Annotation of gforth/primitives, revision 1.6

1.6     ! anton       1: \ Copyright 1992 by the ANSI figForth Development Group
        !             2: \ 
        !             3: \ WARNING: This file is processed by m4. Make sure your identifiers
        !             4: \ don't collide with m4's (e.g. by undefining them).
        !             5: \ 
        !             6: \ This file contains instructions in the following format:
        !             7: \ 
        !             8: \ forth name   stack effect    category        [pronounciation]
        !             9: \ [""glossary entry""]
        !            10: \ C code
        !            11: \ [:
        !            12: \ Forth code]
        !            13: \ 
        !            14: \ The pronounciataion is also used for forming C names.
        !            15: \ 
        !            16: \ These informations are automagically translated into C-code for the
        !            17: \ interpreter and into some other files. The forth name of a word is
        !            18: \ automatically turned into upper case. I hope that your C compiler has
        !            19: \ decent optimization, otherwise the automatically generated code will
        !            20: \ be somewhat slow. The Forth version of the code is included for manual
        !            21: \ compilers, so they will need to compile only the important words.
        !            22: \ 
        !            23: \ Note that stack pointer adjustment is performed according to stack
        !            24: \ effect by automatically generated code and NEXT is automatically
        !            25: \ appended to the C code. Also, you can use the names in the stack
        !            26: \ effect in the C code. Stack access is automatic. One exception: if
        !            27: \ your code does not fall through, the results are not stored into the
        !            28: \ stack. Use different names on both sides of the '--', if you change a
        !            29: \ value (some stores to the stack are optimized away).
        !            30: \ 
        !            31: \ The stack variables have the following types:
        !            32: \ name matches type
        !            33: \ f.*          Bool
        !            34: \ c.*          Char
        !            35: \ [nw].*               Cell
        !            36: \ u.*          UCell
        !            37: \ d.*          DCell
        !            38: \ ud.*         UDCell
        !            39: \ r.*          Float
        !            40: \ a_.*         Cell *
        !            41: \ c_.*         Char *
        !            42: \ f_.*         Float *
        !            43: \ df_.*                DFloat *
        !            44: \ sf_.*                SFloat *
        !            45: \ xt.*         XT
        !            46: \ wid.*                WID
        !            47: \ f83name.*    F83Name *
        !            48: \ 
        !            49: \ In addition the following names can be used:
        !            50: \ ip   the instruction pointer
        !            51: \ sp   the data stack pointer
        !            52: \ rp   the parameter stack pointer
        !            53: \ NEXT executes NEXT
        !            54: \ cfa  
        !            55: \ NEXT1        executes NEXT1
        !            56: \ FLAG(x)      makes a Forth flag from a C flag
        !            57: \ 
        !            58: \ Percentages in comments are from Koopmans book: average/maximum use
        !            59: \ (taken from four, not very representattive benchmarks)
        !            60: \ 
        !            61: \ To do:
        !            62: \ make sensible error returns for file words
        !            63: \ 
        !            64: \ throw execute, cfa and NEXT1 out?
        !            65: \ macroize *ip, ip++, *ip++ (pipelining)?
