File:
[gforth] /
gforth /
Attic /
primitives
Revision
1.42:
download - view:
text,
annotated -
select for diffs
Wed Oct 11 19:39:35 1995 UTC (28 years, 6 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
Now gforth.fi is a nonrelocatable image containing all of startup.fs etc.
savesystem now saves `included-files', too (so require does not start from
scratch)
added/fixed stack effect and wordset documentation for many words in kernal.fs
some reformatting in kernal.fs
fixed some wordset info in primitives
added strsignal
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: \
7: \
8: \ This file contains instructions in the following format:
9: \
10: \ forth name stack effect category [pronunciation]
11: \ [""glossary entry""]
12: \ C code
13: \ [:
14: \ Forth code]
15: \
16: \ The pronunciation is also used for forming C names.
17: \
18: \
19: \
20: \ These informations are automatically translated into C-code for the
21: \ interpreter and into some other files. I hope that your C compiler has
22: \ decent optimization, otherwise the automatically generated code will
23: \ be somewhat slow. The Forth version of the code is included for manual
24: \ compilers, so they will need to compile only the important words.
25: \
26: \ Note that stack pointer adjustment is performed according to stack
27: \ effect by automatically generated code and NEXT is automatically
28: \ appended to the C code. Also, you can use the names in the stack
29: \ effect in the C code. Stack access is automatic. One exception: if
30: \ your code does not fall through, the results are not stored into the
31: \ stack. Use different names on both sides of the '--', if you change a
32: \ value (some stores to the stack are optimized away).
33: \
34: \
35: \
36: \ The stack variables have the following types:
37: \
38: \ name matches type
39: \ f.* Bool
40: \ c.* Char
41: \ [nw].* Cell
42: \ u.* UCell
43: \ d.* DCell
44: \ ud.* UDCell
45: \ r.* Float
46: \ a_.* Cell *
47: \ c_.* Char *
48: \ f_.* Float *
49: \ df_.* DFloat *
50: \ sf_.* SFloat *
51: \ xt.* XT
52: \ wid.* WID
53: \ f83name.* F83Name *
54: \
55: \
56: \
57: \ In addition the following names can be used:
58: \ ip the instruction pointer
59: \ sp the data stack pointer
60: \ rp the parameter stack pointer
61: \ lp the locals stack pointer
62: \ NEXT executes NEXT
63: \ cfa
64: \ NEXT1 executes NEXT1
65: \ FLAG(x) makes a Forth flag from a C flag
66: \
67: \
68: \
69: \ Percentages in comments are from Koopmans book: average/maximum use
70: \ (taken from four, not very representative benchmarks)
71: \
72: \
73: \
74: \ To do:
75: \
76: \ throw execute, cfa and NEXT1 out?
77: \ macroize *ip, ip++, *ip++ (pipelining)?
78:
79: \ these m4 macros would collide with identifiers
80: undefine(`index')
81: undefine(`shift')
82:
83: noop -- fig
84: ;
85: :
86: ;
87:
88: lit -- w fig
89: w = (Cell)NEXT_INST;
90: INC_IP(1);
91:
92: execute xt -- core
93: ip=IP;
94: cfa = xt;
95: IF_TOS(TOS = sp[0]);
96: NEXT1;
97:
98: branch-lp+!# -- new branch_lp_plus_store_number
99: /* this will probably not be used */
100: branch_adjust_lp:
101: lp += (Cell)(IP[1]);
102: goto branch;
103:
104: branch -- fig
105: branch:
106: ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
107: NEXT_P0;
108: :
109: r> dup @ + >r ;
110:
111: \ condbranch(forthname,restline,code)
112: \ this is non-syntactical: code must open a brace that is closed by the macro
113: define(condbranch,
114: $1 $2
115: $3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
116: NEXT_P0;
117: NEXT;
118: }
119: else
120: INC_IP(1);
121:
122: $1-lp+!# $2_lp_plus_store_number
123: $3 goto branch_adjust_lp;
124: }
125: else
126: INC_IP(2);
127:
128: )
129:
130: condbranch(?branch,f -- f83 question_branch,
131: if (f==0) {
132: IF_TOS(TOS = sp[0]);
133: )
134:
135: condbranch((next),-- cmFORTH paren_next,
136: if ((*rp)--) {
137: )
138:
139: condbranch((loop),-- fig paren_loop,
140: Cell index = *rp+1;
141: Cell limit = rp[1];
142: if (index != limit) {
143: *rp = index;
144: )
145:
146: condbranch((+loop),n -- gforth paren_plus_loop,
147: /* !! check this thoroughly */
148: Cell index = *rp;
149: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
150: /* dependent upon two's complement arithmetic */
151: Cell olddiff = index-rp[1];
152: #ifndef undefined
153: if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
154: || (olddiff^n)>=0 /* it is a wrap-around effect */) {
155: #else
156: #ifndef MAXINT
157: #define MAXINT ((((Cell)1)<<(8*sizeof(Cell)-1))-1)
158: #endif
159: if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
160: #endif
161: #ifdef i386
162: *rp += n;
163: #else
164: *rp = index + n;
165: #endif
166: IF_TOS(TOS = sp[0]);
167: )
168:
169: condbranch((-loop),u -- gforth paren_minus_loop,
170: /* !! check this thoroughly */
171: Cell index = *rp;
172: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
173: /* dependent upon two's complement arithmetic */
174: UCell olddiff = index-rp[1];
175: if (olddiff>u) {
176: *rp = index - u;
177: IF_TOS(TOS = sp[0]);
178: )
179:
180: condbranch((s+loop),n -- gforth paren_symmetric_plus_loop,
181: ""The run-time procedure compiled by S+LOOP. It loops until the index
182: crosses the boundary between limit and limit-sign(n). I.e. a symmetric
183: version of (+LOOP).""
184: /* !! check this thoroughly */
185: Cell index = *rp;
186: Cell diff = index-rp[1];
187: Cell newdiff = diff+n;
188: if (n<0) {
189: diff = -diff;
190: newdiff = -newdiff;
191: }
192: if (diff>=0 || newdiff<0) {
193: #ifdef i386
194: *rp += n;
195: #else
196: *rp = index + n;
197: #endif
198: IF_TOS(TOS = sp[0]);
199: )
200:
201: unloop -- core
202: rp += 2;
203: :
204: r> rdrop rdrop >r ;
205:
206: (for) ncount -- cmFORTH paren_for
207: /* or (for) = >r -- collides with unloop! */
208: *--rp = 0;
209: *--rp = ncount;
210: :
211: r> swap 0 >r >r >r ;
212:
213: (do) nlimit nstart -- fig paren_do
214: /* or do it in high-level? 0.09/0.23% */
215: *--rp = nlimit;
216: *--rp = nstart;
217: :
218: r> -rot swap >r >r >r ;
219:
220: (?do) nlimit nstart -- new paren_question_do
221: *--rp = nlimit;
222: *--rp = nstart;
223: if (nstart == nlimit) {
224: IF_TOS(TOS = sp[0]);
225: goto branch;
226: }
227: else {
228: INC_IP(1);
229: }
230:
231: (+do) nlimit nstart -- new paren_plus_do
232: *--rp = nlimit;
233: *--rp = nstart;
234: if (nstart >= nlimit) {
235: IF_TOS(TOS = sp[0]);
236: goto branch;
237: }
238: else {
239: INC_IP(1);
240: }
241:
242: (u+do) ulimit ustart -- new paren_u_plus_do
243: *--rp = ulimit;
244: *--rp = ustart;
245: if (ustart >= ulimit) {
246: IF_TOS(TOS = sp[0]);
247: goto branch;
248: }
249: else {
250: INC_IP(1);
251: }
252:
253: (-do) nlimit nstart -- new paren_minus_do
254: *--rp = nlimit;
255: *--rp = nstart;
256: if (nstart <= nlimit) {
257: IF_TOS(TOS = sp[0]);
258: goto branch;
259: }
260: else {
261: INC_IP(1);
262: }
263:
264: (u-do) ulimit ustart -- new paren_u_minus_do
265: *--rp = ulimit;
266: *--rp = ustart;
267: if (ustart <= ulimit) {
268: IF_TOS(TOS = sp[0]);
269: goto branch;
270: }
271: else {
272: INC_IP(1);
273: }
274:
275: i -- n core
276: n = *rp;
277:
278: j -- n core
279: n = rp[2];
280:
281: \ digit is high-level: 0/0%
282:
283: (emit) c -- fig paren_emit
284: putchar(c);
285: emitcounter++;
286:
287: (type) c_addr n -- gforth paren_type
288: fwrite(c_addr,sizeof(Char),n,stdout);
289: emitcounter += n;
290:
291: (key) -- n fig paren_key
292: fflush(stdout);
293: /* !! noecho */
294: n = key();
295:
296: key? -- n facility key_q
297: fflush(stdout);
298: n = key_query;
299:
300: cr -- core
301: puts("");
302: :
303: $0A emit ;
304:
305: move c_from c_to ucount -- core
306: memmove(c_to,c_from,ucount);
307: /* make an Ifdef for bsd and others? */
308: :
309: >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
310:
311: cmove c_from c_to u -- string
312: while (u-- > 0)
313: *c_to++ = *c_from++;
314: :
315: bounds ?DO dup c@ I c! 1+ LOOP drop ;
316:
317: cmove> c_from c_to u -- string c_move_up
318: while (u-- > 0)
319: c_to[u] = c_from[u];
320: :
321: dup 0= IF drop 2drop exit THEN
322: rot over + -rot bounds swap 1-
323: DO 1- dup c@ I c! -1 +LOOP drop ;
324:
325: fill c_addr u c -- core
326: memset(c_addr,c,u);
327: :
328: -rot bounds
329: ?DO dup I c! LOOP drop ;
330:
331: compare c_addr1 u1 c_addr2 u2 -- n string
332: ""Compare the strings lexicographically. If they are equal, n is 0; if
333: the first string is smaller, n is -1; if the first string is larger, n
334: is 1. Currently this is based on the machine's character
335: comparison. In the future, this may change to considering the current
336: locale and its collation order.""
337: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
338: if (n==0)
339: n = u1-u2;
340: if (n<0)
341: n = -1;
342: else if (n>0)
343: n = 1;
344: :
345: rot 2dup - >r min swap -text dup
346: IF rdrop
347: ELSE drop r@ 0>
348: IF rdrop -1
349: ELSE r> 1 and
350: THEN
351: THEN ;
352:
353: -text c_addr1 u c_addr2 -- n new dash_text
354: n = memcmp(c_addr1, c_addr2, u);
355: if (n<0)
356: n = -1;
357: else if (n>0)
358: n = 1;
359: :
360: swap bounds
361: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
362: ELSE c@ I c@ - unloop THEN -text-flag ;
363: : -text-flag ( n -- -1/0/1 )
364: dup 0< IF drop -1 ELSE 0> IF 1 ELSE 0 THEN THEN ;
365:
366: capscomp c_addr1 u c_addr2 -- n new
367: Char c1, c2;
368: for (;; u--, c_addr1++, c_addr2++) {
369: if (u == 0) {
370: n = 0;
371: break;
372: }
373: c1 = toupper(*c_addr1);
374: c2 = toupper(*c_addr2);
375: if (c1 != c2) {
376: if (c1 < c2)
377: n = -1;
378: else
379: n = 1;
380: break;
381: }
382: }
383: :
384: swap bounds
385: ?DO dup c@ toupper I c@ toupper = WHILE 1+ LOOP drop 0
386: ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ;
387:
388: -trailing c_addr u1 -- c_addr u2 string dash_trailing
389: u2 = u1;
390: while (c_addr[u2-1] == ' ')
391: u2--;
392: :
393: BEGIN 1- 2dup + c@ bl = WHILE
394: dup 0= UNTIL ELSE 1+ THEN ;
395:
396: /string c_addr1 u1 n -- c_addr2 u2 string slash_string
397: c_addr2 = c_addr1+n;
398: u2 = u1-n;
399: :
400: tuck - >r + r> dup 0< IF - 0 THEN ;
401:
402: + n1 n2 -- n core plus
403: n = n1+n2;
404:
405: - n1 n2 -- n core minus
406: n = n1-n2;
407: :
408: negate + ;
409:
410: negate n1 -- n2 core
411: /* use minus as alias */
412: n2 = -n1;
413: :
414: invert 1+ ;
415:
416: 1+ n1 -- n2 core one_plus
417: n2 = n1+1;
418: :
419: 1 + ;
420:
421: 1- n1 -- n2 core one_minus
422: n2 = n1-1;
423: :
424: 1 - ;
425:
426: max n1 n2 -- n core
427: if (n1<n2)
428: n = n2;
429: else
430: n = n1;
431: :
432: 2dup < IF swap THEN drop ;
433:
434: min n1 n2 -- n core
435: if (n1<n2)
436: n = n1;
437: else
438: n = n2;
439: :
440: 2dup > IF swap THEN drop ;
441:
442: abs n1 -- n2 core
443: if (n1<0)
444: n2 = -n1;
445: else
446: n2 = n1;
447: :
448: dup 0< IF negate THEN ;
449:
450: * n1 n2 -- n core star
451: n = n1*n2;
452: :
453: um* drop ;
454:
455: / n1 n2 -- n core slash
456: n = n1/n2;
457: :
458: /mod nip ;
459:
460: mod n1 n2 -- n core
461: n = n1%n2;
462: :
463: /mod drop ;
464:
465: /mod n1 n2 -- n3 n4 core slash_mod
466: n4 = n1/n2;
467: n3 = n1%n2; /* !! is this correct? look into C standard! */
468: :
469: >r s>d r> fm/mod ;
470:
471: 2* n1 -- n2 core two_star
472: n2 = 2*n1;
473: :
474: dup + ;
475:
476: 2/ n1 -- n2 core two_slash
477: /* !! is this still correct? */
478: n2 = n1>>1;
479:
480: fm/mod d1 n1 -- n2 n3 core f_m_slash_mod
481: ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
482: /* assumes that the processor uses either floored or symmetric division */
483: n3 = d1/n1;
484: n2 = d1%n1;
485: /* note that this 1%-3>0 is optimized by the compiler */
486: if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
487: n3--;
488: n2+=n1;
489: }
490:
491: sm/rem d1 n1 -- n2 n3 core s_m_slash_rem
492: ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""
493: /* assumes that the processor uses either floored or symmetric division */
494: n3 = d1/n1;
495: n2 = d1%n1;
496: /* note that this 1%-3<0 is optimized by the compiler */
497: if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
498: n3++;
499: n2-=n1;
500: }
501: :
502: over >r dup >r abs -rot
503: dabs rot um/mod
504: r> 0< IF negate THEN
505: r> 0< IF swap negate swap THEN ;
506:
507: m* n1 n2 -- d core m_star
508: d = (DCell)n1 * (DCell)n2;
509: :
510: 2dup 0< and >r
511: 2dup swap 0< and >r
512: um* r> - r> - ;
513:
514: um* u1 u2 -- ud core u_m_star
515: /* use u* as alias */
516: ud = (UDCell)u1 * (UDCell)u2;
517:
518: um/mod ud u1 -- u2 u3 core u_m_slash_mod
519: u3 = ud/u1;
520: u2 = ud%u1;
521: :
522: dup IF 0 (um/mod) THEN nip ;
523: : (um/mod) ( ud ud--ud u)
524: 2dup >r >r dup 0<
525: IF 2drop 0
526: ELSE 2dup d+ (um/mod) 2* THEN
527: -rot r> r> 2over 2over du<
528: IF 2drop rot
529: ELSE dnegate d+ rot 1+ THEN ;
530:
531: m+ d1 n -- d2 double m_plus
532: d2 = d1+n;
533: :
534: s>d d+ ;
535:
536: d+ d1 d2 -- d double d_plus
537: d = d1+d2;
538: :
539: >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/
540: r> + >r + r> 0< r> r> + swap - ;
541:
542: d- d1 d2 -- d double d_minus
543: d = d1-d2;
544: :
545: dnegate d+ ;
546:
547: dnegate d1 -- d2 double
548: /* use dminus as alias */
549: d2 = -d1;
550: :
551: invert swap negate tuck 0= - ;
552:
553: dmax d1 d2 -- d double
554: if (d1<d2)
555: d = d2;
556: else
557: d = d1;
558: :
559: 2over 2over d> IF 2swap THEN 2drop ;
560:
561: dmin d1 d2 -- d double
562: if (d1<d2)
563: d = d1;
564: else
565: d = d2;
566: :
567: 2over 2over d< IF 2swap THEN 2drop ;
568:
569: dabs d1 -- d2 double
570: if (d1<0)
571: d2 = -d1;
572: else
573: d2 = d1;
574: :
575: dup 0< IF dnegate THEN ;
576:
577: d2* d1 -- d2 double d_two_star
578: d2 = 2*d1;
579: :
580: 2dup d+ ;
581:
582: d2/ d1 -- d2 double d_two_slash
583: /* !! is this still correct? */
584: d2 = d1>>1;
585: :
586: dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
587: r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ;
588:
589: d>s d -- n double d_to_s
590: /* make this an alias for drop? */
591: n = d;
592: :
593: drop ;
594:
595: and w1 w2 -- w core
596: w = w1&w2;
597:
598: or w1 w2 -- w core
599: w = w1|w2;
600:
601: xor w1 w2 -- w core
602: w = w1^w2;
603:
604: invert w1 -- w2 core
605: w2 = ~w1;
606: :
607: -1 xor ;
608:
609: rshift u1 n -- u2 core
610: u2 = u1>>n;
611:
612: lshift u1 n -- u2 core
613: u2 = u1<<n;
614:
615: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
616: define(comparisons,
617: $1= $2 -- f $6 $3equals
618: f = FLAG($4==$5);
619:
620: $1<> $2 -- f $7 $3different
621: /* use != as alias ? */
622: f = FLAG($4!=$5);
623:
624: $1< $2 -- f $8 $3less
625: f = FLAG($4<$5);
626:
627: $1> $2 -- f $9 $3greater
628: f = FLAG($4>$5);
629:
630: $1<= $2 -- f new $3less_or_equal
631: f = FLAG($4<=$5);
632:
633: $1>= $2 -- f new $3greater_or_equal
634: f = FLAG($4>=$5);
635:
636: )
637:
638: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
639: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
640: comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext)
641: comparisons(d, d1 d2, d_, d1, d2, double, new, double, new)
642: comparisons(d0, d, d_zero_, d, 0, double, new, double, new)
643: comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new)
644:
645: within u1 u2 u3 -- f core-ext
646: f = FLAG(u1-u2 < u3-u2);
647: :
648: over - >r - r> u< ;
649:
650: sp@ -- a_addr fig spat
651: a_addr = sp+1;
652:
653: sp! a_addr -- fig spstore
654: sp = a_addr;
655: /* works with and without TOS caching */
656:
657: rp@ -- a_addr fig rpat
658: a_addr = rp;
659:
660: rp! a_addr -- fig rpstore
661: rp = a_addr;
662:
663: fp@ -- f_addr new fp_fetch
664: f_addr = fp;
665:
666: fp! f_addr -- new fp_store
667: fp = f_addr;
668:
669: ;s -- fig semis
670: ip = (Xt *)(*rp++);
671: NEXT_P0;
672:
673: >r w -- core to_r
674: *--rp = w;
675:
676: r> -- w core r_from
677: w = *rp++;
678:
679: r@ -- w core r_fetch
680: /* use r as alias */
681: /* make r@ an alias for i */
682: w = *rp;
683:
684: rdrop -- gforth
685: rp++;
686:
687: i' -- w gforth i_tick
688: w=rp[1];
689:
690: 2>r w1 w2 -- core-ext two_to_r
691: *--rp = w1;
692: *--rp = w2;
693:
694: 2r> -- w1 w2 core-ext two_r_from
695: w2 = *rp++;
696: w1 = *rp++;
697:
698: 2r@ -- w1 w2 core-ext two_r_fetch
699: w2 = rp[0];
700: w1 = rp[1];
701:
702: 2rdrop -- gforth two_r_drop
703: rp+=2;
704:
705: over w1 w2 -- w1 w2 w1 core
706:
707: drop w -- core
708:
709: swap w1 w2 -- w2 w1 core
710:
711: dup w -- w w core
712:
713: rot w1 w2 w3 -- w2 w3 w1 core rote
714:
715: -rot w1 w2 w3 -- w3 w1 w2 gforth not_rote
716: :
717: rot rot ;
718:
719: nip w1 w2 -- w2 core-ext
720: :
721: swap drop ;
722:
723: tuck w1 w2 -- w2 w1 w2 core-ext
724: :
725: swap over ;
726:
727: ?dup w -- w core question_dupe
728: if (w!=0) {
729: IF_TOS(*sp-- = w;)
730: #ifndef USE_TOS
731: *--sp = w;
732: #endif
733: }
734: :
735: dup IF dup THEN ;
736:
737: pick u -- w core-ext
738: w = sp[u+1];
739: :
740: 1+ cells sp@ + @ ;
741:
742: 2drop w1 w2 -- core two_drop
743: :
744: drop drop ;
745:
746: 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe
747: :
748: over over ;
749:
750: 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over
751: :
752: 3 pick 3 pick ;
753:
754: 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap
755: :
756: >r -rot r> -rot ;
757:
758: 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double two_rote
759: :
760: >r >r 2swap r> r> 2swap ;
761:
762: 2nip w1 w2 w3 w4 -- w3 w4 gforth two_nip
763: :
764: 2swap 2drop ;
765:
766: 2tuck w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 gforth two_tuck
767: :
768: 2swap 2over ;
769:
770: \ toggle is high-level: 0.11/0.42%
771:
772: @ a_addr -- w core fetch
773: w = *a_addr;
774:
775: ! w a_addr -- core store
776: *a_addr = w;
777:
778: +! n a_addr -- core plus_store
779: *a_addr += n;
780:
781: c@ c_addr -- c core cfetch
782: c = *c_addr;
783:
784: c! c c_addr -- core cstore
785: *c_addr = c;
786:
787: 2! w1 w2 a_addr -- core two_store
788: a_addr[0] = w2;
789: a_addr[1] = w1;
790: :
791: tuck ! cell+ ! ;
792:
793: 2@ a_addr -- w1 w2 core two_fetch
794: w2 = a_addr[0];
795: w1 = a_addr[1];
796: :
797: dup cell+ @ swap @ ;
798:
799: d! d a_addr -- double d_store
800: /* !! alignment problems on some machines */
801: *(DCell *)a_addr = d;
802:
803: d@ a_addr -- d double d_fetch
804: d = *(DCell *)a_addr;
805:
806: cell+ a_addr1 -- a_addr2 core cell_plus
807: a_addr2 = a_addr1+1;
808: :
809: [ cell ] Literal + ;
810:
811: cells n1 -- n2 core
812: n2 = n1 * sizeof(Cell);
813: :
814: [ cell ]
815: [ 2/ dup ] [IF] 2* [THEN]
816: [ 2/ dup ] [IF] 2* [THEN]
817: [ 2/ dup ] [IF] 2* [THEN]
818: [ 2/ dup ] [IF] 2* [THEN]
819: [ drop ] ;
820:
821: char+ c_addr1 -- c_addr2 core care_plus
822: c_addr2 = c_addr1 + 1;
823: :
824: 1+ ;
825:
826: (chars) n1 -- n2 gforth paren_cares
827: n2 = n1 * sizeof(Char);
828: :
829: ;
830:
831: count c_addr1 -- c_addr2 u core
832: u = *c_addr1;
833: c_addr2 = c_addr1+1;
834: :
835: dup 1+ swap c@ ;
836:
837: (bye) n -- gforth paren_bye
838: return (Label *)n;
839:
840: system c_addr u -- n gforth
841: n=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
842:
843: getenv c_addr1 u1 -- c_addr2 u2 gforth
844: c_addr2 = getenv(cstr(c_addr1,u1,1));
845: u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
846:
847: popen c_addr u n -- wfileid own
848: static char* mode[2]={"r","w"}; /* !! should we use FAM here? */
849: wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]); /* ~ expansion of 1st arg? */
850:
851: pclose wfileid -- wior own
852: wior=pclose((FILE *)wfileid); /* !! what to do with the result */
853:
854: time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date
855: struct timeval time1;
856: struct timezone zone1;
857: struct tm *ltime;
858: gettimeofday(&time1,&zone1);
859: ltime=localtime((time_t *)&time1.tv_sec);
860: nyear =ltime->tm_year+1900;
861: nmonth=ltime->tm_mon+1;
862: nday =ltime->tm_mday;
863: nhour =ltime->tm_hour;
864: nmin =ltime->tm_min;
865: nsec =ltime->tm_sec;
866:
867: ms n -- facility-ext
868: struct timeval timeout;
869: timeout.tv_sec=n/1000;
870: timeout.tv_usec=1000*(n%1000);
871: (void)select(0,0,0,0,&timeout);
872:
873: allocate u -- a_addr wior memory
874: a_addr = (Cell *)malloc(u);
875: wior = IOR(a_addr==NULL);
876:
877: free a_addr -- wior memory
878: free(a_addr);
879: wior = 0;
880:
881: resize a_addr1 u -- a_addr2 wior memory
882: ""Change the size of the allocated area at @i{a_addr1} to @i{u}
883: address units, possibly moving the contents to a different
884: area. @i{a_addr2} is the address of the resulting area. If
885: @code{a_addr2} is 0, gforth's (but not the standard) @code{resize}
886: @code{allocate}s @i{u} address units.""
887: /* the following check is not necessary on most OSs, but it is needed
888: on SunOS 4.1.2. */
889: if (a_addr1==NULL)
890: a_addr2 = (Cell *)malloc(u);
891: else
892: a_addr2 = (Cell *)realloc(a_addr1, u);
893: wior = IOR(a_addr2==NULL); /* !! Define a return code */
894:
895: (f83find) c_addr u f83name1 -- f83name2 new paren_f83find
896: for (; f83name1 != NULL; f83name1 = f83name1->next)
897: if (F83NAME_COUNT(f83name1)==u &&
898: strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
899: break;
900: f83name2=f83name1;
901: :
902: BEGIN dup WHILE
903: >r dup r@ cell+ c@ $1F and =
904: IF 2dup r@ cell+ char+ capscomp 0=
905: IF 2drop r> EXIT THEN THEN
906: r> @
907: REPEAT nip nip ;
908:
909: (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind
910: F83Name *f83name1;
911: f83name2=NULL;
912: while(a_addr != NULL)
913: {
914: f83name1=(F83Name *)(a_addr[1]);
915: a_addr=(Cell *)(a_addr[0]);
916: if (F83NAME_COUNT(f83name1)==u &&
917: strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
918: {
919: f83name2=f83name1;
920: break;
921: }
922: }
923: :
924: BEGIN dup WHILE
925: 2@ >r >r dup r@ cell+ c@ $1F and =
926: IF 2dup r@ cell+ char+ capscomp 0=
927: IF 2drop r> rdrop EXIT THEN THEN
928: rdrop r>
929: REPEAT nip nip ;
930:
931: (hashkey) c_addr u1 -- u2 new paren_hashkey
932: u2=0;
933: while(u1--)
934: u2+=(Cell)toupper(*c_addr++);
935: :
936: 0 -rot bounds ?DO I c@ toupper + LOOP ;
937:
938: (hashkey1) c_addr u ubits -- ukey new paren_hashkey1
939: ""ukey is the hash key for the string c_addr u fitting in ubits bits""
940: /* this hash function rotates the key at every step by rot bits within
941: ubits bits and xors it with the character. This function does ok in
942: the chi-sqare-test. Rot should be <=7 (preferably <=5) for
943: ASCII strings (larger if ubits is large), and should share no
944: divisors with ubits.
945: */
946: 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];
947: Char *cp = c_addr;
948: for (ukey=0; cp<c_addr+u; cp++)
949: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
950: ^ toupper(*cp))
951: & ((1<<ubits)-1));
952: :
953: dup rot-values + c@ over 1 swap lshift 1- >r
954: tuck - 2swap r> 0 2swap bounds
955: ?DO dup 4 pick lshift swap 3 pick rshift or
956: I c@ toupper xor
957: over and LOOP
958: nip nip nip ;
959: Create rot-values
960: 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c,
961: 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c,
962: 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c,
963: 7 c, 5 c, 5 c,
964:
965: (parse-white) c_addr1 u1 -- c_addr2 u2 new paren_parse_white
966: /* use !isgraph instead of isspace? */
967: Char *endp = c_addr1+u1;
968: while (c_addr1<endp && isspace(*c_addr1))
969: c_addr1++;
970: if (c_addr1<endp) {
971: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
972: ;
973: u2 = c_addr1-c_addr2;
974: }
975: else {
976: c_addr2 = c_addr1;
977: u2 = 0;
978: }
979: :
980: BEGIN dup WHILE over c@ bl <= WHILE 1 /string
981: REPEAT THEN 2dup
982: BEGIN dup WHILE over c@ bl > WHILE 1 /string
983: REPEAT THEN nip - ;
984:
985: close-file wfileid -- wior file close_file
986: wior = IOR(fclose((FILE *)wfileid)==EOF);
987:
988: open-file c_addr u ntype -- w2 wior file open_file
989: w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
990: wior = IOR(w2 == 0);
991:
992: create-file c_addr u ntype -- w2 wior file create_file
993: Cell fd;
994: fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);
995: if (fd != -1) {
996: w2 = (Cell)fdopen(fd, fileattr[ntype]);
997: wior = IOR(w2 == 0);
998: } else {
999: w2 = 0;
1000: wior = IOR(1);
1001: }
1002:
1003: delete-file c_addr u -- wior file delete_file
1004: wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
1005:
1006: rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file
1007: char *s1=tilde_cstr(c_addr2, u2, 1);
1008: wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
1009:
1010: file-position wfileid -- ud wior file file_position
1011: /* !! use tell and lseek? */
1012: ud = ftell((FILE *)wfileid);
1013: wior = IOR(ud==-1);
1014:
1015: reposition-file ud wfileid -- wior file reposition_file
1016: wior = IOR(fseek((FILE *)wfileid, (long)ud, SEEK_SET)==-1);
1017:
1018: file-size wfileid -- ud wior file file_size
1019: struct stat buf;
1020: wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
1021: ud = buf.st_size;
1022:
1023: resize-file ud wfileid -- wior file resize_file
1024: wior = IOR(ftruncate(fileno((FILE *)wfileid), (Cell)ud)==-1);
1025:
1026: read-file c_addr u1 wfileid -- u2 wior file read_file
1027: /* !! fread does not guarantee enough */
1028: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1029: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1030: /* !! is the value of ferror errno-compatible? */
1031: if (wior)
1032: clearerr((FILE *)wfileid);
1033:
1034: read-line c_addr u1 wfileid -- u2 flag wior file read_line
1035: /*
1036: Cell c;
1037: flag=-1;
1038: for(u2=0; u2<u1; u2++)
1039: {
1040: *c_addr++ = (Char)(c = getc((FILE *)wfileid));
1041: if(c=='\n') break;
1042: if(c==EOF)
1043: {
1044: flag=FLAG(u2!=0);
1045: break;
1046: }
1047: }
1048: wior=FILEIO(ferror((FILE *)wfileid));
1049: */
1050: if ((flag=FLAG(!feof((FILE *)wfileid) &&
1051: fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
1052: wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */
1053: if (wior)
1054: clearerr((FILE *)wfileid);
1055: u2 = strlen(c_addr);
1056: u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
1057: }
1058: else {
1059: wior=0;
1060: u2=0;
1061: }
1062:
1063: write-file c_addr u1 wfileid -- wior file write_file
1064: /* !! fwrite does not guarantee enough */
1065: {
1066: Cell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1067: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1068: if (wior)
1069: clearerr((FILE *)wfileid);
1070: }
1071:
1072: flush-file wfileid -- wior file-ext flush_file
1073: wior = IOR(fflush((FILE *) wfileid)==EOF);
1074:
1075: file-status c_addr u -- ntype wior file-ext file_status
1076: char *filename=tilde_cstr(c_addr, u, 1);
1077: if (access (filename, F_OK) != 0) {
1078: ntype=0;
1079: wior=IOR(1);
1080: }
1081: else if (access (filename, R_OK | W_OK) == 0) {
1082: ntype=2; /* r/w */
1083: wior=0;
1084: }
1085: else if (access (filename, R_OK) == 0) {
1086: ntype=0; /* r/o */
1087: wior=0;
1088: }
1089: else if (access (filename, W_OK) == 0) {
1090: ntype=4; /* w/o */
1091: wior=0;
1092: }
1093: else {
1094: ntype=1; /* well, we cannot access the file, but better deliver a legal
1095: access mode (r/o bin), so we get a decent error later upon open. */
1096: wior=0;
1097: }
1098:
1099: comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
1100: comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
1101:
1102: d>f d -- r float d_to_f
1103: r = d;
1104:
1105: f>d r -- d float f_to_d
1106: /* !! basis 15 is not very specific */
1107: d = r;
1108:
1109: f! r f_addr -- float f_store
1110: *f_addr = r;
1111:
1112: f@ f_addr -- r float f_fetch
1113: r = *f_addr;
1114:
1115: df@ df_addr -- r float-ext d_f_fetch
1116: #ifdef IEEE_FP
1117: r = *df_addr;
1118: #else
1119: !! df@
1120: #endif
1121:
1122: df! r df_addr -- float-ext d_f_store
1123: #ifdef IEEE_FP
1124: *df_addr = r;
1125: #else
1126: !! df!
1127: #endif
1128:
1129: sf@ sf_addr -- r float-ext s_f_fetch
1130: #ifdef IEEE_FP
1131: r = *sf_addr;
1132: #else
1133: !! sf@
1134: #endif
1135:
1136: sf! r sf_addr -- float-ext s_f_store
1137: #ifdef IEEE_FP
1138: *sf_addr = r;
1139: #else
1140: !! sf!
1141: #endif
1142:
1143: f+ r1 r2 -- r3 float f_plus
1144: r3 = r1+r2;
1145:
1146: f- r1 r2 -- r3 float f_minus
1147: r3 = r1-r2;
1148:
1149: f* r1 r2 -- r3 float f_star
1150: r3 = r1*r2;
1151:
1152: f/ r1 r2 -- r3 float f_slash
1153: r3 = r1/r2;
1154:
1155: f** r1 r2 -- r3 float-ext f_star_star
1156: ""@i{r3} is @i{r1} raised to the @i{r2}th power""
1157: r3 = pow(r1,r2);
1158:
1159: fnegate r1 -- r2 float
1160: r2 = - r1;
1161:
1162: fdrop r -- float
1163:
1164: fdup r -- r r float
1165:
1166: fswap r1 r2 -- r2 r1 float
1167:
1168: fover r1 r2 -- r1 r2 r1 float
1169:
1170: frot r1 r2 r3 -- r2 r3 r1 float
1171:
1172: fnip r1 r2 -- r2 gforth
1173:
1174: ftuck r1 r2 -- r2 r1 r2 gforth
1175:
1176: float+ f_addr1 -- f_addr2 float float_plus
1177: f_addr2 = f_addr1+1;
1178:
1179: floats n1 -- n2 float
1180: n2 = n1*sizeof(Float);
1181:
1182: floor r1 -- r2 float
1183: ""round towards the next smaller integral value, i.e., round toward negative infinity""
1184: /* !! unclear wording */
1185: r2 = floor(r1);
1186:
1187: fround r1 -- r2 float
1188: ""round to the nearest integral value""
1189: /* !! unclear wording */
1190: #ifdef HAVE_RINT
1191: r2 = rint(r1);
1192: #else
1193: r2 = floor(r1+0.5);
1194: /* !! This is not quite true to the rounding rules given in the standard */
1195: #endif
1196:
1197: fmax r1 r2 -- r3 float
1198: if (r1<r2)
1199: r3 = r2;
1200: else
1201: r3 = r1;
1202:
1203: fmin r1 r2 -- r3 float
1204: if (r1<r2)
1205: r3 = r1;
1206: else
1207: r3 = r2;
1208:
1209: represent r c_addr u -- n f1 f2 float
1210: char *sig;
1211: Cell flag;
1212: Cell decpt;
1213: sig=ecvt(r, u, (int *)&decpt, (int *)&flag);
1214: n=(r==0 ? 1 : decpt);
1215: f1=FLAG(flag!=0);
1216: f2=FLAG(isdigit(sig[0])!=0);
1217: memmove(c_addr,sig,u);
1218:
1219: >float c_addr u -- flag float to_float
1220: /* real signature: c_addr u -- r t / f */
1221: Float r;
1222: char *number=cstr(c_addr, u, 1);
1223: char *endconv;
1224: while(isspace(number[--u]) && u>0);
1225: switch(number[u])
1226: {
1227: case 'd':
1228: case 'D':
1229: case 'e':
1230: case 'E': break;
1231: default : u++; break;
1232: }
1233: number[u]='\0';
1234: r=strtod(number,&endconv);
1235: if((flag=FLAG(!(Cell)*endconv)))
1236: {
1237: IF_FTOS(fp[0] = FTOS);
1238: fp += -1;
1239: FTOS = r;
1240: }
1241: else if(*endconv=='d' || *endconv=='D')
1242: {
1243: *endconv='E';
1244: r=strtod(number,&endconv);
1245: if((flag=FLAG(!(Cell)*endconv)))
1246: {
1247: IF_FTOS(fp[0] = FTOS);
1248: fp += -1;
1249: FTOS = r;
1250: }
1251: }
1252:
1253: fabs r1 -- r2 float-ext
1254: r2 = fabs(r1);
1255:
1256: facos r1 -- r2 float-ext
1257: r2 = acos(r1);
1258:
1259: fasin r1 -- r2 float-ext
1260: r2 = asin(r1);
1261:
1262: fatan r1 -- r2 float-ext
1263: r2 = atan(r1);
1264:
1265: fatan2 r1 r2 -- r3 float-ext
1266: ""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably
1267: intends this to be the inverse of @code{fsincos}. In gforth it is.""
1268: r3 = atan2(r1,r2);
1269:
1270: fcos r1 -- r2 float-ext
1271: r2 = cos(r1);
1272:
1273: fexp r1 -- r2 float-ext
1274: r2 = exp(r1);
1275:
1276: fexpm1 r1 -- r2 float-ext
1277: ""@i{r2}=@i{e}**@i{r1}@minus{}1""
1278: #ifdef HAVE_EXPM1
1279: extern double expm1(double);
1280: r2 = expm1(r1);
1281: #else
1282: r2 = exp(r1)-1.;
1283: #endif
1284:
1285: fln r1 -- r2 float-ext
1286: r2 = log(r1);
1287:
1288: flnp1 r1 -- r2 float-ext
1289: ""@i{r2}=ln(@i{r1}+1)""
1290: #ifdef HAVE_LOG1P
1291: extern double log1p(double);
1292: r2 = log1p(r1);
1293: #else
1294: r2 = log(r1+1.);
1295: #endif
1296:
1297: flog r1 -- r2 float-ext
1298: ""the decimal logarithm""
1299: r2 = log10(r1);
1300:
1301: falog r1 -- r2 float-ext
1302: ""@i{r2}=10**@i{r1}""
1303: extern double pow10(double);
1304: r2 = pow10(r1);
1305:
1306: fsin r1 -- r2 float-ext
1307: r2 = sin(r1);
1308:
1309: fsincos r1 -- r2 r3 float-ext
1310: ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
1311: r2 = sin(r1);
1312: r3 = cos(r1);
1313:
1314: fsqrt r1 -- r2 float-ext
1315: r2 = sqrt(r1);
1316:
1317: ftan r1 -- r2 float-ext
1318: r2 = tan(r1);
1319: :
1320: fsincos f/ ;
1321:
1322: fsinh r1 -- r2 float-ext
1323: r2 = sinh(r1);
1324: :
1325: fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
1326:
1327: fcosh r1 -- r2 float-ext
1328: r2 = cosh(r1);
1329: :
1330: fexp fdup 1/f f+ f2/ ;
1331:
1332: ftanh r1 -- r2 float-ext
1333: r2 = tanh(r1);
1334: :
1335: f2* fexpm1 fdup 2. d>f f+ f/ ;
1336:
1337: fasinh r1 -- r2 float-ext
1338: r2 = asinh(r1);
1339: :
1340: fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
1341:
1342: facosh r1 -- r2 float-ext
1343: r2 = acosh(r1);
1344: :
1345: fdup fdup f* 1. d>f f- fsqrt f+ fln ;
1346:
1347: fatanh r1 -- r2 float-ext
1348: r2 = atanh(r1);
1349: :
1350: fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/
1351: r> IF fnegate THEN ;
1352:
1353: \ The following words access machine/OS/installation-dependent ANSI
1354: \ figForth internals
1355: \ !! how about environmental queries DIRECT-THREADED,
1356: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
1357:
1358: >body xt -- a_addr core to_body
1359: a_addr = PFA(xt);
1360:
1361: >code-address xt -- c_addr new to_code_address
1362: ""c_addr is the code address of the word xt""
1363: /* !! This behaves installation-dependently for DOES-words */
1364: c_addr = CODE_ADDRESS(xt);
1365:
1366: >does-code xt -- a_addr new to_does_code
1367: ""If xt ist the execution token of a defining-word-defined word,
1368: a_addr is the start of the Forth code after the DOES>; Otherwise the
1369: behaviour is undefined""
1370: /* !! there is currently no way to determine whether a word is
1371: defining-word-defined */
1372: a_addr = (Cell *)DOES_CODE(xt);
1373:
1374: code-address! c_addr xt -- new code_address_store
1375: ""Creates a code field with code address c_addr at xt""
1376: MAKE_CF(xt, c_addr);
1377: CACHE_FLUSH(xt,PFA(0));
1378:
1379: does-code! a_addr xt -- new does_code_store
1380: ""creates a code field at xt for a defining-word-defined word; a_addr
1381: is the start of the Forth code after DOES>""
1382: MAKE_DOES_CF(xt, a_addr);
1383: CACHE_FLUSH(xt,PFA(0));
1384:
1385: does-handler! a_addr -- new does_handler_store
1386: ""creates a DOES>-handler at address a_addr. a_addr usually points
1387: just behind a DOES>.""
1388: MAKE_DOES_HANDLER(a_addr);
1389: CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
1390:
1391: /does-handler -- n new slash_does_handler
1392: ""the size of a does-handler (includes possible padding)""
1393: /* !! a constant or environmental query might be better */
1394: n = DOES_HANDLER_SIZE;
1395:
1396: flush-icache c_addr u -- gforth flush_icache
1397: ""Make sure that the instruction cache of the processor (if there is
1398: one) does not contain stale data at @var{c_addr} and @var{u} bytes
1399: afterwards. @code{END-CODE} performs a @code{flush-icache}
1400: automatically. Caveat: @code{flush-icache} might not work on your
1401: installation; this is usually the case if direct threading is not
1402: supported on your machine (take a look at your @file{machine.h}) and
1403: your machine has a separate instruction cache. In such cases,
1404: @code{flush-icache} does nothing instead of flushing the instruction
1405: cache.""
1406: FLUSH_ICACHE(c_addr,u);
1407:
1408: toupper c1 -- c2 new
1409: c2 = toupper(c1);
1410:
1411: \ local variable implementation primitives
1412: @local# -- w new fetch_local_number
1413: w = *(Cell *)(lp+(Cell)NEXT_INST);
1414: INC_IP(1);
1415:
1416: @local0 -- w new fetch_local_zero
1417: w = *(Cell *)(lp+0*sizeof(Cell));
1418:
1419: @local1 -- w new fetch_local_four
1420: w = *(Cell *)(lp+1*sizeof(Cell));
1421:
1422: @local2 -- w new fetch_local_eight
1423: w = *(Cell *)(lp+2*sizeof(Cell));
1424:
1425: @local3 -- w new fetch_local_twelve
1426: w = *(Cell *)(lp+3*sizeof(Cell));
1427:
1428: f@local# -- r new f_fetch_local_number
1429: r = *(Float *)(lp+(Cell)NEXT_INST);
1430: INC_IP(1);
1431:
1432: f@local0 -- r new f_fetch_local_zero
1433: r = *(Float *)(lp+0*sizeof(Float));
1434:
1435: f@local1 -- r new f_fetch_local_eight
1436: r = *(Float *)(lp+1*sizeof(Float));
1437:
1438: laddr# -- c_addr new laddr_number
1439: /* this can also be used to implement lp@ */
1440: c_addr = (Char *)(lp+(Cell)NEXT_INST);
1441: INC_IP(1);
1442:
1443: lp+!# -- new lp_plus_store_number
1444: ""used with negative immediate values it allocates memory on the
1445: local stack, a positive immediate argument drops memory from the local
1446: stack""
1447: lp += (Cell)NEXT_INST;
1448: INC_IP(1);
1449:
1450: lp- -- new minus_four_lp_plus_store
1451: lp += -sizeof(Cell);
1452:
1453: lp+ -- new eight_lp_plus_store
1454: lp += sizeof(Float);
1455:
1456: lp+2 -- new sixteen_lp_plus_store
1457: lp += 2*sizeof(Float);
1458:
1459: lp! c_addr -- new lp_store
1460: lp = (Address)c_addr;
1461:
1462: >l w -- new to_l
1463: lp -= sizeof(Cell);
1464: *(Cell *)lp = w;
1465:
1466: f>l r -- new f_to_l
1467: lp -= sizeof(Float);
1468: *(Float *)lp = r;
1469:
1470: up! a_addr -- new up_store
1471: up0=up=(char *)a_addr;
1472:
1473: call-c w -- new call_c
1474: ""Call the C function pointed to by @i{w}. The C function has to
1475: access the stack itself. The stack pointers are exported in the gloabl
1476: variables @code{SP} and @code{FP}.""
1477: /* This is a first attempt at support for calls to C. This may change in
1478: the future */
1479: IF_FTOS(fp[0]=FTOS);
1480: FP=fp;
1481: SP=sp;
1482: ((void (*)())w)();
1483: sp=SP;
1484: fp=FP;
1485: IF_TOS(TOS=sp[0]);
1486: IF_FTOS(FTOS=fp[0]);
1487:
1488: strerror n -- c_addr u new
1489: c_addr = strerror(n);
1490: u = strlen(c_addr);
1491:
1492: strsignal n -- c_addr u new
1493: c_addr = strsignal(n);
1494: u = strlen(c_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