; Copyright (c) 2009-2010, Michael Alyn Miller <malyn@strangeGizmo.com>.
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are met:
;
; 1. Redistributions of source code must retain the above copyright notice
; unmodified, this list of conditions, and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright notice,
; this list of conditions and the following disclaimer in the documentation
; and/or other materials provided with the distribution.
; 3. Neither the name of Michael Alyn Miller nor the names of the contributors
; to this software may be used to endorse or promote products derived from
; this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY
; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
; DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY
; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; ======================================================================
; B ("byte") Register Words
; ======================================================================
; ----------------------------------------------------------------------
; 'B [MFORTH] ( -- c-addr)
;
; Push the address of the B register (a USER variable) to the stack.
LINKTO(LINK_BREG,0,2,'B',"\'")
TICKB: JMP DOUSER
.BYTE USERB
; ----------------------------------------------------------------------
; 'Bend [MFORTH] ( -- c-addr)
;
; Push the address of the Bend register (a USER variable) to the stack.
LINKTO(TICKB,0,5,'d',"neB\'")
TICKBEND: JMP DOUSER
.BYTE USERBEND
; ----------------------------------------------------------------------
; 2>B [MFORTH] "two-to-b" ( c-addr u -- )
;
; Pop an address and length from the stack and store the range in B.
;
; ---
; : 2>B ( c-addr u --) OVER + 'Bend ! 'B ! ;
LINKTO(TICKBEND,0,3,'B',">2")
TWOTOB: JMP ENTER
.WORD OVER,PLUS,TICKBEND,STORE,TICKB,STORE,EXIT
; ----------------------------------------------------------------------
; >B [MFORTH] "to-b" ( c-addr -- )
;
; Pop an address from the stack and put the address into the B register.
;
; ---
; : >B ( c-addr --) 'B ! ;
LINKTO(TWOTOB,0,2,'B',">")
TOB: JMP ENTER
.WORD TICKB,STORE,EXIT
; ----------------------------------------------------------------------
; ?ENDB [MFORTH] "question-end-b"
;
; Interpretation:
; Interpretation semantics for this word are undefined.
;
; Execution: ( flag -- )
; Continue execution immediately following the innermost syntactically
; enclosing FORB ... NEXTB if flag is true. Otherwise continue execution
; at the next instruction.
;
; ---
; ?ENDB POSTPONE IF
; ['] branch COMPILE, HERE 'PREVENDB @ , 'PREVENDB !
; POSTPONE THEN ; IMMEDIATE
LINKTO(TOB,1,5,'B',"DNE?")
QENDB: JMP ENTER
.WORD IF,LIT,branch,COMPILECOMMA
.WORD HERE,LIT,TICKPREVENDB,FETCH,COMMA,LIT,TICKPREVENDB,STORE
.WORD THEN,EXIT
; ----------------------------------------------------------------------
; B [MFORTH] ( -- c-addr)
;
; Push the B register to the stack.
;
; ---
; : B ( -- c-addr) 'B @ ;
LINKTO(QENDB,0,1,'B',"")
B: MOV H,B
MVI L,USERB
MOV A,M ; Load LSB of cell value into A
INX H ; Increment to MSB of the cell value
MOV H,M ; Load MSB of the cell value into H
MOV L,A ; Move LSB of cell value from A to L
PUSH H ; Push cell value onto stack.
NEXT
; ----------------------------------------------------------------------
; B! [MFORTH] "b-store" ( c -- )
;
; Pop a byte from the stack and store it at B.
;
; ---
; : B! (c --) B C! ;
LINKTO(B,0,2,'!',"B")
BSTORE: MOV H,B
MVI L,USERB
MOV A,M ; Load LSB of cell value into A
INX H ; Increment to MSB of the cell value
MOV H,M ; Load MSB of the cell value into H
MOV L,A ; Move LSB of cell value from A to L
XTHL ; Get c into L,
MOV A,L ; ..then move c into A,
POP H ; ..restore store HL.
MOV M,A ; ..and store c at HL.
NEXT
; ----------------------------------------------------------------------
; B!+ [MFORTH] "b-store-plus" ( c -- )
;
; Pop a byte from the stack, store it at B, then increment the B register
; by one (byte address location).
;
; ---
; : B!+ ( c --) B! B+ ;
LINKTO(BSTORE,0,3,'+',"!B")
BSTOREPLUS: JMP ENTER
.WORD BSTORE,BPLUS,EXIT
; ----------------------------------------------------------------------
; B# [MFORTH] "b-number" ( -- u )
;
; Push the number of bytes remaining in the range defined by B.
;
; ---
; : B# ( -- u) 'Bend @ B - ;
LINKTO(BSTOREPLUS,0,2,'#',"B")
BNUMBER: PUSH B
MOV H,B
MVI L,USERB
MOV C,M ; Load LSB of cell value into C
INX H ; Increment to MSB of the cell value
MOV B,M ; Load MSB of the cell value into B.
MVI L,USERBEND
MOV A,M ; Load LSB of cell value into A
INX H ; Increment to MSB of the cell value
MOV H,M ; Load MSB of the cell value into H
MOV L,A ; Move LSB of cell value from A to L
DSUB
XTHL
MOV B,H
MOV C,L
NEXT
; ----------------------------------------------------------------------
; B+ [MFORTH] "b-plus" ( -- c-addr)
;
; Increment the B register by one (byte address location).
;
; ---
; : B+ ( --) 1 CHARS 'B +! ;
LINKTO(BNUMBER,0,2,'+',"B")
BPLUS: MOV H,B ; Get the address of the B user variable
MVI L,USERB ; ..into HL.
INR M ; Increment the B user variable;
JNZ _bplusDONE ; ..we're done if the low byte didn't roll.
INX H ; Otherwise increment to the high byte
INR M ; ..and propagate the overflow.
_bplusDONE: NEXT
; ----------------------------------------------------------------------
; B? [MFORTH] "b-question" ( -- flag )
;
; flag is true if and only if there are more bytes in B.
;
; ---
; : B? ( -- f) B# 0 > ;
LINKTO(BPLUS,0,2,'?',"B")
BQUES: PUSH B
MOV H,B
MVI L,USERB
MOV C,M ; Load LSB of cell value into C
INX H ; Increment to MSB of the cell value
MOV B,M ; Load MSB of the cell value into B.
MVI L,USERBEND
MOV A,M ; Load LSB of cell value into A
INX H ; Increment to MSB of the cell value
MOV H,M ; Load MSB of the cell value into H
MOV L,A ; Move LSB of cell value from A to L
DSUB
JZ _bquesDONE ; Leave zero in HL and we're done; otherwise
LXI H,0FFFFh ; ..put true in HL.
_bquesDONE: XTHL
MOV B,H
MOV C,L
NEXT
; ----------------------------------------------------------------------
; B@ [MFORTH] "b-fetch" ( -- c-addr)
;
; Fetch the byte at B.
;
; ---
; : B@ ( -- c) B C@ ;
LINKTO(BQUES,0,2,'@',"B")
BFETCH: MOV H,B
MVI L,USERB
MOV A,M ; Load LSB of cell value into A
INX H ; Increment to MSB of the cell value
MOV H,M ; Load MSB of the cell value into H
MOV L,A ; Move LSB of cell value from A to L
MOV A,M ; Load target byte into A,
MOV L,A ; ..put target byte into L,
MVI H,0 ; ..clear the high byte,
PUSH H ; ..and then push the byte to the stack.
NEXT
; ----------------------------------------------------------------------
; B@+ [MFORTH] "b-fetch-plus" ( -- c )
;
; Fetch the byte at B, then increment the B register by one (byte address
; location.
;
; ---
; : B@+ ( -- c) B@ B+ ;
LINKTO(BFETCH,0,3,'+',"@B")
BFETCHPLUS: JMP ENTER
.WORD BFETCH,BPLUS,EXIT
; ----------------------------------------------------------------------
; FORB [MFORTH] "for-b"
;
; Interpretation:
; Interpretation semantics for this word are undefined.
;
; Compilation: ( C: -- forb-sys )
; Place forb-sys onto the control-flow stack. Append the run-time
; semantics given below to the current definition. The semantics are
; incomplete until resolved by a consumer of forb-sys such as NEXTB.
;
; Run-time: ( -- )
; Set up a loop that iterates over the bytes from 'B to 'Bend.
;
; ---
; forb-sys in MFORTH is ( forb-orig ). ?ENDB locations chain from the most
; recent ?ENDB to the oldest ?ENDB and then to zero, which signifies the
; end of the ?ENDB list. NEXTB goes through the ?ENDB list and fixes up
; the addresses.
;
; : FORB 0 'PREVENDB ! POSTPONE BEGIN
; POSTPONE B# POSTPONE 0= POSTPONE ?ENDB
; ; IMMEDIATE
LINKTO(BFETCHPLUS,1,4,'B',"ROF")
FORB: JMP ENTER
.WORD ZERO,LIT,TICKPREVENDB,STORE,BEGIN
.WORD LIT,BNUMBER,COMPILECOMMA,LIT,ZEROEQUALS,COMPILECOMMA,QENDB
.WORD EXIT
; ----------------------------------------------------------------------
; NEXTB [MFORTH] "next-b"
;
; Interpretation:
; Interpretation semantics for this word are undefined.
;
; Compilation: ( C: dest -- )
; Append the run-time semantics given below to the current definition.
; Resolve the destination of all unresolved occurrences of ?ENDB between
; the location given by dest and the next location for a transfer of
; control, to execute the words following the NEXTB.
;
; Run-time: ( -- )
; Increment 'B and continue execution at the location specified by dest.
;
; ---
; NEXTB POSTPONE B+ POSTPONE AGAIN 'PREVENDB @ HERE>CHAIN ; IMMEDIATE
LINKTO(FORB,1,5,'B',"TXEN")
LAST_BREG:
NEXTB: JMP ENTER
.WORD LIT,BPLUS,COMPILECOMMA,AGAIN
.WORD LIT,TICKPREVENDB,FETCH,HERETOCHAIN,EXIT