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



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+1ust.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  writes:

> --- Camm Maguire  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 #.
> 
> 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			     			camm@enhanced.com
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah