int Visit (register Object *p) {
register Object *tag;
register int t, size, reloc = 0;
again:
t = TYPE(*p);
if (!Types[t].haspointer)
return 0;
tag = (Object *)POINTER(*p);
if ((char *)tag >= Free_Start && (char *)tag < Free_End)
return 0;
if (TYPE(*tag) == T_Broken_Heart) {
SETPOINTER(*p, POINTER(*tag));
return 0;
}
ELK_ALIGN(To);
switch (t) {
case T_Bignum:
size = sizeof (struct S_Bignum) - sizeof (gran_t)
+ BIGNUM(*p)->size * sizeof (gran_t);
memcpy (To, tag, size);
break;
case T_Flonum:
size = sizeof (struct S_Flonum);
*(struct S_Flonum *)To = *(struct S_Flonum *)tag;
break;
case T_Symbol:
size = sizeof (struct S_Symbol);
*(struct S_Symbol *)To = *(struct S_Symbol *)tag;
break;
case T_Pair:
case T_Environment:
size = sizeof (struct S_Pair);
*(struct S_Pair *)To = *(struct S_Pair *)tag;
break;
case T_String:
size = sizeof (struct S_String) + STRING(*p)->size - 1;
memcpy (To, tag, size);
break;
case T_Vector:
size = sizeof (struct S_Vector) + (VECTOR(*p)->size - 1) *
sizeof (Object);
memcpy (To, tag, size);
break;
case T_Primitive:
size = sizeof (struct S_Primitive);
*(struct S_Primitive *)To = *(struct S_Primitive *)tag;
break;
case T_Compound:
size = sizeof (struct S_Compound);
*(struct S_Compound *)To = *(struct S_Compound *)tag;
break;
case T_Control_Point:
size = sizeof (struct S_Control) + CONTROL(*p)->size - 1;
reloc = To - (char *)tag;
memcpy (To, tag, size);
break;
case T_Promise:
size = sizeof (struct S_Promise);
*(struct S_Promise *)To = *(struct S_Promise *)tag;
break;
case T_Port:
size = sizeof (struct S_Port);
*(struct S_Port *)To = *(struct S_Port *)tag;
break;
case T_Autoload:
size = sizeof (struct S_Autoload);
*(struct S_Autoload *)To = *(struct S_Autoload *)tag;
break;
case T_Macro:
size = sizeof (struct S_Macro);
*(struct S_Macro *)To = *(struct S_Macro *)tag;
break;
case T_Broken_Heart:
Panic ("broken heart in GC");
default:
if (t < 0 || t >= Num_Types)
Panic ("bad type in GC");
if (Types[t].size == NOFUNC)
size = Types[t].const_size;
else
size = (Types[t].size)(*p);
memcpy (To, tag, size);
}
SETPOINTER(*p, To);
SET(*tag, T_Broken_Heart, To);
To += size;
if (To > Free_End)
Panic ("free exhausted in GC");
switch (t) {
case T_Symbol:
Recursive_Visit (&SYMBOL(*p)->next);
Recursive_Visit (&SYMBOL(*p)->name);
Recursive_Visit (&SYMBOL(*p)->value);
p = &SYMBOL(*p)->plist;
goto again;
case T_Pair:
case T_Environment:
Recursive_Visit (&PAIR(*p)->car);
p = &PAIR(*p)->cdr;
goto again;
case T_Vector: {
register int i, n;
for (i = 0, n = VECTOR(*p)->size; i < n; i++)
Recursive_Visit (&VECTOR(*p)->data[i]);
break;
}
case T_Compound:
Recursive_Visit (&COMPOUND(*p)->closure);
Recursive_Visit (&COMPOUND(*p)->env);
p = &COMPOUND(*p)->name;
goto again;
case T_Control_Point:
Recursive_Visit (&CONTROL(*p)->memsave);
CONTROL(*p)->delta += reloc;
#ifdef HAVE_ALLOCA
Visit_GC_List (CONTROL(*p)->gclist, CONTROL(*p)->delta);
#else
Recursive_Visit (&CONTROL(*p)->gcsave);
#endif
Visit_Wind (CONTROL(*p)->firstwind, CONTROL(*p)->delta);
p = &CONTROL(*p)->env;
goto again;
case T_Promise:
Recursive_Visit (&PROMISE(*p)->env);
p = &PROMISE(*p)->thunk;
goto again;
case T_Port:
p = &PORT(*p)->name;
goto again;
case T_Autoload:
Recursive_Visit (&AUTOLOAD(*p)->files);
p = &AUTOLOAD(*p)->env;
goto again;
case T_Macro:
Recursive_Visit (&MACRO(*p)->body);
p = &MACRO(*p)->name;
goto again;
default:
if (Types[t].visit)
(Types[t].visit)(p, Visit);
}
return 0;
}
LispObj *
Lisp_ParseInteger(LispBuiltin *builtin)
/*
parse-integer string &key start end radix junk-allowed
*/
{
GC_ENTER();
char *ptr, *string;
int character, junk, sign, overflow;
long i, start, end, radix, length, integer, check;
LispObj *result;
LispObj *ostring, *ostart, *oend, *oradix, *junk_allowed;
junk_allowed = ARGUMENT(4);
oradix = ARGUMENT(3);
oend = ARGUMENT(2);
ostart = ARGUMENT(1);
ostring = ARGUMENT(0);
start = end = radix = 0;
result = NIL;
CHECK_STRING(ostring);
LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
&start, &end, &length);
string = THESTR(ostring);
if (oradix == UNSPEC)
radix = 10;
else {
CHECK_INDEX(oradix);
radix = FIXNUM_VALUE(oradix);
}
if (radix < 2 || radix > 36)
LispDestroy("%s: :RADIX %ld must be in the range 2 to 36",
STRFUN(builtin), radix);
integer = check = 0;
ptr = string + start;
sign = overflow = 0;
/* Skip leading white spaces */
for (i = start; i < end && *ptr && isspace(*ptr); ptr++, i++)
;
/* Check for sign specification */
if (i < end && (*ptr == '-' || *ptr == '+')) {
sign = *ptr == '-';
++ptr;
++i;
}
for (junk = 0; i < end; i++, ptr++) {
character = *ptr;
if (islower(character))
character = toupper(character);
if (character >= '0' && character <= '9') {
if (character - '0' >= radix)
junk = 1;
else {
check = integer;
integer = integer * radix + character - '0';
}
}
else if (character >= 'A' && character <= 'Z') {
if (character - 'A' + 10 >= radix)
junk = 1;
else {
check = integer;
integer = integer * radix + character - 'A' + 10;
}
}
else {
if (isspace(character))
break;
junk = 1;
}
if (junk)
break;
if (!overflow && check > integer)
overflow = 1;
/* keep looping just to count read bytes */
}
if (!junk)
/* Skip white spaces */
for (; i < end && *ptr && isspace(*ptr); ptr++, i++)
;
if ((junk || ptr == string) &&
(junk_allowed == UNSPEC || junk_allowed == NIL))
LispDestroy("%s: %s has a bad integer representation",
STRFUN(builtin), STROBJ(ostring));
else if (ptr == string)
result = NIL;
else if (overflow) {
mpi *bigi = LispMalloc(sizeof(mpi));
char *str;
length = end - start + sign;
str = LispMalloc(length + 1);
strncpy(str, string - sign, length + sign);
str[length + sign] = '\0';
mpi_init(bigi);
mpi_setstr(bigi, str, radix);
LispFree(str);
result = BIGNUM(bigi);
}
else
result = INTEGER(sign ? -integer : integer);
GC_PROTECT(result);
RETURN(0) = FIXNUM(i);
RETURN_COUNT = 1;
GC_LEAVE();
return (result);
}
