Annotation of gforth/arch/4stack/prim-new.fs, revision 1.3

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

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