├── LICENSE ├── README ├── demos └── elisp │ └── index.html ├── diff-cpp.ss ├── diff-js.ss ├── diff-s.css ├── diff-scheme.ss ├── diff.ss ├── nav-div.js ├── parse-cpp.ss ├── parse-js.ss ├── parse-scheme.ss ├── parsec.ss └── utils.ss /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | * How to build and use 2 | 3 | yDiff is implemented in Scheme. The Scheme implementation I'm using is Racket. 4 | You can find it from http://racket-lang.org. 5 | 6 | yDiff supports multiple languages but currently it is not cleanly modularized 7 | for different languages, and there is no Unix command line interface. In order 8 | to use it, you need to load the 'diff-.ss' files in the Racket repl before 9 | invoking the diff- functions. For example: 10 | 11 | (load "diff-scheme.ss") 12 | (diff- "file1.ss" "file2.ss") 13 | 14 | 15 | * Contact 16 | 17 | If you have suggestions, please contact Yin Wang (yinwang0@gmail.com). 18 | 19 | 20 | * LICENSE 21 | 22 | 23 | Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 24 | 25 | This program is free software: you can redistribute it and/or modify 26 | it under the terms of the GNU General Public License as published by 27 | the Free Software Foundation, either version 3 of the License, or 28 | (at your option) any later version. 29 | 30 | This program is distributed in the hope that it will be useful, 31 | but WITHOUT ANY WARRANTY; without even the implied warranty of 32 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 33 | GNU General Public License for more details. 34 | 35 | You should have received a copy of the GNU General Public License 36 | along with this program. If not, see . 37 | 38 | -------------------------------------------------------------------------------- /diff-cpp.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as published by 6 | ;; the Free Software Foundation, either version 3 of the License, or 7 | ;; (at your option) any later version. 8 | 9 | ;; This program is distributed in the hope that it will be useful, 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | ;; GNU General Public License for more details. 13 | 14 | ;; You should have received a copy of the GNU General Public License 15 | ;; along with this program. If not, see . 16 | 17 | 18 | 19 | 20 | (load "parse-cpp.ss") 21 | (load "diff.ss") 22 | 23 | 24 | ;------------------------------------------------------------- 25 | ; settings 26 | ;------------------------------------------------------------- 27 | 28 | (define *move-ratio* 0) 29 | (define *move-size* 7) 30 | (define *move-depth* 1000) 31 | (define *move-iteration* 1000) 32 | (define *min-frame-size* 5) 33 | (define *min-frame-depth* 10000) 34 | (define *max-string-len* 200) 35 | 36 | 37 | 38 | ;------------------------------------------------------------- 39 | ; parameters for the scanner 40 | ;------------------------------------------------------------- 41 | 42 | (define *keywords* '()) 43 | (define *keyword-exchange* '()) 44 | (define *defs* '()) 45 | 46 | 47 | 48 | ;------------------------------------------------------------- 49 | ; redefinitions 50 | ;------------------------------------------------------------- 51 | 52 | (define get-property 53 | (lambda (e type) 54 | (cond 55 | [(not (Expr? e)) #f] 56 | [else 57 | (let ([matches (filter (lambda (x) (and (Expr? x) 58 | (eq? (Expr-type x) type))) 59 | (Expr-elts e))]) 60 | (cond 61 | [(null? matches) #f] 62 | [else (car matches)]))]))) 63 | 64 | 65 | (define same-def? 66 | (lambda (e1 e2) 67 | (cond 68 | [(and (Expr? e1) (Expr? e2) 69 | (or (and (eq? (Expr-type e1) 'function) 70 | (eq? (Expr-type e2) 'function)) 71 | (and (eq? (Expr-type e1) 'class) 72 | (eq? (Expr-type e2) 'class)))) 73 | (let ([name1 (get-property (get-property e1 'signature) 'name)] 74 | [name2 (get-property (get-property e2 'signature) 'name)]) 75 | (and name1 name2 (node-equal? name1 name2)))] 76 | [else #f]))) 77 | 78 | 79 | ; (same-def? (Token "foo" 0 1) (Token "foo" 0 1)) 80 | 81 | 82 | ;; (same-def? 83 | ;; (Expr 'function (list (Expr 'name (list "foo") 0 4)) 0 10) 84 | ;; (Expr 'function (list (Expr 'name (list "foo") 0 4)) 0 10)) 85 | 86 | ;; (same-def? 87 | ;; (car (parse1 $statement 88 | ;; (read-file "t1.cc") 89 | ;; )) 90 | ;; (car (parse1 $statement 91 | ;; (read-file "t2.cc") 92 | ;; ))) 93 | 94 | 95 | 96 | ;; (node-equal? 97 | ;; (car (parse1 $expression "LineEditor::LineEditor")) 98 | ;; (car (parse1 $expression "LineEditor::LineEditor"))) 99 | 100 | 101 | ; (node-type (car (parse1 $expression "LineEditor::LineEditor"))) 102 | 103 | 104 | ;; use name similarity to determine whether they are 105 | ;; differnet definitions 106 | (define different-def? 107 | (lambda (e1 e2) 108 | (cond 109 | [(and (Expr? e1) (Expr? e2) 110 | (or (and (eq? (Expr-type e1) 'function) 111 | (eq? (Expr-type e2) 'function)) 112 | (and (eq? (Expr-type e1) 'class) 113 | (eq? (Expr-type e2) 'class)))) 114 | (let ([name1 (get-property (get-property e1 'signature) 'name)] 115 | [name2 (get-property (get-property e2 'signature) 'name)]) 116 | (cond 117 | [(and name1 name2) 118 | (not (equal? name1 name2)) 119 | (letv ([(m c) (diff-node name1 name2 0 #t)]) 120 | (> c (* 0 (+ (node-size name1) 121 | (node-size name2)))))] 122 | [else #f]))] 123 | [else #f]))) 124 | 125 | 126 | 127 | ;; (define language-specific-include? 128 | ;; (lambda (e) 129 | ;; (and (Expr? e) 130 | ;; (memq (Expr-type e) 131 | ;; '( 132 | ;; signature 133 | ;; name 134 | ;; macro-definition 135 | ;; if-statement 136 | ;; switch-statement 137 | ;; do-while-statement 138 | ;; while-statement 139 | ;; for-statement 140 | ;; for-in-statement 141 | ;; labelled-statement 142 | ;; try-statement 143 | ;; namespace-definition 144 | ;; using-namespace 145 | ;; class-definition 146 | ;; function-definition 147 | ;; parameters 148 | ;; initializer 149 | ;; function-declaration 150 | ;; variable-definition 151 | ;; enum-declaration 152 | ;; expression-statement 153 | ;; extended-assembly 154 | ;; inline-assembly 155 | ;; ))))) 156 | 157 | 158 | 159 | ;; (define language-specific-similar? 160 | ;; (lambda (e1 e2 c) 161 | ;; (let* ([size1 (node-size e1)] 162 | ;; [size2 (node-size e2)] 163 | ;; [total (+ size1 size2)]) 164 | ;; (cond 165 | ;; [(and (Expr? e1) (Expr? e2) 166 | ;; (eq? 'name (Expr-type e1)) 167 | ;; (eq? 'name (Expr-type e2))) 168 | ;; (= c 0)] 169 | ;; [else #f])))) 170 | 171 | 172 | 173 | 174 | ;--------------------------------------------- 175 | (define diff-cpp 176 | (lambda (file1 file2) 177 | (diff file1 file2 parse-cpp))) 178 | 179 | 180 | 181 | ;--------------------------------------------- 182 | ; (diff-cpp "simulator-mips.cc" "simulator-arm.cc") 183 | ; (diff-cpp "tests/d8-3404.cc" "tests/d8-8424.cc") 184 | 185 | -------------------------------------------------------------------------------- /diff-js.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as published by 6 | ;; the Free Software Foundation, either version 3 of the License, or 7 | ;; (at your option) any later version. 8 | 9 | ;; This program is distributed in the hope that it will be useful, 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | ;; GNU General Public License for more details. 13 | 14 | ;; You should have received a copy of the GNU General Public License 15 | ;; along with this program. If not, see . 16 | 17 | 18 | 19 | (load "parse-js.ss") 20 | (load "diff.ss") 21 | 22 | 23 | ;------------------------------------------------------------- 24 | ; settings 25 | ;------------------------------------------------------------- 26 | 27 | (define *move-ratio* 0) 28 | (define *move-size* 3) 29 | (define *move-depth* 1000) 30 | (define *move-iteration* 1000) 31 | (define *min-frame-size* 3) 32 | (define *min-frame-depth* 10000) 33 | (define *max-string-len* 200) 34 | 35 | 36 | (define *keywords* '()) 37 | (define *keyword-exchange* '()) 38 | (define *defs* '()) 39 | 40 | 41 | 42 | ;--------------------------------------------- 43 | (define diff-js 44 | (lambda (file1 file2) 45 | (diff file1 file2 parse-js))) 46 | 47 | ; (diff-js "tests/nav.js" "tests/nav-div.js") 48 | 49 | -------------------------------------------------------------------------------- /diff-s.css: -------------------------------------------------------------------------------- 1 | /* yDiff - a language-aware tool for comparing programs */ 2 | /* Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) */ 3 | 4 | 5 | /* This program is free software: you can redistribute it and/or modify */ 6 | /* it under the terms of the GNU General Public License as published by */ 7 | /* the Free Software Foundation, either version 3 of the License, or */ 8 | /* (at your option) any later version. */ 9 | 10 | /* This program is distributed in the hope that it will be useful, */ 11 | /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ 12 | /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ 13 | /* GNU General Public License for more details. */ 14 | 15 | /* You should have received a copy of the GNU General Public License */ 16 | /* along with this program. If not, see . */ 17 | 18 | 19 | 20 | .deletion { 21 | border: solid 1px #CC929A; 22 | /* border: solid 1px #E6A4AE; */ 23 | background-color: LightPink; 24 | } 25 | 26 | .insertion { 27 | border: solid 1px #73BE73; 28 | /* border: solid 1px #82D682; */ 29 | background-color: LightGreen; 30 | } 31 | 32 | .change { 33 | border: solid 1px #8AADB8; 34 | /* border: solid 1px #9CC2CF; */ 35 | background-color: LightBlue; 36 | cursor: pointer; 37 | } 38 | 39 | .move { 40 | border: solid 1px LightPink; 41 | /* border: solid 1px #BEBEBE; */ 42 | cursor: pointer; 43 | } 44 | 45 | .move-change { 46 | border: solid 1px LightPink; 47 | background-color: LightBlue; 48 | /* border: solid 1px #BEBEBE; */ 49 | cursor: pointer; 50 | } 51 | 52 | .unchanged { 53 | border: solid 1px #A9A9A9; 54 | /* border: solid 1px #BEBEBE; */ 55 | cursor: pointer; 56 | } 57 | 58 | span.lineno { 59 | color: lightgrey; 60 | -webkit-user-select: none; 61 | -moz-user-select: none; 62 | } 63 | 64 | span.keyword { 65 | /* color: #007070; */ 66 | font-weight: 700; 67 | } 68 | 69 | div.line { 70 | } 71 | 72 | div.src { 73 | width:48%; 74 | height:98%; 75 | overflow:scroll; 76 | border:1px solid; 77 | float:left; 78 | padding:0.5%; 79 | } 80 | 81 | 82 | div.stats { 83 | border: solid 1px grey; 84 | z-index: 1000; 85 | width: 80%; 86 | padding-left: 5%; 87 | } 88 | 89 | pre.stats { 90 | color: grey; 91 | -webkit-user-select: none; 92 | -moz-user-select: none; 93 | } 94 | 95 | pre { 96 | line-height: 200%; 97 | } 98 | 99 | p { 100 | line-height: 200%; 101 | } 102 | -------------------------------------------------------------------------------- /diff-scheme.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as published by 6 | ;; the Free Software Foundation, either version 3 of the License, or 7 | ;; (at your option) any later version. 8 | 9 | ;; This program is distributed in the hope that it will be useful, 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | ;; GNU General Public License for more details. 13 | 14 | ;; You should have received a copy of the GNU General Public License 15 | ;; along with this program. If not, see . 16 | 17 | 18 | 19 | (load "parse-scheme.ss") 20 | (load "diff.ss") 21 | 22 | 23 | (define *move-ratio* 0) 24 | (define *move-size* 3) 25 | (define *move-depth* 1000) 26 | (define *move-iteration* 1000) 27 | (define *min-frame-depth* 10000) 28 | (define *min-frame-size* 3) 29 | (define *max-string-len* 200) 30 | 31 | 32 | (define *keywords* 33 | '(define defun lambda cond if else let let* let-values let*-values 34 | while for define-syntax syntax-rules)) 35 | 36 | (define *keyword-exchange* '()) 37 | 38 | (define *defs* 39 | '(define defun define-syntax)) 40 | 41 | 42 | 43 | ;----------------------------------------- 44 | (define diff-scheme 45 | (lambda (file1 file2) 46 | (diff file1 file2 parse-scheme))) 47 | 48 | 49 | 50 | ; (diff-scheme "diff-js.ss" "diff-cpp.ss") 51 | 52 | -------------------------------------------------------------------------------- /diff.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | 5 | ;; This program is free software: you can redistribute it and/or modify 6 | ;; it under the terms of the GNU General Public License as published by 7 | ;; the Free Software Foundation, either version 3 of the License, or 8 | ;; (at your option) any later version. 9 | 10 | ;; This program is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;; GNU General Public License for more details. 14 | 15 | ;; You should have received a copy of the GNU General Public License 16 | ;; along with this program. If not, see . 17 | 18 | 19 | 20 | (load "utils.ss") 21 | 22 | 23 | 24 | ;------------------------------------------------------------- 25 | ; parameters 26 | ;------------------------------------------------------------- 27 | 28 | ;; The ratio of cost/size that we consider two nodes to be 29 | ;; "similar", so as to perform a heuristic move (that will 30 | ;; cut running time by a lot.) But this number should be 31 | ;; small enough otherwise everything will be considered to 32 | ;; be moves! Set to a small number for accuracy. 33 | (define *move-ratio* 0) 34 | 35 | 36 | ;; The minimum size of a node to be considered for moves. 37 | ;; Shouldn't be too small, otherwise small deletec names 38 | ;; will appear in a very distant place! This number should 39 | ;; be larger than *min-frame-size* otherwise it will not be 40 | ;; effective because substructural diff will do it. 41 | (define *move-size* 5) 42 | 43 | 44 | ;; The depth limit for detecting substructural moves. If 45 | ;; this is set, we will ignore nodes that are deeper than 46 | ;; this number. The minimum is 7 to be useful. 47 | (define *move-depth* 5) 48 | 49 | ;; How many iterations do we go for moves? This parameter 50 | ;; should be large enough so that we can discover enough 51 | ;; moves. The algorithm is guaranteed to terminate, but it 52 | ;; should be be set to some small number if we found that it 53 | ;; takes too much time to terminate. This value should be 54 | ;; larger than 7 in order to work for normal programs. 55 | (define *move-iteration* 1000) 56 | 57 | 58 | ;; How large must a node be considered as container for 59 | ;; another node? If this is set to a big number, we will 60 | ;; ignore nodes that are smaller than the number. This 61 | ;; number shouldn't be too small, otherwise too many 62 | ;; spurious moves will be detected! For example, a deleted 63 | ;; "int" could be moved to a very far place! Setting it to a 64 | ;; bigger number also reduces running time (by a great 65 | ;; amount) because less substructural moves are considered. 66 | ;; Set it to a larger number will cause loss of 67 | ;; substructural changes, but greatly reduces time to run. 68 | (define *min-frame-size* 3) 69 | 70 | 71 | ;; How deep must the frames be for us to consider them as 72 | ;; moves? This affects only already extracted frames, which 73 | ;; may be considered to be moves to other extracted frames. 74 | ;; Set it large will not necessarily lower accuracy, but 75 | ;; improves performance. 76 | (define *min-frame-depth* 2) 77 | 78 | 79 | ;; How long must a string be in order for us to use 80 | ;; string-dist function, which is costly when used on long 81 | ;; strings but the most accurate method to use. This 82 | ;; parameter affects strings/comments only. We use 83 | ;; string-dist for all Tokens. 84 | (define *max-string-len* 200) 85 | 86 | 87 | ;; only memoize the diff of nodes of size larger than this 88 | ;; number 89 | (define *memo-node-size* 2) 90 | 91 | 92 | 93 | (define *keywords* '()) 94 | (define *keyword-exchange* '()) 95 | (define *defs* '()) 96 | 97 | 98 | 99 | ;------------------------------------------------------------- 100 | ; utilities 101 | ;------------------------------------------------------------- 102 | 103 | (define qs 104 | (lambda (x) 105 | (string-append "'" (number->string x) "'"))) 106 | 107 | 108 | (define line 109 | (lambda (port . s) 110 | (display (string-append (apply string-append s) "\n") port))) 111 | 112 | 113 | 114 | ;------------------------------------------------------------- 115 | ; data types 116 | ;------------------------------------------------------------- 117 | 118 | (struct Change (orig cur cost type) #:transparent) 119 | (struct Tag (tag idx start) #:transparent) 120 | 121 | 122 | (define ins? 123 | (lambda (c) 124 | (not (Change-orig c)))) 125 | 126 | (define del? 127 | (lambda (c) 128 | (not (Change-cur c)))) 129 | 130 | (define mod? 131 | (lambda (c) 132 | (and (Change-orig c) (Change-cur c)))) 133 | 134 | 135 | 136 | ;----------------- utils for creating changes ---------------- 137 | (define total 138 | (lambda (node1 node2) 139 | (let ([size1 (node-size node1)] 140 | [size2 (node-size node2)]) 141 | (values (append (del-node node1) (ins-node node2)) 142 | (+ size1 size2))))) 143 | 144 | (define del-node 145 | (lambda (node) 146 | (let ([size (node-size node)]) 147 | (list (Change node #f size 'del))))) 148 | 149 | (define ins-node 150 | (lambda (node) 151 | (let ([size (node-size node)]) 152 | (list (Change #f node size 'ins))))) 153 | 154 | 155 | 156 | (define disassemble-frame 157 | (lambda (node) 158 | (cond 159 | [(and (Expr? node) (eq? 'frame (Expr-type node))) 160 | (apply append (map disassemble-frame (Expr-elts node)))] 161 | [else (list node)]))) 162 | 163 | 164 | (define disassemble-change 165 | (lambda (change) 166 | (cond 167 | [(ins? change) 168 | (apply append 169 | (map ins-node 170 | (disassemble-frame (Change-cur change))))] 171 | [(del? change) 172 | (apply append 173 | (map del-node 174 | (disassemble-frame (Change-orig change))))] 175 | [else (list change)]))) 176 | 177 | 178 | (define extract-frame 179 | (lambda (node1 node2) 180 | (match node1 181 | [(Expr type1 elts1 start1 end1) 182 | (let ([frame-elts (filter (lambda (x) 183 | (not (eq? x node2))) 184 | elts1)]) 185 | (Expr 'frame frame-elts start1 start1))] 186 | [_ fatal 'extract-frame "I only accept Expr"]))) 187 | 188 | 189 | 190 | (define extract-ins-frame 191 | (lambda (node1 node2) 192 | (let ([frame (extract-frame node1 node2)]) 193 | (cond 194 | [(not frame) '()] 195 | [else 196 | (ins-node frame)])))) 197 | 198 | 199 | 200 | (define extract-del-frame 201 | (lambda (node1 node2) 202 | (let ([frame (extract-frame node1 node2)]) 203 | (cond 204 | [(not frame) '()] 205 | [else 206 | (del-node frame)])))) 207 | 208 | 209 | 210 | ;; (define n1 (Token "ok" 0 1)) 211 | 212 | ;; (define n2 (Expr 'ok (list n1 (Token "bar" 1 2)) 0 2)) 213 | 214 | ;; (map disassemble-change (extract-ins-frame n2 n1)) 215 | 216 | 217 | 218 | 219 | (define ins-node-except 220 | (lambda (node1 node2) 221 | (let ([nodes (map (lambda (x) 222 | (if (not (eq? x node2)) 223 | (ins-node x) 224 | '())) 225 | (Expr-elts node1))]) 226 | (apply append nodes)))) 227 | 228 | 229 | (define del-node-except 230 | (lambda (node1 node2) 231 | (let ([nodes (map (lambda (x) 232 | (if (not (eq? x node2)) 233 | (del-node x) 234 | '())) 235 | (Expr-elts node1))]) 236 | (apply append nodes)))) 237 | 238 | 239 | 240 | (define mod-node 241 | (lambda (node1 node2 cost) 242 | (list (Change node1 node2 cost 'mod)))) 243 | 244 | (define mov-node 245 | (lambda (node1 node2 cost) 246 | (list (Change node1 node2 cost 'mov)))) 247 | 248 | (define mod->mov 249 | (lambda (c) 250 | (match c 251 | [(Change node1 node2 cost 'mod) 252 | (Change node1 node2 cost 'mov)] 253 | [other other]))) 254 | 255 | 256 | 257 | 258 | ;------------------ operations on nodes --------------------- 259 | 260 | (define node-equal? 261 | (lambda (node1 node2) 262 | (cond 263 | [(and (null? node1) (null? node2)) #t] 264 | [(and (Str? node1) (Str? node2)) 265 | (and (equal? (Str-s node1) (Str-s node2)))] 266 | [(and (Comment? node1) (Comment? node2)) 267 | (and (equal? (Comment-text node1) (Comment-text node2)))] 268 | [(and (Char? node1) (Char? node2)) 269 | (and (equal? (Char-c node1) (Char-c node2)))] 270 | [(and (Token? node1) (Token? node2)) 271 | (and (equal? (Token-text node1) 272 | (Token-text node2)))] 273 | [(and (Expr? node1) (Expr? node2)) 274 | (and (eq? (Expr-type node1) 275 | (Expr-type node2)) 276 | (node-equal? (Expr-elts node1) 277 | (Expr-elts node2)))] 278 | [(and (pair? node1) (pair? node2)) 279 | (and (node-equal? (car node1) (car node2)) 280 | (node-equal? (cdr node1) (cdr node2)))] 281 | [else #f]))) 282 | 283 | 284 | 285 | (define keyword-exchangeable? 286 | (lambda (k1 k2) 287 | (cond 288 | [(eq? k1 k2) #t] 289 | [(assq k1 *keyword-exchange*) 290 | => (lambda (p) 291 | (cond 292 | [(memq k2 (cdr p)) #t] 293 | [else #f]))] 294 | [else #f]))) 295 | 296 | 297 | 298 | (define keywords-equal? 299 | (lambda (node1 node2) 300 | (and (eq? (Expr-type node1) 301 | (Expr-type node2)) 302 | (not (keywords-differ? node1 node2))))) 303 | 304 | 305 | 306 | (define keywords-differ? 307 | (lambda (exp1 exp2) 308 | (let ([key1 (and (not (null? (Expr-elts exp1))) 309 | (get-symbol (car (Expr-elts exp1))))] 310 | [key2 (and (not (null? (Expr-elts exp2))) 311 | (get-symbol (car (Expr-elts exp2))))]) 312 | (cond 313 | [(and key1 key2 314 | (or (memq key1 *keywords*) 315 | (memq key2 *keywords*)) 316 | (not (keyword-exchangeable? key1 key2))) 317 | #t] 318 | [else #f])))) 319 | 320 | 321 | 322 | (define get-symbol 323 | (lambda (node) 324 | (cond 325 | [(Token? node) 326 | (string->symbol (Token-text node))] 327 | [else #f]))) 328 | 329 | 330 | 331 | (define same-def? 332 | (lambda (e1 e2) 333 | (cond 334 | [(and (Expr? e1) (Expr? e2)) 335 | (let ([elts1 (Expr-elts e1)] 336 | [elts2 (Expr-elts e2)]) 337 | (cond 338 | [(and (> (length elts1) 1) 339 | (> (length elts2) 1) 340 | (memq (get-symbol (car elts1)) *defs*) 341 | (memq (get-symbol (car elts2)) *defs*)) 342 | (eq? (get-symbol (cadr elts1)) 343 | (get-symbol (cadr elts2)))] 344 | [else #f]))] 345 | [else #f]))) 346 | 347 | ;; (same-def? (car (parse-scheme "(define f 1)")) 348 | ;; (car (parse-scheme "(define g 1)"))) 349 | 350 | 351 | 352 | (define different-def? 353 | (lambda (e1 e2) 354 | (cond 355 | [(and (Expr? e1) (Expr? e2)) 356 | (let ([elts1 (Expr-elts e1)] 357 | [elts2 (Expr-elts e2)]) 358 | (cond 359 | [(and (> (length elts1) 1) 360 | (> (length elts2) 1) 361 | (memq (get-symbol (car elts1)) *defs*) 362 | (memq (get-symbol (car elts2)) *defs*)) 363 | (not (eq? (get-symbol (cadr elts1)) 364 | (get-symbol (cadr elts2))))] 365 | [else #f]))] 366 | [else #f]))) 367 | 368 | ;; (different-def? (car (parse-scheme "(define f 1)")) 369 | ;; (car (parse-scheme "(let f 1)"))) 370 | 371 | 372 | 373 | ;; whether two nodes are similar given the cost 374 | (define similar? 375 | (lambda (node1 node2 c) 376 | (<= c (* *move-ratio* (+ (node-size node1) 377 | (node-size node2)))))) 378 | 379 | 380 | (define *node-size-hash* (make-hasheq)) 381 | 382 | (define node-size 383 | (lambda (node) 384 | (define memo 385 | (lambda (v) 386 | (if (> v 1) 387 | (hash-set! *node-size-hash* node v) 388 | (void)) 389 | v)) 390 | (cond 391 | [(pair? node) 392 | (apply + (map node-size node))] 393 | [(or (Token? node) (Str? node) (Char? node)) 1] 394 | [(Expr? node) 395 | (cond 396 | [(hash-has-key? *node-size-hash* node) 397 | (hash-ref *node-size-hash* node)] 398 | [else 399 | (memo (node-size (Expr-elts node)))])] 400 | [else 0]))) 401 | 402 | 403 | (define node-depth 404 | (lambda (node) 405 | (cond 406 | [(null? node) 0] 407 | [(pair? node) 408 | (apply max (map node-depth node))] 409 | [(Expr? node) 410 | (add1 (node-depth (Expr-elts node)))] 411 | [else 0]))) 412 | 413 | 414 | ; (node-depth (parse-scheme "(lambda (x (x (y)) (y)) x)")) 415 | 416 | ;; (same-def? (parse-scheme "(define f (x 1))") 417 | ;; (parse-scheme "(define f 2")) 418 | 419 | 420 | 421 | (define uid 422 | (let ([count 1] 423 | [table (box '())]) 424 | (lambda (node) 425 | (let ([p (assq node (unbox table))]) 426 | (cond 427 | [(not p) 428 | (let ([id count]) 429 | (set! count (add1 count)) 430 | (set-box! table (cons `(,node . ,id) (unbox table))) 431 | id)] 432 | [else 433 | (cdr p)]))))) 434 | 435 | 436 | 437 | (define similarity 438 | (lambda (change) 439 | (let ([total (+ (node-size (Change-orig change)) 440 | (node-size (Change-cur change)))]) 441 | (cond 442 | [(or (= 0 total) (= 0 (Change-cost change))) 443 | "100%"] 444 | [else 445 | (string-append 446 | (real->decimal-string 447 | (* 100 (- 1.0 (/ (Change-cost change) total))) 1) 448 | "%")])))) 449 | 450 | 451 | 452 | ;------------------------------------------------------------- 453 | ; diff stuff 454 | ;------------------------------------------------------------- 455 | 456 | ; 2-D memoization table 457 | (define make-table 458 | (lambda (dim1 dim2) 459 | (let ([vec (make-vector (add1 dim1))]) 460 | (let loop ([n 0]) 461 | (cond 462 | [(= n (vector-length vec)) vec] 463 | [else 464 | (vector-set! vec n (make-vector (add1 dim2) #f)) 465 | (loop (add1 n))]))))) 466 | 467 | 468 | (define table-ref 469 | (lambda (t x y) 470 | (let ([row (vector-ref t x)]) 471 | (vector-ref row y)))) 472 | 473 | 474 | (define table-set! 475 | (lambda (t x y v) 476 | (let ([row (vector-ref t x)]) 477 | (vector-set! row y v)))) 478 | 479 | 480 | 481 | ;---------------- string distance function ----------------- 482 | 483 | (define string-dist 484 | (lambda (s1 s2) 485 | (let* ([len1 (string-length s1)] 486 | [len2 (string-length s2)] 487 | [t (make-table len1 len2)] 488 | [char-dist (dist1 t s1 0 s2 0)]) 489 | (cond 490 | [(= 0 (+ len1 len2)) 0] 491 | [else 492 | (/ (* 2.0 char-dist) (+ len1 len2))])))) 493 | 494 | 495 | 496 | (define dist1 497 | (lambda (table s1 start1 s2 start2) 498 | (define memo 499 | (lambda (value) 500 | (table-set! table start1 start2 value) 501 | value)) 502 | (cond 503 | [(table-ref table start1 start2) 504 | => (lambda (cached) cached)] 505 | [(= start1 (string-length s1)) 506 | (memo (- (string-length s2) start2))] 507 | [(= start2 (string-length s2)) 508 | (memo (- (string-length s1) start1))] 509 | [else 510 | (let* ([c1 (string-ref s1 start1)] 511 | [c2 (string-ref s2 start2)] 512 | [d0 (cond 513 | [(char=? c1 c2) 0] 514 | [(char=? (char-downcase c1) 515 | (char-downcase c2)) 1] 516 | [else 2])] 517 | [d1 (+ d0 (dist1 table s1 (add1 start1) s2 (add1 start2)))] 518 | [d2 (+ 1 (dist1 table s1 (add1 start1) s2 start2))] 519 | [d3 (+ 1 (dist1 table s1 start1 s2 (add1 start2)))]) 520 | (memo (min d1 d2 d3)))]))) 521 | 522 | 523 | 524 | (define diff-string 525 | (lambda (string1 string2 node1 node2) 526 | (cond 527 | [(or (> (string-length string1) *max-string-len*) 528 | (> (string-length string2) *max-string-len*)) 529 | (cond 530 | [(equal? string1 string2) 531 | (values (mod-node node1 node2 0) 0)] 532 | [else 533 | (total node1 node2)])] 534 | [else 535 | (let ([cost (string-dist string1 string2)]) 536 | (values (mod-node node1 node2 cost) cost))]))) 537 | 538 | 539 | 540 | 541 | ;--------------------- main node diff function ---------------------- 542 | (define diff-node 543 | (lambda (node1 node2 depth move?) 544 | 545 | (define memo 546 | (lambda (v1 v2) 547 | (if (and (> (node-size node1) *memo-node-size*) 548 | (> (node-size node2) *memo-node-size*)) 549 | (hash-put! *diff-hash* node1 node2 (cons v1 v2)) 550 | (void)) 551 | (values v1 v2))) 552 | 553 | (define trysub 554 | (lambda (changes cost) 555 | (cond 556 | [(or (not move?) 557 | (similar? node1 node2 cost)) 558 | (memo changes cost)] 559 | [else 560 | (letv ([(m c) (diff-sub node1 node2 depth move?)]) 561 | (cond 562 | [(not m) 563 | (memo changes cost)] 564 | [else 565 | (memo m c)]))]))) 566 | 567 | (diff-progress 1) 568 | 569 | (cond 570 | [(hash-get *diff-hash* node1 node2) 571 | => (lambda (cached) 572 | (values (car cached) (cdr cached)))] 573 | [(and (Char? node1) (Char? node2)) 574 | (diff-string (char->string (Char-c node1)) 575 | (char->string (Char-c node2)) 576 | node1 node2)] 577 | [(and (Str? node1) (Str? node2)) 578 | (diff-string (Str-s node1) (Str-s node2) node1 node2)] 579 | [(and (Comment? node1) (Comment? node2)) 580 | (diff-string (Comment-text node1) (Comment-text node2) node1 node2)] 581 | [(and (Token? node1) (Token? node2)) 582 | (diff-string (Token-text node1) (Token-text node2) node1 node2)] 583 | [(and (Expr? node1) (Expr? node2) 584 | (keywords-equal? node1 node2)) 585 | (letv ([t (make-hasheq)] 586 | [(m c) (diff-list t (Expr-elts node1) (Expr-elts node2) 587 | depth move?)]) 588 | (trysub m c))] 589 | [(and (pair? node1) (not (pair? node2))) 590 | (let ([t (make-hasheq)]) 591 | (diff-list t node1 (list node2) depth move?))] 592 | [(and (not (pair? node1)) (pair? node2)) 593 | (let ([t (make-hasheq)]) 594 | (diff-list t (list node1) node2 depth move?))] 595 | [(and (pair? node1) (pair? node2)) 596 | (let ([t (make-hasheq)]) 597 | (diff-list t node1 node2 depth move?))] 598 | [else 599 | (letv ([(m c) (total node1 node2)]) 600 | (trysub m c))]))) 601 | 602 | 603 | 604 | 605 | 606 | 607 | ;; global 2D hash for storing known diffs 608 | (define *diff-hash* (make-hasheq)) 609 | 610 | (define diff-list 611 | (lambda (table ls1 ls2 depth move?) 612 | 613 | (define memo 614 | (lambda (v1 v2) 615 | (hash-put! table ls1 ls2 (cons v1 v2)) 616 | (values v1 v2))) 617 | 618 | (define guess 619 | (lambda (ls1 ls2) 620 | (letv ([(m0 c0) (diff-node (car ls1) (car ls2) depth move?)] 621 | [(m1 c1) (diff-list table (cdr ls1) (cdr ls2) depth move?)] 622 | [(cost1) (+ c0 c1)]) 623 | (cond 624 | [(or (same-def? (car ls1) (car ls2)) 625 | (and (not (different-def? (car ls1) (car ls2))) 626 | (similar? (car ls1) (car ls2) c0))) 627 | (memo (append m0 m1) cost1)] 628 | [else 629 | (letv ([(m2 c2) (diff-list table (cdr ls1) ls2 depth move?)] 630 | [(m3 c3) (diff-list table ls1 (cdr ls2) depth move?)] 631 | [cost2 (+ c2 (node-size (car ls1)))] 632 | [cost3 (+ c3 (node-size (car ls2)))]) 633 | (cond 634 | ;; They can't be same-def now. 635 | ;; don't move them. It is quite confusing 636 | 637 | ;; [(and (not (different-def? (car ls1) (car ls2))) 638 | ;; (<= cost1 cost2) (<= cost1 cost3)) 639 | ;; (memo (append m0 m1) cost1)] 640 | [(<= cost2 cost3) 641 | (memo (append (del-node (car ls1)) m2) cost2)] 642 | [else 643 | (memo (append (ins-node (car ls2)) m3) cost3)]))])))) 644 | 645 | (cond 646 | [(hash-get table ls1 ls2) 647 | => (lambda (cached) 648 | (values (car cached) (cdr cached)))] 649 | [(and (null? ls1) (null? ls2)) 650 | (values '() 0)] 651 | [(null? ls1) 652 | (let ([changes (apply append (map ins-node ls2))]) 653 | (values changes (node-size ls2)))] 654 | [(null? ls2) 655 | (let ([changes (apply append (map del-node ls1))]) 656 | (values changes (node-size ls1)))] 657 | [else 658 | (guess ls1 ls2)]))) 659 | 660 | 661 | 662 | 663 | 664 | 665 | (define diff-sub 666 | (lambda (node1 node2 depth move?) 667 | (cond 668 | [(or (>= depth *move-depth*) 669 | (< (node-size node1) *min-frame-size*) 670 | (< (node-size node2) *min-frame-size*)) 671 | (values #f #f)] 672 | [(and (Expr? node1) (Expr? node2)) 673 | (cond 674 | [(< (node-size node1) (node-size node2)) 675 | (let loop ([elts2 (Expr-elts node2)]) 676 | (cond 677 | [(null? elts2) (values #f #f)] 678 | [else 679 | (letv ([(m0 c0) (diff-node node1 (car elts2) (add1 depth) move?)]) 680 | (cond 681 | [(or (same-def? node1 (car elts2)) 682 | (similar? node1 (car elts2) c0)) 683 | (let ([frame (extract-ins-frame node2 (car elts2))] 684 | [frame-size (- (node-size node2) (node-size (car elts2)))]) 685 | (values (append m0 frame) c0))] 686 | [else 687 | (loop (cdr elts2))]))]))] 688 | [(> (node-size node1) (node-size node2)) 689 | (let loop ([elts1 (Expr-elts node1)]) 690 | (cond 691 | [(null? elts1) (values #f #f)] 692 | [else 693 | (letv ([(m0 c0) (diff-node (car elts1) node2 (add1 depth) move?)]) 694 | (cond 695 | [(or (same-def? (car elts1) node2) 696 | (similar? (car elts1) node2 c0)) 697 | (let ([frame (extract-del-frame node1 (car elts1))] 698 | [frame-size (- (node-size node1) (node-size (car elts1)))]) 699 | (values (append m0 frame) c0))] 700 | [else 701 | (loop (cdr elts1))]))]))] 702 | [else ; equal size 703 | (values #f #f)])] 704 | [else (values #f #f)]))) 705 | 706 | 707 | 708 | 709 | ;------------------------------------------------------------- 710 | ; finding moves 711 | ;------------------------------------------------------------- 712 | 713 | (define big-node? 714 | (lambda (node) 715 | (>= (node-size node) *move-size*))) 716 | 717 | 718 | 719 | (define shallow-frame? 720 | (lambda (node) 721 | (and (eq? 'frame (node-type node)) 722 | (< (node-depth node) *min-frame-depth*)))) 723 | 724 | 725 | (define big-change? 726 | (lambda (c) 727 | (cond 728 | [(ins? c) 729 | (big-node? (Change-cur c))] 730 | [(del? c) 731 | (big-node? (Change-orig c))] 732 | [(mod? c) 733 | (or (big-node? (Change-orig c)) 734 | (big-node? (Change-cur c)))]))) 735 | 736 | 737 | (define shallow-change? 738 | (lambda (c) 739 | (cond 740 | [(ins? c) 741 | (shallow-frame? (Change-cur c))] 742 | [(del? c) 743 | (shallow-frame? (Change-orig c))] 744 | [(mod? c) 745 | (or (shallow-frame? (Change-orig c)) 746 | (shallow-frame? (Change-cur c)))]))) 747 | 748 | 749 | (define large-change? 750 | (predand big-change? (negate shallow-frame?))) 751 | 752 | 753 | 754 | ; ((predand number? (lambda (x) (> x 1))) 0) 755 | ; ((predor number? (lambda (x) (> x 1))) 5) 756 | 757 | 758 | (define node-sort-fn 759 | (lambda (x y) 760 | (< (get-start x) (get-start y)))) 761 | 762 | 763 | ;; iterate the dynamic programming 764 | (define closure 765 | (lambda (changes) 766 | (set! *diff-hash* (make-hasheq)) 767 | (let loop ([changes changes] [moved '()] [count 1]) 768 | (cond 769 | [(> count *move-iteration*) 770 | (let ([all-changes (append changes moved)]) 771 | (apply append (map disassemble-change all-changes)))] 772 | [else 773 | (printf "~n[closure loop #~a] " count) 774 | (let* ([del-changes (filter (predand del? 775 | (predor (lambda (c) 776 | (language-specific-include? 777 | (Change-orig c))) 778 | large-change?)) 779 | changes)] 780 | [add-changes (filter (predand ins? 781 | (predor (lambda (c) 782 | (language-specific-include? 783 | (Change-cur c))) 784 | large-change?)) 785 | changes)] 786 | [old-moves (filter mod? changes)] 787 | [unincluded (set- changes (append old-moves 788 | del-changes 789 | add-changes))] 790 | [dels (map Change-orig del-changes)] 791 | [adds (map Change-cur add-changes)] 792 | [sorted-dels (sort dels node-sort-fn)] 793 | [sorted-adds (sort adds node-sort-fn)]) 794 | 795 | (letv ([t (make-hasheq)] 796 | [(m c) (diff-list t sorted-dels sorted-adds 0 #t)] 797 | [new-moves (map mod->mov (filter mod? m))]) 798 | (printf "~n~a new moves found" (length new-moves)) 799 | (cond 800 | [(null? new-moves) 801 | (let ([all-changes (append m old-moves unincluded moved)]) 802 | (apply append (map disassemble-change all-changes)))] 803 | [else 804 | (let ([new-changes (filter (negate mod?) m)]) 805 | (loop new-changes 806 | (append new-moves old-moves unincluded moved) 807 | (add1 count)))])))])))) 808 | 809 | 810 | (define language-specific-similar? 811 | (lambda (e1 e2 c) 812 | #f)) 813 | 814 | (define language-specific-include? 815 | (lambda (e) 816 | #f)) 817 | 818 | 819 | 820 | 821 | ;------------------------------------------------------------- 822 | ; HTML generation 823 | ;------------------------------------------------------------- 824 | 825 | (define change-tags 826 | (lambda (changes side) 827 | (let loop ([cs changes] [tags '()]) 828 | (cond 829 | [(null? cs) tags] 830 | [else 831 | (let ([key (if (eq? side 'left) 832 | (Change-orig (car cs)) 833 | (Change-cur (car cs)))]) 834 | (cond 835 | [(or (not key) 836 | (= (get-start key) (get-end key))) 837 | (loop (cdr cs) tags)] 838 | [(and (Change-orig (car cs)) (Change-cur (car cs))) 839 | (let ([startTag (Tag (link-start (car cs) side) 840 | (get-start key) -1)] 841 | [endTag (Tag "" (get-end key) (get-start key))]) 842 | (loop (cdr cs) (cons endTag (cons startTag tags))))] 843 | [else 844 | (let ([startTag (Tag (span-start (car cs) side) 845 | (get-start key) -1)] 846 | [endTag (Tag "" (get-end key) (get-start key))]) 847 | (loop (cdr cs) (cons endTag (cons startTag tags))))]))])))) 848 | 849 | 850 | (define apply-tags 851 | (lambda (s tags) 852 | (let ([tags (sort tags tag-sort-fn)]) 853 | (let loop ([tags tags] [curr 0] [out '()]) 854 | (cond 855 | [(null? tags) 856 | (cond 857 | [(< curr (string-length s)) 858 | (loop tags (add1 curr) (cons (escape (string-ref s curr)) out))] 859 | [else 860 | (apply string-append (reverse out))])] 861 | [else 862 | (cond 863 | [(< curr (Tag-idx (car tags))) 864 | (loop tags (add1 curr) (cons (escape (string-ref s curr)) out))] 865 | [else 866 | (loop (cdr tags) curr (cons (Tag-tag (car tags)) out))])]))))) 867 | 868 | 869 | 870 | (define link-start 871 | (lambda (change side) 872 | (let ([cls (cond 873 | [(and (eq? (Change-type change) 'mov) 874 | (> (Change-cost change) 0)) 875 | "move-change"] 876 | [(eq? (Change-type change) 'mov) "move"] 877 | [(> (Change-cost change) 0) "change"] 878 | [else "unchanged"])] 879 | [text (string-append "(similarity " (similarity change) ")")] 880 | [me (if (eq? side 'left) 881 | (Change-orig change) 882 | (Change-cur change))] 883 | [other (if (eq? side 'left) 884 | (Change-cur change) 885 | (Change-orig change))]) 886 | (string-append 887 | "")))) 891 | 892 | 893 | 894 | (define span-start 895 | (lambda (change side) 896 | (let ([cls (if (Change-orig change) "deletion" "insertion")] 897 | [text (if (Change-orig change) "deleted" "inserted")]) 898 | (string-append "")))) 899 | 900 | 901 | 902 | (define tag-sort-fn 903 | (lambda (t1 t2) 904 | (cond 905 | [(= (Tag-idx t1) (Tag-idx t2)) 906 | (> (Tag-start t1) (Tag-start t2))] 907 | [else 908 | (< (Tag-idx t1) (Tag-idx t2))]))) 909 | 910 | 911 | (define *escape-table* 912 | '((#\" . """) 913 | (#\' . "'") 914 | (#\< . "<") 915 | (#\> . ">") 916 | )) 917 | 918 | 919 | (define escape 920 | (lambda (c) 921 | (cond 922 | [(assq c *escape-table*) => cdr] 923 | [else (char->string c)]))) 924 | 925 | 926 | 927 | 928 | ; getting the base name of a path/file name 929 | ; (base-name "mk/mk-c.scm") => mk-c 930 | (define base-name 931 | (lambda (fn) 932 | (let loop ([i (- (string-length fn) 1)] 933 | [start -1] 934 | [end (- (string-length fn) 1)]) 935 | (cond 936 | [(= i 0) 937 | (substring fn i end)] 938 | [(eq? (string-ref fn i) #\.) 939 | (loop (sub1 i) start i)] 940 | [(eq? (string-ref fn i) #\/) 941 | (substring fn (add1 i) end)] 942 | [else 943 | (loop (sub1 i) start end)])))) 944 | 945 | 946 | 947 | (define html-header 948 | (lambda (port) 949 | (line port "") 950 | (line port "") 951 | (line port "") 953 | (line port "") 955 | (line port "") 957 | (line port "") 958 | (line port ""))) 959 | 960 | (define html-footer 961 | (lambda (port) 962 | (line port "") 963 | (line port ""))) 964 | 965 | 966 | (define write-html 967 | (lambda (port text side) 968 | (line port (string-append "
")) 969 | (line port "
")
 970 |     (if (string=? side "left")
 971 |         (line port "")
 972 |         (line port ""))
 973 |     (line port text)
 974 |     (line port "
") 975 | (line port "
"))) 976 | 977 | 978 | ;; progress bar :-) 979 | (define diff-progress 980 | (new-progress 10000)) 981 | 982 | (define cleanup 983 | (lambda () 984 | (set! *node-size-hash* (make-hasheq)) 985 | (set! *diff-hash* (make-hasheq)))) 986 | 987 | 988 | ;; main command 989 | (define diff 990 | (lambda (file1 file2 parse) 991 | (cleanup) 992 | (letv ([s1 (read-file file1)] 993 | [s2 (read-file file2)] 994 | [node1 (parse s1)] 995 | [node2 (parse s2)] 996 | [_ (diff-progress "\nDone parsing")] 997 | [(changes cost) (diff-node node1 node2 0 #f)] 998 | [_ (diff-progress "\nDone diffing")] 999 | [changes (closure changes)] 1000 | [_ (diff-progress "\nDone moving")] 1001 | [_ (set! *diff-hash* (make-hasheq))] 1002 | [ctags1 (change-tags changes 'left)] 1003 | [ctags2 (change-tags changes 'right)] 1004 | [tagged1 (apply-tags s1 ctags1)] 1005 | [tagged2 (apply-tags s2 ctags2)]) 1006 | (let* ([frame-file (string-append (base-name file1) "-" 1007 | (base-name file2) ".html")] 1008 | [port (open-output-file frame-file 1009 | #:mode 'text 1010 | #:exists 'replace)]) 1011 | (html-header port) 1012 | (write-html port tagged1 "left") 1013 | (write-html port tagged2 "right") 1014 | (html-footer port) 1015 | (close-output-port port) 1016 | (cleanup))))) 1017 | 1018 | 1019 | ; (current-directory "d:/prog/schdiff") 1020 | ; (diff "t2.ss" "diff.ss") 1021 | 1022 | ; (diff "search.ss" "diff.ss") 1023 | ; (diff "mk.scm" "mk-c.scm") 1024 | 1025 | ; (current-directory "d:/home/.emacs.d") 1026 | ; (diff "paredit20.el" "paredit22.el") 1027 | 1028 | -------------------------------------------------------------------------------- /nav-div.js: -------------------------------------------------------------------------------- 1 | // yDiff - a language-aware tool for comparing programs 2 | // Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | 5 | // This program is free software: you can redistribute it and/or modify 6 | // it under the terms of the GNU General Public License as published by 7 | // the Free Software Foundation, either version 3 of the License, or 8 | // (at your option) any later version. 9 | 10 | // This program is distributed in the hope that it will be useful, 11 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | // GNU General Public License for more details. 14 | 15 | // You should have received a copy of the GNU General Public License 16 | // along with this program. If not, see . 17 | 18 | 19 | 20 | /////////////////////// debug flag //////////////////////// 21 | var debug = false; 22 | 23 | 24 | /////////////////////// adjustable parameters ////////////////// 25 | var minStep = 10; 26 | var nSteps = 30; 27 | var stepInterval = 10; 28 | var blockRange = 5; // how far consider one page blocked 29 | var nodeHLColor = 'yellow'; 30 | var lineHLColor = '#FFFF66'; 31 | var lineBlockedColor = '#E9AB17'; 32 | var bgColor = ''; 33 | var bodyBlockedColor = '#FAF0E6'; 34 | 35 | 36 | ///////////////////////// globals //////////////////////// 37 | var eventCount = { 'left' : 0, 'right' : 0}; 38 | var moving = false; 39 | var matchId1 = 'leftstart'; 40 | var matchId2 = 'rightstart'; 41 | var matchLineId1 = -1; 42 | var matchLineId2 = -1; 43 | var cTimeout; 44 | 45 | 46 | ///////////////////////// utilities /////////////////////// 47 | 48 | // No Math.sign() in JS? 49 | function sign(x) { 50 | if (x > 0) { 51 | return 1; 52 | } else if (x < 0) { 53 | return -1; 54 | } else { 55 | return 0; 56 | } 57 | } 58 | 59 | 60 | function log(msg) { 61 | if (debug) { 62 | console.log(msg); 63 | } 64 | } 65 | 66 | 67 | 68 | function elementPosition(id) { 69 | obj = document.getElementById(id); 70 | var curleft = 0, curtop = 0; 71 | 72 | if (obj && obj.offsetParent) { 73 | curleft = obj.offsetLeft; 74 | curtop = obj.offsetTop; 75 | 76 | while (obj = obj.offsetParent) { 77 | curleft += obj.offsetLeft; 78 | curtop += obj.offsetTop; 79 | } 80 | } 81 | 82 | return { x: curleft, y: curtop }; 83 | } 84 | 85 | 86 | /* 87 | * Scroll the window to relative position, detecting blocking positions. 88 | */ 89 | function scrollWithBlockCheck(container, distX, distY) { 90 | var oldTop = container.scrollTop; 91 | var oldLeft = container.scrollLeft; 92 | 93 | container.scrollTop += distY; // the ONLY place for actual scrolling 94 | container.scrollLeft += distX; 95 | 96 | var actualX = container.scrollLeft - oldLeft; 97 | var actualY = container.scrollTop - oldTop; 98 | log("distY=" + distY + ", actualY=" + actualY); 99 | log("distX=" + distX + ", actualX=" + actualX); 100 | 101 | // extra leewaw here because Chrome scrolling is horribly inacurate 102 | if ((Math.abs(distX) > blockRange && actualX == 0) 103 | || Math.abs(distY) > blockRange && actualY == 0) { 104 | log("blocked"); 105 | container.style.backgroundColor = bodyBlockedColor; 106 | return true; 107 | } else { 108 | eventCount[container.id]++; 109 | container.style.backgroundColor = bgColor; 110 | return false; 111 | } 112 | } 113 | 114 | 115 | function getContainer(elm) { 116 | while (elm && elm.tagName != 'DIV') { 117 | elm = elm.parentElement || elm.parentNode; 118 | } 119 | return elm; 120 | } 121 | 122 | 123 | /* 124 | * timed animation function for scrolling the current window 125 | */ 126 | function matchWindow(linkId, targetId, n) 127 | { 128 | moving = true; 129 | 130 | var link = document.getElementById(linkId); 131 | var target = document.getElementById(targetId); 132 | var linkContainer = getContainer(link); 133 | var targetContainer = getContainer(target); 134 | 135 | var linkPos = elementPosition(linkId).y - linkContainer.scrollTop; 136 | var targetPos = elementPosition(targetId).y - targetContainer.scrollTop; 137 | var distY = targetPos - linkPos; 138 | var distX = linkContainer.scrollLeft - targetContainer.scrollLeft; 139 | 140 | 141 | log("matching window... " + n + " distY=" + distY + " distX=" + distX); 142 | 143 | if (distY == 0 && distX == 0) { 144 | clearTimeout(cTimeout); 145 | moving = false; 146 | } else if (n <= 1) { 147 | scrollWithBlockCheck(targetContainer, distX, distY); 148 | moving = false; 149 | } else { 150 | var stepSize = Math.floor(Math.abs(distY) / n); 151 | actualMinStep = Math.min(minStep, Math.abs(distY)); 152 | if (Math.abs(stepSize) < minStep) { 153 | var step = actualMinStep * sign(distY); 154 | } else { 155 | var step = stepSize * sign(distY); 156 | } 157 | var blocked = scrollWithBlockCheck(targetContainer, distX, step); 158 | var rest = Math.floor(distY / step) - 1; 159 | log("blocked?" + blocked + ", rest steps=" + rest); 160 | if (!blocked) { 161 | cTimeout = setTimeout("matchWindow(" + linkId + "," + targetId + "," 162 | + rest + ")", stepInterval); 163 | } else { 164 | clearTimeout(cTimeout); 165 | moving = false; 166 | } 167 | } 168 | } 169 | 170 | 171 | 172 | ////////////////////////// highlighting ///////////////////////////// 173 | 174 | var highlighted = [] 175 | function putHighlight(id, color) { 176 | var elm = document.getElementById(id); 177 | if (elm != null) { 178 | elm.style.backgroundColor = color; 179 | if (color != bgColor) { 180 | highlighted.push(id); 181 | } 182 | } 183 | } 184 | 185 | 186 | function clearHighlight() { 187 | for (i = 0; i < highlighted.length; i++) { 188 | putHighlight(highlighted[i], bgColor); 189 | } 190 | highlighted = []; 191 | } 192 | 193 | 194 | 195 | /* 196 | * Highlight the link, target nodes and their lines, 197 | * then start animation to move the other window to match. 198 | */ 199 | function highlight(me, linkId, targetId, linkLineId, targetLineId) 200 | { 201 | if (me.id == 'left') { 202 | matchId1 = linkId; 203 | matchId2 = targetId; 204 | } else { 205 | matchId1 = targetId; 206 | matchId2 = linkId; 207 | } 208 | 209 | clearHighlight(); 210 | 211 | putHighlight(linkId, nodeHLColor); 212 | putHighlight(targetId, nodeHLColor); 213 | putHighlight(linkLineId, lineHLColor); 214 | putHighlight(targetLineId, lineHLColor); 215 | 216 | matchWindow(linkId, targetId, nSteps); 217 | } 218 | 219 | 220 | function instantMoveOtherWindow (me) { 221 | log("me=" + me.id + ", eventcount=" + eventCount[me.id]); 222 | log("matchId1=" + matchId1 + ", matchId2=" + matchId2); 223 | 224 | me.style.backgroundColor = bgColor; 225 | 226 | if (!moving && eventCount[me.id] == 0) { 227 | if (me.id == 'left') { 228 | matchWindow(matchId1, matchId2, 1); 229 | } else { 230 | matchWindow(matchId2, matchId1, 1); 231 | } 232 | } 233 | if (eventCount[me.id] > 0) { 234 | eventCount[me.id] -= 1; 235 | } 236 | } 237 | 238 | 239 | function getTarget(x){ 240 | x = x || window.event; 241 | return x.target || x.srcElement; 242 | } 243 | 244 | 245 | window.onload = 246 | function (e) { 247 | var tags = document.getElementsByTagName("A") 248 | for (var i = 0; i < tags.length; i++) { 249 | tags[i].onclick = 250 | function (e) { 251 | var t = getTarget(e) 252 | var lid = t.id 253 | var tid = t.getAttribute('tid') 254 | var container = getContainer(t) 255 | highlight(container, lid, tid, 'ignore', 'ignore') 256 | } 257 | } 258 | 259 | tags = document.getElementsByTagName("DIV") 260 | for (var i = 0; i < tags.length; i++) { 261 | tags[i].onscroll = 262 | function (e) { 263 | instantMoveOtherWindow(getTarget(e)) 264 | } 265 | } 266 | 267 | } 268 | -------------------------------------------------------------------------------- /parse-cpp.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as published by 6 | ;; the Free Software Foundation, either version 3 of the License, or 7 | ;; (at your option) any later version. 8 | 9 | ;; This program is distributed in the hope that it will be useful, 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | ;; GNU General Public License for more details. 13 | 14 | ;; You should have received a copy of the GNU General Public License 15 | ;; along with this program. If not, see . 16 | 17 | 18 | (load "parsec.ss") 19 | 20 | (define *delims* (list "(" ")" "[" "]" "{" "}" "," "`" ";" "#")) 21 | 22 | (define *operators* 23 | (list 24 | ">>>=" 25 | "<<=" ">>=" ">>>" "->*" "..." 26 | "&&" "||" ">>" "<<" "++" "--" 27 | "==" "!=" ">=" "<=" "+=" "-=" "*=" "/=" "^=" "&=" "|=" 28 | "->" ".*" "::" 29 | "=" "+" "-" "*" "/" "%" "<" ">" "!" ":" "?" "." 30 | "^" "|" "&" "~" 31 | )) 32 | 33 | ;;---------------- parameters for the scanner --------------- 34 | (define *line-comment* (list "//")) 35 | (define *comment-start* "/*") 36 | (define *comment-end* "*/") 37 | (define *quotation-marks* '(#\" #\')) 38 | (define *significant-whitespaces* 39 | (list #\newline #\linefeed #\u2028 #\u2029)) 40 | 41 | 42 | 43 | 44 | ;------------------------------------------------------------- 45 | ; parsers 46 | ;------------------------------------------------------------- 47 | 48 | ;; literals 49 | (:: $id 50 | ($pred 51 | (lambda (t) 52 | (and (Token? t) 53 | (id? (Token-text t)))))) 54 | 55 | 56 | (::= $identifier 'identifier 57 | (@? ($$ "::")) 58 | (@* $id (@* $type-parameter) ($$ "::")) 59 | (@? ($$ "~")) $id) 60 | 61 | 62 | ;; (::= $identifier 'identifier 63 | ;; (@? ($$ "::")) $scope-resolution (@? ($$ "~")) $id) 64 | 65 | 66 | (:: $numeral-literal 67 | ($pred 68 | (lambda (t) 69 | (and (Token? t) 70 | (numeral? (Token-text t)))))) 71 | 72 | (:: $char-literal ($pred Char?)) 73 | (:: $string-literal ($pred Str?)) 74 | (:: $newline ($pred Newline?)) 75 | (:: $comment ($pred Comment?)) 76 | 77 | 78 | ;; delimeters 79 | (:: |,| (@_ ",")) 80 | (:: |;| (@~ ";")) 81 | (:: |:| (@_ ":")) 82 | (:: |(| (@~ "(")) 83 | (:: |)| (@~ ")")) 84 | (:: |[| (@~ "[")) 85 | (:: |]| (@~ "]")) 86 | (:: |{| (@~ "{")) 87 | (:: |}| (@~ "}")) 88 | 89 | 90 | 91 | ;; redefine sequence to get over newlines 92 | ;; the definition of |\n| must not contain any call to @seq 93 | 94 | (define $glob1 95 | (lambda (p) 96 | (lambda () 97 | (lambda (toks stk ctx) 98 | (letv ([(t r) ((p) toks stk ctx)]) 99 | (cond 100 | [(not t) (values #f #f)] 101 | [else 102 | (values '() r)])))))) 103 | 104 | (define @*1 105 | (lambda (p) 106 | (lambda () 107 | (lambda (toks stk ctx) 108 | (let loop ([toks toks] [nodes '()]) 109 | (cond 110 | [(null? toks) 111 | (values (apply append (reverse nodes)) '())] 112 | [else 113 | (letv ([(t r) ((p) toks stk ctx)]) 114 | (cond 115 | [(not t) 116 | (values (apply append (reverse nodes)) toks)] 117 | [else 118 | (loop r (cons t nodes))]))])))))) 119 | 120 | (define @!1 121 | (lambda (p) 122 | (lambda () 123 | (lambda (toks stk ctx) 124 | (letv ([(t r) ((p) toks stk ctx)]) 125 | (cond 126 | [(not t) (values (list (car toks)) (cdr toks))] 127 | [else (values #f #f)])))))) 128 | 129 | 130 | (:: |\n| ($glob1 (@*1 $newline))) 131 | (:: |;\n| (@or |;| |\n|)) 132 | 133 | 134 | (define old-seq @seq) 135 | 136 | (define @seq 137 | (lambda ps 138 | (let ([psj (join ps |\n|)]) 139 | (apply old-seq `(,|\n| ,@psj ,|\n|))))) 140 | 141 | 142 | (::= $macro-defintion 'macro 143 | (@~ "#") 144 | (@*1 (old-seq (@*1 (@and (@!1 ($$ "\\")) (@!1 $newline))) ($$ "\\") (@*1 $newline))) 145 | (old-seq (@*1 (@!1 $newline)) ($glob1 $newline) ($glob1 (@*1 $newline))) 146 | ) 147 | 148 | 149 | (:: $directive 150 | (@or ($$ "ifdef") 151 | ($$ "define") 152 | ($$ "undef") 153 | ($$ "endif"))) 154 | 155 | 156 | ;;------------------ starting point ----------------- 157 | (::= $program 'program 158 | (@* $statement) 159 | ) 160 | 161 | 162 | 163 | (:: $statement 164 | (@or $macro-defintion 165 | $empty-statement 166 | $access-label 167 | $statement-block 168 | 169 | $if-statement 170 | $switch-statement 171 | $do-while-statement 172 | $while-statement 173 | $for-statement 174 | $for-in-statement 175 | $continue-statement 176 | $break-statement 177 | 178 | $return-statement 179 | $with-statement 180 | $labelled-statement 181 | $try-statement 182 | 183 | $namespace-definition 184 | $using-namespace 185 | 186 | $class-definition 187 | $function-definition 188 | $function-declaration 189 | $variable-definition 190 | $enum-declaration 191 | 192 | $extended-assembly 193 | $inline-assembly 194 | 195 | $expression-statement 196 | )) 197 | 198 | 199 | (:: $empty-statement |;|) 200 | 201 | 202 | (::= $enum-declaration 'enum 203 | (@~ "enum") (@? $identifier) 204 | |{| 205 | (@? (@.@ (@= 'name-value $identifier (@? $initializer)) |,|)) 206 | |}| 207 | |;| 208 | ) 209 | 210 | 211 | (::= $access-label 'access-label 212 | $access-specifier (@~ ":")) 213 | 214 | 215 | (::= $statement-block 'block 216 | |{| (@* $statement) |}| 217 | ) 218 | 219 | 220 | (::= $namespace-definition 'namespace 221 | (@~ "namespace") $identifier 222 | |{| (@* $statement) |}| 223 | ) 224 | 225 | (::= $using-namespace 'using-namespace 226 | (@~ "using") (@~ "namespace") $identifier) 227 | 228 | 229 | 230 | ;;-------------------------------------------- 231 | (::= $class-definition 'class 232 | 233 | (@or ($$ "class") 234 | ($$ "struct") 235 | ($$ "union")) 236 | 237 | (@* (@= 'declspec 238 | (@or ($$ "_declspec") ($$ "__declspec")) |(| $expression |)|)) 239 | 240 | (@or (@= 'signature (@= 'name $identifier |;| )) 241 | 242 | (@... 243 | (@= 'signature (@= 'name (@? $identifier))) (@? (@... (@_ ":") $base-clause)) 244 | (@= 'body |{| (@* $statement) |}|) ) 245 | )) 246 | 247 | 248 | (::= $base-clause 'bases 249 | (@.@ $base-specifier |,|) 250 | ) 251 | 252 | 253 | (::= $base-specifier 'base-specifier 254 | (@? $access-specifier) $identifier) 255 | 256 | 257 | (::= $access-specifier 'access-specifier 258 | (@or ($$ "public") 259 | ($$ "protected") 260 | ($$ "private") 261 | ($$ "virtual"))) 262 | 263 | 264 | ;;---------- function definition and declaration ------------ 265 | 266 | (::= $function-declaration 'function-declaration 267 | (@= 'signature 268 | (@? ($$ "typedef")) 269 | (@? $access-specifier) (@? $modifiers) (@? $type) 270 | (@= 'name (@or $identifier 271 | (@... |(| ($$ "*") $identifier |)|)) ) 272 | $formal-parameter-list) 273 | (@? ($$ "const")) 274 | (@? $initializer) 275 | ) 276 | 277 | 278 | (::= $function-definition 'function 279 | (@= 'signature 280 | (@or (@... (@? $modifiers) $type 281 | (@= 'name $identifier ) $formal-parameter-list) 282 | 283 | (@... (@= 'name $identifier ) $formal-parameter-list))) 284 | (@? $initializer) 285 | $function-body) 286 | 287 | 288 | (::= $type 'type 289 | (@? $modifiers) (@or $primitive-type 290 | $ctype 291 | $identifier) 292 | (@* $type-parameter) (@* $ptr-suffix)) 293 | 294 | 295 | (::= $type-parameter 'type-parameter 296 | (@~ "<") (@.@ (@or $type $numeral-literal) |,|) (@~ ">")) 297 | 298 | 299 | (::= $ptr-suffix 'suffix 300 | (@or ($$ "*") 301 | ($$ "&"))) 302 | 303 | 304 | (::= $formal-parameter-list 'parameters 305 | |(| (@? (@.@ $type-variable |,|)) (@? |,| ($$ "...")) |)| 306 | ) 307 | 308 | 309 | (::= $type-variable 'type-variable 310 | (@? $modifiers) $type (@? $identifier) (@? $array-suffix)) 311 | 312 | 313 | (::= $function-body 'body 314 | |{| (@* $statement) |}| 315 | ) 316 | 317 | 318 | 319 | (::= $variable-definition 'variable-definition 320 | $variable-declaration-list |;| 321 | ) 322 | 323 | 324 | (:: $variable-declaration-list 325 | (@... (@? $modifiers) $type (@.@ $variable-declaration |,|))) 326 | 327 | 328 | (::= $variable-declaration 'variable-declaration 329 | $identifier (@? $variable-declaration-suffix) 330 | (@? $initializer)) 331 | 332 | 333 | (::= $modifiers 'modifiers 334 | (@+ (@or ($$ "const") 335 | ($$ "static") 336 | ($$ "inline")))) 337 | 338 | (:: $primitive-type 339 | (@or (@... 340 | (@or ($$ "signed") 341 | ($$ "unsigned")) 342 | (@or ($$ "int") 343 | ($$ "char") 344 | ($$ "long") 345 | ($$ "double") 346 | ($$ "float"))) 347 | (@or ($$ "signed") 348 | ($$ "unsigned")))) 349 | 350 | (::= $ctype 'ctype 351 | (@or ($$ "struct") 352 | ($$ "enum")) 353 | $identifier 354 | ) 355 | 356 | 357 | (::= $variable-declaration-suffix 'suffix 358 | (@or (@... |[| $expression |]|)) 359 | ) 360 | 361 | (::= $initializer 'initializer 362 | (@or (@... (@_ "=") $expression) 363 | (@... (@_ ":") $expression) 364 | (@... (@_ "(") $expression (@_ ")")))) 365 | 366 | 367 | 368 | 369 | 370 | 371 | 372 | 373 | (::= $if-statement 'if 374 | ($$ "if") (@= 'test |(| $expression |)|) $statement 375 | (@? (@= 'else ($$ "else") $statement)) 376 | ) 377 | 378 | 379 | ; ($eval $if-statement (scan "if (x<1) { return x; } else { return 0;}")) 380 | 381 | 382 | 383 | ;; doWhileStatement 384 | ;; : 'do' LT!* statement LT!* 'while' LT!* '(' expression ')' (LT | ';')! 385 | ;; ; 386 | 387 | (::= $do-while-statement 'do-while 388 | ($$ "do") $statement 389 | (@= 'while-do ($$ "while") (@= 'test |(| $expression |)| )) 390 | |;| 391 | ) 392 | 393 | 394 | ; ($eval $do-while-statement (scan "do {x = x + 1 } while (x < 5);")) 395 | 396 | 397 | 398 | ;; whileStatement 399 | ;; : 'while' LT!* '(' LT!* expression LT!* ')' LT!* statement 400 | ;; ; 401 | 402 | (::= $while-statement 'while 403 | ($$ "while") (@= 'test |(| $expression |)| ) 404 | $statement 405 | ) 406 | 407 | 408 | 409 | (::= $for-statement 'for 410 | ($$ "for") (@= 'iter 411 | |(| (@? $for-initaliser) |;| 412 | (@? $expression) |;| 413 | (@? $expression) 414 | |)| 415 | ) 416 | $statement 417 | ) 418 | 419 | 420 | 421 | 422 | (::= $for-initaliser 'for-initializer 423 | (@or (@= 'variable-declaration 424 | $variable-declaration-list) 425 | 426 | $expression 427 | )) 428 | 429 | 430 | 431 | 432 | ;; for JS 433 | (::= $for-in-statement 'for-in 434 | ($$ "for") (@= 'iter 435 | |(| (@? $for-in-initalizer) ($$ "in") $expression |)|) 436 | $statement 437 | ) 438 | 439 | 440 | (::= $for-in-initalizer 'for-in-initializer 441 | (@or (@= 'variable-declaration 442 | ($$ "var") $variable-declaration-list) 443 | 444 | $expression 445 | )) 446 | 447 | 448 | 449 | (::= $continue-statement 'continue 450 | ($$ "continue") (@= 'label (@? $identifier)) |;| 451 | ) 452 | 453 | 454 | (::= $break-statement 'break 455 | ($$ "break") (@= 'label (@? $identifier)) |;| 456 | ) 457 | 458 | 459 | (::= $return-statement 'return 460 | ($$ "return") (@= 'value (@? $expression)) |;| 461 | ) 462 | 463 | 464 | (::= $with-statement 'with 465 | ($$ "with") (@= 'obj |(| $expression |)|) 466 | $statement 467 | ) 468 | 469 | 470 | (::= $labelled-statement 'labelled-statement 471 | $identifier |:| $statement 472 | ) 473 | 474 | 475 | (::= $switch-statement 'switch 476 | ($$ "switch") |(| $expression |)| 477 | |{| (@* $case-clause) 478 | (@? (@... $default-clause 479 | (@* $case-clause))) 480 | |}| 481 | ) 482 | 483 | 484 | (::= $case-clause 'case-clause 485 | ($$ "case") $expression |:| (@* $statement) 486 | ) 487 | 488 | 489 | (::= $default-clause 'default-clause 490 | ($$ "default") |:| (@* $statement) 491 | ) 492 | 493 | 494 | ;; throw is an expression in C++ 495 | ;; (::= $throw-statement 'throw 496 | ;; ($$ "throw") $expression |;| 497 | ;; ) 498 | 499 | 500 | (::= $try-statement 'try 501 | ($$ "try") $statement-block 502 | (@or $finally-clause 503 | (@... $catch-clause (@? $finally-clause)))) 504 | 505 | 506 | (::= $catch-clause 'catch 507 | ($$ "catch") |(| $identifier |)| $statement-block) 508 | 509 | 510 | (::= $finally-clause 'finally 511 | ($$ "finally") $statement-block) 512 | 513 | 514 | (::= $expression-statement 'expression-statement 515 | $expression |;|) 516 | 517 | 518 | 519 | 520 | ;------------------------------------------------------------- 521 | ; expressions 522 | ;------------------------------------------------------------- 523 | 524 | ;; utility for constructing operators 525 | (define op 526 | (lambda (s) 527 | (@= 'op ($$ s)))) 528 | 529 | 530 | (:: $expression 531 | $comma-expression 532 | ) 533 | 534 | 535 | 536 | 537 | ;; 18. comma 538 | ;;-------------------------------------------- 539 | (:: $comma-expression 540 | (@or (@= 'comma 541 | (@... $assignment-expression |,| 542 | (@.@ $assignment-expression |,|))) 543 | $assignment-expression)) 544 | 545 | 546 | 547 | ;; 17. throw 548 | ;;-------------------------------------------- 549 | (::= $throw-expression 'throw 550 | (@or (@... (@~ "throw")) $expression 551 | $assignment-expression) 552 | ) 553 | 554 | 555 | ;; 16. assignment 556 | ;;-------------------------------------------- 557 | (:: $assignment-expression 558 | (@or (@= 'assignment 559 | $conditional-expression 560 | $assignment-operator 561 | $assignment-expression) 562 | 563 | $conditional-expression 564 | )) 565 | 566 | 567 | (:: $assignment-operator 568 | (@or (op "=") 569 | (op "*=") 570 | (op "/=") 571 | (op "%=") 572 | (op "+=") 573 | (op "-=") 574 | (op "<<=") 575 | (op ">>=") 576 | (op ">>>=") 577 | (op "&=") 578 | (op "^=") 579 | (op "|="))) 580 | 581 | 582 | 583 | ;; 15. ?: Ternary conditional 584 | ;;-------------------------------------------- 585 | (:: $conditional-expression 586 | (@or (@= 'conditional-expression 587 | (@= 'test $logical-or-expression) 588 | (@~ "?") (@= 'then $conditional-expression) 589 | (@~ ":") (@= 'else $conditional-expression)) 590 | 591 | $logical-or-expression 592 | )) 593 | 594 | 595 | ; ($eval $conditional-expression (scan "x > 0? x-1 : x")) 596 | 597 | 598 | 599 | 600 | ;; 14. || Logical OR 601 | ;;-------------------------------------------- 602 | (:: $logical-or-expression 603 | (@or (@infix-left 'binop 604 | $logical-and-expression 605 | (op "||")) 606 | 607 | $logical-and-expression 608 | )) 609 | 610 | 611 | 612 | ;; 13. && Logical AND 613 | ;;-------------------------------------------- 614 | (:: $logical-and-expression 615 | (@or (@infix-left 'binop 616 | $bitwise-or-expression 617 | (op "&&")) 618 | 619 | $bitwise-or-expression 620 | )) 621 | 622 | 623 | 624 | ;; 12. | Bitwise OR (inclusive or) 625 | ;;-------------------------------------------- 626 | (:: $bitwise-or-expression 627 | (@or (@infix-left 'binop 628 | $bitwise-xor-expression 629 | (op "|")) 630 | 631 | $bitwise-xor-expression 632 | )) 633 | 634 | 635 | 636 | ;; 11. ^ Bitwise XOR (exclusive or) 637 | ;;-------------------------------------------- 638 | (:: $bitwise-xor-expression 639 | (@or (@infix-left 'binop 640 | $bitwise-and-expression 641 | (op "^")) 642 | 643 | $bitwise-and-expression 644 | )) 645 | 646 | 647 | 648 | ;; 10. & Bitwise AND 649 | ;;-------------------------------------------- 650 | (:: $bitwise-and-expression 651 | (@or (@infix-left 'binop 652 | $equality-expression 653 | (op "&")) 654 | 655 | $equality-expression 656 | )) 657 | 658 | 659 | 660 | ;; 9. equality 661 | ;;-------------------------------------------- 662 | (:: $equality-expression 663 | (@or (@infix-left 'binop 664 | $relational-expression 665 | $equality-operator) 666 | 667 | $relational-expression 668 | )) 669 | 670 | (:: $equality-operator 671 | (@or (op "==") 672 | (op "!=") 673 | (op "===") 674 | (op "!==") 675 | )) 676 | 677 | 678 | 679 | 680 | ;; 8. relational 681 | ;;-------------------------------------------- 682 | (:: $relational-expression 683 | (@or (@infix-left 'binop 684 | $bitwise-shift-expression 685 | $relational-operator) 686 | 687 | $bitwise-shift-expression 688 | )) 689 | 690 | (:: $relational-operator 691 | (@or (op "<") 692 | (op "<=") 693 | (op ">") 694 | (op ">=") 695 | (op "instanceof") 696 | (op "in") 697 | )) 698 | 699 | 700 | 701 | 702 | ;; 7. bitwise shift 703 | ;;-------------------------------------------- 704 | (:: $bitwise-shift-expression 705 | (@or (@infix-left 'binop 706 | $additive-expression 707 | $shift-operator) 708 | 709 | $additive-expression 710 | )) 711 | 712 | (:: $shift-operator 713 | (@or (op "<<") 714 | (op ">>") 715 | (op ">>>") 716 | )) 717 | 718 | 719 | 720 | 721 | ;; 6. additive 722 | ;;-------------------------------------------- 723 | (:: $additive-expression 724 | (@or (@infix-left 'binop 725 | $multiplicative-expression 726 | $additive-operator) 727 | 728 | $multiplicative-expression 729 | )) 730 | 731 | 732 | (:: $additive-operator 733 | (@or (op "+") 734 | (op "-"))) 735 | 736 | 737 | ;; ($eval $additive-expression (scan "x + y + z")) 738 | 739 | 740 | 741 | 742 | ;; 5. multiplicative 743 | ;;-------------------------------------------- 744 | (:: $multiplicative-expression 745 | (@or (@infix-left 'binop 746 | $unary-expression 747 | $multiplicative-operator) 748 | 749 | $unary-expression)) 750 | 751 | (:: $multiplicative-operator 752 | (@or (op "*") 753 | (op "/") 754 | (op "%"))) 755 | 756 | 757 | 758 | 759 | ;; unary = 760 | ;; 3. prefix 761 | ;; 2. postfix 762 | ;;-------------------------------------------- 763 | (:: $unary-expression 764 | $prefix-expression) 765 | 766 | 767 | 768 | ;; 3. prefix 769 | ;;-------------------------------------------- 770 | (:: $prefix-expression 771 | (@or (@prefix 'prefix 772 | $postfix-expression 773 | $prefix-operator) 774 | $postfix-expression)) 775 | 776 | 777 | (:: $prefix-operator 778 | (@or (@= 'new (op "new") (@? $array-suffix)) 779 | (@= 'delete (op "delete") (@? $array-suffix)) 780 | (@= 'cast |(| $type |)| ) 781 | (op "void") 782 | (op "sizeof") 783 | (op "++") 784 | (op "--") 785 | (op "+") 786 | (op "-") 787 | (op "~") 788 | (op "!") 789 | (op "*") ; indirection 790 | (op "&") ; address of 791 | (op "::") 792 | )) 793 | 794 | 795 | (::= $array-suffix 'array-suffix 796 | |[| |]|) 797 | 798 | 799 | 800 | 801 | ;; 2. postfix 802 | ;;-------------------------------------------- 803 | (:: $postfix-expression 804 | (@or (@postfix 'postfix 805 | $primary-expression 806 | $postfix-operator) 807 | $primary-expression)) 808 | 809 | 810 | (:: $postfix-operator 811 | (@or (op "++") 812 | (op "--") 813 | $index-suffix 814 | $property-reference-suffix 815 | $type-parameter 816 | $arguments)) 817 | 818 | 819 | (::= $arguments 'argument 820 | |(| (@? (@.@ $expression |,|)) |)| 821 | ) 822 | 823 | 824 | (::= $index-suffix 'index 825 | |[| $expression |]| 826 | ) 827 | 828 | 829 | (::= $property-reference-suffix 'field-access 830 | (@or (@~ ".") (@~ "->")) $identifier) 831 | 832 | 833 | 834 | ;; scope resolution :: 835 | ;--------------------------------------------- 836 | (:: $scope-resolution 837 | (@or (@infix-left 'scope 838 | $id 839 | ($$ "::")) 840 | 841 | $primary-expression 842 | )) 843 | 844 | 845 | 846 | ;; 1. primary 847 | ;;-------------------------------------------- 848 | (:: $primary-expression 849 | (@or (@= 'this ($$ "this")) 850 | $type-cast 851 | $ctype ; could be used in a macro argument 852 | $identifier 853 | $literal 854 | $array-literal 855 | $object-literal 856 | (@= #f |(| $expression |)|) 857 | )) 858 | 859 | 860 | (::= $type-cast 'type-cast 861 | (@or ($$ "typeid") 862 | ($$ "const_cast") 863 | ($$ "dynamic_cast") 864 | ($$ "reinterpret_cast") 865 | ($$ "static_cast"))) 866 | 867 | 868 | 869 | ;; literal 870 | ;;-------------------------------------------- 871 | (:: $literal 872 | (@or ($$ "null") 873 | ($$ "true") 874 | ($$ "false") 875 | $string-concat 876 | $float-literal 877 | $numeral-literal 878 | $string-literal 879 | $char-literal)) 880 | 881 | 882 | (::= $array-literal 'array-literal 883 | |{| (@? (@.@ $expression |,|)) |}| 884 | ) 885 | 886 | 887 | (::= $object-literal 'object-literal 888 | |{| $property-name-value (@* (@... |,| $property-name-value)) |}| 889 | ) 890 | 891 | 892 | (::= $property-name-value 'property-name-value 893 | $property-name |:| $assignment-expression) 894 | 895 | 896 | (:: $property-name 897 | (@or $identifier 898 | $string-literal 899 | $numeral-literal)) 900 | 901 | 902 | (::= $float-literal 'float-literal 903 | $numeral-literal ($$ ".") $numeral-literal) 904 | 905 | 906 | (::= $string-concat 'string-concat 907 | $string-literal (@* (@or $string-literal $expression))) 908 | 909 | 910 | 911 | ;------------------------------------------------------------- 912 | ; inline assembly 913 | ;------------------------------------------------------------- 914 | (::= $inline-assembly 'inline-assembly 915 | (@or (@~ "asm") 916 | (@~ "__asm__")) 917 | (@? (@or ($$ "volatile") 918 | ($$ "__volatile__"))) 919 | |(| $string-concat |)| 920 | |;| 921 | ) 922 | 923 | 924 | (::= $extended-assembly 'extended-assembly 925 | (@or (@~ "asm") 926 | (@~ "__asm__")) 927 | (@? (@or ($$ "volatile") 928 | ($$ "__volatile__"))) 929 | |(| $string-concat 930 | |:| (@= 'output-operands (@* $string-literal |(| $identifier |)| )) 931 | |:| (@= 'input-operands (@* $string-literal |(| $identifier |)| )) 932 | |:| (@= 'clobbered-registers (@? (@.@ $string-literal |,|))) 933 | |)| 934 | |;| 935 | ) 936 | 937 | 938 | 939 | 940 | 941 | (define parse-cpp 942 | (lambda (s) 943 | (first-val 944 | ($eval $program 945 | (filter (lambda (x) (not (Comment? x))) 946 | (scan s)))))) 947 | 948 | 949 | 950 | 951 | ;------------------------------------------------------------- 952 | ; tests 953 | ;------------------------------------------------------------- 954 | 955 | ;; (test-file "simulator-arm.cc" 956 | ;; "simulator-mips.cc" 957 | ;; "d8-3404.cc" 958 | ;; "d8-8424.cc" 959 | ;; "assembler-arm-2.cc" 960 | ;; "assembler-arm-7.cc" 961 | ;; "assembler-arm-8309.cc" 962 | ;; ) 963 | 964 | -------------------------------------------------------------------------------- /parse-js.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as published by 6 | ;; the Free Software Foundation, either version 3 of the License, or 7 | ;; (at your option) any later version. 8 | 9 | ;; This program is distributed in the hope that it will be useful, 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | ;; GNU General Public License for more details. 13 | 14 | ;; You should have received a copy of the GNU General Public License 15 | ;; along with this program. If not, see . 16 | 17 | 18 | 19 | (load "parsec.ss") 20 | 21 | 22 | ;------------------------------------------------------------- 23 | ; scanner settings 24 | ;------------------------------------------------------------- 25 | 26 | (define *delims* (list "(" ")" "[" "]" "{" "}" "," "`" ";")) 27 | 28 | (define *operators* 29 | (list 30 | ">>>=" 31 | "<<=" ">>=" ">>>" 32 | "==" "!=" ">=" "<=" "&&" "||" ">>" "<<" "+=" "-=" "*=" "/=" "++" "--" 33 | "=" "+" "-" "*" "/" "%" ">" "<" "!" ":" "?" "." 34 | )) 35 | 36 | 37 | (define *line-comment* (list "//")) 38 | (define *comment-start* "/*") 39 | (define *comment-end* "*/") 40 | (define *quotation-marks* '(#\" #\')) 41 | (define *significant-whitespaces* 42 | (list #\newline #\linefeed #\u2028 #\u2029)) 43 | 44 | 45 | (define alpha? 46 | (predor char-alphabetic? 47 | (lambda (x) (char=? x #\$)))) 48 | 49 | 50 | 51 | 52 | ;------------------------------------------------------------- 53 | ; primitive parsers 54 | ;------------------------------------------------------------- 55 | 56 | 57 | 58 | (:: $identifier 59 | ($pred 60 | (lambda (t) 61 | (and (Token? t) 62 | (id? (Token-text t)))))) 63 | 64 | 65 | (:: $numeral-literal 66 | ($pred 67 | (lambda (t) 68 | (and (Token? t) 69 | (numeral? (Token-text t)))))) 70 | 71 | 72 | (:: $string-literal ($pred Str?)) 73 | (:: $newline ($pred Newline?)) 74 | (:: $comment ($pred Comment?)) 75 | 76 | 77 | (:: |,| (@_ ",")) 78 | (:: |;| (@~ ";")) 79 | (:: |:| (@_ ":")) 80 | (:: |(| (@~ "(")) 81 | (:: |)| (@~ ")")) 82 | (:: |[| (@~ "[")) 83 | (:: |]| (@~ "]")) 84 | (:: |{| (@~ "{")) 85 | (:: |}| (@~ "}")) 86 | (:: |//| ($glob (@* $comment))) 87 | ;; (:: |\n| ($glob (@* $newline))) 88 | ;; (:: |;\n| (@or |;| |\n|)) 89 | (:: |//\n| (@or |//| |\n|)) 90 | 91 | 92 | (define $glob1 93 | (lambda (p) 94 | (lambda () 95 | (lambda (toks stk ctx) 96 | (letv ([(t r) ((p) toks stk ctx)]) 97 | (cond 98 | [(not t) (values #f #f)] 99 | [else 100 | (values '() r)])))))) 101 | 102 | (define @*1 103 | (lambda (p) 104 | (lambda () 105 | (lambda (toks stk ctx) 106 | (let loop ([toks toks] [nodes '()]) 107 | (cond 108 | [(null? toks) 109 | (values (apply append (reverse nodes)) '())] 110 | [else 111 | (letv ([(t r) ((p) toks stk ctx)]) 112 | (cond 113 | [(not t) 114 | (values (apply append (reverse nodes)) toks)] 115 | [else 116 | (loop r (cons t nodes))]))])))))) 117 | 118 | (:: |\n| ($glob1 (@*1 $newline))) 119 | (:: |;\n| (@or |;| |\n|)) 120 | 121 | 122 | ;; redefine sequence to get over newlines 123 | ;; the definition of |\n| must not contain any call to @seq 124 | (define old-seq @seq) 125 | (define @seq 126 | (lambda ps 127 | (let ([psj (join ps |\n|)]) 128 | (apply old-seq `(,|\n| ,@psj ,|\n|))))) 129 | 130 | 131 | ;; ($eval (@seq ($$ "foo") ($$ "bar")) 132 | ;; (scan " 133 | ;; foo 134 | ;; bar ")) 135 | 136 | 137 | 138 | 139 | ;------------------------------------------------------------- 140 | ; compound parsers 141 | ;------------------------------------------------------------- 142 | 143 | (::= $program 'program 144 | (@* $statement)) 145 | 146 | 147 | 148 | (:: $statement 149 | (@or $statement-block 150 | $empty-statement 151 | $function-definition 152 | $variable-statement 153 | $with-statement 154 | 155 | $if-statement 156 | $switch-statement 157 | $do-while-statement 158 | $while-statement 159 | $for-statement 160 | $for-in-statement 161 | $continue-statement 162 | $break-statement 163 | $try-statement 164 | $throw-statement 165 | $return-statement 166 | 167 | $labelled-statement 168 | $expression-statement 169 | )) 170 | 171 | 172 | 173 | (::= $statement-block 'block 174 | |{| (@* $statement) |}| 175 | ) 176 | 177 | 178 | (:: $empty-statement |;|) 179 | 180 | 181 | (::= $function-definition 'function 182 | ($$ "function") (@= 'name $identifier) $formal-parameter-list 183 | $function-body) 184 | 185 | 186 | ;; function-expression can be unnamed 187 | (::= $function-expression 'function 188 | ($$ "function") (@= 'name (@? $identifier)) $formal-parameter-list 189 | $function-body) 190 | 191 | 192 | (::= $formal-parameter-list 'parameters 193 | (@or (@... |(| (@? (@.@ $identifier |,|)) |)| ) 194 | $identifier)) 195 | 196 | 197 | (::= $function-body 'body 198 | $statement-block 199 | ) 200 | 201 | 202 | 203 | ;;---------------- variable statement ----------------- 204 | (::= $variable-statement 'variable-declaration 205 | ($$ "var") (@.@ $variable-declaration |,|) |;\n| 206 | ) 207 | 208 | 209 | (::= $variable-declaration 'variable-declaration 210 | $identifier (@? $initializer)) 211 | 212 | 213 | (::= $initializer 'initializer 214 | (@... ($$ "=") $assignment-expression)) 215 | 216 | 217 | 218 | ;;-------------------------------------------- 219 | (::= $with-statement 'with 220 | ($$ "with") (@= 'obj |(| $expression |)|) 221 | $statement 222 | ) 223 | 224 | 225 | ;;-------------------------------------------- 226 | (::= $if-statement 'if 227 | ($$ "if") (@= 'test |(| $expression |)|) $statement 228 | (@? (@= 'else ($$ "else") $statement 229 | ))) 230 | 231 | 232 | ; ($eval $if-statement (scan "if (x<1) { return x; } else { return 0;}")) 233 | 234 | 235 | ;;-------------------------------------------- 236 | (::= $do-while-statement 'do-while 237 | ($$ "do") $statement 238 | (@= 'while-do ($$ "while") (@= 'test |(| $expression |)| )) 239 | |;\n| 240 | ) 241 | 242 | 243 | ; ($eval $do-while-statement (scan "do {x = x + 1 } while (x < 5);")) 244 | 245 | 246 | 247 | ;;-------------------------------------------- 248 | (::= $while-statement 'while 249 | ($$ "while") (@= 'test |(| $expression |)| ) 250 | $statement 251 | ) 252 | 253 | 254 | 255 | ;;-------------------------------------------- 256 | (::= $for-statement 'for 257 | ($$ "for") (@= 'iter 258 | |(| (@? $for-initaliser) |;| 259 | (@? $expression) |;| 260 | (@? $expression) 261 | |)| 262 | ) 263 | $statement 264 | ) 265 | 266 | 267 | (::= $for-initaliser 'for-initializer 268 | (@or (@= 'variable-declaration 269 | ($$ "var") (@.@ $variable-declaration |,|)) 270 | 271 | $expression 272 | )) 273 | 274 | 275 | ;;-------------------------------------------- 276 | (::= $for-in-statement 'for-in 277 | ($$ "for") (@= 'iter 278 | |(| (@? $for-in-initalizer) ($$ "in") $expression |)|) 279 | $statement 280 | ) 281 | 282 | 283 | (::= $for-in-initalizer 'for-in-initializer 284 | (@or (@= 'variable-declaration 285 | ($$ "var") (@.@ $variable-declaration |,|)) 286 | 287 | $expression 288 | )) 289 | 290 | 291 | 292 | ;;-------------------------------------------- 293 | (::= $continue-statement 'continue 294 | ($$ "continue") (@= 'label (@? $identifier)) |;\n| 295 | ) 296 | 297 | ; ($eval $continue-statement (scan "continue foo")) 298 | 299 | 300 | 301 | ;;-------------------------------------------- 302 | (::= $break-statement 'break 303 | ($$ "break") (@= 'label (@? $identifier)) |;\n| 304 | ) 305 | 306 | 307 | 308 | ;;-------------------------------------------- 309 | (::= $return-statement 'return 310 | ($$ "return") (@= 'value (@? $expression)) |;\n| 311 | ) 312 | 313 | ; ($eval $return-statement (scan "return foo, bar+1")) 314 | 315 | 316 | 317 | ;;-------------------------------------------- 318 | (::= $labelled-statement 'labelled-statement 319 | $identifier |:| $statement 320 | ) 321 | 322 | 323 | 324 | ;;-------------------------------------------- 325 | (::= $switch-statement 'switch-statement 326 | ($$ "switch") |(| $expression |)| 327 | |{| (@* $case-clause) 328 | (@? $default-clause 329 | (@* $case-clause)) 330 | |}| 331 | ) 332 | 333 | 334 | (::= $case-clause 'case-clause 335 | ($$ "case") $expression |:| (@* $statement) 336 | ) 337 | 338 | 339 | (::= $default-clause 'default 340 | ($$ "default") |:| (@* $statement) 341 | ) 342 | 343 | 344 | 345 | ;;-------------------------------------------- 346 | (::= $throw-statement 'throw 347 | ($$ "throw") $expression |;\n| 348 | ) 349 | 350 | 351 | ;;-------------------------------------------- 352 | (::= $try-statement 'try 353 | ($$ "try") $statement-block 354 | (@or $finally-clause 355 | (@... $catch-clause (@? $finally-clause))) 356 | ) 357 | 358 | 359 | (::= $catch-clause 'catch 360 | ($$ "catch") |(| $identifier |)| $statement-block 361 | ) 362 | 363 | 364 | (::= $finally-clause 'finally 365 | ($$ "finally") $statement-block 366 | ) 367 | 368 | 369 | ;;-------------------------------------------- 370 | (::= $expression-statement 'expression-statement 371 | $expression |;\n| 372 | ) 373 | 374 | 375 | 376 | 377 | ;------------------------------------------------------------- 378 | ; expressions 379 | ;------------------------------------------------------------- 380 | 381 | ;; utility for constructing operators 382 | (define op 383 | (lambda (s) 384 | (@= 'op ($$ s)))) 385 | 386 | (define @precedence 387 | (lambda ps 388 | (define build 389 | (lambda (head tail) 390 | (cond 391 | [(null? tail) head] 392 | [else 393 | (build (@or head (car tail)) (cdr tail))]))) 394 | (cond 395 | [(null? ps) 396 | (fatal '@precedence 397 | "need at least one expression to build precedence")] 398 | [else 399 | (build (car ps) (cdr ps))]))) 400 | 401 | 402 | (define-syntax ::op 403 | (syntax-rules () 404 | [(_ (name1 op1 fix1 asso1)) 405 | (begin 406 | (define name1 407 | (cond 408 | [(eq? fix1 'infix) 409 | (cond 410 | [(eq? asso1 'left) 411 | (@infix-left 'binop name2 op1)] 412 | [else 413 | (@infix-right 'binop name2 op1)])] 414 | [(eq? fix1 'postfix) 415 | (@postfix 'postfix $name2 $op1)] 416 | [(eq? fix1 'prefix) 417 | (@prefix 'prefix $name2 $op1)])))] 418 | [(_ (name1 op1 fix1 asso1) 419 | (name2 op2 fix2 asso2) 420 | (name3 op3 fix3 asso3) ...) 421 | (begin 422 | (define name1 423 | (cond 424 | [(eq? fix1 'infix) 425 | (cond 426 | [(eq? asso1 'left) 427 | (@or (@infix-left 'binop name2 op1) 428 | name2)] 429 | [else 430 | (@or (@infix-right 'binop name2 op1) 431 | name2)])] 432 | [(eq? fix1 'postfix) 433 | (@or (@postfix 'postfix $name2 $op1) 434 | name2)] 435 | [(eq? fix1 'prefix) 436 | (@or (@prefix 'prefix $name2 $op1) 437 | name2) 438 | ])) 439 | (::op (name2 op2 fix2 asso2) 440 | (name3 op3 fix3 asso3) ...))])) 441 | 442 | 443 | 444 | 445 | ;; 18. comma 446 | ;;-------------------------------------------- 447 | ;; (:: $expression 448 | ;; (::op ($comma-expression "," 'left) 449 | ;; ($assignment-expression $assignment-operator 'right) 450 | ;; ($conditional-expression ) 451 | ;; $logical-or-expression 452 | ;; $logical-and-expression 453 | ;; $bitwise-or-expression 454 | ;; $bitwise-xor-expression 455 | ;; $bitwise-and-expression 456 | ;; $equality-expression 457 | ;; $relational-expression 458 | ;; $bitwise-shift-expression 459 | ;; $additive-expression 460 | ;; $multiplicative-expression 461 | ;; $prefix-expression 462 | ;; $postfix-expression 463 | ;; $primary-expression 464 | ;; )) 465 | 466 | 467 | 468 | 469 | (:: $expression 470 | $comma-expression 471 | ) 472 | 473 | 474 | 475 | ;; 18. comma 476 | ;;-------------------------------------------- 477 | (::= $comma-expression 'comma 478 | (@.@ $assignment-expression |,|)) 479 | 480 | 481 | 482 | ;; 16. assignment 483 | ;;-------------------------------------------- 484 | (:: $assignment-expression 485 | (@or (@= 'assignment 486 | $conditional-expression 487 | $assignment-operator 488 | $assignment-expression) 489 | 490 | $conditional-expression 491 | )) 492 | 493 | 494 | ;; (:: $assignment-expression 495 | ;; (@or (@infix-right 'assignment 496 | ;; $conditional-expression 497 | ;; $assignment-operator) 498 | 499 | ;; $conditional-expression 500 | ;; )) 501 | 502 | 503 | ; ($eval $assignment-expression (scan "x *= 1")) 504 | 505 | 506 | (:: $assignment-operator 507 | (@or (op "=") 508 | (op "*=") 509 | (op "/=") 510 | (op "%=") 511 | (op "+=") 512 | (op "-=") 513 | (op "<<=") 514 | (op ">>=") 515 | (op ">>>=") 516 | (op "&=") 517 | (op "^=") 518 | (op "|=") 519 | )) 520 | 521 | 522 | 523 | 524 | ;; 15. ?: Ternary conditional 525 | ;;-------------------------------------------- 526 | (:: $conditional-expression 527 | (@or (@= 'conditional-expression 528 | (@= 'test $logical-or-expression) 529 | ($$ "?") (@= 'then $conditional-expression) 530 | ($$ ":") (@= 'else $conditional-expression)) 531 | 532 | $logical-or-expression 533 | )) 534 | 535 | 536 | ; ($eval $conditional-expression (scan "x > 0? x-1 : x")) 537 | 538 | 539 | 540 | 541 | ;; 14. || Logical OR 542 | ;;-------------------------------------------- 543 | (:: $logical-or-expression 544 | (@or (@infix-left 'binop 545 | $logical-and-expression 546 | (op "||")) 547 | 548 | $logical-and-expression 549 | )) 550 | 551 | ; ($eval $logical-or-expression (scan "x || y")) 552 | 553 | 554 | 555 | ;; 13. && Logical AND 556 | ;;-------------------------------------------- 557 | (:: $logical-and-expression 558 | (@or (@infix-left 'binop 559 | $bitwise-or-expression 560 | (op "&&")) 561 | 562 | $bitwise-or-expression 563 | )) 564 | 565 | 566 | ;; 12. | Bitwise OR (inclusive or) 567 | ;;-------------------------------------------- 568 | (:: $bitwise-or-expression 569 | (@or (@infix-left 'binop 570 | $bitwise-xor-expression 571 | (op "|")) 572 | 573 | $bitwise-xor-expression 574 | )) 575 | 576 | 577 | 578 | ;; 11. ^ Bitwise XOR (exclusive or) 579 | ;;-------------------------------------------- 580 | (:: $bitwise-xor-expression 581 | (@or (@infix-left 'binop 582 | $bitwise-and-expression 583 | (op "^")) 584 | 585 | $bitwise-and-expression 586 | )) 587 | 588 | 589 | 590 | ;; 10. & Bitwise AND 591 | ;;-------------------------------------------- 592 | (:: $bitwise-and-expression 593 | (@or (@infix-left 'binop 594 | $equality-expression 595 | (op "&")) 596 | 597 | $equality-expression 598 | )) 599 | 600 | 601 | 602 | ;; 9. equality 603 | ;;-------------------------------------------- 604 | (:: $equality-expression 605 | (@or (@infix-left 'binop 606 | $relational-expression 607 | $equality-operator) 608 | 609 | $relational-expression 610 | )) 611 | 612 | (:: $equality-operator 613 | (@or (op "==") 614 | (op "!=") 615 | (op "===") 616 | (op "!==") 617 | )) 618 | 619 | 620 | 621 | ;; 8. relational 622 | ;;-------------------------------------------- 623 | (:: $relational-expression 624 | (@or (@infix-left 'binop 625 | $bitwise-shift-expression 626 | $relational-operator) 627 | 628 | $bitwise-shift-expression 629 | )) 630 | 631 | (:: $relational-operator 632 | (@or (op "<") 633 | (op "<=") 634 | (op ">") 635 | (op ">=") 636 | (op "instanceof") 637 | (op "in") 638 | )) 639 | 640 | 641 | 642 | ;; 7. bitwise shift 643 | ;;-------------------------------------------- 644 | (:: $bitwise-shift-expression 645 | (@or (@infix-left 'binop 646 | $additive-expression 647 | $bitwise-shift-operator) 648 | 649 | $additive-expression 650 | )) 651 | 652 | (:: $bitwise-shift-operator 653 | (@or (op "<<") 654 | (op ">>") 655 | (op ">>>") 656 | )) 657 | 658 | 659 | 660 | ;; 6. additive 661 | ;;-------------------------------------------- 662 | (:: $additive-expression 663 | (@or (@infix-left 'binop 664 | $multiplicative-expression 665 | $additive-operator) 666 | 667 | $multiplicative-expression 668 | )) 669 | 670 | 671 | (:: $additive-operator 672 | (@or (op "+") 673 | (op "-"))) 674 | 675 | 676 | ;; ($eval $additive-expression (scan "x + y + z")) 677 | 678 | 679 | 680 | 681 | ;; 5. multiplicative 682 | ;;-------------------------------------------- 683 | (:: $multiplicative-expression 684 | (@or (@infix-left 'binop 685 | $unary-expression 686 | $multiplicative-operator) 687 | 688 | $unary-expression)) 689 | 690 | (:: $multiplicative-operator 691 | (@or (op "*") 692 | (op "/") 693 | (op "%"))) 694 | 695 | 696 | 697 | 698 | ;; 3. prefix 699 | ;; 2. postfix 700 | ;;-------------------------------------------- 701 | (:: $unary-expression 702 | $prefix-expression) 703 | 704 | 705 | (:: $prefix-expression 706 | (@or (@prefix 'prefix 707 | $postfix-expression 708 | $prefix-operator) 709 | $postfix-expression)) 710 | 711 | 712 | (:: $postfix-expression 713 | (@or (@postfix 'postfix 714 | $primary-expression 715 | $postfix-operator) 716 | $primary-expression)) 717 | 718 | 719 | (:: $prefix-operator 720 | (@or (op "new") 721 | (op "delete") 722 | (op "void") 723 | (op "typeof") 724 | (op "++") 725 | (op "--") 726 | (op "+") 727 | (op "-") 728 | (op "~") 729 | (op "!") 730 | )) 731 | 732 | 733 | (:: $postfix-operator 734 | (@or $index-suffix 735 | $property-reference-suffix 736 | $arguments 737 | (op "++") 738 | (op "--"))) 739 | 740 | 741 | (::= $index-suffix 'index 742 | |[| $expression |]| 743 | ) 744 | 745 | 746 | (::= $property-reference-suffix 'property 747 | (@_ ".") $identifier) 748 | 749 | 750 | (::= $arguments 'arguments 751 | |(| (@? (@.@ $assignment-expression |,|)) |)| 752 | ) 753 | 754 | 755 | (::= $new-expression 'new 756 | ($$ "new") $postfix-expression) 757 | 758 | 759 | 760 | ;; 1. primary 761 | ;;-------------------------------------------- 762 | (:: $primary-expression 763 | (@or $function-expression 764 | $identifier 765 | $literal 766 | (@= 'expression |(| $expression |)| ) 767 | )) 768 | 769 | 770 | 771 | 772 | ;;----------- 773 | (::= $array-literal 'array-literal 774 | |[| (@? (@.@ $assignment-expression |,|)) |]| 775 | ) 776 | 777 | 778 | 779 | ;;----------- 780 | (::= $object-literal 'object-literal 781 | |{| $property-name-value (@* |,| $property-name-value) |}| 782 | ) 783 | 784 | 785 | (::= $property-name-value 'property-name-value 786 | $property-name |:| $assignment-expression) 787 | 788 | 789 | (:: $property-name 790 | (@or $identifier 791 | $string-literal 792 | $numeral-literal)) 793 | 794 | 795 | 796 | ;;----------- 797 | (:: $literal 798 | (@or ($$ "null") 799 | ($$ "true") 800 | ($$ "false") 801 | (@= 'this ($$ "this")) 802 | $string-literal 803 | $numeral-literal 804 | $array-literal 805 | $object-literal 806 | )) 807 | 808 | 809 | 810 | 811 | 812 | ;------------------------------------------------------------- 813 | ; parse-js 814 | ;------------------------------------------------------------- 815 | 816 | (define parse-js 817 | (lambda (s) 818 | (first-val 819 | ($eval $program 820 | (filter (lambda (x) (not (Comment? x))) 821 | (scan s)))))) 822 | 823 | 824 | 825 | 826 | ;------------------------------------------------------------- 827 | ; tests 828 | ;------------------------------------------------------------- 829 | 830 | ;; (parse-js (read-file "nav-div.js")) 831 | 832 | -------------------------------------------------------------------------------- /parse-scheme.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as published by 6 | ;; the Free Software Foundation, either version 3 of the License, or 7 | ;; (at your option) any later version. 8 | 9 | ;; This program is distributed in the hope that it will be useful, 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | ;; GNU General Public License for more details. 13 | 14 | ;; You should have received a copy of the GNU General Public License 15 | ;; along with this program. If not, see . 16 | 17 | 18 | 19 | (load "parsec.ss") 20 | 21 | 22 | ;------------------------------------------------------------- 23 | ; scanner setttings 24 | ;------------------------------------------------------------- 25 | 26 | ; single quote is considered a delimeter in s-expression 27 | (define *delims* (list "(" ")" "[" "]" "{" "}" "'" "`" "," )) 28 | 29 | (define *line-comment* (list ";")) 30 | (define *comment-start* "") ; no block comments for lisp 31 | (define *comment-end* "") 32 | (define *operators* '()) 33 | (define *quotation-marks* '(#\")) 34 | (define *significant-whitespaces* '()) 35 | 36 | 37 | 38 | ;------------------------------------------------------------- 39 | ; parser 40 | ;------------------------------------------------------------- 41 | 42 | (:: $open 43 | (@or (@~ "(") (@~ "["))) 44 | 45 | (:: $close 46 | (@or (@~ ")") (@~ "]"))) 47 | 48 | (:: $non-parens 49 | (@and (@! $open) (@! $close))) 50 | 51 | (::= $parens 'sexp 52 | (@seq $open (@* $sexp) $close)) 53 | 54 | (:: $sexp 55 | (@+ (@or $parens $non-parens))) 56 | 57 | (:: $program $sexp) 58 | 59 | 60 | (define parse-scheme 61 | (lambda (s) 62 | (first-val ($eval $sexp (scan s))))) 63 | 64 | -------------------------------------------------------------------------------- /parsec.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as published by 6 | ;; the Free Software Foundation, either version 3 of the License, or 7 | ;; (at your option) any later version. 8 | 9 | ;; This program is distributed in the hope that it will be useful, 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | ;; GNU General Public License for more details. 13 | 14 | ;; You should have received a copy of the GNU General Public License 15 | ;; along with this program. If not, see . 16 | 17 | 18 | 19 | (load "utils.ss") 20 | 21 | (define *debug* #f) 22 | (define *left-recur-detection* #f) 23 | 24 | 25 | ;------------------------------------------------------------- 26 | ; parser combinator library 27 | ;------------------------------------------------------------- 28 | 29 | ;; s-expression settings 30 | ;; please override for other languages. 31 | (define *delims* (list "(" ")" "[" "]" "{" "}" "'" "`" "," )) 32 | (define *line-comment* (list ";")) 33 | (define *comment-start* "") 34 | (define *comment-end* "") 35 | (define *operators* '()) 36 | (define *quotation-marks* '(#\")) 37 | (define *significant-whitespaces* '()) 38 | 39 | 40 | 41 | ;--------------------- data types --------------------------- 42 | (struct Expr (type elts start end) #:transparent) 43 | (struct Token (text start end) #:transparent) 44 | (struct Char (c start end) #:transparent) 45 | (struct Comment (text start end) #:transparent) 46 | (struct Str (s start end) #:transparent) 47 | (struct Newline (start end) #:transparent) 48 | (struct Phantom (start end) #:transparent) 49 | 50 | 51 | 52 | (define node-type 53 | (lambda (node) 54 | (and (Expr? node) (Expr-type node)))) 55 | 56 | 57 | (define get-start 58 | (lambda (node) 59 | (cond 60 | [(Expr? node) (Expr-start node)] 61 | [(Token? node) (Token-start node)] 62 | [(Char? node) (Char-start node)] 63 | [(Comment? node) (Comment-start node)] 64 | [(Str? node) (Str-start node)] 65 | [(Newline? node) (Newline-start node)] 66 | [(Phantom? node) (Phantom-start node)] 67 | [else 68 | (fatal 'get-start 69 | "unrecognized node: " node)]))) 70 | 71 | 72 | (define get-end 73 | (lambda (node) 74 | (cond 75 | [(Expr? node) (Expr-end node)] 76 | [(Token? node) (Token-end node)] 77 | [(Char? node) (Char-end node)] 78 | [(Comment? node) (Comment-end node)] 79 | [(Str? node) (Str-end node)] 80 | [(Newline? node) (Newline-end node)] 81 | [(Phantom? node) (Phantom-end node)] 82 | [else 83 | (fatal 'get-end 84 | "unrecognized node: " node)]))) 85 | 86 | 87 | 88 | 89 | 90 | ;------------------------------------------------------------- 91 | ; scanner 92 | ;------------------------------------------------------------- 93 | 94 | (define whitespace? char-whitespace?) 95 | (define alpha? char-alphabetic?) 96 | (define digit? char-numeric?) 97 | 98 | 99 | ; Is char c a delim? 100 | (define delim? 101 | (lambda (c) 102 | (member (char->string c) *delims*))) 103 | 104 | 105 | (define id? 106 | (lambda (s) 107 | (cond 108 | [(= 0 (string-length s)) #f] 109 | [(or (alpha? (string-ref s 0)) 110 | (eq? #\_ (string-ref s 0))) 111 | (let loop ([i 1]) 112 | (cond 113 | [(>= i (string-length s)) #t] 114 | [else 115 | (let ([c (string-ref s i)]) 116 | (cond 117 | [(alpha? c) (loop (add1 i))] 118 | [(digit? c) (loop (add1 i))] 119 | [(char=? c #\_) (loop (add1 i))] 120 | [else #f]))]))] 121 | [else #f]))) 122 | 123 | 124 | (define numeral? 125 | (lambda (s) 126 | (cond 127 | [(= 0 (string-length s)) #f] 128 | [(digit? (string-ref s 0)) #t 129 | ;; (let loop ([i 1]) 130 | ;; (cond 131 | ;; [(>= i (string-length s)) #t] 132 | ;; [else 133 | ;; (let ([c (string-ref s i)]) 134 | ;; (cond 135 | ;; [(digit? c) (loop (add1 i))] 136 | ;; [(char=? c #\.) (loop (add1 i))] 137 | ;; [else #f]))])) 138 | ] 139 | [else #f]))) 140 | 141 | 142 | 143 | 144 | (define start-with 145 | (lambda (s start prefix) 146 | (let* ([prefix-str (if (char? prefix) 147 | (char->string prefix) 148 | prefix)] 149 | [len (string-length prefix-str)]) 150 | (cond 151 | [(= len 0) #f] 152 | [(< (string-length s) (+ start len)) #f] 153 | [(string=? (substring s start (+ start len)) prefix-str) 154 | prefix] 155 | [else #f])))) 156 | 157 | 158 | 159 | (define start-with-one-of 160 | (lambda (s start prefixes) 161 | (cond 162 | [(null? prefixes) #f] 163 | [(start-with s start (car prefixes)) 164 | (car prefixes)] 165 | [else 166 | (start-with-one-of s start (cdr prefixes))]))) 167 | 168 | 169 | ; (start-with-one-of "+>>=" 0 (list ">" #\+)) 170 | 171 | 172 | 173 | (define find-next 174 | (lambda (s start pred) 175 | (cond 176 | [(<= (string-length s) start) #f] 177 | [(pred s start) start] 178 | [else 179 | (find-next s (add1 start) pred)]))) 180 | 181 | 182 | 183 | ; Find the first delim that match the start of s 184 | (define find-delim 185 | (lambda (s start) 186 | (start-with-one-of s start *delims*))) 187 | 188 | 189 | 190 | (define find-operator 191 | (lambda (s start) 192 | (start-with-one-of s start *operators*))) 193 | 194 | ; (find-operator ">> x" 0) 195 | 196 | 197 | 198 | (define scan 199 | (lambda (s) 200 | (define scan1 201 | (lambda (s start) 202 | (cond 203 | [(= start (string-length s)) (values 'eof start)] 204 | [else 205 | (cond 206 | [(start-with-one-of s start *significant-whitespaces*) 207 | (values (Newline start (add1 start)) (add1 start))] 208 | 209 | [(whitespace? (string-ref s start)) 210 | (scan1 s (add1 start))] 211 | 212 | [(start-with-one-of s start *line-comment*) ; line comment 213 | (let ([line-end (find-next s start 214 | (lambda (s start) 215 | (eq? (string-ref s start) #\newline)))]) 216 | (values (Comment (substring s start line-end) 217 | start (add1 line-end)) 218 | line-end))] 219 | 220 | [(start-with s start *comment-start*) ; block comment 221 | (let* ([line-end (find-next s start 222 | (lambda (s start) 223 | (start-with s start *comment-end*)))] 224 | [end (+ line-end (string-length *comment-end*))]) 225 | (values (Comment (substring s start end) start end) end))] 226 | 227 | [(find-delim s start) => 228 | (lambda (delim) 229 | (let ([end (+ start (string-length delim))]) 230 | (values (Token delim start end) end)))] 231 | 232 | [(find-operator s start) => 233 | (lambda (op) 234 | (let ([end (+ start (string-length op))]) 235 | (values (Token op start end) end)))] 236 | 237 | [(start-with-one-of s start *quotation-marks*) ; string 238 | => (lambda (q) (scan-string s start q))] 239 | 240 | [(start-with-one-of s start (list "#\\" "?\\")) ; scheme/elisp char 241 | (cond 242 | [(<= (string-length s) (+ 2 start)) 243 | (error 'scan-string "reached EOF while scanning char")] 244 | [else 245 | (let ([end 246 | (let loop ([end (+ 3 start)]) 247 | (cond 248 | [(or (whitespace? (string-ref s end)) 249 | (delim? (string-ref s end))) 250 | end] 251 | [else (loop (add1 end))]))]) 252 | (values (Char (string-ref s (sub1 end)) start end) end))])] 253 | 254 | [else ; identifier or number 255 | (let loop ([pos start] [chars '()]) 256 | (cond 257 | [(or (<= (string-length s) pos) 258 | (whitespace? (string-ref s pos)) 259 | (find-delim s pos) 260 | (find-operator s pos)) 261 | (let ([text (list->string (reverse chars))]) 262 | (values (Token text start pos) pos))] 263 | [else 264 | (loop (add1 pos) (cons (string-ref s pos) chars))]))])]))) 265 | (let loop ([start 0] [toks '()]) 266 | (letv ([(tok newstart) (scan1 s start)]) 267 | (cond 268 | [(eq? tok 'eof) 269 | (reverse toks)] 270 | [else 271 | (loop newstart (cons tok toks))]))))) 272 | 273 | 274 | 275 | (define scan-string 276 | (lambda (s start quot) 277 | (cond 278 | [(not (eq? quot (string-ref s start))) 279 | (error 'scan-string "string must start with quote")] 280 | [else 281 | (let loop ([next (add1 start)] [chars '()]) 282 | (cond 283 | [(<= (string-length s) next) 284 | (error 'scan-string "reached EOF while scanning string")] 285 | [else 286 | (let ([c (string-ref s next)]) 287 | (cond 288 | [(eq? c quot) 289 | (let ([str (list->string (reverse chars))] 290 | [end (add1 next)]) 291 | (values (Str str start end) end))] 292 | [(eq? c #\\) 293 | (cond 294 | [(<= (string-length s) (add1 next)) 295 | (error 'scan-string "reached EOF while scanning string")] 296 | [else 297 | (loop (+ 2 next) (cons (string-ref s (add1 next)) 298 | (cons #\\ chars)))])] 299 | [else 300 | (loop (add1 next) (cons c chars))]))]))]))) 301 | 302 | 303 | 304 | 305 | 306 | ;------------------------------------------------------------- 307 | ; parser 308 | ;------------------------------------------------------------- 309 | 310 | (define onstack? 311 | (lambda (u v stk) 312 | (let loop ([stk stk] [trace '()]) 313 | (cond 314 | [(null? stk) #f] 315 | [(and (eq? u (car (car stk))) 316 | (eq? v (cdr (car stk)))) 317 | (reverse (cons (car stk) trace))] 318 | [else 319 | (loop (cdr stk) (cons (car stk) trace))])))) 320 | 321 | 322 | 323 | (define stack->string 324 | (lambda (stk) 325 | (let ([ps (map 326 | (lambda (x) (format "~a" (car x))) 327 | stk)]) 328 | (string-join ps "\n")))) 329 | 330 | ; (display (stack->string (onstack? 'x 'y '((u . v) (x . y) (w . t))))) 331 | 332 | 333 | 334 | (define ext 335 | (lambda (u v stk) 336 | (cond 337 | [(not *left-recur-detection*) stk] 338 | [else 339 | (cons (cons u v) stk)]))) 340 | 341 | 342 | 343 | ;; apply parser on toks, check for left-recurson if 344 | ;; *left-recur-detection* is enabled. 345 | (define apply-check 346 | (lambda (parser toks stk ctx) 347 | (cond 348 | [(and *left-recur-detection* 349 | (onstack? parser toks stk)) 350 | => (lambda (t) 351 | (fatal 'apply-check 352 | "left-recursion detected \n" 353 | "parser: " parser "\n" 354 | "start token: " (car toks) "\n" 355 | "stack trace: " (stack->string t)))] 356 | [else 357 | ((parser) toks (ext parser toks stk) ctx)]))) 358 | 359 | 360 | 361 | ;------------------ parser combinators -------------------- 362 | (define @seq 363 | (lambda ps 364 | (lambda () 365 | (lambda (toks stk ctx) 366 | (let loop ([ps ps] [toks toks] [nodes '()]) 367 | (cond 368 | [(null? ps) 369 | (values (apply append (reverse nodes)) toks)] 370 | [else 371 | (letv ([(t r) (apply-check (car ps) toks stk ctx)]) 372 | (cond 373 | [(not t) 374 | (values #f #f)] 375 | [else 376 | (loop (cdr ps) r (cons t nodes))]))])))))) 377 | 378 | 379 | 380 | ;; removes phantoms 381 | (define @... 382 | (lambda ps 383 | (let ([parser ((apply @seq ps))]) 384 | (lambda () 385 | (lambda (toks stk ctx) 386 | (letv ([(t r) (parser toks stk ctx)]) 387 | (cond 388 | [(not t) (values #f #f)] 389 | [else 390 | (values (filter (negate Phantom?) t) r)]))))))) 391 | 392 | 393 | ; (((@seq)) (scan "ok")) 394 | 395 | 396 | 397 | (define @or 398 | (lambda ps 399 | (lambda () 400 | (lambda (toks stk ctx) 401 | (let loop ([ps ps]) 402 | (cond 403 | [(null? ps) 404 | (values #f #f)] 405 | [else 406 | (letv ([(t r) (apply-check (car ps) toks stk ctx)]) 407 | (cond 408 | [(not t) 409 | (loop (cdr ps))] 410 | [else 411 | (values t r)]))])))))) 412 | 413 | 414 | ; (((@or ($$ "foo") ($$ "bar"))) (scan "bar foo")) 415 | 416 | 417 | 418 | (define @= 419 | (lambda (type . ps) 420 | (let ([parser ((apply @seq ps))]) 421 | (lambda () 422 | (lambda (toks stk ctx) 423 | (letv ([(t r) (parser toks stk ctx)]) 424 | (cond 425 | [(not t) (values #f #f)] 426 | [(not type) 427 | (values (filter (negate Phantom?) t) r)] 428 | [(null? t) 429 | (values (list (Expr type '() 430 | (get-start (car toks)) 431 | (get-start (car toks)) )) 432 | r)] 433 | [else 434 | (values (list (Expr type 435 | (filter (negate Phantom?) t) 436 | (get-start (car t)) 437 | (get-end (last t)))) 438 | r)]))))))) 439 | 440 | 441 | 442 | (define @* 443 | (lambda ps 444 | (let ([parser ((apply @... ps))]) 445 | (lambda () 446 | (lambda (toks stk ctx) 447 | (let loop ([toks toks] [nodes '()]) 448 | (cond 449 | [(null? toks) 450 | (values (apply append (reverse nodes)) '())] 451 | [else 452 | (letv ([(t r) (parser toks stk ctx)]) 453 | (cond 454 | [(not t) 455 | (values (apply append (reverse nodes)) toks)] 456 | [else 457 | (loop r (cons t nodes))]))]))))))) 458 | 459 | 460 | ; ($eval (@* ($$ "ok")) (scan "ok ok ok")) 461 | 462 | 463 | (define @+ 464 | (lambda (p) 465 | (@... p (@* p)))) 466 | 467 | ; (((@+ ($$ "ok"))) (scan "ok ok ok")) 468 | 469 | 470 | (define @? 471 | (lambda ps 472 | (@or (apply @... ps) $none))) 473 | 474 | 475 | ; (((@? ($$ "x"))) (scan "x y z")) 476 | 477 | 478 | 479 | (define @! 480 | (lambda ps 481 | (let ([parser ((apply @... ps))]) 482 | (lambda () 483 | (lambda (toks stk ctx) 484 | (letv ([(t r) (parser toks stk ctx)]) 485 | (cond 486 | [(not t) (values (list (car toks)) (cdr toks))] 487 | [else (values #f #f)]))))))) 488 | 489 | 490 | (define @and 491 | (lambda ps 492 | (lambda () 493 | (lambda (toks stk ctx) 494 | (let loop ([ps ps] [res '()]) 495 | (cond 496 | [(null? ps) 497 | (let ([r1 (car res)]) 498 | (values (car r1) (cadr r1)))] 499 | [else 500 | (letv ([(t r) (apply-check (car ps) toks stk ctx)]) 501 | (cond 502 | [(not t) 503 | (values #f #f)] 504 | [else 505 | (loop (cdr ps) (cons (list t r) res))]))])))))) 506 | 507 | 508 | 509 | ; (((@and (@or ($$ "[") ($$ "{")) (@! ($$ "{")))) (scan "[")) 510 | 511 | 512 | (define $glob 513 | (lambda ps 514 | (let ([parser ((apply @... ps))]) 515 | (lambda () 516 | (lambda (toks stk ctx) 517 | (letv ([(t r) (parser toks stk ctx)]) 518 | (cond 519 | [(not t) (values #f #f)] 520 | [else 521 | (values '() r)]))))))) 522 | 523 | 524 | ; (($glob ($$ "foo")) (scan "foo bar")) 525 | 526 | 527 | 528 | (define $phantom 529 | (lambda ps 530 | (let ([parser ((apply @... ps))]) 531 | (lambda () 532 | (lambda (toks stk ctx) 533 | (letv ([(t r) (parser toks stk ctx)]) 534 | (cond 535 | [(not t) (values #f #f)] 536 | [else 537 | (cond 538 | [(null? t) 539 | (values '() r)] 540 | [else 541 | (values (list (Phantom (get-start (car t)) 542 | (get-end (last t)))) 543 | r)])]))))))) 544 | 545 | 546 | 547 | 548 | ;------------------------ parsers --------------------------- 549 | 550 | (define $fail 551 | (lambda () 552 | (lambda (toks stk ctx) 553 | (values #f #f)))) 554 | 555 | 556 | (define $none 557 | (lambda () 558 | (lambda (toks stk ctx) 559 | (values '() toks)))) 560 | 561 | 562 | 563 | (define $pred 564 | (lambda (proc) 565 | (lambda () 566 | (lambda (toks stk ctx) 567 | (cond 568 | [(null? toks) (values #f #f)] 569 | [(proc (car toks)) 570 | (values (list (car toks)) (cdr toks))] 571 | [else 572 | (values #f #f)]))))) 573 | 574 | 575 | (define $eof 576 | ($glob ($pred (lambda (t) (eq? t 'eof))))) 577 | 578 | 579 | (define $$ 580 | (lambda (s) 581 | ($pred 582 | (lambda (x) 583 | (and (Token? x) (string=? (Token-text x) s)))))) 584 | 585 | 586 | (define @_ 587 | (lambda (s) 588 | ($glob ($$ s)))) 589 | 590 | 591 | (define @~ 592 | (lambda (s) 593 | ($phantom ($$ s)))) 594 | 595 | 596 | (define join 597 | (lambda (ps sep) 598 | (cond 599 | [(null? (cdr ps)) ps] 600 | [else 601 | (cons (car ps) (cons sep (join (cdr ps) sep)))]))) 602 | 603 | 604 | (define @.@ 605 | (lambda (p sep) 606 | (@... p (@* (@... sep p))))) 607 | 608 | 609 | 610 | ;; ($eval (@.@ ($$ "foo") ($$ ",")) 611 | ;; (scan "foo, foo,foo ")) 612 | 613 | 614 | 615 | 616 | 617 | ;------------------------------------------------------------- 618 | ; associaltive expressions 619 | ;------------------------------------------------------------- 620 | 621 | 622 | ;; construct left-associative infix expression 623 | (define constr-exp-l 624 | (lambda (type fields) 625 | (let loop ([fields (cdr fields)] [ret (car fields)]) 626 | (cond 627 | [(null? fields) ret] 628 | [else 629 | (let ([e (Expr type (list ret (car fields) (cadr fields)) 630 | (get-start ret) 631 | (get-end (cadr fields)))]) 632 | (loop (cddr fields) e))])))) 633 | 634 | 635 | ;; construct right-associative infix expression 636 | (define constr-exp-r 637 | (lambda (type fields) 638 | (let ([fields (reverse fields)]) 639 | (let loop ([fields (cdr fields)] [ret (car fields)]) 640 | (cond 641 | [(null? fields) ret] 642 | [else 643 | (let ([e (Expr type (list (cadr fields) (car fields) ret) 644 | (get-start (cadr fields)) 645 | (get-end ret))]) 646 | (loop (cddr fields) e))]))))) 647 | 648 | 649 | (define @infix 650 | (lambda (type p op associativity) 651 | (lambda () 652 | (lambda (toks stk ctx) 653 | (let loop ([rest toks] [ret '()]) 654 | (letv ([(tp rp) (((@seq p)) rest stk ctx)]) 655 | (cond 656 | [(not tp) 657 | (cond 658 | [(< (length ret) 3) 659 | (values #f #f)] 660 | [else 661 | (let ([fields (reverse (cdr ret))] 662 | [constr (if (eq? associativity 'left) 663 | constr-exp-l 664 | constr-exp-r)]) 665 | (values (list (constr type fields)) 666 | (cons (car ret) rest)))])] 667 | [else 668 | (letv ([(top rop) (((@seq op)) rp stk ctx)]) 669 | (cond 670 | [(not top) 671 | (cond 672 | [(< (length ret) 2) 673 | (values #f #f)] 674 | [else 675 | (let ([fields (reverse (append tp ret))] 676 | [constr (if (eq? associativity 'left) 677 | constr-exp-l 678 | constr-exp-r)]) 679 | (values (list (constr type fields)) 680 | rp))])] 681 | [else 682 | (loop rop (append (append top tp) ret))]))]))))))) 683 | 684 | 685 | (define @infix-left 686 | (lambda (type p op) 687 | (@infix type p op 'left))) 688 | 689 | 690 | (define @infix-right 691 | (lambda (type p op) 692 | (@infix type p op 'right))) 693 | 694 | 695 | 696 | ;; ($eval (@infix-right 'binop $multiplicative-expression $additive-operator) 697 | ;; (scan "x + y + z")) 698 | 699 | 700 | 701 | 702 | (define @postfix 703 | (lambda (type p op) 704 | (lambda () 705 | (lambda (toks stk ctx) 706 | (letv ([(t r) (((@... p (@+ op))) toks stk ctx)]) 707 | (cond 708 | [(not t) 709 | (values #f #f)] 710 | [else 711 | (values (list (make-postfix type t)) r)])))))) 712 | 713 | 714 | ;; ($eval (@postfix 'ok ($$ "foo") (@= 'bar ($$ "bar")) 'ok) 715 | ;; (scan "foo bar bar")) 716 | 717 | 718 | (define make-postfix 719 | (lambda (type ls) 720 | (let loop ([ls (cdr ls)] [ret (car ls)]) 721 | (cond 722 | [(null? ls) ret] 723 | [else 724 | (let ([e (Expr type 725 | (list ret (car ls)) 726 | (get-start ret) 727 | (get-end (car ls)))]) 728 | (loop (cdr ls) e))])))) 729 | 730 | 731 | (define @prefix 732 | (lambda (type p op) 733 | (lambda () 734 | (lambda (toks stk ctx) 735 | (letv ([(t r) (((@... (@+ op) p)) toks stk ctx)]) 736 | (cond 737 | [(not t) 738 | (values #f #f)] 739 | [else 740 | (values (list (make-prefix type t)) r)])))))) 741 | 742 | 743 | (define make-prefix 744 | (lambda (type ls) 745 | (cond 746 | [(null? (cdr ls)) (car ls)] 747 | [else 748 | (let ([tail (make-prefix type (cdr ls))]) 749 | (Expr type 750 | (list (car ls) tail) 751 | (get-start (car ls)) 752 | (get-end tail)))]))) 753 | 754 | 755 | ;; ($eval (@prefix 'prefix $primary-expression $prefix-operator) 756 | ;; (scan "-1")) 757 | 758 | 759 | 760 | ;;----------------- syntax extensions -------------------- 761 | 762 | (define *parse-hash* (make-hasheq)) 763 | 764 | 765 | (define-syntax :: 766 | (syntax-rules () 767 | [(_ name expr) 768 | (define name 769 | (lambda () 770 | (lambda (toks stk ctx) 771 | (cond 772 | [(hash-get *parse-hash* name toks) 773 | => (lambda (p) 774 | (values (car p) (cdr p)))] 775 | [else 776 | (letv ([(t r) ((expr) toks stk ctx)]) 777 | (hash-put! *parse-hash* name toks (cons t r)) 778 | (values t r))]))))])) 779 | 780 | 781 | 782 | (define-syntax ::= 783 | (syntax-rules () 784 | [(_ name type expr ...) 785 | (define name 786 | (cond 787 | [(symbol? type) 788 | (lambda () 789 | (lambda (toks stk ctx) 790 | (cond 791 | [(hash-get *parse-hash* name toks) 792 | => (lambda (p) 793 | (values (car p) (cdr p)))] 794 | [else 795 | (letv ([parser (@= type expr ...)] 796 | [(t r) ((parser) toks stk (cons 'name ctx))]) 797 | (hash-put! *parse-hash* name toks (cons t r)) 798 | (values t r))])))] 799 | [else 800 | (fatal '::= "type must be a symbol, but got: " type)]))])) 801 | 802 | 803 | 804 | 805 | 806 | ;;---------------- context sensitive parsing ---------------- 807 | 808 | ;; succeed only in certain context 809 | (define-syntax ::? 810 | (syntax-rules () 811 | [(_ name effective-ctx expr) 812 | (define name 813 | (lambda () 814 | (lambda (toks stk ctx) 815 | (cond 816 | [(not (memq 'effective-ctx ctx)) 817 | (values #f #f)] 818 | [(hash-get *parse-hash* name toks) 819 | => (lambda (p) 820 | (values (car p) (cdr p)))] 821 | [else 822 | (letv ([(t r) ((expr) toks stk (cons 'name ctx))]) 823 | (hash-put! *parse-hash* name toks t r) 824 | (values t r))]))))])) 825 | 826 | 827 | 828 | ;; fail if in avoid-ctx 829 | (define-syntax ::! 830 | (syntax-rules () 831 | [(_ name avoid-ctx expr) 832 | (define name 833 | (lambda () 834 | (lambda (toks stk ctx) 835 | (cond 836 | [(memq 'avoid-ctx ctx) 837 | (values #f #f)] 838 | [(hash-get *parse-hash* name toks) 839 | => (lambda (p) 840 | (values (car p) (cdr p)))] 841 | [else 842 | (letv ([(t r) ((expr) toks stk (cons 'name ctx))]) 843 | (hash-put! *parse-hash* name toks t r) 844 | (values t r))]))))])) 845 | 846 | 847 | 848 | ;; (::= $foo 849 | ;; (@= 'foo (@... $bar ($$ "foo")))) 850 | 851 | ;; (::? $bar $baz 852 | ;; ($$ "bar")) 853 | 854 | ;; (::= $baz 855 | ;; (@= 'baz (@... $bar ($$ "baz")))) 856 | 857 | 858 | ;; ($eval $bar (scan "bar foo")) 859 | ;; ($eval $foo (scan "bar foo")) 860 | ;; ($eval $baz (scan "bar baz")) ; only this one succeeds 861 | 862 | 863 | ;; (::! $avoid-foo $foo 864 | ;; (@= 'avoid-foo ($$ "avoid-foo"))) 865 | 866 | ;; (::= $foo 867 | ;; (@= 'foo (@... $avoid-foo ($$ "foo")))) 868 | 869 | ;; (::= $not-foo 870 | ;; (@= 'not-foo (@... $avoid-foo ($$ "not-foo")))) 871 | 872 | 873 | ;; ($eval $foo (scan "avoid-foo foo")) ; $avoid-foo fails only in foo 874 | ;; ($eval $not-foo (scan "avoid-foo not-foo")) 875 | 876 | 877 | 878 | 879 | 880 | (define $eval 881 | (lambda (p toks) 882 | (set! *parse-hash* (make-hasheq)) 883 | (letv ([(t r) ((p) toks '() '())]) 884 | (set! *parse-hash* (make-hasheq)) 885 | (values t r)))) 886 | 887 | 888 | (define parse1 889 | (lambda (p s) 890 | (letv ([(t r) ($eval p (filter (lambda (x) (not (Comment? x))) 891 | (scan s)))]) 892 | t))) 893 | 894 | 895 | 896 | 897 | 898 | 899 | ;------------------------------------------------------------- 900 | ; testing facilities 901 | ;------------------------------------------------------------- 902 | 903 | (define test-string 904 | (lambda (s) 905 | (letv ([(t r) ($eval $program 906 | (filter (lambda (x) (not (Comment? x))) 907 | (scan s)))]) 908 | (cond 909 | [(null? r) #t] 910 | [(not r) #f] 911 | [else (car r)])))) 912 | 913 | 914 | (define test-file1 915 | (lambda (file) 916 | (printf "testing file: ~a ... " file) 917 | (let ([start (current-seconds)]) 918 | (flush-output) 919 | (let ([res (test-string (read-file file))]) 920 | (cond 921 | [(eq? #t res) 922 | (printf "succeed.~ntime used: ~a seconds~n" 923 | (- (current-seconds) start)) 924 | (flush-output)] 925 | [else 926 | (printf "failed at token: ~a~n" res) 927 | (flush-output)]))))) 928 | 929 | 930 | (define test-file 931 | (lambda files 932 | (for-each test-file1 files))) 933 | 934 | 935 | 936 | ;-------------------------- examples --------------------------- 937 | 938 | ; a parser for s-expressions 939 | 940 | (:: $open 941 | (@or (@~ "(") (@~ "["))) 942 | 943 | (:: $close 944 | (@or (@~ ")") (@~ "]"))) 945 | 946 | (:: $non-parens 947 | (@and (@! $open) (@! $close))) 948 | 949 | (:: $parens 950 | (@... $open (@* $sexp) $close)) 951 | 952 | (::= $sexp 'sexp 953 | (@+ (@or $non-parens $parens))) 954 | 955 | (::= $program 'program 956 | $sexp) 957 | 958 | 959 | (define parse-sexp 960 | (lambda (s) 961 | (first-val ($eval $program (scan s))))) 962 | 963 | 964 | ;; (parse-sexp (read-file "paredit20.el")) 965 | 966 | ;; (parse-sexp "(lambda (x) x)") 967 | 968 | 969 | 970 | 971 | ;;-------------------------------------------- 972 | ;; direct left recursion 973 | ;; (::= $left 'left 974 | ;; (@or (@seq $left ($$ "ok")) 975 | ;; ($$ "ok"))) 976 | 977 | ;; ($eval $left (scan "ok")) 978 | 979 | 980 | ;;-------------------------------------------- 981 | ;; indirect left-recursion 982 | ;; (::= $left1 'left1 983 | ;; (@seq $left2 ($$ "ok"))) 984 | 985 | ;; (::= $left2 'left2 986 | ;; (@or (@seq $left1 ($$ "ok")) 987 | ;; ($$ "ok"))) 988 | 989 | ;; ($eval $left1 (scan "ok ok")) 990 | 991 | -------------------------------------------------------------------------------- /utils.ss: -------------------------------------------------------------------------------- 1 | ;; yDiff - a language-aware tool for comparing programs 2 | ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) 3 | 4 | 5 | ;; This program is free software: you can redistribute it and/or modify 6 | ;; it under the terms of the GNU General Public License as published by 7 | ;; the Free Software Foundation, either version 3 of the License, or 8 | ;; (at your option) any later version. 9 | 10 | ;; This program is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;; GNU General Public License for more details. 14 | 15 | ;; You should have received a copy of the GNU General Public License 16 | ;; along with this program. If not, see . 17 | 18 | 19 | 20 | 21 | ;------------------------------------------------------------- 22 | ; utilities 23 | ;------------------------------------------------------------- 24 | 25 | (define-syntax letv 26 | (syntax-rules () 27 | [(_ () body ...) 28 | (begin body ...)] 29 | [(_ ([(e1 e2* ...) e3] bd* ...) body ...) 30 | (let-values ([(e1 e2* ...) e3]) 31 | (letv (bd* ...) body ...))] 32 | [(_ ([e1 e2] bd* ...) body ...) 33 | (let ([e1 e2]) 34 | (letv (bd* ...) body ...))])) 35 | 36 | 37 | (define-syntax first-val 38 | (syntax-rules () 39 | [(_ e) 40 | (letv ([(x y) e]) x)])) 41 | 42 | 43 | (define-syntax second-val 44 | (syntax-rules () 45 | [(_ e) 46 | (letv ([(x y) e]) y)])) 47 | 48 | 49 | (define *debug* #f) 50 | (define-syntax peek 51 | (syntax-rules () 52 | [(_ name args ...) 53 | (if *debug* 54 | (begin 55 | (printf "~s: ~s = ~s~n" name 'args args) 56 | ...) 57 | (void))])) 58 | 59 | 60 | ;; utility for error reporting 61 | (define fatal 62 | (lambda (who . args) 63 | (printf "~s: " who) 64 | (for-each display args) 65 | (display "\n") 66 | (error who ""))) 67 | 68 | 69 | ; foldl of Racket has a bug! 70 | ; (foldl (lambda (x y) x) 0 '(1 2 3 4)) 71 | ; => 4 72 | ; Don't use it! 73 | (define foldl2 74 | (lambda (f x ls) 75 | (cond 76 | [(null? ls) x] 77 | [else 78 | (foldl2 f (f x (car ls)) (cdr ls))]))) 79 | 80 | 81 | ; (foldl2 + 0 '(1 2 3 4 )) 82 | 83 | 84 | 85 | (define orf 86 | (lambda (a b) 87 | (or a b))) 88 | 89 | 90 | 91 | 92 | (define char->string 93 | (lambda (c) 94 | (list->string (list c)))) 95 | 96 | 97 | (define read-file 98 | (lambda (filename) 99 | (let ([port (open-input-file filename #:mode 'text)]) 100 | (let loop ([line (read-line port)] 101 | [all ""]) 102 | (cond 103 | [(eof-object? line) all] 104 | [else 105 | (loop (read-line port) 106 | (string-append all line "\n"))]))))) 107 | 108 | 109 | 110 | (define new-progress 111 | (lambda (size) 112 | (let ([counter 0]) 113 | (lambda (x) 114 | (cond 115 | [(string? x) 116 | (display x) 117 | (display "\n") 118 | (flush-output)] 119 | [(= 0 (remainder counter size)) 120 | (set! counter (+ x counter)) 121 | (display ".") 122 | (flush-output)] 123 | [else 124 | (set! counter (+ x counter))]))))) 125 | 126 | 127 | ;;----------------- multi dimensional eq hash -------------------- 128 | 129 | (define hash-put! 130 | (lambda (hash key1 key2 v) 131 | (cond 132 | [(hash-has-key? hash key2) 133 | (let ([inner (hash-ref hash key2)]) 134 | (hash-set! inner key1 v))] 135 | [else 136 | (let ([inner (make-hasheq)]) 137 | (hash-set! inner key1 v) 138 | (hash-set! hash key2 inner))]))) 139 | 140 | (define hash-get 141 | (lambda (hash key1 key2) 142 | (cond 143 | [(hash-has-key? hash key2) 144 | (let ([inner (hash-ref hash key2)]) 145 | (cond 146 | [(hash-has-key? inner key1) 147 | (hash-ref inner key1)] 148 | [else #f]))] 149 | [else #f]))) 150 | 151 | 152 | (define hash-put2! 153 | (lambda (hash key1 key2 v) 154 | (cond 155 | [(hash-has-key? hash key2) 156 | (let ([inner (hash-ref hash key2)]) 157 | (hash-set! inner key1 v))] 158 | [else 159 | (let ([inner (make-hash)]) 160 | (hash-set! inner key1 v) 161 | (hash-set! hash key2 inner))]))) 162 | 163 | (define hash-get2 164 | (lambda (hash key1 key2) 165 | (cond 166 | [(hash-has-key? hash key2) 167 | (let ([inner (hash-ref hash key2)]) 168 | (cond 169 | [(hash-has-key? inner key1) 170 | (hash-ref inner key1)] 171 | [else #f]))] 172 | [else #f]))) 173 | 174 | 175 | (define predand 176 | (lambda preds 177 | (lambda (x) 178 | (cond 179 | [(null? preds) #t] 180 | [((car preds) x) 181 | ((apply predand (cdr preds)) x)] 182 | [else #f])))) 183 | 184 | 185 | (define predor 186 | (lambda preds 187 | (lambda (x) 188 | (cond 189 | [(null? preds) #f] 190 | [((car preds) x) #t] 191 | [else 192 | ((apply predor (cdr preds)) x)])))) 193 | 194 | 195 | (define set- 196 | (lambda (s1 s2) 197 | (cond 198 | [(null? s1) '()] 199 | [(memq (car s1) s2) 200 | (set- (cdr s1) s2)] 201 | [else 202 | (cons (car s1) (set- (cdr s1) s2))]))) 203 | 204 | 205 | 206 | (define string-join 207 | (lambda (ls sep) 208 | (cond 209 | [(null? ls) ""] 210 | [else 211 | (string-append (car ls) sep (string-join (cdr ls) sep))]))) 212 | 213 | ; (string-join (list "a" "b" "c") ",") 214 | 215 | --------------------------------------------------------------------------------