[BACK]Return to prim.fs CVS log [TXT] [DIR] Up to [gforth] / gforth / arch / misc
File:  [gforth] / gforth / arch / misc / prim.fs
Revision 1.13: download - view: text, annotated - select for diffs
Mon Aug 18 19:29:15 2003 UTC (20 years, 8 months ago) by pazsan
Branches: MAIN
CVS tags: v0-6-2, HEAD
Further fixes for Gforth EC



0 [IF]
Ideas/Todo


[THEN]

UNLOCK
>ENVIRON
\ true SetValue PrimTrace

LOCK

UNLOCK
also assembler definitions

X has? PrimTrace [IF]
: dout PC+6 X , accu X ,
       *accu X , txd X ,
       PC+4 X , jmp X ,
       X , 0 X , ;
[ELSE]
: dout drop ;
[THEN]

LOCK

\ pie primitives

$20 allot

Label start	ahere 2 + , jmp ,
Label "IntoForth" 4711 ,

Label RP'       0 ,
Label SP'       0 ,
Label UP'       0 ,
Label IP'       0 ,

Label #0	0 ,
Label #1	1 ,
Label #2	2 ,
Label #4	4 ,
Label #FF	$FF ,
Label #$8000	$8000 ,
Label #-1	-1 ,
Label "Next"	1802 ,
Label "Next1"	1802 ,
Label ""Next""  "Next" ,
End-Label

\ The virtual machine registers an data (stacks) go
\ to a seperate memory region (hopefully ram)

\ UNLOCK
\ current-region vm-memory activate ( saved-region )
\ LOCK

Label RP	0 ,
Label SP	0 ,
Label UP	0 ,
Label IP	0 ,
Label W		0 ,
Label t0	0 ,
Label t1	0 ,
Label t2	0 ,
Label t3	0 ,
Label srcx	0 ,
Label dstx	0 ,
                "Next" , jmp ,
Label data-stack     50 cells allot
Label data-stack-top 2 cells allot
Label return-stack     50 cells allot
Label return-stack-top 2 cells allot

End-Label

\ UNLOCK
\ ( saved-region ) activate
\ LOCK

\ Up to here it's self modified
Label IntoForth 
                \ Transfer VM registers initial values
                RP' , RP ,
                SP' , SP ,
                IP' , IP ,
                UP' , UP , \ useless since UP is initialized by gforth boot
                ""Next"" , dstx 1 + ,
                #0 , dstx 2 + ,

Label Next	#0 , add ,  \ clear carry
		IP , shr ,
		sym Next
		*accu , W ,
		#1 , add ,
		accu , add ,
		accu , IP ,
Label Next1	W , shr ,
		*accu , shr ,
		accu , jmp ,

Label "xmov"	srcx ,
End-Label

IntoForth "IntoForth" 2* !
Next "Next" 2* !
Next1 "Next1" 2* !

has? PrimTrace [IF]
Label "0"	'< ,
Label "1"	'1 ,
Label "2"	'2 ,
Label "3"	'3 ,
Label "4"	'4 ,
Label "5"	'5 ,
Label "6"	'6 ,
Label "A"	'A ,
Label "B"	'B ,
Label "C"	'C ,
Label "D"	'D ,
Label "E"	'E ,
Label "F"	'> ,
Label "?"	'? ,
Label "+"	'+ ,
Label "/"	'/ ,
Label "H"	'H ,
Label "I"	'I ,
Label "J"	'J ,
Label "K"	'K ,
Label "L"	'L ,
Label "M"	'M ,
Label "N"	'N ,
Label "O"	'O ,
Label "P"	'P ,
Label "Q"	'Q ,
Label "R"	'R ,
Label "S"	'S ,
Label "T"	'T ,
Label "#"	'# ,
End-Label
[THEN]


Code: :docol	
                ': dout
		RP , accu ,
		#1 , sub ,
		accu , RP ,
		IP , *accu ,
		W , accu ,
		#4 , add ,
		accu , IP ,
		"Next" , jmp ,
end-code

Code: :docon	
                '1 dout
		#0 , add ,
		W , shr ,
		#2 , add ,
		*accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code: :dovar
                '2 dout
		W , accu ,
		#4 , add ,
		accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code: :douser	
                '3 dout
		#0 , add ,
		W , shr ,
		#2 , add ,
		*accu , accu ,
		UP , add ,
		accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code: :dodefer	
                '4 dout
		#0 , add ,
		W , shr ,
		#2 , add ,
		*accu , W ,
		"Next1" , jmp ,
