[foo-cvs] foo/elkfoo/src pointer.m,1.3,1.4 tell.m,1.6,1.7

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20777

Modified Files:
	pointer.m tell.m 
Log Message:
K&R->ANSI (partially)

Index: pointer.m
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/src/pointer.m,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** pointer.m	5 Aug 2004 23:13:56 -0000	1.3
--- pointer.m	6 Aug 2004 00:22:11 -0000	1.4
***************
*** 93,348 ****
  };
  
! static SchemeObject P_Pointerp(x)
! SchemeObject x;
  {
!     return TYPE(x) == T_Pointer ? True : False;
  }
  
! static SchemeObject P_Null_Pointerp(x)
! SchemeObject x;
  {
!     Check_Type(x, T_Pointer);
!     return POINTER_T(x)->pointer == (void *)0 ? True : False;
  }
  
! static SchemeObject P_Pointer_Type(ptr)
! SchemeObject ptr;
  {
!     Check_Type(ptr, T_Pointer);
!     return Make_String(type_names[POINTER_T(ptr)->type.data],
! 		       strlen(type_names[POINTER_T(ptr)->type.data]));
  }
  
! static SchemeObject P_Pointer_Addr(ptr)
! SchemeObject ptr;
  {
!     Check_Type(ptr, T_Pointer);
!     return Make_Integer((int)(POINTER_T(ptr)->pointer));
  }
  
! SchemeObject A_Make_Pointer(address, type)
! int address, type;
  {
!     SchemeObject pointer;
  
!     pointer = Alloc_Object(sizeof(struct S_Pointer), T_Pointer, 0);
!     POINTER_T(pointer)->type.data = type;
!     POINTER_T(pointer)->pointer = (void *)address;
!     return pointer;
  }
  
! static SchemeObject P_Make_Pointer(addr, type)
! SchemeObject addr, type;
  {
    //    SchemeObject pointer;
!     int i;
  
!     if (TYPE(type) != T_String && TYPE(type) != T_Symbol)
! 	Wrong_Type_Combination(type, "string or symbol");
!     if (TYPE(type) == T_Symbol)
! 	type = SYMBOL(type)->name;
!     for (i = C_pointers; i < C_last; i++) {
! 	if (strlen(type_names[i]) != STRING(type)->size)
! 	    continue;
! 	if (strcmp(STRING(type)->data, type_names[i]) == 0)
! 	    break;
      }
!     if (i == C_last)
! 	Primitive_Error("unknown pointer type: ~s", type);
!     return A_Make_Pointer(Get_Integer(addr), i);
  }
  
! static SchemeObject Reference_Address(p, t, b)
! int p, t;
! SchemeObject b;
  {
!     switch (t) {
!       case C_CHAR:
!       case C_UNSIGNED_CHAR:
! 	return Make_String((char *)p, strlen((char *)p));
!       case C_SHORT:
! 	return Make_Integer(*((short *)p));
!       case C_INT:
! 	return Make_Integer(*((int *)p));
!       case C_LONG:
! 	return Make_Integer(*((long *)p));
!       case C_UNSIGNED_SHORT:
! 	return Make_Unsigned(*((unsigned short *)p));
!       case C_UNSIGNED_INT:
! 	return Make_Unsigned(*((unsigned int *)p));
!       case C_UNSIGNED_LONG:
! 	return Make_Unsigned(*((unsigned long *)p));
!       case C_FLOAT:
! 	return Make_Reduced_Flonum(*((float *)p));
!       case C_DOUBLE:
! 	return Make_Reduced_Flonum(*((double *)p));
!       case C_CHARPTR:
! 	return Make_String(*((char **)p), strlen((*(char **)p)));
!       default:
! 	return Null;
      }
  }
  
! static int Get_String_List_Items(p, n)
! char **p;
! int n;
  {
!     int m = 0;
!     int l = 10000;
  
!     if (n == 0)
! 	while (*p++ != (char *)0 && --l)
! 	    m++;
!     else
! 	while (n-- > 0)
! 	    if (*p++ == (char *)0 && --l)
! 		break;
! 	    else
! 		m++;
!     if (l)
! 	return m;
!     else
! 	Primitive_Error("expected string vector too long");
!     /*NOTREACHED*/
!     return 0; /* avoid warnings */
  }
  
