home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / PORTS.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-24  |  23.3 KB  |  886 lines
  1. /* PORTS.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *         Basic manipulations on port Object            *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: Marc Vuilleumier        Date: Jan 1993            *
  16.  *             (get_port written by John Jensen 1985)            *
  17.  * Revision history:                            *
  18.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  19.  *                                    *
  20.  *                    ``In nomine omnipotentii dei''    *
  21.  ************************************************************************/
  22.  
  23. ////////////// Don't forget to kill spopen, spclose & get_mode ////////////
  24. /////////////////// when new ports will be working well ///////////////////
  25.  
  26. #include    <stdlib.h>
  27. #include    <string.h>
  28. #include    <ctype.h>
  29. #include    <fcntl.h>
  30. #include    <sys\stat.h>
  31. #include    <share.h>
  32. #include    <io.h>
  33. #include    "scheme.h"
  34.  
  35. static char    *types[] = {
  36.     "WINDOW", "SOFTWARE", "STRING", "FILE", NULL, "MAKE-PORT" };
  37.  
  38. typedef enum    { 
  39.     IS_WINDOW, IS_SOFTWARE, IS_STRING, IS_FILE
  40.     } KIND_OF_PORT;
  41.  
  42. static char    *attributes[] = {
  43.     "TYPE", "SOURCE", "READ", "WRITE", "BINARY?", "WRAP?", "NEW?"
  44.     "TRANSCRIPT?", "LOCK?", "HANDLE", "BORDER", "TEXT", "LINE",
  45.     "COLUMN", "TOP", "LEFT", "HEIGHT", "WIDTH", 
  46.     NULL, "PORT-GET/SET-ATTRIBUTE/!" };
  47.  
  48. typedef    enum    {
  49.     TYPE, SOURCE, READ, WRITE, BINARY, WRAP, NEW, TRANSCRIPT, LOCK,
  50.     HANDLE, BORDER, TEXT, LINE, COLUMN, TOP, LEFT, HEIGHT, WIDTH
  51.     } KIND_OF_ATTRIB;
  52.  
  53. static char    *modes[] = {
  54.     "CLOSED", "PROTECTED", "SHARED", "EXCLUSIVE", NULL, "PORT-SET-ATTRIBUTE!" };
  55.  
  56. typedef    enum    {
  57.     CLOSED, PROTECTED, SHARED, EXCLUSIVE
  58.     } KIND_OF_MODE;
  59.     
  60. /************************************************************************/
  61. /* Give enum equivalents of most importants flags            */
  62. /************************************************************************/
  63. void    port_get_info( PORT far *p, KIND_OF_PORT *type, KIND_OF_MODE *read_mode, 
  64.                             KIND_OF_MODE *write_mode)
  65. {
  66.     switch( p->flags & PORT_TYPE ) {
  67.         case TYPE_WINDOW:
  68.             *type = IS_WINDOW; break;
  69.         case TYPE_SOFTWARE:
  70.             *type = IS_SOFTWARE; break;
  71.         case TYPE_STRING:
  72.             *type = IS_STRING; break;
  73.         case TYPE_FILE:
  74.             *type = IS_FILE; break;
  75.     }
  76.     switch( p->flags & READ_MODE ) {
  77.         case READ_CLOSED:
  78.             *read_mode = CLOSED; break;
  79.         case READ_PROTECTED:
  80.             *read_mode = PROTECTED; break;
  81.         case READ_SHARED:
  82.             *read_mode = SHARED; break;
  83.         case READ_EXCLUSIVE:
  84.             *read_mode = EXCLUSIVE; break;
  85.     }
  86.     switch( p->flags & WRITE_MODE ) {
  87.         case WRITE_CLOSED:
  88.             *write_mode = CLOSED; break;
  89.         case WRITE_PROTECTED:
  90.             *write_mode = PROTECTED; break;
  91.         case WRITE_SHARED:
  92.             *write_mode = SHARED; break;
  93.         case WRITE_EXCLUSIVE:
  94.             *write_mode = EXCLUSIVE; break;
  95.     }
  96. }
  97.  
  98. /************************************************************************/
  99. /* Determine Port                            */
  100. /*                                    */
  101. /* Purpose:  To determine is a register contains a valid port object    */
  102. /* representation and to return the appropriate port            */
  103. /* pointer in "tmp_reg".                        */
  104. /************************************************************************/
  105. int    get_port(REGPTR reg, int mode)
  106. {
  107.     unsigned    disp;    /* displacement component of a pointer */
  108.     unsigned    page;    /* page number component of a pointer */
  109.  
  110.     /* fetch page and displacement portions of port pointer */
  111.     page = CORRPAGE(reg->page);
  112.     disp = reg->disp;
  113.  
  114.     /* check to see if port pointer is nil-- if so, search fluid env */
  115.     if (!page) {
  116.         if (mode)
  117.             intern(&tmp_reg, "OUTPUT-PORT", 11);
  118.         else
  119.             intern(&tmp_reg, "INPUT-PORT", 10);
  120.  
  121.         /* search fluid environment for interned symbol */
  122.         fluid_lookup(&tmp_reg);
  123.         page = CORRPAGE(tmp_reg.page);
  124.         disp = tmp_reg.disp;
  125.     }
  126.     /* page & disp should point to a port, or the symbol 'console */
  127.     if (ptype[page] != PORTTYPE) {
  128.         if (CORRPAGE(console_reg.page) != page || console_reg.disp != disp)
  129.             return    1;
  130.         tmp_reg.page = ADJPAGE(SPECPOR);
  131.         tmp_reg.disp = (mode ? OUT_DISP : IN_DISP);
  132.     } else {
  133.         tmp_reg.page = ADJPAGE(page);
  134.         tmp_reg.disp = disp;
  135.     }
  136.     return    0;
  137. }
  138.  
  139. /************************************************************************/
  140. /* Make a new port                            */
  141. /*                                    */
  142. /* Purpose: to allocate a new port object, of given type and based on    */
  143. /*    source (source type depend of the given type)            */
  144. /************************************************************************/
  145. int    make_port( REGPTR port, REGPTR source )
  146. {
  147.     KIND_OF_PORT    type;
  148.     PORT    far    *p;
  149.  
  150.     type = (KIND_OF_PORT) match( port, types );
  151.     switch( type ) {
  152.         case IS_SOFTWARE:
  153.             if( ptype[CORRPAGE(source->page)] != CLOSTYPE ) {
  154.                 set_src_error("MAKE-PORT", 2, port, source);
  155.                 return -1;
  156.             }
  157.             break;
  158.         case IS_WINDOW:
  159.         case IS_STRING:
  160.             if( eq(source, &nil_reg) ) break;
  161.         case IS_FILE:
  162.             if( ptype[CORRPAGE(source->page)] != STRTYPE ) {
  163.                 set_src_error("MAKE-PORT", 2, port, source);
  164.                 return -1;
  165.             }
  166.     }
  167.  
  168.     alloc_block(port, PORTTYPE, sizeof(PORT)-BLK_OVHD );
  169.     zero_blk( CORRPAGE(port->page), port->disp );
  170.     p = ®2c(port)->port;
  171.  
  172.     load( &(p->ptr), source );
  173.     p->flags = PORT_BINARY | PORT_LOCKED;
  174.     p->nlines = BUFFSIZE;
  175.     p->ncols = 1;
  176.  
  177.     switch( type ) {
  178.         case IS_WINDOW:
  179.             p->flags |= TYPE_WINDOW | PORT_WRAP;
  180.             p->nlines = get_max_rows();
  181.             p->ncols = get_max_cols();
  182.             p->border = -1;
  183.             p->text = 7;
  184.             break;
  185.         case IS_SOFTWARE:
  186.             p->flags |= TYPE_SOFTWARE;
  187.             break;
  188.         case IS_STRING:
  189.             p->flags |= TYPE_STRING;
  190.             if( eq( source, &nil_reg ) )
  191.                 p->flags |= PORT_NEW;
  192.             break;
  193.         case IS_FILE: 
  194.             p->flags |= TYPE_FILE;
  195.         {
  196.             REG    tmp(p->ptr.disp, p->ptr.page);
  197.             char    *name = string_asciz(&tmp);
  198.             int    err = sopen( name, O_RDONLY | SH_DENYNO, 0);
  199.  
  200.             if( err < 0 )
  201.                 p->flags |= PORT_NEW;
  202.             else
  203.                 close( err );
  204.             rlsstr( name );
  205.         }
  206.     }
  207.     return 0;
  208. }
  209.  
  210. /************************************************************************/
  211. /* Get one of the port attributes                    */
  212. /*                                    */
  213. /************************************************************************/
  214. int    port_get_attribute( REGPTR port, REGPTR symbol )
  215. {
  216.     PORT    far    *p;
  217.     KIND_OF_PORT    type;
  218.     KIND_OF_MODE    read_mode, write_mode;
  219.     KIND_OF_ATTRIB    attr;
  220.  
  221.     if( get_port(port, OUTPUT_PORT) )
  222.     {
  223.         set_src_error("PORT-GET-ATTRIBUTE", 2, port, symbol);
  224.         return    -1;
  225.     } else
  226.         *port =    tmp_reg;
  227.  
  228.     attr = (KIND_OF_ATTRIB) match( symbol, attributes );
  229.     p = ®2c(port)->port;
  230.     port_get_info( p, &type, &read_mode, &write_mode );
  231.  
  232.     switch( attr ) {
  233.         case TYPE:
  234.             intern( port, types[type], strlen(types[type]) );
  235.             return 0;
  236.         case SOURCE:
  237.             load( port, &(p->ptr) );
  238.             return 0;
  239.         case READ:
  240.             intern( port, modes[read_mode], strlen(modes[read_mode]) );
  241.             return 0;
  242.         case WRITE:
  243.             intern( port, modes[write_mode], strlen(modes[write_mode]) );
  244.             return 0;
  245.         case BINARY:
  246.             bool2scm( port, p->flags & PORT_BINARY );
  247.             return 0;
  248.         case WRAP:
  249.             bool2scm( port, p->flags & PORT_WRAP );
  250.             return 0;
  251.         case NEW:
  252.             bool2scm( port, p->flags & PORT_NEW );
  253.             return 0;
  254.         case TRANSCRIPT:
  255.             bool2scm( port, p->flags & PORT_TRANSCRIPT );
  256.             return 0;
  257.         case LOCK:
  258.             bool2scm( port, p->flags & PORT_LOCKED );
  259.             return 0;
  260.         case HANDLE:
  261.             if ( type == IS_FILE || type == IS_SOFTWARE ) {
  262.                 long2int( port, p->handle );
  263.                 return 0;
  264.             } else    break;
  265.         case BORDER:
  266.             if ( type == IS_WINDOW || type == IS_SOFTWARE ) {
  267.                 long2int( port, p->border );
  268.                 return 0;
  269.             } else    break;
  270.         case TEXT:
  271.             if ( type == IS_WINDOW || type == IS_SOFTWARE ) {
  272.                 long2int( port, p->text );
  273.                 return 0;
  274.             } else    break;
  275.         case LINE:
  276.             long2int( port, p->curline );
  277.             return 0;
  278.         case COLUMN:
  279.             long2int( port, p->curcol );
  280.             return 0;
  281.         case TOP:
  282.             long2int( port, p->ulline );
  283.             return 0;
  284.         case LEFT:
  285.             long2int( port, p->ulcol );
  286.             return 0;
  287.         case HEIGHT:
  288.             long2int( port, p->nlines );
  289.             return 0;
  290.         case WIDTH:
  291.             long2int( port, p->ncols );
  292.             return 0;
  293.     }
  294.     set_src_error("PORT-GET-ATTRIBUTE", 2, port, symbol);
  295.     return -1;
  296. }
  297.  
  298. /************************************************************************/
  299. /* Calculate offset of upper-left position of a port            */
  300. /************************************************************************/
  301. inline    long    poffset( PORT far *p )
  302. {
  303.     return p->ulcol + p->ulline * p->ncols;
  304. }
  305.  
  306. /************************************************************************/
  307. /* Calculate length of active window of a port                */
  308. /************************************************************************/
  309. inline    long    plength( PORT far *p )
  310. {
  311.     return p->nlines * p->ncols;
  312. }
  313.  
  314. /************************************************************************/
  315. /* Calculate offset from upper-left position of a port            */
  316. /************************************************************************/
  317. inline    long    pcurrent( PORT far *p )
  318. {
  319.     return (p->ulcol + p->curcol) + (p->ulline + p->curline) * p->ncols;
  320. }
  321.  
  322. /************************************************************************/
  323. /* Lock a port                                 */
  324. /************************************************************************/
  325. int    plock( REGPTR port )
  326. {
  327.     PORT    far    *p = ®2c(port)->port;
  328.  
  329.     if( p->flags & PORT_OPEN && p->flags & PORT_SHARED && p->flags & PORT_LOCKED ) {
  330.         if( (p->flags & PORT_TYPE) == TYPE_FILE)
  331.             if( !lock( p->handle, poffset(p), plength(p) ) )
  332.                 return 0;
  333.         else {
  334.             /* ensure string locking accepted */
  335.             return 0;
  336.         }
  337.         /* signal error */
  338.         return -1;
  339.     }
  340.     return 0;
  341. }
  342.  
  343. /************************************************************************/
  344. /* Unlock a port                            */
  345. /************************************************************************/
  346. void    punlock( REGPTR port )
  347. {
  348.     PORT    far    *p = ®2c(port)->port;
  349.  
  350.     if( p->flags & PORT_OPEN && (p->flags & PORT_TYPE) == TYPE_FILE && p->flags & PORT_LOCKED )
  351.         unlock( p->handle, poffset(p), plength(p) );
  352. }
  353.  
  354. /************************************************************************/
  355. /* Open a port                                 */
  356. /************************************************************************/
  357. int    popen( REGPTR port )
  358. {
  359.     PORT    far    *p = ®2c(port)->port;
  360.  
  361.     switch( p->flags & PORT_TYPE ) {
  362.         case TYPE_FILE: {
  363.             REG    tmp(p->ptr.disp, p->ptr.page);
  364.             int    att = O_BINARY;
  365.             char    *name = string_asciz(&tmp);
  366.  
  367.             if( p->flags & WRITE_OPEN ) {
  368.                 if( p->flags & PORT_NEW ) {
  369.                     int    err = creat( name, S_IREAD|S_IWRITE );
  370.                     if( err < 0 ) {
  371.                         /* handle errors */
  372.                         rlsstr( name );
  373.                         return -1;
  374.                     } else
  375.                         close( err );
  376.                 }
  377.  
  378.                 if( p->flags & READ_OPEN )
  379.                     att |= O_RDWR;
  380.                 else
  381.                     att |= O_WRONLY;
  382.             } else
  383.                 att |= O_RDONLY;
  384.  
  385.             if( p->flags & WRITE_PRIVATE )
  386.                 if( p->flags & READ_PRIVATE )
  387.                     att |= SH_DENYRW;
  388.                 else
  389.                     att |= SH_DENYWR;
  390.             else
  391.                 if( p->flags & READ_PRIVATE )
  392.                     att |= SH_DENYRD;
  393.                 else
  394.                     att |= SH_DENYNONE;
  395.             {
  396.                 int err = sopen( name, att, 0 );
  397.  
  398.                 rlsstr( name );
  399.                 if( err < 0 ) {
  400.                     /* handle errors */
  401.                     return -1;
  402.                 } else
  403.                     p->handle = err;
  404.             }
  405.             break;
  406.         }
  407.         case TYPE_STRING:
  408.             /* test nil string -> create, like files */
  409.             /* verify access */
  410.             return -1;
  411.     }
  412.     return plock( port );
  413. }
  414.  
  415. /************************************************************************/
  416. /* Close a port                             */
  417. /************************************************************************/
  418. void    pclose( REGPTR port )
  419. {
  420.     PORT    far    *p;
  421.  
  422.     punlock( port );    
  423.  
  424.     p = ®2c(port)->port;
  425.     if( (p->flags & PORT_TYPE) == TYPE_FILE )
  426.         close( p->handle );
  427. }
  428.  
  429. /************************************************************************/
  430. /* Set one of the port attributes                    */
  431. /*                                    */
  432. /************************************************************************/
  433. int    port_set_attribute( REGPTR port, REGPTR symbol, REGPTR value )
  434. {
  435.     PORT    far    *p;
  436.     KIND_OF_PORT    type;
  437.     KIND_OF_MODE    read_mode, write_mode, new_mode;
  438.     KIND_OF_ATTRIB    attr;
  439.  
  440.     if( get_port(port, OUTPUT_PORT) )
  441.     {
  442.         set_src_error("PORT-SET-ATTRIBUTE!", 2, port, symbol);
  443.         return    -1;
  444.     } else
  445.         *port =    tmp_reg;
  446.  
  447.     attr = (KIND_OF_ATTRIB) match( symbol, attributes );
  448.     p = ®2c(port)->port;
  449.     port_get_info( p, &type, &read_mode, &write_mode );
  450.  
  451.     switch( attr ) {
  452.         case READ:
  453.             new_mode = (KIND_OF_MODE) match( value, modes );
  454.             p = ®2c(port)->port;
  455.             p->flags &= ~READ_MODE;
  456.             switch( new_mode ) {
  457.                 case CLOSED:
  458.                     p->flags |= READ_CLOSED; break;
  459.                 case PROTECTED:
  460.                     p->flags |= READ_PROTECTED; break;
  461.                 case SHARED:
  462.                     p->flags |= READ_SHARED; break;
  463.                 case EXCLUSIVE:
  464.                     p->flags |= READ_EXCLUSIVE;
  465.             }
  466.             if( read_mode != CLOSED || write_mode != CLOSED )
  467.                 pclose( port );
  468.             if( new_mode != CLOSED || write_mode != CLOSED )
  469.                 if( popen( port ) ) {
  470.                     p->flags &= ~PORT_OPEN;
  471.                     return -1;
  472.                 }
  473.             intern( port, modes[read_mode], strlen(modes[read_mode]) );
  474.             return 0;
  475.         case WRITE:
  476.             new_mode = (KIND_OF_MODE) match( value, modes );
  477.             p = ®2c(port)->port;
  478.             p->flags &= ~WRITE_MODE;
  479.             switch( new_mode ) {
  480.                 case CLOSED:
  481.                     p->flags |= WRITE_CLOSED; break;
  482.                 case PROTECTED:
  483.                     p->flags |= WRITE_PROTECTED; break;
  484.                 case SHARED:
  485.                     p->flags |= WRITE_SHARED; break;
  486.                 case EXCLUSIVE:
  487.                     p->flags |= WRITE_EXCLUSIVE; break;
  488.             }
  489.             if( read_mode != CLOSED || write_mode != CLOSED )
  490.                 pclose( port );
  491.             if( read_mode != CLOSED || new_mode != CLOSED )
  492.                 if( popen( port ) ) {
  493.                     p->flags &= ~PORT_OPEN;
  494.                     return -1;
  495.                 }
  496.             intern( port, modes[write_mode], strlen(modes[write_mode]) );
  497.             return 0;
  498.         case BINARY:
  499.             bool2scm( port, p->flags & PORT_BINARY );
  500.             if( scm2bool(value) )
  501.                 p->flags |= PORT_BINARY;
  502.             else
  503.                 p->flags &= ~PORT_BINARY;
  504.             return 0;
  505.         case WRAP:
  506.             bool2scm( port, p->flags & PORT_WRAP );
  507.             if( scm2bool(value) )
  508.                 p->flags |= PORT_WRAP;
  509.             else
  510.                 p->flags &= ~PORT_WRAP;
  511.             return 0;
  512.         case NEW:
  513.             bool2scm( port, p->flags & PORT_NEW );
  514.             if( scm2bool(value) )
  515.                 p->flags |= PORT_NEW;
  516.             else
  517.                 p->flags &= ~PORT_NEW;
  518.             return 0;
  519.         case TRANSCRIPT:
  520.             bool2scm( port, p->flags & PORT_TRANSCRIPT );
  521.             if( scm2bool(value) )
  522.                 p->flags |= PORT_TRANSCRIPT;
  523.             else
  524.                 p->flags &= ~PORT_TRANSCRIPT;
  525.             return 0;
  526.         case LOCK:
  527.             bool2scm( port, p->flags & PORT_LOCKED );
  528.             if( scm2bool(value) ) {
  529.                 if( plock( port ) )
  530.                     return -1;
  531.                 else
  532.                     p->flags |= PORT_LOCKED;
  533.             } else {
  534.                 p->flags &= ~PORT_LOCKED;
  535.                 punlock( port );
  536.             }
  537.             return 0;
  538.         case HANDLE:
  539.             if ( type == IS_SOFTWARE ) {
  540.                 long2int( port, p->handle );
  541.                 p->handle = int2long( value );
  542.                 return 0;
  543.             } else    break;
  544.         case BORDER:
  545.             if ( type == IS_WINDOW || type == IS_SOFTWARE ) {
  546.                 long2int( port, p->border );
  547.                 p->border = int2long( value );
  548.                 if( type == IS_WINDOW && p->border != 0xffff ) {
  549.                     char    *string;
  550.  
  551.                     load( &tmp_reg, &(p->ptr) );
  552.                     string = string_asciz(&tmp_reg);
  553.                     zborder( p->ulline, p->ulcol, p->nlines,
  554.                         p->ncols, p->border, string);
  555.                     rlsstr(string);
  556.                 }
  557.                 return 0;
  558.             } else    break;
  559.         case TEXT:
  560.             if ( type == IS_WINDOW || type == IS_SOFTWARE ) {
  561.                 long2int( port, p->text );
  562.                 p->text = int2long( value );
  563.                 return 0;
  564.             } else    break;
  565.         case LINE: {
  566.             long    old = p->curline, val = int2long(value);
  567.             if ( val < 0 )
  568.                 val += p->nlines;
  569.  
  570.             if ( val > 0 && val < p->nlines ) {
  571.                 p->curline = val;
  572.                 if( type == IS_FILE )
  573.                     lseek( p->handle, pcurrent(p), SEEK_SET );
  574.                 p->bufpos = p->bufend;
  575.                 long2int( port, old );
  576.                 return 0;
  577.             }
  578.         }
  579.         case COLUMN: {
  580.             long    old = p->curcol, val = int2long(value);
  581.             if ( val < 0 )
  582.                 val += p->ncols;
  583.  
  584.             if ( val > 0 && val < p->ncols ) {
  585.                 p->curcol = val;
  586.                 if( type == IS_FILE )
  587.                     lseek( p->handle, pcurrent(p), SEEK_SET );
  588.                 p->bufpos = p->bufend;
  589.                 long2int( port, old );
  590.                 return 0;
  591.             }
  592.         }
  593.         case TOP: {
  594.             int    old = p->ulline, val = int2long(value);
  595.  
  596.             punlock( port );
  597.             if( val < 0 )    switch( type ) {
  598.                 case IS_WINDOW:
  599.                     val += get_max_rows();
  600.                     break;
  601.                 case IS_FILE:
  602.                     val += ( filelength(p->handle) / plength(p) );
  603.                     break;
  604.                 case IS_STRING:
  605.                     val += ( regstrlen(&(REG)p->ptr) / plength(p) );
  606.                     p = ®2c(port)->port;
  607.             };
  608.             p->ulline = val + 1;
  609.             if( type == IS_FILE )
  610.                 lseek( p->handle, pcurrent(p), SEEK_SET );
  611.             plock( port );
  612.             p->bufpos = p->bufend;
  613.             long2int( port, old );
  614.             return 0;
  615.         }
  616.         case LEFT: {
  617.             int    old = p->ulcol, val = int2long(value);
  618.  
  619.             punlock( port );
  620.             if( val < 0 )    switch( type ) {
  621.                 case IS_WINDOW:
  622.                     val += get_max_cols();
  623.                     break;
  624.                 case IS_FILE:
  625.                     val += filelength(p->handle);
  626.                     break;
  627.                 case IS_STRING:
  628.                     val += regstrlen(&(REG)p->ptr);
  629.                     p = ®2c(port)->port;
  630.             };
  631.             p->ulcol = val + 1;
  632.             if( type == IS_FILE )
  633.                 lseek( p->handle, pcurrent(p), SEEK_SET );
  634.             plock( port );
  635.             p->bufpos = p->bufend;
  636.             long2int( port, old );
  637.             return 0;
  638.         }
  639.         case HEIGHT: {
  640.             int    old = p->nlines, val = int2long(value);
  641.  
  642.             if( val >= 0 ) {
  643.                 punlock( port );
  644.                 p->nlines = val;
  645.                 if( p->curline >val ) {
  646.                     p->curline = val;
  647.                     if( type == IS_FILE )
  648.                         lseek( p->handle, pcurrent(p), SEEK_SET );
  649.                 }
  650.                 plock( port );
  651.                 p->bufpos = p->bufend;
  652.                 long2int( port, old );
  653.                 return 0;
  654.             }
  655.         }
  656.         case WIDTH: {
  657.             int    old = p->ncols, val = int2long(value);
  658.  
  659.             if( val >= 0 ) {
  660.                 punlock( port );
  661.                 p->ncols = val;
  662.                 if( p->curcol >val ) {
  663.                     p->curcol = val;
  664.                     if( type == IS_FILE )
  665.                         lseek( p->handle, pcurrent(p), SEEK_SET );
  666.                 }
  667.                 plock( port );
  668.                 p->bufpos = p->bufend;
  669.                 long2int( port, old );
  670.                 return 0;
  671.             }
  672.         }
  673.     }
  674.     set_src_error("PORT-SET-ATTRIBUTE!", 3, port, symbol, value);
  675.     return -1;
  676. }
  677.  
  678. /************************************************************************/
  679. /* Match a symbolic parameter to a string table                */
  680. /************************************************************************/
  681. int    match( REGPTR symbol, char **str )
  682. {
  683.     int    count = 0;
  684.  
  685.     if (ptype[CORRPAGE(symbol->page)] == SYMTYPE)
  686.         while( *str )
  687.         {
  688.             intern( &tmp_reg, *str, strlen(*str) );
  689.             if ( eq( &tmp_reg, symbol ) )
  690.                 return    count;
  691.             count++;
  692.             str++;
  693.         }
  694.     str++;
  695.     set_src_error(*str, 1, symbol);
  696.     scheme_error();        /* we won't return from this call */
  697.     return -1;
  698. }
  699.  
  700.  
  701.  
  702. ///////////////////////////////////////////////////////////////////////////
  703. //////// Following procedures are to be destroyed ! ///////////////////////
  704. ///////////////////////////////////////////////////////////////////////////
  705.  
  706. /************************************************************************/
  707. /* Open a Port                                */
  708. /************************************************************************/
  709. #define FILE_NOT_FOUND    2    /* MS-DOS error code */
  710. #define NON_RESTART    1    /* Operation not restartable */
  711. #define READ        0
  712. #define WRITE        1
  713. #define    APPEND        2
  714.  
  715. int    spopen(REGPTR file, REGPTR mode)
  716. {
  717.     extern int    prn_handle;    /* handle assigned to printer */
  718.     int        direction;    /* 'read, 'write, 'append code */
  719.     unsigned    disp;
  720.     int        handle;
  721.     int        i;
  722.     int        len;    /* length of file's pathname (plus 1) */
  723.      unsigned    page;
  724.     int        retstat = 0;
  725.     int        stat;    /* status returned from open request */
  726.     char        *string;    /* file pathname buffer pointer */
  727.     unsigned long    fsize;    /* file size - dbs */
  728.     SCHEMEOBJ    o;
  729.  
  730.     /* identify mode value */
  731.     if ((direction = get_mode(mode)) == -1)
  732.         goto src_err;
  733.  
  734.     page = CORRPAGE(file->page);
  735.     disp = file->disp;
  736.     o = reg2c(file);
  737.  
  738.     switch (ptype[page]) {
  739.     case STRTYPE:
  740.         len = o->string.len;
  741.         if (len < 0)    /* Adjust for small string */
  742.             len = len + BLK_OVHD;
  743.         else
  744.             len = len - BLK_OVHD;
  745.  
  746.         if (!(string = (char *) malloc(len + 1)))
  747.             malloc_error("spopen");
  748.         get_str(string, page, disp);
  749.         string[len] = '\0';
  750.         for (i = 0; i < len; i++)
  751.             string[i] = toupper(string[i]);
  752.         switch (direction) {
  753.         case READ:
  754.             if ((stat = zopen(&handle, string, direction, &fsize)) != 0) {
  755.         open_error:
  756.                 rlsstr(string);
  757.                 stat += (IO_ERROR_START - 1);
  758.                 dos_error(NON_RESTART, stat, file);
  759.             }
  760.             break;
  761.         case WRITE:
  762.             if ((stat = zcreate(&handle, string)) != 0)
  763.                 goto open_error;
  764.             if (((stat = strcmp(string, "PRN")) == 0) ||
  765.                 ((stat = strcmp(string, "LST")) == 0))
  766.                 prn_handle = handle;
  767.             break;
  768.         case APPEND:
  769.             if ((stat = zopen(&handle, string, direction, &fsize)) == FILE_NOT_FOUND) {
  770.                 if ((stat = zcreate(&handle, string)) != 0)
  771.                     goto open_error;
  772.                 break;
  773.             }
  774.             if (stat)
  775.                 goto open_error;
  776.             /*
  777.              * do { if (zread(handle, buffer, &length)) break; }
  778.              * while (length);
  779.              */
  780.             if (((stat = strcmp(string, "PRN")) == 0) ||
  781.                 ((stat = strcmp(string, "LST")) == 0))
  782.                 break;
  783.             mov_fptr(handle);
  784.         }
  785.         tmp_reg = *file;
  786.         alloc_block(file, PORTTYPE, sizeof(PORT)-BLK_OVHD );
  787.         page = CORRPAGE(file->page);
  788.         disp = file->disp;
  789.         zero_blk(page, disp);
  790.         o = reg2c(file);
  791.  
  792.         if (direction == WRITE)
  793.             o->port.ulline = 1;
  794.         else if (direction == APPEND) {    /* update the chunk# and
  795.                          * buffer position */
  796.             o->port.ulline = (fsize >> 8) + 1;
  797.             o->port.bufpos = fsize & 0xff;
  798.             direction = WRITE;    /* unsets read flag - dbs */
  799.         }
  800.         switch (direction) {
  801.         case READ:
  802.             o->port.flags = READ_EXCLUSIVE; break;
  803.         case WRITE:
  804.             o->port.flags = WRITE_EXCLUSIVE; break;
  805.         case APPEND:
  806.             o->port.flags = READ_EXCLUSIVE + WRITE_EXCLUSIVE; break;
  807.         }
  808.         o->port.flags |= TYPE_FILE;
  809.         o->port.ncols = 80;
  810.         o->port.handle = handle;
  811.         o->port.nlines = fsize >> 16;
  812.         o->port.border = fsize & 0xffff;
  813.         /* put pointer to pathname into port object */
  814.         o->port.ptr.page = tmp_reg.page;
  815.         o->port.ptr.disp = tmp_reg.disp;
  816.         rlsstr(string);
  817.         break;
  818.  
  819.     case SYMTYPE:
  820.         if (file->page != console_reg.page || file->page != console_reg.disp)
  821.             goto src_err;
  822.         break;
  823.  
  824.     case PORTTYPE:
  825.         if( o->port.flags & (READ_EXCLUSIVE | WRITE_EXCLUSIVE) )
  826.             break;
  827.  
  828. src_err:
  829.     default:
  830.         set_src_error("OPEN-PORT", 2, file, mode);
  831.         retstat = -1;
  832.     }
  833.     return    retstat;
  834. }
  835.  
  836. /************************************************************************/
  837. /* Close a Port                                 */
  838. /************************************************************************/
  839. int    spclose(REGPTR port)
  840. {
  841.     SCHEMEOBJ    o;
  842.  
  843.     if( get_port(port, INPUT_PORT) )
  844.     {
  845.         set_src_error("CLOSE-PORT", 1, port);
  846.         return    -1;
  847.     }
  848.  
  849.     o = reg2c(&tmp_reg);
  850.  
  851.     if( o->port.flags & PORT_OPEN && (o->port.flags & PORT_TYPE) == TYPE_FILE )
  852.     {
  853.         int    stat;
  854.  
  855.         if ((stat = zclose(o->port.handle)) != 0)
  856.         {
  857.             stat += (IO_ERROR_START - 1);
  858.     io_err:
  859.             dos_error(NON_RESTART, stat, port);
  860.         }
  861.         o->port.bufpos = BUFFSIZE;
  862.  
  863.         o->port.flags &= ~(READ_MODE | WRITE_MODE);
  864.         return    1;
  865.     }
  866.     o->port.flags &= ~(READ_MODE | WRITE_MODE);
  867.     return    0;
  868. }
  869.  
  870. /************************************************************************/
  871. /* Local Support:    Determine Input/Output Mode Value        */
  872. /************************************************************************/
  873. int    get_mode(REGPTR reg)
  874. {
  875.     char    *modes[] = {"READ", "WRITE", "APPEND", NULL };
  876.  
  877.     if (ptype[CORRPAGE(reg->page)] == SYMTYPE)
  878.     for( int i = 0; modes[i]; i++ )
  879.     {
  880.         intern(&tmp_reg, modes[i], strlen(modes[i]) );
  881.         if (tmp_reg.disp == reg->disp && tmp_reg.page == reg->page)
  882.             return    i;
  883.     }
  884.     return    -1;
  885. }
  886.