1 /* xlsys.c - xlisp builtin system functions */
2 /*	Copyright (c) 1985, by David Michael Betz
3         All Rights Reserved
4         Permission is granted for unrestricted non-commercial use	*/
5 
6 /* HISTORY
7  *
8  * 11-Dec-09    Roger Dannenberg
9  *  Added getenv
10  *
11  * 28-Apr-03	Dominic Mazzoni
12  *  Eliminated some compiler warnings
13  *
14  * 25-Oct-87	Roger Dannenberg at NeXT
15  *  profiling code added: enable with (PROFILE t), disable with
16  *  (PROFILE nil).  While enabled, the profile code counts evals
17  *  within functions and macros.  The count is only for evals
18  *  directly within the form; i.e. only the count of the most
19  *  top-most function or macro form on the stack is incremented.
20  *  Also, counts are only maintained for named functions and macros
21  *  because the count itself is on the property list of the function
22  *  or macro name under the *PROFILE* property.  If a function or
23  *  macro is entered and the *PROFILE* does not exist, the property
24  *  is created with initial value 0, and the name is inserted at the
25  *  head of the list stored as the value of *PROFILE*.  Thus, *PROFILE*
26  *  will list the functions that were touched, and the *PROFILE* property
27  *  of each function gives some idea of how much time it consumed.
28  *  See the file profile.lsp for helpful profiling functions.
29  */
30 
31 #include "xlisp.h"
32 
33 /* profile variables */
34 static FIXTYPE invisible_counter;
35 FIXTYPE *profile_count_ptr = &invisible_counter;
36 FIXTYPE profile_flag = FALSE;
37 
38 
39 /* external variables */
40 extern jmp_buf top_level;
41 extern FILE *tfp;
42 extern int xl_main_loop;
43 
44 /* external symbols */
45 extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
46 extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
47 extern LVAL a_vector,a_closure,a_char,a_ustream;
48 extern LVAL k_verbose,k_print;
49 extern LVAL s_true;
50 
51 /* external routines */
52 extern FILE *osaopen(const char *name, const char *mode);
53 extern LVAL exttype(LVAL x);
54 
55 /* xget_env - get the value of an environment variable */
xget_env(void)56 LVAL xget_env(void)
57 {
58     const char *name = (char *) getstring(xlgetfname());
59     char *val;
60 
61     /* check for too many arguments */
62     xllastarg();
63 
64     /* get the value of the environment variable */
65     val = getenv(name);
66     return (val ? cvstring(val) : NULL);
67 }
68 
69 /* xload - read and evaluate expressions from a file */
xload(void)70 LVAL xload(void)
71 {
72     const char *name;
73     int vflag,pflag;
74     LVAL arg;
75 
76     /* get the file name, converting unsigned char to char */
77     name = (const char *) getstring(xlgetfname());
78 
79     /* get the :verbose flag */
80     if (xlgetkeyarg(k_verbose,&arg))
81         vflag = (arg != NIL);
82     else
83         vflag = TRUE;
84 
85     /* get the :print flag */
86     if (xlgetkeyarg(k_print,&arg))
87         pflag = (arg != NIL);
88     else
89         pflag = FALSE;
90 
91     /* load the file */
92     return (xlload(name, vflag, pflag) ? s_true : NIL);
93 }
94 
95 /* xtranscript - open or close a transcript file */
xtranscript(void)96 LVAL xtranscript(void)
97 {
98     unsigned char *name;
99 
100     /* get the transcript file name */
101     name = (moreargs() ? getstring(xlgetfname()) : NULL);
102     xllastarg();
103 
104     /* close the current transcript */
105     if (tfp) osclose(tfp);
106 
107     /* open the new transcript */
108     tfp = (name ? osaopen((char *) name,"w") : NULL);
109 
110     /* return T if a transcript is open, NIL otherwise */
111     return (tfp ? s_true : NIL);
112 }
113 
114 /* xtype - return type of a thing */
xtype(void)115 LVAL xtype(void)
116 {
117     LVAL arg;
118 
119     if (!(arg = xlgetarg()))
120         return (NIL);
121 
122     switch (ntype(arg)) {
123     case SUBR:		return (a_subr);
124     case FSUBR:		return (a_fsubr);
125     case CONS:		return (a_cons);
126     case SYMBOL:	return (a_symbol);
127     case FIXNUM:	return (a_fixnum);
128     case FLONUM:	return (a_flonum);
129     case STRING:	return (a_string);
130     case OBJECT:	return (a_object);
131     case STREAM:	return (a_stream);
132     case VECTOR:	return (a_vector);
133     case CLOSURE:	return (a_closure);
134     case CHAR:		return (a_char);
135     case USTREAM:	return (a_ustream);
136     case EXTERN:	return (exttype(arg));
137     default:		xlfail("bad node type");
138        return NIL; /* never happens */
139     }
140 }
141 
142 /* xbaktrace - print the trace back stack */
xbaktrace(void)143 LVAL xbaktrace(void)
144 {
145     LVAL num;
146     int n;
147 
148     if (moreargs()) {
149         num = xlgafixnum();
150         n = (int) getfixnum(num);
151     }
152     else
153         n = -1;
154     xllastarg();
155     xlbaktrace(n);
156     return (NIL);
157 }
158 
159 /* xquit - get out of read/eval/print loop */
xquit(void)160 LVAL xquit(void)
161 {
162     xllastarg();
163     xl_main_loop = FALSE;
164     return NIL;
165 }
166 
167 
168 /* xexit does not return anything, so turn off "no return value" warning" */
169 /* #pragma warning(disable: 4035) */
170 
171 /* xexit - get out of xlisp */
xexit(void)172 LVAL xexit(void)
173 {
174     xllastarg();
175     xlisp_wrapup();
176     return NIL; /* never happens */
177 }
178 
179 #ifdef PEEK_AND_POKE
180 /* xpeek - peek at a location in memory */
xpeek(void)181 LVAL xpeek(void)
182 {
183     LVAL num;
184     int *adr;
185 
186     /* get the address */
187     num = xlgafixnum(); adr = (int *)getfixnum(num);
188     xllastarg();
189 
190     /* return the value at that address */
191     return (cvfixnum((FIXTYPE)*adr));
192 }
193 
194 /* xpoke - poke a value into memory */
xpoke(void)195 LVAL xpoke(void)
196 {
197     LVAL val;
198     int *adr;
199 
200     /* get the address and the new value */
201     val = xlgafixnum(); adr = (int *)getfixnum(val);
202     val = xlgafixnum();
203     xllastarg();
204 
205     /* store the new value */
206     *adr = (int)getfixnum(val);
207 
208     /* return the new value */
209     return (val);
210 }
211 
212 /* xaddrs - get the address of an XLISP node */
xaddrs(void)213 LVAL xaddrs(void)
214 {
215     LVAL val;
216 
217     /* get the node */
218     val = xlgetarg();
219     xllastarg();
220 
221     /* return the address of the node */
222     return (cvfixnum((FIXTYPE)val));
223 }
224 #endif /* PEEK_AND_POKE */
225 
226 /* xprofile - turn profiling on and off */
xprofile(void)227 LVAL xprofile(void)
228 {
229     LVAL flag, result;
230 
231     /* get the argument */
232     flag = xlgetarg();
233     xllastarg();
234 
235     result = (profile_flag ? s_true : NIL);
236     profile_flag = !null(flag);
237     /* turn off profiling right away: */
238     if (!profile_flag) profile_count_ptr = &invisible_counter;
239     return result;
240 }
241 
242 
243 #ifdef DEBUG_INPUT
244 FILE *debug_input_fp = NULL;
245 
246 FILE *to_input_buffer = NULL;
247 FILE *read_by_xlisp = NULL;
248 
xstartrecordio(void)249 LVAL xstartrecordio(void)
250 {
251     to_input_buffer = NULL;
252     if (ok_to_open("to-input-buffer.txt", "w"))
253 	to_input_buffer = fopen("to-input-buffer.txt", "w");
254     read_by_xlisp = NULL;
255     if (ok_to_open("read-by-xlisp.txt", "w"))
256 	read_by_xlisp = fopen("read-by-xlisp.txt", "w");
257 	if (!to_input_buffer || !read_by_xlisp) {
258 		return NIL;
259 	}
260 	return s_true;
261 }
262 
263 
xstoprecordio(void)264 LVAL xstoprecordio(void)
265 {
266 	if (to_input_buffer) fclose(to_input_buffer);
267 	if (read_by_xlisp) fclose(read_by_xlisp);
268 	to_input_buffer = NULL;
269 	read_by_xlisp = NULL;
270 	return NIL;
271 }
272 
273 #endif
274 
275 /* xgetruntime - get current run_time */
xgetruntime(void)276 LVAL xgetruntime(void)
277 {
278     /* return the value of run_time variable as integer */
279     return cvfixnum((FIXTYPE) run_time);
280 }
281