├── .gitignore ├── Makefile ├── README.md ├── UNLICENSE.txt ├── debug ├── debug.gdb └── debug2.gdb ├── experiment └── number.asm ├── jombloforth.asm ├── jombloforth.f ├── original ├── jonesforth.S └── jonesforth.f ├── tests ├── nostd-0branch.f ├── nostd-begin-until.f ├── nostd-branch.f ├── nostd-case.f ├── nostd-character-at.f ├── nostd-cmp.f ├── nostd-colon.f ├── nostd-comments.f ├── nostd-distance.f ├── nostd-fortytwo.f ├── nostd-iszero.f ├── nostd-numops.f ├── nostd-print.f ├── nostd-puts.f ├── nostd-squote.f ├── nostd-unless.f └── std-100.f └── unistd_64.inc /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | jombloforth 3 | experiment/number 4 | pdf 5 | jombloforth.lst 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: jombloforth 2 | 3 | jombloforth.o: jombloforth.asm unistd_64.inc 4 | nasm -g -F dwarf -f elf64 -o jombloforth.o jombloforth.asm 5 | 6 | jombloforth: jombloforth.o 7 | ld -o jombloforth jombloforth.o 8 | 9 | slim: jombloforth.asm unistd_64.inc 10 | nasm -f elf64 -o jombloforth.o jombloforth.asm 11 | ld -o jombloforth jombloforth.o 12 | 13 | dump: jombloforth 14 | objdump -z -j .rodata -j .data -j .text -d -M intel jombloforth 15 | 16 | dumpall: jombloforth 17 | objdump -z -D -M intel jombloforth 18 | 19 | jombloforth.lst: jombloforth.asm 20 | nasm -E jombloforth.asm -o jombloforth.lst 21 | 22 | experiment/%: experiment/%.o 23 | gcc -o $@ $< 24 | 25 | experiment/%.o: experiment/%.asm 26 | nasm -g -F dwarf -f elf64 -o $@ $< 27 | 28 | run: jombloforth 29 | cat jombloforth.f - | ./jombloforth 30 | 31 | check: jombloforth 32 | ./jombloforth < jombloforth.f 33 | 34 | clean: 35 | rm jombloforth.o jombloforth 36 | 37 | .PHONY: all slim dump dumpall run check clean 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # jombloforth 2 | 3 | Minimal FORTH interpreter for 64-bit Linux systems. Based on 4 | jonesforth tutorial. 5 | 6 | ## Compile 7 | 8 | You needs make, nasm, and ld to build the executable. Runs the following to build them 9 | 10 | ``` 11 | make jombloforth 12 | ``` 13 | 14 | ## Running 15 | 16 | For a full forth system, runs: 17 | 18 | ``` 19 | make run 20 | ``` 21 | 22 | The interpreter will starts accepting input from stdin. 23 | 24 | ## Quick Forth Tutorial 25 | 26 | After the interpreter starts, you can execute any forth command defined in the system. For example, adding two number and display it. 27 | 28 | ``` 29 | 42 24 + . CR 30 | ``` 31 | 32 | Will print 66 followed by newline. 33 | 34 | Defining new word and runs it: 35 | 36 | ``` 37 | : double DUP + ; 38 | 100 double . CR 39 | ``` 40 | 41 | Will print 200. 42 | 43 | To exit the program, press CTRL+D 44 | 45 | ## License 46 | 47 | UNLICENSE. See [UNLICENSE.txt](/UNLICENSE.txt) -------------------------------------------------------------------------------- /UNLICENSE.txt: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /debug/debug.gdb: -------------------------------------------------------------------------------- 1 | set confirm off 2 | set disassembly-flavor intel 3 | file jombloforth 4 | break _WORD.word 5 | run < jombloforth.f 6 | layout asm 7 | layout regs 8 | display/x $rsp 9 | display/x $rsi 10 | display/x $rdi 11 | display/c $rax 12 | display/s {char[32]}0x601559 13 | display/i $pc 14 | define nextstack 15 | next 16 | x/8xg $rsp 17 | end 18 | continue 1502 -------------------------------------------------------------------------------- /debug/debug2.gdb: -------------------------------------------------------------------------------- 1 | set confirm off 2 | set disassembly-flavor intel 3 | file jombloforth 4 | break _WORD.word 5 | run < tests/nostd-character-at.f 6 | layout asm 7 | display/c $al 8 | define nextstack 9 | next 10 | x/8xg $rsp 11 | end 12 | 13 | -------------------------------------------------------------------------------- /experiment/number.asm: -------------------------------------------------------------------------------- 1 | extern printf 2 | 3 | section .data 4 | align 8 5 | var_BASE: dq 8 6 | 7 | section .text 8 | 9 | NUMBER: 10 | ; in non-forth env, we don't need to pop/push the stack 11 | ; pop rcx ; length of string 12 | ; pop rdi ; start address of string 13 | call .NUMBER 14 | ; push rax ; parsed number 15 | ; push rcx ; number of unparsed characters (0 = no error) 16 | ret 17 | 18 | .NUMBER: 19 | xor rax, rax 20 | xor rbx, rbx 21 | 22 | test rcx, rcx ; trying to parse a zero-length string is an error, but will return 0. 23 | 24 | jz .ret 25 | 26 | mov rdx, [var_BASE] ; get BASE (in dl) 27 | 28 | ; Check if first character is '-'. 29 | mov bl, [rdi] ; bl = first character in string 30 | inc rdi 31 | push rax ; push 0 on stack 32 | cmp bl, '-' ; negative number? 33 | jnz .convert 34 | pop rax 35 | push rbx ; push <> 0 on stack, indicating negative 36 | dec rcx 37 | jnz .loop 38 | pop rbx ; error: string is only '-'. 39 | mov rcx, 1 40 | ret 41 | 42 | ; Loop reading digits. 43 | .loop: 44 | imul rax, rdx ; rax *= BASE 45 | mov bl, [rdi] ; bl = next character in string 46 | inc rdi 47 | 48 | ; Convert 0-9, A-Z to a number 0-35. 49 | .convert: 50 | sub bl, '0' ; < '0'? 51 | jb .finish 52 | cmp bl, 10 ; <= '9'? 53 | jb .digit 54 | sub bl, 17 ; < 'A'? (17 is 'A'-'0') 55 | jb .finish 56 | add bl, 10 57 | 58 | .digit: 59 | cmp bl, dl ; >= BASE? 60 | jge .finish 61 | 62 | ; OK, so add it to rax and loop. 63 | add rax, rbx 64 | dec rcx 65 | jnz .loop 66 | 67 | ; Negate the result if first character was '-' (saved on the stack). 68 | .finish: 69 | pop rbx 70 | test rbx,rbx 71 | jz .ret 72 | neg rax 73 | 74 | .ret: 75 | ret 76 | 77 | section .text 78 | global main 79 | main: 80 | mov rdi, str ; address 81 | mov rcx, [len] ; len 82 | call NUMBER 83 | mov rsi, rax 84 | mov rdi, format 85 | xor rax, rax 86 | call printf 87 | 88 | section .data 89 | align 8 90 | str: db "31" 91 | align 8 92 | len: dq 2 93 | format: db "%d",0x0A,0x00 94 | -------------------------------------------------------------------------------- /jombloforth.asm: -------------------------------------------------------------------------------- 1 | ;; -*- nasm -*- 2 | ;; 3 | ;; Minimal FORTH interpreter for 64-bit Linux systems. 4 | ;; Based on jonesforth 5 | ;; 6 | ;; compile it with: 7 | ;; 8 | ;; nasm -g -F dwarf -f elf64 -o jombloforth.o jombloforth.asm 9 | ;; ld -o jombloforth jombloforth.o 10 | ;; 11 | ;; 12 | ;; UNLICENSE 13 | ;; --------- 14 | ;; 15 | ;; This is free and unencumbered software released into the public 16 | ;; domain. 17 | ;; 18 | ;; Anyone is free to copy, modify, publish, use, compile, sell, or 19 | ;; distribute this software, either in source code form or as a compiled 20 | ;; binary, for any purpose, commercial or non-commercial, and by any 21 | ;; means. 22 | ;; 23 | ;; In jurisdictions that recognize copyright laws, the author or authors 24 | ;; of this software dedicate any and all copyright interest in the 25 | ;; software to the public domain. We make this dedication for the benefit 26 | ;; of the public at large and to the detriment of our heirs and 27 | ;; successors. We intend this dedication to be an overt act of 28 | ;; relinquishment in perpetuity of all present and future rights to this 29 | ;; software under copyright law. 30 | ;; 31 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 32 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 33 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 34 | ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 35 | ;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 36 | ;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 37 | ;; OTHER DEALINGS IN THE SOFTWARE. 38 | ;; 39 | ;; For more information, please refer to 40 | 41 | 42 | ;; syscall number, generated using this command: 43 | ;; 44 | ;; sed 's_#_%_;s_/\*_;_;s_ \*/__' /usr/include/x86_64-linux-gnu/asm/unistd_64.h > unistd_64.inc 45 | ;; 46 | %include "unistd_64.inc" 47 | 48 | ;; see buffer allocation 49 | %define RETURN_STACK_SIZE 8192 50 | %define BUFFER_SIZE 4096 51 | 52 | 53 | 54 | ;; MACRO DEFINITION 55 | ;; ---------------- 56 | 57 | ;; The version of this program, not to be mistaken as how many years the 58 | ;; author has been single. Please increment this number each time one year 59 | ;; passed. 60 | %assign JOMBLO_VERSION 2 61 | ;; (that's a joke, btw) 62 | 63 | ;; Our first word 64 | %macro NEXT 0 65 | lodsq 66 | jmp [rax] 67 | %endmacro 68 | 69 | ;; Helper for pushing/popping from the return stack 70 | 71 | %macro PUSHRSP 1 72 | lea rbp, [rbp-8] 73 | mov [rbp], %1 74 | %endmacro 75 | 76 | %macro POPRSP 1 77 | mov %1, [rbp] 78 | lea rbp, [rbp+8] 79 | %endmacro 80 | 81 | ;; First Non-Macro Word 82 | section .text 83 | DOCOL: 84 | PUSHRSP rsi 85 | add rax, 8 86 | mov rsi, rax 87 | NEXT 88 | 89 | 90 | global _start 91 | _start: 92 | cld ; Clear direction flag 93 | ; Save the initial data stack pointer in variable S0 94 | mov [var_S0], rsp 95 | mov rbp, return_stack_top ; Initialize the return stack 96 | call set_up_data_segment 97 | mov rsi, cold_start 98 | NEXT 99 | 100 | section .rodata 101 | cold_start: 102 | dq QUIT 103 | 104 | ;; Various flags for the dictionary word header 105 | %define F_IMMED 0x80 106 | %define F_HIDDEN 0x20 107 | %define F_LENMASK 0x1f 108 | 109 | ;; Holds previously defined word 110 | ;; Starts as null/zero 111 | %define link 0 112 | 113 | ;; Macro for defining forth word 114 | ;; 115 | ;; defword name, label, flag 116 | ;; 117 | %macro defword 2-3 0 118 | %strlen name_len %1 119 | 120 | ;; dictionary word header 121 | section .rodata 122 | 123 | align 8, db 0 124 | global name_%2 125 | name_%2: 126 | dq link 127 | db name_len + %3 128 | db %1 129 | 130 | ;; update link to point to this word's header 131 | %define link name_%2 132 | 133 | ;; word definitions, starts with DOCOL 134 | align 8, db 0 135 | global %2 136 | %2: 137 | dq DOCOL 138 | %endmacro 139 | 140 | 141 | ;; Macro for defining native word 142 | ;; 143 | ;; defcode name, label, flag 144 | ;; 145 | %macro defcode 2-3 0 146 | %strlen name_len %1 147 | 148 | ;; dictionary word header 149 | section .rodata 150 | align 8, db 0 151 | global name_%2 152 | name_%2: 153 | dq link 154 | db name_len + %3 155 | db %1 156 | 157 | ;; update link to point to this word's header 158 | %define link name_%2 159 | 160 | ;; word definition, link to the native code 161 | align 8, db 0 162 | global $%2 ; fix error for `WORD` which isn't valid label 163 | $%2: 164 | dq code_%2 165 | 166 | ;; native code 167 | section .text 168 | align 8 169 | global code_%2 170 | code_%2: 171 | %endmacro 172 | 173 | defcode "DROP", DROP 174 | pop rax 175 | NEXT 176 | 177 | defcode "SWAP", SWAP 178 | pop rax 179 | pop rbx 180 | push rax 181 | push rbx 182 | NEXT 183 | 184 | defcode "DUP", DUP 185 | mov rax, [rsp] 186 | push rax 187 | NEXT 188 | 189 | defcode "OVER", OVER 190 | mov rax, [rsp+8] 191 | push rax 192 | NEXT 193 | 194 | defcode "ROT", ROT 195 | pop rax 196 | pop rbx 197 | pop rcx 198 | push rbx 199 | push rax 200 | push rcx 201 | NEXT 202 | 203 | defcode "-ROT", NROT 204 | pop rax 205 | pop rbx 206 | pop rcx 207 | push rax 208 | push rcx 209 | push rbx 210 | NEXT 211 | 212 | defcode "2DROP", TWODROP 213 | pop rax 214 | pop rax 215 | NEXT 216 | 217 | defcode "2DUP", TWODUP 218 | mov rax, [rsp] 219 | mov rbx, [rsp+8] 220 | push rbx 221 | push rax 222 | NEXT 223 | 224 | defcode "2SWAP", TWOSWAP 225 | pop rax 226 | pop rbx 227 | pop rcx 228 | pop rdx 229 | push rbx 230 | push rax 231 | push rdx 232 | push rcx 233 | NEXT 234 | 235 | defcode "?DUP", QDUP 236 | mov rax, [rsp] 237 | test rax, rax 238 | jz .next 239 | push rax 240 | .next NEXT 241 | 242 | defcode "1+", INCR 243 | inc qword [rsp] 244 | NEXT 245 | 246 | defcode "1-", DECR 247 | dec qword [rsp] 248 | NEXT 249 | 250 | defcode "8+", INCR8 251 | add qword [rsp], 8 252 | NEXT 253 | 254 | defcode "8-", DECR8 255 | sub qword [rsp], 8 256 | NEXT 257 | 258 | defcode "+", ADD 259 | pop rax 260 | add [rsp], rax 261 | NEXT 262 | 263 | defcode "-", SUB 264 | pop rax 265 | sub [rsp], rax 266 | NEXT 267 | 268 | defcode "*", MUL 269 | pop rax 270 | pop rbx 271 | imul rax, rbx 272 | push rax 273 | NEXT 274 | 275 | defcode "/MOD", DIVMOD 276 | xor rdx, rdx 277 | pop rbx 278 | pop rax 279 | idiv rbx 280 | push rdx 281 | push rax 282 | NEXT 283 | 284 | ;;;; Comparison Words 285 | 286 | %macro defcmp 3 287 | defcode %1, %2 288 | pop rax 289 | pop rbx 290 | cmp rbx, rax 291 | set%+3 al 292 | movzx rax, al 293 | push rax 294 | NEXT 295 | %endmacro 296 | 297 | defcmp "=", EQU, e 298 | defcmp "<>", NEQ, ne 299 | defcmp "<", LT, l 300 | defcmp ">", GT, g 301 | defcmp "<=", LE, le 302 | defcmp ">=", GE, ge 303 | 304 | %macro deftest 3 305 | defcode %1, %2 306 | pop rax 307 | test rax, rax 308 | set%+3 al 309 | movzx rax, al 310 | push rax 311 | NEXT 312 | %endmacro 313 | 314 | deftest "0=", ZEQU, z 315 | deftest "0<>", ZNEQU, nz 316 | deftest "0<", ZLT, l 317 | deftest "0>", ZGT, g 318 | deftest "0<=", ZLE, le 319 | deftest "0>=", ZGE, ge 320 | 321 | defcode "AND", AND 322 | pop rax 323 | and [rsp], rax 324 | NEXT 325 | 326 | defcode "OR", OR 327 | pop rax 328 | or [rsp], rax 329 | NEXT 330 | 331 | defcode "XOR", XOR 332 | pop rax 333 | xor [rsp], rax 334 | NEXT 335 | 336 | defcode "INVERT", INVERT 337 | not qword [rsp] 338 | NEXT 339 | 340 | ;;;; Exiting a Word 341 | 342 | defcode "EXIT", EXIT 343 | POPRSP rsi 344 | NEXT 345 | 346 | ;; Literal 347 | 348 | defcode "LIT", LIT 349 | lodsq 350 | push rax 351 | NEXT 352 | 353 | ;;;; MEMORY 354 | 355 | defcode "!", STORE 356 | pop rbx 357 | pop rax 358 | mov [rbx], rax 359 | NEXT 360 | 361 | defcode "@", FETCH 362 | pop rbx 363 | mov rax, [rbx] 364 | push rax 365 | NEXT 366 | 367 | defcode "+!", ADDSTORE 368 | pop rbx 369 | pop rax 370 | add [rbx], rax 371 | NEXT 372 | 373 | defcode "-!", SUBSTORE 374 | pop rbx 375 | pop rax 376 | sub [rbx], rax 377 | NEXT 378 | 379 | defcode "C!", STOREBYTE 380 | pop rbx 381 | pop rax 382 | mov [rbx], al 383 | NEXT 384 | 385 | defcode "C@", FETCHBYTE 386 | pop rbx 387 | xor rax, rax 388 | mov al, [rbx] 389 | push rax 390 | NEXT 391 | 392 | defcode "C@C!", CCOPY 393 | mov rbx, [rsp+8] 394 | mov al, [rbx] 395 | pop rdi 396 | stosb 397 | push rdi 398 | inc qword [rsp+8] 399 | NEXT 400 | 401 | defcode "CMOVE", CMOVE 402 | mov rdx, rsi 403 | pop rcx 404 | pop rdi 405 | pop rsi 406 | rep movsb 407 | mov rsi, rdx 408 | NEXT 409 | 410 | ;;;; BUILT-IN VARIABLE 411 | 412 | %macro defvar 2-4 0, 0 413 | defcode %1, %2, %4 414 | push var_%2 415 | NEXT 416 | 417 | ;; data storage 418 | section .data 419 | align 8, db 0 420 | var_%2: 421 | dq %3 422 | %endmacro 423 | 424 | defvar "STATE", STATE 425 | defvar "HERE", HERE 426 | defvar "LATEST", LATEST, name_SYSCALL0 427 | defvar "S0", S0 428 | defvar "BASE", BASE, 10 429 | 430 | %macro defconst 3-4 0 431 | defcode %1, %2, %4 432 | push %3 433 | NEXT 434 | %endmacro 435 | 436 | defconst "VERSION", VERSION, JOMBLO_VERSION 437 | defconst "R0", R0, return_stack_top 438 | defconst "DOCOL", __DOCOL, DOCOL 439 | 440 | defconst "F_IMMED", __F_IMMED, F_IMMED 441 | defconst "F_HIDDEN", __F_HIDDEN, F_HIDDEN 442 | defconst "F_LENMASK", __F_LENMASK, F_LENMASK 443 | 444 | %macro defsys 2 445 | %defstr name SYS_%1 446 | defconst name, SYS_%1, __NR_%2 447 | %endmacro 448 | 449 | defsys EXIT, exit 450 | defsys OPEN, open 451 | defsys CLOSE, close 452 | defsys READ, read 453 | defsys WRITE, write 454 | defsys CREAT, creat 455 | defsys BRK, brk 456 | 457 | %macro defo 2 458 | %defstr name O_%1 459 | defconst name, __O_%1, %2 460 | %endmacro 461 | 462 | defo RDONLY, 0o 463 | defo WRONLY, 1o 464 | defo RDWR, 2o 465 | defo CREAT, 100o 466 | defo EXCL, 200o 467 | defo TRUNC, 1000o 468 | defo APPEND, 2000o 469 | defo NONBLOCK, 4000o 470 | 471 | ;;;; RETURN STACK 472 | 473 | defcode ">R", TOR 474 | pop rax 475 | PUSHRSP rax 476 | NEXT 477 | 478 | defcode "R>", FROMR 479 | POPRSP rax 480 | push rax 481 | NEXT 482 | 483 | defcode "RSP@", RSPFETCH 484 | push rbp 485 | NEXT 486 | 487 | defcode "RSP!", RSPSTORE 488 | pop rbp 489 | NEXT 490 | 491 | defcode "RDROP", RDROP 492 | add rbp, 8 493 | NEXT 494 | 495 | 496 | ;;;; PARAMETER (DATA) STACK 497 | 498 | defcode "DSP@", DSPFETCH 499 | mov rax, rsp 500 | push rax 501 | NEXT 502 | 503 | defcode "DSP!", DSPSTORE 504 | pop rsp 505 | NEXT 506 | 507 | ;;;; INPUT OUTPUT 508 | 509 | defcode "KEY", KEY 510 | call _KEY 511 | push rax 512 | NEXT 513 | _KEY: 514 | mov rbx, [currkey] 515 | cmp rbx, [bufftop] 516 | jge .full 517 | xor rax, rax 518 | mov al, [rbx] 519 | inc rbx 520 | mov [currkey], rbx 521 | ret 522 | 523 | .full: 524 | push rsi ; save rsi temporarily 525 | push rdi ; and rdi 526 | xor rdi, rdi ; stdin (0) 527 | mov rsi, buffer ; pointer to the buffer 528 | mov [currkey], rsi 529 | mov rdx, BUFFER_SIZE ; how many bytes to read max 530 | mov rax, __NR_read ; read(0, buffer, size) 531 | syscall 532 | test rax, rax 533 | jbe .eof 534 | add rsi, rax 535 | mov [bufftop], rsi 536 | pop rdi ; restore 537 | pop rsi ; and restore 538 | jmp _KEY 539 | 540 | .eof: 541 | xor rdi, rdi 542 | mov rax, __NR_exit 543 | syscall 544 | 545 | section .data 546 | align 8, db 0 547 | currkey: 548 | dq buffer 549 | bufftop: 550 | dq buffer 551 | 552 | defcode "EMIT", EMIT 553 | pop rax 554 | call _EMIT 555 | NEXT 556 | _EMIT: 557 | mov rdi, 1 ; stdout (1) 558 | mov [emit_scratch], al ; save the byte to scratch buffer 559 | push rsi ; save rsi temporarily 560 | mov rsi, emit_scratch 561 | mov rdx, 1 ; how many bytes to write 562 | mov rax, __NR_write ; write(1, scratch, 1) 563 | syscall 564 | pop rsi ; restore it 565 | ret 566 | 567 | section .data 568 | emit_scratch: db 0 569 | 570 | defcode "WORD", WORD 571 | call _WORD 572 | push rdi 573 | push rcx 574 | NEXT 575 | 576 | _WORD: 577 | .ws: 578 | call _KEY 579 | cmp al, '\' 580 | je .comment 581 | cmp al, ' ' 582 | jbe .ws 583 | 584 | mov rdi, word_buffer 585 | .word: 586 | stosb 587 | call _KEY 588 | cmp al, ' ' 589 | ja .word 590 | 591 | sub rdi, word_buffer 592 | mov rcx, rdi 593 | mov rdi, word_buffer 594 | ret 595 | 596 | .comment: 597 | call _KEY 598 | cmp al, 0x0A 599 | jne .comment 600 | jmp .ws 601 | 602 | section .data 603 | word_buffer: times 32 db 0 604 | 605 | defcode "NUMBER", NUMBER 606 | pop rcx 607 | pop rdi 608 | call _NUMBER 609 | push rax 610 | push rcx 611 | NEXT 612 | 613 | _NUMBER: 614 | xor rax, rax 615 | xor rbx, rbx 616 | 617 | test rcx, rcx ; trying to parse zero-length string is an error, but will return 0. 618 | jz .ret 619 | 620 | mov rdx, [var_BASE] ; get BASE (in dl) 621 | mov bl, [rdi] ; bl = first character in string 622 | inc rdi 623 | push rax ; push 0 on stack 624 | cmp bl, '-' ; negative number? 625 | jnz .convert 626 | pop rax 627 | push rbx ; push <> 0 on stack, indicating negative 628 | dec rcx 629 | jnz .loop 630 | pop rbx 631 | mov rcx, 1 632 | ret 633 | 634 | ; Loop reading digits. 635 | .loop: 636 | imul rax, rdx ; rax *= BASE 637 | mov bl, [rdi] ; bl = next character in string 638 | inc rdi 639 | 640 | .convert: 641 | sub bl, '0' ; < '0'? 642 | jb .finish 643 | cmp bl, 10 ; <= '9'? 644 | jb .numeric 645 | sub bl, 17 ; < 'A'? (17 is 'A'-'0') 646 | jb .finish 647 | add bl, 10 648 | 649 | .numeric: 650 | cmp bl, dl ; >= BASE? 651 | jge .finish 652 | 653 | ; OK, so add it to rax and loop 654 | add rax, rbx 655 | dec rcx 656 | jnz .loop 657 | 658 | ; Negate the result if the first character was '-' (saved on the stack) 659 | .finish: 660 | pop rbx 661 | test rbx, rbx 662 | jz .ret 663 | neg rax 664 | 665 | .ret: 666 | ret 667 | 668 | 669 | ;;;; Dictionary Looks Ups 670 | 671 | defcode "FIND", FIND 672 | pop rcx 673 | pop rdi 674 | call _FIND 675 | push rax 676 | NEXT 677 | 678 | _FIND: 679 | push rsi ; save rsi so that we can use it in string comparison 680 | 681 | ; now we start searching the dictionary for this word 682 | mov rdx, [var_LATEST] ; LATEST points to name header of the latest word in the dictionary 683 | .loop: 684 | test rdx, rdx ; NULL pointer? 685 | je .notfound 686 | 687 | ; Compare the length expected and the length of the word. 688 | ; Note that if the F_HIDDEN flag is set on the word, then by a bit of trickery 689 | ; this won't pick the word (the length will appear to be wrong). 690 | xor rax,rax 691 | mov al, [rdx+8] ; al = flags+length field 692 | and al, F_HIDDEN | F_LENMASK ; al = name length 693 | cmp al, cl ; Length is the same? 694 | jne .next 695 | 696 | ; Compare the strings in detail. 697 | push rcx ; Save the length 698 | push rdi ; Save the address (repe cmpsb will move this pointer) 699 | lea rsi, [rdx+9] ; Dictionary string we are checking against. 700 | repe cmpsb ; Compare the strings. 701 | pop rdi 702 | pop rcx 703 | jne .next ; Not the same. 704 | 705 | ; The strings are the same - return the header pointer in rax 706 | pop rsi 707 | mov rax, rdx 708 | ret 709 | 710 | .next: 711 | mov rdx, [rdx] ; Move back through the link field to the previous word 712 | jmp .loop ; .. and loop. 713 | 714 | .notfound: 715 | pop rsi 716 | xor rax,rax ; Return zero to indicate not found. 717 | ret 718 | 719 | defcode ">CFA", TCFA 720 | pop rdi 721 | call _TCFA 722 | push rdi 723 | NEXT 724 | 725 | _TCFA: 726 | xor rax, rax 727 | add rdi, 8 ; skip link pointer 728 | mov al, [rdi] ; load flags+len into al 729 | inc rdi ; skip flags+len byte 730 | and al, F_LENMASK ; just the length, not the flags 731 | add rdi, rax ; skip the name 732 | add rdi, 0b111 ; the codeword is 8-byte aligned 733 | and rdi, ~0b111 734 | ret 735 | 736 | defword ">DFA", TDFA 737 | dq TCFA 738 | dq INCR8 739 | dq EXIT 740 | 741 | ;;;; Compiling 742 | 743 | defcode "CREATE", CREATE 744 | ; Get the name length and address. 745 | pop rcx ; rcx = length 746 | pop rbx ; rbx = address of name 747 | 748 | ; Link pointer. 749 | mov rdi, [var_HERE] ; rdi is the address of the header 750 | mov rax, [var_LATEST] ; Get link pointer 751 | stosq ; and store it in the header. 752 | 753 | ; Length byte and the word itself. 754 | mov al, cl ; Get the length. 755 | stosb ; Store the length/flags byte. 756 | push rsi 757 | mov rsi, rbx ; rsi = word 758 | rep movsb ; Copy the word 759 | pop rsi 760 | add rdi, 0b111 ; Align to next 8 byte boundary. 761 | and rdi, ~0b111 762 | 763 | ; Update LATEST and HERE. 764 | mov rax, [var_HERE] 765 | mov [var_LATEST], rax 766 | mov [var_HERE], rdi 767 | NEXT 768 | 769 | defcode ",", COMMA 770 | pop rax 771 | call _COMMA 772 | NEXT 773 | 774 | _COMMA: 775 | mov rdi, [var_HERE] ; HERE 776 | stosq ; Store it. 777 | mov [var_HERE], rdi ; Update HERE (incremented) 778 | ret 779 | 780 | defcode "[", LBRAC, F_IMMED 781 | xor rax, rax 782 | mov [var_STATE], rax 783 | NEXT 784 | 785 | defcode "]", RBRAC 786 | mov qword [var_STATE], 1 787 | NEXT 788 | 789 | defword ":", COLON 790 | dq $WORD 791 | dq CREATE 792 | dq LIT, DOCOL, COMMA 793 | dq LATEST, FETCH, HIDDEN 794 | dq RBRAC 795 | dq EXIT 796 | 797 | defword ";", SEMICOLON, F_IMMED 798 | dq LIT, EXIT, COMMA 799 | dq LATEST, FETCH, HIDDEN 800 | dq LBRAC 801 | dq EXIT 802 | 803 | 804 | defcode "IMMEDIATE", IMMEDATE, F_IMMED 805 | mov rdi, [var_LATEST] 806 | add rdi, 8 807 | xor byte [rdi], F_IMMED 808 | NEXT 809 | 810 | defcode "HIDDEN", HIDDEN 811 | pop rdi 812 | add rdi, 8 813 | xor byte [rdi], F_HIDDEN 814 | NEXT 815 | 816 | defword "HIDE", HIDE 817 | dq $WORD 818 | dq FIND 819 | dq HIDDEN 820 | dq EXIT 821 | 822 | defcode "'", TICK 823 | lodsq 824 | push rax 825 | NEXT 826 | 827 | ;;;; Branching 828 | 829 | defcode "BRANCH", BRANCH 830 | add rsi, [rsi] 831 | NEXT 832 | 833 | defcode "0BRANCH", ZBRANCH 834 | pop rax 835 | test rax, rax 836 | jz code_BRANCH 837 | lodsq 838 | NEXT 839 | 840 | ;;;; Literal String 841 | 842 | defcode "LITSTRING", LITSTRING 843 | lodsq 844 | push rsi 845 | push rax 846 | add rsi, rax 847 | add rsi, 0b111 848 | and rsi, ~0b111 849 | NEXT 850 | 851 | defcode "TELL", TELL 852 | mov rcx, rsi ; save temporarily 853 | mov rdi, 1 ; 1st param = stdout(1) 854 | pop rdx ; 3nd param = length of string 855 | pop rsi ; 2nd param = the string 856 | mov rax, __NR_write 857 | push rcx ; save previous value of rsi in the stack 858 | syscall 859 | pop rsi ; restore rsi 860 | NEXT 861 | 862 | ;;;; Part of Testing 863 | 864 | defword "FORTYTWO", FORTYTWO 865 | dq LIT 866 | dq 42 867 | dq EXIT 868 | 869 | ;;;; Quit and Interpret 870 | 871 | defword "QUIT", QUIT 872 | dq R0, RSPSTORE 873 | dq INTERPRET 874 | dq BRANCH, -16 875 | 876 | defcode "INTERPRET", INTERPRET 877 | call _WORD ; return rcx = length, rdi = pointer to word 878 | 879 | ; Is it in the dictionary? 880 | xor rax, rax 881 | mov [interpret_is_lit], rax ; Not a literal number (not yet anyway ...) 882 | call _FIND ; Return rax = pointer to header or 0 if not found 883 | test rax, rax ; Found? 884 | jz .number 885 | 886 | ; In the dictionary. Is it an IMMEDIATE codeword? 887 | mov rdi, rax ; rdi = dictionary entry 888 | mov al, [rdi+8] ; Get name+flags. 889 | push ax ; Just save it for now 890 | call _TCFA ; Convert dictionary entry in rdi to codeword pointer 891 | pop ax 892 | and al, F_IMMED ; Is IMMED flag set? 893 | mov rax, rdi 894 | jnz .exec ; If IMMED, jump straight to executing 895 | 896 | jmp .main 897 | 898 | ; Not in the dictionary (not a word) so assume it's a literal number. 899 | .number: 900 | inc qword [interpret_is_lit] 901 | call _NUMBER ; Returns the parsed number in rax, rcx > 0 if error 902 | test rcx, rcx 903 | jnz .numerror 904 | mov rbx, rax 905 | mov rax, LIT ; The word is LIT 906 | 907 | ; Are we compiling or executing? 908 | .main: 909 | mov rdx, [var_STATE] 910 | test rdx, rdx 911 | jz .exec ; Jump if executing. 912 | 913 | ; Compiling - just append the word to the current dictionary definition. 914 | call _COMMA 915 | mov rcx, [interpret_is_lit] ; Was it a literal? 916 | test rcx, rcx 917 | jz .next 918 | mov rax, rbx ; Yes, so LIT is followed by a number. 919 | call _COMMA 920 | .next: 921 | NEXT 922 | 923 | ; Executing - run it! 924 | .exec: 925 | mov rcx, [interpret_is_lit] ; Literal? 926 | test rcx, rcx ; Literal? 927 | jnz .litexec 928 | 929 | ; Not a literal, execute it now. This never returns, but the codeword will 930 | ; eventually call NEXT which will reenter the loop in QUIT. 931 | jmp [rax] 932 | 933 | ; Executing a literal, which means push it on the stack. 934 | .litexec: 935 | push rbx 936 | NEXT 937 | 938 | ; Parse error (not a known word or a number in the current BASE). 939 | .numerror: 940 | ; Print an error message followed by up to 40 characters of context. 941 | push rsi 942 | 943 | mov rdi, 2 ; 1st param: stderr(2) 944 | mov rsi, errmsg ; 2nd param: error message 945 | mov rdx, errmsglen ; 3rd param: length of string 946 | mov rax, __NR_write ; write syscall 947 | syscall 948 | 949 | mov rsi, [currkey] ; the error occurred just before currkey position 950 | mov rdx, rsi 951 | sub rdx, buffer ; rdx = currkey - buffer (length in buffer before currkey) 952 | cmp rdx, 40 ; if > 40, then print only 40 characters 953 | jle .le 954 | mov rdx, 40 955 | .le: 956 | sub rsi, rdx ; rcx = start of area to print, rdx = length 957 | mov rax, __NR_write ; write syscall 958 | syscall 959 | 960 | mov rsi, errmsgnl ; newline 961 | mov rdx, 1 962 | mov rax, __NR_write ; write syscall 963 | syscall 964 | pop rsi 965 | 966 | NEXT 967 | 968 | section .rodata 969 | errmsg: db "PARSE ERROR: " 970 | errmsglen: equ $ - errmsg 971 | errmsgnl: db 0x0A 972 | 973 | section .data ; NB: easier to fit in the .data section 974 | align 8 975 | interpret_is_lit: 976 | dq 0 ; Flag used to record if reading a literal 977 | 978 | ;;;; Odds and Ends 979 | 980 | defcode "CHAR", CHAR 981 | call _WORD ; Returns rcx = length, rdi = pointer to word. 982 | xor rax, rax 983 | mov al, [rdi] ; Get the first character of the word. 984 | push rax ; Push it onto the stack. 985 | NEXT 986 | 987 | defcode "EXECUTE", EXECUTE 988 | pop rax ; Get xt into rax 989 | jmp [rax] ; and jump to it. 990 | ; After xt runs its NEXT will continue executing the current word. 991 | 992 | defcode "SYSCALL3", SYSCALL3 993 | mov rcx, rsi ; Save rsi 994 | pop rax ; System call number (see ) 995 | pop rdi ; First parameter. 996 | pop rsi ; Second parameter 997 | pop rdx ; Third parameter 998 | push rcx ; Save previous value of rsi on stack 999 | syscall 1000 | pop rsi ; restore 1001 | push rax ; Result (negative for -errno) 1002 | NEXT 1003 | 1004 | defcode "SYSCALL2", SYSCALL2 1005 | mov rcx, rsi 1006 | pop rax ; System call number (see ) 1007 | pop rdi ; First parameter. 1008 | pop rsi ; Second parameter 1009 | push rcx 1010 | syscall 1011 | pop rsi 1012 | push rax ; Result (negative for -errno) 1013 | NEXT 1014 | 1015 | defcode "SYSCALL1", SYSCALL1 1016 | pop rax ; System call number (see ) 1017 | pop rdi ; First parameter. 1018 | syscall 1019 | push rax ; Result (negative for -errno) 1020 | NEXT 1021 | 1022 | defcode "SYSCALL0", SYSCALL0 1023 | pop rax ; System call number (see ) 1024 | syscall 1025 | push rax ; Result (negative for -errno) 1026 | NEXT 1027 | 1028 | 1029 | ;;;; Data Segment 1030 | %define INITIAL_DATA_SEGMENT_SIZE 65536 1031 | 1032 | section .text 1033 | set_up_data_segment: 1034 | xor rdi, rdi 1035 | mov rax, __NR_brk ; brk(0) 1036 | syscall 1037 | mov [var_HERE], rax 1038 | add rax, INITIAL_DATA_SEGMENT_SIZE 1039 | mov rdi, rax 1040 | mov rax, __NR_brk 1041 | syscall 1042 | ret 1043 | 1044 | ;;;; buffers allocation 1045 | 1046 | section .bss 1047 | align 4096 1048 | return_stack: 1049 | resb RETURN_STACK_SIZE 1050 | return_stack_top: 1051 | 1052 | align 4096 1053 | buffer: 1054 | resb BUFFER_SIZE 1055 | -------------------------------------------------------------------------------- /jombloforth.f: -------------------------------------------------------------------------------- 1 | \ Part 2 of the JonesForth tutorial. 2 | \ This one is added word-by-word as they are succesfully executed 3 | 4 | \ Define / and MOD in terms of /MOD 5 | : / /MOD SWAP DROP ; 6 | : MOD /MOD DROP ; 7 | 8 | \ Some char constant 9 | : '\n' 10 ; 10 | : BL 32 ; \ BL (blank) is standard FORTH word for space. 11 | 12 | : CR '\n' EMIT ; 13 | : SPACE BL EMIT ; 14 | 15 | : NEGATE 0 SWAP - ; 16 | 17 | : TRUE 1 ; 18 | : FALSE 0 ; 19 | : NOT 0= ; 20 | 21 | \ LITERAL takes whatever on the stack and compiles LIT 22 | : LITERAL IMMEDIATE 23 | ' LIT , 24 | , 25 | ; 26 | 27 | : ':' 28 | [ 29 | CHAR : 30 | ] 31 | LITERAL 32 | ; 33 | 34 | : ';' [ CHAR ; ] LITERAL ; 35 | : '(' [ CHAR ( ] LITERAL ; 36 | : ')' [ CHAR ) ] LITERAL ; 37 | : '"' [ CHAR " ] LITERAL ; 38 | : 'A' [ CHAR A ] LITERAL ; 39 | : '0' [ CHAR 0 ] LITERAL ; 40 | : '-' [ CHAR - ] LITERAL ; 41 | : '.' [ CHAR . ] LITERAL ; 42 | 43 | : [COMPILE] IMMEDIATE 44 | WORD 45 | FIND 46 | >CFA 47 | , 48 | ; 49 | 50 | : RECURSE IMMEDIATE 51 | LATEST @ 52 | >CFA 53 | , 54 | ; 55 | 56 | \ Conditionals Statements 57 | 58 | : IF IMMEDIATE 59 | ' 0BRANCH , 60 | HERE @ 61 | 0 , 62 | ; 63 | 64 | : THEN IMMEDIATE 65 | DUP 66 | HERE @ SWAP - 67 | SWAP ! 68 | ; 69 | 70 | : ELSE IMMEDIATE 71 | ' BRANCH , 72 | HERE @ 73 | 0 , 74 | SWAP 75 | DUP 76 | HERE @ SWAP - 77 | SWAP ! 78 | ; 79 | 80 | : UNLESS IMMEDIATE 81 | ' NOT , 82 | [COMPILE] IF 83 | ; 84 | 85 | \ Loop Construct 86 | 87 | : BEGIN IMMEDIATE 88 | HERE @ 89 | ; 90 | 91 | : UNTIL IMMEDIATE 92 | ' 0BRANCH , 93 | HERE @ - 94 | , 95 | ; 96 | 97 | : AGAIN IMMEDIATE 98 | ' BRANCH , 99 | HERE @ - 100 | , 101 | ; 102 | 103 | : WHILE IMMEDIATE 104 | ' 0BRANCH , 105 | HERE @ 106 | 0 , 107 | ; 108 | 109 | : REPEAT IMMEDIATE 110 | ' BRANCH , 111 | SWAP 112 | HERE @ - , 113 | DUP 114 | HERE @ SWAP - 115 | SWAP ! 116 | ; 117 | 118 | \ Comments 119 | : ( IMMEDIATE 120 | 1 121 | BEGIN 122 | KEY 123 | DUP '(' = IF 124 | DROP 125 | 1+ 126 | ELSE 127 | ')' = IF 128 | 1- 129 | THEN 130 | THEN 131 | DUP 0= UNTIL 132 | DROP 133 | ; 134 | 135 | ( Now we can nest ( ... ) as much as we want ) 136 | 137 | \ Stack Manipulation 138 | : NIP ( x y -- y ) SWAP DROP ; 139 | : TUCK ( x y -- y x y ) SWAP OVER ; 140 | : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u ) 141 | 1+ 142 | 8 * ( multiply by the word size ) 143 | DSP@ + 144 | @ 145 | ; 146 | 147 | \ Writes N spaces to stdout 148 | : SPACES ( n -- ) 149 | BEGIN 150 | DUP 0> 151 | WHILE 152 | SPACE 153 | 1- 154 | REPEAT 155 | DROP 156 | ; 157 | 158 | \ EXTRA: Writes N zeroes to stdout 159 | : ZEROES ( n -- ) 160 | BEGIN 161 | DUP 0> 162 | WHILE 163 | '0' EMIT 164 | 1- 165 | REPEAT 166 | DROP 167 | ; 168 | 169 | \ Standard word for manipulating BASE. 170 | : DECIMAL ( -- ) 10 BASE ! ; 171 | : HEX ( -- ) 16 BASE ! ; 172 | 173 | ( Printing Numbers ) 174 | 175 | : U. ( u -- ) 176 | BASE @ /MOD 177 | ?DUP IF ( if quotient <> 0 then ) 178 | RECURSE ( print the quotient ) 179 | THEN 180 | 181 | ( print the remainder ) 182 | DUP 10 < IF 183 | '0' 184 | ELSE 185 | 10 - 186 | 'A' 187 | THEN 188 | + 189 | EMIT 190 | ; 191 | 192 | ( Printing the content of the stack ) 193 | : .S ( -- ) 194 | DSP@ 195 | BEGIN 196 | DUP S0 @ < 197 | WHILE 198 | DUP @ U. 199 | SPACE 200 | 8+ 201 | REPEAT 202 | DROP 203 | ; 204 | 205 | ( Returns the width of an unsigned number (in characters) in the current base ) 206 | : UWIDTH 207 | BASE @ / 208 | ?DUP IF 209 | RECURSE 1+ 210 | ELSE 211 | 1 212 | THEN 213 | ; 214 | 215 | : U.R ( u width -- ) 216 | SWAP 217 | DUP 218 | UWIDTH 219 | ROT 220 | SWAP - 221 | SPACES 222 | U. 223 | ; 224 | 225 | \ EXTRA, print zeroes padded unsigned number 226 | : ZU.R ( u width -- ) 227 | SWAP 228 | DUP 229 | UWIDTH 230 | ROT 231 | SWAP - 232 | ZEROES 233 | U. 234 | ; 235 | 236 | : .R ( n width -- ) 237 | SWAP ( width n ) 238 | DUP 0< IF 239 | NEGATE ( width u ) 240 | 1 ( save flag to remember that it was negative | width u 1 ) 241 | SWAP ( width 1 u ) 242 | ROT ( 1 u width ) 243 | 1- ( 1 u width-1 ) 244 | ELSE 245 | 0 ( width u 0 ) 246 | SWAP ( width 0 u ) 247 | ROT ( 0 u width ) 248 | THEN 249 | SWAP ( flag width u ) 250 | DUP ( flag width u u ) 251 | UWIDTH ( flag width u uwidth ) 252 | ROT ( flag u uwidth width ) 253 | SWAP - ( flag u width-uwidth ) 254 | 255 | SPACES ( flag u ) 256 | SWAP ( u flag ) 257 | 258 | IF 259 | '-' EMIT 260 | THEN 261 | U. 262 | ; 263 | 264 | ( Finally ) 265 | : . 0 .R SPACE ; 266 | 267 | ( The real U. ) 268 | : U. U. SPACE ; 269 | 270 | : ? ( addr -- ) @ . ; 271 | 272 | : WITHIN ( c a b - f ) 273 | -ROT ( b c a ) 274 | OVER ( b c a c ) 275 | <= IF 276 | > IF ( b c ) 277 | TRUE 278 | ELSE 279 | FALSE 280 | THEN 281 | ELSE 282 | 2DROP 283 | FALSE 284 | THEN 285 | ; 286 | 287 | : DEPTH ( -- n ) 288 | S0 @ DSP@ - 289 | 8- 290 | ; 291 | 292 | : ALIGNED ( addr -- addr ) 293 | 7 + 7 INVERT AND 294 | ; 295 | 296 | : ALIGN HERE @ ALIGNED HERE ! ; 297 | 298 | : C, 299 | HERE @ C! 300 | 1 HERE +! 301 | ; 302 | 303 | : S" IMMEDIATE ( -- addr len ) 304 | STATE @ IF 305 | ' LITSTRING , 306 | HERE @ 307 | 0 , 308 | BEGIN 309 | KEY 310 | DUP '"' <> 311 | WHILE 312 | C, 313 | REPEAT 314 | DROP 315 | DUP 316 | HERE @ SWAP - 317 | 8- 318 | SWAP ! 319 | ALIGN 320 | ELSE 321 | HERE @ 322 | BEGIN 323 | KEY 324 | DUP '"' <> 325 | WHILE 326 | OVER C! 327 | 1+ 328 | REPEAT 329 | DROP 330 | HERE @ - 331 | HERE @ 332 | SWAP 333 | THEN 334 | ; 335 | 336 | : ." IMMEDIATE 337 | STATE @ IF 338 | [COMPILE] S" 339 | ' TELL , 340 | ELSE 341 | BEGIN 342 | KEY 343 | DUP '"' = IF 344 | DROP 345 | EXIT 346 | THEN 347 | EMIT 348 | AGAIN 349 | THEN 350 | ; 351 | 352 | ( Constant and Variables ) 353 | 354 | : CONSTANT 355 | WORD 356 | CREATE 357 | DOCOL , 358 | ' LIT , 359 | , 360 | ' EXIT , 361 | ; 362 | 363 | : ALLOT ( n -- addr ) 364 | HERE @ SWAP 365 | HERE +! 366 | ; 367 | 368 | : CELLS ( n -- n ) 8 * ; 369 | 370 | : VARIABLE 371 | 1 CELLS ALLOT 372 | WORD CREATE 373 | DOCOL , 374 | ' LIT , 375 | , 376 | ' EXIT , 377 | ; 378 | 379 | : VALUE ( n -- ) 380 | WORD CREATE 381 | DOCOL , 382 | ' LIT , 383 | , 384 | ' EXIT , 385 | ; 386 | 387 | : TO IMMEDIATE ( n -- ) 388 | WORD 389 | FIND 390 | >DFA 391 | 8+ 392 | STATE @ IF 393 | ' LIT , 394 | , 395 | ' ! , 396 | ELSE 397 | ! 398 | THEN 399 | ; 400 | 401 | : +TO IMMEDIATE 402 | WORD 403 | FIND 404 | >DFA 405 | 8+ 406 | STATE @ IF 407 | ' LIT , 408 | , 409 | ' +! , 410 | ELSE 411 | +! 412 | THEN 413 | ; 414 | 415 | : ID. ( addr -- ) 416 | 8+ 417 | DUP C@ 418 | F_LENMASK AND 419 | BEGIN 420 | DUP 0> 421 | WHILE 422 | SWAP 1+ 423 | DUP C@ 424 | EMIT 425 | SWAP 1- 426 | REPEAT 427 | 2DROP ( len addr -- ) 428 | ; 429 | 430 | : ?HIDDEN 431 | 8+ 432 | C@ 433 | F_HIDDEN AND 434 | ; 435 | 436 | : ?IMMEDIATE 437 | 8+ 438 | C@ 439 | F_IMMED AND 440 | ; 441 | 442 | : WORDS 443 | LATEST @ 444 | BEGIN 445 | ?DUP 446 | WHILE 447 | DUP ?HIDDEN NOT IF 448 | DUP ID. 449 | SPACE 450 | THEN 451 | @ 452 | REPEAT 453 | CR 454 | ; 455 | 456 | : FORGET 457 | WORD FIND 458 | DUP @ LATEST ! 459 | HERE ! 460 | ; 461 | 462 | : DUMP ( addr len -- ) 463 | BASE @ -ROT 464 | HEX 465 | 466 | BEGIN 467 | ?DUP ( while len > 0 ) 468 | WHILE 469 | OVER 8 ZU.R ( print the address ) 470 | SPACE 471 | ( print up to 16 words on this line ) 472 | 2DUP ( addr len addr len ) 473 | 1- 15 AND 1+ ( addr len addr linelen ) 474 | BEGIN 475 | ?DUP ( while linelen > 0 ) 476 | WHILE 477 | SWAP ( addr len linelen addr ) 478 | DUP C@ ( addr len linelen addr byte ) 479 | 2 ZU.R SPACE ( print the byte ) 480 | 1+ SWAP 1- ( addr len linelen addr -- addr len addr+1 linelen-1 ) 481 | REPEAT 482 | DROP ( addr len ) 483 | 484 | ( print the ASCII equivalents ) 485 | 2DUP 1- 15 AND 1+ ( addr len addr linelen ) 486 | BEGIN 487 | ?DUP 488 | WHILE 489 | SWAP ( addr len linelen addr ) 490 | DUP C@ ( addr len linelen addr byte ) 491 | DUP 32 128 WITHIN IF ( 32 <= c < 128? ) 492 | EMIT 493 | ELSE 494 | DROP '.' EMIT 495 | THEN 496 | 1+ SWAP 1- 497 | REPEAT 498 | DROP 499 | CR 500 | DUP 1- 15 AND 1+ 501 | TUCK 502 | - 503 | >R + R> 504 | REPEAT 505 | DROP 506 | BASE ! 507 | ; 508 | 509 | : CASE IMMEDIATE 510 | 0 511 | ; 512 | 513 | : OF IMMEDIATE 514 | ' OVER , 515 | ' = , 516 | [COMPILE] IF 517 | ' DROP , 518 | ; 519 | 520 | : ENDOF IMMEDIATE 521 | [COMPILE] ELSE 522 | ; 523 | 524 | : ENDCASE IMMEDIATE 525 | ' DROP , 526 | BEGIN 527 | ?DUP 528 | WHILE 529 | [COMPILE] THEN 530 | REPEAT 531 | ; 532 | 533 | : CFA> 534 | LATEST @ 535 | BEGIN 536 | ?DUP 537 | WHILE 538 | 2DUP SWAP 539 | < IF 540 | NIP 541 | EXIT 542 | THEN 543 | @ 544 | REPEAT 545 | DROP 546 | 0 547 | ; 548 | 549 | : SEE 550 | WORD FIND 551 | HERE @ 552 | LATEST @ 553 | 554 | BEGIN 555 | 2 PICK 556 | OVER 557 | <> 558 | WHILE 559 | NIP 560 | DUP @ 561 | REPEAT 562 | 563 | DROP 564 | SWAP 565 | 566 | ':' EMIT SPACE DUP ID. SPACE 567 | DUP ?IMMEDIATE IF ." IMMEDIATE " THEN 568 | 569 | >DFA 570 | 571 | BEGIN ( end start ) 572 | 2DUP > 573 | WHILE 574 | DUP @ ( end start codeword ) 575 | CASE 576 | ' LIT OF ( is it LIT ? ) 577 | 8 + DUP @ ( get next word ) 578 | . ( and print it ) 579 | ENDOF 580 | ' LITSTRING OF 581 | [ CHAR S ] LITERAL EMIT '"' EMIT SPACE ( print S" ) 582 | 8 + DUP @ ( get the length ) 583 | SWAP 8 + SWAP ( end start+8 length ) 584 | 2DUP TELL ( print the string ) 585 | '"' EMIT SPACE 586 | + ALIGNED ( end start+8+len, aligned ) 587 | 8 - ( because we're about to add 8 below ) 588 | ENDOF 589 | ' 0BRANCH OF 590 | ." 0BRANCH ( " 591 | 8 + DUP @ 592 | . 593 | ." ) " 594 | ENDOF 595 | ' BRANCH OF 596 | ." BRANCH ( " 597 | 8 + DUP @ 598 | . 599 | ." ) " 600 | ENDOF 601 | ' ' OF 602 | [ CHAR ' ] LITERAL EMIT SPACE 603 | 8 + DUP @ 604 | CFA> 605 | ID. SPACE 606 | ENDOF 607 | ' EXIT OF 608 | 2DUP 609 | 8 + 610 | <> IF 611 | ." EXIT " 612 | THEN 613 | ENDOF 614 | DUP 615 | CFA> 616 | ID. SPACE 617 | ENDCASE 618 | 8 + 619 | REPEAT 620 | ';' EMIT CR 621 | 2DROP 622 | ; 623 | 624 | : :NONAME 625 | 0 0 CREATE 626 | HERE @ 627 | DOCOL , 628 | ] 629 | ; 630 | 631 | : ['] IMMEDIATE 632 | ' LIT , 633 | ; 634 | 635 | 636 | ( Exception ) 637 | : EXCEPTION-MARKER 638 | RDROP 639 | 0 640 | ; 641 | 642 | : CATCH 643 | DSP@ 8+ >R 644 | ' EXCEPTION-MARKER 8+ 645 | >R 646 | EXECUTE 647 | ; 648 | 649 | : THROW 650 | ?DUP IF 651 | RSP@ 652 | BEGIN 653 | DUP R0 8- < 654 | WHILE 655 | DUP @ 656 | ' EXCEPTION-MARKER 8+ = IF 657 | 8+ 658 | RSP! 659 | DUP DUP DUP 660 | R> 661 | 8- 662 | SWAP OVER 663 | ! 664 | DSP! EXIT 665 | THEN 666 | 8+ 667 | REPEAT 668 | DROP 669 | CASE 670 | 0 1- OF ( ABORT ) 671 | ." ABORTED" CR 672 | ENDOF 673 | ." UNCAUGHT THROW " 674 | DUP . CR 675 | ENDCASE 676 | QUIT 677 | THEN 678 | ; 679 | 680 | : ABORT 681 | 0 1- THROW 682 | ; 683 | 684 | : PRINT-STACK-TACE 685 | RSP@ 686 | BEGIN 687 | DUP R0 8- < 688 | WHILE 689 | DUP @ 690 | CASE 691 | ' EXCEPTION-MARKER 8+ OF 692 | ." CATCH ( DSP=" 693 | 8+ DUP @ U. 694 | ." ) " 695 | ENDOF 696 | DUP 697 | CFA> 698 | ?DUP IF 699 | 2DUP 700 | ID. 701 | [ CHAR + ] LITERAL EMIT 702 | SWAP >DFA 8+ - . 703 | THEN 704 | ENDCASE 705 | 8+ 706 | REPEAT 707 | DROP 708 | CR 709 | ; 710 | 711 | ( C String ) 712 | 713 | : Z" IMMEDIATE 714 | STATE @ IF 715 | ' LITSTRING , 716 | HERE @ 717 | 0 , 718 | BEGIN 719 | KEY 720 | DUP '"' <> 721 | WHILE 722 | HERE @ C! 723 | 1 HERE +! 724 | REPEAT 725 | 0 HERE @ C! 726 | 1 HERE +! 727 | DROP 728 | DUP 729 | HERE @ SWAP - 730 | 8- 731 | SWAP ! 732 | ALIGN 733 | ' DROP , 734 | ELSE 735 | HERE @ 736 | BEGIN 737 | KEY 738 | DUP '"' <> 739 | WHILE 740 | OVER C! 741 | 1+ 742 | REPEAT 743 | DROP 744 | 0 SWAP C! 745 | HERE @ 746 | THEN 747 | ; 748 | 749 | : STRLEN 750 | DUP 751 | BEGIN 752 | DUP C@ 0<> 753 | WHILE 754 | 1+ 755 | REPEAT 756 | SWAP - 757 | ; 758 | 759 | : CSTRING 760 | SWAP OVER 761 | HERE @ SWAP 762 | CMOVE 763 | HERE @ + 764 | 0 SWAP C! 765 | HERE @ 766 | ; 767 | 768 | ( The Environment ) 769 | 770 | : ARGC S0 @ @ ; 771 | 772 | : ARGV ( n -- str u ) 773 | 1+ CELLS S0 @ + 774 | @ 775 | DUP STRLEN 776 | ; 777 | 778 | : ENVIRON 779 | ARGC 780 | 2 + 781 | CELLS 782 | S0 @ + 783 | ; 784 | 785 | : BYE 0 SYS_EXIT SYSCALL1 ; 786 | 787 | : GET-BRK ( -- brkpoint ) 0 SYS_BRK SYSCALL1 ; 788 | 789 | : UNUSED ( -- n ) GET-BRK HERE @ - 8 / ; 790 | 791 | : BRK ( brkpoint -- ) SYS_BRK SYSCALL1 ; 792 | 793 | : MORECORE ( cells -- ) CELLS GET-BRK + BRK ; 794 | 795 | : R/O ( -- fam ) O_RDONLY ; 796 | : R/W ( -- fam ) O_RDWR ; 797 | 798 | : OPEN-FILE ( addr u fam -- fd 0 (if successful) | c-addr u fam -- fd errno (if there was an error) ) 799 | -ROT 800 | CSTRING 801 | SYS_OPEN SYSCALL2 802 | DUP 803 | DUP 0< IF 804 | NEGATE 805 | ELSE 806 | DROP 0 807 | THEN 808 | ; 809 | 810 | : CREATE-FILE ( similar to OPEN-FILE ) 811 | O_CREAT OR 812 | O_TRUNC OR 813 | -ROT 814 | CSTRING 815 | 420 -ROT 816 | SYS_OPEN SYSCALL3 817 | DUP 818 | DUP 0< IF 819 | NEGATE 820 | ELSE 821 | DROP 0 822 | THEN 823 | ; 824 | 825 | : CLOSE-FILE 826 | SYS_CLOSE SYSCALL1 827 | NEGATE 828 | ; 829 | 830 | : READ-FILE 831 | >R SWAP R> 832 | SYS_READ SYSCALL3 833 | DUP 834 | DUP 0< IF 835 | NEGATE 836 | ELSE 837 | DROP 0 838 | THEN 839 | ; 840 | 841 | : PERROR 842 | TELL 843 | ':' EMIT SPACE 844 | ." ERRNO=" 845 | . CR 846 | ; 847 | 848 | ( TODO: translate jonesforth x86 assembler into x64 ) 849 | 850 | : WELCOME 851 | S" TEST-MODE" FIND NOT IF 852 | ." Jombloforth version " VERSION . CR 853 | UNUSED . ." cells remaining" CR 854 | ." ok " CR 855 | THEN 856 | ; 857 | 858 | WELCOME 859 | HIDE WELCOME 860 | -------------------------------------------------------------------------------- /original/jonesforth.f: -------------------------------------------------------------------------------- 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.18 2009-09-11 08:32:33 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 | \ NEGATE leaves the negative of a number on the stack. 64 | : NEGATE 0 SWAP - ; 65 | 66 | \ Standard words for booleans. 67 | : TRUE 1 ; 68 | : FALSE 0 ; 69 | : NOT 0= ; 70 | 71 | \ LITERAL takes whatever is on the stack and compiles LIT 72 | : LITERAL IMMEDIATE 73 | ' LIT , \ compile LIT 74 | , \ compile the literal itself (from the stack) 75 | ; 76 | 77 | \ Now we can use [ and ] to insert literals which are calculated at compile time. (Recall that 78 | \ [ and ] are the FORTH words which switch into and out of immediate mode.) 79 | \ Within definitions, use [ ... ] LITERAL anywhere that '...' is a constant expression which you 80 | \ would rather only compute once (at compile time, rather than calculating it each time your word runs). 81 | : ':' 82 | [ \ go into immediate mode (temporarily) 83 | CHAR : \ push the number 58 (ASCII code of colon) on the parameter stack 84 | ] \ go back to compile mode 85 | LITERAL \ compile LIT 58 as the definition of ':' word 86 | ; 87 | 88 | \ A few more character constants defined the same way as above. 89 | : ';' [ CHAR ; ] LITERAL ; 90 | : '(' [ CHAR ( ] LITERAL ; 91 | : ')' [ CHAR ) ] LITERAL ; 92 | : '"' [ CHAR " ] LITERAL ; 93 | : 'A' [ CHAR A ] LITERAL ; 94 | : '0' [ CHAR 0 ] LITERAL ; 95 | : '-' [ CHAR - ] LITERAL ; 96 | : '.' [ CHAR . ] LITERAL ; 97 | 98 | \ While compiling, '[COMPILE] word' compiles 'word' if it would otherwise be IMMEDIATE. 99 | : [COMPILE] IMMEDIATE 100 | WORD \ get the next word 101 | FIND \ find it in the dictionary 102 | >CFA \ get its codeword 103 | , \ and compile that 104 | ; 105 | 106 | \ RECURSE makes a recursive call to the current word that is being compiled. 107 | \ 108 | \ Normally while a word is being compiled, it is marked HIDDEN so that references to the 109 | \ same word within are calls to the previous definition of the word. However we still have 110 | \ access to the word which we are currently compiling through the LATEST pointer so we 111 | \ can use that to compile a recursive call. 112 | : RECURSE IMMEDIATE 113 | LATEST @ \ LATEST points to the word being compiled at the moment 114 | >CFA \ get the codeword 115 | , \ compile it 116 | ; 117 | 118 | \ CONTROL STRUCTURES ---------------------------------------------------------------------- 119 | \ 120 | \ So far we have defined only very simple definitions. Before we can go further, we really need to 121 | \ make some control structures, like IF ... THEN and loops. Luckily we can define arbitrary control 122 | \ structures directly in FORTH. 123 | \ 124 | \ Please note that the control structures as I have defined them here will only work inside compiled 125 | \ words. If you try to type in expressions using IF, etc. in immediate mode, then they won't work. 126 | \ Making these work in immediate mode is left as an exercise for the reader. 127 | 128 | \ condition IF true-part THEN rest 129 | \ -- compiles to: --> condition 0BRANCH OFFSET true-part rest 130 | \ where OFFSET is the offset of 'rest' 131 | \ condition IF true-part ELSE false-part THEN 132 | \ -- compiles to: --> condition 0BRANCH OFFSET true-part BRANCH OFFSET2 false-part rest 133 | \ where OFFSET if the offset of false-part and OFFSET2 is the offset of rest 134 | 135 | \ IF is an IMMEDIATE word which compiles 0BRANCH followed by a dummy offset, and places 136 | \ the address of the 0BRANCH on the stack. Later when we see THEN, we pop that address 137 | \ off the stack, calculate the offset, and back-fill the offset. 138 | : IF IMMEDIATE 139 | ' 0BRANCH , \ compile 0BRANCH 140 | HERE @ \ save location of the offset on the stack 141 | 0 , \ compile a dummy offset 142 | ; 143 | 144 | : THEN IMMEDIATE 145 | DUP 146 | HERE @ SWAP - \ calculate the offset from the address saved on the stack 147 | SWAP ! \ store the offset in the back-filled location 148 | ; 149 | 150 | : ELSE IMMEDIATE 151 | ' BRANCH , \ definite branch to just over the false-part 152 | HERE @ \ save location of the offset on the stack 153 | 0 , \ compile a dummy offset 154 | SWAP \ now back-fill the original (IF) offset 155 | DUP \ same as for THEN word above 156 | HERE @ SWAP - 157 | SWAP ! 158 | ; 159 | 160 | \ BEGIN loop-part condition UNTIL 161 | \ -- compiles to: --> loop-part condition 0BRANCH OFFSET 162 | \ where OFFSET points back to the loop-part 163 | \ This is like do { loop-part } while (condition) in the C language 164 | : BEGIN IMMEDIATE 165 | HERE @ \ save location on the stack 166 | ; 167 | 168 | : UNTIL IMMEDIATE 169 | ' 0BRANCH , \ compile 0BRANCH 170 | HERE @ - \ calculate the offset from the address saved on the stack 171 | , \ compile the offset here 172 | ; 173 | 174 | \ BEGIN loop-part AGAIN 175 | \ -- compiles to: --> loop-part BRANCH OFFSET 176 | \ where OFFSET points back to the loop-part 177 | \ In other words, an infinite loop which can only be returned from with EXIT 178 | : AGAIN IMMEDIATE 179 | ' BRANCH , \ compile BRANCH 180 | HERE @ - \ calculate the offset back 181 | , \ compile the offset here 182 | ; 183 | 184 | \ BEGIN condition WHILE loop-part REPEAT 185 | \ -- compiles to: --> condition 0BRANCH OFFSET2 loop-part BRANCH OFFSET 186 | \ where OFFSET points back to condition (the beginning) and OFFSET2 points to after the whole piece of code 187 | \ So this is like a while (condition) { loop-part } loop in the C language 188 | : WHILE IMMEDIATE 189 | ' 0BRANCH , \ compile 0BRANCH 190 | HERE @ \ save location of the offset2 on the stack 191 | 0 , \ compile a dummy offset2 192 | ; 193 | 194 | : REPEAT IMMEDIATE 195 | ' BRANCH , \ compile BRANCH 196 | SWAP \ get the original offset (from BEGIN) 197 | HERE @ - , \ and compile it after BRANCH 198 | DUP 199 | HERE @ SWAP - \ calculate the offset2 200 | SWAP ! \ and back-fill it in the original location 201 | ; 202 | 203 | \ UNLESS is the same as IF but the test is reversed. 204 | \ 205 | \ Note the use of [COMPILE]: Since IF is IMMEDIATE we don't want it to be executed while UNLESS 206 | \ is compiling, but while UNLESS is running (which happens to be when whatever word using UNLESS is 207 | \ being compiled -- whew!). So we use [COMPILE] to reverse the effect of marking IF as immediate. 208 | \ This trick is generally used when we want to write our own control words without having to 209 | \ implement them all in terms of the primitives 0BRANCH and BRANCH, but instead reusing simpler 210 | \ control words like (in this instance) IF. 211 | : UNLESS IMMEDIATE 212 | ' NOT , \ compile NOT (to reverse the test) 213 | [COMPILE] IF \ continue by calling the normal IF 214 | ; 215 | 216 | \ COMMENTS ---------------------------------------------------------------------- 217 | \ 218 | \ FORTH allows ( ... ) as comments within function definitions. This works by having an IMMEDIATE 219 | \ word called ( which just drops input characters until it hits the corresponding ). 220 | : ( IMMEDIATE 221 | 1 \ allowed nested parens by keeping track of depth 222 | BEGIN 223 | KEY \ read next character 224 | DUP '(' = IF \ open paren? 225 | DROP \ drop the open paren 226 | 1+ \ depth increases 227 | ELSE 228 | ')' = IF \ close paren? 229 | 1- \ depth decreases 230 | THEN 231 | THEN 232 | DUP 0= UNTIL \ continue until we reach matching close paren, depth 0 233 | DROP \ drop the depth counter 234 | ; 235 | 236 | ( 237 | From now on we can use ( ... ) for comments. 238 | 239 | STACK NOTATION ---------------------------------------------------------------------- 240 | 241 | In FORTH style we can also use ( ... -- ... ) to show the effects that a word has on the 242 | parameter stack. For example: 243 | 244 | ( n -- ) means that the word consumes an integer (n) from the parameter stack. 245 | ( b a -- c ) means that the word uses two integers (a and b, where a is at the top of stack) 246 | and returns a single integer (c). 247 | ( -- ) means the word has no effect on the stack 248 | ) 249 | 250 | ( Some more complicated stack examples, showing the stack notation. ) 251 | : NIP ( x y -- y ) SWAP DROP ; 252 | : TUCK ( x y -- y x y ) SWAP OVER ; 253 | : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u ) 254 | 1+ ( add one because of 'u' on the stack ) 255 | 4 * ( multiply by the word size ) 256 | DSP@ + ( add to the stack pointer ) 257 | @ ( and fetch ) 258 | ; 259 | 260 | ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. ) 261 | : SPACES ( n -- ) 262 | BEGIN 263 | DUP 0> ( while n > 0 ) 264 | WHILE 265 | SPACE ( print a space ) 266 | 1- ( until we count down to 0 ) 267 | REPEAT 268 | DROP 269 | ; 270 | 271 | ( Standard words for manipulating BASE. ) 272 | : DECIMAL ( -- ) 10 BASE ! ; 273 | : HEX ( -- ) 16 BASE ! ; 274 | 275 | ( 276 | PRINTING NUMBERS ---------------------------------------------------------------------- 277 | 278 | The standard FORTH word . (DOT) is very important. It takes the number at the top 279 | of the stack and prints it out. However first I'm going to implement some lower-level 280 | FORTH words: 281 | 282 | U.R ( u width -- ) which prints an unsigned number, padded to a certain width 283 | U. ( u -- ) which prints an unsigned number 284 | .R ( n width -- ) which prints a signed number, padded to a certain width. 285 | 286 | For example: 287 | -123 6 .R 288 | will print out these characters: 289 | - 1 2 3 290 | 291 | In other words, the number padded left to a certain number of characters. 292 | 293 | The full number is printed even if it is wider than width, and this is what allows us to 294 | define the ordinary functions U. and . (we just set width to zero knowing that the full 295 | number will be printed anyway). 296 | 297 | Another wrinkle of . and friends is that they obey the current base in the variable BASE. 298 | BASE can be anything in the range 2 to 36. 299 | 300 | While we're defining . &c we can also define .S which is a useful debugging tool. This 301 | word prints the current stack (non-destructively) from top to bottom. 302 | ) 303 | 304 | ( This is the underlying recursive definition of U. ) 305 | : U. ( u -- ) 306 | BASE @ /MOD ( width rem quot ) 307 | ?DUP IF ( if quotient <> 0 then ) 308 | RECURSE ( print the quotient ) 309 | THEN 310 | 311 | ( print the remainder ) 312 | DUP 10 < IF 313 | '0' ( decimal digits 0..9 ) 314 | ELSE 315 | 10 - ( hex and beyond digits A..Z ) 316 | 'A' 317 | THEN 318 | + 319 | EMIT 320 | ; 321 | 322 | ( 323 | FORTH word .S prints the contents of the stack. It doesn't alter the stack. 324 | Very useful for debugging. 325 | ) 326 | : .S ( -- ) 327 | DSP@ ( get current stack pointer ) 328 | BEGIN 329 | DUP S0 @ < 330 | WHILE 331 | DUP @ U. ( print the stack element ) 332 | SPACE 333 | 4+ ( move up ) 334 | REPEAT 335 | DROP 336 | ; 337 | 338 | ( This word returns the width (in characters) of an unsigned number in the current base ) 339 | : UWIDTH ( u -- width ) 340 | BASE @ / ( rem quot ) 341 | ?DUP IF ( if quotient <> 0 then ) 342 | RECURSE 1+ ( return 1+recursive call ) 343 | ELSE 344 | 1 ( return 1 ) 345 | THEN 346 | ; 347 | 348 | : U.R ( u width -- ) 349 | SWAP ( width u ) 350 | DUP ( width u u ) 351 | UWIDTH ( width u uwidth ) 352 | ROT ( u uwidth width ) 353 | SWAP - ( u width-uwidth ) 354 | ( At this point if the requested width is narrower, we'll have a negative number on the stack. 355 | Otherwise the number on the stack is the number of spaces to print. But SPACES won't print 356 | a negative number of spaces anyway, so it's now safe to call SPACES ... ) 357 | SPACES 358 | ( ... and then call the underlying implementation of U. ) 359 | U. 360 | ; 361 | 362 | ( 363 | .R prints a signed number, padded to a certain width. We can't just print the sign 364 | and call U.R because we want the sign to be next to the number ('-123' instead of '- 123'). 365 | ) 366 | : .R ( n width -- ) 367 | SWAP ( width n ) 368 | DUP 0< IF 369 | NEGATE ( width u ) 370 | 1 ( save a flag to remember that it was negative | width n 1 ) 371 | SWAP ( width 1 u ) 372 | ROT ( 1 u width ) 373 | 1- ( 1 u width-1 ) 374 | ELSE 375 | 0 ( width u 0 ) 376 | SWAP ( width 0 u ) 377 | ROT ( 0 u width ) 378 | THEN 379 | SWAP ( flag width u ) 380 | DUP ( flag width u u ) 381 | UWIDTH ( flag width u uwidth ) 382 | ROT ( flag u uwidth width ) 383 | SWAP - ( flag u width-uwidth ) 384 | 385 | SPACES ( flag u ) 386 | SWAP ( u flag ) 387 | 388 | IF ( was it negative? print the - character ) 389 | '-' EMIT 390 | THEN 391 | 392 | U. 393 | ; 394 | 395 | ( Finally we can define word . in terms of .R, with a trailing space. ) 396 | : . 0 .R SPACE ; 397 | 398 | ( The real U., note the trailing space. ) 399 | : U. U. SPACE ; 400 | 401 | ( ? fetches the integer at an address and prints it. ) 402 | : ? ( addr -- ) @ . ; 403 | 404 | ( c a b WITHIN returns true if a <= c and c < b ) 405 | ( or define without ifs: OVER - >R - R> U< ) 406 | : WITHIN 407 | -ROT ( b c a ) 408 | OVER ( b c a c ) 409 | <= IF 410 | > IF ( b c -- ) 411 | TRUE 412 | ELSE 413 | FALSE 414 | THEN 415 | ELSE 416 | 2DROP ( b c -- ) 417 | FALSE 418 | THEN 419 | ; 420 | 421 | ( DEPTH returns the depth of the stack. ) 422 | : DEPTH ( -- n ) 423 | S0 @ DSP@ - 424 | 4- ( adjust because S0 was on the stack when we pushed DSP ) 425 | ; 426 | 427 | ( 428 | ALIGNED takes an address and rounds it up (aligns it) to the next 4 byte boundary. 429 | ) 430 | : ALIGNED ( addr -- addr ) 431 | 3 + 3 INVERT AND ( (addr+3) & ~3 ) 432 | ; 433 | 434 | ( 435 | ALIGN aligns the HERE pointer, so the next word appended will be aligned properly. 436 | ) 437 | : ALIGN HERE @ ALIGNED HERE ! ; 438 | 439 | ( 440 | STRINGS ---------------------------------------------------------------------- 441 | 442 | S" string" is used in FORTH to define strings. It leaves the address of the string and 443 | its length on the stack, (length at the top of stack). The space following S" is the normal 444 | space between FORTH words and is not a part of the string. 445 | 446 | This is tricky to define because it has to do different things depending on whether 447 | we are compiling or in immediate mode. (Thus the word is marked IMMEDIATE so it can 448 | detect this and do different things). 449 | 450 | In compile mode we append 451 | LITSTRING 452 | to the current word. The primitive LITSTRING does the right thing when the current 453 | word is executed. 454 | 455 | In immediate mode there isn't a particularly good place to put the string, but in this 456 | case we put the string at HERE (but we _don't_ change HERE). This is meant as a temporary 457 | location, likely to be overwritten soon after. 458 | ) 459 | ( C, appends a byte to the current compiled word. ) 460 | : C, 461 | HERE @ C! ( store the character in the compiled image ) 462 | 1 HERE +! ( increment HERE pointer by 1 byte ) 463 | ; 464 | 465 | : S" IMMEDIATE ( -- addr len ) 466 | STATE @ IF ( compiling? ) 467 | ' LITSTRING , ( compile LITSTRING ) 468 | HERE @ ( save the address of the length word on the stack ) 469 | 0 , ( dummy length - we don't know what it is yet ) 470 | BEGIN 471 | KEY ( get next character of the string ) 472 | DUP '"' <> 473 | WHILE 474 | C, ( copy character ) 475 | REPEAT 476 | DROP ( drop the double quote character at the end ) 477 | DUP ( get the saved address of the length word ) 478 | HERE @ SWAP - ( calculate the length ) 479 | 4- ( subtract 4 (because we measured from the start of the length word) ) 480 | SWAP ! ( and back-fill the length location ) 481 | ALIGN ( round up to next multiple of 4 bytes for the remaining code ) 482 | ELSE ( immediate mode ) 483 | HERE @ ( get the start address of the temporary space ) 484 | BEGIN 485 | KEY 486 | DUP '"' <> 487 | WHILE 488 | OVER C! ( save next character ) 489 | 1+ ( increment address ) 490 | REPEAT 491 | DROP ( drop the final " character ) 492 | HERE @ - ( calculate the length ) 493 | HERE @ ( push the start address ) 494 | SWAP ( addr len ) 495 | THEN 496 | ; 497 | 498 | ( 499 | ." is the print string operator in FORTH. Example: ." Something to print" 500 | The space after the operator is the ordinary space required between words and is not 501 | a part of what is printed. 502 | 503 | In immediate mode we just keep reading characters and printing them until we get to 504 | the next double quote. 505 | 506 | In compile mode we use S" to store the string, then add TELL afterwards: 507 | LITSTRING TELL 508 | 509 | It may be interesting to note the use of [COMPILE] to turn the call to the immediate 510 | word S" into compilation of that word. It compiles it into the definition of .", 511 | not into the definition of the word being compiled when this is running (complicated 512 | enough for you?) 513 | ) 514 | : ." IMMEDIATE ( -- ) 515 | STATE @ IF ( compiling? ) 516 | [COMPILE] S" ( read the string, and compile LITSTRING, etc. ) 517 | ' TELL , ( compile the final TELL ) 518 | ELSE 519 | ( In immediate mode, just read characters and print them until we get 520 | to the ending double quote. ) 521 | BEGIN 522 | KEY 523 | DUP '"' = IF 524 | DROP ( drop the double quote character ) 525 | EXIT ( return from this function ) 526 | THEN 527 | EMIT 528 | AGAIN 529 | THEN 530 | ; 531 | 532 | ( 533 | CONSTANTS AND VARIABLES ---------------------------------------------------------------------- 534 | 535 | In FORTH, global constants and variables are defined like this: 536 | 537 | 10 CONSTANT TEN when TEN is executed, it leaves the integer 10 on the stack 538 | VARIABLE VAR when VAR is executed, it leaves the address of VAR on the stack 539 | 540 | Constants can be read but not written, eg: 541 | 542 | TEN . CR prints 10 543 | 544 | You can read a variable (in this example called VAR) by doing: 545 | 546 | VAR @ leaves the value of VAR on the stack 547 | VAR @ . CR prints the value of VAR 548 | VAR ? CR same as above, since ? is the same as @ . 549 | 550 | and update the variable by doing: 551 | 552 | 20 VAR ! sets VAR to 20 553 | 554 | Note that variables are uninitialised (but see VALUE later on which provides initialised 555 | variables with a slightly simpler syntax). 556 | 557 | How can we define the words CONSTANT and VARIABLE? 558 | 559 | The trick is to define a new word for the variable itself (eg. if the variable was called 560 | 'VAR' then we would define a new word called VAR). This is easy to do because we exposed 561 | dictionary entry creation through the CREATE word (part of the definition of : above). 562 | A call to WORD [TEN] CREATE (where [TEN] means that "TEN" is the next word in the input) 563 | leaves the dictionary entry: 564 | 565 | +--- HERE 566 | | 567 | V 568 | +---------+---+---+---+---+ 569 | | LINK | 3 | T | E | N | 570 | +---------+---+---+---+---+ 571 | len 572 | 573 | For CONSTANT we can continue by appending DOCOL (the codeword), then LIT followed by 574 | the constant itself and then EXIT, forming a little word definition that returns the 575 | constant: 576 | 577 | +---------+---+---+---+---+------------+------------+------------+------------+ 578 | | LINK | 3 | T | E | N | DOCOL | LIT | 10 | EXIT | 579 | +---------+---+---+---+---+------------+------------+------------+------------+ 580 | len codeword 581 | 582 | Notice that this word definition is exactly the same as you would have got if you had 583 | written : TEN 10 ; 584 | 585 | Note for people reading the code below: DOCOL is a constant word which we defined in the 586 | assembler part which returns the value of the assembler symbol of the same name. 587 | ) 588 | : CONSTANT 589 | WORD ( get the name (the name follows CONSTANT) ) 590 | CREATE ( make the dictionary entry ) 591 | DOCOL , ( append DOCOL (the codeword field of this word) ) 592 | ' LIT , ( append the codeword LIT ) 593 | , ( append the value on the top of the stack ) 594 | ' EXIT , ( append the codeword EXIT ) 595 | ; 596 | 597 | ( 598 | VARIABLE is a little bit harder because we need somewhere to put the variable. There is 599 | nothing particularly special about the user memory (the area of memory pointed to by HERE 600 | where we have previously just stored new word definitions). We can slice off bits of this 601 | memory area to store anything we want, so one possible definition of VARIABLE might create 602 | this: 603 | 604 | +--------------------------------------------------------------+ 605 | | | 606 | V | 607 | +---------+---------+---+---+---+---+------------+------------+---|--------+------------+ 608 | | | LINK | 3 | V | A | R | DOCOL | LIT | | EXIT | 609 | +---------+---------+---+---+---+---+------------+------------+------------+------------+ 610 | len codeword 611 | 612 | where is the place to store the variable, and points back to it. 613 | 614 | To make this more general let's define a couple of words which we can use to allocate 615 | arbitrary memory from the user memory. 616 | 617 | First ALLOT, where n ALLOT allocates n bytes of memory. (Note when calling this that 618 | it's a very good idea to make sure that n is a multiple of 4, or at least that next time 619 | a word is compiled that HERE has been left as a multiple of 4). 620 | ) 621 | : ALLOT ( n -- addr ) 622 | HERE @ SWAP ( here n ) 623 | HERE +! ( adds n to HERE, after this the old value of HERE is still on the stack ) 624 | ; 625 | 626 | ( 627 | Second, CELLS. In FORTH the phrase 'n CELLS ALLOT' means allocate n integers of whatever size 628 | is the natural size for integers on this machine architecture. On this 32 bit machine therefore 629 | CELLS just multiplies the top of stack by 4. 630 | ) 631 | : CELLS ( n -- n ) 4 * ; 632 | 633 | ( 634 | So now we can define VARIABLE easily in much the same way as CONSTANT above. Refer to the 635 | diagram above to see what the word that this creates will look like. 636 | ) 637 | : VARIABLE 638 | 1 CELLS ALLOT ( allocate 1 cell of memory, push the pointer to this memory ) 639 | WORD CREATE ( make the dictionary entry (the name follows VARIABLE) ) 640 | DOCOL , ( append DOCOL (the codeword field of this word) ) 641 | ' LIT , ( append the codeword LIT ) 642 | , ( append the pointer to the new memory ) 643 | ' EXIT , ( append the codeword EXIT ) 644 | ; 645 | 646 | ( 647 | VALUES ---------------------------------------------------------------------- 648 | 649 | VALUEs are like VARIABLEs but with a simpler syntax. You would generally use them when you 650 | want a variable which is read often, and written infrequently. 651 | 652 | 20 VALUE VAL creates VAL with initial value 20 653 | VAL pushes the value (20) directly on the stack 654 | 30 TO VAL updates VAL, setting it to 30 655 | VAL pushes the value (30) directly on the stack 656 | 657 | Notice that 'VAL' on its own doesn't return the address of the value, but the value itself, 658 | making values simpler and more obvious to use than variables (no indirection through '@'). 659 | The price is a more complicated implementation, although despite the complexity there is no 660 | performance penalty at runtime. 661 | 662 | A naive implementation of 'TO' would be quite slow, involving a dictionary search each time. 663 | But because this is FORTH we have complete control of the compiler so we can compile TO more 664 | efficiently, turning: 665 | TO VAL 666 | into: 667 | LIT ! 668 | and calculating (the address of the value) at compile time. 669 | 670 | Now this is the clever bit. We'll compile our value like this: 671 | 672 | +---------+---+---+---+---+------------+------------+------------+------------+ 673 | | LINK | 3 | V | A | L | DOCOL | LIT | | EXIT | 674 | +---------+---+---+---+---+------------+------------+------------+------------+ 675 | len codeword 676 | 677 | where is the actual value itself. Note that when VAL executes, it will push the 678 | value on the stack, which is what we want. 679 | 680 | But what will TO use for the address ? Why of course a pointer to that : 681 | 682 | code compiled - - - - --+------------+------------+------------+-- - - - - 683 | by TO VAL | LIT | | ! | 684 | - - - - --+------------+-----|------+------------+-- - - - - 685 | | 686 | V 687 | +---------+---+---+---+---+------------+------------+------------+------------+ 688 | | LINK | 3 | V | A | L | DOCOL | LIT | | EXIT | 689 | +---------+---+---+---+---+------------+------------+------------+------------+ 690 | len codeword 691 | 692 | In other words, this is a kind of self-modifying code. 693 | 694 | (Note to the people who want to modify this FORTH to add inlining: values defined this 695 | way cannot be inlined). 696 | ) 697 | : VALUE ( n -- ) 698 | WORD CREATE ( make the dictionary entry (the name follows VALUE) ) 699 | DOCOL , ( append DOCOL ) 700 | ' LIT , ( append the codeword LIT ) 701 | , ( append the initial value ) 702 | ' EXIT , ( append the codeword EXIT ) 703 | ; 704 | 705 | : TO IMMEDIATE ( n -- ) 706 | WORD ( get the name of the value ) 707 | FIND ( look it up in the dictionary ) 708 | >DFA ( get a pointer to the first data field (the 'LIT') ) 709 | 4+ ( increment to point at the value ) 710 | STATE @ IF ( compiling? ) 711 | ' LIT , ( compile LIT ) 712 | , ( compile the address of the value ) 713 | ' ! , ( compile ! ) 714 | ELSE ( immediate mode ) 715 | ! ( update it straightaway ) 716 | THEN 717 | ; 718 | 719 | ( x +TO VAL adds x to VAL ) 720 | : +TO IMMEDIATE 721 | WORD ( get the name of the value ) 722 | FIND ( look it up in the dictionary ) 723 | >DFA ( get a pointer to the first data field (the 'LIT') ) 724 | 4+ ( increment to point at the value ) 725 | STATE @ IF ( compiling? ) 726 | ' LIT , ( compile LIT ) 727 | , ( compile the address of the value ) 728 | ' +! , ( compile +! ) 729 | ELSE ( immediate mode ) 730 | +! ( update it straightaway ) 731 | THEN 732 | ; 733 | 734 | ( 735 | PRINTING THE DICTIONARY ---------------------------------------------------------------------- 736 | 737 | ID. takes an address of a dictionary entry and prints the word's name. 738 | 739 | For example: LATEST @ ID. would print the name of the last word that was defined. 740 | ) 741 | : ID. 742 | 4+ ( skip over the link pointer ) 743 | DUP C@ ( get the flags/length byte ) 744 | F_LENMASK AND ( mask out the flags - just want the length ) 745 | 746 | BEGIN 747 | DUP 0> ( length > 0? ) 748 | WHILE 749 | SWAP 1+ ( addr len -- len addr+1 ) 750 | DUP C@ ( len addr -- len addr char | get the next character) 751 | EMIT ( len addr char -- len addr | and print it) 752 | SWAP 1- ( len addr -- addr len-1 | subtract one from length ) 753 | REPEAT 754 | 2DROP ( len addr -- ) 755 | ; 756 | 757 | ( 758 | 'WORD word FIND ?HIDDEN' returns true if 'word' is flagged as hidden. 759 | 760 | 'WORD word FIND ?IMMEDIATE' returns true if 'word' is flagged as immediate. 761 | ) 762 | : ?HIDDEN 763 | 4+ ( skip over the link pointer ) 764 | C@ ( get the flags/length byte ) 765 | F_HIDDEN AND ( mask the F_HIDDEN flag and return it (as a truth value) ) 766 | ; 767 | : ?IMMEDIATE 768 | 4+ ( skip over the link pointer ) 769 | C@ ( get the flags/length byte ) 770 | F_IMMED AND ( mask the F_IMMED flag and return it (as a truth value) ) 771 | ; 772 | 773 | ( 774 | WORDS prints all the words defined in the dictionary, starting with the word defined most recently. 775 | However it doesn't print hidden words. 776 | 777 | The implementation simply iterates backwards from LATEST using the link pointers. 778 | ) 779 | : WORDS 780 | LATEST @ ( start at LATEST dictionary entry ) 781 | BEGIN 782 | ?DUP ( while link pointer is not null ) 783 | WHILE 784 | DUP ?HIDDEN NOT IF ( ignore hidden words ) 785 | DUP ID. ( but if not hidden, print the word ) 786 | SPACE 787 | THEN 788 | @ ( dereference the link pointer - go to previous word ) 789 | REPEAT 790 | CR 791 | ; 792 | 793 | ( 794 | FORGET ---------------------------------------------------------------------- 795 | 796 | So far we have only allocated words and memory. FORTH provides a rather primitive method 797 | to deallocate. 798 | 799 | 'FORGET word' deletes the definition of 'word' from the dictionary and everything defined 800 | after it, including any variables and other memory allocated after. 801 | 802 | The implementation is very simple - we look up the word (which returns the dictionary entry 803 | address). Then we set HERE to point to that address, so in effect all future allocations 804 | and definitions will overwrite memory starting at the word. We also need to set LATEST to 805 | point to the previous word. 806 | 807 | Note that you cannot FORGET built-in words (well, you can try but it will probably cause 808 | a segfault). 809 | 810 | XXX: Because we wrote VARIABLE to store the variable in memory allocated before the word, 811 | in the current implementation VARIABLE FOO FORGET FOO will leak 1 cell of memory. 812 | ) 813 | : FORGET 814 | WORD FIND ( find the word, gets the dictionary entry address ) 815 | DUP @ LATEST ! ( set LATEST to point to the previous word ) 816 | HERE ! ( and store HERE with the dictionary address ) 817 | ; 818 | 819 | ( 820 | DUMP ---------------------------------------------------------------------- 821 | 822 | DUMP is used to dump out the contents of memory, in the 'traditional' hexdump format. 823 | 824 | Notice that the parameters to DUMP (address, length) are compatible with string words 825 | such as WORD and S". 826 | 827 | You can dump out the raw code for the last word you defined by doing something like: 828 | 829 | LATEST @ 128 DUMP 830 | ) 831 | : DUMP ( addr len -- ) 832 | BASE @ -ROT ( save the current BASE at the bottom of the stack ) 833 | HEX ( and switch to hexadecimal mode ) 834 | 835 | BEGIN 836 | ?DUP ( while len > 0 ) 837 | WHILE 838 | OVER 8 U.R ( print the address ) 839 | SPACE 840 | 841 | ( print up to 16 words on this line ) 842 | 2DUP ( addr len addr len ) 843 | 1- 15 AND 1+ ( addr len addr linelen ) 844 | BEGIN 845 | ?DUP ( while linelen > 0 ) 846 | WHILE 847 | SWAP ( addr len linelen addr ) 848 | DUP C@ ( addr len linelen addr byte ) 849 | 2 .R SPACE ( print the byte ) 850 | 1+ SWAP 1- ( addr len linelen addr -- addr len addr+1 linelen-1 ) 851 | REPEAT 852 | DROP ( addr len ) 853 | 854 | ( print the ASCII equivalents ) 855 | 2DUP 1- 15 AND 1+ ( addr len addr linelen ) 856 | BEGIN 857 | ?DUP ( while linelen > 0) 858 | WHILE 859 | SWAP ( addr len linelen addr ) 860 | DUP C@ ( addr len linelen addr byte ) 861 | DUP 32 128 WITHIN IF ( 32 <= c < 128? ) 862 | EMIT 863 | ELSE 864 | DROP '.' EMIT 865 | THEN 866 | 1+ SWAP 1- ( addr len linelen addr -- addr len addr+1 linelen-1 ) 867 | REPEAT 868 | DROP ( addr len ) 869 | CR 870 | 871 | DUP 1- 15 AND 1+ ( addr len linelen ) 872 | TUCK ( addr linelen len linelen ) 873 | - ( addr linelen len-linelen ) 874 | >R + R> ( addr+linelen len-linelen ) 875 | REPEAT 876 | 877 | DROP ( restore stack ) 878 | BASE ! ( restore saved BASE ) 879 | ; 880 | 881 | ( 882 | CASE ---------------------------------------------------------------------- 883 | 884 | CASE...ENDCASE is how we do switch statements in FORTH. There is no generally 885 | agreed syntax for this, so I've gone for the syntax mandated by the ISO standard 886 | FORTH (ANS-FORTH). 887 | 888 | ( some value on the stack ) 889 | CASE 890 | test1 OF ... ENDOF 891 | test2 OF ... ENDOF 892 | testn OF ... ENDOF 893 | ... ( default case ) 894 | ENDCASE 895 | 896 | The CASE statement tests the value on the stack by comparing it for equality with 897 | test1, test2, ..., testn and executes the matching piece of code within OF ... ENDOF. 898 | If none of the test values match then the default case is executed. Inside the ... of 899 | the default case, the value is still at the top of stack (it is implicitly DROP-ed 900 | by ENDCASE). When ENDOF is executed it jumps after ENDCASE (ie. there is no "fall-through" 901 | and no need for a break statement like in C). 902 | 903 | The default case may be omitted. In fact the tests may also be omitted so that you 904 | just have a default case, although this is probably not very useful. 905 | 906 | An example (assuming that 'q', etc. are words which push the ASCII value of the letter 907 | on the stack): 908 | 909 | 0 VALUE QUIT 910 | 0 VALUE SLEEP 911 | KEY CASE 912 | 'q' OF 1 TO QUIT ENDOF 913 | 's' OF 1 TO SLEEP ENDOF 914 | ( default case: ) 915 | ." Sorry, I didn't understand key <" DUP EMIT ." >, try again." CR 916 | ENDCASE 917 | 918 | (In some versions of FORTH, more advanced tests are supported, such as ranges, etc. 919 | Other versions of FORTH need you to write OTHERWISE to indicate the default case. 920 | As I said above, this FORTH tries to follow the ANS FORTH standard). 921 | 922 | The implementation of CASE...ENDCASE is somewhat non-trivial. I'm following the 923 | implementations from here: 924 | http://www.uni-giessen.de/faq/archiv/forthfaq.case_endcase/msg00000.html 925 | 926 | The general plan is to compile the code as a series of IF statements: 927 | 928 | CASE (push 0 on the immediate-mode parameter stack) 929 | test1 OF ... ENDOF test1 OVER = IF DROP ... ELSE 930 | test2 OF ... ENDOF test2 OVER = IF DROP ... ELSE 931 | testn OF ... ENDOF testn OVER = IF DROP ... ELSE 932 | ... ( default case ) ... 933 | ENDCASE DROP THEN [THEN [THEN ...]] 934 | 935 | The CASE statement pushes 0 on the immediate-mode parameter stack, and that number 936 | is used to count how many THEN statements we need when we get to ENDCASE so that each 937 | IF has a matching THEN. The counting is done implicitly. If you recall from the 938 | implementation above of IF, each IF pushes a code address on the immediate-mode stack, 939 | and these addresses are non-zero, so by the time we get to ENDCASE the stack contains 940 | some number of non-zeroes, followed by a zero. The number of non-zeroes is how many 941 | times IF has been called, so how many times we need to match it with THEN. 942 | 943 | This code uses [COMPILE] so that we compile calls to IF, ELSE, THEN instead of 944 | actually calling them while we're compiling the words below. 945 | 946 | As is the case with all of our control structures, they only work within word 947 | definitions, not in immediate mode. 948 | ) 949 | : CASE IMMEDIATE 950 | 0 ( push 0 to mark the bottom of the stack ) 951 | ; 952 | 953 | : OF IMMEDIATE 954 | ' OVER , ( compile OVER ) 955 | ' = , ( compile = ) 956 | [COMPILE] IF ( compile IF ) 957 | ' DROP , ( compile DROP ) 958 | ; 959 | 960 | : ENDOF IMMEDIATE 961 | [COMPILE] ELSE ( ENDOF is the same as ELSE ) 962 | ; 963 | 964 | : ENDCASE IMMEDIATE 965 | ' DROP , ( compile DROP ) 966 | 967 | ( keep compiling THEN until we get to our zero marker ) 968 | BEGIN 969 | ?DUP 970 | WHILE 971 | [COMPILE] THEN 972 | REPEAT 973 | ; 974 | 975 | ( 976 | DECOMPILER ---------------------------------------------------------------------- 977 | 978 | CFA> is the opposite of >CFA. It takes a codeword and tries to find the matching 979 | dictionary definition. (In truth, it works with any pointer into a word, not just 980 | the codeword pointer, and this is needed to do stack traces). 981 | 982 | In this FORTH this is not so easy. In fact we have to search through the dictionary 983 | because we don't have a convenient back-pointer (as is often the case in other versions 984 | of FORTH). Because of this search, CFA> should not be used when performance is critical, 985 | so it is only used for debugging tools such as the decompiler and printing stack 986 | traces. 987 | 988 | This word returns 0 if it doesn't find a match. 989 | ) 990 | : CFA> 991 | LATEST @ ( start at LATEST dictionary entry ) 992 | BEGIN 993 | ?DUP ( while link pointer is not null ) 994 | WHILE 995 | 2DUP SWAP ( cfa curr curr cfa ) 996 | < IF ( current dictionary entry < cfa? ) 997 | NIP ( leave curr dictionary entry on the stack ) 998 | EXIT 999 | THEN 1000 | @ ( follow link pointer back ) 1001 | REPEAT 1002 | DROP ( restore stack ) 1003 | 0 ( sorry, nothing found ) 1004 | ; 1005 | 1006 | ( 1007 | SEE decompiles a FORTH word. 1008 | 1009 | We search for the dictionary entry of the word, then search again for the next 1010 | word (effectively, the end of the compiled word). This results in two pointers: 1011 | 1012 | +---------+---+---+---+---+------------+------------+------------+------------+ 1013 | | LINK | 3 | T | E | N | DOCOL | LIT | 10 | EXIT | 1014 | +---------+---+---+---+---+------------+------------+------------+------------+ 1015 | ^ ^ 1016 | | | 1017 | Start of word End of word 1018 | 1019 | With this information we can have a go at decompiling the word. We need to 1020 | recognise "meta-words" like LIT, LITSTRING, BRANCH, etc. and treat those separately. 1021 | ) 1022 | : SEE 1023 | WORD FIND ( find the dictionary entry to decompile ) 1024 | 1025 | ( Now we search again, looking for the next word in the dictionary. This gives us 1026 | the length of the word that we will be decompiling. (Well, mostly it does). ) 1027 | HERE @ ( address of the end of the last compiled word ) 1028 | LATEST @ ( word last curr ) 1029 | BEGIN 1030 | 2 PICK ( word last curr word ) 1031 | OVER ( word last curr word curr ) 1032 | <> ( word last curr word<>curr? ) 1033 | WHILE ( word last curr ) 1034 | NIP ( word curr ) 1035 | DUP @ ( word curr prev (which becomes: word last curr) ) 1036 | REPEAT 1037 | 1038 | DROP ( at this point, the stack is: start-of-word end-of-word ) 1039 | SWAP ( end-of-word start-of-word ) 1040 | 1041 | ( begin the definition with : NAME [IMMEDIATE] ) 1042 | ':' EMIT SPACE DUP ID. SPACE 1043 | DUP ?IMMEDIATE IF ." IMMEDIATE " THEN 1044 | 1045 | >DFA ( get the data address, ie. points after DOCOL | end-of-word start-of-data ) 1046 | 1047 | ( now we start decompiling until we hit the end of the word ) 1048 | BEGIN ( end start ) 1049 | 2DUP > 1050 | WHILE 1051 | DUP @ ( end start codeword ) 1052 | 1053 | CASE 1054 | ' LIT OF ( is it LIT ? ) 1055 | 4 + DUP @ ( get next word which is the integer constant ) 1056 | . ( and print it ) 1057 | ENDOF 1058 | ' LITSTRING OF ( is it LITSTRING ? ) 1059 | [ CHAR S ] LITERAL EMIT '"' EMIT SPACE ( print S" ) 1060 | 4 + DUP @ ( get the length word ) 1061 | SWAP 4 + SWAP ( end start+4 length ) 1062 | 2DUP TELL ( print the string ) 1063 | '"' EMIT SPACE ( finish the string with a final quote ) 1064 | + ALIGNED ( end start+4+len, aligned ) 1065 | 4 - ( because we're about to add 4 below ) 1066 | ENDOF 1067 | ' 0BRANCH OF ( is it 0BRANCH ? ) 1068 | ." 0BRANCH ( " 1069 | 4 + DUP @ ( print the offset ) 1070 | . 1071 | ." ) " 1072 | ENDOF 1073 | ' BRANCH OF ( is it BRANCH ? ) 1074 | ." BRANCH ( " 1075 | 4 + DUP @ ( print the offset ) 1076 | . 1077 | ." ) " 1078 | ENDOF 1079 | ' ' OF ( is it ' (TICK) ? ) 1080 | [ CHAR ' ] LITERAL EMIT SPACE 1081 | 4 + DUP @ ( get the next codeword ) 1082 | CFA> ( and force it to be printed as a dictionary entry ) 1083 | ID. SPACE 1084 | ENDOF 1085 | ' EXIT OF ( is it EXIT? ) 1086 | ( We expect the last word to be EXIT, and if it is then we don't print it 1087 | because EXIT is normally implied by ;. EXIT can also appear in the middle 1088 | of words, and then it needs to be printed. ) 1089 | 2DUP ( end start end start ) 1090 | 4 + ( end start end start+4 ) 1091 | <> IF ( end start | we're not at the end ) 1092 | ." EXIT " 1093 | THEN 1094 | ENDOF 1095 | ( default case: ) 1096 | DUP ( in the default case we always need to DUP before using ) 1097 | CFA> ( look up the codeword to get the dictionary entry ) 1098 | ID. SPACE ( and print it ) 1099 | ENDCASE 1100 | 1101 | 4 + ( end start+4 ) 1102 | REPEAT 1103 | 1104 | ';' EMIT CR 1105 | 1106 | 2DROP ( restore stack ) 1107 | ; 1108 | 1109 | ( 1110 | EXECUTION TOKENS ---------------------------------------------------------------------- 1111 | 1112 | Standard FORTH defines a concept called an 'execution token' (or 'xt') which is very 1113 | similar to a function pointer in C. We map the execution token to a codeword address. 1114 | 1115 | execution token of DOUBLE is the address of this codeword 1116 | | 1117 | V 1118 | +---------+---+---+---+---+---+---+---+---+------------+------------+------------+------------+ 1119 | | LINK | 6 | D | O | U | B | L | E | 0 | DOCOL | DUP | + | EXIT | 1120 | +---------+---+---+---+---+---+---+---+---+------------+------------+------------+------------+ 1121 | len pad codeword ^ 1122 | 1123 | There is one assembler primitive for execution tokens, EXECUTE ( xt -- ), which runs them. 1124 | 1125 | You can make an execution token for an existing word the long way using >CFA, 1126 | ie: WORD [foo] FIND >CFA will push the xt for foo onto the stack where foo is the 1127 | next word in input. So a very slow way to run DOUBLE might be: 1128 | 1129 | : DOUBLE DUP + ; 1130 | : SLOW WORD FIND >CFA EXECUTE ; 1131 | 5 SLOW DOUBLE . CR \ prints 10 1132 | 1133 | We also offer a simpler and faster way to get the execution token of any word FOO: 1134 | 1135 | ['] FOO 1136 | 1137 | (Exercises for readers: (1) What is the difference between ['] FOO and ' FOO? 1138 | (2) What is the relationship between ', ['] and LIT?) 1139 | 1140 | More useful is to define anonymous words and/or to assign xt's to variables. 1141 | 1142 | To define an anonymous word (and push its xt on the stack) use :NONAME ... ; as in this 1143 | example: 1144 | 1145 | :NONAME ." anon word was called" CR ; \ pushes xt on the stack 1146 | DUP EXECUTE EXECUTE \ executes the anon word twice 1147 | 1148 | Stack parameters work as expected: 1149 | 1150 | :NONAME ." called with parameter " . CR ; 1151 | DUP 1152 | 10 SWAP EXECUTE \ prints 'called with parameter 10' 1153 | 20 SWAP EXECUTE \ prints 'called with parameter 20' 1154 | 1155 | Notice that the above code has a memory leak: the anonymous word is still compiled 1156 | into the data segment, so even if you lose track of the xt, the word continues to 1157 | occupy memory. A good way to keep track of the xt and thus avoid the memory leak is 1158 | to assign it to a CONSTANT, VARIABLE or VALUE: 1159 | 1160 | 0 VALUE ANON 1161 | :NONAME ." anon word was called" CR ; TO ANON 1162 | ANON EXECUTE 1163 | ANON EXECUTE 1164 | 1165 | Another use of :NONAME is to create an array of functions which can be called quickly 1166 | (think: fast switch statement). This example is adapted from the ANS FORTH standard: 1167 | 1168 | 10 CELLS ALLOT CONSTANT CMD-TABLE 1169 | : SET-CMD CELLS CMD-TABLE + ! ; 1170 | : CALL-CMD CELLS CMD-TABLE + @ EXECUTE ; 1171 | 1172 | :NONAME ." alternate 0 was called" CR ; 0 SET-CMD 1173 | :NONAME ." alternate 1 was called" CR ; 1 SET-CMD 1174 | \ etc... 1175 | :NONAME ." alternate 9 was called" CR ; 9 SET-CMD 1176 | 1177 | 0 CALL-CMD 1178 | 1 CALL-CMD 1179 | ) 1180 | 1181 | : :NONAME 1182 | 0 0 CREATE ( create a word with no name - we need a dictionary header because ; expects it ) 1183 | HERE @ ( current HERE value is the address of the codeword, ie. the xt ) 1184 | DOCOL , ( compile DOCOL (the codeword) ) 1185 | ] ( go into compile mode ) 1186 | ; 1187 | 1188 | : ['] IMMEDIATE 1189 | ' LIT , ( compile LIT ) 1190 | ; 1191 | 1192 | ( 1193 | EXCEPTIONS ---------------------------------------------------------------------- 1194 | 1195 | Amazingly enough, exceptions can be implemented directly in FORTH, in fact rather easily. 1196 | 1197 | The general usage is as follows: 1198 | 1199 | : FOO ( n -- ) THROW ; 1200 | 1201 | : TEST-EXCEPTIONS 1202 | 25 ['] FOO CATCH \ execute 25 FOO, catching any exception 1203 | ?DUP IF 1204 | ." called FOO and it threw exception number: " 1205 | . CR 1206 | DROP \ we have to drop the argument of FOO (25) 1207 | THEN 1208 | ; 1209 | \ prints: called FOO and it threw exception number: 25 1210 | 1211 | CATCH runs an execution token and detects whether it throws any exception or not. The 1212 | stack signature of CATCH is rather complicated: 1213 | 1214 | ( a_n-1 ... a_1 a_0 xt -- r_m-1 ... r_1 r_0 0 ) if xt did NOT throw an exception 1215 | ( a_n-1 ... a_1 a_0 xt -- ?_n-1 ... ?_1 ?_0 e ) if xt DID throw exception 'e' 1216 | 1217 | where a_i and r_i are the (arbitrary number of) argument and return stack contents 1218 | before and after xt is EXECUTEd. Notice in particular the case where an exception 1219 | is thrown, the stack pointer is restored so that there are n of _something_ on the 1220 | stack in the positions where the arguments a_i used to be. We don't really guarantee 1221 | what is on the stack -- perhaps the original arguments, and perhaps other nonsense -- 1222 | it largely depends on the implementation of the word that was executed. 1223 | 1224 | THROW, ABORT and a few others throw exceptions. 1225 | 1226 | Exception numbers are non-zero integers. By convention the positive numbers can be used 1227 | for app-specific exceptions and the negative numbers have certain meanings defined in 1228 | the ANS FORTH standard. (For example, -1 is the exception thrown by ABORT). 1229 | 1230 | 0 THROW does nothing. This is the stack signature of THROW: 1231 | 1232 | ( 0 -- ) 1233 | ( * e -- ?_n-1 ... ?_1 ?_0 e ) the stack is restored to the state from the corresponding CATCH 1234 | 1235 | The implementation hangs on the definitions of CATCH and THROW and the state shared 1236 | between them. 1237 | 1238 | Up to this point, the return stack has consisted merely of a list of return addresses, 1239 | with the top of the return stack being the return address where we will resume executing 1240 | when the current word EXITs. However CATCH will push a more complicated 'exception stack 1241 | frame' on the return stack. The exception stack frame records some things about the 1242 | state of execution at the time that CATCH was called. 1243 | 1244 | When called, THROW walks up the return stack (the process is called 'unwinding') until 1245 | it finds the exception stack frame. It then uses the data in the exception stack frame 1246 | to restore the state allowing execution to continue after the matching CATCH. (If it 1247 | unwinds the stack and doesn't find the exception stack frame then it prints a message 1248 | and drops back to the prompt, which is also normal behaviour for so-called 'uncaught 1249 | exceptions'). 1250 | 1251 | This is what the exception stack frame looks like. (As is conventional, the return stack 1252 | is shown growing downwards from higher to lower memory addresses). 1253 | 1254 | +------------------------------+ 1255 | | return address from CATCH | Notice this is already on the 1256 | | | return stack when CATCH is called. 1257 | +------------------------------+ 1258 | | original parameter stack | 1259 | | pointer | 1260 | +------------------------------+ ^ 1261 | | exception stack marker | | 1262 | | (EXCEPTION-MARKER) | | Direction of stack 1263 | +------------------------------+ | unwinding by THROW. 1264 | | 1265 | | 1266 | 1267 | The EXCEPTION-MARKER marks the entry as being an exception stack frame rather than an 1268 | ordinary return address, and it is this which THROW "notices" as it is unwinding the 1269 | stack. (If you want to implement more advanced exceptions such as TRY...WITH then 1270 | you'll need to use a different value of marker if you want the old and new exception stack 1271 | frame layouts to coexist). 1272 | 1273 | What happens if the executed word doesn't throw an exception? It will eventually 1274 | return and call EXCEPTION-MARKER, so EXCEPTION-MARKER had better do something sensible 1275 | without us needing to modify EXIT. This nicely gives us a suitable definition of 1276 | EXCEPTION-MARKER, namely a function that just drops the stack frame and itself 1277 | returns (thus "returning" from the original CATCH). 1278 | 1279 | One thing to take from this is that exceptions are a relatively lightweight mechanism 1280 | in FORTH. 1281 | ) 1282 | 1283 | : EXCEPTION-MARKER 1284 | RDROP ( drop the original parameter stack pointer ) 1285 | 0 ( there was no exception, this is the normal return path ) 1286 | ; 1287 | 1288 | : CATCH ( xt -- exn? ) 1289 | DSP@ 4+ >R ( save parameter stack pointer (+4 because of xt) on the return stack ) 1290 | ' EXCEPTION-MARKER 4+ ( push the address of the RDROP inside EXCEPTION-MARKER ... ) 1291 | >R ( ... on to the return stack so it acts like a return address ) 1292 | EXECUTE ( execute the nested function ) 1293 | ; 1294 | 1295 | : THROW ( n -- ) 1296 | ?DUP IF ( only act if the exception code <> 0 ) 1297 | RSP@ ( get return stack pointer ) 1298 | BEGIN 1299 | DUP R0 4- < ( RSP < R0 ) 1300 | WHILE 1301 | DUP @ ( get the return stack entry ) 1302 | ' EXCEPTION-MARKER 4+ = IF ( found the EXCEPTION-MARKER on the return stack ) 1303 | 4+ ( skip the EXCEPTION-MARKER on the return stack ) 1304 | RSP! ( restore the return stack pointer ) 1305 | 1306 | ( Restore the parameter stack. ) 1307 | DUP DUP DUP ( reserve some working space so the stack for this word 1308 | doesn't coincide with the part of the stack being restored ) 1309 | R> ( get the saved parameter stack pointer | n dsp ) 1310 | 4- ( reserve space on the stack to store n ) 1311 | SWAP OVER ( dsp n dsp ) 1312 | ! ( write n on the stack ) 1313 | DSP! EXIT ( restore the parameter stack pointer, immediately exit ) 1314 | THEN 1315 | 4+ 1316 | REPEAT 1317 | 1318 | ( No matching catch - print a message and restart the INTERPRETer. ) 1319 | DROP 1320 | 1321 | CASE 1322 | 0 1- OF ( ABORT ) 1323 | ." ABORTED" CR 1324 | ENDOF 1325 | ( default case ) 1326 | ." UNCAUGHT THROW " 1327 | DUP . CR 1328 | ENDCASE 1329 | QUIT 1330 | THEN 1331 | ; 1332 | 1333 | : ABORT ( -- ) 1334 | 0 1- THROW 1335 | ; 1336 | 1337 | ( Print a stack trace by walking up the return stack. ) 1338 | : PRINT-STACK-TRACE 1339 | RSP@ ( start at caller of this function ) 1340 | BEGIN 1341 | DUP R0 4- < ( RSP < R0 ) 1342 | WHILE 1343 | DUP @ ( get the return stack entry ) 1344 | CASE 1345 | ' EXCEPTION-MARKER 4+ OF ( is it the exception stack frame? ) 1346 | ." CATCH ( DSP=" 1347 | 4+ DUP @ U. ( print saved stack pointer ) 1348 | ." ) " 1349 | ENDOF 1350 | ( default case ) 1351 | DUP 1352 | CFA> ( look up the codeword to get the dictionary entry ) 1353 | ?DUP IF ( and print it ) 1354 | 2DUP ( dea addr dea ) 1355 | ID. ( print word from dictionary entry ) 1356 | [ CHAR + ] LITERAL EMIT 1357 | SWAP >DFA 4+ - . ( print offset ) 1358 | THEN 1359 | ENDCASE 1360 | 4+ ( move up the stack ) 1361 | REPEAT 1362 | DROP 1363 | CR 1364 | ; 1365 | 1366 | ( 1367 | C STRINGS ---------------------------------------------------------------------- 1368 | 1369 | FORTH strings are represented by a start address and length kept on the stack or in memory. 1370 | 1371 | Most FORTHs don't handle C strings, but we need them in order to access the process arguments 1372 | and environment left on the stack by the Linux kernel, and to make some system calls. 1373 | 1374 | Operation Input Output FORTH word Notes 1375 | ---------------------------------------------------------------------- 1376 | 1377 | Create FORTH string addr len S" ..." 1378 | 1379 | Create C string c-addr Z" ..." 1380 | 1381 | C -> FORTH c-addr addr len DUP STRLEN 1382 | 1383 | FORTH -> C addr len c-addr CSTRING Allocated in a temporary buffer, so 1384 | should be consumed / copied immediately. 1385 | FORTH string should not contain NULs. 1386 | 1387 | For example, DUP STRLEN TELL prints a C string. 1388 | ) 1389 | 1390 | ( 1391 | Z" .." is like S" ..." except that the string is terminated by an ASCII NUL character. 1392 | 1393 | To make it more like a C string, at runtime Z" just leaves the address of the string 1394 | on the stack (not address & length as with S"). To implement this we need to add the 1395 | extra NUL to the string and also a DROP instruction afterwards. Apart from that the 1396 | implementation just a modified S". 1397 | ) 1398 | : Z" IMMEDIATE 1399 | STATE @ IF ( compiling? ) 1400 | ' LITSTRING , ( compile LITSTRING ) 1401 | HERE @ ( save the address of the length word on the stack ) 1402 | 0 , ( dummy length - we don't know what it is yet ) 1403 | BEGIN 1404 | KEY ( get next character of the string ) 1405 | DUP '"' <> 1406 | WHILE 1407 | HERE @ C! ( store the character in the compiled image ) 1408 | 1 HERE +! ( increment HERE pointer by 1 byte ) 1409 | REPEAT 1410 | 0 HERE @ C! ( add the ASCII NUL byte ) 1411 | 1 HERE +! 1412 | DROP ( drop the double quote character at the end ) 1413 | DUP ( get the saved address of the length word ) 1414 | HERE @ SWAP - ( calculate the length ) 1415 | 4- ( subtract 4 (because we measured from the start of the length word) ) 1416 | SWAP ! ( and back-fill the length location ) 1417 | ALIGN ( round up to next multiple of 4 bytes for the remaining code ) 1418 | ' DROP , ( compile DROP (to drop the length) ) 1419 | ELSE ( immediate mode ) 1420 | HERE @ ( get the start address of the temporary space ) 1421 | BEGIN 1422 | KEY 1423 | DUP '"' <> 1424 | WHILE 1425 | OVER C! ( save next character ) 1426 | 1+ ( increment address ) 1427 | REPEAT 1428 | DROP ( drop the final " character ) 1429 | 0 SWAP C! ( store final ASCII NUL ) 1430 | HERE @ ( push the start address ) 1431 | THEN 1432 | ; 1433 | 1434 | : STRLEN ( str -- len ) 1435 | DUP ( save start address ) 1436 | BEGIN 1437 | DUP C@ 0<> ( zero byte found? ) 1438 | WHILE 1439 | 1+ 1440 | REPEAT 1441 | 1442 | SWAP - ( calculate the length ) 1443 | ; 1444 | 1445 | : CSTRING ( addr len -- c-addr ) 1446 | SWAP OVER ( len saddr len ) 1447 | HERE @ SWAP ( len saddr daddr len ) 1448 | CMOVE ( len ) 1449 | 1450 | HERE @ + ( daddr+len ) 1451 | 0 SWAP C! ( store terminating NUL char ) 1452 | 1453 | HERE @ ( push start address ) 1454 | ; 1455 | 1456 | ( 1457 | THE ENVIRONMENT ---------------------------------------------------------------------- 1458 | 1459 | Linux makes the process arguments and environment available to us on the stack. 1460 | 1461 | The top of stack pointer is saved by the early assembler code when we start up in the FORTH 1462 | variable S0, and starting at this pointer we can read out the command line arguments and the 1463 | environment. 1464 | 1465 | Starting at S0, S0 itself points to argc (the number of command line arguments). 1466 | 1467 | S0+4 points to argv[0], S0+8 points to argv[1] etc up to argv[argc-1]. 1468 | 1469 | argv[argc] is a NULL pointer. 1470 | 1471 | After that the stack contains environment variables, a set of pointers to strings of the 1472 | form NAME=VALUE and on until we get to another NULL pointer. 1473 | 1474 | The first word that we define, ARGC, pushes the number of command line arguments (note that 1475 | as with C argc, this includes the name of the command). 1476 | ) 1477 | : ARGC 1478 | S0 @ @ 1479 | ; 1480 | 1481 | ( 1482 | n ARGV gets the nth command line argument. 1483 | 1484 | For example to print the command name you would do: 1485 | 0 ARGV TELL CR 1486 | ) 1487 | : ARGV ( n -- str u ) 1488 | 1+ CELLS S0 @ + ( get the address of argv[n] entry ) 1489 | @ ( get the address of the string ) 1490 | DUP STRLEN ( and get its length / turn it into a FORTH string ) 1491 | ; 1492 | 1493 | ( 1494 | ENVIRON returns the address of the first environment string. The list of strings ends 1495 | with a NULL pointer. 1496 | 1497 | For example to print the first string in the environment you could do: 1498 | ENVIRON @ DUP STRLEN TELL 1499 | ) 1500 | : ENVIRON ( -- addr ) 1501 | ARGC ( number of command line parameters on the stack to skip ) 1502 | 2 + ( skip command line count and NULL pointer after the command line args ) 1503 | CELLS ( convert to an offset ) 1504 | S0 @ + ( add to base stack address ) 1505 | ; 1506 | 1507 | ( 1508 | SYSTEM CALLS AND FILES ---------------------------------------------------------------------- 1509 | 1510 | Miscellaneous words related to system calls, and standard access to files. 1511 | ) 1512 | 1513 | ( BYE exits by calling the Linux exit(2) syscall. ) 1514 | : BYE ( -- ) 1515 | 0 ( return code (0) ) 1516 | SYS_EXIT ( system call number ) 1517 | SYSCALL1 1518 | ; 1519 | 1520 | ( 1521 | UNUSED returns the number of cells remaining in the user memory (data segment). 1522 | 1523 | For our implementation we will use Linux brk(2) system call to find out the end 1524 | of the data segment and subtract HERE from it. 1525 | ) 1526 | : GET-BRK ( -- brkpoint ) 1527 | 0 SYS_BRK SYSCALL1 ( call brk(0) ) 1528 | ; 1529 | 1530 | : UNUSED ( -- n ) 1531 | GET-BRK ( get end of data segment according to the kernel ) 1532 | HERE @ ( get current position in data segment ) 1533 | - 1534 | 4 / ( returns number of cells ) 1535 | ; 1536 | 1537 | ( 1538 | MORECORE increases the data segment by the specified number of (4 byte) cells. 1539 | 1540 | NB. The number of cells requested should normally be a multiple of 1024. The 1541 | reason is that Linux can't extend the data segment by less than a single page 1542 | (4096 bytes or 1024 cells). 1543 | 1544 | This FORTH doesn't automatically increase the size of the data segment "on demand" 1545 | (ie. when , (COMMA), ALLOT, CREATE, and so on are used). Instead the programmer 1546 | needs to be aware of how much space a large allocation will take, check UNUSED, and 1547 | call MORECORE if necessary. A simple programming exercise is to change the 1548 | implementation of the data segment so that MORECORE is called automatically if 1549 | the program needs more memory. 1550 | ) 1551 | : BRK ( brkpoint -- ) 1552 | SYS_BRK SYSCALL1 1553 | ; 1554 | 1555 | : MORECORE ( cells -- ) 1556 | CELLS GET-BRK + BRK 1557 | ; 1558 | 1559 | ( 1560 | Standard FORTH provides some simple file access primitives which we model on 1561 | top of Linux syscalls. 1562 | 1563 | The main complication is converting FORTH strings (address & length) into C 1564 | strings for the Linux kernel. 1565 | 1566 | Notice there is no buffering in this implementation. 1567 | ) 1568 | 1569 | : R/O ( -- fam ) O_RDONLY ; 1570 | : R/W ( -- fam ) O_RDWR ; 1571 | 1572 | : OPEN-FILE ( addr u fam -- fd 0 (if successful) | c-addr u fam -- fd errno (if there was an error) ) 1573 | -ROT ( fam addr u ) 1574 | CSTRING ( fam cstring ) 1575 | SYS_OPEN SYSCALL2 ( open (filename, flags) ) 1576 | DUP ( fd fd ) 1577 | DUP 0< IF ( errno? ) 1578 | NEGATE ( fd errno ) 1579 | ELSE 1580 | DROP 0 ( fd 0 ) 1581 | THEN 1582 | ; 1583 | 1584 | : CREATE-FILE ( addr u fam -- fd 0 (if successful) | c-addr u fam -- fd errno (if there was an error) ) 1585 | O_CREAT OR 1586 | O_TRUNC OR 1587 | -ROT ( fam addr u ) 1588 | CSTRING ( fam cstring ) 1589 | 420 -ROT ( 0644 fam cstring ) 1590 | SYS_OPEN SYSCALL3 ( open (filename, flags|O_TRUNC|O_CREAT, 0644) ) 1591 | DUP ( fd fd ) 1592 | DUP 0< IF ( errno? ) 1593 | NEGATE ( fd errno ) 1594 | ELSE 1595 | DROP 0 ( fd 0 ) 1596 | THEN 1597 | ; 1598 | 1599 | : CLOSE-FILE ( fd -- 0 (if successful) | fd -- errno (if there was an error) ) 1600 | SYS_CLOSE SYSCALL1 1601 | NEGATE 1602 | ; 1603 | 1604 | : READ-FILE ( addr u fd -- u2 0 (if successful) | addr u fd -- 0 0 (if EOF) | addr u fd -- u2 errno (if error) ) 1605 | >R SWAP R> ( u addr fd ) 1606 | SYS_READ SYSCALL3 1607 | 1608 | DUP ( u2 u2 ) 1609 | DUP 0< IF ( errno? ) 1610 | NEGATE ( u2 errno ) 1611 | ELSE 1612 | DROP 0 ( u2 0 ) 1613 | THEN 1614 | ; 1615 | 1616 | ( 1617 | PERROR prints a message for an errno, similar to C's perror(3) but we don't have the extensive 1618 | list of strerror strings available, so all we can do is print the errno. 1619 | ) 1620 | : PERROR ( errno addr u -- ) 1621 | TELL 1622 | ':' EMIT SPACE 1623 | ." ERRNO=" 1624 | . CR 1625 | ; 1626 | 1627 | ( 1628 | ASSEMBLER CODE ---------------------------------------------------------------------- 1629 | 1630 | This is just the outline of a simple assembler, allowing you to write FORTH primitives 1631 | in assembly language. 1632 | 1633 | Assembly primitives begin ': NAME' in the normal way, but are ended with ;CODE. ;CODE 1634 | updates the header so that the codeword isn't DOCOL, but points instead to the assembled 1635 | code (in the DFA part of the word). 1636 | 1637 | We provide a convenience macro NEXT (you guessed what it does). However you don't need to 1638 | use it because ;CODE will put a NEXT at the end of your word. 1639 | 1640 | The rest consists of some immediate words which expand into machine code appended to the 1641 | definition of the word. Only a very tiny part of the i386 assembly space is covered, just 1642 | enough to write a few assembler primitives below. 1643 | ) 1644 | 1645 | HEX 1646 | 1647 | ( Equivalent to the NEXT macro ) 1648 | : NEXT IMMEDIATE AD C, FF C, 20 C, ; 1649 | 1650 | : ;CODE IMMEDIATE 1651 | [COMPILE] NEXT ( end the word with NEXT macro ) 1652 | ALIGN ( machine code is assembled in bytes so isn't necessarily aligned at the end ) 1653 | LATEST @ DUP 1654 | HIDDEN ( unhide the word ) 1655 | DUP >DFA SWAP >CFA ! ( change the codeword to point to the data area ) 1656 | [COMPILE] [ ( go back to immediate mode ) 1657 | ; 1658 | 1659 | ( The i386 registers ) 1660 | : EAX IMMEDIATE 0 ; 1661 | : ECX IMMEDIATE 1 ; 1662 | : EDX IMMEDIATE 2 ; 1663 | : EBX IMMEDIATE 3 ; 1664 | : ESP IMMEDIATE 4 ; 1665 | : EBP IMMEDIATE 5 ; 1666 | : ESI IMMEDIATE 6 ; 1667 | : EDI IMMEDIATE 7 ; 1668 | 1669 | ( i386 stack instructions ) 1670 | : PUSH IMMEDIATE 50 + C, ; 1671 | : POP IMMEDIATE 58 + C, ; 1672 | 1673 | ( RDTSC instruction ) 1674 | : RDTSC IMMEDIATE 0F C, 31 C, ; 1675 | 1676 | DECIMAL 1677 | 1678 | ( 1679 | RDTSC is an assembler primitive which reads the Pentium timestamp counter (a very fine- 1680 | grained counter which counts processor clock cycles). Because the TSC is 64 bits wide 1681 | we have to push it onto the stack in two slots. 1682 | ) 1683 | : RDTSC ( -- lsb msb ) 1684 | RDTSC ( writes the result in %edx:%eax ) 1685 | EAX PUSH ( push lsb ) 1686 | EDX PUSH ( push msb ) 1687 | ;CODE 1688 | 1689 | ( 1690 | INLINE can be used to inline an assembler primitive into the current (assembler) 1691 | word. 1692 | 1693 | For example: 1694 | 1695 | : 2DROP INLINE DROP INLINE DROP ;CODE 1696 | 1697 | will build an efficient assembler word 2DROP which contains the inline assembly code 1698 | for DROP followed by DROP (eg. two 'pop %eax' instructions in this case). 1699 | 1700 | Another example. Consider this ordinary FORTH definition: 1701 | 1702 | : C@++ ( addr -- addr+1 byte ) DUP 1+ SWAP C@ ; 1703 | 1704 | (it is equivalent to the C operation '*p++' where p is a pointer to char). If we 1705 | notice that all of the words used to define C@++ are in fact assembler primitives, 1706 | then we can write a faster (but equivalent) definition like this: 1707 | 1708 | : C@++ INLINE DUP INLINE 1+ INLINE SWAP INLINE C@ ;CODE 1709 | 1710 | One interesting point to note is that this "concatenative" style of programming 1711 | allows you to write assembler words portably. The above definition would work 1712 | for any CPU architecture. 1713 | 1714 | There are several conditions that must be met for INLINE to be used successfully: 1715 | 1716 | (1) You must be currently defining an assembler word (ie. : ... ;CODE). 1717 | 1718 | (2) The word that you are inlining must be known to be an assembler word. If you try 1719 | to inline a FORTH word, you'll get an error message. 1720 | 1721 | (3) The assembler primitive must be position-independent code and must end with a 1722 | single NEXT macro. 1723 | 1724 | Exercises for the reader: (a) Generalise INLINE so that it can inline FORTH words when 1725 | building FORTH words. (b) Further generalise INLINE so that it does something sensible 1726 | when you try to inline FORTH into assembler and vice versa. 1727 | 1728 | The implementation of INLINE is pretty simple. We find the word in the dictionary, 1729 | check it's an assembler word, then copy it into the current definition, byte by byte, 1730 | until we reach the NEXT macro (which is not copied). 1731 | ) 1732 | HEX 1733 | : =NEXT ( addr -- next? ) 1734 | DUP C@ AD <> IF DROP FALSE EXIT THEN 1735 | 1+ DUP C@ FF <> IF DROP FALSE EXIT THEN 1736 | 1+ C@ 20 <> IF FALSE EXIT THEN 1737 | TRUE 1738 | ; 1739 | DECIMAL 1740 | 1741 | ( (INLINE) is the lowlevel inline function. ) 1742 | : (INLINE) ( cfa -- ) 1743 | @ ( remember codeword points to the code ) 1744 | BEGIN ( copy bytes until we hit NEXT macro ) 1745 | DUP =NEXT NOT 1746 | WHILE 1747 | DUP C@ C, 1748 | 1+ 1749 | REPEAT 1750 | DROP 1751 | ; 1752 | 1753 | : INLINE IMMEDIATE 1754 | WORD FIND ( find the word in the dictionary ) 1755 | >CFA ( codeword ) 1756 | 1757 | DUP @ DOCOL = IF ( check codeword <> DOCOL (ie. not a FORTH word) ) 1758 | ." Cannot INLINE FORTH words" CR ABORT 1759 | THEN 1760 | 1761 | (INLINE) 1762 | ; 1763 | 1764 | HIDE =NEXT 1765 | 1766 | ( 1767 | NOTES ---------------------------------------------------------------------- 1768 | 1769 | DOES> isn't possible to implement with this FORTH because we don't have a separate 1770 | data pointer. 1771 | ) 1772 | 1773 | ( 1774 | WELCOME MESSAGE ---------------------------------------------------------------------- 1775 | 1776 | Print the version and OK prompt. 1777 | ) 1778 | 1779 | : WELCOME 1780 | S" TEST-MODE" FIND NOT IF 1781 | ." JONESFORTH VERSION " VERSION . CR 1782 | UNUSED . ." CELLS REMAINING" CR 1783 | ." OK " 1784 | THEN 1785 | ; 1786 | 1787 | WELCOME 1788 | HIDE WELCOME 1789 | -------------------------------------------------------------------------------- /tests/nostd-0branch.f: -------------------------------------------------------------------------------- 1 | : STAR 42 EMIT ; 2 | 3 | : [0REPEAT] IMMEDIATE 4 | ' STAR , 5 | ' DUP , 6 | ' 0BRANCH , 7 | -24 , 8 | ; 9 | 10 | : MAIN 11 | 1 12 | [0REPEAT] 13 | ; 14 | 15 | : ALTERNATIVE \ this will repeat 16 | 0 17 | [0REPEAT] 18 | ; 19 | 20 | MAIN 21 | -------------------------------------------------------------------------------- /tests/nostd-begin-until.f: -------------------------------------------------------------------------------- 1 | : BEGIN IMMEDIATE 2 | HERE @ 3 | ; 4 | 5 | : UNTIL IMMEDIATE 6 | ' 0BRANCH , 7 | HERE @ - 8 | , 9 | ; 10 | 11 | \ print number 12 | : PUTS 48 + EMIT 10 EMIT ; 13 | 14 | \ print 9 down to 1 15 | : MAIN 16 | 10 17 | BEGIN 18 | 1- 19 | DUP 20 | PUTS 21 | DUP 0= UNTIL 22 | DROP 23 | ; 24 | 25 | MAIN 26 | -------------------------------------------------------------------------------- /tests/nostd-branch.f: -------------------------------------------------------------------------------- 1 | : STAR 2 | 42 3 | EMIT 4 | ; 5 | 6 | : [BACK] IMMEDIATE 7 | ' BRANCH , 8 | -16 , 9 | ; 10 | 11 | : MAIN 12 | STAR 13 | [BACK] 14 | ; 15 | 16 | MAIN 17 | -------------------------------------------------------------------------------- /tests/nostd-case.f: -------------------------------------------------------------------------------- 1 | : IF IMMEDIATE 2 | ' 0BRANCH , 3 | HERE @ 4 | 0 , 5 | ; 6 | 7 | : THEN IMMEDIATE 8 | DUP 9 | HERE @ SWAP - 10 | SWAP ! 11 | ; 12 | 13 | : ELSE IMMEDIATE 14 | ' BRANCH , 15 | HERE @ 16 | 0 , 17 | SWAP 18 | DUP 19 | HERE @ SWAP - 20 | SWAP ! 21 | ; 22 | 23 | \ Loop Construct 24 | 25 | : BEGIN IMMEDIATE 26 | HERE @ 27 | ; 28 | 29 | : WHILE IMMEDIATE 30 | ' 0BRANCH , 31 | HERE @ 32 | 0 , 33 | ; 34 | 35 | : REPEAT IMMEDIATE 36 | ' BRANCH , 37 | SWAP 38 | HERE @ - , 39 | DUP 40 | HERE @ SWAP - 41 | SWAP ! 42 | ; 43 | 44 | : [COMPILE] IMMEDIATE 45 | WORD 46 | FIND 47 | >CFA 48 | , 49 | ; 50 | 51 | : CASE IMMEDIATE 52 | 0 53 | ; 54 | 55 | : OF IMMEDIATE 56 | ' OVER , 57 | ' = , 58 | [COMPILE] IF 59 | ' DROP , 60 | ; 61 | 62 | : ENDOF IMMEDIATE 63 | [COMPILE] ELSE 64 | ; 65 | 66 | : ENDCASE IMMEDIATE 67 | ' DROP , 68 | BEGIN 69 | ?DUP 70 | WHILE 71 | [COMPILE] THEN 72 | REPEAT 73 | ; 74 | 75 | -------------------------------------------------------------------------------- /tests/nostd-character-at.f: -------------------------------------------------------------------------------- 1 | LATEST @ 8+ 1+ C@ 2 | -------------------------------------------------------------------------------- /tests/nostd-cmp.f: -------------------------------------------------------------------------------- 1 | : CR 10 EMIT ; 2 | : PUTS 48 + EMIT CR ; 3 | 4 | 1 2 < PUTS 5 | 1 2 <= PUTS 6 | 1 2 = PUTS 7 | 1 2 >= PUTS 8 | 1 2 > PUTS 9 | CR 10 | 1 2 <> PUTS 11 | CR 12 | CR 13 | 2 2 < PUTS 14 | 2 2 <= PUTS 15 | 2 2 = PUTS 16 | 2 2 >= PUTS 17 | 2 2 > PUTS 18 | CR 19 | 2 2 <> PUTS 20 | CR 21 | CR 22 | 3 2 < PUTS 23 | 3 2 <= PUTS 24 | 3 2 = PUTS 25 | 3 2 >= PUTS 26 | 3 2 > PUTS 27 | CR 28 | 3 2 <> PUTS 29 | 30 | -------------------------------------------------------------------------------- /tests/nostd-colon.f: -------------------------------------------------------------------------------- 1 | : foo + ; 2 | 1 2 foo 3 | 48 foo 4 | EMIT 5 | 10 EMIT 6 | -------------------------------------------------------------------------------- /tests/nostd-comments.f: -------------------------------------------------------------------------------- 1 | \ Ingredients Needed: 2 | \ - IF ELSE THEN 3 | \ - BEGIN UNTIL 4 | \ - '(' ')' 5 | 6 | : IF IMMEDIATE 7 | ' 0BRANCH , 8 | HERE @ 9 | 0 , 10 | ; 11 | 12 | : THEN IMMEDIATE 13 | DUP 14 | HERE @ SWAP - 15 | SWAP ! 16 | ; 17 | 18 | : ELSE IMMEDIATE 19 | ' BRANCH , 20 | HERE @ 21 | 0 , 22 | SWAP 23 | DUP 24 | HERE @ SWAP - 25 | SWAP ! 26 | ; 27 | 28 | : BEGIN IMMEDIATE 29 | HERE @ 30 | ; 31 | 32 | : UNTIL IMMEDIATE 33 | ' 0BRANCH , 34 | HERE @ - 35 | , 36 | ; 37 | 38 | : LITERAL IMMEDIATE 39 | ' LIT , 40 | , 41 | ; 42 | 43 | : '(' [ CHAR ( ] LITERAL ; 44 | : ')' [ CHAR ) ] LITERAL ; 45 | 46 | : ( IMMEDIATE 47 | 1 48 | BEGIN 49 | KEY 50 | DUP '(' = IF 51 | DROP 52 | 1+ 53 | ELSE 54 | ')' = IF 55 | 1- 56 | THEN 57 | THEN 58 | DUP 0= UNTIL 59 | DROP 60 | ; 61 | 62 | ( foo ) 63 | ( this should compile fine ) 64 | ( and nested ( ... ) should works too ) 65 | -------------------------------------------------------------------------------- /tests/nostd-distance.f: -------------------------------------------------------------------------------- 1 | : START IMMEDIATE 2 | HERE @ 3 | ; 4 | 5 | : FINISH IMMEDIATE 6 | ' LIT , 7 | HERE @ - 8 | , 9 | ; 10 | 11 | : NOP ; 12 | 13 | : MAIN 14 | START 15 | NOP 16 | NOP 17 | FINISH 18 | ; 19 | 20 | MAIN 21 | 0 SWAP - 22 | CHAR 0 + 23 | EMIT 24 | 10 25 | EMIT 26 | -------------------------------------------------------------------------------- /tests/nostd-fortytwo.f: -------------------------------------------------------------------------------- 1 | FORTYTWO EMIT 2 | 10 EMIT 3 | -------------------------------------------------------------------------------- /tests/nostd-iszero.f: -------------------------------------------------------------------------------- 1 | : CR 10 EMIT ; 2 | : PUTS 48 + EMIT CR ; 3 | 4 | -1 0= PUTS 5 | 0 0= PUTS 6 | 1 0= PUTS 7 | CR 8 | -1 0<> PUTS 9 | 0 0<> PUTS 10 | 1 0<> PUTS 11 | CR 12 | -1 0< PUTS 13 | 0 0< PUTS 14 | 1 0< PUTS 15 | CR 16 | -1 0> PUTS 17 | 0 0> PUTS 18 | 1 0> PUTS 19 | CR 20 | -1 0<= PUTS 21 | 0 0<= PUTS 22 | 1 0<= PUTS 23 | CR 24 | -1 0>= PUTS 25 | 0 0>= PUTS 26 | 1 0>= PUTS 27 | -------------------------------------------------------------------------------- /tests/nostd-numops.f: -------------------------------------------------------------------------------- 1 | 1 1 + 2 | 48 + EMIT \ print 1 digit number 3 | 10 EMIT \ newline 4 | \ should output 2 5 | -------------------------------------------------------------------------------- /tests/nostd-print.f: -------------------------------------------------------------------------------- 1 | : LITERAL IMMEDIATE 2 | ' LIT , 3 | , 4 | ; 5 | 6 | : '"' [ CHAR " ] LITERAL ; 7 | 8 | : IF IMMEDIATE 9 | ' 0BRANCH , 10 | HERE @ 11 | 0 , 12 | ; 13 | 14 | : ELSE IMMEDIATE 15 | ' BRANCH , 16 | HERE @ 17 | 0 , 18 | SWAP 19 | DUP 20 | HERE @ SWAP - 21 | SWAP ! 22 | ; 23 | 24 | : THEN IMMEDIATE 25 | DUP 26 | HERE @ SWAP - 27 | SWAP ! 28 | ; 29 | 30 | \ Loop Construct 31 | 32 | : BEGIN IMMEDIATE 33 | HERE @ 34 | ; 35 | 36 | : WHILE IMMEDIATE 37 | ' 0BRANCH , 38 | HERE @ 39 | 0 , 40 | ; 41 | 42 | : REPEAT IMMEDIATE 43 | ' BRANCH , 44 | SWAP 45 | HERE @ - , 46 | DUP 47 | HERE @ SWAP - 48 | SWAP ! 49 | ; 50 | 51 | : AGAIN IMMEDIATE 52 | ' BRANCH , 53 | HERE @ - 54 | , 55 | ; 56 | 57 | : C, 58 | HERE @ C! 59 | 1 HERE +! 60 | ; 61 | 62 | : ALIGNED 7 + 7 INVERT AND ; 63 | 64 | : ALIGN HERE @ ALIGNED HERE ! ; 65 | 66 | : S" IMMEDIATE 67 | STATE @ IF 68 | ' LITSTRING , 69 | HERE @ 70 | 0 , 71 | BEGIN 72 | KEY 73 | DUP '"' <> 74 | WHILE 75 | C, 76 | REPEAT 77 | DROP 78 | DUP 79 | HERE @ SWAP - 80 | 8- 81 | SWAP ! 82 | ALIGN 83 | ELSE 84 | HERE @ 85 | BEGIN 86 | KEY 87 | DUP '"' <> 88 | WHILE 89 | OVER C! 90 | 1+ 91 | REPEAT 92 | DROP 93 | HERE @ - 94 | HERE @ 95 | SWAP 96 | THEN 97 | ; 98 | 99 | : [COMPILE] IMMEDIATE 100 | WORD 101 | FIND 102 | >CFA 103 | , 104 | ; 105 | 106 | : ." IMMEDIATE 107 | STATE @ IF 108 | [COMPILE] S" 109 | ' TELL , 110 | ELSE 111 | BEGIN 112 | KEY 113 | DUP '"' = IF 114 | DROP 115 | EXIT 116 | THEN 117 | EMIT 118 | AGAIN 119 | THEN 120 | ; 121 | 122 | : FOO ." HELLO WORLD" ; 123 | 124 | FOO 125 | -------------------------------------------------------------------------------- /tests/nostd-puts.f: -------------------------------------------------------------------------------- 1 | : puts 48 + EMIT 10 EMIT ; 2 | 0 puts 3 | 1 puts 4 | 2 puts 5 | 3 puts 6 | 4 puts 7 | 5 puts 8 | 6 puts 9 | 7 puts 10 | 8 puts 11 | 9 puts 12 | 13 | -------------------------------------------------------------------------------- /tests/nostd-squote.f: -------------------------------------------------------------------------------- 1 | : LITERAL IMMEDIATE 2 | ' LIT , 3 | , 4 | ; 5 | 6 | : '"' [ CHAR " ] LITERAL ; 7 | 8 | : IF IMMEDIATE 9 | ' 0BRANCH , 10 | HERE @ 11 | 0 , 12 | ; 13 | 14 | : THEN IMMEDIATE 15 | DUP 16 | HERE @ SWAP - 17 | SWAP ! 18 | ; 19 | 20 | : ELSE IMMEDIATE 21 | ' BRANCH , 22 | HERE @ 23 | 0 , 24 | SWAP 25 | DUP 26 | HERE @ SWAP - 27 | SWAP ! 28 | ; 29 | 30 | : BEGIN IMMEDIATE 31 | HERE @ 32 | ; 33 | 34 | : WHILE IMMEDIATE 35 | ' 0BRANCH , 36 | HERE @ 37 | 0 , 38 | ; 39 | 40 | : REPEAT IMMEDIATE 41 | ' BRANCH , 42 | SWAP 43 | HERE @ - , 44 | DUP 45 | HERE @ SWAP - 46 | SWAP ! 47 | ; 48 | 49 | : ALIGNED 50 | 7 + 7 INVERT AND 51 | ; 52 | 53 | : ALIGN HERE @ ALIGNED HERE ; 54 | 55 | : C, 56 | HERE @ C! 57 | 1 HERE +! 58 | ; 59 | 60 | : S" IMMEDIATE 61 | STATE @ IF 62 | ' LITSTRING , 63 | HERE @ 64 | @ , 65 | BEGIN 66 | KEY 67 | DUP '"' <> 68 | WHILE 69 | C, 70 | REPEAT 71 | DROP 72 | DUP 73 | HERE @ SWAP - 74 | 8- 75 | SWAP ! 76 | ALIGN 77 | ELSE 78 | HERE @ 79 | BEGIN 80 | KEY 81 | DUP '"' <> 82 | WHILE 83 | OVER C! 84 | 1+ 85 | REPEAT 86 | DROP 87 | HERE @ - 88 | HERE @ 89 | SWAP 90 | THEN 91 | ; 92 | 93 | S" HELLO WORLD" 94 | -------------------------------------------------------------------------------- /tests/nostd-unless.f: -------------------------------------------------------------------------------- 1 | : NOT 0= ; 2 | 3 | : [COMPILE] IMMEDIATE 4 | WORD 5 | FIND 6 | >CFA 7 | , 8 | ; 9 | 10 | : IF IMMEDIATE 11 | ' 0BRANCH , 12 | HERE @ 13 | 0 , 14 | ; 15 | 16 | : THEN IMMEDIATE 17 | DUP 18 | HERE @ SWAP - 19 | SWAP ! 20 | ; 21 | 22 | : ELSE IMMEDIATE 23 | ' BRANCH , 24 | HERE @ 25 | 0 , 26 | SWAP 27 | DUP 28 | HERE @ SWAP - 29 | SWAP ! 30 | ; 31 | 32 | : UNLESS IMMEDIATE 33 | ' NOT , 34 | [COMPILE] IF 35 | ; 36 | -------------------------------------------------------------------------------- /tests/std-100.f: -------------------------------------------------------------------------------- 1 | : MAIN 2 | 0 3 | BEGIN 4 | 1+ 5 | DUP 100 <= WHILE 6 | DUP . 7 | REPEAT 8 | DROP 9 | ; 10 | 11 | MAIN 12 | -------------------------------------------------------------------------------- /unistd_64.inc: -------------------------------------------------------------------------------- 1 | %ifndef _ASM_X86_UNISTD_64_H 2 | %define _ASM_X86_UNISTD_64_H 1 3 | 4 | %define __NR_read 0 5 | %define __NR_write 1 6 | %define __NR_open 2 7 | %define __NR_close 3 8 | %define __NR_stat 4 9 | %define __NR_fstat 5 10 | %define __NR_lstat 6 11 | %define __NR_poll 7 12 | %define __NR_lseek 8 13 | %define __NR_mmap 9 14 | %define __NR_mprotect 10 15 | %define __NR_munmap 11 16 | %define __NR_brk 12 17 | %define __NR_rt_sigaction 13 18 | %define __NR_rt_sigprocmask 14 19 | %define __NR_rt_sigreturn 15 20 | %define __NR_ioctl 16 21 | %define __NR_pread64 17 22 | %define __NR_pwrite64 18 23 | %define __NR_readv 19 24 | %define __NR_writev 20 25 | %define __NR_access 21 26 | %define __NR_pipe 22 27 | %define __NR_select 23 28 | %define __NR_sched_yield 24 29 | %define __NR_mremap 25 30 | %define __NR_msync 26 31 | %define __NR_mincore 27 32 | %define __NR_madvise 28 33 | %define __NR_shmget 29 34 | %define __NR_shmat 30 35 | %define __NR_shmctl 31 36 | %define __NR_dup 32 37 | %define __NR_dup2 33 38 | %define __NR_pause 34 39 | %define __NR_nanosleep 35 40 | %define __NR_getitimer 36 41 | %define __NR_alarm 37 42 | %define __NR_setitimer 38 43 | %define __NR_getpid 39 44 | %define __NR_sendfile 40 45 | %define __NR_socket 41 46 | %define __NR_connect 42 47 | %define __NR_accept 43 48 | %define __NR_sendto 44 49 | %define __NR_recvfrom 45 50 | %define __NR_sendmsg 46 51 | %define __NR_recvmsg 47 52 | %define __NR_shutdown 48 53 | %define __NR_bind 49 54 | %define __NR_listen 50 55 | %define __NR_getsockname 51 56 | %define __NR_getpeername 52 57 | %define __NR_socketpair 53 58 | %define __NR_setsockopt 54 59 | %define __NR_getsockopt 55 60 | %define __NR_clone 56 61 | %define __NR_fork 57 62 | %define __NR_vfork 58 63 | %define __NR_execve 59 64 | %define __NR_exit 60 65 | %define __NR_wait4 61 66 | %define __NR_kill 62 67 | %define __NR_uname 63 68 | %define __NR_semget 64 69 | %define __NR_semop 65 70 | %define __NR_semctl 66 71 | %define __NR_shmdt 67 72 | %define __NR_msgget 68 73 | %define __NR_msgsnd 69 74 | %define __NR_msgrcv 70 75 | %define __NR_msgctl 71 76 | %define __NR_fcntl 72 77 | %define __NR_flock 73 78 | %define __NR_fsync 74 79 | %define __NR_fdatasync 75 80 | %define __NR_truncate 76 81 | %define __NR_ftruncate 77 82 | %define __NR_getdents 78 83 | %define __NR_getcwd 79 84 | %define __NR_chdir 80 85 | %define __NR_fchdir 81 86 | %define __NR_rename 82 87 | %define __NR_mkdir 83 88 | %define __NR_rmdir 84 89 | %define __NR_creat 85 90 | %define __NR_link 86 91 | %define __NR_unlink 87 92 | %define __NR_symlink 88 93 | %define __NR_readlink 89 94 | %define __NR_chmod 90 95 | %define __NR_fchmod 91 96 | %define __NR_chown 92 97 | %define __NR_fchown 93 98 | %define __NR_lchown 94 99 | %define __NR_umask 95 100 | %define __NR_gettimeofday 96 101 | %define __NR_getrlimit 97 102 | %define __NR_getrusage 98 103 | %define __NR_sysinfo 99 104 | %define __NR_times 100 105 | %define __NR_ptrace 101 106 | %define __NR_getuid 102 107 | %define __NR_syslog 103 108 | %define __NR_getgid 104 109 | %define __NR_setuid 105 110 | %define __NR_setgid 106 111 | %define __NR_geteuid 107 112 | %define __NR_getegid 108 113 | %define __NR_setpgid 109 114 | %define __NR_getppid 110 115 | %define __NR_getpgrp 111 116 | %define __NR_setsid 112 117 | %define __NR_setreuid 113 118 | %define __NR_setregid 114 119 | %define __NR_getgroups 115 120 | %define __NR_setgroups 116 121 | %define __NR_setresuid 117 122 | %define __NR_getresuid 118 123 | %define __NR_setresgid 119 124 | %define __NR_getresgid 120 125 | %define __NR_getpgid 121 126 | %define __NR_setfsuid 122 127 | %define __NR_setfsgid 123 128 | %define __NR_getsid 124 129 | %define __NR_capget 125 130 | %define __NR_capset 126 131 | %define __NR_rt_sigpending 127 132 | %define __NR_rt_sigtimedwait 128 133 | %define __NR_rt_sigqueueinfo 129 134 | %define __NR_rt_sigsuspend 130 135 | %define __NR_sigaltstack 131 136 | %define __NR_utime 132 137 | %define __NR_mknod 133 138 | %define __NR_uselib 134 139 | %define __NR_personality 135 140 | %define __NR_ustat 136 141 | %define __NR_statfs 137 142 | %define __NR_fstatfs 138 143 | %define __NR_sysfs 139 144 | %define __NR_getpriority 140 145 | %define __NR_setpriority 141 146 | %define __NR_sched_setparam 142 147 | %define __NR_sched_getparam 143 148 | %define __NR_sched_setscheduler 144 149 | %define __NR_sched_getscheduler 145 150 | %define __NR_sched_get_priority_max 146 151 | %define __NR_sched_get_priority_min 147 152 | %define __NR_sched_rr_get_interval 148 153 | %define __NR_mlock 149 154 | %define __NR_munlock 150 155 | %define __NR_mlockall 151 156 | %define __NR_munlockall 152 157 | %define __NR_vhangup 153 158 | %define __NR_modify_ldt 154 159 | %define __NR_pivot_root 155 160 | %define __NR__sysctl 156 161 | %define __NR_prctl 157 162 | %define __NR_arch_prctl 158 163 | %define __NR_adjtimex 159 164 | %define __NR_setrlimit 160 165 | %define __NR_chroot 161 166 | %define __NR_sync 162 167 | %define __NR_acct 163 168 | %define __NR_settimeofday 164 169 | %define __NR_mount 165 170 | %define __NR_umount2 166 171 | %define __NR_swapon 167 172 | %define __NR_swapoff 168 173 | %define __NR_reboot 169 174 | %define __NR_sethostname 170 175 | %define __NR_setdomainname 171 176 | %define __NR_iopl 172 177 | %define __NR_ioperm 173 178 | %define __NR_create_module 174 179 | %define __NR_init_module 175 180 | %define __NR_delete_module 176 181 | %define __NR_get_kernel_syms 177 182 | %define __NR_query_module 178 183 | %define __NR_quotactl 179 184 | %define __NR_nfsservctl 180 185 | %define __NR_getpmsg 181 186 | %define __NR_putpmsg 182 187 | %define __NR_afs_syscall 183 188 | %define __NR_tuxcall 184 189 | %define __NR_security 185 190 | %define __NR_gettid 186 191 | %define __NR_readahead 187 192 | %define __NR_setxattr 188 193 | %define __NR_lsetxattr 189 194 | %define __NR_fsetxattr 190 195 | %define __NR_getxattr 191 196 | %define __NR_lgetxattr 192 197 | %define __NR_fgetxattr 193 198 | %define __NR_listxattr 194 199 | %define __NR_llistxattr 195 200 | %define __NR_flistxattr 196 201 | %define __NR_removexattr 197 202 | %define __NR_lremovexattr 198 203 | %define __NR_fremovexattr 199 204 | %define __NR_tkill 200 205 | %define __NR_time 201 206 | %define __NR_futex 202 207 | %define __NR_sched_setaffinity 203 208 | %define __NR_sched_getaffinity 204 209 | %define __NR_set_thread_area 205 210 | %define __NR_io_setup 206 211 | %define __NR_io_destroy 207 212 | %define __NR_io_getevents 208 213 | %define __NR_io_submit 209 214 | %define __NR_io_cancel 210 215 | %define __NR_get_thread_area 211 216 | %define __NR_lookup_dcookie 212 217 | %define __NR_epoll_create 213 218 | %define __NR_epoll_ctl_old 214 219 | %define __NR_epoll_wait_old 215 220 | %define __NR_remap_file_pages 216 221 | %define __NR_getdents64 217 222 | %define __NR_set_tid_address 218 223 | %define __NR_restart_syscall 219 224 | %define __NR_semtimedop 220 225 | %define __NR_fadvise64 221 226 | %define __NR_timer_create 222 227 | %define __NR_timer_settime 223 228 | %define __NR_timer_gettime 224 229 | %define __NR_timer_getoverrun 225 230 | %define __NR_timer_delete 226 231 | %define __NR_clock_settime 227 232 | %define __NR_clock_gettime 228 233 | %define __NR_clock_getres 229 234 | %define __NR_clock_nanosleep 230 235 | %define __NR_exit_group 231 236 | %define __NR_epoll_wait 232 237 | %define __NR_epoll_ctl 233 238 | %define __NR_tgkill 234 239 | %define __NR_utimes 235 240 | %define __NR_vserver 236 241 | %define __NR_mbind 237 242 | %define __NR_set_mempolicy 238 243 | %define __NR_get_mempolicy 239 244 | %define __NR_mq_open 240 245 | %define __NR_mq_unlink 241 246 | %define __NR_mq_timedsend 242 247 | %define __NR_mq_timedreceive 243 248 | %define __NR_mq_notify 244 249 | %define __NR_mq_getsetattr 245 250 | %define __NR_kexec_load 246 251 | %define __NR_waitid 247 252 | %define __NR_add_key 248 253 | %define __NR_request_key 249 254 | %define __NR_keyctl 250 255 | %define __NR_ioprio_set 251 256 | %define __NR_ioprio_get 252 257 | %define __NR_inotify_init 253 258 | %define __NR_inotify_add_watch 254 259 | %define __NR_inotify_rm_watch 255 260 | %define __NR_migrate_pages 256 261 | %define __NR_openat 257 262 | %define __NR_mkdirat 258 263 | %define __NR_mknodat 259 264 | %define __NR_fchownat 260 265 | %define __NR_futimesat 261 266 | %define __NR_newfstatat 262 267 | %define __NR_unlinkat 263 268 | %define __NR_renameat 264 269 | %define __NR_linkat 265 270 | %define __NR_symlinkat 266 271 | %define __NR_readlinkat 267 272 | %define __NR_fchmodat 268 273 | %define __NR_faccessat 269 274 | %define __NR_pselect6 270 275 | %define __NR_ppoll 271 276 | %define __NR_unshare 272 277 | %define __NR_set_robust_list 273 278 | %define __NR_get_robust_list 274 279 | %define __NR_splice 275 280 | %define __NR_tee 276 281 | %define __NR_sync_file_range 277 282 | %define __NR_vmsplice 278 283 | %define __NR_move_pages 279 284 | %define __NR_utimensat 280 285 | %define __NR_epoll_pwait 281 286 | %define __NR_signalfd 282 287 | %define __NR_timerfd_create 283 288 | %define __NR_eventfd 284 289 | %define __NR_fallocate 285 290 | %define __NR_timerfd_settime 286 291 | %define __NR_timerfd_gettime 287 292 | %define __NR_accept4 288 293 | %define __NR_signalfd4 289 294 | %define __NR_eventfd2 290 295 | %define __NR_epoll_create1 291 296 | %define __NR_dup3 292 297 | %define __NR_pipe2 293 298 | %define __NR_inotify_init1 294 299 | %define __NR_preadv 295 300 | %define __NR_pwritev 296 301 | %define __NR_rt_tgsigqueueinfo 297 302 | %define __NR_perf_event_open 298 303 | %define __NR_recvmmsg 299 304 | %define __NR_fanotify_init 300 305 | %define __NR_fanotify_mark 301 306 | %define __NR_prlimit64 302 307 | %define __NR_name_to_handle_at 303 308 | %define __NR_open_by_handle_at 304 309 | %define __NR_clock_adjtime 305 310 | %define __NR_syncfs 306 311 | %define __NR_sendmmsg 307 312 | %define __NR_setns 308 313 | %define __NR_getcpu 309 314 | %define __NR_process_vm_readv 310 315 | %define __NR_process_vm_writev 311 316 | %define __NR_kcmp 312 317 | %define __NR_finit_module 313 318 | %define __NR_sched_setattr 314 319 | %define __NR_sched_getattr 315 320 | %define __NR_renameat2 316 321 | %define __NR_seccomp 317 322 | %define __NR_getrandom 318 323 | %define __NR_memfd_create 319 324 | %define __NR_kexec_file_load 320 325 | %define __NR_bpf 321 326 | %define __NR_execveat 322 327 | %define __NR_userfaultfd 323 328 | %define __NR_membarrier 324 329 | %define __NR_mlock2 325 330 | 331 | %endif ; _ASM_X86_UNISTD_64_H 332 | --------------------------------------------------------------------------------