home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / scheme.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-05-14  |  28.7 KB  |  818 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHEME.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       88/10/05
  9. **
  10. ** DESCRIPTION: Main module for the SCHEME system. Contains Scheme
  11. **              starter, café and waiters. This module contains
  12. **              also the error function(s) and the memory
  13. **              functions.
  14. ** HISTORY:     Version:     1.1
  15. **              Completion:  89/03/21
  16. **              Author:      Alfred Kayser
  17. **              Changes:     Added new-café & waiter, eval-stack,
  18. **                           call/cc. Replaced yac and lex by (very)
  19. **                           fast code in schrdr.c
  20. **              Version:     1.2
  21. **              Completion:  89/05/25
  22. **              Author:      Alfred Kayser
  23. **              Description: Added Garbage Collector, Kernel functions
  24. **                           'precompiled', compiled in small model
  25. **                           with far pointers to cells and S-stack.
  26. **                           Completed kernel functions. Rewrite of
  27. **                           initglobal. Cleanup error handling, des-
  28. **                           ripting string now outside the scheme.lib
  29. **                           Rewritten timestamp functions.
  30. **              Version:     1.3
  31. **              Completion:  89/05/25
  32. **              Author:      Alfred Kayser
  33. **              Description: Some beauty changes. Added macro system.
  34. **                           Added string space. Debugged GC.
  35. **              Version:     1.4
  36. **              Completion:  89/08/16
  37. **              Author:      Alfred Kayser
  38. **              Description: Cleaned up API interface.
  39. **                           Removed some bugs from the SCHBIG module.
  40. **              Version:     1.5
  41. **              Completion:  89/11/11
  42. **              Author:      Alfred Kayser
  43. **              Description: Cleaned interface for external definitions
  44. **                           New TAG numbering, implemented LET,LET*
  45. **                           LETREC and DO. Renamed all function names
  46. **                           according new DNPAP standards.
  47. **              Version:     1.5.3
  48. **              Completion:  90/10/26
  49. **              Author:      Alfred Kayser
  50. **              Description: Small and little cleanups.
  51. **                           Found some ways to optimize code in both
  52. **                           speed and size.
  53. **              Version:     1.5.4
  54. **              Completion:  90/11/09
  55. **              Author:      Alfred Kayser
  56. **              Description: Small and little cleanups.
  57. **                           Found again some ways to optimize code
  58. **                           in both speed and size.
  59. **                           Removed bug introduced by 1.5.3:
  60. **                           Argument count check wrong.
  61. **                           Defined new functions: Append & Append!
  62. **              Version:     1.5.5
  63. **              Completion:  91/03/08
  64. **              Author:      Alfred Kayser
  65. **              Description: Used one Cons less in argument lists.
  66. **                           Define now also works at the beginning
  67. **                           of the body. The one cons less means about
  68. **                           10% speed improvement!!
  69. ***********************************************************************
  70. ** PVCS INFORMATION **
  71. **********************
  72. ** REVISION:    $Revision: 1.5.5  $
  73. ** CHANGER:     $Author:   ALFRED  $
  74. ** WORKFILE:    $Workfile: $
  75. ** LOGFILE:     $Logfile:  $
  76. ** LOGINFO:     $Log:      $
  77. **********************************************************************/
  78. #include "schinc.h"
  79. #include "schprc.h"
  80.  
  81. #ifdef FIXEDGLO
  82.  GLOBAL DsGlo;
  83. #else
  84.  GLOBAL *DsGlo;         /* The only global variable in this system */
  85. #endif                  /* contains all other globals.             */
  86.  
  87. CELP Q_true;
  88. CELP Q_invis;
  89. CELP item;
  90.  
  91. #ifdef INLINE
  92. CELP _tmp_p
  93. #endif
  94.  
  95. int toupper __((int c));
  96. STATIC GLOBAL * PASCAL DsNewGlobal  __((void));
  97. STATIC void PASCAL DsIniEStack      __((int));
  98. STATIC void PASCAL DsIniEnvironment __((void));
  99. STATIC void PASCAL DsIniHash        __((int));
  100. STATIC void PASCAL DsSetStdPorts    __((PORT *, PORT *, PORT *));
  101. STATIC void PASCAL DsIniKey         __((CELP, int, int, char *));
  102. STATIC void PASCAL DsIniConst       __((void));
  103. STATIC void CDECL  DsCtrlHandler    __((int));
  104.  
  105. /***************************************************************
  106. ** NAME:        DSinit                                     [API]
  107. ** SYNOPSIS:    int DSinit(Gloptr, {codenr, val,} 0 );
  108. **              GLOBAL **gloptr pointer to the global struct.
  109. **              int    codenr;  Argument code nr
  110. **              ???    val;     Argument value (can be of any
  111. **                              type.
  112. ** DESCRIPTION: DSinit reads and evaluates the data and programs
  113. **              found in the INPORT and puts the results in the
  114. **              OUTPORT. INPORT and OUTPORT are defined via the
  115. **              PORT functions. These can be strings or files.
  116. **
  117. **              Arguments are passed in a special way. It is not
  118. **              needed to pas all arguments.
  119. **
  120. **              Codenr:      Type:   Description:
  121. **               S_INPORT    *PORT   Pointer to input port
  122. **               S_OUTPORT   *PORT   Pointer to output port
  123. **               S_NUMCEL    int     Number of cells to allocate
  124. **               S_HASHSIZE  int     Size of hashtable (should
  125. **                                   be a prime.)
  126. ** RETURNS:     S_ARGERR, if a error in the arguments was found.
  127. **              S_ERROR, if a DScheme error was signalled.
  128. **              S_OKAY, otherwise.
  129. ** SEE ALSO:    DSfopen, DSinitport
  130. ***************************************************************/
  131. extern EXTDEF extensions[];
  132. int DSinit(global VAR_ARGS)
  133. GLOBAL ** global; 
  134. VAR_DCL
  135. {
  136.     unsigned int val, hashsize, numport, stack, strings,
  137.                  numbuf, bufsize, bigbuf, verb;
  138.     LONG numcel;
  139.     va_list va;
  140.     PORT *inport,*outport,*errport;
  141.     char *prompt=NIL;
  142.     ERRFUN errfun=NIL;
  143.  
  144. #ifndef FIXEDGLO
  145.     DsGlo = *global;
  146. #else
  147.     global;         /* not used */
  148. #endif
  149.     bufsize=IOBUFSIZE;
  150.     if (PGLOBAL==NULL || GLOB(magic)!=COOKIE)          /* Not yet initialized */
  151.     {
  152.         numcel=6550L;                         /* begin to allocate 6550 cells */
  153.         strings=10000;
  154.         stack=10000;
  155.         hashsize=997;                                              /* initial */
  156.         bigbuf=2048;
  157.         numport=8;
  158.         numbuf=4;
  159.         prompt="\nDS>";
  160.     }
  161.     else                               /* restart: don't allocate extra cells */
  162.     {
  163.         numbuf=stack=strings=hashsize=numport=bigbuf=0;
  164.         numcel=0L;
  165.     }
  166.     inport=NIL;                                                   /* defaults */
  167.     outport=NIL;
  168.     errport=NIL;
  169.     verb = -1;
  170.  
  171.     VAR_START(va,global);
  172.     while ((val = va_arg(va,int))!=0)                     /* handle arguments */
  173.     {
  174.          switch(val)
  175.          {
  176.          case S_INPORT :  inport   = va_arg(va, PORT *); break;
  177.          case S_OUTPORT:  outport  = va_arg(va, PORT *); break;
  178.          case S_ERRPORT:  errport  = va_arg(va, PORT *); break;
  179.          case S_STDIN  :  inport   = GLOB(sinport);      break;
  180.          case S_STDOUT :  outport  = GLOB(soutport);     break;
  181.          case S_STDERR :  errport  = GLOB(serrport);     break;
  182.          case S_STRING :  strings  = va_arg(va, int);    break;
  183.          case S_STACK  :  stack    = va_arg(va, int);    break;
  184.          case S_NUMPORT:  numport  = va_arg(va, int);    break;
  185.          case S_NUMCEL :  numcel   = va_arg(va, LONG);    break;
  186.          case S_HASHSIZE: hashsize = va_arg(va, int);    break;
  187.          case S_BIGBUF :  bigbuf   = va_arg(va, int);    break;
  188.          case S_BUFFERS:  numbuf   = va_arg(va, int);
  189.                           bufsize  = va_arg(va, int);    break;
  190.          case S_PROMPT :  prompt   = va_arg(va, char *); break;
  191.          case S_VERBOSE:  verb     = va_arg(va, int);    break;
  192.          case S_CTRLC  :  if (signal(SIGINT,DsCtrlHandler)==SIG_ERR)
  193.                                return(S_ERROR);
  194.                           break;
  195.          case S_ERRFUN :  errfun   = va_arg(va, ERRFUN); break;
  196.          default: return(S_ARGERR);                     /* error in arguments */
  197.          }
  198.     }
  199.     va_end(va);
  200.  
  201.     if (PGLOBAL==NIL || GLOB(magic)!=COOKIE)           /* Not yet initialized */
  202.     {
  203. #ifndef FIXEDGLO
  204.         DsGlo=DsNewGlobal();
  205.         *global=DsGlo;                                /* make known to caller */
  206. #else
  207.         DsNewGlobal();
  208.         *global=&DsGlo;                               /* make known to caller */
  209. #endif
  210.         if (errfun) GLOB(errfunc)=errfun;
  211.         if (!GLOB(errfunc)) GLOB(errfunc)=DsRepError;/* Default error handler */
  212.         if (setjmp(GLOB(err_jmp)))  /* If error somewhere in init jmp to here */
  213.         {
  214.             DsHandleError();
  215.             return(S_ERROR);
  216.         }
  217.         DsIniPorts(numport,bigbuf,numbuf,bufsize);
  218.         DsStdPorts();                            /* initialize standard ports */
  219.         DsIniEStack(stack);
  220.         DsIniParser();
  221.         DsIniHash(hashsize);
  222.         DsIniCells(numcel);
  223.         DsIniBuf(strings);
  224.         DsIniEnvironment();
  225.         DsTraceInit();
  226.     }
  227.     else
  228.     {
  229.         if (setjmp(GLOB(err_jmp)))  /* If error somewhere in init jmp to here */
  230.         {
  231.             DsHandleError();
  232.             return(S_ERROR);
  233.         }
  234.         if (numcel) DsIniCells(numcel);                /* allocate more cells */
  235.         if (strings) DsIniBuf(strings);           /* resize more string space */
  236.     }
  237.     if (prompt!=NIL) strcpy(GLOB(prompt),prompt);
  238.     DsSetStdPorts(inport,outport,errport);
  239.     if (verb!=-1) GLOB(verbose)=(BYTE)verb;
  240.     return(S_OKAY);
  241. }
  242.  
  243.  
  244.  
  245. /***************************************************************
  246. ** NAME:        DSclose                                    [API]
  247. ** SYNOPSIS:    int DSclose(glo)
  248. **              GLOBAL **glo     pointer to the environment.
  249. ** DESCRIPTION: DSclose closes all open I/O ports.
  250. **              It is not considered a serious error if glo is
  251. **              NIL.
  252. ** RETURNS:     S_ERROR, if global is NIL.
  253. **              S_OKAY, otherwise.
  254. ***************************************************************/
  255. int PASCAL DSclose(global)
  256. GLOBAL **global;
  257. {
  258.     int i;
  259.     CELP p,q;
  260.  
  261. #ifndef FIXEDGLO
  262.     DsGlo = *global;
  263. #endif
  264.     signal(SIGINT,SIG_DFL);            /* restore interrupt handler */
  265.     if (PGLOBAL!=NIL)                  /* global exist? */
  266.     {
  267.         for (i=0;i<GLOB(prtnum);i++)   /* close all ports */
  268.             DsClosePort(GLOB(ports+i));
  269.         /* ... free all allocated memory ... */
  270.         /* Free all string space blocks */
  271.         for (q=GLOB(allostr); ISTRUE(q); q=CDRpart(q))
  272.             free(STRPpart(CARpart(q))); /* free this block */
  273.  
  274.         /* Free all cell blocks */
  275.         q=GLOB(fblk);
  276.         while (ISTRUE(q))
  277.         {
  278.             p=CDRpart(q);                /* get pointer to next block */
  279.             FFREE(q);                    /* free this block */
  280.             q=p;                         /* point to next block */
  281.         }
  282.         FFREE(GLOB(sstack));
  283.         free(GLOB(hashtab));
  284.         free(GLOB(bigbuf));
  285.         free(GLOB(ports));
  286. #ifndef FIXEDGLO    
  287.         free(DsGlo);
  288.         *global=DsGlo=NIL;
  289. #endif
  290.         return(S_OKAY);
  291.     }
  292.     else
  293.         return(S_ERROR);
  294. }
  295.  
  296.  
  297. /***************************************************************
  298. ** NAME:        DScheme                                    [API]
  299. ** SYNOPSIS:    int DScheme(global);
  300. **              GLOBAL *global     pointer to the environment.
  301. ** DESCRIPTION: Scheme reads and evaluates the data and programs
  302. **              found in the INPORT and puts the results in the
  303. **              OUTPORT.
  304. ** RETURNS:     S_ERROR, if error occured in DScheme.
  305. **              S_END, otherwise (even if "exit" is evaluated).
  306. ***************************************************************/
  307. int PASCAL DScheme(global)
  308. GLOBAL * global;                         /* pointer to the global environment */
  309. {
  310.     SETGLOB(global,"DScheme");                 /* test and set global pointer */
  311.     return DsWaiter();                                        /* start waiter */
  312. }
  313.  
  314.  
  315. /***************************************************************
  316. ** NAME:        DSextdef                                   [API]
  317. ** SYNOPSIS:    int DSextdef(glo,extdef)
  318. **              GLOBAL *glo     pointer to the environment.
  319. **              EXTDEF *extdef  external procedure def record.
  320. ** DESCRIPTION: Links an external (user supplied) C-function in
  321. **              the DScheme environment.
  322. ** RETURN:      S_ERROR, if an error occured.
  323. **              S_OKAY, otherwise.
  324. ***************************************************************/
  325. int PASCAL DSextdef(global, extdef)
  326. GLOBAL *global;
  327. EXTDEF *extdef;
  328. {
  329.     CELP ext;
  330.  
  331.     SETGLOB(global,"DSextdef");                /* test and set global pointer */
  332.     if (setjmp(GLOB(err_jmp)))   /* If error somewhere in extdef jump to here */
  333.         return(DsRetCode());
  334.     ext=DsInsExt(strupr(extdef->name));
  335.     TAGpart(ext)=TYPE_EXT;
  336.     CELEXT(ext)=extdef;
  337.     return(S_OKAY);
  338. }
  339.  
  340.  
  341. /***************************************************************
  342. ** NAME:        DSmultidef                                 [API]
  343. ** SYNOPSIS:    int DSmultidef(glo,extdef)
  344. **              GLOBAL *glo     pointer to the environment.
  345. **              EXTDEF *extdef  array of external procedures.
  346. ** DESCRIPTION: Links multiple external (user supplied)
  347. **              C-functions in the DScheme environment.
  348. ** RETURN:      S_ERROR, if an error occured.
  349. **              S_OKAY, otherwise.
  350. ***************************************************************/
  351. int PASCAL DSmultidef(glo,extens)
  352. GLOBAL *glo;
  353. EXTDEF *extens;
  354. {
  355.     SETGLOB(glo,"DSmultidef");                 /* test and set global pointer */
  356.     if (setjmp(GLOB(err_jmp)))   /* If error somewhere in extdef jump to here */
  357.         return(DsRetCode());
  358.     DsFuncDef(extens);
  359.     return(S_OKAY);
  360. }
  361.  
  362.  
  363. /***************************************************************
  364. ** NAME:        DsFuncDef
  365. ** SYNOPSIS:    void DsFuncDef(extdef)
  366. **              EXTDEF *extdef  array of external procedures.
  367. ** DESCRIPTION: Links multiple external (user supplied)
  368. **              C-functions in the DScheme environment.
  369. **              Internal Use Only.
  370. ** RETURN:      void
  371. ** SEE:         DSmultidef
  372. ***************************************************************/
  373.  
  374. void PASCAL DsFuncDef(extens)
  375. EXTDEF *extens;
  376. {
  377.     CELP ext;
  378.     while (extens->name!=NULL)
  379.     {
  380.         ext=DsInsExt(strupr(extens->name)); /* insert name in symbol table */
  381.         TAGpart(ext)=TYPE_EXT;
  382.         CELEXT(ext)=extens++;               /* define it */
  383.     }
  384. }
  385.  
  386.  
  387. /***************************************************************
  388. ** NAME:        DSeval                                     [API]
  389. ** SYNOPSIS:    int DSeval(glo,object, result)
  390. **              GLOBAL *glo;    pointer to the environment.
  391. **              CELP object;    object to evaluate
  392. **              CELP **result;  result value
  393. ** DESCRIPTION: Evaluates a DScheme object in the environment
  394. **              pointed to by glo.
  395. ** RETURN:      S_ERROR, if an error occured.
  396. **              S_END, if the DScheme 'exit' is evaluated.
  397. **              S_OKAY, otherwise.
  398. ***************************************************************/
  399. int PASCAL DSeval(global,object,presult)
  400. GLOBAL *global;
  401. CELP object;
  402. CELP *presult;
  403. {
  404.     SETGLOB(global,"DSeval");                 /* test and set global pointer */
  405.     *presult=NIL;
  406.     if (setjmp(GLOB(err_jmp)))   /* If error somewhere in extdef jump to here */
  407.         return(DsRetCode());
  408.     *presult=DsEval(object);
  409.     return(S_OKAY);
  410. }
  411.  
  412.  
  413. /***************************************************************
  414. ** NAME:        DSread                                     [API]
  415. ** SYNOPSIS:    int DSread(glo, port, result)
  416. **              GLOBAL *glo;    pointer to the environment.
  417. **              PORT *port;     Port to read from
  418. **              CELP **result;  result value
  419. ** DESCRIPTION: Reads a DScheme object in the environment
  420. **              pointed to by glo. if <port> is NULL, the read
  421. **              will be done from glo->inport.
  422. ** RETURN:      S_ERROR, if an error occured.
  423. **              S_OKAY, otherwise.
  424. ***************************************************************/
  425. int PASCAL DSread(global,port,presult)
  426. GLOBAL *global;
  427. PORT *port;
  428. CELP *presult;
  429. {
  430.     SETGLOB(global,"DSread");                  /* test and set global pointer */
  431.     *presult=NIL;
  432.     if (setjmp(GLOB(err_jmp)))   /* If error somewhere in extdef jump to here */
  433.         return(DsRetCode());
  434.     *presult=DsRead(port?port:GLOB(inport));
  435.     return(S_OKAY);
  436. }
  437.  
  438.  
  439.  
  440. /***************************************************************
  441. ** NAME:        DSinitport                                 [API]
  442. ** SYNOPSIS:    int DSinitport(global, pport, mode, stream,
  443. **                             inputp, outputp, closep)
  444. **              GLOBAL *global;
  445. **              PORT **port;    Pointer to new port.
  446. **              int mode;
  447. **              void *stream;
  448. **              INP_FUN inputp;
  449. **              OUT_FUN outputp;
  450. **              CLO_FUN closep;
  451. ** DESCRIPTION: Request for a IO port.
  452. **              Finds an empty port slot in the global port
  453. **              resources and initializes it.
  454. **              Calls noinit_error when global is NIL.
  455. ** RETURNS:     S_ERROR, if an error occured.
  456. **              S_OKAY, otherwise.
  457. ***************************************************************/
  458. int PASCAL DSinitport(global,pport,mode,stream,inputp,outputp,closep)
  459. GLOBAL *global;
  460. PORT **pport;
  461. int mode;
  462. UNTYPE *stream;
  463. INP_FUN inputp;
  464. OUT_FUN outputp;
  465. CTL_FUN closep;
  466. {
  467.     SETGLOB(global,"DSinitport");              /* test and set global pointer */
  468.     *pport=NIL;
  469.     if (setjmp(GLOB(err_jmp)))   /* If error somewhere in extdef jump to here */
  470.         return(DsRetCode());
  471.     *pport = (PORT *)DsInitPort(mode,stream,inputp,outputp,closep);
  472.     return(S_OKAY);
  473. }
  474.  
  475.  
  476. /***************************************************************
  477. ** NAME:        DSfopen                                    [API]
  478. ** SYNOPSIS:    int DSfopen(global, pport, name, mode);
  479. **              GLOBAL *global;
  480. **              PORT **pport;   pointer to new port.
  481. **              char *name;     name of file to be opened.
  482. **              int   mode;     filemode
  483. ** DESCRIPTION: Opens a SCHEME port (standard file port)
  484. **              mode can be READMODE, WRITMODE or READWRIT.
  485. **              Calls noinit_error when global is NIL.
  486. ** RETURNS:     S_ERROR, if an error occured.
  487. **              S_OKAY, otherwise.
  488. ***************************************************************/
  489. int PASCAL DSfopen(global, pport, fname, mode)
  490. GLOBAL *global;
  491. PORT **pport;
  492. CONST char *fname;
  493. int   mode;
  494. {
  495.     SETGLOB(global,"DSfopen");                 /* test and set global pointer */
  496.     *pport=NIL;
  497.     if (setjmp(GLOB(err_jmp)))   /* If error somewhere in extdef jump to here */
  498.         return(DsRetCode());
  499.     *pport=DsFOpen(fname,mode);
  500.     return(S_OKAY);
  501. }
  502.  
  503.  
  504. /***************************************************************
  505. ** NAME:        DsWaiter
  506. ** SYNOPSIS:    int DsWaiter();
  507. ** DESCRIPTION: This function is called by the Scheme system
  508. **              to Read-Eval-Print each element of the input
  509. **              stream and print it at the output
  510. ** RETURNS:     S_END, end of REP loop,
  511. **              S_ERROR error occurred.
  512. ***************************************************************/
  513. int CDECL DsWaiter()
  514. {
  515.     CELPP   oldstk;
  516.     CELP    curenv;
  517.     jmp_buf oldjmp;
  518.     int     level=0;
  519.  
  520. #ifdef GCPORTS
  521.     PUSH( DsCons( DSPRTCEL(GLOB(errport)),          /* keep ports save for GC */
  522.                   DsCons( DSPRTCEL(GLOB(inport)),
  523.                           DSPRTCEL(GLOB(outport)))));
  524. #endif
  525.     curenv = GLOB(curenv);
  526.     oldstk = GLOB(stkptr);
  527.     memcpy (oldjmp,GLOB(err_jmp),sizeof(oldjmp));      /* save return address */
  528.     setjmp (GLOB(err_jmp));                /* return here when error occurres */
  529.     if (GLOB(errnr)!=NOERROR)
  530.     {
  531.         GLOB(stkptr) = oldstk;                         /* reset stack pointer */
  532.         if (GLOB(errnr)==ERRXIT)
  533.             level=1;                                         /* a normal exit */
  534.         else
  535.         {
  536.             level=DsHandleError();          /* Call user defined errorhandler */
  537.             if ( ISTYP(GLOB(erritem),TYPE_PRT)        /* or error in IO port? */
  538.             && ( (CELPRT(GLOB(erritem))==GLOB(inport))    /* IO port is stdin */
  539.                 || (CELPRT(GLOB(erritem))==GLOB(outport))))      /* or stdout */
  540.                 level=2;                      /* Can't go on with these ports */
  541.             if (level==1) level=0;         /* warnings and errors are handled */
  542.         GLOB(curenv)=curenv;
  543.         GLOB(evaldepth)=0;
  544.         }   
  545.     }
  546.     while (level==0)                 /* as long as no critical error occurred */
  547.     {
  548.         if (GLOB(verbose))
  549.         {
  550.             DsOuts(GLOB(outport),GLOB(prompt));
  551.             DsFlushPort(GLOB(outport));
  552.         }
  553.         item=DsRead(GLOB(inport));                 /* read an item from stdin */
  554.         if (item==Q_eof) DSVERROR(ERRXIT);                    /* end of input */
  555.         item=DsEval(item);                                     /* evaluate it */
  556.         curenv = GLOB(curenv);                   /* Lock onto new environment */
  557.         if (GLOB(verbose))
  558.             DsOutc(GLOB(outport),item,TRUE);
  559.     }
  560. #ifdef GCPORTS
  561.     POP;                                               /* reset stack (ports) */
  562. #endif
  563.     memcpy(GLOB(err_jmp),oldjmp,sizeof(oldjmp));     /* restore old jmp adres */
  564.     return level==2 ? S_ERROR : S_END;                  /* end of this waiter */
  565. }
  566.  
  567.  
  568.  
  569. /***************************************************************
  570. ** NAME:        DsNewGlobal
  571. ** SYNOPSIS:    GLOBAL *DsNewGlobal;
  572. ** DESCRIPTION: Allocates a new block of global variables.
  573. **              Calls DsError when out of memory.
  574. ** RETURNS:     pointer to new global variables block.
  575. ***************************************************************/
  576. STATIC
  577. GLOBAL * PASCAL DsNewGlobal()
  578. {
  579.     GLOBAL *gp;
  580. #ifndef FIXEDGLO
  581.     GETMEM(gp,GLOBAL,sizeof(GLOBAL),"Global Structure");
  582. #else
  583.     gp=&DsGlo;
  584. #endif
  585.     memset(gp,0,sizeof(GLOBAL));
  586.     gp->verbose = TRUE;
  587.     gp->magic   = COOKIE;
  588.     return(gp);
  589. }
  590.  
  591.  
  592. /*****************************************************************
  593. ** NAME:        DsIniEStack
  594. ** SYNOPSIS:    void DsIniEStack(size);
  595. **              int size;
  596. ** DESCRIPTION: Initializes the evaluator stack.
  597. ** RETURNS:     void
  598. *****************************************************************/
  599. STATIC
  600. void PASCAL DsIniEStack(size)
  601. int size;
  602. {
  603.     if (GLOB(sstack)!=NIL)
  604.         FFREE(GLOB(sstack));
  605.     GLOB(sstack)=(CELPP)FARMALLOC(size, CELP);
  606.     if (ISNIL(GLOB(sstack)))
  607.         DsMemError("S-stack");
  608.     GLOB(stkptr)=GLOB(sstack);                           /* stackptr at begin */
  609.     GLOB(estack)=GLOB(sstack)+size;                           /* end of stack */
  610. }
  611.  
  612.  
  613. /*****************************************************************
  614. ** NAME:        DsIniEnvironment
  615. ** SYNOPSIS:    void DsIniEnvironment();
  616. ** DESCRIPTION: Initializes the system & user environment space.
  617. ** RETURNS:     void
  618. *****************************************************************/
  619. STATIC
  620. void PASCAL DsIniEnvironment()
  621. {
  622.     if (ISNIL(GLOB(sysenv)))
  623.     {
  624.         GLOB(sysenv) = DsCons1(DsCons1(NIL));
  625.         GLOB(curenv) = GLOB(sysenv);
  626.         GLOB(topexp) = NIL;
  627.         GLOB(curexp) = NIL;
  628.         DsIniConst();                            /* init constants after init */
  629.         DsIniIO();
  630.     }
  631. }
  632.  
  633.  
  634.  
  635. /*****************************************************************
  636. ** NAME:        DsIniHash
  637. ** SYNOPSIS:    void DsIniHash(hashsize)
  638. **              int hashsize;
  639. ** DESCRIPTION: Initializes the hashtable.
  640. ** RETURNS:     void
  641. *****************************************************************/
  642. STATIC
  643. void PASCAL DsIniHash(hashsize)
  644. int hashsize;
  645. {
  646.     int i;
  647.  
  648.     if (hashsize>0)
  649.     {
  650.         if (GLOB(hashtab)!=NULL)
  651.             DSVERROR(ERRHASH);
  652.         GETMEM(GLOB(hashtab),CELP,(1+hashsize)*sizeof(CELP),"Hash Table");
  653.         GLOB(hashsize)=hashsize;
  654.         for (i=0;i<hashsize;i++)
  655.            GLOB(hashtab)[i]=NIL;
  656.     }
  657. }
  658.  
  659.  
  660. /*****************************************************************
  661. ** NAME:        DsSetStdPorts
  662. ** SYNOPSIS:    void DsSetStdPorts(inport,outport,errport)
  663. **              PORT *inport,*outport,*errport;
  664. ** DESCRIPTION: Initializes the standard IO ports.
  665. **              If no other ports are given, and no ports are
  666. **              opened, then the standard in, out and err-ports
  667. **              are opened.
  668. ** RETURNS:     void
  669. *****************************************************************/
  670. STATIC
  671. void PASCAL DsSetStdPorts(inport,outport,errport)
  672. PORT *inport,*outport,*errport;
  673. {
  674.     if (inport!=NIL)
  675.     {
  676.         DsClosePort(GLOB(inport));
  677.         GLOB(inport)=inport;                                /* store new port */
  678.     }
  679.     if (outport!=NIL)
  680.     {
  681.         DsClosePort(GLOB(outport));                        /* close old ports */
  682.         GLOB(outport)=outport;                           /* install new ports */
  683.     }
  684.     if (errport!=NIL)
  685.     {
  686.         DsClosePort(GLOB(errport));                        /* close old ports */
  687.         GLOB(errport)=errport;                           /* install new ports */
  688.     }
  689.     if (GLOB(inport)==NIL)
  690.         GLOB(inport)=GLOB(sinport);
  691.     if (GLOB(outport)==NIL)                /* no port defined => use standard */
  692.         GLOB(outport)=GLOB(soutport);
  693.     if (GLOB(errport)==NIL)                /* no port defined => use standard */
  694.         GLOB(errport)=GLOB(serrport);
  695. }
  696.  
  697.  
  698. /***************************************************************
  699. ** NAME:        DsIniConst
  700. ** SYNOPSIS:    void DsIniConst(void);
  701. ** DESCRIPTION: Initializes all the kernel functions and links
  702. **              them to the system environment.
  703. ** RETURNS:     void
  704. ***************************************************************/
  705. STATIC
  706. void PASCAL DsIniConst()
  707. {
  708.     int i;
  709.     CELP newkey;
  710.  
  711.     GLOB(conssym)=FARMALLOC(IP_MAXCONST, CELP);
  712.     if (ISNIL(GLOB(conssym)))
  713.         DsMemError("Constant Symbol space");
  714.     for (i=0;i<IP_MAXCONST;i++)
  715.     {
  716.         GLOB(conssym[i])=newkey=DsInsExt(funs[i].name);
  717.         TAGpart(newkey)=TYPE_KEY;
  718.         KEYpart(newkey)=i;
  719.         ARGpart(newkey)=funs[i].nargs;
  720.     }
  721.     Q_true = CSYM(IP_TRUE);
  722.     Q_invis = CSYM(IP_INVIS);
  723.     TAGpart(Q_true) = TYPE_SPC;
  724.     TAGpart(Q_invis)= TYPE_SPC;
  725.     TAGpart(Q_undef)= TYPE_SPC;
  726.     TAGpart(Q_else) = TYPE_SPC;
  727.     TAGpart(Q_eof)  = TYPE_SPC;
  728. }
  729.  
  730.  
  731. /***************************************************************
  732. ** NAME:        DsCtrlHandler
  733. ** SYNOPSIS:    void DsCtrlHandler(sig)
  734. **              int sig;
  735. ** DESCRIPTION: Called when Ctrl-C is pressed. This function
  736. **              is not part of DScheme, but is used for testing
  737. **              purposes.
  738. ** RETURNS:     void
  739. ***************************************************************/
  740. STATIC
  741. void CDECL DsCtrlHandler(sig)
  742. int sig;
  743. {
  744.     int c;
  745.  
  746.     sig;                      /* disable compiler warning about unreferenced! */
  747.     signal(SIGINT, SIG_IGN);
  748.     DsOut(GLOB(errport),'\n');
  749.     while (1)                              /* until a correct answer is given */
  750.     {
  751.         DsOutf(GLOB(errport),"*** B)reak evaluation, C)ontinue, Q)uit to %s or S)tatus? ",SYSTEEM);
  752.         DsFlushPort(GLOB(errport));
  753. #ifndef MSC
  754.         c=getchar();    /* should be a get with no buffering */
  755.         while (getchar()!='\n');
  756. #else
  757.         c=getche();putchar('\n');
  758. #endif
  759.         c=toupper(c);
  760.         signal(SIGINT, DsCtrlHandler);
  761.         switch (c)
  762.         {
  763.         case 'C': return;
  764.         case 'B': DSVERROR(ERRBREAK);break;
  765.         case 'Q': DSVERROR(ERRXIT);break;
  766.         case 'S': Ds_globals();break;
  767.         default : putchar(BELL);                 /* Produce an audible alert! */
  768.         }
  769.     }
  770. }
  771.  
  772.  
  773.  
  774. #ifndef MSC
  775. /***************************************************************
  776. ** NAME:        strupr
  777. ** SYNOPSIS:    char *strupr(str)
  778. **              char *str;     pointer to input string
  779. ** DESCRIPTION: strupr converts a string to uppercase.
  780. ** RETURNS:     Pointer to (converted) string.
  781. ***************************************************************/
  782. char *strupr(p)
  783. char *p;
  784. {
  785.     char *q;
  786.     for (q=p;*q;q++) 
  787.      if (islower(*q)) *q += ('A'-'a');
  788.     return(p);
  789. }
  790.  
  791. /***************************************************************
  792. ** NAME:        stricmp
  793. ** SYNOPSIS:    int stricmp(s1,s2)
  794. **              char *s1;     pointer to input string
  795. **              char *s2;     pointer to input string
  796. ** DESCRIPTION: A case-insensitive version of strcmp.
  797. ** RETURNS:     <0: s1 is smaller than s2 (alphabeticly)
  798. **              =0: s1 is equal to s2
  799. **              >0: s1 is bigger than s2 (alphabeticly)
  800. ***************************************************************/
  801. int stricmp(s1,s2)
  802. char *s1;
  803. char *s2;
  804. {
  805.     while (*s1)
  806.     {
  807.         register int d = tolower(*s1)-tolower(*s2);
  808.     if (d) return d;
  809.     s1++,s2++;
  810.     }
  811.     return (*s2)?-1:0;
  812. }
  813. #endif
  814.  
  815.  
  816.  
  817.  
  818.