├── .gitignore ├── CHANGES ├── LICENSE ├── Makefile ├── README ├── scheme.c └── stdlib.scm /.gitignore: -------------------------------------------------------------------------------- 1 | .* # Ignore all dotfiles... 2 | !.gitignore # except for .gitignore 3 | scheme 4 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | 0.20 - January 24, 2010 - Peter Michaux 2 | - add I/O primitive procedures 3 | * load 4 | * open-input-port 5 | * close-input-port 6 | * input-port? 7 | * eof-object? 8 | * read 9 | * read-char 10 | * peek-char 11 | * open-output-port 12 | * close-output-port 13 | * output-port? 14 | * write-char 15 | * write 16 | * error 17 | 18 | 0.19 - January 23, 2010 - Peter Michaux 19 | - expose the interaction environment 20 | - allow creation of a new environments 21 | - add eval form 22 | 23 | 0.18 - January 22, 2010 - Peter Michaux 24 | - add apply form 25 | 26 | 0.17 - January 21, 2010 - Peter Michaux 27 | - add and and or forms 28 | 29 | 0.16 - January 20, 2010 - Peter Michaux 30 | - add let form 31 | 32 | 0.15 - January 19, 2010 - Peter Michaux 33 | - add cond form 34 | 35 | 0.14 - January 18, 2010 - Peter Michaux 36 | - add begin form 37 | 38 | 0.13 - January 17, 2010 - Peter Michaux 39 | - lambda the ultimate! 40 | 41 | 0.12 - January 16, 2010 - Peter Michaux 42 | - add more primitive procedures 43 | * null? 44 | * boolean? 45 | * symbol? 46 | * integer? 47 | * char? 48 | * string? 49 | * pair? 50 | * procedure? 51 | * number->string 52 | * string->number 53 | * symbol->string 54 | * string->symbol 55 | * char->integer 56 | * integer->char 57 | * + 58 | * - 59 | * * 60 | * quotient 61 | * remainder 62 | * = 63 | * < 64 | * > 65 | * cons 66 | * car 67 | * cdr 68 | * set-car! 69 | * set-cdr! 70 | * list 71 | * eq? 72 | 73 | 0.11 - January 15, 2010 - Peter Michaux 74 | - add a first primitive procedure: + 75 | 76 | 0.10 - January 14, 2010 - Peter Michaux 77 | - add if form using tail call for consequent or alternative 78 | 79 | 0.9 - January 13, 2010 - Peter Michaux 80 | - add environments, variables, definitions, and assignments 81 | 82 | 0.8 - January 12, 2010 - Peter Michaux 83 | - add quote form 84 | 85 | 0.7 - January 11, 2010 - Peter Michaux 86 | - add symbols 87 | 88 | 0.6 - January 10, 2010 - Peter Michaux 89 | - add pairs and lists 90 | 91 | 0.5 - January 9, 2010 - Peter Michaux 92 | - add the empty list 93 | 94 | 0.4 - January 8, 2010 - Peter Michaux 95 | - add strings 96 | 97 | 0.3 - January 7, 2010 - Peter Michaux 98 | - add characters 99 | 100 | 0.2 - January 6, 2010 - Peter Michaux 101 | - add booleans 102 | 103 | 0.1 - January 5, 2010 - Peter Michaux 104 | - Initial REPL with integers 105 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU AFFERO GENERAL PUBLIC LICENSE 2 | Version 3, 19 November 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU Affero General Public License is a free, copyleft license for 11 | software and other kinds of works, specifically designed to ensure 12 | cooperation with the community in the case of network server software. 13 | 14 | The licenses for most software and other practical works are designed 15 | to take away your freedom to share and change the works. By contrast, 16 | our General Public Licenses are intended to guarantee your freedom to 17 | share and change all versions of a program--to make sure it remains free 18 | software for all its users. 19 | 20 | When we speak of free software, we are referring to freedom, not 21 | price. Our General Public Licenses are designed to make sure that you 22 | have the freedom to distribute copies of free software (and charge for 23 | them if you wish), that you receive source code or can get it if you 24 | want it, that you can change the software or use pieces of it in new 25 | free programs, and that you know you can do these things. 26 | 27 | Developers that use our General Public Licenses protect your rights 28 | with two steps: (1) assert copyright on the software, and (2) offer 29 | you this License which gives you legal permission to copy, distribute 30 | and/or modify the software. 31 | 32 | A secondary benefit of defending all users' freedom is that 33 | improvements made in alternate versions of the program, if they 34 | receive widespread use, become available for other developers to 35 | incorporate. Many developers of free software are heartened and 36 | encouraged by the resulting cooperation. However, in the case of 37 | software used on network servers, this result may fail to come about. 38 | The GNU General Public License permits making a modified version and 39 | letting the public access it on a server without ever releasing its 40 | source code to the public. 41 | 42 | The GNU Affero General Public License is designed specifically to 43 | ensure that, in such cases, the modified source code becomes available 44 | to the community. It requires the operator of a network server to 45 | provide the source code of the modified version running there to the 46 | users of that server. Therefore, public use of a modified version, on 47 | a publicly accessible server, gives the public access to the source 48 | code of the modified version. 49 | 50 | An older license, called the Affero General Public License and 51 | published by Affero, was designed to accomplish similar goals. This is 52 | a different license, not a version of the Affero GPL, but Affero has 53 | released a new version of the Affero GPL which permits relicensing under 54 | this license. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | TERMS AND CONDITIONS 60 | 61 | 0. Definitions. 62 | 63 | "This License" refers to version 3 of the GNU Affero General Public License. 64 | 65 | "Copyright" also means copyright-like laws that apply to other kinds of 66 | works, such as semiconductor masks. 67 | 68 | "The Program" refers to any copyrightable work licensed under this 69 | License. Each licensee is addressed as "you". "Licensees" and 70 | "recipients" may be individuals or organizations. 71 | 72 | To "modify" a work means to copy from or adapt all or part of the work 73 | in a fashion requiring copyright permission, other than the making of an 74 | exact copy. The resulting work is called a "modified version" of the 75 | earlier work or a work "based on" the earlier work. 76 | 77 | A "covered work" means either the unmodified Program or a work based 78 | on the Program. 79 | 80 | To "propagate" a work means to do anything with it that, without 81 | permission, would make you directly or secondarily liable for 82 | infringement under applicable copyright law, except executing it on a 83 | computer or modifying a private copy. Propagation includes copying, 84 | distribution (with or without modification), making available to the 85 | public, and in some countries other activities as well. 86 | 87 | To "convey" a work means any kind of propagation that enables other 88 | parties to make or receive copies. Mere interaction with a user through 89 | a computer network, with no transfer of a copy, is not conveying. 90 | 91 | An interactive user interface displays "Appropriate Legal Notices" 92 | to the extent that it includes a convenient and prominently visible 93 | feature that (1) displays an appropriate copyright notice, and (2) 94 | tells the user that there is no warranty for the work (except to the 95 | extent that warranties are provided), that licensees may convey the 96 | work under this License, and how to view a copy of this License. If 97 | the interface presents a list of user commands or options, such as a 98 | menu, a prominent item in the list meets this criterion. 99 | 100 | 1. Source Code. 101 | 102 | The "source code" for a work means the preferred form of the work 103 | for making modifications to it. "Object code" means any non-source 104 | form of a work. 105 | 106 | A "Standard Interface" means an interface that either is an official 107 | standard defined by a recognized standards body, or, in the case of 108 | interfaces specified for a particular programming language, one that 109 | is widely used among developers working in that language. 110 | 111 | The "System Libraries" of an executable work include anything, other 112 | than the work as a whole, that (a) is included in the normal form of 113 | packaging a Major Component, but which is not part of that Major 114 | Component, and (b) serves only to enable use of the work with that 115 | Major Component, or to implement a Standard Interface for which an 116 | implementation is available to the public in source code form. A 117 | "Major Component", in this context, means a major essential component 118 | (kernel, window system, and so on) of the specific operating system 119 | (if any) on which the executable work runs, or a compiler used to 120 | produce the work, or an object code interpreter used to run it. 121 | 122 | The "Corresponding Source" for a work in object code form means all 123 | the source code needed to generate, install, and (for an executable 124 | work) run the object code and to modify the work, including scripts to 125 | control those activities. However, it does not include the work's 126 | System Libraries, or general-purpose tools or generally available free 127 | programs which are used unmodified in performing those activities but 128 | which are not part of the work. For example, Corresponding Source 129 | includes interface definition files associated with source files for 130 | the work, and the source code for shared libraries and dynamically 131 | linked subprograms that the work is specifically designed to require, 132 | such as by intimate data communication or control flow between those 133 | subprograms and other parts of the work. 134 | 135 | The Corresponding Source need not include anything that users 136 | can regenerate automatically from other parts of the Corresponding 137 | Source. 138 | 139 | The Corresponding Source for a work in source code form is that 140 | same work. 141 | 142 | 2. Basic Permissions. 143 | 144 | All rights granted under this License are granted for the term of 145 | copyright on the Program, and are irrevocable provided the stated 146 | conditions are met. This License explicitly affirms your unlimited 147 | permission to run the unmodified Program. The output from running a 148 | covered work is covered by this License only if the output, given its 149 | content, constitutes a covered work. This License acknowledges your 150 | rights of fair use or other equivalent, as provided by copyright law. 151 | 152 | You may make, run and propagate covered works that you do not 153 | convey, without conditions so long as your license otherwise remains 154 | in force. You may convey covered works to others for the sole purpose 155 | of having them make modifications exclusively for you, or provide you 156 | with facilities for running those works, provided that you comply with 157 | the terms of this License in conveying all material for which you do 158 | not control copyright. Those thus making or running the covered works 159 | for you must do so exclusively on your behalf, under your direction 160 | and control, on terms that prohibit them from making any copies of 161 | your copyrighted material outside their relationship with you. 162 | 163 | Conveying under any other circumstances is permitted solely under 164 | the conditions stated below. Sublicensing is not allowed; section 10 165 | makes it unnecessary. 166 | 167 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 168 | 169 | No covered work shall be deemed part of an effective technological 170 | measure under any applicable law fulfilling obligations under article 171 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 172 | similar laws prohibiting or restricting circumvention of such 173 | measures. 174 | 175 | When you convey a covered work, you waive any legal power to forbid 176 | circumvention of technological measures to the extent such circumvention 177 | is effected by exercising rights under this License with respect to 178 | the covered work, and you disclaim any intention to limit operation or 179 | modification of the work as a means of enforcing, against the work's 180 | users, your or third parties' legal rights to forbid circumvention of 181 | technological measures. 182 | 183 | 4. Conveying Verbatim Copies. 184 | 185 | You may convey verbatim copies of the Program's source code as you 186 | receive it, in any medium, provided that you conspicuously and 187 | appropriately publish on each copy an appropriate copyright notice; 188 | keep intact all notices stating that this License and any 189 | non-permissive terms added in accord with section 7 apply to the code; 190 | keep intact all notices of the absence of any warranty; and give all 191 | recipients a copy of this License along with the Program. 192 | 193 | You may charge any price or no price for each copy that you convey, 194 | and you may offer support or warranty protection for a fee. 195 | 196 | 5. Conveying Modified Source Versions. 197 | 198 | You may convey a work based on the Program, or the modifications to 199 | produce it from the Program, in the form of source code under the 200 | terms of section 4, provided that you also meet all of these conditions: 201 | 202 | a) The work must carry prominent notices stating that you modified 203 | it, and giving a relevant date. 204 | 205 | b) The work must carry prominent notices stating that it is 206 | released under this License and any conditions added under section 207 | 7. This requirement modifies the requirement in section 4 to 208 | "keep intact all notices". 209 | 210 | c) You must license the entire work, as a whole, under this 211 | License to anyone who comes into possession of a copy. This 212 | License will therefore apply, along with any applicable section 7 213 | additional terms, to the whole of the work, and all its parts, 214 | regardless of how they are packaged. This License gives no 215 | permission to license the work in any other way, but it does not 216 | invalidate such permission if you have separately received it. 217 | 218 | d) If the work has interactive user interfaces, each must display 219 | Appropriate Legal Notices; however, if the Program has interactive 220 | interfaces that do not display Appropriate Legal Notices, your 221 | work need not make them do so. 222 | 223 | A compilation of a covered work with other separate and independent 224 | works, which are not by their nature extensions of the covered work, 225 | and which are not combined with it such as to form a larger program, 226 | in or on a volume of a storage or distribution medium, is called an 227 | "aggregate" if the compilation and its resulting copyright are not 228 | used to limit the access or legal rights of the compilation's users 229 | beyond what the individual works permit. Inclusion of a covered work 230 | in an aggregate does not cause this License to apply to the other 231 | parts of the aggregate. 232 | 233 | 6. Conveying Non-Source Forms. 234 | 235 | You may convey a covered work in object code form under the terms 236 | of sections 4 and 5, provided that you also convey the 237 | machine-readable Corresponding Source under the terms of this License, 238 | in one of these ways: 239 | 240 | a) Convey the object code in, or embodied in, a physical product 241 | (including a physical distribution medium), accompanied by the 242 | Corresponding Source fixed on a durable physical medium 243 | customarily used for software interchange. 244 | 245 | b) Convey the object code in, or embodied in, a physical product 246 | (including a physical distribution medium), accompanied by a 247 | written offer, valid for at least three years and valid for as 248 | long as you offer spare parts or customer support for that product 249 | model, to give anyone who possesses the object code either (1) a 250 | copy of the Corresponding Source for all the software in the 251 | product that is covered by this License, on a durable physical 252 | medium customarily used for software interchange, for a price no 253 | more than your reasonable cost of physically performing this 254 | conveying of source, or (2) access to copy the 255 | Corresponding Source from a network server at no charge. 256 | 257 | c) Convey individual copies of the object code with a copy of the 258 | written offer to provide the Corresponding Source. This 259 | alternative is allowed only occasionally and noncommercially, and 260 | only if you received the object code with such an offer, in accord 261 | with subsection 6b. 262 | 263 | d) Convey the object code by offering access from a designated 264 | place (gratis or for a charge), and offer equivalent access to the 265 | Corresponding Source in the same way through the same place at no 266 | further charge. You need not require recipients to copy the 267 | Corresponding Source along with the object code. If the place to 268 | copy the object code is a network server, the Corresponding Source 269 | may be on a different server (operated by you or a third party) 270 | that supports equivalent copying facilities, provided you maintain 271 | clear directions next to the object code saying where to find the 272 | Corresponding Source. Regardless of what server hosts the 273 | Corresponding Source, you remain obligated to ensure that it is 274 | available for as long as needed to satisfy these requirements. 275 | 276 | e) Convey the object code using peer-to-peer transmission, provided 277 | you inform other peers where the object code and Corresponding 278 | Source of the work are being offered to the general public at no 279 | charge under subsection 6d. 280 | 281 | A separable portion of the object code, whose source code is excluded 282 | from the Corresponding Source as a System Library, need not be 283 | included in conveying the object code work. 284 | 285 | A "User Product" is either (1) a "consumer product", which means any 286 | tangible personal property which is normally used for personal, family, 287 | or household purposes, or (2) anything designed or sold for incorporation 288 | into a dwelling. In determining whether a product is a consumer product, 289 | doubtful cases shall be resolved in favor of coverage. For a particular 290 | product received by a particular user, "normally used" refers to a 291 | typical or common use of that class of product, regardless of the status 292 | of the particular user or of the way in which the particular user 293 | actually uses, or expects or is expected to use, the product. A product 294 | is a consumer product regardless of whether the product has substantial 295 | commercial, industrial or non-consumer uses, unless such uses represent 296 | the only significant mode of use of the product. 297 | 298 | "Installation Information" for a User Product means any methods, 299 | procedures, authorization keys, or other information required to install 300 | and execute modified versions of a covered work in that User Product from 301 | a modified version of its Corresponding Source. The information must 302 | suffice to ensure that the continued functioning of the modified object 303 | code is in no case prevented or interfered with solely because 304 | modification has been made. 305 | 306 | If you convey an object code work under this section in, or with, or 307 | specifically for use in, a User Product, and the conveying occurs as 308 | part of a transaction in which the right of possession and use of the 309 | User Product is transferred to the recipient in perpetuity or for a 310 | fixed term (regardless of how the transaction is characterized), the 311 | Corresponding Source conveyed under this section must be accompanied 312 | by the Installation Information. But this requirement does not apply 313 | if neither you nor any third party retains the ability to install 314 | modified object code on the User Product (for example, the work has 315 | been installed in ROM). 316 | 317 | The requirement to provide Installation Information does not include a 318 | requirement to continue to provide support service, warranty, or updates 319 | for a work that has been modified or installed by the recipient, or for 320 | the User Product in which it has been modified or installed. Access to a 321 | network may be denied when the modification itself materially and 322 | adversely affects the operation of the network or violates the rules and 323 | protocols for communication across the network. 324 | 325 | Corresponding Source conveyed, and Installation Information provided, 326 | in accord with this section must be in a format that is publicly 327 | documented (and with an implementation available to the public in 328 | source code form), and must require no special password or key for 329 | unpacking, reading or copying. 330 | 331 | 7. Additional Terms. 332 | 333 | "Additional permissions" are terms that supplement the terms of this 334 | License by making exceptions from one or more of its conditions. 335 | Additional permissions that are applicable to the entire Program shall 336 | be treated as though they were included in this License, to the extent 337 | that they are valid under applicable law. If additional permissions 338 | apply only to part of the Program, that part may be used separately 339 | under those permissions, but the entire Program remains governed by 340 | this License without regard to the additional permissions. 341 | 342 | When you convey a copy of a covered work, you may at your option 343 | remove any additional permissions from that copy, or from any part of 344 | it. (Additional permissions may be written to require their own 345 | removal in certain cases when you modify the work.) You may place 346 | additional permissions on material, added by you to a covered work, 347 | for which you have or can give appropriate copyright permission. 348 | 349 | Notwithstanding any other provision of this License, for material you 350 | add to a covered work, you may (if authorized by the copyright holders of 351 | that material) supplement the terms of this License with terms: 352 | 353 | a) Disclaiming warranty or limiting liability differently from the 354 | terms of sections 15 and 16 of this License; or 355 | 356 | b) Requiring preservation of specified reasonable legal notices or 357 | author attributions in that material or in the Appropriate Legal 358 | Notices displayed by works containing it; or 359 | 360 | c) Prohibiting misrepresentation of the origin of that material, or 361 | requiring that modified versions of such material be marked in 362 | reasonable ways as different from the original version; or 363 | 364 | d) Limiting the use for publicity purposes of names of licensors or 365 | authors of the material; or 366 | 367 | e) Declining to grant rights under trademark law for use of some 368 | trade names, trademarks, or service marks; or 369 | 370 | f) Requiring indemnification of licensors and authors of that 371 | material by anyone who conveys the material (or modified versions of 372 | it) with contractual assumptions of liability to the recipient, for 373 | any liability that these contractual assumptions directly impose on 374 | those licensors and authors. 375 | 376 | All other non-permissive additional terms are considered "further 377 | restrictions" within the meaning of section 10. If the Program as you 378 | received it, or any part of it, contains a notice stating that it is 379 | governed by this License along with a term that is a further 380 | restriction, you may remove that term. If a license document contains 381 | a further restriction but permits relicensing or conveying under this 382 | License, you may add to a covered work material governed by the terms 383 | of that license document, provided that the further restriction does 384 | not survive such relicensing or conveying. 385 | 386 | If you add terms to a covered work in accord with this section, you 387 | must place, in the relevant source files, a statement of the 388 | additional terms that apply to those files, or a notice indicating 389 | where to find the applicable terms. 390 | 391 | Additional terms, permissive or non-permissive, may be stated in the 392 | form of a separately written license, or stated as exceptions; 393 | the above requirements apply either way. 394 | 395 | 8. Termination. 396 | 397 | You may not propagate or modify a covered work except as expressly 398 | provided under this License. Any attempt otherwise to propagate or 399 | modify it is void, and will automatically terminate your rights under 400 | this License (including any patent licenses granted under the third 401 | paragraph of section 11). 402 | 403 | However, if you cease all violation of this License, then your 404 | license from a particular copyright holder is reinstated (a) 405 | provisionally, unless and until the copyright holder explicitly and 406 | finally terminates your license, and (b) permanently, if the copyright 407 | holder fails to notify you of the violation by some reasonable means 408 | prior to 60 days after the cessation. 409 | 410 | Moreover, your license from a particular copyright holder is 411 | reinstated permanently if the copyright holder notifies you of the 412 | violation by some reasonable means, this is the first time you have 413 | received notice of violation of this License (for any work) from that 414 | copyright holder, and you cure the violation prior to 30 days after 415 | your receipt of the notice. 416 | 417 | Termination of your rights under this section does not terminate the 418 | licenses of parties who have received copies or rights from you under 419 | this License. If your rights have been terminated and not permanently 420 | reinstated, you do not qualify to receive new licenses for the same 421 | material under section 10. 422 | 423 | 9. Acceptance Not Required for Having Copies. 424 | 425 | You are not required to accept this License in order to receive or 426 | run a copy of the Program. Ancillary propagation of a covered work 427 | occurring solely as a consequence of using peer-to-peer transmission 428 | to receive a copy likewise does not require acceptance. However, 429 | nothing other than this License grants you permission to propagate or 430 | modify any covered work. These actions infringe copyright if you do 431 | not accept this License. Therefore, by modifying or propagating a 432 | covered work, you indicate your acceptance of this License to do so. 433 | 434 | 10. Automatic Licensing of Downstream Recipients. 435 | 436 | Each time you convey a covered work, the recipient automatically 437 | receives a license from the original licensors, to run, modify and 438 | propagate that work, subject to this License. You are not responsible 439 | for enforcing compliance by third parties with this License. 440 | 441 | An "entity transaction" is a transaction transferring control of an 442 | organization, or substantially all assets of one, or subdividing an 443 | organization, or merging organizations. If propagation of a covered 444 | work results from an entity transaction, each party to that 445 | transaction who receives a copy of the work also receives whatever 446 | licenses to the work the party's predecessor in interest had or could 447 | give under the previous paragraph, plus a right to possession of the 448 | Corresponding Source of the work from the predecessor in interest, if 449 | the predecessor has it or can get it with reasonable efforts. 450 | 451 | You may not impose any further restrictions on the exercise of the 452 | rights granted or affirmed under this License. For example, you may 453 | not impose a license fee, royalty, or other charge for exercise of 454 | rights granted under this License, and you may not initiate litigation 455 | (including a cross-claim or counterclaim in a lawsuit) alleging that 456 | any patent claim is infringed by making, using, selling, offering for 457 | sale, or importing the Program or any portion of it. 458 | 459 | 11. Patents. 460 | 461 | A "contributor" is a copyright holder who authorizes use under this 462 | License of the Program or a work on which the Program is based. The 463 | work thus licensed is called the contributor's "contributor version". 464 | 465 | A contributor's "essential patent claims" are all patent claims 466 | owned or controlled by the contributor, whether already acquired or 467 | hereafter acquired, that would be infringed by some manner, permitted 468 | by this License, of making, using, or selling its contributor version, 469 | but do not include claims that would be infringed only as a 470 | consequence of further modification of the contributor version. For 471 | purposes of this definition, "control" includes the right to grant 472 | patent sublicenses in a manner consistent with the requirements of 473 | this License. 474 | 475 | Each contributor grants you a non-exclusive, worldwide, royalty-free 476 | patent license under the contributor's essential patent claims, to 477 | make, use, sell, offer for sale, import and otherwise run, modify and 478 | propagate the contents of its contributor version. 479 | 480 | In the following three paragraphs, a "patent license" is any express 481 | agreement or commitment, however denominated, not to enforce a patent 482 | (such as an express permission to practice a patent or covenant not to 483 | sue for patent infringement). To "grant" such a patent license to a 484 | party means to make such an agreement or commitment not to enforce a 485 | patent against the party. 486 | 487 | If you convey a covered work, knowingly relying on a patent license, 488 | and the Corresponding Source of the work is not available for anyone 489 | to copy, free of charge and under the terms of this License, through a 490 | publicly available network server or other readily accessible means, 491 | then you must either (1) cause the Corresponding Source to be so 492 | available, or (2) arrange to deprive yourself of the benefit of the 493 | patent license for this particular work, or (3) arrange, in a manner 494 | consistent with the requirements of this License, to extend the patent 495 | license to downstream recipients. "Knowingly relying" means you have 496 | actual knowledge that, but for the patent license, your conveying the 497 | covered work in a country, or your recipient's use of the covered work 498 | in a country, would infringe one or more identifiable patents in that 499 | country that you have reason to believe are valid. 500 | 501 | If, pursuant to or in connection with a single transaction or 502 | arrangement, you convey, or propagate by procuring conveyance of, a 503 | covered work, and grant a patent license to some of the parties 504 | receiving the covered work authorizing them to use, propagate, modify 505 | or convey a specific copy of the covered work, then the patent license 506 | you grant is automatically extended to all recipients of the covered 507 | work and works based on it. 508 | 509 | A patent license is "discriminatory" if it does not include within 510 | the scope of its coverage, prohibits the exercise of, or is 511 | conditioned on the non-exercise of one or more of the rights that are 512 | specifically granted under this License. You may not convey a covered 513 | work if you are a party to an arrangement with a third party that is 514 | in the business of distributing software, under which you make payment 515 | to the third party based on the extent of your activity of conveying 516 | the work, and under which the third party grants, to any of the 517 | parties who would receive the covered work from you, a discriminatory 518 | patent license (a) in connection with copies of the covered work 519 | conveyed by you (or copies made from those copies), or (b) primarily 520 | for and in connection with specific products or compilations that 521 | contain the covered work, unless you entered into that arrangement, 522 | or that patent license was granted, prior to 28 March 2007. 523 | 524 | Nothing in this License shall be construed as excluding or limiting 525 | any implied license or other defenses to infringement that may 526 | otherwise be available to you under applicable patent law. 527 | 528 | 12. No Surrender of Others' Freedom. 529 | 530 | If conditions are imposed on you (whether by court order, agreement or 531 | otherwise) that contradict the conditions of this License, they do not 532 | excuse you from the conditions of this License. If you cannot convey a 533 | covered work so as to satisfy simultaneously your obligations under this 534 | License and any other pertinent obligations, then as a consequence you may 535 | not convey it at all. For example, if you agree to terms that obligate you 536 | to collect a royalty for further conveying from those to whom you convey 537 | the Program, the only way you could satisfy both those terms and this 538 | License would be to refrain entirely from conveying the Program. 539 | 540 | 13. Remote Network Interaction; Use with the GNU General Public License. 541 | 542 | Notwithstanding any other provision of this License, if you modify the 543 | Program, your modified version must prominently offer all users 544 | interacting with it remotely through a computer network (if your version 545 | supports such interaction) an opportunity to receive the Corresponding 546 | Source of your version by providing access to the Corresponding Source 547 | from a network server at no charge, through some standard or customary 548 | means of facilitating copying of software. This Corresponding Source 549 | shall include the Corresponding Source for any work covered by version 3 550 | of the GNU General Public License that is incorporated pursuant to the 551 | following paragraph. 552 | 553 | Notwithstanding any other provision of this License, you have 554 | permission to link or combine any covered work with a work licensed 555 | under version 3 of the GNU General Public License into a single 556 | combined work, and to convey the resulting work. The terms of this 557 | License will continue to apply to the part which is the covered work, 558 | but the work with which it is combined will remain governed by version 559 | 3 of the GNU General Public License. 560 | 561 | 14. Revised Versions of this License. 562 | 563 | The Free Software Foundation may publish revised and/or new versions of 564 | the GNU Affero General Public License from time to time. Such new versions 565 | will be similar in spirit to the present version, but may differ in detail to 566 | address new problems or concerns. 567 | 568 | Each version is given a distinguishing version number. If the 569 | Program specifies that a certain numbered version of the GNU Affero General 570 | Public License "or any later version" applies to it, you have the 571 | option of following the terms and conditions either of that numbered 572 | version or of any later version published by the Free Software 573 | Foundation. If the Program does not specify a version number of the 574 | GNU Affero General Public License, you may choose any version ever published 575 | by the Free Software Foundation. 576 | 577 | If the Program specifies that a proxy can decide which future 578 | versions of the GNU Affero General Public License can be used, that proxy's 579 | public statement of acceptance of a version permanently authorizes you 580 | to choose that version for the Program. 581 | 582 | Later license versions may give you additional or different 583 | permissions. However, no additional obligations are imposed on any 584 | author or copyright holder as a result of your choosing to follow a 585 | later version. 586 | 587 | 15. Disclaimer of Warranty. 588 | 589 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 590 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 591 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 592 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 593 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 594 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 595 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 596 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 597 | 598 | 16. Limitation of Liability. 599 | 600 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 601 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 602 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 603 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 604 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 605 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 606 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 607 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 608 | SUCH DAMAGES. 609 | 610 | 17. Interpretation of Sections 15 and 16. 611 | 612 | If the disclaimer of warranty and limitation of liability provided 613 | above cannot be given local legal effect according to their terms, 614 | reviewing courts shall apply local law that most closely approximates 615 | an absolute waiver of all civil liability in connection with the 616 | Program, unless a warranty or assumption of liability accompanies a 617 | copy of the Program in return for a fee. 618 | 619 | END OF TERMS AND CONDITIONS 620 | 621 | How to Apply These Terms to Your New Programs 622 | 623 | If you develop a new program, and you want it to be of the greatest 624 | possible use to the public, the best way to achieve this is to make it 625 | free software which everyone can redistribute and change under these terms. 626 | 627 | To do so, attach the following notices to the program. It is safest 628 | to attach them to the start of each source file to most effectively 629 | state the exclusion of warranty; and each file should have at least 630 | the "copyright" line and a pointer to where the full notice is found. 631 | 632 | 633 | Copyright (C) 634 | 635 | This program is free software: you can redistribute it and/or modify 636 | it under the terms of the GNU Affero General Public License as published by 637 | the Free Software Foundation, either version 3 of the License, or 638 | (at your option) any later version. 639 | 640 | This program is distributed in the hope that it will be useful, 641 | but WITHOUT ANY WARRANTY; without even the implied warranty of 642 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 643 | GNU Affero General Public License for more details. 644 | 645 | You should have received a copy of the GNU Affero General Public License 646 | along with this program. If not, see . 647 | 648 | Also add information on how to contact you by electronic and paper mail. 649 | 650 | If your software can interact with users remotely through a computer 651 | network, you should also make sure that it provides a way for users to 652 | get its source. For example, if your program is a web application, its 653 | interface could display a "Source" link that leads users to an archive 654 | of the code. There are many ways you could offer source, and different 655 | solutions will be better for different programs; see section 13 for the 656 | specific requirements. 657 | 658 | You should also get your employer (if you work as a programmer) or school, 659 | if any, to sign a "copyright disclaimer" for the program, if necessary. 660 | For more information on this, and how to apply and follow the GNU AGPL, see 661 | . 662 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: clean 2 | 3 | scheme: scheme.c 4 | cc -Wall -ansi -o scheme scheme.c 5 | 6 | clean: 7 | rm scheme 8 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Bootstrap Scheme is a quick and very dirty Scheme interpreter. Its *only* intended use is to compile a self-compiling Scheme-to-Assembly or Scheme-to-C compiler the first time. 2 | 3 | Bootstrap Scheme doesn't have many features a Scheme system usually has. It doesn't have numbers other than integers. It doesn't have vectors. It definitely doesn't have a module system, call/cc, macros, dynamic-wind or any other advanced Scheme features. 4 | 5 | Bootstrap Scheme is slow. The implementation is an abstract syntax tree node walker with no optimizations. There is no point in making a node walking interpreter any better than the absolute base necessity as the fundamental design of a node walker would never be used in production. Small, easy to read source code is far more important than anything else. 6 | 7 | Bootstrap Scheme revels in the opportunity to be very dirty Scheme. 8 | 9 | ---- 10 | 11 | Example build and use. 12 | 13 | $ cd bootstrap 14 | $ make 15 | cc -Wall -ansi -o scheme scheme.c 16 | $ ./scheme 17 | Welcome to your Scheme REPL. Use ctrl-c to exit. 18 | > #t 19 | #t 20 | > -123 21 | -123 22 | > #\c 23 | #\c 24 | > "adsf" 25 | "asdf" 26 | > (quote ()) 27 | () 28 | > (quote (0 . 1)) 29 | (0 . 1) 30 | > (quote (0 1 2 3)) 31 | (0 1 2 3) 32 | > (quote asdf) 33 | asdf 34 | > (define a 1) 35 | ok 36 | > a 37 | 1 38 | > (set! a 2) 39 | ok 40 | > a 41 | 2 42 | > (if #t 1 2) 43 | 1 44 | > (+ 1 2 3) 45 | 6 46 | > + 47 | # 48 | > ((lamba (x) x) 1) 49 | 1 50 | > (define (add x y) (+ x y)) 51 | ok 52 | > (add 1 2) 53 | 3 54 | > add 55 | # 56 | > (define c ((lambda (x) (lambda () x)) 3)) 57 | ok 58 | > (c) 59 | 3 60 | > (begin 1 2) 61 | 2 62 | > (cond (#f 1) 63 | ((eq? #t #t) 2) 64 | (else 3)) 65 | 2 66 | > (let ((x (+ 1 1)) 67 | (y (- 5 2))) 68 | (+ x y)) 69 | 5 70 | > (and 1 2 #f 3) 71 | #f 72 | > (or #f #f 3 #f) 73 | 3 74 | > (apply + '(1 2 3)) 75 | 6 76 | > (define env (environment)) 77 | ok 78 | > (eval '(define z 25) env) 79 | ok 80 | > (eval 'z env) 81 | 25 82 | > (define out (open-output-port "asdf.txt")) 83 | ok 84 | > (write-car #\c out) 85 | ok 86 | > (close-output-port out) 87 | ok 88 | > (load "program.scm") 89 | program-loaded 90 | > (error "bad move") 91 | "bad move" 92 | exiting 93 | $ 94 | 95 | ---- 96 | 97 | For more information see: 98 | 99 | http://peter.michaux.ca/articles/scheme-from-scratch-introduction 100 | 101 | ---- 102 | 103 | See the LICENSE file for legal information. 104 | -------------------------------------------------------------------------------- /scheme.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Bootstrap Scheme - a quick and very dirty Scheme interpreter. 3 | * Copyright (C) 2010 Peter Michaux (http://peter.michaux.ca/) 4 | * 5 | * This program is free software: you can redistribute it and/or 6 | * modify it under the terms of the GNU Affero General Public 7 | * License version 3 as published by the Free Software Foundation. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Affero General Public License version 3 for more details. 13 | * 14 | * You should have received a copy of the GNU Affero General Public 15 | * License version 3 along with this program. If not, see 16 | * . 17 | */ 18 | 19 | #include 20 | #include 21 | #include 22 | #include 23 | 24 | /**************************** MODEL ******************************/ 25 | 26 | typedef enum {THE_EMPTY_LIST, BOOLEAN, SYMBOL, FIXNUM, 27 | CHARACTER, STRING, PAIR, PRIMITIVE_PROC, 28 | COMPOUND_PROC, INPUT_PORT, OUTPUT_PORT, 29 | EOF_OBJECT} object_type; 30 | 31 | typedef struct object { 32 | object_type type; 33 | union { 34 | struct { 35 | char value; 36 | } boolean; 37 | struct { 38 | char *value; 39 | } symbol; 40 | struct { 41 | long value; 42 | } fixnum; 43 | struct { 44 | char value; 45 | } character; 46 | struct { 47 | char *value; 48 | } string; 49 | struct { 50 | struct object *car; 51 | struct object *cdr; 52 | } pair; 53 | struct { 54 | struct object *(*fn)(struct object *arguments); 55 | } primitive_proc; 56 | struct { 57 | struct object *parameters; 58 | struct object *body; 59 | struct object *env; 60 | } compound_proc; 61 | struct { 62 | FILE *stream; 63 | } input_port; 64 | struct { 65 | FILE *stream; 66 | } output_port; 67 | } data; 68 | } object; 69 | 70 | /* no GC so truely "unlimited extent" */ 71 | object *alloc_object(void) { 72 | object *obj; 73 | 74 | obj = malloc(sizeof(object)); 75 | if (obj == NULL) { 76 | fprintf(stderr, "out of memory\n"); 77 | exit(1); 78 | } 79 | return obj; 80 | } 81 | 82 | object *the_empty_list; 83 | object *false; 84 | object *true; 85 | object *symbol_table; 86 | object *quote_symbol; 87 | object *define_symbol; 88 | object *set_symbol; 89 | object *ok_symbol; 90 | object *if_symbol; 91 | object *lambda_symbol; 92 | object *begin_symbol; 93 | object *cond_symbol; 94 | object *else_symbol; 95 | object *let_symbol; 96 | object *and_symbol; 97 | object *or_symbol; 98 | object *eof_object; 99 | object *the_empty_environment; 100 | object *the_global_environment; 101 | 102 | object *cons(object *car, object *cdr); 103 | object *car(object *pair); 104 | object *cdr(object *pair); 105 | 106 | char is_the_empty_list(object *obj) { 107 | return obj == the_empty_list; 108 | } 109 | 110 | char is_boolean(object *obj) { 111 | return obj->type == BOOLEAN; 112 | } 113 | 114 | char is_false(object *obj) { 115 | return obj == false; 116 | } 117 | 118 | char is_true(object *obj) { 119 | return !is_false(obj); 120 | } 121 | 122 | object *make_symbol(char *value) { 123 | object *obj; 124 | object *element; 125 | 126 | /* search for they symbol in the symbol table */ 127 | element = symbol_table; 128 | while (!is_the_empty_list(element)) { 129 | if (strcmp(car(element)->data.symbol.value, value) == 0) { 130 | return car(element); 131 | } 132 | element = cdr(element); 133 | }; 134 | 135 | /* create the symbol and add it to the symbol table */ 136 | obj = alloc_object(); 137 | obj->type = SYMBOL; 138 | obj->data.symbol.value = malloc(strlen(value) + 1); 139 | if (obj->data.symbol.value == NULL) { 140 | fprintf(stderr, "out of memory\n"); 141 | exit(1); 142 | } 143 | strcpy(obj->data.symbol.value, value); 144 | symbol_table = cons(obj, symbol_table); 145 | return obj; 146 | } 147 | 148 | char is_symbol(object *obj) { 149 | return obj->type == SYMBOL; 150 | } 151 | 152 | object *make_fixnum(long value) { 153 | object *obj; 154 | 155 | obj = alloc_object(); 156 | obj->type = FIXNUM; 157 | obj->data.fixnum.value = value; 158 | return obj; 159 | } 160 | 161 | char is_fixnum(object *obj) { 162 | return obj->type == FIXNUM; 163 | } 164 | 165 | object *make_character(char value) { 166 | object *obj; 167 | 168 | obj = alloc_object(); 169 | obj->type = CHARACTER; 170 | obj->data.character.value = value; 171 | return obj; 172 | } 173 | 174 | char is_character(object *obj) { 175 | return obj->type == CHARACTER; 176 | } 177 | 178 | object *make_string(char *value) { 179 | object *obj; 180 | 181 | obj = alloc_object(); 182 | obj->type = STRING; 183 | obj->data.string.value = malloc(strlen(value) + 1); 184 | if (obj->data.string.value == NULL) { 185 | fprintf(stderr, "out of memory\n"); 186 | exit(1); 187 | } 188 | strcpy(obj->data.string.value, value); 189 | return obj; 190 | } 191 | 192 | char is_string(object *obj) { 193 | return obj->type == STRING; 194 | } 195 | 196 | object *cons(object *car, object *cdr) { 197 | object *obj; 198 | 199 | obj = alloc_object(); 200 | obj->type = PAIR; 201 | obj->data.pair.car = car; 202 | obj->data.pair.cdr = cdr; 203 | return obj; 204 | } 205 | 206 | char is_pair(object *obj) { 207 | return obj->type == PAIR; 208 | } 209 | 210 | object *car(object *pair) { 211 | return pair->data.pair.car; 212 | } 213 | 214 | void set_car(object *obj, object* value) { 215 | obj->data.pair.car = value; 216 | } 217 | 218 | object *cdr(object *pair) { 219 | return pair->data.pair.cdr; 220 | } 221 | 222 | void set_cdr(object *obj, object* value) { 223 | obj->data.pair.cdr = value; 224 | } 225 | 226 | #define caar(obj) car(car(obj)) 227 | #define cadr(obj) car(cdr(obj)) 228 | #define cdar(obj) cdr(car(obj)) 229 | #define cddr(obj) cdr(cdr(obj)) 230 | #define caaar(obj) car(car(car(obj))) 231 | #define caadr(obj) car(car(cdr(obj))) 232 | #define cadar(obj) car(cdr(car(obj))) 233 | #define caddr(obj) car(cdr(cdr(obj))) 234 | #define cdaar(obj) cdr(car(car(obj))) 235 | #define cdadr(obj) cdr(car(cdr(obj))) 236 | #define cddar(obj) cdr(cdr(car(obj))) 237 | #define cdddr(obj) cdr(cdr(cdr(obj))) 238 | #define caaaar(obj) car(car(car(car(obj)))) 239 | #define caaadr(obj) car(car(car(cdr(obj)))) 240 | #define caadar(obj) car(car(cdr(car(obj)))) 241 | #define caaddr(obj) car(car(cdr(cdr(obj)))) 242 | #define cadaar(obj) car(cdr(car(car(obj)))) 243 | #define cadadr(obj) car(cdr(car(cdr(obj)))) 244 | #define caddar(obj) car(cdr(cdr(car(obj)))) 245 | #define cadddr(obj) car(cdr(cdr(cdr(obj)))) 246 | #define cdaaar(obj) cdr(car(car(car(obj)))) 247 | #define cdaadr(obj) cdr(car(car(cdr(obj)))) 248 | #define cdadar(obj) cdr(car(cdr(car(obj)))) 249 | #define cdaddr(obj) cdr(car(cdr(cdr(obj)))) 250 | #define cddaar(obj) cdr(cdr(car(car(obj)))) 251 | #define cddadr(obj) cdr(cdr(car(cdr(obj)))) 252 | #define cdddar(obj) cdr(cdr(cdr(car(obj)))) 253 | #define cddddr(obj) cdr(cdr(cdr(cdr(obj)))) 254 | 255 | object *make_primitive_proc( 256 | object *(*fn)(struct object *arguments)) { 257 | object *obj; 258 | 259 | obj = alloc_object(); 260 | obj->type = PRIMITIVE_PROC; 261 | obj->data.primitive_proc.fn = fn; 262 | return obj; 263 | } 264 | 265 | char is_primitive_proc(object *obj) { 266 | return obj->type == PRIMITIVE_PROC; 267 | } 268 | 269 | object *is_null_proc(object *arguments) { 270 | return is_the_empty_list(car(arguments)) ? true : false; 271 | } 272 | 273 | object *is_boolean_proc(object *arguments) { 274 | return is_boolean(car(arguments)) ? true : false; 275 | } 276 | 277 | object *is_symbol_proc(object *arguments) { 278 | return is_symbol(car(arguments)) ? true : false; 279 | } 280 | 281 | object *is_integer_proc(object *arguments) { 282 | return is_fixnum(car(arguments)) ? true : false; 283 | } 284 | 285 | object *is_char_proc(object *arguments) { 286 | return is_character(car(arguments)) ? true : false; 287 | } 288 | 289 | object *is_string_proc(object *arguments) { 290 | return is_string(car(arguments)) ? true : false; 291 | } 292 | 293 | object *is_pair_proc(object *arguments) { 294 | return is_pair(car(arguments)) ? true : false; 295 | } 296 | 297 | char is_compound_proc(object *obj); 298 | 299 | object *is_procedure_proc(object *arguments) { 300 | object *obj; 301 | 302 | obj = car(arguments); 303 | return (is_primitive_proc(obj) || 304 | is_compound_proc(obj)) ? 305 | true : 306 | false; 307 | } 308 | 309 | object *char_to_integer_proc(object *arguments) { 310 | return make_fixnum((car(arguments))->data.character.value); 311 | } 312 | 313 | object *integer_to_char_proc(object *arguments) { 314 | return make_character((car(arguments))->data.fixnum.value); 315 | } 316 | 317 | object *number_to_string_proc(object *arguments) { 318 | char buffer[100]; 319 | 320 | sprintf(buffer, "%ld", (car(arguments))->data.fixnum.value); 321 | return make_string(buffer); 322 | } 323 | 324 | object *string_to_number_proc(object *arguments) { 325 | return make_fixnum(atoi((car(arguments))->data.string.value)); 326 | } 327 | 328 | object *symbol_to_string_proc(object *arguments) { 329 | return make_string((car(arguments))->data.symbol.value); 330 | } 331 | 332 | object *string_to_symbol_proc(object *arguments) { 333 | return make_symbol((car(arguments))->data.string.value); 334 | } 335 | 336 | object *add_proc(object *arguments) { 337 | long result = 0; 338 | 339 | while (!is_the_empty_list(arguments)) { 340 | result += (car(arguments))->data.fixnum.value; 341 | arguments = cdr(arguments); 342 | } 343 | return make_fixnum(result); 344 | } 345 | 346 | object *sub_proc(object *arguments) { 347 | long result; 348 | 349 | result = (car(arguments))->data.fixnum.value; 350 | while (!is_the_empty_list(arguments = cdr(arguments))) { 351 | result -= (car(arguments))->data.fixnum.value; 352 | } 353 | return make_fixnum(result); 354 | } 355 | 356 | object *mul_proc(object *arguments) { 357 | long result = 1; 358 | 359 | while (!is_the_empty_list(arguments)) { 360 | result *= (car(arguments))->data.fixnum.value; 361 | arguments = cdr(arguments); 362 | } 363 | return make_fixnum(result); 364 | } 365 | 366 | object *quotient_proc(object *arguments) { 367 | return make_fixnum( 368 | ((car(arguments) )->data.fixnum.value)/ 369 | ((cadr(arguments))->data.fixnum.value)); 370 | } 371 | 372 | object *remainder_proc(object *arguments) { 373 | return make_fixnum( 374 | ((car(arguments) )->data.fixnum.value)% 375 | ((cadr(arguments))->data.fixnum.value)); 376 | } 377 | 378 | object *is_number_equal_proc(object *arguments) { 379 | long value; 380 | 381 | value = (car(arguments))->data.fixnum.value; 382 | while (!is_the_empty_list(arguments = cdr(arguments))) { 383 | if (value != ((car(arguments))->data.fixnum.value)) { 384 | return false; 385 | } 386 | } 387 | return true; 388 | } 389 | 390 | object *is_less_than_proc(object *arguments) { 391 | long previous; 392 | long next; 393 | 394 | previous = (car(arguments))->data.fixnum.value; 395 | while (!is_the_empty_list(arguments = cdr(arguments))) { 396 | next = (car(arguments))->data.fixnum.value; 397 | if (previous < next) { 398 | previous = next; 399 | } 400 | else { 401 | return false; 402 | } 403 | } 404 | return true; 405 | } 406 | 407 | object *is_greater_than_proc(object *arguments) { 408 | long previous; 409 | long next; 410 | 411 | previous = (car(arguments))->data.fixnum.value; 412 | while (!is_the_empty_list(arguments = cdr(arguments))) { 413 | next = (car(arguments))->data.fixnum.value; 414 | if (previous > next) { 415 | previous = next; 416 | } 417 | else { 418 | return false; 419 | } 420 | } 421 | return true; 422 | } 423 | 424 | object *cons_proc(object *arguments) { 425 | return cons(car(arguments), cadr(arguments)); 426 | } 427 | 428 | object *car_proc(object *arguments) { 429 | return caar(arguments); 430 | } 431 | 432 | object *cdr_proc(object *arguments) { 433 | return cdar(arguments); 434 | } 435 | 436 | object *set_car_proc(object *arguments) { 437 | set_car(car(arguments), cadr(arguments)); 438 | return ok_symbol; 439 | } 440 | 441 | object *set_cdr_proc(object *arguments) { 442 | set_cdr(car(arguments), cadr(arguments)); 443 | return ok_symbol; 444 | } 445 | 446 | object *list_proc(object *arguments) { 447 | return arguments; 448 | } 449 | 450 | object *is_eq_proc(object *arguments) { 451 | object *obj1; 452 | object *obj2; 453 | 454 | obj1 = car(arguments); 455 | obj2 = cadr(arguments); 456 | 457 | if (obj1->type != obj2->type) { 458 | return false; 459 | } 460 | switch (obj1->type) { 461 | case FIXNUM: 462 | return (obj1->data.fixnum.value == 463 | obj2->data.fixnum.value) ? 464 | true : false; 465 | break; 466 | case CHARACTER: 467 | return (obj1->data.character.value == 468 | obj2->data.character.value) ? 469 | true : false; 470 | break; 471 | case STRING: 472 | return (strcmp(obj1->data.string.value, 473 | obj2->data.string.value) == 0) ? 474 | true : false; 475 | break; 476 | default: 477 | return (obj1 == obj2) ? true : false; 478 | } 479 | } 480 | 481 | object *apply_proc(object *arguments) { 482 | fprintf(stderr, "illegal state: The body of the apply " 483 | "primitive procedure should not execute.\n"); 484 | exit(1); 485 | } 486 | 487 | object *interaction_environment_proc(object *arguments) { 488 | return the_global_environment; 489 | } 490 | 491 | object *setup_environment(void); 492 | 493 | object *null_environment_proc(object *arguments) { 494 | return setup_environment(); 495 | } 496 | 497 | object *make_environment(void); 498 | 499 | object *environment_proc(object *arguments) { 500 | return make_environment(); 501 | } 502 | 503 | object *eval_proc(object *arguments) { 504 | fprintf(stderr, "illegal state: The body of the eval " 505 | "primitive procedure should not execute.\n"); 506 | exit(1); 507 | } 508 | 509 | object *read(FILE *in); 510 | object *eval(object *exp, object *env); 511 | 512 | object *load_proc(object *arguments) { 513 | char *filename; 514 | FILE *in; 515 | object *exp; 516 | object *result; 517 | 518 | filename = car(arguments)->data.string.value; 519 | in = fopen(filename, "r"); 520 | if (in == NULL) { 521 | fprintf(stderr, "could not load file \"%s\"", filename); 522 | exit(1); 523 | } 524 | while ((exp = read(in)) != NULL) { 525 | result = eval(exp, the_global_environment); 526 | } 527 | fclose(in); 528 | return result; 529 | } 530 | 531 | object *make_input_port(FILE *in); 532 | 533 | object *open_input_port_proc(object *arguments) { 534 | char *filename; 535 | FILE *in; 536 | 537 | filename = car(arguments)->data.string.value; 538 | in = fopen(filename, "r"); 539 | if (in == NULL) { 540 | fprintf(stderr, "could not open file \"%s\"\n", filename); 541 | exit(1); 542 | } 543 | return make_input_port(in); 544 | } 545 | 546 | object *close_input_port_proc(object *arguments) { 547 | int result; 548 | 549 | result = fclose(car(arguments)->data.input_port.stream); 550 | if (result == EOF) { 551 | fprintf(stderr, "could not close input port\n"); 552 | exit(1); 553 | } 554 | return ok_symbol; 555 | } 556 | 557 | char is_input_port(object *obj); 558 | 559 | object *is_input_port_proc(object *arguments) { 560 | return is_input_port(car(arguments)) ? true : false; 561 | } 562 | 563 | object *read_proc(object *arguments) { 564 | FILE *in; 565 | object *result; 566 | 567 | in = is_the_empty_list(arguments) ? 568 | stdin : 569 | car(arguments)->data.input_port.stream; 570 | result = read(in); 571 | return (result == NULL) ? eof_object : result; 572 | } 573 | 574 | object *read_char_proc(object *arguments) { 575 | FILE *in; 576 | int result; 577 | 578 | in = is_the_empty_list(arguments) ? 579 | stdin : 580 | car(arguments)->data.input_port.stream; 581 | result = getc(in); 582 | return (result == EOF) ? eof_object : make_character(result); 583 | } 584 | 585 | int peek(FILE *in); 586 | 587 | object *peek_char_proc(object *arguments) { 588 | FILE *in; 589 | int result; 590 | 591 | in = is_the_empty_list(arguments) ? 592 | stdin : 593 | car(arguments)->data.input_port.stream; 594 | result = peek(in); 595 | return (result == EOF) ? eof_object : make_character(result); 596 | } 597 | 598 | char is_eof_object(object *obj); 599 | 600 | object *is_eof_object_proc(object *arguments) { 601 | return is_eof_object(car(arguments)) ? true : false; 602 | } 603 | 604 | object *make_output_port(FILE *in); 605 | 606 | object *open_output_port_proc(object *arguments) { 607 | char *filename; 608 | FILE *out; 609 | 610 | filename = car(arguments)->data.string.value; 611 | out = fopen(filename, "w"); 612 | if (out == NULL) { 613 | fprintf(stderr, "could not open file \"%s\"\n", filename); 614 | exit(1); 615 | } 616 | return make_output_port(out); 617 | } 618 | 619 | object *close_output_port_proc(object *arguments) { 620 | int result; 621 | 622 | result = fclose(car(arguments)->data.output_port.stream); 623 | if (result == EOF) { 624 | fprintf(stderr, "could not close output port\n"); 625 | exit(1); 626 | } 627 | return ok_symbol; 628 | } 629 | 630 | char is_output_port(object *obj); 631 | 632 | object *is_output_port_proc(object *arguments) { 633 | return is_output_port(car(arguments)) ? true : false; 634 | } 635 | 636 | object *write_char_proc(object *arguments) { 637 | object *character; 638 | FILE *out; 639 | 640 | character = car(arguments); 641 | arguments = cdr(arguments); 642 | out = is_the_empty_list(arguments) ? 643 | stdout : 644 | car(arguments)->data.output_port.stream; 645 | putc(character->data.character.value, out); 646 | fflush(out); 647 | return ok_symbol; 648 | } 649 | 650 | void write(FILE *out, object *obj); 651 | 652 | object *write_proc(object *arguments) { 653 | object *exp; 654 | FILE *out; 655 | 656 | exp = car(arguments); 657 | arguments = cdr(arguments); 658 | out = is_the_empty_list(arguments) ? 659 | stdout : 660 | car(arguments)->data.output_port.stream; 661 | write(out, exp); 662 | fflush(out); 663 | return ok_symbol; 664 | } 665 | 666 | object *error_proc(object *arguments) { 667 | while (!is_the_empty_list(arguments)) { 668 | write(stderr, car(arguments)); 669 | fprintf(stderr, " "); 670 | arguments = cdr(arguments); 671 | }; 672 | printf("\nexiting\n"); 673 | exit(1); 674 | } 675 | 676 | object *make_compound_proc(object *parameters, object *body, 677 | object* env) { 678 | object *obj; 679 | 680 | obj = alloc_object(); 681 | obj->type = COMPOUND_PROC; 682 | obj->data.compound_proc.parameters = parameters; 683 | obj->data.compound_proc.body = body; 684 | obj->data.compound_proc.env = env; 685 | return obj; 686 | } 687 | 688 | char is_compound_proc(object *obj) { 689 | return obj->type == COMPOUND_PROC; 690 | } 691 | 692 | object *make_input_port(FILE *stream) { 693 | object *obj; 694 | 695 | obj = alloc_object(); 696 | obj->type = INPUT_PORT; 697 | obj->data.input_port.stream = stream; 698 | return obj; 699 | } 700 | 701 | char is_input_port(object *obj) { 702 | return obj->type == INPUT_PORT; 703 | } 704 | 705 | object *make_output_port(FILE *stream) { 706 | object *obj; 707 | 708 | obj = alloc_object(); 709 | obj->type = OUTPUT_PORT; 710 | obj->data.output_port.stream = stream; 711 | return obj; 712 | } 713 | 714 | char is_output_port(object *obj) { 715 | return obj->type == OUTPUT_PORT; 716 | } 717 | 718 | char is_eof_object(object *obj) { 719 | return obj == eof_object; 720 | } 721 | 722 | object *enclosing_environment(object *env) { 723 | return cdr(env); 724 | } 725 | 726 | object *first_frame(object *env) { 727 | return car(env); 728 | } 729 | 730 | object *make_frame(object *variables, object *values) { 731 | return cons(variables, values); 732 | } 733 | 734 | object *frame_variables(object *frame) { 735 | return car(frame); 736 | } 737 | 738 | object *frame_values(object *frame) { 739 | return cdr(frame); 740 | } 741 | 742 | void add_binding_to_frame(object *var, object *val, 743 | object *frame) { 744 | set_car(frame, cons(var, car(frame))); 745 | set_cdr(frame, cons(val, cdr(frame))); 746 | } 747 | 748 | object *extend_environment(object *vars, object *vals, 749 | object *base_env) { 750 | return cons(make_frame(vars, vals), base_env); 751 | } 752 | 753 | object *lookup_variable_value(object *var, object *env) { 754 | object *frame; 755 | object *vars; 756 | object *vals; 757 | while (!is_the_empty_list(env)) { 758 | frame = first_frame(env); 759 | vars = frame_variables(frame); 760 | vals = frame_values(frame); 761 | while (!is_the_empty_list(vars)) { 762 | if (var == car(vars)) { 763 | return car(vals); 764 | } 765 | vars = cdr(vars); 766 | vals = cdr(vals); 767 | } 768 | env = enclosing_environment(env); 769 | } 770 | fprintf(stderr, "unbound variable, %s\n", var->data.symbol.value); 771 | exit(1); 772 | } 773 | 774 | void set_variable_value(object *var, object *val, object *env) { 775 | object *frame; 776 | object *vars; 777 | object *vals; 778 | 779 | while (!is_the_empty_list(env)) { 780 | frame = first_frame(env); 781 | vars = frame_variables(frame); 782 | vals = frame_values(frame); 783 | while (!is_the_empty_list(vars)) { 784 | if (var == car(vars)) { 785 | set_car(vals, val); 786 | return; 787 | } 788 | vars = cdr(vars); 789 | vals = cdr(vals); 790 | } 791 | env = enclosing_environment(env); 792 | } 793 | fprintf(stderr, "unbound variable, %s\n", var->data.symbol.value); 794 | exit(1); 795 | } 796 | 797 | void define_variable(object *var, object *val, object *env) { 798 | object *frame; 799 | object *vars; 800 | object *vals; 801 | 802 | frame = first_frame(env); 803 | vars = frame_variables(frame); 804 | vals = frame_values(frame); 805 | 806 | while (!is_the_empty_list(vars)) { 807 | if (var == car(vars)) { 808 | set_car(vals, val); 809 | return; 810 | } 811 | vars = cdr(vars); 812 | vals = cdr(vals); 813 | } 814 | add_binding_to_frame(var, val, frame); 815 | } 816 | 817 | object *setup_environment(void) { 818 | object *initial_env; 819 | 820 | initial_env = extend_environment( 821 | the_empty_list, 822 | the_empty_list, 823 | the_empty_environment); 824 | return initial_env; 825 | } 826 | 827 | void populate_environment(object *env) { 828 | 829 | #define add_procedure(scheme_name, c_name) \ 830 | define_variable(make_symbol(scheme_name), \ 831 | make_primitive_proc(c_name), \ 832 | env); 833 | 834 | add_procedure("null?" , is_null_proc); 835 | add_procedure("boolean?" , is_boolean_proc); 836 | add_procedure("symbol?" , is_symbol_proc); 837 | add_procedure("integer?" , is_integer_proc); 838 | add_procedure("char?" , is_char_proc); 839 | add_procedure("string?" , is_string_proc); 840 | add_procedure("pair?" , is_pair_proc); 841 | add_procedure("procedure?" , is_procedure_proc); 842 | 843 | add_procedure("char->integer" , char_to_integer_proc); 844 | add_procedure("integer->char" , integer_to_char_proc); 845 | add_procedure("number->string", number_to_string_proc); 846 | add_procedure("string->number", string_to_number_proc); 847 | add_procedure("symbol->string", symbol_to_string_proc); 848 | add_procedure("string->symbol", string_to_symbol_proc); 849 | 850 | add_procedure("+" , add_proc); 851 | add_procedure("-" , sub_proc); 852 | add_procedure("*" , mul_proc); 853 | add_procedure("quotient" , quotient_proc); 854 | add_procedure("remainder", remainder_proc); 855 | add_procedure("=" , is_number_equal_proc); 856 | add_procedure("<" , is_less_than_proc); 857 | add_procedure(">" , is_greater_than_proc); 858 | 859 | add_procedure("cons" , cons_proc); 860 | add_procedure("car" , car_proc); 861 | add_procedure("cdr" , cdr_proc); 862 | add_procedure("set-car!", set_car_proc); 863 | add_procedure("set-cdr!", set_cdr_proc); 864 | add_procedure("list" , list_proc); 865 | 866 | add_procedure("eq?", is_eq_proc); 867 | 868 | add_procedure("apply", apply_proc); 869 | 870 | add_procedure("interaction-environment", 871 | interaction_environment_proc); 872 | add_procedure("null-environment", null_environment_proc); 873 | add_procedure("environment" , environment_proc); 874 | add_procedure("eval" , eval_proc); 875 | 876 | add_procedure("load" , load_proc); 877 | add_procedure("open-input-port" , open_input_port_proc); 878 | add_procedure("close-input-port" , close_input_port_proc); 879 | add_procedure("input-port?" , is_input_port_proc); 880 | add_procedure("read" , read_proc); 881 | add_procedure("read-char" , read_char_proc); 882 | add_procedure("peek-char" , peek_char_proc); 883 | add_procedure("eof-object?" , is_eof_object_proc); 884 | add_procedure("open-output-port" , open_output_port_proc); 885 | add_procedure("close-output-port", close_output_port_proc); 886 | add_procedure("output-port?" , is_output_port_proc); 887 | add_procedure("write-char" , write_char_proc); 888 | add_procedure("write" , write_proc); 889 | 890 | add_procedure("error", error_proc); 891 | } 892 | 893 | object *make_environment(void) { 894 | object *env; 895 | 896 | env = setup_environment(); 897 | populate_environment(env); 898 | return env; 899 | } 900 | 901 | void init(void) { 902 | the_empty_list = alloc_object(); 903 | the_empty_list->type = THE_EMPTY_LIST; 904 | 905 | false = alloc_object(); 906 | false->type = BOOLEAN; 907 | false->data.boolean.value = 0; 908 | 909 | true = alloc_object(); 910 | true->type = BOOLEAN; 911 | true->data.boolean.value = 1; 912 | 913 | symbol_table = the_empty_list; 914 | quote_symbol = make_symbol("quote"); 915 | define_symbol = make_symbol("define"); 916 | set_symbol = make_symbol("set!"); 917 | ok_symbol = make_symbol("ok"); 918 | if_symbol = make_symbol("if"); 919 | lambda_symbol = make_symbol("lambda"); 920 | begin_symbol = make_symbol("begin"); 921 | cond_symbol = make_symbol("cond"); 922 | else_symbol = make_symbol("else"); 923 | let_symbol = make_symbol("let"); 924 | and_symbol = make_symbol("and"); 925 | or_symbol = make_symbol("or"); 926 | 927 | eof_object = alloc_object(); 928 | eof_object->type = EOF_OBJECT; 929 | 930 | the_empty_environment = the_empty_list; 931 | 932 | the_global_environment = make_environment(); 933 | } 934 | 935 | /***************************** READ ******************************/ 936 | 937 | char is_delimiter(int c) { 938 | return isspace(c) || c == EOF || 939 | c == '(' || c == ')' || 940 | c == '"' || c == ';'; 941 | } 942 | 943 | char is_initial(int c) { 944 | return isalpha(c) || c == '*' || c == '/' || c == '>' || 945 | c == '<' || c == '=' || c == '?' || c == '!'; 946 | } 947 | 948 | int peek(FILE *in) { 949 | int c; 950 | 951 | c = getc(in); 952 | ungetc(c, in); 953 | return c; 954 | } 955 | 956 | void eat_whitespace(FILE *in) { 957 | int c; 958 | 959 | while ((c = getc(in)) != EOF) { 960 | if (isspace(c)) { 961 | continue; 962 | } 963 | else if (c == ';') { /* comments are whitespace also */ 964 | while (((c = getc(in)) != EOF) && (c != '\n')); 965 | continue; 966 | } 967 | ungetc(c, in); 968 | break; 969 | } 970 | } 971 | 972 | void eat_expected_string(FILE *in, char *str) { 973 | int c; 974 | 975 | while (*str != '\0') { 976 | c = getc(in); 977 | if (c != *str) { 978 | fprintf(stderr, "unexpected character '%c'\n", c); 979 | exit(1); 980 | } 981 | str++; 982 | } 983 | } 984 | 985 | void peek_expected_delimiter(FILE *in) { 986 | if (!is_delimiter(peek(in))) { 987 | fprintf(stderr, "character not followed by delimiter\n"); 988 | exit(1); 989 | } 990 | } 991 | 992 | object *read_character(FILE *in) { 993 | int c; 994 | 995 | c = getc(in); 996 | switch (c) { 997 | case EOF: 998 | fprintf(stderr, "incomplete character literal\n"); 999 | exit(1); 1000 | case 's': 1001 | if (peek(in) == 'p') { 1002 | eat_expected_string(in, "pace"); 1003 | peek_expected_delimiter(in); 1004 | return make_character(' '); 1005 | } 1006 | break; 1007 | case 'n': 1008 | if (peek(in) == 'e') { 1009 | eat_expected_string(in, "ewline"); 1010 | peek_expected_delimiter(in); 1011 | return make_character('\n'); 1012 | } 1013 | break; 1014 | } 1015 | peek_expected_delimiter(in); 1016 | return make_character(c); 1017 | } 1018 | 1019 | object *read_pair(FILE *in) { 1020 | int c; 1021 | object *car_obj; 1022 | object *cdr_obj; 1023 | 1024 | eat_whitespace(in); 1025 | 1026 | c = getc(in); 1027 | if (c == ')') { /* read the empty list */ 1028 | return the_empty_list; 1029 | } 1030 | ungetc(c, in); 1031 | 1032 | car_obj = read(in); 1033 | 1034 | eat_whitespace(in); 1035 | 1036 | c = getc(in); 1037 | if (c == '.') { /* read improper list */ 1038 | c = peek(in); 1039 | if (!is_delimiter(c)) { 1040 | fprintf(stderr, "dot not followed by delimiter\n"); 1041 | exit(1); 1042 | } 1043 | cdr_obj = read(in); 1044 | eat_whitespace(in); 1045 | c = getc(in); 1046 | if (c != ')') { 1047 | fprintf(stderr, 1048 | "where was the trailing right paren?\n"); 1049 | exit(1); 1050 | } 1051 | return cons(car_obj, cdr_obj); 1052 | } 1053 | else { /* read list */ 1054 | ungetc(c, in); 1055 | cdr_obj = read_pair(in); 1056 | return cons(car_obj, cdr_obj); 1057 | } 1058 | } 1059 | 1060 | object *read(FILE *in) { 1061 | int c; 1062 | short sign = 1; 1063 | int i; 1064 | long num = 0; 1065 | #define BUFFER_MAX 1000 1066 | char buffer[BUFFER_MAX]; 1067 | 1068 | eat_whitespace(in); 1069 | 1070 | c = getc(in); 1071 | 1072 | if (c == '#') { /* read a boolean or character */ 1073 | c = getc(in); 1074 | switch (c) { 1075 | case 't': 1076 | return true; 1077 | case 'f': 1078 | return false; 1079 | case '\\': 1080 | return read_character(in); 1081 | default: 1082 | fprintf(stderr, 1083 | "unknown boolean or character literal\n"); 1084 | exit(1); 1085 | } 1086 | } 1087 | else if (isdigit(c) || (c == '-' && (isdigit(peek(in))))) { 1088 | /* read a fixnum */ 1089 | if (c == '-') { 1090 | sign = -1; 1091 | } 1092 | else { 1093 | ungetc(c, in); 1094 | } 1095 | while (isdigit(c = getc(in))) { 1096 | num = (num * 10) + (c - '0'); 1097 | } 1098 | num *= sign; 1099 | if (is_delimiter(c)) { 1100 | ungetc(c, in); 1101 | return make_fixnum(num); 1102 | } 1103 | else { 1104 | fprintf(stderr, "number not followed by delimiter\n"); 1105 | exit(1); 1106 | } 1107 | } 1108 | else if (is_initial(c) || 1109 | ((c == '+' || c == '-') && 1110 | is_delimiter(peek(in)))) { /* read a symbol */ 1111 | i = 0; 1112 | while (is_initial(c) || isdigit(c) || 1113 | c == '+' || c == '-') { 1114 | /* subtract 1 to save space for '\0' terminator */ 1115 | if (i < BUFFER_MAX - 1) { 1116 | buffer[i++] = c; 1117 | } 1118 | else { 1119 | fprintf(stderr, "symbol too long. " 1120 | "Maximum length is %d\n", BUFFER_MAX); 1121 | exit(1); 1122 | } 1123 | c = getc(in); 1124 | } 1125 | if (is_delimiter(c)) { 1126 | buffer[i] = '\0'; 1127 | ungetc(c, in); 1128 | return make_symbol(buffer); 1129 | } 1130 | else { 1131 | fprintf(stderr, "symbol not followed by delimiter. " 1132 | "Found '%c'\n", c); 1133 | exit(1); 1134 | } 1135 | } 1136 | else if (c == '"') { /* read a string */ 1137 | i = 0; 1138 | while ((c = getc(in)) != '"') { 1139 | if (c == '\\') { 1140 | c = getc(in); 1141 | if (c == 'n') { 1142 | c = '\n'; 1143 | } 1144 | } 1145 | if (c == EOF) { 1146 | fprintf(stderr, "non-terminated string literal\n"); 1147 | exit(1); 1148 | } 1149 | /* subtract 1 to save space for '\0' terminator */ 1150 | if (i < BUFFER_MAX - 1) { 1151 | buffer[i++] = c; 1152 | } 1153 | else { 1154 | fprintf(stderr, 1155 | "string too long. Maximum length is %d\n", 1156 | BUFFER_MAX); 1157 | exit(1); 1158 | } 1159 | } 1160 | buffer[i] = '\0'; 1161 | return make_string(buffer); 1162 | } 1163 | else if (c == '(') { /* read the empty list or pair */ 1164 | return read_pair(in); 1165 | } 1166 | else if (c == '\'') { /* read quoted expression */ 1167 | return cons(quote_symbol, cons(read(in), the_empty_list)); 1168 | } 1169 | else if (c == EOF) { 1170 | return NULL; 1171 | } 1172 | else { 1173 | fprintf(stderr, "bad input. Unexpected '%c'\n", c); 1174 | exit(1); 1175 | } 1176 | fprintf(stderr, "read illegal state\n"); 1177 | exit(1); 1178 | } 1179 | 1180 | /*************************** EVALUATE ****************************/ 1181 | 1182 | char is_self_evaluating(object *exp) { 1183 | return is_boolean(exp) || 1184 | is_fixnum(exp) || 1185 | is_character(exp) || 1186 | is_string(exp); 1187 | } 1188 | 1189 | char is_variable(object *expression) { 1190 | return is_symbol(expression); 1191 | } 1192 | 1193 | char is_tagged_list(object *expression, object *tag) { 1194 | object *the_car; 1195 | 1196 | if (is_pair(expression)) { 1197 | the_car = car(expression); 1198 | return is_symbol(the_car) && (the_car == tag); 1199 | } 1200 | return 0; 1201 | } 1202 | 1203 | char is_quoted(object *expression) { 1204 | return is_tagged_list(expression, quote_symbol); 1205 | } 1206 | 1207 | object *text_of_quotation(object *exp) { 1208 | return cadr(exp); 1209 | } 1210 | 1211 | char is_assignment(object *exp) { 1212 | return is_tagged_list(exp, set_symbol); 1213 | } 1214 | 1215 | object *assignment_variable(object *exp) { 1216 | return car(cdr(exp)); 1217 | } 1218 | 1219 | object *assignment_value(object *exp) { 1220 | return car(cdr(cdr(exp))); 1221 | } 1222 | 1223 | char is_definition(object *exp) { 1224 | return is_tagged_list(exp, define_symbol); 1225 | } 1226 | 1227 | object *definition_variable(object *exp) { 1228 | if (is_symbol(cadr(exp))) { 1229 | return cadr(exp); 1230 | } 1231 | else { 1232 | return caadr(exp); 1233 | } 1234 | } 1235 | 1236 | object *make_lambda(object *parameters, object *body); 1237 | 1238 | object *definition_value(object *exp) { 1239 | if (is_symbol(cadr(exp))) { 1240 | return caddr(exp); 1241 | } 1242 | else { 1243 | return make_lambda(cdadr(exp), cddr(exp)); 1244 | } 1245 | } 1246 | 1247 | object *make_if(object *predicate, object *consequent, 1248 | object *alternative) { 1249 | return cons(if_symbol, 1250 | cons(predicate, 1251 | cons(consequent, 1252 | cons(alternative, the_empty_list)))); 1253 | } 1254 | 1255 | char is_if(object *expression) { 1256 | return is_tagged_list(expression, if_symbol); 1257 | } 1258 | 1259 | object *if_predicate(object *exp) { 1260 | return cadr(exp); 1261 | } 1262 | 1263 | object *if_consequent(object *exp) { 1264 | return caddr(exp); 1265 | } 1266 | 1267 | object *if_alternative(object *exp) { 1268 | if (is_the_empty_list(cdddr(exp))) { 1269 | return false; 1270 | } 1271 | else { 1272 | return cadddr(exp); 1273 | } 1274 | } 1275 | 1276 | object *make_lambda(object *parameters, object *body) { 1277 | return cons(lambda_symbol, cons(parameters, body)); 1278 | } 1279 | 1280 | char is_lambda(object *exp) { 1281 | return is_tagged_list(exp, lambda_symbol); 1282 | } 1283 | 1284 | object *lambda_parameters(object *exp) { 1285 | return cadr(exp); 1286 | } 1287 | 1288 | object *lambda_body(object *exp) { 1289 | return cddr(exp); 1290 | } 1291 | 1292 | object *make_begin(object *seq) { 1293 | return cons(begin_symbol, seq); 1294 | } 1295 | 1296 | char is_begin(object *exp) { 1297 | return is_tagged_list(exp, begin_symbol); 1298 | } 1299 | 1300 | object *begin_actions(object *exp) { 1301 | return cdr(exp); 1302 | } 1303 | 1304 | char is_last_exp(object *seq) { 1305 | return is_the_empty_list(cdr(seq)); 1306 | } 1307 | 1308 | object *first_exp(object *seq) { 1309 | return car(seq); 1310 | } 1311 | 1312 | object *rest_exps(object *seq) { 1313 | return cdr(seq); 1314 | } 1315 | 1316 | char is_cond(object *exp) { 1317 | return is_tagged_list(exp, cond_symbol); 1318 | } 1319 | 1320 | object *cond_clauses(object *exp) { 1321 | return cdr(exp); 1322 | } 1323 | 1324 | object *cond_predicate(object *clause) { 1325 | return car(clause); 1326 | } 1327 | 1328 | object *cond_actions(object *clause) { 1329 | return cdr(clause); 1330 | } 1331 | 1332 | char is_cond_else_clause(object *clause) { 1333 | return cond_predicate(clause) == else_symbol; 1334 | } 1335 | 1336 | object *sequence_to_exp(object *seq) { 1337 | if (is_the_empty_list(seq)) { 1338 | return seq; 1339 | } 1340 | else if (is_last_exp(seq)) { 1341 | return first_exp(seq); 1342 | } 1343 | else { 1344 | return make_begin(seq); 1345 | } 1346 | } 1347 | 1348 | object *expand_clauses(object *clauses) { 1349 | object *first; 1350 | object *rest; 1351 | 1352 | if (is_the_empty_list(clauses)) { 1353 | return false; 1354 | } 1355 | else { 1356 | first = car(clauses); 1357 | rest = cdr(clauses); 1358 | if (is_cond_else_clause(first)) { 1359 | if (is_the_empty_list(rest)) { 1360 | return sequence_to_exp(cond_actions(first)); 1361 | } 1362 | else { 1363 | fprintf(stderr, "else clause isn't last cond->if"); 1364 | exit(1); 1365 | } 1366 | } 1367 | else { 1368 | return make_if(cond_predicate(first), 1369 | sequence_to_exp(cond_actions(first)), 1370 | expand_clauses(rest)); 1371 | } 1372 | } 1373 | } 1374 | 1375 | object *cond_to_if(object *exp) { 1376 | return expand_clauses(cond_clauses(exp)); 1377 | } 1378 | 1379 | object *make_application(object *operator, object *operands) { 1380 | return cons(operator, operands); 1381 | } 1382 | 1383 | char is_application(object *exp) { 1384 | return is_pair(exp); 1385 | } 1386 | 1387 | object *operator(object *exp) { 1388 | return car(exp); 1389 | } 1390 | 1391 | object *operands(object *exp) { 1392 | return cdr(exp); 1393 | } 1394 | 1395 | char is_no_operands(object *ops) { 1396 | return is_the_empty_list(ops); 1397 | } 1398 | 1399 | object *first_operand(object *ops) { 1400 | return car(ops); 1401 | } 1402 | 1403 | object *rest_operands(object *ops) { 1404 | return cdr(ops); 1405 | } 1406 | 1407 | char is_let(object *exp) { 1408 | return is_tagged_list(exp, let_symbol); 1409 | } 1410 | 1411 | object *let_bindings(object *exp) { 1412 | return cadr(exp); 1413 | } 1414 | 1415 | object *let_body(object *exp) { 1416 | return cddr(exp); 1417 | } 1418 | 1419 | object *binding_parameter(object *binding) { 1420 | return car(binding); 1421 | } 1422 | 1423 | object *binding_argument(object *binding) { 1424 | return cadr(binding); 1425 | } 1426 | 1427 | object *bindings_parameters(object *bindings) { 1428 | return is_the_empty_list(bindings) ? 1429 | the_empty_list : 1430 | cons(binding_parameter(car(bindings)), 1431 | bindings_parameters(cdr(bindings))); 1432 | } 1433 | 1434 | object *bindings_arguments(object *bindings) { 1435 | return is_the_empty_list(bindings) ? 1436 | the_empty_list : 1437 | cons(binding_argument(car(bindings)), 1438 | bindings_arguments(cdr(bindings))); 1439 | } 1440 | 1441 | object *let_parameters(object *exp) { 1442 | return bindings_parameters(let_bindings(exp)); 1443 | } 1444 | 1445 | object *let_arguments(object *exp) { 1446 | return bindings_arguments(let_bindings(exp)); 1447 | } 1448 | 1449 | object *let_to_application(object *exp) { 1450 | return make_application( 1451 | make_lambda(let_parameters(exp), 1452 | let_body(exp)), 1453 | let_arguments(exp)); 1454 | } 1455 | 1456 | char is_and(object *exp) { 1457 | return is_tagged_list(exp, and_symbol); 1458 | } 1459 | 1460 | object *and_tests(object *exp) { 1461 | return cdr(exp); 1462 | } 1463 | 1464 | char is_or(object *exp) { 1465 | return is_tagged_list(exp, or_symbol); 1466 | } 1467 | 1468 | object *or_tests(object *exp) { 1469 | return cdr(exp); 1470 | } 1471 | 1472 | object *apply_operator(object *arguments) { 1473 | return car(arguments); 1474 | } 1475 | 1476 | object *prepare_apply_operands(object *arguments) { 1477 | if (is_the_empty_list(cdr(arguments))) { 1478 | return car(arguments); 1479 | } 1480 | else { 1481 | return cons(car(arguments), 1482 | prepare_apply_operands(cdr(arguments))); 1483 | } 1484 | } 1485 | 1486 | object *apply_operands(object *arguments) { 1487 | return prepare_apply_operands(cdr(arguments)); 1488 | } 1489 | 1490 | object *eval_expression(object *arguments) { 1491 | return car(arguments); 1492 | } 1493 | 1494 | object *eval_environment(object *arguments) { 1495 | return cadr(arguments); 1496 | } 1497 | 1498 | object *list_of_values(object *exps, object *env) { 1499 | if (is_no_operands(exps)) { 1500 | return the_empty_list; 1501 | } 1502 | else { 1503 | return cons(eval(first_operand(exps), env), 1504 | list_of_values(rest_operands(exps), env)); 1505 | } 1506 | } 1507 | 1508 | object *eval_assignment(object *exp, object *env) { 1509 | set_variable_value(assignment_variable(exp), 1510 | eval(assignment_value(exp), env), 1511 | env); 1512 | return ok_symbol; 1513 | } 1514 | 1515 | object *eval_definition(object *exp, object *env) { 1516 | define_variable(definition_variable(exp), 1517 | eval(definition_value(exp), env), 1518 | env); 1519 | return ok_symbol; 1520 | } 1521 | 1522 | object *eval(object *exp, object *env) { 1523 | object *procedure; 1524 | object *arguments; 1525 | object *result; 1526 | 1527 | tailcall: 1528 | if (is_self_evaluating(exp)) { 1529 | return exp; 1530 | } 1531 | else if (is_variable(exp)) { 1532 | return lookup_variable_value(exp, env); 1533 | } 1534 | else if (is_quoted(exp)) { 1535 | return text_of_quotation(exp); 1536 | } 1537 | else if (is_assignment(exp)) { 1538 | return eval_assignment(exp, env); 1539 | } 1540 | else if (is_definition(exp)) { 1541 | return eval_definition(exp, env); 1542 | } 1543 | else if (is_if(exp)) { 1544 | exp = is_true(eval(if_predicate(exp), env)) ? 1545 | if_consequent(exp) : 1546 | if_alternative(exp); 1547 | goto tailcall; 1548 | } 1549 | else if (is_lambda(exp)) { 1550 | return make_compound_proc(lambda_parameters(exp), 1551 | lambda_body(exp), 1552 | env); 1553 | } 1554 | else if (is_begin(exp)) { 1555 | exp = begin_actions(exp); 1556 | while (!is_last_exp(exp)) { 1557 | eval(first_exp(exp), env); 1558 | exp = rest_exps(exp); 1559 | } 1560 | exp = first_exp(exp); 1561 | goto tailcall; 1562 | } 1563 | else if (is_cond(exp)) { 1564 | exp = cond_to_if(exp); 1565 | goto tailcall; 1566 | } 1567 | else if (is_let(exp)) { 1568 | exp = let_to_application(exp); 1569 | goto tailcall; 1570 | } 1571 | else if (is_and(exp)) { 1572 | exp = and_tests(exp); 1573 | if (is_the_empty_list(exp)) { 1574 | return true; 1575 | } 1576 | while (!is_last_exp(exp)) { 1577 | result = eval(first_exp(exp), env); 1578 | if (is_false(result)) { 1579 | return result; 1580 | } 1581 | exp = rest_exps(exp); 1582 | } 1583 | exp = first_exp(exp); 1584 | goto tailcall; 1585 | } 1586 | else if (is_or(exp)) { 1587 | exp = or_tests(exp); 1588 | if (is_the_empty_list(exp)) { 1589 | return false; 1590 | } 1591 | while (!is_last_exp(exp)) { 1592 | result = eval(first_exp(exp), env); 1593 | if (is_true(result)) { 1594 | return result; 1595 | } 1596 | exp = rest_exps(exp); 1597 | } 1598 | exp = first_exp(exp); 1599 | goto tailcall; 1600 | } 1601 | else if (is_application(exp)) { 1602 | procedure = eval(operator(exp), env); 1603 | arguments = list_of_values(operands(exp), env); 1604 | 1605 | /* handle eval specially for tail call requirement */ 1606 | if (is_primitive_proc(procedure) && 1607 | procedure->data.primitive_proc.fn == eval_proc) { 1608 | exp = eval_expression(arguments); 1609 | env = eval_environment(arguments); 1610 | goto tailcall; 1611 | } 1612 | 1613 | /* handle apply specially for tail call requirement */ 1614 | if (is_primitive_proc(procedure) && 1615 | procedure->data.primitive_proc.fn == apply_proc) { 1616 | procedure = apply_operator(arguments); 1617 | arguments = apply_operands(arguments); 1618 | } 1619 | 1620 | if (is_primitive_proc(procedure)) { 1621 | return (procedure->data.primitive_proc.fn)(arguments); 1622 | } 1623 | else if (is_compound_proc(procedure)) { 1624 | env = extend_environment( 1625 | procedure->data.compound_proc.parameters, 1626 | arguments, 1627 | procedure->data.compound_proc.env); 1628 | exp = make_begin(procedure->data.compound_proc.body); 1629 | goto tailcall; 1630 | } 1631 | else { 1632 | fprintf(stderr, "unknown procedure type\n"); 1633 | exit(1); 1634 | } 1635 | } 1636 | else { 1637 | fprintf(stderr, "cannot eval unknown expression type\n"); 1638 | exit(1); 1639 | } 1640 | fprintf(stderr, "eval illegal state\n"); 1641 | exit(1); 1642 | } 1643 | 1644 | /**************************** PRINT ******************************/ 1645 | 1646 | void write_pair(FILE *out, object *pair) { 1647 | object *car_obj; 1648 | object *cdr_obj; 1649 | 1650 | car_obj = car(pair); 1651 | cdr_obj = cdr(pair); 1652 | write(out, car_obj); 1653 | if (cdr_obj->type == PAIR) { 1654 | fprintf(out, " "); 1655 | write_pair(out, cdr_obj); 1656 | } 1657 | else if (cdr_obj->type == THE_EMPTY_LIST) { 1658 | return; 1659 | } 1660 | else { 1661 | fprintf(out, " . "); 1662 | write(out, cdr_obj); 1663 | } 1664 | } 1665 | 1666 | void write(FILE *out, object *obj) { 1667 | char c; 1668 | char *str; 1669 | 1670 | switch (obj->type) { 1671 | case THE_EMPTY_LIST: 1672 | fprintf(out, "()"); 1673 | break; 1674 | case BOOLEAN: 1675 | fprintf(out, "#%c", is_false(obj) ? 'f' : 't'); 1676 | break; 1677 | case SYMBOL: 1678 | fprintf(out, "%s", obj->data.symbol.value); 1679 | break; 1680 | case FIXNUM: 1681 | fprintf(out, "%ld", obj->data.fixnum.value); 1682 | break; 1683 | case CHARACTER: 1684 | c = obj->data.character.value; 1685 | fprintf(out, "#\\"); 1686 | switch (c) { 1687 | case '\n': 1688 | fprintf(out, "newline"); 1689 | break; 1690 | case ' ': 1691 | fprintf(out, "space"); 1692 | break; 1693 | default: 1694 | putc(c, out); 1695 | } 1696 | break; 1697 | case STRING: 1698 | str = obj->data.string.value; 1699 | putchar('"'); 1700 | while (*str != '\0') { 1701 | switch (*str) { 1702 | case '\n': 1703 | fprintf(out, "\\n"); 1704 | break; 1705 | case '\\': 1706 | fprintf(out, "\\\\"); 1707 | break; 1708 | case '"': 1709 | fprintf(out, "\\\""); 1710 | break; 1711 | default: 1712 | putc(*str, out); 1713 | } 1714 | str++; 1715 | } 1716 | putchar('"'); 1717 | break; 1718 | case PAIR: 1719 | fprintf(out, "("); 1720 | write_pair(out, obj); 1721 | fprintf(out, ")"); 1722 | break; 1723 | case PRIMITIVE_PROC: 1724 | fprintf(out, "#"); 1725 | break; 1726 | case COMPOUND_PROC: 1727 | fprintf(out, "#"); 1728 | break; 1729 | case INPUT_PORT: 1730 | fprintf(out, "#"); 1731 | break; 1732 | case OUTPUT_PORT: 1733 | fprintf(out, "#"); 1734 | break; 1735 | case EOF_OBJECT: 1736 | fprintf(out, "#"); 1737 | break; 1738 | default: 1739 | fprintf(stderr, "cannot write unknown type\n"); 1740 | exit(1); 1741 | } 1742 | } 1743 | 1744 | /***************************** REPL ******************************/ 1745 | 1746 | int main(void) { 1747 | object *exp; 1748 | 1749 | printf("Welcome to Bootstrap Scheme. " 1750 | "Use ctrl-c to exit.\n"); 1751 | 1752 | init(); 1753 | 1754 | while (1) { 1755 | printf("> "); 1756 | exp = read(stdin); 1757 | if (exp == NULL) { 1758 | break; 1759 | } 1760 | write(stdout, eval(exp, the_global_environment)); 1761 | printf("\n"); 1762 | } 1763 | 1764 | printf("Goodbye\n"); 1765 | 1766 | return 0; 1767 | } 1768 | 1769 | /**************************** MUSIC ******************************* 1770 | 1771 | Slipknot, Neil Young, Pearl Jam, The Dead Weather, 1772 | Dave Matthews Band, Alice in Chains, White Zombie, Blind Melon, 1773 | Priestess, Puscifer, Bob Dylan, Them Crooked Vultures, 1774 | Black Sabbath, Pantera, Tool, ZZ Top, Queens of the Stone Age, 1775 | Raised Fist, Rage Against the Machine, Primus, Black Label Society, 1776 | The Offspring, Nickelback, Metallica, Jeff Beck, M.I.R.V., 1777 | The Tragically Hip, Willie Nelson, Highwaymen 1778 | 1779 | */ 1780 | -------------------------------------------------------------------------------- /stdlib.scm: -------------------------------------------------------------------------------- 1 | (define number? integer?) 2 | 3 | (define (caar x) (car (car x))) 4 | (define (cadr x) (car (cdr x))) 5 | (define (cdar x) (cdr (car x))) 6 | (define (cddr x) (cdr (cdr x))) 7 | (define (caaar x) (car (car (car x)))) 8 | (define (caadr x) (car (car (cdr x)))) 9 | (define (cadar x) (car (cdr (car x)))) 10 | (define (caddr x) (car (cdr (cdr x)))) 11 | (define (cdaar x) (cdr (car (car x)))) 12 | (define (cdadr x) (cdr (car (cdr x)))) 13 | (define (cddar x) (cdr (cdr (car x)))) 14 | (define (cdddr x) (cdr (cdr (cdr x)))) 15 | (define (caaaar x) (car (car (car (car x))))) 16 | (define (caaadr x) (car (car (car (cdr x))))) 17 | (define (caadar x) (car (car (cdr (car x))))) 18 | (define (caaddr x) (car (car (cdr (cdr x))))) 19 | (define (cadaar x) (car (cdr (car (car x))))) 20 | (define (cadadr x) (car (cdr (car (cdr x))))) 21 | (define (caddar x) (car (cdr (cdr (car x))))) 22 | (define (cadddr x) (car (cdr (cdr (cdr x))))) 23 | (define (cdaaar x) (cdr (car (car (car x))))) 24 | (define (cdaadr x) (cdr (car (car (cdr x))))) 25 | (define (cdadar x) (cdr (car (cdr (car x))))) 26 | (define (cdaddr x) (cdr (car (cdr (cdr x))))) 27 | (define (cddaar x) (cdr (cdr (car (car x))))) 28 | (define (cddadr x) (cdr (cdr (car (cdr x))))) 29 | (define (cdddar x) (cdr (cdr (cdr (car x))))) 30 | (define (cddddr x) (cdr (cdr (cdr (cdr x))))) 31 | 32 | (define (length items) 33 | (define (iter a count) 34 | (if (null? a) 35 | count 36 | (iter (cdr a) (+ 1 count)))) 37 | (iter items 0)) 38 | 39 | (define (append list1 list2) 40 | (if (null? list1) 41 | list2 42 | (cons (car list1) (append (cdr list1) list2)))) 43 | 44 | (define (reverse l) 45 | (define (iter in out) 46 | (if (pair? in) 47 | (iter (cdr in) (cons (car in) out)) 48 | out)) 49 | (iter l '())) 50 | 51 | (define (map proc items) 52 | (if (null? items) 53 | '() 54 | (cons (proc (car items)) 55 | (map proc (cdr items))))) 56 | 57 | (define (for-each f l) 58 | (if (null? l) 59 | #t 60 | (begin 61 | (f (car l)) 62 | (for-each f (cdr l))))) 63 | 64 | (define (not x) 65 | (if x #f #t)) 66 | 67 | 'stdlib-loaded --------------------------------------------------------------------------------