[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.1 and 1.7

version 1.1, Fri Feb 11 16:30:46 1994 UTC version 1.7, Wed May 18 17:29:58 1994 UTC
Line 1 
Line 1 
 /*  \ Copyright 1992 by the ANSI figForth Development Group
 $Id$  \
 Copyright 1992 by the ANSI figForth Development Group  \ WARNING: This file is processed by m4. Make sure your identifiers
   \ don't collide with m4's (e.g. by undefining them).
 WARNING: This file is processed by m4. Make sure your identifiers  \
 don't collide with m4's (e.g. by undefining them).  \ This file contains instructions in the following format:
   \
 This file contains instructions in the following format:  \ forth name    stack effect    category        [pronounciation]
   \ [""glossary entry""]
 forth name      stack effect    category        [pronounciation]  \ C code
 [""glossary entry""]  \ [:
 C code  \ Forth code]
 [:  \
 Forth code]  \ The pronounciataion is also used for forming C names.
   \
 The pronounciataion is also used for forming C names.  \ These informations are automagically translated into C-code for the
   \ interpreter and into some other files. The forth name of a word is
 These informations are automagically translated into C-code for the  \ automatically turned into upper case. I hope that your C compiler has
 interpreter and into some other files. The forth name of a word is  \ decent optimization, otherwise the automatically generated code will
 automatically turned into upper case. I hope that your C compiler has  \ be somewhat slow. The Forth version of the code is included for manual
 decent optimization, otherwise the automatically generated code will  \ compilers, so they will need to compile only the important words.
 be somewhat slow. The Forth version of the code is included for manual  \
 compilers, so they will need to compile only the important words.  \ Note that stack pointer adjustment is performed according to stack
   \ effect by automatically generated code and NEXT is automatically
 Note that stack pointer adjustment is performed according to stack  \ appended to the C code. Also, you can use the names in the stack
 effect by automatically generated code and NEXT is automatically  \ effect in the C code. Stack access is automatic. One exception: if
 appended to the C code. Also, you can use the names in the stack  \ your code does not fall through, the results are not stored into the
 effect in the C code. Stack access is automatic. One exception: if  \ stack. Use different names on both sides of the '--', if you change a
 your code does not fall through, the results are not stored into the  \ value (some stores to the stack are optimized away).
 stack. Use different names on both sides of the '--', if you change a  \
 value (some stores to the stack are optimized away).  \ The stack variables have the following types:
   \ name matches  type
 The stack variables have the following types:  \ f.*           Bool
 name matches    type  \ c.*           Char
 f.*             Bool  \ [nw].*                Cell
 c.*             Char  \ u.*           UCell
 [nw].*          Cell  \ d.*           DCell
 u.*             UCell  \ ud.*          UDCell
 d.*             DCell  \ r.*           Float
 ud.*            UDCell  \ a_.*          Cell *
 r.*             Float  \ c_.*          Char *
 a_.*            Cell *  \ f_.*          Float *
 c_.*            Char *  \ df_.*         DFloat *
 f_.*            Float *  \ sf_.*         SFloat *
 df_.*           DFloat *  \ xt.*          XT
 sf_.*           SFloat *  \ wid.*         WID
 xt.*            XT  \ f83name.*     F83Name *
 wid.*           WID  \
 f83name.*       F83Name *  \ In addition the following names can be used:
   \ ip    the instruction pointer
 In addition the following names can be used:  \ sp    the data stack pointer
 ip      the instruction pointer  \ rp    the parameter stack pointer
 sp      the data stack pointer  \ NEXT  executes NEXT
 rp      the parameter stack pointer  \ cfa
 NEXT    executes NEXT  \ NEXT1 executes NEXT1
 cfa  \ FLAG(x)       makes a Forth flag from a C flag
 NEXT1   executes NEXT1  \
 FLAG(x) makes a Forth flag from a C flag  \ Percentages in comments are from Koopmans book: average/maximum use
   \ (taken from four, not very representattive benchmarks)
 Percentages in comments are from Koopmans book: average/maximum use  \
 (taken from four, not very representattive benchmarks)  \ To do:
   \ make sensible error returns for file words
 To do:  \
 make sensible error returns for file words  \ throw execute, cfa and NEXT1 out?
   \ macroize *ip, ip++, *ip++ (pipelining)?
 throw execute, cfa and NEXT1 out?  
 macroize *ip, ip++, *ip++ (pipelining)?  
 */  
   
 /* these m4 macros would collide with identifiers */  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   
Line 77 
Line 74 
 lit     -- w            fig  lit     -- w            fig
 w = (Cell)*ip++;  w = (Cell)*ip++;
   
 /* no clit today */  
   
 execute         xt --           core,fig  execute         xt --           core,fig
 cfa = xt;  cfa = xt;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
Line 183 
Line 178 
 j       -- n            core  j       -- n            core
 n = rp[2];  n = rp[2];
   
 /* digit is high-level: 0/0% */  \ digit is high-level: 0/0%
   
 emit    c --            fig  emit    c --            fig
 putchar(c);  putchar(c);
Line 194 
Line 189 
 /* !! noecho */  /* !! noecho */
 n = key();  n = key();
   
   key?    -- n            fig     key_q
   fflush(stdout);
   n = key_query;
   
 cr      --              fig  cr      --              fig
 puts("");  puts("");
   
 move    c_from c_to ucount --           core  move    c_from c_to ucount --           core
 memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
 /* make an ifdef for bsd and others? */  /* make an Ifdef for bsd and others? */
   
 cmove   c_from c_to u --        string  cmove   c_from c_to u --        string
 while (u-- > 0)  while (u-- > 0)
Line 408 
Line 407 
 lshift  u1 n -- u2              core  lshift  u1 n -- u2              core
   u2 = u1<<n;    u2 = u1<<n;
   
 /* comparisons(prefix, args, prefix, arg1, arg2, wordsets...) */  \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(comparisons,  define(comparisons,
 $1=     $2 -- f         $6      $3equals  $1=     $2 -- f         $6      $3equals
 f = FLAG($4==$5);  f = FLAG($4==$5);
Line 460 
Line 459 
 fp!     f_addr --       new     fp_store  fp!     f_addr --       new     fp_store
 fp = f_addr;  fp = f_addr;
   
 exit    --              core  ;s      --              core    exit
 /* use ;s as alias */  /* use ;s as alias */
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
   
Line 503 
Line 502 
 tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
   
 ?dup    w -- w                  core    question_dupe  ?dup    w -- w                  core    question_dupe
 /* resulting C code suboptimal */  
 /* make -dup an alias */  
 if (w!=0) {  if (w!=0) {
   --sp;    IF_TOS(*sp-- = w;)
 #ifndef USE_TOS  #ifndef USE_TOS
   *sp = w;    *--sp = w;
 #endif  #endif
 }  }
   
Line 525 
Line 522 
   
 2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote  2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote
   
 /* toggle is high-level: 0.11/0.42% */  \ toggle is high-level: 0.11/0.42%
   
 @       a_addr -- w             fig     fetch  @       a_addr -- w             fig     fetch
 w = *a_addr;  w = *a_addr;
Line 591 
Line 588 
 pclose  wfileid -- wior own  pclose  wfileid -- wior own
 wior=pclose((FILE *)wfileid);  wior=pclose((FILE *)wfileid);
   
   time&date       -- nyear nmonth nday nhour nmin nsec    ansi    time_and_date
   struct timeval time1;
   struct timezone zone1;
   struct tm *ltime;
   gettimeofday(&time1,&zone1);
   ltime=localtime(&time1.tv_sec);
   nyear =ltime->tm_year+1900;
   nmonth=ltime->tm_mon;
   nday  =ltime->tm_mday;
   nhour =ltime->tm_hour;
   nmin  =ltime->tm_min;
   nsec  =ltime->tm_sec;
   
   ms      n --    ansi
   struct timeval timeout;
   timeout.tv_sec=n/1000;
   timeout.tv_usec=1000*(n%1000);
   (void)select(0,0,0,0,&timeout);
   
 allocate        u -- a_addr wior        memory  allocate        u -- a_addr wior        memory
 a_addr = (Cell *)malloc(u);  a_addr = (Cell *)malloc(u);
 wior = a_addr==NULL;    /* !! define a return code */  wior = a_addr==NULL;    /* !! Define a return code */
   
 free            a_addr -- wior          memory  free            a_addr -- wior          memory
 free(a_addr);  free(a_addr);
Line 601 
Line 617 
   
 resize          a_addr1 u -- a_addr2 wior       memory  resize          a_addr1 u -- a_addr2 wior       memory
 a_addr2 = realloc(a_addr1, u);  a_addr2 = realloc(a_addr1, u);
 wior = a_addr2==NULL;   /* !! define a return code */  wior = a_addr2==NULL;   /* !! Define a return code */
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
 for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = f83name1->next)
Line 626 
Line 642 
 }  }
   
 close-file      wfileid -- wior file    close_file  close-file      wfileid -- wior file    close_file
 wior = FLAG(fclose((FILE *)wfileid)==EOF);  wior = FILEIO(fclose((FILE *)wfileid)==EOF);
   
 open-file       c_addr u ntype -- w2 wior       file    open_file  open-file       c_addr u ntype -- w2 wior       file    open_file
 char fname[u+1];  char fname[u+1];
 cstr(fname, c_addr, u);  cstr(fname, c_addr, u);
 w2 = (Cell)fopen(fname, fileattr[ntype]);  w2 = (Cell)fopen(fname, fileattr[ntype]);
 wior = FLAG(w2 == NULL);  wior =  FILEEXIST(w2 == NULL);
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- w2 wior       file    create_file
 int     fd;  int     fd;
