fig FORTH on SH3

Fork

	.list ON, EXP
	
; Symbol table definitions for fig-FORTH for SH-3
; Joel Matthew Rees, Hyougo Polytec Center
; 2014.03.01

; 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	symbol, code


; Not in the 6800 fig model, I've just re-factored it for fun.
; (NAME-SCAN)  ( ptr1 --- ptr2 )
;         Scan ptr1 to a byte with the high bit set,
;         leave ptr2 pointing to the next byte.
;         Walks all over r0 and r1. Must leave fW untouched.
;
	HEADER	"(NAME-SCAN)", PNAMESCAN
	mov.l	@fSP, r1 
	mov.b	@r1+, r0
PNAMESCANloop:
	and 	#CTFLAG, r0
	cmp/eq	#CTFLAG, r0
	bf/s 	PNAMESCANloop
	mov.b	@r1+, r0
;
	add 	#-1, r1
	mov 	r1, r0
	mALIGNr0
	rts
	mov.l	r0, @fSP
	


; Not in the 6800 fig model, I've just re-factored it for fun.
; (CHK-NAME)  ( name nfa --- name link f )
;         Compare a name in a buffer to a name in the symbol table.
;         Leave an equality flag and a pointer to the link field for the next name.
;         Names in the dictionary are terminated with the high bit set. 
;         (Names only save 3 significant characters in some FORTHs.)
;         Walks all over r0 - r3. Must leave fW untouched.
;
	HEADER	"(CHK-NAME)", PCHKNAME
	sts.l	pr, @-fRP	; so we can call stuff
	mov.l	@fSP, r2	; name in dictionary
	mov.l	@(NATURAL_SIZE, fSP), r3	; name in buffer
	mov.b	@r2+, r0	; count byte in dictionary, plus flags
	and 	#CTMASK, r0	; Extract the actual count.
	mov.b	@r3+, r1	; count byte in buffer
	cmp/eq	r0, r1
	bf  	PCHKNAMEno
PCHKNAMEloop:
	mov.b	@r2+, r0	; character in dictionary
	tst 	#TAILFLAG, r0
	bt  	PCHKNAMElast
	mov.b	@r3+, r1	; character in buffer
	cmp/eq	r0, r1
	bt  	PCHKNAMEloop
;
PCHKNAMEno:
	mov 	#0, r3		; r3 is not touched by xNAMESCAN
PCHKNAMEret:
	bsr 	_fPNAMESCAN
	mov.l	r2, @fSP	; save it as we go
	lds.l	@fRP+, pr	; Gotta have that return address!
	rts
	mov.l	r3, @-fSP	; flag it as we go
;
PCHKNAMElast:	
	mov.b	@r3+, r1	; last character in buffer
	and		#TAILMASK, r0
	cmp/eq	r0, r1
	bf  	PCHKNAMEno
;
	bra 	PCHKNAMEret	
	mov 	#ALL_BITS8, r3	; Set the flag as we go.
	
	
; (FIND)  ( name nfa --- pfa b tf )
;         ( name nfa --- ff )
;         Search vocabulary for a symbol called name.  
;         name is a pointer to a counted string.
;         nfa is the NFA of the last entry in the vocabulary to be searched.
;         Walks all over r0 - r3, and fW.
;
	HEADER	"(FIND)", PFIND
	sts.l	pr, @-fRP	; so we can call stuff
	mov.l	@fSP, r0
PFINDloop:
	mov.b	@r0, fW		; We aren't using fW anyway, and it doesn't get walked in.
	bsr 	_fPCHKNAME
	mov.l	@fSP+, r0	; Did we find it?
	cmp/eq	#0, r0
	bf/s  	PFINDfound	; Use the true flag in r0
	mov.l	@fSP, r1	; LFA needed either way
;
	mov.l	@r1, r0
	cmp/eq	#0, r0
	bt  	PFINDnot
	bra 	PFINDloop
	mov.l	r0, @fSP	; Store the next one to check as we go.
;
PFINDnot:
;	mov 	#0, r0		; use the NULL pointer as a false flag
	bra 	PFINDret
	add 	#2*NATURAL_SIZE, fSP	; bump as we go
;
PFINDfound:
	add 	#2*NATURAL_SIZE, r1		; pfa
	mov.l	r1, @(NATURAL_SIZE,fSP)
	mov.l	fW, @fSP	; Store the saved count byte, with mode bits.
;	mov 	#ALL_BITS8, r0	; We can reuse the flag that sent us here.
PFINDret:
	lds.l	@fRP+, pr	; Gotta have that return address!
	rts
	mov.l	r0, @-fSP	; Flag it as we go.


; *** Sometime check whether there are extra (unused) instructions in the 6800 code about here.


; WIDTH   ( ---  addr )
;         Number of characters of symbol name significance. 
;         In other words, the maximum width of stored symbol names.
;
;         Fig-FORTH remembers the full length of the symbol name, 
;         but only remembers up to WIDTH of the actual characters.
;         Thus, if WIDTH is 3, ONE and ONEDOG are distinct, 
;         but ONEDOG and ONECAT are the same.
;
;         Per-USER variable, default is 31, max is 31.
;         (So, by default, ONEDOG and ONECAT are properly distinct.)
;
	HIHEADER	WIDTH, WIDTH, DOUSER
	.data.l	XWIDTH


