--- gforth/prim	2001/05/01 13:35:42	1.82
+++ gforth/prim	2002/10/27 09:57:11	1.101
@@ -53,15 +53,18 @@
 \ your code does not fall through, the results are not stored into the
 \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).
-\ 
-\ 
+\
+\ For superinstructions the syntax is:
+\
+\ forth-name [/ c-name] = forth-name forth-name ...
+\
 \ 
 \ The stack variables have the following types:
 \ 
 \ name matches	type
 \ f.*		Bool
 \ c.*		Char
-\ [nw].*		Cell
+\ [nw].*	Cell
 \ u.*		UCell
 \ d.*		DCell
 \ ud.*		UDCell
@@ -101,6 +104,7 @@
 \E inst-stream  stack-prefix #
 \E 
 \E set-current
+\E store-optimization on
 
 \ 
 \ 
@@ -132,6 +136,8 @@ undefine(`index')
 undefine(`shift')
 undefine(`symbols')
 
+\g control
+
 noop	( -- )		gforth
 :
  ;
@@ -177,8 +183,9 @@ SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
 define(condbranch,
 $1 ( `#'ndisp $2 ) $3
 $4	SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
-TAIL;
+INST_TAIL;
 }
+SUPER_CONTINUE;
 $5
 
 \+glocals
@@ -186,8 +193,9 @@ $5
 $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number
 $4    lp += nlocals;
 SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
-TAIL;
+INST_TAIL;
 }
+SUPER_CONTINUE;
 
 \+
 )
@@ -212,8 +220,9 @@ if (f==0) {
   sp++;
   IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
-  TAIL;
+  INST_TAIL;
 }
