File:  [gforth] / gforth / arch / 8086 / prim.fs
Revision 1.5: download - view: text, annotated - select for diffs
Mon Sep 1 22:12:47 2003 UTC (18 years, 8 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
a bit Gforth EC work
Changed Windows distribution to contain PDF instead of PostScript file

    1: \ **************************************************************
    2: \ File:         PRIMS.FS
    3: \                 Lowlevel routines for GFORTH on 8086 (PC)
    4: \ Autor:        Klaus Kohl
    5: \ Log:          30.07.97 KK:    file generated (from KK-FORTH)
    6: \
    7: \ * Register using for 8086 on PC (like KK-FORTH):
    8: \  Intel  Forth    used for                       8bit-Register
    9: \   BX     TOS   oberstes Stackelement             TOSH   TOSL
   10: \   BP     FRP   Returnstack Pointer
   11: \   SP     FSP   Stack Pointer
   12: \   SI     FIP   Instruction Pointer
   13: \   DI      W    Arbeitsregister
   14: \
   15: \ * Memory ( use only one 64K-Page ):
   16: \    $0080-$00FF : TIB
   17: \    $0100-$F800 : program
   18: \    $F800-$FC00 : datastack
   19: \    $FC00-$FFFF : returnstack
   20: \ **************************************************************
   21: 
   22: 
   23: start-macros
   24:  \ register definition
   25:   ' sp Alias fsp
   26:   ' bp Alias frp
   27:   ' bx Alias tos        ' bl Alias tosl  ' bh Alias tosh
   28:   ' si Alias fip
   29:   ' di Alias w
   30: 
   31:  \ system depending macros
   32:   : next,
   33:     lods,
   34:     ax w xchg,
   35:     w ) jmp, ;
   36: \ note that this is really for 8086 and 286, and _not_ intented to run
   37: \ fast on a Pentium (Pro). These old chips load their code from real RAM
   38: \ and do it slow, anyway.
   39: \ If you really want to have a fast 16 bit Forth on modern processors,
   40: \ redefine it as
   41: \ : next,  fip ) w mov,  2 # fip add,  w ) jmp, ;
   42: 
   43: end-macros
   44: 
   45:   unlock
   46:     $0100 $f000 region dictionary
   47:     setup-target
   48:   lock
   49: 
   50: \ ==============================================================
   51: \ rom starts with jump to GFORTH-kernel (must be at $0000 !!!)
   52: \ ==============================================================
   53:   Label into-forth
   54:     $ffff # fip mov,            \ ip will be patched
   55:     $fef0 # fsp mov,            \ sp at $FD80...$FEF0
   56:     $fd80 # frp mov,            \ rp at $F.00...$FD80
   57:     next,
   58:   End-Label
   59: 
   60: 
   61: \ output debug information
   62:   Label (dout)   \ like (emit) with character in dl
   63:     6 # ah mov,
   64:     $21 int,
   65:     ret,
   66:   End-Label
   67: 
   68: Start-Macros
   69: \  : dout,       ( char -- )
   70: \     # dl byte mov,
   71: \    (dout) # call, ;
   72:  : dout,  drop ;               \ no debug output
   73: end-macros
   74: 
   75: 
   76: \ ==============================================================
   77: \ GFORTH minimal primitive set
   78: \ ==============================================================
   79:  \ inner interpreter
   80:   Code: :docol
   81:      ': dout,                    \ only for debugging
   82:      frp dec,   frp dec,   fip frp ) mov,        \ save ip
   83:      4 w d) fip lea,                             \ calc pfa
   84:      next,
   85:    End-Code
   86: 
   87:   Code: :dovar
   88:     '2 dout,                    \ only for debugging
   89:     tos push,
   90:     4 w d) tos lea,
   91:     next,
   92:   End-Code
   93: 
   94:   Code: :dodoes  ( -- pfa ) \ get pfa and execute DOES> part
   95:     '6 dout,                    \ only for debugging
   96:      frp dec,   frp dec,   fip frp ) mov,        \ save ip
   97:      2 # w add,                                  \
   98:      w ) fip mov,                                \ get does> address
   99:      tos push,                                   \ save tos
  100:      2 # w add,
  101:      w tos mov,                                  \ copy pfa to tos
  102:      next,                                       \ execute does> part
  103:    End-Code
  104: 
  105: 
  106:  \ program flow
  107:   Code ;s       ( -- ) \ exit colon definition
  108:     '; dout,                    \ only for debugging
  109:     frp ) fip mov,   frp inc,  frp inc,         \ get ip
  110:     next,
  111:   End-Code
  112: 
  113:   Code execute   ( xt -- ) \ execute colon definition
  114:     'E dout,                    \ only for debugging
  115:     tos w mov,                                  \ copy tos to w
  116:     tos pop,                                    \ get new tos
  117:     w ) jmp,                                    \ execute
  118:   End-Code
  119: 
  120:   Code ?branch   ( f -- ) \ jump on f<>0
  121:     tos tos or,   tos pop,                      \ check and get new tos
  122:     0= IF,  fip ) fip add,      next,           \ jump
  123:     ELSE,   fip inc,  fip inc,  next,  THEN,    \ skip
  124:    End-Code
  125: 
  126: 
  127:  \ memory access
  128:   Code @        ( addr -- n ) \ read cell
  129:     tos ) tos mov,
  130:     next,
  131:    End-Code
  132: 
  133:   Code !        ( n addr -- ) \ write cell
  134:     tos ) pop,
  135:     tos pop,
  136:     next,
  137:    End-Code
  138: 
  139: 
  140:  \ datastack and returnstack address
  141:   Code sp@      ( -- sp ) \ get stack address
  142:     tos push,
  143:     fsp tos mov,
  144:     next,
  145:    End-Code
  146: 
  147:   Code sp!      ( sp -- ) \ set stack address
  148:     tos fsp mov,
  149:     tos pop,
  150:     next,
  151:   End-Code
  152: 
  153:   Code rp@      ( -- rp ) \ get returnstack address
  154:     tos push,
  155:     frp tos mov,
  156:     next,
  157:   End-Code
  158: 
  159:   Code rp!      ( rp -- ) \ set returnstack address
  160:     tos frp mov,
  161:     tos pop,
  162:     next,
  163:   End-Code
  164: 
  165: 
  166:  \ arithmetic and logic
  167:   Code +        ( n1 n2 -- n3 ) \ addition
  168:     ax pop,
  169:     ax tos add,
  170:     next,
  171:    End-Code
  172: 
  173:   Code xor      ( n1 n2 -- n3 ) \ logic XOR
  174:     ax pop,
  175:     ax tos xor,
  176:     next,
  177:    End-Code
  178: 
  179:   Code and      ( n1 n2 -- n3 ) \ logic AND
  180:     ax pop,
  181:     ax tos and,
  182:     next,
  183:    End-Code
  184: 
  185: 
  186:  \ i/o
  187:   Variable lastkey      \ Flag und Zeichencode der letzen Taste
  188: 
  189:   Code (key)    ( -- char ) \ get character
  190:     tos push,
  191:     lastkey #) ax mov,
  192:     ah ah or,  0= IF, 7 # ah mov,  $21 int, THEN,
  193:     0 # lastkey #) mov,
  194:     ah ah xor,
  195:     ax tos mov,
  196:     next,
  197:    End-Code
  198: 
  199:   Code (emit)     ( char -- ) \ output character
  200:     tosl dl mov,
  201:     6 # ah mov,
  202:     $ff # dl cmp,  0= IF, dl dec, THEN,
  203:     $21 int,
  204:     tos pop,
  205:     next,
  206:   End-Code
  207: 
  208: \ ==============================================================
  209: \ additional words (for awaitable response)
  210: \ ==============================================================
  211:  \ memory character access
  212:   Code c@       ( addr -- c ) \ read character
  213:     tos ) tosl mov,
  214:     tosh tosh xor,
  215:     next,
  216:    End-Code
  217: 
  218:   Code c!       ( c addr -- ) \ write character
  219:     ax pop,
  220:     al tos ) mov,
  221:     tos pop,
  222:     next,
  223:    End-Code
  224: 
  225: 
  226:  \ moving datas between stacks
  227:   Code r>       ( -- n ; R: n -- )
  228:     tos push,
  229:     frp ) tos mov,  frp inc,  frp inc,
  230:     next,
  231:    End-Code
  232: 
  233:   Code >r       ( n -- ; R: -- n )
  234:     frp dec,  frp dec,  tos frp ) mov,
  235:     tos pop,
  236:     next,
  237:    End-Code
  238: 
  239: \ ==============================================================
  240: \ usefull lowlevel words
  241: \ ==============================================================
  242:  \ word definitions
  243: 
  244:   Code: :docon
  245:     '1 dout,                    \ only for debugging
  246:     tos push,
  247:     4 w d) tos lea,
  248:     tos ) tos mov,
  249:     next,
  250:   End-Code
  251: 
  252:   Code: :dodefer
  253:     '4 dout,                    \ only for debugging
  254:     4 w d) w mov,
  255:     w ) jmp,
  256:   End-Code
  257: 
  258: 
  259:  \ branch and literal
  260:   Code branch   ( -- ) \ unconditional branch
  261:     fip ) fip add,
  262:     next,
  263:    End-Code
  264: 
  265:   Code lit     ( -- n ) \ inline literal
  266:     tos push,
  267:     lods,
  268:     ax tos mov,
  269:     next,
  270:    End-Code
  271: 
  272: 
  273:  \ data stack words
  274:   Code dup      ( n -- n n )
  275:     tos push,
  276:     next,
  277:    End-Code
  278: 
  279:   Code 2dup     ( d -- d d )
  280:     ax pop,
  281:     ax push,
  282:     tos push,
  283:     ax push,
  284:     next,
  285:    End-Code
  286: 
  287:   Code drop     ( n -- )
  288:     tos pop,
  289:     next,
  290:    End-Code
  291: 
  292:   Code 2drop    ( d -- )
  293:     2 # fsp add,
  294:     tos pop,
  295:     next,
  296:    End-Code
  297: 
  298:   Code swap     ( n1 n2 -- n2 n1 )
  299:     ax pop,
  300:     tos push,
  301:     ax tos mov,
  302:     next,
  303:    End-Code
  304: 
  305:   Code over     ( n1 n2 -- n1 n2 n1 )
  306:     tos ax mov,
  307:     tos pop,
  308:     tos push,
  309:     ax push,
  310:     next,
  311:    End-Code
  312: 
  313:   Code rot      ( n1 n2 n3 -- n2 n3 n1 )
  314:     tos ax mov,
  315:     cx pop,
  316:     tos pop,
  317:     cx push,
  318:     ax push,
  319:     next,
  320:    End-Code
  321: 
  322:   Code -rot     ( n1 n2 n3 -- n3 n1 n2 )
  323:     tos ax mov,
  324:     tos pop,
  325:     cx pop,
  326:     ax push,
  327:     cx push,
  328:     next,
  329:    End-Code
  330: 
  331: 
  332:  \ return stack
  333:   Code r@       ( -- n ; R: n -- n )
  334:     tos push,
  335:     frp ) tos mov,
  336:     next,
  337:   End-Code
  338: 
  339: 
  340:  \ arithmetic
  341:   Code -        ( n1 n2 -- n3 ) \ Subtraktion
  342:     ax pop,
  343:     tos ax sub,
  344:     ax tos mov,
  345:     next,
  346:    End-Code
  347: 
  348:   Code um*      ( u1 u2 -- ud ) \ unsigned multiply
  349:     tos ax mov,
  350:     cx pop,
  351:     cx mul,
  352:     ax push,
  353:     dx tos mov,
  354:     next,
  355:    End-Code
  356: 
  357:   Code um/mod   ( ud u -- r q ) \ unsiged divide
  358:     tos cx mov,
  359:     dx pop,
  360:     ax pop,
  361:     cx div,
  362:     dx push,
  363:     ax tos mov,
  364:     next,
  365:    End-Code
  366: 
  367: 
  368:  \ logic
  369:   Code or       ( n1 n2 -- n3 ) \ logic OR
  370:     ax pop,   ax tos or,   next,
  371:    End-Code
  372: 
  373: 
  374:  \ shift
  375:   Code 2/       ( n1 -- n2 ) \ arithmetic shift right
  376:      tos sar,
  377:      next,
  378:    End-Code
  379: 
  380:   Code lshift   ( n1 n2 -- n3 ) \ shift n1 left n2 bits
  381:      tos cx mov,
  382:      tos pop,
  383:      cx cx or,  0<> IF, tos c* shl, THEN,
  384:      next,
  385:    End-Code
  386: 
  387:   Code rshift   ( n1 n2 -- n3 ) \ shift n1 right n2 bits
  388:      tos cx mov,
  389:      tos pop,
  390:      cx cx or,  0<> IF, tos c* shr, THEN,
  391:      next,
  392:    End-Code
  393: 
  394: 
  395:  \ compare
  396:   Code 0=       ( n -- f ) \ Test auf 0
  397:     tos tos or,
  398:     0 # tos mov,
  399:     0= IF, tos dec, THEN,
  400:     next,
  401:    End-Code
  402: 
  403:   Code =        ( n1 n2 -- f ) \ Test auf Gleichheit
  404:     ax pop,
  405:     ax tos sub,
  406:     0= IF,  -1 # tos mov,   next,
  407:     ELSE,   0  # tos mov,   next,
  408:     THEN,
  409:    End-Code
  410: 
  411: 
  412:  \ additon io routines
  413:   Code (key?)     ( -- f ) \ check for read sio character
  414:     tos push, lastkey # tos mov,
  415:     1 tos d) ah mov,   ah ah or,
  416:     0= IF,  $ff # dl mov,  6 # ah mov,  $21 int,
  417:             0 # ah mov,
  418:             0<> IF, dl ah mov,   ax tos ) mov, THEN,
  419:     THEN,  ah tosl mov,   ah tosh mov,
  420:     next,
  421:    End-Code
  422: 
  423:   Code emit?    ( -- f ) \ check for write character to sio
  424:     tos push,
  425:     -1 # tos mov,             \ output always possible
  426:     next,
  427:    End-Code
  428: 
  429: \ ======================== not ready ============================
  430: 0 [IF]  \ not jet adapted
  431: 
  432: \ ======================== not ready ============================
  433: [ENDIF]
  434: 
  435:   Code (bye)     ( -- ) \ back to DOS
  436:      ax pop,  $4c # ah mov,  $21 int,
  437:     End-Code
  438: 
  439: : bye ( -- )  0 (bye) ;
  440:     
  441: Code: :doesjump
  442: end-code

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