File:
[gforth] /
gforth /
prim
Revision
1.150:
download - view:
text,
annotated -
select for diffs
Sun Jan 25 12:35:58 2004 UTC (20 years, 1 month ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
minore bugfixes (Makefile.in)
enabled 3-state stack caching for gforth-fast and gforth-native
bugfixes (EXECUTE and PERFORM; spbREG use)
explicit register allocation to spb for gforth-native, but not gforth-fast
Due to the shortest-path algorithm this means that gforth-fast uses only
S0 and S1, not S2, so we could keep that.
However, we probably want to use more states etc. for other
architectures, so we may want to have a way to select different
cache.vmg and different peeprules.vmg files for different
archs, builds, and binaries.
1: \ Gforth primitives
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000,2003 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., 59 Temple Place, Suite 330, Boston, MA 02111, 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: \ Note: Fields in brackets are optional. Word specifications have to
36: \ be separated by at least one empty line
37: \
38: \ Both pronounciation and stack items (in the stack effect) must
39: \ conform to the C identifier syntax or the C compiler will complain.
40: \ If you don't have a pronounciation field, the Forth name is used,
41: \ and has to conform to the C identifier syntax.
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: \ For superinstructions the syntax is:
58: \
59: \ forth-name [/ c-name] = forth-name forth-name ...
60: \
61: \
62: \ The stack variables have the following types:
63: \
64: \ name matches type
65: \ f.* Bool
66: \ c.* Char
67: \ [nw].* Cell
68: \ u.* UCell
69: \ d.* DCell
70: \ ud.* UDCell
71: \ r.* Float
72: \ a_.* Cell *
73: \ c_.* Char *
74: \ f_.* Float *
75: \ df_.* DFloat *
76: \ sf_.* SFloat *
77: \ xt.* XT
78: \ f83name.* F83Name *
79:
80: \E stack data-stack sp Cell
81: \E stack fp-stack fp Float
82: \E stack return-stack rp Cell
83: \E
84: \E get-current prefixes set-current
85: \E
86: \E s" Bool" single data-stack type-prefix f
87: \E s" Char" single data-stack type-prefix c
88: \E s" Cell" single data-stack type-prefix n
89: \E s" Cell" single data-stack type-prefix w
90: \E s" UCell" single data-stack type-prefix u
91: \E s" DCell" double data-stack type-prefix d
92: \E s" UDCell" double data-stack type-prefix ud
93: \E s" Float" single fp-stack type-prefix r
94: \E s" Cell *" single data-stack type-prefix a_
95: \E s" Char *" single data-stack type-prefix c_
96: \E s" Float *" single data-stack type-prefix f_
97: \E s" DFloat *" single data-stack type-prefix df_
98: \E s" SFloat *" single data-stack type-prefix sf_
99: \E s" Xt" single data-stack type-prefix xt
100: \E s" struct F83Name *" single data-stack type-prefix f83name
101: \E s" struct Longname *" single data-stack type-prefix longname
102: \E
103: \E return-stack stack-prefix R:
104: \E inst-stream stack-prefix #
105: \E
106: \E set-current
107: \E store-optimization on
108: \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
109: \E
110: \E include-skipped-insts on \ static superinsts include cells for components
111: \E \ useful for dynamic programming and
112: \E \ superinsts across entry points
113:
114: \
115: \
116: \
117: \ In addition the following names can be used:
118: \ ip the instruction pointer
119: \ sp the data stack pointer
120: \ rp the parameter stack pointer
121: \ lp the locals stack pointer
122: \ NEXT executes NEXT
123: \ cfa
124: \ NEXT1 executes NEXT1
125: \ FLAG(x) makes a Forth flag from a C flag
126: \
127: \
128: \
129: \ Percentages in comments are from Koopmans book: average/maximum use
130: \ (taken from four, not very representative benchmarks)
131: \
132: \
133: \
134: \ To do:
135: \
136: \ throw execute, cfa and NEXT1 out?
137: \ macroize *ip, ip++, *ip++ (pipelining)?
138:
139: \ Stack caching setup
140:
141: ifdef(`M4_ENGINE_FAST', `include(cache1.vmg)', `include(cache0.vmg)')
142:
143: \ these m4 macros would collide with identifiers
144: undefine(`index')
145: undefine(`shift')
146: undefine(`symbols')
147:
148: \F 0 [if]
149:
150: \ run-time routines for non-primitives. They are defined as
151: \ primitives, because that simplifies things.
152:
153: (docol) ( -- R:a_retaddr ) gforth-internal paren_docol
154: ""run-time routine for colon definitions""
155: #ifdef NO_IP
156: a_retaddr = next_code;
157: INST_TAIL;
158: goto **(Label *)PFA(CFA);
159: #else /* !defined(NO_IP) */
160: a_retaddr = (Cell *)IP;
161: SET_IP((Xt *)PFA(CFA));
162: #endif /* !defined(NO_IP) */
163:
164: (docon) ( -- w ) gforth-internal paren_docon
165: ""run-time routine for constants""
166: w = *(Cell *)PFA(CFA);
167: #ifdef NO_IP
168: INST_TAIL;
169: goto *next_code;
170: #endif /* defined(NO_IP) */
171:
172: (dovar) ( -- a_body ) gforth-internal paren_dovar
173: ""run-time routine for variables and CREATEd words""
174: a_body = PFA(CFA);
175: #ifdef NO_IP
176: INST_TAIL;
177: goto *next_code;
178: #endif /* defined(NO_IP) */
179:
180: (douser) ( -- a_user ) gforth-internal paren_douser
181: ""run-time routine for constants""
182: a_user = (Cell *)(up+*(Cell *)PFA(CFA));
183: #ifdef NO_IP
184: INST_TAIL;
185: goto *next_code;
186: #endif /* defined(NO_IP) */
187:
188: (dodefer) ( -- ) gforth-internal paren_dodefer
189: ""run-time routine for deferred words""
190: #ifndef NO_IP
191: ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
192: #endif /* !defined(NO_IP) */
193: SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
194: EXEC(*(Xt *)PFA(CFA));
195:
196: (dofield) ( n1 -- n2 ) gforth-internal paren_field
197: ""run-time routine for fields""
198: n2 = n1 + *(Cell *)PFA(CFA);
199: #ifdef NO_IP
200: INST_TAIL;
201: goto *next_code;
202: #endif /* defined(NO_IP) */
203:
204: (dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes
205: ""run-time routine for @code{does>}-defined words""
206: #ifdef NO_IP
207: a_retaddr = next_code;
208: a_body = PFA(CFA);
209: INST_TAIL;
210: goto **(Label *)DOES_CODE1(CFA);
211: #else /* !defined(NO_IP) */
212: a_retaddr = (Cell *)IP;
213: a_body = PFA(CFA);
214: SET_IP(DOES_CODE1(CFA));
215: #endif /* !defined(NO_IP) */
216:
217: (does-handler) ( -- ) gforth-internal paren_does_handler
218: ""just a slot to have an encoding for the DOESJUMP,
219: which is no longer used anyway (!! eliminate this)""
220:
221: \F [endif]
222:
223: \g control
224:
225: noop ( -- ) gforth
226: :
227: ;
228:
229: call ( #a_callee -- R:a_retaddr ) new
230: ""Call callee (a variant of docol with inline argument).""
231: #ifdef NO_IP
232: assert(0);
233: INST_TAIL;
234: JUMP(a_callee);
235: #else
236: #ifdef DEBUG
237: {
238: CFA_TO_NAME((((Cell *)a_callee)-2));
239: fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
240: len,name);
241: }
242: #endif
243: a_retaddr = (Cell *)IP;
244: SET_IP((Xt *)a_callee);
245: #endif
246:
247: execute ( xt -- ) core
248: ""Perform the semantics represented by the execution token, @i{xt}.""
249: #ifndef NO_IP
250: ip=IP;
251: #endif
252: IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */
253: SUPER_END;
254: EXEC(xt);
255:
256: perform ( a_addr -- ) gforth
257: ""@code{@@ execute}.""
258: /* and pfe */
259: #ifndef NO_IP
260: ip=IP;
261: #endif
262: IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */
263: SUPER_END;
264: EXEC(*(Xt *)a_addr);
265: :
266: @ execute ;
267:
268: ;s ( R:w -- ) gforth semis
269: ""The primitive compiled by @code{EXIT}.""
270: #ifdef NO_IP
271: INST_TAIL;
272: goto *(void *)w;
273: #else
274: SET_IP((Xt *)w);
275: #endif
276:
277: unloop ( R:w1 R:w2 -- ) core
278: /* !! alias for 2rdrop */
279: :
280: r> rdrop rdrop >r ;
281:
282: lit-perform ( #a_addr -- ) new lit_perform
283: #ifndef NO_IP
284: ip=IP;
285: #endif
286: SUPER_END;
287: EXEC(*(Xt *)a_addr);
288:
289: does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec
290: #ifdef NO_IP
291: /* compiled to LIT CALL by compile_prim */
292: assert(0);
293: #else
294: a_pfa = PFA(a_cfa);
295: nest = (Cell)IP;
296: IF_spTOS(spTOS = sp[0]);
297: #ifdef DEBUG
298: {
299: CFA_TO_NAME(a_cfa);
300: fprintf(stderr,"%08lx: does %08lx %.*s\n",
301: (Cell)ip,(Cell)a_cfa,len,name);
302: }
303: #endif
304: SET_IP(DOES_CODE1(a_cfa));
305: #endif
306:
307: \+glocals
308:
309: branch-lp+!# ( #a_target #nlocals -- ) gforth branch_lp_plus_store_number
310: /* this will probably not be used */
311: lp += nlocals;
312: #ifdef NO_IP
313: INST_TAIL;
314: JUMP(a_target);
315: #else
316: SET_IP((Xt *)a_target);
317: #endif
318:
319: \+
320:
321: branch ( #a_target -- ) gforth
322: #ifdef NO_IP
323: INST_TAIL;
324: JUMP(a_target);
325: #else
326: SET_IP((Xt *)a_target);
327: #endif
328: :
329: r> @ >r ;
330:
331: \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)
332: \ this is non-syntactical: code must open a brace that is closed by the macro
333: define(condbranch,
334: $1 ( `#'a_target $2 ) $3
335: $4 #ifdef NO_IP
336: INST_TAIL;
337: #endif
338: $5 #ifdef NO_IP
339: JUMP(a_target);
340: #else
341: SET_IP((Xt *)a_target);
342: INST_TAIL; NEXT_P2;
343: #endif
344: }
345: SUPER_CONTINUE;
346: $6
347:
348: \+glocals
349:
350: $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
351: $4 #ifdef NO_IP
352: INST_TAIL;
353: #endif
354: $5 lp += nlocals;
355: #ifdef NO_IP
356: JUMP(a_target);
357: #else
358: SET_IP((Xt *)a_target);
359: INST_TAIL; NEXT_P2;
360: #endif
361: }
362: SUPER_CONTINUE;
363:
364: \+
365: )
366:
367: condbranch(?branch,f --,f83 question_branch,
368: ,if (f==0) {
369: ,:
370: 0= dup 0= \ !f f
371: r> tuck cell+ \ !f branchoffset f IP+
372: and -rot @ and or \ f&IP+|!f&branch
373: >r ;)
374:
375: \ we don't need an lp_plus_store version of the ?dup-stuff, because it
376: \ is only used in if's (yet)
377:
378: \+xconds
379:
380: ?dup-?branch ( #a_target f -- f ) new question_dupe_question_branch
381: ""The run-time procedure compiled by @code{?DUP-IF}.""
382: if (f==0) {
383: sp++;
384: IF_spTOS(spTOS = sp[0]);
385: #ifdef NO_IP
386: INST_TAIL;
387: JUMP(a_target);
388: #else
389: SET_IP((Xt *)a_target);
390: INST_TAIL; NEXT_P2;
391: #endif
392: }
393: SUPER_CONTINUE;
394:
395: ?dup-0=-?branch ( #a_target f -- ) new question_dupe_zero_equals_question_branch
396: ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
397: /* the approach taken here of declaring the word as having the stack
398: effect ( f -- ) and correcting for it in the branch-taken case costs a
399: few cycles in that case, but is easy to convert to a CONDBRANCH
400: invocation */
401: if (f!=0) {
402: sp--;
403: #ifdef NO_IP
404: JUMP(a_target);
405: #else
406: SET_IP((Xt *)a_target);
407: NEXT;
408: #endif
409: }
410: SUPER_CONTINUE;
411:
412: \+
413: \fhas? skiploopprims 0= [IF]
414:
415: condbranch((next),R:n1 -- R:n2,cmFORTH paren_next,
416: n2=n1-1;
417: ,if (n1) {
418: ,:
419: r> r> dup 1- >r
420: IF @ >r ELSE cell+ >r THEN ;)
421:
422: condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,
423: n2=n1+1;
424: ,if (n2 != nlimit) {
425: ,:
426: r> r> 1+ r> 2dup =
427: IF >r 1- >r cell+ >r
428: ELSE >r >r @ >r THEN ;)
429:
430: condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop,
431: /* !! check this thoroughly */
432: /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
433: /* dependent upon two's complement arithmetic */
434: Cell olddiff = n1-nlimit;
435: n2=n1+n;
436: ,if (((olddiff^(olddiff+n)) /* the limit is not crossed */
437: &(olddiff^n)) /* OR it is a wrap-around effect */
438: >=0) { /* & is used to avoid having two branches for gforth-native */
439: ,:
440: r> swap
441: r> r> 2dup - >r
442: 2 pick r@ + r@ xor 0< 0=
443: 3 pick r> xor 0< 0= or
444: IF >r + >r @ >r
445: ELSE >r >r drop cell+ >r THEN ;)
446:
447: \+xconds
448:
449: condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
450: UCell olddiff = n1-nlimit;
451: n2=n1-u;
452: ,if (olddiff>u) {
453: ,)
454:
455: condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_symmetric_plus_loop,
456: ""The run-time procedure compiled by S+LOOP. It loops until the index
457: crosses the boundary between limit and limit-sign(n). I.e. a symmetric
458: version of (+LOOP).""
459: /* !! check this thoroughly */
460: Cell diff = n1-nlimit;
461: Cell newdiff = diff+n;
462: if (n<0) {
463: diff = -diff;
464: newdiff = -newdiff;
465: }
466: n2=n1+n;
467: ,if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */
468: ,)
469:
470: \+
471:
472: (for) ( ncount -- R:nlimit R:ncount ) cmFORTH paren_for
473: /* or (for) = >r -- collides with unloop! */
474: nlimit=0;
475: :
476: r> swap 0 >r >r >r ;
477:
478: (do) ( nlimit nstart -- R:nlimit R:nstart ) gforth paren_do
479: :
480: r> swap rot >r >r >r ;
481:
482: (?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_question_do
483: #ifdef NO_IP
484: INST_TAIL;
485: #endif
486: if (nstart == nlimit) {
487: #ifdef NO_IP
488: JUMP(a_target);
489: #else
490: SET_IP((Xt *)a_target);
491: INST_TAIL; NEXT_P2;
492: #endif
493: }
494: SUPER_CONTINUE;
495: :
496: 2dup =
497: IF r> swap rot >r >r
498: @ >r
499: ELSE r> swap rot >r >r
500: cell+ >r
501: THEN ; \ --> CORE-EXT
502:
503: \+xconds
504:
505: (+do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do
506: #ifdef NO_IP
507: INST_TAIL;
508: #endif
509: if (nstart >= nlimit) {
510: #ifdef NO_IP
511: JUMP(a_target);
512: #else
513: SET_IP((Xt *)a_target);
514: INST_TAIL; NEXT_P2;
515: #endif
516: }
517: SUPER_CONTINUE;
518: :
519: swap 2dup
520: r> swap >r swap >r
521: >=
522: IF
523: @
524: ELSE
525: cell+
526: THEN >r ;
527:
528: (u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do
529: #ifdef NO_IP
530: INST_TAIL;
531: #endif
532: if (ustart >= ulimit) {
533: #ifdef NO_IP
534: JUMP(a_target);
535: #else
536: SET_IP((Xt *)a_target);
537: INST_TAIL; NEXT_P2;
538: #endif
539: }
540: SUPER_CONTINUE;
541: :
542: swap 2dup
543: r> swap >r swap >r
544: u>=
545: IF
546: @
547: ELSE
548: cell+
549: THEN >r ;
550:
551: (-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do
552: #ifdef NO_IP
553: INST_TAIL;
554: #endif
555: if (nstart <= nlimit) {
556: #ifdef NO_IP
557: JUMP(a_target);
558: #else
559: SET_IP((Xt *)a_target);
560: INST_TAIL; NEXT_P2;
561: #endif
562: }
563: SUPER_CONTINUE;
564: :
565: swap 2dup
566: r> swap >r swap >r
567: <=
568: IF
569: @
570: ELSE
571: cell+
572: THEN >r ;
573:
574: (u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do
575: #ifdef NO_IP
576: INST_TAIL;
577: #endif
578: if (ustart <= ulimit) {
579: #ifdef NO_IP
580: JUMP(a_target);
581: #else
582: SET_IP((Xt *)a_target);
583: INST_TAIL; NEXT_P2;
584: #endif
585: }
586: SUPER_CONTINUE;
587: :
588: swap 2dup
589: r> swap >r swap >r
590: u<=
591: IF
592: @
593: ELSE
594: cell+
595: THEN >r ;
596:
597: \+
598:
599: \ don't make any assumptions where the return stack is!!
600: \ implement this in machine code if it should run quickly!
601:
602: i ( R:n -- R:n n ) core
603: :
604: \ rp@ cell+ @ ;
605: r> r> tuck >r >r ;
606:
607: i' ( R:w R:w2 -- R:w R:w2 w ) gforth i_tick
608: :
609: \ rp@ cell+ cell+ @ ;
610: r> r> r> dup itmp ! >r >r >r itmp @ ;
611: variable itmp
612:
613: j ( R:n R:d1 -- n R:n R:d1 ) core
614: :
615: \ rp@ cell+ cell+ cell+ @ ;
616: r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
617: [IFUNDEF] itmp variable itmp [THEN]
618:
619: k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 ) gforth
620: :
621: \ rp@ [ 5 cells ] Literal + @ ;
622: r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
623: [IFUNDEF] itmp variable itmp [THEN]
624:
625: \f[THEN]
626:
627: \ digit is high-level: 0/0%
628:
629: \g strings
630:
631: move ( c_from c_to ucount -- ) core
632: ""Copy the contents of @i{ucount} aus at @i{c-from} to
633: @i{c-to}. @code{move} works correctly even if the two areas overlap.""
634: /* !! note that the standard specifies addr, not c-addr */
635: memmove(c_to,c_from,ucount);
636: /* make an Ifdef for bsd and others? */
637: :
638: >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
639:
640: cmove ( c_from c_to u -- ) string c_move
641: ""Copy the contents of @i{ucount} characters from data space at
642: @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
643: from low address to high address; i.e., for overlapping areas it is
644: safe if @i{c-to}=<@i{c-from}.""
645: cmove(c_from,c_to,u);
646: :
647: bounds ?DO dup c@ I c! 1+ LOOP drop ;
648:
649: cmove> ( c_from c_to u -- ) string c_move_up
650: ""Copy the contents of @i{ucount} characters from data space at
651: @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
652: from high address to low address; i.e., for overlapping areas it is
653: safe if @i{c-to}>=@i{c-from}.""
654: cmove_up(c_from,c_to,u);
655: :
656: dup 0= IF drop 2drop exit THEN
657: rot over + -rot bounds swap 1-
658: DO 1- dup c@ I c! -1 +LOOP drop ;
659:
660: fill ( c_addr u c -- ) core
661: ""Store @i{c} in @i{u} chars starting at @i{c-addr}.""
662: memset(c_addr,c,u);
663: :
664: -rot bounds
665: ?DO dup I c! LOOP drop ;
666:
667: compare ( c_addr1 u1 c_addr2 u2 -- n ) string
668: ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
669: the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}
670: is 1. Currently this is based on the machine's character
671: comparison. In the future, this may change to consider the current
672: locale and its collation order.""
673: /* close ' to keep fontify happy */
674: n = compare(c_addr1, u1, c_addr2, u2);
675: :
676: rot 2dup swap - >r min swap -text dup
677: IF rdrop ELSE drop r> sgn THEN ;
678: : -text ( c_addr1 u c_addr2 -- n )
679: swap bounds
680: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
681: ELSE c@ I c@ - unloop THEN sgn ;
682: : sgn ( n -- -1/0/1 )
683: dup 0= IF EXIT THEN 0< 2* 1+ ;
684:
685: \ -text is only used by replaced primitives now; move it elsewhere
686: \ -text ( c_addr1 u c_addr2 -- n ) new dash_text
687: \ n = memcmp(c_addr1, c_addr2, u);
688: \ if (n<0)
689: \ n = -1;
690: \ else if (n>0)
691: \ n = 1;
692: \ :
693: \ swap bounds
694: \ ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
695: \ ELSE c@ I c@ - unloop THEN sgn ;
696: \ : sgn ( n -- -1/0/1 )
697: \ dup 0= IF EXIT THEN 0< 2* 1+ ;
698:
699: toupper ( c1 -- c2 ) gforth
700: ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
701: is the equivalent upper-case character. All other characters are unchanged.""
702: c2 = toupper(c1);
703: :
704: dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ;
705:
706: /string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string
707: ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
708: characters from the start of the string.""
709: c_addr2 = c_addr1+n;
710: u2 = u1-n;
711: :
712: tuck - >r + r> dup 0< IF - 0 THEN ;
713:
714: \g arith
715:
716: lit ( #w -- w ) gforth
717: :
718: r> dup @ swap cell+ >r ;
719:
720: + ( n1 n2 -- n ) core plus
721: n = n1+n2;
722:
723: \ lit+ / lit_plus = lit +
724:
725: lit+ ( n1 #n2 -- n ) new lit_plus
726: n=n1+n2;
727:
728: \ PFE-0.9.14 has it differently, but the next release will have it as follows
729: under+ ( n1 n2 n3 -- n n2 ) gforth under_plus
730: ""add @i{n3} to @i{n1} (giving @i{n})""
731: n = n1+n3;
732: :
733: rot + swap ;
734:
735: - ( n1 n2 -- n ) core minus
736: n = n1-n2;
737: :
738: negate + ;
739:
740: negate ( n1 -- n2 ) core
741: /* use minus as alias */
742: n2 = -n1;
743: :
744: invert 1+ ;
745:
746: 1+ ( n1 -- n2 ) core one_plus
747: n2 = n1+1;
748: :
749: 1 + ;
750:
751: 1- ( n1 -- n2 ) core one_minus
752: n2 = n1-1;
753: :
754: 1 - ;
755:
756: max ( n1 n2 -- n ) core
757: if (n1<n2)
758: n = n2;
759: else
760: n = n1;
761: :
762: 2dup < IF swap THEN drop ;
763:
764: min ( n1 n2 -- n ) core
765: if (n1<n2)
766: n = n1;
767: else
768: n = n2;
769: :
770: 2dup > IF swap THEN drop ;
771:
772: abs ( n -- u ) core
773: if (n<0)
774: u = -n;
775: else
776: u = n;
777: :
778: dup 0< IF negate THEN ;
779:
780: * ( n1 n2 -- n ) core star
781: n = n1*n2;
782: :
783: um* drop ;
784:
785: / ( n1 n2 -- n ) core slash
786: n = n1/n2;
787: :
788: /mod nip ;
789:
790: mod ( n1 n2 -- n ) core
791: n = n1%n2;
792: :
793: /mod drop ;
794:
795: /mod ( n1 n2 -- n3 n4 ) core slash_mod
796: n4 = n1/n2;
797: n3 = n1%n2; /* !! is this correct? look into C standard! */
798: :
799: >r s>d r> fm/mod ;
800:
801: 2* ( n1 -- n2 ) core two_star
802: ""Shift left by 1; also works on unsigned numbers""
803: n2 = 2*n1;
804: :
805: dup + ;
806:
807: 2/ ( n1 -- n2 ) core two_slash
808: ""Arithmetic shift right by 1. For signed numbers this is a floored
809: division by 2 (note that @code{/} not necessarily floors).""
810: n2 = n1>>1;
811: :
812: dup MINI and IF 1 ELSE 0 THEN
813: [ bits/byte cell * 1- ] literal
814: 0 DO 2* swap dup 2* >r MINI and
815: IF 1 ELSE 0 THEN or r> swap
816: LOOP nip ;
817:
818: fm/mod ( d1 n1 -- n2 n3 ) core f_m_slash_mod
819: ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
820: #ifdef BUGGY_LONG_LONG
821: DCell r = fmdiv(d1,n1);
822: n2=r.hi;
823: n3=r.lo;
824: #else
825: /* assumes that the processor uses either floored or symmetric division */
826: n3 = d1/n1;
827: n2 = d1%n1;
828: /* note that this 1%-3>0 is optimized by the compiler */
829: if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
830: n3--;
831: n2+=n1;
832: }
833: #endif
834: :
835: dup >r dup 0< IF negate >r dnegate r> THEN
836: over 0< IF tuck + swap THEN
837: um/mod
838: r> 0< IF swap negate swap THEN ;
839:
840: sm/rem ( d1 n1 -- n2 n3 ) core s_m_slash_rem
841: ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
842: #ifdef BUGGY_LONG_LONG
843: DCell r = smdiv(d1,n1);
844: n2=r.hi;
845: n3=r.lo;
846: #else
847: /* assumes that the processor uses either floored or symmetric division */
848: n3 = d1/n1;
849: n2 = d1%n1;
850: /* note that this 1%-3<0 is optimized by the compiler */
851: if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
852: n3++;
853: n2-=n1;
854: }
855: #endif
856: :
857: over >r dup >r abs -rot
858: dabs rot um/mod
859: r> r@ xor 0< IF negate THEN
860: r> 0< IF swap negate swap THEN ;
861:
862: m* ( n1 n2 -- d ) core m_star
863: #ifdef BUGGY_LONG_LONG
864: d = mmul(n1,n2);
865: #else
866: d = (DCell)n1 * (DCell)n2;
867: #endif
868: :
869: 2dup 0< and >r
870: 2dup swap 0< and >r
871: um* r> - r> - ;
872:
873: um* ( u1 u2 -- ud ) core u_m_star
874: /* use u* as alias */
875: #ifdef BUGGY_LONG_LONG
876: ud = ummul(u1,u2);
877: #else
878: ud = (UDCell)u1 * (UDCell)u2;
879: #endif
880: :
881: 0 -rot dup [ 8 cells ] literal -
882: DO
883: dup 0< I' and d2*+ drop
884: LOOP ;
885: : d2*+ ( ud n -- ud+n c )
886: over MINI
887: and >r >r 2dup d+ swap r> + swap r> ;
888:
889: um/mod ( ud u1 -- u2 u3 ) core u_m_slash_mod
890: ""ud=u3*u1+u2, u1>u2>=0""
891: #ifdef BUGGY_LONG_LONG
892: UDCell r = umdiv(ud,u1);
893: u2=r.hi;
894: u3=r.lo;
895: #else
896: u3 = ud/u1;
897: u2 = ud%u1;
898: #endif
899: :
900: 0 swap [ 8 cells 1 + ] literal 0
901: ?DO /modstep
902: LOOP drop swap 1 rshift or swap ;
903: : /modstep ( ud c R: u -- ud-?u c R: u )
904: >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ;
905: : d2*+ ( ud n -- ud+n c )
906: over MINI
907: and >r >r 2dup d+ swap r> + swap r> ;
908:
909: m+ ( d1 n -- d2 ) double m_plus
910: #ifdef BUGGY_LONG_LONG
911: d2.lo = d1.lo+n;
912: d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);
913: #else
914: d2 = d1+n;
915: #endif
916: :
917: s>d d+ ;
918:
919: d+ ( d1 d2 -- d ) double d_plus
920: #ifdef BUGGY_LONG_LONG
921: d.lo = d1.lo+d2.lo;
922: d.hi = d1.hi + d2.hi + (d.lo<d1.lo);
923: #else
924: d = d1+d2;
925: #endif
926: :
927: rot + >r tuck + swap over u> r> swap - ;
928:
929: d- ( d1 d2 -- d ) double d_minus
930: #ifdef BUGGY_LONG_LONG
931: d.lo = d1.lo - d2.lo;
932: d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);
933: #else
934: d = d1-d2;
935: #endif
936: :
937: dnegate d+ ;
938:
939: dnegate ( d1 -- d2 ) double d_negate
940: /* use dminus as alias */
941: #ifdef BUGGY_LONG_LONG
942: d2 = dnegate(d1);
943: #else
944: d2 = -d1;
945: #endif
946: :
947: invert swap negate tuck 0= - ;
948:
949: d2* ( d1 -- d2 ) double d_two_star
950: ""Shift left by 1; also works on unsigned numbers""
951: #ifdef BUGGY_LONG_LONG
952: d2.lo = d1.lo<<1;
953: d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
954: #else
955: d2 = 2*d1;
956: #endif
957: :
958: 2dup d+ ;
959:
960: d2/ ( d1 -- d2 ) double d_two_slash
961: ""Arithmetic shift right by 1. For signed numbers this is a floored
962: division by 2.""
963: #ifdef BUGGY_LONG_LONG
964: d2.hi = d1.hi>>1;
965: d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
966: #else
967: d2 = d1>>1;
968: #endif
969: :
970: dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
971: r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ;
972:
973: and ( w1 w2 -- w ) core
974: w = w1&w2;
975:
976: or ( w1 w2 -- w ) core
977: w = w1|w2;
978: :
979: invert swap invert and invert ;
980:
981: xor ( w1 w2 -- w ) core x_or
982: w = w1^w2;
983:
984: invert ( w1 -- w2 ) core
985: w2 = ~w1;
986: :
987: MAXU xor ;
988:
989: rshift ( u1 n -- u2 ) core r_shift
990: ""Logical shift right by @i{n} bits.""
991: u2 = u1>>n;
992: :
993: 0 ?DO 2/ MAXI and LOOP ;
994:
995: lshift ( u1 n -- u2 ) core l_shift
996: u2 = u1<<n;
997: :
998: 0 ?DO 2* LOOP ;
999:
1000: \g compare
1001:
1002: \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
1003: define(comparisons,
1004: $1= ( $2 -- f ) $6 $3equals
1005: f = FLAG($4==$5);
1006: :
1007: [ char $1x char 0 = [IF]
1008: ] IF false ELSE true THEN [
1009: [ELSE]
1010: ] xor 0= [
1011: [THEN] ] ;
1012:
1013: $1<> ( $2 -- f ) $7 $3not_equals
1014: f = FLAG($4!=$5);
1015: :
1016: [ char $1x char 0 = [IF]
1017: ] IF true ELSE false THEN [
1018: [ELSE]
1019: ] xor 0<> [
1020: [THEN] ] ;
1021:
1022: $1< ( $2 -- f ) $8 $3less_than
1023: f = FLAG($4<$5);
1024: :
1025: [ char $1x char 0 = [IF]
1026: ] MINI and 0<> [
1027: [ELSE] char $1x char u = [IF]
1028: ] 2dup xor 0< IF nip ELSE - THEN 0< [
1029: [ELSE]
1030: ] MINI xor >r MINI xor r> u< [
1031: [THEN]
1032: [THEN] ] ;
1033:
1034: $1> ( $2 -- f ) $9 $3greater_than
1035: f = FLAG($4>$5);
1036: :
1037: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
1038: $1< ;
1039:
1040: $1<= ( $2 -- f ) gforth $3less_or_equal
1041: f = FLAG($4<=$5);
1042: :
1043: $1> 0= ;
1044:
1045: $1>= ( $2 -- f ) gforth $3greater_or_equal
1046: f = FLAG($4>=$5);
1047: :
1048: [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
1049: $1<= ;
1050:
1051: )
1052:
1053: comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
1054: comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
1055: comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)
1056:
1057: \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
1058: define(dcomparisons,
1059: $1= ( $2 -- f ) $6 $3equals
1060: #ifdef BUGGY_LONG_LONG
1061: f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
1062: #else
1063: f = FLAG($4==$5);
1064: #endif
1065:
1066: $1<> ( $2 -- f ) $7 $3not_equals
1067: #ifdef BUGGY_LONG_LONG
1068: f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
1069: #else
1070: f = FLAG($4!=$5);
1071: #endif
1072:
1073: $1< ( $2 -- f ) $8 $3less_than
1074: #ifdef BUGGY_LONG_LONG
1075: f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
1076: #else
1077: f = FLAG($4<$5);
1078: #endif
1079:
1080: $1> ( $2 -- f ) $9 $3greater_than
1081: #ifdef BUGGY_LONG_LONG
1082: f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
1083: #else
1084: f = FLAG($4>$5);
1085: #endif
1086:
1087: $1<= ( $2 -- f ) gforth $3less_or_equal
1088: #ifdef BUGGY_LONG_LONG
1089: f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);
1090: #else
1091: f = FLAG($4<=$5);
1092: #endif
1093:
1094: $1>= ( $2 -- f ) gforth $3greater_or_equal
1095: #ifdef BUGGY_LONG_LONG
1096: f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
1097: #else
1098: f = FLAG($4>=$5);
1099: #endif
1100:
1101: )
1102:
1103: \+dcomps
1104:
1105: dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
1106: dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
1107: dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
1108:
1109: \+
1110:
1111: within ( u1 u2 u3 -- f ) core-ext
1112: ""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2). This works for
1113: unsigned and signed numbers (but not a mixture). Another way to think
1114: about this word is to consider the numbers as a circle (wrapping
1115: around from @code{max-u} to 0 for unsigned, and from @code{max-n} to
1116: min-n for signed numbers); now consider the range from u2 towards
1117: increasing numbers up to and excluding u3 (giving an empty range if
1118: u2=u3); if u1 is in this range, @code{within} returns true.""
1119: f = FLAG(u1-u2 < u3-u2);
1120: :
1121: over - >r - r> u< ;
1122:
1123: \g stack
1124:
1125: useraddr ( #u -- a_addr ) new
1126: a_addr = (Cell *)(up+u);
1127:
1128: up! ( a_addr -- ) gforth up_store
1129: UP=up=(char *)a_addr;
1130: :
1131: up ! ;
1132: Variable UP
1133:
1134: sp@ ( -- a_addr ) gforth sp_fetch
1135: a_addr = sp+1;
1136:
1137: sp! ( a_addr -- ) gforth sp_store
1138: sp = a_addr;
1139: /* works with and without spTOS caching */
1140:
1141: rp@ ( -- a_addr ) gforth rp_fetch
1142: a_addr = rp;
1143:
1144: rp! ( a_addr -- ) gforth rp_store
1145: rp = a_addr;
1146:
1147: \+floating
1148:
1149: fp@ ( -- f_addr ) gforth fp_fetch
1150: f_addr = fp;
1151:
1152: fp! ( f_addr -- ) gforth fp_store
1153: fp = f_addr;
1154:
1155: \+
1156:
1157: >r ( w -- R:w ) core to_r
1158: :
1159: (>r) ;
1160: : (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ;
1161:
1162: r> ( R:w -- w ) core r_from
1163: :
1164: rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
1165: Create (rdrop) ' ;s A,
1166:
1167: rdrop ( R:w -- ) gforth
1168: :
1169: r> r> drop >r ;
1170:
1171: 2>r ( d -- R:d ) core-ext two_to_r
1172: :
1173: swap r> swap >r swap >r >r ;
1174:
1175: 2r> ( R:d -- d ) core-ext two_r_from
1176: :
1177: r> r> swap r> swap >r swap ;
1178:
1179: 2r@ ( R:d -- R:d d ) core-ext two_r_fetch
1180: :
1181: i' j ;
1182:
1183: 2rdrop ( R:d -- ) gforth two_r_drop
1184: :
1185: r> r> drop r> drop >r ;
1186:
1187: over ( w1 w2 -- w1 w2 w1 ) core
1188: :
1189: sp@ cell+ @ ;
1190:
1191: drop ( w -- ) core
1192: :
1193: IF THEN ;
1194:
1195: swap ( w1 w2 -- w2 w1 ) core
1196: :
1197: >r (swap) ! r> (swap) @ ;
1198: Variable (swap)
1199:
1200: dup ( w -- w w ) core dupe
1201: :
1202: sp@ @ ;
1203:
1204: rot ( w1 w2 w3 -- w2 w3 w1 ) core rote
1205: :
1206: [ defined? (swap) [IF] ]
1207: (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
1208: Variable (rot)
1209: [ELSE] ]
1210: >r swap r> swap ;
1211: [THEN]
1212:
1213: -rot ( w1 w2 w3 -- w3 w1 w2 ) gforth not_rote
1214: :
1215: rot rot ;
1216:
1217: nip ( w1 w2 -- w2 ) core-ext
1218: :
1219: swap drop ;
1220:
1221: tuck ( w1 w2 -- w2 w1 w2 ) core-ext
1222: :
1223: swap over ;
1224:
1225: ?dup ( w -- w ) core question_dupe
1226: ""Actually the stack effect is: @code{( w -- 0 | w w )}. It performs a
1227: @code{dup} if w is nonzero.""
1228: if (w!=0) {
1229: IF_spTOS(*sp-- = w;)
1230: #ifndef USE_TOS
1231: *--sp = w;
1232: #endif
1233: }
1234: :
1235: dup IF dup THEN ;
1236:
1237: pick ( u -- w ) core-ext
1238: ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
1239: w = sp[u+1];
1240: :
1241: 1+ cells sp@ + @ ;
1242:
1243: 2drop ( w1 w2 -- ) core two_drop
1244: :
1245: drop drop ;
1246:
1247: 2dup ( w1 w2 -- w1 w2 w1 w2 ) core two_dupe
1248: :
1249: over over ;
1250:
1251: 2over ( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 ) core two_over
1252: :
1253: 3 pick 3 pick ;
1254:
1255: 2swap ( w1 w2 w3 w4 -- w3 w4 w1 w2 ) core two_swap
1256: :
1257: rot >r rot r> ;
1258:
1259: 2rot ( w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 ) double-ext two_rote
1260: :
1261: >r >r 2swap r> r> 2swap ;
1262:
1263: 2nip ( w1 w2 w3 w4 -- w3 w4 ) gforth two_nip
1264: :
1265: 2swap 2drop ;
1266:
1267: 2tuck ( w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 ) gforth two_tuck
1268: :
1269: 2swap 2over ;
1270:
1271: \ toggle is high-level: 0.11/0.42%
1272:
1273: \g memory
1274:
1275: @ ( a_addr -- w ) core fetch
1276: ""@i{w} is the cell stored at @i{a_addr}.""
1277: w = *a_addr;
1278:
1279: \ lit@ / lit_fetch = lit @
1280:
1281: lit@ ( #a_addr -- w ) new lit_fetch
1282: w = *a_addr;
1283:
1284: ! ( w a_addr -- ) core store
1285: ""Store @i{w} into the cell at @i{a-addr}.""
1286: *a_addr = w;
1287:
1288: +! ( n a_addr -- ) core plus_store
1289: ""Add @i{n} to the cell at @i{a-addr}.""
1290: *a_addr += n;
1291: :
1292: tuck @ + swap ! ;
1293:
1294: c@ ( c_addr -- c ) core c_fetch
1295: ""@i{c} is the char stored at @i{c_addr}.""
1296: c = *c_addr;
1297: :
1298: [ bigendian [IF] ]
1299: [ cell>bit 4 = [IF] ]
1300: dup [ 0 cell - ] Literal and @ swap 1 and
1301: IF $FF and ELSE 8>> THEN ;
1302: [ [ELSE] ]
1303: dup [ cell 1- ] literal and
1304: tuck - @ swap [ cell 1- ] literal xor
1305: 0 ?DO 8>> LOOP $FF and
1306: [ [THEN] ]
1307: [ [ELSE] ]
1308: [ cell>bit 4 = [IF] ]
1309: dup [ 0 cell - ] Literal and @ swap 1 and
1310: IF 8>> ELSE $FF and THEN
1311: [ [ELSE] ]
1312: dup [ cell 1- ] literal and
1313: tuck - @ swap
1314: 0 ?DO 8>> LOOP 255 and
1315: [ [THEN] ]
1316: [ [THEN] ]
1317: ;
1318: : 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ;
1319:
1320: c! ( c c_addr -- ) core c_store
1321: ""Store @i{c} into the char at @i{c-addr}.""
1322: *c_addr = c;
1323: :
1324: [ bigendian [IF] ]
1325: [ cell>bit 4 = [IF] ]
1326: tuck 1 and IF $FF and ELSE 8<< THEN >r
1327: dup -2 and @ over 1 and cells masks + @ and
1328: r> or swap -2 and ! ;
1329: Create masks $00FF , $FF00 ,
1330: [ELSE] ]
1331: dup [ cell 1- ] literal and dup
1332: [ cell 1- ] literal xor >r
1333: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
1334: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
1335: [THEN]
1336: [ELSE] ]
1337: [ cell>bit 4 = [IF] ]
1338: tuck 1 and IF 8<< ELSE $FF and THEN >r
1339: dup -2 and @ over 1 and cells masks + @ and
1340: r> or swap -2 and ! ;
1341: Create masks $FF00 , $00FF ,
1342: [ELSE] ]
1343: dup [ cell 1- ] literal and dup >r
1344: - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
1345: rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
1346: [THEN]
1347: [THEN]
1348: : 8<< 2* 2* 2* 2* 2* 2* 2* 2* ;
1349:
1350: 2! ( w1 w2 a_addr -- ) core two_store
1351: ""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell.""
1352: a_addr[0] = w2;
1353: a_addr[1] = w1;
1354: :
1355: tuck ! cell+ ! ;
1356:
1357: 2@ ( a_addr -- w1 w2 ) core two_fetch
1358: ""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is
1359: the content of the next cell.""
1360: w2 = a_addr[0];
1361: w1 = a_addr[1];
1362: :
1363: dup cell+ @ swap @ ;
1364:
1365: cell+ ( a_addr1 -- a_addr2 ) core cell_plus
1366: ""@code{1 cells +}""
1367: a_addr2 = a_addr1+1;
1368: :
1369: cell + ;
1370:
1371: cells ( n1 -- n2 ) core
1372: "" @i{n2} is the number of address units of @i{n1} cells.""
1373: n2 = n1 * sizeof(Cell);
1374: :
1375: [ cell
1376: 2/ dup [IF] ] 2* [ [THEN]
1377: 2/ dup [IF] ] 2* [ [THEN]
1378: 2/ dup [IF] ] 2* [ [THEN]
1379: 2/ dup [IF] ] 2* [ [THEN]
1380: drop ] ;
1381:
1382: char+ ( c_addr1 -- c_addr2 ) core char_plus
1383: ""@code{1 chars +}.""
1384: c_addr2 = c_addr1 + 1;
1385: :
1386: 1+ ;
1387:
1388: (chars) ( n1 -- n2 ) gforth paren_chars
1389: n2 = n1 * sizeof(Char);
1390: :
1391: ;
1392:
1393: count ( c_addr1 -- c_addr2 u ) core
1394: ""@i{c-addr2} is the first character and @i{u} the length of the
1395: counted string at @i{c-addr1}.""
1396: u = *c_addr1;
1397: c_addr2 = c_addr1+1;
1398: :
1399: dup 1+ swap c@ ;
1400:
1401: \g compiler
1402:
1403: \+f83headerstring
1404:
1405: (f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find
1406: for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
1407: if ((UCell)F83NAME_COUNT(f83name1)==u &&
1408: memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
1409: break;
1410: f83name2=f83name1;
1411: :
1412: BEGIN dup WHILE (find-samelen) dup WHILE
1413: >r 2dup r@ cell+ char+ capscomp 0=
1414: IF 2drop r> EXIT THEN
1415: r> @
1416: REPEAT THEN nip nip ;
1417: : (find-samelen) ( u f83name1 -- u f83name2/0 )
1418: BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
1419: : capscomp ( c_addr1 u c_addr2 -- n )
1420: swap bounds
1421: ?DO dup c@ I c@ <>
1422: IF dup c@ toupper I c@ toupper =
1423: ELSE true THEN WHILE 1+ LOOP drop 0
1424: ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
1425: : sgn ( n -- -1/0/1 )
1426: dup 0= IF EXIT THEN 0< 2* 1+ ;
1427:
1428: \-
1429:
1430: (listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind
1431: longname2=listlfind(c_addr, u, longname1);
1432: :
1433: BEGIN dup WHILE (findl-samelen) dup WHILE
1434: >r 2dup r@ cell+ cell+ capscomp 0=
1435: IF 2drop r> EXIT THEN
1436: r> @
1437: REPEAT THEN nip nip ;
1438: : (findl-samelen) ( u longname1 -- u longname2/0 )
1439: BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ;
1440: : capscomp ( c_addr1 u c_addr2 -- n )
1441: swap bounds
1442: ?DO dup c@ I c@ <>
1443: IF dup c@ toupper I c@ toupper =
1444: ELSE true THEN WHILE 1+ LOOP drop 0
1445: ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
1446: : sgn ( n -- -1/0/1 )
1447: dup 0= IF EXIT THEN 0< 2* 1+ ;
1448:
1449: \+hash
1450:
1451: (hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind
1452: longname2 = hashlfind(c_addr, u, a_addr);
1453: :
1454: BEGIN dup WHILE
1455: 2@ >r >r dup r@ cell+ @ lcount-mask and =
1456: IF 2dup r@ cell+ cell+ capscomp 0=
1457: IF 2drop r> rdrop EXIT THEN THEN
1458: rdrop r>
1459: REPEAT nip nip ;
1460:
1461: (tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind
1462: ""A case-sensitive variant of @code{(hashfind)}""
1463: longname2 = tablelfind(c_addr, u, a_addr);
1464: :
1465: BEGIN dup WHILE
1466: 2@ >r >r dup r@ cell+ @ lcount-mask and =
1467: IF 2dup r@ cell+ cell+ -text 0=
1468: IF 2drop r> rdrop EXIT THEN THEN
1469: rdrop r>
1470: REPEAT nip nip ;
1471: : -text ( c_addr1 u c_addr2 -- n )
1472: swap bounds
1473: ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
1474: ELSE c@ I c@ - unloop THEN sgn ;
1475: : sgn ( n -- -1/0/1 )
1476: dup 0= IF EXIT THEN 0< 2* 1+ ;
1477:
1478: (hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1
1479: ""ukey is the hash key for the string c_addr u fitting in ubits bits""
1480: ukey = hashkey1(c_addr, u, ubits);
1481: :
1482: dup rot-values + c@ over 1 swap lshift 1- >r
1483: tuck - 2swap r> 0 2swap bounds
1484: ?DO dup 4 pick lshift swap 3 pick rshift or
1485: I c@ toupper xor
1486: over and LOOP
1487: nip nip nip ;
1488: Create rot-values
1489: 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c,
1490: 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c,
1491: 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c,
1492: 7 c, 5 c, 5 c,
1493:
1494: \+
1495:
1496: \+
1497:
1498: (parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white
1499: struct Cellpair r=parse_white(c_addr1, u1);
1500: c_addr2 = (Char *)(r.n1);
1501: u2 = r.n2;
1502: :
1503: BEGIN dup WHILE over c@ bl <= WHILE 1 /string
1504: REPEAT THEN 2dup
1505: BEGIN dup WHILE over c@ bl > WHILE 1 /string
1506: REPEAT THEN nip - ;
1507:
1508: aligned ( c_addr -- a_addr ) core
1509: "" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}.""
1510: a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
1511: :
1512: [ cell 1- ] Literal + [ -1 cells ] Literal and ;
1513:
1514: faligned ( c_addr -- f_addr ) float f_aligned
1515: "" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}.""
1516: f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
1517: :
1518: [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
1519:
1520: \ threading stuff is currently only interesting if we have a compiler
1521: \fhas? standardthreading has? compiler and [IF]
1522: threading-method ( -- n ) gforth threading_method
1523: ""0 if the engine is direct threaded. Note that this may change during
1524: the lifetime of an image.""
1525: #if defined(DOUBLY_INDIRECT)
1526: n=2;
1527: #else
1528: # if defined(DIRECT_THREADED)
1529: n=0;
1530: # else
1531: n=1;
1532: # endif
1533: #endif
1534: :
1535: 1 ;
1536:
1537: \f[THEN]
1538:
1539: \g hostos
1540:
1541: key-file ( wfileid -- n ) gforth paren_key_file
1542: #ifdef HAS_FILE
1543: fflush(stdout);
1544: n = key((FILE*)wfileid);
1545: #else
1546: n = key(stdin);
1547: #endif
1548:
1549: key?-file ( wfileid -- n ) facility key_q_file
1550: #ifdef HAS_FILE
1551: fflush(stdout);
1552: n = key_query((FILE*)wfileid);
1553: #else
1554: n = key_query(stdin);
1555: #endif
1556:
1557: \+os
1558:
1559: stdin ( -- wfileid ) gforth
1560: wfileid = (Cell)stdin;
1561:
1562: stdout ( -- wfileid ) gforth
1563: wfileid = (Cell)stdout;
1564:
1565: stderr ( -- wfileid ) gforth
1566: wfileid = (Cell)stderr;
1567:
1568: form ( -- urows ucols ) gforth
1569: ""The number of lines and columns in the terminal. These numbers may change
1570: with the window size.""
1571: /* we could block SIGWINCH here to get a consistent size, but I don't
1572: think this is necessary or always beneficial */
1573: urows=rows;
1574: ucols=cols;
1575:
1576: flush-icache ( c_addr u -- ) gforth flush_icache
1577: ""Make sure that the instruction cache of the processor (if there is
1578: one) does not contain stale data at @i{c-addr} and @i{u} bytes
1579: afterwards. @code{END-CODE} performs a @code{flush-icache}
1580: automatically. Caveat: @code{flush-icache} might not work on your
1581: installation; this is usually the case if direct threading is not
1582: supported on your machine (take a look at your @file{machine.h}) and
1583: your machine has a separate instruction cache. In such cases,
1584: @code{flush-icache} does nothing instead of flushing the instruction
1585: cache.""
1586: FLUSH_ICACHE(c_addr,u);
1587:
1588: (bye) ( n -- ) gforth paren_bye
1589: SUPER_END;
1590: return (Label *)n;
1591:
1592: (system) ( c_addr u -- wretval wior ) gforth paren_system
1593: #ifndef MSDOS
1594: int old_tp=terminal_prepped;
1595: deprep_terminal();
1596: #endif
1597: wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
1598: wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
1599: #ifndef MSDOS
1600: if (old_tp)
1601: prep_terminal();
1602: #endif
1603:
1604: getenv ( c_addr1 u1 -- c_addr2 u2 ) gforth
1605: ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
1606: is the host operating system's expansion of that environment variable. If the
1607: environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
1608: in length.""
1609: /* close ' to keep fontify happy */
1610: c_addr2 = getenv(cstr(c_addr1,u1,1));
1611: u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
1612:
1613: open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe
1614: wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */
1615: wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
1616:
1617: close-pipe ( wfileid -- wretval wior ) gforth close_pipe
1618: wretval = pclose((FILE *)wfileid);
1619: wior = IOR(wretval==-1);
1620:
1621: time&date ( -- nsec nmin nhour nday nmonth nyear ) facility-ext time_and_date
1622: ""Report the current time of day. Seconds, minutes and hours are numbered from 0.
1623: Months are numbered from 1.""
1624: #if 1
1625: time_t now;
1626: struct tm *ltime;
1627: time(&now);
1628: ltime=localtime(&now);
1629: #else
1630: struct timeval time1;
1631: struct timezone zone1;
1632: struct tm *ltime;
1633: gettimeofday(&time1,&zone1);
1634: /* !! Single Unix specification:
1635: If tzp is not a null pointer, the behaviour is unspecified. */
1636: ltime=localtime((time_t *)&time1.tv_sec);
1637: #endif
1638: nyear =ltime->tm_year+1900;
1639: nmonth=ltime->tm_mon+1;
1640: nday =ltime->tm_mday;
1641: nhour =ltime->tm_hour;
1642: nmin =ltime->tm_min;
1643: nsec =ltime->tm_sec;
1644:
1645: ms ( n -- ) facility-ext
1646: ""Wait at least @i{n} milli-second.""
1647: struct timeval timeout;
1648: timeout.tv_sec=n/1000;
1649: timeout.tv_usec=1000*(n%1000);
1650: (void)select(0,0,0,0,&timeout);
1651:
1652: allocate ( u -- a_addr wior ) memory
1653: ""Allocate @i{u} address units of contiguous data space. The initial
1654: contents of the data space is undefined. If the allocation is successful,
1655: @i{a-addr} is the start address of the allocated region and @i{wior}
1656: is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
1657: is a non-zero I/O result code.""
1658: a_addr = (Cell *)malloc(u?u:1);
1659: wior = IOR(a_addr==NULL);
1660:
1661: free ( a_addr -- wior ) memory
1662: ""Return the region of data space starting at @i{a-addr} to the system.
1663: The region must originally have been obtained using @code{allocate} or
1664: @code{resize}. If the operational is successful, @i{wior} is 0.
1665: If the operation fails, @i{wior} is a non-zero I/O result code.""
1666: free(a_addr);
1667: wior = 0;
1668:
1669: resize ( a_addr1 u -- a_addr2 wior ) memory
1670: ""Change the size of the allocated area at @i{a-addr1} to @i{u}
1671: address units, possibly moving the contents to a different
1672: area. @i{a-addr2} is the address of the resulting area.
1673: If the operation is successful, @i{wior} is 0.
1674: If the operation fails, @i{wior} is a non-zero
1675: I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard)
1676: @code{resize} @code{allocate}s @i{u} address units.""
1677: /* the following check is not necessary on most OSs, but it is needed
1678: on SunOS 4.1.2. */
1679: /* close ' to keep fontify happy */
1680: if (a_addr1==NULL)
1681: a_addr2 = (Cell *)malloc(u);
1682: else
1683: a_addr2 = (Cell *)realloc(a_addr1, u);
1684: wior = IOR(a_addr2==NULL); /* !! Define a return code */
1685:
1686: strerror ( n -- c_addr u ) gforth
1687: c_addr = strerror(n);
1688: u = strlen(c_addr);
1689:
1690: strsignal ( n -- c_addr u ) gforth
1691: c_addr = (Address)strsignal(n);
1692: u = strlen(c_addr);
1693:
1694: call-c ( w -- ) gforth call_c
1695: ""Call the C function pointed to by @i{w}. The C function has to
1696: access the stack itself. The stack pointers are exported in the global
1697: variables @code{SP} and @code{FP}.""
1698: /* This is a first attempt at support for calls to C. This may change in
1699: the future */
1700: IF_fpTOS(fp[0]=fpTOS);
1701: FP=fp;
1702: SP=sp;
1703: ((void (*)())w)();
1704: sp=SP;
1705: fp=FP;
1706: IF_spTOS(spTOS=sp[0]);
1707: IF_fpTOS(fpTOS=fp[0]);
1708:
1709: \+
1710: \+file
1711:
1712: close-file ( wfileid -- wior ) file close_file
1713: wior = IOR(fclose((FILE *)wfileid)==EOF);
1714:
1715: open-file ( c_addr u wfam -- wfileid wior ) file open_file
1716: wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);
1717: wior = IOR(wfileid == 0);
1718:
1719: create-file ( c_addr u wfam -- wfileid wior ) file create_file
1720: Cell fd;
1721: fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);
1722: if (fd != -1) {
1723: wfileid = (Cell)fdopen(fd, fileattr[wfam]);
1724: wior = IOR(wfileid == 0);
1725: } else {
1726: wfileid = 0;
1727: wior = IOR(1);
1728: }
1729:
1730: delete-file ( c_addr u -- wior ) file delete_file
1731: wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
1732:
1733: rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file
1734: ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
1735: wior = rename_file(c_addr1, u1, c_addr2, u2);
1736:
1737: file-position ( wfileid -- ud wior ) file file_position
1738: /* !! use tell and lseek? */
1739: ud = OFF2UD(ftello((FILE *)wfileid));
1740: wior = IOR(UD2OFF(ud)==-1);
1741:
1742: reposition-file ( ud wfileid -- wior ) file reposition_file
1743: wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1);
1744:
1745: file-size ( wfileid -- ud wior ) file file_size
1746: struct stat buf;
1747: wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
1748: ud = OFF2UD(buf.st_size);
1749:
1750: resize-file ( ud wfileid -- wior ) file resize_file
1751: wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1);
1752:
1753: read-file ( c_addr u1 wfileid -- u2 wior ) file read_file
1754: /* !! fread does not guarantee enough */
1755: u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1756: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1757: /* !! is the value of ferror errno-compatible? */
1758: if (wior)
1759: clearerr((FILE *)wfileid);
1760:
1761: (read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line
1762: struct Cellquad r = read_line(c_addr, u1, wfileid);
1763: u2 = r.n1;
1764: flag = r.n2;
1765: u3 = r.n3;
1766: wior = r.n4;
1767:
1768: \+
1769:
1770: write-file ( c_addr u1 wfileid -- wior ) file write_file
1771: /* !! fwrite does not guarantee enough */
1772: #ifdef HAS_FILE
1773: {
1774: UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
1775: wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
1776: if (wior)
1777: clearerr((FILE *)wfileid);
1778: }
1779: #else
1780: TYPE(c_addr, u1);
1781: #endif
1782:
1783: emit-file ( c wfileid -- wior ) gforth emit_file
1784: #ifdef HAS_FILE
1785: wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
1786: if (wior)
1787: clearerr((FILE *)wfileid);
1788: #else
1789: PUTC(c);
1790: #endif
1791:
1792: \+file
1793:
1794: flush-file ( wfileid -- wior ) file-ext flush_file
1795: wior = IOR(fflush((FILE *) wfileid)==EOF);
1796:
1797: file-status ( c_addr u -- wfam wior ) file-ext file_status
1798: struct Cellpair r = file_status(c_addr, u);
1799: wfam = r.n1;
1800: wior = r.n2;
1801:
1802: file-eof? ( wfileid -- flag ) gforth file_eof_query
1803: flag = FLAG(feof((FILE *) wfileid));
1804:
1805: open-dir ( c_addr u -- wdirid wior ) gforth open_dir
1806: ""Open the directory specified by @i{c-addr, u}
1807: and return @i{dir-id} for futher access to it.""
1808: wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
1809: wior = IOR(wdirid == 0);
1810:
1811: read-dir ( c_addr u1 wdirid -- u2 flag wior ) gforth read_dir
1812: ""Attempt to read the next entry from the directory specified
1813: by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}.
1814: If the attempt fails because there is no more entries,
1815: @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
1816: If the attempt to read the next entry fails because of any other reason,
1817: return @i{ior}<>0.
1818: If the attempt succeeds, store file name to the buffer at @i{c-addr}
1819: and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.
1820: If the length of the file name is greater than @i{u1},
1821: store first @i{u1} characters from file name into the buffer and
1822: indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
1823: struct dirent * dent;
1824: dent = readdir((DIR *)wdirid);
1825: wior = 0;
1826: flag = -1;
1827: if(dent == NULL) {
1828: u2 = 0;
1829: flag = 0;
1830: } else {
1831: u2 = strlen(dent->d_name);
1832: if(u2 > u1) {
1833: u2 = u1;
1834: wior = -512-ENAMETOOLONG;
1835: }
1836: memmove(c_addr, dent->d_name, u2);
1837: }
1838:
1839: close-dir ( wdirid -- wior ) gforth close_dir
1840: ""Close the directory specified by @i{dir-id}.""
1841: wior = IOR(closedir((DIR *)wdirid));
1842:
1843: filename-match ( c_addr1 u1 c_addr2 u2 -- flag ) gforth match_file
1844: char * string = cstr(c_addr1, u1, 1);
1845: char * pattern = cstr(c_addr2, u2, 0);
1846: flag = FLAG(!fnmatch(pattern, string, 0));
1847:
1848: \+
1849:
1850: newline ( -- c_addr u ) gforth
1851: ""String containing the newline sequence of the host OS""
1852: char newline[] = {
1853: #if DIRSEP=='/'
1854: /* Unix */
1855: '\n'
1856: #else
1857: /* DOS, Win, OS/2 */
1858: '\r','\n'
1859: #endif
1860: };
1861: c_addr=newline;
1862: u=sizeof(newline);
1863: :
1864: "newline count ;
1865: Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
1866:
1867: \+os
1868:
1869: utime ( -- dtime ) gforth
1870: ""Report the current time in microseconds since some epoch.""
1871: struct timeval time1;
1872: gettimeofday(&time1,NULL);
1873: dtime = timeval2us(&time1);
1874:
1875: cputime ( -- duser dsystem ) gforth
1876: ""duser and dsystem are the respective user- and system-level CPU
1877: times used since the start of the Forth system (excluding child
1878: processes), in microseconds (the granularity may be much larger,
1879: however). On platforms without the getrusage call, it reports elapsed
1880: time (since some epoch) for duser and 0 for dsystem.""
1881: #ifdef HAVE_GETRUSAGE
1882: struct rusage usage;
1883: getrusage(RUSAGE_SELF, &usage);
1884: duser = timeval2us(&usage.ru_utime);
1885: dsystem = timeval2us(&usage.ru_stime);
1886: #else
1887: struct timeval time1;
1888: gettimeofday(&time1,NULL);
1889: duser = timeval2us(&time1);
1890: #ifndef BUGGY_LONG_LONG
1891: dsystem = (DCell)0;
1892: #else
1893: dsystem=(DCell){0,0};
1894: #endif
1895: #endif
1896:
1897: \+
1898:
1899: \+floating
1900:
1901: \g floating
1902:
1903: comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
1904: comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
1905:
1906: d>f ( d -- r ) float d_to_f
1907: #ifdef BUGGY_LONG_LONG
1908: extern double ldexp(double x, int exp);
1909: if (d.hi<0) {
1910: DCell d2=dnegate(d);
1911: r = -(ldexp((Float)d2.hi,CELL_BITS) + (Float)d2.lo);
1912: } else
1913: r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
1914: #else
1915: r = d;
1916: #endif
1917:
1918: f>d ( r -- d ) float f_to_d
1919: extern DCell double2ll(Float r);
1920: d = double2ll(r);
1921:
1922: f! ( r f_addr -- ) float f_store
1923: ""Store @i{r} into the float at address @i{f-addr}.""
1924: *f_addr = r;
1925:
1926: f@ ( f_addr -- r ) float f_fetch
1927: ""@i{r} is the float at address @i{f-addr}.""
1928: r = *f_addr;
1929:
1930: df@ ( df_addr -- r ) float-ext d_f_fetch
1931: ""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
1932: #ifdef IEEE_FP
1933: r = *df_addr;
1934: #else
1935: !! df@
1936: #endif
1937:
1938: df! ( r df_addr -- ) float-ext d_f_store
1939: ""Store @i{r} as double-precision IEEE floating-point value to the
1940: address @i{df-addr}.""
1941: #ifdef IEEE_FP
1942: *df_addr = r;
1943: #else
1944: !! df!
1945: #endif
1946:
1947: sf@ ( sf_addr -- r ) float-ext s_f_fetch
1948: ""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
1949: #ifdef IEEE_FP
1950: r = *sf_addr;
1951: #else
1952: !! sf@
1953: #endif
1954:
1955: sf! ( r sf_addr -- ) float-ext s_f_store
1956: ""Store @i{r} as single-precision IEEE floating-point value to the
1957: address @i{sf-addr}.""
1958: #ifdef IEEE_FP
1959: *sf_addr = r;
1960: #else
1961: !! sf!
1962: #endif
1963:
1964: f+ ( r1 r2 -- r3 ) float f_plus
1965: r3 = r1+r2;
1966:
1967: f- ( r1 r2 -- r3 ) float f_minus
1968: r3 = r1-r2;
1969:
1970: f* ( r1 r2 -- r3 ) float f_star
1971: r3 = r1*r2;
1972:
1973: f/ ( r1 r2 -- r3 ) float f_slash
1974: r3 = r1/r2;
1975:
1976: f** ( r1 r2 -- r3 ) float-ext f_star_star
1977: ""@i{r3} is @i{r1} raised to the @i{r2}th power.""
1978: r3 = pow(r1,r2);
1979:
1980: fnegate ( r1 -- r2 ) float f_negate
1981: r2 = - r1;
1982:
1983: fdrop ( r -- ) float f_drop
1984:
1985: fdup ( r -- r r ) float f_dupe
1986:
1987: fswap ( r1 r2 -- r2 r1 ) float f_swap
1988:
1989: fover ( r1 r2 -- r1 r2 r1 ) float f_over
1990:
1991: frot ( r1 r2 r3 -- r2 r3 r1 ) float f_rote
1992:
1993: fnip ( r1 r2 -- r2 ) gforth f_nip
1994:
1995: ftuck ( r1 r2 -- r2 r1 r2 ) gforth f_tuck
1996:
1997: float+ ( f_addr1 -- f_addr2 ) float float_plus
1998: ""@code{1 floats +}.""
1999: f_addr2 = f_addr1+1;
2000:
2001: floats ( n1 -- n2 ) float
2002: ""@i{n2} is the number of address units of @i{n1} floats.""
2003: n2 = n1*sizeof(Float);
2004:
2005: floor ( r1 -- r2 ) float
2006: ""Round towards the next smaller integral value, i.e., round toward negative infinity.""
2007: /* !! unclear wording */
2008: r2 = floor(r1);
2009:
2010: fround ( r1 -- r2 ) gforth f_round
2011: ""Round to the nearest integral value.""
2012: r2 = rint(r1);
2013:
2014: fmax ( r1 r2 -- r3 ) float f_max
2015: if (r1<r2)
2016: r3 = r2;
2017: else
2018: r3 = r1;
2019:
2020: fmin ( r1 r2 -- r3 ) float f_min
2021: if (r1<r2)
2022: r3 = r1;
2023: else
2024: r3 = r2;
2025:
2026: represent ( r c_addr u -- n f1 f2 ) float
2027: char *sig;
2028: size_t siglen;
2029: int flag;
2030: int decpt;
2031: sig=ecvt(r, u, &decpt, &flag);
2032: n=(r==0. ? 1 : decpt);
2033: f1=FLAG(flag!=0);
2034: f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
2035: siglen=strlen(sig);
2036: if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */
2037: siglen=u;
2038: memcpy(c_addr,sig,siglen);
2039: memset(c_addr+siglen,f2?'0':' ',u-siglen);
2040:
2041: >float ( c_addr u -- flag ) float to_float
2042: ""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the
2043: character string @i{c-addr u} to internal floating-point
2044: representation. If the string represents a valid floating-point number
2045: @i{r} is placed on the floating-point stack and @i{flag} is
2046: true. Otherwise, @i{flag} is false. A string of blanks is a special
2047: case and represents the floating-point number 0.""
2048: Float r;
2049: flag = to_float(c_addr, u, &r);
2050: if (flag) {
2051: IF_fpTOS(fp[0] = fpTOS);
2052: fp += -1;
2053: fpTOS = r;
2054: }
2055:
2056: fabs ( r1 -- r2 ) float-ext f_abs
2057: r2 = fabs(r1);
2058:
2059: facos ( r1 -- r2 ) float-ext f_a_cos
2060: r2 = acos(r1);
2061:
2062: fasin ( r1 -- r2 ) float-ext f_a_sine
2063: r2 = asin(r1);
2064:
2065: fatan ( r1 -- r2 ) float-ext f_a_tan
2066: r2 = atan(r1);
2067:
2068: fatan2 ( r1 r2 -- r3 ) float-ext f_a_tan_two
2069: ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably
2070: intends this to be the inverse of @code{fsincos}. In gforth it is.""
2071: r3 = atan2(r1,r2);
2072:
2073: fcos ( r1 -- r2 ) float-ext f_cos
2074: r2 = cos(r1);
2075:
2076: fexp ( r1 -- r2 ) float-ext f_e_x_p
2077: r2 = exp(r1);
2078:
2079: fexpm1 ( r1 -- r2 ) float-ext f_e_x_p_m_one
2080: ""@i{r2}=@i{e}**@i{r1}@minus{}1""
2081: #ifdef HAVE_EXPM1
2082: extern double
2083: #ifdef NeXT
2084: const
2085: #endif
2086: expm1(double);
2087: r2 = expm1(r1);
2088: #else
2089: r2 = exp(r1)-1.;
2090: #endif
2091:
2092: fln ( r1 -- r2 ) float-ext f_l_n
2093: r2 = log(r1);
2094:
2095: flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one
2096: ""@i{r2}=ln(@i{r1}+1)""
2097: #ifdef HAVE_LOG1P
2098: extern double
2099: #ifdef NeXT
2100: const
2101: #endif
2102: log1p(double);
2103: r2 = log1p(r1);
2104: #else
2105: r2 = log(r1+1.);
2106: #endif
2107:
2108: flog ( r1 -- r2 ) float-ext f_log
2109: ""The decimal logarithm.""
2110: r2 = log10(r1);
2111:
2112: falog ( r1 -- r2 ) float-ext f_a_log
2113: ""@i{r2}=10**@i{r1}""
2114: extern double pow10(double);
2115: r2 = pow10(r1);
2116:
2117: fsin ( r1 -- r2 ) float-ext f_sine
2118: r2 = sin(r1);
2119:
2120: fsincos ( r1 -- r2 r3 ) float-ext f_sine_cos
2121: ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
2122: r2 = sin(r1);
2123: r3 = cos(r1);
2124:
2125: fsqrt ( r1 -- r2 ) float-ext f_square_root
2126: r2 = sqrt(r1);
2127:
2128: ftan ( r1 -- r2 ) float-ext f_tan
2129: r2 = tan(r1);
2130: :
2131: fsincos f/ ;
2132:
2133: fsinh ( r1 -- r2 ) float-ext f_cinch
2134: r2 = sinh(r1);
2135: :
2136: fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
2137:
2138: fcosh ( r1 -- r2 ) float-ext f_cosh
2139: r2 = cosh(r1);
2140: :
2141: fexp fdup 1/f f+ f2/ ;
2142:
2143: ftanh ( r1 -- r2 ) float-ext f_tan_h
2144: r2 = tanh(r1);
2145: :
2146: f2* fexpm1 fdup 2. d>f f+ f/ ;
2147:
2148: fasinh ( r1 -- r2 ) float-ext f_a_cinch
2149: r2 = asinh(r1);
2150: :
2151: fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
2152:
2153: facosh ( r1 -- r2 ) float-ext f_a_cosh
2154: r2 = acosh(r1);
2155: :
2156: fdup fdup f* 1. d>f f- fsqrt f+ fln ;
2157:
2158: fatanh ( r1 -- r2 ) float-ext f_a_tan_h
2159: r2 = atanh(r1);
2160: :
2161: fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/
2162: r> IF fnegate THEN ;
2163:
2164: sfloats ( n1 -- n2 ) float-ext s_floats
2165: ""@i{n2} is the number of address units of @i{n1}
2166: single-precision IEEE floating-point numbers.""
2167: n2 = n1*sizeof(SFloat);
2168:
2169: dfloats ( n1 -- n2 ) float-ext d_floats
2170: ""@i{n2} is the number of address units of @i{n1}
2171: double-precision IEEE floating-point numbers.""
2172: n2 = n1*sizeof(DFloat);
2173:
2174: sfaligned ( c_addr -- sf_addr ) float-ext s_f_aligned
2175: ""@i{sf-addr} is the first single-float-aligned address greater
2176: than or equal to @i{c-addr}.""
2177: sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
2178: :
2179: [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
2180:
2181: dfaligned ( c_addr -- df_addr ) float-ext d_f_aligned
2182: ""@i{df-addr} is the first double-float-aligned address greater
2183: than or equal to @i{c-addr}.""
2184: df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
2185: :
2186: [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
2187:
2188: v* ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
2189: ""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the
2190: next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
2191: ucount elements.""
2192: r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount);
2193: :
2194: >r swap 2swap swap 0e r> 0 ?DO
2195: dup f@ over + 2swap dup f@ f* f+ over + 2swap
2196: LOOP 2drop 2drop ;
2197:
2198: faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth
2199: ""vy=ra*vx+vy""
2200: faxpy(ra, f_x, nstridex, f_y, nstridey, ucount);
2201: :
2202: >r swap 2swap swap r> 0 ?DO
2203: fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
2204: LOOP 2drop 2drop fdrop ;
2205:
2206: \+
2207:
2208: \ The following words access machine/OS/installation-dependent
2209: \ Gforth internals
2210: \ !! how about environmental queries DIRECT-THREADED,
2211: \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
2212:
2213: \ local variable implementation primitives
2214:
2215: \+glocals
2216:
2217: \g locals
2218:
2219: @local# ( #noffset -- w ) gforth fetch_local_number
2220: w = *(Cell *)(lp+noffset);
2221:
2222: @local0 ( -- w ) new fetch_local_zero
2223: w = ((Cell *)lp)[0];
2224:
2225: @local1 ( -- w ) new fetch_local_four
2226: w = ((Cell *)lp)[1];
2227:
2228: @local2 ( -- w ) new fetch_local_eight
2229: w = ((Cell *)lp)[2];
2230:
2231: @local3 ( -- w ) new fetch_local_twelve
2232: w = ((Cell *)lp)[3];
2233:
2234: \+floating
2235:
2236: f@local# ( #noffset -- r ) gforth f_fetch_local_number
2237: r = *(Float *)(lp+noffset);
2238:
2239: f@local0 ( -- r ) new f_fetch_local_zero
2240: r = ((Float *)lp)[0];
2241:
2242: f@local1 ( -- r ) new f_fetch_local_eight
2243: r = ((Float *)lp)[1];
2244:
2245: \+
2246:
2247: laddr# ( #noffset -- c_addr ) gforth laddr_number
2248: /* this can also be used to implement lp@ */
2249: c_addr = (Char *)(lp+noffset);
2250:
2251: lp+!# ( #noffset -- ) gforth lp_plus_store_number
2252: ""used with negative immediate values it allocates memory on the
2253: local stack, a positive immediate argument drops memory from the local
2254: stack""
2255: lp += noffset;
2256:
2257: lp- ( -- ) new minus_four_lp_plus_store
2258: lp += -sizeof(Cell);
2259:
2260: lp+ ( -- ) new eight_lp_plus_store
2261: lp += sizeof(Float);
2262:
2263: lp+2 ( -- ) new sixteen_lp_plus_store
2264: lp += 2*sizeof(Float);
2265:
2266: lp! ( c_addr -- ) gforth lp_store
2267: lp = (Address)c_addr;
2268:
2269: >l ( w -- ) gforth to_l
2270: lp -= sizeof(Cell);
2271: *(Cell *)lp = w;
2272:
2273: \+floating
2274:
2275: f>l ( r -- ) gforth f_to_l
2276: lp -= sizeof(Float);
2277: *(Float *)lp = r;
2278:
2279: fpick ( u -- r ) gforth
2280: ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""
2281: r = fp[u+1]; /* +1, because update of fp happens before this fragment */
2282: :
2283: floats fp@ + f@ ;
2284:
2285: \+
2286: \+
2287:
2288: \+OS
2289:
2290: \g syslib
2291:
2292: open-lib ( c_addr1 u1 -- u2 ) gforth open_lib
2293: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
2294: #ifndef RTLD_GLOBAL
2295: #define RTLD_GLOBAL 0
2296: #endif
2297: u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
2298: #else
2299: # ifdef _WIN32
2300: u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
2301: # else
2302: #warning Define open-lib!
2303: u2 = 0;
2304: # endif
2305: #endif
2306:
2307: lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym
2308: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
2309: u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
2310: #else
2311: # ifdef _WIN32
2312: u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
2313: # else
2314: #warning Define lib-sym!
2315: u3 = 0;
2316: # endif
2317: #endif
2318:
2319: wcall ( u -- ) gforth
2320: IF_fpTOS(fp[0]=fpTOS);
2321: FP=fp;
2322: sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
2323: fp=FP;
2324: IF_spTOS(spTOS=sp[0];)
2325: IF_fpTOS(fpTOS=fp[0]);
2326:
2327: \+FFCALL
2328:
2329: av-start-void ( c_addr -- ) gforth av_start_void
2330: av_start_void(alist, c_addr);
2331:
2332: av-start-int ( c_addr -- ) gforth av_start_int
2333: av_start_int(alist, c_addr, &irv);
2334:
2335: av-start-float ( c_addr -- ) gforth av_start_float
2336: av_start_float(alist, c_addr, &frv);
2337:
2338: av-start-double ( c_addr -- ) gforth av_start_double
2339: av_start_double(alist, c_addr, &drv);
2340:
2341: av-start-longlong ( c_addr -- ) gforth av_start_longlong
2342: av_start_longlong(alist, c_addr, &llrv);
2343:
2344: av-start-ptr ( c_addr -- ) gforth av_start_ptr
2345: av_start_ptr(alist, c_addr, void*, &prv);
2346:
2347: av-int ( w -- ) gforth av_int
2348: av_int(alist, w);
2349:
2350: av-float ( r -- ) gforth av_float
2351: av_float(alist, r);
2352:
2353: av-double ( r -- ) gforth av_double
2354: av_double(alist, r);
2355:
2356: av-longlong ( d -- ) gforth av_longlong
2357: av_longlong(alist, d);
2358:
2359: av-ptr ( c_addr -- ) gforth av_ptr
2360: av_ptr(alist, void*, c_addr);
2361:
2362: av-int-r ( R:w -- ) gforth av_int_r
2363: av_int(alist, w);
2364:
2365: av-float-r ( -- ) gforth av_float_r
2366: float r = *(Float*)lp;
2367: lp += sizeof(Float);
2368: av_float(alist, r);
2369:
2370: av-double-r ( -- ) gforth av_double_r
2371: double r = *(Float*)lp;
2372: lp += sizeof(Float);
2373: av_double(alist, r);
2374:
2375: av-longlong-r ( R:d -- ) gforth av_longlong_r
2376: av_longlong(alist, d);
2377:
2378: av-ptr-r ( R:c_addr -- ) gforth av_ptr_r
2379: av_ptr(alist, void*, c_addr);
2380:
2381: av-call-void ( -- ) gforth av_call_void
2382: SAVE_REGS
2383: av_call(alist);
2384: REST_REGS
2385:
2386: av-call-int ( -- w ) gforth av_call_int
2387: SAVE_REGS
2388: av_call(alist);
2389: REST_REGS
2390: w = irv;
2391:
2392: av-call-float ( -- r ) gforth av_call_float
2393: SAVE_REGS
2394: av_call(alist);
2395: REST_REGS
2396: r = frv;
2397:
2398: av-call-double ( -- r ) gforth av_call_double
2399: SAVE_REGS
2400: av_call(alist);
2401: REST_REGS
2402: r = drv;
2403:
2404: av-call-longlong ( -- d ) gforth av_call_longlong
2405: SAVE_REGS
2406: av_call(alist);
2407: REST_REGS
2408: d = llrv;
2409:
2410: av-call-ptr ( -- c_addr ) gforth av_call_ptr
2411: SAVE_REGS
2412: av_call(alist);
2413: REST_REGS
2414: c_addr = prv;
2415:
2416: alloc-callback ( a_ip -- c_addr ) gforth alloc_callback
2417: c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip);
2418:
2419: va-start-void ( -- ) gforth va_start_void
2420: va_start_void(clist);
2421:
2422: va-start-int ( -- ) gforth va_start_int
2423: va_start_int(clist);
2424:
2425: va-start-longlong ( -- ) gforth va_start_longlong
2426: va_start_longlong(clist);
2427:
2428: va-start-ptr ( -- ) gforth va_start_ptr
2429: va_start_ptr(clist, (char *));
2430:
2431: va-start-float ( -- ) gforth va_start_float
2432: va_start_float(clist);
2433:
2434: va-start-double ( -- ) gforth va_start_double
2435: va_start_double(clist);
2436:
2437: va-arg-int ( -- w ) gforth va_arg_int
2438: w = va_arg_int(clist);
2439:
2440: va-arg-longlong ( -- d ) gforth va_arg_longlong
2441: d = va_arg_longlong(clist);
2442:
2443: va-arg-ptr ( -- c_addr ) gforth va_arg_ptr
2444: c_addr = (char *)va_arg_ptr(clist,char*);
2445:
2446: va-arg-float ( -- r ) gforth va_arg_float
2447: r = va_arg_float(clist);
2448:
2449: va-arg-double ( -- r ) gforth va_arg_double
2450: r = va_arg_double(clist);
2451:
2452: va-return-void ( -- ) gforth va_return_void
2453: va_return_void(clist);
2454: return 0;
2455:
2456: va-return-int ( w -- ) gforth va_return_int
2457: va_return_int(clist, w);
2458: return 0;
2459:
2460: va-return-ptr ( c_addr -- ) gforth va_return_ptr
2461: va_return_ptr(clist, void *, c_addr);
2462: return 0;
2463:
2464: va-return-longlong ( d -- ) gforth va_return_longlong
2465: va_return_longlong(clist, d);
2466: return 0;
2467:
2468: va-return-float ( r -- ) gforth va_return_float
2469: va_return_float(clist, r);
2470: return 0;
2471:
2472: va-return-double ( r -- ) gforth va_return_double
2473: va_return_double(clist, r);
2474: return 0;
2475:
2476: \+
2477:
2478: \+OLDCALL
2479:
2480: define(`uploop',
2481: `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
2482: define(`_uploop',
2483: `ifelse($1, `$3', `$5',
2484: `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')
2485: \ argflist(argnum): Forth argument list
2486: define(argflist,
2487: `ifelse($1, 0, `',
2488: `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')')
2489: \ argdlist(argnum): declare C's arguments
2490: define(argdlist,
2491: `ifelse($1, 0, `',
2492: `uploop(`_i', 1, $1, `Cell, ', `Cell')')')
2493: \ argclist(argnum): pass C's arguments
2494: define(argclist,
2495: `ifelse($1, 0, `',
2496: `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')
2497: \ icall(argnum)
2498: define(icall,
2499: `icall$1 ( argflist($1)u -- uret ) gforth
2500: uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
2501:
2502: ')
2503: define(fcall,
2504: `fcall$1 ( argflist($1)u -- rret ) gforth
2505: rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
2506:
2507: ')
2508:
2509: \ close ' to keep fontify happy
2510:
2511: uploop(i, 0, 7, `icall(i)')
2512: icall(20)
2513: uploop(i, 0, 7, `fcall(i)')
2514: fcall(20)
2515:
2516: \+
2517: \+
2518:
2519: \g peephole
2520:
2521: \+peephole
2522:
2523: compile-prim1 ( a_prim -- ) gforth compile_prim1
2524: ""compile prim (incl. immargs) at @var{a_prim}""
2525: compile_prim1(a_prim);
2526:
2527: finish-code ( -- ) gforth finish_code
2528: ""Perform delayed steps in code generation (branch resolution, I-cache
2529: flushing).""
2530: IF_spTOS(sp[0]=spTOS); /* workaround for failing to save spTOS
2531: (gcc-2.95.1, gforth-fast --enable-force-reg) */
2532: finish_code();
2533: IF_spTOS(spTOS=sp[0]);
2534:
2535: forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
2536: f = forget_dyncode(c_code);
2537:
2538: decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
2539: ""a_prim is the code address of the primitive that has been
2540: compile_prim1ed to a_code""
2541: a_prim = (Cell *)decompile_code((Label)a_code);
2542:
2543: \ set-next-code and call2 do not appear in images and can be
2544: \ renumbered arbitrarily
2545:
2546: set-next-code ( #w -- ) gforth set_next_code
2547: #ifdef NO_IP
2548: next_code = (Label)w;
2549: #endif
2550:
2551: call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
2552: /* call with explicit return address */
2553: #ifdef NO_IP
2554: INST_TAIL;
2555: JUMP(a_callee);
2556: #else
2557: assert(0);
2558: #endif
2559:
2560: tag-offsets ( -- a_addr ) gforth tag_offsets
2561: extern Cell groups[32];
2562: a_addr = groups;
2563:
2564: \+
2565:
2566: \g static_super
2567:
2568: ifdef(`M4_ENGINE_FAST',
2569: `include(peeprules.vmg)')
2570:
2571: \g end
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>