end-code

Code: :dofield
                '5 dout
		#0 , add ,
		W , shr ,
		#2 , add ,
		*accu , accu ,
		accu , t0 ,
		SP , accu ,
		*accu , accu ,
		t0 , add ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code: :dodoes
                '6 dout
		RP , accu ,
		#1 , sub ,
		accu , RP ,
		IP , *accu ,
		W , accu ,
		#4 , add ,
		accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		t0 , accu ,
		#2 , sub ,
		#0 , add ,
		accu , shr ,
		*accu , IP ,
		"Next" , jmp ,
end-code

Code: :doesjump
end-code

Code execute
                'E dout
		SP , accu ,
		*accu , W ,
		#1 , add ,
		accu , SP ,
		"Next1" , jmp ,
end-code

Code ;s
                '; dout
		RP , accu ,
		#1 , add ,
		accu , RP ,
		#1 , sub ,
		*accu , IP ,
		"Next" , jmp ,
end-code

Code !
                '! dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		*accu , t1 ,
		#1 , add ,
		accu , SP ,
		t0 , shr ,
		t1 , *accu ,
		"Next" , jmp ,
end-code

Code @
                '@ dout
		#0 , add ,
		SP , accu ,
		*accu , shr ,
		*accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code ?branch
                '? dout
		#0 , add ,
		IP , shr ,
		accu , t0 ,
		#1 , add ,
		accu , add ,
		accu , IP ,
                SP , accu ,
                *accu , t1 ,
		#1 , add ,
		accu , SP ,
                t1 , accu ,
		pc+4 , jz ,
		"Next" , jmp ,
                '~ dout
		t0 , accu ,
		*accu , IP ,
		"Next" , jmp ,
end-code

Code branch
                'b dout
		#0 , add ,
		IP , shr ,
		*accu , IP ,
		"Next" , jmp ,
end-code

Code (loop)	
                'l dout
		#0 , add ,
		IP , shr ,
		accu , t0 ,
		#1 , add ,
		accu , add ,
                accu , IP ,
    
		RP , accu ,
		*accu , t2 ,
		#1 , add ,
		*accu , t3 ,
		t2 , accu ,
		#1 , add ,
		accu , t1 ,
		RP , accu ,
		t1 , *accu ,
		t1 , accu ,
		t3 , sub ,
		"Next" , jz ,
		t0 , accu ,
		*accu , IP ,
		"Next" , jmp ,
end-code
		
Code xor
                'x dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		*accu , accu ,
		t0 , xor ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code or	
                'o dout	
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		*accu , accu ,
		t0 , or ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code and
                'a dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		*accu , accu ,
		t0 , and ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code +		
                '+ dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		*accu , accu ,
		t0 , add ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code -		
                '- dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		*accu , accu ,
		t0 , sub ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code 2/		
                '/ dout
		#0 , add ,
		SP , accu ,
		*accu , accu ,
		PC+6 , js ,
		accu , shr ,
		PC+6 , jmp ,
		accu , shr ,
		#$8000 , or ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code 0=		
                '° dout
		SP , accu ,
		*accu , accu ,
		ZF , accu ,
		#1 , xor ,
		#1 , sub ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code 0<>	
                '% dout
		SP , accu ,
		*accu , accu ,
		ZF , accu ,
		#1 , sub ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code =		
                '= dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		*accu , accu ,
		t0 , sub ,
		ZF , accu ,
		#1 , xor ,
		#1 , sub ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code u<		
                '< dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		*accu , accu ,
		t0 , sub ,
		CF , accu ,
		#1 , xor ,
		#1 , sub ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code 1+		
                'p dout
		SP , accu ,
		*accu , accu ,
		#1 , add ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code cell+	
                'P dout
		SP , accu ,
		*accu , accu ,
		#2 , add ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code 8<<	
                '{ dout
		#0 , add ,
		SP , accu ,
		*accu , accu ,
		accu , add ,
		accu , add ,
		accu , add ,
		accu , add ,
		accu , add ,
		accu , add ,
		accu , add ,
		accu , add ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code 8>>	
                '{ dout
		#0 , add ,
		SP , accu ,
Label c-even@	*accu , shr ,
		accu , shr ,
		accu , shr ,
		accu , shr ,
		accu , shr ,
		accu , shr ,
		accu , shr ,
		accu , shr ,
		#FF , and ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
