home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schio.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  33.0 KB  |  1,172 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHIO.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       88/10/17
  9. **
  10. ** DESCRIPTION: The IO routines used by the SCHEME system
  11. **              are defined in this file.
  12. ***********************************************************************
  13. ** CHANGES INFORMATION **
  14. *************************
  15. ** REVISION:    $Revision:   1.0  $
  16. ** CHANGER:     $Author:   JAN  $
  17. ** WORKFILE:    $Workfile:   schio.c  $
  18. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHIO.C_V  $
  19. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHIO.C_V  $
  20. **              
  21. **                 Rev 1.0   12 Oct 1989 11:46:26   JAN
  22. **              Initial revision.
  23. **********************************************************************/
  24. #ifdef OS2
  25. #define INCL_DOS
  26. #include <os2.h>
  27. #endif
  28. #include "schinc.h"
  29.  
  30. #ifdef SUN
  31. int fgetc __((UNTYPE *));
  32. void fputc __((int, UNTYPE *));
  33. #endif
  34.  
  35. STATIC CELP   PASCAL DsOFile    __((CELP str,int mode));
  36. STATIC void   PASCAL DsOutg     __((PORT *outport, REAL g));
  37. STATIC void   PASCAL DsOutx     __((PORT *outport, LONG x));
  38. STATIC void   PASCAL DsOutl     __((PORT *outp, CELP elem, int mode));
  39. STATIC void   PASCAL DsOutv     __((PORT *outp, CELP elem, int mode));
  40. STATIC char * PASCAL DsString   __((CELP elem));
  41. STATIC char * PASCAL DsChar     __((int ch));
  42. STATIC void   PASCAL DsPSError  __((int num, UNTYPE *stream));
  43. STATIC char * PASCAL DsItoa     __((long num));
  44. STATIC PORT * PASCAL GetOPort   __((int n, CELP *pp));
  45. #ifdef OS2
  46. STATIC PORT * PASCAL  DsDosOpen     __((HFILE, USHORT));
  47. #endif
  48.  
  49. /*-------------------- Scheme Procedures ------------------*/
  50. STATIC CELP   CDECL  Ds_write          __((int nvals,CELP args));
  51. STATIC CELP   CDECL  Ds_writech        __((int nvals,CELP args));
  52. STATIC CELP   CDECL  Ds_readitem       __((int nvals,CELP args));
  53. STATIC CELP   CDECL  Ds_readch         __((int nvals,CELP args));
  54. STATIC CELP   CDECL  Ds_display        __((int nvals,CELP args));
  55. STATIC CELP   CDECL  Ds_newline        __((int nvals,CELP args));
  56. STATIC CELP   CDECL  Ds_flush          __((int nvals,CELP args));
  57. STATIC CELP   CDECL  Ds_close          __((CELP args));
  58. STATIC CELP   CDECL  Ds_oifile         __((CELP args));
  59. STATIC CELP   CDECL  Ds_oofile         __((CELP args));
  60. STATIC CELP   CDECL  Ds_getcip         __((void));
  61. STATIC CELP   CDECL  Ds_getcop         __((void));
  62. STATIC CELP   CDECL  Ds_getcep         __((void));
  63.  
  64. /*--------------------- Port Functions --------------------*/
  65. STATIC int    PASCAL DsFInput   __((UNTYPE *stream));
  66. STATIC void   PASCAL DsFOutput  __((int c, UNTYPE *stream));
  67. STATIC void   PASCAL DsFControl __((UNTYPE *stream, int action));
  68. STATIC CELP   CDECL  Ds_inport  __((CELP port));
  69. STATIC CELP   CDECL  Ds_outport __((CELP port));
  70. STATIC CELP   CDECL  Ds_errport __((CELP port));
  71.  
  72. static EXTDEF DsPortFuns[] =
  73.     {
  74.         {"WRITE",              (EXTPROC)Ds_write,    -1},
  75.         {"WRITE-CHAR",         (EXTPROC)Ds_writech,  -1},
  76.         {"DISPLAY",            (EXTPROC)Ds_display,  -1},
  77.         {"READ",               (EXTPROC)Ds_readitem, -1},
  78.         {"READ-CHAR",          (EXTPROC)Ds_readch,   -1},
  79.         {"NEWLINE",            (EXTPROC)Ds_newline,  -1},
  80.         {"FLUSH",              (EXTPROC)Ds_flush,    -1},
  81.         {"GET-CIP",            (EXTPROC)Ds_getcip,    0},
  82.         {"CURRENT-INPUT-PORT", (EXTPROC)Ds_getcip,    0},
  83.         {"GET-COP",            (EXTPROC)Ds_getcop,    0},
  84.         {"CURRENT-OUTPUT-PORT",(EXTPROC)Ds_getcop,    0},
  85.         {"GET-CEP",            (EXTPROC)Ds_getcep,    0},
  86.         {"CURRENT-ERROR-PORT", (EXTPROC)Ds_getcep,    0},
  87.         {"CLOSE-PORT",         (EXTPROC)Ds_close,     1, TYPE_PRT},
  88.         {"OPEN-INPUT-FILE",    (EXTPROC)Ds_oifile,    1, TYPE_STR},
  89.         {"OPEN-OUTPUT-FILE",   (EXTPROC)Ds_oofile,    1, TYPE_STR},
  90.         {"LOAD",               (EXTPROC)Ds_load,      1, TYPE_STR},
  91.         {"SET-INPUT-PORT",     (EXTPROC)Ds_inport,    1, TYPE_PRT},
  92.         {"SET-OUTPUT-PORT",    (EXTPROC)Ds_outport,   1, TYPE_PRT},
  93.         {"SET-ERROR-PORT",     (EXTPROC)Ds_errport,   1, TYPE_PRT},
  94.         ENDOFLIST
  95.     };
  96.  
  97. extern CELP item;
  98.  
  99. /**************************************************************
  100. ** NAME:        DsIniIO
  101. ** SYNOPSIS:    void DsIniIO(void);
  102. ** DESCRIPTION: Initializes the Scheme IO procedures and
  103. **              constants.
  104. ** RETURNS:     void
  105. **************************************************************/
  106. void PASCAL DsIniIO()
  107. {
  108.     PRTCEL(item,GLOB(sinport));
  109.     DsDefVar(DsInsExt("STDIN"));
  110.     PRTCEL(item,GLOB(soutport));
  111.     DsDefVar(DsInsExt("STDOUT"));
  112.     PRTCEL(item,GLOB(serrport));
  113.     DsDefVar(DsInsExt("STDERR"));
  114.     DsFuncDef(DsPortFuns); /* define port functions */
  115. }
  116.  
  117.  
  118. /*****************************************************************
  119. ** NAME:        DsIniPorts
  120. ** SYNOPSIS:    void DsIniPorts()
  121. **              int numport;    Size of port table
  122. **              int bigbuf;     Size of big string buffer
  123. **              int numbuf;     Number of io buffers.
  124. **              int bufsize;    Size of io buffer.
  125. ** DESCRIPTION: Initializes the port system & file io buffers.
  126. ** RETURNS:     void
  127. *****************************************************************/
  128. void PASCAL DsIniPorts(numport,bigbuf,numbuf,bufsize)
  129. int numport,bigbuf,numbuf,bufsize;
  130. {
  131.     int i;
  132.  
  133.     if (numport>0)
  134.     {
  135.         if (GLOB(ports)!=NIL)
  136.             DSVERROR(ERRPORT);
  137.         GETMEM(GLOB(ports),PORT,numport*sizeof(PORT),"Port Table");
  138.         for (i=0;i<numport;i++)
  139.             GLOB(ports[i]).dir=FREE;
  140.         GLOB(prtnum)=numport;
  141.  
  142.         if (bigbuf<MAXSTR) bigbuf=MAXSTR;     /* Safety Treshold */
  143.         BIGMAX=bigbuf;
  144.         GETMEM(BIGBUF, char, bigbuf,"BIGbuffer");
  145.     }
  146. }
  147.  
  148.  
  149. /***************************************************************
  150. ** NAME:        DsInput
  151. ** SYNOPSIS:    int DsInput(inport);
  152. **              PORT *inport;   The input port.
  153. ** DESCRIPTION: DsInput tries to read a character from a scheme
  154. **              port. This can be from a file or a string. In
  155. **              both cases the unput buffer is emptied first.
  156. ** RETURNS:     Character read from the port.
  157. **              EOF when at end of file/string.
  158. ** SEE ALSO:    Sunput()
  159. ***************************************************************/
  160. int PASCAL DsInput(inport)
  161. PORT *inport;
  162. {
  163.     if (inport->dir & UNPUTTED)
  164.         inport->dir ^= UNPUTTED;                     /* reset unputted flag */
  165.     else
  166.         inport->unput=inport->portin(inport->stream);
  167.     if (inport->unput=='\n') inport->lineno++;
  168.     return inport->unput;
  169. }
  170.  
  171.  
  172. /***************************************************************
  173. ** NAME:        DsUnput
  174. ** SYNOPSIS:    void DsUnput(inport,c);
  175. **              PORT *inport;   The input port.
  176. **              int c;         The character which is to be
  177. **                              put back in the port.
  178. ** DESCRIPTION: DsUnput pushes the last read character back into
  179. **              the port. (Only one char can be put back).
  180. ** RETURNS:     void.
  181. ** SEE ALSO:    DsInput()
  182. ***************************************************************/
  183. void PASCAL DsUnput(inport,c)
  184. PORT *inport;
  185. int c;
  186. {
  187.     if (inport->dir & UNPUTTED) DSPERROR(ERRIOU,inport);
  188.     if (c=='\n') inport->lineno--;
  189.     inport->dir |= UNPUTTED;
  190.     inport->unput = c;
  191. }
  192.  
  193.  
  194. /***************************************************************
  195. ** NAME:        DsPeek
  196. ** SYNOPSIS:    int DsPeek(inport);
  197. **              PORT *inport;   The input port.
  198. ** DESCRIPTION: DsPeek reads a character from the input port
  199. **              pushes it immediately back.
  200. ** RETURNS:     void.
  201. ** SEE ALSO:    DsInput()
  202. ***************************************************************/
  203. int PASCAL DsPeek(inport)
  204. PORT *inport;
  205. {
  206.     if (!(inport->dir & UNPUTTED))
  207.     {
  208.         inport->unput=inport->portin(inport->stream);     /* read a character */
  209.         inport->dir |= UNPUTTED;
  210.     }
  211.     return inport->unput;
  212. }
  213.  
  214.  
  215. /***************************************************************
  216. ** NAME:        DsOut
  217. ** SYNOPSIS:    void DsOut(outport,c);
  218. **              PORT *outport;  The output port.
  219. **              int c;         The character which is to be
  220. **                              put in the output port.
  221. ** DESCRIPTION: Puts the character c into the output port.
  222. ** RETURNS:     void.
  223. ** SEE ALSO:    DsInput()
  224. ***************************************************************/
  225. #ifdef OLD
  226. void PASCAL DsOut(outport,c)
  227. PORT *outport;
  228. int c;
  229. {
  230.     outport->portout(c,outport->stream);
  231. }
  232. #endif
  233.  
  234.  
  235. /***************************************************************
  236. ** NAME:        DsOuts
  237. ** SYNOPSIS:    void DsOuts(outport,str);
  238. **              PORT *outport;  The output port.
  239. **              char *str;      The string of characters to be
  240. **                              put in the output port.
  241. ** DESCRIPTION: Puts the string str into the output port.
  242. ** RETURNS:     void.
  243. ** SEE ALSO:    DsOut()
  244. ***************************************************************/
  245. void PASCAL DsOuts(outport,str)
  246. PORT *outport;
  247. CONST char *str;
  248. {
  249.     register OUT_FUN portout=outport->portout;
  250.     register UNTYPE *stream=outport->stream;
  251.     while (*str)
  252.         portout(*str++,stream);
  253. }
  254.  
  255.  
  256. /***************************************************************
  257. ** NAME:        DsOutf
  258. ** SYNOPSIS:    void DsOutf(outport,fmt,...);
  259. **              PORT *outport;  The output port.
  260. **              char *fmt;      The format string.
  261. ** DESCRIPTION: Puts the string str into the output port.
  262. **              Possible format commando's:
  263. **              %c: insert char.
  264. **              %s: insert string.
  265. **              %d: insert integer.
  266. **              %l: insert long integer. 
  267. **              %f: insert float.
  268. **              %t: insert timestamp (time_t)
  269. **              %a: insert cell.    (write mode)
  270. **              %A: insert cell.    (display mode)
  271. **              %x: insert hex integer.
  272. ** RETURNS:     void.
  273. ** SEE ALSO:    printf()
  274. ***************************************************************/
  275. void DsOutf(outport, fmt VAR_ARGS)
  276. PORT *outport;
  277. CONST char *fmt;
  278. VAR_DCL
  279. {
  280.     CONST char *p;
  281.     va_list va;
  282.     VAR_START(va,fmt);
  283.     for (p=fmt;*p;p++)
  284.     {
  285.         if (*p=='%')
  286.         {
  287.             switch(*++p)
  288.             {
  289.             case 'a': DsOutc(outport,va_arg(va, CELP),TRUE);        break;
  290.             case 'A': DsOutc(outport,va_arg(va, CELP),FALSE);       break;
  291.             case 'c': DsOut (outport,va_arg(va, int));              break;
  292.             case 'd': DsOuts(outport,DsItoa((LONG)va_arg(va,int))); break;
  293.             case 'f': DsOutg(outport,va_arg(va, REAL));             break;
  294.             case 'l': DsOuts(outport,DsItoa(va_arg(va, LONG)));     break;
  295.             case 's': DsOuts(outport,va_arg(va, char *));           break;
  296.             case 't': DsOuts(outport,CELTMS(DsMakeTime(va_arg(va,time_t))));break;
  297.             case 'x': DsOutx(outport,va_arg(va, LONG));             break;
  298.             default : DsOut (outport,(int)*p);
  299.             }
  300.         }
  301.         else
  302.             DsOut(outport,(int)*p);
  303.     }
  304.     va_end(va);
  305. }
  306.  
  307.  
  308. /***************************************************************
  309. ** NAME:        DsOutg
  310. ** SYNOPSIS:    void DsOutg(outport,g);
  311. **              PORT *outport;  The output port.
  312. **              REAL g;         The floating point number.
  313. ** DESCRIPTION: Puts the real g into the output port.
  314. ** RETURNS:     void.
  315. ***************************************************************/
  316. STATIC
  317. void PASCAL DsOutg(outport,g)
  318. REAL g;
  319. PORT *outport;
  320. {
  321.     static char buf[30];
  322.     sprintf(buf,"%#g",g);
  323.     DsOuts(outport,buf);
  324. }
  325.  
  326.  
  327. /***************************************************************
  328. ** NAME:        DsOutx
  329. ** SYNOPSIS:    void DsOutx(outport,x);
  330. **              PORT *outport;  The output port.
  331. **              LONG x;
  332. ** DESCRIPTION: Puts the hex x into the output port.
  333. ** RETURNS:     void.
  334. ***************************************************************/
  335. STATIC
  336. void PASCAL DsOutx(outport,x)
  337. PORT *outport;
  338. LONG x;
  339. {
  340.     static char buf[10];
  341.     sprintf(buf,"%08x",x);
  342.     DsOuts(outport,buf);
  343. }
  344.  
  345.  
  346. /***************************************************************
  347. ** NAME:        DsOutc
  348. ** SYNOPSIS:    void DsOutc(outp,elem,mode);
  349. **              PORT *outp      The output port
  350. **              CELP elem       The SCHEME item to be printed
  351. **              int  mode       TRUE => output is SCHEME
  352. ** DESCRIPTION: Prints a SCHEME item. Item can be an atom or a
  353. **              list. If item is a list then DsOutc calls
  354. **              DsOutl which calls recursively DsOutc. This
  355. **              goes wrong if elem points to a circular list
  356. ** RETURNS:     void
  357. ***************************************************************/
  358. void PASCAL DsOutc(outp,elem,mode)
  359. CELP elem;
  360. PORT *outp;
  361. int mode;
  362. {
  363.     if (ISNIL(elem))
  364.     {
  365.         DsOut(outp,'(');
  366.         DsOut(outp,')');
  367.         return;
  368.     }
  369.     switch (TAGpart(elem))
  370.     {
  371.     case TYPE_STR:
  372.         DsOuts(outp,(mode)?DsString(elem):STRPpart(elem));
  373.         break;
  374.  
  375.     case TYPE_TMS:
  376.         DsOuts(outp,CELTMS(elem));
  377.         break;
  378.  
  379.     case TYPE_CHR:
  380.         if (mode)
  381.             DsOuts(outp,DsChar(CHRpart(elem)));
  382.         else
  383.             DsOut(outp,CHRpart(elem));
  384.         break;
  385.  
  386.     case TYPE_PRT:
  387.         DsOuts(outp,"#PORT");
  388.         break;
  389.  
  390.     case TYPE_VEC:
  391.         DsOutv(outp,elem,mode);
  392.         break;
  393.  
  394.     case TYPE_OID:
  395.         DsOutf(outp,"#!%d",CELINT(elem));
  396.         break;
  397.  
  398.     case TYPE_INT:
  399.         DsOuts(outp,DsItoa(CELINT(elem)));
  400.         break;
  401.  
  402.     case TYPE_FLT:
  403.         DsOutg(outp,CELFLT(elem));
  404.         break;
  405.  
  406.     case TYPE_PAIR:
  407.         DsOutl(outp,elem,mode);
  408.         break;
  409.  
  410.     case TYPE_PRC:
  411.         DsOuts(outp,"#LAMBDA");
  412.         break;
  413.  
  414.     case TYPE_SYM:
  415.     case TYPE_EXT:
  416.     case TYPE_KEY:
  417.     case TYPE_SPC:
  418.     case TYPE_SYMD:
  419.         DsOuts(outp,STRPpart(CDRpart(elem)));
  420.         break;
  421.  
  422.     case TYPE_FUN:
  423.         DsOutf(outp,"[%a, %d, %d]",CDRpart(elem),KEYpart(elem),ARGpart(elem));
  424.         break;
  425.  
  426.     case TYPE_MAC:
  427.         DsOuts(outp,"#MACRO");
  428.         break;
  429.  
  430.     case TYPE_FREE:
  431.         DsOuts(outp,"#FREECEL");
  432.         break;
  433.  
  434.     case TYPE_BIGN:
  435.     case TYPE_BIGP:
  436.         DsOuts(outp,DsBigStr(elem));
  437.         break;
  438.  
  439.     }
  440. }
  441.  
  442.  
  443. /***************************************************************
  444. ** NAME:        DsOutl
  445. ** SYNOPSIS:    void DsOutl(outp,elem);
  446. **              PORT *outp      The output port
  447. **              CELP elem       The SCHEME item to be printed
  448. ** DESCRIPTION: Prints a SCHEME list. (Elem must be a list)
  449. **              Each member of the list is printed via 'DsOutc'.
  450. **              The list doesn't have to be a simple list. This
  451. **              function checks also for dotted lists.
  452. ** RETURNS:     void
  453. ** SEE ALSO:    DsOutc, DsOut
  454. ***************************************************************/
  455. STATIC
  456. void PASCAL DsOutl(outp,elem,mode)
  457. PORT *outp;
  458. CELP elem;
  459. int mode;
  460. {
  461.     char pre='(';                    /* pre is character to print before item */
  462.  
  463.     for (;ISPAIR(elem);elem=CDRpart(elem))   /* first item begins with a '(', */
  464.     {                                  /* all others are separated with a ' ' */
  465.          DsOut(outp,pre);
  466.          DsOutc(outp,CARpart(elem),mode);
  467.          pre=' ';
  468.     }                                   /* p is no longer a pointer to a pair */
  469.                                /* is elem is a simple list, then p is now NIL */
  470.     if (ISTRUE(elem))                        /* if p is not nil a dot follows */
  471.     {
  472.          DsOuts(outp," . ");
  473.          DsOutc(outp,elem,mode);
  474.     }
  475.     DsOut(outp,')');
  476. }
  477.  
  478.  
  479. /***************************************************************
  480. ** NAME:        DsOutv
  481. ** SYNOPSIS:    void DsOutv(outp,elem);
  482. **              PORT *outp      The output port
  483. **              CELP elem       The SCHEME item to be printed
  484. ** DESCRIPTION: Prints a SCHEME vector.
  485. **              Each member of the vector is printed via DsOutc.
  486. ** RETURNS:     void
  487. ** SEE ALSO:    DsOutc, DsOut
  488. ***************************************************************/
  489. STATIC
  490. void PASCAL DsOutv(outp,elem,mode)
  491. PORT *outp;
  492. CELP elem;
  493. int mode;
  494. {
  495.     char pre='(';                 /* pre is character to print before item */
  496.     int i;
  497.  
  498.     DsOut(outp,'#');
  499.     for (i=0;i<VECLpart(elem);i++)
  500.     {
  501.         DsOut(outp,pre);
  502.         DsOutc(outp,VECPpart(elem)[i],mode);
  503.         pre=' ';
  504.     }
  505.     DsOut(outp,')');
  506. }
  507.  
  508.  
  509. /***************************************************************
  510. ** NAME:        DsString
  511. ** SYNOPSIS:    void DsString(elem);
  512. **              CELP elem       The SCHEME str to be printed
  513. ** DESCRIPTION: Prints a SCHEME character.
  514. ** RETURNS:     void
  515. ** SEE ALSO:    Printc, DsOut
  516. ***************************************************************/
  517. STATIC
  518. char * PASCAL DsString(elem)
  519. CELP elem;
  520. {
  521.     char *p;
  522.     char *q;
  523.  
  524.     q=BIGBUF;
  525.     *q++='\"';
  526.     for (p=STRPpart(elem);*p;p++)
  527.     {
  528.         switch(*p)
  529.         {
  530.         case BELL : *q++='\\';*q++='a';break;
  531.         case '\b' : *q++='\\';*q++='b';break;
  532.         case '\t' : *q++='\\';*q++='t';break;
  533.         case '\n' : *q++='\\';*q++='n';break;
  534.         case '\f' : *q++='\\';*q++='f';break;
  535.         case '\r' : *q++='\\';*q++='r';break;
  536.         case '\27': *q++='\\';*q++='e';break; /* escape */
  537.         default   : if (isprint(*p))
  538.             *q++=*p; 
  539.                     else
  540.             {
  541.             *q++='\\';
  542.             *q++='0'+(((*p)>>6)&7);
  543.             *q++='0'+(((*p)>>3)&7);
  544.             *q++='0'+(((*p)>>0)&7);
  545.             }
  546.         }
  547.     }
  548.     *q++='\"';*q='\0';
  549.     return BIGBUF;
  550. }
  551.  
  552.  
  553. /***************************************************************
  554. ** NAME:        DsChar
  555. ** SYNOPSIS:    char *DsChar(elem);
  556. **              int elem       The SCHEME char to be printed
  557. ** DESCRIPTION: Prints a SCHEME character.
  558. ** RETURNS:     void
  559. ** SEE ALSO:    Printc, DsOut
  560. ***************************************************************/
  561. STATIC
  562. char *PASCAL DsChar(ch)
  563. int ch;
  564. {
  565.     static char normal[4]="#\\a";
  566.     switch(ch)
  567.     {
  568.     case BELL : return "#\\BELL";
  569.     case '\b' : return "#\\BACKSPACE";
  570.     case '\t' : return "#\\TAB";
  571.     case '\n' : return "#\\NEWLINE";
  572.     case '\f' : return "#\\FORMFEED";
  573.     case '\r' : return "#\\RETURN";
  574.     case '\27': return "#\\ESCAPE";
  575.     case ' '  : return "#\\SPACE";
  576.     }
  577.     normal[2]=(char)ch;
  578.     return normal;
  579. }
  580.                 
  581.  
  582. /***************************************************************
  583. ** NAME:        DsInitPort
  584. ** SYNOPSIS:    PORT *DsInitPort(mode, stream, inputp,
  585. **                             outputp, controlp)
  586. **              int mode;
  587. **              UNTYPE *stream;
  588. **              INP_FUN inputp;
  589. **              OUT_FUN outputp;
  590. **              CTL_FUN controlp;
  591. ** DESCRIPTION: Request for a IO port.
  592. **              Finds an empty port slot in the global port
  593. **              resources and initializes it.
  594. ** RETURNS:     Pointer to the allocated and initialized port.
  595. ***************************************************************/
  596. PORT * PASCAL DsInitPort(mode,stream,inputp,outputp,closep)
  597. int mode;
  598. UNTYPE *stream;
  599. INP_FUN inputp;
  600. OUT_FUN outputp;
  601. CTL_FUN closep;
  602. {
  603.     int i;
  604.     PORT *tmp;
  605.  
  606.     tmp=GLOB(ports);
  607.     for (i=0;i<GLOB(prtnum);i++,tmp++)
  608.         if (tmp->dir==FREE) break;                          /* find free port */
  609.     if (i==GLOB(prtnum))                                /* no free port found */
  610.         DSVERROR(ERRPORTF);
  611.  
  612.     tmp->dir     = mode;
  613.     tmp->lineno  = 1L;
  614.     tmp->stream  = stream;
  615.     tmp->portin  = inputp;
  616.     tmp->portout = outputp;
  617.     tmp->portctl = closep;
  618.     return(tmp);
  619. }
  620.  
  621.  
  622. /***************************************************************
  623. ** NAME:        DsClosePort
  624. ** SYNOPSIS:    void DsClosePort(port);
  625. **              PORT *port;
  626. ** DESCRIPTION: Closes the SCHEME port.
  627. **              Structure port is also released to port space.
  628. ** RETURNS:     void
  629. ***************************************************************/
  630. void PASCAL DsClosePort(prt)
  631. PORT *prt;
  632. {
  633.     if ((prt->dir&READWRIT) && !(prt->dir&STANDARD))/* is port really opened? */
  634.     {
  635.         prt->dir=FREE;                                  /* release for re-use */
  636.         prt->portctl(prt->stream,IOCLOSE);                 /* close IO stream */
  637.     }
  638. }
  639.  
  640.  
  641. /***************************************************************
  642. ** NAME:        DsFlushPort
  643. ** SYNOPSIS:    void DsFlushPort(port);
  644. **              PORT *port;
  645. ** DESCRIPTION: Flushes the SCHEME port.
  646. ** RETURNS:     void
  647. ***************************************************************/
  648. void PASCAL DsFlushPort(prt)
  649. PORT *prt;
  650. {
  651.     if (prt->dir&WRITMODE)
  652.         prt->portctl(prt->stream,IOFLUSH);                 /* close IO stream */
  653. }
  654.                 
  655. /*---------------------------FILE IO (standard)----------------------------*/
  656.  
  657.  
  658. /***************************************************************
  659. ** NAME:        DsFOpen
  660. ** SYNOPSIS:    PORT *DsFOpen(name,mode);
  661. **              char *name;     name of file to be opened.
  662. **              int   mode;     filemode
  663. ** DESCRIPTION: Opens a SCHEME port (standard file port)
  664. **              mode can be READMODE, WRITMODE or READWRIT.
  665. ** RETURNS:     Return pointer to port.
  666. **              If port can't be opened, NIL is returned.
  667. ***************************************************************/
  668. PORT *PASCAL DsFOpen(fname,mode)
  669. CONST char *fname;
  670. int   mode;
  671. {
  672.     FILE *fp;
  673.     PORT *pp;
  674.  
  675.     switch (mode)
  676.     {
  677.     case READMODE: fp=fopen( fname, "r"); break;
  678.     case WRITMODE: fp=fopen( fname, "w"); break;
  679.     case READWRIT: fp=fopen( fname, "a"); break;
  680.     default: DSVERROR(ERRINT);
  681.     }
  682.     if (ISNIL(fp)) return(NIL);
  683.     switch(mode)
  684.     {
  685.     case READMODE:
  686.         pp = DsInitPort( READMODE, (UNTYPE *)fp,
  687.                          DsFInput, DsEOutput, DsFControl);
  688.         break;
  689.     case WRITMODE:
  690.         pp = DsInitPort( WRITMODE, (UNTYPE *)fp,
  691.                          DsEInput, DsFOutput, DsFControl);
  692.         break;
  693.     default:
  694.         pp = DsInitPort( READWRIT, (UNTYPE *)fp,
  695.                          DsFInput, DsFOutput, DsFControl);
  696.         break;
  697.     }
  698.     return(pp);
  699. }
  700.  
  701.  
  702.  
  703.  
  704. /***************************************************************
  705. ** NAME:        DsEInput
  706. ** SYNOPSIS:    char DsEInput(stream)
  707. **              UNTYPE *stream;   Pointer to file stream.
  708. ** DESCRIPTION: Called by DsInput when a file port is encountered
  709. **              and port mode is WRITMODE.
  710. ** RETURNS:     never
  711. ***************************************************************/
  712. int PASCAL DsEInput(stream)
  713. UNTYPE *stream;
  714. {
  715.     STOP(DsPSError(ERRIOR,stream));
  716.     return 0;
  717. }
  718.  
  719.  
  720. /***************************************************************
  721. ** NAME:        DsEOutput
  722. ** SYNOPSIS:    void DsEOutput(stream,c)
  723. **              UNTYPE *stream;   Pointer to file stream.
  724. ** DESCRIPTION: Called by DsOutut when a file port is
  725. **              encountered, and mode is READMODE.
  726. ** RETURNS:     void
  727. ***************************************************************/
  728. void PASCAL DsEOutput(c,stream)
  729. int c;
  730. UNTYPE *stream;
  731. {
  732.     c;
  733.     STOP(DsPSError(ERRIOW,stream));
  734. }
  735.  
  736.  
  737. /***************************************************************
  738. ** NAME:        DsFInput
  739. ** SYNOPSIS:    int DsFInput(stream)
  740. **              UNTYPE *stream;   Pointer to file stream.
  741. ** DESCRIPTION: Reads one character from a file stream.
  742. ** RETURNS:     character read (-1 is EOF)
  743. ***************************************************************/
  744. STATIC int PASCAL DsFInput(stream)
  745. UNTYPE *stream;
  746. {
  747.     return getc((FILE *)stream);
  748. }
  749.  
  750.  
  751. /***************************************************************
  752. ** NAME:        DsFOutput
  753. ** SYNOPSIS:    void DsFOutput(stream,c)
  754. **              UNTYPE *stream;   Pointer to file stream.
  755. ** DESCRIPTION: Reads one character from a file stream.
  756. ** RETURNS:     void
  757. ***************************************************************/
  758. STATIC void PASCAL DsFOutput(c,stream)
  759. int c;
  760. UNTYPE *stream;
  761. {
  762.     putc(c,(FILE *)stream);
  763. }
  764.  
  765.  
  766. /***************************************************************
  767. ** NAME:        DsFControl
  768. ** SYNOPSIS:    char DsFControl(stream,nr)
  769. **              UNTYPE *stream;   Pointer to file stream.
  770. **              int action;       action to perform.
  771. ** DESCRIPTION: Called by DsControlPort when a file port is to be
  772. **              controlled. The second argument is defined by the
  773. **              DsInitPort call, and is used for file IO as
  774. **              IObuffer nummer.
  775. ** RETURNS:     void.
  776. ***************************************************************/
  777. STATIC void PASCAL DsFControl(stream,action)
  778. UNTYPE *stream;
  779. int action;
  780. {
  781.     switch(action)
  782.     {
  783.     case IOCLOSE:
  784.         fclose((FILE *)stream);
  785.         break;
  786.  
  787.     case IOFLUSH:
  788.         break;
  789.     }
  790. }
  791.  
  792.  
  793. /**************************************************************
  794. ** NAME:        DsPSError
  795. ** SYNOPSIS:    void PASCAL DsPSError(num,stream)
  796. **              int num;
  797. **              UNTYPE *stream;
  798. ** DESCRIPTION: Finds the port cell with the stream and raises
  799. **              an IO error.
  800. ** RETURNS:     never
  801. **************************************************************/
  802. STATIC void PASCAL DsPSError(num,stream)
  803. int num;
  804. UNTYPE *stream;
  805. {
  806.     int i;
  807.  
  808.     for (i=0;i<GLOB(prtnum);i++)
  809.         if (GLOB(ports)[i].stream==stream)
  810.             DSPERROR(num,GLOB(ports)+i);
  811.     DSVERROR(num);
  812. }
  813.  
  814.  
  815. /***************************************************************
  816. ** NAME:        DsStdPorts
  817. ** SYNOPSIS:    void DsStdPorts();
  818. ** DESCRIPTION: Initializes the standard ports connected to
  819. **              'stdin', 'stdout' and 'stderr'.
  820. ** RETURNS:     void
  821. ***************************************************************/
  822. void PASCAL DsStdPorts()
  823. {
  824. #ifdef OS2
  825.     GLOB(outport)  =
  826.     GLOB(soutport) = DsDosOpen(1, WRITMODE | STANDARD);
  827.     GLOB(errport)  =
  828.     GLOB(serrport) = DsDosOpen(2, WRITMODE | STANDARD);
  829. #else
  830.     GLOB(outport) =
  831.     GLOB(soutport) = DsInitPort( WRITMODE | STANDARD,
  832.                                  (UNTYPE *)stdout,
  833.                                  DsEInput,
  834.                                  DsFOutput,
  835.                                  DsFControl);
  836.     GLOB(serrport) =
  837.     GLOB(errport) = DsInitPort( WRITMODE | STANDARD,
  838.                                 (UNTYPE *)stderr,
  839.                                 DsEInput,
  840.                                 DsFOutput,
  841.                                 DsFControl);
  842. #endif
  843.     GLOB(inport) =
  844.     GLOB(sinport) = DsInitPort( READMODE | STANDARD,
  845.                                 (UNTYPE *)stdin,
  846.                                 DsFInput,
  847.                                 DsEOutput,
  848.                                 DsFControl);
  849. }
  850.  
  851.  
  852. STATIC char * PASCAL DsItoa(num)
  853. DWORD num;
  854. {
  855. #ifdef MSC
  856.     static char buf[12];
  857.     return ltoa(num,buf,10);
  858. #else
  859.     return ltostr(num,10);
  860. #endif
  861. }
  862.  
  863. char * PASCAL ltostr(num, base)
  864. long num;
  865. int base;
  866. {
  867.     static char digits[]="0123456789abcdefghijklmnopqrstuvwxyz";
  868.     register char *q;
  869.     int sign;
  870.  
  871.     q=&BIGBUF[BIGMAX];
  872.     *--q='\0';
  873.     sign=0;
  874.     if (num<0) sign++,num=-num;
  875.     while (num>=base)
  876.     {
  877.     *--q=digits[num%base];
  878.     num/=base;
  879.     }
  880.     *--q=digits[num];
  881.     if (sign) *--q='-';
  882.     return q;
  883. }
  884.  
  885. STATIC PORT * PASCAL GetOPort(n,pp)
  886. int n;
  887. CELP *pp;
  888. {
  889.     CELP q;
  890.     switch(n)
  891.     {
  892.     case 1: return GLOB(outport);
  893.     case 2: q=CARpart(*pp);
  894.             TYPCHECK(q,TYPE_PRT);
  895.             *pp=CDRpart(*pp);
  896.             return CELPRT(q);
  897.     default:DSVERROR(ERRARC);
  898.     }
  899. }
  900.  
  901.  
  902. /*------------------------ DScheme Port Functions -----------------------*/
  903. STATIC CELP Ds_write(nvals,args)
  904. int nvals;                    
  905. CELP args;                    
  906. {
  907.     PORT *prt=GetOPort(nvals,&args);
  908.     DsOutc(prt,args,TRUE);  
  909.     return(Q_invis);
  910. }
  911.  
  912. STATIC CELP Ds_display(nvals,args)
  913. int nvals;
  914. CELP args;
  915. {
  916.     PORT *prt=GetOPort(nvals,&args);
  917.     DsOutc(prt,args,FALSE);                        /* print the item */
  918.     return(Q_invis);
  919. }
  920.  
  921.  
  922. /***************************************************************
  923. ** NAME:        Ds_writech
  924. ** SYNOPSIS:    CELP Ds_writech(nvals)
  925. **              int nval;
  926. **              CELP list;      List
  927. ** DESCRIPTION: Prints all the elements of the list
  928. ** RETURNS:     an unprintable cell.
  929. ***************************************************************/
  930. STATIC CELP Ds_writech(n,p)
  931. int n;
  932. CELP p;
  933. {
  934.     PORT *prt=GetOPort(n,&p);
  935.     TYPCHECK(p,TYPE_CHR);
  936.     DsOut(prt,CELCHR(p));                              /* print the character */
  937.     return Q_invis;
  938. }
  939.  
  940.  
  941. STATIC CELP Ds_newline(n,p)
  942. int n;
  943. CELP p;
  944. {
  945.     DsOut(GetOPort(n+1,&p),'\n');
  946.     return Q_invis;
  947. }
  948.  
  949.  
  950. STATIC CELP Ds_flush(n,p)
  951. int n;
  952. CELP p;
  953. {
  954.     PORT *prt=GetOPort(n+1,&p); /* Fake a second argument */
  955.     DsFlushPort(prt);
  956.     return Q_invis;
  957. }
  958.  
  959.  
  960. /***************************************************************
  961. ** NAME:        Ds_readitem
  962. ** SYNOPSIS:    CELP Ds_readitem(n,largs)
  963. **              int n;
  964. **              CELP largs;
  965. ** DESCRIPTION: Reads an item from the port.
  966. ** RETURNS:     The read item.
  967. ***************************************************************/
  968. CELP Ds_readitem(n,p)
  969. int n;
  970. CELP p;
  971. {
  972.     switch(n)
  973.     {
  974.     case 0: return DsRead(GLOB(inport));
  975.     case 1: TYPCHECK(p,TYPE_PRT);
  976.             return DsRead(CELPRT(p));
  977.     default: DSVERROR(ERRARC);
  978.     }
  979. }
  980.  
  981.  
  982. /***************************************************************
  983. ** NAME:        Ds_readch
  984. ** SYNOPSIS:    CELP Ds_read(n,largs)
  985. **              int n;
  986. **              CELP largs;
  987. ** DESCRIPTION: Reads an character from the port.
  988. ** RETURNS:     The read item.
  989. ***************************************************************/
  990. CELP Ds_readch(n,p)
  991. int n;
  992. CELP p;
  993. {
  994.     PORT *prt;
  995.     switch(n)
  996.     {
  997.     case 0: prt=GLOB(inport); break;
  998.     case 1: TYPCHECK(p,TYPE_PRT); prt=CELPRT(p); break;
  999.     default: DSVERROR(ERRARC);
  1000.     }
  1001.     return DSCHRCEL(DsInput(prt));
  1002. }
  1003.  
  1004.  
  1005. STATIC CELP Ds_getcip()
  1006. {                             
  1007.     return DSPRTCEL(GLOB(inport));
  1008. }
  1009.  
  1010.  
  1011. STATIC CELP Ds_getcop()
  1012. {                             
  1013.     return DSPRTCEL(GLOB(outport));
  1014. }
  1015.  
  1016. STATIC CELP Ds_getcep()
  1017. {                             
  1018.     return DSPRTCEL(GLOB(errport));
  1019. }
  1020.  
  1021. STATIC CELP Ds_close(arg)
  1022. CELP arg;
  1023. {
  1024.     DsClosePort(CELPRT(arg));
  1025.     return Q_invis;
  1026. }
  1027.  
  1028. STATIC CELP Ds_oifile(arg)
  1029. CELP arg;
  1030. {
  1031.     return DsOFile(arg,READMODE);
  1032. }
  1033.  
  1034. STATIC CELP Ds_oofile(arg)
  1035. CELP arg;
  1036. {
  1037.     return DsOFile(arg,WRITMODE);
  1038. }
  1039.  
  1040.  
  1041. STATIC
  1042. CELP PASCAL DsOFile(str,mode)
  1043. CELP str;
  1044. int mode;
  1045. {
  1046.     PORT *pp=DsFOpen(STRPpart(str),mode);
  1047.     return (pp)?DSPRTCEL(pp):NIL;
  1048. }
  1049.  
  1050.  
  1051. STATIC
  1052. CELP Ds_inport(port)
  1053. CELP port;
  1054. {
  1055.     GLOB(inport)=CELPRT(port);
  1056.     return port;
  1057. }
  1058.  
  1059. STATIC
  1060. CELP Ds_outport(port)
  1061. CELP port;
  1062. {
  1063.     GLOB(outport)=CELPRT(port);
  1064.     return port;
  1065. }
  1066.  
  1067. STATIC
  1068. CELP Ds_errport(port)
  1069. CELP port;
  1070. {
  1071.     GLOB(errport)=CELPRT(port);
  1072.     return port;
  1073. }
  1074.  
  1075.  
  1076. /*---------------------------- OS2 IO Speedup Code -------------------------*/
  1077. #ifdef OS2
  1078. #define DOSBUFSIZE 250
  1079. #define H(s) ((HDOS *)(s))
  1080. typedef struct _hdos
  1081.     {
  1082.         HFILE   handle;                    /* 2 */
  1083.         SHORT   bufpos;                    /* 2 */        
  1084.         CHAR    buffer[DOSBUFSIZE+2];    /* 252 */
  1085.     }   HDOS;                   /* total is 256 */
  1086.  
  1087. STATIC void PASCAL DsDosWrite(int c, UNTYPE *stream);
  1088. STATIC void PASCAL DsDosControl(UNTYPE *stream, int action);
  1089. /***************************************************************
  1090. ** NAME:        DsDosOpen
  1091. ** SYNOPSIS:    PORT *DsDosOpen(handle,mode);
  1092. **              int handle;     name of file to be opened.
  1093. **              int mode;     filemode
  1094. ** DESCRIPTION: Opens a SCHEME port to a OS2 handle
  1095. **              mode can be READMODE, WRITMODE or READWRIT.
  1096. ** RETURNS:     Return pointer to port.
  1097. **              If port can't be opened, NIL is returned.
  1098. ***************************************************************/
  1099. STATIC PORT * PASCAL DsDosOpen(handle,mode)
  1100. HFILE handle;
  1101. USHORT mode;
  1102. {
  1103.     HDOS *hand;
  1104.  
  1105.     if ((hand=malloc(sizeof(HDOS)))==NULL)
  1106.         DSVERROR(ERRMEM);
  1107.     hand->bufpos=0;
  1108.     hand->handle=handle;
  1109.     if (!(mode & READMODE))
  1110.         return DsInitPort( mode, (UNTYPE *)hand,
  1111.                            DsEInput, DsDosWrite, DsDosControl);
  1112.     DSVERROR(ERRNOT);
  1113. }
  1114.  
  1115.  
  1116. /***************************************************************
  1117. ** NAME:        DsDosWrite
  1118. ** SYNOPSIS:    void DsDosWrite(stream,c)
  1119. **              UNTYPE *stream;   Pointer to file stream.
  1120. ** DESCRIPTION: Called by DsOut for Dos handles.
  1121. ** RETURNS:     void
  1122. ***************************************************************/
  1123. STATIC void PASCAL DsDosWrite(c,stream)
  1124. int c;
  1125. UNTYPE *stream;
  1126. {
  1127.     if (c=='\n')
  1128.     {
  1129.         H(stream)->buffer[H(stream)->bufpos++]=(char)'\r';
  1130.         H(stream)->buffer[H(stream)->bufpos++]=(char)'\n';
  1131.         DsDosControl(stream,IOFLUSH);
  1132.     }
  1133.     else
  1134.     {
  1135.         H(stream)->buffer[H(stream)->bufpos++]=(char)c;
  1136.         if (H(stream)->bufpos==DOSBUFSIZE)                           /* full? */
  1137.             DsDosControl(stream,IOFLUSH);
  1138.     }
  1139. }
  1140.  
  1141.  
  1142. /***************************************************************
  1143. ** NAME:        DsDosControl
  1144. ** SYNOPSIS:    char DsDosControl(stream,action)
  1145. **              UNTYPE *stream; Pointer to file stream.
  1146. **              int action;     IOCLOSE or IOFLUSH;
  1147. ** DESCRIPTION: Called by DsClosePort when a dos port is to be
  1148. **              closed. Called by DsFlushPort to flush the port.
  1149. ** RETURNS:     void.
  1150. ***************************************************************/
  1151. STATIC void PASCAL DsDosControl(stream, action)
  1152. UNTYPE *stream;
  1153. int action;
  1154. {
  1155.     static USHORT nwrit;
  1156.     switch(action)
  1157.     {
  1158.     case IOCLOSE:
  1159.         DosClose(H(stream)->handle);
  1160.         free(stream);
  1161.         break;
  1162.  
  1163.     case IOFLUSH:
  1164.         DosWrite( H(stream)->handle,
  1165.                   H(stream)->buffer,
  1166.                   H(stream)->bufpos,&nwrit);
  1167.         H(stream)->bufpos=0;
  1168.         break;
  1169.     }
  1170. }
  1171. #endif /* OS2 */
  1172.