1.1       anton      66: 
1.6     ! anton      67: \ these m4 macros would collide with identifiers
1.1       anton      68: undefine(`index')
                     69: undefine(`shift')
                     70: 
                     71: noop   --              fig
                     72: ;
                     73: 
                     74: lit    -- w            fig
                     75: w = (Cell)*ip++;
                     76: 
                     77: execute                xt --           core,fig
                     78: cfa = xt;
                     79: IF_TOS(TOS = sp[0]);
                     80: NEXT1;
                     81: 
                     82: branch --              fig
                     83: branch:
                     84: ip = (Xt *)(((int)ip)+(int)*ip);
                     85: 
                     86: ?branch                f --            f83     question_branch
                     87: ""also known as 0branch""
                     88: if (f==0) {
                     89:     IF_TOS(TOS = sp[0]);
                     90:     goto branch;
                     91:     }
                     92: else
                     93:     ip++;
                     94: 
                     95: (next) --              cmFORTH paren_next
                     96: if ((*rp)--) {
                     97:     goto branch;
                     98: } else {
                     99:     ip++;
                    100: }
                    101: 
                    102: (loop) --              fig     paren_loop
                    103: int index = *rp+1;
                    104: int limit = rp[1];
                    105: if (index != limit) {
                    106:     *rp = index;
                    107:     goto branch;
                    108: } else {
                    109:     ip++;
                    110: }
                    111: 
                    112: (+loop)                n --            fig     paren_plus_loop
                    113: /* !! check this thoroughly */
                    114: int index = *rp;
                    115: int olddiff = index-rp[1];
                    116: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
                    117: /* dependent upon two's complement arithmetic */
                    118: if ((olddiff^(olddiff+n))<0   /* the limit is crossed */
                    119:     && (olddiff^n)<0          /* it is not a wrap-around effect */) {
                    120:     /* break */
                    121:     ip++;
                    122: } else {
                    123:     /* continue */
                    124:     *rp = index+n;
                    125:     IF_TOS(TOS = sp[0]);
                    126:     goto branch;
                    127: }
                    128: 
                    129: (s+loop)       n --            new     paren_symmetric_plus_loop
                    130: ""The run-time procedure compiled by S+LOOP. It loops until the index
                    131: crosses the boundary between limit and limit-sign(n). I.e. a symmetric
                    132: version of (+LOOP).""
                    133: /* !! check this thoroughly */
                    134: int oldindex = *rp;
                    135: int diff = oldindex-rp[1];
                    136: int newdiff = diff+n;
                    137: if (n<0) {
                    138:     diff = -diff;
                    139:     newdiff = - newdiff;
                    140: }
                    141: if (diff>=0 || newdiff<0) {
                    142:     *rp = oldindex+n;
                    143:     IF_TOS(TOS = sp[0]);
                    144:     goto branch;
                    145: } else {
                    146:     ip++;
                    147: }
                    148: 
                    149: unloop         --      core
                    150: rp += 2;
                    151: 
                    152: (for)  ncount --               cmFORTH         paren_for
                    153: /* or (for) = >r -- collides with unloop! */
                    154: *--rp = 0;
                    155: *--rp = ncount;
                    156: 
                    157: (do)   nlimit nstart --                fig             paren_do
                    158: /* or do it in high-level? 0.09/0.23% */
                    159: *--rp = nlimit;
                    160: *--rp = nstart;
                    161: :
                    162:  swap >r >r ;
                    163: 
                    164: (?do)  nlimit nstart --        core-ext        paren_question_do
                    165: *--rp = nlimit;
                    166: *--rp = nstart;
                    167: if (nstart == nlimit) {
                    168:     IF_TOS(TOS = sp[0]);
                    169:     goto branch;
                    170:     }
                    171: else {
                    172:     ip++;
                    173: }
                    174: 
                    175: i      -- n            core,fig
                    176: n = *rp;
                    177: 
                    178: j      -- n            core
                    179: n = rp[2];
                    180: 
1.6     ! anton     181: \ digit is high-level: 0/0%
1.1       anton     182: 
                    183: emit   c --            fig
                    184: putchar(c);
                    185: emitcounter++;
                    186: 
                    187: key    -- n            fig
                    188: fflush(stdout);
                    189: /* !! noecho */
                    190: n = key();
                    191: 
1.2       pazsan    192: key?   -- n            fig     key_q
                    193: fflush(stdout);
                    194: n = key_query;
                    195: 
1.1       anton     196: cr     --              fig
                    197: puts("");
                    198: 
                    199: move   c_from c_to ucount --           core
                    200: memmove(c_to,c_from,ucount);
1.6     ! anton     201: /* make an Ifdef for bsd and others? */
1.1       anton     202: 
                    203: cmove  c_from c_to u --        string
                    204: while (u-- > 0)
                    205:   *c_to++ = *c_from++;
                    206: 
                    207: cmove> c_from c_to u --        string  c_move_up
                    208: while (u-- > 0)
                    209:   c_to[u] = c_from[u];
                    210: 
                    211: fill   c_addr u c --   core
                    212: memset(c_addr,c,u);
                    213: 
                    214: compare                c_addr1 u1 c_addr2 u2 -- n      string
                    215: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
                    216: if (n==0)
                    217:   n = u1-u2;
                    218: if (n<0)
                    219:   n = -1;
                    220: else if (n>0)
                    221:   n = 1;
                    222: 
                    223: -text          c_addr1 u c_addr2 -- n  new     dash_text
                    224: n = memcmp(c_addr1, c_addr2, u);
                    225: if (n<0)
                    226:   n = -1;
                    227: else if (n>0)
                    228:   n = 1;
                    229: 
                    230: capscomp       c_addr1 u c_addr2 -- n  new
                    231: Char c1, c2;
                    232: for (;; u--, c_addr1++, c_addr2++) {
                    233:   if (u == 0) {
                    234:     n = 0;
                    235:     break;
                    236:   }
                    237:   c1 = toupper(*c_addr1);
                    238:   c2 = toupper(*c_addr2);
                    239:   if (c1 != c2) {
                    240:     if (c1 < c2)
                    241:       n = -1;
                    242:     else
                    243:       n = 1;
                    244:     break;
                    245:   }
                    246: }
                    247: 
                    248: -trailing      c_addr u1 -- c_addr u2          string  dash_trailing
                    249: u2 = u1;
                    250: while (c_addr[u2-1] == ' ')
                    251:   u2--;
                    252: 
                    253: /string                c_addr1 u1 n -- c_addr2 u2      string  slash_string
                    254: c_addr2 = c_addr1+n;
                    255: u2 = u1-n;
                    256: 
                    257: +      n1 n2 -- n              core,fig        plus
                    258: n = n1+n2;
                    259: 
                    260: -      n1 n2 -- n              core,fig        minus
                    261: n = n1-n2;
                    262: 
                    263: negate n1 -- n2                core,fig
                    264: /* use minus as alias */
                    265: n2 = -n1;
                    266: 
                    267: 1+     n1 -- n2                core            one_plus
                    268: n2 = n1+1;
                    269: 
                    270: 1-     n1 -- n2                core            one_minus
                    271: n2 = n1-1;
                    272: 
                    273: max    n1 n2 -- n      core
                    274: if (n1<n2)
                    275:   n = n2;
                    276: else
                    277:   n = n1;
                    278: :
                    279:  2dup < if
                    280:   swap drop
                    281:  else
                    282:   drop
                    283:  endif ;
                    284: 
                    285: min    n1 n2 -- n      core
                    286: if (n1<n2)
                    287:   n = n1;
                    288: else
                    289:   n = n2;
                    290: 
                    291: abs    n1 -- n2        core
                    292: if (n1<0)
                    293:   n2 = -n1;
                    294: else
                    295:   n2 = n1;
                    296: 
                    297: *      n1 n2 -- n              core,fig        star
                    298: n = n1*n2;
                    299: 
                    300: /      n1 n2 -- n              core,fig        slash
                    301: n = n1/n2;
                    302: 
                    303: mod    n1 n2 -- n              core
                    304: n = n1%n2;
                    305: 
                    306: /mod   n1 n2 -- n3 n4          core            slash_mod
                    307: n4 = n1/n2;
                    308: n3 = n1%n2; /* !! is this correct? look into C standard! */
                    309: 
                    310: 2*     n1 -- n2                core            two_star
                    311: n2 = 2*n1;
                    312: 
                    313: 2/     n1 -- n2                core            two_slash
                    314: /* !! is this still correct? */
                    315: n2 = n1>>1;
                    316: 
                    317: fm/mod d1 n1 -- n2 n3          core            f_m_slash_mod
                    318: ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
                    319: /* assumes that the processor uses either floored or symmetric division */
                    320: n3 = d1/n1;
                    321: n2 = d1%n1;
                    322: /* note that this 1%-3>0 is optimized by the compiler */
                    323: if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
                    324:   n3--;
                    325:   n2+=n1;
                    326: }
                    327: 
                    328: sm/rem d1 n1 -- n2 n3          core            s_m_slash_rem
                    329: ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""
                    330: /* assumes that the processor uses either floored or symmetric division */
                    331: n3 = d1/n1;
                    332: n2 = d1%n1;
                    333: /* note that this 1%-3<0 is optimized by the compiler */
                    334: if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
                    335:   n3++;
                    336:   n2-=n1;
                    337: }
                    338: 
                    339: m*     n1 n2 -- d              core    m_star
                    340: d = (DCell)n1 * (DCell)n2;
                    341: 
                    342: um*    u1 u2 -- ud             core    u_m_star
                    343: /* use u* as alias */
                    344: ud = (UDCell)u1 * (UDCell)u2;
                    345: 
                    346: um/mod ud u1 -- u2 u3          core    u_m_slash_mod
                    347: u3 = ud/u1;
                    348: u2 = ud%u1;
                    349: 
                    350: m+     d1 n -- d2              double          m_plus
                    351: d2 = d1+n;
                    352: 
                    353: d+     d1 d2 -- d              double,fig      d_plus
                    354: d = d1+d2;
                    355: 
                    356: d-     d1 d2 -- d              double          d_minus
                    357: d = d1-d2;
                    358: 
                    359: dnegate        d1 -- d2                double
                    360: /* use dminus as alias */
                    361: d2 = -d1;
                    362: 
                    363: dmax   d1 d2 -- d      double
                    364: if (d1<d2)
                    365:   d = d2;
                    366: else
                    367:   d = d1;
                    368: 
                    369: dmin   d1 d2 -- d      double
                    370: if (d1<d2)
                    371:   d = d1;
                    372: else
                    373:   d = d2;
                    374: 
                    375: dabs   d1 -- d2        double
                    376: if (d1<0)
                    377:   d2 = -d1;
                    378: else
                    379:   d2 = d1;
                    380: 
                    381: d2*    d1 -- d2                double          d_two_star
                    382: d2 = 2*d1;
                    383: 
                    384: d2/    d1 -- d2                double          d_two_slash
                    385: /* !! is this still correct? */
                    386: d2 = d1/2;
                    387: 
                    388: d>s    d -- n                  double          d_to_s
                    389: /* make this an alias for drop? */
                    390: n = d;
                    391: 
                    392: and    w1 w2 -- w              core,fig
                    393: w = w1&w2;
                    394: 
                    395: or     w1 w2 -- w              core,fig
                    396: w = w1|w2;
                    397: 
                    398: xor    w1 w2 -- w              core,fig
                    399: w = w1^w2;
                    400: 
                    401: invert w1 -- w2                core
                    402: w2 = ~w1;
                    403: 
                    404: rshift u1 n -- u2              core
                    405:   u2 = u1>>n;
                    406: 
                    407: lshift u1 n -- u2              core
                    408:   u2 = u1<<n;
                    409: 
