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; }