Annotation of gforth/arch/r8c/prim.fs, revision 1.33

1.1       pazsan      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
1.2       pazsan     35:   ' R0L Alias tos.b
1.1       pazsan     36: 
1.7       pazsan     37:  \ hfs wichtig, damit der erste Befehl richtig compiliert wird
                     38:    reset  \ hfs
                     39: 
1.1       pazsan     40:  \ system depending macros
1.8       pazsan     41:   : next1,
1.18      pazsan     42:       [w] , r1 mov.w:g  r3r1 jmpi.a ;
1.1       pazsan     43:   : next,
                     44:       [ip] , w mov.w:g
1.8       pazsan     45:       # 2 , ip add.w:q  next1, ;
1.1       pazsan     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
1.2       pazsan     56:     $0000 $FFFF region address-space
                     57:     $C000 $4000 region rom-dictionary
1.5       pazsan     58:     $0400 $0400 region ram-dictionary
1.2       pazsan     59:   .regions
                     60:   setup-target
1.1       pazsan     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
1.18      pazsan     68:     # $0780 , sp ldc                \ sp at $0600...$0700
1.31      pazsan     69:     # $0800 , rp mov.w:g            \ rp at $0780...$0800
1.32      pazsan     70:     # $C084 , intbl ldc
1.9       pazsan     71:     # $0F , $E3  mov.b:g
                     72:     # $0F , $E1  mov.b:g
1.16      pazsan     73:   Label mem-init
1.18      pazsan     74:     $01 , $0A bset:g
                     75:     $00 , $05 bset:g                \ open data RAM
                     76:     $01 , $0A bclr:g
1.9       pazsan     77:   Label clock-init                  \ default is 125kHz/8
1.18      pazsan     78:     $00 , $0A  bset:g
1.33    ! pazsan     79:     # $2808 , $06  mov.w:g
1.16      pazsan     80:     AHEAD  THEN
1.18      pazsan     81:     2 , $0C bclr:g
1.9       pazsan     82:     # $00 , $08  mov.b:g            \ set to 20MHz
1.18      pazsan     83:     $00 , $0A  bclr:g
1.5       pazsan     84:   Label uart-init
1.13      pazsan     85:     # $27 , $B0  mov.b:g      \ hfs
1.32      pazsan     86: \    # $8105 , $A8  mov.w:g    \ ser1: 9600 baud, 8N1  \ hfs
1.23      pazsan     87: \    # $2005 , $A8  mov.w:g    \ ser1: 38k4 baud, 8N1  \ hfs
1.10      pazsan     88:     # $0500 , $AC  mov.w:g      \ hfs
1.33    ! pazsan     89:     I fset
1.14      pazsan     90:   next,
1.1       pazsan     91:   End-Label
                     92: 
                     93: 
                     94: \ ==============================================================
                     95: \ GFORTH minimal primitive set
                     96: \ ==============================================================
                     97:  \ inner interpreter
1.19      pazsan     98:   align
                     99: 
1.1       pazsan    100:   Code: :docol
                    101:   \     ': dout,                    \ only for debugging
                    102:      # -2 , rp add.w:q
1.7       pazsan    103:      w , r1 mov.w:g
1.1       pazsan    104:      rp , w mov.w:g  ip , [w] mov.w:g
1.7       pazsan    105:      # 4 , r1 add.w:q  r1 , ip mov.w:g
1.1       pazsan    106:      next,
                    107:    End-Code
                    108: 
1.19      pazsan    109:    align
1.1       pazsan    110: 
1.4       pazsan    111:   Code: :docon
                    112: \    '2 dout,                    \ only for debugging
                    113:     tos push.w:g
1.10      pazsan    114:     4 [w] , tos mov.w:g
1.4       pazsan    115:     next,
                    116:   End-Code
                    117: 
1.19      pazsan    118:   align
                    119: 
1.8       pazsan    120:   Code: :dovalue
                    121: \    '2 dout,                    \ only for debugging
                    122:     tos push.w:g
1.10      pazsan    123:     4 [w] , w mov.w:g  [w] , tos mov.w:g
1.8       pazsan    124:     next,
1.4       pazsan    125:   End-Code
                    126: 
1.19      pazsan    127:   align
                    128: 
1.13      pazsan    129:   Code: :dofield
                    130:       4 [w] , tos add.w:g
                    131:       next,
                    132:   end-code
                    133:   
1.19      pazsan    134:   align
                    135: 
1.9       pazsan    136:   Code: :dodefer
1.10      pazsan    137: \      # $05 , $E1 mov.b:g
                    138:      4 [w] , w mov.w:g  [w] , w mov.w:g
