[Gcl-devel] Re: describe bug, was: Re: [Maxima] First step toward a 5.9.2 release

[Camm Maguire]

Greetings!

Here is a preliminary patch against CVS head, which we could backport
to stable if needed.

1) Support for pre-compiled regexps
2) info syntax fix.
3) make use of 1) in gcl_info.lsp
4) Follow maxima's logic for multiple info entries

TODO

1) libc POSIX regex -> eliminate old o/regexp.c

NOTES:

1) maxima's cl-info.lsp with the defuns surrounded by (let (()) )
   results in uncompiled closures, at least on gcl, which is
   needlessly slow.   You might want to make use of load-time-value as
   in this patch.

Take care,


=============================================================================
Index: o/regexp.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/regexp.c,v
retrieving revision 1.3
diff -u -r1.3 regexp.c
--- o/regexp.c  15 Feb 2003 00:38:28 -0000      1.3
+++ o/regexp.c  1 Apr 2005 22:40:57 -0000
@@ -230,7 +230,7 @@
  * of the structure of the compiled regexp.
  */
 static regexp *
-regcomp(char *exp)
+regcomp(char *exp,int *sz)
 {
        register regexp *r;
        register char *scan;
@@ -255,7 +255,8 @@
                FAIL("regexp too big");
 
        /* Allocate space. */
-       r = (regexp *)malloc(sizeof(regexp) + (unsigned)regsize);
+       *sz=sizeof(regexp) + (unsigned)regsize;
+       r = (regexp *)alloc_relblock(*sz);
        if (r == NULL)
                FAIL("out of space");
 
cvs diff: I know nothing about o/regexp.c.ori
cvs diff: I know nothing about o/regexp.c.~1.3.~
cvs diff: I know nothing about o/regexp.h.ori
Index: o/regexpr.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/regexpr.c,v
retrieving revision 1.9
diff -u -r1.9 regexpr.c
--- o/regexpr.c 5 Aug 2004 22:21:59 -0000       1.9
+++ o/regexpr.c 1 Apr 2005 22:40:58 -0000
@@ -61,6 +61,35 @@
   RETURN1(make_fixnum(-1));
 }
 
+DEFUN_NEW("COMPILE-REGEXP",object,fScompile_regexp,SI,1,1,NONE,OO,OO,OO,OO,(object
 p),
+         "Provide handle to export pre-compiled regexp's to string-match") {
+
+  char *tmp;
+  object res;
+
+  if (type_of(p)!= t_string && type_of(p)!=t_symbol)
+    not_a_string_or_symbol(p);
+  
+  if (!(tmp=alloca(p->st.st_fillp+1)))
+    FEerror("out of C stack",0);
+  memcpy(tmp,p->st.st_self,p->st.st_fillp);
+  tmp[p->st.st_fillp]=0;
+
+  res=alloc_object(t_vector);
+  res->v.v_displaced=Cnil;
+  res->v.v_hasfillp=1;
+  res->v.v_elttype=aet_uchar;
+  res->v.v_adjustable=0;
+  res->v.v_offset=0;
+  if (!(res->v.v_self=(void *)regcomp(tmp,&res->v.v_dim)))
+    FEerror("regcomp failure",0);
+  res->v.v_fillp=res->v.v_dim;
+
+  RETURN1(res);
+
+}
+
+
 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 \
@@ -73,13 +102,14 @@
 
   int i,ans,nargs=VFUN_NARGS,len,start,end;
   static char buf[400],case_fold;
-  static regexp *compiled_regexp;
+  static regexp *saved_compiled_regexp;
   va_list ap;
   object v = sSAmatch_dataA->s.s_dbind;
   char **pp,*str,save_c=0;
   unsigned np;
 
-  if (type_of(pattern)!= t_string && type_of(pattern)!=t_symbol)
+  if (type_of(pattern)!= t_string && type_of(pattern)!=t_symbol &&
+      type_of(pattern)!=t_vector)
     not_a_string_or_symbol(string);
   if (type_of(string)!= t_string && type_of(string)!=t_symbol)
     not_a_string_or_symbol(string);
@@ -109,30 +139,21 @@
    }
 
    {
+
+     regexp *compiled_regexp=saved_compiled_regexp;
+
      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)) {
+     
+     if (type_of(pattern)==t_vector)
+       
+       compiled_regexp=(void *)pattern->ust.ust_self;
 
-       char *tmp=len+1<sizeof(buf) ? buf : (char *) alloca(len+1);
-       if (!tmp)
-        FEerror("Cannot allocate memory on C stack",0);
+     else if (case_fold != case_fold_search || len != strlen(buf) || 
memcmp(pattern->ust.ust_self,buf,len)) 
 
-       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));
-       }
+       compiled_regexp=saved_compiled_regexp=(regexp 
*)fScompile_regexp(pattern)->v.v_self;
 
