home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schtst.c < prev   
Encoding:
C/C++ Source or Header  |  1991-05-14  |  4.3 KB  |  153 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHTST.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       88/02/29
  9. **
  10. ** DESCRIPTION: Test main module for the SCHEME system.
  11. **              Contains dummy "main".
  12. ***********************************************************************
  13. ** CHANGES INFORMATION **
  14. *************************
  15. ** REVISION:    $Revision:   1.0  $
  16. ** CHANGER:     $Author:   ALFRED  $
  17. ** WORKFILE:    $Workfile:   schtst.c  $
  18. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHTST.C_V  $
  19. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHTST.C_V  $
  20. **              
  21. **                 Rev 1.0   12 Oct 1989 11:45:14   ALFRED
  22. **              Initial revision.
  23. **********************************************************************/
  24. #include <fcntl.h>
  25. #ifndef UNIX
  26. #include <io.h>
  27. #endif
  28. #include "schinc.h"         /* needed for DScheme.lib */
  29.  
  30. STATIC void PASCAL werror  __((CONST char *mes));
  31. STATIC void PASCAL quit    __((int ret_code));
  32.  
  33. /***************************************************************
  34. ** NAME:        main
  35. ** SYNOPSIS:    void main(argc,argv)
  36. **              int argc;
  37. **              char **argv;
  38. ** DESCRIPTION: Initializes the SCHEME system for a test drive
  39. ** RETURNS:     Error code
  40. ** SEE ALSO:    Scheme
  41. ***************************************************************/
  42. GLOBAL *job1=NIL;
  43.  
  44. void main(argc,argv)
  45. int argc;
  46. char **argv;
  47. {
  48.     LONG numcels;
  49.  
  50.     numcels=6550L; /*default*/
  51. #ifndef MSDOS
  52.     setvbuf(stdin,NULL,_IONBF,0);/*force immediate flushing of each character */
  53.     setvbuf(stdout,NULL,_IONBF,0); /* stderr is already unbufferd */
  54. #endif
  55.     info();
  56.     if (argc==2)
  57.     {
  58.         numcels=atol(argv[1]);
  59.         if (numcels==0)
  60.             werror("Error: first argument must be a number.\nUsage: 'DScheme <number>' or 'DScheme'\n");
  61.     }
  62.     if (DSinit(&job1, S_NUMCEL,    numcels,
  63.                       S_STRING,    10000,
  64.                       S_STACK,     8000,
  65.                       S_HASHSIZE,  997,
  66.                       S_PROMPT,    "\nDS=> ",
  67.                       S_CTRLC,
  68.                       0)==S_OKAY)
  69.     {
  70.         if (DSmath(job1)!=S_OKAY ||
  71. /*          DSutinit(job1)!=S_OKAY ||     * Uncomment this if utlib is needed */
  72.             DSextend(job1)!=S_OKAY)
  73.             werror("Errors detected while initializing DScheme\n");
  74.         DScheme(job1);
  75.     }
  76.     quit(0);
  77. }
  78.  
  79.  
  80. /***************************************************************
  81. ** NAME:        DSGCmessage
  82. ** SYNOPSIS:    void DSGCmessage(global,mesnr)
  83. **              GLOBAL *global; Pointer to environment
  84. **              int mesnr;      Message nummer
  85. ** DESCRIPTION: To be supplied by the user. This function is
  86. **              called by the garbage collector to indicate its
  87. **              progress. Mesnr can be: GCstart,GCrun and GSstop
  88. **              These are defined in scheme.h
  89. ** RETURNS:     void
  90. ***************************************************************/
  91. void PASCAL DSGCmessage(nr)
  92. int nr;
  93. {
  94. #ifndef GCDEBUG
  95.     static int smiley='\\';
  96.     if (nr==GCstop)         /* end of GC? */
  97.         putchar(' ');
  98.     else
  99.     {
  100.         putchar(smiley);
  101.         smiley ^= '\\'^'/';
  102.     }
  103.     putchar('\b');
  104. #else
  105.     static LONG lastfree;
  106.     switch(nr)
  107.     {
  108.     case GCstart:
  109.         lastfree=GLOB(freecels);
  110.         DsOuts((GLOB(soutport),"\n*** Garbage Collecting ***           ");
  111.         break;
  112.  
  113.     case GCrun:
  114.         if (GLOB(freecels)>lastfree)
  115.             DsOutf( (GLOB(soutport),
  116.                     "\r*** GC: %ld cells released ***       ",
  117.                     GLOB(freecels)-lastfree);
  118.         break;
  119.  
  120.     case GCstop:
  121.         if (GLOB(freecels)>lastfree)
  122.             DsOutf( (GLOB(soutport),
  123.                     "\r*** GC: %ld cells released ***       \n",
  124.                     GLOB(freecels)-lastfree);
  125.         else
  126.             DsOuts( (GLOB(soutport),
  127.                     "\r*** GC: No garbage found! ***        \n");
  128.         break;
  129.     }
  130. #endif
  131. }
  132.  
  133.  
  134. STATIC void PASCAL werror(mes)
  135. CONST char *mes;
  136. {
  137.     fprintf(stderr,"SCHTST: %s\n",mes);
  138.     quit(1);
  139. }
  140.  
  141.  
  142. STATIC void PASCAL quit(ret_code)
  143. int ret_code;
  144. {
  145.     if (job1)
  146.     {
  147.         DsOutf(job1->soutport,"Back to %s\n",SYSTEEM);
  148.         DSclose(&job1);
  149.     }
  150.     exit(ret_code);
  151. }
  152.  
  153.