Annotation of gforth/primitives, revision 1.19
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;
1.19 ! pazsan 444: :
! 445: dup IF 0 (um/mod) THEN nip ;
! 446: : (um/mod) ( ud ud--ud u)
! 447: 2dup >r >r dup 0<
! 448: IF 2drop 0
! 449: ELSE 2dup d+ (um/mod) 2* THEN
! 450: -rot r> r> 2over 2over du<
! 451: IF 2drop rot
! 452: ELSE dnegate d+ rot 1+ THEN ;
1.1 anton 453:
454: m+ d1 n -- d2 double m_plus
455: d2 = d1+n;
1.18 pazsan 456: :
457: s>d d+ ;
1.1 anton 458:
459: d+ d1 d2 -- d double,fig d_plus
460: d = d1+d2;
1.18 pazsan 461: :
462: >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/
463: r> + >r + r> 0< r> r> + swap - ;
1.1 anton 464:
465: d- d1 d2 -- d double d_minus
466: d = d1-d2;
1.18 pazsan 467: :
468: dnegate d+ ;
1.1 anton 469:
470: dnegate d1 -- d2 double
471: /* use dminus as alias */
472: d2 = -d1;
1.18 pazsan 473: :
474: invert swap negate tuck 0= - ;
1.1 anton 475:
476: dmax d1 d2 -- d double
477: if (d1<d2)
478: d = d2;
479: else
480: d = d1;
1.18 pazsan 481: :
482: 2over 2over d> IF 2swap THEN 2drop ;
1.1 anton 483:
484: dmin d1 d2 -- d double
485: if (d1<d2)
486: d = d1;
487: else
488: d = d2;
1.18 pazsan 489: :
490: 2over 2over d< IF 2swap THEN 2drop ;
1.1 anton 491:
492: dabs d1 -- d2 double
493: if (d1<0)
494: d2 = -d1;
495: else
496: d2 = d1;
1.18 pazsan 497: :
498: dup 0< IF dnegate THEN ;
1.1 anton 499:
500: d2* d1 -- d2 double d_two_star
501: d2 = 2*d1;
1.18 pazsan 502: :
503: 2dup d+ ;
1.1 anton 504:
505: d2/ d1 -- d2 double d_two_slash
506: /* !! is this still correct? */
1.13 pazsan 507: d2 = d1>>1;
1.18 pazsan 508: :
509: dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
510: r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ;
1.1 anton 511:
512: d>s d -- n double d_to_s
513: /* make this an alias for drop? */
514: n = d;
1.18 pazsan 515: :
516: drop ;
1.1 anton 517:
518: and w1 w2 -- w core,fig
519: w = w1&w2;
520:
521: or w1 w2 -- w core,fig
522: w = w1|w2;
523:
524: xor w1 w2 -- w core,fig
525: w = w1^w2;
526:
527: invert w1 -- w2 core
528: w2 = ~w1;
1.18 pazsan 529: :
530: -1 xor ;
1.1 anton 531:
532: rshift u1 n -- u2 core
533: u2 = u1>>n;
534:
535: lshift u1 n -- u2 core
536: u2 = u1<<n;
537:
1.6 anton 538: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
1.1 anton 539: define(comparisons,
540: $1= $2 -- f $6 $3equals
541: f = FLAG($4==$5);
542:
543: $1<> $2 -- f $7 $3different
544: /* use != as alias ? */
545: f = FLAG($4!=$5);
546:
547: $1< $2 -- f $8 $3less
548: f = FLAG($4<$5);
549:
550: $1> $2 -- f $9 $3greater
551: f = FLAG($4>$5);
552:
553: $1<= $2 -- f new $3less_or_equal
554: f = FLAG($4<=$5);
555:
556: $1>= $2 -- f new $3greater_or_equal
557: f = FLAG($4>=$5);
558:
559: )
560:
561: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
562: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
563: comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext)
564: comparisons(d, d1 d2, d_, d1, d2, double, new, double, new)
565: comparisons(d0, d, d_zero_, d, 0, double, new, double, new)
566: comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new)
567:
568: within u1 u2 u3 -- f core-ext
569: f = FLAG(u1-u2 < u3-u2);
1.18 pazsan 570: :
571: over - >r - r> u< ;
1.1 anton 572:
573: sp@ -- a_addr fig spat
1.15 pazsan 574: a_addr = sp+1;
1.1 anton 575:
576: sp! a_addr -- fig spstore
1.15 pazsan 577: sp = a_addr;
1.1 anton 578: /* works with and without TOS caching */
579:
580: rp@ -- a_addr fig rpat
581: a_addr = rp;
582:
583: rp! a_addr -- fig rpstore
584: rp = a_addr;
585:
586: fp@ -- f_addr new fp_fetch
587: f_addr = fp;
588:
589: fp! f_addr -- new fp_store
590: fp = f_addr;
591:
1.3 pazsan 592: ;s -- core exit
1.1 anton 593: ip = (Xt *)(*rp++);
594:
595: >r w -- core,fig to_r
596: *--rp = w;
597:
598: r> -- w core,fig r_from
599: w = *rp++;
600:
601: r@ -- w core,fig r_fetch
602: /* use r as alias */
603: /* make r@ an alias for i */
604: w = *rp;
605:
606: rdrop -- fig
607: rp++;
608:
609: i' -- w fig i_tick
610: w=rp[1];
611:
1.14 anton 612: 2>r w1 w2 -- core-ext two_to_r
613: *--rp = w1;
614: *--rp = w2;
615:
616: 2r> -- w1 w2 core-ext two_r_from
617: w2 = *rp++;
618: w1 = *rp++;
619:
620: 2r@ -- w1 w2 core-ext two_r_fetch
621: w2 = rp[0];
622: w1 = rp[1];
623:
624: 2rdrop -- new two_r_drop
625: rp+=2;
626:
1.1 anton 627: over w1 w2 -- w1 w2 w1 core,fig
628:
629: drop w -- core,fig
630:
631: swap w1 w2 -- w2 w1 core,fig
632:
633: dup w -- w w core,fig
634:
635: rot w1 w2 w3 -- w2 w3 w1 core rote
636:
637: -rot w1 w2 w3 -- w3 w1 w2 fig not_rote
1.18 pazsan 638: :
639: rot rot ;
1.1 anton 640:
641: nip w1 w2 -- w2 core-ext
1.18 pazsan 642: :
643: swap drop ;
1.1 anton 644:
645: tuck w1 w2 -- w2 w1 w2 core-ext
1.18 pazsan 646: :
647: swap over ;
1.1 anton 648:
649: ?dup w -- w core question_dupe
650: if (w!=0) {
1.7 pazsan 651: IF_TOS(*sp-- = w;)
1.1 anton 652: #ifndef USE_TOS
1.7 pazsan 653: *--sp = w;
1.1 anton 654: #endif
655: }
1.18 pazsan 656: :
657: dup IF dup THEN ;
1.1 anton 658:
659: pick u -- w core-ext
660: w = sp[u+1];
1.18 pazsan 661: :
662: 1+ cells sp@ + @ ;
1.1 anton 663:
664: 2drop w1 w2 -- core two_drop
1.18 pazsan 665: :
666: drop drop ;
1.1 anton 667:
668: 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe
1.18 pazsan 669: :
670: over over ;
1.1 anton 671:
672: 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over
1.18 pazsan 673: :
674: 3 pick 3 pick ;
1.1 anton 675:
676: 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap
1.18 pazsan 677: :
678: >r -rot r> -rot ;
1.1 anton 679:
680: 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double two_rote
1.18 pazsan 681: :
682: >r >r 2swap r> r> 2swap ;
1.1 anton 683:
1.6 anton 684: \ toggle is high-level: 0.11/0.42%
1.1 anton 685:
686: @ a_addr -- w fig fetch
687: w = *a_addr;
688:
689: ! w a_addr -- core,fig store
690: *a_addr = w;
691:
692: +! n a_addr -- core,fig plus_store
693: *a_addr += n;
694:
695: c@ c_addr -- c fig cfetch
696: c = *c_addr;
697:
698: c! c c_addr -- fig cstore
699: *c_addr = c;
700:
701: 2! w1 w2 a_addr -- core two_store
702: a_addr[0] = w2;
703: a_addr[1] = w1;
1.18 pazsan 704: :
705: tuck ! cell+ ! ;
1.1 anton 706:
707: 2@ a_addr -- w1 w2 core two_fetch
708: w2 = a_addr[0];
709: w1 = a_addr[1];
1.18 pazsan 710: :
711: dup cell+ @ swap @ ;
1.1 anton 712:
713: d! d a_addr -- double d_store
714: /* !! alignment problems on some machines */
715: *(DCell *)a_addr = d;
716:
717: d@ a_addr -- d double d_fetch
718: d = *(DCell *)a_addr;
719:
720: cell+ a_addr1 -- a_addr2 core cell_plus
721: a_addr2 = a_addr1+1;
1.18 pazsan 722: :
723: [ cell ] Literal + ;
1.1 anton 724:
725: cells n1 -- n2 core
726: n2 = n1 * sizeof(Cell);
1.18 pazsan 727: :
728: [ cell ]
729: [ 2/ dup ] [IF] 2* [THEN]
730: [ 2/ dup ] [IF] 2* [THEN]
731: [ 2/ dup ] [IF] 2* [THEN]
732: [ 2/ dup ] [IF] 2* [THEN]
733: [ drop ] ;
1.1 anton 734:
735: char+ c_addr1 -- c_addr2 core care_plus
1.18 pazsan 736: c_addr2 = c_addr1 + 1;
737: :
738: 1+ ;
1.1 anton 739:
740: chars n1 -- n2 core cares
741: n2 = n1 * sizeof(Char);
1.18 pazsan 742: :
743: ;
1.1 anton 744:
745: count c_addr1 -- c_addr2 u core
746: u = *c_addr1;
747: c_addr2 = c_addr1+1;
1.18 pazsan 748: :
749: dup 1+ swap c@ ;
1.1 anton 750:
751: (bye) n -- toolkit-ext paren_bye
1.15 pazsan 752: return (Label *)n;
1.1 anton 753:
754: system c_addr u -- n own
1.17 anton 755: n=system(cstr(c_addr,u,1));
1.1 anton 756:
1.16 anton 757: getenv c_addr1 u1 -- c_addr2 u2 new
1.17 anton 758: c_addr2 = getenv(cstr(c_addr1,u1,1));
1.16 anton 759: u2=strlen(c_addr2);
760:
1.1 anton 761: popen c_addr u n -- wfileid own
762: static char* mode[2]={"r","w"};
1.17 anton 763: wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);
1.1 anton 764:
1.18 pazsan 765: pclose wfileid -- wior own
1.1 anton 766: wior=pclose((FILE *)wfileid);
1.2 pazsan 767:
1.16 anton 768: time&date -- nyear nmonth nday nhour nmin nsec facility-ext time_and_date
1.2 pazsan 769: struct timeval time1;
770: struct timezone zone1;
771: struct tm *ltime;
772: gettimeofday(&time1,&zone1);
773: ltime=localtime(&time1.tv_sec);
774: nyear =ltime->tm_year+1900;
775: nmonth=ltime->tm_mon;
776: nday =ltime->tm_mday;
777: nhour =ltime->tm_hour;
778: nmin =ltime->tm_min;
779: nsec =ltime->tm_sec;
780:
1.16 anton 781: ms n -- facility-ext
1.2 pazsan 782: struct timeval timeout;
783: timeout.tv_sec=n/1000;
784: timeout.tv_usec=1000*(n%1000);
785: (void)select(0,0,0,0,&timeout);
1.1 anton 786:
787: allocate u -- a_addr wior memory
788: a_addr = (Cell *)malloc(u);
1.6 anton 789: wior = a_addr==NULL; /* !! Define a return code */
1.1 anton 790:
791: free a_addr -- wior memory
792: free(a_addr);
793: wior = 0;
794:
795: resize a_addr1 u -- a_addr2 wior memory
796: a_addr2 = realloc(a_addr1, u);
1.6 anton 797: wior = a_addr2==NULL; /* !! Define a return code */
1.1 anton 798:
799: (f83find) c_addr u f83name1 -- f83name2 new paren_f83find
800: for (; f83name1 != NULL; f83name1 = f83name1->next)
1.8 pazsan 801: if (F83NAME_COUNT(f83name1)==u &&
1.13 pazsan 802: strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1.8 pazsan 803: break;
804: f83name2=f83name1;
1.18 pazsan 805: :
806: BEGIN dup WHILE
807: >r dup r@ cell+ c@ $1F and =
808: IF 2dup r@ cell+ char+ capscomp 0=
809: IF 2drop r> EXIT THEN THEN
810: r> @
811: REPEAT nip nip ;
1.8 pazsan 812:
1.13 pazsan 813: (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind
814: F83Name *f83name1;
815: f83name2=NULL;
816: while(a_addr != NULL)
817: {
818: f83name1=(F83Name *)(a_addr[1]);
819: a_addr=(Cell *)(a_addr[0]);
820: if (F83NAME_COUNT(f83name1)==u &&
821: strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
822: {
823: f83name2=f83name1;
824: break;
825: }
826: }
1.18 pazsan 827: :
828: BEGIN dup WHILE
829: 2@ >r >r dup r@ cell+ c@ $1F and =
830: IF 2dup r@ cell+ char+ capscomp 0=
831: IF 2drop r> rdrop EXIT THEN THEN
832: rdrop r>
833: REPEAT nip nip ;
1.13 pazsan 834:
1.14 anton 835: (hashkey) c_addr u1 -- u2 new paren_hashkey
1.13 pazsan 836: u2=0;
837: while(u1--)
838: u2+=(int)toupper(*c_addr++);
1.18 pazsan 839: :
840: 0 -rot bounds ?DO I c@ toupper + LOOP ;
1.14 anton 841:
842: (hashkey1) c_addr u ubits -- ukey new paren_hashkey1
843: ""ukey is the hash key for the string c_addr u fitting in ubits bits""
844: /* this hash function rotates the key at every step by rot bits within
845: ubits bits and xors it with the character. This function does ok in
846: the chi-sqare-test. Rot should be <=7 (preferably <=5) for
847: ASCII strings (larger if ubits is large), and should share no
848: divisors with ubits.
849: */
850: 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];
851: Char *cp = c_addr;
852: for (ukey=0; cp<c_addr+u; cp++)
853: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
854: ^ toupper(*cp))
855: & ((1<<ubits)-1));
1.18 pazsan 856: :
857: dup rot-values + c@ over 1 swap lshift 1- >r
858: tuck - 2swap r> 0 2swap bounds
859: ?DO dup 4 pick lshift swap 3 pick rshift or
860: I c@ toupper xor
861: over and LOOP
862: nip nip nip ;
863: Create rot-values
864: 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c,
865: 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c,
866: 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c,
867: 7 c, 5 c, 5 c,
1.1 anton 868:
869: (parse-white) c_addr1 u1 -- c_addr2 u2 new paren_parse_white
870: /* use !isgraph instead of isspace? */
871: Char *endp = c_addr1+u1;
872: while (c_addr1<endp && isspace(*c_addr1))
873: c_addr1++;
874: if (c_addr1<endp) {
875: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
876: ;
877: u2 = c_addr1-c_addr2;
878: }
879: else {
880: c_addr2 = c_addr1;
881: u2 = 0;
882: }
1.18 pazsan 883: :
884: BEGIN dup WHILE over c@ bl <= WHILE 1 /string
885: REPEAT THEN 2dup
886: BEGIN dup WHILE over c@ bl > WHILE 1 /string
887: REPEAT THEN nip - ;
1.1 anton 888:
889: close-file wfileid -- wior file close_file
1.7 pazsan 890: wior = FILEIO(fclose((FILE *)wfileid)==EOF);
1.1 anton 891:
892: open-file c_addr u ntype -- w2 wior file open_file
1.18 pazsan 893: w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
1.7 pazsan 894: wior = FILEEXIST(w2 == NULL);
1.1 anton 895:
896: create-file c_addr u ntype -- w2 wior file create_file
897: int fd;
1.18 pazsan 898: fd = creat(cstr(c_addr, u, 1), 0644);
1.1 anton 899: if (fd > -1) {
900: w2 = (Cell)fdopen(fd, fileattr[ntype]);
901: assert(w2 != NULL);
902: wior = 0;
903: } else {
904: assert(fd == -1);
1.7 pazsan 905: wior = FILEIO(fd);
1.1 anton 906: w2 = 0;
907: }
908:
909: delete-file c_addr u -- wior file delete_file
1.18 pazsan 910: wior = FILEEXIST(unlink(cstr(c_addr, u, 1)));
1.1 anton 911:
912: rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file
1.18 pazsan 913: char *s1=cstr(c_addr2, u2, 1);
1.17 anton 914: wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1));
1.1 anton 915:
916: file-position wfileid -- ud wior file file_position
917: /* !! use tell and lseek? */
918: ud = ftell((FILE *)wfileid);
919: wior = 0; /* !! or wior = FLAG(ud<0) */
920:
921: reposition-file ud wfileid -- wior file reposition_file
1.7 pazsan 922: wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET));
1.1 anton 923:
924: file-size wfileid -- ud wior file file_size
925: struct stat buf;
1.7 pazsan 926: wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));
1.1 anton 927: ud = buf.st_size;
928:
929: resize-file ud wfileid -- wior file resize_file
1.7 pazsan 930: wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud));
1.1 anton 931:
932: read-file c_addr u1 wfileid -- u2 wior file read_file
933: /* !! fread does not guarantee enough */
934: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1.7 pazsan 935: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1.1 anton 936: /* !! who performs clearerr((FILE *)wfileid); ? */
937:
938: read-line c_addr u1 wfileid -- u2 flag wior file read_line
1.13 pazsan 939: /*
940: Cell c;
941: flag=-1;
942: for(u2=0; u2<u1; u2++)
943: {
944: *c_addr++ = (Char)(c = getc((FILE *)wfileid));
945: if(c=='\n') break;
946: if(c==EOF)
947: {
948: flag=FLAG(u2!=0);
949: break;
950: }
951: }
952: wior=FILEIO(ferror((FILE *)wfileid));
953: */
954: if ((flag=FLAG(!feof((FILE *)wfileid) &&
955: fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
1.11 anton 956: wior=FILEIO(ferror((FILE *)wfileid));
1.13 pazsan 957: u2 = strlen(c_addr);
1.11 anton 958: u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
959: }
960: else {
961: wior=0;
962: u2=0;
963: }
1.1 anton 964:
965: write-file c_addr u1 wfileid -- wior file write_file
966: /* !! fwrite does not guarantee enough */
967: {
968: int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1.7 pazsan 969: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1.1 anton 970: }
971:
972: flush-file wfileid -- wior file-ext flush_file
1.7 pazsan 973: wior = FILEIO(fflush((FILE *) wfileid));
1.1 anton 974:
975: comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
976: comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
977:
978: d>f d -- r float d_to_f
979: r = d;
980:
981: f>d r -- d float f_to_d
982: /* !! basis 15 is not very specific */
983: d = r;
984:
985: f! r f_addr -- float f_store
986: *f_addr = r;
987:
988: f@ f_addr -- r float f_fetch
989: r = *f_addr;
990:
991: df@ df_addr -- r float-ext d_f_fetch
992: #ifdef IEEE_FP
993: r = *df_addr;
994: #else
995: !! df@
996: #endif
997:
998: df! r df_addr -- float-ext d_f_store
999: #ifdef IEEE_FP
1000: *df_addr = r;
1001: #else
1002: !! df!
1003: #endif
1004:
1005: sf@ sf_addr -- r float-ext s_f_fetch
1006: #ifdef IEEE_FP
1007: r = *sf_addr;
1008: #else
1009: !! sf@
1010: #endif
1011:
1012: sf! r sf_addr -- float-ext s_f_store
1013: #ifdef IEEE_FP
1014: *sf_addr = r;
1015: #else
1016: !! sf!
1017: #endif
1018:
1019: f+ r1 r2 -- r3 float f_plus
1020: r3 = r1+r2;
1021:
1022: f- r1 r2 -- r3 float f_minus
1023: r3 = r1-r2;
1024:
1025: f* r1 r2 -- r3 float f_star
1026: r3 = r1*r2;
1027:
1028: f/ r1 r2 -- r3 float f_slash
1029: r3 = r1/r2;
1030:
1031: f** r1 r2 -- r3 float-ext f_star_star
1032: r3 = pow(r1,r2);
1033:
1034: fnegate r1 -- r2 float
1035: r2 = - r1;
1036:
1037: fdrop r -- float
1038:
1039: fdup r -- r r float
1040:
1041: fswap r1 r2 -- r2 r1 float
1042:
1043: fover r1 r2 -- r1 r2 r1 float
1044:
1045: frot r1 r2 r3 -- r2 r3 r1 float
1046:
1047: float+ f_addr1 -- f_addr2 float float_plus
1048: f_addr2 = f_addr1+1;
1049:
1050: floats n1 -- n2 float
1051: n2 = n1*sizeof(Float);
1052:
1053: floor r1 -- r2 float
1054: /* !! unclear wording */
1055: r2 = floor(r1);
1056:
1057: fround r1 -- r2 float
1058: /* !! unclear wording */
1059: r2 = rint(r1);
1060:
1061: fmax r1 r2 -- r3 float
1062: if (r1<r2)
1063: r3 = r2;
1064: else
1065: r3 = r1;
1066:
1067: fmin r1 r2 -- r3 float
1068: if (r1<r2)
1069: r3 = r1;
1070: else
1071: r3 = r2;
1072:
1073: represent r c_addr u -- n f1 f2 float
1074: char *sig;
1075: int flag;
1.9 anton 1076: int decpt;
1077: sig=ecvt(r, u, &decpt, &flag);
1078: n=decpt;
1.1 anton 1079: f1=FLAG(flag!=0);
1080: f2=FLAG(isdigit(sig[0])!=0);
1081: memmove(c_addr,sig,u);
1082:
1083: >float c_addr u -- flag float to_float
1084: /* real signature: c_addr u -- r t / f */
1085: Float r;
1.17 anton 1086: char *number=cstr(c_addr, u, 1);
1.1 anton 1087: char *endconv;
1088: r=strtod(number,&endconv);
1.8 pazsan 1089: if((flag=FLAG(!(int)*endconv)))
1.1 anton 1090: {
1091: IF_FTOS(fp[0] = FTOS);
1092: fp += -1;
1093: FTOS = r;
1094: }
1095: else if(*endconv=='d' || *endconv=='D')
1096: {
1097: *endconv='E';
1098: r=strtod(number,&endconv);
1.8 pazsan 1099: if((flag=FLAG(!(int)*endconv)))
1.1 anton 1100: {
1101: IF_FTOS(fp[0] = FTOS);
1102: fp += -1;
1103: FTOS = r;
1104: }
1105: }
1106:
1107: fabs r1 -- r2 float-ext
1108: r2 = fabs(r1);
1109:
1110: facos r1 -- r2 float-ext
1111: r2 = acos(r1);
1112:
1113: fasin r1 -- r2 float-ext
1114: r2 = asin(r1);
1115:
1116: fatan r1 -- r2 float-ext
1117: r2 = atan(r1);
1118:
1119: fatan2 r1 r2 -- r3 float-ext
1120: r3 = atan2(r1,r2);
1121:
1122: fcos r1 -- r2 float-ext
1123: r2 = cos(r1);
1124:
1125: fexp r1 -- r2 float-ext
1126: r2 = exp(r1);
1127:
1.3 pazsan 1128: fexpm1 r1 -- r2 float-ext
1129: r2 =
1.18 pazsan 1130: #ifdef HAS_EXPM1
1.3 pazsan 1131: expm1(r1);
1132: #else
1133: exp(r1)-1;
1134: #endif
1135:
1.1 anton 1136: fln r1 -- r2 float-ext
1137: r2 = log(r1);
1138:
1.3 pazsan 1139: flnp1 r1 -- r2 float-ext
1140: r2 =
1.18 pazsan 1141: #ifdef HAS_LOG1P
1.3 pazsan 1142: log1p(r1);
1143: #else
1.18 pazsan 1144: log(r1+1);
1.3 pazsan 1145: #endif
1146:
1.1 anton 1147: flog r1 -- r2 float-ext
1148: r2 = log10(r1);
1149:
1.3 pazsan 1150: fsin r1 -- r2 float-ext
1151: r2 = sin(r1);
1152:
1153: fsincos r1 -- r2 r3 float-ext
1.1 anton 1154: r2 = sin(r1);
1155: r3 = cos(r1);
1156:
1157: fsqrt r1 -- r2 float-ext
1158: r2 = sqrt(r1);
1159:
1160: ftan r1 -- r2 float-ext
1161: r2 = tan(r1);
1162:
1.6 anton 1163: \ The following words access machine/OS/installation-dependent ANSI
1164: \ figForth internals
1165: \ !! how about environmental queries DIRECT-THREADED,
1166: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
1.1 anton 1167:
1168: >body xt -- a_addr core to_body
1169: a_addr = PFA(xt);
1170:
1171: >code-address xt -- c_addr new to_code_address
1172: ""c_addr is the code address of the word xt""
1173: /* !! This behaves installation-dependently for DOES-words */
1174: c_addr = CODE_ADDRESS(xt);
1175:
1176: >does-code xt -- a_addr new to_does_code
1177: ""If xt ist the execution token of a defining-word-defined word,
1178: a_addr is the start of the Forth code after the DOES>; Otherwise the
1179: behaviour is uundefined""
1180: /* !! there is currently no way to determine whether a word is
1181: defining-word-defined */
1182: a_addr = DOES_CODE(xt);
1183:
1.4 pazsan 1184: code-address! n xt -- new code_address_store
1.1 anton 1185: ""Creates a code field with code address c_addr at xt""
1.4 pazsan 1186: MAKE_CF(xt, symbols[CF(n)]);
1.5 pazsan 1187: CACHE_FLUSH(xt,PFA(0));
1.1 anton 1188:
1189: does-code! a_addr xt -- new does_code_store
1190: ""creates a code field at xt for a defining-word-defined word; a_addr
1191: is the start of the Forth code after DOES>""
1192: MAKE_DOES_CF(xt, a_addr);
1.5 pazsan 1193: CACHE_FLUSH(xt,PFA(0));
1.1 anton 1194:
1195: does-handler! a_addr -- new does_jump_store
1196: ""creates a DOES>-handler at address a_addr. a_addr usually points
1197: just behind a DOES>.""
1198: MAKE_DOES_HANDLER(a_addr);
1.5 pazsan 1199: CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
1.1 anton 1200:
1201: /does-handler -- n new slash_does_handler
1202: ""the size of a does-handler (includes possible padding)""
1203: /* !! a constant or environmental query might be better */
1204: n = DOES_HANDLER_SIZE;
1205:
1206: toupper c1 -- c2 new
1207: c2 = toupper(c1);
1208:
1.6 anton 1209: \ local variable implementation primitives
1.1 anton 1210: @local# -- w new fetch_local_number
1211: w = *(Cell *)(lp+(int)(*ip++));
1212:
1.9 anton 1213: @local0 -- w new fetch_local_zero
1.18 pazsan 1214: w = *(Cell *)(lp+0*sizeof(Cell));
1.9 anton 1215:
1.18 pazsan 1216: @local1 -- w new fetch_local_four
1217: w = *(Cell *)(lp+1*sizeof(Cell));
1.9 anton 1218:
1.18 pazsan 1219: @local2 -- w new fetch_local_eight
1220: w = *(Cell *)(lp+2*sizeof(Cell));
1.9 anton 1221:
1.18 pazsan 1222: @local3 -- w new fetch_local_twelve
1223: w = *(Cell *)(lp+3*sizeof(Cell));
1.9 anton 1224:
1.1 anton 1225: f@local# -- r new f_fetch_local_number
1226: r = *(Float *)(lp+(int)(*ip++));
1227:
1.9 anton 1228: f@local0 -- r new f_fetch_local_zero
1.18 pazsan 1229: r = *(Float *)(lp+0*sizeof(Float));
1.9 anton 1230:
1.18 pazsan 1231: f@local1 -- r new f_fetch_local_eight
1232: r = *(Float *)(lp+1*sizeof(Float));
1.9 anton 1233:
1.1 anton 1234: laddr# -- c_addr new laddr_number
1235: /* this can also be used to implement lp@ */
1236: c_addr = (Char *)(lp+(int)(*ip++));
1237:
1238: lp+!# -- new lp_plus_store_number
1239: ""used with negative immediate values it allocates memory on the
1240: local stack, a positive immediate argument drops memory from the local
1241: stack""
1242: lp += (int)(*ip++);
1.9 anton 1243:
1.18 pazsan 1244: lp- -- new minus_four_lp_plus_store
1245: lp += -sizeof(Cell);
1.9 anton 1246:
1.18 pazsan 1247: lp+ -- new eight_lp_plus_store
1248: lp += sizeof(Float);
1.9 anton 1249:
1.18 pazsan 1250: lp+2 -- new sixteen_lp_plus_store
1251: lp += 2*sizeof(Float);
1.1 anton 1252:
1253: lp! c_addr -- new lp_store
1254: lp = (Address)c_addr;
1255:
1256: >l w -- new to_l
1257: lp -= sizeof(Cell);
1258: *(Cell *)lp = w;
1259:
1260: f>l r -- new f_to_l
1261: lp -= sizeof(Float);
1262: *(Float *)lp = r;
1.4 pazsan 1263:
1264: up! a_addr -- new up_store
1.18 pazsan 1265: 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