Description: <short summary of the patch>
 TODO: Put a short summary on the line above and replace this paragraph
 with a longer explanation of this change. Complete the meta-information
 with other relevant fields (see below for details). To make it easier, the
 information below has been extracted from the changelog. Adjust it or drop
 it.
 .
 gcl27 (2.7.0-34) unstable; urgency=medium
 .
   * Version_2_7_0pre37
   * Bug fix: "outdated debconf version constraint; inhibits support for
     debconf-2.0/cdebconf", thanks to Gioele Barabucci (Closes: #1096166).
Author: Camm Maguire <camm@debian.org>
Bug-Debian: https://bugs.debian.org/1096166

---
The information above should follow the Patch Tagging Guidelines, please
checkout https://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:

Origin: (upstream|backport|vendor|other), (<patch-url>|commit:<commit-id>)
Bug: <upstream-bugtracker-url>
Bug-Debian: https://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: (no|not-needed|<patch-forwarded-url>)
Applied-Upstream: <version>, (<commit-url>|commit:<commid-id>)
Reviewed-By: <name and email of someone who approved/reviewed the patch>
Last-Update: 2025-02-18

--- gcl27-2.7.0.orig/cmpnew/gcl_cmpeval.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpeval.lsp
@@ -1707,10 +1707,12 @@
 ;; 		(do-setq-tp v '(ccb-ref) (type-or1 (var-type v) (get (var-store v) 'ccb-tp)))
 ;; 		(setf (var-store v) +opaque+))))) *vars*))
 
