File:  [gforth] / gforth / arch / 4stack / asm.fs
Revision 1.4: download - view: text, annotated - select for diffs
Sat Sep 23 15:47:01 2000 UTC (22 years, 2 months ago) by anton
Branches: MAIN
CVS tags: v0-6-1, v0-6-0, v0-5-0, HEAD
changed FSF address in copyright messages

    1: \ four stack assembler                                 19jan94py
    2: 
    3: \ Copyright (C) 2000 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: Vocabulary asm4stack
   22: Vocabulary asmdefs
   23: 
   24: asm4stack also asmdefs also definitions Forth
   25: 
   26: ' asm4stack Alias [A] immediate
   27: ' Forth     Alias [F] immediate
   28: : :A asm4stack definitions Forth ;
   29: : :D asmdefs   definitions Forth ;
   30: 
   31: \ assembly area setup                                  24apr94py
   32: 
   33: Defer '2@
   34: Defer '2!
   35: Defer 'c!
   36: Defer '!
   37: Defer 'SF!
   38: Defer 'F!
   39: Defer 4here
   40: Defer 4allot
   41: 
   42: \ frame format:
   43: \ { target addr, target length, host addr, framelink }
   44: 
   45: : 4there  4here ;
   46: 
   47: : op!       '2! ;
   48: : op,       4there op!  2 cells 4allot ;
   49: : op@       '2@ ;
   50: : caddr  ;  immediate
   51: : waddr  ;  immediate
   52: : laddr  ;  immediate
   53: [THEN]
   54: 
   55: \ instruction generation                               24apr94py
   56: 
   57: 2Variable ibuf       0. ibuf 2!
   58: Variable  instfield  0  instfield !
   59: Variable  condfield  0  condfield !
   60: Variable  lastmove   0  lastmove !
   61: 
   62: Create instmasks  $003FFFFF.FFFFFFFF , ,
   63:                   $FFC00FFF.FFFFFFFF , , 
   64:                   $FFFFF003.FFFFFFFF , ,
   65:                   $FFFFFFFC.00FFFFFF , ,
   66:                   $FFFFFFFF.FF003FFF , ,
   67:                   $FFFFFFFF.FFFFC00F , ,
   68: 
   69: : instshift ( 10bit -- 64bit )
   70:   1 5 instfield @ - &10 * 4 + $20 /mod >r
   71:   lshift um* r> IF  swap  THEN ;
   72: 
   73: : 2and  ( d1 d2 -- d )  rot and -rot and swap ;
   74: : 2or   ( d1 d2 -- d )  rot or  -rot or  swap ;
   75: 
   76: : !inst ( 10bit -- )  instshift
   77:   instfield @ 2* cells instmasks + 2@ ibuf 2@ 2and 2or ibuf 2!
   78:   1 instfield +! ;
   79: 
   80: : finish ( -- )  ibuf 2@ op,
   81:   0 0 ibuf 2!  instfield off  condfield off lastmove off ;
   82: : finish?   instfield @ IF  finish  THEN ;
   83: :A
   84: : ;;  ( -- )  finish?  postpone \ ;
   85: : .org ( n -- )  4here - 4allot ;
   86: :D
   87: 
   88: \ checks for instruction slots                         19jan94py
   89: 
   90: : alu?  ( -- flag )  instfield @ 0 4 within ;
   91: : move? ( -- flag )  instfield @ 4 6 within
   92:   ibuf cell+ @ 3 and 1 <> and ;
   93: : call? ( -- flag )  instfield @ 4 < ;
   94: : br?   ( -- flag )  instfield @ 5 < ;
   95: 
   96: : ?finish ( -- )  instfield @ 6 = IF  finish  THEN ;
   97: 
   98: \ automatic feed of instructions                       19jan94py
   99: 
  100: Variable lastalu
  101: Variable lastalufield
  102: 
  103: : !alu  ( 10bit -- )
  104:   alu? 0= IF  finish  THEN
  105:   dup lastalu !
  106:   instfield @ lastalufield !
  107:   !inst ;
  108: 
  109: : !data ( 10bit -- )  alu? IF  4 instfield !  THEN
  110:   move? 0= IF  finish 4 instfield !  THEN
  111:   instfield @ lastmove !  !inst ;
  112: 
  113: : !br ( 10bit likelyhood -- addr )
  114:   br? 0= abort" No Data in Branch!"
  115:   alu? IF  4 instfield !  THEN  >r !inst
  116:   ibuf 2@  2 r> 3 and 2* 2* + 0 2or  ibuf 2!  4here ;
  117: :A
  118: : do   ( -- addr )     0 0 !br finish ;
  119: : br   ( -- addr )  $200 1 !br ;
  120: 
  121: : br,0 ( -- addr )  $200 0 !br ;
  122: : br,1 ( -- addr )  $200 1 !br ;
  123: 
  124: : call ( -- addr )  call? 0= IF  finish  THEN
  125:   6 instfield !  ibuf 2@ $0.00000003 2or  ibuf 2!  4here ;
  126: : jmp  ( -- addr )  call? 0= IF  finish  THEN
  127:   6 instfield !  ibuf 2@ $1.00000003 2or  ibuf 2!  4here ;
  128: 
  129: : calla ( -- addr )  call? 0= IF  finish  THEN
  130:   6 instfield !  ibuf 2@ $2.00000003 2or  ibuf 2!  4here ;
  131: : jmpa  ( -- addr )  call? 0= IF  finish  THEN
  132:   6 instfield !  ibuf 2@ $3.00000003 2or  ibuf 2!  4here ;
  133: :D
  134: 
  135: \ branch conditions                                    20mar94py
  136: 
  137: Create and/or-tab
  138:        $08 c, $04 c, $02 c, $01 c,
  139:        $1C c, $1A c, $19 c, $16 c, $15 c, $13 c,
  140:        $1E c, $1D c, $1B c, $17 c,
  141:        $1F c,
  142:        $0C c, $0A c, $09 c, $06 c, $05 c, $03 c,
  143:        $0E c, $0D c, $0B c, $07 c,
  144:        $0F c,
  145: 
  146: : >and/or ( n -- stacks )  and/or-tab + c@ ;
  147: 
  148: : constants  0 ?DO  constant  LOOP ;
  149: 
  150: :A
  151: hex
  152: 9 8 7 6 5 4       6 constants  0&1 0&2 0&3 1&2 1&3 2&3
  153: D C B A           4 constants  0&1&2 0&1&3 0&2&3 1&2&3
  154: E                   constant   0&1&2&3
  155: 
  156: 14 13 12 11 10 F  6 constants  0|1 0|2 0|3 1|2 1|3 2|3
  157: 18 17 16 15       4 constants  0|1|2 0|1|3 0|2|3 1|2|3
  158: 19                  constant   0|1|2|3
  159: decimal
  160: :D
  161: 
  162: \ branch conditions                                    20mar94py
  163: 
  164: Create condmasks  $FF07FFFF ,
  165:                   $FFF83FFF ,
  166:                   $FFFFC1FF ,
  167:                   $FFFFFE0F ,
  168: 
  169: : !cond  ( n -- )  condfield @ 3 > abort" too much conds!"
  170:   $1F and 3 condfield @ - 5 * 4 + lshift
  171:   ibuf cell+ @  condmasks condfield @ cells + @ and or
  172:   ibuf cell+ !  1 condfield +!
  173:   condfield @ 2/ 4 + instfield ! ;
  174: 
  175: \ branch conditions                                    20mar94py
  176: 
  177: : brcond ( n flag -- )  swap >and/or !cond !cond ;
  178: 
  179: : cond:  ( n -- )  Create ,
  180:   DOES> ( n/ -- )  @  ibuf cell+ @ 3 and
  181:   dup 2 = IF    drop condfield @ dup 0=
  182:                 IF  drop  brcond  EXIT  THEN
  183:           ELSE  dup 0=
  184:                 IF    1 ibuf cell+ +!
  185:                 ELSE  1 <>  THEN  THEN
  186:   abort" Misplaced condition"  !cond ;
  187: 
  188: : conds: ( end start -- )  DO  I cond:  LOOP ;
  189: 
  190: :A
  191: $08 $00 conds:  :t   :0=  :0<  :ov  :u<  :u>  :<  :>
  192: $10 $08 conds:  :f   :0<> :0>= :no  :u>= :u<= :>= :<=
  193: $18 $10 conds:  ?t   ?0=  ?0<  ?ov  ?u<  ?u>  ?<  ?>
  194: $20 $18 conds:  ?f   ?0<> ?0>= ?no  ?u>= ?u<= ?>= ?<=
  195: :D
  196: 
  197: \ loop/branch resolve                                  19mar94py
  198: 
  199: : resolve! ( dist addr -- )
  200:   >r  r@ op@ drop 3 and
  201:   dup 2 =  IF    drop $3FF8 and 0  ELSE
  202:       dup 3 =  IF    drop -8 and 0
  203: 	  r@ op@ nip 2 and IF  swap r@ 8 + + swap  THEN
  204:            ELSE  true abort" No Jump!"  THEN THEN
  205:   r@ op@ 2or r> op! ;
  206: 
  207: :A
  208: : .loop  ( addr -- )  finish?  dup >r 4here swap - 8 -
  209:   dup $2000 u>= abort" LOOP out of range!" r> resolve! ;
  210: : .endif ( addr -- )  finish?  dup >r 4here swap - 8 -
  211:   dup $1000 -$1000 within abort" BR out of range!"
  212:   r> resolve! ;
  213: 
  214: : .begin ( -- addr )  finish? 4here ;
  215: : .until ( addr1 addr2 -- )  finish?  dup >r - 8 -
  216:   dup $1000 -$1000 within abort" BR out of range! "
  217:   r> resolve! ;
  218: 
  219: : +IP ( addr1 rel -- )  finish? 8 * swap resolve! ;
  220: : >IP ( addr1 addr -- )  finish? over 8 + - swap resolve! ;
  221: :D
  222: 
  223: \ labels                                               23may94py
  224: 
  225: Vocabulary symbols
  226: : symbols[  symbols definitions ;
  227: : symbols]  forth   definitions ;
  228: 
  229: Create makesym"   ," label: "  here $40 allot AConstant symname
  230: 
  231: : sym-lookup? ( addr len -- xt/0 )
  232:   [ ' symbols >body ] ALiteral search-wordlist
  233:   0= IF  0  THEN ;
  234: : >sym" ( addr len -- )  symname swap move ;
  235: : sym, ( addr len -- addr )   drop ;
  236: \  symframe cell+ 2@ + swap ( --> addr target len )
  237: \  2dup aligned dup cell+ symframe cell+ +!
  238: \  2dup + >r cell+ erase move r> ( --> addr ) ;
  239: : symbol,  ( addr len -- xt )  dup >r
  240:   2dup >sym"  sym,
  241:   also asmdefs  makesym" count r> + evaluate  previous ;
  242: : label:  ( addr -- xt )
  243:   symbols[ Create symbols] 0 A, , lastxt
  244:   DOES>  ( addr -- )  dup cell+ @ @ dup
  245:          IF  nip >IP  EXIT  THEN
  246:          drop dup @ here rot ! A, , ;
  247: : reveal: ( addr xt -- )  >body 2dup cell+ @ !
  248:   BEGIN  @ dup  WHILE
  249:          2dup cell+ @ swap >IP  REPEAT  2drop ;
  250: :A
  251: : .globl  ( -- )  0 bl word count symbol, ;
  252: :D
  253: 
  254: : is-label?  ( addr u -- flag )  drop c@ '@ >= ;
  255: : ?label ( addr u -- )
  256:   2dup is-label?
  257:   IF  2dup 1- + c@ ': = dup >r +
  258:       2dup sym-lookup? dup 0=
  259:       IF  drop symbol,  ELSE  nip nip  THEN
  260:       r@ IF  finish? 4here over reveal:  THEN
  261:       r> 0= IF  execute  ELSE  drop  THEN  EXIT
  262:   THEN
  263:   defers interpreter-notfound ;
  264: 
  265: \ >call                                                09sep94py
  266: 
  267: : >call  call? 0= IF  finish  THEN  3 instfield ! ;
  268: 
  269: \ simple instructions                                  19jan94py
  270: 
  271: : alu: ( 10bit -- )  Create ,  DOES>  @ !alu ;
  272: 
  273: : readword ( -- )
  274:   BEGIN  >in @  bl word count dup 0=
  275:          WHILE  refill 2drop 2drop  REPEAT   2drop >in ! ;
  276: 
  277: : alus: ( start end step -- )  -rot swap
  278:   ?DO  readword  I alu:
  279: \       s" --" compare
  280: \       IF  >in !  I alu:  ELSE  drop  THEN
  281:        dup +LOOP  drop ;
  282: 
  283: :A
  284: %0000001001 %0110001001 %100000
  285: alus: or    add   addc   mul
  286:       and   sub   subc   umul
  287:       xor   subr  subcr  pass
  288: 
  289: \ s1p is default
  290: 
  291: \ mul@                                                 19jan94py
  292: 
  293: %0110100000 %0110110000 1
  294: alus:  mul@    mul<@    mulr@    mulr<@
  295:       -mul@   -mul<@   -mulr@   -mulr<@
  296:        mul@+   mul<@+   mulr@+   mulr<@+
  297:       -mul@+  -mul<@+  -mulr@+  -mulr<@+
  298: 
  299: \ flag generation                                      19jan94py
  300: 
  301: %0110110000 %0111000000 1
  302: alus:  t   0=  0<  ov  u<  u>  <  >
  303:        f   0<> 0>= no  u>= u<= >= <=
  304: 
  305: \ T4                                                   19jan94py
  306: 
  307: %0111000000 %0111100000 1
  308: alus: asr    lsr    ror    rorc    asl    lsl    rol    rolc
  309:       ff1    popc   lob    loh     extb   exth   hib    hih
  310:       sp@    loops@ loope@ ip@     sr@    cm@    index@ flatch@
  311:       sp!    loops! loope! ip!     sr!    cm!    index! flatch!
  312: 
  313: \ T5, floating point:                                  19jan94py
  314: 
  315: %0111100000 %0111110000 1
  316: alus:  fadd     fsub     fmul     fnmul
  317:        faddadd  faddsub  fmuladd  fmulsub
  318:        fi2f     fni2f    fadd@    fmul@
  319:        fs2d     fd2s     fxtract  fiscale
  320: 
  321: \ %0111110000 %0111110100 1
  322: \ alus:  ext    extu   mak    clr
  323: 
  324: %0111110000 %0111110010 1  alus:  bfu  bfs
  325: %0111110100 %0111110110 1  alus:  cc@  cc!
  326: 
  327: %0111111000 %1000000000 1
  328: alus:  px1 px2 px4 px8
  329:        pp1 pp2 pp4 pp8
  330: :D
  331: 
  332: \ Stack effects                                        19jan94py
  333: 
  334: : >curstack ( 5bit -- 5bit )  lastalufield @ 2* 2* xor ;
  335: 
  336: : >stack ( alu -- )  lastalufield @
  337:   dup 1+ instfield @ <> ABORT" Spurious stack address!"
  338:   instfield ! !alu ;
  339: 
  340: \ pick and pin                                         21jan94py
  341: 
  342: : pin,  ( 5bit -- )  dup %10000 and
  343:   IF    >curstack  dup %11 and swap  %01100 and
  344:   ELSE  dup %11 and %100 + swap  %10000 %01100 within
  345:   THEN  ABORT" Only current stack!"
  346:   %0110000000 or >stack ;
  347: 
  348: : pick,  ( 5bit -- )
  349:   dup %00000 %00100 within ABORT" No constant"
  350:   %0110000000 or >stack ;
  351: 
  352: :A
  353: %0110000000 alu: pin
  354: 
  355: : pick  ( -- )
  356:   alu? 0= IF  finish  THEN
  357:   instfield @ lastalufield !  %0110010000  >curstack !alu ;
  358: :D
  359: 
  360: \ Stack addresses                                      21jan94py
  361: 
  362: : !stack ( 5bit -- )
  363:   lastalu @ %0110000000 =  IF  pin,  EXIT  THEN
  364:   lastalu @ %0110010000 >curstack  =  IF  pick,  EXIT  THEN
  365:   lastalu @ %11111 and %01001 <> ABORT" Only one address!"
  366:   lastalu @ %1111100000 and or
  367:   dup %0110000000 u>= ABORT" no ALU instruction!" >stack ;
  368: 
  369: : stack: ( 5bit -- )  Create ,  DOES>  @ !stack ;
  370: 
  371: : stacks: ( n -- )
  372:   0 ?DO  readword  I stack:  LOOP ;
  373: 
  374: :A
  375: $20 stacks:  #0         #-1         #$7FFFFFFF  #$80000000
  376:              c0         c1          c2          c3
  377:              s0p        s1p         s2p         s3p
  378:              s4         s5          s6          s7
  379:              0s0        0s1         0s2         0s3
  380:              1s0        1s1         1s2         1s3
  381:              2s0        2s1         2s2         2s3
  382:              3s0        3s1         3s2         3s3
  383: :D
  384: 
  385: \ relativ to current stack                             21jan94py
  386: 
  387: : curstack: ( 5bit -- )
  388:   Create ,  DOES>  @ >curstack !stack ;
  389: 
  390: :A
  391: %10000 curstack: s0
  392: %10001 curstack: s1
  393: %10010 curstack: s2
  394: %10011 curstack: s3
  395: 
  396: \ Abbrevations                                         21jan94py
  397: 
  398: ' #$7FFFFFFF Alias #max
  399: ' #$80000000 Alias #min
  400: 
  401: \ FP abbrevations                                      21jan94py
  402: 
  403: [A]
  404: : fabs  and #max ;
  405: : fneg  xor #min ;
  406: : f2*   add c3 ;
  407: : f2/   sub c3 ;
  408: 
  409: \ ALU abbrevations                                     21jan94py
  410: 
  411: : nop   or   #0 ;
  412: : not   xor #-1 ;
  413: : neg   subr #0 ;
  414: : inc   sub #-1 ;
  415: : dec   add #-1 ;
  416: 
  417: \ Stack abbrevations                                   21jan94py
  418: 
  419: : dup   pick s0 ;
  420: : over  pick s1 ;
  421: : swap  pick s1p ;
  422: : rot   pick s2p ;
  423: : drop  pin  s0 ;
  424: : nip   pin  s1 ;
  425: 
  426: \ ret                                                  19mar94py
  427: 
  428: : ret   ( -- ) >call ip! ;
  429: 
  430: [F]
  431: :D
  432: 
  433: \ Literals                                             21mar94py
  434: 
  435: : !a/d  ( 10bit -- ) ?finish
  436:     alu?  IF  $200 or !alu  ELSE  !data  THEN ;
  437: Create lits  0. 2, 0. 2, 0. 2, 0. 2,  0. 2, 0. 2,
  438: 
  439: :A
  440: : #  ( 8bit -- )  dup $80 -$80 within abort" out of range"
  441:   $FF and !a/d ;
  442: : #< ( 8bit -- )  dup $100 0  within abort" out of range"
  443:   $100 or !a/d ;
  444: 
  445: : ## ( 32bit -- )  ?finish  3
  446:   BEGIN  over $FF800000 and dup $FF800000 = swap 0= or  WHILE
  447:          1- swap 8 lshift swap  dup 0= UNTIL  THEN
  448:   swap $100 um*  dup $80 and negate or >r
  449:   swap lits instfield @ 2* cells + 2!  r> [A] # [F] ;
  450: 
  451: : #, ( -- )  ?finish  lits instfield @ 2* cells + dup 2@ dup 0>
  452:   IF    over 0= alu? and
  453:         IF  dup 3 =  IF  hib  2drop  0 0 rot 2!  EXIT THEN
  454:             dup 2 =  IF  hih  2drop  0 0 rot 2!  EXIT THEN THEN
  455:         1- >r $100 um* #< r> rot 2!
  456:   ELSE  2drop drop  alu? IF  nop  ELSE  0 #  THEN  THEN ;
  457: :D
  458: 
  459: : >ip.b  ( -- )
  460:   bl word count sym-lookup? dup 0= abort" No symbol!"
  461:   >body cell+ @ @ 4here 2 cells + - ;
  462: :A
  463: : .ip.b#  ( -- )    >ip.b                [A] # [F] ;
  464: : .ip.h#  ( -- )    >ip.b 2/             [A] # [F] ;
  465: : .ip.w#  ( -- )    >ip.b 2/ 2/          [A] # [F] ;
  466: : .ip.2#  ( -- )    >ip.b 2/ 2/ 2/       [A] # [F] ;
  467: : .ip.4#  ( -- )    >ip.b 2/ 2/ 2/ 1+ 2/ [A] # [F] ;
  468: ' .ip.2# alias .ip.d#
  469: ' .ip.2# alias .ip.f#
  470: ' .ip.4# alias .ip.q#
  471: ' .ip.4# alias .ip.2f#
  472: :D
  473: Variable procstart
  474: : >p.b  ( -- )
  475:   bl word count sym-lookup? dup 0= abort" No symbol!"
  476:   >body cell+ @ @ procstart @ - ;
  477: :A
  478: : .proc  finish?  4here procstart ! ;
  479: : .p     ( -- n )  >p.b                       ;
  480: : .p.b#  ( -- )    >p.b             [A] # [F] ;
  481: : .p.h#  ( -- )    >p.b 2/          [A] # [F] ;
  482: : .p.w#  ( -- )    >p.b 2/ 2/       [A] # [F] ;
  483: : .p.2#  ( -- )    >p.b 2/ 2/ 2/    [A] # [F] ;
  484: : .p.4#  ( -- )    >p.b 2/ 2/ 2/ 2/ [A] # [F] ;
  485: ' .p.2# alias .p.d#
  486: ' .p.2# alias .p.f#
  487: ' .p.4# alias .p.q#
  488: ' .p.4# alias .p.2f#
  489: : .p.b## ( -- )    >p.b             [A] ## [F] ;
  490: : .p.h## ( -- )    >p.b 2/          [A] ## [F] ;
  491: : .p.w## ( -- )    >p.b 2/ 2/       [A] ## [F] ;
  492: : .p.2## ( -- )    >p.b 2/ 2/ 2/    [A] ## [F] ;
  493: : .p.4## ( -- )    >p.b 2/ 2/ 2/ 2/ [A] ## [F] ;
  494: ' .p.2## alias .p.d##
  495: ' .p.2## alias .p.f##
  496: ' .p.4## alias .p.q##
  497: ' .p.4## alias .p.2f##
  498: :D
  499: 
  500: \ data instructions                                    20mar94py
  501: 
  502: : cu ( -- n )  instfield @ 1- 1 and  IF  4  ELSE  8  THEN ;
  503: : move:  ( n -- )  Create ,
  504:   DOES> @  !data  cu  ibuf cell+ tuck @ or swap ! ;
  505: : moves:  -rot ?DO  I move:  dup +LOOP  drop ;
  506: 
  507: :A
  508: %0010000000 %0000000000 %100000 moves: ldb ldh ld ld2
  509: %1010000000 %1000000000 %100000 moves: stb sth st st2
  510: 
  511: ' ld2 Alias ldf
  512: ' ld2 Alias ldq
  513: ' st2 Alias stf
  514: ' st2 Alias stq
  515: :D
  516: 
  517: \ data instructions                                    22mar94py
  518: 
  519: : ua:  ( n -- )  Create ,  DOES>  @ !data ;
  520: : uas: ( e s i -- )  -rot ?DO  i ua:  dup +LOOP  drop ;
  521: 
  522: :A
  523: %1000010000 %1000000000 %100 uas: R0= R1= R2= R3=
  524: %1001000000 ua: get
  525: %1001010000 ua: set
  526: %1001100000 ua: getd
  527: %1001110000 ua: setd
  528: 
  529: %1010010000 %1010000000 %100 uas: ccheck cclr cstore cflush
  530: %1010100000 %1010010100 %100 uas: cload calloc cxlock
  531: 
  532: %1010011000 %1010010000 %100 uas: mccheck mdcheck
  533: %1010011100 %1010011000 %001 uas: mcget mcset mchif mclof
  534: %1010100000 %1010011100 %001 uas: mdget mdset mdhif mdlof
  535: 
  536: %1011100000 %1011000000 %100 uas: inb inh in ind outb outh out outd
  537: %1011000011 %1011000001 %1   uas: inq ins
  538: 
  539: %1011100100 %1011100000 %1   uas: =c0  =c1  =c2  =c3
  540: 
  541: %1011101000 ua: geta
  542: %1011111000 ua: seta
  543: %1011101100 ua: getdrn
  544: %1011111100 ua: setdrn
  545: %1111101100 ua: getdmf
  546: %1111111100 ua: setdmf
  547: 
  548: %1011100100 ua: getc
  549: %1011110100 ua: setc
  550: %1011100101 ua: stop
  551: %1011110101 ua: restart
  552: %1011100110 ua: stop1
  553: %1011110110 ua: restart1
  554: %1011100111 ua: halt
  555: 
  556: :D
  557: 
  558: \ data instructions                                    20mar94py
  559: 
  560: : |inst ( 10bit n -- )
  561:   dup 0= abort" Only after moves!"
  562:   instfield @ >r  instfield !
  563:   instshift  ibuf 2@ 2or ibuf 2!  r> instfield ! ;
  564: : mode:  Create ,  DOES>  @ lastmove @ |inst ;
  565: 
  566: : modes:  DO  I mode:  4 +LOOP ;
  567: : regs:   DO  I mode:  LOOP ;
  568: 
  569: :A
  570: $10 $04 modes: +N  N+  +N+
  571: $20 $14 modes: +s0 s0+ +s0+
  572: 
  573: $10 $00 regs: R0 R1 R2 R3  N0 N1 N2 N3  L0 L1 L2 L3  F0 F1 F2 F3
  574: $14 $10 regs: ip s0b ip+s0 s0l
  575: :D
  576: 
  577: \ data instructions                                    22mar94py
  578: 
  579: : ua-only  true abort" Only for update!" ;
  580: : umode:  >in @ >r  name sfind  r> >in !  Create
  581:   0=  IF  ['] ua-only  THEN  swap , ,
  582:   DOES>  dup @ lastmove @ 1 and IF  4  ELSE  8  THEN
  583:   ibuf cell+ @ and  IF  drop cell+ @ execute  EXIT  THEN  
  584:   lastmove @ |inst drop ;
  585: 
  586: :A
  587: %0100000000 umode: +N
  588: %0000010000 umode: +s0
  589: %0000100000 umode: -N
  590: %0000110000 umode: -s0
  591: :D
  592: 
  593: \ data instructions                                    20mar94py
  594: 
  595: : stevnop: ( n -- )  Create ,
  596:   DOES>  @ lastmove @ 4 <> abort" Only even stacks!"  4 |inst ;
  597: : stoddop: ( n -- )  Create ,
  598:   DOES>  @ lastmove @ 5 <> abort" Only odd stacks!" 5 |inst ;
  599: 
  600: : stevnops: ( end start disp -- )  -rot
  601:   DO  I stevnop:  dup +LOOP  drop ;
  602: : stoddops: ( end start disp -- )  -rot
  603:   DO  I stoddop:  dup +LOOP  drop ;
  604: 
  605: :A
  606: %1000000000 %0000000000 %0010000000  stevnops: 0: 0&2: 2: 2&0:
  607: %1000000000 %0000000000 %0010000000  stoddops: 1: 1&3: 3: 3&1:
  608: :D
  609: 
  610: \ data definition instructions                         24apr94py
  611: 
  612: Defer normal-mode
  613: Defer char-mode
  614: 
  615: : number-mode ( n dest char -- n' dest' )
  616: \ ." Number: " dup emit cr
  617:   dup toupper digit?
  618:   IF  nip rot base @ * + dup $10000 >=
  619:       IF  normal-mode $100  THEN  swap EXIT  THEN
  620:   >r tuck caddr 'c! 1+ $100 swap r> normal-mode ;
  621: 
  622: : esc-mode ( dest char -- dest' )
  623: \ ." Escape: " dup emit cr
  624:   dup 'n = IF  drop #lf  normal-mode  EXIT  THEN
  625:   dup 't = IF  drop #tab normal-mode  EXIT  THEN
  626:   dup 'x = IF  drop hex ['] number-mode IS char-mode   EXIT THEN
  627:   dup '0 '8 within
  628:   IF  8 base ! ['] number-mode IS char-mode char-mode  EXIT THEN
  629:   $100 + normal-mode ;
  630: 
  631: : (normal-mode) ( dest char -- dest' )
  632: \ ." Char  : " dup emit cr
  633:   dup '\ = IF  drop ['] esc-mode IS char-mode  EXIT  THEN
  634:   over caddr 'c! 1+ ['] normal-mode IS char-mode ;
  635: ' (normal-mode) IS normal-mode
  636: 
  637: : \move  ( addr len dest -- dest+n )
  638:   base @ >r  ['] normal-mode IS char-mode
  639:   $100 swap 2swap bounds  ?DO  I c@ char-mode  LOOP
  640:   over $FF and 0> IF  tuck caddr 'c! 1+  ELSE  nip  THEN
  641:   r> base ! ;
  642: 
  643: : byte,   4there caddr  'c!  1        4allot ;
  644: : short,  $100 /mod 4there waddr  'c!
  645:               4there  waddr 1+ 'c!  2 4allot ;
  646: : int,    4there laddr   '!  1 cells  4allot ;
  647: : long,   4there laddr   '!  1 cells  4allot ;
  648: : quad,   op, ;
  649: \ : float,  4there laddr 'SF!  1 cells  4allot ;
  650: \ : double, 4there        'F!  1 floats 4allot ;
  651: 
  652: : ascii,  4there \move 4there - 4allot ;
  653: 
  654: :A
  655: : .align ( "n[,m]" -- )   0 0 name >number
  656:   dup IF  over c@ ', =
  657:           IF  1 /string parser  0 0  THEN  THEN
  658:   2drop  1 rot lshift  4here over 1- >r - r> and
  659:   0 ?DO  dup 4there caddr 'c!  1 4allot  LOOP  drop ;
  660: 
  661: : .(  ') parse also Forth evaluate previous ;
  662: 
  663: : .byte   name parser byte,   ;
  664: : .short  name parser short,  ;
  665: : .int    name parser int,    ;
  666: : .long   name parser long,   ;
  667: : .quad   name s>number dpl @ 0= abort" Not a number" quad, ;
  668: \ : .float  name >float 0= abort" Not a FP number" float,  ;
  669: \ : .double name >float 0= abort" Not a FP number" double, ;
  670: 
  671: : .ascii  '" parse 2drop
  672:   source  >in @ /string  over  swap
  673:   BEGIN  '"  scan   over 1- c@ '\ = over 0<> and  WHILE
  674:          1 /string  REPEAT  >r
  675:   over - dup r> IF 1+ THEN  >in +! ascii, ;
  676: 
  677: : .macro      finish?  also asmdefs also asm4stack definitions
  678:               : ;
  679: : .end-macro  postpone ; previous previous ; immediate restrict
  680: 
  681: : .include    include ;
  682: 
  683: : .times{  ( n -- input n )
  684:   dup >r 1 > IF  save-input  THEN  r> ;
  685: : .}times  ( input n -- input n-1 / 1 / )
  686:   1- dup 0>
  687:   IF  >r restore-input throw r@ 1 >
  688:       IF  save-input  THEN  r>
  689:   THEN ;
  690: :D
  691: 
  692: \ save assembler output                                25apr94py
  693: 
  694: : (fdump ( handle link -- )  2dup >r swap
  695:   3 cells + @  dup  IF  recurse  ELSE  2drop  THEN
  696:   r@ cell+ @ 0=  IF  rdrop drop  EXIT  THEN
  697: \ cr ." Writing " r@ @ . ." len " r@ cell+ @ .
  698:   r@ cell+ @ 7 + -8 and r@ cell+ !
  699:   r@ 2 cells 2 pick write-file throw
  700:   r@ cell+ cell+ @  dup 7 and 2 =  IF  2drop rdrop  EXIT  THEN
  701:   r> cell+ @  rot write-file throw ;
  702: 
  703: Create 4magic  ," 4stack00"
  704: 
  705: \ end of assembler
  706: 
  707: Variable old-notfound
  708: 
  709: :A
  710: : F' ' ;
  711: 
  712: also Forth definitions
  713: 
  714: : (code)
  715:     also asm4stack
  716:     s" F' 2@ F' 2! F' c! F' ! F' here F' allot" evaluate
  717:     IS 4allot  IS 4here  IS  '! IS  'c!  IS '2!  IS '2@
  718:     What's interpreter-notfound old-notfound !
  719:     ['] ?label IS interpreter-notfound ;
  720: : label (code) 4here label: drop asm4stack depth ;
  721: : (end-code) previous old-notfound @ IS interpreter-notfound ;
  722: 
  723: previous previous previous Forth
  724: 

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