Annotation of gforth/arch/4stack/prim.fs, revision 1.7

1.1       pazsan      1: \ 4stack primitives
                      2: 
1.7     ! anton       3: \ Copyright (C) 2000,2003 Free Software Foundation, Inc.
1.4       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
                      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
1.5       anton      19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.4       anton      20: 
1.2       pazsan     21: Label start
1.6       pazsan     22:         nop          ;; first opcode must be a nop!
1.2       pazsan     23:        $80000000 ## ;;
                     24:        #,           ;;
                     25:        sr!          jmpa $818 >IP ;;
1.1       pazsan     26: 
                     27: $800 .org
                     28: ip0:   .int 0
                     29:        .int 0
                     30: varpat:        ip@      nop       nop      jmpa                              ;;
                     31: colpat:        ip@      nop       nop      jmpa                              ;;
                     32: ;;      ds       cfa       fs       rs
                     33: main:   ;;
                     34:        -$200 ## nop       nop      nop       -8 #        ld 1: ip    ;;
                     35:        #,       nop       nop      nop       set 0: R3               ;;
                     36:        nop      nop       nop      nop       0 #         set 1: R1   ;;
                     37:        nop      nop       nop      nop       0 #         ld 1: R1 N+ ;;
                     38:        nop      nop       nop      nop                               ;;
                     39:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                     40:        nop      nop       nop      nop                               ;;
                     41: 
                     42: docol:  .endif ;;
                     43: ;;     nop      ip@       nop      call docol                        ;;
                     44: ;;      ds ca    cfa       fs       rs
                     45: dodoes:
                     46: ;;      ip@      nop       nop      call doesjump
                     47: ;;      ip@      nop       nop      call dodoes
                     48: ;;      ds df ca cfa       fs       rs
                     49:         drop     pick 0s0  nop      nop       0 #         get 3: R1   ;;
                     50:        nop      nop       nop      -4 #      0 #         set 1: R1   ;;
                     51:         nop      drop      nop      add       0 #         ld 1: R1 N+ ;;
                     52:        nop      nop       nop      nop                               ;;
                     53:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                     54:        nop      nop       nop      nop                               ;;
                     55: 
                     56: dovar:  .endif ;;
                     57: ;;     ip@      nop       nop      call dovar                        ;;
                     58: ;;      ds       cfa       fs       rs
                     59:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                     60:        nop      nop       nop      nop                               ;;
                     61: 
                     62: docon:  ;;
                     63: ;;     ip@      nop       nop      call dovar                        ;;
                     64: ;;      ds       cfa       fs       rs
                     65:        nop      ip!       nop      nop       ld 0: s0b   ld 1: R1 N+ ;;
                     66:        drop     nop       nop      nop                               ;;
                     67: end-code
                     68: 
1.6       pazsan     69: -2 Doer: :docol
                     70: -3 Doer: :docon
                     71: -4 Doer: :dovar
                     72: -8 Doer: :dodoes
                     73: -9 Doer: :doesjump
1.1       pazsan     74: 
                     75: Code execute ( xt -- )
                     76:        ip!      nop       nop      nop                               ;;
                     77:        nop      nop       nop      nop                               ;;
                     78: end-code
                     79: 
                     80: Code ?branch
                     81:        nop      nop       nop      nop       br 0 ?0<>