1.6     ! anton     410: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
1.1       anton     411: define(comparisons,
                    412: $1=    $2 -- f         $6      $3equals
                    413: f = FLAG($4==$5);
                    414: 
                    415: $1<>   $2 -- f         $7      $3different
                    416: /* use != as alias ? */
                    417: f = FLAG($4!=$5);
                    418: 
                    419: $1<    $2 -- f         $8      $3less
                    420: f = FLAG($4<$5);
                    421: 
                    422: $1>    $2 -- f         $9      $3greater
                    423: f = FLAG($4>$5);
                    424: 
                    425: $1<=   $2 -- f         new     $3less_or_equal
                    426: f = FLAG($4<=$5);
                    427: 
                    428: $1>=   $2 -- f         new     $3greater_or_equal
                    429: f = FLAG($4>=$5);
                    430: 
                    431: )
                    432: 
                    433: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
                    434: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
                    435: comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext)
                    436: comparisons(d, d1 d2, d_, d1, d2, double, new, double, new)
                    437: comparisons(d0, d, d_zero_, d, 0, double, new, double, new)
                    438: comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new)
                    439: 
                    440: within u1 u2 u3 -- f           core-ext
                    441: f = FLAG(u1-u2 < u3-u2);
                    442: 
                    443: sp@    -- a_addr               fig             spat
                    444: a_addr = sp;
                    445: 
                    446: sp!    a_addr --               fig             spstore
                    447: sp = a_addr+1;
                    448: /* works with and without TOS caching */
                    449: 
                    450: rp@    -- a_addr               fig             rpat
                    451: a_addr = rp;
                    452: 
                    453: rp!    a_addr --               fig             rpstore
                    454: rp = a_addr;
                    455: 
                    456: fp@    -- f_addr       new     fp_fetch
                    457: f_addr = fp;
                    458: 
                    459: fp!    f_addr --       new     fp_store
                    460: fp = f_addr;
                    461: 
