Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. |
2 | * | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | * | |
17 | * As a special exception, the Free Software Foundation gives permission | |
18 | * for additional uses of the text contained in its release of GUILE. | |
19 | * | |
20 | * The exception is that, if you link the GUILE library with other files | |
21 | * to produce an executable, this does not by itself cause the | |
22 | * resulting executable to be covered by the GNU General Public License. | |
23 | * Your use of that executable is in no way restricted on account of | |
24 | * linking the GUILE library code into it. | |
25 | * | |
26 | * This exception does not however invalidate any other reasons why | |
27 | * the executable file might be covered by the GNU General Public License. | |
28 | * | |
29 | * This exception applies only to the code released by the | |
30 | * Free Software Foundation under the name GUILE. If you copy | |
31 | * code from other Free Software Foundation releases into a copy of | |
32 | * GUILE, as the General Public License permits, the exception does | |
33 | * not apply to the code that you add in this way. To avoid misleading | |
34 | * anyone as to the status of such modified files, you must delete | |
35 | * this exception notice from them. | |
36 | * | |
37 | * If you write modifications of your own for GUILE, it is your choice | |
38 | * whether to permit this exception to apply to your modifications. | |
39 | * If you do not wish that, delete this exception notice. | |
40 | */ | |
41 | \f | |
42 | ||
43 | ||
44 | \f | |
45 | ||
46 | #include <stdio.h> | |
47 | #include <sys/param.h> | |
48 | #include "gscm.h" | |
49 | #include "_scm.h" | |
50 | ||
51 | #ifdef HAVE_UNISTD_H | |
52 | #include <unistd.h> | |
53 | #endif | |
54 | #ifdef HAVE_STRING_H | |
55 | #include <string.h> | |
56 | #endif | |
57 | ||
58 | \f | |
59 | ||
60 | extern char *getenv (); | |
61 | ||
62 | \f | |
63 | /* {Top Level Evaluation} | |
64 | * | |
65 | * Top level evaluation has to establish a dynamic root context, | |
66 | * enable Scheme signal handlers, and catch global escapes (errors, quits, | |
67 | * aborts, restarts, and execs) from the interpreter. | |
68 | */ | |
69 | ||
70 | ||
71 | /* {Printing Objects to Strings} | |
72 | */ | |
73 | ||
1cc91f1b JB |
74 | |
75 | static GSCM_status gscm_portprint_obj SCM_P ((SCM port, SCM obj)); | |
76 | ||
0f2d19dd JB |
77 | static GSCM_status |
78 | gscm_portprint_obj (port, obj) | |
79 | SCM port; | |
80 | SCM obj; | |
0f2d19dd | 81 | { |
c88edfaf | 82 | scm_prin1 (obj, port, 1); |
0f2d19dd JB |
83 | return GSCM_OK; |
84 | } | |
85 | ||
86 | ||
87 | struct seval_str_frame | |
88 | { | |
89 | GSCM_status status; | |
90 | SCM * answer; | |
91 | GSCM_top_level top; | |
92 | char * str; | |
93 | }; | |
94 | ||
1cc91f1b JB |
95 | |
96 | static void _seval_str_fn SCM_P ((void * vframe)); | |
97 | ||
0f2d19dd JB |
98 | static void |
99 | _seval_str_fn (vframe) | |
100 | void * vframe; | |
0f2d19dd JB |
101 | { |
102 | struct seval_str_frame * frame; | |
103 | frame = (struct seval_str_frame *)vframe; | |
104 | frame->status = gscm_seval_str (frame->answer, frame->top, frame->str); | |
105 | } | |
106 | ||
107 | ||
108 | ||
1cc91f1b JB |
109 | |
110 | static GSCM_status gscm_strprint_obj SCM_P ((SCM * answer, SCM obj)); | |
111 | ||
0f2d19dd JB |
112 | static GSCM_status |
113 | gscm_strprint_obj (answer, obj) | |
114 | SCM * answer; | |
115 | SCM obj; | |
0f2d19dd JB |
116 | { |
117 | SCM str; | |
118 | SCM port; | |
119 | GSCM_status stat; | |
120 | str = scm_makstr (64, 0); | |
121 | port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "gscm_strprint_obj"); | |
122 | stat = gscm_portprint_obj (port, obj); | |
123 | if (stat == GSCM_OK) | |
124 | *answer = str; | |
125 | else | |
126 | *answer = SCM_BOOL_F; | |
127 | return stat; | |
128 | } | |
129 | ||
1cc91f1b JB |
130 | |
131 | static GSCM_status gscm_cstr SCM_P ((char ** answer, SCM obj)); | |
132 | ||
0f2d19dd JB |
133 | static GSCM_status |
134 | gscm_cstr (answer, obj) | |
135 | char ** answer; | |
136 | SCM obj; | |
0f2d19dd JB |
137 | { |
138 | GSCM_status stat; | |
139 | ||
140 | *answer = (char *)malloc (SCM_LENGTH (obj)); | |
141 | stat = GSCM_OK; | |
142 | if (!*answer) | |
143 | stat = GSCM_OUT_OF_MEM; | |
144 | else | |
145 | memcpy (*answer, SCM_CHARS (obj), SCM_LENGTH (obj)); | |
146 | return stat; | |
147 | } | |
148 | ||
149 | ||
150 | /* {Invoking The Interpreter} | |
151 | */ | |
152 | ||
1cc91f1b JB |
153 | |
154 | static SCM gscm_silent_repl SCM_P ((SCM env)); | |
155 | ||
0f2d19dd JB |
156 | static SCM |
157 | gscm_silent_repl (env) | |
158 | SCM env; | |
0f2d19dd JB |
159 | { |
160 | SCM source; | |
161 | SCM answer; | |
162 | answer = SCM_UNSPECIFIED; | |
163 | while ((source = scm_read (SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED)) != SCM_EOF_VAL) | |
164 | answer = scm_eval_x (source); | |
165 | return answer; | |
166 | } | |
167 | ||
168 | ||
169 | #ifdef _UNICOS | |
170 | typedef int setjmp_type; | |
171 | #else | |
172 | typedef long setjmp_type; | |
173 | #endif | |
174 | ||
1cc91f1b JB |
175 | |
176 | static GSCM_status _eval_port SCM_P ((SCM * answer, GSCM_top_level toplvl, SCM port, int printp)); | |
177 | ||
0f2d19dd JB |
178 | static GSCM_status |
179 | _eval_port (answer, toplvl, port, printp) | |
180 | SCM * answer; | |
181 | GSCM_top_level toplvl; | |
182 | SCM port; | |
183 | int printp; | |
0f2d19dd JB |
184 | { |
185 | SCM saved_inp; | |
186 | GSCM_status status; | |
187 | setjmp_type i; | |
188 | static int deja_vu = 0; | |
189 | SCM ignored; | |
190 | ||
191 | if (deja_vu) | |
192 | return GSCM_ILLEGALLY_REENTERED; | |
193 | ||
194 | ++deja_vu; | |
195 | /* Take over signal handlers for all the interesting signals. | |
196 | */ | |
197 | scm_init_signals (); | |
198 | ||
199 | ||
200 | /* Default return values: | |
201 | */ | |
202 | if (!answer) | |
203 | answer = &ignored; | |
204 | status = GSCM_OK; | |
205 | *answer = SCM_BOOL_F; | |
206 | ||
207 | /* Perform evalutation under a new dynamic root. | |
208 | * | |
209 | */ | |
210 | SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i; | |
211 | #ifdef DEBUG_EXTENSIONS | |
1646d37b | 212 | SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; |
0f2d19dd JB |
213 | #endif |
214 | saved_inp = scm_cur_inp; | |
215 | i = setjmp (SCM_JMPBUF (scm_rootcont)); | |
faa6b3df MD |
216 | #ifdef STACK_CHECKING |
217 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; | |
0f2d19dd JB |
218 | #endif |
219 | if (!i) | |
220 | { | |
221 | scm_gc_heap_lock = 0; | |
222 | scm_ints_disabled = 0; | |
223 | /* need to close loading files here. */ | |
224 | scm_cur_inp = port; | |
225 | { | |
226 | SCM top_env; | |
227 | top_env = SCM_EOL; | |
228 | *answer = gscm_silent_repl (top_env); | |
229 | } | |
230 | scm_cur_inp = saved_inp; | |
231 | if (printp) | |
232 | status = gscm_strprint_obj (answer, *answer); | |
233 | } | |
234 | else | |
235 | { | |
236 | scm_cur_inp = saved_inp; | |
237 | *answer = scm_exitval; | |
238 | if (printp) | |
239 | gscm_strprint_obj (answer, *answer); | |
240 | status = GSCM_ERROR; | |
241 | } | |
242 | ||
243 | scm_gc_heap_lock = 1; | |
244 | scm_ints_disabled = 1; | |
245 | scm_restore_signals (); | |
246 | --deja_vu; | |
247 | return status; | |
248 | } | |
249 | ||
1cc91f1b JB |
250 | |
251 | static GSCM_status seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str)); | |
252 | ||
0f2d19dd JB |
253 | static GSCM_status |
254 | seval_str (answer, toplvl, str) | |
255 | SCM *answer; | |
256 | GSCM_top_level toplvl; | |
257 | char * str; | |
0f2d19dd JB |
258 | { |
259 | SCM scheme_str; | |
260 | SCM port; | |
261 | GSCM_status status; | |
262 | ||
263 | scheme_str = scm_makfromstr (str, strlen (str), 0); | |
264 | port = scm_mkstrport (SCM_MAKINUM (0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_seval_str"); | |
265 | status = _eval_port (answer, toplvl, port, 0); | |
266 | return status; | |
267 | } | |
268 | ||
269 | ||
1cc91f1b | 270 | |
0f2d19dd JB |
271 | GSCM_status |
272 | gscm_seval_str (answer, toplvl, str) | |
273 | SCM *answer; | |
274 | GSCM_top_level toplvl; | |
275 | char * str; | |
0f2d19dd JB |
276 | { |
277 | SCM_STACKITEM i; | |
278 | GSCM_status status; | |
279 | scm_stack_base = &i; | |
280 | status = seval_str (answer, toplvl, str); | |
281 | scm_stack_base = 0; | |
282 | return status; | |
283 | } | |
284 | ||
1cc91f1b | 285 | |
0f2d19dd JB |
286 | void |
287 | format_load_command (buf, file_name) | |
288 | char * buf; | |
289 | char *file_name; | |
0f2d19dd JB |
290 | { |
291 | char quoted_name[MAXPATHLEN + 1]; | |
292 | int source; | |
293 | int dest; | |
294 | ||
295 | for (source = dest = 0; file_name[source]; ++source) | |
296 | { | |
297 | if (file_name[source] == '"') | |
298 | quoted_name[dest++] = '\\'; | |
299 | quoted_name[dest++] = file_name[source]; | |
300 | } | |
301 | quoted_name[dest] = 0; | |
302 | sprintf (buf, "(%%try-load \"%s\")", quoted_name); | |
303 | } | |
304 | ||
1cc91f1b | 305 | |
0f2d19dd JB |
306 | GSCM_status |
307 | gscm_seval_file (answer, toplvl, file_name) | |
308 | SCM *answer; | |
309 | GSCM_top_level toplvl; | |
310 | char * file_name; | |
0f2d19dd JB |
311 | { |
312 | char command[MAXPATHLEN * 3]; | |
313 | format_load_command (command, file_name); | |
314 | return gscm_seval_str (answer, toplvl, command); | |
315 | } | |
316 | ||
317 | ||
1cc91f1b JB |
318 | |
319 | static GSCM_status eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str)); | |
320 | ||
0f2d19dd JB |
321 | static GSCM_status |
322 | eval_str (answer, toplvl, str) | |
323 | char ** answer; | |
324 | GSCM_top_level toplvl; | |
325 | char * str; | |
0f2d19dd JB |
326 | { |
327 | SCM sanswer; | |
328 | SCM scheme_str; | |
329 | SCM port; | |
330 | GSCM_status status; | |
331 | ||
332 | scheme_str = scm_makfromstr (str, strlen (str), 0); | |
333 | port = scm_mkstrport (SCM_MAKINUM(0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_eval_str"); | |
334 | status = _eval_port (&sanswer, toplvl, port, 1); | |
335 | if (answer) | |
336 | { | |
337 | if (status == GSCM_OK) | |
338 | status = gscm_cstr (answer, sanswer); | |
339 | else | |
340 | *answer = 0; | |
341 | } | |
342 | return status; | |
343 | } | |
344 | ||
345 | ||
1cc91f1b | 346 | |
0f2d19dd JB |
347 | GSCM_status |
348 | gscm_eval_str (answer, toplvl, str) | |
349 | char ** answer; | |
350 | GSCM_top_level toplvl; | |
351 | char * str; | |
0f2d19dd JB |
352 | { |
353 | SCM_STACKITEM i; | |
354 | GSCM_status status; | |
355 | scm_stack_base = &i; | |
356 | status = eval_str (answer, toplvl, str); | |
357 | scm_stack_base = 0; | |
358 | return status; | |
359 | } | |
360 | ||
361 | ||
1cc91f1b | 362 | |
0f2d19dd JB |
363 | GSCM_status |
364 | gscm_eval_file (answer, toplvl, file_name) | |
365 | char ** answer; | |
366 | GSCM_top_level toplvl; | |
367 | char * file_name; | |
0f2d19dd JB |
368 | { |
369 | char command[MAXPATHLEN * 3]; | |
370 | format_load_command (command, file_name); | |
371 | return gscm_eval_str (answer, toplvl, command); | |
372 | } | |
373 | ||
374 | ||
375 | ||
376 | \f | |
377 | /* {Error Messages} | |
378 | */ | |
379 | ||
380 | ||
381 | #ifdef __GNUC__ | |
382 | # define AT(X) [X] = | |
383 | #else | |
384 | # define AT(X) | |
385 | #endif | |
386 | ||
387 | static char * gscm_error_msgs[] = | |
388 | { | |
389 | AT(GSCM_OK) "No error.", | |
390 | AT(GSCM_ERROR) "ERROR in init file.", | |
391 | AT(GSCM_ILLEGALLY_REENTERED) "Gscm function was illegally reentered.", | |
392 | AT(GSCM_OUT_OF_MEM) "Out of memory.", | |
393 | AT(GSCM_ERROR_OPENING_FILE) "Error opening file.", | |
394 | AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file." | |
395 | }; | |
396 | ||
1cc91f1b | 397 | |
0f2d19dd JB |
398 | char * |
399 | gscm_error_msg (n) | |
400 | int n; | |
0f2d19dd JB |
401 | { |
402 | if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *)))) | |
403 | return "Unrecognized error."; | |
404 | else | |
405 | return gscm_error_msgs[n]; | |
406 | } | |
407 | ||
408 | ||
409 | \f | |
410 | /* {Defining New Procedures} | |
411 | */ | |
412 | ||
1cc91f1b | 413 | |
0f2d19dd JB |
414 | SCM |
415 | gscm_make_subr (fn, req, opt, varp, doc) | |
416 | SCM (*fn)(); | |
417 | int req; | |
418 | int opt; | |
419 | int varp; | |
420 | char * doc; | |
0f2d19dd JB |
421 | { |
422 | return scm_make_gsubr ("*anonymous*", req, opt, varp, fn); | |
423 | } | |
424 | \f | |
1cc91f1b | 425 | |
0f2d19dd JB |
426 | int |
427 | gscm_2_char (c) | |
428 | SCM c; | |
0f2d19dd JB |
429 | { |
430 | SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char"); | |
431 | return SCM_ICHR (c); | |
432 | } | |
433 | ||
434 | \f | |
435 | ||
1cc91f1b | 436 | |
0f2d19dd JB |
437 | void |
438 | gscm_2_str (out, len_out, objp) | |
439 | char ** out; | |
440 | int * len_out; | |
441 | SCM * objp; | |
0f2d19dd JB |
442 | { |
443 | SCM_ASSERT (SCM_NIMP (*objp) && SCM_STRINGP (*objp), *objp, SCM_ARG3, "gscm_2_str"); | |
444 | if (out) | |
445 | *out = SCM_CHARS (*objp); | |
446 | if (len_out) | |
447 | *len_out = SCM_LENGTH (*objp); | |
448 | } | |
449 | \f | |
450 | ||
1cc91f1b | 451 | |
0f2d19dd JB |
452 | void |
453 | gscm_error (message, args) | |
454 | char * message; | |
455 | SCM args; | |
0f2d19dd JB |
456 | { |
457 | SCM errsym; | |
458 | SCM str; | |
459 | ||
460 | errsym = SCM_CAR (scm_intern ("error", 5)); | |
461 | str = scm_makfrom0str (message); | |
462 | scm_throw (errsym, scm_cons (str, args)); | |
463 | } | |
464 | ||
465 | \f | |
1cc91f1b | 466 | |
0f2d19dd JB |
467 | GSCM_status |
468 | gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd) | |
469 | int argc; | |
470 | char ** argv; | |
471 | FILE * in; | |
472 | FILE * out; | |
473 | FILE * err; | |
474 | GSCM_status (*initfn)(); | |
475 | char * initfile; | |
476 | char * initcmd; | |
0f2d19dd JB |
477 | { |
478 | SCM_STACKITEM i; | |
479 | GSCM_status status; | |
480 | GSCM_top_level top; | |
481 | ||
482 | scm_ports_prehistory (); | |
483 | scm_smob_prehistory (); | |
484 | scm_tables_prehistory (); | |
485 | scm_init_storage (0); | |
486 | scm_start_stack (&i, in, out, err); | |
487 | scm_init_gsubr (); | |
488 | scm_init_curry (); | |
489 | scm_init_feature (); | |
490 | /* scm_init_debug (); */ | |
491 | scm_init_alist (); | |
492 | scm_init_append (); | |
493 | scm_init_arbiters (); | |
494 | scm_init_async (); | |
495 | scm_init_boolean (); | |
496 | scm_init_chars (); | |
497 | scm_init_continuations (); | |
498 | scm_init_dynwind (); | |
499 | scm_init_eq (); | |
500 | scm_init_error (); | |
501 | scm_init_fports (); | |
502 | scm_init_files (); | |
503 | scm_init_gc (); | |
504 | scm_init_hash (); | |
505 | scm_init_hashtab (); | |
506 | scm_init_kw (); | |
507 | scm_init_list (); | |
508 | scm_init_lvectors (); | |
509 | scm_init_numbers (); | |
510 | scm_init_pairs (); | |
511 | scm_init_ports (); | |
512 | scm_init_procs (); | |
513 | scm_init_procprop (); | |
514 | scm_init_scmsigs (); | |
515 | scm_init_stackchk (); | |
516 | scm_init_strports (); | |
517 | scm_init_struct (); | |
518 | scm_init_symbols (); | |
519 | scm_init_load (); | |
520 | scm_init_print (); | |
521 | scm_init_read (); | |
522 | scm_init_sequences (); | |
523 | scm_init_stime (); | |
524 | scm_init_strings (); | |
525 | scm_init_strorder (); | |
526 | scm_init_mbstrings (); | |
527 | scm_init_strop (); | |
528 | scm_init_throw (); | |
529 | scm_init_variable (); | |
530 | scm_init_vectors (); | |
9d7e1edf | 531 | scm_init_version (); |
0f2d19dd JB |
532 | scm_init_weaks (); |
533 | scm_init_vports (); | |
534 | scm_init_eval (); | |
535 | scm_init_ramap (); | |
536 | scm_init_unif (); | |
537 | scm_init_simpos (); | |
538 | scm_init_elisp (); | |
539 | scm_init_mallocs (); | |
540 | scm_init_cnsvobj (); | |
541 | scm_init_guile (); | |
542 | initfn (); | |
543 | ||
544 | /* Save the argument list to be the return value of (program-arguments). | |
545 | */ | |
546 | scm_progargs = scm_makfromstrs (argc, argv); | |
547 | ||
548 | scm_gc_heap_lock = 0; | |
549 | errno = 0; | |
550 | scm_ints_disabled = 1; | |
551 | ||
552 | /* init_basic (); */ | |
553 | ||
554 | /* init_init(); */ | |
555 | ||
556 | if (initfile == NULL) | |
557 | { | |
558 | initfile = getenv ("GUILE_INIT_PATH"); | |
559 | if (initfile == NULL) | |
560 | initfile = SCM_IMPLINIT; | |
561 | } | |
562 | ||
563 | if (initfile == NULL) | |
564 | { | |
565 | status = GSCM_OK; | |
566 | } | |
567 | else | |
568 | { | |
569 | SCM answer; | |
570 | ||
571 | status = gscm_seval_file (&answer, -1, initfile); | |
572 | if ((status == GSCM_OK) && (answer == SCM_BOOL_F)) | |
573 | status = GSCM_ERROR_OPENING_INIT_FILE; | |
574 | } | |
575 | ||
576 | top = SCM_EOL; | |
577 | ||
578 | if (status == GSCM_OK) | |
579 | { | |
580 | scm_sysintern ("*stdin*", scm_cur_inp); | |
581 | status = gscm_seval_str (0, top, initcmd); | |
582 | } | |
583 | return status; | |
584 | } | |
585 | ||
586 | \f | |
587 | ||
1cc91f1b | 588 | |
0f2d19dd JB |
589 | void |
590 | scm_init_guile () | |
0f2d19dd JB |
591 | { |
592 | #include "gscm.x" | |
593 | } | |
594 |