1 /* libelk.c
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include <errno.h>
34 #include <limits.h>
35 #include <string.h>
36 #include <stdlib.h>
37 #include <stdlib.h>
38 #include <sys/types.h>
39 #include <sys/stat.h>
40
41 #ifdef HAVE_STRUCT_RLIMIT
42 # ifdef HAVE_SYS_TIME_H
43 # include <sys/time.h>
44 # endif
45 # ifdef HAVE_SYS_RESOURCE_H
46 # include <sys/resource.h>
47 # endif
48 #endif
49
50 #ifdef WIN32
51 # include <windows.h>
52 #endif
53
54 #ifdef HAVE_UNISTD_H
55 # include <unistd.h>
56 #endif
57
58 #ifdef HAVE_SYS_FILE_H
59 # include <sys/file.h>
60 #endif
61
62 #include "kernel.h"
63
64 extern void Call_Initializers (SYMTAB *, char *, int);
65 extern void Load_Source (Object);
66 extern void Call_Finalizers ();
67 extern void Generational_GC_Reinitialize ();
68 extern int Check_Stack_Grows_Down ();
69 extern void Make_Heap (int);
70 extern void Free_Heap ();
71 extern void Init_Auto (void);
72 extern void Init_Cstring();
73 extern void Init_Dump ();
74 extern void Init_Env ();
75 extern void Init_Error ();
76 extern void Init_Exception ();
77 extern void Init_Features ();
78 extern void Init_Heap ();
79 extern void Init_Io ();
80 extern void Init_Load ();
81 extern void Init_Loadpath (char *);
82 extern void Init_Math ();
83 extern void Init_Prim ();
84 extern void Init_Print ();
85 extern void Init_Proc ();
86 extern void Init_Read ();
87 extern void Init_Special ();
88 extern void Init_String ();
89 extern void Init_Symbol ();
90 extern void Init_Terminate ();
91 extern void Init_Type();
92
93 extern char *getenv();
94
95 void Get_Stack_Limit ();
96 void Usage ();
97 void Init_Everything ();
98
99 char *stkbase;
100 int Stack_Grows_Down;
101 unsigned int Max_Stack;
102 int Interpreter_Initialized;
103 int GC_Debug = 0;
104 int Case_Insensitive = 1;
105 int Verb_Load = 0, Verb_Init = 0;
106
107 char **Argv;
108 int Argc, First_Arg;
109
110 char *Scm_Dir;
111 char *Lib_Dir;
112 #ifdef FIND_AOUT
113 char *A_Out_Name;
114 char *Find_Executable();
115 #endif
116
117 #if defined(CAN_LOAD_LIB) || defined(INIT_OBJECTS)
118 SYMTAB *The_Symbols;
119 #endif
120
Exit_Handler()121 void Exit_Handler () {
122 #if defined(CAN_LOAD_LIB) || defined(INIT_OBJECTS)
123 Call_Finalizers ();
124 #endif
125 Free_Heap ();
126 }
127
128 #ifndef HAVE_ATEXIT
129 /* Hack: __GNUC_MINOR__ was introduced together with __attribute__ */
130 #ifdef __GNUC_MINOR__
131 extern void _exit() elk_attribute(__noreturn__);
132 #endif
133 #ifndef PROFILING
exit(n)134 void exit (n) {
135 Exit_Handler ();
136 _cleanup ();
137 _exit (n);
138 }
139 #endif
140 #endif
141
142 #ifdef CAN_DUMP
143 int Was_Dumped;
144 char *Brk_On_Dump;
145 #endif
146
147
148 /* dump currently does not work for applications using Elk_Init().
149 * The reason is that in this case the INITIAL_STK_OFFSET which
150 * compensates for differences in argv[] in the original/dumped a.out
151 * is not in effect (see comment below).
152 * This cannot be fixed without changing Elk_Init() and its use in
153 * an incompatible way.
154 */
Check_If_Dump_Works()155 void Check_If_Dump_Works () {
156 Primitive_Error ("not yet supported for standalone applications");
157 }
158
159
Elk_Init(int ac,char ** av,int init_objects,char * toplevel)160 void Elk_Init (int ac, char **av, int init_objects, char *toplevel) {
161
162 /* To avoid that the stack copying code overwrites argv if a dumped
163 * copy of the interpreter is invoked with more arguments than the
164 * original a.out, move the stack base INITIAL_STK_OFFSET bytes down.
165 * The call to memset() is there to prevent the optimizer from removing
166 * the array.
167 */
168 #ifdef CAN_DUMP
169 char unused[INITIAL_STK_OFFSET];
170 #endif
171 char *initfile, *loadfile = 0, *loadpath = 0;
172 int debug = 0, heap = HEAP_SIZE;
173 Object file;
174 struct stat st;
175 extern int errno;
176 #if defined(CAN_DUMP)
177 # define foo (av[0][0])
178 #else
179 volatile char foo;
180 #endif
181
182 #ifdef CAN_DUMP
183 memset (unused, 0, 1); /* see comment above */
184 #endif
185 if (ac == 0) {
186 av[0] = "Elk"; ac = 1;
187 }
188 Get_Stack_Limit ();
189
190 Lib_Dir = NULL;
191 Scm_Dir = NULL;
192
193 #ifdef WIN32
194 if (av[0]) {
195 char path[MAX_PATH], *exe;
196 GetFullPathName (av[0], MAX_PATH, path, &exe);
197 if (exe > path && exe[-1] == '\\') {
198 char newpath[MAX_PATH+5];
199 exe[-1] = '\0';
200 sprintf (newpath, "%s\\lib", path);
201 Lib_Dir = strdup (newpath);
202 sprintf (newpath, "%s\\scm", path);
203 Scm_Dir = strdup (newpath);
204 }
205 }
206 #elif defined(FIND_AOUT)
207 A_Out_Name = Find_Executable (av[0]);
208 #endif
209 if (Scm_Dir == NULL)
210 Scm_Dir = strdup (SCM_DIR);
211 if (Lib_Dir == NULL)
212 Lib_Dir = strdup (LIB_DIR);
213
214 Argc = ac; Argv = av;
215 First_Arg = 1;
216 #ifdef CAN_DUMP
217 if (Was_Dumped) {
218 /* Check if beginning of stack has moved by a large amount.
219 * This is the case, for instance, on a Sun-4m when the
220 * interpreter was dumped on a Sun-4c and vice versa.
221 */
222 if (abs (stkbase - &foo) > INITIAL_STK_OFFSET) {
223 fprintf (stderr,
224 "Can't restart dumped interpreter from a different machine architecture\n");
225 fprintf (stderr,
226 " (Stack delta = %lld bytes).\n", (long long int)(intptr_t)(stkbase - &foo));
227 exit (1);
228 }
229 /* Check if program break must be reset.
230 */
231 if ((intptr_t)Brk_On_Dump && (intptr_t)brk (Brk_On_Dump)
232 == (intptr_t)-1) {
233 perror ("brk"); exit (1);
234 }
235 #if defined(HP9K) && defined(CAN_DUMP) && defined(HPSHLIB)
236 Restore_Shared_Data ();
237 #endif
238 #ifdef GENERATIONAL_GC
239 Generational_GC_Reinitialize ();
240 #endif
241 Loader_Input = 0;
242 Install_Intr_Handler ();
243 (void)Funcall_Control_Point (Dump_Control_Point, Arg_True, 0);
244 /*NOTREACHED*/
245 }
246 #endif
247
248 for ( ; First_Arg < ac; First_Arg++) {
249 if (strcmp (av[First_Arg], "-debug") == 0) {
250 debug = 1;
251 } else if (strcmp (av[First_Arg], "-g") == 0) {
252 Case_Insensitive = 0;
253 } else if (strcmp (av[First_Arg], "-i") == 0) {
254 Case_Insensitive = 1;
255 } else if (strcmp (av[First_Arg], "-v") == 0) {
256 if (++First_Arg == ac)
257 Usage ();
258 if (strcmp (av[First_Arg], "load") == 0)
259 Verb_Load = 1;
260 else if (strcmp (av[First_Arg], "init") == 0)
261 Verb_Init = 1;
262 else Usage ();
263 } else if (strcmp (av[First_Arg], "-h") == 0) {
264 if (++First_Arg == ac)
265 Usage ();
266 if ((heap = atoi (av[First_Arg])) <= 0) {
267 fprintf (stderr, "Heap size must be a positive number.\n");
268 exit (1);
269 }
270 } else if (strcmp (av[First_Arg], "-l") == 0) {
271 if (++First_Arg == ac || loadfile)
272 Usage ();
273 loadfile = av[First_Arg];
274 } else if (strcmp (av[First_Arg], "-p") == 0) {
275 if (++First_Arg == ac || loadpath)
276 Usage ();
277 loadpath = av[First_Arg];
278 } else if (strcmp (av[First_Arg], "--") == 0) {
279 First_Arg++;
280 break;
281 } else if (av[First_Arg][0] == '-') {
282 Usage ();
283 } else {
284 break;
285 }
286 }
287
288 stkbase = &foo;
289 Stack_Grows_Down = Check_Stack_Grows_Down ();
290 ELK_ALIGN(stkbase);
291 Make_Heap (heap);
292 Init_Everything ();
293 #ifdef HAVE_ATEXIT
294 if (atexit (Exit_Handler) != 0)
295 Fatal_Error ("atexit returned non-zero value");
296 #endif
297 #ifdef INIT_OBJECTS
298 if (init_objects) {
299 Set_Error_Tag ("init-objects");
300 The_Symbols = Open_File_And_Snarf_Symbols (A_Out_Name);
301 Call_Initializers (The_Symbols, (char *)0, PR_EXTENSION);
302 }
303 #endif
304 if (loadpath || (loadpath = getenv (LOADPATH_ENV)))
305 Init_Loadpath (loadpath);
306
307 /* The following code is sort of a hack. initscheme.scm should not
308 * be resolved against load-path. However, the .scm-files may not
309 * have been installed yet (note that the interpreter is already
310 * used in the "make" process).
311 * Solution: if initscheme.scm hasn't been installed yet, do search
312 * the load-path, so that -p can be used.
313 */
314 Set_Error_Tag ("scheme-init");
315 initfile = Safe_Malloc (strlen (Scm_Dir) + 1 + sizeof (INITFILE) + 1);
316 sprintf (initfile, "%s" SEPARATOR_STRING "%s", Scm_Dir, INITFILE);
317 if (stat (initfile, &st) == -1 && errno == ENOENT)
318 file = Make_String (INITFILE, sizeof(INITFILE)-1);
319 else
320 file = Make_String (initfile, strlen (initfile));
321 free (initfile);
322 (void)General_Load (file, The_Environment);
323
324 Install_Intr_Handler ();
325
326 Set_Error_Tag ("top-level");
327 if (toplevel == 0) {
328 Interpreter_Initialized = 1;
329 GC_Debug = debug;
330 return;
331 }
332 /* Special case: if toplevel is "", act as if run from main() */
333 if (loadfile == 0 && toplevel[0] != '\0')
334 loadfile = toplevel;
335 if (loadfile == 0)
336 loadfile = "toplevel.scm";
337 file = Make_String (loadfile, strlen (loadfile));
338 Interpreter_Initialized = 1;
339 GC_Debug = debug;
340 if (loadfile[0] == '-' && loadfile[1] == '\0')
341 Load_Source_Port (Standard_Input_Port);
342 else
343 (void)General_Load (file, The_Environment);
344 }
345
346 static char *Usage_Msg[] = {
347 "Options:",
348 " [-l filename] Load file instead of standard toplevel",
349 " [-l -] Load from standard input",
350 " [-h heapsize] Heap size in KBytes",
351 " [-p loadpath] Initialize load-path (colon-list of directories)",
352 " [-debug] Enable GC-debugging",
353 " [-g] Case-sensitive symbols",
354 " [-i] Case-insensitive symbols",
355 " [-v type] Be verbose. \"type\" controls what to print:",
356 " load linker command when loading object file",
357 " init names of extension [f]init functions when \
358 called",
359 " [--] End options and begin arguments",
360 0 };
361
Usage()362 void Usage () {
363 char **p;
364
365 fprintf (stderr, "Usage: %s [options] [arguments]\n", Argv[0]);
366 for (p = Usage_Msg; *p; p++)
367 fprintf (stderr, "%s\n", *p);
368 exit (1);
369 }
370
Init_Everything()371 void Init_Everything () {
372 Init_Type ();
373 Init_Cstring ();
374 Init_String ();
375 Init_Symbol ();
376 Init_Env ();
377 Init_Error ();
378 Init_Exception ();
379 Init_Io ();
380 Init_Prim ();
381 Init_Math ();
382 Init_Print ();
383 Init_Auto ();
384 Init_Heap ();
385 Init_Load ();
386 Init_Proc ();
387 Init_Special ();
388 Init_Read ();
389 Init_Features ();
390 Init_Terminate ();
391 #ifdef CAN_DUMP
392 Init_Dump ();
393 #endif
394 }
395
Get_Stack_Limit()396 void Get_Stack_Limit () {
397 #ifdef HAVE_STRUCT_RLIMIT
398 struct rlimit rl;
399
400 if (getrlimit (RLIMIT_STACK, &rl) == -1) {
401 perror ("getrlimit");
402 exit (1);
403 }
404 Max_Stack = rl.rlim_cur;
405 #else
406 Max_Stack = DEFAULT_MAX_STACK_SIZE;
407 #endif
408 Max_Stack -= STACK_MARGIN;
409 }
410
411 #ifdef FIND_AOUT
Executable(char * fn)412 int Executable (char *fn) {
413 struct stat s;
414
415 return stat (fn, &s) != -1 && (s.st_mode & S_IFMT) == S_IFREG
416 && access (fn, X_OK) != -1;
417 }
418
Find_Executable(char * fn)419 char *Find_Executable (char *fn) {
420 char *path, *dir, *getenv();
421 static char buf[1025]; /* Can't use Path_Max or Safe_Malloc here */
422 register char *p;
423
424 for (p = fn; *p; p++) {
425 if (*p == '/') {
426 if (Executable (fn))
427 return fn;
428 else
429 Fatal_Error ("%s is not executable", fn);
430 }
431 }
432 if ((path = getenv ("PATH")) == 0)
433 path = ":/usr/ucb:/bin:/usr/bin";
434 dir = path;
435 do {
436 p = buf;
437 while (*dir && *dir != ':')
438 *p++ = *dir++;
439 if (*dir)
440 ++dir;
441 if (p > buf)
442 *p++ = '/';
443 strcpy (p, fn);
444 if (Executable (buf))
445 return buf;
446 } while (*dir);
447 if (dir > path && dir[-1] == ':' && Executable (fn))
448 return fn;
449 Fatal_Error ("cannot find pathname of %s", fn);
450 /*NOTREACHED*/
451 }
452 #endif
453
P_Command_Line_Args()454 Object P_Command_Line_Args () {
455 Object ret, tail;
456 register int i;
457 GC_Node2;
458
459 ret = tail = P_Make_List (Make_Integer (Argc-First_Arg), Null);
460 GC_Link2 (ret, tail);
461 for (i = First_Arg; i < Argc; i++, tail = Cdr (tail)) {
462 Object a;
463
464 a = Make_String (Argv[i], strlen (Argv[i]));
465 Car (tail) = a;
466 }
467 GC_Unlink;
468 return ret;
469 }
470
P_Exit(int argc,Object * argv)471 Object P_Exit (int argc, Object *argv) {
472 exit (argc == 0 ? 0 : Get_Unsigned (argv[0]));
473 /*NOTREACHED*/
474 }
475