Annotation of gforth/primitives, revision 1.11

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

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