File:  [gforth] / gforth / arch / r8c / prim.fs
Revision 1.33: download - view: text, annotated - select for diffs
Sat May 27 13:41:21 2006 UTC (17 years, 10 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Timer interrupt for Gforth R8C

    1: \ r8c/m16c primitives
    2: 
    3: \ Copyright (C) 2006 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   20: 
   21: \ * Register using for r8c
   22: \  Renesas  Forth    used for
   23: \   R0      TOS   oberstes Stackelement
   24: \   R3      RP    Returnstack Pointer
   25: \   SP      SP    Stack Pointer
   26: \   A1      IP    Instruction Pointer
   27: \   A0      W     Arbeitsregister
   28: \
   29: \ * Memory ( use only one 64K-Page ): TBD
   30: \ **************************************************************
   31: 
   32: 
   33: start-macros
   34:  \ register definition
   35:   ' R0L Alias tos.b
   36: 
   37:  \ hfs wichtig, damit der erste Befehl richtig compiliert wird
   38:    reset  \ hfs
   39: 
   40:  \ system depending macros
   41:   : next1,
   42:       [w] , r1 mov.w:g  r3r1 jmpi.a ;
   43:   : next,
   44:       [ip] , w mov.w:g
   45:       # 2 , ip add.w:q  next1, ;
   46: \ note that this is really for 8086 and 286, and _not_ intented to run
   47: \ fast on a Pentium (Pro). These old chips load their code from real RAM
   48: \ and do it slow, anyway.
   49: \ If you really want to have a fast 16 bit Forth on modern processors,
   50: \ redefine it as
   51: \ : next,  [ip] w mov,  2 # ip add,  [w] jmp, ;
   52: 
   53: end-macros
   54: 
   55:   unlock
   56:     $0000 $FFFF region address-space
   57:     $C000 $4000 region rom-dictionary
   58:     $0400 $0400 region ram-dictionary
   59:   .regions
   60:   setup-target
   61:   lock
   62: 
   63: \ ==============================================================
   64: \ rom starts with jump to GFORTH-kernel (must be at $0000 !!!)
   65: \ ==============================================================
   66:   Label into-forth
   67:     # $ffff , ip mov.w:g            \ ip will be patched
   68:     # $0780 , sp ldc                \ sp at $0600...$0700
   69:     # $0800 , rp mov.w:g            \ rp at $0780...$0800
   70:     # $C084 , intbl ldc
   71:     # $0F , $E3  mov.b:g
   72:     # $0F , $E1  mov.b:g
   73:   Label mem-init
   74:     $01 , $0A bset:g
   75:     $00 , $05 bset:g                \ open data RAM
   76:     $01 , $0A bclr:g
   77:   Label clock-init                  \ default is 125kHz/8
   78:     $00 , $0A  bset:g
   79:     # $2808 , $06  mov.w:g
   80:     AHEAD  THEN
   81:     2 , $0C bclr:g
   82:     # $00 , $08  mov.b:g            \ set to 20MHz
   83:     $00 , $0A  bclr:g
   84:   Label uart-init
   85:     # $27 , $B0  mov.b:g      \ hfs
   86: \    # $8105 , $A8  mov.w:g    \ ser1: 9600 baud, 8N1  \ hfs
   87: \    # $2005 , $A8  mov.w:g    \ ser1: 38k4 baud, 8N1  \ hfs
   88:     # $0500 , $AC  mov.w:g      \ hfs
   89:     I fset
   90:   next,
   91:   End-Label
   92: 
   93: 
   94: \ ==============================================================
   95: \ GFORTH minimal primitive set
   96: \ ==============================================================
   97:  \ inner interpreter
   98:   align
   99: 
  100:   Code: :docol
  101:   \     ': dout,                    \ only for debugging
  102:      # -2 , rp add.w:q
  103:      w , r1 mov.w:g
  104:      rp , w mov.w:g  ip , [w] mov.w:g
  105:      # 4 , r1 add.w:q  r1 , ip mov.w:g
  106:      next,
  107:    End-Code
  108: 
  109:    align
  110: 
  111:   Code: :docon
  112: \    '2 dout,                    \ only for debugging
  113:     tos push.w:g
  114:     4 [w] , tos mov.w:g
  115:     next,
  116:   End-Code
  117: 
  118:   align
  119: 
  120:   Code: :dovalue
  121: \    '2 dout,                    \ only for debugging
  122:     tos push.w:g
  123:     4 [w] , w mov.w:g  [w] , tos mov.w:g
  124:     next,
  125:   End-Code
  126: 
  127:   align
  128: 
  129:   Code: :dofield
  130:       4 [w] , tos add.w:g
  131:       next,
  132:   end-code
  133:   
  134:   align
  135: 
  136:   Code: :dodefer
  137: \      # $05 , $E1 mov.b:g
  138:      4 [w] , w mov.w:g  [w] , w mov.w:g
  139:      next1,
  140:   End-Code
  141: 
  142:   align
  143:   
  144:   Code: :dodoes  ( -- pfa ) \ get pfa and execute DOES> part
  145: \    '6 dout,                    \ only for debugging
  146: \      # $06 , $E1 mov.b:g
  147:      tos push.w:g
  148:      w , tos mov.w:g   # 4 , tos add.w:q
  149:      # -2 , rp add.w:q  2 [w] , r1 mov.w:g
  150:      rp , w mov.w:g  ip , [w] mov.w:g
  151:      r1 , ip mov.w:g
  152:      next,                                       \ execute does> part
  153:   End-Code
  154: 
  155:   $FF $C0FE here - tcallot
  156:   
  157:   Code: :dovar
  158: \    '2 dout,                    \ only for debugging
  159:     tos push.w:g
  160:     # 4 , w add.w:q
  161:     w , tos mov.w:g
  162:     next,
  163:   End-Code
  164: 
  165: \ program flow
  166:   Code ;s       ( -- ) \ exit colon definition
  167: \    '; dout,                    \ only for debugging
  168:       rp , w mov.w:g  # 2 , rp add.w:q
  169:       [w] , ip mov.w:g
  170:       next,
  171:   End-Code
  172: 
  173:   Code execute   ( xt -- ) \ execute colon definition
  174:     tos , w mov.w:g                          \ copy tos to w
  175:     tos pop.w:g                              \ get new tos
  176:     next1,
  177:   End-Code
  178: 
  179:   Code perform   ( xt -- ) \ execute colon definition
  180:     tos , w mov.w:g                          \ copy tos to w
  181:     tos pop.w:g                              \ get new tos
  182:     [w] , w mov.w:g
  183:     next1,
  184:   End-Code
  185: 
  186:   Code ?branch   ( f -- ) \ jump on f=0
  187:       # 2 , ip add.w:q
  188:       tos , tos tst.w   0= IF  -2 [ip] , ip mov.w:g   THEN
  189:       tos pop.w:g
  190:       next,
  191:   End-Code
  192: 
  193:   Code (for) ( n -- r:0 r:n )
  194:       # -4 , rp add.w:q  rp , w mov.w:g
  195:       r3 , 2 [w] mov.w:g
  196:       tos , [w] mov.w:g
  197:       tos pop.w:g
  198:       next,
  199:   End-Code
  200:   
  201:   Code (?do) ( n -- r:0 r:n )
  202:       # 2 , ip add.w:q
  203:       # -4 , rp add.w:q  rp , w mov.w:g
  204:       tos , [w] mov.w:g
  205:       r1 pop.w:g
  206:       r1 , 2 [w] mov.w:g
  207:       tos pop.w:g
  208:       [w] , r1 sub.w:g
  209:       0= IF  -2 [ip] , ip mov.w:g   THEN
  210:       next,
  211:   End-Code
  212:   
  213:   Code (do) ( n -- r:0 r:n )
  214:       # -4 , rp add.w:q  rp , w mov.w:g
  215:       tos , [w] mov.w:g
  216:       tos pop.w:g
  217:       tos , 2 [w] mov.w:g
  218:       tos pop.w:g
  219:       next,
  220:   End-Code
  221:   
  222:   Code (next) ( -- )
  223:       # 2 , ip add.w:q
  224:       rp , w mov.w:g  [w] , r1 mov.w:g
  225:       # -1 , r1 add.w:q  r1 , [w] mov.w:g
  226:       u>= IF  -2 [ip] , ip mov.w:g  THEN
  227:       next,
  228:   End-Code
  229: 
  230:   Code (loop) ( -- )
  231:       # 2 , ip add.w:q
  232:       rp , w mov.w:g  [w] , r1 mov.w:g
  233:       # 1 , r1 add.w:q  r1 , [w] mov.w:g
  234:       2 [w] , r1 sub.w:g
  235:       0<> IF  -2 [ip] , ip mov.w:g  THEN
  236:       next,
  237:   End-Code
  238: 
  239:   Code (+loop) ( n -- )
  240:       # 2 , ip add.w:q
  241:       rp , w mov.w:g  [w] , r1 mov.w:g
  242:       2 [w] , r1 sub.w:g  # $8000 , r1 xor.w
  243:       tos , r1 add.w:g
  244:       no IF  -2 [ip] , ip mov.w:g  THEN
  245:       tos , [w] add.w:g
  246:       tos pop.w:g
  247:       next,
  248:   End-Code
  249: 
  250:  \ memory access
  251:   Code @        ( addr -- n ) \ read cell
  252:       tos , w mov.w:g  [w] , tos mov.w:g
  253:       next,
  254:    End-Code
  255: 
  256:   Code !        ( n addr -- ) \ write cell
  257:       tos , w mov.w:g  tos pop.w:g  tos , [w] mov.w:g
  258:       tos pop.w:g
  259:       next,
  260:    End-Code
  261: 
  262:   Code +!        ( n addr -- ) \ write cell
  263:       tos , w mov.w:g  tos pop.w:g  tos , [w] add.w:g
  264:       tos pop.w:g
  265:       next,
  266:    End-Code
  267: 
  268:   Code c@        ( addr -- uc ) \ read cell
  269:       tos , w mov.w:g  tos , tos xor.w  [w] , tos.b mov.b:g
  270:       next,
  271:    End-Code
  272: 
  273:   Code count     ( addr -- addr+1 uc ) \ read cell
  274:       tos , w mov.w:g  tos , tos xor.w  [w] , tos.b mov.b:g
  275:       # 1 , w add.w:q  w push.w:g
  276:       next,
  277:    End-Code
  278: 
  279:   Code c!        ( n addr -- ) \ write cell
  280:       tos , w mov.w:g  tos pop.w:g  tos.b , [w] mov.b:g
  281:       tos pop.w:g
  282:       next,
  283:    End-Code
  284: 
  285:  \ arithmetic and logic
  286:   Code +        ( n1 n2 -- n3 ) \ addition
  287:       r1 pop.w:g
  288:       r1 , tos add.w:g
  289:       next,
  290:   End-Code
  291:   
  292:   Code 2*        ( n1 n2 -- n3 ) \ addition
  293:       tos , tos add.w:g
  294:       next,
  295:   End-Code
  296:   
  297:   Code -        ( n1 n2 -- n3 ) \ addition
  298:       r1 pop.w:g
  299:       tos , r1 sub.w:g
  300:       r1 , tos mov.w:g
  301:       next,
  302:   End-Code
  303: 
  304:   Code negate ( n1 -- n2 )
  305:       tos neg.w
  306:       next,
  307:   End-Code
  308:   
  309:   Code invert ( n1 -- n2 )
  310:       tos not.w:g
  311:       next,
  312:   End-Code
  313:   
  314:   Code 1+        ( n1 n2 -- n3 ) \ addition
  315:       # 1 , tos add.w:g
  316:       next,
  317:   End-Code
  318:   
  319:   Code 1-        ( n1 n2 -- n3 ) \ addition
  320:       # -1 , tos add.w:g
  321:       next,
  322:   End-Code
  323:   
  324:   Code cell+        ( n1 n2 -- n3 ) \ addition
  325:       # 2 , tos add.w:g
  326:       next,
  327:   End-Code
  328:   
  329:   Code and        ( n1 n2 -- n3 ) \ addition
  330:       r1 pop.w:g
  331:       r1 , tos and.w:g
  332:       next,
  333:   End-Code
  334:   
  335:   Code or       ( n1 n2 -- n3 ) \ addition
  336:       r1 pop.w:g
  337:       r1 , tos or.w:g
  338:       next,
  339:   End-Code
  340:   
  341:   Code xor      ( n1 n2 -- n3 ) \ addition
  342:       r1 pop.w:g
  343:       r1 , tos xor.w
  344:       next,
  345:    End-Code
  346: 
  347:  \ moving datas between stacks
  348:   Code r>       ( -- n ; R: n -- )
  349:       tos push.w:g
  350:       rp , w mov.w:g
  351:       [w] , tos mov.w:g
  352:       # 2 , rp add.w:q  \ ? hfs
  353:       next,
  354:   End-Code
  355:   
  356:   Code i       ( -- n ; R: n -- )
  357:       tos push.w:g
  358:       rp , w mov.w:g
  359:       [w] , tos mov.w:g
  360:       next,
  361:    End-Code
  362: 
  363:   Code i'       ( -- n ; R: n -- )
  364:       tos push.w:g
  365:       rp , w mov.w:g
  366:       2 [w] , tos mov.w:g
  367:       next,
  368:    End-Code
  369: 
  370:   Code j       ( -- n ; R: n -- )
  371:       tos push.w:g
  372:       rp , w mov.w:g
  373:       4 [w] , tos mov.w:g
  374:       next,
  375:    End-Code
  376: 
  377:   Code k       ( -- n ; R: n -- )
  378:       tos push.w:g
  379:       rp , w mov.w:g
  380:       8 [w] , tos mov.w:g
  381:       next,
  382:    End-Code
  383: 
  384:    Code >r       ( n -- ; R: -- n )
  385:        # -2 , rp add.w:q  \ ? hfs
  386:        rp , w mov.w:g
  387:        tos , [w] mov.w:g
  388:        tos pop.w:g
  389:        next,
  390:    End-Code
  391: 
  392:    Code rdrop       ( R:n -- )
  393:       # 2 , rp add.w:q  \ ? hfs
  394:       next,
  395:    End-Code
  396: 
  397:    Code unloop       ( R:n -- )
  398:       # 4 , rp add.w:q  \ ? hfs
  399:       next,
  400:    End-Code
  401: 
  402:  \ datastack and returnstack address
  403:   Code sp@      ( -- sp ) \ get stack address
  404:       tos push.w:g
  405:       sp , tos stc
  406:       next,
  407:   End-Code
  408: 
  409:   Code sp!      ( sp -- ) \ set stack address
  410:       tos , sp ldc
  411:       tos pop.w:g
  412:       next,
  413:   End-Code
  414: 
  415:   Code rp@      ( -- rp ) \ get returnstack address
  416:     tos push.w:g
  417:     rp , tos mov.w:g
  418:     next,
  419:   End-Code
  420: 
  421:   Code rp!      ( rp -- ) \ set returnstack address
  422:       tos , rp mov.w:g
  423:       tos pop.w:g
  424:       next,
  425:   End-Code
  426: 
  427:   Code branch   ( -- ) \ unconditional branch
  428:       [ip] , ip mov.w:g
  429:       next,
  430:    End-Code
  431: 
  432:   Code lit     ( -- n ) \ inline literal
  433:       tos push.w:g
  434:       [ip] , tos mov.w:g
  435:       # 2 , ip add.w:q
  436:       next,
  437:    End-Code
  438: 
  439: Code: :doesjump
  440: end-code
  441: 
  442: \ ==============================================================
  443: \ usefull lowlevel words
  444: \ ==============================================================
  445:  \ word definitions
  446: 
  447: 
  448:  \ branch and literal
  449: 
  450:  \ data stack words
  451:   Code dup      ( n -- n n )
  452:     tos push.w:g
  453:     next,
  454:    End-Code
  455: 
  456:   Code 2dup     ( d -- d d )
  457:     r1 pop.w:g
  458:     r1 push.w:g
  459:     tos push.w:g
  460:     r1 push.w:g
  461:     next,
  462:    End-Code
  463: 
  464:   Code drop     ( n -- )
  465:     tos pop.w:g
  466:     next,
  467:    End-Code
  468: 
  469:   Code 2drop    ( d -- )
  470:     tos pop.w:g
  471:     tos pop.w:g
  472:     next,
  473:    End-Code
  474: 
  475:   Code swap     ( n1 n2 -- n2 n1 )
  476:     r1 pop.w:g
  477:     tos push.w:g
  478:     r1 , tos mov.w:g
  479:     next,
  480:    End-Code
  481: 
  482:   Code over     ( n1 n2 -- n1 n2 n1 )
  483:     tos , r1 mov.w:g
  484:     tos pop.w:g
  485:     tos push.w:g
  486:     r1 push.w:g
  487:     next,
  488:    End-Code
  489: 
  490:   Code rot      ( n1 n2 n3 -- n2 n3 n1 )
  491:     tos , r1 mov.w:g
  492:     r3 pop.w:g
  493:     tos pop.w:g
  494:     r3 push.w:g
  495:     r1 push.w:g
  496:     r3 , r3 xor.w
  497:     next,
  498:    End-Code
  499: 
  500:   Code -rot     ( n1 n2 n3 -- n3 n1 n2 )
  501:     tos , r1 mov.w:g
  502:     tos pop.w:g
  503:     r3 pop.w:g
  504:     r1 push.w:g
  505:     r3 push.w:g
  506:     r3 , r3 xor.w
  507:     next,
  508:    End-Code
  509: 
  510: 
  511:  \ return stack
  512:   Code r@       ( -- n ; R: n -- n )
  513:     tos push.w:g
  514:     rp , w mov.w:g
  515:     [w] , tos mov.w:g
  516:     next,
  517:   End-Code
  518: 
  519: 
  520:  \ arithmetic
  521: 
  522:   Code um*      ( u1 u2 -- ud ) \ unsigned multiply
  523:       rp , r3 mov.w:g
  524:       r2 pop.w:g
  525:       r2 , r2r0 mulu.w:g
  526:       r0 push.w:g
  527:       r2 , tos mov.w:g
  528:       r3 , rp mov.w:g
  529:       r3 , r3 xor.w
  530:       next,
  531:    End-Code
  532: 
  533:   Code m*      ( u1 u2 -- ud ) \ unsigned multiply
  534:       rp , r3 mov.w:g
  535:       r2 pop.w:g
  536:       r2 , r2r0 mul.w:g
  537:       r0 push.w:g
  538:       r2 , tos mov.w:g
  539:       r3 , rp mov.w:g
  540:       r3 , r3 xor.w
  541:       next,
  542:    End-Code
  543: 
  544:   Code um/mod   ( ud u -- r q ) \ unsiged divide
  545:       rp , r3 mov.w:g
  546:       tos , r1 mov.w:g
  547:       r2 pop.w:g
  548:       tos pop.w:g
  549:       r3r1 divu.w
  550:       r2 push.w:g
  551:       r3 , rp mov.w:g
  552:       r3 , r3 xor.w
  553:       next,
  554:    End-Code
  555: 
  556:  \ shift
  557:   Code 2/       ( n1 -- n2 ) \ arithmetic shift right
  558:      # -1 , tos sha.w 
  559:  \    # -1 , r1h mov.b:q
  560:  \    r1h , tos sha.w
  561:      next,
  562:    End-Code
  563: 
  564:   Code lshift   ( n1 n2 -- n3 ) \ shift n1 left n2 bits
  565:  \     tos.b , r1h mov.w:g
  566:       tos.b , r1h mov.b:g  \ ? hfs
  567:       tos pop.w:g
  568:       r1h , tos shl.w
  569:       next,
  570:    End-Code
  571: 
  572:   Code rshift   ( n1 n2 -- n3 ) \ shift n1 right n2 bits
  573: \     tos.b , r1h mov.w:g
  574:       tos.b , r1h mov.b:g  \ ? hfs
  575:       r1h neg.b
  576:       tos pop.w:g
  577:       r1h , tos shl.w
  578:      next,
  579:    End-Code
  580: 
  581:  \ compare
  582:   Code 0=       ( n -- f ) \ Test auf 0
  583:     tos , tos tst.w
  584:     0= IF  # -1 , tos mov.w:q   next,
  585:     THEN   #  0 , tos mov.w:q   next,
  586:     next,
  587:    End-Code
  588: 
  589:    Code 0<       ( n -- f ) \ Test auf 0
  590:     tos , tos tst.w
  591:     0< IF  # -1 , tos mov.w:q   next,
  592:     THEN   #  0 , tos mov.w:q   next,
  593:     next,
  594:    End-Code
  595: 
  596:   Code =        ( n1 n2 -- f ) \ Test auf Gleichheit
  597:     r1 pop.w:g
  598:     r1 , tos sub.w:g
  599:     0= IF  # -1 , tos mov.w:q   next,
  600:     THEN   #  0 , tos mov.w:q   next,
  601:    End-Code
  602: 
  603:    ' = alias u=
  604:    
  605:   Code u<        ( n1 n2 -- f ) \ Test auf Gleichheit
  606:     r1 pop.w:g
  607:     r1 , tos sub.w:g
  608:     u> IF  # -1 , tos mov.w:q   next,
  609:     THEN   #  0 , tos mov.w:q   next,
  610:    End-Code
  611: 
  612:   Code u>        ( n1 n2 -- f ) \ Test auf Gleichheit
  613:     r1 pop.w:g
  614:     r1 , tos sub.w:g
  615:     u< IF  # -1 , tos mov.w:q   next,
  616:     THEN   #  0 , tos mov.w:q   next,
  617:    End-Code
  618: 
  619:   Code <        ( n1 n2 -- f ) \ Test auf Gleichheit
  620:     r1 pop.w:g
  621:     r1 , tos sub.w:g
  622:     > IF  # -1 , tos mov.w:q   next,
  623:     THEN   #  0 , tos mov.w:q   next,
  624:    End-Code
  625: 
  626:   Code >        ( n1 n2 -- f ) \ Test auf Gleichheit
  627:     r1 pop.w:g
  628:     r1 , tos sub.w:g
  629:     < IF  # -1 , tos mov.w:q   next,
  630:     THEN   #  0 , tos mov.w:q   next,
  631:    End-Code
  632: 
  633:   Code (key)    ( -- char ) \ get character
  634:       tos push.w:g
  635:       BEGIN  3 , $AD  btst:g  0<> UNTIL
  636:       $AE  , tos mov.w:g  r0h , r0h xor.b
  637:     next,
  638:    End-Code
  639: 
  640:   Code (emit)     ( char -- ) \ output character
  641:       BEGIN  1 , $AD  btst:g  0<> UNTIL
  642:       tos.b , $AA  mov.b:g
  643:       tos pop.w:g
  644:       next,
  645:   End-Code
  646: 
  647:  \ additon io routines
  648:   Code (key?)     ( -- f ) \ check for read sio character
  649:       tos push.w:g
  650:       3 , $AD  btst:g
  651:       0<> IF  # -1 , tos mov.w:q   next,
  652:       THEN    #  0 , tos mov.w:q   next,
  653:    End-Code
  654: 
  655:   Code emit?    ( -- f ) \ check for write character to sio
  656:       tos push.w:g
  657:       1 , $AD  btst:g
  658:       0<> IF  # -1 , tos mov.w:q   next,
  659:       THEN    #  0 , tos mov.w:q   next,
  660:    End-Code
  661: 
  662:    \ String operations
  663: 
  664:    Code fill ( addr u char -- )
  665:        R3 pop.w:g  ip , r1 mov.w:g  A1 pop.w:g
  666:        sstr.b  tos pop.w:g
  667:        R3 , R3 xor.w  r1 , ip mov.w:g  next,
  668:    End-Code
  669: 
  670:    Code cmove ( from to count -- )
  671:        tos , R3 mov.w:g  ip , r1 mov.w:g
  672:        a1 pop.w:g  a0 pop.w:g  r1 push.w:g  r1 , r1 xor.w
  673:        smovf.b
  674:        R3 , R3 xor.w  ip pop.w:g  tos pop.w:g next,
  675:    End-Code
  676:    
  677:    Code cmove> ( from to count -- )
  678:        tos , R3 mov.w:g  ip , r1 mov.w:g
  679:        a1 pop.w:g  a0 pop.w:g  r1 push.w:g  r1 , r1 xor.w
  680:        r3 , a0 add.w:g  # -1 , a0 add.w:q
  681:        r3 , a1 add.w:g  # -1 , a1 add.w:q
  682:        smovb.b
  683:        R3 , R3 xor.w  ip pop.w:g  tos pop.w:g next,
  684:    End-Code
  685:    
  686:    Code (find-samelen) ( u f83name1 -- u f83name2/0 )
  687:        tos , w mov.w:g  r0 pop.w:g
  688:        BEGIN  2 [w] , r0h mov.b:g  # $1F , r0h and.b:g
  689: 	   r0l , r0h cmp.b:g  0<> WHILE  [w] , w mov.w:g
  690: 	   0= UNTIL  THEN
  691:        r0h , r0h xor.b  r0 push.w:g  w , tos mov.w:g
  692:        next,
  693:    End-Code
  694: 
  695: : capscomp ( c_addr1 u c_addr2 -- n )
  696:  swap bounds
  697:  ?DO  dup c@ I c@ <>
  698:      IF  dup c@ toupper I c@ toupper =
  699:      ELSE  true  THEN  WHILE  1+  LOOP  drop 0
  700:  ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
  701: : sgn ( n -- -1/0/1 )
  702:  dup 0= IF EXIT THEN  0< 2* 1+ ;
  703:        
  704:    Code btst ( b# addr -- f ) \ check for bit set in addr
  705:       tos , w mov.w:g  # 3 , w shl.w
  706:       r1 pop.w:g       r1 , w add.w:g      [w] btst:g
  707:       0<> IF    # -1 , tos mov.w:q   next,
  708:           THEN  #  0 , tos mov.w:q   next,
  709:    End-Code
  710: 
  711:    Code bset ( b# addr -- ) \ set bit in addr
  712:       tos , w mov.w:g  # 3 , w shl.w
  713:       r1 pop.w:g       r1 , w add.w:g      [w] bset:g
  714:       tos pop.w:g      next,
  715:    End-Code
  716: 
  717:    Code bclr ( b# addr -- ) \ clr bit in addr
  718:       tos , w mov.w:g  # 3 , w shl.w
  719:       r1 pop.w:g       r1 , w add.w:g      [w] bclr:g
  720:       tos pop.w:g      next,
  721:    End-Code
  722: 
  723:    Code us ( n -- ) \ n microseconds delay
  724:        BEGIN  AHEAD  THEN  AHEAD  THEN
  725:            r1 , r1 mov.w:g
  726:            # -1 , tos  add.w:q  0= UNTIL
  727:        tos pop.w:g
  728:        next,
  729:    end-code
  730:    
  731:    Variable timer
  732:    
  733:    Code ms-irq ( -- )
  734:        # 1 , timer add.w:g
  735:        reit
  736:    end-code
  737: 
  738:    ' ms-irq >body $C084 $40 + ! 0 $C084 $42 + c!
  739: 
  740:    : timer-init ( -- )
  741:        &19999 $9E !
  742:        $0401 $9A !
  743:        1 $50 c! ;
  744: 
  745:    : ms ( n -- )  timer @ +
  746:        BEGIN  dup timer @ - 0<  UNTIL  drop ;
  747:    
  748:    $400 constant ram-start
  749:    $2FFC Constant ram-shadow
  750:    0 Constant ram-mirror
  751:    0 Constant ram-size
  752:    $E0 Constant port0
  753:    $E1 Constant port1
  754:    
  755:    : led!  port1 c! ;
  756:    : >lcd ( 4bit -- )
  757:        1+ dup port0 c! dup 8 + port0 c!  1 us  port0 c!
  758:        &40 us ;
  759:    : lcdctrl!  ( n -- )
  760:        dup $F0 and >lcd
  761:        4 lshift >lcd
  762:        &100 us ;
  763:    : lcdemit ( n -- )  &100 us
  764:        dup $F0 and 4 + >lcd
  765:        4 lshift 4 + >lcd
  766:        &250 us ;
  767:    : lcdtype  bounds ?DO  I c@ lcdemit  LOOP ;
  768:    : lcdpage  $01 lcdctrl! &15 ms ;
  769:    : lcdcr    $C0 lcdctrl! ;
  770:    : lcdinit ( -- )
  771:        $02 $0A bset $FD $E2 c!
  772:        &20 ms $30 >lcd  5 ms  $33 lcdctrl! 5 ms $20 >lcd
  773:        &5 ms  $28 lcdctrl!
  774:        &1 ms  $0C lcdctrl!
  775:        &1 ms  lcdpage ;
  776:    \ default channel is channel 6
  777:    : adc@ ( chan -- value )  $80 + $D6 c!  $28 $D7 c!
  778:        6 $D6 bset  BEGIN  6 $D6 btst 0=  UNTIL  $C0 @ ;
  779:    : ?flash  BEGIN  $1B7 c@ 1 and 1 =  UNTIL ;
  780:    : flashc! ( c addr -- )  $40 over c! c! ?flash ;
  781:    : flash! ( x addr -- )  2dup flashc! >r 8 rshift r> 1+ flashc! ;
  782:    : flash-off ( addr -- )  $20 over c! $D0 swap c! ?flash ;
  783:    : flash-enable ( -- )   $1b7 c! 3 $1b7 c! 0 $1b5 c! 2 $1b5 c! ;
  784:    : 9k6   $8105 $A8 ! ; \ baud setting
  785:    : 38k4  $2005 $A8 ! ; \ fast terminal
  786:    : r8cboot ( -- )  timer-init flash-enable lcdinit 38k4
  787:        s" Gforth EC R8C" lcdtype boot ;
  788:    ' r8cboot >body $C002 !
  789:    : savesystem ( -- )
  790:        dpp @ >r rom here normal-dp @ ram-start tuck - tuck
  791:        here over allot r> dpp ! -rot
  792:        bounds ?DO  I c@ over flashc! 1+  LOOP  drop
  793:        ram-shadow tuck flash! cell+ flash! ;
  794:    : refill-loop ( -- )
  795:        BEGIN  3 emit refill  WHILE  interpret  REPEAT ;   
  796:    : included ( addr u -- )  echo off
  797:        2 emit dup $20 + emit type ['] refill-loop catch
  798:        dup IF  4 emit  THEN  echo on  throw ;
  799:    : include ( "file" -- )  parse-name included ;
  800:    : empty ( -- )  $2800 flash-off $2000 flash-off
  801:        forth-wordlist ram-mirror + ram-start - @ forth-wordlist !
  802:        normal-dp ram-mirror + ram-start - @ normal-dp ! $2000 flash-dp ! ;
  803: 
  804: : (bye)     ( 0 -- ) \ back to DOS
  805:     drop 5 emit ;
  806: 
  807: : bye ( -- )  0 (bye) ;
  808:     
  809: : x@+/string ( addr u -- addr' u' c )
  810:     over c@ >r 1 /string r> ;
  811: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>