home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / scherr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  10.6 KB  |  334 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHERR.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       89/05/09
  9. **
  10. ** DESCRIPTION: This module contains the error routines.
  11. ***********************************************************************
  12. ** CHANGES INFORMATION **
  13. *************************
  14. ** REVISION:    $Revision:   1.0  $
  15. ** CHANGER:     $Author:   JAN  $
  16. ** WORKFILE:    $Workfile:   scherr.c  $
  17. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHERR.C_V  $
  18. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHERR.C_V  $
  19. **              
  20. **                 Rev 1.0   12 Oct 1989 11:45:30   JAN
  21. **              Initial revision.
  22. **********************************************************************/
  23. #include "schinc.h"
  24.  
  25. STATIC char *ErrMsg[] = {
  26.     "End of DScheme",
  27.     "Out of memory",
  28.     "Internal error (contact A.Kayser at TUDelft)",
  29.     "Exit",
  30.     "NIL pointer",
  31.     "Hash table allready initialized",
  32.     "Internal: Unknown cell type",
  33.     "EVAL: Not (yet) implemented",
  34.     "EVAL: Wrong argument count",
  35.     "EVAL: Wrong argument type",
  36.     "EVAL: CAR needs a pair as argument",
  37.     "EVAL: CDR needs a pair as argument",
  38.     "EVAL: This is not a self-evaluating atom",
  39.     "EVAL: Can't evaluate this procedure",
  40.     "EVAL: Unknown symbol",
  41.     "EVAL: Evaluation stack overflow",
  42.     "Internal use: Break",
  43.     "IO: Output error (disk or string full)",
  44.     "IO: Read error (port is closed or write-only)",
  45.     "IO: Write error (port is closed or read-only)",
  46.     "IO: Out of port space",
  47.     "IO: port is closed!",
  48.     "IO: Port table allready initialized",
  49.     "IO: Port table is full",
  50.     "IO: File not found",
  51.     "IO: Unput buffer overflow",
  52.     "Parser: DOT encountered in wrong place",
  53.     "Parser: Syntax error",
  54.     "Parser: Premature EOF",
  55.     "Parser: Too many ')'s",
  56.     "Parser: Real numbers don't support binair, octal and hex numbers",
  57.     "Parser: Number expected after +/-",
  58.     "Parser: Quote argument missing",
  59.     "Parser: String too long",
  60.     "Parser: Internal error",
  61.     "Parser: Illegal character encountered",
  62.     "Parser: Illegal character(s) after '#'",
  63.     "Parser: Illegal character in number",
  64.     "Parser: Illegal floating point format",
  65.     "Parser: Only integers may follow '#!'",
  66.     "Timestamp: out of range",
  67.     "Timestamp: syntax error",
  68.     "Timestamp: error in year",
  69.     "Timestamp: error in month",
  70.     "Timestamp: error in day",
  71.     "Timestamp: error in hours",
  72.     "Timestamp: error in minutes",
  73.     "Timestamp: error in seconds",
  74.     "Math: bignumber too big",
  75.     "Math: divide by zero",
  76.     "Math: floating point overflow",
  77.     "Math: bignumber math not present",
  78.     "Math: Floating point error",
  79.     "Parser: 3 octal digits expected in string escape"
  80.     };
  81.  
  82.  
  83. /***************************************************************
  84. ** NAME:        DsNoInitError
  85. ** SYNOPSIS:    void DsNoInitError(function)
  86. **              char *function;     function name
  87. ** DESCRIPTION: called when a DS function is called with the
  88. **              global structure pointing to NIL.
  89. ***************************************************************/
  90. void PASCAL DsNoInitError(function)
  91. CONST char *function;
  92. {
  93.     fprintf(stderr,
  94.             "Function %s is called before initialization of the environment\n",
  95.             function);
  96.     exit(2);
  97. }
  98.  
  99.  
  100. /***************************************************************
  101. ** NAME:        DsRetCode
  102. ** SYNOPSIS:    int DsRetCode();
  103. ** DESCRIPTION: Called by DS??? functions when an error is
  104. **              raised, to clean up the environment and to
  105. **              determine what return code should be given to
  106. **              the application.
  107. ** RETURN:      S_ERROR, if really an error occured.
  108. **              S_END, if the DScheme 'exit' is evaluated.
  109. **              S_OKAY, otherwise.
  110. ***************************************************************/
  111. int PASCAL DsRetCode()
  112. {
  113.     switch(GLOB(errnr))
  114.     {
  115.     case NOERROR: return(S_OKAY);                            /* normal return */
  116.     case ERRXIT:  return(S_END);         /* DScheme has evaluated an "(exit)" */
  117.     default:      DsHandleError();           /* handle error, display message */
  118.                   return(S_ERROR);                  /* got an (serious) error */
  119.     }
  120. }
  121.  
  122.  
  123. /***************************************************************
  124. ** NAME:        DsHandleError
  125. ** SYNOPSIS:    void DsHandleError()
  126. ** DESCRIPTION: This function is called by the reader to display
  127. **              a neat error message.
  128. ** RETURNS:     void
  129. ***************************************************************/
  130. int PASCAL DsHandleError()
  131. {
  132.     int val=GLOB(errfunc)(PGLOBAL,GLOB(errnr),GLOB(erritem));
  133.     GLOB(errnr)=NOERROR;
  134.     return val;
  135. }
  136.  
  137.  
  138. /***************************************************************
  139. ** NAME:        DsMemError
  140. ** SYNOPSIS:    void DsMemError(mes);
  141. ** DESCRIPTION: Signals a memory error to stderr. Called by
  142. **              initialization functions.
  143. ** RETURN:      void
  144. ***************************************************************/
  145. void PASCAL DsMemError(mes)
  146. CONST char *mes;
  147. {
  148.     fprintf(stderr,"DScheme: INIT: no memory for %s\n",mes);
  149.     exit(1);
  150. }
  151.  
  152.  
  153. /***************************************************************
  154. ** NAME:        DsTypError
  155. ** SYNOPSIS:    void DsTypError(q)
  156. **              CELP q;         Argument in error
  157. ** DESCRIPTION: Signals a argument type error. Shorthand for
  158. **              DsError(ERRART,q);
  159. ** RETURN:      void
  160. ***************************************************************/
  161. void PASCAL DsTypError(q)
  162. CELP q;
  163. {
  164.     DsError(ERRART,q);
  165. }
  166.  
  167.  
  168. /***************************************************************
  169. ** NAME:        DsStkError
  170. ** SYNOPSIS:    void DsStkError()
  171. ** DESCRIPTION: Signals a stack error. Shorthand for
  172. **              DsError(ERRSTK,Q_invis);
  173. ** RETURN:      void
  174. ***************************************************************/
  175. void PASCAL DsStkError()
  176. {
  177.     DsVError(ERRSTK);
  178. }
  179.  
  180. /***************************************************************
  181. ** NAME:        DsVError
  182. ** SYNOPSIS:    void DsVError(nr)
  183. **              int nr;
  184. ** DESCRIPTION: Raises error <nr> with a void argument.
  185. **              same as DsError(nr,Q_invis);
  186. ** RETURN:      void
  187. ***************************************************************/
  188. void PASCAL DsVError(nr)
  189. int nr;
  190. {
  191.     DsError(nr,Q_invis);
  192. }
  193.  
  194. /***************************************************************
  195. ** NAME:        DsError
  196. ** SYNOPSIS:    CELP DsError(nr,item);
  197. **              int     nr;       Error number
  198. **              CELP    item;     Item
  199. ** DESCRIPTION: Stores error number in glo->errnr and jmps to
  200. **              glo->err_jmp. (the 'main' function).
  201. ** RETURNS:     Doesn't return to caller!
  202. ***************************************************************/
  203. void PASCAL DsError(err_nr,item)
  204. int err_nr;
  205. CELP item;
  206. {
  207.     if (err_nr==ERRMEM) GLOB(GCflag)=3; /* Garbage Collect a.s.a.p */
  208.     GLOB(errexp)=GLOB(curexp);
  209.     GLOB(erritem)=item;
  210.     GLOB(errnr)=err_nr;
  211.     /* GLOB(errline)=GLOB(inport)->lineno; */
  212.     longjmp(GLOB(err_jmp),1);      /* severe error */
  213. }                               
  214.  
  215.  
  216. /***************************************************************
  217. ** NAME:        DsPError
  218. ** SYNOPSIS:    void DsPError(nr,item);
  219. **              int     nr;       Error number
  220. **              PORT    *item;    Port in error
  221. ** DESCRIPTION: Stores error number in glo->errnr and jmps to
  222. **              glo->err_jmp.
  223. **              Same as DsError, but this one is for port errors
  224. ** RETURNS:     Doesn't return to caller!
  225. ***************************************************************/
  226. void PASCAL DsPError(err_nr,item)
  227. int err_nr;
  228. PORT *item;
  229. {
  230.     DsError(err_nr,DSPRTCEL(item));
  231. }
  232.  
  233.  
  234. /**************************************************************
  235. ** NAME:        DsRepError
  236. ** SYNOPSIS:    int DsRepError(glo,errnr,item)
  237. **              GLOBAL *glo;
  238. **              int errnr;
  239. ** DESCRIPTION: Default error reporter.
  240. ** RETURNS:     error level.
  241. **************************************************************/
  242. int DsRepError(glo,errnr,item)
  243. GLOBAL *glo;
  244. int errnr;
  245. CELP item;
  246. {
  247.     char *errlev;
  248.     char *errmsg;
  249.  
  250.     if (errnr==ERRBREAK)
  251.     {
  252.         DsOuts(glo->errport,"*** BREAK ***\n");
  253.         return(0);
  254.     }
  255.     if (errnr>0)
  256.     {
  257.         switch(DsErrorLevel(errnr))
  258.         {
  259.         case 0 : errlev="** ";   errmsg="Warning";      break;
  260.         case 1 : errlev="*** ";  errmsg="ERROR";        break;
  261.         default: errlev="**** "; errmsg="SEVERE ERROR"; break;
  262.         }
  263.         if (errnr<ERRUSER1)
  264.         {
  265.             DsOutf(glo->errport,"%s%s [%d] at line %l: %s\n",
  266.                 errlev, errmsg, errnr, GLOB(errline), DsErrMsg(errnr));
  267.             if (item!=Q_invis)
  268.                 DsOutf(glo->errport,"%sItem in error: %a\n",errlev, item);
  269.             if (glo->errexp)
  270.                 DsOutf(glo->errport,"%sExpression: %a\n",errlev, glo->errexp);
  271.         }
  272.         else
  273.             DsOutf(glo->errport,"%s%s [%d] at line %l: %p\n",
  274.                 errlev, errmsg, errnr, GLOB(errline), item);
  275.     }
  276.     return(DsErrorLevel(errnr)); /* return error level */
  277. }
  278.  
  279.  
  280. /***************************************************************
  281. ** NAME:        DsErrMsg
  282. ** SYNOPSIS:    char *DsErrMsg(errnr)
  283. **              int errnr;         Error nummer
  284. ** DESCRIPTION: Translates an error number in an error
  285. **              description message.
  286. ** RETURNS:     The error description.
  287. ***************************************************************/
  288. STATIC char * PASCAL DsErrMsg(errnr)
  289. int errnr;
  290. {
  291.     return (errnr<0 || errnr>sizeof(ErrMsg)/sizeof(char *))
  292.            ? "Unknown error: core dumped"
  293.            : ErrMsg[errnr];
  294. }
  295.  
  296.  
  297. /***************************************************************
  298. ** NAME:        DsErrorLevel
  299. ** SYNOPSIS:    int DsErrorLevel(errnr)
  300. **              int errnr;      error number.
  301. ** DESCRIPTION: determines the level of the error.
  302. ** RETURNS:     0=warning: continue evaluation.
  303. **              1=error:   stop evaluation.
  304. **              2=serious: stop WaiterLoop
  305. ***************************************************************/
  306. STATIC int PASCAL DsErrorLevel(errornr)
  307. int errornr;
  308. {
  309.     switch(errornr)
  310.     {
  311.     case NOERROR:                 /* not serious, but must get out of Dscheme */
  312.     case ERRMEM:
  313.     case ERRXIT:
  314.     case ERRINT:
  315.     case ERROUT:
  316.     case ERRIOW:
  317.     case ERRUSER2:
  318.     case ERREOF:   return 2;                       /* close café after an EOF */
  319.     case ERRUSER1: return 0;                                 /* warning level */
  320.     }
  321.     return 1;
  322. }
  323.  
  324.  
  325. void PASCAL DsStrError(typ,str)
  326. int typ;
  327. CONST char *str;
  328. {
  329.     DsError(typ,DsStrCell(str));
  330. }
  331.  
  332.  
  333.  
  334.