home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schstr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  23.3 KB  |  881 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHSTR.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       88/10/12
  9. **
  10. ** DESCRIPTION: All the Scheme STR functions are defined here.
  11. **              If the format of the cel is changed only this
  12. **              module needs to be changed.
  13. ***********************************************************************
  14. ** CHANGES INFORMATION **
  15. *************************
  16. ** REVISION:    $Revision:   1.0  $
  17. ** CHANGER:     $Author:   JAN  $
  18. ** WORKFILE:    $Workfile:   schbuf.c  $
  19. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHSTR.C_V  $
  20. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHSTR.C_V  $
  21. **
  22. **                 Rev 1.0   12 Oct 1989 11:45:58   JAN
  23. **              Initial revision.
  24. **********************************************************************/
  25. #include "schinc.h"
  26. #include "schdef.h"
  27.  
  28. #define PROTBIT 0x2
  29. #define BUFGRAN 4
  30.  
  31. STATIC char * PASCAL DsGetBuf   __((int len));
  32. STATIC CELP PASCAL DsGetVec __((int n));
  33. STATIC CELP PASCAL DsBufUsed __((void));
  34. STATIC CELP CDECL Ds_makestr    __((int n, CELP args));
  35. STATIC CELP CDECL Ds_string     __((int n, CELP args));
  36. STATIC CELP CDECL Ds_strlen     __((CELP q));
  37. STATIC CELP CDECL Ds_strref     __((CELP str, CELP pos));
  38. STATIC CELP CDECL Ds_strset     __((CELP str, CELP pos, CELP chr));
  39. STATIC CELP CDECL Ds_streq      __((CELP str1, CELP str2));
  40. STATIC CELP CDECL Ds_strlt      __((CELP str1, CELP str2));
  41. STATIC CELP CDECL Ds_strle      __((CELP str1, CELP str2));
  42. STATIC CELP CDECL Ds_strge      __((CELP str1, CELP str2));
  43. STATIC CELP CDECL Ds_strgt      __((CELP str1, CELP str2));
  44. STATIC CELP CDECL Ds_streqci    __((CELP str1, CELP str2));
  45. STATIC CELP CDECL Ds_strltci    __((CELP str1, CELP str2));
  46. STATIC CELP CDECL Ds_strleci    __((CELP str1, CELP str2));
  47. STATIC CELP CDECL Ds_strgeci    __((CELP str1, CELP str2));
  48. STATIC CELP CDECL Ds_strgtci    __((CELP str1, CELP str2));
  49. STATIC CELP CDECL Ds_strsub     __((CELP str, CELP pos, CELP cnt));
  50. STATIC CELP CDECL Ds_strappend  __((CELP p, CELP q));
  51. STATIC CELP CDECL Ds_strlist    __((CELP p));
  52. STATIC CELP CDECL Ds_liststr    __((CELP p));
  53. STATIC CELP CDECL Ds_strfill    __((CELP p, CELP q));
  54. STATIC CELP CDECL Ds_strcopy    __((CELP p));
  55.  
  56. STATIC CELP CDECL Ds_intchar    __((CELP p));
  57. STATIC CELP CDECL Ds_charint    __((CELP p));
  58. STATIC CELP CDECL Ds_charup     __((CELP p));
  59. STATIC CELP CDECL Ds_chardown   __((CELP p));
  60. STATIC CELP CDECL Ds_intstr     __((int n, CELP p));
  61. STATIC CELP CDECL Ds_strint     __((int n, CELP p));
  62. STATIC CELP CDECL Ds_symstr     __((CELP q));
  63. STATIC CELP CDECL Ds_strsym     __((CELP q));
  64. STATIC CELP CDECL Ds_makevec    __((int n, CELP a));
  65. STATIC CELP CDECL Ds_vector     __((int n, CELP l));
  66. STATIC CELP CDECL Ds_veclen     __((CELP v));
  67. STATIC CELP CDECL Ds_vecref     __((CELP v, CELP i));
  68. STATIC CELP CDECL Ds_vecset     __((CELP v, CELP i, CELP a));
  69. STATIC CELP CDECL Ds_veclst     __((CELP v));
  70. STATIC CELP CDECL Ds_vecfill    __((CELP p, CELP q));
  71. #ifdef DEBUG
  72. STATIC CELP CDECL Ds_dumpstr    __((void));
  73. #endif
  74.  
  75. STATIC
  76. EXTDEF StringFunctions[] =
  77. {
  78.     /* Section 6.6 of Revised3.99 Scheme */
  79.     {"INTEGER->CHAR",  (EXTPROC)Ds_intchar,   1, TYPE_INT},
  80.     {"CHAR->INTEGER",  (EXTPROC)Ds_charint,   1, TYPE_CHR},
  81.     {"CHAR-UPCASE",    (EXTPROC)Ds_charup,    1, TYPE_CHR},
  82.     {"CHAR-DOWNCASE",  (EXTPROC)Ds_chardown,  1, TYPE_CHR},
  83.     /* remaining functions (the xxx? procedures) are in schprc.h */
  84.  
  85.     /* Section 6.7 of Revised3.99 Scheme */
  86.     {"MAKE-STRING",    (EXTPROC)Ds_makestr,  -1},
  87.     {"STRING",         (EXTPROC)Ds_string,  -1},
  88.     {"STRING-LENGTH",  (EXTPROC)Ds_strlen,    1, TYPE_STR},
  89.     {"STRING-REF",     (EXTPROC)Ds_strref,    2, TYPE_STR, TYPE_INT},
  90.     {"STRING-SET!",    (EXTPROC)Ds_strset,    3, TYPE_STR, TYPE_INT, TYPE_CHR},
  91.     {"STRING=?",       (EXTPROC)Ds_streq,     2, TYPE_STR, TYPE_STR},
  92.     {"STRING<?",       (EXTPROC)Ds_strlt,     2, TYPE_STR, TYPE_STR},
  93.     {"STRING>?",       (EXTPROC)Ds_strgt,     2, TYPE_STR, TYPE_STR},
  94.     {"STRING<=?",      (EXTPROC)Ds_strle,     2, TYPE_STR, TYPE_STR},
  95.     {"STRING>=?",      (EXTPROC)Ds_strge,     2, TYPE_STR, TYPE_STR},
  96.     {"STRING-CI=?",    (EXTPROC)Ds_streqci,   2, TYPE_STR, TYPE_STR},
  97.     {"STRING-CI<?",    (EXTPROC)Ds_strltci,   2, TYPE_STR, TYPE_STR},
  98.     {"STRING-CI>?",    (EXTPROC)Ds_strgtci,   2, TYPE_STR, TYPE_STR},
  99.     {"STRING-CI<=?",   (EXTPROC)Ds_strleci,   2, TYPE_STR, TYPE_STR},
  100.     {"STRING-CI>=?",   (EXTPROC)Ds_strgeci,   2, TYPE_STR, TYPE_STR},
  101.     {"SUBSTRING",      (EXTPROC)Ds_strsub,    3, TYPE_STR, TYPE_INT, TYPE_INT},
  102.     {"STRING-APPEND",  (EXTPROC)Ds_strappend, 2, TYPE_STR, TYPE_STR},
  103.     {"STRING->LIST",   (EXTPROC)Ds_strlist,   1, TYPE_STR},
  104.     {"LIST->STRING",   (EXTPROC)Ds_liststr,   1, 0},
  105.     {"STRING-FILL!",   (EXTPROC)Ds_strfill,   2, TYPE_STR, TYPE_CHR},
  106.     {"STRING-COPY",    (EXTPROC)Ds_strcopy,   1, TYPE_STR},
  107.     {"NUMBER->STRING", (EXTPROC)Ds_intstr,   -1, 0},
  108.     {"STRING->NUMBER", (EXTPROC)Ds_strint,   -1, 0},
  109.  
  110.     {"STRING->SYMBOL", (EXTPROC)Ds_strsym,    1, TYPE_STR},
  111.     {"SYMBOL->STRING", (EXTPROC)Ds_symstr,    1, 0},
  112.  
  113.     /* Section 6.8 of Revised3.99 Scheme */
  114.     {"MAKE-VECTOR",    (EXTPROC)Ds_makevec,  -1, 0},
  115.     {"VECTOR",         (EXTPROC)Ds_vector,   -1, 0},
  116.     {"VECTOR-LENGTH",  (EXTPROC)Ds_veclen,    1, TYPE_VEC},
  117.     {"VECTOR-REF",     (EXTPROC)Ds_vecref,    2, TYPE_VEC, TYPE_INT},
  118.     {"VECTOR-SET!",    (EXTPROC)Ds_vecset,    3, TYPE_VEC, TYPE_INT, 0},
  119.     {"VECTOR->LIST",   (EXTPROC)Ds_veclst,    1, TYPE_VEC},
  120.     {"LIST->VECTOR",   (EXTPROC)Ds_lstvec,    1, 0},         
  121.     {"VECTOR-FILL!",   (EXTPROC)Ds_vecfill,   2, TYPE_STR, TYPE_CHR},
  122. #ifdef DEBUG
  123.     {"DUMP-STRINGS",   (EXTPROC)Ds_dumpstr,   0},
  124. #endif
  125.     {NULL}
  126. };
  127.  
  128.  
  129. /***************************************************************
  130. ** NAME:        DsIniBuf
  131. ** SYNOPSIS:    void DsIniBuf(size)
  132. **              int size;       size of new buffer segment.
  133. ** DESCRIPTION: Allocates and initializes a new buffer segment.
  134. ** RETURNS:     void
  135. ***************************************************************/
  136. void PASCAL DsIniBuf(size)
  137. int size;
  138. {
  139.     char *buffer;
  140.     CELP newstr;
  141.  
  142.     if (size>0)
  143.     {
  144.         if (size%BUFGRAN) size+=BUFGRAN-(size%BUFGRAN);
  145.         GETMEM(buffer,char,size,"Buffer Space");
  146.         newstr=DsGetCell(TYPE_STR);
  147.         PROTECT(newstr);             
  148.         STRPpart(newstr)=buffer;
  149.         STRLpart(newstr)=size;
  150.         GLOB(freestr)=DsCons(newstr,GLOB(freestr)); 
  151.         PROTECT(GLOB(freestr));
  152.  
  153.         newstr=DsGetCell(TYPE_STR);
  154.         PROTECT(newstr); 
  155.         STRPpart(newstr)=buffer;
  156.         STRLpart(newstr)=size;
  157.         GLOB(allostr)=DsCons(newstr,GLOB(allostr));
  158.         PROTECT(GLOB(allostr));              /* This descriptor is protected! */
  159.  
  160.         GLOB(strspace)+=(DWORD)size;
  161.         GLOB(strsize)+=(DWORD)size;
  162.     }
  163.     DsFuncDef(StringFunctions); /* define string functions */
  164. }
  165.  
  166.  
  167. /***************************************************************
  168. ** NAME:        DsGetBuf
  169. ** SYNOPSIS:    char * DsGetBuf(len)
  170. **              int len;    size of new string (including '\0')
  171. ** DESCRIPTION: DsGetBuf allocates a piece of string space to
  172. **              store a string.
  173. ** RETURNS:     A pointer to a string space.
  174. ***************************************************************/
  175. STATIC char * PASCAL DsGetBuf(len)
  176. int len;
  177. {
  178.     CELP desc,p,pp;
  179.     char *str;
  180.  
  181.     if (len%BUFGRAN) len+=BUFGRAN-(len%BUFGRAN);
  182.     len+=sizeof(int);                         /* Reserve room for real length */
  183.     pp=NIL;                 /* search for empty spot big enough to hold 'str' */
  184.     for (p=GLOB(freestr); ISTRUE(p); p=CDRpart(p))
  185.     {
  186.         if (STRLpart(CARpart(p))>=len) break;     /* This block is big enough */
  187.         pp=p;
  188.     }
  189.     if (ISNIL(p))                                            /* no fit found! */
  190.         DSVERROR(ERRMEM);             /* string space empty or too fragmented */
  191.     GLOB(strspace)-=len;             /* spot with len characters now reserved */
  192.     if (GLOB(strspace)<256)             /* only a few chars left in strspace! */
  193.         GLOB(GCflag)=1; /* G.C. asap (defragment if after GC still fragmented */
  194.     desc=CARpart(p);
  195.     str=STRPpart(desc);                      /* Pointer to fresh string space */
  196.     STRLpart(desc)-=len;
  197.     if (STRLpart(desc))                          /* remainder is still usable */
  198.         STRPpart(desc)+=len;
  199.     else                                      /* This free block is empty now */
  200.     {   
  201.         if (ISNIL(pp))
  202.             GLOB(freestr)=CDRpart(p);        /* remove string desc. from list */
  203.         else
  204.             CDRpart(pp)=CDRpart(p);      /* remove string desc. from freelist */
  205.         DsFreeCell(desc);                           /* remove this descriptor */
  206.         DsFreeCell(p);                            /* Release this linker cell */
  207.     }
  208.     *(int *)str=len;        /* Store real length */
  209.     return(str+sizeof(int));
  210. }
  211.  
  212.  
  213. /***************************************************************
  214. ** NAME:        DsFreeBuf
  215. ** SYNOPSIS:    void DsFreeBuf(buf);
  216. **              char *buf;
  217. ** DESCRIPTION: DsFreeBuf frees the occupied space by the
  218. **              buffer, by linking it to the freestr list.
  219. **              It searches for a free block connected to it 
  220. **              and extents that block so that it contains the
  221. **              the new block. If there are two free blocks
  222. **              connected (head and tail) then one freeblock
  223. **              entry is destroyed and the other is extended.
  224. **              This will defragment the string space after
  225. **              a garbage collect.
  226. ** RETURNS:     void
  227. ***************************************************************/
  228. void PASCAL DsFreeBuf(str)
  229. char *str;
  230. {
  231.     CELP q, pr, bp=NIL, pp=NIL;
  232.     int  chain=0, len;
  233.     char *endstr;
  234.  
  235.     str-=sizeof(int);
  236.     len=*(int *)str; 
  237.     endstr=str+len;
  238.  
  239.     GLOB(strspace)+=len;
  240.     for (q=GLOB(freestr); q; q=CDRpart(q))
  241.     {
  242.         pr=CARpart(q);
  243.         if (!(chain&1) && (STRPpart(pr)+STRLpart(pr)==str))
  244.         {                   /* Backchain i.e. chain freecell before str to it */
  245.             if (!chain) bp=pr;            /* pointer to be changed descriptor */
  246.             chain |= 1;                                  /* Performed a chain */
  247.             str=STRPpart(pr);              /* try to chain this extended part */
  248.             len+=STRLpart(pr);            /* New length of part to be chained */
  249.         }
  250.         else if (!(chain&2) && (STRPpart(pr)==endstr))
  251.         {
  252.             if (!chain) bp=pr;            /* pointer to be changed descriptor */
  253.             chain |= 2;
  254.             len+=STRLpart(pr);            /* New length of part to be chained */
  255.         }
  256.         if (chain==3)                                        /* Both chained! */
  257.         {                                  /* Discard second changed freecell */
  258.             if (ISTRUE(pp))
  259.                 CDRpart(pp)=CDRpart(q);
  260.             else
  261.                 GLOB(freestr)=CDRpart(q);
  262.             DsFreeCell(pr);
  263.             DsFreeCell(q);     /* We can discard one link cell with its desc. */
  264.             break;            /* Can't chain more so we break the search loop */
  265.         }
  266.         pp=q;
  267.     }
  268.     if (!chain)                        /* not chained! => prepend to freelist */
  269.     {
  270.         bp=DsGetCell(TYPE_STR);
  271.         STRPpart(bp)=str;
  272.         STRLpart(bp)=len;
  273.         PROTECT(bp);
  274.         GLOB(freestr)=DsCons(bp,GLOB(freestr));     /* Add it to the freelist */
  275.         PROTECT(GLOB(freestr));        /* Freestr linklist cell are protected */
  276.     }
  277.     else
  278.     {
  279.         STRPpart(bp)=str;               /* change entries of merged freecell. */
  280.         STRLpart(bp)=len;
  281.     }
  282. }
  283.  
  284.  
  285. /***************************************************************
  286. ** NAME:        DsFragmented
  287. ** SYNOPSIS:    int PASCAL DsFragmented();
  288. ** DESCRIPTION: Checks if the string space if fragmented.
  289. **              It is fragmented unless there is at least one 
  290. **              big free block.
  291. ** RETURNS:     TRUE, when string space if too much fragmented.
  292. **              FALSE, string space is clean enough.
  293. ***************************************************************/
  294. int PASCAL DsFragmented()
  295. {
  296.     CELP p;
  297.  
  298.     if (ISNIL(CDRpart(GLOB(freestr)))) return FALSE;
  299.     for (p=GLOB(freestr); ISTRUE(p); p=CDRpart(p))
  300.         if (STRLpart(CARpart(p))>256)  
  301.             return FALSE;
  302.     return TRUE;
  303. }
  304.  
  305.  
  306. STATIC CELP PASCAL DsBufUsed()
  307. {
  308.     CELP used,p,q;
  309.     int i;
  310.  
  311.     DSGCmessage(GCrun);                                /* we're still running */
  312.     used=NIL;
  313.     for (p=GLOB(fblk); ISTRUE(p); p=CDRpart(p)) 
  314.     {
  315.         q=p;
  316.         for (i=(int)CARIpart(p)-1;i>0;i--)
  317.     {
  318.         q++;
  319.             if (TAGpart(q)==TYPE_STR || TAGpart(q)==TYPE_VEC)
  320.                 if (!(GCFpart(q)&PROTBIT))    /* Not a protected descriptor */
  321.                     used=DsCons(q,used);  /* Chain it to list of used strings */
  322.         }
  323.     }
  324.     return used;
  325. }
  326.  
  327.  
  328. void PASCAL DsBufDefrag()
  329. {
  330.     CELP p, q, used;
  331.     FILE *fp;
  332.  
  333.     used=DsBufUsed();
  334.     DSGCmessage(GCrun);                                /* we're still running */
  335.     fp=tmpfile();
  336.     for (q=used; ISTRUE(q); q=CDRpart(q))    
  337.     {
  338.         p=CARpart(q);
  339.         fwrite(STRPpart(p), STRLpart(p), 1, fp); /* write buffer into tmpfile */
  340.         DsFreeBuf(STRPpart(p));                             /* Release buffer */
  341.     }                                   /* All used space should be free now! */
  342.     fseek(fp,0L,SEEK_SET);
  343.     DSGCmessage(GCrun);                                /* we're still running */
  344.     for (q=used; ISTRUE(q); q=p)    
  345.     {
  346.         p=CARpart(q);
  347.         STRPpart(p)=DsGetBuf(STRLpart(p));          /* get fresh buffer space */
  348.         fread(STRPpart(p), STRLpart(p), 1, fp);      /* read buffer data back */
  349.         p=CDRpart(q);
  350.         DsFreeCell(q);
  351.     }
  352.     fclose(fp); 
  353. }
  354.  
  355.  
  356. /***************************************************************
  357. ** NAME:        DsStrCell
  358. ** SYNOPSIS:    CELP DsStrCell(str)
  359. **              char *str;      pointer to input string
  360. ** DESCRIPTION: Strcel converts a C string into a SCHEME string.
  361. ** RETURNS:     A pointer to a SCHEME string.
  362. ***************************************************************/
  363. CELP PASCAL DsStrCell(str)
  364. CONST char *str;
  365. {
  366.     CELP p;
  367.     
  368.     p=DsGetStr(strlen(str));
  369.     strncpy(STRPpart(p),str,STRLpart(p));           /* fill it with its value */
  370.     return(p);
  371. }
  372.  
  373.  
  374. /***************************************************************
  375. ** NAME:        DsCmpVector
  376. ** SYNOPSIS:    CELP DsCmpVector(a1,a2)
  377. **              CELP a1, a2; the two vectors to compare.
  378. ** DESCRIPTION: Compares two vectors.
  379. ** RETURNS:     Q_true when equal, NIL otherwise.
  380. ***************************************************************/
  381. CELP PASCAL DsCmpVector(a1,a2)
  382. CELP a1,a2;
  383. {
  384.     CELP *v1, *v2;
  385.     register int i;
  386.  
  387.     TYPCHECK(a1,TYPE_VEC);
  388.     TYPCHECK(a2,TYPE_VEC);
  389.     i=VECLpart(a1);
  390.     if (i!=VECLpart(a2)) return NIL;
  391.     v1=VECPpart(a1);
  392.     v2=VECPpart(a2);
  393.     while (i-->0)
  394.     if (ISNIL(DsCompare(*v1++,*v2++))) 
  395.         return NIL;
  396.     return Q_true;
  397. }
  398.  
  399.  
  400. STATIC
  401. CELP Ds_makestr(n,args)
  402. int n;
  403. CELP args;
  404. {
  405.     if (n==2)
  406.     {
  407.         CELP q=CDRpart(args);
  408.         TYPCHECK(q,TYPE_CHR);
  409.         args=CARpart(args);
  410.         TYPCHECK(args,TYPE_INT);
  411.         return Ds_strfill(DsGetStr((int)INTpart(args)),q);
  412.     }
  413.     TYPCHECK(args,TYPE_INT);
  414.     return DsGetStr((int)INTpart(args));
  415. }
  416.  
  417. STATIC
  418. CELP Ds_string(n,args)
  419. int n;
  420. CELP args;
  421. {
  422.     CELP p,c;
  423.     int i;
  424.     
  425.     p=DsGetStr(n);
  426.     for (i=0;i<n;i++)
  427.     {
  428.         if (i) args=CDRpart(args);
  429.         c=CARpart(args);
  430.         TYPCHECK(c,TYPE_CHR);
  431.         STRPpart(p)[i]=(char)CHRpart(c);
  432.     }
  433.     STRPpart(p)[n]='\0';
  434.     return p;
  435. }
  436.  
  437.  
  438. STATIC
  439. CELP Ds_strfill(p,q)
  440. CELP p,q;
  441. {
  442.     int i;
  443.     for (i=0;i<STRLpart(p);i++)
  444.         STRPpart(p)[i]=(char)CHRpart(q);
  445.     return p;
  446. }
  447.  
  448. STATIC
  449. CELP Ds_strcopy(p)
  450. CELP p;
  451. {
  452.     CELP q=DsGetStr(STRLpart(p));
  453.     strncpy(STRPpart(q),STRPpart(p),STRLpart(p));
  454.     return q;
  455. }
  456.  
  457. STATIC
  458. CELP Ds_charint(arg)
  459. CELP arg;
  460. {
  461.     CELP p;
  462.     INTCEL(p,CELCHR(arg)); return p;
  463. }
  464.  
  465.  
  466. STATIC CELP Ds_intchar(arg)
  467. CELP arg;
  468. {
  469.     return DSCHRCEL((char)CELINT(arg));
  470. }
  471.  
  472. STATIC CELP Ds_charup(arg)
  473. CELP arg;
  474. {
  475.     return DSCHRCEL(toupper((char)CHRpart(arg)));
  476. }
  477.  
  478. STATIC CELP Ds_chardown(arg)
  479. CELP arg;
  480. {
  481.     return DSCHRCEL(tolower((char)CHRpart(arg)));
  482. }
  483.  
  484. STATIC CELP Ds_strint(n, arg)
  485. int n;
  486. CELP arg;
  487. {
  488.     int base;
  489.     switch(n)
  490.     {
  491.     case 1:base=10;break;
  492.     case 2:TYPCHECK(CDRpart(arg),TYPE_INT);
  493.        base=INTpart(CDRpart(arg));
  494.        arg=CARpart(arg);
  495.        break;
  496.     default:DSERROR(ERRARC,arg);
  497.     }
  498.     TYPCHECK(arg,TYPE_STR);
  499.     return DsStrNumber(STRPpart(arg),base);
  500. }
  501.  
  502.  
  503. STATIC CELP Ds_intstr(n,arg)
  504. int n;
  505. CELP arg;
  506. {
  507.     int base;
  508.     switch(n)
  509.     {
  510.     case 1:base=10;break;
  511.     case 2:TYPCHECK(CDRpart(arg),TYPE_INT);
  512.        base=INTpart(CDRpart(arg));
  513.        arg=CARpart(arg);
  514.        break;
  515.     default:DSERROR(ERRARC,arg);
  516.     }
  517.     switch(TAG(arg))
  518.     {
  519.     case TYPE_INT: 
  520.     if (base<2 || base>36) DSERROR(ERRARC,arg);
  521.         return DsStrCell(ltostr(INTpart(arg),base));
  522.  
  523.     case TYPE_BIGN:
  524.     case TYPE_BIGP:
  525.     if (base!=10) DSERROR(ERRBASE,arg);
  526.         return DsStrCell(DsBigStr(arg));
  527.  
  528.     case TYPE_FLT:
  529.     if (base!=10) DSERROR(ERRBASE,arg);
  530.         sprintf(BIGBUF,"%g",FLTpart(arg));
  531.         return DsStrCell(BIGBUF);
  532.     }
  533.     DSTERROR(arg);
  534. }
  535.  
  536. STATIC
  537. CELP Ds_strlist(s)
  538. CELP s;
  539. {
  540.     CELP cp;
  541.     char *sp;
  542.     register int i;
  543.  
  544.     cp=NIL;
  545.     sp=STRPpart(s)+STRLpart(s);
  546.     for (i=STRLpart(s);i>0;i--)
  547.         cp=DsCons(DSCHRCEL(*--sp),cp);
  548.     return(cp);
  549. }
  550.  
  551.  
  552. STATIC
  553. CELP Ds_liststr(p)
  554. CELP p;
  555. {
  556.     char *str;
  557.     CELP q,np;
  558.     SHORT cnt;
  559.     
  560.     np=DsGetStr(cnt=(SHORT)DsLength(p));
  561.     str=STRPpart(np);
  562.     while (cnt-->0)
  563.     {
  564.         TYPCHECK(p,TYPE_PAIR);
  565.         q=CARpart(p);
  566.         TYPCHECK(q,TYPE_CHR);
  567.         *str++=(char)CELCHR(q);
  568.         p=CDRpart(p);
  569.     }
  570.     if (!ISNIL(p)) DSTERROR(p);
  571.     return(np);
  572. }
  573.  
  574.  
  575. /***************************************************************
  576. ** NAME:        Ds_strappend
  577. ** SYNOPSIS:    CELP Ds_strappend(p,q)
  578. **              CELP p;         DScheme string
  579. **              CELP q;         DScheme string
  580. ** DESCRIPTION: Ds_strappend combines two strings into one string
  581. ** RETURNS:     A DScheme string
  582. ***************************************************************/
  583. STATIC
  584. CELP Ds_strappend(p,q)
  585. CELP p,q;
  586. {
  587.     CELP np;
  588.     char *s;
  589.     int cnt;
  590.  
  591.     cnt=STRLpart(p)+STRLpart(q);              /* we can discard one '\0' byte */
  592.     np=DsGetStr(cnt);                                       /* Get fresh cell */
  593.     s=STRPpart(np);
  594.     strncpy(s,STRPpart(p),STRLpart(p));
  595.     strncpy(s+STRLpart(p),STRPpart(q),STRLpart(q));     /* Append second part */
  596.     return(np);
  597. }
  598.  
  599.  
  600. STATIC
  601. CELP Ds_symstr(q)
  602. CELP q;
  603. {
  604.     if (!ISSYM(q)) DSTERROR(q);
  605.     return(CDRpart(q));
  606. }
  607.  
  608.  
  609. STATIC
  610. CELP Ds_strsym(q)
  611. CELP q;
  612. {
  613.     return(DsSymbol(STRPpart(q)));
  614. }
  615.  
  616. STATIC
  617. CELP Ds_strlen(q)
  618. CELP q;
  619. {
  620.     CELP p;
  621.     INTCEL(p,(STRLpart(q)));
  622.     return p;
  623. }
  624.  
  625. STATIC
  626. CELP Ds_strset(str,pos,chr)
  627. CELP str,pos,chr;
  628. {
  629.     register int i=(int)CELINT(pos);
  630.     if (i<0 || i>=STRLpart(str)) return(NIL);
  631.     STRPpart(str)[i]=(char)CELCHR(chr);                          /* modify it */
  632.     return(str);                                   /* returns modified string */
  633. }
  634.  
  635. STATIC
  636. CELP Ds_strref(str,pos)
  637. CELP str;
  638. CELP pos;
  639. {
  640.     register int i=(int)CELINT(pos);
  641.     if (i<0 || i>=STRLpart(str)) return(NIL);
  642.     return DSCHRCEL(STRPpart(str)[i]);
  643. }
  644.  
  645. STATIC
  646. CELP Ds_strsub(str,pos,cnt)
  647. CELP str,pos,cnt;
  648. {
  649.     CELP np;
  650.     int i,l;
  651.  
  652.     i=(int)CELINT(pos);
  653.     l=(int)CELINT(cnt);
  654.     if (! (0<=i && i<=l && l<=STRLpart(str)))               /* Bound checking */
  655.         return(NIL);                         
  656.     l-=i;                                              /* length of substring */
  657.     np=DsGetStr(l);
  658.     strncpy(STRPpart(np),STRPpart(str)+i,l);              /* add start offset */
  659.     return(np);
  660. }
  661.  
  662. STATIC
  663. CELP Ds_strlt(str1,str2)
  664. CELP str1,str2;
  665. {
  666.     RETBOO(strcmp(STRPpart(str1),STRPpart(str2)) <  0);
  667. }
  668.  
  669. STATIC
  670. CELP Ds_strle(str1,str2)
  671. CELP str1,str2;
  672. {
  673.     RETBOO(strcmp(STRPpart(str1),STRPpart(str2)) <= 0);
  674. }
  675.  
  676. STATIC
  677. CELP Ds_streq(str1,str2)
  678. CELP str1,str2;
  679. {
  680.     RETBOO(strcmp(STRPpart(str1),STRPpart(str2)) == 0);
  681. }
  682.  
  683. STATIC
  684. CELP Ds_strge(str1,str2)
  685. CELP str1,str2;
  686. {
  687.     RETBOO(strcmp(STRPpart(str1),STRPpart(str2)) >= 0);
  688. }
  689.  
  690. STATIC
  691. CELP Ds_strgt(str1,str2)
  692. CELP str1,str2;
  693. {
  694.     RETBOO(strcmp(STRPpart(str1),STRPpart(str2)) >  0);
  695. }
  696.  
  697. STATIC
  698. CELP Ds_strltci(str1,str2)
  699. CELP str1,str2;
  700. {
  701.     RETBOO(stricmp(STRPpart(str1),STRPpart(str2)) <  0);
  702. }
  703.  
  704. STATIC
  705. CELP Ds_strleci(str1,str2)
  706. CELP str1,str2;
  707. {
  708.     RETBOO(stricmp(STRPpart(str1),STRPpart(str2)) <= 0);
  709. }
  710.  
  711. STATIC
  712. CELP Ds_streqci(str1,str2)
  713. CELP str1,str2;
  714. {
  715.     RETBOO(stricmp(STRPpart(str1),STRPpart(str2)) == 0);
  716. }
  717.  
  718. STATIC
  719. CELP Ds_strgeci(str1,str2)
  720. CELP str1,str2;
  721. {
  722.     RETBOO(stricmp(STRPpart(str1),STRPpart(str2)) >= 0);
  723. }
  724.  
  725. STATIC
  726. CELP Ds_strgtci(str1,str2)
  727. CELP str1,str2;
  728. {
  729.     RETBOO(stricmp(STRPpart(str1),STRPpart(str2)) >  0);
  730. }
  731.  
  732. STATIC CELP PASCAL DsGetVec(n)
  733. int n;
  734. {
  735.     CELP p=DsGetCell(TYPE_VEC);
  736.     STRLpart(p)=n*sizeof(CELP);
  737.     STRPpart(p)=DsGetBuf(n*sizeof(CELP));
  738.     return p;
  739. }
  740.  
  741. CELP PASCAL DsGetStr(n)
  742. int n;
  743. {
  744.     CELP p=DsGetCell(TYPE_STR);
  745.     STRLpart(p)=n;
  746.     STRPpart(p)=DsGetBuf(n+1);
  747.     STRPpart(p)[n]='\0';
  748.     return p;
  749. }
  750.  
  751.  
  752.  
  753. STATIC
  754. CELP Ds_makevec(n,args)
  755. int n;
  756. CELP args;
  757. {
  758.     CELP q=NIL;
  759.  
  760.     if (n==2)
  761.     {
  762.         q=CDRpart(args);
  763.         args=CARpart(args);
  764.     }
  765.     return Ds_vecfill(DsGetVec((int)INTpart(args)),q);
  766. }
  767.  
  768. STATIC
  769. CELP Ds_vector(n,args)
  770. int n;
  771. CELP args;
  772. {
  773.     CELP p;
  774.     int i;
  775.     
  776.     p=DsGetVec(n);
  777.     for (i=0;i<n;i++)
  778.     {
  779.         if (i) args=CDRpart(args);
  780.         VECPpart(p)[i]=CARpart(args);
  781.     }
  782.     return p;
  783. }
  784.  
  785. STATIC
  786. CELP Ds_veclen(v)
  787. CELP v;
  788. {
  789.     CELP p;
  790.     INTCEL(p,(VECLpart(v)));
  791.     return p;
  792. }
  793.  
  794. STATIC
  795. CELP Ds_vecref(vec, pos)
  796. CELP vec, pos;
  797. {
  798.     register int i=(int)INTpart(pos);
  799.     if (i<0 || i>=VECLpart(vec)) return(NIL);
  800.     return VECPpart(vec)[i];
  801. }
  802.  
  803. CELP Ds_vecset(vec,pos,arg)
  804. CELP vec,pos,arg;
  805. {
  806.     register int i=(int)CELINT(pos);
  807.     if (i<0 || i>=VECLpart(vec)) return(NIL);
  808.     VECPpart(vec)[i]=arg;                          /* modify it */
  809.     return(vec);                                   /* returns modified string */
  810. }
  811.  
  812.  
  813.  
  814. STATIC
  815. CELP Ds_veclst(s)
  816. CELP s;
  817. {
  818.     CELP cp, *vp;
  819.     register int i=VECLpart(s);
  820.  
  821.     cp=NIL;
  822.     vp=VECPpart(s);
  823.     while (i>0)
  824.         cp=DsCons(vp[--i],cp);
  825.     return(cp);
  826. }
  827.  
  828.  
  829. CELP Ds_lstvec(p)
  830. CELP p;
  831. {
  832.     CELP *vp, np;
  833.     int cnt;
  834.     
  835.     np=DsGetVec(cnt=(int)DsLength(p));
  836.     vp=VECPpart(np);
  837.     while (cnt-->0)
  838.     {
  839.         TYPCHECK(p,TYPE_PAIR);
  840.         *vp++=CARpart(p);
  841.         p=CDRpart(p);
  842.     }
  843.     return(np);
  844. }
  845.  
  846. STATIC
  847. CELP Ds_vecfill(p,q)
  848. CELP p,q;
  849. {
  850.     int i;
  851.     for (i=0;i<VECLpart(p);i++)
  852.         VECPpart(p)[i]=q;
  853.     return p;
  854. }
  855.  
  856. #ifdef DEBUG
  857. STATIC 
  858. CELP Ds_dumpstr()
  859. {
  860.     CELP p,q;
  861.     int i=0;
  862.     long totlen=0L;
  863.  
  864.     DsOuts(GLOB(errport),"**********************************\n");
  865.     DsOuts(GLOB(errport),"** Blok Address   Length EndOfBlok\n");
  866.     DsOuts(GLOB(errport),"** ---- --------- ------ ---------\n");
  867.     for (q=GLOB(freestr); ISTRUE(q); q=CDRpart(q))
  868.     {
  869.         p=CARpart(q);
  870.         sprintf(GLOB(bigbuf),"** %-4d %09p %6d %09p\n",
  871.              ++i, STRPpart(p), STRLpart(p), STRPpart(p)+STRLpart(p));
  872.         DsOuts(GLOB(errport),GLOB(bigbuf));
  873.         totlen+=STRLpart(p);
  874.     }
  875.     DsOuts(GLOB(errport),"**\n");
  876.     DsOutf(GLOB(errport),"** %d part%s, %l bytes\n", i, i==1?"":"s", totlen);
  877.     DsOuts(GLOB(errport),"**********************************\n");
  878.     return Q_invis;
  879. }
  880. #endif
  881.