Annotation of gforth/arch/4stack/asm.fs, revision 1.13

1.1       pazsan      1: \ four stack assembler                                 19jan94py
                      2: 
1.13    ! anton       3: \ Copyright (C) 2000,2003,2007,2008 Free Software Foundation, Inc.
1.3       anton       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
1.7       anton       9: \ as published by the Free Software Foundation, either version 3
1.3       anton      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
1.7       anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.3       anton      19: 
1.1       pazsan     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: 
1.11      pazsan     46: cell 8 = [IF]
                     47: : op!       >r drop $100000000 /mod r> '2! ;
                     48: : op@       '2@ $100000000 * + 0 ;
                     49: [ELSE]
1.1       pazsan     50: : op!       '2! ;
                     51: : op@       '2@ ;
1.11      pazsan     52: [THEN]
                     53: : op,       4there op!  8 4allot ;
1.1       pazsan     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: 
1.11      pazsan     65: 8 cells Constant bit/cell
                     66: 
1.1       pazsan     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 )
1.11      pazsan     75:   1 5 instfield @ - &10 * 4 + bit/cell /mod >r
1.1       pazsan     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,
1.11      pazsan    144:        $1C c, $1A c, $16 c, $19 c, $15 c, $13 c,
1.1       pazsan    145:        $1E c, $1D c, $1B c, $17 c,
                    146:        $1F c,
1.11      pazsan    147:        $0C c, $0A c, $06 c, $09 c, $05 c, $03 c,
1.1       pazsan    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: 
1.12      pazsan    169: Create condmasks  $FFFFFFFFFF07FFFF ,
                    170:                   $FFFFFFFFFFF83FFF ,
                    171:                   $FFFFFFFFFFFFC1FF ,
                    172:                   $FFFFFFFFFFFFFE0F ,
1.1       pazsan    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
1.12      pazsan    208:          r@ op@ [ cell 8 = ] [IF]
                    209:              drop $200000000
                    210:          [ELSE]
                    211:              nip 2
                    212:          [THEN]
                    213:          and IF  swap r@ 8 + + swap  THEN
1.1       pazsan    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 ;
1.9       pazsan    242: : sym, ( addr len -- addr ) 2drop here 0 , ;
1.1       pazsan    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
1.9       pazsan    248:   DOES>  ( addr -- ) dup cell+ @ @ dup
1.1       pazsan    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 ;
1.9       pazsan    254: : symbol,  ( addr len -- xt )
                    255:   2dup nextname  sym,
                    256:   also asmdefs  label:  previous ;
1.1       pazsan    257: :A
                    258: : .globl  ( -- )  0 bl word count symbol, ;
                    259: :D
                    260: 
                    261: : is-label?  ( addr u -- flag )  drop c@ '@ >= ;
1.9       pazsan    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 ;
1.1       pazsan    268: : ?label ( addr u -- )
1.9       pazsan    269:   2dup is-label?  IF  ['] do-label EXIT  THEN
                    270:   defers interpreter-notfound1 ;
1.1       pazsan    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: 
1.12      pazsan    446: : bytesplit ( n -- n1 n2 )
                    447:     0 $1000000 um/mod swap 8 lshift swap ;
                    448: 
1.1       pazsan    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
1.12      pazsan    458:   swap bytesplit  dup $80 and negate or >r
1.1       pazsan    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
1.12      pazsan    465:         1- >r bytesplit #< r> rot 2!
1.1       pazsan    466:   ELSE  2drop drop  alu? IF  nop  ELSE  0 #  THEN  THEN ;
1.5       pazsan    467: 
                    468: : >sym ( "symbol" -- addr )
                    469:     bl word count sym-lookup? dup 0= abort" No symbol!"
                    470:     >body cell+ @ @ ;
1.1       pazsan    471: :D
                    472: : >ip.b  ( -- )
1.11      pazsan    473:     >sym 4here 8 + - ;
1.1       pazsan    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  ( -- )
1.5       pazsan    487:     >sym procstart @ - ;
1.1       pazsan    488: :A
                    489: : .proc  finish?  4here procstart ! ;
1.5       pazsan    490: : .p#    ( -- n )  >p.b                       ;
1.1       pazsan    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: 
1.11      pazsan    654: : byte,   4there caddr  'c!         1 4allot ;
1.1       pazsan    655: : short,  $100 /mod 4there waddr  'c!
                    656:               4there  waddr 1+ 'c!  2 4allot ;
1.11      pazsan    657: : int,    4there laddr   '!         4 4allot ;
                    658: : long,   4there laddr   '!         4 4allot ;
1.1       pazsan    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: 
1.9       pazsan    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, ;
1.1       pazsan    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+ !
1.11      pazsan    710:   r@ 4 2 pick write-file throw
                    711:   r@ cell+ 4 2 pick write-file throw
1.1       pazsan    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)
1.2       pazsan    727:     also asm4stack
1.1       pazsan    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@
1.9       pazsan    730:     What's interpreter-notfound1 old-notfound !
                    731:     ['] ?label IS interpreter-notfound1 ;
1.1       pazsan    732: : label (code) 4here label: drop asm4stack depth ;
1.9       pazsan    733: : (end-code) previous old-notfound @ IS interpreter-notfound1 ;
1.1       pazsan    734: 
                    735: previous previous previous Forth
                    736: 

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