static Object P_Read_Directory(Object fn) {
DIR *d;
#ifdef HAVE_DIRENT_H
struct dirent *dp;
#else
struct direct *dp;
#endif
Object ret;
GC_Node;
ret = Null;
GC_Link(ret);
Disable_Interrupts;
if ((d = opendir(Get_Strsym(fn))) == NULL) {
Saved_Errno = errno;
Enable_Interrupts;
Raise_System_Error1("~s: cannot open", fn);
}
while ((dp = readdir(d)) != NULL) {
Object x;
x = Make_String(dp->d_name, strlen(dp->d_name));
ret = Cons(x, ret);
}
/* closedir() is void under 4.3BSD, should check result elsewhere.
*/
(void)closedir(d);
Enable_Interrupts;
GC_Unlink;
return ret;
}
Object
elk_csg_complete(Object csgobj, Object labelobj)
{
CSGNodePtr tree;
char *label;
BaseObjectPtr new_base;
Check_Type(csgobj, CSGNODE_TYPE);
Check_Type(labelobj, T_String);
tree = ELKCSGNODE(csgobj)->csg_node;
label = STRING(labelobj)->data;
if ( ! ( elk_csg_get_root_node ) )
return Void;
Delete_Displayed_Tree(tree);
CSG_Free_Widgets(tree);
CSG_Update_Reference_Constraints(tree, tree);
new_base = Add_CSG_Base_Object(tree, label, NULL, NULL);
object_count[csg_obj]++;
new_base->b_ref_num = 0;
CSG_Add_Select_Option(new_base);
return Make_String(new_base->b_label, strlen(new_base->b_label) + 1);
}
void Action_Hook (Widget w, XtPointer client_data, char *name, XEvent *ep,
char **argv, int *argc) {
ACTION *ap;
Object args, params, tail;
register int i;
GC_Node3;
for (ap = actions; ap; ap = ap->next) {
if (strcmp (ap->name, name))
continue;
args = params = tail = Null;
GC_Link3 (args, params, tail);
params = P_Make_List (Make_Integer (*argc), Null);
for (i = 0, tail = params; i < *argc; tail = Cdr (tail), i++) {
Object tmp;
tmp = Make_String (argv[i], strlen (argv[i]));
Car (tail) = tmp;
}
args = Cons (params, Null);
params = Get_Event_Args (ep);
args = Cons (Copy_List (params), args);
Destroy_Event_Args (params);
args = Cons (Make_Widget_Foreign (w), args);
(void)Funcall (Get_Function (ap->num), args, 0);
GC_Unlink;
}
}
static int
p_errno_id1(value sval, type stag)
{
pword pw;
char buf[1024];
Check_Output_String(stag);
Make_String(&pw, ec_os_err_string(ec_os_errno_, ec_os_errgrp_, buf, 1024));
Return_Unify_Pw(sval, stag, pw.val, pw.tag);
}
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;
}
static Object P_Readlink(Object fn) {
char *buf;
int len;
Object ret;
Alloca_Begin;
len = Path_Max();
Alloca(buf, char*, len);
if ((len = readlink(Get_Strsym(fn), buf, len)) == -1) {
Alloca_End;
Raise_System_Error1("~s: ~E", fn);
}
ret = Make_String(buf, len);
Alloca_End;
return ret;
}
Object P_Read_String (int argc, Object *argv) {
Object port;
register FILE *f;
register int c, str;
port = argc == 1 ? argv[0] : Curr_Input_Port;
Check_Input_Port (port);
f = PORT(port)->file;
str = PORT(port)->flags & P_STRING;
Read_Reset ();
while (1) {
Reader_Getc;
if (c == '\n' || c == EOF)
break;
Read_Store (c);
}
Reader_Tweak_Stream;
return c == EOF ? Eof : Make_String (Read_Buf, Read_Size);
}
static Object P_List_Extensions (Object d) {
Object ret;
int n;
register int i;
register char **p;
GC_Node;
Check_Type (d, T_Display);
Disable_Interrupts;
p = XListExtensions (DISPLAY(d)->dpy, &n);
Enable_Interrupts;
ret = Make_Vector (n, Null);
GC_Link (ret);
for (i = 0; i < n; i++) {
Object e;
e = Make_String (p[i], strlen (p[i]));
VECTOR(ret)->data[i] = e;
}
GC_Unlink;
XFreeExtensionList (p);
return ret;
}
int
p_session_error_value(
/* + */ value v_session, type t_session,
/* + */ value v_code, type t_code,
/* + */ value v_message, type t_message
)
{
int code;
char * message;
pword p;
session_t * session;
Prepare_Requests;
Check_Output_Integer(t_code);
Check_Output_String(t_message);
Get_Typed_Object(v_session,t_session,&session_handle_tid,session);
session_error_value(session, &code, &message);
Make_String(&p,message);
Request_Unify_Integer(v_code, t_code, code);
Request_Unify_Pw(v_message, t_message, p.val, p.tag);
Succeed;
}
int Parse_Ctlfile(char *ctlname)
{
FILE *ctlfile;
char p[MAX_LINE]; /* First word on line */
char temp[MAX_LINE];
char *bufr;
int x;
linenum=1;
strcpy(ctl_name, fancy_fn(ctlname));
fixPathMove(ctl_name);
printf("\nParsing `%s':",ctl_name);
if ((ctlfile=fopen(ctlname,"r"))==NULL)
{
printf(" \aFatal error opening `%s' for read!\n",ctlname);
exit(1);
}
if ((bufr=malloc(MAX_BUFR)) != NULL)
setvbuf(ctlfile, bufr, _IOFBF, MAX_BUFR);
while (fgets(line, MAX_LINE, ctlfile))
{
Strip_Comment(line);
if (*line)
{
getword(line, p, ctl_delim, 1);
if (! *p)
linenum++;
else if (eqstri(p,"system"))
{
Compiling(LAST_SECTION,cc_section,"System");
Parse_System(ctlfile);
done_sys=TRUE;
}
else if (eqstri(p,"access"))
{
strcpy(p,fchar(line,ctl_delim,2));
Compiling(LAST_ACCESS,cc_accs,p);
ParseAccess(ctlfile,p);
done_access=TRUE;
}
else if (eqstri(p,"equipment"))
{
Compiling(LAST_SECTION,cc_section,"Equipment");
Parse_Equipment(ctlfile);
done_equip=TRUE;
}
else if (eqstri(p,"matrix"))
{
Compiling(LAST_SECTION,cc_section,"Matrix");
Parse_Matrix(ctlfile);
done_matrix=TRUE;
}
else if (eqstri(p,"colour") || eqstri(p,"color") ||
eqstri(p,"colours") || eqstri(p,"colors"))
{
Compiling(LAST_SECTION,cc_section,"Colors");
Parse_Colours(ctlfile);
done_colours=TRUE;
}
else if (eqstri(p,"session"))
{
Compiling(LAST_SECTION,cc_section,"Session");
Parse_Session(ctlfile);
done_session=TRUE;
}
else if (eqstri(p,"language"))
{
Compiling(LAST_SECTION,cc_section,"Language");
Parse_Language(ctlfile);
done_language=TRUE;
}
else if (eqstri(p,"reader"))
{
Compiling(LAST_SECTION,cc_section,"Reader");
Parse_Reader(ctlfile);
}
else if (eqstri(p, "msgdivisionbegin"))
{
char acs[PATHLEN];
char displayfile[PATHLEN];
linenum++;
/* MsgDivisionBegin comp sysop/1234 misc\msgname The InterNet comp.* hierarchy */
getword(line, p, ctl_delim, 2);
getword(line, acs, ctl_delim, 3);
getword(line, displayfile, ctl_delim, 4);
ParseMsgDivisionBegin(p, acs, displayfile, fchar(line, ctl_delim, 5));
}
else if (eqstri(p, "filedivisionbegin"))
{
char acs[PATHLEN];
char displayfile[PATHLEN];
linenum++;
/* FileDivisionBegin comp sysop/1234 misc\filename The InterNet comp.* hierarchy */
getword(line, p, ctl_delim, 2);
getword(line, acs, ctl_delim, 3);
getword(line, displayfile, ctl_delim, 4);
ParseFileDivisionBegin(p, acs, displayfile, fchar(line, ctl_delim, 5));
}
else if (eqstri(p, "msgdivisionend"))
{
linenum++;
ParseMsgDivisionEnd();
}
else if (eqstri(p, "filedivisionend"))
{
linenum++;
ParseFileDivisionEnd();
}
else if (eqstri(p,"msgarea"))
{
linenum++;
getword(line,p,ctl_delim,2);
Compiling(LAST_AREA,cc_area,p);
ParseMsgArea(ctlfile, p);
}
else if (eqstri(p,"filearea"))
{
linenum++;
getword(line,p,ctl_delim,2);
Compiling(LAST_AREA,cc_area,p);
ParseFileArea(ctlfile, p);
}
else if (eqstri(p,"protocol"))
{
strcpy(p, fchar(line, ctl_delim, 2));
Compiling(LAST_SECTION, cc_section, p);
Parse_Protocol(ctlfile, p);
}
else if (eqstri(p,"menu"))
{
strcpy(p,fchar(line,ctl_delim,2));
Compiling(LAST_MENU,cc_menu,p);
Parse_Menu(ctlfile,p);
}
else if (eqstri(p,"section"))
{
linenum++;
while (fgets(line,MAX_LINE,ctlfile) != NULL)
{
linenum++;
getword(line,p," \t\n",1);
if (eqstri(p,"end"))
break;
}
}
else if (eqstri(p,"include"))
{
getword(line,p,ctl_delim,2);
linenum++;
x=linenum;
last=LAST_NONE;
Parse_Ctlfile(p);
strcpy(ctl_name,ctlname);
linenum=x;
}
else if (eqstri(p, "max20area"))
{
getword(line, p, ctl_delim, 2);
if (p[1] != ':' && p[0] != '\\' && p[0] != '/')
{
strcpy(temp, strings + prm.sys_path);
strcat(temp, p);
strcpy(p, temp);
}
strcpy(max20area, p);
strcpy(temp, p);
strcat(temp, ".dat");
Make_String(prm.adat_name, temp);
strcpy(temp, p);
strcat(temp, ".idx");
Make_String(prm.aidx_name, temp);
}
else if (eqstri(p,"version14"))
;
else if (eqstri(p,"version17"))
;
else if (eqstri(p, "app") || eqstri(p, "application"))
;
else Unknown_Ctl(linenum++,p);
}
else linenum++;
}
fclose(ctlfile);
if (bufr)
free(bufr);
return 0;
}
void Elk_Init (int ac, char **av, int init_objects, char *toplevel) {
/* 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;
#if defined(CAN_DUMP)
# define foo (av[0][0])
#else
volatile char foo;
#endif
#ifdef CAN_DUMP
memset (unused, 0, 1); /* see comment above */
#endif
if (ac == 0) {
av[0] = "Elk"; ac = 1;
}
Get_Stack_Limit ();
Lib_Dir = NULL;
Scm_Dir = NULL;
#ifdef WIN32
if (av[0]) {
char path[MAX_PATH], *exe;
GetFullPathName (av[0], MAX_PATH, path, &exe);
if (exe > path && exe[-1] == '\\') {
char newpath[MAX_PATH+5];
exe[-1] = '\0';
sprintf (newpath, "%s\\lib", path);
Lib_Dir = strdup (newpath);
sprintf (newpath, "%s\\scm", path);
Scm_Dir = strdup (newpath);
}
}
#elif defined(FIND_AOUT)
A_Out_Name = Find_Executable (av[0]);
#endif
if (Scm_Dir == NULL)
Scm_Dir = strdup (SCM_DIR);
if (Lib_Dir == NULL)
Lib_Dir = strdup (LIB_DIR);
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)(intptr_t)(stkbase - &foo));
exit (1);
}
/* Check if program break must be reset.
*/
if ((intptr_t)Brk_On_Dump && (intptr_t)brk (Brk_On_Dump)
== (intptr_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], "-debug") == 0) {
debug = 1;
} else if (strcmp (av[First_Arg], "-g") == 0) {
Case_Insensitive = 0;
} 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 ();
ELK_ALIGN(stkbase);
Make_Heap (heap);
Init_Everything ();
#ifdef HAVE_ATEXIT
if (atexit (Exit_Handler) != 0)
Fatal_Error ("atexit returned non-zero value");
#endif
#ifdef INIT_OBJECTS
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);
}
#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" SEPARATOR_STRING "%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");
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;
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);
}
int Parse_Reader(FILE *ctlfile)
{
char temp[MAX_LINE], /* Contains entire line */
p[MAX_LINE]; /* First word on line */
linenum++;
while (fgets(line,MAX_LINE,ctlfile))
{
Strip_Comment(line);
if (*line)
{
strcpy(temp,line);
getword(line,p,ctl_delim,1);
if (! *p)
;
else if (eqstri(p,"end"))
break;
else if (eqstri(p,"archivers"))
{
getword(line,p,ctl_delim,2);
Make_Filename(prm.arc_ctl,p);
}
else if (eqstri(p,"packet"))
{
getword(line,p,ctl_delim,3);
p[8]='\0';
Make_String(prm.olr_name,p);
}
else if (eqstri(p,"work"))
{
getword(line,p,ctl_delim,3);
Make_Path(prm.olr_dir,p);
if (! direxist(p))
makedir(p);
}
else if (eqstri(p,"phone"))
{
Make_String(prm.phone_num, fchar(line, ctl_delim, 3));
}
else if (eqstri(p, "max"))
{
getword(line, p, ctl_delim, 3);
prm.max_pack=(word)atoi(p);
}
else if (eqstri(p,"app") || eqstri(p,"application"))
;
else Unknown_Ctl(linenum,p);
}
linenum++;
}
linenum++;
return 0;
}
