From 0000000000000000000000000000000000000000 Mon Sep 17 00:00:00 2001
From: Camm Maguire <camm@debian.org>
Date: Nov, 07 2026 22:09:35 +0000
Subject: [PATCH] <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.

---
The information above should follow the Patch Tagging Guidelines,
see 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-<Vendor>: <vendor-bugtracker-url>
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>

--- gcl27-2.7.1.orig/Makefile.am
+++ gcl27-2.7.1/Makefile.am
@@ -289,7 +289,7 @@ unixport/gcl_cmpnopt_pre_gcl.lsp: # FIXM
 	touch $@
 unixport/gcl_cmpnopt_%.lsp: unixport/lib%.a | unixport/%
 	echo "(clrhash compiler::*inl-hash*)" \
-             "(mapc (quote load) (directory \"$*/*.hsh\"))" \
+             "(mapc (quote load) (sort (directory \"$*/*.hsh\") (quote string<) :key (quote namestring)))" \
 	     "(compiler::dump-inl-hash \"$@\")" | $|
 
 $(addprefix unixport/lib,$(addsuffix .a,pre_gcl $(MY_DIRS))): \
@@ -382,7 +382,7 @@ $(addprefix gcl0/,$(LL_OBJS)): gcl0/%.o
 $(addprefix gcl0/,$(LC_OBJS)): gcl0/%.o : cmpnew/%.lsp
 gcl0/%.o: | unixport/gcl0
 	rm -f $(@D)/$*.done
-	$(word 1,$|) -eval "(mapc 'load (directory \"$(@D)/*.done\"))" -compile $< -o $@
+	$(word 1,$|) -eval "(mapc 'load (sort (directory \"$(@D)/*.done\") (quote string<) :key (quote namestring)))" -compile $< -o $@
 	[ "$*" = "gcl_seqlib" ] || [ "$*" = "gcl_evalmacros" ] || [ "$*" = "gcl_top" ] || \
 	[ "$*" = "gcl_c" ] || [ "$*" = "gcl_listlib" ] || \
 		ln -f $@ $$(echo $@ |sed 's,\.o,\.done,g') #FIXME directory link, clang variadic pointer bug
@@ -391,7 +391,7 @@ $(addprefix gcl1/,$(LL_OBJS)): gcl1/%.o
 $(addprefix gcl1/,$(LC_OBJS)): gcl1/%.o : cmpnew/%.lsp
 gcl1/%.o: | unixport/gcl1
 	rm -f $(@D)/$*.done
-	$| -eval "(mapc 'load (directory \"$(@D)/*.done\"))" \
+	$| -eval "(mapc 'load (sort (directory \"$(@D)/*.done\") (quote string<) :key (quote namestring)))" \
 	   -eval "(setq compiler::*dump-inl-hash* t)" \
 	   -compile $< -o $@
 	[ "$*" = "gcl_sym" ] || ln -f $@ $$(echo $@ |sed 's,\.o,\.done,g') # FIXME listlib must come before sym
@@ -432,12 +432,14 @@ mod_gcl/%.o: mod_gcl0/%.o | unixport/mod
 	     "(si::do-recomp2 \
 		\"$@\" \
 		(mapcar (quote namestring) \
-		  (directory \
+		  (sort \
+		    (directory \
 		     (merge-pathnames \
 			\"*.*p\" \
 			(make-pathname \
 			  :directory (pathname-directory \
-				        (si::file (quote pcl::renew-sys-files))))))))" | $|
+				        (si::file (quote pcl::renew-sys-files)))))) \
+                    (quote string<) :key (quote namestring))))" | $|
 %/p1.lisp: | unixport/%
 	echo "(in-package :si)" \
 	     "(export (quote %structure-name))" \
--- gcl27-2.7.1.orig/ansi-tests/subtypep-cons.lsp
+++ gcl27-2.7.1/ansi-tests/subtypep-cons.lsp
@@ -428,3 +428,21 @@
      'si::proper-list
      '(cons t (cons t (not si::proper-list))))
   nil)
+
+(defun subtypep.cons.53.foo (x) (declare (ignore x)) (= 1 (random 2)))
+(defun subtypep.cons.53.bar (x) (declare (ignore x)) (= 1 (random 2)))
+(defun subtypep.cons.53.baz (x) (declare (ignore x)) (= 1 (random 2)))
+(defun subtypep.cons.53.qux (x) (declare (ignore x)) (= 1 (random 2)))
+
+(deftest subtypep.cons.53
+    (let* ((t1 `(cons (not float)))
+           (t2 `(or (cons (satisfies subtypep.cons.53.foo)
+                          (satisfies subtypep.cons.53.bar))
+                    (cons (satisfies subtypep.cons.53.baz)
+                          (satisfies subtypep.cons.53.qux)))))
+      (multiple-value-bind (sub1 good1)
+          (subtypep* t1 t2)
+        (multiple-value-bind (sub2 good2)
+            (subtypep* `(not ,t2) `(not ,t1))
+          (and (not sub1) (not sub2) (not good1) (not good2)))))
+  t)
--- gcl27-2.7.1.orig/cmpnew/gcl_cmpeval.lsp
+++ gcl27-2.7.1/cmpnew/gcl_cmpeval.lsp
@@ -2049,7 +2049,7 @@
      (when (or tp (eq otp tp))
        (mi2 fun args last fms (ff-env (or ff fun))))
      (when (member-if-not 'identity fms :key (lambda (x) (info-type (cadr x))))
-       (c1progn args fms))
+       (c1progn (if last (append args (list last)) args) fms))
      (mi5 (or (when (symbolp fun) fun) ff) info fms last))))
 
 
--- gcl27-2.7.1.orig/cmpnew/gcl_cmpflet.lsp
+++ gcl27-2.7.1/cmpnew/gcl_cmpflet.lsp
@@ -56,7 +56,7 @@
 	                        ;;;     (let ((v9 a)) (- (%f8) v9))))
 	                        ;;;           (defun foo (a) (flet ((%f8 nil (setq a 2)))
                                 ;;;     (* a (%f8))))
