\ r8c/m16c primitives \ Copyright (C) 2006,2007 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License \ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, \ but WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License \ along with this program. If not, see http://www.gnu.org/licenses/. \ * Register using for r8c \ Renesas Forth used for \ R0 TOS oberstes Stackelement \ R3 RP Returnstack Pointer \ SP SP Stack Pointer \ A1 IP Instruction Pointer \ A0 W Arbeitsregister \ \ * Memory ( use only one 64K-Page ): TBD \ ************************************************************** start-macros \ register definition ' R0L Alias tos.b \ hfs wichtig, damit der erste Befehl richtig compiliert wird reset \ hfs \ system depending macros : next1, [w] , r1 mov.w:g r3r1 jmpi.a ; : next, [ip] , w mov.w:g # 2 , ip add.w:q next1, ; \ note that this is really for 8086 and 286, and _not_ intented to run \ fast on a Pentium (Pro). These old chips load their code from real RAM \ and do it slow, anyway. \ If you really want to have a fast 16 bit Forth on modern processors, \ redefine it as \ : next, [ip] w mov, 2 # ip add, [w] jmp, ; end-macros unlock $0000 $FFFF region address-space $C000 $4000 region rom-dictionary $0400 $0400 region ram-dictionary .regions setup-target lock \ ============================================================== \ rom starts with jump to GFORTH-kernel (must be at $0000 !!!) \ ============================================================== Label into-forth # $ffff , ip mov.w:g \ ip will be patched # $0780 , sp ldc \ sp at $0600...$0700 # $0800 , rp mov.w:g \ rp at $0780...$0800 # $C084 , intbl ldc # $0F , $E3 mov.b:g # $0F , $E1 mov.b:g Label mem-init $01 , $0A bset:g $00 , $05 bset:g \ open data RAM $01 , $0A bclr:g Label clock-init \ default is 125kHz/8 $00 , $0A bset:g # $2808 , $06 mov.w:g AHEAD THEN 2 , $0C bclr:g # $00 , $08 mov.b:g \ set to 20MHz $00 , $0A bclr:g Label uart-init # $27 , $B0 mov.b:g \ hfs \ # $8105 , $A8 mov.w:g \ ser1: 9600 baud, 8N1 \ hfs \ # $2005 , $A8 mov.w:g \ ser1: 38k4 baud, 8N1 \ hfs # $0500 , $AC mov.w:g \ hfs I fset next, End-Label \ ============================================================== \ GFORTH minimal primitive set \ ============================================================== \ inner interpreter align Code: :docol \ ': dout, \ only for debugging # -2 , rp add.w:q w , r1 mov.w:g rp , w mov.w:g ip , [w] mov.w:g # 4 , r1 add.w:q r1 , ip mov.w:g next, End-Code align Code: :docon \ '2 dout, \ only for debugging tos push.w:g 4 [w] , tos mov.w:g next, End-Code align Code: :dovalue \ '2 dout, \ only for debugging tos push.w:g 4 [w] , w mov.w:g [w] , tos mov.w:g next, End-Code align Code: :dofield 4 [w] , tos add.w:g next, end-code align Code: :dodefer \ # $05 , $E1 mov.b:g 4 [w] , w mov.w:g [w] , w mov.w:g next1, End-Code align Code: :dodoes ( -- pfa ) \ get pfa and execute DOES> part \ '6 dout, \ only for debugging \ # $06 , $E1 mov.b:g tos push.w:g w , tos mov.w:g # 4 , tos add.w:q # -2 , rp add.w:q 2 [w] , r1 mov.w:g rp , w mov.w:g ip , [w] mov.w:g r1 , ip mov.w:g next, \ execute does> part End-Code $FF $C0FE here - tcallot Code: :dovar \ '2 dout, \ only for debugging tos push.w:g # 4 , w add.w:q w , tos mov.w:g next, End-Code \ program flow Code ;s ( -- ) \ exit colon definition \ '; dout, \ only for debugging rp , w mov.w:g # 2 , rp add.w:q [w] , ip mov.w:g next, End-Code Code execute ( xt -- ) \ execute colon definition tos , w mov.w:g \ copy tos to w tos pop.w:g \ get new tos next1, End-Code Code perform ( xt -- ) \ execute colon definition tos , w mov.w:g \ copy tos to w tos pop.w:g \ get new tos [w] , w mov.w:g next1, End-Code Code ?branch ( f -- ) \ jump on f=0 # 2 , ip add.w:q tos , tos tst.w 0= IF -2 [ip] , ip mov.w:g THEN tos pop.w:g next, End-Code Code (for) ( n -- r:0 r:n ) # -4 , rp add.w:q rp , w mov.w:g r3 , 2 [w] mov.w:g tos , [w] mov.w:g tos pop.w:g next, End-Code Code (?do) ( n -- r:0 r:n ) # 2 , ip add.w:q # -4 , rp add.w:q rp , w mov.w:g tos , [w] mov.w:g r1 pop.w:g r1 , 2 [w] mov.w:g tos pop.w:g [w] , r1 sub.w:g 0= IF -2 [ip] , ip mov.w:g THEN next, End-Code Code (do) ( n -- r:0 r:n ) # -4 , rp add.w:q rp , w mov.w:g tos , [w] mov.w:g tos pop.w:g tos , 2 [w] mov.w:g tos pop.w:g next, End-Code Code (next) ( -- ) # 2 , ip add.w:q rp , w mov.w:g [w] , r1 mov.w:g # -1 , r1 add.w:q r1 , [w] mov.w:g u>= IF -2 [ip] , ip mov.w:g THEN next, End-Code Code (loop) ( -- ) # 2 , ip add.w:q rp , w mov.w:g [w] , r1 mov.w:g # 1 , r1 add.w:q r1 , [w] mov.w:g 2 [w] , r1 sub.w:g 0<> IF -2 [ip] , ip mov.w:g THEN next, End-Code Code (+loop) ( n -- ) # 2 , ip add.w:q rp , w mov.w:g [w] , r1 mov.w:g 2 [w] , r1 sub.w:g # $8000 , r1 xor.w tos , r1 add.w:g no IF -2 [ip] , ip mov.w:g THEN tos , [w] add.w:g tos pop.w:g next, End-Code \ memory access Code @ ( addr -- n ) \ read cell tos , w mov.w:g [w] , tos mov.w:g next, End-Code Code ! ( n addr -- ) \ write cell tos , w mov.w:g tos pop.w:g tos , [w] mov.w:g tos pop.w:g next, End-Code Code +! ( n addr -- ) \ write cell tos , w mov.w:g tos pop.w:g tos , [w] add.w:g tos pop.w:g next, End-Code Code c@ ( addr -- uc ) \ read cell tos , w mov.w:g tos , tos xor.w [w] , tos.b mov.b:g next, End-Code Code count ( addr -- addr+1 uc ) \ read cell tos , w mov.w:g tos , tos xor.w [w] , tos.b mov.b:g # 1 , w add.w:q w push.w:g next, End-Code Code c! ( n addr -- ) \ write cell tos , w mov.w:g tos pop.w:g tos.b , [w] mov.b:g tos pop.w:g next, End-Code \ arithmetic and logic Code + ( n1 n2 -- n3 ) \ addition r1 pop.w:g r1 , tos add.w:g next, End-Code Code 2* ( n1 n2 -- n3 ) \ addition tos , tos add.w:g next, End-Code Code - ( n1 n2 -- n3 ) \ addition r1 pop.w:g tos , r1 sub.w:g r1 , tos mov.w:g next, End-Code Code negate ( n1 -- n2 ) tos neg.w next, End-Code Code invert ( n1 -- n2 ) tos not.w:g next, End-Code Code 1+ ( n1 n2 -- n3 ) \ addition # 1 , tos add.w:g next, End-Code Code 1- ( n1 n2 -- n3 ) \ addition # -1 , tos add.w:g next, End-Code Code cell+ ( n1 n2 -- n3 ) \ addition # 2 , tos add.w:g next, End-Code Code and ( n1 n2 -- n3 ) \ addition r1 pop.w:g r1 , tos and.w:g next, End-Code Code or ( n1 n2 -- n3 ) \ addition r1 pop.w:g r1 , tos or.w:g next, End-Code Code xor ( n1 n2 -- n3 ) \ addition r1 pop.w:g r1 , tos xor.w next, End-Code \ moving datas between stacks Code r> ( -- n ; R: n -- ) tos push.w:g rp , w mov.w:g [w] , tos mov.w:g # 2 , rp add.w:q \ ? hfs next, End-Code Code i ( -- n ; R: n -- ) tos push.w:g rp , w mov.w:g [w] , tos mov.w:g next, End-Code Code i' ( -- n ; R: n -- ) tos push.w:g rp , w mov.w:g 2 [w] , tos mov.w:g next, End-Code Code j ( -- n ; R: n -- ) tos push.w:g rp , w mov.w:g 4 [w] , tos mov.w:g next, End-Code Code k ( -- n ; R: n -- ) tos push.w:g rp , w mov.w:g 8 [w] , tos mov.w:g next, End-Code Code >r ( n -- ; R: -- n ) # -2 , rp add.w:q \ ? hfs rp , w mov.w:g tos , [w] mov.w:g tos pop.w:g next, End-Code Code rdrop ( R:n -- ) # 2 , rp add.w:q \ ? hfs next, End-Code Code unloop ( R:n -- ) # 4 , rp add.w:q \ ? hfs next, End-Code \ datastack and returnstack address Code sp@ ( -- sp ) \ get stack address tos push.w:g sp , tos stc next, End-Code Code sp! ( sp -- ) \ set stack address tos , sp ldc tos pop.w:g next, End-Code Code rp@ ( -- rp ) \ get returnstack address tos push.w:g rp , tos mov.w:g next, End-Code Code rp! ( rp -- ) \ set returnstack address tos , rp mov.w:g tos pop.w:g next, End-Code Code branch ( -- ) \ unconditional branch [ip] , ip mov.w:g next, End-Code Code lit ( -- n ) \ inline literal tos push.w:g [ip] , tos mov.w:g # 2 , ip add.w:q next, End-Code Code: :doesjump end-code \ ============================================================== \ usefull lowlevel words \ ============================================================== \ word definitions \ branch and literal \ data stack words Code dup ( n -- n n ) tos push.w:g next, End-Code Code 2dup ( d -- d d ) r1 pop.w:g r1 push.w:g tos push.w:g r1 push.w:g next, End-Code Code drop ( n -- ) tos pop.w:g next, End-Code Code 2drop ( d -- ) tos pop.w:g tos pop.w:g next, End-Code Code swap ( n1 n2 -- n2 n1 ) r1 pop.w:g tos push.w:g r1 , tos mov.w:g next, End-Code Code over ( n1 n2 -- n1 n2 n1 ) tos , r1 mov.w:g tos pop.w:g tos push.w:g r1 push.w:g next, End-Code Code rot ( n1 n2 n3 -- n2 n3 n1 ) tos , r1 mov.w:g r3 pop.w:g tos pop.w:g r3 push.w:g r1 push.w:g r3 , r3 xor.w next, End-Code Code -rot ( n1 n2 n3 -- n3 n1 n2 ) tos , r1 mov.w:g tos pop.w:g r3 pop.w:g r1 push.w:g r3 push.w:g r3 , r3 xor.w next, End-Code \ return stack Code r@ ( -- n ; R: n -- n ) tos push.w:g rp , w mov.w:g [w] , tos mov.w:g next, End-Code \ arithmetic Code um* ( u1 u2 -- ud ) \ unsigned multiply rp , r3 mov.w:g r2 pop.w:g r2 , r2r0 mulu.w:g r0 push.w:g r2 , tos mov.w:g r3 , rp mov.w:g r3 , r3 xor.w next, End-Code Code m* ( u1 u2 -- ud ) \ unsigned multiply rp , r3 mov.w:g r2 pop.w:g r2 , r2r0 mul.w:g r0 push.w:g r2 , tos mov.w:g r3 , rp mov.w:g r3 , r3 xor.w next, End-Code Code um/mod ( ud u -- r q ) \ unsiged divide rp , r3 mov.w:g tos , r1 mov.w:g r2 pop.w:g tos pop.w:g r3r1 divu.w r2 push.w:g r3 , rp mov.w:g r3 , r3 xor.w next, End-Code \ shift Code 2/ ( n1 -- n2 ) \ arithmetic shift right # -1 , tos sha.w \ # -1 , r1h mov.b:q \ r1h , tos sha.w next, End-Code Code lshift ( n1 n2 -- n3 ) \ shift n1 left n2 bits \ tos.b , r1h mov.w:g tos.b , r1h mov.b:g \ ? hfs tos pop.w:g r1h , tos shl.w next, End-Code Code rshift ( n1 n2 -- n3 ) \ shift n1 right n2 bits \ tos.b , r1h mov.w:g tos.b , r1h mov.b:g \ ? hfs r1h neg.b tos pop.w:g r1h , tos shl.w next, End-Code \ compare Code 0= ( n -- f ) \ Test auf 0 tos , tos tst.w 0= IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, next, End-Code Code 0< ( n -- f ) \ Test auf 0 tos , tos tst.w 0< IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, next, End-Code Code = ( n1 n2 -- f ) \ Test auf Gleichheit r1 pop.w:g r1 , tos sub.w:g 0= IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code ' = alias u= Code u< ( n1 n2 -- f ) \ Test auf Gleichheit r1 pop.w:g r1 , tos sub.w:g u> IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code Code u> ( n1 n2 -- f ) \ Test auf Gleichheit r1 pop.w:g r1 , tos sub.w:g u< IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code Code < ( n1 n2 -- f ) \ Test auf Gleichheit r1 pop.w:g r1 , tos sub.w:g > IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code Code > ( n1 n2 -- f ) \ Test auf Gleichheit r1 pop.w:g r1 , tos sub.w:g < IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code Code (key) ( -- char ) \ get character tos push.w:g BEGIN 3 , $AD btst:g 0<> UNTIL $AE , tos mov.w:g r0h , r0h xor.b next, End-Code Code (emit) ( char -- ) \ output character BEGIN 1 , $AD btst:g 0<> UNTIL tos.b , $AA mov.b:g tos pop.w:g next, End-Code \ additon io routines Code (key?) ( -- f ) \ check for read sio character tos push.w:g 3 , $AD btst:g 0<> IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code Code emit? ( -- f ) \ check for write character to sio tos push.w:g 1 , $AD btst:g 0<> IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code \ String operations Code fill ( addr u char -- ) R3 pop.w:g ip , r1 mov.w:g A1 pop.w:g sstr.b tos pop.w:g R3 , R3 xor.w r1 , ip mov.w:g next, End-Code Code cmove ( from to count -- ) tos , R3 mov.w:g ip , r1 mov.w:g a1 pop.w:g a0 pop.w:g r1 push.w:g r1 , r1 xor.w smovf.b R3 , R3 xor.w ip pop.w:g tos pop.w:g next, End-Code Code cmove> ( from to count -- ) tos , R3 mov.w:g ip , r1 mov.w:g a1 pop.w:g a0 pop.w:g r1 push.w:g r1 , r1 xor.w r3 , a0 add.w:g # -1 , a0 add.w:q r3 , a1 add.w:g # -1 , a1 add.w:q smovb.b R3 , R3 xor.w ip pop.w:g tos pop.w:g next, End-Code Code (find-samelen) ( u f83name1 -- u f83name2/0 ) tos , w mov.w:g r0 pop.w:g BEGIN 2 [w] , r0h mov.b:g # $1F , r0h and.b:g r0l , r0h cmp.b:g 0<> WHILE [w] , w mov.w:g 0= UNTIL THEN r0h , r0h xor.b r0 push.w:g w , tos mov.w:g next, End-Code : capscomp ( c_addr1 u c_addr2 -- n ) swap bounds ?DO dup c@ I c@ <> IF dup c@ toupper I c@ toupper = ELSE true THEN WHILE 1+ LOOP drop 0 ELSE c@ toupper I c@ toupper - unloop THEN sgn ; : sgn ( n -- -1/0/1 ) dup 0= IF EXIT THEN 0< 2* 1+ ; Code btst ( b# addr -- f ) \ check for bit set in addr tos , w mov.w:g # 3 , w shl.w r1 pop.w:g r1 , w add.w:g [w] btst:g 0<> IF # -1 , tos mov.w:q next, THEN # 0 , tos mov.w:q next, End-Code Code bset ( b# addr -- ) \ set bit in addr tos , w mov.w:g # 3 , w shl.w r1 pop.w:g r1 , w add.w:g [w] bset:g tos pop.w:g next, End-Code Code bclr ( b# addr -- ) \ clr bit in addr tos , w mov.w:g # 3 , w shl.w r1 pop.w:g r1 , w add.w:g [w] bclr:g tos pop.w:g next, End-Code Code us ( n -- ) \ n microseconds delay BEGIN AHEAD THEN AHEAD THEN r1 , r1 mov.w:g # -1 , tos add.w:q 0= UNTIL tos pop.w:g next, end-code Variable timer Code ms-irq ( -- ) # 1 , timer add.w:g reit end-code ' ms-irq >body $C084 $40 + ! 0 $C084 $42 + c! : timer-init ( -- ) &19999 $9E ! $0401 $9A ! 1 $50 c! ; : noop ; defer pause ' noop is pause : ms ( n -- ) timer @ + BEGIN pause dup timer @ - 0< UNTIL drop ; $400 constant ram-start $2FFC Constant ram-shadow 0 Constant ram-mirror 0 Constant ram-size $E0 Constant port0 $E1 Constant port1 : led! port1 c! ; : >lcd ( 4bit -- ) 1+ dup port0 c! dup 8 + port0 c! 1 us port0 c! &40 us ; : lcdctrl! ( n -- ) dup $F0 and >lcd 4 lshift >lcd &100 us ; : lcdemit ( n -- ) &100 us dup $F0 and 4 + >lcd 4 lshift 4 + >lcd &250 us ; : lcdtype bounds ?DO I c@ lcdemit LOOP ; : lcdpage $01 lcdctrl! &15 ms ; : lcdcr $C0 lcdctrl! ; : lcdinit ( -- ) $02 $0A bset $FD $E2 c! &20 ms $30 >lcd 5 ms $33 lcdctrl! 5 ms $20 >lcd &5 ms $28 lcdctrl! &1 ms $0C lcdctrl! &1 ms lcdpage ; \ default channel is channel 6 : adc@ ( chan -- value ) $80 + $D6 c! $28 $D7 c! 6 $D6 bset BEGIN 6 $D6 btst 0= UNTIL $C0 @ ; : ?flash BEGIN $1B7 c@ 1 and 1 = UNTIL ; : flashc! ( c addr -- ) $40 over c! c! ?flash ; : flash! ( x addr -- ) 2dup flashc! >r 8 rshift r> 1+ flashc! ; : flash-off ( addr -- ) $20 over c! $D0 swap c! ?flash ; : flash-enable ( -- ) 1 $1b7 c! 3 $1b7 c! 0 $1b5 c! 2 $1b5 c! ; : 9k6 $8105 $A8 ! ; \ baud setting : 38k4 $2005 $A8 ! ; \ fast terminal : r8cboot ( -- ) ['] noop IS pause timer-init flash-enable lcdinit 38k4 s" Gforth EC R8C" lcdtype boot ; ' r8cboot >body $C002 ! : savesystem ( -- ) dpp @ >r rom here normal-dp @ ram-start tuck - tuck here over allot r> dpp ! -rot bounds ?DO I c@ over flashc! 1+ LOOP drop ram-shadow tuck flash! cell+ flash! ; : refill-loop ( -- ) BEGIN 3 emit refill WHILE interpret REPEAT ; : included ( addr u -- ) 2 emit dup $20 + emit type echo @ IF echo off ['] refill-loop catch dup IF 4 emit THEN echo on throw THEN ; : include ( "file" -- ) parse-name included ; : empty ( -- ) $2800 flash-off $2000 flash-off forth-wordlist ram-mirror + ram-start - @ forth-wordlist ! normal-dp ram-mirror + ram-start - @ normal-dp ! $2000 flash-dp ! ;