/* * p o r t . c -- ports implementation * * Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI * * * Permission to use, copy, modify, distribute,and license this * software and its documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in any * distributions. No written agreement, license, or royalty fee is * required for any of the authorized uses. * This software is provided ``AS IS'' without express or implied * warranty. * * Author: Erick Gallesio [eg@unice.fr] * Creation date: 17-Feb-1993 12:27 * Last file update: 3-Sep-1999 20:21 (eg) * * Win32 support by Steve Pruitt * - Modified do_load for dynamic loading of WIN32 Dll files * - Added check for *shared-prefix* in try_loadfile * - Added "#define strcasecmp stricmp" for Win32 *shared-prefix* support * - Modified STk_open_file to allow Win32 modes "wb" and "rb" * */ #include "stk.h" #include "module.h" #define INITIAL_LINE_SIZE 256 /* Initial size for readline */ #if defined(WIN32) && !defined(CYGWIN32) # define strcasecmp stricmp /* Provide substitute functions dor WIN32 */ FILE *popen(char *cmd, char *mode) { /* Returning NULL will yield an error */ return NULL; } void pclose(FILE *f) {} #endif /* external vars */ SCM STk_curr_iport, STk_curr_oport, STk_curr_eport, STk_eof_object; SCM STk_Cfile2port(char *name, FILE *f, int type, int flags) { SCM z; NEWCELL(z, type); z->storage_as.port.p = (struct port_descr *) must_malloc(sizeof(struct port_descr)); PORT_UNGETC(z) = EOF; PORT_FILE(z) = f; PORT_FLAGS(z) = flags; PORT_REVENT(z) = Ntruth; PORT_WEVENT(z) = Ntruth; PORT_NAME(z) = (char *) must_malloc(strlen(name)+1); strcpy(PORT_NAME(z), name); return z; } static SCM makeport(char *name, int type, char *mode, int error) { int flags = 0; FILE *f; char *full_name; #ifdef WIN32 /* Transform name in an absolute name */ name = CHARS(STk_internal_expand_file_name(name)); #endif if (strncmp(name, "| ", 2)) { full_name = CHARS(STk_internal_expand_file_name(name)); if ((f = fopen(full_name, mode)) == NULL) { if (error) Err("could not open file", STk_makestring(name)); else return Ntruth; } } else { full_name = name; flags = PIPE_PORT; if ((f = popen(name+1, mode)) == NULL) { if (error) Err("could not create pipe", STk_makestring(name)); else return Ntruth; } } return STk_Cfile2port(full_name, f, type, flags); } static SCM verify_port(char *proc_name, SCM port, int mode) { if (port == UNBOUND) /* test write 'cause of flush */ port = (mode&F_WRITE) ? STk_curr_oport: STk_curr_iport; if (!(INP(port) || OUTP(port))) Serror("bad port", port); if (PORT_FLAGS(port) & PORT_CLOSED) Serror("port is closed", port); if ((mode & F_READ) && INP(port)) return port; /* not else. It can be both */ if ((mode & F_WRITE) && OUTP(port)) return port; Serror("bad port", port); return UNDEFINED; /* cannot occur */ } void STk_close_file_port(SCM port) { FILE *f = PORT_FILE(port); #if defined(USE_TK) && !defined(WIN32) /* For pipe and file ports, delete the fileevent associated to it (if any) */ Tcl_DeleteFileHandler(fileno(f)); #endif if (PORT_FLAGS(port) & PIPE_PORT) /* Pipe port */ pclose(f); else { /* File port */ /* FIXME: Normally close should suffice but glibc2.1.1 on Linux dumps * core if a file is closed two times. (this arrives when a socket is * lost and the interpreter call this function). */ fflush(f); close(fileno(f)); } } void STk_freeport(SCM port) { STk_close(port); free(PORT_NAME(port)); free(port->storage_as.port.p); } void STk_init_standard_ports(void) { STk_stdin = STk_curr_iport = STk_Cfile2port("*stdin*", stdin, tc_iport, 0); STk_gc_protect(&STk_stdin); STk_gc_protect(&STk_curr_iport); STk_stdout = STk_curr_oport = STk_Cfile2port("*stdout*", stdout, tc_oport, 0); STk_gc_protect(&STk_stdout); STk_gc_protect(&STk_curr_oport); STk_stderr = STk_curr_eport = STk_Cfile2port("*stderr*", stderr, tc_oport, 0); STk_gc_protect(&STk_stderr); STk_gc_protect(&STk_curr_eport); NEWCELL(STk_eof_object, tc_eof); STk_gc_protect(&STk_eof_object); STk_line_counter = 1; STk_current_filename = UNBOUND; /* Unbound <=> stdin */ STk_gc_protect(&STk_current_filename); } /*=============================================================================*\ * * L O A D stuff * \*=============================================================================*/ static int do_load(char *full_name, SCM module) { int c; #ifdef WIN32 /* Transform name in an absolute name */ full_name = CHARS(STk_internal_expand_file_name(full_name)); #endif if (!STk_dirp(full_name)) { FILE *f = fopen(full_name, "r"); if (f == NULL) return 0; if (STk_lookup_variable(LOAD_VERBOSE, NIL) != Ntruth) Fprintf(STk_curr_eport, ";; Loading file \"%s\"\n", full_name); /* Just read one character. Assume that file is an object if this * character is a control one. Here, I don't try to see if the file magic * number has a particular value, since I'm not sure that all platforms * use identical conventions */ c = getc(f); fclose(f); #if (defined(WIN32) && defined(USE_DYNLOAD) && !defined(CYGWIN32)) /* If suffix is a Win32 shared-suffix then assume object file */ if (c != EOF) { char *s, *shared_suffix; s=full_name; shared_suffix=CHARS(STk_lookup_variable("*shared-suffix*", NIL)); s = s + strlen(s) - strlen(shared_suffix); if (stricmp(s,shared_suffix) == 0) c = *(s-1); else c = EOF; } if (c == '.') { #else if (c != EOF && ((iscntrl(c)&& c!= '\n' && c!= '\t') || !isascii(c))) { #endif STk_load_object_file(full_name); } else { /* file seems not to be an object file. Try to load it as a Scheme file */ SCM prev_module; SCM previous_file, port; int previous_line; /* Save info about current line and file */ previous_file = STk_current_filename; previous_line = STk_line_counter; STk_line_counter = 1; STk_current_filename = STk_makestring(full_name); /* Save info about selected module */ prev_module = STk_selected_module; STk_selected_module = module; /* Create port for reading */ port = makeport(full_name, tc_iport, "r", TRUE); PUSH_ERROR_HANDLER { SCM form; STk_err_handler->context |= ERR_IN_LOAD; for( ; ; ) { form = STk_readf(port, FALSE); if (EQ(form, STk_eof_object)) break; STk_eval(form, MOD_ENV(STk_selected_module)); } } WHEN_ERROR { STk_close(port); STk_selected_module = prev_module; STk_last_defined = Ntruth; if (!STk_control_C) PROPAGATE_ERROR(); } POP_ERROR_HANDLER; STk_close(port); STk_current_filename = previous_file; STk_line_counter = previous_line; STk_selected_module = prev_module; STk_last_defined = Ntruth; } if (STk_lookup_variable(LOAD_VERBOSE, NIL) != Ntruth) Fprintf(STk_curr_eport, ";; File \"%s\" loaded\n", full_name); return 1; } /* No file found */ return 0; } static int try_loadfile(char *prefix, char *fname, SCM suffixes, SCM module) { char full_name[MAX_PATH_LENGTH], *s; /* First try to load without suffix */ if (strlen(prefix) + strlen(fname) + 2 >= MAX_PATH_LENGTH) goto TooLong; sprintf(full_name, "%s%s%s", prefix, (*prefix ? "/": ""), fname); if (do_load(full_name, module)) return 1; /* Now try to load file with suffix */ for ( ; NNULLP(suffixes); suffixes = CDR(suffixes)) { /* We are sure that suffixes is a well formed list (ensured by loadfile) */ if (NSTRINGP(CAR(suffixes))) Err("load: bad suffix component", CAR(suffixes)); s = CHARS(CAR(suffixes)); if (strlen(prefix)+strlen(fname)+strlen(s)+3 >= MAX_PATH_LENGTH) goto TooLong; sprintf(full_name, "%s%s%s.%s", prefix, (*prefix ? "/": ""), fname, s); if (do_load(full_name, module)) return 1; } /* No file loaded */ return 0; TooLong: Err("load: filename too long", NIL); return 0; /* cannot occur */ } SCM STk_load_file(char *fname, int err_if_absent, SCM module) { int len; SCM load_path, load_suffixes; ENTER_PRIMITIVE("load"); len = strlen(fname); load_path = STk_lookup_variable(LOAD_PATH, NIL); load_suffixes = STk_lookup_variable(LOAD_SUFFIXES, NIL); if (STk_llength(load_path)<0) Serror("bad loading path", load_path); if (STk_llength(load_suffixes)<0) Serror("bad set of suffixes", load_suffixes); #ifdef WIN32 if ((len > 0 && (fname[0] == '/' || fname[0] == '\\' || fname[0] == '~')) || (len > 1 && fname[0] == '.' && (fname[1] == '/' || fname[1] == '\\')) || (len > 2 && fname[0] == '.' && fname[1] == '.' && (fname[2] == '/' || fname[2]=='\\')) || (len > 1 && isalpha(fname[0]) && fname[1]==':')) { #else if ((len > 0 && (fname[0] == '/' || fname[0] == '~')) || (len > 1 && fname[0] == '.' && fname[1] == '/') || (len > 2 && fname[0] == '.' && fname[1] == '.' && fname[2] == '/')) { #endif if (fname[0] == '~') fname = CHARS(STk_internal_expand_file_name(fname)); if (try_loadfile("", fname, load_suffixes, module)) return(err_if_absent? UNDEFINED: Truth); } else { /* Use *load-path* for loading file */ for ( ; NNULLP(load_path); load_path = CDR(load_path)) { if (NSTRINGP(CAR(load_path))) Serror("bad loading path component", CAR(load_path)); if (try_loadfile(CHARS(CAR(load_path)), fname, load_suffixes, module)) return(err_if_absent? UNDEFINED: Truth); } } /* If we are here, we have been unable to load a file. Report err if needed */ if (err_if_absent) Serror("cannot open file", STk_makestring(fname)); return Ntruth; } PRIMITIVE STk_input_portp(SCM port) { return INP(port) ? Truth: Ntruth; } PRIMITIVE STk_output_portp(SCM port) { return OUTP(port)? Truth: Ntruth; } PRIMITIVE STk_input_file_portp(SCM port) { return IPORTP(port) ? Truth: Ntruth; } PRIMITIVE STk_output_file_portp(SCM port) { return OPORTP(port)? Truth: Ntruth; } PRIMITIVE STk_current_input_port(void) { return STk_curr_iport; } PRIMITIVE STk_current_output_port(void) { return STk_curr_oport; } PRIMITIVE STk_current_error_port(void) { return STk_curr_eport; } /*============================================================================*\ * w i t h - i n p u t - f r o m - . . . \*============================================================================*/ SCM STk_redirect_input(SCM port, SCM thunk) { SCM result = UNDEFINED; /* to make gcc happy*/ SCM prev_iport = STk_curr_iport; PUSH_ERROR_HANDLER { STk_curr_iport = port; result = Apply0(thunk); STk_curr_iport = prev_iport; } WHEN_ERROR { STk_curr_iport = prev_iport; PROPAGATE_ERROR(); } POP_ERROR_HANDLER; return result; } PRIMITIVE STk_with_input_from_file(SCM string, SCM thunk) { SCM res, p; ENTER_PRIMITIVE("with-input-from-file"); if (NSTRINGP(string)) Serror("bad string", string); if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk); p = makeport(CHARS(string), tc_iport, "r", TRUE); res = STk_redirect_input(p , thunk); STk_close(p); return res; } PRIMITIVE STk_with_input_from_port(SCM port, SCM thunk) { ENTER_PRIMITIVE("with-input-from-port"); if (!INP(port)) Serror("bad port", port); if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk); return STk_redirect_input(port, thunk); } /*============================================================================*\ * w i t h - o u t p u t - t o - . . . \*============================================================================*/ SCM STk_redirect_output(SCM port, SCM thunk) { SCM result = UNDEFINED; /* to make gcc happy*/ SCM prev_oport = STk_curr_oport; PUSH_ERROR_HANDLER { STk_curr_oport = port; result = Apply0(thunk); STk_curr_oport = prev_oport; } WHEN_ERROR { STk_curr_oport = prev_oport; PROPAGATE_ERROR(); } POP_ERROR_HANDLER; Flush(port); return result; } PRIMITIVE STk_with_output_to_file(SCM string, SCM thunk) { SCM res, p; ENTER_PRIMITIVE("with-output-to-file"); if (NSTRINGP(string)) Serror("bad string", string); if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk); p = makeport(CHARS(string), tc_oport, "w", TRUE); res = STk_redirect_output(p, thunk); STk_close(p); return res; } PRIMITIVE STk_with_output_to_port(SCM port, SCM thunk) { ENTER_PRIMITIVE("with-output-to-port"); if (!OUTP(port)) Serror("bad port", port); if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk); return STk_redirect_output(port, thunk); } /*============================================================================*\ * w i t h - e r r o r - t o - . . . \*============================================================================*/ SCM STk_redirect_error(SCM port, SCM thunk) { SCM result = UNDEFINED; /* to make gcc happy*/ SCM prev_eport = STk_curr_eport; PUSH_ERROR_HANDLER { STk_curr_eport = port; result = Apply0(thunk); STk_curr_eport = prev_eport; } WHEN_ERROR { STk_curr_eport = prev_eport; PROPAGATE_ERROR(); } POP_ERROR_HANDLER; Flush(port); return result; } PRIMITIVE STk_with_error_to_file(SCM string, SCM thunk) { SCM res, p; ENTER_PRIMITIVE("with-error-to-file"); if (NSTRINGP(string)) Serror("bad string", string); if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk); p = makeport(CHARS(string), tc_oport, "w", TRUE); res = STk_redirect_error(p, thunk); STk_close(p); return res; } PRIMITIVE STk_with_error_to_port(SCM port, SCM thunk) { ENTER_PRIMITIVE("with-error-to-port"); if (!OUTP(port)) Serror("bad port", port); if (!STk_is_thunk(thunk)) Serror("bad thunk", thunk); return STk_redirect_error(port, thunk); } /*=============================================================================*\ * Open/Close \*=============================================================================*/ PRIMITIVE STk_open_input_file(SCM filename) { if (NSTRINGP(filename)) Err("open-input-file: bad file name", filename); return makeport(CHARS(filename), tc_iport, "r", TRUE); } PRIMITIVE STk_open_output_file(SCM filename) { if (NSTRINGP(filename)) Err("open-output-file: bad file name", filename); return makeport(CHARS(filename), tc_oport, "w", TRUE); } PRIMITIVE STk_close_input_port(SCM port) { if (!INP(port)) Err("close-input-port: not an input port", port); STk_close(port); return UNDEFINED; } PRIMITIVE STk_close_output_port(SCM port) { if (!OUTP(port)) Err("close-output-port: not an output port", port); STk_close(port); return UNDEFINED; } /*=============================================================================*\ * Read \*=============================================================================*/ PRIMITIVE STk_read(SCM port) { port = verify_port("read", port, F_READ); return(STk_readf(port, FALSE)); } PRIMITIVE STk_read_char(SCM port) { int c; port = verify_port("read-char", port, F_READ); c = Getc(port); return (c == EOF) ? STk_eof_object : STk_makechar((unsigned char) c); } PRIMITIVE STk_peek_char(SCM port) { int c; port = verify_port("peek-char", port, F_READ); c = Getc(port); Ungetc(c, port); return (c == EOF) ? STk_eof_object : STk_makechar((unsigned char) c); } PRIMITIVE STk_eof_objectp(SCM obj) { return (obj == STk_eof_object)? Truth : Ntruth; } PRIMITIVE STk_char_readyp(SCM port) { port = verify_port("char-ready?", port, F_READ); return STk_internal_char_readyp(port) ? Truth : Ntruth; } /*=============================================================================*\ * Write \*=============================================================================*/ PRIMITIVE STk_write(SCM expr, SCM port) { port = verify_port("write", port, F_WRITE); STk_print(expr, port, WRT_MODE); return UNDEFINED; } PRIMITIVE STk_display(SCM expr, SCM port) { port = verify_port("display", port, F_WRITE); STk_print(expr, port, DSP_MODE); return UNDEFINED; } PRIMITIVE STk_newline(SCM port) { port = verify_port("newline", port, F_WRITE); Putc('\n', port); return UNDEFINED; } PRIMITIVE STk_write_char(SCM c, SCM port) { ENTER_PRIMITIVE("write-char"); if (NCHARP(c)) Serror("not a character", c); port = verify_port(proc_name, port, F_WRITE); Putc(CHAR(c), port); return UNDEFINED; } /*=============================================================================*\ * Load \*=============================================================================*/ PRIMITIVE STk_load(SCM filename, SCM module) { ENTER_PRIMITIVE("load"); if (NSTRINGP(filename)) Serror("bad file name", filename); if (module != UNBOUND) { if (NMODULEP(module)) Serror("bad module", module); } else module = STk_selected_module; return STk_load_file(CHARS(filename), TRUE, module); } /*===========================================================================*\ * * S T k b o n u s * \*===========================================================================*/ static SCM internal_format(SCM l,int len,int error)/* a very simple and poor one */ { SCM port, fmt; int format_in_string = 0; char *p, *proc_name = error? "error": "format"; if (error) { if (len < 1) Serror("bad list of parameters", l); format_in_string = 1; port = STk_open_output_string(); len -= 1; } else { if (len < 2) Serror("bad list of parameters", l); port = CAR(l); l = CDR(l); len -= 2; } fmt = CAR(l); l = CDR(l); if (BOOLEANP(port)){ if (port == Truth) port = STk_curr_oport; else { format_in_string = 1; port= STk_open_output_string(); } } verify_port(proc_name, port, F_WRITE); if (NSTRINGP(fmt)) Serror("bad format string", fmt); for(p=CHARS(fmt); *p; p++) { if (*p == '~') { switch(*(++p)) { case 'A': case 'a': if (len-- <= 0) goto TooMuch; STk_print(CAR(l), port, DSP_MODE); l = CDR(l); continue; case 'S': case 's': if (len-- <= 0) goto TooMuch; STk_print(CAR(l), port, WRT_MODE); l = CDR(l); continue; case 'W': case 'w': if (len-- <= 0) goto TooMuch; STk_print_star(CAR(l), port); l = CDR(l); continue; case '%': Putc('\n', port); continue; case '~': Putc('~', port); continue; default: Putc('~', port); /* NO BREAK */ } } Putc(*p, port); } if (NNULLP(l)) Serror("too few ~ in format string", l); return format_in_string ? STk_get_output_string(port) : UNDEFINED; TooMuch: Serror("too many ``~'' in format string", l); return UNDEFINED; } PRIMITIVE STk_format(SCM l, int len) { return internal_format(l, len, FALSE); } PRIMITIVE STk_error(SCM l, int len) { /* Set context to ERR_OK but keep the bit indicating if error must be caught */ STk_err_handler->context = ERR_OK | ( STk_err_handler->context & ERR_IGNORED); Err(CHARS(internal_format(l, len, TRUE)), NIL); return UNDEFINED; /* for compiler */ } PRIMITIVE STk_try_load(SCM filename, SCM module) { ENTER_PRIMITIVE("try-load"); if (NSTRINGP(filename)) Serror("bad file name", filename); if (module != UNBOUND) { if (NMODULEP(module)) Serror("bad module", module); } else module = STk_selected_module; return STk_load_file(CHARS(filename), FALSE, module); } PRIMITIVE STk_open_file(SCM filename, SCM mode) { int type; ENTER_PRIMITIVE("open-file"); if (NSTRINGP(filename)) Serror("bad file name", filename); /* allow modes "wb" and "rb" on win32 systems */ #if (defined(MSC_VER) && defined(WIN32) && !defined(CYGWIN32)) if (NSTRINGP(mode)) goto Error; if (CHARS(mode)[1] != '\0' && CHARS(mode)[1] != 'b') goto Error; #else if (NSTRINGP(mode) || CHARS(mode)[1] != '\0') goto Error; #endif switch (CHARS(mode)[0]) { case 'a': case 'w': type = tc_oport; break; case 'r': type = tc_iport; break; default: goto Error; } return(makeport(CHARS(filename), type, CHARS(mode), FALSE)); Error: Serror("bad mode", mode); return UNDEFINED; /* for the compiler */ } PRIMITIVE STk_close_port(SCM port) { if (INP(port) || OUTP(port)) STk_close(port); else Err("close-port: bad port", port); return UNDEFINED; } PRIMITIVE STk_port_closedp(SCM port) { ENTER_PRIMITIVE("port-closed?"); if (!(INP(port) || OUTP(port))) Serror("bad port", port); return (PORT_FLAGS(port) & PORT_CLOSED) ? Truth : Ntruth; } PRIMITIVE STk_read_line(SCM port) { int c; char buffer[INITIAL_LINE_SIZE], *buff; size_t i, size = INITIAL_LINE_SIZE; SCM res; port = verify_port("read-line", port, F_READ); buff = buffer; for (i = 0; ; i++) { if (i == size) { /* We must enlarge the buffer */ size += size / 2; if (i == INITIAL_LINE_SIZE) { /* This is the first resize. Pass from static to dynamic allocation */ buff = must_malloc(size); strncpy(buff, buffer, INITIAL_LINE_SIZE); } else buff = must_realloc(buff, size); } switch (c = Getc(port)) { case EOF: if (i == 0) return STk_eof_object; /* NO BREAK */ case '\n': res = STk_makestrg(i, buff); if (buff != buffer) free(buff); return res; case '\r': i--; continue; default: buff[i] = c; } } } PRIMITIVE STk_copy_port(SCM in, SCM out) { int c; ENTER_PRIMITIVE("copy-port"); if (! INP(in)) Serror("bad input port", in); if (! OUTP(out)) Serror("bad output port", out); while ((c = Getc(in)) != EOF) Putc(c, out); return UNDEFINED; } PRIMITIVE STk_flush(SCM port) { ENTER_PRIMITIVE("flush"); port = verify_port(proc_name, port, F_WRITE|F_READ); if (STk_internal_flush(port)) Serror("cannot flush buffer", port); return UNDEFINED; } PRIMITIVE STk_write_star(SCM expr, SCM port) { port = verify_port("write*", port, F_WRITE); STk_print_star(expr, port); return UNDEFINED; } /****************************************************************************** * * Autoload stuff * ******************************************************************************/ static SCM list_of_files = NULL; static int dont_do_autoload = 0; /* 1 if we are testing autoload? */ static SCM make_autoload(SCM file, SCM env) { SCM z; NEWCELL(z, tc_autoload); CAR(z) = file; CDR(z) = env; return z; } void STk_do_autoload(SCM var, SCM autoload) { static int recursive_call = 0; ENTER_PRIMITIVE("autoload"); if (dont_do_autoload) return; if (recursive_call) { /* We have a recursive call if var has not be defined in the specified * file. In effect when a file has been loaded, we just try to find * the value of var. If this value has not been defined we will do * another STk_do_autoload */ recursive_call = 0; Serror("symbol was not defined", var); } { SCM file = CAR(autoload); SCM module = CDR(autoload); SCM loaded; /* Retain in a list, files which are currently autoloaded to avoid mult. load */ if (!list_of_files) { list_of_files = NIL; STk_gc_protect(&list_of_files); } if (STk_member(file, list_of_files) != Ntruth) return; list_of_files = Cons(file, list_of_files); /* Load file in the module used when the symbol was defined as autoload */ loaded = STk_load_file(CHARS(file), FALSE, module); list_of_files = CDR(list_of_files); /* Verify that file was really loaded (loaded is true in this case) */ if (loaded == Ntruth) Serror("file not found for autoload symbol", Cons(var, file)); /* File is now loaded. Try to lookup the value of var and see if it * provokes another STk_do_autoload call */ recursive_call = 1; STk_varlookup(var, MOD_ENV(module), TRUE); recursive_call = 0; } } PRIMITIVE STk_autoload(SCM l, SCM env, int len) { SCM file, current_module; ENTER_PRIMITIVE("autoload"); if (len < 2) Serror("bad parameter list", l); file = CAR(l); if (NSTRINGP(file)) Serror("bad file name", file); current_module = STk_current_module(NIL, env, 0); for (l = CDR(l); NNULLP(l); l = CDR(l)) { if (NSYMBOLP(CAR(l))) Serror("bad symbol", CAR(l)); STk_define_public_var(current_module, CAR(l), make_autoload(file, current_module)); } return UNDEFINED; } PRIMITIVE STk_autoloadp(SCM symbol, SCM module) { SCM *value, env; ENTER_PRIMITIVE("autoload?"); if (NSYMBOLP(symbol)) Serror("bad symbol", symbol); if (module == UNBOUND) env = STk_global_module; else { if (NMODULEP(module)) Serror("bad module", module); env = MOD_ENV(module); } /* Looking at var value will load the file. Signal that we don't want to load */ /* This is a little bit hacky, but it does the job */ dont_do_autoload = 1; value = STk_varlookup(symbol, env, FALSE); dont_do_autoload = 0; return TYPEP(*value, tc_autoload) ? Truth: Ntruth; } #if defined(USE_TK) && !defined(WIN32) /****************************************************************************** * * Port event management * ******************************************************************************/ static void apply_file_closure(SCM closure) { Apply0(closure); } static SCM when_port_ready(SCM port, SCM closure, char *name, int mode) { char str[50]; int fd; if (NIPORTP(port) && NOPORTP(port)) { sprintf(str, "%s: bad port", name); STk_err(str, port); } if (closure == UNBOUND) { /* Return the current handler closure */ return ((mode == TCL_READABLE)? PORT_REVENT(port): PORT_WEVENT(port)); } fd = fileno(PORT_FILE(port)); if (closure == Ntruth) { Tcl_DeleteFileHandler(fd); if (mode == TCL_READABLE) PORT_REVENT(port) = Ntruth; else PORT_WEVENT(port) = Ntruth; } else { if (STk_procedurep(closure) == Ntruth) { sprintf(str, "%s: bad closure", name); STk_err(str, closure); } /* It is not necessary to mark the closure in the Tcl tables since it is * also pointed by the Scheme port. This prevent GC problems */ Tcl_CreateFileHandler(fd, mode, (Tcl_FileProc *) apply_file_closure, (ClientData) closure); if (mode == TCL_READABLE) PORT_REVENT(port) = closure; else PORT_WEVENT(port) = closure; } return UNDEFINED; } PRIMITIVE STk_when_port_readable(SCM port, SCM closure) { return when_port_ready(port, closure, "when-port-readable", TCL_READABLE); } PRIMITIVE STk_when_port_writable(SCM port, SCM closure) { return when_port_ready(port, closure, "when-port-writable", TCL_WRITABLE); } #endif #ifdef USE_TK /****************************************************************************** * * Changing standard ports * ******************************************************************************/ PRIMITIVE STk_change_standard_ports(SCM in, SCM out, SCM err) { static int cpt = 0; ENTER_PRIMITIVE("%change-standard-ports"); if (cpt++) Serror("Cannot redirected standard port anymore", NIL); if (!INP(in)) Serror("bad input port", in); if (!OUTP(out)) Serror("bad output port", out); if (!OUTP(err)) Serror("bad error port", err); STk_curr_iport = in; STk_curr_oport = out; STk_curr_eport = err; return UNDEFINED; } #endif