Line 645 
Line 661 
   wior = 0;    wior = 0;
 } else {  } else {
   assert(fd == -1);    assert(fd == -1);
   wior = fd;    wior = FILEIO(fd);
   w2 = 0;    w2 = 0;
 }  }
   
 delete-file     c_addr u -- wior                file    delete_file  delete-file     c_addr u -- wior                file    delete_file
 char fname[u+1];  char fname[u+1];
 cstr(fname, c_addr, u);  cstr(fname, c_addr, u);
 wior = unlink(fname);  wior = FILEEXIST(unlink(fname));
   
 rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file  rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
 char fname1[u1+1];  char fname1[u1+1];
 char fname2[u2+1];  char fname2[u2+1];
 cstr(fname1, c_addr1, u1);  cstr(fname1, c_addr1, u1);
 cstr(fname2, c_addr2, u2);  cstr(fname2, c_addr2, u2);
 wior = rename(fname1, fname2);  wior = FILEEXIST(rename(fname1, fname2));
   
 file-position   wfileid -- ud wior      file    file_position  file-position   wfileid -- ud wior      file    file_position
 /* !! use tell and lseek? */  /* !! use tell and lseek? */
Line 667 
Line 683 
 wior = 0; /* !! or wior = FLAG(ud<0) */  wior = 0; /* !! or wior = FLAG(ud<0) */
   
 reposition-file ud wfileid -- wior      file    reposition_file  reposition-file ud wfileid -- wior      file    reposition_file
 wior = fseek((FILE *)wfileid, (long)ud, SEEK_SET);  wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET));
   
 file-size       wfileid -- ud wior      file    file_size  file-size       wfileid -- ud wior      file    file_size
 struct stat buf;  struct stat buf;
 wior = fstat(fileno((FILE *)wfileid), &buf);  wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));
 ud = buf.st_size;  ud = buf.st_size;
   
 resize-file     ud wfileid -- wior      file    resize_file  resize-file     ud wfileid -- wior      file    resize_file
 wior = ftruncate(fileno((FILE *)wfileid), (int)ud);  wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud));
   
 read-file       c_addr u1 wfileid -- u2 wior    file    read_file  read-file       c_addr u1 wfileid -- u2 wior    file    read_file
 /* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
 u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);  u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
 wior = FLAG(u2<u1 && ferror((FILE *)wfileid));  wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
 /* !! who performs clearerr((FILE *)wfileid); ? */  /* !! who performs clearerr((FILE *)wfileid); ? */
   
 read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line  read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line
 wior=(Cell)fgets(c_addr,u1+1,(FILE *)wfileid);  wior=(Cell)fgets(c_addr,u1+1,(FILE *)wfileid);
 flag=FLAG(!feof((FILE *)wfileid) && wior);  flag=FLAG(!feof((FILE *)wfileid) && wior);
 wior=FLAG(ferror((FILE *)wfileid)) & flag;  wior=FILEIO(ferror((FILE *)wfileid)) & flag;
 u2=(flag & strlen(c_addr));  u2=(flag & strlen(c_addr));
 u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));  u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
   
