home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / port.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-21  |  21.2 KB  |  852 lines
  1. /*
  2.  *
  3.  *  p o r t . c            -- ports implementation
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *            Author: Erick Gallesio [eg@unice.fr]
  21.  *    Creation date: 17-Feb-1993 12:27
  22.  * Last file update: 21-Jul-1996 17:48
  23.  *
  24.  */
  25. #ifndef WIN32
  26. #  include <sys/ioctl.h>
  27. #  include <sys/time.h>
  28. #  include <ctype.h>
  29. #endif
  30.  
  31. #ifdef HAVE_SYS_SELECT_H
  32. #include <sys/select.h>    /* This seems to be useful only for AIX */
  33. #endif
  34.  
  35. #ifndef NO_FD_SET
  36. #   define SELECT_MASK fd_set
  37. #else
  38. #   ifndef _AIX
  39.     typedef long fd_mask;
  40. #   endif
  41. #   if defined(_IBMR2)
  42. #    define SELECT_MASK void
  43. #   else
  44. #    define SELECT_MASK int
  45. #   endif
  46. #endif
  47.  
  48. #include "stk.h"
  49.  
  50. #ifdef WIN32
  51.   /* Provide substitute functions dor WIN32 */
  52.   FILE *popen(char *cmd, char *mode) 
  53.   {    
  54.     /* Returning NULL will yield an error */
  55.     return NULL;
  56.   }
  57.   void pclose(FILE *f)
  58.   {}
  59. #endif
  60.  
  61. /* external vars */
  62. SCM STk_curr_iport, STk_curr_oport, STk_curr_eport, STk_eof_object;
  63.  
  64.  
  65. SCM STk_Cfile2port(char *name, FILE *f, int type, int flags)
  66. {
  67.   SCM z;
  68.  
  69.   NEWCELL(z, type);
  70.   z->storage_as.port.p   = (struct port_descr *) 
  71.                     must_malloc(sizeof(struct port_descr));
  72.   PORT_FILE(z)           = f;
  73.   PORT_FLAGS(z)          = flags;
  74.   PORT_REVENT(z)     = Ntruth;
  75.   PORT_WEVENT(z)     = Ntruth;
  76.   PORT_NAME(z)           = (char *) must_malloc(strlen(name)+1);
  77.   strcpy(PORT_NAME(z), name);
  78.  
  79.   return z;
  80. }
  81.  
  82. static SCM makeport(char *name, int type, char *mode, int error)
  83. {
  84.   SCM z     = Ntruth;
  85.   int flags = 0;
  86.   FILE *f;
  87.   char *full_name;
  88.  
  89.   STk_disallow_sigint();
  90.   if (strncmp(name, "| ", 2)) {
  91.     full_name = CHARS(STk_internal_expand_file_name(name));
  92.  
  93.     if ((f = fopen(full_name, mode)) == NULL) {
  94.       if (error) Err("could not open file", STk_makestring(name));
  95.       else goto Out;
  96.     }
  97.   }
  98.   else {
  99.     full_name = name;
  100.     if ((f = popen(name+1, mode)) == NULL) {
  101.       flags = PIPE_PORT;
  102.       if (error) Err("could not create pipe", STk_makestring(name));
  103.       else goto Out;
  104.     }    
  105.   }
  106.  
  107.   z = STk_Cfile2port(full_name, f, type, flags);
  108.  
  109. Out:
  110.   STk_allow_sigint();
  111.   return(z);
  112. }
  113.   
  114. static SCM verify_port(char *who, SCM port, int mode)
  115. {
  116.   char buff[100];
  117.  
  118.   if (port == UNBOUND)     /* test write 'cause of flush */
  119.     port = (mode&F_WRITE) ? STk_curr_oport: STk_curr_iport; 
  120.  
  121.   if (!(INP(port) || OUTP(port))) {
  122.     sprintf(buff, "%s: bad port", who);
  123.     Err(buff, port);
  124.   }
  125.   if (PORT_FLAGS(port) & PORT_CLOSED) {
  126.     sprintf(buff, "%s: port is closed", who);
  127.     Err(buff, port);
  128.   }
  129.   if ((mode & F_READ)  && INP(port))  return port; /* not else. It can be both */
  130.   if ((mode & F_WRITE) && OUTP(port)) return port;
  131. Error:
  132.   sprintf(buff, "%s: bad port", who);
  133.   Err(buff, port);
  134. }
  135.  
  136. static void closeport(SCM port)
  137. {
  138.   if (PORT_FLAGS(port) & PORT_CLOSED) return;
  139.  
  140.   STk_disallow_sigint();
  141.   
  142.   if (IPORTP(port) || OPORTP(port)) {                /* Not a string port */
  143. #ifdef USE_TK
  144.     /* For pipe and file ports, delete the fileevent associated to it (if any) */
  145.     Tcl_DeleteFileHandler(Tcl_GetFile((ClientData) fileno(PORT_FILE(port)), 
  146.                     TCL_UNIX_FD));
  147. #endif
  148.     if (PORT_FLAGS(port) & PIPE_PORT)               /* Pipe port */
  149.       pclose(PORT_FILE(port));
  150.     else                             /* File port */
  151.       fclose(PORT_FILE(port));
  152.   }
  153.   PORT_FLAGS(port) |= PORT_CLOSED;
  154.   STk_allow_sigint();
  155. }
  156.  
  157. void STk_freeport(SCM port)
  158. {
  159.   STk_disallow_sigint();
  160.   closeport(port);
  161.   free(PORT_NAME(port));
  162.   free(port->storage_as.port.p);
  163.   STk_allow_sigint();
  164. }
  165.  
  166. void STk_init_standard_ports(void)
  167. {
  168.   STk_curr_iport = STk_Cfile2port("*stdin*",  STk_stdin, tc_iport, 0);  
  169.   STk_gc_protect(&STk_curr_iport);
  170.   
  171.   STk_curr_oport = STk_Cfile2port("*stdout*", STk_stdout, tc_oport, 0);
  172.   STk_gc_protect(&STk_curr_oport);
  173.  
  174.   STk_curr_eport = STk_Cfile2port("*stderr*", STk_stderr, tc_oport, 0);
  175.   STk_gc_protect(&STk_curr_eport);
  176.  
  177.   
  178.   NEWCELL(STk_eof_object, tc_eof);
  179.   STk_gc_protect(&STk_eof_object);
  180.  
  181.   STk_line_counter = 1;
  182.   STk_current_filename = UNBOUND;    /* Ubound <=> stdin */
  183.   STk_gc_protect(&STk_current_filename);
  184. }
  185.  
  186. /******************************************************************************
  187.  *
  188.  * L O A D  stuff
  189.  *
  190.  ******************************************************************************/
  191. static int do_load(char *full_name)
  192. {
  193.   FILE *f;
  194.   int c;
  195.  
  196.   if (!STk_dirp(full_name)) {
  197.      f = fopen(full_name, "r");
  198.      
  199.      if (f == NULL) return 0;
  200.  
  201.      if (VCELL(Intern(LOAD_VERBOSE)) != Ntruth)
  202.        fprintf(STk_stderr, ";; Loading file \"%s\"\n", full_name);
  203.      
  204.      /* Just read one character. Assume that file is an object if this 
  205.       * character is a control one. Here, I don't try to see if the file magic 
  206.       * number has a particular value, since I'm not nure that all platforms
  207.       * use identical conventions 
  208.       */
  209.      c = Getc(f); Ungetc(c, f);
  210.      if (c != EOF &&  ((iscntrl(c)&& c!= '\n') || !isascii(c))) {
  211.        fclose(f);
  212.        STk_load_object_file(full_name);
  213.      }
  214.      else {
  215.        /* file seems not to be an object file. Try to load it as a Scheme file */
  216.        jmp_buf jb, *prev_jb = Top_jmp_buf;
  217.        long prev_context    = Error_context;
  218.        SCM previous_file, form;
  219.        int k, previous_line;
  220.       
  221.        /* Save info about current line and file */
  222.        previous_file        = STk_current_filename;
  223.        previous_line        = STk_line_counter;
  224.        STk_line_counter     = 1;
  225.        STk_current_filename = STk_makestring(full_name);
  226.  
  227.        /* save normal error jmpbuf so that eval error don't lead to toplevel */
  228.        /* This permits to close the opened file in case of error */
  229.        /* If in a "catch", keep the ERR_IGNORED bit set */
  230.        if ((k = setjmp(jb)) == 0) {
  231.      Top_jmp_buf   = &jb;
  232.  
  233.      for( ; ; ) {
  234.        form = STk_readf(f, FALSE);
  235.        if EQ(form, STk_eof_object) break;
  236.        STk_eval(form, NIL);
  237.      }
  238.        }
  239.        fclose(f);
  240.  
  241.        Top_jmp_buf   = prev_jb;
  242.        Error_context = prev_context;
  243.        if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
  244.  
  245.        /* No error: restore info about current line and file */
  246.        STk_current_filename = previous_file;
  247.        STk_line_counter        = previous_line;
  248.      }
  249.      if (VCELL(Intern(LOAD_VERBOSE)) != Ntruth)
  250.        fprintf(STk_stderr, ";; File \"%s\" loaded\n", full_name);
  251.      return 1;
  252.   }
  253.   /* No file found */
  254.   return 0;
  255. }
  256.  
  257. static int try_loadfile(char *prefix, char *fname, SCM suffixes)
  258. {
  259.   char full_name[MAX_PATH_LENGTH], *s;
  260.  
  261.   /* First try to load without suffix */
  262.   if (strlen(prefix) + strlen(fname) + 2 >= MAX_PATH_LENGTH) goto TooLong;
  263.   sprintf(full_name, "%s%s%s", prefix, (*prefix ? "/": ""), fname);
  264.   
  265.   if (do_load(full_name)) return 1;
  266.  
  267.   /* Now try to load file with suffix */
  268.   for ( ; NNULLP(suffixes); suffixes = CDR(suffixes)) {
  269.     /* We are sure that suffixes is a well formed list (ensured by loadfile) */
  270.     if (NSTRINGP(CAR(suffixes))) Err("load: bad suffix component", CAR(suffixes));
  271.     s = CHARS(CAR(suffixes));
  272.  
  273.     if (strlen(prefix)+strlen(fname)+strlen(s)+3 >= MAX_PATH_LENGTH) goto  TooLong;
  274.     sprintf(full_name, "%s%s%s.%s", prefix, (*prefix ? "/": ""), fname, s);
  275.  
  276.     if (do_load(full_name)) return 1;
  277.   }
  278.   
  279.   /* No file loaded */
  280.   return 0;
  281.  
  282. TooLong:
  283.     Err("load: Filename too long", NIL);
  284. }
  285.  
  286. SCM STk_loadfile(char *fname, int err_if_absent)
  287. {
  288.   int len;
  289.   SCM load_path, load_suffixes;     
  290.   
  291.   len           = strlen(fname);
  292.   load_path     = VCELL(Intern(LOAD_PATH));
  293.   load_suffixes = VCELL(Intern(LOAD_SUFFIXES));
  294.   
  295.   if (STk_llength(load_path)<0)     Err("load: bad loading path", load_path);
  296.   if (STk_llength(load_suffixes)<0) Err("load: bad set of suffixes", load_suffixes);
  297.  
  298. #ifdef WIN32
  299.   if ((len > 0 && (fname[0] == '/' || fname[0] == '\\' || fname[0] == '~')) ||
  300.       (len > 1 && fname[0] == '.' && (fname[1] == '/' || fname[1] == '\\')) ||
  301.       (len > 2 && fname[0] == '.' && fname[1] == '.' && (fname[2] == '/' ||
  302.                              fname[2]=='\\'))   ||
  303.       (len > 1 && isalpha(fname[0]) && fname[1]==':')) {
  304. #else
  305.   if ((len > 0 && (fname[0] == '/' || fname[0] == '~')) ||
  306.       (len > 1 && fname[0] == '.' && fname[1] == '/') ||
  307.       (len > 2 && fname[0] == '.' && fname[1] == '.' && fname[2] == '/')) {
  308. #endif
  309.     
  310.     if (fname[0] == '~') 
  311.       fname = CHARS(STk_internal_expand_file_name(fname));
  312.  
  313.     if (try_loadfile("", fname, load_suffixes))
  314.       return(err_if_absent? UNDEFINED: Truth);
  315.   }
  316.   else {
  317.     /* Use *load-path* for loading file */
  318.     for ( ; NNULLP(load_path); load_path = CDR(load_path)) {
  319.       if (NSTRINGP(CAR(load_path))) 
  320.     Err("load: bad loading path component", CAR(load_path));
  321.  
  322.       if (try_loadfile(CHARS(CAR(load_path)), fname, load_suffixes))
  323.     return(err_if_absent? UNDEFINED: Truth);
  324.     }
  325.   }
  326.  
  327.     /* If we are here, we have been unable to load a file. Report err if needed */
  328.   if (err_if_absent)
  329.     Err("load: cannot open file", STk_makestring(fname));
  330.   return Ntruth; 
  331. }
  332.  
  333.  
  334. PRIMITIVE STk_input_portp(SCM port)
  335. {
  336.   return IPORTP(port)? Truth: Ntruth;
  337. }
  338.  
  339. PRIMITIVE STk_output_portp(SCM port)
  340. {
  341.   return OPORTP(port)? Truth: Ntruth;
  342. }
  343.  
  344. PRIMITIVE STk_current_input_port(void)
  345. {
  346.   return STk_curr_iport;
  347. }
  348.  
  349. PRIMITIVE STk_current_output_port(void)
  350. {
  351.   return STk_curr_oport;
  352. }
  353.  
  354. PRIMITIVE STk_current_error_port(void)
  355. {
  356.   return STk_curr_eport;
  357. }
  358.  
  359. PRIMITIVE STk_with_input_from_file(SCM string, SCM thunk)
  360. {
  361.   jmp_buf env, *prev_env = Top_jmp_buf;
  362.   SCM result, prev_iport = STk_curr_iport;
  363.   int prev_context      = Error_context;
  364.   int k;
  365.  
  366.   if (NSTRINGP(string))     Err("with-input-from-file: bad string", string);
  367.   if (!STk_is_thunk(thunk)) Err("with-input-from-file: bad thunk", thunk);
  368.  
  369.   STk_curr_iport = UNBOUND;     /* will not be changed if opening fails */
  370.  
  371.   if ((k = setjmp(env)) == 0) {
  372.     Top_jmp_buf     = &env;
  373.     STk_curr_iport  = makeport(CHARS(string), tc_iport, "r", TRUE);
  374.     result          = Apply(thunk, NIL);
  375.   }
  376.   /* restore normal error jmpbuf  and current input port*/
  377.   if (STk_curr_iport != UNBOUND) closeport(STk_curr_iport);
  378.   STk_curr_iport = prev_iport;
  379.   Top_jmp_buf    = prev_env;
  380.   Error_context  = prev_context;
  381.  
  382.   if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
  383.   return result;
  384. }
  385.  
  386. PRIMITIVE STk_with_output_to_file(SCM string, SCM thunk)
  387. {
  388.   jmp_buf env, *prev_env = Top_jmp_buf;
  389.   SCM result, prev_oport = STk_curr_oport;
  390.   int prev_context       = Error_context;
  391.   int k;
  392.  
  393.   if (NSTRINGP(string))     Err("with-output-to-file: bad string", string);
  394.   if (!STk_is_thunk(thunk)) Err("with-output-to-file: bad thunk", thunk);
  395.  
  396.   STk_curr_oport = UNBOUND;        /* will not be changed if opening fails */
  397.  
  398.   if ((k = setjmp(env)) == 0) {
  399.     Top_jmp_buf     = &env;
  400.     STk_curr_oport  = makeport(CHARS(string), tc_oport, "w", TRUE);
  401.     result          = Apply(thunk, NIL);
  402.   }
  403.   /* restore normal error jmpbuf  and current output port*/
  404.   if (STk_curr_oport != UNBOUND) closeport(STk_curr_oport);
  405.   STk_curr_oport = prev_oport;
  406.   Top_jmp_buf    = prev_env;
  407.   Error_context  = prev_context;
  408.  
  409.   if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
  410.   return result;
  411. }
  412.  
  413.  
  414. PRIMITIVE STk_open_input_file(SCM filename)
  415. {
  416.   if (NSTRINGP(filename)) Err("open-input-file: bad file name", filename);
  417.   return makeport(CHARS(filename), tc_iport, "r", TRUE);
  418. }
  419.  
  420. PRIMITIVE STk_open_output_file(SCM filename)
  421. {
  422.   if (NSTRINGP(filename)) Err("open-output-file: bad file name", filename);
  423.   return makeport(CHARS(filename), tc_oport, "w", TRUE); 
  424. }
  425.  
  426. PRIMITIVE STk_close_input_port(SCM port)
  427. {
  428.   if (!INP(port)) Err("close-input-port: not an input port", port);
  429.   closeport(port);
  430.  
  431.   return UNDEFINED;
  432. }
  433.  
  434. PRIMITIVE STk_close_output_port(SCM port)
  435. {
  436.   if (!OUTP(port)) Err("close-output-port: not an output port", port);
  437.   closeport(port);
  438.  
  439.   return UNDEFINED;
  440. }
  441.  
  442. PRIMITIVE STk_read(SCM port)
  443. {
  444.   port = verify_port("read", port, F_READ);
  445.   return(STk_readf(PORT_FILE(port), FALSE));
  446. }
  447.  
  448. PRIMITIVE STk_read_char(SCM port)
  449. {
  450.   int c;
  451.  
  452.   port = verify_port("read-char", port, F_READ);
  453.   c = Getc(PORT_FILE(port));
  454.   return (c == EOF) ? STk_eof_object : STk_makechar(c);
  455. }
  456.  
  457. PRIMITIVE STk_peek_char(SCM port)
  458. {
  459.   int c;
  460.  
  461.   port = verify_port("peek-char", port, F_READ);
  462.   c = Getc(PORT_FILE(port));
  463.   Ungetc(c, PORT_FILE(port));
  464.   return (c == EOF) ? STk_eof_object : STk_makechar(c);
  465. }
  466.  
  467. PRIMITIVE STk_eof_objectp(SCM obj)
  468. {
  469.   return (obj == STk_eof_object)? Truth : Ntruth;
  470. }
  471. #ifdef max
  472. #undef max
  473. #endif
  474. #define max(a,b) ((a)>(b)? (a) : (b))
  475.  
  476. #ifdef _STDIO_USES_IOSTREAM  /* GNU libc */
  477. #  if defined(_IO_STDIO_H) || defined (linux)
  478. #    define READ_DATA_PENDING(fp) (max(0,(fp)->_IO_read_end - (fp)->_IO_read_ptr))
  479. #  else
  480. #    define READ_DATA_PENDING(fp) (max(0,(fp)->_egptr - (fp)->_gptr))
  481. #  endif
  482. #endif
  483. #if (!defined (READ_DATA_PENDING)) && defined __SLBF
  484. #  define READ_DATA_PENDING(fp) (max(0,fp->_r))
  485. #endif
  486. #if !defined (READ_DATA_PENDING)
  487. #  define READ_DATA_PENDING(fp) (fp->_cnt)
  488. #endif
  489.  
  490. #ifdef WIN32
  491. PRIMITIVE STk_char_readyp(SCM port) 
  492. {
  493.   STk_panic("Not yet implemented!");
  494. }
  495. #else
  496. PRIMITIVE STk_char_readyp(SCM port) 
  497. { 
  498.   port = verify_port("char-ready?", port, F_READ);
  499.   if (Eof(PORT_FILE(port))) return Truth;
  500.   if (ISPORTP(port)) /* !eof -> */  return Truth;
  501.   else {
  502.     /* First, see if characters are available in the buffer */
  503.     if (READ_DATA_PENDING(PORT_FILE(port)))
  504.       return Truth;
  505.  
  506. #ifdef HAVE_SELECT
  507.     {
  508.       SELECT_MASK readfds;
  509.       struct timeval timeout;
  510.       int f = fileno(PORT_FILE(port));
  511.  
  512.       FD_ZERO(&readfds); 
  513.       FD_SET(f, &readfds);
  514.       timeout.tv_sec = timeout.tv_usec = 0;
  515.       return (select(f+1, &readfds, NULL, NULL, &timeout)) ? Truth : Ntruth;
  516.     }
  517. #else
  518. #  ifdef FIONREAD
  519.    {
  520.      int result;
  521.  
  522.      ioctl(fileno(PORT_FILE(port)), FIONREAD, &result);
  523.      return result ? Truth : Ntruth;
  524.    }
  525. #  else
  526.    return Truth;
  527. #  endif
  528. #endif
  529.   }
  530. }
  531. #endif
  532.  
  533. PRIMITIVE STk_write(SCM expr, SCM port)
  534. {
  535.   port = verify_port("write", port, F_WRITE);
  536.   STk_print(expr, port, WRT_MODE);
  537.   return UNDEFINED;
  538. }
  539.  
  540. PRIMITIVE STk_display(SCM expr, SCM port)
  541. {
  542.   port = verify_port("display", port, F_WRITE);
  543.   STk_print(expr, port, DSP_MODE);
  544.   return UNDEFINED;
  545. }
  546.  
  547. PRIMITIVE STk_newline(SCM port)
  548. {
  549.   port = verify_port("newline", port, F_WRITE);
  550.   Putc('\n', PORT_FILE(port));
  551.   return UNDEFINED;
  552. }
  553.  
  554. PRIMITIVE STk_write_char(SCM c, SCM port)
  555. {
  556.   if (NCHARP(c)) Err("write-char: not a character", c);
  557.   port = verify_port("write-char", port, F_WRITE);
  558.   Putc(CHAR(c), PORT_FILE(port));
  559.   return UNDEFINED;
  560. }
  561.  
  562. /*
  563.  * The name `scheme_load' is needed because of a symbol table conflict
  564.  * in libc. This is bogus, but what do you do.
  565.  */
  566. PRIMITIVE STk_scheme_load(SCM filename)
  567. {
  568.   if (NSTRINGP(filename)) Err("load: bad file name", filename); 
  569.   return STk_loadfile(CHARS(filename), 1);
  570. }
  571.  
  572.  
  573. /*
  574.  *
  575.  * STk bonus
  576.  *
  577.  */
  578.  
  579. static SCM internal_format(SCM l,int len,int error)/* a very simple and poor one */ 
  580. {
  581.   SCM port, fmt;
  582.   int format_in_string = 0;
  583.   char *p;
  584.   FILE *f;
  585.  
  586.   if (error) {
  587.     if (len < 1) Err("error: Bad list of parameters", l);
  588.     format_in_string = 1;
  589.     port = STk_open_output_string();
  590.     len -= 1;
  591.   }
  592.   else {
  593.     if (len < 2) Err("format: Bad list of parameters", l);
  594.     port = CAR(l); l = CDR(l);
  595.     len -= 2;
  596.   }
  597.   fmt  = CAR(l); l = CDR(l);
  598.  
  599.   if (BOOLEANP(port)){
  600.     if (port == Truth) port = STk_curr_oport;
  601.     else {
  602.       format_in_string = 1;
  603.       port= STk_open_output_string();
  604.     }
  605.   }
  606.   
  607.   verify_port(error? "error": "format", port, F_WRITE);
  608.   if (NSTRINGP(fmt)) Err("format: bad format string", fmt);
  609.  
  610.   f = PORT_FILE(port);
  611.  
  612.   for(p=CHARS(fmt); *p; p++) {
  613.     if (*p == '~') {
  614.       switch(*(++p)) {
  615.         case 'S':
  616.         case 's':
  617.         case 'A':
  618.         case 'a': if (len-- > 0) {
  619.                     STk_print(CAR(l), 
  620.                   port, 
  621.                   (tolower(*p) == 's')? WRT_MODE: DSP_MODE);
  622.                     l = CDR(l);
  623.                   }
  624.                   else Err("format: too much ~ in format string", l); 
  625.               continue;
  626.         case '%': Putc('\n', f);
  627.                   continue;
  628.         case '~': Putc('~', f);
  629.                   continue;
  630.         default:  Putc('~',  f);
  631.                   /* NO BREAK */
  632.       }
  633.     }
  634.     Putc(*p, f);
  635.   }
  636.  
  637.   if (NNULLP(l)) Err("format: too few ~ in format string", l);
  638.  
  639.   return format_in_string ? STk_get_output_string(port) : UNDEFINED;
  640. }
  641.  
  642. PRIMITIVE STk_format(SCM l, int len)
  643. {
  644.   return internal_format(l, len, FALSE);
  645. }
  646.  
  647. PRIMITIVE STk_error(SCM l, int len)
  648. {
  649.   /* Set context to ERR_OK but keep the bit indicating if error must be caught */
  650.   Error_context = ERR_OK | (Error_context & ERR_IGNORED);
  651.  
  652.   Err(CHARS(internal_format(l, len, TRUE)), NIL);
  653.   return UNDEFINED;     /* for compiler */
  654. }
  655.  
  656. PRIMITIVE STk_try_load(SCM filename)
  657. {
  658.   if (NSTRINGP(filename)) Err("try-load: bad file name", filename); 
  659.  
  660.   return STk_loadfile(CHARS(filename), FALSE);
  661. }
  662.  
  663. PRIMITIVE STk_open_file(SCM filename, SCM mode)
  664. {
  665.   int type;
  666.   
  667.  
  668.   if (NSTRINGP(filename)) Err("open-file: bad file name", filename); 
  669.   if (NSTRINGP(mode) || CHARS(mode)[1] != '\0') goto Error;
  670.   
  671.   switch (CHARS(mode)[0]) {
  672.     case 'a': 
  673.     case 'w': type = tc_oport; break;
  674.     case 'r': type = tc_iport; break;
  675.     default:  ;
  676. Error:          Err("open-file: bad mode", mode);
  677.   }
  678.   return(makeport(CHARS(filename), type, CHARS(mode), FALSE));
  679. }
  680.  
  681. PRIMITIVE STk_close_port(SCM port)
  682. {
  683.   if (INP(port) || OUTP(port)) closeport(port);
  684.   else Err("close-port: bad port", port);
  685.   return UNDEFINED;
  686. }
  687.  
  688. PRIMITIVE STk_read_line(SCM port)
  689. {
  690.   FILE *f;
  691.   int c, i, size = 128;
  692.   char *buff = (char *) must_malloc(size);
  693.   SCM res;
  694.  
  695.   port = verify_port("read-line", port, F_READ);
  696.   f = PORT_FILE(port);
  697.   for (i = 0; ; i++) {
  698.     switch (c = Getc(f)) {
  699.       case EOF:  if (i == 0) { free(buff); return STk_eof_object; }
  700.       case '\n': res = STk_makestrg(i, buff); free(buff); return res;
  701.       default:   if (i == size) {
  702.                size += size / 2;
  703.            buff = must_realloc(buff, size);
  704.          }
  705.              buff[i] = c;
  706.     }
  707.   }
  708. }
  709.  
  710. PRIMITIVE STk_flush(SCM port)
  711. {
  712.   int code;
  713.  
  714.   port = verify_port("flush", port, F_WRITE|F_READ);
  715.   code = fflush(PORT_FILE(port));
  716.  
  717.   if (code == EOF) Err("flush: cannot flush buffer", port);
  718.  
  719.   return UNDEFINED;
  720. }
  721.  
  722. /******************************************************************************
  723.  *
  724.  * Autoload stuff
  725.  *
  726.  ******************************************************************************/
  727.  
  728. static SCM list_of_files = NULL;
  729.  
  730. static SCM make_autoload(SCM file)
  731. {
  732.   SCM z;
  733.   
  734.   NEWCELL(z, tc_autoload);
  735.   CAR(z) =  file;
  736.   return z;
  737. }
  738.  
  739. void STk_do_autoload(SCM var)
  740. {
  741.   SCM file, autoload;
  742.  
  743.   autoload = VCELL(var); file = CAR(autoload);
  744.   
  745.   /* Retain in a list, files which are currently autoloaded to avoid mult. load */
  746.   if (!list_of_files) {
  747.     list_of_files = NIL;
  748.     STk_gc_protect(&list_of_files);
  749.   }
  750.  
  751.   if (STk_member(file, list_of_files) != Ntruth) return;
  752.   list_of_files = Cons(file, list_of_files);
  753.  
  754.   STk_loadfile(CHARS(file), TRUE);
  755.  
  756.   list_of_files = CDR(list_of_files);
  757.  
  758.   if (TYPEP(VCELL(var), tc_autoload)) {
  759.     Err("autoload: symbol was not defined", var);
  760.   }
  761. }
  762.  
  763. PRIMITIVE STk_autoload(SCM l, SCM env, int len)
  764. {
  765.   SCM file;
  766.  
  767.   if (len < 2) Err("autoload: bad parameter list", l);
  768.  
  769.   file = CAR(l); 
  770.   if (NSTRINGP(file)) Err("autoload: bad file name", file);
  771.  
  772.   for (l = CDR(l); NNULLP(l); l = CDR(l)) {
  773.     if (NSYMBOLP(CAR(l))) Err("autoload: bad symbol", CAR(l));
  774.     VCELL(CAR(l)) = make_autoload(file);
  775.   }
  776.   return UNDEFINED;
  777. }
  778.  
  779. PRIMITIVE STk_autoloadp(SCM l, SCM env, int len)
  780. {
  781.   if (len != 1 || NSYMBOLP(CAR(l)))
  782.     Err("autoload?: bad symbol", l);
  783.   
  784.   return TYPEP(CAR(l), tc_autoload) ? Truth: Ntruth;
  785. }
  786.  
  787. #ifdef USE_TK
  788. /******************************************************************************
  789.  *
  790.  * Port event management
  791.  *
  792.  ******************************************************************************/
  793.  
  794. static void apply_file_closure(SCM closure)
  795. {
  796.   Apply(closure, NIL);
  797. }
  798.  
  799.  
  800. static SCM when_port_ready(SCM port, SCM closure, char *name, int mode)
  801. {
  802.   char str[50];
  803.   Tcl_File f;
  804.  
  805.   if (NIPORTP(port) && NOPORTP(port)) {
  806.     sprintf(str, "%s: bad port", name);
  807.     STk_err(str, port);
  808.   }
  809.  
  810.   if (closure == UNBOUND) {
  811.     /* Return the current handler closure */
  812.     return ((mode == TCL_READABLE)? PORT_REVENT(port): PORT_WEVENT(port));
  813.   }
  814.  
  815.   f = Tcl_GetFile((ClientData) fileno(PORT_FILE(port)), TCL_UNIX_FD);
  816.   
  817.   if (closure == Ntruth) {
  818.     Tcl_DeleteFileHandler(f);    
  819.     if (mode == TCL_READABLE)
  820.       PORT_REVENT(port) = Ntruth;
  821.     else
  822.       PORT_WEVENT(port) = Ntruth;
  823.   }
  824.   else {
  825.     if (STk_procedurep(closure) == Ntruth) {
  826.       sprintf(str, "%s: bad closure", name);
  827.       STk_err(str, closure);
  828.     }
  829.  
  830.     Tcl_CreateFileHandler(f, mode, (Tcl_FileProc *) apply_file_closure, 
  831.               (ClientData) closure);
  832.     if (mode == TCL_READABLE)
  833.       PORT_REVENT(port) = closure;
  834.     else
  835.       PORT_WEVENT(port) = closure;
  836.   }
  837.   return UNDEFINED;
  838. }
  839.   
  840.  
  841. PRIMITIVE STk_when_port_readable(SCM port, SCM closure)
  842. {
  843.   return when_port_ready(port, closure, "when-port-readable", TCL_READABLE);
  844. }
  845.  
  846.  
  847. PRIMITIVE STk_when_port_writable(SCM port, SCM closure)
  848. {
  849.   return when_port_ready(port, closure, "when-port-writable", TCL_WRITABLE);
  850. }
  851. #endif
  852.