fig FORTH on SH3

Fork

	.list ON, EXP
	
; Primitive (kernel) definitions for fig-FORTH for SH-3
; Joel Matthew Rees, Hyougo Polytec Center
; 2014.02.28

; Licensed extended under GPL v. 2 or 3, or per the following:
; ------------------------------------LICENSE-------------------------------------
;
; Copyright (c) 2009, 2010, 2011 Joel Matthew Rees
;
; Permission is hereby granted, free of charge, to any person obtaining a copy
; of this software and associated documentation files (the "Software"), to deal
; in the Software without restriction, including without limitation the rights
; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
; copies of the Software, and to permit persons to whom the Software is
; furnished to do so, subject to the following conditions:
;
; The above copyright notice and this permission notice shall be included in
; all copies or substantial portions of the Software.
;
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
; THE SOFTWARE.
;
; --------------------------------END-OF-LICENSE----------------------------------


; Monolithic, not separate assembly:
; context.inc must be included before this file.
;	.include	"context.inc"
;
;	.section	primitives, code, align=4


; ***** Need to load the return register with something safe.
; Probably the call to next from warm?
;
; Anyway, this is the inner interpreter.
;
NEXT:
	mov.l	@fIP+, fW	; get the pointer to the next definition to execute
NEXTloop:
	mov.l	@fW, r0		; get the defitinition characteristic
	jsr		@r0
; 3 cycles to get back to the top of the loop.
	nop	
	bra		NEXTloop
	mov.l	@fIP+, fW	; grab the next pointer as we loop back.
; Note that, since jumps to absolute addresses have limits in constant-width instruction sets,
; using the subroutine call mode for the virtual machine is not as much a penalty as it might seem.
; It also has the advantage of being more compatible with more conventional code.
; Ways to make an absolute jump work might include 
; * the address of next in a table of constants (and reserving a register for the table base), or
; * reserving a register for the address of next.
;
; See DOCOL ( _fDOCOL ).


; LIT     ( --- n )                                               C
;         Push the following word from the instruction stream as a
;         literal, or immediate value.
;
	HEADER	LIT, LIT
	mov.l	@fIP+, r0
	rts
	mov.l	r0, @-fSP


; "character" (byte or word) literal doesn't work on SH3
; It'll cause alignment problems.


; EXECUTE ( adr --- )                                             C
;         Jump to address on stack.  Used by the "outer" interpreter to
;         interactively invoke routines.  (Not compile-only in fig.)
;
	HEADER	EXECUTE, EXEC
	mov.l	@fSP+, fW
	mov.l	@fW, r0
	jmp 	@r0		; borrow the return there
	nop


; BRANCH  ( --- )                                                 C
;         Add the following word from the instruction stream to the
;         instruction pointer (postincrement).  Causes a program branch.
;
	HEADER	BRANCH, BRAN
	mov.l	@fIP+, r0
BRANCHgo:
	rts
	add 	r0, fIP


; 0BRANCH ( f --- )                                               C
;         BRANCH if flag is zero.
;
	HEADER	"0BRANCH", ZBRAN
	mov.l	@fSP+, r0
	cmp/eq	#0, r0	
	bt/s	BRANCHgo
	mov.l	@fIP+, r0
	rts
	nop

; fig-FORTH puts temporaries on the control stack. I prefer a third stack.
; But if we put I in registers, (DO) is affected.
; One might put I and the loop limit in, say, r8 and r9, 
; but then they must be saved and restored,
; and interrupts have to avoid r8 and r9 or save them.
;
; Note: fig-FORTH +LOOP has an un-signed loop counter, but a signed increment.
; (JMR: but the increment is signed!)


; (LOOP)  ( --- )         ( limit index *** limit index+1)        C
;                         ( limit index *** )
;         Counting loop primitive.  The counter and limit are the top two
;         words on the return stack.  If the updated index/counter does
;         not exceed the limit, a branch occurs.  If it does, the branch
;         does not occur, and the index and limit are dropped from the
;         return stack.
;
	HEADER	"(LOOP)", XLOOP
	mov.l	@fRP, r0	; I (loop counter)
	add 	#1, r0
	mov.l	r0, @fRP	; update I
	mov.l	@(NATURAL_SIZE,fRP), r1	; limit
	cmp/ge	r1, r0		; r0 >= r1 ?
	bf/s	BRANCHgo	; not yet
	mov.l	@fIP+, r0
	rts
	add 	#2*NATURAL_SIZE, fRP
	