Label "c-even@"	c-even@ ,
end-code

Code c@		
                'c dout
		#0 , add ,
		SP , accu ,
		*accu , shr ,
		PC+4 , jc ,
		"c-even@" , jmp ,
		*accu , accu ,
		#FF , and ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code 2*		
                '* dout
		SP , accu ,
		*accu , accu ,
		accu , add ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code >r		
                'R dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		RP , accu ,
		#1 , sub ,
		accu , RP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code r>		
                'r dout
		RP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , RP ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code sp@	
                's dout
		SP , accu ,
		accu , add ,
		accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code sp!	
                'S dout
		#0 , add ,
		SP , accu ,
		*accu , shr ,
		accu , SP ,
		"Next" , jmp ,
end-code

Code rp@	
		RP , accu ,
		accu , add ,
		accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code rp!	sym rp!
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		accu , SP ,
		#0 , add ,
		t0 , shr ,
		accu , RP ,
		"Next" , jmp ,
end-code

Code drop
                'd dout	
		SP , accu ,
		#1 , add ,
		accu , SP ,
		"Next" , jmp ,
end-code

Code lit	
                '# dout
		IP , shr ,
		*accu , t0 ,
		#1 , add ,
		accu , add ,
		accu , IP ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code dup	
                'u dout
		SP , accu ,
		*accu , t0 ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code r@		
                'I dout
		RP , accu ,
		*accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code over	
                'v dout
		SP , accu ,
		#1 , add ,
		*accu , t0 ,
		#2 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code swap	
                'w dout
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		*accu , t1 ,
		t0 , *accu ,
		#1 , sub ,
		t1 , *accu ,
		"Next" , jmp ,
end-code

Code d+		
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		*accu , t1 ,
		#1 , add ,
		*accu , t2 ,
		accu , SP ,
		#1 , add ,
		*accu , accu ,
		t1 , add ,
		accu , t1 ,
		CF , accu ,
		t2 , add ,
		t0 , add ,
		accu , t0 ,
		SP , accu ,
		t0 , *accu ,
		#1 , add ,
		t1 , *accu ,
		"Next" , jmp ,
end-code

Label cf1	0 ,
End-Label
Code d2*+	sym d2*+
		SP , accu ,
Label >d2*+	*accu , t0 ,
		#1 , add ,
		*accu , t1 ,
		#1 , add ,
		*accu , t2 ,
		accu , t3 ,
		t0 , accu ,
		t2 , add ,
		t2 , add ,
		accu , t2 ,
		CF , accu ,
		t1 , add ,
		t1 , add ,
		accu , t0 ,
		t1 , accu ,
		#$8000 , and ,
		accu , t1 ,
		t3 , accu ,
		t2 , *accu ,
		#1 , sub ,
		t0 , *accu ,
		#1 , sub ,
		t1 , *accu ,
		"Next" , jmp ,
end-code

Label "d2*+"	>d2*+ ,
End-Label
Code /modstep ( ud c R: u -- ud-?u 0/1 )
		sym /modstep
		SP , accu ,
		*accu , t0 ,
		#1 , add ,
		*accu , t1 ,
		#1 , add ,
		*accu , t2 ,
		t2 , accu ,
		t0 , sub ,
		accu , t0 ,
		CF , accu ,
		t1 , or ,
		PC+6 , JZ ,
		#0 , accu ,
		PC+6 , jmp ,
		t0 , t2 ,
		#1 , accu ,
		accu , t0 ,
		SP , accu ,
		#1 , add ,
		t0 , *accu ,
		#1 , add ,
		t2 , *accu ,
		#1 , sub ,
		"d2*+" , jmp ,
end-code

Code (key)      
		SP , accu ,
		#1 , sub ,
		accu , SP ,
                rxd , *accu ,
		"Next" , jmp ,
end-code

Code (key?)      
                rx? , accu ,
		ZF , accu ,
		#1 , sub ,
		accu , t0 ,
		SP , accu ,
		#1 , sub ,
		accu , SP ,
		t0 , *accu ,
		"Next" , jmp ,
end-code

Code (emit)      
		SP , accu ,
                *accu , txd ,
		#1 , add ,
		accu , SP ,
		"Next" , jmp ,
end-code
		
UP 2* Constant UP

: up@ up @ ;
: up! up ! ;

\ include ./key.fs
include ./optcmove.fs

: (bye) 0 execute ;
: float+ 8 + ;
: finish-code ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>