; FENCE   ( --- vadr )    Boundary for FORGET.
;         fig-FORTH can FORGET (de-allocate) compiled symbols and their 
;         definitions. (Within certain limits. Fig-FORTH does not do 
;         anything special, for instance, for forward references.) 
;
;         FENCE allows the user to set limits to FORGETting.
;
	HIHEADER	FENCE, FENCE, DOUSER
	.data.l	XFENCE


; DP      DPC     ( --- vadr )    Dictionary allocation pointer, 
;         fetched by HERE, adjusted by ALLOT.
;
;         Points to the first free byte in the dictionary space. 
; 
	HIHEADER	DP, DP, DOUSER
	.data.l	XDP


; VOC-LINK ( --- addr )
; ************** Need to correct this.
;          Pointer to a pointer to the currently active (CONTEXT) 
;          vocabulary chain.
;
;          fig-FORTH vocabularies are linear linked lists.
;          This USER variable points into the parameter field of the 
;          active CONTEXT vocabulary, at a pointer to the tail of the 
;          linked list (the most recently defined symbol).
;
	HIHEADER	"VOC-LINK", VOCLIN, DOUSER
	.data.l	XVOCL


; TRAVERSE ( addr1 dir --- addr2 )
;        Traverse the name of a symbol.
;        The sign of dir is the direction to traverse, 
;        if 1 traverse to the end (high memory),
;        if -1 traverse to the beginning (low memory).
;        Leave the address at the other end. 
;        (Don't pass anything but -1 or 1, not firewalled!)
;
	HIHEADER	TRAVERSE, TRAV, DOCOL
	.data.l	SWAP
TRAVloop:
	.data.l	OVER,PLUS,LIT
	.data.l	h'7f
	.data.l	OVER,CAT,LESS,ZBRAN
	mTARGET	TRAVloop
	.data.l	SWAP,DROP
	.data.l	SEMIS


; LATEST  ( --- symptr )
;         Fetch CURRENT as a per-USER constant.
;         Returns the NFA of the most recently defined symbol 
;         in the CURRENT vocabulary.
;
	HIHEADER	LATEST, LATEST, DOCOL
	.data.l	CURENT,AT,AT
	.data.l	SEMIS


; LFA     ( pfa --- lfa )
;         Convert PFA to LFA.
;
;         LFA is the Link Field Address, 
;         the address of a definition's allocation link:
;
	HIHEADER	LFA, LFA, DOCOL
	.data.l	LIT
	.data.l	_fLFA-_lLFA		; Use the offsets in its own header.
	.data.l	SUB
	.data.l	SEMIS


; CFA     ( pfa --- cfa )
;         Convert PFA to CFA.
;
;         CFA is the Characteristic (or Code) Field Address,
;         the address of the pointer to the that interprets the definition.
;
	HIHEADER	CFA, CFA, DOCOL
	.data.l	LIT
	.data.l	_fCFA-CFA		; Use the offsets in its own header.
	.data.l	SUB
	.data.l	SEMIS


; NFA     ( pfa --- nfa )
;         Convert PFA to NFA.
;
;         NFA is the Name Field Address, 
;         the address of the symbol name length byte in the header.
;
;         Because of SH-3 alignment issues, we have to be a little tricky.
;         **** And CREATE has to clear  alignment bytes! ****
;         This is part of the reason BIF actually points to the name string.
;
	HIHEADER	NFA, NFA, DOCOL
	.data.l	LFA		; Not to one before the link, but the link itself.
	.data.l	ONE,MINUS,TRAV	; We know TRAVERSE bumps without looking.
; And we know CREATE clears the alignment bytes.
	.data.l	ONE,MINUS,TRAV	; This is the real TRAVERSE.
	.data.l	SEMIS


; PFA     ( nfa --- pfa )
;         Convert NFA to PFA.
;
;         PFA is the Parameter Field Address, 
;         the address of the parameters which define a symbol.
;         For a low-level definition, this is machine code.
;         For a high-level definition, this is the definition parameters.
;
;         For a CONSTANT, the parameter is a constant, or several constants.
;         For a global VARIABLE, the parameter is a variable data value.
;         (This makes true multi-tasking problematic, yes.)
;         For a USER variable, it is a (constant) offset into the per-USER table.
;
;         For a COLON definition, the parameter field is a list of virtual icodes, 
;         considering the address of the characteristic field 
;         as a sort of virtual (non-portable) FORTH intermediate code.
;
;         And so forth (ahem).
;
;         There are many ways to use the parameter field.
;         It is the magic, the LISPishness, of FORTH!
;
	HIHEADER	PFA, PFA, DOCOL
	.data.l	ONE,TRAV,ONEP,ALIGN	; Bumped to the LFA
	.data.l	LIT
	.data.l	_fPFA-_lPFA		; Use the offsets in its own header.
	.data.l	PLUS
	.data.l	SEMIS


;	HEADER	, 
;	HIHEADER	, , 
;	.data.l	
;	.data.l	SEMIS