home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schext.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-05-14  |  12.5 KB  |  439 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHEXT.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       89/10/21
  9. **                                                                  
  10. ** DESCRIPTION: All the DScheme extended functions are defined here.
  11. ***********************************************************************
  12. ** CHANGES INFORMATION **
  13. *************************
  14. ** REVISION:    $Revision$
  15. ** CHANGER:     $Author$
  16. ** WORKFILE:    $Workfile$
  17. ** LOGFILE:     $Logfile$
  18. ** LOGINFO:     $Log$
  19. **********************************************************************/
  20. #define DEBUG
  21.  
  22. #include "schinc.h"
  23. #include "schdef.h"
  24.  
  25. STATIC CELP CDECL Ds_guenv      __((void));
  26. STATIC CELP CDECL Ds_gsenv      __((void));
  27. STATIC CELP CDECL Ds_gtimer     __((void));
  28. STATIC CELP CDECL Ds_gtime      __((void));
  29. STATIC CELP CDECL Ds_getsym     __((void));
  30. STATIC CELP CDECL Ds_free       __((void));
  31. STATIC CELP CDECL Ds_gettag     __((CELP arg));
  32. STATIC CELP CDECL Ds_war        __((CELP p));
  33. STATIC CELP CDECL Ds_err        __((CELP p));
  34. STATIC CELP CDECL Ds_serr       __((CELP p));
  35. STATIC CELP CDECL Ds_gpenv      __((CELP arg));
  36. STATIC CELP CDECL Ds_strtime    __((CELP p));
  37. STATIC CELP CDECL Ds_timestr    __((CELP p));
  38. STATIC CELP CDECL Ds_nsecs      __((CELP p));
  39. STATIC CELP CDECL Ds_ndays      __((CELP p));
  40. STATIC CELP CDECL Ds_sprmpt     __((CELP arg));
  41. STATIC CELP CDECL Ds_setgc      __((CELP arg));
  42. STATIC CELP CDECL Ds_dumpcell   __((CELP arg));
  43. STATIC CELP CDECL Ds_symbols    __((void));
  44.  
  45.  
  46. static EXTDEF extensions[]=
  47.     {
  48.         {"GET-USER-ENV",    (EXTPROC)Ds_guenv,    0},
  49.         {"GET-SYSTEM-ENV",  (EXTPROC)Ds_gsenv,    0},
  50.         {"GET-TIME",        (EXTPROC)Ds_gtime,    0},
  51.         {"DUMP-GLOBAL",     (EXTPROC)Ds_globals,  0},
  52.         {"GET-SYMBOLS",     (EXTPROC)Ds_getsym,   0},
  53.         {"GET-STATUS",      (EXTPROC)Ds_free,     0},
  54.         {"GET-TIMER",       (EXTPROC)Ds_gtimer,   0},
  55.         {"ERROR",           (EXTPROC)Ds_err,      1, 0},
  56.         {"WARNING",         (EXTPROC)Ds_war,      1, 0},
  57.         {"SERIOUS",         (EXTPROC)Ds_serr,     1, 0},
  58.         {"GET-TAG",         (EXTPROC)Ds_gettag,   1, 0},
  59.         {"GET-PROC-ENV",    (EXTPROC)Ds_gpenv,    1, TYPE_PRC},
  60.         {"TIME->STRING",    (EXTPROC)Ds_timestr,  1, TYPE_TMS},
  61.         {"STRING->TIME",    (EXTPROC)Ds_strtime,  1, TYPE_STR},
  62.         {"NUMBER-OF-SECS",  (EXTPROC)Ds_nsecs,    1, TYPE_INT},
  63.         {"NUMBER-OF-DAYS",  (EXTPROC)Ds_ndays,    1, TYPE_TMS},
  64.         {"TIME->REAL",      (EXTPROC)DsTimeReal,  1, TYPE_TMS},
  65.         {"REAL->TIME",      (EXTPROC)DsRealTime,  1, TYPE_FLT},
  66.         {"SET-PROMPT!",     (EXTPROC)Ds_sprmpt,   1, TYPE_STR},
  67.         {"SET-GC-TRESHOLD!",(EXTPROC)Ds_setgc,    1, TYPE_INT},
  68. #ifdef DEBUG
  69.         {"DUMP-CELL",       (EXTPROC)Ds_dumpcell, 1, 0},
  70.         {"DUMP-SYMBOLS",    (EXTPROC)Ds_symbols,  0},
  71. #endif
  72.         ENDOFLIST
  73.     };
  74.  
  75.  
  76. /***************************************************************
  77. ** NAME:        DSextend                                   [API]
  78. ** SYNOPSIS:    int DSextend(glo)
  79. **              GLOBAL *glo;
  80. ** DESCRIPTION: Initializes and link some extensions to the
  81. **              DScheme system.
  82. ** RETURNS:     S_ERROR, if error occured.
  83. **              S_OKAY otherwise.
  84. ***************************************************************/
  85.                                                                              
  86. int PASCAL DSextend(glo)
  87. GLOBAL *glo;
  88. {
  89.     return(DSmultidef(glo,extensions));        /* link extended functions */
  90. }
  91.  
  92.  
  93. STATIC
  94. CELP Ds_gettag(arg)
  95. CELP arg;
  96. {
  97.     return DSINTCEL(TAG(arg));
  98. }
  99.  
  100. STATIC
  101. CELP Ds_war(arg)
  102. CELP arg;
  103. {
  104.     DSERROR(ERRUSER1,arg);
  105.     return NIL;
  106. }
  107.  
  108.  
  109. STATIC
  110. CELP Ds_err(arg)
  111. CELP arg;
  112. {
  113.     DSERROR(ERRUSER2,arg);
  114.     return NIL;
  115. }
  116.  
  117.  
  118. STATIC
  119. CELP Ds_serr(arg)
  120. CELP arg;
  121. {
  122.     DSERROR(ERRUSER3,arg);
  123.     return NIL;
  124. }
  125.  
  126.  
  127. STATIC
  128. CELP Ds_gpenv(arg)
  129. CELP arg;
  130. {
  131.     return CDRpart(CDRpart(arg));
  132. }
  133.  
  134.  
  135. STATIC
  136. CELP Ds_setgc(arg)
  137. CELP arg;
  138. {
  139.     GLOB(GCtreshold)=CELINT(arg);
  140.     return arg;
  141. }
  142.  
  143. STATIC
  144. CELP Ds_guenv()
  145. {
  146.     return GLOB(curenv);
  147. }
  148.  
  149. STATIC
  150. CELP Ds_gsenv()
  151. {
  152.     return GLOB(sysenv);
  153. }
  154.      
  155. STATIC
  156. CELP Ds_gtimer()
  157. {
  158. #if CLOCKS_PER_SEC>1000
  159.     return DSINTCEL(clock()/(CLOCKS_PER_SEC/1000L));         /* returns milliseconds */
  160. #else
  161.     return DSINTCEL(clock()*((long)(1000L/CLOCKS_PER_SEC))); /* returns milliseconds */
  162. #endif
  163. }
  164.  
  165.  
  166. /***************************************************************
  167. ** NAME:        Ds_gtime
  168. ** SYNOPSIS:    CELP Ds_gtime()
  169. ** DESCRIPTION: Returns the current time.
  170. ** RETURNS:     The time.
  171. ***************************************************************/
  172.  
  173. STATIC
  174. CELP Ds_gtime()
  175. {
  176.     return DsMakeTime(time(NULL));
  177. }
  178.  
  179. STATIC
  180. CELP Ds_strtime(p)
  181. CELP p;
  182. {
  183.     return DsStrTime(STRPpart(p));
  184. }
  185.  
  186. STATIC
  187. CELP Ds_timestr(p)
  188. CELP p;
  189. {
  190.     return DsStrCell(DsTimeStr(p));
  191. }
  192.  
  193. STATIC
  194. CELP Ds_nsecs(p)
  195. CELP p;
  196. {
  197.     return DSINTCEL(60L * (LONG)CELTIM(p).time + (LONG)CELTIM(p).fsec);
  198. }
  199.  
  200.  
  201. STATIC
  202. CELP Ds_ndays(p)
  203. CELP p;
  204. {
  205.     return DSINTCEL(CELTIM(p).date);
  206. }
  207.  
  208.  
  209. STATIC
  210. CELP Ds_sprmpt(arg)
  211. CELP arg;
  212. {
  213.     strcpy(GLOB(prompt),STRPpart(arg));
  214.     return(arg);
  215. }
  216.  
  217.  
  218. /***************************************************************
  219. ** NAME:        Ds_globals
  220. ** SYNOPSIS:    CELP Ds_globals()
  221. ** DESCRIPTION: This function prints the contents of the global
  222. **              table to stdout.
  223. ** RETURN:      Q_invis
  224. ***************************************************************/
  225. STATIC
  226. CELP Ds_globals()
  227. {
  228.     CELP p;
  229.     WORD i, c, c2, c3, c4, c5;
  230.     REAL used, gemuse;
  231.     LONG count, count2, total=sizeof(GLOBAL);
  232.     char buf[255];
  233.  
  234.     count=0L;
  235.     for (p=GLOB(fblk); ISTRUE(p); p=CDRpart(p)) count+=CARIpart(p);
  236.     count+=IP_MAXCONST+1;
  237.     used = (REAL)( 100L * (count-GLOB(freecels))) / (REAL)count ;
  238.     gemuse=used;  /*1*/
  239.     DsOuts(GLOB(errport),
  240.                 "***********************************************************************\n");
  241.     DsOuts(GLOB(errport),
  242.                 "**  DUMP-GLOBAL          MEMORY  ENTRYSIZE    ENTRIES       FREE   USED\n");
  243.     DsOuts(GLOB(errport),
  244.                 "**                    =========  =========  =========  =========  =====\n");
  245.     sprintf(buf,"**  Global structure  %9u          -          -          -      -\n",
  246.                               sizeof(GLOBAL));
  247.     DsOuts(GLOB(errport),buf);
  248.     sprintf(buf,"**  Cell space        %9lu  %9u  %9lu  %9lu  %4.1lf%%\n",
  249.                               (LONG)sizeof(CEL)*count, sizeof(CEL), count,
  250.                               GLOB(freecels), used);
  251.     DsOuts(GLOB(errport),buf);
  252.     total+=(LONG)sizeof(CEL)*count;
  253.     count=0L;
  254.     for (p=GLOB(freel); ISTRUE(p); p=CDRpart(p)) count++;
  255.     if (count!=GLOB(freecels))
  256.         DsOutf(GLOB(errport),"*** ERROR: %d free cells counted.\n",count);
  257.  
  258.     c=0;
  259.     for (i=0;i<GLOB(hashsize);i++)
  260.         if (ISTRUE(GLOB(hashtab)[i])) c++;
  261.     used = (REAL) (100*c) / (REAL) GLOB(hashsize);
  262.     gemuse+=used; /*2*/
  263.     sprintf(buf,"**  Symbol table      %9u  %9u  %9u  %9u  %4.1lf%%\n",
  264.                               (sizeof(*GLOB(hashtab)) * GLOB(hashsize)),
  265.                               sizeof(*GLOB(hashtab)), GLOB(hashsize),
  266.                               GLOB(hashsize)-c, used);
  267.     DsOuts(GLOB(errport),buf);
  268.     total+=(LONG)( sizeof(*GLOB(hashtab)) * GLOB(hashsize) );
  269.  
  270.     c2=c=0;
  271.     for (i=0;i<GLOB(prtnum);i++)
  272.     {
  273.         if (GLOB(ports)[i].dir==FREE) c++;
  274.         else c2++;
  275.     }
  276.     used = (REAL) (100*c2) / (REAL) GLOB(prtnum);
  277.     gemuse+=used; /*3*/
  278.     sprintf(buf,"**  Port table        %9u  %9u  %9u  %9u  %4.1lf%%\n",
  279.                                 (sizeof(PORT)*GLOB(prtnum)),
  280.                                 sizeof(PORT), GLOB(prtnum), c, used);
  281.     DsOuts(GLOB(errport),buf);
  282.     total+=(LONG)(sizeof(PORT)*GLOB(prtnum));
  283.  
  284.     count2=count=0L;
  285.     c=0;
  286.     for (p=GLOB(freestr); ISTRUE(p); p=CDRpart(p))
  287.     {
  288.         c++;
  289.         count+=STRLpart(CARpart(p));
  290.     }
  291.     for (p=GLOB(allostr); ISTRUE(p); p=CDRpart(p))
  292.         count2+=STRLpart(CARpart(p));
  293.     if (GLOB(strsize>0))
  294.     {
  295.         used = (REAL) (100L*(GLOB(strsize)-GLOB(strspace))) / (REAL) GLOB(strsize);
  296.         gemuse+=used; /*5*/
  297.     }
  298.     else used = 0.0;
  299.     sprintf(buf,"**  String space      %9lu  %9u  %9u  %9lu  %4.1lf%%\n",
  300.                               GLOB(strsize), 1, c, GLOB(strspace), used);
  301.     DsOuts(GLOB(errport),buf);
  302.     total+=GLOB(strsize);
  303.     if (count2!=GLOB(strsize))
  304.         DsOutf(GLOB(errport),"*** WARNING: total of string space blocks is %l\n",count2);
  305.     if (count!=GLOB(strspace))
  306.         DsOutf(GLOB(errport),"*** ERROR: %l free characters counted.\n",count);
  307.  
  308.     c=strlen(GLOB(bigbuf));
  309.     if (BIGMAX)
  310.         used = (REAL) (100*c) / (REAL) BIGMAX;
  311.     else
  312.         used = 0.0;
  313.     gemuse+=used; /*6*/
  314.     sprintf(buf,"**  String buffer     %9u  %9u  %9u  %9u  %4.1lf%%\n",
  315.                                   BIGMAX, BIGMAX, 1, c, used);
  316.     DsOuts(GLOB(errport),buf);
  317.     total+=(LONG)(BIGMAX);
  318.  
  319. #ifdef MSDOS 
  320.     c = FP_OFF(GLOB(estack))/sizeof(CELP) - FP_OFF(GLOB(sstack))/sizeof(CELP);
  321.     c2 = FP_OFF(GLOB(stkptr))/sizeof(CELP) - FP_OFF(GLOB(sstack))/sizeof(CELP);
  322. #else
  323.     c = GLOB(estack)-GLOB(sstack);
  324.     c2 = GLOB(stkptr)-GLOB(sstack);
  325. #endif
  326.     used = (c>0) ? (REAL) (100*c2) / (REAL) c : 0.0;
  327.     gemuse+=used; /*7*/
  328.     c3=sizeof(CELP);
  329.     sprintf(buf,"**  Scheme stack      %9u  %9u  %9u  %9u  %4.1lf%%\n",
  330.                                 c3*c, c3, c, c - c2 , used); /* free */
  331.     DsOuts(GLOB(errport),buf);
  332.     total+=(LONG)(sizeof(*GLOB(stkptr))*c);
  333.  
  334.     DsOuts(GLOB(errport),
  335.                 "**                    =========\t\t\t\t\t  =====\n");
  336.     sprintf(buf,"**  Total             %9lu\t\t\t\t\t  %4.1lf%%\n**\n",total, gemuse/7.0);
  337.     DsOuts(GLOB(errport),buf);
  338.  
  339.     c=c2=c3=c4=c5=0;
  340.     for (i=0;i<GLOB(hashsize);i++)
  341.     {
  342.         for (p=GLOB(hashtab[i]); ISTRUE(p); p=CDRpart(p))
  343.             switch(TAG(CARpart(p)))
  344.             {
  345.             case TYPE_SYM:c++;break;    /* symbols */
  346.             case TYPE_EXT:c2++;break;   /* externals */
  347.             case TYPE_PRC:c3++;break;   /* lambda's */
  348.             case TYPE_MAC:c4++;break;   /* macro's */
  349.             case TYPE_KEY:c5++;break;   /* keyword (const) */
  350.             }
  351.     }
  352.     DsOutf(GLOB(errport),"**  Tokens: %d symbols, %d consts, %d macros, %d lambda's, %d externals\n",c,c5,c4,c3,c2);
  353.     DsOutf(GLOB(errport),"**  Error code: %d, item: %a, expression %a\n", GLOB(errnr), GLOB(erritem), GLOB(errexp));
  354.     DsOutf(GLOB(errport),"**  GarbageCollect flag: %d, treshold: %l\n", GLOB(GCflag), GLOB(GCtreshold));
  355.     DsOuts(GLOB(errport),"***********************************************************************\n");
  356.     return (Q_invis);
  357. }
  358.  
  359.  
  360. #ifdef DEBUG
  361. STATIC CELP Ds_dumpcell(p)
  362. CELP p;
  363. {
  364.     fprintf(stderr,"* Address: %lp\n",p);
  365.     if (ISTRUE(p))
  366.     {
  367.         fprintf(stderr,"* TAGpart: %02x\n",TAGpart(p));
  368.         fprintf(stderr,"* GCflags: %02x\n",GCFpart(p));
  369.         fprintf(stderr,"* HexDump: %08lx%08lx\n",INTpart(p),CDRpart(p));
  370.         if (ISCDR(p))
  371.             Ds_dumpcell(CDRpart(p));
  372.     }
  373.     return (Q_invis);
  374. }
  375.  
  376.  
  377. STATIC CELP Ds_symbols()
  378. {
  379.     CELP p;
  380.     int i;
  381.  
  382.     for (i=0;i<GLOB(hashsize);i++)
  383.     {
  384.         if (p=GLOB(hashtab[i]))
  385.         {
  386.             fprintf(stderr,"* [%4d] :", i);
  387.             for (; ISTRUE(p); p=CDRpart(p))
  388.                 fprintf(stderr," %s", STRPpart(CDARpart(p)));
  389.             fprintf(stderr,"\n");
  390.         }
  391.     }
  392.     return (Q_invis);
  393. }
  394. #endif
  395.  
  396.  
  397. /***************************************************************
  398. ** NAME:        Ds_getsym
  399. ** SYNOPSIS:    CELP Ds_getsym()
  400. ** DESCRIPTION: This function gets the contents of the symbol
  401. **              table to GLOB(errport). GetSym is defined for
  402. **              debugging purposes.
  403. ** RETURNS:     List of interned symbols.
  404. ***************************************************************/
  405. STATIC
  406. CELP Ds_getsym()
  407. {
  408.     int i;
  409.     CELP p;
  410.     CELP n=NIL;
  411.  
  412.     for (i=0; i<GLOB(hashsize); i++)
  413.         for (p=GLOB(hashtab[i]);ISTRUE(p);p=CDRpart(p))
  414.             n=DsCons(CARpart(p),n);
  415.     return(n);
  416. }
  417.  
  418.  
  419. /***************************************************************
  420. ** NAME:        Ds_free
  421. ** SYNOPSIS:    CELP Ds_free()
  422. **              CELP cfname;    pointer to cel with fname.
  423. ** DESCRIPTION: Returns the number of free cels, and the number
  424. **              of cels.
  425. ** RETURNS:     A list containing two numbers.
  426. ***************************************************************/
  427. STATIC
  428. CELP Ds_free()
  429. {
  430.     CELP p;
  431.     LONG count;
  432.  
  433.     count=0L;
  434.     for (p=GLOB(fblk); ISTRUE(p); p=CDRpart(p))
  435.         count+=CARIpart(p);                     /* total cells */
  436.     return DsCons(DSINTCEL(count+IP_MAXCONST),DSINTCEL(GLOB(freecels)));
  437. }
  438.  
  439.