RUNTIME
 1 BLK ! 1 LINE# ! ( SOURCE )
 ECHO OFF
FORTH DEFINITIONS
ALIAS BPW 4	   ( BYTES PER WORD )
ALIAS BPW+ 4+
ALIAS BPW- 4-
ALIAS -BPW -4
FORTH DEFINITIONS
ALIAS MACRO :
COMPILER DEFINITIONS
ALIAS END-MACRO ;
VDROP
ASSEMBLER DEFINITIONS

DEBUG
TRACE OFF
FORTHONLY
FORTH DEFINITIONS
( T414/800 TRANSPUTER FORTH META COMPILER )
( COPYRIGHT E.K.MATEJOWSKY 24 HANSELL'S PDE RIVERVIEW 4303 AUSTRALIA )
( PH. +61 7 282 5939 )
( may be distributed as a share-ware product by non-commercial users )
( provided this notice is included )
( Native compiler cross compiled from an amiga A1000 )
( this source is meant to be printed with a tab = 4 spaces )
( August 1990 X-compiler started )
( 11-sept-90 hardware up on MAC-SE )
( 18-sept-90 amiga link adaptor running)
( 23-sept-90 interpreter running )
( 25-sept-90 native compiler compiling)
( 5-oct-90 Meta compiler running )
(		2044 lines at 57 k meta compile in 88 seconds from host ramdisk )
( 6-OCT-90 EXPECT MADE CODE 	2062 LINES, 58 K, 85 SECONDS , NICE TRY )
( 7-OCT-90 BEGIN-WHILE-REPEAT added to assembler )
( 		CONVERT SPACES TO TAB 	2101 LINES, 46 K, 91 SEC )
( 		-FIND MADE CODE 		2102 LINES, 47 K, 17 SECONDS WOOPIE !! )
( 		TRACE ADDED )
( 8-OCT-90 WORD MAKE CODE 			2124 LINES, 47 K, 14 SECONDS )
( 		CHANGED BOOT + STARTUP SO LINK IS IN C WS IN B AT STARTUP TIME )
( 11-OCT-90 STACK BALANCE NOW CHECKED BY : ; CODE AND END-CODE )
( 18-OCT-90 the assembler workspace offset needs to be declared earlier )
( 4-NOV-90 added the word PATH to show search path )
( 5-NOV-90 added ^^ operator to change abs address into ws offsets )
( 4-JAN-91 new transputer board running )
( 25 meg t800 reduces meta compile from 17 to 10 seconds )
( 2-FEB-91 bit 80 of the last word in a name is used as immediate flag )
( objects etc feb-march-91 ?? )
( sema-phore memalloc etc )
( 21-MAR-91 finger added to list an object message list )
( MAY ?? Process defined and startup modified , ran 1000 forked processes )
( AUG-19 changed message format they're now in a linked list )
( added GMESSAGE it's similiar to MESSAGE expect you have it's value on stack )
( it used for global messages as used in a network of different types of cpus )
( SEPT-91 T800 and host run a packet based protocol , t800 can now open )
( 	the host disk files etc. )
( MAR-92 fixed a bug in digit where it was accepting asc h'3a-40 as hex digits )
( MAR-92 FIXED A BUG READING FILES 4096 BYTES LONG )
( 30-9-92 type and emit now return empty ack packets to client )

." HOST STUFF " CR
( all the host stuff gets removed by prune )
( head bits --> )
( 40		= smudge bit )
( 80 		= immediate bit )
( 8000		= remote bit )
( 800000 	= host dict flag )
( 80000000 	= term bit )
HEX GETTIMER 80000048 !
80010000 10000 ERASE
80000048 CONSTANT MEMSTART
10000 CONSTANT OFFSET					( meta-compile offset )
64 CONSTANT DSIZE						( data stack size )
32 CONSTANT RSIZE						( return stack size )
16 CONSTANT VSTKSIZE					( vocab stack size )
16 CONSTANT DAPSIZE						( dataptr stack size )
16 CONSTANT MPSIZE						( message stack size )
50 CONSTANT TOBSIZE
1000 CONSTANT BUFFSIZE
VARIABLE FORTHSTART
VARIABLE COMPILERSTART
VARIABLE ASSEMBLERSTART
VARIABLE RUNTIMESTART
VARIABLE MISCSTART
VARIABLE DEBUGSTART
VARIABLE STARTUPADDRESS
VARIABLE MAINLENGTH
VARIABLE RTNEXT
VARIABLE PATCH
( VARIABLE DP'
MEMSTART DP' !
VARIABLE dA'
VARIABLE dA
0 H/C !
0 dA !
RUNTIME
OFFSET dA' !
( ALIAS )

: OLDDP' DP' ;

: OLD] ] ;

: OLDTIB TIB ;

: OLD: : ;

: OLDUSER USER ;

: OLDSP SP ;

: OLDCONTEXT CONTEXT ;

: OLDBLK BLK ;

: OLDLATEST LATEST ;

: OLDLINKINPTR LINKINPTR ;

: OLDLINKOUTPTR LINKOUTPTR ;
RUNTIME
COMPILER DEFINITIONS FORTH

: OLDLITERAL [ ' LITERAL , ] ;

: OLD; [GOTO] [ ' ; BPW+ , ] ;

: OLDIF [ ' IF , ] ;

: OLDTHEN [ ' THEN , ] ;

: OLDABORT" [ ' ABORT" , ] ;
FORTH DEFINITIONS

: A, dA @ - , ;

: A! SWAP dA @ - SWAP ! ;

: {
		DP' @ DP @ DP' ! DP !
		dA @ dA' @ dA ! dA' !
;

: } { ;

: {'} { ' } ;

: FIND	( THREAD --- F | T CFA )
	20 WORD SWAP
	dA @ IF						( if da!=0 set relocates bit )
		HEREW @ 800000 OR HEREW !
	THEN
	HEREW C@
		IF
			-FIND
		ELSE
			DROP FALSE
		THEN
;

: -'	( ---   SEARCH PATH FOR WORD )
	CONINDEX @							( INDEX -- )				 
	BEGIN
		DUP 0 >							( INDEX T/F -- )
	WHILE
		DUP 1- BPW * CONARRAY +			( IND POINT TO POINTER )
		HEREW SWAP -FIND
		IF
			SWAP DROP EXIT
		ELSE DROP
		THEN
		1-
	REPEAT
;

: '
	20 WORD C@
	dA @ IF						( if da!=0 set relocates bit )
		HEREW @ 800000 OR HEREW !
	THEN
    IF -'
		DUP NOT	IF ABORT" ??? " 
		ELSE EXIT
		THEN
	ELSE
		FALSE	
	THEN
;

: CREATE
	H/C @ IF { THEN
(    ALIGN
	HERE BPW+ LATEST !
	HERE CURRENT @ @ ,				( save thread in head link )
	CURRENT @ !						( Save head link address in thread )
	20 WORD DUP
	C@ 1+ ALLOT DPALIGN				( getword and pad to word boundary )
	HERE 1- C@ 80 OR HERE 1- C!		( set term bit )
	dA @ IF
		DUP @ 800000 OR SWAP !		( if da!=0 set relocates bit )
	ELSE
		DROP
	THEN
	H/C @ IF
 		LATEST @ @ 808000 OR LATEST @ !
		MODE @ IF
			-BPW ALLOT HERE @ DP' @ , } ,
		ELSE
			DP' @ , }
		THEN
	THEN
;

: HEADERLESS H/C ON ;

: HEADS H/C OFF ;

: CODE
	CREATE
	ASSEMBLER
;

: ALIAS CREATE SMUDGE ' SMUDGE OFFSET - , LATEST @ @ 8000 OR LATEST @ ! ;

: ALIAS'  CREATE ' , LATEST @ @ 8000 OR LATEST @ ! ;

COMPILER DEFINITIONS FORTH

: {'}-  { ' }  OFFSET - , ;

: \\' ' OFFSET - , ;

: \'   '  , ;

FORTH DEFINITIONS
." WORKSPACE CONSTANTS " CR
( WE DEFINE THESE AGAIN IN CASE THEY'RE DIFFERENT FROM THE HOST )
( WORKSPACE 1 BYTE ACCESS )
MEMSTART 100 +	DP' !	( LEAVE 64 WORDS FOR WORKSACE ADJUSTMENT ETC )

: NEWALLOT DP' @ + DP' ! ;

: VARIABLE DP' @ CONSTANT BPW NEWALLOT ;
FORTH DEFINITIONS
	VARIABLE WS
RUNTIME DEFINITIONS
	VARIABLE IP					( interpretive pointer )
	VARIABLE SP					( data stack pointer )
	VARIABLE RP					( return stack pointer )
	VARIABLE CP					( colon pointer - points to [COLON] )
	VARIABLE ASAVE
	VARIABLE DAP				( pointer to data address stack )
	VARIABLE MP					( pointer to message stack )
	VARIABLE STKLIM			( stack limit for underflow checking )
	VARIABLE RTNXT
	VARIABLE INTPFLG			( set is object interpretted not compiled )
FORTH DEFINITIONS
	VARIABLE USER
	9 BPW * NEWALLOT 			( 10 fast access words for user )
									( used at compile time and by expect )
( WORKSPACE 2 BYTE ACCESS )
	
	VARIABLE CURRENT
	VARIABLE DP					( DICT POINTER )
	VARIABLE DP'				( ALTERNATE DP FOR HEADERLESS CODE )
	VARIABLE H/C				( HEADERLESS FLAG )
	VARIABLE DP'INIT			( POINTS TO MEMALOCED AREA FOR LOCAL HEADS )
	VARIABLE METHTABPTR		( POINTS TO METHOD TABLE )
	VARIABLE SYMTABPTR		( POINTS TO METHOD TABLE )
	VARIABLE BASE
	VARIABLE CNT
	VARIABLE >IN
	VARIABLE >OUT
	VARIABLE BLK
	VARIABLE ECHO
	VARIABLE LINKINPTR
	VARIABLE LINKOUTPTR
 	VARIABLE SIZE			( keeps count of storage needed for data )
    VARIABLE PATHSIZE
	VARIABLE SELF			( POINT TO CURRENT CLASS )
	VARIABLE MODE			( COMP OR INTERP MODE )
	VARIABLE SAVEMODE
	VARIABLE FONE
    VARIABLE REPLYPORT
	VARIABLE NETWORKED
    VARIABLE OUTLINK
DEBUG DEFINITIONS
	VARIABLE TRACE
	VARIABLE ERTYPE
RUNTIME DEFINITIONS
	VARIABLE BSAVE
	VARIABLE ERRORVEC
	VARIABLE STRTVEC
	VARIABLE VOCLINK
	VARIABLE CONINDEX
	VARIABLE LATEST
	VARIABLE MARKER
	VARIABLE LINE#
	VARIABLE ANCHOR		( LINK ALLOCATED MEMORY HERE )
	VARIABLE WARMFLG
	VARIABLE CAPFP		( CAPTURE FP )
	VARIABLE STDOUTFP		( CAPTURE FP )
	VARIABLE LSTMSG
	VARIABLE MSGLINK
	VARIABLE *CR
	VARIABLE *KEY
	VARIABLE *GETLINE
    VARIABLE BYPASS
	VARIABLE TIB	 DECIMAL 76 NEWALLOT	HEX ( RESERVE 80 BYTES FOR TIB )
	VARIABLE TOB	 DECIMAL 76 NEWALLOT	HEX ( RESERVE 80 BYTES FOR TOB )
	VARIABLE CONARRAY VSTKSIZE BPW * NEWALLOT		( ARRAY FOR SAVING SEARCH PATH )
	DAPSIZE 1- BPW * NEWALLOT	VARIABLE DAPINIT	( RESERVE ?? BYTES FOR R-STACK )
	MPSIZE 1- BPW * NEWALLOT	VARIABLE MPINIT	( RESERVE ?? BYTES FOR MES-STACK )
	RSIZE 1- BPW * NEWALLOT	VARIABLE RPINIT		( RESERVE 128 BYTES FOR R-STACK )
 	DSIZE 1- BPW * NEWALLOT	VARIABLE SPINIT		( RESERVE 256 BYTES FOR D-STACK )
BPW ALLOT
ASSEMBLER DEFINITIONS
( host macros )
MACRO ;CODE		( CALL NEXT AND END CODE )
	RTNXT  ^^ LDL   GCALL
	END-CODE
END-MACRO

MACRO SP>A
	SP ^^ LDL
END-MACRO

MACRO TOP>A
	SP ^^ LDL 0 LDNL
END-MACRO

MACRO NEXT>A
	SP ^^ LDL 1 LDNL
END-MACRO

MACRO A>TOP
	SP ^^ LDL 0 STNL
END-MACRO

MACRO A>NEXT
	SP ^^ LDL 1 STNL

END-MACRO

MACRO SP2DROP
	SP ^^ LDL  BPW 2 * ADC, SP ^^ STL
END-MACRO

FORTH DEFINITIONS

( find address of next link in dictonary chain )
." SCAN "

: SCAN	( linkaddr --- nextlinkaddr/f ; find next link in target dict )
	BEGIN
		@							( newlink -- )
		DUP RUNTIMESTART @ SWAP > NOT	( newlink f -- )
	UNTIL							( nextlink -- )
;
." CLIP "

: CLRFLAGS
		DUP BPW+ DUP @	( NXT NXT THR THR+BPW CNT+CHAR -- )
		FF7FFF3F AND SWAP !	( NXT NXT THR -- )
;

: CLIP	( THREAD -- cut threads to host dict )
." CLIPPING " CR
	BEGIN				( THR -- )
		DUP				( THR THR -- )
		SCAN			( THR NXTTHR/F -- )
		SWAP OVER SWAP	( NXT NXT THR -- )
		CLRFLAGS
		A!				( NXT )
		DUP @ MINT=
	UNTIL
	CLRFLAGS
DROP
;
." START X-ASSM "
OFFSET SPINIT + BPW 2 * + OLDDP' !
}
RUNTIME DEFINITIONS
( NEXT is gcalled or jumped to at the end of a colon def )
( it pops the return addr from R-stack into IP and gets address pointed to )
( , inc IP then	GCALLS the code at the address )
( if this code is a normal code def the code GCALLS back i.e returns )
( and the IP next word called etc. )
( if the code is the COLON def then a gcall the [COLON] is made )
( by getting [COLON] address stored in the workspace CP )
( IP is pushed to R-stack and the address in A-reg is used to calc new IP )
( and COLON returns )
( at the end of a COLON def the IP points to a cell containing the )
( address of NEXT and NEXT undoes the previous COLON )
( the return address in the A register is never used again and is ignored )
( N.B. STACKS build down )
( RP + SP POINTS TO LASTS PUSHED VALUE NOT THE NEXT FREE SLOT )
HEX
( CP is a workspace location pointing to [COLON] CFA )
HERE RUNTIMESTART ! 

CODE [IF]
		SP POP 					(  POP TOP TO AREG )
		IF
			IP ++W				( SKIP OVER ELSE ADDR )
		ELSE
			IP *LOAD IP ^^ STL	( IF ZERO STUFF ELSE ADDR IN IP )
		THEN
RTNXT ^^ LDL GCALL
END-CODE
HEADERLESS
( hi level goto runtime code )
CODE [GOTO]
	IP *LOAD IP ^^ STL
	GCALL
END-CODE
( hi level loop runtime code )
CODE [DO]
	RP ^^ LDL   -BPW 3 * ADC, RP ^^ STL				( advance RP 3 cells )
	IP ^^ LDL   RP ^^ LDL   2 STNL				( R3 GETS IP FOR LOOPING BACK )
	NEXT>A RP ^^ LDL   1 STNL		( next goes to R next as limit )
	TOP>A RP *STORE		( top goes R top as count )
	SP2DROP				( adjust SP so 2 words drop )
	GCALL
END-CODE

CODE [LOOP]
	RP *LOAD 1 ADC, RP *STORE	( inc loop count )
	RP *LOAD RP ^^ LDL   1 LDNL DIFF	( compare with limit )
		IF										( if limit not reached )
			RP ^^ LDL   2 LDNL IP ^^ STL		( stuff loop address in ip )
		ELSE
			RP ^^ LDL   BPW 3 * ADC, RP ^^ STL			( limit reached drop 3 words from R)
		THEN
RTNXT ^^ LDL GCALL
END-CODE

." [DOES>] "
( does is accessed by adding a neg number to CP and gcalling )

CODE [DOES>]							( a has calling addr b has nxtret )
	ASAVE ^^ STL						( save calling addr )
	RP --W		( DEC RP )
	IP ^^ LDL   RP *STORE		( Store IP on R-stack )
	ASAVE ^^ LDL  						( calling adrr back again )
	BPW ADC, SP ^^ LDL   -1 STNL			( push address of variable on stack )
	SP --W		( adjust stack )
	ASAVE *LOAD IP ^^ STL		( put does> address it ip )
	GCALL
END-CODE

CODE [VAR]
	SP PUSH ( A has return address ; this is where the variable is stored )
	GCALL   ( B has the address of the NEXT loop this is where we gcall )
END-CODE

CODE [COLON]	 ( NEXTRETURN FWORDADDR -- )
	ASAVE ^^ STL				( NEXTRETURN -- SAVE FORTHWORDADDR )
	RP --W		                ( DEC RP )
	IP ^^ LDL   RP *STORE		( Store IP on R-stack )
	ASAVE ^^ LDL   2 ADC, IP ^^ STL		( calc new IP and save it )
	GCALL								( return to NEXT )
 END-CODE
." [COLON] DONE" CR
( too hard good nite )
CODE [CODEOB]
	ASAVE ^^ STL
	INTPFLG	^^ LDL
	IF	                        ( INTERP ie runtime call )
		0 LDC INTPFLG ^^ STL	( clear flag )
	ELSE                        ( compile time call )
		IP *LOAD				( get value from cell )
		DAP PUSH				( store value )
		IP ++W					( advance IP )
	THEN
	ASAVE ^^ LDL
	GCALL						( RETURN TO CODE )
END-CODE

CODE [OBJ]
	ASAVE ^^ STL				( SAVE CALLING ADDR )
	INTPFLG	^^ LDL
	IF	( INTERP )
		0 LDC INTPFLG ^^ STL	( clear flag )
	ELSE
		IP *LOAD				( get value from cell )
		IP ++W					( advance IP )
		DAP PUSH				( store value on stack )
	THEN
		IP ^^ LDL   RP PUSH	( Store IP on R-stack )
	ASAVE ^^ LDL 
	IP ^^ STL		( calc new IP and save it )
RTNXT ^^ LDL GCALL
END-CODE
( these run time routines are accessed by adding pos number to CP )
." NEXT " CR
( IP ALWAY POINTS TO A POINTER WHICH POINTS TO CODE )

CODE [NEXT]
	RP *LOAD IP ^^ STL			( pop IP from R-stack )
	RP ++W						( INC RP )
		BEGIN
			BEGIN
				IP *LOAD					( get address IP points to )
				IP ++W						( inc IP )
				GCALL						( execute it )
HERE RTNEXT !								( set RTNXT for execute )
				SP>A  						( get sp )
				STKLIM	^^ LDL  			( get stack limit )
			GT UNTIL						( if sp > lim fall through )
			1 LDC ERTYPE ^^ STL
			ERRORVEC ^^ LDL   GCALL			( CALL ERROR )
		AGAIN
END-CODE

CODE [DNEXT]				( DROP DAP STACK AND CALL NEXT )
	DAP ++W
	 ' [NEXT] JMPBACK
END-CODE
." NEXT DONE " CR
( N.B. these run time routines are accessed via CP )
( so their positions are important )
( and can't be more than 256 or less than 16 bytes from [colon] )
( Variable run time code , it also must be < 256 byte from colon )
( Constant run time code , it also must be < 256 byte from colon )

CODE [CON]	 ( nextret CALLINGADDR -- )
	0 LDNL							( nextret const --- get constant at areg addr )
	SP PUSH
	GCALL
END-CODE

CODE [WS,VAR]						( nextret , address of W + constant on tos )
	REV ASAVE ^^ STL				( CALLINGADDR -- save return address )
	0 LDNL							( CONST -- get literal at AREG )
	0 LDLP							( CONST WADDR -- get address of W )
	SUM SP PUSH			( -- add them and save at top )
	ASAVE ^^ LDL   GCALL
END-CODE

CODE [LITERAL] 
	IP *LOAD					( get value from cell )
	SP PUSH						( store value on stack )
	IP ++W						( advance IP )
	GCALL
END-CODE
( Vocabulary run time code , adds vocab to path )
DEBUG

CODE [VOC]					( areg = vocab variable breg = return to next )
	ASAVE ^^ STL 						( ADDRESS OF VOCAB )
	BSAVE ^^ STL						( RETURN ADDR )
	CONINDEX ^^ LDL						( CHECK CONINDEX )
	VSTKSIZE 1- LDC						( AGAINST STACKSIZE )
	GT IF 								( IF = OVERFLOW )
		2 LDC ERTYPE ^^ STL				( SET ERROR TYPE )
		ERRORVEC ^^ LDL GCALL			( CALL ERROR ROUTINE )
	THEN
	ASAVE ^^ LDL  						( RETRIEVE VOCAB ADDR )
	CONINDEX ^^  LDL					( GET WORD INDEX CONVERT TO BYTE INDEX )
	CONARRAY ^^  LDLP					( GET BASE ADDRESS OF CONARRAY )
	WSUB								( FIND BYTE ADDRESS OF NETXT FREE WORD )
	0 STNL								( ADD VOCAB TO PATH )
	CONINDEX ^^  LDL USER ^^ STL				( LOOP COUNTER FOR SEARCH )
	CONINDEX ++B		( INC CONINDEX )
	MINT USER ^^ BPW+ STL					( FLAG OF SEARCH )
	BEGIN								
		USER --B
		USER ^^ BPW+ LDL MINT DIFF NOT
		USER ^^ LDL   -1 LDC GT AND 
	WHILE								
		USER ^^ LDL   CONARRAY ^^  LDLP WSUB 
		0 LDNL ASAVE ^^ LDL   DIFF NOT
			IF									( MATCH FOUND ) 
				USER ^^ LDL   USER ^^ BPW+ STL	( SAVE INDEX IN USER+4 )
			THEN	
	REPEAT
	USER ^^ BPW+ LDL MINT DIFF
		IF										( MATCH FOUND DO MOVE ETC )
			CONINDEX ^^  LDL USER ^^ BPW+ LDL
			-1 ADC, SUB BPW LDC PROD
			USER ^^ STL							( LENGTH IN BYTES )
			USER ^^ BPW+ LDL
			CONARRAY ^^  LDLP WSUB				( DEST ADDR )
			USER ^^ BPW+ STL
			USER ^^ BPW+ LDL BPW ADC,
			USER ^^ BPW+ LDL						( SOURCE ADDR )
			USER ^^ LDL  						( GET CNT )
			MOVE
			CONINDEX --B 
		THEN
	BSAVE ^^ LDL
	GCALL
END-CODE
HEADS

CODE [OUTLINE]
	IP ^^ LDL
	RP PUSH					( PUSH IP > R )
	-1 ADC, -4 LDC AND 4 ADC,	( WORD ALIGN )
	IP ^^ STL
	RTNXT ^^ LDL GCALL			( START INNER INTERP. )
END-CODE

CODE [INLINE]
	IP ^^ LDL
	RP POP
	IP ^^ STL
	GCALL	( START CODE )
END-CODE
HERE FORTHSTART !

FORTH DEFINITIONS

CODE CONTEXT
	CONINDEX ^^  LDL -1 ADC,				( GET WORD INDEX CONVERT TO BYTE INDEX )
	CONARRAY ^^  LDLP						( GET BASE ADDRESS OF CONARRAY )
	WSUB								( FIND BYTE ADDRESS OF TOP WORD )
    SP PUSH
RTNXT ^^ LDL GCALL
END-CODE
HEADERLESS

CODE CMOVE	 ( SRC DST CNT -- )
	SP ^^ LDL   2 LDNL	( SRC > C )
	NEXT>A	( DST > B )
	TOP>A	( CNT > A )
	MOVE
	SP ^^ LDL   BPW 3 * ADC, SP ^^ STL
RTNXT ^^ LDL GCALL
END-CODE

CODE SP!	 ( reset data stack pointer )
	SPINIT ^^ ( WS - BPW / ) LDLP
	SP ^^ STL
	GCALL
END-CODE

CODE DAP!	 ( reset data pntr stack pointer )
	DAPINIT ^^ ( WS - BPW / ) LDLP
	DAP ^^ STL
	GCALL
END-CODE

CODE MP!	 ( reset data pntr stack pointer )
	MPINIT ^^ ( WS - BPW / ) LDLP
	MP ^^ STL
	GCALL
END-CODE

CODE  RP!	 ( reset return stack pointer )
	RPINIT ^^ ( WS - BPW / ) LDLP
	RP ^^ STL
	GCALL
END-CODE

CODE EXECUTE	 ( addr -- )
	SP POP 		( GET EXEC ADDR FROM TOS )
	GCALL					( CALL EXEC ADDR )
RTNXT ^^ LDL GCALL
END-CODE

CODE @	 ( addr - W , fetch word at addr to tos )
	TOP>A 0 LDNL				( get **SP )
	A>TOP						( store in top )
	GCALL
END-CODE

CODE C@	 ( addr - B , fetch byte at addr to tos )
	TOP>A LB					( get **sp )
	A>TOP						( store in top )
	GCALL
END-CODE

CODE !	 ( W addr --   store word at addr )
	NEXT>A TOP>A 0 STNL	( get num and addr and store it )
	SP2DROP					( move sp back 2 words )
	GCALL
END-CODE

CODE C!	 ( B addr --   store byte at addr )
	NEXT>A TOP>A SB	( get num and addr and store it )
	SP2DROP					( move sp back 2 words )
	GCALL
END-CODE
( THIS MAY BE THE WRONG ORDER )

CODE +!	 	( *addr inc -- ADD TOS TO *ADDR AT NEXT eg	DP 1 +! TO INC DP )
	TOP>A 0 LDNL				( RET *NEXT -- get word *NEXT )
	NEXT>A						( RET *NEXT TOP -- get TOP )
	SUM									( RET SUM -- )
	TOP>A 0 STNL				( RET -- save result at *NEXT )
	SP2DROP					( RET -- drop top and next )
	GCALL
END-CODE

CODE + 
	SP POP TOP>A SUM		( get top+next into a+b , add )
	A>TOP						( store in next )
	GCALL
END-CODE

CODE 1-		 							( DEC TOS BY 1 )
	TOP>A -1 ADC,
	A>TOP
	GCALL
END-CODE

CODE 2-									( DEC TOS BY 2 )
	TOP>A -2 ADC,
	A>TOP
	GCALL
END-CODE

CODE 4-									( DEC TOS BY 4 )
	TOP>A -4 ADC,
	A>TOP
	GCALL
END-CODE

CODE 1+									( INC TOS BY 1 )
	TOP>A 1 ADC,
	A>TOP
	GCALL
END-CODE

CODE 2+									( INC TOS BY 2 )
	TOP>A 2 ADC,
	A>TOP
	GCALL
END-CODE

CODE 4+									( INC TOS BY 4 )
	TOP>A 4 ADC,
	A>TOP
	GCALL
END-CODE

CODE 2/									( DIV TOS BY 2 )
	TOP>A 2 LDC DIV
	A>TOP
	GCALL
END-CODE

CODE 2*									( MULT TOS BY 2 )
	TOP>A 2 LDC PROD
	A>TOP
	GCALL
END-CODE

CODE AND 
	SP POP TOP>A AND		( get top+next into a+b , and )
	A>TOP						( store in next )
	GCALL
END-CODE

CODE OR 
	SP POP TOP>A OR		( get top+next into a+b , or )
	A>TOP						( store in next )
	GCALL
END-CODE

CODE XOR 
	SP POP TOP>A XOR		( get top+next into a+b , xor )
	A>TOP						( store in next )
	GCALL
END-CODE

CODE -
	NEXT>A TOP>A DIFF		( get top+next into a+b , sub )
	A>NEXT						( store in next )
	SP ++W					( move sp back 1 word )
	GCALL
END-CODE

CODE / 
	NEXT>A TOP>A DIV		( get top+next into a+b , div )
	A>NEXT						( store in next )
	SP ++W					( move sp back 1 word )
	GCALL
END-CODE

CODE U/ 
		0 LDC								( 0 GOES INTO C )
	NEXT>A TOP>A LDIV							( get top+next into a+b , ldiv )
	A>NEXT					( store in next )
	SP ++W			( move sp back 1 word )
RTNXT ^^ LDL GCALL
END-CODE

CODE UMOD 
		0 LDC								( 0 GOES INTO C )
	NEXT>A TOP>A LDIV							( get top+next into a+b , ldiv )
	REV A>NEXT				( store in next )
	SP ++W			( move sp back 1 word )
RTNXT ^^ LDL GCALL
END-CODE

CODE U/MOD
		0 LDC								( 0 GOES INTO C )
	NEXT>A TOP>A LDIV					( get top+next into a+b , ldiv )
	A>TOP									( store Q in TOP )
	A>NEXT								( STORE R IN NEXT )
RTNXT ^^ LDL GCALL
END-CODE

CODE MOD
	NEXT>A TOP>A REM							( get top+next into a+b , REM )
	A>NEXT					( store in next )
	SP ++W			( move sp back 1 word )
	GCALL
END-CODE

CODE * 
	SP POP TOP>A PROD							( get top+next into a+b , mult )
	A>TOP					( store in next )
	GCALL
END-CODE

CODE = 
	SP POP TOP>A DIFF							( get top+next into a+b , gt )
	0 EQC								( if result 0 convert to true )
	A>TOP					( store in next )
	GCALL
END-CODE

CODE > 
	NEXT>A TOP>A GT							( get top+next into a+b , gt )
	A>NEXT					( store in next )
	SP ++W			( move sp back 1 word )
	GCALL
END-CODE

CODE < 
	TOP>A NEXT>A GT						( get next+top into a+b , gt )
	A>NEXT					( store in next )
	SP ++W			( move sp back 1 word )
	GCALL
END-CODE

CODE 0<
	0 LDC TOP>A GT			( get top a , b=0	, gt )
	A>TOP					( store in top )
	GCALL
END-CODE

( NOT AND 0= ARE THE SAME THING )

CODE 0=	 ( W -- t/f )
	TOP>A 0 EQC			( is top = 0 )
	A>TOP					( store in top )
	GCALL
END-CODE

CODE NOT	 ( W - t/f )
	TOP>A 0 EQC			( is top = 0 )
	A>TOP					( store in top )
	GCALL
END-CODE

CODE MINT=	 ( W -- t/f )
	TOP>A MINT DIFF NOT		( is top = MINT )
	A>TOP					( store in top )
	GCALL
END-CODE

CODE DUP	 ( W - W W )
	TOP>A
 	SP PUSH
	GCALL
END-CODE

CODE ?DUP 								( DUP if non zero )
		TOP>A					( TOP TO AREG )
	IF
		TOP>A
		SP PUSH
	THEN
RTNXT ^^ LDL GCALL
END-CODE

CODE DROP	 ( W -- )
	SP ++W
	GCALL
END-CODE

CODE OVER	 ( A B -- A B A )
	SP ^^ LDL 1 LDNL
	SP PUSH
	GCALL
END-CODE

HEADS

CODE SWAP	( A B -- B A )
	TOP>A
	NEXT>A
	A>TOP
	A>NEXT
RTNXT ^^ LDL GCALL
END-CODE

CODE >R									( MOVE TOS TO RS )
	SP POP RP PUSH								( MOVE TOS THERE )
	GCALL
END-CODE

CODE R>									( RET -- MOVE RS TO TOS )
	RP POP
	SP PUSH								( RET -- MOVE R THERE )
	GCALL
END-CODE

( SAME AS R> EXCEPT R ISN'T DROPED )

CODE I									( MOVE RS TO TOS )
	RP *LOAD
	SP PUSH								( MOVE R THERE )
	GCALL
END-CODE

CODE LEAVE								( MAKE R = TO R NEXT - 1 )
	RP ^^ LDL   1 LDNL					( GET R NEXT )
	-1 ADC,								( DEC )
	RP *STORE					( STORE IN R )
	GCALL
END-CODE

CODE TRUE	( -- T )
	1 LDC SP PUSH			( PUT A 1 THERE )
	GCALL
END-CODE

CODE FALSE	( -- F )
	0 LDC SP PUSH				( PUT A 0 THERE )
	GCALL
END-CODE

CODE 0	( -- 0 )
	0 LDC SP PUSH				( PUT A 0 THERE )
	GCALL
END-CODE

CODE 1	( -- 1 )
	1 LDC SP PUSH				( PUT A 1 THERE )
	GCALL
END-CODE

CODE 2	( -- 2 )
	2 LDC SP PUSH				( PUT A 2 THERE )
	GCALL
END-CODE

CODE 4	( -- 4 )
	4 LDC SP PUSH				( PUT A 4 THERE )
	GCALL
END-CODE

CODE -1	( -- -1 )
	-1 LDC SP PUSH				( PUT A -1 THERE )
	GCALL
END-CODE

CODE -2	( -- -2 )
	-2 LDC SP PUSH				( PUT A -2 THERE )
	GCALL
END-CODE

CODE -4	( -- -4 )
	-4 LDC SP PUSH				( PUT A -4 THERE )
	GCALL
END-CODE

CODE MINT	( -- MINT )
	MINT SP PUSH					( PUT MINT THERE )
	GCALL
END-CODE

CODE HERE	( -- DP@ )						( PUSH DP ON STACK )
	DP ^^  LDL SP PUSH
	GCALL
END-CODE

CODE HEREW									( PUSH DP ON STACK )
	DP ^^  LDL -1 ADC, -BPW LDC AND BPW ADC,		( ADRRESS OF FIRST FREE WORD )
	SP PUSH
	GCALL
END-CODE

CODE -FIND		( TEXT,LINK --> TEXT FALSE | CFA, TRUE :- USER = NFA )
	NEXT>A							( TEXT -- )
	TOP>A							( TEXT LINK -- )
	-10 AJW							( TEXT LINK -- CLAIM 10 WORDS WORKSPACE )
	1 STL 2 STL						( -- LINK > WS1 TEXT > WS2 )
	8080 LDC COMP 6 STL
	0 LDC USER ^^ STL				( CLEAR USER-10  )
	BEGIN
		1 LDL 0 LDNL MINT DIFF NOT	( TRUE IF LINK = MINT )
		USER ^^ LDL   MINT DIFF NOT	( TRUE IF USER = MINT )
		OR NOT						( FALSE IF USER|LINK = MINT )
	WHILE							( WHILE USER != MINT AND LINK != MINT )
		1 LDL USER ^^ 11 + STL		( STORE PREVIOUS LINK IN USER1 )
		1 LDL 0 LDNL 1 STL			( LINK@ )
		1 LDL BPW ADC, 3 STL			( WS3 = NFA )
		3 LDL LB 1 ADC,				( GET CNT )
		BPW STL						( WS4 = CNT )
		0 LDC 5 STL					( WS5 = BYTE INDEX )
		BEGIN
			3 LDL 5 LDL SUM	0 LDNL	( GET *NFA+INDEX )
			6 LDL AND 
			2 LDL 5 LDL SUM 0 LDNL	( GET *TEXT+INDEX )
			DIFF USER ^^ STL		( GET DIFF > USER )
			BPW LDL -BPW ADC, BPW STL		( DEC CNT )
			5 LDL BPW ADC, 5 STL		( INC INDEX )
			0 LDC BPW LDL GT  		( 0< )
			USER ^^ LDL NOT NOT OR
		UNTIL						( UNTIL USER TRUE OR CNT <=0 )
	REPEAT
	USER ^^ LDL   MINT DIFF				( MINT = NOT )
		IF
			FALSE LDC SP ^^ 10 + LDL 0 STNL
		ELSE
			5 LDL -1 ADC, 3 LDL SUM	( CALC CFA )
			-BPW LDC AND BPW ADC,
			SP ^^ 10 + LDL 1 STNL
			TRUE LDC SP ^^ 10 + LDL 0 STNL
		THEN
	1 LDL BPW ADC,						( NFA )
	10 AJW							( RELEASE 10 WORDS WS )
	USER ^^ STL
	USER ^^ LDL 0 LDNL 8000 LDC AND
		IF
			NEXT>A
			0 LDNL
			A>NEXT
		THEN
RTNXT ^^ LDL GCALL
END-CODE

 ." end runtime stuff "
CR
( the vocabs are linked together so their contents can be save and restored )
{

: VOCABULARY
HERE
CREATE
COMPILE
[ { '  [VOC] ' [COLON] } - ASSEMBLER 
CP ^^ LDL   ADC, GCALL VDROP ]
HERE 	OLDLATEST !			            ( SAVE HERE SO WE CAN UNLINK VOC )
CONTEXT @ @ ,			                ( LINK TO CONTEXT DICT )
HERE OFFSET - VOCLINK OFFSET + @ ,		( LINK TO PREVIOUS VOCAB )
VOCLINK OFFSET + !				        ( POINT VOCLINK HERE )
BPW+ OFFSET - , 						( PIONT BACK TO NAME OF VOCAB )
;

: UNLINKVOCAB
	MINT OLDLATEST @ !
;

}
MINT VOCLINK OFFSET + !
VOCABULARY FORTH		OLDLATEST @ @ UNLINKVOCAB
FORTH DEFINITIONS
VOCABULARY RUNTIME		OLDLATEST @ !
VOCABULARY COMPILER		UNLINKVOCAB
VOCABULARY ASSEMBLER	UNLINKVOCAB
VOCABULARY FPUASM	 	UNLINKVOCAB
VOCABULARY DEBUG	UNLINKVOCAB
VOCABULARY MISC			UNLINKVOCAB

{
." FORTH + COMPILER VOCABS CREATED " CR

: CONSTANT
	CREATE
	COMPILE
[	{ ' [CON] ' [COLON] } -		( CALCULATE OFFSET )
	ASSEMBLER
	CP ^^ LDL  
	ADC, GCALL
	VDROP ]
	,
;

: WS,VAR					( OFFSET FROM W )
	CREATE
	COMPILE
[	{ ' [WS,VAR] ' [COLON] } -		( CALCULATE OFFSET )
	ASSEMBLER
	CP ^^ LDL  
	ADC, GCALL
	VDROP ]
	WS - ,
;

: VARIABLE
	CREATE
	COMPILE
[	{ ' [VAR] ' [COLON] } - 
	ASSEMBLER
	CP ^^ LDL  
	ADC, GCALL
	VDROP ]
	MINT ,
;
VARIABLE BOOTINFO -BPW ALLOT
OLDLINKINPTR @ ,
OLDLINKOUTPTR @ ,
WS ,
MINT ,

CR ." CONSTANTS + VARIABLE DEFINED " CR
." MOVEFORTH "

CODE MOVEFORTH
(	OLDLINKINPTR ^^ LDL  
(	OLDDP' LDC 0 STNL			( SAVE LINKADDR )
FORTH WS dA' @ + ASSEMBLER 
	LDC						( SRC > C , WS IS FORTH VARIABLE )
	WS LDC					( DST > B )
	MAINLENGTH LDC 0 LDNL	( CNT > A , MAINLENGTH IS FORTH VARIABLE )
	MOVE
	' BOOTINFO BPW+ LDC
 	STARTUPADDRESS LDC 0 LDNL GCALL
END-CODE

: PRUNE
." PRUNING " CR
	MINT RUNTIMESTART @ !
	RUNTIME OLDCONTEXT @ @ CLIP
	MINT FORTHSTART @ !
	FORTH OLDCONTEXT @ @ CLIP
	MINT COMPILERSTART @ !
	COMPILER OLDCONTEXT @ @ CLIP
	MINT DEBUGSTART @ !
	DEBUG OLDCONTEXT @ @ CLIP
	MOVEFORTH 
;

}

RUNTIME DEFINITIONS
	." CREATING TARGET SYSTEM CONSTANTS " CR
	( these constants are word offsets from WS )
	( the 32 bits addresses are in forth voc. )
	( N.B. do not use WS+0 when using io etc )
	IP		WS,VAR IP	( interpretive pointer )
	SP		WS,VAR SP	( data stack pointer )
	RP		WS,VAR RP	( return stack pointer )
	CP		WS,VAR CP	( colon pointer - points to [COLON] )
	ASAVE	WS,VAR ASAVE
	DAP		WS,VAR DAP
	MP		WS,VAR MP
	MPINIT		WS,VAR MPINIT
	STKLIM	WS,VAR STKLIM
	BSAVE	WS,VAR BSAVE
	ERRORVEC	WS,VAR ERRORVEC
	RTNXT	 WS,VAR RTNXT
	INTPFLG WS,VAR INTPFLG
	STRTVEC	WS,VAR STRTVEC
	VOCLINK	WS,VAR VOCLINK
	CONINDEX WS,VAR CONINDEX
	CONARRAY WS,VAR CONARRAY
	LATEST	WS,VAR LATEST
	MARKER	WS,VAR MARKER
	LINE#	WS,VAR LINE#
	ANCHOR	WS,VAR ANCHOR
	WARMFLG	WS,VAR WARMFLG
	CAPFP	WS,VAR CAPFP
	STDOUTFP	WS,VAR STDOUTFP
	MSGLINK	WS,VAR MSGLINK
	LSTMSG	WS,VAR LSTMSG
	*CR		WS,VAR *CR
	*KEY	WS,VAR *KEY
(	*TYPE	WS,VAR *TYPE
	*GETLINE	WS,VAR *GETLINE
	BYPASS	WS,VAR BYPASS
	TIB		WS,VAR TIB
	TOB		WS,VAR TOB
	FORTH DEFINITIONS
	WS		WS,VAR WS
	USER	WS,VAR USER
	CURRENT	WS,VAR CURRENT
	DP		WS,VAR DP
	DP'		WS,VAR DP'				( ALTERNATE DP FOR HEADERLESS CODE )
	H/C		WS,VAR H/C				( HEADERLESS FLAG )
	DP'INIT	WS,VAR DP'INIT			( POINTS TO MEMALOCED AREA FOR LOCAL HEADS )
	BASE	WS,VAR BASE
	CNT		WS,VAR CNT
	>IN		WS,VAR >IN
	>OUT	WS,VAR >OUT
	BLK		WS,VAR BLK
	ECHO	WS,VAR ECHO
	LINKINPTR	WS,VAR LINKINPTR
	LINKOUTPTR	WS,VAR LINKOUTPTR
	SIZE	WS,VAR SIZE
    PATHSIZE WS,VAR PATHSIZE
	SELF 	WS,VAR SELF
	MODE	WS,VAR MODE
	SAVEMODE WS,VAR SAVEMODE
	FONE	WS,VAR FONE
	METHTABPTR	WS,VAR METHTABPTR
	SYMTABPTR	WS,VAR SYMTABPTR
	REPLYPORT	WS,VAR REPLYPORT
	NETWORKED	WS,VAR NETWORKED
	OUTLINK	WS,VAR OUTLINK
	HERE DEBUGSTART !
DEBUG DEFINITIONS FORTH
	TRACE	WS,VAR TRACE
	ERTYPE	WS,VAR ERTYPE
FORTH DEFINITIONS
." TARGET CODE WORDS "
RUNTIME

CODE WORD	( N - A )
	TOP>A
	USER ^^ STL			( remember delimiter in USER )
	DP ^^  LDL -1 ADC, -BPW LDC AND BPW ADC,	( ADRRESS OF FIRST FREE WORD )
	USER ^^ 1+ STL			( HEREW > USER+1 )
	USER ^^ 1+ LDL 1 ADC,
	USER ^^ 2+ STL			( *TO > USER+2 )
	>IN ^^  LDL				( idst dst >in --> position of first char to input)
	TIB ^^  LDLP SUM			( idst dst scr --> mem addr of first char )
	USER ^^ 3 + STL		( *FROM > USER+3 )
	BEGIN				( FIND FIRST VALID CHAR OR EOL )
		21 LDC USER ^^ 3 + LDL LB GT					( CHAR < 20 ? )
		CNT ^^  LDL	>IN ^^  LDL GT AND
	WHILE									( CHAR < 20 & >IN < CNT 
		USER ^^ 3 + LDL 1 ADC, USER ^^ 3 + STL		( INC *FROM )
		>IN ++B				( INC >IN )
	REPEAT
	BEGIN
		USER ^^ LDL   USER ^^ 3 + LDL LB DIFF NOT NOT	( CHAR < 20 ? )
		CNT ^^  LDL	>IN ^^  LDL GT AND
	WHILE
		USER ^^ 3 + LDL LB						( GET CHAR )
		USER ^^ 2+ LDL SB						( STORE CHAR )
		USER ^^ 3 + LDL 1 ADC, USER ^^ 3 + STL		( INC *FROM )
		USER ^^ 2+ LDL 1 ADC, USER ^^ 2 + STL		( INC *TO )
		>IN ^^  LDL 1 ADC, >IN ^^  STL				( INC >IN )
	REPEAT
	>IN ++B				( INC >IN )
	USER ^^ 2+ LDL USER ^^ 1+ LDL DIFF	-1 ADC,			( CALC CHAR COUNT )
	USER ^^ 1+ LDL SB							( SAVE CNT IN HERE )
	BEGIN
		USER ^^ 2+ LDL
		3 LDC AND
	WHILE
		0 LDC USER ^^ 2+ LDL SB
		USER ^^ 2+ LDL 1 ADC, USER ^^ 2+ STL
	REPEAT
	USER ^^ 1+ LDL
	A>TOP
RTNXT ^^ LDL GCALL
END-CODE

CODE LOCALKEY
	0 LDC SP PUSH					( null tos so high byte 0 )
	SP>A								( get address of top will become C )
	LINKINPTR ^^  LDL						( get address of link to B )
	1 LDC IN							( make cnt 1, get char)
	RTNXT ^^ LDL GCALL
END-CODE

CODE KEY	( -- CHAR )
	*KEY ^^ LDL GCALL
	RTNXT ^^ LDL GCALL
END-CODE

CODE WEMIT	( W -- 		send word down link )
	LINKOUTPTR ^^  LDL						( get address of link to B )
	TOP>A OUTWORD				( get WORD to areg send it )
	SP ++W					( drop tos )
RTNXT ^^ LDL GCALL
END-CODE

CODE ROT	( A B C -- B C A )	SP ^^ LDL   2 LDNL
	NEXT>A
	SP ^^ LDL   2 STNL
	TOP>A
	A>NEXT
	A>TOP
RTNXT ^^ LDL GCALL
END-CODE

CODE PICK ( . . N - W )
	TOP>A
	2 LDC SHL SP>A   SUM
	0 LDNL A>TOP
	GCALL
END-CODE

." DEFINING EXPECT " CR

CODE EXPECT	( ADDR NUM --- )
	-10 AJW							( CLAIM 10 WORDS WORKSPACE )
	1 STL							( SAVE RETURN ADDRESS )
	SP ^^ 10 + LDL 1 LDNL				( SP IS 10 WORDS HIGHER THAN USUAL )
	SP ^^ 10 + LDL 0 LDNL				( ADDR NUM -- )
	SP ^^ 10 + LDL BPW 2 * ADC, SP ^^ 10 + STL	( DROP STACK )
	USER ^^ STL						( adr -- SAVE CHR LIMIT IN NEW USER )
	USER ^^ 1+ STL 0 LDC USER ^^ 2+ STL	( SAVE TIB , INITIALIZE CNT	)
	0 LDC 3 STL						( USE AS FLAG FOR CR )
	BEGIN
		BEGIN
			0 LDC 2 STL						( null 2 so high byte 0 )
			2 LDLP							( get address of top will become C )
			LINKINPTR ^^  10 + LDL				( get address of link to B )
			1 LDC IN						( make cnt 1, get char)
			2 LDL 8 EQC
				IF
					USER ^^ 2+ LDL			( ARE THERE ANY CHARS IN BUFFER )
						IF
							USER ^^ 2+ LDL
							-1 ADC, USER ^^ 2+ STL
							BLK ^^  10 + LDL MINT DIFF NOT
								IF 
									LINKOUTPTR ^^  10 + LDL
									2 LDL OUTBYTE	( ECHO BS )
								THEN
						THEN
				THEN
			2 LDL 8 EQC NOT
		UNTIL
		2 LDL A EQC
			IF
				0D LDC 2 STL 
			THEN	
		2 LDL D EQC
			IF
				20 LDC 2 STL TRUE LDC 3 STL
				LINE# ^^ 10 + LDL 1 ADC, LINE# ^^ 10 + STL		( INC LINE CNT )
			THEN	( IF CR > SPACE )
		BLK ^^  10 + LDL MINT DIFF NOT
			IF
				LINKOUTPTR ^^  10 + LDL
				2 LDL OUTBYTE	( ECHO )
			THEN
		2 LDL 9 EQC						( TEST FOR TAB )
			IF
				20 LDC 2 STL			( MAKE A SPACE )
			THEN
		2 LDL USER ^^ 1+ LDL USER ^^ 2+ LDL SUM SB
		USER ^^ 2+ LDL 1 ADC, USER ^^ 2+ STL
		USER ^^ 2+ LDL USER ^^ LDL   GT 3 LDL OR	
	( while last char not cr + more expected )
	 UNTIL
	 USER ^^ 2+ LDL -1 ADC, CNT ^^  10 + STL
	1 LDL							( RECOVER RETURN ADDRESS )
	10 AJW							( RELEASE WORKSPACE )
	0 LDC >IN ^^  STL
	GCALL
END-CODE

CODE GETTIMER	( -- TIME )
	LDTIMER SP PUSH	( GET TIMER TO TOS )
	GCALL
END-CODE

CODE DELAY	( N -- DELAY N 64 uS TICKS )
		SP POP
		LDTIMER SUM TIN			( GET TIME ADD DELAY STORE TIME )
RTNXT ^^ LDL GCALL
END-CODE

CODE TIMERWAIT	( N -- WAIT N 64 uS TICKS )
		SP POP
		TIN			( GET TIME ADD DELAY STORE TIME )
RTNXT ^^ LDL GCALL
END-CODE

CODE BITREV32
	SP POP
	BITREVWORD
	SP PUSH
	RTNXT ^^ LDL GCALL
END-CODE

CODE BITREV16
	SP POP
	10 LDC
	BITREVNBITS
	SP PUSH
	RTNXT ^^ LDL GCALL
END-CODE
." END CODE WORDS "
{
COMPILER DEFINITIONS FORTH
0

: ELSE	( IFADDR 1 -- ELSEADDR 1 )
	 1 = IF						( check byte compare )
		 COMPILE {'}-    [GOTO]			( COMPILE CALL TO [GOTO] )
		 HERE 0 ,				( remember here,reserve space for addr )
		 SWAP HERE SWAP A! 1	( patch if jump )
	ELSE
		 ERROR1					( conditional not paired )
	THEN
; REMSMUDGE

: THEN	( IF|ELSE-ADDR 1 -- )
	 1 = IF							( checkbyte )
			 HERE SWAP A!			( patch if jump )
		 ELSE
			 ERROR1					( not paired )
		 THEN
; REMSMUDGE

: BEGIN	( BEGINADDR 2 -- )
	HERE 2							( remember here save checkbyte )
; REMSMUDGE

: WHILE	( BEGINADDR 2 -- BEGINADDR WHILEADDR 3 )
	2 = IF
		COMPILE  {'}-  [IF] 
		HERE 3 0 ,
	ELSE
		ERROR1
	THEN
; REMSMUDGE

: REPEAT	( 3 B W -- )
	3 = IF
		SWAP									( get begin addr )
		COMPILE  {'}-  [GOTO]							( compile goto )
		A,										( point BEGIN here )
		HERE SWAP
 A!							( patch while )
	ELSE
		ERROR1
	THEN
; REMSMUDGE

: DO	( -- )
	COMPILE  {'}-  [DO]
	4
; REMSMUDGE

: LOOP ( -- )
	4 = IF
			COMPILE  {'}-  [LOOP]
	ELSE
		ERROR1
	THEN
; REMSMUDGE

: UNTIL	( BEGINADDR 2 -- )
	2 = IF
	 COMPILE  {'}-  [IF]
		A,											( branch back if !0 )
	ELSE
		ERROR1
	THEN
; REMSMUDGE

: AGAIN	( BEGINADDR 2 -- )
	2 = IF
		COMPILE  {'}-  [GOTO]
		A,											( branch back ) 
	ELSE
		ERROR1
	THEN
; REMSMUDGE

: IF	( -- IFADDR 2 )
	 COMPILE  {'}-  [IF]					( compile call to [IF] )
 HERE 0 , 1							( remember here,reserve space for addr )
; REMSMUDGE

: EXIT COMPILE  {'}-  [NEXT] ; REMSMUDGE

: LITERAL
COMPILE  {'}-  [LITERAL]					( jump to [literal] )
,									( store number here )
;
." DEFINING host [ " CR
FORTH DEFINITIONS

: ]
	BEGIN
		BEGIN
			20 WORD
			C@
		WHILE
			HEREW [ ' COMPILER BPW+ ] OLDLITERAL -FIND
					(	search compiler vocab )
			IF									( WORD FOUND IN COMPILER )
 				EXECUTE							( execute compiler word )
			ELSE
					dA @ IF						( if da!=0 set relocates bit )
						HEREW @ 800000 XOR HEREW !
					THEN
				DROP -' 
				?DUP
				IF
					OFFSET - ,							( COMPILE AND CALL TO IT )
				ELSE
					HEREW 2+ C@ 7F AND HEREW 2+ C!
					HEREW NUMBER \' LITERAL
				THEN
			THEN
		REPEAT
	OLDBLK @ MINT= IF CR THEN
	OLDTIB 80 EXPECT
	AGAIN
;

UNSMUDGE
0 
( host version of : )

: :
	HERE BPW+ OLDLATEST !				( SAVE ADDRESS OF CFA FOR SMUDGE )
	CREATE COMPILE
	[ ASSEMBLER CP ^^ LDL   GCALL NOP NOP FORTH OLD]
	SMUDGE
	OLDSP @ OLDUSER 14 + !
	]
; REMSMUDGE
COMPILER DEFINITIONS FORTH
( host version of ; )

: ;
	COMPILE {'}-  [NEXT] R> DROP SMUDGE
	OLDSP @ OLDUSER 14 + @ = NOT 
	OLDIF OLDABORT" DEFINITION NOT FINISHED " OLDTHEN 
;

UNSMUDGE
}
FORTH DEFINITIONS
ALIAS' BPW  4		( BYTES PER WORD )
ALIAS' BPW+ 4+
ALIAS' BPW- 4-
ALIAS' -BPW  -4

: EMIT	( CHAR -- )
	>OUT C@ [ TOBSIZE ] LITERAL <
	IF
		TOB >OUT C@ + C!	( PUT CHAR TO TOB )
		1 >OUT +!			( INC >OUT )
	ELSE DROP
	THEN
;

: TYPE							( CNTADDR -- NEXTADDR )
			DUP C@				( CNTADDR CNT -- )
			SWAP 1+ SWAP 
			OVER OVER + >R 		( TEXTADDR CNT --> SAVE NXT )
			0	DO
					DUP I + C@ 7F AND EMIT
				LOOP
		DROP R>
;

RUNTIME DEFINITIONS
." DOT " CR

: dot"
	 R> TYPE 1- -4 AND 4+ >R
;
{
COMPILER DEFINITIONS FORTH
OLD: ."
	COMPILE {'}-  dot"	( compile dot",  )
	22 STRING
OLD;
}
FORTH DEFINITIONS

: DECIMAL A BASE !
;

: WITHIN ( N1 N2 N3 -- T/F ; is N1 within the range N2 - N3 inclusive )
  OVER OVER < IF SWAP THEN  ( N1 H L -- put lower limit on top )
  ROT SWAP OVER             ( H N1 L N1 -- )
  > >R                      ( H N1 -- )
  < R> OR NOT               ( T/F )
;

: HEX 10 BASE ! ;

: DEPTH STKLIM @ SP @ - BPW / 2- ;
CR ." COMPILING TARGET FORTH WORDS " CR
." CR .. " CR

CODE PUTBYTE	( BYTEDATA CHAN -- )
	TOP>A NEXT>A		( get chan to B and data to A )
	OUTBYTE				( get num and addr and store it )
	SP2DROP				( move sp back 2 words )
;CODE

: CR *CR @ EXECUTE ;

: LOCALCR
	>OUT C@ ( DUP 80040000 ! )
	?DUP
	IF
		0 DO 
			TOB I + ( 80040004 ! ) C@ LINKOUTPTR @ PUTBYTE
		LOOP
		0 >OUT !
	THEN
	D  LINKOUTPTR @ PUTBYTE
	A  LINKOUTPTR @ PUTBYTE
;

: SPACE 20 EMIT ;

: SPACES DUP 0 > IF 0 DO SPACE LOOP ELSE DROP THEN ;

DECIMAL

: /MOD	( U U -- R Q )
	OVER OVER / >R MOD R>
;

: ABS	( N - U ) DUP 0< IF 0 SWAP - THEN ;

: NEGATE 0 SWAP - ;
HEADERLESS

: HOLD	( ..# X N - ..# X)
	SWAP >R SWAP 1 + R>
;
RUNTIME DEFINITIONS

: DIGIT	 ( N - N)
	DUP 9 > IF 7 + THEN 48 +
;

: <#	 ( N - ..* N)
	-1 SWAP
;

: #>	 ( ..# N)
	DROP -1 DO EMIT LOOP
;

: #		 ( ..# N - ..# N)	BASE @ U/MOD SWAP
	DIGIT HOLD ;

: #S	 ( ..# N - ..# 0)
	BEGIN
		# DUP
	0= UNTIL
;
HEADS

: SIGN	( ..# N N - ..# N )	0< IF 45 HOLD THEN ;

: (.)	 ( N - ..# N) DUP >R ABS <# #S R> SIGN ;
FORTH DEFINITIONS

: .	( N)	(.) #> SPACE ;

: ?	( A) @ . ;

: U.R	( U N) >R <# #S OVER R> SWAP - SPACES #> ;

: U.	( U) 0 U.R SPACE ;

: U?	( A) @ U. ;
HEX
RUNTIME DEFINITIONS

: abort"
	 R> TYPE
	 BLK @ MINT= NOT  CR
		IF
		NETWORKED @ MINT= IF
			10000 DELAY ( DELAY TO TRIP TIMEOUT )
		THEN
			."  ABORT AT LINE " BASE @ >R DECIMAL LINE# @ .
			R> BASE !
		THEN
	CR CNT @ 0 DO TIB I + C@ EMIT LOOP
	CR >IN @ HEREW C@ - 1- SPACES HEREW C@ 0 DO ." ^" LOOP CR
    STRTVEC @ EXECUTE
;
COMPILER DEFINITIONS

{
." HOST ABORT " CR 
OLD: ABORT"
	COMPILE {'}-  abort"	( compile abort" )
	22 STRING
OLD;
}
FORTH DEFINITIONS

: ,
	HERE ! BPW DP  +!
;

: C,
	HERE C! 1 DP  +!
;

: ALLOT	( N --	 MOVE DP N BYTES )
	HERE + DP !
;
." -DIGIT " CR
RUNTIME DEFINITIONS
HEADERLESS

: CRASH	CR HEREW TYPE DROP ABORT" ???" ;

: -DIGIT	 ( ASCII - N )
	DUP 39 >
		IF
			DUP 40 >
				IF 7 -
                ELSE CRASH
			THEN
		THEN
	30 -
	DUP BASE @ < OVER 0< NOT AND
		IF EXIT
		THEN
    CRASH
;
." 10*+ " CR

: 10*+	 ( U ASCII - U)
	-DIGIT				( CONVERT ASCII TO NUMBER )
	SWAP				( BRING SUM TO TOP )
	BASE @ * +			( * SUM BY BASE AND ADD NUMBER )
;
HEADS
." NUMBER " CR
FORTH DEFINITIONS

: NUMBER	( A- N )
	DUP 1+ C@						( A 1ST --> GET FIRST CHAR )
	DUP 2D =						( IS IT - )
		IF
			SWAP 0					( SIGN A SUM --> )
		ELSE
			>R 0 SWAP R> -DIGIT		( 0 A SUM --> )
		THEN
	SWAP DUP C@ 1- >R				( SGN SUM A --> REMAINING COUNT TO R )
	1+								( SGN SUM A --> ADDRESS OF NEXT CHAR )
		BEGIN
			I						( GET CNT FROM R )
		WHILE
			1+ SWAP OVER C@			( SGN A++ SUM ASCII --> )
			10*+ SWAP				( SGN SUM A -- )
			R> 1- >R				( SGN SUM A -- DEC CNT )
		REPEAT
	R> DROP							( DROP CNT )
	DROP SWAP						( SUM SGN --> TRASH A GET SIGN )
		IF							( SIGNED )
			0 SWAP -				( -SUM --> )
		THEN
;
RUNTIME DEFINITIONS

: FIND	( THREAD --- F | T CFA )
	20 WORD SWAP
	HEREW C@
		IF
			-FIND
		ELSE
			DROP FALSE
		THEN
;

: -'	 ( ---   SEARCH PATH FOR WORD )
	CONINDEX @							( INDEX -- )				 
	BEGIN
		DUP 0 >							( INDEX T/F -- )
	WHILE
		DUP 1- BPW * CONARRAY +			( IND POINT TO POINTER )
		HEREW SWAP -FIND
		IF
			SWAP DROP EXIT
		ELSE
			DROP
		THEN
		1-
	REPEAT
;
HEADS
FORTH DEFINITIONS

: '
	20 WORD C@
	IF -'
		DUP NOT	IF ABORT" ??? " 
		ELSE EXIT
		THEN
	ELSE
		FALSE	
	THEN
;
	
: FORTHONLY		( ONLY SEARCH FORTH VOCAB )
	1 CONINDEX !
	[ ' FORTH OFFSET - BPW + ] LITERAL CONARRAY !
;

: VDROP		( DROP TO OF VOCAB STACK )
	CONINDEX @
	?DUP IF
		1- CONINDEX !
	THEN
;
CR ." defining interpret" CR

: INTERPRET
	BEGIN
		20 WORD
		C@								( WAS A WORD PARSED )
	WHILE
		-'							(	search CONTEXT vocab )
		?DUP
			IF								( WORD FOUND IN CONTEXT )
				EXECUTE						( execute CONTEXT word )
			ELSE
				HEREW NUMBER
			THEN
	REPEAT
;

: SMUDGE
	LATEST @ DUP
	@ 40 XOR SWAP !
;

: COMPILE
	R> DUP @ , BPW+ >R
;
." ERROR1 " 
RUNTIME DEFINITIONS

: ERROR1 ABORT" NOT PAIRED " ;
FORTH DEFINITIONS

: ON TRUE SWAP ! ;

: OFF FALSE SWAP ! ;
." QUIT " 

: LOCGETLINE
	TIB 80 EXPECT BLK @ MINT= IF CR THEN
;

CODE GETLINE
	*GETLINE ^^ LDL GCALL
RTNXT ^^ LDL GCALL
END-CODE

: QUIT
	BEGIN
		GETLINE
		INTERPRET
		ECHO @ IF ." ok " CR THEN
	AGAIN
;
." ABORT .. "

: DEFINITIONS CONTEXT @ CURRENT ! ;
VERSION 1+ CONSTANT VERSION
SPINIT WS - CONSTANT WSLEN

: ABORT1
	BEGIN
		SP! RP! DAP! MP!
		MINT BLK ! 0 MODE ! 1 ECHO !
		0 >IN !
		0 CNT !
		0 >OUT !
		CR	." EM-Forth for the T4XX/T8XX ver " VERSION . CR
			." Copyright E.Matejowsky   Oct 1990 - 1992" CR
			." Ph. (Australia ) +61 7 282 5939" CR
                        ." Email matejowsky@qut.edu.au" CR
		QUIT
	AGAIN
;
VARIABLE *ABORT
' ABORT1 OFFSET - -BPW ALLOT  ,

: ABORT *ABORT @ EXECUTE ;
RUNTIME DEFINITIONS
VARIABLE *COLD
' FORTHONLY OFFSET - -BPW ALLOT  ,
VARIABLE *DIE
' FORTHONLY OFFSET - -BPW ALLOT  ,
VARIABLE *EMPTY
' FORTHONLY OFFSET - -BPW ALLOT  ,
HEADERLESS

: COLD2
		HEX SP! RP! DAP! MP!
		USER @ [ BPW 3 * ] LITERAL + @		 	( GET AUTOSTART ADDR )
		DUP MINT= 
		IF WARMFLG @ 					( IF COLD *EMPTY )
			IF
				ABORT
			ELSE
				*COLD @ EXECUTE	( DO MEMALOC )
				DROP *EMPTY @
			THEN
		THEN
		WARMFLG @ NOT
			IF
				TRUE WARMFLG !
			THEN
		EXECUTE DEFINITIONS		( setup default context + current )
		WARMFLG @ 2 =
			IF *DIE @ EXECUTE
		THEN
		ABORT
;
 HEADS
." COLD .. " CR
FORTH DEFINITIONS

CODE COLD
	RPINIT WS - BPW / LDLP RP ^^ STL ( set rp to empty stack )
FORTH	' COLD2 dA @ - BPW + ASSEMBLER LDC
	RP *STORE						( put COLD+4 address on R stack )
	SPINIT WS - BPW / LDLP SP ^^ STL		( INITIALIZE DATA STACK PTR )
	SP>A   STKLIM ^^ STL					( SET STACK LIMIT TO SPINIT )
	CP ^^ LDL  
FORTH ' [NEXT] ' [COLON] - ASSEMBLER ADC,	( use CP to calculate [NEXT] addr )
	GCALL									( jump to next )
END-CODE
HEADS
{
ASSEMBLER DEFINITIONS
}
RUNTIME DEFINITIONS
." STARTUP "

CODE STARTUP	 ( address of startup info in B )
	REV
	USER ^^ STL								( store addr here for now )
	USER ^^ LDL
	USER ^^ LDL								( get two copies of addr )
	2 LDNL								( get WS addr )
	GAJW								( initialize wptr )
	0 STL								( DROP PREVIOUS WS from A )
	USER ^^ STL							( save block addr here )
	USER *LOAD LINKINPTR ^^  STL		( save input link )
	USER ^^ LDL 1 LDNL LINKOUTPTR ^^  STL	( save output link )
FORTH ' COLD dA @ - ASSEMBLER LDC GCALL
END-CODE
." END "
( FINIS

CODE WARM	( NB :- NEW WS IS ALREADY ACTIVE BUT STARTUP SETS IT AGAIN )
	1 LDL 
	' STARTUP dA @ - LDC GCALL
END-CODE
FORTH DEFINITIONS

: ( 29 WORD DROP ;
." target compiler stuff " 
COMPILER DEFINITIONS
HERE COMPILERSTART !

: ELSE
	 1 =	IF						( check byte compare )
			 COMPILE \\'  [GOTO]	( COMPILE [GOTO] )
			 HERE 0 ,				( remember here,reserve space for addr )
			 SWAP HERE SWAP ! 1	( patch if jump )
			ELSE
			 ERROR1				( conditional not paired )
			THEN
;
."	( " 

: ( \\'	( ; SMUDGE

: THEN
	 1 = IF							( checkbyte )
			 HERE SWAP !			( patch if jump )
		 ELSE
			 ERROR1					( not paired )
		 THEN
;

: BEGIN
	HERE 2							( remember here save checkbyte )
;

: WHILE
	2 = IF
		COMPILE \\'  [IF]
		HERE 3 0 ,
	ELSE
		ERROR1
	THEN
;

: REPEAT
	3 = IF
		SWAP									( get begin addr )
		COMPILE \\'  [GOTO]							( compile goto )
		,										( point BEGIN here )
		HERE SWAP !							( patch while )
	ELSE
		ERROR1
	THEN
;

: DO
	COMPILE \\'  [DO]
	4
;

: LOOP
	4 = IF
			COMPILE \\'  [LOOP]
	ELSE
		ERROR1
	THEN
;

: UNTIL
	2 = IF
	 COMPILE \\'  [IF]
		,											( branch back if !0 )
	ELSE
		ERROR1
	THEN
;

: AGAIN
	2 = IF
	 COMPILE \\'  [GOTO]
	 ,											( branch back if !0 )
	ELSE
		ERROR1
	THEN
;

: IF
	 COMPILE \\'  [IF]					( compile addr of to [if] )
	HERE 0 , 1						( remember here,reserve space for addr )
;

: ;
 	COMPILE \\'  [NEXT] SMUDGE
 	R> DROP
	SP @ USER 14 + @ = NOT IF
		 ABORT" DEFINITION NOT FINISHED "
		THEN
 	0 MODE !						( BACK TO INTERP MODE )
; SMUDGE

: EXIT
	MODE @ 2 = IF
 		COMPILE \\'  [DNEXT]
	ELSE
 		COMPILE \\'  [NEXT]
	THEN
;

: LITERAL
COMPILE \\'  [LITERAL]
,
;

: [ 0 MODE !
  R> DROP ;

FORTH DEFINITIONS

: .S
    CR ." DATA STACK -- "
	STKLIM @ BPW-
	BEGIN
		SP @ BPW+ OVER <
	WHILE
		DUP @ U. BPW-
	REPEAT
	DROP ." (TOS) " CR
;
RUNTIME DEFINITIONS

: DPALIGN
	BEGIN							( move dp to word boundary )
		HERE 3 AND
	WHILE
		0 C,
	REPEAT
;
." STRING " 

: STRING WORD C@ 1+ ALLOT DPALIGN ;
DEBUG DEFINITIONS

: --> SPACE ." --> " ;

: D.S .S KEY 1B = IF QUIT THEN ;
FORTH DEFINITIONS
." DEFINING [ " CR

: ] SAVEMODE @ MODE !
	BEGIN
		BEGIN
			20 WORD
			C@
		WHILE
			HEREW [ ' COMPILER OFFSET - BPW+ ] LITERAL -FIND
				(	search compiler vocab )
			IF									( WORD FOUND IN COMPILER )
 				EXECUTE							( execute compiler word )
			ELSE
				DROP -'
				?DUP
					IF
					USER @ @ 80 AND
						IF	( IMMEDIATE )
							DUP USER ! EXECUTE
						ELSE ( COMPILE )
							,	MP!				( COMPILE AND CALL TO IT )
						THEN
					ELSE
				HEREW NUMBER \\' LITERAL MP!
				THEN
			THEN
		REPEAT
(	BLK @ 0< IF CR THEN
	GETLINE
	TRACE @
		IF				( INSERT TRACEING CODE )
			>IN @ >R
			COMPILE \\'  D.S COMPILE \\'  dot" 0 STRING COMPILE \\'  -->
			R> >IN !
		THEN
	AGAIN
;
." CREATE "

: {
		DP' @ DP @ DP' ! DP !
;

: } { ;

: CREATE
	H/C @ IF { THEN DPALIGN
	HERE BPW+ LATEST !				( SAVE ADDRESS OF CFA FOR SMUDGE )
	HERE CURRENT @ @ ,				( save thread in head link )
	CURRENT @ !						( Save head link address in thread )
	20 WORD DUP
	C@ 1+ ALLOT DPALIGN				( getword and pad to word boundary )
	HERE 1- C@ 80 OR HERE 1- C!		( set term bit )
	DROP
	H/C @ IF
 		LATEST @ @ 8000 OR LATEST @ !
		MODE @ IF
			-BPW ALLOT HERE @ DP' @ , } ,
		ELSE
			DP' @ , }
		THEN
	THEN
;

: :	CREATE COMPILE [ ASSEMBLER CP ^^ LDL   GCALL NOP NOP VDROP ] SMUDGE
	TRACE @
		IF							( INSERT TRACEING CODE )
			>IN @ >R
			0 >IN !  COMPILE \\'  D.S COMPILE \\'  dot" 0 STRING
			R> >IN !
		THEN
	SP @ USER 14 + !
	]
;

COMPILER DEFINITIONS FORTH
." .QUOTE " 

: ."
	COMPILE \\'  dot"	( compile call to dot" )
	22 STRING		( embed string )
;

: ABORT"
	COMPILE \\'  abort"	( compile call to dot" )
	22 STRING		( embed string )
;

: INLINE
R> DROP
COMPILE \\' [INLINE]
0 MODE !
ASSEMBLER
;

RUNTIME DEFINITIONS 

." ERROR " 

: ERROR
	SP! RP! DAP! MP!
    ERTYPE @
	CR
	DUP 1 = IF	ABORT" DATA STACK UNDERFLOW !!!" 	THEN
	DUP 2 = IF	ABORT" VOCAB STACK OVERFLOW !!! " 	THEN
	DUP 3 = IF	ABORT" MESSAGE STACK UNDERFLOW !!!" 	THEN
;
ALIAS [DOES>] [DOES>]
ALIAS [GOTO] [GOTO]
ALIAS [VAR] [VAR]
ALIAS [COLON] [COLON]
ALIAS [CODEOB] [CODEOB]
ALIAS [OBJ] [OBJ]
ALIAS [NEXT] [NEXT]
ALIAS [DNEXT] [DNEXT]
ALIAS [CON] [CON]
ALIAS [WS,VAR] [WS,VAR]
ALIAS [LITERAL] [LITERAL]
ALIAS [VOC] [VOC]
FORTH DEFINITIONS

ALIAS BPW  4		( BYTES PER WORD )
ALIAS BPW+  4+
ALIAS BPW-  4-
ALIAS -BPW  -4

ALIAS CMOVE CMOVE
ALIAS SP! SP!
ALIAS DAP! DAP!
ALIAS MP! MP!
ALIAS EXECUTE EXECUTE
ALIAS @ @
ALIAS C@ C@
ALIAS ! !
ALIAS C! C!
ALIAS +! +!
ALIAS + +
ALIAS 1- 1-
ALIAS 2- 2-
ALIAS 4- 4-
ALIAS 1+ 1+
ALIAS 2+ 2+
ALIAS 4+ 4+
ALIAS 2/ 2/
ALIAS 2* 2*
ALIAS AND AND
ALIAS OR OR
ALIAS XOR XOR
ALIAS - -
ALIAS / /
ALIAS U/ U/
ALIAS UMOD UMOD
ALIAS U/MOD U/MOD
ALIAS MOD MOD
ALIAS * *
ALIAS = =
ALIAS > >
ALIAS < <
ALIAS 0< 0<
ALIAS 0= 0=
ALIAS NOT NOT
ALIAS MINT= MINT=
ALIAS DUP DUP
ALIAS ?DUP ?DUP
ALIAS DROP DROP
ALIAS OVER OVER
ALIAS MACRO :
BUFFSIZE CONSTANT BUFFSIZE
80000020 CONSTANT EVENT
." FINISHED COMPILING NOW INITIALIZING CP ETC " CR
'	LOCALCR 	*CR 		dA @ +	A!
' 	LOCALKEY 	*KEY 		dA @ +	A!
( ' 	LOCALTYPE 	*TYPE 	dA @ +	A!
' 	LOCGETLINE 	*GETLINE 	dA @ +	A!

'	[COLON]		CP			dA @ +	!					( SETUP CP )
	RTNEXT @ 	RTNXT		dA @ +	A!					( SETUP RTNXT )
'	ERROR		ERRORVEC	dA @ +	A!
	HERE		DP			dA @ +	A!
'	ABORT		STRTVEC		dA @ +	A!
( '	FORTHONLY	*EMPTY		dA @ +	A!
( '	FORTHONLY	*COLD		dA @ +	A!
( '	FORTHONLY	*DIE		dA @ +	A!
'	STARTUP		STARTUPADDRESS		A!
	HERE WS - 	MAINLENGTH			A!
	FALSE 		WARMFLG 	dA @ +	!
	MINT	 	CAPFP	 	dA @ +	!
	MINT 		STDOUTFP	dA @ +	!
	MINT		REPLYPORT	dA @ +	!	( INITIALIZE PORT )
	FALSE 		NETWORKED 	dA @ +	!
{'} FORTH 		BPW+ @	' FORTH			BPW+ 	A!
{'} COMPILER	BPW+ @	' COMPILER 		BPW+ 	A!
{'} RUNTIME		BPW+ @	' RUNTIME		BPW+ 	A!
{'} DEBUG	BPW+ @	' DEBUG	BPW+ 	A!
1 SAVEMODE dA @ + !
( FPU  1 0 EXP )
3F800000 FONE dA @ + !  ( that's a floating point one )
 DECIMAL
PRUNE
RUNTIME 1 BLK ! ( 1 LINE# ! )	0 ECHO ! ( SOURCE )
FORTHONLY
FORTH DEFINITIONS
DEBUG
TRACE OFF

: ." 22 WORD TYPE DROP ;
( IT MAY BE BETTER TO FILL WORDS NOT BYTES )

: ERASE	( STRT LEN --- )
	OVER + SWAP	( END STRT -- )
		DO
			0 I C!
		LOOP
;

: HIDE ' DROP USER @ BPW - @ USER BPW + @ ! ;

RUNTIME DEFINITIONS
." ASSEMBLER STUFF " CR

: REMSMUDGE SMUDGE LATEST @ ;
." UNSMUDGE " .S

: UNSMUDGE	( UNSMUDGE CFA ADDRESS ON STACK UNTIL 0 FOUND )
	BEGIN
		DUP
	WHILE
		LATEST ! SMUDGE
	REPEAT
	DROP
;
FORTH DEFINITIONS
: ALIAS CREATE ' , LATEST @ @ 8000 OR LATEST @ ! ;

COMPILER DEFINITIONS
  ALIAS END-MACRO ;
VDROP
FORTH DEFINITIONS

: CODE
	CREATE
	ASSEMBLER
SP @ USER 14 + !
;

ASSEMBLER DEFINITIONS

MACRO ^^ WS - BPW / END-MACRO

: CONER ABORT" conditionals not paired " ;

: LIMER ABORT" BRANCH TO FAR " ;

: FWER ABORT" FORWARD REFERENCE " ;

: ?PREF	( WORD --> 4 BIT .. generate prefixes or nfixes if required )
	DUP -10 AND
	IF								( we need prefixes )
		DUP 0<
		IF							( we need a nfix )
			DUP F OR -1 =
			IF						( small neg number need nfix 0 only )
				60 C, F AND EXIT
			ELSE					( large neg number )
				>R					( --- save number on return stack )
				-1					( CNT --- set prefix count to -1 )
				BEGIN
					R> DUP F AND	( CNT NUM 4BIT --- get num, copy , extract 4 bits )
					SWAP 10 U/
					F0000000 OR	>R	( CNT 4BIT --- bring num to top shift and >r )
					SWAP 1+			( 4BIT CNT++ --- inc counter )
					I -1	=		
				UNTIL
				R> DROP				( drop -1 from r )
				SWAP F XOR 60 OR C,	( create nfix instruction )
				1-					( dec counter )
			THEN
		ELSE						( we only need prefixes )
				>R					( save number on return stack )
				-1					( set prefix count to -1 )
				BEGIN
					R> DUP F AND	( get num, copy , extract 4 bits )
					SWAP 10 U/ >R	( bring num to top shift and >r )
					SWAP 1+			( inc counter )
					I	NOT			( keep going till all bits zero )
				UNTIL
				R> DROP
		THEN
			BEGIN
				DUP
			WHILE					( while count nonzero )
				1- SWAP				( dec count, bring next nibble to top )
				20 OR C,			( generate prefix )
			REPEAT
			DROP
	THEN
;

: PREADJUST		( OFS --> ADJOFFS , ADJUST OFFSET TO WITH INST LEN )
	ABS 10 		( OFS PWR --> )
	BEGIN
		SWAP 1+ SWAP		( INC OFS )
		10 * OVER OVER /	( ADJ PWR --> )
	NOT UNTIL
	DROP NEGATE 
;

: CALCBACK	( ABSWORD --> 4 BIT .. generate prefixes or nfixes if required )
	HERE 1+ - DUP -10 AND
	IF								( we need prefixes )
		DUP 0< NOT IF FWER THEN
			PREADJUST
			DUP F OR -1 =
			IF						( small neg number need nfix 0 only )
				60 C, F AND EXIT
			ELSE					( large neg number )
				>R					( --- save number on return stack )
				-1					( CNT --- set prefix count to -1 )
				BEGIN
					R> DUP F AND	( CNT NUM 4BIT --- get num, copy , extract 4 bits )
					SWAP 10 U/
					F0000000 OR	>R	( CNT 4BIT --- bring num to top shift and >r )
					SWAP 1+			( 4BIT CNT++ --- inc counter )
					I -1	=		
				UNTIL
				R> DROP				( drop -1 from r )
				SWAP F XOR 60 OR C,	( create nfix instruction )
				1-					( dec counter )
			THEN
			BEGIN
				DUP
			WHILE					( while count nonzero )
				1- SWAP				( dec count, bring next nibble to top )
				20 OR C,			( generate prefix )
			REPEAT
			DROP
	THEN
;

: TYPEONE	( operand , operation code --> )
	SWAP ?PREF OR C,
;

: END-CODE
	DPALIGN
	SP @ USER 14 + @ = NOT IF ABORT" DEFINITION NOT FINISHED " THEN
	ASSEMBLER VDROP FPUASM VDROP
;

( instruction such as ldc , prefixes are generated with l.s. nibble embedded )
( in the instruction )
0	( MARKER FOR UNSMUDGE )

: J	 00 TYPEONE ;				( jump relative )

: LDLP	10 TYPEONE ;			( load local pointer )

: LDNL	30 TYPEONE ;			( load non-local )

: LDNLP 50 TYPEONE ;			( load non-local pointer )

: LDL	70 TYPEONE ;			( load local )

: ADC,	80 TYPEONE ;			( add constant )

: CALL	90 TYPEONE ;			( call )

: CJ	A0 TYPEONE ;			( conditional jump )

: AJW	B0 TYPEONE ;			( adjust workspace )

: EQC	C0 TYPEONE ;			( equals constant )

: STL	D0 TYPEONE ;			( store local )

: STNL	E0 TYPEONE ;			( store non-local )

: OPR	F0 TYPEONE ;			( store non-local )
( two byte op-codes )

: AND 46 OPR ; REMSMUDGE

: OR	4B OPR ; REMSMUDGE

: XOR 33 OPR ;

: COMP 32 OPR ;	( I've changed NOT to COMP )

: SHL 41 OPR ;

: SHR 40 OPR ;

: MUL 53 OPR ;

: FMUL 72 OPR ;

: DIV 2C OPR ;

: REM 1F OPR ;		( REMAINDER )

: SUM 52 OPR ;

: LADD 16 OPR ;	( LONG ADD )

: LSUB 38 OPR ;

: LSUM 37 OPR ;

: LDIFF 4F OPR ;

: LMUL 31 OPR ;

: LDIV 1A OPR ;

: LSHL 36 OPR ;

: LSHR 35 OPR ;

: NORM 19 OPR ;

: CFLERR 73 OPR ;

: UNPACKSN 63 OPR ;

: ROUNDSN 6D OPR ;

: POSTNORMSN 6C OPR ;

: LDINF 71 OPR ;

: XWORD 3A OPR ;

: CWORD 56 OPR ;

: XDBLE 1D OPR ;

: CSNGL 4C OPR ;

: MINT 42 OPR ;

: DUP, 5A OPR ;

: MOVE2DINIT 5B OPR ;

: MOVE2DALL 5C OPR ;

: MOVE2DNONZERO 5D OPR ;

: MOVE2DZERO 5E OPR ;

: CRCWORD 74 OPR ;

: CRCBYTE 75 OPR ;

: BITCNT 76 OPR ;

: BITREVWORD 77 OPR ;

: BITREVNBITS 78 OPR ;

: BCNT 34 OPR ;

: WCNT 3F OPR ;

: SB 3B OPR ;

: MOVE 4A OPR ;

: LDTIMER 22 OPR ;

: TIN 2B	OPR ;

: TALT 4E OPR ;

: TALTWT 51 OPR ;

: ENBT 47 OPR ;

: DIST 2E OPR ;

: ALT 43 OPR ;

: ALTWT 44 OPR ;

: ALTEND 45 OPR ;

: ENBS 49 OPR ;

: DISS 30 OPR ;

: RESETCH 12 OPR ;

: ENBC 48 OPR ;

: DISC 2F OPR ;

: RET 20 OPR ;

: LDPI 1B OPR ;

: GAJW 3C OPR ;

: LEND 21 OPR ;

: RUNP 39 OPR ;

: STOPP 15 OPR ;

: LDPRI 1E OPR ;

: CSUB0 13 OPR ;

: CCNT1 4D OPR ;

: TESTERR 29 OPR ;

: SETERR 10 OPR ;

: STOPERR 55 OPR ;

: CLRHALTERR 57 OPR ;

: SETHALTERR 58 OPR ;

: TESTHALTERR 59 OPR ;

: TESTPRANAL 2A OPR ;

: SAVEH 3E OPR ;

: SAVEL 3D OPR ;

: STHF 18 OPR ;

: STHB 50 OPR ;

: STLF 1C OPR ;

: STLB 17 OPR ;

: STTIMER 54 OPR ;
( TYPE3 INSTRUCTIONS 1 BYTE )

: NOP 80 C, ;

: ADD, F5 C, ;

: SUB FC C, ;

: GT F9 C, ;

: DIFF F4 C, ;

: PROD F8 C, ;

: REV F0 C, ;

: BSUB F2 C, ;

: WSUB FA C, ;

: LB F1 C, ;

: IN F7 C, ;

: OUT FB C, ;

: OUTWORD FF C, ;

: OUTBYTE FE C, ;

: GCALL F6 C, ;

: STARTP FD C, ;

: ENDP F3 C, ;

: LDC	DUP
	FF000000 AND MINT= IF	( SHOULD WE DO MINT ADC, INSTEAD OF LDC )
		MINT 80000000 - ADC,
	ELSE
		40 TYPEONE
	THEN
;			( load constant )
( T425 + T805 INST )
: BREAK B1 OPR ;
: CIRJ0BREAK B2 OPR ;
: SETJ0BREAK B3 OPR ;
: TIMERDISABLEH 7A OPR ;
: TIMERDISABLEL 7B OPR ;
: TIMERENABLEH 7C OPR ;
: TIMERENABLEL 7D OPR ;
: POP, 79 OPR ;
: LDDEVID 17C OPR ;
: LDMEMSTARTVAL 7E OPR ;

( Assembler control structures )
( unlike most other processors the transputer is not meant to keep data )
( in it registers, you use the workspace that purpose. If you use this )
( aproach it get around two problems concerning the following structures )
( One is that the J instruction is a descheduling point where a context swap )
( may take place; usually destroying the registers contents. )
( Two is that the CJ instruction drop the areg if no branch occures but )
( leaves it intact if the branch was taken. In short don't try and leave )
( stuff on stack during control branches. Most of the following code words )
( don't use any control structures so they can keep there return address )
( on stack. If any code word uses control structures it must store it's )
( return address in memory, usually in ASAVE, DATAPTR  or the forth R-stack )

: CALLSUB
	CALCBACK 90 OR C,
;

: JMPBACK CALCBACK C, ;
( : GOTOWORD ' JMPBACK ;

: IF
	HERE 1					( remember here use 1 for pair test )
	80 C, 80 C,				( 0 ADC, as nop )
; REMSMUDGE

: ELSE	( ADDR 1 -- ADDR 2 )
	1 =
	IF
		HERE >R				( address of else patch to R )
		80 C, 80 C,			( stuff in 2 nops )
		DUP					(	copy if addr )
		HERE SWAP - 2- DUP	( calc length of jump )
			DUP FF > IF
				LIMER			( to far , get upset )
			ELSE
				10 < IF			( small jump leave first nop )
					SWAP 1+		( if addr to top inc it )
				ELSE
					SWAP
				THEN
				HERE >R		( remember here so we can move dp )
				DP !		( move dp back to if addr )
				CJ			( assm jc inst there )
				R> DP !		( restore dp to normal position )
			THEN
		R> 2				( get else addr and use 2 as check byte )
	ELSE
		CONER
	THEN
; REMSMUDGE

: THEN									( ADDR 1|2 -- )
	DUP USER [ BPW 2 * ] LITERAL + !						( ADDR 1|2 -- )
	DUP 1 = SWAP 2 = OR					( ADDR T/F -- )
	IF
		DUP								( ADDR ADDR --	copy if addr )
		HERE SWAP - 2-					( ADDR OFFS -- calc length of jump )
			DUP							( ADDR OFFS OFFS -- )
			DUP FF >					( ADDR OFFS OFFS T/F -- )
				IF
					LIMER				( to far , get upset )
				ELSE
					10 <				( ADDR OFFS T/F -- )
						IF				( small jump leave first nop )
							SWAP 1+		( OFFS ADDR++ -- if addr to top inc it)
						ELSE
							SWAP		( OFFS ADDR -- )
						THEN
					HERE >R		( OFFS ADDR -- remember here for dp restore )
					DP !				( OFFS -- move dp back to if addr )
					USER [ BPW 2 * ] LITERAL + @ 1 =		( OFFS -- is if IF or ELSE )
						IF
								CJ			( -- or cj for "if" )
						ELSE
								J			( -- assm j for "else")
						THEN
					R> DP !		( -- restore dp to normal position )
				THEN
	ELSE
				CONER
	THEN
; REMSMUDGE

: BEGIN
	HERE 0					( remember here for branch while , again or until )
; REMSMUDGE

: UNTIL						( ADDR 0 -- until areg = 0 )
	NOT IF
		HERE - 2-			( jump offset )
		DUP -100 <
		IF
			LIMER			( error )
		ELSE
			CJ				( assemble jump )
		THEN
	ELSE
		CONER
	THEN
; REMSMUDGE

: WHILE	( BEGIN 0 -- BEGIN WHILE 3 )
	NOT IF
			HERE 3
			80 C, 80 C,			( 2 NOPS )
	ELSE
		CONER
	THEN
; REMSMUDGE

: REPEAT	( B W 3 -- )
	3 = IF
		SWAP HERE - 2-			( W OFFS -- BEGIN jump offset )
		DUP -100 <				( W OFFS F --
			IF
				LIMER			( error )
			ELSE
				J				( W -- assemble jump )
				DUP HERE SWAP - 2-	( WHILE WOFFS -- OFFSET FROM WHILE TO HERE )
				DUP FF >
					IF 
						LIMER
					ELSE			( W O -- )
						DUP 10 <
							IF SWAP 1+		( W O -- SINGLE BYTE JUMP MOVE W)
							ELSE SWAP
							THEN
						HERE >R DP !		( O -- DP TO W )
						CJ					( -- FORWARD CJ )
						R> DP !
					THEN
			THEN
	ELSE
		CONER
	THEN
; REMSMUDGE

: AGAIN
	NOT IF					( there should be a zero in top )
		HERE - 2-			( calculate jump offset to here+2 )
			DUP -100 <		( is it to great )
			IF
				LIMER		( error abort )
			ELSE
				J			( assemble jump )
			THEN
	ELSE
		CONER				( conditions don't match give error )
	THEN
; REMSMUDGE

: NOT						( Logical not , not a bitwise not )
	0 EQC
;

: 0=
	NOT
;
 UNSMUDGE
HIDE CONER
HIDE ?PREF
HIDE PREADJUST
HIDE TYPEONE
HIDE CALCBACK
( ASSEMBLER MACROS )
( INC WORKSPACE LOC BY BPW )

MACRO ++W
^^ DUP LDL BPW ADC, STL
END-MACRO
( DEC WORKSPACE LOC BY BPW )

MACRO --W
^^ DUP LDL -BPW ADC, STL
END-MACRO
( INC WORKSPACE LOC BY 1 )

MACRO ++B
^^ DUP LDL 1 ADC, STL
END-MACRO
( DEC WORKSPACE LOC BY 1 )

MACRO --B
^^ DUP LDL -1 ADC, STL
END-MACRO

MACRO ;CODE		( CALL NEXT AND END CODE )
	RTNXT  ^^ LDL   GCALL
	END-CODE
END-MACRO

MACRO SP>A
	SP ^^ LDL
END-MACRO

MACRO TOP>A
	SP ^^ LDL 0 LDNL
END-MACRO

MACRO NEXT>A
	SP ^^ LDL 1 LDNL
END-MACRO

MACRO A>TOP
	SP ^^ LDL 0 STNL
END-MACRO

MACRO A>NEXT
	SP ^^ LDL 1 STNL
END-MACRO

MACRO SP2DROP
	SP ^^ LDL  BPW 2 * ADC, SP ^^ STL
END-MACRO

MACRO PUSH
	DUP
	--W ^^ LDL 0 STNL
END-MACRO

MACRO POP
 DUP
  ^^ LDL 0 LDNL
  ++W
END-MACRO

MACRO *LOAD
	^^ LDL 0 LDNL
END-MACRO

MACRO *STORE
	^^ LDL 0 STNL
END-MACRO

MACRO FIELDADDR	( OFFS -- )
	DAP *LOAD ADC,
END-MACRO

MACRO FIELDLOAD	( OFFS -- )
	DAP *LOAD 4 / LDNL
END-MACRO

MACRO FIELDSAVE	( OFFS -- )
	DAP *LOAD 4 / STNL
END-MACRO

: OUTLINE
	[ ' [OUTLINE] ] LITERAL	LDC GCALL
	DPALIGN
	ASSEMBLER VDROP FPUASM VDROP
	]
;
FPUASM DEFINITIONS

: FPCHKERROR		83 OPR ;

: FPSTNLDB		84 OPR ;

: FPLDNLSNI		86 OPR ;

: FPADD			87 OPR ;

: FPSTNLSN		88 OPR ;

: FPSUB			89 OPR ;

: FPLDNLDB		8A OPR ;

: FPMUL			8B OPR ;

: FPDIV			8C OPR ;

: FPLDNLSN		8E OPR ;

: FPREMFIRST 	8F OPR ;

: FPREMSTEP		90 OPR ;

: FPNAN			91 OPR ;

: FPORDERED		92 OPR ;

: FPNOTFINITE 	93 OPR ;

: FPGT			94 OPR ;

: FPEQ			95 OPR ;

: FPI32TOR32 	96 OPR ;

: FPI32TOR64 	98 OPR ;

: FPB32TOR64 	9A OPR ;

: FPTESTERROR	9C OPR ;

: FPRTOI32		9D OPR ;

: FPSTNLI32		9E OPR ;

: FPLDZEROSN 	9F OPR ;

: FPLDZERODB 	A0 OPR ;

: FPINT			A1 OPR ;

: FPDUP			A3 OPR ;

: FPREV			A4 OPR ;

: FPLDNLADDDB 	A6 OPR ;

: FPLDNLMULDB	A8 OPR ;

: FPLDNLADDSN	AA OPR ;

: FPENTRY		AB OPR ;

: FPLDNLMULSN	AC OPR ;

: FPUSQRTFIRST	1 LDC FPENTRY ;

: FPUSQRTSTEP	2 LDC FPENTRY ;

: FPUSQRTLAST 	3 LDC FPENTRY ;

: FPURP			4 LDC FPENTRY ;

: FPURM			5 LDC FPENTRY ;

: FPURZ			6 LDC FPENTRY ;

: FPUR32TOR64	7 LDC FPENTRY ;

: FPUR64TOR32	8 LDC FPENTRY ;

: FPUEXPDEC32	9 LDC FPENTRY ;

: FPUEXPINC32	A LDC FPENTRY ;

: FPUABS		B LDC FPENTRY ;

: FPUNOROUND	D LDC FPENTRY ;

: FPUCHKI32		E LDC FPENTRY ;

: FPUCHKI64		F LDC FPENTRY ;

: FPUDIVBY2		11 LDC FPENTRY ;

: FPUMULBY2		12 LDC FPENTRY ;

: FPURN			22 LDC FPENTRY ;

: FPUSETERROR		23 LDC FPENTRY ;

: FPUCLEARERROR		9C LDC FPENTRY ;

: TOP>FPA 	SP ^^ LDL FPLDNLSN ;

: FPA>TOP	SP ^^ LDL FPSTNLSN ;

: POPFPA TOP>FPA SP ++W ;

: PUSHFPA SP --W FPA>TOP ;


FORTH DEFINITIONS
( the assembler constants aren't defined yet so we calculate CP word offset )

: VARIABLE
	CREATE COMPILE [ ASSEMBLER
	CP ^^ LDL
	FORTH ' [VAR] ' [COLON] -	ASSEMBLER ADC, GCALL VDROP ]
	MINT ,
;

: WS,VAR					( FUDGE OFFSET FOR ADDRESS CONSTANTS )
	CREATE
	COMPILE
[ ASSEMBLER
	CP ^^ LDL  
	FORTH ' [WS,VAR] ' [COLON] -		( CALCULATE OFFSET )
	ASSEMBLER ADC, GCALL
	VDROP ]
	WS - ,
;

: CONSTANT
	CREATE
	COMPILE
[ ASSEMBLER
	CP ^^ LDL  
	FORTH ' [CON] ' [COLON] -		( CALCULATE OFFSET )
	ASSEMBLER ADC, GCALL
	VDROP ]
 ,
;
RUNTIME FORTH DEFINITIONS

: CODESUB
	VARIABLE -BPW ALLOT
	SP @ USER 14 + !
	ASSEMBLER
;

." <BUILDS "

: <BUILDS
	CREATE COMPILE [
	FORTH ' [DOES>] ' [COLON] - ASSEMBLER
	CP ^^ LDL   ADC, GCALL VDROP ]
	HERE  MARKER ! 
	0 ,			( RESERVE SPACE FOR DOES> ADDR )
;

: DOES> R> MARKER @  ! 
	MODE @ 2 = IF
		." DOES> " BPW DAP +!
	THEN ;
." REMEMBER " CR

: REMEMBER
	<BUILDS
	VOCLINK DUP @ ,			( STORE VOCLINK )
	BEGIN
		DUP MINT= NOT
	WHILE
		@					( TRACE LINK )
		DUP BPW- @ ,			( GET VOC VARIABLE TO HERE )
	REPEAT
	DROP
	DOES>				( DPSAVEADDR -- TOP HAS ADDRESS OF SAVE AREA )
	DUP @ VOCLINK !		( VLINKSAVEADDR -- )
	DUP						( VLS VLS -- )
	BEGIN
		@ SWAP BPW+ SWAP		( *VDATA VLADR -- )
		OVER @ OVER BPW-		( *VDATA VLADR VSDAT VDADR -- )
		!					( *VDATA VLADR -- )
		DUP @ MINT=			( *VDATA VLADR F -- LOOP TILL LINK = MINT )
	UNTIL					( *VDATA VLADR -- )
	DROP
	BPW+ DP !					( DP POINT TO THE NEXT WORD AFTER MINT )
	FORTHONLY
	FORTH DEFINITIONS
;
FORTH DEFINITIONS

: VOCABULARY
HERE
CREATE
COMPILE
[ '  [VOC] ' [COLON]  - ASSEMBLER 
CP ^^ LDL   ADC, GCALL VDROP ]
HERE MARKER !		( SAVE HERE SO WE CAN UNLINK VOC )
CONTEXT @ @ ,			( LINK TO CONTEXT DICT )
HERE VOCLINK @ ,		( LINK TO PREVIOUS VOCAB )
VOCLINK !				( POINT VOCLINK HERE )
BPW+ ,
;

: UNLINKVOCAB
	MINT MARKER @ !
;
VOCABULARY FLOAT UNLINKVOCAB
FLOAT DEFINITIONS
( FLOAT MACROS )
ASSEMBLER FLOAT

CODE ITOF
FPUASM
	SP ^^ LDL
	FPI32TOR32
	FPA>TOP
;CODE

CODE FTOI
FPUASM
	TOP>FPA
	FPINT
	SP ^^ LDL
	FPSTNLI32
;CODE
DECIMAL

CODE X^I	( I FPX --> X^I   take REAL X TO INT I TH POWER )
FPUASM
	SP POP USER ^^ STL				( X to USER )
	TOP>A
	22 LDC SHL
	USER ^^ 2+ STL					( I shifted to USER+1 )
	10 LDC USER ^^ 3 + STL			( loop counter to USER+2 )
	1 LDC USER ^^ 4+ STL			( store int 1 to convert to real )
	USER ^^ 4+ LDLP 		 		( get 1 to FPU )
	FPI32TOR32						( make it real32 )
	BEGIN
		FPDUP FPMUL					( sqr FPA )
		USER ^^ 2+ LDL
		MINT AND 
			IF						( if hi bit set )
				USER ^^ LDLP		( address of x )
				FPLDNLSN			( get x )
				FPMUL				( mult )
			THEN
		USER ^^ 2+ LDL
  		1 LDC SHL
		USER ^^ 2+ STL
		USER ^^ 3 + LDL -1 ADC, USER ^^ 3 + STL
		USER ^^ 3 + LDL
	NOT UNTIL
	SP ^^ LDL
	FPSTNLSN		
;CODE

CODE F-
FPUASM
	POPFPA	TOP>FPA
	FPSUB	FPA>TOP
;CODE

CODE F+
FPUASM
	POPFPA	TOP>FPA
	FPADD	FPA>TOP
;CODE

CODE F*
FPUASM
	POPFPA	TOP>FPA
	FPMUL	FPA>TOP
;CODE

CODE F/
FPUASM
	POPFPA	TOP>FPA
	FPREV	FPDIV
	FPA>TOP
;CODE

CODE F=
FPUASM
	POPFPA	TOP>FPA
	FPEQ	A>TOP
;CODE

CODE F<
FPUASM
	POPFPA	TOP>FPA
	FPGT A>TOP
;CODE

CODE F>
FPUASM
	POPFPA	TOP>FPA
	FPREV FPGT A>TOP
;CODE

CODE F0<
FPUASM
	FPLDZEROSN TOP>FPA
	FPGT A>TOP
;CODE

CODE F0=
FPUASM
	FPLDZEROSN TOP>FPA
	FPEQ A>TOP
;CODE

CODE FABS
FPUASM
	TOP>FPA
	FPUABS
	FPA>TOP
;CODE

: ^I ( I NBASE --> )
	ITOF OVER ABS SWAP ( I I NBASE -> )
	X^I
	SWAP 0< IF
		[ HEX ] 
(		FONE @
		3F800000	( THAT'S AN FP ONE )
		SWAP F/
	THEN
;

DECIMAL

: F10^I	( I --> 10^I 	TAKE TEN TO I'TH POWER )
  10 ^I
;
HEX

: FBASE^I	( I --> FBASE^I 	TAKE BASE TO I'TH POWER )
	BASE @ ^I
;

: FX	( I FX --> FP 		take int at next and exp at top to make a real32 )
	SWAP ITOF 	SWAP		( FX FP --> )
    F10^I F*
;
DECIMAL
HERE 				( REMEMBER START OF TABLE )
( SIGN ADJUST LOC 0-1 ) 	-1 0 FX , 1 0 FX ,
( TRANSLATION LOC 2-3 ) 	-90 0 FX , -270 0 FX ,
( FP 360 LOC 4 )			360 0 FX ,
( FP180 LOC 5 )				180 0 FX ,
( FP PI/180 LOC 6 )			17453292 -9 FX ,
( COEFS LOC 7-A )
-16666656 -8  FX ,
 83330251 -10 FX ,
-19807418 -11 FX ,
 26019030 -13 FX ,
HEX

CODESUB [COS]
FPUASM
	USER ^^ 4+ LDLP				( ORIGINAL ANGLE SAVED HERE )
		FPLDNLSN		
    HERE - BPW- LDC			( HOW FAR BACK TO TABLE ? )
	LDPI
	USER ^^ 5 + STL				( BASE ADDRESS OF DATA TABLE )
		( GET IT TO FPA )
		FPUABS					( MAKE ABSOLUTE )
	USER ^^ 5 + LDL				( TABLE BASE ADDR )
	4 4 * ADC,						( ADDR OF FP360 )
		FPLDNLSN				( GET IT TO FPA )
		FPREMFIRST				( REMAINDER FIRST STEP )
		0= IF
			BEGIN
				FPREMSTEP	
			0= UNTIL
		THEN					( IS REM NEG? , INMOS ARE TURKEYS !! )
			FPDUP
			FPLDZEROSN
			FPREV
			FPGT
			IF 
				USER ^^ 5 + LDL		( TABLE BASE ADDR )
				4 4 * ADC,			( ADDR OF FP360 )
				FPLDNLADDSN
			THEN
			FPDUP
		USER ^^ 5 + LDL 
		5 4 * ADC,					( GET FP180 )
			FPLDNLSN
			FPDIV
		USER ^^ 6 + LDLP 
		FPSTNLI32					( SAVE SEMI-CIRCLE )
		USER ^^ 6 + LDL
		4 LDC PROD
		USER ^^ 6 + STL
		USER ^^ 5 + LDL				( BASE ADRR )
		2 4 * ADC,					( ADJUST TO TRANSLATION )
		USER ^^ 6 + LDL SUM			( INDEX 0 OR 4 )
		FPLDNLADDSN					( ADJUST TO +-90 DEG )
		USER ^^ 5 + LDL
		6 4 * ADC,					( ADDR OF PI/180 CONST )
		FPLDNLMULSN					( CONVERT DEG TO RADIANS )
		USER ^^ 4+ LDLP				( X --> CALC SAVE ADDR )
			FPDUP					( X X --> )
			FPSTNLSN				( X --> )
			FPDUP					( X X --> )
			FPMUL					( G --> SQUARE ANGLE )
		USER ^^ 7 + LDLP			( G --> CALC SAVE ADDR )
			FPDUP					( G G --> )
			FPSTNLSN				( G --> )
			FPDUP					( G G --> )
		USER ^^ 5 + LDL
		A 4 * ADC,					( G G --> ADDR OF R4 )
			FPLDNLMULSN				( G G*R4 --> )
		USER ^^ 5 + LDL
		9 4 * ADC,					( G G*R4 --> ADDR OF R3 )
			FPLDNLADDSN				( G G*R4+R3 --> )
			FPMUL					( {R4*G+R3}*G --> )
		USER ^^ 5 + LDL
		8 4 * ADC,					( {R4*G+R3}*G --> ADDR OF R2 )
			FPLDNLADDSN				( {R4*G+R3}*G+R2 --> )
		USER ^^ 7 + LDLP
			FPLDNLMULSN				( {{R4*G+R3}*G+R2}*G --> )
		USER ^^ 5 + LDL
		7 4 * ADC,					( {{R4*G+R3}*G+R2}*G --> ADDR OF R1 )
			FPLDNLADDSN				( {{R4*G+R3}*G+R2}*G+R1 --> )			
		USER ^^ 7 + LDLP
			FPLDNLMULSN				( {{{R4*G+R3}*G+R2}*G+R1}*G --> )
		USER ^^ 4 + LDLP
			FPLDNLMULSN				( X*R ) 
		USER ^^ 4 + LDLP
			FPLDNLADDSN				( X+X*R )
		USER ^^ 5 + LDL				( ADRESS OF SIGN ADJUST )
		USER ^^ 6 + LDL SUM			( INDEX 0 OR 4 )
		FPLDNLMULSN					( ADJUST TO +-90 DEG )
		USER ^^ 4 + LDLP
			FPSTNLSN
	RET
0
END-CODE
DROP

CODE FCOS			( XRAD --> COSINE )
FPUASM				( T800 STK			FPU STK
	TOP>A				( --				X 		get X 	)
	USER ^^ STL
	[COS] CALLSUB
	USER ^^ LDL
	A>TOP
;CODE

RUNTIME
HERE 				( REMEMBER ADDR OF 90.0 CONSTANT )
DECIMAL
-90 0 FX ,

CODE FSIN			( XRAD --> COSINE )
FPUASM				( T800 STK			FPU STK
( TOP>A				( --				X 		get X 	)
	SP ^^ LDL		( ADDR OF TOP )
		FPLDNLSN
	HERE - BPW- LDC LDPI
		FPLDNLADDSN
	USER ^^ LDLP
		FPSTNLSN
	[COS] CALLSUB
	USER ^^ LDL
	A>TOP
0
;CODE
DROP

: FTAN
	DUP
	FSIN
	SWAP FCOS F/
;

HEX

: FABS1< 		( FP --> IS IT A FRACTION )
	FABS
	[ 1 0 FX ] LITERAL
	F<
;

: F#.#>	( ..# N --> )
DUP USER @ - USER !
	 -1 DO			( N -1 DO )
		I USER @ = IF 2E EMIT THEN
 EMIT LOOP
;

: F.ETC	( DP N --> PRINT N WITH DECIMAL POINT AT DP )
		USER !			( DECIMAL PLACE TO USER )
		(.) DROP F#.#> SPACE ;

: F.	( FP32 -->		print 32 bits float )
	DUP F0= IF ." 000.000 E 0 " DROP EXIT THEN
	DUP FABS1<
	IF						( FP32 --> it's a fraction )
		0 
		BEGIN
			3 - OVER FABS OVER 	( FP32 FX FP32 FX --> )
			 FBASE^I F>
		UNTIL
		3 +
	ELSE					( FP32 --> it abs32 >= 1 )
		0 					( FP32 FX --> lets see how big it is )
		BEGIN
			3 + OVER FABS OVER 	( FP32 FX FP32 FX --> )
			FBASE^I F<
		UNTIL
	THEN
	6 - DUP >R 
	FBASE^I
	F/ FTOI 3 F.ETC
	." E " R> 3 + .
;
( DECIMAL314159265 -8 FX )
HEX 40490FDA CONSTANT FPI
DECIMAL
: FDEGTORAD	( FPDEG --> FPRAD )
	[ 180 0 FX ] LITERAL F/
	FPI F*
;

: FRADTODEG	( FPRAD --> FPDEG )
	[ 180 0 FX ] LITERAL F/
	FPI F*
;

CODE SQRT
FPUASM
	TOP>FPA
	FPUSQRTFIRST
	FPUSQRTSTEP
	FPUSQRTSTEP
	FPUSQRTLAST
	FPA>TOP
	RTNXT ^^ LDL
	GCALL
END-CODE
HEX
FLOAT VDROP
FORTH DEFINITIONS

CODE TIMERIN
	SP POP
	TIN
;CODE

CODE PUTWORD	( WORDDATA CHAN -- )
	TOP>A NEXT>A		( get chan to B and data to A )
	OUTWORD							( get num and addr and store it )
	SP2DROP				( move sp back 2 words )
;CODE

CODE PUTBYTES	( SIZE &DATA CHAN -- )
	NEXT>A TOP>A		( get chan to B and data to C )
	SP ^^ LDL
	2 BPW * ADC, 0 LDNL
	OUT				( get num and addr and store it )
	SP ^^ LDL
	3 BPW * ADC, SP ^^ STL
RTNXT ^^ LDL GCALL
;CODE

CODE PUT16
	SP ^^ LDL	( ADDR OF DATA TO C )
	BPW ADC,
	TOP>A		( CHAN TO B )
	2 LDC 		( SIZE TO A )
	OUT
	SP2DROP
RTNXT ^^ LDL GCALL
END-CODE

CODE GETBYTES	 ( LINK DST CNT -- )
	TOP>A
	IF
		NEXT>A	( DST > C )
		SP ^^ LDL   2 LDNL	( SRC > B )
		TOP>A	( CNT > A )
		IN
	THEN
	SP ^^ LDL   BPW 3 * ADC, SP ^^ STL
RTNXT ^^ LDL GCALL
END-CODE

CODE GETWORD	( CHAN -- WORDDATA )
	SP>A  								( get address of top will become C )
	TOP>A						( get address of link to B )
	BPW LDC IN							( make cnt 1, get char)
;CODE

CODE GETBYTE	( CHAN -- BYTEDATA )
	SP>A  								( get address of top will become C )
	TOP>A						( get address of link to B )
	1 LDC IN								( make cnt 1, get char)
	TOP>A
	FF LDC AND A>TOP			( zero all bits at tos )
;CODE

CODE GET16	( CHAN -- DATA16 )
	SP>A  								( get address of top will become C )
	TOP>A						( get address of link to B )
	2 LDC IN								( make cnt 1, get char)
	TOP>A
	FFFF LDC AND A>TOP			( zero all bits at tos )
;CODE

VARIABLE BOOTLENGTH

: DUMPOUT ( ADDR LEN -- )
	OVER +  ( STATADR ENDADR -- )	SWAP DO ( END START -- )
	I C@ EMIT
	LOOP
;

VARIABLE STARTUPADDRESS

RUNTIME
' STARTUP STARTUPADDRESS !
( SEND STRT LEN EXEC + BODY )

: DUMPMAIN
	WS WEMIT
	HERE WS - DUP WEMIT
	STARTUPADDRESS @ WEMIT
	WS SWAP
	DUMPOUT
;
." ASSEMBLING BOOT "
( W+1 USED AS LOOP CNT W+2 TO REMEMBER BOOTING LINK )

CODESUB BOOTSTRAP
	5 AJW								( Adjust W so boot isn't cruded )
	2 STL REV							( get C into A )
	10 J								( jump around data table )
( startup info block MUST BE WORD ALIGNED )
	0 ,			( input link address )
	0 ,			( output link address )
	WS ,		( workspace )
	FORTH MINT ,		( auto exec FORTH word or null )
	ASSEMBLER
	-15 LDC LDPI  						( get base of table )
	6 STL								( W6 gets base )
	2 STL								( W2 gets in link )
	2 LDL 6 LDL 0 STNL					( put in link in table )
	2 LDL -10 ADC, 6 LDL 1 STNL			( put out link in table )
	MINT STHF							( set front pointers )
	MINT STLF							( set bottom 11 words to mint )
	TESTERR CLRHALTERR					( clear error flags )
	2C	LDC
	1 STL								( setup loop counter )
		BEGIN
			1 LDL -BPW ADC, 1 STL			( dec counter BPW )
			MINT MINT 1 LDL SUM 0 STNL	( store mint )
			1 LDL 0 EQC					( if counter =0 we're done )
		UNTIL
	0 LDC STTIMER						( start timer )
	( get start count and execute addr into W3,4 and 5)
	3 LDLP 2 LDL BPW 3 * LDC IN				( get 3 words into w+3)
	3 LDL 2 LDL 4 LDL IN				( get body of main)
	6 LDL 5 LDL GCALL
END-CODE
HERE BOOTSTRAP - BOOTLENGTH !

: DUMPBOOT
	BOOTSTRAP BOOTLENGTH @ DUP EMIT
	DUMPOUT
;

: BOOT FALSE WARMFLG ! DUMPBOOT DUMPMAIN KEY DROP ;
( CLASS FORMAT ETC )
( 1 -> CODE TO CALL DOES> )
( 2 -> POINTER TO CLASS RUNTIME CODE )
( 3 -> POINER TO SUPERCLASS { SAME FIELD IN SUPER , THE CHAIN ENDS AT Nil } )
( 4 -> POINTER TO METHOD LIST AT THE END OF THE CLASS DEF )
( 5 -> THE NUMBER OF BYTES USED FOR DATA STORAGE NOT COUNTING ANY INHERITED )
( 6 -> A POINTER BACK TO THE NAME FIELD OF THE CLASS )
		( 6a -> A POINTER TO SYMBOL TABLE { NOT IN TEMPORY OOPS STUFF } )
( 7... METHOD DEFINITIONS )
( LATER .. METHOD TABLE )
		( THEN .. SYMBOL TABLE  { NOT IN TEMPORY OOPS STUFF })
		( OBJECT FORMAT ETC.    { NOT IN TEMPORY OOPS STUFF })
( 1 -> CODE TO CALL DOES> )
( 2 -> POINTER TO OBJECT RUNTIME CODE )
( 3 -> POINTER TO THE OBJECTS CLASS )
( 4.... data )
HEX
RUNTIME
." OOPS STUFF " CR 
VOCABULARY OOPS UNLINKVOCAB

: IMMED ( MAKE IMMEDIATE )
	LATEST @ @ 80 OR LATEST @ !
;

RUNTIME DEFINITIONS
VARIABLE *GETMEM1
' FORTH *GETMEM1 !
DECIMAL 
30 CONSTANT MAX_METHODS	( MAXIMUM NUMBER OF METHODS )
HEX

: MSGTYPE	( MSGNO. -- EMPTY )
MSGLINK @	( MSGNO. LINK --> )
BEGIN
	DUP MINT= NOT
WHILE
	OVER OVER  ( MSGNO. LINK MSGNO. LINK --> )
	BPW- @ = IF
		BPW+ @
			DUP C@ 1F AND
			?DUP
			IF 0
				DO
					DUP 1+ I + C@ 7F AND EMIT
				LOOP
			THEN
			DROP DROP EXIT
	THEN
	@
REPEAT
DROP DROP
;

: UNKNMSG
	." Message No. " DUP U. MSGTYPE SPACE 
	ABORT" NOT UNDERSTOOD ??? "
;

: TYPE2
			DUP C@ 1F AND
			?DUP
			IF 0
				DO
					DUP 1+ I + C@ 7F AND EMIT
				LOOP
			THEN
		DROP
;
DEBUG

CODESUB [INDEX]		( ADD LITERAL TO DATAPTR AND PUSH )
 	DAP *LOAD
	IP *LOAD SUM
	SP PUSH
	IP ++W
	GCALL
END-CODE

CODESUB [BASE]		( PUSH DATAPTR )
 	DAP *LOAD
	SP PUSH
	GCALL
END-CODE
DEBUG

CODESUB [SUPER]	( ADD OFFSET TO TOP AND CALL METHOD )
	1 LDC INTPFLG ^^ STL	(  -- )
	DAP *LOAD IP *LOAD		( topdas dataofs -- get top of das and offset )
	SUM						( top+offs -- )
	DAP PUSH				( --  add and put back )
	IP ^^ LDL 1 LDNL				( methaddr -- get method address )
	IP ^^ LDL BPW 2 * ADC, IP ^^ STL		( methaddr -- advance ip past literal data )
	GCALL							( CALL METHOD )
END-CODE

CODESUB [DYN]					( DUP DATA ADDRESS STACK )
	SP POP
	IP ^^ LDL 0 LDNL		( GET OFFSET )
	SUM
	DAP PUSH				( PUSH TOP+OFFSET )
	1 LDC  INTPFLG ^^ STL
	IP ++W
	RTNXT ^^ LDL GCALL
END-CODE

CODESUB [DDUP]				( DUP DATA ADDRESS STACK )
	DAP *LOAD
	DAP PUSH
	1 LDC INTPFLG ^^ STL
	GCALL
END-CODE

OOPS DEFINITIONS

CODE DDUP				( DUP DATA ADDRESS STACK )
	DAP *LOAD
	DAP PUSH
	GCALL
END-CODE

CODE >D					( DUP DATA ADDRESS STACK )
	SP POP
	DAP PUSH
	GCALL
END-CODE

CODE D>					( DUP DATA ADDRESS STACK )
	DAP POP
	SP PUSH
	GCALL
END-CODE

CODE >M					( DUP DATA ADDRESS STACK )
	SP POP
	MP PUSH
	GCALL
END-CODE

CODE M>					( DUP DATA ADDRESS STACK )
	MP ^^ LDL
	MPINIT EQC
	IF 
			3 LDC ERTYPE ^^ STL
			ERRORVEC ^^ LDL   GCALL			( CALL ERROR )
	THEN
	MP POP
	SP PUSH
	RTNXT ^^ LDL GCALL
END-CODE

CODE DDROP				( DUP DATA ADDRESS STACK )
	DAP ++W
	GCALL
END-CODE

CODE MDROP				( DUP DATA ADDRESS STACK )
	MP ++W
	GCALL
END-CODE

CODE MAKELOCAL				( ADDR -->		MOVE DATAPTR TO ADDR )
	SP POP			( GET PTR FROM TOP )
	DAP *STORE
	GCALL
END-CODE
OOPS DEFINITIONS

: REDEFINED?
>IN @ 20 WORD C@ 
IF -'
    IF ." Warning message '" HERE TYPE DROP ." ' redefined " CR 
    THEN
THEN
>IN !
;
MINT MSGLINK !
MINT LSTMSG !

CODE [MSGLITERAL]
	IP *LOAD								( get value from cell )
	MP PUSH								( store value on stack )
	IP ++W						( advance IP )
	GCALL
END-CODE

: GMESSAGE
 REDEFINED?
 <BUILDS IMMED						( BUILD MESSAGE HEADER ETC )
 ,		( save message value )
	HERE MSGLINK @ , MSGLINK !		( save link to prev message )
	CURRENT @ @ BPW+ ,				( save link to text )
	DOES>
	@
	MODE @ IF
		DUP COMPILE [MSGLITERAL] ,
	THEN
	>M
;

: MESSAGE
 LSTMSG @ 1+ DUP LSTMSG !
 GMESSAGE
;
HIDE REDEFINED?
VOCABULARY MESSAGES UNLINKVOCAB
RUNTIME DEFINITIONS

: SETSUPER	( MS --> MS )
	USER BPW+ @ [ BPW 2 * ] LITERAL + @ 	( ms size --> get subsize )
	DUP USER +!			( ms --> ptr to next sub )
	USER [ BPW 2 * ] LITERAL + +!			( update offset )
	USER BPW+ @ @		( ms *super --> get super class )
	DUP USER BPW+ !		( ms *super --> save it )
	@ MINT= 
		IF UNKNMSG
		THEN
;

: SEARCHMETH	(  { msg }  --> 		msg only in interp mode )
	0 >D							( SAVE DEPTH = 0 )
	MODE @ IF
		MP @ MPINIT =   ( IF MODE != 0 AND MP EMPTY )
		IF
			 D> DROP FALSE EXIT
		ELSE -BPW 2* ALLOT
		THEN
	THEN
    M> D> BPW 2* + >D
	BEGIN 
		USER BPW+ @			( msg *class --> get class ptr )
		BPW+ 					( msg **methlist --> )
		@					( msg *methodlist --> )
			BEGIN
				OVER OVER				( msg *meth msg *meth --> )
				@ 						( msg *meth msg meth --> )
				= 						( msg *meth t/f --> )
				IF  SWAP DROP 			( *method --> )
					BPW+ 			( *rt-code --> )
					@
					DUP 1 AND IF	( IS LSB SET )
						1 XOR
						MODE @ IF
							MP @ MPINIT =
							IF
								DROP 
								D> ALLOT
								 		FALSE EXIT
							ELSE
								-BPW 2 * ALLOT M> D> BPW 2* + >D SWAP
							THEN
						ELSE
							M> SWAP
						THEN
						DUP DUP
					ELSE
					DDROP TRUE EXIT
					THEN
				ELSE
					DUP [ BPW 2 * ] LITERAL +
					@ DUP					( msg *link *methnew *methnew  )
				THEN
				MINT= NOT				( msg *meth *newmeth t/f )
			WHILE
				SWAP DROP				( msg *newmeth --> )
			REPEAT
			DROP DROP
			DDUP D> 8 > IF UNKNMSG
			ELSE SETSUPER	( ms --> )
			THEN
	AGAIN 
;

: CALLOBJ
	USER BPW+ !				( msg --> save *class )
	SEARCHMETH
	IF
 		EXECUTE
	ELSE
 		USER @ , 
	THEN
;

: COMPCALLOBJ
	USER BPW+ !				( msg --> save *class )
	SEARCHMETH
	IF
	MODE @ 
		IF				( METH -->    COMPILE )
			,			( -->	COMPILE METHOD )
		ELSE			( INTERP )
 			EXECUTE
		THEN	
	ELSE
		 USER @ , 
	THEN
;

HERE 10000 + METHTABPTR !
HERE 11000 + SYMTABPTR !
HERE 12000 + DUP DP'INIT ! DP' !

MESSAGES DEFINITIONS
MESSAGE instance
MESSAGE super
MESSAGE self
MESSAGE sizeof
MESSAGE clear
MESSAGE addmethod
MESSAGE buildtable
MESSAGE search    
( MESSAGE DEFINITIONS
OOPS DEFINITIONS
( TEMPORY OOPS STUFF STARTS HERE , THIS IS DISCARDED WHEN NO LONGER NEEDED )
( -------------------------------------------------------------------------)
CURRENT @ @
	HERE 8000 ALLOT
	CONSTANT FORK 
CONSTANT SAVECURRENT
MSGLINK @
MESSAGE submeth
MESSAGE endsubmeth
MSGLINK !

: BLD_MTAB					( WORD TO BUILD METHOD TABLE )
	<BUILDS
	MAX_METHODS 1+ [ BPW 3 * ] LITERAL * ALLOT ( RESERVE SPACE FOR TABLE )
	DOES>			( ? ? ? MSG1 ADDR --> )
	>R						( SAVE BASE ADDR )
	M>
	DUP clear M> = IF DROP		( --> )
		0 I ! R> [ BPW 2 * ] LITERAL +
		DUP !  ( POINT LINKPTR TO ITSELF AS FIRST LINKS RUBISH )
	EXIT THEN
	DUP addmethod M> = IF DROP	M>	( msg2 --> )
		I @
			1+ DUP MAX_METHODS > IF
				ABORT" METHOD TABLE FULL !! "
			THEN 
		I !						( msg2 --> 				bump index )
		I DUP @ [ BPW 3 * ] LITERAL * +			( msg2 NEXTADDR --> )
		R> [ BPW 2 * ] LITERAL +
		OVER OVER @ !	( msg2 NEXTADDR LNKPTR --> PNT PREV LINK HERE )
		OVER [ BPW 2 * ] LITERAL +
		SWAP !		( msg2 NEXTADDR --> PNT LINKPTR TO NEXT LINK )
		SWAP OVER !	BPW+ 			( NEXTADDR --> 		save msg )
		HERE OVER !				( --> 	save here )
		BPW+ MINT SWAP !
	EXIT THEN
	DUP buildtable M> = IF DROP	( --> )
	HERE SELF @ BPW+ !
		I BPW+ @					( LINK --> retrieve link )
		BYPASS @ !
		I [ BPW 3 * ] LITERAL + 					( SRC -->  )
					( SRC -->  )
		DUP HERE				( SRC SRC DST --> )
		SWAP -						( SRC OFFSET )
		SWAP
		R> @ 				( OFFSET SRC CNT --> )
		0 DO
( HERE U. CR	)		DUP @ , BPW+			( OFS SRC --> MOVE MESSAGE )
			DUP @ 1 AND 		( OFS SRC T/F --> LINK? )
				IF
					OVER OVER @ + , ( OFS SRC --> YES ADJUST )
				ELSE
					DUP @ ,		( OFS SRC --> NO DON'T ADJUST )
			THEN
			BPW+					( OFS SRC --> )
			DUP @ MINT= 		( OFS SRC T/F --> LINK? )
				IF
					DUP @ ,		( OFS SRC --> NO DON'T ADJUST )
				ELSE
					OVER OVER @ + , ( OFS SRC --> YES ADJUST )
			THEN
			BPW+					( OFS SRC --> )
		LOOP DROP DROP
		EXIT
	THEN
	DUP submeth M> = IF DROP M>
	I @
		1+ DUP MAX_METHODS > IF
			ABORT" METHOD TABLE FULL !! "
		THEN 
	I !					( msg2 --> 				bump index )
	I DUP @ [ BPW 3 * ] LITERAL * +		( msg2 NEXTADDR --> )
	SWAP OVER ! 		( NEXTADDR )
	DUP BPW+ DUP 9 + SWAP !	( NEXTADDR --> POINT TO NEXT METHOD LSB SET )
	R> [ BPW 2 * ] LITERAL +
	OVER OVER @ !	( NEXTADDR *linkptr --> LINK TO SUB )
	SWAP [ BPW 2 * ] LITERAL + SWAP OVER SWAP !	 	( NEXTADDR LINKPTR --> )
	DUP MINT SWAP !			( NEXTADDR --> MINT IT FOR NOW )
	EXIT
	THEN
	DUP endsubmeth M> = IF DROP	( PTR --> )
		DUP MINT SWAP !
		R> [ BPW 2 * ] LITERAL + ! EXIT
	THEN
	DUP super M> = IF DROP
		H/C ON DP'INIT  @ DP' !
		CURRENT @ @ R> BPW+ !	EXIT ( save link to hide data )
	THEN
	UNKNMSG
;

BLD_MTAB METH_TABLE

: SUBMETH	( -- PTR )
	submeth METH_TABLE
;

: ENDSUBMETH ( PTR -- )
	endsubmeth METH_TABLE
;

: :METH
		addmethod METH_TABLE
		SAVEMODE @ 2 = IF
			COMPILE
			[ ASSEMBLER CP ^^ LDL   ' [OBJ] ' [COLON] - ADC, GCALL VDROP ]
		ELSE ( 3 =  ) 
			COMPILE
			[ ASSEMBLER CP ^^ LDL   GCALL NOP NOP VDROP ]
		THEN
	TRACE @
		IF							( INSERT TRACEING CODE )
			>IN @ >R
			0 >IN !  COMPILE D.S COMPILE  dot" 0 STRING
			R> >IN !
		THEN
	SP @ USER 14 + !
	]
;

: ;METH
	MODE @ 2 = IF
 		COMPILE  [DNEXT] 
	ELSE COMPILE [NEXT]
	THEN
 	R> DROP
	SP @ USER 14 + @ = NOT IF
		 ABORT" DEFINITION NOT FINISHED "
		THEN 
 	0 MODE !						( BACK TO INTERP MODE )
;
IMMED
( CREATE WORD ALIGNED INDEX INTO DATA STRUCT = W-SIZE , BUMP SIZE )
( format PARENT,*METHODLIST,METHDEF,METHLIST)

: OBJECT
	H/C OFF
	HERE BYPASS !
	<BUILDS 				( build class header )
	IMMED
		HERE SELF @ ,			( link to superclass )
		SELF !			( point self here )
		MINT ,				( method pointer goes here )
		clear METH_TABLE				( marker for end_Class to stack )
		3 SAVEMODE !
		[ ' COMPCALLOBJ BPW+ ] LITERAL MARKER @ !
;

: COMPILEROBJECT
	H/C OFF
	HERE BYPASS !
	<BUILDS 				( build class header )
	IMMED
		HERE SELF @ ,			( link to superclass )
		SELF !			( point self here )
		MINT ,				( method pointer goes here )
		clear METH_TABLE				( marker for end_Class to stack )
		3 SAVEMODE !
		[ ' CALLOBJ BPW+ ] LITERAL MARKER @ !
;
( format PARENT,*METHODLIST,LOC-SIZE,METHDEF,METHLIST)

: CLASS
	H/C OFF
	HERE BYPASS !
	<BUILDS 				( build class header )
	IMMED
		HERE SELF @ ,		( link to superclass )
		SELF !				( point self here )
		MINT ,				( method pointer goes here )
		SIZE @ ,			( size goes here )
 		CURRENT @ @ BPW+ ,
		clear METH_TABLE				( marker for end_Class to stack )
		2 SAVEMODE !
	DOES>					( msg **parent --> )
				M>
				DUP super M> = IF ( make this ancestor )
				DROP
				super METH_TABLE
				SELF !
				0 SIZE ! ( clear size )
				EXIT
			THEN
	UNKNMSG
;

: END-DEFINITION
	buildtable METH_TABLE
	1 SAVEMODE !
;

FORK DP !			( BACK TO TARGET DICTIONARY )
( THIS IS THE END OF THE TEMPORY STUFF )
( ------------------------------------------------------------------------)
MESSAGE var
MESSAGES DEFINITIONS
MESSAGE published
MESSAGE array
MESSAGE setsize
RUNTIME DEFINITIONS
OOPS DEFINITIONS
MINT SELF ! 0 SIZE !
CLASS Nil
1 SAVEMODE !
-1 SELF !

: REMOTE 0 SIZE ! ;

: LOCAL 0 SIZE ! ;

: SAVESIZE SIZE @ CONSTANT ;

( FUDGE TILL MEMALOC READY )
MESSAGES DEFINITIONS
MESSAGE end
MESSAGE class
MESSAGE object
MESSAGE dynamic
MESSAGE addsymbol
( MESSAGE remember
MESSAGE compiler
OOPS DEFINITIONS
." OBJECT SYMBOL_TABLE " CR
super Nil
( CNT SAVELINK LINKPTR MES1 ADDR1 LINK1 MES2 ETC )
OBJECT Symbol_Table				( WORD TO BUILD METHOD TABLE )
clear :METH
			SYMTABPTR @ DUP	( &TABLE &TABLE --> )
			BPW+ SWAP !		( SET UP SYMTAB )
		;METH
addsymbol :METH ( NO TABLE OVERFLOW CHECKING YET )
		>IN @				( CNT --> REMEMBER CNT FOR LATER )
		20 WORD 			( CNT HERE --> )
		SYMTABPTR @ >R
		I @ OVER C@ 1+ OVER OVER + >R CMOVE
		R> 
		BEGIN							( PAD TO WORD BOUNDARY )
			DUP 3 AND
		WHILE
			1+ DUP 0 C!
		REPEAT
		DUP 1- DUP C@ 80 OR SWAP C!		( SET TERM BIT )
		SIZE @ OVER ! BPW+
		R> !
		>IN !
	;METH
buildtable :METH
	SYMTABPTR @ >R	( EMPTY --> R GETS &TABLE
	I BPW+			( SRCPNTR --> )
	DUP I @ = NOT
	IF 
		HERE SELF @ [ 4 BPW * ] LITERAL + !
		BEGIN
			DUP I @ = NOT	( WHILE ANOTHER SYMBOL EXISTS )
		WHILE
			DUP C@ 			( SRCPNTR CNT --> GET CNTBYTE )
			[ BPW 2 * ] LITERAL +
			-BPW AND	( SRCPNTR CNT --> ADJUST TO WORD BOUNDARY )
			>R DUP HERE I CMOVE ( SRCPNTR --> MOVE TO HERE )
			I ALLOT			( SRCPNTR -->  ADJUST DP )
			R> +			( SRCPNTR+? --> ADJUST  SRCPNTR )
		REPEAT
		MINT ,
	THEN
	DROP R> DROP
;METH

END-DEFINITION

super Nil
( CNT SAVELINK LINKPTR MES1 ADDR1 LINK1 MES2 ETC )
OBJECT Meth_Table				( WORD TO BUILD METHOD TABLE )
clear :METH
			METHTABPTR @ 0 OVER	! 	( *METHTABLE --> SET CNT IN FIRST WORD TO = 0 )
 			[ BPW 2 * ] LITERAL +   ( *SYMTABLE+2W --> )
			DUP ! 					( --> LNKPTR PNTS TO ITSELF )
		;METH
addmethod :METH M>
				METHTABPTR @ DUP >R @
				1+ DUP MAX_METHODS > IF
						ABORT" METHOD TABLE FULL !! "
					THEN 
		I !						( msg2 --> 				bump index )
		I DUP @ [ BPW 3 * ] LITERAL * +			( msg2 NEXTADDR --> )
		R> [ BPW 2 * ] LITERAL +
		OVER OVER @  !	( msg2 NEXTADDR LNKPTR --> PNT PREV LINK HERE )
		OVER [ BPW 2 * ] LITERAL +
		SWAP  !		( msg2 NEXTADDR --> PNT LINKPTR TO NEXT LINK )
		SWAP OVER  !	BPW+ 		( NEXTADDR --> 		save msg )
		HERE OVER !				( --> 	save here )
		BPW+ MINT SWAP !			( MINT LINK FOR NOW )
	;METH
buildtable :METH
		HERE SELF @ BPW+ !
		METHTABPTR @ BPW+ @					( LINK --> retrieve link )
		BYPASS @  !
		METHTABPTR @ [ BPW 3 * ] LITERAL + 					( SRC -->  )
					( SRC -->  )
		DUP HERE				( SRC SRC DST --> )
		SWAP -						( SRC OFFSET )
		SWAP
		METHTABPTR @ @ 				( OFFSET SRC CNT --> )
		0 DO
			DUP @ , BPW+			( MOVE MESSAGE )
			DUP @ 1 AND 		( OFS SRC T/F --> LINK? )
				IF
					OVER OVER @ + , ( OFS SRC --> YES ADJUST )
				ELSE
					DUP @ ,		( OFS SRC --> NO DON'T ADJUST )
			THEN
			BPW+					( OFS SRC --> )
			DUP @ MINT= 
				IF
					DUP @ ,
				ELSE
					OVER OVER @ + ,
			THEN
			BPW+	( OFS SRC --> MOVE AND ADJUST LINK )
		LOOP	DROP DROP
		;METH
search :METH 
		METHTABPTR @ 				( msg addr -->   get cnt )
		C + 
		BEGIN				( PTR --> )
			M> SWAP
		BEGIN				( PTR MSG --> 
			OVER OVER @ = NOT
 		WHILE	( msg addr++ --> 	if match )
			[ BPW 2 * ] LITERAL + @ DUP
			MINT= IF
				SWAP DROP UNKNMSG
			THEN
		REPEAT
			SWAP DROP	-BPW 2 * ALLOT	( addr++ --> 	drop msg )
			BPW+ @ DUP
			1 AND IF 
				-2 AND 
			ELSE
				EXIT		( meth	--> get method addr exit )
			THEN
		AGAIN					( repeat till LINK = MINT )
		;METH
super :METH 
			METHTABPTR @ MINT= IF
				ABORT" 'PROGRAM' missing !!!"
			ELSE
				clear Symbol_Table
				CURRENT @ @ METHTABPTR @ BPW+ ! ( save link to hide data )
				H/C ON DP'INIT  @ DP' !
			THEN
		;METH
submeth :METH M>
		METHTABPTR @ >R
		I @
			1+ DUP MAX_METHODS > IF
				ABORT" METHOD TABLE FULL !! "
			THEN 
		I !						( msg2 --> 				bump index )
		I DUP @ [ BPW 3 * ] LITERAL * +			( msg2 NEXTADDR --> )
		SWAP OVER ! 			( NEXTADDR )
		DUP BPW+ DUP 9 + SWAP !	( NEXTADDR --> POINT TO NEXT METHOD LSB SET )
		R> [ BPW 2 * ] LITERAL +
		OVER OVER @ !		( NEXTADDR *linkptr --> LINK TO SUB )
		SWAP [ BPW 2 * ] LITERAL + SWAP OVER SWAP !	( NEXTADDR LINKPTR --> )
		DUP MINT SWAP !				( NEXTADDR --> MINT IT FOR NOW )
	;METH
endsubmeth :METH ( PTR --> )
		DUP MINT SWAP !
		METHTABPTR @ [ BPW 2 * ] LITERAL + !
	;METH

END-DEFINITION
MESSAGES DEFINITIONS 
MESSAGE method
MESSAGE begin
MESSAGE alt

RUNTIME DEFINITIONS

super Nil

: COMPORCALL
	DUP BPW+ USER [ BPW 3 * ] LITERAL + ! 	( msg **class --> save data addr )
	@ USER BPW+ !				( msg --> save *class )
	0 USER [ BPW 2 * ] LITERAL + !			( clear data offset )
	SEARCHMETH
	IF
	MODE @
	USER [ BPW 2 * ] LITERAL + @ USER [ BPW 3 * ] LITERAL + @ + >R
		IF					( METH -->    COMPILE )
			,				( -->	COMPILE METHOD )
			R> ,	( COMPILE DATA-ADDR )
		ELSE				( INTERP )
			1 INTPFLG !
			-BPW DAP +! R> DAP @ !
 			EXECUTE 
		THEN
	ELSE
 		USER @ , 
	THEN
;

: MAKEINST	( **class --> LOCAL WORD TO [CLASS] )
	<BUILDS		( *class --> )
	IMMED
	DUP ,
	BEGIN		( ALLOT SPACE FOR DATA )
		DUP @ MINT= NOT 		( *class --> )
	WHILE
		DUP [ BPW 2 * ] LITERAL +
		@ ALLOT		( *superclass --> allot loc size )
		@
	REPEAT
	DROP
	DOES>
	COMPORCALL				
;

: GETSIZE
				0 >R	( cnt *class --> )
				BEGIN			( find space needed )
					DUP @ MINT= NOT 		( msg *class --> )
				WHILE
					DUP [ BPW 2 * ] LITERAL +
					@ R> + >R		( msg *superclass --> allot loc size )
					@
				REPEAT
			DROP	R>
;

: DINST
  I @ *GETMEM1 @ EXECUTE		( ADDROB -- ADDR OF OBJ )
	DUP MINT= IF ABORT" MEMALLOC FAILED " THEN
	[ ' super @ ] LITERAL 		( A DOES CONSTRUCT )
	OVER !						( PUT DOES CALL INTO OBJECT )
	[ ' COMPORCALL BPW+ ] LITERAL 	( BPW+ TO SKIP COLON )
	OVER BPW+ !					( ADDROB -- SAVE RUNTIME CODE )
	I BPW+ @ OVER				( ADDROB CLASS ADDROB+2 -- SAVE RUNTIME CODE )
	[ BPW 2 * ] LITERAL + !	( SAVE *CLASS )
	R> [ BPW 2 * ] LITERAL + >R
;

." [Class] " CR
COMPILEROBJECT [Class]
	super :METH ( make this ancestor )
				SELF @ -1 = NOT IF -1 SELF !
					 ABORT" Superclass already defined "
				THEN
				super Meth_Table
				SELF !
				0 SIZE ! ( clear size )
		;METH
	instance :METH ( instance of class )
			MAKEINST
			;METH
	sizeof :METH ( msg *class --> GET SIZE OF OBJ )
				GETSIZE
			;METH
( TRACE ON
dynamic SUBMETH
		instance :METH
			DUP		GETSIZE
			[ 3 BPW * ] LITERAL + 		( AND SPACE FOR " DOES " + CLASS )
			MODE @
				IF
					COMPILE DINST , , ( COMPILE DINST SAVE SIZE AND CLASS )
				ELSE
					*GETMEM1 @ EXECUTE
					MINT= IF ABORT" MEMALLOC FAILED " THEN
				THEN
		;METH
		method :METH ( )
				USER BPW+ !
				0  USER [ BPW 2* ] LITERAL + !
				SEARCHMETH
					IF
						MODE @ IF
							[DYN] , USER [ BPW 2* ] LITERAL + @ ( OFFSET )
							[ BPW 3 * ] LITERAL +	( ADJUST TO SKIP DOES ETC)
							, ,
						ELSE
							SWAP [ BPW 3 * ] LITERAL + >D			
							1 INTPFLG !
							EXECUTE
						THEN
					ELSE
						COMPILE >D 	( TO BE CHANGED SOON )
						USER @ ,
					THEN
			;METH
ENDSUBMETH
TRACE OFF
END-DEFINITION
." Definition " CR
OOPS DEFINITIONS
super Nil

: MAKEOBJECT
		SELF @ @ MINT= NOT IF
			 ABORT" Superclass must be Nil for object Definitions "
		THEN
	H/C OFF
	HERE BYPASS !
	<BUILDS 				( build class header )
	IMMED
		HERE SELF @ ,			( link to superclass )
		SELF !				( point self here )
		MINT ,				( method pointer goes here )
		clear Meth_Table	( marker for end_Class to stack )
		MINT ,				( symbol pointer goes here )
		3 SAVEMODE !
;

: ENDOBJ
	buildtable Meth_Table
	buildtable Symbol_Table
	1 SAVEMODE ! -1 SELF !
;
ASSEMBLER FORTH OOPS
OBJECT Definition
	class SUBMETH
	begin
		:METH
		SELF @ -1 = IF ABORT" Superclass not defined " THEN
		H/C OFF
		HERE BYPASS !
		<BUILDS 				( build class header )
		IMMED					( make immediate )
			HERE SELF @ ,		( link to superclass )
			SELF !				( point self here )
			MINT ,				( method pointer goes here )
			SIZE @ ,			( size goes here )
			CURRENT @ @ BPW+ ,	( pointer to class name )
			clear Meth_Table				( marker for end_Class to stack )
			MINT ,				( Symbol pointer goes here )
			2 SAVEMODE !
		DOES> [Class] (  **parent --> )
	;METH
	end
	:METH
		ENDOBJ
	;METH
ENDSUBMETH
	object SUBMETH
	begin
	:METH
		MAKEOBJECT
	DOES>					( msg *parent --> )
		COMPCALLOBJ
	;METH
end :METH
		ENDOBJ
	;METH
ENDSUBMETH
compiler SUBMETH
	object SUBMETH
		begin 
		:METH
			MAKEOBJECT
		DOES>					( msg *parent --> )
			CALLOBJ
		;METH
		end :METH
			ENDOBJ
		;METH
	ENDSUBMETH
ENDSUBMETH
END-DEFINITION
HIDE FWER
MESSAGES DEFINITIONS
MESSAGE code
MESSAGE colon
MESSAGE sub
( MESSAGE endsub
OOPS DEFINITIONS
super Nil
COMPILEROBJECT Method
colon SUBMETH 
	begin :METH
		addmethod Meth_Table
		SAVEMODE @ 2 = IF
			COMPILE
			[ ASSEMBLER CP ^^ LDL   ' [OBJ] ' [COLON] - ADC, GCALL VDROP ]
		ELSE ( 3 =  ) 
			COMPILE
			[ ASSEMBLER CP ^^ LDL   GCALL NOP NOP VDROP ]
		THEN
	TRACE @
		IF							( INSERT TRACEING CODE )
			>IN @ >R
			0 >IN !  COMPILE D.S COMPILE  dot" 0 STRING
			R> >IN !
		THEN
	SP @ USER 14 + !
	]
	;METH
	end :METH
	SAVEMODE @ 2 = IF
 			COMPILE  [DNEXT] 
		ELSE COMPILE [NEXT]
		THEN
	SP @ USER 14 + @ = NOT IF
		 	ABORT" DEFINITION NOT FINISHED "
		THEN 
 	R> DROP R> DROP
 	0 MODE !						( BACK TO INTERP MODE )
	;METH
ENDSUBMETH

code SUBMETH
	ASSEMBLER FORTH OOPS
	begin :METH addmethod Meth_Table 
		SAVEMODE @ 2 = IF
			COMPILE
			[ ASSEMBLER CP ^^ LDL   ' [CODEOB] ' [COLON] - ADC, GCALL NOP VDROP ]
		THEN
		ASSEMBLER SP @ USER 14 + !
		;METH
		ASSEMBLER FORTH OOPS
	end :METH
		SAVEMODE @ 2 = IF
			DAP ++W
		THEN
		RTNXT  ^^ LDL   GCALL
		END-CODE
		;METH
ENDSUBMETH
sub SUBMETH
	begin :METH	( -- PTR )
		submeth Meth_Table
	;METH
	end :METH ( PTR -- )
		endsubmeth Meth_Table
	;METH

ENDSUBMETH
super :METH
	SELF @ USER BPW+ !
	0 USER [ BPW 2 * ] LITERAL + !			( clear data offset )
	SEARCHMETH
	IF
 		USER [ BPW 2 * ] LITERAL + @
		[SUPER] , , , 
	ELSE
		USER @ , 
	THEN
;METH
self :METH
	search Meth_Table	( msg METH/MINT --> )
	SAVEMODE @ 2 = IF
		[DDUP] ,
	THEN ,
;METH
END-DEFINITION
HIDE Meth_Table
HIDE D.S
HIDE -->
OOPS DEFINITIONS
MINT SELF ! 0 SIZE !
begin class Definition  Nil
1 SAVEMODE !
-1 SELF !
	: COMPINDEX
		MODE @ IF ( COMPILED )
			?DUP IF
				[INDEX] , ,
			ELSE
				[BASE] ,
			THEN
		THEN
	;

super Nil
	: { H/C OFF { ;
	: } H/C ON } ;
	: ADJUSTSIZE
		>R
		SIZE @ MINT OR MINT XOR		( CLEAR SIZE SIGN BIT )
		3 + -BPW AND				( ADJUST TO WORD BOUNDARY )
 		DUP , R> + SIZE !			( SAVE SIZE AND ADJUST NEW SIZE )
	;
	: BUILDVAR
		<BUILDS IMMED
			[ [BASE] , ] @ ADJUSTSIZE
		DOES>
			@ COMPINDEX
	;
	: BUILDARRAY
		<BUILDS IMMED 
			[ [BASE] , ] @  *  ADJUSTSIZE
		DOES>
			@ COMPINDEX
	;
BPW SIZE !

begin class Definition Vardec_Class
	var 	begin colon Method
				{ BUILDVAR }
			end colon   Method
	array 	begin colon Method
 				{ BUILDARRAY }
			end colon Method
	setsize begin colon Method
				[ [BASE] , ] !
			end colon Method
	sizeof	begin colon Method
				[ [BASE] , ]  @
			end colon Method
	published
	begin sub Method
		var 	begin colon Method
					addsymbol Symbol_Table 
					var self Method
				end colon   Method
		array 	begin colon Method
					addsymbol Symbol_Table
					array self Method
				end colon   Method
	end sub Method
end class Definition

HIDE Symbol_Table

instance Vardec_Class Real
4 setsize Real
instance Vardec_Class Int
BPW setsize Int
instance Vardec_Class Ptr 
BPW setsize Ptr
instance Vardec_Class Byte
1 setsize Byte

super Nil	( this is the ancestor to all objects + Classes )
begin object Definition DUMMY
super
	begin colon Method
	end colon Method
end object Definition
( COMPILER DEFINITIONS VDROP
super Nil

: FINDSYMBOL
20 WORD DROP
0 >R
	BEGIN						( *SUPER --> )
		DUP @ MINT= NOT
	WHILE
		DUP [ 4 BPW * ] LITERAL + @				( *SUPER *SYM --> )
		DUP MINT= NOT
		IF
			BEGIN
				DUP @ MINT= NOT		( *SUPER *SYM T/F --> )
			WHILE
            	DUP >D
				HERE 				(  *SUPER *SYM HERE --> )
					BEGIN
						OVER @ OVER @ - DUP NOT	( *SUPER *SYM HERE DIFF SAME --> )
					WHILE
						DROP BPW+ SWAP BPW+ SWAP
					REPEAT                      ( *SUPER *SYM HERE --> )
					SWAP DROP                     ( *SUPER *SYM DIFF --> )
				MINT= IF
            		 BPW+ @ R> + SWAP DROP D> DROP EXIT
				THEN
				D> C@                           ( *SUPER *SYM CNT --> )
				BPW+ -BPW AND	( *SUPER *SYM+ --> ADJUST TO WORD BOUNDARY )
				+
				BPW+
			REPEAT
		THEN
	OVER [ 2 BPW * ] LITERAL + @ R> + >R		( ADD SIZE TO I )
	DROP						( *SUPER --> )
	@						( *NEWSUP *NEWSUP --> )
	REPEAT						( *NEWSUP )
ABORT" Data field not found "
;
begin object compiler Definition Field
super
	begin colon Method
		SELF @ FINDSYMBOL COMPINDEX
	end colon Method
end object Definition
HIDE COMPINDEX
HIDE  SIZE
HIDE  SELF
MESSAGES DEFINITIONS
MESSAGE methods
MESSAGE fields

OOPS DEFINITIONS
super Nil

: FINGER	( FINGER AN OBJECT )
	CR 	' BPW+
	DUP @ [ ' Method BPW+ @ ] LITERAL =
	OVER @ [ ' Definition BPW+ @ ] LITERAL = OR
	OVER @ [ ' DUMMY  BPW+ @ ] LITERAL = OR
	OVER @ [ COMPILER ' Method  VDROP BPW+ @ ] LITERAL = OR
	IF ." it's an object " 2 >D
		BPW+ 			( METH LIST )
	ELSE
		DUP @ [ ' Vardec_Class BPW+ @ ] LITERAL =
		IF ." it's a class " 1 >D
			BPW+ 
		ELSE
			DUP @ [ ' Int BPW+ @ ] LITERAL =
			IF 			
				1 >D ." it's an instance of the class "
				BPW+ @ DUP [ BPW 3 * ] LITERAL + @ TYPE2
			ELSE ." Not an object " CR 0 >D EXIT
			THEN
		THEN
	THEN						( *SUPER --> )
;
HIDE DUMMY
begin object Definition Of
    methods
    begin colon Method
	FINGER
	D> IF
		0 >R						( DEPTH )
		CR ." it understands the following messages :- " CR
		BEGIN
			DUP @ MINT= NOT
		WHILE
			DUP BPW+ @				( *SUPER *METH --> 
			BEGIN
				DUP @ MINT= NOT		( *SUPER *METH T/F --> )
			WHILE
				I 4 * SPACES
				DUP @ MSGTYPE CR	( *SUPER *METH --> )
				DUP BPW+ @ 1 AND IF
					DUP BPW+ @ -2 AND
					R> 1+ >R
				ELSE				 				( *SUPER *NEWMETH --> )
					BEGIN
						[ BPW 2 * ] LITERAL + @ DUP MINT= I NOT NOT AND 
					WHILE
						R> 1- >R DROP
					REPEAT
				THEN
			REPEAT
			DROP						( *SUPER --> )
			@ DUP						( *NEWSUP *NEWSUP --> )
			C + @						( *NEWSUP NAMEPTR --> )
			." SUPER CLASS --> " TYPE2 CR
		REPEAT						( *NEWSUP )
	R> DROP							( DROP DEPTH )
	THEN
	DROP
end colon Method
fields
begin colon Method
	FINGER
	D> DUP 1 = IF DROP
	0 >R FALSE >D
	CR ." it has the following published data fields :- " CR
	BEGIN						( *SUPER --> )
		DUP @ MINT= NOT
	WHILE
		DUP [ 4 BPW * ] LITERAL + @				( *SUPER *SYM --> )
		DUP MINT= NOT IF
			BEGIN
				DUP @ MINT= NOT		( *SUPER *SYM T/F --> )
			WHILE
				D> DROP TRUE >D
				." Field :- " DUP TYPE2 4 SPACES ." OFFSET = " ( *SUPER *SYM --> )
				DUP C@ 
				 BPW+	-BPW AND	( *SUPER *SYM --> ADJUST TO WORD BOUNDARY )
				+ DUP @  I + . CR BPW+
			REPEAT
		THEN
		OVER [ 2 BPW * ] LITERAL + @ R> + >R		( ADD SIZE TO I )
	DROP						( *SUPER --> )
	@ DUP						( *NEWSUP *NEWSUP --> )
	C + @						( *NEWSUP NAMEPTR --> )
	." SUPER CLASS --> " TYPE2 CR
	REPEAT						( *NEWSUP )
	R> DROP D> 
		NOT IF ." No published fields " THEN
	ELSE 2 = IF ." which " 
			ELSE ." it "
			THEN
		." can't have published fields "
	THEN
DROP
end colon Method
end object Definition
 ' FORK
 SAVECURRENT FORK !	( remove all the tempory stuff )
 1000 ERASE
OOPS MESSAGES

DEBUG
RUNTIME 
HEX
MESSAGES DEFINITIONS
	MESSAGE hold
	MESSAGE release
	MESSAGE die
	MESSAGE settimeout
( semaphore class mint = free )
OOPS DEFINITIONS
super Nil
var published Int SEMA
var Int TIMEOUT

CODE TESTANDSET	( all instances of forth should run low priority )
	TOP>A		( or this code can be interrupted leading to a possible )
	TOP>A		( clash i think , but maybe the hi-pri would run to )
	0 LDNL		( completion before returning , end Forth is worth watching )
	REV
	0 LDLP REV 0 STNL	( Save process I.D. in sema-phore )
	A>TOP
;CODE

begin class Definition Semaphore_Class
release
	begin colon Method
		MINT SEMA !
	end colon Method
hold
	begin colon Method
		GETTIMER
		BEGIN
			SEMA TESTANDSET DUP MINT= NOT SWAP WS = NOT AND
		WHILE				( WHILE SEMA HOLDS ANOTHER PROCESS I.D. )
			GETTIMER OVER -
			TIMEOUT @ > IF CR
					." Semaphore time out in process  " WS U. CR
					." Esc to abort any other key to retry :- "
					KEY 1B = IF ABORT THEN
					DROP GETTIMER
				THEN
			2 DELAY
		REPEAT
		DROP
	end colon Method
settimeout
	 begin colon Method
		TIMEOUT !
	end colon Method
end class Definition
( ' Semaphore_Class U.
( MINT MINT 10000 + 10000 CMOVE

( LINK LIST USAGE FOR FREE MEMORY LIST 
( 
( CLASS DATA	BLOCK1		BLOCK2		LASTBLK
( FREEPTR	--> FREEPTR	--> FREEPTR	--> MINT
( SIZE BLK1		SIZE BLK2	SIZELST		???
(
MESSAGES DEFINITIONS

	MESSAGE trace
	MESSAGE getmem
	MESSAGE freemem
	MESSAGE configure
(	MESSAGE getptr
	MESSAGE showfree
	MESSAGE mode1
	MESSAGE mode2
	MESSAGE special
OOPS DEFINITIONS

super Semaphore_Class

	var Ptr FREEPTR
	var Int BLKSIZE
	VARIABLE TOP
	VARIABLE BOTTOM
	VARIABLE SAVEPTR
( TRACE ON

: FREEMEM
	DDUP
	BPW- DUP DUP BOTTOM !
	@ + TOP !
				MINT SAVEPTR !				( SAVE PREVIOUS LINK )
			BEGIN
				FREEPTR @ MINT= NOT
				FREEPTR @ BOTTOM @ < AND 
			WHILE
				FREEPTR SAVEPTR !				( SAVE PREVIOUS LINK )
				FREEPTR @ MAKELOCAL
			REPEAT
( see if the previous and released block can be merged )
				SAVEPTR @ MINT= NOT 
					IF				( CALC END OF PREVIOUS BLOCK )
						SAVEPTR @
						BPW+ @ FREEPTR +
					ELSE MINT
					THEN
				BOTTOM @ =
				IF ( MERGE BOTTOM WITH PREVIOUS
 					BOTTOM @ @ ( GET SIZE )
					SAVEPTR @ BPW+ @ + SAVEPTR @ BPW+ !
				ELSE ( LINK TO PREVIOUS )
					FREEPTR SAVEPTR !
					BOTTOM @ @					( KEEP SIZE )
					FREEPTR @ BOTTOM @ !		( MOVE LINKS TO BLOCK )
					BLKSIZE @ BOTTOM @ BPW+ !
					BLKSIZE !
					BOTTOM @ FREEPTR !
					FREEPTR @ MAKELOCAL
				THEN
( now check if the next two block can merge )
			FREEPTR @
 MINT= NOT	( check if there is a next block )
				IF 
					FREEPTR @ 				( start of next block )
					SAVEPTR @
					DUP @ SWAP BPW+ @ + 	( end of this block )
					=
						IF 						( yes merge them )
							BLKSIZE @			( )
							FREEPTR @ BPW+ @ 	( S1 size of 2nd block )
							SAVEPTR @ BPW+ @	( S1 S2 --SIZE 1'ST BLK)
							FREEPTR @ @  		( S1 S2 P2 get next ptr )
							ROT BLKSIZE !		( S2 P2 -- S1 > S1 )
							FREEPTR !			( S1 -- P2 > P1
							+ SAVEPTR @ BPW+ !	( S1 @S2 @S2 -- calc merged size )
						THEN
				THEN
			DDROP
;
( TRACE OFF

: GETMEM
		DDUP
		3 + -BPW AND BPW+		( ADJUST TO WORD LEN + 1 WORD FOR CNT  )
		>R					( SAVE NUMBER ON R )
		BEGIN
			FREEPTR @ MINT= NOT	( T/F --> )
			BLKSIZE @ I < AND		( T/F --> )
		WHILE					( WHILE SIZE TO SMALL AND VALID PTR )
			FREEPTR @ MAKELOCAL
		REPEAT
		FREEPTR @ MINT=
			IF ( FAIL )
				R> DROP
			 	DDROP
				MINT EXIT
			THEN
		BLKSIZE @ I - [ BPW 2 * ] LITERAL <
		IF
				R> DROP 
				BLKSIZE @			( SIZE --> )
				FREEPTR @ BPW+ SWAP	( *FREE SIZE --> THIS IS THE FIRST FREE WORD )
				FREEPTR @			( *FREE SIZE *CNT --> SET CNT LATER )
				DUP BPW+ @			( *FREE SIZE *CNT NEXTSIZE --> )
				BLKSIZE !			( *FREE SIZE *CNT --> MOVE SIZE )
				DUP @ FREEPTR ! 	( *FREE SIZE *CNT --> MOVE LINK )
				!					( *FREE --> PUTCOUNT IN FREE-4 )
		ELSE
				FREEPTR @ BPW+		( *FREE --> THIS IS THE FREE MEMORY ADDR )
				I FREEPTR @			( *FREE SIZE *CNT -->
				BLKSIZE @ I - BLKSIZE !	( *FREE SIZE *CNT --> ADJUST SIZE
				DUP R> + FREEPTR !	( *FREE SIZE *CNT --> ADJUST FREEPTR
				DUP @ FREEPTR @ !	( *FREE SIZE *CNT -->
				DUP BPW+ @ FREEPTR @ BPW+ !	( *FREE SIZE *CNT -->
				!					( *FREE -->
		THEN
		DDROP
;
begin class Definition MemAlloc_Class
getmem				( take memory from free list and give to caller )
begin sub Method	( N --> NUM 	ALLOCATE N BYTES )
	mode1	( NUM -- *FREE RETURN PTR TO FREE MEM WITH LENGTH AT FREE - 4 )
	begin colon Method
		hold super Method
			GETMEM
		release super Method
	end colon Method
	mode2
		begin colon Method
						( var num --> *free   as above but chains used blocks )
			BPW+
			hold super Method
			GETMEM  ( var *free --> get extra word for link )
			release super Method
			DUP MINT= IF EXIT THEN
			OVER @ OVER !			( var *free --> copy var to free )
			DUP ROT !				( *free --> copy free to var )
			BPW+					( *free++ --> inc beyond link )
		end colon Method
	end sub Method
freemem 							( return memory to free list )
	begin sub Method
		mode1 
		begin colon Method			( *FREE --> addr )
			hold super Method
				FREEMEM
			release super Method
		end colon Method
		mode2 
		begin colon Method			( *LIST --> addr )
			DUP @ SWAP MINT SWAP !
			BEGIN
				DUP 				( *LIST --> )
				MINT= NOT 			WHILE
				DUP @ SWAP 
				hold super Method
					FREEMEM
				release super Method
			REPEAT
			DROP
		end colon Method
		special 					( no semaphore check , use by ENDFORTH ? )
		begin colon Method			( *LIST --> )
			DUP @ SWAP MINT SWAP !
			BEGIN
				DUP 				( *LIST --> )
				MINT= NOT 
			WHILE
				DUP @ SWAP 
				FREEMEM
			REPEAT
			DROP
		end colon Method
	end sub Method
configure	 ( see how much memory we got and set up free list )
	begin colon Method
	hold super Method
	0 >R						( TEST OFFSET TO R )
	HERE @ HERE !
	BEGIN
		I HERE + DUP DUP !		( TAD TAD --> WRITE TO TEST WORD )
		DUP @ =					( T/F  --> READIT BACK AND COMPARE )
		HERE @ HERE = 			( T/F T/F --> HAS HERE BEEN CHANGED )
		AND						( T/F --> IF BOTH ARE TRUE CONTINUE )
	WHILE
		R> 100000 + >R			( INC R BY ONE MEG )
	REPEAT						( UNTIL BAD OR ALIASED MEMORY )
		R>						( GET OFFSET TO BAD WORD )
		HERE +					( FIND IT'S ABS VALUE )
		FFF00000 AND			( ADJUST BEGINING OF BAD MEG )
		HERE FREEPTR !
		HERE - BLKSIZE !		( SIZE OF BLOCK IN BYTES )
		MINT ,					( END OF CHAIN = MINT )
	release super Method
	end colon Method

clear
	begin colon Method
	hold super Method
		 MINT FREEPTR !
	release super Method
	end colon Method
showfree
	begin colon Method
		." Show free list "
		DDUP
 hold super Method
		CR
		BEGIN
			FREEPTR @ MINT= NOT
		WHILE
			." Address - " FREEPTR @ U. SPACE
			." Size - " BLKSIZE @ U. CR
			FREEPTR @ MAKELOCAL
		REPEAT
		DDROP release super Method
	end colon Method
trace	( var --> )
	 begin colon Method
		." Show Allocated list " CR
		hold super Method
		CR
		BEGIN
			@ DUP MINT= NOT
		WHILE
			." Address - " DUP BPW+ U. SPACE
			." Size - " DUP BPW- @ [ BPW 2 * ] LITERAL - U. CR
		REPEAT
		DROP
		release super Method
	end colon Method
die
	begin code Method
	MINT
	DAP *LOAD 
	super Field SEMA ADC,
	0 STNL
	STOPP
	end code Method
end class Definition

FORTH DEFINITIONS

instance  MemAlloc_Class	MemAlloc
		release  MemAlloc
		4000 settimeout MemAlloc
		configure MemAlloc
showfree MemAlloc
10000 mode1 getmem MemAlloc DP !
showfree MemAlloc

: FREE showfree MemAlloc ;

: GETMEM1 mode1 getmem MemAlloc ;
' GETMEM1 *GETMEM1 !
RUNTIME DEFINITIONS

: COLD3
	MINT ANCHOR !
 	configure MemAlloc
	ANCHOR 10000 mode2 getmem MemAlloc
	DUP MINT= NOT IF
		DP !
	ELSE
		." MEMALLOC FAILED " 
	THEN
;
FORTH DEFINITIONS
 MINT METHTABPTR !
 MINT SYMTABPTR !
 MINT DP'INIT !

: PROGRAM ( allocate memory used for meth-table and H/C )
	OOPS MESSAGES FORTH
	METHTABPTR @
	MINT= IF
		1000 mode1 getmem MemAlloc
		DUP MINT= IF ABORT" MemAloc failed " 
		THEN
		METHTABPTR !
	ELSE
			 ." Method table already initialized " CR
	THEN
		DP'INIT @
	MINT= IF
		1000 mode1 getmem MemAlloc
		DUP MINT= IF ABORT" MemAloc failed " 
		THEN
		DP'INIT !
	ELSE
			 ." DP'INIT already initialized " CR
	THEN
		SYMTABPTR @
	MINT= IF
		1000 mode1 getmem MemAlloc
		DUP MINT= IF ABORT" MemAloc failed " 
		THEN
		SYMTABPTR !
	ELSE
			 ." SYMTABPTR already initialized " CR
	THEN
;

: END. ( release memory used for meth-table and H/C )
	SYMTABPTR @ DUP MINT= IF
			DROP
	ELSE
		mode1 freemem MemAlloc
	THEN
	METHTABPTR @ DUP MINT= IF
			DROP
	ELSE
		mode1 freemem MemAlloc
	THEN
		DP'INIT @ DUP MINT= IF
			DROP
	ELSE
		mode1 freemem MemAlloc
	THEN
	MINT METHTABPTR !
	MINT DP'INIT !
	MINT SYMTABPTR !
;
HIDE SYMTABPTR
HIDE METHTABPTR
HIDE DP'INIT

PROGRAM
MESSAGES DEFINITIONS
	MESSAGE new
	MESSAGE run
	MESSAGE kill
	MESSAGE hi
	MESSAGE stop
	MESSAGE forth
	MESSAGE word
	MESSAGE path
	MESSAGE memory
    MESSAGE offset
	MESSAGE channel
	MESSAGE time
	MESSAGE fixed
	MESSAGE variable
	MESSAGE delay
ASSEMBLER DEFINITIONS FORTH
( alt flags )
( bit 1 set - variable has value at runtime , clear - fixed value )
( bit 2 set - we wait for a time to elapse - value on stack at runtime )
( bit 4 set - we wait for a delay to elapse - either fixed or variable )
( SCRATCHPAD FORMAT CHAN/VAR/DELAY , CODESTRT , CODEEND , FLAG , . . . )
( WARNING DELAY ALT USES USER0 AT RUNTIME )
super Nil	( this is the ancestor to all objects + Classes )
( LOCAL WORDS )

: CHECKBYTE 4 PICK 5 = NOT IF ABORT" Checkbyte miss-match " THEN ;

: CALCADDR ( CHECKBYTE, &ALTSTRT,&SCRATCH,NO_OF_ALTS,INDEX -- ?? )
	  3 PICK SWAP [ BPW 4 * ] LITERAL * +
;

: SAVEHEREETC 	( CHECKBYTE, &ALTSTRT,&SCRATCH,NO_OF_ALTS,CHAN,FLAG, )
	>D >D 					( CHECKBYTE, &ALTSTRT,&SCRATCH,NO_OF_ALTS )
 	CHECKBYTE 	
	( calc pointer >R )
	DUP CALCADDR >R	 ( CHECKBYTE, &ALTSTRT,&SCRATCH,NO_OF_ALTS )
	( save channel/etc )
	D> I !
	( save flag in scratch )
	D> I [ 3 BPW * ] LITERAL + !
	( save here  )
	HERE R> BPW+ ! ( CHECKBYTE, &ALTSTRT,&SCRATCH,NO_OF_ALTS )
;

: SAVEENDETC ( CHECKBYTE, &ALTSTRT,&SCRATCH,NO_OF_ALTS )
    CHECKBYTE
	DUP CALCADDR [ 2 BPW * ] LITERAL + HERE SWAP !
	NOP NOP
	1+ 				( INC NO_OF_ALTS )
;

: GETFLAG ( CHECKBYTE,&ALTSTRT,&SCRATCH,NO_OF_ALTS,LOOPI --  )
 	CALCADDR [ 3 BPW * ] LITERAL + @
;

: C|T 	( CHECKBYTE ,&ALTSTRT,&SCRATCH,NO_OF_ALTS, LOOPI )
		( --  CHECKBYTE ,&ALTSTRT,&SCRATCH,NO_OF_ALTS )
		( generate code to load channel or time to areg )
	CALCADDR >R
	I [ 3 BPW * ] LITERAL + @	( GET FLAG )
    DUP 1 AND
	IF				( variable mode could be time channel or delay )
 		R> @
		LDC 0 LDNL
		4 AND IF	( user delay mode )
			LDTIMER ( calculate time for alt )
			SUM
		THEN
	ELSE			( fixed mode - could be delay or channel )
		R> SWAP >R
		@ ( both modes need this value )
		R>	4 AND 
		IF	( fixed delay mode )
			USER @ 8 AND NOT
				 IF ( ENABLE MODE )
						LDTIMER
						USER ^^ STL 
			THEN
			USER ^^ LDL
			ADC,
		ELSE	( fixed channel mode )
			LDC
		THEN
	THEN
	TRUE LDC
;
begin object Definition Alt
	begin
		begin colon Method ( CHECKBYTE ,&ALTSTRT,&SCRATCH,NO_OF_ALTS)
			5							( CHECKBYTE )
			HERE NOP NOP 	( save here reserve space for forward jump )
			100 mode1 getmem MemAlloc 	( GETMEM FOR SCRATCHPAD )
			0						  	( CNT )
		end colon Method
	end
	begin colon Method
		CHECKBYTE
		( FORWARD BRANCH FROM BEGINING OF ALT INTO THE GUTS OF ALT )
		3 PICK
		2 [ ' THEN , ]
		( Check for timer flag )
		2 PICK [ 3 BPW * ] LITERAL + USER !
		0 >D
		DUP 0 DO
			USER @ DUP @ D> OR >D
			[ 4 BPW * ] LITERAL + USER !
		LOOP
		D> DUP USER !
		6 AND IF ( TIMER )
			TALT
		ELSE ( NO TIMER )
			ALT
		THEN
		( GENERATE ENABLES )
		DUP 0
		 DO
			I C|T
			I GETFLAG 
			6 AND
			IF	( TIMER )
				ENBT
			ELSE
				ENBC
			THEN
		LOOP
		USER @
		6 AND IF ( TIMER )
			TALTWT
		ELSE ( NO TIMER )
			ALTWT
		THEN
	( GENERATE DISABLES )
		8 USER +!	( FLAG FOR TIMERSTUFF )
		DUP 0 DO
			I C|T
			I CALCADDR HERE SWAP !
			NOP NOP
			I GETFLAG 
			6 AND
			IF	( TIMER )
				DIST
			ELSE
				DISC
			THEN
		LOOP
		ALTEND
	( PATCH FORWARD JUMPS )
		DUP 0 DO
			I CALCADDR >R
			I [ BPW 2 * ] LITERAL + @ 	( CODE END )
			2 [ ' THEN , ]
			I BPW+ @				  	( CODE STRT )
			HERE -					  	( OFFSET FROM ALTEND TO CODE )
			DUP FF > IF LIMER THEN
			R> @					  	( ADDRESS OF LDC INST )
			HERE >R DP !				( MOVE BACK TO LDC )
			LDC
			R> DP !						( RESTORE DP )
		LOOP
		DROP DROP DROP DROP
	end colon Method
	channel
	begin sub Method
		fixed
		begin sub Method
			begin
				begin colon Method	( chan -- chan codest )
					0 SAVEHEREETC 			( start of code )
				end colon Method
			end
				begin colon Method ( chan codest -- chan codest codend flag )
 					SAVEENDETC
				end colon Method
		end sub Method
		variable
		begin sub Method
			begin
				begin colon Method	( chan -- chan codest )
					1 SAVEHEREETC	( )
				end colon Method
			end
				begin colon Method ( chan codest -- chan codest codend flag )
					SAVEENDETC 
				end colon Method
		end sub Method
	end sub Method
	time
	begin sub Method
		variable
		begin sub Method
			begin
				begin colon Method	( chan -- chan codest )
					3  SAVEHEREETC ( )
				end colon Method
			end
				begin colon Method ( chan codest -- chan codest codend flag )
					SAVEENDETC
				end colon Method
		end sub Method
	end sub Method
	delay
	begin sub Method
		variable
		begin sub Method
			begin
				begin colon Method	( chan -- chan codest )
					5 SAVEHEREETC	( pad where fixed time would go )
				end colon Method
			end
				begin colon Method ( chan codest -- chan codest codend flag )
					SAVEENDETC 
				end colon Method
		end sub Method
		fixed 
		begin sub Method
			begin
				begin colon Method	( chan -- chan codest )
					 4 SAVEHEREETC 			( start of code )
				end colon Method
			end
				begin colon Method ( chan codest -- chan codest codend flag )
					SAVEENDETC
				end colon Method
		end sub Method
	end sub Method
end object Definition

HIDE LIMER
RUNTIME
HEX

FORTH DEFINITIONS

HEX
super Nil
( allocate memory and setup new WS )

: SETUPWS	( MINT|FORTHCFA --> )
	>R
	2 WARMFLG !
	WSLEN 100 + 
mode1 getmem MemAlloc	( ALLOC WS WITH 100 BYTE IN FRONT )
	DUP MINT= IF ABORT" MemAlloc failed " THEN
	DUP 100 +							( MEM MEM+100 --> CLONE OLD WS THERE )
	WS SWAP WSLEN CMOVE					( MEM --> )
	DUP DUP MINT OVER !					( MEM MEM MEM+4 --> MANUALLY LINK TO ANCHOR )
	SWAP [ ANCHOR WS - 100 + ] LITERAL + !	( --> LINK TO NEW ANCHOR )
	DUP BPW+							( MEM MEM+4 --> )
	LINKINPTR @ OVER !					( MEM MEM++ --> STORE LINKIN )
	BPW+ LINKOUTPTR @ OVER !			( MEM MEM++ --> STORE LINKOUT )
	BPW+ OVER 100 + OVER	!			( MEM MEM++ --> STORE NEW WS )
	BPW+ R> SWAP !						( MEM MEM++ --> STORE EXEC ADDR )
	DUP 100 + 							( WS-100 WS --> )
	SWAP BPW+ OVER BPW+ !				( WS --> SETUP LOCAL 1 TO TABLE )
;
begin object Definition Process
( start a new instance of FORTH and execute addr|quit )
code
	begin sub Method
	hi
		 begin sub Method
		new
			begin code Method	( *STARTINST W )
				NEXT>A			( GET *STRTINST )
				TOP>A			( GET NEW:W )
				-1 STNL			( SET UP NEW:W-1 )
				TOP>A			( GET NEW:W AGAIN )
				RUNP
				SP2DROP
			end code Method
		end sub Method
	new begin code Method	( *STARTINST W )
			NEXT>A			( GET *STRTINST )
			TOP>A			( GET NEW:W )
			-1 STNL			( SET UP NEW:W-1 )
			TOP>A			( GET NEW:W AGAIN )
			LDPRI OR		( SET PRIORITY BIT SAME AS CURRENT )
			RUNP
			SP2DROP
		end code Method
	stop
		begin code Method	( *STARTINST W )
			STOPP
		end code Method
end sub Method
forth
	begin sub Method
	hi
	begin sub Method
		new
			begin colon Method			( EXEC|mint  --> )
				SETUPWS 			( WS-100 --> )
				[ ' WARM ] LITERAL SWAP new hi code self Method
			end colon Method
		run
			begin colon Method
				' new hi forth self Method 
			end colon Method
	end sub Method
		new
			begin colon Method		( EXEC|mint  --> )
				SETUPWS 			( WS-100 --> )
				[ ' WARM ] LITERAL SWAP
				new code self Method
			end colon Method
( start a new instance of FORTH at high priority and execute addr|quit )
		run
			begin colon Method
				' new forth self Method 
			end colon Method
		kill	
( kill the current instance of forth freeing it's memory etc )
HERE *DIE !
		begin colon Method	
			hold MemAlloc
			ANCHOR special freemem MemAlloc
			die MemAlloc
		end colon Method	
	end sub Method
end object Definition
RUNTIME DEFINITIONS

: [FORK] R> DUP @ new forth Process BPW+ >R ;

: [FORKHI] R> DUP @ new hi forth Process BPW+ >R ;
COMPILER DEFINITIONS VDROP

: FORK COMPILE [FORK] ;

: FORKHI COMPILE [FORKHI] ;
FORTH DEFINITIONS

: FORK
	run forth Process
;

: FORKHI
	run hi forth Process
;

RUNTIME DEFINITIONS

: ["]	( PUT ADDRESS OF LITERAL STRING TO TOP )
	R> DUP DUP C@ +  -4 AND 4+ >R ;
COMPILER DEFINITIONS

: "
	COMPILE ["]	( compile runtime code  )
	22 STRING
;

RUNTIME OOPS MESSAGES DEFINITIONS
( global messages )
( VDU OUTPUT MESSAGES )
1 GMESSAGE emit
2 GMESSAGE type
3 GMESSAGE cr
( KEYBOARD IO MESSAGES )
100 GMESSAGE getline
101 GMESSAGE key
102 GMESSAGE getnumber
103 GMESSAGE hit
( FILE IO MESSAGES )
1001 GMESSAGE	open
1002 GMESSAGE	close
1003 GMESSAGE	append
1004 GMESSAGE	read
1005 GMESSAGE	write
1006 GMESSAGE	eof
( MISC PARAMETERS )
1800 GMESSAGE  real32
1801 GMESSAGE  int32
( MISC MESSAGES )
2001 GMESSAGE   error

( local messages )
MESSAGE send
MESSAGE recieve
MESSAGE header
MESSAGE byte
MESSAGE message
MESSAGE nodata
MESSAGE nomsg
MESSAGE getmsg
MESSAGE tib
MESSAGE hookon
MESSAGE rewind

FORTH DEFINITIONS
VOCABULARY NETWORK UNLINKVOCAB
NETWORK DEFINITIONS
1 CONSTANT VDU
2 CONSTANT KBD
3 CONSTANT FSERVE
5A5A5AA5	CONSTANT SYNC

VARIABLE OUTTABLE OUTTABLE DP !
MINT DUP ,
BPW+ DUP ,
BPW+ DUP ,
BPW+ ,

: ADTONO
	0 			( LINKADDR CNT -- )
	BEGIN
		DUP 4 <
	WHILE
		OVER OVER ( LINKADDR CNT LINKADDR CNT -- )
		BPW * OUTTABLE + @ = IF SWAP DROP EXIT THEN
		1+
	REPEAT
ABORT" UNKNOWN LINK ADDRESS "
;
VARIABLE INTABLE INTABLE DP !
MINT 10 + DUP ,
BPW+ DUP ,
BPW+ DUP ,
BPW+ ,

( eventually we need a level of indirection for &VDU etc )
( so that they're pointers to the network paths )

VARIABLE &VDU &VDU DP !
VDU , ( PORT ie the port or pseudo port on the destination processor
1 C, ( SIZE ie number of nodes )
1 C, ( CURRENT NODE ie the next node the packet goes through a no. from 1 to SIZE )
0 C, ( LINKS ie a list of links numbered 0-3 which is SIZE long )
DPALIGN
VARIABLE &KBD &KBD DP !
KBD , ( PORT ie the port or pseudo port on the destination processor )
1 C, ( SIZE ie number of nodes )
1 C, ( CURRENT NODE ie the next node the packet goes through a no. from 1 to SIZE )
0 C, ( LINKS ie a list of links numbered 0-3 which is SIZE long )
DPALIGN
VARIABLE &FSERVE &FSERVE DP !
FSERVE ,
1 C, ( SIZE )
1 C, ( CURRENT NODE )
0 C, ( LINKS )
DPALIGN
( the packet format is as follows )
( SYNC 	REPLY 	DEST 	SIZE 	CURRENTNODE 	LINKS .. )
( 32	32	    32	    8	    8	            8... 	)
( SIZE2	MESS1	MESS2..	SIZE3	DATA ........ )
( 8	    16	    16	    32	    ?????? )
( where SYNC is the pattern 5A5A5AA5 )
( REPLY is the port [if any] in the sending processor where a reply )
(      packet is expected )
( DEST is a port in the destination processor of the process that will )
(      recieve it )
( SIZE is number of nodes )
( CURRENTNODE is the next node the packet goes through a no. from 1 to SIZE )
( LINKS is an array of links numbered 0-3 which is SIZE long )
(     the intial value of CURRENTNODE and the  order of links )
(     hasn't been decided yet; most likely CM will initially = SIZE )
(     and decrement as the packet passes each node and decrementing to zero )
(     indicates the packet has arrived; therefor the LINKS will be in )
(     reverse order ie the last link in the array will be the first used. )
(     The destination process can reverse the links to make the return path )

( SIZE2 is the number of messages in the message list )
( MESS1 etc an array of 16 bit message tokens as define by GMESSAGE )
( SIZE3 the length of the DATA field in bytes , is zero if no data )
( DATA the data field if present is an array of bytes of SIZE3 length )

super Nil

LATEST WS,VAR THEIRPORT ( these ws location are only to be used by the router)
MARKER WS,VAR OURPORT
LINE# WS,VAR NODE

: FINDSYNC	( LOOK FOR A55A5A5A SYNC PATERN )
BEGIN
	BEGIN
		LINKINPTR @ GETBYTE
	A5 = UNTIL
	LINKINPTR @ GETBYTE	5A =
	LINKINPTR @ GETBYTE	5A =
	LINKINPTR @ GETBYTE	5A =
	AND AND
UNTIL
;
begin object Definition Packet
recieve
begin sub Method
	header
		begin colon Method
( This method is used by the router process only THEIRPORT etc. alias to the )
( routers WS not the WS of the main forth system/s )
			FINDSYNC					( wait for sync )
			LINKINPTR @ >R 				( outaddr to R )
			I GETWORD THEIRPORT !		( get senders port )
			I GETWORD OURPORT !			( get our msg port )
			I GETBYTE PATHSIZE !		( get size of path )
			I GETBYTE NODE !			( get node ptr )
			R> TIB PATHSIZE @ GETBYTES	( get to router TIB path )
 			LINKINPTR @ OURPORT @ PUTWORD
		 	( send address of link to reciever process )
			OURPORT @ GETWORD DROP	( wait till reciever is finished )
	end colon Method
	nomsg 
		begin colon Method
			LINKINPTR @ GETBYTE DROP
	end colon Method
	getmsg
		begin colon Method
			LINKINPTR @ GETBYTE	( MSGCNT )
			DUP
			BEGIN
				DUP 
			WHILE
				LINKINPTR @ GET16 >M
				1-
			REPEAT
			DROP
	end colon Method
	byte 
		begin colon Method
			LINKINPTR @ GETWORD	DROP	( LENGTH OF DATA; WHICH IS ONE  )
			LINKINPTR @ GETBYTE			( GET CHAR )
	end colon Method
	word 
		begin colon Method
			LINKINPTR @ GETWORD	DROP	( LENGTH OF DATA; WHICH IS 4  )
			LINKINPTR @ GETWORD			( GET CHAR )
	end colon Method
	nodata 
		begin colon Method
			LINKINPTR @ GETWORD	DROP	( DROP LENGTH OF DATA; WHICH IS 0  )
	end colon Method
end sub Method

send 
begin sub Method
	header
		begin colon Method	( *PATH --> )
			DUP 6 + C@ 4 * OUTTABLE + @
			>R 
				SYNC I PUTWORD		( SEND SYNC )
				REPLYPORT I PUTWORD 		( SEND REPLY )
				DUP BPW+ C@ 6 + SWAP
				I PUTBYTES		( SEND DEST SIZE CNT + PATH )
			R> OUTLINK !
			MP @		( REMEMBER DEPTH OF MESS STACK )
		end colon Method
	message
		begin colon Method
			MP @ - 4 /		( DEPTH OF NEW MESSAGES )
			DUP OUTLINK @ PUTBYTE
			0 DO
				M> OUTLINK @ PUT16
			LOOP
		end colon Method
	byte 
		begin colon Method	( char --> )
			OUTLINK @ 1 OVER PUTWORD
			PUTBYTE
		end colon Method
	word 
		begin colon Method	( char --> )
			OUTLINK @ 4 OVER PUTWORD
			PUTWORD
		end colon Method
	type
		begin colon Method	( addr --> )
			DUP C@ DUP OUTLINK @ PUTWORD ( ADDR CNT --> )
			SWAP 1+ OUTLINK  @ PUTBYTES 	( EMPTY )
		end colon Method
	cr
		begin colon Method	( --> )
			>OUT C@ DUP 2+ OUTLINK @ >R I PUTWORD (  --> )
			TOB I PUTBYTES 	( )
			D I PUTBYTE
			A R> PUTBYTE
			0 >OUT !
		end colon Method
	nodata
		begin colon Method	( --> )
			0 OUTLINK @ PUTWORD
		end colon Method
	end sub Method
end object Definition
: CHECKFORERROR
	REPLYPORT GETWORD DROP	( LINK ADDR )
	getmsg recieve Packet	( any messages T/F)
		IF
			M> DROP ABORT" FILE ERROR "
		THEN
		nodata recieve Packet
	0 REPLYPORT PUTWORD		( RELEASE LINK )
;

: NETEMIT
	&VDU header send Packet
	emit message send Packet
	byte send Packet
	CHECKFORERROR
;
super Nil

: TAIL	message send Packet
	nodata send Packet
	REPLYPORT GETWORD	( LINK ADDR )
DROP
	nomsg recieve Packet	( DROP MSG CNT; WHICH IS ZERO )
	byte recieve Packet
	0 REPLYPORT PUTWORD		( RELEASE LINK )
;

: HEAD	&KBD header send Packet ;
begin object Definition Kbd
key
	begin colon Method
		HEAD
			key
		TAIL
	end colon Method
hit
	begin colon Method
		HEAD
			hit
		TAIL
	end colon Method
end object Definition

: NETKEY
  key Kbd
;

: KEYHIT
  NETWORKED @ IF
    hit Kbd
  ELSE
    FALSE
  THEN
;

super Nil


: OPENETC
			type send Packet 	( adr+cnt )
			REPLYPORT GETWORD DROP	( LINK ADDR )
			getmsg recieve Packet	( any messages )
				IF
					M> DROP FALSE
				ELSE
					word recieve Packet	TRUE
				THEN
			0 REPLYPORT PUTWORD		( RELEASE LINK )
;
begin object Definition File
open 
begin sub Method
	write
	begin colon Method	( *filename --- F | filepointer,T )
			&FSERVE header send Packet
			write open 
			message send Packet
			OPENETC
	end colon Method
	read
	begin colon Method
			&FSERVE header send Packet
			read open 
			message send Packet
			OPENETC
	end colon Method
	end sub Method
close
begin colon Method	( fp -- empty )
	&FSERVE header send Packet
	close
	message send Packet
	word send Packet
	CHECKFORERROR
end colon Method
read
begin colon Method			( fp length *data -- fp len2 )
	&FSERVE header send Packet
	read
	message send Packet
	OUTLINK @ >R			( fp length *data -- )
	8 I PUTWORD				( fp length *data -- SEND DATA LENGTH RQST )
	3 PICK I PUTWORD		( fp length *data -- SEND FP )
	SWAP R> PUTWORD			( fp *data -- SEND LEN )
	REPLYPORT GETWORD				( LINK ADDR )
	>R
	getmsg recieve Packet	( fp *data t/f -- )
	I GETWORD				( fp *data T/F size -- length OF DATA RETURNED )
	SWAP IF M> DROP ABORT" FILE ERROR" THEN		( drop msg )
	( fp *data size )
	SWAP OVER 
	R> ROT ROT GETBYTES
	0 REPLYPORT PUTWORD				( FP LEN2 --- RELEASE LINK )
end colon Method
write
begin colon Method			( fp length *data -- fp)
	&FSERVE header send Packet
	write
	message send Packet
	OUTLINK @ >R			( fp length *data -- )
	OVER 4+ I PUTWORD		( fp length *data -- SEND DATA length )
	3 PICK I PUTWORD		( fp length *data -- SEND FP )
	R> PUTBYTES
	CHECKFORERROR
end colon Method
word
begin sub Method
	write		( fp word -- fp )
		begin colon Method
		&FSERVE header send Packet
		write
		message send Packet
		OUTLINK @ >R
		8 I PUTWORD		( SEND DATA LEN FP + WORD = 4 + 4 = 8)
		OVER I PUTWORD	( SEND FP )
		R> PUTWORD		( SEND WORD )
		CHECKFORERROR
	end colon Method
end sub Method
byte
begin sub Method
	write		( byte fp -- fp )
		begin colon Method
		&FSERVE header send Packet
		write
		message send Packet
		OUTLINK @ >R
		5 I PUTWORD		( SEND DATA LEN FP + BYTE = 4 + 1 = 5)
		OVER I PUTWORD	( SEND FP )
		R> PUTBYTE	( SEND BYTE )
		CHECKFORERROR
	end colon Method
end sub Method
cr
begin colon Method	( fp )
		>OUT C@ 
		?DUP
		IF
			TOB ( fp length *data -- )
			write 	self Method	( fp )
		THEN
		A write byte 	self Method	( fp )
		0 >OUT !
end colon Method
tib
begin colon Method	( fp )
		CNT C@ 
		?DUP
		IF
			TIB ( fp length *data -- )
			write 	self Method	( fp )
		THEN
		A write byte 	self Method	( fp )
end colon Method
getline				( fp -- fp T/F { TRUE = EOF } )
	begin colon Method
		&FSERVE header send Packet
		getline
		message send Packet
		4 OUTLINK @ PUTWORD		( fp  -- SEND DATA LENGTH )
		DUP OUTLINK @ PUTWORD		( fp  -- SEND FP )
		REPLYPORT GETWORD				( LINK ADDR )
		>R
		getmsg recieve Packet		( fp t/f -- )
		I GETWORD			( LENGTH OF TEXT )
		CNT !
		R> TIB CNT @ GETBYTES
		0 >IN !
		20 TIB CNT @ + C!
		0 REPLYPORT PUTWORD				( RELEASE LINK )
		DUP IF M> DROP THEN		( drop msg )
	end colon Method
end object Definition
FORTH DEFINITIONS
super Nil

: SDASC
	OVER OVER SWAP
	OVER OVER -
	IF SPACE
		DO
			I C@ 
			DUP 20 < OVER 7A > OR
				IF DROP 2E THEN
					EMIT
		LOOP
	ELSE
		DROP DROP
THEN
;

: ID	( LFA --> )
	BPW+						( NFA --> )
	DUP @ 800000 AND
		IF 5E EMIT
		ELSE
			DUP @ 8000 AND
				IF 2A EMIT
				ELSE SPACE
				THEN
		THEN
	DUP C@ 7F AND			( NFA COUNT --> )
	DUP 8 > IF DROP 8 THEN	( ONLY DO 8 CHAR )
	SWAP 1+ OVER			( COUNT NFA+1 COUNT --> )
		0 DO
			DUP I + C@ 7F AND EMIT
		LOOP
	DROP SPACE					( COUNT --> )
	DUP 9 < IF
		8 SWAP - SPACES
	ELSE
	DROP
	THEN
;

: DUMPMEM
		DEPTH 2 < IF ABORT" Not enough items on stack " THEN
		OVER SWAP				( ADDR ADDR CNT )
		0 DO					( LOOP LEN TIMES )
			I 0F AND NOT
				IF
					SDASC
					CR DUP
					USER @ - U.
					SWAP DROP DUP
				THEN
			DUP C@ 2 U.R
			1+
			KEYHIT IF LEAVE THEN
		LOOP
		SDASC
		DROP DROP
		CR
;
begin object Definition List
word
	begin colon Method
		CR
		CONINDEX @ 1- BPW * CONARRAY + @ @ ( FIRST LFA --> )
		0 SWAP							( CNT LFA	--> )
		BEGIN
			DUP MINT= NOT
			KEYHIT NOT AND
		WHILE
			DUP U. DUP ID				( CNT LFA --> )
			SWAP 1+						( LFA CNT++ --> )
				DUP BPW = IF				( LFA CNT FLAG --> )
					CR DROP 0			( LFA 0 --> )
				THEN
				SWAP					( CNT LFA --> )
			@							( CNT NEXTLINK --> )
		REPEAT
		DROP
		DROP
		CR
	end colon Method
path
	begin colon Method
	CR ." Search path --> " CR
	CONINDEX @ 
		BEGIN
			DUP
		WHILE
			1- DUP BPW * CONARRAY +		( ADDRESS OF POINTER TO VOC VAR )
			@ [ BPW 2 * ] LITERAL + @						( CNTADDR  --> )
			DUP C@ OVER +				( CNTADDR ENDADDR --> )
				SWAP DO
					I 1+ C@ 7F AND EMIT	( TYPE STRING )
				LOOP
			CR 
		REPEAT
	DROP
	end colon Method
memory  ( start len -- )
	begin colon Method
       0 USER !
       DUMPMEM
	end colon Method
    offset
		  begin sub Method
           memory ( start len offset )
              begin colon Method
                  USER !
                  DUMPMEM
              end colon Method
		  end sub Method
end object Definition

: VLIST word List ;

: PATH path List ;

: DUMP memory List ;

super Nil
begin class Definition Dynamic_Class
	rewind		( *firstfield --- *startobj )
	begin colon Method
		[ 3 BPW * ] LITERAL -
	end colon Method
end class Definition

super Dynamic_Class
var Ptr PREVIOUS
var Int FP
var Int INDEX
var Int LIMIT
var Int EOF
var Int CRFLAG
BUFFSIZE array Byte BUFFER

: GETBLK    ( --- SIZE )
	BUFFER INDEX !
	FP @ BUFFSIZE BUFFER
	read File				( PF SIZE -- )
	DUP BUFFER + LIMIT !
	DUP 0< IF ABORT" FILE ERROR " THEN
	BUFFSIZE = NOT EOF !
	DROP
;
begin class Definition DiskBuff_Class
hookon
	begin colon Method ( fp -- )
		FP !				( SAVE FP )
		0 INDEX !
		BLK @ PREVIOUS !
		PREVIOUS rewind super Method	( get pointer to this objects start )
		BLK !
		GETBLK ( NOT IF ABORT" EMPTY FILE !!!" THEN
	end colon Method
close
	begin colon Method ( -- )
		FP @ close File		( close the file )
		PREVIOUS @ BLK !	( unlink this buffer )
		PREVIOUS  rewind super Method
		mode1 freemem MemAlloc
	end colon Method
( GETLINES A BIT MESSY BECAUSE IT MUST COPE WITH LF,CR OR CRLF )
getline
	begin code Method ( -- )
		0 LDC >IN ^^ STL
		0 LDC CRFLAG FIELDSAVE			( CLEAR CR FLAG )
		TIB	^^ LDLP			( @TIB )
		CNT ^^ STL			( @TIB TO CNT )
		BEGIN
			INDEX FIELDLOAD 		( GET INDEX )
			LIMIT FIELDLOAD 		( GET LIMIT )
			DIFF
			0= IF
				OUTLINE
				EOF @ IF				( TIB+ -- END OF FILE EXIT )
                    close self Method
                    20 CNT @ C!
                    CNT @ TIB - CNT !
                    EXIT
				THEN
				GETBLK
				INLINE
		  ELSE
			INDEX FIELDLOAD LB				( TIB+ CHAR -- GETBYTE )
			USER ^^ STL						( SAVE IN USER FOR NOW )
			USER ^^ LDL
			A EQC							( IS LF FOUND )
			IF
					INDEX FIELDLOAD 	( ADVANCE TO NEXT CHAR )
					1 ADC,
					INDEX FIELDSAVE					( INC INDEX )
			THEN
			CRFLAG FIELDLOAD
			USER ^^ LDL A EQC
			OR					( IF IT WAS CR OR IS LF EXIT )
			IF
	 			20 LDC CNT ^^ LDL SB	( SAVE IN TIB )
				CNT ^^ LDL				( GET TIB+ )
				TIB ^^ LDLP				( GET BEGINING OF TIB )
				DIFF
				CNT ^^ STL
				DAP ++W
				RTNXT ^^ LDL GCALL 	( EXIT
			THEN
			INDEX FIELDLOAD
			1 ADC,
			INDEX FIELDSAVE						( INC INDEX )
			USER ^^ LDL							( GET IT BACK FOR COMPARE )
			D EQC IF					( IS IT CR )
				1 LDC CRFLAG FIELDSAVE	( MARK CR FOUND )
			ELSE
				20 LDC GT
				NOT IF								(  CONTROL CHAR ? )
					USER ^^ LDL						( GET IT BACK FOR COMPARE )
					9 EQC IF						( IS IT TAB )
						 20 LDC USER ^^ STL 		( DROP CONVERT TAB TO SPACE )
					THEN
				THEN
	 		USER ^^ LDL CNT ^^ LDL SB			    ( SAVE CHAR )
			CNT ++B									( INC @TIB )
			THEN
          THEN
		AGAIN
	end code Method
end class Definition

( MINT BLK ! ECHO ON
." GETNUM " CR
super Nil
begin object Definition GetNumber
	real32
	begin colon Method
		&KBD header send Packet
			  real32 getnumber
		message send Packet
		nodata send Packet
		REPLYPORT GETWORD								( LINK ADDR )
		DROP
		nomsg recieve Packet							( DROP MSG CNT; WHICH IS ZERO )
		word recieve Packet
		0 REPLYPORT PUTWORD							( RELEASE LINK )
	end colon Method
	int32
	begin colon Method
		&KBD header send Packet
			  int32 getnumber
		message send Packet
		nodata send Packet
		REPLYPORT GETWORD								( LINK ADDR )
		DROP
		nomsg recieve Packet							( DROP MSG CNT; WHICH IS ZERO )
		word recieve Packet
		0 REPLYPORT PUTWORD							( RELEASE LINK )
	end colon Method
end object Definition
	." END GETNUM " CR

: NETCR
	CAPFP @ MINT= NOT IF
		>OUT C@
		CAPFP @ cr File DROP
		>OUT C!
	THEN
	STDOUTFP @ MINT= NOT IF
		STDOUTFP @ cr File DROP
	ELSE
		>OUT C@
		IF
			&VDU header send Packet
			type message send Packet
			cr send Packet
			CHECKFORERROR
		THEN
	THEN
;

: NETGETLINE
		&KBD header send Packet
		getline
 		message send Packet
		nodata send Packet
		REPLYPORT GETWORD				( LINK ADDR )
		>R
		nomsg recieve Packet
		I GETWORD						( LENGTH OF TEXT )
		CNT !
		R> TIB CNT @ GETBYTES
		20 TIB CNT @ + C!
		0 >IN !
		0 REPLYPORT PUTWORD			( RELEASE LINK )
	CAPFP @ MINT= NOT IF
		CAPFP @ tib File DROP		( SEND INPUT TEXT TO CAPTURE FILE )
	THEN
	STDOUTFP @ MINT= NOT IF
		STDOUTFP @ tib File DROP	( SEND INPUT TEXT TO STD FILE )
	THEN
;

: FILEGETLINE
	BLK @ MINT= 
	IF
		 [ ' NETGETLINE ] LITERAL *GETLINE !
		ECHO ON
	ELSE
		BLK @
		getline 	
		method dynamic DiskBuff_Class
		ECHO @
		IF
			CNT @ IF
				CNT @ 0 DO I TIB + C@ EMIT LOOP CR
			THEN
		THEN
	THEN
	1 LINE# +!
;

VOCABULARY ROUTER UNLINKVOCAB
ROUTER DEFINITIONS

: ROUTE
BEGIN
 	header recieve Packet
AGAIN
;
NETWORK DEFINITIONS

: ON-NET
	TRUE NETWORKED !
 	[ ' NETCR ] LITERAL *CR !
	[ ' NETGETLINE ] LITERAL *GETLINE !	
	[ ' NETKEY ] LITERAL *KEY !
	LINKOUTPTR @ ADTONO DUP DUP
	&VDU 6 + C!
	&KBD 6 + C!
	&FSERVE 6 + C!
 	FORK ROUTE
;

: OFF-NET
	FALSE NETWORKED !
	[ ' LOCALCR ] LITERAL *CR !
	[ ' LOCGETLINE ] LITERAL *GETLINE !
	[ ' LOCALKEY ] LITERAL *KEY !
;
FORTH DEFINITIONS

: COLD4
	BEGIN
		LOCALKEY
		DUP D = IF COLD3 OFF-NET showfree MemAlloc EXIT THEN
		NOT IF
			COLD3
			ON-NET
			showfree MemAlloc
			FALSE WARMFLG !
			EXIT
		THEN
	AGAIN
;

: SAVEBOOT
 FALSE WARMFLG ! 
 " BOOTS\BOOTTRANS.BIN" write open File
	IF
." Writing Boot " CR
		BOOTLENGTH @  
		write byte File
		BOOTLENGTH @ BOOTSTRAP
		write File
." Writing Main " CR
		WS
		write word File
		HERE WS -
		write word File
		STARTUPADDRESS @
		write word File
		HERE WS - WS
		write File
	 	close File
	ELSE
		." FILE CREATION FAILED "
	THEN
;

: GETNAME
	20 WORD DUP
 	C@ NOT IF
	DROP ." Filename Please -" CR GETLINE 20 WORD
	THEN
;

: CAPTURE
	CAPFP @ MINT= IF
		GETNAME
		write open File
		IF
			CAPFP !
		ELSE
			 ABORT" CAN'T OPEN FILE "
		THEN
	ELSE
		CAPFP @ close File
		MINT CAPFP !
		." Capture file closed " CR
	THEN
;

: STDOUT
	STDOUTFP @ MINT= IF
		GETNAME
		write open File
		IF
			STDOUTFP !
		ELSE
			 ABORT" CAN'T OPEN FILE "
		THEN
	ELSE
		STDOUTFP @ close File
		MINT STDOUTFP !
		." Capture file closed " CR
	THEN
;

: ABORT2
NETWORKED @ IF
	STDOUTFP @ MINT= NOT IF STDOUTFP @ close File MINT STDOUTFP ! THEN
	CAPFP @ MINT= NOT IF CAPFP @ close File MINT CAPFP ! THEN
	BEGIN
		BLK @ MINT= NOT
	WHILE
		BLK @ 
		close 	
		method dynamic DiskBuff_Class
	REPEAT
	END.
	THEN
ABORT1
;
' ABORT2 *ABORT !

: INCLUDE
	GETNAME
	read open File
	IF
	ECHO OFF 1 LINE# !
	instance dynamic DiskBuff_Class
	hookon
	method dynamic DiskBuff_Class
	[ ' FILEGETLINE ] LITERAL *GETLINE !
	ELSE
		 ABORT" CAN'T OPEN FILE "
	THEN
;

: .MSG
BEGIN
	MP @ MPINIT = NOT
WHILE
	M> MSGTYPE CR
REPEAT
;
COMPILER DEFINITIONS
ALIAS ENDIF THEN
VDROP
ASSEMBLER DEFINITIONS
ALIAS ENDIF THEN
FORTH DEFINITIONS
REMEMBER EMPTY
' EMPTY *EMPTY !
GETTIMER 80000048 @ - DECIMAL 15625 /
 CR ." COMPILE TIME = " . ."  SECONDS" HEX CR
' COLD4 *COLD !
HIDE COLD
HIDE COLD3
HIDE COLD4
HIDE SAVEMODE
END.
ECHO ON	MINT BLK ! ( FINIS )
ON-NET