1.6       pazsan     82:        nop      dup       nop      nop       0 #         set 1: R1   ;;
1.1       pazsan     83: .endif
                     84:        nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
                     85:        nop      nop       nop      nop                               ;;
                     86:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                     87:        nop      nop       nop      nop                               ;;
                     88: end-code
                     89: 
                     90: Code +
                     91:        add      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                     92:        nop      nop       nop      nop                               ;;
                     93: end-code
                     94: 
                     95: Code and
                     96:        and      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                     97:        nop      nop       nop      nop                               ;;
                     98: end-code
                     99: 
                    100: Code xor
                    101:        xor      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    102:        nop      nop       nop      nop                               ;;
                    103: end-code
                    104: 
                    105: Code sp@
                    106:        sp@      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    107:        nop      nop       nop      nop                               ;;
                    108: end-code
                    109: 
                    110: Code sp!
                    111:        sp!      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    112:        nop      nop       nop      nop                               ;;
                    113: end-code
                    114: 
                    115: Code rp@
                    116:        nop      ip!       nop      sp@       0 #         ld 1: R1 N+ ;;
                    117:        pick 3s0 nop       nop      drop                              ;;
                    118: end-code
                    119: 
                    120: Code rp!
                    121:        drop     ip!       nop      pick 0s0  0 #         ld 1: R1 N+ ;;
                    122:        nop      nop       nop      sp!                               ;;
                    123: end-code
                    124: 
                    125: Code ;s
                    126:        nop      drop      nop      nop       0 #         set 3: R1   ;;
                    127:        nop      nop       nop      nop       0 #         ld 1: R1 N+ ;;
                    128:        nop      nop       nop      nop                               ;;
                    129:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    130:        nop      nop       nop      nop                               ;;
                    131: end-code
                    132: 
                    133: Code @
                    134:        nop      ip!       nop      nop       ld 0: s0b   ld 1: R1 N+ ;;
                    135:        drop     nop       nop      nop                               ;;
                    136: end-code
                    137: 
                    138: Code !
                    139:        drop     ip!       nop      nop       st 0: s0b   ld 1: R1 N+ ;;
                    140:        nop      nop       nop      nop                               ;;
                    141: end-code
                    142: 
                    143: \ obligatory IO
                    144: 
1.2       pazsan    145: Code (key?)
1.1       pazsan    146:        nop      nop       nop      nop       inb R3      3 #         ;;
                    147:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    148:        0<>      nop       nop      nop                               ;;
                    149: end-code
                    150: 
                    151: Code (key)
                    152: .begin                                       inb R3      3 #          ;;
                    153:        nop                                   br 0 ?0= .until
                    154:                                              inb R3      2 #          ;;
                    155:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    156:        nop      nop       nop      nop                               ;;
                    157: end-code
                    158: 
                    159: Code (emit)
                    160: .begin                                       inb R3      1 #         ;;
                    161:        nop                                   br 0 ?0= .until
                    162:                                              outb R3     0 #         ;;
                    163:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    164:        nop      nop       nop      nop                               ;;
                    165: end-code
                    166: 
                    167: \ this was obligatory, now some things to speed it up
                    168: 
                    169: Code 2/
                    170:        asr      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    171:        nop      nop       nop      nop                               ;;
                    172: end-code
                    173: 
                    174: Code branch
1.6       pazsan    175:        nop      nop       nop      nop       0 #         set 1: R1   ;;
                    176:        nop      nop       nop      nop       0 #         ld 1: R1 N+ ;;
1.1       pazsan    177:        nop      nop       nop      nop                               ;;
                    178:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    179:        nop      nop       nop      nop                               ;;
                    180: end-code
                    181: 
                    182: Code (loop)
                    183:        pick 3s1 nop       nop      inc                               ;;
                    184:         sub 3s0  nop       nop      nop       br 0 ?0=
1.6       pazsan    185:        nop      dup       nop      nop       0 #         set 1: R1   ;;
1.1       pazsan    186: .endif
                    187:        nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
                    188:        nop      nop       nop      nop                               ;;
                    189:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    190:        nop      nop       nop      nop                               ;;
                    191: end-code
                    192: 
                    193: Code (+loop)
                    194:        pick 3s1 nop       nop      nop                               ;;
                    195:        subr 3s0 nop       nop      nop                               ;;
                    196:        xor #min nop       nop      nop                               ;;
                    197:        add s1   nop       nop      nop       br 0 ?ov
1.6       pazsan    198:        nop      dup       nop      nop       0 #         set 1: R1   ;;
1.1       pazsan    199: .endif
                    200:        nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
                    201:        nop      nop       nop      nop
                    202:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    203:        drop     nop       nop      add 0s0                           ;;
                    204: end-code
                    205: 
                    206: Code (do)
                    207:        nip      ip!       nop      pick 0s1  0 #         ld 1: R1 N+ ;;
                    208:        drop     nop       nop      pick 0s0                          ;;
                    209: end-code
                    210: 
1.6       pazsan    211: Code unloop
                    212:        nop      ip!       nop      drop      0 #         ld 1: R1 N+ ;;
                    213:        nop      nop       nop      drop                              ;;
                    214: end-code
                    215: 