! static SchemeObject P_Pointer_Ref(argc, argv)
! int argc;
! SchemeObject *argv;
  {
!     SchemeObject result, pointer;
!     int offset = 0, items = 1, type, addr, i;
  
!     GC_Node;
  
!     pointer = argv[0];
!     Check_Type(pointer, T_Pointer);
!     GC_Link(pointer);
!     type = POINTER_T(pointer)->type.data;
!     addr = (int)POINTER_T(pointer)->pointer;
!     if (argc > 1)
! 	offset = Get_Integer(argv[1]);
!     if (argc > 2)
! 	items = Get_Integer(argv[2]);
!     if (items == 1)
! 	result = Reference_Address(addr, type, pointer);
!     else {
! 	if (type == C_CHARPTR)
! 	    items = Get_String_List_Items((char **)addr, items);
! 	result = Make_Vector(items, Null);
! 	for (i = 0; i < items; i++) {
! 	    VECTOR(result)->data[i] = Reference_Address(addr, type, pointer);
! 	    switch (type) {
! 	      case C_CHAR:
! 		addr += sizeof(char);
! 		break;
! 	      case C_SHORT:
! 		addr += sizeof(short);
! 		break;
! 	      case C_INT:
! 		addr += sizeof(int);
! 		break;
! 	      case C_LONG:
! 		addr += sizeof(long);
! 		break;
! 	      case C_UNSIGNED_CHAR:
! 		addr += sizeof(unsigned char);
! 		break;
! 	      case C_UNSIGNED_SHORT:
! 		addr += sizeof(unsigned short);
! 		break;
! 	      case C_UNSIGNED_INT:
! 		addr += sizeof(unsigned int);
! 		break;
! 	      case C_UNSIGNED_LONG:
! 		addr += sizeof(unsigned long);
! 		break;
! 	      case C_FLOAT:
! 		addr += sizeof(float);
! 		break;
! 	      case C_DOUBLE:
! 		addr += sizeof(double);
! 		break;
! 	      case C_CHARPTR:
! 		addr += sizeof(char *);
! 		break;
! 	      default:
! 		Primitive_Error("internal error with address increment");
  	    }
  	}
      }
!     GC_Unlink;
!     return result;
  }
  
! static SchemeObject P_Pointer_Set(ptr, addr)
! SchemeObject ptr, addr;
  {
!     Check_Type(ptr, T_Pointer);
!     POINTER_T(ptr)->pointer = (void *)Get_Integer(addr);
!     return ptr;
  }
  
! static int Pointer_Equal(a, b)
! SchemeObject a, b;
  {
!     return EQ(POINTER_T(a)->type, POINTER_T(b)->type) &&
! 	(POINTER_T(a)->pointer == POINTER_T(b)->pointer);
  }
  
! static int Pointer_Print(x, port, raw, depth, length)
! SchemeObject x, port;
! int raw, depth, length;
  {
!     int type;
!     GC_Node2;
  
!     GC_Link2(port, x);
!     type = POINTER_T(x)->type.data;
!     if (type < C_base || type > C_last)
! 	Panic("bad pointer type in print");
!     if (POINTER_T(x)->pointer == (void *)0)
! 	Printf(port, "#[pointer NULL]");
!     else {
! 	Printf(port, "#[pointer <%s>", type_names[type]);
! 	if (type == C_ID) {
  	  id obj = ((id) (POINTER_T(x)->pointer));
! 	    char *otype = "instance";
  #ifdef NeXT_RUNTIME
! 	    if (CLS_GETINFO(obj->isa, CLS_META))
  #elif GNU_RUNTIME
! 	    if (CLS_ISMETA(obj->class_pointer))
  #else
  #error *** NEITHER NeXT NOR GNU RUNTIME PRESENT ***
  #endif
! 		otype = "class";
  #ifdef NeXT_RUNTIME
! 	    Printf(port, " {%s %s}", obj->isa->name, otype);
  #elif GNU_RUNTIME
! 	    Printf(port, " {%s %s}", obj->class_pointer->name, otype);
  #else
  #error *** NEITHER NeXT NOR GNU RUNTIME PRESENT ***
  #endif
  	}
! 	Printf(port, " (%u)]", (unsigned int)POINTER_T(x)->pointer);
      }
!     GC_Unlink;
  
!     return 0;
  }
  
