void Check_Input_Port (Object port) {
Check_Type (port, T_Port);
if (!(PORT(port)->flags & P_OPEN))
Primitive_Error ("port has been closed: ~s", port);
if (!IS_INPUT(port))
Primitive_Error ("not an input port: ~s", port);
}
void Reader_Error (Object port, char *msg) {
char buf[100];
if (PORT(port)->flags & P_STRING) {
sprintf (buf, "[string-port]: %u: %s", PORT(port)->lno, msg);
Primitive_Error (buf);
} else {
sprintf (buf, "~s: %u: %s", PORT(port)->lno, msg);
Primitive_Error (buf, PORT(port)->name);
}
}
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
struct exec hdr;
FILE *f;
SYMTAB *tab;
if ((f = fopen (name, "r")) == NULL)
Primitive_Error ("can't open a.out file");
if (fread ((char *)&hdr, sizeof hdr, 1, f) != 1) {
(void)fclose (f);
Primitive_Error ("can't read a.out header");
}
tab = Snarf_Symbols (f, &hdr);
(void)fclose (f);
return tab;
}
SYMTAB *Snarf_Symbols (FILE *f, struct exec *ep) {
SYMTAB *tab;
register SYM *sp, **nextp;
int nsyms, strsiz;
struct nlist nl;
tab = (SYMTAB *)Safe_Malloc (sizeof (SYMTAB));
tab->first = 0;
tab->strings = 0;
nextp = &tab->first;
(void)fseek (f, (long)N_SYMOFF(*ep), 0);
for (nsyms = ep->a_syms / sizeof (nl); nsyms > 0; nsyms--) {
if (fread ((char *)&nl, sizeof (nl), 1, f) != 1) {
Free_Symbols (tab);
(void)fclose (f);
Primitive_Error ("corrupt symbol table in object file");
}
if (nl.n_un.n_strx == 0 || nl.n_type & N_STAB)
continue;
#ifndef ibm023
if ((nl.n_type & N_TYPE) != N_TEXT)
continue;
#endif
sp = (SYM *)Safe_Malloc (sizeof (SYM));
sp->name = (char *)nl.n_un.n_strx;
sp->value = nl.n_value;
*nextp = sp;
nextp = &sp->next;
*nextp = 0;
}
if (fread ((char *)&strsiz, sizeof (strsiz), 1, f) != 1) {
strerr:
Free_Symbols (tab);
(void)fclose (f);
Primitive_Error ("corrupt string table in object file");
}
if (strsiz <= 4)
goto strerr;
tab->strings = Safe_Malloc (strsiz);
strsiz -= 4;
if (fread (tab->strings+4, 1, strsiz, f) != strsiz)
goto strerr;
for (sp = tab->first; sp; sp = sp->next)
sp->name = tab->strings + (long)sp->name;
return tab;
}
Object
elk_csg_attach(Object left_obj, Object right_obj, Object op_obj)
{
Object res_obj;
CSGTreeRoot *root;
CSGOperation op;
CSGNodePtr left_child;
CSGNodePtr right_child;
/* Check that the window exists. */
if ( ! csg_window.shell )
return Void;
Check_Type(left_obj, CSGNODE_TYPE);
Check_Type(right_obj, CSGNODE_TYPE);
Check_Type(op_obj, T_Symbol);
if ( EQ(op_obj, Sym_Union) )
op = csg_union_op;
else if ( EQ(op_obj, Sym_Intersection) )
op = csg_intersection_op;
else if ( EQ(op_obj, Sym_Difference) )
op = csg_difference_op;
else
Primitive_Error("Invalid CSG Operation: ~s", op_obj);
left_child = ELKCSGNODE(left_obj)->csg_node;
right_child = ELKCSGNODE(right_obj)->csg_node;
if ( ! left_child || ! right_child )
return Void;
/* Just check that the left child is a root node. */
root = elk_csg_get_root_node(left_child);
if ( ! root )
return Void;
/* Right is the root we actually want. */
root = elk_csg_get_root_node(right_child);
if ( ! root )
return Void;
Delete_Displayed_Tree(root->tree);
/* Do the attach. */
right_child->csg_parent = NULL;
CSG_Add_Node(right_child, left_child, op, NULL, 0);
XawTreeForceLayout(csg_tree_widget);
changed_scene = TRUE;
res_obj = Alloc_Object(sizeof(Elkcsgnode), CSGNODE_TYPE, 0);
ELKCSGNODE(res_obj)->csg_node = left_child->csg_parent;
return res_obj;
}
void Wrong_Type_Combination (Object x, register char const *name) {
register int t = TYPE(x);
char buf[100];
if (t < 0 || t >= Num_Types)
Panic ("bad type1");
sprintf (buf, "wrong argument type %s (expected %s)",
Types[t].name, name);
Primitive_Error (buf);
}
XtAccelerators Get_Accelerators (Object a) {
register char *s;
XtAccelerators ret;
Alloca_Begin;
Get_Strsym_Stack (a, s);
if ((ret = XtParseAcceleratorTable (s)) == 0)
Primitive_Error ("bad accelerator table: ~s", a);
Alloca_End;
return ret;
}
Object P_Unread_Char (int argc, Object *argv) {
Object port, ch;
register struct S_Port *p;
ch = argv[0];
Check_Type (ch, T_Character);
port = argc == 2 ? argv[1] : Curr_Input_Port;
Check_Input_Port (port);
p = PORT(port);
if (p->flags & P_STRING) {
if (p->flags & P_UNREAD)
Primitive_Error ("cannot push back more than one char");
String_Ungetc (port, CHAR(ch));
} else {
if (ungetc (CHAR(ch), p->file) == EOF)
Primitive_Error ("failed to push back char");
}
if (CHAR(ch) == '\n' && PORT(port)->lno > 1) PORT(port)->lno--;
return ch;
}
static Object P_Wait(int argc, Object *argv) {
int flags = 0;
if (argc == 3)
#ifdef WAIT_OPTIONS
flags = (int)Symbols_To_Bits(argv[2], 1, Wait_Flags);
#else
Primitive_Error("wait options not supported");
#endif
return General_Wait(argv[0], argv[1], 0, 0, flags);
}
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
struct exec hdr;
int fd;
FILE *fp;
SYMTAB *tab;
if ((fd = open (name, O_RDONLY|O_BINARY)) == -1) {
Saved_Errno = errno;
Primitive_Error ("can't open a.out file: ~E");
}
if (read (fd, (char *)&hdr, sizeof hdr) != sizeof hdr) {
close (fd);
Primitive_Error ("can't read a.out header");
}
if ((fp = fdopen (fd, O_BINARY ? "rb" : "r")) == NULL) {
close (fd);
Primitive_Error ("can't fdopen a.out file");
}
tab = Snarf_Symbols (fp, &hdr);
(void)fclose (fp);
return tab;
}
static Object P_Create_Bitmap_From_Data (Object win, Object data, Object pw,
Object ph) {
register unsigned int w, h;
Check_Type (win, T_Window);
Check_Type (data, T_String);
w = Get_Integer (pw);
h = Get_Integer (ph);
if (w * h > 8 * STRING(data)->size)
Primitive_Error ("bitmap too small");
return Make_Pixmap (WINDOW(win)->dpy,
XCreateBitmapFromData (WINDOW(win)->dpy, WINDOW(win)->win,
STRING(data)->data, w, h));
}
char *Safe_Realloc (char *ptr, unsigned int size) {
char *ret;
Disable_Interrupts;
if ((ret = ptr ? realloc (ptr, size) : malloc (size)) == 0) {
if (Interpreter_Initialized)
Primitive_Error ("not enough memory to malloc ~s bytes",
Make_Integer (size));
else
Fatal_Error ("not enough memory to malloc %u bytes", size);
}
Enable_Interrupts;
return ret;
}
static Object P_Create_Window (Object parent, Object x, Object y, Object width,
Object height, Object border_width,
Object attr) {
unsigned long mask;
Window win;
Check_Type (parent, T_Window);
mask = Vector_To_Record (attr, Set_Attr_Size, Sym_Set_Attr, Set_Attr_Rec);
if ((win = XCreateWindow (WINDOW(parent)->dpy, WINDOW(parent)->win,
Get_Integer (x), Get_Integer (y), Get_Integer (width),
Get_Integer (height), Get_Integer (border_width),
CopyFromParent, CopyFromParent, CopyFromParent, mask, &SWA)) == 0)
Primitive_Error ("cannot create window");
return Make_Window (1, WINDOW(parent)->dpy, win);
}
static Object P_Utime(int argc, Object *argv) {
struct utimbuf ut;
if (argc == 2)
Primitive_Error("wrong number of arguments");
if (argc == 3) {
ut.actime = (time_t)Get_Unsigned_Long(argv[1]);
ut.modtime = (time_t)Get_Unsigned_Long(argv[2]);
}
#ifndef WIN32
if (utime(Get_Strsym(argv[0]), argc == 1 ? (struct utimbuf *)0 : &ut)
== -1)
Raise_System_Error1("~s: ~E", argv[0]);
#endif
return Void;
}
static Object P_Write_Bitmap_File (int argc, Object *argv) {
Pixmap pm;
int ret, xhot = -1, yhot = -1;
pm = Get_Pixmap (argv[1]);
if (argc == 5)
Primitive_Error ("both x-hot and y-hot must be specified");
if (argc == 6) {
xhot = Get_Integer (argv[4]);
yhot = Get_Integer (argv[5]);
}
Disable_Interrupts;
ret = XWriteBitmapFile (PIXMAP(argv[1])->dpy, Get_Strsym (argv[0]), pm,
Get_Integer (argv[2]), Get_Integer (argv[3]), xhot, yhot);
Enable_Interrupts;
return Bits_To_Symbols ((unsigned long)ret, 0, Bitmapstatus_Syms);
}
void Define_Primitive (Object (*fun)(), char const *name, int min, int max,
enum discipline disc) {
Object prim, sym, frame;
GC_Node2;
Set_Error_Tag ("define-primitive");
prim = Make_Primitive (fun, name, min, max, disc);
sym = Null;
GC_Link2 (prim, sym);
sym = Intern (name);
if (disc == EVAL && min != max)
Primitive_Error ("~s: number of arguments must be fixed", sym);
frame = Add_Binding (Car (The_Environment), sym, prim);
SYMBOL(sym)->value = prim;
Car (The_Environment) = frame;
GC_Unlink;
}
void Define_Reader (int c, READFUN fun) {
if (Readers[c] && Readers[c] != fun)
Primitive_Error ("reader for `~a' already defined", Make_Char (c));
Readers[c] = fun;
}
/* 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 () {
Primitive_Error ("not yet supported for standalone applications");
}
SYMTAB *Snarf_Symbols (FILE *f, struct exec *ep) {
SYMTAB *tab;
register SYM *sp;
register SYM **nextp;
int strsiz = 0; /* running total length of names read, */
/* each '\0' terminated */
int nread = 0; /* running total of bytes read from symbol table */
int max = 0; /* current maximum size of name table */
char *names = 0; /* the name table */
struct nlist_ nl;
tab = (SYMTAB *)Safe_Malloc (sizeof (SYMTAB));
tab->first = 0;
tab->strings = 0;
nextp = &tab->first;
(void)fseek (f, (long)LESYM_OFFSET(*ep), 0);
while (nread < ep->a_lesyms) {
if (fread ((char *)&nl, sizeof (nl), 1, f) != 1) {
Free_Symbols (tab);
(void)fclose (f);
Primitive_Error ("corrupt symbol table in object file");
}
nread += sizeof (nl);
if (nl.n_length == 0) {
continue;
}
else if (nl.n_length + strsiz + 1 > max) {
max += STRING_BLOCK;
names = Safe_Realloc (names, max);
}
if (fread (names + strsiz, 1, nl.n_length, f) != nl.n_length) {
Free_Symbols (tab);
(void)fclose (f);
Primitive_Error ("corrupt symbol table in object file");
}
else {
nread += nl.n_length;
names[ strsiz + nl.n_length ] = '\0';
}
if ((nl.n_type & N_TYPE) != N_TEXT) {
strsiz += nl.n_length +1;
continue;
}
sp = (SYM *)Safe_Malloc (sizeof (SYM));
sp->name = (char *)strsiz;
strsiz += (nl.n_length + 1);
sp->value = nl.n_value;
*nextp = sp;
nextp = &sp->next;
*nextp = 0;
}
tab->strings = names;
for (sp = tab->first; sp; sp = sp->next)
sp->name += (unsigned int)names;
return tab;
}