1.1       pazsan    216: Code -
                    217:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    218:        nop      nop       nop      nop                               ;;
                    219: end-code
                    220: 
                    221: Code or
                    222:        or       ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    223:        nop      nop       nop      nop                               ;;
                    224: end-code
                    225: 
                    226: Code 1+
                    227:        inc      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    228:        nop      nop       nop      nop                               ;;
                    229: end-code
                    230: 
                    231: Code cell+
                    232:        4 #      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    233:        add      nop       nop      nop                               ;;
                    234: end-code
                    235: 
                    236: Code cells
                    237:        asl      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    238:        asl      nop       nop      nop                               ;;
                    239: end-code
                    240: 
                    241: Code c@
                    242:        nop      ip!       nop      nop       ldb 0: s0b  ld 1: R1 N+ ;;
                    243:        drop     nop       nop      nop                               ;;
                    244: end-code
                    245: 
                    246: Code c!
                    247:        drop     ip!       nop      nop       stb 0: s0b  ld 1: R1 N+ ;;
                    248:        nop      nop       nop      nop                               ;;
                    249: end-code
                    250: 
                    251: Code um*
                    252:        umul     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    253:        mul@     nop       nop      nop                               ;;
                    254: end-code
                    255: 
                    256: Code m*
                    257:        mul      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    258:        mul@     nop       nop      nop                               ;;
                    259: end-code
                    260: 
                    261: Code d+
                    262:        pass     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    263:        mul@+    nop       nop      nop                               ;;
                    264: end-code
                    265: 
                    266: Code >r
                    267:        drop     ip!       nop      pick 0s0  0 #         ld 1: R1 N+ ;;
                    268:        nop      nop       nop      nop                               ;;
                    269: end-code
                    270: 
                    271: Code r>
                    272:        pick 3s0 ip!       nop      drop      0 #         ld 1: R1 N+ ;;
                    273:        nop      nop       nop      nop                               ;;
                    274: end-code
                    275: 
                    276: Code drop
                    277:        drop     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    278:        nop      nop       nop      nop                               ;;
                    279: end-code
                    280: 
                    281: Code swap
                    282:        swap     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    283:        nop      nop       nop      nop                               ;;
                    284: end-code
                    285: 
                    286: Code over
                    287:        over     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    288:        nop      nop       nop      nop                               ;;
                    289: end-code
                    290: 
                    291: Code 2dup
                    292:        over     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    293:        over     nop       nop      nop                               ;;
                    294: end-code
                    295: 
                    296: Code rot
                    297:        rot      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    298:        nop      nop       nop      nop                               ;;
                    299: end-code
                    300: 
                    301: Code -rot
                    302:        rot      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    303:        rot      nop       nop      nop                               ;;
                    304: end-code
                    305: 
                    306: Code i
                    307:        pick 3s0 ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    308:        nop      nop       nop      nop                               ;;
                    309: end-code
                    310: 
                    311: Code i'
                    312:        pick 3s1 ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    313:        nop      nop       nop      nop                               ;;
                    314: end-code
                    315: 
                    316: Code j
                    317:        pick 3s2 ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    318:        nop      nop       nop      nop                               ;;
                    319: end-code
                    320: 
                    321: Code lit
                    322:        pick 1s0 drop      nop      nop       0 #         ld 1: R1 N+ ;;
                    323:        nop      nop       nop      nop                               ;;
                    324:        nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    325:        nop      nop       nop      nop                               ;;
                    326: end-code
                    327: 
                    328: Code 0=
                    329:        0=       ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    330:        nop      nop       nop      nop                               ;;
                    331: end-code
                    332: 
                    333: Code 0<>
                    334:        0<>      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    335:        nop      nop       nop      nop                               ;;
                    336: end-code
                    337: 
                    338: Code u<
                    339:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    340:        u<       nop       nop      nop                               ;;
                    341: end-code
                    342: 
                    343: Code u>
                    344:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    345:        u>       nop       nop      nop                               ;;
                    346: end-code
                    347: 
                    348: Code u<=
                    349:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    350:        u<=      nop       nop      nop                               ;;
                    351: end-code
                    352: 
                    353: Code u>=
                    354:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    355:        u>=      nop       nop      nop                               ;;
                    356: end-code
                    357: 
                    358: Code <=
                    359:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    360:        <=       nop       nop      nop                               ;;
                    361: end-code
                    362: 
                    363: Code >=
                    364:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    365:        >=       nop       nop      nop                               ;;
                    366: end-code
                    367: 
                    368: Code =
                    369:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    370:        0=       nop       nop      nop                               ;;
                    371: end-code
                    372: 
                    373: Code <>
                    374:        subr     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    375:        0<>      nop       nop      nop                               ;;
                    376: end-code
                    377: 