! void elk_init_pointer()
  {   
!     T_Pointer = Define_Type(0, "pointer", NOFUNC, sizeof(struct S_Pointer),
! 		       Pointer_Equal, Pointer_Equal, Pointer_Print, NOFUNC);
!     Null_Pointer = A_Make_Pointer(0, C_VOID);
!     Define_Primitive(P_Pointerp, "pointer?", 1, 1, EVAL);
!     Define_Primitive(P_Null_Pointerp, "null-pointer?", 1, 1, EVAL);
!     Define_Primitive(P_Make_Pointer, "make-pointer", 2, 2, EVAL);
!     Define_Primitive(P_Pointer_Type, "pointer-type", 1, 1, EVAL);
!     Define_Primitive(P_Pointer_Addr, "pointer-addr", 1, 1, EVAL);
!     Define_Primitive(P_Pointer_Ref, "pointer-ref", 1, 3, VARARGS);
!     Define_Primitive(P_Pointer_Set, "pointer-set!", 2, 2, EVAL);
!     P_Provide(Intern("pointer"));
  }
--- 93,442 ----
  };
  
! 
! static SchemeObject
! P_Pointerp(SchemeObject x)
  {
!   return TYPE(x) == T_Pointer ? True : False;
  }
  
! 
! static SchemeObject
! P_Null_Pointerp (SchemeObject x)
  {
!   Check_Type(x, T_Pointer);
!   return POINTER_T(x)->pointer == (void *)0 ? True : False;
  }
  
! 
! static SchemeObject
! P_Pointer_Type (SchemeObject ptr)
  {
!   Check_Type(ptr, T_Pointer);
!   return Make_String(type_names[POINTER_T(ptr)->type.data],
! 		     strlen(type_names[POINTER_T(ptr)->type.data]));
  }
  
! 
! static SchemeObject
! P_Pointer_Addr (SchemeObject ptr)
  {
!   Check_Type(ptr, T_Pointer);
!   return Make_Integer((int)(POINTER_T(ptr)->pointer));
  }
  
! 
! SchemeObject
! A_Make_Pointer (int address,
! 		int type)
  {
!   SchemeObject pointer;
  
!   pointer = Alloc_Object(sizeof(struct S_Pointer), T_Pointer, 0);
!   POINTER_T(pointer)->type.data = type;
!   POINTER_T(pointer)->pointer = (void *)address;
!   return pointer;
  }
  
! 
! static SchemeObject
! P_Make_Pointer (SchemeObject addr,
! 		SchemeObject type)
  {
    //    SchemeObject pointer;
!   int i;
  
!   if (TYPE(type) != T_String && TYPE(type) != T_Symbol)
!     {
!       Wrong_Type_Combination(type, "string or symbol");
      }
!   if (TYPE(type) == T_Symbol)
!     {
!       type = SYMBOL(type)->name;
!     }
!   for (i = C_pointers; i < C_last; i++)
!     {
!       if (strlen(type_names[i]) != STRING(type)->size)
! 	{
! 	  continue;
! 	}
!       if (strcmp(STRING(type)->data, type_names[i]) == 0)
! 	{
! 	  break;
! 	}
!     }
!   if (i == C_last)
!     {
!       Primitive_Error("unknown pointer type: ~s", type);
!     }
! 
!   return A_Make_Pointer(Get_Integer(addr), i);
  }
  
