1 /* main.c -- Entry point for Jade
2 Copyright (C) 1993, 1994 John Harper <john@dcs.warwick.ac.uk>
3 $Id$
4
5 This file is part of Jade.
6
7 Jade is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 Jade is distributed in the hope that it will be useful, but
13 WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with Jade; see the file COPYING. If not, write to
19 the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
20
21 #define _GNU_SOURCE
22
23 #include "repint.h"
24 #include <string.h>
25 #include <limits.h>
26
27 void *rep_common_db;
28
29 int rep_recurse_depth = -1;
30
31 rep_bool (*rep_on_idle_fun)(int since_last);
32 DEFSYM(idle_hook, "idle-hook"); /*
33 ::doc:idle-hook::
34 This hook gets evaluated every second while the editor is idle. Don't depend
35 on how regularly this gets called, any events from the window-system will
36 delay it. Also, auto-saving files and garbage-collection take precedence
37 when there's idle time available. Use this hook sparingly, or for short
38 periods only!
39 ::end::
40 ::doc:program-name::
41 The name of the program running the rep interpreter.
42 ::end::
43 ::doc:error-mode::
44 When nil, errors are handled at the current event loop, other possible
45 values include `exit' and `top-level'.
46 ::end::
47 ::doc:interrupt-mode::
48 When nil, interrupts are handled at the current event loop, other possible
49 values include `exit' and `top-level'.
50 ::end:: */
51
52 /* Called when we get a termination signal. */
53 void (*rep_on_termination_fun)(void);
54
55 /* The event-loop function, may be entered recursively. */
56 repv (*rep_event_loop_fun)(void) = rep_event_loop;
57
58 /* rep_init () will set this to an early stack pointer */
59 char *rep_stack_bottom;
60
61 DEFSYM(exit, "exit");
62 DEFSYM(quit, "quit");
63 DEFSYM(top_level, "top-level");
64 DEFSYM(command_line_args, "command-line-args");
65 DEFSYM(batch_mode, "batch-mode");
66 DEFSYM(interpreted_mode, "interpreted-mode");
67 DEFSYM(program_name, "program-name");
68 DEFSYM(error_mode, "error-mode");
69 DEFSYM(interrupt_mode, "interrupt-mode");
70 DEFSYM(before_exit_hook, "before-exit-hook");
71
72 static void rep_main_init(void);
73
74 DEFSTRING(noarg, "No argument for option");
75
76 /* Look for the command line option called OPTION. If ARGP is non-null,
77 the option requires an argument, it will be stored in *ARGP. If
78 the option isn't given return false, else return true. */
79 rep_bool
rep_get_option(char * option,repv * argp)80 rep_get_option (char *option, repv *argp)
81 {
82 int optlen = strlen(option);
83 repv tem = Fsymbol_value (Qcommand_line_args, Qt);
84 while (!rep_INTERRUPTP && rep_CONSP(tem) && rep_STRINGP(rep_CAR(tem)))
85 {
86 if (strncmp (option, rep_STR(rep_CAR(tem)), optlen) == 0)
87 {
88 repv opt = rep_CAR(tem), cdr = rep_CDR(tem);
89 if (rep_STR(opt)[optlen] == '=' || rep_STR(opt)[optlen] == 0)
90 {
91 Fset (Qcommand_line_args,
92 Fdelq (opt, Fsymbol_value (Qcommand_line_args, Qt)));
93 if (argp != 0)
94 {
95 if (rep_STR(opt)[optlen] == '=')
96 {
97 *argp = rep_string_dup (rep_STR(opt) + optlen + 1);
98 return rep_TRUE;
99 }
100 else if (rep_CONSP(cdr) && rep_STRINGP(rep_CAR(cdr)))
101 {
102 *argp = rep_CAR(cdr);
103 Fset (Qcommand_line_args,
104 Fdelq (*argp, Fsymbol_value(Qcommand_line_args, Qt)));
105 return rep_TRUE;
106 }
107 else
108 {
109 Fsignal (Qerror, rep_list_2(rep_VAL(&noarg),
110 rep_string_dup(option)));
111 return rep_FALSE;
112 }
113 }
114 else
115 return rep_TRUE;
116 }
117 }
118 tem = rep_CDR(tem);
119 rep_TEST_INT;
120 }
121 return rep_FALSE;
122 }
123
124 static int
get_main_options(char * prog_name,int * argc_p,char *** argv_p)125 get_main_options(char *prog_name, int *argc_p, char ***argv_p)
126 {
127 int argc = *argc_p;
128 char **argv = *argv_p;
129 repv head, *last;
130
131 /* any command line args are made into a list of strings
132 in symbol command-line-args. */
133 head = Qnil;
134 last = &head;
135 while(argc > 0)
136 {
137 *last = Fcons(rep_string_dup(*argv), Qnil);
138 last = &rep_CDR(*last);
139 argc--;
140 argv++;
141 }
142 Fset (Qcommand_line_args, head);
143 *argc_p = argc;
144 *argv_p = argv;
145
146 if (rep_get_option("--batch", 0))
147 Fset (Qbatch_mode, Qt);
148
149 if (rep_get_option("--interp", 0))
150 {
151 Fset (Qinterpreted_mode, Qt);
152
153 /* XXX somewhat non-related, but.. */
154 rep_record_origins = rep_TRUE;
155 }
156
157 return rep_TRUE;
158 }
159
160 /* GCC 4 helpfully inlines this function and breaks the stack check. */
161 #if __GNUC__ >= 4
162 static void check_configuration (int *stack_low) __attribute__ ((noinline));
163 #endif
164
165 void
check_configuration(int * stack_low)166 check_configuration (int *stack_low)
167 {
168 int stack_high;
169 int stack_dir = (&stack_high < stack_low) ? -1 : +1;
170
171 if (sizeof (rep_PTR_SIZED_INT) < sizeof(void *))
172 {
173 fprintf (stderr,
174 " ** error: --with-value-type is incorrect; it should be `%s'\n",
175 (sizeof (int) >= sizeof (void *)) ? "int"
176 : (sizeof (long) >= sizeof (void *)) ? "long"
177 : (sizeof (rep_long_long) >= sizeof (void *)) ? "long long"
178 : "<unknown>");
179 exit (10);
180 }
181
182 if (sizeof (rep_PTR_SIZED_INT) != rep_PTR_SIZED_INT_SIZEOF)
183 {
184 fprintf (stderr,
185 " ** error: --with-value-sizeof is incorrect; it should be %d\n",
186 (int) sizeof (rep_PTR_SIZED_INT));
187 exit (10);
188 }
189
190 if (stack_dir != STACK_DIRECTION)
191 {
192 fprintf (stderr,
193 " ** error: --with-stack-direction is incorrect; it should be %d\n",
194 stack_dir);
195 exit (10);
196 }
197 }
198
199 /* Note that `argc' _must_ (I mean _must_!) be a pointer to the real
200 argc on the stack frame of the outermost procedure */
201 void
rep_init(char * prog_name,int * argc,char *** argv,void (* sys_symbols)(void),void (* obsolete_sys_usage)(void))202 rep_init(char *prog_name, int *argc, char ***argv,
203 void (*sys_symbols)(void), void (*obsolete_sys_usage)(void))
204 {
205 #ifdef ENABLE_BROKEN_DUMPING
206 char *dump_file = getenv ("REPDUMPFILE");
207 #else
208 char *dump_file = 0;
209 #endif
210 rep_init_from_dump (prog_name, argc, argv,
211 sys_symbols, obsolete_sys_usage, dump_file);
212 }
213
214 void
rep_init_from_dump(char * prog_name,int * argc,char *** argv,void (* sys_symbols)(void),void (* obsolete_sys_usage)(void),char * dump_file)215 rep_init_from_dump(char *prog_name, int *argc, char ***argv,
216 void (*sys_symbols)(void), void (*obsolete_sys_usage)(void),
217 char *dump_file)
218 {
219 int dummy;
220 check_configuration (&dummy);
221
222 if(!sys_memory_init())
223 exit(10);
224
225 rep_common_db = rep_db_alloc("common", 4096);
226
227 rep_pre_values_init();
228 rep_pre_sys_os_init();
229 if(rep_pre_symbols_init())
230 {
231 #ifdef ENABLE_BROKEN_DUMPING
232 char *tem = getenv ("REPUNDUMPED");
233 if (dump_file && (!tem || atoi(tem) == 0))
234 rep_dumped_init (dump_file);
235 #endif
236
237 rep_symbols_init();
238 rep_structures_init ();
239 rep_numbers_init ();
240
241 rep_lisp_init();
242 rep_values_init();
243 rep_origin_init (); /* must be after values */
244 rep_macros_init ();
245 rep_lispcmds_init();
246 rep_lispmach_init();
247 rep_find_init();
248 rep_main_init();
249 rep_misc_init();
250 rep_streams_init();
251 rep_files_init();
252 rep_datums_init();
253 rep_fluids_init();
254 rep_weak_refs_init ();
255 rep_sys_os_init();
256
257 /* XXX Assumes that argc is on the stack. I can't think of
258 XXX any other way to reliably find the real base of the
259 XXX stack.. */
260 rep_stack_bottom = (char *) argc;
261 rep_continuations_init ();
262
263 if (sys_symbols != 0)
264 (*sys_symbols)();
265
266 Fset (Qprogram_name, rep_string_dup (prog_name));
267
268 if(get_main_options(prog_name, argc, argv))
269 return;
270 }
271 exit (10);
272 }
273
274 /* Should be called sometime after calling rep_init*. It will load
275 the standard init scripts, plus FILE if non-nil. Returns the
276 result of the last form evaluated. */
277 repv
rep_load_environment(repv file)278 rep_load_environment (repv file)
279 {
280 /* Modules that have Lisp code stored in the filing system. */
281 static const char *init[] = {
282 "rep.lang.interpreter",
283 "rep.structures",
284 "rep.module-system",
285 "rep.lang.math",
286 "rep.data",
287 "rep.regexp",
288 "rep.system",
289 "rep.io.streams",
290 "rep.io.files",
291 "rep.io.file-handlers",
292 "rep",
293 0
294 };
295 const char **ptr;
296
297 repv res = Qnil;
298 rep_GC_root gc_file;
299
300 rep_PUSHGC (gc_file, file);
301
302 /* 1. Do the rep bootstrap */
303
304 if (rep_dumped_non_constants != rep_NULL)
305 res = Feval (rep_dumped_non_constants);
306
307 for (ptr = init; res != rep_NULL && *ptr != 0; ptr++)
308 {
309 res = rep_bootstrap_structure (*ptr);
310 }
311
312 /* 2. Do the caller-local bootstrap */
313
314 if (res != rep_NULL && rep_STRINGP(file))
315 res = Fload (file, Qnil, Qnil, Qnil, Qnil);
316
317 rep_POPGC;
318 return res;
319 }
320
321 void
rep_kill(void)322 rep_kill(void)
323 {
324 rep_sys_os_kill();
325 rep_find_kill();
326 rep_files_kill();
327 #ifdef HAVE_DYNAMIC_LOADING
328 rep_kill_dl_libraries();
329 #endif
330 rep_lispmach_kill();
331 rep_db_kill();
332 rep_tuples_kill();
333 rep_values_kill();
334 sys_memory_kill();
335 }
336
337 /* This function gets called when we have idle time available. The
338 single argument is the number of seconds since we weren't idle.
339 The first idle period after a non-idle period should pass zero.
340 Returns rep_TRUE if the display should be refreshed. */
341 rep_bool
rep_on_idle(long since_last_event)342 rep_on_idle(long since_last_event)
343 {
344 static rep_bool called_hook;
345 static int depth;
346 rep_bool res = rep_FALSE;
347
348 depth++;
349
350 /* A timeout; do one of:
351 * Remove messages in minibuffers
352 * Print the current key-prefix
353 * Auto-save a buffer
354 * GC if enough data allocated
355 * Run the `idle-hook' (only once per idle-period) */
356
357 if(since_last_event == 0)
358 called_hook = rep_FALSE;
359
360 if(rep_on_idle_fun != 0 && (*rep_on_idle_fun)(since_last_event))
361 res = rep_TRUE;
362 else if(rep_data_after_gc > rep_idle_gc_threshold)
363 /* nothing was saved so try a GC */
364 Fgarbage_collect (Qnil);
365 else if(!called_hook && depth == 1)
366 {
367 repv hook = Fsymbol_value(Qidle_hook, Qt);
368 if(!rep_VOIDP(hook) && !rep_NILP(hook))
369 {
370 Fcall_hook(hook, Qnil, Qnil);
371 res = rep_TRUE;
372 }
373 called_hook = rep_TRUE;
374 }
375
376 depth--;
377 return res;
378 }
379
380 /* The input loop should call this function when rep_throw_value == rep_NULL.
381 It returns rep_TRUE when the input loop should exit, returning whatever
382 is stored in *RESULT-P. */
383 rep_bool
rep_handle_input_exception(repv * result_p)384 rep_handle_input_exception(repv *result_p)
385 {
386 repv tv = rep_throw_value;
387 repv car = rep_CAR(tv);
388 rep_throw_value = rep_NULL;
389 *result_p = rep_NULL;
390
391 if(car == Qexit)
392 {
393 *result_p = rep_CDR(tv);
394 if(rep_recurse_depth > 0)
395 return rep_TRUE;
396 }
397 else if((car == Qtop_level) && (rep_recurse_depth == 0))
398 *result_p = rep_CDR(tv);
399 else if(car == Qquit)
400 {
401 *result_p = rep_CDR(tv);
402 return rep_TRUE;
403 }
404 else if(car == Quser_interrupt)
405 {
406 repv tem = Fsymbol_value (Qinterrupt_mode, Qt);
407 if (tem == Qexit && rep_recurse_depth == 0)
408 goto terminate;
409 else if (rep_recurse_depth == 0 || tem != Qtop_level)
410 rep_handle_error(car, Qnil);
411 else
412 goto unhandled;
413 }
414 else if(car == Qerror)
415 {
416 repv tem = Fsymbol_value (Qerror_mode, Qt);
417 if (tem == Qexit && rep_recurse_depth == 0)
418 {
419 rep_handle_error(rep_CAR(rep_CDR(tv)), rep_CDR(rep_CDR(tv)));
420 goto terminate;
421 }
422 else if (rep_recurse_depth == 0 || tem != Qtop_level)
423 rep_handle_error(rep_CAR(rep_CDR(tv)), rep_CDR(rep_CDR(tv)));
424 else
425 goto unhandled;
426 }
427 else if(car == Qterm_interrupt)
428 {
429 terminate:
430 if(rep_recurse_depth == 0 && rep_on_termination_fun != 0)
431 (*rep_on_termination_fun)();
432 *result_p = Qnil;
433 return rep_TRUE;
434 }
435 #if 0
436 else if(rep_recurse_depth == 0)
437 rep_handle_error(Qno_catcher, rep_LIST_1(car));
438 #endif
439 else
440 {
441 unhandled:
442 rep_throw_value = tv;
443 return rep_TRUE;
444 }
445 return rep_FALSE;
446 }
447
448 /* should be called before exiting (for any reason). returns the value
449 that should be returned by the process */
450 int
rep_top_level_exit(void)451 rep_top_level_exit (void)
452 {
453 rep_GC_root gc_throw;
454 repv throw = rep_throw_value;
455 rep_throw_value = rep_NULL;
456 if(throw && rep_CAR(throw) == Qerror)
457 {
458 /* If quitting due to an error, print the error cell if
459 at all possible. */
460 repv stream = Fstderr_file();
461 if(stream && rep_FILEP(stream))
462 {
463 fputs("error--> ", stderr);
464 Fprin1(rep_CDR(throw), stream);
465 fputc('\n', stderr);
466 }
467 else
468 fputs("error in initialisation\n", stderr);
469 return 10;
470 }
471
472 rep_PUSHGC(gc_throw, throw);
473 Fcall_hook (Qbefore_exit_hook, Qnil, Qnil);
474 rep_throw_value = rep_NULL;
475 rep_POPGC;
476
477 if (throw && rep_CAR (throw) == Qquit && rep_INTP (rep_CDR(throw)))
478 return (rep_INT (rep_CDR(throw)));
479
480 return 0;
481 }
482
483 DEFUN_INT("recursive-edit", Frecursive_edit, Srecursive_edit, (void), rep_Subr0, "") /*
484 ::doc:rep.system#recursive-edit::
485 recursive-edit
486
487 Enter a new recursive-edit.
488 ::end:: */
489 {
490 repv ret;
491
492 rep_recurse_depth++;
493 ret = (*rep_event_loop_fun)();
494 rep_recurse_depth--;
495
496 return ret;
497 }
498
499 /* Called from the main function of input-driven programs. Avoids the
500 program exiting due to an unhandled exception */
501 repv
rep_top_level_recursive_edit(void)502 rep_top_level_recursive_edit (void)
503 {
504 repv ret;
505 again:
506 ret = Frecursive_edit ();
507 if (rep_recurse_depth < 0
508 && rep_throw_value && rep_CONSP (rep_throw_value))
509 {
510 repv type = rep_CAR (rep_throw_value);
511 if (type != Qquit
512 && type != Qerror
513 && type != Qterm_interrupt
514 && type != Quser_interrupt)
515 {
516 rep_throw_value = rep_NULL;
517 rep_handle_error (Qno_catcher, rep_LIST_1 (type));
518 goto again;
519 }
520 }
521 return ret;
522 }
523
524 DEFUN("recursion-depth", Frecursion_depth, Srecursion_depth, (void), rep_Subr0) /*
525 ::doc:rep.system#recursion-depth::
526 recursion-depth
527
528 Returns the number of recursive-edit's deep we are, zero signifies the
529 original level.
530 ::end:: */
531 {
532 return rep_MAKE_INT(rep_recurse_depth);
533 }
534
535 void
rep_deprecated(rep_bool * seen,const char * desc)536 rep_deprecated (rep_bool *seen, const char *desc)
537 {
538 if (!*seen)
539 {
540 fprintf (stderr, "rep: using deprecated feature - %s\n", desc);
541 *seen = rep_TRUE;
542 }
543 }
544
545 static void check_configuration (int *stack_low) __attribute__((noinline));
546 static void
rep_main_init(void)547 rep_main_init(void)
548 {
549 repv tem = rep_push_structure ("rep.system");
550 rep_ADD_SUBR_INT(Srecursive_edit);
551 rep_ADD_SUBR(Srecursion_depth);
552 rep_pop_structure (tem);
553
554 rep_INTERN(quit);
555 rep_INTERN(exit);
556 rep_INTERN(top_level);
557 rep_INTERN_SPECIAL(command_line_args);
558 rep_INTERN_SPECIAL(idle_hook);
559 rep_INTERN_SPECIAL(batch_mode);
560 Fset (Qbatch_mode, Qnil);
561 rep_INTERN_SPECIAL(interpreted_mode);
562 Fset (Qinterpreted_mode, Qnil);
563 rep_INTERN_SPECIAL(program_name);
564 rep_INTERN_SPECIAL(error_mode);
565 Fset (Qerror_mode, Qnil);
566 rep_INTERN_SPECIAL(interrupt_mode);
567 Fset (Qinterrupt_mode, Qnil);
568 rep_INTERN_SPECIAL(before_exit_hook);
569 }
570