1.9       pazsan    139:      next1,
                    140:   End-Code
1.8       pazsan    141: 
1.19      pazsan    142:   align
                    143:   
1.1       pazsan    144:   Code: :dodoes  ( -- pfa ) \ get pfa and execute DOES> part
                    145: \    '6 dout,                    \ only for debugging
1.8       pazsan    146: \      # $06 , $E1 mov.b:g
                    147:      tos push.w:g
                    148:      w , tos mov.w:g   # 4 , tos add.w:q
1.20      pazsan    149:      # -2 , rp add.w:q  2 [w] , r1 mov.w:g
1.13      pazsan    150:      rp , w mov.w:g  ip , [w] mov.w:g
1.20      pazsan    151:      r1 , ip mov.w:g
1.1       pazsan    152:      next,                                       \ execute does> part
1.5       pazsan    153:   End-Code
1.19      pazsan    154: 
1.32      pazsan    155:   $FF $C0FE here - tcallot
1.5       pazsan    156:   
1.19      pazsan    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
1.1       pazsan    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
1.8       pazsan    174:     tos , w mov.w:g                          \ copy tos to w
                    175:     tos pop.w:g                              \ get new tos
                    176:     next1,
1.1       pazsan    177:   End-Code
                    178: 
1.23      pazsan    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: 
1.10      pazsan    186:   Code ?branch   ( f -- ) \ jump on f=0
1.7       pazsan    187:       # 2 , ip add.w:q
1.10      pazsan    188:       tos , tos tst.w   0= IF  -2 [ip] , ip mov.w:g   THEN
1.11      pazsan    189:       tos pop.w:g
1.2       pazsan    190:       next,
1.1       pazsan    191:   End-Code
                    192: 
1.10      pazsan    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
1.1       pazsan    238: 
1.23      pazsan    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: 
1.1       pazsan    250:  \ memory access
                    251:   Code @        ( addr -- n ) \ read cell
1.2       pazsan    252:       tos , w mov.w:g  [w] , tos mov.w:g
1.1       pazsan    253:       next,
                    254:    End-Code
                    255: 
                    256:   Code !        ( n addr -- ) \ write cell
1.2       pazsan    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: 
1.23      pazsan    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
1.2       pazsan    274:       tos , w mov.w:g  tos , tos xor.w  [w] , tos.b mov.b:g
1.23      pazsan    275:       # 1 , w add.w:q  w push.w:g
1.2       pazsan    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:   
1.23      pazsan    292:   Code 2*        ( n1 n2 -- n3 ) \ addition
                    293:       tos , tos add.w:g
                    294:       next,
                    295:   End-Code
                    296:   
1.2       pazsan    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: 
1.23      pazsan    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:   
1.2       pazsan    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
1.7       pazsan    352:       # 2 , rp add.w:q  \ ? hfs
1.1       pazsan    353:       next,
1.23      pazsan    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,
1.1       pazsan    382:    End-Code
                    383: 
1.2       pazsan    384:    Code >r       ( n -- ; R: -- n )
1.7       pazsan    385:        # -2 , rp add.w:q  \ ? hfs
1.2       pazsan    386:        rp , w mov.w:g
                    387:        tos , [w] mov.w:g
                    388:        tos pop.w:g
                    389:        next,
                    390:    End-Code
                    391: 
1.10      pazsan    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: 
1.1       pazsan    402:  \ datastack and returnstack address
                    403:   Code sp@      ( -- sp ) \ get stack address
1.2       pazsan    404:       tos push.w:g
                    405:       sp , tos stc
                    406:       next,
                    407:   End-Code
1.1       pazsan    408: 
                    409:   Code sp!      ( sp -- ) \ set stack address
1.2       pazsan    410:       tos , sp ldc
                    411:       tos pop.w:g
                    412:       next,
1.1       pazsan    413:   End-Code
                    414: 
                    415:   Code rp@      ( -- rp ) \ get returnstack address
1.2       pazsan    416:     tos push.w:g
                    417:     rp , tos mov.w:g
1.1       pazsan    418:     next,
                    419:   End-Code
                    420: 
                    421:   Code rp!      ( rp -- ) \ set returnstack address
1.2       pazsan    422:       tos , rp mov.w:g
                    423:       tos pop.w:g
                    424:       next,
                    425:   End-Code
1.1       pazsan    426: 
1.2       pazsan    427:   Code branch   ( -- ) \ unconditional branch
                    428:       [ip] , ip mov.w:g
                    429:       next,
1.1       pazsan    430:    End-Code
                    431: 
