├── .dir-locals.el ├── .gitignore ├── COPYING ├── README ├── contributors ├── docs ├── LICENSE ├── introduction.lisp ├── reference.html └── tutorial.html ├── extras ├── firebug-tracing.lisp ├── js-expander.el └── swank-parenscript.lisp ├── parenscript.asd ├── parenscript.tests.asd ├── runtime └── ps-runtime-lib.lisp ├── src ├── compilation-interface.lisp ├── compiler.lisp ├── deprecated-interface.lisp ├── function-definition.lisp ├── js-dom-symbol-exports.lisp ├── js-ir-package.lisp ├── lib │ ├── ps-dom.lisp │ ├── ps-html.lisp │ └── ps-loop.lisp ├── macros.lisp ├── namespace.lisp ├── non-cl.lisp ├── package.lisp ├── parse-lambda-list.lisp ├── printer.lisp ├── special-operators.lisp └── utils.lisp └── tests ├── eval-tests.lisp ├── output-tests.lisp ├── package-system-tests.lisp ├── test-package.lisp └── test.lisp /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((nil 5 | (indent-tabs-mode) 6 | (fill-column . 69)) 7 | (lisp-mode 8 | (eval put 'test-ps-js 'common-lisp-indent-function 1) 9 | (eval put 'test-js-eval 'common-lisp-indent-function 1))) 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.*fsl 2 | *.*fasl 3 | *~ 4 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005 Manuel Odendahl 2 | Copyright (c) 2005-2006 Edward Marco Baringer 3 | Copyright (c) 2007-2013, 2018 Vladimir Sedach 4 | Copyright (c) 2008, 2009 Travis Cross 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are 8 | met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 17 | 3. Neither the name of the copyright holder nor the names of its 18 | contributors may be used to endorse or promote products derived from 19 | this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Parenscript is a translator from an extended subset of Common Lisp to 2 | JavaScript. Parenscript code can run almost identically on both the 3 | browser (as JavaScript) and server (as Common Lisp). 4 | 5 | Parenscript code is treated the same way as Common Lisp code, making 6 | the full power of Lisp macros available for JavaScript. This provides 7 | a web development environment that is unmatched in its ability to 8 | reduce code duplication and provide advanced meta-programming 9 | facilities to web developers. 10 | 11 | At the same time, Parenscript is different from almost all other 12 | "language X" to JavaScript translators in that it imposes almost no 13 | overhead: 14 | 15 | No run-time dependencies: 16 | Any piece of Parenscript code is runnable as-is. There are no 17 | JavaScript files to include. 18 | Native types: 19 | Parenscript works entirely with native JavaScript data types. There 20 | are no new types introduced, and object prototypes are not 21 | touched. 22 | Native calling convention: 23 | Any JavaScript code can be called without the need for 24 | bindings. Likewise, Parenscript can be used to make efficient, 25 | self-contained JavaScript libraries. 26 | Readable code: 27 | Parenscript generates concise, formatted, idiomatic JavaScript 28 | code. Identifier names are preserved. This enables seamless 29 | use of JavaScript debuggers. 30 | Efficiency: 31 | Parenscript introduces minimal overhead for advanced Common Lisp 32 | features. The generated code is almost as fast as hand-written 33 | JavaScript. 34 | 35 | Parenscript is available via Quicklisp: 36 | (ql:quickload :parenscript) 37 | 38 | To run unit tests: 39 | (ql:quickload :parenscript.tests) 40 | (parenscript.tests:run-tests) 41 | 42 | Contributing: 43 | Please send patches and bug reports to the mailing list: 44 | parenscript-devel@common-lisp.net 45 | 46 | Documentation: 47 | See docs/tutorial.html and docs/reference.html 48 | Mailing list: 49 | parenscript-devel@common-lisp.net 50 | https://mailman.common-lisp.net/listinfo/parenscript-devel 51 | Web site: 52 | http://common-lisp.net/project/parenscript/ 53 | Source repository: 54 | https://gitlab.common-lisp.net/parenscript/parenscript.git 55 | License: 56 | BSD-3-Clause, see the file COPYING 57 | -------------------------------------------------------------------------------- /contributors: -------------------------------------------------------------------------------- 1 | This is a list of people who have contributed to the ParenScript 2 | project. Please contact the maintainer if you see any errors or 3 | omissions. 4 | 5 | Manuel Odendahl 6 | Marco Baringer 7 | Ivan Toshkov 8 | Luca Capello 9 | Alan Shields 10 | Henrik Hjelte 11 | Attila Lendvai 12 | Marijn Haverbeke 13 | Vladimir Sedach 14 | John Fremlin 15 | Red Daly 16 | Travis Cross 17 | Daniel Gackle 18 | William Halliburton 19 | Scott Bell 20 | Bart Botta 21 | Boris Smilga 22 | Russell Sim 23 | -------------------------------------------------------------------------------- /docs/LICENSE: -------------------------------------------------------------------------------- 1 | 2 | GNU Free Documentation License 3 | Version 1.3, 3 November 2008 4 | 5 | 6 | Copyright (C) 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc. 7 | 8 | Everyone is permitted to copy and distribute verbatim copies 9 | of this license document, but changing it is not allowed. 10 | 11 | 0. PREAMBLE 12 | 13 | The purpose of this License is to make a manual, textbook, or other 14 | functional and useful document "free" in the sense of freedom: to 15 | assure everyone the effective freedom to copy and redistribute it, 16 | with or without modifying it, either commercially or noncommercially. 17 | Secondarily, this License preserves for the author and publisher a way 18 | to get credit for their work, while not being considered responsible 19 | for modifications made by others. 20 | 21 | This License is a kind of "copyleft", which means that derivative 22 | works of the document must themselves be free in the same sense. It 23 | complements the GNU General Public License, which is a copyleft 24 | license designed for free software. 25 | 26 | We have designed this License in order to use it for manuals for free 27 | software, because free software needs free documentation: a free 28 | program should come with manuals providing the same freedoms that the 29 | software does. But this License is not limited to software manuals; 30 | it can be used for any textual work, regardless of subject matter or 31 | whether it is published as a printed book. We recommend this License 32 | principally for works whose purpose is instruction or reference. 33 | 34 | 35 | 1. APPLICABILITY AND DEFINITIONS 36 | 37 | This License applies to any manual or other work, in any medium, that 38 | contains a notice placed by the copyright holder saying it can be 39 | distributed under the terms of this License. Such a notice grants a 40 | world-wide, royalty-free license, unlimited in duration, to use that 41 | work under the conditions stated herein. The "Document", below, 42 | refers to any such manual or work. Any member of the public is a 43 | licensee, and is addressed as "you". You accept the license if you 44 | copy, modify or distribute the work in a way requiring permission 45 | under copyright law. 46 | 47 | A "Modified Version" of the Document means any work containing the 48 | Document or a portion of it, either copied verbatim, or with 49 | modifications and/or translated into another language. 50 | 51 | A "Secondary Section" is a named appendix or a front-matter section of 52 | the Document that deals exclusively with the relationship of the 53 | publishers or authors of the Document to the Document's overall 54 | subject (or to related matters) and contains nothing that could fall 55 | directly within that overall subject. (Thus, if the Document is in 56 | part a textbook of mathematics, a Secondary Section may not explain 57 | any mathematics.) The relationship could be a matter of historical 58 | connection with the subject or with related matters, or of legal, 59 | commercial, philosophical, ethical or political position regarding 60 | them. 61 | 62 | The "Invariant Sections" are certain Secondary Sections whose titles 63 | are designated, as being those of Invariant Sections, in the notice 64 | that says that the Document is released under this License. If a 65 | section does not fit the above definition of Secondary then it is not 66 | allowed to be designated as Invariant. The Document may contain zero 67 | Invariant Sections. If the Document does not identify any Invariant 68 | Sections then there are none. 69 | 70 | The "Cover Texts" are certain short passages of text that are listed, 71 | as Front-Cover Texts or Back-Cover Texts, in the notice that says that 72 | the Document is released under this License. A Front-Cover Text may 73 | be at most 5 words, and a Back-Cover Text may be at most 25 words. 74 | 75 | A "Transparent" copy of the Document means a machine-readable copy, 76 | represented in a format whose specification is available to the 77 | general public, that is suitable for revising the document 78 | straightforwardly with generic text editors or (for images composed of 79 | pixels) generic paint programs or (for drawings) some widely available 80 | drawing editor, and that is suitable for input to text formatters or 81 | for automatic translation to a variety of formats suitable for input 82 | to text formatters. A copy made in an otherwise Transparent file 83 | format whose markup, or absence of markup, has been arranged to thwart 84 | or discourage subsequent modification by readers is not Transparent. 85 | An image format is not Transparent if used for any substantial amount 86 | of text. A copy that is not "Transparent" is called "Opaque". 87 | 88 | Examples of suitable formats for Transparent copies include plain 89 | ASCII without markup, Texinfo input format, LaTeX input format, SGML 90 | or XML using a publicly available DTD, and standard-conforming simple 91 | HTML, PostScript or PDF designed for human modification. Examples of 92 | transparent image formats include PNG, XCF and JPG. Opaque formats 93 | include proprietary formats that can be read and edited only by 94 | proprietary word processors, SGML or XML for which the DTD and/or 95 | processing tools are not generally available, and the 96 | machine-generated HTML, PostScript or PDF produced by some word 97 | processors for output purposes only. 98 | 99 | The "Title Page" means, for a printed book, the title page itself, 100 | plus such following pages as are needed to hold, legibly, the material 101 | this License requires to appear in the title page. For works in 102 | formats which do not have any title page as such, "Title Page" means 103 | the text near the most prominent appearance of the work's title, 104 | preceding the beginning of the body of the text. 105 | 106 | The "publisher" means any person or entity that distributes copies of 107 | the Document to the public. 108 | 109 | A section "Entitled XYZ" means a named subunit of the Document whose 110 | title either is precisely XYZ or contains XYZ in parentheses following 111 | text that translates XYZ in another language. (Here XYZ stands for a 112 | specific section name mentioned below, such as "Acknowledgements", 113 | "Dedications", "Endorsements", or "History".) To "Preserve the Title" 114 | of such a section when you modify the Document means that it remains a 115 | section "Entitled XYZ" according to this definition. 116 | 117 | The Document may include Warranty Disclaimers next to the notice which 118 | states that this License applies to the Document. These Warranty 119 | Disclaimers are considered to be included by reference in this 120 | License, but only as regards disclaiming warranties: any other 121 | implication that these Warranty Disclaimers may have is void and has 122 | no effect on the meaning of this License. 123 | 124 | 2. VERBATIM COPYING 125 | 126 | You may copy and distribute the Document in any medium, either 127 | commercially or noncommercially, provided that this License, the 128 | copyright notices, and the license notice saying this License applies 129 | to the Document are reproduced in all copies, and that you add no 130 | other conditions whatsoever to those of this License. You may not use 131 | technical measures to obstruct or control the reading or further 132 | copying of the copies you make or distribute. However, you may accept 133 | compensation in exchange for copies. If you distribute a large enough 134 | number of copies you must also follow the conditions in section 3. 135 | 136 | You may also lend copies, under the same conditions stated above, and 137 | you may publicly display copies. 138 | 139 | 140 | 3. COPYING IN QUANTITY 141 | 142 | If you publish printed copies (or copies in media that commonly have 143 | printed covers) of the Document, numbering more than 100, and the 144 | Document's license notice requires Cover Texts, you must enclose the 145 | copies in covers that carry, clearly and legibly, all these Cover 146 | Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on 147 | the back cover. Both covers must also clearly and legibly identify 148 | you as the publisher of these copies. The front cover must present 149 | the full title with all words of the title equally prominent and 150 | visible. You may add other material on the covers in addition. 151 | Copying with changes limited to the covers, as long as they preserve 152 | the title of the Document and satisfy these conditions, can be treated 153 | as verbatim copying in other respects. 154 | 155 | If the required texts for either cover are too voluminous to fit 156 | legibly, you should put the first ones listed (as many as fit 157 | reasonably) on the actual cover, and continue the rest onto adjacent 158 | pages. 159 | 160 | If you publish or distribute Opaque copies of the Document numbering 161 | more than 100, you must either include a machine-readable Transparent 162 | copy along with each Opaque copy, or state in or with each Opaque copy 163 | a computer-network location from which the general network-using 164 | public has access to download using public-standard network protocols 165 | a complete Transparent copy of the Document, free of added material. 166 | If you use the latter option, you must take reasonably prudent steps, 167 | when you begin distribution of Opaque copies in quantity, to ensure 168 | that this Transparent copy will remain thus accessible at the stated 169 | location until at least one year after the last time you distribute an 170 | Opaque copy (directly or through your agents or retailers) of that 171 | edition to the public. 172 | 173 | It is requested, but not required, that you contact the authors of the 174 | Document well before redistributing any large number of copies, to 175 | give them a chance to provide you with an updated version of the 176 | Document. 177 | 178 | 179 | 4. MODIFICATIONS 180 | 181 | You may copy and distribute a Modified Version of the Document under 182 | the conditions of sections 2 and 3 above, provided that you release 183 | the Modified Version under precisely this License, with the Modified 184 | Version filling the role of the Document, thus licensing distribution 185 | and modification of the Modified Version to whoever possesses a copy 186 | of it. In addition, you must do these things in the Modified Version: 187 | 188 | A. Use in the Title Page (and on the covers, if any) a title distinct 189 | from that of the Document, and from those of previous versions 190 | (which should, if there were any, be listed in the History section 191 | of the Document). You may use the same title as a previous version 192 | if the original publisher of that version gives permission. 193 | B. List on the Title Page, as authors, one or more persons or entities 194 | responsible for authorship of the modifications in the Modified 195 | Version, together with at least five of the principal authors of the 196 | Document (all of its principal authors, if it has fewer than five), 197 | unless they release you from this requirement. 198 | C. State on the Title page the name of the publisher of the 199 | Modified Version, as the publisher. 200 | D. Preserve all the copyright notices of the Document. 201 | E. Add an appropriate copyright notice for your modifications 202 | adjacent to the other copyright notices. 203 | F. Include, immediately after the copyright notices, a license notice 204 | giving the public permission to use the Modified Version under the 205 | terms of this License, in the form shown in the Addendum below. 206 | G. Preserve in that license notice the full lists of Invariant Sections 207 | and required Cover Texts given in the Document's license notice. 208 | H. Include an unaltered copy of this License. 209 | I. Preserve the section Entitled "History", Preserve its Title, and add 210 | to it an item stating at least the title, year, new authors, and 211 | publisher of the Modified Version as given on the Title Page. If 212 | there is no section Entitled "History" in the Document, create one 213 | stating the title, year, authors, and publisher of the Document as 214 | given on its Title Page, then add an item describing the Modified 215 | Version as stated in the previous sentence. 216 | J. Preserve the network location, if any, given in the Document for 217 | public access to a Transparent copy of the Document, and likewise 218 | the network locations given in the Document for previous versions 219 | it was based on. These may be placed in the "History" section. 220 | You may omit a network location for a work that was published at 221 | least four years before the Document itself, or if the original 222 | publisher of the version it refers to gives permission. 223 | K. For any section Entitled "Acknowledgements" or "Dedications", 224 | Preserve the Title of the section, and preserve in the section all 225 | the substance and tone of each of the contributor acknowledgements 226 | and/or dedications given therein. 227 | L. Preserve all the Invariant Sections of the Document, 228 | unaltered in their text and in their titles. Section numbers 229 | or the equivalent are not considered part of the section titles. 230 | M. Delete any section Entitled "Endorsements". Such a section 231 | may not be included in the Modified Version. 232 | N. Do not retitle any existing section to be Entitled "Endorsements" 233 | or to conflict in title with any Invariant Section. 234 | O. Preserve any Warranty Disclaimers. 235 | 236 | If the Modified Version includes new front-matter sections or 237 | appendices that qualify as Secondary Sections and contain no material 238 | copied from the Document, you may at your option designate some or all 239 | of these sections as invariant. To do this, add their titles to the 240 | list of Invariant Sections in the Modified Version's license notice. 241 | These titles must be distinct from any other section titles. 242 | 243 | You may add a section Entitled "Endorsements", provided it contains 244 | nothing but endorsements of your Modified Version by various 245 | parties--for example, statements of peer review or that the text has 246 | been approved by an organization as the authoritative definition of a 247 | standard. 248 | 249 | You may add a passage of up to five words as a Front-Cover Text, and a 250 | passage of up to 25 words as a Back-Cover Text, to the end of the list 251 | of Cover Texts in the Modified Version. Only one passage of 252 | Front-Cover Text and one of Back-Cover Text may be added by (or 253 | through arrangements made by) any one entity. If the Document already 254 | includes a cover text for the same cover, previously added by you or 255 | by arrangement made by the same entity you are acting on behalf of, 256 | you may not add another; but you may replace the old one, on explicit 257 | permission from the previous publisher that added the old one. 258 | 259 | The author(s) and publisher(s) of the Document do not by this License 260 | give permission to use their names for publicity for or to assert or 261 | imply endorsement of any Modified Version. 262 | 263 | 264 | 5. COMBINING DOCUMENTS 265 | 266 | You may combine the Document with other documents released under this 267 | License, under the terms defined in section 4 above for modified 268 | versions, provided that you include in the combination all of the 269 | Invariant Sections of all of the original documents, unmodified, and 270 | list them all as Invariant Sections of your combined work in its 271 | license notice, and that you preserve all their Warranty Disclaimers. 272 | 273 | The combined work need only contain one copy of this License, and 274 | multiple identical Invariant Sections may be replaced with a single 275 | copy. If there are multiple Invariant Sections with the same name but 276 | different contents, make the title of each such section unique by 277 | adding at the end of it, in parentheses, the name of the original 278 | author or publisher of that section if known, or else a unique number. 279 | Make the same adjustment to the section titles in the list of 280 | Invariant Sections in the license notice of the combined work. 281 | 282 | In the combination, you must combine any sections Entitled "History" 283 | in the various original documents, forming one section Entitled 284 | "History"; likewise combine any sections Entitled "Acknowledgements", 285 | and any sections Entitled "Dedications". You must delete all sections 286 | Entitled "Endorsements". 287 | 288 | 289 | 6. COLLECTIONS OF DOCUMENTS 290 | 291 | You may make a collection consisting of the Document and other 292 | documents released under this License, and replace the individual 293 | copies of this License in the various documents with a single copy 294 | that is included in the collection, provided that you follow the rules 295 | of this License for verbatim copying of each of the documents in all 296 | other respects. 297 | 298 | You may extract a single document from such a collection, and 299 | distribute it individually under this License, provided you insert a 300 | copy of this License into the extracted document, and follow this 301 | License in all other respects regarding verbatim copying of that 302 | document. 303 | 304 | 305 | 7. AGGREGATION WITH INDEPENDENT WORKS 306 | 307 | A compilation of the Document or its derivatives with other separate 308 | and independent documents or works, in or on a volume of a storage or 309 | distribution medium, is called an "aggregate" if the copyright 310 | resulting from the compilation is not used to limit the legal rights 311 | of the compilation's users beyond what the individual works permit. 312 | When the Document is included in an aggregate, this License does not 313 | apply to the other works in the aggregate which are not themselves 314 | derivative works of the Document. 315 | 316 | If the Cover Text requirement of section 3 is applicable to these 317 | copies of the Document, then if the Document is less than one half of 318 | the entire aggregate, the Document's Cover Texts may be placed on 319 | covers that bracket the Document within the aggregate, or the 320 | electronic equivalent of covers if the Document is in electronic form. 321 | Otherwise they must appear on printed covers that bracket the whole 322 | aggregate. 323 | 324 | 325 | 8. TRANSLATION 326 | 327 | Translation is considered a kind of modification, so you may 328 | distribute translations of the Document under the terms of section 4. 329 | Replacing Invariant Sections with translations requires special 330 | permission from their copyright holders, but you may include 331 | translations of some or all Invariant Sections in addition to the 332 | original versions of these Invariant Sections. You may include a 333 | translation of this License, and all the license notices in the 334 | Document, and any Warranty Disclaimers, provided that you also include 335 | the original English version of this License and the original versions 336 | of those notices and disclaimers. In case of a disagreement between 337 | the translation and the original version of this License or a notice 338 | or disclaimer, the original version will prevail. 339 | 340 | If a section in the Document is Entitled "Acknowledgements", 341 | "Dedications", or "History", the requirement (section 4) to Preserve 342 | its Title (section 1) will typically require changing the actual 343 | title. 344 | 345 | 346 | 9. TERMINATION 347 | 348 | You may not copy, modify, sublicense, or distribute the Document 349 | except as expressly provided under this License. Any attempt 350 | otherwise to copy, modify, sublicense, or distribute it is void, and 351 | will automatically terminate your rights under this License. 352 | 353 | However, if you cease all violation of this License, then your license 354 | from a particular copyright holder is reinstated (a) provisionally, 355 | unless and until the copyright holder explicitly and finally 356 | terminates your license, and (b) permanently, if the copyright holder 357 | fails to notify you of the violation by some reasonable means prior to 358 | 60 days after the cessation. 359 | 360 | Moreover, your license from a particular copyright holder is 361 | reinstated permanently if the copyright holder notifies you of the 362 | violation by some reasonable means, this is the first time you have 363 | received notice of violation of this License (for any work) from that 364 | copyright holder, and you cure the violation prior to 30 days after 365 | your receipt of the notice. 366 | 367 | Termination of your rights under this section does not terminate the 368 | licenses of parties who have received copies or rights from you under 369 | this License. If your rights have been terminated and not permanently 370 | reinstated, receipt of a copy of some or all of the same material does 371 | not give you any rights to use it. 372 | 373 | 374 | 10. FUTURE REVISIONS OF THIS LICENSE 375 | 376 | The Free Software Foundation may publish new, revised versions of the 377 | GNU Free Documentation License from time to time. Such new versions 378 | will be similar in spirit to the present version, but may differ in 379 | detail to address new problems or concerns. See 380 | https://www.gnu.org/licenses/. 381 | 382 | Each version of the License is given a distinguishing version number. 383 | If the Document specifies that a particular numbered version of this 384 | License "or any later version" applies to it, you have the option of 385 | following the terms and conditions either of that specified version or 386 | of any later version that has been published (not as a draft) by the 387 | Free Software Foundation. If the Document does not specify a version 388 | number of this License, you may choose any version ever published (not 389 | as a draft) by the Free Software Foundation. If the Document 390 | specifies that a proxy can decide which future versions of this 391 | License can be used, that proxy's public statement of acceptance of a 392 | version permanently authorizes you to choose that version for the 393 | Document. 394 | 395 | 11. RELICENSING 396 | 397 | "Massive Multiauthor Collaboration Site" (or "MMC Site") means any 398 | World Wide Web server that publishes copyrightable works and also 399 | provides prominent facilities for anybody to edit those works. A 400 | public wiki that anybody can edit is an example of such a server. A 401 | "Massive Multiauthor Collaboration" (or "MMC") contained in the site 402 | means any set of copyrightable works thus published on the MMC site. 403 | 404 | "CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0 405 | license published by Creative Commons Corporation, a not-for-profit 406 | corporation with a principal place of business in San Francisco, 407 | California, as well as future copyleft versions of that license 408 | published by that same organization. 409 | 410 | "Incorporate" means to publish or republish a Document, in whole or in 411 | part, as part of another Document. 412 | 413 | An MMC is "eligible for relicensing" if it is licensed under this 414 | License, and if all works that were first published under this License 415 | somewhere other than this MMC, and subsequently incorporated in whole or 416 | in part into the MMC, (1) had no cover texts or invariant sections, and 417 | (2) were thus incorporated prior to November 1, 2008. 418 | 419 | The operator of an MMC Site may republish an MMC contained in the site 420 | under CC-BY-SA on the same site at any time before August 1, 2009, 421 | provided the MMC is eligible for relicensing. 422 | 423 | 424 | ADDENDUM: How to use this License for your documents 425 | 426 | To use this License in a document you have written, include a copy of 427 | the License in the document and put the following copyright and 428 | license notices just after the title page: 429 | 430 | Copyright (c) YEAR YOUR NAME. 431 | Permission is granted to copy, distribute and/or modify this document 432 | under the terms of the GNU Free Documentation License, Version 1.3 433 | or any later version published by the Free Software Foundation; 434 | with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. 435 | A copy of the license is included in the section entitled "GNU 436 | Free Documentation License". 437 | 438 | If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts, 439 | replace the "with...Texts." line with this: 440 | 441 | with the Invariant Sections being LIST THEIR TITLES, with the 442 | Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST. 443 | 444 | If you have Invariant Sections without Cover Texts, or some other 445 | combination of the three, merge those two alternatives to suit the 446 | situation. 447 | 448 | If your document contains nontrivial examples of program code, we 449 | recommend releasing these examples in parallel under your choice of 450 | free software license, such as the GNU General Public License, 451 | to permit their use in free software. 452 | -------------------------------------------------------------------------------- /docs/introduction.lisp: -------------------------------------------------------------------------------- 1 | (in-package :ps) 2 | 3 | ;;; Introduction 4 | ;;; 5 | ;;; Parenscript is a language that looks a lot like Common Lisp, but 6 | ;;; is JavaScript in disguise. This way, JavaScript programs can be 7 | ;;; seamlessly integrated in a Lisp web application. The programmer 8 | ;;; doesn't have to resort to a different syntax, and JavaScript code 9 | ;;; can easily be generated without having to resort to complicated 10 | ;;; string generation or `FORMAT' expressions. 11 | ;;; 12 | ;;; The following Lisp expression is a call to the Parenscript 13 | ;;; translator Parenscript transforms the expression in Parenscript 14 | ;;; into an equivalent, human-readable expression in JavaScript. 15 | 16 | (ps 17 | (defun foobar (a b) 18 | (+ a b))) 19 | 20 | ;;; The resulting javascript is: 21 | 22 | " 23 | function foobar(a, b) { 24 | return a + b; 25 | } 26 | " 27 | 28 | ;;; Great care has been given to the indentation and overall 29 | ;;; readability of the generated JavaScript code. 30 | 31 | ;;; Features 32 | ;;; 33 | ;;; Parenscript supports all the statements and expressions defined by 34 | ;;; the EcmaScript 262 standard. Lisp symbols are converted to 35 | ;;; camelcase, javascript-compliant syntax. This idea is taken from 36 | ;;; Linj by Antonio Menezes Leitao. Case sensitivity (using the 37 | ;;; :invert readtable-case option) is supported. Here are a few 38 | ;;; examples of Lisp symbol to JavaScript name conversion: 39 | 40 | (ps foobar) => "foobar" 41 | (ps foo-bar) => "fooBar" 42 | (ps foo-b@r) => "fooBatr" 43 | (ps *array) => "Array" 44 | (ps FooBar) => "FooBar" 45 | 46 | ;;; Parenscript supports a subset of Common Lisp iteration constructs. 47 | ;;; `for' loops can be written using the customary `DO*' syntax. 48 | 49 | (ps 50 | (do* ((i 0 (incf i)) 51 | (j (aref arr i) (aref arr i))) 52 | ((>= i 10)) 53 | (alert (+ "i is " i " and j is " j)))) 54 | 55 | ;; compiles to 56 | " 57 | for (var i = 0, j = arr[i]; i < 10; i = ++i, j = arr[i]) { 58 | alert('i is ' + i + ' and j is ' + j); 59 | }; 60 | " 61 | ;;; Parenscript uses the Lisp reader, allowing for reader macros. It 62 | ;;; also comes with its own macro environment, allowing host Lisp 63 | ;;; macros and Parenscript macros to coexist without interfering with 64 | ;;; each other. For example, the `1+' construct is implemented using 65 | ;;; a Parenscript macro: 66 | 67 | (defpsmacro 1+ (form) 68 | `(+ ,form 1)) 69 | 70 | ;;; Parenscript allows the creation of JavaScript objects in a Lispy 71 | ;;; way, using keyword arguments. 72 | 73 | (ps 74 | (create :foo "foo" 75 | :bla "bla")) 76 | 77 | ;; compiles to 78 | " 79 | { foo : 'foo', 80 | bla : 'bla' } 81 | " 82 | ;;; Parenscript features a HTML generator. Using the same syntax as 83 | ;;; the HTMLGEN package of Franz, Inc., it can generate JavaScript 84 | ;;; string expressions. This allows for a clean integration of HTML in 85 | ;;; Parenscript code, instead of writing the tedious and error-prone 86 | ;;; string generation code generally found in JavaScript. 87 | 88 | (ps 89 | (defun add-div (name href link-text) 90 | (funcall (getprop document 'write) 91 | (ps-html ((:div :id name) 92 | "The link is: " 93 | ((:a :href href) link-text)))))) 94 | 95 | ;; compiles to 96 | " 97 | function addDiv(name, href, linkText) { 98 | return document.write(['
The link is: ', linkText, '
'].join('')); 99 | }; 100 | " 101 | -------------------------------------------------------------------------------- /docs/tutorial.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 9 | 10 | Parenscript Tutorial 11 | 22 | 23 | 24 | 25 |