! 
! static SchemeObject
! Reference_Address (int p,
! 		   int t,
! 		   SchemeObject b)
  {
!   switch (t)
!     {
!     case C_CHAR:
!     case C_UNSIGNED_CHAR:
!       return Make_String((char *)p, strlen((char *)p));
! 
!     case C_SHORT:
!       return Make_Integer(*((short *)p));
! 
!     case C_INT:
!       return Make_Integer(*((int *)p));
! 
!     case C_LONG:
!       return Make_Integer(*((long *)p));
! 
!     case C_UNSIGNED_SHORT:
!       return Make_Unsigned(*((unsigned short *)p));
! 
!     case C_UNSIGNED_INT:
!       return Make_Unsigned(*((unsigned int *)p));
! 
!     case C_UNSIGNED_LONG:
!       return Make_Unsigned(*((unsigned long *)p));
! 
!     case C_FLOAT:
!       return Make_Reduced_Flonum(*((float *)p));
! 
!     case C_DOUBLE:
!       return Make_Reduced_Flonum(*((double *)p));
! 
!     case C_CHARPTR:
!       return Make_String(*((char **)p), strlen((*(char **)p)));
! 
!     default:
!       return Null;
      }
  }
  
! 
! static int
! Get_String_List_Items (char **p,
! 		       int n)
  {
!   int m = 0;
!   int l = 10000;
  
!   if (n == 0)
!     {
!       while (*p++ != (char *)0 && --l)
! 	{
! 	  m++;
! 	}
!     }
!   else
!     {
!       while (n-- > 0)
! 	{
! 	  if (*p++ == (char *)0 && --l)
! 	    {
! 	      break;
! 	    }
! 	  else
! 	    {
! 	      m++;
! 	    }
! 	}
!     }
!   if (l)
!     {
!       return m;
!     }
!   else
!     {
!       Primitive_Error("expected string vector too long");
!     }
!   /*NOTREACHED*/
!   return 0; /* avoid warnings */
  }
  
! 
! static SchemeObject
! P_Pointer_Ref (int argc,
! 	       SchemeObject *argv)
  {
!   SchemeObject result, pointer;
!   int offset = 0, items = 1, type, addr, i;
  
!   GC_Node;
  
!   pointer = argv[0];
!   Check_Type(pointer, T_Pointer);
!   GC_Link(pointer);
!   type = POINTER_T(pointer)->type.data;
!   addr = (int)POINTER_T(pointer)->pointer;
! 
!   if (argc > 1)
!     {
!       offset = Get_Integer(argv[1]);
!     }
!   if (argc > 2)
!     {
!       items = Get_Integer(argv[2]);
!     }
!   if (items == 1)
!     {
!       result = Reference_Address(addr, type, pointer);
!     }
!   else
!     {
!       if (type == C_CHARPTR)
! 	items = Get_String_List_Items((char **)addr, items);
!       result = Make_Vector(items, Null);
!       for (i = 0; i < items; i++)
! 	{
! 	  VECTOR(result)->data[i] = Reference_Address(addr, type, pointer);
! 	  switch (type)
! 	    {
! 	    case C_CHAR:
! 	      addr += sizeof(char);
! 	      break;
! 
! 	    case C_SHORT:
! 	      addr += sizeof(short);
! 	      break;
! 
! 	    case C_INT:
! 	      addr += sizeof(int);
! 	      break;
! 
! 	    case C_LONG:
! 	      addr += sizeof(long);
! 	      break;
! 
! 	    case C_UNSIGNED_CHAR:
! 	      addr += sizeof(unsigned char);
! 	      break;
! 
! 	    case C_UNSIGNED_SHORT:
! 	      addr += sizeof(unsigned short);
! 	      break;
! 
! 	    case C_UNSIGNED_INT:
! 	      addr += sizeof(unsigned int);
! 	      break;
! 
! 	    case C_UNSIGNED_LONG:
! 	      addr += sizeof(unsigned long);
! 	      break;
! 
! 	    case C_FLOAT:
! 	      addr += sizeof(float);
! 	      break;
! 
! 	    case C_DOUBLE:
! 	      addr += sizeof(double);
! 	      break;
! 
! 	    case C_CHARPTR:
! 	      addr += sizeof(char *);
! 	      break;
! 
! 	    default:
! 	      Primitive_Error("internal error with address increment");
  	    }
  	}
      }
!   GC_Unlink;
! 
!   return result;
  }
  