+SUPER_CONTINUE;
 
 ?dup-0=-?branch	( #ndisp f -- )	new	question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
@@ -226,6 +235,7 @@ if (f!=0) {
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT;
 }
+SUPER_CONTINUE;
 
 \+
 \f[THEN]
@@ -305,8 +315,9 @@ nlimit=0;
 (?do)	( #ndisp nlimit nstart -- R:nlimit R:nstart )	gforth	paren_question_do
 if (nstart == nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
-    TAIL;
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
   2dup =
   IF   r> swap rot >r >r
@@ -320,8 +331,9 @@ if (nstart == nlimit) {
 (+do)	( #ndisp nlimit nstart -- R:nlimit R:nstart )	gforth	paren_plus_do
 if (nstart >= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
-    TAIL;
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -335,8 +347,9 @@ if (nstart >= nlimit) {
 (u+do)	( #ndisp ulimit ustart -- R:ulimit R:ustart )	gforth	paren_u_plus_do
 if (ustart >= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
-    TAIL;
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -350,8 +363,9 @@ if (ustart >= ulimit) {
 (-do)	( #ndisp nlimit nstart -- R:nlimit R:nstart )	gforth	paren_minus_do
 if (nstart <= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
-    TAIL;
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -365,8 +379,9 @@ if (nstart <= nlimit) {
 (u-do)	( #ndisp ulimit ustart -- R:ulimit R:ustart )	gforth	paren_u_minus_do
 if (ustart <= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
-    TAIL;
+    INST_TAIL;
 }
+SUPER_CONTINUE;
 :
  swap 2dup
  r> swap >r swap >r
@@ -409,6 +424,8 @@ k	( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
 
 \ digit is high-level: 0/0%
 
+\g strings
+
 move	( c_from c_to ucount -- )		core
 ""Copy the contents of @i{ucount} aus at @i{c-from} to
 @i{c-to}. @code{move} works correctly even if the two areas overlap.""
@@ -518,6 +535,8 @@ u2 = u1-n;
 :
  tuck - >r + r> dup 0< IF  - 0  THEN ;
 
+\g arith
+
 +	( n1 n2 -- n )		core	plus
 n = n1+n2;
 
@@ -915,6 +934,8 @@ f = FLAG(u1-u2 < u3-u2);
 :
  over - >r - r> u< ;
 
+\g internal
+
 sp@	( -- a_addr )		gforth		sp_fetch
 a_addr = sp+1;
 
@@ -942,6 +963,8 @@ fp = f_addr;
 ""The primitive compiled by @code{EXIT}.""
 SET_IP((Xt *)w);
 
+\g stack
+
 >r	( w -- R:w )		core	to_r
 :
  (>r) ;
@@ -1337,7 +1360,6 @@ a_addr = (Cell *)DOES_CODE(xt);
 code-address!	( c_addr xt -- )		gforth	code_address_store
 ""Create a code field with code address @i{c-addr} at @i{xt}.""
 MAKE_CF(xt, c_addr);
-CACHE_FLUSH(xt,(size_t)PFA(0));
 :
     ! ;
 
@@ -1345,7 +1367,6 @@ does-code!	( a_addr xt -- )		gforth	does
 ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
 @i{a-addr} is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);
-CACHE_FLUSH(xt,(size_t)PFA(0));
 :
     dodoes: over ! cell+ ! ;
 
@@ -1353,7 +1374,6 @@ does-handler!	( a_addr -- )	gforth	does_
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
 @i{a-addr} points just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);
-CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :
     drop ;
 
@@ -1381,6 +1401,8 @@ n=1;
 
 \f[THEN]
 
+\g hostos
+
 key-file	( wfileid -- n )		gforth	paren_key_file
 #ifdef HAS_FILE
 fflush(stdout);
@@ -1454,7 +1476,7 @@ c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
 
 open-pipe	( c_addr u wfam -- wfileid wior )	gforth	open_pipe
-wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */
+wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
 
 close-pipe	( wfileid -- wretval wior )		gforth	close_pipe
@@ -1596,7 +1618,7 @@ if (wior)
   clearerr((FILE *)wfileid);
 
 read-line	( c_addr u1 wfileid -- u2 flag wior )	file	read_line
-""this is only for backward compatibility""
+/* this may one day be replaced with : read-line (read-line) nip ; */
 Cell c;
 flag=-1;
 for(u2=0; u2<u1; u2++)
@@ -1672,6 +1694,8 @@ else {
 \+
 \+floating
 
+\g floating
+
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
 
@@ -1684,12 +1708,8 @@ r = d;
 #endif
 
 f>d	( r -- d )		float	f_to_d
-#ifdef BUGGY_LONG_LONG
-d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
-d.lo = r-ldexp((Float)d.hi,CELL_BITS);
-#else
-d = r;
-#endif
+extern DCell double2ll(Float r);
+d = double2ll(r);
 
 f!	( r f_addr -- )	float	f_store
 ""Store @i{r} into the float at address @i{f-addr}.""
@@ -1779,8 +1799,9 @@ floor	( r1 -- r2 )	float
 /* !! unclear wording */
 r2 = floor(r1);
 
-fround	( r1 -- r2 )	float	f_round
-""Round to the nearest integral value.""
+(fround)	( r1 -- r2 )	gforth	paren_f_round
+""Round to the nearest integral value.  Primitive variant (unused)""
+/* !! eliminate this as primitive? */
 /* !! unclear wording */
 #ifdef HAVE_RINT
 r2 = rint(r1);
@@ -2143,7 +2164,7 @@ Variable UP
 wcall	( u -- )	gforth
 IF_fpTOS(fp[0]=fpTOS);
 FP=fp;
-sp=(Cell*)(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
+sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;
 IF_spTOS(spTOS=sp[0];)
 IF_fpTOS(fpTOS=fp[0]);
@@ -2151,10 +2172,23 @@ IF_fpTOS(fpTOS=fp[0]);
 \+file
 
 open-dir	( c_addr u -- wdirid wior )	gforth	open_dir
+""Open the directory specified by @i{c-addr, u}
+and return @i{dir-id} for futher access to it.""
 wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
 wior =  IOR(wdirid == 0);
 
 read-dir	( c_addr u1 wdirid -- u2 flag wior )	gforth	read_dir
+""Attempt to read the next entry from the directory specified
+by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}. 
+If the attempt fails because there is no more entries,
+@i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
+If the attempt to read the next entry fails because of any other reason, 
+return @i{ior}<>0.
+If the attempt succeeds, store file name to the buffer at @i{c-addr}
+and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.
+If the length of the file name is greater than @i{u1}, 
+store first @i{u1} characters from file name into the buffer and
+indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
 struct dirent * dent;
 dent = readdir((DIR *)wdirid);
 wior = 0;
@@ -2172,6 +2206,7 @@ if(dent == NULL) {
 }
 
 close-dir	( wdirid -- wior )	gforth	close_dir
+""Close the directory specified by @i{dir-id}.""
 wior = IOR(closedir((DIR *)wdirid));
 
 filename-match	( c_addr1 u1 c_addr2 u2 -- flag )	gforth	match_file
@@ -2353,6 +2388,8 @@ while(a_addr != NULL)
 
 \+peephole
 
+\g peephole
+
 primtable	( -- wprimtable )	new
 ""wprimtable is a table containing the xts of the primitives indexed
 by sequence-number in prim (for use in prepare-peephole-table).""
@@ -2369,14 +2406,263 @@ peephole-opt	( xt1 xt2 wpeeptable -- xt
 they cannot be combined, xt is 0.""
 xt = peephole_opt(xt1, xt2, wpeeptable);
 
-call	( #a_callee -- R:a_retaddr )
+call	( #a_callee -- R:a_retaddr )	new
 ""Call callee (a variant of docol with inline argument).""
+#ifdef DEBUG
+    {
+      CFA_TO_NAME((((Cell *)a_callee)-2));
+      fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
+	      len,name);
+    }
+#endif
 a_retaddr = (Cell *)IP;
 SET_IP((Xt *)a_callee);
 
-useraddr	( #u -- a_addr )
+useraddr	( #u -- a_addr )	new
 a_addr = (Cell *)(up+u);
 
+compile-prim ( xt1 -- xt2 )	new	compile_prim
+xt2 = (Xt)compile_prim((Label)xt1);
+
+\ lit@ / lit_fetch = lit @
+
+lit@		( #a_addr -- w ) new	lit_fetch
+w = *a_addr;
+
+lit-perform	( #a_addr -- )	new	lit_perform
+ip=IP;
+SUPER_END;
+EXEC(*(Xt *)a_addr);
+
+\ lit+ / lit_plus = lit +
+
+lit+	( n1 #n2 -- n )		new	lit_plus
+n=n1+n2;
+
+does-exec ( #a_cfa -- R:nest a_pfa )	new	does_exec
+a_pfa = PFA(a_cfa);
+nest = (Cell)ip;
+IF_spTOS(spTOS = sp[0]);
+#ifdef DEBUG
+    {
+      CFA_TO_NAME(a_cfa);
+      fprintf(stderr,"%08lx: does %08lx %.*s\n",
+	      (Cell)ip,(Cell)a_cfa,len,name);
+    }
+#endif
+SET_IP(DOES_CODE1(a_cfa));
+
+abranch-lp+!# ( #a_target #nlocals -- )	gforth	abranch_lp_plus_store_number
+/* this will probably not be used */
+lp += nlocals;
+SET_IP((Xt *)a_target);
+
+\+
+
+abranch	( #a_target -- )	gforth
+SET_IP((Xt *)a_target);
+:
+ r> @ >r ;
+
+\ acondbranch(forthname,stackeffect,restline,code,forthcode)
+\ this is non-syntactical: code must open a brace that is closed by the macro
+define(acondbranch,
+$1 ( `#'a_target $2 ) $3
+$4	SET_IP((Xt *)a_target);
+INST_TAIL;
+}
+SUPER_CONTINUE;
+$5
+
+\+glocals
+
+$1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
+$4    lp += nlocals;
+SET_IP((Xt *)a_target);
+INST_TAIL;
+}
+SUPER_CONTINUE;
+
+\+
+)
+
+acondbranch(a?branch,f --,f83	aquestion_branch,
+if (f==0) {
+,:
+ 0= dup     \ !f !f \ !! still uses relative addresses
+ r> dup @   \ !f !f IP branchoffset
+ rot and +  \ !f IP|IP+branchoffset
+ swap 0= cell and + \ IP''
+ >r ;)
+
+\ we don't need an lp_plus_store version of the ?dup-stuff, because it
+\ is only used in if's (yet)
+
+\+xconds
+
+a?dup-?branch	( #a_target f -- f )	new	aquestion_dupe_question_branch
+""The run-time procedure compiled by @code{?DUP-IF}.""
+if (f==0) {
+  sp++;
+  IF_spTOS(spTOS = sp[0]);
+  SET_IP((Xt *)a_target);
+  INST_TAIL;
+}
+SUPER_CONTINUE;
+
+a?dup-0=-?branch ( #a_target f -- ) new	aquestion_dupe_zero_equals_question_branch
+""The run-time procedure compiled by @code{?DUP-0=-IF}.""
+/* the approach taken here of declaring the word as having the stack
+effect ( f -- ) and correcting for it in the branch-taken case costs a
+few cycles in that case, but is easy to convert to a CONDBRANCH
+invocation */
+if (f!=0) {
+  sp--;
+  SET_IP((Xt *)a_target);
+  NEXT;
+}
+SUPER_CONTINUE;
+
+\+
+\f[THEN]
+\fhas? skiploopprims 0= [IF]
+
+acondbranch(a(next),R:n1 -- R:n2,cmFORTH	aparen_next,
+n2=n1-1;
+if (n1) {
+,:
+ r> r> dup 1- >r
+ IF @ >r ELSE cell+ >r THEN ;)
+
+acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth	aparen_loop,
+n2=n1+1;
+if (n2 != nlimit) {
+,:
+ r> r> 1+ r> 2dup =
+ IF >r 1- >r cell+ >r
+ ELSE >r >r @ >r THEN ;)
+
+acondbranch(a(+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_plus_loop,
+/* !! check this thoroughly */
+/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
+/* dependent upon two's complement arithmetic */
+Cell olddiff = n1-nlimit;
+n2=n1+n;	
+if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
+    || (olddiff^n)>=0          /* it is a wrap-around effect */) {
+,:
+ r> swap
+ r> r> 2dup - >r
+ 2 pick r@ + r@ xor 0< 0=
+ 3 pick r> xor 0< 0= or
+ IF    >r + >r @ >r
+ ELSE  >r >r drop cell+ >r THEN ;)
+
+\+xconds
+
+acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,
+UCell olddiff = n1-nlimit;
+n2=n1-u;
+if (olddiff>u) {
+,)
+
+acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth	aparen_symmetric_plus_loop,
+""The run-time procedure compiled by S+LOOP. It loops until the index
+crosses the boundary between limit and limit-sign(n). I.e. a symmetric
+version of (+LOOP).""
+/* !! check this thoroughly */
+Cell diff = n1-nlimit;
+Cell newdiff = diff+n;
+if (n<0) {
+    diff = -diff;
+    newdiff = -newdiff;
+}
+n2=n1+n;
+if (diff>=0 || newdiff<0) {
+,)
+
+a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_question_do
+if (nstart == nlimit) {
+    SET_IP((Xt *)a_target);
+    INST_TAIL;
+}
+SUPER_CONTINUE;
+:
+  2dup =
+  IF   r> swap rot >r >r
+       @ >r
+  ELSE r> swap rot >r >r
+       cell+ >r
+  THEN ;				\ --> CORE-EXT
+
+\+xconds
+
+a(+do)	( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_plus_do
+if (nstart >= nlimit) {
+    SET_IP((Xt *)a_target);
+    INST_TAIL;
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ >=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(u+do)	( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth	aparen_u_plus_do
+if (ustart >= ulimit) {
+    SET_IP((Xt *)a_target);
+    INST_TAIL;
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ u>=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(-do)	( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth	aparen_minus_do
+if (nstart <= nlimit) {
+    SET_IP((Xt *)a_target);
+    INST_TAIL;
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ <=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+a(u-do)	( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth	aparen_u_minus_do
+if (ustart <= ulimit) {
+    SET_IP((Xt *)a_target);
+    INST_TAIL;
+}
+SUPER_CONTINUE;
+:
+ swap 2dup
+ r> swap >r swap >r
+ u<=
+ IF
+     @
+ ELSE
+     cell+
+ THEN  >r ;
+
+\+
+
 include(peeprules.vmg)
 
 \+