├── .gitattributes ├── Fifth.exe ├── FifthCoverPages.pdf ├── FifthTutorial.pdf ├── Fifth_sw.exe ├── Forth83.exe ├── README.md ├── Window.fiv ├── asm.fiv ├── assign.fiv ├── bld.fiv ├── cond.fiv ├── dump.fiv ├── fifth.hlp ├── forth83.fiv ├── frac.fiv ├── mandel.fiv ├── names.fiv ├── queens.fiv ├── sieve.fiv ├── t.exe ├── t.fiv ├── text.fiv ├── time.fiv ├── towers.fiv └── unws.fiv /.gitattributes: -------------------------------------------------------------------------------- 1 | *.fiv linguist-language=Forth 2 | -------------------------------------------------------------------------------- /Fifth.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/Fifth.exe -------------------------------------------------------------------------------- /FifthCoverPages.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/FifthCoverPages.pdf -------------------------------------------------------------------------------- /FifthTutorial.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/FifthTutorial.pdf -------------------------------------------------------------------------------- /Fifth_sw.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/Fifth_sw.exe -------------------------------------------------------------------------------- /Forth83.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/Forth83.exe -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Fifth 2 | ===== 3 | 4 | Not just Fifth... Professional Fifth! 5 | 6 | Cliff Click and I designed and built Fifth while in graduate school. 7 | Fifth is a complete programming environment that is somewhat close to 8 | but not quite a 32 bit Forth. Fifth was written for 8086/8087 based IBM 9 | compatiable PCs. We later rewrote Fifth from the ground up for 68000 based embedded systems. 10 | The 68000 version was written in order to implement the first PostScript clone to Ship in a comerical Printer. 11 | (Printware's 720, in December of 1987) 12 | 13 | The 68000 version was really fun, but almost certainly lost to the sands of time. 14 | 15 | Fifth works very much like Forth, but provides this 16 | really cool if terribly simple character graphics based UI. Memory is 17 | managed using a heap instead of Forth's stack based memory management, 18 | and the scoping is tree based rather than linear as in Forth. Much of that 19 | won't mean much to you if you don't know Forth, and mostly won't matter 20 | much if you do. 21 | 22 | Features include: 23 | 24 | * Exports stand-alone executables. 25 | * Selective Trace of Words 26 | * Snapshot (let's you add your stuff to the environment) 27 | * Help (written in Fifth) 28 | * Floating point support (using a separate floating point stack) 29 | * VGA Graphics operators 30 | * Lazy compilation (Words are compiled if you try to execute something that isn't compiled yet) 31 | * Operators for selecting words and forcing them to compile 32 | * Indirect addresses for Fifth execution 33 | * Direct address support for playing with hardware (Don't have any idea what this will do under DosBox!) 34 | * All the normal Forth weirdness 35 | 36 | Anyway, for a number of years I couldn't put my hands on a copy of the 37 | full Fifth environment. This has really bothered me over the last few 38 | years, but not enough to mount all the old hard drives I have collected... 39 | (Hint: I have lots of old hard drives! "Toss the computer, keep the hard drive" 40 | -- the motto I live by!) 41 | 42 | Looked first on the web, and found a number of Shareware versions. Shareware... 43 | Yes, you heard that right. Fifth predates Open Source by a few years. 44 | 45 | But now, looking on my own drives, I have found a copy of the full version! And I 46 | hereby release Fifth to the world! 47 | 48 | I'd like to say I am releasing Fifth as open source, but I can't because 49 | I doubt the source exists any more. If it does, it is on some even older 50 | drives and/or floppies that I haven't looked at yet. But all 51 | the various Fifth programs that were distributed with Fifth are here. And 52 | I welcome the world to add to the Library of Open Sourced Fifth programs! 53 | 54 | ((It would be really cool if I could find the old version of Postscript begun 55 | on PC Fifth, but that is almost surly lost to history.)) 56 | 57 | Fifth runs just fine in DosBox, which provides an old style MS-DOS environment 58 | on nearly all hardware so you can run those old MS-DOS based games! 59 | 60 | You can find DosBox here: http://www.dosbox.com/ 61 | 62 | Feel free to download Professional Fifth, and freely redistribute as you see fit! 63 | 64 | And if anyone wants to contribute new Fifth programs, feel free to contact 65 | me and I will make you a contributor! 66 | 67 | snow.paul@gmail.com 68 | 69 | -------------------------------------------------------------------------------- /Window.fiv: -------------------------------------------------------------------------------- 1 | WINDOW 2 | !00000017 3 | : window windowdemo ; 4 | -*- 5 | v 6 | SCROLL 7 | !0000014D 8 | : scroll 9 | 0 0 \ es:ds si:di 10 | 4 pick 8 shl \ dh 11 | 6 pick + 8 shl \ dl 12 | 7 pick + 8 shl \ ch 13 | 8 pick + \ cl 14 | 4 pick 16 shl \ bh bl->0 15 | 4 pick 0< if 7 + 8 shl 4 pick negate + 16 | else 6 + 8 shl 4 pick + endif 17 | 16 int 18 | drop drop drop drop drop 19 | drop drop drop drop drop drop 20 | ; 21 | -*- 22 | > 23 | W1COLOR 24 | !00000015 25 | 31 constant w1color 26 | -*- 27 | > 28 | W2COLOR 29 | !00000015 30 | 79 constant w2color 31 | -*- 32 | > 33 | W3COLOR 34 | !00000016 35 | 121 constant w3color 36 | -*- 37 | > 38 | W1SCRL 39 | !0000002B 40 | : w1scrl 41 | 1 1 38 10 w1color 1 scroll 42 | ; 43 | -*- 44 | > 45 | W2SCRL 46 | !0000002D 47 | : w2scrl 48 | 41 1 78 10 w2color 1 scroll 49 | ; 50 | -*- 51 | > 52 | W3SCRL 53 | !0000002E 54 | : w3scrl 55 | 1 13 78 22 w3color -1 scroll 56 | ; 57 | -*- 58 | > 59 | WINDOWS 60 | !00000067 61 | : windows 62 | 0 0 39 11 w1color 0 wbox 63 | 40 0 79 11 w2color 0 wbox 64 | 0 12 79 23 w3color 0 wbox 65 | ; 66 | -*- 67 | v 68 | ULCORN 69 | !00000015 70 | 201 constant ulcorn 71 | -*- 72 | > 73 | URCORN 74 | !00000015 75 | 187 constant urcorn 76 | -*- 77 | > 78 | LLCORN 79 | !00000015 80 | 200 constant llcorn 81 | -*- 82 | > 83 | LRCORN 84 | !00000015 85 | 188 constant lrcorn 86 | -*- 87 | > 88 | HSIDE 89 | !00000014 90 | 205 constant hside 91 | -*- 92 | > 93 | VSIDE 94 | !00000014 95 | 186 constant vside 96 | -*- 97 | > 98 | WBOX 99 | !00000197 100 | : wbox 101 | 5 pick 5 pick 5 pick 5 pick 5 pick 0 scroll 102 | 5 pick 5 pick gotoxy ulcorn emit 103 | 3 pick 6 pick - 1- 0 do hside emit loop 104 | urcorn emit 105 | 2 pick 5 pick - 1- 5 pick + 1+ 5 pick 1+ 106 | do 107 | 5 pick i gotoxy vside emit 108 | 3 pick i gotoxy vside emit 109 | loop 110 | 5 pick 3 pick gotoxy llcorn emit 111 | 3 pick 6 pick - 1- 0 do hside emit loop 112 | lrcorn emit 113 | drop drop drop drop drop drop 114 | ; 115 | -*- 116 | ^ 117 | > 118 | SAVEAREA 119 | !0000001C 120 | create savearea 4000 allot 121 | -*- 122 | > 123 | SAVEIT 124 | !0000002A 125 | : saveit 126 | screen savearea 4000 move 127 | ; 128 | -*- 129 | > 130 | RESTOREIT 131 | !0000002D 132 | : restoreit 133 | savearea screen 4000 move 134 | ; 135 | -*- 136 | > 137 | WINDOWDEMO 138 | !000001B4 139 | : windowdemo 140 | saveit 141 | windows 142 | 100 0 do 143 | 1 10 gotoxy 144 | ." Line " i . 145 | ." This window is window 1" 146 | w1scrl 147 | 41 10 gotoxy 148 | ." Line " i . 149 | ." This window is window 2" 150 | w2scrl 151 | 1 13 gotoxy 152 | ." Line " i . 153 | ." This is window 3 this is window 3 this is window 3 this is window 3" 154 | w3scrl 155 | ?term if restoreit 0 23 gotoxy abort endif 156 | loop 157 | restoreit 158 | 0 23 gotoxy abort 159 | ; 160 | -*- 161 | ^ 162 | -------------------------------------------------------------------------------- /asm.fiv: -------------------------------------------------------------------------------- 1 | ASM[ 2 | !000001E2 3 | \ FORTH 8088/8087 ASSEMBLER PHIL KOOPMAN JR. LAST UPDATE: 9/2/86 4 | \ 5 | \ (C) COPYRIGHT 1986 BY PHIL KOOPMAN JR. 6 | \ Modifed 2/5/87 by CLICK Software to run under Fifth 2.5 7 | \ 8 | \ The contents of this file are released without restrictions. 9 | \ Acknowledgement of its use would be appreciated. 10 | : asm[ 11 | [compile] here-be-stuff \ Setup the package 12 | [compile] [ \ Turn compiler off 13 | reset \ Reset, ready assembler 14 | ; immediate 15 | -*- 16 | v 17 | HEX 18 | !00000013 19 | : hex 16 base ! ; 20 | -*- 21 | > 22 | XX@ 23 | !0000001B 24 | ( ADDR -> N ) 25 | : xx@ w@ ; 26 | -*- 27 | > 28 | XX! 29 | !0000001B 30 | ( N ADDR -> ) 31 | : xx! w! ; 32 | -*- 33 | > 34 | XXC@ 35 | !0000001C 36 | ( ADDR -> B ) 37 | : xxc@ c@ ; 38 | -*- 39 | > 40 | XXC! 41 | !0000001C 42 | ( B ADDR -> ) 43 | : XXC! c! ; 44 | -*- 45 | > 46 | XX+! 47 | !00000033 48 | ( N ADDR -> ) 49 | : XX+! stack ab|bab w@ + swap w! ; 50 | -*- 51 | > 52 | XXHERE 53 | !00000013 54 | : XXHERE here ; 55 | -*- 56 | > 57 | XXALLOT 58 | !00000022 59 | : XXALLOT ( N -> ) 60 | allot 61 | ; 62 | -*- 63 | > 64 | XXC, 65 | !0000001C 66 | : XXC, ( B -> ) 67 | c, 68 | ; 69 | -*- 70 | > 71 | XX, 72 | !0000001B 73 | : XX, ( N -> ) 74 | w, 75 | ; 76 | -*- 77 | > 78 | ERROR-CHECK 79 | !000001B2 80 | \ ERROR CHECKING ASSISTANCE -- COMPILE CALL TO RUN-TIME CHECK 81 | \ #IN = max # stack parameters expected for input 82 | \ #OUT = max # stack parameters expected for output 83 | \ Comment out to remove 84 | : ERROR-CHECK ( #IN #OUT -> ) 85 | compile check \ Compile a call to CHECK 86 | OVER - 0 MAX 2 shl XXC, \ # Bytes stack growth for output 87 | 2 shl XXC, \ # Bytes needed on stack for input 88 | ; immediate 89 | -*- 90 | v 91 | CHECK 92 | !00000148 93 | \ Check the stack for proper balance 94 | \ Remove stack growth needed & desired from return address 95 | : check 96 | r> \ Get return address 97 | dup c@@ drop \ Get stack growth needed 98 | 1+ dup c@@ drop \ Get bytes needed for input 99 | 1+ >r \ Push modified return address back, exit 100 | ; 101 | -*- 102 | ^ 103 | > 104 | STATUS-WORD 105 | !00000052 106 | ( ASSEMBLER VARIABLES ) 107 | VARIABLE STATUS-WORD \ SOURCE & DEST OPERAND TYPES 108 | -*- 109 | > 110 | SOURCE-REG 111 | !0000002F 112 | VARIABLE SOURCE-REG \ SOURCE REG NUMBER 113 | -*- 114 | > 115 | DEST-REG 116 | !0000002D 117 | VARIABLE DEST-REG \ DEST REG NUMBER 118 | -*- 119 | > 120 | SOURCE-VALUE 121 | !0000003B 122 | VARIABLE SOURCE-VALUE \ IMMEDIATE/DIRECT/OFFSET VALUE 123 | -*- 124 | > 125 | DEST-VALUE 126 | !0000003B 127 | VARIABLE DEST-VALUE \ IMMEDIATE/DIRECT/OFFSET VALUE 128 | -*- 129 | > 130 | AUX-VALUE 131 | !00000034 132 | VARIABLE AUX-VALUE \ USED FOR FAR ADDRESSES 133 | -*- 134 | > 135 | LENGTH-WORD 136 | !00000041 137 | VARIABLE LENGTH-WORD \ FLAG BITS TO DETERMINE OPERAND TYPE 138 | -*- 139 | > 140 | OLD-DEPTH 141 | !00000035 142 | VARIABLE OLD-DEPTH \ DATA STACK POINTER SAVE 143 | -*- 144 | > 145 | ILLEGAL-OPS? 146 | !00000038 147 | ( FLAG -> ) 148 | : ILLEGAL-OPS? ABORT" ILLEGAL OPERANDS" ; 149 | -*- 150 | > 151 | ILLEGAL-OPS 152 | !00000039 153 | ( -> ) ( FORCE ERROR ) 154 | : ILLEGAL-OPS 1 ILLEGAL-OPS? ; 155 | -*- 156 | > 157 | UPDATE-FLAGS 158 | !00000082 159 | : UPDATE-FLAGS ( LENGTH-BITS STATUS-BITS -> ) 160 | STATUS-WORD W@ OR STATUS-WORD W! 161 | LENGTH-WORD W@ OR LENGTH-WORD W! ; 162 | -*- 163 | > 164 | PARAMS? 165 | !00000079 166 | : PARAMS? ( -> #PARAMS ) ( TRUE IF IMMED/DIR PARAM ON STACK ) 167 | DEPTH OLD-DEPTH w@ - 168 | DUP 0< ILLEGAL-OPS? ; 169 | -*- 170 | > 171 | DISP8, 172 | !00000035 173 | ( JMPADDR -> ) 174 | : DISP8, XXHERE 1+ - XXC, ; 175 | -*- 176 | > 177 | DISP16, 178 | !00000032 179 | ( JMPADDR -> ) 180 | : DISP16, XXHERE 2+ - XX, ; 181 | -*- 182 | > 183 | ?W 184 | !0000005E 185 | hex 186 | : ?W ( -> W=0/1 ) 187 | LENGTH-WORD w@ DUP 0FC AND ILLEGAL-OPS? 188 | 2 = 1 and ; 189 | -*- 190 | > 191 | BYTESWAP 192 | !0000009D 193 | hex 194 | : BYTESWAP [ 195 | 1 1 ERROR-CHECK 196 | 8B C, 46 C, 00 C, \ AX , 0 [BP] MOV 197 | 86 C, E0 C, \ AH , AL XCHG 198 | 89 C, 46 C, 00 C, \ 0 [BP] , AX MOV 199 | ] ; 200 | -*- 201 | > 202 | STATUS-LOW 203 | !0000004F 204 | HEX 205 | : STATUS-LOW ( -> LOW.STATUS.BYTE.0->FF ) 206 | STATUS-WORD w@ 0FF AND ; 207 | -*- 208 | > 209 | STATUS-HIGH 210 | !00000058 211 | hex 212 | : STATUS-HIGH ( -> HIGH.STATUS.BYTE.0000->FF00 ) 213 | STATUS-WORD w@ 0FF00 AND ; 214 | -*- 215 | > 216 | ?D 217 | !000001AD 218 | ( ?D ?REG ) 219 | HEX 220 | : ?D ( -> D=0/1 ) ( 0=SOURCE IS REG/ 1= DEST IS REG ) 221 | STATUS-LOW 10 AND IF ( DEST IS SEG REG ) 1 ELSE 222 | STATUS-HIGH 1000 AND IF ( SOURCE IS SEG REG ) 0 ELSE 223 | STATUS-HIGH 0400 AND IF ( SOURCE IS IMMEDIATE ) 0 ELSE 224 | STATUS-LOW 80 AND IF ( DEST IS REG ) 1 ELSE 225 | STATUS-HIGH 8000 AND IF ( SOURCE IS REG ) 0 ELSE 226 | 1 endif endif endif endif endif ; 227 | -*- 228 | > 229 | ?REG 230 | !0000004F 231 | : ?REG ( -> REG-VALUE ) 232 | ?D IF DEST-REG ELSE SOURCE-REG endif w@ ; 233 | -*- 234 | > 235 | ?FD 236 | !000000AF 237 | HEX 238 | : ?FD ( -> D=0/1 ) ( 0=DEST IS ST[0] / 1= SOURCE IS ST[0] ) 239 | STATUS-LOW 08 AND IF DEST-REG w@ 0= 240 | IF ( DEST IS ST[0] ) 0 ELSE 1 endif 241 | ELSE 1 endif ; 242 | -*- 243 | > 244 | ?FREG 245 | !00000079 246 | : ?FREG ( -> REG# ) 247 | SOURCE-REG w@ 0= NOT DEST-REG w@ 0= NOT AND ILLEGAL-OPS? 248 | SOURCE-REG w@ DEST-REG w@ OR ; 249 | -*- 250 | > 251 | 252 | !00000227 253 | HEX 254 | : ( STATUS-BYTE -> MODXXR/M ) 255 | DUP 80 AND IF ( REGISTER ) DROP 0C0 256 | ?D IF SOURCE-REG ELSE DEST-REG endif w@ OR 257 | ELSE DUP 60 AND 20 = 258 | IF ( DIRECT ) DROP 06 259 | ELSE DUP 40 AND 0= ILLEGAL-OPS? 260 | ( INDIRECT ) ?D IF SOURCE-REG w@ SOURCE-VALUE w@ 261 | ELSE DEST-REG w@ DEST-VALUE w@ endif 262 | stack abc|bca 20 AND 263 | IF FF80 AND DUP 0= SWAP FF80 = OR 264 | IF ( 8-BIT ) 40 OR ELSE ( 16-BIT ) 80 OR endif 265 | ELSE DROP endif 266 | endif endif ; 267 | -*- 268 | > 269 | ?MOD-R/M2 270 | !0000007D 271 | HEX 272 | : ?MOD-R/M2 ( -> MODXXXR/M ) ( FOR 2 OPERAND CASE ) 273 | STATUS-WORD w@ ?D IF BYTESWAP endif 0FF AND ; 274 | -*- 275 | > 276 | ?MOD-R/M1 277 | !0000007A 278 | : ?MOD-R/M1 ( -> MODXXXR/M ) ( FOR 1 OPERAND CASE ) 279 | SOURCE-REG w@ DEST-REG w! STATUS-HIGH BYTESWAP ; 280 | -*- 281 | > 282 | ?MOD-R/M2-REG 283 | !00000076 284 | : ?MOD-R/M2-REG ( -> MODXXXR/M ) ( 2 OPERANDS, BUT USE REG ) 285 | DEST-REG w@ SOURCE-REG w! STATUS-LOW ; 286 | -*- 287 | > 288 | ?OFFSET, 289 | !00000190 290 | ( ?OFFSET, DATA, ) 291 | HEX 292 | : ?OFFSET, ( -> ) 293 | ( COMMA'S OFFSET ONLY IF NEEDED IN ASSEMBLED FORMAT ) 294 | STATUS-WORD w@ 2020 AND DUP 2020 = ILLEGAL-OPS? 295 | ?DUP IF ( OFFSET INFORMATION APPLICABLE ) 296 | 20 AND IF DEST-VALUE w@ ELSE SOURCE-VALUE w@ endif 297 | STATUS-WORD w@ 4040 AND IF DUP FF80 AND DUP FF80 = SWAP 0= 298 | OR IF XXC, ELSE XX, endif ELSE XX, endif endif ; 299 | -*- 300 | > 301 | DATA, 302 | !0000009F 303 | hex 304 | : DATA, ( N -> ) 305 | ( COMMA 1 OR 2 BYTES ACCORDING TO W ) 306 | ?W IF XX, 307 | ELSE DUP FF00 AND ( TOO LONG? ) ILLEGAL-OPS? 308 | XXC, endif ; 309 | -*- 310 | > 311 | ?Q 312 | !000000C2 313 | HEX 314 | : ?Q ( -> 0/1 ) ( 0=TO ACCUM/1= FROM ACCUM ) 315 | STATUS-LOW 80 = DEST-REG w@ 0= AND 316 | IF 0 317 | ELSE STATUS-HIGH 8000 = 318 | SOURCE-REG w@ 0= AND 0= ILLEGAL-OPS? 1 endif ; 319 | -*- 320 | > 321 | ?V 322 | !000000CE 323 | hex 324 | : ?V ( -> 0=SHIFT COUNT 1/1=SHIFT COUNT CX ) 325 | STATUS-HIGH 8000 = SOURCE-REG w@ 1 = AND 326 | IF 1 327 | ELSE STATUS-HIGH 2000 = SOURCE-VALUE w@ 1 = AND 328 | 0= ILLEGAL-OPS? 0 endif ; 329 | -*- 330 | > 331 | ?MF 332 | !000000F1 333 | ( ?MF ?DF ) 334 | HEX 335 | : ?MF ( -> TYPE-OF-OPERANDS ) 336 | LENGTH-WORD w@ DUP 10 = 337 | IF DROP 0 338 | ELSE DUP 4 = IF DROP 1 339 | ELSE DUP 20 = IF DROP 2 340 | ELSE 2 = IF 3 341 | ELSE ILLEGAL-OPS endif endif endif endif ; 342 | -*- 343 | > 344 | ?DF 345 | !0000007A 346 | : ?DF ( -> 0=DEST ST/1=DEST STi ) 347 | STATUS-WORD w@ 808 AND 0= ILLEGAL-OPS? 348 | STATUS-WORD w@ 8 AND NOT ; 349 | -*- 350 | > 351 | # 352 | !00000058 353 | ( # GET-STACK-PARAMS ) 354 | ( -> ) 355 | HEX : # STATUS-WORD w@ 400 OR STATUS-WORD w! ; 356 | -*- 357 | > 358 | GET-STACK-PARAMS 359 | !00000121 360 | hex 361 | : GET-STACK-PARAMS ( N? -> ) 362 | PARAMS? 363 | IF SOURCE-VALUE w! 364 | STATUS-WORD w@ 400 AND 0= 365 | IF 2000 STATUS-WORD w@ OR STATUS-WORD w! endif endif 366 | PARAMS? 367 | IF AUX-VALUE w! 368 | STATUS-WORD w@ 200 OR STATUS-WORD w! endif 369 | PARAMS? ILLEGAL-OPS? ; 370 | -*- 371 | > 372 | RESET 373 | !000000E6 374 | ( RESET CHECK-LENGTH ) 375 | HEX 376 | : RESET ( -> ) ( RESET ASSEMBLER AFTER EVERY WORD ) 377 | 0 LENGTH-WORD w! 0 STATUS-WORD w! 378 | 0 SOURCE-VALUE w! 0 DEST-VALUE w! 379 | 0 SOURCE-REG w! 0 DEST-REG w! DEPTH OLD-DEPTH w! ; 380 | -*- 381 | > 382 | LENGTH-DATA 383 | !0000007F 384 | CREATE LENGTH-DATA hex 385 | 1 w, 2 w, 4 w, 8 w, 10 w, 20 w, 40 w, 80 w, 386 | 100 w, 200 w, 400 w, 800 w, 2000 w, 5000 w, 387 | -*- 388 | > 389 | CHECK-LENGTH 390 | !000000B2 391 | hex 392 | : CHECK-LENGTH ( -> ) 393 | 0 394 | 1C 0 DO I LENGTH-DATA + w@ 395 | LENGTH-WORD w@ AND 0= NOT negate + 2 +LOOP 396 | 1 = NOT ABORT" MISMATCHED OPERAND LENGTHS" ; 397 | -*- 398 | > 399 | SREG 400 | !000000D8 401 | ( SREG ) 402 | HEX 403 | : SREG ( -> ) 404 | CREATE C, ( REG# ) w, ( STATUS ) w, ( LENGTH ) 405 | DOES> STATUS-WORD w@ 0DF00 AND ILLEGAL-OPS? 406 | DUP C@ SOURCE-REG w! 407 | DUP 3 + w@ SWAP 1+ w@ UPDATE-FLAGS ; 408 | -*- 409 | > 410 | MODIFIER 411 | !00000067 412 | ( MODIFIER ) 413 | HEX 414 | : MODIFIER ( -> ) 415 | CREATE w, ( LENGTH ) 416 | DOES> w@ 0 UPDATE-FLAGS ; 417 | -*- 418 | > 419 | INCR1 420 | !00000035 421 | : INCR1 ( NA NB -> NA+1 NB ) 422 | SWAP 1+ SWAP ; 423 | -*- 424 | > 425 | INCR2 426 | !00000035 427 | : INCR2 ( NA NB -> NA+2 NB ) 428 | SWAP 2+ SWAP ; 429 | -*- 430 | > 431 | TYPE1 432 | !0000017D 433 | ( TYPE1 ) 434 | ( ! xxxxxx D W ! MOD REG R/M ! DISP-LO ! DISP-HI ! ) 435 | HEX 436 | : TYPE1 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 437 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 438 | STATUS-WORD w@ 01F1F AND IF 0 439 | ELSE CHECK-LENGTH 440 | DUP C@ ?W OR ?D 1 shl OR XXC, 441 | ?MOD-R/M2 ?REG 3 shl OR XXC, 442 | ?OFFSET, 443 | 1 endif endif 444 | INCR1 ; 445 | -*- 446 | > 447 | TYPE2 448 | !000001A2 449 | ( TYPE2 ) 450 | ( ! xxxxxx Q x ! MOD x SR R/M ! DISP-LO ! DISP-HI ) 451 | HEX 452 | : TYPE2 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 453 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 454 | STATUS-WORD w@ DUP 1010 AND NOT 455 | SWAP 0F0F AND OR IF 0 456 | ELSE CHECK-LENGTH 457 | DUP C@ ?D 1 shl OR XXC, 458 | DUP 1+ C@ ?MOD-R/M2 ?REG 8 * OR OR XXC, 459 | ?OFFSET, 460 | 1 endif endif 461 | INCR2 ; 462 | -*- 463 | > 464 | TYPE3 465 | !000001FF 466 | ( TYPE3 ) 467 | ( ! xxxxxx S W ! MOD xxx R/M ! DISP-LO ! DISP-HI ! 468 | DATALO ! DATAHI if w=1 ! ) HEX 469 | : TYPE3 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 470 | ( NOTE: S BIT=1 NOT SUPPORTED; S FORCED TO 0 ) 471 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 472 | STATUS-WORD w@ DUP 400 AND NOT 473 | SWAP 01F AND OR IF 0 474 | ELSE CHECK-LENGTH 475 | DUP C@ ?W OR XXC, 476 | DUP 1+ C@ ?MOD-R/M2 OR XXC, 477 | ?OFFSET, 478 | SOURCE-VALUE w@ DATA, 479 | 1 endif endif 480 | INCR2 ; 481 | -*- 482 | > 483 | TYPE4 484 | !00000169 485 | ( TYPE4 ) 486 | ( ! xxxxxxx W ! MOD xxx R/M ! DISP-LO ! DISP-HI ! ) 487 | HEX 488 | : TYPE4 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 489 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 490 | STATUS-WORD w@ 01FFF AND 491 | IF 0 492 | ELSE CHECK-LENGTH 493 | DUP C@ ?W OR XXC, 494 | DUP 1+ C@ ?MOD-R/M1 OR XXC, 495 | ?OFFSET, 496 | 1 endif endif 497 | INCR2 ; 498 | -*- 499 | > 500 | TYPE5 501 | !000001E8 502 | ( TYPE5 ) 503 | ( ! xxxxxx V W ! MOD xxx R/M ! DISP-LO ! DISP-HI ! ) 504 | HEX 505 | : TYPE5 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 506 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 507 | STATUS-WORD w@ DUP A000 AND NOT SWAP 508 | 01F AND OR IF 0 509 | ELSE LENGTH-WORD w@ 3 = IF 2 LENGTH-WORD w! endif 510 | DUP C@ ?V 1 shl OR ?W OR XXC, 511 | DUP 1+ C@ ?MOD-R/M2-REG OR XXC, 512 | ( OFFSET ) STATUS-LOW 20 AND IF DEST-VALUE w@ XX, endif 513 | 1 endif endif 514 | INCR2 ; 515 | -*- 516 | > 517 | TYPE6 518 | !00000162 519 | ( TYPE6 ) 520 | ( ! xxxx W REG ! DATALO ! DATAHI if w=1 ! ) 521 | HEX 522 | : TYPE6 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 523 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 524 | STATUS-WORD w@ 0480 = NOT 525 | IF 0 526 | ELSE CHECK-LENGTH 527 | DUP C@ ?W 8 * OR DEST-REG w@ OR XXC, 528 | SOURCE-VALUE w@ DATA, 529 | 1 endif endif 530 | INCR1 ; 531 | -*- 532 | > 533 | TYPE7 534 | !00000190 535 | ( TYPE7 ) 536 | ( ! xxxxxx Q W ! ADDR-LO ! ADDR-HI ! ) 537 | HEX 538 | : TYPE7 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 539 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 540 | STATUS-WORD w@ DUP 8020 = SWAP 541 | 2080 = OR NOT IF 0 542 | ELSE CHECK-LENGTH 543 | DUP C@ ?Q 1 shl OR ?W OR XXC, 544 | ?Q IF DEST-VALUE w@ ELSE SOURCE-VALUE w@ endif XX, 545 | 1 endif endif 546 | INCR1 ; 547 | -*- 548 | > 549 | TYPE8 550 | !0000019F 551 | ( TYPE8 ) 552 | ( ! xxxxxxx W ! DATA-LO ! DATA-HI ! ) 553 | HEX 554 | : TYPE8 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 555 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 556 | STATUS-WORD w@ 0480 = NOT 557 | DEST-REG w@ OR SOURCE-REG w@ OR 558 | IF 0 559 | ELSE CHECK-LENGTH 560 | ( ENSURE DEST IS ACCUM ) ?Q DROP 561 | DUP C@ ?W OR XXC, 562 | SOURCE-VALUE w@ DATA, 563 | 1 endif endif 564 | INCR1 ; 565 | -*- 566 | > 567 | TYPE9 568 | !0000012B 569 | ( TYPE9 ) 570 | ( ! xxxxxxxx ! DATA-LO ! DATA-HI ! ) 571 | HEX 572 | : TYPE9 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 573 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 574 | STATUS-WORD w@ 2000 = NOT 575 | IF 0 576 | ELSE 577 | DUP C@ XXC, 578 | SOURCE-VALUE w@ XX, 579 | 1 endif endif 580 | INCR1 ; 581 | -*- 582 | > 583 | TYPE10 584 | !0000015F 585 | ( TYPE10 ) 586 | ( ! xxxxxxxx ! xxxxxxxx ! DISP-LO ! DISP-HI ! ) 587 | HEX 588 | : TYPE10 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 589 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 590 | STATUS-WORD w@ 2000 = NOT 591 | IF 0 592 | ELSE CHECK-LENGTH 593 | DUP C@ XXC, 594 | DUP 1+ C@ XXC, 595 | SOURCE-VALUE w@ XX, 596 | 1 endif endif 597 | INCR1 ; 598 | -*- 599 | > 600 | TYPE11 601 | !00000192 602 | ( TYPE11 ) 603 | ( ! xxxxxxx W ! DATA-8 ! ) 604 | HEX 605 | : TYPE11 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 606 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 607 | STATUS-WORD w@ DUP 8020 = OVER 2080 = OR 608 | SWAP 2000 = OR NOT IF 0 609 | ELSE 610 | DUP C@ ?W OR XXC, 611 | SOURCE-VALUE w@ DEST-VALUE w@ OR 612 | DUP 0FF00 AND ILLEGAL-OPS? XXC, 613 | 1 endif endif 614 | INCR1 ; 615 | -*- 616 | > 617 | TYPE12 618 | !0000017A 619 | ( TYPE12 ) 620 | ( ! xxxxx REG ! ) 621 | HEX 622 | : TYPE12 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 623 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 624 | STATUS-WORD w@ 7F7F AND 625 | LENGTH-WORD w@ 2 = NOT OR 626 | IF 0 627 | ELSE CHECK-LENGTH 628 | ( ONLY AX ALLOWED FOR DEST ) DEST-REG w@ ILLEGAL-OPS? 629 | DUP C@ SOURCE-REG w@ OR XXC, 630 | 1 endif endif 631 | INCR1 ; 632 | -*- 633 | > 634 | TYPE13 635 | !00000127 636 | ( TYPE13 ) 637 | ( ! xxx SR xxx ! ) 638 | HEX 639 | : TYPE13 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 640 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 641 | STATUS-WORD w@ 1000 AND NOT 642 | IF 0 643 | ELSE CHECK-LENGTH 644 | DUP C@ SOURCE-REG w@ 8 * OR XXC, 645 | 1 endif endif 646 | INCR1 ; 647 | -*- 648 | > 649 | TYPE14 650 | !00000132 651 | ( TYPE14 ) 652 | ( ! xxxxxxxx ! IP-INC-LO ! IP-INC-HI ! ) 653 | HEX 654 | : TYPE14 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 655 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 656 | STATUS-WORD w@ 2000 = NOT 657 | IF 0 658 | ELSE 659 | DUP C@ XXC, 660 | SOURCE-VALUE w@ DISP16, 661 | 1 endif endif 662 | INCR1 ; 663 | -*- 664 | > 665 | TYPE15 666 | !00000178 667 | ( TYPE15 ) 668 | ( ! xxxxxxxx ! OFFSET-LO ! OFFSET-HI ! SEG-LO ! SEG-HI ! ) 669 | HEX 670 | : TYPE15 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 671 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 672 | STATUS-WORD w@ 2200 = NOT 673 | LENGTH-WORD w@ 4000 = NOT OR 674 | IF 0 675 | ELSE 676 | DUP C@ XXC, 677 | SOURCE-VALUE w@ XX, AUX-VALUE w@ XX, 678 | 1 endif endif 679 | INCR1 ; 680 | -*- 681 | > 682 | TYPE16 683 | !00000143 684 | ( TYPE16 ) 685 | ( ! xxxxxxxx ! IP-INC-LO ! ) 686 | HEX 687 | : TYPE16 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 688 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 689 | STATUS-WORD w@ 2000 = NOT LENGTH-WORD w@ 2000 = NOT OR 690 | IF 0 691 | ELSE 692 | DUP C@ XXC, 693 | SOURCE-VALUE w@ DISP8, 694 | 1 endif endif 695 | INCR1 ; 696 | -*- 697 | > 698 | TYPE18 699 | !000000E4 700 | ( TYPE18 ) 701 | ( ! xxxxxxxx ! ) 702 | HEX 703 | : TYPE18 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 704 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 705 | STATUS-WORD w@ IF 0 ELSE 706 | DUP C@ XXC, 707 | 1 endif endif 708 | INCR1 ; 709 | -*- 710 | > 711 | TYPE19 712 | !00000173 713 | ( TYPE19 ) 714 | ( ! xxxxx MF x ! MOD xxx R/M ! DISP-LO ! DISP-HI ! ) 715 | HEX 716 | : TYPE19 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 717 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 718 | STATUS-WORD w@ 01FFF AND 719 | IF 0 720 | ELSE CHECK-LENGTH 721 | DUP C@ ?MF 1 shl OR XXC, 722 | DUP 1+ C@ ?MOD-R/M1 OR XXC, 723 | ?OFFSET, 724 | 1 endif endif 725 | INCR2 ; 726 | -*- 727 | > 728 | TYPE21 729 | !00000152 730 | ( TYPE21 ) 731 | ( ! xxxxxxxx ! MOD xxx R/M ! DISP-LO ! DISP-HI ! ) 732 | HEX 733 | : TYPE21 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 734 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 735 | STATUS-WORD w@ 01FFF AND 736 | IF 0 737 | ELSE 738 | DUP C@ XXC, 739 | DUP 1+ C@ ?MOD-R/M1 OR XXC, 740 | ?OFFSET, 741 | 1 endif endif 742 | INCR2 ; 743 | -*- 744 | > 745 | TYPE22 746 | !00000132 747 | ( TYPE22 ) 748 | ( ! xxxxxxxx ! xxxxx ST[i] ! ) 749 | HEX 750 | : TYPE22 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 751 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 752 | STATUS-WORD w@ 0808 AND NOT 753 | IF 0 754 | ELSE 755 | DUP C@ XXC, 756 | DUP 1+ C@ ?FREG OR XXC, 757 | 1 endif endif 758 | INCR2 ; 759 | -*- 760 | > 761 | TYPE23 762 | !00000108 763 | ( TYPE23 ) 764 | ( ! xxxxxxxx ! xxxxxxxx ! ) 765 | HEX 766 | : TYPE23 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 767 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 768 | STATUS-WORD w@ IF 0 ELSE 769 | DUP C@ XXC, 770 | DUP 1+ C@ XXC, 771 | 1 endif endif 772 | INCR2 ; 773 | -*- 774 | > 775 | TYPE24 776 | !00000142 777 | ( TYPE24 ) 778 | ( ! xxxxx D xx ! xxxxx ST[i] ! ) 779 | HEX 780 | : TYPE24 ( ADDR PREV-SUCCESS-FLAG -> ADDR+2 SUCCESS-FLAG ) 781 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 782 | STATUS-WORD w@ 0808 AND NOT 783 | IF 0 784 | ELSE 785 | DUP C@ ?FD 4 * OR XXC, 786 | DUP 1+ C@ ?FREG OR XXC, 787 | 1 endif endif 788 | INCR2 ; 789 | -*- 790 | > 791 | TYPE25 792 | !0000010F 793 | ( TYPE25 ) 794 | ( ! xxxxxxx W ! ) ( used by IN/OUT ) 795 | HEX 796 | : TYPE25 ( ADDR PREV-SUCCESS-FLAG -> ADDR+1 SUCCESS-FLAG ) 797 | ?DUP 0= IF ( NO PREVIOUS SUCCESS ) 798 | STATUS-WORD w@ 8080 = NOT IF 0 ELSE 799 | DUP C@ ?W OR XXC, 800 | 1 endif endif 801 | INCR1 ; 802 | -*- 803 | > 804 | GET-OPS 805 | !00000051 806 | ( FACTORED WORDS FOR GROUPS ) 807 | : GET-OPS ( N -> ) 808 | 0 DO C, LOOP ; 809 | -*- 810 | > 811 | OP-FOUND? 812 | !0000004F 813 | : OP-FOUND? ( ADDR FOUND-FLAG -> ) 814 | 0= ILLEGAL-OPS? DROP RESET ; 815 | -*- 816 | > 817 | GROUP-SETUP 818 | !0000003D 819 | : GROUP-SETUP ( -> 0 ) 820 | >R GET-STACK-PARAMS R> 0 ; 821 | -*- 822 | > 823 | GROUPA 824 | !00000099 825 | ( GROUPA ) 826 | HEX 827 | : GROUPA ( OP7 OP6 OP3 OP2 OP1 -> ) 828 | CREATE 7 GET-OPS 829 | DOES> GROUP-SETUP TYPE1 TYPE2 TYPE6 TYPE3 TYPE7 830 | OP-FOUND? ; 831 | -*- 832 | > 833 | GROUPB 834 | !0000008A 835 | ( GROUPB ) 836 | HEX 837 | : GROUPB ( OP13 OP12 OP4 -> ) 838 | CREATE 4 GET-OPS 839 | DOES> GROUP-SETUP TYPE12 TYPE13 TYPE4 840 | OP-FOUND? ; 841 | 842 | -*- 843 | > 844 | GROUPC 845 | !000000A4 846 | ( GROUPC ) 847 | HEX 848 | : GROUPC ( OP12 OP1 -> ) 849 | CREATE 2 GET-OPS 850 | DOES> GROUP-SETUP DEST-REG w@ 0= IF TYPE12 851 | ELSE INCR1 endif TYPE1 OP-FOUND? ; 852 | -*- 853 | > 854 | GROUPD 855 | !000000B7 856 | ( GROUPD ) 857 | HEX 858 | : GROUPD ( OP12 OP11 -> ) 859 | CREATE 2 GET-OPS 860 | DOES> GROUP-SETUP LENGTH-WORD w@ 3 = 861 | IF 1 LENGTH-WORD w! endif TYPE11 TYPE25 862 | OP-FOUND? ; 863 | -*- 864 | > 865 | GROUPE 866 | !00000083 867 | ( GROUPE ) 868 | HEX 869 | : GROUPE ( OP18 -> ) ( CONSTANT OPCODES ) 870 | CREATE 1 GET-OPS 871 | DOES> GROUP-SETUP TYPE18 872 | OP-FOUND? ; 873 | -*- 874 | > 875 | GROUPF 876 | !000000A7 877 | ( GROUPF ) 878 | HEX 879 | : GROUPF ( OP1 -> ) 880 | CREATE 1 GET-OPS 881 | DOES> GROUP-SETUP XXHERE >R 1 LENGTH-WORD w! TYPE1 882 | OP-FOUND? R@ XXC@ 0FD AND R> XXC! ; 883 | -*- 884 | > 885 | GROUPG 886 | !00000085 887 | ( GROUPG ) 888 | HEX 889 | : GROUPG ( OP1 OP3 OP8 -> ) 890 | CREATE 4 GET-OPS 891 | DOES> GROUP-SETUP TYPE8 TYPE1 TYPE3 892 | OP-FOUND? ; 893 | -*- 894 | > 895 | GROUPH 896 | !000000C2 897 | ( GROUPH ) 898 | HEX 899 | : GROUPH ( OP1 OP3 OP8 -> ) 900 | CREATE 4 GET-OPS 901 | DOES> XXHERE >R GROUP-SETUP TYPE1 902 | DUP IF R@ XXC@ 0FD AND R@ XXC! endif R> DROP 903 | TYPE8 TYPE3 OP-FOUND? ; 904 | -*- 905 | > 906 | GROUPJ 907 | !00000079 908 | ( GROUPJ ) 909 | HEX 910 | : GROUPJ ( OP4 OP12 -> ) 911 | CREATE 3 GET-OPS 912 | DOES> GROUP-SETUP TYPE12 TYPE4 913 | OP-FOUND? ; 914 | -*- 915 | > 916 | GROUPK 917 | !0000006B 918 | ( GROUPK ) 919 | HEX 920 | : GROUPK ( OP4 -> ) 921 | CREATE 2 GET-OPS 922 | DOES> GROUP-SETUP TYPE4 923 | OP-FOUND? ; 924 | -*- 925 | > 926 | GROUPL 927 | !0000006C 928 | ( GROUPL ) 929 | HEX 930 | : GROUPL ( OP10 -> ) 931 | CREATE 2 GET-OPS 932 | DOES> GROUP-SETUP TYPE23 933 | OP-FOUND? ; 934 | -*- 935 | > 936 | GROUPM 937 | !0000018A 938 | ( GROUPM ) 939 | HEX 940 | : GROUPM ( OP4 OP15 OP4 OP16 OP14 -> ) 941 | CREATE 7 GET-OPS 942 | DOES> LENGTH-WORD w@ F000 AND LENGTH-WORD w! GROUP-SETUP 943 | ( INTER-SEGMENT ) LENGTH-WORD w@ 5000 AND 5000 = 944 | IF 4000 LENGTH-WORD w! TYPE4 945 | ELSE INCR2 endif TYPE15 946 | ( INTRA-SEGMENT ) LENGTH-WORD w@ 1000 AND 947 | IF TYPE4 ELSE INCR2 endif TYPE16 TYPE14 948 | OP-FOUND? ; 949 | -*- 950 | > 951 | GROUPN 952 | !000000BA 953 | ( GROUPN ) 954 | HEX 955 | : GROUPN ( OP18 OP8 -> ) 956 | CREATE 4 GET-OPS 957 | DOES> GROUP-SETUP LENGTH-WORD w@ 4000 = 958 | IF TYPE9 TYPE18 ELSE INCR2 endif TYPE9 TYPE18 959 | OP-FOUND? ; 960 | -*- 961 | > 962 | GROUPP 963 | !00000073 964 | ( GROUPP ) 965 | HEX 966 | : GROUPP ( OP16 -> ) 967 | CREATE 1 GET-OPS 968 | DOES> SHORT GROUP-SETUP TYPE16 969 | OP-FOUND? ; 970 | -*- 971 | > 972 | GROUPQ 973 | !000000DD 974 | ( GROUPQ ) 975 | HEX 976 | : GROUPQ ( OP11 OP18 -> ) 977 | CREATE 2 GET-OPS 978 | DOES> GROUP-SETUP STATUS-WORD w@ 2000 = 979 | SOURCE-VALUE w@ 3 = AND 980 | IF 0 STATUS-WORD w! TYPE18 ELSE INCR1 endif TYPE11 981 | OP-FOUND? ; 982 | -*- 983 | > 984 | GROUPR 985 | !0000016A 986 | ( GROUPR ) 987 | HEX 988 | : GROUPR ( OP22 OP19 OP21 OP21 OP21 -> ) 989 | CREATE 0A GET-OPS 990 | DOES> 9B XXC, GROUP-SETUP LENGTH-WORD w@ 8 = 991 | IF TYPE21 ELSE INCR2 endif 992 | LENGTH-WORD w@ 40 = 993 | IF TYPE21 ELSE INCR2 endif 994 | LENGTH-WORD w@ 80 = 995 | IF TYPE21 ELSE INCR2 endif 996 | TYPE19 TYPE22 997 | OP-FOUND? ; 998 | -*- 999 | > 1000 | GROUPS 1001 | !00000083 1002 | ( GROUPS ) 1003 | HEX 1004 | : GROUPS ( OP19 OP22 -> ) 1005 | CREATE 4 GET-OPS 1006 | DOES> 9B XXC, GROUP-SETUP TYPE19 TYPE22 1007 | OP-FOUND? ; 1008 | -*- 1009 | > 1010 | GROUPT 1011 | !00000076 1012 | ( GROUPT ) 1013 | HEX 1014 | : GROUPT ( OP22 -> ) 1015 | CREATE 2 GET-OPS 1016 | DOES> 9B XXC, GROUP-SETUP TYPE22 1017 | OP-FOUND? ; 1018 | -*- 1019 | > 1020 | GROUPU 1021 | !00000082 1022 | ( GROUPU ) 1023 | HEX 1024 | : GROUPU ( OP24 OP19 -> ) 1025 | CREATE 4 GET-OPS 1026 | DOES> 9B XXC, GROUP-SETUP TYPE24 TYPE19 1027 | OP-FOUND? ; 1028 | -*- 1029 | > 1030 | GROUPV 1031 | !00000075 1032 | ( GROUPV ) 1033 | HEX 1034 | : GROUPV ( OP24 -> ) 1035 | CREATE 2 GET-OPS 1036 | DOES> 9B XXC, GROUP-SETUP TYPE24 1037 | OP-FOUND? ; 1038 | -*- 1039 | > 1040 | GROUPW 1041 | !00000075 1042 | ( GROUPW ) 1043 | HEX 1044 | : GROUPW ( OP23 -> ) 1045 | CREATE 2 GET-OPS 1046 | DOES> 9B XXC, GROUP-SETUP TYPE23 1047 | OP-FOUND? ; 1048 | -*- 1049 | > 1050 | GROUPX 1051 | !00000082 1052 | ( GROUPX ) 1053 | HEX 1054 | : GROUPX ( OP21 -> ) 1055 | CREATE 3 GET-OPS 1056 | DOES> DUP C@ XXC, 1+ GROUP-SETUP TYPE21 1057 | OP-FOUND? ; 1058 | -*- 1059 | > 1060 | GROUPY 1061 | !0000006B 1062 | ( GROUPY ) 1063 | HEX 1064 | : GROUPY ( OP5 -> ) 1065 | CREATE 2 GET-OPS 1066 | DOES> GROUP-SETUP TYPE5 1067 | OP-FOUND? ; 1068 | -*- 1069 | > 1070 | ZAREA 1071 | !00000024 1072 | ( GROUPZA ) 1073 | CREATE ZAREA 4 ALLOT 1074 | -*- 1075 | > 1076 | GROUPZA 1077 | !000000DE 1078 | hex 1079 | : GROUPZA ( OP24 OP19 -> ) 1080 | CREATE 4 GET-OPS 1081 | DOES> 9B XXC, GROUP-SETUP DROP 1082 | DUP w@ ZAREA w! 1083 | 2+ w@ ?FD 800 * XOR ZAREA 2+ w! 1084 | ZAREA 0 TYPE19 TYPE24 1085 | OP-FOUND? ; 1086 | -*- 1087 | > 1088 | GROUPZB 1089 | !00000077 1090 | ( GROUPZB ) 1091 | HEX 1092 | : GROUPZB ( OP24 -> ) 1093 | CREATE 2 GET-OPS 1094 | DOES> 9B XXC, GROUP-SETUP TYPE24 1095 | OP-FOUND? ; 1096 | -*- 1097 | > 1098 | GROUPZC 1099 | !00000077 1100 | ( GROUPZC ) 1101 | HEX 1102 | : GROUPZC ( OP23 -> ) 1103 | CREATE 2 GET-OPS 1104 | DOES> 90 XXC, GROUP-SETUP TYPE23 1105 | OP-FOUND? ; 1106 | -*- 1107 | > 1108 | HERE-BE-STUFF 1109 | !00000017 1110 | package here-be-stuff 1111 | -*- 1112 | v 1113 | AL 1114 | !00000039 1115 | ( SOURCE REGISTER DEFINITIONS ) 1116 | HEX 1 8000 0 SREG AL 1117 | -*- 1118 | > 1119 | AH 1120 | !00000017 1121 | hex 1 8000 4 SREG AH 1122 | -*- 1123 | > 1124 | CL 1125 | !00000018 1126 | hex 1 8000 1 SREG CL 1127 | -*- 1128 | > 1129 | CH 1130 | !00000017 1131 | hex 1 8000 5 SREG CH 1132 | -*- 1133 | > 1134 | DL 1135 | !00000018 1136 | hex 1 8000 2 SREG DL 1137 | -*- 1138 | > 1139 | DH 1140 | !00000017 1141 | hex 1 8000 6 SREG DH 1142 | -*- 1143 | > 1144 | BL 1145 | !00000018 1146 | hex 1 8000 3 SREG BL 1147 | -*- 1148 | > 1149 | BH 1150 | !00000017 1151 | hex 1 8000 7 SREG BH 1152 | -*- 1153 | > 1154 | AX 1155 | !00000018 1156 | hex 2 8000 0 SREG AX 1157 | -*- 1158 | > 1159 | SP 1160 | !00000017 1161 | hex 2 8000 4 SREG SP 1162 | -*- 1163 | > 1164 | CX 1165 | !00000018 1166 | hex 2 8000 1 SREG CX 1167 | -*- 1168 | > 1169 | BP 1170 | !00000017 1171 | hex 2 8000 5 SREG BP 1172 | -*- 1173 | > 1174 | DX 1175 | !00000018 1176 | hex 2 8000 2 SREG DX 1177 | -*- 1178 | > 1179 | SI 1180 | !00000017 1181 | hex 2 8000 6 SREG SI 1182 | -*- 1183 | > 1184 | BX 1185 | !00000018 1186 | hex 2 8000 3 SREG BX 1187 | -*- 1188 | > 1189 | DI 1190 | !00000017 1191 | hex 2 8000 7 SREG DI 1192 | -*- 1193 | > 1194 | ES 1195 | !00000018 1196 | hex 2 1000 0 SREG ES 1197 | -*- 1198 | > 1199 | SS 1200 | !00000017 1201 | hex 2 1000 2 SREG SS 1202 | -*- 1203 | > 1204 | CS 1205 | !00000018 1206 | hex 2 1000 1 SREG CS 1207 | -*- 1208 | > 1209 | DS 1210 | !00000017 1211 | hex 2 1000 3 SREG DS 1212 | -*- 1213 | > 1214 | [BX+SI] 1215 | !00000042 1216 | ( SOURCE REGISTER DEFINITIONS - 2 ) 1217 | HEX 0 4000 0 SREG [BX+SI] 1218 | -*- 1219 | > 1220 | [SI] 1221 | !00000019 1222 | hex 0 4000 4 SREG [SI] 1223 | -*- 1224 | > 1225 | [BX+DI] 1226 | !0000001D 1227 | hex 0 4000 1 SREG [BX+DI] 1228 | -*- 1229 | > 1230 | [DI] 1231 | !00000019 1232 | hex 0 4000 5 SREG [DI] 1233 | -*- 1234 | > 1235 | [BP+SI] 1236 | !0000001D 1237 | hex 0 4000 2 SREG [BP+SI] 1238 | -*- 1239 | > 1240 | 1241 | !00000019 1242 | hex 0 4000 6 SREG 1243 | -*- 1244 | > 1245 | [BP+DI] 1246 | !0000001D 1247 | hex 0 4000 3 SREG [BP+DI] 1248 | -*- 1249 | > 1250 | [BX] 1251 | !00000019 1252 | hex 0 4000 7 SREG [BX] 1253 | -*- 1254 | > 1255 | ST[0] 1256 | !0000001B 1257 | hex 0 800 0 SREG ST[0] 1258 | -*- 1259 | > 1260 | ST[4] 1261 | !0000001B 1262 | hex 0 800 4 SREG ST[4] 1263 | -*- 1264 | > 1265 | ST[1] 1266 | !0000001B 1267 | hex 0 800 1 SREG ST[1] 1268 | -*- 1269 | > 1270 | ST[5] 1271 | !0000001A 1272 | hex 0 800 5 SREG ST[5] 1273 | -*- 1274 | > 1275 | ST[2] 1276 | !0000001B 1277 | hex 0 800 2 SREG ST[2] 1278 | -*- 1279 | > 1280 | ST[6] 1281 | !0000001D 1282 | hex 0 800 6 SREG ST[6] 1283 | -*- 1284 | > 1285 | ST[3] 1286 | !0000001B 1287 | hex 0 800 3 SREG ST[3] 1288 | -*- 1289 | > 1290 | ST[7] 1291 | !0000001D 1292 | hex 0 800 7 SREG ST[7] 1293 | -*- 1294 | > 1295 | ST 1296 | !00000018 1297 | hex 0 800 0 SREG ST 1298 | -*- 1299 | > 1300 | [BP] 1301 | !0000006A 1302 | : [BP] ( N or --- -> N or 0 ) ( [BP] with no offset illegal) 1303 | PARAMS? 0= IF 0 endif ; 1304 | -*- 1305 | > 1306 | DS: 1307 | !00000032 1308 | ( SEGMENT PREFIXES ) 1309 | HEX 1310 | : DS: 3E XXC, ; 1311 | -*- 1312 | > 1313 | CS: 1314 | !0000001B 1315 | hex 1316 | : CS: 2E XXC, ; 1317 | -*- 1318 | > 1319 | ES: 1320 | !0000001B 1321 | hex 1322 | : ES: 26 XXC, ; 1323 | -*- 1324 | > 1325 | SS: 1326 | !0000001B 1327 | hex 1328 | : SS: 36 XXC, ; 1329 | -*- 1330 | > 1331 | BYTE 1332 | !00000018 1333 | hex 1 MODIFIER BYTE 1334 | -*- 1335 | > 1336 | WORD 1337 | !00000018 1338 | hex 2 MODIFIER WORD 1339 | -*- 1340 | > 1341 | SHORT_INT 1342 | !0000001D 1343 | hex 4 MODIFIER SHORT_INT 1344 | -*- 1345 | > 1346 | LONG_INT 1347 | !0000001C 1348 | hex 8 MODIFIER LONG_INT 1349 | -*- 1350 | > 1351 | SHORT_REAL 1352 | !0000001E 1353 | hex 10 MODIFIER SHORT_REAL 1354 | -*- 1355 | > 1356 | LONG_REAL 1357 | !0000001D 1358 | hex 20 MODIFIER LONG_REAL 1359 | -*- 1360 | > 1361 | TEMP_REAL 1362 | !0000001D 1363 | hex 40 MODIFIER TEMP_REAL 1364 | -*- 1365 | > 1366 | BCD 1367 | !00000017 1368 | hex 80 MODIFIER BCD 1369 | -*- 1370 | > 1371 | INDIRECT 1372 | !0000001D 1373 | hex 1000 MODIFIER INDIRECT 1374 | -*- 1375 | > 1376 | SHORT 1377 | !0000001A 1378 | hex 2000 MODIFIER SHORT 1379 | -*- 1380 | > 1381 | FAR 1382 | !00000018 1383 | hex 4000 MODIFIER FAR 1384 | -*- 1385 | > 1386 | MOV 1387 | !0000002B 1388 | hex A0 00 C6 B0 00 8C 88 GROUPA MOV 1389 | -*- 1390 | > 1391 | PUSH 1392 | !00000023 1393 | hex 30 FF 06 50 GROUPB PUSH 1394 | -*- 1395 | > 1396 | POP 1397 | !00000022 1398 | hex 00 8F 07 58 GROUPB POP 1399 | -*- 1400 | > 1401 | XCHG 1402 | !0000001A 1403 | hex 86 90 GROUPC XCHG 1404 | -*- 1405 | > 1406 | IN 1407 | !00000018 1408 | hex EC E4 GROUPD IN 1409 | -*- 1410 | > 1411 | OUT 1412 | !00000019 1413 | hex EE E6 GROUPD OUT 1414 | -*- 1415 | > 1416 | PUSHF 1417 | !00000016 1418 | hex 9C GROUPE PUSHF 1419 | -*- 1420 | > 1421 | POPF 1422 | !00000014 1423 | hex 9d GROUPE POPF 1424 | -*- 1425 | > 1426 | AAA 1427 | !00000013 1428 | hex 37 GROUPE AAA 1429 | -*- 1430 | > 1431 | DAA 1432 | !00000015 1433 | hex 27 GROUPE DAA 1434 | -*- 1435 | > 1436 | AAS 1437 | !00000013 1438 | hex 3f GROUPE AAS 1439 | -*- 1440 | > 1441 | DAS 1442 | !00000013 1443 | hex 2f GROUPE DAS 1444 | -*- 1445 | > 1446 | CBW 1447 | !00000015 1448 | hex 98 GROUPE CBW 1449 | -*- 1450 | > 1451 | CWD 1452 | !00000013 1453 | hex 99 GROUPE CWD 1454 | -*- 1455 | > 1456 | REPZ 1457 | !00000014 1458 | hex f3 GROUPE REPZ 1459 | -*- 1460 | > 1461 | REPNZ 1462 | !00000017 1463 | hex F2 GROUPE REPNZ 1464 | -*- 1465 | > 1466 | MOVSB 1467 | !00000015 1468 | hex a4 GROUPE MOVSB 1469 | -*- 1470 | > 1471 | MOVSW 1472 | !00000015 1473 | hex a5 GROUPE MOVSW 1474 | -*- 1475 | > 1476 | CMPSB 1477 | !00000017 1478 | hex A6 GROUPE CMPSB 1479 | -*- 1480 | > 1481 | CMPSW 1482 | !00000015 1483 | hex a7 GROUPE CMPSW 1484 | -*- 1485 | > 1486 | SCASB 1487 | !00000015 1488 | hex ae GROUPE SCASB 1489 | -*- 1490 | > 1491 | SCASW 1492 | !00000017 1493 | hex AF GROUPE SCASW 1494 | -*- 1495 | > 1496 | LODSB 1497 | !00000015 1498 | hex ac GROUPE LODSB 1499 | -*- 1500 | > 1501 | LODSW 1502 | !00000015 1503 | hex ad GROUPE LODSW 1504 | -*- 1505 | > 1506 | STOSB 1507 | !00000017 1508 | hex AA GROUPE STOSB 1509 | -*- 1510 | > 1511 | STOSW 1512 | !00000015 1513 | hex ab GROUPE STOSW 1514 | -*- 1515 | > 1516 | INTO 1517 | !00000014 1518 | hex ce GROUPE INTO 1519 | -*- 1520 | > 1521 | XLAT 1522 | !00000025 1523 | ( GROUPE - 2 ) 1524 | HEX D7 GROUPE XLAT 1525 | -*- 1526 | > 1527 | LAHF 1528 | !00000014 1529 | hex 9f GROUPE LAHF 1530 | -*- 1531 | > 1532 | SAHF 1533 | !00000014 1534 | hex 9e GROUPE SAHF 1535 | -*- 1536 | > 1537 | IRET 1538 | !00000016 1539 | hex CF GROUPE IRET 1540 | -*- 1541 | > 1542 | CLC 1543 | !00000013 1544 | hex f8 GROUPE CLC 1545 | -*- 1546 | > 1547 | CMC 1548 | !00000013 1549 | hex f5 GROUPE CMC 1550 | -*- 1551 | > 1552 | STC 1553 | !00000015 1554 | hex F9 GROUPE STC 1555 | -*- 1556 | > 1557 | CLD 1558 | !00000013 1559 | hex fc GROUPE CLD 1560 | -*- 1561 | > 1562 | STD 1563 | !00000013 1564 | hex fd GROUPE STD 1565 | -*- 1566 | > 1567 | CLI 1568 | !00000015 1569 | hex FA GROUPE CLI 1570 | -*- 1571 | > 1572 | STI 1573 | !00000013 1574 | hex fb GROUPE STI 1575 | -*- 1576 | > 1577 | HLT 1578 | !00000013 1579 | hex f4 GROUPE HLT 1580 | -*- 1581 | > 1582 | WAIT 1583 | !00000016 1584 | hex 9B GROUPE WAIT 1585 | -*- 1586 | > 1587 | FWAIT 1588 | !00000015 1589 | hex 9b GROUPE FWAIT 1590 | -*- 1591 | > 1592 | LOCK 1593 | !00000014 1594 | hex f0 GROUPE LOCK 1595 | -*- 1596 | > 1597 | REPE 1598 | !00000016 1599 | hex F3 GROUPE REPE 1600 | -*- 1601 | > 1602 | REP 1603 | !00000013 1604 | hex f3 GROUPE REP 1605 | -*- 1606 | > 1607 | REPNE 1608 | !00000015 1609 | hex f2 GROUPE REPNE 1610 | -*- 1611 | > 1612 | NOP 1613 | !00000015 1614 | hex 90 GROUPE NOP 1615 | -*- 1616 | > 1617 | LEA 1618 | !00000015 1619 | hex 8D GROUPF LEA 1620 | -*- 1621 | > 1622 | LDS 1623 | !00000016 1624 | hex C5 GROUPF LDS 1625 | -*- 1626 | > 1627 | LES 1628 | !00000016 1629 | hex C4 GROUPF LES 1630 | -*- 1631 | > 1632 | ADD 1633 | !00000020 1634 | hex 00 80 00 04 GROUPG ADD 1635 | -*- 1636 | > 1637 | ADC 1638 | !00000021 1639 | hex 10 80 10 15 GROUPG ADC 1640 | -*- 1641 | > 1642 | SUB 1643 | !00000021 1644 | hex 28 80 28 2C GROUPG SUB 1645 | -*- 1646 | > 1647 | SBB 1648 | !00000021 1649 | hex 18 80 18 1C GROUPG SBB 1650 | -*- 1651 | > 1652 | CMP 1653 | !00000021 1654 | hex 38 80 38 3C GROUPG CMP 1655 | -*- 1656 | > 1657 | AND 1658 | !00000021 1659 | hex 20 80 20 24 GROUPG AND 1660 | -*- 1661 | > 1662 | OR 1663 | !00000020 1664 | hex 08 80 08 0C GROUPG OR 1665 | -*- 1666 | > 1667 | XOR 1668 | !00000021 1669 | hex 30 80 30 34 GROUPG XOR 1670 | -*- 1671 | > 1672 | TEST 1673 | !00000021 1674 | hex 00 F6 A8 84 GROUPH TEST 1675 | -*- 1676 | > 1677 | INC 1678 | !0000001C 1679 | hex 00 FE 40 GROUPJ INC 1680 | -*- 1681 | > 1682 | DEC 1683 | !0000001D 1684 | hex 08 FE 48 GROUPJ DEC 1685 | -*- 1686 | > 1687 | NEG 1688 | !00000018 1689 | hex 18 F6 GROUPK NEG 1690 | -*- 1691 | > 1692 | MUL 1693 | !00000019 1694 | hex 20 F6 GROUPK MUL 1695 | -*- 1696 | > 1697 | IMUL 1698 | !0000001A 1699 | hex 28 F6 GROUPK IMUL 1700 | -*- 1701 | > 1702 | DIV 1703 | !00000019 1704 | hex 30 F6 GROUPK DIV 1705 | -*- 1706 | > 1707 | IDIV 1708 | !0000001A 1709 | hex 38 F6 GROUPK IDIV 1710 | -*- 1711 | > 1712 | NOT 1713 | !00000019 1714 | hex 10 F6 GROUPK NOT 1715 | -*- 1716 | > 1717 | AAM 1718 | !00000018 1719 | hex 0A D4 GROUPL AAM 1720 | -*- 1721 | > 1722 | AAD 1723 | !00000019 1724 | hex 0A D5 GROUPL AAD 1725 | -*- 1726 | > 1727 | CALL 1728 | !0000002C 1729 | hex E8 F4 10 FF 9A 18 FF GROUPM CALL 1730 | -*- 1731 | > 1732 | JMP 1733 | !0000002C 1734 | hex E9 EB 20 FF EA 28 FF GROUPM JMP 1735 | -*- 1736 | > 1737 | RET 1738 | !00000021 1739 | hex C3 C2 CB CA GROUPN RET 1740 | -*- 1741 | > 1742 | JE 1743 | !00000013 1744 | hex 74 GROUPP JE 1745 | -*- 1746 | > 1747 | JZ 1748 | !00000012 1749 | hex 74 GROUPP JZ 1750 | -*- 1751 | > 1752 | JL 1753 | !00000012 1754 | hex 7c GROUPP JL 1755 | -*- 1756 | > 1757 | JNGE 1758 | !00000016 1759 | hex 7C GROUPP JNGE 1760 | -*- 1761 | > 1762 | JLE 1763 | !00000013 1764 | hex 7e GROUPP JLE 1765 | -*- 1766 | > 1767 | JNG 1768 | !00000013 1769 | hex 7e GROUPP JNG 1770 | -*- 1771 | > 1772 | JB 1773 | !00000014 1774 | hex 72 GROUPP JB 1775 | -*- 1776 | > 1777 | JNAE 1778 | !00000014 1779 | hex 72 GROUPP JNAE 1780 | -*- 1781 | > 1782 | JBE 1783 | !00000013 1784 | hex 76 GROUPP JBE 1785 | -*- 1786 | > 1787 | JNA 1788 | !00000015 1789 | hex 76 GROUPP JNA 1790 | -*- 1791 | > 1792 | JP 1793 | !00000012 1794 | hex 7A GROUPP JP 1795 | -*- 1796 | > 1797 | JPE 1798 | !00000013 1799 | hex 7a GROUPP JPE 1800 | -*- 1801 | > 1802 | JO 1803 | !00000014 1804 | hex 70 GROUPP JO 1805 | -*- 1806 | > 1807 | JS 1808 | !0000000E 1809 | 78 GROUPP JS 1810 | -*- 1811 | > 1812 | JNE 1813 | !00000013 1814 | hex 75 GROUPP JNE 1815 | -*- 1816 | > 1817 | JNZ 1818 | !00000015 1819 | hex 75 GROUPP JNZ 1820 | -*- 1821 | > 1822 | JNL 1823 | !00000013 1824 | hex 7d GROUPP JNL 1825 | -*- 1826 | > 1827 | JGE 1828 | !00000013 1829 | hex 7d GROUPP JGE 1830 | -*- 1831 | > 1832 | JNLE 1833 | !00000025 1834 | ( GROUPP - 2 ) 1835 | HEX 7F GROUPP JNLE 1836 | -*- 1837 | > 1838 | JG 1839 | !00000012 1840 | hex 7f GROUPP JG 1841 | -*- 1842 | > 1843 | JNB 1844 | !00000013 1845 | hex 73 GROUPP JNB 1846 | -*- 1847 | > 1848 | JAE 1849 | !00000015 1850 | hex 73 GROUPP JAE 1851 | -*- 1852 | > 1853 | JNBE 1854 | !00000014 1855 | hex 77 GROUPP JNBE 1856 | -*- 1857 | > 1858 | JA 1859 | !00000012 1860 | hex 77 GROUPP JA 1861 | -*- 1862 | > 1863 | JNP 1864 | !00000015 1865 | hex 7B GROUPP JNP 1866 | -*- 1867 | > 1868 | JPO 1869 | !00000013 1870 | hex 7b GROUPP JPO 1871 | -*- 1872 | > 1873 | JNO 1874 | !00000013 1875 | hex 71 GROUPP JNO 1876 | -*- 1877 | > 1878 | JNS 1879 | !00000015 1880 | hex 79 GROUPP JNS 1881 | -*- 1882 | > 1883 | LOOPZ 1884 | !00000015 1885 | hex e1 GROUPP LOOPZ 1886 | -*- 1887 | > 1888 | LOOPE 1889 | !00000017 1890 | hex E1 GROUPP LOOPE 1891 | -*- 1892 | > 1893 | LOOPNZ 1894 | !00000016 1895 | hex e0 GROUPP LOOPNZ 1896 | -*- 1897 | > 1898 | LOOPNE 1899 | !00000016 1900 | hex e0 GROUPP LOOPNE 1901 | -*- 1902 | > 1903 | JNC 1904 | !00000015 1905 | hex 73 GROUPP JNC 1906 | -*- 1907 | > 1908 | JC 1909 | !00000012 1910 | hex 72 GROUPP JC 1911 | -*- 1912 | > 1913 | JCXZ 1914 | !00000016 1915 | hex E3 GROUPP JCXZ 1916 | -*- 1917 | > 1918 | LOOP 1919 | !00000016 1920 | hex E2 GROUPP LOOP 1921 | -*- 1922 | > 1923 | INT 1924 | !00000019 1925 | hex CD CC GROUPQ INT 1926 | -*- 1927 | > 1928 | FLD 1929 | !00000034 1930 | hex C0 D9 00 D9 20 DF 28 DB 28 DF GROUPR FLD 1931 | -*- 1932 | > 1933 | FSTP 1934 | !00000036 1935 | hex D8 DD 18 D9 30 DF 38 DB 38 DF GROUPR FSTP 1936 | -*- 1937 | > 1938 | FST 1939 | !0000001F 1940 | hex D0 DD 10 D9 GROUPS FST 1941 | -*- 1942 | > 1943 | FCOM 1944 | !00000021 1945 | hex D0 D8 10 D8 GROUPS FCOM 1946 | -*- 1947 | > 1948 | FCOMP 1949 | !00000022 1950 | hex D8 D8 18 D8 GROUPS FCOMP 1951 | -*- 1952 | > 1953 | FXCH 1954 | !00000019 1955 | hex C8 D9 GROUPT FXCH 1956 | -*- 1957 | > 1958 | FFREE 1959 | !0000001B 1960 | hex C0 DD GROUPT FFREE 1961 | -*- 1962 | > 1963 | FADD 1964 | !00000020 1965 | hex 00 D8 C0 D8 GROUPU FADD 1966 | -*- 1967 | > 1968 | FMUL 1969 | !00000021 1970 | hex 08 D8 C8 D8 GROUPU FMUL 1971 | -*- 1972 | > 1973 | FADDP 1974 | !0000001A 1975 | hex C0 DA GROUPV FADDP 1976 | -*- 1977 | > 1978 | FMULP 1979 | !0000001B 1980 | hex C8 DA GROUPV FMULP 1981 | -*- 1982 | > 1983 | FCOMPP 1984 | !0000001B 1985 | hex D9 DE GROUPW FCOMPP 1986 | -*- 1987 | > 1988 | FTST 1989 | !00000017 1990 | hex e4 d9 GROUPW FTST 1991 | -*- 1992 | > 1993 | FXAM 1994 | !0000001A 1995 | hex E5 D9 GROUPW FXAM 1996 | -*- 1997 | > 1998 | FSQRT 1999 | !00000018 2000 | hex fa d9 GROUPW FSQRT 2001 | -*- 2002 | > 2003 | FSCALE 2004 | !0000001C 2005 | hex FD D9 GROUPW FSCALE 2006 | -*- 2007 | > 2008 | FPREM 2009 | !00000018 2010 | hex f8 d9 GROUPW FPREM 2011 | -*- 2012 | > 2013 | FRNDINT 2014 | !0000001D 2015 | hex FC D9 GROUPW FRNDINT 2016 | -*- 2017 | > 2018 | FXTRACT 2019 | !0000001A 2020 | hex f4 d9 GROUPW FXTRACT 2021 | -*- 2022 | > 2023 | FABS 2024 | !0000001A 2025 | hex E1 D9 GROUPW FABS 2026 | -*- 2027 | > 2028 | FCHS 2029 | !00000017 2030 | hex e0 d9 GROUPW FCHS 2031 | -*- 2032 | > 2033 | FPTAN 2034 | !0000001B 2035 | hex F2 D9 GROUPW FPTAN 2036 | -*- 2037 | > 2038 | FPATAN 2039 | !00000019 2040 | hex f3 d9 GROUPW FPATAN 2041 | -*- 2042 | > 2043 | F2XM1 2044 | !0000002A 2045 | ( GROUPW - 2 ) 2046 | HEX F0 D9 GROUPW F2XM1 2047 | -*- 2048 | > 2049 | FINCSTP 2050 | !0000001A 2051 | hex f7 d9 GROUPW FINCSTP 2052 | -*- 2053 | > 2054 | FYL2X 2055 | !0000001B 2056 | hex F1 D9 GROUPW FYL2X 2057 | -*- 2058 | > 2059 | FYL2XP1 2060 | !0000001A 2061 | hex f9 d9 GROUPW FYL2XP1 2062 | -*- 2063 | > 2064 | FLDZ 2065 | !0000001A 2066 | hex EE D9 GROUPW FLDZ 2067 | -*- 2068 | > 2069 | FLD1 2070 | !00000017 2071 | hex e8 d9 GROUPW FLD1 2072 | -*- 2073 | > 2074 | FLDPI 2075 | !0000001B 2076 | hex EB D9 GROUPW FLDPI 2077 | -*- 2078 | > 2079 | FLDL2T 2080 | !00000019 2081 | hex e9 d9 GROUPW FLDL2T 2082 | -*- 2083 | > 2084 | FLDL2E 2085 | !0000001C 2086 | hex EA D9 GROUPW FLDL2E 2087 | -*- 2088 | > 2089 | FLDLG2 2090 | !00000019 2091 | hex ec d9 GROUPW FLDLG2 2092 | -*- 2093 | > 2094 | FLDLN2 2095 | !0000001C 2096 | hex ED D9 GROUPW FLDLN2 2097 | -*- 2098 | > 2099 | FINIT 2100 | !00000018 2101 | hex e3 db GROUPW FINIT 2102 | -*- 2103 | > 2104 | FENI 2105 | !0000001A 2106 | hex E0 DB GROUPW FENI 2107 | -*- 2108 | > 2109 | FDISI 2110 | !00000018 2111 | hex e1 db GROUPW FDISI 2112 | -*- 2113 | > 2114 | FCLEX 2115 | !0000001B 2116 | hex E2 DB GROUPW FCLEX 2117 | -*- 2118 | > 2119 | FDECSTP 2120 | !0000001A 2121 | hex f6 d9 GROUPW FDECSTP 2122 | -*- 2123 | > 2124 | FNOP 2125 | !0000001A 2126 | hex D0 D9 GROUPW FNOP 2127 | -*- 2128 | > 2129 | FLDCW 2130 | !0000001E 2131 | hex 28 D9 9B GROUPX FLDCW 2132 | -*- 2133 | > 2134 | FSTCW 2135 | !0000001F 2136 | hex 38 D9 9B GROUPX FSTCW 2137 | -*- 2138 | > 2139 | FNSTCW 2140 | !0000001C 2141 | hex 38 d9 90 GROUPX FNSTCW 2142 | -*- 2143 | > 2144 | FSTSW 2145 | !0000001F 2146 | hex 38 DD 9B GROUPX FSTSW 2147 | -*- 2148 | > 2149 | FNSTSW 2150 | !0000001C 2151 | hex 38 dd 90 GROUPX FNSTSW 2152 | -*- 2153 | > 2154 | FSTENV 2155 | !00000021 2156 | hex 30 D9 9B GROUPX FSTENV 2157 | -*- 2158 | > 2159 | FNSTENV 2160 | !0000001D 2161 | hex 30 d9 90 GROUPX FNSTENV 2162 | -*- 2163 | > 2164 | FLDENV 2165 | !00000020 2166 | hex 20 D9 9B GROUPX FLDENV 2167 | -*- 2168 | > 2169 | FSAVE 2170 | !0000001F 2171 | hex 30 DD 9B GROUPX FSAVE 2172 | -*- 2173 | > 2174 | FNSAVE 2175 | !0000001C 2176 | hex 30 dd 90 GROUPX FNSAVE 2177 | -*- 2178 | > 2179 | FRSTOR 2180 | !00000020 2181 | hex 20 DD 9B GROUPX FRSTOR 2182 | -*- 2183 | > 2184 | SHL 2185 | !00000018 2186 | hex 20 D0 GROUPY SHL 2187 | -*- 2188 | > 2189 | SAL 2190 | !0000000F 2191 | : SAL SHL ; 2192 | 2193 | -*- 2194 | > 2195 | SHR 2196 | !00000019 2197 | hex 28 D0 GROUPY SHR 2198 | -*- 2199 | > 2200 | SAR 2201 | !00000019 2202 | hex 38 D0 GROUPY SAR 2203 | -*- 2204 | > 2205 | ROL 2206 | !00000019 2207 | hex 00 D0 GROUPY ROL 2208 | -*- 2209 | > 2210 | ROR 2211 | !00000019 2212 | hex 08 D0 GROUPY ROR 2213 | -*- 2214 | > 2215 | RCL 2216 | !00000019 2217 | hex 10 D0 GROUPY RCL 2218 | -*- 2219 | > 2220 | RCR 2221 | !00000019 2222 | hex 18 D0 GROUPY RCR 2223 | -*- 2224 | > 2225 | FSUB 2226 | !00000021 2227 | hex E0 D8 20 D8 GROUPZA FSUB 2228 | -*- 2229 | > 2230 | FSUBR 2231 | !00000023 2232 | hex E8 D8 28 D8 GROUPZA FSUBR 2233 | -*- 2234 | > 2235 | FDIV 2236 | !00000022 2237 | hex F0 D8 30 D8 GROUPZA FDIV 2238 | -*- 2239 | > 2240 | FDIVR 2241 | !00000023 2242 | hex F8 D8 38 D8 GROUPZA FDIVR 2243 | -*- 2244 | > 2245 | FSUBP 2246 | !0000001B 2247 | hex E8 DA GROUPZB FSUBP 2248 | -*- 2249 | > 2250 | FSUBRP 2251 | !0000001D 2252 | hex E0 DA GROUPZB FSUBRP 2253 | -*- 2254 | > 2255 | FDIVP 2256 | !0000001C 2257 | hex F8 DA GROUPZB FDIVP 2258 | -*- 2259 | > 2260 | FDIVRP 2261 | !0000001D 2262 | hex F0 DA GROUPZB FDIVRP 2263 | -*- 2264 | > 2265 | FNCLEX 2266 | !0000001C 2267 | hex E2 DB GROUPZC FNCLEX 2268 | -*- 2269 | > 2270 | FNDISI 2271 | !0000001D 2272 | hex E1 DB GROUPZC FNDISI 2273 | -*- 2274 | > 2275 | FNENI 2276 | !0000001C 2277 | hex E0 DB GROUPZC FNENI 2278 | -*- 2279 | > 2280 | FNINIT 2281 | !0000001D 2282 | hex E3 DB GROUPZC FNINIT 2283 | -*- 2284 | > 2285 | MATCH-LENGTH 2286 | !0000006E 2287 | ( INTEGER AND BCD F-WORDS ) 2288 | HEX 2289 | : MATCH-LENGTH ( MASK -> ) 2290 | LENGTH-WORD w@ AND NOT ILLEGAL-OPS? ; 2291 | -*- 2292 | > 2293 | FBLD 2294 | !0000001A 2295 | : FBLD BCD FLD ; 2296 | -*- 2297 | > 2298 | FBSTP 2299 | !0000001D 2300 | : FBSTP BCD FSTP ; 2301 | 2302 | -*- 2303 | > 2304 | FIADD 2305 | !00000029 2306 | : FIADD 06 MATCH-LENGTH FADD ; 2307 | 2308 | -*- 2309 | > 2310 | FICOM 2311 | !00000029 2312 | : FICOM 06 MATCH-LENGTH FCOM ; 2313 | 2314 | -*- 2315 | > 2316 | FICOMP 2317 | !0000002A 2318 | : FICOMP 06 MATCH-LENGTH FCOMP ; 2319 | 2320 | -*- 2321 | > 2322 | FIDIV 2323 | !00000029 2324 | : FIDIV 06 MATCH-LENGTH FDIV ; 2325 | 2326 | -*- 2327 | > 2328 | FIDIVR 2329 | !0000002A 2330 | : FIDIVR 06 MATCH-LENGTH FDIVR ; 2331 | 2332 | -*- 2333 | > 2334 | FILD 2335 | !00000028 2336 | : FILD 0E MATCH-LENGTH FLD ; 2337 | 2338 | -*- 2339 | > 2340 | FIMUL 2341 | !00000029 2342 | : FIMUL 06 MATCH-LENGTH FMUL ; 2343 | 2344 | -*- 2345 | > 2346 | FIST 2347 | !00000028 2348 | : FIST 06 MATCH-LENGTH FST ; 2349 | 2350 | -*- 2351 | > 2352 | FISTP 2353 | !00000029 2354 | : FISTP 0E MATCH-LENGTH FSTP ; 2355 | 2356 | -*- 2357 | > 2358 | FISUB 2359 | !00000029 2360 | : FISUB 06 MATCH-LENGTH FSUB ; 2361 | 2362 | -*- 2363 | > 2364 | FISUBR 2365 | !00000028 2366 | : FISUBR 06 MATCH-LENGTH FSUBR ; 2367 | -*- 2368 | > 2369 | OVERFLOW? 2370 | !0000003D 2371 | ( BRANCH CONDITION DEFINITIONS ) 2372 | HEX 71 CONSTANT OVERFLOW? 2373 | -*- 2374 | > 2375 | NO-OVERFLOW? 2376 | !0000001E 2377 | hex 70 CONSTANT NO-OVERFLOW? 2378 | -*- 2379 | > 2380 | BELOW? 2381 | !00000018 2382 | hex 73 CONSTANT BELOW? 2383 | -*- 2384 | > 2385 | NOT-BELOW? 2386 | !0000001C 2387 | hex 72 CONSTANT NOT-BELOW? 2388 | -*- 2389 | > 2390 | =0? 2391 | !00000015 2392 | hex 75 CONSTANT =0? 2393 | -*- 2394 | > 2395 | <>0? 2396 | !00000016 2397 | hex 74 CONSTANT <>0? 2398 | -*- 2399 | > 2400 | =? 2401 | !00000014 2402 | hex 75 CONSTANT =? 2403 | -*- 2404 | > 2405 | <>? 2406 | !00000015 2407 | hex 74 CONSTANT <>? 2408 | -*- 2409 | > 2410 | BELOW/=? 2411 | !0000001A 2412 | hex 77 CONSTANT BELOW/=? 2413 | -*- 2414 | > 2415 | NOT-BELOW/=? 2416 | !0000001E 2417 | hex 76 CONSTANT NOT-BELOW/=? 2418 | -*- 2419 | > 2420 | SIGN? 2421 | !00000017 2422 | hex 79 CONSTANT SIGN? 2423 | -*- 2424 | > 2425 | NO-SIGN? 2426 | !0000001A 2427 | hex 78 CONSTANT NO-SIGN? 2428 | -*- 2429 | > 2430 | PARITY? 2431 | !00000019 2432 | hex 7B CONSTANT PARITY? 2433 | -*- 2434 | > 2435 | NO-PARITY? 2436 | !0000001C 2437 | hex 7a CONSTANT NO-PARITY? 2438 | -*- 2439 | > 2440 | 2445 | >=? 2446 | !00000015 2447 | hex 7c CONSTANT >=? 2448 | -*- 2449 | > 2450 | <=? 2451 | !00000015 2452 | hex 7F CONSTANT <=? 2453 | -*- 2454 | > 2455 | >? 2456 | !00000014 2457 | hex 7e CONSTANT >? 2458 | -*- 2459 | > 2460 | CARRY? 2461 | !00000018 2462 | hex 73 CONSTANT CARRY? 2463 | -*- 2464 | > 2465 | NO-CARRY? 2466 | !0000001B 2467 | hex 72 CONSTANT NO-CARRY? 2468 | -*- 2469 | > 2470 | ?LOOPZ 2471 | !00000018 2472 | hex E1 CONSTANT ?LOOPZ 2473 | -*- 2474 | > 2475 | ?LOOPNZ 2476 | !00000019 2477 | hex e0 CONSTANT ?LOOPNZ 2478 | -*- 2479 | > 2480 | ?LOOP 2481 | !00000017 2482 | hex E2 CONSTANT ?LOOP 2483 | -*- 2484 | > 2485 | CX<>0? 2486 | !00000018 2487 | hex e3 CONSTANT CX<>0? 2488 | -*- 2489 | > 2490 | DISP8! 2491 | !000000BA 2492 | ( CONDITIONAL BRANCH CONTROL STRUCTURES ) 2493 | HEX 2494 | : DISP8! ( !ADDR BRANCH-ADDR -> ) 2495 | OVER 1+ - DUP FF00 AND DUP FF00 = SWAP 0= OR NOT 2496 | ABORT" JUMP OUT OF RANGE" SWAP XXC! ; 2497 | -*- 2498 | > 2499 | IF 2500 | !00000069 2501 | : IF ( OP-CODE -> ADDR ) 2502 | PARAMS? 1 = NOT ILLEGAL-OPS? 2503 | XXC, XXHERE 0 XXC, RESET ; 2504 | -*- 2505 | > 2506 | WHILE 2507 | !00000028 2508 | : WHILE ( OPCODE -> ADDR ) IF ; 2509 | -*- 2510 | > 2511 | UNTIL 2512 | !0000007E 2513 | : UNTIL ( ADDR OPCODE -> ) 2514 | PARAMS? 1 = NOT ILLEGAL-OPS? 2515 | XXC, XXHERE 1 XXALLOT SWAP DISP8! ?STACK RESET ; 2516 | -*- 2517 | > 2518 | BEGIN 2519 | !0000004D 2520 | ( IF -- CONDITIONALS ) 2521 | HEX 2522 | : BEGIN ( -> ADDR ) 2523 | XXHERE RESET ; 2524 | -*- 2525 | > 2526 | REPEAT 2527 | !0000007B 2528 | hex 2529 | : REPEAT ( BEGIN-ADDR WHILE-ADDR -> ) 2530 | XXHERE 2+ DISP8! 0EB XXC, 2531 | XXHERE 1 XXALLOT SWAP DISP8! RESET ; 2532 | -*- 2533 | > 2534 | ELSE 2535 | !00000065 2536 | hex 2537 | : ELSE ( IF-ADDR -> ELSE-ADDR ) 2538 | 0EB XXC, XXHERE 0 XXC, SWAP XXHERE DISP8! RESET ; 2539 | -*- 2540 | > 2541 | THEN 2542 | !0000003E 2543 | hex 2544 | : THEN ( ELSE-ADDR -> ) 2545 | XXHERE DISP8! RESET ; 2546 | -*- 2547 | > 2548 | , 2549 | !0000013B 2550 | ( , -- SOURCE/DEST DELIMITER ) 2551 | : , ( -> ) ( DESTINATION DELIMITER ) 2552 | STATUS-LOW ABORT" MULTIPLE DESTINATIONS" 2553 | GET-STACK-PARAMS 2554 | STATUS-WORD w@ BYTESWAP STATUS-WORD w! 2555 | SOURCE-REG w@ DEST-REG w! 0 SOURCE-REG w! 2556 | SOURCE-VALUE w@ DEST-VALUE w! 0 SOURCE-VALUE w! 2557 | DEPTH OLD-DEPTH w! ; 2558 | -*- 2559 | > 2560 | ]ENDASM 2561 | !00000099 2562 | \ End using the assembler 2563 | : ]endasm 2564 | [compile] x \ Use empty package (turn off searching the assembler) 2565 | [compile] ] \ Turn the compiler on 2566 | ; 2567 | -*- 2568 | v 2569 | X 2570 | !0000000B 2571 | package x 2572 | -*- 2573 | ^ 2574 | ^ 2575 | ^ 2576 | -------------------------------------------------------------------------------- /assign.fiv: -------------------------------------------------------------------------------- 1 | X 2 | !00000000 3 | -*- 4 | v 5 | ^ 6 | !00000112 7 | \ This exponent program does not work well on numbers close to zero. 8 | \ For example, .01 2. ^ yields: .0000709 (It should be .0001) 9 | \ 10 | \ We wrote a ^ module that works fine, but I don't have it. Put yours 11 | \ in instead of this one. 12 | float 13 | : ^ 14 | fswap flog f* fexp 15 | ; 16 | -*- 17 | > 18 | := 19 | !0000022B 20 | ( addr -> ) 21 | \ Compiles the following expression storing the results at addr. The expression 22 | \ is terminated by a semicolon. If any thing is not in the operator list, it is 23 | \ considered a variable. You can easily die if you mess up and put a module in 24 | \ as a variable. 25 | float 26 | : := 27 | state c@ 0= abort" Assignment statments are only allowed in compile mode." 28 | >in @ 10 text >in ! 29 | pad 1- buff 150 move \ Save the expression for error messages. 30 | ['] abort 64 31 | express 32 | drop drop drop drop 33 | compile f! 34 | 1 >in +! 35 | ; immediate 36 | -*- 37 | v 38 | PP 39 | !0000024D 40 | \ This is a debugging print routine. 41 | 42 | 43 | : pp 0 \ <<<--- If this is a 1, run time trace occurs on expressions. 44 | \ is a 2, the postfix expression is printed. 45 | \ is none of the above, nothing happens. 46 | 47 | dup 1 = if \ Run time debugging. 48 | drop 49 | [compile] literal compile count compile type 50 | compile .s 51 | compile key compile drop 52 | else 53 | 2 = if \ Compile time debugging 54 | count type 55 | else 56 | drop \ No debugging. 57 | endif 58 | endif 59 | ; 60 | -*- 61 | > 62 | BUFF 63 | !00000017 64 | create buff 200 allot 65 | -*- 66 | > 67 | OPLIST 68 | !000001AC 69 | \ ( string -> addr num ) 70 | \ Returns the address and number of the operator or identifier. 71 | \ Operator Num 72 | \ -------------- 73 | \ constant 0 74 | \ variable 8 75 | \ + 16 76 | \ - 24 77 | \ * 32 78 | \ / 40 79 | \ ( 48 80 | \ ) 56 81 | \ ; 64 82 | \ [ 72 83 | \ ] 80 84 | \ ^ 88 85 | define oplist 86 | -*- 87 | v 88 | DEFINE 89 | !000004DB 90 | float 91 | : define 92 | create \ Create the module. 93 | here \ Address of number of entries. 94 | 0 , \ Number of entries spot. 95 | here \ Addr of beginning of list. 96 | " +" , ['] f+ , \ All arithmetic is done in floating point. 97 | " -" , ['] f- , 98 | " *" , ['] f* , 99 | " /" , ['] f/ , 100 | " (" , ['] abort , \ Left paren. 101 | " )" , ['] abort , \ Right paren. 102 | " ;" , ['] abort , \ End of statement marker. 103 | " [" , ['] abort , \ Begin subscript (or function) marker. 104 | " ]" , ['] abort , \ Close subscript (or function) marker. 105 | " ^" , ['] ^ , \ You must supply exponent routine. 106 | here swap - \ Compute length of list. 107 | swap ! \ Save this away. (Number of entries = length/8) 108 | does> 109 | dup 4 + swap @ 0 do 110 | stack ab|abab @ str= if 111 | swap drop 4 + @ i 16 + exit 112 | endif 113 | 8 + 114 | 8 +loop 115 | drop dup find 116 | -1 = if stack ab|b 8 exit \ Token 117 | else a->i swap c@ 0= if stack ab|b i->f 0 exit endif \ Integer 118 | drop a->f s->f c@ 0= if 0 exit endif \ Float 119 | endif 120 | 0 24 gotoxy cr cr buff count type cr 121 | ." Token Not Found error in := statement: " count type cr cr abort 122 | ; 123 | -*- 124 | v 125 | STR= 126 | !00000101 127 | ( str1 str2 -> flag ) 128 | \ flag = -1 if str1 = str2 129 | \ otherwise flag = 0 130 | : str= 131 | over c@ 1+ 0 do \ For 0 to character count do: 132 | over c@ over c@ = 133 | if else drop drop 0 exit endif 134 | 1+ swap 1+ 135 | loop 136 | drop drop -1 137 | ; 138 | -*- 139 | ^ 140 | ^ 141 | > 142 | PREC 143 | !0000000D 144 | define prec 145 | -*- 146 | v 147 | DEFINE 148 | !00000585 149 | : define 150 | create 151 | \ 0 8 16 24 32 40 48 56 64 72 80 88 152 | \ lit var + - * / ( ) ; [ ] ^ 153 | \ +---------------------------------------------------------------------- 154 | ( lit) 15 c, 15 c, 0 c, 0 c, 0 c, 0 c, 15 c, 1 c, 1 c, 15 c, 1 c, 0 c, 155 | ( var) 15 c, 15 c, 0 c, 0 c, 0 c, 0 c, 15 c, 1 c, 1 c, 15 c, 1 c, 0 c, 156 | ( + ) 1 c, 1 c, 1 c, 1 c, 0 c, 0 c, 15 c, 1 c, 1 c, 15 c, 1 c, 0 c, 157 | ( - ) 1 c, 1 c, 1 c, 1 c, 0 c, 0 c, 15 c, 1 c, 1 c, 15 c, 1 c, 0 c, 158 | ( * ) 1 c, 1 c, 1 c, 1 c, 1 c, 1 c, 15 c, 1 c, 1 c, 15 c, 1 c, 0 c, 159 | ( / ) 1 c, 1 c, 1 c, 1 c, 1 c, 1 c, 15 c, 1 c, 1 c, 15 c, 1 c, 0 c, 160 | ( { ) 1 c, 1 c, 0 c, 0 c, 0 c, 0 c, 0 c, 2 c, 15 c, 15 c, 15 c, 0 c, 161 | ( } ) 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 162 | ( ; ) 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 15 c, 3 c, 15 c, 15 c, 0 c, 163 | ( [ ) 1 c, 1 c, 0 c, 0 c, 0 c, 0 c, 0 c, 15 c, 15 c, 15 c, 4 c, 0 c, 164 | ( ] ) 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 165 | ( ^ ) 1 c, 1 c, 1 c, 1 c, 1 c, 1 c, 0 c, 1 c, 1 c, 15 c, 1 c, 0 c, 166 | does> 167 | stack abc|bca 8 / stack abc|bca 8 / 168 | swap 12 * + dup 144 u< if else 169 | 0 24 gotoxy cr 170 | buff count type 171 | ." You have an ill eagle in your := statement " abort 172 | endif 173 | + c@ 174 | ; 175 | -*- 176 | ^ 177 | > 178 | EXPRESS 179 | !0000035C 180 | \ ( -> ) Compiles an expression pointed to by >in. 181 | float 182 | : express 183 | 32 word oplist \ Get a token. 184 | dup 0 = if drop " c" pp [compile] fliteral else \ Compile a constant. 185 | dup 8 = if drop \ This is a variable or array. 186 | array? \ Compile subscripts if an array. 187 | " a" pp 188 | [compile] literal \ Compile execution address. 189 | compile execute compile f@ else \ Compile an EXECUTE and a Fetch. 190 | dup 48 = if express else 191 | dup 56 = if reduce express else \ End of parenthesis? 192 | 0 24 gotoxy cr cr buff count type cr 193 | ." Something is out of order in your := statement! " cr cr abort 194 | endif 195 | endif 196 | endif 197 | endif 198 | 32 word oplist reduce \ Reduce operators. 199 | ; 200 | -*- 201 | v 202 | ARRAY? 203 | !00000205 204 | \ Check to see if we are dealing with an array. If so, evaluate the subscripts. 205 | float 206 | : array? 207 | >in @ 32 word oplist dup 72 = if \ Is it an array? 208 | " [" pp 209 | stack abc|bc \ If so, get rid of the text pointer. 210 | express \ Evaluate the subscript expression. 211 | compile f->i \ Force to integer 212 | else 213 | drop drop >in ! \ Restore the text pointer if it's not 214 | endif \ an array. 215 | ; 216 | -*- 217 | > 218 | REDUCE 219 | !0000037C 220 | \ Reduces an operator. 221 | float 222 | : reduce 223 | stack ABCD|ABCDBD 224 | prec \ Get precedence code. 225 | dup 1 = if \ 1 = Reduce an operator. 226 | stack ABCDE|CDA 227 | " &" pp 228 | [compile] literal compile execute 229 | reduce exit 230 | endif 231 | dup 4 = if \ End a subscript. 232 | " ]" pp 233 | drop drop drop drop drop \ Drop brackets, and 234 | array? exit \ check for more subscripts. 235 | endif 236 | dup 2 = if drop drop drop drop drop exit endif \ Remove paren's from stack. 237 | dup 15 = if \ An ill eagle state found. 238 | 0 24 gotoxy cr cr buff count type cr 239 | ." I can't figure out your := statement. Sorry." cr cr abort 240 | endif 241 | 3 = if exit endif \ End of statement found. 242 | express 243 | ; 244 | -*- 245 | ^ 246 | ^ 247 | > 248 | README 249 | !0000055D 250 | float 251 | : readme 252 | 253 | \ These are some examples of expressions. 254 | 255 | a := 3.5 + 1.0 + -6.7 - 8.001 * 3.5 + 7.6 ; 256 | 257 | \ Every token ( a number, operator, variable ) MUST be seperated by a space. 258 | 259 | 5 0 do 260 | i i->f k f! 261 | 3 d := 7.5 ; 262 | 2 k @ e := 9.6 ; 263 | 3 d := d [ 3 ] + e [ 2 ] [ k ] ; 264 | loop 265 | 266 | \ Notice that to the left of the := you use Fifth code to get the address 267 | \ the results of the expression are to be stored at. 268 | \ Notice how pairs of subscripts can be specified. This is the same as 269 | \ Basic's e(2,5). This is the same notation C uses. The subscripts are 270 | \ handled by the array, NOT by :=. See E ad D's definition. 271 | \ Another limitation is that I can not be used as a subscript. Store I in 272 | \ a convienent variable, then use the variable. 273 | 274 | a := 5. + 2. * 0. ; \ Same as a := 5. + ( 2. * 0. ) ; 275 | c := a + a * 2. ^ 3. ^ 2. ; \ Same as a := a + ( a * ( 2. ^ ( 3. ^ 2. ) ) ) ; 276 | 277 | \ The order of operations between operators hold. A little "behind the scenes" 278 | \ explaination is in order now. What does the := module do? Given the 279 | \ following: 280 | \ 281 | \ := 4. + 3. * 7. 282 | \ 283 | \ The := module compiles the code to do: 284 | \ 285 | \ 4. 3. 7. f* f+ f! 286 | \ 287 | \ Thus If you neglect to leave a valid address on the stack, := is going to 288 | \ blow up. Also, if you specify a procedure instead of a variable, your 289 | \ system will most likely crash. 290 | ; 291 | -*- 292 | v 293 | A 294 | !00000013 295 | float fvariable a 296 | -*- 297 | > 298 | B 299 | !00000013 300 | float fvariable b 301 | -*- 302 | > 303 | C 304 | !00000013 305 | float fvariable c 306 | -*- 307 | > 308 | D 309 | !000000A8 310 | ( subscript -> address ) 311 | \ D is a 10 element array. See DEFINE below for D's definition. 312 | \ Takes the subscript and returns the address of that element. 313 | 314 | define d 315 | -*- 316 | v 317 | DEFINE 318 | !000002CD 319 | \ The execution of this module will create a array which takes a subscript 320 | \ from the stack and returns the address of that element. 321 | 322 | : define 323 | create \ Create a module. 324 | 10 10 * allot \ Allot room for 10 elements, 10 bytes each. 325 | does> \ Define this module's run time behavior. 326 | \ ( Remember that the address of beginning of the 10 327 | \ elements allotted above has been pushed on the 328 | \ stack prior to this code. ) 329 | 330 | swap dup 10 u< if else \ Do range checking. 331 | ." Out of range" abort 332 | endif 333 | 10 * + \ Multiply the subscript by 10, add to beginning address. 334 | ; 335 | -*- 336 | ^ 337 | > 338 | E 339 | !000000A8 340 | ( subscript subscript -> address ) 341 | \ Expects two subscripts, returns address of the specified element. 342 | \ E is a 5x5 array. See DEFINE for the definition. 343 | define e 344 | -*- 345 | v 346 | DEFINE 347 | !000003A6 348 | \ The execution of this module will create a array which takes two subscripts 349 | \ from the stack and returns the address of that element. 350 | 351 | : define 352 | create \ Create a module. 353 | 5 5 * 10 * allot \ Allot room for a 5x5 array, each element is 10 bytes. 354 | does> \ Define this module's run time behavior. 355 | \ ( Remember that the address of beginning of the 356 | \ first element has been pushed on the stack 357 | \ on top of the subscripts prior to the execution 358 | \ of this code. ) 359 | stack abc|cabab \ Put subscripts on top of stack, address on bottom. 360 | 5 u< swap 5 u< and \ Are both subscripts under 5? 361 | if else \ If not, you have an error. 362 | ." Out of range" abort 363 | endif 364 | 5 * + 10 * + \ Multiply the subscript by 10, add to beginning address. 365 | ; 366 | -*- 367 | ^ 368 | > 369 | K 370 | !00000013 371 | float fvariable k 372 | -*- 373 | ^ 374 | ^ 375 | -------------------------------------------------------------------------------- /bld.fiv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/bld.fiv -------------------------------------------------------------------------------- /cond.fiv: -------------------------------------------------------------------------------- 1 | FIFTH 2 | !00000000 3 | -*- 4 | > 5 | }ENDIF 6 | !00000043 7 | \ End a IF{ ... }ELSE{ ... }ENDIF construct 8 | : }endif ; immediate 9 | -*- 10 | > 11 | }ELSE{ 12 | !000000DF 13 | \ Select the false-body code of IF{ ... }ELSE{ ... }ENDIF construct. 14 | : }else{ 15 | begin 16 | 0 word dup count 0= if ." Missing }ENDIF" abort endif drop 17 | find abs 1- if drop 0 endif 18 | ['] }endif = until 19 | ; immediate 20 | -*- 21 | > 22 | IF{ 23 | !00000157 24 | \ A compile-time, or from interactive level, skip sections of code. 25 | \ This allows conditional compilation. IF{ ... }ELSE{ ... }ENDIF 26 | : if{ 27 | if exit else 28 | begin 29 | 0 word dup count 0= if ." Missing }ENDIF" abort endif drop 30 | find abs 1- if drop 0 endif 31 | dup ['] }endif = swap ['] }else{ = or until 32 | endif 33 | ; immediate 34 | -*- 35 | > 36 | ` 37 | !000001BB 38 | \ Takes the next character in the input stream and generates the its ASCII 39 | \ value. If the compiler is on, the code to push this ASCII representation 40 | \ onto the stack is generated. A compile error occurs if back-tic is followed 41 | \ by more than one character. 42 | 43 | : ` 44 | 0 word count 1- abort" ASCII error" \ Test for 1 character found 45 | c@ \ Get character 46 | state if [compile] literal endif \ Literlize if compiling 47 | ; immediate 48 | -*- 49 | > 50 | H# 51 | !00000152 52 | \ Generate an inline HEX constant, a state sensitive word. 53 | 54 | : h# 55 | base c@ hex \ Get the current radix, set to hex 56 | 0 word a->i swap drop \ Get the numeric value of what follows 57 | swap base c! \ Restore the radix 58 | state if \ Compiling? 59 | [compile] literal \ Compile inline literal 60 | endif \ Not compiling! 61 | ; immediate 62 | -*- 63 | > 64 | HELP 65 | !0000061A 66 | \ ( -> ) HELP parses a help entry from the input stream, and displays help. 67 | \ Some entries allow further help. HELP uses a string stack to keep up with 68 | \ control between sub helps and so forth. At compile time, NAMES is filled with 69 | \ an offset table. At run time, HELP looks up the text entry, and displays it. 70 | : help 71 | eflg @ -1 = if ['] names comp endif \ Recompile names if needed. 72 | helpfile 0 open \ Open the helpfile. 73 | 0= if drop err exit endif \ If an error, abort. 74 | h ! \ Save handle of the helpfile. 75 | 0 word dup c@ 0= if \ Check and see if nothing follows. 76 | drop " GEN-HELP" \ If nothing follows, replace with HELP. 77 | endif 78 | dup a->i drop c@ 0= if \ Check to see if string is a number. 79 | drop " INTEGERS" \ Integer. 80 | endif \ Neither 81 | 1 cnt ! \ Set the nexting count to one. 82 | begin 83 | search \ Display help. 84 | ?dup 0= if -1 cnt +! else \ If the name is not found, back up a level. 85 | dup 32 = over 27 = or over 13 = or if \ Check if exit is desired... 86 | stack abc| -1 cnt +! \ Back help up a level. 87 | else 88 | 97 - stack ab|baba c@ u< \ Compute # items picked; Do a range check. 89 | if 90 | 4 + swap \ Pass up the item count. 91 | begin ?dup while 1- >r \ Scan for # items (hide # on return stk.) 92 | dup 3000 0 scan + r> 93 | repeat 94 | 1 cnt +! \ Increment the nexting level. 95 | else 96 | drop drop \ If out of range, ignore. 97 | endif endif endif 98 | cnt @ 0= until \ So long as cnt > 0, do it. 99 | h @ close if else drop endif 100 | ; 101 | -1 eflg ! 102 | -*- 103 | v 104 | CNT 105 | !0000005D 106 | \ count of how deep help is nested. If this cnt falls to zero, help returns. 107 | variable cnt 108 | -*- 109 | > 110 | EFLG 111 | !00000012 112 | create eflg -1 , 113 | -*- 114 | > 115 | HELPFILE 116 | !00000123 117 | \ ( -> addr ) addr points to the null ended string giving the path and 118 | \ the name of the help file. The file BLD.FIV contains the code used to 119 | \ build this file. 120 | : helpfile 121 | " fifth.hlp" \ Returns pointer to a counted string 122 | 1+ \ Increment past the count byte. 123 | ; 124 | -1 eflg ! 125 | -*- 126 | > 127 | NCNT 128 | !00000050 129 | \ Names CouNT. Count of the number of entries in the help file. 130 | variable ncnt 131 | -*- 132 | > 133 | NLEN 134 | !00000053 135 | \ Names LENgth. A variable holding the length of the names array. 136 | variable nlen 137 | -*- 138 | > 139 | H 140 | !0000000C 141 | variable h 142 | -*- 143 | > 144 | BOXIT 145 | !000003EC 146 | \ ( addr1 addr2 -> 8b ) 147 | \ Figures out a minimum boxsize and titles the box using addr1, and fills the 148 | \ box with addr2. Returns the ascii code of the key pressed to remove the box. 149 | : boxit 150 | ?term if drop drop key exit endif \ Cheap lookahead 151 | swap title ! \ Save away the title. 152 | 0 >r \ Put the line count on the return stack. 153 | dup \ Make a copy of the address to count lines with. 154 | begin 155 | dup 80 13 scan \ Find the next linefeed 156 | over 2048 0 scan \ Find the end of text 157 | over > \ If the next linefeed is not passed the end of text 158 | over 0= not and if \ and a line feed was found, 159 | + \ Punch the address by the offset 160 | r> 1+ >r \ Increment the line count 161 | 0 \ Keep looking for the end of text. (0 for until) 162 | else drop -1 \ Done! ( -1 for until) 163 | endif 164 | until 165 | drop 166 | r> swap >r >r \ Put address under line count. 167 | 0 24 r> - 2- 79 24 79 30 title @ r> popbox 168 | dup ` A < over ` Z > or 0= if 32 or endif \ force lowercase. 169 | ; 170 | -*- 171 | v 172 | TITLE 173 | !00000010 174 | variable title 175 | -*- 176 | ^ 177 | > 178 | ERR 179 | !00000143 180 | \ ( -> ) Prints an error message. Sets the error flag EFLG . 181 | : ERR 182 | 0 word drop 183 | 3 10 76 13 79 30 184 | helpfile 185 | " HELP could not find this file. Correct the name and/or the path. The 186 | name and path is specified in the module HELPFILE under the module HELP." 187 | 1+ popbox drop 188 | -1 eflg ! \ Indicate an error. 189 | ; 190 | -*- 191 | > 192 | NAMES 193 | !00000013 194 | create names nbld 195 | -*- 196 | v 197 | NBLD 198 | !00000380 199 | \ ( -> ) Names list BuiLD routine. 200 | \ Builds the name list. Sets the value of NCNT and NLEN. 201 | \ Following the names list is the list of file offsets for each entry. 202 | : nbld 203 | helpfile 0 open \ Open the help file 204 | 0= if 205 | drop exit \ If I did not succeed, Indicate an error. 206 | endif 207 | h ! \ Save the file handle 208 | nlen 4 h @ read drop drop \ Read names length (assume the read worked). 209 | ncnt 4 h @ read drop drop \ Read entry count (assume the read worked). 210 | ncnt @ 2 < if err endif \ I insist on at least two entries! 211 | nlen @ 10 + allot \ Allocate room for the names list. 212 | ncnt @ 4 * allot \ Allocate room for the file offsets. 213 | names nlen @ ncnt @ 4 * + \ Read in the names list and the file offsets 214 | h @ read drop drop \ (assume as above). 215 | h @ close if else drop endif \ Close the file (assume close succeeds). 216 | 0 eflg ! \ Indicate that all is well! 217 | ; 218 | -*- 219 | ^ 220 | > 221 | SEARCH 222 | !0000040B 223 | \ ( addr1 -> addr2 addr3 8b ) Searches names for a match with addr1. If found, 224 | \ displays the text in a popbox. Returns addr3, the address of the menu list 225 | \ and addr2, the address of the name in the names array. 226 | \ (or a null (zero) if the entry is not found). 227 | : search 228 | names 229 | ncnt @ 0 do \ For each name in the names list 230 | over over str= if 231 | stack ab|bb \ If found, use names addr's; they stay good. 232 | names nlen @ + i 4 * + @ \ Get the file offset. 233 | 0 h @ seek drop drop \ Seek to the text (assume success). 234 | buff 3000 h @ read drop drop \ Read in the text (assume success). 235 | buff 3000 0 scan buff + \ Compute address of menu list. 236 | swap 1+ buff boxit \ Skip count byte of entry name, display box. 237 | ?dup 0= if -1 endif exit \ Insure I don't return a null here. 238 | endif 239 | dup c@ + 2 + \ If not found, increment to the next name. 240 | loop 241 | drop 1+ \ Drop names address; Print not found message. 242 | " I could not find this entry" 1+ boxit drop 0 \ Return a null. 243 | ; 244 | -*- 245 | v 246 | BUFF 247 | !00000040 248 | \ Create a buffer to hold a menu entry 249 | create buff 3000 allot 250 | -*- 251 | ^ 252 | ^ 253 | > 254 | DO{ 255 | !00000106 256 | \ A compile-time, or from interactive level, loop sections of code. 257 | \ This allows conditional compilation. term start DO{ ... }LOOP 258 | \ Values on return stack! 259 | : do{ 260 | r> >in @ >r stack abc|cba >r >r >r \ Setup index, terminator, backup for loop 261 | ; immediate 262 | -*- 263 | > 264 | }LOOP 265 | !000001F7 266 | \ A compile-time, or from interactive level, loop sections of code. 267 | \ This allows conditional compilation. term start DO{ ... }LOOP 268 | \ Parms on return stack as: loop-addr 269 | \ term 270 | \ index 271 | \ return-from-}LOOP 272 | : }loop 273 | r> r> 1+ r> stack ab|abab = \ Fetch return, index+1, term, test for exit. 274 | if r> drop drop drop >r exit endif \ Drop loop-addr, all, stuff return back. 275 | r@ >in ! \ Backup input pointer 276 | >r >r >r \ stuff all back to return stack 277 | ; immediate 278 | -*- 279 | > 280 | BEGIN{ 281 | !000000EE 282 | \ A compile-time, or from interactive level, loop sections of code. 283 | \ This allows conditional compilation. term start BEGIN{ ... }UNTIL 284 | \ Values on return stack! 285 | : begin{ 286 | r> >in @ >r >r \ Setup backup address for loop 287 | ; immediate 288 | -*- 289 | > 290 | }UNTIL 291 | !000001A5 292 | \ A compile-time, or from interactive level, loop sections of code. 293 | \ This allows conditional compilation. term start BEGIN{ ... }UNTIL 294 | \ Parms on return stack as: loop-addr 295 | \ return-from-}UNTIL 296 | : }until 297 | if r> r> drop >r exit endif \ Drop loop-addr, stuff return back, exit. 298 | r> \ Fetch return. 299 | r@ >in ! \ Backup input pointer 300 | >r \ stuff return address back to return stack 301 | ; immediate 302 | -*- 303 | > 304 | }REPEAT 305 | !000000A4 306 | \ Compile and interpretive execution of code. 307 | \ Used as BEGIN{ ... }WHILE{ .. }REPEAT 308 | : }REPEAT 309 | r> r@ >in ! >r \ Move text pointer to loop start 310 | ; immediate 311 | -*- 312 | > 313 | }WHILE{ 314 | !000001A8 315 | \ A compile-time, or from interactive level, skip sections of code. 316 | \ This allows conditional compilation. BEGIN{ ... }WHILE{ ... }REPEAT 317 | : }while{ 318 | if exit else 319 | r> r> drop >r \ Drop loop start address from return stack 320 | begin \ Search for closing }REPEAT 321 | 0 word dup count 0= if ." Missing }REPEAT" abort endif drop 322 | find abs 1- if drop 0 endif 323 | ['] }repeat = until 324 | endif 325 | ; immediate 326 | -*- 327 | ^ 328 | -------------------------------------------------------------------------------- /dump.fiv: -------------------------------------------------------------------------------- 1 | DUMP 2 | !000002FC 3 | \ Hex dump a module 4 | \ Usage: dump module 5 | : dump 6 | base @ oldbase ! 16 base ! 7 | 0 q ! cr 8 | ' dup dup getsize + swap do \ Loop thru module 9 | q @ 0= if \ Start of line 10 | i <# # # # # # # # # #> type ." : " \ Address at line start 11 | endif 12 | i c@ dup <# # # #> type space \ Print a hex byte 13 | line q @ + c! 1 q +! \ Save byte in LINE 14 | q @ 16 = if \ Got a complete line? 15 | space ascii \ Make room for ASCII 16 | 0 q ! \ Ready for next line 17 | endif 18 | loop \ End of module 19 | q @ ?dup if \ Half done last line? 20 | 16 swap - 3 * 1+ spaces ascii \ Skip over to ASCII 21 | endif 22 | cr oldbase @ base ! 23 | ; 24 | -*- 25 | v 26 | OLDBASE 27 | !00000012 28 | variable oldbase 29 | -*- 30 | > 31 | LINE 32 | !00000016 33 | create line 16 allot 34 | -*- 35 | > 36 | Q 37 | !0000000C 38 | variable q 39 | -*- 40 | > 41 | ASCII 42 | !0000010A 43 | : ascii 44 | q @ 0 do \ Loop thru line 45 | line i + c@ dup 32 < over 127 > or if 46 | drop 46 \ Replace unprintable with decimal 47 | endif emit \ Show ASCII 48 | loop cr \ End of line, ready for next 49 | ; 50 | -*- 51 | ^ 52 | -------------------------------------------------------------------------------- /fifth.hlp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/fifth.hlp -------------------------------------------------------------------------------- /forth83.fiv: -------------------------------------------------------------------------------- 1 | FORTH83 2 | !00000966 3 | ( 4 | This program will convert a MVP-Forth-83 ASCII file to a Fifth file. The file 5 | contains 64 bytes per line, with no CR/LF`s, 1024 bytes per block. The file 6 | consists of concatenated screens. 7 | 8 | The conversion process is by no means complete. Some of the worst errors may 9 | have to be editted out with a text editor before the file can be loaded into a 10 | Fifth system. Once inside Fifth, several of the MVP functions are handled 11 | differently than Fifth. Some of these are listed here: 12 | 13 | Fifth requires 1 definition per module: With Forth code it can be difficult 14 | to tell which module a section of code belongs too. This program guesses, 15 | and may guess wrong. Be especially wary of initilization code and comments, 16 | which can end up in the wrong module. 17 | VOCABULARIES: Fifth uses a different structure than the standard VOCABULARY. 18 | You may find it more convient to rewrite your program in Forth to remove 19 | the VOCABULARY. If you want to remove the VOCABULARY from Fifth, a good 20 | understanding of Fifth's scoping is nessecary. 21 | PFA, CFA: Fifth dosn't deal with PFA and CFA addresses per se, close 22 | inspection of the MVP code may be in order. 23 | Recursion: Fifth handles recursion automatically. There is no need for a 24 | word to allow recursion. 25 | Clearing the screen, moving the cursor: Fifth has a set of screen i/o 26 | routines that use the IBM BIOS. Some MVP functions use ANSI standard. This 27 | requires ANSI.SYS in your CONFIG.SYS file during booting. 28 | LOAD, --> : Fifth dosn't use screens and blocks. If your file loads in other 29 | than sequential order, this program get's in trouble! It dosn't understand 30 | references to screens and blocks, and will merrily put the commands with 31 | some nearby module. 32 | Forth-83 vs Forth-79: Fifth is very close the the Forth-83 standard. 33 | Differences between the standards may cause you problems. For instance, 34 | STACK? in Forth-79 causes an abort if the stack has underflowed, in Forth-83 35 | STACK? leaves a flag on the stack. 36 | Fifth vs Forth-83: There are some name changes between Forth-83 and Fifth. 37 | For instance THEN's in Forth-83 are ENDIF's in Fifth. 38 | 39 | Your own Forth system will undoubtly have a lot of kernal words not in the 40 | Fifth system. If you are doing lots of conversions, you may want to build up 41 | a file of Fifth routines similiar to what's in your system. 42 | 43 | ) 44 | : Forth83 doit ; 45 | -*- 46 | v 47 | DOIT 48 | !000001D9 49 | \ This routine asks for a file name, with an assumed extension of .4TH. It 50 | \ opens this file, and the output file with extension .FIV. Then does the 51 | \ conversion. 52 | : doit 53 | 54 | open-file \ Open both files 55 | 56 | " CREATE FROM-83" 1+ wrtstr 57 | 58 | conversion \ Convert 59 | 60 | " ABORT" 1+ wrtstr \ Write the string, CR/LF terminated 61 | 62 | in-file @ close if else drop endif 63 | out-file @ close if else drop endif 64 | cr cr ." Hit a key..." key drop 65 | ; 66 | -*- 67 | v 68 | IN-FILE 69 | !00000027 70 | \ Input file handle 71 | variable in-file 72 | -*- 73 | > 74 | OUT-FILE 75 | !00000029 76 | \ Output file handle 77 | variable out-file 78 | -*- 79 | > 80 | OPEN-FILE 81 | !000003AE 82 | \ Asks for a name, then opens the file for reading. Also opens the output file 83 | 84 | : open-file 85 | 86 | begin \ Get names until or can open 87 | ask-name cr \ Get name 88 | name-buf 0 open if \ Opened okay 89 | in-file ! \ Save input file handle 90 | " .FIV" 1+ \ Output extension 91 | name-buf len @ + 5 move \ Fix filename 92 | name-buf 0 createfile \ Make output file 93 | if out-file ! exit \ Save handle, exit 94 | else drop cr cr 7 emit \ Can't create output file 95 | ." Can't make " name-buf len @ 4 + type ." !" 96 | 30000 0 do loop 97 | in-file @ close if else drop endif 98 | endif 99 | else \ Can't open input file 100 | drop cr cr 7 emit \ Beep at 'em 101 | ." Can't find " name-buf len @ 4 + type ." !" 102 | 30000 0 do loop 103 | endif 104 | 0 until 105 | ; 106 | -*- 107 | v 108 | NAME-BUF 109 | !00000040 110 | \ This is the input file-name buffer 111 | create name-buf 60 allot 112 | -*- 113 | > 114 | LEN 115 | !00000026 116 | \ Length of typed name 117 | variable len 118 | -*- 119 | > 120 | ASK-NAME 121 | !00000399 122 | \ Politly ask for a file name 123 | : ask-name 124 | 125 | cls 0 6 gotoxy 126 | ." The file name can be a complete path-name." cr 127 | ." An extension of .4TH is assumed for the input file, and" cr 128 | ." an extension of .FIV is assumed for the output file." cr 129 | ." Please enter a file name, or type to abort." cr cr 130 | ." Name: " 131 | name-buf 50 expect 132 | dup 0= if abort endif \ Abort if CR hit 133 | dup len ! \ Store name length 134 | ` . scan \ Look for a decimal 135 | ?dup if \ Found one? 136 | 0 name-buf len @ + c! \ Add a trailing null 137 | 1- len ! \ Make LEN point to decimal 138 | else \ Didn't find a decimal! 139 | " .4TH" 1+ name-buf len @ + \ Compute where to put extension 140 | 5 move \ Put extension (+1 for trailing null) 141 | endif 142 | ; 143 | -*- 144 | ^ 145 | > 146 | WRTSTR 147 | !000001C6 148 | \ (addr -> ) Writes a null terminated string, and a CR/LF 149 | : wrtstr 150 | 151 | dup -1 0 scan 1- \ Length to write 152 | out-file @ write if \ Write it 153 | drop \ Assume wrote okay length 154 | else ." Error writing:" . cr \ Write error 155 | endif 156 | 157 | crlf 2 out-file @ write if \ Write CR/LF 158 | drop \ Assume wrote okay length 159 | else ." Error writing:" . cr \ Write error 160 | endif 161 | 162 | 163 | ; 164 | -*- 165 | v 166 | CRLF 167 | !00000022 168 | \ CR/LF 169 | create crlf 13 c, 10 c, 170 | -*- 171 | ^ 172 | > 173 | STR= 174 | !0000018A 175 | \ Compare two null terminated strings, returns TRUE/FALSE 176 | \ (addr1 addr2 --> Flag) 177 | : str= 178 | 179 | begin 180 | dup c@ 2 pick c@ - if \ Not equal chars? 181 | drop drop 0 exit \ Exit FALSE 182 | endif 183 | dup c@ while \ While not end of string(s) 184 | 1+ swap 1+ \ Bump to next char 185 | repeat 186 | drop drop 1 \ Compared till EOS 187 | ; 188 | -*- 189 | > 190 | CONVERSION 191 | !000010D8 192 | \ This module is the workhorse of the program. It reads from the input file, 193 | \ converts, and writes to the output file. 194 | 195 | : conversion 196 | 197 | 2 create? 2 f83->5th \ Reset CREATE list, Conversion list 198 | modbuf modsiz ! \ Reset 1st module size 199 | 0 scanning c! \ Not scanning for end of comments 200 | 1 mode ! \ Pre-module starting mode 201 | inbuf inptr ! 0 inbuf ! \ Start at input start, input empty 202 | 0 linecnt ! 0 blockcnt ! \ Start at file start 203 | 204 | begin \ Read all of input 205 | ?stack abort" Stack underflow" 206 | scanning c@ if \ Scanning? 207 | inptr @ 64 scanning c@ scan 208 | dup if \ Found it? (Leave on stack) 209 | dup inptr +! \ Yes, bump input past it 210 | endif \ Return EOL flag 211 | else \ Not scanning, parse a word out 212 | inptr @ i->d dup >r >in ! \ Setup as input stream, leave on stack 213 | 0 word dup token ! c@ \ Parse & store the token, return EOL flag 214 | >in @ r> - inptr +! \ Advance inptr by as much 215 | endif \ Stack contains EOL flag 216 | 217 | 0= if \ True if EOL 218 | mode @ 3 = if \ Looking for EOL at definition end? 219 | wrimod 1 mode ! \ Write the finished module, reset mode 220 | endif \ 221 | inquery 0= if \ Read a new line, EOF? 222 | Eof-error \ Eof error handling 223 | exit \ End of File, End of Routine, Exit! 224 | endif 225 | else \ Not an EOL 226 | scanning c@ if \ Was scanning? 227 | 0 scanning c! \ Yes, found scan char so stop 228 | else mode @ 3 > if \ Mode=4,5? Looking for a module name? 229 | modname 7 + token @ count 1+ stack abc|bac move \ Copy into MODNAME 230 | mode @ 4 = if \ CONSTANT or VARIABLE? 231 | 3 \ Yes, mode is End-Of-Module to End-Of-Line 232 | else 2 endif \ Must have been a colon defintion, find code 233 | mode ! \ Set new mode 234 | else \ Just a generic token, interpret it 235 | token @ dup " \" str= if \ Token is a backslash comment? 236 | drop inbuf inptr ! 0 inbuf ! \ Wipe out rest of line 237 | else dup str1 str= \ Token is dot-quote? 238 | over str2 str= or if \ or quote? 239 | drop ` " scanning c! \ Yes, scanning for closing quote 240 | else dup dup " .(" str= swap " (" str= or if 241 | drop ` ) scanning c! \ Yes, scanning for closing paren 242 | else dup " ;" str= if \ Token is semi-colon? 243 | drop mode @ 2 = if 3 mode ! endif \ Yes, mark end of module def 244 | else \ Nice token 245 | token @ 0 f83->5th \ Convert to 5th token, if needed 246 | 0 create? if \ Creating word? 247 | mode @ dup 1 = if drop \ Local for a module start? 248 | token @ dup 1 f83->5th \ Remove personal def's from list 249 | " :" str= if \ Colon definition? 250 | 5 \ Yes, use colon definition mode 251 | else 4 endif \ No, CONSTANT, CREATE, VARIABLE mode 252 | mode ! \ Set new mode 253 | else 2 = if \ Mode = 2? Module can create modules? 254 | modname 7 + i->d >in ! \ Store module name in input stream 255 | 0 word 1 create? \ Parse, pass length-byte string to C? 256 | else \ Mode = 3! Multiple def's per line 257 | token @ count negate inptr +! drop \ Back up input pointer 258 | inptr @ inbuf - modline @ + modsiz ! \ Back up module size 259 | 0 modsiz @ c! wrimod \ End module here (not at EOL), write 260 | inptr @ modline @ \ Src, Dest 261 | inptr @ -1 0 scan move \ Characters to move 262 | 1 mode ! \ Ready for next module 263 | endif endif 264 | endif 265 | endif endif endif endif 266 | endif endif 267 | endif 268 | 269 | 0 until 270 | 271 | 272 | ; 273 | -*- 274 | v 275 | LINECNT 276 | !0000002C 277 | \ Count of line in block 278 | variable linecnt 279 | -*- 280 | > 281 | BLOCKCNT 282 | !0000002D 283 | \ Count of block in file 284 | variable blockcnt 285 | -*- 286 | > 287 | MODNAME 288 | !0000008E 289 | \ Module name buffer 290 | create MODNAME 291 | ` C c, 292 | ` R c, 293 | ` E c, 294 | ` A c, 295 | ` T c, 296 | ` E c, 297 | 32 c, 298 | 0 c, \ Module name starts here... 299 | 80 allot 300 | -*- 301 | > 302 | INBUF 303 | !0000002F 304 | \ Input & parse buffer 305 | create inbuf 80 allot 306 | -*- 307 | > 308 | INPTR 309 | !00000028 310 | \ Input buffer pointer 311 | variable inptr 312 | -*- 313 | > 314 | MODBUF 315 | !00000035 316 | \ Accumalted module code 317 | create modbuf 10000 allot 318 | -*- 319 | > 320 | MODSIZ 321 | !00000023 322 | \ Size of MODBUF 323 | variable modsiz 324 | -*- 325 | > 326 | MODLINE 327 | !00000057 328 | \ Start of last line read into MODBUF, multple definitions per line 329 | variable modline 330 | -*- 331 | > 332 | MODE 333 | !00000031 334 | \ State of my state machine, 1-4 335 | variable mode 336 | -*- 337 | > 338 | SCANNING 339 | !00000061 340 | \ Contains a end-comment character, if I'm scanning for the end if a comment 341 | variable scanning 342 | -*- 343 | > 344 | INQUERY 345 | !00000321 346 | \ This module reads a 64 byte line into the input buffer, after appending 347 | \ a CR/LF. WORD and TEXT may be used to parse out the input. It returns a 348 | \ true, or a false at end-of-file or other read error. 349 | : inquery 350 | 351 | linecnt @ 1+ dup 15 > if 352 | drop 1 blockcnt +! 0 353 | 10 12 gotoxy ." Block: " blockcnt @ . 354 | endif linecnt ! 355 | inbuf 64 in-file @ read if \ Read a line 356 | dup 0= if exit endif \ EOF detection, return a zero 357 | dup end-line \ Strip trailing whitespace, add cr/lf 358 | 64 = if \ Short read? 359 | 1 \ No, alls fine, exit. 360 | else ." Input file size not a multple of 64 bytes." cr 1 361 | endif \ Return, keep reading 362 | else ." Error reading input file: " . cr 0 363 | endif 364 | 365 | ; 366 | -*- 367 | v 368 | END-LINE 369 | !000003A4 370 | \ (size -> ) Remove trailing whitespace from an input line, null terminate 371 | : end-line 372 | 373 | dup inbuf + \ Generate end-buffer address 374 | swap ?dup if \ Check for short line 375 | 0 do \ Till non-space 376 | 1- \ Pre-decrement 377 | dup c@ 32 = not \ 378 | if 1+ leave endif \ Until not a space 379 | loop 380 | endif 381 | 13 over c! 1+ \ Add missing CR/LF 382 | 10 over c! 1+ \ 383 | 0 over c! \ Store null 384 | inbuf - \ Size of line just read 385 | dup modsiz @ modbuf - + 10000 > abort" Module greater than 10000 chars!" 386 | modsiz @ dup modline ! \ Store start of new line 387 | inbuf stack abc|acba 1+ move \ Account for trailing null, copy into MODBUF 388 | modsiz +! \ Advance by size 389 | inbuf inptr ! \ Setup as input stream 390 | ; 391 | -*- 392 | ^ 393 | > 394 | CREATE? 395 | !000004E6 396 | \ Tests for, or adds a token to the CREATE list 397 | \ ( 2 -> ) Inits CREATE list 398 | \ (addr 1 -> ) Adds token to CREATE list 399 | \ (addr 0 -> flag) Tests for token in CREATE list 400 | : create? 401 | 402 | dup 2 = if drop \ Initing CREATE list 403 | clist csize ! \ Zero size 404 | " :" 1 create? \ Add colon 405 | " CONSTANT" 1 create? \ Add CONSTANT 406 | " VARIABLE" 1 create? \ Add VARIABLE 407 | " CREATE" 1 create? \ Add CREATE 408 | " VOCABULARY" 1 create? \ Add VOCABULARY 409 | else if \ Adding? 410 | count 1+ dup >r \ Get size, adding for trailing null 411 | csize @ swap move \ Copy into buffer 412 | r> csize +! \ Bump by size 413 | else \ Must be checking 414 | 1+ clist \ Skip past size byte, start at start 415 | begin \ Loop thru all 416 | dup csize @ < while \ While not past end of list 417 | stack ab|abab str= if \ Test for string equality 418 | drop drop 1 exit \ YES! Found it, so return TRUE. 419 | endif \ Oops, not today... 420 | dup 1000 0 scan + \ Skip to next string 421 | repeat \ Repeat search 422 | drop drop 0 \ Drop failed search string, exit FALSE 423 | endif endif 424 | 425 | ; 426 | -*- 427 | v 428 | CLIST 429 | !00000038 430 | \ List(s) of CREATE'ing words 431 | create clist 1000 allot 432 | -*- 433 | > 434 | CSIZE 435 | !00000020 436 | \ Size of list 437 | variable csize 438 | -*- 439 | ^ 440 | > 441 | WRIMOD 442 | !0000013C 443 | \ Write the module in MODBUF to the disk. 444 | : wrimod 445 | modname wrtstr \ Write the 'CREATE modname' 446 | " EDIT" 1+ wrtstr \ Write EDIT 447 | modbuf wrtstr \ Write module body 448 | tildeup wrtstr \ Write tildeUP 449 | modbuf dup modsiz ! modline ! \ Reset MODBUF 450 | 451 | ; 452 | -*- 453 | v 454 | TILDEUP 455 | !00000068 456 | \ We can't have a tilde in the source file, so I cheat here 457 | create tildeup 458 | 126 c, ` U c, ` P c, 0 c, 459 | -*- 460 | ^ 461 | > 462 | TOKEN 463 | !00000036 464 | \ This is the parsed token from WORD 465 | variable token 466 | -*- 467 | > 468 | EOF-ERROR 469 | !00000425 470 | \ End of file error handling 471 | : Eof-error 472 | 473 | cr scanning c@ ?dup if \ Scanning? 474 | ." Error: End of file before closing " emit ." ." 475 | else 476 | mode c@ dup 1 = if \ Looking for a new module? 477 | ." Finished conversion." \ No error. 478 | else dup 2 = if \ In the middle of a defintion? 479 | ." Error: Module " 480 | modname 7 + dup 80 0 scan 1- type \ Module name under construction 481 | ." definition not completed." 482 | else dup 3 = if \ Internal error 483 | ." Internal Error: Mode = 3 on EOF." 484 | else dup 4 = if \ Ended between creater & name 485 | ." Error: End of file before " 486 | token @ count type ." finds a name to define." 487 | else dup 5 = if \ Ended between colon & name 488 | ." Error: End of file before : finds a name to define." 489 | else \ Bad mode 490 | ." Internal Error: Mode = " mode @ . 491 | endif endif endif endif endif drop \ Drop mode 492 | endif 493 | cr 494 | ; 495 | -*- 496 | > 497 | F83->5TH 498 | !00000902 499 | \ Converts a Forth-83 word to it's Fifth word, if needed. Also removes peronal 500 | \ definitions from list. 501 | \ ( 2 -> ) Inits Convert list 502 | \ (addr 1 -> ) Removes token from Convert list 503 | \ (addr 0 -> ) Converts token in module buffer 504 | : f83->5th 505 | 506 | dup 2 = if drop clist \ Initing Conversion list 507 | " THEN" " endif" add \ The first string MUST be uppercase. 508 | " PAGE" " cls" add \ The second string can be anything, but 509 | " DDUP" " stack ab|abab" add \ I'm using lowercase to distinguish 510 | " ROT" " stack abc|bca" add \ it from the original code. 511 | " 2*" " 1 shl" add 512 | " /LOOP" " +loop" add 513 | 0 swap ! \ End list with nulls 514 | else if \ Removing? 515 | clist begin \ Search for token 516 | dup c@ while \ While not at end of list 517 | stack ab|abab str= if \ Test for string equality 518 | 1+ 32 swap c! drop \ Blank out first character 519 | endif \ Oops, not today... 520 | count + 1+ count + 1+ \ Skip to next string pair 521 | repeat \ Repeat search 522 | drop drop \ Drop failed search string, exit 523 | else \ Must be Converting 524 | clist \ Start at start 525 | begin \ Loop thru all 526 | dup c@ while \ While not at end of list 527 | stack ab|abab str= if \ Test for string equality 528 | stack ab|bb c@ modsiz @ inptr @ -1 0 scan 1- - 529 | stack ab|abba - dup >r \ Stack: otok osiz src dest, Return: dest 530 | modsiz @ 2 pick - 1+ dup >r \ Stack: otok osiz src dest len 531 | move \ Remove old stuff, stack: otok osiz 532 | negate modsiz +! \ Shrink module size by removed token 533 | count + 1+ \ Move to new (replacement) token 534 | count dup modsiz +! \ Add new token size to module length 535 | r> r> stack abcd|adbdcdb + \ Stack: newtok dest osiz dest len dest+osi 536 | swap move move \ Insert a hole, copy token inline 537 | exit 538 | endif \ Oops, not today... 539 | count + 1+ count + 1+ \ Skip to next string pair 540 | repeat \ Repeat search 541 | drop drop \ Drop failed search string, exit 542 | endif endif 543 | 544 | ; 545 | -*- 546 | v 547 | CLIST 548 | !00000037 549 | \ List(s) of Convert'd words 550 | create clist 1000 allot 551 | -*- 552 | > 553 | ADD 554 | !000000F4 555 | \ Add a conversion pair to the conversion list 556 | \ (ptr F83-str 5th-str -> ptr' ) 557 | : add 558 | swap dup c@ 2+ stack abcd|badcad move + \ Copy inline, advance ptr 559 | swap dup c@ 2+ stack abc|acbac move + \ Copy inline, advance ptr 560 | ; 561 | -*- 562 | ^ 563 | > 564 | STR1 565 | !00000049 566 | \ dot-quote string literal 567 | create str1 568 | 2 c, 569 | ` . c, 570 | ` " c, 571 | 0 c, 572 | -*- 573 | > 574 | STR2 575 | !0000003D 576 | \ quote string literal 577 | create str2 578 | 1 c, 579 | ` " c, 580 | 0 c, 581 | -*- 582 | > 583 | NOTES2 584 | !00000D39 585 | create notes2 exit 586 | 587 | This is the state machine for the conversion: 588 | 1: Accumulating whitespace and intro material prior to a module. 589 | 2: Parsing the 'guts' of a colon definition. 590 | 3: Found the end of a definition, comments to EOL are included with 591 | this module. A creating word will end this module before the EOL. 592 | 4: Have found creating word, looking for new module's name. 593 | 5: Found a `:', looking for new module's name. 594 | ): Found a `(' or a `.(' comment, skipping to `)' 595 | ": Found a ." , skipping to a " 596 | 597 | Loop: 598 | If Scanning then Scan for character. 599 | else Parse a word. 600 | 601 | If EOL then 602 | if Mode==3 then 603 | Write local module; mode := 1; 604 | endif 605 | Read line 606 | if EOF then 607 | 1: 608 | 2: Error: End in middle of definition xxx. 609 | 3: Internal error 610 | 4: Error: File ends before xxx finds a name to define. 611 | 5: Error: File ends before `:' finds a name to define. 612 | ): Error: File ends before closing `)' 613 | ": Error: File ends before closing `"' 614 | 615 | If Mode!=1 then Write local module 616 | Write root module 617 | Exit. Done. Fina. 618 | endif 619 | Copy line to MODBUF. 620 | else ; Parse/scan worked 621 | if Scanning then ; Scanning? 622 | Scanning := FALSE ; Found end of comment 623 | else if Mode >= 4 then ; Was parsing module name? 624 | MODNAME := token; ; Got module name 625 | if Mode == 4 then ; CONSTANT or VARIABLE... 626 | Mode := 3; ; End of module 627 | else ; Must have been `:' 628 | Mode := 2; ; Find module gut's 629 | endif ; 630 | else ; No comment or module name parsing... 631 | if token == `\' then ; Line comments 632 | Force EOL ; Skip to EOL 633 | else if token == `."' or `"' ; b type scan ? 634 | Scanning := `"' ; Begin " type scan 635 | else if token == `(' or `.(' ; a type scan ? 636 | Scanning := `)' ; Begin ) type scan 637 | else if token == `;' then ; End of a colon definition? 638 | if Mode==2 then ; During a colon definition? 639 | Mode := 3 ; End module 640 | endif ; Nope, ignore 641 | else ; 642 | Convert F83->5th token ; 643 | if Creating word then ; Starting a defintion? 644 | if Mode == 1 then ; Looking for a module start? 645 | Remove from F83->5th; He's defining a Forth word, don't convert it 646 | if token == `:' then; Start of colon definition? 647 | Mode := 5; ; Look for it's name 648 | else ; Must be CONSTANT or VARIABLE 649 | Mode := 4; ; Look for it's name 650 | endif ; 651 | else if Mode == 2 then; Found a CREATE inside a colon definition? 652 | Make MODNAME a creating word 653 | else ; Must be Mode == 3, two definitions per line 654 | Backup parse before token 655 | Shorten MODBUF ; 656 | Write local module ; 657 | Copy end of MODBUF to start of MODBUF 658 | Mode := 1 ; 659 | endif endif 660 | endif 661 | endif endif endif endif 662 | endif endif 663 | endif 664 | pooL ; End of Loop 665 | -*- 666 | ^ 667 | ^ 668 | ^ 669 | -------------------------------------------------------------------------------- /frac.fiv: -------------------------------------------------------------------------------- 1 | FRAC 2 | !0000000D 3 | : frac go ; 4 | -*- 5 | v 6 | XMAX 7 | !00000027 8 | ( Maximum X value) 9 | 320 constant xmax 10 | -*- 11 | > 12 | YMAX 13 | !00000013 14 | 200 constant ymax 15 | -*- 16 | > 17 | GO 18 | !0000007B 19 | : GO 20 | cls gcls generate 21 | 99 0 do 22 | ?term if key drop abort endif 23 | i 3 mod 1+ i 3 and plot 24 | loop 25 | ; 26 | -*- 27 | v 28 | GCLS 29 | !00000046 30 | : GCLS 4 vmode 31 | 0 0 0 xmax 1- ymax 1- FILLBOX 32 | ; 33 | -*- 34 | > 35 | ARRAY 36 | !0000000E 37 | DEFINE ARRAY 38 | -*- 39 | v 40 | DEFINE 41 | !00000088 42 | : DEFINE CREATE 43 | 16 1024 * ALLOT 44 | DOES> 45 | SWAP DUP 16384 U< IF + ELSE ." Out of range, array" ABORT ENDIF 46 | 47 | ; 48 | -*- 49 | ^ 50 | > 51 | GENERATE 52 | !0000021A 53 | : GENERATE 54 | 2 0 ARRAY C! 55 | 0 1 ARRAY C! \ Changing the ARRAY initial values or 56 | 1 2 ARRAY C! \ 57 | 3 TOP ! \ uncommenting this line and removing the 58 | \ trailing +1 changes the pattern. 59 | 11 0 DO \ | 60 | 1 TOP @ 1- DO \ | 61 | I ARRAY C@ \ V 62 | ( J 3 AND IF 1+ ELSE 1- THEN 3 AND ) 1+ 63 | TOP @ ARRAY C! 1 TOP +! 64 | -1 +LOOP 65 | LOOP 66 | ; 67 | -*- 68 | v 69 | TOP 70 | !0000000E 71 | VARIABLE TOP 72 | -*- 73 | ^ 74 | > 75 | PLOT 76 | !0000017F 77 | ( Color Rotation -> ) 78 | : PLOT 79 | RR ! ( Save rotation) 80 | xmax 2/ X ! ymax 2/ Y ! 81 | x @ y @ ( Initial point, color on stack) 82 | 1 array c@ rr @ + 3 and CURR 83 | 512 1 * 2 DO 84 | I 1- ARRAY C@ RR @ + 3 AND PREV 85 | I ARRAY C@ RR @ + 3 AND CURR 86 | LOOP drop drop drop 87 | ; 88 | -*- 89 | v 90 | X 91 | !0000000C 92 | VARIABLE X 93 | -*- 94 | > 95 | Y 96 | !0000000C 97 | VARIABLE Y 98 | -*- 99 | > 100 | RR 101 | !0000000D 102 | variable rr 103 | -*- 104 | > 105 | PREV 106 | !000000AD 107 | : prev 108 | 109 | dup 0 = if 2 y +! drop exit endif 110 | dup 1 = if -3 x +! drop exit endif 111 | 2 = if -2 y +! exit endif 112 | 3 x +! 113 | ; 114 | -*- 115 | > 116 | CURR 117 | !0000014C 118 | : CURR 119 | dup 0 = if drop 2 y +! L 120 | 2 y +! L exit endif 121 | dup 1 = if drop -3 x +! L 122 | -3 x +! L exit endif 123 | 2 = if -2 y +! L 124 | -2 y +! L exit endif 125 | 3 x +! L 126 | 3 x +! L 127 | ; 128 | -*- 129 | v 130 | L 131 | !000000E7 132 | : L 133 | stack ab|abab ymax u< swap xmax u< and if 134 | else drop drop X @ Y @ exit endif 135 | 136 | moveto dup X @ Y @ 137 | 138 | stack ab|abab ymax u< swap xmax u< and if 139 | else stack abcde|de exit endif 140 | 141 | lineto moveto? 142 | ; 143 | -*- 144 | ^ 145 | ^ 146 | ^ 147 | ^ 148 | -------------------------------------------------------------------------------- /mandel.fiv: -------------------------------------------------------------------------------- 1 | MANDEL 2 | !0000003B 3 | : mandel 4 | gcls 5 | begin 1 while 6 | draw 7 | repeat 8 | key drop 9 | ; 10 | -*- 11 | v 12 | XMAX 13 | !00000027 14 | ( Maximum X value) 15 | 320 constant xmax 16 | -*- 17 | > 18 | YMAX 19 | !00000013 20 | 200 constant ymax 21 | -*- 22 | > 23 | GCLS 24 | !0000004A 25 | : GCLS cls 4 vmode 26 | 0 0 0 xmax 1- ymax 1- FILLBOX 27 | ; 28 | -*- 29 | > 30 | DIS 31 | !00000029 32 | : dis 33 | 34 | 8 0 do 35 | i 0 palette 36 | loop 37 | ; 38 | -*- 39 | > 40 | DRAW 41 | !00000289 42 | \ Exploring the Mandelbrot set 43 | : draw 44 | x gx f- xc f! \ Compute X corner 45 | xmax 0 do 46 | y gy f- yc f! \ Compute Y corner 47 | gx xc f@ f+ xc f! \ New X corner 48 | ymax 0 do \ 49 | gy yc f@ f+ yc f! \ New Y corner 50 | 0. fdup \ Stk: 0 0 51 | 64 cnt ! 52 | 64 1 do 53 | fover fover f* 2. f* yc f@ f+ yt f! 54 | fdup f* fswap fdup f* fover fover f+ 55 | 4. f> if fdrop fdrop i cnt ! leave endif 56 | fswap f- xc f@ f+ yt f@ 57 | loop 58 | cnt @ j i pset 59 | loop drop ?term if key drop abort endif 60 | loop 61 | ; 62 | -*- 63 | v 64 | X 65 | !00000024 66 | \ Real part start 67 | -2. fconstant x 68 | -*- 69 | > 70 | Y 71 | !00000029 72 | \ Imaginary part start 73 | -2. fconstant y 74 | -*- 75 | > 76 | SX 77 | !00000026 78 | \ Size of real part 79 | 4. fconstant sx 80 | -*- 81 | > 82 | SY 83 | !0000002B 84 | \ Size of imagniary part 85 | 4. fconstant sy 86 | -*- 87 | > 88 | GX 89 | !00000038 90 | \ Real pixel gap 91 | sx xmax i->f f/ fconstant gx 92 | -*- 93 | > 94 | GY 95 | !0000003D 96 | \ Imaginary pixel gap 97 | sy ymax i->f f/ fconstant gy 98 | -*- 99 | > 100 | XC 101 | !00000032 102 | \ real corner of pixel in progress 103 | fvariable xc 104 | -*- 105 | > 106 | YC 107 | !00000037 108 | \ imaginary corner of pixel in progress 109 | fvariable yc 110 | -*- 111 | > 112 | CNT 113 | !00000037 114 | \ count of iterations until z explodes 115 | fvariable cnt 116 | -*- 117 | > 118 | XT 119 | !0000000E 120 | fvariable xt 121 | -*- 122 | > 123 | YT 124 | !0000000E 125 | fvariable yt 126 | -*- 127 | ^ 128 | ^ 129 | -------------------------------------------------------------------------------- /names.fiv: -------------------------------------------------------------------------------- 1 | 2 | !000001AA 3 | \ The names package for the diagnoser (sp?). The two routines to be used 4 | \ by the rest of the world are s->n and n->s. Given a string, s->n gives 5 | \ a unique pointer to that string. n->s converts the name back into a string. 6 | \ Note that this string cannot be changed! 7 | package 8 | 9 | \ s->n ( string -> name ) Converts a string to a name. 10 | \ n->s ( name -> string ) Converts a name to a string. 11 | -*- 12 | v 13 | MAXNAMES 14 | !00000068 15 | \ maxnames is four times the number of maximum names allowed in the system. 16 | h# 8000 constant maxnames 17 | -*- 18 | > 19 | STRINGSPACE 20 | !00000152 21 | \ This is a data structure containing the strings for all names 22 | \ encountered to date. For now, we will use a fixed amount of space; 23 | \ Later we will allocate the memory as we need it. 24 | create stringspace 25 | 4 , \ Offset first string in the stringspace 26 | 32768 allot \ The rest of the possible stringspace. 27 | -*- 28 | > 29 | NAMESTABLE 30 | !00000117 31 | \ This is the name table. Each unused entry is null; each 32 | \ used entry is an offset into the stringspace to the string for the name. 33 | create namestable 34 | maxnames allot \ Allocate the memory for the table. 35 | namestable maxnames erase \ Erase all entries. 36 | -*- 37 | > 38 | S->N 39 | !00000518 40 | \ ( string -> name ) 41 | \ This routine uses string to hash into the namestable, then looks for 42 | \ a match. If it is not found, the string is added to the stringspace 43 | \ and the offset to the string is placed into the namestable. The offset 44 | \ into the namestable to the pointer to the string is the name returned. 45 | : s->n 46 | namestable maxnames + \ The end of the table. 47 | over hashstring namestable + \ The starting point of our search. 48 | do 49 | i @ 0= if i addname i exit endif \ Found a null entry? Then we done! 50 | i @ stringspace + over cstr= if \ Is this the name for which we search? 51 | drop i exit \ If so, return the offset, and exit. 52 | endif 53 | 4 +loop \ Loop by entry size. 54 | dup hashstring namestable + \ Wrap if at the end of the table. 55 | namestable \ Start at the beginning of the table. 56 | do 57 | i @ 0= if i addname i exit endif \ Found a null entry? Then we done! 58 | i @ stringspace + over cstr= if \ Is this the name for which we search? 59 | drop i exit \ If so, return the offset, and exit. 60 | endif 61 | 4 +loop \ Loop by entry size. 62 | -1 abort" String to name conversion error." 63 | ; 64 | -*- 65 | v 66 | ADDNAME 67 | !00000200 68 | \ ( string ptr -> ) 69 | \ Add the string to the stringspace, and make the namestable entry pointed to 70 | \ by ptr point to the string. 71 | : addname 72 | stringspace @ \ Get the offset to the string 73 | swap ! \ Save offset into the namestable. 74 | stringspace dup @ + \ Get address of where to put the str. 75 | over c@ 1+ dup stringspace +! move \ Increment stringspace end ptr, and 76 | ; \ copy in the string. 77 | -*- 78 | > 79 | HASHSTRING 80 | !000002E5 81 | \ ( string -> hash-key ) 82 | \ string is a counted string. 83 | \ Takes the string and computes a reasonable hash key into the names table. 84 | : hashstring 85 | 0 swap \ Put the total on the data stack. 86 | dup c@ over + 1+ swap do \ Make my do loop index a pointer into 87 | i c@ + 3 cshr \ the string. Add the ASCII value of 88 | loop \ each character, and circular shift 89 | \ right by three. 90 | dup 16 shr + h# 7FFC and \ Patch up the offset. 91 | \ (Mask to 32K, clear low two bits; 92 | ; \ we are assuming a 32K names table!!!) 93 | -*- 94 | > 95 | CSTR= 96 | !000001DE 97 | \ ( str1 str2 -> flg ) 98 | \ Compares the counted strings str1 and str2. flg = -1 if equal, otherwise 0 99 | : cstr= 100 | dup c@ 1+ 0 do \ Compare str2's count of characters. 101 | count >r swap count r> = not if \ Every character, includeing the count, 102 | drop drop 0 exit \ must be the same, or we exit with a 103 | endif \ zero! 104 | loop 105 | drop drop -1 \ All is the same, return strings equal! 106 | ; 107 | -*- 108 | ^ 109 | > 110 | N->S 111 | !00000060 112 | \ ( name -> string ) 113 | \ Converts the name into a counted string. 114 | : n->s 115 | @ stringspace + 116 | ; 117 | -*- 118 | ^ 119 | -------------------------------------------------------------------------------- /queens.fiv: -------------------------------------------------------------------------------- 1 | QUEENS 2 | !000001AD 3 | \ DRIVING PROGRAM QUEENS 4 | 5 | : QUEENS ( N -> ) 6 | cls 7 | depth 1 < 8 | abort" 9 | 10 | To run this demo type 'N queens' where N is the number of queens 11 | you wish to use. If you uncomment a line in place-queens you will 12 | see the search for the solution." 13 | 14 | INITIALIZE-ARRAYS 15 | DUP #QUEENS ! 16 | 1- PLACE-QUEEN 17 | IF .BOARD ." SUCCESS" 18 | ELSE cls ." NO SOLUTION FOR " #queens @ . ." QUEENS" clreol 19 | endif ; 20 | -*- 21 | v 22 | MAX-QUEENS 23 | !00000053 24 | \ QUEENS PROBLEM DATA STRUCTURES 25 | \ ALLOW UP TO 50 QUEENS 26 | 50 CONSTANT MAX-QUEENS 27 | -*- 28 | > 29 | #QUEENS 30 | !0000003D 31 | VARIABLE #QUEENS \ Number of queens in use on current run 32 | -*- 33 | > 34 | COL 35 | !0000007F 36 | \ NOTE: The row number implicitly =s the queen sequence number 37 | CREATE COL MAX-QUEENS ALLOT \ Flag whether col occupied 38 | -*- 39 | > 40 | DIAG1 41 | !00000046 42 | CREATE DIAG1 MAX-QUEENS 1 shl ALLOT \ Flag whether diag1 occupied 43 | 44 | -*- 45 | > 46 | DIAG2 47 | !00000046 48 | CREATE DIAG2 MAX-QUEENS 1 shl ALLOT \ Flag whether diag2 occupied 49 | 50 | -*- 51 | > 52 | XBOARD 53 | !00000028 54 | CREATE XBOARD MAX-QUEENS DUP * ALLOT 55 | -*- 56 | > 57 | INITIALIZE-ARRAYS 58 | !000000BC 59 | \ INITIALIZE DATA STRUCTURES 60 | : INITIALIZE-ARRAYS ( -> ) 61 | COL MAX-QUEENS 0 FILL 62 | DIAG1 MAX-QUEENS 0 FILL 63 | DIAG2 MAX-QUEENS 0 FILL 64 | XBOARD MAX-QUEENS DUP * 0 FILL ; 65 | -*- 66 | > 67 | .BOARD 68 | !00000183 69 | \ DISPLAY CURRENT BOARD RESULTS 70 | : .BOARD ( -> ) 71 | ?STACK abort" Stack underflow" 72 | 0 0 gotoxy ." Solution for " #queens @ dup . 1 = 73 | if ." queen!" 74 | else ." queens!" endif 75 | clreol cr 76 | #QUEENS @ 0 DO ( Row loop ) CR 77 | #QUEENS @ 0 DO ( Column loop ) 78 | J #QUEENS @ * I + XBOARD + C@ 79 | IF ." * " ELSE ." . " endif 80 | LOOP 81 | LOOP ; 82 | -*- 83 | > 84 | DIAG1-ADDR 85 | !0000009A 86 | \ COMPUTE DIAGONAL POSITIONS & DETERMINE IF SPACE IS FREE 87 | : DIAG1-ADDR ( ROW COL -> DIAG1.ADDR ) ( "\" Slanted ) 88 | SWAP - #QUEENS @ + DIAG1 + ; 89 | -*- 90 | > 91 | DIAG2-ADDR 92 | !00000051 93 | : DIAG2-ADDR ( ROW COL -> DIAG2.ADDR ) ( "/" Slanted ) 94 | + 1+ DIAG2 + ; 95 | -*- 96 | > 97 | SPACE-FREE? 98 | !00000093 99 | : SPACE-FREE? ( ROW COL -> FREE-FLAG ) 100 | DUP COL + C@ 0= >R 101 | stack ab|abab DIAG1-ADDR C@ 0= >R 102 | DIAG2-ADDR C@ 0= R> AND R> AND ; 103 | -*- 104 | > 105 | PLACE-PIECE 106 | !000000D1 107 | \ PLACE & REMOVE PIECE FROM BOARD 108 | : PLACE-PIECE ( ROW COL -> ) 109 | 1 OVER COL + C! 110 | OVER #QUEENS @ * OVER + XBOARD + 1 SWAP C! 111 | stack ab|abab DIAG1-ADDR 1 SWAP C! DIAG2-ADDR 1 SWAP C! ; 112 | -*- 113 | > 114 | REMOVE-PIECE 115 | !000000AF 116 | : REMOVE-PIECE ( ROW COL -> ) 117 | 0 OVER COL + C! 118 | OVER #QUEENS @ * OVER + XBOARD + 0 SWAP C! 119 | stack ab|abab DIAG1-ADDR 0 SWAP C! DIAG2-ADDR 0 SWAP C! ; 120 | -*- 121 | > 122 | PLACE-QUEEN 123 | !00000249 124 | \ PLACE-QUEEN RECURSIVE PROCEDURE 125 | : PLACE-QUEEN ( #QUEENS.LEFT -> SUCCESS-FLAG ) 126 | DUP 0< NOT IF ( non-zero queen # ) 127 | 0 SWAP #QUEENS @ 0 128 | DO ( Sequence thru cols ) 129 | DUP I SPACE-FREE? 130 | IF DUP I PLACE-PIECE 131 | \ .BOARD ( <- uncomment this line to see the solutions as they are found!) 132 | DUP 1- place-queen 133 | IF ( success ) SWAP DROP 1 SWAP LEAVE 134 | ELSE ( failure ) DUP I REMOVE-PIECE endif 135 | endif 136 | LOOP DROP ( drop #queens leaving flag ) 137 | ELSE ( last queen ) DROP 1 endif ; 138 | -*- 139 | > 140 | DEMO 141 | !0000002D 142 | : demo 1 10 do i queens key drop -1 +loop ; 143 | -*- 144 | ^ 145 | -------------------------------------------------------------------------------- /sieve.fiv: -------------------------------------------------------------------------------- 1 | BENCH1 2 | !000000FE 3 | : BENCH1 4 | FLAGS SIZE 1 FILL 5 | 0 SIZE 0 6 | DO FLAGS I + C@ 7 | IF I DUP + 3 + DUP I + 8 | BEGIN DUP SIZE < 9 | WHILE 0 OVER FLAGS + C! OVER + 10 | REPEAT DROP DROP 1+ 11 | ENDIF 12 | LOOP 13 | . ." Primes " ; 14 | -*- 15 | v 16 | SIZE 17 | !00000014 18 | 8190 constant size 19 | -*- 20 | > 21 | FLAGS 22 | !0000001A 23 | create flags 24 | size allot 25 | -*- 26 | > 27 | 10TIMES 28 | !0000002D 29 | : 10times 30 | 10 0 do 31 | bench1 32 | loop 33 | ; 34 | -*- 35 | ^ 36 | -------------------------------------------------------------------------------- /t.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PaulSnow/Fifth/9c78c59552d6ffec363248645f31c64d8ccb9042/t.exe -------------------------------------------------------------------------------- /t.fiv: -------------------------------------------------------------------------------- 1 | T 2 | !00000573 3 | 4 | 5 | 6 | : t 7 | ['] tickbeat drop \ Include this man 8 | titlescreen \ put up a title screen 9 | init_rand \ initialize the random number generator 10 | cls 11 | begin 12 | 5 10 gotoxy ." Play level (0-9) or ESC? " 13 | 0 begin 14 | drop key 15 | dup 27 = if 16 | drop cls 17 | [ TURNKEYING -1 = ] IF{ 18 | vbname 1 open if 19 | ." Writing out high scores " cr 20 | vboard slotwidth 10 * stack abc|abca write drop drop 21 | close if else drop endif 22 | else 23 | ." error " . ." writing out high scores." 24 | endif 25 | exit 26 | }ELSE{ [ TURNKEYING 1 = ] IF{ 27 | snapshot 28 | bye 29 | }ELSE{ 30 | exit 31 | }ENDIF 32 | }ENDIF 33 | endif 34 | ` 0 - dup 10 u< 35 | until 10 swap - speed ! \ Figure speed 36 | 0 score ! 0 rows ! \ New game 37 | title \ Show off 38 | 0 score+ \ Show score 39 | stats 7 4 * 0 fill \ erase the statistics area 40 | 0 svoffset gotoxy 41 | 7 0 do i . ." : 0" cr loop \ put up the block numbers 42 | 0 svoffset 7 + gotoxy ." # dropped:" 43 | play \ Play game 44 | cls 45 | 0 score+ \ Show score 46 | sethighscore \ set new high score, if any 47 | 5 10 gotoxy ." Press ESC..." 48 | begin key 27 = until 49 | 0 until 50 | ; 51 | -*- 52 | v 53 | TURNKEYING 54 | !00000062 55 | \ -1 turnkey 56 | \ 0 memory 57 | \ 1 snapshot 58 | 0 constant turnkeying 59 | -*- 60 | > 61 | .R 62 | !0000004B 63 | : .r ( n w -- ) 64 | swap <# #s #> stack abc|bcac - 0 max spaces type 65 | ; 66 | -*- 67 | > 68 |