\ 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 .
\ 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 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 ;
: <> != ;