File:  [gforth] / gforth / arch / r8c / prim.fs
Revision 1.41: download - view: text, annotated - select for diffs
Fri Dec 31 18:09:02 2010 UTC (11 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright years

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

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