├── .gitattributes ├── .github └── workflows │ └── c-cpp.yml ├── .gitignore ├── .gitmodules ├── COPYING ├── Makefile.am ├── README ├── README.md ├── build-aux ├── .gitignore └── install-executor ├── configure.ac ├── doc ├── .gitignore ├── Makefile.am ├── TODO.txt ├── ideas.md └── pforth.tex ├── extras ├── DoubleARM.txt ├── Makefile.am ├── ackermann.fs ├── armfpasm.fs ├── redefinition.fs └── string.fs └── src ├── .gitignore ├── Makefile.am ├── accept.fs ├── assembler.fs ├── call-cells.fs ├── code.fs ├── compiler-asm.fs ├── compiler-defer.fs ├── compiler-postpone.fs ├── compiler.fs ├── compiler1.fs ├── compiler2.fs ├── compiler4.fs ├── compiler5.fs ├── control1.fs ├── control2.fs ├── control3.fs ├── defer-fetch-store.fs ├── defining.fs ├── does.fs ├── extra-primitives.fs ├── fileio.fs ├── highlevel.fs.in ├── init-space.fs ├── initialize.fs ├── interpreter3.fs ├── make.fs ├── mangle.fs ├── native-call.fs ├── opcodes.fs ├── os-compiler.fs ├── os.fs ├── parse-command-line.fs ├── pforth-32.bin ├── pforth-64.bin ├── pforth.s ├── pforthi.in ├── platform.fs ├── primitives.fs ├── resolver-branch.fs ├── save.fs ├── strings2a.fs ├── strings2b.fs ├── system-params.fs ├── terminal.fs ├── util.fs └── vocabulary.fs /.gitattributes: -------------------------------------------------------------------------------- 1 | # Disable text line ending translation for Forth sources 2 | # pForth can’t cope with CRLF line endings! 3 | *.fs -text 4 | -------------------------------------------------------------------------------- /.github/workflows/c-cpp.yml: -------------------------------------------------------------------------------- 1 | name: C/C++ CI 2 | 3 | on: [ push, pull_request ] 4 | 5 | jobs: 6 | build: 7 | strategy: 8 | matrix: 9 | os: [ubuntu-latest, macos-latest] 10 | include: 11 | - os: ubuntu-latest 12 | shell: bash 13 | - os: macos-latest 14 | shell: bash 15 | - os: windows-latest 16 | sys: mingw64 17 | arch: x86_64 18 | shell: msys2 19 | sudo_flag: --no-sudo 20 | # FIXME: Bee doesn't currently build on 32-bit systems: https://github.com/rrthomas/bee/issues/17 21 | # - os: windows-latest 22 | # sys: mingw32 23 | # arch: i686 24 | # shell: msys2 25 | # sudo_flag: --no-sudo 26 | runs-on: ${{ matrix.os }} 27 | defaults: 28 | run: 29 | shell: ${{ matrix.shell }} {0} 30 | steps: 31 | - uses: msys2/setup-msys2@v2 32 | if: ${{ matrix.os == 'windows-latest' }} 33 | with: 34 | release: false 35 | msystem: ${{matrix.sys}} 36 | install: >- 37 | patch git groff help2man 38 | mingw-w64-${{matrix.arch}}-autotools 39 | mingw-w64-${{matrix.arch}}-gcc 40 | - uses: actions/checkout@v3 41 | with: 42 | submodules: true 43 | - name: Install dependencies (Ubuntu) 44 | if: ${{ matrix.os == 'ubuntu-latest' }} 45 | run: sudo apt-get -y install texlive-latex-extra texlive-science texlive-fonts-recommended texlive-fonts-extra tex-gyre help2man latexmk rlwrap 46 | - name: Install dependencies (macOS) 47 | if: ${{ matrix.os == 'macos-latest' }} 48 | run: | 49 | brew install help2man automake 50 | # Prepend optional brew binary directories to PATH 51 | echo "/usr/local/opt/m4/bin" >> $GITHUB_PATH 52 | - name: Set up environment (Windows) 53 | if: ${{ matrix.os == 'windows-latest' }} 54 | run: | 55 | # Define _POSIX to get a full set of POSIX signal names from signal.h on mingw 56 | echo "CPPFLAGS=-D_POSIX" >> $GITHUB_ENV 57 | - name: Install VM executor 58 | run: | 59 | ./build-aux/install-executor ${{ matrix.sudo_flag }} 60 | if test ${{ matrix.os }} = ubuntu-latest; then sudo ldconfig; fi 61 | - name: Build 62 | run: | 63 | autoreconf -i && ./configure --enable-silent-rules 64 | if test ${{ matrix.os }} = ubuntu-latest; then make distcheck; else make check; fi 65 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | Makefile.in 3 | /aclocal.m4 4 | /autom4te.cache/ 5 | /config.log 6 | /config.status 7 | /configure 8 | /INSTALL 9 | /pforth-*.tar.gz 10 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "doc/bibtex"] 2 | path = doc/bibtex 3 | url = https://github.com/rrthomas/bibtex.git 4 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 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.am: -------------------------------------------------------------------------------- 1 | # Top-level Makefile.am 2 | # 3 | # (c) Reuben Thomas 2018-2020 4 | # 5 | # The package is distributed under the GNU GPL version 3, or, at your 6 | # option, any later version. 7 | # 8 | # THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | # RISK. 10 | 11 | SUBDIRS = src doc extras 12 | 13 | EXTRA_DIST = README.md 14 | 15 | release: distcheck 16 | git diff --exit-code && \ 17 | git tag -a -m "Release tag" "v$(VERSION)" && \ 18 | git push && git push --tags && \ 19 | woger github \ 20 | github_user=rrthomas \ 21 | package=pforth \ 22 | version=$(VERSION) \ 23 | dist_type=tar.gz 24 | 25 | distcheck-hook: 26 | touch $(srcdir)/src/highlevel.fs.in 27 | 28 | # Ignore built files that are part of the distribution (specifically, 29 | # src/*/pforth). 30 | distcleancheck_listfiles = \ 31 | find . -type f -exec sh -c 'test -f $(srcdir)/$$1 || echo $$1' \ 32 | sh '{}' ';' 33 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pForth 2 | 3 | https://github.com/rrthomas/pforth 4 | 5 | by Reuben Thomas 6 | 7 | pForth is a simple ANS Forth compiler, intended for portability and study. 8 | It has been principally used as an environment for building other Forth 9 | compilers: metacompiling itself for the 10 | [Bee](https://github.com/rrthomas/bee) portable virtual machine; compiling a 11 | cut-down version called mForth (now defunct) for RISC OS and the 12 | [Beetle](https://github.com/rrthomas/beetle) virtual machine, and building 13 | [Machine Forth](https://rrt.sc3d.org/Software/Forth) systems. 14 | 15 | pForth is released purely in the hope that it might be interesting or useful 16 | to someone. 17 | 18 | (I am aware that there are other Forth compilers called pForth; the 19 | duplication was unintentional.) 20 | 21 | pForth comes pre-compiled for Bee (`src/pforth-32.bin` and 22 | `src/pforth-64.bin`). 23 | 24 | See `doc/pforth.pdf` for ANSI conformance information. 25 | 26 | 27 | ## Copyright and Disclaimer 28 | 29 | The package is distributed under the GNU Public License version 3, or, at 30 | your option, any later version. See the file COPYING. 31 | 32 | THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER'S RISK. 33 | 34 | 35 | ## Installation 36 | 37 | Bee version 1 is required (see above) in either a 32- or 64-bit build. 38 | 39 | To build the documentation, a comprehensive TeX system such as TeXLive is 40 | required. 41 | 42 | ### Building from a release tarball 43 | 44 | From an unpacked release tarball, run: 45 | 46 | ``` 47 | ./configure && make && make check && [sudo] make install 48 | ``` 49 | 50 | See the file `INSTALL` or the output of `./configure --help` for more 51 | information. 52 | 53 | ### Building from git 54 | 55 | To build from a git checkout, GNU autotools (autoconf and automake) are also 56 | required. Run: 57 | 58 | ``` 59 | git submodule update --init --recursive 60 | autoreconf -fi 61 | ``` 62 | 63 | and then proceed as above for a release build. 64 | 65 | 66 | ## Acknowledgements 67 | 68 | Thanks to the authors of RISC Forth, the first Forth system I studied closely, 69 | which inspired me to write pForth. 70 | 71 | 72 | ## Bugs and comments 73 | 74 | Please file bug reports and make comments on 75 | [GitHub](https://github.com/rrthomas/pforth/issues), or by email (see 76 | above). 77 | 78 | I will probably fix any bugs. Any future development is likely to involve a 79 | total rewrite; I'm particularly interested in rewriting pForth in a more 80 | Forth-like manner (more decomposed, rather than implementing each word as a 81 | single word), and perhaps using object orientation. See `doc/TODO.txt`. 82 | -------------------------------------------------------------------------------- /build-aux/.gitignore: -------------------------------------------------------------------------------- 1 | /install-sh 2 | /missing 3 | -------------------------------------------------------------------------------- /build-aux/install-executor: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Install Bee (used for CI) 3 | # 4 | # (c) Reuben Thomas 2018-2023 5 | # 6 | # This file is in the public domain. 7 | 8 | SUDO=sudo 9 | if test "$1" = "--no-sudo"; then 10 | shift 11 | SUDO="" 12 | fi 13 | 14 | cd $HOME 15 | git clone --branch v1.0 https://github.com/rrthomas/bee.git 16 | cd bee 17 | ./bootstrap && ./configure --enable-silent-rules && make check && $SUDO make install 18 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # configure.ac 2 | # 3 | # (c) Reuben Thomas 2018-2022 4 | # 5 | # The package is distributed under the GNU GPL version 3, or, at your 6 | # option, any later version. 7 | # 8 | # THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | # RISK. 10 | 11 | AC_INIT(pForth, 0.82, rrt@sc3d.org) 12 | AC_CONFIG_AUX_DIR([build-aux]) 13 | AM_INIT_AUTOMAKE([-Wall foreign]) 14 | 15 | dnl Check for programs 16 | AC_PROG_LN_S 17 | AC_PATH_PROG(LATEXMK, latexmk, true) 18 | AM_CONDITIONAL([HAVE_LATEXMK], [test "$ac_cv_path_LATEXMK" != "true"]) 19 | 20 | dnl Check for Bee and its binutils 21 | AC_PROG_GREP 22 | AC_PATH_PROG([BEE], [bee]) 23 | AS_IF([test "$ac_cv_path_BEE" = ""], 24 | AC_MSG_ERROR([Could not find Bee])) 25 | AS_IF([$ac_cv_path_BEE --version | $GREP -q 64-bit], [bee_word_bits=64], [bee_word_bits=32]) 26 | AS_IF([! $ac_cv_path_BEE $srcdir/src/pforth-$bee_word_bits.bin --evaluate BYE], 27 | [AC_MSG_ERROR([$ac_cv_path_BEE does not work!])]) 28 | AC_SUBST([bee_word_bits]) 29 | AC_PATH_PROG([AS], [bee-as], [true]) 30 | AC_PATH_PROG([OBJCOPY], [bee-objcopy], [true]) 31 | 32 | dnl Readline wrapper 33 | AC_PATH_PROG(RLWRAP, rlwrap) 34 | AM_CONDITIONAL([HAVE_RLWRAP], [test -n "$ac_cv_path_RLWRAP"]) 35 | 36 | dnl Code counting 37 | AM_EXTRA_RECURSIVE_TARGETS([loc]) 38 | AC_PATH_PROG(CLOC, cloc, true) 39 | CLOC_OPTS=--force-lang="Forth",fs 40 | AC_SUBST([CLOC_OPTS]) 41 | 42 | dnl Generate output files 43 | AC_CONFIG_FILES([ 44 | Makefile 45 | src/Makefile 46 | src/pforthi 47 | src/highlevel.fs 48 | doc/Makefile 49 | extras/Makefile 50 | ]) 51 | AC_OUTPUT 52 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.bbl 3 | *.blg 4 | *.fls 5 | *.fdb_latexmk 6 | *.log 7 | *.pdf 8 | *.synctex.gz 9 | -------------------------------------------------------------------------------- /doc/Makefile.am: -------------------------------------------------------------------------------- 1 | # Docs Makefile.am 2 | # 3 | # (c) Reuben Thomas 2018-2020 4 | # 5 | # The package is distributed under the GNU GPL version 3, or, at your 6 | # option, any later version. 7 | # 8 | # THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | # RISK. 10 | 11 | LATEX_SRCS = \ 12 | $(srcdir)/pforth.tex \ 13 | $(srcdir)/bibtex/bib/vm.bib 14 | 15 | LATEX_PDFS = \ 16 | pforth.pdf 17 | 18 | if HAVE_LATEXMK 19 | dist_doc_DATA = $(LATEX_PDFS) 20 | endif 21 | 22 | all: pdf 23 | 24 | pdf-local: $(LATEX_PDFS) 25 | 26 | MAINTAINERCLEANFILES = $(LATEX_PDFS) 27 | 28 | LATEXMK_OPTS = -bibtex -pdf 29 | 30 | clean-local: 31 | $(LATEXMK) $(LATEXMK_OPTS) -C $(LATEX_SRCS) 32 | 33 | EXTRA_DIST = $(LATEX_SRCS) $(LATEX_PDFS) \ 34 | ideas.md TODO.txt 35 | 36 | .tex.pdf: 37 | env BIBINPUTS=$(abs_srcdir)/bibtex/bib $(LATEXMK) $(LATEXMK_OPTS) $< 38 | -------------------------------------------------------------------------------- /doc/TODO.txt: -------------------------------------------------------------------------------- 1 | This file, written by Reuben Thomas, is in the public domain. 2 | 3 | Have SIGINT handler in interpreter loop. Process Ctrl+D as normal. 4 | 5 | Add startup script support using environment variable PFORTH_INIT (needs 6 | getenv), and use this to replace extended image building (works for RISC OS 7 | too!). 8 | 9 | Document the compiler relative to the Forth 2012 standard. 10 | 11 | Add backtrace to error output. 12 | 13 | Support objects. 14 | 15 | Support locals. 16 | 17 | Add TIMES combinator and use in assembler. 18 | 19 | Make pForth case-insensitive for word lookup, or downcase it all. 20 | 21 | Add assembler to base image. 22 | 23 | Obviate the need for the compilation method field (>COMPILE) by using 24 | cmForth-like compilation word list. But this does prevent it being possible 25 | to have separate execution and interpretation semantics at compile time. Or, 26 | have a stateless always-compiling compiler, where running out of code to 27 | compile before ; causes the code compiled so far to be executed and thrown 28 | away. 29 | 30 | 31 | The future of pForth: 32 | 33 | All the stuff below still applies if I feel like doing anything to the Forth 34 | system itself. Indeed, it may well provide a good starting point for many of 35 | the Tau structures, though I'll probably want to develop the language first. 36 | 37 | 38 | Add INLINE name and ( xt ) INLINE, for compiling in-line code. 39 | 40 | Have DLITERAL, as the current way of doing double literals is rather 41 | unportable. 42 | 43 | Have proper escape and error handlers that throw an exception. Use exceptions 44 | in the file words instead of return codes (have a switch to go between 45 | returning codes and throwing exceptions). 46 | 47 | Metacompilation: all defining words should be classes; then during 48 | metacompilation there's two versions of each class, one implemented by the 49 | cross-compiler, and one in the compiled implementation. Using something like 50 | delegation, metacompiled classes can delegate to a class in the metacompiler, 51 | or (much of the time) delegate wholesale to the standard class (when the 52 | structure of the metacompiled class is the same). 53 | 54 | Continue to reengineer HighLevel code: 55 | 56 | 0. OOPify; this takes in all the steps below. Rewrite the metacompiler to use 57 | objects whose methods are different depending on whether we're in the 58 | compiler or metacompiler (this is really contexts). 59 | 60 | 1. Factor long definitions. Especially, re-engineer code that deals with 61 | input source in a much more OOP manner into one package for each type of 62 | input stream (string, terminal, files): have an input source object whose 63 | methods (SOURCE-ID, SOURCE, SAVE-INPUT, RESTORE-INPUT &c.) can be called. 64 | 65 | 2. Break up HighLevel into multiple source files: do it by wordset: then can 66 | build versions of pForth with any specified wordsets, and later wordsets 67 | ought to be able to be loaded on top of older ones. The hard thing will be to 68 | deal with words whose semantics are extended by different wordsets, 69 | especially those whose semantics are extended more than once. pForth's own 70 | words such as the forward refs compiler tools ought to have their own 71 | wordsets. 72 | 73 | 3. Add memory allocation and use for transient buffers. Using for 74 | dictionaries has two obvious problems: first, need to auto-extend areas being 75 | compiled into (or shrink to fit at end); second, generating a meta-compiled 76 | image will be harder. 77 | 78 | 4. Make general-purpose forward-reference mechanism (using CATCH/THROW around 79 | ordinary INTERPRET, and existing forward resolution mechanism). Needs memory 80 | allocation to be able to start a new definition when half-way through the 81 | current one. 82 | 83 | 5. Reorganize the mess over wordlists (FOREIGN &c.); there must be a simpler 84 | way of handling metacompilation using a more OOP approach (so that even 85 | different dictionary structures can be accomodated). Wordlists in the search 86 | order should call their method (inherited from their dictionary) for 87 | scanning themselves, and report whether the word found is executable on the 88 | current system or not. 89 | 90 | 6. Need a mechanism for handling system-specific replacement code; then can 91 | replace bits all the way from a simple VM implementation (Tau?) down to a 92 | highly OS-integrated one which replaces ACCEPT &c. Again, use objects. 93 | 94 | 7. Don't interpret, always compile, by default as a :NONAME. Use separate 95 | control stack: if when the input source becomes empty the control stack is 96 | empty, execute. (Defining words put a placeholder on the control stack; [ 97 | and ] must temporarily stash the top value.) This gets rid of STATE and 98 | dual-action (compile/interpret) words. Hopefully (there may be some traps in 99 | ANS). -------------------------------------------------------------------------------- /doc/ideas.md: -------------------------------------------------------------------------------- 1 | This file is (c) Reuben Thomas 1995-2020, and is in the public domain. 2 | 3 | # Input stack 4 | 5 | Could generalise the input stream to be a stack. Have a specification for 6 | each stream giving its handle (e.g. a filename, file handle+ptr+length, 7 | address+length &c.). Also have a flag specifying whether the end of the 8 | stream counts as EOL or not. Then can splice into the middle of a source by 9 | copying its specifiers and changing the length and starting address (to do 10 | this, need to have a known start address and length for the source that is to 11 | be split). 12 | 13 | # Object-oriented Forth syntax 14 | 15 | CREATE[ ... ] for per-instance declarations. Need non-parsing versions of 16 | VARIABLE, VALUE etc. Then can say e.g. 17 | 18 | CREATE[ S" FOO" VARIABLE 42 S" BAR" VALUE ] 19 | 20 | DOES[ ... ] for methods. Go into interpretation mode after DOES[ and compile 21 | into a (per-class) private dictionary. 22 | 23 | DOES> and CREATE work as normal: CREATE is effectively CREATE[ ] and DOES> is 24 | DOES[ : DOES-METHOD ... ; DEFAULT ]. 25 | 26 | DEFAULT after a declaration in CREATE[ ... ] or DOES[ ... ] makes that method 27 | the default. 28 | 29 | Modify the parser to allow the following syntax: 30 | 31 | object executes default method of object 32 | object.method executes method of object 33 | class_method executes method of class on the object on the stack 34 | O' object returns the object pointer of object. 35 | 36 | Can parse the top three after attempting to parse a token as a number (should 37 | be before for efficiency, but after for ANS compatibility; and yet not, as if 38 | no non-ANSI object words are created, this effect will not occur). 39 | 40 | # Partial evaluation 41 | 42 | Newsgroups: comp.lang.forth 43 | Subject: Partial evaluation: a code generation mechanism (long) 44 | Organization: University of Cambridge, England 45 | 46 | Optimising compilers, particularly of functional languages, are often seen 47 | as partial evaluators, and it occurred to me a little while ago that this 48 | idea could be applied to Forth. More recently, it occurred to me that this 49 | would not necessarily change the semantics of the language at all (at 50 | least, not of ANS Standard Forth). 51 | 52 | The scheme goes like this: 53 | 54 | Instead of the traditional distinction between interpretation and 55 | compilation, the distinction is made between full and partial evaluation. 56 | These work as follows: 57 | 58 | * With full evaluation, all code entered is compiled and then executed. 59 | Hence the phrase A B ... Z is treated as if it had been entered 60 | 61 | :NONAME A B ... Z ; EXECUTE 62 | 63 | in a Standard system. Code is executed as soon as it can be, so that for 64 | example 65 | 66 | 4 2 + 67 | 68 | causes "4" then "2" then "+" to be executed, while 69 | 70 | TRUE IF 15 ELSE 14 THEN 71 | 72 | causes "TRUE IF 15 ELSE 14 THEN" to be executed, as the control 73 | structure can only be executed when it has been terminated (of course, if 74 | we were being really clever, we could execute "15" as soon as we'd found 75 | "TRUE IF" and simply discard "ELSE 14 THEN"). 76 | 77 | * Partial evaluation is the same, except that whenever a non-manifest 78 | quantity is referred to evaluation stops and the code that has been 79 | compiled so far is added to the dictionary plus the offending reference to 80 | a non-manifest quantity. Partial evaluation then starts afresh. A 81 | non-manifest quantity is one that is not known at compile-time. This can 82 | be: 83 | 84 | 1. A stack location whose contents was not put there by the code being 85 | compiled 86 | 2. A memory location whose contents was not stored by the code being 87 | compiled 88 | 3. The result of an I/O operation 89 | 90 | The final result of the partial evaluation is also compiled. Hence, the 91 | phrase 92 | 93 | 4 2 + SWAP 1 3 * 94 | 95 | would cause the code "4" "2" and "+" to be executed, then "6 SWAP" to be 96 | compiled when "SWAP" is found, which refers to a stack item not put there 97 | by the code so far. Finally, "1" "3" and "*" are executed and "3" is 98 | compiled. This is rather like the phrase 99 | 100 | [ 4 2 + ] LITERAL SWAP [ 1 3 * ] LITERAL 101 | 102 | in Standard Forth. 103 | 104 | The simplest implementation of this evaluation mechanism is a table of 105 | known memory locations. Whenever a location is stored to, it is added to 106 | the table, or altered if it is already held there. This requires a few 107 | words such as ! and +! to be trapped. Whenever a location is read (@ &c.) 108 | the list is scanned to see if it is known. Whenever an unknown location is 109 | read from, partial evaluation halts. 110 | 111 | A special stack could also be used, with markers to represent unknown 112 | quantities. Stack operators such as OVER and SWAP do not stop partial 113 | evaluation; only words that use the value, such as +, cause it to halt. At 114 | that point, code must be compiled to put the unknown quantities at the 115 | correct positions on the stack. This requires far more words to be trapped 116 | than simply memory references, but produces more efficient code, 117 | especially on systems in which the stack's address is not fixed. 118 | 119 | : switches into partial evaluation mode, and ; into full evaluation mode. 120 | Hence, the definition 121 | 122 | : FOO 4 2 + * ; 123 | 124 | causes "6 *" to be compiled. In a Standard system we might have written 125 | 126 | : FOO [ 4 2 + ] LITERAL * ; 127 | 128 | to get the same effect, but here we don't have to. The beauty of the new 129 | system is that all values that can be reduced to literals are, without the 130 | programmer having to specify them, and without compromising readability. 131 | However, this is only the beginning: a word such as 132 | 133 | : FACT5* 1 5 BEGIN ?DUP WHILE TUCK * SWAP 1- REPEAT * ; 134 | 135 | would be compiled as "120 *". Arbitrary control structures can be used 136 | without the awkwardness or waste of memory of the usual circumlocution: 137 | 138 | : FACT5 1 5 BEGIN ?DUP WHILE TUCK * SWAP 1- REPEAT ; 139 | : FACT5* [ FACT5 ] LITERAL * ; 140 | 141 | Also, if the stack is modelled, many stack overheads disappear; the word 142 | 143 | 'BUFFER COUNT 144 | 145 | might be compiled as if written 146 | 147 | [ 'BUFFER CHAR+ ] LITERAL [ 'BUFFER ] LITERAL C@ 148 | 149 | if COUNT were defined 150 | 151 | : COUNT DUP CHAR+ SWAP C@ ; 152 | 153 | In some ways, this is worse code, but if we take clever code generation a 154 | stage further and assume we are generating native machine code, it is easy 155 | to see how positions on the stack could be mapped on to machine registers 156 | and quite efficient code generated. 157 | 158 | Although partial evaluation does not give particularly good optimisation 159 | for typical code which makes heavy use of non-manifest quantities, it 160 | nevertheless performs some useful inter-word optimisations, and 161 | additionally can be used to aid native code generation for register 162 | machines, because it turns stack operations into memory stores. Also, 163 | because it is so simple, uniform and low-level, it might be a good 164 | mechanism for object-oriented systems, where different degrees of opacity 165 | could be specified for partial evaluation. For example, method calls could 166 | be treated as non-manifest to allow dynamic binding, or as manifest, so 167 | that more efficient code could be generated. 168 | 169 | Finally, introduced with care, it could be used in an ANS Standard system, 170 | thanks to the Standard's being specified in semantic terms (though this 171 | extensional approach grates with the simpler intensional stance of the 172 | traditional Forth model, it is one of the Standard's greatest strengths). 173 | Such a compiler would extend the Standard, for example by allowing control 174 | structures to be used in interpretive mode, without breaching it. 175 | 176 | --{End of message}-- 177 | 178 | Heuristic for stopping unbounded code expansion: set some factor (e.g. 2) 179 | above which code will not be expanded over the unevaluated version. 180 | 181 | # Direct threading 182 | 183 | Use 4-byte addresses, with the bottom two bits as follows: 184 | 185 | 00 - next word is code 186 | 01 - next word is data 187 | 10 - string follows (length in count byte) 188 | 11 - end of code (EXIT) or native code/data follows 189 | 190 | Could use relative addressing. 191 | -------------------------------------------------------------------------------- /doc/pforth.tex: -------------------------------------------------------------------------------- 1 | % 2 | % Documentation for pForth 3 | % 4 | % Reuben Thomas 5 | % 6 | % Started 14/1/95 7 | % 8 | % (c) Reuben Thomas 1995-2020 9 | % 10 | % The package is distributed under the GNU GPL version 3, or, at your 11 | % option, any later version. 12 | % 13 | % THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 14 | % RISK. 15 | 16 | \documentclass[english]{article} 17 | \usepackage[utf8x]{inputenc} 18 | \usepackage{a4,newpxtext,url} 19 | 20 | 21 | % Alter some default parameters for general typesetting 22 | 23 | \parindent=0pt 24 | \parskip=1.5ex plus 0.5ex 25 | \topskip=0pt 26 | \emergencystretch=12pt 27 | 28 | \frenchspacing 29 | 30 | 31 | % Font for stack pictures; macro \spic includes italic correction 32 | 33 | \newcommand{\spic}[1]{{\it #1\/}} 34 | 35 | 36 | \begin{document} 37 | 38 | \title{The pForth Forth compiler} 39 | \author{Reuben Thomas} 40 | \date{13th February 2018} 41 | \maketitle 42 | 43 | 44 | \section{Introduction} 45 | 46 | pForth is a Forth compiler which complies with the ANSI Forth standard~\cite{ANSIforth}. Is is designed to be a teaching tool and portable Forth compiler. It has been implemented for the Beetle VM and on Acorn RISC OS. It is written mostly in standard Forth, so that the workings of the compiler can be examined and understood by students learning the language; the compiler itself can be used to illustrate the language and the ANSI standard. Some primitive functions are written in assembly code, and the compiler has a few environmental dependencies, such as requiring twos-complement arithmetic, which are exploited to make the system simpler. 47 | 48 | Because it is designed to be easily understood and ported, the compiler is 49 | simple, using few optimisations, and with little error checking. It does not 50 | implement the whole of the ANSI standard, notably omitting floating point arithmetic. 51 | 52 | pForth also implements parts of the draft Forth 2012 standard. See section~\ref{forth2012} for details. 53 | 54 | 55 | \section{Documentation required by the ANSI standard} 56 | 57 | Section~\ref{labelling} contains the ANS labelling for pForth; the other 58 | sections give the documentation required in \cite[section 4.1]{ANSIforth}, 59 | laid out like the corresponding sections in the standard. 60 | 61 | 62 | \subsection{Labelling} 63 | \label{labelling} 64 | 65 | pForth is an ANS Forth System 66 | \vspace{-3mm} 67 | \begin{itemize} 68 | \item[]providing the Core Extensions word set (except {\tt CONVERT}, {\tt EXPECT}, {\tt SPAN} and {\tt UNUSED}), 69 | \item[]providing {\tt D+}, {\tt D.}, {\tt D.R}, {\tt D0=}, {\tt D>S}, {\tt DABS}, {\tt DNEGATE}, {\tt M+} and {\tt 2ROT} from the Double-Number Extensions word set, 70 | \item[]providing the Exception Extensions word set, 71 | \item[]providing {\tt (}, {\tt BIN}, {\tt CLOSE-FILE}, {\tt CREATE-FILE}, {\tt OPEN-FILE}, {\tt R/O}, {\tt R/W}, {\tt READ-}\-{\tt FILE}, {\tt REPOSITION-}\-{\tt FILE}, {\tt W/O} and {\tt WRITE-FILE} from the File Extensions word set, 72 | \item[]providing {\tt .S}, {\tt ?}, {\tt WORDS}, {\tt AHEAD}, {\tt BYE}, {\tt CS-PICK}, {\tt CS-ROLL} and {\tt FORGET} from the Programming-Tools Extensions word set, 73 | \item[]providing the Search-Order Extensions word set, 74 | \item[]providing {\tt -TRAILING}, {\tt BLANK}, {\tt CMOVE}, {\tt CMOVE>} and {\tt COMPARE} from the String Extensions word set. 75 | \end{itemize} 76 | 77 | 78 | \subsection{Implementation-defined options} 79 | 80 | \subsubsection{Core word set} 81 | 82 | \begin{itemize} 83 | \item[--]Aligned addresses are those addresses which are divisible by four. 84 | \item[--]When given a non-graphic character, {\tt EMIT} passes the code to the host environment's character output routine. 85 | \item[--]{\tt ACCEPT} allows the input to be edited by pressing the backspace key or equivalent to delete the last character entered (or do nothing if there are currently no characters in the input). 86 | \item[--]The character set corresponds with one of the permitted sets in the range \{32\dots 126\} but is otherwise environment-dependent. 87 | \item[--]All addresses are character-aligned. 88 | \item[--]All characters in any character set extensions are matched when finding definition names. 89 | \item[--]Control characters never match a space delimiter. 90 | \item[--]The control-flow stack is implemented using the data stack. All items placed on the stack are single cells except for \spic{do-sys} elements, which occupy two cells. 91 | \item[--]Digits larger than thirty-five are represented by characters with codes starting at the first character after ``Z'', modulo the size of the character set. 92 | \item[--]After input terminates in {\tt ACCEPT}, the cursor remains immediately after the entered text. 93 | \item[--]{\tt ABORT"}'s exception abort sequence is to execute {\tt ABORT}. 94 | \item[--]The end of an input line is signalled by pressing the return key or equivalent. 95 | \item[--]The maximum size of a counted string is 255 characters. 96 | \item[--]The maximum size of a parsed string is $2^{32}-1$ characters. 97 | \item[--]The maximum size of a definition name is 31 characters. 98 | \item[--]The maximum string length for {\tt ENVIRONMENT?} is 255 characters. 99 | \item[--]Only one user input device (the keyboard) is supported. 100 | \item[--]Only one user output device (the terminal display) is supported. 101 | \item[--]There are eight bits in one address unit. 102 | \item[--]Number representation and arithmetic is performed with binary numbers in twos-complement form. 103 | \item[--]Types \spic{n} and \spic{d} range over \{$-2^{31}$\dots $2^{31}-1$\}, types \spic{+n} and \spic{+d} over \{$0\dots 2^{31}-1$\} and \spic{u} and \spic{ud} over \{$0\dots 2^{32}-1$\}. 104 | \item[--]There are no read-only data-space regions. 105 | \item[--]The buffer at {\tt WORD} is 256 characters in size. 106 | \item[--]A cell is four address units in size. 107 | \item[--]A character is one address unit in size. 108 | \item[--]The keyboard terminal input buffer is 256 characters in size. 109 | \item[--]The pictured numeric output string buffer is 256 characters in size. 110 | \item[--]The scratch area whose address is returned by {\tt PAD} is 256 characters in size. 111 | \item[--]The system is case-sensitive. 112 | \item[--]The system prompt is ``ok''. 113 | \item[--]All standard division words use floored division except {\tt SM/REM}, which uses symmetric division. 114 | \item[--]When true, {\tt STATE} takes the value 1. 115 | \item[--]When arithmetic overflow occurs, the value returned is the answer modulo the largest number of the result type plus one. 116 | \item[--]The current definition cannot be found after {\tt DOES>} is compiled. 117 | \end{itemize} 118 | 119 | \subsubsection{Exception word set} 120 | 121 | \begin{itemize} 122 | \item[--]Exceptions $-1$, $-2$, $-10$, $-11$, $-14$ and $-56$ may be raised by the system. Exception values $-256$ to $-511$ are reserved for the environment executing pForth to raise exceptions. Value $-512$ is used to indicate an unknown command-line option. Other exceptions in the range \{$-255\dots -1$\} may be raised by the host environment. 123 | \end{itemize} 124 | 125 | \subsubsection{File word set} 126 | 127 | The implementation-defined options depend on the host operating system. 128 | 129 | \subsubsection{Search-Order word set} 130 | 131 | \begin{itemize} 132 | \item[--]The search order may contain up to eight word lists. 133 | \item[--]The minimum search order consists of the single word list identified 134 | by {\tt FORTH-}\-{\tt WORDLIST}. 135 | \end{itemize} 136 | 137 | 138 | \subsection{Ambiguous conditions} 139 | 140 | The following ambiguous conditions are recognised and acted upon; all other 141 | ambiguous conditions are ignored by the System (although some of them may 142 | result in action being taken by the host machine, such as addressing a region 143 | outside data space resulting in an address exception). Dashes denote general 144 | ambiguous conditions which could arise because of a combination of factors; 145 | asterisks denote specific ambiguous conditions which are noted in the 146 | glossary entries of the relevant words in the standard. 147 | 148 | \subsubsection{Core word set} 149 | 150 | \begin{itemize} 151 | \item[--]If a \textit{name} that is neither a valid definition name nor a valid number is encountered during text interpretation, the \textit{name} is displayed followed by a question mark, and {\tt ABORT} is executed. 152 | \item[--]If a definition name exceeds the maximum length allowed, it is truncated to the maximum length (31 characters). 153 | \item[--]If division by zero is attempted, {\tt -10 THROW} is executed. By default this displays the message ``division by zero'' and executes {\tt ABORT}. 154 | \item[--]When signed division overflows, the quotient is the largest negative integer, and the remainder is $0$. 155 | \item[--]When a word with undefined interpretation semantics is interpreted, the message ``compilation only'' is displayed, and {\tt ABORT} is executed. 156 | \item[--]If the data stack has underflowed when the ``ok'' prompt would usually be displayed by {\tt QUIT}, {\tt ABORT"} is executed with the message ``stack underflow''. All other stack underflow conditions are ignored. 157 | \item[*]If {\tt RECURSE} appears after {\tt DOES>}, the execution semantics of the word containing the {\tt DOES>} are appended to that word while it is being compiled. 158 | \item[*]If the argument input source is different from the current input source for {\tt RESTORE-}\-{\tt INPUT}, the flag returned is true. 159 | \item[*]If data space containing definitions is de-allocated, those definitions continue to be found by dictionary search, and remain intact until overwritten, when the effects depend on exactly what is overwritten, but will probably include name lookup malfunction and incorrect execution semantics. 160 | \item[*]If {\tt IMMEDIATE} is executed when the most recent definition does not have a \textit{name}, the most recent named definition in the compilation word list is made immediate. 161 | \item[*]If a \textit{name} is not found by {\tt '}, {\tt POSTPONE} or {\tt [']}, the \textit{name} is displayed followed by a question mark, and {\tt ABORT} is executed. 162 | \item[*]If {\tt POSTPONE} is applied to {\tt TO}, the compilation semantics of {\tt TO} are appended to the current definition. 163 | \end{itemize} 164 | 165 | \subsubsection{Double-Number word set} 166 | 167 | \begin{itemize} 168 | \item[*]If \spic{d} is outside the range of \spic{n} in {\tt D>S}, the least-significant cell of the number is returned. 169 | \end{itemize} 170 | 171 | \subsubsection{Programming-Tools word set} 172 | 173 | \begin{itemize} 174 | \item[*]If the compilation word list is deleted by {\tt FORGET}, new definitions will still be added to the defunct word list; if the relevant data structures are subsequently overwritten, incorrect effects will probably occur. 175 | \item[*]If {\tt FORGET} cannot find \textit{name}, \textit{name} is displayed followed by a question mark, and {\tt ABORT} is executed. 176 | \end{itemize} 177 | 178 | \subsubsection{Search-Order word set} 179 | \begin{itemize} 180 | \item[*]Changing the compilation word list during compilation has no effect; changing the compilation word list before {\tt DOES>} or {\tt IMMEDIATE} causes the most recent definition in the new compilation word list to be modified; in the former case this may cause the next definition in memory to be partially overwritten. 181 | \item[*]If the search order is empty, {\tt PREVIOUS} has no effect. 182 | \item[*]If {\tt ALSO} is executed when the search order is full, the last word list in the search order is lost. 183 | \end{itemize} 184 | 185 | 186 | \subsection{Other system documentation} 187 | 188 | \subsubsection{Core word set} 189 | 190 | \begin{itemize} 191 | \item[--]No non-standard word provided uses {\tt PAD}. 192 | \item[--]The terminal facilities available are a single input (the keyboard), and a single output (the terminal display). 193 | \item[--]The available program data space is dependent on the memory available in the host environment. 194 | \item[--]4096 cells of return stack space is available. 195 | \item[--]4096 cells of data stack space is available. 196 | \item[--]The system dictionary space required depends on the implementation, and is typically under 32 kilobytes. 197 | \end{itemize} 198 | 199 | 200 | \section{Forth 2012} 201 | \label{forth2012} 202 | 203 | pForth implements some parts of the Forth 2012 standard. In the future, the documentation may be fully updated relative to that standard; until then, this section documents features and words that are part of the later standard. 204 | 205 | pForth implements the Forth 2012 syntax for decimal, hex and binary number input using respectively the {\tt \#}, {\tt \$} and {\tt \%} prefixes~\cite[section 3.4.1.3 “Text interpreter input number conversion”]{forth2012}. 206 | 207 | pForth 208 | \vspace{-3mm} 209 | \begin{itemize} 210 | \item[]provides {\tt DEFER}, {\tt DEFER!}, {\tt DEFER@}, {\tt IS} and {\tt ACTION-OF} from the Core Extensions word set. 211 | \end{itemize} 212 | 213 | 214 | \bibliographystyle{plain} 215 | \bibliography{vm} 216 | 217 | 218 | \end{document} 219 | -------------------------------------------------------------------------------- /extras/DoubleARM.txt: -------------------------------------------------------------------------------- 1 | REM ARM code double-length and mixed precision routines 2 | REM R.R.T. from Animynd Forth '91-'92 3 | REM (c) Reuben Thomas 1991-1992 4 | REM The package is distributed under the GNU GPL version 3, or, at your 5 | REM option, any later version. 6 | REM 7 | REM THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 8 | REM RISK. 9 | 10 | FNcode("2DUP") 11 | ldr r0,[sp] 12 | stmfd sp !,{r0,top} 13 | mov pc,lr 14 | 15 | FNcode("2DROP") 16 | add sp,sp,#4 17 | ldr top,[sp],#4 18 | mov pc,lr 19 | 20 | FNcode("2SWAP") 21 | ldmfd sp !,{r0-r2} 22 | mov r3,top 23 | mov r4,r0 24 | mov top,r1 25 | stmfd sp !,{r2-r4} 26 | mov pc,lr 27 | 28 | FNcode("2OVER") 29 | str top,[sp,#-4] 30 | ldmib sp,{r0-r1} 31 | str r1,[sp,#-8]! 32 | mov top,r0 33 | mov pc,lr 34 | 35 | FNcode("2ROT") 36 | ldmfd sp !,{r0-r4} 37 | stmfd sp !,{r0-r2} 38 | stmfd sp !,{r4,top} 39 | mov top,r3 40 | mov pc,lr 41 | 42 | FNcode("2-ROT") 43 | mov r0,top 44 | ldmfd sp !,{r1-r4,top} 45 | stmfd sp !,{r0-r1} 46 | stmfd sp !,{r3-r4,top} 47 | mov top,r2 48 | mov pc,lr 49 | 50 | FNcode("2TUCK") 51 | ldmfd sp !,{r0-r2} 52 | mov r4,r0 53 | mov r3,top 54 | stmfd sp !,{r0-r4} 55 | mov pc,lr 56 | 57 | FNcode("2NIP") 58 | ldr r0,[sp] 59 | str r0,[sp,#8]! 60 | mov pc,lr 61 | 62 | FNcode("D<") 63 | ldmfd sp !,{r0-r2} 64 | cmp r2,r0 65 | mvnlt top,#0 66 | movgt top,#0 67 | movne pc,lr 68 | sub top,r1,top 69 | mov top,top,asr#31 70 | mov pc,lr 71 | 72 | FNcode("D>") 73 | ldmfd sp !,{r0-r2} 74 | cmp r2,r0 75 | mvngt top,#0 76 | movlt top,#0 77 | movne pc,lr 78 | sub top,top,r1 79 | mov top,top,asr#31 80 | mov pc,lr 81 | 82 | FNcode("D=") 83 | ldmfd sp !,{r0-r2} 84 | cmp r2,r0 85 | cmpeq r1,top 86 | mvneq top,#0 87 | movne top,#0 88 | mov pc,lr 89 | 90 | FNcode("D<>") 91 | ldmfd sp !,{r0-r2} 92 | cmp r2,r0 93 | cmpeq r1,top 94 | mvnne top,#0 95 | moveq top,#0 96 | mov pc,lr 97 | 98 | FNcode("D0<") 99 | ldr top,[sp],#4 100 | mov top,top,asr#31 101 | mov pc,lr 102 | 103 | FNcode("D0>") 104 | cmp top,#0 105 | ldr top,[sp],#4 106 | cmpeq top,#0 107 | mvn top,top,asr#31 108 | moveq top,#0 109 | mov pc,lr 110 | 111 | FNcode("D0=") 112 | ldr r0,[sp],#4 113 | orrs r0,r0,top 114 | mvneq top,#0 115 | movne top,#0 116 | mov pc,lr 117 | 118 | FNcode("DU<") 119 | ldmfd sp !,{r0-r2} 120 | subs top,r1,top 121 | sbc r0,r0,r2 122 | mov top,r0,asr#31 123 | mov pc,lr 124 | 125 | FNcode("(UD/MOD)") 126 | cmp r3,#0 \ shift divisor left until MSB in same position 127 | cmpeq r2,r1 \ as dividend's 128 | movls r3,r2 \ 32 bits 129 | movls r2,#0 130 | mov r4,r0,lsr#16 \ 16 bits 131 | orr r4,r4,r1,lsl#16 132 | cmp r3,r1,lsr#16 133 | cmpeq r2,r4 134 | movls r3,r3,lsl#16 135 | orrls r3,r3,r2,lsr#16 136 | movls r2,r2,lsl#16 137 | mov r4,r0,lsr#8 \ 8 bits 138 | orr r4,r4,r1,lsl#24 139 | cmp r3,r1,lsr#8 140 | cmpeq r2,r4 141 | movls r3,r3,lsl#8 142 | orrls r3,r3,r2,lsr#24 143 | movls r2,r2,lsl#8 144 | mov r4,r0,lsr#4 \ 4 bits 145 | orr r4,r4,r1,lsl#28 146 | cmp r3,r1,lsr#4 147 | cmpeq r2,r4 148 | movls r3,r3,lsl#4 149 | orrls r3,r3,r2,lsr#28 150 | movls r2,r2,lsl#4 151 | mov r4,r0,lsr#2 \ 2 bits 152 | orr r4,r4,r1,lsl#30 153 | cmp r3,r1,lsr#2 154 | cmpeq r2,r4 155 | movls r3,r3,lsl#2 156 | orrls r3,r3,r2,lsr#30 157 | movls r2,r2,lsl#2 158 | mov r4,r0,lsr#1 \ 1 bit 159 | orr r4,r4,r1,lsl#31 160 | cmp r3,r1,lsr#1 161 | cmpeq r2,r4 162 | movls r3,r3,lsl#1 163 | orrls r3,r3,r2,lsr#31 164 | movls r2,r2,lsl#1 165 | mov r5,#0 \ quotient=0 166 | mov r6,#0 167 | .loop 168 | cmp r1,r3 \ if dividend>divisor 169 | cmpeq r0,r2 170 | mov r6,r6,lsl#1 \ shift quotient and add carry 171 | orr r6,r6,r5,lsr#31 172 | adc r5,r5,r5 173 | blo P%+12 174 | subs r0,r0,r2 \ then dividend-=divisor 175 | sbc r1,r1,r3 176 | mov r2,r2,lsr#1 \ shift divisor 177 | orr r2,r2,r3,lsl#31 178 | mov r3,r3,lsr#1 179 | cmp r3,r7 \ continue until divisor 0 and n = 0 10 | DROP 1- 1 RECURSE 11 | ELSE \ A(m - 1, A(m, n - 1)) if m > 0 and n > 0 12 | OVER SWAP 1- RECURSE \ compute a = A(m, n - 1), saving m 13 | SWAP 1- SWAP RECURSE \ A(m - 1, a) 14 | THEN 15 | THEN ; 16 | 17 | : ACKERMANN-ITERATIVE ( m n -- result ) 18 | BEGIN OVER 0> WHILE 19 | DUP 0= IF 20 | DROP 1 21 | ELSE 22 | OVER SWAP 1- RECURSE 23 | THEN 24 | SWAP 1- SWAP 25 | REPEAT 26 | NIP 1+ ; -------------------------------------------------------------------------------- /extras/armfpasm.fs: -------------------------------------------------------------------------------- 1 | ( Floating Point Assembler ) 2 | ASSEMBLER DEFINITIONS ALSO FORTH 3 | DECIMAL 4 | 5 | VARIABLE FRound VARIABLE FPrecision 6 | : SPREC 0 FPrecision ! ; : DPREC 1 FPrecision ! ; 7 | : EPREC 2 FPrecision ! ; : PPREC 3 FPrecision ! ; 8 | : NEAREST 0 FRound ! ; : +INF 1 FRound ! ; 9 | : -INF 2 FRound ! ; : ZERO 3 FRound ! ; 10 | 11 | : !ROUND FRound @ 5 << 12 | FPrecision @ DUP 1 AND 7 << 13 | SWAP 2 AND 18 << OR OR COND OR! ; 14 | SPREC NEAREST 15 | 16 | : FCONST 8 0 DO I CONSTANT I 8 OR CONSTANT LOOP ; 17 | FCONST 18 | F0 #0.0 F1 #1.0 F2 #2.0 F3 #3.0 19 | F4 #4.0 F5 #5.0 F6 #0.5 F7 #10.0 20 | 21 | : FPCR ( addr -- offset ) 22 | HERE ALIGN 8 + - 23 | DUP 0< IF @- ELSE @+ THEN 24 | ABS DUP 1023 > ABORT" FP Address Range" PC SWAP ; 25 | 26 | HEX 27 | : STF ( Fn Rn n -- ) 2 >>> SWAP 10 << OR 28 | FPrecision @ 1 AND 0F << OR 29 | FPrecision @ 2 AND 15 << OR C000000 OR 100 OR 30 | COND @ OR SWAP C << OR , RESET ; 31 | : LDF 100000 COND OR! STF ; 32 | \ Need to add STFM, LDFM or whatever 33 | 34 | : FLT 0C << 0E000110 OR SWAP 10 << OR 35 | !ROUND COND @ OR , RESET ; 36 | : WFS 0 SWAP 00200000 COND OR! FLT ; 37 | : RFS 100000 COND OR! WFS ; 38 | : FIX SWAP 00100000 COND OR! FLT ; 39 | 40 | : FOP CREATE , DOES> @ DUP 1 AND 41 | IF 0E008100 ELSE ROT 10 << 0E000100 OR THEN !ROUND SWAP 42 | 1 BIC 13 << OR OR SWAP 0C << OR COND @ OR , RESET ; 43 | : FOPS 1C 0 DO I FOP LOOP ; 44 | 45 | FOPS ADF MVF MUF MNF SUF ABS RSF RND 46 | DVF SQT RDF LOG POW LGN RPW EXP 47 | RMF SIN FML COS FDV TAN FRD ASN 48 | POL ACS ??? ATN 49 | 50 | : CMF SWAP 10 << OR 0E90F110 OR COND @ OR , RESET ; 51 | : CNF 00300000 OR CMF ; 52 | : CMFE 00400000 OR CMF ; 53 | : CNFE 00600000 OR CMF ; 54 | -------------------------------------------------------------------------------- /extras/redefinition.fs: -------------------------------------------------------------------------------- 1 | \ REDEFINERs swap the execution semantics of words redefined with R: between 2 | \ the old and new semantics. u is the number of words to swap. The words 3 | \ must have been defined with R: name ... ; as R; consumes information that 4 | \ REDEFINER needs. 5 | 6 | \ (c) Reuben Thomas 1995-2018 7 | \ 8 | \ The package is distributed under the GNU GPL version 3, or, at your 9 | \ option, any later version. 10 | \ 11 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 12 | \ RISK. 13 | 14 | \ R: redefines name. old is the old xt and new the new xt. 15 | \ To redefine a word immediately use R: name ... R;; to set up a redefinition 16 | \ for later use with a REDEFINER use R: name ... ;. 17 | : R: ( name ) ( -- old new ) 18 | ' \ get old xt 19 | :NONAME ; \ start the redefinition; leave new xt 20 | 21 | \ R; makes a redefinition created with R: take effect immediately. 22 | : R; ( old new -- ) 23 | OVER SWAP BRANCH \ compile a branch in the old word 24 | POSTPONE ; ; \ end the redefinition 25 | IMMEDIATE COMPILING 26 | 27 | \ DOES>: allows the run-time code of a defining word to be redefined. Use 28 | \ like R:; name must be the name of a defining word. 29 | : DOES>: ( name ) ( -- old new ) 30 | ' >DOES> \ get address of old DOES> code 31 | :NONAME ; \ start new definition 32 | 33 | \ RESOLVE: is used to supply the definition of a RESOLVER; the branch list is 34 | \ resolved to calls to the new definition. 35 | : RESOLVE: ( name ) 36 | BL WORD \ get name 37 | DUP FIND 0= IF UNDEFINED THEN \ get RESOLVER's execution token 38 | TRUE OVER SMUDGE! \ remove RESOLVER from search order 39 | SWAP HEADER TRUE SMUDGE \ start creating new definition 40 | HERE RESOLVE \ resolve calls to new definition 41 | LINK, ] ; \ add link code and start compiling -------------------------------------------------------------------------------- /extras/string.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2018 2 | \ 3 | \ This file is in the public domain. 4 | 5 | : CHOMP ( c-addr u1 -- c-addr u2 ) 6 | 2DUP + \ end of string 7 | EOL TUCK 2SWAP - OVER \ calculate where EOL would start 8 | COMPARE 0= IF \ if string ends with EOL, 9 | EOL NIP - \ reduce its length accordingly 10 | THEN ; 11 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | highlevel.fs 3 | /pforthi 4 | /pforthi.tmp 5 | /pforth 6 | /pforth-new 7 | -------------------------------------------------------------------------------- /src/Makefile.am: -------------------------------------------------------------------------------- 1 | # Source Makefile.am 2 | # 3 | # (c) Reuben Thomas 2018-2022 4 | # 5 | # The package is distributed under the GNU GPL version 3, or, at your 6 | # option, any later version. 7 | # 8 | # THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | # RISK. 10 | 11 | bin_SCRIPTS = pforth 12 | 13 | noinst_DATA = pforth-32.bin pforth-64.bin 14 | EXTRA_DIST = $(portable_SRCS) $(host_SRCS) pforth pforth-32.bin pforth-64.bin 15 | DISTCLEANFILES = highlevel.fs pforth.s 16 | 17 | portable_SRCS = compiler2.fs compiler4.fs compiler5.fs control1.fs \ 18 | control2.fs control3.fs defer-fetch-store.fs defining.fs does.fs \ 19 | interpreter3.fs make.fs vocabulary.fs 20 | 21 | BUILD_PFORTH = $(BEE) $(abs_top_srcdir)/src/pforth-$(bee_word_bits).bin 22 | 23 | host_SRCS = $(portable_SRCS) \ 24 | accept.fs assembler.fs call-cells.fs code.fs compiler1.fs \ 25 | compiler.fs compiler-asm.fs compiler-defer.fs compiler-postpone.fs \ 26 | extra-primitives.fs fileio.fs init-space.fs initialize.fs mangle.fs \ 27 | native-call.fs opcodes.fs os-compiler.fs os.fs parse-command-line.fs \ 28 | platform.fs primitives.fs resolver-branch.fs save.fs strings2a.fs \ 29 | strings2b.fs system-params.fs terminal.fs util.fs 30 | 31 | ETAGS_ARGS = --language forth $(portable_SRCS) $(host_SRCS) highlevel.fs.in 32 | 33 | do_build = \ 34 | if test $(srcdir) != $(builddir); then \ 35 | for i in $(host_SRCS); do \ 36 | $(LN_S) -f $(abs_top_srcdir)/src/"$$i" . ; \ 37 | done; \ 38 | fi && \ 39 | $(BUILD_PFORTH) --evaluate "$$MINIMAL_PRIMITIVES" make.fs 40 | 41 | # Build with triple test 42 | pforth-$(bee_word_bits).bin: $(host_SRCS) highlevel.fs 43 | $(do_build) && \ 44 | mv pforth-new pforth-new-0 && \ 45 | $(BEE) pforth-new-0 --evaluate "$$MINIMAL_PRIMITIVES" make.fs && \ 46 | cmp pforth-new pforth-new-0 && \ 47 | rm pforth-new-0 && \ 48 | mv pforth-new $@ 49 | 50 | pforth.s: pforth-$(bee_word_bits).bin 51 | $(BUILD_PFORTH) make.fs 2> $@ 52 | 53 | %-32.o: %.s 54 | $(AS) -m32 -R -o $@ $< 55 | 56 | %-64.o: %.s 57 | $(AS) -m64 -R -o $@ $< 58 | 59 | .o.bin: 60 | $(OBJCOPY) -O binary $< $@ 61 | 62 | loc-local: 63 | cd $(srcdir) && $(CLOC) $(CLOC_OPTS) $(host_SRCS) $(portable_SRCS) $(abs_builddir)/highlevel.fs 64 | 65 | # Forth executable 66 | pforth: pforth-$(bee_word_bits).bin 67 | echo "#!$(BEE)" | cat - pforth-$(bee_word_bits).bin > $@ 68 | chmod +x $@ 69 | 70 | CLEANFILES = pforth 71 | 72 | if HAVE_RLWRAP 73 | install-exec-hook: 74 | export pforth_name=`echo pforth | sed '$(transform)'`; \ 75 | sed 's,@PFORTH@,'$$pforth_name',' < pforthi > pforthi.tmp; \ 76 | $(INSTALL_PROGRAM) pforthi.tmp $(DESTDIR)$(bindir)/`echo pforthi | sed '$(transform)'` 77 | 78 | uninstall-hook: 79 | rm $(DESTDIR)$(bindir)/`echo pforthi | sed '$(transform)'` 80 | 81 | DISTCLEANFILES += pforthi pforthi.tmp 82 | endif 83 | 84 | # Error code 243 below is 256 + (-13) (Forth error code for "unknown word") 85 | check-local: pforth 86 | $(do_build) && \ 87 | cmp pforth-$(bee_word_bits).bin pforth-new && \ 88 | rm pforth-new && \ 89 | ./pforth --evaluate "42 HALT" || test $$? = 42 90 | -------------------------------------------------------------------------------- /src/accept.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2019 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : ACCEPT ( c-addr +n1 -- +n2 ) STDIN READ-LINE 2DROP ; -------------------------------------------------------------------------------- /src/assembler.fs: -------------------------------------------------------------------------------- 1 | \ Bee assembler for pForth 2 | \ 3 | \ (c) Reuben Thomas 2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | 12 | \ VOCABULARY ASSEMBLER ALSO ASSEMBLER DEFINITIONS 13 | 14 | : INLINE ( char -- ) DUP LAST >NAME .INLINE-COUNT LAST >INFO 2 + C! ; 15 | 16 | \ PREVIOUS DEFINITIONS 17 | INCLUDE" code.fs" 18 | : END-CODE ALIGN ( PREVIOUS ) ; 19 | \ ALSO ASSEMBLER DEFINITIONS 20 | 21 | INCLUDE" opcodes.fs" 22 | 23 | : OPCODE>NAME ( n -- addr ) 24 | CASE 25 | 0 OF C" nop" ENDOF 26 | 1 OF C" not" ENDOF 27 | 2 OF C" and" ENDOF 28 | 3 OF C" or" ENDOF 29 | 4 OF C" xor" ENDOF 30 | 5 OF C" lshift" ENDOF 31 | 6 OF C" rshift" ENDOF 32 | 7 OF C" arshift" ENDOF 33 | 8 OF C" pop" ENDOF 34 | 9 OF C" dup" ENDOF 35 | 10 OF C" set" ENDOF 36 | 11 OF C" swap" ENDOF 37 | 12 OF C" jump" ENDOF 38 | 13 OF C" jumpz" ENDOF 39 | 14 OF C" call" ENDOF 40 | 15 OF C" ret" ENDOF 41 | 16 OF C" load" ENDOF 42 | 17 OF C" store" ENDOF 43 | 18 OF C" load1" ENDOF 44 | 19 OF C" store1" ENDOF 45 | 20 OF C" load2" ENDOF 46 | 21 OF C" store2" ENDOF 47 | 22 OF C" load4" ENDOF 48 | 23 OF C" store4" ENDOF 49 | 24 OF C" neg" ENDOF 50 | 25 OF C" add" ENDOF 51 | 26 OF C" mul" ENDOF 52 | 27 OF C" divmod" ENDOF 53 | 28 OF C" udivmod" ENDOF 54 | 29 OF C" eq" ENDOF 55 | 30 OF C" lt" ENDOF 56 | 31 OF C" ult" ENDOF 57 | 32 OF C" pushs" ENDOF 58 | 33 OF C" pops" ENDOF 59 | 34 OF C" dups" ENDOF 60 | 35 OF C" catch" ENDOF 61 | 36 OF C" throw" ENDOF 62 | 37 OF C" break" ENDOF 63 | 38 OF C" word_bytes" ENDOF 64 | 39 OF C" get_m0" ENDOF 65 | 40 OF C" get_msize" ENDOF 66 | 41 OF C" get_ssize" ENDOF 67 | 42 OF C" get_sp" ENDOF 68 | 43 OF C" set_sp" ENDOF 69 | 44 OF C" get_dsize" ENDOF 70 | 45 OF C" get_dp" ENDOF 71 | 46 OF C" set_dp" ENDOF 72 | 47 OF C" get_handler_sp" ENDOF 73 | >R 0 R> 74 | ENDCASE ; 75 | 76 | 77 | \ Print the disassembly of the given instruction 78 | : DISASSEMBLE ( pc opcode -- ) 79 | CASE DUP OPCODE> 80 | OP_CALLI OF 81 | OP1_SHIFT ARSHIFT CELLS + \ compute address 82 | ." calli " >NAME COUNT TYPE 83 | ENDOF 84 | OP_PUSHI OF 85 | NIP 86 | OP1_SHIFT ARSHIFT \ compute constant 87 | ." pushi " DUP . ." # 0x" H. 88 | ENDOF 89 | OP_PUSHRELI OF 90 | OP1_SHIFT ARSHIFT CELLS + \ compute address 91 | ." pushreli 0x" H. 92 | ENDOF 93 | >R 94 | CASE DUP OPCODE2> 95 | OP2_JUMPI OF 96 | OP2_SHIFT ARSHIFT CELLS + \ compute address 97 | ." jumpi 0x" H. 98 | ENDOF 99 | OP2_JUMPZI OF 100 | OP2_SHIFT ARSHIFT CELLS + \ compute address 101 | ." jumpzi 0x" H. 102 | ENDOF 103 | OP2_TRAP OF 104 | NIP 105 | OP2_SHIFT RSHIFT \ compute trap code 106 | ." trap 0x" H. 107 | ENDOF 108 | OP2_INSN OF 109 | NIP 110 | OP2_SHIFT RSHIFT 111 | #INSTRUCTIONS OVER > SWAP OPCODE>NAME TUCK AND IF 112 | COUNT TYPE 113 | ELSE 114 | DROP ." ; invalid instruction!" 115 | THEN 116 | ENDOF 117 | ENDCASE 118 | R> 119 | ENDCASE 120 | CR ; 121 | 122 | : SHOW ( a-addr len -- ) 123 | OVER + SWAP DO 124 | I DUP @ DISASSEMBLE 125 | CELL +LOOP ; 126 | 127 | : TRAP CREATE OP2_TRAP >OPCODE2 , DOES> @ HERE OVER ['] DISASSEMBLE TO-ASMOUT RAW, ; 128 | : INST CREATE OP2_INSN >OPCODE2 , DOES> @ HERE OVER ['] DISASSEMBLE TO-ASMOUT RAW, ; 129 | : INSTS SWAP 1+ SWAP DO I INST LOOP ; 130 | 131 | : (BCALLI) ." calli 0x" DUP H. CR HERE - CELL/ OP_CALLI >OPCODE RAW, ; 132 | : (BPUSHI) ." pushi 0x" DUP H. CR OP_PUSHI >OPCODE RAW, ; 133 | : (BPUSHRELI) ." pushreli 0x" DUP H. CR HERE SWAP OFFSET OP1_SHIFT ARSHIFT OP_PUSHRELI >OPCODE , ; 134 | : BCALLI ['] (BCALLI) TO-ASMOUT ; 135 | : BPUSHI ['] (BPUSHI) TO-ASMOUT ; 136 | : BPUSHRELI ['] (BPUSHRELI) TO-ASMOUT ; 137 | 138 | 7 0 INSTS BNOP BNOT BAND BOR BXOR BLSHIFT BRSHIFT BARSHIFT 139 | 15 8 INSTS BPOP BDUP BSET BSWAP BJUMP BJUMPZ BCALL BRET 140 | 23 16 INSTS BLOAD BSTORE BLOAD1 BSTORE1 BLOAD2 BSTORE2 BLOAD4 BSTORE4 141 | 31 24 INSTS BNEG BADD BMUL BDIVMOD BUDIVMOD BEQ BLT BULT 142 | 39 32 INSTS BPUSHR BPOPR BDUPR BCATCH BTHROW BBREAK BWORD_BYTES BGET_M0 143 | 47 40 INSTS BGET_MSIZE BGET_SSIZE BGET_SP BSET_SP BGET_DSIZE BGET_DP BSET_DP BGET_HANDLER_SP 144 | 145 | 0 TRAP LIBC 146 | 147 | \ PREVIOUS DEFINITIONS 148 | -------------------------------------------------------------------------------- /src/call-cells.fs: -------------------------------------------------------------------------------- 1 | 1 2 | -------------------------------------------------------------------------------- /src/code.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 1995-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : CODE BL WORD HEADER ( ALSO ASSEMBLER ) ; 10 | -------------------------------------------------------------------------------- /src/compiler-asm.fs: -------------------------------------------------------------------------------- 1 | : (.ALIGN) ." .balign bee_word_bytes" CR ; 2 | :NONAME ['] (.ALIGN) TO-ASMOUT ; IS .ALIGN 3 | : (.CALIGN) ." .balign bee_word_bytes, 0x" H. CR ; 4 | :NONAME ['] (.CALIGN) TO-ASMOUT ; IS .CALIGN 5 | : (.REL-OFFSET) ." .word " ?DUP IF BACKWARD .LABEL ." - ." ELSE ." 0" THEN CR ; 6 | :NONAME ['] (.REL-OFFSET) TO-ASMOUT ; IS .REL-OFFSET 7 | : (.NOP) ." nop " CR ; 8 | :NONAME ['] (.NOP) TO-ASMOUT ; IS .NOP 9 | : (.ALLOT) ." .ds.b " . CR ; 10 | :NONAME ['] (.ALLOT) TO-ASMOUT ; IS .ALLOT 11 | : (.ALLOT-CELLS) ." .ds.b " . ." * bee_word_bytes" CR ; 12 | :NONAME ['] (.ALLOT-CELLS) TO-ASMOUT ; IS .ALLOT-CELLS 13 | : (.WORD) ." .word " . CR ; 14 | :NONAME ['] (.WORD) TO-ASMOUT ; IS .WORD 15 | : (.BYTE) ." .byte 0x" H. CR ; 16 | :NONAME ['] (.BYTE) TO-ASMOUT ; IS .BYTE 17 | : (.STRING) ." .ascii " 18 | [CHAR] " DUP EMIT -ROT 19 | OVER + SWAP DO 20 | I C@ 21 | DUP [CHAR] " = OVER [CHAR] \ = OR IF 22 | [CHAR] \ EMIT 23 | THEN 24 | EMIT 25 | LOOP 26 | EMIT CR ; 27 | :NONAME ['] (.STRING) TO-ASMOUT ; IS .STRING 28 | : (.PUSHI) ." pushi " . CR ; 29 | :NONAME ['] (.PUSHI) TO-ASMOUT ; IS .PUSHI 30 | : (.PUSHRELI) ." pushreli " .SYMBOL CR ; 31 | :NONAME ['] (.PUSHRELI) TO-ASMOUT ; IS .PUSHRELI 32 | : (.PUSH) HERE ." calli " DUP FORWARD .LABEL CR 33 | SWAP (.WORD) 34 | FORWARD .LABEL-DEF 35 | ." pops" CR 36 | ." load" CR ; 37 | :NONAME ['] (.PUSH) TO-ASMOUT ; IS .PUSH 38 | : (.LABEL) SWAP ." .L" ADDR>LABEL 0 U.R EMIT ; 39 | :NONAME ['] (.LABEL) TO-ASMOUT ; IS .LABEL 40 | : (.LABEL-DEF) .LABEL ." :" CR ; 41 | :NONAME ['] (.LABEL-DEF) TO-ASMOUT ; IS .LABEL-DEF 42 | : (.BODY-LABEL-DEF) >NAME .NAME ." _body:" CR ; 43 | :NONAME ['] (.BODY-LABEL-DEF) TO-ASMOUT ; IS .BODY-LABEL-DEF 44 | : (.BRANCH) ." jumpi " .LABEL CR ; 45 | :NONAME ['] (.BRANCH) TO-ASMOUT ; IS .BRANCH 46 | : (.IF) ." jumpzi " .LABEL CR ; 47 | :NONAME ['] (.IF) TO-ASMOUT ; IS .IF 48 | : (.RET) ." ret" CR ; 49 | :NONAME ['] (.RET) TO-ASMOUT ; IS .RET 50 | : (.IMMEDIATE-METHOD) ." .set " .NAME ." _compilation, (2 * bee_word_bytes)" CR ; 51 | :NONAME ['] (.IMMEDIATE-METHOD) TO-ASMOUT ; IS .IMMEDIATE-METHOD 52 | : (.COMPILE-METHOD) ." .set " TUCK .NAME ." _compilation, " NONAME .LABEL ." - (" .NAME ." - 2 * bee_word_bytes)" CR ; 53 | :NONAME ['] (.COMPILE-METHOD) TO-ASMOUT ; IS .COMPILE-METHOD 54 | : (.CALL-COMPILE-METHOD) ." calli " DUP .NAME ." - (2 * bee_word_bytes) + " .NAME ." _compilation" CR ; 55 | :NONAME ['] (.CALL-COMPILE-METHOD) TO-ASMOUT ; IS .CALL-COMPILE-METHOD 56 | : (.INLINE-COUNT) ." .set " .NAME ." _inline, " 0 U.R CR ; 57 | :NONAME ['] (.INLINE-COUNT) TO-ASMOUT ; IS .INLINE-COUNT 58 | : (.CREATED-CODE) ." calli " .NAME ." _doer" CR ; 59 | :NONAME ['] (.CREATED-CODE) TO-ASMOUT ; IS .CREATED-CODE 60 | : (.PUSHRELI-SYMBOL) ." pushreli " .NAME CR ; 61 | :NONAME ['] (.PUSHRELI-SYMBOL) TO-ASMOUT ; IS .PUSHRELI-SYMBOL 62 | -------------------------------------------------------------------------------- /src/compiler-defer.fs: -------------------------------------------------------------------------------- 1 | \ These words are defined in compiler-asm.fs 2 | DEFER .ALIGN 3 | DEFER .CALIGN 4 | DEFER .REL-OFFSET 5 | DEFER .NOP 6 | DEFER .ALLOT 7 | DEFER .ALLOT-CELLS 8 | DEFER .WORD 9 | DEFER .BYTE 10 | DEFER .STRING 11 | DEFER .PUSHI 12 | DEFER .PUSHRELI 13 | DEFER .PUSH 14 | DEFER .LABEL 15 | DEFER .LABEL-DEF 16 | DEFER .BODY-LABEL-DEF 17 | DEFER .BRANCH 18 | DEFER .IF 19 | DEFER .RET 20 | DEFER .IMMEDIATE-METHOD 21 | DEFER .COMPILE-METHOD 22 | DEFER .CALL-COMPILE-METHOD 23 | DEFER .INLINE-COUNT 24 | DEFER .CREATED-CODE 25 | DEFER .PUSHRELI-SYMBOL 26 | -------------------------------------------------------------------------------- /src/compiler-postpone.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2019-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | \ Compiler words that need special treatment during meta-compilation owing 10 | \ to their use of POSTPONE 11 | 12 | \ Compiler 13 | 14 | : AGAIN DUP BACKWARD .BRANCH HERE BRANCH, SWAP !BRANCH ; IMMEDIATE COMPILING 15 | : UNTIL DUP BACKWARD .IF HERE IF, SWAP !BRANCH ; IMMEDIATE COMPILING 16 | 17 | : DOES-LINK, POSTPONE R> ; 18 | 19 | : DO, POSTPONE 2>R ; COMPILING 20 | : LOOP, POSTPONE (LOOP) POSTPONE UNTIL ; COMPILING 21 | : +LOOP, POSTPONE (+LOOP) POSTPONE UNTIL ; COMPILING 22 | : END-LOOP, POSTPONE UNLOOP ; COMPILING 23 | 24 | : CREATE, .NOP NOP, RAW-POSTPONE (CREATE) 25 | LAST >NAME .CREATED-CODE 26 | ['] (CREATE) >NAME CREATED ! ; 27 | -------------------------------------------------------------------------------- /src/compiler.fs: -------------------------------------------------------------------------------- 1 | \ Machine-dependent words (Bee) 2 | \ 3 | \ (c) Reuben Thomas 2019-2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | INCLUDE" opcodes.fs" 12 | 13 | 14 | \ Core compiler 15 | 16 | : CALL ( at from to -- ) >-< SWAP ! ; 17 | 18 | : NOP, INSN_NOP OP2_INSN >OPCODE2 RAW, ; 19 | : CALL, HERE SWAP OFFSET CELL/ OP_CALLI >OPCODE RAW, ; 20 | : BRANCH, 0 OP2_JUMPI >OPCODE2 RAW, ; 21 | : IF, 0 OP2_JUMPZI >OPCODE2 RAW, ; 22 | : PUSH, ( x -- ) 23 | DUP CELLS CELL/ OVER = IF 24 | OP_PUSHI >OPCODE RAW, 25 | ELSE 26 | HERE 2 CELLS + CALL, RAW, INSN_POPR OP2_INSN >OPCODE2 RAW, INSN_LOAD OP2_INSN >OPCODE2 RAW, 27 | THEN ; 28 | : PUSHREL, HERE SWAP OFFSET CELL/ OP_PUSHRELI >OPCODE RAW, ; 29 | 30 | : @BRANCH ( from -- to ) DUP @ OP2_SHIFT ARSHIFT CELLS + ; 31 | : !BRANCH ( from to -- ) OVER SWAP OFFSET CELL/ OVER @ OPCODE2> >OPCODE2 SWAP ! ; 32 | : COMPILE, DUP >INFO 2 + C@ ?DUP IF 0 DO DUP @ , CELL+ LOOP DROP 33 | ELSE CALL, THEN ; 34 | 35 | : ADDR>LABEL 'FORTH - CELL/ ; 36 | CHAR b CONSTANT BACKWARD 37 | CHAR f CONSTANT FORWARD 38 | CHAR n CONSTANT NONAME 39 | 40 | : BEGIN HERE DUP BACKWARD .LABEL-DEF ; IMMEDIATE COMPILING 41 | : AHEAD HERE DUP FORWARD .BRANCH BRANCH, ; IMMEDIATE COMPILING 42 | : IF HERE DUP FORWARD .IF IF, ; IMMEDIATE COMPILING 43 | 44 | : THEN DUP FORWARD .LABEL-DEF HERE !BRANCH ; IMMEDIATE COMPILING 45 | 46 | : LINK, ; 47 | : UNLINK, .RET INSN_RET OP2_INSN >OPCODE2 RAW, ; COMPILING 48 | : LEAVE, ; 49 | -------------------------------------------------------------------------------- /src/compiler1.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2019-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | \ Data structures 10 | 11 | : LITERAL 12 | DUP 13 | DUP CELLS CELL/ OVER = IF .PUSHI ELSE .PUSH THEN 14 | PUSH, ; IMMEDIATE COMPILING 15 | : RELATIVE-LITERAL DUP .PUSHRELI PUSHREL, ; IMMEDIATE COMPILING 16 | 17 | : >BODY 2 CELLS + ; 18 | \ >DOES>, given the xt of a defining word, returns the address of the DOES> 19 | \ code. 20 | : >DOES> ( xt -- 'does ) DUP >INFO @ $FFFF AND CELLS + ; 21 | : (DOES>) DUP >NAME CREATED ! >DOES> LAST CELL+ DUP ROT CALL ; -------------------------------------------------------------------------------- /src/compiler2.fs: -------------------------------------------------------------------------------- 1 | \ Compiler #2 2 | \ 3 | \ (c) Reuben Thomas 1995-2016 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | : C" [CHAR] " PARSE POSTPONE CLITERAL ; IMMEDIATE COMPILING 12 | : S" [CHAR] " PARSE S"B SWAP 2DUP 2>R CMOVE 2R> ; 13 | :NONAME [CHAR] " PARSE POSTPONE SLITERAL ;IMMEDIATE 14 | 15 | : ." POSTPONE S" POSTPONE TYPE ; IMMEDIATE COMPILING 16 | 17 | : CHAR BL WORD CHAR+ C@ ; 18 | : [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE COMPILING 19 | -------------------------------------------------------------------------------- /src/compiler4.fs: -------------------------------------------------------------------------------- 1 | \ Compiler #4 2 | \ 3 | \ (c) Reuben Thomas 1995-2019 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | : COLON HEADER TRUE SMUDGE LINK, ] ; 12 | : : BL WORD COLON ; 13 | : CURRENT? ( wid xt n -- f ) 2DROP GET-CURRENT = ; 14 | : PROVIDED? ['] CURRENT? SELECT NIP ; 15 | : [PROVIDED] BL WORD PROVIDED? ; IMMEDIATE 16 | : PROVIDE: 17 | BL WORD DUP PROVIDED? IF 18 | DROP 19 | POSTPONE [ELSE] 20 | ELSE 21 | COLON 22 | THEN ; 23 | : ; UNLINK, POSTPONE [ FALSE SMUDGE ; IMMEDIATE COMPILING 24 | : :NONAME ALIGN 0 , HERE DUP NONAME .LABEL-DEF LINK, ] ; 25 | : ;IMMEDIATE POSTPONE ; SET-IMMEDIATE 26 | DUP LAST >NAME .COMPILE-METHOD 27 | LAST >COMPILE REL! ; IMMEDIATE COMPILING 28 | -------------------------------------------------------------------------------- /src/compiler5.fs: -------------------------------------------------------------------------------- 1 | \ Compiler #5 2 | \ 3 | \ (c) Reuben Thomas 1995-2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | : ' BL WORD FIND 0= IF UNDEFINED THEN ; 12 | : ['] ' DUP >NAME .PUSHRELI-SYMBOL PUSHREL, ; IMMEDIATE COMPILING 13 | -------------------------------------------------------------------------------- /src/control1.fs: -------------------------------------------------------------------------------- 1 | \ Control structures #1 2 | \ 3 | \ (c) Reuben Thomas 2016-2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | PROVIDE: J R> R> R> R> DUP -ROT >R >R -ROT >R >R ; [THEN] 12 | PROVIDE: (LOOP) R> R> 1+ DUP R@ = SWAP >R SWAP >R ; [THEN] 13 | PROVIDE: (+LOOP) R> SWAP R> R@ OVER SWAP - -ROT + R@ OVER SWAP - 14 | SWAP >R XOR 0< SWAP >R ; [THEN] 15 | PROVIDE: UNLOOP R> R> DROP R> DROP >R ; [THEN] -------------------------------------------------------------------------------- /src/control2.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2016-2019 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | \ Control structures #2 10 | 11 | : CS-PICK PICK ; COMPILING 12 | : CS-ROLL ROLL ; COMPILING 13 | 14 | : WHILE POSTPONE IF 1 CS-ROLL ; IMMEDIATE COMPILING 15 | : REPEAT POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE COMPILING 16 | : ELSE POSTPONE AHEAD 1 CS-ROLL POSTPONE THEN ; IMMEDIATE COMPILING 17 | 18 | VARIABLE 'NODE 19 | VARIABLE 'LOOP 20 | : NEW-NODE 21 | 'NODE @ 'LOOP @ 22 | HERE CELL 1- INVERT AND 23 | DUP 'LOOP ! 'NODE ! ; 24 | : TIE-NODE 25 | 'LOOP @ FORWARD .LABEL-DEF 26 | 'NODE @ 27 | BEGIN 28 | DUP 'LOOP @ <> WHILE 29 | DUP @BRANCH SWAP POSTPONE THEN 30 | REPEAT DROP 31 | 'LOOP ! 'NODE ! ; 32 | : I POSTPONE R@ ; IMMEDIATE COMPILING 33 | : LEAVE LEAVE, 'LOOP @ FORWARD .BRANCH HERE 'NODE DUP @ HERE BRANCH, SWAP !BRANCH ! ; IMMEDIATE COMPILING 34 | : DO NEW-NODE DO, POSTPONE BEGIN ; IMMEDIATE COMPILING 35 | : ?DO NEW-NODE POSTPONE 2DUP DO, POSTPONE = POSTPONE IF 36 | POSTPONE LEAVE POSTPONE THEN POSTPONE BEGIN ; IMMEDIATE COMPILING 37 | : LOOP LOOP, TIE-NODE END-LOOP, ; IMMEDIATE COMPILING 38 | : +LOOP +LOOP, TIE-NODE END-LOOP, ; IMMEDIATE COMPILING 39 | 40 | : RECURSE LAST COMPILE, ; IMMEDIATE COMPILING 41 | 42 | : CASE 0 ; IMMEDIATE COMPILING 43 | : OF 1+ >R POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP R> ; 44 | IMMEDIATE COMPILING 45 | : ENDOF >R POSTPONE ELSE R> ; IMMEDIATE COMPILING 46 | : ENDCASE POSTPONE DROP 0 ?DO POSTPONE THEN LOOP ; IMMEDIATE COMPILING 47 | -------------------------------------------------------------------------------- /src/control3.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2018 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | \ Control structures #3 10 | 11 | : "CASE POSTPONE CASE ; IMMEDIATE COMPILING 12 | : "OF 1+ >R POSTPONE 2OVER POSTPONE COMPARE POSTPONE 0= POSTPONE IF 13 | POSTPONE 2DROP R> ; IMMEDIATE COMPILING 14 | : "ENDOF POSTPONE ENDOF ; IMMEDIATE COMPILING 15 | : "ENDCASE POSTPONE 2DROP 0 ?DO POSTPONE THEN LOOP ; IMMEDIATE COMPILING 16 | -------------------------------------------------------------------------------- /src/defer-fetch-store.fs: -------------------------------------------------------------------------------- 1 | \ Defer address fetch/store 2 | \ Defined early so they can be POSTPONEd 3 | \ 4 | \ (c) Reuben Thomas 2018-2020 5 | \ 6 | \ The package is distributed under the GNU GPL version 3, or, at your 7 | \ option, any later version. 8 | \ 9 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 10 | \ RISK. 11 | 12 | : DEFER! >BODY REL! ; 13 | : DEFER@ >BODY REL@ ; 14 | -------------------------------------------------------------------------------- /src/defining.fs: -------------------------------------------------------------------------------- 1 | \ Defining 2 | \ 3 | \ (c) Reuben Thomas 1995-2019 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | : CREATE BL WORD HEADER CREATE, ALIGN LAST .BODY-LABEL-DEF ; 12 | INCLUDE" does.fs" 13 | 14 | : VARIABLE CREATE 1 ALLOT-CELLS ; 15 | : CONSTANT BL WORD HEADER LINK, POSTPONE LITERAL UNLINK, ; 16 | : VALUE CREATE , DOES> @ ; 17 | : .BODY-LITERAL ." pushreli " .NAME ." _body" CR ; 18 | : BODY-LITERAL 19 | DUP FIND 0= IF UNDEFINED THEN 20 | >BODY PUSHREL, 21 | ['] .BODY-LITERAL TO-ASMOUT ; 22 | : TO ' >BODY ! ; 23 | :NONAME BL WORD BODY-LITERAL POSTPONE ! ;IMMEDIATE 24 | 25 | : .DEFER-ADDRESS ." .word " .NAME ." _defer - ." CR ; 26 | : DEFER CREATE HERE ['] ABORT >REL RAW, LAST >NAME ['] .DEFER-ADDRESS TO-ASMOUT DOES> REL@ EXECUTE ; 27 | : ACTION-OF ' DEFER@ ; 28 | :NONAME POSTPONE ['] POSTPONE DEFER@ ;IMMEDIATE 29 | : .DEFER-LABEL ." .set " .NAME ." _defer, " 30 | DUP >INFO CELL 1- + C@ IF >NAME .NAME ELSE NONAME .LABEL THEN CR ; 31 | : .DEFER-ABORT ." .set " .NAME ." _defer, ABORT" CR ; 32 | : IS ' 2DUP >NAME ['] .DEFER-LABEL TO-ASMOUT DEFER! ; 33 | :NONAME POSTPONE ['] POSTPONE DEFER! ;IMMEDIATE 34 | -------------------------------------------------------------------------------- /src/does.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2016-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : DOES> LAST POSTPONE RELATIVE-LITERAL POSTPONE (DOES>) UNLINK, ALIGN 10 | HERE LAST TUCK - CELL/ SWAP DUP >NAME ['] .DOES-LABEL TO-ASMOUT >INFO 11 | DUP @ $FFFF INVERT AND ROT OR SWAP ! DOES-LINK, ; IMMEDIATE COMPILING -------------------------------------------------------------------------------- /src/extra-primitives.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | CR .( Extra primitives ) 10 | 11 | 12 | \ Stack primitives 13 | 14 | CODE DUP 15 | 0 BPUSHI BDUP 16 | BRET 17 | END-CODE 18 | 2 INLINE 19 | 20 | CODE SWAP 21 | 0 BPUSHI BSWAP 22 | BRET 23 | END-CODE 24 | 2 INLINE 25 | 26 | CODE OVER 27 | 1 BPUSHI BDUP 28 | BRET 29 | END-CODE 30 | 2 INLINE 31 | 32 | CODE ROT 33 | 0 BPUSHI BSWAP 34 | 1 BPUSHI BSWAP 35 | BRET 36 | END-CODE 37 | 4 INLINE 38 | 39 | CODE -ROT 40 | 1 BPUSHI BSWAP 41 | 0 BPUSHI BSWAP 42 | BRET 43 | END-CODE 44 | 4 INLINE 45 | 46 | CODE 2SWAP 47 | 1 BPUSHI BSWAP 48 | 0 BPUSHI BSWAP 49 | 2 BPUSHI BSWAP 50 | 0 BPUSHI BSWAP 51 | BRET 52 | END-CODE 53 | 8 INLINE 54 | 55 | 56 | \ Arithmetic and logical primitives 57 | 58 | CODE - 59 | BNEG BADD 60 | BRET 61 | END-CODE 62 | 2 INLINE 63 | 64 | CODE 1+ 65 | BNOT BNEG 66 | BRET 67 | END-CODE 68 | 2 INLINE 69 | 70 | CODE 1- 71 | BNEG BNOT 72 | BRET 73 | END-CODE 74 | 2 INLINE 75 | 76 | CODE ARSHIFT 77 | BARSHIFT 78 | BRET 79 | END-CODE 80 | 1 INLINE 81 | -------------------------------------------------------------------------------- /src/fileio.fs: -------------------------------------------------------------------------------- 1 | \ Mass storage input/output words 2 | \ 3 | \ (c) Reuben Thomas 1996-2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | \ ALSO ASSEMBLER 12 | 13 | 1 1 0 LIBC-PRIMITIVE STRLEN 14 | 3 1 1 LIBC-PRIMITIVE STRNCPY 15 | 0 1 2 LIBC-PRIMITIVE STDIN-FILENO 16 | 0 1 3 LIBC-PRIMITIVE STDOUT-FILENO 17 | 0 1 4 LIBC-PRIMITIVE STDERR-FILENO 18 | 0 1 5 LIBC-PRIMITIVE R/O 19 | 0 1 6 LIBC-PRIMITIVE W/O 20 | 0 1 7 LIBC-PRIMITIVE R/W 21 | 0 1 8 LIBC-PRIMITIVE O_CREAT 22 | 0 1 9 LIBC-PRIMITIVE O_TRUNC 23 | 2 1 10 LIBC-PRIMITIVE OPEN 24 | 1 1 11 LIBC-PRIMITIVE CLOSE-FILE 25 | 3 1 12 LIBC-PRIMITIVE READ 26 | 3 1 13 LIBC-PRIMITIVE WRITE 27 | 0 1 14 LIBC-PRIMITIVE SEEK_SET 28 | 0 1 15 LIBC-PRIMITIVE SEEK_CUR 29 | 0 1 16 LIBC-PRIMITIVE SEEK_END 30 | 4 2 17 LIBC-PRIMITIVE LSEEK \ FIXME: express off_t more accurately! 31 | 1 1 18 LIBC-PRIMITIVE FLUSH-FILE 32 | 2 1 19 LIBC-PRIMITIVE RENAME 33 | 1 1 20 LIBC-PRIMITIVE REMOVE 34 | 1 3 21 LIBC-PRIMITIVE FILE_SIZE \ FIXME: express off_t more accurately! 35 | 3 1 22 LIBC-PRIMITIVE RESIZE_FILE \ FIXME: express off_t more accurately! 36 | 1 2 23 LIBC-PRIMITIVE FILE-STATUS 37 | 0 1 $100 LIBC-PRIMITIVE TOTAL-ARGS 38 | 0 1 $101 LIBC-PRIMITIVE ARGV 39 | 40 | \ PREVIOUS 41 | 42 | 43 | : CREATE-FAM O_CREAT O_TRUNC OR ; 44 | 45 | 0 CONSTANT BIN-MODE 46 | : BIN ; 47 | 48 | : OPEN-FILE ( c-addr u fam -- fid ior ) -ROT SCRATCH-C0END SWAP OPEN 49 | DUP 0 < ; 50 | : READ-FILE ( c-addr u fileid -- nread ior ) READ DUP 0 < ; 51 | : WRITE-FILE ( c-addr u fileid -- ior ) WRITE 0 < ; 52 | : RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior ) SCRATCH-C0END -ROT HERE 256 C0END HERE 53 | SWAP RENAME ; 54 | : DELETE-FILE ( c-addr u -- ior ) SCRATCH-C0END REMOVE ; 55 | : CREATE-FILE ( adr u fam -- fid ior ) CREATE-FAM OR OPEN-FILE ; 56 | \ FIXME: Next two words depend on ENDISM and sizeof(off_t) 57 | : D>OFF_T ; 58 | : OFF_T>D ; 59 | : FILE-POSITION 0. D>OFF_T SEEK_CUR LSEEK 60 | OFF_T>D OVER -1 = OVER -1 = AND ; 61 | : REPOSITION-FILE -ROT D>OFF_T SEEK_SET LSEEK OFF_T>D -1 = SWAP -1 = AND ; 62 | : FILE-SIZE FILE_SIZE >R OFF_T>D R> ; 63 | : RESIZE-FILE >R D>OFF_T R> RESIZE_FILE ; 64 | : ABSOLUTE-ARG ( u1 -- c-addr u2 ) 65 | TOTAL-ARGS OVER > IF \ u1 66 | ARGV SWAP CELLS + @ DUP STRLEN 67 | ELSE 68 | DROP 0 0 69 | THEN ; -------------------------------------------------------------------------------- /src/highlevel.fs.in: -------------------------------------------------------------------------------- 1 | \ pForth high level words 2 | \ 3 | \ (c) Reuben Thomas 1991-2022 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | CR .( @PACKAGE_NAME@ high level words ) 12 | 13 | 14 | \ Placeholder 15 | 16 | : NOTHING ; 17 | 18 | 19 | \ System variables 20 | 21 | 0 VALUE 'FORTH \ set in per-platform INITIALIZE 22 | 0 VALUE LIMIT 23 | 24 | 25 | \ Arithmetic #1 26 | 27 | PROVIDE: TRUE -1 ; [THEN] 28 | PROVIDE: FALSE 0 ; [THEN] 29 | 30 | \ FIXME: should really be calculated for host system 31 | S" ADDRESS-UNIT-BITS" ENVIRONMENT? 0= [IF] ABORT [THEN] CONSTANT BYTE-BITS 32 | 33 | PROVIDE: - NEGATE + ; [THEN] 34 | 35 | PROVIDE: 1+ 1 + ; [THEN] 36 | PROVIDE: 1- 1 - ; [THEN] 37 | PROVIDE: -CELL CELL NEGATE ; [THEN] 38 | PROVIDE: CELL+ CELL + ; [THEN] 39 | PROVIDE: CELL- CELL - ; [THEN] 40 | 41 | 42 | \ Stack manipulation #1 43 | 44 | PROVIDE: DUP 0 PICK ; [THEN] 45 | PROVIDE: OVER 1 PICK ; [THEN] 46 | PROVIDE: ?DUP DUP IF DUP THEN ; [THEN] 47 | PROVIDE: ROLL 48 | DUP 1 + PICK >R DUP >R 49 | BEGIN ?DUP WHILE 50 | SWAP R> SWAP >R >R 51 | 1 - 52 | REPEAT 53 | DROP 54 | R> BEGIN ?DUP WHILE 55 | R> SWAP 56 | 1 - 57 | REPEAT 58 | R> ; [THEN] 59 | PROVIDE: SWAP 1 ROLL ; [THEN] 60 | PROVIDE: ROT 2 ROLL ; [THEN] 61 | PROVIDE: -ROT ROT ROT ; [THEN] 62 | PROVIDE: TUCK SWAP OVER ; [THEN] 63 | PROVIDE: NIP SWAP DROP ; [THEN] 64 | 65 | 66 | \ Exceptions #1 67 | 68 | [PROVIDED] THROW INVERT [IF] 69 | VARIABLE 'THROW 70 | : 'THROW! 'THROW ! ; 71 | : THROW 'THROW @EXECUTE ; 72 | [THEN] 73 | VARIABLE 'THROWN 74 | : (ABORT") SWAP IF 'THROWN ! -2 THROW ELSE DROP THEN ; 75 | : UNDEFINED ( c-addr -- ) 'THROWN ! -13 THROW ; 76 | PROVIDE: BYE 0 HALT ; [THEN] 77 | 78 | 79 | \ Arithmetic #2 80 | 81 | PROVIDE: >-< SWAP - ; [THEN] 82 | 83 | PROVIDE: < SWAP > ; [THEN] 84 | PROVIDE: > SWAP < ; [THEN] 85 | PROVIDE: U< SWAP U> ; [THEN] 86 | PROVIDE: U> SWAP U< ; [THEN] 87 | 88 | PROVIDE: ARSHIFT OVER OVER RSHIFT -ROT 89 | NEGATE CELL-BITS + 90 | SWAP 0 < SWAP LSHIFT OR ; [THEN] 91 | 92 | PROVIDE: <> = INVERT ; [THEN] 93 | PROVIDE: 0< 0 < ; [THEN] 94 | PROVIDE: 0> 0 > ; [THEN] 95 | PROVIDE: 0= 0 = ; [THEN] 96 | PROVIDE: 0<> 0 <> ; [THEN] 97 | 98 | PROVIDE: ABS DUP 0< IF NEGATE THEN ; [THEN] 99 | 100 | \ Allow division primitives without 0 divisor checking 101 | \ Assume that if S/REM is provided, so is U/MOD 102 | [PROVIDED] S/REM INVERT [IF] 103 | : CHECK-DIVISOR DUP 0= IF -10 THROW THEN ; 104 | : S/REM CHECK-DIVISOR (S/REM) ; 105 | : U/MOD CHECK-DIVISOR (U/MOD) ; 106 | [PROVIDED] (/MOD) [IF] 107 | : /MOD CHECK-DIVISOR (/MOD) ; 108 | [THEN] 109 | [THEN] 110 | 111 | PROVIDE: /MOD ( n1 n2 -- n3 n4 ) 112 | DUP >R 113 | OVER OVER XOR -ROT 114 | S/REM SWAP DUP 3 PICK 115 | 0< OVER 0<> AND IF 116 | R@ ABS SWAP ABS - 117 | R> 0> IF 1 ELSE -1 THEN * 118 | ELSE 119 | R> DROP 120 | THEN 121 | >R 122 | 0<> ROT 0< AND + 123 | R> SWAP ; [THEN] 124 | PROVIDE: / /MOD NIP ; [THEN] 125 | PROVIDE: MOD /MOD DROP ; [THEN] 126 | 127 | PROVIDE: 2* 1 LSHIFT ; [THEN] 128 | PROVIDE: 2/ 1 ARSHIFT ; [THEN] 129 | PROVIDE: CELLS CELL * ; [THEN] 130 | PROVIDE: CELL/ CELL / ; [THEN] 131 | 132 | : CELL-BITS BYTE-BITS CELLS ; 133 | : TOP-BIT-SET 1 CELL-BITS 1- LSHIFT ; 134 | 135 | 136 | INCLUDE" control1.fs" 137 | 138 | 139 | \ Stack manipulation #2 140 | 141 | PROVIDE: 2DUP OVER OVER ; [THEN] 142 | PROVIDE: 2DROP DROP DROP ; [THEN] 143 | PROVIDE: 2SWAP 3 ROLL 3 ROLL ; [THEN] 144 | PROVIDE: 2OVER 3 PICK 3 PICK ; [THEN] 145 | PROVIDE: 2ROT 5 ROLL 5 ROLL ; [THEN] 146 | 147 | PROVIDE: 2>R R> -ROT SWAP >R >R >R ; COMPILING [THEN] 148 | PROVIDE: 2R> R> R> R> SWAP ROT >R ; COMPILING [THEN] 149 | PROVIDE: 2R@ R> R> R> 2DUP >R >R SWAP ROT >R ; COMPILING [THEN] 150 | 151 | : STACK-DIRECTION SP@ SP@ - 0< NEGATE 2* 1- ; 152 | : DEPTH SP@ S0 - CELL/ STACK-DIRECTION * ; 153 | 154 | 155 | \ Memory #1 156 | 157 | PROVIDE: +! TUCK @ + SWAP ! ; [THEN] 158 | 159 | 160 | \ Characters 161 | 162 | \ FIXME: Add SYNONYM 163 | : +CHAR 1 ; 164 | : -CHAR -1 ; 165 | : CHAR+ 1+ ; 166 | : CHAR- 1- ; 167 | : CHARS ; IMMEDIATE 168 | : CHAR/ ; IMMEDIATE 169 | 170 | 171 | \ Arithmetic #4 172 | 173 | PROVIDE: MIN 2DUP > IF SWAP THEN DROP ; [THEN] 174 | PROVIDE: MAX 2DUP < IF SWAP THEN DROP ; [THEN] 175 | 176 | : S>D DUP 0< ; 177 | : D>S DROP ; 178 | 179 | : U>UD 0 ; 180 | : UD>U DROP ; 181 | 182 | : WITHIN OVER - >R - R> U< ; 183 | 184 | : M* * S>D ; 185 | : UM* * U>UD ; 186 | : FM/MOD NIP /MOD ; 187 | : SM/REM NIP S/REM ; 188 | : UM/MOD NIP U/MOD ; 189 | : */ >R * R> / ; 190 | : */MOD >R * R> /MOD ; 191 | 192 | : D0= 0= SWAP 0= AND ; 193 | : D+ D>S >R D>S R> + S>D ; 194 | : DNEGATE D>S NEGATE S>D ; 195 | : D- DNEGATE D+ ; 196 | : M+ S>D D+ ; 197 | : D* D>S >R D>S R> * S>D ; 198 | : UD/MOD UD>U >R UD>U R> U/MOD >R U>UD R> U>UD ; 199 | : DABS IF NEGATE THEN U>UD ; 200 | 201 | 202 | \ Strings #1 203 | 204 | : COUNT DUP CHAR+ SWAP C@ ; 205 | : /STRING ( c-addr1 u1 n -- c-addr2 u2 ) TUCK - -ROT CHARS + SWAP ; 206 | : CMOVE CHARS OVER + SWAP ?DO DUP C@ I C! CHAR+ +CHAR +LOOP DROP ; 207 | : CMOVE> ?DUP IF CHARS CHAR- TUCK + -ROT OVER + DO I C@ OVER C! CHAR- 208 | -CHAR +LOOP ELSE DROP THEN DROP ; 209 | : MOVE -ROT 2DUP > IF ROT CMOVE ELSE ROT CMOVE> THEN ; 210 | : FILL -ROT CHARS OVER + SWAP ?DO DUP I C! +CHAR +LOOP DROP ; 211 | : ERASE 0 FILL ; 212 | 213 | 214 | \ Compiler #1 215 | 216 | INCLUDE" compiler-defer.fs" 217 | 218 | 0 VALUE DP 219 | : HERE DP @ ; 220 | : RAW-ALLOT HERE OVER ERASE DP +! ; 221 | : ALLOT DUP .ALLOT RAW-ALLOT ; 222 | : ALLOT-CELLS DUP .ALLOT-CELLS CELLS RAW-ALLOT ; 223 | 224 | VARIABLE ROOTDP 225 | 226 | : ALIGNED CELL+ 1- -CELL AND ; 227 | : ALIGN .ALIGN HERE ALIGNED DP ! ; 228 | : RAW, HERE CELL RAW-ALLOT ! ; 229 | : , DUP .WORD RAW, ; 230 | : RAW-C, HERE +CHAR RAW-ALLOT C! ; 231 | : C, DUP .BYTE RAW-C, ; 232 | : CALIGN HERE DUP ALIGNED >-< 0 ?DO DUP RAW-C, LOOP .CALIGN ; 233 | 234 | : ADDRESS! ! ; 235 | : >REL ( from to -- offset ) DUP IF >-< ELSE NIP THEN ; 236 | : RAW-REL, HERE SWAP >REL RAW, ; 237 | : REL, DUP RAW-REL, .REL-OFFSET ; 238 | : REL@ DUP @ ?DUP IF + ELSE DROP 0 THEN ; 239 | : REL! ( to 'link -- ) DUP ROT >REL SWAP ! ; 240 | 241 | VARIABLE STATE 242 | : [ 0 STATE ! ; IMMEDIATE COMPILING 243 | : ] 1 STATE ! ; 244 | 245 | VARIABLE #ORDER 246 | CREATE CONTEXT 8 ALLOT-CELLS \ FIXME: constant 247 | 248 | VARIABLE CURRENT 249 | : GET-CURRENT CURRENT @ ; 250 | : SET-CURRENT CURRENT ! ; 251 | : LAST GET-CURRENT REL@ ; 252 | 253 | : >LINK 3 CELLS - ; 254 | : >COMPILE 2 CELLS - ; 255 | : >INFO CELL- ; 256 | : >NAME DUP >INFO CELL 1- + C@ 31 AND 1+ CHARS ALIGNED SWAP >LINK >-< ; 257 | 258 | : IMMEDIATE-BIT TOP-BIT-SET ; 259 | : SET-IMMEDIATE LAST >INFO DUP @ IMMEDIATE-BIT OR SWAP ! ; 260 | : IMMEDIATE SET-IMMEDIATE LAST >NAME .IMMEDIATE-METHOD 261 | LAST DUP >COMPILE REL! ; 262 | : COMPILING-BIT TOP-BIT-SET 1 RSHIFT ; 263 | : COMPILING LAST >INFO DUP @ COMPILING-BIT OR SWAP ! ; 264 | : SMUDGE-BIT TOP-BIT-SET 2 RSHIFT ; 265 | : SMUDGE! ( f a-addr -- ) >INFO TUCK @ SMUDGE-BIT DUP INVERT ROT AND 266 | -ROT AND OR SWAP ! ; 267 | : SMUDGE ( f -- ) LAST SMUDGE! ; 268 | 269 | 270 | \ Interpreter #1 271 | 272 | VARIABLE 'BUFFERS 273 | : PAD 'BUFFERS @ 256 + ; 274 | : TOKEN 'BUFFERS @ 512 + ; 275 | : S"B 'BUFFERS @ 768 + ; 276 | : SCRATCH 'BUFFERS @ 1024 + ; 277 | 278 | 279 | INCLUDE" os-compiler.fs" \ words necessary for the machine 280 | : CODE-MOVE CELLS OVER + SWAP ?DO DUP @ I CODE! CELL+ 281 | CELL +LOOP DROP ; 282 | INCLUDE" compiler.fs" 283 | DEFER CURRENT-COMPILE, ' COMPILE, IS CURRENT-COMPILE, 284 | INCLUDE" call-cells.fs" CONSTANT #CALL-CELLS 285 | : (RAW-POSTPONE) CURRENT-COMPILE, ; 286 | : (POSTPONE) CURRENT-COMPILE, ; 287 | VARIABLE CREATED \ Indicate whether last word was CREATEd 288 | INCLUDE" compiler1.fs" 289 | INCLUDE" compiler-postpone.fs" 290 | INCLUDE" defer-fetch-store.fs" 291 | 292 | 293 | \ Strings #2 294 | 295 | \ Copy string c-addr1 u1 into buffer c-addr2 u2, and NUL-terminate it 296 | : C0END ( c-addr1 u1 c-addr2 u2 -- ) 1- ROT MIN 2DUP + >R 297 | MOVE 0 R> C! ; 298 | \ FIXME: caller should allocate buffer! 299 | : SCRATCH-C0END ( c-addr1 u1 -- HERE ) SCRATCH 256 C0END SCRATCH ; 300 | : ", ( c-addr u -- ) DUP C, 2DUP .STRING HERE SWAP DUP RAW-ALLOT CMOVE ; 301 | 302 | INCLUDE" strings2a.fs" 303 | 304 | 305 | INCLUDE" fileio.fs" 306 | INCLUDE" terminal.fs" \ terminal I/O words 307 | 308 | 309 | \ Interpreter #2 310 | 311 | : ABORT -1 THROW ; 312 | : QUIT -56 THROW ; 313 | 314 | 315 | INCLUDE" control2.fs" 316 | INCLUDE" strings2b.fs" 317 | 318 | 319 | \ Memory #2 320 | 321 | : 2@ DUP CELL+ @ SWAP @ ; 322 | : 2! TUCK ! CELL+ ! ; 323 | : 2, , , ; 324 | 325 | 326 | \ Strings #3 327 | 328 | : BLANK BL FILL ; 329 | 330 | : COMPARE ( c-addr1 u1 c-addr2 u2 -- n ) 331 | ROT 2SWAP 2OVER MIN \ no. of characters to check 332 | DUP 0> IF \ if strings not both length 0 333 | 0 DO \ for each character 334 | OVER C@ OVER C@ \ get the characters 335 | <> IF \ if they're unequal 336 | C@ SWAP C@ \ retrieve the characters 337 | < 2* INVERT \ construct the return code 338 | NIP NIP UNLOOP EXIT \ and exit 339 | THEN 340 | CHAR+ SWAP CHAR+ SWAP \ increment addresses 341 | LOOP 342 | 2DROP \ get rid of addresses 343 | 2DUP <> -ROT < 2* INVERT AND \ construct return code 344 | ELSE \ if strings are both length 0 345 | 2DROP 2DROP \ leave 0 346 | THEN ; 347 | 348 | : SEARCH ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 f ) 349 | ROT 2DUP \ copy lengths 350 | OVER SWAP U> SWAP 0= OR IF \ if u2>u1 or u2=0 351 | NIP NIP FALSE EXIT \ exit with false flag 352 | THEN 353 | -ROT 2OVER \ save c-addr1 u1 354 | 2SWAP TUCK 2>R \ save c-addr2 u2 355 | - 1+ OVER + SWAP \ make c-addr1 c-addr1+u1-u2 356 | 2R> 2SWAP \ retrieve c-addr2 u2 357 | DO 358 | 2DUP I OVER COMPARE 0= IF \ if we find the string 359 | 2DROP + I TUCK - \ calculate c-addr3 u3 360 | TRUE UNLOOP EXIT \ exit with true flag 361 | THEN 362 | LOOP 363 | 2DROP FALSE ; \ leave c-addr1 u1 false 364 | 365 | 366 | INCLUDE" control3.fs" 367 | 368 | 369 | \ Mass storage input/output #1 370 | 371 | : READ-LINE ( c-addr u1 fid -- u2 flag ior ) 372 | >R OVER SWAP \ save fid and copy c-addr 373 | R@ READ-FILE \ fill buffer 374 | ?DUP IF \ if an error occurred 375 | NIP NIP 0 FALSE ROT \ leave 0 false ior 376 | R> DROP EXIT \ drop fid and exit 377 | THEN 378 | DUP 0= IF \ if the line is of length 0, 379 | NIP FALSE 0 R> DROP EXIT \ exit with false flag 380 | THEN 381 | TUCK \ save no. of chars read 382 | EOL SEARCH ROT DROP \ search for EOL; drop address 383 | IF \ if found, 384 | TUCK - SWAP \ calculate length, save it 385 | EOL NIP - ?DUP IF \ if not at the end of the line, 386 | R@ FILE-POSITION \ get the current file position 387 | ?DUP IF \ if an error occurred 388 | >R 2DROP DROP FALSE R> \ clear up, leave false flag 389 | R> DROP EXIT \ and ior, and exit 390 | THEN 391 | ROT U>UD D- \ set pointer to just after EOL 392 | R@ REPOSITION-FILE 393 | ?DUP IF \ if there was an error 394 | FALSE SWAP EXIT \ exit with error code 395 | THEN 396 | THEN 397 | ELSE 398 | DROP \ else u2=u1 399 | THEN 400 | R> DROP \ drop fid 401 | TRUE 0 ; \ leave true flag, ior=0 402 | : WRITE-LINE ( c-addr u fid -- ior ) 403 | >R \ save fid 404 | R@ WRITE-FILE \ write the line 405 | ?DUP IF \ if there was an error 406 | R> DROP EXIT \ drop fid and exit 407 | THEN 408 | EOL R> WRITE-FILE ; \ write the line terminator; 409 | \ ior is WRITE-FILE's result 410 | 411 | 412 | \ Terminal input/output #1 413 | 414 | : SPACE BL EMIT ; 415 | : SPACES 0 ?DO SPACE LOOP ; 416 | : TYPE CHARS OVER + SWAP ?DO I C@ EMIT +CHAR +LOOP ; 417 | : -TRAILING BEGIN DUP IF 2DUP 1- CHARS + C@ BL = ELSE FALSE THEN 418 | WHILE 1- REPEAT ; 419 | 420 | 421 | \ Mass storage input/output #2 422 | 423 | 1024 CONSTANT /FILE-BUFFER 424 | 16 CONSTANT #FILE-BUFFERS 425 | VARIABLE FILE-BUFFER# 0 ' FILE-BUFFER# >BODY ! \ next file buffer to use 426 | 0 VALUE FIRST-FILE 427 | : ALLOCATE-BUFFER ( -- c-addr ior ) FILE-BUFFER# @ DUP #FILE-BUFFERS 428 | = IF -1 ELSE DUP 1+ FILE-BUFFER# ! /FILE-BUFFER * FIRST-FILE + 0 429 | THEN ; 430 | : FREE-BUFFER ( -- ior ) FILE-BUFFER# DUP @ 0= IF DROP -1 431 | ELSE -1 SWAP +! 0 THEN ; 432 | 433 | 434 | \ Terminal input/output #2 435 | 436 | INCLUDE" accept.fs" 437 | 438 | VARIABLE >IN 439 | 440 | VARIABLE EVALUAND 441 | VARIABLE #EVALUAND 442 | 443 | VARIABLE #TIB 444 | : TIB 'BUFFERS @ ; 445 | 446 | VARIABLE #FIB 447 | 0 VALUE FIB 448 | 449 | 0 VALUE SOURCE-ID 450 | : SOURCE 451 | CASE SOURCE-ID 452 | -1 OF EVALUAND @ #EVALUAND @ ENDOF 453 | 0 OF TIB #TIB @ ENDOF 454 | >R FIB #FIB @ R> 455 | ENDCASE ; 456 | 457 | \ SAVE-INPUT returns the current input source immediately under the number of 458 | \ items returned, encoded as: 459 | \ 0 = user input device, -1 = string 460 | \ 2 = file 461 | : SAVE-INPUT ( -- xn...x1 n ) 462 | >IN @ \ get >IN 463 | CASE SOURCE-ID \ look at SOURCE-ID 464 | 0 OF 0 2 ENDOF \ if 0, leave >IN 0 465 | -1 OF \ if -1, leave >IN EVALUAND 466 | EVALUAND @ #EVALUAND @ \ #EVALUAND -1 467 | -1 4 468 | ENDOF 469 | >R FIB #FIB @ SOURCE-ID 2 5 R> 470 | \ if a file leave >IN FIB #FIB fid 2 471 | ENDCASE ; 472 | \ RESTORE-INPUT always succeeds unless the input source buffer being restored 473 | \ has been altered, which it has no way of telling. 474 | : RESTORE-INPUT ( xn...x1 n -- f ) 475 | DROP 476 | CASE 477 | 0 OF 0 TO SOURCE-ID ENDOF 478 | 2 OF TO SOURCE-ID #FIB ! TO FIB ENDOF 479 | -1 OF #EVALUAND ! EVALUAND ! -1 TO SOURCE-ID 480 | ENDOF 481 | ENDCASE 482 | >IN ! 483 | FALSE ; 484 | 485 | VARIABLE 'RETURN 486 | : SAVE-INPUT>R \ save input specification to return stack 487 | R> 'RETURN ! \ save return address 488 | SAVE-INPUT \ get input specification 489 | DUP \ push it to return stack 490 | BEGIN ?DUP WHILE \ can't use a DO loop as this would 491 | ROT >R \ interfere with the return stack 492 | 1- 493 | REPEAT 494 | >R 495 | 'RETURN @ >R ; \ restore return address 496 | : R>RESTORE-INPUT \ restore input specification from return stack 497 | R> 'RETURN ! \ save return address 498 | R> DUP \ pop input specification 499 | BEGIN ?DUP WHILE \ from return stack 500 | R> -ROT \ can't use a DO loop as this would 501 | 1- \ interfere with the return stack 502 | REPEAT 503 | RESTORE-INPUT DROP \ set input specification 504 | 'RETURN @ >R ; \ restore return address 505 | 506 | DEFER SCAN-TEST 507 | LAST >NAME ' .DEFER-ABORT TO-ASMOUT 508 | : SCAN ( char xt -- c-addr u ) 509 | IS SCAN-TEST 510 | SOURCE CHARS \ get input source 511 | OVER + \ end of input buffer + 1 512 | SWAP >IN @ CHARS + \ start of parse area 513 | SWAP ROT OVER 3 PICK ?DO \ save start & end of input buffer 514 | DUP I C@ SCAN-TEST IF \ if test true, 515 | NIP I SWAP LEAVE \ drop end, leave I and exit 516 | THEN 517 | +CHAR +LOOP \ if end of loop reached, end left 518 | DROP \ get rid of delimiter 519 | OVER - DUP >IN +! \ advance >IN 520 | CHAR/ ; \ leave count and length 521 | 522 | : PARSE ( char -- c-addr u ) 523 | ['] = SCAN \ search for delimiter 524 | >IN DUP @ CHAR+ \ advance >IN past delimiter 525 | SOURCE NIP MIN SWAP ! ; \ making sure it stays in the source 526 | 527 | : WORD ( char -- c-addr ) 528 | DUP \ copy delimiter 529 | ['] <> SCAN 2DROP \ skip delimiter 530 | PARSE \ get the delimited string 531 | TOKEN 2DUP C! \ store count 532 | CHAR+ 2DUP + BL SWAP C! \ store blank at end of string 533 | SWAP CMOVE \ store string 534 | TOKEN ; \ leave the string's address 535 | 536 | : .( [CHAR] ) PARSE TYPE ; IMMEDIATE 537 | 538 | \ Set default PROGRAM-NAME in case for some reason there is no ARG 0 539 | HERE DUP BACKWARD .LABEL-DEF S" @PACKAGE@" ", CREATE "PROGRAM-NAME REL, 540 | 541 | : ERROR-PREFIX "PROGRAM-NAME REL@ COUNT TYPE S" : " TYPE ; 542 | 543 | 544 | INCLUDE" compiler2.fs" 545 | INCLUDE" interpreter3.fs" 546 | 547 | 548 | \ Numeric conversion 549 | 550 | VARIABLE BASE 551 | VARIABLE HELD 552 | 553 | : DECIMAL 10 BASE ! ; 554 | : HEX 16 BASE ! ; 555 | : HOLD -CHAR HELD +! HELD @ C! ; 556 | : SIGN 0< IF [CHAR] - HOLD THEN ; 557 | : <# TOKEN HELD ! ; 558 | : #> 2DROP HELD @ TOKEN OVER - ; 559 | : # BASE @ U>UD UD/MOD 2SWAP UD>U DUP 10 < IF [CHAR] 0 + 560 | ELSE [ CHAR A 10 - ] LITERAL + THEN HOLD ; 561 | : #S BEGIN # 2DUP D0= UNTIL ; 562 | 563 | : D.R -ROT TUCK DABS <# #S ROT SIGN #> ROT OVER - 0 MAX SPACES TYPE ; 564 | : D. 0 D.R SPACE ; 565 | : .R SWAP S>D ROT D.R ; 566 | : . 0 .R SPACE ; 567 | : DEC. BASE @ SWAP DECIMAL . BASE ! ; 568 | : U.R SWAP U>UD ROT D.R ; 569 | : U. 0 U.R SPACE ; 570 | : H. BASE @ SWAP HEX U. BASE ! ; 571 | 572 | : >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 573 | DUP IF \ if something to convert 574 | CHARS OVER + SWAP \ form limits for a loop 575 | TUCK OVER >R \ save initial address and 576 | \ address of last character + 1 577 | DO 578 | C@ \ get next character 579 | DUP [CHAR] A < IF \ convert to a digit 580 | [CHAR] 0 - ELSE [ CHAR A 10 - ] LITERAL - 581 | THEN 582 | DUP BASE @ - 0< INVERT \ if digit is too large... 583 | OVER 0< OR IF \ or too small 584 | DROP I LEAVE \ leave address of character 585 | THEN \ and exit the loop 586 | >R BASE @ U>UD D* \ multiply n by BASE 587 | R> M+ \ add new digit 588 | I CHAR+ \ address of next character 589 | LOOP 590 | DUP R> >-< \ construct u' 591 | THEN ; 592 | : SKIP-CHAR ( c-addr u -- c-addr+1 u-1) 1- SWAP CHAR+ SWAP ; 593 | : NUMBER ( c-addr -- d true | n false ) 594 | DUP >R \ save address of string 595 | 0. ROT \ make accumulator for >NUMBER 596 | COUNT \ count the string 597 | BASE @ >R \ save BASE 598 | CASE OVER C@ \ set base if leading #, $ or % 599 | [CHAR] # OF 10 BASE ! SKIP-CHAR ENDOF 600 | [CHAR] $ OF 16 BASE ! SKIP-CHAR ENDOF 601 | [CHAR] % OF 2 BASE ! SKIP-CHAR ENDOF 602 | ENDCASE 603 | OVER C@ \ get the leading character 604 | [CHAR] - = DUP >R IF \ skip first character if it's 605 | SKIP-CHAR \ a minus and save the flag 606 | THEN 607 | FALSE >R \ save false flag 608 | BEGIN 609 | >NUMBER \ convert up to non-digit 610 | ?DUP WHILE \ if the string's not finished, 611 | OVER C@ 4 / 11 <> IF \ is the non-digit punctuation? 612 | 2R> 2DROP \ FIXME: Tighten up parsing 613 | R> BASE ! R> UNDEFINED \ if not, then not a number 614 | THEN 615 | R> DROP TRUE >R \ if so, set double no. flag 616 | SKIP-CHAR \ and skip the punctuation 617 | REPEAT 618 | DROP \ drop string address 619 | 2R> >R \ retrieve leading minus flag 620 | IF DNEGATE THEN \ if leading minus, negate no. 621 | R@ INVERT IF D>S THEN \ return single or double no. 622 | R> \ and flag as appropriate 623 | R> BASE ! \ restore BASE 624 | R> DROP ; \ drop address of string 625 | 626 | 627 | \ Compiler #3 628 | 629 | : DEFINITIONS CONTEXT @ SET-CURRENT ; 630 | 631 | : GET-ORDER #ORDER @ DUP IF DUP >R CELLS CONTEXT TUCK + CELL- DO 632 | I @ -CELL +LOOP R> THEN ; 633 | 634 | DEFER VISIBLE? \ word visibility test 635 | LAST >NAME ' .DEFER-ABORT TO-ASMOUT 636 | : ALL-VISIBLE ( wid xt n -- true ) 2DROP DROP TRUE ; 637 | \ VISIBLE? must be set before VET-WORDLIST is called, with a word whose 638 | \ stack effect is ( wid xt n -- f ), where wid is the word list and xt the 639 | \ execution token of the found word and n its immediacy flag, and f is true 640 | \ if the word is deemed visible by the test. 641 | : VET-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1 ) 642 | DUP >R \ save wid 643 | BEGIN REL@ ?DUP WHILE \ for all words in list 644 | DUP >NAME \ get name field address 645 | 2OVER ROT COUNT \ COUNT the strings 646 | COMPARE 0= IF \ if the name matches 647 | DUP >INFO @ \ and the word is not SMUDGEd 648 | SMUDGE-BIT AND 0= IF 649 | R@ OVER \ get wid and xt of word 650 | DUP >INFO @ 0< 2* INVERT \ get immediacy flag 651 | DUP >R \ save flag 652 | VISIBLE? IF \ if word is deemed visible 653 | NIP NIP R> R> DROP \ get flag, drop string and wid, 654 | EXIT \ and exit 655 | ELSE 656 | R> DROP \ else drop immediacy flag 657 | THEN 658 | THEN 659 | THEN 660 | >LINK \ leave next link field 661 | REPEAT 662 | 2DROP R> DROP \ get rid of c-addr, u and wid, 663 | 0 ; \ and set flag to 0 664 | : SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1 ) 665 | ['] ALL-VISIBLE IS VISIBLE? VET-WORDLIST ; 666 | 667 | : SELECT ( a-addr1 xt -- a-addr2 n ) 668 | IS VISIBLE? \ set up visibility selector 669 | >R GET-ORDER R> SWAP \ get search order 670 | ?DUP IF \ if search order non-empty 671 | 1 SWAP DO \ for each word list in order 672 | TUCK COUNT ROT VET-WORDLIST \ search it 673 | ?DUP IF \ if the word is found 674 | I -ROT 2>R \ save xt and immediacy flag 675 | 0 DO DROP LOOP \ drop wids and string address 676 | 2R> UNLOOP EXIT \ retrieve results and exit 677 | THEN 678 | -1 +LOOP 679 | THEN 680 | 0 ; \ if not found leave string & 0 flag 681 | : FIND ( c-addr -- a-addr n ) ['] ALL-VISIBLE SELECT ; 682 | 683 | DEFER CURRENT-LITERAL ' LITERAL IS CURRENT-LITERAL 684 | DEFER CURRENT-RELATIVE-LITERAL ' RELATIVE-LITERAL IS CURRENT-RELATIVE-LITERAL 685 | : POSTPONE 686 | BL WORD DUP FIND 687 | ?DUP 0= IF UNDEFINED THEN 688 | 0> IF 689 | >COMPILE REL@ CALL, .CALL-COMPILE-METHOD 690 | ELSE 691 | PUSHREL, .PUSHRELI-SYMBOL ['] (POSTPONE) CURRENT-COMPILE, 692 | THEN ; 693 | IMMEDIATE COMPILING 694 | 695 | \ A header has the following structure: 696 | \ 697 | \ Name field counted string, up to 32 chars, space-padded to cell 698 | \ Link field 1 cell, relative link to LAST 699 | \ Compilation method 1 cell, relative pointer 700 | \ Info field 1 cell: MS byte bit 7 is IMMEDIATE flag, 701 | \ bit 6 is COMPILING flag, 702 | \ bit 5 is SMUDGE flag, 703 | \ rest of MS byte is length of name field, 704 | \ bytes 2-(MS byte - 1) are reserved for the back-end 705 | \ bytes 0 & 1 are offset in cells to DOES> code for a 706 | \ defining word 707 | INCLUDE" mangle.fs" 708 | : .NAME COUNT .MANGLE ; 709 | : .NAME-LABEL DUP ." .global " .NAME CR .NAME ." :" CR ; 710 | : (.LINK) ." .word " ?DUP IF >NAME .NAME ELSE ." . " THEN ." - ." CR ; 711 | : .LINK ['] (.LINK) TO-ASMOUT ; 712 | : .COMPILE-FIELD ." .word " .NAME ." _compilation" CR ; 713 | \ FIXME: put values for DOES> code, inline code, IMMEDIATE and COMPILING bits into an expression 714 | : .INFO-FIELD ." .word " .NAME ." _info " CR ; 715 | : .INFO ." .set " .NAME ." _info, " 716 | DUP IMMEDIATE-BIT AND IF ." _immediate_bit" ELSE ." 0" THEN 717 | IMMEDIATE-BIT INVERT AND ." | " 718 | DUP COMPILING-BIT AND IF ." _compiling_bit" ELSE ." 0" THEN 719 | COMPILING-BIT INVERT AND ." | " 720 | DUP SMUDGE-BIT AND IF ." _smudge_bit" ELSE ." 0" THEN 721 | SMUDGE-BIT INVERT AND ." | " 722 | CELL-BITS BYTE-BITS - 2DUP RSHIFT ." (" . ." <<" ." _name_length_bits) | 0x" 723 | 1 SWAP LSHIFT 1- AND H. CR ; 724 | : .PREVIOUS-INFO LAST DUP >INFO @ SWAP >NAME ['] .INFO TO-ASMOUT ; 725 | : .DOES ." .set " .NAME ." _doer, " .NAME ." _does" CR ; 726 | : .DOES-LABEL .NAME ." _does:" CR ; 727 | : .CREATED LAST >NAME ['] .DOES TO-ASMOUT ; 728 | : .SYMBOL 729 | DUP >INFO CELL 1- + C@ IF 730 | >NAME .NAME 731 | ELSE 732 | NONAME .LABEL 733 | THEN ; 734 | : HEADER ( c-addr -- ) 735 | LAST IF \ output previous word's info field 736 | .PREVIOUS-INFO 737 | CREATED @ ?DUP IF .CREATED THEN 738 | THEN 739 | FALSE CREATED ! 740 | DUP >R \ save name 741 | ALIGN \ align DP for new definition 742 | DUP C@ 31 MIN \ get name (max. 31 chars) 743 | OVER C! \ set length 744 | COUNT 745 | 2DUP GET-CURRENT SEARCH-WORDLIST IF \ check name is unique 746 | DROP 2DUP TYPE ." is not unique " 747 | THEN 748 | TUCK \ save length 749 | ", \ write name in name field 750 | BL CALIGN \ pad with spaces to next cell boundary 751 | LAST .LINK \ store link to last word 752 | LAST RAW-REL, 753 | R@ ['] .COMPILE-FIELD TO-ASMOUT \ compilation method field 754 | 0 RAW, 755 | R@ ['] .INFO-FIELD TO-ASMOUT 756 | CELL-BITS BYTE-BITS - LSHIFT RAW, \ save length of name field 757 | R> ['] .NAME-LABEL TO-ASMOUT \ output label 758 | HERE GET-CURRENT REL! ; \ update CURRENT word list 759 | 760 | 761 | \ Exceptions #2 762 | 763 | VARIABLE HANDLER 0 ' HANDLER >BODY ! 764 | : CATCH 765 | SP@ -CELL STACK-DIRECTION * + >R \ push data stack pointer 766 | HANDLER @ >R \ push pointer to last frame 767 | SAVE-INPUT>R \ push current input source 768 | RP@ HANDLER ! \ set pointer to current frame 769 | EXECUTE \ execute guarded word 770 | R> BEGIN ?DUP WHILE \ pop input source; 771 | R> DROP 1- \ can't use a DO loop as that would 772 | REPEAT \ interfere with the return stack 773 | R> HANDLER ! \ reset pointer to previous frame 774 | R> DROP \ discard saved stack pointer 775 | 0 ; \ leave OK flag 776 | 777 | 778 | \ Interpreter #4 779 | 780 | : FOREIGN? ( wid -- f ) 2 CELLS + @ 1023 > ; 781 | : LOCAL? ( wid xt n -- f ) 782 | NIP 1 <> IF \ is the word non-immediate? 783 | STATE @ \ if so, if we are compiling, 784 | GET-CURRENT FOREIGN? AND IF \ and CURRENT is foreign, 785 | GET-CURRENT = \ word must be in CURRENT to be compiled 786 | EXIT 787 | THEN 788 | THEN 789 | FOREIGN? INVERT ; \ otherwise word must be native 790 | : NON-META? ( wid xt n -- f ) 791 | NIP 1 <> STATE @ AND IF \ if we are compiling a word, 792 | DROP TRUE \ allow any word; 793 | ELSE 794 | FOREIGN? INVERT \ to execute, word must be native 795 | THEN ; 796 | CREATE 'SELECTOR ' LOCAL? DUP RAW-REL, .LINK 797 | : INTERPRET 798 | BEGIN BL WORD DUP C@ WHILE \ while text in input stream 799 | 'SELECTOR REL@ SELECT \ search for word 800 | DUP IF \ if word found in dictionary 801 | STATE @ 0= IF \ if interpreting, execute it 802 | DROP \ drop found flag 803 | DUP >INFO @ COMPILING-BIT AND 804 | IF -14 THROW THEN 805 | EXECUTE 806 | ELSE 807 | 0> IF \ if immediate, execute compile method 808 | >COMPILE REL@ EXECUTE 809 | ELSE 810 | CURRENT-COMPILE, \ if non-immediate, compile it 811 | THEN 812 | THEN 813 | ELSE \ if word is not found 814 | DROP \ drop found flag 815 | NUMBER \ try getting a number 816 | STATE @ IF \ compile if STATE is non-zero 817 | IF \ if a double number 818 | SWAP \ compile MS word 819 | CURRENT-LITERAL 820 | THEN 821 | CURRENT-LITERAL \ compile single no./LS word 822 | ELSE 823 | DROP \ else get rid of flag 824 | THEN 825 | THEN 826 | REPEAT DROP ; \ get rid of input address 827 | 828 | : EVALUATE SAVE-INPUT>R -1 TO SOURCE-ID #EVALUAND ! EVALUAND ! 0 >IN ! 829 | INTERPRET R>RESTORE-INPUT ; 830 | 831 | : REFILL ( -- f ) 832 | CASE SOURCE-ID \ switch on SOURCE-ID 833 | 0 OF \ if user input device 834 | TIB 80 ACCEPT \ get a line of text to TIB 835 | #TIB ! 0 >IN ! TRUE 836 | ENDOF 837 | -1 OF FALSE ENDOF \ if a string, return false 838 | >R \ save switch 839 | FIB /FILE-BUFFER R@ READ-LINE \ else read a line from file 840 | ABORT" file read error during REFILL" 841 | \ if an exception occurred, abort 842 | SWAP #FIB ! 0 >IN ! \ set no. of chars in line 843 | R> \ restore switch 844 | ENDCASE ; 845 | 846 | : ?STACK DEPTH 0< ABORT" stack underflow" ; 847 | : REPL 848 | POSTPONE [ 849 | 0 TO SOURCE-ID 850 | BEGIN CR REFILL WHILE 851 | INTERPRET ?STACK STATE @ 0= IF ." ok" THEN 852 | REPEAT 853 | TRUE ABORT" parse area empty" ; 854 | : HANDLE-ERROR ( n -- ) 855 | CASE 856 | -1 OF ( ABORT ) ENDOF 857 | -2 OF 'THROWN @ COUNT TYPE ENDOF 858 | -9 OF -9 HALT ENDOF 859 | -10 OF ." division by zero" ENDOF 860 | -11 OF ." quotient too large" ENDOF 861 | -13 OF 'THROWN @ COUNT TYPE ." ?" ENDOF 862 | -14 OF ." compilation only" ENDOF 863 | -20 OF ." write to a read-only location" ENDOF 864 | -23 OF -23 HALT ENDOF 865 | -56 OF ( QUIT ) ENDOF 866 | -512 OF ." unknown option " 'THROWN @ COUNT TYPE CR 1 HALT ENDOF 867 | ." exception " DUP . ." raised" 868 | ENDCASE ; 869 | : (QUIT) 870 | BEGIN 871 | R0 RP! 872 | ['] REPL CATCH \ cannot return normally 873 | DUP HANDLE-ERROR 874 | -56 <> IF S0 SP! THEN 875 | AGAIN ; 876 | 877 | 878 | \ Tools 879 | 880 | : [ELSE] ( -- ) 881 | 1 BEGIN \ level 882 | BEGIN BL WORD COUNT DUP WHILE \ level adr len 883 | 2DUP S" [IF]" COMPARE 0= IF \ level adr len 884 | 2DROP 1+ \ level' 885 | ELSE \ level adr len 886 | 2DUP S" [ELSE]" COMPARE 0= IF \ level adr len 887 | 2DROP 1- DUP IF 1+ THEN \ level' 888 | ELSE \ level adr len 889 | S" [THEN]" COMPARE 0= IF \ level 890 | 1- \ level' 891 | THEN 892 | THEN 893 | THEN ?DUP 0= IF EXIT THEN \ level' 894 | REPEAT 2DROP \ level 895 | REFILL 0= UNTIL \ level 896 | DROP ; IMMEDIATE 897 | : [IF] ( flag -- ) 898 | 0= IF POSTPONE [ELSE] THEN ; IMMEDIATE 899 | : [THEN] ( -- ) ; IMMEDIATE 900 | 901 | : DEFINED? FIND NIP 0<> ; 902 | : [DEFINED] BL WORD DEFINED? ; IMMEDIATE 903 | : [UNDEFINED] POSTPONE [DEFINED] INVERT ; IMMEDIATE 904 | 905 | 906 | INCLUDE" compiler4.fs" 907 | 908 | 909 | \ Miscellaneous 910 | 911 | : ( 912 | BEGIN 913 | [CHAR] ) PARSE 2DROP \ parse up to ) or end of area 914 | SOURCE-ID 1+ 2 U< IF \ exit if not reading from file 915 | EXIT 916 | THEN 917 | >IN @ IF \ was parse area empty? 918 | SOURCE DROP >IN @ 1- CHARS + C@ [CHAR] ) <> 919 | \ if not, was last character )? 920 | ELSE 921 | TRUE \ if empty we must refill 922 | THEN 923 | WHILE \ if parse area empty or no ) 924 | REFILL 0= \ found, refill and parse again 925 | UNTIL THEN ; IMMEDIATE 926 | 927 | : \ SOURCE NIP >IN ! ; IMMEDIATE 928 | : ? @ . ; 929 | : .S ?STACK DEPTH ?DUP IF 1- 0 SWAP DO I PICK . -1 +LOOP 930 | ELSE ." stack empty " THEN ; 931 | 932 | 933 | \ Mass storage input/output #4 934 | 935 | : INCLUDE-FILE ( i*x fid -- j*x ) 936 | SAVE-INPUT>R \ save current input source 937 | TO SOURCE-ID \ set up new input source 938 | ALLOCATE-BUFFER IF \ allocate new file buffer 939 | SOURCE-ID CLOSE-FILE 940 | TRUE ABORT" no more file buffers" 941 | THEN 942 | TO FIB 943 | REFILL DUP IF \ check for #! line at start of file 944 | #FIB @ 1 > IF \ if we have at least 2 characters 945 | FIB C@ [CHAR] # = 946 | FIB 1+ C@ [CHAR] ! = 947 | AND IF \ and the first two are `#!' 948 | DROP REFILL \ then skip the line 949 | THEN 950 | THEN 951 | THEN 952 | BEGIN WHILE \ interpret the file 953 | ['] INTERPRET CATCH ?DUP IF \ close the file if an exception is 954 | SOURCE-ID CLOSE-FILE DROP \ generated, then pass the exception on 955 | FREE-BUFFER DROP \ having freed the buffer 956 | THROW 957 | THEN 958 | REFILL 959 | REPEAT 960 | FREE-BUFFER ABORT" no file buffer to free" 961 | \ free the file buffer 962 | R>RESTORE-INPUT ; \ restore the input source 963 | : INCLUDED ( i*x c-addr u -- j*x ) 964 | 2DUP R/O OPEN-FILE IF \ open file; if error, 965 | DROP \ get rid of bad fid 966 | \ TYPE FIXME: include file name in error message 967 | TRUE ABORT" file can't be INCLUDED" \ abort with error message 968 | THEN 969 | >R \ save fid 970 | 2DROP \ drop c-addr u 971 | R@ INCLUDE-FILE \ include the file 972 | R> CLOSE-FILE \ close the file; if error, 973 | ABORT" error after INCLUDEing" ; \ give error message and abort 974 | : INCLUDE" ( file ) [CHAR] " WORD COUNT INCLUDED ; 975 | 976 | 977 | INCLUDE" compiler5.fs" 978 | INCLUDE" defining.fs" 979 | 980 | 981 | \ Word lists 982 | 983 | : DICTIONARY CREATE HERE CELL+ , ALLOT DOES> TO DP ; 984 | : ROOT ROOTDP TO DP ; 985 | 986 | CREATE CHAIN HERE BACKWARD .LABEL-DEF 0 , 987 | ( A wordlist has the following structure: 988 | 989 | Head of list relative link to most recently defined word 990 | Link field relative link to next wordlist in CHAIN 991 | Info field bit 10 is FOREIGN flag 992 | ) 993 | : WORDLIST ALIGN HERE 0 RAW, 994 | HERE CHAIN DUP REL@ RAW-REL, 0 .WORD ( FIXME: chain to previous wordlist ) REL! 0 , ; 995 | INCLUDE" vocabulary.fs" 996 | HERE BACKWARD .LABEL-DEF ' .FORTH-ADDRESS TO-ASMOUT 997 | VOCABULARY FORTH 998 | : FORTH-WORDLIST ['] FORTH >BODY REL@ ; 999 | : ALSO CONTEXT DUP CELL+ #ORDER @ CELLS MOVE 1 #ORDER +! ; 1000 | : ONLY FORTH 1 #ORDER ! ; 1001 | : FOREIGN CONTEXT @ 2 CELLS + DUP @ 1024 OR SWAP ! ; 1002 | : NATIVE CONTEXT @ 2 CELLS + DUP @ 1023 AND SWAP ! ; 1003 | : SET-ORDER DUP -1 = IF ONLY ELSE DUP #ORDER ! CELLS CONTEXT TUCK + 1004 | SWAP ?DO I ! CELL +LOOP THEN ; 1005 | : PREVIOUS GET-ORDER DUP 0> IF NIP 1- THEN SET-ORDER ; 1006 | : ORDER ." CONTEXT: " GET-ORDER 0 ?DO H. LOOP CR ." CURRENT: " 1007 | GET-CURRENT H. ; 1008 | 1009 | : (FORGET) 1010 | >NAME DP ! 1011 | CHAIN DUP BEGIN @ DUP HERE < UNTIL OVER ! 1012 | BEGIN @ ?DUP WHILE 1013 | DUP CELL- DUP @ 1014 | BEGIN DUP HERE < INVERT WHILE >LINK REL@ REPEAT 1015 | SWAP REL! 1016 | REPEAT ; 1017 | : FORGET ( name ) ' (FORGET) ; 1018 | : MARKER ( name ) 1019 | CREATE \ create the MARKER word 1020 | GET-ORDER DUP , \ save the search order 1021 | 0 ?DO , LOOP 1022 | LAST , \ and the last definition. 1023 | DP , \ and the current DP 1024 | DOES> \ at runtime: 1025 | DUP @ DUP >R \ save no. of lists in order 1026 | CELLS 2DUP + CELL+ \ get old value of HERE 1027 | DP >R \ save current DP 1028 | DUP CELL+ @ TO DP \ restore old DP 1029 | @ (FORGET) \ delete words after old HERE 1030 | R> TO DP \ restore current DP 1031 | OVER CELL+ -ROT + DO \ retrieve the search order 1032 | I @ 1033 | -CELL +LOOP 1034 | R> \ retrieve size of search order 1035 | SET-ORDER ; \ restore the search order 1036 | 1037 | VARIABLE CURSORX \ cursor x position during WORDS 1038 | : ADVANCE ( +n -- ) CURSORX +! ; 1039 | : WRAP? ( -- f ) CURSORX @ + WIDTH < INVERT ; 1040 | : NEWLINE 0 CURSORX ! CR ; 1041 | 3 CONSTANT GAP 1042 | : WORDLIST-WORDS ( wid -- ) 1043 | NEWLINE \ start listing on a new line 1044 | BEGIN REL@ ?DUP WHILE \ for each word in the chain 1045 | DUP >NAME COUNT \ get the name 1046 | DUP WRAP? IF NEWLINE THEN \ new line if necessary 1047 | DUP ADVANCE \ advance the cursor 1048 | TYPE \ type the name 1049 | GAP WRAP? IF \ leave a gap or move to a new 1050 | NEWLINE \ line 1051 | ELSE 1052 | GAP DUP SPACES ADVANCE 1053 | THEN 1054 | >LINK \ get link to next word 1055 | REPEAT 1056 | CURSORX @ IF NEWLINE THEN ; \ ensure we're on a new line 1057 | : WORDS CONTEXT @ WORDLIST-WORDS ; 1058 | : ALL-WORDS GET-ORDER 0 ?DO WORDLIST-WORDS LOOP ; 1059 | 1060 | 1061 | \ Environmental queries 1062 | 1063 | : ENVIRONMENT? 1064 | "CASE 1065 | S" /COUNTED-STRING" "OF 255 "ENDOF 1066 | S" /HOLD" "OF 256 "ENDOF 1067 | S" /PAD" "OF 256 "ENDOF 1068 | S" ADDRESS-UNIT-BITS" "OF 8 "ENDOF 1069 | S" BLOCK" "OF FALSE "ENDOF 1070 | S" BLOCK-EXT" "OF FALSE "ENDOF 1071 | S" CORE" "OF TRUE "ENDOF 1072 | S" CORE-EXT" "OF FALSE "ENDOF 1073 | S" DOUBLE" "OF FALSE "ENDOF 1074 | S" DOUBLE-EXT" "OF FALSE "ENDOF 1075 | S" EXCEPTION" "OF TRUE "ENDOF 1076 | S" EXCEPTION-EXT" "OF TRUE "ENDOF 1077 | S" FACILITY" "OF FALSE "ENDOF 1078 | S" FACILITY-EXT" "OF FALSE "ENDOF 1079 | S" FILE" "OF TRUE "ENDOF 1080 | S" FILE-EXT" "OF TRUE "ENDOF 1081 | S" FLOORED" "OF TRUE "ENDOF 1082 | S" MAX-CHAR" "OF 255 "ENDOF 1083 | S" MAX-D" "OF -1 1 RSHIFT S>D "ENDOF 1084 | S" MAX-N" "OF -1 1 RSHIFT "ENDOF 1085 | S" MAX-U" "OF -1 "ENDOF 1086 | S" MAX-UD" "OF -1 0 "ENDOF 1087 | S" RETURN-STACK-CELLS" "OF RETURN-STACK-CELLS "ENDOF 1088 | S" SEARCH-ORDER" "OF TRUE "ENDOF 1089 | S" SEARCH-ORDER-EXT" "OF TRUE "ENDOF 1090 | S" STACK-CELLS" "OF STACK-CELLS "ENDOF 1091 | S" STRING" "OF TRUE "ENDOF 1092 | S" STRING-EXT" "OF TRUE "ENDOF 1093 | S" TOOLS" "OF FALSE "ENDOF 1094 | S" TOOLS-EXT" "OF FALSE "ENDOF 1095 | S" WORDLISTS" "OF 8 "ENDOF 1096 | 2DROP FALSE EXIT 1097 | "ENDCASE 1098 | TRUE ; 1099 | 1100 | 1101 | \ Exceptions #3 1102 | 1103 | : (THROW) 1104 | ?DUP IF \ if flag is true 1105 | HANDLER @ ?DUP IF \ and there's a frame to pop 1106 | RP! \ set return stack to frame 1107 | R>RESTORE-INPUT \ restore input source 1108 | R> HANDLER ! \ set pointer to next frame 1109 | R> SWAP >R \ keep exception number 1110 | SP! \ restore data stack 1111 | R> \ restore exception number 1112 | ELSE \ if no frame, 1113 | ERROR-PREFIX \ print any message 1114 | DUP HANDLE-ERROR CR 1115 | HALT \ and halt 1116 | THEN 1117 | THEN ; 1118 | 1119 | 1120 | INCLUDE" os.fs" \ include OS access words 1121 | INCLUDE" save.fs" 1122 | 1123 | : SAVE-IMAGE ( c-addr u -- ) 1124 | 'FORTH -ROT ALIGN HERE 'FORTH - -ROT SAVE-OBJECT ; 1125 | 1126 | 1127 | \ Command-line argument interface 1128 | \ (Design copied from GForth) 1129 | 1130 | VARIABLE ARGC 1131 | 1132 | : INITIALIZE-ARGS TOTAL-ARGS ARGC ! ; 1133 | 1134 | : ARG TOTAL-ARGS ARGC @ - + ABSOLUTE-ARG ; 1135 | : SHIFT-ARGS ARGC @ 1- 0 MAX ARGC ! ; 1136 | : NEXT-ARG 0 ARG SHIFT-ARGS ; 1137 | 1138 | 1139 | \ Initialisation and version number 1140 | 1141 | : VERSION S" @VERSION@" ; 1142 | INCLUDE" platform.fs" 1143 | 1144 | : HELP 1145 | ." Usage: " "PROGRAM-NAME REL@ COUNT TYPE ." [OPTION...] [FILENAME...]" CR 1146 | CR 1147 | ." Run @PACKAGE_NAME@." CR 1148 | CR 1149 | ." --interact enter interactive loop after evaluating" CR 1150 | ." command-line arguments" CR 1151 | ." --evaluate TEXT evaluate the given text" CR 1152 | ." --help display this help message and exit" CR 1153 | ." --version display version information and exit" CR 1154 | ." FILE evaluate FILE" CR 1155 | CR 1156 | ." Report bugs to @PACKAGE_BUGREPORT@." CR ; 1157 | 1158 | : BANNER 1159 | ." @PACKAGE_NAME@ v" VERSION TYPE ." (platform: " "PLATFORM TYPE ." )" 1160 | CR ." (c) Reuben Thomas 1991-2021" CR ; 1161 | 1162 | FALSE VALUE INTERACT? 1163 | : DO-START-OPTIONS 1164 | ARGC @ IF 1165 | HERE "PROGRAM-NAME REL! \ update "PROGRAM-NAME 1166 | NEXT-ARG ", \ save new name 1167 | THEN 1168 | ARGC @ IF 1169 | BEGIN NEXT-ARG OVER WHILE 1170 | OVER C@ [CHAR] - = IF \ process option 1171 | "CASE 1172 | S" --help" "OF HELP BYE "ENDOF 1173 | S" --version" "OF BANNER BYE "ENDOF 1174 | S" --evaluate" "OF NEXT-ARG EVALUATE "ENDOF 1175 | S" --interact" "OF TRUE TO INTERACT? "ENDOF 1176 | HERE 'THROWN ! ", -512 THROW 1177 | "ENDCASE 1178 | ELSE \ or interpret file 1179 | \ FIXME: install CATCH handler, and if INTERACT? is true, even 1180 | \ if case of error, respect it 1181 | INCLUDED 1182 | THEN 1183 | REPEAT 1184 | 2DROP \ drop 0 0 from NEXT-ARG 1185 | INTERACT? INVERT IF BYE THEN 1186 | ELSE 1187 | BANNER 1188 | THEN 1189 | (QUIT) ; 1190 | 1191 | INCLUDE" parse-command-line.fs" 1192 | 1193 | : START ( limit here -- ) 1194 | ROOTDP ! \ initialize dictionary pointer 1195 | DUP TO LIMIT \ set LIMIT 1196 | [ ' (THROW) ] RELATIVE-LITERAL 'THROW! 1197 | \ set 'THROW 1198 | 0 HANDLER ! \ reset HANDLER 1199 | 0 FILE-BUFFER# ! \ reset FILE-BUFFER# 1200 | DUP #FILE-BUFFERS /FILE-BUFFER * - \ file buffers, 1201 | DUP TO FIRST-FILE 1202 | 256 5 * - \ and TIB, PAD, TOKEN, SCRATCH and S"B 1203 | 'BUFFERS ! \ set 'BUFFERS 1204 | 'BUFFERS @ TUCK - ERASE \ erase buffers 1205 | ROOT \ use ROOT dictionary 1206 | ONLY FORTH DEFINITIONS \ minimal word list 1207 | DECIMAL \ numbers treated as base 10 1208 | PARSE-COMMAND-LINE 1209 | INITIALIZE-ARGS 1210 | INITIALIZE-TERMINAL 1211 | DO-START-OPTIONS ; \ process command-line args 1212 | -------------------------------------------------------------------------------- /src/init-space.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2019-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | #TARGET-CALL-CELLS -------------------------------------------------------------------------------- /src/initialize.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 1995-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : INITIALIZE 10 | \ Assume that we were called by a call instruction at 'FORTH, and 11 | \ use our return address to calculate the new value of 'FORTH. 12 | R> CELL- TO 'FORTH 13 | MEMORY@ M0@ + 14 | [ HERE .ASM[ pushreli END_OF_IMAGE] 0 RAW, DUP ] \ value of HERE 15 | START ; 16 | ALIGN 17 | .ASM[ END_OF_IMAGE:] 18 | HERE >-< OP_PUSHRELI OR SWAP ! \ FIXME: add !OFFSET 19 | -------------------------------------------------------------------------------- /src/interpreter3.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2018 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | \ Interpreter #3 10 | 11 | : ABORT" POSTPONE C" POSTPONE (ABORT") ; IMMEDIATE COMPILING 12 | -------------------------------------------------------------------------------- /src/make.fs: -------------------------------------------------------------------------------- 1 | \ Metacompile pForth base image 2 | \ 3 | \ (c) Reuben Thomas 1996-2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | MARKER DISPOSE 12 | 13 | \ Halt immediately on exception, for easier debugging 14 | \ FIXME: Only halt on memory exceptions (or use core dump facility) 15 | \ : HALT-HANDLER HALT ; 16 | \ ' HALT-HANDLER 'THROW! 17 | 18 | DEPTH VALUE INITIAL-DEPTH \ Note initial stack depth 19 | INCLUDE" platform.fs" 20 | CR .( Metacompiling pForth for ) "PLATFORM TYPE .( : ) 21 | 22 | 23 | INCLUDE" assembler.fs" 24 | INCLUDE" save.fs" 25 | 26 | 27 | \ Meta-compiler utilities 28 | 29 | \ ALSO ASSEMBLER 30 | 92 1024 * CONSTANT DICTIONARY-SIZE 31 | 32 | : .[ [CHAR] ] PARSE TYPE ; IMMEDIATE 33 | : .ASM[ ['] .[ TO-ASMOUT ['] CR TO-ASMOUT ; 34 | 35 | : .CALL ." calli " .SYMBOL CR ; 36 | : ASM-COMPILE, DUP >INFO 2 + C@ ?DUP IF 37 | 0 DO DUP DUP @ RAW, DUP @ ['] DISASSEMBLE TO-ASMOUT CELL+ LOOP DROP 38 | ELSE 39 | DUP ['] .CALL TO-ASMOUT 40 | CALL, 41 | THEN ; 42 | 43 | : .FORTH-ADDRESS ." .word last_word - ." CR ; 44 | : .FORTH-LINK ." .set last_word, " LAST >NAME .NAME CR ; 45 | 46 | \ STUB FOO creates an empty word. 47 | \ This is used to POSTPONE target words that may not exist on the host. 48 | : STUB BL WORD HEADER ; 49 | 50 | \ Create stubs for words that may not exist on host 51 | STUB IP 52 | STUB DOCOL 53 | STUB LINK 54 | STUB UNLINK 55 | STUB (LITERAL) 56 | STUB (BRANCH) 57 | STUB (?BRANCH) 58 | STUB (LOOP) 59 | STUB (+LOOP) 60 | STUB UNLOOP 61 | STUB (CREATE) 62 | STUB (C") 63 | STUB (S") 64 | 65 | 66 | \ Machinery for compiling forward references to defining words' DOES> code 67 | 68 | : ADD-RESOLVE DUP @ LAST CELL+ TUCK ! SWAP ! ; 69 | : (DOES>) DUP >NAME CREATED ! >DOES> ADD-RESOLVE ; 70 | : DOES-LINK, 0 , ; 71 | : .DOES-LABEL .NAME ." _does:" CR ; 72 | INCLUDE" does.fs" 73 | 74 | 75 | VOCABULARY META ALSO META DEFINITIONS 76 | FOREIGN ' NON-META? ' 'SELECTOR >BODY REL! \ build meta-compiler using native compiler 77 | DECIMAL 78 | 79 | \ Check stack is balanced 80 | : ??STACK 81 | DEPTH INITIAL-DEPTH <> IF 82 | .S ." stack not balanced" CR ABORT 83 | THEN ; 84 | 85 | 86 | INCLUDE" compiler-defer.fs" 87 | INCLUDE" compiler-asm.fs" 88 | INCLUDE" compiler.fs" 89 | INCLUDE" native-call.fs" 90 | INCLUDE" compiler1.fs" 91 | 92 | 93 | \ Special definition of POSTPONE, to cope with FOREIGN vocabularies 94 | 95 | : ?FIND ( c-addr -- xt ) FIND 0= IF UNDEFINED THEN ; 96 | : (POSTPONE) >NAME ?FIND CURRENT-COMPILE, ; 97 | : (RAW-POSTPONE) >NAME ?FIND CALL, ; 98 | 99 | \ POSTPONE itself must be defined in FORTH, so that it can be run during the 100 | \ compilation of the rest of META, which is FOREIGN while it is being built. 101 | ALSO FORTH DEFINITIONS 102 | 103 | : RAW-POSTPONE 104 | BL WORD DUP FIND 105 | ?DUP 0= IF UNDEFINED THEN 106 | 0> IF 107 | ABORT \ We never RAW-POSTPONE IMMEDIATE words 108 | ELSE 109 | PUSHREL, .PUSHRELI-SYMBOL C" (RAW-POSTPONE)" ?FIND CURRENT-COMPILE, 110 | THEN ; 111 | IMMEDIATE COMPILING 112 | : POSTPONE 113 | BL WORD DUP FIND 114 | ?DUP 0= IF UNDEFINED THEN 115 | 0> IF 116 | >COMPILE REL@ CALL, .CALL-COMPILE-METHOD 117 | ELSE 118 | PUSHREL, .PUSHRELI-SYMBOL C" (POSTPONE)" ?FIND CURRENT-COMPILE, 119 | THEN ; 120 | IMMEDIATE COMPILING 121 | 122 | META DEFINITIONS PREVIOUS \ use META POSTPONE and LINK, 123 | INCLUDE" compiler-postpone.fs" 124 | ALSO META FOREIGN PREVIOUS 125 | 126 | 127 | INCLUDE" code.fs" 128 | INCLUDE" util.fs" 129 | INCLUDE" control2.fs" 130 | INCLUDE" control3.fs" 131 | INCLUDE" strings2b.fs" 132 | INCLUDE" compiler2.fs" 133 | INCLUDE" interpreter3.fs" 134 | : SET-IMMEDIATE LAST >INFO DUP @ TOP-BIT-SET OR SWAP ! ; 135 | INCLUDE" compiler4.fs" 136 | INCLUDE" compiler5.fs" 137 | INCLUDE" defer-fetch-store.fs" 138 | INCLUDE" defining.fs" 139 | INCLUDE" vocabulary.fs" 140 | INCLUDE" resolver-branch.fs" 141 | 142 | : RESOLVES ( name ) ( a-addr -- ) 143 | ' 144 | >DOES> @ \ get first address in branch list 145 | BEGIN ?DUP WHILE \ chain down list until null marker 146 | DUP @ \ get next address in list 147 | -ROT 2DUP SWAP RESOLVER-BRANCH \ compile the call or branch 148 | SWAP 149 | REPEAT 150 | DROP ; \ drop a-addr 151 | 152 | 153 | \ Constants 154 | 155 | DICTIONARY-SIZE CONSTANT SIZE 156 | INCLUDE" call-cells.fs" CONSTANT #TARGET-CALL-CELLS 157 | 158 | NATIVE ' LOCAL? ' 'SELECTOR >BODY REL! \ now meta-compiler is built, allow it to run 159 | 160 | ALSO FORTH \ use FORTH's VOCABULARY 161 | VOCABULARY NEW-FORTH \ define the new root vocabulary 162 | PREVIOUS 163 | 164 | SIZE DICTIONARY CROSS \ define a new dictionary 165 | ' CURRENT-COMPILE, >BODY @ \ save compiler 166 | ' CURRENT-LITERAL >BODY @ 167 | ' CURRENT-RELATIVE-LITERAL >BODY @ 168 | ' ASM-COMPILE, ' CURRENT-COMPILE, >BODY REL! \ use target compiler 169 | ' LITERAL ' CURRENT-LITERAL >BODY REL! 170 | ' RELATIVE-LITERAL ' CURRENT-RELATIVE-LITERAL >BODY REL! 171 | 'FORTH \ save value of 'FORTH 172 | ' CROSS >BODY @ INCLUDE" init-space.fs" CELLS - TO 'FORTH 173 | \ make 'FORTH point to the start of it minus the initial branch 174 | 175 | ALSO CROSS NEW-FORTH DEFINITIONS FOREIGN 176 | STDERR-FILENO TO ASMOUT 177 | .ASM[ calli INITIALIZE] 178 | .ASM[ .set _byte_bits, 8] 179 | .ASM[ .set _immediate_bit, 1 << (bee_word_bits - 1)] 180 | .ASM[ .set _compiling_bit, 1 << (bee_word_bits - 2)] 181 | .ASM[ .set _smudge_bit, 1 << (bee_word_bits - 3)] 182 | .ASM[ .set _name_length_bits, bee_word_bits - _byte_bits] 183 | INCLUDE" primitives.fs" 184 | INCLUDE" system-params.fs" 185 | [UNDEFINED] MINIMAL-PRIMITIVES [IF] 186 | INCLUDE" extra-primitives.fs" 187 | [THEN] 188 | 189 | INCLUDE" highlevel.fs" 190 | INCLUDE" initialize.fs" 191 | 192 | ' .FORTH-LINK TO-ASMOUT 193 | ' NEW-FORTH >BODY REL@ REL@ ' FORTH >BODY REL@ REL! \ patch root wordlist 194 | ' FORTH >BODY REL@ CELL+ CHAIN REL! \ patch CHAIN 195 | ' FORTH >NAME CELL- 0 OVER ! CELL- 0 SWAP ! \ zero FORTH wordlist's info and link fields 196 | ' VALUE >DOES> ALSO META RESOLVES VALUE PREVIOUS \ resolve run-times 197 | ' DEFER >DOES> ALSO META RESOLVES DEFER PREVIOUS 198 | ' VOCABULARY >DOES> ALSO META RESOLVES VOCABULARY PREVIOUS 199 | ' ABORT ' SCAN-TEST >BODY REL! 200 | ' ABORT ' VISIBLE? >BODY REL! 201 | ' NEW-FORTH >BODY REL@ REL@ PREVIOUS \ leave initial branch target on the stack 202 | 203 | .PREVIOUS-INFO \ output info field of last word defined 204 | -1 TO ASMOUT 205 | HERE 'FORTH - \ ( length ) of binary image 206 | ROOT HERE OVER ALLOT \ make space for binary image ( length start ) 207 | TUCK \ ( start length start ) 208 | 'FORTH INCLUDE" init-space.fs" CELLS \ ( s l s 'FORTH nCELLS ) 209 | TUCK + -ROT + \ ( s l 'FORTH+nCELLS s+nCELLS ) 210 | 2 PICK MOVE \ copy dictionary ( s l ) 211 | 212 | OVER INCLUDE" init-space.fs" CELLS ERASE \ zero initial branch space 213 | OVER SWAP 2SWAP 'FORTH ROT NATIVE-CALL \ patch in initial branch 214 | 215 | S" pforth-new" SAVE-OBJECT \ write system image 216 | 217 | ( PREVIOUS) PREVIOUS DEFINITIONS \ restore original order 218 | TO 'FORTH \ restore 'FORTH 219 | TO CURRENT-RELATIVE-LITERAL \ restore original compiler 220 | TO CURRENT-LITERAL 221 | TO CURRENT-COMPILE, 222 | 223 | ALSO META 224 | ??STACK \ check stack is balanced 225 | PREVIOUS 226 | -------------------------------------------------------------------------------- /src/mangle.fs: -------------------------------------------------------------------------------- 1 | \ Name mangling 2 | : ISDIGIT DUP [CHAR] 0 < INVERT SWAP [CHAR] 9 > INVERT AND ; 3 | : ISUPPER DUP [CHAR] A < INVERT SWAP [CHAR] Z > INVERT AND ; 4 | : ISLOWER DUP [CHAR] a < INVERT SWAP [CHAR] z > INVERT AND ; 5 | : ISALPHA DUP ISUPPER SWAP ISLOWER OR ; 6 | : ISALNUM DUP ISDIGIT SWAP ISALPHA OR ; 7 | : 2.H BASE @ >R HEX U>UD <# # # #> R> BASE ! TYPE ; 8 | : .MANGLE ( c-addr u -- ) \ print a Forth name mangled 9 | OVER + SWAP ?DO 10 | I C@ DUP ISALPHA IF \ output letters literally (FIXME: only mangle leading digit) 11 | EMIT 12 | ELSE \ escape everything else 13 | [CHAR] _ EMIT 2.H [CHAR] _ EMIT 14 | THEN 15 | LOOP ; 16 | -------------------------------------------------------------------------------- /src/native-call.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2019-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : NATIVE-CALL CALL ; -------------------------------------------------------------------------------- /src/opcodes.fs: -------------------------------------------------------------------------------- 1 | \ Bee opcodes 2 | \ 3 | \ (c) Reuben Thomas 2019-2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | 12 | : OFFSET ( from to -- offset ) >-< ; 13 | 14 | $0 CONSTANT OP_CALLI $1 CONSTANT OP_PUSHI 15 | $2 CONSTANT OP_PUSHRELI 16 | 17 | : OP2_JUMPI CELL 4 = IF $3 ELSE $3 THEN ; 18 | : OP2_JUMPZI CELL 4 = IF $7 ELSE $4 THEN ; 19 | : OP2_TRAP CELL 4 = IF $B ELSE $5 THEN ; 20 | : OP2_INSN CELL 4 = IF $F ELSE $7 THEN ; 21 | 22 | : OP1_SHIFT CELL 4 = IF 2 ELSE 3 THEN ; 23 | : OP2_SHIFT CELL 4 = IF 4 ELSE 3 THEN ; 24 | 25 | : OP1_MASK CELL 4 = IF $3 ELSE $7 THEN ; 26 | : OP2_MASK CELL 4 = IF $F ELSE $7 THEN ; 27 | 28 | : >OPCODE ( operand type -- ) SWAP OP1_SHIFT LSHIFT OR ; 29 | : >OPCODE2 ( operand type -- ) SWAP OP2_SHIFT LSHIFT OR ; 30 | 31 | : OPCODE> ( instruction -- opcode ) OP1_MASK AND ; 32 | : OPCODE2> ( instruction -- opcode ) OP2_MASK AND ; 33 | 34 | 35 | 0 CONSTANT INSN_NOP 36 | 1 CONSTANT INSN_NOT 37 | 2 CONSTANT INSN_AND 38 | 3 CONSTANT INSN_OR 39 | 4 CONSTANT INSN_XOR 40 | 5 CONSTANT INSN_LSHIFT 41 | 6 CONSTANT INSN_RSHIFT 42 | 7 CONSTANT INSN_ARSHIFT 43 | 44 | 8 CONSTANT INSN_POP 45 | 9 CONSTANT INSN_DUP 46 | 10 CONSTANT INSN_SET 47 | 11 CONSTANT INSN_SWAP 48 | 12 CONSTANT INSN_JUMP 49 | 13 CONSTANT INSN_JUMPZ 50 | 14 CONSTANT INSN_CALL 51 | 15 CONSTANT INSN_RET 52 | 53 | 16 CONSTANT INSN_LOAD 54 | 17 CONSTANT INSN_STORE 55 | 18 CONSTANT INSN_LOAD1 56 | 19 CONSTANT INSN_STORE1 57 | 20 CONSTANT INSN_LOAD2 58 | 21 CONSTANT INSN_STORE2 59 | 22 CONSTANT INSN_LOAD4 60 | 23 CONSTANT INSN_STORE4 61 | 62 | 24 CONSTANT INSN_NEG 63 | 25 CONSTANT INSN_ADD 64 | 26 CONSTANT INSN_MUL 65 | 27 CONSTANT INSN_DIVMOD 66 | 28 CONSTANT INSN_UDIVMOD 67 | 29 CONSTANT INSN_EQ 68 | 30 CONSTANT INSN_LT 69 | 31 CONSTANT INSN_ULT 70 | 71 | 32 CONSTANT INSN_PUSHR 72 | 33 CONSTANT INSN_POPR 73 | 34 CONSTANT INSN_DUPR 74 | 35 CONSTANT INSN_CATCH 75 | 36 CONSTANT INSN_THROW 76 | 37 CONSTANT INSN_BREAK 77 | 38 CONSTANT INSN_WORD_BYTES 78 | 39 CONSTANT INSN_GET_M0 79 | 80 | 40 CONSTANT INSN_GET_MSIZE 81 | 41 CONSTANT INSN_GET_SSIZE 82 | 42 CONSTANT INSN_GET_SP 83 | 43 CONSTANT INSN_SET_SP 84 | 44 CONSTANT INSN_GET_DSIZE 85 | 45 CONSTANT INSN_GET_DP 86 | 46 CONSTANT INSN_SET_DP 87 | 47 CONSTANT INSN_GET_HANDLER_SP 88 | 89 | 48 CONSTANT #INSTRUCTIONS 90 | -------------------------------------------------------------------------------- /src/os-compiler.fs: -------------------------------------------------------------------------------- 1 | \ Writing code to memory 2 | \ 3 | \ (c) Reuben Thomas 2019 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | \ Default naive implementation. 12 | : CODE! ( x adr -- ) ! ; 13 | : CODE, ( x -- ) , ; -------------------------------------------------------------------------------- /src/os.fs: -------------------------------------------------------------------------------- 1 | \ FIXME: use curses instead. 2 | : AT-XY 3 | 27 EMIT [CHAR] [ EMIT SWAP 0 .R [CHAR] ; EMIT 0 .R [CHAR] H EMIT ; 4 | 5 | INCLUDE" compiler-asm.fs" 6 | -------------------------------------------------------------------------------- /src/parse-command-line.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2019 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : PARSE-COMMAND-LINE ; -------------------------------------------------------------------------------- /src/pforth-32.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rrthomas/pforth/c2bf240579ab6dc7784a88f568fc85d2c86387f9/src/pforth-32.bin -------------------------------------------------------------------------------- /src/pforth-64.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rrthomas/pforth/c2bf240579ab6dc7784a88f568fc85d2c86387f9/src/pforth-64.bin -------------------------------------------------------------------------------- /src/pforthi.in: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Run @PACKAGE_NAME@ with command-line completion and history 3 | # (c) Reuben Thomas 2018 4 | 5 | @RLWRAP@ --complete-filenames --history-filename $HOME/.@PACKAGE@_history @PFORTH@ "$@" 6 | -------------------------------------------------------------------------------- /src/platform.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : "PLATFORM S" Bee" ; -------------------------------------------------------------------------------- /src/primitives.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 1995-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | CR .( Required primitives ) 10 | 11 | \ Stack primitives 12 | CODE DROP BPOP BRET END-CODE 1 INLINE 13 | CODE PICK BDUP BRET END-CODE 1 INLINE 14 | CODE >R BPUSHR BRET END-CODE 1 INLINE 15 | CODE R> BPOPR BRET END-CODE 1 INLINE 16 | CODE R@ BDUPR BRET END-CODE 1 INLINE 17 | CODE CELL BWORD_BYTES BRET END-CODE 1 INLINE 18 | 19 | \ Stack management primitives 20 | CODE SP@ BGET_DP BWORD_BYTES BMUL BRET END-CODE 21 | CODE SP! BWORD_BYTES BUDIVMOD BPOP BSET_DP BRET END-CODE 22 | CODE RP@ BGET_SP BRET END-CODE 1 INLINE 23 | CODE RP! BSET_SP BRET END-CODE 1 INLINE 24 | CODE MEMORY@ BGET_MSIZE BRET END-CODE 1 INLINE 25 | CODE M0@ BGET_M0 BRET END-CODE 1 INLINE 26 | CODE S0 0 BPUSHI BRET END-CODE 27 | CODE R0 0 BPUSHI BRET END-CODE 28 | 29 | \ Memory primitives 30 | CODE @ BLOAD BRET END-CODE 1 INLINE 31 | CODE ! BSTORE BRET END-CODE 1 INLINE 32 | CODE C@ BLOAD1 BRET END-CODE 1 INLINE 33 | CODE C! BSTORE1 BRET END-CODE 1 INLINE 34 | 35 | \ Arithmetic and logical primitives 36 | CODE + BADD BRET END-CODE 1 INLINE 37 | CODE NEGATE BNEG BRET END-CODE 1 INLINE 38 | CODE * BMUL BRET END-CODE 1 INLINE 39 | CODE (U/MOD) BUDIVMOD 0 BPUSHI BSWAP BRET END-CODE 3 INLINE 40 | CODE (S/REM) BDIVMOD 0 BPUSHI BSWAP BRET END-CODE 3 INLINE 41 | CODE = BEQ BNEG BRET END-CODE 2 INLINE 42 | CODE < BLT BNEG BRET END-CODE 2 INLINE 43 | CODE U< BULT BNEG BRET END-CODE 2 INLINE 44 | CODE INVERT BNOT BRET END-CODE 1 INLINE 45 | CODE AND BAND BRET END-CODE 1 INLINE 46 | CODE OR BOR BRET END-CODE 1 INLINE 47 | CODE XOR BXOR BRET END-CODE 1 INLINE 48 | CODE LSHIFT BLSHIFT BRET END-CODE 1 INLINE 49 | CODE RSHIFT BRSHIFT BRET END-CODE 1 INLINE 50 | 51 | \ Control primitives 52 | CODE EXIT BRET END-CODE 1 INLINE \ FIXME: Should be EXECUTEable 53 | CODE EXECUTE BCALL BRET END-CODE 1 INLINE 54 | CODE @EXECUTE BLOAD BCALL BRET END-CODE 55 | 56 | \ System primitives 57 | CODE HALT BTHROW END-CODE 1 INLINE 58 | \ (CREATE) must not be inlined 59 | CODE (CREATE) LAST >NAME ' .DOES-LABEL TO-ASMOUT BPOPR BRET END-CODE 60 | -------------------------------------------------------------------------------- /src/resolver-branch.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 1995-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : RESOLVER-BRANCH CALL ; -------------------------------------------------------------------------------- /src/save.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2018-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | \ Save an object file 10 | \ FIXME: Check I/O return codes 11 | : SAVE-FILE ( a-addr u1 c-addr u2 -- ) 12 | W/O BIN CREATE-FILE DROP \ open file 13 | >R \ save file-id 14 | R@ WRITE-FILE DROP \ write data 15 | R> CLOSE-FILE DROP ; \ close file 16 | 17 | : SAVE-OBJECT SAVE-FILE ; -------------------------------------------------------------------------------- /src/strings2a.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 1991-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : (C") R> DUP C@ 1+ CHARS OVER + ALIGNED >R ; 10 | : (S") R> DUP C@ TUCK 1+ CHARS OVER + ALIGNED >R 11 | CHAR+ SWAP ; 12 | -------------------------------------------------------------------------------- /src/strings2b.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 1991-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : CLITERAL POSTPONE (C") ", 0 CALIGN ; IMMEDIATE COMPILING 10 | : SLITERAL POSTPONE (S") ", 0 CALIGN ; IMMEDIATE COMPILING 11 | -------------------------------------------------------------------------------- /src/system-params.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 1995-2019 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | 4096 CONSTANT STACK-CELLS 10 | 4096 CONSTANT RETURN-STACK-CELLS 11 | -------------------------------------------------------------------------------- /src/terminal.fs: -------------------------------------------------------------------------------- 1 | \ Terminal input/output 2 | \ 3 | \ (c) Reuben Thomas 1995-2020 4 | \ 5 | \ The package is distributed under the GNU GPL version 3, or, at your 6 | \ option, any later version. 7 | \ 8 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 9 | \ RISK. 10 | 11 | \ I/O streams 12 | CREATE IO-BUFFER 1 ALLOT-CELLS 13 | 0 VALUE STDIN 0 VALUE STDOUT 0 VALUE STDERR 14 | 15 | : INITIALIZE-TERMINAL 16 | STDIN-FILENO TO STDIN 17 | STDOUT-FILENO TO STDOUT 18 | STDERR-FILENO TO STDERR ; 19 | 20 | : EMIT IO-BUFFER TUCK C! 1 STDOUT WRITE-FILE DROP ; 21 | : KEY IO-BUFFER DUP 1 STDIN READ-FILE 2DROP C@ ; 22 | 23 | : BL 32 ; 24 | : CR 13 EMIT 10 EMIT ; 25 | : DEL 8 EMIT BL EMIT 8 EMIT ; 26 | 27 | : DEL? DUP 127 = SWAP 8 = OR ; 28 | : CR? DUP 13 = SWAP 10 = OR ; 29 | CREATE EOL" 10 C, 0 CALIGN \ FIXME: Make SLITERAL work here 30 | : EOL EOL" 1 ; 31 | 32 | \ FIXME: implement GET-ENVIRONMENT-VARIABLE and use it to read $COLUMNS 33 | 77 CONSTANT WIDTH \ width of display 34 | 35 | : REDIRECT-STDOUT ( xt fd -- ) 36 | STDOUT >R 37 | TO STDOUT 38 | EXECUTE 39 | R> TO STDOUT ; 40 | 41 | -1 VALUE ASMOUT \ is this really an acceptable way to swallow output? 42 | : TO-ASMOUT ASMOUT REDIRECT-STDOUT ; 43 | -------------------------------------------------------------------------------- /src/util.fs: -------------------------------------------------------------------------------- 1 | : LIBC-PRIMITIVE NIP NIP CODE BPUSHI LIBC BRET END-CODE 2 INLINE ; 2 | -------------------------------------------------------------------------------- /src/vocabulary.fs: -------------------------------------------------------------------------------- 1 | \ (c) Reuben Thomas 2016-2020 2 | \ 3 | \ The package is distributed under the GNU GPL version 3, or, at your 4 | \ option, any later version. 5 | \ 6 | \ THIS PROGRAM IS PROVIDED AS IS, WITH NO WARRANTY. USE IS AT THE USER’S 7 | \ RISK. 8 | 9 | : VOCABULARY WORDLIST CREATE REL, DOES> 10 | #ORDER @ 0= IF 1 #ORDER +! THEN REL@ CONTEXT ! ; --------------------------------------------------------------------------------