Line 694 
Line 710 
 /* !! fwrite does not guarantee enough */  /* !! fwrite does not guarantee enough */
 {  {
   int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);    int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
   wior = FLAG(u2<u1 && ferror((FILE *)wfileid));    wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
 }  }
   
 flush-file      wfileid -- wior         file-ext        flush_file  flush-file      wfileid -- wior         file-ext        flush_file
 wior = fflush((FILE *)wfileid);  wior = FILEIO(fflush((FILE *) wfileid));
   
 comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)  comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
 comparisons(f0, r, f_zero_, r, 0., float, new, float, new)  comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
Line 852 
Line 868 
 fexp            r1 -- r2        float-ext  fexp            r1 -- r2        float-ext
 r2 = exp(r1);  r2 = exp(r1);
   
   fexpm1          r1 -- r2        float-ext
   r2 =
   #ifdef expm1
           expm1(r1);
   #else
           exp(r1)-1;
   #endif
   
 fln             r1 -- r2        float-ext  fln             r1 -- r2        float-ext
 r2 = log(r1);  r2 = log(r1);
   
   flnp1           r1 -- r2        float-ext
   r2 =
   #ifdef log1p
           log1p(r1);
   #else
           log(r1+1);
   #endif
   
 flog            r1 -- r2        float-ext  flog            r1 -- r2        float-ext
 r2 = log10(r1);  r2 = log10(r1);
   
 fsin            r1 -- r2 r3     float-ext  fsin            r1 -- r2        float-ext
   r2 = sin(r1);
   
   fsincos         r1 -- r2 r3     float-ext
 r2 = sin(r1);  r2 = sin(r1);
 r3 = cos(r1);  r3 = cos(r1);
   
