330 lines
14 KiB
Forth
330 lines
14 KiB
Forth
ASSEMBLER
|
||
: EXIT IPOP NXT ;
|
||
: (lit) CRX PHX NXT ;
|
||
: (slit) CRX TXY TIX PHX PHY ADD TYX TXI NXT ;
|
||
: (dodoes) CRX PHX CRX TXI NXT ;
|
||
: DUP SPX PHX NXT ;
|
||
: SWAP PLX PLY PHX PHY NXT ;
|
||
: ROT PLX PLY PLZ PHY PHX PHZ NXT ;
|
||
: -ROT PLX PLY PLZ PHX PHZ PHY NXT ;
|
||
: OVER PLY SPX PHY PHX NXT ;
|
||
: PICK PLY TYX ADD TSX SUB RYY PHY NXT ;
|
||
: DROP PLX NXT ;
|
||
: 2DROP PLX PLX NXT ;
|
||
: 2DUP PLY SPX PHY PHX PHY NXT ;
|
||
: 2SWAP PLX PLY PLZ RPHZ PLZ PHY PHX PHZ RPLZ PHZ NXT ;
|
||
: 2OVER PLZ RPHZ PLZ PLY SPX PHY PHZ RPLZ PHZ PHX PHY NXT ;
|
||
: NIP PLX PSX NXT ;
|
||
: TUCK PLX PLY PHX PHY PHX NXT ;
|
||
: ?DUP SPX XJMP 1 0 NXT PHX NXT ;
|
||
: >R PLX RPHX NXT ;
|
||
: R> RPLX PHX NXT ;
|
||
: R@ RPX PHX NXT ;
|
||
: ! PLY PLX WYX NXT ;
|
||
: C! PLY PLX CWYX NXT ;
|
||
: @ SPX RXX PSX NXT ;
|
||
: C@ SPX CRXX PSX NXT ;
|
||
: AND PLY SPX AND PSX NXT ;
|
||
: OR PLY SPX OR PSX NXT ;
|
||
: XOR PLY SPX XOR PSX NXT ;
|
||
: INVERT SPX NOT PSX NXT ;
|
||
: (branch) CRX TXI NXT ;
|
||
: (0branch) PLY CRX YJMP 1 0 TXI NXT ;
|
||
: ROLL PLY TYZ INCZ TYX ADD TSX SUB RXY PHX PLX TYX INCY INCY RYY WXY INCX INCX TXY DECZ ZJMP -11 -1 NXT ;
|
||
: + PLY PLX ADD PHY NXT ;
|
||
: - PLY PLX SUB PHY NXT ;
|
||
: +! PLY TYZ RYY PLX ADD TZX WXY NXT ;
|
||
: * PLY PLX MUL PHY NXT ;
|
||
: U< PLY SPX SUB PSX NXT ;
|
||
: U> PLX PLY SUB PHX NXT ;
|
||
: M* PLY PLX SMUL PHY PHX NXT ;
|
||
: UM* PLY PLX MUL PHY PHX NXT ;
|
||
: 0= SPX XJMP 3 0 NOT PSX NXT ENTX 0 0 PSX NXT ;
|
||
: 0<> SPX XJMP 1 0 NXT ENTX -1 -1 PSX NXT ;
|
||
: 0< PLY SIGN PHX NXT ;
|
||
: 0> PLY YJMP 2 0 PHY NXT SIGN NOT PHX NXT ;
|
||
: <> PLY SPX SUB YJMP 2 0 PSX NXT ENTX -1 -1 PSX NXT ;
|
||
: = PLY SPX SUB YJMP 5 0 ENTX -1 -1 PSX NXT ENTX 0 0 PSX NXT ;
|
||
: EMPTYR ENTX 0 3 TXR NXT ;
|
||
: EMPTYS ENTX 0 2 TXS NXT ;
|
||
: DEPTH TSX ENTY 0 2 SUB TYX ENTY 1 0 ASH PHX NXT ;
|
||
: 2* ENTY 1 0 SPX LSH PSX NXT ;
|
||
: 2/ ENTY 1 0 SPX ASH PSX NXT ;
|
||
: RSHIFT PLY SPX RSH PSX NXT ;
|
||
: LSHIFT PLY SPX LSH PSX NXT ;
|
||
: 2>R PLY PLX RPHX RPHY NXT ;
|
||
: 2R> RPLY RPLX PHX PHY NXT ;
|
||
: 2R@ RPLY RPX RPHY PHX PHY NXT ;
|
||
: 1+ SPX INCX PSX NXT ;
|
||
: 1- SPX DECX PSX NXT ;
|
||
: EXECUTE PLX TXP ;
|
||
: */MOD PLZ PLY PLX SMUL SDIV PHZ PHY NXT ;
|
||
: */ PLZ PLY PLX SMUL SDIV PHY NXT ;
|
||
: /MOD PLZ PLY SIGN SDIV PHZ PHY NXT ;
|
||
: / PLZ PLY SIGN SDIV PHY NXT ;
|
||
: MOD PLZ PLY SIGN SDIV PHZ NXT ;
|
||
: UM/MOD PLZ PLX PLY DIV PHZ PHY NXT ;
|
||
: FM/MOD PLZ PLX PLY SDIV PHZ PHY NXT ;
|
||
: O+ PLY PLX ADD PHY PHX NXT ;
|
||
: UDM/MOD PLZ PLX PLY DIV PHZ PHY PHX NXT ;
|
||
: < PLY SIGN TYZ PLY PHY XOR TXY SIGN NOT XJMP 4 0 PLY SIGN PHX NXT PLX TZY SUB PHX NXT ;
|
||
: > PLX PLY PHX SIGN TYZ PLY PHY XOR TXY SIGN NOT XJMP 4 0 PLY SIGN PHX NXT PLX TZY SUB PHX NXT ;
|
||
: NEGATE SPX NOT INCX PSX NXT ;
|
||
: (do) CRX RPHX PLY PLZ RPHZ RPHY NXT ;
|
||
: (?do) CRX RPHX PLY PLX RPHX RPHY SUB YJMP 4 0 RPLY RPLY RPLX TXI NXT ;
|
||
: I RPX PHX NXT ;
|
||
: J RPLZ RPLY PHY RPLY RPX RPHY PLY RPHY RPHZ PHX NXT ;
|
||
: UNLOOP RPLY RPLY RPLY NXT ;
|
||
: (loop) RPLY INCY RPX RPHY SUB CRX YJMP 4 0 RPLY RPLY RPLY NXT TXI NXT ;
|
||
: (+loop) RPLY TYZ PLX ADD RPX DECX RPHY TZY TXZ SUB SIGN PHX TZX RPLY RPHY SUB SIGN PLY XOR TXY CRX YJMP 2 0 TXI NXT RPLY RPLY RPLY NXT ;
|
||
: WAIT BRK NXT ;
|
||
: LEAVE RPLX RPLX RPLX TXI NXT ;
|
||
: RECEIVE-AT PLZ PLY SPX RCV PSX NXT ;
|
||
: DELETE-MSG PLY PLX DMSG NXT ;
|
||
: SET-CHANNEL PLY PLX CHAN NXT ;
|
||
: SEND PLY PLX SEND NXT ;
|
||
|
||
: FW 0x60 PHX NXT ;
|
||
: BW 0x61 PHX NXT ;
|
||
: UP 0x62 PHX NXT ;
|
||
: DN 0x63 PHX NXT ;
|
||
: TL 0x64 NXT ;
|
||
: TR 0x65 NXT ;
|
||
|
||
: DT PLX 0x68 PHX NXT ;
|
||
: DT-UP PLX 0x69 PHX NXT ;
|
||
: DT-DN PLX 0x6a PHX NXT ;
|
||
: DIG 0x70 NXT ;
|
||
: DIG-UP 0x71 NXT ;
|
||
: DIG-DN 0x72 NXT ;
|
||
: PLACE 0x74 NXT ;
|
||
: PLACE-UP 0x75 NXT ;
|
||
: PLACE-DN 0x76 NXT ;
|
||
|
||
: REFUEL PLY PLX 0x80 PHX NXT ;
|
||
: SELECT PLX 0x81 NXT ;
|
||
: GET-ENERGY 0x82 PHY PHX NXT ;
|
||
|
||
: OPEN-INV 0x88 NXT ;
|
||
: GET-FORMSPEC PLX 0x89 NXT ;
|
||
: GET-STACK PLZ PLY PLX 0x8a NXT ;
|
||
: (move_item) PLX 0x8b NXT ;
|
||
|
||
ENVIRONMENT
|
||
256 CONSTANT /COUNTED-STRING
|
||
34 CONSTANT /HOLD
|
||
84 CONSTANT /PAD
|
||
8 CONSTANT ADRESS-UNIT-BITS
|
||
-1 CONSTANT CORE
|
||
-1 CONSTANT CORE-EXT
|
||
-1 CONSTANT FLOORED
|
||
255 CONSTANT MAX-CHAR
|
||
32767 CONSTANT MAX-N
|
||
-1 CONSTANT MAX-U
|
||
128 CONSTANT RETURN-STACK-CELLS
|
||
128 CONSTANT STACK-CELLS
|
||
0xffffffff 2CONSTANT MAX-UD
|
||
0x7fffffff 2CONSTANT MAX-D
|
||
-1 CONSTANT SEARCH-ORDER
|
||
-1 CONSTANT SEARCH-ORDER-EXT
|
||
8 CONSTANT WORDLISTS
|
||
|
||
FORTH
|
||
32 CONSTANT BL
|
||
0 CONSTANT FALSE
|
||
-1 CONSTANT TRUE
|
||
0x100 CONSTANT (source)
|
||
0x104 CONSTANT >IN
|
||
0x106 CONSTANT SOURCE-ID
|
||
0x108 CONSTANT BASE
|
||
0x10a CONSTANT STATE
|
||
0x10c CONSTANT LATEST
|
||
0x110 CONSTANT SPAN
|
||
0x112 CONSTANT (here)
|
||
0x114 CONSTANT LT
|
||
0x116 CONSTANT #TIB
|
||
0x118 CONSTANT TIB
|
||
0x1a0 CONSTANT 'NUMBER
|
||
0x1a2 CONSTANT NEW-WORDLIST
|
||
0x1a4 CONSTANT CW
|
||
0x1a6 CONSTANT NWORDER
|
||
0x1b0 CONSTANT WORDLISTS
|
||
0x1b0 CONSTANT FORTH-WORDLIST
|
||
0x1b2 CONSTANT ENVDICO
|
||
0x1d0 CONSTANT WORDER
|
||
|
||
: CHARS ; IMMEDIATE
|
||
: ALIGN ; IMMEDIATE
|
||
: ALIGNED ; IMMEDIATE
|
||
: CELL+ 2 + ;
|
||
: CELL- 2 - ;
|
||
: CHAR+ 1+ ;
|
||
: CELLS 2* ;
|
||
: EMIT S" screen" SET-CHANNEL 2 ! 2 1 SEND ;
|
||
: RECEIVE 0x80 RECEIVE-AT ;
|
||
: 2! SWAP OVER ! CELL+ ! ;
|
||
: 2@ DUP CELL+ @ SWAP @ ;
|
||
: SOURCE (source) 2@ ;
|
||
: S>D DUP 0< ;
|
||
: MAX 2DUP > IF DROP ELSE NIP THEN ;
|
||
: MIN 2DUP > IF NIP ELSE DROP THEN ;
|
||
: D+ ROT + -ROT O+ ROT + ;
|
||
: HEX 16 BASE ! ;
|
||
: DECIMAL 10 BASE ! ;
|
||
: TUCK SWAP OVER ;
|
||
: ABS DUP 0< IF NEGATE THEN ;
|
||
: (marker) LATEST ! (here) ! ;
|
||
: TYPE DUP 0> IF OVER + SWAP ?DO I C@ EMIT LOOP ELSE 2DROP THEN ;
|
||
: RSTR 1+ DUP 2 + C@ 127 AND TUCK - SWAP ;
|
||
: CR 10 EMIT ;
|
||
: SPACE 32 EMIT ;
|
||
: SPACES DUP 0> IF 0 DO SPACE LOOP ELSE DROP THEN ;
|
||
: STR= 0 DO OVER C@ OVER C@ <> IF UNLOOP 2DROP FALSE EXIT THEN SWAP 1+ SWAP 1+ LOOP 2DROP TRUE ;
|
||
: IMMEDIATE LATEST @ 1- DUP C@ 128 OR SWAP C! ;
|
||
: HERE (here) @ ;
|
||
: [ FALSE STATE ! ; IMMEDIATE
|
||
: ] TRUE STATE ! ;
|
||
: ALLOT (here) +! ;
|
||
: , HERE ! 2 ALLOT ;
|
||
: C, HERE C! 1 ALLOT ;
|
||
: SKIP-WHITE BEGIN DUP C@ 33 < WHILE 1+ 2DUP = IF EXIT THEN REPEAT ;
|
||
: EXIT-IF-END SOURCE NIP >IN @ = IF SOURCE + 0 R> DROP THEN ;
|
||
: PARSE-LIMITS SOURCE OVER + SWAP >IN @ + ;
|
||
: >IN-END SOURCE NIP >IN ! ;
|
||
: COUNTED-STRING DUP HERE C! HERE 1+ -ROT OVER + SWAP DO I C@ OVER C! 1+ LOOP DROP HERE ;
|
||
: PARSE-WORD EXIT-IF-END PARSE-LIMITS SKIP-WHITE 2DUP = IF >IN-END DROP 0 EXIT THEN DUP >R BEGIN DUP C@ 32 > WHILE 1+ 2DUP = IF >IN-END DROP R@ - R> SWAP EXIT THEN REPEAT NIP DUP SOURCE DROP - 1+ >IN ! R@ - R> SWAP ;
|
||
: PARSE SOURCE NIP >IN @ = IF DROP SOURCE + 0 EXIT THEN PARSE-LIMITS DUP >R ROT >R BEGIN DUP C@ R@ <> WHILE 1+ 2DUP = IF R> DROP >IN-END DROP R@ - R> SWAP EXIT THEN REPEAT R> DROP NIP DUP SOURCE DROP - 1+ >IN ! R@ - R> SWAP ;
|
||
|
||
\ TODO: Fix WORD not skipping leading delimiters
|
||
: WORD SOURCE NIP >IN @ = IF DROP 0 HERE C! HERE EXIT THEN PARSE-LIMITS DUP >R ROT >R BEGIN DUP C@ R@ <> WHILE 1+ 2DUP = IF R> DROP >IN-END DROP R@ - R> SWAP EXIT THEN REPEAT R> DROP NIP DUP SOURCE DROP - 1+ >IN ! R@ - R> SWAP COUNTED-STRING ;
|
||
|
||
: HEADER PARSE-WORD TUCK 0 C, OVER + SWAP DO I C@ C, LOOP LATEST @ , C, ;
|
||
: : HEADER HERE DUP LT ! 42 C, ] ;
|
||
: :CODE HEADER HERE DUP LT ! ;
|
||
: UNUSED HERE NEGATE ;
|
||
: NCHAR DUP C@ DUP 58 < IF 48 - ELSE DUP 97 < IF 55 - ELSE 87 - THEN THEN ;
|
||
: >NUMBER DUP >R 0 DO NCHAR DUP BASE @ < OVER 0< INVERT AND IF 2SWAP BASE @ * 0 SWAP ROT BASE @ UM* D+ ROT 0 D+ ROT 1+ ELSE DROP I UNLOOP R> SWAP - EXIT THEN LOOP R> DROP 0 ;
|
||
:NONAME 0 0 2SWAP OVER C@ 45 = IF SWAP 1+ SWAP 1- >NUMBER 2SWAP DROP NEGATE 1 2SWAP ELSE >NUMBER ROT DROP 1 -ROT THEN ; 'NUMBER !
|
||
: NUMBER 'NUMBER @ EXECUTE ;
|
||
: SAVE-INPUT >IN @ 1 ;
|
||
: RESTORE-INPUT DUP 1 = IF DROP >IN ! FALSE ELSE 0 ?DO DROP LOOP TRUE THEN ;
|
||
: COUNT DUP 1+ SWAP C@ ;
|
||
: CHAR PARSE-WORD DROP C@ ;
|
||
: FILL -ROT DUP 0> IF OVER + SWAP DO DUP I C! LOOP ELSE 2DROP THEN DROP ;
|
||
: ERASE 0 FILL ;
|
||
: ( 41 PARSE 2DROP ; IMMEDIATE
|
||
: .( 41 PARSE TYPE ; IMMEDIATE
|
||
: \ 10 PARSE 2DROP ; IMMEDIATE
|
||
: THEN HERE SWAP ! ; IMMEDIATE
|
||
: BEGIN HERE ; IMMEDIATE
|
||
: FIND-WORD-DICO SWAP >R BEGIN DUP 4 - RSTR R@ = IF 2 PICK R@ STR= IF NIP R> DROP EXIT THEN ELSE DROP THEN 3 - @ DUP 0= UNTIL NIP R> DROP ;
|
||
: GET-WL-LATEST DUP CW @ = IF DROP LATEST @ ELSE @ THEN ;
|
||
: FIND-WORD WORDER NWORDER @ 2* + WORDER DO I @ GET-WL-LATEST FIND-WORD-DICO ?DUP IF UNLOOP EXIT THEN 2 +LOOP 0 ;
|
||
: ' PARSE-WORD FIND-WORD ;
|
||
: POSTPONE ' DUP 1- C@ 128 AND IF , ELSE ['] (lit) , , ['] , , THEN ; IMMEDIATE
|
||
: LITERAL ['] (lit) , , ; IMMEDIATE
|
||
: NLITERAL DUP >R 0 DO ['] (lit) , 0 , LOOP R> 0 DO HERE 2 - I 4 * - ! LOOP ; IMMEDIATE
|
||
: DOES> ['] (dodoes) LATEST @ 1+ ! R> LATEST @ 5 + ! ;
|
||
: ['] ' POSTPONE LITERAL ; IMMEDIATE
|
||
: [COMPILE] ' , ; IMMEDIATE
|
||
: ; ['] EXIT , LATEST ! POSTPONE [ ; IMMEDIATE
|
||
: CODE; 41 C, LATEST ! ;
|
||
: [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE
|
||
: CREATE HEADER HERE LATEST ! 42 C, HERE 6 + POSTPONE LITERAL ['] EXIT , ;
|
||
: VARIABLE CREATE 2 ALLOT ;
|
||
: CONSTANT HEADER HERE LATEST ! 77 C, , 33 C, 41 C, ;
|
||
: MARKER HERE HEADER HERE SWAP 42 C, POSTPONE LITERAL LATEST @ POSTPONE LITERAL ['] (marker) , ['] EXIT , LATEST ! ;
|
||
: IF ['] (0branch) , HERE 0 , ; IMMEDIATE
|
||
: ELSE ['] (branch) , HERE SWAP 0 , HERE SWAP ! ; IMMEDIATE
|
||
: UNTIL ['] (0branch) , , ; IMMEDIATE
|
||
: REPEAT ['] (branch) , , HERE SWAP ! ; IMMEDIATE
|
||
: WHILE ['] (0branch) , HERE SWAP 0 , ; IMMEDIATE
|
||
: CASE 0 ; IMMEDIATE
|
||
: ENDCASE ['] DROP , BEGIN DUP 0<> WHILE HERE SWAP ! REPEAT DROP ; IMMEDIATE
|
||
: OF ['] OVER , ['] = , ['] (0branch) , HERE 0 , ['] DROP , ; IMMEDIATE
|
||
: ENDOF ['] (branch) , HERE 0 , HERE ROT ! ; IMMEDIATE
|
||
\ : S" 34 PARSE ['] (branch) , HERE 0 , -ROT 2DUP OVER + SWAP ?DO I C@ C, LOOP NIP SWAP DUP HERE SWAP ! 2 + POSTPONE LITERAL POSTPONE LITERAL ; IMMEDIATE
|
||
: SLITERAL ['] (slit) , DUP , OVER + SWAP ?DO I C@ C, LOOP ; IMMEDIATE
|
||
: S" 34 PARSE POSTPONE SLITERAL ; IMMEDIATE
|
||
: PAD HERE 36 + ;
|
||
: VALUE HEADER HERE LATEST ! 77 C, , 33 C, 41 C, ;
|
||
: TO PARSE-WORD FIND-WORD 1+ STATE @ IF POSTPONE LITERAL ['] ! , ELSE ! THEN ; IMMEDIATE
|
||
: COMPILE, , ;
|
||
: AGAIN ['] (branch) , , ; IMMEDIATE
|
||
: ABORT EMPTYS QUIT ;
|
||
: COMPILE-WORD 2DUP 2>R FIND-WORD ?DUP IF 2R> 2DROP DUP 1- C@ 128 AND IF EXECUTE ELSE , THEN ELSE 2R@ NUMBER 0= IF DROP 2R> 2DROP POSTPONE NLITERAL ELSE DROP 0 ?DO DROP LOOP 2R> TYPE SPACE 63 EMIT ABORT THEN THEN ;
|
||
: COUNT DUP 1+ SWAP C@ ;
|
||
: RECURSE LT @ , ; IMMEDIATE
|
||
: :NONAME HERE DUP LT ! 42 C, LATEST @ ] ;
|
||
: >BODY 7 + ;
|
||
: ENVIRONMENT? ENVDICO @ FIND-WORD-DICO DUP IF EXECUTE TRUE THEN ;
|
||
: D0= OR 0= ;
|
||
: HOLD HERE @ 1- DUP HERE ! C! ;
|
||
: # BASE @ UDM/MOD ROT DUP 9 > IF 55 + ELSE 48 + THEN HOLD ;
|
||
: #S BEGIN # 2DUP D0= UNTIL ;
|
||
: ." POSTPONE S" ['] TYPE , ; IMMEDIATE
|
||
: C" 34 PARSE ['] (branch) , HERE 0 , -ROT HERE -ROT DUP C, OVER + SWAP ?DO I C@ C, LOOP SWAP HERE SWAP ! POSTPONE LITERAL ; IMMEDIATE
|
||
: <# PAD HERE ! ;
|
||
: #> 2DROP HERE @ PAD OVER - ;
|
||
: SIGN 0< IF 45 HOLD THEN ;
|
||
: CONVERT -1 >NUMBER DROP ;
|
||
: MOVE DUP 0= IF DROP 2DROP EXIT THEN -ROT 2DUP U> IF ROT 0 DO OVER C@ OVER C! 1+ SWAP 1+ SWAP LOOP ELSE 2 PICK TUCK + -ROT + SWAP ROT 0 DO 1- SWAP 1- SWAP OVER C@ OVER C! LOOP THEN 2DROP ;
|
||
: . DUP >R ABS 0 <# BL HOLD #S R> SIGN #> TYPE ;
|
||
: U. 0 <# BL HOLD #S #> TYPE ;
|
||
: .R >R DUP >R ABS 0 <# BL HOLD #S R> SIGN #> R> OVER - SPACES TYPE ;
|
||
: U.R >R 0 <# BL HOLD #S #> R> OVER - SPACES TYPE ;
|
||
: WITHIN OVER - >R - R> U< ;
|
||
: DO ['] (do) , HERE 0 , HERE ; IMMEDIATE
|
||
: ?DO ['] (?do) , HERE 0 , HERE ; IMMEDIATE
|
||
: LOOP ['] (loop) , , HERE SWAP ! ; IMMEDIATE
|
||
: +LOOP ['] (+loop) , , HERE SWAP ! ; IMMEDIATE
|
||
: ACCEPT S" screen" DELETE-MSG BEGIN S" screen" 16 RECEIVE-AT DUP 0< WHILE DROP WAIT REPEAT MIN TUCK 16 -ROT MOVE ;
|
||
: EXPECT ACCEPT SPAN ! ;
|
||
: QUERY 0 >IN ! 0 SOURCE-ID ! TIB DUP 80 ACCEPT SPACE (source) 2! ;
|
||
: REFILL SOURCE-ID @ IF FALSE ELSE 0 >IN ! TIB DUP 80 ACCEPT SPACE (source) 2! TRUE THEN ;
|
||
: INTERPRET-WORD 2DUP 2>R FIND-WORD ?DUP IF 2R> 2DROP EXECUTE ELSE 2R@ NUMBER 0= IF 2DROP 2R> 2DROP ELSE DROP 0 ?DO DROP LOOP 2R> TYPE SPACE 63 EMIT ABORT THEN THEN ;
|
||
: EVALUATE SOURCE 2>R >IN @ >R SOURCE-ID @ >R -1 SOURCE-ID ! 0 >IN ! (source) 2! BEGIN PARSE-WORD ?DUP WHILE STATE @ IF COMPILE-WORD ELSE INTERPRET-WORD THEN REPEAT DROP R> SOURCE-ID ! R> >IN ! 2R> (source) 2! ;
|
||
: QUIT EMPTYR CR BEGIN REFILL WHILE BEGIN PARSE-WORD ?DUP WHILE STATE @ IF COMPILE-WORD ELSE INTERPRET-WORD THEN REPEAT DROP SPACE 79 EMIT 75 EMIT CR REPEAT ;
|
||
: (abort") ROT IF TYPE ABORT THEN 2DROP ;
|
||
: ABORT" POSTPONE S" ['] (abort") , ; IMMEDIATE
|
||
: DABS DUP 0< IF OVER NEGATE ROT IF SWAP INVERT ELSE SWAP NEGATE THEN THEN ;
|
||
: D. DUP >R DABS <# BL HOLD #S R> SIGN #> TYPE ;
|
||
: SM/REM OVER >R 2DUP XOR >R ABS >R DABS R> UM/MOD R> 0< IF NEGATE THEN SWAP R> 0< IF NEGATE THEN SWAP ;
|
||
\ : KEY BEGIN RAWKEY DUP 31 > OVER 127 < AND IF EXIT THEN DROP AGAIN ;
|
||
|
||
: ON SET-CHANNEL S" on" SEND ;
|
||
: OFF SET-CHANNEL S" off" SEND ;
|
||
: IO@ RECEIVE 3 < ;
|
||
: LOADPKG 0 0x11e C! PARSE-WORD 0x11a 2! BEGIN 0x11a 2@ SET-CHANNEL 0x11e 1 SEND 0x11e C@ 1+ 0x11e C! 0x11a 2@ 16 RECEIVE-AT 16 C@ WHILE 16 SWAP EVALUATE REPEAT DROP ;
|
||
|
||
0xf000 CONSTANT FORMSPEC-BUFFER
|
||
0 CONSTANT TAG-END
|
||
1 CONSTANT TAG-LIST
|
||
\ location location-length listname listname-length formspec-addr
|
||
: IS-ADDR-LIST DUP >R @ 3 PICK = IF 3 PICK R@ 2 + R@ @ STR= IF R@ @ R> + 2 + DUP >R @ OVER = IF OVER R@ 2 + R@ @ STR= ELSE 0 THEN ELSE 0 THEN ELSE 0 THEN R> DROP ;
|
||
: GET-LIST-ADDR >R BEGIN R@ C@ WHILE R@ R@ 1+ @ R@ C@ SWAP >R TAG-LIST = IF 4 + IS-ADDR-LIST IF R> DROP DROP DROP DROP DROP R> -1 EXIT THEN THEN R> R> DROP >R REPEAT R> DROP DROP DROP DROP DROP 0 ;
|
||
: GET-ELEM-ID 3 + C@ ;
|
||
: GET-LIST-ID GET-LIST-ADDR IF GET-ELEM-ID ELSE -1 THEN ;
|
||
: GET-INV-ID >R S" current_player" S" main" R> GET-LIST-ID ;
|
||
: GET-CRAFT-ID >R S" current_player" S" craft" R> GET-LIST-ID ;
|
||
: GET-CRAFT-OUTPUT-ID >R S" current_player" S" craftpreview" R> GET-LIST-ID ;
|
||
\ from_id from_index to_id to_index count
|
||
: MOVE-ITEM 0xfffe ! 0xfffc ! 0xfff9 C! 0xfffa ! 0xfff8 C! 0xfff8 (move_item) ;
|
||
|
||
: GET-CURRENT CW @ ;
|
||
: SET-CURRENT LATEST @ CW @ ! DUP CW ! @ LATEST ! ;
|
||
: WORDLIST NEW-WORDLIST @ DUP CELL+ NEW-WORDLIST ! ;
|
||
: DEFINITIONS WORDER @ SET-CURRENT ;
|
||
: GET-ORDER WORDER NWORDER @ 1- 2* + ?DO I @ -2 +LOOP NWORDER @ ;
|
||
: SET-ORDER DUP NWORDER ! WORDER 0 ?DO TUCK ! CELL+ LOOP DROP ;
|
||
: ALSO WORDER DUP CELL+ NWORDER @ 2* MOVE NWORDER 2 +! ;
|
||
: FORTH FORTH-WORDLIST WORDER ! ;
|
||
: ONLY FORTH 1 NWORDER ! ;
|
||
: ORDER WORDER NWORDER @ 2* + WORDER DO I @ . 2 +LOOP CR CW @ ;
|
||
: PREVIOUS WORDER CELL+ WORDER NWORDER @ 1- 2* MOVE NWORDER -2 +! ;
|
||
: SEARCH-WORDLIST GET-WL-LATEST FIND-WORD-DICO DUP IF DUP 1- C@ 128 AND IF 1 ELSE -1 THEN THEN ;
|
||
: FIND DUP COUNT WORDER NWORDER @ 2* + WORDER DO 2DUP I @ SEARCH-WORDLIST ?DUP IF 2>R 2DROP DROP 2R> UNLOOP EXIT THEN 2 +LOOP 2DROP 0 ;
|
||
: DUMP SET-CHANNEL 256 0 DO I 64 * PAD 1+ 64 MOVE I PAD C! PAD 65 SEND LOOP ;
|
||
: SAVE-STATE S" boot" DUMP ;
|
||
: COLD S" Computer is ready (" TYPE UNUSED U. S" bytes free)" TYPE QUIT ;
|