File:
[gforth] /
gforth /
prim
Revision
1.29:
download - view:
text,
annotated -
select for diffs
Thu May 6 21:33:32 1999 UTC (24 years, 10 months ago) by
crook
Branches:
MAIN
CVS tags:
HEAD
Major re-write of manual sections concerning text interpreter and
defining words. Much fine-tuning of other sections. The manual is
``nearly finished'' -- at least, all the major pieces of work that
I envisaged for the first mods (which were only going to take a
couple of weeks...). The manual has grown from 127 pages to 192
which is good news in terms of content but bad news in terms of the
time it takes to print out on my HP550C DeskJet.
Other changes are just tweaks to glossary entries.
1: \ Gforth primitives
2:
3: \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21:
22: \ WARNING: This file is processed by m4. Make sure your identifiers
23: \ don't collide with m4's (e.g. by undefining them).
24: \
25: \
26: \
27: \ This file contains primitive specifications in the following format:
28: \
29: \ forth name stack effect category [pronunciation]
30: \ [""glossary entry""]
31: \ C code
32: \ [:
33: \ Forth code]
34: \
35: \ prims2x is pedantic about tabs vs. blanks. The fields of the first
36: \ line of a primitive are separated by tabs, the stack items in a
37: \ stack effect by blanks.
38: \
39: \ Both pronounciation and stack items (in the stack effect) must
40: \ conform to the C name syntax or the C compiler will complain.
41: \
42: \
43: \ These specifications are automatically translated into C-code for the
44: \ interpreter and into some other files. I hope that your C compiler has
45: \ decent optimization, otherwise the automatically generated code will
46: \ be somewhat slow. The Forth version of the code is included for manual
47: \ compilers, so they will need to compile only the important words.
48: \
49: \ Note that stack pointer adjustment is performed according to stack
50: \ effect by automatically generated code and NEXT is automatically
51: \ appended to the C code. Also, you can use the names in the stack
52: \ effect in the C code. Stack access is automatic. One exception: if
53: \ your code does not fall through, the results are not stored into the
54: \ stack. Use different names on both sides of the '--', if you change a
55: \ value (some stores to the stack are optimized away).
56: \
57: \
58: \
59: \ The stack variables have the following types:
60: \
61: \ name matches type
62: \ f.* Bool
63: \ c.* Char
64: \ [nw].* Cell
65: \ u.* UCell
66: \ d.* DCell
67: \ ud.* UDCell
68: \ r.* Float
69: \ a_.* Cell *
70: \ c_.* Char *
71: \ f_.* Float *
72: \ df_.* DFloat *
73: \ sf_.* SFloat *
74: \ xt.* XT
75: \ wid.* WID
76: \ f83name.* F83Name *
77: \
78: \
79: \
80: \ In addition the following names can be used:
81: \ ip the instruction pointer
82: \ sp the data stack pointer
83: \ rp the parameter stack pointer
84: \ lp the locals stack pointer
85: \ NEXT executes NEXT
86: \ cfa
87: \ NEXT1 executes NEXT1
88: \ FLAG(x) makes a Forth flag from a C flag
89: \
90: \
91: \
92: \ Percentages in comments are from Koopmans book: average/maximum use
93: \ (taken from four, not very representative benchmarks)
94: \
95: \
96: \
97: \ To do:
98: \
99: \ throw execute, cfa and NEXT1 out?
100: \ macroize *ip, ip++, *ip++ (pipelining)?
101:
102: \ these m4 macros would collide with identifiers
103: undefine(`index')
104: undefine(`shift')
105:
106: noop -- gforth
107: ;
108: :
109: ;
110:
111: lit -- w gforth
112: w = (Cell)NEXT_INST;
113: INC_IP(1);
114: :
115: r> dup @ swap cell+ >r ;
116:
117: execute xt -- core
118: ""Perform the semantics represented by the execution token, @i{xt}.""
119: ip=IP;
120: IF_TOS(TOS = sp[0]);
121: EXEC(xt);
122:
123: perform a_addr -- gforth
124: ""Equivalent to @code{@ execute}.""
125: /* and pfe */
126: ip=IP;
127: IF_TOS(TOS = sp[0]);
128: EXEC(*(Xt *)a_addr);
129: :
130: @ execute ;
131:
132: \+glocals
133:
134: branch-lp+!# -- gforth branch_lp_plus_store_number
135: /* this will probably not be used */
136: branch_adjust_lp:
137: lp += (Cell)(IP[1]);
138: goto branch;
139:
140: \+
141:
142: branch -- gforth
143: branch:
144: SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
145: :
146: r> dup @ + >r ;
147:
148: \ condbranch(forthname,restline,code,forthcode)
149: \ this is non-syntactical: code must open a brace that is closed by the macro
150: define(condbranch,
151: $1 $2
152: $3 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
153: NEXT;
154: }
155: else
156: INC_IP(1);
157: $4
158:
159: \+glocals
160:
161: $1-lp+!# $2_lp_plus_store_number
162: $3 goto branch_adjust_lp;
163: }
164: else
165: INC_IP(2);
166:
167: \+
168: )
169:
170: condbranch(?branch,f -- f83 question_branch,
171: if (f==0) {
172: IF_TOS(TOS = sp[0]);
173: ,:
174: 0= dup \ !f !f
175: r> dup @ \ !f !f IP branchoffset
176: rot and + \ !f IP|IP+branchoffset
177: swap 0= cell and + \ IP''
178: >r ;)
179:
180: \ we don't need an lp_plus_store version of the ?dup-stuff, because it
181: \ is only used in if's (yet)
182:
183: \+xconds
184:
185: ?dup-?branch f -- f new question_dupe_question_branch
186: ""The run-time procedure compiled by @code{?DUP-IF}.""
187: if (f==0) {
188: sp++;
189: IF_TOS(TOS = sp[0]);
190: SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
191: NEXT;
192: }
193: else
194: INC_IP(1);
195:
196: ?dup-0=-?branch f -- new question_dupe_zero_equals_question_branch
197: ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
198: /* the approach taken here of declaring the word as having the stack
199: effect ( f -- ) and correcting for it in the branch-taken case costs a
200: few cycles in that case, but is easy to convert to a CONDBRANCH
201: invocation */
202: if (f!=0) {
203: sp--;
204: SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
205: NEXT;
206: }
207: else
208: INC_IP(1);
209:
210: \+
211:
212: condbranch((next),-- cmFORTH paren_next,
213: if ((*rp)--) {
214: ,:
215: r> r> dup 1- >r
216: IF dup @ + >r ELSE cell+ >r THEN ;)
217:
218: condbranch((loop),-- gforth paren_loop,
219: Cell index = *rp+1;
220: Cell limit = rp[1];
221: if (index != limit) {
222: *rp = index;
223: ,:
224: r> r> 1+ r> 2dup =
225: IF >r 1- >r cell+ >r
226: ELSE >r >r dup @ + >r THEN ;)
227:
228: condbranch((+loop),n -- gforth paren_plus_loop,
229: /* !! check this thoroughly */
230: Cell index = *rp;
231: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
232: /* dependent upon two's complement arithmetic */
233: Cell olddiff = index-rp[1];
234: if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
235: || (olddiff^n)>=0 /* it is a wrap-around effect */) {
236: #ifdef i386
237: *rp += n;
238: #else
239: *rp = index + n;
240: #endif
241: IF_TOS(TOS = sp[0]);
242: ,:
243: r> swap
244: r> r> 2dup - >r
245: 2 pick r@ + r@ xor 0< 0=
246: 3 pick r> xor 0< 0= or
247: IF >r + >r dup @ + >r
248: ELSE >r >r drop cell+ >r THEN ;)
249:
250: \+xconds
251:
252: condbranch((-loop),u -- gforth paren_minus_loop,
253: /* !! check this thoroughly */
254: Cell index = *rp;
255: UCell olddiff = index-rp[1];
256: if (olddiff>u) {
257: #ifdef i386
258: *rp -= u;
259: #else
260: *rp = index - u;
261: #endif
262: IF_TOS(TOS = sp[0]);
263: ,)
264:
265: condbranch((s+loop),n -- gforth paren_symmetric_plus_loop,
266: ""The run-time procedure compiled by S+LOOP. It loops until the index
267: crosses the boundary between limit and limit-sign(n). I.e. a symmetric
268: version of (+LOOP).""
269: /* !! check this thoroughly */
270: Cell index = *rp;
271: Cell diff = index-rp[1];
272: Cell newdiff = diff+n;
273: if (n<0) {
274: diff = -diff;
275: newdiff = -newdiff;
276: }
277: if (diff>=0 || newdiff<0) {
278: #ifdef i386
279: *rp += n;
280: #else
281: *rp = index + n;
282: #endif
283: IF_TOS(TOS = sp[0]);
284: ,)
285:
286: \+
287:
288: unloop -- core
289: rp += 2;
290: :
291: r> rdrop rdrop >r ;
292:
293: (for) ncount -- cmFORTH paren_for
294: /* or (for) = >r -- collides with unloop! */
295: *--rp = 0;
296: *--rp = ncount;
297: :
298: r> swap 0 >r >r >r ;
299:
300: (do) nlimit nstart -- gforth paren_do
301: /* or do it in high-level? 0.09/0.23% */
302: *--rp = nlimit;
303: *--rp = nstart;
304: :
305: r> swap rot >r >r >r ;
306:
307: (?do) nlimit nstart -- gforth paren_question_do
308: *--rp = nlimit;
309: *--rp = nstart;
310: if (nstart == nlimit) {
311: IF_TOS(TOS = sp[0]);
312: goto branch;
313: }
314: else {
315: INC_IP(1);
316: }
317: :
318: 2dup =
319: IF r> swap rot >r >r
320: dup @ + >r
321: ELSE r> swap rot >r >r
322: cell+ >r
323: THEN ; \ --> CORE-EXT
324:
325: \+xconds
326:
327: (+do) nlimit nstart -- gforth paren_plus_do
328: *--rp = nlimit;
329: *--rp = nstart;
330: if (nstart >= nlimit) {
331: IF_TOS(TOS = sp[0]);
332: goto branch;
333: }
334: else {
335: INC_IP(1);
336: }
337: :
338: swap 2dup
339: r> swap >r swap >r
340: >=
341: IF
342: dup @ +
343: ELSE
344: cell+
345: THEN >r ;
346:
347: (u+do) ulimit ustart -- gforth paren_u_plus_do
348: *--rp = ulimit;
349: *--rp = ustart;
350: if (ustart >= ulimit) {
351: IF_TOS(TOS = sp[0]);
352: goto branch;
353: }
354: else {
355: INC_IP(1);
356: }
357: :
358: swap 2dup
359: r> swap >r swap >r
360: u>=
361: IF
362: dup @ +
363: ELSE
364: cell+
365: THEN >r ;
366:
367: (-do) nlimit nstart -- gforth paren_minus_do
368: *--rp = nlimit;
369: *--rp = nstart;
370: if (nstart <= nlimit) {
371: IF_TOS(TOS = sp[0]);
372: goto branch;
373: }
374: else {
375: INC_IP(1);
376: }
377: :
378: swap 2dup
379: r> swap >r swap >r
380: <=
381: IF
382: dup @ +
383: ELSE
384: cell+
385: THEN >r ;
386:
387: (u-do) ulimit ustart -- gforth paren_u_minus_do
388: *--rp = ulimit;
389: *--rp = ustart;
390: if (ustart <= ulimit) {
391: IF_TOS(TOS = sp[0]);
392: goto branch;
393: }
394: else {
395: INC_IP(1);
396: }
397: :
398: swap 2dup
399: r> swap >r swap >r
400: u<=
401: IF
402: dup @ +
403: ELSE
404: cell+
405: THEN >r ;
406:
407: \+
408:
409: \ don't make any assumptions where the return stack is!!
410: \ implement this in machine code if it should run quickly!
411:
412: i -- n core
413: n = *rp;
414: :
415: \ rp@ cell+ @ ;
416: r> r> tuck >r >r ;
417:
418: i' -- w gforth i_tick
419: ""loop end value""
420: w = rp[1];
421: :
422: \ rp@ cell+ cell+ @ ;
423: r> r> r> dup itmp ! >r >r >r itmp @ ;
424: variable itmp
425:
426: j -- n core
427: n = rp[2];
428: :
429: \ rp@ cell+ cell+ cell+ @ ;
430: r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
431: [IFUNDEF] itmp variable itmp [THEN]
432:
433: k -- n gforth
434: n = rp[4];
435: :
436: \ rp@ [ 5 cells ] Literal + @ ;
437: r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
438: [IFUNDEF] itmp variable itmp [THEN]
439:
440: \ digit is high-level: 0/0%
441:
442: move c_from c_to ucount -- core
443: "" If @i{ucount}>0, copy the contents of @i{ucount} address units
444: at @i{c-from} to @i{c-to}. @code{move} chooses its copy direction
445: to avoid problems when @i{c-from}, @i{c-to} overlap.""
446: memmove(c_to,c_from,ucount);
447: /* make an Ifdef for bsd and others? */
448: :
449: >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
450:
451: cmove c_from c_to u -- string
452: "" If @i{u}>0, copy the contents of @i{ucount} characters from
453: data space at @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
454: from low address to high address.""
455: while (u-- > 0)
456: *c_to++ = *c_from++;
457: :
458: bounds ?DO dup c@ I c! 1+ LOOP drop ;
459:
460: cmove> c_from c_to u -- string c_move_up
461: "" If @i{u}>0, copy the contents of @i{ucount} characters from
462: data space at @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
463: from high address to low address.""
464: while (u-- > 0)
465: c_to[u] = c_from[u];
466: :
467: dup 0= IF drop 2drop exit THEN
468: rot over + -rot bounds swap 1-
469: DO 1- dup c@ I c! -1 +LOOP drop ;
470:
471: fill c_addr u c -- core
472: "" If @i{u}>0, store character @i{c} in each of @i{u} consecutive
473: @code{char} addresses in memory, starting at address @i{c-addr}.""
474: memset(c_addr,c,u);
475: :
476: -rot bounds
477: ?DO dup I c! LOOP drop ;
478:
479: compare c_addr1 u1 c_addr2 u2 -- n string
480: ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
481: the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}
482: is 1. Currently this is based on the machine's character
483: comparison. In the future, this may change to consider the current
484: locale and its collation order.""
485: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
486: if (n==0)
487: n = u1-u2;
488: if (n<0)
489: n = -1;
490: else if (n>0)
491: n = 1;
492: :
493: rot 2dup - >r min swap -text dup
494: IF rdrop
495: ELSE drop r@ 0>
496: IF rdrop -1
497: ELSE r> 1 and
498: THEN
499: THEN ;
500:
501: -text c_addr1 u c_addr2 -- n new dash_text
502: n = memcmp(c_addr1, c_addr2, u);
503: if (n<0)
504: n = -1;
505: else if (n>0)
506: n = 1;
507: :
508: swap bounds
509: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
510: ELSE c@ I c@ - unloop THEN -text-flag ;
511: : -text-flag ( n -- -1/0/1 )
512: dup 0< IF drop -1 ELSE 0> 1 and THEN ;
513:
514: toupper c1 -- c2 gforth
515: ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
516: is the equivalent upper-case character. All other characters are unchanged.""
517: c2 = toupper(c1);
518: :
519: dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ;
520:
521: capscomp c_addr1 u c_addr2 -- n new
522: n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
523: if (n<0)
524: n = -1;
525: else if (n>0)
526: n = 1;
527: :
528: swap bounds
529: ?DO dup c@ I c@ <>
530: IF dup c@ toupper I c@ toupper =
531: ELSE true THEN WHILE 1+ LOOP drop 0
532: ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ;
533:
534: -trailing c_addr u1 -- c_addr u2 string dash_trailing
535: ""Adjust the string specified by @i{c-addr, u1} to remove all trailing
536: spaces. @i{u2} is the length of the modified string.""
537: u2 = u1;
538: while (u2>0 && c_addr[u2-1] == ' ')
539: u2--;
540: :
541: BEGIN 1- 2dup + c@ bl = WHILE
542: dup 0= UNTIL ELSE 1+ THEN ;
543:
544: /string c_addr1 u1 n -- c_addr2 u2 string slash_string
545: ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
546: characters from the start of the string.""
547: c_addr2 = c_addr1+n;
548: u2 = u1-n;
549: :
550: tuck - >r + r> dup 0< IF - 0 THEN ;
551:
552: + n1 n2 -- n core plus
553: n = n1+n2;
554:
555: \ PFE-0.9.14 has it differently, but the next release will have it as follows
556: under+ n1 n2 n3 -- n n2 gforth under_plus
557: ""add @i{n3} to @i{n1} (giving @i{n})""
558: n = n1+n3;
559: :
560: rot + swap ;
561:
562: - n1 n2 -- n core minus
563: n = n1-n2;
564: :
565: negate + ;
566:
567: negate n1 -- n2 core
568: /* use minus as alias */
569: n2 = -n1;
570: :
571: invert 1+ ;
572:
573: 1+ n1 -- n2 core one_plus
574: n2 = n1+1;
575: :
576: 1 + ;
577:
578: 1- n1 -- n2 core one_minus
579: n2 = n1-1;
580: :
581: 1 - ;
582:
583: max n1 n2 -- n core
584: if (n1<n2)
585: n = n2;
586: else
587: n = n1;
588: :
589: 2dup < IF swap THEN drop ;
590:
591: min n1 n2 -- n core
592: if (n1<n2)
593: n = n1;
594: else
595: n = n2;
596: :
597: 2dup > IF swap THEN drop ;
598:
599: abs n1 -- n2 core
600: if (n1<0)
601: n2 = -n1;
602: else
603: n2 = n1;
604: :
605: dup 0< IF negate THEN ;
606:
607: * n1 n2 -- n core star
608: n = n1*n2;
609: :
610: um* drop ;
611:
612: / n1 n2 -- n core slash
613: n = n1/n2;
614: :
615: /mod nip ;
616:
617: mod n1 n2 -- n core
618: n = n1%n2;
619: :
620: /mod drop ;
621:
622: /mod n1 n2 -- n3 n4 core slash_mod
623: n4 = n1/n2;
624: n3 = n1%n2; /* !! is this correct? look into C standard! */
625: :
626: >r s>d r> fm/mod ;
627:
628: 2* n1 -- n2 core two_star
629: n2 = 2*n1;
630: :
631: dup + ;
632:
633: 2/ n1 -- n2 core two_slash
634: /* !! is this still correct? */
635: n2 = n1>>1;
636: :
637: dup MINI and IF 1 ELSE 0 THEN
638: [ bits/byte cell * 1- ] literal
639: 0 DO 2* swap dup 2* >r MINI and
640: IF 1 ELSE 0 THEN or r> swap
641: LOOP nip ;
642:
643: fm/mod d1 n1 -- n2 n3 core f_m_slash_mod
644: ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
645: #ifdef BUGGY_LONG_LONG
646: DCell r = fmdiv(d1,n1);
647: n2=r.hi;
648: n3=r.lo;
649: #else
650: /* assumes that the processor uses either floored or symmetric division */
651: n3 = d1/n1;
652: n2 = d1%n1;
653: /* note that this 1%-3>0 is optimized by the compiler */
654: if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
655: n3--;
656: n2+=n1;
657: }
658: #endif
659: :
660: dup >r dup 0< IF negate >r dnegate r> THEN
661: over 0< IF tuck + swap THEN
662: um/mod
663: r> 0< IF swap negate swap THEN ;
664:
665: sm/rem d1 n1 -- n2 n3 core s_m_slash_rem
666: ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
667: #ifdef BUGGY_LONG_LONG
668: DCell r = smdiv(d1,n1);
669: n2=r.hi;
670: n3=r.lo;
671: #else
672: /* assumes that the processor uses either floored or symmetric division */
673: n3 = d1/n1;
674: n2 = d1%n1;
675: /* note that this 1%-3<0 is optimized by the compiler */
676: if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
677: n3++;
678: n2-=n1;
679: }
680: #endif
681: :
682: over >r dup >r abs -rot
683: dabs rot um/mod
684: r> r@ xor 0< IF negate THEN
685: r> 0< IF swap negate swap THEN ;
686:
687: m* n1 n2 -- d core m_star
688: #ifdef BUGGY_LONG_LONG
689: d = mmul(n1,n2);
690: #else
691: d = (DCell)n1 * (DCell)n2;
692: #endif
693: :
694: 2dup 0< and >r
695: 2dup swap 0< and >r
696: um* r> - r> - ;
697:
698: um* u1 u2 -- ud core u_m_star
699: /* use u* as alias */
700: #ifdef BUGGY_LONG_LONG
701: ud = ummul(u1,u2);
702: #else
703: ud = (UDCell)u1 * (UDCell)u2;
704: #endif
705: :
706: >r >r 0 0 r> r> [ 8 cells ] literal 0
707: DO
708: over >r dup >r 0< and d2*+ drop
709: r> 2* r> swap
710: LOOP 2drop ;
711: : d2*+ ( ud n -- ud+n c )
712: over MINI
713: and >r >r 2dup d+ swap r> + swap r> ;
714:
715: um/mod ud u1 -- u2 u3 core u_m_slash_mod
716: #ifdef BUGGY_LONG_LONG
717: UDCell r = umdiv(ud,u1);
718: u2=r.hi;
719: u3=r.lo;
720: #else
721: u3 = ud/u1;
722: u2 = ud%u1;
723: #endif
724: :
725: 0 swap [ 8 cells 1 + ] literal 0
726: ?DO /modstep
727: LOOP drop swap 1 rshift or swap ;
728: : /modstep ( ud c R: u -- ud-?u c R: u )
729: >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ;
730: : d2*+ ( ud n -- ud+n c )
731: over MINI
732: and >r >r 2dup d+ swap r> + swap r> ;
733:
734: m+ d1 n -- d2 double m_plus
735: #ifdef BUGGY_LONG_LONG
736: d2.lo = d1.lo+n;
737: d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);
738: #else
739: d2 = d1+n;
740: #endif
741: :
742: s>d d+ ;
743:
744: d+ d1 d2 -- d double d_plus
745: #ifdef BUGGY_LONG_LONG
746: d.lo = d1.lo+d2.lo;
747: d.hi = d1.hi + d2.hi + (d.lo<d1.lo);
748: #else
749: d = d1+d2;
750: #endif
751: :
752: rot + >r tuck + swap over u> r> swap - ;
753:
754: d- d1 d2 -- d double d_minus
755: #ifdef BUGGY_LONG_LONG
756: d.lo = d1.lo - d2.lo;
757: d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);
758: #else
759: d = d1-d2;
760: #endif
761: :
762: dnegate d+ ;
763:
764: dnegate d1 -- d2 double
765: /* use dminus as alias */
766: #ifdef BUGGY_LONG_LONG
767: d2 = dnegate(d1);
768: #else
769: d2 = -d1;
770: #endif
771: :
772: invert swap negate tuck 0= - ;
773:
774: d2* d1 -- d2 double d_two_star
775: #ifdef BUGGY_LONG_LONG
776: d2.lo = d1.lo<<1;
777: d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
778: #else
779: d2 = 2*d1;
780: #endif
781: :
782: 2dup d+ ;
783:
784: d2/ d1 -- d2 double d_two_slash
785: #ifdef BUGGY_LONG_LONG
786: d2.hi = d1.hi>>1;
787: d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
788: #else
789: d2 = d1>>1;
790: #endif
791: :
792: dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
793: r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ;
794:
795: and w1 w2 -- w core
796: w = w1&w2;
797:
798: or w1 w2 -- w core
799: w = w1|w2;
800: :
801: invert swap invert and invert ;
802:
803: xor w1 w2 -- w core
804: w = w1^w2;
805:
806: invert w1 -- w2 core
807: w2 = ~w1;
808: :
809: MAXU xor ;
810:
811: rshift u1 n -- u2 core
812: u2 = u1>>n;
813: :
814: 0 ?DO 2/ MAXI and LOOP ;
815:
816: lshift u1 n -- u2 core
817: u2 = u1<<n;
818: :
819: 0 ?DO 2* LOOP ;
820:
821: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
822: define(comparisons,
823: $1= $2 -- f $6 $3equals
824: f = FLAG($4==$5);
825: :
826: [ char $1x char 0 = [IF]
827: ] IF false ELSE true THEN [
828: [ELSE]
829: ] xor 0= [
830: [THEN] ] ;
831:
832: $1<> $2 -- f $7 $3different
833: f = FLAG($4!=$5);
834: :
835: [ char $1x char 0 = [IF]
836: ] IF true ELSE false THEN [
837: [ELSE]
838: ] xor 0<> [
839: [THEN] ] ;
840:
841: $1< $2 -- f $8 $3less
842: f = FLAG($4<$5);
843: :
844: [ char $1x char 0 = [IF]
845: ] MINI and 0<> [
846: [ELSE] char $1x char u = [IF]
847: ] 2dup xor 0< IF nip ELSE - THEN 0< [
848: [ELSE]
849: ] MINI xor >r MINI xor r> u< [
850: [THEN]
851: [THEN] ] ;
852:
853: $1> $2 -- f $9 $3greater
854: f = FLAG($4>$5);
855: :
856: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
857: $1< ;
858:
859: $1<= $2 -- f gforth $3less_or_equal
860: f = FLAG($4<=$5);
861: :
862: $1> 0= ;
863:
864: $1>= $2 -- f gforth $3greater_or_equal
865: f = FLAG($4>=$5);
866: :
867: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
868: $1<= ;
869:
870: )
871:
872: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
873: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
874: comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)
875:
876: \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
877: define(dcomparisons,
878: $1= $2 -- f $6 $3equals
879: #ifdef BUGGY_LONG_LONG
880: f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
881: #else
882: f = FLAG($4==$5);
883: #endif
884:
885: $1<> $2 -- f $7 $3different
886: #ifdef BUGGY_LONG_LONG
887: f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
888: #else
889: f = FLAG($4!=$5);
890: #endif
891:
892: $1< $2 -- f $8 $3less
893: #ifdef BUGGY_LONG_LONG
894: f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
895: #else
896: f = FLAG($4<$5);
897: #endif
898:
899: $1> $2 -- f $9 $3greater
900: #ifdef BUGGY_LONG_LONG
901: f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
902: #else
903: f = FLAG($4>$5);
904: #endif
905:
906: $1<= $2 -- f gforth $3less_or_equal
907: #ifdef BUGGY_LONG_LONG
908: f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);
909: #else
910: f = FLAG($4<=$5);
911: #endif
912:
913: $1>= $2 -- f gforth $3greater_or_equal
914: #ifdef BUGGY_LONG_LONG
915: f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
916: #else
917: f = FLAG($4>=$5);
918: #endif
919:
920: )
921:
922: \+dcomps
923:
924: dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
925: dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
926: dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
927:
928: \+
929:
930: within u1 u2 u3 -- f core-ext
931: f = FLAG(u1-u2 < u3-u2);
932: :
933: over - >r - r> u< ;
934:
935: sp@ -- a_addr gforth sp_fetch
936: a_addr = sp+1;
937:
938: sp! a_addr -- gforth sp_store
939: sp = a_addr;
940: /* works with and without TOS caching */
941:
942: rp@ -- a_addr gforth rp_fetch
943: a_addr = rp;
944:
945: rp! a_addr -- gforth rp_store
946: rp = a_addr;
947:
948: \+floating
949:
950: fp@ -- f_addr gforth fp_fetch
951: f_addr = fp;
952:
953: fp! f_addr -- gforth fp_store
954: fp = f_addr;
955:
956: \+
957:
958: ;s -- gforth semis
959: ""The primitive compiled by @code{EXIT}.""
960: SET_IP((Xt *)(*rp++));
961:
962: >r w -- core to_r
963: *--rp = w;
964: :
965: (>r) ;
966: : (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ;
967:
968: r> -- w core r_from
969: w = *rp++;
970: :
971: rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
972: Create (rdrop) ' ;s A,
973:
974: rdrop -- gforth
975: rp++;
976: :
977: r> r> drop >r ;
978:
979: 2>r w1 w2 -- core-ext two_to_r
980: *--rp = w1;
981: *--rp = w2;
982: :
983: swap r> swap >r swap >r >r ;
984:
985: 2r> -- w1 w2 core-ext two_r_from
986: w2 = *rp++;
987: w1 = *rp++;
988: :
989: r> r> swap r> swap >r swap ;
990:
991: 2r@ -- w1 w2 core-ext two_r_fetch
992: w2 = rp[0];
993: w1 = rp[1];
994: :
995: i' j ;
996:
997: 2rdrop -- gforth two_r_drop
998: rp+=2;
999: :
1000: r> r> drop r> drop >r ;
1001:
1002: over w1 w2 -- w1 w2 w1 core
1003: :
1004: sp@ cell+ @ ;
1005:
1006: drop w -- core
1007: :
1008: IF THEN ;
1009:
1010: swap w1 w2 -- w2 w1 core
1011: :
1012: >r (swap) ! r> (swap) @ ;
1013: Variable (swap)
1014:
1015: dup w -- w w core
1016: :
1017: sp@ @ ;
1018:
1019: rot w1 w2 w3 -- w2 w3 w1 core rote
1020: :
1021: [ defined? (swap) [IF] ]
1022: (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
1023: Variable (rot)
1024: [ELSE] ]
1025: >r swap r> swap ;
1026: [THEN]
1027:
1028: -rot w1 w2 w3 -- w3 w1 w2 gforth not_rote
1029: :
1030: rot rot ;
1031:
1032: nip w1 w2 -- w2 core-ext
1033: :
1034: swap drop ;
1035:
1036: tuck w1 w2 -- w2 w1 w2 core-ext
1037: :
1038: swap over ;
1039:
1040: ?dup w -- w core question_dupe
1041: if (w!=0) {
1042: IF_TOS(*sp-- = w;)
1043: #ifndef USE_TOS
1044: *--sp = w;
1045: #endif
1046: }
1047: :
1048: dup IF dup THEN ;
1049:
1050: pick u -- w core-ext
1051: w = sp[u+1];
1052: :
1053: 1+ cells sp@ + @ ;
1054:
1055: 2drop w1 w2 -- core two_drop
1056: :
1057: drop drop ;
1058:
1059: 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe
1060: :
1061: over over ;
1062:
1063: 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over
1064: :
1065: 3 pick 3 pick ;
1066:
1067: 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap
1068: :
1069: rot >r rot r> ;
1070:
1071: 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double-ext two_rote
1072: :
1073: >r >r 2swap r> r> 2swap ;
1074:
1075: 2nip w1 w2 w3 w4 -- w3 w4 gforth two_nip
1076: :
1077: 2swap 2drop ;
1078:
1079: 2tuck w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 gforth two_tuck
1080: :
1081: 2swap 2over ;
1082:
1083: \ toggle is high-level: 0.11/0.42%
1084:
1085: @ a_addr -- w core fetch
1086: "" Read from the cell at address @i{a-addr}, and return its contents, @i{w}.""
1087: w = *a_addr;
1088:
1089: ! w a_addr -- core store
1090: "" Write the value @i{w} to the cell at address @i{a-addr}.""
1091: *a_addr = w;
1092:
1093: +! n a_addr -- core plus_store
1094: "" Add @i{n} to the value stored in the cell at address @i{a-addr}.""
1095: *a_addr += n;
1096: :
1097: tuck @ + swap ! ;
1098:
1099: c@ c_addr -- c core c_fetch
1100: "" Read from the char at address @i{c-addr}, and return its contents, @i{c}.""
1101: c = *c_addr;
1102: :
1103: [ bigendian [IF] ]
1104: [ cell>bit 4 = [IF] ]
1105: dup [ 0 cell - ] Literal and @ swap 1 and
1106: IF $FF and ELSE 8>> THEN ;
1107: [ [ELSE] ]
1108: dup [ cell 1- ] literal and
1109: tuck - @ swap [ cell 1- ] literal xor
1110: 0 ?DO 8>> LOOP $FF and
1111: [ [THEN] ]
1112: [ [ELSE] ]
1113: [ cell>bit 4 = [IF] ]
1114: dup [ 0 cell - ] Literal and @ swap 1 and
1115: IF 8>> ELSE $FF and THEN
1116: [ [ELSE] ]
1117: dup [ cell 1- ] literal and
1118: tuck - @ swap
1119: 0 ?DO 8>> LOOP 255 and
1120: [ [THEN] ]
1121: [ [THEN] ]
1122: ;
1123: : 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ;
1124:
1125: c! c c_addr -- core c_store
1126: "" Write the value @i{c} to the char at address @i{c-addr}.""
1127: *c_addr = c;
1128: :
1129: [ bigendian [IF] ]
1130: [ cell>bit 4 = [IF] ]
1131: tuck 1 and IF $FF and ELSE 8<< THEN >r
1132: dup -2 and @ over 1 and cells masks + @ and
1133: r> or swap -2 and ! ;
1134: Create masks $00FF , $FF00 ,
1135: [ELSE] ]
1136: dup [ cell 1- ] literal and dup
1137: [ cell 1- ] literal xor >r
1138: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
1139: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
1140: [THEN]
1141: [ELSE] ]
1142: [ cell>bit 4 = [IF] ]
1143: tuck 1 and IF 8<< ELSE $FF and THEN >r
1144: dup -2 and @ over 1 and cells masks + @ and
1145: r> or swap -2 and ! ;
1146: Create masks $FF00 , $00FF ,
1147: [ELSE] ]
1148: dup [ cell 1- ] literal and dup >r
1149: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
1150: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
1151: [THEN]
1152: [THEN]
1153: : 8<< 2* 2* 2* 2* 2* 2* 2* 2* ;
1154:
1155: 2! w1 w2 a_addr -- core two_store
1156: "" Write the value @i{w1, w2} to the double at address @i{a-addr}.""
1157: a_addr[0] = w2;
1158: a_addr[1] = w1;
1159: :
1160: tuck ! cell+ ! ;
1161:
1162: 2@ a_addr -- w1 w2 core two_fetch
1163: "" Read from the double at address @i{a-addr}, and return its contents, @i{w1, w2}.""
1164: w2 = a_addr[0];
1165: w1 = a_addr[1];
1166: :
1167: dup cell+ @ swap @ ;
1168:
1169: cell+ a_addr1 -- a_addr2 core cell_plus
1170: "" Increment @i{a-addr1} by the number of address units corresponding to the size of
1171: one cell, to give @i{a-addr2}.""
1172: a_addr2 = a_addr1+1;
1173: :
1174: cell + ;
1175:
1176: cells n1 -- n2 core
1177: "" @i{n2} is the number of address units corresponding to @i{n1} cells.""
1178: n2 = n1 * sizeof(Cell);
1179: :
1180: [ cell
1181: 2/ dup [IF] ] 2* [ [THEN]
1182: 2/ dup [IF] ] 2* [ [THEN]
1183: 2/ dup [IF] ] 2* [ [THEN]
1184: 2/ dup [IF] ] 2* [ [THEN]
1185: drop ] ;
1186:
1187: char+ c_addr1 -- c_addr2 core char_plus
1188: "" Increment @i{c-addr1} by the number of address units corresponding to the size of
1189: one char, to give @i{c-addr2}.""
1190: c_addr2 = c_addr1 + 1;
1191: :
1192: 1+ ;
1193:
1194: (chars) n1 -- n2 gforth paren_chars
1195: n2 = n1 * sizeof(Char);
1196: :
1197: ;
1198:
1199: count c_addr1 -- c_addr2 u core
1200: "" If @i{c-add1} is the address of a counted string return the length of
1201: the string, @i{u}, and the address of its first character, @i{c-addr2}.""
1202: u = *c_addr1;
1203: c_addr2 = c_addr1+1;
1204: :
1205: dup 1+ swap c@ ;
1206:
1207: (f83find) c_addr u f83name1 -- f83name2 new paren_f83find
1208: for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
1209: if ((UCell)F83NAME_COUNT(f83name1)==u &&
1210: memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1211: break;
1212: f83name2=f83name1;
1213: :
1214: BEGIN dup WHILE (find-samelen) dup WHILE
1215: >r 2dup r@ cell+ char+ capscomp 0=
1216: IF 2drop r> EXIT THEN
1217: r> @
1218: REPEAT THEN nip nip ;
1219: : (find-samelen) ( u f83name1 -- u f83name2/0 )
1220: BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
1221:
1222: \+hash
1223:
1224: (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind
1225: struct F83Name *f83name1;
1226: f83name2=NULL;
1227: while(a_addr != NULL)
1228: {
1229: f83name1=(struct F83Name *)(a_addr[1]);
1230: a_addr=(Cell *)(a_addr[0]);
1231: if ((UCell)F83NAME_COUNT(f83name1)==u &&
1232: memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1233: {
1234: f83name2=f83name1;
1235: break;
1236: }
1237: }
1238: :
1239: BEGIN dup WHILE
1240: 2@ >r >r dup r@ cell+ c@ $1F and =
1241: IF 2dup r@ cell+ char+ capscomp 0=
1242: IF 2drop r> rdrop EXIT THEN THEN
1243: rdrop r>
1244: REPEAT nip nip ;
1245:
1246: (tablefind) c_addr u a_addr -- f83name2 new paren_tablefind
1247: ""A case-sensitive variant of @code{(hashfind)}""
1248: struct F83Name *f83name1;
1249: f83name2=NULL;
1250: while(a_addr != NULL)
1251: {
1252: f83name1=(struct F83Name *)(a_addr[1]);
1253: a_addr=(Cell *)(a_addr[0]);
1254: if ((UCell)F83NAME_COUNT(f83name1)==u &&
1255: memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1256: {
1257: f83name2=f83name1;
1258: break;
1259: }
1260: }
1261: :
1262: BEGIN dup WHILE
1263: 2@ >r >r dup r@ cell+ c@ $1F and =
1264: IF 2dup r@ cell+ char+ -text 0=
1265: IF 2drop r> rdrop EXIT THEN THEN
1266: rdrop r>
1267: REPEAT nip nip ;
1268:
1269: (hashkey) c_addr u1 -- u2 gforth paren_hashkey
1270: u2=0;
1271: while(u1--)
1272: u2+=(Cell)toupper(*c_addr++);
1273: :
1274: 0 -rot bounds ?DO I c@ toupper + LOOP ;
1275:
1276: (hashkey1) c_addr u ubits -- ukey gforth paren_hashkey1
1277: ""ukey is the hash key for the string c_addr u fitting in ubits bits""
1278: /* this hash function rotates the key at every step by rot bits within
1279: ubits bits and xors it with the character. This function does ok in
1280: the chi-sqare-test. Rot should be <=7 (preferably <=5) for
1281: ASCII strings (larger if ubits is large), and should share no
1282: divisors with ubits.
1283: */
1284: 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];
1285: Char *cp = c_addr;
1286: for (ukey=0; cp<c_addr+u; cp++)
1287: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
1288: ^ toupper(*cp))
1289: & ((1<<ubits)-1));
1290: :
1291: dup rot-values + c@ over 1 swap lshift 1- >r
1292: tuck - 2swap r> 0 2swap bounds
1293: ?DO dup 4 pick lshift swap 3 pick rshift or
1294: I c@ toupper xor
1295: over and LOOP
1296: nip nip nip ;
1297: Create rot-values
1298: 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c,
1299: 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c,
1300: 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c,
1301: 7 c, 5 c, 5 c,
1302:
1303: \+
1304:
1305: (parse-white) c_addr1 u1 -- c_addr2 u2 gforth paren_parse_white
1306: /* use !isgraph instead of isspace? */
1307: Char *endp = c_addr1+u1;
1308: while (c_addr1<endp && isspace(*c_addr1))
1309: c_addr1++;
1310: if (c_addr1<endp) {
1311: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
1312: ;
1313: u2 = c_addr1-c_addr2;
1314: }
1315: else {
1316: c_addr2 = c_addr1;
1317: u2 = 0;
1318: }
1319: :
1320: BEGIN dup WHILE over c@ bl <= WHILE 1 /string
1321: REPEAT THEN 2dup
1322: BEGIN dup WHILE over c@ bl > WHILE 1 /string
1323: REPEAT THEN nip - ;
1324:
1325: aligned c_addr -- a_addr core
1326: "" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}.""
1327: a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
1328: :
1329: [ cell 1- ] Literal + [ -1 cells ] Literal and ;
1330:
1331: faligned c_addr -- f_addr float f_aligned
1332: "" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}.""
1333: f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
1334: :
1335: [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
1336:
1337: >body xt -- a_addr core to_body
1338: a_addr = PFA(xt);
1339: :
1340: 2 cells + ;
1341:
1342: \+standardthreading
1343:
1344: >code-address xt -- c_addr gforth to_code_address
1345: ""@i{c-addr} is the code address of the word @i{xt}.""
1346: /* !! This behaves installation-dependently for DOES-words */
1347: c_addr = (Address)CODE_ADDRESS(xt);
1348: :
1349: @ ;
1350:
1351: >does-code xt -- a_addr gforth to_does_code
1352: ""If @i{xt} is the execution token of a defining-word-defined word,
1353: @i{a-addr} is the start of the Forth code after the @code{DOES>};
1354: Otherwise @i{a-addr} is 0.""
1355: a_addr = (Cell *)DOES_CODE(xt);
1356: :
1357: cell+ @ ;
1358:
1359: code-address! c_addr xt -- gforth code_address_store
1360: ""Create a code field with code address @i{c-addr} at @i{xt}.""
1361: MAKE_CF(xt, c_addr);
1362: CACHE_FLUSH(xt,(size_t)PFA(0));
1363: :
1364: ! ;
1365:
1366: does-code! a_addr xt -- gforth does_code_store
1367: ""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr}
1368: is the start of the Forth code after @code{DOES>}.""
1369: MAKE_DOES_CF(xt, a_addr);
1370: CACHE_FLUSH(xt,(size_t)PFA(0));
1371: :
1372: dodoes: over ! cell+ ! ;
1373:
1374: does-handler! a_addr -- gforth does_handler_store
1375: ""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points
1376: just behind a @code{DOES>}.""
1377: MAKE_DOES_HANDLER(a_addr);
1378: CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
1379: :
1380: drop ;
1381:
1382: /does-handler -- n gforth slash_does_handler
1383: ""The size of a @code{DOES>}-handler (includes possible padding).""
1384: /* !! a constant or environmental query might be better */
1385: n = DOES_HANDLER_SIZE;
1386: :
1387: 2 cells ;
1388:
1389: threading-method -- n gforth threading_method
1390: ""0 if the engine is direct threaded. Note that this may change during
1391: the lifetime of an image.""
1392: #if defined(DOUBLY_INDIRECT)
1393: n=2;
1394: #else
1395: # if defined(DIRECT_THREADED)
1396: n=0;
1397: # else
1398: n=1;
1399: # endif
1400: #endif
1401: :
1402: 1 ;
1403:
1404: \+
1405:
1406: key-file wfileid -- n gforth paren_key_file
1407: #ifdef HAS_FILE
1408: fflush(stdout);
1409: n = key((FILE*)wfileid);
1410: #else
1411: n = key(stdin);
1412: #endif
1413:
1414: key?-file wfileid -- n facility key_q_file
1415: #ifdef HAS_FILE
1416: fflush(stdout);
1417: n = key_query((FILE*)wfileid);
1418: #else
1419: n = key_query(stdin);
1420: #endif
1421:
1422: \+os
1423:
1424: stdin -- wfileid gforth
1425: wfileid = (Cell)stdin;
1426:
1427: stdout -- wfileid gforth
1428: wfileid = (Cell)stdout;
1429:
1430: stderr -- wfileid gforth
1431: wfileid = (Cell)stderr;
1432:
1433: form -- urows ucols gforth
1434: ""The number of lines and columns in the terminal. These numbers may change
1435: with the window size.""
1436: /* we could block SIGWINCH here to get a consistent size, but I don't
1437: think this is necessary or always beneficial */
1438: urows=rows;
1439: ucols=cols;
1440:
1441: flush-icache c_addr u -- gforth flush_icache
1442: ""Make sure that the instruction cache of the processor (if there is
1443: one) does not contain stale data at @i{c-addr} and @i{u} bytes
1444: afterwards. @code{END-CODE} performs a @code{flush-icache}
1445: automatically. Caveat: @code{flush-icache} might not work on your
1446: installation; this is usually the case if direct threading is not
1447: supported on your machine (take a look at your @file{machine.h}) and
1448: your machine has a separate instruction cache. In such cases,
1449: @code{flush-icache} does nothing instead of flushing the instruction
1450: cache.""
1451: FLUSH_ICACHE(c_addr,u);
1452:
1453: (bye) n -- gforth paren_bye
1454: return (Label *)n;
1455:
1456: (system) c_addr u -- wretval wior gforth peren_system
1457: #ifndef MSDOS
1458: int old_tp=terminal_prepped;
1459: deprep_terminal();
1460: #endif
1461: wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
1462: wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
1463: #ifndef MSDOS
1464: if (old_tp)
1465: prep_terminal();
1466: #endif
1467:
1468: getenv c_addr1 u1 -- c_addr2 u2 gforth
1469: ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
1470: is the host operating system's expansion of that environment variable. If the
1471: environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
1472: in length.""
1473: c_addr2 = getenv(cstr(c_addr1,u1,1));
1474: u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
1475:
1476: open-pipe c_addr u ntype -- wfileid wior gforth open_pipe
1477: wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */
1478: wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
1479:
1480: close-pipe wfileid -- wretval wior gforth close_pipe
1481: wretval = pclose((FILE *)wfileid);
1482: wior = IOR(wretval==-1);
1483:
1484: time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date
1485: struct timeval time1;
1486: struct timezone zone1;
1487: struct tm *ltime;
1488: gettimeofday(&time1,&zone1);
1489: ltime=localtime((time_t *)&time1.tv_sec);
1490: nyear =ltime->tm_year+1900;
1491: nmonth=ltime->tm_mon+1;
1492: nday =ltime->tm_mday;
1493: nhour =ltime->tm_hour;
1494: nmin =ltime->tm_min;
1495: nsec =ltime->tm_sec;
1496:
1497: ms n -- facility-ext
1498: struct timeval timeout;
1499: timeout.tv_sec=n/1000;
1500: timeout.tv_usec=1000*(n%1000);
1501: (void)select(0,0,0,0,&timeout);
1502:
1503: allocate u -- a_addr wior memory
1504: ""Allocate @i{u} address units of contiguous data space. The initial
1505: contents of the data space is undefined. If the allocation is successful,
1506: @i{a-addr} is the start address of the allocated region and @i{wior}
1507: is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
1508: is an implementation-defined I/O result code.""
1509: a_addr = (Cell *)malloc(u?u:1);
1510: wior = IOR(a_addr==NULL);
1511:
1512: free a_addr -- wior memory
1513: ""Return the region of data space starting at @i{a-addr} to the system.
1514: The regon must originally have been obtained using @code{allocate} or
1515: @code{resize}. If the operational is successful, @i{wior} is 0.
1516: If the operation fails, @i{wior} is an implementation-defined
1517: I/O result code.""
1518: free(a_addr);
1519: wior = 0;
1520:
1521: resize a_addr1 u -- a_addr2 wior memory
1522: ""Change the size of the allocated area at @i{a-addr1} to @i{u}
1523: address units, possibly moving the contents to a different
1524: area. @i{a-addr2} is the address of the resulting area.
1525: If the operational is successful, @i{wior} is 0.
1526: If the operation fails, @i{wior} is an implementation-defined
1527: I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard)
1528: @code{resize} @code{allocate}s @i{u} address units.""
1529: /* the following check is not necessary on most OSs, but it is needed
1530: on SunOS 4.1.2. */
1531: if (a_addr1==NULL)
1532: a_addr2 = (Cell *)malloc(u);
1533: else
1534: a_addr2 = (Cell *)realloc(a_addr1, u);
1535: wior = IOR(a_addr2==NULL); /* !! Define a return code */
1536:
1537: strerror n -- c_addr u gforth
1538: c_addr = strerror(n);
1539: u = strlen(c_addr);
1540:
1541: strsignal n -- c_addr u gforth
1542: c_addr = strsignal(n);
1543: u = strlen(c_addr);
1544:
1545: call-c w -- gforth call_c
1546: ""Call the C function pointed to by @i{w}. The C function has to
1547: access the stack itself. The stack pointers are exported in the global
1548: variables @code{SP} and @code{FP}.""
1549: /* This is a first attempt at support for calls to C. This may change in
1550: the future */
1551: IF_FTOS(fp[0]=FTOS);
1552: FP=fp;
1553: SP=sp;
1554: ((void (*)())w)();
1555: sp=SP;
1556: fp=FP;
1557: IF_TOS(TOS=sp[0]);
1558: IF_FTOS(FTOS=fp[0]);
1559:
1560: \+
1561: \+file
1562:
1563: close-file wfileid -- wior file close_file
1564: wior = IOR(fclose((FILE *)wfileid)==EOF);
1565:
1566: open-file c_addr u ntype -- wfileid wior file open_file
1567: wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
1568: #if defined(GO32) && defined(MSDOS)
1569: if(wfileid && !(ntype & 1))
1570: setbuf((FILE*)wfileid, NULL);
1571: #endif
1572: wior = IOR(wfileid == 0);
1573:
1574: create-file c_addr u ntype -- wfileid wior file create_file
1575: Cell fd;
1576: fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);
1577: if (fd != -1) {
1578: wfileid = (Cell)fdopen(fd, fileattr[ntype]);
1579: #if defined(GO32) && defined(MSDOS)
1580: if(wfileid && !(ntype & 1))
1581: setbuf((FILE*)wfileid, NULL);
1582: #endif
1583: wior = IOR(wfileid == 0);
1584: } else {
1585: wfileid = 0;
1586: wior = IOR(1);
1587: }
1588:
1589: delete-file c_addr u -- wior file delete_file
1590: wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
1591:
1592: rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file
1593: ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
1594: char *s1=tilde_cstr(c_addr2, u2, 1);
1595: wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
1596:
1597: file-position wfileid -- ud wior file file_position
1598: /* !! use tell and lseek? */
1599: ud = LONG2UD(ftell((FILE *)wfileid));
1600: wior = IOR(UD2LONG(ud)==-1);
1601:
1602: reposition-file ud wfileid -- wior file reposition_file
1603: wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
1604:
1605: file-size wfileid -- ud wior file file_size
1606: struct stat buf;
1607: wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
1608: ud = LONG2UD(buf.st_size);
1609:
1610: resize-file ud wfileid -- wior file resize_file
1611: wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1);
1612:
1613: read-file c_addr u1 wfileid -- u2 wior file read_file
1614: /* !! fread does not guarantee enough */
1615: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1616: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1617: /* !! is the value of ferror errno-compatible? */
1618: if (wior)
1619: clearerr((FILE *)wfileid);
1620:
1621: read-line c_addr u1 wfileid -- u2 flag wior file read_line
1622: /*
1623: Cell c;
1624: flag=-1;
1625: for(u2=0; u2<u1; u2++)
1626: {
1627: *c_addr++ = (Char)(c = getc((FILE *)wfileid));
1628: if(c=='\n') break;
1629: if(c==EOF)
1630: {
1631: flag=FLAG(u2!=0);
1632: break;
1633: }
1634: }
1635: wior=FILEIO(ferror((FILE *)wfileid));
1636: */
1637: if ((flag=FLAG(!feof((FILE *)wfileid) &&
1638: fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
1639: wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */
1640: if (wior)
1641: clearerr((FILE *)wfileid);
1642: u2 = strlen(c_addr);
1643: u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
1644: }
1645: else {
1646: wior=0;
1647: u2=0;
1648: }
1649:
1650: \+
1651: \+file
1652:
1653: write-file c_addr u1 wfileid -- wior file write_file
1654: /* !! fwrite does not guarantee enough */
1655: {
1656: UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1657: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1658: if (wior)
1659: clearerr((FILE *)wfileid);
1660: }
1661:
1662: \+
1663:
1664: emit-file c wfileid -- wior gforth emit_file
1665: #ifdef HAS_FILE
1666: wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
1667: if (wior)
1668: clearerr((FILE *)wfileid);
1669: #else
1670: putc(c, stdout);
1671: #endif
1672:
1673: \+file
1674:
1675: flush-file wfileid -- wior file-ext flush_file
1676: wior = IOR(fflush((FILE *) wfileid)==EOF);
1677:
1678: file-status c_addr u -- ntype wior file-ext file_status
1679: char *filename=tilde_cstr(c_addr, u, 1);
1680: if (access (filename, F_OK) != 0) {
1681: ntype=0;
1682: wior=IOR(1);
1683: }
1684: else if (access (filename, R_OK | W_OK) == 0) {
1685: ntype=2; /* r/w */
1686: wior=0;
1687: }
1688: else if (access (filename, R_OK) == 0) {
1689: ntype=0; /* r/o */
1690: wior=0;
1691: }
1692: else if (access (filename, W_OK) == 0) {
1693: ntype=4; /* w/o */
1694: wior=0;
1695: }
1696: else {
1697: ntype=1; /* well, we cannot access the file, but better deliver a legal
1698: access mode (r/o bin), so we get a decent error later upon open. */
1699: wior=0;
1700: }
1701:
1702: \+
1703: \+floating
1704:
1705: comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
1706: comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
1707:
1708: d>f d -- r float d_to_f
1709: #ifdef BUGGY_LONG_LONG
1710: extern double ldexp(double x, int exp);
1711: r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
1712: #else
1713: r = d;
1714: #endif
1715:
1716: f>d r -- d float f_to_d
1717: #ifdef BUGGY_LONG_LONG
1718: d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
1719: d.lo = r-ldexp((Float)d.hi,CELL_BITS);
1720: #else
1721: d = r;
1722: #endif
1723:
1724: f! r f_addr -- float f_store
1725: "" Store the floating-point value @i{r} to address @i{f-addr}.""
1726: *f_addr = r;
1727:
1728: f@ f_addr -- r float f_fetch
1729: "" Fetch floating-point value @i{r} from address @i{f-addr}.""
1730: r = *f_addr;
1731:
1732: df@ df_addr -- r float-ext d_f_fetch
1733: "" Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
1734: #ifdef IEEE_FP
1735: r = *df_addr;
1736: #else
1737: !! df@
1738: #endif
1739:
1740: df! r df_addr -- float-ext d_f_store
1741: "" Store the double-precision IEEE floating-point value @i{r} to the address @i{df-addr}.""
1742: #ifdef IEEE_FP
1743: *df_addr = r;
1744: #else
1745: !! df!
1746: #endif
1747:
1748: sf@ sf_addr -- r float-ext s_f_fetch
1749: "" Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
1750: #ifdef IEEE_FP
1751: r = *sf_addr;
1752: #else
1753: !! sf@
1754: #endif
1755:
1756: sf! r sf_addr -- float-ext s_f_store
1757: "" Store the single-precision IEEE floating-point value @i{r} to the address @i{sf-addr}.""
1758: #ifdef IEEE_FP
1759: *sf_addr = r;
1760: #else
1761: !! sf!
1762: #endif
1763:
1764: f+ r1 r2 -- r3 float f_plus
1765: r3 = r1+r2;
1766:
1767: f- r1 r2 -- r3 float f_minus
1768: r3 = r1-r2;
1769:
1770: f* r1 r2 -- r3 float f_star
1771: r3 = r1*r2;
1772:
1773: f/ r1 r2 -- r3 float f_slash
1774: r3 = r1/r2;
1775:
1776: f** r1 r2 -- r3 float-ext f_star_star
1777: ""@i{r3} is @i{r1} raised to the @i{r2}th power.""
1778: r3 = pow(r1,r2);
1779:
1780: fnegate r1 -- r2 float
1781: r2 = - r1;
1782:
1783: fdrop r -- float
1784:
1785: fdup r -- r r float
1786:
1787: fswap r1 r2 -- r2 r1 float
1788:
1789: fover r1 r2 -- r1 r2 r1 float
1790:
1791: frot r1 r2 r3 -- r2 r3 r1 float
1792:
1793: fnip r1 r2 -- r2 gforth
1794:
1795: ftuck r1 r2 -- r2 r1 r2 gforth
1796:
1797: float+ f_addr1 -- f_addr2 float float_plus
1798: "" Increment @i{f-addr1} by the number of address units corresponding to the size of
1799: one floating-point number, to give @i{f-addr2}.""
1800: f_addr2 = f_addr1+1;
1801:
1802: floats n1 -- n2 float
1803: ""@i{n2} is the number of address units corresponding to @i{n1} floating-point numbers.""
1804: n2 = n1*sizeof(Float);
1805:
1806: floor r1 -- r2 float
1807: ""Round towards the next smaller integral value, i.e., round toward negative infinity.""
1808: /* !! unclear wording */
1809: r2 = floor(r1);
1810:
1811: fround r1 -- r2 float
1812: ""Round to the nearest integral value.""
1813: /* !! unclear wording */
1814: #ifdef HAVE_RINT
1815: r2 = rint(r1);
1816: #else
1817: r2 = floor(r1+0.5);
1818: /* !! This is not quite true to the rounding rules given in the standard */
1819: #endif
1820:
1821: fmax r1 r2 -- r3 float
1822: if (r1<r2)
1823: r3 = r2;
1824: else
1825: r3 = r1;
1826:
1827: fmin r1 r2 -- r3 float
1828: if (r1<r2)
1829: r3 = r1;
1830: else
1831: r3 = r2;
1832:
1833: represent r c_addr u -- n f1 f2 float
1834: char *sig;
1835: int flag;
1836: int decpt;
1837: sig=ecvt(r, u, &decpt, &flag);
1838: n=(r==0 ? 1 : decpt);
1839: f1=FLAG(flag!=0);
1840: f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
1841: memmove(c_addr,sig,u);
1842:
1843: >float c_addr u -- flag float to_float
1844: ""Attempt to convert the character string @i{c-addr u} to
1845: internal floating-point representation. If the string
1846: represents a valid floating-point number @i{r} is placed
1847: on the floating-point stack and @i{flag} is true. Otherwise,
1848: @i{flag} is false. A string of blanks is a special case
1849: and represents the flotaing-point number 0.""
1850: /* real signature: c_addr u -- r t / f */
1851: Float r;
1852: char *number=cstr(c_addr, u, 1);
1853: char *endconv;
1854: while(isspace((unsigned)(number[--u])) && u>0);
1855: switch(number[u])
1856: {
1857: case 'd':
1858: case 'D':
1859: case 'e':
1860: case 'E': break;
1861: default : u++; break;
1862: }
1863: number[u]='\0';
1864: r=strtod(number,&endconv);
1865: if((flag=FLAG(!(Cell)*endconv)))
1866: {
1867: IF_FTOS(fp[0] = FTOS);
1868: fp += -1;
1869: FTOS = r;
1870: }
1871: else if(*endconv=='d' || *endconv=='D')
1872: {
1873: *endconv='E';
1874: r=strtod(number,&endconv);
1875: if((flag=FLAG(!(Cell)*endconv)))
1876: {
1877: IF_FTOS(fp[0] = FTOS);
1878: fp += -1;
1879: FTOS = r;
1880: }
1881: }
1882:
1883: fabs r1 -- r2 float-ext
1884: r2 = fabs(r1);
1885:
1886: facos r1 -- r2 float-ext
1887: r2 = acos(r1);
1888:
1889: fasin r1 -- r2 float-ext
1890: r2 = asin(r1);
1891:
1892: fatan r1 -- r2 float-ext
1893: r2 = atan(r1);
1894:
1895: fatan2 r1 r2 -- r3 float-ext
1896: ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably
1897: intends this to be the inverse of @code{fsincos}. In gforth it is.""
1898: r3 = atan2(r1,r2);
1899:
1900: fcos r1 -- r2 float-ext
1901: r2 = cos(r1);
1902:
1903: fexp r1 -- r2 float-ext
1904: r2 = exp(r1);
1905:
1906: fexpm1 r1 -- r2 float-ext
1907: ""@i{r2}=@i{e}**@i{r1}@minus{}1""
1908: #ifdef HAVE_EXPM1
1909: extern double
1910: #ifdef NeXT
1911: const
1912: #endif
1913: expm1(double);
1914: r2 = expm1(r1);
1915: #else
1916: r2 = exp(r1)-1.;
1917: #endif
1918:
1919: fln r1 -- r2 float-ext
1920: r2 = log(r1);
1921:
1922: flnp1 r1 -- r2 float-ext
1923: ""@i{r2}=ln(@i{r1}+1)""
1924: #ifdef HAVE_LOG1P
1925: extern double
1926: #ifdef NeXT
1927: const
1928: #endif
1929: log1p(double);
1930: r2 = log1p(r1);
1931: #else
1932: r2 = log(r1+1.);
1933: #endif
1934:
1935: flog r1 -- r2 float-ext
1936: ""The decimal logarithm.""
1937: r2 = log10(r1);
1938:
1939: falog r1 -- r2 float-ext
1940: ""@i{r2}=10**@i{r1}""
1941: extern double pow10(double);
1942: r2 = pow10(r1);
1943:
1944: fsin r1 -- r2 float-ext
1945: r2 = sin(r1);
1946:
1947: fsincos r1 -- r2 r3 float-ext
1948: ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
1949: r2 = sin(r1);
1950: r3 = cos(r1);
1951:
1952: fsqrt r1 -- r2 float-ext
1953: r2 = sqrt(r1);
1954:
1955: ftan r1 -- r2 float-ext
1956: r2 = tan(r1);
1957: :
1958: fsincos f/ ;
1959:
1960: fsinh r1 -- r2 float-ext
1961: r2 = sinh(r1);
1962: :
1963: fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
1964:
1965: fcosh r1 -- r2 float-ext
1966: r2 = cosh(r1);
1967: :
1968: fexp fdup 1/f f+ f2/ ;
1969:
1970: ftanh r1 -- r2 float-ext
1971: r2 = tanh(r1);
1972: :
1973: f2* fexpm1 fdup 2. d>f f+ f/ ;
1974:
1975: fasinh r1 -- r2 float-ext
1976: r2 = asinh(r1);
1977: :
1978: fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
1979:
1980: facosh r1 -- r2 float-ext
1981: r2 = acosh(r1);
1982: :
1983: fdup fdup f* 1. d>f f- fsqrt f+ fln ;
1984:
1985: fatanh r1 -- r2 float-ext
1986: r2 = atanh(r1);
1987: :
1988: fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/
1989: r> IF fnegate THEN ;
1990:
1991: sfloats n1 -- n2 float-ext s_floats
1992: ""@i{n2} is the number of address units corresponding to @i{n1}
1993: single-precision IEEE floating-point numbers.""
1994: n2 = n1*sizeof(SFloat);
1995:
1996: dfloats n1 -- n2 float-ext d_floats
1997: ""@i{n2} is the number of address units corresponding to @i{n1}
1998: double-precision IEEE floating-point numbers.""
1999: n2 = n1*sizeof(DFloat);
2000:
2001: sfaligned c_addr -- sf_addr float-ext s_f_aligned
2002: "" @i{sf-addr} is the first single-float-aligned address greater
2003: than or equal to @i{c-addr}.""
2004: sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
2005: :
2006: [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
2007:
2008: dfaligned c_addr -- df_addr float-ext d_f_aligned
2009: "" @i{df-addr} is the first double-float-aligned address greater
2010: than or equal to @i{c-addr}.""
2011: df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
2012: :
2013: [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
2014:
2015: \ The following words access machine/OS/installation-dependent
2016: \ Gforth internals
2017: \ !! how about environmental queries DIRECT-THREADED,
2018: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
2019:
2020: \ local variable implementation primitives
2021: \+
2022: \+glocals
2023:
2024: @local# -- w gforth fetch_local_number
2025: w = *(Cell *)(lp+(Cell)NEXT_INST);
2026: INC_IP(1);
2027:
2028: @local0 -- w new fetch_local_zero
2029: w = *(Cell *)(lp+0*sizeof(Cell));
2030:
2031: @local1 -- w new fetch_local_four
2032: w = *(Cell *)(lp+1*sizeof(Cell));
2033:
2034: @local2 -- w new fetch_local_eight
2035: w = *(Cell *)(lp+2*sizeof(Cell));
2036:
2037: @local3 -- w new fetch_local_twelve
2038: w = *(Cell *)(lp+3*sizeof(Cell));
2039:
2040: \+floating
2041:
2042: f@local# -- r gforth f_fetch_local_number
2043: r = *(Float *)(lp+(Cell)NEXT_INST);
2044: INC_IP(1);
2045:
2046: f@local0 -- r new f_fetch_local_zero
2047: r = *(Float *)(lp+0*sizeof(Float));
2048:
2049: f@local1 -- r new f_fetch_local_eight
2050: r = *(Float *)(lp+1*sizeof(Float));
2051:
2052: \+
2053:
2054: laddr# -- c_addr gforth laddr_number
2055: /* this can also be used to implement lp@ */
2056: c_addr = (Char *)(lp+(Cell)NEXT_INST);
2057: INC_IP(1);
2058:
2059: lp+!# -- gforth lp_plus_store_number
2060: ""used with negative immediate values it allocates memory on the
2061: local stack, a positive immediate argument drops memory from the local
2062: stack""
2063: lp += (Cell)NEXT_INST;
2064: INC_IP(1);
2065:
2066: lp- -- new minus_four_lp_plus_store
2067: lp += -sizeof(Cell);
2068:
2069: lp+ -- new eight_lp_plus_store
2070: lp += sizeof(Float);
2071:
2072: lp+2 -- new sixteen_lp_plus_store
2073: lp += 2*sizeof(Float);
2074:
2075: lp! c_addr -- gforth lp_store
2076: lp = (Address)c_addr;
2077:
2078: >l w -- gforth to_l
2079: lp -= sizeof(Cell);
2080: *(Cell *)lp = w;
2081:
2082: \+floating
2083:
2084: f>l r -- gforth f_to_l
2085: lp -= sizeof(Float);
2086: *(Float *)lp = r;
2087:
2088: fpick u -- r gforth
2089: r = fp[u+1]; /* +1, because update of fp happens before this fragment */
2090: :
2091: floats fp@ + f@ ;
2092:
2093: \+
2094: \+
2095:
2096: \+OS
2097:
2098: define(`uploop',
2099: `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
2100: define(`_uploop',
2101: `ifelse($1, `$3', `$5',
2102: `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')
2103: \ argflist(argnum): Forth argument list
2104: define(argflist,
2105: `ifelse($1, 0, `',
2106: `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')')
2107: \ argdlist(argnum): declare C's arguments
2108: define(argdlist,
2109: `ifelse($1, 0, `',
2110: `uploop(`_i', 1, $1, `Cell, ', `Cell')')')
2111: \ argclist(argnum): pass C's arguments
2112: define(argclist,
2113: `ifelse($1, 0, `',
2114: `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')
2115: \ icall(argnum)
2116: define(icall,
2117: `icall$1 argflist($1)u -- uret gforth
2118: uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
2119:
2120: ')
2121: define(fcall,
2122: `fcall$1 argflist($1)u -- rret gforth
2123: rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
2124:
2125: ')
2126:
2127:
2128: open-lib c_addr1 u1 -- u2 gforth open_lib
2129: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
2130: #ifndef RTLD_GLOBAL
2131: #define RTLD_GLOBAL 0
2132: #endif
2133: u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
2134: #else
2135: # ifdef _WIN32
2136: u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
2137: # else
2138: #warning Define open-lib!
2139: u2 = 0;
2140: # endif
2141: #endif
2142:
2143: lib-sym c_addr1 u1 u2 -- u3 gforth lib_sym
2144: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
2145: u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
2146: #else
2147: # ifdef _WIN32
2148: u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
2149: # else
2150: #warning Define lib-sym!
2151: u3 = 0;
2152: # endif
2153: #endif
2154:
2155: uploop(i, 0, 7, `icall(i)')
2156: icall(20)
2157: uploop(i, 0, 7, `fcall(i)')
2158: fcall(20)
2159:
2160: \+
2161:
2162: up! a_addr -- gforth up_store
2163: UP=up=(char *)a_addr;
2164: :
2165: up ! ;
2166: Variable UP
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>