Commit: 338d0dd50a7709c65aa80f78651c5a33bfee2c4c - fig_sh (git)

Implementing figFORTH on SH3 assembler

Commit MetaInfo

• Revisión: 338d0dd50a7709c65aa80f78651c5a33bfee2c4c (tree)
• Tiempo: 2014-03-14 21:06:47
• Autor: Joel Matthew Rees <reiisi@user...>
• Commiter: Joel Matthew Rees

Log Message

Up to HEX and DECIMAL, #116

Cambiar Resumen

• modified: compiler.inc
• modified: context.inc
• add: error.inc
• modified: evaluator.inc
• modified: inout.inc
• modified: main.src
• modified: symbol.inc
• modified: teststuff.inc

Diferencia incremental

--- a/compiler.inc
+++ b/compiler.inc
@@ -221,4 +221,115 @@ _fDOUSER:
 	.data.l	HERE,CSTORE,ONE,ALLOT
 	.data.l	SEMIS
 
+
+; !CSP    ( --- )
+;         Save the parameter stack pointer in CSP for compiler checks.
+	HIHEADER	"!CSP", SCSP, DOCOL
+	.data.l	SPAT,CSP,STORE
+	.data.l	SEMIS
+
+
+; ?COMP   ( --- )                 ( *** )
+;         ( --- IN BLK )          ( anything *** nothing )
+;         ERROR if not compiling.
+;
+	HIHEADER	"?COMP", QCOMP, DOCOL
+	.data.l	STATE,AT,ZEQU,LIT
+	.data.l	errCOMPILE_ONLY
+	.data.l	QERR
+	.data.l	SEMIS
+
+
+; ?PAIRS  ( n1 n2 --- )           ( *** )
+;         ( n1 n2 --- IN BLK )    ( anything *** nothing )
+;         ERROR if n1 and n2 are unequal.
+;   
+;         MESSAGE says compiled conditionals do not match.
+;
+	HIHEADER	"?PAIRS", QPAIRS, DOCOL
+	.data.l	SUB,LIT
+	.data.l	errUNBALANCED_CONDITIONALS
+	.data.l	QERR
+	.data.l	SEMIS
+
+
+; ?CSP    ( --- )                 ( *** )
+;         ( --- IN BLK )          ( anything *** nothing )
+;         ERROR if parameter stack is not at same level as last !CSP.
+;
+;         MESSAGE says a definition has been left incomplete.
+;
+	HIHEADER	"?CSP", QCSP, DOCOL
+	.data.l	SPAT,CSP,AT,SUB,LIT
+	.data.l	errDEFINITION_INCOMPLETE
+	.data.l	QERR
+	.data.l	SEMIS
+
+
+; COMPILE ( --- )
+;         Compile an in-line literal value from the instruction stream.
+;
+	HIHEADER	COMPILE, COMPIL, DOCOL
+	.data.l	QCOMP,FROMR,NATPLUS,DUP,TOR,AT,COMMA
+	.data.l	SEMIS
+
+
+COMPILE_MODE:	.equ	h'C0
+
+
+; [      ( --- )                                         P
+;        Clear the compile state bits (shift to interpret).
+;        { : symbol compiled-stuff [ compile-time-stuff ] more-compiled-stuff ; } typical use
+;
+;        Sometimes you need to do something run-time at compile-time.
+;        For example, you may not know a constant's actual value 
+;        until the source is compiled. But it will be a real constant,
+;        so you don't want to compile in the calculation.
+;
+;        (This is one of the killer features of FORTH.
+;        It seriously reduces the burden on the optimizer, when there is one.)
+;
+	HIHEADER	"[", LBRAK, DOCOL, MIMM
+	.data.l	ZERO,STATE,STORE
+	.data.l	SEMIS
+
+
+; ]       ( --- )
+;         Set the compile state bits. (Shift back to compiling.)
+;         See [.
+;
+	HIHEADER	"[", RBRAK, DOCOL
+	.data.l	LIT
+	.data.l	COMPILE_MODE
+	.data.l	STATE,STORE
+	.data.l	SEMIS
+
+
+; SMUDGE  ( --- )
+;         Toggle HIDDEN bit of LATEST definition header, 
+;         to hide it until defined, or reveal it after definition.
+;
+;         It helps keep symbol table lookup simple in the compiler.
+;
+	HIHEADER	SMUDGE, SMUDGE, DOCOL
+	.data.l	LATEST,LIT
+	.data.l	MHID
+	.data.l	TOGGLE
+	.data.l	SEMIS
+
+
+
+; [COMPILE]       ( --- )                                         P
+;         { [COMPILE] name } typical use
+;         -DFIND next WORD and COMPILE it, literally; used to compile
+;         immediate definitions.
+;[COMPILE]                                       p,C
+;        Used in a colon-definition in form:
+;                         :  xxx    [COMPILE]   FORTH   ;
+;        [COMPILE] will force the compilation of an immediate definitions,
+;        that would otherwise execute during compilation. The above example
+;        will select the FORTH vocabulary then xxx executes, rather than at
+;        compile time.
+;
+;
 

--- a/context.inc
+++ b/context.inc
@@ -389,6 +389,7 @@ _s\characteristic:	.sdata	.substr("\name", 0, .len("\name")-1)
 ; Symbol names float a little, yes this is a little awkward.
 	.align	NATURAL_SIZE
 ; (Allocation) link to previously defined symbol's header.
+_l\characteristic
 	.data.l	_PREVNAME
 ; Use the SH-3 assembler to track the last symbol. 
 ; (This is not always a good idea.)

--- /dev/null
+++ b/error.inc
@@ -0,0 +1,125 @@
+	.list ON, EXP
+	
+; Error handling and other message definitions for fig-FORTH for SH-3
+; Joel Matthew Rees, Hyougo Polytec Center
+; 2014.03.15
+
+; 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	error, code
+
+
+; This list was originall borrowed from BIF,
+; *** so it has some that aren't relevant! ***
+;
+errNONE:				.equ	0
+;	FCC	"DATA STACK UNDERFLOW                                            " 1
+errSTACK_UNDERFLOW:		.equ	1
+;	FCC	"DICTIONARY FULL                                                 " 2
+;	FCC	"ADDRESS RESOLUTION ERROR                                        " 3
+;	FCC	"HIDES DEFINITION IN                                             " 4
+;	FCC	"NULL VECTOR WRITTEN                                             " 5
+;	FCC	"DISC RANGE?                                                     " 6
+;	FCC	"DATA STACK OVERFLOW                                             " 7
+;	FCC	"DISC ERROR!                                                     " 8
+;	FCC	"CAN'T EXECUTE A NULL!                                           " 9
+;	FCC	"CONTROL STACK UNDERFLOW                                         " 10
+;	FCC	"CONTROL STACK OVERFLOW                                          " 11
+;	FCC	"ARRAY REFERENCE OUT OF BOUNDS                                   " 12
+;	FCC	"ARRAY DIMENSION NOT VALID                                       " 13
+;	FCC	"NO PROCEDURE TO ENTER                                           " 14
+;	FCC	"               ( WAS REGISTER )                                 " 15
+;* SCREEN 5
+;	FCC	"                                                                " 0
+;	FCC	"COMPILATION ONLY, USE IN DEF                                    " 1
+errCOMPILE_ONLY:			.equ	h'11
+;	FCC	"EXECUTION ONLY                                                  " 2
+errEXECUTE_ONLY:			.equ	h'12
+;	FCC	"CONDITIONALS NOT PAIRED                                         " 3
+errUNBALANCED_CONDITIONALS:	.equ	h'13
+;	FCC	"DEFINITION INCOMPLETE                                           " 4
+errDEFINITION_INCOMPLETE:	.equ	h'14	
+;	FCC	"IN PROTECTED DICTIONARY                                         " 5
+;	FCC	"USE ONLY WHEN LOADING                                           " 6
+errLOADING_ONLY:			.equ	h'16
+;	FCC	"OFF CURRENT EDITING SCREEN                                      " 7 
+;	FCC	"DECLARE VOCABULARY                                              " 8
+;	FCC	"DEFINITION NOT IN VOCABULARY                                    " 9
+;	FCC	"IN FORWARD BLOCK                                                " 10
+;	FCC	"ALLOCATION LIST CORRUPTED: LOST                                 " 11
+;	FCC	"CAN'T REDEFINE nul!                                             " 12
+;	FCC	"NOT FORWARD REFERENCE                                           " 13
+;	FCC	"              ( WAS IMMEDIATE )                                 " 14
+;	FCC	"                                                                " 15
+;* SCREEN 6
+;	FCC	"( MORE ERROR MESSAGES asm6809 )                                 " 0
+;	FCC	"HAS INCORRECT ADDRESS MODE                                      " 1
+;	FCC	"HAS INCORRECT INDEX MODE                                        " 2
+;	FCC	"OPERAND NOT REGISTER                                            " 3
+;	FCC	"HAS ILLEGAL IMMEDIATE                                           " 4
+;	FCC	"PC OFFSET MUST BE ABSOLUTE                                      " 5
+;	FCC	"ACCUMULATOR OFFSET REQUIRED                                     " 6
+;	FCC	"ILLEGAL MEMORY INDIRECTION  (6809)                              " 7
+;	FCC	"ILLEGAL INDEX BASE (6809)                                       " 8
+;	FCC	"ILLEGAL TARGET SPECIFIED                                        " 9
+;	FCC	"CAN'T STACK ON SELF (6809)                                      " 10
+;	FCC	"DUPLICATE IN LIST                                               " 11
+;	FCC	"REGISTER NOT STACK (6809)                                       " 12
+;	FCC	"EMPTY REGISTER LIST (6809)                                      " 13
+;	FCC	"IMMEDIATE OPERAND REQUIRED                                      " 14
+;	FCC	"REQUIRES CONDITION                                              " 15
+;* 
+;* SCREEN 7
+;	FCC	"                                                                " 0
+;	FCC	"COMPILE-TIME STACK UNDERFLOW                                    " 1
+;	FCC	"COMPILE-TIME STACK OVERFLOW                                     " 2
+
+
+; ?ERROR  ( 0 n --- )             ( *** )
+;         ( true n --- IN BLK )   ( anything *** nothing )
+;         If flag is false, do nothing. 
+;         If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+;         Leaves cursor position (IN) and currently loading block number (BLK) on stack,
+;         for later analysis.
+;
+	HIHEADER	"?ERROR", QERR, DOCOL
+	.data.l	SWAP,ZBRAN
+	mTARGET QERRnone
+	.data.l	ERROR,BRAN
+	mTARGET	QERRleave
+QERRnone:
+	.data.l	DROP
+QERRleave:
+	.data.l	SEMIS
+
+
+
+
+

--- a/evaluator.inc
+++ b/evaluator.inc
@@ -43,7 +43,7 @@
 ;         In other words, if ptr1 is aligned at a NATURAL_SIZE boundary, do nothing.
 ;         Otherwise, adjust it up until it is aligned.
 ;
-	HEADER ALIGN, xPALIGN
+	HEADER ALIGN, ALIGN
 	mov.l	@fSP, r0
 	mALIGNr0
 	rts
@@ -692,12 +692,78 @@ GREATgreat:
 	mov.l	r2, @fSP
 
 
+; MIN     ( n0 n1 --- min(n0,n1) )
+;         Leave the minimum of the top two natural integers.
 ;
-;* ======>>  93  <<
-;	FCB	$83
-;	FCC	2,ROT
-;	FCB	$D4
-;	FDB	GREAT-4
+	HIHEADER	MIN, MIN, DOCOL
+	.data.l	OVER,OVER,GREAT,ZBRAN
+	mTARGET	MINdrop
+	.data.l	SWAP
+MINdrop:
+	.data.l	DROP
+	.data.l	SEMIS
+
+
+; MAX     ( n0 n1 --- max(n0,n1) )
+;         Leave the maximum of the top two natural integers.
+;
+	HIHEADER	MAX, MAX, DOCOL
+	.data.l	OVER,OVER,LESS,ZBRAN
+	mTARGET	MAXdrop
+	.data.l	SWAP
+MAXdrop:
+	.data.l	DROP
+	.data.l	SEMIS
+
+
+; -DUP    ( 0 --- 0 )
+;         ( n --- n n )
+;         DUP iff non-zero. 
+;
+;         Convenience definition for IF tests.
+;         (Otherwise, many ELSE clauses would contain only a DROP.)
+;
+	HIHEADER	"-DUP", DDUP, DOCOL
+	.data.l	DUP,ZBRAN
+	mTARGET	DDUPzero
+	.data.l	DUP
+DDUPzero:
+	.data.l	SEMIS
+
+
+; ?EXEC   ( --- )                 ( *** )
+;         ( --- IN BLK )          ( anything *** nothing )
+;         ERROR if not executing.
+;
+	HIHEADER	"?EXEC", QEXEC, DOCOL
+	.data.l	STATE,AT,LIT
+	.data.l	errEXECUTE_ONLY
+	.data.l	QERR
+	.data.l	SEMIS
+
+
+; HEX     ( --- ) 
+;         Set the conversion base to sixteen (hexadecimal).
+;
+	HIHEADER	HEX, HEX, DOCOL
+	.data.l	LIT
+	.data.l	16
+	.data.l	BASE,STORE
+	.data.l	SEMIS
+
+
+; DECIMAL ( --- )
+;         Set the conversion base to ten.
+;
+;         (Note that "DEC" is a valid hexadecimal number. So is A.)
+;
+	HIHEADER	DECIMAL, DEC, DOCOL
+	.data.l	LIT
+	.data.l	10
+	.data.l	BASE,STORE
+	.data.l	SEMIS
+
+
 
 
 ; D-       ( d1 d2 --- d1+d2 )

--- a/inout.inc
+++ b/inout.inc
@@ -215,3 +215,21 @@
 	HIHEADER	COLUMNS, COLUMS, DOUSER
 	.data.l	XCOLUM
 
+; SPACE   ( --- )
+;         EMIT a SPACE.
+;
+	HIHEADER	SPACE, SPACE, DOCOL
+	.data.l	BL,EMIT
+	.data.l	SEMIS
+
+
+; ?LOADING  ( --- )         ( *** )
+;           ( --- IN BLK )          ( anything *** nothing )
+;           ERROR if not loading, i. e., if BLK is zero.
+;
+	HIHEADER	"?LOADING", QLOAD, DOCOL
+	.data.l	BLK,AT,ZEQU,LIT
+	.data.l	errLOADING_ONLY
+	.data.l	QERR
+	.data.l	SEMIS
+

--- a/main.src
+++ b/main.src
@@ -117,6 +117,7 @@ _iWENT:
 	.include	"symbol.inc"
 	.include	"compiler.inc"
 	.include	"inout.inc"
+	.include	"error.inc"
 	
 	.include	"driver.inc"
 

--- a/symbol.inc
+++ b/symbol.inc
@@ -196,7 +196,110 @@ PFINDret:
 	.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

--- a/teststuff.inc
+++ b/teststuff.inc
@@ -44,20 +44,21 @@
 ;
 ; These aren't magic, just shims for the assembler.
 ;
-QEXEC:	.define	"NOOP"	; used in COLON
-SCSP:	.define	"NOOP"	; used in COLON
+; QEXEC:	.define	"NOOP"	; used in COLON
+; SCSP:	.define	"NOOP"	; used in COLON
 ; CURENT:	.define	"NOOP"	; used in COLON
 ; CONTXT:	.define	"NOOP"	; used in COLON
 CREATE:	.define	"NOOP"	; used in COLON
-RBRAK:	.define	"NOOP"	; used in COLON
+; RBRAK:	.define	"NOOP"	; used in COLON
 PSCODE:	.define	"NOOP"	; used in COLON
-QCSP:	.define	"NOOP"	; used in SEMI
-COMPIL:	.define	"NOOP"	; used in SEMI
-SMUDGE:	.define	"NOOP"	; used in SEMI
-LBRAK:	.define	"NOOP"	; used in SEMI
+; QCSP:	.define	"NOOP"	; used in SEMI
+; COMPIL:	.define	"NOOP"	; used in SEMI
+; SMUDGE:	.define	"NOOP"	; used in SEMI
+; LBRAK:	.define	"NOOP"	; used in SEMI
 ; COMMA:	.define	"NOOP"	; used in CONSTANT
 DODOES:	.define	"NOOP"	; used in ROMFORTH
 DOVOC:	.define	"NOOP"	; used in ROMFORTH
+ERROR:	.define	"NOOP"	; used in QERROR
 ; :	.define	"NOOP"