Re: [Gcl-devel] memory damaged at (system:STRING-MATCH :anykey :verbose)

[Camm Maguire]

Greetings!  OK, I've fixed this, but cannot commit for the time being
as subversions is down.  Here is the new function in regexpr.c:

DEFUN_NEW("STRING-MATCH",object,fSstring_match,SI,2,4,NONE,OO,OI,IO,OO,(object 
pattern,object string,...),
      "Match regexp PATTERN in STRING starting in string starting at START \
and ending at END.  Return -1 if match not found, otherwise \
return the start index  of the first matchs.  The variable \
*MATCH-DATA* will be set to a fixnum array of sufficient size to hold \
the matches, to be obtained with match-beginning and match-end. \
If it already contains such an array, then the contents of it will \
be over written.   \
") {  

  int i,ans,nargs=VFUN_NARGS,len,start,end;
  static char buf[400],case_fold;
  static regexp *compiled_regexp;
  va_list ap;
  object v = sSAmatch_dataA->s.s_dbind;
  char **pp,*str,save_c;
  unsigned np;

  if (type_of(pattern)!= t_string && type_of(pattern)!=t_symbol)
    not_a_string_or_symbol(string);
  if (type_of(string)!= t_string && type_of(string)!=t_symbol)
    not_a_string_or_symbol(string);
  
  if (type_of(v) != t_vector || v->v.v_elttype != aet_fix || v->v.v_dim < 
NSUBEXP*2)
    v=sSAmatch_dataA->s.s_dbind=fSmake_vector1_1((NSUBEXP *2),aet_fix,sLnil);
  
  start=0;
  end=string->st.st_fillp;
  if (nargs>2) {
    va_start(ap,string);
    start=va_arg(ap,fixnum);
    if (nargs>3)
      end=va_arg(ap,fixnum);
    va_end(ap);
  }
  if (start < 0 || end > string->st.st_fillp || start > end)
     FEerror("Bad start or end",0);

  len=pattern->ust.ust_fillp;
   if (len==0) {
     /* trivial case of empty pattern */
     for (i=0;i<NSUBEXP;i++) 
       v->fixa.fixa_self[i]=i ? -1 : 0;
     
memcpy(v->fixa.fixa_self+NSUBEXP,v->fixa.fixa_self,NSUBEXP*sizeof(*v->fixa.fixa_self));
     RETURN1(make_fixnum(0));
   }

   {
     BEGIN_NO_INTERRUPT;

     case_fold_search = sSAcase_fold_searchA->s.s_dbind != sLnil ? 1 : 0;
     if (case_fold != case_fold_search || len != strlen(buf) ||  
memcmp(pattern->ust.ust_self,buf,len)) {

       char *tmp=len+1<sizeof(buf) ? buf : (char *) alloca(len+1);
       if (!tmp)
         FEerror("Cannot allocate memory on C stack",0);

       case_fold = case_fold_search;
       memcpy(tmp,pattern->st.st_self,len);
       tmp[len]=0;

       if (compiled_regexp) {
         free((void *)compiled_regexp);
         compiled_regexp = 0;
       }
       
       if (!(compiled_regexp=regcomp(tmp))) {
         END_NO_INTERRUPT;
         RETURN1(make_fixnum(-1));
       }

     }

     str=string->st.st_self;
     np=page(str);
     if (np>=MAXPAGE || (type_map[np] != t_contiguous && type_map[np] != 
t_relocatable) ||
         str+end==(void *)core_end || str+end==(void *)compiled_regexp) {

       if (!(str=alloca(string->st.st_fillp+1)))
         FEerror("Cannot allocate memory on C stack",0);
       memcpy(str,string->st.st_self,string->st.st_fillp);

     } else
       save_c=str[end];
     str[end]=0;

     ans = regexec(compiled_regexp,str+start,str,end-start);

     str[end] = save_c;

     if (!ans ) {
       END_NO_INTERRUPT;
       RETURN1(make_fixnum(-1));
     }

     pp=compiled_regexp->startp;
     for (i=0;i<NSUBEXP;i++,pp++)
       v->fixa.fixa_self[i]=*pp ? *pp-str : -1;
     pp=compiled_regexp->endp;
     for (;i<2*NSUBEXP;i++,pp++)
       v->fixa.fixa_self[i]=*pp ? *pp-str : -1;

     END_NO_INTERRUPT;
     RETURN1(make_fixnum(v->fixa.fixa_self[0]));

   }

}
        

Take care,

"Mike Thomas" <address@hidden> writes:

> Hi Mr Koehne.
> 
> | Moin Mike Thomas,
> | 
> | > For the record, on Windows 2.6.2 ANSI I get the same problem:
> | 
> |   you might try the same fix
> 
> 'Ken Boughtone as they say.
> 
> >(system:STRING-MATCH :anykey :verbose)
> 
> -1
> 
> >(si:string-match :ish :up)
> 
> -1
> 
> >(sloop:sloop for v in-package 'keyword do (when (get v 'si::break-command)
>    (format t "~%~S " v)
>    (format t "~S" (si:string-match :ish v))
>    (format t " ok")))
> 
> :BREAK -1 ok
> :A -1 ok
> :B -1 ok
> :C -1 ok
> :H -1 ok
> :M -1 ok
> :N -1 ok
> :P -1 ok
> :Q -1 ok
> :R -1 ok
> :S -1 ok
> :ENV -1 ok
> :NEXT -1 ok
> :BL -1 ok
> :BT -1 ok
> :FR -1 ok
> :UP -1 ok
> :ENABLE -1 ok
> :LOC -1 ok
> :INFO -1 ok
> :RESUME -1 ok
> :DISABLE -1 ok
> :HELP -1 ok
> :DELETE -1 ok
> :DOWN -1 ok
> :BLOCKS -1 ok
> :FUNCTIONS -1 ok
> :GO -1 ok
> :BS -1 ok
> :FS -1 ok
> :VS -1 ok
> :BDS -1 ok
> :IHS -1 ok
> :STEP -1 ok
> NIL
> 
> 
> Cheers
> 
> Mike Thomas.
> 
> 
> 
> _______________________________________________
> Gcl-devel mailing list
> address@hidden
> http://lists.gnu.org/mailman/listinfo/gcl-devel
> 
> 
> 

-- 
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah