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-11) unstable; urgency=medium
 .
   * Version_2_7_0pre14
Author: Camm Maguire <camm@debian.org>

---
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: 2024-02-19

--- gcl27-2.7.0.orig/ansi-tests/gclload1.lsp
+++ gcl27-2.7.0/ansi-tests/gclload1.lsp
@@ -3,10 +3,13 @@
 
 #+cmu (setq ext:*gc-verbose* nil)
 
-#+gcl (setq compiler:*suppress-compiler-notes* t
-            compiler:*suppress-compiler-warnings* t
-            compiler:*compile-verbose* nil
-            compiler:*compile-print* nil)
+#+gcl(setq si::*code-block-reserve*
+	   (or si::*code-block-reserve*
+	       (make-array 30000000 :element-type 'character :static t))
+	   compiler:*suppress-compiler-notes* t
+           compiler:*suppress-compiler-warnings* t
+           compiler:*compile-verbose* nil
+           compiler:*compile-print* nil)
 
 #+lispworks (setq compiler::*compiler-warnings* nil)
 #+lispworks (make-echo-stream *standard-input* *standard-output*)
--- gcl27-2.7.0.orig/ansi-tests/sqrt.lsp
+++ gcl27-2.7.0/ansi-tests/sqrt.lsp
@@ -202,3 +202,6 @@
 	collect (list x s))
   nil)
 
+(deftest sqrt.20
+    (sqrt 1075)
+  32.78719262151)
--- gcl27-2.7.0.orig/clcs/gcl_clcs_condition_definitions.lisp
+++ gcl27-2.7.0/clcs/gcl_clcs_condition_definitions.lisp
@@ -151,31 +151,34 @@
 						    package cell arithmetic pathname)))))
 
 (macrolet
- ((make-fpe-conditions (&aux (n "indoux"))
-  (labels
-   ((fpe (st &optional (p "FPE-")) (intern (concatenate 'string p (string st))))
-    (fpess (st) (when (> (length st) 2)
-		  (let ((i -1))
-		    (mapcar (lambda (x)
-			      (fpe (concatenate 'string (subseq st 0 (incf i)) (subseq st (1+ i)))))
-			    (make-list (length st))))))
-    (make-sub-fpe-conditions (l &optional c);FIXME, all combinations not needed nor possible per IEEE
-			     (cond (l (append
-				       (make-sub-fpe-conditions (cdr l) c)
-				       (make-sub-fpe-conditions (cdr l) (cons (car l) c))))
-				   ((cdr c)
-				    (let ((st (nstring-upcase
-					       (coerce
-						(mapcar (lambda (x) (aref n (1- (integer-length (caddr x))))) c)
-						'string))))
-				      `((,(fpe st) ,(or (fpess st) (mapcar (lambda (x) (fpe (car x) "INTERNAL-SIMPLE-")) c)))))))))
-   `(progn
-      ,@(mapcar (lambda (x) `(define-condition ,(car x) (arithmetic-error) nil)) fpe::+fe-list+)
-      ,@(mapcar (lambda (x) `(define-condition ,@x nil))
-		(make-sub-fpe-conditions fpe::+fe-list+))))))
- (make-fpe-conditions))
-
-
+    ((make-fpe-conditions ()
+       (labels
+	   ((nm (x) (cadr (assoc (car x) '((floating-point-invalid-operation #\i)
+					  (division-by-zero #\d)
+					  (floating-point-overflow #\o)
+					  (floating-point-underflow #\u)
+					  (floating-point-inexact #\x)))))
+	    (fpe (st &optional (p "FPE-")) (intern (concatenate 'string p (string st))))
+	    (fpess (st) (when (> (length st) 2)
+			  (let ((i -1))
+			    (mapcar (lambda (x)
+				      (fpe (concatenate 'string (subseq st 0 (incf i)) (subseq st (1+ i)))))
+				    (make-list (length st))))))
+	    (make-sub-fpe-conditions (l &optional c);FIXME, all combinations not needed nor possible per IEEE
+	      (cond (l (append
+			(make-sub-fpe-conditions (cdr l) c)
+			(make-sub-fpe-conditions (cdr l) (cons (car l) c))))
+		    ((cdr c)
+		     (let ((st (nstring-upcase
+				(coerce
+				 (mapcar (lambda (x) (nm x)) c)
+				 'string))))
+		       `((,(fpe st) ,(or (fpess st) (mapcar (lambda (x) (fpe (car x) "INTERNAL-SIMPLE-")) c)))))))))
+	 `(progn
+	    ,@(mapcar (lambda (x) `(define-condition ,(car x) (arithmetic-error) nil)) fpe::+fe-list+)
+	    ,@(mapcar (lambda (x) `(define-condition ,@x nil))
+		      (make-sub-fpe-conditions fpe::+fe-list+))))))
+  (make-fpe-conditions))
 
 #.`(progn
      ,@(mapcar (lambda (x)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpblock.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpblock.lsp
@@ -129,18 +129,19 @@
     (ref-blks body (list blk))
     (when (or (blk-ref-ccb blk) (blk-ref-clb blk))
       (set-volatile info))
-    (mapc (lambda (x &aux (y x)(v (pop x))(tp (pop x))(st (pop x))(m (car x))
-		       (tp (type-and tp (var-dt v))));FIXME, unnecessary?
-	    (unless (and (si::type= tp (var-type v))
-			 (subsetp st (var-store v)) (subsetp (var-store v) st)
-			 (if m (equal m tp) t))
+    (when (info-type info)
+      (mapc (lambda (x &aux (y x)(v (pop x))(tp (pop x))(st (pop x))(m (car x))
+			 (tp (type-and tp (var-dt v))));FIXME, unnecessary?
+	      (unless (and (type= tp (var-type v))
+			   (subsetp st (var-store v)) (subsetp (var-store v) st)
+			   (if m (equal m tp) t))
 		(keyed-cmpnote (list (var-name v) 'block-set)
 			       "Altering ~s at end of block ~s:~%   type from ~s to ~s,~%   store from ~s to ~s"
 			       v (blk-name blk) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp)
 			       (var-store v) st)
 		(do-setq-tp v '(blk-set) tp)
 		(push-vbinds v st)))
-	  (blk-var blk))
+	    (blk-var blk)))
     (cond ((or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))(list 'block info blk body))
 	  (body))))
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpcall.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpcall.lsp
@@ -517,10 +517,10 @@
 		 (write-to-string (argsizes args type 0));FIXME
 		 ",(void **)(void *)&Lnk" num "," (new-proclaimed-argd args type)
 		 ",first,ap);va_end(ap);return V1;}")
-	   (wt "(){" d "V1=(" d ")call_proc_new(" (vv-str name) "," (if clp "1" "0") ","
+	   (wt "(){va_list dummy;" d "V1=(" d ")call_proc_new(" (vv-str name) "," (if clp "1" "0") ","
 	       (write-to-string (argsizes args type 0));FIXME
 	       ",(void **)(void *)&Lnk" num "," (new-proclaimed-argd args type)
-	       ",0,0);return V1;}")))))
+	       ",0,dummy);return V1;}")))))
     (setq name (function-string name))
     (if (find #\/ name) (setq name (remove #\/ name)))
     (wt " /* " name " */")))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpeval.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpeval.lsp
@@ -213,7 +213,7 @@
 		  (cddr a))))
     (when (listp (car opt))
       (unless (flag-p (caddr opt) nt)
-	(let ((s (unique-sigs (list (mapcar 'cmp-norm-tp (car opt)) (cmp-norm-tp (cadr opt))))))
+	(let ((s (uniq-sig (list (mapcar 'cmp-norm-tp (car opt)) (cmp-norm-tp (cadr opt))))))
 	  (setf (car opt) (car s)
 		(cadr opt) (cadr s)
 		(caddr opt) (logior (caddr opt) (flags nt))))))
@@ -680,7 +680,7 @@
 
 (defvar *annotate* nil)
 
-(defun c2inline (comment expr)
+(defun c2inline (comment expr &aux (comment (mysub (mysub (write-to-string comment) "/*" "") "*/" "")))
   (when *annotate* (wt-nl "/*")(princ comment *compiler-output1*)(wt "*/"))
   (c2expr expr)
   (when *annotate* (wt-nl "/* END ")(princ comment *compiler-output1*)(wt "*/")))
@@ -1287,12 +1287,12 @@
 (defun arg-types-match (tps sir)
   (and (= (length tps) (length sir))
        (every (lambda (x y) 
-		(or (si::type= x y)
+		(or (type= x y)
 		    (and (type>= #tinteger x) (type>= #tinteger y))
 		    (let ((cx (car (atomic-tp x)))(cy (car (atomic-tp y))))
 		      (and (consp cx) (consp cy)
 			   (if (tailp cy cx)
-			       (> (length cx) *src-loop-unroll-limit*)
+			       (> (labels ((l (x i) (if (consp x) (l (cdr x) (1+ i)) i))) (l cx 0)) *src-loop-unroll-limit*)
 			       (tailp cx cy))))))
 	      tps sir)))
 
@@ -1533,7 +1533,7 @@
 ;;   (if ce e l))
 
 (defun mod-env (e l)
-  (setq *lexical-env-mask* (nconc (remove-if (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) *lexical-env-mask*))
+  (setq *lexical-env-mask* (nconc (remove-if (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) *lexical-env-mask*));FIXME
   l)
 
 
@@ -1670,7 +1670,7 @@
 
     (mapc (lambda (x) (setf (info-type (cadr x)) (coerce-to-one-value (info-type (cadr x))))) nargs)
 
-    (unless (or last (local-fun-p fn) (eq fn (cadr *current-form*)));FIXME
+    (unless (or last (local-fun-p fn) (eq fn (when (consp *current-form*) (cadr *current-form*))));FIXME
       (when (do (p ;n
 		 (a at (if (eq (car a) '*) a (cdr a)))
 		 (r args (cdr r))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpflet.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpflet.lsp
@@ -964,7 +964,7 @@
 	 (clp (pop fd))
 	 (ap  (cadr fd))
 	 (sig (car (fun-call fun)))
-	 (sig (list (mapcar  (lambda (x) (link-rt x nil)) (car sig)) (link-rt (cadr sig) nil)))
+	 (sig (list (mapcar  (lambda (x) (link-rt x t)) (car sig)) (link-rt (cadr sig) t)))
 	 (mv (not (single-type-p (cadr sig))))
 	 (nm (c-function-name "L" (fun-cfun fun) (fun-name fun)))
 	 (clp (when clp (ccb-vs-str (fun-ref-ccb fun))))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpfun.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpfun.lsp
@@ -250,27 +250,29 @@
 (defun equalp-is-eq-tp (x)
   (eq-subtp x #tequalp-is-eq-tp))
 
-(defun do-eq-et-al (fn args);FIXME  pass through function inlining
-  (let* ((tf (cadr (test-to-tf fn)))
-	 (info (make-info :type #tboolean))
-	 (nargs (c1args args info))
-	 (t1 (info-type (cadar nargs)))
-	 (t2 (info-type (cadadr nargs)))
-	 (a1 (atomic-tp t1))
-	 (a2 (atomic-tp t2))
-	 (nfn (if (when tf (or (funcall tf t1) (funcall tf t2))) 'eq fn)))
-    (unless (and t1 t2) (setf (info-type info) nil))
-    (cond ((not (type-and t1 t2))
+
+(defun do-eq-et-al (fn args &aux (info (make-info :type #tboolean)));FIXME  pass through function inlining
+  (let* ((nargs (c1args args info))
+	 (t1 (info-type (cadar nargs)))(t2 (info-type (cadadr nargs)))
+	 (a1 (atomic-tp t1))(a2 (atomic-tp t2))
+	 (nfn (ecase fn
+		(eq fn)
+		(eql (let ((tp #teql-is-eq-tp)) (if (or (type<= t1 tp)(type<= t2 tp)) 'eq fn)))
+		(equal (let ((tp #tequal-is-eq-tp)) (if (or (type<= t1 tp)(type<= t2 tp)) 'eq fn)))
+		(equalp (let ((tp #tequalp-is-eq-tp)) (if (or (type<= t1 tp)(type<= t2 tp)) 'eq fn)))))
+	 (nfn (if (when (member nfn '(equal equalp))
+		    (or (type<= t1 #tnumber) (type<= t2 #tnumber)))
+		  'eql nfn)))
+    (cond ((when (and t1 t2 (member nfn '(eq eql))) (not (type-and t1 t2)))
 	   (c1progn (append args (list nil)) (nconc nargs (list (c1nil)))))
-	  ((and a1 a2 (case nfn (eq (eql-is-eq (car a1)))(eql t)))
+	  ((and a1 a2 (case nfn (eq (or (eql-is-eq (car a1)) (eql-is-eq (car a2))))(eql t)))
 	   (let ((q (eql (car a1) (car a2))))
 	     (c1progn (append args (list q)) (nconc nargs (list (if q (c1t) (c1nil)))))))
-	  ((let ((x (get-vbind (car nargs)))(y (get-vbind (cadr nargs))))
-	     (when (or (when x (eq x y)) (and (symbolp (car args)) (eq (car args) (cadr args))))
-	       (c1t))))
-	  (`(call-global ,info
-	     ,(if (when tf (or (funcall tf t1) (funcall tf t2))) 'eq fn)
-	     ,nargs)))))
+	  ((when (and t1 t2)
+	     (let ((x (get-vbind (car nargs)))(y (get-vbind (cadr nargs))))
+	       (when (or (when x (eq x y)) (and (symbolp (car args)) (eq (car args) (cadr args))))
+		 (c1t)))))
+	  (t (unless (and t1 t2) (setf (info-type info) nil)) `(call-global ,info ,nfn ,nargs)))))
 
 	   
 (dolist (l `(eq eql equal equalp))
@@ -592,7 +594,7 @@
 ;    (when dot (setf (cdr (last y 2)) (car (last y)))) ;FIXME bump-pcons -- get rid of pcons entirely
     (let* ((s (when dot (car (last y))))(s (when s (unless (typep s 'proper-list) s)))(tp (info-type (cadar (last nargs)))));FIXME
       (cond ((when s (type>= #tproper-list tp)) #tproper-cons)
-	    ((when s (type-and #tnull tp)) #tcons)
+	    ((when s (type-and #tproper-list tp)) #tcons)
 	    (t (when dot (setf (cdr (last y 2)) (car (last y)))) (object-type y))))))
 
 (defun c1list (args)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpif.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpif.lsp
@@ -247,7 +247,7 @@
 			   (vl (third fmla))
 			   (i (cond ((type>= #tnull tp) (cons nil (fourth fmla)));FIXME nil tp
 				    ((type>= #t(not null) tp) (cons (fourth fmla) nil)))))
-		      (nconc (when i (mapcar (lambda (x) (cons x i)) vl)) (fmla-infer-tp (fifth fmla)))))
+		      (nconc (when i (mapcar (lambda (x) (cons x i)) vl)) (fmla-infer-tp (fifth fmla)))));FIXME
 	  (if (apply 'fmla-if (cddr fmla)))
 	  (var (when (llvar-p (car (third fmla)))
 		 (list (cons (car (third fmla)) (cons #t(not null) #tnull)))))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpinline.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpinline.lsp
@@ -40,11 +40,11 @@
 	    `(si::|#,| name-to-sd ',x))))
 
 (defun s-print (n x a s)
-  (princ "#<" s)
-  (princ n s)
-  (princ " " s)
-  (princ x s)
-  (format s " ~x>" a))
+  (print-unreadable-object (x s)
+    (princ n s)
+    (princ " " s)
+    (princ x s)
+    (format s " ~x" a)))
 
 (defstruct (info (:print-function (lambda (x s i) (s-print 'info (info-type x) (si::address x) s)))
 		 (:copier old-copy-info))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpmain.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpmain.lsp
@@ -202,7 +202,7 @@
 			   (*standard-output* *standard-output*)
 			   (*prof-p* prof-p)
 			   #+large-memory-model(*large-memory-model-p* large-memory-model-p)
-			   (output-file (pathname output-file))
+			   (output-file (translate-logical-pathname output-file))
 		           (*error-output* *error-output*)
                            (*compiler-in-use* *compiler-in-use*)
 			   (*c-debug* c-debug)
@@ -253,6 +253,7 @@ Cannot compile ~a.~%" (namestring (merge
    
    (with-open-file (s output-file :if-does-not-exist :create))
    (setq *init-name* (init-name output-file t))
+   (delete-file output-file)
    (setq *function-filename* (unless *compiler-compile*
 			       (namestring (truename (pathname *compiler-input*)))))
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpopt.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpopt.lsp
@@ -53,18 +53,18 @@
    (get 'si::complexp 'inline-always))
 
 ;;SFEOF
- (push `((t) boolean #.(flags set rfa) ,(lambda (x) (add-libc "feof") (wt "(feof((" x ")->sm.sm_fp))")))
+ (push `((t) boolean #.(flags set rfa) ,(lambda (x) (add-libc "feof") (wt "(((int(*)(void *))dlfeof)((" x ")->sm.sm_fp))")))
    (get 'sfeof 'inline-unsafe))
 
 
 ;;SGETC1
- (push `((t) fixnum #.(flags set rfa) ,(lambda (x) (add-libc "getc") (wt "(getc((" x ")->sm.sm_fp))")))
+ (push `((t) fixnum #.(flags set rfa) ,(lambda (x) (add-libc "getc") (wt "(((int(*)(void *))dlgetc)((" x ")->sm.sm_fp))")))
    (get 'sgetc1 'inline-unsafe))
 
 ;;SPUTC
- (push `((fixnum t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(putc(" x ",(" y ")->sm.sm_fp))")))
+ (push `((fixnum t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(((int(*)(int,void *))dlputc)(" x ",(" y ")->sm.sm_fp))")))
    (get 'sputc 'inline-always))
-(push `((character t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(putc(char_code(" x "),(" y ")->sm.sm_fp))")))
+(push `((character t) fixnum #.(flags set rfa) ,(lambda (x y) (add-libc "putc") (wt "(((int(*)(int,void *))dlputc)(char_code(" x "),(" y ")->sm.sm_fp))")))
    (get 'sputc 'inline-always))
 
 ;;FORK
@@ -1178,8 +1178,8 @@
 (push '((ratio)  integer        #.(flags rfa) "(#0)->rat.rat_num") (get 'ratio-numerator 'inline-always))
 (push '((ratio)  integer        #.(flags rfa) "(#0)->rat.rat_den") (get 'ratio-denominator 'inline-always))
 
-(push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isinf") (wt "(isinf(" x "))"))) (get 'si::isinf 'inline-always))
-(push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isnan") (wt "(isnan(" x "))"))) (get 'si::isnan 'inline-always))
+(push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isinf") (wt "(((int(*)(double))dlisinf)(" x "))"))) (get 'si::isinf 'inline-always))
+(push `((long-float) boolean #.(flags rfa) ,(lambda (x) (add-libc "isnan") (wt "(((int(*)(double))dlisnan)(" x "))"))) (get 'si::isnan 'inline-always))
 
 
 ;;LOGCOUNT
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpspecial.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpspecial.lsp
@@ -250,13 +250,14 @@
   (find-special-var l 'is-fun-var))
 
 (defun export-sig (sig)
-  (unique-sigs `((,@(mapcar 'export-type (car sig))) ,(export-type (cadr sig)))))
+  (uniq-sig `((,@(mapcar 'export-type (car sig))) ,(export-type (cadr sig)))))
 
 (defun mbt (tp &aux (atp (atomic-tp tp)))
   (if (and atp (consp (car atp)))
-      (if (cdar atp) #tcons #tproper-cons)
+      (if (typep (car atp) 'proper-cons) #tproper-cons #tcons)
     tp))
 
+
 ;; (defun mbt (tp &aux (atp (atomic-tp tp)))
 ;;   (cond (*compiler-new-safety* (if (single-type-p tp) #tt #t*))
 ;; 	((and atp (consp (car atp))) (if (cdar atp) #tcons #tproper-cons))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptag.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptag.lsp
@@ -141,7 +141,7 @@
 	    (setf (var-type v) (car x));FIXME do-setq-tp ?
 	    (push-vbinds v (cadr x)))
 	  x))
-  (when z x))
+  (when z x));FIXME return type
 
 (defun pt (y x) (or (tst y (with-restore-vars (catch y (prog1 (cons y (pr x)) (keep-vars))))) (pt y x)))
 
@@ -202,7 +202,7 @@
   (let* ((body (mapcar (lambda (x) (if (or (symbolp x) (integerp x)) (make-tag :name x) x)) body))
 	 (tags (remove-if-not 'tag-p body))
 	 (body (let* ((*tags* (append tags *tags*))
-		      (*ft* (nconc (mapcar 'list tags) *ft*))
+		      (*ft* (nconc (mapcar 'list tags) *ft*));FIXME
 		      (*ttl-tags* (nttl-tags body)))
 		  (pr body)))
 	 (body (mapc (lambda (x) (unless (tag-p x) (ref-tags x tags))) body))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptop.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptop.lsp
@@ -511,7 +511,7 @@
 	  (cc (split-ctps  ax ctps)))
      (portable-source `(lambda ,nal
 			 ,@(when doc `(,doc))
-			 ,@(nconc (nreverse (cadr dd)) (cadr cc))
+			 ,@(nconc (nreverse (cadr dd)) (cadr cc));FIXME
 			 ,@(let* ((r args)(bname (blocked-body-name r))(fname (if (when bname (eq fname 'lambda)) bname fname))
 				  (r (if (eq fname bname) (cddar r) r))
 				  (r (if (or al (car dd)) `((let* ,al ,@(append (car dd) (car cc)) ,@r)) r)))
@@ -1349,7 +1349,7 @@
       tp))
 
 (defun exp-sig (sig)
-  (list (mapcar 'ex-tp (car sig)) (if (consp (cadr sig)) (cons (caadr sig) (mapcar 'ex-tp (cdadr sig))) (ex-tp (cadr sig)))))
+  (list (mapcar 'ex-tp (car sig)) (if (cmpt (cadr sig)) (cons (caadr sig) (mapcar 'ex-tp (cdadr sig))) (ex-tp (cadr sig)))))
 
 (defun ex-sig (sig) (list (mapcar 'cmp-unnorm-tp (car sig)) (cmp-unnorm-tp (cadr sig))))
 (defun export-call-struct (l)
@@ -1896,13 +1896,14 @@
   (flet ((wt (x) (wt x) (let ((*compiler-output1* *compiler-output2*)) (wt x))))
 	(dolist (v requireds (wt (if narg ",...)" ")")))
 	  (setq narg (or narg (is-narg-var v)))
-	  (let ((cvar (cs-push (var-type v) t)))
+	  (let* ((gt (global-type-bump (var-type v)))
+		 (cvar (cs-push gt t)))
 	    (when first (wt ","))
 	    (setq first t)
 	    (setf (var-loc v) cvar)
 	    (wt *volatile*)
 	    (wt (register v))
-	    (wt (rep-type (var-type v)))
+	    (wt (rep-type gt))
 	    (wt "V")
 	    (wt cvar)))))
 
@@ -2531,7 +2532,7 @@
 	  ((var-cb vl) (push (list (eq 'clb (var-loc vl)) vl) *reg-clv*))
 ;	  ((var-cb vl) (push vl *reg-clv*))
 	  ((setf (var-kind vl)
-		 (or (car (member (promoted-c-type (var-type vl)) +c-local-arg-types+)) 'object))))
+		 (or (car (member (promoted-c-type (var-type vl)) +c-global-arg-types+)) 'object))))
     (setf (var-loc vl) (cs-push (var-type vl) t)))
 
   (wt-comment "local function " (if (fun-name fun) (fun-name fun) nil))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptype.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptype.lsp
@@ -22,6 +22,92 @@
 
 (in-package :compiler)
 
+(defstruct (binding (:print-function (lambda (x s i) (s-print 'binding (binding-repeatable x) (si::address x) s))))
+  form
+  repeatable)
+
+(defun naltp (tp &aux (catp (car (atomic-tp tp))))
+  (labels ((g (x) (when (binding-p x) (return-from naltp catp)))
+	   (f (x) (if (consp x) (or (g (car x)) (f (cdr x))) (g x))))
+    (f catp)))
+
+(defun explode-nalt (tp)
+  (labels ((g (x)
+	     (if (binding-p x)
+		 (if (binding-form x) (cmp-unnorm-tp (info-type (cadr (binding-form x)))) t)
+		 `(member ,x)))
+	   (f (x) (if (consp x) `(cons ,(g (car x)) ,(f (cdr x))) (g x))))
+  (cmp-norm-tp (f tp))))
+
+(defun cons-type-p (ktp tp)
+  (let ((a (type-and ktp tp)))
+    (when (consp a)
+      (member-if #'identity (cdr (caar (third a))) :key 'car))))
+
+(defun needs-explode (t1 t2 &aux (n (naltp t1)))
+  (when (and n (cons-type-p (if (typep n 'proper-cons) #tproper-cons #tsi::improper-cons) t2))
+    n))
+
+
+(defun ctp-and (t1 t2 &aux n)
+  (cond ((setq n (needs-explode t1 t2)) (when (tp-and (explode-nalt n) t2) t1))
+	((setq n (needs-explode t2 t1)) (when (tp-and (explode-nalt n) t1) t2))
+	((tp-and t1 t2))))
+
+(defun ctp<= (t1 t2 &aux n)
+  (cond ((setq n (needs-explode t1 t2)) (when (tp-and (explode-nalt n) t2) t));hash
+	((tp<= t1 t2))))
+
+(defun null-list (x) (when (plusp x) (make-list x :initial-element #tnull)))
+
+(defun type-and (x y)
+  (cond ((eq x '*) y)
+	((eq y '*) x)
+	((and (cmpt x) (cmpt y))
+	 (let ((lx (length x))(ly (length y)))
+	   (cons (if (when (eql lx ly)
+		       (when (eq (car x) (car y))
+			 (eq (car x) 'returns-exactly)))
+		     'returns-exactly 'values)
+		 (mapcar 'type-and
+			 (append (cdr x) (null-list (- ly lx)))
+			 (append (cdr y) (null-list (- lx ly)))))))
+	((cmpt x) (type-and (or (cadr x) #tnull) y))
+	((cmpt y) (type-and x (or (cadr y) #tnull)))
+	((ctp-and x y))))
+
+(defun type-or1 (x y)
+  (cond ((eq x '*) x)
+	((eq y '*) y)
+	((and (cmpt x) (cmpt y))
+	 (let ((lx (length x))(ly (length y)))
+	   (cons (if (when (eql lx ly)
+		    (when (eq (car x) (car y))
+		      (eq (car x) 'returns-exactly)))
+		  'returns-exactly 'values)
+		 (mapcar 'type-or1
+			 (append (cdr x) (null-list (- ly lx)))
+			 (append (cdr y) (null-list (- lx ly)))))))
+	((cmpt x) (type-or1 x `(returns-exactly ,y)))
+	((cmpt y) (type-or1 `(returns-exactly ,x) y))
+	((tp-or x y))))
+
+(defun type<= (x y)
+  (cond ((eq y '*))
+	((eq x '*) nil)
+	((and (cmpt x) (cmpt y))
+	 (do ((x (cdr x) (cdr x))(y (cdr y) (cdr y)))
+	     ((and (not x) (not y)) t)
+	     (unless (type<= (if x (car x) #tnull) (if y (car y) #tnull))
+	       (return nil))))
+	((cmpt x) (type<= x `(returns-exactly ,y)));FIXME
+	((cmpt y) (type<= `(returns-exactly ,x) y))
+	((ctp<= x y))))
+
+(defun type>= (x y) (type<= y x))
+
+(defun type= (x y) (when (type<= y x) (type<= x y)))
+
 
 (defun get-sym (args)
   (intern (apply 'concatenate 'string (mapcar 'string args))))
@@ -617,19 +703,41 @@
       (do-setq-tp v nil tp)
       (mapc (lambda (x) (bump-pconsa x ctp)) (var-aliases v)))))
 
+
+(defun bump-cons-tp-if (f tp)
+  (dolist (v *vars*)
+    (when (var-p v)
+      (unless (tp<= tp (var-type v))
+	(when (funcall f (var-type v))
+	  (keyed-cmpnote (list (var-name v) 'type-propagation 'type 'bump-cons-tp-if)
+			 "Bumping var ~s cons type ~s -> ~s, tp ~s"
+			 (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp (tp-or (var-type v) tp)) (cmp-unnorm-tp tp))
+	  (do-setq-tp v 'bump-cons-tp-if (tp-or (var-type v) tp))))
+      (let ((s (var-store v)))
+	(when (listp s);FIXME
+	  (dolist (b s)
+	    (let* ((fm (binding-form b))(i (when fm (cadr fm)))(itp (when i (info-type i))))
+	      (when (and fm (funcall f itp))
+		(setf (info-type i) (type-or1 itp tp))))))))))
+
 (defun c1rplacd (args)
   (let* ((info (make-info :flags (iflags side-effects)))
 	 (nargs (c1args args info))
-	 (p (type>= #tproper-list (info-type (cadadr nargs))))
-	 (atp (car (atomic-tp (info-type (cadar nargs)))))
-	 (atp1 (car (atomic-tp (info-type (cadadr nargs))))))
+	 (tp1 (type-and #tcons (info-type (cadar nargs))))(tp2 (info-type (cadadr nargs)))
+	 (c1 (car (atomic-tp tp1)))(atp2 (atomic-tp tp2))(a2 (car atp2)) itp)
     (c1side-effects nil)
-    (when (consp atp) 
-      (when (eq atp atp1) (setq atp1 (copy-list atp1)))
-      (setf (cdr atp) (or atp1 (new-bind))))
-    (when (eq (caar nargs) 'var)
-      (bump-pcons (caaddr (car nargs)) p))
-    (setf (info-type info) (if p #tproper-cons #tcons))
+    (cond
+      ((and c1 atp2 (not (eq c1 a2)) (if (typep c1 'proper-cons) (typep a2 'proper-list) (typep a2 '(not proper-list))))
+       (setf (cdr c1) a2 itp tp1))
+      ((and (typep c1 'proper-cons) (type<= tp2 #tproper-list))
+       (bump-cons-tp-if (lambda (x &aux (c (car (atomic-tp x)))) (when (consp c) (tailp c1 c))) #tproper-cons))
+      ((and (typep c1 'si::improper-cons) (type<= tp2 #t(not proper-list)))
+       (bump-cons-tp-if (lambda (x &aux (c (car (atomic-tp x)))) (when (consp c) (tailp c1 c))) #tsi::improper-cons))
+      ((and (type<= tp1 #tproper-cons) (type-and tp2 #t(not proper-list)))
+       (bump-cons-tp-if (lambda (x) (type-and x #tproper-cons)) #tcons))
+      ((and (type<= tp1 #tsi::improper-cons) (type-and tp2 #tproper-list))
+       (bump-cons-tp-if (lambda (x) (type-and x #tsi::improper-cons)) #tcons)))
+    (setf (info-type info) (or itp (if (type<= tp2 #tproper-list) #tproper-cons #tcons)))
     (list 'call-global info 'rplacd nargs)))
 (si::putprop 'rplacd 'c1rplacd 'c1)
 
@@ -986,18 +1094,28 @@
 	((short-float long-float) (member-if (lambda (x) (or (isinf x) (isnan x))) (cdr u)))
 	(otherwise (si::si-classp u))))
 
-(defun export-type (type)
-  (if (unprintable-individualsp (cmp-unnorm-tp type))
-      (bump-tp type)
-    type))
-
-(defun unique-sigs (sig) (si::uniq-list sig))
+(defun kingdoms-with-unprintable-individuals (tp)
+  (labels ((f (x)
+	     (typecase x
+	       (float (or (isnan x) (isinf x)))
+	       ((or string bit-vector number random-state character symbol pathname) nil)
+	       (cons (or (f (car x)) (f (cdr x))))
+	       ((array t) (some (lambda (x) (f x)) x));FIXME #'f
+	       ;FIXME assumes structure elements are printable
+	       (structure (si::s-data-print-function (c-structure-def x)))
+	       (t t))))
+    (when (consp tp)
+      (if (cmpt tp)
+	  (mapcan 'kingdoms-with-unprintable-individuals (cdr tp))
+	  (mapcan (lambda (x)
+		    (when (member-if (lambda (x) (f x)) (cdr x));FIXME #'f
+		      (list (car x))))
+		  (caaddr tp))))))
 
 
-(defun tsrch (tp &optional (y *useful-type-tree*))
-  (let ((x (member tp y :test 'type<= :key 'car)))
-    (when x
-      (or (tsrch tp (cdar x)) (caar x)))))
+(defun export-type (type)
+  (let ((x (kingdoms-with-unprintable-individuals type)))
+    (if x (type-or1 type (cmp-norm-tp (cons 'or x))) type)))
 
 (defun bump-tp (tp)
   (cond ((eq tp '*) tp)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmputil.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmputil.lsp
@@ -72,7 +72,7 @@
 
 (defmacro maybe-to-wn-stack (&rest body)
   (let ((cf (sgen "MTWSCF"))(sri (sgen "MTWSSRI")))
-  `(if (and (boundp '*warning-note-stack*) (not *note-keys*))
+  `(if (and (boundp '*warning-note-stack*) (not *note-keys*));FIXME
        (let ((,cf *current-form*)(,sri *src-inline-recursion*)) 
 	 (push (lambda nil
 		 (let ((*current-form* ,cf)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpvar.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpvar.lsp
@@ -300,9 +300,6 @@
 	(unless (or (info-ref-clb i) (info-ref-ccb i))
 	  t)))))
 
-(defstruct (binding (:print-function (lambda (x s i) (s-print 'binding (binding-repeatable x) (si::address x) s))))
-  form
-  repeatable)
 
 (defun new-bind (&optional form)
   (make-binding :form form :repeatable (repeatable-binding-p form)))
--- gcl27-2.7.0.orig/configure
+++ gcl27-2.7.0/configure
@@ -6247,7 +6247,7 @@ printf "%s\n" "good" >&6; }
 		      TLIBS="$TLIBS -lgmp"
 		      echo "#include \"gmp.h\"" >foo.c
 		      echo "int main() {return 0;}" >>foo.c
-		      MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'`
+		      MP_INCLUDE=`$CC -E foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'`
 		      rm -f foo.c
 fi
 rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
@@ -6774,9 +6774,8 @@ fi
 # Dynamic loading
 #
 
-if test "$enable_dlopen" = "yes" ; then
-
-    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
+# boot.so requires dlopen
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
 printf %s "checking for dlopen in -ldl... " >&6; }
 if test ${ac_cv_lib_dl_dlopen+y}
 then :
@@ -6822,6 +6821,9 @@ else $as_nop
 fi
 
 
+if test "$enable_dlopen" = "yes" ; then
+
+
     TLIBS="$TLIBS -ldl -rdynamic"
     assert_arg_to_cflags -fPIC
 
@@ -8999,13 +9001,19 @@ printf "%s\n" "#define NO_GETTOD 1" >>co
 fi
 
 
-ac_fn_c_check_func "$LINENO" "readlinkat" "ac_cv_func_readlinkat"
+
+  for ac_func in readlinkat
+do :
+  ac_fn_c_check_func "$LINENO" "readlinkat" "ac_cv_func_readlinkat"
 if test "x$ac_cv_func_readlinkat" = xyes
 then :
   printf "%s\n" "#define HAVE_READLINKAT 1" >>confdefs.h
 
+else $as_nop
+  as_fn_error $? "must have readlinkat" "$LINENO" 5
 fi
 
+done
 
 ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default"
 if test "x$ac_cv_header_sys_ioctl_h" = xyes
--- gcl27-2.7.0.orig/configure.in
+++ gcl27-2.7.0/configure.in
@@ -661,7 +661,7 @@ if test "$enable_dynsysgmp" != "no" ; th
 		      TLIBS="$TLIBS -lgmp"
 		      echo "#include \"gmp.h\"" >foo.c
 		      echo "int main() {return 0;}" >>foo.c
-		      MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'`
+		      MP_INCLUDE=`$CC -E foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'`
 		      rm -f foo.c])])])
 
     if test "$MP_INCLUDE" = "" ; then
@@ -804,9 +804,12 @@ AC_SUBST(X_CFLAGS)
 # Dynamic loading
 #
 
+# boot.so requires dlopen
+AC_CHECK_LIB([dl],[dlopen],,AC_MSG_ERROR([Cannot find dlopen]))
+
 if test "$enable_dlopen" = "yes" ; then
 
-    AC_CHECK_LIB([dl],[dlopen],,AC_MSG_ERROR([Cannot find dlopen]))
+    dnl AC_CHECK_LIB([dl],[dlopen],,AC_MSG_ERROR([Cannot find dlopen]))
 
     TLIBS="$TLIBS -ldl -rdynamic"
     assert_arg_to_cflags -fPIC
@@ -1703,7 +1706,7 @@ AC_CHECK_FUNCS(rename)
 AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME,1,[no uname call]))
 AC_CHECK_FUNC(gettimeofday,, AC_DEFINE(NO_GETTOD,[1],[no gettimeofday call]))
 
-AC_CHECK_FUNCS(readlinkat)
+AC_CHECK_FUNCS(readlinkat,[],[AC_MSG_ERROR([must have readlinkat])])
 
 AC_CHECK_HEADERS(sys/ioctl.h)
 
--- gcl27-2.7.0.orig/git.tag
+++ gcl27-2.7.0/git.tag
@@ -1,2 +1,2 @@
-"Version_2_7_0pre13"
+"Version_2_7_0pre14"
 
--- gcl27-2.7.0.orig/h/cmponly_last.h
+++ gcl27-2.7.0/h/cmponly_last.h
@@ -5,29 +5,3 @@
 #undef _setjmp
 #define _setjmp ((int(*)(void *))dlsetjmp)
 #endif
-#undef getc
-#define getc   ((int(*)(void *))dlgetc)
-#undef putc
-#define putc   ((int(*)(int,void *))dlputc)
-#undef bzero
-#define bzero  ((void(*)(void *,int))dlbzero)
-#undef memset
-#define memset  ((void(*)(void *,int,int))dlmemset)
-#undef feof
-#define feof   ((int(*)(void *))dlfeof)
-#undef fdopen
-#define fdopen   (((void *)(*)(int,void *))dlfdopen)
-#undef write
-#define write   ((int(*)(int,void *,int))dlwrite)
-#undef read
-#define read   ((int(*)(int,void *,int))dlread)
-#undef isinf
-#define isinf  ((int(*)(double))dlisinf)
-#undef isnan
-#define isnan  ((int(*)(double))dlisnan)
-#undef pipe
-#define pipe  ((int(*)(int*))dlpipe)
-#undef close
-#define close  ((int(*)(int))dlclose)
-#undef fork
-#define fork  ((int(*)(void))dlfork)
--- gcl27-2.7.0.orig/h/compbas2.h
+++ gcl27-2.7.0/h/compbas2.h
@@ -10,7 +10,6 @@ EXTER int Rset;
 
 #ifndef U8_DEFINED
 
-#include <stdint.h>
 
 typedef int8_t  i8 ;
 typedef int16_t i16;
--- gcl27-2.7.0.orig/h/compprotos.h
+++ gcl27-2.7.0/h/compprotos.h
@@ -95,3 +95,4 @@ object Icall_gen_error_handler(object,ob
 object Icall_gen_error_handler_noreturn(object,object,object,object,ufixnum,...) __attribute__((noreturn));
 object file_stream(object);
 fixnum fixnum_expt(fixnum, fixnum);
+int gcl_puts(const char *);
--- gcl27-2.7.0.orig/h/lu.h
+++ gcl27-2.7.0/h/lu.h
@@ -8,21 +8,23 @@ typedef unsigned long   ufixnum;
 
 #ifndef WORDS_BIGENDIAN
 
-#define FRSTWRD(t_,a_...) ufixnum    e:1,m:1,f:1,    t_:5,t:5,st:3, ##a_
-#define FIRSTWORD         ufixnum    e:1,m:1,f:1,    tt:5,t:5,st:3,w:LM(16)
-#define FSTPWORD          ufixnum  emf:3,            tp:10,   st:3,w:LM(16)
-#define MARKWORD          ufixnum    e:1,   mf:2,    tt:5,t:5,x:LM(13)
-#define SGCMWORD          ufixnum    e:1,mf:2,       tt:5,t:5,x:LM(13)
-#define TYPEWORD          ufixnum  emf:3,            tt:5,t:5,x:LM(13)
+/* high bit must be clear to distinguish from high immediate fixnum*/
+#define FRSTWRD(t_,b_,a_...) ufixnum    e:1,m:1,f:1,    t_:5,t:5,st:3,a_,b_
+#define FIRSTWORD            ufixnum    e:1,m:1,f:1,    tt:5,t:5,st:3,w:LM(16)
+#define FSTPWORD             ufixnum  emf:3,            tp:10,   st:3,w:LM(16)
+#define MARKWORD             ufixnum    e:1,   mf:2,    tt:5,t:5,x:LM(13)
+#define SGCMWORD             ufixnum    e:1,mf:2,       tt:5,t:5,x:LM(13)
+#define TYPEWORD             ufixnum  emf:3,            tt:5,t:5,x:LM(13)
 
 #else
 
-#define FRSTWRD(t_,a_...) ufixnum ##a_,    st:3,t:5,t_:5,    f:1,m:1,e:1
-#define FIRSTWORD         ufixnum w:LM(16),st:3,t:5,tt:5,    f:1,m:1,e:1
-#define FSTPWORD          ufixnum w:LM(16),st:3,tp:10,             emf:3
-#define MARKWORD          ufixnum x:LM(13),     t:5,tt:5,       mf:2,e:1
-#define SGCMWORD          ufixnum x:LM(13),     t:5,tt:5,       mf:2,e:1
-#define TYPEWORD          ufixnum x:LM(13),     t:5,tt:5,          emf:3
+/* high bit must be clear to distinguish from high immediate fixnum*/
+#define FRSTWRD(t_,b_,a_...) ufixnum b_,a_,   st:3,t:5,t_:5,    f:1,m:1,e:1
+#define FIRSTWORD            ufixnum w:LM(16),st:3,t:5,tt:5,    f:1,m:1,e:1
+#define FSTPWORD             ufixnum w:LM(16),st:3,tp:10,             emf:3
+#define MARKWORD             ufixnum x:LM(13),     t:5,tt:5,       mf:2,e:1
+#define SGCMWORD             ufixnum x:LM(13),     t:5,tt:5,       mf:2,e:1
+#define TYPEWORD             ufixnum x:LM(13),     t:5,tt:5,          emf:3
 
 #endif
 
@@ -232,12 +234,13 @@ struct hashtable {           /*  hash ta
 #if SIZEOF_LONG == 8
 #define ARRAYWORD(b_,c_)						\
   FRSTWRD(J(b_,J(c_,elttype)),						\
+	  pd:LM(62),							\
 	  J(b_,J(c_,hasfillp)):1,					\
 	  J(b_,J(c_,adjustable)):1,					\
 	  J(b_,J(c_,writable)):1,					\
 	  J(b_,J(c_,offset)):3,						\
-	  J(b_,J(c_,eltsize)):4,					\
-	  J(b_,J(c_,eltmode)):4,					\
+	  J(b_,J(c_,eltsize)):3,					\
+	  J(b_,J(c_,eltmode)):3,					\
 	  J(b_,J(c_,rank)):ARRAY_RANK_BITS,				\
 	  J(b_,J(c_,dim)):ARRAY_DIMENSION_BITS)
 
@@ -249,18 +252,20 @@ struct hashtable {           /*  hash ta
 
 #define ARRAYWORD(b_,c_)						\
   FRSTWRD(J(b_,J(c_,elttype)),						\
+	  pad:LM(31),							\
 	  J(b_,J(c_,hasfillp)):1,					\
 	  J(b_,J(c_,adjustable)):1,					\
 	  J(b_,J(c_,writable)):1,					\
 	  J(b_,J(c_,offset)):3,						\
-	  J(b_,J(c_,eltsize)):4,					\
+	  J(b_,J(c_,eltsize)):3,					\
 	  J(b_,J(c_,rank)):ARRAY_RANK_BITS)
 
 #define atem(a_,b_,c_)					\
   ARRAYWORD(b_,c_);					\
   a_       *J(b_,J(c_,self));				\
   ufixnum   J(b_,J(c_,dim)):ARRAY_DIMENSION_BITS;	\
-  ufixnum   J(b_,J(c_,eltmode)):4
+  ufixnum   J(b_,J(c_,eltmode)):3;			\
+  ufixnum   pad1:LM(31)
 
 #endif
 
@@ -440,14 +445,16 @@ struct pathname {
 struct function {
 
   FRSTWRD(tt,
+#if SIZEOF_LONG == 8
+	  fw:LM(34),
 	  fun_minarg:6,    /* required arguments */
 	  fun_maxarg:6,    /* maximum arguments */
-#if SIZEOF_LONG == 8
 	  fun_neval:5,     /* maximum extra values set */
-	  fun_vv:1,        /* variable number of values */
-	  fw:LM(34)
+	  fun_vv:1         /* variable number of values */
 #else
-	  fw:LM(28)
+	  fw:LM(28),
+	  fun_minarg:6,    /* required arguments */
+	  fun_maxarg:6     /* maximum arguments */
 #endif
 	  );
 
@@ -468,8 +475,8 @@ struct function {
 struct cfdata {
 
   FRSTWRD(tt,
-	  cfd_prof:1,       /* profiling */
-	  cfw:LM(17)
+	  cfw:LM(17),
+	  cfd_prof:1       /* profiling */
 	  );
 
   char   *cfd_start;             /* beginning of contblock for fun */
--- gcl27-2.7.0.orig/h/protoize.h
+++ gcl27-2.7.0/h/protoize.h
@@ -1431,7 +1431,7 @@ object macro_def_int(object);
 
 int reset_plt(void);
 
-int msystem(const char *);
+int msystem(char *);
 
 fcomplex object_to_fcomplex(object);
 
@@ -1449,7 +1449,7 @@ void init_shared_memory(void);
 
 void * object_to_pointer(object);
 
-void * alloca(size_t);
+void * alloca(unsigned long);
 
 object make_dcomplex(dcomplex);
 
--- gcl27-2.7.0.orig/h/s390-linux.h
+++ gcl27-2.7.0/h/s390-linux.h
@@ -1,4 +1,4 @@
-n#include "linux.h"
+#include "linux.h"
 
 #ifdef IN_GBC
 #undef MPROTECT_ACTION_FLAGS
--- gcl27-2.7.0.orig/lsp/gcl_arraylib.lsp
+++ gcl27-2.7.0/lsp/gcl_arraylib.lsp
@@ -64,7 +64,7 @@
 					  (lambda (rs i) (,w rs i nil nil))
 					  (lambda (v rs i) (,w rs i t v)))))))))
 		  (lreduce (lambda (y x &aux (sz (caddr x))(fn (fifth x))(z (assoc sz y))(tp (cmp-norm-tp `(array ,(car x)))))
-			     (cond (z (setf (cadr z) (type-or1 (cadr z) tp) (caddr z) fn) y)
+			     (cond (z (setf (cadr z) (tp-or (cadr z) tp) (caddr z) fn) y)
 				   ((cons (list sz tp fn) y))))
 			   si::*array-type-info* :initial-value nil)))))
 (declaim (inline set-array))
@@ -387,7 +387,7 @@
 (setf (get 'array-dims 'type-propagator) 'array-dims-propagator)
 
 (defun applicable-array-infos (x k)
-  (when (type>= #tarray x)
+  (when (tp>= #tarray x)
     (cmp-norm-tp
      (cons 'member
 	   (mapcar k
@@ -415,10 +415,10 @@
 (defun array-rank-propagator (f x)
   (declare (ignore f))
   (cond
-    ((type>= #tvector x) #t(member 1))
+    ((tp>= #tvector x) #t(member 1))
     ((let ((d (atomic-tp-array-rank x)))
       (when d (object-tp d))))
-    ((type>= #tarray x) #trnkind)))
+    ((tp>= #tarray x) #trnkind)))
 (setf (get 'c-array-rank 'type-propagator) 'array-rank-propagator)
 
 (defun array-dim-propagator (f t1 &aux (d (atomic-tp-array-dimensions t1)))
--- gcl27-2.7.0.orig/lsp/gcl_callhash.lsp
+++ gcl27-2.7.0/lsp/gcl_callhash.lsp
@@ -41,7 +41,7 @@
     (mapc (lambda (x &aux (s (car x)) (cmp-sig (cdr x))(act-sig (car (sym-plist s))))
 	    (unless (eq sym s)
 	      (when act-sig
-		(unless (eq cmp-sig act-sig)
+		(unless (eq cmp-sig act-sig);Can be sig= if we don't hash
 		  (return-from needs-recompile (list (list sym s cmp-sig act-sig))))))) callees)
     nil))
 
--- gcl27-2.7.0.orig/lsp/gcl_debug.lsp
+++ gcl27-2.7.0/lsp/gcl_debug.lsp
@@ -5,11 +5,12 @@
 (In-package :SYSTEM)
 (import 'sloop::sloop)
 
-(defmacro f (op &rest args)
+(eval-when (compile eval)
+  (defmacro f (op &rest args)
     `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
 
-(defmacro fb (op &rest args)
-    `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
+  (defmacro fb (op &rest args)
+    `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args))))
 
 
 ;;; Some debugging features:
--- gcl27-2.7.0.orig/lsp/gcl_defmacro.lsp
+++ gcl27-2.7.0/lsp/gcl_defmacro.lsp
@@ -260,6 +260,7 @@
 (export '(blocked-body-name parse-body-header blla va-pop))
 
 (defun parse-body-header (x &optional doc decl ctps &aux (a (car x)))
+  (declare (proper-list x));FIXME
   (cond 
    ((unless (or doc ctps) (and (stringp a) (cdr x))) (parse-body-header (cdr x) a decl ctps))
    ((unless ctps (when (consp a) (eq (car a) 'declare)))  (parse-body-header (cdr x) doc (cons a decl) ctps))
--- gcl27-2.7.0.orig/lsp/gcl_defstruct.lsp
+++ gcl27-2.7.0/lsp/gcl_defstruct.lsp
@@ -339,10 +339,12 @@
 
 
 (defun tp-heads (tp0 &aux r)
-  (maphash (lambda (x y &aux (x (if (symbolp (car x)) (cdr x) x))); (print x)
-	     (mapl (lambda (x) (when (type= tp0 (car x)) (push x r))) (when (cdr x) (pop x)))
-	     (mapl (lambda (x) (when (type= (car x) tp0) (push x r))) x))
-	   *uniq-list*)
+  (maphash (lambda (x y); (print x)
+	     (mapl (lambda (x) (unless (eq '* (car x)) (when (tp= tp0 (car x)) (push x r)))) (car x))
+	     (if (cmpt (cadr x))
+		 (mapl (lambda (x) (when (tp= tp0 (car x)) (push x r))) (cdadr x))
+		 (when (tp= tp0 (cadr x)) (push (cdr x) r))))
+	   *uniq-sig*)
   r)
 
 (defun get-uniq-old-tp-heads (name);fixopt, others?
@@ -355,7 +357,7 @@
   (when i; (print (list 'foo (sdata-name i)))
     (let ((r (get-uniq-old-tp-heads (sdata-name i))))
       (pushnew name (s-data-included i))
-      (mapc (lambda (x &aux (tp1 (cmp-norm-tp (pop x))))
+      (mapc (lambda (x &aux (tp1 (uniq-tp (cmp-norm-tp (pop x)))))
 	      (mapc (lambda (x) (setf (car x) tp1)) x))
 	    r))))
 
--- gcl27-2.7.0.orig/lsp/gcl_evalmacros.lsp
+++ gcl27-2.7.0/lsp/gcl_evalmacros.lsp
@@ -445,21 +445,16 @@
 
 (defvar *alien-declarations* nil)
 
-(defvar *uniq-list* (gcl-make-hash-table 'equal))
-
-(defun uniq-list (list) (or (gethash list *uniq-list*) (setf (gethash list *uniq-list*) list)))
-
 (defun normalize-function-plist (plist)
-  (setf (car plist) (uniq-list (car plist))
-	(cadr plist) (mapcar (lambda (x)
-			       (uniq-list (cons (car x) (uniq-list (cdr x)))))
+  (setf (car plist) (uniq-sig (car plist))
+	(cadr plist) (mapcar (lambda (x) (cons (car x) (uniq-sig (cdr x))))
 			     (cadr plist)))
   plist)
 
 (defvar *function-plists* nil);rely on defvar not resetting to nil on loading this file compiled
 
 (defun make-function-plist (&rest args)
-  (cond ((and (fboundp 'cmp-norm-tp) (fboundp 'typep))
+  (cond ((and (fboundp 'cmp-norm-tp) (fboundp 'typep) (fboundp 'uniq-sig))
 	 (mapc 'normalize-function-plist *function-plists*)
 	 (unintern '*function-plists*)
 	 (defun make-function-plist (&rest args) (normalize-function-plist args))
@@ -508,7 +503,7 @@
   (unless (or (eq tp '*) (eq tp t))
     (mapc (lambda (x)
 	    (check-type x symbol)
-	    (assert (setq tp (type-and tp (get x 'cmp-type t))))
+	    (assert (setq tp (tp-and tp (get x 'cmp-type t))))
 	    (putprop x tp 'cmp-type)) l)));sch-global, improper-list
 
 (defun readable-sig (sig)
@@ -518,11 +513,6 @@
   (when (type>= t1 t2)
     (type>= t2 t1)))
 
-(defun sig= (s1 s2)
-  (when (eql (length (car s1)) (length (car s2)))
-    (unless (notevery 'type= (car s1) (car s2))
-      (type= (cadr s1) (cadr s2)))))
-
 ;FIXME, implement these in place of returns-exactly, etc.
 (defun ftype-to-sig (ftype &aux (a (pop ftype))(d (car ftype)))
   (let* ((x (member-if (lambda (x) (member x '(&optional &rest &key))) a))
@@ -540,8 +530,8 @@
 
 (defun proclaim-ftype (ftype var-list
 		       &aux  (sig (ftype-to-sig (cdr ftype)))
-			 (sig (uniq-list (list (mapcar 'norm-possibly-unkown-type (car sig))
-					       (norm-possibly-unkown-type (cadr sig))))))
+			 (sig (uniq-sig (list (mapcar 'norm-possibly-unkown-type (car sig))
+					      (norm-possibly-unkown-type (cadr sig))))))
   (declare (optimize (safety 2)))
   (mapc (lambda (x &aux (c (car (call x))))
 	  (cond (c (unless (sig= c sig)
--- gcl27-2.7.0.orig/lsp/gcl_iolib.lsp
+++ gcl27-2.7.0/lsp/gcl_iolib.lsp
@@ -406,9 +406,9 @@
 (defun get-byte-stream-nchars (s)
   (let* ((tp (stream-element-type s))(ctp (cmp-norm-tp tp)))
     (labels ((ts (i) (when (<= i 32)
-		       (if (type<= ctp (cmp-norm-tp `(unsigned-byte ,(* i char-length))))
+		       (if (tp<= ctp (cmp-norm-tp `(unsigned-byte ,(* i char-length))))
 			   i (ts (1+ i))))))
-      (cond ((type<= ctp #tcharacter) 1)
+      (cond ((tp<= ctp #tcharacter) 1)
 	    ((ts 0))
 	    (1)))))
 
--- gcl27-2.7.0.orig/lsp/gcl_listlib.lsp
+++ gcl27-2.7.0/lsp/gcl_listlib.lsp
@@ -217,13 +217,13 @@
   (maplist (lambda (x &aux (e (car x))) (if (consp e) (cons (car e) (cdr e)) e)) l))
 
 
-(defun nconc (&rest l &aux r rp)
-  (declare (dynamic-extent l))
-  (mapl (lambda (l &aux (it (car l)))
-	  (if rp (rplacd rp it) (setq r it))
-	  (when (and (cdr l) (consp it)) (setq rp (last it)))) l)
-  r)
 	
+(defun nconc (&rest l)
+  (declare (optimize (safety 1))(dynamic-extent l))
+  (if (cdr l)
+      (let ((x (pop l))(y (apply 'nconc l)))
+	(etypecase x (cons (rplacd (last x) y) x)(null y)))
+      (car l)))
 
 (defun nreconc (list tail &aux r)
   (declare (optimize (safety 1)))
@@ -265,13 +265,17 @@
 	    ((setq st (cons tr st) cs (cons g cs) tr (car tr))))))
 
 
-(defun append (&rest l &aux r rp)
-  (declare (dynamic-extent l))
-  (mapl (lambda (x &aux (y (car x)))
-	  (declare (optimize (safety 2)))
-	  (if (cdr x)
-	      (mapc (lambda (x) (collect r rp (cons x nil))) y)
-	    (collect r rp y))) l) r)
+(defun append (&rest l)
+  (declare (optimize (safety 1))(dynamic-extent l))
+  (if (cdr l)
+      (let ((x (pop l))(y (apply 'append l)))
+	(check-type x proper-list)
+	(if (typep y 'proper-list)
+	    (let (r rp) (mapc (lambda (x) (collect r rp (cons x nil))) x) (when rp (rplacd rp y)) (or r y))
+	    (labels ((f (x) (if x (cons (car x) (f (cdr x))) y))) (f x))))
+      (car l)))
+
+
 
 (defun revappend (list tail)
   (declare (optimize (safety 1)))
--- gcl27-2.7.0.orig/lsp/gcl_make_pathname.lsp
+++ gcl27-2.7.0/lsp/gcl_make_pathname.lsp
@@ -36,29 +36,29 @@
 
 (defun msub (a x) (if a (msub (cdr a) (substitute (caar a) (cdar a) x)) x))
 
-(defconstant +glob-to-regexp-alist+ (list (cons #v"{[^}]*}" (lambda (x) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x)))
+(defconstant +glob-to-regexp-alist+ (list (cons #v"{[^}]*}" (lambda (x y) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x)))
 					  (cons #v"\\[[^\\]*\\]"
-						(lambda (x)
+						(lambda (x y)
 						  (string-concatenate "(" (substitute #\^ #\! (subseq x 0 2)) (subseq x 2) ")")))
-					  (cons #v"\\*" (lambda (x) "([^/.]*)"))
-					  (cons #v"\\?" (lambda (x) "([^/.])"))
-					  (cons #v"\\." (lambda (x) "\\."))))
-
-(defconstant +physical-pathname-defaults+ '(("" "" "")
-					    ("" "" "")
-					    ("" "(/?([^/]+/)*)" "" "" "([^/]+/)" "/")
-					    ("" "([^/.]*)" "")
-					    ("." "(\\.[^/]*)?" "")
-					    ("" "" "")))
-(defconstant +logical-pathname-defaults+  '(("" "([-0-9A-Z]+:)?" ":")
-					    ("" "" "")
-					    ("" "(;?((\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*\\*?);)*)" "" "" "((\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*);)" ";");
+					  (cons #v"\\*" (lambda (x y) (if (plusp (length y)) (string-concatenate "([^" y "]*)") "(.*)")))
+					  (cons #v"\\?" (lambda (x y) (if (plusp (length y)) (string-concatenate "([^" y "])") "(.)")))
+					  (cons #v"\\." (lambda (x y) "\\."))))
+
+(defconstant +physical-pathname-defaults+ '(("" "" "" "")
+					    ("" "" "" "")
+					    ("" "(/?([^/]+/)*)" "" "" "" "([^/]+/)" "/" "/")
+					    ("" "([^/.]*)" "" ".")
+					    ("." "(\\.[^/]*)?" "" "")
+					    ("" "" "" "")))
+(defconstant +logical-pathname-defaults+  '(("" "([-0-9A-Z]+:)?" ":" ":")
+					    ("" "" "" "")
+					    ("" "(;?((\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*\\*?);)*)" "" "" "" "((\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*);)" ";" ";");
 ;					    ("" "(;?((\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*|\\*\\*);)*)" "" "" "((\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*);)" ";")
-					    ("" "(\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*)?" "")
+					    ("" "(\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*)?" "" ".")
 ;					    ("" "(\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*)?" "")
-					    ("." "(\\.(\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*))?" "")
+					    ("." "(\\.(\\*?([-0-9A-Z]+\\*)*[-0-9A-Z]*))?" "" ".")
 ;					    ("." "(\\.(\\*?([-0-9A-Z]+[-0-9A-Z\\*])+|\\*))?" "")
-					    ("." "(\\.([1-9][0-9]*|newest|NEWEST|\\*))?" "")))
+					    ("." "(\\.([1-9][0-9]*|newest|NEWEST|\\*))?" "" "")))
 
 (defun mglist (x &optional (b 0))
   (let* ((y (mapcan (lambda (z &aux (w (string-match (car z) x b)))
@@ -69,19 +69,19 @@
     (when z
       (cons z (mglist x (cadr z))))))
 
-(defun mgsub (x &optional (l (mglist x)) (b 0) &aux (w (pop l)))
+(defun mgsub (x term &optional (l (mglist x)) (b 0) &aux (w (pop l)))
   (if w
       (string-concatenate
 		   (subseq x b (car w))
-		   (funcall (cdaddr w) (subseq x (car w) (cadr w)))
-		   (mgsub x l (cadr w)))
+		   (funcall (cdaddr w) (subseq x (car w) (cadr w)) term)
+		   (mgsub x term l (cadr w)))
     (subseq x b)))
 
 
-(defun elsub (el x rp lp &aux (y x) (pref (pop y))(dflt (pop y))(post (pop y)))
+(defun elsub (el x rp lp &aux (y x) (pref (pop y))(dflt (pop y))(post (pop y))(term (pop y)))
 ;  (destructuring-bind (pref dflt post &rest y) x
     (etypecase el
-      (string (let ((x (list pref el post))) (unless (zerop (length dflt)) (if rp (mapcar 'mgsub x) x))))
+      (string (let ((x (list pref el post))) (unless (zerop (length dflt)) (if rp (mapcar (lambda (x) (mgsub x term)) x) x))))
       (integer (elsub (write-to-string el) x rp lp))
       ((eql :wild-inferiors) (if rp (list "(" dflt "*)") (elsub "**" x rp lp)))
       ((eql :wild) (if rp (list dflt) (elsub "*" x rp lp)))
--- gcl27-2.7.0.orig/lsp/gcl_mnum.lsp
+++ gcl27-2.7.0/lsp/gcl_mnum.lsp
@@ -89,7 +89,7 @@
 	  (body `(typecase x
 		   (long-float  (,b x))
 		   (short-float (,f x))
-                   ,@(when sqrtp `((integer (float (isqrt x) 0.0))))
+                   ,@(when sqrtp `((bignum (max (,b (float x 0.0)) (float (isqrt x) 0.0)))))
 		   (rational    (,b (float x 0.0)))
 		   (dcomplex    (,c x))
 		   (fcomplex    (,cf x))
--- gcl27-2.7.0.orig/lsp/gcl_numlib.lsp
+++ gcl27-2.7.0/lsp/gcl_numlib.lsp
@@ -180,10 +180,10 @@
 
 (defun make-complex-propagator (f t1 t2 t3 &aux (i -1))
   (declare (ignore f))
-  (reduce 'type-or1
+  (reduce 'tp-or
 	  (mapcan (lambda (x)
-		    (when (type-and t1 (object-tp (incf i)))
-		      (list (cmp-norm-tp `(complex* ,(cmp-unnorm-tp (type-and t2 (cadr x))) ,(cmp-unnorm-tp (type-and t3 (caddr x))))))))
+		    (when (tp-and t1 (object-tp (incf i)))
+		      (list (cmp-norm-tp `(complex* ,(cmp-unnorm-tp (tp-and t2 (cadr x))) ,(cmp-unnorm-tp (tp-and t3 (caddr x))))))))
 		  +make-complex-alist+)
 	  :initial-value nil))
 (setf (get 'make-complex 'type-propagator) 'make-complex-propagator)
--- gcl27-2.7.0.orig/lsp/gcl_predlib.lsp
+++ gcl27-2.7.0/lsp/gcl_predlib.lsp
@@ -49,13 +49,12 @@
 
 (defun ldiff-nf-with-last (l tl &aux r rp)
   (declare (optimize (safety 1)))
-  (check-type l list)
+  (check-type l proper-list)
   (labels ((srch (x)
-	     (cond ((eq x tl) (values r rp))
-		   ((atom x) (when rp (rplacd rp x)) (values (or r x) rp))
-		   (t (let ((tmp (cons (car x) nil)))
-			(setq rp (if rp (cdr (rplacd rp tmp)) (setq r tmp)))
-			(srch (cdr x)))))))
+	     (if (eq x tl) (values r rp)
+		 (let ((tmp (cons (car x) nil)))
+		   (setq rp (if rp (cdr (rplacd rp tmp)) (setq r tmp)))
+		   (srch (cdr x))))))
     (if tl (srch l) (values l nil))))
 (setf (get 'ldiff-nf-with-last 'cmp-inline) t)
 
@@ -294,6 +293,7 @@
       '(lremove lremove-if lremove-if-not lremove-duplicates lreduce))
 
 (defun lremove (q l &key (key #'identity) (test #'eql) &aux r rp (p l))
+  (declare (proper-list l));FIXME
   (mapl (lambda (x)
 		(when (funcall test q (funcall key (car x)))
 		  (let ((y (ldiff-nf p x)))
--- gcl27-2.7.0.orig/lsp/gcl_seq.lsp
+++ gcl27-2.7.0/lsp/gcl_seq.lsp
@@ -32,7 +32,7 @@
 		 ',(mapcar (lambda (x) (cons (cmp-norm-tp (car x)) (cdr x)))
 			   `((null . null) (cons . cons) (list . list)
 			     ,@(mapcar (lambda (x) `((vector ,x) . ,x)) +array-types+)))
-		 :test 'type<=))
+		 :test 'tp<=))
       (equal #tvector (if (listp x) (car x) x))))
 (setf (get 'make-sequence-element-type 'type-propagator) 'compiler::expand-type-propagator)
 
@@ -46,7 +46,7 @@
       (if (assoc-if-not (lambda (x) (or (eq x 'proper-cons) (eq x 'improper-cons))) (car x))
 	  (cons 0 y) y))))
 
-(defun cons-tp-lengths (tp &aux (tp (type-and #tcons tp)))
+(defun cons-tp-lengths (tp &aux (tp (tp-and #tcons tp)))
   (when (consp tp)
     (let ((x (lremove-duplicates (ntp-cons-lengths (caddr tp)))))
       (unless (member '* x)
@@ -62,14 +62,14 @@
 		 (nunion (fx (cdr x)) y)))
 	     (car x) :initial-value nil)))
 
-(defun vector-tp-lengths (tp &aux (tp (type-and #tvector tp)))
+(defun vector-tp-lengths (tp &aux (tp (tp-and #tvector tp)))
   (when (consp tp)
     (let ((x (lremove-duplicates (ntp-vector-lengths (caddr tp)))))
       (unless (member '* x) x))))
 
 (defun sequence-tp-lengths (type &aux (tp (cmp-norm-tp type)))
   #+pre-gcl(when (eq type 'string) (return-from sequence-tp-lengths nil))
-  (if (type<= tp #tlist)
+  (if (tp<= tp #tlist)
       (cons-tp-lengths tp)
       (vector-tp-lengths tp)))
 (setf (get 'sequence-tp-lengths 'type-propagator) 'compiler::expand-type-propagator)
@@ -78,7 +78,7 @@
 
 (defun sequence-tp-nonsimple-p (type)
   #-pre-gcl(when (eq type 'string) (return-from sequence-tp-nonsimple-p nil))
-  (type<= (cmp-norm-tp type) #tnon-simple-array))
+  (tp<= (cmp-norm-tp type) #tnon-simple-array))
 (setf (get 'sequence-tp-nonsimple-p 'type-propagator) 'compiler::expand-type-propagator)
 
 #.`(defun make-sequence (type size &key initial-element)
--- gcl27-2.7.0.orig/lsp/gcl_seqlib.lsp
+++ gcl27-2.7.0/lsp/gcl_seqlib.lsp
@@ -116,11 +116,12 @@
       (remove-loop (if from-end (1- end) start) (when l (or r s)))
       (unless from-end (collect indl inds indp)))
     (unless (cdr inds) (return-from remove seq))
-    (cond (l (let (w r rp)
-	       (dolist (ind inds r)
-		 (declare (proper-list ind));FIXME
-		 (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (unless ind (collect q r rp)) (setq w ind))
-		   (collect (cons (car q) nil) r rp)))))
+    (cond ((listp seq)
+	   (let (w r rp)
+	     (dolist (ind inds r)
+	       (declare (proper-list ind));FIXME
+	       (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (unless ind (collect q r rp)) (setq w ind))
+		 (collect (cons (car q) nil) r rp)))))
 	  ((let* ((q (make-array (- lsa (1- (length inds))) :element-type (array-element-type s))))
 	     (do* ((inds inds (cdr inds))(n -1 nn)(nn (car inds) (car inds))(k 0 (1+ k)))((not inds) q)
 	       (declare (seqind nn k));FIXME
@@ -138,11 +139,12 @@
       (delete-loop (if from-end (1- end) start) (when l (or r s)))
       (unless from-end (collect indl inds indp)))
     (unless (cdr inds) (return-from delete seq))
-    (cond (l (let (w r rp)
-	       (dolist (ind inds r)
-		 (declare (proper-list ind));FIXME
-		 (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (unless ind (collect q r rp)) (setq w ind))
-		   (collect q r rp)))))
+    (cond ((listp seq)
+	   (let (w r rp)
+	     (dolist (ind inds r)
+	       (declare (proper-list ind));FIXME
+	       (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (unless ind (collect q r rp)) (setq w ind))
+		 (collect q r rp)))))
 	  ((let* ((lq (- lsa (1- (length inds))))
 		  (q (if (array-has-fill-pointer-p seq) seq (make-array lq :element-type (array-element-type s)))))
 	     (do* ((inds inds (cdr inds))(n -1 nn)(nn (car inds) (car inds))(k 0 (1+ k)))((not inds) (when (eq seq q) (setf (fill-pointer q) lq)) q)
@@ -172,11 +174,12 @@
       (substitute-loop (if from-end (1- end) start) (when l (or r s)))
       (unless from-end (collect indl inds indp)))
     (unless (cdr inds) (return-from substitute seq))
-    (cond (l (let (w r rp)
-	       (dolist (ind inds r)
-		 (declare (proper-list ind));FIXME
-		 (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (collect (if ind (cons new nil) q) r rp) (setq w ind))
-		   (collect (cons (car q) nil) r rp)))))
+    (cond ((listp seq)
+	   (let (w r rp)
+	     (dolist (ind inds r)
+	       (declare (proper-list ind));FIXME
+	       (do ((q (if w (cdr w) seq) (cdr q))) ((eq q (or ind q)) (collect (if ind (cons new nil) q) r rp) (setq w ind))
+		 (collect (cons (car q) nil) r rp)))))
 	  ((let* ((q (make-array lsa :element-type (array-element-type s))))
 	     (do* ((inds inds (cdr inds))(n -1 nn)(nn (car inds) (car inds)))((not inds) q)
 	       (declare (seqind nn));FIXME
--- gcl27-2.7.0.orig/lsp/gcl_serror.lsp
+++ gcl27-2.7.0/lsp/gcl_serror.lsp
@@ -88,7 +88,7 @@
     (unless (stringp condition)
       (do nil ((not *handler-clusters*))
 	(dolist (handler (pop *handler-clusters*))
-	  (when (typep condition (car handler))
+	  (when (typep condition (car handler));FIXME, might string-match condition w handler in non-ansi here.
 	    (funcall (cdr handler) condition)))))
     nil))
 
@@ -126,7 +126,7 @@
 (defun coerce-to-string (datum args) 
   (cond ((stringp datum)
 	 (if args 
-	     (let ((*print-pretty* nil)
+	     (let ((*print-pretty* nil)(*print-readably* nil)
 		   (*print-level* *debug-print-level*)
 		   (*print-length* *debug-print-level*)
 		   (*print-case* :upcase))
--- gcl27-2.7.0.orig/lsp/gcl_sf.lsp
+++ gcl27-2.7.0/lsp/gcl_sf.lsp
@@ -123,9 +123,11 @@
 		(declare (optimize (safety 1)))
 		,@(unless (eq tp t) `((check-type x ,tp))),@(when ytp `((check-type y ,ytp)))
 	       ,@body)))
- 
- (defun gbe (f tp o s sz b a)  `((the ,tp ,(m& (m>> `(,f ,a ,o nil nil) s) (when (< (+ s sz) b) (mm (1- (ash 1 sz))))))))
- (defun sbe (f    o s sz b a) 
+
+ (defun ends (s sz b) (if (member :clx-little-endian *features*) s (- b s sz)))
+ (defun gbe (f tp o s sz b a &aux (s (ends s sz b)))
+   `((the ,tp ,(m& (m>> `(,f ,a ,o nil nil) s) (when (< (+ s sz) b) (mm (1- (ash 1 sz))))))))
+ (defun sbe (f    o s sz b a &aux (s (ends s sz b)))
    `((,f ,a ,o t ,(m\| (m<< 'y s) (when (< sz b) `(& (,f ,a ,o nil nil) ,(~ (mm (ash (1- (ash 1 sz)) s))))))) y))
  
  (defun fnk (k) (intern (string-concatenate "*" (string k))))
--- gcl27-2.7.0.orig/lsp/gcl_subtypep.lsp
+++ gcl27-2.7.0/lsp/gcl_subtypep.lsp
@@ -152,7 +152,7 @@
 	((when (eq x ax) (member-if 'listp x))
 	 (nconc (ar~ (substitute-if '* 'listp x)) (disu x)))
 	((eq x ax) (nconc (ar~ (cons 'rank (length x))) (onot x)))
-	((listp x) (nconc (ar~ (array-dimensions (car x))) x))
+	((listp x) (nconc (ar~ (array-dimensions (car x))) x));FIXME
 	((nconc (ar~ (array-dimensions x)) `((,x))))))
 
 (defun ar-ld (type &aux (s (eq (car type) 'simple-array)))
@@ -406,7 +406,7 @@
 (defun orthog-to-and-not (x c)
   (cond
    ((eq x t) (list c))
-   ((listp x) (nconc (std-car (car x) c) x))
+   ((listp x) (nconc (std-car (car x) c) x));FIXME
    ((s-class-p x) (gen-get-included x))
    (`((member ,x)))))
 
--- gcl27-2.7.0.orig/lsp/gcl_type.lsp
+++ gcl27-2.7.0/lsp/gcl_type.lsp
@@ -3,7 +3,8 @@
 
 (export '(cmp-norm-tp tp-p
 	  cmp-unnorm-tp
-	  type-and type-or1 type>= type<= tp-not tp-and tp-or
+;	  type-and type-or1 type>= type<=
+	  tp-not tp-and tp-or tp<= tp>= tp= uniq-tp tsrch uniq-sig
 	  atomic-tp tp-bnds object-tp
 	  cmpt t-to-nil returs-exactly funcallable-symbol-function
 	  infer-tp cnum creal long
@@ -21,17 +22,6 @@
 (defun t-to-nil (x) (unless (eq x t) x))
 (setf (get 't-to-nil 'cmp-inline) t)
 
-
-
-(defun real-rep (x)
-  (case x (integer 1) (ratio 1/2) (short-float 1.0s0) (long-float 1.0)))
-
-(defun complex-rep (x)
-  (let* ((s (symbolp x))
-	 (r (real-rep (if s x (car x))))
-	 (i (real-rep (if s x (cadr x)))))
-    (complex r i)))
-
 (let ((f (car (resolve-type `(or (array nil) ,@(mapcar 'car +r+))))))
   (unless (eq t f)
     (print (list "Representative types ill-defined" f))))
@@ -514,6 +504,15 @@
 
 (defun tp>= (t1 t2) (tp<= t2 t1))
 
+(defun tp= (t1 t2);(when (tp<= t1 t2) (tp<= t2 t1)))
+  (cond ((or (if t1 (eq t1 t) t) (if t2 (eq t2 t) t)) (eq t1 t2))
+	((and (atom t1) (atom t2)) (btp-equal t1 t2))
+	((or (atom t1) (atom t2)) nil)
+	((and (btp-equal (car t1) (car t2))
+	      (btp-equal (cadr t1) (cadr t2))
+	      (ntp-subtp (caddr t1) (caddr t2))
+	      (ntp-subtp (caddr t2) (caddr t1))))))
+
 (defun tp-p (x)
   (or (null x) (eq x t) (bit-vector-p x)
       (when (listp x)
@@ -574,53 +573,10 @@
 		 ((not returns-exactly values) (cons (car x) (mapcar 'cmp-unnorm-tp (cdr x)))))))
 	(x)))
 
-(defun null-list (x) (when (plusp x) (make-list x :initial-element #tnull)))
 
-(defun type-and (x y)
-  (cond ((eq x '*) y)
-	((eq y '*) x)
-	((and (cmpt x) (cmpt y))
-	 (let ((lx (length x))(ly (length y)))
-	   (cons (if (when (eql lx ly)
-		       (when (eq (car x) (car y))
-			 (eq (car x) 'returns-exactly)))
-		     'returns-exactly 'values)
-		 (mapcar 'type-and
-			 (append (cdr x) (null-list (- ly lx)))
-			 (append (cdr y) (null-list (- lx ly)))))))
-	((cmpt x) (type-and (or (cadr x) #tnull) y))
-	((cmpt y) (type-and x (or (cadr y) #tnull)))
-	((tp-and x y))))
-
-(defun type-or1 (x y)
-  (cond ((eq x '*) x)
-	((eq y '*) y)
-	((and (cmpt x) (cmpt y))
-	 (let ((lx (length x))(ly (length y)))
-	   (cons (if (when (eql lx ly)
-		    (when (eq (car x) (car y))
-		      (eq (car x) 'returns-exactly)))
-		  'returns-exactly 'values)
-		 (mapcar 'type-or1
-			 (append (cdr x) (null-list (- ly lx)))
-			 (append (cdr y) (null-list (- lx ly)))))))
-	((cmpt x) (type-or1 x `(returns-exactly ,y)))
-	((cmpt y) (type-or1 `(returns-exactly ,x) y))
-	((tp-or x y))))
-
-(defun type<= (x y)
-  (cond ((eq y '*))
-	((eq x '*) nil)
-	((and (cmpt x) (cmpt y))
-	 (do ((x (cdr x) (cdr x))(y (cdr y) (cdr y)))
-	     ((and (not x) (not y)) t)
-	     (unless (type<= (if x (car x) #tnull) (if y (car y) #tnull))
-	       (return nil))))
-	((cmpt x) (type<= x `(returns-exactly ,y)));FIXME
-	((cmpt y) (type<= `(returns-exactly ,x) y))
-	((tp<= x y))))
 
-(defun type>= (x y) (type<= y x))
+
+
 
 
 
@@ -656,7 +612,7 @@
   (lremove-duplicates (mapcar (lambda (x) (cdr (assoc (cadr x) rl))) a)))
 
 (defun ints-tps (a rl)
-  (lreduce (lambda (y x) (if (member (cdr x) a) (type-or1 y (car x)) y)) rl :initial-value nil))
+  (lreduce (lambda (y x) (if (member (cdr x) a) (tp-or y (car x)) y)) rl :initial-value nil))
 
 
 (eval-when
@@ -675,7 +631,7 @@
 		      (unless (tp<= q (cdr y))
 			`((,x ,(car y)
 			      ,(cond ((tp<= (car y) x) (car y))
-				     ((let ((x (type-and (car y) x)))
+				     ((let ((x (tp-and (car y) x)))
 					(when (decidable-type-p x)
 					  x)))
 				     (x))))))
@@ -788,10 +744,45 @@
 			    (lreduce (lambda (y x)
 				      (if (member-if (lambda (z) (member (car x) (cdr z))) y) y (cons x y)))
 				    (list-merge-sort
-				     (mapcar (lambda (z) (cons z (lremove z (lremove-if-not (lambda (x) (type>= z x)) y)))) y)
+				     (mapcar (lambda (z) (cons z (lremove z (lremove-if-not (lambda (x) (tp>= z x)) y)))) y)
 				     #'> #'length)
 				    :initial-value nil))
 		    #'> #'cons-count))))
     (cdr (group-useful-types t (mapcan (lambda (x &aux (x (cdr x)))
 					 (when x (unless (eq x t) (list x))))
 				       +useful-types-alist+)))))
+
+
+(defun tsrch (tp &optional (y *useful-type-tree*))
+  (let ((x (member tp y :test 'tp<= :key 'car)))
+    (when x
+      (or (tsrch tp (cdar x)) (caar x)))))
+
+(defvar *uniq-tp* (make-hash-table :test 'eq))
+
+(defun uniq-tp (tp)
+  (when tp
+    (or (eq tp t)
+	(let ((x (or (tsrch tp) t)))
+	  (if (tp<= x tp) x
+	      (let ((y (gethash x *uniq-tp*)))
+		(car (or (member tp y :test 'tp=)
+			 (setf (gethash x *uniq-tp*) (cons tp y))))))))))
+
+(defvar *uniq-sig* (make-hash-table :test 'equal))
+
+(defun uniq-sig (sig)
+  (let ((x (list (mapcar (lambda (x) (if (eq x '*) x (uniq-tp x))) (car sig))
+		 (cond ((cmpt (cadr sig)) (cons (caadr sig) (mapcar 'uniq-tp (cdadr sig))))
+		       ((eq (cadr sig) '*) (cadr sig))
+		       ((uniq-tp (cadr sig)))))))
+    (or (gethash x *uniq-sig*) (setf (gethash x *uniq-sig*) x))))
+
+(defun sig= (s1 s2)
+  (labels ((s= (l1 l2)
+	     (and (eql (length l1) (length l2))
+		  (every (lambda (x y) (if (or (symbolp x) (symbolp y)) (eq x y) (tp= x y))) l1 l2))))
+    (and (s= (car s1) (car s2))
+	 (if (or (cmpt (cadr s1)) (cmpt (cadr s2)))
+	     (and (cmpt (cadr s1)) (cmpt (cadr s2)) (s= (cadr s1) (cadr s2)))
+	     (s= (cdr s1) (cdr s2))))))
--- gcl27-2.7.0.orig/lsp/gcl_typecase.lsp
+++ gcl27-2.7.0/lsp/gcl_typecase.lsp
@@ -66,8 +66,8 @@
 
 (defun complex-part-types (z)
   (lreduce (lambda (y x)
-	     (if (type-and z (pop x))
-		 (mapcar 'type-or1 x y)
+	     (if (tp-and z (pop x))
+		 (mapcar 'tp-or x y)
 	       y))
 	   *complex-part-types* :initial-value (list nil nil)))
 
@@ -78,7 +78,7 @@
 	  (`(when ,x ,y)))))
 
 (defun msubt (o tp y &aux
-		(tp (let ((x (cmp-norm-tp tp))) (or (type>= x y) (when (type-and x y) tp))))
+		(tp (let ((x (cmp-norm-tp tp))) (or (tp>= x y) (when (tp-and x y) tp))))
 		(otp (normalize-type tp));FIXME normalize, eg structure
                 (lp (listp otp))(ctp (if lp (car otp) otp))(tp (when lp (cdr otp))))
   (case ctp
@@ -88,7 +88,7 @@
 	(member (if (cdr tp) `(member ,o ',tp) `(eql ,o ',(car tp))))
 	((t nil) ctp)
 	(otherwise
-	 (if (type>= (case ctp ((proper-cons improper-cons) #tcons) (otherwise (cmp-norm-tp ctp))) y) ;FIXME
+	 (if (tp>= (case ctp ((proper-cons improper-cons) #tcons) (otherwise (cmp-norm-tp ctp))) y) ;FIXME
              (ecase ctp
 		    (#.+range-types+ (mibb o tp))
 		    (complex* (let* ((x (complex-part-types y))
@@ -105,8 +105,8 @@
 		     (and-form
 		      (and-form (simple-type-case `(car ,o) (car tp)) (simple-type-case `(cdr ,o) (cadr tp)))
 		      (if (eq ctp 'proper-cons)
-			  (or (type>= #tproper-list (cmp-norm-tp (cadr tp))) `(not (improper-consp ,o)))
-			(or (type>= #t(not proper-list) (cmp-norm-tp (cadr tp))) `(improper-consp ,o))))))
+			  (or (tp>= #tproper-list (cmp-norm-tp (cadr tp))) `(not (improper-consp ,o)))
+			(or (tp>= #t(not proper-list) (cmp-norm-tp (cadr tp))) `(improper-consp ,o))))))
 	   (progn (break) (simple-type-case o otp))))));;undecidable aggregation support
 
 
@@ -116,14 +116,14 @@
     `((t ,(?-add 'progn z)))))
 
 
-(defun branch1 (x tpsff f o &aux (y (lreduce 'type-or1 (car x) :initial-value nil)))
+(defun branch1 (x tpsff f o &aux (y (lreduce 'tp-or (car x) :initial-value nil)))
   (let* ((z (mapcan (lambda (x) (branch tpsff x f y)) (cdr x)))
 	 (s (lremove nil (mapcar 'cdr (cdr x))))
-	 (z (if s (nconc z `((t ,(mkinfm f (tp-not (lreduce 'type-or1 s :initial-value nil)) (cdar o))))) z)))
+	 (z (if s (nconc z `((t ,(mkinfm f (tp-not (lreduce 'tp-or s :initial-value nil)) (cdar o))))) z)))
     (cons 'cond z)))
 
 (defun mkinfm (f tp z &aux (z (?-add 'progn z)))
-  (if (type>= tp #tt) z `(infer-tp ,f ,tp ,z)))
+  (if (tp>= tp #tt) z `(infer-tp ,f ,tp ,z)))
 
 (define-compiler-macro typecase (&whole w x &rest ff)
   (let* ((bind (unless (symbolp x) (list (list (gensym) x))));FIXME sgen?
@@ -132,7 +132,7 @@
 	 (ff (if o (ldiff-nf ff o) ff))
 	 (o (list (cons t (cdar o))))
 	 (tps (mapcar 'cmp-norm-tp (mapcar 'car ff)))
-	 (z nil) (tps (mapcar (lambda (x) (prog1 (type-and x (tp-not z)) (setq z (type-or1 x z)))) tps))
+	 (z nil) (tps (mapcar (lambda (x) (prog1 (tp-and x (tp-not z)) (setq z (tp-or x z)))) tps))
 	 (tpsff (mapcan (lambda (x y) (when x (list (cons x y)))) tps ff))
 	 (oth (unless (eq z t) (mkinfm f (tp-not z) (cdar o))))
 	 (nb (>= (+ (length tpsff) (if oth 1 0)) 2))
@@ -152,7 +152,7 @@
 (defun branches (f tpsff fnl o c)
   (mapcar (lambda (x)
 	    `(,(lremove-duplicates (mapcar (lambda (x) (cdr (assoc x fnl))) (car x)))
-	      ,(mkinfm f (lreduce 'type-or1 (car x) :initial-value nil) (list (branch1 x tpsff f o)))))
+	      ,(mkinfm f (lreduce 'tp-or (car x) :initial-value nil) (list (branch1 x tpsff f o)))))
 	  c))
 
 
@@ -171,7 +171,7 @@
 (eval-when
  (compile eval)
  (defun mtp8b (tpi &aux (rl (cdr (assoc 'tp8 +rs+)))
-		   (tp (lreduce 'type-or1
+		   (tp (lreduce 'tp-or
 				(mapcar 'car
 					(lremove-if-not
 					 (lambda (x) (eql tpi (cdr x)))
@@ -182,7 +182,7 @@
      (infer-tp
       y ,tp
       ,(let ((x (caar (member-if
-		       (lambda (x &aux (z (assoc (cmp-norm-tp (cdr x)) rl :test 'type<=)))
+		       (lambda (x &aux (z (assoc (cmp-norm-tp (cdr x)) rl :test 'tp<=)))
 			 (eql tpi (cdr z)))
 		       '((:fixnum . (and fixnum (not immfix)))
 			 (:float . short-float)
@@ -190,11 +190,11 @@
 			 (:fcomplex . fcomplex)
 			 (:dcomplex . dcomplex))))))
 	 (if x `(,(intern (string-upcase (strcat "C-" x "-=="))) x y)
-	   (cond ((type<= tp (cmp-norm-tp 'bignum)) `(eql 0 (mpz_cmp x y)))
-		 ((type<= tp (cmp-norm-tp 'ratio))
+	   (cond ((tp<= tp (cmp-norm-tp 'bignum)) `(eql 0 (mpz_cmp x y)))
+		 ((tp<= tp (cmp-norm-tp 'ratio))
 		  `(and (eql (numerator x) (numerator y))
 			(eql (denominator x) (denominator y))))
-		 ((type<= tp (cmp-norm-tp '(complex rational)))
+		 ((tp<= tp (cmp-norm-tp '(complex rational)))
 		  `(and (eql (realpart x) (realpart y))
 			(eql (imagpart x) (imagpart y))))
 		 ((error "Unknown tp")))))))))
--- gcl27-2.7.0.orig/makefile
+++ gcl27-2.7.0/makefile
@@ -382,7 +382,7 @@ CMPINCLUDE_FILES=$(HDIR)cmpincl1.h $(HDI
 	$(HDIR)lu.h $(HDIR)globals.h  $(HDIR)vs.h \
 	$(HDIR)bds.h $(HDIR)frame.h \
 	$(HDIR)lex.h \
-	$(HDIR)compbas2.h \
+	$(HDIR)mstdint.h $(HDIR)compbas2.h \
 	$(HDIR)compprotos.h  $(HDIR)immnum.h
 
 OTHERS=$(HDIR)notcomp.h $(HDIR)rgbc.h $(HDIR)stacks.h 
@@ -390,6 +390,9 @@ OTHERS=$(HDIR)notcomp.h $(HDIR)rgbc.h $(
 $(HDIR)new_decl.h:
 	(cd o && $(MAKE) ../$@)
 
+$(HDIR)mstdint.h:
+	echo "#include <stdint.h>" | $(CC) -E -I./$(HDIR) - | $(AWK) '/fsid/ {next} {print}' >$@
+
 $(HDIR)mcompdefs.h: $(HDIR)compdefs.h $(HDIR)new_decl.h
 	$(AWK) 'BEGIN {print "#include \"include.h\"";print "#include \"page.h\"";print "---"} {a=$$1;gsub("\\.\\.\\.","",a);print "\"#define " $$1 "\" " a}' $< |\
 	$(CC) -E -P -I./$(HDIR) - |\
@@ -419,4 +422,4 @@ kcp:
 	(cd go ; $(MAKE)  "CFLAGS = -I../h -pg  -c -g ")
 	(cd unixport ; $(MAKE) gcp)
 
-.INTERMEDIATE: $(HDIR)mcompdefs.h
+.INTERMEDIATE: $(HDIR)mcompdefs.h $(HDIR)mstdint.h
--- gcl27-2.7.0.orig/man/man1/gcl.1
+++ gcl27-2.7.0/man/man1/gcl.1
@@ -1,6 +1,6 @@
 .TH GCL 1 "17 March 1997"
 .SH NAME
-gcl \- GCL Common Lisp interpreter/compiler, CVS snapshot
+gcl \- GCL Common Lisp interpreter/compiler
 .SH SYNOPSIS
 .B gcl
 [
--- gcl27-2.7.0.orig/o/cfun.c
+++ gcl27-2.7.0/o/cfun.c
@@ -76,24 +76,19 @@ DEFUN("CFDL",object,fScfdl,SI,0,0,NONE,O
     
 DEFUN("DLSYM",object,fSdlsym,SI,2,2,NONE,OI,OO,OO,OO,(fixnum h,object name),"") {
 
-  char ch,*er;
+  char ch;
   void *ad;
 
   dlerror();
   name=coerce_to_string(name);
   ch=name->st.st_self[VLEN(name)];
   name->st.st_self[VLEN(name)]=0;
-  if (h) {
-    ad=dlsym((void *)h,name->st.st_self);
-    if (!dlerror()) {
-      name->st.st_self[VLEN(name)]=ch;
-      RETURN1(make_fixnum((fixnum)ad));
-    }
-  }
-  ad=dlsym(RTLD_DEFAULT,name->st.st_self);
-  if ((er=dlerror()))
-    FEerror("dlsym lookup failure on ~s: ~s",2,name,make_simple_string(er));
+  ad=dlsym(h ? (void *)h : RTLD_DEFAULT,name->st.st_self);
+  ad=ad ? ad : dlsym(RTLD_DEFAULT,name->st.st_self);
+  ad=ad<data_start ? dlsym(RTLD_NEXT,name->st.st_self) : ad;
   name->st.st_self[VLEN(name)]=ch;
+  if (ad<data_start)
+    FEerror("dlsym lookup failure on ~s: ~s",2,name,make_simple_string(dlerror()));
   RETURN1(make_fixnum((fixnum)ad));
 
 }
--- gcl27-2.7.0.orig/o/error.c
+++ gcl27-2.7.0/o/error.c
@@ -399,9 +399,9 @@ void
 check_arg_failed(int n)
 {
   if (n<vs_top-vs_base)
-    FEtoo_many_arguments(vs_base,vs_top);
-  else
     FEtoo_few_arguments(vs_base,vs_top);
+  else
+    FEtoo_many_arguments(vs_base,vs_top);
 }
 
 void
--- gcl27-2.7.0.orig/o/funlink.c
+++ gcl27-2.7.0/o/funlink.c
@@ -229,15 +229,13 @@ clean_link_array(object *ar, object *ar_
 
 DEFVAR("*FAST-LINK-WARNINGS*",sSAfast_link_warningsA,SI,Cnil,"");
 
-typedef struct {
-  ufixnum ma:6;
-  ufixnum xa:6;
-  ufixnum nv:5;
-  ufixnum vv:1;
-  ufixnum va:1;
-  ufixnum pu:1;
-  ufixnum nf:1;
-} fw;
+#include "pbits.h"
+
+#ifdef WORDS_BIGENDIAN
+typedef struct {ufixnum pad:LM(21),nf:1,pu:1,va:1,vv:1,nv:5,xa:6,ma:6;} fw;
+#else
+typedef struct {ufixnum ma:6,xa:6,nv:5,vv:1,va:1,pu:1,nf:1,pad:LM(21);} fw;
+#endif
 
 typedef union {
   ufixnum i;
@@ -330,7 +328,7 @@ call_proc_new(object sym,ufixnum clp,ufi
     if (tp==t_function) {
       fprintf(stderr,"Warning: arg/val mismatch in call to %-.*s (%p) prevents fast linking:\n %ld %ld/%ld %d(%d)  %ld %d  %ld %d  %ld, recompile caller\n",
 	      (int)(type_of(sym)==t_symbol ? VLEN(sym->s.s_name) : 0),sym->s.s_name->st.st_self,sym,
-	      argd,fun->fun.fun_argd,
+	      argd,(long)fun->fun.fun_argd,
 	      vald,fun->fun.fun_neval,fun->fun.fun_vv,
 	      margs,fun->fun.fun_minarg,nargs,fun->fun.fun_maxarg,pushed);
       fflush(stderr);
@@ -419,7 +417,7 @@ call_proc_new(object sym,ufixnum clp,ufi
     } else
       vs_top=base;
 
-    for (;--old_top>=vs_top;) *old_top=Cnil;
+    for (;--old_top>=vs_top && old_top>=vs_org;) *old_top=Cnil;
     
     switch(result_type) {
     case f_fixnum:
--- gcl27-2.7.0.orig/o/grab_defs.c
+++ gcl27-2.7.0/o/grab_defs.c
@@ -1,99 +1,42 @@
-/*
- Copyright (C) 1994  W. Schelter
- Copyright (C) 2024 Camm Maguire
-
-This file is part of GNU Common Lisp, herein referred to as GCL
-
-GCL is free software; you can redistribute it and/or modify it under
-the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GCL is distributed in the hope that it will be useful, but WITHOUT
-ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
-License for more details.
+/*  Copyright (C) 2024 Camm Maguire */
 
-*/
-
-#include <stdio.h>
-#include <stdlib.h>
 #include <string.h>
+#include <stdio.h>
 
-/* recognize \nDEF ......... ") and output it to stdout
-   [ie '")' is a two character sequence which ends the def
-   recognize \nDO_ [^\n]\n  and output it to stdout
-
-   Thus the DEF's MUST contain a doc string as last component.
-   
-*/
-int pos = 0;
-#define GETC(x) (pos++,getc(x))
-int
-read_some(char *buf, int n, int start_ch, int copy)
-     /* if copy is not 0 then copy characters to stdout while scanning
-	to find start_ch.   When you find it, read n characters into buf,
-	return the number of characters read into buf, but these characters
-	MUST be free of start_ch.
-	*/
-               
-                         
-{ int ch;
-  int prev = 0;
-  while (1)
-    { ch =GETC(stdin);
-      if (ch == EOF) return -1;
-      if (copy) {putc(ch,stdout);
-		 if (prev == '\n' && ch == '{')
-		   { fprintf(stderr,"Error(at char %d):found \\n{ inside section to copy\n",pos) ;
-		     exit(1);}
-		 prev = ch;
-	       }
-    AGAIN:
-      if (ch == start_ch)
-	{ int i = 0;
-	  while (i < n)
-	    { ch = GETC(stdin);
-	      if (ch == EOF) return i;
-	      if (copy) {putc(ch,stdout);
-			 if (prev == '\n' && ch == '{')
-			   { fprintf(stderr,"Error(at char %d):found \\n{ inside section to copy",pos) ;
-			     exit(1);}
-			 prev = ch;
-		       }
-
-	      if (ch == start_ch) goto AGAIN;
-	      buf[i++] = ch;
-	    }
-	  return i;
-	}}}
-	  
-	
+static char *
+match(char *c) {
+
+  char *d;
+
+  if (!(c=strstr(c,"DEF")))
+    return NULL;
+
+  for (d=c;*d && (*d=='_' || (*d>='A'&& *d<='Z'));d++);
+
+  return *d=='(' ? c : match(d);
 
-int
-main(void)
-{ 
-  char buf[20];
-  while (3==read_some(buf,3,'\n',0))
-   { buf[3] = 0;
-     if (strcmp(buf,"DEF") ==0)
-       { printf("\n%s",buf);
-	 while(1==read_some(buf,1,'\"',1))
-	   { if (buf[0] == ')')
-		 break;
-	       }}
-     if (strcmp(buf,"DO_") ==0)
-       {printf("\n%s",buf);
-	read_some(buf,0,'\n',1);
-	ungetc('\n',stdin);
-      }
-   }
-  printf("\n");
-  exit(0);
-  
 }
 
-	 
-	 
-	 
-       
+int
+main() {
+
+  char buf[4096],*c,*d=(void *)-1,*e;
+
+  for (;fgets(buf,sizeof(buf),stdin);) {
+
+    if (!strchr(buf,'\n')) {
+      fprintf(stderr,"Line too long, %s\n",buf);
+      return -1;
+    }
+
+    for (c=buf;(c=!d&&*c!='\n' ? c : match(c));c=e) {
+
+      d=strstr(c,"\")");
+      e=d ? d+2 : buf+strlen(buf)-1;
+      printf("%-.*s\n",e-c,c);
+
+    }
+
+  }
+
+}
--- gcl27-2.7.0.orig/o/main.c
+++ gcl27-2.7.0/o/main.c
@@ -839,6 +839,7 @@ initlisp(void) {
 #ifdef USE_READLINE
 	gcl_init_readline();
 #endif
+	gcl_init_safety();
 
 }
 object
--- gcl27-2.7.0.orig/o/makefile
+++ gcl27-2.7.0/o/makefile
@@ -42,8 +42,7 @@ gprof.o: gprof.c $(DECL)
 	[ "$(GPROF)" != "" ] || (touch foo.c ;$(CC) -c foo.c $(CFLAGS) $(DEFS) $(AUX_INFO) -o $@; rm foo.c)
 
 gprof.ini: gprof.c grab_defs
-	[ "$(GPROF)" = "" ] || $(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c |\
-		 sed -e 's,DEFUNB(\([^)]*\)),\nDEFUNB(\1),g' -e 's/DEF,//g' -e 's:\"[ ]*):\"):g' | ./grab_defs > $@
+	[ "$(GPROF)" = "" ] || $(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c | ./grab_defs > $@
 	touch $@
 
 prelink.o: prelink.c $(DECL)
@@ -64,8 +63,7 @@ prelink.o: prelink.c $(DECL)
 	rm $*.c
 
 boot.ini: boot.c grab_defs
-	$(CC) -DINICOMP -DNO_DEFUN -DNO_BOOT_H $(CFLAGS) $(DEFS) -E $*.c |\
-		 sed -e 's,DEFUN,\'$$'\nDEFUN,g' -e 's,^.* DEFUNB,DEFUNB,g' -e 's/DEF,//g' -e 's:\"[ ]*):\"):g' | ./grab_defs > $@
+	$(CC) -DINICOMP -DNO_DEFUN -DNO_BOOT_H $(CFLAGS) $(DEFS) -E $*.c | ./grab_defs > $@
 
 boot.h: boot.ini
 	echo '#include "make-init.h"' > $@
@@ -74,13 +72,11 @@ boot.h: boot.ini
 	echo '}' >> $@
 
 %.ini: %.c grab_defs
-	$(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c |\
-		 sed -e 's,DEFUNB(\([^)]*\)),\nDEFUNB(\1),g' -e 's/DEF,//g' -e 's:\"[ ]*):\"):g' | ./grab_defs > $*.ini
+	$(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c | ./grab_defs > $*.ini
 
 %.ini: %.d $(DPP) grab_defs
 	$(DPP) $*
-	$(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c |\
-		 sed -e 's,^.* DEFUNB,DEFUNB,g' -e 's/DEF,//g' | sed -e 's:\"[ ]*):\"):g' | ./grab_defs > $*.ini
+	$(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c | ./grab_defs > $*.ini
 	rm $*.c
 
 $(DPP):	../bin/dpp.c
--- gcl27-2.7.0.orig/o/print.d
+++ gcl27-2.7.0/o/print.d
@@ -292,8 +292,12 @@ travel_push(object x,fixnum lev,fixnum l
 
     case t_vector:
     case t_array:
+    case t_string:
+    case t_bitvector:
     case t_simple_vector:
     case t_simple_array:
+    case t_simple_string:
+    case t_simple_bitvector:
 
       mark(x);
       if (dga && (enum aelttype)x->a.a_elttype==aet_object)
@@ -745,14 +749,12 @@ edit_double(int n,double d,int *sp,char
   int i;
   
   if (!ISFINITE(d)) {
-    if (sSAprint_nansA->s.s_dbind !=Cnil) {
+    if (1 /* sSAprint_nansA->s.s_dbind !=Cnil */) {
       sprintf(s, "%e",d);
       *sp=2;
       return;
     }
-    else
-      FEerror("Can't print a non-number.",0);}
-  else
+  } else
     sprintf(b, "%*.*e",FPRC+8,FPRC,d);
   if (b[FPRC+3] != 'e') {
     sprintf(b, "%*.*e",FPRC+7,FPRC,d);
@@ -790,6 +792,13 @@ edit_double(int n,double d,int *sp,char
 }
 
 static void
+write_unreadable_str(object x,char *str) {
+  if (PRINTreadably)
+    PRINT_NOT_READABLE(x,"No readable print representation.");
+  write_str(str);
+}
+
+static void
 write_double(d, e, shortp)
 double d;
 int e;
@@ -804,7 +813,7 @@ bool shortp;
 	if (shortp)
 	  n = 10;
 	edit_double(n, d, &sign, buff, &exp, !shortp);
-	if (sign==2) {write_str("#<");
+	if (sign==2) {write_unreadable_str(make_longfloat(d),"#<");
 		      write_str(buff);
 		      write_ch('>');
 		      return;
@@ -1094,13 +1103,6 @@ write_level(void) {
 
 
 static void
-write_unreadable_str(object x,char *str) {
-  if (PRINTreadably)
-    PRINT_NOT_READABLE(x,"No readable print representation.");
-  write_str(str);
-}
-
-static void
 write_object(object x,int level) {
 
 	object r, y;
@@ -1301,6 +1303,7 @@ write_object(object x,int level) {
 	    break;
 	  }
 	case t_array:
+	case t_simple_array:
 	{
 		int subscripts[ARRAY_RANK_LIMIT];
 		int n, m;
@@ -1310,7 +1313,8 @@ write_object(object x,int level) {
 			write_addr(x);
 			write_str(">");
 			break;
-		}
+		} else if (x->v.v_elttype!=aet_object)
+		  write_unreadable_str(x,"");
 		if (PRINTcircle)
 		  if (write_sharp_eq(x,FALSE)==DONE) return;
 		if (PRINTlevel >= 0 && level >= PRINTlevel) {
@@ -1384,14 +1388,15 @@ write_object(object x,int level) {
 		break;
 	}
 
-	case t_simple_vector:
 	case t_vector:
+	case t_simple_vector:
 		if (!PRINTarray) {
 		        write_unreadable_str(x,"#<vector ");
 			write_addr(x);
 			write_str(">");
 			break;
-		}
+		} else if (x->v.v_elttype!=aet_object)
+		  write_unreadable_str(x,"");
 		if (PRINTcircle)
 		  if (write_sharp_eq(x,FALSE)==DONE) return;
 		if (PRINTlevel >= 0 && level >= PRINTlevel) {
@@ -1429,6 +1434,8 @@ write_object(object x,int level) {
 
 	case t_simple_string:
 	case t_string:
+	  if (PRINTcircle)
+	    if (write_sharp_eq(x,FALSE)==DONE) return;
 	  if (!PRINTescape) {
 		  for (i = 0;  i < VLEN(x);  i++)
 		    write_ch((uchar)x->st.st_self[i]);
@@ -1446,6 +1453,8 @@ write_object(object x,int level) {
 
 	case t_bitvector:
 	case t_simple_bitvector:
+	  if (PRINTcircle)
+	    if (write_sharp_eq(x,FALSE)==DONE) return;
 		if (!PRINTarray) {
 		        write_unreadable_str(x,"#<bit-vector ");
 			write_addr(x);
--- gcl27-2.7.0.orig/o/save.c
+++ gcl27-2.7.0/o/save.c
@@ -22,11 +22,11 @@ LFD(siLsave)(void) {
   extern char *kcl_self;
 
   check_arg(1);
-  check_type_or_pathname_string_symbol_stream(&vs_base[0]);
-  coerce_to_filename(vs_base[0], FN1);
 
   gcl_cleanup(1);
-  
+
+  coerce_to_filename(vs_base[0], FN1);
+
 #ifdef MEMORY_SAVE
   MEMORY_SAVE(kcl_self,FN1);
 #else	  
--- gcl27-2.7.0.orig/o/toplevel.c
+++ gcl27-2.7.0/o/toplevel.c
@@ -119,7 +119,7 @@ DEFUN("*MAKE-CONSTANT",object,fSAmake_co
   check_type_sym(&s);
   switch(s->s.s_stype) {
   case stp_special:
-    FEerror("The argument ~S to DEFCONSTANT is a special variable.", 1, s);
+    FEerror("The argument ~S to defconstant is a special variable.", 1, s);
     break;
   case stp_constant:
     break;
--- gcl27-2.7.0.orig/o/unixfsys.c
+++ gcl27-2.7.0/o/unixfsys.c
@@ -277,16 +277,11 @@ DEFUN("READLINKAT",object,fSreadlinkat,S
   ssize_t l,z1;
 
   check_type_string(&s);
-  /* l=s->st.st_hasfillp ? s->st.st_fillp : s->st.st_dim; */
-  z1=length(s);
+  z1=VLEN(s);
   massert(z1<sizeof(FN1));
   memcpy(FN1,s->st.st_self,z1);
   FN1[z1]=0;
-#ifndef HAVE_READLINKAT
   massert((l=readlinkat(d ? dirfd((DIR *)d) : AT_FDCWD,FN1,FN2,sizeof(FN2)))>=0 && l<sizeof(FN2));
-#else
-  l=0;
-#endif
   FN2[l]=0;
   RETURN1(make_simple_string(FN2));
 
@@ -382,7 +377,7 @@ DEFUN("READDIR",object,fSreaddir,SI,3,3,
 
   tl=telldir((DIR *)x);
 
-  for (;(e=readdir((DIR *)x)) && y!=DT_UNKNOWN && y!=(d_type=get_d_type(e,s)););
+  for (;(e=readdir((DIR *)x)) && y!=DT_UNKNOWN && (d_type=get_d_type(e,s))!=DT_UNKNOWN && y!=d_type;);
   if (!e) RETURN1(Cnil);
 
   if (s==Cnil)
--- gcl27-2.7.0.orig/o/unixsys.c
+++ gcl27-2.7.0/o/unixsys.c
@@ -36,11 +36,10 @@ Foundation, 675 Mass Ave, Cambridge, MA
 
 
 int
-vsystem(const char *command) {
+vsystem(char *command) {
 
-  unsigned j,n=strlen(command)+1;
-  char *z,*c;
-  const char *x1[]={"/bin/sh","-c",NULL,NULL},*spc=" \n\t",**p1,**pp;
+  char *c;
+  const char *x1[]={"/bin/sh","-c",NULL,NULL},*spc=" \n\t",**p1,**pp,**pe;
   int s;
   pid_t pid;
   posix_spawnattr_t attr;
@@ -53,14 +52,10 @@ vsystem(const char *command) {
 
   else {
 
-    massert(n<sizeof(FN1));
-    memcpy((z=FN1),command,n);
-    for (j=1,c=z;strtok(c,spc);c=NULL,j++);
-
-    memcpy(z,command,n);
-    massert(j*sizeof(*p1)<sizeof(FN2));
     p1=(void *)FN2;
-    for (pp=p1,c=z;(*pp=strtok(c,spc));c=NULL,pp++);
+    pe=p1+sizeof(FN2)/sizeof(*p1);
+    for (pp=p1,c=command;pp<pe && (*pp=strtok(c,spc));c=NULL,pp++);
+    massert(pp<pe);
 
   }
 
@@ -153,7 +148,7 @@ char *command;
 #endif
 
 int
-msystem(const char *s) {
+msystem(char *s) {
 
   return psystem(s);
 
@@ -162,7 +157,7 @@ msystem(const char *s) {
 static void
 FFN(siLsystem)(void)
 {
-	char command[32768];
+	static char command[32768];
 	int i;
 
 	check_arg(1);
--- gcl27-2.7.0.orig/o/usig2.c
+++ gcl27-2.7.0/o/usig2.c
@@ -150,7 +150,6 @@ gcl_init_safety(void)
   safety_required[SIGALRM]=sig_normal;
 }
   
-DO_INIT(gcl_init_safety();)
 DEFUN("SIGNAL-SAFETY-REQUIRED",object,sSsignal_safety_required,SI,2,2,
 	  NONE,OI,IO,OO,OO,(fixnum signo,fixnum safety),
       "Set the safety level required for handling SIGNO to SAFETY, or if \
--- gcl27-2.7.0.orig/pcl/gcl_pcl_macros.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_macros.lisp
@@ -320,9 +320,9 @@
 ;;; Similar to printing-random-object in the lisp machine but much simpler
 ;;; and machine independent.
 (defmacro printing-random-thing ((thing stream) &body body)
-  #+cmu17
+  #+(or cmu17 gcl)
   `(print-unreadable-object (,thing ,stream :identity t) ,@body)
-  #-cmu17
+  #-(or cmu17 gcl)
   (once-only (thing stream)
     `(progn
        #+cmu
--- gcl27-2.7.0.orig/unixport/boot.lisp
+++ gcl27-2.7.0/unixport/boot.lisp
@@ -53,8 +53,8 @@
 (doit (if (boundp 'noload) 'identity 'load) 'compile-file)
 
 
-#+pre-gcl
+#+(and pre-gcl xgcl)
 (progn
   (si::chdir "../xgcl-2")
   (load "sysdef.lisp")(load "sys-proclaim.lisp")(compiler::cdebug))
-#+pre-gcl(xlib::compile-xgcl)
+#+(and pre-gcl xgcl)(xlib::compile-xgcl)
--- gcl27-2.7.0.orig/unixport/sys.c
+++ gcl27-2.7.0/unixport/sys.c
@@ -23,7 +23,6 @@
 static void
 ar_init_fn(void (fn)(void),const char *s) {
 
-  char b[200];
   struct stat ss;
   
   if (stat(s,&ss)) {
@@ -32,8 +31,8 @@ ar_init_fn(void (fn)(void),const char *s
     char *d=sysd ? sysd : kcl_self;
     int n=sysd ? strlen(sysd) : dir_name_length(d);
 
-    assert(snprintf(b,sizeof(b),"ar x %-.*s%s %s",n,d,libname,s)>0);
-    assert(!msystem(b));
+    assert(snprintf(FN1,sizeof(FN1),"ar x %-.*s%s %s",n,d,libname,s)>0);
+    assert(!msystem(FN1));
 
   }
   gcl_init_or_load1(fn,s);
@@ -65,16 +64,15 @@ ar_check_init_fn(void (fn)(void),char *s
 static void
 lsp_init(const char *a,const char *b) {
 
-  char c[200],*d;
-  char *sysd=getenv("GCL_SYSDIR");
+  char *d,*sysd=getenv("GCL_SYSDIR");
   int n;
 
   d=sysd ? sysd : kcl_self;
   n=sysd ? strlen(sysd) : dir_name_length(d);
-  assert(snprintf(c,sizeof(c),"%-.*s../%s/%s%s",n,d,a,b,strchr(b,'.') ? "" : ".lsp")>0);
-  printf("loading %s\n",c);
+  assert(snprintf(FN1,sizeof(FN1),"%-.*s../%s/%s%s",n,d,a,b,strchr(b,'.') ? "" : ".lsp")>0);
+  printf("loading %s\n",FN1);
   fflush(stdout);
-  load(c);
+  load(FN1);
 
 }
 
--- gcl27-2.7.0.orig/xgcl-2/general-c.c
+++ gcl27-2.7.0/xgcl-2/general-c.c
@@ -1,7 +1,7 @@
 /* general-c.c           Hiep Huu Nguyen   24 Jun 06 */
 /* 27 Aug 92; 24 Jan 06; 22 Jun 06  */
 /* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin.
-/* ; Copyright (c) 2024 Camm Maguire
+   ; Copyright (c) 2024 Camm Maguire
 
 ; See the files gnu.license and dec.copyright .
 