1.2       pazsan    432:   Code lit     ( -- n ) \ inline literal
                    433:       tos push.w:g
                    434:       [ip] , tos mov.w:g
1.3       pazsan    435:       # 2 , ip add.w:q
1.2       pazsan    436:       next,
1.1       pazsan    437:    End-Code
                    438: 
1.2       pazsan    439: Code: :doesjump
                    440: end-code
1.1       pazsan    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 )
1.3       pazsan    452:     tos push.w:g
1.1       pazsan    453:     next,
                    454:    End-Code
                    455: 
                    456:   Code 2dup     ( d -- d d )
1.3       pazsan    457:     r1 pop.w:g
                    458:     r1 push.w:g
                    459:     tos push.w:g
                    460:     r1 push.w:g
1.1       pazsan    461:     next,
                    462:    End-Code
                    463: 
                    464:   Code drop     ( n -- )
1.3       pazsan    465:     tos pop.w:g
1.1       pazsan    466:     next,
                    467:    End-Code
                    468: 
                    469:   Code 2drop    ( d -- )
1.3       pazsan    470:     tos pop.w:g
                    471:     tos pop.w:g
1.1       pazsan    472:     next,
                    473:    End-Code
                    474: 
                    475:   Code swap     ( n1 n2 -- n2 n1 )
1.5       pazsan    476:     r1 pop.w:g
                    477:     tos push.w:g
                    478:     r1 , tos mov.w:g
1.1       pazsan    479:     next,
                    480:    End-Code
                    481: 
                    482:   Code over     ( n1 n2 -- n1 n2 n1 )
1.5       pazsan    483:     tos , r1 mov.w:g
                    484:     tos pop.w:g
                    485:     tos push.w:g
                    486:     r1 push.w:g
1.1       pazsan    487:     next,
                    488:    End-Code
                    489: 
                    490:   Code rot      ( n1 n2 n3 -- n2 n3 n1 )
1.5       pazsan    491:     tos , r1 mov.w:g
1.7       pazsan    492:     r3 pop.w:g
1.5       pazsan    493:     tos pop.w:g
1.7       pazsan    494:     r3 push.w:g
1.5       pazsan    495:     r1 push.w:g
1.7       pazsan    496:     r3 , r3 xor.w
1.1       pazsan    497:     next,
                    498:    End-Code
                    499: 
                    500:   Code -rot     ( n1 n2 n3 -- n3 n1 n2 )
1.5       pazsan    501:     tos , r1 mov.w:g
                    502:     tos pop.w:g
1.7       pazsan    503:     r3 pop.w:g
1.5       pazsan    504:     r1 push.w:g
1.7       pazsan    505:     r3 push.w:g
                    506:     r3 , r3 xor.w
1.1       pazsan    507:     next,
                    508:    End-Code
                    509: 
                    510: 
                    511:  \ return stack
                    512:   Code r@       ( -- n ; R: n -- n )
1.5       pazsan    513:     tos push.w:g
                    514:     rp , w mov.w:g
                    515:     [w] , tos mov.w:g
1.1       pazsan    516:     next,
                    517:   End-Code
                    518: 
                    519: 
                    520:  \ arithmetic
                    521: 
                    522:   Code um*      ( u1 u2 -- ud ) \ unsigned multiply
1.7       pazsan    523:       rp , r3 mov.w:g
1.5       pazsan    524:       r2 pop.w:g
1.24      pazsan    525:       r2 , r2r0 mulu.w:g
1.5       pazsan    526:       r0 push.w:g
                    527:       r2 , tos mov.w:g
1.7       pazsan    528:       r3 , rp mov.w:g
                    529:       r3 , r3 xor.w
1.5       pazsan    530:       next,
1.1       pazsan    531:    End-Code
                    532: 
1.16      pazsan    533:   Code m*      ( u1 u2 -- ud ) \ unsigned multiply
                    534:       rp , r3 mov.w:g
                    535:       r2 pop.w:g
1.24      pazsan    536:       r2 , r2r0 mul.w:g
1.16      pazsan    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: 
1.1       pazsan    544:   Code um/mod   ( ud u -- r q ) \ unsiged divide
1.7       pazsan    545:       rp , r3 mov.w:g
1.5       pazsan    546:       tos , r1 mov.w:g
                    547:       r2 pop.w:g
                    548:       tos pop.w:g
1.24      pazsan    549:       r3r1 divu.w
1.5       pazsan    550:       r2 push.w:g
1.7       pazsan    551:       r3 , rp mov.w:g
                    552:       r3 , r3 xor.w