-     }
 
      str=string->st.st_self;
      np=page(str);
cvs diff: I know nothing about o/regexpr.c.ori
cvs diff: I know nothing about o/regexpr.c.~1.9.~
cvs diff: I know nothing about o/regexpr.ini
cvs diff: I know nothing about o/regexpr.o
Index: lsp/gcl_info.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_info.lsp,v
retrieving revision 1.4
diff -u -r1.4 gcl_info.lsp
--- lsp/gcl_info.lsp    13 Aug 2004 15:29:59 -0000      1.4
+++ lsp/gcl_info.lsp    1 Apr 2005 22:41:00 -0000
@@ -11,7 +11,8 @@
   `(slooP::sloop while ,test do ,@ body))
  (defmacro f (op x y)
    `(the ,(if  (get op 'compiler::predicate)  't 'fixnum)
-        (,op (the fixnum ,x) (the fixnum ,y)))))
+        (,op (the fixnum ,x) (the fixnum ,y))))
+(defmacro fcr (x) `(load-time-value (compile-regexp ,x))))
 
 (eval-when (compile eval load)
 (defun sharp-u-reader (stream subchar arg)
@@ -31,10 +32,13 @@
        (vector-push-extend ch tem)))
     tem))
 
-
 (set-dispatch-macro-character #\# #\u 'sharp-u-reader)
+
 )
 
+(defconstant +crlu+ (compile-regexp #u""))
+(defconstant +crnp+ (compile-regexp #u"[]"))
+
 (defvar *info-data* nil)
 (defvar *current-info-data* nil)
 
@@ -67,11 +71,11 @@
   (declare (fixnum lim))
   (let ((s (file-to-string file)) (i 0))
     (declare (fixnum i) (string s))
-    (cond ((f >= (string-match #u"[\n]+Indirect:" s 0) 0)
+    (cond ((f >= (string-match (fcr #u"[\n]+Indirect:") s 0) 0)
           (setq i (match-end 0))
-          (setq lim (string-match #u"" s i))
+          (setq lim (string-match +crlu+ s i))
           (while
-              (f >= (string-match #u"\n([^\n]+): ([0-9]+)" s i lim) 0)
+              (f >= (string-match (fcr #u"\n([^\n]+): ([0-9]+)") s i lim) 0)
             (setq i (match-end 0))
             (setq files
                   (cons(cons
@@ -79,9 +83,9 @@
                         (get-match s 1)
                         )
                        files)))))
-    (cond ((f >=  (si::string-match #u"[\n]+Tag Table:" s i) 0)
+    (cond ((f >=  (si::string-match (fcr #u"[\n]+Tag Table:") s i) 0)
           (setq i (si::match-end 0))
-          (cond ((f >= (si::string-match "" s i) 0)
+          (cond ((f >= (si::string-match +crlu+ s i) 0)
                  (setq tags (subseq s i (si::match-end 0)))))))
     (if files (or tags (info-error "Need tags if have multiple files")))
     (list* tags (nreverse files))))
@@ -89,29 +93,30 @@
 (defun re-quote-string (x &aux (i 0) (len (length x)) ch
                           (extra 0)  )
   (declare (fixnum i len extra))
-  (declare (string x))
-  (let (tem)
-    (tagbody
-     AGAIN
-     (while (< i len)
-       (setq ch (aref x i))
-       (cond ((position ch "\\()[]+.*|^$?")
-             (cond (tem 
-                    (vector-push-extend #\\ tem))
-                   (t (incf extra)))))
-       (if tem
-          (vector-push-extend ch tem))
-       (setq i (+ i 1)))
-     (cond (tem )
-          ((> extra 0)
-           (setq tem 
-                 (make-array (f + (length x) extra)
-                             :element-type 'string-char :fill-pointer 0))
-           (setq i 0)
-           (go AGAIN))
-          (t (setq tem x)))
-     )
-    tem))
+  (let ((x (if (stringp x) x (string x))))
+    (declare (string x))
+    (let (tem)
+      (tagbody
+       AGAIN
+       (while (< i len)
+        (setq ch (aref x i))
+        (cond ((position ch "\\()[]+.*|^$?")
+               (cond (tem 
+                      (vector-push-extend #\\ tem))
+                     (t (incf extra)))))
+        (if tem
+            (vector-push-extend ch tem))
+        (setq i (+ i 1)))
+       (cond (tem )
+            ((> extra 0)
+             (setq tem 
+                   (make-array (f + (length x) extra)
+                               :element-type 'string-char :fill-pointer 0))
+             (setq i 0)
+             (go AGAIN))
+            (t (setq tem x)))
+       )
+      tem)))
 
 (defun get-match (string i)
   (subseq string (match-beginning i) (match-end i)))
@@ -289,15 +294,15 @@
   (let* ((info-subfile (info-subfile n))
         (s (info-get-file (cdr info-subfile)))
         (end (- n (car info-subfile))))
-    (while (f >=  (string-match #u"" s i end) 0)
+    (while (f >=  (string-match +crlu+ s i end) 0)
       (setq i (match-end 0)))
     (setq i (- i 1))
     (if (f >= (string-match
-              #u"[\n][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n"  s i) 0)
+              (fcr #u"[\n][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n")  s 
i) 0)
        (let* ((i (match-beginning 0))
               (beg (match-end 0))
               (name (get-match s 1))
-              (end(if (f >= (string-match "[]" s beg) 0)
+              (end(if (f >= (string-match +crnp+ s beg) 0)
                       (match-beginning 0)
                     (length s)))
               (node (list* s beg end i name info-subfile
@@ -323,7 +328,7 @@
           (setq position-pattern (car name) name (cdr name)))))
   (or (stringp name) (info-error "bad arg"))
   (waiting *info-window*)  
-  (cond ((f >= (string-match "^\\(([^(]+)\\)([^)]*)" name) 0)
+  (cond ((f >= (string-match (fcr "^\\(([^(]+)\\)([^)]*)") name) 0)
         ;; (file)node
         (setq file (get-match name 1))
         (setq name (get-match name 2))
@@ -348,7 +353,7 @@
                    s start) 0)
             (let* ((i (match-beginning 0))
                    (beg (match-end 0))
-                   (end(if (f >= (string-match "[]" s beg) 0)
+                   (end(if (f >= (string-match +crnp+ s beg) 0)
                            (match-beginning 0)
                          (length s)))
                    (node (list* s beg end i name info-subfile
@@ -363,7 +368,7 @@
                        (f >= (setq subnode
                                    (string-match
                                     (si::string-concatenate
-                                     #u"\n - [A-Za-z ]+: "
+                                     #u"\n -+ [A-Za-z ]+: "
                                      position-pattern #u"[ \n]")
                                     s beg end)) 0)
                        (f >= (string-match position-pattern s beg end) 0))
@@ -378,9 +383,13 @@
                      (let ((e
                             (if (and (>= subnode 0)
                                      (f >=
-                                        (string-match #u"\n\n - [A-Z]"
-                                                      s (+ beg 1
-                                                           initial-offset)
+                                        (string-match 
+                                         (fcr #u"\n -+ [a-zA-Z]")
+                                         s 
+                                         (let* ((bg (+ beg 1 initial-offset))
+                                                (sd (string-match (fcr #u"\n   
") s bg end))
+                                                (nb (if (minusp sd) bg sd)))
+                                           nb) 
                                                       end)
                                         0))
                                 (match-beginning 0)
=============================================================================

Robert Dodier <address@hidden> writes:

> --- "Vadim V. Zhytnikov" <address@hidden> wrote:
> 
> > Wolfgang just committed the fix into Maxima CVS.
> > The problem was not with new Maxima info layout
> > but with new texinfo version.  Robert, could you
> > verify after this fix describe well for you?
> > The also should not forget to switch to Maxima's
> > describe for gcl at least temporary.
> 
> I have updated the source code on my machine and rebuilt
> with gcl and clisp. I find that the clisp version works
> correctly -- "? limit", then choosing 2 gives just item 2.
> Likewise for some other cases I tried.
> 
> As you know the gcl version uses the built-in gcl info
> system when *PROMPT-PREFIX* and *PROMPT-SUFFIX* are empty,
> and otherwise falls back on src/cl-info.lisp. 
> I find that the "? limit", then choose 2, yields a mess
> of irrelevant text when the built-in gcl info system is
> used. Setting *PROMPT-PREFIX* to "FOO" (to cause Maxima
> to use cl-info.lisp), then "? limit" and choose 2, yields
> the correct output (but much more slowly).
> 
> gcl version is 2.6.6, makeinfo is 4.5, clisp is 2.31.
> 
> Hope this helps,
> Robert Dodier
> 
> 
>               
> __________________________________ 
> Do you Yahoo!? 
> Make Yahoo! your home page 
> http://www.yahoo.com/r/hs
> 
> 
> 

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