Annotation of gforth/primitives, revision 1.4

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

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