├── .gitignore ├── TODO.md ├── README.md ├── aforth.f └── aforth.S /.gitignore: -------------------------------------------------------------------------------- 1 | aforth 2 | aforth.o 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # TODO 2 | - ~~Redo branches to use jump to memory instead of jump to offset~~ 3 | - ~~Macro to make `lit, xxx, branchz` more readable in asm code~~ 4 | - ~~Restructure dictionary to allow long word names~~ 5 | - Rewrite some forth words in aforth.S to assembly where the forth 6 | implementation is more complex 7 | - ~~Figure out how a prompt can be provided in the outer interpreter~~ 8 | - Implement more control flow words 9 | - ~~Facilitate hiding of words, and hide some internal words~~ 10 | - ~~Let primitive and forthword macros have better defaults for flags 11 | so usage does not need to specify in most cases~~ 12 | - Use system call to request more memory instead of defining max 13 | memory at build time 14 | - Buffer stdin instead of one key at a time 15 | - Introspect word definitions (like disassemble a forth word) 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # aforth 2 | A simplistic FORTH bootstrapped from x86 assembly language 3 | 4 | ## Compile 5 | ./build.sh [linux|bsd|osx] 6 | 7 | ## Run 8 | cat aforth.f - | ./aforth 9 | 10 | ## Sample aforth code 11 | Add two numbers and display the result: 12 | ```` 13 | 12 34 // place two numbers on the stack 14 | + // the `+` word removes two numbers from the stack, adds them 15 | // and places the result on the stack 16 | . // the `.` word outputs it 17 | 46 18 | ```` 19 | Show all words present in the dictionary: 20 | ```` 21 | // the `words.` word displays all known words in the dictionary 22 | words. 23 | . words. word. spc num>str 1+@ 1-@ var: alloc bytes cells str: neg? neg 24 | char: ( ) // \ recur loop until while end else unless if mod / word 25 | latestword latest word>str hide hidden? immediate? prevword str>num 26 | execute scantoken readtoken discard ; immediate : [ ] create copy, c, , 27 | mode here write eof key nl emit +! c! c@ ! @ whitespace? whitespace str= 28 | charindex strcpy bit invert & | false true not or and /mod * - + 1- 1+ 29 | fail errorquit quit 2? ? branchnz branchz branch lit > < != = pick -rot 30 | rot nip over ndrop 3drop 2drop drop 3dup 2dup dup swapd 2swap swap exit 31 | ```` 32 | Print the multiplication table of a number upto 10: 33 | ```` 34 | // define a word *table that consumes one parameter 35 | // off the stack and outputs a multiplication table 36 | // for that number 37 | 38 | : *table ( n -- ) 39 | 1 // place index on stack 40 | until dup 10 > do 41 | over num>str write spc // display n 42 | char: * emit spc // display * 43 | dup num>str write spc // display index 44 | char: = emit spc // display = 45 | 2dup * . // multiply and display result 46 | 1+ // increment index 47 | done 48 | 2drop ; 49 | 50 | // output multiplication table for number 5 51 | 5 *table 52 | 5 * 1 = 5 53 | 5 * 2 = 10 54 | 5 * 3 = 15 55 | 5 * 4 = 20 56 | 5 * 5 = 25 57 | 5 * 6 = 30 58 | 5 * 7 = 35 59 | 5 * 8 = 40 60 | 5 * 9 = 45 61 | 5 * 10 = 50 62 | ```` 63 | 64 | ## Did you know? 65 | - In FORTH, functions are called words. All words take their inputs from the 66 | stack and place their outputs on the same stack. Thus a word in forth is 67 | defined as a list of other words that need to be executed. e.g. 68 | `: double 2 * ;` and `: quadruple double double ;`. 69 | - The word `//` defines a comment that extends until end of line. The word pair 70 | `/*` and `*/` define a multi-line comment. Unlike most languages, they are 71 | simply forth words like any other. 72 | - `if`, `else`, `while`, `until` are higher level control flow words, that are 73 | defined in terms of other primitive forth words like `branch` and `branchz` 74 | that in turn are forth primitives defined in x86 assembly. 75 | - The word `:` (COLON) is a forth word that is used to define new words at 76 | runtime. It does this by compiling the addresses of other words into 77 | consecutive memory addresses. 78 | 79 | ## Why I built this 80 | The [Factor][0] programming language was my first exposure to concatenative or 81 | stack based programming languages. After seeing that all syntax in Factor was 82 | runtime defined, I was impressed. I mean, I had never come across a language 83 | that had no fixed syntax. Even LISP (ignoring reader macros) had parenthesis. 84 | 85 | So I spent a lot of time learning more about concatenative languages and FORTH. 86 | I also came across [JonesForth][1] and [Itsy Forth][2], and through them I 87 | realized bootstrapping a forth could be very simple. 88 | 89 | I build this to clarify for myself what I learnt about FORTH from studying these 90 | implementations, to see for myself if I could build a forth and to be able to 91 | better appreciate what makes FORTH so simple but extremely low level and high 92 | level at the same time. I mean you start out with x86 assembly language and very 93 | soon you are representing FORTH words within assembly language (using macros), 94 | and then you write a parser using the FORTH words you have, which then enables 95 | you to write more FORTH, building up a language as you go. 96 | 97 | ## Is it useful software? 98 | Not really. 99 | 100 | ## Do I have plans to improve it? 101 | Not at the moment. I might come back to it to try building out other concepts 102 | linked to compilers and interpreters (like say adding garbage collection or 103 | local variables). 104 | 105 | [0]: https://factorcode.org 106 | [1]: https://github.com/AlexandreAbreu/jonesforth 107 | [2]: http://www.retroprogramming.com/2012/06/itsy-forth-compiler.html 108 | -------------------------------------------------------------------------------- /aforth.f: -------------------------------------------------------------------------------- 1 | : lit, 2 | lit lit , , ; 3 | 4 | : dup, 5 | lit dup , ; 6 | 7 | : branchz, 8 | 0 lit, 9 | lit branchz , 10 | here @ 8 - ; 11 | 12 | : branchnz, 13 | 0 lit, 14 | lit branchnz , 15 | here @ 8 - ; 16 | 17 | : branch, 18 | 0 lit, 19 | lit branch , 20 | here @ 8 - ; 21 | 22 | : branchoff! 23 | swap ! ; 24 | 25 | : if 26 | branchnz, 27 | ; immediate 28 | 29 | : unless 30 | branchz, 31 | ; immediate 32 | 33 | : else 34 | branch, swap 35 | here @ branchoff! 36 | ; immediate 37 | 38 | : end 39 | here @ branchoff! 40 | ; immediate 41 | 42 | : while 43 | here @ true 44 | ; immediate 45 | 46 | : until 47 | here @ false 48 | ; immediate 49 | 50 | : do 51 | if 52 | branchnz, 53 | else 54 | branchz, 55 | end 56 | ; immediate 57 | 58 | : done 59 | branch, rot branchoff! 60 | here @ branchoff! 61 | ; immediate 62 | 63 | : recur 64 | branch, latestword 4 + 65 | branchoff! 66 | ; immediate 67 | 68 | : \ 69 | scantoken word 70 | mode @ unless 71 | lit, 72 | end 73 | ; immediate 74 | 75 | : // 76 | key 10 = 77 | unless recur end 78 | ; immediate 79 | 80 | // ------------------------------------------------------------- 81 | // now we gain the ability to insert comments in a forth program 82 | // ------------------------------------------------------------- 83 | 84 | : */ ; 85 | 86 | : /* 87 | scantoken 88 | \ */ word>str 89 | str= unless 90 | recur 91 | end 92 | ; immediate 93 | 94 | /* -------------------------------------------------------------- 95 | now we gain the ability to place multi-line comments like this 96 | -------------------------------------------------------------- */ 97 | 98 | : ) ; 99 | 100 | : ( 101 | scantoken 102 | \ ) word>str 103 | str= unless 104 | recur 105 | end 106 | ; immediate 107 | 108 | // stack effect signatures ( x y -- z ) are like function signatures 109 | // and are used indicate the input and output stack effects of a word 110 | 111 | // 112 | // general utility words 113 | // 114 | 115 | : on ( var -- ) 116 | true swap ! ; 117 | 118 | : off ( var -- ) 119 | false swap ! ; 120 | 121 | : >= ( n1 n2 -- ? ) 122 | < not ; 123 | 124 | : <= ( n1 n2 -- ? ) 125 | > not ; 126 | 127 | : / ( n1 n2 -- quot ) 128 | /mod drop ; 129 | 130 | : mod ( n1 n2 -- rem ) 131 | /mod nip ; 132 | 133 | : neg ( x -- -x ) 134 | 0 swap - ; 135 | 136 | : neg? ( x -- ? ) 137 | 0 < ; 138 | 139 | : 1+@ ( var -- ) // increment variable 140 | dup @ 1+ 141 | swap ! ; 142 | 143 | : 1-@ ( var -- ) // decrement variable 144 | dup @ 1- 145 | swap ! ; 146 | 147 | // 148 | // utility words related to memory sizing 149 | // 150 | 151 | : cell ( n -- ) 152 | 4 * ; 153 | 154 | : cells ( n -- ) 155 | 4 * ; 156 | 157 | : byte ( n -- ) ; 158 | 159 | : bytes ( n -- ) ; 160 | 161 | : kb ( n -- n ) 162 | 1024 * ; 163 | 164 | // 165 | // character literal support 166 | // 167 | // usage: 168 | // char: a emit char: b emit char: c emit 169 | // 170 | 171 | : char: 172 | scantoken drop c@ 173 | mode @ unless 174 | lit, 175 | end 176 | ; immediate 177 | 178 | // 179 | // accept character strings from stdin 180 | // 181 | 182 | : accept-more? ( buff max ptr -- ? ) 183 | over -1 = if 184 | true 185 | else 186 | rot - > 187 | end ; 188 | 189 | : escape? ( ch -- ? ) 190 | char: \ = ; 191 | 192 | : buff,c ( buff ch -- buff+1 ) 193 | over c! 1+ ; 194 | 195 | : finish-accept ( delim buff max ptr -- buff len ) 196 | nip over - 197 | rot drop ; 198 | 199 | : accept ( delim buff max -- buff len ) 200 | over 201 | while 3dup accept-more? do 202 | key dup escape? 203 | if 204 | drop key drop 205 | key buff,c 206 | else 207 | ( delim buff max ptr ch ) 208 | dup 5 pick = 209 | unless 210 | buff,c 211 | else 212 | drop finish-accept 213 | exit 214 | end 215 | end 216 | done 217 | finish-accept ; 218 | 219 | \ accept-more? hide 220 | \ escape? hide 221 | \ buff,c hide 222 | \ finish-accept hide 223 | 224 | // 225 | // support runtime variables 226 | // 227 | // usage: 228 | // var a 1 cell alloc 229 | // 230 | 231 | : var ( -- var-sizeof-addr ) 232 | scantoken create 233 | here @ 3 cells + lit, 234 | lit exit , 235 | ; immediate 236 | 237 | : alloc ( n -- ) 238 | here +! ; 239 | 240 | // 241 | // support runtime string constants 242 | // 243 | // usage: 244 | // stringconst abcd "abcd" 245 | // 246 | 247 | : stringconst ( -- ) 248 | scantoken 249 | whitespace discard drop 250 | here @ 100 accept 251 | ( word wlen buff blen ) 252 | dup here +! 253 | 2swap create swap 254 | lit, lit, lit exit , 255 | ; immediate 256 | 257 | // 258 | // support allocating buffers to hold runtime input 259 | // 260 | // usage: 261 | // buffer userinput 100 262 | // userinput readln 263 | // 264 | 265 | : buffer ( -- ) 266 | scantoken create 267 | here @ 5 cells + lit, 268 | scantoken str>num dup lit, 269 | lit exit , alloc 270 | ; immediate 271 | 272 | : readln ( buff max -- buff len ) 273 | 10 -rot accept ; 274 | 275 | // 276 | // words to convert numbers to strings 277 | // 278 | 279 | var n>s_buff 15 bytes alloc 280 | var n>s_ptr 1 cells alloc 281 | 282 | : num>str ( n -- buff len ) 283 | dup if 284 | drop 285 | char: 0 n>s_buff c! 286 | n>s_buff 1 exit 287 | end 288 | n>s_buff 15 + n>s_ptr ! 289 | dup neg? if 290 | neg true 291 | else 292 | false 293 | end swap 294 | until dup do 295 | 10 /mod 296 | char: 0 + 297 | n>s_ptr 1-@ 298 | n>s_ptr @ c! 299 | done drop 300 | if 301 | n>s_ptr 1-@ 302 | char: - n>s_ptr @ c! 303 | end 304 | n>s_ptr @ 305 | n>s_buff 15 + n>s_ptr @ - ; 306 | 307 | \ n>s_buff hide 308 | \ n>s_ptr hide 309 | 310 | // 311 | // words to output stuff 312 | // 313 | 314 | : spc ( -- ) 315 | 32 emit ; 316 | 317 | : write. ( buff str -- ) 318 | write nl ; 319 | 320 | : word. ( word -- ) 321 | word>str write nl ; 322 | 323 | : words. ( -- ) 324 | latestword 325 | until dup do 326 | dup hidden? unless 327 | dup word>str write spc 328 | end 329 | prevword 330 | done 331 | drop nl ; 332 | 333 | : . ( n -- ) 334 | num>str write. ; 335 | 336 | // 337 | // words to inspect the parameter & return stacks 338 | // 339 | 340 | stringconst s_bot "---------" 341 | stringconst s_top "-- top --" 342 | 343 | : s. ( -- ) 344 | psbase ps = if 345 | exit 346 | end 347 | s_bot write. 348 | psbase while ps over < do 349 | dup @ . 350 | 1 cells - 351 | done drop 352 | s_top write. ; 353 | 354 | : rframe. ( rs -- ) 355 | latestword 356 | until 2dup swap < do 357 | prevword 358 | done 359 | word. drop ; 360 | 361 | : r. ( -- ) 362 | s_bot write. 363 | rsbase 364 | while rs over >= do 365 | dup @ rframe. 366 | 1 cells + 367 | done drop 368 | s_top write. ; 369 | 370 | \ s_bot hide 371 | \ s_top hide 372 | 373 | // 374 | // words to inspect free memory 375 | // 376 | 377 | stringconst bytes_str "bytes" 378 | stringconst kb_str "kb" 379 | stringconst free_str "free" 380 | 381 | : mem. ( -- ) 382 | mem 1 kb >= if 383 | mem 1 kb / num>str write 384 | spc kb_str write 385 | else 386 | mem num>str write 387 | spc bytes_str write 388 | end 389 | spc free_str write nl ; 390 | 391 | \ bytes_str hide 392 | \ kb_str hide 393 | \ free_str hide 394 | 395 | // 396 | // hide internal words 397 | // 398 | 399 | \ lit, hide 400 | \ dup, hide 401 | \ branchz, hide 402 | \ branchnz, hide 403 | \ branch, hide 404 | \ branchoff! hide 405 | 406 | stringconst welcome "aforth v0.0.1 ready" 407 | welcome write. 408 | 409 | \ welcome hide 410 | 411 | prompt on 412 | -------------------------------------------------------------------------------- /aforth.S: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; aforth - a simple forth bootstrapped from 32-bit x86 assembly 3 | ;;; 4 | ;;; compile: ./build.sh [linux|osx] 5 | ;;; run: cat aforth.f - | ./aforth 6 | ;;; 7 | 8 | 9 | %ifdef OSX 10 | %define startsymbol start 11 | %else 12 | %define startsymbol _start 13 | %endif 14 | 15 | 16 | ;;; 17 | ;;; macro definitions 18 | ;;; 19 | 20 | 21 | ;;; linux 32-bit style syscall abi handler: 22 | ;;; 1) pass syscall number in eax 23 | ;;; 2) pass params in the order: ebx, ecx, edx 24 | ;;; 3) supports syscalls having upto 3 parameter 25 | %macro systemcall 0 26 | %ifndef linux 27 | push edx 28 | push ecx 29 | push ebx 30 | push eax 31 | %endif 32 | int 0x80 33 | %ifndef linux 34 | add esp, 16 35 | %endif 36 | %endmacro 37 | 38 | ;;; 39 | ;;; next macro: 40 | ;;; used to transfer control from the currently 41 | ;;; executing primitive word to the next word 42 | ;;; 43 | %macro next 0 44 | lodsd 45 | jmp [eax] 46 | %endmacro 47 | 48 | ;;; 49 | ;;; push a value onto the return stack 50 | ;;; 51 | %macro pushrs 1 52 | add ebp, 4 53 | mov [ebp], %1 54 | %endmacro 55 | 56 | ;;; 57 | ;;; pop a value from the return stack 58 | ;;; 59 | %macro poprs 1 60 | mov %1, dword [ebp] 61 | sub ebp, 4 62 | %endmacro 63 | 64 | 65 | ;;; 66 | ;;; how words are structured in the `aforth` dictionary: 67 | ;;; +-----------------------------------------------------------+ 68 | ;;; | link | name | len | flags | interpreter | definition ... | 69 | ;;; +-----------------------------------------------------------+ 70 | ;;; 71 | ;;; link : address to the previously defined word (4 bytes) 72 | ;;; name : max 256 bytes (variable size) 73 | ;;; len : name length (1 byte) 74 | ;;; flags : to control behaviour of this word (1 byte) 75 | ;;; interpreter : pointer to x86 code that can execute this word (4 bytes) 76 | ;;; definition : either x86 code or a pointers to other words (variable size) 77 | ;;; 78 | 79 | ;;; 80 | ;;; keep track of the last defined word in assembly 81 | ;;; in order to maintain a chain of words in the 82 | ;;; forth dictionary 83 | ;;; 84 | %define lastword 0 85 | 86 | ;;; 87 | ;;; allowed flags: 88 | ;;; 1 => word is immediate 89 | ;;; 2 => word is hidden 90 | ;;; 91 | %define F_IMMEDIATE 1 92 | %define F_HIDDEN 2 93 | 94 | ;;; 95 | ;;; macro: primitive asmname, 'wordname', flags 96 | ;;; 97 | ;;; primitive words do not need an interpreter, so their 98 | ;;; interpreter pointer simply points to the start of their 99 | ;;; x86 instructions 100 | ;;; 101 | %macro primitive 2-3 0 102 | %1_dict_entry: 103 | dd lastword 104 | %1_name: 105 | db %2 106 | db $ - %1_name 107 | db %3 108 | %1: 109 | dd %1_asm 110 | %1_asm: 111 | %define lastword %1 112 | %endmacro 113 | 114 | ;;; 115 | ;;; macro: forthword asmname, 'wordname', flags 116 | ;;; 117 | ;;; non-primitive / compound words are words that are defined 118 | ;;; in terms of other words. their definition consists of a 119 | ;;; list of pointers to other forth words. thus they cannot be 120 | ;;; "executed" directly. their interpreter word thus points to a 121 | ;;; simple interpreter (defined further down below) that sets up 122 | ;;; some state and jumps to the first word of word definition 123 | ;;; 124 | %macro forthword 2-3 0 125 | %1_dict_entry: 126 | dd lastword 127 | %1_name: 128 | db %2 129 | db $ - %1_name 130 | db %3 131 | %1: 132 | dd interpreter 133 | %define lastword %1 134 | %endmacro 135 | 136 | ;;; 137 | ;;; macro: stringconst asmname, 'wordname', flags 138 | ;;; 139 | ;;; this macro defines a forth word that when executed simply places 140 | ;;; on the stack (a) the address of the string buffer, (b) the string length 141 | ;;; 142 | %macro stringconst 2-3 0 143 | section .data 144 | str_data_%1: db %2 145 | str_len_%1: equ $-str_data_%1 146 | section .text 147 | %defstr variable_name %1 148 | primitive %1, variable_name, %3 149 | push str_data_%1 150 | push str_len_%1 151 | next 152 | %endmacro 153 | 154 | ;;; 155 | ;;; macro: variable wordname 156 | ;;; 157 | ;;; this macro first reserves 4 bytes of space in the .data section 158 | ;;; and defines a forth word that simply places this address on 159 | ;;; the stack 160 | ;;; 161 | %macro variable 1-2 0 162 | section .bss 163 | var_data_%1: 164 | resd 1 165 | section .text 166 | %defstr variable_name %1 167 | primitive %1, variable_name, %2 168 | push var_data_%1 169 | next 170 | %endmacro 171 | 172 | %define branch(label) lit, label, branch 173 | %define branchz(label) lit, label, branchz 174 | %define branchnz(label) lit, label, branchnz 175 | 176 | global startsymbol 177 | 178 | section .text 179 | 180 | ;;; 181 | ;;; interpreter for forth words 182 | ;;; 1) push the next word to be executed onto the return stack 183 | ;;; 2) sets up the next word to be executed as the first word 184 | ;;; from the currently executing words definition 185 | ;;; 3) execute next word 186 | ;;; 187 | interpreter: 188 | pushrs esi 189 | lea esi, [eax+4] 190 | next 191 | 192 | ;;; 193 | ;;; core words 194 | ;;; 195 | 196 | 197 | primitive exit, 'exit' 198 | ;; ( -- ) 199 | ;; return from currently executing forth word 200 | poprs esi 201 | next 202 | 203 | primitive swap, 'swap' 204 | ;; ( x y -- y x ) 205 | pop eax 206 | pop ebx 207 | push eax 208 | push ebx 209 | next 210 | 211 | primitive swap2, '2swap' 212 | ;; ( x1 x2 y1 y2 -- y1 y2 x1 x2 ) 213 | pop ebx 214 | pop eax 215 | pop edx 216 | pop ecx 217 | push eax 218 | push ebx 219 | push ecx 220 | push edx 221 | next 222 | 223 | primitive swapd, 'swapd' 224 | ;; ( x y z -- y x z ) 225 | pop eax 226 | pop ebx 227 | pop ecx 228 | push ebx 229 | push ecx 230 | push eax 231 | next 232 | 233 | primitive dup, 'dup' 234 | ;; ( x -- x x ) 235 | mov eax, dword [esp] 236 | push eax 237 | next 238 | 239 | primitive dup2, '2dup' 240 | ;; ( x y -- x y x y ) 241 | mov eax, dword [esp+4] 242 | push eax 243 | mov eax, dword [esp+4] 244 | push eax 245 | next 246 | 247 | primitive dup3, '3dup' 248 | ;; ( x y z -- x y z x y z ) 249 | mov eax, dword [esp+8] 250 | push eax 251 | mov eax, dword [esp+8] 252 | push eax 253 | mov eax, dword [esp+8] 254 | push eax 255 | next 256 | 257 | primitive dupd, 'dupd' 258 | ;; ( x y -- x x y ) 259 | pop ebx 260 | mov eax, dword [esp] 261 | push eax 262 | push ebx 263 | next 264 | 265 | primitive drop, 'drop' 266 | ;; ( x -- ) 267 | pop eax 268 | next 269 | 270 | primitive drop2, '2drop' 271 | ;; ( x y -- ) 272 | pop eax 273 | pop eax 274 | next 275 | 276 | primitive drop3, '3drop' 277 | ;; ( x y z -- ) 278 | pop eax 279 | pop eax 280 | pop eax 281 | next 282 | 283 | primitive ndrop, 'ndrop' 284 | ;; 0 ndrop => ( x 0 -- x ) 285 | ;; 1 ndrop => ( x 1 -- ) 286 | ;; 2 ndrop => ( x y 2 -- ) 287 | pop eax 288 | lea esp, [esp + 4*eax] 289 | next 290 | 291 | primitive over, 'over' 292 | ;; ( x y -- x y x ) 293 | mov eax, dword [esp + 4] 294 | push eax 295 | next 296 | 297 | primitive nip, 'nip' 298 | ;; ( x y -- y ) 299 | pop eax 300 | pop ebx 301 | push eax 302 | next 303 | 304 | primitive rot, 'rot' 305 | ;; ( x y z -- y z x ) 306 | pop ecx 307 | pop ebx 308 | pop eax 309 | push ebx 310 | push ecx 311 | push eax 312 | next 313 | 314 | primitive rotr, '-rot' 315 | ;; ( x y z -- z x y ) 316 | pop ecx 317 | pop ebx 318 | pop eax 319 | push ecx 320 | push eax 321 | push ebx 322 | next 323 | 324 | primitive pick, 'pick' 325 | ;; 0 pick => ( x 0 -- x x ) 326 | ;; 1 pick => ( x y 1 -- x y x ) 327 | ;; 2 pick => ( x y z 2 -- x y z x ) 328 | pop eax 329 | mov ebx, dword [esp + 4*eax] 330 | push ebx 331 | next 332 | 333 | 334 | ;;; 335 | ;;; comparison words 336 | ;;; 337 | 338 | 339 | primitive equalp, '=' 340 | ;; ( x y -- ? ) 341 | ;; 0 => true 342 | ;; 1 => false 343 | pop eax 344 | pop ebx 345 | cmp eax, ebx 346 | jz equalp_true 347 | push 1 348 | next 349 | equalp_true: 350 | push 0 351 | next 352 | 353 | forthword notequalp, '!=' 354 | ;; ( x y -- ? ) 355 | dd equalp, boolnot 356 | dd exit 357 | 358 | primitive lessthanp, '<' 359 | ;; ( x y -- ? ) 360 | pop ebx 361 | pop eax 362 | cmp eax, ebx 363 | jl lessthanp_true 364 | push 1 365 | next 366 | lessthanp_true: 367 | push 0 368 | next 369 | 370 | forthword greaterthanp, '>' 371 | ;; ( x y -- ? ) 372 | dd dup2, lessthanp 373 | dd rotr, equalp 374 | dd boolor, boolnot 375 | dd exit 376 | 377 | primitive lit, 'lit' 378 | ;; ( -- x ) 379 | ;; treat the following word in definition as 380 | ;; a literal value and push it onto the stack 381 | push dword [esi] 382 | add esi, 4 383 | next 384 | 385 | primitive branch, 'branch' 386 | ;; ( addr -- ) 387 | ;; jump to forth addr (address of a cell in a given word) 388 | pop esi 389 | next 390 | 391 | primitive branchz, 'branchz' 392 | ;; ( ? addr -- ) 393 | ;; jump to forth addr if condition is zero 394 | pop eax ; addr 395 | pop ebx ; value 396 | cmp ebx, 0 397 | jz branchz_jump 398 | next 399 | branchz_jump: 400 | mov esi, eax 401 | next 402 | 403 | primitive branchnz, 'branchnz' 404 | ;; ( ? addr -- ) 405 | ;; jump to forth addr if condition is non-zero 406 | pop eax ; addr 407 | pop ebx ; value 408 | cmp ebx, 0 409 | jnz branchz_jump 410 | next 411 | branchnz_jump: 412 | mov esi, eax 413 | next 414 | 415 | forthword choose, '?' 416 | ;; ( x y ? -- x/y ) 417 | ;; choose x if top of stack is true (zero) 418 | ;; choose y if top of stack is false (non-zero) 419 | dd branchnz(choose_false) 420 | dd drop, exit 421 | choose_false: 422 | dd nip, exit 423 | 424 | forthword choose2, '2?' 425 | ;; ( x1 y1 x2 y2 ? -- x1/x2 y1/y2 ) 426 | ;; choose x1 y1 if top of stack is true (zero) 427 | ;; choose x2 y2 if top of stack is false (non-zero) 428 | dd branchnz(choose2_false) 429 | dd drop2, exit 430 | choose2_false: 431 | dd rot, drop 432 | dd rot, drop 433 | dd exit 434 | 435 | 436 | ;;; 437 | ;;; system words 438 | ;;; 439 | 440 | primitive quit, 'quit' 441 | ;; ( -- ) 442 | ;; terminate program with 0 return code 443 | mov ebx, 0 444 | mov eax, 1 445 | systemcall 446 | next 447 | 448 | primitive errorquit, 'errorquit' 449 | ;; ( -- ) 450 | ;; terminate program with 1 return code 451 | mov ebx, 1 452 | mov eax, 1 453 | systemcall 454 | next 455 | 456 | forthword fail, 'fail' 457 | ;; ( buff len -- ) 458 | ;; write string to stdout and terminate with failure 459 | ;; return code 460 | dd write, errorquit 461 | 462 | 463 | ;;; 464 | ;;; arithmetic words 465 | ;;; 466 | 467 | primitive oneplus, '1+' 468 | ;; ( x -- x+1 ) 469 | inc dword [esp] 470 | next 471 | 472 | primitive oneminus, '1-' 473 | ;; ( x -- x-1 ) 474 | dec dword [esp] 475 | next 476 | 477 | primitive plus, '+' 478 | ;; ( x y -- x+y ) 479 | pop eax 480 | add dword [esp], eax 481 | next 482 | 483 | primitive minus, '-' 484 | ;; ( x y -- x-y ) 485 | pop eax 486 | sub dword [esp], eax 487 | next 488 | 489 | primitive multiply, '*' 490 | ;; ( x y -- x*y ) 491 | pop eax 492 | pop ebx 493 | imul ebx 494 | push eax 495 | next 496 | 497 | primitive divmod, '/mod' 498 | ;; ( x y -- q r ) 499 | ;; divide x by y producing quotient q and remainder r 500 | pop ebx 501 | pop eax 502 | cdq 503 | idiv ebx 504 | push eax 505 | push edx 506 | next 507 | 508 | 509 | ;;; 510 | ;;; boolean logic words 511 | ;;; 512 | 513 | primitive booland, 'and' 514 | ;; ( x y -- x&&y ) 515 | pop ebx 516 | pop eax 517 | cmp eax, 0 518 | je booland_2nd 519 | push eax 520 | next 521 | booland_2nd: 522 | push ebx 523 | next 524 | 525 | primitive boolor, 'or' 526 | ;; ( x y -- x||y ) 527 | pop ebx 528 | pop eax 529 | cmp eax, 0 530 | jne boolor_2nd 531 | push eax 532 | next 533 | boolor_2nd: 534 | push ebx 535 | next 536 | 537 | primitive boolnot, 'not' 538 | ;; ( x -- !x ) 539 | pop eax 540 | cmp eax, 0 541 | je boolnot_true 542 | push dword 0 543 | next 544 | boolnot_true: 545 | push dword 1 546 | next 547 | 548 | primitive true, 'true' 549 | ;; ( -- ? ) 550 | push dword 0 551 | next 552 | 553 | primitive false, 'false' 554 | ;; ( -- ? ) 555 | push dword 1 556 | next 557 | 558 | 559 | ;;; 560 | ;;; bitwise operation words 561 | ;;; 562 | 563 | 564 | primitive bitor, '|' 565 | ;; ( x y -- x|y ) 566 | pop ebx 567 | pop eax 568 | or eax, ebx 569 | push eax 570 | next 571 | 572 | primitive bitand, '&' 573 | ;; ( x y -- x&y ) 574 | pop ebx 575 | pop eax 576 | and eax, ebx 577 | push eax 578 | next 579 | 580 | primitive bitxor, '^' 581 | ;; ( x y -- x^y ) 582 | pop ebx 583 | pop eax 584 | xor eax, ebx 585 | push eax 586 | next 587 | 588 | primitive bitnot, 'invert' 589 | ;; ( x -- x' ) 590 | pop eax 591 | not eax 592 | push eax 593 | next 594 | 595 | forthword bit, 'bit' 596 | ;; ( value index -- ? ) 597 | dd bitand, boolnot, boolnot 598 | dd exit 599 | 600 | 601 | ;;; 602 | ;;; words to work with strings 603 | ;;; 604 | 605 | 606 | primitive strcpy, 'strcpy' 607 | ;; ( src length dest -- ) 608 | mov eax, esi 609 | pop edi 610 | pop ecx 611 | pop esi 612 | rep movsb 613 | mov esi, eax 614 | next 615 | 616 | primitive charindex, 'charindex' 617 | ;; ( buff len ch -- index/-1 ) 618 | pop eax 619 | pop ecx 620 | pop edi 621 | mov ebx, edi 622 | repne scasb 623 | jz charindex_found 624 | mov eax, -1 625 | push eax 626 | next 627 | charindex_found: 628 | sub edi, ebx 629 | dec edi 630 | push edi 631 | next 632 | 633 | primitive streqp, 'str=' 634 | ;; ( buff1 len1 buff2 len2 -- ? ) 635 | push ebp 636 | mov ebp, esp 637 | push esi 638 | mov ebx, dword [ebp+4] 639 | mov edi, dword [ebp+8] 640 | mov eax, dword [ebp+12] 641 | mov esi, dword [ebp+16] 642 | cmp eax, ebx 643 | jne streqp_notequal 644 | mov ecx, eax 645 | repe cmpsb 646 | jne streqp_notequal 647 | mov eax, 0 648 | jmp streqp_done 649 | streqp_notequal: 650 | mov eax, 1 651 | streqp_done: 652 | pop esi 653 | pop ebp 654 | add esp, 16 655 | push eax 656 | next 657 | 658 | ;; a string containing the characters: 659 | ;; space(32) newline(10) tab(9) 660 | stringconst whitespace, {32, 10, 9} 661 | 662 | forthword whitespacep, 'whitespace?' 663 | ;; ( ch -- ? ) 664 | dd whitespace, rot, charindex 665 | dd lit, -1, notequalp 666 | dd exit 667 | 668 | ;; a string containing the characters: 669 | ;; space(32) tab(9) 670 | stringconst spaces, {32, 9} 671 | 672 | forthword spacesp, 'spaces?' 673 | ;; ( ch -- ? ) 674 | dd spaces, rot, charindex 675 | dd lit, -1, notequalp 676 | dd exit 677 | 678 | forthword spcp, 'spc?' 679 | ;; ( ch -- ? ) 680 | dd lit, 32, equalp 681 | dd exit 682 | 683 | forthword nlp, 'nl?' 684 | ;; ( ch -- ? ) 685 | dd lit, 10, equalp 686 | dd exit 687 | 688 | 689 | ;;; 690 | ;;; words to work with numbers 691 | ;;; 692 | 693 | 694 | stringconst errnotanum, 'err: not a number', F_HIDDEN 695 | 696 | primitive parsenum, 'parsenum', F_HIDDEN 697 | ;; ( buff len -- num? valid? ) 698 | mov edx, 0 ; edx will hold sign, edx = 0 indicates positive 699 | mov ebx, 0 ; ebx will hold +ve value 700 | pop ecx ; len 701 | pop edi 702 | push esi 703 | mov esi, edi ; esi points to buff 704 | pop edi ; edi holds next word address 705 | mov eax, 0 ; eax will hold each digit as they are processed 706 | lodsb 707 | cmp al, 45 ; starts with - sign? 708 | jnz parsenum_loop 709 | mov edx, 1 ; edx = 1 indicates negative 710 | dec ecx 711 | jz parsenum_invalid ; buff containd only a minus sign 712 | lodsb 713 | parsenum_loop: 714 | cmp al, 48 ; less than ascii 0? 715 | jb parsenum_invalid 716 | cmp al, 57 717 | ja parsenum_invalid ; greater than ascii 9? 718 | sub al, 48 719 | imul ebx, 10 720 | add ebx, eax 721 | dec ecx 722 | jz parsenum_done_digits 723 | lodsb 724 | jmp parsenum_loop 725 | parsenum_done_digits: 726 | cmp edx, 1 ; handle negative sign 727 | jnz parsenum_done 728 | imul ebx, -1 729 | parsenum_done: 730 | mov esi, edi ; restore next word address 731 | push ebx ; parsed number 732 | push dword 0 ; valid = true 733 | next 734 | parsenum_invalid: 735 | push dword 0 ; dummy number 736 | push dword 1 ; valid = false 737 | next 738 | 739 | forthword strtonum, 'str>num' 740 | ;; ( buff len -- num ) 741 | dd parsenum, branchnz(strtonum_invalid) 742 | dd exit 743 | strtonum_invalid: 744 | dd errnotanum, fail 745 | 746 | 747 | ;;; 748 | ;;; memory access words 749 | ;;; 750 | 751 | 752 | primitive read4, '@' 753 | ;; ( addr -- x ) 754 | pop eax 755 | push dword [eax] 756 | next 757 | 758 | primitive store4, '!' 759 | ;; ( x addr -- ) 760 | pop eax ; address 761 | pop ebx ; value 762 | mov dword [eax], ebx 763 | next 764 | 765 | primitive read1, 'c@' 766 | ;; ( addr -- ch ) 767 | pop eax 768 | mov bl, byte [eax] 769 | and ebx, 0xff 770 | push ebx 771 | next 772 | 773 | primitive store1, 'c!' 774 | ;; ( ch addr -- ) 775 | pop eax ; address 776 | pop ebx ; value 777 | mov byte [eax], bl 778 | next 779 | 780 | forthword addstore4, '+!' 781 | ;; ( x addr -- ) 782 | ;; add x to value at addr 783 | dd swap, over, read4, plus 784 | dd swap, store4 785 | dd exit 786 | 787 | forthword mem, 'mem' 788 | ;; ( -- n ) 789 | ;; returns free memory available for runtime allocation 790 | ;; in bytes 791 | dd lit, alloc_end 792 | dd here, read4 793 | dd minus 794 | dd exit 795 | 796 | 797 | ;;; 798 | ;;; words to work with the return stack 799 | ;;; 800 | 801 | 802 | primitive rsbase, 'rsbase' 803 | ;; ( -- addr ) 804 | push return_stack_base 805 | next 806 | 807 | primitive peekrs, 'rs' 808 | ;; ( -- addr ) 809 | push ebp 810 | next 811 | 812 | primitive pushrsp, '>rs' 813 | ;; ( n -- ) 814 | pop eax 815 | pushrs eax 816 | next 817 | 818 | primitive poprsp, 'rs>' 819 | ;; ( -- n ) 820 | poprs eax 821 | push eax 822 | next 823 | 824 | 825 | ;;; 826 | ;;; words to work with the parameter stack 827 | ;;; 828 | 829 | 830 | section .bss 831 | parameter_stack_base: 832 | resd 1 833 | section .text 834 | 835 | primitive psbase, 'psbase' 836 | mov eax, dword [parameter_stack_base] 837 | push eax 838 | next 839 | 840 | primitive ps, 'ps' 841 | mov eax, esp 842 | push eax 843 | next 844 | 845 | 846 | ;;; 847 | ;;; i/o words 848 | ;;; 849 | 850 | section .bss 851 | internal_var_eof: 852 | resd 1 853 | section .text 854 | 855 | primitive emit, 'emit' 856 | ;; ( ch -- ) 857 | ;; write one character to stdout 858 | mov ebx, 1 859 | mov ecx, esp ; cbuf is 1 character on the stack 860 | mov edx, 1 861 | mov eax, 4 862 | systemcall 863 | pop eax ; remove character from stack 864 | next 865 | 866 | forthword nl, 'nl' 867 | ;; ( -- ) 868 | ;; write new line to stdout 869 | dd lit, 10, emit 870 | dd exit 871 | 872 | primitive key, 'key' 873 | ;; ( -- ch/0 ) 874 | ;; reads a character from stdin 875 | ;; if end of stream is reached, eof is set to true and the 876 | ;; character placed on top of stack should be discarded 877 | push dword 0 ; make room on stack for character 878 | mov ebx, 0 879 | mov ecx, esp ; cbuf 880 | mov edx, 1 881 | mov eax, 3 882 | systemcall 883 | mov dword [internal_var_eof], eax 884 | next 885 | 886 | primitive eof, 'eof' 887 | ;; ( -- ? ) 888 | push dword [internal_var_eof] 889 | next 890 | 891 | primitive write, 'write' 892 | ;; ( buff len -- ) 893 | ;; write string starting at buff and length len to stdout 894 | mov ebx, 1 895 | pop edx 896 | pop ecx 897 | mov eax, 4 898 | systemcall 899 | next 900 | 901 | 902 | ;;; 903 | ;;; compiler words 904 | ;;; 905 | 906 | 907 | ;; points to start of free memory 908 | variable here 909 | 910 | ;; compile / interpret mode 911 | ;; 0 => interpret mode 912 | ;; 1 => compile mode 913 | variable mode 914 | 915 | forthword comma, ',' 916 | ;; ( x -- ) 917 | ;; store x at here, advance here by 1 cell 918 | dd here, read4, store4 919 | dd lit, 4, here, addstore4 920 | dd exit 921 | 922 | forthword ccomma, 'c,' 923 | ;; ( ch -- ) 924 | ;; store ch at here, advance here by 1 byte 925 | dd here, read4, store1 926 | dd lit, 1, here, addstore4 927 | dd exit 928 | 929 | forthword copycomma, 'copy,' 930 | ;; ( addr len -- ) 931 | ;; copy len bytes starting at addr to here and 932 | ;; advance here 933 | dd swap, over 934 | dd here, read4, strcpy 935 | dd here, addstore4 936 | dd exit 937 | 938 | forthword create, 'create' 939 | ;; ( buff len -- ) 940 | ;; start a word definition for word named(buff, len) at here 941 | ;; and advance here 942 | dd swap, over 943 | dd latestword, comma 944 | dd copycomma, ccomma 945 | dd lit, 0, ccomma 946 | dd here, read4, latest, store4 947 | dd lit, interpreter, comma 948 | dd exit 949 | 950 | forthword compilemode, ']' 951 | ;; ( -- ) 952 | ;; switch to compile mode 953 | dd lit, 1, mode, store4 954 | dd exit 955 | 956 | forthword interpretmode, '[', F_IMMEDIATE 957 | ;; ( -- ) 958 | ;; switch to interpret mode 959 | dd lit, 0, mode, store4 960 | dd exit 961 | 962 | forthword colon, ':' 963 | ;; ( -- ) 964 | ;; scan a string from stdin and create a word thus named 965 | ;; and switch to compile mode 966 | dd prompt, read4, lit, 1, prompt, store4 967 | dd scantoken, create, compilemode 968 | dd exit 969 | 970 | forthword semicolon, ';', F_IMMEDIATE 971 | ;; ( -- ) 972 | ;; complete current word definition by compiling the 973 | ;; exit word and then switch back to interpret mode 974 | dd lit, exit, comma, interpretmode 975 | dd prompt, store4 976 | dd exit 977 | 978 | 979 | ;;; 980 | ;;; words to work with words 981 | ;;; 982 | 983 | 984 | primitive execute, 'execute' 985 | ;; ( ...a word -- ...b ) 986 | ;; execute word on top of stack 987 | pop eax 988 | jmp dword [eax] 989 | 990 | forthword prevword, 'prevword' 991 | ;; ( word -- prevword ) 992 | dd lit, 2, minus 993 | dd dup, read1, lit, 4, plus, minus 994 | dd read4 995 | dd exit 996 | 997 | forthword wordtoflags, 'word>flags', F_HIDDEN 998 | ;; ( word -- flags ) 999 | dd oneminus, read1 1000 | dd exit 1001 | 1002 | forthword setwordflags, 'wordflags!', F_HIDDEN 1003 | ;; ( flags word -- ) 1004 | dd oneminus, store1 1005 | dd exit 1006 | 1007 | forthword immediatep, 'immediate?' 1008 | ;; ( word -- ? ) 1009 | dd wordtoflags, lit, F_IMMEDIATE 1010 | dd bit, boolnot 1011 | dd exit 1012 | 1013 | forthword immediate, 'immediate' 1014 | ;; ( -- ) 1015 | ;; set latest word as an immediate word 1016 | dd latestword, oneminus, dup 1017 | dd read1, lit, 1, bitor, swap, store1 1018 | dd exit 1019 | 1020 | forthword hiddenp, 'hidden?' 1021 | ;; ( word -- ? ) 1022 | dd wordtoflags, lit, F_HIDDEN 1023 | dd bit, boolnot 1024 | dd exit 1025 | 1026 | forthword hide, 'hide' 1027 | ;; ( word -- ) 1028 | dd dup, wordtoflags, lit, F_HIDDEN 1029 | dd bitor, swap, setwordflags 1030 | dd exit 1031 | 1032 | forthword wordtostr, 'word>str' 1033 | ;; ( word -- buff len ) 1034 | dd lit, 2, minus 1035 | dd dup, read1, swap, over 1036 | dd minus, swap 1037 | dd exit 1038 | 1039 | forthword findword, 'findword', F_HIDDEN 1040 | ;; ( buff len word -- word/0 ) 1041 | findword_loop: 1042 | dd dup, branchnz(findword_not_last) 1043 | dd nip, nip, exit 1044 | findword_not_last: 1045 | dd dup, prevword 1046 | dd over, hiddenp 1047 | dd branchnz(findword_not_hidden) 1048 | dd nip, branch(findword_loop) 1049 | findword_not_hidden: 1050 | dd over, wordtostr 1051 | dd lit, 5, pick, lit, 5, pick 1052 | dd streqp 1053 | dd branchnz(findword_not_same) 1054 | dd drop, nip, nip, exit 1055 | findword_not_same: 1056 | dd nip, branch(findword_loop) 1057 | 1058 | ;; points to the last defined word 1059 | ;; i.e. the begining of the aforth dictionary 1060 | variable latest 1061 | 1062 | forthword latestword, 'latestword' 1063 | ;; ( -- word ) 1064 | ;; places last defined word on top of stack 1065 | dd latest, read4 1066 | dd exit 1067 | 1068 | forthword wordf, 'word' 1069 | ;; ( buff len -- word/0 ) 1070 | dd latestword, findword 1071 | dd exit 1072 | 1073 | 1074 | ;;; 1075 | ;;; outer interpreter 1076 | ;;; 1077 | 1078 | 1079 | section .bss 1080 | internal_var_tokbuff: 1081 | resb 256 1082 | 1083 | section .text 1084 | 1085 | primitive tokenbuff, 'tokenbuff', F_HIDDEN 1086 | ;; ( -- addr ) 1087 | ;; places start address of the token buffer on stack 1088 | push internal_var_tokbuff 1089 | next 1090 | 1091 | forthword discard, 'discard' 1092 | ;; ( buff len -- ch/0 eof? ) 1093 | ;; read characters from stdin until a character not present 1094 | ;; in the string(buff,len) is encountered. place this non-matching 1095 | ;; character and eof flag on stack. if eof is true, then ch should 1096 | ;; be discarded (its value will be 0) 1097 | discard_loop: 1098 | dd key, eof, branchnz(discard_not_eof) 1099 | ;; ( buff len 0 ) 1100 | dd nip, nip, eof, exit 1101 | ;; ( buff len ch ) 1102 | discard_not_eof: 1103 | dd dup3, charindex, lit, -1, equalp 1104 | ;; ( buff len ch ? ) 1105 | dd branchnz(discard_no_match) 1106 | ;; ( buff len ch ) 1107 | dd nip, nip, eof, exit 1108 | ;; ( buff len ch ) 1109 | discard_no_match: 1110 | dd drop, branch(discard_loop) 1111 | 1112 | stringconst errlongtok, {'err: token too long (limit 256)', 10}, F_HIDDEN 1113 | 1114 | forthword readtoken, 'readtoken', F_HIDDEN 1115 | ;; ( ch -- ws/0 buff len ) 1116 | ;; read a token (represented by buff and len) whose first character 1117 | ;; is ch. if end of stream was reached then len will be zero. return 1118 | ;; the token along with the last character read (or zero) 1119 | dd lit, 0 1120 | ;; ( ch index ) 1121 | readtoken_loop: 1122 | dd dup, tokenbuff, plus, swapd, store1, oneplus 1123 | ;; ( index+1 ) 1124 | dd dup, lit, 256, lessthanp, branchz(readtoken_length_ok) 1125 | ;; ( index+1 ) 1126 | dd errlongtok, fail 1127 | ;; ( index+1 ) 1128 | readtoken_length_ok: 1129 | dd key, eof, branchnz(readtoken_not_eof) 1130 | ;; ( index+1 0 ) 1131 | dd tokenbuff, rot, exit 1132 | ;; ( index+1 ch/ws ) 1133 | readtoken_not_eof: 1134 | dd dup, whitespacep, branchnz(readtoken_not_ws) 1135 | ;; ( index+1 ws ) 1136 | dd tokenbuff, rot, exit 1137 | ;; ( index+1 ch ) 1138 | readtoken_not_ws: 1139 | dd swap, branch(readtoken_loop) 1140 | 1141 | forthword scantoken, 'scantoken' 1142 | ;; ( -- buff len ) 1143 | dd whitespace, discard 1144 | dd branchnz(scantoken_not_eof) 1145 | dd dup, exit 1146 | scantoken_not_eof: 1147 | dd readtoken 1148 | dd rot, drop 1149 | dd exit 1150 | 1151 | forthword executeorcomma, 'executeorcomma', F_HIDDEN 1152 | ;; ( ...a word -- ...b ) 1153 | ;; interpret mode: execute word 1154 | ;; compile mode: compiles word into current definition 1155 | dd dup, immediatep 1156 | dd branchz(executeorcomma_execute) 1157 | dd mode, read4 1158 | dd branchnz(executeorcomma_compile) 1159 | executeorcomma_execute: 1160 | dd execute, exit 1161 | executeorcomma_compile: 1162 | dd comma, exit 1163 | 1164 | forthword numorcomma, 'numorcomma', F_HIDDEN 1165 | ;; ( ...a n -- ...b ) 1166 | ;; interpret mode: does nothing 1167 | ;; compile mode: compiles literal n into current definition 1168 | dd mode, read4 1169 | dd branchnz(numorcomma_compile) 1170 | dd exit 1171 | numorcomma_compile: 1172 | dd lit, lit, comma, comma, exit 1173 | 1174 | ;; controls if the prompt should be displayed or not 1175 | ;; true(0) => show prompt 1176 | ;; false(1) => hide prompt 1177 | variable prompt 1178 | 1179 | stringconst promptstring, 'ok ', F_HIDDEN 1180 | 1181 | forthword pshowprompt, '?showprompt', F_HIDDEN 1182 | ;; ( -- ) 1183 | dd prompt, read4 1184 | dd branchnz(pshowprompt_no_prompt) 1185 | dd promptstring, write 1186 | pshowprompt_no_prompt: 1187 | dd exit 1188 | 1189 | forthword processtoken, 'processtoken', F_HIDDEN 1190 | ;; ( ..a buff len -- ..b ) 1191 | dd dup2, wordf 1192 | dd dup, branchz(processtoken_not_word) 1193 | dd nip, nip, executeorcomma, branch(processtoken_done) 1194 | processtoken_not_word: 1195 | dd drop, strtonum, numorcomma 1196 | processtoken_done: 1197 | dd exit 1198 | 1199 | forthword replline, 'repl-line', F_HIDDEN 1200 | ;; ( ..a -- ..b eof ) 1201 | replline_loop: 1202 | dd spaces, discard 1203 | dd branchnz(replline_not_eof) 1204 | dd exit 1205 | replline_not_eof: 1206 | dd dup, nlp, branchnz(replline_not_nl) 1207 | dd exit 1208 | replline_not_nl: 1209 | dd readtoken, dup, lit, 0, equalp 1210 | dd branchnz(replline_token_not_empty) 1211 | dd nip, nip, exit 1212 | replline_token_not_empty: 1213 | dd rot, nlp 1214 | dd branchnz(replline_no_nl_after_token) 1215 | dd processtoken 1216 | dd lit, 1, exit 1217 | replline_no_nl_after_token: 1218 | dd processtoken 1219 | dd branch(replline_loop) 1220 | 1221 | forthword repl, 'repl', F_HIDDEN 1222 | ;; ( ...a -- ...b ) 1223 | repl_loop: 1224 | dd pshowprompt, replline 1225 | dd branchnz(repl_loop) 1226 | dd exit 1227 | 1228 | 1229 | ;;; 1230 | ;;; main 1231 | ;;; 1232 | 1233 | 1234 | forthword bootstrap, 'bootstrap', F_HIDDEN 1235 | dd repl, quit 1236 | 1237 | startsymbol: 1238 | ;; set up dictionary pointer 1239 | ;; (no further words should be defined within assembly) 1240 | mov eax, lastword 1241 | mov dword [var_data_latest], eax 1242 | 1243 | ;; set up here pointer 1244 | mov eax, alloc_base 1245 | mov dword [var_data_here], eax 1246 | 1247 | ;; set up outer interpreter mode 1248 | mov eax, 0 1249 | mov dword [var_data_mode], eax 1250 | 1251 | ;; store parameter stack base 1252 | mov ebx, esp 1253 | sub ebx, 4 1254 | mov dword [parameter_stack_base], ebx 1255 | 1256 | ;; set up return stack 1257 | mov ebp, return_stack_base - 4 1258 | 1259 | ;; set up the first forth word that will be 1260 | ;; interpreted 1261 | mov esi, bootstrap + 4 1262 | 1263 | ;; initialize repl state 1264 | mov dword [var_data_prompt] , 1 1265 | 1266 | ;; jump to forth 1267 | next 1268 | 1269 | 1270 | section .bss 1271 | return_stack_base: 1272 | ;; return stack with a capacity of 200 items 1273 | ;; (grows downwards, i.e. low memory -> high memory) 1274 | resd 200 1275 | alloc_base: 1276 | resd 20000 ; space for 20000 cells 1277 | alloc_end: 1278 | resd 1 ; unused 1279 | --------------------------------------------------------------------------------