├── AUTHORS ├── LICENSE ├── Makefile ├── README.md ├── annexia ├── jonesforth.f.txt └── jonesforth.s.txt ├── firmware ├── bootcode.bin └── start.elf ├── hex.scr ├── jonesforth.f ├── jonesforth.s └── loadmap /AUTHORS: -------------------------------------------------------------------------------- 1 | Minimised minforth version: 2 | John Williamson 3 | 4 | Bare-metal Raspberry Pi port by: 5 | 6 | Dale Schumacher 7 | Tristan Slominski 8 | 9 | M2IHP'13 class Contributors: 10 | 11 | ABECASSIS Felix 12 | BISPO VIEIRA Ricardo 13 | BLANC Benjamin 14 | BORDESSOULES Arthur 15 | BOUDJEMAI Yassine 16 | BRICAGE Marie 17 | ETSCHMANN Marc 18 | GAYE Ndeye Aram 19 | GONCALVES Thomas 20 | GOUGEAUD Sebastien 21 | HAINE Christopher 22 | OLIVEIRA Pablo 23 | PLAZA ONATE Florian 24 | POPOV Mihail 25 | 26 | Original x86/FORTH Literate Code by: 27 | 28 | Richard W.M. Jones 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER 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 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Makefile for minforth -- Raspberry Pi JonesFORTH Operating System 3 | # 4 | # remove the prefix if compiling on an RPI 5 | PREFIX= arm-none-eabi- 6 | AS= $(PREFIX)as 7 | CC= $(PREFIX)gcc -Wall -O2 -nostdlib -nostartfiles -ffreestanding -Os 8 | LD= $(PREFIX)ld 9 | 10 | KOBJS= jonesforth.o 11 | 12 | all: kernel.img 13 | 14 | 15 | jonesforth.o: jonesforth.s 16 | $(AS) jonesforth.s -o jonesforth.o 17 | 18 | kernel.img: loadmap $(KOBJS) jonesforth.f 19 | $(PREFIX)objcopy -I binary -O elf32-littlearm -B arm --rename-section .data=.rodata,alloc,load,readonly,data,contents jonesforth.f jonesforthf.o 20 | $(LD) $(KOBJS) jonesforthf.o -T loadmap -o minforth.elf -Map minforth.map 21 | $(PREFIX)objdump -D minforth.elf > minforth.list 22 | $(PREFIX)objcopy minforth.elf -O ihex minforth.hex 23 | $(PREFIX)objcopy --only-keep-debug minforth.elf kernel.sym 24 | $(PREFIX)objcopy minforth.elf -O binary kernel.img 25 | hexdump -v -e '16/1 " %.2X""\n"' kernel.img > kernel.hex 26 | echo " END" >> kernel.hex 27 | 28 | .c.o: 29 | $(CC) -c $< 30 | 31 | clean: 32 | rm -f *.o 33 | rm -f *.bin 34 | rm -f *.hex 35 | rm -f *.elf 36 | rm -f *.list 37 | rm -f *.img 38 | rm -f *~ core 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Raspberry Pi JonesFORTH O/S 2 | 3 | Derived from [pijFORTHos], in turn based on [_Jonesforth-ARM_](https://github.com/M2IHP13-admin/JonesForth-arm). 4 | 5 | _Jonesforth-ARM_ is an ARM port, by M2IHP'13 class members listed in `AUTHORS`, of _x86 JonesForth_. Much of the bare metal code 6 | was modified from [dwelch67]'s excellent bare metal tutorials. 7 | 8 | The major difference with pijFORTHos is a really minimal ASM kernel (just 3k), and no C code. The kernel does *just* enough to bootstrap FORTH. 9 | 10 | ## Instructions 11 | 12 | On an RPi you can just do 13 | 14 | make clean ; make 15 | 16 | Then copy kernel.img, start.elf, bootload.bin to a blank FAT32 formatted SD card. 17 | 18 | Everything that works in pijFORTHos should also work here. But note that the 19 | bootloader can be called with UPLOAD, but expects a hex dump of the kernel. 20 | The makefile generates this as kernel.hex. 21 | You can simply paste (Ctrl-a Ctrl-y in Minicom) in after entering UPLOAD and the kernel will be transferred. 22 | BOOT will start the new kernel and reload it. 23 | 24 | As in pijFORTHos, you can connect over serial with the port settings 115200-8-N-1. If you use minicom, the supplied 25 | script hex.scr recompiles, and then uses the bootloader to upload the new kernel and reboots. Configure minicom to use 26 | ANSI color, as minFORTH use ANSI codes to display colored text, clear the screen etc. 27 | 28 | ## Running 29 | 30 | ____ _____ ____ ______ __ __ 31 | __ /\ _`\ /\ __`\/\ _`\ /\__ _\/\ \/\ \ 32 | ___ ___ /\_\ ___\ \ \L\_\ \ \/\ \ \ \L\ \/_/\ \/\ \ \_\ \ 33 | /' __` __`\/\ \ /' _ `\ \ _\/\ \ \ \ \ \ , / \ \ \ \ \ _ \ 34 | /\ \/\ \/\ \ \ \/\ \/\ \ \ \/ \ \ \_\ \ \ \\ \ \ \ \ \ \ \ \ \ 35 | \ \_\ \_\ \_\ \_\ \_\ \_\ \_\ \ \_____\ \_\ \_\ \ \_\ \ \_\ \_\ 36 | \/_/\/_/\/_/\/_/\/_/\/_/\/_/ \/_____/\/_/\/ / \/_/ \/_/\/_/ 37 | 0x4183976 CELLS FREE 38 | HERE:0x21E80 LATEST:0x21E1C R0:0xFD20 RSP:0xFD14 DSP:0x7CF4 S0:0x8000 39 | 40 | 41 | Original pijFORTHos documentation: 42 | 43 | pijFORTHos 44 | 45 | _x86 JonesForth_ is a Linux-hosted FORTH presented in a Literate Programming style 46 | by Richard W.M. Jones originally at . 47 | Comments embedded in the original provide an excellent FORTH implementation tutorial. 48 | See the `/annexia/` directory for a copy of this original source. 49 | 50 | The algorithm for our unsigned DIVMOD instruction is extracted from 'ARM 51 | Software Development Toolkit User Guide v2.50' published by ARM in 1997-1998 52 | 53 | Firmware files to make bootable images are maintained at . 54 | See the `/firmware/` directory for local copies used in the build process. 55 | 56 | 57 | ## What is this ? 58 | 59 | _pijFORTHos_ is a bare-metal FORTH interpreter for the Raspberry Pi. 60 | It follows the general strategy given by David Welch's 61 | [excellent examples](https://github.com/dwelch67/raspberrypi). 62 | A simple [bootloader](/doc/bootload.md#bootloader) is built in, 63 | supporting XMODEM uploads of new bare-metal kernel images. 64 | 65 | The interpreter uses the RPi serial console (115200 baud, 8 data bits, no parity, 1 stop bit). 66 | If you have _pijFORTHos_ on an SD card in the RPi, 67 | you can connect it to another machine (even another RPi) 68 | using a [USB-to-Serial cable](http://www.adafruit.com/products/954). 69 | When the RPi is powered on (I provide power through the cable), 70 | a terminal program on the host machine allows access to the FORTH console. 71 | 72 | 73 | ## Build and run instructions 74 | 75 | If you are building on the RPi, just type: 76 | 77 | $ make clean all 78 | 79 | If you can't compile (or cross-compile) from source, 80 | you can use the pre-built `kernel.img` file. 81 | 82 | Next, copy the firmware and kernel to a blank SD card, for example: 83 | 84 | $ cp firmware/* /media// 85 | $ cp kernel.img /media// 86 | 87 | The end state for the SD card is to have a FAT32 filesystem on it with the following files: 88 | 89 | bootcode.bin 90 | start.elf 91 | kernel.img 92 | 93 | Put the prepared SD card into the RPi, 94 | connect the USB-to-Serial cable 95 | (see [RPi Serial Connection](http://elinux.org/RPi_Serial_Connection) for more details), 96 | and power-up to the console. 97 | 98 | To get to the console, you'll need to connect. Here are two ways to try: 99 | 100 | $ minicom -b 115200 -o -D 101 | 102 | Where `` is something like `/dev/ttyUSB0` or similar 103 | (wherever you plugged in your USB-to-Serial cable). 104 | 105 | Alternatively, if `minicom` is not working for you, try using `screen`: 106 | 107 | $ screen 115200 108 | 109 | Where `` is, again, something like `/dev/ttyUSB0`. 110 | 111 | The console will be waiting for an input, press ``. You should then see: 112 | 113 | pijFORTHos sp=0x00008000 114 | 115 | 116 | ## Where to go from HERE ? 117 | 118 | With FORTH REPL running, try typing: 119 | 120 | HEX 8000 DECIMAL 128 DUMP 121 | 122 | You should see something like: 123 | 124 | 00008000 08 10 4f e2 01 d0 a0 e1 80 e0 9f e5 02 09 a0 e3 |..O.............| 125 | 00008010 01 00 50 e1 44 06 00 0a 00 e0 a0 e1 7f 2c a0 e3 |..P.D........,..| 126 | 00008020 f8 07 b1 e8 f8 07 a0 e8 20 20 52 e2 fb ff ff ca |........ R.....| 127 | 00008030 1e ff 2f e1 fe ff ff ea 1e ff 2f e1 00 10 80 e5 |../......./.....| 128 | 00008040 1e ff 2f e1 00 00 90 e5 1e ff 2f e1 b0 10 c0 e1 |../......./.....| 129 | 00008050 1e ff 2f e1 b0 00 d0 e1 1e ff 2f e1 00 10 c0 e5 |../......./.....| 130 | 00008060 1e ff 2f e1 00 00 d0 e5 1e ff 2f e1 0e 00 a0 e1 |../......./.....| 131 | 00008070 1e ff 2f e1 10 ff 2f e1 ff 5f 2d e9 f8 07 b1 e8 |../.../.._-.....| 132 | 133 | For something a little more interesting, try the [GPIO Morse Code](/doc/blinker.md) tutorial. 134 | 135 | The [FORTH reference](/doc/forth.md) page describes the FORTH words available in _pijFORTHos_. 136 | 137 | The [Bootloader](/doc/bootload.md) page describes the memory layout and boot process. 138 | 139 | There is a persistent thread on the Rasberry Pi forums with a useful collection of 140 | [bare-metal resources](http://www.raspberrypi.org/forums/viewtopic.php?f=72&t=72260), 141 | including ARM CPU programming references and peripheral register descriptions. 142 | -------------------------------------------------------------------------------- /annexia/jonesforth.f.txt: -------------------------------------------------------------------------------- 1 | \ -*- text -*- 2 | \ A sometimes minimal FORTH compiler and tutorial for Linux / i386 systems. -*- asm -*- 3 | \ By Richard W.M. Jones http://annexia.org/forth 4 | \ This is PUBLIC DOMAIN (see public domain release statement below). 5 | \ $Id: jonesforth.f,v 1.13 2007/10/07 11:07:15 rich Exp $ 6 | \ 7 | \ The first part of this tutorial is in jonesforth.S. Get if from http://annexia.org/forth 8 | \ 9 | \ PUBLIC DOMAIN ---------------------------------------------------------------------- 10 | \ 11 | \ I, the copyright holder of this work, hereby release it into the public domain. This applies worldwide. 12 | \ 13 | \ In case this is not legally possible, I grant any entity the right to use this work for any purpose, 14 | \ without any conditions, unless such conditions are required by law. 15 | \ 16 | \ SETTING UP ---------------------------------------------------------------------- 17 | \ 18 | \ Let's get a few housekeeping things out of the way. Firstly because I need to draw lots of 19 | \ ASCII-art diagrams to explain concepts, the best way to look at this is using a window which 20 | \ uses a fixed width font and is at least this wide: 21 | \ 22 | \<------------------------------------------------------------------------------------------------------------------------> 23 | \ 24 | \ Secondly make sure TABS are set to 8 characters. The following should be a vertical 25 | \ line. If not, sort out your tabs. 26 | \ 27 | \ | 28 | \ | 29 | \ | 30 | \ 31 | \ Thirdly I assume that your screen is at least 50 characters high. 32 | \ 33 | \ START OF FORTH CODE ---------------------------------------------------------------------- 34 | \ 35 | \ We've now reached the stage where the FORTH system is running and self-hosting. All further 36 | \ words can be written as FORTH itself, including words like IF, THEN, .", etc which in most 37 | \ languages would be considered rather fundamental. 38 | \ 39 | \ Some notes about the code: 40 | \ 41 | \ I use indenting to show structure. The amount of whitespace has no meaning to FORTH however 42 | \ except that you must use at least one whitespace character between words, and words themselves 43 | \ cannot contain whitespace. 44 | \ 45 | \ FORTH is case-sensitive. Use capslock! 46 | 47 | \ The primitive word /MOD (DIVMOD) leaves both the quotient and the remainder on the stack. (On 48 | \ i386, the idivl instruction gives both anyway). Now we can define the / and MOD in terms of /MOD 49 | \ and a few other primitives. 50 | : / /MOD SWAP DROP ; 51 | : MOD /MOD DROP ; 52 | 53 | \ Define some character constants 54 | : '\n' 10 ; 55 | : BL 32 ; \ BL (BLank) is a standard FORTH word for space. 56 | 57 | \ CR prints a carriage return 58 | : CR '\n' EMIT ; 59 | 60 | \ SPACE prints a space 61 | : SPACE BL EMIT ; 62 | 63 | \ The 2... versions of the standard operators work on pairs of stack entries. They're not used 64 | \ very commonly so not really worth writing in assembler. Here is how they are defined in FORTH. 65 | : 2DUP OVER OVER ; 66 | : 2DROP DROP DROP ; 67 | 68 | \ More standard FORTH words. 69 | : 2* 2 * ; 70 | : 2/ 2 / ; 71 | 72 | \ NEGATE leaves the negative of a number on the stack. 73 | : NEGATE 0 SWAP - ; 74 | 75 | \ Standard words for booleans. 76 | : TRUE 1 ; 77 | : FALSE 0 ; 78 | : NOT 0= ; 79 | 80 | \ LITERAL takes whatever is on the stack and compiles LIT 81 | : LITERAL IMMEDIATE 82 | ' LIT , \ compile LIT 83 | , \ compile the literal itself (from the stack) 84 | ; 85 | 86 | \ Now we can use [ and ] to insert literals which are calculated at compile time. (Recall that 87 | \ [ and ] are the FORTH words which switch into and out of immediate mode.) 88 | \ Within definitions, use [ ... ] LITERAL anywhere that '...' is a constant expression which you 89 | \ would rather only compute once (at compile time, rather than calculating it each time your word runs). 90 | : ':' 91 | [ \ go into immediate mode (temporarily) 92 | CHAR : \ push the number 58 (ASCII code of colon) on the parameter stack 93 | ] \ go back to compile mode 94 | LITERAL \ compile LIT 58 as the definition of ':' word 95 | ; 96 | 97 | \ A few more character constants defined the same way as above. 98 | : ';' [ CHAR ; ] LITERAL ; 99 | : '(' [ CHAR ( ] LITERAL ; 100 | : ')' [ CHAR ) ] LITERAL ; 101 | : '"' [ CHAR " ] LITERAL ; 102 | : 'A' [ CHAR A ] LITERAL ; 103 | : '0' [ CHAR 0 ] LITERAL ; 104 | : '-' [ CHAR - ] LITERAL ; 105 | : '.' [ CHAR . ] LITERAL ; 106 | 107 | \ While compiling, '[COMPILE] word' compiles 'word' if it would otherwise be IMMEDIATE. 108 | : [COMPILE] IMMEDIATE 109 | WORD \ get the next word 110 | FIND \ find it in the dictionary 111 | >CFA \ get its codeword 112 | , \ and compile that 113 | ; 114 | 115 | \ RECURSE makes a recursive call to the current word that is being compiled. 116 | \ 117 | \ Normally while a word is being compiled, it is marked HIDDEN so that references to the 118 | \ same word within are calls to the previous definition of the word. However we still have 119 | \ access to the word which we are currently compiling through the LATEST pointer so we 120 | \ can use that to compile a recursive call. 121 | : RECURSE IMMEDIATE 122 | LATEST @ \ LATEST points to the word being compiled at the moment 123 | >CFA \ get the codeword 124 | , \ compile it 125 | ; 126 | 127 | \ CONTROL STRUCTURES ---------------------------------------------------------------------- 128 | \ 129 | \ So far we have defined only very simple definitions. Before we can go further, we really need to 130 | \ make some control structures, like IF ... THEN and loops. Luckily we can define arbitrary control 131 | \ structures directly in FORTH. 132 | \ 133 | \ Please note that the control structures as I have defined them here will only work inside compiled 134 | \ words. If you try to type in expressions using IF, etc. in immediate mode, then they won't work. 135 | \ Making these work in immediate mode is left as an exercise for the reader. 136 | 137 | \ condition IF true-part THEN rest 138 | \ -- compiles to: --> condition 0BRANCH OFFSET true-part rest 139 | \ where OFFSET is the offset of 'rest' 140 | \ condition IF true-part ELSE false-part THEN 141 | \ -- compiles to: --> condition 0BRANCH OFFSET true-part BRANCH OFFSET2 false-part rest 142 | \ where OFFSET if the offset of false-part and OFFSET2 is the offset of rest 143 | 144 | \ IF is an IMMEDIATE word which compiles 0BRANCH followed by a dummy offset, and places 145 | \ the address of the 0BRANCH on the stack. Later when we see THEN, we pop that address 146 | \ off the stack, calculate the offset, and back-fill the offset. 147 | : IF IMMEDIATE 148 | ' 0BRANCH , \ compile 0BRANCH 149 | HERE @ \ save location of the offset on the stack 150 | 0 , \ compile a dummy offset 151 | ; 152 | 153 | : THEN IMMEDIATE 154 | DUP 155 | HERE @ SWAP - \ calculate the offset from the address saved on the stack 156 | SWAP ! \ store the offset in the back-filled location 157 | ; 158 | 159 | : ELSE IMMEDIATE 160 | ' BRANCH , \ definite branch to just over the false-part 161 | HERE @ \ save location of the offset on the stack 162 | 0 , \ compile a dummy offset 163 | SWAP \ now back-fill the original (IF) offset 164 | DUP \ same as for THEN word above 165 | HERE @ SWAP - 166 | SWAP ! 167 | ; 168 | 169 | \ BEGIN loop-part condition UNTIL 170 | \ -- compiles to: --> loop-part condition 0BRANCH OFFSET 171 | \ where OFFSET points back to the loop-part 172 | \ This is like do { loop-part } while (condition) in the C language 173 | : BEGIN IMMEDIATE 174 | HERE @ \ save location on the stack 175 | ; 176 | 177 | : UNTIL IMMEDIATE 178 | ' 0BRANCH , \ compile 0BRANCH 179 | HERE @ - \ calculate the offset from the address saved on the stack 180 | , \ compile the offset here 181 | ; 182 | 183 | \ BEGIN loop-part AGAIN 184 | \ -- compiles to: --> loop-part BRANCH OFFSET 185 | \ where OFFSET points back to the loop-part 186 | \ In other words, an infinite loop which can only be returned from with EXIT 187 | : AGAIN IMMEDIATE 188 | ' BRANCH , \ compile BRANCH 189 | HERE @ - \ calculate the offset back 190 | , \ compile the offset here 191 | ; 192 | 193 | \ BEGIN condition WHILE loop-part REPEAT 194 | \ -- compiles to: --> condition 0BRANCH OFFSET2 loop-part BRANCH OFFSET 195 | \ where OFFSET points back to condition (the beginning) and OFFSET2 points to after the whole piece of code 196 | \ So this is like a while (condition) { loop-part } loop in the C language 197 | : WHILE IMMEDIATE 198 | ' 0BRANCH , \ compile 0BRANCH 199 | HERE @ \ save location of the offset2 on the stack 200 | 0 , \ compile a dummy offset2 201 | ; 202 | 203 | : REPEAT IMMEDIATE 204 | ' BRANCH , \ compile BRANCH 205 | SWAP \ get the original offset (from BEGIN) 206 | HERE @ - , \ and compile it after BRANCH 207 | DUP 208 | HERE @ SWAP - \ calculate the offset2 209 | SWAP ! \ and back-fill it in the original location 210 | ; 211 | 212 | \ UNLESS is the same as IF but the test is reversed. 213 | \ 214 | \ Note the use of [COMPILE]: Since IF is IMMEDIATE we don't want it to be executed while UNLESS 215 | \ is compiling, but while UNLESS is running (which happens to be when whatever word using UNLESS is 216 | \ being compiled -- whew!). So we use [COMPILE] to reverse the effect of marking IF as immediate. 217 | \ This trick is generally used when we want to write our own control words without having to 218 | \ implement them all in terms of the primitives 0BRANCH and BRANCH, but instead reusing simpler 219 | \ control words like (in this instance) IF. 220 | : UNLESS IMMEDIATE 221 | ' NOT , \ compile NOT (to reverse the test) 222 | [COMPILE] IF \ continue by calling the normal IF 223 | ; 224 | 225 | \ COMMENTS ---------------------------------------------------------------------- 226 | \ 227 | \ FORTH allows ( ... ) as comments within function definitions. This works by having an IMMEDIATE 228 | \ word called ( which just drops input characters until it hits the corresponding ). 229 | : ( IMMEDIATE 230 | 1 \ allowed nested parens by keeping track of depth 231 | BEGIN 232 | KEY \ read next character 233 | DUP '(' = IF \ open paren? 234 | DROP \ drop the open paren 235 | 1+ \ depth increases 236 | ELSE 237 | ')' = IF \ close paren? 238 | 1- \ depth decreases 239 | THEN 240 | THEN 241 | DUP 0= UNTIL \ continue until we reach matching close paren, depth 0 242 | DROP \ drop the depth counter 243 | ; 244 | 245 | ( 246 | From now on we can use ( ... ) for comments. 247 | 248 | STACK NOTATION ---------------------------------------------------------------------- 249 | 250 | In FORTH style we can also use ( ... -- ... ) to show the effects that a word has on the 251 | parameter stack. For example: 252 | 253 | ( n -- ) means that the word consumes an integer (n) from the parameter stack. 254 | ( b a -- c ) means that the word uses two integers (a and b, where a is at the top of stack) 255 | and returns a single integer (c). 256 | ( -- ) means the word has no effect on the stack 257 | ) 258 | 259 | ( Some more complicated stack examples, showing the stack notation. ) 260 | : NIP ( x y -- y ) SWAP DROP ; 261 | : TUCK ( x y -- y x y ) DUP ROT ; 262 | : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u ) 263 | 1+ ( add one because of 'u' on the stack ) 264 | 4 * ( multiply by the word size ) 265 | DSP@ + ( add to the stack pointer ) 266 | @ ( and fetch ) 267 | ; 268 | 269 | ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. ) 270 | : SPACES ( n -- ) 271 | BEGIN 272 | DUP 0> ( while n > 0 ) 273 | WHILE 274 | SPACE ( print a space ) 275 | 1- ( until we count down to 0 ) 276 | REPEAT 277 | DROP 278 | ; 279 | 280 | ( Standard words for manipulating BASE. ) 281 | : DECIMAL ( -- ) 10 BASE ! ; 282 | : HEX ( -- ) 16 BASE ! ; 283 | 284 | ( 285 | PRINTING NUMBERS ---------------------------------------------------------------------- 286 | 287 | The standard FORTH word . (DOT) is very important. It takes the number at the top 288 | of the stack and prints it out. However first I'm going to implement some lower-level 289 | FORTH words: 290 | 291 | U.R ( u width -- ) which prints an unsigned number, padded to a certain width 292 | U. ( u -- ) which prints an unsigned number 293 | .R ( n width -- ) which prints a signed number, padded to a certain width. 294 | 295 | For example: 296 | -123 6 .R 297 | will print out these characters: 298 | - 1 2 3 299 | 300 | In other words, the number padded left to a certain number of characters. 301 | 302 | The full number is printed even if it is wider than width, and this is what allows us to 303 | define the ordinary functions U. and . (we just set width to zero knowing that the full 304 | number will be printed anyway). 305 | 306 | Another wrinkle of . and friends is that they obey the current base in the variable BASE. 307 | BASE can be anything in the range 2 to 36. 308 | 309 | While we're defining . &c we can also define .S which is a useful debugging tool. This 310 | word prints the current stack (non-destructively) from top to bottom. 311 | ) 312 | 313 | ( This is the underlying recursive definition of U. ) 314 | : U. ( u -- ) 315 | BASE @ /MOD ( width rem quot ) 316 | ?DUP IF ( if quotient <> 0 then ) 317 | RECURSE ( print the quotient ) 318 | THEN 319 | 320 | ( print the remainder ) 321 | DUP 10 < IF 322 | '0' ( decimal digits 0..9 ) 323 | ELSE 324 | 10 - ( hex and beyond digits A..Z ) 325 | 'A' 326 | THEN 327 | + 328 | EMIT 329 | ; 330 | 331 | ( 332 | FORTH word .S prints the contents of the stack. It doesn't alter the stack. 333 | Very useful for debugging. 334 | ) 335 | : .S ( -- ) 336 | DSP@ ( get current stack pointer ) 337 | BEGIN 338 | DUP S0 @ < 339 | WHILE 340 | DUP @ U. ( print the stack element ) 341 | SPACE 342 | 4+ ( move up ) 343 | REPEAT 344 | DROP 345 | ; 346 | 347 | ( This word returns the width (in characters) of an unsigned number in the current base ) 348 | : UWIDTH ( u -- width ) 349 | BASE @ / ( rem quot ) 350 | ?DUP IF ( if quotient <> 0 then ) 351 | RECURSE 1+ ( return 1+recursive call ) 352 | ELSE 353 | 1 ( return 1 ) 354 | THEN 355 | ; 356 | 357 | : U.R ( u width -- ) 358 | SWAP ( width u ) 359 | DUP ( width u u ) 360 | UWIDTH ( width u uwidth ) 361 | -ROT ( u uwidth width ) 362 | SWAP - ( u width-uwidth ) 363 | ( At this point if the requested width is narrower, we'll have a negative number on the stack. 364 | Otherwise the number on the stack is the number of spaces to print. But SPACES won't print 365 | a negative number of spaces anyway, so it's now safe to call SPACES ... ) 366 | SPACES 367 | ( ... and then call the underlying implementation of U. ) 368 | U. 369 | ; 370 | 371 | ( 372 | .R prints a signed number, padded to a certain width. We can't just print the sign 373 | and call U.R because we want the sign to be next to the number ('-123' instead of '- 123'). 374 | ) 375 | : .R ( n width -- ) 376 | SWAP ( width n ) 377 | DUP 0< IF 378 | NEGATE ( width u ) 379 | 1 ( save a flag to remember that it was negative | width n 1 ) 380 | ROT ( 1 width u ) 381 | SWAP ( 1 u width ) 382 | 1- ( 1 u width-1 ) 383 | ELSE 384 | 0 ( width u 0 ) 385 | ROT ( 0 width u ) 386 | SWAP ( 0 u width ) 387 | THEN 388 | SWAP ( flag width u ) 389 | DUP ( flag width u u ) 390 | UWIDTH ( flag width u uwidth ) 391 | -ROT ( flag u uwidth width ) 392 | SWAP - ( flag u width-uwidth ) 393 | 394 | SPACES ( flag u ) 395 | SWAP ( u flag ) 396 | 397 | IF ( was it negative? print the - character ) 398 | '-' EMIT 399 | THEN 400 | 401 | U. 402 | ; 403 | 404 | ( Finally we can define word . in terms of .R, with a trailing space. ) 405 | : . 0 .R SPACE ; 406 | 407 | ( The real U., note the trailing space. ) 408 | : U. U. SPACE ; 409 | 410 | ( ? fetches the integer at an address and prints it. ) 411 | : ? ( addr -- ) @ . ; 412 | 413 | ( c a b WITHIN returns true if a <= c and c < b ) 414 | : WITHIN 415 | ROT ( b c a ) 416 | OVER ( b c a c ) 417 | <= IF 418 | > IF ( b c -- ) 419 | TRUE 420 | ELSE 421 | FALSE 422 | THEN 423 | ELSE 424 | 2DROP ( b c -- ) 425 | FALSE 426 | THEN 427 | ; 428 | 429 | ( DEPTH returns the depth of the stack. ) 430 | : DEPTH ( -- n ) 431 | S0 @ DSP@ - 432 | 4- ( adjust because S0 was on the stack when we pushed DSP ) 433 | ; 434 | 435 | ( 436 | ALIGNED takes an address and rounds it up (aligns it) to the next 4 byte boundary. 437 | ) 438 | : ALIGNED ( addr -- addr ) 439 | 3 + 3 INVERT AND ( (addr+3) & ~3 ) 440 | ; 441 | 442 | ( 443 | ALIGN aligns the HERE pointer, so the next word appended will be aligned properly. 444 | ) 445 | : ALIGN HERE @ ALIGNED HERE ! ; 446 | 447 | ( 448 | STRINGS ---------------------------------------------------------------------- 449 | 450 | S" string" is used in FORTH to define strings. It leaves the address of the string and 451 | its length on the stack, (length at the top of stack). The space following S" is the normal 452 | space between FORTH words and is not a part of the string. 453 | 454 | This is tricky to define because it has to do different things depending on whether 455 | we are compiling or in immediate mode. (Thus the word is marked IMMEDIATE so it can 456 | detect this and do different things). 457 | 458 | In compile mode we append 459 | LITSTRING 460 | to the current word. The primitive LITSTRING does the right thing when the current 461 | word is executed. 462 | 463 | In immediate mode there isn't a particularly good place to put the string, but in this 464 | case we put the string at HERE (but we _don't_ change HERE). This is meant as a temporary 465 | location, likely to be overwritten soon after. 466 | ) 467 | ( C, appends a byte to the current compiled word. ) 468 | : C, 469 | HERE @ C! ( store the character in the compiled image ) 470 | 1 HERE +! ( increment HERE pointer by 1 byte ) 471 | ; 472 | 473 | : S" IMMEDIATE ( -- addr len ) 474 | STATE @ IF ( compiling? ) 475 | ' LITSTRING , ( compile LITSTRING ) 476 | HERE @ ( save the address of the length word on the stack ) 477 | 0 , ( dummy length - we don't know what it is yet ) 478 | BEGIN 479 | KEY ( get next character of the string ) 480 | DUP '"' <> 481 | WHILE 482 | C, ( copy character ) 483 | REPEAT 484 | DROP ( drop the double quote character at the end ) 485 | DUP ( get the saved address of the length word ) 486 | HERE @ SWAP - ( calculate the length ) 487 | 4- ( subtract 4 (because we measured from the start of the length word) ) 488 | SWAP ! ( and back-fill the length location ) 489 | ALIGN ( round up to next multiple of 4 bytes for the remaining code ) 490 | ELSE ( immediate mode ) 491 | HERE @ ( get the start address of the temporary space ) 492 | BEGIN 493 | KEY 494 | DUP '"' <> 495 | WHILE 496 | OVER C! ( save next character ) 497 | 1+ ( increment address ) 498 | REPEAT 499 | DROP ( drop the final " character ) 500 | HERE @ - ( calculate the length ) 501 | HERE @ ( push the start address ) 502 | SWAP ( addr len ) 503 | THEN 504 | ; 505 | 506 | ( 507 | ." is the print string operator in FORTH. Example: ." Something to print" 508 | The space after the operator is the ordinary space required between words and is not 509 | a part of what is printed. 510 | 511 | In immediate mode we just keep reading characters and printing them until we get to 512 | the next double quote. 513 | 514 | In compile mode we use S" to store the string, then add TELL afterwards: 515 | LITSTRING TELL 516 | 517 | It may be interesting to note the use of [COMPILE] to turn the call to the immediate 518 | word S" into compilation of that word. It compiles it into the definition of .", 519 | not into the definition of the word being compiled when this is running (complicated 520 | enough for you?) 521 | ) 522 | : ." IMMEDIATE ( -- ) 523 | STATE @ IF ( compiling? ) 524 | [COMPILE] S" ( read the string, and compile LITSTRING, etc. ) 525 | ' TELL , ( compile the final TELL ) 526 | ELSE 527 | ( In immediate mode, just read characters and print them until we get 528 | to the ending double quote. ) 529 | BEGIN 530 | KEY 531 | DUP '"' = IF 532 | DROP ( drop the double quote character ) 533 | EXIT ( return from this function ) 534 | THEN 535 | EMIT 536 | AGAIN 537 | THEN 538 | ; 539 | 540 | ( 541 | CONSTANTS AND VARIABLES ---------------------------------------------------------------------- 542 | 543 | In FORTH, global constants and variables are defined like this: 544 | 545 | 10 CONSTANT TEN when TEN is executed, it leaves the integer 10 on the stack 546 | VARIABLE VAR when VAR is executed, it leaves the address of VAR on the stack 547 | 548 | Constants can be read but not written, eg: 549 | 550 | TEN . CR prints 10 551 | 552 | You can read a variable (in this example called VAR) by doing: 553 | 554 | VAR @ leaves the value of VAR on the stack 555 | VAR @ . CR prints the value of VAR 556 | VAR ? CR same as above, since ? is the same as @ . 557 | 558 | and update the variable by doing: 559 | 560 | 20 VAR ! sets VAR to 20 561 | 562 | Note that variables are uninitialised (but see VALUE later on which provides initialised 563 | variables with a slightly simpler syntax). 564 | 565 | How can we define the words CONSTANT and VARIABLE? 566 | 567 | The trick is to define a new word for the variable itself (eg. if the variable was called 568 | 'VAR' then we would define a new word called VAR). This is easy to do because we exposed 569 | dictionary entry creation through the CREATE word (part of the definition of : above). 570 | A call to WORD [TEN] CREATE (where [TEN] means that "TEN" is the next word in the input) 571 | leaves the dictionary entry: 572 | 573 | +--- HERE 574 | | 575 | V 576 | +---------+---+---+---+---+ 577 | | LINK | 3 | T | E | N | 578 | +---------+---+---+---+---+ 579 | len 580 | 581 | For CONSTANT we can continue by appending DOCOL (the codeword), then LIT followed by 582 | the constant itself and then EXIT, forming a little word definition that returns the 583 | constant: 584 | 585 | +---------+---+---+---+---+------------+------------+------------+------------+ 586 | | LINK | 3 | T | E | N | DOCOL | LIT | 10 | EXIT | 587 | +---------+---+---+---+---+------------+------------+------------+------------+ 588 | len codeword 589 | 590 | Notice that this word definition is exactly the same as you would have got if you had 591 | written : TEN 10 ; 592 | 593 | Note for people reading the code below: DOCOL is a constant word which we defined in the 594 | assembler part which returns the value of the assembler symbol of the same name. 595 | ) 596 | : CONSTANT 597 | WORD ( get the name (the name follows CONSTANT) ) 598 | CREATE ( make the dictionary entry ) 599 | DOCOL , ( append DOCOL (the codeword field of this word) ) 600 | ' LIT , ( append the codeword LIT ) 601 | , ( append the value on the top of the stack ) 602 | ' EXIT , ( append the codeword EXIT ) 603 | ; 604 | 605 | ( 606 | VARIABLE is a little bit harder because we need somewhere to put the variable. There is 607 | nothing particularly special about the user memory (the area of memory pointed to by HERE 608 | where we have previously just stored new word definitions). We can slice off bits of this 609 | memory area to store anything we want, so one possible definition of VARIABLE might create 610 | this: 611 | 612 | +--------------------------------------------------------------+ 613 | | | 614 | V | 615 | +---------+---------+---+---+---+---+------------+------------+---|--------+------------+ 616 | | | LINK | 3 | V | A | R | DOCOL | LIT | | EXIT | 617 | +---------+---------+---+---+---+---+------------+------------+------------+------------+ 618 | len codeword 619 | 620 | where is the place to store the variable, and points back to it. 621 | 622 | To make this more general let's define a couple of words which we can use to allocate 623 | arbitrary memory from the user memory. 624 | 625 | First ALLOT, where n ALLOT allocates n bytes of memory. (Note when calling this that 626 | it's a very good idea to make sure that n is a multiple of 4, or at least that next time 627 | a word is compiled that HERE has been left as a multiple of 4). 628 | ) 629 | : ALLOT ( n -- addr ) 630 | HERE @ SWAP ( here n ) 631 | HERE +! ( adds n to HERE, after this the old value of HERE is still on the stack ) 632 | ; 633 | 634 | ( 635 | Second, CELLS. In FORTH the phrase 'n CELLS ALLOT' means allocate n integers of whatever size 636 | is the natural size for integers on this machine architecture. On this 32 bit machine therefore 637 | CELLS just multiplies the top of stack by 4. 638 | ) 639 | : CELLS ( n -- n ) 4 * ; 640 | 641 | ( 642 | So now we can define VARIABLE easily in much the same way as CONSTANT above. Refer to the 643 | diagram above to see what the word that this creates will look like. 644 | ) 645 | : VARIABLE 646 | 1 CELLS ALLOT ( allocate 1 cell of memory, push the pointer to this memory ) 647 | WORD CREATE ( make the dictionary entry (the name follows VARIABLE) ) 648 | DOCOL , ( append DOCOL (the codeword field of this word) ) 649 | ' LIT , ( append the codeword LIT ) 650 | , ( append the pointer to the new memory ) 651 | ' EXIT , ( append the codeword EXIT ) 652 | ; 653 | 654 | ( 655 | VALUES ---------------------------------------------------------------------- 656 | 657 | VALUEs are like VARIABLEs but with a simpler syntax. You would generally use them when you 658 | want a variable which is read often, and written infrequently. 659 | 660 | 20 VALUE VAL creates VAL with initial value 20 661 | VAL pushes the value directly on the stack 662 | 30 TO VAL updates VAL, setting it to 30 663 | 664 | Notice that 'VAL' on its own doesn't return the address of the value, but the value itself, 665 | making values simpler and more obvious to use than variables (no indirection through '@'). 666 | The price is a more complicated implementation, although despite the complexity there is no 667 | performance penalty at runtime. 668 | 669 | A naive implementation of 'TO' would be quite slow, involving a dictionary search each time. 670 | But because this is FORTH we have complete control of the compiler so we can compile TO more 671 | efficiently, turning: 672 | TO VAL 673 | into: 674 | LIT ! 675 | and calculating (the address of the value) at compile time. 676 | 677 | Now this is the clever bit. We'll compile our value like this: 678 | 679 | +---------+---+---+---+---+------------+------------+------------+------------+ 680 | | LINK | 3 | V | A | L | DOCOL | LIT | | EXIT | 681 | +---------+---+---+---+---+------------+------------+------------+------------+ 682 | len codeword 683 | 684 | where is the actual value itself. Note that when VAL executes, it will push the 685 | value on the stack, which is what we want. 686 | 687 | But what will TO use for the address ? Why of course a pointer to that : 688 | 689 | code compiled - - - - --+------------+------------+------------+-- - - - - 690 | by TO VAL | LIT | | ! | 691 | - - - - --+------------+-----|------+------------+-- - - - - 692 | | 693 | V 694 | +---------+---+---+---+---+------------+------------+------------+------------+ 695 | | LINK | 3 | V | A | L | DOCOL | LIT | | EXIT | 696 | +---------+---+---+---+---+------------+------------+------------+------------+ 697 | len codeword 698 | 699 | In other words, this is a kind of self-modifying code. 700 | 701 | (Note to the people who want to modify this FORTH to add inlining: values defined this 702 | way cannot be inlined). 703 | ) 704 | : VALUE ( n -- ) 705 | WORD CREATE ( make the dictionary entry (the name follows VALUE) ) 706 | DOCOL , ( append DOCOL ) 707 | ' LIT , ( append the codeword LIT ) 708 | , ( append the initial value ) 709 | ' EXIT , ( append the codeword EXIT ) 710 | ; 711 | 712 | : TO IMMEDIATE ( n -- ) 713 | WORD ( get the name of the value ) 714 | FIND ( look it up in the dictionary ) 715 | >DFA ( get a pointer to the first data field (the 'LIT') ) 716 | 4+ ( increment to point at the value ) 717 | STATE @ IF ( compiling? ) 718 | ' LIT , ( compile LIT ) 719 | , ( compile the address of the value ) 720 | ' ! , ( compile ! ) 721 | ELSE ( immediate mode ) 722 | ! ( update it straightaway ) 723 | THEN 724 | ; 725 | 726 | ( x +TO VAL adds x to VAL ) 727 | : +TO IMMEDIATE 728 | WORD ( get the name of the value ) 729 | FIND ( look it up in the dictionary ) 730 | >DFA ( get a pointer to the first data field (the 'LIT') ) 731 | 4+ ( increment to point at the value ) 732 | STATE @ IF ( compiling? ) 733 | ' LIT , ( compile LIT ) 734 | , ( compile the address of the value ) 735 | ' +! , ( compile +! ) 736 | ELSE ( immediate mode ) 737 | +! ( update it straightaway ) 738 | THEN 739 | ; 740 | 741 | ( 742 | PRINTING THE DICTIONARY ---------------------------------------------------------------------- 743 | 744 | ID. takes an address of a dictionary entry and prints the word's name. 745 | 746 | For example: LATEST @ ID. would print the name of the last word that was defined. 747 | ) 748 | : ID. 749 | 4+ ( skip over the link pointer ) 750 | DUP C@ ( get the flags/length byte ) 751 | F_LENMASK AND ( mask out the flags - just want the length ) 752 | 753 | BEGIN 754 | DUP 0> ( length > 0? ) 755 | WHILE 756 | SWAP 1+ ( addr len -- len addr+1 ) 757 | DUP C@ ( len addr -- len addr char | get the next character) 758 | EMIT ( len addr char -- len addr | and print it) 759 | SWAP 1- ( len addr -- addr len-1 | subtract one from length ) 760 | REPEAT 761 | 2DROP ( len addr -- ) 762 | ; 763 | 764 | ( 765 | 'WORD word FIND ?HIDDEN' returns true if 'word' is flagged as hidden. 766 | 767 | 'WORD word FIND ?IMMEDIATE' returns true if 'word' is flagged as immediate. 768 | ) 769 | : ?HIDDEN 770 | 4+ ( skip over the link pointer ) 771 | C@ ( get the flags/length byte ) 772 | F_HIDDEN AND ( mask the F_HIDDEN flag and return it (as a truth value) ) 773 | ; 774 | : ?IMMEDIATE 775 | 4+ ( skip over the link pointer ) 776 | C@ ( get the flags/length byte ) 777 | F_IMMED AND ( mask the F_IMMED flag and return it (as a truth value) ) 778 | ; 779 | 780 | ( 781 | WORDS prints all the words defined in the dictionary, starting with the word defined most recently. 782 | However it doesn't print hidden words. 783 | 784 | The implementation simply iterates backwards from LATEST using the link pointers. 785 | ) 786 | : WORDS 787 | LATEST @ ( start at LATEST dictionary entry ) 788 | BEGIN 789 | ?DUP ( while link pointer is not null ) 790 | WHILE 791 | DUP ?HIDDEN NOT IF ( ignore hidden words ) 792 | DUP ID. ( but if not hidden, print the word ) 793 | SPACE 794 | THEN 795 | @ ( dereference the link pointer - go to previous word ) 796 | REPEAT 797 | CR 798 | ; 799 | 800 | ( 801 | FORGET ---------------------------------------------------------------------- 802 | 803 | So far we have only allocated words and memory. FORTH provides a rather primitive method 804 | to deallocate. 805 | 806 | 'FORGET word' deletes the definition of 'word' from the dictionary and everything defined 807 | after it, including any variables and other memory allocated after. 808 | 809 | The implementation is very simple - we look up the word (which returns the dictionary entry 810 | address). Then we set HERE to point to that address, so in effect all future allocations 811 | and definitions will overwrite memory starting at the word. We also need to set LATEST to 812 | point to the previous word. 813 | 814 | Note that you cannot FORGET built-in words (well, you can try but it will probably cause 815 | a segfault). 816 | 817 | XXX: Because we wrote VARIABLE to store the variable in memory allocated before the word, 818 | in the current implementation VARIABLE FOO FORGET FOO will leak 1 cell of memory. 819 | ) 820 | : FORGET 821 | WORD FIND ( find the word, gets the dictionary entry address ) 822 | DUP @ LATEST ! ( set LATEST to point to the previous word ) 823 | HERE ! ( and store HERE with the dictionary address ) 824 | ; 825 | 826 | ( 827 | DUMP ---------------------------------------------------------------------- 828 | 829 | DUMP is used to dump out the contents of memory, in the 'traditional' hexdump format. 830 | 831 | Notice that the parameters to DUMP (address, length) are compatible with string words 832 | such as WORD and S". 833 | ) 834 | : DUMP ( addr len -- ) 835 | BASE @ ROT ( save the current BASE at the bottom of the stack ) 836 | HEX ( and switch the hexadecimal mode ) 837 | 838 | BEGIN 839 | DUP 0> ( while len > 0 ) 840 | WHILE 841 | OVER 8 U.R ( print the address ) 842 | SPACE 843 | 844 | ( print up to 16 words on this line ) 845 | 2DUP ( addr len addr len ) 846 | 1- 15 AND 1+ ( addr len addr linelen ) 847 | BEGIN 848 | DUP 0> ( while linelen > 0 ) 849 | WHILE 850 | SWAP ( addr len linelen addr ) 851 | DUP C@ ( addr len linelen addr byte ) 852 | 2 .R SPACE ( print the byte ) 853 | 1+ SWAP 1- ( addr len linelen addr -- addr len addr+1 linelen-1 ) 854 | REPEAT 855 | 2DROP ( addr len ) 856 | 857 | ( print the ASCII equivalents ) 858 | 2DUP 1- 15 AND 1+ ( addr len addr linelen ) 859 | BEGIN 860 | DUP 0> ( while linelen > 0) 861 | WHILE 862 | SWAP ( addr len linelen addr ) 863 | DUP C@ ( addr len linelen addr byte ) 864 | DUP 32 128 WITHIN IF ( 32 <= c < 128? ) 865 | EMIT 866 | ELSE 867 | DROP '.' EMIT 868 | THEN 869 | 1+ SWAP 1- ( addr len linelen addr -- addr len addr+1 linelen-1 ) 870 | REPEAT 871 | 2DROP ( addr len ) 872 | CR 873 | 874 | DUP 1- 15 AND 1+ ( addr len linelen ) 875 | DUP ( addr len linelen linelen ) 876 | ROT ( addr linelen len linelen ) 877 | - ( addr linelen len-linelen ) 878 | ROT ( len-linelen addr linelen ) 879 | + ( len-linelen addr+linelen ) 880 | SWAP ( addr-linelen len-linelen ) 881 | REPEAT 882 | 883 | 2DROP ( restore stack ) 884 | BASE ! ( restore saved BASE ) 885 | ; 886 | 887 | ( 888 | CASE ---------------------------------------------------------------------- 889 | 890 | CASE...ENDCASE is how we do switch statements in FORTH. There is no generally 891 | agreed syntax for this, so I've gone for the syntax mandated by the ISO standard 892 | FORTH (ANS-FORTH). 893 | 894 | ( some value on the stack ) 895 | CASE 896 | test1 OF ... ENDOF 897 | test2 OF ... ENDOF 898 | testn OF ... ENDOF 899 | ... ( default case ) 900 | ENDCASE 901 | 902 | The CASE statement tests the value on the stack by comparing it for equality with 903 | test1, test2, ..., testn and executes the matching piece of code within OF ... ENDOF. 904 | If none of the test values match then the default case is executed. Inside the ... of 905 | the default case, the value is still at the top of stack (it is implicitly DROP-ed 906 | by ENDCASE). When ENDOF is executed it jumps after ENDCASE (ie. there is no "fall-through" 907 | and no need for a break statement like in C). 908 | 909 | The default case may be omitted. In fact the tests may also be omitted so that you 910 | just have a default case, although this is probably not very useful. 911 | 912 | An example (assuming that 'q', etc. are words which push the ASCII value of the letter 913 | on the stack): 914 | 915 | 0 VALUE QUIT 916 | 0 VALUE SLEEP 917 | KEY CASE 918 | 'q' OF 1 TO QUIT ENDOF 919 | 's' OF 1 TO SLEEP ENDOF 920 | ( default case: ) 921 | ." Sorry, I didn't understand key <" DUP EMIT ." >, try again." CR 922 | ENDCASE 923 | 924 | (In some versions of FORTH, more advanced tests are supported, such as ranges, etc. 925 | Other versions of FORTH need you to write OTHERWISE to indicate the default case. 926 | As I said above, this FORTH tries to follow the ANS FORTH standard). 927 | 928 | The implementation of CASE...ENDCASE is somewhat non-trivial. I'm following the 929 | implementations from here: 930 | http://www.uni-giessen.de/faq/archiv/forthfaq.case_endcase/msg00000.html 931 | 932 | The general plan is to compile the code as a series of IF statements: 933 | 934 | CASE (push 0 on the immediate-mode parameter stack) 935 | test1 OF ... ENDOF test1 OVER = IF DROP ... ELSE 936 | test2 OF ... ENDOF test2 OVER = IF DROP ... ELSE 937 | testn OF ... ENDOF testn OVER = IF DROP ... ELSE 938 | ... ( default case ) ... 939 | ENDCASE DROP THEN [THEN [THEN ...]] 940 | 941 | The CASE statement pushes 0 on the immediate-mode parameter stack, and that number 942 | is used to count how many THEN statements we need when we get to ENDCASE so that each 943 | IF has a matching THEN. The counting is done implicitly. If you recall from the 944 | implementation above of IF, each IF pushes a code address on the immediate-mode stack, 945 | and these addresses are non-zero, so by the time we get to ENDCASE the stack contains 946 | some number of non-zeroes, followed by a zero. The number of non-zeroes is how many 947 | times IF has been called, so how many times we need to match it with THEN. 948 | 949 | This code uses [COMPILE] so that we compile calls to IF, ELSE, THEN instead of 950 | actually calling them while we're compiling the words below. 951 | 952 | As is the case with all of our control structures, they only work within word 953 | definitions, not in immediate mode. 954 | ) 955 | : CASE IMMEDIATE 956 | 0 ( push 0 to mark the bottom of the stack ) 957 | ; 958 | 959 | : OF IMMEDIATE 960 | ' OVER , ( compile OVER ) 961 | ' = , ( compile = ) 962 | [COMPILE] IF ( compile IF ) 963 | ' DROP , ( compile DROP ) 964 | ; 965 | 966 | : ENDOF IMMEDIATE 967 | [COMPILE] ELSE ( ENDOF is the same as ELSE ) 968 | ; 969 | 970 | : ENDCASE IMMEDIATE 971 | ' DROP , ( compile DROP ) 972 | 973 | ( keep compiling THEN until we get to our zero marker ) 974 | BEGIN 975 | ?DUP 976 | WHILE 977 | [COMPILE] THEN 978 | REPEAT 979 | ; 980 | 981 | ( 982 | DECOMPILER ---------------------------------------------------------------------- 983 | 984 | CFA> is the opposite of >CFA. It takes a codeword and tries to find the matching 985 | dictionary definition. (In truth, it works with any pointer into a word, not just 986 | the codeword pointer, and this is needed to do stack traces). 987 | 988 | In this FORTH this is not so easy. In fact we have to search through the dictionary 989 | because we don't have a convenient back-pointer (as is often the case in other versions 990 | of FORTH). Because of this search, CFA> should not be used when performance is critical, 991 | so it is only used for debugging tools such as the decompiler and printing stack 992 | traces. 993 | 994 | This word returns 0 if it doesn't find a match. 995 | ) 996 | : CFA> 997 | LATEST @ ( start at LATEST dictionary entry ) 998 | BEGIN 999 | ?DUP ( while link pointer is not null ) 1000 | WHILE 1001 | 2DUP SWAP ( cfa curr curr cfa ) 1002 | < IF ( current dictionary entry < cfa? ) 1003 | NIP ( leave curr dictionary entry on the stack ) 1004 | EXIT 1005 | THEN 1006 | @ ( follow link pointer back ) 1007 | REPEAT 1008 | DROP ( restore stack ) 1009 | 0 ( sorry, nothing found ) 1010 | ; 1011 | 1012 | ( 1013 | SEE decompiles a FORTH word. 1014 | 1015 | We search for the dictionary entry of the word, then search again for the next 1016 | word (effectively, the end of the compiled word). This results in two pointers: 1017 | 1018 | +---------+---+---+---+---+------------+------------+------------+------------+ 1019 | | LINK | 3 | T | E | N | DOCOL | LIT | 10 | EXIT | 1020 | +---------+---+---+---+---+------------+------------+------------+------------+ 1021 | ^ ^ 1022 | | | 1023 | Start of word End of word 1024 | 1025 | With this information we can have a go at decompiling the word. We need to 1026 | recognise "meta-words" like LIT, LITSTRING, BRANCH, etc. and treat those separately. 1027 | ) 1028 | : SEE 1029 | WORD FIND ( find the dictionary entry to decompile ) 1030 | 1031 | ( Now we search again, looking for the next word in the dictionary. This gives us 1032 | the length of the word that we will be decompiling. (Well, mostly it does). ) 1033 | HERE @ ( address of the end of the last compiled word ) 1034 | LATEST @ ( word last curr ) 1035 | BEGIN 1036 | 2 PICK ( word last curr word ) 1037 | OVER ( word last curr word curr ) 1038 | <> ( word last curr word<>curr? ) 1039 | WHILE ( word last curr ) 1040 | NIP ( word curr ) 1041 | DUP @ ( word curr prev (which becomes: word last curr) ) 1042 | REPEAT 1043 | 1044 | DROP ( at this point, the stack is: start-of-word end-of-word ) 1045 | SWAP ( end-of-word start-of-word ) 1046 | 1047 | ( begin the definition with : NAME [IMMEDIATE] ) 1048 | ':' EMIT SPACE DUP ID. SPACE 1049 | DUP ?IMMEDIATE IF ." IMMEDIATE " THEN 1050 | 1051 | >DFA ( get the data address, ie. points after DOCOL | end-of-word start-of-data ) 1052 | 1053 | ( now we start decompiling until we hit the end of the word ) 1054 | BEGIN ( end start ) 1055 | 2DUP > 1056 | WHILE 1057 | DUP @ ( end start codeword ) 1058 | 1059 | CASE 1060 | ' LIT OF ( is it LIT ? ) 1061 | 4 + DUP @ ( get next word which is the integer constant ) 1062 | . ( and print it ) 1063 | ENDOF 1064 | ' LITSTRING OF ( is it LITSTRING ? ) 1065 | [ CHAR S ] LITERAL EMIT '"' EMIT SPACE ( print S" ) 1066 | 4 + DUP @ ( get the length word ) 1067 | SWAP 4 + SWAP ( end start+4 length ) 1068 | 2DUP TELL ( print the string ) 1069 | '"' EMIT SPACE ( finish the string with a final quote ) 1070 | + ALIGNED ( end start+4+len, aligned ) 1071 | 4 - ( because we're about to add 4 below ) 1072 | ENDOF 1073 | ' 0BRANCH OF ( is it 0BRANCH ? ) 1074 | ." 0BRANCH ( " 1075 | 4 + DUP @ ( print the offset ) 1076 | . 1077 | ." ) " 1078 | ENDOF 1079 | ' BRANCH OF ( is it BRANCH ? ) 1080 | ." BRANCH ( " 1081 | 4 + DUP @ ( print the offset ) 1082 | . 1083 | ." ) " 1084 | ENDOF 1085 | ' ' OF ( is it ' (TICK) ? ) 1086 | [ CHAR ' ] LITERAL EMIT SPACE 1087 | 4 + DUP @ ( get the next codeword ) 1088 | CFA> ( and force it to be printed as a dictionary entry ) 1089 | ID. SPACE 1090 | ENDOF 1091 | ' EXIT OF ( is it EXIT? ) 1092 | ( We expect the last word to be EXIT, and if it is then we don't print it 1093 | because EXIT is normally implied by ;. EXIT can also appear in the middle 1094 | of words, and then it needs to be printed. ) 1095 | 2DUP ( end start end start ) 1096 | 4 + ( end start end start+4 ) 1097 | <> IF ( end start | we're not at the end ) 1098 | ." EXIT " 1099 | THEN 1100 | ENDOF 1101 | ( default case: ) 1102 | DUP ( in the default case we always need to DUP before using ) 1103 | CFA> ( look up the codeword to get the dictionary entry ) 1104 | ID. SPACE ( and print it ) 1105 | ENDCASE 1106 | 1107 | 4 + ( end start+4 ) 1108 | REPEAT 1109 | 1110 | ';' EMIT CR 1111 | 1112 | 2DROP ( restore stack ) 1113 | ; 1114 | 1115 | ( 1116 | EXECUTION TOKENS ---------------------------------------------------------------------- 1117 | 1118 | Standard FORTH defines a concept called an 'execution token' (or 'xt') which is very 1119 | similar to a function pointer in C. We map the execution token to a codeword address. 1120 | 1121 | execution token of DOUBLE is the address of this codeword 1122 | | 1123 | V 1124 | +---------+---+---+---+---+---+---+---+---+------------+------------+------------+------------+ 1125 | | LINK | 6 | D | O | U | B | L | E | 0 | DOCOL | DUP | + | EXIT | 1126 | +---------+---+---+---+---+---+---+---+---+------------+------------+------------+------------+ 1127 | len pad codeword ^ 1128 | 1129 | There is one assembler primitive for execution tokens, EXECUTE ( xt -- ), which runs them. 1130 | 1131 | You can make an execution token for an existing word the long way using >CFA, 1132 | ie: WORD [foo] FIND >CFA will push the xt for foo onto the stack where foo is the 1133 | next word in input. So a very slow way to run DOUBLE might be: 1134 | 1135 | : DOUBLE DUP + ; 1136 | : SLOW WORD FIND >CFA EXECUTE ; 1137 | 5 SLOW DOUBLE . CR \ prints 10 1138 | 1139 | We also offer a simpler and faster way to get the execution token of any word FOO: 1140 | 1141 | ['] FOO 1142 | 1143 | (Exercises for readers: (1) What is the difference between ['] FOO and ' FOO? 1144 | (2) What is the relationship between ', ['] and LIT?) 1145 | 1146 | More useful is to define anonymous words and/or to assign xt's to variables. 1147 | 1148 | To define an anonymous word (and push its xt on the stack) use :NONAME ... ; as in this 1149 | example: 1150 | 1151 | :NONAME ." anon word was called" CR ; \ pushes xt on the stack 1152 | DUP EXECUTE EXECUTE \ executes the anon word twice 1153 | 1154 | Stack parameters work as expected: 1155 | 1156 | :NONAME ." called with parameter " . CR ; 1157 | DUP 1158 | 10 SWAP EXECUTE \ prints 'called with parameter 10' 1159 | 20 SWAP EXECUTE \ prints 'called with parameter 20' 1160 | 1161 | Notice that the above code has a memory leak: the anonymous word is still compiled 1162 | into the data segment, so even if you lose track of the xt, the word continues to 1163 | occupy memory. A good way to keep track of the xt and thus avoid the memory leak is 1164 | to assign it to a CONSTANT, VARIABLE or VALUE: 1165 | 1166 | 0 VALUE ANON 1167 | :NONAME ." anon word was called" CR ; TO ANON 1168 | ANON EXECUTE 1169 | ANON EXECUTE 1170 | 1171 | Another use of :NONAME is to create an array of functions which can be called quickly 1172 | (think: fast switch statement). This example is adapted from the ANS FORTH standard: 1173 | 1174 | 10 CELLS ALLOT CONSTANT CMD-TABLE 1175 | : SET-CMD CELLS CMD-TABLE + ! ; 1176 | : CALL-CMD CELLS CMD-TABLE + @ EXECUTE ; 1177 | 1178 | :NONAME ." alternate 0 was called" CR ; 0 SET-CMD 1179 | :NONAME ." alternate 1 was called" CR ; 1 SET-CMD 1180 | \ etc... 1181 | :NONAME ." alternate 9 was called" CR ; 9 SET-CMD 1182 | 1183 | 0 CALL-CMD 1184 | 1 CALL-CMD 1185 | ) 1186 | 1187 | : :NONAME 1188 | 0 0 CREATE ( create a word with no name - we need a dictionary header because ; expects it ) 1189 | HERE @ ( current HERE value is the address of the codeword, ie. the xt ) 1190 | DOCOL , ( compile DOCOL (the codeword) ) 1191 | ] ( go into compile mode ) 1192 | ; 1193 | 1194 | : ['] IMMEDIATE 1195 | ' LIT , ( compile LIT ) 1196 | ; 1197 | 1198 | ( 1199 | EXCEPTIONS ---------------------------------------------------------------------- 1200 | 1201 | Amazingly enough, exceptions can be implemented directly in FORTH, in fact rather easily. 1202 | 1203 | The general usage is as follows: 1204 | 1205 | : FOO ( n -- ) THROW ; 1206 | 1207 | : TEST-EXCEPTIONS 1208 | 25 ['] FOO CATCH \ execute 25 FOO, catching any exception 1209 | ?DUP IF 1210 | ." called FOO and it threw exception number: " 1211 | . CR 1212 | DROP \ we have to drop the argument of FOO (25) 1213 | THEN 1214 | ; 1215 | \ prints: called FOO and it threw exception number: 25 1216 | 1217 | CATCH runs an execution token and detects whether it throws any exception or not. The 1218 | stack signature of CATCH is rather complicated: 1219 | 1220 | ( a_n-1 ... a_1 a_0 xt -- r_m-1 ... r_1 r_0 0 ) if xt did NOT throw an exception 1221 | ( a_n-1 ... a_1 a_0 xt -- ?_n-1 ... ?_1 ?_0 e ) if xt DID throw exception 'e' 1222 | 1223 | where a_i and r_i are the (arbitrary number of) argument and return stack contents 1224 | before and after xt is EXECUTEd. Notice in particular the case where an exception 1225 | is thrown, the stack pointer is restored so that there are n of _something_ on the 1226 | stack in the positions where the arguments a_i used to be. We don't really guarantee 1227 | what is on the stack -- perhaps the original arguments, and perhaps other nonsense -- 1228 | it largely depends on the implementation of the word that was executed. 1229 | 1230 | THROW, ABORT and a few others throw exceptions. 1231 | 1232 | Exception numbers are non-zero integers. By convention the positive numbers can be used 1233 | for app-specific exceptions and the negative numbers have certain meanings defined in 1234 | the ANS FORTH standard. (For example, -1 is the exception thrown by ABORT). 1235 | 1236 | 0 THROW does nothing. This is the stack signature of THROW: 1237 | 1238 | ( 0 -- ) 1239 | ( * e -- ?_n-1 ... ?_1 ?_0 e ) the stack is restored to the state from the corresponding CATCH 1240 | 1241 | The implementation hangs on the definitions of CATCH and THROW and the state shared 1242 | between them. 1243 | 1244 | Up to this point, the return stack has consisted merely of a list of return addresses, 1245 | with the top of the return stack being the return address where we will resume executing 1246 | when the current word EXITs. However CATCH will push a more complicated 'exception stack 1247 | frame' on the return stack. The exception stack frame records some things about the 1248 | state of execution at the time that CATCH was called. 1249 | 1250 | When called, THROW walks up the return stack (the process is called 'unwinding') until 1251 | it finds the exception stack frame. It then uses the data in the exception stack frame 1252 | to restore the state allowing execution to continue after the matching CATCH. (If it 1253 | unwinds the stack and doesn't find the exception stack frame then it prints a message 1254 | and drops back to the prompt, which is also normal behaviour for so-called 'uncaught 1255 | exceptions'). 1256 | 1257 | This is what the exception stack frame looks like. (As is conventional, the return stack 1258 | is shown growing downwards from higher to lower memory addresses). 1259 | 1260 | +------------------------------+ 1261 | | return address from CATCH | Notice this is already on the 1262 | | | return stack when CATCH is called. 1263 | +------------------------------+ 1264 | | original parameter stack | 1265 | | pointer | 1266 | +------------------------------+ ^ 1267 | | exception stack marker | | 1268 | | (EXCEPTION-MARKER) | | Direction of stack 1269 | +------------------------------+ | unwinding by THROW. 1270 | | 1271 | | 1272 | 1273 | The EXCEPTION-MARKER marks the entry as being an exception stack frame rather than an 1274 | ordinary return address, and it is this which THROW "notices" as it is unwinding the 1275 | stack. (If you want to implement more advanced exceptions such as TRY...WITH then 1276 | you'll need to use a different value of marker if you want the old and new exception stack 1277 | frame layouts to coexist). 1278 | 1279 | What happens if the executed word doesn't throw an exception? It will eventually 1280 | return and call EXCEPTION-MARKER, so EXCEPTION-MARKER had better do something sensible 1281 | without us needing to modify EXIT. This nicely gives us a suitable definition of 1282 | EXCEPTION-MARKER, namely a function that just drops the stack frame and itself 1283 | returns (thus "returning" from the original CATCH). 1284 | 1285 | One thing to take from this is that exceptions are a relatively lightweight mechanism 1286 | in FORTH. 1287 | ) 1288 | 1289 | : EXCEPTION-MARKER 1290 | RDROP ( drop the original parameter stack pointer ) 1291 | 0 ( there was no exception, this is the normal return path ) 1292 | ; 1293 | 1294 | : CATCH ( xt -- exn? ) 1295 | DSP@ 4+ >R ( save parameter stack pointer (+4 because of xt) on the return stack ) 1296 | ' EXCEPTION-MARKER 4+ ( push the address of the RDROP inside EXCEPTION-MARKER ... ) 1297 | >R ( ... on to the return stack so it acts like a return address ) 1298 | EXECUTE ( execute the nested function ) 1299 | ; 1300 | 1301 | : THROW ( n -- ) 1302 | ?DUP IF ( only act if the exception code <> 0 ) 1303 | RSP@ ( get return stack pointer ) 1304 | BEGIN 1305 | DUP R0 4- < ( RSP < R0 ) 1306 | WHILE 1307 | DUP @ ( get the return stack entry ) 1308 | ' EXCEPTION-MARKER 4+ = IF ( found the EXCEPTION-MARKER on the return stack ) 1309 | 4+ ( skip the EXCEPTION-MARKER on the return stack ) 1310 | RSP! ( restore the return stack pointer ) 1311 | 1312 | ( Restore the parameter stack. ) 1313 | DUP DUP DUP ( reserve some working space so the stack for this word 1314 | doesn't coincide with the part of the stack being restored ) 1315 | R> ( get the saved parameter stack pointer | n dsp ) 1316 | 4- ( reserve space on the stack to store n ) 1317 | SWAP OVER ( dsp n dsp ) 1318 | ! ( write n on the stack ) 1319 | DSP! EXIT ( restore the parameter stack pointer, immediately exit ) 1320 | THEN 1321 | 4+ 1322 | REPEAT 1323 | 1324 | ( No matching catch - print a message and restart the INTERPRETer. ) 1325 | DROP 1326 | 1327 | CASE 1328 | 0 1- OF ( ABORT ) 1329 | ." ABORTED" CR 1330 | ENDOF 1331 | ( default case ) 1332 | ." UNCAUGHT THROW " 1333 | DUP . CR 1334 | ENDCASE 1335 | QUIT 1336 | THEN 1337 | ; 1338 | 1339 | : ABORT ( -- ) 1340 | 0 1- THROW 1341 | ; 1342 | 1343 | ( Print a stack trace by walking up the return stack. ) 1344 | : PRINT-STACK-TRACE 1345 | RSP@ ( start at caller of this function ) 1346 | BEGIN 1347 | DUP R0 4- < ( RSP < R0 ) 1348 | WHILE 1349 | DUP @ ( get the return stack entry ) 1350 | CASE 1351 | ' EXCEPTION-MARKER 4+ OF ( is it the exception stack frame? ) 1352 | ." CATCH ( DSP=" 1353 | 4+ DUP @ U. ( print saved stack pointer ) 1354 | ." ) " 1355 | ENDOF 1356 | ( default case ) 1357 | DUP 1358 | CFA> ( look up the codeword to get the dictionary entry ) 1359 | ?DUP IF ( and print it ) 1360 | 2DUP ( dea addr dea ) 1361 | ID. ( print word from dictionary entry ) 1362 | [ CHAR + ] LITERAL EMIT 1363 | SWAP >DFA 4+ - . ( print offset ) 1364 | THEN 1365 | ENDCASE 1366 | 4+ ( move up the stack ) 1367 | REPEAT 1368 | DROP 1369 | CR 1370 | ; 1371 | 1372 | ( 1373 | C STRINGS ---------------------------------------------------------------------- 1374 | 1375 | FORTH strings are represented by a start address and length kept on the stack or in memory. 1376 | 1377 | Most FORTHs don't handle C strings, but we need them in order to access the process arguments 1378 | and environment left on the stack by the Linux kernel, and to make some system calls. 1379 | 1380 | Operation Input Output FORTH word Notes 1381 | ---------------------------------------------------------------------- 1382 | 1383 | Create FORTH string addr len S" ..." 1384 | 1385 | Create C string c-addr Z" ..." 1386 | 1387 | C -> FORTH c-addr addr len DUP STRLEN 1388 | 1389 | FORTH -> C addr len c-addr CSTRING Allocated in a temporary buffer, so 1390 | should be consumed / copied immediately. 1391 | FORTH string should not contain NULs. 1392 | 1393 | For example, DUP STRLEN TELL prints a C string. 1394 | ) 1395 | 1396 | ( 1397 | Z" .." is like S" ..." except that the string is terminated by an ASCII NUL character. 1398 | 1399 | To make it more like a C string, at runtime Z" just leaves the address of the string 1400 | on the stack (not address & length as with S"). To implement this we need to add the 1401 | extra NUL to the string and also a DROP instruction afterwards. Apart from that the 1402 | implementation just a modified S". 1403 | ) 1404 | : Z" IMMEDIATE 1405 | STATE @ IF ( compiling? ) 1406 | ' LITSTRING , ( compile LITSTRING ) 1407 | HERE @ ( save the address of the length word on the stack ) 1408 | 0 , ( dummy length - we don't know what it is yet ) 1409 | BEGIN 1410 | KEY ( get next character of the string ) 1411 | DUP '"' <> 1412 | WHILE 1413 | HERE @ C! ( store the character in the compiled image ) 1414 | 1 HERE +! ( increment HERE pointer by 1 byte ) 1415 | REPEAT 1416 | 0 HERE @ C! ( add the ASCII NUL byte ) 1417 | 1 HERE +! 1418 | DROP ( drop the double quote character at the end ) 1419 | DUP ( get the saved address of the length word ) 1420 | HERE @ SWAP - ( calculate the length ) 1421 | 4- ( subtract 4 (because we measured from the start of the length word) ) 1422 | SWAP ! ( and back-fill the length location ) 1423 | ALIGN ( round up to next multiple of 4 bytes for the remaining code ) 1424 | ' DROP , ( compile DROP (to drop the length) ) 1425 | ELSE ( immediate mode ) 1426 | HERE @ ( get the start address of the temporary space ) 1427 | BEGIN 1428 | KEY 1429 | DUP '"' <> 1430 | WHILE 1431 | OVER C! ( save next character ) 1432 | 1+ ( increment address ) 1433 | REPEAT 1434 | DROP ( drop the final " character ) 1435 | 0 SWAP C! ( store final ASCII NUL ) 1436 | HERE @ ( push the start address ) 1437 | THEN 1438 | ; 1439 | 1440 | : STRLEN ( str -- len ) 1441 | DUP ( save start address ) 1442 | BEGIN 1443 | DUP C@ 0<> ( zero byte found? ) 1444 | WHILE 1445 | 1+ 1446 | REPEAT 1447 | 1448 | SWAP - ( calculate the length ) 1449 | ; 1450 | 1451 | : CSTRING ( addr len -- c-addr ) 1452 | SWAP OVER ( len saddr len ) 1453 | HERE @ SWAP ( len saddr daddr len ) 1454 | CMOVE ( len ) 1455 | 1456 | HERE @ + ( daddr+len ) 1457 | 0 SWAP C! ( store terminating NUL char ) 1458 | 1459 | HERE @ ( push start address ) 1460 | ; 1461 | 1462 | ( 1463 | THE ENVIRONMENT ---------------------------------------------------------------------- 1464 | 1465 | Linux makes the process arguments and environment available to us on the stack. 1466 | 1467 | The top of stack pointer is saved by the early assembler code when we start up in the FORTH 1468 | variable S0, and starting at this pointer we can read out the command line arguments and the 1469 | environment. 1470 | 1471 | Starting at S0, S0 itself points to argc (the number of command line arguments). 1472 | 1473 | S0+4 points to argv[0], S0+8 points to argv[1] etc up to argv[argc-1]. 1474 | 1475 | argv[argc] is a NULL pointer. 1476 | 1477 | After that the stack contains environment variables, a set of pointers to strings of the 1478 | form NAME=VALUE and on until we get to another NULL pointer. 1479 | 1480 | The first word that we define, ARGC, pushes the number of command line arguments (note that 1481 | as with C argc, this includes the name of the command). 1482 | ) 1483 | : ARGC 1484 | S0 @ @ 1485 | ; 1486 | 1487 | ( 1488 | n ARGV gets the nth command line argument. 1489 | 1490 | For example to print the command name you would do: 1491 | 0 ARGV TELL CR 1492 | ) 1493 | : ARGV ( n -- str u ) 1494 | 1+ CELLS S0 @ + ( get the address of argv[n] entry ) 1495 | @ ( get the address of the string ) 1496 | DUP STRLEN ( and get its length / turn it into a FORTH string ) 1497 | ; 1498 | 1499 | ( 1500 | ENVIRON returns the address of the first environment string. The list of strings ends 1501 | with a NULL pointer. 1502 | 1503 | For example to print the first string in the environment you could do: 1504 | ENVIRON @ DUP STRLEN TELL 1505 | ) 1506 | : ENVIRON ( -- addr ) 1507 | ARGC ( number of command line parameters on the stack to skip ) 1508 | 2 + ( skip command line count and NULL pointer after the command line args ) 1509 | CELLS ( convert to an offset ) 1510 | S0 @ + ( add to base stack address ) 1511 | ; 1512 | 1513 | ( 1514 | SYSTEM CALLS AND FILES ---------------------------------------------------------------------- 1515 | 1516 | Miscellaneous words related to system calls, and standard access to files. 1517 | ) 1518 | 1519 | ( BYE exits by calling the Linux exit(2) syscall. ) 1520 | : BYE ( -- ) 1521 | 0 ( return code (0) ) 1522 | SYS_EXIT ( system call number ) 1523 | SYSCALL1 1524 | ; 1525 | 1526 | ( 1527 | UNUSED returns the number of cells remaining in the user memory (data segment). 1528 | 1529 | For our implementation we will use Linux brk(2) system call to find out the end 1530 | of the data segment and subtract HERE from it. 1531 | ) 1532 | : GET-BRK ( -- brkpoint ) 1533 | 0 SYS_BRK SYSCALL1 ( call brk(0) ) 1534 | ; 1535 | 1536 | : UNUSED ( -- n ) 1537 | GET-BRK ( get end of data segment according to the kernel ) 1538 | HERE @ ( get current position in data segment ) 1539 | - 1540 | 4 / ( returns number of cells ) 1541 | ; 1542 | 1543 | ( 1544 | MORECORE increases the data segment by the specified number of (4 byte) cells. 1545 | 1546 | NB. The number of cells requested should normally be a multiple of 1024. The 1547 | reason is that Linux can't extend the data segment by less than a single page 1548 | (4096 bytes or 1024 cells). 1549 | 1550 | This FORTH doesn't automatically increase the size of the data segment "on demand" 1551 | (ie. when , (COMMA), ALLOT, CREATE, and so on are used). Instead the programmer 1552 | needs to be aware of how much space a large allocation will take, check UNUSED, and 1553 | call MORECORE if necessary. A simple programming exercise is to change the 1554 | implementation of the data segment so that MORECORE is called automatically if 1555 | the program needs more memory. 1556 | ) 1557 | : BRK ( brkpoint -- ) 1558 | SYS_BRK SYSCALL1 1559 | ; 1560 | 1561 | : MORECORE ( cells -- ) 1562 | CELLS GET-BRK + BRK 1563 | ; 1564 | 1565 | ( 1566 | Standard FORTH provides some simple file access primitives which we model on 1567 | top of Linux syscalls. 1568 | 1569 | The main complication is converting FORTH strings (address & length) into C 1570 | strings for the Linux kernel. 1571 | 1572 | Notice there is no buffering in this implementation. 1573 | ) 1574 | 1575 | : R/O ( -- fam ) O_RDONLY ; 1576 | : R/W ( -- fam ) O_RDWR ; 1577 | 1578 | : OPEN-FILE ( addr u fam -- fd 0 (if successful) | c-addr u fam -- fd errno (if there was an error) ) 1579 | ROT ( fam addr u ) 1580 | CSTRING ( fam cstring ) 1581 | SYS_OPEN SYSCALL2 ( open (filename, flags) ) 1582 | DUP ( fd fd ) 1583 | DUP 0< IF ( errno? ) 1584 | NEGATE ( fd errno ) 1585 | ELSE 1586 | DROP 0 ( fd 0 ) 1587 | THEN 1588 | ; 1589 | 1590 | : CREATE-FILE ( addr u fam -- fd 0 (if successful) | c-addr u fam -- fd errno (if there was an error) ) 1591 | O_CREAT OR 1592 | O_TRUNC OR 1593 | ROT ( fam addr u ) 1594 | CSTRING ( fam cstring ) 1595 | 420 ROT ( 0644 fam cstring ) 1596 | SYS_OPEN SYSCALL3 ( open (filename, flags|O_TRUNC|O_CREAT, 0644) ) 1597 | DUP ( fd fd ) 1598 | DUP 0< IF ( errno? ) 1599 | NEGATE ( fd errno ) 1600 | ELSE 1601 | DROP 0 ( fd 0 ) 1602 | THEN 1603 | ; 1604 | 1605 | : CLOSE-FILE ( fd -- 0 (if successful) | fd -- errno (if there was an error) ) 1606 | SYS_CLOSE SYSCALL1 1607 | NEGATE 1608 | ; 1609 | 1610 | : READ-FILE ( addr u fd -- u2 0 (if successful) | addr u fd -- 0 0 (if EOF) | addr u fd -- u2 errno (if error) ) 1611 | ROT SWAP -ROT ( u addr fd ) 1612 | SYS_READ SYSCALL3 1613 | 1614 | DUP ( u2 u2 ) 1615 | DUP 0< IF ( errno? ) 1616 | NEGATE ( u2 errno ) 1617 | ELSE 1618 | DROP 0 ( u2 0 ) 1619 | THEN 1620 | ; 1621 | 1622 | ( 1623 | PERROR prints a message for an errno, similar to C's perror(3) but we don't have the extensive 1624 | list of strerror strings available, so all we can do is print the errno. 1625 | ) 1626 | : PERROR ( errno addr u -- ) 1627 | TELL 1628 | ':' EMIT SPACE 1629 | ." ERRNO=" 1630 | . CR 1631 | ; 1632 | 1633 | ( 1634 | NOTES ---------------------------------------------------------------------- 1635 | 1636 | DOES> isn't possible to implement with this FORTH because we don't have a separate 1637 | data pointer. 1638 | ) 1639 | 1640 | ( 1641 | WELCOME MESSAGE ---------------------------------------------------------------------- 1642 | 1643 | Print the version and OK prompt. 1644 | ) 1645 | 1646 | : WELCOME 1647 | S" TEST-MODE" FIND NOT IF 1648 | ." JONESFORTH VERSION " VERSION . CR 1649 | UNUSED . ." CELLS REMAINING" CR 1650 | ." OK " 1651 | THEN 1652 | ; 1653 | 1654 | WELCOME 1655 | HIDE WELCOME 1656 | -------------------------------------------------------------------------------- /firmware/bootcode.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/johnhw/minforth/f43a87a448ef2768ef527a05d2d275d6f2b0e0f7/firmware/bootcode.bin -------------------------------------------------------------------------------- /firmware/start.elf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/johnhw/minforth/f43a87a448ef2768ef527a05d2d275d6f2b0e0f7/firmware/start.elf -------------------------------------------------------------------------------- /hex.scr: -------------------------------------------------------------------------------- 1 | print "Compiling kernel...\n" 2 | ! cd ~/pf/minforth ; make clean ; make 3 | print "Compiled!\n" 4 | send "\n\n\n\n" 5 | print "Uploading to device...\n" 6 | send "UPLOAD\n" 7 | ! cat kernel.hex > /dev/ttyAMA0 8 | print "\nUploaded; rebooting..." 9 | send "BOOT\n" 10 | send "BOOT\n" 11 | print "Reboot complete.\n" 12 | 13 | -------------------------------------------------------------------------------- /jonesforth.f: -------------------------------------------------------------------------------- 1 | : CONSTANT WORD CREATE DOCOL , ' LIT , , ' EXIT , ; 2 | 1 1 - CONSTANT 0 3 | 1 1 + CONSTANT 2 4 | 2 2 + CONSTANT 4 5 | 2 1 + CONSTANT 3 6 | 0 1 - CONSTANT -1 7 | 8 | : TRUE -1 ; 9 | : FALSE 0 ; 10 | : 1- 1 - ; 11 | : 1+ 1 + ; 12 | : 2- 2 - ; 13 | : 2+ 2 + ; 14 | : 4+ 4 + ; 15 | : 4- 4 - ; 16 | : 2* 1 LSHIFT ; 17 | : 2/ 1 RSHIFT ; 18 | : 4* 2 LSHIFT ; 19 | : 4/ 2 RSHIFT ; 20 | : INVERT -1 XOR ; 21 | 22 | : PICK 1+ 4* DSP@ + @ ; 23 | : DROP DSP@ 4+ DSP! ; 24 | : DUP 0 PICK ; 25 | : OVER 1 PICK ; 26 | : 2DROP DROP DROP ; 27 | : 2DUP OVER OVER ; 28 | : NIP SWAP DROP ; 29 | : +! DUP @ ROT + SWAP ! ; 30 | : -! DUP @ ROT - SWAP ! ; 31 | : / /MOD SWAP DROP ; 32 | : MOD /MOD DROP ; 33 | : NEGATE 0 SWAP - ; 34 | 35 | : <> = INVERT ; 36 | : >= < INVERT ; 37 | : <= > INVERT ; 38 | : 0= 0 = ; 39 | : 0<> 0 <> ; 40 | : 0< 0 < ; 41 | : 0> 0 > ; 42 | : 0<= 0 <= ; 43 | : 0>= 0 >= ; 44 | : NOT 0= ; 45 | 46 | : ALLOT HERE @ SWAP HERE +! ; 47 | : CELLS 4* ; 48 | : VARIABLE 1 CELLS ALLOT WORD CREATE DOCOL , ' LIT , , ' EXIT , ; 49 | 50 | : IMMEDIATE LATEST @ 4+ C@ F_IMMED OR LATEST @ 4+ C! ; 51 | LATEST @ 4+ C@ F_IMMED OR LATEST @ 4+ C! 52 | 53 | : HIDDEN 4+ DUP C@ F_HIDDEN XOR SWAP C! ; 54 | : +HIDDEN 4+ DUP C@ F_HIDDEN OR SWAP C! ; 55 | : -HIDDEN 4+ DUP C@ F_HIDDEN INVERT AND SWAP C! ; 56 | : CHAR WORD DROP C@ ; 57 | : [COMPILE] IMMEDIATE WORD FIND >CFA , ; 58 | : ~ WORD CREATE DOCOL , LATEST @ HIDDEN ]] ; 59 | : ~ IMMEDIATE LIT EXIT , LATEST @ HIDDEN [COMPILE] [[ ; 60 | CHAR ; LATEST @ 4+ 1+ C! 61 | CHAR : LATEST @ @ 4+ 1+ C! 62 | 63 | : IF IMMEDIATE ' 0BRANCH , HERE @ 0 , ; 64 | : THEN IMMEDIATE DUP HERE @ SWAP - SWAP ! ; 65 | : ELSE IMMEDIATE ' BRANCH , HERE @ 0 , SWAP DUP HERE @ SWAP - SWAP ! ; 66 | : ?DUP DUP IF DUP THEN ; 67 | : UNLESS IMMEDIATE ' NOT , [COMPILE] IF ; 68 | : BEGIN IMMEDIATE HERE @ ; 69 | : UNTIL IMMEDIATE ' 0BRANCH , HERE @ - , ; 70 | : AGAIN IMMEDIATE ' BRANCH , HERE @ - , ; 71 | : WHILE IMMEDIATE ' 0BRANCH , HERE @ 0 , ; 72 | : REPEAT IMMEDIATE ' BRANCH , SWAP HERE @ - , DUP HERE @ SWAP - SWAP ! ; 73 | : CASE IMMEDIATE 0 ; 74 | : OF IMMEDIATE ' OVER , ' = , [COMPILE] IF ' DROP , ; 75 | : ENDOF IMMEDIATE [COMPILE] ELSE ; 76 | : ENDCASE IMMEDIATE ' DROP , BEGIN ?DUP WHILE [COMPILE] THEN REPEAT ; 77 | 78 | : LITERAL IMMEDIATE ' LIT , , ; 79 | : ':' [[ CHAR : ]] LITERAL ; 80 | : ';' [[ CHAR ; ]] LITERAL ; 81 | : '(' [[ CHAR ( ]] LITERAL ; 82 | : ')' [[ CHAR ) ]] LITERAL ; 83 | : '"' [[ CHAR " ]] LITERAL ; 84 | : 'A' [[ CHAR A ]] LITERAL ; 85 | : 'Z' [[ CHAR Z ]] LITERAL ; 86 | : 'a' [[ CHAR A ]] LITERAL ; 87 | : 'z' [[ CHAR Z ]] LITERAL ; 88 | : '0' [[ CHAR 0 ]] LITERAL ; 89 | : '9' [[ CHAR 9 ]] LITERAL ; 90 | : '-' [[ CHAR - ]] LITERAL ; 91 | : '.' [[ CHAR . ]] LITERAL ; 92 | 93 | : ( IMMEDIATE 1 BEGIN KEY DUP '(' = IF DROP 1+ ELSE ')' = IF 1- THEN THEN DUP 0= UNTIL DROP ; 94 | ( comments are now available! ) 95 | 96 | 97 | ( parse numbers ) 98 | 0 VARIABLE TNUM 99 | 'A' '9' '0' - 1+ - CONSTANT A10 100 | : ISDIGIT DUP '0' >= SWAP '9' <= AND ; 101 | : MULBASE TNUM @ BASE @ * TNUM ! ; 102 | : NEXTCHAR OVER C@ -ROT 1 - -ROT 1 + -ROT ; 103 | : SKIPCHAR NEXTCHAR DROP ; 104 | : ISALPHA ( c -- ok ) DUP 'A' >= SWAP 'Z' <= AND ; 105 | 106 | : CHECKBASE ( n -- ok ) DUP BASE @ < IF TNUM +! TRUE ELSE DROP FALSE THEN ; 107 | : CHECKSIGN ( c -- ) OVER C@ '-' = IF SKIPCHAR -1 ELSE 1 THEN -ROT ; 108 | : NUMBER ( addr length -- n e ) 109 | CHECKSIGN 0 TNUM ! 110 | BEGIN DUP 0 = IF 1 - FALSE ( stop, string is complete ) 111 | ELSE 112 | MULBASE NEXTCHAR 113 | DUP ISDIGIT IF '0' - CHECKBASE ELSE 114 | DUP ISALPHA IF A10 - CHECKBASE ELSE DROP FALSE THEN THEN 115 | THEN 0 = UNTIL 1 + 116 | SWAP DROP ( len -- ) 117 | SWAP TNUM @ * 118 | SWAP 119 | ( -- n e ) ; 120 | 121 | ( String handling ) 122 | : TELL DUP 0> IF BEGIN SWAP DUP C@ EMIT 1+ SWAP 1- DUP 0<= UNTIL THEN DROP DROP ; 123 | : ALIGNED ( c-addr -- a-addr ) 3 + 3 INVERT AND ; 124 | : ALIGN HERE @ ALIGNED HERE ! ; 125 | : C, HERE @ C! 1 HERE +! ; 126 | : S" IMMEDIATE ( -- addr len ) 127 | STATE @ IF 128 | ' LITS , HERE @ 0 , 129 | BEGIN KEY DUP '"' 130 | <> WHILE C, REPEAT 131 | DROP DUP HERE @ SWAP - 4- SWAP ! ALIGN 132 | ELSE 133 | HERE @ 134 | BEGIN KEY DUP '"' 135 | <> WHILE OVER C! 1+ REPEAT 136 | DROP HERE @ - HERE @ SWAP 137 | THEN 138 | ; 139 | 140 | : DROPALL S0 @ DSP! ; 141 | : ?STACK S0 @ DSP@ <= IF DROPALL S" Stack underflow!" TELL THEN ; 142 | 143 | : INTERPRET 144 | 2DUP FIND DUP 0= IF 145 | DROP 2DUP NUMBER ( must be a number or invalid token ) 146 | 0<> IF DROP S" Unknown word <" TELL TELL S" > 147 | " TELL 148 | ELSE NIP NIP STATE @ IF ' LIT , , THEN 149 | THEN 150 | ELSE 151 | NIP NIP 152 | DUP 4+ C@ F_IMMED AND 0<> IF >CFA EXECUTE ELSE 153 | >CFA STATE @ IF , ELSE EXECUTE THEN 154 | THEN 155 | THEN ; 156 | 157 | : QUIT BEGIN R0 RSP! ?STACK WORD INTERPRET AGAIN ; 158 | : BREAK DROPALL ." " CR QUIT ; 159 | 160 | QUIT 161 | ( now we are running in our own interpreter ) 162 | ( and we have numbers as literals! ) 163 | 164 | ( line comments ) 165 | : '\n' 10 ; 166 | : \ IMMEDIATE BEGIN KEY '\n' = UNTIL ; 167 | 168 | : HEX 16 BASE ! ; 169 | : DECIMAL 10 BASE ! ; 170 | 171 | \ binary manipulation 172 | : NTHBIT 1 SWAP LSHIFT ; 173 | : CLEARMASK INVERT AND ; 174 | : SETMASK OR ; 175 | : BITRANGE SWAP DUP -ROT - 1 SWAP LSHIFT 1- SWAP LSHIFT ; 176 | : CLEARBITS BITRANGE CLEARMASK ; 177 | : SETBITS BITRANGE SETMASK ; 178 | : SETBIT NTHBIT OR ; 179 | : CLEARBIT NTHBIT INVERT AND ; 180 | HEX 181 | FF CONSTANT 8BITMASK 182 | FFFF CONSTANT 16BITMASK 183 | DECIMAL 184 | : HIGH16 16 RSHIFT ; 185 | : LOW16 16BITMASK AND ; 186 | : LSB 8BITMASK AND ; 187 | 188 | \ GPIO 189 | HEX 190 | 20200004 CONSTANT GPFSEL1 191 | 20200008 CONSTANT GPFSEL2 192 | 2020000C CONSTANT GPFSEL3 193 | 20200010 CONSTANT GPFSEL4 194 | 2020001C CONSTANT GPSET0 195 | 20200020 CONSTANT GPSET1 196 | 20200028 CONSTANT GPCLR0 197 | 2020002C CONSTANT GPCLR1 198 | DECIMAL 199 | 200 | : GPIO_ON DUP 32 > IF 32 - NTHBIT GPSET1 ! ELSE NTHBIT GPSET0 THEN ; 201 | : GPIO_OFF DUP 32 > IF 32 - NTHBIT GPCLR1 ! ELSE NTHBIT GPCLR0 THEN ; 202 | : GPIO_ENABLE ( gpio -- sel a b ) 10 /MOD 4 * GPFSEL1 + SWAP 3 * DUP 3 + ; 203 | 204 | VARIABLE GPIO_RSTART 205 | VARIABLE GPIO_REND 206 | VARIABLE GPIO 207 | 208 | : GPIO_OUT GPIO_ENABLE GPIO_REND ! GPIO_RSTART ! GPIO ! GPIO @ @ GPIO_REND @ GPIO_RSTART @ CLEARBITS GPIO_RSTART SETBIT GPIO ! ; 209 | : GPIO_IN GPIO_ENABLE GPIO_REND ! GPIO_RSTART ! GPIO ! GPIO @ @ GPIO_REND @ GPIO_RSTART @ CLEARBITS GPIO ! ; 210 | 211 | \ For B+ boards 212 | 47 CONSTANT LED_GPIO 213 | 214 | : LEDENABLE GPIO_OUT LED_GPIO ; 215 | : LEDON LED_GPIO GPIO_ON ; 216 | : LEDOFF LED_GPIO GPIO_OFF ; 217 | LEDON 218 | 219 | \ UART 220 | 5 NTHBIT CONSTANT UART_OUTREADY_MASK 221 | 0 NTHBIT CONSTANT UART_INREADY_MASK 222 | 223 | HEX 224 | 20200094 CONSTANT GPPUD 225 | 20200098 CONSTANT GPPUDCLK0 226 | 20215004 CONSTANT AUX_ENABLES 227 | 20215040 CONSTANT AUX_IO 228 | 20215054 CONSTANT AUX_LSR 229 | 20215044 CONSTANT AUX_IER 230 | 20215048 CONSTANT AUX_IIR 231 | 2021504C CONSTANT AUX_LCR 232 | 20215050 CONSTANT AUX_MCR 233 | 20215058 CONSTANT AUX_MSR 234 | 20215060 CONSTANT AUX_CNTL 235 | 20215068 CONSTANT AUX_BAUD 236 | DECIMAL 237 | 238 | : SPIN 0 DO LOOP ; 239 | : UARTCLEAR 1 AUX_ENABLES ! 0 AUX_IER ! 0 AUX_CNTL ! 3 AUX_LCR ! 0 AUX_MCR ! 0 AUX_IER ! 198 AUX_IIR ! 270 AUX_BAUD ! ; 240 | : UARTGPIO GPFSEL1 @ 12 15 CLEARBITS 13 SETBIT 15 18 CLEARBITS 16 SETBIT GPFSEL1 ! ; 241 | : UARTCLOCK 0 GPPUD ! 150 SPIN 14 NTHBIT 15 NTHBIT OR GPPUDCLK0 ! 150 SPIN 0 GPPUDCLK0 ! ; 242 | : UARTINIT UARTCLEAR UARTGPIO UARTCLOCK 3 AUX_CNTL ! ; 243 | : UARTOUTREADY AUX_LSR @ UART_OUTREADY_MASK AND 0<> ; 244 | : UARTINREADY AUX_LSR @ UART_INREADY_MASK AND 0<> ; 245 | : UARTRAWPUT AUX_IO ! ; 246 | : UARTPUT BEGIN UARTOUTREADY UNTIL UARTRAWPUT ; 247 | : UARTEMIT DUP '\n' = IF 13 UARTPUT THEN UARTPUT ; 248 | : UARTGET AUX_IO @ 8BITMASK AND ; 249 | : BREAK_TEST 3 = IF BREAK THEN ; 250 | : UARTRAWKEY BEGIN UARTINREADY UNTIL UARTGET ; 251 | : UARTKEY UARTRAWKEY DUP 3 = IF BREAK THEN DUP 13 = IF DROP 10 THEN ; 252 | UARTINIT 253 | 254 | 65 UARTPUT 66 UARTPUT '\n' UARTEMIT 255 | 256 | : UARTTELL DUP 0> IF BEGIN SWAP DUP C@ UARTEMIT 1+ SWAP 1- DUP 0<= UNTIL THEN DROP DROP ; 257 | : UARTLINE UARTTELL '\n' UARTEMIT ; 258 | 259 | : ." IMMEDIATE ( -- ) 260 | STATE @ IF 261 | [COMPILE] S" ' TELL , 262 | ELSE 263 | BEGIN KEY DUP '"' = IF DROP EXIT THEN EMIT AGAIN 264 | THEN 265 | ; 266 | 267 | S" Memory" UARTLINE 268 | \ Memory words 269 | : C++ DUP C@ 1+ SWAP C! ; 270 | : C-- DUP C@ 1- SWAP C! ; 271 | : ++ DUP @ 1+ SWAP ! ; 272 | : -- DUP @ 1- SWAP ! ; 273 | : ->CELL 4 SWAP +! ; 274 | : <-CELL 4 SWAP -! ; 275 | : ->C 1 SWAP +! ; 276 | : <-C 1 SWAP -! ; 277 | 278 | S" Characters" UARTLINE 279 | \ Character constants 280 | : BKSP 8 ; 281 | : NL 10 ; 282 | : '\t' 9 ; 283 | : BL 32 ; 284 | : CR 10 EMIT ; 285 | : SPACE 32 EMIT ; 286 | : ISSPACE BL = ; 287 | : SPACES ( n -- ) BEGIN DUP 0> WHILE SPACE 1- REPEAT DROP ; 288 | : ZEROS ( n -- ) BEGIN DUP 0> WHILE '0' EMIT 1- REPEAT DROP ; 289 | 290 | S" Numbers" UARTLINE 291 | \ write out unsigned numbers 292 | 64 BUFFER NUMPAD 293 | 63 NUMPAD + CONSTANT TOPPAD 294 | : WRITECHAR TOPPAD C++ TOPPAD TOPPAD C@ - C! ; 295 | : DIGIT DUP 10 >= IF 55 + WRITECHAR ELSE '0' + WRITECHAR THEN ; 296 | : PUSHPAD TOPPAD TOPPAD C@ - TOPPAD C@ ; 297 | : CLEARPAD 0 TOPPAD C! ; 298 | : PDOT CLEARPAD BEGIN BASE @ /MOD SWAP DIGIT DUP 0= UNTIL DROP ; 299 | : UDOT PDOT PUSHPAD ; 300 | : DOT DUP 0< IF NEGATE PDOT '-' WRITECHAR ELSE PDOT THEN PUSHPAD ; 301 | 302 | S" Aligned" UARTLINE 303 | \ aligned unsigned 304 | : U.R UDOT ROT OVER - SPACES TELL ; 305 | : U.ZR UDOT ROT OVER - ZEROS TELL ; 306 | : U. UDOT TELL BL EMIT ; 307 | 308 | \ signed number output 309 | : .R DOT ROT OVER - SPACES TELL ; 310 | : . DOT TELL BL EMIT ; 311 | : ? @ . ; 312 | : .BIN BASE @ SWAP BINARY . BASE ! ; 313 | : .HEX BASE @ SWAP HEX . BASE ! ; 314 | : .OCTAL BASE @ SWAP OCTAL . BASE ! ; 315 | 316 | S" FIXED" UARTLINE 317 | 318 | \ Fixed point 319 | : .INTEGER 16 RSHIFT DOT TELL ; 320 | : .FRACTIONAL 16BITMASK AND BEGIN 10 * DUP 16 RSHIFT '0' + EMIT 16BITMASK AND DUP 0= UNTIL ; 321 | : .X DUP .INTEGER '.' EMIT .FRACTIONAL ; 322 | 323 | S" Base" UARTLINE 324 | \ Base switching words 325 | : # ( b -- n ) BASE @ SWAP BASE ! WORD NUMBER DROP SWAP BASE ! ; 326 | : 16# 16 # ; 327 | : 10# 10 # ; 328 | : 2# 2 # ; 329 | : 8# 8 # ; 330 | : BINARY ( -- ) 2 BASE ! ; 331 | : OCTAL ( -- ) 8 BASE ! ; 332 | 333 | S" Standard" UARTLINE 334 | \ standard words 335 | : ON TRUE SWAP ! ; 336 | : OFF FALSE SWAP ! ; 337 | : MAX 2DUP > IF DROP ELSE SWAP DROP THEN ; 338 | : MIN 2DUP <= IF DROP ELSE SWAP DROP THEN ; 339 | : CLIP ( c a b -- c ) ROT MIN MAX ; 340 | : ABS DUP 0< IF NEGATE THEN ; 341 | : WITHIN -ROT OVER <= IF > IF TRUE ELSE FALSE THEN ELSE 2DROP FALSE THEN ; 342 | : ISLOWERALPHA ( c -- ok ) DUP 'a' >= SWAP 'z' <= AND ; 343 | : ISLETTER DUP ISALPHA SWAP ISLOWERALPHA OR ; 344 | : DEPTH DSP@ S0 @ - 2 RSHIFT ; 345 | : NALIGNED ( val n -- val_aligned ) 1 SWAP LSHIFT 1- DUP ROT + SWAP INVERT AND ; 346 | : NALIGN ( n -- ) HERE @ SWAP NALIGNED HERE ! ; 347 | : BUFFER ALLOT CONSTANT ; 348 | : 2OVER 3 PICK 3 PICK ; 349 | : 2SWAP >R -ROT R> -ROT ; 350 | : TUCK SWAP OVER ; 351 | : VARIABLE: VARIABLE LATEST @ >CFA EXECUTE ! ; 352 | : RECURSE IMMEDIATE LATEST @ >CFA , ; 353 | 354 | S" Namespaces" UARTLINE 355 | \ Private namespaces 356 | VARIABLE HIDDEN_BLOCK 357 | VARIABLE REVEAL_BLOCK 358 | : +HIDDEN 4+ DUP C@ F_HIDDEN OR SWAP C! ; 359 | : {{ LATEST @ HIDDEN_BLOCK ! 0 REVEAL_BLOCK ! ; 360 | : PUBLIC: LATEST @ REVEAL_BLOCK ! ; 361 | : }} REVEAL_BLOCK @ DUP 0= IF DROP LATEST THEN BEGIN @ DUP +HIDDEN DUP HIDDEN_BLOCK @ = UNTIL DROP ; 362 | 363 | 364 | S" Stack printing" UARTLINE 365 | \ stack printing 366 | {{ 367 | VARIABLE TSP 368 | : +TSP -4 TSP +! ; 369 | : TSP@ TSP @ @ ; 370 | : SETTSP S0 @ 4 - TSP ! ; 371 | PUBLIC: 372 | : .S SETTSP BEGIN TSP @ DSP@ 4 + >= IF TSP@ . +TSP FALSE ELSE TRUE THEN UNTIL ; 373 | : .R RSP@ BEGIN DUP R0 <= IF ." 0x" DUP @ .HEX 4+ FALSE ELSE TRUE THEN UNTIL DROP ; 374 | }} 375 | 376 | 377 | \ quotations 378 | 379 | S" Quotations" UARTLINE 380 | \ space to store quotations 381 | 16000 ALLOT CONSTANT QUOTEBLOCK 382 | QUOTEBLOCK VARIABLE: QUOTEHERE 383 | \ recursive quotes don't work :( 384 | : [ IMMEDIATE QUOTEHERE @ STATE @ IF ' LIT , , THEN STATE @ HERE @ QUOTEHERE @ HERE ! DOCOL , ]] ; 385 | : ] IMMEDIATE LIT EXIT , HERE @ QUOTEHERE ! HERE ! STATE ! ; 386 | : QIF IF NIP EXECUTE ELSE DROP EXECUTE THEN ; 387 | : QIFTRUE IF EXECUTE ELSE DROP THEN ; 388 | : QIFFALSE IF DROP ELSE EXECUTE THEN ; 389 | : QWHILE >R BEGIN R> DUP >R EXECUTE INVERT UNTIL R> DROP ; 390 | : QUNTIL >R BEGIN R> DUP >R EXECUTE UNTIL R> DROP ; 391 | \ : QTIMES >R 0 DO R> DUP >R EXECUTE LOOP R> DROP ; 392 | \ : ITER >R 0 DO R> DUP >R I EXECUTE LOOP R> DROP ; 393 | \ : ITERD >R >R BEGIN R> DUP >R EXECUTE R> R> 1- -ROT >R >R 0= UNTIL R> R> DROP DROP ; 394 | : QPRESERVE DUP >R @ >R EXECUTE R> R> SWAP ! ; 395 | : QDIP >R EXECUTE R> ; 396 | : QSIP DUP >R EXECUTE R> ; 397 | 398 | S" Introspection" UARTLINE 399 | \ Original JONESFORTH introspection functions 400 | : COUNT DUP 1+ SWAP C@ ; 401 | : ID. 4+ COUNT F_LENMASK AND BEGIN DUP 0> WHILE SWAP COUNT EMIT SWAP 1- REPEAT 2DROP ; 402 | : >DFA >CFA 4+ ; 403 | : DICT WORD FIND ; 404 | : VALUE ( n -- ) WORD CREATE DOCOL , ' LIT , , ' EXIT , ; 405 | : TO IMMEDIATE ( n -- ) 406 | DICT >DFA 4+ 407 | STATE @ IF ' LIT , , ' ! , ELSE ! THEN 408 | ; 409 | : +TO IMMEDIATE 410 | DICT >DFA 4+ 411 | STATE @ IF ' LIT , , ' +! , ELSE +! THEN 412 | ; 413 | 414 | 415 | : ?HIDDEN 4+ C@ F_HIDDEN AND ; 416 | : ?IMMEDIATE 4+ C@ F_IMMED AND ; 417 | : WORDS LATEST @ BEGIN ?DUP WHILE DUP ?HIDDEN NOT IF DUP ID. SPACE ." 0x" DUP . CR THEN @ REPEAT CR ; 418 | : FORGET DICT DUP @ LATEST ! HERE ! ; 419 | : CFA> LATEST @ BEGIN ?DUP WHILE 2DUP SWAP < IF NIP EXIT THEN @ REPEAT DROP 0 ; 420 | : WORDEXTENTS ( wordptr -- end start ) HERE @ LATEST @ 421 | BEGIN 2 PICK OVER <> WHILE NIP DUP @ REPEAT 422 | DROP SWAP ; 423 | 424 | : SEE 425 | DICT DUP 0= IF ." Word not found" CR EXIT THEN WORDEXTENTS ':' EMIT SPACE DUP ID. SPACE 426 | DUP ?IMMEDIATE IF ." IMMEDIATE " THEN 427 | >DFA BEGIN 2DUP 428 | > WHILE DUP @ CASE 429 | ' LIT OF 4 + DUP @ . ENDOF 430 | ' LITS OF [[ CHAR S ]] LITERAL EMIT '"' EMIT SPACE 431 | 4 + DUP @ SWAP 4 + SWAP 2DUP TELL '"' EMIT SPACE + ALIGNED 4 - 432 | ENDOF 433 | ' 0BRANCH OF ." 0BRANCH ( " 4 + DUP @ . ." ) " ENDOF 434 | ' BRANCH OF ." BRANCH ( " 4 + DUP @ . ." ) " ENDOF 435 | ' ' OF [[ CHAR ' ]] LITERAL EMIT SPACE 4 + DUP @ CFA> ID. SPACE ENDOF 436 | ' EXIT OF 2DUP 4 + <> IF ." EXIT " THEN ENDOF 437 | DUP CFA> ID. SPACE 438 | ENDCASE 4 + REPEAT 439 | ';' EMIT CR 2DROP 440 | ; 441 | : :NONAME 0 0 CREATE HERE @ DOCOL , ]] ; 442 | : ['] IMMEDIATE ' LIT , ; 443 | 444 | S" Expansion" UARTLINE 445 | \ compile a word by expanding it in place 446 | \ : EXPAND IMMEDIATE STATE @ IF HERE 4- @ WORDEXTENTS HERE @ HERE 4- ! BEGIN DUP @ , 4+ 2DUP = UNTIL THEN ; 447 | 448 | S" Exceptions" UARTLINE 449 | \ Exception handling 450 | : EXCEPTION-MARKER R> DROP 0 ; 451 | : CATCH ( xt -- exn? ) DSP@ 4+ >R ' EXCEPTION-MARKER 4+ >R EXECUTE ; 452 | : THROW ( n -- ) ?DUP IF 453 | RSP@ BEGIN DUP R0 4- 454 | < WHILE DUP @ ' EXCEPTION-MARKER 4+ 455 | = IF 4+ RSP! DUP DUP DUP R> 4- SWAP OVER ! DSP! EXIT THEN 456 | 4+ REPEAT DROP 457 | CASE 458 | 0 1- OF ." ABORTED" CR ENDOF 459 | ." UNCAUGHT THROW " DUP . CR 460 | ENDCASE QUIT THEN 461 | ; 462 | : ABORT ( -- ) 0 1- THROW ; 463 | : PRINT-STACK-TRACE 464 | RSP@ BEGIN DUP R0 4- 465 | < WHILE DUP @ CASE 466 | ' EXCEPTION-MARKER 4+ OF ." CATCH ( DSP=" 4+ DUP @ U. ." ) " ENDOF 467 | DUP CFA> ?DUP IF 2DUP ID. [[ CHAR + ]] LITERAL EMIT SWAP >DFA 4+ - . THEN 468 | ENDCASE 4+ REPEAT DROP CR 469 | ; 470 | : UNUSED ( -- n ) PAD HERE @ - 4/ ; 471 | 472 | 473 | S" Dumping" UARTLINE 474 | \ Hex dumping of memory 475 | 476 | {{ 477 | : BAR [[ CHAR | ]] LITERAL EMIT ; 478 | : HEX_ADDRESS DUP 8 SWAP U.ZR ; 479 | : HD DUP C@ 2 SWAP U.ZR 1+ SPACE ; 480 | : HEX_ROW HD HD HD HD HD HD HD HD ; 481 | : PRINTABLE_CHAR DUP 32 < IF DROP '.' THEN DUP 127 > IF DROP '.' THEN ; 482 | : AS DUP C@ PRINTABLE_CHAR EMIT 1+ ; 483 | : 4AS AS AS AS AS ; 484 | : ASCII_ROW 4AS 4AS 4AS 4AS ; 485 | PUBLIC: 486 | : DUMP ( addr len -- ) DUP 4096 > IF DROP 4096 THEN 487 | BASE @ -ROT HEX \ store old base and switch to hex 488 | BEGIN SWAP HEX_ADDRESS 2 SPACES HEX_ROW SPACE HEX_ROW 2 SPACES 489 | 16 - BAR ASCII_ROW BAR CR SWAP 16 - DUP 0<= UNTIL \ until done 490 | CR 2DROP BASE ! ; 491 | }} 492 | 493 | 494 | S" Counted" UARTLINE 495 | \ Counted loops 496 | 32 CELLS ALLOT VARIABLE: LOOPSP 497 | LOOPSP @ CONSTANT LOOPTOP 498 | : >LOOP LOOPSP @ ! LOOPSP ->CELL ; 499 | : LOOP> LOOPSP <-CELL LOOPSP @ @ ; 500 | : DO IMMEDIATE ' >LOOP , ' >LOOP , [COMPILE] BEGIN ; 501 | : LOOPCHECK LOOP> LOOP> 1+ 2DUP = -ROT >LOOP >LOOP ; 502 | : +LOOPCHECK LOOP> LOOP> ROT + 2DUP <= -ROT >LOOP >LOOP ; 503 | : LOOPFINISH LOOP> DROP LOOP> DROP ; 504 | : LOOP IMMEDIATE ' LOOPCHECK , [COMPILE] UNTIL ' LOOPFINISH , ; 505 | : +LOOP IMMEDIATE ' +LOOPCHECK , [COMPILE] UNTIL ' LOOPFINISH , ; 506 | : I LOOPTOP @ ; 507 | : J LOOPTOP 8 + @ ; 508 | 509 | \ append a character to a string on the stack; must be enough room in the buffer 510 | : SUFFIX 1+ SWAP OVER + ROT SWAP -ROT C! SWAP ; 511 | 512 | S" Lists" UARTLINE 513 | \ basic linked list/stack 514 | : LIST.MK 2 CELLS ALLOT DUP 4+ 0 ! ( -- listptr[val,ptr] ) ; 515 | : LIST.NIL 0 ; 516 | : LIST.CONS ( car cdr -- cons ) SWAP LIST.MK DUP -ROT ! DUP ROT SWAP 4+ ! ; 517 | : LIST.CDR ( listptr -- listptr ) 4+ @ ; 518 | : LIST.CAR ( listptr -- val ) @ ; 519 | : LIST.NTH ( listptr n -- val ) 0 DO LIST.CDR LOOP LIST.CAR ; 520 | 521 | : LIST.PUSH BEGIN DUP LIST.CAR SWAP LIST.CDR DUP 0= UNTIL DROP ; 522 | : LIST.CREATE ( n1 n2 n3 n4 ... n -- listptr ) LIST.NIL SWAP 0 DO LIST.CONS LOOP ; 523 | : LIST.MAPCAR >R BEGIN DUP LIST.CAR R> DUP >R EXECUTE DUP LIST.CDR 0= IF DROP TRUE ELSE LIST.CDR FALSE THEN UNTIL R> DROP ; 524 | : LIST.PRINT ['] . LIST.MAPCAR ; 525 | VARIABLE LIST.FILTERED 526 | : LIST.FILTER NIL LIST.FILTERED ! >R BEGIN DUP LIST.CAR DUP R> DUP >R EXECUTE IF LIST.FILTERED @ CONS LIST.FILTERED ! ELSE DROP THEN DUP LIST.CDR 0= IF DROP TRUE ELSE LIST.CDR FALSE THEN UNTIL R> DROP ; 527 | 528 | VARIABLE LIST.PRODUCT 529 | : LIST.REDUCE >R DUP LIST.CAR LIST.PRODUCT ! LIST.CDR BEGIN DUP LIST.CAR LIST.PRODUCT @ R> DUP >R EXECUTE LIST.PRODUCT ! DUP LIST.CDR 0= IF DROP TRUE ELSE LIST.CDR FALSE THEN UNTIL R> DROP LIST.PRODUCT @ ; 530 | 531 | : LIST.LAST BEGIN DUP LIST.CDR 0<> WHILE LIST.CDR REPEAT ; 532 | : LIST.MAKE_ENDLESS DUP DUP LIST.LAST 4+ ! ; 533 | 534 | : TESTLIST 1 2 3 4 5 5 LIST.CREATE ; 535 | 536 | S" ANSI" UARTLINE 537 | \ ANSI codes 538 | 539 | 27 CONSTANT ESC 540 | : '~' [[ CHAR ~ ]] LITERAL ; 541 | : '[' [[ CHAR [ ]] LITERAL ; 542 | : 'm' [[ CHAR m ]] LITERAL ; 543 | : '2' [[ CHAR 2 ]] LITERAL ; 544 | : 'J' [[ CHAR j ]] LITERAL ; 545 | : ANSICOLOR ESC EMIT '[' EMIT DOT TELL 'm' EMIT ; 546 | VARIABLE ANSI_FG_SET 547 | VARIABLE ANSI_BG_SET 548 | : ANSI_FG 30 + DUP ANSI_FG_SET ! ANSICOLOR ; 549 | : ANSI_BG 40 + DUP ANSI_BG_SET ! ANSICOLOR ; 550 | : ANSI_ATTR ANSI_BG ANSI_FG ; 551 | 0 CONSTANT ANSI_BLACK 552 | 1 CONSTANT ANSI_RED 553 | 2 CONSTANT ANSI_GREEN 554 | 3 CONSTANT ANSI_YELLOW 555 | 4 CONSTANT ANSI_BLUE 556 | 5 CONSTANT ANSI_MAGENTA 557 | 6 CONSTANT ANSI_CYAN 558 | 7 CONSTANT ANSI_WHITE 559 | 0 CONSTANT ANSI_PLAIN 560 | 1 CONSTANT ANSI_BOLD 561 | 4 CONSTANT ANSI_UNDERSCORE 562 | 5 CONSTANT ANSI_BLINK 563 | 7 CONSTANT ANSI_REVERSE 564 | 8 CONSTANT ANSI_CONCEALED 565 | : ANSI_CLS ESC EMIT S" [2J" TELL ; 566 | : ANSI_CLRLINE ESC EMIT S" [K" TELL ; 567 | : ANSI_DEFAULT 37 ANSICOLOR 40 ANSICOLOR ; 568 | : ANSI_ERROR ANSI_BLACK ANSI_BG ANSI_RED ANSI_FG ; 569 | 570 | S" Timer" UARTLINE 571 | \ System functions 572 | 573 | 574 | 575 | \ Load a hex block from the stream. Terminate with non-number 576 | {{ 577 | 16# 100000 CONSTANT UPLOAD_ADDRESS 578 | VARIABLE BOOT_ADDRESS 579 | : HEXLOAD HEX BEGIN DUP WORD NUMBER 0= IF SWAP C! 1+ FALSE ELSE DROP TRUE THEN UNTIL ; 580 | PUBLIC: 581 | : UPLOAD ." Start hex transfer:" CR HEX UPLOAD_ADDRESS HEXLOAD ." OK: 0x" UPLOAD_ADDRESS - . ." bytes transferred." CR ; 582 | : BOOT UPLOAD_ADDRESS BOOT_ADDRESS ! BOOT_ADDRESS EXECUTE ; 583 | }} 584 | 585 | 586 | \ Timer access 587 | {{ 588 | 16# 2000B400 CONSTANT TIMER_BASE 589 | TIMER_BASE 16# 8 + CONSTANT TIMER_CTL 590 | TIMER_BASE 16# 20 + CONSTANT TIMER_CNT 591 | 16# 00F90000 CONSTANT TIMER_ENABLE 592 | 16# 00F90200 CONSTANT TIMER_SET 593 | 0 VARIABLE: WAIT_ADJUSTMENT 594 | VARIABLE TIMEITVAR 595 | VARIABLE TIMEIT_OVERHEAD 596 | PUBLIC: 597 | : TIMER_INIT TIMER_ENABLE TIMER_CTL ! TIMER_SET TIMER_CTL ! ; 598 | : TIMER_READ TIMER_CNT @ ; 599 | : TIMER_WAIT ( usecs -- ) TIMER_READ + WAIT_ADJUSTMENT @ - BEGIN DUP TIMER_READ < UNTIL DROP ; 600 | : TIMER_SECONDS TIMER_READ 1000000 / ; 601 | \ Profile run time of a word: e.g. 200 30 RUNTIME + 602 | \ compute the call overhead 603 | : CALC_OVERHEAD TIMER_READ TIMEITVAR ! TIMER_READ TIMEITVAR @ - TIMEIT_OVERHEAD ! ; 604 | \ CALC_OVERHEAD FORGET CALC_OVERHEAD 605 | : RUNTIME WORD FIND >CFA TIMER_READ TIMEITVAR ! EXECUTE TIMER_READ TIMEITVAR @ - TIMEIT_OVERHEAD @ - ; 606 | \ adjust the timer waiting 607 | \ 200 RUNTIME TIMER_WAIT 200 - WAIT_ADJUSTMENT ! 608 | : TIMEIT RUNTIME . ." uS" ; 609 | }} 610 | 611 | 612 | S" Quote" UARTLINE 613 | \ quote that works in immediate mode 614 | : QUOTE WORD FIND >CFA ( -- xt ) ; 615 | : BACKPATCH QUOTE QUOTE 4+ ! ; 616 | 617 | 618 | 619 | 620 | : UARTIN_TIMEOUT TIMER_READ + BEGIN UARTINREADY IF UARTGET EXIT ELSE DUP TIMER_READ < IF -1 EXIT THEN THEN AGAIN ; 621 | 622 | 623 | {{ 624 | 16# 4 CONSTANT X_EOT 625 | 16# 1 CONSTANT X_SOH 626 | 16# 6 CONSTANT X_ACK 627 | 16# 15 CONSTANT X_NAK 628 | 16# 18 CONSTANT X_CAN 629 | 630 | : SOH X_SOH UARTEMIT ; 631 | : EOT X_EOT UARTEMIT ; 632 | : ACK X_ACK UARTEMIT ; 633 | : NAK X_NAK UARTEMIT ; 634 | : CAN X_CAN UARTEMIT ; 635 | 636 | : WAITCHAR 250000 UARTIN_TIMEOUT ; 637 | : XMODEM_FLUSH BEGIN WAITCHAR -1 = UNTIL ; 638 | 639 | VARIABLE RCV_LIMIT 640 | VARIABLE RCV_ADDR 641 | VARIABLE RCV_LEN 642 | VARIABLE BLK 643 | VARIABLE ERRCOUNT 644 | 0 VARIABLE: RCV_DONE 645 | : SECS 1000000 * ; 646 | 647 | : XMODEM_CANCEL CAN CAN CAN ; 648 | VARIABLE CHKSUM 649 | : RCV_BYTES 0 DO WAITCHAR DUP CHKSUM +! OVER C! 1+ LOOP ; 650 | : XMODEM_BLKNO WAITCHAR BLK @ <> IF FALSE EXIT THEN WAITCHAR 255 BLK @ - <> IF FALSE EXIT THEN TRUE ; 651 | : XMODEM_NEXT 128 RCV_ADDR +! 1 BLK +! 128 RCV_LEN +! ; 652 | : XMODEM_BLOCK XMODEM_BLKNO NOT IF FALSE EXIT THEN 0 CHKSUM ! RCV_ADDR 128 RCV_BYTES WAITCHAR CHKSUM @ <> IF FALSE EXIT THEN XMODEM_NEXT TRUE ; 653 | : XMODEM_ERROR XMODEM_FLUSH NAK ERRCOUNT ++ ; 654 | : XMODEM_HEADER BEGIN 655 | ERRCOUNT @ 10 > IF XMODEM_CANCEL -1 RCV_LEN ! EXIT THEN ( break on too many errors ) 656 | XMODEM_ERROR 3 SECS UARTIN_TIMEOUT DUP ( NAK every 3 seconds ) 657 | X_EOT = IF ACK DROP EXIT ELSE ( check if done ) 658 | X_SOH = IF XMODEM_BLOCK IF ACK ELSE XMODEM_ERROR THEN ELSE XMODEM_ERROR THEN ( if data, read it ) 659 | AGAIN ; 660 | PUBLIC: 661 | : XMODEM_RCV ( addr max -- ) 0 ERRCOUNT ! RCV_LIMIT ! RCV_ADDR ! 0 RCV_LEN ! XMODEM_HEADER RCV_LEN @ ; 662 | : XMODEM_RECV ." Begin XMODEM transfer" CR XMODEM_RCV DUP -1 = IF ." Transfer failed!" CR ELSE ." Transfer succeeded; " DUP . ." bytes transfered" CR THEN ; 663 | }} 664 | 665 | 666 | 667 | S" Streams" UARTLINE 668 | \ allow input redirection by redefining INPUT-STREAM 669 | \ INPUT-STREAM points at a word that retrieves one more character from the input 670 | \ OUTPUT-STREAM points at a word that outputs a single character 671 | VARIABLE INPUT-STREAM QUOTE MEMKEY INPUT-STREAM ! 672 | VARIABLE OUTPUT-STREAM QUOTE UARTEMIT OUTPUT-STREAM ! 673 | : NKEY INPUT-STREAM @ EXECUTE ; 674 | : NEMIT OUTPUT-STREAM @ EXECUTE ; 675 | BACKPATCH NKEY KEY 676 | BACKPATCH NEMIT EMIT 677 | 678 | 679 | \ rewrite WORD to use the new KEY function 680 | : APPEND ( c addr -- ) DUP C++ DUP C@ + C! ; 681 | : DELETE ( addr -- ) DUP C@ 0> IF C-- THEN ; 682 | : CLEARSTR 0 SWAP C! ; 683 | : PUSHSTR DUP C@ SWAP 1+ SWAP ; 684 | : LENSTR C@ ; 685 | : CMP 2DUP = IF 0 ELSE > IF -1 ELSE 1 THEN THEN ; 686 | : CMPCHAR DUP C@ 2 PICK C@ CMP ; 687 | : 3DROP DROP DROP DROP ; 688 | : CMPSTR ( addr1 l1 addr2 l2 -- cmp ) ROT MIN BEGIN -ROT CMPCHAR DUP 0< IF 3DROP -1 EXIT THEN 0> IF 3DROP 1 EXIT THEN 689 | ROT DUP 0= SWAP 1- SWAP UNTIL 3DROP 0 ; 690 | : STRCMP PUSHSTR ROT PUSHSTR CMPSTR ; 691 | : TELLSTR PUSHSTR TELL ; 692 | : ISBLANK DUP BL = OVER '\n' = OR OVER '\t' = OR NIP ; 693 | : SKIPSPACE BEGIN KEY DUP ISBLANK NOT UNTIL ; 694 | 32 ALLOT CONSTANT WORDBUFFER# 695 | WORDBUFFER# 1+ CONSTANT WORDBUFFER 696 | : NWORD 697 | WORDBUFFER# CLEARSTR 698 | KEY DUP ISBLANK IF DROP SKIPSPACE THEN 699 | WORDBUFFER# APPEND 700 | BEGIN KEY DUP ISBLANK IF DROP TRUE ELSE WORDBUFFER# APPEND FALSE THEN UNTIL 701 | WORDBUFFER# PUSHSTR 702 | ; 703 | S" Preword" UARTLINE 704 | ( backpatch word to actually execute nword ) 705 | BACKPATCH NWORD WORD 706 | 707 | 708 | 709 | \ 16 CONSTANT HISTORY_LINES 710 | \ VARIABLE HISTORY_PTR 711 | \ : ALLOCATE_HISTORY_LINE 256 ALLOT ; 712 | \ 4 CONSTANT HISTORY_LINES 713 | \ HERE @ CONSTANT HISTORY_START ALLOCATE_HISTORY_LINE ALLOCATE_HISTORY_LINE ALLOCATE_HISTORY_LINE ALLOCATE_HISTORY_LINE 714 | \ make loop here 715 | \ : NEXT_HISTORY HISTORY_PTR 1+ DUP > HISTORY_LINES IF 0 THEN HISTORY_PTR ! ; 716 | \ : PREV_HISTORY HISTORY_PTR 1- DUP < 0 IF HISTORY_LINES 1- THEN HISTORY_PTR ! ; 717 | \ : HISTORY_BUF HISTORY_PTR @ 8 LSHIFT HISTORY_START + 718 | \ : COPY_HISTORY HISTORY_BUF TIB# 256 CMOVE ; 719 | \ : PUSH_HISTORY TIB# HISTORY_BUF 256 CMOVE ; 720 | 721 | S" INTIB" UARTLINE 722 | 256 BUFFER TIB# 723 | TIB# 1+ CONSTANT TIB 724 | VARIABLE TIB_CURSOR 725 | VARIABLE ESCAPE_STATE 726 | 0 ESCAPE_STATE ! 727 | 728 | VARIABLE >IN 0 >IN ! 729 | : CLEAR_TIB 0 TIB# C! 0 TIB_CURSOR ! 0 >IN ! ; 730 | : ECHO UARTKEY DUP EMIT ; 731 | : CURSOR_LEFT TIB_CURSOR C-- ; 732 | : CURSOR_RIGHT TIB_CURSOR C++ ; 733 | : BACKSPACE TIB# C@ 0> IF TIB# C-- CURSOR_LEFT ELSE 0 TIB# C! THEN ; 734 | : WRITE_CHAR TIB# APPEND CURSOR_RIGHT ; 735 | 736 | : NORMAL_CHAR DUP CASE 737 | ( not in an escape sequence ) 738 | BKSP OF EMIT BACKSPACE ENDOF 739 | ESC OF DROP 1 ESCAPE_STATE ! ENDOF 740 | ( -- default ) DUP EMIT WRITE_CHAR 741 | ENDCASE ; 742 | 743 | \ control characters are of the form 'ESC' '[' [value[;value]] 744 | 745 | \ buffer for ansi value field 746 | 32 BUFFER ESCAPE_BUF 747 | 748 | 749 | 750 | VARIABLE TABPTR 751 | : RESET_TAB LATEST @ TABPTR ! ; 752 | \ find first space character, moving rightwards 753 | : FIND_PREFIX TIB# C@ 1+ BEGIN 1- DUP TIB# + 1+ C@ ISBLANK OVER 0<= OR UNTIL DUP TIB# + SWAP TIB# C@ SWAP - ; 754 | : HANDLE_CURSOR 'A' = IF 'A' CURSOR_LEFT ESC EMIT '[' EMIT 'A' EMIT ELSE DROP THEN ; 755 | : CLEAR_ESCAPE 0 ESCAPE_STATE ! ; 756 | : TEST_ESCAPE DUP '[' = IF 2 ESCAPE_STATE ! ESCAPE_BUF CLEARSTR DROP ELSE CLEAR_ESCAPE NORMAL_CHAR THEN ; 757 | : ANSI_ESCAPE DUP ISLETTER OVER '~' = OR IF HANDLE_CURSOR CLEAR_ESCAPE ELSE ESCAPE_BUF APPEND THEN ; 758 | : ESCAPE_CHAR ESCAPE_STATE @ 2 = IF ANSI_ESCAPE ELSE TEST_ESCAPE THEN ; 759 | 760 | : IN_CHAR ESCAPE_STATE @ 0= IF NORMAL_CHAR ELSE ESCAPE_CHAR THEN ; 761 | : ACCEPT CLEAR_TIB BEGIN UARTKEY DUP IN_CHAR OVER = UNTIL DROP ; 762 | : READ_LINE NL ACCEPT ; 763 | 764 | : CHARAT ( addr ix -- c) + 1+ C@ ; 765 | : LINE_FLUSH_IN CLEAR_TIB ; 766 | 767 | 768 | 769 | 770 | : FLUSH_IN . ; \ backpatch this later 771 | : FLUSH_OUT . ; \ backpatch this later 772 | 773 | S" LINEKEY" UARTLINE 774 | ( make line buffered input the outer interpreter ) 775 | : LINE_KEY 776 | ( get some characters ) 777 | TIB# LENSTR 0= IF BEGIN READ_LINE TIB# LENSTR 0<> UNTIL 0 >IN ! THEN 778 | TIB# >IN @ CHARAT >IN @ 1+ >IN ! 779 | ( clear buffer at end of line ) 780 | >IN @ TIB# LENSTR >= IF CLEAR_TIB THEN 781 | ; 782 | 783 | \ left, right 784 | \ home, end 785 | \ ins/over 786 | \ up/down buffer 787 | \ tab completion 788 | 789 | S" STATUS" UARTLINE 790 | 791 | : STATUS ." HERE:0x" HERE @ .HEX ." LATEST:0x" LATEST @ .HEX 2 SPACES ." R0:0x" R0 .HEX ." RSP:0x" RSP@ .HEX 2 SPACES ." DSP:0x" DSP@ .HEX ." S0:0x" S0 @ .HEX CR ; 792 | 793 | : WELCOME ANSI_BLUE ANSI_BG ANSI_CLS ANSI_YELLOW ANSI_FG 794 | S" 795 | ____ _____ ____ ______ __ __ 796 | __ /\ _`\ /\ __`\/\ _`\ /\__ _\/\ \/\ \ 797 | ___ ___ /\_\ ___\ \ \L\_\ \ \/\ \ \ \L\ \/_/\ \/\ \ \_\ \ 798 | /' __` __`\/\ \ /' _ `\ \ _\/\ \ \ \ \ \ , / \ \ \ \ \ _ \ 799 | /\ \/\ \/\ \ \ \/\ \/\ \ \ \/ \ \ \_\ \ \ \\ \ \ \ \ \ \ \ \ \ 800 | \ \_\ \_\ \_\ \_\ \_\ \_\ \_\ \ \_____\ \_\ \_\ \ \_\ \ \_\ \_\ 801 | \/_/\/_/\/_/\/_/\/_/\/_/\/_/ \/_____/\/_/\/ / \/_/ \/_/\/_/ 802 | " TELL CR 803 | ." 0x" UNUSED . ." CELLS FREE" 804 | CR STATUS 805 | 806 | CR ." READY" 807 | CR 808 | DECIMAL 809 | ; 810 | 811 | 812 | 813 | 814 | 815 | \ experimental stuff 816 | 817 | ( signed division ) 818 | 819 | 820 | \ heap manipulation 821 | \ | SIZE | PREV | NEXT | REFC | TYPE | 822 | : H->SIZE 0 ; 823 | : H->PREV 4 + ; 824 | : H->NEXT 8 + ; 825 | : H->REFC 12 + ; 826 | : H->TYPE 16 + ; 827 | 828 | 20 CONSTANT HEADER_SIZE 829 | PAD 128 + CONSTANT HEAP_START 830 | 16# 1000000 CONSTANT HEAP_SIZE 831 | HEAP_SIZE VARIABLE: HEAP_AVAILABLE 832 | : !-> SWAP DUP -ROT ! 4+ ; 833 | : INIT_HEAP HEAP_START HEAP_SIZE !-> 0 !-> 0 !-> 0 !-> 0 !-> DROP ; 834 | : BLOCKFITS DUP H->TYPE @ 0= OVER H->SIZE @ > AND ; 835 | : BLOCKNEXT DUP H->NEXT @ 0= IF ." Memory exhausted" ABORT THEN ; 836 | \ : NEWBLOCK ( n ptr -- ) OVER HEADER_SIZE + SIZE @ !-> PREV @ !-> NEXT @ 0 !-> 0 !-> ; 837 | \ : FINDFREE ( n -- ptr ) HEAP_START BLOCKFITS NOT IF BEGIN BLOCKNEXT BLOCKFITS UNTIL ; 838 | : FREE ( ptr -- ) ; 839 | : REALLOC ( n -- ptr ) ; 840 | 841 | : S/MOD 842 | TUCK DUP 0< 843 | IF NEGATE TRUE ELSE FALSE THEN 844 | ROT 845 | DUP 0< IF NEGATE -ROT INVERT ELSE -ROT THEN -ROT /MOD ROT 846 | IF NEGATE 1- SWAP ROT SWAP - ELSE ROT DROP THEN ; 847 | 848 | 849 | 850 | 851 | 852 | : LOOPTEST 5 0 DO I . LOOP ; 853 | : IJLOOPTEST 5 0 DO 10 0 DO I . J . LOOP LOOP ; 854 | : +LOOPTEST 50 0 DO I . 5 +LOOP ; 855 | 856 | 857 | \ Framebuffer access (preliminary) 858 | : MKSTRUCT HERE @ CONSTANT ; 859 | : DW 1 CELLS ALLOT CONSTANT ; 860 | 861 | 4 NALIGN 862 | MKSTRUCT FRAMEBUFFER 863 | DW FB_PHYSICAL_WIDTH 864 | DW FB_PHYSICAL_HEIGHT 865 | DW FB_VIRTUAL_WIDTH 866 | DW FB_VIRTUAL_HEIGHT 867 | DW FB_PITCH 868 | DW FB_BIT_DEPTH 869 | DW FB_X 870 | DW FB_Y 871 | DW FB_PTR 872 | DW FB_SIZE 873 | 874 | 30 NTHBIT CONSTANT BIT30 875 | 876 | 16# 2000B880 CONSTANT MAILREAD_ADDR 877 | 16# 2000B890 CONSTANT MAILPOLL_ADDR 878 | 16# 2000B894 CONSTANT MAILSENDER_ADDR 879 | 16# 2000B898 CONSTANT MAILSTATUS_ADDR 880 | 16# 2000B89C CONSTANT MAILCONFIG_ADDR 881 | 16# 2000B89C CONSTANT MAILWRITE_ADDR 882 | 883 | : MAILWAIT_STATUS BEGIN MAILSTATUS_ADDR @ BIT30 AND 0= UNTIL ; 884 | : LOW4BITS 2# 1111 AND ; 885 | : MAILREAD ( mbox ) LOW4BITS BEGIN MAILWAIT_STATUS DUP MAILREAD_ADDR @ XOR DUP LOW4BITS 0= UNTIL 4 RSHIFT ; 886 | : MAILWRITE ( msg mbox -- ) MAILWAIT_STATUS SWAP 4 LSHIFT OR MAILWRITE_ADDR ! ; 887 | 888 | : MAPCHAR NEXTCHAR 3 PICK EXECUTE ROT DUP -ROT 1- C! SWAP ( xt addr len -- xt addr+1 len-1 ) ; 889 | : MAPSTR 2 PICK 2 PICK BEGIN MAPCHAR DUP 0= UNTIL DROP DROP DROP ( addr len xt -- addr len ) ; 890 | : +13 13 + ; 891 | : ROT13 QUOTE +13 MAPSTR ; 892 | 893 | ( N D Q R ) 894 | VARIABLE DIVD 895 | VARIABLE DIVN 896 | 897 | : DIVSTEP RSHIFT DIVN @ 1 AND OR DUP 4 PICK >= IF 2 PICK - SWAP 1 OR SWAP THEN ; 898 | : DIVI 899 | DIVN ! DIVD ! 900 | DIVD @ 0= IF ." Divide by zero" ABORT THEN 901 | 0 0 902 | 903 | DIVSTEP 904 | ; 905 | 906 | \ redirect input 907 | 908 | CLEAR_TIB LEDOFF WELCOME 909 | \ Everything after this line will not be seen! 910 | QUOTE LINE_KEY INPUT-STREAM ! 911 | 912 | 913 | 914 | \ ARM opcodes 915 | 916 | \ 0 VARIABLE OPC 917 | \ : ENUM 0 OPC ! BEGIN OPC @ CONSTANT OPC 1 +! 1- 0= UNTIL ; 918 | : ENUM{ BEGIN WORD 2DUP DROP C@ '}' <> WHILE REPEAT ; 919 | \ 16 ENUM{ EQ NE CS CC MI PL VS VC HI LS GE LT GT LE AL UNC } 920 | \ data processing opcodes 921 | \ 16 ENUM{ AND EOR SUB RSB ADD ADC SBC RSC TST TEQ CMP CMN ORR MOV BIC MVN } 922 | 923 | \ EQ R4 45 # 2 LSL ORR; 924 | \ R4 R0 2 ROR MOV; 925 | 926 | 927 | \ VARIABLE ASM.COND 928 | \ VARIABLE ASM.SHIFTER 929 | \ VARIABLE ASM.Rn 930 | \ VARIABLE ASM.Rd 931 | \ VARIABLE ASM.# 932 | 933 | 934 | 935 | 936 | \ TODO 937 | \ line editor 938 | \ ?do / LEAVE / UNLOOP 939 | \ clear / cmove / fill / blank 940 | \ make word names indirect : | FLAGS | STRPTR | CFA | | CODE ... 941 | \ namespaces 942 | \ debugger 943 | \ toupper / tolower 944 | \ strcompare 945 | \ make quotations work in compile mode 946 | \ mmc 947 | \ xmodem transfer 948 | \ signed division 949 | \ inline / code 950 | \ locals 951 | \ framebuffer 952 | \ fixed point: */ .FX / SIN.COS / SQRT / EXP 953 | \ live syntax highlighting / tab completion 954 | \ alloc / free / resize 955 | \ structs, lists 956 | \ inline / unthread / unthread-fully / denext 957 | 958 | 959 | 960 | 961 | 962 | -------------------------------------------------------------------------------- /jonesforth.s: -------------------------------------------------------------------------------- 1 | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 2 | @ 3 | @ pijFORTHos -- Raspberry Pi JonesFORTH Operating System 4 | @ 5 | @ A bare-metal FORTH operating system for Raspberry Pi 6 | @ Copyright (C) 2014 Dale Schumacher and Tristan Slominski 7 | @ 8 | @ based on Jones' Forth port for ARM EABI 9 | @ Copyright (C) 2013 M2IHP'13 class 10 | @ 11 | @ Original x86 and FORTH code: Richard W.M. Jones 12 | @ 13 | @ See AUTHORS for the full list of contributors. 14 | @ 15 | @ The extensive comments from Jones' x86 version have been removed. You should 16 | @ check them out, they are really detailed, well written and pedagogical. 17 | @ The original sources (with full comments) are in the /annexia/ directory. 18 | @ 19 | @ DIVMOD routine taken from the ARM Software Development Toolkit User Guide 2.50 20 | @ 21 | @ This program is free software: you can redistribute it and/or modify it under 22 | @ the terms of the GNU Lesser General Public License as published by the Free 23 | @ Software Foundation, either version 3 of the License, or (at your option) any 24 | @ later version. 25 | @ 26 | @ This program is distributed in the hope that it will be useful, but WITHOUT 27 | @ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 28 | @ FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more 29 | @ details. 30 | @ 31 | @ You should have received a copy of the GNU Lesser General Public License 32 | @ along with this program. If not, see . 33 | @ 34 | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 35 | 36 | .set JONES_VERSION,48 37 | 38 | @ Reserve three special registers: 39 | @ DSP (r13) points to the top of the data stack 40 | @ RSP (r11) points to the top of the return stack 41 | @ FIP (r10) points to the next FORTH word that will be executed 42 | @ Note: r12 is often considered a "scratch" register 43 | 44 | DSP .req r13 45 | RSP .req r11 46 | FIP .req r10 47 | 48 | @ Define macros to push and pop from the data and return stacks 49 | 50 | .macro PUSHRSP reg 51 | str \reg, [RSP, #-4]! 52 | .endm 53 | 54 | .macro POPRSP reg 55 | ldr \reg, [RSP], #4 56 | .endm 57 | 58 | .macro PUSHDSP reg 59 | str \reg, [DSP, #-4]! 60 | .endm 61 | 62 | .macro POPDSP reg 63 | ldr \reg, [DSP], #4 64 | .endm 65 | 66 | .macro PUSH2 reg 67 | stmdb \reg!, {r0-r1} @ ( -- r1 r0 ) 68 | .endm 69 | 70 | .macro POP2 reg 71 | ldmia \reg!, {r0-r1} @ ( r1 r0 -- ) 72 | .endm 73 | 74 | .macro PUSH3 reg 75 | stmdb \reg!, {r0-r2} @ ( -- r2 r1 r0 ) 76 | .endm 77 | 78 | .macro POP3 reg 79 | ldmia \reg!, {r0-r2} @ ( r2 r1 r0 -- ) 80 | .endm 81 | 82 | 83 | @ _NEXT is the assembly subroutine that is called 84 | @ at the end of every FORTH word execution. 85 | @ The NEXT macro is defined to simply call _NEXT 86 | .macro NEXT 87 | b _NEXT 88 | .endm 89 | 90 | @ jonesforth is the entry point for the FORTH environment 91 | .text 92 | .align 2 @ alignment 2^n (2^2 = 4 byte alignment) 93 | .global _start 94 | 95 | reset: 96 | @ relocation code 97 | sub r1, pc, #8 @ Where are we? 98 | mov sp, r1 @ Bootstrap stack immediately before _start 99 | ldr r0, =0x8000 @ Absolute address of kernel memory 100 | cmp r0, r1 @ Are we loaded where we expect to be? 101 | beq no_relocate @ Then, jump to kernel entry-point 102 | mov lr, r0 @ Otherwise, relocate ourselves 103 | ldr r2, =0x7F00 @ Copy (32k - 256) bytes 104 | 1: ldmia r1!, {r3-r10} @ Read 8 words 105 | stmia r0!, {r3-r10} @ Write 8 words 106 | subs r2, #32 @ Decrement len 107 | bgt 1b @ More to copy? 108 | bx lr @ Return to our relocated selves! 109 | no_relocate: 110 | ldr r0, =0x8000 @ load the start address 111 | 112 | jonesforth: 113 | ldr r0, =var_S0 114 | str DSP, [r0] @ Save the original stack position in S0 115 | ldr RSP, =return_stack_top @ Set the initial return stack position 116 | ldr r0, =data_segment @ Get the initial data segment address 117 | ldr r1, =var_HERE @ Initialize HERE to point at 118 | str r0, [r1] @ the beginning of data segment 119 | ldr FIP, =cold_start @ Make the FIP point to cold_start 120 | NEXT @ Start the interpreter 121 | 122 | @ _DOCOL is the assembly subroutine that is called 123 | @ at the start of every FORTH word execution, which: 124 | @ 0. expects the CFA of a FORTH word in r0 125 | @ 1. saves the old FIP on the return stack 126 | @ 2. makes FIP point to the DFA (first codeword) 127 | @ 3. uses _NEXT to start interpreting the word 128 | _DOCOL: 129 | PUSHRSP FIP 130 | add FIP, r0, #4 131 | 132 | @ _NEXT is the assembly subroutine that is called 133 | @ at the end of every FORTH word execution, which: 134 | @ 1. finds the CFA of the FORTH word to execute 135 | @ by dereferencing the FIP 136 | @ 2. increments FIP 137 | @ 3. begins executing the routine pointed to 138 | @ by the CFA, with the CFA in r0 139 | _NEXT: 140 | ldr r0, [FIP], #4 141 | ldr r1, [r0] 142 | bx r1 143 | 144 | @ cold_start is used to bootstrap the interpreter, 145 | @ the first word executed is QUIT 146 | .section .rodata 147 | cold_start: 148 | .int QUIT 149 | 150 | 151 | @@ Now we define a set of helper macros that are syntactic sugar 152 | @@ to ease the declaration of FORTH words, Native words, FORTH variables 153 | @@ and FORTH constants. 154 | 155 | @ define the word flags 156 | .set F_IMM, 0x80 157 | .set F_HID, 0x20 158 | .set F_LEN, 0x1f 159 | 160 | @ link is used to chain the words in the dictionary as they are defined 161 | .set link, 0 162 | 163 | @ defword macro helps defining new FORTH words in assembly 164 | .macro defword name, namelen, flags=0, label 165 | .section .rodata 166 | .align 2 167 | .global name_\label 168 | name_\label : 169 | .int link @ link 170 | .set link,name_\label 171 | .byte \flags+\namelen @ flags + length byte 172 | .ascii "\name" @ the name 173 | .align 2 @ padding to next 4 byte boundary 174 | .global \label 175 | \label : 176 | .int _DOCOL @ codeword - the interpreter 177 | @ list of word pointers follow 178 | .endm 179 | 180 | @ defcode macro helps defining new native words in assembly 181 | .macro defcode name, namelen, flags=0, label 182 | .section .rodata 183 | .align 2 184 | .globl name_\label 185 | name_\label : 186 | .int link @ link 187 | .set link,name_\label 188 | .byte \flags+\namelen @ flags + length byte 189 | .ascii "\name" @ the name 190 | .align 2 @ padding to next 4 byte boundary 191 | .global \label 192 | \label : 193 | .int code_\label @ codeword 194 | .text 195 | .global code_\label 196 | code_\label : @ assembler code follows 197 | .endm 198 | 199 | @ EXIT is the last codeword of a FORTH word. 200 | @ It restores the FIP and returns to the caller using NEXT. 201 | @ (See _DOCOL) 202 | defcode "EXIT",4,,EXIT 203 | POPRSP FIP 204 | NEXT 205 | 206 | 207 | 208 | @ defvar macro helps defining FORTH variables in assembly 209 | .macro defvar name, namelen, flags=0, label, initial=0 210 | defcode \name,\namelen,\flags,\label 211 | ldr r0, =var_\name 212 | PUSHDSP r0 213 | NEXT 214 | .data 215 | .align 2 216 | .global var_\name 217 | var_\name : 218 | .int \initial 219 | .endm 220 | 221 | @ The built-in variables are: 222 | @ STATE Is the interpreter executing code (0) or compiling a word (non-zero)? 223 | defvar "STATE",5,,STATE 224 | @ HERE Points to the next free byte of memory. When compiling, compiled words go here. 225 | defvar "HERE",4,,HERE 226 | @ LATEST Points to the latest (most recently defined) word in the dictionary. 227 | defvar "LATEST",6,,LATEST,name_EXECUTE @ The last word defined in assembly is EXECUTE 228 | @ S0 Stores the address of the top of the parameter stack. 229 | defvar "S0",2,,S0 230 | @ BASE The current base for printing and reading numbers. 231 | defvar "BASE",4,,BASE,10 232 | 233 | @ defconst macro helps defining FORTH constants in assembly 234 | .macro defconst name, namelen, flags=0, label, value 235 | defcode \name,\namelen,\flags,\label 236 | ldr r0, =\value 237 | PUSHDSP r0 238 | NEXT 239 | .endm 240 | 241 | @ The built-in constants are: 242 | @ VERSION Is the current version of this FORTH. 243 | defconst "VERSION",7,,VERSION,JONES_VERSION 244 | @ R0 The address of the top of the return stack. 245 | defconst "R0",2,,R0,return_stack_top 246 | @ DOCOL Pointer to _DOCOL. 247 | defconst "DOCOL",5,,DOCOL,_DOCOL 248 | @ PAD Pointer to scratch-pad buffer. 249 | defconst "PAD",3,,PAD,scratch_pad 250 | @ MEMTOP Pointer to the start of the heap 251 | defconst "MEMTOP",6,,MEMTOP,scratch_pad_top 252 | @ F_IMMED The IMMEDIATE flag's actual value. 253 | defconst "F_IMMED",7,,F_IMMED,F_IMM 254 | @ F_HIDDEN The HIDDEN flag's actual value. 255 | defconst "F_HIDDEN",8,,F_HIDDEN,F_HID 256 | @ F_LENMASK The length mask in the flags/len byte. 257 | defconst "F_LENMASK",9,,F_LENMASK,F_LEN 258 | @ 1 itself (since we can't parse numbers yet!) 259 | defconst "1",1,,ONE,1 260 | 261 | 262 | @ SWAP ( a b -- b a ) swaps the two top elements 263 | defcode "SWAP",4,,SWAP 264 | POP2 DSP @ ( ), r1 = a, r0 = b 265 | PUSHDSP r0 @ ( b ), r1 = a, r0 = b 266 | PUSHDSP r1 @ ( b a ), r1 = a, r0 = b 267 | NEXT 268 | 269 | 270 | @ ROT ( a b c -- b c a ) rotation 271 | defcode "ROT",3,,ROT 272 | POPDSP r1 @ ( a b ), r1 = c 273 | POPDSP r2 @ ( a ), r2 = b 274 | POPDSP r0 @ ( ), r0 = a 275 | PUSH3 DSP @ ( b c a ), r2 = b, r1 = c, r0 = a 276 | NEXT 277 | 278 | @ -ROT ( a b c -- c a b ) backwards rotation 279 | defcode "-ROT",4,,NROT 280 | POP3 DSP @ ( ), r2 = a, r1 = b, r0 = c 281 | PUSHDSP r0 @ ( c ) 282 | PUSHDSP r2 @ ( c a ) 283 | PUSHDSP r1 @ ( c a b ) 284 | NEXT 285 | 286 | 287 | @ + ( a b -- a+b ) 288 | defcode "+",1,,ADD 289 | POP2 DSP @ ( ), r1 = a, r0 = b 290 | add r0, r0, r1 291 | PUSHDSP r0 292 | NEXT 293 | 294 | @ - ( a b -- a-b ) 295 | defcode "-",1,,SUB 296 | POP2 DSP @ ( ), r1 = a, r0 = b 297 | sub r0, r1, r0 298 | PUSHDSP r0 299 | NEXT 300 | 301 | @ LSHIFT ( a b -- a<>b ) 309 | defcode "RSHIFT",6,,RSHIFT 310 | POP2 DSP @ ( ), r1 = a, r0 = b 311 | mov r0, r1, LSR r0 312 | PUSHDSP r0 313 | NEXT 314 | 315 | @ * ( a b -- a*b ) 316 | defcode "*",1,,MUL 317 | POP2 DSP @ ( ), r1 = a, r0 = b 318 | mul r2, r1, r0 319 | PUSHDSP r2 320 | NEXT 321 | 322 | @ = ( a b -- p ) where p is 1 when a and b are equal (0 otherwise) 323 | defcode "=",1,,EQ 324 | POP2 DSP @ ( ), r1 = a, r0 = b 325 | cmp r1, r0 326 | mvneq r0, #0 327 | movne r0, #0 328 | PUSHDSP r0 329 | NEXT 330 | 331 | @ < ( a b -- p ) where p = a < b 332 | defcode "<",1,,LT 333 | POP2 DSP @ ( ), r1 = a, r0 = b 334 | cmp r1, r0 335 | mvnlt r0, #0 336 | movge r0, #0 337 | PUSHDSP r0 338 | NEXT 339 | 340 | @ > ( a b -- p ) where p = a < b 341 | defcode ">",1,,GT 342 | POP2 DSP @ ( ), r1 = a, r0 = b 343 | cmp r1, r0 344 | mvngt r0, #0 345 | movle r0, #0 346 | PUSHDSP r0 347 | NEXT 348 | 349 | @ AND ( a b -- a&b ) bitwise and 350 | defcode "AND",3,,AND 351 | POP2 DSP @ ( ), r1 = a, r0 = b 352 | and r0, r1, r0 353 | PUSHDSP r0 354 | NEXT 355 | 356 | @ OR ( a b -- a|b ) bitwise or 357 | defcode "OR",2,,OR 358 | POP2 DSP @ ( ), r1 = a, r0 = b 359 | orr r0, r1, r0 360 | PUSHDSP r0 361 | NEXT 362 | 363 | @ XOR ( a b -- a^b ) bitwise xor 364 | defcode "XOR",3,,XOR 365 | POP2 DSP @ ( ), r1 = a, r0 = b 366 | eor r0, r1, r0 367 | PUSHDSP r0 368 | NEXT 369 | 370 | 371 | @ CMOVE ( source dest length -- ) copy length bytes from source to dest 372 | defcode "CMOVE",5,,CMOVE 373 | POP3 DSP @ ( ), r2 = source, r1 = dest, r0 = length 374 | cmp r2, r1 @ account for potential overlap 375 | bge 2f @ copy forward if s >= d, backward otherwise 376 | sub r3, r0, #1 @ (length - 1) 377 | add r2, r3 @ end of source 378 | add r1, r3 @ end of dest 379 | 1: 380 | cmp r0, #0 @ while length > 0 381 | ble 3f 382 | ldrb r3, [r2], #-1 @ read character from source 383 | strb r3, [r1], #-1 @ and write it to dest (decrement both pointers) 384 | sub r0, r0, #1 @ decrement length 385 | b 1b 386 | 2: 387 | cmp r0, #0 @ while length > 0 388 | ble 3f 389 | ldrb r3, [r2], #1 @ read character from source 390 | strb r3, [r1], #1 @ and write it to dest (increment both pointers) 391 | sub r0, r0, #1 @ decrement length 392 | b 2b 393 | 3: 394 | NEXT 395 | 396 | @ FILL ( dest length byte -- ) 397 | defcode "FILL",4,,FILL 398 | POP3 DSP @ r2 = dest, r1=len, r0=byte 399 | _fill: 400 | strb r0, [r2] 401 | add r2, #1 402 | subs r1, #1 403 | bgt _fill 404 | NEXT 405 | 406 | 407 | @ LIT is used to compile literals in FORTH word. 408 | @ When LIT is executed it pushes the literal (which is the next codeword) 409 | @ into the stack and skips it (since the literal is not executable). 410 | defcode "LIT", 3,, LIT 411 | ldr r1, [FIP], #4 412 | PUSHDSP r1 413 | NEXT 414 | 415 | @ ! ( value address -- ) write value at address 416 | defcode "!",1,,STORE 417 | POP2 DSP @ ( ), r1 = value, r0 = address 418 | str r1, [r0] 419 | NEXT 420 | 421 | @ @ ( address -- value ) reads value from address 422 | defcode "@",1,,FETCH 423 | POPDSP r1 424 | ldr r0, [r1] 425 | PUSHDSP r0 426 | NEXT 427 | 428 | 429 | @ C! ( c addr -- ) write byte c at addr 430 | defcode "C!",2,,STOREBYTE 431 | POP2 DSP @ ( ), r1 = c, r0 = addr 432 | strb r1, [r0] 433 | NEXT 434 | 435 | @ C@ ( addr -- c ) read byte from addr 436 | defcode "C@",2,,FETCHBYTE 437 | POPDSP r1 438 | ldrb r0, [r1] 439 | PUSHDSP r0 440 | NEXT 441 | 442 | 443 | @ >R ( a -- ) move the top element from the data stack to the return stack 444 | defcode ">R",2,,TOR 445 | POPDSP r0 446 | PUSHRSP r0 447 | NEXT 448 | 449 | @ R> ( -- a ) move the top element from the return stack to the data stack 450 | defcode "R>",2,,FROMR 451 | POPRSP r0 452 | PUSHDSP r0 453 | NEXT 454 | 455 | @ RSP@, RSP!, DSP@, DSP! manipulate the return and data stack pointers 456 | 457 | defcode "RSP@",4,,RSPFETCH 458 | PUSHDSP RSP 459 | NEXT 460 | 461 | defcode "RSP!",4,,RSPSTORE 462 | POPDSP RSP 463 | NEXT 464 | 465 | defcode "DSP@",4,,DSPFETCH 466 | mov r0, DSP 467 | PUSHDSP r0 468 | NEXT 469 | 470 | defcode "DSP!",4,,DSPSTORE 471 | POPDSP r0 472 | mov DSP, r0 473 | NEXT 474 | 475 | defcode "FIP@",4,,FIPFETCH 476 | mov r0, FIP 477 | PUSHDSP r0 478 | NEXT 479 | 480 | defcode "FIP!",4,,FIPSTORE 481 | POPDSP r0 482 | mov FIP, r0 483 | NEXT 484 | 485 | defcode "HASH",4,,HASH 486 | POPDSP r1 487 | POPDSP r0 488 | bl murmur_hash 489 | PUSHDSP r0 490 | NEXT 491 | 492 | @ Compute the murmur3 hash of a string. 493 | @ string in r0, len in r1, return in r0 494 | .globl murmur_hash 495 | murmur_hash: 496 | ldr r6, =0xcc9e2d51 497 | ldr r7, =0x1b873593 498 | ldr r8, =0xe6546b64 499 | ldr r5, =0 @ hash 500 | push {r1} 501 | 502 | block_loop: 503 | ldr r2, [r0] @ k = blocks[i] 504 | add r0, #4 505 | sub r1, #4 506 | mul r2, r6 @ *= c1 507 | mov r2, r2, ROR #32-15 @ rotl(k, 15) 508 | mul r2, r7 @ *=c2 509 | eor r5, r2 @ hash ^ = k 510 | mov r5, r5, ROR #32-13 @ hash = rotl(hash, 13) 511 | ldr r4, =5 @ hash = hash * m + n 512 | mul r5, r4 513 | add r5, r8 514 | cmp r1, #3 @ loop if not finished 515 | bgt block_loop 516 | 517 | @ r1 is left over characters 518 | cmp r1, #0 519 | beq finalise @ can finalise if len%4==0 520 | ldr r2, [r0] 521 | cmp r1, #3 522 | andeq r2, #0x00ffffff @ hash the tail 523 | cmp r1, #2 524 | ldr r3, =0x0000ffff 525 | andeq r2, r3 526 | cmp r1, #1 527 | andeq r2, #0x000000ff 528 | mul r2, r6 @ *= c1 529 | mov r2, r2, ROR #32-15 @ rotl(k, 15) 530 | mul r2, r7 @ *=c2 531 | eor r5, r2 @ hash ^ = k 532 | 533 | finalise: 534 | pop {r1} 535 | eor r5, r1 536 | eor r5, r5, LSR #16 537 | ldr r0, =0x085ebca6b 538 | mul r5, r0 539 | eor r5, r5, LSR #13 540 | ldr r0, =0xc2b2ae35 541 | mul r5, r0 542 | eor r5, r5, LSR #16 543 | mov r0, r5 @ return hash 544 | bx lr 545 | 546 | 547 | @ hash a 32 bit integer 548 | defcode "HASHINT",7,,HASHINT 549 | ldr r1, =4 550 | POPDSP r5 551 | bl finalise 552 | PUSHDSP r0 553 | NEXT 554 | 555 | 556 | @ MEMKEY ( -- c ) Read the next character from the built in source buffer 557 | defcode "MEMKEY",6,,MEMKEY 558 | bl _MEMKEY 559 | PUSHDSP r0 560 | NEXT 561 | @ read one character from the pre-loaded source 562 | _MEMKEY: 563 | ldr r1, =srcptr 564 | ldr r2, [r1] 565 | ldrb r0, [r2] 566 | add r2, #1 567 | str r2, [r1] 568 | bx lr 569 | .data 570 | .align 2 571 | .global srcptr 572 | srcptr: .int _binary_jonesforth_f_start 573 | 574 | 575 | @ WORD ( -- addr length ) reads next word from stdin 576 | @ skips spaces, control-characters and comments, limited to 32 characters 577 | defcode "MEMWORD",7,,MEMWORD 578 | bl _WORD 579 | PUSHDSP r0 @ address 580 | PUSHDSP r1 @ length 581 | NEXT 582 | _WORD: 583 | stmfd sp!, {r6,lr} @ preserve r6 and lr 584 | 1: 585 | bl _MEMKEY @ read a character 586 | cmp r0, #' ' 587 | ble 1b @ skip blank character 588 | 589 | ldr r6, =word_buffer 590 | 2: 591 | strb r0, [r6], #1 @ store character in word buffer 592 | bl _MEMKEY @ read more characters until a space is found 593 | cmp r0, #' ' 594 | bgt 2b 595 | 596 | ldr r0, =word_buffer @ r0, address of word 597 | sub r1, r6, r0 @ r1, length of word 598 | 599 | ldmfd sp!, {r6,lr} @ restore r6 and lr 600 | bx lr 601 | 602 | @ word_buffer for WORD 603 | .data 604 | .align 5 @ align to cache-line size 605 | word_buffer: 606 | .space 32 @ FIXME: what about overflow!? 607 | .int 0 608 | word_length: 609 | .space 1 610 | 611 | 612 | 613 | 614 | @ FIND ( addr length -- dictionary_address ) 615 | @ Tries to find a word in the dictionary and returns its address. 616 | @ If the word is not found, NULL is returned. 617 | defcode "FIND",4,,FIND 618 | POPDSP r1 @ length 619 | POPDSP r0 @ addr 620 | bl _FIND 621 | PUSHDSP r0 622 | NEXT 623 | 624 | _FIND: 625 | stmfd sp!, {r5,r6,r8,r9} @ save callee save registers 626 | ldr r2, =var_LATEST 627 | ldr r3, [r2] @ get the last defined word address 628 | 1: 629 | cmp r3, #0 @ did we check all the words ? 630 | beq 4f @ then exit 631 | 632 | ldrb r2, [r3, #4] @ read the length field 633 | and r2, r2, #(F_HID|F_LEN) @ keep only length + hidden bits 634 | cmp r2, r1 @ do the lengths match ? 635 | @ (note that if a word is hidden, 636 | @ the test will be always negative) 637 | bne 3f @ branch if they do not match 638 | @ Now we compare strings characters 639 | mov r5, r0 @ r5 contains searched string 640 | mov r6, r3 @ r6 contains dict string 641 | add r6, r6, #5 @ (we skip link and length fields) 642 | @ r2 contains the length 643 | 644 | 2: 645 | ldrb r8, [r5], #1 @ compare character per character 646 | ldrb r9, [r6], #1 647 | cmp r8,r9 648 | bne 3f @ if they do not match, branch to 3 649 | subs r2,r2,#1 @ decrement length 650 | bne 2b @ loop 651 | 652 | @ here, strings are equal 653 | b 4f @ branch to 4 654 | 655 | 3: 656 | ldr r3, [r3] @ Mismatch, follow link to the next 657 | b 1b @ dictionary word 658 | 4: 659 | mov r0, r3 @ move result to r0 660 | ldmfd sp!, {r5,r6,r8,r9} @ restore callee save registers 661 | bx lr 662 | 663 | @ >CFA ( dictionary_address -- executable_address ) 664 | @ Transformat a dictionary address into a code field address 665 | defcode ">CFA",4,,TCFA 666 | POPDSP r0 667 | bl _TCFA 668 | PUSHDSP r0 669 | NEXT 670 | 671 | _TCFA: 672 | add r0,r0,#4 @ skip link field 673 | ldrb r1, [r0], #1 @ load and skip the length field 674 | and r1,r1,#F_LEN @ keep only the length 675 | add r0,r0,r1 @ skip the name field 676 | add r0,r0,#3 @ find the next 4-byte boundary 677 | and r0,r0,#~3 678 | bx lr 679 | 680 | @ >DFA ( dictionary_address -- data_field_address ) 681 | @ Return the address of the first data field 682 | 683 | @ CREATE ( address length -- ) Creates a new dictionary entry 684 | @ in the data segment. 685 | defcode "CREATE",6,,CREATE 686 | POPDSP r1 @ length of the word to insert into the dictionnary 687 | POPDSP r0 @ address of the word to insert into the dictionnary 688 | 689 | ldr r2,=var_HERE 690 | ldr r3,[r2] @ load into r3 and r8 the location of the header 691 | mov r8,r3 692 | 693 | ldr r4,=var_LATEST 694 | ldr r5,[r4] @ load into r5 the link pointer 695 | str r5,[r3] @ store link here -> last 696 | add r3,r3,#4 @ skip link adress 697 | strb r1,[r3] @ store the length of the word 698 | add r3,r3,#1 @ skip the length adress 699 | mov r7,#0 @ initialize the incrementation 700 | 701 | 1: 702 | cmp r7,r1 @ if the word is completley read 703 | beq 2f 704 | ldrb r6,[r0,r7] @ read and store a character 705 | strb r6,[r3,r7] 706 | add r7,r7,#1 @ ready to read the next character 707 | b 1b 708 | 2: 709 | add r3,r3,r7 @ skip the word 710 | add r3,r3,#3 @ align to next 4 byte boundary 711 | and r3,r3,#~3 712 | str r8,[r4] @ update LATEST and HERE 713 | str r3,[r2] 714 | NEXT 715 | 716 | 717 | @ , ( n -- ) writes the top element from the stack at HERE 718 | defcode ",",1,,COMMA 719 | POPDSP r0 720 | bl _COMMA 721 | NEXT 722 | _COMMA: 723 | ldr r1, =var_HERE 724 | ldr r2, [r1] @ read HERE 725 | str r0, [r2], #4 @ write value and increment address 726 | str r2, [r1] @ update HERE 727 | bx lr 728 | 729 | @ [ ( -- ) Change interpreter state to Immediate mode 730 | defcode "[[",2,F_IMM,LBRAC 731 | ldr r0, =var_STATE 732 | mov r1, #0 @ FALSE 733 | str r1, [r0] 734 | NEXT 735 | 736 | @ ] ( -- ) Change interpreter state to Compilation mode 737 | defcode "]]",2,,RBRAC 738 | ldr r0, =var_STATE 739 | mvn r1, #0 @ TRUE 740 | str r1, [r0] 741 | NEXT 742 | 743 | defcode "SOURCE",6,,SOURCE 744 | ldr r0, =_binary_jonesforth_f_start 745 | PUSHDSP r0 746 | ldr r0, =_binary_jonesforth_f_size 747 | PUSHDSP r0 748 | NEXT 749 | 750 | defword "EMIT",4,,EMIT 751 | .int EXIT 752 | .int EXIT 753 | 754 | defword "KEY",3,,KEY 755 | .int MEMKEY 756 | .int EXIT 757 | 758 | defword "WORD",4,,WORD 759 | .int MEMWORD 760 | .int EXIT 761 | 762 | @ : word ( -- ) Define a new FORTH word 763 | @ : : WORD CREATE DOCOL , ] ; 764 | defword ":",1,,COLON 765 | .int WORD @ Get the name of the new word 766 | .int CREATE @ CREATE the dictionary entry / header 767 | .int DOCOL, COMMA @ Append DOCOL (the codeword). 768 | .int RBRAC @ Go into compile mode. 769 | .int EXIT @ Return from the function. 770 | 771 | @ : ; IMMEDIATE LIT EXIT , [ ; 772 | defword ";",1,F_IMM,SEMICOLON 773 | .int LIT, EXIT, COMMA @ Append EXIT (so the word will return). 774 | .int LBRAC @ Go back to IMMEDIATE mode. 775 | .int EXIT @ Return from the function. 776 | 777 | 778 | @ ' ( -- ) returns the codeword address of next read word 779 | @ only works in compile mode. Implementation is identical to LIT. 780 | defcode "'",1,,TICK 781 | ldr r1, [FIP], #4 782 | PUSHDSP r1 783 | NEXT 784 | 785 | @ BRANCH ( -- ) changes FIP by offset which is found in the next codeword 786 | defcode "BRANCH",6,,BRANCH 787 | ldr r1, [FIP] 788 | add FIP, FIP, r1 789 | NEXT 790 | 791 | @ 0BRANCH ( p -- ) branch if the top of the stack is zero 792 | defcode "0BRANCH",7,,ZBRANCH 793 | POPDSP r0 794 | cmp r0, #0 @ if the top of the stack is zero 795 | beq code_BRANCH @ then branch 796 | add FIP, FIP, #4 @ else, skip the offset 797 | NEXT 798 | 799 | @ LITS as LIT but for strings 800 | defcode "LITS",4,,LITS 801 | ldr r0, [FIP], #4 @ read length 802 | PUSHDSP FIP @ push address 803 | PUSHDSP r0 @ push string 804 | add FIP, FIP, r0 @ skip the string 805 | add FIP, FIP, #3 @ find the next 4-byte boundary 806 | and FIP, FIP, #~3 807 | NEXT 808 | 809 | 810 | @ DIVMOD computes the unsigned integer division and remainder 811 | @ The implementation is based upon the algorithm extracted from 'ARM Software 812 | @ Development Toolkit User Guide v2.50' published by ARM in 1997-1998 813 | @ The algorithm is split in two steps: search the biggest divisor b^(2^n) 814 | @ lesser than a and then subtract it and all b^(2^i) (for i from 0 to n) 815 | @ to a. 816 | @ ( a b -- r q ) where a = q * b + r 817 | defcode "/MOD",4,,DIVMOD 818 | POPDSP r1 @ Get b 819 | POPDSP r0 @ Get a 820 | bl _DIVMOD 821 | PUSHDSP r0 @ Put r 822 | PUSHDSP r2 @ Put q 823 | NEXT 824 | 825 | @ on entry r0=numerator r1=denominator 826 | @ on exit r0=remainder r1=denominator r2=quotient 827 | _DIVMOD: @ Integer Divide/Modulus 828 | mov r3, r1 @ Put b in tmp 829 | 830 | cmp r3, r0, LSR #1 831 | 1: movls r3, r3, LSL #1 @ Double tmp 832 | cmp r3, r0, LSR #1 833 | bls 1b @ Jump until 2 * tmp > a 834 | 835 | mov r2, #0 @ Initialize q 836 | 837 | 2: cmp r0, r3 @ If a - tmp > 0 838 | subcs r0, r0, r3 @ a <= a - tmp 839 | adc r2, r2, r2 @ Increment q 840 | mov r3, r3, LSR #1 @ Halve tmp 841 | cmp r3, r1 @ Jump until tmp < b 842 | bhs 2b 843 | 844 | bx lr 845 | 846 | @ QUIT ( -- ) the first word to be executed 847 | defword "QUIT", 4,, QUIT 848 | .int INTERPRET @ Interpret a word 849 | .int BRANCH,-8 @ LOOP FOREVER 850 | 851 | @ INTERPRET, reads a word from stdin and executes or compiles it. 852 | @ No need to backup callee save registers here, 853 | @ since we are the top level routine! 854 | defcode "INTERPRET",9,,INTERPRET 855 | 7: 856 | bl _WORD @ read a word from stdin 857 | mov r4, r0 @ store it in r4,r5 858 | mov r5, r1 859 | 860 | bl _FIND @ find its dictionary entry 861 | cmp r0, #0 @ if not found go to 6 862 | beq 6f 863 | 864 | @ Here the entry is found 865 | ldrb r6, [r0, #4] @ read length and flags field 866 | bl _TCFA @ find code field address 867 | tst r6, #F_IMM @ if the word is immediate 868 | bne 4f @ branch to 4 (execute) 869 | b 2f @ otherwise, branch to 2 870 | 871 | 2: @ Compiling or Executing 872 | ldr r1, =var_STATE @ Are we compiling or executing ? 873 | ldr r1, [r1] 874 | cmp r1, #0 875 | beq 4f @ Go to 4 if in interpret mode 876 | 877 | @ Here in compile mode 878 | bl _COMMA @ Call comma to compile the codeword 879 | NEXT 880 | 881 | 4: @ Executing 882 | ldr r1, [r0] @ (it's important here that 883 | bx r1 @ FIP address in r0, since _DOCOL 884 | @ assumes it) 885 | 6: @ Parse error 886 | @ just ignore it; must *NEVER* happen before we've established the new interpreter 887 | NEXT 888 | 889 | 890 | @ EXECUTE ( xt -- ) jump to the address on the stack 891 | @-- WARNING! THIS MUST BE THE LAST WORD DEFINED IN ASSEMBLY (see LATEST) --@ 892 | defcode "EXECUTE",7,,EXECUTE 893 | POPDSP r0 894 | ldr r1, [r0] 895 | bx r1 896 | 897 | @ Reserve space for the return stack (1Kb) 898 | .bss 899 | .align 5 @ align to cache-line size 900 | .set RETURN_STACK_SIZE, 0x400 901 | return_stack: 902 | .space RETURN_STACK_SIZE 903 | return_stack_top: 904 | 905 | @ Reserve space for the return stack (1Kb) 906 | .bss 907 | .align 5 @ align to cache-line size 908 | .set STRING_TABLE_SIZE, 0x8000 909 | .set STRING_TABLE_MASK, 0x7fff 910 | string_table: 911 | .space STRING_TABLE_SIZE 912 | string_table_end: 913 | 914 | 915 | @ Reserve space for new words and data structures (16Mb) 916 | .bss 917 | .align 5 @ align to cache-line size 918 | .set DATA_SEGMENT_SIZE, 0x1000000 919 | data_segment: 920 | .space DATA_SEGMENT_SIZE 921 | data_segment_top: 922 | 923 | @ Reserve space for scratch-pad buffer (128b) 924 | .bss 925 | .align 5 @ align to cache-line size 926 | .set SCRATCH_PAD_SIZE, 0x80 927 | scratch_pad: 928 | .space SCRATCH_PAD_SIZE 929 | scratch_pad_top: 930 | -------------------------------------------------------------------------------- /loadmap: -------------------------------------------------------------------------------- 1 | 2 | MEMORY 3 | { 4 | arm : ORIGIN = 0x8000, LENGTH = 0xC000000 5 | } 6 | 7 | SECTIONS 8 | { 9 | .text : { *(.text*) } > arm 10 | .rodata : { *(.rodata*) } > arm 11 | .data : { *(.data*) } > arm 12 | .bss : { *(.bss*) } > arm 13 | } 14 | 15 | --------------------------------------------------------------------------------