-	   (call (make-list 6));FIXME
+	   (call (list '((*)*) nil nil nil nil nil));FIXME
 	   vv src c1 c1cb fn)
 
 (defun local-fun-fn (id)
--- gcl27-2.7.1.orig/cmpnew/gcl_cmpfun.lsp
+++ gcl27-2.7.1/cmpnew/gcl_cmpfun.lsp
@@ -180,18 +180,33 @@
 	    (keep-vars) (mapc 'eliminate-src (ldiff *prov-src* ops)) res)))
     (progn ,@body)))
 
+(define-compiler-macro apply (&whole form &rest args &aux (sym (sgen "ACM")))
+  (if (symbolp (car args)) form
+      `(let ((,sym ,(car args)))
+	 (,(car form) ,sym ,@(cdr args)))))
+
 (defun c1apply (args)
   (when (or (endp args) (endp (cdr args)))
     (too-few-args 'apply 2 (length args)))
   (try-provisional-functions
    (let* ((ff (c1arg (car args)))(args (cdr args))(fid (coerce-ff ff)))
-     (if (eq fid 'funcall) (c1apply args) (mi1 fid (butlast args) (car (last args)) ff)))))
+      (if (eq fid 'funcall)
+	  (c1apply args)
+	  (mi1 fid (butlast args) (car (last args)) ff)))))
+
+(define-compiler-macro funcall (&whole form &rest args &aux (sym (sgen "FCM")))
+  (if (symbolp (car args)) form
+      `(let ((,sym ,(car args)))
+	 (,(car form) ,sym ,@(cdr args)))))
 
 (defun c1funcall (args)
   (when (endp args) (too-few-args 'funcall 1 0))
   (try-provisional-functions
    (let* ((ff (c1arg (car args)))(args (cdr args))(fid (coerce-ff ff)))
-     (case fid (funcall (c1funcall args))(apply (c1apply args)) (otherwise (mi1 fid args nil ff))))))
+     (case fid
+       (funcall (c1funcall args))
+       (apply (c1apply args))
+       (otherwise (mi1 fid args nil ff))))))
 
 
 ;; (defun c1funcall-apply (args &optional last)
--- gcl27-2.7.1.orig/cmpnew/gcl_cmptop.lsp
+++ gcl27-2.7.1/cmpnew/gcl_cmptop.lsp
@@ -1457,12 +1457,13 @@
 
 (defun if1 (f)
   (when (info-type f)
-    (flet ((tbp (l) (member-if (lambda (x) (or (tag-p x) (blk-p x))) l)))
-      (not (or (info-ch f)
-	       (tbp (info-ref     f))
-	       (tbp (info-ref-ccb f))
-	       (tbp (info-ref-clb f))
-	       (/= 0 (logand (info-flags f) (iflags side-effects compiler))))))))
+    (unless (iflag-p (info-flags f) provisional)
+      (flet ((tbp (l) (member-if (lambda (x) (or (tag-p x) (blk-p x))) l)))
+	(not (or (info-ch f)
+		 (tbp (info-ref     f))
+		 (tbp (info-ref-ccb f))
+		 (tbp (info-ref-clb f))
+		 (/= 0 (logand (info-flags f) (iflags side-effects compiler)))))))))
   
 (defun ignorable-form (f)
   (case (car f)
--- gcl27-2.7.1.orig/cmpnew/gcl_cmptype.lsp
+++ gcl27-2.7.1/cmpnew/gcl_cmptype.lsp
@@ -848,11 +848,13 @@
 (si::putprop 'car 'car-propagator 'type-propagator)
 
 (defun contagion (t1 t2)
-  (car (member (type-or1 t1 t2) `(,#tlong-float ,#tshort-float #tratio #tinteger)
-	       :test 'type-and)))
+  (let ((x (car (member (type-or1 t1 t2) `(,#tlong-float ,#tshort-float #tratio #tinteger)
+			:test 'type-and))))
+    (if (tp<= x #tratio) #trational x)))
+
 (defun mod-propagator (f t1 t2 &aux (t1 (type-and #treal t1))(t2 (type-and #treal t2))
 				 (r1 (range-decomp t1))(r2 (range-decomp t2)))
-  (declare (ignore f))
+  (declare (ignorable f))
   (cond
    ((cdr r1) (reduce 'type-or1 (mapcar (lambda (x) (mod-propagator f (cdr x) t2)) r1) :initial-value nil))
    ((cdr r2) (reduce 'type-or1 (mapcar (lambda (x) (mod-propagator f t1 (cdr x))) r2) :initial-value nil))
@@ -955,6 +957,7 @@
 (si::putprop 'expt 'expt-propagator 'type-propagator)
 
 (defun scale-float-propagator (f t1 t2)
+  (declare (ignore f))
   (super-range '* t1 (expt-propagator 'expt #t(integer 2 2) t2)))
 (si::putprop 'scale-float 'scale-float-propagator 'type-propagator)
 
--- gcl27-2.7.1.orig/git.tag
+++ gcl27-2.7.1/git.tag
@@ -1 +1 @@
-"Version_2_7_2pre43"
+"Version_2_7_2pre44"
--- gcl27-2.7.1.orig/lsp/gcl_assert.lsp
+++ gcl27-2.7.1/lsp/gcl_assert.lsp
@@ -65,12 +65,11 @@
        (apply 'assert-places ',places (list ,@places)
 	      ,@(if string `(,string (list ,@args)) `("The assertion ~:@(~S~) failed." ',test-form nil))))))
 
-(defmacro ctypecase (keyform &rest clauses &aux (key (sgen "CTYPECASE")))
-  (declare (optimize (safety 2)))
-;  (check-type clauses (list-of proper-list))
-  `(do nil (nil)
-    (typecase ,keyform
-      ,@(mapcar (lambda (l)
-		  `(,(car l) (return (progn ,@(subst key keyform (cdr l))))))
-		clauses))
-    (check-type ,keyform (or ,@(mapcar 'car clauses)))))
+(defmacro ctypecase (keyform &rest clauses &aux (ctf (sgen "CTYPECASE")))
+  `(labels ((ctf nil
+	      (typecase
+		  ,keyform ,@clauses
+		  (otherwise
+		   (check-type ,keyform (or ,@(mapcar 'car clauses)))
+		   (ctf)))))
+     (ctf)))
--- gcl27-2.7.1.orig/lsp/gcl_defstruct.lsp
+++ gcl27-2.7.1/lsp/gcl_defstruct.lsp
@@ -431,7 +431,7 @@
 	   (or tem (setf (get name 's-data) def)))
 	  (tem 
 	   (check-s-data tem def name))
-	  (t (setf (get name 's-data) def) (update-sdata-included name)))
+	  (t (setf (get name 's-data) def) (update-sdata-included name)));FIXME get-slot-pos here for recursive slot types
     (when documentation
 	  (setf (get name 'structure-documentation) documentation))
     (when (and (null type) predicate)
@@ -537,9 +537,9 @@
     (when (and print-function print-object)
       (error "Cannot specify both :print-function and :print-object."))
     (when print-object
-      (setq print-function (lambda (x y z) 
+      (setq print-function `(lambda (x y z)
 			     (declare (optimize (safety 2)))
-			     (declare (ignore z)) (funcall print-object x y))))
+			     (declare (ignore z)) (funcall ,print-object x y))))
 
     (and include (not print-function)
 	 (setq print-function (s-data-print-function (get (car include)  's-data))))
--- gcl27-2.7.1.orig/lsp/gcl_deftype.lsp
+++ gcl27-2.7.1/lsp/gcl_deftype.lsp
@@ -213,7 +213,8 @@
 
 (deftype stream nil
   `(or broadcast-stream concatenated-stream echo-stream
-       file-stream string-stream synonym-stream two-way-stream))
+       file-stream string-stream synonym-stream two-way-stream
+       user-defined-stream socket-stream))
 (deftype file-stream nil
   `(or file-input-stream file-output-stream file-io-stream file-probe-stream))
 (deftype path-stream nil
--- gcl27-2.7.1.orig/lsp/gcl_iolib.lsp
+++ gcl27-2.7.1/lsp/gcl_iolib.lsp
@@ -526,7 +526,8 @@
      (stream-element-type (symbol-value (c-stream-object0 s))))
     (file-stream;define socket
      (c-stream-object0 s))
-    (t 'character)))
+    (string-stream 'character)
+    (t '(unsigned-byte 8))))
 
 (deftype binary-stream-element-type nil 'list)
 (defconstant +char-shft+ (1- (integer-length char-length)))
--- gcl27-2.7.1.orig/lsp/gcl_predlib.lsp
+++ gcl27-2.7.1/lsp/gcl_predlib.lsp
@@ -276,7 +276,8 @@
 				      file-input-stream file-output-stream
 				      file-io-stream file-probe-stream
 				      string-input-stream string-output-stream
-				      file-synonym-stream non-file-synonym-stream two-way-stream 
+				      file-synonym-stream non-file-synonym-stream two-way-stream
+				      user-defined-stream socket-stream
 				      non-logical-pathname logical-pathname
 				      readtable 
 				      hash-table-eq hash-table-eql hash-table-equal hash-table-equalp
--- gcl27-2.7.1.orig/lsp/gcl_seqlib.lsp
+++ gcl27-2.7.1/lsp/gcl_seqlib.lsp
@@ -347,10 +347,10 @@
   (check-type seq proper-sequence)
   (let* ((ll (length seq))
 	 (list (listp seq))
-	 (a (when list (make-array ll))))
+	 (a (when (and list seq) (make-array ll))))
     (when list
       (do ((fi 0 (1+ fi)) (l seq (cdr l))) ((>= fi ll)) (setf (aref a fi) l)))
-    (do ((ii (list ll 0))) ((not ii) seq)
+    (do ((ii (list ll 0))) ((not ii) (if a (aref a 0) seq)); or could "spoil" (car l) above
 	(declare (dynamic-extent ii))
 	(let* ((ls (pop ii)) (fi (pop ii)))
 	  (declare (seqind ls fi))
--- gcl27-2.7.1.orig/lsp/gcl_setf.lsp
+++ gcl27-2.7.1/lsp/gcl_setf.lsp
@@ -45,14 +45,15 @@
 (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
 
 (defvar *setf-syms* nil)
-(defvar *setf-set* nil)
 (defconstant +setf-prefix+ "SETF")
 (defconstant +setf-syms+ (let ((*gensym-counter* 0))
 			   (mapl (lambda (x) (rplaca x (gensym +setf-prefix+)))
 				   (make-list 19))))
-;(defun setf-set nil (setq *setf-syms* nil *gensym-counter* 0))
-;(defun setf-set nil (or *setf-set* (setq *setf-syms* +setf-syms+)));FIXME, this does not seem possible
-(defun setf-gensym nil (if *setf-syms* (prog1 (car *setf-syms*) (setq *setf-syms* (cdr *setf-syms*))) (gensym +setf-prefix+)))
+
+(defun setf-gensym nil
+  (if *setf-syms*
+      (prog1 (car *setf-syms*) (setq *setf-syms* (cdr *setf-syms*)))
+      (gensym +setf-prefix+)))
 
 ;;; DEFSETF macro.
 (defmacro defsetf (access-fn &rest rest)
@@ -99,15 +100,18 @@
    (cond (env (setq args (cons env args)))
 	 ((setq args (cons (sgen "DEFINE-SETF-METHOD") args))
 	  (push `(declare (ignore ,(car args))) body)))
+   (multiple-value-bind
+    (doc decls ctps body) (parse-body-header body)
+    (declare (ignore doc))
    `(eval-when (compile eval load)
 	       (si:putprop ',access-fn
-			   #'(lambda ,args (block ,access-fn ,@body)) 'setf-method);(*setf-set* (setf-set))
+			   #'(lambda ,args ,@decls ,@ctps (block ,access-fn ,@body)) 'setf-method)
 	       (remprop ',access-fn 'setf-lambda)
 	       (remprop ',access-fn 'setf-update-fn)
 	       (si:putprop ',access-fn
 			   ,(find-documentation (cdr rest))
 			   'setf-documentation)
-	       ',access-fn)))
+	       ',access-fn))))
 
 (defmacro define-setf-expander (access-fn &rest rest)
   (declare (optimize (safety 2)))
@@ -132,7 +136,7 @@
 ;; FIXME  when all is well, remove this and the setf tests in the pcl directory
 (push :setf *features*)
 
-(defun get-setf-method-multiple-value (form &optional env &aux tem); (*setf-set* (setf-set))
+(defun get-setf-method-multiple-value (form &optional env &aux tem)
   (flet ((mvars (form) (mapcar (lambda (x) (declare (ignore x)) (setf-gensym)) (cdr form))))
     (cond ((symbolp form)
 	   (let ((store (setf-gensym)))
@@ -359,31 +363,25 @@
 
 ;;; The expansion function for SETF.
 (defun setf-expand-1 (place newvalue env &aux g)
-  (when (and (consp place) (eq (car place) 'the))
-        (return-from setf-expand-1
-          (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env)))
-  (when (and (consp place) (eq (car place) 'values))
-    (return-from setf-expand-1 (setf-expand-values (cdr place) newvalue env)))
-  (when (symbolp place)
-        (return-from setf-expand-1 `(setq ,place ,newvalue)))
-  (when (and (consp place)
-	       (not (or (get (car place) 'setf-lambda)
-			(get (car place) 'setf-update-fn))))
-	  (multiple-value-setq (place g) (macroexpand place env))
-	  (if g (return-from setf-expand-1 (setf-expand-1 place newvalue env))))
-  (when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn)))
-    (return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue)))
-  (cond ((and (symbolp (car place))
-	      (setq g (get (car place) 'structure-access)))
-	 (return-from setf-expand-1
-	   (setf-structure-access (cadr place) (car g) (cdr g) newvalue))))
-	     
-  (multiple-value-bind (vars vals stores store-form access-form)
-      (get-setf-expansion place env)
-    (declare (ignore access-form))
-    `(let* ,(mapcar 'list (append vars stores) (append vals (list newvalue)))
-       (declare (ignorable ,@vars))
-       ,store-form)))
+  (etypecase place
+    (symbol `(setq ,place ,newvalue))
+    ((cons symbol t)
+     (let ((sym (car place)))
+       (cond ((eq sym 'the) (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env))
+	     ((eq sym 'values) (setf-expand-values (cdr place) newvalue env))
+	     ((setq g (get sym 'setf-update-fn)) `(,g ,@(cdr place) ,newvalue))
+	     ((unless (get sym 'setf-lambda)
+		(multiple-value-bind (place g) (macroexpand place env)
+		  (when g
+		    (setf-expand-1 place newvalue env)))))
+	     ((setq g (get sym 'structure-access))
+	      (setf-structure-access (cadr place) (car g) (cdr g) newvalue))
+	     ((multiple-value-bind (vars vals stores store-form access-form)
+		  (get-setf-expansion place env)
+		(declare (ignore access-form))
+		`(let* ,(mapcar 'list (append vars stores) (append vals (list newvalue)))
+		   (declare (ignorable ,@vars))
+		   ,store-form))))))))
 
 (defun setf-structure-access (struct type index newvalue)
   (case type
--- gcl27-2.7.1.orig/lsp/gcl_subtypep.lsp
+++ gcl27-2.7.1/lsp/gcl_subtypep.lsp
@@ -585,15 +585,173 @@
 	   (lreduce (lambda (ll l) (?cns (k-op 'not l nil d) ll)) l :initial-value nil)
 	   d u x)))
 
-(defun ntp-list (op lx ly d dx dy)
-  (lreduce (lambda (ll l &aux (ny (assoc (car l) ly)))
-	     (?cns (cond (ny (k-op op l ny d)) (dy l)) ll))
-	   lx :initial-value
-	   (when dx
-	     (lreduce (lambda (ll l) (?cns (unless (assoc (car l) lx) l) ll))
-		      ly :initial-value nil))))
+;; UNKNOWN type simplification
 
-(defun ntp-subtp (x y) (ntp-and?c2-nil-p x y t))
+(defun bspf (f)
+  (if (atom f)
+      (not (eq f 'satisfies))
+      (and (bspf (car f)) (bspf (cdr f)))))
+
+(defun bcol (f &aux l)
+  (labels ((u (f)
+	     (if (when (consp f) (eq (car f) 'not))
+		 `(not ,(u (cadr f)))
+		 (car (or (member f l :test 'equal)
+			  (push f l)))))
+	   (w (f)
+	     (if (atom f) (list f nil)
+		 (case (car f)
+		   (satisfies (list (u f) t))
+		   ((and or)
+		    (let ((x (mapcar #'w (cdr f))))
+		      (if (member t x :key 'cadr)
+			  (list (cons (car f) (mapcar (lambda (x) (if (cadr x) (car x) (u (car x)))) x)) t)
+			  (list f nil))))
+		   (not
+		    (let ((x (w (cadr f))))
+		      (list* `(not ,(car x)) (cdr x))))
+		   (otherwise (list f nil))))))
+    (let ((x (w f)))
+      (list (car x) (or l (list (car x)))))))
+
+(defun bval (l)
+  (labels ((bw (f)
+	     (if f
+		 (let ((y (bw (cdr f))))
+		   (nconc (mapcar (lambda (x) (cons (caar  f) x)) y)
+			  (mapcar (lambda (x) (cons (cadar f) x)) y)))
+		 (list nil))))
+    (bw (mapcar (lambda (x) (list x `(not ,x))) l))))
+
+(defun bmabv (ll &optional (i (1+ ll))(j ll))
+  (when (plusp j)
+      (cons (eql (- ll j) i) (bmabv ll i (1- j)))))
+
+(defun bmabit-and (x y &optional z)
+  (if z
+      (mapl (lambda (x y) (setf (car x) (and (car x) (car y)))) x y)
+      (mapcar 'and x y)))
+
+(defun bmabit-ior (x y &optional z)
+  (if z
+      (mapl (lambda (x y) (setf (car x) (or (car x) (car y)))) x y)
+      (mapcar 'or x y)))
+
+(defun bmabit-not (x &optional z)
+  (if z
+      (mapl (lambda (x) (setf (car x) (not (car x)))) x)
+      (mapcar 'not x)))
+
+(defun bmabit-p (x i)
+  (nth i x))
+
+(defun bmval (l &aux (i -1) (ll (length l)))
+  (mapcar (lambda (x) (cons x (bmabv ll (incf i)))) l))
+
+(defun bmv (l ll)
+  (labels ((bmabit-iort (x y) (bmabit-ior x y t)))
+    (let ((x (mapcar 'cdr (lremove l ll :test (lambda (x y) (not (member x y))) :key 'car))))
+      (lreduce #'bmabit-iort (cdr x)
+	       :initial-value
+	       (or (copy-seq (car x))
+		   (bmabv (length ll)))))))
+
+(defun bsimp (f l
+	      &aux (a (mapcar (lambda (x) (cons x (bmv x l))) (caar l)))
+		(ll (length l))(vn (bmabv ll))(vt (bmabit-not vn)))
+  (labels ((bmabit-andt (x y) (bmabit-and x y t))
+	   (bmabit-iort (x y) (bmabit-ior x y t))
+	   (sw (f)
+	     (or (cdr (assoc f a))
+		 (if (atom f) (error "Bad form in bsimp")
+		     (ecase (car f)
+		       (and
+			(let ((x (mapcar #'sw (cdr f))))
+			  (lreduce #'bmabit-andt (cdr x) :initial-value (copy-seq (or (car x) vt)))))
+		       (or
+			(let ((x (mapcar #'sw (cdr f))))
+			  (lreduce #'bmabit-iort (cdr x) :initial-value (copy-seq (or (car x) vn)))))
+		       (not
+			(bmabit-not (sw (cadr f)))))))))
+    (sw f)))
+
+(defun br1 (l a)
+  (when l
+    (let* ((x (pop l))(lx (length x))
+	   (y (br1 l a)) r
+	   (z (member-if
+	       (lambda (w)
+		 (when (eql lx (length w))
+		   (setq r (lreduce (lambda (y x)
+				     (cond ((eq (car x) (cdr x)) y)
+					   ((not (eq (car x) (cdr (assoc (cdr x) a)))) nil)
+					   ((eq y t) (car x))))
+				   (mapcar 'cons x w) :initial-value t))))
+	       y)))
+      (if z (br1 (cons (lremove r x) (lremove (car z) y)) a) (cons x y)))))
+
+(defun brst (l &aux (m (lreduce 'max l :key 'length :initial-value 0)))
+  (labels ((brst1 (i)
+	     (when (<= i m)
+	       (append (lremove i l :test (lambda (x y) (not (eql x (length y)))))
+		       (brst1 (1+ i))))))
+    (brst1 0)))
+
+(defun br2 (l a)
+  (when l
+    (if (cdar l) l
+      (let* ((c (car l)))
+	(cons c (br2 (brst (mapcar (lambda (x) (lremove (cdr (assoc (car c) a)) x)) (cdr l))) a))))))
+
+(defun br3 (l)
+  (when l
+    (let* ((x (pop l)))
+      (cons x (lremove x (br3 l) :test 'subsetp)))))
+
+(defun br4u (x y a p)
+  (labels ((mm (x l) (or (member (car x) l) (member (cdr x) l))))
+    (car
+     (member
+      (mapcan (lambda (z &aux (q (mm z x))(w (mm z y)))
+	      (cond ((and q w) (if (eq (car q) (car w)) (list (car q)) (return-from br4u nil)))
+		    (q (list (car q)))
+		    (w (list (car w)))))
+	      (ldiff a (nthcdr (ash (length a) -1) a)))
+      p :test 'equal))))
+
+(defun br4 (p a)
+  (labels ((mtrp (l)
+	     (when l
+	       (let ((x (pop l)))
+		 (nconc
+		  (mapcan (lambda (cx &aux (ncx (cdr (assoc cx a))))
+			   (mapcan (lambda (y)
+				     (when (member ncx y)
+				       (let ((z (br4u (lremove cx x) (lremove ncx y) a p)))
+					 (when z
+					   (list (list x y z))))))
+				   l))
+			  x)
+		  (mtrp l)))))
+	   (tcmp (x y) (or (equal (caddr x) (car y)) (equal (caddr x) (cadr y))))
+	   (tred (l) (when l (let* ((x (pop l))(y (tred l))) (if (member x y :test #'tcmp) y (cons x y))))))
+    (set-difference p (mapcar 'caddr (tred (mtrp p))))))
+
+(defun brr (bv ll)
+  (labels ((ma (x y) (nconc (mapcar 'cons x y) (mapcar 'cons y x)))
+	   (mr (bv &aux (i -1)) (mapcan (lambda (x) (when (bmabit-p bv (incf i)) (list (car x)))) ll)))
+    (let* ((a (ma (caar ll) (caar (last ll))))
+	   (x (br4 (br3 (br2 (brst (br1 (mr bv) a)) a)) a))
+	   (x (mapcar (lambda (x) (if x (if (cdr x) (cons 'and x) (car x)) (return-from brr t))) x)))
+      (if (and x (cdr x)) (cons 'or x) (car x)))))
+
+(defun saoutps (op t1 t2)
+  (let* ((l `(,op ,t1 ,t2))
+	 (c (bcol l))
+	 (ll (bmval (bval (cadr c))))
+	 (r (brr (bsimp (car c) ll) ll)))
+    (unless (bspf r)
+      r)))
 
 (defun ntp-and-unknown (ox lx ux oy ly uy d)
   (let* ((xx (if ux (pop lx) ox))(xy (if uy (pop ly) oy))(x (ntp-and xx xy))
@@ -601,11 +759,10 @@
     (cond ((ntp-subtp x m) x)
 	  ((unless ux (ntp-subtp xy xx)) oy)
 	  ((unless uy (ntp-subtp xx xy)) ox)
-	  ((list (list x m
-		       (let ((x (if ux (car lx) (car (nreconstruct-type ox))))
-			     (y (if uy (car ly) (car (nreconstruct-type oy)))))
-			 (if (equal x y) x `(and ,x ,y))))
-		 d t)))))
+	  ((let ((z (saoutps 'and
+			     (if ux (car lx) (car (nreconstruct-type ox)))
+			     (if uy (car ly) (car (nreconstruct-type oy))))))
+	     (if z (list (list x m z) d t) m))))))
 
 (defun ntp-or-unknown (ox lx ux oy ly uy d)
   (let* ((xx (if ux (pop lx) ox))(xy (if uy (pop ly) oy))(x (ntp-or xx xy))
@@ -613,11 +770,20 @@
     (cond ((ntp-subtp x m) x)
 	  ((unless ux (ntp-subtp mx my)) oy)
 	  ((unless uy (ntp-subtp my mx)) ox)
-	  ((list (list x m
-		       (let ((x (if ux (car lx) (car (nreconstruct-type ox))))
-			     (y (if uy (car ly) (car (nreconstruct-type oy)))))
-			 (if (equal x y) x `(or ,x ,y))))
-		 d t)))))
+	  ((let ((z (saoutps 'or
+			     (if ux (car lx) (car (nreconstruct-type ox)))
+			     (if uy (car ly) (car (nreconstruct-type oy))))))
+	     (if z (list (list x m z) d t) x))))))
+
+(defun ntp-list (op lx ly d dx dy)
+  (lreduce (lambda (ll l &aux (ny (assoc (car l) ly)))
+	     (?cns (cond (ny (k-op op l ny d)) (dy l)) ll))
+	   lx :initial-value
+	   (when dx
+	     (lreduce (lambda (ll l) (?cns (unless (assoc (car l) lx) l) ll))
+		      ly :initial-value nil))))
+
+(defun ntp-subtp (x y) (ntp-and?c2-nil-p x y t))
 
 (defun ntp-and?c2-nil-p (x y ?c2)
   (let* ((x (if (caddr x) (caar x) x))(y (if (caddr y) (if ?c2 (cadar y) (caar y)) y))
@@ -715,6 +881,12 @@
 (defun resolve-type (type)
   (nreconstruct-type (nprocess-type (normalize-type type))))
 
+(defun ntp-unknown-p (ntp)
+  (labels ((cup (x) (when (consp x) (or (ntp-unknown-p (car x)) (ntp-unknown-p (cadr x))))))
+  (or (caddr ntp)
+      (member-if #'cup (cdr (assoc 'proper-cons (car ntp))))
+      (member-if #'cup (cdr (assoc 'improper-cons (car ntp)))))))
+
 (defun subtypep (t1 t2 &optional env)
   (declare (ignore env) (optimize (safety 1)))
   (check-type t1 full-type-spec)
@@ -722,8 +894,9 @@
   (if (or (not t1) (eq t2 t))
       (values t t)
       (let* ((n1 (nprocess-type (normalize-type t1)))
-	     (n2 (nprocess-type (normalize-type t2))))
-	(values (ntp-subtp n1 n2) (not (or (caddr n1) (caddr n2)))))))
+	     (n2 (nprocess-type (normalize-type t2)))
+	     (r (ntp-subtp n1 n2)))
+	(values r (or r (and (not (ntp-unknown-p n1)) (not (ntp-unknown-p n2))))))))
 
 
 
--- gcl27-2.7.1.orig/lsp/gcl_typeof.lsp
+++ gcl27-2.7.1/lsp/gcl_typeof.lsp
@@ -47,7 +47,9 @@
 		   (two-way-stream (allocate-basic-stream 8))
 		   (echo-stream (allocate-basic-stream 9))
 		   (string-input-stream (allocate-basic-stream 10))
-		   (string-output-stream (allocate-basic-stream 11));FIXME user defined, socket
+		   (string-output-stream (allocate-basic-stream 11))
+		   (user-defined-stream (allocate-basic-stream 12))
+		   (socket-stream (allocate-basic-stream 13))
 		   (random-state (make-random-state)) 
 		   (readtable (standard-readtable)) 
 		   (non-standard-object-compiled-function (function eq))
--- gcl27-2.7.1.orig/o/file.d
+++ gcl27-2.7.1/o/file.d
@@ -95,6 +95,19 @@ Foundation, 675 Mass Ave, Cambridge, MA
 #endif
 #include <errno.h>
 
+
+#ifdef USER_DEFINED_STREAMS
+#define STM_DATA_STRUCT 0
+#define STM_READ_CHAR 1
+#define STM_WRITE_CHAR 2
+#define STM_LISTEN 3
+#define STM_FORCE_OUTPUT 4
+#define STM_CLOSE 5
+#define STM_TYPE 6
+#define STM_UNREAD_CHAR 7
+#define STM_NAME 8
+#endif
+
 extern void tcpCloseSocket (int fd);
 
 object terminal_io;
@@ -517,6 +530,7 @@ tty_stream_p(object strm) {
   case smm_probe:
   case smm_string_input:
   case smm_string_output:
+  case smm_user_defined:
     return(FALSE);
 
   case smm_broadcast:
@@ -569,6 +583,23 @@ cannot_read(object);
 static void
 closed_stream(object);
 
+static object
+user_defined_call(object strm,uint8_t i,int c) {
+
+  object val;
+  object *old_vs_base = vs_base;
+  object *old_vs_top = vs_top;
+  vs_base = vs_top;
+  if (i==STM_WRITE_CHAR||i==STM_UNREAD_CHAR) vs_push(code_char(c));
+  vs_push(strm);
+  super_funcall(strm->sm.sm_object1->str.str_self[i]);
+  val = vs_base[0];
+  vs_base = old_vs_base;
+  vs_top = old_vs_top;
+  return val;
+
+}
+
 int
 readc_stream(object strm) {
 
@@ -637,25 +668,8 @@ readc_stream(object strm) {
     cannot_read(strm);
 #ifdef USER_DEFINED_STREAMS
   case smm_user_defined:
-#define STM_DATA_STRUCT 0
-#define STM_READ_CHAR 1
-#define STM_WRITE_CHAR 2
-#define STM_UNREAD_CHAR 7
-#define STM_FORCE_OUTPUT 4
-#define STM_PEEK_CHAR 3
-#define STM_CLOSE 5
-#define STM_TYPE 6
-#define STM_NAME 8
     {
-      object val;
-      object *old_vs_base = vs_base;
-      object *old_vs_top = vs_top;
-      vs_base = vs_top;
-      vs_push(strm);
-      super_funcall(strm->sm.sm_object1->str.str_self[STM_READ_CHAR]);
-      val = vs_base[0];
-      vs_base = old_vs_base;
-      vs_top = old_vs_top;
+      object val=user_defined_call(strm,STM_READ_CHAR,0);
       if (type_of(val) == t_fixnum)
 	return (fix(val));
       if (type_of(val) == t_character)
@@ -727,21 +741,7 @@ unreadc_stream(int c, object strm) {
 
 #ifdef USER_DEFINED_STREAMS
   case smm_user_defined:
-    {
-      object *old_vs_base = vs_base;
-      object *old_vs_top = vs_top;
-      vs_base = vs_top;
-      vs_push(strm);
-      /* if there is a file pointer and no define unget function,
-       * then call ungetc */
-      if ((strm->sm.sm_fp != NULL ) &&
-	  strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR] == Cnil)
-	kclungetc(c, strm->sm.sm_fp);
-      else
-	super_funcall(strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR]);
-      vs_top = old_vs_top;
-      vs_base = old_vs_base;
-    }
+    user_defined_call(strm,STM_UNREAD_CHAR,c);
     break;
 #endif
   default:
@@ -937,17 +937,8 @@ BEGIN:
 
 #ifdef USER_DEFINED_STREAMS
   case smm_user_defined:
-    {
-      object *old_vs_base = vs_base;
-      object *old_vs_top = vs_top;
-      vs_base = vs_top;
-      vs_push(strm);
-      vs_push(code_char(c));
-      super_funcall(strm->sm.sm_object1->str.str_self[2]);
-      vs_base = old_vs_base;
-      vs_top = old_vs_top;
-      break;
-    }
+    user_defined_call(strm,STM_WRITE_CHAR,c);
+    break;
 
 #endif
   default:
@@ -1004,16 +995,8 @@ flush_stream(object strm) {
     FEerror("Cannot flush the stream ~S.", 1, strm);
 #ifdef USER_DEFINED_STREAMS
   case smm_user_defined:
-    {
-      object *old_vs_base = vs_base;
-      object *old_vs_top = vs_top;
-      vs_base = vs_top;
-      vs_push(strm);
-      super_funcall(strm->sm.sm_object1->str.str_self[4]);
-      vs_base = old_vs_base;
-      vs_top = old_vs_top;
-      break;
-    }
+    user_defined_call(strm,STM_FORCE_OUTPUT,0);
+    break;
 
 #endif
 
@@ -1225,6 +1208,15 @@ BEGIN:
 	case smm_string_output:
 		FEerror("Can't listen to ~S.", 1, strm);
 		return(FALSE);
+
+#ifdef USER_DEFINED_STREAMS
+  case smm_user_defined:
+    {
+      object val=user_defined_call(strm,STM_LISTEN,0);
+      return(val);
+    }
+
+#endif
 	default:
 		FEerror("Illegal stream mode for ~S.",1,strm);
 		return(FALSE);
@@ -1613,7 +1605,7 @@ FFN(siLuser_stream_state)() {
   check_arg(1);
 
   if(vs_base[0]->sm.sm_object1)
-    vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[0];
+    vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[STM_DATA_STRUCT];
   else
     FEerror("sLtream data NULL ~S", 1, vs_base[0]);
 }
--- gcl27-2.7.1.orig/o/format.c
+++ gcl27-2.7.1/o/format.c
@@ -714,6 +714,7 @@ fmt_ascii(bool colon, bool atsign)
 	fmt_set_param(0, &mincol, fmt_int, 0);
 	mincol=BOUND_MINCOL(mincol);
 	fmt_set_param(1, &colinc, fmt_int, 1);
+	if (colinc<=0) fmt_error("Illegal column increment");
 	fmt_set_param(2, &minpad, fmt_int, 0);
 	fmt_set_param(3, &padchar, fmt_char, ' ');
 
@@ -775,6 +776,7 @@ fmt_S_expression(bool colon, bool atsign
 	fmt_set_param(0, &mincol, fmt_int, 0);
 	mincol=BOUND_MINCOL(mincol);
 	fmt_set_param(1, &colinc, fmt_int, 1);
+	if (colinc<=0) fmt_error("Illegal column increment");
 	fmt_set_param(2, &minpad, fmt_int, 0);
 	fmt_set_param(3, &padchar, fmt_char, ' ');
 
@@ -2536,6 +2538,7 @@ fmt_justification(volatile bool colon, b
 	fmt_set_param(0, &mincol, fmt_int, 0);
 	mincol=BOUND_MINCOL(mincol);
 	fmt_set_param(1, &colinc, fmt_int, 1);
+	if (colinc<=0) fmt_error("Illegal column increment");
 	fmt_set_param(2, &minpad, fmt_int, 0);
 	fmt_set_param(3, &padchar, fmt_char, ' ');
 
--- gcl27-2.7.1.orig/o/hash.d
+++ gcl27-2.7.1/o/hash.d
@@ -297,7 +297,7 @@ BEGIN:
 			
     case t_array:
       h^=ufixhash(j=x->a.a_rank);
-      for (i=0;i<j-1;i++)
+      for (i=0;i+1<j;i++)
 	h^=ufixhash(x->a.a_dims[i]);
       j=x->a.a_dim;
       j=j>10 ? 10 : j;
@@ -565,6 +565,8 @@ DEFUN("MAKE-HASH-TABLE-INT",object,fSmak
 
   if (type_of(size)!=t_fixnum || fix(size)<0)
      FEerror("~S is an illegal hash-table size.", 1, size);
+  if (!fix(size))
+    size=small_fixnum(1);
 
   err=0;
   switch(type_of(rehash_size)) {
--- gcl27-2.7.1.orig/o/msbrk.c
+++ gcl27-2.7.1/o/msbrk.c
@@ -75,7 +75,7 @@ msbrk(intptr_t inc) {
     if (m+mps!=new_map(m+mps,p2-mps))
       return (void *)-1;
 #ifdef HAVE_MADVISE_HUGEPAGE
-    massert(!madvise(m,p2,MADV_HUGEPAGE));
+    madvise(m,p2,MADV_HUGEPAGE);
 #endif
     mps=p2;
   }
--- gcl27-2.7.1.orig/o/num_co.c
+++ gcl27-2.7.1/o/num_co.c
@@ -453,7 +453,6 @@ DEFUNM("ROUND",object,fLround,LISP,1,2,N
   object f=OBJNULL,l=Cnil,y,q,q1,r;
   fixnum vals=(fixnum)fcall.valp;
   object *base=vs_top;
-  double d;
   int c;
   enum type tp;
   va_list ap;
@@ -485,19 +484,11 @@ DEFUNM("ROUND",object,fLround,LISP,1,2,N
     RETURN2(q1,num_remainder(x, y, q1));
 
   case t_shortfloat:
+    q1=double_to_integer(nearbyintf(sf(q)));
+    RETURN2(q1,num_remainder(x,y,q1));
   case t_longfloat:
-    d = number_to_double(q);
-    q1 = double_to_integer(d + (d >= 0.0 ? 0.5 : -0.5));
-    d -= number_to_double(q1);
-    if (d == 0.5 && number_oddp(q1)) {
-      q1 = one_plus(q1);
-      d=-0.5;
-    }
-    if (d == -0.5 && number_oddp(q1)) {
-      q1 = one_minus(q1);
-      d=+0.5;
-    }
-    RETURN2(q1,tp==t_shortfloat ? make_shortfloat((shortfloat)d) : make_longfloat(d));
+    q1=double_to_integer(nearbyint(lf(q)));
+    RETURN2(q1,num_remainder(x,y,q1));
   default:
     TYPE_ERROR(q,sLreal);
   }
--- gcl27-2.7.1.orig/o/print.d
+++ gcl27-2.7.1/o/print.d
@@ -701,9 +701,11 @@ char_inc(char *b,char *p) {
 
 }
 
+#define DCOMP(a_,b_,c_) ({double _a=strtod(a_,b_),_b=(c_);*(volatile double *)&_a== fabs(*(volatile double *)&_b);})
+#define FCOMP(a_,b_,c_) ({float  _a=strtof(a_,b_),_b=(c_);*(volatile float  *)&_a==fabsf(*(volatile float  *)&_b);})
 #define COMP(a_,b_,c_,d_)						\
   ({fixnum _r;								\
-    BLOCK_EXCEPTIONS(_r=((d_) ? strtod((a_),(b_))==(c_) : strtof((a_),(b_))==(float)(c_))); \
+    BLOCK_EXCEPTIONS(_r=((d_) ? DCOMP(a_,b_,c_) : FCOMP(a_,b_,c_)));	\
     _r;})
 
 static int
@@ -725,9 +727,9 @@ truncate_double(char *b,double d,int dp)
 
   strcpy(c,n);
   for (p=c;*p && *p!='e';p++);
-  if (p>c && p[-1]!='.' && char_inc(c,p-1) && COMP(c,&pp,d,dp)) {
+  if (p>c && p[-1]!='.' && char_inc(c,p-1) && COMP(c,&p,d,dp)) {
     j=truncate_double(c,d,dp);
-    if (j<=k) {
+    if (j<k) {
       k=j;
       n=c;
     }
--- gcl27-2.7.1.orig/o/read.d
+++ gcl27-2.7.1/o/read.d
@@ -2044,13 +2044,9 @@ DEFUN("READ-CHAR-NO-HANG",object,fLread_
   else if (strm == Ct)
     strm = symbol_value(sLAterminal_ioA);
   check_type_stream(&strm);
-  if (stream_at_end(strm)) {
-    if (eof_errorp == Cnil)
-      RETURN1(eof_value);
-    else
-      end_of_stream(strm);
-  }
-  RETURN1(listen_stream(strm) ? read_char(strm) : Cnil);
+  RETURN1(stream_at_end(strm) ?
+	  (eof_errorp == Cnil ?  eof_value : (end_of_stream(strm),Cnil)) :
+	  (listen_stream(strm) ? read_char(strm) : Cnil));
 }
 
 @(defun clear_input (&optional (strm `symbol_value(sLAstandard_inputA)`))
--- gcl27-2.7.1.orig/o/save.c
+++ gcl27-2.7.1/o/save.c
@@ -52,17 +52,15 @@ LFD(siLsave)(void) {
 #if !defined(__APPLE__)
     extern char **__environ;
 #endif
+#ifdef USE_READLINE
     extern FILE *rl_instream;
     extern char *rl_line_buffer;
+#endif
     extern void clear_eval_vec(void);
 
 #if !defined(__APPLE__)
     __environ=NULL;
 #endif
-    rl_instream=NULL;
-    rl_readline_name=NULL;
-    rl_line_buffer=NULL;
-    rl_completion_entry_function=NULL;
     stdin=NULL;
     stdout=NULL;
     stderr=NULL;
@@ -80,8 +78,14 @@ LFD(siLsave)(void) {
     my_stdin=NULL;
     my_stdout=NULL;
     my_stderr=NULL;
+#ifdef USE_READLINE
+    rl_instream=NULL;
+    rl_readline_name=NULL;
+    rl_line_buffer=NULL;
+    rl_completion_entry_function=NULL;
     my_rl_readline_name_ptr=NULL;
     my_rl_completion_entry_function_ptr=NULL;
+#endif
 
   }
 
