* Renamed main.c into libelk.c.
* Added a new main.c that uses libelk. Can be built this way:
gcc main.c -o scheme -L. -lelk
git-svn-id: svn://svn.zoy.org/elk/trunk@18 55e467fa-43c5-0310-a8a2-de718669efc6
This commit is contained in:
sam
parent
f66cc0d573
commit
166aa29795
35
src/build
35
src/build
|
|
@ -61,7 +61,7 @@ C= autoload.c\\
|
|||
io.c\\
|
||||
list.c\\
|
||||
load.c\\
|
||||
main.c\\
|
||||
libelk.c\\
|
||||
malloc.c\\
|
||||
math.c\\
|
||||
onfork.c\\
|
||||
|
|
@ -112,15 +112,18 @@ OCOMMON=\\
|
|||
type.o\\
|
||||
vector.o
|
||||
|
||||
O1= \$(OCOMMON) main.o stab.o
|
||||
O2= \$(OCOMMON) main2.o stab2.o
|
||||
O3= \$(OCOMMON) main3.o stab2.o
|
||||
O1= \$(OCOMMON) libelk.o stab.o
|
||||
O2= \$(OCOMMON) libelk2.o stab2.o
|
||||
O3= \$(OCOMMON) libelk3.o stab2.o
|
||||
|
||||
all: scheme standalone.a module.a
|
||||
all: scheme libelk.so standalone.a module.a
|
||||
|
||||
scheme: \$(O1)
|
||||
\$(CC) -o \$@ \$(CFLAGS) \$(O1) \$(LDFLAGS)
|
||||
|
||||
libelk.so: \$(O3)
|
||||
gcc -shared -o \$@ \$(O3) \$(LDFLAGS)
|
||||
|
||||
standalone.a: \$(O2)
|
||||
ar cru \$@ \$(O2)
|
||||
|
||||
|
|
@ -154,7 +157,7 @@ heap.o: \$(H) heap.c heap-sc.c heap-gen.c
|
|||
io.o: \$(H) io.c
|
||||
list.o: \$(H) list.c
|
||||
load.o: \$(H) load.c $load
|
||||
main.o: \$(H) main.c
|
||||
libelk.o: \$(H) libelk.c
|
||||
malloc.o: \$(H) malloc.c
|
||||
math.o: \$(H) math.c
|
||||
onfork.o: \$(H) onfork.c
|
||||
|
|
@ -172,20 +175,20 @@ terminate.o: \$(H) terminate.c
|
|||
type.o: \$(H) type.c
|
||||
vector.o: \$(H) vector.c
|
||||
|
||||
main2.o: \$(H) main.c
|
||||
rm -f main2.c; ln main.c main2.c
|
||||
\$(CC) -DINIT_OBJECTS \$(CFLAGS) -I\$(INC) -c main2.c
|
||||
rm main2.c
|
||||
libelk2.o: \$(H) libelk.c
|
||||
rm -f libelk2.c; ln libelk.c libelk2.c
|
||||
\$(CC) -DINIT_OBJECTS \$(CFLAGS) -I\$(INC) -c libelk2.c
|
||||
rm libelk2.c
|
||||
|
||||
stab2.o: \$(H) stab.c $stab
|
||||
rm -f stab2.c; ln stab.c stab2.c
|
||||
\$(CC) -DINIT_OBJECTS \$(CFLAGS) -I\$(INC) -c stab2.c
|
||||
rm stab2.c
|
||||
|
||||
main3.o: \$(H) main.c
|
||||
rm -f main3.c; ln main.c main3.c
|
||||
\$(CC) -DINIT_OBJECTS -DNOMAIN \$(CFLAGS) -I\$(INC) -c main3.c
|
||||
rm main3.c
|
||||
libelk3.o: \$(H) libelk.c
|
||||
rm -f libelk3.c; ln libelk.c libelk3.c
|
||||
\$(CC) -DINIT_OBJECTS -DNOMAIN \$(CFLAGS) -I\$(INC) -c libelk3.c
|
||||
rm libelk3.c
|
||||
|
||||
install: scheme standalone.a module.a
|
||||
-@if [ ! -d $install_dir/bin ]; then \\
|
||||
|
|
@ -208,8 +211,8 @@ lint:
|
|||
lint \$(LINTFLAGS) -I\$(INC) \$(C)
|
||||
|
||||
clean:
|
||||
rm -f *.o *.a core main2.c stab2.c main3.c
|
||||
rm -f *.o *.a core libelk2.c stab2.c libelk3.c
|
||||
|
||||
distclean:
|
||||
rm -f *.o *.a core main2.c stab2.c main3.c lint.out scheme Makefile.local
|
||||
rm -f *.o *.a core libelk2.c stab2.c libelk3.c lint.out scheme Makefile.local
|
||||
EOT
|
||||
|
|
|
|||
|
|
@ -0,0 +1,437 @@
|
|||
#include "kernel.h"
|
||||
|
||||
#include <errno.h>
|
||||
#include <limits.h>
|
||||
#include <string.h>
|
||||
#include <stdlib.h>
|
||||
#include <malloc.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
|
||||
#ifndef MAX_STACK_SIZE
|
||||
# include <sys/time.h>
|
||||
# include <sys/resource.h>
|
||||
#endif
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
# ifdef INCLUDE_UNISTD_H
|
||||
# include <unistd.h>
|
||||
# else
|
||||
# include <sys/file.h>
|
||||
# endif
|
||||
#endif
|
||||
|
||||
extern void Call_Initializers (SYMTAB *, char *, int);
|
||||
extern void Load_Source (Object);
|
||||
extern void Call_Finalizers ();
|
||||
extern void Finit_Load ();
|
||||
extern void Generational_GC_Reinitialize ();
|
||||
extern int Check_Stack_Grows_Down ();
|
||||
extern void Make_Heap (int);
|
||||
extern void Free_Heap ();
|
||||
extern void Init_Auto (void);
|
||||
extern void Init_Cstring();
|
||||
extern void Init_Dump ();
|
||||
extern void Init_Env ();
|
||||
extern void Init_Error ();
|
||||
extern void Init_Exception ();
|
||||
extern void Init_Features ();
|
||||
extern void Init_Heap ();
|
||||
extern void Init_Io ();
|
||||
extern void Init_Load ();
|
||||
extern void Init_Loadpath (char *);
|
||||
extern void Init_Math ();
|
||||
extern void Init_Prim ();
|
||||
extern void Init_Print ();
|
||||
extern void Init_Proc ();
|
||||
extern void Init_Read ();
|
||||
extern void Init_Special ();
|
||||
extern void Init_String ();
|
||||
extern void Init_Symbol ();
|
||||
extern void Init_Terminate ();
|
||||
extern void Init_Type();
|
||||
|
||||
extern char *getenv();
|
||||
|
||||
void Get_Stack_Limit ();
|
||||
void Usage ();
|
||||
void Init_Everything ();
|
||||
|
||||
char *stkbase;
|
||||
int Stack_Grows_Down;
|
||||
unsigned int Max_Stack;
|
||||
int Interpreter_Initialized;
|
||||
int GC_Debug = 0;
|
||||
int Case_Insensitive;
|
||||
int Verb_Load = 0, Verb_Init = 0;
|
||||
|
||||
char **Argv;
|
||||
int Argc, First_Arg;
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
char *A_Out_Name;
|
||||
char *Find_Executable();
|
||||
#endif
|
||||
|
||||
#if defined(CAN_LOAD_OBJ) || defined(INIT_OBJECTS)
|
||||
SYMTAB *The_Symbols;
|
||||
#endif
|
||||
|
||||
void Exit_Handler () {
|
||||
#if defined(CAN_LOAD_OBJ) || defined(INIT_OBJECTS)
|
||||
Call_Finalizers ();
|
||||
#endif
|
||||
#ifdef CAN_LOAD_OBJ
|
||||
Finit_Load ();
|
||||
#endif
|
||||
Free_Heap ();
|
||||
}
|
||||
|
||||
#ifndef ATEXIT
|
||||
/* Hack: __GNUC_MINOR__ was introduced together with __attribute__ */
|
||||
#ifdef __GNUC_MINOR__
|
||||
extern void _exit() __attribute__ ((noreturn));
|
||||
#endif
|
||||
#ifndef PROFILING
|
||||
void exit (n) {
|
||||
Exit_Handler ();
|
||||
_cleanup ();
|
||||
_exit (n);
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef CAN_DUMP
|
||||
int Was_Dumped;
|
||||
char *Brk_On_Dump;
|
||||
#endif
|
||||
|
||||
|
||||
/* dump currently does not work for applications using Elk_Init().
|
||||
* The reason is that in this case the INITIAL_STK_OFFSET which
|
||||
* compensates for differences in argv[] in the original/dumped a.out
|
||||
* is not in effect (see comment below).
|
||||
* This cannot be fixed without changing Elk_Init() and its use in
|
||||
* an incompatible way.
|
||||
*/
|
||||
void Check_If_Dump_Works () {
|
||||
#ifdef NOMAIN
|
||||
Primitive_Error ("not yet supported for standalone applications");
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
#ifdef NOMAIN
|
||||
|
||||
void Elk_Init (int ac, char **av, int init_objects, char *toplevel) {
|
||||
|
||||
#else
|
||||
|
||||
int main (int ac, char **av) {
|
||||
|
||||
#endif
|
||||
|
||||
/* To avoid that the stack copying code overwrites argv if a dumped
|
||||
* copy of the interpreter is invoked with more arguments than the
|
||||
* original a.out, move the stack base INITIAL_STK_OFFSET bytes down.
|
||||
* The call to memset() is there to prevent the optimizer from removing
|
||||
* the array.
|
||||
*/
|
||||
#ifdef CAN_DUMP
|
||||
char unused[INITIAL_STK_OFFSET];
|
||||
#endif
|
||||
char *initfile, *loadfile = 0, *loadpath = 0;
|
||||
int debug = 0, heap = HEAP_SIZE;
|
||||
Object file;
|
||||
struct stat st;
|
||||
extern int errno;
|
||||
#ifdef CAN_DUMP
|
||||
#ifdef NOMAIN
|
||||
# define foo (av[0][0])
|
||||
#else
|
||||
char foo;
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef CAN_DUMP
|
||||
memset (unused, 0, 1); /* see comment above */
|
||||
#endif
|
||||
if (ac == 0) {
|
||||
av[0] = "Elk"; ac = 1;
|
||||
}
|
||||
Get_Stack_Limit ();
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
A_Out_Name = Find_Executable (av[0]);
|
||||
#endif
|
||||
|
||||
Argc = ac; Argv = av;
|
||||
First_Arg = 1;
|
||||
#ifdef CAN_DUMP
|
||||
if (Was_Dumped) {
|
||||
/* Check if beginning of stack has moved by a large amount.
|
||||
* This is the case, for instance, on a Sun-4m when the
|
||||
* interpreter was dumped on a Sun-4c and vice versa.
|
||||
*/
|
||||
if (abs (stkbase - &foo) > INITIAL_STK_OFFSET) {
|
||||
fprintf (stderr,
|
||||
"Can't restart dumped interpreter from a different machine architecture\n");
|
||||
fprintf (stderr,
|
||||
" (Stack delta = %lld bytes).\n", (long long int)(ptrdiff_t)(stkbase - &foo));
|
||||
exit (1);
|
||||
}
|
||||
/* Check if program break must be reset.
|
||||
*/
|
||||
if ((ptrdiff_t)Brk_On_Dump && (ptrdiff_t)brk (Brk_On_Dump)
|
||||
== (ptrdiff_t)-1) {
|
||||
perror ("brk"); exit (1);
|
||||
}
|
||||
#if defined(HP9K) && defined(CAN_DUMP) && defined(HPSHLIB)
|
||||
Restore_Shared_Data ();
|
||||
#endif
|
||||
#ifdef GENERATIONAL_GC
|
||||
Generational_GC_Reinitialize ();
|
||||
#endif
|
||||
Loader_Input = 0;
|
||||
Install_Intr_Handler ();
|
||||
(void)Funcall_Control_Point (Dump_Control_Point, Arg_True, 0);
|
||||
/*NOTREACHED*/
|
||||
}
|
||||
#endif
|
||||
|
||||
for ( ; First_Arg < ac; First_Arg++) {
|
||||
if (strcmp (av[First_Arg], "-g") == 0) {
|
||||
debug = 1;
|
||||
} else if (strcmp (av[First_Arg], "-i") == 0) {
|
||||
Case_Insensitive = 1;
|
||||
} else if (strcmp (av[First_Arg], "-v") == 0) {
|
||||
if (++First_Arg == ac)
|
||||
Usage ();
|
||||
if (strcmp (av[First_Arg], "load") == 0)
|
||||
Verb_Load = 1;
|
||||
else if (strcmp (av[First_Arg], "init") == 0)
|
||||
Verb_Init = 1;
|
||||
else Usage ();
|
||||
} else if (strcmp (av[First_Arg], "-h") == 0) {
|
||||
if (++First_Arg == ac)
|
||||
Usage ();
|
||||
if ((heap = atoi (av[First_Arg])) <= 0) {
|
||||
fprintf (stderr, "Heap size must be a positive number.\n");
|
||||
exit (1);
|
||||
}
|
||||
} else if (strcmp (av[First_Arg], "-l") == 0) {
|
||||
if (++First_Arg == ac || loadfile)
|
||||
Usage ();
|
||||
loadfile = av[First_Arg];
|
||||
} else if (strcmp (av[First_Arg], "-p") == 0) {
|
||||
if (++First_Arg == ac || loadpath)
|
||||
Usage ();
|
||||
loadpath = av[First_Arg];
|
||||
} else if (strcmp (av[First_Arg], "--") == 0) {
|
||||
First_Arg++;
|
||||
break;
|
||||
} else if (av[First_Arg][0] == '-') {
|
||||
Usage ();
|
||||
} else {
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
stkbase = &foo;
|
||||
Stack_Grows_Down = Check_Stack_Grows_Down ();
|
||||
ALIGN(stkbase);
|
||||
Make_Heap (heap);
|
||||
Init_Everything ();
|
||||
#ifdef ATEXIT
|
||||
if (atexit (Exit_Handler) != 0)
|
||||
Fatal_Error ("atexit returned non-zero value");
|
||||
#endif
|
||||
#ifdef INIT_OBJECTS
|
||||
#ifdef NOMAIN
|
||||
if (init_objects) {
|
||||
Set_Error_Tag ("init-objects");
|
||||
The_Symbols = Open_File_And_Snarf_Symbols (A_Out_Name);
|
||||
Call_Initializers (The_Symbols, (char *)0, PR_EXTENSION);
|
||||
}
|
||||
#else
|
||||
Set_Error_Tag ("init-objects");
|
||||
The_Symbols = Open_File_And_Snarf_Symbols (A_Out_Name);
|
||||
Call_Initializers (The_Symbols, (char *)0, PR_CONSTRUCTOR);
|
||||
Call_Initializers (The_Symbols, (char *)0, PR_EXTENSION);
|
||||
#endif
|
||||
#endif
|
||||
if (loadpath || (loadpath = getenv (LOADPATH_ENV)))
|
||||
Init_Loadpath (loadpath);
|
||||
|
||||
/* The following code is sort of a hack. initscheme.scm should not
|
||||
* be resolved against load-path. However, the .scm-files may not
|
||||
* have been installed yet (note that the interpreter is already
|
||||
* used in the "make" process).
|
||||
* Solution: if initscheme.scm hasn't been installed yet, do search
|
||||
* the load-path, so that -p can be used.
|
||||
*/
|
||||
Set_Error_Tag ("scheme-init");
|
||||
initfile = Safe_Malloc (strlen (SCM_DIR) + 1 + sizeof (INITFILE) + 1);
|
||||
sprintf (initfile, "%s/%s", SCM_DIR, INITFILE);
|
||||
if (stat (initfile, &st) == -1 && errno == ENOENT)
|
||||
file = Make_String (INITFILE, sizeof(INITFILE)-1);
|
||||
else
|
||||
file = Make_String (initfile, strlen (initfile));
|
||||
free (initfile);
|
||||
(void)General_Load (file, The_Environment);
|
||||
|
||||
Install_Intr_Handler ();
|
||||
|
||||
Set_Error_Tag ("top-level");
|
||||
#ifdef NOMAIN
|
||||
if (toplevel == 0) {
|
||||
Interpreter_Initialized = 1;
|
||||
GC_Debug = debug;
|
||||
return;
|
||||
}
|
||||
/* Special case: if toplevel is "", act as if run from main() */
|
||||
if (loadfile == 0 && toplevel[0] != '\0')
|
||||
loadfile = toplevel;
|
||||
#endif
|
||||
if (loadfile == 0)
|
||||
loadfile = "toplevel.scm";
|
||||
file = Make_String (loadfile, strlen (loadfile));
|
||||
Interpreter_Initialized = 1;
|
||||
GC_Debug = debug;
|
||||
if (loadfile[0] == '-' && loadfile[1] == '\0')
|
||||
Load_Source_Port (Standard_Input_Port);
|
||||
else
|
||||
(void)General_Load (file, The_Environment);
|
||||
#ifndef NOMAIN
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
static char *Usage_Msg[] = {
|
||||
"Options:",
|
||||
" [-l filename] Load file instead of standard toplevel",
|
||||
" [-l -] Load from standard input",
|
||||
" [-h heapsize] Heap size in KBytes",
|
||||
" [-p loadpath] Initialize load-path (colon-list of directories)",
|
||||
" [-g] Enable GC-debugging",
|
||||
" [-i] Case-insensitive symbols",
|
||||
" [-v type] Be verbose. \"type\" controls what to print:",
|
||||
" load linker command when loading object file",
|
||||
" init names of extension [f]init functions when \
|
||||
called",
|
||||
" [--] End options and begin arguments",
|
||||
0 };
|
||||
|
||||
void Usage () {
|
||||
char **p;
|
||||
|
||||
fprintf (stderr, "Usage: %s [options] [arguments]\n", Argv[0]);
|
||||
for (p = Usage_Msg; *p; p++)
|
||||
fprintf (stderr, "%s\n", *p);
|
||||
exit (1);
|
||||
}
|
||||
|
||||
void Init_Everything () {
|
||||
Init_Type ();
|
||||
Init_Cstring ();
|
||||
Init_String ();
|
||||
Init_Symbol ();
|
||||
Init_Env ();
|
||||
Init_Error ();
|
||||
Init_Exception ();
|
||||
Init_Io ();
|
||||
Init_Prim ();
|
||||
Init_Math ();
|
||||
Init_Print ();
|
||||
Init_Auto ();
|
||||
Init_Heap ();
|
||||
Init_Load ();
|
||||
Init_Proc ();
|
||||
Init_Special ();
|
||||
Init_Read ();
|
||||
Init_Features ();
|
||||
Init_Terminate ();
|
||||
#ifdef CAN_DUMP
|
||||
Init_Dump ();
|
||||
#endif
|
||||
}
|
||||
|
||||
void Get_Stack_Limit () {
|
||||
#ifdef MAX_STACK_SIZE
|
||||
Max_Stack = MAX_STACK_SIZE;
|
||||
#else
|
||||
struct rlimit rl;
|
||||
|
||||
if (getrlimit (RLIMIT_STACK, &rl) == -1) {
|
||||
perror ("getrlimit");
|
||||
exit (1);
|
||||
}
|
||||
Max_Stack = rl.rlim_cur;
|
||||
#endif
|
||||
Max_Stack -= STACK_MARGIN;
|
||||
}
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
int Executable (char *fn) {
|
||||
struct stat s;
|
||||
|
||||
return stat (fn, &s) != -1 && (s.st_mode & S_IFMT) == S_IFREG
|
||||
&& access (fn, X_OK) != -1;
|
||||
}
|
||||
|
||||
char *Find_Executable (char *fn) {
|
||||
char *path, *dir, *getenv();
|
||||
static char buf[1025]; /* Can't use Path_Max or Safe_Malloc here */
|
||||
register char *p;
|
||||
|
||||
for (p = fn; *p; p++) {
|
||||
if (*p == '/') {
|
||||
if (Executable (fn))
|
||||
return fn;
|
||||
else
|
||||
Fatal_Error ("%s is not executable", fn);
|
||||
}
|
||||
}
|
||||
if ((path = getenv ("PATH")) == 0)
|
||||
path = ":/usr/ucb:/bin:/usr/bin";
|
||||
dir = path;
|
||||
do {
|
||||
p = buf;
|
||||
while (*dir && *dir != ':')
|
||||
*p++ = *dir++;
|
||||
if (*dir)
|
||||
++dir;
|
||||
if (p > buf)
|
||||
*p++ = '/';
|
||||
strcpy (p, fn);
|
||||
if (Executable (buf))
|
||||
return buf;
|
||||
} while (*dir);
|
||||
if (dir > path && dir[-1] == ':' && Executable (fn))
|
||||
return fn;
|
||||
Fatal_Error ("cannot find pathname of %s", fn);
|
||||
/*NOTREACHED*/
|
||||
}
|
||||
#endif
|
||||
|
||||
Object P_Command_Line_Args () {
|
||||
Object ret, tail;
|
||||
register int i;
|
||||
GC_Node2;
|
||||
|
||||
ret = tail = P_Make_List (Make_Integer (Argc-First_Arg), Null);
|
||||
GC_Link2 (ret, tail);
|
||||
for (i = First_Arg; i < Argc; i++, tail = Cdr (tail)) {
|
||||
Object a;
|
||||
|
||||
a = Make_String (Argv[i], strlen (Argv[i]));
|
||||
Car (tail) = a;
|
||||
}
|
||||
GC_Unlink;
|
||||
return ret;
|
||||
}
|
||||
|
||||
Object P_Exit (int argc, Object *argv) {
|
||||
exit (argc == 0 ? 0 : Get_Unsigned (argv[0]));
|
||||
/*NOTREACHED*/
|
||||
}
|
||||
436
src/main.c
436
src/main.c
|
|
@ -1,437 +1,7 @@
|
|||
#include "kernel.h"
|
||||
#include <elk/scheme.h>
|
||||
|
||||
#include <errno.h>
|
||||
#include <limits.h>
|
||||
#include <string.h>
|
||||
#include <stdlib.h>
|
||||
#include <malloc.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
|
||||
#ifndef MAX_STACK_SIZE
|
||||
# include <sys/time.h>
|
||||
# include <sys/resource.h>
|
||||
#endif
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
# ifdef INCLUDE_UNISTD_H
|
||||
# include <unistd.h>
|
||||
# else
|
||||
# include <sys/file.h>
|
||||
# endif
|
||||
#endif
|
||||
|
||||
extern void Call_Initializers (SYMTAB *, char *, int);
|
||||
extern void Load_Source (Object);
|
||||
extern void Call_Finalizers ();
|
||||
extern void Finit_Load ();
|
||||
extern void Generational_GC_Reinitialize ();
|
||||
extern int Check_Stack_Grows_Down ();
|
||||
extern void Make_Heap (int);
|
||||
extern void Free_Heap ();
|
||||
extern void Init_Auto (void);
|
||||
extern void Init_Cstring();
|
||||
extern void Init_Dump ();
|
||||
extern void Init_Env ();
|
||||
extern void Init_Error ();
|
||||
extern void Init_Exception ();
|
||||
extern void Init_Features ();
|
||||
extern void Init_Heap ();
|
||||
extern void Init_Io ();
|
||||
extern void Init_Load ();
|
||||
extern void Init_Loadpath (char *);
|
||||
extern void Init_Math ();
|
||||
extern void Init_Prim ();
|
||||
extern void Init_Print ();
|
||||
extern void Init_Proc ();
|
||||
extern void Init_Read ();
|
||||
extern void Init_Special ();
|
||||
extern void Init_String ();
|
||||
extern void Init_Symbol ();
|
||||
extern void Init_Terminate ();
|
||||
extern void Init_Type();
|
||||
|
||||
extern char *getenv();
|
||||
|
||||
void Get_Stack_Limit ();
|
||||
void Usage ();
|
||||
void Init_Everything ();
|
||||
|
||||
char *stkbase;
|
||||
int Stack_Grows_Down;
|
||||
unsigned int Max_Stack;
|
||||
int Interpreter_Initialized;
|
||||
int GC_Debug = 0;
|
||||
int Case_Insensitive;
|
||||
int Verb_Load = 0, Verb_Init = 0;
|
||||
|
||||
char **Argv;
|
||||
int Argc, First_Arg;
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
char *A_Out_Name;
|
||||
char *Find_Executable();
|
||||
#endif
|
||||
|
||||
#if defined(CAN_LOAD_OBJ) || defined(INIT_OBJECTS)
|
||||
SYMTAB *The_Symbols;
|
||||
#endif
|
||||
|
||||
void Exit_Handler () {
|
||||
#if defined(CAN_LOAD_OBJ) || defined(INIT_OBJECTS)
|
||||
Call_Finalizers ();
|
||||
#endif
|
||||
#ifdef CAN_LOAD_OBJ
|
||||
Finit_Load ();
|
||||
#endif
|
||||
Free_Heap ();
|
||||
}
|
||||
|
||||
#ifndef ATEXIT
|
||||
/* Hack: __GNUC_MINOR__ was introduced together with __attribute__ */
|
||||
#ifdef __GNUC_MINOR__
|
||||
extern void _exit() __attribute__ ((noreturn));
|
||||
#endif
|
||||
#ifndef PROFILING
|
||||
void exit (n) {
|
||||
Exit_Handler ();
|
||||
_cleanup ();
|
||||
_exit (n);
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef CAN_DUMP
|
||||
int Was_Dumped;
|
||||
char *Brk_On_Dump;
|
||||
#endif
|
||||
|
||||
|
||||
/* dump currently does not work for applications using Elk_Init().
|
||||
* The reason is that in this case the INITIAL_STK_OFFSET which
|
||||
* compensates for differences in argv[] in the original/dumped a.out
|
||||
* is not in effect (see comment below).
|
||||
* This cannot be fixed without changing Elk_Init() and its use in
|
||||
* an incompatible way.
|
||||
*/
|
||||
void Check_If_Dump_Works () {
|
||||
#ifdef NOMAIN
|
||||
Primitive_Error ("not yet supported for standalone applications");
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
#ifdef NOMAIN
|
||||
|
||||
void Elk_Init (int ac, char **av, int init_objects, char *toplevel) {
|
||||
|
||||
#else
|
||||
|
||||
int main (int ac, char **av) {
|
||||
|
||||
#endif
|
||||
|
||||
/* To avoid that the stack copying code overwrites argv if a dumped
|
||||
* copy of the interpreter is invoked with more arguments than the
|
||||
* original a.out, move the stack base INITIAL_STK_OFFSET bytes down.
|
||||
* The call to memset() is there to prevent the optimizer from removing
|
||||
* the array.
|
||||
*/
|
||||
#ifdef CAN_DUMP
|
||||
char unused[INITIAL_STK_OFFSET];
|
||||
#endif
|
||||
char *initfile, *loadfile = 0, *loadpath = 0;
|
||||
int debug = 0, heap = HEAP_SIZE;
|
||||
Object file;
|
||||
struct stat st;
|
||||
extern int errno;
|
||||
#ifdef CAN_DUMP
|
||||
#ifdef NOMAIN
|
||||
# define foo (av[0][0])
|
||||
#else
|
||||
char foo;
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef CAN_DUMP
|
||||
memset (unused, 0, 1); /* see comment above */
|
||||
#endif
|
||||
if (ac == 0) {
|
||||
av[0] = "Elk"; ac = 1;
|
||||
}
|
||||
Get_Stack_Limit ();
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
A_Out_Name = Find_Executable (av[0]);
|
||||
#endif
|
||||
|
||||
Argc = ac; Argv = av;
|
||||
First_Arg = 1;
|
||||
#ifdef CAN_DUMP
|
||||
if (Was_Dumped) {
|
||||
/* Check if beginning of stack has moved by a large amount.
|
||||
* This is the case, for instance, on a Sun-4m when the
|
||||
* interpreter was dumped on a Sun-4c and vice versa.
|
||||
*/
|
||||
if (abs (stkbase - &foo) > INITIAL_STK_OFFSET) {
|
||||
fprintf (stderr,
|
||||
"Can't restart dumped interpreter from a different machine architecture\n");
|
||||
fprintf (stderr,
|
||||
" (Stack delta = %lld bytes).\n", (long long int)(ptrdiff_t)(stkbase - &foo));
|
||||
exit (1);
|
||||
}
|
||||
/* Check if program break must be reset.
|
||||
*/
|
||||
if ((ptrdiff_t)Brk_On_Dump && (ptrdiff_t)brk (Brk_On_Dump)
|
||||
== (ptrdiff_t)-1) {
|
||||
perror ("brk"); exit (1);
|
||||
}
|
||||
#if defined(HP9K) && defined(CAN_DUMP) && defined(HPSHLIB)
|
||||
Restore_Shared_Data ();
|
||||
#endif
|
||||
#ifdef GENERATIONAL_GC
|
||||
Generational_GC_Reinitialize ();
|
||||
#endif
|
||||
Loader_Input = 0;
|
||||
Install_Intr_Handler ();
|
||||
(void)Funcall_Control_Point (Dump_Control_Point, Arg_True, 0);
|
||||
/*NOTREACHED*/
|
||||
}
|
||||
#endif
|
||||
|
||||
for ( ; First_Arg < ac; First_Arg++) {
|
||||
if (strcmp (av[First_Arg], "-g") == 0) {
|
||||
debug = 1;
|
||||
} else if (strcmp (av[First_Arg], "-i") == 0) {
|
||||
Case_Insensitive = 1;
|
||||
} else if (strcmp (av[First_Arg], "-v") == 0) {
|
||||
if (++First_Arg == ac)
|
||||
Usage ();
|
||||
if (strcmp (av[First_Arg], "load") == 0)
|
||||
Verb_Load = 1;
|
||||
else if (strcmp (av[First_Arg], "init") == 0)
|
||||
Verb_Init = 1;
|
||||
else Usage ();
|
||||
} else if (strcmp (av[First_Arg], "-h") == 0) {
|
||||
if (++First_Arg == ac)
|
||||
Usage ();
|
||||
if ((heap = atoi (av[First_Arg])) <= 0) {
|
||||
fprintf (stderr, "Heap size must be a positive number.\n");
|
||||
exit (1);
|
||||
}
|
||||
} else if (strcmp (av[First_Arg], "-l") == 0) {
|
||||
if (++First_Arg == ac || loadfile)
|
||||
Usage ();
|
||||
loadfile = av[First_Arg];
|
||||
} else if (strcmp (av[First_Arg], "-p") == 0) {
|
||||
if (++First_Arg == ac || loadpath)
|
||||
Usage ();
|
||||
loadpath = av[First_Arg];
|
||||
} else if (strcmp (av[First_Arg], "--") == 0) {
|
||||
First_Arg++;
|
||||
break;
|
||||
} else if (av[First_Arg][0] == '-') {
|
||||
Usage ();
|
||||
} else {
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
stkbase = &foo;
|
||||
Stack_Grows_Down = Check_Stack_Grows_Down ();
|
||||
ALIGN(stkbase);
|
||||
Make_Heap (heap);
|
||||
Init_Everything ();
|
||||
#ifdef ATEXIT
|
||||
if (atexit (Exit_Handler) != 0)
|
||||
Fatal_Error ("atexit returned non-zero value");
|
||||
#endif
|
||||
#ifdef INIT_OBJECTS
|
||||
#ifdef NOMAIN
|
||||
if (init_objects) {
|
||||
Set_Error_Tag ("init-objects");
|
||||
The_Symbols = Open_File_And_Snarf_Symbols (A_Out_Name);
|
||||
Call_Initializers (The_Symbols, (char *)0, PR_EXTENSION);
|
||||
}
|
||||
#else
|
||||
Set_Error_Tag ("init-objects");
|
||||
The_Symbols = Open_File_And_Snarf_Symbols (A_Out_Name);
|
||||
Call_Initializers (The_Symbols, (char *)0, PR_CONSTRUCTOR);
|
||||
Call_Initializers (The_Symbols, (char *)0, PR_EXTENSION);
|
||||
#endif
|
||||
#endif
|
||||
if (loadpath || (loadpath = getenv (LOADPATH_ENV)))
|
||||
Init_Loadpath (loadpath);
|
||||
|
||||
/* The following code is sort of a hack. initscheme.scm should not
|
||||
* be resolved against load-path. However, the .scm-files may not
|
||||
* have been installed yet (note that the interpreter is already
|
||||
* used in the "make" process).
|
||||
* Solution: if initscheme.scm hasn't been installed yet, do search
|
||||
* the load-path, so that -p can be used.
|
||||
*/
|
||||
Set_Error_Tag ("scheme-init");
|
||||
initfile = Safe_Malloc (strlen (SCM_DIR) + 1 + sizeof (INITFILE) + 1);
|
||||
sprintf (initfile, "%s/%s", SCM_DIR, INITFILE);
|
||||
if (stat (initfile, &st) == -1 && errno == ENOENT)
|
||||
file = Make_String (INITFILE, sizeof(INITFILE)-1);
|
||||
else
|
||||
file = Make_String (initfile, strlen (initfile));
|
||||
free (initfile);
|
||||
(void)General_Load (file, The_Environment);
|
||||
|
||||
Install_Intr_Handler ();
|
||||
|
||||
Set_Error_Tag ("top-level");
|
||||
#ifdef NOMAIN
|
||||
if (toplevel == 0) {
|
||||
Interpreter_Initialized = 1;
|
||||
GC_Debug = debug;
|
||||
return;
|
||||
}
|
||||
/* Special case: if toplevel is "", act as if run from main() */
|
||||
if (loadfile == 0 && toplevel[0] != '\0')
|
||||
loadfile = toplevel;
|
||||
#endif
|
||||
if (loadfile == 0)
|
||||
loadfile = "toplevel.scm";
|
||||
file = Make_String (loadfile, strlen (loadfile));
|
||||
Interpreter_Initialized = 1;
|
||||
GC_Debug = debug;
|
||||
if (loadfile[0] == '-' && loadfile[1] == '\0')
|
||||
Load_Source_Port (Standard_Input_Port);
|
||||
else
|
||||
(void)General_Load (file, The_Environment);
|
||||
#ifndef NOMAIN
|
||||
int main(int ac, char **av) {
|
||||
Elk_Init(ac, av, 1, "");
|
||||
return 0;
|
||||
#endif
|
||||
}
|
||||
|
||||
static char *Usage_Msg[] = {
|
||||
"Options:",
|
||||
" [-l filename] Load file instead of standard toplevel",
|
||||
" [-l -] Load from standard input",
|
||||
" [-h heapsize] Heap size in KBytes",
|
||||
" [-p loadpath] Initialize load-path (colon-list of directories)",
|
||||
" [-g] Enable GC-debugging",
|
||||
" [-i] Case-insensitive symbols",
|
||||
" [-v type] Be verbose. \"type\" controls what to print:",
|
||||
" load linker command when loading object file",
|
||||
" init names of extension [f]init functions when \
|
||||
called",
|
||||
" [--] End options and begin arguments",
|
||||
0 };
|
||||
|
||||
void Usage () {
|
||||
char **p;
|
||||
|
||||
fprintf (stderr, "Usage: %s [options] [arguments]\n", Argv[0]);
|
||||
for (p = Usage_Msg; *p; p++)
|
||||
fprintf (stderr, "%s\n", *p);
|
||||
exit (1);
|
||||
}
|
||||
|
||||
void Init_Everything () {
|
||||
Init_Type ();
|
||||
Init_Cstring ();
|
||||
Init_String ();
|
||||
Init_Symbol ();
|
||||
Init_Env ();
|
||||
Init_Error ();
|
||||
Init_Exception ();
|
||||
Init_Io ();
|
||||
Init_Prim ();
|
||||
Init_Math ();
|
||||
Init_Print ();
|
||||
Init_Auto ();
|
||||
Init_Heap ();
|
||||
Init_Load ();
|
||||
Init_Proc ();
|
||||
Init_Special ();
|
||||
Init_Read ();
|
||||
Init_Features ();
|
||||
Init_Terminate ();
|
||||
#ifdef CAN_DUMP
|
||||
Init_Dump ();
|
||||
#endif
|
||||
}
|
||||
|
||||
void Get_Stack_Limit () {
|
||||
#ifdef MAX_STACK_SIZE
|
||||
Max_Stack = MAX_STACK_SIZE;
|
||||
#else
|
||||
struct rlimit rl;
|
||||
|
||||
if (getrlimit (RLIMIT_STACK, &rl) == -1) {
|
||||
perror ("getrlimit");
|
||||
exit (1);
|
||||
}
|
||||
Max_Stack = rl.rlim_cur;
|
||||
#endif
|
||||
Max_Stack -= STACK_MARGIN;
|
||||
}
|
||||
|
||||
#ifdef FIND_AOUT
|
||||
int Executable (char *fn) {
|
||||
struct stat s;
|
||||
|
||||
return stat (fn, &s) != -1 && (s.st_mode & S_IFMT) == S_IFREG
|
||||
&& access (fn, X_OK) != -1;
|
||||
}
|
||||
|
||||
char *Find_Executable (char *fn) {
|
||||
char *path, *dir, *getenv();
|
||||
static char buf[1025]; /* Can't use Path_Max or Safe_Malloc here */
|
||||
register char *p;
|
||||
|
||||
for (p = fn; *p; p++) {
|
||||
if (*p == '/') {
|
||||
if (Executable (fn))
|
||||
return fn;
|
||||
else
|
||||
Fatal_Error ("%s is not executable", fn);
|
||||
}
|
||||
}
|
||||
if ((path = getenv ("PATH")) == 0)
|
||||
path = ":/usr/ucb:/bin:/usr/bin";
|
||||
dir = path;
|
||||
do {
|
||||
p = buf;
|
||||
while (*dir && *dir != ':')
|
||||
*p++ = *dir++;
|
||||
if (*dir)
|
||||
++dir;
|
||||
if (p > buf)
|
||||
*p++ = '/';
|
||||
strcpy (p, fn);
|
||||
if (Executable (buf))
|
||||
return buf;
|
||||
} while (*dir);
|
||||
if (dir > path && dir[-1] == ':' && Executable (fn))
|
||||
return fn;
|
||||
Fatal_Error ("cannot find pathname of %s", fn);
|
||||
/*NOTREACHED*/
|
||||
}
|
||||
#endif
|
||||
|
||||
Object P_Command_Line_Args () {
|
||||
Object ret, tail;
|
||||
register int i;
|
||||
GC_Node2;
|
||||
|
||||
ret = tail = P_Make_List (Make_Integer (Argc-First_Arg), Null);
|
||||
GC_Link2 (ret, tail);
|
||||
for (i = First_Arg; i < Argc; i++, tail = Cdr (tail)) {
|
||||
Object a;
|
||||
|
||||
a = Make_String (Argv[i], strlen (Argv[i]));
|
||||
Car (tail) = a;
|
||||
}
|
||||
GC_Unlink;
|
||||
return ret;
|
||||
}
|
||||
|
||||
Object P_Exit (int argc, Object *argv) {
|
||||
exit (argc == 0 ? 0 : Get_Unsigned (argv[0]));
|
||||
/*NOTREACHED*/
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue