| 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 | |
| 74 | |
| 75 | static GSCM_status gscm_portprint_obj SCM_P ((SCM port, SCM obj)); |
| 76 | |
| 77 | static GSCM_status |
| 78 | gscm_portprint_obj (port, obj) |
| 79 | SCM port; |
| 80 | SCM obj; |
| 81 | { |
| 82 | scm_prin1 (obj, port, 1); |
| 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 | |
| 95 | |
| 96 | static void _seval_str_fn SCM_P ((void * vframe)); |
| 97 | |
| 98 | static void |
| 99 | _seval_str_fn (vframe) |
| 100 | void * vframe; |
| 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 | |
| 109 | |
| 110 | static GSCM_status gscm_strprint_obj SCM_P ((SCM * answer, SCM obj)); |
| 111 | |
| 112 | static GSCM_status |
| 113 | gscm_strprint_obj (answer, obj) |
| 114 | SCM * answer; |
| 115 | SCM obj; |
| 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 | |
| 130 | |
| 131 | static GSCM_status gscm_cstr SCM_P ((char ** answer, SCM obj)); |
| 132 | |
| 133 | static GSCM_status |
| 134 | gscm_cstr (answer, obj) |
| 135 | char ** answer; |
| 136 | SCM obj; |
| 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 | |
| 153 | |
| 154 | static SCM gscm_silent_repl SCM_P ((SCM env)); |
| 155 | |
| 156 | static SCM |
| 157 | gscm_silent_repl (env) |
| 158 | SCM env; |
| 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 | |
| 175 | |
| 176 | static GSCM_status _eval_port SCM_P ((SCM * answer, GSCM_top_level toplvl, SCM port, int printp)); |
| 177 | |
| 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; |
| 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 |
| 212 | SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; |
| 213 | #endif |
| 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; |
| 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 | |
| 250 | |
| 251 | static GSCM_status seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str)); |
| 252 | |
| 253 | static GSCM_status |
| 254 | seval_str (answer, toplvl, str) |
| 255 | SCM *answer; |
| 256 | GSCM_top_level toplvl; |
| 257 | char * str; |
| 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 | |
| 270 | |
| 271 | GSCM_status |
| 272 | gscm_seval_str (answer, toplvl, str) |
| 273 | SCM *answer; |
| 274 | GSCM_top_level toplvl; |
| 275 | char * str; |
| 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 | |
| 285 | |
| 286 | void |
| 287 | format_load_command (buf, file_name) |
| 288 | char * buf; |
| 289 | char *file_name; |
| 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 | |
| 305 | |
| 306 | GSCM_status |
| 307 | gscm_seval_file (answer, toplvl, file_name) |
| 308 | SCM *answer; |
| 309 | GSCM_top_level toplvl; |
| 310 | char * file_name; |
| 311 | { |
| 312 | char command[MAXPATHLEN * 3]; |
| 313 | format_load_command (command, file_name); |
| 314 | return gscm_seval_str (answer, toplvl, command); |
| 315 | } |
| 316 | |
| 317 | |
| 318 | |
| 319 | static GSCM_status eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str)); |
| 320 | |
| 321 | static GSCM_status |
| 322 | eval_str (answer, toplvl, str) |
| 323 | char ** answer; |
| 324 | GSCM_top_level toplvl; |
| 325 | char * str; |
| 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 | |
| 346 | |
| 347 | GSCM_status |
| 348 | gscm_eval_str (answer, toplvl, str) |
| 349 | char ** answer; |
| 350 | GSCM_top_level toplvl; |
| 351 | char * str; |
| 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 | |
| 362 | |
| 363 | GSCM_status |
| 364 | gscm_eval_file (answer, toplvl, file_name) |
| 365 | char ** answer; |
| 366 | GSCM_top_level toplvl; |
| 367 | char * file_name; |
| 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 | |
| 397 | |
| 398 | char * |
| 399 | gscm_error_msg (n) |
| 400 | int n; |
| 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 | |
| 413 | |
| 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; |
| 421 | { |
| 422 | return scm_make_gsubr ("*anonymous*", req, opt, varp, fn); |
| 423 | } |
| 424 | \f |
| 425 | |
| 426 | int |
| 427 | gscm_2_char (c) |
| 428 | SCM c; |
| 429 | { |
| 430 | SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char"); |
| 431 | return SCM_ICHR (c); |
| 432 | } |
| 433 | |
| 434 | \f |
| 435 | |
| 436 | |
| 437 | void |
| 438 | gscm_2_str (out, len_out, objp) |
| 439 | char ** out; |
| 440 | int * len_out; |
| 441 | SCM * objp; |
| 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 | |
| 451 | |
| 452 | void |
| 453 | gscm_error (message, args) |
| 454 | char * message; |
| 455 | SCM args; |
| 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 |
| 466 | |
| 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; |
| 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 (); |
| 531 | scm_init_version (); |
| 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 | |
| 588 | |
| 589 | void |
| 590 | scm_init_guile () |
| 591 | { |
| 592 | #include "gscm.x" |
| 593 | } |
| 594 | |