[Maxima-commits] [git] Maxima CAS branch master updated. branch-5_49-base-580-ga005a38fb

[tomasriker <tom...@us...>]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Maxima CAS".

The branch, master has been updated
       via  a005a38fb4a72b946c86c2de1964b2776bc30775 (commit)
       via  a84283151975c49a54e4be7a934c1aa8f306d76b (commit)
       via  0465239815dda4c84b2c6e5e9e68ee2578601454 (commit)
       via  9ca4afa79cb2c8bfb6f2b28f057b35ab4b24ea57 (commit)
       via  fe1ee8adcefca436cb10354fe4ca5775ddb3f00b (commit)
      from  c66d6a30289a13325c7b2879d6befe582c7558e3 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit a005a38fb4a72b946c86c2de1964b2776bc30775
Merge: a84283151 c66d6a302
Author: David Scherfgen <d.s...@go...>
Date:   Sun Jun 7 07:01:21 2026 +0200

    Merge branch 'master' of https://git.code.sf.net/p/maxima/code


commit a84283151975c49a54e4be7a934c1aa8f306d76b
Author: David Scherfgen <d.s...@go...>
Date:   Sun Jun 7 07:01:09 2026 +0200

    Fix thread-local storage (TLS) exhaustion on SBCL via symbol pooling
    
    The pattern matching compiler generates and dynamically binds interned symbols
    for each new rule. On SBCL, each such symbol permanently occupies a thread-local
    storage (TLS) slot that can never be reclaimed even when the symbols get GC-ed.
    Once the TLS is exhausted, e.g. after running the RTEST_RULES test multiple
    times, Maxima crashes. Another problem is that the interned symbols can
    increasingly bloat the package's symbol table.
    
    This patch introduces a symbol pool (*RULE-SYMBOL-POOL*) to recycle symbols
    of deleted rules:
    - GET-RULE-SYMBOL draws from the pool or generates a new interned symbol.
    - FREE-RULE-SYMBOLS "scrubs" symbols (MAKUNBOUND, FMAKUNBOUND, clearing property
      list) before returning them to the pool.
    - Rule compilation functions (PROC-$DEFRULE, PROC-$TELLSIMP, etc.) now track
      symbols for each rule and attach a list of them to the rule's properties.
    - Symbols are reclaimed when a rule is deleted (KILL1-ATOM) or overwritten,
      or when rule compilation fails.
    
    TLS consumption is now bounded by the concurrently existing rules rather than
    the historical total, generally preventing the crash. The package's symbol table
    no longer keeps growing.
    
    This fixes bug #4517.

diff --git a/src/globals.lisp b/src/globals.lisp
index 316613cee..e76e0dc9a 100644
--- a/src/globals.lisp
+++ b/src/globals.lisp
@@ -1910,3 +1910,6 @@
 (defmvar *preserve-direction* ()
   "Makes `limit' return Direction info.")
 
