home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schbi2.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  24.8 KB  |  769 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHBI2.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       89/05/29
  9. **
  10. ** DESCRIPTION: This module contains functions to handle the
  11. **              Scheme Bignumbers (very large integers!)
  12. ***********************************************************************
  13. ** CHANGES INFORMATION **
  14. *************************
  15. ** REVISION:    $Revision:   1.0  $
  16. ** CHANGER:     $Author:   JAN  $
  17. ** WORKFILE:    $Workfile:   schbig.c  $
  18. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHBIG.C_V  $
  19. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHBIG.C_V  $
  20. **              
  21. **                 Rev 1.0   12 Oct 1989 11:45:42   JAN
  22. **              Initial revision.
  23. **********************************************************************/
  24. #include "schinc.h"
  25.  
  26.                        /* 0  1   2    3     4      5       6        7        */
  27. static ULONG bigfactor[]={1L,10L,100L,1000L,10000L,100000L,1000000L,10000000L};
  28. static REAL  ffactor[]={1e8,1e16};                                   
  29. #ifdef MSC
  30. STATIC ULONG inprod __((USHORT,USHORT,USHORT,USHORT));
  31. #else
  32. #define inprod(a,b,c,d) (((ULONG)a*(ULONG)b)+((ULONG)c*(ULONG)d))
  33. #endif
  34.  
  35.  
  36. /***************************************************************
  37. ** NAME:        DsStrBig
  38. ** SYNOPSIS:    CELP DsStrBig(str)
  39. **              char *str
  40. ** DESCRIPTION: Bigcel converts a string with digits into a
  41. **              Scheme bignum.
  42. ** RETURNS:     A pointer to a Scheme bignum.
  43. ***************************************************************/
  44. CELP PASCAL DsStrBig(str)
  45. char *str;                  
  46. {                           
  47.     CELP fp,cp;
  48.     int  i,j;
  49.     char *p;
  50.  
  51.     p=str;
  52.     if (p[0]=='-') p++;                                        /* skip - sign */
  53.     while (*p=='0') p++;                                       /* skip zero's */
  54.     if (*p=='\0')                                  /* empty string means zero */
  55.         return DsGetCell(TYPE_BIGP);       /* DsGetCell ensures value is zero */
  56.     for (i=0;*p;p++,i++)                            /* count number of digits */
  57.         if (!isdigit(*p))                     /* check if they are all digits */
  58.             DsStrError(ERRCHARN,str);
  59.     cp=fp=DsGetCell(TYPE_BIGP);
  60.     while (1)                           /* work from Least sign.to Most Sign. */
  61.     {
  62.         p -= (j=min(i,8));                    /* size of part to be converted */
  63.         BIGpart(cp) = atol(p);
  64.         if ((i-=j)==0) break;
  65.         cp = CDRpart(cp) = DsGetCell(TYPE_BIGP);             /* get next cell */
  66.         *p='\0';                                   /* mark parts already done */
  67.     }
  68.     if (*str=='-') TAGpart(fp)=TYPE_BIGN;                  /* negative number */
  69.     return(fp);
  70. }
  71.  
  72.  
  73. /***************************************************************
  74. ** NAME:        DsBigStr
  75. ** SYNOPSIS:    char *DsBigStr(p)
  76. **              CELP p;
  77. ** DESCRIPTION: Celbig converts a bignum to a string with digits
  78. ** RETURNS:     A pointer to a string (in BIGBUF)
  79. ***************************************************************/
  80. char * PASCAL DsBigStr(p)
  81. CELP p;
  82. {                                           /* "1 23456789 01234567 89012345" */
  83.     SHORT  sign,l;
  84.     char   *q;                       /* 89012345 -> 01234567 -> 23456789 -> 1 */
  85.     USHORT t;
  86.     ULONG  ll;
  87.  
  88.     l=(SHORT)DsLength(p)*8;                                /* number of cells */
  89.     if (l>=BIGMAX)                            /* test on maximum bufferlength */
  90.         DSVERROR(ERRBIGBIG);           /* can't pass argument to errorhandler */
  91.     q=BIGBUF+l+1;                                  /* inclusive space for '-' */
  92.     q[0]='\0';
  93.     sign = 1;
  94.     if (TAGpart(p)==TYPE_BIGN) sign=-1;
  95.     for (;l;l-=8)
  96.     {
  97.         ll=BIGpart(p);                              /* get value of this part */
  98.         p=CDRpart(p);                                  /* next part of bignum */
  99.         t=(USHORT)(ll % 10000L);                         /* first four digits */
  100.         *--q=(char)((t % 10)+'0');t/=10; 
  101.         *--q=(char)((t % 10)+'0');t/=10; 
  102.         *--q=(char)((t % 10)+'0'); 
  103.         *--q=(char)((t / 10)+'0');  
  104.         t=(USHORT)(ll / 10000L);                        /* last four digits */  
  105.         *--q=(char)((t % 10)+'0');t/=10;  
  106.         *--q=(char)((t % 10)+'0');t/=10;  
  107.         *--q=(char)((t % 10)+'0');        
  108.         *--q=(char)((t / 10)+'0');        
  109.     }
  110.     while (*q=='0') q++;                            /* discard leading zero's */
  111.     if (*q=='\0')
  112.         *(--q)='0';                    /* if string is empty than number is 0 */
  113.     else
  114.         if (sign<0)
  115.             *(--q)='-';                                  /* add negative sign */
  116.     return(q);
  117. }
  118.  
  119.  
  120. /***************************************************************
  121. ** NAME:        big_cpy
  122. ** SYNOPSIS:    CELP big_cpy(p)
  123. **              CELP p;
  124. ** DESCRIPTION: Big_cpy copies a bignum in a newly allocated
  125. **              linked list of cells.
  126. ** RETURNS:     A new list with the same BIGnumber.
  127. ***************************************************************/
  128. CELP PASCAL big_cpy(num)
  129. CELP num;
  130. {
  131.     CELP fp,cp;
  132.  
  133.     if (ISNIL(num)) return NIL;
  134.     cp=fp=DsGetCell(TAGpart(num));
  135.     while (1)
  136.     {
  137.         BIGpart(cp)=BIGpart(num);                            /* copy contents */
  138.         if (ISNIL(num=CDRpart(num))) break;              /* no more ? => quit */
  139.         cp=CDRpart(cp)=DsGetCell(TYPE_BIGP);             /* allocate new cell */
  140.     }
  141.     return(fp);
  142. }
  143.  
  144.  
  145. /***************************************************************
  146. ** NAME:        big_add
  147. ** SYNOPSIS:    CELP big_add(n1,n2)
  148. **              CELP n1;        Number 1
  149. **              CELP n2;        Number 2
  150. ** DESCRIPTION: big_add adds two bignumber together and
  151. **              produces a new bignum.
  152. ** RETURNS:     The sum of n1 and n2.
  153. ***************************************************************/
  154. CELP PASCAL big_add(n1,n2)
  155. CELP n1,n2;
  156. {
  157.     CELP fp,cp;
  158.     USHORT carry;
  159.  
  160.     fp=cp=DsGetCell(TYPE_BIGP);
  161.     while(1)
  162.     {
  163.         if (ISTRUE(n1))
  164.         {
  165.             BIGpart(cp)+=BIGpart(n1);
  166.             n1=CDRpart(n1);
  167.         }
  168.         if (ISTRUE(n2))
  169.         {
  170.             BIGpart(cp)+=BIGpart(n2);
  171.             n2=CDRpart(n2);
  172.         }
  173.         if (carry=BIGpart(cp)>=BIGBASE)
  174.             BIGpart(cp)-=BIGBASE;
  175.         if (ISNIL(n1) && ISNIL(n2) && !carry) break;  /* nothing left */
  176.         cp=CDRpart(cp)=DsGetCell(TYPE_BIGP);          /* next cell */
  177.         BIGpart(cp)=(ULONG)carry;                     /* store carry */
  178.     }
  179.     return(fp);
  180. }
  181.  
  182.  
  183. /***************************************************************
  184. ** NAME:        big_sub
  185. ** SYNOPSIS:    CELP big_sub(n1,n2)
  186. **              CELP n1;        Number 1
  187. **              CELP n2;        Number 2
  188. ** DESCRIPTION: big_sub subtracts two bignumbers and
  189. **              produces a new bignum.
  190. ** RETURNS:     (- n1 n2)
  191. ***************************************************************/
  192. CELP PASCAL big_sub(n1,n2)
  193. CELP n1,n2;
  194. {
  195.     CELP fp,cp,lp;
  196.     LONG tmp=0L;
  197.  
  198.     cp=lp=fp=DsGetCell(TYPE_BIGP);
  199.     while (1)
  200.     {
  201.         if (ISTRUE(n1))
  202.         {
  203.             tmp+=BIGpart(n1);
  204.             n1=CDRpart(n1);
  205.         }
  206.         if (ISTRUE(n2))
  207.         {
  208.             tmp-=BIGpart(n2);
  209.             n2=CDRpart(n2);
  210.         }
  211.         BIGpart(cp)=(tmp<0)?tmp+BIGBASE:tmp;         /* borrow from next part */
  212.         if (BIGpart(cp)) lp=cp;       /* most significant part with no zero's */
  213.         tmp=(tmp<0L)?-1L:0;
  214.         if (ISNIL(n1) && ISNIL(n2)) break;     /* no more digits to substract */
  215.         cp=CDRpart(cp)=DsGetCell(TYPE_BIGP);                 /* Get next part */
  216.     }
  217.     if (tmp)                                          /* result is negative ! */
  218.     {
  219.         cp=lp=fp;
  220.         TAGpart(cp)=TYPE_BIGN;
  221.         BIGpart(cp)=BIGBASE-BIGpart(cp);
  222.         while (ISTRUE(cp=CDRpart(cp)))
  223.             if (BIGpart(cp)=(BIGBASE-1)-BIGpart(cp))   /* take (base-1) cmpl. */
  224.                 lp=cp;           /* find most significant part with no zero's */
  225.     }
  226.     CDRpart(lp)=NIL;            /* all parts after lp are zero, wipe them */
  227.     return(fp);
  228. }
  229.  
  230.  
  231. /***************************************************************
  232. ** NAME:        big_muli
  233. ** SYNOPSIS:    CELP big_muli(ln,n2)
  234. **              LONG  ln;        Number 1
  235. **              CELP n2;        Number 2
  236. ** DESCRIPTION: big_muli multiplies a bignum with a long
  237. **              integer. This is a subfunction of bug_mul.
  238. ** RETURNS:     The product of ln and n2.
  239. ***************************************************************/
  240. #ifdef MSC
  241. STATIC ULONG inprod(a,b,c,d) 
  242. int a,b,c,d;
  243. {
  244.     return ((ULONG)a*(ULONG)b)+((ULONG)c*(ULONG)d);
  245. }
  246. #endif
  247.  
  248. CELP PASCAL big_muli(l,num)
  249. ULONG l;
  250. CELP num;
  251. {
  252.     CELP fp,cp;
  253.     USHORT Al,Ah,Bl,Bh;
  254.     ULONG t,overflow=0;
  255.  
  256.     Al=(USHORT)(l%10000L);
  257.     Ah=(USHORT)(l/10000L);
  258.     fp=cp=DsGetCell(TYPE_BIGP);
  259.     while (ISTRUE(num))
  260.     {                             
  261.         Bl=(USHORT)(BIGpart(num)%10000L);
  262.         Bh=(USHORT)(BIGpart(num)/10000L);
  263.         num=CDRpart(num);
  264.         t=inprod(Ah, Bl, Al, Bh);
  265.         BIGpart(cp)=overflow+inprod(Al, Bl, 10000, (USHORT)(t%10000L));
  266.         overflow=inprod(Ah, Bh, 1, (USHORT)(t/10000L));
  267.         if (BIGpart(cp)>=BIGBASE)
  268.         {                 
  269.             BIGpart(cp)-=BIGBASE;
  270.             overflow++;
  271.         }
  272.         if (ISNIL(num) && overflow==0) break;
  273.         cp=CDRpart(cp)=DsGetCell(TYPE_BIGP);
  274.     }
  275.     if (overflow) BIGpart(cp)=overflow;
  276.     return(fp);
  277. }
  278.  
  279.  
  280. /***************************************************************
  281. ** NAME:        big_free
  282. ** SYNOPSIS:    void big_free(p)
  283. **              CELP p;         A bignumber (or linked list)
  284. ** DESCRIPTION: big_free releases a bignumber to the free cell
  285. **              space.
  286. ** RETURNS:     void
  287. ***************************************************************/
  288. void PASCAL big_free(p)
  289. CELP p;
  290. {
  291.     CELP next;
  292.     while (ISTRUE(p))
  293.     {
  294.         next=CDRpart(p);                                /* point to next cell */
  295.         DsFreeCell(p);                                        /* release cell */
  296.         p=next;
  297.     }
  298. }
  299.  
  300.  
  301. /***************************************************************
  302. ** NAME:        big_mul
  303. ** SYNOPSIS:    CELP big_mul(n1,n2)
  304. **              CELP n1;        Number 1
  305. **              CELP n2;        Number 2
  306. ** DESCRIPTION: big_mul multiplies number1 with number2.
  307. ** RETURNS:     The product of n1 and n2.
  308. ***************************************************************/
  309. CELP PASCAL big_mul(n1,n2)
  310. CELP n1,n2;
  311. {
  312.     CELP pp,rp,sump,zerop1,zerop2;
  313.  
  314.     sump=big_muli(BIGpart(n1),n2);                               /* first hit */
  315.     if (n1=CDRpart(n1))
  316.     {
  317.         zerop1=zerop2=DsGetCell(TYPE_BIGP);
  318.         while (1)
  319.         {
  320.             pp=big_muli(BIGpart(n1),n2);             /* calculate temp result */
  321.             CDRpart(zerop2)=pp;                   /* chain a few zero's to it */
  322.             n1=CDRpart(n1);
  323.             rp=big_add(sump,zerop1);               /* add this to sum pointer */
  324.             CDRpart(zerop2)=NIL;           /* rest of chain is to be released */
  325.             big_free(pp);                              /* release temp result */
  326.             big_free(sump);                         /* release old sum result */
  327.             sump=rp;                                   /* point to new result */
  328.             if (ISNIL(n1)) break;                    /* end of the multiplyer */
  329.             zerop2=CDRpart(zerop2)=DsGetCell(TYPE_BIGP);  /* chain extra zero */
  330.         } 
  331.         big_free(zerop1);                               /* release all zero's */
  332.     }
  333.     return(sump);
  334. }
  335.  
  336.  
  337. /***************************************************************
  338. ** NAME:        big_len
  339. ** SYNOPSIS:    CELP big_len(number)
  340. **              CELP number;    a bignumber
  341. ** DESCRIPTION: big_len calculates the number of digits in a
  342. **              bignumber.
  343. ** RETURNS:     The length of number.
  344. ***************************************************************/
  345. int PASCAL big_len(p)
  346. CELP p;
  347. {
  348.     int l,i;
  349.     ULONG t;
  350.  
  351.     for (l=0; ISTRUE(CDRpart(p)); p=CDRpart(p)) l++;          /* count parts */
  352.     for (t=BIGpart(p),i=0;i<8 && t>=bigfactor[i];i++);  /* cnt digits in last */
  353.     return((l<<3)+i);                            /* 8 digits per part  \\ part */
  354. }
  355.  
  356.  
  357. /***************************************************************
  358. ** NAME:        big_mul10
  359. ** SYNOPSIS:    CELP big_mul10(n,n2)
  360. **              int  n;         a power of 10.
  361. **              CELP n2;        Number2
  362. ** DESCRIPTION: big_mul10 multiplies a bignum with the n-th
  363. **              power of 10. This is a subfunction of big_div.
  364. **              Instead of multipling with 10.00000000.00000000
  365. **              will number2 be multiplied by 10 and 16 digits
  366. **              are chained at the end.
  367. ** RETURNS:     The product of 10^n and n2.
  368. ***************************************************************/
  369. CELP PASCAL big_mul10(l,num)
  370. int l;
  371. CELP num;
  372. {
  373.     CELP tp;
  374.  
  375.     num = (l&0x7) ? big_muli(bigfactor[l&0x7],num) : big_cpy(num);
  376.     l>>=3;                             /* res = 10.00000000.00000000.00000000 */
  377.     while (l--)                                /* preprend 3 times a 00000000 */
  378.     {
  379.         tp=DsGetCell(TYPE_BIGP);                            /* Get a new cell */
  380.         CDRpart(tp)=num;                              /* chain in front of it */
  381.         num=tp;
  382.     }
  383.     return(num);
  384. }
  385.  
  386.  
  387. /***************************************************************
  388. ** NAME:        big_div
  389. ** SYNOPSIS:    CELP big_div(dd,div,prem)
  390. **              CELP dd;        Dividend
  391. **              CELP div;       Divider
  392. **              CELP *prem;     Pointer to remainder
  393. ** DESCRIPTION: big_div divides dd by div and returnes the
  394. **              quotient and the remainder is returned via the
  395. **              prem pointer.
  396. ** RETURNS:     The quotient
  397. ***************************************************************/
  398. CELP PASCAL big_div(dd,div,prem)
  399. CELP dd,div;
  400. CELP *prem;
  401. {
  402.     CELP rp,dp,rem;
  403.     int lquo,ldiv;
  404.     char *p,c;
  405.  
  406.     if (ISNIL(CDRpart(div)) && BIGpart(div)==0L) DSERROR(ERRDIV0,DsCons(dd,div));
  407.     p=BIGBUF;                                       /* point to result buffer */
  408.     rem=dd;            /* start condition:  QUOtient=DIVider*RESult+REMainder */
  409.     lquo=big_len(dd);
  410.     ldiv=big_len(div);
  411.     if (lquo-ldiv>=BIGMAX)
  412.         DSERROR(ERRBIGBIG,DsCons(dd,div));  /* result wil become much too big */
  413.     while (lquo>=ldiv)
  414.     {
  415.         dp=big_mul10(lquo-ldiv,div);                 /* div *= 10^(lquo-ldiv) */
  416.         c='0';                                             /* start with zero */
  417.         while (1)
  418.         {
  419.             rp=big_sub(rem,dp);                          /* substract divider */
  420.             if (TAGpart(rp)==TYPE_BIGN)               /* it became negative ? */
  421.                 break;                                                /* oops */
  422.             c++;
  423.             rem=rp;                                    /* store new remainder */
  424.         }
  425.         lquo--;                                 /* number of digits decreased */
  426.         *p++=c;                                               /* store result */
  427.         big_free(dp);                                 /* release temp divider */
  428.     }
  429.     *p='\0';                                                 /* end of string */
  430.     *prem=rem;                                /* return remainder via pointer */
  431.     return(DsStrBig(BIGBUF));
  432. }
  433.                                          
  434.  
  435. /***************************************************************
  436. ** NAME:        big_cmp
  437. ** SYNOPSIS:    CELP big_cmp(n1,n2)
  438. **              CELP n1;        Number 1
  439. **              CELP n2;        Number 2
  440. ** DESCRIPTION: big_cmp compares number1 with number2.
  441. **              It actually performs a subtraction without
  442. **              keeping the result.
  443. ** RETURNS:     -1 when n1<n2, 0 when n1=2n, and 1 when n1>n2.
  444. ***************************************************************/
  445. int PASCAL big_cmp(n1,n2)
  446. CELP n1,n2;
  447. {
  448.     LONG tmp=0L, ored=0L;
  449.  
  450.     while (ISTRUE(n1) || ISTRUE(n2))
  451.     {
  452.         if (ISTRUE(n1))
  453.         {
  454.             tmp+=BIGpart(n1);
  455.             n1=CDRpart(n1);
  456.         }
  457.         if (ISTRUE(n2))
  458.         {
  459.             tmp-=BIGpart(n2);
  460.             n2=CDRpart(n2);
  461.         }
  462.         ored |= tmp;                    /* ored is 0 when all digits are zero */
  463.         tmp = (tmp<0L) ? -1L : 0L;                   /* borrow from next part */
  464.     }
  465.     return tmp ? -1 : (ored==0) ? 0 : 1;
  466. }
  467.  
  468.  
  469. /***************************************************************
  470. ** NAME:        big_adds
  471. ** SYNOPSIS:    CELP big_adds(n1,n2)
  472. **              CELP n1;        Number 1
  473. **              CELP n2;        Number 2
  474. ** DESCRIPTION: big_adds adds two numbers, but checks the signs
  475. **              first.
  476. ** RETURNS:     The sum of n1 and n2.
  477. ***************************************************************/
  478. CELP PASCAL big_adds(n1,n2)
  479. CELP n1,n2;
  480. {
  481.     if (TAGpart(n1)==TYPE_BIGP)         /* number 1 positive ? */
  482.         return (TAGpart(n2)==TYPE_BIGP) /* number 2 also positive ? */
  483.                ? big_add(n1,n2)         /* n1+n2 */
  484.                : big_sub(n1,n2);        /* calc n1-n2  instead of n1+-n2 */
  485.     else
  486.     {                                  /* number 1 is negative */
  487.         if (TAGpart(n2)==TYPE_BIGP)    /* number 2 positive ? */
  488.             return big_sub(n2,n1);     /* calc n2-n1 instead of -n1+n2 */
  489.         else
  490.         {
  491.             CELP res;
  492.             res = big_add(n1,n2);      /* calc -(n1+n2)  instead of -n1+-n2 */
  493.             TAGpart(res) = TYPE_BIGN;
  494.             return res;
  495.         }
  496.     }
  497. }
  498.  
  499.  
  500. /***************************************************************
  501. ** NAME:        big_subs
  502. ** SYNOPSIS:    CELP big_subs(n1,n2)
  503. **              CELP n1;        Number 1
  504. **              CELP n2;        Number 2
  505. ** DESCRIPTION: big_subs adds two numbers, but checks the signs
  506. **              first.
  507. ** RETURNS:     The sum of n1 and n2.
  508. ***************************************************************/
  509. CELP PASCAL big_subs(n1,n2)
  510. CELP n1,n2;
  511. {
  512.     if (TAGpart(n1)==TYPE_BIGP)         /* number 1 positive ? */
  513.         return (TAGpart(n2)==TYPE_BIGP) /* number 2 also positive ? */
  514.                ? big_sub(n1,n2)         /* n1-n2 */
  515.                : big_add(n1,n2);        /* calc n1+n2  instead of n1--n2 */
  516.     else
  517.     {
  518.         if (TAGpart(n2)==TYPE_BIGP)     /* positive ? */
  519.         {
  520.             CELP res;
  521.             res=big_add(n1,n2);         /* perform -(n1+n2) instead of -n1-n2 */
  522.             TAGpart(res)=TYPE_BIGN;     /* make result negative */
  523.             return(res);
  524.         }
  525.         else
  526.             return big_sub(n2,n1);      /* perform n2-n1  instead of -n1--n2 */
  527.     }
  528. }
  529.  
  530.  
  531. /***************************************************************
  532. ** NAME:        big_muls
  533. ** SYNOPSIS:    CELP big_muls(n1,n2)
  534. **              CELP n1;        Number 1
  535. **              CELP n2;        Number 2
  536. ** DESCRIPTION: big_muls adds two numbers, but checks the signs.
  537. ** RETURNS:     The sum of n1 and n2.
  538. ***************************************************************/
  539. CELP PASCAL big_muls(n1,n2)
  540. CELP n1,n2;
  541. {
  542.     CELP res = big_mul(n1,n2);
  543.     if (TAGpart(n1)!=TAGpart(n2))      /* Unequal signs so result is negative */
  544.         TAGpart(res)=TYPE_BIGN;
  545.     return res;
  546. }
  547.  
  548.  
  549. /***************************************************************
  550. ** NAME:        big_divs
  551. ** SYNOPSIS:    CELP PASCAL big_divs(quo, div, prem)  
  552. **              CELP quo,div;                         
  553. **              CELP *prem;                           
  554. ** DESCRIPTION: big_divs adds two numbers, but checks the signs
  555. **              first.
  556. ** RETURNS:     the quotient, remainder is in <prem>.
  557. ***************************************************************/
  558.                                       /* +13/+3 =  4,  1 : +13 = +3 *  4 +  1 */
  559. CELP PASCAL big_divs(quo, div, prem)  /* +13/-3 = -4,  1 : +13 = -3 * -4 +  1 */
  560. CELP quo,div;                         /* -13/+3 = -4, -1 : -13 = +3 * -4 + -1 */
  561. CELP *prem;                           /* -13/-3 =  4, -1 : -13 = -3 *  4 + -1 */
  562. {                                    
  563.     CELP res=big_div(quo,div,prem);                                  /* n1/n2 */
  564.     TAGpart(*prem)=TAGpart(quo);
  565.     if (TAGpart(quo)!=TAGpart(div))    /* Unequal signs so result is negative */
  566.         TAGpart(res)=TYPE_BIGN;
  567.     return res;
  568. }
  569.  
  570.  
  571. /***************************************************************
  572. ** NAME:        int2big
  573. ** SYNOPSIS:    CELP int2big(p)
  574. **              CELP p;         cell with integer value
  575. ** DESCRIPTION: int2big converts a long integer to a bignumber.
  576. ** RETURNS:     The bignumber with value n.
  577. ***************************************************************/
  578. CELP PASCAL int2big(p)
  579. CELP p;
  580. {
  581.     LONG val=INTpart(p);
  582.  
  583.     p=DsGetCell(TYPE_BIGP);
  584.     if (val<0)
  585.     {
  586.         TAGpart(p)=TYPE_BIGN;
  587.         val=-val;
  588.     }
  589.     if (val<BIGBASE)
  590.         BIGpart(p)=val;
  591.     else
  592.     {
  593.         CELP np=DsGetCell(TYPE_BIGP);
  594.         BIGpart(np)=val/BIGBASE;      /* quotient */
  595.         CDRpart(p)=np;
  596.         BIGpart(p)=val%BIGBASE;     /* remainder */
  597.     }
  598.     return(p);
  599. }
  600.  
  601.  
  602. /***************************************************************
  603. ** NAME:        big2int
  604. ** SYNOPSIS:    CELP big2int(p)
  605. **              CELP p;
  606. ** DESCRIPTION: Converts if possible a bignum to an integer.
  607. ** RETURNS:     the result.
  608. ***************************************************************/
  609. CELP PASCAL big2int(p)
  610. CELP p;
  611. {
  612.     if (ISTRUE(CDRpart(p))) return p;
  613.  
  614.     {
  615.         CELP item=DsGetCell(TYPE_INT);
  616.         if (TAGpart(p)==TYPE_BIGN)
  617.             INTpart(item)= -INTpart(p);
  618.         else
  619.             INTpart(item)= INTpart(p);
  620.         return item;
  621.     }
  622. }
  623.  
  624.  
  625. /***************************************************************
  626. ** NAME:        real2big
  627. ** SYNOPSIS:    CELP real2big(p)
  628. **              CELP p;        real value
  629. ** DESCRIPTION: real2big converts a REAL number to a bignumber.
  630. ** RETURNS:     The bignumber with value n.
  631. ***************************************************************/
  632. CELP PASCAL real2big(p)
  633. CELP p;                   /* 1.85e30 => 1850000000000000000000000000000       */
  634. {                              /*       1234567890123450000000000000000. 30   */
  635.     SHORT digits,zeros;        /*      012345678901234560000000.         22   */
  636.     CELP fp;                   /*      ^       ^       ^       12345678       */
  637.     char fmt[10],buf[25];
  638.     REAL val;
  639.     int sign=1;
  640.  
  641.     val=FLTpart(p);
  642.     if (val<0.0)
  643.     {
  644.         val-=val;
  645.     sign=-1;
  646.     }
  647.     digits=(int)log10(val);
  648.     zeros=0;
  649.     if (digits>15)
  650.     {
  651.     zeros=digits-15;
  652.     digits=15;
  653.     }
  654.     sprintf(fmt,"%%%d.0f",digits+1);
  655.     sprintf(buf,fmt,val);
  656.     fp = big_mul10(zeros, DsStrBig(buf));
  657.     if (sign<0) TAGpart(fp)=TYPE_BIGN;
  658.     return(fp);
  659. }
  660.  
  661.  
  662. /***************************************************************
  663. ** NAME:        big2real
  664. ** SYNOPSIS:    REAL big2real(p)
  665. **              CELP p;         a bignumber.
  666. ** DESCRIPTION: big2real converts a bignumber to a REAL number.
  667. **              At most three (most significant) parts are
  668. **              converted.
  669. ** RETURNS:     a REAL number with value n.
  670. ***************************************************************/
  671. REAL PASCAL big2real(p)
  672. CELP p;                   
  673. {                         
  674.     REAL fres;
  675.  
  676.     if (ISNIL(p)) return 0.0;
  677.     if (ISNIL(CDRpart(p)))                                         /* simple? */
  678.         fres=(REAL)BIGpart(p);
  679.     else
  680.     {
  681.         CELP cp;              
  682.         int f,l,digits;
  683.  
  684.         f=digits=0;
  685.         cp=p;
  686.         l=(SHORT)DsLength(p);
  687. #ifndef MATHTRAP
  688.         if (l>308) DSERROR(ERROVRFLW,p);
  689. #endif
  690.         while (l>3)            /* if more than 3 cells skip least significant */
  691.         {
  692.             digits+=8;l--;
  693.             cp=CDRpart(cp);
  694.         }
  695.         fres = (REAL)BIGpart(cp);
  696.         while (l>1)
  697.         {
  698.             cp=CDRpart(cp);
  699.             fres += ffactor[f++]*(REAL)BIGpart(cp);l--;
  700.         }
  701.         if (digits) fres *= pow(10.0,(REAL)digits);
  702.     }
  703.     if (TAG(p)==TYPE_BIGN) fres = -fres;
  704.     return(fres);
  705. }
  706.  
  707.  
  708. /***************************************************************
  709. ** NAME:        makebig
  710. ** SYNOPSIS:    CELP makebig(arg)
  711. **              CELP arg;       Scheme argument.
  712. ** DESCRIPTION: makebig converts a argument to a bignumber.
  713. ** RETURNS:     The bignumber with value n.
  714. ***************************************************************/
  715. CELP PASCAL makebig(arg)
  716. CELP arg;
  717. {
  718.     switch(DsGetNTag(arg))
  719.     {
  720.     case TYPE_INT: return int2big(arg); 
  721.     case TYPE_FLT: return real2big(arg);
  722.     }
  723.     return arg;
  724. }
  725.  
  726.  
  727. /***************************************************************
  728. ** NAME:        makeflo2
  729. ** SYNOPSIS:    REAL makeflo2(arg, tag)
  730. **              CELP arg;       Scheme argument.
  731. **              USHORT tag;
  732. ** DESCRIPTION: makeflo2 converts a argument to a floating point
  733. ** RETURNS:     The REAL number with value n.
  734. ***************************************************************/
  735. REAL PASCAL makeflo2(arg,tag)
  736. CELP arg;
  737. int tag;
  738. {
  739.     switch(tag)
  740.     {
  741.     case TYPE_INT: return (REAL)CELINT(arg); 
  742.     case TYPE_FLT: return CELFLT(arg);       
  743.     }
  744.     return big2real(arg);     
  745. }
  746.  
  747.  
  748.  
  749.  
  750.  
  751.  
  752.  
  753.  
  754.  
  755.  
  756.  
  757.  
  758.  
  759.  
  760.  
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  
  768.                 
  769.