! 
! static SchemeObject
! P_Pointer_Set (SchemeObject ptr,
! 	       SchemeObject addr)
  {
!   Check_Type(ptr, T_Pointer);
!   POINTER_T(ptr)->pointer = (void *)Get_Integer(addr);
! 
!   return ptr;
  }
  
! 
! static int
! Pointer_Equal (SchemeObject a,
! 	       SchemeObject b)
  {
!   return EQ(POINTER_T(a)->type, POINTER_T(b)->type) &&
!     (POINTER_T(a)->pointer == POINTER_T(b)->pointer);
  }
  
! 
! static int
! Pointer_Print(SchemeObject x,
! 	      SchemeObject port,
! 	      int raw,
! 	      int depth,
! 	      int length)
  {
!   int type;
!   GC_Node2;
  
!   GC_Link2(port, x);
!   type = POINTER_T(x)->type.data;
!   if (type < C_base || type > C_last)
!     {
!       Panic("bad pointer type in print");
!     }
!   if (POINTER_T(x)->pointer == NULL)
!     {
!       Printf(port, "#[pointer NULL]");
!     }
!   else
!     {
!       // FIXME: THIS MIGHT GET BETTER USING HIGHLEVEL CALLS
! 
!       Printf(port, "#[pointer <%s>", type_names[type]);
!       if (type == C_ID)
! 	{
  	  id obj = ((id) (POINTER_T(x)->pointer));
! 	  char *otype = "instance";
  #ifdef NeXT_RUNTIME
! 	  if (CLS_GETINFO(obj->isa, CLS_META))
  #elif GNU_RUNTIME
! 	  if (CLS_ISMETA(obj->class_pointer))
  #else
  #error *** NEITHER NeXT NOR GNU RUNTIME PRESENT ***
  #endif
! 	    {
! 	      otype = "class";
! 	    }
  #ifdef NeXT_RUNTIME
! 	  Printf(port, " {%s %s}", obj->isa->name, otype);
  #elif GNU_RUNTIME
! 	  Printf(port, " {%s %s}", obj->class_pointer->name, otype);
  #else
  #error *** NEITHER NeXT NOR GNU RUNTIME PRESENT ***
  #endif
  	}
!       Printf(port, " (%u)]", (unsigned int)POINTER_T(x)->pointer);
      }
!   GC_Unlink;
  
!   return 0;
  }
  
! 
! void
! elk_nit_pointer ()
  {   
!   T_Pointer = Define_Type(0, "pointer", NOFUNC, sizeof(struct S_Pointer),
! 			  Pointer_Equal, Pointer_Equal, Pointer_Print, NOFUNC);
!   Null_Pointer = A_Make_Pointer(0, C_VOID);
!   Define_Primitive(P_Pointerp, "pointer?", 1, 1, EVAL);
!   Define_Primitive(P_Null_Pointerp, "null-pointer?", 1, 1, EVAL);
!   Define_Primitive(P_Make_Pointer, "make-pointer", 2, 2, EVAL);
!   Define_Primitive(P_Pointer_Type, "pointer-type", 1, 1, EVAL);
!   Define_Primitive(P_Pointer_Addr, "pointer-addr", 1, 1, EVAL);
!   Define_Primitive(P_Pointer_Ref, "pointer-ref", 1, 3, VARARGS);
!   Define_Primitive(P_Pointer_Set, "pointer-set!", 2, 2, EVAL);
!   P_Provide(Intern("pointer"));
  }

Index: tell.m
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/src/tell.m,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** tell.m	5 Aug 2004 23:32:08 -0000	1.6
--- tell.m	6 Aug 2004 00:22:11 -0000	1.7
***************
*** 655,660 ****
  
  static SchemeObject
! P_Types(SchemeObject receiver,
! 	SchemeObject selector)
  {
    STR name;
--- 655,660 ----
  
  static SchemeObject
! P_Types (SchemeObject receiver,
! 	 SchemeObject selector)
  {
    STR name;