1.6       pazsan    378: \ : (findl-samelen) ( u name1 -- u name2/0 )
                    379: \     BEGIN  2dup cell+ @ $1FFFFFFF and <> WHILE  @  dup 0= UNTIL  THEN ;
                    380: Code (findl-samelen)
                    381:         nop      0 #       0 #      $20 #                             ;;
                    382:         nop      nop       pick 0s0 hib                               ;;
                    383:         nop      nop       nop      dec                               ;;
1.1       pazsan    384: .begin
1.6       pazsan    385:        drop     drop      nop      nop       ld 0: s0b   1 #         ;;
                    386:         nop      pick 3s0  nip      nop       ld 2: s0b   0 #         ;;
1.1       pazsan    387:        drop     and 0s0   nop      nop                               ;;
                    388:        pick 2s0 sub 0s0   nop      nop       br 1&2 :0<> .until      ;;
                    389:        nop      nop       nop      nop       br 1 ?0=                ;;
1.6       pazsan    390:        nop      ip!       drop     drop      0 #         ld 1: R1 N+ ;;
1.1       pazsan    391:        nop      nop       drop     nop                               ;;
                    392: .endif
1.6       pazsan    393:        pick 2s1 ip!       drop     drop      0 #         ld 1: R1 N+ ;;
1.1       pazsan    394:        nip      nop       drop     nop                               ;;
                    395: end-code
1.6       pazsan    396: 
                    397: \ necessary high-level code
                    398: 
                    399: : (type)
                    400:     bounds ?DO  I c@ (emit)  LOOP ;
                    401: \    BEGIN  dup  WHILE
                    402: \      >r dup c@ (emit) 1+ r> 1-  REPEAT  2drop ;
                    403: 
                    404: \ obligatory code address manipulations
                    405: 
                    406: : >code-address ( xt -- addr )  cell+ @ -8 and ;
                    407: : >does-code    ( xt -- addr )
                    408:     cell+ @ -8 and \ dup 3 and 3 <> IF  drop 0  EXIT  THEN
                    409:     8 + dup cell - @ 3 and 0<> and ;
                    410: : code-address! ( addr xt -- )  >r 3 or $808 @ r> 2! ;
                    411: : does-code!    ( a_addr xt -- )  >r 5 - $808 @ r> 2! ;
                    412: : does-handler! ( a_addr -- )  >r $810 2@ r> 2! ;
1.1       pazsan    413: 
1.3       pazsan    414: : bye  0 execute ;
                    415: 
1.1       pazsan    416: \ division a/b
                    417: \ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r);
                    418: \ result: x=a/b; y=1; r=1
                    419: 
                    420: \ Label idiv-table
                    421: \ idiv-tab:
                    422: \ .macro .idiv-table [F]
                    423: \      $100 $80 DO  0 $100 I 2* 1+ um/mod  long, drop  LOOP
                    424: \ .end-macro
                    425: \      .idiv-table
                    426: \ end-code
                    427: \ 
                    428: \ Code um/mod1 ( u -- 1/u )
                    429: \ ;;   b        --        --       --        --          --          ;;
                    430: \      ff1      -$1F #    nop      nop       br 0 :0= div0
                    431: \      bfu      add 0s0   ip@      nop       set 2: R2               ;;
                    432: \ ;;   b'       --        --       --        --          --          ;;
                    433: \      lob      $0FF ##   pick 0s0 pick 0s0  0 #         -$108 ## ;;
                    434: \      1 #      #,        sub #min 1 #       ld 0: R2 +s0 #,         ;;
                    435: \      cm!      and       nop      cm!       br 2 ?0= by2
                    436: \ ;;      est      --        --       b'        --          --          ;;
                    437: \      umul 3s0 pick 0s0  nop      umul 0s0  0 #         0 #         ;;
                    438: \      mulr<@   nop       nop      -mulr@                            ;;
                    439: \      drop     umul 3s0  nop      umul 0s0                          ;;
                    440: \      mulr<@   cm!       nop      -mulr@                            ;;
                    441: \      umul 3s0 drop      pick 1s0 drop                              ;;
                    442: \      drop     mulr<@    ip!      nop       0 #         ld 1: R1 N+ ;;
                    443: \      pick 1s0 drop      nop      nop                               ;;
                    444: \ by2:
                    445: \ div0:
                    446: \      -1 #     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
                    447: \      nop      nop       nop      nop                               ;;
                    448: \ end-code

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