247 lines
9.2 KiB
Forth
247 lines
9.2 KiB
Forth
\ Copyright (C) 2017 Jeremiah Orians
|
|
\ Copyright (C) 2017 Reepca
|
|
\ This file is part of stage0.
|
|
\
|
|
\ stage0 is free software: you can redistribute it and/or modify
|
|
\ it under the terms of the GNU General Public License as published by
|
|
\ the Free Software Foundation, either version 3 of the License, or
|
|
\ (at your option) any later version.
|
|
\
|
|
\ stage0 is distributed in the hope that it will be useful,
|
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
\ GNU General Public License for more details.
|
|
\
|
|
\ You should have received a copy of the GNU General Public License
|
|
\ along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
\ Simply cat this file to the top of any forth program that leverages its functionality
|
|
\ then execute the resulting out put as so:
|
|
\ ./bin/vm --rom roms/forth --memory 1M --tape_01 The_combined_file
|
|
\ All writes via WRITE8 will be written to tape_02 or whatever name you prefer via the --tape_02 option
|
|
\ However should you wish to leverage readline for interacting with forth use vm-production but be warned
|
|
\ WILL see duplicate lines being printed when you hit enter as both readline and the forth are echoing your key strokes
|
|
|
|
\ Define our CELL size as 4 bytes
|
|
: CELL 4 ;
|
|
|
|
\ Save us from manually calculating how many bytes is a given number of CELLS
|
|
: CELLS CELL * ;
|
|
|
|
\ Setup an easy to reference FLAGS offset Constant
|
|
: >FLAGS 2 CELLS + ;
|
|
|
|
\ Update the flags of the latest defintion to IMMEDIATE
|
|
: IMMEDIATE LATEST >FLAGS DUP @ 0x2 OR SWAP ! ;
|
|
|
|
\ Define ALLOT to allocate a give number of bytes
|
|
: ALLOT HERE + DP! ;
|
|
|
|
\ Read a word, lookup and return pointer to its definition.
|
|
: ' WORD DROP FIND >CFA ;
|
|
|
|
\ Lookup a word and write the address of its definition
|
|
: [COMPILE] ' , ; IMMEDIATE
|
|
|
|
\ The literal code address of LIT. Don't think too hard about it.
|
|
: LITERAL [ ' LIT DUP , , ] , , ;
|
|
|
|
\ Compile the CFA of a word looked up as a literal
|
|
: ['] ' LITERAL ; IMMEDIATE
|
|
|
|
\ CONTROL STRUCTURES
|
|
|
|
\ Compile a conditional forward branch, to be resolved by THEN or ELSE.
|
|
: IF ['] 0BRANCH , HERE 0 , ; IMMEDIATE
|
|
|
|
\ Get displacement between two address and write the difference to the address first given
|
|
: TARGET! OVER - SWAP ! ;
|
|
|
|
\ equivalent to "ENDIF".
|
|
: THEN HERE TARGET! ; IMMEDIATE
|
|
|
|
\ And our ELSE for our IF
|
|
: ELSE HERE 2 CELLS + TARGET! ['] BRANCH , HERE 0 , ; IMMEDIATE
|
|
|
|
\ A backwards branch destination, to be resolved by AGAIN, UNTIL, or REPEAT.
|
|
: BEGIN HERE ; IMMEDIATE
|
|
|
|
\ This forward conditional branch will be resolved by REPEAT.
|
|
: WHILE [COMPILE] IF SWAP ; IMMEDIATE
|
|
|
|
\ Resolve a backwards branch.
|
|
: AGAIN ['] BRANCH , HERE SWAP TARGET! CELL ALLOT ; IMMEDIATE
|
|
|
|
: UNTIL ['] 0BRANCH , HERE SWAP TARGET! CELL ALLOT ; IMMEDIATE
|
|
|
|
\ Resolve the latest forward branch and compile a backwards branch.
|
|
: REPEAT [COMPILE] AGAIN [COMPILE] THEN ; IMMEDIATE
|
|
|
|
\ Note that it is possible to use multiple exits from a
|
|
\ BEGIN ... WHILE ... REPEAT loop, as long as you resolve the forward branches
|
|
\ manually. For example, BEGIN ... WHILE ... WHILE ... REPEAT THEN will allow
|
|
\ an exit from either WHILE. You can even put other stuff between the REPEAT and
|
|
\ THEN if you need to handle certain exits specially. Use sparingly unless
|
|
\ you're sure you understand how it works.
|
|
|
|
: [CHAR] KEY LITERAL ; IMMEDIATE
|
|
|
|
\ If true put t otherwise put f
|
|
: .BOOL IF [CHAR] t ELSE [CHAR] f THEN EMIT ;
|
|
|
|
\ Writes a Byte to HEAP
|
|
: C, HERE C! 1 ALLOT ;
|
|
|
|
\ addr count -- high low
|
|
: BOUNDS OVER + SWAP ;
|
|
|
|
\ Prints Memory from address a to a + b when invoked as a b TYPE
|
|
: TYPE BOUNDS BEGIN 2DUP > WHILE DUP C@ EMIT 1 + REPEAT 2DROP ;
|
|
|
|
\ So we don't have to type 10 EMIT for newlines anymore
|
|
: CR 10 EMIT ;
|
|
|
|
\ Makes a string on the HEAP from everything between it and "
|
|
: STR" HERE BEGIN KEY DUP [CHAR] " != WHILE C, REPEAT DROP HERE OVER - ;
|
|
|
|
\ Extends STR" to work in Compile mode
|
|
: S" STATE IF ['] BRANCH , HERE 0 , STR" ROT HERE TARGET! SWAP LITERAL LITERAL
|
|
ELSE STR" THEN ; IMMEDIATE
|
|
|
|
\ Extends S" to behave the way most users want
|
|
: ." [COMPILE] S" STATE IF ['] TYPE , ELSE TYPE THEN ; IMMEDIATE
|
|
|
|
\ add the ANS keyword for modulus
|
|
: MOD % ;
|
|
|
|
\ add ANS keyword for getting both Quotent and Remainder
|
|
: /MOD 2DUP MOD >R / R> ;
|
|
|
|
\ valid bases are from 2 to 36.
|
|
CREATE BASE 10 ,
|
|
|
|
\ Primitive needed for printing base 10 numbers
|
|
: NEXT-DIGIT BASE @ /MOD ;
|
|
|
|
\ Give us a 400bytes of storage to play with
|
|
: PAD HERE 100 CELLS + ;
|
|
|
|
\ Assuming 2's complement
|
|
: NEGATE NOT 1 + ;
|
|
|
|
\ Swap the contents of 2 Memory addresses
|
|
: CSWAP! 2DUP C@ SWAP C@ ROT C! SWAP C! ;
|
|
|
|
\ Given an address and a number of Chars, reverses a string (handy for little
|
|
\ endian systems that have bytes in the wrong order)
|
|
: REVERSE-STRING OVER + 1 -
|
|
BEGIN 2DUP < WHILE 2DUP CSWAP! 1 - SWAP 1 + SWAP REPEAT 2DROP ;
|
|
|
|
\ Given an address and number, writeout number at address and increment address
|
|
: +C! OVER C! 1 + ;
|
|
|
|
|
|
\ works for hex and stuff
|
|
: >ASCII-DIGIT DUP 10 < IF 48 ELSE 55 THEN + ;
|
|
|
|
\ Given a number and address write out string form of number at address and
|
|
\ returns address and length (address should have at least 10 free bytes).
|
|
: NUM>STRING DUP >R OVER 0 < IF SWAP NEGATE SWAP [CHAR] - +C!
|
|
THEN DUP >R SWAP \ R: str-start digits-start
|
|
BEGIN NEXT-DIGIT ROT SWAP >ASCII-DIGIT +C! SWAP DUP WHILE REPEAT
|
|
DROP R> 2DUP - REVERSE-STRING R> SWAP OVER - ;
|
|
|
|
\ A user friendly way to print a number
|
|
: . PAD NUM>STRING TYPE ;
|
|
|
|
\ A temp constant that is going to be replaced
|
|
: STACK-BASE 0x00090000 ;
|
|
|
|
\ Given current stack pointer calculate and display number of underflowed cells
|
|
: .UNDERFLOW ." Warning: stack is underflowed by "
|
|
STACK-BASE SWAP - CELL / . ." cells!" CR ;
|
|
|
|
\ Display the number of entries on stack in <n> form
|
|
: .HEIGHT STACK-BASE - CELL / ." <" . ." > " ;
|
|
|
|
\ Display count and contents of stack or error message if Underflow
|
|
: .S DSP@ DUP STACK-BASE < IF .UNDERFLOW
|
|
ELSE DUP .HEIGHT STACK-BASE
|
|
BEGIN 2DUP > WHILE DUP @ . 32 EMIT CELL + REPEAT
|
|
2DROP
|
|
THEN ;
|
|
|
|
\ Pop off contents of stack to Zero stack
|
|
: CLEAR-STACK BEGIN DSP@ STACK-BASE > WHILE .S 10 EMIT DROP REPEAT STACK-BASE DSP! ;
|
|
: ( BEGIN KEY [CHAR] ) = UNTIL ; IMMEDIATE
|
|
\ Note: for further reading, see brad rodriguez's moving forth stuff.
|
|
\ The return address currently on the stack points to the next word to be
|
|
\ executed. DOER! should only be compiled by DOES> or other similar words, so
|
|
\ the address on the return stack should be right past DOER!'s. Which should be
|
|
\ the code to make the action for the latest word. Since we only want to set
|
|
\ this code as the latest word's action, not actually execute it at this point,
|
|
\ we don't bother putting anything back on the return stack - we'll return
|
|
\ straight up past the word we came from.
|
|
|
|
\ For example: consider this definition
|
|
\ : CONSTANT CREATE , DOES> @ ;
|
|
\ This compiles to the sequence: DOCOL CREATE , DOER! @ EXIT
|
|
\ DOER! will point the latest word (the CREATEd one) to the code right past it -
|
|
\ the @ EXIT - and then exit the definition it's in.
|
|
: DOER! R> SWAP >CFA ! ;
|
|
\ This is a tricky one. Basically, we need to compile a little bit of machine
|
|
\ code that will invoke the code that follows. Notes: R12 should, at this point,
|
|
\ have the address of the place we got here from. So we should just put
|
|
\ that+cell on the stack (for use by what follows DOES>) and run DOCOL. (Note:
|
|
\ implemented in forth.s)
|
|
\ Assumes most significant byte is at lower address
|
|
: 2C, DUP 0xFF00 AND 8 RSHIFT C, 0xFF AND C, ;
|
|
|
|
\ Compiles an assembly-level jump to a location.
|
|
\ We may have to compile more than just a jump in the future in order
|
|
\ for DOES> to work properly - we'd need to load the address into a register,
|
|
\ having the actual address nearby, and then use that coroutine jump thing.
|
|
\ JUMP over the Address, the address, LOADRU32 R0 -4, JSR_COROUTINE R0
|
|
: JUMP-TO, 0x3C000008 , , 0x2E60FFFC , 0x0D010000 , ;
|
|
|
|
\ Sets the action of the latest word
|
|
: DOES> ['] LATEST , ['] DOER! , 'DODOES JUMP-TO, ; IMMEDIATE
|
|
\ Sets the action of a certain word
|
|
: DOER> ['] DOER! , 'DODOES JUMP-TO, ; IMMEDIATE
|
|
: TUCK SWAP OVER ;
|
|
|
|
: MIN 2DUP < IF SWAP THEN DROP ;
|
|
: HEX 16 BASE ! ;
|
|
: DECIMAL 10 BASE ! ;
|
|
|
|
CREATE LINE-SIZE CELL ,
|
|
: PRINTABLE? DUP 127 < SWAP 31 > AND ;
|
|
: EMIT-PRINTABLE DUP PRINTABLE? IF EMIT ELSE DROP [CHAR] . EMIT THEN ;
|
|
: DUMP-TYPE BOUNDS BEGIN 2DUP > WHILE DUP C@ EMIT-PRINTABLE 1 + REPEAT 2DROP ;
|
|
\ will always print two characters.
|
|
: .HEX-BYTE DUP 16 / >ASCII-DIGIT EMIT 15 AND >ASCII-DIGIT EMIT ;
|
|
: DUMP-LINE 2DUP BOUNDS BEGIN 2DUP > WHILE DUP C@ .HEX-BYTE ." " 1 + REPEAT
|
|
2DROP ." " DUMP-TYPE CR ;
|
|
: DUMP-LINES LINE-SIZE @ * BOUNDS
|
|
BEGIN 2DUP > WHILE DUP LINE-SIZE @ TUCK DUMP-LINE + REPEAT 2DROP ;
|
|
: DUMP LINE-SIZE @ /MOD -ROT 2DUP DUMP-LINES LINE-SIZE @ * + SWAP DUMP-LINE ;
|
|
|
|
: VARIABLE CREATE 0 , ;
|
|
: CONSTANT CREATE , DOES> @ ;
|
|
: NOOP ;
|
|
: DEFER CREATE ['] NOOP , DOES> @ EXECUTE ;
|
|
: IS ' CELL + STATE IF LITERAL ['] ! , ELSE ! THEN ; IMMEDIATE
|
|
|
|
|
|
\ emits n spaces.
|
|
: SPACES BEGIN DUP WHILE 32 EMIT 1 - REPEAT DROP ;
|
|
' NOOP @ CONSTANT 'DOCOL
|
|
\ Starts a definition without a name, leaving the execution token (the thing
|
|
\ that can be passed to EXECUTE) on the stack.
|
|
: :NONAME HERE 'DOCOL , ] ;
|
|
|
|
\ fill n bytes with char.
|
|
\ addr n char --
|
|
: FILL >R BOUNDS BEGIN 2DUP > WHILE DUP R@ C! 1 + REPEAT 2DROP R> DROP ;
|
|
: <> != ;
|