Line 868 
Line 903 
 ftan            r1 -- r2        float-ext  ftan            r1 -- r2        float-ext
 r2 = tan(r1);  r2 = tan(r1);
   
 /* The following words access machine/OS/installation-dependent ANSI  \ The following words access machine/OS/installation-dependent ANSI
    figForth internals */  \   figForth internals
 /* !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
    INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 >body           xt -- a_addr    core    to_body  >body           xt -- a_addr    core    to_body
 a_addr = PFA(xt);  a_addr = PFA(xt);
Line 889 
Line 924 
 defining-word-defined */  defining-word-defined */
 a_addr = DOES_CODE(xt);  a_addr = DOES_CODE(xt);
   
 code-address!           c_addr xt --    new     code_address_store  code-address!           n xt -- new     code_address_store
 ""Creates a code field with code address c_addr at xt""  ""Creates a code field with code address c_addr at xt""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, symbols[CF(n)]);
   CACHE_FLUSH(xt,PFA(0));
   
 does-code!      a_addr xt --            new     does_code_store  does-code!      a_addr xt --            new     does_code_store
 ""creates a code field at xt for a defining-word-defined word; a_addr  ""creates a code field at xt for a defining-word-defined word; a_addr
 is the start of the Forth code after DOES>""  is the start of the Forth code after DOES>""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
   CACHE_FLUSH(xt,PFA(0));
   
 does-handler!   a_addr --       new     does_jump_store  does-handler!   a_addr --       new     does_jump_store
 ""creates a DOES>-handler at address a_addr. a_addr usually points  ""creates a DOES>-handler at address a_addr. a_addr usually points
 just behind a DOES>.""  just behind a DOES>.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
   CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
   
 /does-handler   -- n    new     slash_does_handler  /does-handler   -- n    new     slash_does_handler
 ""the size of a does-handler (includes possible padding)""  ""the size of a does-handler (includes possible padding)""
Line 911 
Line 949 
 toupper c1 -- c2        new  toupper c1 -- c2        new
 c2 = toupper(c1);  c2 = toupper(c1);
   
 /* local variable implementation primitives */  \ local variable implementation primitives
 @local#         -- w    new     fetch_local_number  @local#         -- w    new     fetch_local_number
 w = *(Cell *)(lp+(int)(*ip++));  w = *(Cell *)(lp+(int)(*ip++));
   
Line 938 
Line 976 
 f>l     r --    new     f_to_l  f>l     r --    new     f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
   up!     a_addr --       new     up_store
   up=a_addr;

Generate output suitable for use with a patch program
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.7
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help