diff options
Diffstat (limited to 'xlisp/xlsys.c')
| -rw-r--r-- | xlisp/xlsys.c | 271 |
1 files changed, 271 insertions, 0 deletions
diff --git a/xlisp/xlsys.c b/xlisp/xlsys.c new file mode 100644 index 0000000..99a1b4e --- /dev/null +++ b/xlisp/xlsys.c @@ -0,0 +1,271 @@ +/* xlsys.c - xlisp builtin system functions */ +/* Copyright (c) 1985, by David Michael Betz + All Rights Reserved + Permission is granted for unrestricted non-commercial use */ + +/* HISTORY + * + * 11-Dec-09 Roger Dannenberg + * Added getenv + * + * 28-Apr-03 Dominic Mazzoni + * Eliminated some compiler warnings + * + * 25-Oct-87 Roger Dannenberg at NeXT + * profiling code added: enable with (PROFILE t), disable with + * (PROFILE nil). While enabled, the profile code counts evals + * within functions and macros. The count is only for evals + * directly within the form; i.e. only the count of the most + * top-most function or macro form on the stack is incremented. + * Also, counts are only maintained for named functions and macros + * because the count itself is on the property list of the function + * or macro name under the *PROFILE* property. If a function or + * macro is entered and the *PROFILE* does not exist, the property + * is created with initial value 0, and the name is inserted at the + * head of the list stored as the value of *PROFILE*. Thus, *PROFILE* + * will list the functions that were touched, and the *PROFILE* property + * of each function gives some idea of how much time it consumed. + * See the file profile.lsp for helpful profiling functions. + */ + +#include "xlisp.h" + +/* profile variables */ +static FIXTYPE invisible_counter; +FIXTYPE *profile_count_ptr = &invisible_counter; +FIXTYPE profile_flag = FALSE; + + +/* external variables */ +extern jmp_buf top_level; +extern FILE *tfp; +extern int xl_main_loop; + +/* external symbols */ +extern LVAL a_subr,a_fsubr,a_cons,a_symbol; +extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream; +extern LVAL a_vector,a_closure,a_char,a_ustream; +extern LVAL k_verbose,k_print; +extern LVAL s_true; + +/* external routines */ +extern FILE *osaopen(); +extern LVAL exttype(); + +/* xget_env - get the value of an environment variable */ +LVAL xget_env(void) +{ + const char *name = (char *) getstring(xlgetfname()); + char *val; + + /* check for too many arguments */ + xllastarg(); + + /* get the value of the environment variable */ + val = getenv(name); + return (val ? cvstring(val) : NULL); +} + +/* xload - read and evaluate expressions from a file */ +LVAL xload(void) +{ + unsigned char *name; + int vflag,pflag; + LVAL arg; + + /* get the file name */ + name = getstring(xlgetfname()); + + /* get the :verbose flag */ + if (xlgetkeyarg(k_verbose,&arg)) + vflag = (arg != NIL); + else + vflag = TRUE; + + /* get the :print flag */ + if (xlgetkeyarg(k_print,&arg)) + pflag = (arg != NIL); + else + pflag = FALSE; + + /* load the file */ + return (xlload((char *) name, vflag, pflag) ? s_true : NIL); +} + +/* xtranscript - open or close a transcript file */ +LVAL xtranscript(void) +{ + unsigned char *name; + + /* get the transcript file name */ + name = (moreargs() ? getstring(xlgetfname()) : NULL); + xllastarg(); + + /* close the current transcript */ + if (tfp) osclose(tfp); + + /* open the new transcript */ + tfp = (name ? osaopen((char *) name,"w") : NULL); + + /* return T if a transcript is open, NIL otherwise */ + return (tfp ? s_true : NIL); +} + +/* xtype - return type of a thing */ +LVAL xtype(void) +{ + LVAL arg; + + if (!(arg = xlgetarg())) + return (NIL); + + switch (ntype(arg)) { + case SUBR: return (a_subr); + case FSUBR: return (a_fsubr); + case CONS: return (a_cons); + case SYMBOL: return (a_symbol); + case FIXNUM: return (a_fixnum); + case FLONUM: return (a_flonum); + case STRING: return (a_string); + case OBJECT: return (a_object); + case STREAM: return (a_stream); + case VECTOR: return (a_vector); + case CLOSURE: return (a_closure); + case CHAR: return (a_char); + case USTREAM: return (a_ustream); + case EXTERN: return (exttype(arg)); + default: xlfail("bad node type"); + return NIL; /* never happens */ + } +} + +/* xbaktrace - print the trace back stack */ +LVAL xbaktrace(void) +{ + LVAL num; + int n; + + if (moreargs()) { + num = xlgafixnum(); + n = getfixnum(num); + } + else + n = -1; + xllastarg(); + xlbaktrace(n); + return (NIL); +} + +/* xquit - get out of read/eval/print loop */ +LVAL xquit() +{ + xllastarg(); + xl_main_loop = FALSE; + return NIL; +} + + +/* xexit does not return anything, so turn off "no return value" warning" */ +/* #pragma warning(disable: 4035) */ + +/* xexit - get out of xlisp */ +LVAL xexit(void) +{ + xllastarg(); + xlisp_wrapup(); + return NIL; /* never happens */ +} + +#ifdef PEEK_AND_POKE +/* xpeek - peek at a location in memory */ +LVAL xpeek(void) +{ + LVAL num; + int *adr; + + /* get the address */ + num = xlgafixnum(); adr = (int *)getfixnum(num); + xllastarg(); + + /* return the value at that address */ + return (cvfixnum((FIXTYPE)*adr)); +} + +/* xpoke - poke a value into memory */ +LVAL xpoke(void) +{ + LVAL val; + int *adr; + + /* get the address and the new value */ + val = xlgafixnum(); adr = (int *)getfixnum(val); + val = xlgafixnum(); + xllastarg(); + + /* store the new value */ + *adr = (int)getfixnum(val); + + /* return the new value */ + return (val); +} + +/* xaddrs - get the address of an XLISP node */ +LVAL xaddrs(void) +{ + LVAL val; + + /* get the node */ + val = xlgetarg(); + xllastarg(); + + /* return the address of the node */ + return (cvfixnum((FIXTYPE)val)); +} +#endif PEEK_AND_POKE + +/* xprofile - turn profiling on and off */ +LVAL xprofile() +{ + LVAL flag, result; + + /* get the argument */ + flag = xlgetarg(); + xllastarg(); + + result = (profile_flag ? s_true : NIL); + profile_flag = !null(flag); + /* turn off profiling right away: */ + if (!profile_flag) profile_count_ptr = &invisible_counter; + return result; +} + + +#ifdef DEBUG_INPUT +FILE *debug_input_fp = NULL; + +FILE *to_input_buffer = NULL; +FILE *read_by_xlisp = NULL; + +LVAL xstartrecordio() +{ + to_input_buffer = fopen("to-input-buffer.txt", "w"); + read_by_xlisp = fopen("read-by-xlisp.txt", "w"); + if (!to_input_buffer || !read_by_xlisp) { + return NIL; + } + return s_true; +} + + +LVAL xstoprecordio() +{ + if (to_input_buffer) fclose(to_input_buffer); + if (read_by_xlisp) fclose(read_by_xlisp); + to_input_buffer = NULL; + read_by_xlisp = NULL; + return NIL; +} + +#endif + + |