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

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

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