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

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

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