File:  [gforth] / gforth / arch / 4stack / asm.fs
Revision 1.13: download - view: text, annotated - select for diffs
Sat Nov 1 22:19:30 2008 UTC (14 years ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD
updated copyright years

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

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