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