+(defvar *rule-symbol-pool* nil
+  "List of symbols used by deleted rules, ready to be re-used in order to
+  prevent thread-local storage (TLS) exhaustion on SBCL.")
diff --git a/src/matcom.lisp b/src/matcom.lisp
index f9117232a..b68172415 100644
--- a/src/matcom.lisp
+++ b/src/matcom.lisp
@@ -18,10 +18,32 @@
 
 (defmvar $announce_rules_firing nil)
 
+(defvar *current-rule-symbols* nil
+  "Serves as an accumulator for collecting symbols used by a rule while it's
+  being created.")
+
 (defmspec $matchdeclare (form)
   (let ((meta-prop-p nil))
     (proc-$matchdeclare (cdr form))))
 
+(defun get-rule-symbol ()
+  "Generates a new interned symbol for the rule system or returns a recycled
+  existing one from the symbol pool (*RULE-SYMBOL-POOL*)."
+  (let ((sym (if *rule-symbol-pool*
+                (pop *rule-symbol-pool*)
+                (intern (symbol-name (gensym "RULE-SYMBOL-")) :maxima))))
+    (push sym *current-rule-symbols*)
+    sym))
+
+(defun free-rule-symbols (symbols)
+  "Frees the symbols SYMBOLS by clearing their values, functions and property lists,
+  then adding them to the symbol pool (*RULE-SYMBOL-POOL*) for recycling."
+  (dolist (sym symbols)
+    (makunbound sym)
+    (fmakunbound sym)
+    (setf (symbol-plist sym) nil)
+    (push sym *rule-symbol-pool*)))
+
 (defun proc-$matchdeclare (x)
   (if (oddp (length x))
       (merror (intl:gettext "matchdeclare: must be an even number of arguments.")))
@@ -66,10 +88,10 @@
 (defun makepreds (l gg) 
   (cond ((null l) nil)
 	(t (cons (cond ((atom (car l))
-			(list 'lambda (list (setq gg (gensym)))
+			(list 'lambda (list (setq gg (get-rule-symbol)))
 			      `(declare (special ,gg))
 			      (getdec (car l) gg)))
-		       (t (defmatch1 (car l) (gensym))))
+		       (t (defmatch1 (car l) (get-rule-symbol))))
 		 (makepreds (cdr l) nil)))))
 
 (defun defmatch1 (pt e) 
@@ -313,6 +335,7 @@
     (proc-$defmatch (cdr form))))
 
 (defun proc-$defmatch (l) 
+ (let (*current-rule-symbols*)
   (prog (pt pt* args a boundlist reflist topreflist program name tem) 
      (setq name (car l))
      (setq pt (copy-tree (setq pt* (simplify (cadr l)))))
@@ -325,6 +348,7 @@
      (setq boundlist args)
      (setq a (genref))
      (cond ((atom (errset (compilematch a pt)))
+	    (free-rule-symbols *current-rule-symbols*)
 	    (merror (intl:gettext "defmatch: failed to compile match for pattern ~M") pt))
 	   (t (meta-fset name
 			 (list 'lambda
@@ -348,7 +372,9 @@
 							      (t t))))))))
 	      (meta-add2lnc name '$rules) 
 	      (meta-mputprop name (list '(mlist) pt* (cons '(mlist) args)) '$rule)
-	      (return name)))))
+          (free-rule-symbols (get name 'rule-symbols))
+          (putprop name *current-rule-symbols* 'rule-symbols)
+	      (return name))))))
 
 (defmspec $tellsimp (form)
   (twoargcheck form)
@@ -361,6 +387,7 @@
 	 do (setf (mget v 'rulenum) nil)))
 
 (defun proc-$tellsimp (l) 
+ (let (*current-rule-symbols*)
   (prog (pt rhs boundlist reflist topreflist a program name tem
 	 oldstuff pgname oname rulenum) 
      (setq pt (copy-tree (simplifya (car l) nil)))
@@ -374,6 +401,7 @@
 	    (mtell (intl:gettext "tellsimp: warning: rule will treat '~M' as noncommutative and nonassociative.~%") name)))
      (setq a (genref))
      (cond ((atom (errset (compileeach a (cdr pt))))
+	    (free-rule-symbols *current-rule-symbols*)
 	    (merror (intl:gettext "tellsimp: failed to compile match for pattern ~M") (cdr pt))))
      (setq oldstuff (get name 'operators))
      (setq rulenum (mget name 'rulenum))
@@ -449,10 +477,12 @@
 			   (list (get name 'operators))
 			   'oldrules)))
      (meta-putprop name pgname 'operators)
+     (free-rule-symbols (get pgname 'rule-symbols))
+     (putprop pgname *current-rule-symbols* 'rule-symbols)
      (return (cons '(mlist)
 		   (meta-mputprop name
 				  (cons pgname (mget name 'oldrules))
-				  'oldrules)))))
+				  'oldrules))))))
 
 (defun %to$ (l) (cond ((eq (car l) '%) (rplaca l '$)) (l)))
 
@@ -463,6 +493,7 @@
     (proc-$tellsimpafter (cdr form))))
 
 (defun proc-$tellsimpafter (l) 
+ (let (*current-rule-symbols*)
   (prog (pt rhs boundlist reflist topreflist a program name oldstuff plustimes pgname oname tem
 	 rulenum my*afterflag) 
      (setq pt (copy-tree (simplifya (car l) nil)))
@@ -474,8 +505,9 @@
 	    (merror (intl:gettext "tellsimpafter: main operator of pattern must not be match variable; found: ~A") (fullstrip1 (getop name)))))
      (setq a (genref))
      (setq plustimes (member name '(mplus mtimes) :test #'eq))
-     (if (atom (if plustimes (errset (compilematch a pt))
+     (when (atom (if plustimes (errset (compilematch a pt))
 		   (errset (compileeach a (cdr pt)))))
+	 (free-rule-symbols *current-rule-symbols*)
 	 (merror (intl:gettext "tellsimpafter: failed to compile match for pattern ~M") (cdr pt)))
      (setq oldstuff (get name 'operators))
      (setq rulenum (mget name 'rulenum))
@@ -483,7 +515,7 @@
      (setq oname (getop name))
      (setq pgname (implode (append (%to$ (explodec oname))
 				   '(|r| |u| |l| |e|) (mexploden rulenum))))
-     (setq my*afterflag (gensym "*AFTERFLAG-"))
+     (setq my*afterflag (get-rule-symbol))
      (proclaim `(special ,my*afterflag))
      (setf (symbol-value my*afterflag) nil)
      (meta-mputprop pgname name 'ruleof)
@@ -537,10 +569,12 @@
      (cond ((null (mget name 'oldrules))
 	    (meta-mputprop name (list (get name 'operators)) 'oldrules)))
      (meta-putprop name pgname 'operators)
+     (free-rule-symbols (get pgname 'rule-symbols))
+     (putprop pgname *current-rule-symbols* 'rule-symbols)
      (return (cons '(mlist)
 		   (meta-mputprop name
 				  (cons pgname (mget name 'oldrules))
-				  'oldrules)))))
+				  'oldrules))))))
 
 (defun announce-rule-firing (rulename expr simplified-expr)
   (let (($display2d nil) ($stringdisp nil))
@@ -553,6 +587,7 @@
 
 ;;(defvar *match-specials* nil);;Hell lets declare them all special, its safer--wfs
 (defun proc-$defrule (l) 
+ (let (*current-rule-symbols*)
   (prog (pt rhs boundlist reflist topreflist name a program lhs* rhs*   tem) 
      (if (not (= (length l) 3)) (wna-err '$defrule))
      (setq name (car l))
@@ -562,6 +597,7 @@
      (setq rhs (copy-tree (setq rhs* (simplify (caddr l)))))
      (setq a (genref))
      (cond ((atom (errset (compilematch a pt)))
+        (free-rule-symbols *current-rule-symbols*)
 	    (merror (intl:gettext "defrule: failed to compile match for pattern ~M") pt))
 	   (t (meta-fset name
 			 (list 'lambda
@@ -585,7 +621,9 @@
 	      (meta-add2lnc name '$rules)
 	      (meta-mputprop name (setq l (list '(mequal) lhs* rhs*)) '$rule)
 	      (meta-mputprop name '$defrule '$ruletype)
-	      (return (list '(msetq) name (cons '(marrow) (cdr l))))))))
+          (free-rule-symbols (get name 'rule-symbols))
+          (putprop name *current-rule-symbols* 'rule-symbols)
+	      (return (list '(msetq) name (cons '(marrow) (cdr l)))))))))
 
 ; GETDEC constructs an expression of the form ``if <match> then <assign value> else <match failed>''.
 
@@ -698,7 +736,7 @@
 
 (defun genref nil 
   (prog (a) 
-     (setq a (tr-gensym))
+     (setq a (get-rule-symbol))
      (setq topreflist (cons a topreflist))
      (return (car (setq reflist (cons a reflist))))))
 (defun compileeach (elist plist) 
diff --git a/src/suprv1.lisp b/src/suprv1.lisp
index 7f2b5f433..ef1ed84af 100644
--- a/src/suprv1.lisp
+++ b/src/suprv1.lisp
@@ -206,6 +206,8 @@
       (when (member x (cdr $contexts) :test #'equal)
 	($killcontext x))
       (when (mget x '$rule)
+	(free-rule-symbols (get x 'rule-symbols))
+	(remprop x 'rule-symbols)
 	(let ((y (ruleof x)))
 	  (cond (y ($remrule y x))
 		(t (when (not (member x *builtin-$rules* :test #'equal))

commit 0465239815dda4c84b2c6e5e9e68ee2578601454
Author: David Scherfgen <d.s...@go...>
Date:   Sat Jun 6 16:56:02 2026 +0200

    In SIMPEXPT, don't use (EQUAL POT *BIGFLOATONE*)
    
    This doesn't work correctly when POT's precision is not the current precision.
    At this place it's already clear that its value is 1, so it's sufficient to test
    whether it's actually a bigfloat.

diff --git a/src/simp.lisp b/src/simp.lisp
index cc9570091..ff488a1ca 100644
--- a/src/simp.lisp
+++ b/src/simp.lisp
@@ -2215,7 +2215,7 @@
                   ;; A numeric constant like %e, %pi, ... and 
                   ;; exponent is a float or bigfloat value.
                   (return (if (and (member gr *builtin-numeric-constants*)
-                                   (equal pot *bigfloatone*))
+                                   ($bfloatp pot))
                               ;; Return a bigfloat value.
                               ($bfloat gr)
                               ;; Return a float value.

commit 9ca4afa79cb2c8bfb6f2b28f057b35ab4b24ea57
Author: David Scherfgen <d.s...@go...>
Date:   Sat Jun 6 16:35:48 2026 +0200

    In $BFLOAT, use (ZEROP1 X) instead of (EQUAL X *BIGFLOATZERO*)
    
    The latter doesn't work correctly when X's precision is not the current
    precision.

diff --git a/src/float.lisp b/src/float.lisp
index ec3480c9c..6bd07bff7 100644
--- a/src/float.lisp
+++ b/src/float.lisp
@@ -728,7 +728,7 @@
                       ;; that and signal a domain error if so.  There
                       ;; are no other bfloat values where tan(x) or
                       ;; sin(x) is zero.
-                      (when (equal (second x) *bigfloatzero*)
+                      (when (zerop1 (second x))
                         (domain-error (second x) (caar x)))
 		      (invertbigfloat
 		       ($bfloat (list (ncons (safe-get (caar x) 'recip)) y))))

commit fe1ee8adcefca436cb10354fe4ca5775ddb3f00b
Author: David Scherfgen <d.s...@go...>
Date:   Sat Jun 6 16:27:50 2026 +0200

    Fix %emode = false incorrectly preventing %e^2.0 from being simplified to float
    
    This fixes bug #4757.

diff --git a/src/simp.lisp b/src/simp.lisp
index 78bc48e1b..cc9570091 100644
--- a/src/simp.lisp
+++ b/src/simp.lisp
@@ -2224,7 +2224,6 @@
                   (return (exptrl gr pot)))))
            ((eq gr '$%e)
             ;; Numerically evaluate if the power is a flonum.
-            (when $%emode
               (let ((val (flonum-eval '%exp pot)))
 		(when (float-inf-p val)
 		    ;; needed for gcl and sbcl - (sometimes) no trap of overflow
@@ -2242,7 +2241,7 @@
                         ((or ($bfloatp x) ($bfloatp y))
                          (let ((z (add ($bfloat x) (mul '$%i ($bfloat y)))))
                            (setq z ($rectform `((mexpt simp) $%e ,z)))
-                           (return ($bfloat z))))))))
+                           (return ($bfloat z)))))))
             (cond ((and $logsimp (among '%log pot)) (return (%etolog pot)))
                   ((and $demoivre (setq z (demoivre pot))) (return z))
                   ((and $%emode
diff --git a/tests/rtest16.mac b/tests/rtest16.mac
index c54f5ddcc..7f35b42b4 100644
--- a/tests/rtest16.mac
+++ b/tests/rtest16.mac
@@ -3384,6 +3384,20 @@ sublist
 kill(x);
 done;
 
+/* Bug #4757: "%e^2.0, %emode:false stays %e^2.0" */
+
+%e^2.0, %emode: true;
+7.38905609893065;
+
+%e^2.0, %emode: false;
+7.38905609893065;
+
+%e^(%i*%pi), %emode: true;
+-1;
+
+string(%e^(%i*%pi)), %emode: false;
+"%e^(%i*%pi)";
+
 
 
 /* Leave this at the end of the file! */

-----------------------------------------------------------------------

Summary of changes:
 src/float.lisp    |  2 +-
 src/globals.lisp  |  3 +++
 src/matcom.lisp   | 56 ++++++++++++++++++++++++++++++++++++++++++++++---------
 src/simp.lisp     |  5 ++---
 src/suprv1.lisp   |  2 ++
 tests/rtest16.mac | 14 ++++++++++++++
 6 files changed, 69 insertions(+), 13 deletions(-)


hooks/post-receive
-- 
Maxima CAS