* 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\\
|
io.c\\
|
||||||
list.c\\
|
list.c\\
|
||||||
load.c\\
|
load.c\\
|
||||||
main.c\\
|
libelk.c\\
|
||||||
malloc.c\\
|
malloc.c\\
|
||||||
math.c\\
|
math.c\\
|
||||||
onfork.c\\
|
onfork.c\\
|
||||||
|
|
@ -112,15 +112,18 @@ OCOMMON=\\
|
||||||
type.o\\
|
type.o\\
|
||||||
vector.o
|
vector.o
|
||||||
|
|
||||||
O1= \$(OCOMMON) main.o stab.o
|
O1= \$(OCOMMON) libelk.o stab.o
|
||||||
O2= \$(OCOMMON) main2.o stab2.o
|
O2= \$(OCOMMON) libelk2.o stab2.o
|
||||||
O3= \$(OCOMMON) main3.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)
|
scheme: \$(O1)
|
||||||
\$(CC) -o \$@ \$(CFLAGS) \$(O1) \$(LDFLAGS)
|
\$(CC) -o \$@ \$(CFLAGS) \$(O1) \$(LDFLAGS)
|
||||||
|
|
||||||
|
libelk.so: \$(O3)
|
||||||
|
gcc -shared -o \$@ \$(O3) \$(LDFLAGS)
|
||||||
|
|
||||||
standalone.a: \$(O2)
|
standalone.a: \$(O2)
|
||||||
ar cru \$@ \$(O2)
|
ar cru \$@ \$(O2)
|
||||||
|
|
||||||
|
|
@ -154,7 +157,7 @@ heap.o: \$(H) heap.c heap-sc.c heap-gen.c
|
||||||
io.o: \$(H) io.c
|
io.o: \$(H) io.c
|
||||||
list.o: \$(H) list.c
|
list.o: \$(H) list.c
|
||||||
load.o: \$(H) load.c $load
|
load.o: \$(H) load.c $load
|
||||||
main.o: \$(H) main.c
|
libelk.o: \$(H) libelk.c
|
||||||
malloc.o: \$(H) malloc.c
|
malloc.o: \$(H) malloc.c
|
||||||
math.o: \$(H) math.c
|
math.o: \$(H) math.c
|
||||||
onfork.o: \$(H) onfork.c
|
onfork.o: \$(H) onfork.c
|
||||||
|
|
@ -172,20 +175,20 @@ terminate.o: \$(H) terminate.c
|
||||||
type.o: \$(H) type.c
|
type.o: \$(H) type.c
|
||||||
vector.o: \$(H) vector.c
|
vector.o: \$(H) vector.c
|
||||||
|
|
||||||
main2.o: \$(H) main.c
|
libelk2.o: \$(H) libelk.c
|
||||||
rm -f main2.c; ln main.c main2.c
|
rm -f libelk2.c; ln libelk.c libelk2.c
|
||||||
\$(CC) -DINIT_OBJECTS \$(CFLAGS) -I\$(INC) -c main2.c
|
\$(CC) -DINIT_OBJECTS \$(CFLAGS) -I\$(INC) -c libelk2.c
|
||||||
rm main2.c
|
rm libelk2.c
|
||||||
|
|
||||||
stab2.o: \$(H) stab.c $stab
|
stab2.o: \$(H) stab.c $stab
|
||||||
rm -f stab2.c; ln stab.c stab2.c
|
rm -f stab2.c; ln stab.c stab2.c
|
||||||
\$(CC) -DINIT_OBJECTS \$(CFLAGS) -I\$(INC) -c stab2.c
|
\$(CC) -DINIT_OBJECTS \$(CFLAGS) -I\$(INC) -c stab2.c
|
||||||
rm stab2.c
|
rm stab2.c
|
||||||
|
|
||||||
main3.o: \$(H) main.c
|
libelk3.o: \$(H) libelk.c
|
||||||
rm -f main3.c; ln main.c main3.c
|
rm -f libelk3.c; ln libelk.c libelk3.c
|
||||||
\$(CC) -DINIT_OBJECTS -DNOMAIN \$(CFLAGS) -I\$(INC) -c main3.c
|
\$(CC) -DINIT_OBJECTS -DNOMAIN \$(CFLAGS) -I\$(INC) -c libelk3.c
|
||||||
rm main3.c
|
rm libelk3.c
|
||||||
|
|
||||||
install: scheme standalone.a module.a
|
install: scheme standalone.a module.a
|
||||||
-@if [ ! -d $install_dir/bin ]; then \\
|
-@if [ ! -d $install_dir/bin ]; then \\
|
||||||
|
|
@ -208,8 +211,8 @@ lint:
|
||||||
lint \$(LINTFLAGS) -I\$(INC) \$(C)
|
lint \$(LINTFLAGS) -I\$(INC) \$(C)
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f *.o *.a core main2.c stab2.c main3.c
|
rm -f *.o *.a core libelk2.c stab2.c libelk3.c
|
||||||
|
|
||||||
distclean:
|
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
|
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*/
|
||||||
|
}
|
||||||
434
src/main.c
434
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) {
|
int main(int ac, char **av) {
|
||||||
|
Elk_Init(ac, av, 1, "");
|
||||||
#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;
|
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