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

[Camm Maguire]

Greetings!

OK here is the backport to 2.6.6, also posted to the errata page on
the gcl website.  Works for me, please let me know if not for you.

=============================================================================
diff -ru gcl-2.6.6/cmpnew/gcl_cmpeval.lsp gcl-2.6.6.new/cmpnew/gcl_cmpeval.lsp
--- gcl-2.6.6/cmpnew/gcl_cmpeval.lsp    2003-10-31 01:03:29.000000000 +0000
+++ gcl-2.6.6.new/cmpnew/gcl_cmpeval.lsp        2005-04-03 00:00:38.000000000 
+0000
@@ -68,10 +68,31 @@
   (if (eq form '*cmperr-tag*) (c1nil) form))
 
 (si::putprop 'si:|#,| 'c1sharp-comma 'c1special)
+(si::putprop 'load-time-value 'c1load-time-value 'c1special)
 
 (defun c1sharp-comma (arg)
   (c1constant-value (cons 'si:|#,| arg) t))
 
+(defun wrap-literals (form)
+  (cond ((consp form)
+        (if (eq (car form) 'quote )
+            `(load-time-value (si::nani ,(si::address (cadr form))))
+          (cons (wrap-literals (car form)) (wrap-literals (cdr form)))))
+       ((stringp form)
+        `(load-time-value (si::nani ,(si::address form))))
+       (t form)))
+
+(defun c1load-time-value (arg)
+  (c1constant-value
+   (cons 'si:|#,|
+        (if *compiler-compile*
+            (let ((x (cmp-eval (car arg))))
+              (if (and (cdr arg) (cadr arg))
+                  x
+                `(si::nani ,(si::address x))))
+          (car arg)))
+   t))
+
 (si::putprop 'si::define-structure 'c1define-structure 't1)
 
 (defun c1define-structure (arg &aux *sharp-commas*)
diff -ru gcl-2.6.6/cmpnew/gcl_cmpmain.lsp gcl-2.6.6.new/cmpnew/gcl_cmpmain.lsp
--- gcl-2.6.6/cmpnew/gcl_cmpmain.lsp    2005-01-15 16:27:15.000000000 +0000
+++ gcl-2.6.6.new/cmpnew/gcl_cmpmain.lsp        2005-04-03 00:00:38.000000000 
+0000
@@ -35,6 +35,7 @@
 
 
 (defvar *compiler-in-use* nil)
+(defvar *compiler-compile* nil)
 (defvar *compiler-input*)
 (defvar *compiler-output1*)
 (defvar *compiler-output2*)
@@ -408,7 +409,6 @@
     (wt-data1 form)  ;; this binds all the print stuff
     ))
 
-
 (defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* 
#"."))
 
   (cond ((not(symbolp name)) (error "Must be a name"))
@@ -423,10 +423,12 @@
         (setf (symbol-function 'cmp-anon) tem)
         (compile 'cmp-anon)
         (setf (macro-function name) (macro-function name))
-        name)
+        ;; FIXME -- support warnings-p and failures-p.  CM 20041119
+        (values name nil nil))
        ((and (setq tem (symbol-function name))
              (consp tem))
-        (let ((na (if (symbol-package name) name 'cmp-anon)))
+        (let ((na (if (symbol-package name) name 'cmp-anon))
+              (tem (wrap-literals tem)))
           (unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) 
(fmakunbound 'si::init-cmp-anon)))
             (with-open-file
              (st (setq gaz (gazonk-name)) :direction :output)
@@ -434,12 +436,14 @@
                                               (lambda (cdr tem))
                                               (lambda-block (cddr tem))
                                               ))       st))
-            (let ((fi (compile-file gaz)))
+            (let ((fi (let ((*compiler-compile* t))
+                        (compile-file gaz))))
               (load fi)
               (delete-file fi))
             (unless *keep-gaz* (delete-file gaz)))
           (or (eq na name) (setf (symbol-function name) (symbol-function na)))
-          (symbol-function name)
+        ;; FIXME -- support warnings-p and failures-p.  CM 20041119
+          (values (symbol-function name) nil nil)
           ))
        (t (error "can't compile ~a" name))))
 
diff -ru gcl-2.6.6/lsp/gcl_info.lsp gcl-2.6.6.new/lsp/gcl_info.lsp
--- gcl-2.6.6/lsp/gcl_info.lsp  2004-03-20 01:35:28.000000000 +0000
+++ gcl-2.6.6.new/lsp/gcl_info.lsp      2005-04-02 23:59:54.000000000 +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,39 +83,40 @@
                         (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))))
 
-(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))
+(defun re-quote-string (x &aux (i 0) ch (extra 0))
+  (declare (fixnum i extra))
+  (let ((x (if (stringp x) x (string x))))
+    (declare (string x))
+    (let (tem (len (length x)))
+      (declare (fixnum len))
+      (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)))
@@ -292,15 +297,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
@@ -326,7 +331,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))
@@ -351,7 +356,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
@@ -366,7 +371,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))
@@ -381,9 +386,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)
diff -ru gcl-2.6.6/o/regexp.c gcl-2.6.6.new/o/regexp.c
--- gcl-2.6.6/o/regexp.c        2003-02-15 00:38:28.000000000 +0000
+++ gcl-2.6.6.new/o/regexp.c    2005-04-02 23:40:21.000000000 +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");
 
diff -ru gcl-2.6.6/o/regexpr.c gcl-2.6.6.new/o/regexpr.c
--- gcl-2.6.6/o/regexpr.c       2004-08-05 22:21:11.000000000 +0000
+++ gcl-2.6.6.new/o/regexpr.c   2005-04-02 23:40:21.000000000 +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,14 +102,15 @@
 
   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)
-    not_a_string_or_symbol(string);
+  if (type_of(pattern)!= t_string && type_of(pattern)!=t_symbol &&
+      (type_of(pattern)!=t_vector || pattern->v.v_elttype!=aet_uchar))
+    FEerror("~S is not a regexp pattern", 1 , pattern);
   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);
diff -ru gcl-2.6.6/o/toplevel.c gcl-2.6.6.new/o/toplevel.c
--- gcl-2.6.6/o/toplevel.c      2004-03-20 01:47:38.000000000 +0000
+++ gcl-2.6.6.new/o/toplevel.c  2005-04-02 23:45:46.000000000 +0000
@@ -149,6 +149,19 @@
 }
 
 static void
+FFN(Fload_time_value)(object arg)
+{
+
+       if(endp(arg))
+               FEtoo_few_argumentsF(arg);
+       if(!endp(MMcdr(arg)) && !endp(MMcddr(arg)))
+               FEtoo_many_argumentsF(arg);
+       vs_push(MMcar(arg));
+       eval(vs_head);
+
+}
+
+static void
 FFN(Fdeclare)(object arg)
 {
        FEerror("DECLARE appeared in an invalid position.", 0);
@@ -215,6 +228,7 @@
        make_si_function("*MAKE-SPECIAL", siLAmake_special);
        make_si_function("*MAKE-CONSTANT", siLAmake_constant);
        make_special_form("EVAL-WHEN", Feval_when);
+       make_special_form("LOAD-TIME-VALUE", Fload_time_value);
        make_special_form("THE", Fthe);
        sLdeclare=make_special_form("DECLARE",Fdeclare);
        make_special_form("LOCALLY",Flocally);
=============================================================================

Take care,

Robert Dodier <address@hidden> writes:

> --- Camm Maguire <address@hidden> wrote:
> 
> > 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
> 
> Camm, thanks for working on this problem. I have applied
> the patch which you sent. Unfortunately DESCRIBE is broken
> in the resulting system. I find (DESCRIBE 'DESCRIBE) yields
> 
> Error in PCL::DESCRIBE-OBJECT [or a callee]: 
> Error in TYPE-ERROR-DATUM [or a callee]: The slot CONDITIONS::DATUM is
> unbound in the object #<CONDITIONS::INTERNAL-TYPE-ERROR.0>.
> 
> I have tried this a couple of ways: (1) Unpack gcl-2.6.6.tar.gz,
> get head revs of o/regexp.c, o/regexpr.c, and lsp/gcl_info.lsp
> from cvs, apply patch, & make. (2) Get head revs of everything
> from cvs, apply patch, & make. Same error in either case.
> 
> I have enabled ANSI mode with configure (and nothing else).
> gcc version 3.3.2, on Linux Fedora Core 1.
> 
> Maybe someone can point out where I'm going wrong here.
> Thanks for any light you can shed on this problem.
> 
> All the best,
> Robert Dodier
> 
> 
>               
> __________________________________ 
> Do you Yahoo!? 
> Yahoo! Personals - Better first dates. More second dates. 
> http://personals.yahoo.com
> 
> 
> 
> 

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