; (+LOOP) ( n --- )       ( limit index *** limit index+n )       C
;                         ( limit index *** )
;         Loop with a variable increment.  Terminates when the index
;         crosses the boundary from one below the limit to the limit.  A
;         positive n will cause termination if the result index equals the
;         limit.  A negative n must cause the index to become less than
;         the limit to cause loop termination.
;
	HEADER	"(+LOOP)", XPLOOP
	mov.l	@fSP+, r1	; increment
	mov.l	@fRP, r0	; I (loop counter)
	add 	r1, r0
	mov.l	r0, @fRP	; update I
	shal	r1		 	; increment negative or positive?
	bt/s	XPLOOPminus
	mov.l	@(NATURAL_SIZE,fRP), r1	; limit
;
; Stealing too much code would cost more than it would save.
XPLOOPplus:
	cmp/ge	r0, r1		; limit (r1) >= counter (I=r0) ?
	bf/s	BRANCHgo	; not yet
	mov.l	@fIP+, r0	; grab offset and bump fIP before we go
	rts
	add.l	#2*NATURAL_SIZE, fRP	; drop I and limit before we return
;
XPLOOPminus:
	cmp/ge	r0, r1		; limit (r1) >= counter (I=r0) ?
	bt/s	BRANCHgo	; not yet
	mov.l	@fIP+, r0	; grab offset and bump fIP before we go
	rts
	add.l	#2*NATURAL_SIZE, fRP	; drop I and limit before we return


; Putting I and limit in registers would require (DO) to save the registers first 
; and it would require LOOP and +LOOP to restore the registers on exit.
; That would cost more than it would save.
; 
; (DO)    ( limit index --- )     ( *** limit index )
;         Move the loop parameters to the return stack.  Synonym for D>R, here.
; 
	HEADER	"(DO)", XDO
	mov.l	@fSP+, r0
	mov.l	@fSP+, r1
	add 	#-2*NATURAL_SIZE, fRP
	mov.l	r1, @(NATURAL_SIZE,fRP)
	rts
	mov.l	r0, @fRP


; CMOVE   ( source target count --- )
;         Copy/move count bytes from source to target.  Moves ascending
;         addresses, so that overlapping only works if the source is
;         above the destination.
;  	      Further specification is necessary on word addressing computers.
;         Note -- In many cases, the source and target will not be an even 
;         number of words apart, so we can't optimize to long moves. 
;         Walks on r0-r3.
;
	HEADER	CMOVE, CMOVE
	mov.l	@fSP, r0					; count
	cmp/eq	#0, r0
	bt  	CMOVEdone
	mov.l	@(NATURAL_SIZE,fSP), r2		; target
	mov.l	@(2*NATURAL_SIZE,fSP), r1	; source
CMOVEloop:
	mov.b	@r1+, r3
	mov.b	r3, @r2
	dt  	r0
	bf/s  	CMOVEloop
	add 	#1, r2		; Inc as we loop, since there is no auto-inc store.
;
CMOVEdone:
	rts
	add 	#3*NATURAL_SIZE, fSP	; Drop the parameters as we go.


; SP@     ( --- adr )
; SPAT    Fetch the parameter stack pointer (before it is pushed).
;
	HEADER	SP@, SPAT
	rts
	mov.l	fSP, @-fSP


; SP!     ( whatever --- nothing )
; SPSTOR  Initialize the parameter stack pointer from the USER variable
;         S0.  Effectively clears the stack.
;
	HEADER	"SP!", SPSTOR
	mov.l	@(XSPZER,fUP), r0
	rts
	mov.l	r0, fSP


; RP!     ( whatever *** nothing )
; RPSTOR  Initialize the return stack pointer from the USER variable R0.
;         Effectively aborts all in process definitions, except the active
;         one.  An emergency measure, to be sure.
;
;         Deferring to the glossary, rather than the 6800 model, 
;         and getting the initializer from the PER_USER table.
;
	HEADER	"RP!", RPSTOR
	mov.l	@(XRZERO,fUP), r0	
	rts
	mov.l	r0, fSP


; ;S      ( ip *** )
; SEMIS   Pop IP from return stack (return from high-level definition).
;         Can be used in a screen to force interpretion to terminate.
;
	HEADER	";S", SEMIS
	rts
	mov.l	@fRP+, fIP



; S0       ( --- addr )
;          The USER variable that points to the base (initial value) of 
;          the parameter stack.
;          Pronounced S-zero. See SP!
;
	HIHEADER	S0, SZERO, DOUSER
	.data.l	XSPZER


; R0       ( --- addr )
;          The USER variable that points to the base (initial value) of 
;          the flow-of-control/return stack.
;          Pronounced R-zero. See RP!
;
	HIHEADER	R0, RZERO, DOUSER
	.data.l	XRZERO


; NOOP  ( --- )
;       For stuffing no-operation placeholders into code.
;       Useful for temporarily resolving forward definitions, among other things.
;
;       This is part of the 6800 model, but not in the fig-FORTH glossary.
;
	HEADER	NOOP, NOOP
	rts
	nop