This is main.c in view mode; [Download] [Up]
/*
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
This file is part of GNU Common Lisp, herein referred to as GCL
GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GCL is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
License for more details.
You should have received a copy of the GNU Library General Public License
along with GCL; see the file COPYING. If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/*
main.c
IMPLEMENTATION-DEPENDENT
*/
#define IN_MAIN
#ifdef KCLOVM
#include <ovm/ovm.h>
void change_contexts();
int ovm_process_created;
void initialize_process();
#endif
#include "include.h"
#ifdef UNIX
#include <signal.h>
#endif
#include "page.h"
bool saving_system ;
#ifdef BSD
#include <sys/time.h>
#ifndef SGI
#include <sys/resource.h>
#endif
#endif
#ifdef AOSVS
#endif
#define LISP_IMPLEMENTATION_VERSION "April 1994"
char *system_directory;
char system_directory_buf[MAXPATHLEN];
int page_multiple=1;
#define EXTRA_BUFSIZE 8
char stdin_buf[BUFSIZ + EXTRA_BUFSIZE];
char stdout_buf[BUFSIZ + EXTRA_BUFSIZE];
int debug; /* debug switch */
int initflag = FALSE; /* initialized flag */
int real_maxpage;
object sSAlisp_maxpagesA;
object siClisp_pagesize;
object sStop_level;
object sSAmultiply_stacksA;
int stack_multiple=1;
static object stack_space;
char *merge_system_directory();
int cssize;
int sgc_enabled;
void install_segmentation_catcher();
#ifndef SIG_STACK_SIZE
#define SIG_STACK_SIZE 1000
#endif
#ifndef SETUP_SIG_STACK
#if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
struct sigstack estack;
#endif
#endif
main(argc, argv, envp)
int argc;
char **argv, **envp;
{
FILE *i;
#ifdef BSD
#ifndef SGI
struct rlimit rl;
#endif
#endif
#if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
#ifdef SETJMP_ONE_DIRECTION
static
#endif
/* make sure the stack is 8 byte aligned */
double estack_buf[SIG_STACK_SIZE];
#endif
setbuf(stdin, stdin_buf);
setbuf(stdout, stdout_buf);
ARGC = argc;
ARGV = argv;
#ifdef UNIX
ENVP = envp;
#endif
#ifdef UNIX
/*
if (argv[0][0] != '/')
error("can't get the program name");
*/
kcl_self = argv[0];
system_directory = system_directory_buf;
if (!initflag) {
strcpy(system_directory, argv[0]);
if (system_directory[0] != '/')
strcpy(system_directory, "./");
else {
int j;
for (j = strlen(system_directory);
system_directory[j-1] != '/'; --j)
;
system_directory[j] = '\0';
}
}
#endif
#ifdef AOSVS
#endif
if (!initflag && argc > 1) {
#ifdef UNIX
if (argv[1][strlen(argv[1])-1] != '/')
#endif
#ifdef AOSVS
#endif
error("can't get the system directory");
strcpy(system_directory, argv[1]);
}
GBC_enable = FALSE;
/* if stack_space not zero we have grown the stack space */
if (stack_space == 0)
{
vs_org = value_stack;
vs_limit = &vs_org[VSSIZE];
frs_org = frame_stack;
frs_limit = &frs_org[FRSSIZE];
bds_org = bind_stack;
bds_limit = &bds_org[BDSSIZE];
#ifdef KCLOVM
bds_save_org = save_bind_stack;
bds_save_top = bds_save_org - 1;
bds_save_limit = &bds_save_org[BDSSIZE];
#endif
ihs_org = ihs_stack;
ihs_limit = &ihs_org[IHSSIZE];}
vs_top = vs_base = vs_org;
clear_stack(vs_top,vs_top+200);
ihs_top = ihs_org-1;
bds_top = bds_org-1;
frs_top = frs_org-1;
cs_org = &argc;
cssize = CSSIZE;
install_segmentation_catcher();
#ifdef BSD
#ifdef RLIMIT_STACK
getrlimit(RLIMIT_STACK, &rl);
cssize = rl.rlim_cur/4 - 4*CSGETA;
#endif
#endif
#ifdef AV
cs_limit = cs_org - cssize;
#endif
#ifdef MV
#endif
set_maxpage();
#ifdef SETUP_SIG_STACK
SETUP_SIG_STACK
#else
#if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
bzero(estack_buf,sizeof(estack_buf));
estack.ss_sp = (char *) &estack_buf[SIG_STACK_SIZE-1];
estack.ss_onstack=0;
sigstack(&estack,0);
#endif
#endif
if (initflag) {
if (saving_system) {
saving_system = FALSE;
#ifdef INIT_CORE_END
INIT_CORE_END
#endif
alloc_page(-(holepage + nrbpage));
}
initflag = FALSE;
GBC_enable = TRUE;
vs_base = vs_top;
ihs_push(Cnil);
lex_new();
vs_base = vs_top;
interrupt_enable = TRUE;
install_default_signals();
sSAlisp_maxpagesA->s.s_dbind = make_fixnum(real_maxpage);
initflag = TRUE;
#ifdef KCLOVM
ovm_user_context_change = change_contexts;
ovm_user_context_initialize = initialize_process;
v_init_processes();
ovm_process_created = 1;
#endif
again:
super_funcall(sStop_level);
if (type_of(sSAmultiply_stacksA->s.s_dbind)==t_fixnum)
{multiply_stacks(fix(sSAmultiply_stacksA->s.s_dbind));
goto again;}
#ifdef USE_DLOPEN
unlink_loaded_files();
#endif
exit(0);
}
printf("GCL (GNU Common Lisp) %s %d pages\n",
LISP_IMPLEMENTATION_VERSION,
MAXPAGE);
fflush(stdout);
initlisp();
vs_base = vs_top;
ihs_push(Cnil);
lex_new();
GBC_enable = TRUE;
CMPtemp = CMPtemp1 = CMPtemp2 = CMPtemp3 = OBJNULL;
init_init();
sLApackageA->s.s_dbind = user_package;
lex_new();
vs_base = vs_top;
initflag = TRUE;
interrupt_enable = TRUE;
super_funcall(sStop_level);
}
/* catch certain signals */
void install_segmentation_catcher()
{
#ifdef INSTALL_SEGMENTATION_CATCHER
INSTALL_SEGMENTATION_CATCHER;
#else
#ifdef SIGSEGV
(void) gcl_signal(SIGSEGV,segmentation_catcher);
#endif
#endif
}
int catch_fatal=1;
void
error(s)
char *s;
{
if (catch_fatal>0 && interrupt_enable )
{catch_fatal = -1;
if (sgc_enabled)
{ sgc_quit();}
if (sgc_enabled==0)
{ install_segmentation_catcher() ;}
FEerror("Caught fatal error [memory may be damaged]",0); }
printf("\nUnrecoverable error: %s.\n", s);
fflush(stdout);
#ifdef UNIX
abort();
#endif
}
initlisp()
{
int j;
if (NULL_OR_ON_C_STACK(&j) == 0
|| NULL_OR_ON_C_STACK(Cnil) != 0
|| (((unsigned long )core_end) !=0
&& NULL_OR_ON_C_STACK(core_end) != 0))
{ /* check person has correct definition of above */
error("NULL_OR_ON_C_STACK macro invalid");
}
init_alloc();
Cnil_body.t = (short)t_symbol;
Cnil_body.s_dbind = Cnil;
Cnil_body.s_sfdef = NOT_SPECIAL;
Cnil_body.s_fillp = 3;
Cnil_body.s_self = "NIL";
Cnil_body.s_gfdef = OBJNULL;
Cnil_body.s_plist = Cnil;
Cnil_body.s_hpack = Cnil;
Cnil_body.s_stype = (short)stp_constant;
Cnil_body.s_mflag = FALSE;
Ct_body.t = (short)t_symbol;
Ct_body.s_dbind = Ct;
Ct_body.s_sfdef = NOT_SPECIAL;
Ct_body.s_fillp = 1;
Ct_body.s_self = "T";
Ct_body.s_gfdef = OBJNULL;
Ct_body.s_plist = Cnil;
Ct_body.s_hpack = Cnil;
Ct_body.s_stype = (short)stp_constant;
Ct_body.s_mflag = FALSE;
init_symbol();
init_package();
Cnil->s.s_hpack = lisp_package;
import(Cnil, lisp_package);
export(Cnil, lisp_package);
Ct->s.s_hpack = lisp_package;
import(Ct, lisp_package);
export(Ct, lisp_package);
sLquote = make_ordinary("QUOTE");
sLfunction = make_ordinary("FUNCTION");
sLlambda = make_ordinary("LAMBDA");
sLlambda_block = make_ordinary("LAMBDA-BLOCK");
sLlambda_closure = make_ordinary("LAMBDA-CLOSURE");
sLlambda_block_closure = make_ordinary("LAMBDA-BLOCK-CLOSURE");
sLspecial = make_ordinary("SPECIAL");
NewInit();
init_typespec();
init_pari();
init_number();
init_character();
init_read();
init_bind();
init_pathname();
init_print();
init_GBC();
#ifdef UNIX
#ifndef DGUX
init_unixfasl();
init_unixsys();
init_unixsave();
#else
#endif
#endif
init_alloc_function();
init_array_function();
init_character_function();
init_file_function();
init_list_function();
init_package_function();
init_pathname_function();
init_predicate_function();
init_print_function();
init_read_function();
init_sequence_function();
#if defined(KCLOVM) || defined(RUN_PROCESS)
init_socket_function();
#endif
init_structure_function();
init_string_function();
init_symbol_function();
init_typespec_function();
init_hash();
init_cfun();
#ifdef UNIX
init_unixfsys();
init_unixtime();
#endif
init_eval();
init_lex();
init_prog();
init_catch();
init_block();
init_macros();
init_conditional();
init_reference();
init_assignment();
init_multival();
init_error();
init_let();
init_mapfun();
init_iteration();
init_toplevel();
init_cmpaux();
init_main();
init_format();
init_links();
init_fat_string();
#ifdef CMAC
init_cmac();
#endif
}
char *
merge_system_directory(s)
{
static char buff[MAXPATHLEN];
extern char *strcat();
strcpy(buff, system_directory);
return(strcat(buff, s));
}
vs_overflow()
{
if (vs_limit > vs_org + stack_multiple * VSSIZE)
error("value stack overflow");
vs_limit += STACK_OVER*VSGETA;
FEerror("Value stack overflow.", 0);
}
bds_overflow()
{
--bds_top;
if (bds_limit > bds_org + stack_multiple * BDSSIZE)
error("bind stack overflow");
bds_limit += STACK_OVER *BDSGETA;
FEerror("Bind stack overflow.", 0);
}
frs_overflow()
{
--frs_top;
if (frs_limit > frs_org + stack_multiple * FRSSIZE)
error("frame stack overflow");
frs_limit += STACK_OVER* FRSGETA;
FEerror("Frame stack overflow.", 0);
}
ihs_overflow()
{
--ihs_top;
if (ihs_limit > ihs_org + stack_multiple * IHSSIZE)
error("invocation history stack overflow");
ihs_limit += STACK_OVER*IHSGETA;
FEerror("Invocation history stack overflow.", 0);
}
void
segmentation_catcher()
{int x;
#ifndef SIG_STACK_SIZE
if (&x < cs_limit)
cs_overflow();
else
{printf("Segmentation violation: c stack ok:signalling error");
}
#endif
error("Segmentation violation.");
}
cs_overflow()
{
#ifdef AV
if (cs_limit < cs_org - cssize)
error("control stack overflow");
cs_limit -= CSGETA;
#endif
#ifdef MV
#endif
FEerror("Control stack overflow.", 0);
}
end_of_file()
{
error("end of file");
}
DEFUNO("BYE",int,fLbye,LISP
,0,1,NONE,II,OO,OO,OO,Lby,"")(va_alist)
va_dcl
{ int n=VFUN_NARGS;
int exit_code;
va_list ap;
{ va_start(ap);
if (n>=1) exit_code=va_arg(ap,int);else goto LDEFAULT1;
goto LEND_VARARG;
LDEFAULT1: exit_code = 0;
LEND_VARARG: va_end(ap);}
#ifdef UNIX
/* printf("Bye.\n"); */
exit(exit_code);
#endif
RETURN(1,int,exit_code, 0);
}
c_trace()
{
#ifdef AOSVS
#endif
}
siLargc()
{
check_arg(0);
vs_push(make_fixnum(ARGC));
}
siLargv()
{
int i;
check_arg(1);
if (type_of(vs_base[0]) != t_fixnum ||
(i = fix(vs_base[0])) < 0 ||
i >= ARGC)
FEerror("Illegal argument index: ~S.", 1, vs_base[0]);
vs_base[0] = make_simple_string(ARGV[i]);
}
#ifdef UNIX
siLgetenv()
{
char name[256];
int i;
char *value;
extern char *getenv();
check_arg(1);
check_type_string(&vs_base[0]);
if (vs_base[0]->st.st_fillp >= 256)
FEerror("Too long name: ~S.", 1, vs_base[0]);
for (i = 0; i < vs_base[0]->st.st_fillp; i++)
name[i] = vs_base[0]->st.st_self[i];
name[i] = '\0';
if ((value = getenv(name)) != NULL)
vs_base[0] = make_simple_string(value);
else
vs_base[0] = Cnil;
}
#endif
object *vs_marker;
siLmark_vs()
{
check_arg(0);
vs_marker = vs_base;
vs_base[0] = Cnil;
}
siLcheck_vs()
{
check_arg(0);
if (vs_base != vs_marker)
FEerror("Value stack is flawed.", 0);
vs_base[0] = Cnil;
}
object
siLcatch_fatal(i)
{catch_fatal=i;
return Cnil;}
void
siLreset_stack_limits(arg)
int arg;
{
check_arg(0);
if(catch_fatal <0) catch_fatal=1;
#ifdef SGC
{extern int fault_count ; fault_count = 0;}
#endif
if (vs_top < vs_org + stack_multiple * VSSIZE)
vs_limit = vs_org + stack_multiple * VSSIZE;
else
error("can't reset vs_limit");
if (bds_top < bds_org + stack_multiple * BDSSIZE)
bds_limit = bds_org + stack_multiple * BDSSIZE;
else
error("can't reset bds_limit");
if (frs_top < frs_org + stack_multiple * FRSSIZE)
frs_limit = frs_org + stack_multiple * FRSSIZE;
else
error("can't reset frs_limit");
if (ihs_top < ihs_org + stack_multiple * IHSSIZE)
ihs_limit = ihs_org + stack_multiple * IHSSIZE;
else
error("can't reset ihs_limit");
#ifdef AV
if (&arg > cs_org - cssize + 16)
cs_limit = cs_org - cssize;
#endif
else
error("can't reset cs_limit");
vs_base[0] = Cnil;
}
#define COPYSTACK(org,p,typ,lim,top,geta,size) \
do{int leng,topl; \
bcopy(org,p,leng=(stack_multiple*size*sizeof(typ))); \
topl= top - org; \
org=(typ *)p; top = org +topl;\
p=p+leng+(STACK_OVER+1)*geta*sizeof(typ); \
lim = ((typ *)p) - (STACK_OVER+1)*geta; \
}while (0)
multiply_stacks(m)
int m;
{ int n;
object x;
object gc_pro=stack_space;
char *p;
int vs,bd,frs,ihs;
stack_multiple=stack_multiple*m;
#define ELTSIZE(x) (((char *)((x)+1)) - ((char *) x))
vs = (stack_multiple*VSSIZE + (STACK_OVER+1)*VSGETA)* ELTSIZE(vs_org);
bd = (stack_multiple*BDSSIZE + (STACK_OVER+1)*BDSGETA)*ELTSIZE(bds_org);
frs = (stack_multiple*FRSSIZE + (STACK_OVER+1)*FRSGETA)*ELTSIZE(frs_org);
ihs = (stack_multiple*IHSSIZE + (STACK_OVER+1)*IHSGETA)*ELTSIZE(ihs_org);
if (stack_space==0) {enter_mark_origin(&stack_space);}
stack_space = alloc_simple_string(vs+bd+frs+ihs);
array_allocself(stack_space,1,code_char(0));
p=stack_space->st.st_self;
COPYSTACK(vs_org,p,object,vs_limit,vs_top,VSGETA,VSSIZE);
COPYSTACK(bds_org,p,struct bds_bd,bds_limit,bds_top,BDSGETA,BDSSIZE);
COPYSTACK(frs_org,p,struct frame,frs_limit,frs_top,FRSGETA,FRSSIZE);
COPYSTACK(ihs_org,p,struct invocation_history,ihs_limit,ihs_top,
IHSGETA,IHSSIZE);
vs_base=vs_top;
return stack_multiple;
}
siLinit_system()
{
check_arg(0);
init_system();
vs_base[0] = Cnil;
}
siLaddress()
{
check_arg(1);
vs_base[0] = make_fixnum((int)vs_base[0]);
}
siLnani()
{
check_arg(1);
vs_base[0] = (object)fixint(vs_base[0]);
}
siLinitialization_failure()
{
check_arg(0);
printf("lisp initialization failed\n");
exit(0);
}
DEFUNO("IDENTITY",object,fLidentity,LISP
,1,1,NONE,OO,OO,OO,OO,Lidentity,"")(x0)
object x0;
{
/* 1 args */
RETURN1 (x0);
}
DEFUNO("LISP-IMPLEMENTATION-VERSION",object,fLlisp_implementation_version,LISP
,0,0,NONE,OO,OO,OO,OO,Llisp_implementation_version,"")()
{
/* 0 args */
RETURN1((make_simple_string(LISP_IMPLEMENTATION_VERSION)));
}
siLsave_system()
{
int i;
#ifdef HAVE_YP_UNBIND
extern object truename(),namestring();
check_arg(1);
/* prevent subsequent consultation of yp by getting
truename now*/
vs_base[0]=namestring(truename(vs_base[0]));
{char name[200];
char *dom = name;
if (0== getdomainname(dom,sizeof(name)))
yp_unbind(dom);}
#endif
#ifdef DO_BEFORE_SAVE
DO_BEFORE_SAVE
#endif
saving_system = TRUE;
GBC(t_contiguous);
#if defined(BSD) || defined(ATT)
brk(core_end);
/* printf( "(breaking at core_end = %x in main ,)",core_end); */
#endif
#ifdef DGUX
#endif
#ifdef AOSVS
#endif
cbgbccount = 0;
rbgbccount = 0;
for (i = 0; i < (int)t_end; i++)
tm_table[i].tm_gbccount = 0;
Lsave();
saving_system = FALSE;
alloc_page(-(holepage+nrbpage));
}
DEFVAR("*LISP-MAXPAGES*",sSAlisp_maxpagesA,SI,make_fixnum(real_maxpage),"");
DEFVAR("*SYSTEM-DIRECTORY*",sSAsystem_directoryA,SI,make_simple_string(system_directory),"");
DEFVAR("*MULTIPLY-STACKS*",sSAmultiply_stacksA,SI,Cnil,"");
DEF_ORDINARY("TOP-LEVEL",sStop_level,SI,"");
DEFVAR("*COMMAND-ARGS*",sSAcommand_argsA,SI,sLnil,"");
init_main()
{
make_function("BY", Lby);
make_si_function("ARGC", siLargc);
make_si_function("ARGV", siLargv);
#ifdef UNIX
make_si_function("GETENV", siLgetenv);
#endif
make_si_function("MARK-VS", siLmark_vs);
make_si_function("CHECK-VS", siLcheck_vs);
make_si_function("RESET-STACK-LIMITS", siLreset_stack_limits);
make_si_function("INIT-SYSTEM", siLinit_system);
make_si_function("ADDRESS", siLaddress);
make_si_function("NANI", siLnani);
make_si_function("INITIALIZATION-FAILURE",
siLinitialization_failure);
siClisp_pagesize =
make_si_constant("LISP-PAGESIZE", make_fixnum(PAGESIZE));
{object features;
#define ADD_FEATURE(name) \
features= make_cons(make_ordinary(name),features)
features= make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil));
ADD_FEATURE("AKCL");
ADD_FEATURE("GCL");
#ifdef UNIX
ADD_FEATURE("UNIX");
#endif
#ifdef IEEEFLOAT
ADD_FEATURE("IEEE-FLOATING-POINT");
#endif
#ifdef SGC
ADD_FEATURE("SGC");
#endif
#ifdef ADDITIONAL_FEATURES
ADDITIONAL_FEATURES;
#endif
#ifdef BSD
ADD_FEATURE("BSD");
#endif
#ifndef PECULIAR_MACHINE
#define BIGM (int)((((unsigned int)(-1))/2))
{
int ONEM = -1;
int Bigm = BIGM;
int Smallm = -BIGM-1;
int Seven = 7;
int Three = 3;
if ( (Smallm / Seven) < 0
&& (Smallm / (-Seven)) > 0
&& (Bigm / (-Seven)) < 0
&& ((-Seven) / Three) == -2
&& (Seven / (-Three)) == -2
&& ((-Seven)/ (-Three)) == 2)
{ ADD_FEATURE("TRUNCATE_USE_C");
} }
#endif
make_special("*FEATURES*",features);}
make_si_function("SAVE-SYSTEM", siLsave_system);
make_si_sfun("CATCH-FATAL",siLcatch_fatal,ARGTYPE1(f_fixnum));
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.