--- gforth/Attic/primitives 1994/09/08 17:20:10 1.17 +++ gforth/Attic/primitives 1994/09/12 19:00:35 1.18 @@ -70,6 +70,8 @@ undefine(`shift') noop -- fig ; +: + ; lit -- w fig w = (Cell)*ip++; @@ -88,6 +90,8 @@ goto branch; branch -- fig branch: ip = (Xt *)(((int)ip)+(int)*ip); +: + r> dup @ + >r ; \ condbranch(forthname,restline,code) \ this is non-syntactical: code must open a brace that is close by the macro @@ -128,14 +132,14 @@ int index = *rp; /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ /* dependent upon two's complement arithmetic */ int olddiff = index-rp[1]; -#ifndef undefined +#ifdef undefined if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ || (olddiff^n)>=0 /* it is a wrap-around effect */) { #else #ifndef MAXINT #define MAXINT ((1<<(8*sizeof(Cell)-1))-1) #endif -if(((olddiff^MAXINT) >= n) ? ((olddiff+n) >= 0) : ((olddiff+n) < 0)) { +if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) { #endif #ifdef i386 *rp += n; @@ -168,11 +172,15 @@ if (diff>=0 || newdiff<0) { unloop -- core rp += 2; +: + r> rdrop rdrop >r ; (for) ncount -- cmFORTH paren_for /* or (for) = >r -- collides with unloop! */ *--rp = 0; *--rp = ncount; +: + r> swap 0 >r >r >r ; (do) nlimit nstart -- fig paren_do /* or do it in high-level? 0.09/0.23% */ @@ -219,21 +227,34 @@ n = key_query; cr -- fig puts(""); +: + $0A emit ; move c_from c_to ucount -- core memmove(c_to,c_from,ucount); /* make an Ifdef for bsd and others? */ +: + >r 2dup u< IF r> cmove> ELSE r> cmove THEN ; cmove c_from c_to u -- string while (u-- > 0) *c_to++ = *c_from++; +: + bounds ?DO dup c@ I c! 1+ LOOP drop ; cmove> c_from c_to u -- string c_move_up while (u-- > 0) c_to[u] = c_from[u]; +: + dup 0= IF drop 2drop exit THEN + rot over + -rot bounds swap 1- + DO 1- dup c@ I c! -1 +LOOP drop ; fill c_addr u c -- core memset(c_addr,c,u); +: + -rot bounds + ?DO dup I c! LOOP drop ; compare c_addr1 u1 c_addr2 u2 -- n string n = memcmp(c_addr1, c_addr2, u10) n = 1; +: + rot 2dup - >r min swap -text dup + IF rdrop + ELSE drop r@ 0> + IF rdrop -1 + ELSE r> 1 and + THEN + THEN ; -text c_addr1 u c_addr2 -- n new dash_text n = memcmp(c_addr1, c_addr2, u); @@ -250,6 +279,12 @@ if (n<0) n = -1; else if (n>0) n = 1; +: + swap bounds + ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 + ELSE c@ I c@ - unloop THEN -text-flag ; +: -text-flag ( n -- -1/0/1 ) + dup 0< IF drop -1 ELSE 0> IF 1 ELSE 0 THEN THEN ; capscomp c_addr1 u c_addr2 -- n new Char c1, c2; @@ -268,31 +303,48 @@ for (;; u--, c_addr1++, c_addr2++) { break; } } +: + swap bounds + ?DO dup c@ toupper I c@ toupper = WHILE 1+ LOOP drop 0 + ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ; -trailing c_addr u1 -- c_addr u2 string dash_trailing u2 = u1; while (c_addr[u2-1] == ' ') u2--; +: + BEGIN 1- 2dup + c@ bl = WHILE + dup 0= UNTIL ELSE 1+ THEN ; /string c_addr1 u1 n -- c_addr2 u2 string slash_string c_addr2 = c_addr1+n; u2 = u1-n; +: + tuck - >r + r> dup 0< IF - 0 THEN ; + n1 n2 -- n core,fig plus n = n1+n2; - n1 n2 -- n core,fig minus n = n1-n2; +: + negate + ; negate n1 -- n2 core,fig /* use minus as alias */ n2 = -n1; +: + invert 1+ ; 1+ n1 -- n2 core one_plus n2 = n1+1; +: + 1 + ; 1- n1 -- n2 core one_minus n2 = n1-1; +: + 1 - ; max n1 n2 -- n core if (n1 IF swap THEN drop ; abs n1 -- n2 core if (n1<0) n2 = -n1; else n2 = n1; +: + dup 0< IF negate THEN ; * n1 n2 -- n core,fig star n = n1*n2; +: + um* drop ; / n1 n2 -- n core,fig slash n = n1/n2; +: + /mod nip ; mod n1 n2 -- n core n = n1%n2; +: + /mod drop ; /mod n1 n2 -- n3 n4 core slash_mod n4 = n1/n2; n3 = n1%n2; /* !! is this correct? look into C standard! */ +: + >r s>d r> fm/mod ; 2* n1 -- n2 core two_star n2 = 2*n1; +: + dup + ; 2/ n1 -- n2 core two_slash /* !! is this still correct? */ @@ -359,9 +421,18 @@ if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) n3++; n2-=n1; } +: + over >r dup >r abs -rot + dabs rot um/mod + r> 0< IF negate THEN + r> 0< IF swap negate swap THEN ; m* n1 n2 -- d core m_star d = (DCell)n1 * (DCell)n2; +: + 2dup 0< and >r + 2dup swap 0< and >r + um* r> - r> - ; um* u1 u2 -- ud core u_m_star /* use u* as alias */ @@ -373,45 +444,67 @@ u2 = ud%u1; m+ d1 n -- d2 double m_plus d2 = d1+n; +: + s>d d+ ; d+ d1 d2 -- d double,fig d_plus d = d1+d2; +: + >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/ + r> + >r + r> 0< r> r> + swap - ; d- d1 d2 -- d double d_minus d = d1-d2; +: + dnegate d+ ; dnegate d1 -- d2 double /* use dminus as alias */ d2 = -d1; +: + invert swap negate tuck 0= - ; dmax d1 d2 -- d double if (d1 IF 2swap THEN 2drop ; dmin d1 d2 -- d double if (d1>1; +: + dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and + r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ; d>s d -- n double d_to_s /* make this an alias for drop? */ n = d; +: + drop ; and w1 w2 -- w core,fig w = w1&w2; @@ -424,6 +517,8 @@ w = w1^w2; invert w1 -- w2 core w2 = ~w1; +: + -1 xor ; rshift u1 n -- u2 core u2 = u1>>n; @@ -463,6 +558,8 @@ comparisons(du, ud1 ud2, d_u_, ud1, ud2, within u1 u2 u3 -- f core-ext f = FLAG(u1-u2 < u3-u2); +: + over - >r - r> u< ; sp@ -- a_addr fig spat a_addr = sp+1; @@ -529,10 +626,16 @@ dup w -- w w core,fig rot w1 w2 w3 -- w2 w3 w1 core rote -rot w1 w2 w3 -- w3 w1 w2 fig not_rote +: + rot rot ; nip w1 w2 -- w2 core-ext +: + swap drop ; tuck w1 w2 -- w2 w1 w2 core-ext +: + swap over ; ?dup w -- w core question_dupe if (w!=0) { @@ -541,19 +644,33 @@ if (w!=0) { *--sp = w; #endif } +: + dup IF dup THEN ; pick u -- w core-ext w = sp[u+1]; +: + 1+ cells sp@ + @ ; 2drop w1 w2 -- core two_drop +: + drop drop ; 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe +: + over over ; 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over +: + 3 pick 3 pick ; 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap +: + >r -rot r> -rot ; 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double two_rote +: + >r >r 2swap r> r> 2swap ; \ toggle is high-level: 0.11/0.42% @@ -575,10 +692,14 @@ c! c c_addr -- fig cstore 2! w1 w2 a_addr -- core two_store a_addr[0] = w2; a_addr[1] = w1; +: + tuck ! cell+ ! ; 2@ a_addr -- w1 w2 core two_fetch w2 = a_addr[0]; w1 = a_addr[1]; +: + dup cell+ @ swap @ ; d! d a_addr -- double d_store /* !! alignment problems on some machines */ @@ -589,22 +710,36 @@ d = *(DCell *)a_addr; cell+ a_addr1 -- a_addr2 core cell_plus a_addr2 = a_addr1+1; +: + [ cell ] Literal + ; cells n1 -- n2 core n2 = n1 * sizeof(Cell); +: + [ cell ] + [ 2/ dup ] [IF] 2* [THEN] + [ 2/ dup ] [IF] 2* [THEN] + [ 2/ dup ] [IF] 2* [THEN] + [ 2/ dup ] [IF] 2* [THEN] + [ drop ] ; char+ c_addr1 -- c_addr2 core care_plus -c_addr2 = c_addr1+1; +c_addr2 = c_addr1 + 1; +: + 1+ ; chars n1 -- n2 core cares n2 = n1 * sizeof(Char); +: + ; count c_addr1 -- c_addr2 u core u = *c_addr1; c_addr2 = c_addr1+1; +: + dup 1+ swap c@ ; (bye) n -- toolkit-ext paren_bye -deprep_terminal(); return (Label *)n; system c_addr u -- n own @@ -618,7 +753,7 @@ popen c_addr u n -- wfileid own static char* mode[2]={"r","w"}; wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]); -pclose wfileid -- wior own +pclose wfileid -- wior own wior=pclose((FILE *)wfileid); time&date -- nyear nmonth nday nhour nmin nsec facility-ext time_and_date @@ -658,6 +793,13 @@ for (; f83name1 != NULL; f83name1 = f83n strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) break; f83name2=f83name1; +: + BEGIN dup WHILE + >r dup r@ cell+ c@ $1F and = + IF 2dup r@ cell+ char+ capscomp 0= + IF 2drop r> EXIT THEN THEN + r> @ + REPEAT nip nip ; (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind F83Name *f83name1; @@ -673,11 +815,20 @@ while(a_addr != NULL) break; } } +: + BEGIN dup WHILE + 2@ >r >r dup r@ cell+ c@ $1F and = + IF 2dup r@ cell+ char+ capscomp 0= + IF 2drop r> rdrop EXIT THEN THEN + rdrop r> + REPEAT nip nip ; (hashkey) c_addr u1 -- u2 new paren_hashkey u2=0; while(u1--) u2+=(int)toupper(*c_addr++); +: + 0 -rot bounds ?DO I c@ toupper + LOOP ; (hashkey1) c_addr u ubits -- ukey new paren_hashkey1 ""ukey is the hash key for the string c_addr u fitting in ubits bits"" @@ -693,6 +844,18 @@ for (ukey=0; cp>(ubits-rot))) ^ toupper(*cp)) & ((1<r + tuck - 2swap r> 0 2swap bounds + ?DO dup 4 pick lshift swap 3 pick rshift or + I c@ toupper xor + over and LOOP + nip nip nip ; +Create rot-values + 5 c, 0 c, 1 c, 2 c, 3 c, 4 c, 5 c, 5 c, 5 c, 5 c, + 3 c, 5 c, 5 c, 5 c, 5 c, 7 c, 5 c, 5 c, 5 c, 5 c, + 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, + 7 c, 5 c, 5 c, (parse-white) c_addr1 u1 -- c_addr2 u2 new paren_parse_white /* use !isgraph instead of isspace? */ @@ -708,17 +871,22 @@ else { c_addr2 = c_addr1; u2 = 0; } +: + BEGIN dup WHILE over c@ bl <= WHILE 1 /string + REPEAT THEN 2dup + BEGIN dup WHILE over c@ bl > WHILE 1 /string + REPEAT THEN nip - ; close-file wfileid -- wior file close_file wior = FILEIO(fclose((FILE *)wfileid)==EOF); open-file c_addr u ntype -- w2 wior file open_file -w2 = (Cell)fopen(cstr(c_addr, u,1), fileattr[ntype]); +w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]); wior = FILEEXIST(w2 == NULL); create-file c_addr u ntype -- w2 wior file create_file int fd; -fd = creat(cstr(c_addr, u,1), 0644); +fd = creat(cstr(c_addr, u, 1), 0644); if (fd > -1) { w2 = (Cell)fdopen(fd, fileattr[ntype]); assert(w2 != NULL); @@ -730,10 +898,10 @@ if (fd > -1) { } delete-file c_addr u -- wior file delete_file -wior = FILEEXIST(unlink(cstr(c_addr, u,1))); +wior = FILEEXIST(unlink(cstr(c_addr, u, 1))); rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file -char *s1=cstr(c_addr2, u2,1); +char *s1=cstr(c_addr2, u2, 1); wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1)); file-position wfileid -- ud wior file file_position @@ -950,7 +1118,7 @@ r2 = exp(r1); fexpm1 r1 -- r2 float-ext r2 = -#ifdef expm1 +#ifdef HAS_EXPM1 expm1(r1); #else exp(r1)-1; @@ -961,10 +1129,10 @@ r2 = log(r1); flnp1 r1 -- r2 float-ext r2 = -#ifdef log1p +#ifdef HAS_LOG1P log1p(r1); #else - log(r1+1); +log(r1+1); #endif flog r1 -- r2 float-ext @@ -1034,25 +1202,25 @@ c2 = toupper(c1); w = *(Cell *)(lp+(int)(*ip++)); @local0 -- w new fetch_local_zero -w = *(Cell *)(lp+0); +w = *(Cell *)(lp+0*sizeof(Cell)); -@local4 -- w new fetch_local_four -w = *(Cell *)(lp+4); +@local1 -- w new fetch_local_four +w = *(Cell *)(lp+1*sizeof(Cell)); -@local8 -- w new fetch_local_eight -w = *(Cell *)(lp+8); +@local2 -- w new fetch_local_eight +w = *(Cell *)(lp+2*sizeof(Cell)); -@local12 -- w new fetch_local_twelve -w = *(Cell *)(lp+12); +@local3 -- w new fetch_local_twelve +w = *(Cell *)(lp+3*sizeof(Cell)); f@local# -- r new f_fetch_local_number r = *(Float *)(lp+(int)(*ip++)); f@local0 -- r new f_fetch_local_zero -r = *(Float *)(lp+0); +r = *(Float *)(lp+0*sizeof(Float)); -f@local8 -- r new f_fetch_local_eight -r = *(Float *)(lp+8); +f@local1 -- r new f_fetch_local_eight +r = *(Float *)(lp+1*sizeof(Float)); laddr# -- c_addr new laddr_number /* this can also be used to implement lp@ */ @@ -1064,14 +1232,14 @@ local stack, a positive immediate argume stack"" lp += (int)(*ip++); --4lp+! -- new minus_four_lp_plus_store -lp += -4; +lp- -- new minus_four_lp_plus_store +lp += -sizeof(Cell); -8lp+! -- new eight_lp_plus_store -lp += 8; +lp+ -- new eight_lp_plus_store +lp += sizeof(Float); -16lp+! -- new sixteen_lp_plus_store -lp += 16; +lp+2 -- new sixteen_lp_plus_store +lp += 2*sizeof(Float); lp! c_addr -- new lp_store lp = (Address)c_addr; @@ -1085,5 +1253,4 @@ lp -= sizeof(Float); *(Float *)lp = r; up! a_addr -- new up_store -up=(char *)a_addr; -up0=(char *)a_addr; +up0=up=(char *)a_addr;