1.3       pazsan    462: ;s     --              core    exit
1.1       anton     463: /* use ;s as alias */
                    464: ip = (Xt *)(*rp++);
                    465: 
                    466: ?exit  w --            core            question_exit
                    467: /* use ;s as alias */
                    468: if(w)
                    469:        ip = (Xt *)(*rp++);
                    470: 
                    471: >r     w --            core,fig        to_r
                    472: *--rp = w;
                    473: 
                    474: r>     -- w            core,fig        r_from
                    475: w = *rp++;
                    476: 
                    477: r@     -- w            core,fig        r_fetch
                    478: /* use r as alias */
                    479: /* make r@ an alias for i */
                    480: w = *rp;
                    481: 
                    482: rdrop  --              fig
                    483: rp++;
                    484: 
                    485: i'     -- w            fig             i_tick
                    486: w=rp[1];
                    487: 
                    488: over   w1 w2 -- w1 w2 w1               core,fig
                    489: 
                    490: drop   w --            core,fig
                    491: 
                    492: swap   w1 w2 -- w2 w1          core,fig
                    493: 
                    494: dup    w -- w w                core,fig
                    495: 
                    496: rot    w1 w2 w3 -- w2 w3 w1    core    rote
                    497: 
                    498: -rot   w1 w2 w3 -- w3 w1 w2    fig     not_rote
                    499: 
                    500: nip    w1 w2 -- w2             core-ext
                    501: 
                    502: tuck   w1 w2 -- w2 w1 w2       core-ext
                    503: 
                    504: ?dup   w -- w                  core    question_dupe
                    505: /* resulting C code suboptimal */
                    506: /* make -dup an alias */
                    507: if (w!=0) {
                    508:   --sp;
                    509: #ifndef USE_TOS
                    510:   *sp = w;
                    511: #endif
                    512: }
                    513: 
                    514: pick   u -- w                  core-ext
                    515: w = sp[u+1];
                    516: 
                    517: 2drop  w1 w2 --                core    two_drop
                    518: 
                    519: 2dup   w1 w2 -- w1 w2 w1 w2    core    two_dupe
                    520: 
                    521: 2over  w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2        core    two_over
                    522: 
                    523: 2swap  w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap
                    524: 
                    525: 2rot   w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote
                    526: 
