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