describe bug, was: Re: [Maxima] First step toward a 5.9.2 release
- Subject: describe bug, was: Re: [Maxima] First step toward a 5.9.2 release
- From: Camm Maguire
- Date: 02 Apr 2005 19:11:25 -0500
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