1.5       pazsan    553:       next,
1.1       pazsan    554:    End-Code
                    555: 
                    556:  \ shift
                    557:   Code 2/       ( n1 -- n2 ) \ arithmetic shift right
1.18      pazsan    558:      # -1 , tos sha.w 
                    559:  \    # -1 , r1h mov.b:q
                    560:  \    r1h , tos sha.w
1.1       pazsan    561:      next,
                    562:    End-Code
                    563: 
                    564:   Code lshift   ( n1 n2 -- n3 ) \ shift n1 left n2 bits
1.7       pazsan    565:  \     tos.b , r1h mov.w:g
1.14      pazsan    566:       tos.b , r1h mov.b:g  \ ? hfs
                    567:       tos pop.w:g
                    568:       r1h , tos shl.w
                    569:       next,
1.1       pazsan    570:    End-Code
                    571: 
                    572:   Code rshift   ( n1 n2 -- n3 ) \ shift n1 right n2 bits
1.7       pazsan    573: \     tos.b , r1h mov.w:g
1.14      pazsan    574:       tos.b , r1h mov.b:g  \ ? hfs
                    575:       r1h neg.b
                    576:       tos pop.w:g
                    577:       r1h , tos shl.w
1.1       pazsan    578:      next,
                    579:    End-Code
                    580: 
                    581:  \ compare
                    582:   Code 0=       ( n -- f ) \ Test auf 0
1.5       pazsan    583:     tos , tos tst.w
1.18      pazsan    584:     0= IF  # -1 , tos mov.w:q   next,
                    585:     THEN   #  0 , tos mov.w:q   next,
1.1       pazsan    586:     next,
                    587:    End-Code
                    588: 
1.10      pazsan    589:    Code 0<       ( n -- f ) \ Test auf 0
                    590:     tos , tos tst.w
1.18      pazsan    591:     0< IF  # -1 , tos mov.w:q   next,
                    592:     THEN   #  0 , tos mov.w:q   next,
1.10      pazsan    593:     next,
                    594:    End-Code
                    595: 
1.1       pazsan    596:   Code =        ( n1 n2 -- f ) \ Test auf Gleichheit
1.5       pazsan    597:     r1 pop.w:g
                    598:     r1 , tos sub.w:g
1.18      pazsan    599:     0= IF  # -1 , tos mov.w:q   next,
                    600:     THEN   #  0 , tos mov.w:q   next,
1.1       pazsan    601:    End-Code
                    602: 
1.16      pazsan    603:    ' = alias u=
                    604:    
1.10      pazsan    605:   Code u<        ( n1 n2 -- f ) \ Test auf Gleichheit
                    606:     r1 pop.w:g
                    607:     r1 , tos sub.w:g
1.18      pazsan    608:     u> IF  # -1 , tos mov.w:q   next,
                    609:     THEN   #  0 , tos mov.w:q   next,
1.10      pazsan    610:    End-Code
                    611: 
                    612:   Code u>        ( n1 n2 -- f ) \ Test auf Gleichheit
                    613:     r1 pop.w:g
                    614:     r1 , tos sub.w:g
1.18      pazsan    615:     u< IF  # -1 , tos mov.w:q   next,
                    616:     THEN   #  0 , tos mov.w:q   next,
1.10      pazsan    617:    End-Code
                    618: 
1.23      pazsan    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: 
1.3       pazsan    633:   Code (key)    ( -- char ) \ get character
1.5       pazsan    634:       tos push.w:g
1.18      pazsan    635:       BEGIN  3 , $AD  btst:g  0<> UNTIL
1.27      pazsan    636:       $AE  , tos mov.w:g  r0h , r0h xor.b
1.3       pazsan    637:     next,
                    638:    End-Code
                    639: 
                    640:   Code (emit)     ( char -- ) \ output character
1.18      pazsan    641:       BEGIN  1 , $AD  btst:g  0<> UNTIL
1.7       pazsan    642:       tos.b , $AA  mov.b:g
1.5       pazsan    643:       tos pop.w:g
                    644:       next,
1.3       pazsan    645:   End-Code
                    646: 
1.1       pazsan    647:  \ additon io routines
                    648:   Code (key?)     ( -- f ) \ check for read sio character
1.5       pazsan    649:       tos push.w:g
1.18      pazsan    650:       3 , $AD  btst:g
                    651:       0<> IF  # -1 , tos mov.w:q   next,
                    652:       THEN    #  0 , tos mov.w:q   next,
1.1       pazsan    653:    End-Code
                    654: 
                    655:   Code emit?    ( -- f ) \ check for write character to sio