Parenscript Tutorial

26 | 27 |

28 | Copyright 2009, 2018 Vladimir Sedach.
29 | 30 | Permission is granted to copy, distribute and/or modify this 31 | document under the terms of the GNU Free Documentation License, 32 | Version 1.3 or any later version published by the Free Software 33 | Foundation; with no Invariant Sections, no Front-Cover Texts, 34 | and no Back-Cover Texts. A copy of the license can be 35 | found on the 36 | GNU website. 37 |

38 | 39 |

Introduction

40 | 41 |

42 | This tutorial shows how to build a simple web application in 43 | Common Lisp, specifically demonstrating 44 | the Parenscript 45 | Lisp to JavaScript compiler. 46 |

47 | 48 |

49 | The Parenscript 50 | reference manual contains a description of Parenscript 51 | functions and macros. 52 |

53 | 54 |

Getting Started

55 | 56 |

57 | First, install a Common Lisp 58 | implementation. SBCL is a good 59 | one; CLiki has 60 | a comprehensive 61 | list of Common Lisp implementations. Next, get 62 | the Quicklisp package 63 | manager. 64 |

65 | 66 |

67 | This tutorial uses the following libraries: 68 |

69 | 70 |
71 |
CL-FAD
72 |
file utilities
73 | 74 |
CL-WHO
75 |
HTML generator
76 | 77 |
Hunchentoot
78 |
web server
79 | 80 |
Parenscript
81 |
JavaScript generator
82 |
83 | 84 |

85 | Load them using Quicklisp: 86 |

87 | 88 | 
(mapc #'ql:quickload '(:cl-fad :cl-who :hunchentoot :parenscript))
89 | 90 |

91 | Next, define a package to hold the example code: 92 |

93 | 94 | 
(defpackage "PS-TUTORIAL"
 95 |   (:use "COMMON-LISP" "HUNCHENTOOT" "CL-WHO" "PARENSCRIPT" "CL-FAD"))
 96 | 
 97 | (in-package "PS-TUTORIAL")
98 | 99 |

100 | CL-WHO leaves it up to you to escape HTML attributes. One way to 101 | make sure that quoted strings in inline JavaScript work inside 102 | HTML attributes is to use double quotes for HTML attributes and 103 | single quotes for JavaScript strings. 104 |

105 | 106 | 
(setq cl-who:*attribute-quote-char* #\")
107 | 108 |

109 | Now start the web server: 110 |

111 | 112 | 
(start (make-instance 'easy-acceptor :port 8080))
113 | 114 |

Examples

115 | 116 |

117 | The ps macro takes Parenscript code in the form of 118 | s-expressions (Parenscript code and Common Lisp code share the 119 | same representation), translates as much as it can into constant 120 | strings at macro-expansion time, and expands into a form that 121 | will evaluate to a string containing JavaScript code. 122 |

123 | 124 | 
(define-easy-handler (example1 :uri "/example1") ()
125 |   (with-html-output-to-string (s)
126 |     (:html
127 |      (:head (:title "Parenscript tutorial: 1st example"))
128 |      (:body (:h2 "Parenscript tutorial: 1st example")
129 |             "Please click the link below." :br
130 |             (:a :href "#" :onclick (ps (alert "Hello World"))
131 |                 "Hello World")))))
132 | 133 |

134 | One way to include Parenscript code in web pages is to inline it 135 | in HTML script tags: 136 |

137 | 138 | 
(define-easy-handler (example2 :uri "/example2") ()
139 |   (with-html-output-to-string (s)
140 |     (:html
141 |      (:head
142 |       (:title "Parenscript tutorial: 2nd example")
143 |       (:script :type "text/javascript"
144 |                (str (ps
145 |                       (defun greeting-callback ()
146 |                         (alert "Hello World"))))))
147 |      (:body
148 |       (:h2 "Parenscript tutorial: 2nd example")
149 |       (:a :href "#" :onclick (ps (greeting-callback))
150 |           "Hello World")))))
151 | 152 |

153 | Another way to integrate Parenscript into a web application is 154 | to serve the generated JavaScript as a separate HTTP resource. 155 | Requests to this resource can then be cached by the browser: 156 |

157 | 158 | 
(define-easy-handler (example3 :uri "/example3.js") ()
159 |   (setf (content-type*) "text/javascript")
160 |   (ps
161 |     (defun greeting-callback ()
162 |       (alert "Hello World"))))
163 | 164 |

Slideshow

165 | 166 |

167 | Next let's try a more complicated example: an image slideshow 168 | viewer. 169 |

170 | 171 |

172 | First we need a way to define slideshows. For this tutorial we 173 | will assume that we have several different folders containing 174 | image files, and we want to serve each of the folders as its own 175 | slideshow under its own URL. We will use a custom Hunchentoot 176 | handler to serve the slideshow 177 | under /slideshows/{slideshow-name}, and the 178 | built-in Hunchentoot 179 | folder 180 | dispatcher to serve the image files 181 | from /slideshow-images/{slideshow-name}/{image-file}. 182 |

183 | 184 | 
(defvar *slideshows* (make-hash-table :test 'equalp))
185 | 
186 | (defun add-slideshow (slideshow-name image-folder)
187 |   (setf (gethash slideshow-name *slideshows*) image-folder)
188 |   (push (create-folder-dispatcher-and-handler
189 |          (format nil "/slideshow-images/~a/" slideshow-name)
190 |          image-folder)
191 |         *dispatch-table*))
192 | 193 |

194 | Let's find some important pictures on our machine and get 195 | Hunchentoot to start serving them: 196 |

197 | 198 | 
(add-slideshow "lolcat" "/home/junk/lolcats/")
199 | (add-slideshow "lolrus" "/home/other-junk/lolruses/")
200 | 201 |

202 | Next we need to create the slideshow web page. We can use 203 | JavaScript to view the slideshow without refreshing the whole 204 | page, and provide regular link navigation for client browsers 205 | that do not have JavaScript enabled. Either way, we want viewers 206 | of our slideshow to be able to bookmark their place in the 207 | slideshow viewing sequence. 208 |

209 | 210 |

211 | We will need a way to generate URIs for slideshow images on both 212 | the server and browser. We can eliminate code duplication with 213 | the defmacro+ps macro, which shares macro 214 | definitions between Common Lisp and Parenscript. 215 |

216 | 217 | 
(defmacro+ps slideshow-image-uri (slideshow-name image-file)
218 |   `(concatenate 'string "/slideshow-images/" ,slideshow-name "/" ,image-file))
219 | 220 |

221 | Next is the function to serve up the slideshow page. The pages 222 | will be served under /slideshows/{slideshow-name}, 223 | all of them handled by a single function that will dispatch on 224 | {slideshow-name}. 225 |

226 | 227 |

228 | JavaScript-enabled web browsers will get information about the 229 | slideshow in an inline script generated 230 | by ps*, 231 | a function used for translating code generated at run-time. 232 | Slideshow navigation will be done with onclick 233 | handlers, generated at compile-time by 234 | the ps 235 | macro. 236 |

237 | 238 |

239 | Regular HTML slideshow navigation will be done using query 240 | parameters. 241 |

242 | 243 | 
(defun slideshow-handler ()
244 |   (cl-ppcre:register-groups-bind (slideshow-name)
245 |       ("/slideshows/(.*)" (script-name*))
246 |     (let* ((images (mapcar
247 |                     (lambda (i) (url-encode (file-namestring i)))
248 |                     (list-directory
249 |                      (or (gethash slideshow-name *slideshows*)
250 |                          (progn (setf (return-code*) 404)
251 |                                 (return-from slideshow-handler))))))
252 |            (current-image-index
253 |              (or (position (url-encode (or (get-parameter "image") ""))
254 |                            images
255 |                            :test #'equalp)
256 |                  0))
257 |            (previous-image-index (max 0
258 |                                       (1- current-image-index)))
259 |            (next-image-index (min (1- (length images))
260 |                                   (1+ current-image-index))))
261 |       (with-html-output-to-string (s)
262 |         (:html
263 |          (:head
264 |           (:title "Parenscript slideshow")
265 |           (:script
266 |            :type "text/javascript"
267 |            (str
268 |             (ps*
269 |              `(progn
270 |                 (var *slideshow-name* ,slideshow-name)
271 |                 (var *images* (array ,@images))
272 |                 (var *current-image-index* ,current-image-index)))))
273 |           (:script :type "text/javascript" :src "/slideshow.js"))
274 |          (:body
275 |           (:div :id "slideshow-container"
276 |                 :style "width:100%;text-align:center"
277 |                 (:img :id "slideshow-img-object"
278 |                       :src (slideshow-image-uri
279 |                             slideshow-name
280 |                             (elt images current-image-index)))
281 |                 :br
282 |                 (:a :href (format nil "/slideshows/~a?image=~a"
283 |                                   slideshow-name
284 |                                   (elt images previous-image-index))
285 |                     :onclick (ps (previous-image) (return false))
286 |                     "Previous")
287 |                 " "
288 |                 (:a :href (format nil "/slideshows/~a?image=~a"
289 |                                   slideshow-name
290 |                                   (elt images next-image-index))
291 |                     :onclick (ps (next-image) (return false))
292 |                     "Next"))))))))
293 | 294 |

295 | Since this function is a custom handler, we need to create a new 296 | dispatcher for it. Note that we are passing the symbol naming 297 | the handler instead of the function object, which lets us 298 | redefine the handler without touching the dispatcher. 299 |