1.6     ! anton     527: \ toggle is high-level: 0.11/0.42%
1.1       anton     528: 
                    529: @      a_addr -- w             fig     fetch
                    530: w = *a_addr;
                    531: 
                    532: !      w a_addr --             core,fig        store
                    533: *a_addr = w;
                    534: 
                    535: +!     n a_addr --             core,fig        plus_store
                    536: *a_addr += n;
                    537: 
                    538: c@     c_addr -- c             fig     cfetch
                    539: c = *c_addr;
                    540: 
                    541: c!     c c_addr --             fig     cstore
                    542: *c_addr = c;
                    543: 
                    544: 2!     w1 w2 a_addr --         core    two_store
                    545: a_addr[0] = w2;
                    546: a_addr[1] = w1;
                    547: 
                    548: 2@     a_addr -- w1 w2         core    two_fetch
                    549: w2 = a_addr[0];
                    550: w1 = a_addr[1];
                    551: 
                    552: d!     d a_addr --             double  d_store
                    553: /* !! alignment problems on some machines */
                    554: *(DCell *)a_addr = d;
                    555: 
                    556: d@     a_addr -- d             double  d_fetch
                    557: d = *(DCell *)a_addr;
                    558: 
                    559: cell+  a_addr1 -- a_addr2      core    cell_plus
                    560: a_addr2 = a_addr1+1;
                    561: 
                    562: cells  n1 -- n2                core
                    563: n2 = n1 * sizeof(Cell);
                    564: 
                    565: char+  c_addr1 -- c_addr2      core    care_plus
                    566: c_addr2 = c_addr1+1;
                    567: 
                    568: chars  n1 -- n2                core    cares
                    569: n2 = n1 * sizeof(Char);
                    570: 
                    571: count  c_addr1 -- c_addr2 u    core
                    572: u = *c_addr1;
                    573: c_addr2 = c_addr1+1;
                    574: 
                    575: (bye)  n --    toolkit-ext     paren_bye
                    576: deprep_terminal();
                    577: exit(n);
                    578: 
                    579: system c_addr u -- n   own
                    580: char pname[u+1];
                    581: cstr(pname,c_addr,u);
                    582: n=system(pname);
                    583: 
                    584: popen  c_addr u n -- wfileid   own
                    585: char pname[u+1];
                    586: static char* mode[2]={"r","w"};
                    587: cstr(pname,c_addr,u);
                    588: wfileid=(Cell)popen(pname,mode[n]);
                    589: 
                    590: pclose wfileid -- wior own
                    591: wior=pclose((FILE *)wfileid);
1.2       pazsan    592: 
                    593: time&date      -- nyear nmonth nday nhour nmin nsec    ansi    time_and_date
                    594: struct timeval time1;
                    595: struct timezone zone1;
                    596: struct tm *ltime;
                    597: gettimeofday(&time1,&zone1);
                    598: ltime=localtime(&time1.tv_sec);
                    599: nyear =ltime->tm_year+1900;
                    600: nmonth=ltime->tm_mon;
                    601: nday  =ltime->tm_mday;
                    602: nhour =ltime->tm_hour;
                    603: nmin  =ltime->tm_min;
                    604: nsec  =ltime->tm_sec;
                    605: 
                    606: ms     n --    ansi
                    607: struct timeval timeout;
                    608: timeout.tv_sec=n/1000;
                    609: timeout.tv_usec=1000*(n%1000);
                    610: (void)select(0,0,0,0,&timeout);
1.1       anton     611: 
                    612: allocate       u -- a_addr wior        memory
                    613: a_addr = (Cell *)malloc(u);
1.6     ! anton     614: wior = a_addr==NULL;   /* !! Define a return code */
1.1       anton     615: 
                    616: free           a_addr -- wior          memory
                    617: free(a_addr);
                    618: wior = 0;
                    619: 
                    620: resize         a_addr1 u -- a_addr2 wior       memory
                    621: a_addr2 = realloc(a_addr1, u);
