├── .gitignore ├── rayforth-launcher ├── test2.fs ├── test.fs ├── Makefile ├── localwords.fs ├── LICENSE.md ├── string.fs ├── see.fs ├── dijkstramap.fs ├── assembler.fs ├── boot.fs └── main.asm /.gitignore: -------------------------------------------------------------------------------- 1 | /*.o 2 | /rayforth 3 | -------------------------------------------------------------------------------- /rayforth-launcher: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | cat $@ - | ./rayforth 3 | -------------------------------------------------------------------------------- /test2.fs: -------------------------------------------------------------------------------- 1 | \ this is a file included from test.fs 2 | \ to test include nesting 3 | 4 | : BAZ 40 2 + . ; 5 | BAZ 6 | 7 | S" Thanks for using test2.fs" TYPE CR 8 | -------------------------------------------------------------------------------- /test.fs: -------------------------------------------------------------------------------- 1 | 1234567980 2 | 3 | : BAR 5 0 DO I . LOOP CR ; 4 | 5 | : BAZ 3 0 DO 3 0 DO J . I . CR LOOP LOOP ; 6 | 7 | : TESTTHIS DUP 0= IF DROP CR EXIT THEN DUP . 1 - RECURSE ; 5 TESTTHIS 8 | 9 | : TEST1 0 BEGIN DUP . 1 + DUP 10 = IF EXIT THEN AGAIN ; 10 | 11 | : TEST2 0 BEGIN DUP . DUP 10 <> WHILE 1 + REPEAT DROP ; 12 | 13 | 5 TESTTHIS 14 | 15 | BAR 16 | BAZ 17 | 18 | S" test2.fs" INCLUDED 19 | 20 | TEST1 DROP CR 21 | TEST2 CR 22 | . 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | BINARY=rayforth 2 | OBJECT=main.o 3 | ASM=nasm 4 | LD=ld 5 | ASMFLAGS=-f elf64 6 | LDFLAGS=-m elf_x86_64 -s --omagic 7 | #ASMFLAGSDBG=-f elf64 -g -F dwarf 8 | ASMFLAGSDBG=-f elf64 -g 9 | LDFLAGSDBG=-m elf_x86_64 -g --omagic 10 | 11 | .PHONY: clean test debug 12 | 13 | all: $(BINARY) 14 | 15 | %.o : %.asm 16 | 17 | $(BINARY): main.asm 18 | ${ASM} ${ASMFLAGS} main.asm 19 | ${LD} ${LDFLAGS} ${OBJECT} -o ${BINARY} 20 | 21 | debug: main.asm 22 | ${ASM} ${ASMFLAGSDBG} main.asm 23 | ${LD} ${LDFLAGSDBG} ${OBJECT} -o ${BINARY} 24 | 25 | clean: 26 | rm -f *.o ${BINARY} nul 27 | 28 | test: ${BINARY} 29 | cat test.fs | ./rayforth 30 | -------------------------------------------------------------------------------- /localwords.fs: -------------------------------------------------------------------------------- 1 | \ Local words 2 | \ Inspired by Carol Pruitt's article on Forth Dimensions V6N6 3 | \ http://www.forth.org/fd/FD-V06N6.pdf 4 | 5 | $40 constant LOCALBIT 6 | 7 | : LOCAL ( -- ) latest @ >FLAGS DUP c@ LOCALBIT or SWAP c! ; 8 | : local? ( addr -- f ) >FLAGS c@ LOCALBIT and ; 9 | 10 | ( local.start ) here 11 | 12 | variable link.from LOCAL 13 | 14 | : keep ( addr -- addr' ) dup link.from ! @ ; LOCAL 15 | : discard ( addr -- addr' ) @ dup link.from @ ! ; LOCAL 16 | 17 | : ?delink ( addr f -- addr' ) 18 | dup local? if discard exit then keep 19 | ; LOCAL 20 | 21 | : local.start ( -- start-of-local-area ) here ; 22 | : local.end ( start-of-local-area -- ) 23 | latest @ DUP link.from ! 24 | @ begin 2dup <= while ?delink repeat 2drop 25 | ; 26 | 27 | local.end 28 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Sergi Reyner 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /string.fs: -------------------------------------------------------------------------------- 1 | \ these words are likely better off being written in asm?... 2 | 3 | local.start 4 | 5 | 0 VALUE caddr1 LOCAL 6 | 0 VALUE caddr2 LOCAL 7 | 0 VALUE u1 LOCAL 8 | 0 VALUE u2 LOCAL 9 | 10 | : COMPARE ( caddr1 u1 caddr2 u2 -- -1/0/1 ) 11 | TO u2 TO caddr2 TO u1 TO caddr1 12 | 13 | BEGIN 14 | caddr2 count caddr1 count ( caddr2+1 c2 caddr1+1 c1 ) 15 | ROT ( caddr2+1 caddr1+1 c1 c2 ) 16 | 17 | 2DUP < IF 2DROP 2DROP -1 EXIT THEN 18 | > IF 2DROP 1 EXIT THEN 19 | 20 | TO caddr1 TO caddr2 21 | -1 +TO u1 -1 +TO u2 22 | 23 | u1 0= IF u2 IF -1 EXIT THEN 0 EXIT THEN 24 | u2 0= IF 1 EXIT THEN 25 | AGAIN 26 | ; 27 | 28 | local.end 29 | 30 | local.start 31 | 32 | 0 VALUE caddr1 LOCAL 33 | 0 VALUE caddr2 LOCAL 34 | 0 VALUE u1 LOCAL 35 | 0 VALUE u2 LOCAL 36 | 37 | : SEARCH ( caddr1 u1 caddr2 u2 -- caddr3 u3 f ) 38 | 2OVER TO u1 TO caddr1 TO u2 TO caddr2 ( caddr1 u1 ) 39 | 40 | BEGIN 41 | caddr1 u2 caddr2 u2 COMPARE 0= IF 2DROP caddr1 u2 TRUE EXIT THEN 42 | 1 +TO caddr1 -1 +TO u1 43 | u1 u2 < 44 | UNTIL 45 | FALSE 46 | ; 47 | 48 | local.end 49 | 50 | : upcase! ( c-addr u -- ) 51 | OVER + SWAP DO I C@ 'a 'z 1+ WITHIN IF -32 I c+! THEN LOOP 52 | ; 53 | -------------------------------------------------------------------------------- /see.fs: -------------------------------------------------------------------------------- 1 | local.start 2 | 3 | : (fetch32) ( addr -- u32 ) 4 | 0 SWAP 5 | 32 0 DO 6 | COUNT I LSHIFT UNDER+ 7 | 8 +LOOP 8 | DROP 9 | DUP $80000000 AND IF $FFFFFFFF00000000 OR THEN \ sign extend 10 | ; LOCAL 11 | 12 | : (see-call) ( addr xt -- addr' ) 13 | XT>NAME COUNT TYPE SPACE \ display name 14 | 4 + \ next adddress 15 | ; LOCAL 16 | 17 | : (see-lit) ( addr -- addr' ) 18 | 16 OVER @ HEX U0.R DECIMAL \ display callee address 19 | 8 + \ next adddress 20 | ; LOCAL 21 | 22 | : (see-string) ( addr -- addr' ) 23 | DUP COUNT 24 | [CHAR] " EMIT TYPE [CHAR] " EMIT \ display string 25 | COUNT + \ next adddress 26 | ; LOCAL 27 | 28 | : (see-absolute) ( addr -- addr' ) 29 | 5 - 8 - DUP @ (see-call) \ display name 30 | 4 + 5 + \ next address 31 | ; LOCAL 32 | 33 | : (see) ( addr -- addr' f ) 34 | 16 OVER HEX U0.R DECIMAL SPACE \ display address 35 | DUP C@ $E8 = IF 36 | 1+ \ move to next position 37 | DUP (fetch32) \ read next 4 bytes which are an offset 38 | OVER 4 + + \ calculate xt 39 | \ check xt against LIT and friends 40 | \ special case those 41 | ['] LIT OVER = IF DROP 4 + S" LIT " TYPE (see-lit) TRUE EXIT THEN 42 | ['] (0branch) OVER = IF (see-call) (see-lit) TRUE EXIT THEN 43 | ['] (branch) OVER = IF (see-call) (see-lit) TRUE EXIT THEN 44 | ['] (s") OVER = IF (see-call) (see-string) TRUE EXIT THEN 45 | ['] COMPILE, OVER = IF (see-call) (see-absolute) TRUE EXIT THEN 46 | \ otherwise print as a call 47 | (see-call) TRUE EXIT 48 | THEN 49 | DUP C@ $C2 = IF 50 | 1+ COUNT SWAP COUNT ROT + ABORT" unexpected $C2 operand" 51 | S" EXIT" TYPE TRUE EXIT 52 | THEN 53 | DUP C@ $C3 = IF S" ;" TYPE 1+ FALSE EXIT THEN 54 | FALSE 55 | ; LOCAL 56 | 57 | : SEE ( "name" -- ) 58 | BL WORD FIND 0= IF DROP EXIT THEN 59 | \ S" Address: " TYPE 8 OVER U0.R 60 | \ CELL+ DUP C@ $80 AND IF SPACE S" IMMEDIATE" TYPE THEN CR 61 | \ COUNT 2DUP TYPE + 62 | \ 256 dump 63 | BEGIN (see) CR WHILE REPEAT DROP 64 | ; 65 | 66 | local.end 67 | -------------------------------------------------------------------------------- /dijkstramap.fs: -------------------------------------------------------------------------------- 1 | \ let's define a map as uhhh 40x20 2 | CREATE map here 40 20 * dup allot blank 3 | 4 | : >map ( x y map -- addr ) swap 40 * + + ; 5 | : map@ ( x y map -- c ) >map c@ ; 6 | : map! ( c x y map -- ) >map c! ; 7 | 8 | : maprow{ ( u "data" -- ) 9 | 40 * map + '} word count >R swap R> cmove 10 | ; 11 | 12 | 0 maprow{ ########################################} 13 | 1 maprow{ # # # #} 14 | 2 maprow{ # # # X #} 15 | 3 maprow{ # # # #} 16 | 4 maprow{ # # # #} 17 | 5 maprow{ # # # #} 18 | 6 maprow{ # # #} 19 | 7 maprow{ ############### ########## ###} 20 | 8 maprow{ # #} 21 | 9 maprow{ # #} 22 | 10 maprow{ # #} 23 | 11 maprow{ ######### #} 24 | 12 maprow{ # #} 25 | 13 maprow{ # ######################} 26 | 14 maprow{ # #} 27 | 15 maprow{ # #} 28 | 16 maprow{ # #} 29 | 17 maprow{ ########## #} 30 | 18 maprow{ # #} 31 | 19 maprow{ ########################################} 32 | 33 | \ To get a Dijkstra map, you start with an integer array representing 34 | \ your map, with some set of goal cells set to zero and all the rest 35 | \ set to a very high number. 36 | 37 | \ Iterate through the map's "floor" cells -- skip the impassable wall 38 | \ cells. 39 | 40 | \ If any floor tile has a value greater than 1 regarding to its 41 | \ lowest-value floor neighbour (in a cardinal direction - i.e. up, 42 | \ down, left or right; a cell next to the one we are checking), set it 43 | \ to be exactly 1 greater than its lowest value neighbor. 44 | 45 | \ Repeat until no changes are made. 46 | 47 | \ The resulting grid of numbers represents the number of steps that it 48 | \ will take to get from any given tile to the nearest goal. 49 | 50 | \ djikstra map stuff 51 | CREATE dmap here 40 20 * dup allot blank 52 | CREATE dmap* here 40 20 * dup allot blank 53 | 54 | : >dijk ( c -- c' ) 55 | dup BL = if drop 120 exit then 56 | dup '# = if drop 127 exit then 57 | dup 'X = if drop 0 exit then 58 | ; 59 | 60 | : makedmap 61 | 20 0 do 62 | 40 0 do 63 | I J map map@ >dijk I J dmap map! 64 | loop 65 | loop 66 | ; 67 | 68 | : 3dup ( u1 u2 u3 -- u1 u2 u3 u1 u2 u3 ) >R 2DUP R@ -ROT R> ; 69 | : 3drop ( u1 u2 u3 -- ) drop 2drop ; 70 | 71 | local.start 72 | 73 | : upneigh ( x y addr -- c ) -rot 1- rot map@ ; LOCAL 74 | : downneigh ( x y addr -- c ) -rot 1+ rot map@ ; LOCAL 75 | : leftneigh ( x y addr -- c ) rot 1- -rot map@ ; LOCAL 76 | : rightneigh ( x y addr -- c ) rot 1+ -rot map@ ; LOCAL 77 | 78 | : dijk@ ( x y dmap -- u f ) 79 | \ we process only inside the border (caller responsibility)? 80 | 3dup map@ >R \ store this cell's weight 81 | R@ 127 = if 3drop R> FALSE exit then \ skip walls, keep value 82 | 3dup upneigh >R \ store neighbour weight 83 | 3dup downneigh >R \ store neighbour weight 84 | 3dup leftneigh >R \ store neighbour weight 85 | 3dup rightneigh >R \ store neighbour weight 86 | 3drop \ we're done with the coords/map 87 | R> R> R> R> min min min \ find lowest 88 | R> \ ( lowest current ) 89 | 2dup swap - 1 > if drop 1+ TRUE exit then \ cap higher at lowest+1 90 | nip FALSE \ otherwise keep current value 91 | ; 92 | 93 | : iterate ( -- f ) 94 | FALSE 95 | 20 0 do 96 | 40 0 do 97 | I J dmap dijk@ swap I J dmap* map! OR 98 | loop 99 | loop 100 | dmap* dmap 40 20 * cmove 101 | ; 102 | 103 | : .djik ( c -- ) 104 | dup 127 = if drop '# emit exit then 105 | BL + 126 min emit 106 | ; LOCAL 107 | 108 | : whole ( -- ) 109 | 0 0 at 110 | 20 0 do 111 | 40 0 do 112 | I J dmap map@ .djik 113 | loop cr 114 | loop 115 | ; 116 | 117 | \ include dijkstramap.fs 118 | \ makedmap 119 | \ : foo begin whole iterate while 100 ms repeat ; 120 | \ foo 121 | -------------------------------------------------------------------------------- /assembler.fs: -------------------------------------------------------------------------------- 1 | VARIABLE 2 | VARIABLE 3 | VARIABLE 4 | VARIABLE 5 | 6 | \ ADDRESSING ------------------------------------------ 7 | \ type is 0 for immediate, 1 for register 8 | : rax 1 0 ; : rcx 1 1 ; : rdx 1 2 ; : rbx 1 3 ; 9 | : rsp 1 4 ; : rbp 1 5 ; : rsi 1 6 ; : rdi 1 7 ; 10 | : r8 1 8 ; : r9 1 9 ; : r10 1 10 ; : r11 1 11 ; 11 | : r12 1 12 ; : r13 1 13 ; : r14 1 14 ; : r15 1 15 ; 12 | 13 | \ type 3 is register indirect 14 | : [rax] 3 0 ; : [rcx] 3 1 ; : [rdx] 3 2 ; : [rbx] 3 3 ; 15 | : [rsp] 3 4 ; : [rbp] 3 5 ; : [rsi] 3 6 ; : [rdi] 3 7 ; 16 | : [r8] 3 8 ; : [r9] 3 9 ; : [r10] 3 10 ; : [r11] 3 11 ; 17 | : [r12] 3 12 ; : [r13] 3 13 ; : [r14] 3 14 ; : [r15] 3 15 ; 18 | 19 | \ type 2 for memory 20 | : mem ( u -- 2 u ) 2 swap ; 21 | 22 | : rex.w c@ %01001000 or c! ; 23 | : rex.r c@ %01000100 or c! ; 24 | : rex.x c@ %01000010 or c! ; 25 | : rex.b c@ %01000001 or c! ; 26 | 27 | : ModR/M.mod! ( bb -- ) %11 and 6 LSHIFT c@ or c! ; 28 | : ModR/M.reg! ( bbb -- ) %111 and 3 LSHIFT c@ or c! ; 29 | : ModR/M.rm! ( bbb -- ) %111 and c@ or c! ; 30 | 31 | \ COMPILING WORDS ---------------------------------------- 32 | : rex, ( -- ) c@ dup if dup c, then drop ; 33 | : ModR/M, ( -- ) c@ c, ; 34 | : reset-assembler ( -- ) 0 ! 0 ! 0 ! 0 ! ; 35 | : assemble/1 ( -- ) rex, c@ c, ModR/M, reset-assembler ; 36 | 37 | : assemble/2 ( -- ) 38 | rex, c@ c, c@ c, \ compile 2-byte opcode 39 | ModR/M, reset-assembler 40 | ; 41 | 42 | : address32, ( addr32 -- ) 43 | dup c, 8 rshift dup c, 8 rshift dup c, 8 rshift c, 44 | ; 45 | 46 | : >ModR/M.rm ( u -- ) dup 7 > if rex.b then ModR/M.rm! ; 47 | : >ModR/M.reg ( u -- ) dup 7 > if rex.r then ModR/M.reg! ; 48 | 49 | \ INSTRUCTIONS ------------------------------------- 50 | : ret, $C3 c, ; immediate 51 | 52 | : inc, ( spec dst -- ) 53 | \ figure out rex.w prefix 54 | rex.w \ always 64-bit operand 55 | \ rearrange parameters 56 | swap 57 | \ validate operand 58 | dup 0= abort" operand cannot be immediate" 59 | \ register operand 60 | dup 1 = over 3 = or if 61 | \ figure out ModR/M 62 | 1 = if %11 ModR/M.mod! then \ 11 direct 63 | >ModR/M.rm 64 | \ assemble instruction 65 | $FF c! assemble/1 \ always opcode FF 01, 64-bit 66 | exit \ drop spec and finish 67 | then 68 | \ memory operand 69 | dup 2 = if 70 | drop 71 | \ figure out ModR/M (ModR/M $25 means index=RSP,base=RBP, so 0 72 | %00 ModR/M.mod! \ indirect 73 | %100 ModR/M.reg! \ RSP INDEX 74 | %101 ModR/M.rm! \ RBP BASE 75 | \ RSP cannot be used as index, RBP cannot be used as base, so in the end 76 | \ it means the disp32 follows the ModR/M byte 77 | 78 | \ for memory address, we have to encode it as 32-bit offset from 79 | \ an index... not sure how the index is specified 80 | \ anyway, the opcode is 'FF 04' in that case, followed 81 | \ by a ModR/M byte of $25, then the disp32 (from... 0?) follows 82 | 83 | \ assemble instruction 84 | \ always opcode FF 04, 64-bit 85 | $FF C! $04 C! assemble/2 86 | $FFFFFFFF and \ trim to 32 bits because science 87 | address32, \ write address32 88 | exit \ finish 89 | then 90 | true abort" invalid parameters" 91 | ; immediate 92 | 93 | : add, ( type src type dst -- ) 94 | \ figure out rex.w prefix 95 | rex.w \ always 64-bit operands 96 | $01 C! \ $01 unless the src is indirect 97 | \ rearrange parameters ( srcspec src dstspec dst ) 98 | 2swap swap -rot swap 2swap swap ( src dst srcspec dstspec ) 99 | \ validate operands 100 | dup 0= abort" destination cannot be immediate" 101 | dup 2 = abort" cannot encode dst address yet" 102 | over 0= abort" source cannot be immediate yet" 103 | over 2 = abort" cannot encode src address yet" 104 | dup 1 = if \ dst is direct 105 | drop \ drop dstspec ( src dst srcspec ) 106 | dup 1 = if %11 ModR/M.mod! then \ src is direct 107 | 3 = if swap $03 c! then \ src is indirect, swap src/dst 108 | >ModR/M.rm >ModR/M.reg assemble/1 109 | exit 110 | then 111 | dup 3 = if \ dst is indirect 112 | drop \ drop dstspec 113 | 3 = abort" two indirect operands" 114 | >ModR/M.rm >ModR/M.reg assemble/1 115 | exit 116 | then 117 | true abort" wat" 118 | ; immediate 119 | 120 | : sub, ( type src type dst -- ) 121 | \ figure out rex.w prefix 122 | rex.w \ always 64-bit operands 123 | $29 C! \ $01 unless the src is indirect 124 | \ rearrange parameters ( srcspec src dstspec dst ) 125 | 2swap swap -rot swap 2swap swap ( src dst srcspec dstspec ) 126 | \ validate operands 127 | dup 0= abort" destination cannot be immediate" 128 | dup 2 = abort" cannot encode dst address yet" 129 | over 0= abort" source cannot be immediate yet" 130 | over 2 = abort" cannot encode src address yet" 131 | dup 1 = if \ dst is direct 132 | drop \ drop dstspec ( src dst srcspec ) 133 | dup 1 = if %11 ModR/M.mod! then \ src is direct 134 | 3 = if swap $2B c! then \ src is indirect, swap src/dst 135 | >ModR/M.rm >ModR/M.reg assemble/1 136 | exit 137 | then 138 | dup 3 = if \ dst is indirect 139 | drop \ drop dstspec 140 | 3 = abort" two indirect operands" 141 | >ModR/M.rm >ModR/M.reg assemble/1 142 | exit 143 | then 144 | true abort" wat" 145 | ; immediate 146 | 147 | : mov, ( type src type dst -- ) 148 | \ figure out rex.w prefix 149 | rex.w \ always 64-bit operands 150 | $89 C! \ $89 unless the src is indirect 151 | \ rearrange parameters ( srcspec src dstspec dst ) 152 | 2swap swap -rot swap 2swap swap ( src dst srcspec dstspec ) 153 | \ validate operands 154 | dup 0= abort" destination cannot be immediate" 155 | over 0= abort" source cannot be immediate yet" 156 | dup 1 = if \ dst is direct 157 | drop \ drop dstspec ( src dst srcspec ) 158 | dup 2 = if \ src is memory 159 | drop ( swap ) 160 | $8B c! \ src is indirect, swap src/dst 161 | 4 >ModR/M.rm >ModR/M.reg 162 | assemble/1 163 | $25 c, \ SIB byte pointing to next addr 164 | $FFFFFFFF and \ trim to 32 bits because science 165 | address32, \ write address32 166 | exit 167 | then 168 | dup 1 = if %11 ModR/M.mod! then \ src is direct 169 | dup 3 = if 170 | -rot swap rot $8B c! \ src is indirect, swap src/dst 171 | then 172 | drop 173 | >ModR/M.rm >ModR/M.reg assemble/1 174 | exit 175 | then 176 | dup 2 = if \ dst is address 177 | drop \ drop dstspec ( src dst srcspec ) 178 | dup 2 = abort" two operands are memory" 179 | dup 3 = abort" can't encode indirect source and memory" 180 | dup 1 = if 181 | drop 182 | swap \ src is indirect, swap src/dst 183 | 4 >ModR/M.rm >ModR/M.reg assemble/1 184 | $25 c, \ SIB byte pointing to next addr 185 | $FFFFFFFF and \ trim to 32 bits because science 186 | address32, \ write address32 187 | exit 188 | then 189 | then 190 | dup 3 = if \ dst is indirect 191 | drop \ drop dstspec 192 | dup 2 = abort" can't encode indirect destination and memory" 193 | dup 3 = abort" two indirect operands" 194 | drop 195 | >ModR/M.rm >ModR/M.reg assemble/1 196 | exit 197 | then 198 | true abort" wat" 199 | ; immediate 200 | 201 | \ - populate assembler variables based on operands and operand specs 202 | \ - return a flag indicating whether to compile a SIB byte and disp32 203 | \ - return a flag indicating whether to switch to alternative opcode 204 | \ this is not a perfect system but for now we're only using 2 opcodes 205 | \ per instruction 206 | 207 | \ dd $89 208 | \ di $8B 209 | \ dm $8B 210 | \ md $89 211 | \ mi not available 212 | \ mm not available 213 | \ id $89 214 | \ ii not available 215 | \ im not available 216 | 217 | 218 | : encodeoperands ( type src type dst -- disp-f altopcode-f ) 219 | \ figure out rex.w prefix 220 | rex.w \ always 64-bit operands 221 | \ rearrange parameters ( srcspec src dstspec dst ) 222 | 2swap swap -rot swap 2swap swap ( src dst srcspec dstspec ) 223 | \ validate operands 224 | dup 0= abort" destination cannot be immediate" 225 | over 0= abort" source cannot be immediate yet" 226 | dup 1 = if \ dst is direct 227 | drop \ drop dstspec ( src dst srcspec ) 228 | dup 1 = if 229 | drop 230 | %11 ModR/M.mod! >ModR/M.rm >ModR/M.reg 231 | FALSE FALSE exit 232 | then \ src is direct 233 | dup 2 = if \ src is memory 234 | drop 235 | 4 >ModR/M.rm >ModR/M.reg 236 | TRUE TRUE exit 237 | then 238 | dup 3 = if 239 | drop swap >ModR/M.rm >ModR/M.reg 240 | FALSE TRUE exit 241 | then 242 | true abort" direct dst, invalid src type" 243 | then 244 | dup 2 = if \ dst is address 245 | drop \ drop dstspec ( src dst srcspec ) 246 | dup 2 = abort" two operands are memory" 247 | dup 3 = abort" can't encode indirect source and memory" 248 | dup 1 = if 249 | drop 250 | swap \ src is indirect, swap src/dst 251 | 4 >ModR/M.rm >ModR/M.reg 252 | TRUE FALSE exit 253 | then 254 | true abort" memory dst, invalid src type" 255 | then 256 | dup 3 = if \ dst is indirect 257 | drop \ drop dstspec 258 | dup 2 = abort" can't encode indirect destination and memory" 259 | dup 3 = abort" two indirect operands" 260 | dup 1 = if 261 | drop 262 | >ModR/M.rm >ModR/M.reg 263 | FALSE FALSE exit 264 | then 265 | true abort" indirect dst, invalid src type" 266 | then 267 | true abort" wat" 268 | ; 269 | 270 | : newmov, ( spec src spec dst -- ) 271 | $89 ! 272 | encodeoperands if $8B ! then 273 | assemble/1 274 | if 275 | $25 c, \ SIB byte pointing to next addr 276 | $FFFFFFFF and \ trim to 32 bits because science 277 | address32, \ write address32 278 | then 279 | ; immediate 280 | 281 | 282 | variable timmy 283 | 284 | : one+ ( n -- n+1 ) [ r15 ] inc, ; 285 | : dupe ( n -- n+n ) [ r15 r15 ] add, ; 286 | : makeone ( n -- n+1-n ) [ r15 r8 ] mov, [ r15 ] inc, [ r8 r15 ] sub, ; 287 | 288 | : oneup ( -- ) [ timmy mem ] inc, ; 289 | : addrup [ [r15] ] inc, ; 290 | -------------------------------------------------------------------------------- /boot.fs: -------------------------------------------------------------------------------- 1 | #! /home/raydj/forth/rayforth/rayforth-launcher 2 | 3 | CREATE builtins----> 4 | 5 | : INCLUDE ( "filename" -- ) BL WORD COUNT INCLUDED ; 6 | 7 | : EXIT $C2 C, 0 C, 0 C, ; IMMEDIATE 8 | 9 | : HEX 16 BASE ! ; 10 | : DECIMAL 10 BASE ! ; 11 | : BINARY 2 BASE ! ; 12 | 13 | : CELL+ ( addr -- addr' ) 8 + ; 14 | : CELLS ( n -- n*cellsize ) 8 * ; 15 | 16 | : >FLAGS CELL+ ; 17 | : >NAME >FLAGS 1+ ; 18 | : >CODE >NAME COUNT + ; 19 | 20 | : RECURSE ['] (branch) COMPILE, LATEST @ >CODE , ; IMMEDIATE 21 | 22 | : DODOES R> R> SWAP >R ; 23 | : (DOES>) R> LATEST @ >CODE COMPILE@ ; 24 | : DOES> ['] (DOES>) COMPILE, ['] DODOES COMPILE, ; IMMEDIATE 25 | 26 | 0 , ( sigh... ) 27 | 28 | : IF ['] (0branch) COMPILE, HERE 0 , ; IMMEDIATE 29 | : ELSE ['] (branch) COMPILE, HERE 0 , HERE ROT ! ; IMMEDIATE 30 | : THEN HERE SWAP ! ; IMMEDIATE 31 | : ?IF ['] ?DUP COMPILE, ['] (0branch) COMPILE, HERE 0 , ; IMMEDIATE 32 | 33 | : CONSTANT CREATE , DOES> @ ; 34 | : VARIABLE CREATE 0 , ; 35 | 36 | \ for some reason alignment seems to matter... this should help 37 | : aligned ( u-addr -- a-addr ) 4 rshift 4 lshift 16 + ; 38 | : align ( -- ) here aligned dp ! ; 39 | 40 | : 2@ ( addr -- u1 u2 ) dup cell+ @ swap @ ; 41 | : 2! ( u1 u2 addr -- ) tuck ! cell+ ! ; 42 | 43 | : 2CONSTANT CREATE , , DOES> 2@ ; 44 | : 2VARIABLE CREATE 0 , 0 , ; 45 | 46 | : WITHIN ( u/n lo hi -- f ) OVER - >R - R> U< ; 47 | 48 | : DO ['] (do) COMPILE, HERE ; IMMEDIATE 49 | : LOOP 50 | ['] (loop) COMPILE, 51 | ['] (0branch) COMPILE, , 52 | ['] (enddo) COMPILE, 53 | ; IMMEDIATE 54 | : +LOOP 55 | ['] (+loop) COMPILE, 56 | ['] (0branch) COMPILE, , 57 | ['] (enddo) COMPILE, 58 | ; IMMEDIATE 59 | : UNLOOP ['] (enddo) COMPILE, ; IMMEDIATE 60 | : LEAVE ( not sure how to go about this right now...) ; 61 | 62 | : BEGIN HERE ; IMMEDIATE 63 | : UNTIL ['] (0branch) COMPILE, , ; IMMEDIATE 64 | : AGAIN ['] (branch) COMPILE, , ; IMMEDIATE 65 | : WHILE ['] (0branch) COMPILE, HERE 0 , ; IMMEDIATE 66 | : ?WHILE ['] ?DUP COMPILE, ['] (0branch) COMPILE, HERE 0 , ; IMMEDIATE 67 | : REPEAT SWAP ['] (branch) COMPILE, , HERE SWAP ! ; IMMEDIATE 68 | 69 | \ the following logic is prone to false positives, but only if the 70 | \ word name exceeds 32 characters, at which point you have a naming 71 | \ problem, which is way worse 72 | : XT>NAME ( addr -- addr' ) 73 | DUP >R BEGIN \ addr' | addr0 74 | 1- \ addr'-1 | addr0 75 | DUP C@ 1+ \ addr'-1 len?+1 | addr0 76 | OVER + R@ = \ addr'-1 found? | addr0 77 | UNTIL 78 | R> DROP \ addr' 79 | ; 80 | 81 | : XT>LINK ( addr -- addr' ) XT>NAME 1 CELLS - 1- ; 82 | 83 | INCLUDE localwords.fs 84 | 85 | : WORDS 86 | LATEST @ 87 | BEGIN 88 | DUP >NAME 89 | COUNT TYPE BL EMIT 90 | @ DUP 0= 91 | UNTIL 92 | DROP 93 | ; 94 | 95 | : LITERAL ( x -- ) ['] LIT COMPILE, , ; IMMEDIATE 96 | 97 | : CHAR BL WORD 1 + C@ ; 98 | : [CHAR] BL WORD 1 + C@ POSTPONE LITERAL ; IMMEDIATE 99 | 100 | \ some VT100 stuff 101 | : 27 EMIT ; 102 | : [CHAR] [ EMIT ; 103 | 104 | : PAGE [CHAR] H EMIT 105 | [CHAR] 2 EMIT [CHAR] J EMIT ; 106 | 107 | : UNDER+ ( a b c -- a+c b ) ROT + SWAP ; 108 | : SPACE ( -- ) BL EMIT ; 109 | : SPACES ( n -- ) DUP 0 > IF 0 DO BL EMIT LOOP EXIT THEN DROP ; 110 | : ZEROS ( n -- ) DUP 0 > IF 0 DO '0 EMIT LOOP EXIT THEN DROP ; 111 | 112 | CREATE 256 ALLOT LOCAL 113 | VARIABLE # LOCAL 114 | VARIABLE sign? LOCAL 115 | 116 | : <# ( u/n -- u ) 256 ERASE 256 # ! dup 0 < sign? ! abs ; 117 | : # ( u1 -- u2 ) 118 | -1 # +! 119 | 0 BASE @ UM/MOD SWAP BASEDIGITS + c@ # @ + C! 120 | ; 121 | : #S ( u1 -- 0 ) BEGIN # DUP WHILE REPEAT ; 122 | : #> ( u -- c-addr u ) DROP # @ + 256 # @ - ; 123 | : HOLD ( c -- ) # @ + C! -1 # +! ; 124 | : SIGN ( u -- u ) sign? @ 0 < IF '- HOLD THEN ; 125 | 126 | : U.R ( rlen u -- ) 127 | TUCK BEGIN -1 UNDER+ BASE @ / DUP WHILE REPEAT DROP SPACES .. 128 | ; 129 | 130 | : U0.R ( rlen u -- ) 131 | TUCK BEGIN -1 UNDER+ BASE @ / DUP WHILE REPEAT DROP ZEROS .. 132 | ; 133 | 134 | : AT ( x y -- ) 135 | 1+ .. [CHAR] ; EMIT 1+ .. [CHAR] H EMIT 136 | ; 137 | 138 | : ATTR: ( "name" n -- ) 139 | CREATE , DOES> @ EMIT [CHAR] m EMIT 140 | ; 141 | 142 | CHAR 1 ATTR: 143 | CHAR 2 ATTR: 144 | CHAR 4 ATTR: 145 | CHAR 5 ATTR: 146 | CHAR 7 ATTR: 147 | CHAR 8 ATTR: 148 | 149 | 0 CONSTANT BLACK 150 | 1 CONSTANT RED 151 | 2 CONSTANT GREEN 152 | 3 CONSTANT YELLOW 153 | 4 CONSTANT BLUE 154 | 5 CONSTANT MAGENTA 155 | 6 CONSTANT CYAN 156 | 7 CONSTANT WHITE 157 | 9 CONSTANT NOCOLOR 158 | 159 | : FG ( n -- ) 3 .. .. [CHAR] m EMIT ; 160 | : BG ( n -- ) 4 .. .. [CHAR] m EMIT ; 161 | 162 | : (ior) ( n -- ior ) 0 < ; LOCAL 163 | 164 | : READ-FILE ( c-addr u1 fid -- u2 ior ) 165 | ROT SWAP 0 SYSCALL/3 DUP (ior) 166 | ; 167 | 168 | : WRITE-FILE ( c-addr u1 fid -- u2 ior ) 169 | ROT SWAP 1 SYSCALL/3 DUP (ior) 170 | ; 171 | 172 | : WRITE-LINE ( c-addr u1 fid -- u2 ior ) 173 | dup >R ROT SWAP 1 SYSCALL/3 DUP (ior) 174 | 10 1 PSP 1 cells + R> 1 SYSCALL/3 DUP (ior) 175 | ; 176 | 177 | : FILE-POSITION ( fid -- u ior ) 178 | 1 0 ROT 8 SYSCALL/3 DUP (ior) 179 | ; 180 | 181 | : FILE-SIZE ( fid -- u ior ) 182 | DUP DUP FILE-POSITION DROP 183 | ROT 2 0 ROT 8 SYSCALL/3 >R 184 | ROT 8 SYSCALL/3 DROP 185 | DROP R> DUP (ior) 186 | ; 187 | 188 | : REPOSITION-FILE ( u fid -- ior ) 189 | 0 ( <-SEEK_SET ) -rot 8 SYSCALL/3 (ior) 190 | ; 191 | 192 | \ only one buffer for now 193 | local.start 194 | CREATE 256 ALLOT LOCAL 195 | 196 | : ( "string" -- addr n ) 197 | [CHAR] " WORD 198 | COUNT TUCK C! 199 | SWAP 1 + SWAP CMOVE 200 | COUNT 201 | ; 202 | local.end 203 | 204 | : (S") ( R: addr -- addr u | R: addr> ) R> COUNT 2DUP + >R ; 205 | 206 | : S" ( "string" -- addr n ) 207 | STATE @ 0= IF EXIT THEN 208 | ['] (S") COMPILE, [CHAR] " WORD 209 | COUNT + DP ! 210 | ; IMMEDIATE 211 | 212 | : ." ( "name" -- ) POSTPONE S" ['] TYPE COMPILE, ; IMMEDIATE 213 | : .( ( "name" -- ) ') WORD COUNT TYPE ; 214 | 215 | : (abort") ( u -- ) 216 | IF S" ¯\_(ツ)_/¯ <{ " TYPE TYPE S" }" TYPE CR ABORT THEN 217 | 2DROP 218 | ; LOCAL 219 | 220 | : ABORT" ( "msg" -- ) 221 | ['] (S") COMPILE, [CHAR] " WORD 222 | COUNT + DP ! 223 | ['] ROT COMPILE, 224 | ['] (abort") COMPILE, 225 | ; IMMEDIATE 226 | 227 | \ reads the newline too... :-/ 228 | : ACCEPT ( c-addr +n1 -- +n2 ) 0 read-file abort" ACCEPT error" 1- ; 229 | 230 | 231 | \ format is: 232 | \ TIBDATA len >IN @ 0 4 for stdin 233 | \ addr len >IN @ fid 4 for files 234 | 235 | : SAVE-INPUT ( -- xn..x1 n ) 236 | \ both stdin and file have the same number and kind of args 237 | SOURCE >IN @ SOURCE-ID @ 4 238 | ; 239 | 240 | : RESTORE-INPUT ( nx..x1 n -- f ) 241 | \ both stdin and file have the same number and kind of args 242 | DROP 243 | SOURCE-ID ! >IN ! ! ! 244 | TRUE 245 | ; 246 | 247 | : (dump) ( addr -- ) 248 | HEX 249 | 8 OVER U0.R SPACE DUP 16 + SWAP DO 2 I C@ U0.R SPACE LOOP 250 | DECIMAL CR 251 | ; LOCAL 252 | : DUMP ( addr n -- ) OVER + SWAP DO I (dump) 16 +LOOP ; 253 | 254 | INCLUDE see.fs 255 | 256 | : args ( -- args-addr ) rp0@ 3 cells + ; 257 | : nargs ( -- n ) rp0@ 2 cells + @ ; 258 | : ctype ( cstr -- ) begin count dup while emit repeat 2drop ; 259 | : ?args ( -- ) 260 | nargs dup . 261 | args swap 0 do 262 | dup @ ctype space cell+ 263 | loop drop 264 | ; 265 | 266 | : forget ( "name" -- ) 267 | bl word find 0= abort" word not found" 268 | xt>name 1 cells - dup dp ! @ latest ! 269 | ; 270 | 271 | : VALUE CREATE , DOES> @ ; 272 | 273 | : ( "string" u -- ) 274 | BL WORD FIND 0= ABORT" value not found" 275 | \ maybe should test if it's a value 276 | \ on the other hand, read what you write...? 277 | 5 + ! \ skip code, store in data 278 | ; LOCAL 279 | 280 | : (TO) ( u | R: addr -- R: addr> ) 281 | R> DUP CELL+ >R @ ! 282 | ; LOCAL 283 | 284 | : TO ( "name" u -- ) 285 | STATE @ 0= IF EXIT THEN 286 | ['] (TO) COMPILE, 287 | BL WORD FIND 0= ABORT" value not found" 288 | 5 + , 289 | ; IMMEDIATE 290 | 291 | : <+TO> ( "string" u -- ) 292 | BL WORD FIND 0= ABORT" value not found" 293 | 5 + DUP @ UNDER+ ! \ skip code, store in data 294 | ; LOCAL 295 | 296 | : (+TO) ( u | R: addr -- R: addr> ) 297 | R> DUP CELL+ >R @ DUP @ UNDER+ ! 298 | ; LOCAL 299 | 300 | : +TO ( "name" u -- ) 301 | STATE @ 0= IF <+TO> EXIT THEN 302 | ['] (+TO) COMPILE, 303 | BL WORD FIND 0= ABORT" value not found" 304 | 5 + , 305 | ; IMMEDIATE 306 | 307 | : DEFER ( "name" -- ) 308 | CREATE 0 , \ maybe a default deferred instead? 309 | DOES> @ EXECUTE 310 | ; 311 | 312 | \ BLOCKS code -------------------------------------------------- 313 | variable BLK 314 | variable SCR 315 | variable cbuf LOCAL 316 | 317 | variable LOCAL 318 | 319 | : USE ( "name" -- ) 320 | @ ?dup if close-file abort" error closing blocks file" then 321 | 0 ! 322 | BL WORD COUNT r/w open-file abort" error opening blocks file" 323 | ! 324 | ; 325 | 326 | \ block -1 is not valid in a mapping, it means "no block" (yes?) 327 | create LOCAL 64 CELLS allot 328 | create LOCAL 64 1024 * allot 329 | 64 cells -1 fill 330 | 331 | \ bitvector to keep track of updated buffers 332 | variable LOCAL 333 | : BIT ( u -- mask ) 1 swap lshift ; 334 | : CLEAR ( mask addr -- ) tuck @ xor swap ! ; 335 | : SET ( mask addr -- ) tuck @ or swap ! ; 336 | : TEST ( mask addr -- f ) tuck @ and 0<> ; 337 | 338 | : buf>map ( baddr -- maddr ) - 128 / + ; LOCAL 339 | : map>buf ( baddr -- maddr ) - 128 * + ; LOCAL 340 | : map>bit ( maddr -- ubit ) - 8 / BIT ; LOCAL 341 | : map>blk ( maddr -- blk# ) @ ; LOCAL 342 | : range ( -- limit base ) dup 64 cells under+ ; LOCAL 343 | : updated? ( maddr -- f ) map>bit @ AND 0<> ; LOCAL 344 | 345 | : read ( u baddr -- ) 346 | swap 1024 * @ reposition-file abort" error seeking blocks file" 347 | 1024 @ READ-FILE ABORT" error reading blocks file" 348 | drop 349 | ; LOCAL 350 | 351 | : write ( maddr -- ) 352 | dup map>blk 1024 * @ reposition-file abort" error seeking blocks file" 353 | map>buf 1024 @ write-file abort" error writing blocks file" 354 | drop 355 | ; LOCAL 356 | 357 | : mapping ( u -- maddr/false ) 358 | range DO 359 | DUP I @ = IF drop I UNLOOP EXIT THEN 360 | 1 CELLS +LOOP 361 | drop FALSE 362 | ; LOCAL 363 | 364 | : map ( u maddr -- ) ! ; LOCAL 365 | 366 | : unmap ( maddr -- ) 367 | dup updated? IF dup write THEN 368 | dup map>bit clear 369 | -1 swap ! 370 | ; LOCAL 371 | 372 | : BLOCK ( u -- baddr ) 373 | DUP mapping ?DUP IF nip map>buf dup cbuf ! exit then 374 | -1 mapping ?DUP IF 2dup map map>buf tuck read dup cbuf ! exit then 375 | \ unmap... but which block? always the first one? 376 | \ use some LRU strategy where mapping positions swap on access? 377 | dup unmap 2dup map map>buf tuck read dup cbuf ! 378 | ; 379 | 380 | : BUFFER ( u -- addr ) 381 | DUP mapping ?DUP IF nip map>buf dup cbuf ! exit then 382 | -1 mapping ?DUP IF tuck map map>buf dup cbuf ! exit then 383 | dup unmap tuck map map>buf dup cbuf ! 384 | ; 385 | 386 | : EMPTY-BUFFERS ( -- ) 64 CELLS erase ; 387 | 388 | : SAVE-BUFFERS ( -- ) 389 | range do I updated? if I write then 1 cells +loop 0 ! 390 | ; 391 | 392 | : FLUSH ( -- ) save-buffers 64 cells erase ; 393 | 394 | \ can be factored better, maybe... not right now :-) 395 | \ block 0 cannot be LOADed, because BLK would be set to 0, 396 | \ which makes the terminal the input source, 397 | \ however it can be BLOCKed, LISTed, etc 398 | : LOAD ( i*x u -- j*x ) 399 | dup 0= if true abort" Cannot LOAD block 0" then 400 | >R save-input R> 401 | dup block ! blk ! 402 | 1024 ! 403 | 0 >in ! 404 | interpret 405 | restore-input 0 blk ! 0= abort" restore-input failed" 406 | ; 407 | 408 | : THRU ( i * x u1 u2 -- j * x ) 1+ swap DO I load LOOP ; 409 | 410 | : UPDATE ( -- ) 411 | cbuf @ buf>map map>bit @ OR ! 412 | ; 413 | 414 | : LIST ( u -- ) 415 | dup SCR ! 416 | block 16 0 DO I 64 * OVER + 64 type cr loop 417 | drop 418 | ; 419 | 420 | \ extend backslash, REFILL, and EVALUATE (which we don't have yet) 421 | : \ ( "some text" -- ) 422 | BLK @ IF 423 | >in @ 6 rshift 6 lshift 64 + >in ! exit 424 | THEN 425 | postpone \ 426 | ; IMMEDIATE 427 | \ BLOCKS code end ---------------------------------------------- 428 | 429 | include string.fs 430 | 431 | CREATE needle 32 allot LOCAL 432 | CREATE haystack 32 allot LOCAL 433 | 434 | : WORDS.LIKE ( "name" -- ) 435 | BL WORD COUNT needle c! needle COUNT CMOVE 436 | needle COUNT upcase! 437 | 438 | LATEST @ BEGIN ( linkaddr ) 439 | DUP >NAME COUNT haystack c! haystack COUNT CMOVE 440 | haystack COUNT upcase! 441 | haystack COUNT needle COUNT SEARCH -ROT 2DROP 442 | IF DUP >NAME COUNT type space THEN 443 | @ DUP 0= 444 | UNTIL 445 | ; 446 | 447 | \ fork and exec things 448 | : fork ( -- f ) $39 syscall/0 ; 449 | 450 | CREATE LOCAL here 1024 dup allot erase 451 | CREATE LOCAL here 16 cells dup allot erase 452 | VARIABLE LOCAL 453 | 0 CONSTANT NULLENV LOCAL 454 | 455 | : add-arg ( c-addr u addr -- addr' ) 456 | dup @ cells + ! \ set up the pointer in args* 457 | 2dup 2>R \ save address and count 458 | swap cmove \ copy to 459 | 2R> + \ restore and move past 460 | 0 over c! 1+ \ store 0 and move past 461 | 0 over c! \ store another 0, end of array 462 | 1 +! \ increment arg count 463 | ; LOCAL 464 | 465 | : exec ( c-addrn un ... c-addr1 u1 argc c-addr u -- n ) 466 | 0 ! 16 cells erase 467 | add-arg \ first arg is the pathname 468 | swap ?dup if 469 | 0 do add-arg loop \ copy args 470 | then drop 471 | NULLENV $3B syscall/3 472 | ; 473 | 474 | : (system) ( c-addrn un ... c-addr1 u1 argc c-addr u -- ) 475 | fork dup 0 < abort" error forking" if 476 | ( wait for child ) 477 | 2drop exit 478 | then 479 | exec ." error executing" bye \ execute in forked process 480 | ; 481 | 482 | : system ( c-addrn un ... c-addr1 u1 argc "pathname" -- ) 483 | BL WORD COUNT (system) 484 | ; 485 | 486 | \ --- thoughts on non-buffered KEY and such ------------- 487 | \ use stty -icanon -echo before starting 488 | \ use stty icanon echo after exiting 489 | \ echoing will be disabled, but so will be buffering 490 | \ not disabling echo causes double characters and oddness 491 | \ anyway we need a way to see what's being typed 492 | \ key will still be blocking but not buffered anymore 493 | \ ------------------------------------------------------- 494 | 495 | : buffered ( -- ) 496 | s" icanon" s" echo" 2 s" /bin/stty" (system) drop 2drop 2drop 497 | ; 498 | 499 | : unbuffered ( -- ) 500 | s" -icanon" s" -echo" 2 s" /bin/stty" (system) drop 2drop 2drop 501 | ; 502 | 503 | \ key? 504 | CREATE pollfd 505 | 0 c, 0 c, 0 c, 0 c, \ fd 506 | 1 c, 0 c, \ events 507 | 0 c, 0 c, \ revents 508 | 509 | : poll ( timeout nfds fds* -- u ) 510 | $07 syscall/3 dup -1 = abort" poll error" 511 | ; 512 | 513 | : key? ( -- f ) 0 1 pollfd poll ; 514 | 515 | 516 | \ PRNG stuff ( https://prng.di.unimi.it/ ) 517 | 2variable xoshiro128+state $DEADBEEF xoshiro128+state ! 518 | 519 | : rotl ( x k -- u ) 2dup lshift -rot 64 swap - rshift or ; 520 | 521 | : xoshiro128+ ( -- u ) 522 | xoshiro128+state 2@ 2dup + -rot \ result 523 | xor 524 | xoshiro128+state @ 24 rotl over xor over 16 lshift xor 525 | swap 37 rotl swap xoshiro128+state 2! 526 | ; 527 | 528 | 529 | \ almost ready to boot 530 | 531 | \ Process all local words defined either in assembly or boot.fs. The 532 | \ very first word defined is TRUE, so we take that address as the 533 | \ start of local area. 534 | ' TRUE XT>LINK local.end 535 | 536 | : HELLO 537 | S" boot.fs loaded" TYPE CR 538 | UNUSED . S" bytes available" TYPE CR 539 | ; 540 | 541 | HELLO 542 | -------------------------------------------------------------------------------- /main.asm: -------------------------------------------------------------------------------- 1 | ;; this is a forth written in assembly... or at least it tries to be 2 | ;; (C) 2022 Sergi Reyner 3 | ;; MIT License 4 | 5 | bits 64 6 | 7 | ;; design goals: 8 | ;; ------------- 9 | 10 | ;; designed to run under Linux x64 11 | ;; the native cell size is 64-bit 12 | ;; must be able to interpret most words 13 | ;; must produce reasonably fast code 14 | ;; must be implemented in an easy to understand way 15 | ;; will attempt to follow the Forth2012 Standard (latest at the time of implementation) 16 | ;; should... provide a C interface 17 | 18 | 19 | ;; The Forth 2012 Standard is considered a suggestion/guideline 20 | 21 | ;; most of the core words can be implemented as macros (immediate 22 | ;; words) that compile small snippets of machine code, somewhat 23 | ;; similar to machineforth 24 | 25 | ;; should make a decision on whether to have dual sets of words 26 | ;; (DUP/DUP,) for interpretation/regular compiling vs inlining 27 | 28 | ;; once file access is implemented, determine what should be a 29 | ;; primitive and what should be a high level definition, then move the 30 | ;; high level code to boot.fs 31 | 32 | ;; things that are used frequently or interface with the OS: 33 | ;; -------------------------------- 34 | ;; math words 35 | ;; stack words 36 | ;; syscalls 37 | 38 | 39 | ;; writing "fast" code in Forth is possible given a basic set of words 40 | ;; capable of assembling code 41 | 42 | 43 | ;; Register Allocation 44 | 45 | ;; The System V ABI has just enough registers that we can avoid using 46 | ;; rax-rdx, which are the means to pass parameters to linux syscalls 47 | 48 | ;; All registers are equally capable (for the most part...) 49 | 50 | ;; Since this is an STC Forth, the IP register is also the IP register 51 | ;; of the machine, namely rip 52 | 53 | ;; The parameter stack pointer will reside on rbp, which is the stack 54 | ;; frame pointer and not really relevant as long as we stay on the 55 | ;; Forth and assembly side of code 56 | 57 | ;; rsi and rdi are used as source and destination pointers for a few 58 | ;; instructions 59 | 60 | ;; r8 r9 r10 r11 are scratch registers 61 | ;; r12 r13 r14 r15 are preserved between calls 62 | 63 | ;; rcx and r11 are destroyed by syscalls 64 | ;; should change Y to r8 and rewrite? 65 | 66 | ;; There's not really a need to respect the System V ABI, but in the 67 | ;; future we may want to interface with C code. Since there's not 68 | ;; really a cost to this future-proofing, because we have enough 69 | ;; preserved registers, I ended up with the following allocation, 70 | ;; assigned following the recommendations from Moving Forth: 71 | 72 | ;; %define IP rip 73 | ;; %define RSP rsp 74 | %define PSP rbp 75 | %define TOS r15 76 | %define W r12 77 | %define X r13 78 | %define Y r11 ; it's going to be a scratch register anyway 79 | %define UP r14 80 | 81 | ;; Possibly useful for compiling literals? 82 | ;; x64 provides a new rip-relative addressing mode. Instructions that 83 | ;; refer to a single constant address are encoded as offsets from 84 | ;; rip. For example, the mov rax, [addr] instruction moves 8 bytes 85 | ;; beginning at addr + rip to rax. 86 | 87 | ;; Constants 88 | CELLSIZE equ 8 89 | STACKSIZE equ 64 90 | BUFFERSIZE equ 4096 91 | TRUE equ -1 92 | FALSE equ 0 93 | MMAP_FLAGS equ 0x22 ; MAP_ANONYMOUS|MAP_PRIVATE 94 | MMAP_PROTECTION equ 0x7 ; RWE 95 | BLOCK_MMAP_FLAGS equ 0x22 ; MAP_SHARED|MAP_SYNC 96 | BLOCK_MMAP_PROTECTION equ 0x3 ; RW? 97 | 98 | ;; static data stuff 99 | SECTION .data 100 | ; align 4 101 | BASEDIGITS db "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 102 | 103 | helloStr db "RayForth v0", 10 104 | helloLen equ $-helloStr 105 | 106 | notFoundMsgStr db " not found" 107 | notFoundMsgLen equ $-notFoundMsgStr 108 | 109 | promptStr db " ok", 10 110 | promptLen equ $-promptStr 111 | 112 | bootfsStr db "boot.fs" 113 | bootfsLen equ $-bootfsStr 114 | 115 | timeval: 116 | tv_sec dq 0 117 | tv_usec dq 0 118 | 119 | ;; here's where these things go, apparently 120 | SECTION .bss 121 | ; align 4 122 | 123 | ;; Parameter stack 124 | DATASTACK resb CELLSIZE*STACKSIZE 125 | DATASTACKBOTTOM equ $ 126 | 127 | ;; Return Stack 128 | RETURNSTACKBOTTOM resb 8 129 | 130 | ;; Parameter Stack Macros 131 | 132 | %define NOS [PSP] 133 | 134 | %define NIP add PSP, CELLSIZE 135 | 136 | %macro DROP 0 137 | mov TOS, NOS 138 | NIP 139 | %endmacro 140 | 141 | %macro DUP 0 142 | sub PSP, CELLSIZE 143 | mov qword NOS, TOS 144 | %endmacro 145 | 146 | %macro DPUSH 1 147 | DUP 148 | mov TOS, qword %1 149 | %endmacro 150 | 151 | %macro DPOP 1 152 | mov qword %1, TOS 153 | mov TOS, NOS 154 | NIP 155 | %endmacro 156 | 157 | %macro CLR 1 158 | xor %1, %1 159 | %endmacro 160 | 161 | %macro SWAP 0-1 r8 162 | mov %1, TOS 163 | mov TOS, NOS 164 | mov NOS, %1 165 | %endmacro 166 | 167 | ;; Other memory zones 168 | PADDATA: 169 | resb BUFFERSIZE 170 | TIBDATA: 171 | resb BUFFERSIZE 172 | WORDBUFFER: 173 | resb BUFFERSIZE 174 | 175 | ;; dictionary here? 176 | ;; colon and code definitions have the same structure 177 | ;; LINK (8) FLAGS (1) COUNT (1) NAME (cnt) code follows... 178 | 179 | ;; Here we create some macros for easy creation of dictionary entries, 180 | ;; along with labels than can be used later to call code or address 181 | ;; data directly from assembly 182 | 183 | ;; inspired by Itsy Forth, modified for STC and additional 184 | ;; code. .CONSTANT and .VARIABLE compile their own code straight 185 | ;; away. .CODE is gone, since all definitions are the same under STC, 186 | ;; but may come back later if I find some utility to having two 187 | ;; different words. 188 | 189 | %define link 0 190 | %define IMM 0x80 191 | %define LOCAL 0x40 192 | %define SMUDGE 0x20 193 | 194 | %macro head 3 195 | %{2}_entry: 196 | %%link dq link 197 | %define link %%link 198 | db %3 199 | %strlen %%count %1 200 | db %%count,%1 201 | %endmacro 202 | 203 | %macro .colon 2-3 0 204 | head %1,%2,%3 205 | %{2}: 206 | %endmacro 207 | 208 | ; %macro .constant 3 209 | %macro .constant 3-4 0 210 | head %1,%2,%4 211 | %{2}: 212 | mov W, val_ %+ %2 213 | mov X, [W] 214 | DPUSH X 215 | ret 216 | val_ %+ %2 dq %3 ; value stored here 217 | %endmacro 218 | 219 | ; %macro .variable 3 220 | %macro .variable 3-4 0 221 | head %1,%2,%4 222 | %{2}: 223 | DPUSH val_ %+ %2 224 | ret 225 | val_ %+ %2 dq %3 ; value stored here 226 | %endmacro 227 | 228 | 229 | SECTION .mysection exec 230 | align 4 231 | 232 | DICTIONARY: 233 | ;; primitives 234 | .constant "TRUE", true, -1 235 | .constant "FALSE", false, 0 236 | 237 | .constant "BASEDIGITS", digits, BASEDIGITS 238 | 239 | .colon "@", fetch 240 | mov TOS, [TOS] 241 | ret 242 | 243 | .colon "!",store 244 | mov r8, NOS 245 | mov [TOS], r8 246 | mov TOS, [PSP+CELLSIZE] 247 | add PSP, CELLSIZE*2 248 | ret 249 | 250 | .colon "+!",plusstore 251 | mov r8, NOS 252 | add [TOS], r8 253 | mov TOS, [PSP+CELLSIZE] 254 | add PSP, CELLSIZE*2 255 | ret 256 | 257 | .colon "C@", cfetch 258 | movzx TOS, byte [TOS] 259 | ret 260 | 261 | .colon "C!", cstore 262 | movzx r8, byte NOS 263 | mov byte [TOS], r8b 264 | mov TOS, [PSP+CELLSIZE] 265 | add PSP, CELLSIZE*2 266 | ret 267 | 268 | .colon "C+!", cplusstore 269 | movzx r8, byte NOS 270 | add byte [TOS], r8b 271 | mov TOS, [PSP+CELLSIZE] 272 | add PSP, CELLSIZE*2 273 | ret 274 | 275 | ;; mostly for internal use 276 | .colon "PSP", pointerOfNOS 277 | DUP 278 | mov TOS, PSP 279 | ret 280 | 281 | .colon "RP@", rpFetch 282 | DUP 283 | mov TOS, rsp 284 | add TOS, CELLSIZE ; return value under this function's return 285 | ret 286 | 287 | .colon "RP0@", rpBaseFetch 288 | DUP 289 | mov TOS, [RETURNSTACKBOTTOM] 290 | ret 291 | 292 | .colon "R@", rfetch 293 | DUP 294 | mov TOS, [rsp+CELLSIZE] 295 | ret 296 | 297 | ;; these words become shorter if code is inlined 298 | .colon "R>", fromrstack 299 | pop r8 300 | pop r9 301 | push r8 302 | DPUSH r9 303 | ret 304 | 305 | .colon ">R", torstack 306 | DPOP r8 307 | pop r9 308 | push r8 309 | push r9 310 | ret 311 | 312 | .colon "2R>", twofromrstack 313 | pop r10 314 | pop r8 315 | pop r9 316 | push r10 317 | DPUSH r9 318 | DPUSH r8 319 | ret 320 | 321 | .colon "2>R", twotorstack 322 | DPOP r8 323 | DPOP r9 324 | pop r10 325 | push r9 326 | push r8 327 | push r10 328 | ret 329 | 330 | .colon "0=", zeroEqual 331 | mov r8, TOS 332 | CLR TOS 333 | mov W, -1 334 | test r8, r8 335 | cmovz TOS, W 336 | ret 337 | 338 | .colon "0<>", zeroNotEqual 339 | mov r8, TOS 340 | CLR TOS 341 | mov W, -1 342 | test r8, r8 343 | cmovnz TOS, W 344 | ret 345 | 346 | .colon "0<", zeroLess 347 | mov r8, TOS 348 | CLR TOS 349 | mov W, -1 350 | cmp r8, 0 351 | cmovl TOS, W 352 | ret 353 | 354 | .colon "0>", zeroMore 355 | mov r8, TOS 356 | CLR TOS 357 | mov W, -1 358 | cmp r8, 0 359 | cmovg TOS, W 360 | ret 361 | 362 | .colon "=", equal 363 | mov r8, TOS 364 | CLR TOS 365 | mov W, -1 366 | cmp NOS, r8 367 | cmove TOS, W 368 | NIP 369 | ret 370 | 371 | .colon "<>", different 372 | mov r8, TOS 373 | CLR TOS 374 | mov W, -1 375 | cmp NOS, r8 376 | cmovne TOS, W 377 | NIP 378 | ret 379 | 380 | .colon "<", lesserthan 381 | mov r8, TOS 382 | CLR TOS 383 | mov W, -1 384 | cmp NOS, r8 385 | cmovl TOS, W 386 | NIP 387 | ret 388 | 389 | .colon ">", greaterthan 390 | mov r8, TOS 391 | CLR TOS 392 | mov W, -1 393 | cmp NOS, r8 394 | cmovg TOS, W 395 | NIP 396 | ret 397 | 398 | .colon "<=", lesserthanorequal 399 | mov r8, TOS 400 | CLR TOS 401 | mov W, -1 402 | cmp NOS, r8 403 | cmovle TOS, W 404 | NIP 405 | ret 406 | 407 | .colon ">=", greaterthanorequal 408 | mov r8, TOS 409 | CLR TOS 410 | mov W, -1 411 | cmp NOS, r8 412 | cmovge TOS, W 413 | NIP 414 | ret 415 | 416 | .colon "U<", ulesserthan 417 | mov r8, TOS 418 | CLR TOS 419 | mov W, -1 420 | cmp NOS, r8 421 | cmovb TOS, W 422 | NIP 423 | ret 424 | 425 | .colon "U>", ugreaterthan 426 | mov r8, TOS 427 | CLR TOS 428 | mov W, -1 429 | cmp NOS, r8 430 | cmova TOS, W 431 | NIP 432 | ret 433 | 434 | .colon "U<=", ulesserthanorequal 435 | mov r8, TOS 436 | CLR TOS 437 | mov W, -1 438 | cmp NOS, r8 439 | cmovbe TOS, W 440 | NIP 441 | ret 442 | 443 | .colon "U>=", ugreaterthanorequal 444 | mov r8, TOS 445 | CLR TOS 446 | mov W, -1 447 | cmp NOS, r8 448 | cmovae TOS, W 449 | NIP 450 | ret 451 | 452 | .colon "+", plus 453 | add TOS, NOS 454 | NIP 455 | ret 456 | 457 | .colon "-", minus 458 | sub NOS, TOS 459 | mov TOS, NOS 460 | NIP 461 | ret 462 | 463 | .colon "1+", increment 464 | inc TOS 465 | ret 466 | 467 | .colon "1-", decrement 468 | dec TOS 469 | ret 470 | 471 | .colon "*", multiply ; bit broken but works for reasonable numbers... xD 472 | imul TOS, NOS 473 | NIP 474 | ret 475 | 476 | ;; Signed divide RDX:RAX by r/m64, with result stored in 477 | ;; RAX ← Quotient, RDX ← Remainder. 478 | .colon "/MOD", dividemod 479 | xor rdx, rdx 480 | mov rax, NOS 481 | idiv TOS 482 | mov TOS, rax 483 | mov NOS, rdx 484 | ret 485 | 486 | ;; Unsigned divide RDX:RAX by r/m64, with result stored in 487 | ;; RAX ← Quotient, RDX ← Remainder. 488 | ;; ( ud u1 -- u2 u3 ) 489 | .colon "UM/MOD", umdividemod 490 | mov rax, [PSP+CELLSIZE] 491 | mov rdx, NOS ; which will be 0, but whatever... 492 | div TOS 493 | add PSP, CELLSIZE ; remove the high part of the double 494 | mov TOS, rax 495 | mov NOS, rdx 496 | ret 497 | 498 | .colon "/", divide 499 | xor rdx, rdx 500 | mov rax, NOS 501 | idiv TOS 502 | mov TOS, rax 503 | NIP 504 | ret 505 | 506 | .colon "MOD", mod 507 | xor rdx, rdx 508 | mov rax, NOS 509 | idiv TOS 510 | mov TOS, rdx 511 | NIP 512 | ret 513 | 514 | .colon "MIN", min 515 | mov r8, NOS 516 | mov r9, TOS 517 | cmp r8, r9 518 | cmovl TOS, r8 519 | NIP 520 | ret 521 | 522 | .colon "MAX", max 523 | mov r8, NOS 524 | mov r9, TOS 525 | cmp r8, r9 526 | cmovg TOS, r8 527 | NIP 528 | ret 529 | 530 | .colon "ABS", _abs 531 | mov r8, TOS 532 | neg r8 533 | cmovns TOS, r8 534 | ret 535 | 536 | .colon "NEGATE", negate 537 | neg TOS 538 | ret 539 | 540 | .colon "NAND", nand_ 541 | and TOS, NOS 542 | not TOS 543 | NIP 544 | ret 545 | 546 | .colon "NOR", nor_ 547 | or TOS, NOS 548 | not TOS 549 | NIP 550 | ret 551 | 552 | .colon "XNOR", xnor_ 553 | xor TOS, NOS 554 | not TOS 555 | NIP 556 | ret 557 | 558 | .colon "AND", and_ 559 | and TOS, NOS 560 | NIP 561 | ret 562 | 563 | .colon "OR", or_ 564 | or TOS, NOS 565 | NIP 566 | ret 567 | 568 | .colon "XOR", xor_ 569 | xor TOS, NOS 570 | NIP 571 | ret 572 | 573 | .colon "INVERT", invert 574 | not TOS 575 | ret 576 | 577 | .colon "2*", shift1left 578 | shl TOS, 1 579 | ret 580 | 581 | .colon "2/", shift1right 582 | shr TOS, 1 583 | ret 584 | 585 | .colon "LSHIFT", shiftleft 586 | mov rcx, TOS 587 | mov TOS, NOS 588 | add PSP, CELLSIZE 589 | shl TOS, cl 590 | ret 591 | 592 | .colon "RSHIFT", shiftright 593 | mov rcx, TOS 594 | mov TOS, NOS 595 | add PSP, CELLSIZE 596 | shr TOS, cl 597 | ret 598 | 599 | ;; User-level applications use as integer registers for passing the 600 | ;; sequence %rdi, %rsi, %rdx, %rcx, %r8 and %r9. The kernel interface 601 | ;; uses %rdi, %rsi, %rdx, %r10, %r8 and %r9. 602 | 603 | ;; A system-call is done via the syscall instruction. The kernel 604 | ;; destroys registers %rcx and %r11. 605 | 606 | ;; The number of the syscall has to be passed in register %rax. 607 | 608 | ;; System-calls are limited to six arguments,no argument is passed 609 | ;; directly on the stack. 610 | 611 | ;; Returning from the syscall, register %rax contains the result of 612 | ;; the system-call. A value in the range between -4095 and -1 613 | ;; indicates an error, it is -errno. 614 | 615 | ;; Only values of class INTEGER or class MEMORY are passed to the 616 | ;; kernel. 617 | 618 | 619 | .colon "MS", ms 620 | xor rdx, rdx 621 | mov rax, TOS 622 | mov rbx, 1000 623 | idiv rbx 624 | mov qword [tv_sec], rax 625 | mov rax, rdx 626 | mul rbx 627 | mul rbx 628 | mov qword [tv_usec], rax 629 | mov rdi, timeval 630 | mov rsi, 0 631 | mov rax, 0x23 632 | syscall 633 | DROP 634 | ret 635 | 636 | .colon "SYSCALL/0", colonsyscall ; ( int -- result ) 637 | DPOP rax 638 | syscall 639 | DPUSH rax 640 | ret 641 | 642 | .colon "SYSCALL/1", colonsyscall1 ; ( arg1 int -- result ) 643 | DPOP rax 644 | DPOP rdi 645 | syscall 646 | DPUSH rax 647 | ret 648 | 649 | .colon "SYSCALL/2", colonsyscall2 650 | DPOP rax 651 | DPOP rdi 652 | DPOP rsi 653 | syscall 654 | DPUSH rax 655 | ret 656 | 657 | .colon "SYSCALL/3", colonsyscall3 658 | DPOP rax 659 | DPOP rdi 660 | DPOP rsi 661 | DPOP rdx 662 | syscall 663 | DPUSH rax 664 | ret 665 | 666 | .colon "SYSCALL/4", colonsyscall4 667 | DPOP rax 668 | DPOP rdi 669 | DPOP rsi 670 | DPOP rdx 671 | DPOP r10 672 | syscall 673 | DPUSH rax 674 | ret 675 | 676 | .colon "SYSCALL/5", colonsyscall5 677 | DPOP rax 678 | DPOP rdi 679 | DPOP rsi 680 | DPOP rdx 681 | DPOP r10 682 | DPOP r8 683 | syscall 684 | DPUSH rax 685 | ret 686 | 687 | .colon "SYSCALL/6", colonsyscall6 688 | DPOP rax 689 | DPOP rdi 690 | DPOP rsi 691 | DPOP rdx 692 | DPOP r10 693 | DPOP r8 694 | DPOP r9 695 | syscall 696 | DPUSH rax 697 | ret 698 | 699 | ;; TYPE 700 | .colon "TYPE", type ; ( addr n -- ) 701 | call swap 702 | DPUSH 1 703 | DPUSH 1 704 | call colonsyscall3 705 | call drop 706 | ret 707 | 708 | .colon "EMIT", emit 709 | ; instead store the char on the return stack 710 | DPOP r8 711 | push r8 712 | DPUSH rsp 713 | DPUSH 1 714 | call type 715 | ; drop the char on the return stack 716 | pop r8 717 | ret 718 | 719 | .colon "KEY", key 720 | ;; ideally we should set the terminal to raw or something first 721 | push 0 722 | DPUSH 1 723 | DPUSH rsp 724 | DPUSH 0 725 | DPUSH 0 726 | call colonsyscall3 727 | call drop 728 | pop r8 729 | DPUSH r8 730 | ret 731 | 732 | ;; stack manipulation 733 | 734 | .colon "DUP", dup ; ( a -- a a ) 735 | DUP 736 | ret 737 | 738 | .colon "?DUP", maybedup ; ( a -- a / a a ) 739 | test TOS, TOS 740 | jz maybedup_end 741 | DUP 742 | maybedup_end: 743 | ret 744 | 745 | .colon "2DUP", _2dup ; ( a b -- a b a b ) 746 | mov r8, NOS 747 | sub PSP, CELLSIZE*2 748 | mov [PSP+CELLSIZE], TOS 749 | mov NOS, r8 750 | ret 751 | 752 | .colon "SWAP", swap ; ( a b -- b a ) 753 | SWAP 754 | ret 755 | 756 | .colon "2SWAP", _2swap ; ( a b c d -- c d a b ) 757 | mov r8, [PSP+CELLSIZE*2] 758 | mov r9, NOS 759 | mov NOS, r8 760 | mov [PSP+CELLSIZE*2], r9 761 | mov r11, TOS 762 | mov r12, [PSP+CELLSIZE] 763 | mov [PSP+CELLSIZE], r11 764 | mov TOS, r12 765 | ret 766 | 767 | .colon "DROP", drop ; ( a -- ) 768 | DROP 769 | ret 770 | 771 | .colon "2DROP", _2drop ; ( a b -- ) 772 | mov TOS, [PSP+CELLSIZE] 773 | add PSP, CELLSIZE*2 774 | ret 775 | 776 | .colon "OVER", over ; ( a b -- a b a ) 777 | mov r8, NOS 778 | DPUSH r8 779 | ret 780 | 781 | .colon "2OVER", _2over ; ( a b c d -- a b c d a b ) 782 | sub PSP, CELLSIZE*2 783 | mov [PSP+CELLSIZE], TOS 784 | mov r8, [PSP+CELLSIZE*4] 785 | mov NOS, r8 786 | mov TOS, [PSP+CELLSIZE*3] 787 | ret 788 | 789 | .colon "NIP", nip ; ( a b -- b ) 790 | NIP 791 | ret 792 | 793 | .colon "TUCK", tuck ; ( a b -- b a b ) 794 | mov r8, NOS 795 | sub PSP, CELLSIZE 796 | mov NOS, r8 797 | mov [PSP+CELLSIZE], TOS 798 | ret 799 | 800 | .colon "ROT", rot ; ( a b c -- b c a ) 801 | mov r8, NOS 802 | mov r9, [PSP+CELLSIZE] 803 | mov NOS, TOS 804 | mov [PSP+CELLSIZE], r8 805 | mov TOS, r9 806 | ret 807 | 808 | .colon "-ROT", minusrot ; ( a b c -- c a b ) 809 | mov r8, NOS 810 | mov r9, [PSP+CELLSIZE] 811 | mov [PSP+CELLSIZE], TOS 812 | mov NOS, r9 813 | mov TOS, r8 814 | ret 815 | 816 | .colon "PICK", pick 817 | shl TOS, 3 ; cell size is 8 818 | add TOS, PSP 819 | mov TOS, [TOS] 820 | ret 821 | 822 | .colon "ROLL", roll 823 | ; all the elements to be rotated are on the PSP area, 824 | ; TOS holds the index, overwrite it with the final value 825 | mov r8, TOS 826 | mov r9, r8 827 | shl r9, 3 ; cell size is 8 828 | add r9, PSP 829 | mov TOS, [r9] 830 | ; now copy stack down (or up...?) 831 | mov rdi, r9 832 | sub r9, CELLSIZE 833 | mov rsi, r9 834 | mov rcx, r8 835 | ; IN REVERSE, stack grows downwards, so we want to start 836 | ; copying from the end, and decrement the pointers!! 837 | std 838 | rep movsq 839 | cld 840 | ; finally adjust the stack pointer since we consumed the index 841 | NIP 842 | ret 843 | 844 | .colon "CR", cr 845 | DPUSH 10 846 | call emit 847 | ret 848 | 849 | .colon "BYE", bye 850 | DPUSH 0 851 | DPUSH 60 852 | call colonsyscall1 853 | ; not that we ever get here... 854 | call drop 855 | ret 856 | 857 | .variable "BASE", base, 10 ; base is 10 by default 858 | .variable "STATE", state, 0 ; 0 interpret, 1 compile 859 | .variable "LATEST", latest, 0 860 | .variable "TIB", TIB, TIBDATA 861 | .variable ">IN", TOIN, 0 862 | 863 | .variable "DP", dp, 0 864 | .colon "HERE", here 865 | mov r8, [val_dp] 866 | DPUSH r8 867 | ret 868 | 869 | .colon "UNUSED", unused 870 | mov r8, end_of_dictionary 871 | sub r8, [val_dp] 872 | DPUSH r8 873 | ret 874 | 875 | .colon "(", leftparen, IMM 876 | DPUSH ')' 877 | call word_ 878 | call drop 879 | ret 880 | 881 | .colon '\', backslash, IMM 882 | ;;; ' ; work around nasm-mode highlighting 883 | DPUSH 10 884 | call word_ 885 | call drop 886 | ret 887 | 888 | .colon "#!", shellsignature, IMM 889 | DPUSH 10 890 | call word_ 891 | call drop 892 | ret 893 | 894 | ;; ( c-addr u1 fileid -- u2 flag ior ) 895 | .colon "READ-LINE", readline 896 | DPOP W ; fid 897 | DPOP X ; max 898 | xor r8, r8 ; count 899 | DPOP r9 ; c-addr 900 | 901 | readline_next_char: 902 | cmp r8, X 903 | je readline_done 904 | 905 | DPUSH 1 906 | DPUSH r9 907 | DPUSH W 908 | DPUSH 0 ; read syscall 909 | call colonsyscall3 910 | DPOP rax 911 | 912 | ;; rax holds size (0/1) or -errno 913 | test rax, rax 914 | ;; exit when either error 915 | js readline_error 916 | ;; or EOF 917 | jz readline_eof 918 | 919 | ;; if newline then done 920 | cmp byte [r9], 10 921 | je readline_done 922 | 923 | ;; move to next char 924 | inc r9 925 | inc r8 926 | jmp readline_next_char 927 | 928 | readline_done: 929 | DPUSH r8 930 | DPUSH -1 931 | DPUSH 0 932 | ret 933 | 934 | readline_eof: 935 | DPUSH r8 936 | DPUSH 0 937 | DPUSH 0 938 | ret 939 | 940 | readline_error: 941 | DPUSH r8 942 | DPUSH r8 ; return values don't matter 943 | DPUSH -1 ; and ior 944 | ret 945 | 946 | .variable "", sourceaddr, TIBDATA, LOCAL 947 | .variable "", sourcelen, BUFFERSIZE, LOCAL 948 | .variable "SOURCE-ID", sourceid, 0 949 | .variable "BLK", blk, 0 950 | 951 | .colon "SOURCE", source 952 | mov r8, [val_sourceaddr] 953 | mov r9, [val_sourcelen] 954 | DPUSH r8 955 | DPUSH r9 956 | ret 957 | 958 | ;; ( -- f ) 959 | .colon "REFILL", refill 960 | mov r8, [val_sourceid] 961 | cmp r8, -1 962 | je refill_error 963 | 964 | ; clear the input buffer 965 | ; mov rdi, TIBDATA 966 | ; mov rcx, BUFFERSIZE 967 | mov rdi, [val_sourceaddr] 968 | mov rcx, [val_sourcelen] 969 | mov al, ' ' 970 | rep stosb 971 | 972 | ; read a... line 973 | ; DPUSH TIBDATA 974 | ; DPUSH BUFFERSIZE 975 | mov r8, [val_sourceaddr] 976 | mov r9, [val_sourcelen] 977 | mov r10, [val_sourceid] 978 | DPUSH r8 979 | DPUSH r9 980 | DPUSH r10 981 | call readline 982 | 983 | DPOP W ; test ior 984 | test W, W 985 | js refill_error2 986 | 987 | DPOP X ; test flag 988 | test X, X 989 | jz refill_error 990 | 991 | refill_done: 992 | ; no error, reset >IN and return true 993 | DPOP r8 994 | DPUSH 0 995 | call TOIN 996 | call store 997 | DPUSH -1 998 | ret 999 | 1000 | refill_error2: 1001 | DPOP r8 1002 | refill_error: 1003 | DPUSH 0 ; return false 1004 | ret 1005 | 1006 | .constant "R/O", rofam, 0 1007 | .constant "W/O", wofam, 1 1008 | .constant "R/W", rwfam, 2 1009 | 1010 | ;; Outer interpreter stuff 1011 | .constant "BL", bl_, ' ' 1012 | 1013 | .colon "COUNT", count 1014 | call dup 1015 | call cfetch 1016 | call swap 1017 | DPUSH 1 1018 | call plus 1019 | call swap 1020 | ret 1021 | 1022 | .colon "WORD", word_ 1023 | ; call TIB 1024 | ; call fetch 1025 | mov r8, [val_sourceaddr] 1026 | DPUSH r8 1027 | call TOIN 1028 | call fetch 1029 | call plus 1030 | 1031 | ; compare char with delimiter 1032 | ; the address of the potential word is on TOS 1033 | DPOP rsi 1034 | ; the delimiter is on TOS now, we'll just point rdi to it 1035 | ; mov rdi, PSP 1036 | ; ok so what if we move it to the return stack instead...? 1037 | DPOP r8 1038 | push 10 ; newline 1039 | push r8 1040 | 1041 | 1042 | word_skip_delimiters: 1043 | mov rdi, rsp 1044 | cmpsb 1045 | je word_check_end 1046 | 1047 | ;; if not equal we may have a word 1048 | ;; we still need to check for newline 1049 | 1050 | maybe_newline: 1051 | dec rsi 1052 | add rdi, 7 1053 | cmpsb 1054 | je word_check_end 1055 | 1056 | ;; we do have a word 1057 | jmp skipped_delimiters 1058 | 1059 | word_check_end: 1060 | ; if we went over the end of TIBDATA, we're done 1061 | ; cmp rsi, TIBDATA+BUFFERSIZE-1 1062 | mov r8, [val_sourceaddr] 1063 | add r8, [val_sourcelen] 1064 | dec r8 1065 | cmp rsi, r8 1066 | jge tibdata_was_empty 1067 | 1068 | ;; otherwise continue 1069 | jmp word_skip_delimiters 1070 | 1071 | tibdata_was_empty: 1072 | ;; mov rsi, WORDBUFFER 1073 | mov rsi, [val_dp] 1074 | mov qword [rsi], qword 0 1075 | 1076 | ; clean up the delimiters from the return stack 1077 | ; call drop (?) 1078 | pop r8 1079 | pop r8 1080 | ;; DPUSH WORDBUFFER 1081 | mov r8, [val_dp] 1082 | DPUSH r8 1083 | 1084 | ret 1085 | 1086 | skipped_delimiters: 1087 | ; readjust the pointers back 1088 | dec rsi 1089 | DPUSH rsi ; save the beginning of the word 1090 | 1091 | find_closing_delimiter: 1092 | ; we have a word, find the end 1093 | ; the word address is on rsi (and on the stack) 1094 | ; the delimiter is on rdi (and on the stack under TOS) 1095 | 1096 | ; compare char with delimiter 1097 | mov rdi, rsp 1098 | cmpsb 1099 | 1100 | ; if we find delimiter, we are past the word 1101 | je found_closing_delimiter 1102 | 1103 | ;; repeat for newline 1104 | dec rsi 1105 | add rdi, 7 1106 | cmpsb 1107 | je found_closing_delimiter 1108 | 1109 | ; if we went over the end of input_buffer, return right away 1110 | ; address A holding size S gives a max address of A+S-1 1111 | ; cmp rsi, TIBDATA+BUFFERSIZE-1 1112 | mov r8, [val_sourceaddr] 1113 | add r8, [val_sourcelen] 1114 | dec r8 1115 | cmp rsi, r8 1116 | je found_closing_delimiter 1117 | 1118 | ;; otherwise move along to the next char 1119 | jmp find_closing_delimiter 1120 | 1121 | found_closing_delimiter: 1122 | ; update >IN 1123 | ; with the difference between end of parsing and end of input bufer 1124 | mov W, rsi 1125 | sub W, [val_sourceaddr] 1126 | DPUSH W 1127 | call TOIN 1128 | call store 1129 | 1130 | ; we have the end, calculate the length now 1131 | ; rsi holds the end 1132 | ; the word address is on the stack 1133 | mov rcx, rsi 1134 | DPOP W 1135 | sub rcx, W ; load the number of chars on RCX (end-start) 1136 | dec rcx ; correct the off by one 1137 | 1138 | mov rsi, W 1139 | ;; mov rdi, WORDBUFFER 1140 | mov rdi, [val_dp] 1141 | mov [rdi], cl ; put the count 1142 | 1143 | ; put the string 1144 | inc rdi 1145 | rep movsb 1146 | 1147 | ;; clear the delimiters off the stack 1148 | ;; call drop (?) 1149 | pop r8 1150 | pop r8 1151 | 1152 | ; return the address of the parsed word 1153 | ;; DPUSH WORDBUFFER 1154 | mov r8, [val_dp] 1155 | DPUSH r8 1156 | ret 1157 | 1158 | .colon "FIND", find ; ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 1159 | ; store the address of the source string on r10 1160 | ; mov r10, NOS 1161 | DPOP r10 1162 | DPUSH r10 1163 | ; store the address of the link on Y 1164 | call latest 1165 | call fetch 1166 | DPOP Y 1167 | 1168 | find_setup: 1169 | ; load rsi and rdi 1170 | mov rsi, r10 1171 | mov rdi, Y 1172 | 1173 | ; first move over the link, to the flags 1174 | add rdi, CELLSIZE 1175 | 1176 | ; if it's smudged, skip 1177 | test byte [rdi], SMUDGE 1178 | jnz find_next_link 1179 | 1180 | ; else store the immediate bit 1181 | mov dl, byte [rdi] 1182 | and dl, IMM 1183 | 1184 | ; then move over the flags 1185 | add rdi, 1 1186 | 1187 | ; compare the string lengths 1188 | find_check_lengths: 1189 | xor rbx, rbx 1190 | xor rcx, rcx 1191 | mov bl, [rsi] 1192 | mov cl, [rdi] 1193 | cmp bl, cl 1194 | je find_check_names 1195 | 1196 | find_next_link: 1197 | ; if they're different move to the next link 1198 | mov Y, [Y] 1199 | mov rdi, Y 1200 | 1201 | ; if the link is 0, not found 1202 | test rdi, rdi 1203 | jz find_not_found 1204 | 1205 | ; else check the next entry 1206 | jmp find_setup 1207 | 1208 | find_check_names: 1209 | ; count is still loaded on bl and cl 1210 | ; advance the pointers over the counts 1211 | inc rsi 1212 | inc rdi 1213 | 1214 | ; if no chars left (-1), they're equal, we're done 1215 | dec rcx 1216 | js find_word_found 1217 | 1218 | ; compare strings, count is already loaded in cl/rcx 1219 | mov r8b, byte [rsi] 1220 | mov r9b, byte [rdi] 1221 | cmp r8b, r9b 1222 | 1223 | ; if they're equal keep checking 1224 | je find_check_names 1225 | 1226 | ; retry with toggled case (but only if it's a letter!!) 1227 | or r8b, 0b00100000 ; force "lowercase" 1228 | sub r8b, 'a' ; convert to 0-25 1229 | cmp r8b, 'z'-'a' ; check if it is a letter 1230 | ja find_next_link 1231 | 1232 | or r9b, 0b00100000 ; force lowercase on dict letter 1233 | sub r9b, 'a' ; convert, no need for checks here 1234 | cmp r8b, r9b 1235 | je find_check_names 1236 | 1237 | jmp find_next_link 1238 | 1239 | find_not_found: 1240 | ; return c-addr and 0 1241 | DPUSH 0 1242 | ret 1243 | 1244 | find_word_found: 1245 | ; drop c-addr 1246 | DROP 1247 | ; push xt (code address) 1248 | DPUSH rdi 1249 | ; push either 1 (imm) or -1 (non-imm) 1250 | test dl, dl 1251 | jz find_return_non_immediate 1252 | 1253 | find_return_immediate: 1254 | DPUSH 1 1255 | ret 1256 | 1257 | find_return_non_immediate: 1258 | DPUSH -1 1259 | ret 1260 | 1261 | .colon "'", tick ; ( c"" -- xt ) 1262 | call bl_ 1263 | call word_ 1264 | call find 1265 | DROP ; nope, bad 1266 | ret 1267 | 1268 | .colon "[']", tickimm, IMM ; ( c"" -- xt ) 1269 | call bl_ 1270 | call word_ 1271 | call find 1272 | DROP ; nope, bad 1273 | DPUSH lit 1274 | call compilecomma 1275 | call comma 1276 | ret 1277 | 1278 | .colon "EXECUTE", execute ; ( xt -- ) 1279 | DPOP W 1280 | call W ; what about a jump...? 1281 | ret 1282 | 1283 | .colon ";", semicolon, IMM 1284 | mov rsi, [val_dp] 1285 | mov byte [rsi], 0xC3 1286 | inc rsi 1287 | mov rdi, val_dp 1288 | mov [rdi], rsi 1289 | 1290 | ; reveal the word 1291 | call reveal 1292 | 1293 | DPUSH 0 1294 | call state 1295 | call store 1296 | ret 1297 | 1298 | ;; Forth 2012 says this ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 1299 | ;; For now we will have ( n1 c-addr1 u1 -- n2 c-addr2 u2 ) ? 1300 | .colon ">NUMBER", tonumber 1301 | DPOP X 1302 | DPOP W 1303 | 1304 | ; bail out early if there are no digits to check 1305 | test X, X 1306 | jz tonumber_done 1307 | 1308 | ; always save BASE under TOS (the accumulator at this point) 1309 | call base 1310 | call fetch 1311 | call swap 1312 | 1313 | CLR r10 ; clear the 64-bit register to load 8 bits 1314 | 1315 | ; check for sign and prefixes first!!!! 1316 | mov r10b, [W] 1317 | ; is it '? character, read until next ' 1318 | ; maybe we ignore this one for now... 1319 | 1320 | ; is it $? hex 1321 | cmp r10, '$' 1322 | je tonumber_hex 1323 | 1324 | ; is it #? decimal 1325 | cmp r10, '#' 1326 | je tonumber_decimal 1327 | 1328 | ; is it %? binary 1329 | cmp r10, '%' 1330 | je tonumber_binary 1331 | 1332 | ; is it '? ascii 1333 | cmp r10, "'" 1334 | je tonumber_ascii 1335 | 1336 | ; the number is in the current base 1337 | jmp tonumber_begin 1338 | 1339 | tonumber_hex: 1340 | DPUSH 16 1341 | call base 1342 | call store 1343 | inc W 1344 | dec X 1345 | jmp tonumber_begin 1346 | 1347 | tonumber_decimal: 1348 | DPUSH 10 1349 | call base 1350 | call store 1351 | inc W 1352 | dec X 1353 | jmp tonumber_begin 1354 | 1355 | tonumber_binary: 1356 | DPUSH 2 1357 | call base 1358 | call store 1359 | inc W 1360 | dec X 1361 | jmp tonumber_begin 1362 | 1363 | tonumber_ascii: 1364 | inc W 1365 | dec X 1366 | mov r10b, [W] 1367 | mov rdx, 1 1368 | DPUSH r10 1369 | call plus 1370 | inc W 1371 | dec X 1372 | jmp tonumber_done 1373 | 1374 | ; and for the first three prefixes... 1375 | ; is it -? negative 1376 | 1377 | tonumber_begin: 1378 | mov r10b, [W] 1379 | mov rdx, 1 1380 | ; check if it's a negative 1381 | cmp r10, '-' 1382 | je tonumber_negative 1383 | jmp tonumber_one_digit 1384 | 1385 | tonumber_negative: 1386 | mov rdx, -1 1387 | inc W 1388 | dec X 1389 | 1390 | ; add each digit until we run out of (valid) digits 1391 | tonumber_one_digit: 1392 | mov r10b, [W] 1393 | 1394 | ; is Y between '0' and '9'? 1395 | cmp r10, '0' 1396 | jl tonumber_done 1397 | 1398 | cmp r10, '9' 1399 | jg tonumber_maybe_letter 1400 | 1401 | ; we have a digit, convert 1402 | sub r10, '0' 1403 | 1404 | jmp tonumber_validate_digit 1405 | 1406 | tonumber_maybe_letter: 1407 | ; is Y between '0' and '9'? 1408 | cmp r10, 'A' 1409 | jl tonumber_done 1410 | 1411 | cmp r10, 'Z' 1412 | jg tonumber_done 1413 | 1414 | ; we have a digit, convert 1415 | sub r10, 'A'-10 1416 | 1417 | jmp tonumber_validate_digit 1418 | 1419 | tonumber_validate_digit: 1420 | ; is the value under BASE? if not, it's an invalid digit 1421 | call base 1422 | call fetch 1423 | DPOP Y 1424 | cmp r10, Y 1425 | jge tonumber_done 1426 | 1427 | tonumber_convert: 1428 | ; first multiply n1 by BASE 1429 | call base 1430 | call fetch 1431 | call multiply 1432 | 1433 | ; then add to the running total 1434 | DPUSH r10 1435 | call plus 1436 | 1437 | tonumber_next_digit: 1438 | inc W 1439 | dec X 1440 | jnz tonumber_one_digit 1441 | 1442 | tonumber_done: 1443 | call swap 1444 | call base 1445 | call store 1446 | DPUSH rdx 1447 | call multiply 1448 | DPUSH W 1449 | DPUSH X 1450 | ret 1451 | 1452 | 1453 | .colon "INTERPRET", interpret 1454 | interpret_next_word: 1455 | call bl_ 1456 | call word_ 1457 | 1458 | ; finished if there are no more words left (WORD returns "") 1459 | call dup 1460 | call cfetch 1461 | DPOP W 1462 | test W, W 1463 | jz interpret_end 1464 | 1465 | call find 1466 | DPOP W 1467 | test W, W 1468 | 1469 | ; if not found, it may be a number 1470 | jz interpret_maybe_number 1471 | 1472 | ; if found, execute or compile it 1473 | 1474 | ; check immediacy 1475 | ; W = 1 immediate 1476 | ; W = -1 non-immediate 1477 | test W, W 1478 | jns interpreting_or_immediate 1479 | 1480 | ; check state 1481 | call state 1482 | call fetch 1483 | DPOP X 1484 | test X, X 1485 | jz interpreting_or_immediate 1486 | 1487 | interpret_compiling: 1488 | DPOP W 1489 | ; compile a near relative call, target address is in W 1490 | call dp 1491 | call fetch 1492 | DPOP rdi 1493 | mov byte [rdi], 0xE8 1494 | 1495 | ; obtain a 32 bit number to work with 32 bit signed 1496 | call dp 1497 | call fetch 1498 | ;mov r13d, NOS 1499 | ;call drop 1500 | DPOP X 1501 | 1502 | sub r12d, r13d ; this is W as a dword 1503 | sub r12d, 5 ; additional offset from next instruction 1504 | mov [rdi+1], r12d ; this is W as (now negative) dword 1505 | 1506 | ; update here 1507 | call dp 1508 | call fetch 1509 | DPUSH 5 1510 | call plus 1511 | call dp 1512 | call store 1513 | 1514 | jmp interpret_next_word 1515 | 1516 | interpreting_or_immediate: 1517 | ; interpreting or it's an immediate, execute it 1518 | DPOP W 1519 | call W 1520 | jmp interpret_next_word 1521 | 1522 | interpret_maybe_number: 1523 | ; keep the original address on the stack? 1524 | call dup 1525 | 1526 | ; we swipe the 0 first because I haven't written ROT and -ROT yet 1527 | DPUSH 0 1528 | call swap 1529 | ; we can thrash the address copy 1530 | call count 1531 | ; >number takes (0 address count) 1532 | call tonumber 1533 | 1534 | ; if we got any characters left, it's not a number 1535 | DPOP W 1536 | test W, W 1537 | jnz interpret_not_found 1538 | 1539 | ; if there are no chars left, we can drop the address 1540 | call drop 1541 | ; we can also drop the original address 1542 | call swap 1543 | call drop 1544 | 1545 | ; IF WE'RE COMPILING WE MUST COMPILE THE NUMBER(!!!!!!) 1546 | ; but if interpreting, we're done 1547 | mov rcx, [val_state] 1548 | test rcx, rcx 1549 | jz interpret_next_word 1550 | 1551 | ; compile a call to LIT 1552 | ; compute the relative address from here to LIT 1553 | mov W, lit 1554 | ; compile a near relative call, target address is in W 1555 | call dp 1556 | call fetch 1557 | DPOP rdi 1558 | mov byte [rdi], 0xE8 1559 | 1560 | ; obtain a 32 bit number to work with 32 bit signed 1561 | call dp 1562 | call fetch 1563 | ;mov r13d, NOS 1564 | ;call drop 1565 | DPOP X 1566 | 1567 | sub r12d, r13d ; this is W as a dword 1568 | sub r12d, 5 ; additional offset from next instruction 1569 | mov [rdi+1], r12d ; this is W as (now negative) dword 1570 | 1571 | ; compile the number immediately after 1572 | DPOP r8 1573 | mov qword [rdi+5], r8 1574 | 1575 | ; update here 1576 | call dp 1577 | call fetch 1578 | DPUSH 5+CELLSIZE 1579 | call plus 1580 | call dp 1581 | call store 1582 | 1583 | 1584 | ; and we're left with the number, move along to the next word 1585 | jmp interpret_next_word 1586 | 1587 | interpret_not_found: 1588 | call drop 1589 | call drop 1590 | call count 1591 | call type 1592 | DPUSH notFoundMsgStr 1593 | DPUSH notFoundMsgLen 1594 | call type 1595 | call cr 1596 | 1597 | ; should clear the stack pointers... or is that QUIT's job? 1598 | ;jmp interpret_end 1599 | call warm 1600 | ret 1601 | 1602 | interpret_end: 1603 | call drop 1604 | ret 1605 | 1606 | .colon ".", period ; ( n -- ) 1607 | ; if 0, just print 0 and exit 1608 | DPOP rax 1609 | test rax, rax 1610 | jz period_zero 1611 | 1612 | ; display negatives somehow... only if BASE is 10 1613 | cmp qword [val_base], 10 1614 | jne period_begin_process 1615 | 1616 | ; print a '-' only if it's a negative 1617 | test rax, rax 1618 | jns period_begin_process 1619 | 1620 | mov W, rax 1621 | DPUSH '-' 1622 | call emit 1623 | mov rax, W 1624 | ; then negate the number and print it normally 1625 | neg rax 1626 | 1627 | period_begin_process: 1628 | CLR W 1629 | 1630 | period_process_digit: 1631 | CLR rdx 1632 | mov rbx, [val_base] 1633 | div rbx 1634 | add rdx, BASEDIGITS ; make a letter 1635 | mov rdx, [rdx] 1636 | DPUSH byte rdx 1637 | inc W 1638 | test rax, rax 1639 | jnz period_process_digit 1640 | 1641 | period_emit_digit: 1642 | ; no more digits, print them back from the stack 1643 | call emit 1644 | dec W 1645 | jnz period_emit_digit 1646 | 1647 | jmp period_done 1648 | 1649 | period_zero: 1650 | DPUSH '0' 1651 | call emit 1652 | 1653 | period_done: 1654 | DPUSH ' ' 1655 | call emit 1656 | ret 1657 | 1658 | ;; hack to print numbers without spaces, until I implement U.R 1659 | .colon "..", period2 ; ( n -- ) 1660 | ; if 0, just print 0 and exit 1661 | DPOP rax 1662 | test rax, rax 1663 | jz period_zero2 1664 | 1665 | ; display negatives somehow... only if BASE is 10 1666 | cmp qword [val_base], 10 1667 | jne period_begin_process2 1668 | 1669 | ; print a '-' only if it's a negative 1670 | test rax, rax 1671 | jns period_begin_process2 1672 | 1673 | mov W, rax 1674 | DPUSH '-' 1675 | call emit 1676 | mov rax, W 1677 | ; then negate then number and print it normally 1678 | neg rax 1679 | 1680 | period_begin_process2: 1681 | CLR W 1682 | 1683 | period_process_digit2: 1684 | CLR rdx 1685 | mov rbx, [val_base] 1686 | div rbx 1687 | add rdx, BASEDIGITS ; make a letter 1688 | mov rdx, [rdx] 1689 | DPUSH byte rdx 1690 | inc W 1691 | test rax, rax 1692 | jnz period_process_digit2 1693 | 1694 | period_emit_digit2: 1695 | ; no more digits, print them back from the stack 1696 | call emit 1697 | dec W 1698 | jnz period_emit_digit2 1699 | 1700 | jmp period_done2 1701 | 1702 | period_zero2: 1703 | DPUSH '0' 1704 | call emit 1705 | 1706 | period_done2: 1707 | ret 1708 | 1709 | 1710 | .colon ".S", printstack 1711 | DPUSH ' ' 1712 | DPUSH '[' 1713 | call emit 1714 | call emit 1715 | DPUSH 0 ; inject a 0 to move TOS down into memory 1716 | mov r9, DATASTACKBOTTOM-CELLSIZE ; address of bottom cell on r9 1717 | mov X, DATASTACKBOTTOM-CELLSIZE 1718 | sub X, PSP 1719 | shr X, 3 ; divide by 8, DEPTH on X 1720 | 1721 | printstack_next_deepest: 1722 | cmp r9, PSP 1723 | jl printstack_done 1724 | 1725 | mov r8, [r9] 1726 | DPUSH r8 1727 | call period 1728 | sub r9, CELLSIZE 1729 | jmp printstack_next_deepest 1730 | 1731 | printstack_done: 1732 | DPOP r8 ; clear the injected 0 1733 | DPUSH ' ' 1734 | DPUSH ']' 1735 | call emit 1736 | call emit 1737 | inc X 1738 | DPUSH X 1739 | call period 1740 | ret 1741 | 1742 | .variable "", _promptbool, -1 1743 | 1744 | .colon "", _noprompt 1745 | DPUSH 0 1746 | call _promptbool 1747 | call store 1748 | ret 1749 | 1750 | .colon "", _prompt 1751 | DPUSH -1 1752 | call _promptbool 1753 | call store 1754 | ret 1755 | 1756 | .colon "QUIT", quit 1757 | ; interpret some words from TIB separated by spaces(!) 1758 | call refill 1759 | DPOP r8 1760 | test r8, r8 1761 | jz bye 1762 | 1763 | ;; call drop ; should do something with this flag(!) 1764 | 1765 | call interpret 1766 | call quit_prompt 1767 | jmp quit 1768 | 1769 | quit_prompt: 1770 | mov r8, [val__promptbool] 1771 | test r8, r8 1772 | jz quit_prompt_end 1773 | 1774 | DPUSH promptStr 1775 | DPUSH promptLen 1776 | call type 1777 | quit_prompt_end: 1778 | ret 1779 | 1780 | .colon "ALLOT", allot ; ( n -- ) 1781 | ; should clear the space too? 1782 | call dp 1783 | call fetch 1784 | call plus 1785 | call dp 1786 | call store 1787 | ret 1788 | 1789 | 1790 | .colon "[", leftbracket, IMM 1791 | DPUSH 0 1792 | call state 1793 | call store 1794 | ret 1795 | 1796 | .colon "]", rightbracket, IMM 1797 | DPUSH 1 1798 | call state 1799 | call store 1800 | ret 1801 | 1802 | .colon ",", comma 1803 | call here 1804 | call store 1805 | call here 1806 | DPUSH CELLSIZE 1807 | call plus 1808 | call dp 1809 | call store 1810 | ret 1811 | 1812 | .colon "C,", c_comma 1813 | call here 1814 | call cstore 1815 | call here 1816 | DPUSH 1 1817 | call plus 1818 | call dp 1819 | call store 1820 | ret 1821 | 1822 | .colon "IMMEDIATE", immediate 1823 | ; find last entry 1824 | call latest 1825 | call fetch 1826 | ; get to the flags 1827 | DPUSH CELLSIZE 1828 | call plus 1829 | call dup 1830 | ; enable MSB 1831 | call cfetch 1832 | DPOP r8 1833 | or r8, IMM 1834 | DPUSH r8 1835 | call swap 1836 | call cstore 1837 | ret 1838 | 1839 | .colon "BREAK", break 1840 | int3 1841 | ret 1842 | 1843 | .colon "POSTPONE", postpone, IMM 1844 | ; parse input stream and find xt 1845 | call bl_ 1846 | call word_ 1847 | call dup 1848 | call cfetch 1849 | DPOP W 1850 | test W, W 1851 | jz postpone_end ; no more input 1852 | ; probably not the right thing to do 1853 | ; we should abort? don't have it yet xD 1854 | 1855 | call find 1856 | DPOP W 1857 | test W, W 1858 | 1859 | ; if not found, we should abort, don't have it yet xD 1860 | jz postpone_end 1861 | 1862 | ; if immediate, must compile code to compile a relative call !!! 1863 | 1864 | ; compile relative call 1865 | DPOP W 1866 | 1867 | ; compile a near relative call, target address is in W 1868 | call here 1869 | DPOP rdi 1870 | mov byte [rdi], 0xE8 1871 | 1872 | ; obtain a 32 bit number to work with 32 bit signed 1873 | call here 1874 | ;mov r13d, NOS 1875 | ;call drop 1876 | DPOP X 1877 | 1878 | sub r12d, r13d ; this is W as a dword 1879 | sub r12d, 5 ; additional offset from next instruction 1880 | mov [rdi+1], r12d ; this is W as (now negative) dword 1881 | 1882 | ; update here 1883 | call here 1884 | DPUSH 5 1885 | call plus 1886 | call dp 1887 | call store 1888 | ret 1889 | 1890 | postpone_end: 1891 | call drop 1892 | ret 1893 | 1894 | .colon "COMPILE@", compileat ; ( xt addr -- ) compiles a call... 1895 | ; compile relative call 1896 | DPOP rdi 1897 | DPOP W 1898 | 1899 | ; obtain a 32 bit number to work with 32 bit signed 1900 | DPUSH rdi 1901 | ;mov r13d, NOS 1902 | ;call drop 1903 | DPOP X 1904 | 1905 | sub r12d, r13d ; this is W as a dword 1906 | sub r12d, 5 ; additional offset from next instruction 1907 | 1908 | ; compile a near relative call, target address is in W 1909 | mov byte [rdi], 0xE8 1910 | mov [rdi+1], r12d ; this is W as (now negative, or not) dword 1911 | 1912 | ret 1913 | 1914 | .colon "COMPILE,", compilecomma ; ( xt -- ) compiles a call...? execute? what? 1915 | call here 1916 | call compileat 1917 | 1918 | ; update here 1919 | call here 1920 | DPUSH 5 1921 | call plus 1922 | call dp 1923 | call store 1924 | ret 1925 | 1926 | .colon "HIDE", hide, IMM 1927 | mov r8, [val_latest] 1928 | add r8, CELLSIZE 1929 | or byte [r8], SMUDGE 1930 | ret 1931 | 1932 | .colon "REVEAL", reveal, IMM 1933 | mov r8, [val_latest] 1934 | add r8, CELLSIZE 1935 | and byte [r8], 0xFF-SMUDGE ; clear SMUDGE bit 1936 | ret 1937 | 1938 | .colon ":", colon 1939 | ; make an entry at HERE 1940 | ; first store the address on LATEST at HERE 1941 | call latest 1942 | call fetch 1943 | call dp 1944 | call fetch 1945 | call store 1946 | 1947 | call dp ; store here at latest 1948 | call fetch 1949 | call dup 1950 | call latest 1951 | call store 1952 | 1953 | DPUSH CELLSIZE ; update here 1954 | call plus 1955 | call dp 1956 | call store 1957 | 1958 | ; compile a flags byte 1959 | DPUSH 0 1960 | call dp 1961 | call fetch 1962 | call cstore 1963 | ; increment dictionary pointer 1964 | DPUSH 1 1965 | call dp 1966 | call cplusstore 1967 | 1968 | call bl_ ; get the word name 1969 | ;; call word_ ; which will be on WORDBUFFER as a c-string 1970 | call word_ ; which will be on HERE as a counted string 1971 | 1972 | ;; get the length and increment dp 1973 | ;; then flags+count followed by the name 1974 | ;; call dup 1975 | ;; call cfetch 1976 | ;; DPUSH 1 1977 | ;; call plus 1978 | ;; DPOP rcx ; we will copy count+1 bytes 1979 | ;; DPOP rsi 1980 | ;; DPUSH rcx ; let's keep the size on the stack 1981 | ;; call dp 1982 | ;; call fetch 1983 | ;; DPOP rdi 1984 | ;; rep movsb 1985 | 1986 | ; update here (we left the count on the stack) 1987 | call dup 1988 | call cfetch 1989 | call plus 1990 | DPUSH 1 1991 | call plus ; add HERE to the size we kept on the stack + 1 1992 | call dp 1993 | call store 1994 | 1995 | ; hide the word 1996 | call hide 1997 | 1998 | ; finally switch to compile mode 1999 | DPUSH 1 2000 | call state 2001 | call store 2002 | 2003 | ret 2004 | 2005 | 2006 | ;; piece of code called for a CREATEd word 2007 | ;; push into datastack the address immediately after the call 2008 | ;; and return to the caller of the caller 2009 | created: 2010 | pop r8 2011 | DPUSH r8 2012 | ret 2013 | 2014 | ;; piece of code called for a compiled literal 2015 | ;; push into datastack the 64 bit number immediately after the call 2016 | ;; and return to the address after it 2017 | .colon "LIT", lit 2018 | pop r8 2019 | mov r9, [r8] 2020 | DPUSH r9 2021 | add r8, CELLSIZE 2022 | push r8 2023 | ret 2024 | 2025 | 2026 | .colon "(0branch)", zerobranch, LOCAL 2027 | pop r9 2028 | DPOP r8 2029 | test r8, r8 2030 | jz zerobranch_backward 2031 | add r9, CELLSIZE 2032 | push r9 2033 | ret 2034 | zerobranch_backward: 2035 | push qword [r9] 2036 | ret 2037 | 2038 | .colon "(branch)", branch, LOCAL 2039 | pop r9 2040 | push qword [r9] 2041 | ret 2042 | 2043 | .colon "(for)", innerfor, LOCAL 2044 | ; slide the loop counter on the stack to second on return stack 2045 | DPOP r8 2046 | pop r9 2047 | push r8 2048 | push r9 2049 | ret 2050 | 2051 | .colon "(next)", innernext, LOCAL 2052 | ; decrease the index by 1 2053 | dec qword [rsp+8] 2054 | ret 2055 | 2056 | .colon "(endfor)", endfor, LOCAL 2057 | ; remove the loop counter from second on return stack 2058 | pop r8 2059 | pop r9 2060 | push r8 2061 | ret 2062 | 2063 | .colon "(do)", innerdo, LOCAL 2064 | ;; put index and limit on the return stack 2065 | DPOP r8 2066 | DPOP r9 2067 | pop r10 2068 | push r9 2069 | push r8 2070 | push r10 2071 | ret 2072 | 2073 | .colon "(loop)", innerloop, LOCAL 2074 | ; inject a false result by default 2075 | DUP 2076 | CLR TOS 2077 | mov Y, -1 2078 | ; increase the loop counter by 1 2079 | mov W, [rsp+CELLSIZE] 2080 | add W, 1 2081 | ; write back the increment 2082 | mov qword [rsp+CELLSIZE], W 2083 | ; check if = limit 2084 | mov X, [rsp+CELLSIZE*2] 2085 | cmp W, X 2086 | ; set result if needed 2087 | cmove TOS, Y 2088 | ret 2089 | 2090 | .colon "(+loop)", innerplusloop, LOCAL 2091 | ; move TOS to r8, inject a false result by default 2092 | mov r8, TOS 2093 | CLR TOS 2094 | mov Y, -1 2095 | ; increase the loop counter by r8 (positive or negative) 2096 | mov W, [rsp+CELLSIZE] 2097 | add W, r8 2098 | ; write back the increment 2099 | mov qword [rsp+CELLSIZE], W 2100 | ; check limit, according to sign of r8 2101 | test r8, r8 2102 | js innerplusloopdown 2103 | innerplusloopup: 2104 | mov X, [rsp+CELLSIZE*2] 2105 | cmp W, X 2106 | cmovge TOS, Y ; set result if needed 2107 | jmp innerplusloopdone 2108 | innerplusloopdown: 2109 | mov X, [rsp+CELLSIZE*2] 2110 | cmp W, X 2111 | cmovle TOS, Y ; set result if needed 2112 | innerplusloopdone: 2113 | mov X, [rsp+CELLSIZE*2] 2114 | ret 2115 | 2116 | .colon "(enddo)", enddo, LOCAL 2117 | ; remove the loop data from return stack 2118 | pop r8 2119 | pop r9 2120 | pop r9 2121 | push r8 2122 | ret 2123 | 2124 | 2125 | .colon "I", i 2126 | mov r8, [rsp+CELLSIZE] 2127 | DPUSH r8 2128 | ret 2129 | 2130 | .colon "J", j 2131 | mov r8, [rsp+CELLSIZE*3] 2132 | DPUSH r8 2133 | ret 2134 | 2135 | .colon "(limit)", dolimit, LOCAL 2136 | mov r8, [rsp+CELLSIZE*2] 2137 | DPUSH r8 2138 | ret 2139 | 2140 | 2141 | 2142 | 2143 | ;; allocation: 2144 | 2145 | ;; just allocate 8 extra bytes, stick the length in the beginning, 2146 | ;; return the pointer after the length to the user 2147 | 2148 | ;; freeing: 2149 | ;; subtract 8 bytes from the address, get the length from there 2150 | 2151 | ;; resizing: 2152 | ;; subtract 8 bytes from the address, store the new length there 2153 | 2154 | ;; dynamic memory - mmap() allocates 4Kb pages (so it should always be aligned...?) 2155 | 2156 | ;; test this ??? 2157 | 2158 | .colon "ALLOCATE", allocate ; ( u -- addr ior ) 2159 | ; off fd flags prot len address 9 SYSCALL/6 2160 | DPOP W ; save the length in W 2161 | add W, CELLSIZE 2162 | DPUSH 0 2163 | DPUSH -1 ; -1 for compatibility 2164 | DPUSH MMAP_FLAGS 2165 | DPUSH MMAP_PROTECTION 2166 | DPUSH W 2167 | DPUSH 0 2168 | DPUSH 9 ; mmap 2169 | call colonsyscall6 2170 | 2171 | ; if TOS is -1, return ( invalid-addr -1 ) straight ahead 2172 | call dup 2173 | test TOS, TOS 2174 | js allocate_end 2175 | 2176 | ; otherwise store the length at the address, then increment 2177 | ; address by CELLSIZE 2178 | mov r8, NOS 2179 | mov [r8], W 2180 | add r8, CELLSIZE 2181 | mov NOS, r8 2182 | ; and replace TOS with a 0 2183 | CLR TOS 2184 | allocate_end: 2185 | ret 2186 | 2187 | .colon "FREE", free ; ( addr -- ior ) 2188 | ; len address 11 SYSCALL/2 2189 | sub TOS, CELLSIZE 2190 | mov r9, [TOS] 2191 | DPUSH r9 2192 | call swap 2193 | DPUSH 11 ; munmap 2194 | call colonsyscall2 2195 | ret 2196 | 2197 | .colon "RESIZE", resize ; ( addr u -- addr' ior ) 2198 | ; new_addr flags new_len old_len addr 25 syscall/5 2199 | DPOP W ; length 2200 | DPOP X ; address 2201 | DPUSH 0 2202 | DPUSH 0 ; or maybe MREMAP_MAYMOVE? 2203 | add W, CELLSIZE ; account for storing the size 2204 | DPUSH W ; new length 2205 | sub X, CELLSIZE 2206 | mov r9, [X] 2207 | DPUSH r9 ; old length 2208 | DPUSH X ; address 2209 | DPUSH 25 ; mremap 2210 | call colonsyscall5 2211 | 2212 | ; if TOS is -1, return ( invalid-addr -1 ) straight ahead 2213 | call dup 2214 | test TOS, TOS 2215 | js resize_end 2216 | 2217 | ; otherwise store the length at the address, then increment 2218 | ; address by CELLSIZE 2219 | mov r8, NOS 2220 | mov [r8], W 2221 | add r8, CELLSIZE 2222 | mov NOS, r8 2223 | ; and replace TOS with a 0 2224 | CLR TOS 2225 | resize_end: 2226 | ret 2227 | 2228 | .colon "CMOVE", cmove ; ( addr1 addr2 u -- ) 2229 | DPOP rcx 2230 | DPOP rdi 2231 | DPOP rsi 2232 | test rcx, rcx 2233 | jz cmove_end 2234 | rep movsb 2235 | cmove_end: 2236 | ret 2237 | 2238 | align 4 ; but why.... :-/ 2239 | .colon "CMOVE>", cmovefw ; ( addr1 addr2 u -- ) 2240 | DPOP rcx 2241 | DPOP rdi 2242 | add rdi, rcx 2243 | dec rdi 2244 | DPOP rsi 2245 | add rsi, rcx 2246 | dec rsi 2247 | test rcx, rcx 2248 | jz cmovefw_end 2249 | std 2250 | rep movsb 2251 | cld 2252 | cmovefw_end: 2253 | ret 2254 | 2255 | ;; this is supposed to NOT propagate when addresses overlap 2256 | .colon "MOVE", move ; ( addr1 addr2 u -- ) 2257 | DPOP rcx 2258 | DPOP rdi 2259 | DPOP rsi 2260 | test rcx, rcx 2261 | jz move_end 2262 | rep movsq 2263 | move_end: 2264 | ret 2265 | 2266 | .colon "FILL", fill ; ( addr u c -- ) 2267 | DPOP rax 2268 | DPOP rcx 2269 | DPOP rdi 2270 | test rcx, rcx 2271 | jz fill_end 2272 | rep stosb 2273 | fill_end: 2274 | ret 2275 | 2276 | .colon "ERASE", erase ; ( addr u -- ) 2277 | DPUSH 0 2278 | call fill 2279 | ret 2280 | 2281 | .colon "BLANK", blank ; ( addr u -- ) 2282 | DPUSH 32 2283 | call fill 2284 | ret 2285 | 2286 | filenamestr: 2287 | resb 4096 2288 | 2289 | ;; ( c-addr u fam -- fileid ior ) 2290 | .colon "OPEN-FILE", openfile 2291 | call minusrot ; ( fam c-addr u ) 2292 | 2293 | ;; clear filenamestr with zeros ( C-string compatibility ) 2294 | DPUSH filenamestr 2295 | DPUSH 4096 2296 | DPUSH 0 2297 | call fill 2298 | 2299 | DPUSH filenamestr 2300 | call swap ; ( fam c-addr fstr u ) 2301 | call cmove ; ( fam ) ; flags 2302 | 2303 | DPUSH 0 ; permissions, apparently 2304 | call swap 2305 | DPUSH filenamestr ; C-filename pointer 2306 | DPUSH 2 2307 | call colonsyscall3 2308 | ;; must return ior 2309 | call dup 2310 | DPUSH 0 2311 | call lesserthan 2312 | ret 2313 | 2314 | ;; ( fileid -- ior ) 2315 | .colon "CLOSE-FILE", closefile 2316 | DPUSH 3 ; close(fd) 2317 | call colonsyscall1 2318 | ret 2319 | 2320 | ;; ( addr n -- ) 2321 | .colon "INCLUDED", included 2322 | ; save input specification directly to rstack 2323 | push qword 4 ; shouldn't this be the top value...? 2324 | ; it's never used anyway... 2325 | ; the regular mechanism uses 2326 | ; the data stack 2327 | push qword [val_sourceid] 2328 | push qword [val_TOIN] 2329 | push qword [val_sourcelen] 2330 | push qword [val_sourceaddr] 2331 | 2332 | ; open the file read only 2333 | DPUSH 0 2334 | call openfile 2335 | 2336 | ; give notice if it doesn't exist 2337 | DPOP r8 ; (-x if error) 2338 | test r8, r8 2339 | jns included_file_exists 2340 | 2341 | DPUSH notFoundMsgStr 2342 | DPUSH notFoundMsgLen 2343 | call type 2344 | jmp included_restore_input 2345 | 2346 | included_file_exists: 2347 | ; store the source-id 2348 | DPOP r8 2349 | mov [val_sourceid], r8 2350 | 2351 | ; make the file the input source 2352 | mov qword [val_sourcelen], BUFFERSIZE 2353 | DPUSH BUFFERSIZE 2354 | call allocate 2355 | DPOP r8 ; ignoring the errors again \o/ 2356 | DPOP r8 2357 | mov [val_sourceaddr], r8 2358 | 2359 | ; store a 0 in BLK 2360 | mov qword [val_blk], 0 2361 | 2362 | ; repeat until eof: read line, set >in to 0, interpret 2363 | included_next_line: 2364 | call refill 2365 | DPOP r8 2366 | test r8, r8 2367 | jz included_done 2368 | 2369 | mov qword [val_TOIN], 0 2370 | call interpret 2371 | jmp included_next_line 2372 | 2373 | included_done: 2374 | call drop ; not sure why.... 2375 | ; free buffer 2376 | mov r8, [val_sourceaddr] 2377 | DPUSH r8 2378 | call free 2379 | DPOP r8 ; and more error ignoring 2380 | 2381 | ; close file 2382 | mov r8, [val_sourceid] 2383 | DPUSH r8 2384 | call closefile 2385 | DPOP r8 ; and yet some more 2386 | 2387 | included_restore_input: 2388 | ; restore input specification 2389 | pop qword [val_sourceaddr] 2390 | pop qword [val_sourcelen] 2391 | pop qword [val_TOIN] 2392 | pop qword [val_sourceid] 2393 | pop qword r8 ; final error ignoring 2394 | 2395 | ret 2396 | 2397 | ;; perform various initialization stuff 2398 | .colon "ABORT", abort 2399 | call warm 2400 | jmp quit 2401 | ret 2402 | 2403 | ; last builtin word, for now, this is important because init uses this 2404 | ; word to set up LATEST 2405 | .colon "CREATE", create 2406 | ; make an entry at HERE 2407 | ; first store the address on LATEST at HERE 2408 | call latest 2409 | call fetch 2410 | call dp 2411 | call fetch 2412 | call store 2413 | 2414 | call dp ; store here at latest 2415 | call fetch 2416 | call dup 2417 | call latest 2418 | call store 2419 | 2420 | DPUSH CELLSIZE ; update here 2421 | call plus 2422 | call dp 2423 | call store 2424 | 2425 | ; compile a flags byte 2426 | DPUSH 0 2427 | call dp 2428 | call fetch 2429 | call cstore 2430 | ; increment dictionary pointer 2431 | DPUSH 1 2432 | call dp 2433 | call cplusstore 2434 | 2435 | call bl_ ; get the word name 2436 | call word_ ; which will be on WORDBUFFER as a c-string 2437 | 2438 | ; update here (we left the address on the stack) 2439 | call dup 2440 | call cfetch 2441 | call plus ; add HERE to the size we kept on the stack 2442 | DPUSH 1 2443 | call plus 2444 | call dp 2445 | call store 2446 | 2447 | ; compile a near relative call, target address is in W 2448 | mov W, created 2449 | call dp 2450 | call fetch 2451 | DPOP rdi 2452 | mov byte [rdi], 0xE8 2453 | 2454 | ; obtain a 32 bit number to work with 32 bit signed 2455 | call dp 2456 | call fetch 2457 | ;mov r13d, NOS 2458 | ;call drop 2459 | DPOP X 2460 | 2461 | sub r12d, r13d ; this is W as a dword 2462 | sub r12d, 5 ; additional offset from next instruction 2463 | mov [rdi+1], r12d ; this is W as (now negative) dword 2464 | 2465 | ; update here 2466 | call dp 2467 | call fetch 2468 | DPUSH 5 2469 | call plus 2470 | call dp 2471 | call store 2472 | 2473 | ret 2474 | 2475 | end_of_builtins: 2476 | ;; should I add a blob of uninitialised (or initialised) space here? 2477 | 2478 | resb 65536*4 2479 | end_of_dictionary: 2480 | 2481 | ;; the program code here 2482 | SECTION .text 2483 | ;align 4 2484 | 2485 | global _start 2486 | 2487 | warm: 2488 | ; clear the buffers 2489 | mov rdi, PADDATA 2490 | mov rcx, BUFFERSIZE 2491 | mov al, ' ' 2492 | rep stosb 2493 | 2494 | mov rdi, TIBDATA 2495 | mov rcx, BUFFERSIZE 2496 | mov al, ' ' 2497 | rep stosb 2498 | 2499 | ; reset the stacks 2500 | mov rdi, DATASTACK 2501 | mov rcx, CELLSIZE*STACKSIZE 2502 | mov al, 0 2503 | rep stosb 2504 | 2505 | mov PSP, DATASTACKBOTTOM 2506 | CLR TOS 2507 | 2508 | ; should reset return stack here 2509 | pop r8 2510 | mov qword rsp, qword [RETURNSTACKBOTTOM] 2511 | push r8 2512 | 2513 | ; reset STATE to interpret 2514 | mov qword [val_state], 0 2515 | 2516 | ret 2517 | 2518 | init: 2519 | mov r8, rsp 2520 | sub r8, CELLSIZE 2521 | mov qword [RETURNSTACKBOTTOM], r8 2522 | call warm 2523 | mov rsi, val_dp 2524 | mov qword [rsi], end_of_builtins 2525 | mov rsi, val_latest 2526 | mov qword [rsi], create_entry ; THIS HAS TO BE MANUALLY UPDATED...(!) 2527 | ret 2528 | 2529 | loadbootfs: 2530 | DPUSH bootfsStr 2531 | DPUSH bootfsLen 2532 | mov qword [val__promptbool], 0 2533 | call included 2534 | mov qword [val__promptbool], 1 2535 | call quit_prompt 2536 | ret 2537 | 2538 | 2539 | ;; --- more code --- 2540 | 2541 | ;; function things 2542 | hello: 2543 | DPUSH helloStr 2544 | DPUSH helloLen 2545 | call type 2546 | ret 2547 | 2548 | ;; Inner interpreter stuff 2549 | ;; do we even have one? :-/ 2550 | ;; answer is nope, with the magic of STC 2551 | 2552 | ;;;; THIS IS THE ENTRY POINT 2553 | _start: 2554 | call init 2555 | call hello 2556 | call loadbootfs 2557 | call quit 2558 | jmp coda 2559 | 2560 | 2561 | ;;;; THIS IS THE EXIT POINT 2562 | coda: 2563 | call bye 2564 | --------------------------------------------------------------------------------