300 | 301 | 
(push (create-prefix-dispatcher "/slideshows/" 'slideshow-handler)
302 |       *dispatch-table*)
303 | 304 |

305 | Last, we need to define the /slideshow.js script. 306 |

307 | 308 | 
(define-easy-handler (js-slideshow :uri "/slideshow.js") ()
309 |   (setf (content-type*) "text/javascript")
310 |   (ps
311 |     (define-symbol-macro fragment-identifier (@ window location hash))
312 | 
313 |     (defun show-image-number (image-index)
314 |       (let ((image-name (aref *images* (setf *current-image-index* image-index))))
315 |         (setf (chain document (get-element-by-id "slideshow-img-object") src)
316 |               (slideshow-image-uri *slideshow-name* image-name)
317 |               fragment-identifier
318 |               image-name)))
319 | 
320 |     (defun previous-image ()
321 |       (when (> *current-image-index* 0)
322 |         (show-image-number (1- *current-image-index*))))
323 | 
324 |     (defun next-image ()
325 |       (when (< *current-image-index* (1- (getprop *images* 'length)))
326 |         (show-image-number (1+ *current-image-index*))))
327 | 
328 |     ;; use fragment identifiers to allow bookmarking
329 |     (setf (getprop window 'onload)
330 |           (lambda ()
331 |             (when fragment-identifier
332 |               (let ((image-name (chain fragment-identifier (slice 1))))
333 |                 (dotimes (i (length *images*))
334 |                   (when (string= image-name (aref *images* i))
335 |                     (show-image-number i)))))))))
336 | 337 |

338 | Note 339 | the @ 340 | and chain 341 | property access convenience macros. (@ object slotA 342 | slotB) expands to 343 | (getprop (getprop object 'slotA) 344 | 'slotB). chain is similar and also provides 345 | nested method calls. 346 |

347 | 348 |

Author: Vladimir Sedach <vas@oneofus.la> Last modified: 2018-03-29

349 | 350 | 351 | -------------------------------------------------------------------------------- /extras/firebug-tracing.lisp: -------------------------------------------------------------------------------- 1 | ;; SPDX-License-Identifier: BSD-3-Clause 2 | 3 | ;; Tracing macro courtesy of William Halliburton 4 | ;; , logs to Firebug console 5 | 6 | ;; On a happier note here is a macro I wrote to enable 7 | ;; tracing-ala-cl. Works with firebug. You'll need to (defvar 8 | ;; *trace-level*). I don't do indentation but that would be an easy 9 | ;; addition. 10 | 11 | (defpsmacro console (&rest rest) 12 | `(console.log ,@rest)) 13 | 14 | (defpsmacro defun-trace (name args &rest body) 15 | (let* ((sname (ps::symbol-to-js name)) 16 | (tname (ps-gensym name)) 17 | (arg-names (loop for arg in args 18 | unless (eq arg '&optional) 19 | collect (if (consp arg) (car arg) arg))) 20 | (argpairs 21 | (loop for arg in arg-names 22 | nconc (list (ps::symbol-to-js arg) arg)))) 23 | `(progn 24 | (defun ,name ,arg-names 25 | (console *trace-level* ,sname ":" ,@argpairs) 26 | (incf *trace-level*) 27 | (let* ((rtn (,tname ,@arg-names))) 28 | (decf *trace-level*) 29 | (console *trace-level* ,sname "returned" rtn) 30 | (return rtn))) 31 | (defun ,tname ,args 32 | ,@body)))) 33 | -------------------------------------------------------------------------------- /extras/js-expander.el: -------------------------------------------------------------------------------- 1 | ;; SPDX-License-Identifier: BSD-3-Clause 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;;; This is an extension to SLIME that is inspired by (and works 5 | ;;;; like) the SLIME 'C-c M-m' macroexpansion feature. 6 | 7 | ;;;; After loading, 'C-c j' (PS) or 'C-c d' (PS-DOC) at a ParenScript 8 | ;;;; expression in a slime-mode buffer will bring up a buffer with the 9 | ;;;; resulting Javascript code. Note that the extension does not work 10 | ;;;; in slime-repl-mode, which is intentional. 11 | 12 | ;;;; Copyright 2007, Vladimir Sedach. See the COPYING file in the 13 | ;;;; Parenscript distribution for licensing information. 14 | 15 | ;;; The code below is a generic facility for adding "macroexpand-like" buffer expansion to Slime 16 | (defun slime-eval-custom-expand (expander exp-str package buffer-name buffer-mode printer) 17 | (lexical-let ((package package) 18 | (buffer-name buffer-name) 19 | (buffer-mode buffer-mode) 20 | (printer printer)) 21 | (slime-eval-async 22 | (list 'swank:eval-and-grab-output (format "(%s %s)" expander exp-str)) 23 | (lambda (expansion) 24 | (slime-with-popup-buffer (buffer-name) 25 | (funcall buffer-mode) 26 | (setq buffer-read-only nil) 27 | (erase-buffer) 28 | (insert (funcall printer (second expansion))) 29 | (setq buffer-read-only t) 30 | (font-lock-fontify-buffer))) 31 | package))) 32 | 33 | (defun* slime-add-custom-expander (key expander buffer-name &optional (buffer-mode 'slime-mode) (printer #'identity)) 34 | (define-key slime-parent-map (concat "\C-c" key) 35 | (lexical-let ((expander expander) 36 | (buffer-name buffer-name) 37 | (buffer-mode buffer-mode) 38 | (printer printer)) 39 | (lambda (&rest _) 40 | (interactive "P") 41 | (slime-eval-custom-expand expander 42 | (slime-sexp-at-point) 43 | (slime-current-package) 44 | buffer-name 45 | buffer-mode 46 | printer))))) 47 | 48 | ;;; This actually defines the expander. If the code above belongs in slime.el, the code below would go into .emacs 49 | (map nil (lambda (x) 50 | (slime-add-custom-expander (car x) 51 | (cdr x) 52 | "*Parenscript generated Javascript*" 53 | (if (featurep 'javascript-mode) 'javascript-mode 'c-mode) 54 | #'read)) 55 | '(("j" . ps:ps) ("d" . ps:ps-doc))) 56 | -------------------------------------------------------------------------------- /extras/swank-parenscript.lisp: -------------------------------------------------------------------------------- 1 | ;; SPDX-License-Identifier: BSD-3-Clause 2 | 3 | (in-package :parenscript) 4 | 5 | (defun parenscript-function-p (symbol) 6 | (and (or (gethash symbol *ps-macro-toplevel* ) 7 | (gethash symbol *ps-function-toplevel-cache*)) 8 | t)) 9 | #++ 10 | (pushnew 'parenscript-function-p swank::*external-valid-function-name-p-hooks*) 11 | 12 | (defun parenscript-arglist (fname) 13 | (acond 14 | ((gethash fname *ps-macro-toplevel-lambda-list*) 15 | (values it t)) 16 | ((gethash fname *ps-function-toplevel-cache*) 17 | (values it t)))) 18 | #++ 19 | (pushnew 'parenscript-arglist swank::*external-arglist-hooks*) 20 | -------------------------------------------------------------------------------- /parenscript.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- lisp -*- 2 | 3 | (defsystem :parenscript 4 | :name "parenscript" 5 | :author "Manuel Odendahl " 6 | :maintainer "Vladimir Sedach " 7 | :licence "BSD-3-Clause" 8 | :description "Lisp to JavaScript transpiler" 9 | :components 10 | ((:static-file "parenscript.asd") 11 | (:module :src 12 | :serial t 13 | :components ((:file "package") 14 | (:file "js-dom-symbol-exports") ;; has to be loaded here, ps-js-symbols externals are re-exported from #:parenscript package 15 | (:file "js-ir-package") 16 | (:file "utils") 17 | (:file "namespace") 18 | (:file "compiler") 19 | (:file "printer") 20 | (:file "compilation-interface") 21 | (:file "non-cl") 22 | (:file "special-operators") 23 | (:file "parse-lambda-list") 24 | (:file "function-definition") 25 | (:file "macros") 26 | (:file "deprecated-interface") 27 | (:module :lib 28 | :components ((:file "ps-html") 29 | (:file "ps-loop") 30 | (:file "ps-dom")) 31 | :depends-on ("compilation-interface")))) 32 | (:module :runtime 33 | :components ((:file "ps-runtime-lib")) 34 | :depends-on (:src))) 35 | :depends-on (:cl-ppcre :anaphora :named-readtables)) 36 | -------------------------------------------------------------------------------- /parenscript.tests.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- lisp -*- 2 | 3 | (defsystem :parenscript.tests 4 | :license "BSD-3-Clause" 5 | :description "Unit tests for Parenscript" 6 | :components ((:module :tests 7 | :serial t 8 | :components ((:file "test-package") 9 | (:file "test") 10 | (:file "output-tests") 11 | (:file "package-system-tests") 12 | (:file "eval-tests")))) 13 | :depends-on (:parenscript :fiveam :cl-js)) 14 | -------------------------------------------------------------------------------- /runtime/ps-runtime-lib.lisp: -------------------------------------------------------------------------------- 1 | ;; SPDX-License-Identifier: BSD-3-Clause 2 | 3 | (in-package #:parenscript) 4 | 5 | ;;; Script of library functions you can include with your own code to 6 | ;;; provide standard Lisp functionality. 7 | 8 | (defparameter *ps-lisp-library* 9 | '(progn 10 | (defun mapcar (fun &rest arrs) 11 | (let ((result-array (make-array))) 12 | (if (= 1 (length arrs)) 13 | (dolist (element (aref arrs 0)) 14 | ((@ result-array push) (fun element))) 15 | (dotimes (i (length (aref arrs 0))) 16 | (let ((args-array (mapcar (lambda (a) (aref a i)) arrs))) 17 | ((@ result-array push) ((@ fun apply) fun args-array))))) 18 | result-array)) 19 | 20 | (defun map-into (fn arr) 21 | "Call FN on each element in ARR, replace element with the return value." 22 | (let ((idx 0)) 23 | (dolist (el arr) 24 | (setf (aref arr idx) (fn el)) 25 | (setf idx (1+ idx)))) 26 | arr) 27 | 28 | (defun map (fn arr) 29 | "Call FN on each element in ARR and return the returned values in a new array." 30 | ;; In newer versions of ECMAScript, this may call Array.map, too 31 | (let ((idx 0) 32 | (result (array))) 33 | (dolist (el arr) 34 | (setf (aref result idx) (fn el)) 35 | (setf idx (1+ idx))) 36 | result)) 37 | 38 | (defun member (item arr) 39 | "Check if ITEM is a member of ARR." 40 | (dolist (el arr) 41 | (if (= el item) 42 | (return-from member true))) 43 | false) 44 | 45 | (defun set-difference (arr arr-to-sub) 46 | "Return a new array with only those elements in ARR that are not in ARR-TO-SUB." 47 | (let ((idx 0) 48 | (result (array))) 49 | (dolist (el arr) 50 | (unless (member el arr-to-sub) 51 | (setf (aref result idx) el) 52 | (setf idx (1+ idx)))) 53 | result)) 54 | 55 | (defun reduce (func list &optional init) 56 | (let* ((acc)) 57 | (do* ((i (if (= (length arguments) 3) -1 0) 58 | (1+ i)) 59 | (acc (if (= (length arguments) 3) init (elt list 0)) 60 | (func acc (elt list i)))) 61 | ((>= i (1- (length list))))) 62 | acc)) 63 | 64 | (defun nconc (arr &rest arrs) 65 | (when (and arr (> (length arr) 0)) 66 | (loop :for other :in arrs :when (and other (> (length other) 0)) :do 67 | ((@ arr :splice :apply) arr 68 | (append (list (length arr) (length other)) other)))) 69 | arr))) 70 | -------------------------------------------------------------------------------- /src/compilation-interface.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-2006 Edward Marco Baringer 3 | ;;; Copyright 2006 Luca Capello 4 | ;;; Copyright 2007-2009 Red Daly 5 | ;;; Copyright 2008 Travis Cross 6 | ;;; Copyright 2007-2011 Vladimir Sedach 7 | ;;; Copyright 2009-2010 Daniel Gackle 8 | 9 | ;;; SPDX-License-Identifier: BSD-3-Clause 10 | 11 | ;;; Redistribution and use in source and binary forms, with or 12 | ;;; without modification, are permitted provided that the following 13 | ;;; conditions are met: 14 | 15 | ;;; 1. Redistributions of source code must retain the above copyright 16 | ;;; notice, this list of conditions and the following disclaimer. 17 | 18 | ;;; 2. Redistributions in binary form must reproduce the above 19 | ;;; copyright notice, this list of conditions and the following 20 | ;;; disclaimer in the documentation and/or other materials provided 21 | ;;; with the distribution. 22 | 23 | ;;; 3. Neither the name of the copyright holder nor the names of its 24 | ;;; contributors may be used to endorse or promote products derived 25 | ;;; from this software without specific prior written permission. 26 | 27 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 28 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 29 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 30 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 31 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 32 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 33 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 34 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 35 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 36 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 37 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 38 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 39 | ;;; POSSIBILITY OF SUCH DAMAGE. 40 | 41 | (in-package #:parenscript) 42 | 43 | (defparameter *js-target-version* "1.3") 44 | 45 | (defvar *parenscript-stream* nil) 46 | 47 | (defmacro ps (&body body) 48 | "Given Parenscript forms (an implicit progn), compiles those forms 49 | to a JavaScript string at macro-expansion time. Expands into a form 50 | which evaluates to a string." 51 | (let ((printed-forms (parenscript-print 52 | (compile-statement `(progn ,@body)) 53 | nil))) 54 | (if (and (not (cdr printed-forms)) 55 | (stringp (car printed-forms))) 56 | (car printed-forms) 57 | (let ((s (gensym))) 58 | `(with-output-to-string (,s) 59 | ,@(mapcar (lambda (x) `(write-string ,x ,s)) 60 | printed-forms)))))) 61 | 62 | (defmacro ps-to-stream (stream &body body) 63 | "Given Parenscript forms (an implicit progn), compiles those forms 64 | to a JavaScript string at macro-expansion time. Expands into a form 65 | which writes the resulting code to stream." 66 | (let ((printed-forms (parenscript-print 67 | (compile-statement `(progn ,@body)) 68 | nil))) 69 | `(let ((*parenscript-stream* ,stream)) 70 | ,@(mapcar (lambda (x) `(write-string ,x *parenscript-stream*)) 71 | printed-forms)))) 72 | 73 | (defun ps* (&rest body) 74 | "Compiles body to a JavaScript string. If *parenscript-stream* is 75 | bound, writes the output to *parenscript-stream*, otherwise returns a 76 | string." 77 | (let ((*psw-stream* (or *parenscript-stream* (make-string-output-stream)))) 78 | (parenscript-print (compile-statement `(progn ,@body)) t) 79 | (unless *parenscript-stream* 80 | (get-output-stream-string *psw-stream*)))) 81 | 82 | (defmacro with-blank-compilation-environment (&body body) 83 | `(let ((*ps-gensym-counter* 0) 84 | (*special-variables* nil)) 85 | ,@body)) 86 | 87 | (defmacro ps-doc (&body body) 88 | "Expands Parenscript forms in a clean environment." 89 | (with-blank-compilation-environment 90 | (macroexpand-1 `(ps ,@body)))) 91 | 92 | (defun ps-doc* (&rest body) 93 | (with-blank-compilation-environment 94 | (apply #'ps* body))) 95 | 96 | (defvar *js-inline-string-delimiter* #\" 97 | "Controls the string delimiter char used when compiling Parenscript in ps-inline.") 98 | 99 | (defun ps-inline* (form &optional 100 | (*js-string-delimiter* *js-inline-string-delimiter*)) 101 | (concatenate 'string "javascript:" (ps* form))) 102 | 103 | (defmacro+ps ps-inline (form &optional 104 | (string-delimiter *js-inline-string-delimiter*)) 105 | `(concatenate 'string "javascript:" 106 | ,@(let ((*js-string-delimiter* string-delimiter)) 107 | (parenscript-print (compile-statement form) nil)))) 108 | 109 | (defvar *ps-read-function* #'read) 110 | 111 | (defun ps-compile-stream (stream) 112 | "Reads (using the value of *ps-read-function*, #'read by default, as 113 | the read function) Parenscript forms from stream and compiles them as 114 | if by ps*. If *parenscript-stream* is bound, writes the output to 115 | *parenscript-stream*, otherwise and returns a string." 116 | (let ((output-stream (or *parenscript-stream* (make-string-output-stream)))) 117 | (let ((*compilation-level* :toplevel) 118 | (*readtable* *readtable*) 119 | (*package* *package*) 120 | (*parenscript-stream* output-stream) 121 | (eof '#:eof)) 122 | (loop for form = (funcall *ps-read-function* stream nil eof) 123 | until (eq form eof) do (ps* form) (fresh-line *parenscript-stream*))) 124 | (unless *parenscript-stream* 125 | (get-output-stream-string output-stream)))) 126 | 127 | (defun ps-compile-file (source-file &key (element-type 'character) (external-format :default)) 128 | "Opens file as input stream and calls ps-compile-stream on it." 129 | (with-open-file (stream source-file 130 | :direction :input 131 | :element-type element-type 132 | :external-format external-format) 133 | (ps-compile-stream stream))) 134 | -------------------------------------------------------------------------------- /src/compiler.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-2006 Edward Marco Baringer 3 | ;;; Copyright 2006 Attila Lendvai 4 | ;;; Copyright 2006 Luca Capello 5 | ;;; Copyright 2007-2012, 2018 Vladimir Sedach 6 | ;;; Copyright 2008 Travis Cross 7 | ;;; Copyright 2009-2010 Red Daly 8 | ;;; Copyright 2009-2010 Daniel Gackle 9 | ;;; Copyright 2012, 2015 Boris Smilga 10 | 11 | ;;; SPDX-License-Identifier: BSD-3-Clause 12 | 13 | ;;; Redistribution and use in source and binary forms, with or 14 | ;;; without modification, are permitted provided that the following 15 | ;;; conditions are met: 16 | 17 | ;;; 1. Redistributions of source code must retain the above copyright 18 | ;;; notice, this list of conditions and the following disclaimer. 19 | 20 | ;;; 2. Redistributions in binary form must reproduce the above 21 | ;;; copyright notice, this list of conditions and the following 22 | ;;; disclaimer in the documentation and/or other materials provided 23 | ;;; with the distribution. 24 | 25 | ;;; 3. Neither the name of the copyright holder nor the names of its 26 | ;;; contributors may be used to endorse or promote products derived 27 | ;;; from this software without specific prior written permission. 28 | 29 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 30 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 31 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 32 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 33 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 34 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 35 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 36 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 37 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 38 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 39 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 40 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 41 | ;;; POSSIBILITY OF SUCH DAMAGE. 42 | 43 | (in-package #:parenscript) 44 | (in-readtable :parenscript) 45 | 46 | (defvar *version* 2.7 "Parenscript compiler version.") 47 | 48 | (defparameter %compiling-reserved-forms-p% t 49 | "Used to issue warnings when replacing PS special operators or macros.") 50 | 51 | (defvar *defined-operators* () 52 | "Special operators and macros defined by Parenscript. Replace at your own risk!") 53 | 54 | (defun defined-operator-override-check (name &rest body) 55 | (when (and (not %compiling-reserved-forms-p%) (member name *defined-operators*)) 56 | (warn 'simple-style-warning 57 | :format-control "Redefining Parenscript operator/macro ~A" 58 | :format-arguments (list name))) 59 | `(progn ,(when %compiling-reserved-forms-p% `(pushnew ',name *defined-operators*)) 60 | ,@body)) 61 | 62 | (defvar *reserved-symbol-names* 63 | (list "break" "case" "catch" "continue" "default" "delete" "do" "else" 64 | "finally" "for" "function" "if" "in" "instanceof" "new" "return" 65 | "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with" 66 | "abstract" "boolean" "byte" "char" "class" "const" "debugger" 67 | "double" "enum" "export" "extends" "final" "float" "goto" 68 | "implements" "import" "int" "interface" "long" "native" "package" 69 | "private" "protected" "public" "short" "static" "super" 70 | "synchronized" "throws" "transient" "volatile" "{}" "true" "false" 71 | "null" "undefined")) 72 | 73 | (defvar *lambda-wrappable-statements* 74 | '(throw switch for for-in while try block) 75 | "Statement special forms that can be wrapped in a lambda to make 76 | them into expressions. Control transfer forms like BREAK, RETURN, 77 | and CONTINUE need special treatment, and are not included.") 78 | 79 | (defun reserved-symbol-p (symbol) 80 | (find (string-downcase (string symbol)) *reserved-symbol-names* :test #'string=)) 81 | 82 | ;;; special forms 83 | 84 | (defvar *special-expression-operators* (make-hash-table :test 'eq)) 85 | (defvar *special-statement-operators* (make-hash-table :test 'eq)) 86 | 87 | ;; need to split special op definition into two parts - statement and expression 88 | (defmacro %define-special-operator (type name lambda-list &body body) 89 | (defined-operator-override-check name 90 | `(setf (gethash ',name ,type) 91 | (lambda (&rest whole) 92 | (destructuring-bind ,lambda-list whole 93 | ,@body))))) 94 | 95 | (defmacro define-expression-operator (name lambda-list &body body) 96 | `(%define-special-operator *special-expression-operators* 97 | ,name ,lambda-list ,@body)) 98 | 99 | (defmacro define-statement-operator (name lambda-list &body body) 100 | `(%define-special-operator *special-statement-operators* 101 | ,name ,lambda-list ,@body)) 102 | 103 | (defun special-form? (form) 104 | (and (consp form) 105 | (symbolp (car form)) 106 | (or (gethash (car form) *special-expression-operators*) 107 | (gethash (car form) *special-statement-operators*)))) 108 | 109 | ;;; naming, scoping, and lexical environment 110 | 111 | (defvar *ps-gensym-counter* 0) 112 | 113 | (defvar *vars-needing-to-be-declared* () 114 | "This special variable is expected to be bound to a fresh list by 115 | special forms that introduce a new JavaScript lexical block (currently 116 | function definitions and lambdas). Enclosed special forms are expected 117 | to push variable declarations onto the list when the variables 118 | declaration cannot be made by the enclosed form (for example, a x,y,z 119 | expression progn). It is then the responsibility of the enclosing 120 | special form to introduce the variable declarations in its lexical 121 | block.") 122 | 123 | (defvar *used-up-names*) 124 | (setf (documentation '*used-up-names* 'variable) 125 | "Names that have been already used for lexical bindings in the current function scope.") 126 | 127 | (defvar in-case? nil 128 | "Bind to T when compiling CASE branches.") 129 | 130 | (defvar in-loop-scope? nil 131 | "Used for seeing when we're in loops, so that we can introduce 132 | proper scoping for lambdas closing over loop-bound 133 | variables (otherwise they all share the same binding).") 134 | (defvar *loop-return-var* nil 135 | "Variable which is used to return values from inside loop bodies.") 136 | (defvar *loop-return-set-var* nil 137 | "Variable which is set by RETURN-FROM when it returns a value from inside 138 | a loop. The value is the name of a PS variable which dynamically 139 | indicates if the return statement indeed has been invoked.") 140 | 141 | (defvar *loop-scope-lexicals*) 142 | (setf (documentation '*loop-scope-lexicals* 'variable) 143 | "Lexical variables introduced by a loop.") 144 | (defvar *loop-scope-lexicals-captured*) 145 | (setf (documentation '*loop-scope-lexicals-captured* 'variable) 146 | "Lexical variables introduced by a loop that are also captured by lambdas inside a loop.") 147 | 148 | (defvar in-function-scope? nil 149 | "Lets the compiler know when lambda wrapping is necessary.") 150 | 151 | (defvar *local-function-names* () 152 | "Functions named by flet and label.") 153 | ;; is a subset of 154 | (defvar *enclosing-lexicals* () 155 | "All enclosing lexical variables (includes function names).") 156 | (defvar *enclosing-function-arguments* () 157 | "Lexical variables bound in all lexically enclosing function argument lists.") 158 | 159 | (defvar *function-block-names* () 160 | "All block names that this function is responsible for catching.") 161 | (defvar *dynamic-return-tags* () 162 | "Tags that need to be thrown to to reach.") 163 | (defvar *current-block-tag* nil 164 | "Name of the lexically enclosing block, if any.") 165 | 166 | (defvar *special-variables* () 167 | "Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.") 168 | 169 | (defun special-variable? (sym) 170 | (member sym *special-variables*)) 171 | 172 | ;;; meta info 173 | 174 | (defvar *macro-toplevel-lambda-list* (make-hash-table) 175 | "Table of lambda lists for toplevel macros.") 176 | 177 | (defvar *function-lambda-list* (make-hash-table) 178 | "Table of lambda lists for defined functions.") 179 | 180 | ;;; macros 181 | (defun make-macro-dictionary () 182 | (make-hash-table :test 'eq)) 183 | 184 | (defvar *macro-toplevel* (make-macro-dictionary) 185 | "Toplevel macro environment dictionary.") 186 | 187 | (defvar *macro-env* (list *macro-toplevel*) 188 | "Current macro environment.") 189 | 190 | (defvar *symbol-macro-toplevel* (make-macro-dictionary)) 191 | 192 | (defvar *symbol-macro-env* (list *symbol-macro-toplevel*)) 193 | 194 | (defvar *setf-expanders* (make-macro-dictionary) 195 | "Setf expander dictionary. Key is the symbol of the access 196 | function of the place, value is an expansion function that takes the 197 | arguments of the access functions as a first value and the form to be 198 | stored as the second value.") 199 | 200 | (defun lookup-macro-def (name env) 201 | (loop for e in env thereis (gethash name e))) 202 | 203 | (defun make-ps-macro-function (args body) 204 | "Given the arguments and body to a parenscript macro, returns a 205 | function that may be called on the entire parenscript form and outputs 206 | some parenscript code. Returns a second value that is the effective 207 | lambda list from a Parenscript perspective." 208 | (let* ((whole-var (when (eql '&whole (first args)) (second args))) 209 | (effective-lambda-list (if whole-var (cddr args) args)) 210 | (whole-arg (or whole-var (gensym "ps-macro-form-arg-")))) 211 | (values 212 | `(lambda (,whole-arg) 213 | (destructuring-bind ,effective-lambda-list 214 | (cdr ,whole-arg) 215 | ,@body)) 216 | effective-lambda-list))) 217 | 218 | (defmacro defpsmacro (name args &body body) 219 | (defined-operator-override-check name 220 | (multiple-value-bind (macro-fn-form effective-lambda-list) 221 | (make-ps-macro-function args body) 222 | `(eval-when (:compile-toplevel :load-toplevel :execute) 223 | (setf (gethash ',name *macro-toplevel*) ,macro-fn-form) 224 | (setf (gethash ',name *macro-toplevel-lambda-list*) ',effective-lambda-list) 225 | ',name)))) 226 | 227 | (defmacro define-ps-symbol-macro (symbol expansion) 228 | (defined-operator-override-check symbol 229 | `(eval-when (:compile-toplevel :load-toplevel :execute) 230 | (setf (gethash ',symbol *symbol-macro-toplevel*) 231 | (lambda (form) 232 | (declare (ignore form)) 233 | ',expansion))))) 234 | 235 | (defun import-macros-from-lisp (&rest names) 236 | "Import the named Lisp macros into the Parenscript macro 237 | environment. When the imported macro is macroexpanded by Parenscript, 238 | it is first fully macroexpanded in the Lisp macro environment, and 239 | then that expansion is further expanded by Parenscript." 240 | (dolist (name names) 241 | (eval `(defpsmacro ,name (&rest args) 242 | (macroexpand `(,',name ,@args)))))) 243 | 244 | (defmacro defmacro+ps (name args &body body) 245 | "Define a Lisp macro and a Parenscript macro with the same macro 246 | function (ie - the same result from macroexpand-1), for cases when the 247 | two have different full macroexpansions (for example if the CL macro 248 | contains implementation-specific code when macroexpanded fully in the 249 | CL environment)." 250 | `(progn (defmacro ,name ,args ,@body) 251 | (defpsmacro ,name ,args ,@body))) 252 | 253 | (defun symbol-macro? (form) 254 | "If FORM is a symbol macro, return its macro function. Otherwise, 255 | return NIL." 256 | (and (symbolp form) 257 | (or (and (member form *enclosing-lexicals*) 258 | (lookup-macro-def form *symbol-macro-env*)) 259 | (gethash form *symbol-macro-toplevel*)))) 260 | 261 | (defun ps-macroexpand-1 (form) 262 | (aif (or (symbol-macro? form) 263 | (and (consp form) (lookup-macro-def (car form) *macro-env*))) 264 | (values (ps-macroexpand (funcall it form)) t) 265 | form)) 266 | 267 | (defun ps-macroexpand (form) 268 | (multiple-value-bind (form1 expanded?) 269 | (ps-macroexpand-1 form) 270 | (if expanded? 271 | (values (ps-macroexpand form1) t) 272 | form1))) 273 | 274 | ;;;; compiler interface 275 | 276 | (defparameter *compilation-level* :toplevel 277 | "This value takes on the following values: 278 | :toplevel indicates that we are traversing toplevel forms. 279 | :inside-toplevel-form indicates that we are inside a call to ps-compile-* 280 | nil indicates we are no longer toplevel-related.") 281 | 282 | (defun adjust-compilation-level (form level) 283 | "Given the current *compilation-level*, LEVEL, and the fully macroexpanded 284 | form, FORM, returns the new value for *compilation-level*." 285 | (cond ((or (and (consp form) 286 | (member (car form) '(progn locally macrolet symbol-macrolet))) 287 | (and (symbolp form) (eq :toplevel level))) 288 | level) 289 | ((eq :toplevel level) :inside-toplevel-form))) 290 | 291 | (defvar compile-expression?) 292 | (defvar clear-multiple-values? t) 293 | 294 | (define-condition compile-expression-error (error) 295 | ((form :initarg :form :reader error-form)) 296 | (:report 297 | (lambda (condition stream) 298 | (format 299 | stream 300 | "The Parenscript form ~A cannot be compiled into an expression." 301 | (error-form condition))))) 302 | 303 | (defun compile-special-form (form) 304 | (let* ((op (car form)) 305 | (statement-impl (gethash op *special-statement-operators*)) 306 | (expression-impl (gethash op *special-expression-operators*))) 307 | (cond ((not compile-expression?) 308 | (apply (or statement-impl expression-impl) (cdr form))) 309 | (expression-impl 310 | (apply expression-impl (cdr form))) 311 | ((member op *lambda-wrappable-statements*) 312 | (compile-expression (with-lambda-scope form))) 313 | (t 314 | (error 'compile-expression-error :form form))))) 315 | 316 | (defun ps-compile (form) 317 | (macrolet 318 | ((try-expanding (form &body body) 319 | `(multiple-value-bind (expansion expanded?) 320 | (ps-macroexpand ,form) 321 | (if expanded? 322 | (ps-compile expansion) 323 | ,@body)))) 324 | (typecase form 325 | ((or null number string character) 326 | form) 327 | (vector 328 | (ps-compile `(quote ,(coerce form 'list)))) 329 | (symbol 330 | (try-expanding form form)) 331 | (cons 332 | (try-expanding form 333 | (let ((*compilation-level* 334 | (adjust-compilation-level form *compilation-level*))) 335 | (if (special-form? form) 336 | (compile-special-form form) 337 | (progn 338 | (setq clear-multiple-values? t) 339 | `(ps-js:funcall 340 | ,(if (symbolp (car form)) 341 | (maybe-rename-local-function (car form)) 342 | (compile-expression (car form))) 343 | ,@(mapcar #'compile-expression (cdr form))))))))))) 344 | 345 | (defun compile-statement (form) 346 | (let ((compile-expression? nil)) 347 | (ps-compile form))) 348 | 349 | (defun compile-expression (form) 350 | (let ((compile-expression? t)) 351 | (ps-compile form))) 352 | 353 | (defun ps-gensym (&optional (x '_js)) 354 | (make-symbol 355 | (if (integerp x) 356 | (format nil "~A~A" '_js x) 357 | (let ((prefix (string x))) 358 | (format nil "~A~:[~;_~]~A" 359 | prefix 360 | (digit-char-p (char prefix (1- (length prefix)))) 361 | (incf *ps-gensym-counter*)))))) 362 | 363 | (defmacro with-ps-gensyms (symbols &body body) 364 | "Helper macro for writing Parenscript macros. Each element of 365 | SYMBOLS is either a symbol or a list of (symbol 366 | gensym-prefix-string)." 367 | `(let* ,(mapcar (lambda (symbol) 368 | (destructuring-bind (symbol &optional prefix) 369 | (if (consp symbol) 370 | symbol 371 | (list symbol)) 372 | (if prefix 373 | `(,symbol (ps-gensym ,(string prefix))) 374 | `(,symbol (ps-gensym ,(string symbol)))))) 375 | symbols) 376 | ,@body)) 377 | 378 | (defmacro ps-once-only ((&rest vars) &body body) 379 | "Helper macro for writing Parenscript macros. Useful for preventing unwanted multiple evaluation." 380 | (warn-deprecated 'ps-once-only 'maybe-once-only) 381 | (let ((gensyms (mapcar #'ps-gensym vars))) 382 | `(let* ,(mapcar (lambda (g v) `(,g (ps-gensym ',v))) 383 | gensyms vars) 384 | `(let* (,,@(mapcar (lambda (g v) `(list ,g ,v)) 385 | gensyms vars)) 386 | ,(let* ,(mapcar (lambda (g v) (list v g)) 387 | gensyms vars) 388 | ,@body))))) 389 | 390 | (defmacro maybe-once-only ((&rest vars) &body body) 391 | "Helper macro for writing Parenscript macros. Like PS-ONCE-ONLY, 392 | except that if the given VARS are variables or constants, no intermediate variables are created." 393 | (let ((vars-bound (gensym))) 394 | `(let* 395 | ((,vars-bound ()) 396 | ,@(loop for var in vars collect 397 | `(,var 398 | (let ((form (ps-macroexpand ,var))) 399 | (if (atom form) 400 | form 401 | (let ((var¹ (ps-gensym ',var))) 402 | (push (list var¹ form) ,vars-bound) 403 | var¹)))))) 404 | `(let* ,(nreverse ,vars-bound) 405 | ,,@body)))) 406 | -------------------------------------------------------------------------------- /src/deprecated-interface.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-06 Edward Marco Baringer 3 | ;;; Copyright 2007 Red Daly 4 | ;;; Copyright 2007 Attila Lendvai 5 | ;;; Copyright 2007-2012 Vladimir Sedach 6 | ;;; Copyright 2008 Travis Cross 7 | ;;; Coypright 2010, 2013 Daniel Gackle 8 | 9 | ;;; SPDX-License-Identifier: BSD-3-Clause 10 | 11 | ;;; Redistribution and use in source and binary forms, with or 12 | ;;; without modification, are permitted provided that the following 13 | ;;; conditions are met: 14 | 15 | ;;; 1. Redistributions of source code must retain the above copyright 16 | ;;; notice, this list of conditions and the following disclaimer. 17 | 18 | ;;; 2. Redistributions in binary form must reproduce the above 19 | ;;; copyright notice, this list of conditions and the following 20 | ;;; disclaimer in the documentation and/or other materials provided 21 | ;;; with the distribution. 22 | 23 | ;;; 3. Neither the name of the copyright holder nor the names of its 24 | ;;; contributors may be used to endorse or promote products derived 25 | ;;; from this software without specific prior written permission. 26 | 27 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 28 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 29 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 30 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 31 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 32 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 33 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 34 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 35 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 36 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 37 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 38 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 39 | ;;; POSSIBILITY OF SUCH DAMAGE. 40 | 41 | (in-package #:parenscript) 42 | (in-readtable :parenscript) 43 | 44 | (defun warn-deprecated (old-name &optional new-name) 45 | (warn 'simple-style-warning 46 | :format-control "~:@(~a~) is deprecated~:[.~;, use ~:@(~a~) instead~]" 47 | :format-arguments (list old-name new-name new-name))) 48 | 49 | (defmacro defun-js (old-name new-name args &body body) 50 | `(defun ,old-name ,args 51 | ,(when (and (stringp (car body)) (< 1 (length body))) ; docstring 52 | (car body)) 53 | (warn-deprecated ',old-name ',new-name) 54 | ,@body)) 55 | 56 | ;;; DEPRECATED INTERFACE 57 | 58 | (defmacro define-script-symbol-macro (name &body body) 59 | (warn-deprecated 'define-script-symbol-macro 'define-ps-symbol-macro) 60 | `(define-ps-symbol-macro ,name ,@body)) 61 | 62 | (defun js-equal (ps-form1 ps-form2) 63 | (warn-deprecated 'js-equal) 64 | (equalp ps-form1 ps-form2)) 65 | 66 | (defun-js js-compile compile-script (form) 67 | (compile-script form)) 68 | 69 | (defun-js js-compile-list compile-script (form) 70 | (compile-script form)) 71 | 72 | (defmacro defjsmacro (&rest args) 73 | (warn-deprecated 'defjsmacro 'defpsmacro) 74 | `(defpsmacro ,@args)) 75 | 76 | (defmacro js-inline (&rest body) 77 | (warn-deprecated 'js-inline 'ps-inline) 78 | `(js-inline* '(progn ,@body))) 79 | 80 | (defun-js js-inline* ps-inline* (&rest body) 81 | (apply #'ps-inline* body)) 82 | 83 | (defmacro with-unique-js-names (&rest args) 84 | (warn-deprecated 'with-unique-js-names 'with-ps-gensyms) 85 | `(with-ps-gensyms ,@args)) 86 | 87 | (defun-js gen-js-name ps-gensym (&optional (prefix "_JS_")) 88 | (ps-gensym prefix)) 89 | 90 | (defmacro js (&rest args) 91 | (warn-deprecated 'js 'ps) 92 | `(ps ,@args)) 93 | 94 | (defun-js js* ps* (&rest args) 95 | (apply #'ps* args)) 96 | 97 | (defun-js compile-script ps* (ps-form &key (output-stream nil)) 98 | "Compiles the Parenscript form PS-FORM into Javascript. 99 | If OUTPUT-STREAM is NIL, then the result is a string; otherwise code 100 | is output to the OUTPUT-STREAM stream." 101 | (format output-stream "~A" (ps* ps-form))) 102 | 103 | (defun-js symbol-to-js symbol-to-js-string (symbol) 104 | (symbol-to-js-string symbol)) 105 | 106 | (defmacro defmacro/ps (name args &body body) 107 | (warn-deprecated 'defmacro/ps 'defmacro+ps) 108 | `(progn (defmacro ,name ,args ,@body) 109 | (import-macros-from-lisp ',name))) 110 | 111 | (defmacro defpsmacro-deprecated (old new) 112 | `(defpsmacro ,old (&rest args) 113 | (warn-deprecated ',old ',new) 114 | (cons ',new args))) 115 | 116 | (defpsmacro-deprecated slot-value getprop) 117 | (defpsmacro-deprecated === eql) 118 | (defpsmacro-deprecated == equal) 119 | (defpsmacro-deprecated % rem) 120 | (defpsmacro-deprecated concat-string stringify) 121 | 122 | (defpsmacro !== (&rest args) 123 | (warn-deprecated '!==) 124 | `(not (eql ,@args))) 125 | 126 | (defpsmacro != (&rest args) 127 | (warn-deprecated '!=) 128 | `(not (equal ,@args))) 129 | 130 | (defpsmacro labeled-for (label init-forms cond-forms step-forms &rest body) 131 | (warn-deprecated 'labeled-for 'label) 132 | `(label ,label (for ,init-forms ,cond-forms ,step-forms ,@body))) 133 | 134 | (defpsmacro do-set-timeout ((timeout) &body body) 135 | (warn-deprecated 'do-set-timeout 'set-timeout) 136 | `(set-timeout (lambda () ,@body) ,timeout)) 137 | 138 | (defun concat-string (&rest things) 139 | (warn-deprecated 'concat-string 'stringify) 140 | (apply #'stringify things)) 141 | 142 | (define-statement-operator with (expression &rest body) 143 | (warn-deprecated 'with '|LET or WITH-SLOTS|) 144 | `(ps-js:with ,(compile-expression expression) 145 | ,(compile-statement `(progn ,@body)))) 146 | 147 | (define-statement-operator while (test &rest body) 148 | (warn-deprecated 'while '|LOOP WHILE|) 149 | `(ps-js:while ,(compile-expression test) 150 | ,(compile-loop-body () body))) 151 | 152 | (defmacro while (test &body body) 153 | (warn-deprecated 'while '|LOOP WHILE|) 154 | `(loop while ,test do (progn ,@body))) 155 | 156 | (defpsmacro label (&rest args) 157 | (warn-deprecated 'label 'block) 158 | `(block ,@args)) 159 | 160 | (define-ps-symbol-macro f ps-js:false) 161 | 162 | (setf %compiling-reserved-forms-p% nil) 163 | -------------------------------------------------------------------------------- /src/function-definition.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2011 Vladimir Sedach 2 | ;;; Copyright 2014-2015 Boris Smilga 3 | ;;; Copyright 2014 Max Rottenkolber 4 | 5 | ;;; SPDX-License-Identifier: BSD-3-Clause 6 | 7 | ;;; Redistribution and use in source and binary forms, with or 8 | ;;; without modification, are permitted provided that the following 9 | ;;; conditions are met: 10 | 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | 14 | ;;; 2. Redistributions in binary form must reproduce the above 15 | ;;; copyright notice, this list of conditions and the following 16 | ;;; disclaimer in the documentation and/or other materials provided 17 | ;;; with the distribution. 18 | 19 | ;;; 3. Neither the name of the copyright holder nor the names of its 20 | ;;; contributors may be used to endorse or promote products derived 21 | ;;; from this software without specific prior written permission. 22 | 23 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 28 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 29 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 30 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 32 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 33 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 34 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 | ;;; POSSIBILITY OF SUCH DAMAGE. 36 | 37 | (in-package #:parenscript) 38 | (in-readtable :parenscript) 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;; lambda lists 42 | 43 | (defun parse-key-spec (key-spec) 44 | "parses an &key parameter. Returns 5 values: 45 | var, init-form, keyword-name, supplied-p-var, init-form-supplied-p. 46 | 47 | Syntax of key spec: 48 | [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* 49 | " 50 | (let* ((var (cond ((symbolp key-spec) key-spec) 51 | ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec)) 52 | ((and (listp key-spec) (listp (first key-spec))) (second (first key-spec))))) 53 | (keyword-name (if (and (listp key-spec) (listp (first key-spec))) 54 | (first (first key-spec)) 55 | (intern (string var) :keyword))) 56 | (init-form (if (listp key-spec) (second key-spec) nil)) 57 | (init-form-supplied-p (if (listp key-spec) t nil)) 58 | (supplied-p-var (if (listp key-spec) (third key-spec) nil))) 59 | (values var init-form keyword-name supplied-p-var init-form-supplied-p))) 60 | 61 | (defun parse-optional-spec (spec) 62 | "Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var. 63 | [&optional {var | (var [init-form [supplied-p-parameter]])}*] " 64 | (let* ((var (cond ((symbolp spec) spec) 65 | ((and (listp spec) (first spec))))) 66 | (init-form (if (listp spec) (second spec))) 67 | (supplied-p-var (if (listp spec) (third spec)))) 68 | (values var init-form supplied-p-var))) 69 | 70 | (defun parse-body (body &key allow-docstring) 71 | "Parses a function or block body, which may or may not include a 72 | docstring. Returns 2 or 3 values: a docstring (if allowed for), a list 73 | of (declare ...) forms, and the remaining body." 74 | (let (docstring declarations) 75 | (loop while 76 | (cond ((and (consp (car body)) (eq (caar body) 'declare)) 77 | (push (pop body) declarations)) 78 | ((and allow-docstring (not docstring) 79 | (stringp (car body)) (cdr body)) 80 | (setf docstring (pop body))))) 81 | (values body declarations docstring))) 82 | 83 | (defun parse-extended-function (lambda-list body) 84 | "The lambda list is transformed as follows: 85 | 86 | * standard and optional variables are the mapped directly into 87 | the js-lambda list 88 | 89 | * keyword variables are not included in the js-lambda list, but 90 | instead are obtained from the magic js ARGUMENTS 91 | pseudo-array. Code assigning values to keyword vars is 92 | prepended to the body of the function." 93 | (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? 94 | aux more? more-context more-count key-object) 95 | (parse-lambda-list lambda-list) 96 | (declare (ignore allow? aux? aux more? more-context more-count key-object)) 97 | (let* ( ;; optionals are of form (var default-value) 98 | (effective-args 99 | (remove-if #'null 100 | (append requireds 101 | (mapcar #'parse-optional-spec optionals)))) 102 | (opt-forms 103 | (mapcar (lambda (opt-spec) 104 | (multiple-value-bind (name value suppl) 105 | (parse-optional-spec opt-spec) 106 | (cond (suppl 107 | `(progn 108 | (var ,suppl (not (eql ,name undefined))) 109 | ,@(when value 110 | `((when (not ,suppl) (setf ,name ,value)))))) 111 | (value 112 | `(when (eql ,name undefined) 113 | (setf ,name ,value)))))) 114 | optionals)) 115 | (key-forms 116 | (when keys? 117 | (with-ps-gensyms (n) 118 | (let (defaults assigns) 119 | (mapc 120 | (lambda (k) 121 | (multiple-value-bind (var init-form keyword-str suppl) 122 | (parse-key-spec k) 123 | (push `(var ,var ,@(when init-form `((if (undefined ,var) ,init-form ,var)))) defaults) 124 | (when suppl (push `(var ,suppl) defaults)) 125 | (push `(,keyword-str 126 | (setf ,var (aref arguments (1+ ,n)) 127 | ,@(when suppl `(,suppl t)))) 128 | assigns))) 129 | (reverse keys)) 130 | `((loop for ,n from ,(length requireds) below (length arguments) by 2 do 131 | (case (aref arguments ,n) 132 | ,@assigns)) 133 | ,@defaults))))) 134 | (rest-form 135 | (when rest? 136 | `(var ,rest 137 | ((@ Array prototype slice call) 138 | arguments ,(length effective-args)))))) 139 | (multiple-value-bind (fun-body declarations docstring) 140 | (parse-body body :allow-docstring t) 141 | (values effective-args 142 | (append declarations 143 | opt-forms key-forms (awhen rest-form (list it)) 144 | fun-body) 145 | docstring))))) 146 | 147 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 148 | ;;; common 149 | 150 | (defun collapse-function-return-blocks (body) 151 | (append (butlast body) 152 | (let ((last (ps-macroexpand (car (last body))))) 153 | (if (and (listp last) (eq 'block (car last))) 154 | ;; no need for a block at the end of a function body 155 | (progn (push (or (second last) 'nilBlock) 156 | *function-block-names*) 157 | (cddr last)) 158 | (list last))))) 159 | 160 | (defun compile-function-body (args body) 161 | (with-declaration-effects (body body) 162 | (let* ((in-function-scope? t) 163 | (*current-block-tag* nil) 164 | (*vars-needing-to-be-declared* ()) 165 | (*used-up-names* ()) 166 | (returning-values? nil) 167 | (clear-multiple-values? nil) 168 | (*enclosing-function-arguments* 169 | (append args *enclosing-function-arguments*)) 170 | (*enclosing-lexicals* 171 | (set-difference *enclosing-lexicals* args)) 172 | (collapsed-body 173 | (collapse-function-return-blocks body)) 174 | (*dynamic-return-tags* 175 | (append (mapcar (lambda (x) (cons x nil)) 176 | *function-block-names*) 177 | *dynamic-return-tags*)) 178 | (body 179 | (let ((in-loop-scope? nil) 180 | (*loop-scope-lexicals* ()) 181 | (*loop-scope-lexicals-captured* ())) 182 | (cdr 183 | (wrap-for-dynamic-return 184 | *function-block-names* 185 | (compile-statement 186 | `(return-from %function (progn ,@collapsed-body))))))) 187 | (var-decls 188 | (compile-statement 189 | `(progn 190 | ,@(mapcar 191 | (lambda (var) `(var ,var)) 192 | (remove-duplicates *vars-needing-to-be-declared*)))))) 193 | (when in-loop-scope? 194 | (setf *loop-scope-lexicals-captured* 195 | (append (intersection (flatten body) *loop-scope-lexicals*) 196 | *loop-scope-lexicals-captured*))) 197 | `(ps-js:block ,@(reverse (cdr var-decls)) 198 | ,@body)))) 199 | 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | ;;; lambda 202 | 203 | (define-expression-operator lambda (lambda-list &rest body) 204 | (multiple-value-bind (effective-args effective-body) 205 | (parse-extended-function lambda-list body) 206 | `(ps-js:lambda ,effective-args 207 | ,(let ((*function-block-names* ())) 208 | (compile-function-body effective-args effective-body))))) 209 | 210 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 211 | ;;; named functions 212 | 213 | (defun compile-named-function-body (name lambda-list body) 214 | (let ((*enclosing-lexicals* (cons name *enclosing-lexicals*)) 215 | (*function-block-names* (list name))) 216 | (multiple-value-bind (effective-args effective-body docstring) 217 | (parse-extended-function lambda-list body) 218 | (values effective-args 219 | (compile-function-body effective-args effective-body) 220 | docstring)))) 221 | 222 | (define-statement-operator defun% (name lambda-list &rest body) 223 | (multiple-value-bind (effective-args body-block docstring) 224 | (compile-named-function-body name lambda-list body) 225 | (list 'ps-js:defun name effective-args docstring body-block))) 226 | 227 | (defun maybe-rename-local-function (fun-name) 228 | (or (getf *local-function-names* fun-name) fun-name)) 229 | 230 | (defun collect-function-names (fn-defs) 231 | (loop for (fn-name) in fn-defs 232 | collect fn-name 233 | collect (if (or (member fn-name *enclosing-lexicals*) 234 | (lookup-macro-def fn-name *symbol-macro-env*)) 235 | (ps-gensym (string fn-name)) 236 | fn-name))) 237 | 238 | (defun compile-named-local-function (name args body) 239 | (multiple-value-bind (args1 body-block) 240 | (compile-named-function-body name args body) 241 | `(ps-js:lambda ,args1 ,body-block))) 242 | 243 | (defmacro local-functions (special-op &body bindings) 244 | `(if in-function-scope? 245 | (let* ((fn-renames (collect-function-names fn-defs)) 246 | ,@bindings) 247 | `(,(if compile-expression? 'ps-js:|,| 'ps-js:block) 248 | ,@definitions 249 | ,@(compile-progn body))) 250 | (ps-compile (with-lambda-scope `(,',special-op ,fn-defs ,@body))))) 251 | 252 | (defun compile-local-function-defs (fn-defs renames) 253 | (loop for (fn-name . (args . body)) in fn-defs collect 254 | (progn (when compile-expression? 255 | (push (getf renames fn-name) 256 | *vars-needing-to-be-declared*)) 257 | (list (if compile-expression? 'ps-js:= 'ps-js:var) 258 | (getf renames fn-name) 259 | (compile-named-local-function fn-name args body))))) 260 | 261 | (define-expression-operator flet (fn-defs &rest body) 262 | (local-functions flet 263 | ;; the function definitions need to be compiled with previous 264 | ;; lexical bindings 265 | (definitions (compile-local-function-defs fn-defs fn-renames)) 266 | ;; the flet body needs to be compiled with the extended 267 | ;; lexical environment 268 | (*enclosing-lexicals* (append fn-renames *enclosing-lexicals*)) 269 | (*loop-scope-lexicals* (when in-loop-scope? 270 | (append fn-renames *loop-scope-lexicals*))) 271 | (*local-function-names* (append fn-renames *local-function-names*)))) 272 | 273 | (define-expression-operator labels (fn-defs &rest body) 274 | (local-functions labels 275 | (*enclosing-lexicals* (append fn-renames *enclosing-lexicals*)) 276 | (*loop-scope-lexicals* (when in-loop-scope? 277 | (append fn-renames *loop-scope-lexicals*))) 278 | (*local-function-names* (append fn-renames *local-function-names*)) 279 | (definitions (compile-local-function-defs fn-defs *local-function-names*)))) 280 | 281 | (define-expression-operator function (fn-name) 282 | ;; one of the things responsible for function namespace 283 | (ps-compile (maybe-rename-local-function fn-name))) 284 | -------------------------------------------------------------------------------- /src/js-ir-package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2010, 2012 Vladimir Sedach 2 | 3 | ;;; SPDX-License-Identifier: BSD-3-Clause 4 | 5 | ;;; Redistribution and use in source and binary forms, with or 6 | ;;; without modification, are permitted provided that the following 7 | ;;; conditions are met: 8 | 9 | ;;; 1. Redistributions of source code must retain the above copyright 10 | ;;; notice, this list of conditions and the following disclaimer. 11 | 12 | ;;; 2. Redistributions in binary form must reproduce the above 13 | ;;; copyright notice, this list of conditions and the following 14 | ;;; disclaimer in the documentation and/or other materials provided 15 | ;;; with the distribution. 16 | 17 | ;;; 3. Neither the name of the copyright holder nor the names of its 18 | ;;; contributors may be used to endorse or promote products derived 19 | ;;; from this software without specific prior written permission. 20 | 21 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 22 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 23 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 24 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 26 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 27 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 28 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 30 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 31 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 32 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 | ;;; POSSIBILITY OF SUCH DAMAGE. 34 | 35 | 36 | (in-package #:parenscript) 37 | (in-readtable :parenscript) 38 | 39 | (defpackage #:ps-js 40 | (:use) 41 | (:export 42 | ;; operators 43 | ;; arithmetic 44 | #:+ 45 | #:unary-plus 46 | #:- 47 | #:negate 48 | #:* 49 | #:/ 50 | #:% 51 | 52 | ;; bitwise 53 | #:& 54 | #:\| 55 | #:^ 56 | #:~ 57 | #:>> 58 | #:<< 59 | #:>>> 60 | 61 | ;; assignment 62 | #:= 63 | #:+= 64 | #:-= 65 | #:*= 66 | #:/= 67 | #:%= 68 | #:&= 69 | #:\|= 70 | #:^= 71 | #:~= 72 | #:>>= 73 | #:<<= 74 | #:>>>= 75 | 76 | ;; increment/decrement 77 | #:++ 78 | #:-- 79 | #:post++ 80 | #:post-- 81 | 82 | ;; comparison 83 | #:== 84 | #:=== 85 | #:!= 86 | #:!== 87 | #:> 88 | #:>= 89 | #:< 90 | #:<= 91 | 92 | ;; logical 93 | #:&& 94 | #:\|\| 95 | #:! 96 | 97 | ;; misc 98 | #:? ;; ternary 99 | #:|,| 100 | #:delete 101 | #:function 102 | #:get 103 | #:set 104 | #:in 105 | #:instanceof 106 | #:new 107 | #:typeof 108 | #:void 109 | 110 | ;; literals 111 | #:nil 112 | #:t 113 | #:false 114 | #:undefined 115 | #:this 116 | 117 | ;; statements 118 | #:block 119 | #:break 120 | #:continue 121 | #:do-while ; currently unused 122 | #:for 123 | #:for-in 124 | #:if 125 | #:label 126 | #:return 127 | #:switch 128 | #:default 129 | #:throw 130 | #:try 131 | #:var 132 | #:while 133 | #:with 134 | 135 | #:array 136 | #:aref 137 | #:cond 138 | #:lambda 139 | #:defun 140 | #:object 141 | #:getprop 142 | #:funcall 143 | #:escape 144 | #:regex 145 | )) 146 | -------------------------------------------------------------------------------- /src/lib/ps-dom.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2009-2010 Daniel Gackle 2 | 3 | ;;; SPDX-License-Identifier: BSD-3-Clause 4 | 5 | ;;; Redistribution and use in source and binary forms, with or 6 | ;;; without modification, are permitted provided that the following 7 | ;;; conditions are met: 8 | 9 | ;;; 1. Redistributions of source code must retain the above copyright 10 | ;;; notice, this list of conditions and the following disclaimer. 11 | 12 | ;;; 2. Redistributions in binary form must reproduce the above 13 | ;;; copyright notice, this list of conditions and the following 14 | ;;; disclaimer in the documentation and/or other materials provided 15 | ;;; with the distribution. 16 | 17 | ;;; 3. Neither the name of the copyright holder nor the names of its 18 | ;;; contributors may be used to endorse or promote products derived 19 | ;;; from this software without specific prior written permission. 20 | 21 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 22 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 23 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 24 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 26 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 27 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 28 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 30 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 31 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 32 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 | ;;; POSSIBILITY OF SUCH DAMAGE. 34 | 35 | (in-package #:parenscript) 36 | 37 | ;; Utilities for accessing standard DOM functionality in a Lispier, PSier way. 38 | 39 | (defpsmacro inner-html (el) 40 | `(@ ,el 'inner-h-t-m-l)) 41 | 42 | (defpsmacro uri-encode (str) 43 | `(if (null ,str) "" (encode-u-r-i-component ,str))) 44 | 45 | (defpsmacro attribute (el attr) 46 | `((@ ,el 'get-attribute) ,attr)) 47 | 48 | (defun assert-is-one-of (val options) 49 | (unless (member val options) 50 | (error "~s is not one of ~s" val options))) 51 | 52 | (defpsmacro offset (what el) 53 | (if (consp what) 54 | `(offset ,(eval what) ,el) 55 | (case what 56 | ((:top :left :height :width) `(@ ,el ,(intern (format nil "OFFSET-~a" what)))) 57 | (:right `(+ (offset :left ,el) (offset :width ,el))) 58 | (:bottom `(+ (offset :top ,el) (offset :height ,el))) 59 | (:hcenter `(+ (offset :left ,el) (/ (offset :width ,el) 2))) 60 | (:vcenter `(+ (offset :top ,el) (/ (offset :height ,el) 2))) 61 | (t (error "The OFFSET macro doesn't accept ~s as a key." what))))) 62 | 63 | (defpsmacro scroll (what el) 64 | (assert-is-one-of what '(:top :left :right :bottom :width :height)) 65 | (cond ((member what '(:top :left :width :height)) 66 | `(@ ,el ,(intern (format nil "SCROLL-~a" what)))) 67 | ((eq what :right) 68 | `(+ (scroll :left ,el) (offset :width ,el))) 69 | ((eq what :bottom) 70 | `(+ (scroll :top ,el) (offset :height ,el))))) 71 | 72 | (defpsmacro inner (what el) 73 | (assert-is-one-of what '(:width :height)) 74 | `(@ ,el ,(intern (format nil "INNER-~a" what)))) 75 | 76 | (defpsmacro client (what el) 77 | (assert-is-one-of what '(:width :height)) 78 | `(@ ,el ,(intern (format nil "CLIENT-~a" what)))) 79 | -------------------------------------------------------------------------------- /src/lib/ps-html.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005 Edward Marco Baringer 3 | ;;; Copyright 2007-2011 Vladimir Sedach 4 | 5 | ;;; SPDX-License-Identifier: BSD-3-Clause 6 | 7 | ;;; Redistribution and use in source and binary forms, with or 8 | ;;; without modification, are permitted provided that the following 9 | ;;; conditions are met: 10 | 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | 14 | ;;; 2. Redistributions in binary form must reproduce the above 15 | ;;; copyright notice, this list of conditions and the following 16 | ;;; disclaimer in the documentation and/or other materials provided 17 | ;;; with the distribution. 18 | 19 | ;;; 3. Neither the name of the copyright holder nor the names of its 20 | ;;; contributors may be used to endorse or promote products derived 21 | ;;; from this software without specific prior written permission. 22 | 23 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 28 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 29 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 30 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 32 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 33 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 34 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 | ;;; POSSIBILITY OF SUCH DAMAGE. 36 | 37 | (in-package #:parenscript) 38 | (named-readtables:in-readtable :parenscript) 39 | 40 | (defvar *ps-html-empty-tag-aware-p* t) 41 | (defvar *ps-html-mode* :sgml "One of :sgml or :xml") 42 | 43 | (defvar *html-empty-tags* '(:area :atop :audioscope :base :basefont :br :choose :col :frame 44 | :hr :img :input :isindex :keygen :left :limittext :link :meta 45 | :nextid :of :over :param :range :right :spacer :spot :tab :wbr)) 46 | 47 | (defun empty-tag-p (tag) 48 | (and *ps-html-empty-tag-aware-p* 49 | (member tag *html-empty-tags*))) 50 | 51 | (defun concat-constant-strings (str-list) 52 | (flet ((expand (expr) 53 | (setf expr (ps-macroexpand expr)) 54 | (cond ((and (consp expr) (eq (car expr) 'quote) (symbolp (second expr))) 55 | (symbol-to-js-string (second expr))) 56 | ((keywordp expr) (string-downcase expr)) 57 | ((characterp expr) (string expr)) 58 | (t expr)))) 59 | (reverse (reduce (lambda (optimized-list next-expr) 60 | (let ((next-obj (expand next-expr))) 61 | (if (and (or (numberp next-obj) (stringp next-obj)) 62 | (stringp (car optimized-list))) 63 | (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list)) 64 | (cons next-obj optimized-list)))) 65 | (cons () str-list))))) 66 | 67 | (defun process-html-forms-lhtml (forms) 68 | (let ((r ())) 69 | (labels ((process-attrs (attrs) 70 | (do (attr-test attr-name attr-val) 71 | ((not attrs)) 72 | (setf attr-name (pop attrs) 73 | attr-test (when (not (keywordp attr-name)) 74 | (let ((test attr-name)) 75 | (setf attr-name (pop attrs)) 76 | test)) 77 | attr-val (pop attrs)) 78 | (if attr-test 79 | (push `(if ,attr-test 80 | (stringify ,(format nil " ~(~A~)=\"" attr-name) ,attr-val "\"") 81 | "") 82 | r) 83 | (progn 84 | (push (format nil " ~(~A~)=\"" attr-name) r) 85 | (push attr-val r) 86 | (push "\"" r))))) 87 | (process-form% (tag attrs content) 88 | (push (format nil "<~(~A~)" tag) r) 89 | (process-attrs attrs) 90 | (if (or content (not (empty-tag-p tag))) 91 | (progn (push ">" r) 92 | (map nil #'process-form content) 93 | (push (format nil "" tag) r)) 94 | (progn (when (eql *ps-html-mode* :xml) 95 | (push "/" r)) 96 | (push ">" r)))) 97 | (process-form (form) 98 | (cond ((keywordp form) (process-form (list form))) 99 | ((atom form) (push form r)) 100 | ((and (consp form) (keywordp (car form))) 101 | (process-form% (car form) () (cdr form))) 102 | ((and (consp form) (consp (first form)) (keywordp (caar form))) 103 | (process-form% (caar form) (cdar form) (cdr form))) 104 | (t (push form r))))) 105 | (map nil #'process-form forms) 106 | (concat-constant-strings (reverse r))))) 107 | 108 | (defun process-html-forms-cl-who (forms) 109 | (let ((r ())) 110 | (labels ((process-form (form) 111 | (cond ((keywordp form) (process-form (list form))) 112 | ((atom form) (push form r)) 113 | ((and (consp form) (keywordp (car form))) 114 | (push (format nil "<~(~A~)" (car form)) r) 115 | (labels ((process-attributes (el-body) 116 | (when el-body 117 | (if (keywordp (car el-body)) 118 | (progn 119 | (push (format nil " ~(~A~)=\"" 120 | (car el-body)) r) 121 | (push (cadr el-body) r) 122 | (push "\"" r) 123 | (process-attributes (cddr el-body))) 124 | el-body)))) 125 | (let ((content (process-attributes (cdr form)))) 126 | (if (or content (not (empty-tag-p (car form)))) 127 | (progn (push ">" r) 128 | (when content (map nil #'process-form content)) 129 | (push (format nil "" (car form)) r)) 130 | (progn (when (eql *ps-html-mode* :xml) 131 | (push "/" r)) 132 | (push ">" r)))))) 133 | (t (push form r))))) 134 | (map nil #'process-form forms) 135 | (concat-constant-strings (reverse r))))) 136 | 137 | (defmacro+ps ps-html (&rest html-forms) 138 | `(stringify ,@(with-standard-io-syntax (process-html-forms-lhtml html-forms)))) 139 | 140 | (defmacro+ps who-ps-html (&rest html-forms) 141 | `(stringify ,@(with-standard-io-syntax (process-html-forms-cl-who html-forms)))) 142 | -------------------------------------------------------------------------------- /src/lib/ps-loop.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2009-2013 Daniel Gackle 2 | ;;; Copyright 2009-2012 Vladimir Sedach 3 | ;;; Copyright 2012, 2015 Boris Smilga 4 | ;;; Copyright 2018 Neil Lindquist 5 | 6 | ;;; SPDX-License-Identifier: BSD-3-Clause 7 | 8 | ;;; Redistribution and use in source and binary forms, with or 9 | ;;; without modification, are permitted provided that the following 10 | ;;; conditions are met: 11 | 12 | ;;; 1. Redistributions of source code must retain the above copyright 13 | ;;; notice, this list of conditions and the following disclaimer. 14 | 15 | ;;; 2. Redistributions in binary form must reproduce the above 16 | ;;; copyright notice, this list of conditions and the following 17 | ;;; disclaimer in the documentation and/or other materials provided 18 | ;;; with the distribution. 19 | 20 | ;;; 3. Neither the name of the copyright holder nor the names of its 21 | ;;; contributors may be used to endorse or promote products derived 22 | ;;; from this software without specific prior written permission. 23 | 24 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 25 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 26 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 27 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 28 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 29 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 30 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 31 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 32 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 33 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 34 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 35 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 36 | ;;; POSSIBILITY OF SUCH DAMAGE. 37 | 38 | (in-package #:parenscript) 39 | (named-readtables:in-readtable :parenscript) 40 | 41 | ;;; bind and bind* - macros used for destructuring bindings in PS LOOP 42 | 43 | (defun dot->rest (x) 44 | (cond ((atom x) x) 45 | ((not (listp (cdr x))) ; dotted list 46 | (list (dot->rest (car x)) '&rest (dot->rest (cdr x)))) 47 | (t (cons (dot->rest (car x)) (dot->rest (cdr x)))))) 48 | 49 | (defun property-bindings-p (x) 50 | (when (consp x) 51 | (every (lambda (y) 52 | (or (keywordp y) ; standalone property name 53 | (and (consp y) ; var name paired with property name 54 | (= (length y) 2) 55 | (symbolp (car y)) 56 | (not (keywordp (car y))) 57 | (keywordp (cadr y))))) 58 | x))) 59 | 60 | (defun extract-bindings (x) 61 | ;; returns a pair of destructuring bindings and property bindings 62 | (cond ((atom x) (list x nil)) 63 | ((property-bindings-p x) 64 | (let ((var (ps-gensym))) 65 | (list var (list x var)))) 66 | (t (loop :for y :on x 67 | :for (d p) = (extract-bindings (car y)) 68 | :collect d :into ds 69 | :when p :append p :into ps 70 | :finally (return (list ds ps)))))) 71 | 72 | (defun property-bindings (bindings expr body) 73 | `(let ,(loop :for b :in bindings 74 | :for (var p) = (cond ((consp b) b) ; var name paired with property name 75 | (t (list (intern (string b)) b))) ; make var from prop 76 | :collect `(,var (@ ,expr ,p))) 77 | ,@body)) 78 | 79 | (defpsmacro bind (bindings expr &body body) 80 | (let ((bindings (dot->rest bindings))) 81 | (destructuring-bind (d p) 82 | (extract-bindings bindings) 83 | (cond ((and (atom d) 84 | (or (= (length bindings) 1) 85 | (atom (ps-macroexpand expr)))) 86 | (property-bindings bindings expr body)) 87 | ((atom d) 88 | (with-ps-gensyms (var) 89 | `(let ((,var ,expr)) 90 | (bind ,bindings ,var ,@body)))) 91 | ((null p) 92 | `(destructuring-bind ,bindings ,expr ,@body)) 93 | (t `(destructuring-bind ,d ,expr 94 | (bind* ,p ,@body))))))) 95 | 96 | (defpsmacro bind* (bindings &body body) 97 | (cond ((= (length bindings) 2) 98 | `(bind ,(car bindings) ,(cadr bindings) ,@body)) 99 | (t `(bind ,(car bindings) ,(cadr bindings) 100 | (bind* ,(cddr bindings) ,@body))))) 101 | 102 | (eval-when (:compile-toplevel :load-toplevel :execute) 103 | (defvar *loop-keywords* 104 | '(:named :for :repeat :with :while :until :initially :finally 105 | :from :downfrom :to :below :downto :above :by :in :across :on := :then 106 | :when :unless :if :else :end :do :doing :return 107 | :sum :summing :collect :collecting :append :appending :count :counting 108 | :minimize :minimizing :maximize :maximizing :map :mapping 109 | :of :into)) 110 | 111 | (defun as-keyword (key) 112 | (cond ((not (symbolp key)) key) 113 | ((keywordp key) key) 114 | (t (intern (symbol-name key) :keyword))))) 115 | 116 | (defmacro loop-case (key &body forms) 117 | (loop :for (match . nil) :in forms 118 | :for keys = (if (listp match) match (list match)) :do 119 | (loop :for k :in keys :do 120 | (assert (member k (append *loop-keywords* '(t otherwise))) 121 | nil "~a isn't a recognized loop keyword." k))) 122 | `(case (as-keyword ,key) ,@forms)) 123 | 124 | (defun err (expected got) 125 | (error "PS-LOOP expected ~a, got ~a." expected got)) 126 | 127 | (defclass loop-state () 128 | ((tokens :initarg :tokens :accessor tokens) 129 | (name :initform nil :accessor name) 130 | ;; A clause is either (:BODY FORM) or (:ITER PLACE INIT STEP TEST &OPTIONAL JS-OBJ) 131 | (clauses :initform nil :accessor clauses) 132 | (prologue :initform nil :accessor prologue) 133 | (finally :initform nil :accessor finally) 134 | (accum-var :initform nil :accessor accum-var) 135 | (accum-kind :initform nil :accessor accum-kind))) 136 | 137 | (defun push-body-clause (clause state) 138 | (push (list :body clause) (clauses state))) 139 | 140 | (defun push-iter-clause (clause state) 141 | (push (cons :iter clause) (clauses state))) 142 | 143 | (defun push-tokens (state toks) 144 | (setf (tokens state) (append toks (tokens state)))) 145 | 146 | (defun peek (state) 147 | (car (tokens state))) 148 | 149 | (defun eat (state &optional what tag) 150 | "Consumes the next meaningful chunk of loop for processing." 151 | (case what 152 | (:if (when (eq (as-keyword (peek state)) tag) 153 | (eat state) 154 | (values (eat state) t))) 155 | (:progn (cons 'progn (loop :collect (if (consp (peek state)) 156 | (eat state) 157 | (err "a compound form" (peek state))) 158 | :until (atom (peek state))))) 159 | (otherwise (let ((tok (pop (tokens state)))) 160 | (when (and (eq what :atom) (not (atom tok))) 161 | (err "an atom" tok)) 162 | (when (and (eq what :symbol) (not (symbolp tok))) 163 | (err "a symbol" tok)) 164 | tok)))) 165 | 166 | (defun maybe-hoist (expr state) 167 | (cond ((complex-js-expr? expr) 168 | (let ((var (ps-gensym))) 169 | (push (list 'setf var expr) (prologue state)) 170 | var)) 171 | (t expr))) 172 | 173 | (defun for-from (from-key var state) 174 | (unless (atom var) 175 | (err "an atom after FROM" var)) 176 | (let ((start (eat state)) 177 | (op (loop-case from-key (:downfrom '-) (otherwise '+))) 178 | (test-op (loop-case from-key (:downfrom '>=) (otherwise '<=))) 179 | (by nil) 180 | (end nil)) 181 | (loop while (member (as-keyword (peek state)) '(:to :below :downto :above :by)) do 182 | (let ((term (eat state))) 183 | (if (eq (as-keyword term) :by) 184 | (setf by (eat state)) 185 | (setf op (loop-case term ((:downto :above) '-) (otherwise op)) 186 | test-op (loop-case term (:to test-op) (:below '<) (:downto '>=) (:above '>)) 187 | end (eat state))))) 188 | (let ((test (when test-op 189 | (list test-op var (maybe-hoist end state))))) 190 | (push-iter-clause `(,var ,start (,op ,var ,(or by 1)) ,test) state)))) 191 | 192 | (defun for-= (place state) 193 | (let ((start (eat state))) 194 | (multiple-value-bind (then thenp) 195 | (eat state :if :then) 196 | (push-iter-clause (list place start (if thenp then start) nil) state)))) 197 | 198 | (defun for-in (place state) 199 | (let ((arr (maybe-hoist (eat state) state)) 200 | (index (ps-gensym))) 201 | (push-tokens state `(,index :from 0 :below (length ,arr) 202 | ,place := (aref ,arr ,index))) 203 | (for-clause state) 204 | (for-clause state))) 205 | 206 | (defun for-on (place state) 207 | (let* ((arr (eat state)) 208 | (by (or (eat state :if :by) 1)) 209 | (var (if (atom place) place (ps-gensym))) 210 | (then (if (numberp by) `((@ ,var :slice) ,by) `(,by ,var)))) 211 | (push-tokens state `(,var := ,arr :then ,then)) 212 | (for-clause state) 213 | ;; set the end-test by snooping into the iteration clause we just added 214 | (setf (fifth (car (clauses state))) `(> (length ,var) 0)) 215 | (unless (eq place var) 216 | (push-tokens state `(,place := ,var)) 217 | (for-clause state)))) 218 | 219 | (defun for-keys-of (place state) 220 | (when (clauses state) 221 | (error "FOR..OF is only allowed as the first clause in a loop.")) 222 | (when (consp place) 223 | (unless (<= (length place) 2) ; length 1 is ok, treat (k) as (k nil) 224 | (error "FOR..OF must be followed by a key variable or key-value pair.")) 225 | (unless (atom (first place)) 226 | (error "The key in a FOR..OF clause must be a variable."))) 227 | (let ((k (or (if (atom place) place (first place)) (ps-gensym))) 228 | (v (when (consp place) (second place)))) 229 | (let ((js-obj (eat state))) 230 | (when v ; assign JS-OBJ to a local var if we need to for value binding (otherwise inline it) 231 | (setf js-obj (maybe-hoist js-obj state))) 232 | (push-iter-clause (list k nil nil nil js-obj) state) 233 | (when v 234 | (let ((val `(getprop ,js-obj ,k))) 235 | (push-iter-clause (list v val val nil) state)))))) 236 | 237 | (defun for-clause (state) 238 | (let ((place (eat state)) 239 | (term (eat state :atom))) 240 | (loop-case term 241 | ((:from :downfrom) (for-from term place state)) 242 | (:= (for-= place state)) 243 | ((:in :across) (for-in place state)) 244 | (:on (for-on place state)) 245 | (:of (for-keys-of place state)) 246 | (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." place term))))) 247 | 248 | (defun a-with-clause (state) ;; so named to avoid with-xxx macro convention 249 | (let ((place (eat state))) 250 | (push (list 'setf place (eat state :if :=)) (prologue state)))) 251 | 252 | (defun accumulate (kind item var state) 253 | (when (null var) 254 | (when (and (accum-kind state) (not (eq kind (accum-kind state)))) 255 | (error "PS-LOOP encountered illegal ~a: ~a was already declared, and there can only be one kind of implicit accumulation per loop." kind (accum-kind state))) 256 | (unless (accum-var state) 257 | (setf (accum-var state) 258 | (ps-gensym (string (loop-case kind 259 | ((:minimize :minimizing) 'min) 260 | ((:maximize :maximizing) 'max) 261 | (t kind))))) 262 | (setf (accum-kind state) kind)) 263 | (setf var (accum-var state))) 264 | (let ((initial (loop-case kind 265 | ((:sum :summing :count :counting) 0) 266 | ((:maximize :maximizing :minimize :minimizing) nil) 267 | ((:collect :collecting :append :appending) '[]) 268 | ((:map :mapping) '{})))) 269 | (push (list 'setf var initial) (prologue state))) 270 | (loop-case kind 271 | ((:sum :summing)`(incf ,var ,item)) 272 | ((:count :counting)`(when ,item (incf ,var))) ;; note the JS semantics - neither 0 nor "" will count 273 | ((:minimize :minimizing) `(setf ,var (if (null ,var) ,item (min ,var ,item)))) 274 | ((:maximize :maximizing) `(setf ,var (if (null ,var) ,item (max ,var ,item)))) 275 | ((:collect :collecting) `((@ ,var 'push) ,item)) 276 | ((:append :appending) `(setf ,var (append ,var ,item))) 277 | ((:map :mapping) (destructuring-bind (key val) item 278 | `(setf (getprop ,var ,key) ,val))))) 279 | 280 | (defun repeat-clause (state) 281 | (let ((index (ps-gensym))) 282 | (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state))) 283 | (for-clause state))) 284 | 285 | (defun while-clause (state) 286 | (push-iter-clause (list nil nil nil (eat state)) state)) 287 | 288 | (defun until-clause (state) 289 | (push-iter-clause (list nil nil nil `(not ,(eat state))) state)) 290 | 291 | (defun body-clause (term state) 292 | (loop-case term 293 | ((:if :when :unless) 294 | (let* ((test-form (eat state)) 295 | (seqs (list (body-clause (eat state :atom) state))) 296 | (alts (list))) 297 | (loop while (eq (as-keyword (peek state)) :and) 298 | do (eat state) 299 | (push (body-clause (eat state :atom) state) seqs)) 300 | (when (eq (as-keyword (peek state)) :else) 301 | (eat state) 302 | (push (body-clause (eat state :atom) state) alts) 303 | (loop while (eq (as-keyword (peek state)) :and) 304 | do (eat state) 305 | (push (body-clause (eat state :atom) state) alts))) 306 | (when (eq (as-keyword (peek state)) :end) 307 | (eat state)) 308 | (if (null alts) 309 | `(,(loop-case term ((:unless) 'unless) (otherwise 'when)) 310 | ,test-form 311 | ,@(reverse seqs)) 312 | `(if ,(loop-case term 313 | ((:unless) `(not ,test-form)) 314 | (otherwise test-form)) 315 | (progn ,@(reverse seqs)) 316 | (progn ,@(reverse alts)))))) 317 | ((:sum :summing :collect :collecting :append :appending :count :counting 318 | :minimize :minimizing :maximize :maximizing) 319 | (accumulate term (eat state) (eat state :if :into) state)) 320 | ((:map :mapping) (let ((key (eat state))) 321 | (multiple-value-bind (val valp) 322 | (eat state :if :to) 323 | (unless valp 324 | (error "MAP must be followed by a TO to specify value.")) 325 | (accumulate :map (list key val) (eat state :if :into) state)))) 326 | ((:do :doing) (eat state :progn)) 327 | (:return `(return-from ,(name state) ,(eat state))) 328 | (otherwise (err "a PS-LOOP keyword" term)))) 329 | 330 | (defun clause (state) 331 | (let ((term (eat state :atom))) 332 | (loop-case term 333 | (:named (setf (name state) (eat state :symbol))) 334 | (:with (a-with-clause state)) 335 | (:initially (push (eat state :progn) (prologue state))) 336 | (:for (for-clause state)) 337 | (:repeat (repeat-clause state)) 338 | (:while (while-clause state)) 339 | (:until (until-clause state)) 340 | (:finally (push (eat state :progn) (finally state))) 341 | (otherwise (push-body-clause (body-clause term state) state))))) 342 | 343 | (defun parse-ps-loop (terms) 344 | (cond ((null terms) (err "loop definition" nil)) 345 | (t (let ((state (make-instance 'loop-state :tokens terms))) 346 | (loop :while (tokens state) :do (clause state)) 347 | state)))) 348 | 349 | (defun fold-iterations-where-possible (clauses) 350 | (let ((folded '())) 351 | (loop :for clause :in clauses :do 352 | (assert (member (car clause) '(:iter :body))) 353 | (let ((folded? nil)) 354 | (when (and (eq (car clause) :iter) (eq (caar folded) :iter)) 355 | (destructuring-bind (tag place init step test &optional js-obj) clause 356 | (declare (ignore tag)) 357 | (when (null place) ;; can't combine two iterations that both have state 358 | (assert (not (or init step js-obj)) nil "Invalid iteration ~a: PLACE should not be null." clause) 359 | (assert test nil "Iteration ~a has neither PLACE nor TEST." clause) 360 | (unless (sixth (car folded)) ;; js-obj means a for..in loop and those can't have tests 361 | (let ((prev-test (fifth (car folded)))) 362 | (setf (fifth (car folded)) (if prev-test `(and ,prev-test ,test) test)) 363 | (setf folded? t)))))) 364 | (unless folded? 365 | (push clause folded)))) 366 | (nreverse folded))) 367 | 368 | (defun organize-iterations (clauses) 369 | ;; we want clauses to start with a master loop to provide the 370 | ;; skeleton for everything else. secondary iterations are ok but 371 | ;; will be generated inside the body of this master loop 372 | (unless (eq (caar clauses) :iter) 373 | (push (list :iter nil nil nil t) clauses)) 374 | ;; unify adjacent test expressions by ANDing them together where possible 375 | (setf clauses (fold-iterations-where-possible clauses)) 376 | ;; if leading iteration has a binding expression, replace it with a var 377 | (destructuring-bind (tag place init step test &optional js-obj) (car clauses) 378 | (assert (eq tag :iter)) 379 | (when (complex-js-expr? place) 380 | (assert (null js-obj) nil "Invalid iteration ~a: FOR..IN can't have a binding expression." (car clauses)) 381 | (let ((var (ps-gensym))) 382 | (pop clauses) 383 | (push (list :iter place var var nil) clauses) 384 | (push (list :iter var init step test) clauses)))) 385 | clauses) 386 | 387 | (defun build-body (clauses firstvar) 388 | (cond ((null clauses) nil) 389 | ((eq (caar clauses) :body) 390 | (cons (second (car clauses)) (build-body (cdr clauses) firstvar))) 391 | (t (destructuring-bind (tag place init step test) (car clauses) 392 | (assert (eq tag :iter)) 393 | (let ((body (build-body (cdr clauses) firstvar))) 394 | (when test 395 | (push `(unless ,test (break)) body)) 396 | (when place 397 | (let ((expr (if (tree-equal init step) init `(if ,firstvar ,init ,step)))) 398 | (setf body 399 | (cond ((and (atom place) (eq expr init)) 400 | `((let ((,place ,expr)) ,@body))) 401 | ;; can't use LET because EXPR may reference PLACE 402 | ((atom place) `((var ,place ,expr) ,@body)) 403 | ;; BIND has scoping problems. For example, 404 | ;; (loop :for (a b) = x :then b) doesn't work 405 | ;; since EXPR is referencing part of PLACE. 406 | ;; But the following is ok for known uses so far. 407 | (t `((bind ,place ,expr ,@body))))))) 408 | body))))) 409 | 410 | (define-statement-operator loop-while (test &rest body) 411 | `(ps-js:while ,(compile-expression test) 412 | ,(compile-loop-body () body))) 413 | 414 | (defun master-loop (master-iter body) 415 | (destructuring-bind (tag place init step test &optional js-obj) master-iter 416 | (assert (eq tag :iter)) 417 | (cond ((null place) `(loop-while ,test ,@body)) 418 | (js-obj 419 | (assert (not (or init step test)) nil "Unexpected iteration state in for..in loop: ~a" master-iter) 420 | `(for-in (,place ,js-obj) ,@body)) 421 | (t (assert (atom place) nil "Unexpected destructuring list ~a in master loop" place) 422 | `(for ((,place ,init)) (,(or test t)) ((setf ,place ,step)) ,@body))))) 423 | 424 | (defun build-loop (clauses) 425 | (destructuring-bind (master . rest) clauses 426 | (assert (eq (car master) :iter) nil "First clause is not master loop: ~a" master) 427 | (let* ((firstvar (loop :for (tag nil init step) :in rest 428 | :when (and (eq tag :iter) (not (tree-equal init step))) 429 | :do (return (ps-gensym 'FIRST)))) 430 | (body (build-body rest firstvar))) 431 | (when firstvar 432 | (setf body (append body `((setf ,firstvar nil))))) 433 | (let ((form (master-loop master body))) 434 | (if firstvar `(let ((,firstvar t)) ,form) form))))) 435 | 436 | (defun prologue-wrap (prologue body) 437 | (cond ((null prologue) body) 438 | ((equal 'setf (caar prologue)) 439 | (destructuring-bind (place expr) (cdr (car prologue)) 440 | (prologue-wrap 441 | (cdr prologue) 442 | (cond ((atom place) (cons `(var ,place ,expr) body)) 443 | (t `((bind ,place ,expr ,@body))))))) 444 | (t (prologue-wrap 445 | (cdr prologue) 446 | (cons (car prologue) body))))) 447 | 448 | (defpsmacro loop (&rest keywords-and-forms) 449 | (let ((state (parse-ps-loop keywords-and-forms))) 450 | (let* ((clauses (organize-iterations (reverse (clauses state)))) 451 | (main `(,(build-loop (organize-iterations clauses)) 452 | ,@(reverse (finally state)) 453 | ,@(awhen (accum-var state) (list it)))) 454 | (full `(block ,(name state) ,@(prologue-wrap (prologue state) main)))) 455 | (if (accum-var state) 456 | (with-lambda-scope full) 457 | full)))) 458 | -------------------------------------------------------------------------------- /src/macros.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-2006 Edward Marco Baringer 3 | ;;; Copyright 2006 Luca Capello 4 | ;;; Copyright 2010-2012 Vladimir Sedach 5 | ;;; Copyright 2010-2013 Daniel Gackle 6 | ;;; Copyright 2012, 2014 Boris Smilga 7 | 8 | ;;; SPDX-License-Identifier: BSD-3-Clause 9 | 10 | ;;; Redistribution and use in source and binary forms, with or 11 | ;;; without modification, are permitted provided that the following 12 | ;;; conditions are met: 13 | 14 | ;;; 1. Redistributions of source code must retain the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer. 16 | 17 | ;;; 2. Redistributions in binary form must reproduce the above 18 | ;;; copyright notice, this list of conditions and the following 19 | ;;; disclaimer in the documentation and/or other materials provided 20 | ;;; with the distribution. 21 | 22 | ;;; 3. Neither the name of the copyright holder nor the names of its 23 | ;;; contributors may be used to endorse or promote products derived 24 | ;;; from this software without specific prior written permission. 25 | 26 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 27 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 28 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 29 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 30 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 31 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 32 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 33 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 34 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 35 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 36 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 37 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 38 | ;;; POSSIBILITY OF SUCH DAMAGE. 39 | 40 | (in-package #:parenscript) 41 | (in-readtable :parenscript) 42 | 43 | (macrolet ((define-trivial-mappings (&rest mappings) 44 | `(progn 45 | ,@(loop for (macro-name ps-op) on mappings by #'cddr collect 46 | `(defpsmacro ,macro-name (&rest args) 47 | (cons ',ps-op args)))))) 48 | (define-trivial-mappings 49 | string= eql 50 | eq eql 51 | = eql 52 | list array 53 | elt aref)) 54 | 55 | (defpsmacro null (x) 56 | `(equal ,x nil)) 57 | 58 | ;;; Math 59 | 60 | (defmacro def-js-maths (&rest mathdefs) 61 | `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs))) 62 | 63 | (def-js-maths 64 | (max (&rest nums) `((@ *math max) ,@nums)) 65 | (min (&rest nums) `((@ *math min) ,@nums)) 66 | (floor (n &optional divisor) 67 | `((@ *math floor) ,(if divisor `(/ ,n ,divisor) n))) 68 | (ceiling (n &optional divisor) 69 | `((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n))) 70 | (round (n &optional divisor) 71 | `((@ *math round) ,(if divisor `(/ ,n ,divisor) n))) 72 | (sin (n) `((@ *math sin) ,n)) 73 | (cos (n) `((@ *math cos) ,n)) 74 | (tan (n) `((@ *math tan) ,n)) 75 | (asin (n) `((@ *math asin) ,n)) 76 | (acos (n) `((@ *math acos) ,n)) 77 | (atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y))) 78 | (sinh (x) 79 | (maybe-once-only (x) 80 | `(/ (- (exp ,x) (exp (- ,x))) 2))) 81 | (cosh (x) 82 | (maybe-once-only (x) 83 | `(/ (+ (exp ,x) (exp (- ,x))) 2))) 84 | (tanh (x) 85 | (maybe-once-only (x) 86 | `(/ (- (exp ,x) (exp (- ,x))) (+ (exp ,x) (exp (- ,x)))))) 87 | (asinh (x) 88 | (maybe-once-only (x) 89 | `(log (+ ,x (sqrt (1+ (* ,x ,x))))))) 90 | (acosh (x) 91 | (maybe-once-only (x) 92 | `(* 2 (log (+ (sqrt (/ (1+ ,x) 2)) (sqrt (/ (1- ,x) 2))))))) 93 | (atanh (x) ;; real only for -1 < x < 1, otherwise complex 94 | (maybe-once-only (x) 95 | `(/ (- (log (+ 1 ,x)) (log (- 1 ,x))) 2))) 96 | (mod (x n) 97 | (maybe-once-only (n) 98 | `(rem (+ (rem ,x ,n) ,n) ,n))) 99 | (1+ (n) `(+ ,n 1)) 100 | (1- (n) `(- ,n 1)) 101 | (abs (n) `((@ *math abs) ,n)) 102 | (evenp (n) `(not (oddp ,n))) 103 | (oddp (n) `(rem ,n 2)) 104 | (exp (n) `((@ *math exp) ,n)) 105 | (expt (base power) `((@ *math pow) ,base ,power)) 106 | (log (n &optional base) 107 | (or (and (null base) `((@ *math log) ,n)) 108 | (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*))) 109 | `(/ (log ,n) (log ,base)))) 110 | (sqrt (n) `((@ *math sqrt) ,n)) 111 | (random (&optional upto) (if upto 112 | (maybe-once-only (upto) 113 | `(if (rem ,upto 1) 114 | (* ,upto (random)) 115 | (floor (* ,upto (random))))) 116 | '(funcall (@ *math random))))) 117 | 118 | (defpsmacro ash (integer count) 119 | (let ((count (ps-macroexpand count))) 120 | (cond ((and (numberp count) (> count 0)) `(<< ,integer ,count)) 121 | ((numberp count) `(>> ,integer ,(- count))) 122 | ((complex-js-expr? count) 123 | (let ((count-var (ps-gensym))) 124 | `(let ((,count-var ,count)) 125 | (if (> ,count-var 0) 126 | (<< ,integer ,count-var) 127 | (>> ,integer (- ,count-var)))))) 128 | (t `(if (> ,count 0) 129 | (<< ,integer ,count) 130 | (>> ,integer (- ,count))))))) 131 | 132 | (define-ps-symbol-macro pi (getprop *math '*pi*)) 133 | 134 | ;;; Types 135 | 136 | (defpsmacro stringp (x) 137 | `(string= (typeof ,x) "string")) 138 | 139 | (defpsmacro numberp (x) 140 | `(string= (typeof ,x) "number")) 141 | 142 | (defpsmacro functionp (x) 143 | `(string= (typeof ,x) "function")) 144 | 145 | (defpsmacro booleanp (x) 146 | `(string= (typeof ,x) "boolean")) 147 | 148 | (defpsmacro listp (x) 149 | (if (js-target-at-least "1.8.5") 150 | `(funcall (getprop Array 'is-array) ,x) 151 | `(string= (funcall (getprop Object 'prototype 'to-string 'call) ,x) 152 | "[object Array]"))) 153 | 154 | (defpsmacro arrayp (x) 155 | `(listp ,x)) 156 | 157 | ;;; Data structures 158 | 159 | (defpsmacro make-array (&rest args) 160 | (or (ignore-errors 161 | (destructuring-bind (dim &key (initial-element nil initial-element-p) 162 | initial-contents element-type) 163 | args 164 | (declare (ignore element-type)) 165 | (and (or initial-element-p initial-contents) 166 | (not (and initial-element-p initial-contents)) 167 | (with-ps-gensyms (arr init elt i) 168 | `(let ((,arr (new (*array ,dim)))) 169 | ,@(when initial-element-p 170 | `((let ((,elt ,initial-element)) 171 | (dotimes (,i (length ,arr)) 172 | (setf (aref ,arr ,i) ,elt))))) 173 | ,@(when initial-contents 174 | `((let ((,init ,initial-contents)) 175 | (dotimes (,i (min (length ,arr) (length ,init))) 176 | (setf (aref ,arr ,i) (aref ,init ,i)))))) 177 | ,arr))))) 178 | `(new (*array ,@args)))) 179 | 180 | (defpsmacro length (a) 181 | `(getprop ,a 'length)) 182 | 183 | ;;; Getters 184 | 185 | (defpsmacro with-slots (slots object &rest body) 186 | (flet ((slot-var (slot) 187 | (if (listp slot) 188 | (first slot) 189 | slot)) 190 | (slot-symbol (slot) 191 | (if (listp slot) 192 | (second slot) 193 | slot))) 194 | (maybe-once-only (object) 195 | `(symbol-macrolet ,(mapcar (lambda (slot) 196 | `(,(slot-var slot) (getprop ,object ',(slot-symbol slot)))) 197 | slots) 198 | ,@body)))) 199 | 200 | ;;; multiple values 201 | 202 | (defpsmacro multiple-value-bind (vars form &body body) 203 | (let* ((form (ps-macroexpand form)) 204 | (progn-form (when (and (consp form) 205 | (member (car form) 206 | '(with label let flet labels 207 | macrolet symbol-macrolet progn))) 208 | (pop form)))) 209 | (if progn-form 210 | `(,progn-form 211 | ,@(butlast form) 212 | (multiple-value-bind ,vars 213 | ,@(last form) 214 | ,@body)) 215 | ;; assume function call 216 | `(progn 217 | (setf __PS_MV_REG '()) 218 | (let ((,(car vars) ,form)) 219 | (destructuring-bind (&optional ,@(cdr vars)) 220 | __PS_MV_REG 221 | ,@body)))))) 222 | 223 | (defpsmacro multiple-value-list (form) 224 | (with-ps-gensyms (first-value values-list) 225 | `(let* ((,first-value (progn 226 | (setf __PS_MV_REG '()) 227 | ,form)) 228 | (,values-list (funcall (getprop __PS_MV_REG 'slice)))) 229 | (funcall (getprop ,values-list 'unshift) ,first-value) 230 | ,values-list))) 231 | 232 | ;;; conditionals 233 | 234 | (defpsmacro case (value &rest clauses) 235 | (labels 236 | ((make-switch-clause (val body more) 237 | (if (consp val) 238 | (append (mapcar #'list (butlast val)) 239 | (make-switch-clause 240 | (if (eq t (car (last val))) ;; literal 'true' 241 | '%true 242 | (car (last val))) 243 | body 244 | more)) 245 | `((,(cond ((member val '(t otherwise)) 'default) 246 | ((eql val '%true) t) 247 | ((eql val 'false) 'false) 248 | ((null val) 'false) 249 | ((symbolp val) (list 'quote val)) 250 | (t val)) 251 | ,@body 252 | ,@(when more '(break))))))) 253 | `(switch ,value 254 | ,@(mapcon (lambda (clause) 255 | (make-switch-clause (car (first clause)) 256 | (cdr (first clause)) 257 | (rest clause))) 258 | clauses)))) 259 | 260 | (defpsmacro when (test &rest body) 261 | `(if ,test (progn ,@body))) 262 | 263 | (defpsmacro unless (test &rest body) 264 | `(when (not ,test) ,@body)) 265 | 266 | ;;; function definition 267 | 268 | (defpsmacro defun (name lambda-list &body body) 269 | "An extended defun macro that allows cool things like keyword arguments. 270 | lambda-list::= 271 | (var* 272 | [&optional {var | (var [init-form [supplied-p-parameter]])}*] 273 | [&rest var] 274 | [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]] 275 | [&aux {var | (var [init-form])}*])" 276 | (if (symbolp name) 277 | (progn (setf (gethash name *function-lambda-list*) lambda-list) 278 | `(defun% ,name ,lambda-list ,@body)) 279 | (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) () 280 | "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list) 281 | `(defun-setf ,(second name) ,lambda-list ,@body)))) 282 | 283 | ;;; defining setf expanders 284 | 285 | (defvar *defun-setf-name-prefix* '__setf_) 286 | 287 | (defpsmacro defun-setf (name lambda-list &body body) 288 | (let ((mangled-function-name 289 | (intern (format nil "~A~A" (string *defun-setf-name-prefix*) (string name)) 290 | (symbol-package name)))) 291 | (setf (gethash name *setf-expanders*) 292 | (lambda (access-args store-form) 293 | `(,mangled-function-name ,store-form ,@access-args))) 294 | `(defun ,mangled-function-name ,lambda-list ,@body))) 295 | 296 | ;;; slightly broken WRT lambda lists 297 | (defpsmacro defsetf-long (access-fn lambda-list (store-var) form) 298 | (setf (gethash access-fn *setf-expanders*) 299 | (compile 300 | nil 301 | (let ((var-bindings (ordered-set-difference lambda-list 302 | lambda-list-keywords))) 303 | `(lambda (access-fn-args store-form) 304 | (destructuring-bind ,lambda-list 305 | access-fn-args 306 | (let* ((,store-var (ps-gensym)) 307 | (gensymed-names (loop repeat ,(length var-bindings) 308 | collecting (ps-gensym))) 309 | (gensymed-arg-bindings (mapcar #'list 310 | gensymed-names 311 | (list ,@var-bindings)))) 312 | (destructuring-bind ,var-bindings 313 | gensymed-names 314 | `(let* (,@gensymed-arg-bindings 315 | (,,store-var ,store-form)) 316 | ,,form)))))))) 317 | nil) 318 | 319 | (defpsmacro defsetf-short (access-fn update-fn &optional docstring) 320 | (declare (ignore docstring)) 321 | (setf (gethash access-fn *setf-expanders*) 322 | (lambda (access-fn-args store-form) 323 | `(,update-fn ,@access-fn-args ,store-form))) 324 | nil) 325 | 326 | (defpsmacro defsetf (access-fn &rest args) 327 | `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args)) 328 | 329 | ;;; setf 330 | 331 | (defpsmacro setf (&rest args) 332 | (assert (evenp (length args)) () 333 | "~s does not have an even number of arguments." `(setf ,args)) 334 | `(progn ,@(loop for (place value) on args by #'cddr collect 335 | (aif (and (listp place) (gethash (car place) *setf-expanders*)) 336 | (funcall it (cdr place) value) 337 | `(ps-assign ,place ,value))))) 338 | 339 | (defpsmacro psetf (&rest args) 340 | (let ((places (loop for x in args by #'cddr collect x)) 341 | (vals (loop for x in (cdr args) by #'cddr collect x))) 342 | (let ((gensyms (loop repeat (length places) collect (ps-gensym)))) 343 | `(let ,(mapcar #'list gensyms vals) 344 | (setf ,@(mapcan #'list places gensyms)))))) 345 | 346 | (defun check-setq-args (args) 347 | (let ((vars (loop for x in args by #'cddr collect x))) 348 | (let ((non-var (find-if (complement #'symbolp) vars))) 349 | (when non-var 350 | (error 'type-error :datum non-var :expected-type 'symbol))))) 351 | 352 | (defpsmacro setq (&rest args) 353 | (check-setq-args args) 354 | `(setf ,@args)) 355 | 356 | (defpsmacro psetq (&rest args) 357 | (check-setq-args args) 358 | `(psetf ,@args)) 359 | 360 | ;;; iteration 361 | 362 | (defun do-make-iteration-bindings (decls) 363 | (mapcar (lambda (x) 364 | (cond ((atom x) x) 365 | ((endp (cdr x)) (list (car x))) 366 | (t (subseq x 0 2)))) 367 | decls)) 368 | 369 | (defun do-make-for-steps (decls) 370 | (mapcar (lambda (x) 371 | `(setf ,(first x) ,(third x))) 372 | (remove-if (lambda (x) 373 | (or (atom x) (< (length x) 3))) 374 | decls))) 375 | 376 | (defun do-make-iter-psteps (decls) 377 | `(psetq 378 | ,@(mapcan (lambda (x) 379 | (list (first x) (third x))) 380 | (remove-if (lambda (x) 381 | (or (atom x) (< (length x) 3))) 382 | decls)))) 383 | 384 | (defpsmacro do* (decls (end-test &optional (result nil result?)) &body body) 385 | `(block nil 386 | (for ,(do-make-iteration-bindings decls) 387 | ((not ,end-test)) 388 | ,(do-make-for-steps decls) 389 | (locally ,@body)) 390 | ,@(when result? (list result)))) 391 | 392 | (defpsmacro do (decls (end-test &optional (result nil result?)) &body body) 393 | (multiple-value-bind (do-body declarations) 394 | (parse-body body) 395 | `(block nil 396 | (let ,(do-make-iteration-bindings decls) 397 | ,@declarations 398 | (for () ((not ,end-test)) () 399 | ,@do-body 400 | ,(do-make-iter-psteps decls)) 401 | ,@(when result? (list result)))))) 402 | 403 | (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body) 404 | `(do* ((,var 0 (1+ ,var))) 405 | ((>= ,var ,count) 406 | ,@(when result? `((let ((,var nil)) ,result)))) 407 | ,@body)) 408 | 409 | (defpsmacro dolist ((var array &optional (result nil result?)) &body body) 410 | (let* ((idx (ps-gensym '_js_idx)) 411 | (introduce-array-var? (not (symbolp array))) 412 | (arrvar (if introduce-array-var? 413 | (ps-gensym '_js_arrvar) 414 | array))) 415 | `(do* (,var 416 | ,@(when introduce-array-var? 417 | (list (list arrvar array))) 418 | (,idx 0 (1+ ,idx))) 419 | ((>= ,idx (getprop ,arrvar 'length)) 420 | ,@(when result? `((let ((,var nil)) ,result)))) 421 | (setq ,var (aref ,arrvar ,idx)) 422 | ,@body))) 423 | 424 | ;;; Concatenation 425 | 426 | (defpsmacro concatenate (result-type &rest sequences) 427 | (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.") 428 | (cons '+ sequences)) 429 | 430 | (defpsmacro append (arr1 &rest arrs) 431 | (if arrs 432 | `((@ ,arr1 concat) ,@arrs) 433 | arr1)) 434 | 435 | ;;; Destructuring bind 436 | 437 | (defun complex-js-expr? (expr) 438 | (consp (if (symbolp expr) (ps-macroexpand expr) expr))) 439 | 440 | (defun hoist-expr? (bindings expr) 441 | (and (> (length bindings) 1) (complex-js-expr? expr))) 442 | 443 | (defun pop-declarations-for-var (var declarations) 444 | (loop for declarations* on declarations 445 | with var-declarations = nil 446 | do (setf (first declarations*) 447 | (loop for spec in (first declarations*) 448 | ;; We only care for SPECIAL declarations for now 449 | ;; (cf. WITH-DECLARATION-EFFECTS) 450 | if (and (consp spec) (eq 'special (first spec))) 451 | collect 452 | (let ((vars* (remove var (rest spec)))) 453 | (if (eq vars* (cdr spec)) 454 | spec 455 | (progn 456 | (pushnew var (getf var-declarations 'special)) 457 | (cons 'special vars*)))) 458 | else 459 | collect spec)) 460 | finally (return 461 | (loop for (sym decls) on var-declarations by #'cddr 462 | collect (cons sym decls))))) 463 | 464 | (defun destructuring-wrap (arr n bindings declarations body) 465 | (cond ((null bindings) body) 466 | ((eq (car bindings) '&rest) 467 | (cond ((and (= (length bindings) 2) (atom (second bindings))) 468 | `(let ((,(second bindings) (if (> (length ,arr) ,n) ((@ ,arr slice) ,n) '()))) 469 | (declare ,@(pop-declarations-for-var (second bindings) declarations)) 470 | ,body)) 471 | (t (error "~a is invalid in destructuring list." bindings)))) 472 | ((eq (car bindings) '&optional) 473 | (destructuring-wrap arr n (cdr bindings) declarations body)) 474 | (t (let ((var (car bindings)) 475 | (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) declarations body))) 476 | (cond ((null var) inner-body) 477 | ((atom var) `(let ((,var (aref ,arr ,n))) 478 | (declare ,@(pop-declarations-for-var var declarations)) 479 | ,inner-body)) 480 | (t `(,'destructuring-bind ,var (aref ,arr ,n) 481 | ,@declarations 482 | ,inner-body))))))) 483 | 484 | (defpsmacro destructuring-bind (bindings expr &body body) 485 | (setf bindings (dot->rest bindings)) 486 | (multiple-value-bind (body1 declarations) (parse-body body) 487 | (let* ((arr (if (hoist-expr? bindings expr) (ps-gensym '_db) expr)) 488 | (bound (destructuring-wrap arr 0 bindings declarations 489 | (cons 'progn body1)))) 490 | (cond ((eq arr expr) bound) 491 | (t `(let ((,arr ,expr)) ,bound)))))) 492 | 493 | ;;; Control structures 494 | 495 | (defpsmacro return (&optional result) 496 | `(return-from nil ,result)) 497 | 498 | (defpsmacro ignore-errors (&body forms) 499 | (with-ps-gensyms (e) 500 | `(try (progn ,@forms) 501 | (:catch (,e) nil)))) 502 | 503 | (defpsmacro unwind-protect (protected-form cleanup-form) 504 | `(try ,protected-form 505 | (:finally ,cleanup-form))) 506 | 507 | (defpsmacro prog1 (first &rest others) 508 | (with-ps-gensyms (val) 509 | `(let ((,val (multiple-value-list ,first))) 510 | ,@others 511 | (values-list ,val)))) 512 | 513 | (defpsmacro prog2 (first second &rest others) 514 | `(progn ,first (prog1 ,second ,@others))) 515 | 516 | (defpsmacro apply (fn &rest args) 517 | (let ((arglist (if (> (length args) 1) 518 | `(append (list ,@(butlast args)) ,(car (last args))) 519 | (first args)))) 520 | (if (and (listp fn) 521 | (find (car fn) #(getprop chain @))) 522 | (if (and (= (length fn) 3) (symbolp (second fn))) 523 | `(funcall (getprop ,fn 'apply) ,(second fn) ,arglist) 524 | (let ((obj (ps-gensym)) (method (ps-gensym))) 525 | `(let* ((,obj ,(butlast fn)) 526 | (,method (,(car fn) ,obj ,(car (last fn))))) 527 | (funcall (getprop ,method 'apply) ,obj ,arglist)))) 528 | `(funcall (getprop ,fn 'apply) this ,arglist)))) 529 | 530 | ;;; misc 531 | 532 | (defpsmacro let* (bindings &body body) 533 | (multiple-value-bind (let-body declarations) (parse-body body) 534 | (loop for binding in (cons nil (reverse bindings)) 535 | for var = (if (symbolp binding) binding (car binding)) 536 | for body = let-body 537 | then `((let (,binding) 538 | (declare ,@(pop-declarations-for-var var declarations)) 539 | ,@body)) 540 | finally (return `(progn ,@body))))) 541 | 542 | (defpsmacro in-package (package-designator) 543 | `(eval-when (:compile-toplevel) 544 | (in-package ,package-designator))) 545 | 546 | (defpsmacro use-package (package-designator &optional package) 547 | `(eval-when (:compile-toplevel) 548 | (use-package ,package-designator ,@(when package (list package))))) 549 | -------------------------------------------------------------------------------- /src/namespace.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2007-2010 Vladimir Sedach 2 | ;;; Copyright 2008 Travis Cross 3 | 4 | ;;; SPDX-License-Identifier: BSD-3-Clause 5 | 6 | ;;; Redistribution and use in source and binary forms, with or 7 | ;;; without modification, are permitted provided that the following 8 | ;;; conditions are met: 9 | 10 | ;;; 1. Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; 2. Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials provided 16 | ;;; with the distribution. 17 | 18 | ;;; 3. Neither the name of the copyright holder nor the names of its 19 | ;;; contributors may be used to endorse or promote products derived 20 | ;;; from this software without specific prior written permission. 21 | 22 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 23 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 24 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 25 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 27 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 28 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 29 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 30 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 31 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 32 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 33 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | ;;; POSSIBILITY OF SUCH DAMAGE. 35 | 36 | (in-package #:parenscript) 37 | (in-readtable :parenscript) 38 | 39 | (defvar *obfuscated-packages* (make-hash-table)) 40 | 41 | (defun obfuscate-package (package-designator &optional symbol-map) 42 | (setf (gethash (find-package package-designator) 43 | *obfuscated-packages*) 44 | (or symbol-map 45 | (let ((symbol-table (make-hash-table))) 46 | (lambda (symbol) 47 | (or (gethash symbol symbol-table) 48 | (setf (gethash symbol symbol-table) 49 | (ps-gensym 'g)))))))) 50 | 51 | (defun unobfuscate-package (package-designator) 52 | (remhash (find-package package-designator) *obfuscated-packages*)) 53 | 54 | (defun maybe-obfuscate-symbol (symbol) 55 | (if (aand (symbol-package symbol) (eq :external (nth-value 1 (find-symbol (symbol-name symbol) it)))) 56 | symbol 57 | (aif (gethash (symbol-package symbol) *obfuscated-packages*) 58 | (funcall it symbol) 59 | symbol))) 60 | 61 | (defvar *package-prefix-table* (make-hash-table)) 62 | 63 | (defmacro ps-package-prefix (package) 64 | `(gethash (find-package ,package) *package-prefix-table*)) 65 | 66 | (defun symbol-to-js-string (symbol &optional (mangle-symbol-name? t)) 67 | (let* ((symbol-name (symbol-name (maybe-obfuscate-symbol symbol))) 68 | (identifier (if mangle-symbol-name? 69 | (encode-js-identifier symbol-name) 70 | symbol-name))) 71 | (aif (ps-package-prefix (symbol-package symbol)) 72 | (concatenate 'string it identifier) 73 | identifier))) 74 | -------------------------------------------------------------------------------- /src/non-cl.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-2006 Edward Marco Baringer 3 | ;;; Copyright 2006 Luca Capello 4 | ;;; Copyright 2010-2012 Vladimir Sedach 5 | ;;; Copyright 2012, 2014, 2015 Boris Smilga 6 | 7 | ;;; SPDX-License-Identifier: BSD-3-Clause 8 | 9 | ;;; Redistribution and use in source and binary forms, with or 10 | ;;; without modification, are permitted provided that the following 11 | ;;; conditions are met: 12 | 13 | ;;; 1. Redistributions of source code must retain the above copyright 14 | ;;; notice, this list of conditions and the following disclaimer. 15 | 16 | ;;; 2. Redistributions in binary form must reproduce the above 17 | ;;; copyright notice, this list of conditions and the following 18 | ;;; disclaimer in the documentation and/or other materials provided 19 | ;;; with the distribution. 20 | 21 | ;;; 3. Neither the name of the copyright holder nor the names of its 22 | ;;; contributors may be used to endorse or promote products derived 23 | ;;; from this software without specific prior written permission. 24 | 25 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 26 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 27 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 28 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 29 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 30 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 31 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 32 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 33 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 34 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 35 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 36 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 37 | ;;; POSSIBILITY OF SUCH DAMAGE. 38 | 39 | (in-package #:parenscript) 40 | (in-readtable :parenscript) 41 | 42 | ;;; PS operators and macros that aren't present in the Common Lisp 43 | ;;; standard but exported by Parenscript, and their Common Lisp 44 | ;;; equivalent definitions 45 | 46 | (defmacro define-trivial-special-ops (&rest mappings) 47 | `(progn ,@(loop for (form-name js-primitive) on mappings by #'cddr collect 48 | `(define-expression-operator ,form-name (&rest args) 49 | (cons ',js-primitive (mapcar #'compile-expression args)))))) 50 | 51 | (define-trivial-special-ops 52 | array ps-js:array 53 | instanceof ps-js:instanceof 54 | typeof ps-js:typeof 55 | new ps-js:new 56 | delete ps-js:delete 57 | in ps-js:in ;; maybe rename to slot-boundp? 58 | break ps-js:break 59 | << ps-js:<< 60 | >> ps-js:>> 61 | ) 62 | 63 | (define-statement-operator continue (&optional label) 64 | `(ps-js:continue ,label)) 65 | 66 | (define-statement-operator switch (test-expr &rest clauses) 67 | `(ps-js:switch ,(compile-expression test-expr) 68 | ,@(let ((in-case? t)) 69 | (loop for (val . body) in clauses collect 70 | (cons (if (eq val 'default) 71 | 'ps-js:default 72 | (compile-expression val)) 73 | (flatten-blocks 74 | (mapcar #'compile-statement body))))))) 75 | 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | ;;; objects 78 | 79 | (define-expression-operator create (&rest arrows) 80 | (let ((allow-accessors (js-target-at-least "1.8.5"))) 81 | (cons 82 | 'ps-js:object 83 | (loop for (key val-expr) on arrows by #'cddr 84 | for (accessor . accessor-args) = 85 | (when (and allow-accessors 86 | (consp key) 87 | (symbolp (first key)) 88 | (symbolp (second key))) 89 | (case (first key) 90 | (get (and (null (third key)) 91 | `((ps-js:get ,(second key))))) 92 | (set (and (symbolp (third key)) (null (fourth key)) 93 | `((ps-js:set ,(second key)) ,(third key)))))) 94 | collecting 95 | (if accessor 96 | (list accessor accessor-args 97 | (let ((*function-block-names* ())) 98 | (compile-function-body (third accessor) 99 | (list val-expr)))) 100 | (cons (cond ((and (symbolp key) (reserved-symbol-p key)) 101 | (reserved-symbol-p key)) 102 | ((or (stringp key) (numberp key) (symbolp key)) 103 | key) 104 | ((and (consp key) 105 | (eq 'quote (first key)) 106 | (symbolp (second key)) 107 | (null (third key))) 108 | (symbol-to-js-string (second key))) 109 | (t 110 | (error "Slot key ~s is not one of ~ 111 | ~{~a~#[~;, or ~:;, ~]~}." 112 | key 113 | (list* "symbol" "string" "number" 114 | (when allow-accessors 115 | '("accessor spec")))))) 116 | (compile-expression val-expr))))))) 117 | 118 | (define-expression-operator %js-getprop (obj slot) 119 | (let ((expanded-slot (ps-macroexpand slot)) 120 | (obj (compile-expression obj))) 121 | (if (and (listp expanded-slot) 122 | (eq 'quote (car expanded-slot))) 123 | (aif (or (reserved-symbol-p (second expanded-slot)) 124 | (and (keywordp (second expanded-slot)) (second expanded-slot))) 125 | `(ps-js:aref ,obj ,it) 126 | `(ps-js:getprop ,obj ,(second expanded-slot))) 127 | `(ps-js:aref ,obj ,(compile-expression slot))))) 128 | 129 | (defpsmacro getprop (obj &rest slots) 130 | (if (null (rest slots)) 131 | `(%js-getprop ,obj ,(first slots)) 132 | `(getprop (getprop ,obj ,(first slots)) ,@(rest slots)))) 133 | 134 | (defpsmacro @ (obj &rest props) 135 | "Handy getprop/aref composition macro." 136 | (if props 137 | `(@ (getprop ,obj ,(if (symbolp (car props)) 138 | `',(car props) 139 | (car props))) 140 | ,@(cdr props)) 141 | obj)) 142 | 143 | (defun chain (method-calls) 144 | (let ((chain (car method-calls))) 145 | (dolist (next (cdr method-calls)) 146 | (setf chain (if (consp next) 147 | `(funcall (@ ,chain ,(car next)) ,@(cdr next)) 148 | `(@ ,chain ,next)))) 149 | chain)) 150 | 151 | (defpsmacro chain (&rest method-calls) 152 | (chain method-calls)) 153 | 154 | ;;; var 155 | 156 | (define-expression-operator var (name &optional (value (values) value?) docstr) 157 | (declare (ignore docstr)) 158 | (push name *vars-needing-to-be-declared*) 159 | (when value? (compile-expression `(setf ,name ,value)))) 160 | 161 | (define-statement-operator var (name &optional (value (values) value?) docstr) 162 | (let ((value (ps-macroexpand value))) 163 | (if (and (listp value) (eq 'progn (car value))) 164 | (ps-compile `(progn ,@(butlast (cdr value)) 165 | (var ,name ,(car (last value))))) 166 | `(ps-js:var ,(ps-macroexpand name) 167 | ,@(when value? (list (compile-expression value) docstr)))))) 168 | 169 | (defmacro var (name &optional value docstr) 170 | `(defparameter ,name ,value ,@(when docstr (list docstr)))) 171 | 172 | ;;; iteration 173 | 174 | (define-statement-operator for (init-forms cond-forms step-forms &body body) 175 | (let ((init-forms (make-for-vars/inits init-forms))) 176 | `(ps-js:for ,init-forms 177 | ,(mapcar #'compile-expression cond-forms) 178 | ,(mapcar #'compile-expression step-forms) 179 | ,(compile-loop-body (mapcar #'car init-forms) body)))) 180 | 181 | (define-statement-operator for-in ((var object) &rest body) 182 | `(ps-js:for-in ,(compile-expression var) 183 | ,(compile-expression object) 184 | ,(compile-loop-body (list var) body))) 185 | 186 | ;;; misc 187 | 188 | (define-statement-operator try (form &rest clauses) 189 | (let ((catch (cdr (assoc :catch clauses))) 190 | (finally (cdr (assoc :finally clauses)))) 191 | (assert (not (cdar catch)) () 192 | "Sorry, currently only simple catch forms are supported.") 193 | (assert (or catch finally) () 194 | "Try form should have either a catch or a finally clause or both.") 195 | `(ps-js:try 196 | ,(compile-statement `(progn ,form)) 197 | :catch ,(when catch 198 | (list (caar catch) 199 | (compile-statement `(progn ,@(cdr catch))))) 200 | :finally ,(when finally 201 | (compile-statement `(progn ,@finally)))))) 202 | 203 | (define-expression-operator regex (regex) 204 | `(ps-js:regex ,(string regex))) 205 | 206 | (define-expression-operator lisp (lisp-form) 207 | ;; (ps (foo (lisp bar))) is like (ps* `(foo ,bar)) 208 | ;; When called from inside of ps*, lisp-form has access to the 209 | ;; dynamic environment only, analogous to eval. 210 | `(ps-js:escape 211 | (with-output-to-string (*psw-stream*) 212 | (let ((compile-expression? ,compile-expression?) 213 | (*js-string-delimiter* ,*js-string-delimiter*) 214 | (eval-results (multiple-value-list ,lisp-form))) 215 | (when eval-results 216 | (parenscript-print (ps-compile (car eval-results)) t)))))) 217 | 218 | (defun lisp (x) x) 219 | 220 | (defpsmacro undefined (x) 221 | `(eql "undefined" (typeof ,x))) 222 | 223 | (defpsmacro defined (x) 224 | `(not (undefined ,x))) 225 | 226 | (defpsmacro objectp (x) 227 | `(string= (typeof ,x) "object")) 228 | 229 | (define-ps-symbol-macro {} (create)) 230 | 231 | (defpsmacro [] (&rest args) 232 | `(array ,@(mapcar (lambda (arg) 233 | (if (and (consp arg) (not (equal '[] (car arg)))) 234 | (cons '[] arg) 235 | arg)) 236 | args))) 237 | 238 | (defpsmacro stringify (&rest things) 239 | (if (and (= (length things) 1) (stringp (car things))) 240 | (car things) 241 | `(funcall (getprop (list ,@things) 'join) ""))) 242 | (defun stringify (&rest things) 243 | "Like concatenate but prints all of its arguments." 244 | (format nil "~{~A~}" things)) 245 | 246 | (define-ps-symbol-macro false ps-js:false) 247 | (defvar false nil) 248 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-2006 Edward Marco Baringer 3 | ;;; Copyright 2006 Luca Capello 4 | ;;; Copyright 2006 Atilla Lendvai 5 | ;;; Copyright 2007-2012 Vladimir Sedach 6 | ;;; Copyright 2007 Red Daly 7 | ;;; Copyright 2008 Travis Cross 8 | 9 | ;;; SPDX-License-Identifier: BSD-3-Clause 10 | 11 | ;;; Redistribution and use in source and binary forms, with or 12 | ;;; without modification, are permitted provided that the following 13 | ;;; conditions are met: 14 | 15 | ;;; 1. Redistributions of source code must retain the above copyright 16 | ;;; notice, this list of conditions and the following disclaimer. 17 | 18 | ;;; 2. Redistributions in binary form must reproduce the above 19 | ;;; copyright notice, this list of conditions and the following 20 | ;;; disclaimer in the documentation and/or other materials provided 21 | ;;; with the distribution. 22 | 23 | ;;; 3. Neither the name of the copyright holder nor the names of its 24 | ;;; contributors may be used to endorse or promote products derived 25 | ;;; from this software without specific prior written permission. 26 | 27 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 28 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 29 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 30 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 31 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 32 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 33 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 34 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 35 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 36 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 37 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 38 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 39 | ;;; POSSIBILITY OF SUCH DAMAGE. 40 | 41 | (in-package #:cl) 42 | 43 | (pushnew :parenscript *features*) 44 | 45 | (eval-when (:compile-toplevel :load-toplevel :execute) 46 | (unless (named-readtables:find-readtable :parenscript) 47 | (named-readtables:defreadtable :parenscript 48 | (:merge :standard) 49 | (:case #.(if (eql :upcase (readtable-case *readtable*)) 50 | :invert 51 | (readtable-case *readtable*)))))) 52 | 53 | (named-readtables:in-readtable :parenscript) 54 | 55 | (defpackage #:parenscript 56 | (:use #:cl #:anaphora #:named-readtables) 57 | (:nicknames #:ps) 58 | (:export 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | ;;; Compiler interface 61 | 62 | ;; compiler 63 | #:*js-target-version* 64 | #:ps 65 | #:*parenscript-stream* 66 | #:ps-to-stream 67 | #:ps-doc 68 | #:ps-doc* 69 | #:ps* 70 | #:ps-inline 71 | #:ps-inline* 72 | #:*ps-read-function* 73 | #:ps-compile-file 74 | #:ps-compile-stream 75 | ;; for parenscript macro definition within lisp 76 | #:defpsmacro 77 | #:defmacro+ps 78 | #:import-macros-from-lisp 79 | #:*defined-operators* 80 | #:*version* 81 | 82 | ;; gensym 83 | #:ps-gensym 84 | #:with-ps-gensyms 85 | #:ps-once-only 86 | #:maybe-once-only 87 | #:*ps-gensym-counter* 88 | 89 | ;; naming and namespaces 90 | #:in-package 91 | #:use-package 92 | #:ps-package-prefix 93 | #:obfuscate-package 94 | #:unobfuscate-package 95 | 96 | ;; printer 97 | #:symbol-to-js-string 98 | #:*js-string-delimiter* 99 | #:*js-inline-string-delimiter* 100 | #:*ps-print-pretty* 101 | #:*indent-num-spaces* 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;;; Language 105 | 106 | ;; literals 107 | #:t 108 | #:nil 109 | 110 | ;; array literals 111 | #:array 112 | #:list 113 | #:aref 114 | #:elt 115 | #:make-array 116 | #:[] 117 | 118 | ;; operators 119 | ;; logical boolean 120 | #:not 121 | #:and 122 | #:or 123 | 124 | ;; bitwise boolean 125 | #:logand 126 | #:logior 127 | #:logxor 128 | #:lognot 129 | #:ash 130 | 131 | #:* 132 | #:/ 133 | #:rem 134 | #:mod 135 | #:+ 136 | #:- 137 | #:< 138 | #:> 139 | #:<= 140 | #:>= 141 | #:incf 142 | #:decf 143 | #:equal 144 | #:eql 145 | #:eq 146 | #:= 147 | 148 | ;; compile-time stuff 149 | #:eval-when 150 | 151 | ;; body forms 152 | #:progn 153 | 154 | ;; if 155 | #:if 156 | #:when 157 | #:unless 158 | 159 | ;; control flow 160 | #:return 161 | #:return-from 162 | #:throw 163 | 164 | ;; assignment and binding 165 | #:setf 166 | #:defsetf 167 | #:psetf 168 | #:setq 169 | #:psetq 170 | #:let* 171 | #:let 172 | 173 | ;; variables 174 | #:defvar 175 | 176 | ;; iteration 177 | #:do 178 | #:do* 179 | #:dotimes 180 | #:dolist 181 | #:loop 182 | 183 | ;; case 184 | #:switch 185 | #:case 186 | #:default 187 | 188 | ;; function definition 189 | #:defun 190 | #:lambda 191 | #:flet 192 | #:labels 193 | 194 | ;; lambda lists 195 | #:&key 196 | #:&rest 197 | #:&body 198 | #:&optional 199 | #:&aux 200 | #:&environment 201 | #:&key-object 202 | 203 | ;; macros 204 | #:macrolet 205 | #:symbol-macrolet 206 | #:define-symbol-macro 207 | #:define-ps-symbol-macro 208 | #:defmacro 209 | 210 | ;; utils 211 | #:max 212 | #:min 213 | #:floor 214 | #:ceiling 215 | #:round 216 | #:sin 217 | #:cos 218 | #:tan 219 | #:asin 220 | #:acos 221 | #:atan 222 | #:pi 223 | #:sinh 224 | #:cosh 225 | #:tanh 226 | #:asinh 227 | #:acosh 228 | #:atanh 229 | #:1+ 230 | #:1- 231 | #:abs 232 | #:evenp 233 | #:oddp 234 | #:exp 235 | #:expt 236 | #:log 237 | #:sqrt 238 | #:random 239 | #:ignore-errors 240 | #:concatenate 241 | #:length 242 | #:stringp 243 | #:numberp 244 | #:functionp 245 | #:append 246 | #:apply 247 | #:destructuring-bind 248 | 249 | ;; js runtime utils 250 | #:*ps-lisp-library* 251 | #:mapcar 252 | #:map-into 253 | #:map 254 | #:member 255 | #:append 256 | #:set-difference 257 | 258 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 259 | ;;; Non-Common Lisp functionality 260 | 261 | ;; DOM accessing utils 262 | #:inner-html 263 | #:uri-encode 264 | #:attribute 265 | #:offset 266 | #:scroll 267 | #:inner 268 | #:client 269 | 270 | ;; utils 271 | #:@ 272 | #:chain 273 | #:defined 274 | #:undefined 275 | #:booleanp 276 | #:objectp 277 | #:stringify 278 | 279 | ;; html generator for javascript 280 | #:*ps-html-empty-tag-aware-p* 281 | #:*ps-html-mode* 282 | #:ps-html 283 | #:who-ps-html 284 | 285 | ;; lisp eval 286 | #:lisp 287 | 288 | ;; js object stuff 289 | #:delete 290 | #:typeof 291 | #:instanceof 292 | #:new 293 | #:create 294 | 295 | ;; slot access 296 | #:with-slots 297 | #:getprop 298 | #:in 299 | 300 | ;; literals 301 | #:regex 302 | #:this 303 | #:undefined 304 | #:{} 305 | #:false 306 | 307 | ;; iteration 308 | #:for 309 | #:for-in 310 | #:while 311 | 312 | ;; global var 313 | #:var 314 | 315 | ;; control flow 316 | #:try 317 | #:break 318 | #:continue 319 | 320 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 321 | ;;; Deprecated functionality 322 | 323 | #:define-script-symbol-macro 324 | #:gen-js-name 325 | #:with-unique-js-names 326 | #:defjsmacro 327 | #:js-compile 328 | #:js-inline 329 | #:js-inline* 330 | #:js 331 | #:js* 332 | #:symbol-to-js 333 | #:slot-value 334 | #:compile-script 335 | #:defmacro/ps 336 | #:% 337 | #:== 338 | #:=== 339 | #:!= 340 | #:!== 341 | #:labeled-for 342 | #:do-set-timeout 343 | #:concat-string 344 | #:with 345 | #:label 346 | #:f 347 | #:bind 348 | #:bind* 349 | )) 350 | -------------------------------------------------------------------------------- /src/parse-lambda-list.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2007 Red Daly 2 | 3 | ;;; SPDX-License-Identifier: BSD-3-Clause 4 | 5 | ;;; Redistribution and use in source and binary forms, with or 6 | ;;; without modification, are permitted provided that the following 7 | ;;; conditions are met: 8 | 9 | ;;; 1. Redistributions of source code must retain the above copyright 10 | ;;; notice, this list of conditions and the following disclaimer. 11 | 12 | ;;; 2. Redistributions in binary form must reproduce the above 13 | ;;; copyright notice, this list of conditions and the following 14 | ;;; disclaimer in the documentation and/or other materials provided 15 | ;;; with the distribution. 16 | 17 | ;;; 3. Neither the name of the copyright holder nor the names of its 18 | ;;; contributors may be used to endorse or promote products derived 19 | ;;; from this software without specific prior written permission. 20 | 21 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 22 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 23 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 24 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 26 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 27 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 28 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 30 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 31 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 32 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 | ;;; POSSIBILITY OF SUCH DAMAGE. 34 | 35 | (in-package #:parenscript) 36 | 37 | ;;;; This software was taken from the SBCL system, mostly verbatim. 38 | 39 | ;;; if you have found this on google, THIS IS NOT AN SBCL SOURCE FILE 40 | 41 | ;;; Break something like a lambda list (but not necessarily actually a 42 | ;;; lambda list, e.g. the representation of argument types which is 43 | ;;; used within an FTYPE specification) into its component parts. We 44 | ;;; return twelve values: 45 | ;;; 1. a list of the required args; 46 | ;;; 2. a list of the &OPTIONAL arg specs; 47 | ;;; 3. true if a &REST arg was specified; 48 | ;;; 4. the &REST arg; 49 | ;;; 5. true if &KEY args are present; 50 | ;;; 6. a list of the &KEY arg specs; 51 | ;;; 7. true if &ALLOW-OTHER-KEYS was specified.; 52 | ;;; 8. true if any &AUX is present (new in SBCL vs. CMU CL); 53 | ;;; 9. a list of the &AUX specifiers; 54 | ;;; 10. true if a &MORE arg was specified; 55 | ;;; 11. the &MORE context var; 56 | ;;; 12. the &MORE count var; 57 | ;;; 13. true if any lambda list keyword is present (only for 58 | ;;; PARSE-LAMBDA-LIST-LIKE-THING). 59 | ;;; 14. the &KEY-OBJECT var 60 | ;;; 61 | ;;; The top level lambda list syntax is checked for validity, but the 62 | ;;; arg specifiers are just passed through untouched. 63 | 64 | (eval-when (:compile-toplevel :load-toplevel :execute) 65 | (defun collect-list-expander (n-value n-tail forms) 66 | (let ((n-res (gensym))) 67 | `(progn 68 | ,@(mapcar (lambda (form) 69 | `(let ((,n-res (cons ,form nil))) 70 | (cond (,n-tail 71 | (setf (cdr ,n-tail) ,n-res) 72 | (setq ,n-tail ,n-res)) 73 | (t 74 | (setq ,n-tail ,n-res ,n-value ,n-res))))) 75 | forms) 76 | ,n-value)))) 77 | 78 | (defmacro collect (collections &body body) 79 | (let ((macros ()) 80 | (binds ())) 81 | (dolist (spec collections) 82 | ;;(unless (proper-list-of-length-p spec 1 3) 83 | ;; (error "malformed collection specifier: ~S" spec)) 84 | (let* ((name (first spec)) 85 | (default (second spec)) 86 | (kind (or (third spec) 'collect)) 87 | (n-value (gensym (concatenate 'string 88 | (symbol-name name) 89 | "-N-VALUE-")))) 90 | (push `(,n-value ,default) binds) 91 | (if (eq kind 'collect) 92 | (let ((n-tail (gensym (concatenate 'string 93 | (symbol-name name) 94 | "-N-TAIL-")))) 95 | (if default 96 | (push `(,n-tail (last ,n-value)) binds) 97 | (push n-tail binds)) 98 | (push `(,name (&rest args) 99 | (collect-list-expander ',n-value ',n-tail args)) 100 | macros)) 101 | (push `(,name (&rest args) 102 | (collect-normal-expander ',n-value ',kind args)) 103 | macros)))) 104 | `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) 105 | 106 | (defparameter *lambda-list-keywords* 107 | '(&allow-other-keys &aux &body &environment &key &key-object &optional &rest &whole)) 108 | 109 | (defun style-warn (&rest args) (apply #'format t args)) 110 | 111 | (defun parse-lambda-list-like-thing (list) 112 | (collect ((required) 113 | (optional) 114 | (keys) 115 | (aux)) 116 | (let ((restp nil) 117 | (rest nil) 118 | (morep nil) 119 | (more-context nil) 120 | (more-count nil) 121 | (keyp nil) 122 | (auxp nil) 123 | (allowp nil) 124 | (key-object nil) 125 | (state :required)) 126 | (declare (type (member :allow-other-keys :aux 127 | :key 128 | :more-context :more-count 129 | :optional 130 | :post-more :post-rest 131 | :required :rest 132 | :key-object :post-key) 133 | state)) 134 | (dolist (arg list) 135 | (if (member arg *lambda-list-keywords*) 136 | (case arg 137 | (&optional 138 | (unless (eq state :required) 139 | (format t "misplaced &OPTIONAL in lambda list: ~S" 140 | list)) 141 | (setq state :optional)) 142 | (&rest 143 | (unless (member state '(:required :optional)) 144 | (format t "misplaced &REST in lambda list: ~S" list)) 145 | (setq state :rest)) 146 | (&more 147 | (unless (member state '(:required :optional)) 148 | (format t "misplaced &MORE in lambda list: ~S" list)) 149 | (setq morep t 150 | state :more-context)) 151 | (&key 152 | (unless (member state 153 | '(:required :optional :post-rest :post-more)) 154 | (format t "misplaced &KEY in lambda list: ~S" list)) 155 | (when (optional) 156 | (format t "&OPTIONAL and &KEY found in the same lambda list: ~S" list)) 157 | (setq keyp t 158 | state :key)) 159 | (&allow-other-keys 160 | (unless (member state '(:key :post-key)) 161 | (format t "misplaced &ALLOW-OTHER-KEYS in ~ 162 | lambda list: ~S" 163 | list)) 164 | (setq allowp t 165 | state :allow-other-keys)) 166 | (&aux 167 | (when (member state '(:rest :more-context :more-count)) 168 | (format t "misplaced &AUX in lambda list: ~S" list)) 169 | (when auxp 170 | (format t "multiple &AUX in lambda list: ~S" list)) 171 | (setq auxp t 172 | state :aux)) 173 | (&key-object 174 | (unless (member state '(:key :allow-other-keys)) 175 | (format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list)) 176 | (setf state :key-object)) 177 | (t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg))) 178 | (progn 179 | (when (symbolp arg) 180 | (let ((name (symbol-name arg))) 181 | (when (and (plusp (length name)) 182 | (char= (char name 0) #\&)) 183 | (style-warn 184 | "suspicious variable in lambda list: ~S." arg)))) 185 | (case state 186 | (:required (required arg)) 187 | (:optional (optional arg)) 188 | (:rest 189 | (setq restp t 190 | rest arg 191 | state :post-rest)) 192 | (:more-context 193 | (setq more-context arg 194 | state :more-count)) 195 | (:more-count 196 | (setq more-count arg 197 | state :post-more)) 198 | (:key (keys arg)) 199 | (:key-object (setf key-object arg) (setf state :post-key)) 200 | (:aux (aux arg)) 201 | (t 202 | (format t "found garbage in lambda list when expecting ~ 203 | a keyword: ~S" 204 | arg)))))) 205 | (when (eq state :rest) 206 | (format t "&REST without rest variable")) 207 | 208 | (values (required) (optional) restp rest keyp (keys) allowp auxp (aux) 209 | morep more-context more-count 210 | (not (eq state :required)) 211 | key-object)))) 212 | 213 | ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument 214 | ;;; really *is* a lambda list, not just a "lambda-list-like thing", so 215 | ;;; can barf on things which're illegal as arguments in lambda lists 216 | ;;; even if they could conceivably be legal in not-quite-a-lambda-list 217 | ;;; weirdosities 218 | (defun parse-lambda-list (lambda-list) 219 | ;; Classify parameters without checking their validity individually. 220 | (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux 221 | morep more-context more-count beyond-requireds? key-object) 222 | (parse-lambda-list-like-thing lambda-list) 223 | (declare (ignore beyond-requireds?)) 224 | ;; Check validity of parameters. 225 | (flet ((need-symbol (x why) 226 | (unless (symbolp x) 227 | (format t "~A is not a symbol: ~S" why x)))) 228 | (dolist (i required) 229 | (need-symbol i "Required argument")) 230 | (dolist (i optional) 231 | (typecase i 232 | (symbol) 233 | (cons 234 | (destructuring-bind (var &optional init-form supplied-p) i 235 | (declare (ignore init-form supplied-p)) 236 | (need-symbol var "&OPTIONAL parameter name"))) 237 | (t 238 | (format t "&OPTIONAL parameter is not a symbol or cons: ~S" 239 | i)))) 240 | (when restp 241 | (need-symbol rest "&REST argument")) 242 | (when keyp 243 | (dolist (i keys) 244 | (typecase i 245 | (symbol) 246 | (cons 247 | (destructuring-bind (var-or-kv &optional init-form supplied-p) i 248 | (declare (ignore init-form supplied-p)) 249 | (if (consp var-or-kv) 250 | (destructuring-bind (keyword-name var) var-or-kv 251 | (declare (ignore keyword-name)) 252 | (need-symbol var "&KEY parameter name")) 253 | (need-symbol var-or-kv "&KEY parameter name")))) 254 | (t 255 | (format t "&KEY parameter is not a symbol or cons: ~S" 256 | i)))))) 257 | ;; Voila. 258 | (values required optional restp rest keyp keys allowp auxp aux 259 | morep more-context more-count key-object))) 260 | -------------------------------------------------------------------------------- /src/printer.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-2006 Edward Marco Baringer 3 | ;;; Copyright 2007-2012 Vladimir Sedach 4 | ;;; Copyright 2008 Travis Cross 5 | ;;; Copyright 2009-2013 Daniel Gackle 6 | ;;; Copyright 2010 Scott Bell 7 | ;;; Copyright 2014 Boris Smilga 8 | 9 | ;;; SPDX-License-Identifier: BSD-3-Clause 10 | 11 | ;;; Redistribution and use in source and binary forms, with or 12 | ;;; without modification, are permitted provided that the following 13 | ;;; conditions are met: 14 | 15 | ;;; 1. Redistributions of source code must retain the above copyright 16 | ;;; notice, this list of conditions and the following disclaimer. 17 | 18 | ;;; 2. Redistributions in binary form must reproduce the above 19 | ;;; copyright notice, this list of conditions and the following 20 | ;;; disclaimer in the documentation and/or other materials provided 21 | ;;; with the distribution. 22 | 23 | ;;; 3. Neither the name of the copyright holder nor the names of its 24 | ;;; contributors may be used to endorse or promote products derived 25 | ;;; from this software without specific prior written permission. 26 | 27 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 28 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 29 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 30 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 31 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 32 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 33 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 34 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 35 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 36 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 37 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 38 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 39 | ;;; POSSIBILITY OF SUCH DAMAGE. 40 | 41 | (in-package #:parenscript) 42 | (in-readtable :parenscript) 43 | 44 | (defvar *ps-print-pretty* t) 45 | (defvar *indent-num-spaces* 4) 46 | (defvar *js-string-delimiter* #\' 47 | "Specifies which character should be used for delimiting strings. 48 | 49 | This variable is used when you want to embed the resulting JavaScript 50 | in an html attribute delimited by #\\\" as opposed to #\\', or 51 | vice-versa.") 52 | 53 | (defvar *indent-level*) 54 | (defvar *column*) 55 | 56 | (defvar *psw-stream*) 57 | 58 | (defun parenscript-print (form immediate?) 59 | (declare (special immediate?)) 60 | (let ((*indent-level* 0) 61 | (*column* 0) 62 | (*psw-stream* (if immediate? 63 | *psw-stream* 64 | (make-string-output-stream))) 65 | (%psw-accumulator ())) 66 | (declare (special %psw-accumulator)) 67 | (with-standard-io-syntax 68 | (if (and (listp form) (eq 'ps-js:block (car form))) ; ignore top-level block 69 | (loop for (statement . remaining) on (cdr form) do 70 | (ps-print statement) (psw #\;) (when remaining (psw #\Newline))) 71 | (ps-print form))) 72 | (unless immediate? 73 | (reverse (cons (get-output-stream-string *psw-stream*) 74 | %psw-accumulator))))) 75 | 76 | (defun psw (&rest objs) 77 | (dolist (obj objs) 78 | (declare (special %psw-accumulator immediate?)) 79 | (typecase obj 80 | (string 81 | (incf *column* (length obj)) 82 | (write-string obj *psw-stream*)) 83 | (character 84 | (if (eql obj #\Newline) 85 | (setf *column* 0) 86 | (incf *column*)) 87 | (write-char obj *psw-stream*)) 88 | (otherwise 89 | (if immediate? 90 | (let ((str (eval obj))) 91 | (incf *column* (length str)) 92 | (write-string str *psw-stream*)) 93 | (setf %psw-accumulator 94 | (list* obj 95 | (get-output-stream-string *psw-stream*) 96 | %psw-accumulator))))))) 97 | 98 | (defgeneric ps-print (form)) 99 | (defgeneric ps-print% (js-primitive args)) 100 | 101 | (defmacro defprinter (js-primitive args &body body) 102 | (if (listp js-primitive) 103 | (cons 'progn (mapcar (lambda (p) 104 | `(defprinter ,p ,args ,@body)) 105 | js-primitive)) 106 | (let ((pargs (gensym))) 107 | `(defmethod ps-print% ((op (eql ',js-primitive)) ,pargs) 108 | (declare (ignorable op)) 109 | (destructuring-bind ,args 110 | ,pargs 111 | ,@(loop for x in body collect 112 | (if (or (characterp x) 113 | (stringp x)) 114 | (list 'psw x) 115 | x))))))) 116 | 117 | (defmethod ps-print ((x null)) 118 | (psw "null")) 119 | 120 | (defmethod ps-print ((x (eql t))) 121 | (psw "true")) 122 | 123 | (defmethod ps-print ((x (eql 'ps-js:false))) 124 | (psw "false")) 125 | 126 | (defmethod ps-print ((s symbol)) 127 | (if (keywordp s) 128 | (ps-print (string-downcase s)) 129 | (psw (symbol-to-js-string s)))) 130 | 131 | (defmethod ps-print ((compiled-form cons)) 132 | (ps-print% (car compiled-form) (cdr compiled-form))) 133 | 134 | (defun newline-and-indent (&optional indent-spaces) 135 | (if *ps-print-pretty* 136 | (progn (psw #\Newline) 137 | (loop repeat (if indent-spaces 138 | indent-spaces 139 | (* *indent-level* *indent-num-spaces*)) 140 | do (psw #\Space))) 141 | (psw #\Space))) 142 | 143 | (defun print-comment (comment-str) 144 | (when *ps-print-pretty* 145 | (let ((lines (cl-ppcre:split #\Newline comment-str))) 146 | (if (cdr lines) 147 | (progn (psw "/**") (newline-and-indent) 148 | (dolist (x lines) (psw " * " x) (newline-and-indent)) 149 | (psw " */")) 150 | (psw "/** " comment-str " */")) 151 | (newline-and-indent)))) 152 | 153 | (defparameter *js-lisp-escaped-chars* 154 | (list #\' #\' 155 | #\" #\" 156 | #\\ #\\ 157 | #\Backspace #\b 158 | (code-char 12) #\f 159 | #\Newline #\n 160 | #\Return #\r 161 | #\Tab #\t)) 162 | 163 | (defmethod ps-print ((char character)) 164 | (ps-print (string char))) 165 | 166 | (defmethod ps-print ((string string)) 167 | (psw *js-string-delimiter*) 168 | (loop for char across string do 169 | (acond ((getf *js-lisp-escaped-chars* char) 170 | (psw #\\ it)) 171 | ((or (<= (char-code char) #x1F) 172 | (<= #x80 (char-code char) #x9F) 173 | (member (char-code char) '(#xA0 #xAD #x200B #x200C))) 174 | (format *psw-stream* "\\u~:@(~4,'0x~)" (char-code char))) 175 | (t 176 | (psw char)))) 177 | (psw *js-string-delimiter*)) 178 | 179 | (defmethod ps-print ((number number)) 180 | (format *psw-stream* (if (integerp number) "~D" "~F") number)) 181 | 182 | (let ((precedence-table (make-hash-table :test 'eq))) 183 | (loop for level in '((ps-js:getprop ps-js:aref ps-js:funcall) 184 | (ps-js:new) 185 | (ps-js:lambda) ;; you won't find this in JS books 186 | (ps-js:++ ps-js:-- ps-js:post++ ps-js:post--) 187 | (ps-js:! ps-js:~ ps-js:negate ps-js:unary-plus ps-js:typeof ps-js:delete) 188 | (ps-js:* ps-js:/ ps-js:%) 189 | (ps-js:- ps-js:+) 190 | (ps-js:<< ps-js:>> ps-js:>>>) 191 | (ps-js:< ps-js:> ps-js:<= ps-js:>= ps-js:instanceof ps-js:in) 192 | (ps-js:== ps-js:!= ps-js:=== ps-js:!==) 193 | (ps-js:&) 194 | (ps-js:^) 195 | (ps-js:\|) 196 | (ps-js:&&) 197 | (ps-js:\|\|) 198 | (ps-js:?) 199 | (ps-js:= ps-js:*= ps-js:/= ps-js:%= ps-js:+= ps-js:-= ps-js:<<= ps-js:>>= ps-js:>>>= ps-js:&= ps-js:^= ps-js:\|=) 200 | (ps-js:return ps-js:throw) 201 | (ps-js:|,|)) 202 | for i from 0 203 | do (mapc (lambda (symbol) 204 | (setf (gethash symbol precedence-table) i)) 205 | level)) 206 | (defun precedence (op) 207 | (gethash op precedence-table -1))) 208 | 209 | (defun associative? (op) 210 | (member op '(ps-js:* ps-js:& ps-js:&& ps-js:\| ps-js:\|\| 211 | ps-js:funcall ps-js:aref ps-js:getprop))) ;; these aren't really associative, but RPN 212 | 213 | (defun parenthesize-print (x) 214 | (psw #\() (ps-print x) (psw #\))) 215 | 216 | (defun print-op-argument (op argument) 217 | (let ((arg-op (when (listp argument) (car argument)))) 218 | (if (or (< (precedence op) (precedence arg-op)) 219 | (and (= (precedence op) (precedence arg-op)) 220 | (or (not (associative? op)) (not (associative? arg-op))))) 221 | (parenthesize-print argument) 222 | (ps-print argument)))) 223 | 224 | (defun print-op (op) 225 | (psw (string-downcase op))) 226 | 227 | (defprinter (ps-js:! ps-js:~ ps-js:++ ps-js:--) (x) 228 | (print-op op) (print-op-argument op x)) 229 | 230 | (defprinter ps-js:negate (x) 231 | "-"(print-op-argument op x)) 232 | 233 | (defprinter ps-js:unary-plus (x) 234 | "+"(print-op-argument op x)) 235 | 236 | (defprinter (ps-js:delete ps-js:typeof ps-js:new ps-js:throw) (x) 237 | (print-op op)" "(print-op-argument op x)) 238 | 239 | (defprinter (ps-js:return) (&optional (x nil x?)) 240 | (print-op op) 241 | (when x? 242 | (psw " ") (print-op-argument op x))) 243 | 244 | (defprinter ps-js:post++ (x) 245 | (ps-print x)"++") 246 | 247 | (defprinter ps-js:post-- (x) 248 | (ps-print x)"--") 249 | 250 | (defprinter (ps-js:+ ps-js:- ps-js:* ps-js:/ ps-js:% ps-js:&& ps-js:\|\| ps-js:& ps-js:\| ps-js:-= ps-js:+= ps-js:*= ps-js:/= ps-js:%= ps-js:^ ps-js:<< ps-js:>> ps-js:&= ps-js:^= ps-js:\|= ps-js:= ps-js:in ps-js:> ps-js:>= ps-js:< ps-js:<= ps-js:== ps-js:!= ps-js:=== ps-js:!==) 251 | (&rest args) 252 | (loop for (arg . remaining) on args do 253 | (print-op-argument op arg) 254 | (when remaining (format *psw-stream* " ~(~A~) " op)))) 255 | 256 | (defprinter ps-js:aref (array &rest indices) 257 | (print-op-argument 'ps-js:aref array) 258 | (dolist (idx indices) 259 | (psw #\[) (ps-print idx) (psw #\]))) 260 | 261 | (defun print-comma-delimited-list (ps-forms) 262 | (loop for (form . remaining) on ps-forms do 263 | (print-op-argument 'ps-js:|,| form) 264 | (when remaining (psw ", ")))) 265 | 266 | (defprinter ps-js:array (&rest initial-contents) 267 | "["(print-comma-delimited-list initial-contents)"]") 268 | 269 | (defprinter (ps-js:|,|) (&rest expressions) 270 | (print-comma-delimited-list expressions)) 271 | 272 | (defprinter ps-js:funcall (fun-designator &rest args) 273 | (print-op-argument op fun-designator)"("(print-comma-delimited-list args)")") 274 | 275 | (defprinter ps-js:block (&rest statements) 276 | "{" (incf *indent-level*) 277 | (dolist (statement statements) 278 | (newline-and-indent) (ps-print statement) (psw #\;)) 279 | (decf *indent-level*) (newline-and-indent) 280 | "}") 281 | 282 | (defprinter ps-js:lambda (args body-block) 283 | (print-fun-def nil args body-block)) 284 | 285 | (defprinter ps-js:defun (name args docstring body-block) 286 | (when docstring (print-comment docstring)) 287 | (print-fun-def name args body-block)) 288 | 289 | (defun print-fun-def (name args body) 290 | (destructuring-bind (keyword name) (if (consp name) name `(function ,name)) 291 | (format *psw-stream* "~(~A~) ~:[~;~A~](" 292 | keyword name (symbol-to-js-string name)) 293 | (loop for (arg . remaining) on args do 294 | (psw (symbol-to-js-string arg)) (when remaining (psw ", "))) 295 | (psw ") ") 296 | (ps-print body))) 297 | 298 | (defprinter ps-js:object (&rest slot-defs) 299 | (psw "{ ") 300 | (let ((indent? (< 2 (length slot-defs))) 301 | (indent *column*)) 302 | (loop for ((slot-name . slot-value) . remaining) on slot-defs do 303 | (if (consp slot-name) 304 | (apply #'print-fun-def slot-name slot-value) 305 | (progn 306 | (ps-print slot-name) (psw " : ") 307 | (if (and (consp slot-value) 308 | (eq 'ps-js:|,| (car slot-value))) 309 | (parenthesize-print slot-value) 310 | (ps-print slot-value)))) 311 | (when remaining 312 | (psw ",") 313 | (if indent? 314 | (newline-and-indent indent) 315 | (psw #\Space)))) 316 | (if indent? 317 | (newline-and-indent (- indent 2)) 318 | (psw #\Space))) 319 | (psw "}")) 320 | 321 | (defprinter ps-js:getprop (obj slot) 322 | (print-op-argument op obj)"."(psw (symbol-to-js-string slot))) 323 | 324 | (defprinter ps-js:if (test consequent &rest clauses) 325 | "if (" (ps-print test) ") " 326 | (ps-print consequent) 327 | (loop while clauses do 328 | (ecase (car clauses) 329 | (:else-if (psw " else if (") (ps-print (cadr clauses)) (psw ") ") 330 | (ps-print (caddr clauses)) 331 | (setf clauses (cdddr clauses))) 332 | (:else (psw " else ") 333 | (ps-print (cadr clauses)) 334 | (return))))) 335 | 336 | (defprinter ps-js:? (test then else) 337 | (print-op-argument op test) " ? " 338 | (print-op-argument op then) " : " 339 | (print-op-argument op else)) 340 | 341 | (defprinter ps-js:var (var-name &optional (value (values) value?) docstring) 342 | (when docstring (print-comment docstring)) 343 | "var "(psw (symbol-to-js-string var-name)) 344 | (when value? (psw " = ") (print-op-argument 'ps-js:= value))) 345 | 346 | (defprinter ps-js:label (label statement) 347 | (psw (symbol-to-js-string label))": "(ps-print statement)) 348 | 349 | (defprinter (ps-js:continue ps-js:break) (&optional label) 350 | (print-op op) (when label 351 | (psw " " (symbol-to-js-string label)))) 352 | 353 | ;;; iteration 354 | (defprinter ps-js:for (vars tests steps body-block) 355 | "for (" 356 | (loop for ((var-name . var-init) . remaining) on vars 357 | for decl = "var " then "" do 358 | (psw decl (symbol-to-js-string var-name) " = ") 359 | (print-op-argument 'ps-js:= var-init) 360 | (when remaining (psw ", "))) 361 | "; " 362 | (loop for (test . remaining) on tests do 363 | (ps-print test) (when remaining (psw ", "))) 364 | "; " 365 | (loop for (step . remaining) on steps do 366 | (ps-print step) (when remaining (psw ", "))) 367 | ") " 368 | (ps-print body-block)) 369 | 370 | (defprinter ps-js:for-in (var object body-block) 371 | "for (var "(ps-print var)" in "(ps-print object)") " 372 | (ps-print body-block)) 373 | 374 | (defprinter (ps-js:with ps-js:while) (expression body-block) 375 | (print-op op)" ("(ps-print expression)") " 376 | (ps-print body-block)) 377 | 378 | (defprinter ps-js:switch (test &rest clauses) 379 | "switch ("(ps-print test)") {" 380 | (flet ((print-body (body) 381 | (incf *indent-level*) 382 | (loop for statement in body do 383 | (newline-and-indent) 384 | (ps-print statement) 385 | (psw #\;)) 386 | (decf *indent-level*))) 387 | (loop for (val . statements) in clauses do 388 | (newline-and-indent) 389 | (if (eq val 'ps-js:default) 390 | (progn (psw "default:") 391 | (print-body statements)) 392 | (progn (psw "case ") (ps-print val) (psw #\:) 393 | (print-body statements))))) 394 | (newline-and-indent) 395 | "}") 396 | 397 | (defprinter ps-js:try (body-block &key catch finally) 398 | "try "(ps-print body-block) 399 | (when catch 400 | (psw " catch ("(symbol-to-js-string (first catch))") ") 401 | (ps-print (second catch))) 402 | (when finally 403 | (psw " finally ") (ps-print finally))) 404 | 405 | (defprinter ps-js:regex (regex) 406 | (let ((slash (unless (and (> (length regex) 0) (char= (char regex 0) #\/)) "/"))) 407 | (psw (concatenate 'string slash regex slash)))) 408 | 409 | (defprinter ps-js:instanceof (value type) 410 | "("(print-op-argument op value)" instanceof "(print-op-argument op type)")") 411 | 412 | (defprinter ps-js:escape (literal-js) 413 | ;; literal-js should be a form that evaluates to a string containing 414 | ;; valid JavaScript 415 | (psw literal-js)) 416 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005 Manuel Odendahl 2 | ;;; Copyright 2005-2006 Edward Marco Baringer 3 | ;;; Copyright 2007 Attila Lendvai 4 | ;;; Copyright 2007 Red Daly 5 | ;;; Copyright 2007-2012 Vladimir Sedach 6 | ;;; Copyright 2008 Travis Cross 7 | 8 | ;;; SPDX-License-Identifier: BSD-3-Clause 9 | 10 | ;;; Redistribution and use in source and binary forms, with or 11 | ;;; without modification, are permitted provided that the following 12 | ;;; conditions are met: 13 | 14 | ;;; 1. Redistributions of source code must retain the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer. 16 | 17 | ;;; 2. Redistributions in binary form must reproduce the above 18 | ;;; copyright notice, this list of conditions and the following 19 | ;;; disclaimer in the documentation and/or other materials provided 20 | ;;; with the distribution. 21 | 22 | ;;; 3. Neither the name of the copyright holder nor the names of its 23 | ;;; contributors may be used to endorse or promote products derived 24 | ;;; from this software without specific prior written permission. 25 | 26 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 27 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 28 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 29 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 30 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 31 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 32 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 33 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 34 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 35 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 36 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 37 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 38 | ;;; POSSIBILITY OF SUCH DAMAGE. 39 | 40 | (in-package #:parenscript) 41 | 42 | (define-condition simple-style-warning (simple-warning style-warning) 43 | ()) 44 | 45 | (let ((cache (make-hash-table :test 'equal))) 46 | (defun encode-js-identifier (identifier) 47 | "Given a string, produces to a valid JavaScript identifier by 48 | following transformation heuristics case conversion. For example, 49 | paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL." 50 | (when (and (not (string= identifier "[]")) 51 | (find #\[ identifier)) 52 | (warn 'simple-style-warning 53 | :format-control 54 | "Parenscript symbol ~A contains a literal array accessor. 55 | This compound naming convention is deprecated and will be removed! 56 | Use AREF, ELT, GETPROP, @, or CHAIN instead." 57 | :format-arguments (list identifier))) 58 | (when (find #\. identifier) 59 | (warn 'simple-style-warning 60 | :format-control 61 | "Parenscript symbol ~A contains one or more dot operators. 62 | This compound naming convention is deprecated and will be removed! 63 | Use GETPROP, @, or CHAIN instead." 64 | :format-arguments (list identifier))) 65 | (or 66 | (gethash identifier cache) 67 | (setf 68 | (gethash identifier cache) 69 | (cond 70 | ((some (lambda (c) (find c "-*+!?#@%/=:<>^")) identifier) 71 | (let ((lowercase t) 72 | (all-uppercase nil)) 73 | (acond 74 | ((nth-value 1 75 | (cl-ppcre:scan-to-strings 76 | "[\\*|\\+](.+)[\\*|\\+](.*)" 77 | identifier :sharedp t)) 78 | (setf all-uppercase t 79 | identifier (concatenate 80 | 'string (aref it 0) (aref it 1)))) 81 | ((and (> (length identifier) 1) 82 | (or (eql (char identifier 0) #\+) 83 | (eql (char identifier 0) #\*))) 84 | (setf lowercase nil 85 | identifier (subseq identifier 1)))) 86 | (with-output-to-string (acc) 87 | (loop 88 | for c across identifier 89 | do (acond 90 | ((eql c #\-) 91 | (setf lowercase (not lowercase))) 92 | ((position c "!?#@%+*/=:<>^") 93 | (write-sequence 94 | (aref #("bang" "what" "hash" "at" "percent" 95 | "plus" "star" "slash" "equals" "colon" 96 | "lessthan" "greaterthan" "caret") 97 | it) 98 | acc)) 99 | (t 100 | (write-char 101 | (if (and lowercase (not all-uppercase)) 102 | (char-downcase c) 103 | (char-upcase c)) 104 | acc) 105 | (setf lowercase t))))))) 106 | (#.(eql :invert (readtable-case 107 | (named-readtables:find-readtable :parenscript))) 108 | (cond 109 | ((every #'upper-case-p 110 | (remove-if-not #'alpha-char-p identifier)) 111 | (string-downcase identifier)) 112 | ((every #'lower-case-p 113 | (remove-if-not #'alpha-char-p identifier)) 114 | (string-upcase identifier)) 115 | (t identifier))) 116 | (t identifier)))))) 117 | 118 | (defun ordered-set-difference (list1 list2 &key (test #'eql)) 119 | "CL set-difference may not preserve order." 120 | (reduce (lambda (list el) (remove el list :test test)) 121 | (cons list1 list2))) 122 | 123 | (defun flatten (x &optional acc) 124 | (cond ((null x) acc) 125 | ((atom x) (cons x acc)) 126 | (t (flatten (car x) (flatten (cdr x) acc))))) 127 | 128 | (defun flatten-blocks (body) 129 | (when body 130 | (if (and (listp (car body)) (eq 'ps-js:block (caar body))) 131 | (append (flatten-blocks (cdr (car body))) 132 | (flatten-blocks (cdr body))) 133 | (cons (car body) (flatten-blocks (cdr body)))))) 134 | 135 | (defun tree-find (A tree) 136 | (or (equal A tree) 137 | (when (consp tree) 138 | (loop for x on tree thereis 139 | (or (tree-find A (car x)) 140 | (unless (listp (cdr x)) 141 | (equal A (cdr x)))))))) 142 | 143 | (defun parse-semver (semver-string) 144 | (let ((semver-list (cl-ppcre:split "\\." semver-string)) 145 | (semver-scaled 0)) 146 | (dotimes (i 3) 147 | (incf semver-scaled 148 | (* (expt 1000 (- 2 i)) 149 | (parse-integer (or (nth i semver-list) "0"))))) 150 | semver-scaled)) 151 | 152 | (defun js-target-at-least (version) 153 | (>= (parse-semver *js-target-version*) (parse-semver version))) 154 | -------------------------------------------------------------------------------- /tests/package-system-tests.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2007 Red Daly 2 | ;;; Copyright 2007 Vladimir Sedach 3 | 4 | ;;; SPDX-License-Identifier: BSD-3-Clause 5 | 6 | ;;; Redistribution and use in source and binary forms, with or 7 | ;;; without modification, are permitted provided that the following 8 | ;;; conditions are met: 9 | 10 | ;;; 1. Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; 2. Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials provided 16 | ;;; with the distribution. 17 | 18 | ;;; 3. Neither the name of the copyright holder nor the names of its 19 | ;;; contributors may be used to endorse or promote products derived 20 | ;;; from this software without specific prior written permission. 21 | 22 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 23 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 24 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 25 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 27 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 28 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 29 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 30 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 31 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 32 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 33 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | ;;; POSSIBILITY OF SUCH DAMAGE. 35 | 36 | (in-package #:parenscript.tests) 37 | 38 | (fiveam:in-suite package-system-tests) 39 | 40 | (test-ps-js operator-packages1 41 | (#:new) 42 | "new();") 43 | 44 | (defpackage #:parenscript.tests.my-library 45 | (:use #:parenscript)) 46 | (setf (ps-package-prefix '#:parenscript.tests.my-library) 47 | "my_library_") 48 | 49 | (test-ps-js lib-function1 50 | (defun parenscript.tests.my-library::library-function (x y) 51 | (+ x y)) 52 | "function my_library_libraryFunction(x, y) { 53 | return x + y; 54 | };") 55 | 56 | (test-ps-js lib-function2 57 | (defun parenscript.tests.my-library::library-function 58 | (parenscript.tests.my-library::x 59 | &key ((:y parenscript.tests.my-library::z) 1)) 60 | (+ parenscript.tests.my-library::x parenscript.tests.my-library::z)) 61 | "function my_library_libraryFunction(my_library_x) { 62 | var _js2 = arguments.length; 63 | for (var n1 = 1; n1 < _js2; n1 += 2) { 64 | switch (arguments[n1]) { 65 | case 'y': 66 | my_library_z = arguments[n1 + 1]; 67 | }; 68 | }; 69 | var my_library_z = 'undefined' === typeof my_library_z ? 1 : my_library_z; 70 | 71 | return my_library_x + my_library_z; 72 | };") 73 | 74 | (test-ps-js uniform-symbol-handling1 75 | (progn (create parenscript.tests.my-library::foo 1) 76 | (getprop foo 'parenscript.tests.my-library::foo)) 77 | "{ my_library_foo : 1 }; 78 | foo.my_library_foo;") 79 | 80 | (let ((map (make-hash-table))) 81 | (defun symbol-obfuscator (symbol) 82 | (or #1=(gethash symbol map) 83 | (setf #1# (make-symbol (map 'string (lambda (x) 84 | (code-char (1+ (char-code x)))) 85 | (symbol-name symbol))))))) 86 | 87 | (defpackage #:parenscript.tests.obfuscate-me) 88 | (obfuscate-package '#:parenscript.tests.obfuscate-me 89 | #'symbol-obfuscator) 90 | 91 | (test-ps-js obfuscation1 92 | (defun parenscript.tests.obfuscate-me::libfun2 (a b parenscript.tests.obfuscate-me::foo) 93 | (+ a (parenscript.tests.my-library::library-function b parenscript.tests.obfuscate-me::foo))) 94 | "function mjcgvo3(a, b, gpp) { 95 | __PS_MV_REG = []; 96 | return a + my_library_libraryFunction(b, gpp); 97 | };") 98 | 99 | (defpackage #:parenscript.tests.obfuscate-and-prefix) 100 | (obfuscate-package '#:parenscript.tests.obfuscate-and-prefix #'symbol-obfuscator) 101 | (setf (ps-package-prefix '#:parenscript.tests.obfuscate-and-prefix) "__FOO___") 102 | 103 | (test-ps-js obfuscate-and-prefix 104 | (defun parenscript.tests.obfuscate-and-prefix::xfun (a parenscript.tests.obfuscate-and-prefix::b parenscript.tests.my-library::d) 105 | (* a 106 | (parenscript.tests.obfuscate-me::libfun2 parenscript.tests.obfuscate-and-prefix::b a) 107 | (parenscript.tests.my-library::library-function parenscript.tests.my-library::d parenscript.tests.obfuscate-and-prefix::b))) 108 | "function __FOO___ygvo(a, __FOO___c, my_library_d) { 109 | __PS_MV_REG = []; 110 | return a * mjcgvo3(__FOO___c, a) * my_library_libraryFunction(my_library_d, __FOO___c); 111 | };") 112 | 113 | (defpackage #:parenscript.tests.pststpkg 114 | (:use #:parenscript)) 115 | 116 | (setf (ps-package-prefix '#:parenscript.tests.pststpkg) "prefix_") 117 | 118 | (fiveam:test namespace1 () 119 | (fiveam:is (string= 120 | (ps* 'parenscript.tests.pststpkg::foo) 121 | "prefix_foo;"))) 122 | 123 | (cl:in-package #:parenscript.tests.pststpkg) 124 | 125 | (parenscript.tests::test-ps-js namespace-and-special-forms 126 | (defun foo () 127 | (let ((foo (create bar 1 not-a-keyword something))) 128 | (return-from foo (and (not foo) (+ (getprop foo 'bar) some-other-var))))) 129 | "function prefix_foo() { 130 | var foo1 = { prefix_bar : 1, prefix_notAKeyword : prefix_something }; 131 | return !foo1 && foo1.prefix_bar + prefix_someOtherVar; 132 | };") 133 | 134 | (parenscript.tests::test-ps-js exported-interface 135 | (defun parenscript.tests:interface-function (baz) 136 | (+ baz parenscript.tests.obfuscate-me::foo)) 137 | "function interfaceFunction(prefix_baz) { 138 | return prefix_baz + gpp; 139 | };") 140 | 141 | (parenscript.tests::test-ps-js prefixed-symbol-macro-obj1 142 | (symbol-macrolet ((x (+ 1 2))) 143 | (ps:create x x)) 144 | "{ prefix_x : 1 + 2 };") 145 | 146 | (cl:in-package #:parenscript.tests) 147 | 148 | (fiveam:test compile-stream-in-package 149 | (fiveam:is 150 | (string= 151 | (with-input-from-string (s " 152 | (defun parenscript.tests.obfuscate-and-prefix::xfun (a parenscript.tests.obfuscate-and-prefix::b parenscript.tests.my-library::d) 153 | (* a 154 | (parenscript.tests.obfuscate-me::libfun2 parenscript.tests.obfuscate-and-prefix::b a) 155 | (parenscript.tests.my-library::library-function parenscript.tests.my-library::d parenscript.tests.obfuscate-and-prefix::b))) 156 | 157 | (in-package #:parenscript.tests.pststpkg) 158 | 159 | (defun parenscript.tests:interface-function (baz) 160 | (+ baz parenscript.tests.obfuscate-me::foo)) 161 | ") 162 | (ps-compile-stream s)) 163 | "function __FOO___ygvo(a, __FOO___c, my_library_d) { 164 | __PS_MV_REG = []; 165 | return a * mjcgvo3(__FOO___c, a) * my_library_libraryFunction(my_library_d, __FOO___c); 166 | }; 167 | function interfaceFunction(prefix_baz) { 168 | return prefix_baz + gpp; 169 | }; 170 | "))) 171 | -------------------------------------------------------------------------------- /tests/test-package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl) 2 | (named-readtables:in-readtable :parenscript) 3 | 4 | (defpackage #:parenscript.tests 5 | (:use #:cl #:parenscript) 6 | (:export 7 | #:parenscript-tests 8 | #:run-tests 9 | #:interface-function 10 | #:test-js-eval 11 | #:test-js-eval-epsilon 12 | #:jsarray)) 13 | 14 | (defpackage #:parenscript.eval-tests 15 | (:use #:cl #:parenscript #:parenscript.tests)) 16 | -------------------------------------------------------------------------------- /tests/test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2005-2006 Henrik Hjelte 2 | ;;; Copyright 2007-2012 Vladimir Sedach 3 | 4 | ;;; SPDX-License-Identifier: BSD-3-Clause 5 | 6 | ;;; Redistribution and use in source and binary forms, with or 7 | ;;; without modification, are permitted provided that the following 8 | ;;; conditions are met: 9 | 10 | ;;; 1. Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; 2. Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials provided 16 | ;;; with the distribution. 17 | 18 | ;;; 3. Neither the name of the copyright holder nor the names of its 19 | ;;; contributors may be used to endorse or promote products derived 20 | ;;; from this software without specific prior written permission. 21 | 22 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 23 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 24 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 25 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS 27 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 28 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 29 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 30 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 31 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 32 | ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 33 | ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | ;;; POSSIBILITY OF SUCH DAMAGE. 35 | 36 | (in-package #:parenscript.tests) 37 | 38 | (defun normalize-js-output (str) 39 | (cl-ppcre:regex-replace-all "\\s+" str " ")) 40 | 41 | (defmacro test-ps-js (testname parenscript javascript 42 | &key (js-target-version *js-target-version*)) 43 | `(fiveam:test ,testname () 44 | (fiveam:is 45 | (string= (normalize-js-output ,javascript) 46 | (normalize-js-output 47 | (let ((*js-target-version* ,js-target-version)) 48 | (ps-doc* ',parenscript))))))) 49 | 50 | (defun js-repr (x) 51 | (cond ((or (consp x) (simple-vector-p x)) 52 | (cl-js:js-array 53 | (make-array (length x) 54 | :initial-contents (map 'vector #'js-repr x) 55 | :adjustable t))) 56 | ((null x) :null) 57 | (t x))) 58 | 59 | (defmacro %test-js-eval (testname parenscript test-statement 60 | js-target-version) 61 | `(fiveam:test ,testname () 62 | (cl-js:with-js-env () 63 | (let* ((*js-target-version* ,js-target-version) 64 | (js-result (cl-js:run-js (ps-doc* ',parenscript)))) 65 | ,test-statement)))) 66 | 67 | (defmacro test-js-eval (testname parenscript expected 68 | &key (js-target-version *js-target-version*)) 69 | `(%test-js-eval ,testname ,parenscript 70 | (fiveam:is (equalp js-result (js-repr ,expected))) 71 | ,js-target-version)) 72 | 73 | (defmacro test-js-eval-epsilon (testname parenscript expected 74 | &key (js-target-version *js-target-version*)) 75 | `(%test-js-eval ,testname ,parenscript 76 | (fiveam:is (< (abs (- js-result ,expected)) 0.0001)) 77 | ,js-target-version)) 78 | 79 | (fiveam:def-suite parenscript-tests) 80 | (fiveam:def-suite output-tests :in parenscript-tests) 81 | (fiveam:def-suite package-system-tests :in parenscript-tests) 82 | (fiveam:def-suite eval-tests :in parenscript-tests) 83 | 84 | (defun run-tests () 85 | (let ((*js-string-delimiter* #\')) 86 | (fiveam:run! 'parenscript-tests))) 87 | --------------------------------------------------------------------------------