Lisp_Object make_complex(Lisp_Object r, Lisp_Object i)
{
Lisp_Object v, nil = C_nil;
/*
* Here r and i are expected to be either both rational (which in this
* context includes the case of integer values) or both of the same
* floating point type. It is assumed that this has already been
* arranged by here.
*/
if (i == fixnum_of_int(0)) return r;
stackcheck2(0, r, i);
push2(r, i);
v = getvector(TAG_NUMBERS, TYPE_COMPLEX_NUM, sizeof(Complex_Number));
/*
* The vector r has uninitialized contents here - dodgy. If the call
* to getvector succeeded then I fill it in, otherwise I will not
* refer to it again, and I think that unreferenced vectors containing junk
* are OK.
*/
pop2(i, r);
errexit();
real_part(v) = r;
imag_part(v) = i;
return v;
}
int scdate::add(const std::string& fmt)
{
std::vector<daterange *> *newvec;
newvec=getvector(fmt);
vectormerge(newvec);
return 1;
}
Lisp_Object make_one_word_bignum(int32_t n)
/*
* n is an integer - create a bignum representation of it. This is
* done when n is outside the range 0xf8000000 to 0x07ffffff, but
* inside the range 0xc0000000 to 0x3fffffff.
*/
{ Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+4);
Lisp_Object nil;
errexit();
bignum_digits(w)[0] = n;
if (SIXTY_FOUR_BIT) bignum_digits(w)[1] = 0; /* padding */
return w;
}
Lisp_Object make_boxfloat(double a, int32_t type)
/*
* Make a boxed float (single, double or long according to the type specifier)
* if type==0 this makes a short float
*/
{
Lisp_Object r, nil;
#ifndef COMMON
CSL_IGNORE(type);
#endif
#ifdef COMMON
switch (type)
{
case 0:
{ Float_union aa;
aa.f = (float)a;
return (aa.i & ~(intptr_t)0xf) + TAG_SFLOAT;
}
case TYPE_SINGLE_FLOAT:
r = getvector(TAG_BOXFLOAT, TYPE_SINGLE_FLOAT, sizeof(Single_Float));
errexit();
single_float_val(r) = (float)a;
return r;
default: /* TYPE_DOUBLE_FLOAT I hope */
#endif
r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT, SIZEOF_DOUBLE_FLOAT);
errexit();
double_float_val(r) = a;
return r;
#ifdef COMMON
case TYPE_LONG_FLOAT:
r = getvector(TAG_BOXFLOAT, TYPE_LONG_FLOAT, SIZEOF_LONG_FLOAT);
errexit();
long_float_val(r) = a;
return r;
}
#endif
}
scdate::scdate(const std::string& fmt)
{
unsigned int loopa;
daterange *olddate;
seconds=0;
datevec=getvector(fmt);
for (loopa=0;loopa<datevec->size();++loopa)
{
olddate=datevec->at(datevec->size()-1);
seconds+=olddate->seconds;
}
}
Lisp_Object make_two_word_bignum(int32_t a1, uint32_t a0)
/*
* This make a 2-word bignum from the 2-word value (a1,a0), where it
* must have been arranged already that a1 and a0 are correctly
* normalized to put in the two words as indicated.
*/
{
Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+8);
Lisp_Object nil;
errexit();
bignum_digits(w)[0] = a0;
bignum_digits(w)[1] = a1;
if (!SIXTY_FOUR_BIT) bignum_digits(w)[2] = 0;
return w;
}
Lisp_Object copyb(Lisp_Object a)
/*
* copy a bignum.
*/
{
Lisp_Object b, nil;
int32_t len = bignum_length(a), i;
push(a);
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
pop(a);
errexit();
len = (len-CELL)/4;
for (i=0; i<len; i++)
bignum_digits(b)[i] = bignum_digits(a)[i];
return b;
}
Lisp_Object make_ratio(Lisp_Object p, Lisp_Object q)
/*
* By the time this is called (p/q) must be in its lowest terms, q>0
*/
{
Lisp_Object v, nil = C_nil;
if (q == fixnum_of_int(1)) return p;
stackcheck2(0, p, q);
push2(p, q);
v = getvector(TAG_NUMBERS, TYPE_RATNUM, sizeof(Rational_Number));
pop2(q, p);
errexit();
numerator(v) = p;
denominator(v) = q;
return v;
}
Lisp_Object make_three_word_bignum(int32_t a2, uint32_t a1, uint32_t a0)
/*
* This make a 3-word bignum from the 3-word value (a2,a1,a0), where it
* must have been arranged already that the values are correctly
* normalized.
*/
{
Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+12);
Lisp_Object nil;
errexit();
bignum_digits(w)[0] = a0;
bignum_digits(w)[1] = a1;
bignum_digits(w)[2] = a2;
if (SIXTY_FOUR_BIT) bignum_digits(w)[3] = 0;
return w;
}
int scdate::remove(const std::string& fmt)
{
std::vector<daterange *> *newvec;
daterange *olddate;
newvec=getvector(fmt);
while (newvec->size()>0)
{
olddate=newvec->at(newvec->size()-1);
newvec->pop_back();
//Now we add this one to the system one
this->remove(olddate->start,olddate->end);
delete olddate;
}
delete newvec;
return 1;
}
Lisp_Object lengthen_by_one_bit(Lisp_Object a, int32_t msd)
/*
* (a) is a bignum, and arithmetic on it has (just) caused overflow
* in its top word - I just need to stick on another word. (msd) is the
* current top word, and its sign will be used to decide on the value
* that must be appended.
*/
{
int32_t len = bignum_length(a);
/*
* Sometimes I need to allocate a new vector and copy data across into it
*/
if ((len & 4) == 0)
{ Lisp_Object b, nil;
int32_t i;
push(a);
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, len+4);
pop(a);
errexit();
len = (len-CELL)/4;
for (i=0; i<len; i++)
bignum_digits(b)[i] = clear_top_bit(bignum_digits(a)[i]);
bignum_digits(b)[len] = top_bit_set(msd) ? -1 : 0;
bignum_digits(b)[len+1] = 0;
return b;
}
else
/*
* .. whereas sometimes I have a spare word already available.
*/
{ numhdr(a) += pack_hdrlength(1L);
len = (len-CELL)/4;
bignum_digits(a)[len-1] = clear_top_bit(bignum_digits(a)[len-1]);
bignum_digits(a)[len] = top_bit_set(msd) ? -1 : 0;
return a;
}
}
void GPSstuff(char *filename)
{
#if GPSDEBUG
printf("GPS starting...\n");
#endif
//CommDevice GPS("COM1", 0, 115200, 128);
GPS = new CommDevice("COM1", 0, 115200, 180);
#if GPSDEBUG
printf("GPS successfully started...\n");
#endif
GPS->Write("em,,/msg/nmea/RMC:.2\n");
//fio << "Hello world" << endl;
vector<smGPSDatum> GPStars;
char templocGPSbuf[360];
smGPSDatum tempsmGPS;
char prevmode = mode;
while (!escape)
{
//printf("Switching modes...\n");
fstream fio(filename);
if (!fio.is_open())
{
printf("Error: unable to open %s\n", filename);
}
//load the target GPSs
if (mode == AUTOMODE)
{
//printf("auto mode\n (GPS)\n");
while(!fio.eof())
{
//printf("loading target...\n");
smGPSDatum smtemp;
if (loadGPStar(&smtemp, &fio))
{
printf("Loaded Target: Lat: %2.12f, Lon: %3.12f\n", smtemp.latitude, smtemp.longitude);
GPStars.insert(GPStars.begin(), smtemp);
}
}
printf("%d GPS targets loaded.\n", GPStars.size());
}
SetEvent(hTargetsLoaded);
while (!escape)
{
if (mode != prevmode)
{
prevmode = mode;
break;
}
//find terminating null-character
char *tc = strchr(templocGPSbuf, 0);
char *GPSToParse = 0;
#if FORCEGPSINPUT
GPSToParse = new char[256];
sprintf(GPSToParse, "$GNRMC,123519,A,4807.038,N,01131.000,E,022.4,084.4,230394,003.1,W,N*6A");
#else
//DWORD evstatus;
//do
//{
// WaitCommEvent(GPS.hComm, &evstatus, NULL);
//} while (evstatus != EV_RXFLAG);
//printf("starting GPS read\n");
GPS->Read(tc);
//GPS.Read(rawGPSdata, sizeof(rawGPSdata));
int i;
//char *GPSEnd = 0;
for (i = strlen(tc)/*256*/; i > 0 && tc[i] != '\n'; --i);
if (tc[i] == '\n')
{
//printf("\\n at i=%d\n", i);
//GPSEnd = &tc[i];
//tc[i] = 0;
for ( ; i > 0 && tc[i] != '$'; --i);
if (tc[i] == '$')
{
GPSToParse = &tc[i];
//printf("GPSToParse: %s\n", GPSToParse);
}
}
#endif
if (GPSToParse)
{
//strcpy(strrchr(locGPSbuf, 0), rawGPSdata);
#if GPSDEBUG
if (rawGPSdata)
printf("GPS: %s\n", rawGPSdata);
else
printf("Error: rawGPSdata == 0\n");
#endif
//printf("rawGPSdata: %s\n", rawGPSdata);
//printf("Going to parse GPS...\n");
//printf("GPSToParse: %s\n", GPSToParse);
char *cur_pos = strstr(GPSToParse, "$GNRMC");
//printf("cur_pos: %s\n", cur_pos);
if (cur_pos)//strstr(rawGPSdata, "$GNRMC"))
{
//Parse the GPS data from rawGPSdata
//Look for GPS coordinates, etc:
//char *cur_pos;
unsigned char i = 0; //shoud always be less than 255 commas
//printf("looking for a value for cur_pos\n");
cur_pos = strchr(cur_pos, ',');//strchr(rawGPSdata, ',');
GPSDatum curGPS = {0};
//printf("cur_pos: %d\n", cur_pos);
while (cur_pos)
{
double tempd;
cur_pos = strchr(cur_pos, ',');
if (cur_pos)
{
cur_pos++;
switch(++i)
{
case 1: //UTC Time [char*]
memcpy(curGPS.time, cur_pos, 6);
#if GPSDEBUG
printf("time: %s\n", curGPS.time);
#endif
break;
case 2: //Status (A = Active, V = Void) [char]
curGPS.status = (cur_pos && *cur_pos != ',') ? *cur_pos : 0;
#if GPSDEBUG
printf("status: %c\n", curGPS.status);
#endif
if (tolower(curGPS.status) != 'a')
{
//force a break from the loop
cur_pos = 0;
}
break;
case 3: //Latitude [double]
//must convert from DDMM.MMM to DD.DDDD
tempd = atof(cur_pos+2);
curGPS.latitude = ((atof(cur_pos) - tempd)/100.0 + tempd/60.0);
//curGPS.latitude = atof(cur_pos);
break;
case 4: //Latitude N/S [char]
curGPS.latitudeNS = (cur_pos && *cur_pos != ',') ? *cur_pos : 0;
if (tolower(curGPS.latitudeNS) == 's')
{
curGPS.latitude *= -1.0;
}
//#if GPSDEBUG
printf("latitude: %f\n", curGPS.latitude);
//#endif
break;
case 5: //Longitude [double]
//must convert from DDMM.MMM to DD.DDDD
tempd = atof(cur_pos+3);
curGPS.longitude = ((atof(cur_pos) - tempd)/100.0 + tempd/60.0);
//curGPS.longitude = atof(cur_pos);
break;
case 6: //Longitude E/W [char]
curGPS.longitudeEW = (cur_pos && *cur_pos != ',') ? *cur_pos : 0;
if (tolower(curGPS.longitudeEW) == 'w')
{
curGPS.longitude *= -1.0;
}
//#if GPSDEBUG
printf("longitude: %f\n", curGPS.longitude);
//#endif
break;
case 7: //Velocity (knots) [float]
curGPS.velocity = (float)atof(cur_pos);
#if GPSDEBUG
printf("velocity: %f\n", curGPS.velocity);
#endif
break;
case 8: //Heading True North [float]
curGPS.heading = (float)atof(cur_pos);
#if GPSDEBUG
printf("heading: %f\n", curGPS.heading);
#endif
break;
case 9: //UTC Date [char*]
memcpy(curGPS.date, cur_pos, 6);
#if GPSDEBUG
printf("date: %s\n", curGPS.date);
#endif
break;
case 10: //Magnetic Variation [float]
curGPS.magvariation = (float)atof(cur_pos);
#if GPSDEBUG
printf("magvariation: %f\n", curGPS.magvariation);
#endif
break;
case 11: //Magnetic Variation E/W [char]
curGPS.magvariationEW = (cur_pos && *cur_pos != ',') ? *cur_pos : 0;
if (tolower(curGPS.magvariationEW) == 'e')
{
curGPS.magvariation *= -1.0;
}
#if GPSDEBUG
printf("magvariationEW: %c\n", curGPS.magvariationEW);
#endif
break;
case 12: //Checksum [char*]
memcpy(curGPS.checksum, cur_pos, 4);
#if GPSDEBUG
printf("checksum: %s\n", curGPS.checksum);
#endif
break;
}
}
}
if (curGPS.checksum[1] != '*')
{
printf("continuing...\n\a");
goto mylab; //perhaps there is a more elegant way to fix this (?)
//continue; //continue; did not seem to work
}
if (mode != GPSMODE)
{
WaitForSingleObject(mStoreGPS, INFINITE);
if (StoreGPS)
{
smGPSDatum savetempGPSDatum;
savetempGPSDatum.latitude = curGPS.latitude;
savetempGPSDatum.longitude = curGPS.longitude;
saveGPStar(&savetempGPSDatum, &fio);
//store the current GPS location at this point in the code
StoreGPS = false;
printf("GPS Stored!\n");
SetEvent(hStoreGPS); //currently unusued; perhaps later to stop robot until GPS point recorded
}
ReleaseMutex(mStoreGPS);
}
else
{
//it is auto mode
printf("GPStars.size(): %d\n", GPStars.size());
if (curGPSHit)
{
if (GPStars.size())
{
tempsmGPS = GPStars.back();
printf("New GPS Target: Lat: %f, Long: %f\n", tempsmGPS.latitude, tempsmGPS.longitude);
GPStars.pop_back();
curGPSHit = 0;
}
else
{
//all GPS targets have been reached, or no GPS targets remain
printf("Done.\n");
stopmain = true;
}
}
GPSvector tempGPSvec = getvector(&curGPS, &tempsmGPS);
tempGPSvec.curdir = curGPS.heading;
tempGPSvec.magvariation = curGPS.magvariation;
WaitForSingleObject(mGPSData, INFINITE);
//curGPSHit = false;
curGPSvec = tempGPSvec;
//CompassData = atof(rawGPSdata)/10;
//copy to global compass value here
ReleaseMutex(mGPSData);
SetEvent(hNewGPSData);
}
}
}
mylab:
char tempstr[256];
strcpy(tempstr, tc);
memset(templocGPSbuf, 0, sizeof(templocGPSbuf));
strcpy(templocGPSbuf, tempstr);
}
fio.close();
}
}
Lisp_Object negateb(Lisp_Object a)
/*
* Negate a bignum. Note that negating the 1-word bignum
* value of 0x08000000 will produce a fixnum as a result,
* which might confuse the caller... in a similar way negating
* the value -0x40000000 will need to promote from a one-word
* bignum to a 2-word bignum. How messy just for negation!
*/
{
Lisp_Object b, nil;
int32_t len = bignum_length(a), i, carry;
if (len == CELL+4) /* one-word bignum - do specially */
{ len = -(int32_t)bignum_digits(a)[0];
if (len == fix_mask) return fixnum_of_int(len);
else if (len == 0x40000000) return make_two_word_bignum(0, len);
else return make_one_word_bignum(len);
}
push(a);
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, len);
pop(a);
errexit();
len = (len-CELL)/4-1;
carry = -1;
for (i=0; i<len; i++)
{ carry = clear_top_bit(~bignum_digits(a)[i]) + top_bit(carry);
bignum_digits(b)[i] = clear_top_bit(carry);
}
/*
* Handle the top digit separately since it is signed.
*/
carry = ~bignum_digits(a)[i] + top_bit(carry);
if (!signed_overflow(carry))
{
/*
* If the most significant word ends up as -1 then I just might
* have 0x40000000 in the next word down and so I may need to shrink
* the number. Since I handled 1-word bignums specially I have at
* least two words to deal with here.
*/
if (carry == -1 && (bignum_digits(b)[i-1] & 0x40000000) != 0)
{ bignum_digits(b)[i-1] |= ~0x7fffffff;
numhdr(b) -= pack_hdrlength(1);
if (SIXTY_FOUR_BIT)
{ if ((i & 1) != 0) bignum_digits(b)[i] = 0;
else bignum_digits(b)[i] = make_bighdr(2);
}
else
{ if ((i & 1) == 0) bignum_digits(b)[i] = 0;
else bignum_digits(b)[i] = make_bighdr(2);
}
}
else bignum_digits(b)[i] = carry; /* no shrinking needed */
return b;
}
/*
* Here I have overflow: this can only happen when I negate a number
* that started off with 0xc0000000 in the most significant digit,
* and I have to pad a zero word onto the front.
*/
bignum_digits(b)[i] = clear_top_bit(carry);
return lengthen_by_one_bit(b, carry);
}
LISP getexpr () /* чтение выражения АТОМ | ЧИСЛО | '(' СПИСОК ')' */
{
LISP p;
switch (getlex ()) {
default:
fatal ("syntax error");
case ')':
ungetlex ();
case 0:
return (NIL);
case '(':
if (getlex () == ')')
return (NIL);
ungetlex ();
p = getlist ();
if (getlex () != ')')
fatal ("right parence expected");
break;
case '\'':
p = cons (symbol ("quote"), cons (getexpr (), NIL));
break;
case '`':
p = cons (symbol ("quasiquote"), cons (getexpr (), NIL));
break;
case ',':
if (getlex () == '@')
p = cons (symbol ("unquote-splicing"), cons (getexpr (), NIL));
else {
ungetlex ();
p = cons (symbol ("unquote"), cons (getexpr (), NIL));
}
break;
case TSYMBOL:
p = symbol (lexsym);
if (trace > 2)
fprintf (stderr, "%s\n", lexsym);
break;
case TBOOL:
p = lexval ? T : NIL;
if (trace > 2)
fprintf (stderr, "#%c\n", lexval ? 't' : 'f');
break;
case TCHAR:
p = character (lexval);
if (trace > 2)
fprintf (stderr, "#\\\\%03o\n", (unsigned) lexval);
break;
case TINTEGER:
p = number (lexval);
if (trace > 2)
fprintf (stderr, "%ld\n", lexval);
break;
case TREAL:
p = real (lexrealval);
if (trace > 2)
fprintf (stderr, "%#g\n", lexrealval);
break;
case TSTRING:
p = string (lexlen, lexsym);
if (trace > 2) {
putstring (p, stderr);
fprintf (stderr, "\n");
}
break;
case TVECTOR:
p = getvector ();
if (getlex () != ')')
fatal ("right parence expected");
break;
}
return (p);
}
static Lisp_Object plusbb(Lisp_Object a, Lisp_Object b)
/*
* add two bignums.
*/
{
int32_t la = bignum_length(a),
lb = bignum_length(b),
i, s, carry;
Lisp_Object c, nil;
if (la < lb) /* maybe swap order of args */
{ Lisp_Object t = a;
int32_t t1;
a = b; b = t;
t1 = la; la = lb; lb = t1;
}
/*
* now (a) is AT LEAST as long as b. I have special case code for
* when both args are single-word bignums, since I expect that to be
* an especially common case.
*/
if (la == CELL+4) /* and hence b also has only 1 digit */
{ int32_t va = bignum_digits(a)[0],
vb = bignum_digits(b)[0],
vc = va + vb;
if (signed_overflow(vc)) /* we have a 2-word bignum result */
{ Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+8);
errexit();
bignum_digits(w)[0] = clear_top_bit(vc);
bignum_digits(w)[1] = top_bit_set(vc) ? -1 : 0;
if (!SIXTY_FOUR_BIT) bignum_digits(w)[2] = 0;
return w;
}
/*
* here the result fits into one word - maybe it will squash down into
* a fixnum?
*/
else
{ vb = vc & fix_mask;
if (vb == 0 || vb == fix_mask) return fixnum_of_int(vc);
else return make_one_word_bignum(vc);
}
}
push2(a, b);
c = getvector(TAG_NUMBERS, TYPE_BIGNUM, la);
pop2(b, a);
errexit();
la = (la-CELL)/4 - 1;
lb = (lb-CELL)/4 - 1;
carry = 0;
/*
* Add all but the top digit of b
*/
for (i=0; i<lb; i++)
{ carry = bignum_digits(a)[i] + bignum_digits(b)[i] + top_bit(carry);
bignum_digits(c)[i] = clear_top_bit(carry);
}
if (la == lb) s = bignum_digits(b)[i];
else
/*
* If a is strictly longer than b I sign extend b here and add in as many
* copies of 0 or -1 as needbe to get up to the length of a.
*/
{ s = bignum_digits(b)[i];
carry = bignum_digits(a)[i] + clear_top_bit(s) + top_bit(carry);
bignum_digits(c)[i] = clear_top_bit(carry);
if (s < 0) s = -1; else s = 0;
for (i++; i<la; i++)
{ carry = bignum_digits(a)[i] + clear_top_bit(s) + top_bit(carry);
bignum_digits(c)[i] = clear_top_bit(carry);
}
}
/*
* the most significant digit is added using signed arithmetic so that I
* can tell if it overflowed.
*/
carry = bignum_digits(a)[i] + s + top_bit(carry);
if (!signed_overflow(carry))
{
/*
* Here the number has not expanded - but it may be shrinking, and it can
* shrink by any number of words, all the way down to a fixnum maybe. Note
* that I started with at least a 2-word bignum here.
*/
int32_t msd;
bignum_digits(c)[i] = carry;
if (carry == 0)
{ int32_t j = i-1;
while ((msd = bignum_digits(c)[j]) == 0 && j > 0) j--;
/*
* ... but I may need a zero word on the front if the next word down
* has its top bit set... (top of 31 bits, that is)
*/
if ((msd & 0x40000000) != 0)
{ j++;
if (i == j) return c;
}
if (j == 0)
{ int32_t s = bignum_digits(c)[0];
if ((s & fix_mask) == 0) return fixnum_of_int(s);
}
/*
* If I am shrinking by one word and had an even length to start with
* I do not have to mess about so much.
*/
if ((SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) != 0)) ||
(!SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) == 0)))
{ numhdr(c) -= pack_hdrlength(1L);
return c;
}
numhdr(c) -= pack_hdrlength(i - j);
if (SIXTY_FOUR_BIT)
{ i = (i+2) & ~1;
j = (j+2) & ~1; /* Round up to odd index */
}
else
{ i = (i+1) | 1;
j = (j+1) | 1; /* Round up to odd index */
}
/*
* I forge a header word to allow the garbage collector to skip over
* (and in due course reclaim) the space that turned out not to be needed.
*/
if (i != j) bignum_digits(c)[j] = make_bighdr(i - j);
return c;
}
/*
* Now do all the same sorts of things but this time for negative numbers.
*/
else if (carry == -1)
{ int32_t j = i-1;
msd = carry; /* in case j = 0 */
while ((msd = bignum_digits(c)[j]) == 0x7fffffff && j > 0) j--;
if ((msd & 0x40000000) == 0)
{ j++;
if (i == j) return c;
}
if (j == 0)
{ int32_t s = bignum_digits(c)[0] | ~0x7fffffff;
if ((s & fix_mask) == fix_mask) return fixnum_of_int(s);
}
if ((SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) != 0)) ||
(!SIXTY_FOUR_BIT && (j == i-1) && ((i & 1) == 0)))
{ bignum_digits(c)[i] = 0;
bignum_digits(c)[i-1] |= ~0x7fffffff;
numhdr(c) -= pack_hdrlength(1);
return c;
}
numhdr(c) -= pack_hdrlength(i - j);
bignum_digits(c)[j+1] = 0;
bignum_digits(c)[j] |= ~0x7fffffff;
if (SIXTY_FOUR_BIT)
{ i = (i+2) & ~1;
j = (j+2) & ~1; /* Round up to odd index */
}
else
{ i = (i+1) | 1;
j = (j+1) | 1; /* Round up to odd index */
}
if (i != j) bignum_digits(c)[j] = make_bighdr(i - j);
return c;
}
return c;
}
else
{ bignum_digits(c)[i] = carry;
return lengthen_by_one_bit(c, carry);
}
}
static Lisp_Object plusib(Lisp_Object a, Lisp_Object b)
/*
* Add a fixnum to a bignum, returning a result as a fixnum or bignum
* depending on its size. This seems much nastier than one would have
* hoped.
*/
{
int32_t len = bignum_length(b)-CELL, i, sign = int_of_fixnum(a), s;
Lisp_Object c, nil;
len = len/4; /* This is always 4 because even on a 64-bit */
/* machine where CELL=8 I use 4-byte B-digits */
if (len == 1)
{ int32_t t;
/*
* Partly because it will be a common case and partly because it has
* various special cases I have special purpose code to cope with
* adding a fixnum to a one-word bignum.
*/
s = (int32_t)bignum_digits(b)[0] + sign;
t = s + s;
if (top_bit_set(s ^ t)) /* needs to turn into two-word bignum */
{ if (s < 0) return make_two_word_bignum(-1, clear_top_bit(s));
else return make_two_word_bignum(0, s);
}
t = s & fix_mask; /* Will it fit as a fixnum? */
if (t == 0 || t == fix_mask) return fixnum_of_int(s);
/* here the result is a one-word bignum */
return make_one_word_bignum(s);
}
/*
* Now, after all the silly cases have been handled, I have a calculation
* which seems set to give a multi-word result. The result here can at
* least never shrink to a fixnum since subtracting a fixnum can at
* most shrink the length of a number by one word. I omit the stack-
* check here in the hope that code here never nests enough for trouble.
*/
push(b);
c = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+4*len);
pop(b);
errexit();
s = bignum_digits(b)[0] + clear_top_bit(sign);
bignum_digits(c)[0] = clear_top_bit(s);
if (sign >= 0) sign = 0; else sign = 0x7fffffff; /* extend the sign */
len--;
for (i=1; i<len; i++)
{ s = bignum_digits(b)[i] + sign + top_bit(s);
bignum_digits(c)[i] = clear_top_bit(s);
}
/* Now just the most significant digit remains to be processed */
if (sign != 0) sign = -1;
{ s = bignum_digits(b)[i] + sign + top_bit(s);
if (!signed_overflow(s)) /* did it overflow? */
{
/*
* Here the most significant digit did not produce an overflow, but maybe
* what we actually had was some cancellation and the MSD is now zero
* or -1, so that the number should shrink...
*/
if ((s == 0 && (bignum_digits(c)[i-1] & 0x40000000) == 0) ||
(s == -1 && (bignum_digits(c)[i-1] & 0x40000000) != 0))
{ /* shrink the number */
numhdr(c) -= pack_hdrlength(1L);
if (s == -1) bignum_digits(c)[i-1] |= ~0x7fffffff;
/*
* Now sometimes the shrinkage will leave a padding word, sometimes it
* will really allow me to save space. As a jolly joke with a 64-bit
* system I need padding if there have been an odd number of (32-bit)
* words of bignum data while with a 32-bit system the header word is
* 32-bits wide and I need padding if there are ar even number of additional
* data words.
*/
if ((SIXTY_FOUR_BIT && ((i & 1) != 0)) ||
(!SIXTY_FOUR_BIT && ((i & 1) == 0)))
{ bignum_digits(c)[i] = 0; /* leave the unused word tidy */
return c;
}
/*
* Having shrunk the number I am leaving a doubleword of unallocated space
* in the heap. Dump a header word into it to make it look like an
* 8-byte bignum since that will allow the garbage collector to handle it.
* It I left it containing arbitrary junk I could wreck myself. The
* make_bighdr(2L) makes a header for a number that fills 2 32-bit words
* in all.
*/
*(Header *)&bignum_digits(c)[i] = make_bighdr(2L);
return c;
}
bignum_digits(c)[i] = s; /* length unchanged */
return c;
}
/*
* Here the result is one word longer than the input-bignum.
* Once again SOMTIMES this will not involve allocating more store,
* but just encroaching into the previously unused word that was padding
* things out to a multiple of 8 bytes.
*/
if ((SIXTY_FOUR_BIT && ((i & 1) == 0)) ||
(!SIXTY_FOUR_BIT && ((i & 1) == 1)))
{ bignum_digits(c)[i++] = clear_top_bit(s);
bignum_digits(c)[i] = top_bit_set(s) ? -1 : 0;
numhdr(c) += pack_hdrlength(1L);
return c;
}
push(c);
/*
* NB on the next line there is a +8. One +4 is because I had gone len--
* somewhere earlier. The other +4 is to increase the length of the number
* by one word.
*/
b = getvector(TAG_NUMBERS, TYPE_BIGNUM, CELL+8+4*len);
pop(c);
errexit();
for (i=0; i<len; i++)
bignum_digits(b)[i] = bignum_digits(c)[i];
/*
* I move the top digit across by hand since if the number is negative
* I must lost its top bit
*/
bignum_digits(b)[i++] = clear_top_bit(s);
/* Now the one-word extension to the number */
bignum_digits(b)[i++] = top_bit_set(s) ? -1 : 0;
/*
* Finally because I know that I expanded into a new doubleword I should
* tidy up the second word of the newly allocated pair.
*/
bignum_digits(b)[i] = 0;
return b;
}
}