1.5       pazsan    656:       tos push.w:g
1.18      pazsan    657:       1 , $AD  btst:g
                    658:       0<> IF  # -1 , tos mov.w:q   next,
                    659:       THEN    #  0 , tos mov.w:q   next,
1.1       pazsan    660:    End-Code
                    661: 
1.23      pazsan    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
1.14      pazsan    669: 
1.23      pazsan    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:    
1.24      pazsan    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+ ;
1.23      pazsan    703:        
1.18      pazsan    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: 
1.16      pazsan    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
1.14      pazsan    727:        tos pop.w:g
                    728:        next,
                    729:    end-code
1.16      pazsan    730:    
1.33    ! pazsan    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!
1.14      pazsan    739: 
1.33    ! pazsan    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:    
1.30      pazsan    748:    $400 constant ram-start
                    749:    $2FFC Constant ram-shadow
                    750:    0 Constant ram-mirror
                    751:    0 Constant ram-size
1.14      pazsan    752:    $E0 Constant port0
                    753:    $E1 Constant port1
                    754:    
                    755:    : led!  port1 c! ;
1.16      pazsan    756:    : >lcd ( 4bit -- )
                    757:        1+ dup port0 c! dup 8 + port0 c!  1 us  port0 c!
                    758:        &40 us ;
1.14      pazsan    759:    : lcdctrl!  ( n -- )
                    760:        dup $F0 and >lcd
                    761:        4 lshift >lcd
1.16      pazsan    762:        &100 us ;
                    763:    : lcdemit ( n -- )  &100 us
1.14      pazsan    764:        dup $F0 and 4 + >lcd
                    765:        4 lshift 4 + >lcd
1.16      pazsan    766:        &250 us ;
1.14      pazsan    767:    : lcdtype  bounds ?DO  I c@ lcdemit  LOOP ;
1.16      pazsan    768:    : lcdpage  $01 lcdctrl! &15 ms ;
1.14      pazsan    769:    : lcdcr    $C0 lcdctrl! ;
                    770:    : lcdinit ( -- )
1.32      pazsan    771:        $02 $0A bset $FD $E2 c!
1.25      pazsan    772:        &20 ms $30 >lcd  5 ms  $33 lcdctrl! 5 ms $20 >lcd
1.16      pazsan    773:        &5 ms  $28 lcdctrl!
                    774:        &1 ms  $0C lcdctrl!
                    775:        &1 ms  lcdpage ;
1.25      pazsan    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 @ ;
1.18      pazsan    779:    : ?flash  BEGIN  $1B7 c@ 1 and 1 =  UNTIL ;
                    780:    : flashc! ( c addr -- )  $40 over c! c! ?flash ;
1.20      pazsan    781:    : flash! ( x addr -- )  2dup flashc! >r 8 rshift r> 1+ flashc! ;
1.18      pazsan    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! ;
1.23      pazsan    784:    : 9k6   $8105 $A8 ! ; \ baud setting
                    785:    : 38k4  $2005 $A8 ! ; \ fast terminal
1.33    ! pazsan    786:    : r8cboot ( -- )  timer-init flash-enable lcdinit 38k4
1.23      pazsan    787:        s" Gforth EC R8C" lcdtype boot ;
1.14      pazsan    788:    ' r8cboot >body $C002 !
1.26      pazsan    789:    : savesystem ( -- )
1.28      pazsan    790:        dpp @ >r rom here normal-dp @ ram-start tuck - tuck
1.29      pazsan    791:        here over allot r> dpp ! -rot
                    792:        bounds ?DO  I c@ over flashc! 1+  LOOP  drop
1.22      pazsan    793:        ram-shadow tuck flash! cell+ flash! ;
1.26      pazsan    794:    : refill-loop ( -- )
                    795:        BEGIN  3 emit refill  WHILE  interpret  REPEAT ;   
                    796:    : included ( addr u -- )  echo off
1.27      pazsan    797:        2 emit dup $20 + emit type ['] refill-loop catch
1.26      pazsan    798:        dup IF  4 emit  THEN  echo on  throw ;
                    799:    : include ( "file" -- )  parse-name included ;
1.27      pazsan    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 ! ;
1.18      pazsan    803: 
1.3       pazsan    804: : (bye)     ( 0 -- ) \ back to DOS
1.26      pazsan    805:     drop 5 emit ;
1.1       pazsan    806: 
                    807: : bye ( -- )  0 (bye) ;
                    808:     
1.3       pazsan    809: : x@+/string ( addr u -- addr' u' c )
                    810:     over c@ >r 1 /string r> ;
1.18      pazsan    811: 

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