1 /* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
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)
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.
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.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
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.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
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.
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.
47 #include <sys/param.h>
60 extern char *getenv ();
63 /* {Top Level Evaluation}
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.
71 /* {Printing Objects to Strings}
75 static GSCM_status gscm_portprint_obj
SCM_P ((SCM port
, SCM obj
));
78 gscm_portprint_obj (port
, obj
)
82 scm_prin1 (obj
, port
, 1);
87 struct seval_str_frame
96 static void _seval_str_fn
SCM_P ((void * vframe
));
99 _seval_str_fn (vframe
)
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
);
110 static GSCM_status gscm_strprint_obj
SCM_P ((SCM
* answer
, SCM obj
));
113 gscm_strprint_obj (answer
, obj
)
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
);
126 *answer
= SCM_BOOL_F
;
131 static GSCM_status gscm_cstr
SCM_P ((char ** answer
, SCM obj
));
134 gscm_cstr (answer
, obj
)
140 *answer
= (char *)malloc (SCM_LENGTH (obj
));
143 stat
= GSCM_OUT_OF_MEM
;
145 memcpy (*answer
, SCM_CHARS (obj
), SCM_LENGTH (obj
));
150 /* {Invoking The Interpreter}
154 static SCM gscm_silent_repl
SCM_P ((SCM env
));
157 gscm_silent_repl (env
)
162 answer
= SCM_UNSPECIFIED
;
163 while ((source
= scm_read (SCM_UNDEFINED
, SCM_UNDEFINED
, SCM_UNDEFINED
)) != SCM_EOF_VAL
)
164 answer
= scm_eval_x (source
);
170 typedef int setjmp_type
;
172 typedef long setjmp_type
;
176 static GSCM_status _eval_port
SCM_P ((SCM
* answer
, GSCM_top_level toplvl
, SCM port
, int printp
));
179 _eval_port (answer
, toplvl
, port
, printp
)
181 GSCM_top_level toplvl
;
188 static int deja_vu
= 0;
192 return GSCM_ILLEGALLY_REENTERED
;
195 /* Take over signal handlers for all the interesting signals.
200 /* Default return values:
205 *answer
= SCM_BOOL_F
;
207 /* Perform evalutation under a new dynamic root.
210 SCM_BASE (scm_rootcont
) = (SCM_STACKITEM
*) & i
;
211 #ifdef DEBUG_EXTENSIONS
212 SCM_DFRAME (scm_rootcont
) = scm_last_debug_frame
= 0;
214 saved_inp
= scm_cur_inp
;
215 i
= setjmp (SCM_JMPBUF (scm_rootcont
));
216 #ifdef STACK_CHECKING
217 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
221 scm_gc_heap_lock
= 0;
222 scm_ints_disabled
= 0;
223 /* need to close loading files here. */
228 *answer
= gscm_silent_repl (top_env
);
230 scm_cur_inp
= saved_inp
;
232 status
= gscm_strprint_obj (answer
, *answer
);
236 scm_cur_inp
= saved_inp
;
237 *answer
= scm_exitval
;
239 gscm_strprint_obj (answer
, *answer
);
243 scm_gc_heap_lock
= 1;
244 scm_ints_disabled
= 1;
245 scm_restore_signals ();
251 static GSCM_status seval_str
SCM_P ((SCM
*answer
, GSCM_top_level toplvl
, char * str
));
254 seval_str (answer
, toplvl
, str
)
256 GSCM_top_level toplvl
;
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);
272 gscm_seval_str (answer
, toplvl
, str
)
274 GSCM_top_level toplvl
;
280 status
= seval_str (answer
, toplvl
, str
);
287 format_load_command (buf
, file_name
)
291 char quoted_name
[MAXPATHLEN
+ 1];
295 for (source
= dest
= 0; file_name
[source
]; ++source
)
297 if (file_name
[source
] == '"')
298 quoted_name
[dest
++] = '\\';
299 quoted_name
[dest
++] = file_name
[source
];
301 quoted_name
[dest
] = 0;
302 sprintf (buf
, "(%%try-load \"%s\")", quoted_name
);
307 gscm_seval_file (answer
, toplvl
, file_name
)
309 GSCM_top_level toplvl
;
312 char command
[MAXPATHLEN
* 3];
313 format_load_command (command
, file_name
);
314 return gscm_seval_str (answer
, toplvl
, command
);
319 static GSCM_status eval_str
SCM_P ((char ** answer
, GSCM_top_level toplvl
, char * str
));
322 eval_str (answer
, toplvl
, str
)
324 GSCM_top_level toplvl
;
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);
337 if (status
== GSCM_OK
)
338 status
= gscm_cstr (answer
, sanswer
);
348 gscm_eval_str (answer
, toplvl
, str
)
350 GSCM_top_level toplvl
;
356 status
= eval_str (answer
, toplvl
, str
);
364 gscm_eval_file (answer
, toplvl
, file_name
)
366 GSCM_top_level toplvl
;
369 char command
[MAXPATHLEN
* 3];
370 format_load_command (command
, file_name
);
371 return gscm_eval_str (answer
, toplvl
, command
);
387 static char * gscm_error_msgs
[] =
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."
402 if ((n
< 0) || (n
> (sizeof (gscm_error_msgs
) / sizeof (char *))))
403 return "Unrecognized error.";
405 return gscm_error_msgs
[n
];
410 /* {Defining New Procedures}
415 gscm_make_subr (fn
, req
, opt
, varp
, doc
)
422 return scm_make_gsubr ("*anonymous*", req
, opt
, varp
, fn
);
430 SCM_ASSERT (SCM_ICHRP (c
), c
, SCM_ARG1
, "gscm_2_char");
438 gscm_2_str (out
, len_out
, objp
)
443 SCM_ASSERT (SCM_NIMP (*objp
) && SCM_STRINGP (*objp
), *objp
, SCM_ARG3
, "gscm_2_str");
445 *out
= SCM_CHARS (*objp
);
447 *len_out
= SCM_LENGTH (*objp
);
453 gscm_error (message
, args
)
460 errsym
= SCM_CAR (scm_intern ("error", 5));
461 str
= scm_makfrom0str (message
);
462 scm_throw (errsym
, scm_cons (str
, args
));
468 gscm_run_scm (argc
, argv
, in
, out
, err
, initfn
, initfile
, initcmd
)
474 GSCM_status (*initfn
)();
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
);
490 /* scm_init_debug (); */
493 scm_init_arbiters ();
497 scm_init_continuations ();
508 scm_init_lvectors ();
513 scm_init_procprop ();
515 scm_init_stackchk ();
516 scm_init_strports ();
522 scm_init_sequences ();
525 scm_init_strorder ();
526 scm_init_mbstrings ();
529 scm_init_variable ();
544 /* Save the argument list to be the return value of (program-arguments).
546 scm_progargs
= scm_makfromstrs (argc
, argv
);
548 scm_gc_heap_lock
= 0;
550 scm_ints_disabled
= 1;
556 if (initfile
== NULL
)
558 initfile
= getenv ("GUILE_INIT_PATH");
559 if (initfile
== NULL
)
560 initfile
= SCM_IMPLINIT
;
563 if (initfile
== NULL
)
571 status
= gscm_seval_file (&answer
, -1, initfile
);
572 if ((status
== GSCM_OK
) && (answer
== SCM_BOOL_F
))
573 status
= GSCM_ERROR_OPENING_INIT_FILE
;
578 if (status
== GSCM_OK
)
580 scm_sysintern ("*stdin*", scm_cur_inp
);
581 status
= gscm_seval_str (0, top
, initcmd
);