├── .gitignore ├── .gitmodules ├── .travis.yml ├── COPYING.RUNTIME ├── COPYING3 ├── Makefile ├── aforth.adb ├── aforth.gpr ├── builtins.fs ├── embed.py ├── forth-interpreter.adb ├── forth-interpreter.ads ├── forth-stacks.adb ├── forth-stacks.ads ├── forth-types.adb ├── forth-types.ads ├── forth.ads ├── gnat.adc └── t ├── Makefile ├── again.fs ├── align.fs ├── base.fs ├── bye.fs ├── compile-only.fs ├── conditionals.fs ├── create-does.fs ├── evaluate.fs ├── exit.fs ├── fetch-store.fs ├── find.fs ├── fm-mod.fs ├── include-helper.fs ├── include.fs ├── j.fs ├── leave.fs ├── loops.fs ├── parse.fs ├── picture.fs ├── recurse.fs ├── run-test.sh ├── scale-mod.fs ├── sm-rem.fs ├── stack-depth.fs ├── stack-overflow.fs ├── stack-underflow.fs ├── twodiv.fs ├── um-mod.fs ├── value.fs └── while.fs /.gitignore: -------------------------------------------------------------------------------- 1 | b~*.ad? 2 | *.ali 3 | *.o 4 | test_aforth 5 | forth-builtins.ads 6 | *~ 7 | \#*\# 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "areadline"] 2 | path = areadline 3 | url = https://github.com/samueltardieu/areadline.git 4 | branch = master 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | addons: 4 | apt: 5 | packages: 6 | - gnat 7 | script: make check 8 | -------------------------------------------------------------------------------- /COPYING.RUNTIME: -------------------------------------------------------------------------------- 1 | GCC RUNTIME LIBRARY EXCEPTION 2 | 3 | Version 3.1, 31 March 2009 4 | 5 | Copyright (C) 2009 Free Software Foundation, Inc. 6 | 7 | Everyone is permitted to copy and distribute verbatim copies of this 8 | license document, but changing it is not allowed. 9 | 10 | This GCC Runtime Library Exception ("Exception") is an additional 11 | permission under section 7 of the GNU General Public License, version 12 | 3 ("GPLv3"). It applies to a given file (the "Runtime Library") that 13 | bears a notice placed by the copyright holder of the file stating that 14 | the file is governed by GPLv3 along with this Exception. 15 | 16 | When you use GCC to compile a program, GCC may combine portions of 17 | certain GCC header files and runtime libraries with the compiled 18 | program. The purpose of this Exception is to allow compilation of 19 | non-GPL (including proprietary) programs to use, in this way, the 20 | header files and runtime libraries covered by this Exception. 21 | 22 | 0. Definitions. 23 | 24 | A file is an "Independent Module" if it either requires the Runtime 25 | Library for execution after a Compilation Process, or makes use of an 26 | interface provided by the Runtime Library, but is not otherwise based 27 | on the Runtime Library. 28 | 29 | "GCC" means a version of the GNU Compiler Collection, with or without 30 | modifications, governed by version 3 (or a specified later version) of 31 | the GNU General Public License (GPL) with the option of using any 32 | subsequent versions published by the FSF. 33 | 34 | "GPL-compatible Software" is software whose conditions of propagation, 35 | modification and use would permit combination with GCC in accord with 36 | the license of GCC. 37 | 38 | "Target Code" refers to output from any compiler for a real or virtual 39 | target processor architecture, in executable form or suitable for 40 | input to an assembler, loader, linker and/or execution 41 | phase. Notwithstanding that, Target Code does not include data in any 42 | format that is used as a compiler intermediate representation, or used 43 | for producing a compiler intermediate representation. 44 | 45 | The "Compilation Process" transforms code entirely represented in 46 | non-intermediate languages designed for human-written code, and/or in 47 | Java Virtual Machine byte code, into Target Code. Thus, for example, 48 | use of source code generators and preprocessors need not be considered 49 | part of the Compilation Process, since the Compilation Process can be 50 | understood as starting with the output of the generators or 51 | preprocessors. 52 | 53 | A Compilation Process is "Eligible" if it is done using GCC, alone or 54 | with other GPL-compatible software, or if it is done without using any 55 | work based on GCC. For example, using non-GPL-compatible Software to 56 | optimize any GCC intermediate representations would not qualify as an 57 | Eligible Compilation Process. 58 | 59 | 1. Grant of Additional Permission. 60 | 61 | You have permission to propagate a work of Target Code formed by 62 | combining the Runtime Library with Independent Modules, even if such 63 | propagation would otherwise violate the terms of GPLv3, provided that 64 | all Target Code was generated by Eligible Compilation Processes. You 65 | may then convey such a combination under terms of your choice, 66 | consistent with the licensing of the Independent Modules. 67 | 68 | 2. No Weakening of GCC Copyleft. 69 | 70 | The availability of this Exception does not imply any general 71 | presumption that third-party software is unaffected by the copyleft 72 | requirements of the license of GCC. 73 | 74 | -------------------------------------------------------------------------------- /COPYING3: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | GNATMAKE ?= gnatmake 2 | GNATCFLAGS = -aPareadline 3 | PYTHON ?= python 4 | 5 | PROGRAMS = aforth 6 | 7 | all:: $(PROGRAMS) 8 | 9 | install:: $(PROGRAMS) 10 | rsync $(PROGRAMS) /home/shix 11 | 12 | %.ads %.adb: %.fs 13 | $(PYTHON) embed.py $< 14 | 15 | forth-builtins.ads: builtins.fs embed.py 16 | $(PYTHON) embed.py $< Forth.Builtins 17 | 18 | aforth: never forth-builtins.ads 19 | $(GNATMAKE) $(GNATCFLAGS) -Paforth 20 | 21 | clean:: never 22 | $(RM) *.o *.ali *~ b~*.ad? $(PROGRAMS) \ 23 | forth-builtins.ads forth-builtins.adb 24 | 25 | never:: 26 | 27 | check-syntax:: 28 | gcc -Iareadline -S -o /dev/null -gnatwa -gnaty $(CHK_SOURCES) 2>&1 | \ 29 | grep -v 'file name does not match unit name' >&2 || true 30 | 31 | check: all 32 | @$(MAKE) -C t check 33 | -------------------------------------------------------------------------------- /aforth.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- A F O R T H -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Command_Line; use Ada.Command_Line; 33 | with Ada.IO_Exceptions; 34 | with Forth.Interpreter; use Forth.Interpreter; 35 | with Forth.Types; use Forth.Types; 36 | with Readline.Completion; 37 | 38 | procedure Aforth is 39 | 40 | Interpreter : Interpreter_Type := New_Interpreter; 41 | 42 | procedure Cleanup; 43 | 44 | ------------- 45 | -- Cleanup -- 46 | ------------- 47 | 48 | procedure Cleanup is 49 | begin 50 | Free_Interpreter (Interpreter); 51 | Readline.Completion.Clear_All_Words; 52 | end Cleanup; 53 | 54 | begin 55 | for I in 1 .. Argument_Count loop 56 | Include_File (Interpreter, Argument (I)); 57 | end loop; 58 | Quit (Interpreter); 59 | exception 60 | when Ada.IO_Exceptions.Name_Error => 61 | Cleanup; 62 | Set_Exit_Status (1); 63 | when Bye_Exception => 64 | Cleanup; 65 | end Aforth; 66 | -------------------------------------------------------------------------------- /aforth.gpr: -------------------------------------------------------------------------------- 1 | with "areadline"; 2 | 3 | project Aforth is 4 | 5 | for Main use ("aforth"); 6 | 7 | package Builder is 8 | for Default_Switches ("Ada") use ("-g"); 9 | for Global_Configuration_Pragmas use "gnat.adc"; 10 | end Builder; 11 | 12 | package Compiler is 13 | for Default_Switches ("Ada") use ("-g", "-O2", "-gnatg", "-gnaty", "-gnatwa"); 14 | end Compiler; 15 | 16 | end Aforth; 17 | -------------------------------------------------------------------------------- /builtins.fs: -------------------------------------------------------------------------------- 1 | : HERE (HERE) @ ; 2 | : \ TIB# @ >IN ! ; IMMEDIATE 3 | : CELL 4 ; INLINE 4 | : OVER 1 PICK ; 5 | : TUCK SWAP OVER ; 6 | : +! TUCK @ + SWAP ! ; 7 | : , HERE ! CELL (HERE) +! ; 8 | : CREATE : HERE POSTPONE LITERAL POSTPONE ; ; 9 | : CONSTANT ALIGN CREATE , DOES> @ ; 10 | : VARIABLE ALIGN CREATE 0 , ; 11 | : 2VARIABLE ALIGN CREATE 0 , 0 , ; 12 | : 1+ 1 + ; 13 | : NEGATE -1 XOR 1+ ; 14 | : 0>= 0 >= ; 15 | : 0= 0 = ; 16 | : < >= 0= ; 17 | : <> = 0= ; 18 | : 0> NEGATE 0< ; 19 | : 0<= NEGATE 0>= ; 20 | : 0<> 0 <> ; 21 | : < >= 0= ; 22 | : > SWAP < ; 23 | : <= SWAP >= ; 24 | : 2* 2 * ; 25 | : NIP SWAP DROP ; 26 | : / /MOD NIP ; 27 | : - NEGATE + ; 28 | : 1- 1 - ; 29 | : 2DROP DROP DROP ; 30 | : 2DUP OVER OVER ; 31 | : CHAR PARSE-WORD DROP C@ ; 32 | : [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE 33 | : ( [CHAR] ) PARSE 2DROP ; IMMEDIATE 34 | : DECIMAL 10 BASE ! ; 35 | : HEX 16 BASE ! ; 36 | : CELLS CELL * ; 37 | : CELL+ CELL + ; 38 | : 2! SWAP OVER ! CELL+ ! ; 39 | : 2@ DUP CELL+ @ SWAP @ ; 40 | : 2OVER 3 PICK 3 PICK ; 41 | : ROT 2 ROLL ; 42 | : ?DUP DUP IF DUP THEN ; 43 | : ABS DUP 0< IF NEGATE THEN ; 44 | : ALIGNED CELL 1- + CELL / CELL * ; 45 | : ALLOT (HERE) +! ; 46 | : INVERT NEGATE 1- ; 47 | : CHAR+ 1 + ; 48 | : CHARS ; 49 | : 2SWAP 3 ROLL 3 ROLL ; 50 | : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; IMMEDIATE 51 | : MAX 2DUP > IF DROP ELSE NIP THEN ; 52 | : MIN 2DUP > IF NIP ELSE DROP THEN ; 53 | : MOD /MOD DROP ; 54 | : BOUNDS OVER + SWAP ; 55 | : LOOP 1 POSTPONE LITERAL POSTPONE +LOOP ; IMMEDIATE 56 | : I R@ ; INLINE 57 | : TYPE DUP IF BOUNDS DO I C@ EMIT LOOP ELSE 2DROP THEN ; 58 | : .( [CHAR] ) PARSE TYPE ; IMMEDIATE 59 | 0 CONSTANT FALSE 60 | -1 CONSTANT TRUE 61 | ALIGN CREATE PAD 256 ALLOT 62 | : ['] ' POSTPONE LITERAL ; IMMEDIATE 63 | : VALUE CONSTANT ; 64 | : TO ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; IMMEDIATE 65 | : -ROT ROT ROT ; 66 | : DEFER VARIABLE DOES> @ ?DUP IF EXECUTE THEN ; 67 | : IS ' >BODY ! ; 68 | 32 CONSTANT BL 69 | : SPACE BL EMIT ; 70 | : */ */MOD NIP ; 71 | : 1+ 1 + ; 72 | : 1- 1 - ; 73 | : UNTIL POSTPONE 0= POSTPONE WHILE POSTPONE REPEAT ; IMMEDIATE 74 | : C, HERE C! 1 ALLOT ; 75 | : S" [CHAR] " PARSE HERE POSTPONE LITERAL DUP POSTPONE LITERAL 76 | BOUNDS DO I C@ C, LOOP ; IMMEDIATE 77 | : C" [CHAR] " PARSE HERE POSTPONE LITERAL DUP C, 78 | BOUNDS DO I C@ C, LOOP ; IMMEDIATE 79 | : ." POSTPONE S" POSTPONE TYPE ; IMMEDIATE 80 | : 2R> R> R> SWAP ; INLINE 81 | : -! TUCK @ SWAP - SWAP ! ; 82 | : CLEAR DEPTH DUP IF 0 DO DROP LOOP THEN ; 83 | : SOURCE TIB TIB# @ ; 84 | 85 | 86 | \ Picture output 87 | 88 | 32 CONSTANT #-SIZE 89 | CREATE #-BUFFER #-SIZE ALLOT 90 | #-BUFFER #-SIZE + CONSTANT #-AFTER 91 | 92 | VARIABLE #-HERE 93 | 94 | : (BASE/MOD) BASE @ OVER 0< IF NEGATE THEN FM/MOD 0 ; 95 | 96 | : <# #-AFTER #-HERE ! ; 97 | : #> 2DROP #-HERE @ #-AFTER OVER - ; 98 | : DIGIT DUP 10 < IF [CHAR] 0 ELSE [CHAR] A 10 - THEN + ; 99 | : HOLD 1 #-HERE -! #-HERE @ C! ; 100 | : SIGN 0< IF [CHAR] - HOLD THEN ; 101 | : # (BASE/MOD) ROT ABS DIGIT HOLD ; 102 | : #S BEGIN # 2DUP OR WHILE REPEAT ; 103 | 104 | : . DUP <# S>D #S ROT SIGN #> TYPE ; 105 | : .S [CHAR] < EMIT DEPTH DUP . [CHAR] > EMIT 106 | DUP IF 1 SWAP 1- NEGATE DO SPACE I NEGATE PICK . LOOP ELSE DROP THEN ; 107 | -------------------------------------------------------------------------------- /embed.py: -------------------------------------------------------------------------------- 1 | #! /usr/bin/python 2 | # 3 | # Usage: embed input_forth_file output_ada_unit 4 | # 5 | 6 | import sys 7 | try: 8 | from functools import reduce # Python 3 needs this 9 | except: 10 | pass 11 | 12 | try: ada = sys.argv[2] 13 | except IndexError: ada = sys.argv[1][:-3].capitalize() 14 | 15 | adafile = ada.lower().replace('.', '-') 16 | 17 | outspec = open("%s.ads" % adafile, "w") 18 | outspec.write('''------------------------------------------------------------------------------ 19 | -- -- 20 | -- AFORTH COMPONENTS -- 21 | -- -- 22 | -- F O R T H . B U I L T I N S -- 23 | -- -- 24 | -- S p e c -- 25 | -- -- 26 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 27 | -- -- 28 | -- GNAT is free software; you can redistribute it and/or modify it under -- 29 | -- terms of the GNU General Public License as published by the Free Soft- -- 30 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 31 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 32 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 33 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 34 | -- -- 35 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 36 | -- additional permissions described in the GCC Runtime Library Exception, -- 37 | -- version 3.1, as published by the Free Software Foundation. -- 38 | -- -- 39 | -- You should have received a copy of the GNU General Public License and -- 40 | -- a copy of the GCC Runtime Library Exception along with this program; -- 41 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 42 | -- . -- 43 | -- -- 44 | -- The main repository for this software is located at: -- 45 | -- http://git.rfc1149.net/aforth.git -- 46 | -- -- 47 | ------------------------------------------------------------------------------ 48 | 49 | -- This file is autogenerated. Changes must be made to the builtins.fs 50 | -- file instead or they will be lost. 51 | 52 | private package %s is 53 | 54 | pragma Preelaborate; 55 | 56 | type String_Access is access constant String; 57 | type String_Array is array (Positive range <>) of String_Access; 58 | 59 | Builtins : constant String_Array := ( 60 | ''' % ada) 61 | 62 | # Snippet copied from http://code.activestate.com/recipes/148061/ 63 | # (PSF license) 64 | def wrap(text, width): 65 | """ 66 | A word-wrap function that preserves existing line breaks 67 | and most spaces in the text. Expects that existing line 68 | breaks are posix newlines (\n). 69 | """ 70 | return reduce(lambda line, word, width=width: '%s%s%s' % 71 | (line, 72 | ' \n'[(len(line)-line.rfind('\n')-1 73 | + len(word.split('\n',1)[0] 74 | ) >= width)], 75 | word), 76 | text.split(' ')) 77 | 78 | # Protect and unprotect some words that must not be separated 79 | def protect(text): 80 | return text.replace('POSTPONE ', 'POSTPONE_').replace('] ', ']_') 81 | 82 | def unprotect(text): 83 | return text.replace('POSTPONE_', 'POSTPONE ').replace(']_', '] ') 84 | 85 | # Make sure we don't split lines after POSTPONE 86 | text = unprotect(wrap(protect(open(sys.argv[1]).read()), 40)) 87 | 88 | outspec.write (',\n '.join(['''new String'("%s")''' % l.replace('"', '""') for l in text.splitlines()])) 89 | 90 | outspec.write("""); 91 | 92 | end %s; 93 | """ % ada) 94 | 95 | -------------------------------------------------------------------------------- /forth-interpreter.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- F O R T H . I N T E R P R E T E R -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Characters.Handling; use Ada.Characters.Handling; 33 | with Ada.Exceptions; use Ada.Exceptions; 34 | with Ada.Real_Time; use Ada.Real_Time; 35 | with Ada.Text_IO; use Ada.Text_IO; 36 | with Ada.Unchecked_Conversion; 37 | with Ada.Unchecked_Deallocation; 38 | with Forth.Builtins; 39 | with Readline.Completion; 40 | with Readline.Variables; 41 | 42 | package body Forth.Interpreter is 43 | 44 | -- Notes: 45 | -- - the compilation stack is the data stack 46 | 47 | TIB_Length : constant := 1024; 48 | 49 | Stack_Marker : constant := -1; 50 | Forward_Reference : constant := -100; 51 | Backward_Reference : constant := -101; 52 | Do_Loop_Reference : constant := -102; 53 | Definition_Reference : constant := -103; 54 | 55 | use Dictionaries, Compilation_Buffers; 56 | 57 | procedure Initialize (I : IT); 58 | -- Register builtin words (Ada and Forth primitives) 59 | 60 | procedure Register (I : IT; 61 | Name : String; 62 | Action : Action_Type); 63 | 64 | function Find (I : IT; Name : String) return Action_Type; 65 | -- May raise Word_Not_Found 66 | 67 | procedure Add_To_Compilation_Buffer (I : IT; Action : Action_Type); 68 | 69 | function Next_Index (V : Compilation_Buffers.Vector) 70 | return Natural_Cell; 71 | 72 | package Cell_IO is new Ada.Text_IO.Integer_IO (Cell); 73 | use Cell_IO; 74 | 75 | pragma Warnings (Off); 76 | function To_Cell_Access is 77 | new Ada.Unchecked_Conversion (Byte_Access, Cell_Access); 78 | pragma Warnings (On); 79 | 80 | function To_Unsigned_32 is 81 | new Ada.Unchecked_Conversion (Cell, Unsigned_32); 82 | function To_Cell is 83 | new Ada.Unchecked_Conversion (Unsigned_32, Cell); 84 | function To_Unsigned_64 is 85 | new Ada.Unchecked_Conversion (Integer_64, Unsigned_64); 86 | function To_Integer_64 is 87 | new Ada.Unchecked_Conversion (Unsigned_64, Integer_64); 88 | 89 | Forth_Exit : constant Action_Type := (Kind => Forth_Word, 90 | Immediate => True, 91 | Inline => False, 92 | Forth_Proc => -1); 93 | 94 | procedure Remember_Variable 95 | (I : IT; 96 | Name : String; 97 | Var : out Cell_Access); 98 | 99 | procedure Remember_Variable 100 | (I : IT; 101 | Name : String; 102 | Var : out Cell); 103 | 104 | procedure Start_Definition (I : IT; Name : String := ""); 105 | 106 | function To_String (I : IT) return String; 107 | 108 | procedure Execute_Action (I : IT; Action : Action_Type); 109 | 110 | procedure Execute_Forth_Word (I : IT; Addr : Cell); 111 | 112 | procedure Main_Loop (I : IT); 113 | 114 | function Word (I : IT) return String; 115 | 116 | procedure Jump (I : IT); 117 | procedure Jump_If_False (I : IT); 118 | procedure Patch_Jump (I : IT; To_Patch : Cell; Target : Cell); 119 | 120 | procedure Add_To_Compilation_Buffer (I : IT; Ada_Proc : Ada_Word_Access); 121 | procedure Add_To_Compilation_Buffer (I : IT; Value : Cell); 122 | 123 | procedure DoDoes (I : IT); 124 | 125 | procedure Refill_Line (I : IT; Buffer : String); 126 | 127 | procedure Check_Compile_Only (I : IT); 128 | 129 | procedure Tick (I : IT; Name : String); 130 | 131 | procedure Check_Control_Structure (I : IT; Reference : Cell); 132 | 133 | function Is_Blank (C : Character) return Boolean; 134 | 135 | function Parse_Number (I : IT; S : String) return Cell; 136 | -- Parse a number given the current base. This will raise Constraint_Error 137 | -- if the number cannot be parsed. 138 | 139 | function Peek (I : IT) return Cell; 140 | 141 | ------------------------------- 142 | -- Add_To_Compilation_Buffer -- 143 | ------------------------------- 144 | 145 | procedure Add_To_Compilation_Buffer (I : IT; Action : Action_Type) is 146 | begin 147 | Check_Compile_Only (I); 148 | 149 | -- Call or inline words 150 | 151 | if Action.Kind = Forth_Word and then Action.Inline then 152 | declare 153 | Index : Cell := Action.Forth_Proc; 154 | begin 155 | while Element (I.Compilation_Buffer, Index) /= Forth_Exit loop 156 | Add_To_Compilation_Buffer 157 | (I, Element (I.Compilation_Buffer, Index)); 158 | Index := Index + 1; 159 | end loop; 160 | end; 161 | else 162 | Append (I.Compilation_Buffer, Action); 163 | end if; 164 | end Add_To_Compilation_Buffer; 165 | 166 | ------------------------------- 167 | -- Add_To_Compilation_Buffer -- 168 | ------------------------------- 169 | 170 | procedure Add_To_Compilation_Buffer (I : IT; Ada_Proc : Ada_Word_Access) is 171 | begin 172 | Add_To_Compilation_Buffer 173 | (I, 174 | Action_Type'(Kind => Ada_Word, 175 | Immediate => True, 176 | Ada_Proc => Ada_Proc)); 177 | end Add_To_Compilation_Buffer; 178 | 179 | ------------------------------- 180 | -- Add_To_Compilation_Buffer -- 181 | ------------------------------- 182 | 183 | procedure Add_To_Compilation_Buffer (I : IT; Value : Cell) is 184 | begin 185 | Add_To_Compilation_Buffer 186 | (I, 187 | Action_Type'(Kind => Number, 188 | Immediate => True, 189 | Value => Value)); 190 | end Add_To_Compilation_Buffer; 191 | 192 | ----------- 193 | -- Again -- 194 | ----------- 195 | 196 | procedure Again (I : IT) is 197 | begin 198 | Check_Control_Structure (I, Backward_Reference); 199 | Literal (I); 200 | Add_To_Compilation_Buffer (I, Jump'Access); 201 | Check_Control_Structure (I, Stack_Marker); 202 | end Again; 203 | 204 | ----------- 205 | -- Ahead -- 206 | ----------- 207 | 208 | procedure Ahead (I : IT) is 209 | 210 | -- The compilation stack contains the index of the address to 211 | -- patch when the AHEAD is resolved by a THEN. 212 | 213 | begin 214 | Push (I, Next_Index (I.Compilation_Buffer)); 215 | Push (I, Forward_Reference); 216 | Add_To_Compilation_Buffer (I, 0); 217 | Add_To_Compilation_Buffer (I, Jump'Access); 218 | end Ahead; 219 | 220 | ----------- 221 | -- Align -- 222 | ----------- 223 | 224 | procedure Align (I : IT) is 225 | begin 226 | if I.Here.all mod 4 /= 0 then 227 | I.Here.all := I.Here.all + (4 - (I.Here.all mod 4)); 228 | end if; 229 | end Align; 230 | 231 | --------- 232 | -- Bye -- 233 | --------- 234 | 235 | procedure Bye (I : IT) is 236 | begin 237 | raise Bye_Exception; 238 | end Bye; 239 | 240 | ------------ 241 | -- Cfetch -- 242 | ------------ 243 | 244 | procedure Cfetch (I : IT) is 245 | begin 246 | Push (I, Cell (I.Memory (Pop (I)))); 247 | end Cfetch; 248 | 249 | ------------ 250 | -- Cfetch -- 251 | ------------ 252 | 253 | function Cfetch (I : IT; Addr : Cell) return Cell is 254 | begin 255 | Push (I, Addr); 256 | Cfetch (I); 257 | return Pop (I); 258 | end Cfetch; 259 | 260 | ------------------------ 261 | -- Check_Compile_Only -- 262 | ------------------------ 263 | 264 | procedure Check_Compile_Only (I : IT) is 265 | begin 266 | if I.State.all /= 1 then 267 | raise Compile_Only; 268 | end if; 269 | end Check_Compile_Only; 270 | 271 | ----------------------------- 272 | -- Check_Control_Structure -- 273 | ----------------------------- 274 | 275 | procedure Check_Control_Structure (I : IT; Reference : Cell) is 276 | begin 277 | Check_Compile_Only (I); 278 | if Pop (I) /= Reference then 279 | raise Unbalanced_Control_Structure; 280 | end if; 281 | end Check_Control_Structure; 282 | 283 | ----------- 284 | -- Colon -- 285 | ----------- 286 | 287 | procedure Colon (I : IT) is 288 | begin 289 | Start_Definition (I, Word (I)); 290 | end Colon; 291 | 292 | ------------------ 293 | -- Colon_Noname -- 294 | ------------------ 295 | 296 | procedure Colon_Noname (I : IT) is 297 | begin 298 | Push (I, Next_Index (I.Compilation_Buffer)); 299 | Start_Definition (I); 300 | end Colon_Noname; 301 | 302 | ------------------- 303 | -- Compile_Comma -- 304 | ------------------- 305 | 306 | procedure Compile_Comma (I : IT) is 307 | begin 308 | Add_To_Compilation_Buffer (I, Pop (I)); 309 | Add_To_Compilation_Buffer (I, Execute'Access); 310 | end Compile_Comma; 311 | 312 | ------------------ 313 | -- Compile_Exit -- 314 | ------------------ 315 | 316 | procedure Compile_Exit (I : IT) is 317 | begin 318 | Add_To_Compilation_Buffer (I, Forth_Exit); 319 | end Compile_Exit; 320 | 321 | ------------------ 322 | -- Compile_Mode -- 323 | ------------------ 324 | 325 | procedure Compile_Mode (I : IT) is 326 | begin 327 | I.State.all := 1; 328 | end Compile_Mode; 329 | 330 | ----------- 331 | -- Count -- 332 | ----------- 333 | 334 | procedure Count (I : IT) is 335 | Start : constant Cell := Pop (I); 336 | begin 337 | Push (I, Start + 1); 338 | Push (I, Cell (I.Memory (Start))); 339 | end Count; 340 | 341 | -------- 342 | -- Cr -- 343 | -------- 344 | 345 | procedure Cr (I : IT) is 346 | begin 347 | Push (I, 13); 348 | Emit (I); 349 | Push (I, 10); 350 | Emit (I); 351 | end Cr; 352 | 353 | ------------ 354 | -- Cstore -- 355 | ------------ 356 | 357 | procedure Cstore (I : IT) is 358 | Addr : constant Cell := Pop (I); 359 | begin 360 | I.Memory (Addr) := Unsigned_8 (Pop (I)); 361 | end Cstore; 362 | 363 | ----------- 364 | -- D_Abs -- 365 | ----------- 366 | 367 | procedure D_Abs (I : IT) is 368 | begin 369 | Push_64 (I, abs (Pop_64 (I))); 370 | end D_Abs; 371 | 372 | ------------- 373 | -- D_Equal -- 374 | ------------- 375 | 376 | procedure D_Equal (I : IT) is 377 | begin 378 | Push (I, Pop_64 (I) = Pop_64 (I)); 379 | end D_Equal; 380 | 381 | ----------- 382 | -- D_Max -- 383 | ----------- 384 | 385 | procedure D_Max (I : IT) is 386 | begin 387 | Push_64 (I, Integer_64'Max (Pop_64 (I), Pop_64 (I))); 388 | end D_Max; 389 | 390 | ----------- 391 | -- D_Min -- 392 | ----------- 393 | 394 | procedure D_Min (I : IT) is 395 | begin 396 | Push_64 (I, Integer_64'Min (Pop_64 (I), Pop_64 (I))); 397 | end D_Min; 398 | 399 | ------------- 400 | -- D_Minus -- 401 | ------------- 402 | 403 | procedure D_Minus (I : IT) is 404 | X : constant Integer_64 := Pop_64 (I); 405 | begin 406 | Push_64 (I, Pop_64 (I) - X); 407 | end D_Minus; 408 | 409 | ------------ 410 | -- D_Plus -- 411 | ------------ 412 | 413 | procedure D_Plus (I : IT) is 414 | begin 415 | Push_64 (I, Pop_64 (I) + Pop_64 (I)); 416 | end D_Plus; 417 | 418 | --------------- 419 | -- D_Smaller -- 420 | --------------- 421 | 422 | procedure D_Smaller (I : IT) is 423 | X : constant Integer_64 := Pop_64 (I); 424 | begin 425 | Push (I, Pop_64 (I) < X); 426 | end D_Smaller; 427 | 428 | --------------- 429 | -- D_Two_Div -- 430 | --------------- 431 | 432 | procedure D_Two_Div (I : IT) is 433 | A : constant Integer_64 := Pop_64 (I); 434 | B : Unsigned_64 := To_Unsigned_64 (A) / 2; 435 | begin 436 | if A < 0 then 437 | B := B or (2 ** 63); 438 | end if; 439 | Push_Unsigned_64 (I, B); 440 | end D_Two_Div; 441 | 442 | ----------------- 443 | -- D_Two_Times -- 444 | ----------------- 445 | 446 | procedure D_Two_Times (I : IT) is 447 | begin 448 | Push_Unsigned_64 (I, Pop_Unsigned_64 (I) * 2); 449 | end D_Two_Times; 450 | 451 | ----------- 452 | -- Depth -- 453 | ----------- 454 | 455 | procedure Depth (I : IT) is 456 | begin 457 | Push (I, Cell (Length (I.Data_Stack))); 458 | end Depth; 459 | 460 | ------------ 461 | -- DivMod -- 462 | ------------ 463 | 464 | procedure DivMod (I : IT) is 465 | B : constant Cell := Pop (I); 466 | A : constant Cell := Pop (I); 467 | begin 468 | Push (I, A rem B); 469 | Push (I, A / B); 470 | end DivMod; 471 | 472 | ------------ 473 | -- DoDoes -- 474 | ------------ 475 | 476 | procedure DoDoes (I : IT) is 477 | begin 478 | -- Patch the latest exit by inserting a call to the current 479 | -- action. 480 | 481 | pragma Assert (Last_Element (I.Compilation_Buffer) = Forth_Exit); 482 | Insert (I.Compilation_Buffer, 483 | Last_Index (I.Compilation_Buffer), 484 | Action_Type'(Kind => Forth_Word, 485 | Immediate => True, 486 | Inline => False, 487 | Forth_Proc => Pop (I))); 488 | end DoDoes; 489 | 490 | ---------- 491 | -- Does -- 492 | ---------- 493 | 494 | procedure Does (I : IT) is 495 | 496 | -- Terminate current word after asking to patch the latest created 497 | -- one. Compilation buffer after index, call to DoDoes and exit 498 | -- is Compilation_Index + 3. 499 | 500 | Does_Part : constant Cell := Last_Index (I.Compilation_Buffer) + 4; 501 | begin 502 | Add_To_Compilation_Buffer (I, Does_Part); 503 | Add_To_Compilation_Buffer (I, DoDoes'Access); 504 | Semicolon (I); 505 | 506 | -- Start an unnamed word corresponding to the DOES> part 507 | 508 | Start_Definition (I); 509 | pragma Assert (Next_Index (I.Compilation_Buffer) = Does_Part); 510 | end Does; 511 | 512 | ---------- 513 | -- Drop -- 514 | ---------- 515 | 516 | procedure Drop (I : IT) is 517 | Value : constant Cell := Pop (I); 518 | pragma Unreferenced (Value); 519 | begin 520 | null; 521 | end Drop; 522 | 523 | --------- 524 | -- Dup -- 525 | --------- 526 | 527 | procedure Dup (I : IT) is 528 | begin 529 | Push (I, Peek (I.Data_Stack)); 530 | end Dup; 531 | 532 | ---------- 533 | -- Emit -- 534 | ---------- 535 | 536 | procedure Emit (I : IT) is 537 | begin 538 | Put (Character'Val (Pop (I))); 539 | end Emit; 540 | 541 | ----------- 542 | -- Equal -- 543 | ----------- 544 | 545 | procedure Equal (I : IT) is 546 | begin 547 | Push (I, Pop (I) = Pop (I)); 548 | end Equal; 549 | 550 | -------------- 551 | -- Evaluate -- 552 | -------------- 553 | 554 | procedure Evaluate (I : IT) is 555 | begin 556 | Interpret_Line (I, To_String (I)); 557 | end Evaluate; 558 | 559 | ------------- 560 | -- Execute -- 561 | ------------- 562 | 563 | procedure Execute (I : IT) is 564 | begin 565 | Execute_Forth_Word (I, Pop (I)); 566 | end Execute; 567 | 568 | -------------------- 569 | -- Execute_Action -- 570 | -------------------- 571 | 572 | procedure Execute_Action (I : IT; Action : Action_Type) is 573 | begin 574 | case Action.Kind is 575 | when Ada_Word => 576 | Action.Ada_Proc.all (I); 577 | when Forth_Word => 578 | Execute_Forth_Word (I, Action.Forth_Proc); 579 | when Number => 580 | Push (I, Action.Value); 581 | end case; 582 | end Execute_Action; 583 | 584 | ------------------------ 585 | -- Execute_Forth_Word -- 586 | ------------------------ 587 | 588 | procedure Execute_Forth_Word (I : IT; Addr : Cell) is 589 | begin 590 | Push (I.Return_Stack, I.Current_IP); 591 | I.Current_IP := Addr; 592 | while not I.Interrupt loop 593 | declare 594 | Current_Action : constant Action_Type := 595 | Element (I.Compilation_Buffer, I.Current_IP); 596 | begin 597 | I.Current_IP := I.Current_IP + 1; 598 | if Current_Action = Forth_Exit then 599 | I.Current_IP := Pop (I.Return_Stack); 600 | return; 601 | end if; 602 | Execute_Action (I, Current_Action); 603 | end; 604 | end loop; 605 | end Execute_Forth_Word; 606 | 607 | ----------- 608 | -- Fetch -- 609 | ----------- 610 | 611 | procedure Fetch (I : IT) is 612 | pragma Warnings (Off); 613 | Addr : constant Cell_Access := 614 | To_Cell_Access (I.Memory (Pop (I))'Access); 615 | pragma Warnings (On); 616 | begin 617 | Push (I, Addr.all); 618 | end Fetch; 619 | 620 | ----------- 621 | -- Fetch -- 622 | ----------- 623 | 624 | function Fetch (I : IT; Addr : Cell) return Cell is 625 | begin 626 | Push (I, Addr); 627 | Fetch (I); 628 | return Pop (I); 629 | end Fetch; 630 | 631 | ---------- 632 | -- Find -- 633 | ---------- 634 | 635 | procedure Find (I : IT) is 636 | C : constant Cell := Peek (I); 637 | A : Action_Type; 638 | begin 639 | Count (I); 640 | A := Find (I, To_String (I)); 641 | Push (I, A.Forth_Proc); 642 | if A.Immediate then 643 | Push (I, 1); 644 | else 645 | Push (I, -1); 646 | end if; 647 | exception 648 | when Word_Not_Found => 649 | Push (I, C); 650 | Push (I, 0); 651 | end Find; 652 | 653 | ---------- 654 | -- Find -- 655 | ---------- 656 | 657 | function Find (I : IT; Name : String) return Action_Type 658 | is 659 | Lower_Name : constant String := To_Lower (Name); 660 | begin 661 | for J in reverse First_Index (I.Dict) .. Last_Index (I.Dict) loop 662 | declare 663 | Current : Dictionary_Entry renames Element (I.Dict, J); 664 | begin 665 | if To_Lower (To_String (Current.Name)) = Lower_Name then 666 | pragma Assert (Current.Action.Kind = Forth_Word); 667 | return Current.Action; 668 | end if; 669 | end; 670 | end loop; 671 | Raise_Word_Not_Found (Name); 672 | end Find; 673 | 674 | ------------------ 675 | -- Fm_Slash_Mod -- 676 | ------------------ 677 | 678 | procedure Fm_Slash_Mod (I : IT) is 679 | Divisor : constant Integer_64 := Integer_64 (Pop (I)); 680 | Dividend : constant Integer_64 := Pop_64 (I); 681 | Remainder : constant Integer_64 := Dividend mod Divisor; 682 | Quotient : constant Integer_64 := (Dividend - Remainder) / Divisor; 683 | begin 684 | Push (I, Cell (Remainder)); 685 | Push_64 (I, Quotient); 686 | Drop (I); 687 | end Fm_Slash_Mod; 688 | 689 | --------------- 690 | -- Forth_And -- 691 | --------------- 692 | 693 | procedure Forth_And (I : IT) is 694 | begin 695 | Push_Unsigned (I, Pop_Unsigned (I) and Pop_Unsigned (I)); 696 | end Forth_And; 697 | 698 | ----------------- 699 | -- Forth_Begin -- 700 | ----------------- 701 | 702 | procedure Forth_Begin (I : IT) is 703 | 704 | -- The structure of the BEGIN/WHILE/REPEAT loop on the compilation 705 | -- stack is: 706 | -- Stack_Marker 707 | -- addr of first WHILE to patch 708 | -- addr of second WHILE to patch 709 | -- ... 710 | -- addr of the beginning of the loop 711 | -- Backward_Reference 712 | 713 | begin 714 | Push (I, Stack_Marker); 715 | Push (I, Next_Index (I.Compilation_Buffer)); 716 | Push (I, Backward_Reference); 717 | end Forth_Begin; 718 | 719 | -------------- 720 | -- Forth_Do -- 721 | -------------- 722 | 723 | procedure Forth_Do (I : IT) is 724 | 725 | -- The structure of a DO - LOOP/+LOOP on the compilation stack 726 | -- is: 727 | -- Stack_Marker 728 | -- addr of the first DO/LEAVE 729 | -- addr of the second LEAVE 730 | -- addr of the third LEAVE 731 | -- ... 732 | -- addr of the beginning of the loop 733 | -- Do_Loop_Reference 734 | -- At run-time, on the return stack, we have: 735 | -- Loop_Limit 736 | -- Loop_Index 737 | 738 | begin 739 | Add_To_Compilation_Buffer (I, Two_To_R'Access); 740 | Push (I, Stack_Marker); 741 | Push (I, Next_Index (I.Compilation_Buffer)); 742 | Push (I, Do_Loop_Reference); 743 | end Forth_Do; 744 | 745 | -------------- 746 | -- Forth_If -- 747 | -------------- 748 | 749 | procedure Forth_If (I : IT) is 750 | begin 751 | Push (I, Next_Index (I.Compilation_Buffer)); 752 | Push (I, Forward_Reference); 753 | Add_To_Compilation_Buffer (I, 0); 754 | Add_To_Compilation_Buffer (I, Jump_If_False'Access); 755 | end Forth_If; 756 | 757 | -------------- 758 | -- Forth_Or -- 759 | -------------- 760 | 761 | procedure Forth_Or (I : IT) is 762 | begin 763 | Push_Unsigned (I, Pop_Unsigned (I) or Pop_Unsigned (I)); 764 | end Forth_Or; 765 | 766 | ---------------- 767 | -- Forth_Then -- 768 | ---------------- 769 | 770 | procedure Forth_Then (I : IT) is 771 | begin 772 | Check_Control_Structure (I, Forward_Reference); 773 | Patch_Jump (I, 774 | To_Patch => Pop (I), 775 | Target => Next_Index (I.Compilation_Buffer)); 776 | end Forth_Then; 777 | 778 | ----------------- 779 | -- Forth_While -- 780 | ----------------- 781 | 782 | procedure Forth_While (I : IT) is 783 | begin 784 | Check_Control_Structure (I, Backward_Reference); 785 | Push (I, Next_Index (I.Compilation_Buffer)); 786 | Swap (I); 787 | Add_To_Compilation_Buffer (I, 0); 788 | Add_To_Compilation_Buffer (I, Jump_If_False'Access); 789 | Push (I, Backward_Reference); 790 | end Forth_While; 791 | 792 | --------------- 793 | -- Forth_Xor -- 794 | --------------- 795 | 796 | procedure Forth_Xor (I : IT) is 797 | begin 798 | Push_Unsigned (I, Pop_Unsigned (I) xor Pop_Unsigned (I)); 799 | end Forth_Xor; 800 | 801 | ---------------------- 802 | -- Free_Interpreter -- 803 | ---------------------- 804 | 805 | procedure Free_Interpreter (I : in out IT) is 806 | procedure Free is 807 | new Ada.Unchecked_Deallocation (Interpreter_Body, Interpreter_Type); 808 | begin 809 | Free (I); 810 | end Free_Interpreter; 811 | 812 | ------------ 813 | -- From_R -- 814 | ------------ 815 | 816 | procedure From_R (I : IT) is 817 | begin 818 | Push (I, Pop (I.Return_Stack)); 819 | end From_R; 820 | 821 | ------------------ 822 | -- Greaterequal -- 823 | ------------------ 824 | 825 | procedure Greaterequal (I : IT) is 826 | B : constant Cell := Pop (I); 827 | begin 828 | Push (I, Pop (I) >= B); 829 | end Greaterequal; 830 | 831 | ------------- 832 | -- Include -- 833 | ------------- 834 | 835 | procedure Include (I : IT) is 836 | begin 837 | Include_File (I, Word (I)); 838 | end Include; 839 | 840 | ------------------ 841 | -- Include_File -- 842 | ------------------ 843 | 844 | procedure Include_File (I : IT; File_Name : String) 845 | is 846 | Previous_Input : constant File_Access := Current_Input; 847 | File : File_Type; 848 | Old_TIB_Count : constant Cell := I.TIB_Count.all; 849 | Old_IN_Ptr : constant Cell := I.IN_Ptr.all; 850 | Old_TIB : constant Byte_Array := 851 | I.Memory (I.TIB .. I.TIB + Old_TIB_Count - 1); 852 | Old_Use_RL : constant Boolean := I.Use_RL; 853 | begin 854 | begin 855 | Open (File, In_File, File_Name); 856 | exception 857 | when Name_Error => 858 | Put_Line ("*** File not found: " & File_Name); 859 | raise; 860 | end; 861 | Set_Input (File); 862 | I.Use_RL := False; 863 | begin 864 | Main_Loop (I); 865 | exception 866 | when End_Error => 867 | Close (File); 868 | Set_Input (Previous_Input.all); 869 | I.Memory (I.TIB .. I.TIB + Old_TIB_Count - 1) := Old_TIB; 870 | I.TIB_Count.all := Old_TIB_Count; 871 | I.IN_Ptr.all := Old_IN_Ptr; 872 | I.Use_RL := Old_Use_RL; 873 | when others => 874 | Close (File); 875 | Set_Input (Previous_Input.all); 876 | I.Use_RL := Old_Use_RL; 877 | raise; 878 | end; 879 | end Include_File; 880 | 881 | ---------------- 882 | -- Initialize -- 883 | ---------------- 884 | 885 | procedure Initialize (I : IT) is 886 | begin 887 | -- Store and register HERE at position 0 888 | -- Bootstrap STATE at position 4 889 | pragma Warnings (Off); 890 | I.State := To_Cell_Access (I.Memory (4)'Access); 891 | pragma Warnings (On); 892 | Store (I, 0, 4); 893 | Start_Definition (I, "(HERE)"); 894 | Add_To_Compilation_Buffer (I, 0); 895 | Semicolon (I); 896 | Remember_Variable (I, "(HERE)", I.Here); 897 | Make_And_Remember_Variable (I, "STATE", I.State); 898 | 899 | -- Default existing variables 900 | Make_And_Remember_Variable (I, "BASE", I.Base, Initial_Value => 10); 901 | Make_And_Remember_Variable (I, "TIB", I.TIB, Size => 1024); 902 | Make_And_Remember_Variable (I, "TIB#", I.TIB_Count); 903 | Make_And_Remember_Variable (I, ">IN", I.IN_Ptr); 904 | 905 | -- Default Ada words 906 | Register_Ada_Word (I, "AGAIN", Again'Access, Immediate => True); 907 | Register_Ada_Word (I, "AHEAD", Ahead'Access, Immediate => True); 908 | Register_Ada_Word (I, "ALIGN", Align'Access); 909 | Register_Ada_Word (I, "BYE", Bye'Access); 910 | Register_Ada_Word (I, "C@", Cfetch'Access); 911 | Register_Ada_Word (I, "COMPILE,", Compile_Comma'Access); 912 | Register_Ada_Word (I, "COUNT", Count'Access); 913 | Register_Ada_Word (I, "C!", Cstore'Access); 914 | Register_Ada_Word (I, ":", Colon'Access); 915 | Register_Ada_Word (I, ":NONAME", Colon_Noname'Access); 916 | Register_Ada_Word (I, "]", Compile_Mode'Access); 917 | Register_Ada_Word (I, "CR", Cr'Access); 918 | Register_Ada_Word (I, "DABS", D_Abs'Access); 919 | Register_Ada_Word (I, "D=", D_Equal'Access); 920 | Register_Ada_Word (I, "DMAX", D_Max'Access); 921 | Register_Ada_Word (I, "DMIN", D_Min'Access); 922 | Register_Ada_Word (I, "D-", D_Minus'Access); 923 | Register_Ada_Word (I, "D+", D_Plus'Access); 924 | Register_Ada_Word (I, "D<", D_Smaller'Access); 925 | Register_Ada_Word (I, "D2/", D_Two_Div'Access); 926 | Register_Ada_Word (I, "D2*", D_Two_Times'Access); 927 | Register_Ada_Word (I, "DEPTH", Depth'Access); 928 | Register_Ada_Word (I, "/MOD", DivMod'Access); 929 | Register_Ada_Word (I, "DOES>", Does'Access, Immediate => True); 930 | Register_Ada_Word (I, "DROP", Drop'Access); 931 | Register_Ada_Word (I, "DUP", Dup'Access); 932 | Register_Ada_Word (I, "EMIT", Emit'Access); 933 | Register_Ada_Word (I, "=", Equal'Access); 934 | Register_Ada_Word (I, "EVALUATE", Evaluate'Access); 935 | Register_Ada_Word (I, "EXECUTE", Execute'Access); 936 | Register_Ada_Word (I, "@", Fetch'Access); 937 | Register_Ada_Word (I, "FIND", Find'Access); 938 | Register_Ada_Word (I, "FM/MOD", Fm_Slash_Mod'Access); 939 | Register_Ada_Word (I, "AND", Forth_And'Access); 940 | Register_Ada_Word (I, "BEGIN", Forth_Begin'Access, Immediate => True); 941 | Register_Ada_Word (I, "DO", Forth_Do'Access, Immediate => True); 942 | Register_Ada_Word (I, "EXIT", Compile_Exit'Access, Immediate => True); 943 | Register_Ada_Word (I, "IF", Forth_If'Access, Immediate => True); 944 | Register_Ada_Word (I, "OR", Forth_Or'Access); 945 | Register_Ada_Word (I, "THEN", Forth_Then'Access, Immediate => True); 946 | Register_Ada_Word (I, "WHILE", Forth_While'Access, Immediate => True); 947 | Register_Ada_Word (I, "XOR", Forth_Xor'Access); 948 | Register_Ada_Word (I, "R>", From_R'Access); 949 | Register_Ada_Word (I, ">=", Greaterequal'Access); 950 | Register_Ada_Word (I, "J", J'Access); 951 | Register_Ada_Word (I, "INCLUDE", Include'Access); 952 | Register_Ada_Word (I, "[", Interpret_Mode'Access, Immediate => True); 953 | Register_Ada_Word (I, "LEAVE", Leave'Access, Immediate => True); 954 | Register_Ada_Word (I, "LITERAL", Literal'Access, Immediate => True); 955 | Register_Ada_Word (I, "LSHIFT", Lshift'Access); 956 | Register_Ada_Word (I, "KEY", Key'Access); 957 | Register_Ada_Word (I, "MS", MS'Access); 958 | Register_Ada_Word (I, "M*", Mstar'Access); 959 | Register_Ada_Word (I, "0<", Negative'Access); 960 | Register_Ada_Word (I, "PARSE", Parse'Access); 961 | Register_Ada_Word (I, "PARSE-WORD", Parse_Word'Access); 962 | Register_Ada_Word (I, "PICK", Pick'Access); 963 | Register_Ada_Word (I, "+", Plus'Access); 964 | Register_Ada_Word (I, "+LOOP", Plus_Loop'Access, Immediate => True); 965 | Register_Ada_Word (I, "POSTPONE", Postpone'Access, Immediate => True); 966 | Register_Ada_Word (I, "QUIT", Quit'Access); 967 | Register_Ada_Word (I, "R@", R_At'Access); 968 | Register_Ada_Word (I, "RECURSE", Recurse'Access, Immediate => True); 969 | Register_Ada_Word (I, "REFILL", Refill'Access); 970 | Register_Ada_Word (I, "REPEAT", Repeat'Access, Immediate => True); 971 | Register_Ada_Word (I, "ROLL", Roll'Access); 972 | Register_Ada_Word (I, "RSHIFT", Rshift'Access); 973 | Register_Ada_Word (I, "S>D", S_To_D'Access); 974 | Register_Ada_Word (I, "*/MOD", ScaleMod'Access); 975 | Register_Ada_Word (I, "SEE", See'Access); 976 | Register_Ada_Word (I, ";", Semicolon'Access, Immediate => True); 977 | Register_Ada_Word (I, "IMMEDIATE", Set_Immediate'Access); 978 | Register_Ada_Word (I, "INLINE", Set_Inline'Access); 979 | Register_Ada_Word (I, "SKIP-BLANKS", Skip_Blanks'Access); 980 | Register_Ada_Word (I, "SM/REM", Sm_Slash_Rem'Access); 981 | Register_Ada_Word (I, "SWAP", Swap'Access); 982 | Register_Ada_Word (I, "!", Store'Access); 983 | Register_Ada_Word (I, "'", Tick'Access); 984 | Register_Ada_Word (I, "*", Times'Access); 985 | Register_Ada_Word (I, ">BODY", To_Body'Access); 986 | Register_Ada_Word (I, ">R", To_R'Access); 987 | Register_Ada_Word (I, "2/", Two_Div'Access); 988 | Register_Ada_Word (I, "2DUP", Two_Dup'Access); 989 | Register_Ada_Word (I, "2R@", Two_R_At'Access); 990 | Register_Ada_Word (I, "2>R", Two_To_R'Access); 991 | Register_Ada_Word (I, "U<", U_Smaller'Access); 992 | Register_Ada_Word (I, "UM/MOD", Um_Slash_Mod'Access); 993 | Register_Ada_Word (I, "UM*", Um_Star'Access); 994 | Register_Ada_Word (I, "UNLOOP", Unloop'Access); 995 | Register_Ada_Word (I, "UNUSED", Unused'Access); 996 | Register_Ada_Word (I, "WORD", Word'Access); 997 | Register_Ada_Word (I, "WORDS", Words'Access); 998 | 999 | for J in Forth.Builtins.Builtins'Range loop 1000 | Interpret_Line (I, Forth.Builtins.Builtins (J) .all); 1001 | end loop; 1002 | 1003 | Readline.Variables.Variable_Bind ("completion-ignore-case", "on"); 1004 | end Initialize; 1005 | 1006 | -------------- 1007 | -- Is_Blank -- 1008 | -------------- 1009 | 1010 | function Is_Blank (C : Character) return Boolean is 1011 | begin 1012 | return C <= ' '; 1013 | end Is_Blank; 1014 | 1015 | --------------- 1016 | -- Interpret -- 1017 | --------------- 1018 | 1019 | procedure Interpret (I : IT) is 1020 | begin 1021 | while not I.Interrupt loop 1022 | declare 1023 | W : constant String := Word (I); 1024 | A : Action_Type; 1025 | C : Cell; 1026 | begin 1027 | if W'Length = 0 then 1028 | exit; 1029 | end if; 1030 | if I.State.all = 0 then 1031 | begin 1032 | A := Find (I, W); 1033 | A.Immediate := True; 1034 | Execute_Action (I, A); 1035 | exception 1036 | when NF : Word_Not_Found => 1037 | begin 1038 | C := Parse_Number (I, W); 1039 | exception 1040 | when Constraint_Error => 1041 | Reraise_Occurrence (NF); 1042 | end; 1043 | Push (I, C); 1044 | when Compile_Only => 1045 | raise Compile_Only with W; 1046 | end; 1047 | else 1048 | begin 1049 | A := Find (I, W); 1050 | if A.Immediate then 1051 | Execute_Action (I, A); 1052 | else 1053 | Add_To_Compilation_Buffer (I, A); 1054 | end if; 1055 | exception 1056 | when NF : Word_Not_Found => 1057 | begin 1058 | C := Parse_Number (I, W); 1059 | exception 1060 | when Constraint_Error => 1061 | Reraise_Occurrence (NF); 1062 | end; 1063 | Add_To_Compilation_Buffer (I, C); 1064 | when Compile_Only => 1065 | raise Compile_Only with W; 1066 | end; 1067 | end if; 1068 | end; 1069 | end loop; 1070 | end Interpret; 1071 | 1072 | -------------------- 1073 | -- Interpret_Line -- 1074 | -------------------- 1075 | 1076 | procedure Interpret_Line (I : IT; Line : String) is 1077 | Saved_Count : constant Cell := I.TIB_Count.all; 1078 | Saved_Content : constant Byte_Array (1 .. TIB_Length) := 1079 | I.Memory (I.TIB .. I.TIB + TIB_Length - 1); 1080 | Saved_Ptr : constant Cell := I.IN_Ptr.all; 1081 | begin 1082 | I.Interrupt := False; 1083 | Refill_Line (I, Line); 1084 | Interpret (I); 1085 | I.Memory (I.TIB .. I.TIB + TIB_Length - 1) := Saved_Content; 1086 | I.TIB_Count.all := Saved_Count; 1087 | I.IN_Ptr.all := Saved_Ptr; 1088 | end Interpret_Line; 1089 | 1090 | -------------------- 1091 | -- Interpret_Mode -- 1092 | -------------------- 1093 | 1094 | procedure Interpret_Mode (I : IT) is 1095 | begin 1096 | I.State.all := 0; 1097 | end Interpret_Mode; 1098 | 1099 | --------------- 1100 | -- Interrupt -- 1101 | --------------- 1102 | 1103 | procedure Interrupt (I : IT) is 1104 | begin 1105 | I.Interrupt := True; 1106 | end Interrupt; 1107 | 1108 | ------- 1109 | -- J -- 1110 | ------- 1111 | 1112 | procedure J (I : IT) is 1113 | begin 1114 | if Length (I.Return_Stack) < 3 then 1115 | raise Stack_Underflow; 1116 | end if; 1117 | Push (I, Element (I.Return_Stack, Length (I.Return_Stack) - 2)); 1118 | end J; 1119 | 1120 | ---------- 1121 | -- Jump -- 1122 | ---------- 1123 | 1124 | procedure Jump (I : IT) is 1125 | begin 1126 | I.Current_IP := Pop (I); 1127 | end Jump; 1128 | 1129 | ------------------- 1130 | -- Jump_If_False -- 1131 | ------------------- 1132 | 1133 | procedure Jump_If_False (I : IT) is 1134 | Target : constant Cell := Pop (I); 1135 | begin 1136 | if Pop (I) = 0 then 1137 | I.Current_IP := Target; 1138 | end if; 1139 | end Jump_If_False; 1140 | 1141 | --------- 1142 | -- Key -- 1143 | --------- 1144 | 1145 | procedure Key (I : IT) is 1146 | C : Character; 1147 | begin 1148 | Get_Immediate (C); 1149 | Push (I, Cell (Character'Pos (C))); 1150 | end Key; 1151 | 1152 | ----------- 1153 | -- Leave -- 1154 | ----------- 1155 | 1156 | procedure Leave (I : IT) is 1157 | begin 1158 | -- Look for Do_Loop_Reference on the stack 1159 | 1160 | for J in reverse 1 .. Length (I.Data_Stack) loop 1161 | if Element (I.Data_Stack, J) = Do_Loop_Reference then 1162 | 1163 | -- Insert the leave information at the proper place 1164 | 1165 | Insert (I.Data_Stack, J - 1, Next_Index (I.Compilation_Buffer)); 1166 | Add_To_Compilation_Buffer (I, 0); 1167 | Add_To_Compilation_Buffer (I, Jump'Access); 1168 | return; 1169 | end if; 1170 | end loop; 1171 | 1172 | raise Unbalanced_Control_Structure; 1173 | end Leave; 1174 | 1175 | ------------- 1176 | -- Literal -- 1177 | ------------- 1178 | 1179 | procedure Literal (I : IT) is 1180 | begin 1181 | Add_To_Compilation_Buffer (I, Pop (I)); 1182 | end Literal; 1183 | 1184 | ------------ 1185 | -- Lshift -- 1186 | ------------ 1187 | 1188 | procedure Lshift (I : IT) is 1189 | U : constant Natural := Natural (Pop_Unsigned (I)); 1190 | begin 1191 | Push (I, Pop (I) * 2 ** U); 1192 | end Lshift; 1193 | 1194 | --------------- 1195 | -- Main_Loop -- 1196 | --------------- 1197 | 1198 | procedure Main_Loop (I : IT) is 1199 | begin 1200 | loop 1201 | Refill (I); 1202 | Interpret (I); 1203 | end loop; 1204 | end Main_Loop; 1205 | 1206 | -------------------------------- 1207 | -- Make_And_Remember_Variable -- 1208 | -------------------------------- 1209 | 1210 | procedure Make_And_Remember_Variable 1211 | (I : IT; 1212 | Name : String; 1213 | Var : out Cell_Access; 1214 | Size : Cell := 4; 1215 | Initial_Value : Cell := 0) 1216 | is 1217 | begin 1218 | Make_Variable (I, Name, Size, Initial_Value); 1219 | Remember_Variable (I, Name, Var); 1220 | end Make_And_Remember_Variable; 1221 | 1222 | -------------------------------- 1223 | -- Make_And_Remember_Variable -- 1224 | -------------------------------- 1225 | 1226 | procedure Make_And_Remember_Variable 1227 | (I : IT; 1228 | Name : String; 1229 | Var : out Cell; 1230 | Size : Cell := 4; 1231 | Initial_Value : Cell := 0) 1232 | is 1233 | begin 1234 | Make_Variable (I, Name, Size, Initial_Value); 1235 | Remember_Variable (I, Name, Var); 1236 | end Make_And_Remember_Variable; 1237 | 1238 | ------------------- 1239 | -- Make_Variable -- 1240 | ------------------- 1241 | 1242 | procedure Make_Variable 1243 | (I : IT; 1244 | Name : String; 1245 | Size : Cell := 4; 1246 | Initial_Value : Cell := 0) 1247 | is 1248 | begin 1249 | if Size = 4 then 1250 | Align (I); 1251 | Store (I, I.Here.all, Initial_Value); 1252 | elsif Initial_Value /= 0 then 1253 | raise Program_Error; 1254 | end if; 1255 | Start_Definition (I, Name); 1256 | Add_To_Compilation_Buffer (I, I.Here.all); 1257 | Semicolon (I); 1258 | I.Here.all := I.Here.all + Size; 1259 | end Make_Variable; 1260 | 1261 | -------- 1262 | -- MS -- 1263 | -------- 1264 | 1265 | procedure MS (I : IT) is 1266 | begin 1267 | delay until Clock + Milliseconds (Integer (Pop (I))); 1268 | end MS; 1269 | 1270 | ----------- 1271 | -- Mstar -- 1272 | ----------- 1273 | 1274 | procedure Mstar (I : IT) is 1275 | begin 1276 | Push_64 (I, Integer_64 (Pop (I)) * Integer_64 (Pop (I))); 1277 | end Mstar; 1278 | 1279 | -------------- 1280 | -- Negative -- 1281 | -------------- 1282 | 1283 | procedure Negative (I : IT) is 1284 | begin 1285 | Push (I, Pop (I) < 0); 1286 | end Negative; 1287 | 1288 | ---------------- 1289 | -- Next_Index -- 1290 | ---------------- 1291 | 1292 | function Next_Index (V : Compilation_Buffers.Vector) return Natural_Cell is 1293 | begin 1294 | return Last_Index (V) + 1; 1295 | end Next_Index; 1296 | 1297 | --------------------- 1298 | -- New_Interpreter -- 1299 | --------------------- 1300 | 1301 | function New_Interpreter 1302 | (Memory_Size : Cell := 65536; 1303 | Stack_Size : Cell := 256) 1304 | return IT is 1305 | begin 1306 | return I : constant IT := new Interpreter_Body (Memory_Size - 1) do 1307 | New_Stack (I.Data_Stack, Stack_Size); 1308 | New_Stack (I.Return_Stack, Stack_Size); 1309 | Initialize (I); 1310 | end return; 1311 | end New_Interpreter; 1312 | 1313 | ----------- 1314 | -- Parse -- 1315 | ----------- 1316 | 1317 | procedure Parse (I : IT) 1318 | is 1319 | Char : constant Unsigned_8 := Unsigned_8 (Pop (I)); 1320 | begin 1321 | Push (I, I.TIB + I.IN_Ptr.all); 1322 | for J in I.IN_Ptr.all .. I.TIB_Count.all - 1 loop 1323 | if I.Memory (I.TIB + J) = Char then 1324 | Push (I, J - I.IN_Ptr.all); 1325 | I.IN_Ptr.all := J + 1; 1326 | return; 1327 | end if; 1328 | end loop; 1329 | Push (I, I.TIB_Count.all - I.IN_Ptr.all); 1330 | I.IN_Ptr.all := I.TIB_Count.all; 1331 | end Parse; 1332 | 1333 | ------------------ 1334 | -- Parse_Number -- 1335 | ------------------ 1336 | 1337 | function Parse_Number (I : IT; S : String) return Cell 1338 | is 1339 | B : constant Unsigned_32 := Unsigned_32 (I.Base.all); 1340 | Negative : Boolean := False; 1341 | Sign_Parsed : Boolean := False; 1342 | Result : Unsigned_32 := 0; 1343 | begin 1344 | for I in S'Range loop 1345 | declare 1346 | C : Character renames S (I); 1347 | begin 1348 | if C = '+' then 1349 | if Sign_Parsed then 1350 | raise Constraint_Error; 1351 | end if; 1352 | elsif C = '-' then 1353 | if Sign_Parsed then 1354 | raise Constraint_Error; 1355 | end if; 1356 | Negative := not Negative; 1357 | else 1358 | declare 1359 | Digit : Unsigned_32; 1360 | begin 1361 | Sign_Parsed := True; 1362 | if C >= '0' and C <= '9' then 1363 | Digit := Character'Pos (C) - Character'Pos ('0'); 1364 | elsif C >= 'A' and C <= 'Z' then 1365 | Digit := 10 + Character'Pos (C) - Character'Pos ('A'); 1366 | elsif C >= 'a' and C <= 'z' then 1367 | Digit := 10 + Character'Pos (C) - Character'Pos ('a'); 1368 | else 1369 | raise Constraint_Error; 1370 | end if; 1371 | if Digit >= B then 1372 | raise Constraint_Error; 1373 | end if; 1374 | Result := Result * B + Digit; 1375 | end; 1376 | end if; 1377 | end; 1378 | end loop; 1379 | if Negative then 1380 | return -To_Cell (Result); 1381 | else 1382 | return To_Cell (Result); 1383 | end if; 1384 | end Parse_Number; 1385 | 1386 | ---------------- 1387 | -- Parse_Word -- 1388 | ---------------- 1389 | 1390 | procedure Parse_Word (I : IT) is 1391 | Origin : Cell; 1392 | begin 1393 | Skip_Blanks (I); 1394 | Origin := I.IN_Ptr.all; 1395 | Push (I, I.TIB + Origin); 1396 | while I.IN_Ptr.all < I.TIB_Count.all loop 1397 | declare 1398 | C : constant Character := 1399 | Character'Val (I.Memory (I.TIB + I.IN_Ptr.all)); 1400 | begin 1401 | I.IN_Ptr.all := I.IN_Ptr.all + 1; 1402 | if Is_Blank (C) then 1403 | Push (I, I.IN_Ptr.all - Origin - 1); 1404 | return; 1405 | end if; 1406 | end; 1407 | end loop; 1408 | Push (I, I.IN_Ptr.all - Origin); 1409 | end Parse_Word; 1410 | 1411 | ---------------- 1412 | -- Patch_Jump -- 1413 | ---------------- 1414 | 1415 | procedure Patch_Jump (I : IT; To_Patch : Cell; Target : Cell) is 1416 | pragma Assert (To_Patch < Next_Index (I.Compilation_Buffer)); 1417 | pragma Assert (Target <= Next_Index (I.Compilation_Buffer)); 1418 | Current : Action_Type := Element (I.Compilation_Buffer, To_Patch); 1419 | begin 1420 | Current.Value := Target; 1421 | Replace_Element (I.Compilation_Buffer, To_Patch, Current); 1422 | end Patch_Jump; 1423 | 1424 | ---------- 1425 | -- Peek -- 1426 | ----------- 1427 | 1428 | function Peek (I : IT) return Cell is 1429 | begin 1430 | return Peek (I.Data_Stack); 1431 | end Peek; 1432 | 1433 | ---------- 1434 | -- Pick -- 1435 | ---------- 1436 | 1437 | procedure Pick (I : IT) is 1438 | How_Deep : constant Integer := Integer (Pop (I)); 1439 | begin 1440 | if How_Deep >= Length (I.Data_Stack) then 1441 | raise Stack_Underflow; 1442 | end if; 1443 | Push (I, Element (I.Data_Stack, Length (I.Data_Stack) - How_Deep)); 1444 | end Pick; 1445 | 1446 | ---------- 1447 | -- Plus -- 1448 | ---------- 1449 | 1450 | procedure Plus (I : IT) is 1451 | begin 1452 | Push (I, Pop (I) + Pop (I)); 1453 | end Plus; 1454 | 1455 | --------------- 1456 | -- Plus_Loop -- 1457 | --------------- 1458 | 1459 | procedure Plus_Loop (I : IT) is 1460 | To_Patch : Cell; 1461 | begin 1462 | Check_Control_Structure (I, Do_Loop_Reference); 1463 | 1464 | -- The standard says: "Add n to the loop index. If the loop 1465 | -- index did not cross the boundary between the loop limit 1466 | -- minus one and the loop limit, continue execution at the 1467 | -- beginning of the loop. Otherwise, discard the current loop 1468 | -- control parameters and continue execution immediately 1469 | -- following the loop." 1470 | -- 1471 | -- In Forth, that is: 1472 | -- dup >r + >r 2dup >r >r >= swap 0< xor 1473 | -- not if [beginning] then unloop 1474 | 1475 | Add_To_Compilation_Buffer (I, Dup'Access); 1476 | Add_To_Compilation_Buffer (I, From_R'Access); 1477 | Add_To_Compilation_Buffer (I, Plus'Access); 1478 | Add_To_Compilation_Buffer (I, From_R'Access); 1479 | Add_To_Compilation_Buffer (I, Two_Dup'Access); 1480 | Add_To_Compilation_Buffer (I, To_R'Access); 1481 | Add_To_Compilation_Buffer (I, To_R'Access); 1482 | Add_To_Compilation_Buffer (I, Greaterequal'Access); 1483 | Add_To_Compilation_Buffer (I, Swap'Access); 1484 | Add_To_Compilation_Buffer (I, Negative'Access); 1485 | Add_To_Compilation_Buffer (I, Forth_Xor'Access); 1486 | Add_To_Compilation_Buffer (I, Pop (I)); 1487 | Add_To_Compilation_Buffer (I, Jump_If_False'Access); 1488 | Add_To_Compilation_Buffer (I, Unloop'Access); 1489 | 1490 | -- Resolve forward references 1491 | 1492 | loop 1493 | To_Patch := Pop (I); 1494 | exit when To_Patch = Stack_Marker; 1495 | Patch_Jump (I, 1496 | To_Patch => To_Patch, 1497 | Target => Next_Index (I.Compilation_Buffer)); 1498 | end loop; 1499 | end Plus_Loop; 1500 | 1501 | --------- 1502 | -- Pop -- 1503 | --------- 1504 | 1505 | function Pop (I : IT) return Cell is 1506 | begin 1507 | return Pop (I.Data_Stack); 1508 | end Pop; 1509 | 1510 | ------------ 1511 | -- Pop_64 -- 1512 | ------------ 1513 | 1514 | function Pop_64 (I : IT) return Integer_64 is 1515 | begin 1516 | return To_Integer_64 (Pop_Unsigned_64 (I)); 1517 | end Pop_64; 1518 | 1519 | ------------------ 1520 | -- Pop_Unsigned -- 1521 | ------------------ 1522 | 1523 | function Pop_Unsigned (I : IT) return Unsigned_32 is 1524 | begin 1525 | return To_Unsigned_32 (Pop (I)); 1526 | end Pop_Unsigned; 1527 | 1528 | --------------------- 1529 | -- Pop_Unsigned_64 -- 1530 | --------------------- 1531 | 1532 | function Pop_Unsigned_64 (I : IT) return Unsigned_64 is 1533 | High : constant Unsigned_64 := Unsigned_64 (Pop_Unsigned (I)) * 2 ** 32; 1534 | begin 1535 | return High + Unsigned_64 (Pop_Unsigned (I)); 1536 | end Pop_Unsigned_64; 1537 | 1538 | -------------- 1539 | -- Postpone -- 1540 | -------------- 1541 | 1542 | procedure Postpone (I : IT) is 1543 | W : constant String := Word (I); 1544 | Action : Action_Type; 1545 | begin 1546 | Action := Find (I, W); 1547 | if Action.Immediate then 1548 | Add_To_Compilation_Buffer (I, Action); 1549 | else 1550 | Add_To_Compilation_Buffer (I, Action.Forth_Proc); 1551 | Add_To_Compilation_Buffer (I, Compile_Comma'Access); 1552 | end if; 1553 | exception 1554 | when Word_Not_Found => 1555 | begin 1556 | Add_To_Compilation_Buffer (I, Parse_Number (I, W)); 1557 | exception 1558 | when Constraint_Error => 1559 | Raise_Word_Not_Found (W); 1560 | end; 1561 | end Postpone; 1562 | 1563 | ---------- 1564 | -- Push -- 1565 | ---------- 1566 | 1567 | procedure Push (I : IT; X : Cell) is 1568 | begin 1569 | Push (I.Data_Stack, X); 1570 | end Push; 1571 | 1572 | ---------- 1573 | -- Push -- 1574 | ---------- 1575 | 1576 | procedure Push (I : IT; B : Boolean) is 1577 | begin 1578 | if B then 1579 | Push (I, -1); 1580 | else 1581 | Push (I, 0); 1582 | end if; 1583 | end Push; 1584 | 1585 | ------------- 1586 | -- Push_64 -- 1587 | ------------- 1588 | 1589 | procedure Push_64 (I : IT; X : Integer_64) is 1590 | begin 1591 | Push_Unsigned_64 (I, To_Unsigned_64 (X)); 1592 | end Push_64; 1593 | 1594 | ------------------- 1595 | -- Push_Unsigned -- 1596 | ------------------- 1597 | 1598 | procedure Push_Unsigned (I : IT; X : Unsigned_32) is 1599 | begin 1600 | Push (I, To_Cell (X)); 1601 | end Push_Unsigned; 1602 | 1603 | ---------------------- 1604 | -- Push_Unsigned_64 -- 1605 | ---------------------- 1606 | 1607 | procedure Push_Unsigned_64 (I : IT; X : Unsigned_64) is 1608 | begin 1609 | Push_Unsigned (I, Unsigned_32 (X mod (2 ** 32))); 1610 | Push_Unsigned (I, Unsigned_32 (X / 2 ** 32)); 1611 | end Push_Unsigned_64; 1612 | 1613 | ---------- 1614 | -- Quit -- 1615 | ---------- 1616 | 1617 | procedure Quit (I : IT) is 1618 | begin 1619 | loop 1620 | Clear (I.Data_Stack); 1621 | Clear (I.Return_Stack); 1622 | Interpret_Mode (I); 1623 | begin 1624 | Main_Loop (I); 1625 | exception 1626 | when Bye_Exception => 1627 | return; 1628 | when End_Error => 1629 | return; 1630 | when NF : Word_Not_Found => 1631 | Put_Line ("*** Word not found: " & Exception_Message (NF)); 1632 | when Stack_Overflow => 1633 | Put_Line ("*** Stack overflow"); 1634 | when Stack_Underflow => 1635 | Put_Line ("*** Stack underflow"); 1636 | when CO : Compile_Only => 1637 | Put_Line ("*** Compile only: " & Exception_Message (CO)); 1638 | when Name_Error => 1639 | -- This exception has already been handled and is getting 1640 | -- reraised. 1641 | null; 1642 | when E : others => 1643 | Put_Line ("*** Exception " & Exception_Name (E) & 1644 | " with message " & 1645 | Exception_Message (E)); 1646 | end; 1647 | end loop; 1648 | end Quit; 1649 | 1650 | ---------- 1651 | -- R_At -- 1652 | ---------- 1653 | 1654 | procedure R_At (I : IT) is 1655 | begin 1656 | Push (I, Peek (I.Return_Stack)); 1657 | end R_At; 1658 | 1659 | ------------- 1660 | -- Recurse -- 1661 | ------------- 1662 | 1663 | procedure Recurse (I : IT) is 1664 | begin 1665 | Add_To_Compilation_Buffer (I, I.Current_Action); 1666 | end Recurse; 1667 | 1668 | ------------ 1669 | -- Refill -- 1670 | ------------ 1671 | 1672 | procedure Refill (I : IT) is 1673 | begin 1674 | if I.Use_RL then 1675 | if I.State.all = 0 then 1676 | Cr (I); 1677 | Refill_Line (I, Readline.Read_Line ("ok> ")); 1678 | else 1679 | Refill_Line (I, Readline.Read_Line ("] ")); 1680 | end if; 1681 | else 1682 | declare 1683 | Buffer : String (1 .. TIB_Length); 1684 | Last : Natural; 1685 | begin 1686 | Get_Line (Buffer, Last); 1687 | Refill_Line (I, Buffer (1 .. Last)); 1688 | end; 1689 | end if; 1690 | end Refill; 1691 | 1692 | ----------------- 1693 | -- Refill_Line -- 1694 | ----------------- 1695 | 1696 | procedure Refill_Line (I : IT; Buffer : String) is 1697 | Last : constant Natural := Natural'Min (Buffer'Length, TIB_Length); 1698 | begin 1699 | for J in 1 .. Integer'Min (Buffer'Length, TIB_Length) loop 1700 | I.Memory (I.TIB + Cell (J) - 1) := Character'Pos (Buffer (J)); 1701 | end loop; 1702 | I.TIB_Count.all := Cell (Last); 1703 | I.IN_Ptr.all := 0; 1704 | end Refill_Line; 1705 | 1706 | -------------- 1707 | -- Register -- 1708 | -------------- 1709 | 1710 | procedure Register 1711 | (I : IT; 1712 | Name : String; 1713 | Action : Action_Type) 1714 | is 1715 | begin 1716 | Append (I.Dict, (Name => To_Unbounded_String (Name), 1717 | Action => Action)); 1718 | Readline.Completion.Add_Word (Name); 1719 | end Register; 1720 | 1721 | ----------------------- 1722 | -- Register_Ada_Word -- 1723 | ----------------------- 1724 | 1725 | procedure Register_Ada_Word 1726 | (I : IT; 1727 | Name : String; 1728 | Word : Ada_Word_Access; 1729 | Immediate : Boolean := False) 1730 | is 1731 | begin 1732 | -- Create a Forth wrapper around an Ada word so that its address 1733 | -- can be taken and passed to EXECUTE. 1734 | 1735 | Start_Definition (I, Name); 1736 | Add_To_Compilation_Buffer (I, Word); 1737 | Semicolon (I); 1738 | if Immediate then 1739 | Set_Immediate (I); 1740 | end if; 1741 | Set_Inline (I); 1742 | end Register_Ada_Word; 1743 | 1744 | ----------------------- 1745 | -- Register_Constant -- 1746 | ----------------------- 1747 | 1748 | procedure Register_Constant 1749 | (I : IT; 1750 | Name : String; 1751 | Value : Cell) 1752 | is 1753 | begin 1754 | Start_Definition (I, Name); 1755 | Add_To_Compilation_Buffer (I, Value); 1756 | Semicolon (I); 1757 | end Register_Constant; 1758 | 1759 | ----------------------- 1760 | -- Remember_Variable -- 1761 | ----------------------- 1762 | 1763 | procedure Remember_Variable 1764 | (I : IT; 1765 | Name : String; 1766 | Var : out Cell_Access) 1767 | is 1768 | begin 1769 | Tick (I, Name); 1770 | To_Body (I); 1771 | pragma Warnings (Off); 1772 | Var := To_Cell_Access (I.Memory (Pop (I)) 'Access); 1773 | pragma Warnings (On); 1774 | end Remember_Variable; 1775 | 1776 | ----------------------- 1777 | -- Remember_Variable -- 1778 | ----------------------- 1779 | 1780 | procedure Remember_Variable 1781 | (I : IT; 1782 | Name : String; 1783 | Var : out Cell) 1784 | is 1785 | begin 1786 | Tick (I, Name); 1787 | To_Body (I); 1788 | Var := Pop (I); 1789 | end Remember_Variable; 1790 | 1791 | ------------ 1792 | -- Repeat -- 1793 | ------------ 1794 | 1795 | procedure Repeat (I : IT) is 1796 | begin 1797 | Check_Control_Structure (I, Backward_Reference); 1798 | Literal (I); 1799 | Add_To_Compilation_Buffer (I, Jump'Access); 1800 | loop 1801 | declare 1802 | To_Fix : constant Cell := Pop (I); 1803 | begin 1804 | exit when To_Fix = Stack_Marker; 1805 | Patch_Jump (I, To_Fix, Next_Index (I.Compilation_Buffer)); 1806 | end; 1807 | end loop; 1808 | end Repeat; 1809 | 1810 | ---------- 1811 | -- Roll -- 1812 | ---------- 1813 | 1814 | procedure Roll (I : IT) is 1815 | Offset : constant Integer := Integer (Pop (I)); 1816 | Index : constant Positive := Length (I.Data_Stack) - Offset; 1817 | begin 1818 | Push (I.Data_Stack, Element (I.Data_Stack, Index)); 1819 | Delete (I.Data_Stack, Index); 1820 | end Roll; 1821 | 1822 | ------------ 1823 | -- Rshift -- 1824 | ------------ 1825 | 1826 | procedure Rshift (I : IT) is 1827 | U : constant Natural := Natural (Pop_Unsigned (I)); 1828 | begin 1829 | Push_Unsigned (I, Pop_Unsigned (I) / 2 ** U); 1830 | end Rshift; 1831 | 1832 | ------------ 1833 | -- S_To_D -- 1834 | ------------ 1835 | 1836 | procedure S_To_D (I : IT) is 1837 | begin 1838 | Push_64 (I, Integer_64 (Pop (I))); 1839 | end S_To_D; 1840 | 1841 | -------------- 1842 | -- ScaleMod -- 1843 | -------------- 1844 | 1845 | procedure ScaleMod (I : IT) is 1846 | begin 1847 | To_R (I); 1848 | Mstar (I); 1849 | From_R (I); 1850 | Sm_Slash_Rem (I); 1851 | end ScaleMod; 1852 | 1853 | --------- 1854 | -- See -- 1855 | --------- 1856 | 1857 | procedure See (I : IT) is 1858 | Index : Cell; 1859 | Action : Action_Type; 1860 | Found : Boolean; 1861 | begin 1862 | Tick (I); 1863 | Index := Pop (I); 1864 | loop 1865 | Found := False; 1866 | Put (Cell'Image (Index) & ": "); 1867 | Action := Element (I.Compilation_Buffer, Index); 1868 | if Action = Forth_Exit then 1869 | Put_Line ("EXIT"); 1870 | exit; 1871 | end if; 1872 | case Action.Kind is 1873 | when Number => 1874 | declare 1875 | S : constant String := Cell'Image (Action.Value); 1876 | begin 1877 | Found := True; 1878 | if Action.Value >= 0 then 1879 | Put_Line (S (2 .. S'Last)); 1880 | else 1881 | Put_Line (S); 1882 | end if; 1883 | end; 1884 | when Forth_Word => 1885 | for J in 1886 | reverse First_Index (I.Dict) .. Last_Index (I.Dict) loop 1887 | declare 1888 | Current : Dictionary_Entry renames Element (I.Dict, J); 1889 | begin 1890 | if Current.Action.Kind = Forth_Word and then 1891 | Current.Action.Forth_Proc = Action.Forth_Proc 1892 | then 1893 | Found := True; 1894 | Put_Line (To_String (Current.Name)); 1895 | exit; 1896 | end if; 1897 | end; 1898 | end loop; 1899 | when Ada_Word => 1900 | if Action.Ada_Proc = Jump'Access then 1901 | Found := True; 1902 | Put_Line (""); 1903 | elsif Action.Ada_Proc = Jump_If_False'Access then 1904 | Found := True; 1905 | Put_Line (""); 1906 | elsif Action.Ada_Proc = DoDoes'Access then 1907 | Found := True; 1908 | Put_Line (""); 1909 | else 1910 | for J in 1911 | reverse First_Index (I.Dict) .. Last_Index (I.Dict) loop 1912 | declare 1913 | Current : Dictionary_Entry renames Element (I.Dict, J); 1914 | begin 1915 | if Current.Action.Kind = Forth_Word then 1916 | declare 1917 | Idx : constant Cell := 1918 | Current.Action.Forth_Proc; 1919 | A : constant Action_Type := 1920 | Element (I.Compilation_Buffer, Idx); 1921 | begin 1922 | if A.Kind = Ada_Word and then 1923 | A.Ada_Proc = Action.Ada_Proc and then 1924 | Element (I.Compilation_Buffer, Idx + 1) = 1925 | Forth_Exit 1926 | then 1927 | Found := True; 1928 | Put_Line (To_String (Current.Name) & 1929 | " "); 1930 | exit; 1931 | end if; 1932 | end; 1933 | end if; 1934 | end; 1935 | end loop; 1936 | end if; 1937 | end case; 1938 | if not Found then 1939 | Put_Line (""); 1940 | end if; 1941 | Index := Index + 1; 1942 | end loop; 1943 | end See; 1944 | 1945 | --------------- 1946 | -- Semicolon -- 1947 | --------------- 1948 | 1949 | procedure Semicolon (I : IT) is 1950 | begin 1951 | Check_Control_Structure (I, Definition_Reference); 1952 | Add_To_Compilation_Buffer (I, Forth_Exit); 1953 | 1954 | -- Current_Name can be null during definition or completion of 1955 | -- a DOES> prefix. 1956 | 1957 | if I.Current_Name /= "" then 1958 | Register (I, To_String (I.Current_Name), I.Current_Action); 1959 | I.Current_Name := To_Unbounded_String (""); 1960 | end if; 1961 | 1962 | Interpret_Mode (I); 1963 | end Semicolon; 1964 | 1965 | ------------------- 1966 | -- Set_Immediate -- 1967 | ------------------- 1968 | 1969 | procedure Set_Immediate (I : IT) is 1970 | Current : Dictionary_Entry := Last_Element (I.Dict); 1971 | begin 1972 | Current.Action.Immediate := True; 1973 | Replace_Element (I.Dict, Last_Index (I.Dict), Current); 1974 | end Set_Immediate; 1975 | 1976 | ---------------- 1977 | -- Set_Inline -- 1978 | ---------------- 1979 | 1980 | procedure Set_Inline (I : IT) is 1981 | Current : Dictionary_Entry := Last_Element (I.Dict); 1982 | begin 1983 | Current.Action.Inline := True; 1984 | Replace_Element (I.Dict, Last_Index (I.Dict), Current); 1985 | end Set_Inline; 1986 | 1987 | ----------------- 1988 | -- Skip_Blanks -- 1989 | ----------------- 1990 | 1991 | procedure Skip_Blanks (I : IT) is 1992 | begin 1993 | while I.IN_Ptr.all < I.TIB_Count.all loop 1994 | exit when 1995 | not Is_Blank (Character'Val (I.Memory (I.TIB + I.IN_Ptr.all))); 1996 | I.IN_Ptr.all := I.IN_Ptr.all + 1; 1997 | end loop; 1998 | end Skip_Blanks; 1999 | 2000 | ------------------ 2001 | -- Sm_Slash_Rem -- 2002 | ------------------ 2003 | 2004 | procedure Sm_Slash_Rem (I : IT) is 2005 | N : constant Integer_64 := Integer_64 (Pop (I)); 2006 | D : constant Integer_64 := Pop_64 (I); 2007 | R : constant Integer_64 := D rem N; 2008 | begin 2009 | Push (I, Cell (R)); 2010 | Push_64 (I, (D - R) / N); 2011 | Drop (I); 2012 | end Sm_Slash_Rem; 2013 | 2014 | ---------------------- 2015 | -- Start_Definition -- 2016 | ---------------------- 2017 | 2018 | procedure Start_Definition (I : IT; Name : String := "") is 2019 | begin 2020 | if Name /= "" then 2021 | I.Current_Name := To_Unbounded_String (Name); 2022 | end if; 2023 | I.Current_Action.Immediate := False; 2024 | I.Current_Action.Forth_Proc := Next_Index (I.Compilation_Buffer); 2025 | Compile_Mode (I); 2026 | Push (I, Definition_Reference); 2027 | end Start_Definition; 2028 | 2029 | ----------- 2030 | -- Store -- 2031 | ----------- 2032 | 2033 | procedure Store (I : IT) 2034 | is 2035 | pragma Warnings (Off); 2036 | Addr : constant Cell_Access := 2037 | To_Cell_Access (I.Memory (Pop (I))'Access); 2038 | pragma Warnings (On); 2039 | begin 2040 | Addr.all := Pop (I); 2041 | end Store; 2042 | 2043 | ----------- 2044 | -- Store -- 2045 | ----------- 2046 | 2047 | procedure Store (I : IT; Addr : Cell; Value : Cell) is 2048 | begin 2049 | Push (I, Value); 2050 | Push (I, Addr); 2051 | Store (I); 2052 | end Store; 2053 | 2054 | ---------- 2055 | -- Swap -- 2056 | ---------- 2057 | 2058 | procedure Swap (I : IT) 2059 | is 2060 | A : constant Cell := Pop (I); 2061 | B : constant Cell := Pop (I); 2062 | begin 2063 | Push (I, A); 2064 | Push (I, B); 2065 | end Swap; 2066 | 2067 | ---------- 2068 | -- Tick -- 2069 | ---------- 2070 | 2071 | procedure Tick (I : IT; Name : String) is 2072 | A : constant Action_Type := Find (I, Name); 2073 | begin 2074 | Push (I, A.Forth_Proc); 2075 | end Tick; 2076 | 2077 | ---------- 2078 | -- Tick -- 2079 | ---------- 2080 | 2081 | procedure Tick (I : IT) is 2082 | begin 2083 | Tick (I, Word (I)); 2084 | end Tick; 2085 | 2086 | ----------- 2087 | -- Times -- 2088 | ----------- 2089 | 2090 | procedure Times (I : IT) is 2091 | begin 2092 | Push (I, Pop (I) * Pop (I)); 2093 | end Times; 2094 | 2095 | ------------- 2096 | -- To_Body -- 2097 | ------------- 2098 | 2099 | procedure To_Body (I : IT) is 2100 | begin 2101 | Push (I, Element (I.Compilation_Buffer, Pop (I)) .Value); 2102 | end To_Body; 2103 | 2104 | ---------- 2105 | -- To_R -- 2106 | ---------- 2107 | 2108 | procedure To_R (I : IT) is 2109 | begin 2110 | Push (I.Return_Stack, Pop (I)); 2111 | end To_R; 2112 | 2113 | --------------- 2114 | -- To_String -- 2115 | --------------- 2116 | 2117 | function To_String (I : IT) return String is 2118 | Length : constant Natural := Natural (Pop (I)); 2119 | Addr : Cell := Pop (I); 2120 | Result : String (1 .. Length); 2121 | begin 2122 | for J in Result'Range loop 2123 | Result (J) := Character'Val (Cfetch (I, Addr)); 2124 | Addr := Addr + 1; 2125 | end loop; 2126 | return Result; 2127 | end To_String; 2128 | 2129 | ------------- 2130 | -- Two_Div -- 2131 | ------------- 2132 | 2133 | procedure Two_Div (I : IT) is 2134 | A : constant Cell := Pop (I); 2135 | B : Unsigned_32 := To_Unsigned_32 (A) / 2; 2136 | begin 2137 | if A < 0 then 2138 | B := B or (2 ** 31); 2139 | end if; 2140 | Push_Unsigned (I, B); 2141 | end Two_Div; 2142 | 2143 | ------------- 2144 | -- Two_Dup -- 2145 | ------------- 2146 | 2147 | procedure Two_Dup (I : IT) is 2148 | A : constant Cell := Pop (I); 2149 | B : constant Cell := Pop (I); 2150 | begin 2151 | Push (I, B); 2152 | Push (I, A); 2153 | Push (I, B); 2154 | Push (I, A); 2155 | end Two_Dup; 2156 | 2157 | -------------- 2158 | -- Two_R_At -- 2159 | -------------- 2160 | 2161 | procedure Two_R_At (I : IT) is 2162 | begin 2163 | Push (I, Element (I.Return_Stack, Length (I.Return_Stack) - 1)); 2164 | Push (I, Peek (I.Return_Stack)); 2165 | end Two_R_At; 2166 | 2167 | -------------- 2168 | -- Two_To_R -- 2169 | -------------- 2170 | 2171 | procedure Two_To_R (I : IT) is 2172 | begin 2173 | Swap (I); 2174 | To_R (I); 2175 | To_R (I); 2176 | end Two_To_R; 2177 | 2178 | --------------- 2179 | -- U_Smaller -- 2180 | --------------- 2181 | 2182 | procedure U_Smaller (I : IT) is 2183 | R : constant Unsigned_32 := Pop_Unsigned (I); 2184 | begin 2185 | Push (I, Pop_Unsigned (I) < R); 2186 | end U_Smaller; 2187 | 2188 | ------------------ 2189 | -- Um_Slash_Mod -- 2190 | ------------------ 2191 | 2192 | procedure Um_Slash_Mod (I : IT) is 2193 | N : constant Unsigned_64 := Unsigned_64 (Pop_Unsigned (I)); 2194 | D : constant Unsigned_64 := Pop_Unsigned_64 (I); 2195 | begin 2196 | Push_Unsigned (I, Unsigned_32 (D mod N)); 2197 | Push_Unsigned_64 (I, D / N); 2198 | Drop (I); 2199 | end Um_Slash_Mod; 2200 | 2201 | ------------- 2202 | -- Um_Star -- 2203 | ------------- 2204 | 2205 | procedure Um_Star (I : IT) is 2206 | begin 2207 | Push_Unsigned_64 (I, Unsigned_64 (Pop_Unsigned (I)) * 2208 | Unsigned_64 (Pop_Unsigned (I))); 2209 | end Um_Star; 2210 | 2211 | ------------ 2212 | -- Unloop -- 2213 | ------------ 2214 | 2215 | procedure Unloop (I : IT) is 2216 | begin 2217 | Delete_Last (I.Return_Stack); 2218 | Delete_Last (I.Return_Stack); 2219 | end Unloop; 2220 | 2221 | ------------ 2222 | -- Unused -- 2223 | ------------ 2224 | 2225 | procedure Unused (I : IT) is 2226 | begin 2227 | Push (I, I.Memory'Last - I.Here.all + 1); 2228 | end Unused; 2229 | 2230 | ---------- 2231 | -- Word -- 2232 | ---------- 2233 | 2234 | procedure Word (I : IT) is 2235 | Length : Cell; 2236 | Addr : Cell; 2237 | begin 2238 | Parse (I); 2239 | Length := Pop (I); 2240 | Addr := Pop (I); 2241 | I.Memory (Addr - 1) := Unsigned_8 (Length); 2242 | Push (I, Addr - 1); 2243 | end Word; 2244 | 2245 | ---------- 2246 | -- Word -- 2247 | ---------- 2248 | 2249 | function Word (I : IT) return String is 2250 | begin 2251 | Parse_Word (I); 2252 | return To_String (I); 2253 | end Word; 2254 | 2255 | ----------- 2256 | -- Words -- 2257 | ----------- 2258 | 2259 | procedure Words (I : IT) is 2260 | Len : Natural := 0; 2261 | begin 2262 | for J in First_Index (I.Dict) .. Last_Index (I.Dict) loop 2263 | declare 2264 | Current : Dictionary_Entry renames Element (I.Dict, J); 2265 | begin 2266 | Len := Len + Length (Current.Name) + 1; 2267 | if Len > 75 then 2268 | New_Line; 2269 | Len := Length (Current.Name); 2270 | elsif J /= First_Index (I.Dict) then 2271 | Put (' '); 2272 | end if; 2273 | Put (To_String (Current.Name)); 2274 | end; 2275 | end loop; 2276 | end Words; 2277 | 2278 | end Forth.Interpreter; 2279 | -------------------------------------------------------------------------------- /forth-interpreter.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- F O R T H . I N T E R P R E T E R -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Containers.Vectors; 33 | with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 34 | with Forth.Stacks; 35 | with Forth.Types; use Forth.Types; 36 | with Interfaces; use Interfaces; 37 | 38 | package Forth.Interpreter is 39 | 40 | pragma Elaborate_Body; 41 | 42 | type Interpreter_Type is private; 43 | 44 | subtype IT is Interpreter_Type; 45 | -- Shortcut 46 | 47 | type Cell_Access is access all Cell; 48 | pragma No_Strict_Aliasing (Cell_Access); 49 | 50 | type Ada_Word_Access is access procedure (I : IT); 51 | 52 | function New_Interpreter 53 | (Memory_Size : Cell := 65536; 54 | Stack_Size : Cell := 256) 55 | return IT; 56 | -- Memory size is in bytes, stack size is in cells. Both data and return 57 | -- stacks are bounded to avoid runaway memory exhaustion. 58 | 59 | procedure Free_Interpreter (I : in out IT); 60 | -- Reclaim the memory used by the interpreter. After this call, the 61 | -- interpreter cannot be used anymore. 62 | 63 | procedure Push (I : IT; X : Cell); 64 | procedure Push_Unsigned (I : IT; X : Unsigned_32); 65 | procedure Push_Unsigned_64 (I : IT; X : Unsigned_64); 66 | procedure Push_64 (I : IT; X : Integer_64); 67 | procedure Push (I : IT; B : Boolean); 68 | function Pop (I : IT) return Cell; 69 | function Pop_Unsigned (I : IT) return Unsigned_32; 70 | function Pop_64 (I : IT) return Integer_64; 71 | function Pop_Unsigned_64 (I : IT) return Unsigned_64; 72 | -- Shortcut operating on Data_Stack 73 | 74 | procedure Make_And_Remember_Variable 75 | (I : IT; 76 | Name : String; 77 | Var : out Cell_Access; 78 | Size : Cell := 4; 79 | Initial_Value : Cell := 0); 80 | 81 | procedure Make_And_Remember_Variable 82 | (I : IT; 83 | Name : String; 84 | Var : out Cell; 85 | Size : Cell := 4; 86 | Initial_Value : Cell := 0); 87 | 88 | function Fetch (I : IT; Addr : Cell) return Cell; 89 | function Cfetch (I : IT; Addr : Cell) return Cell; 90 | procedure Store (I : IT; Addr : Cell; Value : Cell); 91 | 92 | procedure Make_Variable 93 | (I : IT; 94 | Name : String; 95 | Size : Cell := 4; 96 | Initial_Value : Cell := 0); 97 | 98 | procedure Register_Ada_Word 99 | (I : IT; 100 | Name : String; 101 | Word : Ada_Word_Access; 102 | Immediate : Boolean := False); 103 | 104 | procedure Register_Constant 105 | (I : IT; 106 | Name : String; 107 | Value : Cell); 108 | 109 | procedure Include_File (I : IT; File_Name : String); 110 | -- This may raise Ada.IO_Exceptions.Name_Error if the file cannot be found, 111 | -- or Bye_Exception if the "BYE" word is used while reading the file. 112 | 113 | procedure Interpret_Line (I : IT; Line : String); 114 | 115 | procedure Interrupt (I : IT); 116 | 117 | -- Predefined Ada words 118 | procedure Again (I : IT); 119 | procedure Ahead (I : IT); 120 | procedure Align (I : IT); 121 | procedure Bye (I : IT); 122 | procedure Cfetch (I : IT); 123 | procedure Colon (I : IT); 124 | procedure Colon_Noname (I : IT); 125 | procedure Compile_Comma (I : IT); 126 | procedure Compile_Exit (I : IT); 127 | procedure Compile_Mode (I : IT); 128 | procedure Count (I : IT); 129 | procedure Cr (I : IT); 130 | procedure Cstore (I : IT); 131 | procedure D_Abs (I : IT); 132 | procedure D_Equal (I : IT); 133 | procedure D_Max (I : IT); 134 | procedure D_Min (I : IT); 135 | procedure D_Minus (I : IT); 136 | procedure D_Plus (I : IT); 137 | procedure D_Smaller (I : IT); 138 | procedure D_Two_Div (I : IT); 139 | procedure D_Two_Times (I : IT); 140 | procedure Depth (I : IT); 141 | procedure DivMod (I : IT); 142 | procedure Does (I : IT); 143 | procedure Drop (I : IT); 144 | procedure Dup (I : IT); 145 | procedure Emit (I : IT); 146 | procedure Equal (I : IT); 147 | procedure Evaluate (I : IT); 148 | procedure Execute (I : IT); 149 | procedure Fetch (I : IT); 150 | procedure Find (I : IT); 151 | procedure Fm_Slash_Mod (I : IT); 152 | procedure Forth_And (I : IT); 153 | procedure Forth_Begin (I : IT); 154 | procedure Forth_Do (I : IT); 155 | procedure Forth_If (I : IT); 156 | procedure Forth_Or (I : IT); 157 | procedure Forth_Then (I : IT); 158 | procedure Forth_While (I : IT); 159 | procedure Forth_Xor (I : IT); 160 | procedure From_R (I : IT); 161 | procedure Greaterequal (I : IT); 162 | procedure Include (I : IT); 163 | procedure Interpret (I : IT); 164 | procedure Interpret_Mode (I : IT); 165 | procedure J (I : IT); 166 | procedure Key (I : IT); 167 | procedure Leave (I : IT); 168 | procedure Literal (I : IT); 169 | procedure Lshift (I : IT); 170 | procedure MS (I : IT); 171 | procedure Mstar (I : IT); 172 | procedure Negative (I : IT); 173 | procedure Parse (I : IT); 174 | procedure Parse_Word (I : IT); 175 | procedure Pick (I : IT); 176 | procedure Plus (I : IT); 177 | procedure Plus_Loop (I : IT); 178 | procedure Postpone (I : IT); 179 | procedure Quit (I : IT); 180 | procedure R_At (I : IT); 181 | procedure Recurse (I : IT); 182 | procedure Refill (I : IT); 183 | procedure Repeat (I : IT); 184 | procedure Roll (I : IT); 185 | procedure Rshift (I : IT); 186 | procedure S_To_D (I : IT); 187 | procedure ScaleMod (I : IT); 188 | procedure See (I : IT); 189 | procedure Semicolon (I : IT); 190 | procedure Set_Immediate (I : IT); 191 | procedure Set_Inline (I : IT); 192 | procedure Skip_Blanks (I : IT); 193 | procedure Sm_Slash_Rem (I : IT); 194 | procedure Store (I : IT); 195 | procedure Swap (I : IT); 196 | procedure Tick (I : IT); 197 | procedure Times (I : IT); 198 | procedure To_Body (I : IT); 199 | procedure To_R (I : IT); 200 | procedure Two_Div (I : IT); 201 | procedure Two_Dup (I : IT); 202 | procedure Two_R_At (I : IT); 203 | procedure Two_To_R (I : IT); 204 | procedure U_Smaller (I : IT); 205 | procedure Um_Slash_Mod (I : IT); 206 | procedure Um_Star (I : IT); 207 | procedure Unloop (I : IT); 208 | procedure Unused (I : IT); 209 | procedure Word (I : IT); 210 | procedure Words (I : IT); 211 | 212 | private 213 | 214 | use Forth.Stacks; 215 | 216 | type Action_Kind is (Ada_Word, Forth_Word, Number); 217 | 218 | type Action_Type (Kind : Action_Kind := Number) is record 219 | Immediate : Boolean; 220 | case Kind is 221 | when Ada_Word => 222 | Ada_Proc : Ada_Word_Access; 223 | when Forth_Word => 224 | Forth_Proc : Cell; 225 | Inline : Boolean := False; 226 | when Number => 227 | Value : Cell; 228 | end case; 229 | end record; 230 | 231 | subtype Natural_Cell is Cell range 1 .. Cell'Last; 232 | package Compilation_Buffers is 233 | new Ada.Containers.Vectors (Natural_Cell, Action_Type); 234 | 235 | type Dictionary_Entry is record 236 | Name : Unbounded_String; 237 | Action : Action_Type; 238 | end record; 239 | 240 | package Dictionaries is 241 | new Ada.Containers.Vectors (Positive, Dictionary_Entry); 242 | 243 | type Byte_Array is array (Cell range <>) of aliased Unsigned_8; 244 | 245 | type Byte_Access is access all Unsigned_8; 246 | 247 | type Interpreter_Body (Last_Address : Cell) is record 248 | Data_Stack : Stack_Type; 249 | Return_Stack : Stack_Type; 250 | Compilation_Buffer : Compilation_Buffers.Vector; 251 | Dict : Dictionaries.Vector; 252 | Memory : Byte_Array (0 .. Last_Address); 253 | Here : Cell_Access; 254 | Base : Cell_Access; 255 | TIB : Cell; 256 | TIB_Count : Cell_Access; 257 | IN_Ptr : Cell_Access; 258 | State : Cell_Access; 259 | Current_Name : Unbounded_String; 260 | Current_Action : Action_Type (Forth_Word); 261 | Current_IP : Cell := -1; 262 | Use_RL : Boolean := True; 263 | Interrupt : Boolean := False; 264 | end record; 265 | 266 | type Interpreter_Type is access Interpreter_Body; 267 | 268 | end Forth.Interpreter; 269 | -------------------------------------------------------------------------------- /forth-stacks.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- F O R T H . S T A C K S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Unchecked_Deallocation; 33 | 34 | package body Forth.Stacks is 35 | 36 | procedure Check_For_Room (S : Stack_Type); 37 | -- Check that there is still room to insert an element in the stack. 38 | -- If there is not, raise Stack_Overflow. 39 | 40 | -------------------- 41 | -- Check_For_Room -- 42 | -------------------- 43 | 44 | procedure Check_For_Room (S : Stack_Type) is 45 | begin 46 | if Cell (Length (S) + 1) > S.Size then 47 | raise Stack_Overflow; 48 | end if; 49 | end Check_For_Room; 50 | 51 | ----------- 52 | -- Clear -- 53 | ----------- 54 | 55 | procedure Clear (S : Stack_Type) is 56 | begin 57 | S.Data.Clear; 58 | end Clear; 59 | 60 | ------------ 61 | -- Delete -- 62 | ------------ 63 | 64 | procedure Delete (S : Stack_Type; I : Positive) is 65 | begin 66 | if Length (S) < I then 67 | raise Stack_Underflow; 68 | end if; 69 | S.Data.Delete (I); 70 | end Delete; 71 | 72 | ----------------- 73 | -- Delete_Last -- 74 | ----------------- 75 | 76 | procedure Delete_Last (S : Stack_Type) is 77 | begin 78 | if S.Data.Is_Empty then 79 | raise Stack_Underflow; 80 | end if; 81 | S.Data.Delete_Last; 82 | end Delete_Last; 83 | 84 | ------------- 85 | -- Element -- 86 | ------------- 87 | 88 | function Element (S : Stack_Type; I : Positive) return Cell is 89 | begin 90 | if Length (S) < I then 91 | raise Stack_Underflow; 92 | end if; 93 | return S.Data.Element (I); 94 | end Element; 95 | 96 | -------------- 97 | -- Finalize -- 98 | -------------- 99 | 100 | procedure Finalize (Stack : in out Stack_Type) is 101 | procedure Free is 102 | new Ada.Unchecked_Deallocation (Stacks.Vector, Stack_Access); 103 | begin 104 | Free (Stack.Data); 105 | end Finalize; 106 | 107 | ------------ 108 | -- Insert -- 109 | ------------ 110 | 111 | procedure Insert (S : Stack_Type; I : Positive; C : Cell) is 112 | begin 113 | if Length (S) < I then 114 | raise Stack_Underflow; 115 | end if; 116 | Check_For_Room (S); 117 | S.Data.Insert (I, C); 118 | end Insert; 119 | 120 | -------------- 121 | -- Is_Empty -- 122 | -------------- 123 | 124 | function Is_Empty (S : Stack_Type) return Boolean is 125 | begin 126 | return S.Data.Is_Empty; 127 | end Is_Empty; 128 | 129 | ------------ 130 | -- Length -- 131 | ------------ 132 | 133 | function Length (S : Stack_Type) return Natural is 134 | begin 135 | return Natural (S.Data.Length); 136 | end Length; 137 | 138 | --------------- 139 | -- New_Stack -- 140 | --------------- 141 | 142 | procedure New_Stack (Stack : out Stack_Type; Stack_Size : Cell) is 143 | begin 144 | Stack.Data := new Stacks.Vector; 145 | Stack.Size := Stack_Size; 146 | end New_Stack; 147 | 148 | ---------- 149 | -- Peek -- 150 | ---------- 151 | 152 | function Peek (S : Stack_Type) return Cell is 153 | begin 154 | if S.Data.Is_Empty then 155 | raise Stack_Underflow; 156 | end if; 157 | return S.Data.Last_Element; 158 | end Peek; 159 | 160 | --------- 161 | -- Pop -- 162 | --------- 163 | 164 | function Pop (S : Stack_Type) return Cell is 165 | begin 166 | if S.Data.Is_Empty then 167 | raise Stack_Underflow; 168 | end if; 169 | return Result : Cell do 170 | Result := S.Data.Last_Element; 171 | S.Data.Delete_Last; 172 | end return; 173 | end Pop; 174 | 175 | ---------- 176 | -- Push -- 177 | ---------- 178 | 179 | procedure Push (S : Stack_Type; X : Cell) is 180 | begin 181 | Check_For_Room (S); 182 | S.Data.Append (X); 183 | end Push; 184 | 185 | end Forth.Stacks; 186 | -------------------------------------------------------------------------------- /forth-stacks.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- F O R T H . S T A C K S -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Containers.Vectors; 33 | with Ada.Finalization; 34 | with Forth.Types; use Forth.Types; 35 | 36 | package Forth.Stacks is 37 | 38 | pragma Preelaborate; 39 | 40 | type Stack_Type is limited private; 41 | -- The stack elements go from 1 to Length (Stack) 42 | 43 | procedure New_Stack (Stack : out Stack_Type; Stack_Size : Cell); 44 | -- Create a new empty stack 45 | 46 | procedure Push (S : Stack_Type; X : Cell); 47 | -- Push an element to the top of the stack 48 | 49 | function Pop (S : Stack_Type) return Cell; 50 | -- Remove the element from the top of the stack 51 | 52 | function Peek (S : Stack_Type) return Cell; 53 | -- Return the top of the stack 54 | 55 | function Length (S : Stack_Type) return Natural; 56 | -- Return the number of elements on the stack 57 | 58 | function Element (S : Stack_Type; I : Positive) return Cell; 59 | -- Return one element from the stack 60 | 61 | function Is_Empty (S : Stack_Type) return Boolean; 62 | -- Check whether the stack is empty 63 | 64 | procedure Clear (S : Stack_Type); 65 | -- Clear the stack 66 | 67 | procedure Insert (S : Stack_Type; I : Positive; C : Cell); 68 | -- Insert an element before position I 69 | 70 | procedure Delete (S : Stack_Type; I : Positive); 71 | -- Remove the element at position I 72 | 73 | procedure Delete_Last (S : Stack_Type); 74 | -- Remove the last element of the stack 75 | 76 | private 77 | 78 | package Stacks is 79 | new Ada.Containers.Vectors (Positive, Cell); 80 | 81 | type Stack_Access is access Stacks.Vector; 82 | 83 | type Stack_Type is new Ada.Finalization.Limited_Controlled with record 84 | Data : Stack_Access; 85 | Size : Cell; 86 | end record; 87 | 88 | procedure Finalize (Stack : in out Stack_Type); 89 | 90 | end Forth.Stacks; 91 | -------------------------------------------------------------------------------- /forth-types.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- F O R T H . T Y P E S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | package body Forth.Types is 33 | 34 | -------------------------- 35 | -- Raise_Word_Not_Found -- 36 | -------------------------- 37 | 38 | procedure Raise_Word_Not_Found (Word : String) is 39 | begin 40 | raise Word_Not_Found with Word; 41 | end Raise_Word_Not_Found; 42 | 43 | end Forth.Types; 44 | -------------------------------------------------------------------------------- /forth-types.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- F O R T H . T Y P E S -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Interfaces; use Interfaces; 33 | 34 | package Forth.Types is 35 | 36 | pragma Pure; 37 | 38 | type Cell is new Integer_32; 39 | 40 | type Cell_Array is array (Positive range <>) of Cell; 41 | 42 | Bye_Exception : exception; 43 | Compile_Only : exception; 44 | Stack_Overflow : exception; 45 | Stack_Underflow : exception; 46 | Unbalanced_Control_Structure : exception; 47 | Word_Not_Found : exception; 48 | 49 | procedure Raise_Word_Not_Found (Word : String); 50 | pragma No_Return (Raise_Word_Not_Found); 51 | 52 | end Forth.Types; 53 | -------------------------------------------------------------------------------- /forth.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- AFORTH COMPONENTS -- 4 | -- -- 5 | -- F O R T H -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- Copyright (C) 2006-2011 Samuel Tardieu -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- The main repository for this software is located at: -- 28 | -- http://git.rfc1149.net/aforth.git -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | pragma License (Modified_GPL); 33 | 34 | package Forth is 35 | 36 | pragma Pure; 37 | 38 | end Forth; 39 | -------------------------------------------------------------------------------- /gnat.adc: -------------------------------------------------------------------------------- 1 | pragma Profile (Ravenscar); 2 | -------------------------------------------------------------------------------- /t/Makefile: -------------------------------------------------------------------------------- 1 | check: 2 | @set -e && for f in *.fs; do \ 3 | bash run-test.sh $$f; \ 4 | done 5 | -------------------------------------------------------------------------------- /t/again.fs: -------------------------------------------------------------------------------- 1 | : t 3 begin dup . dup 0= if bye then 1- again CHAR . emit ; t \ 3210 2 | -------------------------------------------------------------------------------- /t/align.fs: -------------------------------------------------------------------------------- 1 | align here align here swap - . \ 0 2 | 1 allot here align here swap - . \ 3 3 | here 4 mod . \ 0 4 | -------------------------------------------------------------------------------- /t/base.fs: -------------------------------------------------------------------------------- 1 | f \ *** Word not found: f 2 | hex 3 | f . \ F 4 | F . \ F 5 | g \ *** Word not found: g 6 | decimal 7 | f . \ *** Word not found: f 8 | -------------------------------------------------------------------------------- /t/bye.fs: -------------------------------------------------------------------------------- 1 | 1 . \ 1 2 | bye 3 | 2 . 4 | -------------------------------------------------------------------------------- /t/compile-only.fs: -------------------------------------------------------------------------------- 1 | then \ *** Compile only: then 2 | -------------------------------------------------------------------------------- /t/conditionals.fs: -------------------------------------------------------------------------------- 1 | : test if ." true" else ." false" then cr ; 2 | 1 test \ true 3 | 0 test \ false 4 | -------------------------------------------------------------------------------- /t/create-does.fs: -------------------------------------------------------------------------------- 1 | : mkthing create , , does> dup @ 2 * swap cell+ @ + ; 2 | 5 7 mkthing thing 3 | depth . \ 0 4 | thing . \ 19 5 | -------------------------------------------------------------------------------- /t/evaluate.fs: -------------------------------------------------------------------------------- 1 | : make s" : foo 1 2 + ;" ; 2 | make evaluate 3 | foo . \ 3 4 | 5 | : make s" : bar 1 2 + ;" evaluate ; 6 | make 7 | bar . \ 3 8 | 9 | : str s" 3 4 +" ; immediate 10 | : eva evaluate ; immediate 11 | 12 | : make str eva ; 13 | .s \ <0> 14 | make . \ 7 15 | -------------------------------------------------------------------------------- /t/exit.fs: -------------------------------------------------------------------------------- 1 | : t 1 2 exit 3 4 ; t .s \ <2> 1 2 2 | -------------------------------------------------------------------------------- /t/fetch-store.fs: -------------------------------------------------------------------------------- 1 | variable foobar 2 | 50331651 foobar ! .s \ <0> 3 | foobar @ . \ 50331651 4 | foobar c@ . \ 3 5 | foobar 1 + c@ . \ 0 6 | foobar 2 + c@ . \ 0 7 | foobar 3 + c@ . \ 3 8 | 2 foobar 1 + c! 9 | 2 foobar 2 + c! 10 | foobar @ .s \ <1> 50463235 11 | -------------------------------------------------------------------------------- /t/find.fs: -------------------------------------------------------------------------------- 1 | : t c" foobar" ; t find . drop \ 0 2 | : t c" \" ; t find . drop \ 1 3 | : t c" find" ; t find . drop \ -1 4 | -------------------------------------------------------------------------------- /t/fm-mod.fs: -------------------------------------------------------------------------------- 1 | 7 s>d -3 fm/mod .s \ <2> -2 -3 2 | clear 3 | -7 s>d 3 fm/mod .s \ <2> 2 -3 4 | -------------------------------------------------------------------------------- /t/include-helper.fs: -------------------------------------------------------------------------------- 1 | 3 2 + . \ 5 2 | -------------------------------------------------------------------------------- /t/include.fs: -------------------------------------------------------------------------------- 1 | include ../include-helper.fs \ 5 2 | include non-existent \ *** File not found: non-existent 3 | -------------------------------------------------------------------------------- /t/j.fs: -------------------------------------------------------------------------------- 1 | : t 4 0 do 1 0 do j loop loop ; t .s \ <4> 0 1 2 3 2 | -------------------------------------------------------------------------------- /t/leave.fs: -------------------------------------------------------------------------------- 1 | : test 5 0 do i 3 = if leave then loop ; 2 | -------------------------------------------------------------------------------- /t/loops.fs: -------------------------------------------------------------------------------- 1 | : test 5 0 do i loop ; 2 | test .s \ <5> 0 1 2 3 4 3 | 4 | clear 5 | 6 | : test 0 5 do i -1 +loop ; 7 | test .s \ <6> 5 4 3 2 1 0 8 | -------------------------------------------------------------------------------- /t/parse.fs: -------------------------------------------------------------------------------- 1 | : test [char] " parse type ; 2 | test foobar" .s \ foobar<0> 3 | 4 | : test c" count" count type ; 5 | test .s \ count<0> -------------------------------------------------------------------------------- /t/picture.fs: -------------------------------------------------------------------------------- 1 | 1 31 lshift . cr \ -2147483648 2 | 12345 . cr \ 12345 3 | -12345 . cr \ -12345 4 | hex 1AFBC . cr \ 1AFBC 5 | -1 2 BASE ! . cr \ -1 6 | decimal 7 | 1 31 lshift 8 | 1 - 2 base ! . cr \ 1111111111111111111111111111111 9 | -------------------------------------------------------------------------------- /t/recurse.fs: -------------------------------------------------------------------------------- 1 | : factorial dup 2 > if dup 1- recurse * then ; 2 | 1 factorial . \ 1 3 | 10 factorial . \ 3628800 4 | -------------------------------------------------------------------------------- /t/run-test.sh: -------------------------------------------------------------------------------- 1 | # 2 | # Tests helper functions and setup 3 | # 4 | 5 | filter() { 6 | sed -e 's/\xd//' -e '/^ok>/d' -e '/^]/d' -e 's/\\ .*//' -e 's/^ *//' -e 's/ *$//' -e '/^$/d' 7 | } 8 | 9 | fail() { 10 | echo $1 11 | printf "(test can be examined in directory $testdir)" 12 | echo 13 | mycat Errors 14 | mycat Commands 15 | mycat Output 16 | mycat Expected 17 | exit 1 18 | } 19 | 20 | mycat() { 21 | echo 22 | echo "$1:" 23 | sed -e 's/^/ /' < $(echo $1 | tr A-Z a-z) 24 | } 25 | 26 | set -e 27 | 28 | testfile=$1 29 | testname=$(echo $(basename $testfile) | sed -e 's/\.fs$//') 30 | 31 | rm -rf scratch.$testname.* 32 | testdir=scratch.$testname.$$ 33 | mkdir -p $testdir 34 | cd $testdir 35 | 36 | echo -n "Testing $testname... " 37 | 38 | (cat ../$testfile; echo) > commands 39 | 40 | sed -ne 's/^.*\\ \(.*\)/\1/p' < commands | filter > expected 41 | ../../aforth < commands | filter > output 2> errors 42 | if [ $? -ne 0 ] ; then 43 | fail "bad exit code $?" 44 | fi 45 | if [ -s errors ]; then 46 | fail "standard error not empty" 47 | fi 48 | if ! cmp output expected > /dev/null; then 49 | fail "bad output" 50 | fi 51 | echo "ok" 52 | cd .. 53 | rm -rf $testdir 54 | -------------------------------------------------------------------------------- /t/scale-mod.fs: -------------------------------------------------------------------------------- 1 | 7 2 -3 */mod .s \ <2> 2 -4 2 | -------------------------------------------------------------------------------- /t/sm-rem.fs: -------------------------------------------------------------------------------- 1 | 7 s>d -3 sm/rem .s \ <2> 1 -2 2 | clear 3 | -7 s>d 3 sm/rem .s \ <2> -1 -2 4 | -------------------------------------------------------------------------------- /t/stack-depth.fs: -------------------------------------------------------------------------------- 1 | .s cr \ <0> 2 | 10 20 .s cr \ <2> 10 20 3 | depth . cr \ 2 4 | clear depth . cr \ 0 5 | -------------------------------------------------------------------------------- /t/stack-overflow.fs: -------------------------------------------------------------------------------- 1 | : overflow ( -- ) 1 recurse ; overflow \ *** Stack overflow 2 | -------------------------------------------------------------------------------- /t/stack-underflow.fs: -------------------------------------------------------------------------------- 1 | dup \ *** Stack underflow 2 | 1 2 .s cr \ <2> 1 2 3 | 2drop 3 4 .s cr \ <2> 3 4 4 | drop .s cr \ <1> 3 5 | 2drop \ *** Stack underflow 6 | .s cr \ <0> 7 | -------------------------------------------------------------------------------- /t/twodiv.fs: -------------------------------------------------------------------------------- 1 | -1 2/ . \ -1 2 | -2 2/ . \ -1 3 | -------------------------------------------------------------------------------- /t/um-mod.fs: -------------------------------------------------------------------------------- 1 | 0 0 1 um/mod .s \ <2> 0 0 2 | clear 3 | 1 0 1 um/mod .s \ <2> 0 1 4 | clear 5 | 1 0 2 um/mod .s \ <2> 1 0 6 | clear 7 | 3 0 2 um/mod .s \ <2> 1 1 8 | -------------------------------------------------------------------------------- /t/value.fs: -------------------------------------------------------------------------------- 1 | 5 value toto 2 | toto . \ 5 3 | 3 to toto 4 | toto . \ 3 5 | 3 to foobar \ *** Word not found: foobar 6 | -------------------------------------------------------------------------------- /t/while.fs: -------------------------------------------------------------------------------- 1 | : t 5 begin dup . space dup while 1- repeat [CHAR] . emit ; t \ 5 4 3 2 1 0 . 2 | : odd 2 mod 1 = ; 3 | : t 5 begin dup . space dup while dup odd while 1- repeat [CHAR] . emit ; t \ 5 4 . 4 | : t 5 begin dup . space dup odd while dup while 1- repeat [CHAR] . emit ; t \ 5 4 . 5 | --------------------------------------------------------------------------------