+(defun bump-cons-tp (tp &aux (c (type-and tp #tcons))(p (type-and tp #tproper-cons)))
+  (type-or1 tp (if (type>= p c) #tproper-cons #tcons)))
 
 (defun do-ccb-ch (ccb-ch)
   (mapc (lambda (x &aux (v (pop x)))
-	  (do-setq-tp v '(ccb-ch) (type-or1 (var-type v) (info-type (cadr x))))
+	  (do-setq-tp v '(ccb-ch) (type-or1 (var-type v) (bump-cons-tp (info-type (cadr x)))))
 	  (push-vbind v x t))
 	ccb-ch))
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpfun.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpfun.lsp
@@ -392,9 +392,9 @@
 	 (otherwise x))))))
 
 (defun limit-list-call-args (form &aux (of form)(fn (pop of))
-				    (x (nthcdr (1- call-arguments-limit) of)))
-  (if x
-      `(nconc (list ,@(ldiff of x)) ,(limit-list-call-args (cons fn x)))
+				    (x (nthcdr (- call-arguments-limit 2) of)))
+  (if (cdr x)
+      `(list* ,@(ldiff of x) ,(limit-list-call-args (cons fn x)))
       form))
 
 (defun co1cons (f args &aux (tem (cons-to-listc args)))
@@ -574,3 +574,6 @@
 	   `(call-global ,info ,(if (cddr nargs) 'list* 'cons) ,nargs)))))
 (si::putprop 'list* 'c1list* 'c1)
 (si::putprop 'cons  'c1list* 'c1)
+
+(define-compiler-macro list  (&whole form) (limit-list-call-args form))
+(define-compiler-macro list* (&whole form) (limit-list-call-args form))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpif.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpif.lsp
@@ -266,9 +266,17 @@
 		     (when (vlp (first args))
 		       (list (cons (car (third (first args)))
 				   (tppra (vl-type (first args)) (second args) fn rfn))))
+		     (when (eq 'lit (car (first args)))
+		       (mapcar (lambda (x)
+				 (cons x (tppra (vl-type (first args)) (second args) fn rfn)))
+			       (local-aliases (get-top-var-binding (lit-bind (first args))) nil)))
 		     (when (vlp (second args))
 		       (list (cons (car (third (second args)))
-				   (tppra (vl-type (second args)) (first args) sfn srfn))))))
+				   (tppra (vl-type (second args)) (first args) sfn srfn))))
+		     (when (eq 'lit (car (second args)))
+		       (mapcar (lambda (x)
+				 (cons x (tppra (vl-type (second args)) (first args) sfn srfn)))
+			       (local-aliases (get-top-var-binding (lit-bind (second args))) nil)))))
 		   ((fmla-default fmla)))))
 	  (otherwise (fmla-default fmla)))))
 
@@ -406,19 +414,7 @@
 			   (when tret
 			     (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv)))))))
 
-		     (do (rv) ((not (setq rv (pop trv))))
-		       (cond ((var-p (car rv))
-			      (unless (subsetp (caddr rv) (var-store (car rv)))
-				(keyed-cmpnote
-				 (list (var-name (car rv)) 'var-store 'binding '+opaque+)
-				 "~s store set to +opaque+ from ~s/~s across if branches"
-				 (var-name (car rv)) (caddr rv) (var-store (car rv)))
-				(push-vbinds (car rv) (caddr rv)))
-			      (do-setq-tp (car rv) (list args nil) (type-or1 (var-type (car rv)) (cadr rv))))
-			     (t
-			      (keyed-cmpnote (list 'type-mod-unwind) "Unwinding type ~s ~s" (car rv) (cadr rv))
-			      (repl-tp (car rv) (cadr rv) t))))
-
+		     (or-branches trv)
 		     (list 'if info fmla tb fb))
 
 		 (dolist (l r)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpinline.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpinline.lsp
@@ -927,7 +927,7 @@
 	((append arg-type (make-list (max 0 (- (length type) (length arg-type))))))))
 
 (defun inline-type-matches (fname inline-info arg-types return-type &optional apnarg
-                                        &aux rts (flags (third inline-info)))
+                            &aux rts (flags (third inline-info)))
   (declare (ignore fname))
 
   (fix-opt inline-info)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpmain.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpmain.lsp
@@ -49,11 +49,11 @@
 (defvar *cmpinclude* "\"cmpinclude.h\"")
 ;;If the following is a string, then it is inserted instead of
 ;; the include file cmpinclude.h, EXCEPT for system-p calls.
-(defvar *cmpinclude-string* t)
-  ;; (si::file-to-string
-  ;;  (namestring
-  ;;   (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :back "h"))
-  ;; 		   :name "cmpinclude" :type "h"))))
+(defvar *cmpinclude-string* ;t)
+  (si::file-to-string
+   (namestring
+    (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :back "h"))
+		   :name "cmpinclude" :type "h"))))
 (defvar *compiler-default-type* #p".lsp")
 (defvar *compiler-normal-type* #p".lsp")
 (defvar *compile-file-truename* nil)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptag.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptag.lsp
@@ -353,9 +353,18 @@
   (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":"))))
 
 (defun or-branches (trv)
-  (mapc (lambda (x &aux (v (pop x))) 
-	  (do-setq-tp v (list 'or-branches nil) (type-or1 (var-type v) (car x)))
-	  (push-vbinds v (cadr x)))
+  (mapc (lambda (x &aux (v (pop x))(tp (pop x))(st (car x)))
+	  (cond ((var-p v)
+		 (unless (subsetp st (var-store v))
+		   (keyed-cmpnote
+		    (list (var-name v) 'var-store 'binding '+opaque+)
+		    "~s store set to +opaque+ from ~s/~s across if branches"
+		    (var-name v) st (var-store v))
+		   (push-vbinds v st))
+		 (do-setq-tp v (list 'or-branches nil) (type-or1 (var-type v) tp)))
+		(t
+		 (keyed-cmpnote (list 'type-mod-unwind) "Unwinding type ~s ~s" v tp)
+		 (repl-tp v tp t))))
 	trv))
 
 (defun c1switch (body)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptop.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptop.lsp
@@ -826,7 +826,7 @@
     (integer (format nil "~a" form)); string character
     (float (format nil "~10,,,,,,'eG" form))
     ((complex float)
-     (string-concatenate "(" (fm-to-string (realpart form)) " + I * " (fm-to-string (realpart form)) ")"))))
+     (string-concatenate "(" (fm-to-string (realpart form)) " + I * " (fm-to-string (imagpart form)) ")"))))
 
 (defun loc-str (x key ft &aux p (tt (get key 'cmp-lisp-type))(cast (strcat "(" key ")"))(pp (find #\* cast)))
   (string-concatenate
--- gcl27-2.7.0.orig/git.tag
+++ gcl27-2.7.0/git.tag
@@ -1,2 +1,2 @@
-"Version_2_7_0pre36"
+"Version_2_7_0pre37"
 
--- gcl27-2.7.0.orig/h/notcomp.h
+++ gcl27-2.7.0/h/notcomp.h
@@ -91,6 +91,7 @@ EXTER object user_package;
 #define make_macro_function(a_,b_) make_macro_internal(a_,FFN(b_))
 #define make_si_function(a_,b_) make_si_function_internal(a_,FFN(b_))
 #define make_special_form(a_,b_) make_special_form_internal(a_,FFN(b_))
+#define make_si_special_form(a_,b_) make_si_special_form_internal(a_,FFN(b_))
 #define make_macro_function(a_,b_) make_macro_internal(a_,FFN(b_))
 #define make_si_sfun(a_,b_,c_) make_si_sfun_internal(a_,FFN(b_),c_)
 #define STATD static
@@ -102,7 +103,7 @@ EXTER object user_package;
 #define make_macro_function(a_,b_) make_macro_internal(a_,b_)
 #define make_si_function(a_,b_) make_si_function_internal(a_,b_)
 #define make_special_form(a_,b_) make_special_form_internal(a_,b_)
-#define make_si_special_form(a_,b_) make_si_special_form_internal(a_,FFN(b_))
+#define make_si_special_form(a_,b_) make_si_special_form_internal(a_,b_)
 #define make_macro_function(a_,b_) make_macro_internal(a_,b_)
 #define make_si_sfun(a_,b_,c_) make_si_sfun_internal(a_,b_,c_)
 #define STATD
--- gcl27-2.7.0.orig/h/pool.h
+++ gcl27-2.7.0/h/pool.h
@@ -115,7 +115,7 @@ close_pool(void) {
   if (pool!=-1) {
     f.l_type=F_WRLCK;
     if (!fcntl(pool,F_SETLK,&f))
-      massert(!unlink(gcl_pool));
+      massert(!unlink(gcl_pool) || errno==ENOENT);
     register_pool(-1);
     massert(!close(pool));
     massert(!munmap(Pool,sizeof(struct pool)));
--- gcl27-2.7.0.orig/lsp/gcl_arraylib.lsp
+++ gcl27-2.7.0/lsp/gcl_arraylib.lsp
@@ -484,19 +484,26 @@
 (defun msdata-ref (d s)
   (structure-ref1 d (fifth (assoc s (structure-ref1 d 7)))));FIXME 7
 
-(defmacro str-refset (x s n &optional (v nil vp))
+(defmacro str-refset (x s n &optional (v nil vp)
+			      &aux (str (sgen "STR-REFSET"))(val (sgen "STR-REFSET")))
+  (declare (optimize (safety 1)))
   (assert (and (constantp s) (constantp n)))
   (let* ((s (eval s))(n (eval n))(?sd (eq s 's-data))
 	 (d (get s 's-data))
-	 (k (aref (if ?sd (msdata-ref d 'raw) (s-data-raw d)) n))
 	 (pos (aref (if ?sd (msdata-ref d 'slot-position) (s-data-slot-position d)) n))
-	 (l (nth k +array-type-info+))
-	 (cp (eq (car l) 'character))
-	 (v (when vp (if cp `(char-code ,v) v)))
-	 (res `(,(fifth l) (c-strstd-sself ,x) ,(ash pos (min 0 (- (1- (third l))))) ,(when vp t) ,v))
 	 (tp (car (last (nth n (if ?sd (msdata-ref d 'slot-descriptions) (s-data-slot-descriptions d))))))
-	 (res (if cp `(code-char ,res) res)))
-    (if (unless (eq tp t) tp) `(the ,tp ,res) res)))
+	 (k (aref (if ?sd (msdata-ref d 'raw) (s-data-raw d)) n))
+	 (l (nth k +array-type-info+))
+	 (off (ash pos (min 0 (- (1- (third l))))))
+	 (cp (eq (car l) 'character)))
+    (flet ((fm (x y)
+	     (let* ((res `(,(fifth l) (c-strstd-sself ,x) ,off ,(when y t) ,y))
+		    (res (if cp `(code-char ,res) res)))
+	       (if (unless (eq tp t) tp) `(the ,tp ,res) res))))
+      (if vp
+	  `(let ((,str ,x)(,val ,(if cp `(char-code ,v) v)));FIXME sgc-touch would go here
+	     ,(fm str val))
+	  (fm x nil)))))
 
 (defun *-propagator (f t1 t2 t3 t4)
   (declare (ignore t1 t2))
--- gcl27-2.7.0.orig/lsp/gcl_sharp.lsp
+++ gcl27-2.7.0/lsp/gcl_sharp.lsp
@@ -1,28 +1,29 @@
 (in-package :si)
 
-(defstruct
-  context
-  (vec (make-array 0 :adjustable t :fill-pointer t) :type (vector t))
+(defstruct context
+  (first 1 :type seqind)
+  (vec (make-array 10 :adjustable t :fill-pointer 0) :type (vector t))
   (hash nil :type (or null hash-table))
   (spice (make-hash-table :test 'eq :rehash-size 2.0) :type hash-table))
 
-(defun get-context (i)
-  (declare (fixnum i))
-  (when *sharp-eq-context*
-    (let ((v (context-vec *sharp-eq-context*)))
-      (if (< i (length v)) (aref v i)
-	(let ((h (context-hash *sharp-eq-context*)))
+(defun get-context (i &aux (ctxt *sharp-eq-context*))
+  (declare (seqind i))
+  (when ctxt
+    (let ((v (context-vec ctxt))(i (- i (context-first ctxt))))
+      (if (< -1 i (length v)) (aref v i)
+	(let ((h (context-hash ctxt)))
 	  (when h (gethash1 i h)))))))
 
 (defun push-context (i)
-  (declare (fixnum i))
-  (unless *sharp-eq-context* (setq *sharp-eq-context* (make-context)))
-  (let* ((v (context-vec *sharp-eq-context*))(l (length v))(x (cons nil nil)))
-    (cond ((< i l) (error "#~s= multiply defined" i))
-	  ((= i l) (vector-push-extend x v (1+ l)) x)
-	  ((let ((h (context-hash *sharp-eq-context*)))
+  (declare (seqind i))
+  (unless *sharp-eq-context* (setq *sharp-eq-context* (make-context :first i)))
+  (let* ((ctxt *sharp-eq-context*)(v (context-vec ctxt))
+	 (l (length v))(x (cons nil nil))(i (- i (context-first ctxt))))
+    (cond ((< -1 i l) (error "#~s= multiply defined" i))
+	  ((eql i l) (vector-push-extend x v (1+ l)) x)
+	  ((let ((h (context-hash ctxt)))
 	     (if h (when (gethash1 i h) (error "#~s= multiply defined" i)) 
-	       (setf (context-hash *sharp-eq-context*) (setq h (make-hash-table :test 'eql :rehash-size 2.0))))
+	       (setf (context-hash ctxt) (setq h (make-hash-table :test 'eql :rehash-size 2.0))))
 	     (setf (gethash i h) x))))))
 
 (defconstant +nil-proxy+ (cons nil nil))
--- gcl27-2.7.0.orig/o/run_process.c
+++ gcl27-2.7.0/o/run_process.c
@@ -613,13 +613,13 @@ FFN(siLrun_process)() {
     FEwrong_no_args("RUN-PROCESS requires two arguments",make_fixnum(vs_top-vs_base));
   check_type_string(&vs_base[0]);
 
-  massert(snprintf(FN1,sizeof(FN1),"%.*s%n",vs_base[0]->st.st_fillp,vs_base[0]->st.st_self,&i)>=0);
+  massert(snprintf(FN1,sizeof(FN1),"%.*s%n",VLEN(vs_base[0]),vs_base[0]->st.st_self,&i)>=0);
 
   x=vs_base[1];
   for (;x!=Cnil;x=x->c.c_cdr,i+=j) {
     check_type_list(&x);
     check_type_string(&x->c.c_car);
-    massert(snprintf(FN1+i,sizeof(FN1)-i," %.*s %n",x->c.c_car->st.st_fillp,x->c.c_car->st.st_self,&j)>=0);
+    massert(snprintf(FN1+i,sizeof(FN1)-i," %.*s %n",VLEN(x->c.c_car),x->c.c_car->st.st_self,&j)>=0);
   }
 
   for (pp=p1=(void *)FN2,c=FN1;(*pp=strtok(c,spc));c=NULL,pp++)