1.6     ! anton     622: wior = a_addr2==NULL;  /* !! Define a return code */
1.1       anton     623: 
                    624: (f83find)      c_addr u f83name1 -- f83name2   new     paren_f83find
                    625: for (; f83name1 != NULL; f83name1 = f83name1->next)
                    626:   if (F83NAME_COUNT(f83name1)==u && !F83NAME_SMUDGE(f83name1) &&
                    627:       strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
                    628:     break;
                    629: f83name2=f83name1;
                    630: 
                    631: (parse-white)  c_addr1 u1 -- c_addr2 u2        new     paren_parse_white
                    632: /* use !isgraph instead of isspace? */
                    633: Char *endp = c_addr1+u1;
                    634: while (c_addr1<endp && isspace(*c_addr1))
                    635:   c_addr1++;
                    636: if (c_addr1<endp) {
                    637:   for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
                    638:     ;
                    639:   u2 = c_addr1-c_addr2;
                    640: }
                    641: else {
                    642:   c_addr2 = c_addr1;
                    643:   u2 = 0;
                    644: }
                    645: 
                    646: close-file     wfileid -- wior file    close_file
                    647: wior = FLAG(fclose((FILE *)wfileid)==EOF);
                    648: 
                    649: open-file      c_addr u ntype -- w2 wior       file    open_file
                    650: char fname[u+1];
                    651: cstr(fname, c_addr, u);
                    652: w2 = (Cell)fopen(fname, fileattr[ntype]);
                    653: wior = FLAG(w2 == NULL);
                    654: 
                    655: create-file    c_addr u ntype -- w2 wior       file    create_file
                    656: int    fd;
                    657: char fname[u+1];
                    658: cstr(fname, c_addr, u);
                    659: fd = creat(fname, 0666);
                    660: if (fd > -1) {
                    661:   w2 = (Cell)fdopen(fd, fileattr[ntype]);
                    662:   assert(w2 != NULL);
                    663:   wior = 0;
                    664: } else {
                    665:   assert(fd == -1);
                    666:   wior = fd;
                    667:   w2 = 0;
                    668: }
                    669: 
                    670: delete-file    c_addr u -- wior                file    delete_file
                    671: char fname[u+1];
                    672: cstr(fname, c_addr, u);
                    673: wior = unlink(fname);
                    674: 
                    675: rename-file    c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
                    676: char fname1[u1+1];
                    677: char fname2[u2+1];
                    678: cstr(fname1, c_addr1, u1);
                    679: cstr(fname2, c_addr2, u2);
                    680: wior = rename(fname1, fname2);
                    681: 
                    682: file-position  wfileid -- ud wior      file    file_position
                    683: /* !! use tell and lseek? */
                    684: ud = ftell((FILE *)wfileid);
                    685: wior = 0; /* !! or wior = FLAG(ud<0) */
                    686: 
                    687: reposition-file        ud wfileid -- wior      file    reposition_file
                    688: wior = fseek((FILE *)wfileid, (long)ud, SEEK_SET);
                    689: 
                    690: file-size      wfileid -- ud wior      file    file_size
                    691: struct stat buf;
                    692: wior = fstat(fileno((FILE *)wfileid), &buf);
                    693: ud = buf.st_size;
                    694: 
                    695: resize-file    ud wfileid -- wior      file    resize_file
                    696: wior = ftruncate(fileno((FILE *)wfileid), (int)ud);
                    697: 
                    698: read-file      c_addr u1 wfileid -- u2 wior    file    read_file
                    699: /* !! fread does not guarantee enough */
                    700: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
                    701: wior = FLAG(u2<u1 && ferror((FILE *)wfileid));
                    702: /* !! who performs clearerr((FILE *)wfileid); ? */
                    703: 
                    704: read-line      c_addr u1 wfileid -- u2 flag wior       file    read_line
                    705: wior=(Cell)fgets(c_addr,u1+1,(FILE *)wfileid);
                    706: flag=FLAG(!feof((FILE *)wfileid) && wior);
                    707: wior=FLAG(ferror((FILE *)wfileid)) & flag;
                    708: u2=(flag & strlen(c_addr));
                    709: u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
                    710: 
                    711: write-file     c_addr u1 wfileid -- wior       file    write_file
                    712: /* !! fwrite does not guarantee enough */
                    713: {
                    714:   int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
                    715:   wior = FLAG(u2<u1 && ferror((FILE *)wfileid));
                    716: }
                    717: 
                    718: flush-file     wfileid -- wior         file-ext        flush_file
                    719: wior = fflush((FILE *)wfileid);
                    720: 
                    721: comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
                    722: comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
                    723: 
                    724: d>f            d -- r          float   d_to_f
                    725: r = d;
                    726: 
                    727: f>d            r -- d          float   f_to_d
                    728: /* !! basis 15 is not very specific */
                    729: d = r;
                    730: 
                    731: f!             r f_addr --     float   f_store
                    732: *f_addr = r;
                    733: 
                    734: f@             f_addr -- r     float   f_fetch
                    735: r = *f_addr;
                    736: 
                    737: df@            df_addr -- r    float-ext       d_f_fetch
                    738: #ifdef IEEE_FP
                    739: r = *df_addr;
                    740: #else
                    741: !! df@
                    742: #endif
                    743: 
                    744: df!            r df_addr --    float-ext       d_f_store
                    745: #ifdef IEEE_FP
                    746: *df_addr = r;
                    747: #else
                    748: !! df!
                    749: #endif
                    750: 
                    751: sf@            sf_addr -- r    float-ext       s_f_fetch
                    752: #ifdef IEEE_FP
                    753: r = *sf_addr;
                    754: #else
                    755: !! sf@
                    756: #endif
                    757: 
                    758: sf!            r sf_addr --    float-ext       s_f_store
                    759: #ifdef IEEE_FP
                    760: *sf_addr = r;
                    761: #else
                    762: !! sf!
                    763: #endif
                    764: 
                    765: f+             r1 r2 -- r3     float   f_plus
                    766: r3 = r1+r2;
                    767: 
                    768: f-             r1 r2 -- r3     float   f_minus
                    769: r3 = r1-r2;
                    770: 
                    771: f*             r1 r2 -- r3     float   f_star
                    772: r3 = r1*r2;
                    773: 
                    774: f/             r1 r2 -- r3     float   f_slash
                    775: r3 = r1/r2;
                    776: 
                    777: f**            r1 r2 -- r3     float-ext       f_star_star
                    778: r3 = pow(r1,r2);
                    779: 
                    780: fnegate                r1 -- r2        float
                    781: r2 = - r1;
                    782: 
                    783: fdrop          r --            float
                    784: 
                    785: fdup           r -- r r        float
                    786: 
                    787: fswap          r1 r2 -- r2 r1  float
                    788: 
                    789: fover          r1 r2 -- r1 r2 r1       float
                    790: 
                    791: frot           r1 r2 r3 -- r2 r3 r1    float
                    792: 
                    793: float+         f_addr1 -- f_addr2      float   float_plus
                    794: f_addr2 = f_addr1+1;
                    795: 
                    796: floats         n1 -- n2        float
                    797: n2 = n1*sizeof(Float);
                    798: 
                    799: floor          r1 -- r2        float
                    800: /* !! unclear wording */
                    801: r2 = floor(r1);
                    802: 
                    803: fround         r1 -- r2        float
                    804: /* !! unclear wording */
                    805: r2 = rint(r1);
                    806: 
                    807: fmax           r1 r2 -- r3     float
                    808: if (r1<r2)
                    809:   r3 = r2;
                    810: else
                    811:   r3 = r1;
                    812: 
                    813: fmin           r1 r2 -- r3     float
                    814: if (r1<r2)
                    815:   r3 = r1;
                    816: else
                    817:   r3 = r2;
                    818: 
                    819: represent              r c_addr u -- n f1 f2   float
                    820: char *sig;
                    821: int flag;
                    822: sig=ecvt(r, u, &n, &flag);
                    823: f1=FLAG(flag!=0);
                    824: f2=FLAG(isdigit(sig[0])!=0);
                    825: memmove(c_addr,sig,u);
                    826: 
                    827: >float c_addr u -- flag        float   to_float
                    828: /* real signature: c_addr u -- r t / f */
                    829: Float r;
                    830: char number[u+1];
                    831: char *endconv;
                    832: cstr(number, c_addr, u);
                    833: r=strtod(number,&endconv);
                    834: if(flag=FLAG(!(int)*endconv))
                    835: {
                    836:        IF_FTOS(fp[0] = FTOS);
                    837:        fp += -1;
                    838:        FTOS = r;
                    839: }
                    840: else if(*endconv=='d' || *endconv=='D')
                    841: {
                    842:        *endconv='E';
                    843:        r=strtod(number,&endconv);
                    844:        if(flag=FLAG(!(int)*endconv))
                    845:        {
                    846:                IF_FTOS(fp[0] = FTOS);
                    847:                fp += -1;
                    848:                FTOS = r;
                    849:        }
                    850: }
                    851: 
                    852: fabs           r1 -- r2        float-ext
                    853: r2 = fabs(r1);
                    854: 
                    855: facos          r1 -- r2        float-ext
                    856: r2 = acos(r1);
                    857: 
                    858: fasin          r1 -- r2        float-ext
                    859: r2 = asin(r1);
                    860: 
                    861: fatan          r1 -- r2        float-ext
                    862: r2 = atan(r1);
                    863: 
                    864: fatan2         r1 r2 -- r3     float-ext
                    865: r3 = atan2(r1,r2);
                    866: 
                    867: fcos           r1 -- r2        float-ext
                    868: r2 = cos(r1);
                    869: 
                    870: fexp           r1 -- r2        float-ext
                    871: r2 = exp(r1);
                    872: 
1.3       pazsan    873: fexpm1         r1 -- r2        float-ext
                    874: r2 =
                    875: #ifdef expm1
                    876:        expm1(r1);
                    877: #else
                    878:        exp(r1)-1;
                    879: #endif
                    880: 
1.1       anton     881: fln            r1 -- r2        float-ext
                    882: r2 = log(r1);
                    883: 
1.3       pazsan    884: flnp1          r1 -- r2        float-ext
                    885: r2 =
                    886: #ifdef log1p
                    887:        log1p(r1);
                    888: #else
                    889:        log(r1+1);
                    890: #endif
                    891: 
1.1       anton     892: flog           r1 -- r2        float-ext
                    893: r2 = log10(r1);
                    894: 
1.3       pazsan    895: fsin           r1 -- r2        float-ext
                    896: r2 = sin(r1);
                    897: 
                    898: fsincos                r1 -- r2 r3     float-ext
1.1       anton     899: r2 = sin(r1);
                    900: r3 = cos(r1);
                    901: 
                    902: fsqrt          r1 -- r2        float-ext
                    903: r2 = sqrt(r1);
                    904: 
                    905: ftan           r1 -- r2        float-ext
                    906: r2 = tan(r1);
                    907: 
1.6     ! anton     908: \ The following words access machine/OS/installation-dependent ANSI
        !           909: \   figForth internals
        !           910: \ !! how about environmental queries DIRECT-THREADED,
        !           911: \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
1.1       anton     912: 
                    913: >body          xt -- a_addr    core    to_body
                    914: a_addr = PFA(xt);
                    915: 
                    916: >code-address          xt -- c_addr            new     to_code_address
                    917: ""c_addr is the code address of the word xt""
                    918: /* !! This behaves installation-dependently for DOES-words */
                    919: c_addr = CODE_ADDRESS(xt);
                    920: 
                    921: >does-code     xt -- a_addr            new     to_does_code
                    922: ""If xt ist the execution token of a defining-word-defined word,
                    923: a_addr is the start of the Forth code after the DOES>; Otherwise the
                    924: behaviour is uundefined""
                    925: /* !! there is currently no way to determine whether a word is
                    926: defining-word-defined */
                    927: a_addr = DOES_CODE(xt);
                    928: 
1.4       pazsan    929: code-address!          n xt -- new     code_address_store
1.1       anton     930: ""Creates a code field with code address c_addr at xt""
1.4       pazsan    931: MAKE_CF(xt, symbols[CF(n)]);
1.5       pazsan    932: CACHE_FLUSH(xt,PFA(0));
1.1       anton     933: 
                    934: does-code!     a_addr xt --            new     does_code_store
                    935: ""creates a code field at xt for a defining-word-defined word; a_addr
                    936: is the start of the Forth code after DOES>""
                    937: MAKE_DOES_CF(xt, a_addr);
1.5       pazsan    938: CACHE_FLUSH(xt,PFA(0));
1.1       anton     939: 
                    940: does-handler!  a_addr --       new     does_jump_store
                    941: ""creates a DOES>-handler at address a_addr. a_addr usually points
                    942: just behind a DOES>.""
                    943: MAKE_DOES_HANDLER(a_addr);
1.5       pazsan    944: CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
1.1       anton     945: 
                    946: /does-handler  -- n    new     slash_does_handler
                    947: ""the size of a does-handler (includes possible padding)""
                    948: /* !! a constant or environmental query might be better */
                    949: n = DOES_HANDLER_SIZE;
                    950: 
                    951: toupper        c1 -- c2        new
                    952: c2 = toupper(c1);
                    953: 
1.6     ! anton     954: \ local variable implementation primitives
1.1       anton     955: @local#                -- w    new     fetch_local_number
                    956: w = *(Cell *)(lp+(int)(*ip++));
                    957: 
                    958: f@local#       -- r    new     f_fetch_local_number
                    959: r = *(Float *)(lp+(int)(*ip++));
                    960: 
                    961: laddr#         -- c_addr       new     laddr_number
                    962: /* this can also be used to implement lp@ */
                    963: c_addr = (Char *)(lp+(int)(*ip++));
                    964: 
                    965: lp+!#  --      new     lp_plus_store_number
                    966: ""used with negative immediate values it allocates memory on the
                    967: local stack, a positive immediate argument drops memory from the local
                    968: stack""
                    969: lp += (int)(*ip++);
                    970: 
                    971: lp!    c_addr --       new     lp_store
                    972: lp = (Address)c_addr;
                    973: 
                    974: >l     w --    new     to_l
                    975: lp -= sizeof(Cell);
                    976: *(Cell *)lp = w;
                    977: 
                    978: f>l    r --    new     f_to_l
                    979: lp -= sizeof(Float);
                    980: *(Float *)lp = r;
1.4       pazsan    981: 
                    982: up!    a_addr --       new     up_store
                    983: up=a_addr;

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