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-28) unstable; urgency=medium
 .
   * Version_2_7_0pre31
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-12-04

--- gcl27-2.7.0.orig/clcs/gcl_clcs_condition_definitions.lisp
+++ gcl27-2.7.0/clcs/gcl_clcs_condition_definitions.lisp
@@ -119,23 +119,11 @@
 		       (internal-condition-function-name condition)))
 	     (call-next-method))))
 
-(define-condition internal-simple-condition (internal-condition simple-condition) nil)
 
 (define-condition internal-simple-error (internal-condition simple-error) nil)
 (define-condition internal-simple-type-error (internal-condition simple-type-error) nil)
 (define-condition internal-simple-warning (internal-condition simple-warning) nil)
 
-       (DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) NIL)
-
-       (DEFINE-CONDITION FLOATING-POINT-INVALID-OPERATION
-           (ARITHMETIC-ERROR) NIL)
-
-       (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR)
-           NIL)
-(DEFINE-CONDITION FLOATING-POINT-INEXACT (ARITHMETIC-ERROR) NIL)
-
-       (DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR)
-           NIL)
 #.`(progn
      ,@(mapcar (lambda (x) 
 		 `(define-condition
@@ -179,17 +167,3 @@
 	    ,@(mapcar (lambda (x) `(define-condition ,@x nil))
 		      (make-sub-fpe-conditions fpe::+fe-list+))))))
   (make-fpe-conditions))
-
-#.`(progn
-     ,@(mapcar (lambda (x)
-		 `(define-condition
-		    ,(intern (concatenate 'string "INTERNAL-SIMPLE-" (string x)))
-		    (internal-condition simple-condition ,x) nil))
-	       `(stack-overflow storage-exhausted print-not-readable end-of-file style-warning
-				unbound-variable unbound-slot undefined-function division-by-zero
-				case-failure abort-failure
-				,@(mapcar (lambda (x) (intern (concatenate 'string "FLOATING-POINT-" (string x))))
-					  '(overflow underflow invalid-operation inexact))
-				,@(mapcar (lambda (x) (intern (concatenate 'string (string x) "-ERROR")))
-					  '(program control parse stream reader file
-						    package cell arithmetic pathname)))))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpcall.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpcall.lsp
@@ -551,27 +551,6 @@
 ;;     (and loc (wt "}")))
 ;;   (unwind-exit 'fun-val))
 
-(defun inline-proc (fname args &aux (n (length args)) res (obj fname))
-  (format t "~%Using ifuncall: ~a" fname)
-  (let ((result
-  (case n
-	;(0  (list () t (flags ans set) (format nil "ifuncall0(VV[~d])" obj)))
-	(1 (list  '(t) t (flags ans set) (format nil "ifuncall1(~a,(#0))" (vv-str obj))
-		  'ifuncall))
-	(2 (list  '(t t) t  (flags ans set) 
-		       (format nil "ifuncall2(~a,(#0),(#1))" (vv-str obj))
-		       'ifuncall))
-	(t
-	 (list (make-list n :initial-element t)
-	       t (flags ans set) 
-	       (format nil "ifuncall(~a,~a~{,#~a~})"
-		       (vv-str obj) n
-		       (dotimes (i n(nreverse res))
-				(push i res)))
-	       'ifuncall)))))
-    (push (cons fname result ) *inline-functions*)
-    result
-    ))
 
 
 (si:putprop 'simple-call 'wt-simple-call 'wt-loc)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpeval.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpeval.lsp
@@ -1904,9 +1904,18 @@
 ;; 	(`(call-global ,info ,fn ,fms nil ,@ll))))
 
 
+;; Objects when read are not eql
+(declaim (inline unreadable-individual-p))
+(defun unreadable-individual-p (x)
+  (typecase x (number)(symbol (not (symbol-package x)))(otherwise t)))
+
+(defun bump-unreadable-individuals (tp)
+  (bump-individuals 'unreadable-individual-p tp))
+
+
+
 (defun type-from-args (fun fms last info &aux x)
   (when (symbolp fun)
-    (setf (info-type info) (type-and (or (get-return-type fun) '*) (info-type info)))
     (unless (get fun 'c1no-side-effects)
       (setf (info-flags info) (logior (info-flags info) (iflags side-effects)))));FIXME
   (cond ((setq x (member-if-not 'identity fms :key (lambda (x) (info-type (cadr x)))))
@@ -1919,6 +1928,12 @@
 	 (let ((tp (result-type-from-args fun (mapcar (lambda (x) (info-type (cadr x))) fms))))
 	   (when tp
 	     (setf (info-type info) (type-and (info-type info) tp))))))
+  ;;FIXME inline functions from source with static data
+  ;; (when (unreadable-individuals-p (info-type info))
+  ;;   (keyed-cmpnote (list fun 'unreadable-individuals)
+  ;; 		   "~<;; ~@;Setting return type on call to ~s to nil due to unreadable individuals in~%~s~;~:>"
+  ;; 		   (list fun (cmp-unnorm-tp (info-type info))))
+  ;;   (setf (info-type info) nil))
   (info-type info))
 
 (defun coerce-ff (ff)
@@ -2054,15 +2069,15 @@
 (defun mi1 (fn args &optional last ff)
   (let* ((tp (get-return-type fn))
 	 (sp (if (when (symbolp fn) (get fn 'no-sp-change)) 0 1))
-	 (info (make-info :type tp :flags (if sp (iflags sp-change) 0)))
+	 (info (make-info :type (bump-unreadable-individuals tp) :flags (if sp (iflags sp-change) 0)))
  	 (res (mi1a fn args last info ff)))
     (when tp 
       (let ((t1 (info-type (cadr res)))(t2 (info-type info)))
 	(when (exit-to-fmla-p)
 	  (labels ((tb (tp) (type-or1 (when (type-and #tnull tp) #tnull)
 				      (when (type-and #t(not null) tp) #ttrue))))
-		  (setq t1 (tb t1) t2 (tb t2))))
-	(setf (info-type (cadr res)) (type-and t1 t2))))
+	    (setq t1 (tb t1) t2 (tb t2) tp (tb tp))))
+	(setf (info-type (cadr res)) (type-and t1 (if (type= t1 t2) tp t2)))))
     res))
 
 ;; (defun mi1 (fn args &optional last)
@@ -2746,7 +2761,7 @@
 	   (fun (when (fun-p fun) fun))
 	   (sym (car (atomic-tp (info-type (cadar nargs))))))
       (when (and sym fun);FIXME
-	(push (cons sym (apply 'si::make-function-plist (exp-sig (car (fun-call fun))) (cdr (fun-call fun)))) si::*sig-discovery-props*))))
+	(push (cons sym (apply 'si::make-function-plist (fun-call fun))) si::*sig-discovery-props*))))
   form)
 
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpflet.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpflet.lsp
@@ -306,150 +306,6 @@
 
   (c2expr body))
 
-;; (defun c2flet-labels (labels local-funs closures body
-;; 			     &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) 
-;; 			     (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*))
-
-;;   (mapc (lambda (def &aux (fun (car def)))
-;; 	  (setf (fun-ref fun) (vs-push))
-;; 	  (clink (fun-ref fun))
-;; 	  (setf (fun-ref-ccb fun) (ccb-vs-push))) closures)
-
-;;   (mapc (lambda (def &aux (fun (car def)))
-;; 	  (when (eq (fun-ref fun) t) (setf (fun-ref fun) (vs-push)))) local-funs)
-  
-;;   (let ((*clink*  (if labels *clink*  oclink))
-;; 	(*ccb-vs* (if labels *ccb-vs* occb-vs)))
-
-;;     (mapc (lambda (def &aux (fun (pop def)))
-;; 	    (setf (fun-level fun) *level*)
-;; 	    (push (list nil *clink* *ccb-vs* fun (car def) *initial-ccb-vs*) *local-funs*)) local-funs)
-    
-;;     (when (or local-funs closures) (base-used));fixme
-    
-;;     (dolist (def closures)
-      
-;;       (let* ((fun (pop def))
-;; 	     (lam (car def))
-;; 	     (cl (fun-call fun))
-;; 	     (sig (car cl))
-;; 	     (at (car sig))
-;; 	     (rt (cadr sig)))
-	
-;; 	(push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs*)
-      
-;; 	(wt-nl)
-;; 	(wt-vs* (fun-ref fun))
-;; 	(wt "=")
-
-;; 	(setf (fun-vv fun) 
-;; 	      (cons '|#,| `(let ((si::f #'(lambda nil nil)))
-;; 			     (si::add-hash si::f ,@(mapcar (lambda (x) `',x) (export-call cl)))
-;; ;			     (si::call si::f)
-;; 			     si::f)))
-
-;; 	(wt-make-cclosure (fun-cfun fun) (fun-name fun) 
-;; 			  (fun-vv fun) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*)
-;; 	(wt ";")
-;; 	(wt-nl))))
-
-;;   (c2expr body))
-
-;; (defun c2flet-labels (labels local-funs closures body
-;; 			     &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) 
-;; 			     (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*))
-
-;;   (mapc (lambda (def &aux (fun (car def)))
-;; 	  (setf (fun-ref fun) (vs-push))
-;; 	  (clink (fun-ref fun))
-;; 	  (setf (fun-ref-ccb fun) (ccb-vs-push))) closures)
-
-;;   (mapc (lambda (def &aux (fun (car def)))
-;; 	  (when (eq (fun-ref fun) t) (setf (fun-ref fun) (vs-push)))) local-funs)
-  
-;;   (let ((*clink*  (if labels *clink*  oclink))
-;; 	(*ccb-vs* (if labels *ccb-vs* occb-vs)))
-
-;;     (mapc (lambda (def &aux (fun (pop def)))
-;; 	    (setf (fun-level fun) *level*)
-;; 	    (push (list nil *clink* *ccb-vs* fun (car def) *initial-ccb-vs*) *local-funs*)) local-funs)
-    
-;;     (when (or local-funs closures) (base-used));fixme
-    
-;;     (dolist (def closures)
-      
-;;       (let* ((fun (pop def))
-;; 	     (lam (car def))
-;; 	     (cl (fun-call fun))
-;; 	     (sig (car cl))
-;; 	     (at (car sig))
-;; 	     (rt (cadr sig)))
-	
-;; 	(push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam) *local-funs*)
-      
-;; 	(wt-nl)
-;; 	(wt-vs* (fun-ref fun))
-;; 	(wt "=")
-;; 	(wt-make-cclosure (fun-cfun fun) (fun-name fun) 
-;; 			  (1+ *next-vv*) (new-proclaimed-argd at rt) (argsizes at rt (xa lam)) *clink*)
-;; 	(wt ";")
-;; 	(wt-nl)
-	
-;; 	(push-data-incf nil)
-;; 	(add-init
-;; 	 `(si::setvv ,*next-vv*
-;; 		     (let ((si::f #'(lambda nil nil)))
-;; 		       (si::add-hash si::f ,@(mapcar (lambda (x) `',x) (export-call cl)))
-;; 		       (si::call si::f))) t))))
-
-;;   (c2expr body))
-
-;; (defun c2flet-labels (labels local-funs closures body
-;; 			     &aux (*vs* *vs*) (oclink *clink*) (*clink* *clink*) 
-;; 			     (occb-vs *ccb-vs*) (*ccb-vs* *ccb-vs*))
-
-;;   (dolist (def closures)
-;;     (let ((fun (car def)))
-;;       (setf (fun-ref fun) (vs-push))
-;;       (clink (fun-ref fun))
-;;       (setf (fun-ref-ccb fun) (ccb-vs-push))))
-    
-;;   (let ((*clink*  (if labels *clink*  oclink))
-;; 	(*ccb-vs* (if labels *ccb-vs* occb-vs)))
-
-;;     (dolist (def local-funs)
-;;       (setf (fun-level (car def)) *level*)
-;;       (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*))
-    
-;;     (when (or local-funs closures) (base-used));fixme
-    
-;;     (dolist (def closures)
-      
-;;       (push (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* (car def) (cadr def)) *local-funs*)
-      
-;;       (let* ((fun (car def))
-;; 	     (cl (fun-call fun))
-;; 	     (sig (car cl))
-;; 	     (at (car sig))
-;; 	     (rt (cadr sig)))
-	
-;; 	(wt-nl)
-;; 	(wt-vs* (fun-ref fun))
-;; 	(wt "=")
-;; 	(wt-make-cclosure (fun-cfun fun) (fun-name fun) 
-;; 			  (1+ *next-vv*) (new-proclaimed-argd at rt) (argsizes at rt (xa (cadr def))) *clink*)
-;; 	(wt ";")
-;; 	(wt-nl)
-	
-;; 	(push-data-incf nil)
-;; 	(add-init
-;; 	 `(si::setvv ,*next-vv*
-;; 		     (let ((si::f #'(lambda nil nil)))
-;; 		       (si::add-hash si::f ,@(mapcar (lambda (x) `',x) (cons (export-sig (car cl)) (cdr cl))))
-;; 		       (si::call si::f))) t))))
-
-;;   (c2expr body))
-
 (defun c2flet (local-funs closures body)
   (c2flet-labels nil local-funs closures body))
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpfun.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpfun.lsp
@@ -252,6 +252,7 @@
 
 
 (defun do-eq-et-al (fn args &aux (info (make-info :type #tboolean)));FIXME  pass through function inlining
+  (cmpck (not (eql (length args) 2)) "Predicate ~s takes two arguments" fn)
   (let* ((nargs (c1args args info))
 	 (t1 (info-type (cadar nargs)))(t2 (info-type (cadadr nargs)))
 	 (a1 (atomic-tp t1))(a2 (atomic-tp t2))
@@ -260,8 +261,7 @@
 		(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)))
+	 (nfn (if (when (eq nfn 'equal) (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)))))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmplabel.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmplabel.lsp
@@ -149,7 +149,7 @@
 		     (let ((*value-to-go* (list 'cvar fv))) (set-loc loc))
 		     (wt-nl "}"))
 		    ((set-loc loc)))
-	      (when (or (eq loc 'fun-val) ;FIXME this can lead to a value stack leak on vs_top, e.g. typep with local mvfun tpi
+	      (when (or (eq loc 'fun-val) ;FIXME believe this is fixed now -- check;FIXME this can lead to a value stack leak on vs_top, e.g. typep with local mvfun tpi
 			(and (consp loc)
 			     (rassoc (car loc) +inline-types-alist+)
 			     (flag-p (cadr loc) sets-vs-top)))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpmain.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpmain.lsp
@@ -426,6 +426,11 @@ Cannot compile ~a.~%" (namestring (merge
 	    form)
 	  na))))))
 
+(defun interpret (name &aux (form (get-named-form name)))
+  (if (when (consp (cadr form)) (eq (caadr form) 'macro))
+      (setf (macro-function (cdadr form)) (eval (cons 'lambda (cddr form))))
+      (eval form)))
+
 (defvar *compiler-compile-data* nil)
 
 (defun compile (name &optional def &aux na tem gaz (*default-pathname-defaults* #p"."))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpspecial.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpspecial.lsp
@@ -69,67 +69,6 @@
 ;  (setf (info-type info) type)
   form)
 
-;; (defun c1the (args &aux info form type dtype)
-;;   (when (or (endp args) (endp (cdr args)))
-;;     (too-few-args 'the 2 (length args)))
-;;   (unless (endp (cddr args))
-;;     (too-many-args 'the 2 (length args)))
-;;   (setq form (c1expr (cadr args)))
-;;   (setq info (copy-info (cadr form)))
-;;   (setq dtype (max-vtp (car args)))
-;;   (when *compiler-new-safety* (setq dtype t))
-;;   (when (eq dtype #tboolean) 
-;;     (unless (type>= dtype (info-type info))
-;;       (return-from c1the (c1expr `(when ,(cadr args) t)))))
-;;   (setq type (type-and dtype (info-type info)))
-;;   (when (null type)
-;;     (when (eq (car form) 'var)
-;;       (do-setq-tp (car (third form)) nil dtype))
-;;     (setq type dtype)
-;;     (unless (not (and dtype (info-type info)))
-;;       (cmpwarn "Type mismatch was found in ~s.~%Modifying type ~s to ~s."
-;; 	       (cons 'the args) (info-type info) type)))
-
-;;   (setq form (list* (car form) info (cddr form)))
-;;   (if (type>= #tboolean dtype) (setf (info-type (cadr form)) type) (set-form-type form type))
-;; ;  (setf (info-type info) type)
-;;   form)
-
-;; (defun c1the (args &aux info form type dtype)
-;;   (when (or (endp args) (endp (cdr args)))
-;;     (too-few-args 'the 2 (length args)))
-;;   (unless (endp (cddr args))
-;;     (too-many-args 'the 2 (length args)))
-;;   (setq form (c1expr (cadr args)))
-;;   (setq info (copy-info (cadr form)))
-;;   (setq dtype (max-vtp (car args)))
-;;   (when *compiler-new-safety* (setq dtype t))
-;;   (when (eq dtype #tboolean) 
-;;     (unless (type>= dtype (info-type info))
-;;       (return-from c1the (c1expr `(when ,(cadr args) t)))))
-;;   (setq type (type-and dtype (info-type info)))
-;;   (when (null type)
-;;     (when (eq (car form) 'var)
-;;       (let* ((v (car (third form)))
-;; 	     (tg (t-to-nil (var-tag v))))
-;; 	(when tg
-;; 	  (unless (type>= (var-mt v) dtype)
-;; 	    (setf (var-mt v) (type-or1 (var-mt v) dtype))
-;; 	    (let* ((nmt (bump-tp (var-mt v)))
-;; 		   (nmt (type-and nmt (var-dt v))))
-;; 	      (setf (var-mt v) nmt))
-;; 	    (pushnew v *tvc*)
-;; 	    (when (member (var-tag v) *catch-tags*) (throw (var-tag v) v))))))
-;;     (setq type dtype)
-;;     (unless (not (and dtype (info-type info)))
-;;       (cmpwarn "Type mismatch was found in ~s.~%Modifying type ~s to ~s."
-;; 	       (cons 'the args) (info-type info) type)))
-
-;;   (setq form (list* (car form) info (cddr form)))
-;;   (if (type>= #tboolean dtype) (setf (info-type (cadr form)) type) (set-form-type form type))
-;; ;  (setf (info-type info) type)
-;;   form)
-
 (defun c1compiler-let (args &aux (symbols nil) (values nil))
   (when (endp args) (too-few-args 'compiler-let 1 0))
   (dolist (spec (car args))
@@ -252,44 +191,12 @@
 (defun export-sig (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 (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))
-;; 	(tp)))
 
 (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (regs (if (is-first-var (car regs)) (cdr regs) regs)))
-  `((,@(mapcar 'var-type regs)
-     ,@(when (or (is-narg-le l) (member-if 'identity (cdr args))) `(*)))
-    ,(mbt (info-type (cadar (last l))))))
-
-;; (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (narg (is-narg-le l))
-;; 		       (first (is-first-var (car regs))) (regs (if first (cdr regs) regs)))
-;;   `((,@(mapcar (lambda (x) (if *compiler-new-safety* #tt (var-type x))) regs)
-;; 	  ,@(when (or narg (member-if 'identity (cdr args))) `(*)))
-;; 	,(mbt (info-type (cadar (last l))))))
-
-;; (defun mbt (tp &aux (atp (atomic-tp tp)))
-;;   (if (and atp (consp (car atp)))
-;;       (if (cdar atp) #tcons #tproper-cons)
-;;     tp))
-
-;; (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (narg (is-narg-le l))
-;; 		       (first (is-first-var (car regs))) (regs (if first (cdr regs) regs)))
-;;   `((,@(mapcar 'var-type regs)
-;; 	  ,@(when (or narg (member-if 'identity (cdr args))) `(*)))
-;; 	,(mbt (info-type (cadar (last l))))))
-
-;; (defun lam-e-to-sig (l &aux (args (caddr l)) (regs (car args)) (narg (is-narg-le l))
-;; 		       (first (is-first-var (car regs))) (regs (if first (cdr regs) regs)))
-;;   `((,@(mapcar 'var-type regs)
-;; 	  ,@(when (or narg (member-if 'identity (cdr args))) `(*)))
-;; 	,(info-type (cadar (last l)))))
+  (export-sig
+   `((,@(mapcar 'var-type regs)
+	,@(when (or (is-narg-le l) (member-if 'identity (cdr args))) `(*)))
+     ,(info-type (cadar (last l))))))
 
 (defun compress-fle (l y z)
   (let* ((fname (pop l))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptop.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptop.lsp
@@ -621,43 +621,6 @@
 		 ,@(mapcar 'c1retnote (last le))))
 	(otherwise (list (car le) 'foo))))
 
-;; (defun c1retnote (le)
-;;   (case (car le)
-;; 	(call-global (list (third le) (export-type (info-type (second le)))))
-;; 	((let let* flet labels) 
-;; 	 (list (car le) (export-type (info-type (second le))) 
-;; 	       (mapcar (lambda (x y) (list (var-name x) (c1retnote y))) 
-;; 		       (third le) (fourth le)) 
-;; 	       (c1retnote (fifth le))))
-;; 	(recur (list (car le) (export-type (info-type (second le)))))
-;; 	(progn 
-;; 	  (list (car le)
-;; 		(export-type (info-type (second le)))
-;; 		(mapcar 'c1retnote (car (last le)))))
-;; 	((lambda decl-body) 
-;; 	 (list (car le) 
-;; 	       (export-type (info-type (second le))) 
-;; 	       (c1retnote (car (last le)))))
-;; 	(inline 
-;; 	 (list (car le) (caddr le)
-;; 	       (export-type (info-type (second le))) 
-;; 	       (c1retnote (car (last le)))))
-;; 	(if 
-;; 	    (list (car le) 
-;; 		  (export-type (info-type (second le))) 
-;; 		  (c1retnote (fourth le)) 
-;; 		  (c1retnote (fifth le))))
-;; 	(var (list (car le) (export-type (info-type (second le))) (var-name (car (third le)))))
-;; 	(location (list (car le) (export-type (info-type (second le)))))
-;; 	(return-from (list (car le) (c1retnote (car (last le)))))
-;; 	(tagbody `(,(car le) 
-;; 		   ,(export-type (info-type (second le))) 
-;; 		   ,@(mapcar (lambda(x) (unless (tag-p x) (c1retnote x))) (car (last le)))))
-;; 	(block `(,(car le) 
-;; 		 ,(export-type (info-type (second le))) 
-;; 		 ,@(mapcar 'c1retnote (last le))))
-;; 	(otherwise (list (car le) 'foo))))
-
 ;(defvar *callees* nil)
 
 (defconstant +nargs+ (let ((s (tmpsym))) (setf (get s 'tmp) t) s))
@@ -1014,93 +977,12 @@
 	   (do-l1-fun name src e b))
 	  (l))))
 
-;; (defun do-l1-fun (name src e b &aux *callees* (*recursion-detected* (cons (list name) *recursion-detected*))
-;; 		       *warning-note-stack* *undefined-vars*)
-
-;;   (let* ((l (c1lambda-expr src))
-;; 	 (osig (car e))
-;; 	 (sig (lam-e-to-sig l))
-;; 	 (rd (cdar *recursion-detected*))
-;; 	 (sig (if rd (list (car sig) (bbump-tp (cadr sig))) sig)))
-;;     (setf (car e) sig (cadr e) *callees*)
-;;     (if (and rd (not (eq (cadr osig) (cadr sig))))
-;; 	(progn
-;; 	  (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig)
-;; 	  (do-l1-fun name src e b))
-;;       (progn
-;; 	(unless (suppress-unfinalized-local-fun-warnings name b l)
-;; 	  (output-warning-note-stack))
-;; 	l))))
-
-;; (defun do-l1-fun (name src e &aux *callees* (*recursion-detected* (cons (list name) *recursion-detected*)) *warning-note-stack*)
-
-;;   (let* ((l (c1lambda-expr src))
-;; 	 (osig (car e))
-;; 	 (sig (lam-e-to-sig l))
-;; 	 (rd (cdar *recursion-detected*))
-;; 	 (sig (if rd (list (car sig) (bbump-tp (cadr sig))) sig)))
-;;     (setf (car e) sig (cadr e) *callees*)
-;;     (if (and rd (not (eq (cadr osig) (cadr sig))))
-;; 	(progn (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig) (do-l1-fun name src e))
-;;       l)))
-
-;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*)
-
-;;   (let* ((l (c1lambda-expr src))
-;; 	 (osig (car e))
-;; 	 (sig (lam-e-to-sig l))
-;; 	 (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig)))
-;;     (setf (car e) sig (cadr e) *callees*)
-;;     (if (and *recursion-detected* (not (eq (cadr osig) (cadr sig))))
-;; 	(progn (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig) (do-l1-fun name src e))
-;;       l)))
-
-;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*)
-
-;;   (let* ((l (c1lambda-expr src))
-;; 	 (osig (car e))
-;; 	 (sig (lam-e-to-sig l))
-;; 	 (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig)))
-;;     (setf (car e) sig (cadr e) *callees*)
-;;     (if (and *recursion-detected* (not (eq (cadr osig) (cadr sig))))
-;; 	(do-l1-fun name src e)
-;;       l)))
-
-;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*)
-
-;;   (let* ((l (c1lambda-expr src))
-;; 	 (osig (car e))
-;; 	 (sig (lam-e-to-sig l))
-;; 	 (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig)))
-;;     (setf (car e) sig (cadr e) *callees*)
-;;     (cond ((and *recursion-detected* (not (eq (cadr osig) (cadr sig))))
-;; 	   (do-l1-fun name src e))
-;; 	  (t (output-warning-note-stack) l))))
-
-;; (defun do-l1-fun (name src e &aux *callees* *recursion-detected* *warning-note-stack*)
-
-;;   (let* ((l (c1lambda-expr src name))
-;; 	 (osig (car e))
-;; 	 (sig (lam-e-to-sig l))
-;; 	 (sig (if *recursion-detected* (list (car sig) (bbump-tp (cadr sig))) sig)))
-;;     (setf (car e) sig (cadr e) *callees*)
-;;     (cond ((and *recursion-detected* (not (eq (cadr osig) (cadr sig))))
-;; 	   (do-l1-fun name src e))
-;; 	  (t (output-warning-note-stack) l))))
-
-;   (unless (member v (caaddr l));FIXME not in info referred?
-;     (when (and (var-p v) (var-cb v)) 
-;       )))
 
 (defun get-clv (l &aux (i (cadr l)))
   (mapcan
    (lambda (v) (when (var-p v) (list (list v nil))))
    (append (info-ref-ccb i) (info-ref-clb i))))
 
-;; (defun get-clv (l &aux r)
-;;   (do-referred-cb (v (cadr l)) (push (list (var-name v) (car (atomic-tp (var-type v)))) r))
-;;   (nreverse r))
-
 (defvar *top-tag* nil)
 
 (defun top-level-src-p nil (not (member *top-tag* *lexical-env-mask*)))
@@ -1119,76 +1001,16 @@
 	 (*current-form* `(defun ,name))
 	 (l (do-l1-fun name (cdr (new-defun-args src tag)) e b))
 	 (clv (get-clv l)))
-    (setf (car e) (export-sig (car e))
-	  (second e) (mapcan (lambda (x) (when (symbolp x) (list (cons x (get-sig x)))))
+    (setf (second e) (mapcan (lambda (x) (when (symbolp x) (list (cons x (get-sig x)))))
 			     (info-ref (cadr l)))
 	  (third e) (list src clv name)
 	  (fourth e) *function-filename*
 	  (fifth e) (if (= (length clv) 0) 1 0)
 	  (sixth e) name)
     (when *sig-discovery*
-      (when (symbol-package name) (unless (eq name 'lambda) (push (cons name (apply 'si::make-function-plist (exp-sig (pop e)) e)) si::*sig-discovery-props*))))
+      (when (symbol-package name) (unless (eq name 'lambda) (push (cons name (apply 'si::make-function-plist e)) si::*sig-discovery-props*))))
     l))
 
-;; (defun do-fun (name src e vis b)
-;;   (let* ((*vars*   (when b (cons b *vars*)))
-;; 	 (*funs*   (when b (cons b *funs*)))
-;; 	 (*blocks* (when b (cons b *blocks*)))
-;; 	 (*tags*   (when b (cons b *tags*)))
-;; 	 (tag (tmpsym))
-;; 	 (*prev-sri* (append *src-inline-recursion* *prev-sri*))
-;; 	 (*src-inline-recursion* (when vis (list (list (list (sir-name name)) tag (ttl-ll (cadr src))))))
-;; 	 (*c1exit* (list name))
-;; 	 (*current-form* `(defun ,name))
-;; 	 (l (do-l1-fun name (cdr (new-defun-args src tag)) e))
-;; 	 (clv (get-clv l)))
-;;     (setf (car e) (export-sig (car e))
-;; 	  (third e) (list src clv name)
-;; 	  (fourth e) (unless *compiler-compile* (namestring (truename (pathname *compiler-input*))))
-;; 	  (fifth e) (if (= (length clv) 0) 1 0))
-;;     (if (suppress-unfinalized-local-fun-warnings name b l)
-;;       (output-warning-note-stack))
-;;     l))
-
-;; (defun do-fun (name src e vis b)
-;;   (let* ((*vars*   (when b (cons b *vars*)))
-;; 	 (*funs*   (when b (cons b *funs*)))
-;; 	 (*blocks* (when b (cons b *blocks*)))
-;; 	 (*tags*   (when b (cons b *tags*)))
-;; 	 (tag (tmpsym))
-;; 	 (*prev-sri* (append *src-inline-recursion* *prev-sri*))
-;; 	 (*src-inline-recursion* (when vis (list (list (list (sir-name name)) tag (ttl-ll (cadr src))))))
-;; 	 *provisional-inline*
-;; 	 (*c1exit* (list name))
-;; 	 (*current-form* `(defun ,name))
-;; 	 (l (do-l1-fun name (cdr (new-defun-args src tag)) e))
-;; 	 (clv (get-clv l)))
-;;     (setf (car e) (export-sig (car e))
-;; 	  (third e) (list src clv name)
-;; 	  (fourth e) (unless *compiler-compile* (namestring (truename (pathname *compiler-input*))))
-;; 	  (fifth e) (if (= (length clv) 0) 1 0))
-;;     l))
-
-;; (defun do-fun (name src e vis b)
-;;   (let* ((*vars*   (when b (cons b *vars*)))
-;; 	 (*funs*   (when b (cons b *funs*)))
-;; 	 (*blocks* (when b (cons b *blocks*)))
-;; 	 (*tags*   (when b (cons b *tags*)))
-;; 	 (tag (tmpsym))
-;; 	 (*prev-sri* (append *src-inline-recursion* *prev-sri*))
-;; 	 (*src-inline-recursion* (when vis (list (list (list (sir-name name)) tag (ttl-ll (cadr src))))))
-;; 	 *provisional-inline*
-;; 	 (*c1exit* (list name))
-;; 	 (*current-form* `(defun ,name))
-;; 	 (l (do-l1-fun name (cdr (new-defun-args src tag)) e))
-;; 	 (clv (get-clv l)))
-;;     (setf (car e) (export-sig (car e))
-;; 	  (third e) (compress-fle src clv name)
-;; 	  (fourth e) (unless *compiler-compile* (namestring (pathname *compiler-input*)))
-;; 	  (fifth e) (if (= (length clv) 0) 1 0))
-;;     l))
-	 
-
 (defun t1defun (args &aux *warning-note-stack*)
 
   (when (or (endp args) (endp (cdr args)))
@@ -1209,7 +1031,8 @@
     (keyed-cmpnote (list 'return-type fname) "~s return type ~s" fname (c1retnote lambda-expr))
     
     (unless (or (equal osig sig) (eq fname 'cmp-anon));FIXME
-      (cmpwarn "signature change on function ~s,~%   ~s -> ~s~%" fname (ex-sig osig) (ex-sig sig))
+      (cmpwarn "signature change on function ~s,~%   ~s -> ~s~%"
+	       fname (si::readable-sig osig) (si::readable-sig sig))
       (setq *new-sigs-in-file* 
 	    (some
 	     (lambda (x) 
@@ -1233,52 +1056,6 @@
 
     (output-warning-note-stack)))
 
-;; (defun t1defun (args)
-
-;;   (when (or (endp args) (endp (cdr args)))
-;;     (too-few-args 'defun 2 (length args)))
-;;   (maybe-eval nil (cons 'defun args))
-
-;;   (let* ((fname (car args))
-;; 	 (fname (or (function-symbol fname) (cmperr "The function name ~s is not valid." fname)))
-;; 	 (cfun (next-cfun))
-;; 	 (oal (get-arg-types fname)) (ort (get-return-type fname))
-;; 	 (osig (export-sig (list oal ort)))
-;; 	 (e (or (gethash fname *sigs*) (setf (gethash fname *sigs*) (make-list 5))))
-;; 	 (setjmps *setjmps*)
-;; 	 (lambda-expr (do-fun fname args e t nil))
-;; 	 (sig (car e))
-;; 	 (osig (if (equal '((*) *) osig) sig osig));FIXME
-;; 	 (doc (cadddr lambda-expr)))
-	 
-;;     (or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) 1))
-;;     (keyed-cmpnote (list 'return-type fname) "~s return type ~s" fname (c1retnote lambda-expr))
-    
-;;     (unless (or (equal osig sig) (eq fname 'cmp-anon));FIXME
-;;       (cmpwarn "signature change on function ~s, ~s -> ~s~%" fname osig sig)
-;;       (setq *new-sigs-in-file* 
-;; 	    (some
-;; 	     (lambda (x) 
-;; 	       (unless (eq x fname)
-;; 		 (multiple-value-bind 
-;; 		  (s f) (gethash x *sigs*) 
-;; 		  (declare (ignore s))
-;; 		  (when f (list x fname osig sig))))) (si::callers fname))))
-    
-;;     (push (let* ((at (car sig))
-;; 		 (al (mapcar (lambda (x) (link-rt (cmp-norm-tp x) nil)) at))
-;; 		 (rt (link-rt (cmp-norm-tp (cadr sig)) nil)))
-;; 	    (list fname al rt
-;; 		  (if (single-type-p rt) (flags set ans) (flags set ans sets-vs-top))
-;; 		  (make-inline-string cfun at fname)))
-;; 	  *inline-functions*)
-  
-;;     (push (list 'defun fname cfun lambda-expr doc nil) *top-level-forms*)
-;;     (push (cons fname cfun) *global-funs*)
-    
-;;     (when *sig-discovery*
-;;       (si::add-hash fname (car e) (cadr e) nil nil))))
-
 (defun make-inline-string (cfun args fname)
   (format nil "~d(~a)" (c-function-name "LI" cfun fname)
 	  (make-inline-arg-str (list args (get-return-type fname)))))
@@ -1331,114 +1108,13 @@
 	((eq (car tp) 'returns-exactly) (- 2 (length tp)))
 	((- (length tp) 2))))
 
-(defun ty-contains-binding-p (tp)
-  (typecase tp
-    (binding t)
-    (atom nil)
-    (cons (or (ty-contains-binding-p (car tp)) (ty-contains-binding-p (cdr tp))))))
-
-(defun ex-tp (tp)
-  (if (ty-contains-binding-p tp)
-      (car tp)
-      tp))
-
-(defun exp-sig (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)
   `(apply 'make-function-plist
-	  ',(exp-sig (pop l))
+	  ',(pop l)
 	  ',(pop l)
 	  ',(apply 'compress-fle (pop l))
 	  ',l))
 
-
-(defun wt-if-proclaimed (fname cfun lambda-expr macro-p)
-  (when (fast-link-proclaimed-type-p fname);(and  (not (member '* (get-arg-types fname))))
-    (let* ((sig (lam-e-to-sig lambda-expr))
-	   (at (pop sig))
-	   (rt (car sig)))
-      (cond ((assoc fname *inline-functions*)
-	     (let ((finit `(init-function ,(export-call-struct (gethash fname *sigs*))
-					     ,(add-address (c-function-name "LI" cfun fname))
-					     nil nil -1 ,(new-proclaimed-argd at rt)
-					     ,(argsizes at rt (xa lambda-expr)))))
-	       (add-init `(fset ',fname ,(if macro-p `(cons 'macro ,finit) finit)))))
-	    ((let ((arg-c (length (car (lambda-list lambda-expr))))
-		   (arg-p (length at))
-		   (va (member '* at)))
-	       (cond (va
-		      (or (>= arg-c (- arg-p (length va)))
-			  (cmpwarn "~a needs ~a args. ~a supplied." fname (- arg-p (length va)) arg-c)))
-		     ((not (eql arg-c arg-p))
-		      (cmpwarn
-		       "~%;; ~a Number of proclaimed args was ~a. ~
-                          ~%;;Its definition had ~a." fname arg-p arg-c))
-					;((>= arg-c 10.)) ;checked above 
-					;(cmpwarn " t1defun only likes 10 args ~
-					;            ~%for proclaimed functions")
-		     (t (cmpwarn
-		       " ~a is proclaimed but not in *inline-functions* ~
-        ~%T1defun could not assure suitability of args for C call" fname)))
-	       nil))))))
-
-;; (defun wt-if-proclaimed (fname cfun lambda-expr macro-p)
-;;   (when (fast-link-proclaimed-type-p fname);(and  (not (member '* (get-arg-types fname))))
-;;     (let* ((sig (lam-e-to-sig lambda-expr))
-;; 	   (at (pop sig))
-;; 	   (rt (car sig)))
-;;       (cond ((assoc fname *inline-functions*)
-;; 	     (add-init `(si::init-function ',(if macro-p (cons 'macro fname) fname)
-;; 					   ,(add-address (c-function-name "LI" cfun fname))
-;; 					   nil nil -1 ,(new-proclaimed-argd at rt)
-;; 					   ,(argsizes at rt (xa lambda-expr)))))
-;; 	    ((let ((arg-c (length (car (lambda-list lambda-expr))))
-;; 		   (arg-p (length at))
-;; 		   (va (member '* at)))
-;; 	       (cond (va
-;; 		      (or (>= arg-c (- arg-p (length va)))
-;; 			  (cmpwarn "~a needs ~a args. ~a supplied." fname (- arg-p (length va)) arg-c)))
-;; 		     ((not (eql arg-c arg-p))
-;; 		      (cmpwarn
-;; 		       "~%;; ~a Number of proclaimed args was ~a. ~
-;;                           ~%;;Its definition had ~a." fname arg-p arg-c))
-;; 					;((>= arg-c 10.)) ;checked above 
-;; 					;(cmpwarn " t1defun only likes 10 args ~
-;; 					;            ~%for proclaimed functions")
-;; 		     (t (cmpwarn
-;; 		       " ~a is proclaimed but not in *inline-functions* ~
-;;         ~%T1defun could not assure suitability of args for C call" fname)))
-;; 	       nil))))))
-
-;; (defun wt-if-proclaimed (fname cfun lambda-expr)
-;;   (when (fast-link-proclaimed-type-p fname);(and  (not (member '* (get-arg-types fname))))
-;;     (let ((at (get-arg-types fname))
-;; 	  (rt (get-return-type fname)))
-;;       (cond ((assoc fname *inline-functions*)
-;; 	     (add-init `(si::init-function ',fname
-;; 					   ,(add-address (c-function-name "LI" cfun fname))
-;; 					   nil nil -1 ,(new-proclaimed-argd at rt)
-;; 					   ,(argsizes at rt (xa lambda-expr)))))
-;; 	    ((let ((arg-c (length (car (lambda-list lambda-expr))))
-;; 		   (arg-p (length at))
-;; 		   (va (member '* at)))
-;; 	       (cond (va
-;; 		      (or (>= arg-c (- arg-p (length va)))
-;; 			  (cmpwarn "~a needs ~a args. ~a supplied." fname (- arg-p (length va)) arg-c)))
-;; 		     ((not (eql arg-c arg-p))
-;; 		      (cmpwarn
-;; 		       "~%;; ~a Number of proclaimed args was ~a. ~
-;;                           ~%;;Its definition had ~a." fname arg-p arg-c))
-;; 					;((>= arg-c 10.)) ;checked above 
-;; 					;(cmpwarn " t1defun only likes 10 args ~
-;; 					;            ~%for proclaimed functions")
-;; 		     (t (cmpwarn
-;; 		       " ~a is proclaimed but not in *inline-functions* ~
-;;         ~%T1defun could not assure suitability of args for C call" fname)))
-;; 	       nil))))))
-	
-
 (defun volatile (info) (if (iflag-p (info-flags info) volatile) "VOL " ""))
 (defun set-volatile (info) (setf (info-flags info) (logior (iflags volatile) (info-flags info))))
 
@@ -1496,64 +1172,6 @@
   (when (< *space* 2)
     (setf (get fname 'debug-prop) t)))
 
-;; (defun t2defun (fname cfun lambda-expr doc sp)
-;;   (declare (ignore sp))
-
-;;   (cond ((get fname 'no-global-entry)(return-from t2defun nil)))
-
-;;   (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation)))
-
-;;   (cond ((wt-if-proclaimed fname cfun lambda-expr))
-;; 	((numberp cfun)
-;; 	 (let ((at (mapcar 'global-type-bump (get-arg-types fname)))
-;; 	       (rt (global-type-bump (get-return-type fname))))
-;; 	   (add-init `(si::init-function
-;; 		       ',fname
-;; ;		       ,(add-address (c-function-name "LI" (format nil "G~a" cfun) fname))
-;; 		       ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname))
-;; 		       nil nil -1 ,(new-proclaimed-argd at rt)
-;; 		       ,(argsizes at rt (xa lambda-expr)))))
-;; ;         (wt-h "static void " (c-function-name "L" cfun fname) "();")
-;; ;	 (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname))))
-;; 	 )
-;;         (t (baboon)(wt-h cfun "();")
-;; 	   (add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun fname))))))
-
-;;   (when *compiler-auto-proclaim*
-;;     (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*))))))
-  
-;;   (when (< *space* 2)
-;;     (setf (get fname 'debug-prop) t)))
-
-
-;; (defun t2defun (fname cfun lambda-expr doc sp)
-;;   (declare (ignore sp))
-
-;;   (cond ((get fname 'no-global-entry)(return-from t2defun nil)))
-
-;;   (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation)))
-
-;;   (cond ((wt-if-proclaimed fname cfun lambda-expr))
-;; 	((numberp cfun)
-;; 	 (let ((at (mapcar 'global-type-bump (get-arg-types fname)))
-;; 	       (rt (global-type-bump (get-return-type fname))))
-;; 	   (add-init `(si::init-function
-;; 		       ',fname
-;; ;		       ,(add-address (c-function-name "LI" (format nil "G~a" cfun) fname))
-;; 		       ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname))
-;; 		       nil nil -1 ,(new-proclaimed-argd at rt)
-;; 		       ,(argsizes at rt (xa lambda-expr)))))
-;; ;         (wt-h "static void " (c-function-name "L" cfun fname) "();")
-;; ;	 (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname))))
-;; 	 )
-;;         (t (baboon)(wt-h cfun "();")
-;; 	   (add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun fname))))))
-
-;;   (when *compiler-auto-proclaim*
-;;     (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (gethash fname *sigs*)))))
-  
-;;   (when (< *space* 2)
-;;     (setf (get fname 'debug-prop) t)))
 
 (defun si::add-debug (fname x)
   (si::putprop fname x  'si::debugger))
@@ -1562,69 +1180,19 @@
 
   (when doc (add-init `(putprop ',fname ,doc 'function-documentation)))
 
-  (unless (wt-if-proclaimed fname cfun lambda-expr macro-p)
-    (assert (numberp cfun))
-    (let* ((sig (lam-e-to-sig lambda-expr))
-	   (at (mapcar 'global-type-bump (pop sig)))
-	   (rt (global-type-bump (car sig)))
-	   (finit `(init-function ,(export-call-struct (gethash fname *sigs*))
-				      ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname))
-				      nil nil -1 ,(new-proclaimed-argd at rt)
-				      ,(argsizes at rt (xa lambda-expr)))))
-      (add-init `(fset ',fname ,(if macro-p `(cons 'macro ,finit) finit))))))
-
-;; (defun t3init-fun (fname cfun lambda-expr doc macro-p)
-
-;;   (when doc (add-init `(putprop ',fname ,doc 'function-documentation)))
-
-;;   (unless (wt-if-proclaimed fname cfun lambda-expr macro-p)
-;;     (assert (numberp cfun))
-;;     (let* ((sig (lam-e-to-sig lambda-expr))
-;; 	   (at (mapcar 'global-type-bump (pop sig)))
-;; 	   (rt (global-type-bump (car sig))))
-;;       (add-init `(init-function
-;; 		  ',(if macro-p (cons 'macro fname) fname)
-;; 		  ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname))
-;; 		  nil nil -1 ,(new-proclaimed-argd at rt)
-;; 		  ,(argsizes at rt (xa lambda-expr))))))
-
-;;   (when *compiler-auto-proclaim*
-;;     (push `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*)))) *add-hash-calls*)))
-
-;; (defun t3init-fun (fname cfun lambda-expr doc)
-
-;;   (when doc (add-init `(putprop ',fname ,doc 'function-documentation)))
-
-;;   (unless (wt-if-proclaimed fname cfun lambda-expr)
-;;     (assert (numberp cfun))
-;;     (let* ((sig (lam-e-to-sig lambda-expr))
-;; 	   (at (mapcar 'global-type-bump (pop sig)))
-;; 	   (rt (global-type-bump (car sig))))
-;;       (add-init `(init-function
-;; 		  ',fname
-;; 		  ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname))
-;; 		  nil nil -1 ,(new-proclaimed-argd at rt)
-;; 		  ,(argsizes at rt (xa lambda-expr))))))
-
-;;   (when *compiler-auto-proclaim*
-;;     (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*)))))))
-
-;; (defun t3init-fun (fname cfun lambda-expr doc)
-
-;;   (when doc (add-init `(putprop ',fname ,doc 'function-documentation)))
-
-;;   (unless (wt-if-proclaimed fname cfun lambda-expr)
-;;     (assert (numberp cfun))
-;;     (let ((at (mapcar 'global-type-bump (get-arg-types fname)))
-;; 	  (rt (global-type-bump (get-return-type fname))))
-;;       (add-init `(init-function
-;; 		  ',fname
-;; 		  ,(add-address (c-function-name "LI" (format nil "~a" cfun) fname))
-;; 		  nil nil -1 ,(new-proclaimed-argd at rt)
-;; 		  ,(argsizes at rt (xa lambda-expr))))))
+  (let* ((e (gethash fname *sigs*))
+	 (f (when (fast-link-proclaimed-type-p fname) (assert (assoc fname *inline-functions*)) t))
+	 (sig (car e))
+	 (at (pop sig))
+	 (at (if f at (mapcar 'global-type-bump at)))
+	 (rt (car sig))
+	 (rt (if f rt (global-type-bump rt)))
+	 (finit `(init-function ,(export-call-struct (gethash fname *sigs*))
+				,(add-address (c-function-name "LI" cfun fname))
+				nil nil -1 ,(new-proclaimed-argd at rt)
+				,(argsizes at rt (xa lambda-expr)))))
+    (add-init `(fset ',fname ,(if macro-p `(cons 'macro ,finit) finit)))))
 
-;;   (when *compiler-auto-proclaim*
-;;     (add-init `(si::add-hash ',fname ,@(mapcar (lambda (x) `(quote ,x)) (export-call (gethash fname *sigs*)))))))
 
 (defun t3defun (fname cfun lambda-expr doc sp macro-p &aux inline-info 
 ;		      (macro-p (equal `(mflag ,fname) (cadr (member *current-form* *top-level-forms*))))
@@ -1672,126 +1240,12 @@
 
     (add-debug-info fname lambda-expr)))
 
-;; (defun t3defun (fname cfun lambda-expr doc sp &aux inline-info 
-;; 		      (macro-p (equal `(mflag ,fname) (cadr (member *current-form* *top-level-forms*))))
-;; 		      (*current-form* (list 'defun fname))
-;; 		      (*volatile* (volatile (second lambda-expr))))
-
-;;   (declare (ignore doc))
-
-;;   (let ((*compiler-check-args* *compiler-check-args*)
-;;         (*safe-compile* *safe-compile*)
-;;         (*compiler-push-events* *compiler-push-events*)
-;;         (*compiler-new-safety* *compiler-new-safety*)
-;;         (*notinline* *notinline*)
-;;         (*space* *space*)
-;;         (*debug* *debug*))
-    
-;;     (when (eq (car (caddr (cddr lambda-expr))) 'decl-body)
-;;       (local-compile-decls (caddr (caddr (cddr lambda-expr)))))
-
-;;     (cond
-;;      ((dolist (v *inline-functions*)
-;; 	(or (si::fixnump (nth 3 v))
-;; 	    (error "Old style inline"))
-;; 	(and (eq (car v) fname)
-;; 	     (not (nth 5 v)) ; ie.not  'link-call or 'ifuncall
-;; 	     (return (setq inline-info v))))
-      
-;;     ;;; Add global entry information.
-;; ;; 	(push (list fname cfun (cadr inline-info) (caddr inline-info))
-;; ;; 	      *global-entries*))
-    
-;;     ;;; Local entry
-;;       (analyze-regs (cadr lambda-expr) 0)
-
-;;       (mapc (lambda (x) (setf (var-type x) (global-type-bump (var-type x)))) (caaddr lambda-expr))
-;;       (setf (info-type (cadr (fifth lambda-expr))) (global-type-bump (info-type (cadr (fifth lambda-expr)))))
-;;       (setf (caddr inline-info) (global-type-bump (cadr (lam-e-to-sig lambda-expr))))
-
-;;       (t3defun-aux 't3defun-local-entry
-;; 		   (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object)
-;; 		   fname cfun lambda-expr sp inline-info))
-;;      ((baboon)))
-    
-;;     (t3init-fun fname cfun lambda-expr doc macro-p)
-
-;;     (add-debug-info fname lambda-expr)))
-
-;; (defun t3defun (fname cfun lambda-expr doc sp &aux inline-info 
-;; 		      (*current-form* (list 'defun fname))
-;; 		      (*volatile* (volatile (second lambda-expr))))
-
-;;   (declare (ignore doc))
-
-;;   (let ((*compiler-check-args* *compiler-check-args*)
-;;         (*safe-compile* *safe-compile*)
-;;         (*compiler-push-events* *compiler-push-events*)
-;;         (*compiler-new-safety* *compiler-new-safety*)
-;;         (*notinline* *notinline*)
-;;         (*space* *space*)
-;;         (*debug* *debug*))
-    
-;;     (when (eq (car (caddr (cddr lambda-expr))) 'decl-body)
-;;       (local-compile-decls (caddr (caddr (cddr lambda-expr)))))
-
-;;     (cond
-;;      ((dolist (v *inline-functions*)
-;; 	(or (si::fixnump (nth 3 v))
-;; 	    (error "Old style inline"))
-;; 	(and (eq (car v) fname)
-;; 	     (not (nth 5 v)) ; ie.not  'link-call or 'ifuncall
-;; 	     (return (setq inline-info v))))
-      
-;;     ;;; Add global entry information.
-;; ;; 	(push (list fname cfun (cadr inline-info) (caddr inline-info))
-;; ;; 	      *global-entries*))
-    
-;;     ;;; Local entry
-;;       (analyze-regs (cadr lambda-expr) 0)
-;;       (let ((lambda-expr (if (fast-link-proclaimed-type-p fname) lambda-expr (ttl-to-top lambda-expr fname))))
-;; 	(t3defun-aux 't3defun-local-entry
-;; 		     (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object)
-;; 		     fname cfun lambda-expr sp inline-info))
-
-
-;;       (when (not (fast-link-proclaimed-type-p fname))
-;; 	(let* ((sig (lam-e-to-sig lambda-expr))
-;; 	       (lsig (list (car sig) (if (type>= #tboolean (cadr sig)) #tt (cadr sig))));FIXME
-;; 	       (fun (make-fun :level -1 
-;; 			      :info (make-info :type (cadr lsig)) :call (list lsig) 
-;; 			      :name fname :cfun (format nil "I~a" cfun)))
-;; 	       (ttl (find-ttl-vars lambda-expr))
-;; 	       (vp (member-if-not 'var-p ttl))
-;; 	       (ttl (ldiff ttl vp))
-;; 	       (v (mapcar (lambda (x) (list 'var (make-info :type (var-type x)) (list x nil))) ttl))
-;; 	       (tp (cadr sig))
-;; 	       (inline-info (copy-tree inline-info)))
-;; 	  (setf (caddr inline-info) (global-type-bump tp))
-;; 	  (rcl lambda-expr fun v fname)
-;; 	  (t3defun-aux 't3defun-local-entry
-;; 		       (or (cdr (assoc (promoted-c-type (caddr inline-info)) +return-alist+)) 'return-object)
-;; 		       fname (format nil "G~a" cfun) lambda-expr sp inline-info))))
-
-;;      ((baboon)))
-    
-;;     (add-debug-info fname lambda-expr)))
 
 (defun t3defun-aux (f *exit* &rest lis)
   (let-pass3 ()   (apply f lis)))   
 
 (defvar *mv-var* nil)
 
-;; (defun tail-recursion-info (fname mv-var ll)
-;;   (when *do-tail-recursion*
-;;     (cons fname (append (if mv-var (cdr (car ll)) (car ll)) (ll-optionals ll) (list (ll-rest ll)) (ll-keywords ll)))))
-
-;; (defun tail-recursion-info (fname mv-var l)
-;;   (declare (ignore mv-var))
-;;   (when *do-tail-recursion*
-;;     (cons fname (find-ttl-vars l))))
-
-
 (defun t3defun-local-entry (fname cfun lambda-expr sp inline-info
 				  &aux specials *reg-clv* (requireds (caaddr lambda-expr)) nargs)
   (do ((vl requireds (cdr vl))
@@ -1804,11 +1258,6 @@
 	    ((setf (var-kind (car vl))
 		   (or (car (member (promoted-c-type (var-type (car vl))) +c-local-arg-types+)) 'object))))
       (setf (var-loc (car vl)) (cs-push (var-type (car vl)) t)))
-  (let ((rt (get-return-type fname)))
-    (unless (single-type-p rt)
-      (let ((ns (abs (vald rt))))
-	(unless (= ns (- multiple-values-limit 2))
-	  (setq *max-vs* (max *max-vs* ns))))))
   (when (is-narg-le lambda-expr)
     (setq nargs (car (last requireds)))
     (setf (var-register nargs) 0))
@@ -1875,8 +1324,7 @@
 
   (let ((vstu (cond (*mv-var* 
 		     (let ((loc (write-to-string (var-loc *mv-var*))))
-		       (concatenate 'string " if ((b_)>=-1) vs_top=V" loc 
-				    " ? (object *)V" loc "+(b_) : base;")))
+		       (concatenate 'string " if (V" loc ") {if ((b_)>=-1) vs_top=(object *)V" loc "+(b_);} else vs_top=base;")))
 		    ((or (> *max-vs* 0) *base-used*) " vs_top=base;")
 		    ("")))
 	(bdsu (if *bds-used* " for (;bds_top>old_bds_top;) bds_unwind1;" ""))
@@ -2536,10 +1984,6 @@
 	  (c-function-name (if closure-p "LC" "L") (fun-cfun fun) (fun-name fun)) "(")
   (wt-nl1 "static " (declaration-type (rep-type rt))
 	  (c-function-name (if closure-p "LC" "L") (fun-cfun fun) (fun-name fun)) "(")
-  (unless (single-type-p rt)
-    (let ((ns (abs (vald rt))))
-      (unless (= ns (- multiple-values-limit 2))
-	(setq *max-vs* (max *max-vs* ns)))))
   (when (is-narg-le lambda-expr)
     (setq nargs (car (last requireds)))
     (setf (var-register nargs) 0))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptype.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptype.lsp
@@ -1115,39 +1115,70 @@
 
 (defun coerce-to-one-value (type) (type-and type t))
 
-(defun unprintable-individualsp (u)
-  (case (when (listp u) (car u))
-	((or returns-exactly values) (member-if 'unprintable-individualsp (cdr u)))
-	(member (member-if (lambda (x)
-			     (or (si::si-classp x) (typep x '(or function cons binding array))))
-			   (cdr u)))
-	((short-float long-float) (member-if (lambda (x) (or (isinf x) (isnan x))) (cdr u)))
-	(otherwise (si::si-classp u))))
-
-(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)
-      (mapcan (lambda (x)
-		(when (member-if (lambda (x) (f x)) (cdr x));FIXME #'f
-		  (list (car x))))
-	      (caaddr tp)))))
-
-(defun export-type1 (type)
-  (let ((x (kingdoms-with-unprintable-individuals type)))
-    (if x (type-or1 type (cmp-norm-tp (cons 'or x))) type)))
+(defun individuals (f x)
+  (mapcan (lambda (y &aux (y (if (listp y) (car y) y)))
+	    (when (funcall f y)
+	      (list (cons (car x) y))))
+	  (cdr x)))
+
+(defun ntp-kingdoms-with-individuals (ntp)
+  (mapcan (lambda (x)
+	    (case (car x)
+	      ((complex-integer complex-integer-ratio complex-ratio-integer
+				complex-short-float complex-long-float)
+	       (individuals 'complexp x))
+	      ((integer ratio))
+	      ((short-float long-float);FIXME conceptually this should not be here.
+	       (mapcan (lambda (y)
+			 (when (consp y)
+			   (labels ((d (z &aux (z (if (listp z) (car z) z)))
+				      (when (or (isinf z) (isnan z))
+					(list (cons (car x) z)))))
+			     (append (d (car y)) (d (cdr y))))))
+		       (cdr x)))
+	      ((std-instance structure funcallable-std-instance)
+	       (individuals (lambda (y) (not (eq 'top (si::std-def y)))) x))
+	      ((proper-cons si::improper-cons);FIXME
+	       (mapcan (lambda (y)
+			 (when (listp y)
+			   (append (ntp-kingdoms-with-individuals (car y))
+				   (ntp-kingdoms-with-individuals (cadr y))
+				   (when (caddr y) (list (cons (car x) (caddr y))))
+				   (when (cadddr y) (list (cons (car x) (car (cadddr y))))))))
+		       (cdr x)))
+	      (#.(mapcar 'cdr si::*all-array-types*)  (individuals 'arrayp x))
+	      (otherwise (individuals (lambda (y) (not (eq y t))) x))))
+	  (car ntp)))
+
+(defun kingdoms-with-individuals (tp)
+  (when (consp tp)
+    (ntp-kingdoms-with-individuals (caddr tp))))
+
+
+(declaim (inline bump-individuals))
+(defun bump-individuals (f tp)
+  (cond ((cmpt tp) (cons (car tp) (mapcar (lambda (x) (bump-individuals f x)) (cdr tp))))
+	((let* ((x (kingdoms-with-individuals tp))
+		(x (remove-if-not f x :key 'cdr))
+		(x (remove-duplicates (mapcar 'car x))))
+	   (if x
+	       (compiler::type-or1 (cmp-norm-tp (cons 'or x)) tp)
+	       tp)))))
+
+(declaim (inline unprintable-individual-p))
+(defun unprintable-individual-p (x)
+  (typecase x
+    (float (or (isnan x) (isinf x)));t
+    ((or string bit-vector number random-state character symbol pathname) nil)
+    (cons (or (unprintable-individual-p (car x)) (unprintable-individual-p (cdr x))))
+    ((array t) (some 'unprintable-individual-p x))
+    ;FIXME assumes structure elements are printable
+    (structure (si::s-data-print-function (c-structure-def x)))
+    (t t)))
 
 (defun export-type (type)
-  (if (cmpt type)
-      (cons (pop type) (mapcar 'export-type1 type))
-    (export-type1 type)))
+  (bump-individuals 'unprintable-individual-p type))
+
 
 
 (defun bump-tp (tp)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpwt.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpwt.lsp
@@ -226,7 +226,8 @@
   (cond (*compiler-compile*;FIXME, clean this up
 	 (setq *compiler-compile-data* (mapcar 'verify-datum (nreverse *data*)))
 	 (wt-data2 `(mapc 'eval *compiler-compile-data*)))
-	((wt-data2 `(progn ,@(mapcar 'verify-datum (nreverse *data*))))))
+	;; Carefully allow sharing across all data but preseve eval order
+	((wt-data2 `'(progn ,@(mapcar (lambda (x) (cons '|#,| (verify-datum x))) (nreverse *data*))))))
   (when *fasd-data*
     (si::close-fasd (car *fasd-data*))))
 
--- gcl27-2.7.0.orig/cmpnew/gcl_lfun_list.lsp
+++ gcl27-2.7.0/cmpnew/gcl_lfun_list.lsp
@@ -57,7 +57,6 @@
   (c-set-function-vv (symbol-function l) 0)
   (c-set-function-neval (symbol-function l) 1)
   )
-;  (si::add-hash (cdr l) (export-sig (car l)) nil nil nil))
 
 (dolist (l '(eq eql equal equalp ldb-test logtest))
   (setf (get l 'predicate) t))
--- gcl27-2.7.0.orig/git.tag
+++ gcl27-2.7.0/git.tag
@@ -1,2 +1,2 @@
-"Version_2_7_0pre29"
+"Version_2_7_0pre31"
 
--- gcl27-2.7.0.orig/h/object.h
+++ gcl27-2.7.0/h/object.h
@@ -606,7 +606,7 @@ EXTER char *alloca_val;
 #define RETURN2I(x,y)   RETURN(2,fixnum,x,(RV(y)))
 /* #define RETURN1(x) RETURN(1,object,x,) */
 #define RETURN1(x) return(x)
-#define RETURN0 do {vs_top=(object *)vals-1;return Cnil;} while (0)
+#define RETURN0 do {vs_top=vals ? (object *)vals-1 : base;return Cnil;} while (0)
 
 #define RV(x) ({if (_p) *_p++ = x;})
 
--- gcl27-2.7.0.orig/h/pool.h
+++ gcl27-2.7.0/h/pool.h
@@ -27,11 +27,8 @@ static int
 set_lock(void) {
   
   errno=0;
-  if (fcntl(pool,F_SETLKW,plp)) {
-    if (errno==EINTR)
-      set_lock();
-    return -1;
-  }
+  if (fcntl(pool,F_SETLKW,plp))
+    return errno==EINTR ? set_lock() : -1;
   return 0;
 
 }
--- gcl27-2.7.0.orig/h/protoize.h
+++ gcl27-2.7.0/h/protoize.h
@@ -1613,8 +1613,8 @@ fSstring_match2(object,object);
 object
 aelttype_list(void);
 
-object alloc_simple_string(int);
-object alloc_string(int);
+object alloc_simple_string(fixnum);
+object alloc_string(fixnum);
 object append(object,object);
 object car(object);
 object cdr(object);
@@ -1642,10 +1642,10 @@ object read_object_non_recursive(object)
 object make_symbol(object);
 object elt_set(object,int,object);
 object reverse(object);
-object alloc_bitvector(int);
-object alloc_simple_bitvector(int);
-object alloc_simple_vector(int);
-object alloc_vector(int,enum aelttype);
+object alloc_bitvector(fixnum);
+object alloc_simple_bitvector(fixnum);
+object alloc_simple_vector(fixnum);
+object alloc_vector(fixnum,enum aelttype);
 object coerce_to_character(object);
 object peek_char(bool,object);
 object prin1(object,object);
--- gcl27-2.7.0.orig/lsp/gcl_callhash.lsp
+++ gcl27-2.7.0/lsp/gcl_callhash.lsp
@@ -47,7 +47,10 @@
     nil))
 
 (defun all-conflicts (&aux r q)
-  (do-all-symbols (sym q)
+  (do-all-symbols (sym (sort q (lambda (x y)
+				 (cond ((member (caar x) (cadr y)) 1)
+				       ((member (caar y) (cadr x)) -1)
+				       (0)))))
     (let* ((plist (sym-plist sym))(callees (cadr plist)))
       (mapc (lambda (x &aux (s (car x)) (cmp-sig (cdr x))(act-sig (car (sym-plist s))))
 	      (unless (eq sym s)
@@ -291,12 +294,12 @@
 	(push (list s sig) r))))
   (write-sys-proclaims1 sp r))
 
-(defun do-recomp (&rest excl &aux *sig-discovery-props* *compile-verbose*)
+(defun do-recomp (&optional cdebug &rest excl &aux *sig-discovery-props* *compile-verbose*)
   (gen-discovery-props)
   (let* ((fl (mapcar 'car *sig-discovery-props*))
 	 (fl (remove-duplicates (mapcar (lambda (x &aux (f (file x))) (when f (namestring f))) fl) :test 'string=))
 	 (fl (set-difference fl excl :test (lambda (x y) (search y x)))))
-    (compiler::cdebug)
+    (when cdebug (compiler::cdebug))
     (format t "~%Recompiling original source files ...")
     (mapc (lambda (x) (format t "~s~%" x) (compile-file x)) (remove nil fl))))
 
--- gcl27-2.7.0.orig/makefile
+++ gcl27-2.7.0/makefile
@@ -114,12 +114,12 @@ $(PORTDIR)/saved_gcl2: $(PORTDIR)/saved_
 
 $(PORTDIR)/saved_gcl: $(PORTDIR)/saved_gcl2 $(HDIR)cmpinclude.h
 	cd $(@D) && echo '(time (load "boot.lisp"))' | ./$(<F) && $(MAKE) $(@F)
-	echo '(si::do-recomp)' | $@ && cd $(@D) && $(MAKE) $(@F)
+	echo '(si::do-recomp t)' | $@ && cd $(@D) && $(MAKE) $(@F)
 
 $(PORTDIR)/saved_mod_gcl: $(PORTDIR)/saved_gcl
 	(cd $(MODDIR); $(MAKE) clean; $(MAKE) all)
 	cd $(@D) && $(MAKE) $(@F)
-	echo '(si::do-recomp)' | $@ && cd $(@D) && $(MAKE) $(@F)
+	echo '(si::do-recomp t)' | $@ && cd $(@D) && $(MAKE) $(@F)
 
 $(PORTDIR)/saved_pcl_gcl: $(PORTDIR)/saved_mod_gcl
 #	(cd $(PCLDIR); $(MAKE) clean; $(MAKE) all)
--- gcl27-2.7.0.orig/o/cmpaux.c
+++ gcl27-2.7.0/o/cmpaux.c
@@ -111,13 +111,15 @@ DEFUN("DEBUGGER",object,fSdebugger,SI
 }
 
 
-DEFUN("SETVV",object,fSsetvv,SI
-       ,2,2,NONE,OO,OO,OO,OO,(object index,object val),"")
-{ /* 2 args */
+DEFUN("SETVV",object,fSsetvv,SI,2,2,NONE,OO,OO,OO,OO,(object index,object val),"") {
+
   if(type_of(sSPmemory->s.s_dbind)==t_cfdata)
-  sSPmemory->s.s_dbind->cfd.cfd_self[fix(index)]=val;
-  else FEerror("setvv called outside %init",0);
+    sSPmemory->s.s_dbind->cfd.cfd_self[fix(index)]=val;
+  else
+    FEerror("setvv called outside %init",0);
+
   RETURN1(index);
+
 }
 
 DEFVAR("%MEMORY",sSPmemory,SI,OBJNULL,"");
--- gcl27-2.7.0.orig/o/error.c
+++ gcl27-2.7.0/o/error.c
@@ -342,6 +342,7 @@ DEFUN("SCH-FRS-BASE",object,fSsch_frs_ba
 DEFUNM("INTERNAL-SUPER-GO",object,fSinternal_super_go,SI,3,3,NONE,OO,OO,OO,OO,(object tag,object x1,object x2),"") {
   frame_ptr fr;
   fixnum vals=(fixnum)fcall.valp;
+  object *base=vs_top;
   
   fr = frs_sch(tag);
   if (fr == NULL)
--- gcl27-2.7.0.orig/o/fasdump.c
+++ gcl27-2.7.0/o/fasdump.c
@@ -1003,34 +1003,16 @@ DEFUN("FIND-SHARING-TOP",object,fSfind_s
 
 }
 
+static object
+lisp_eval(object x) {
 
+  SAVE_CURRENT_FASD;
+  x=ieval(x);
+  RESTORE_FASD;
 
-/* static object            */
-/* read_fasd(int i) */
-/* {object tem; */
-/*    read_fasd1(i,&tem); */
-/*    return tem;} */
-
-
-     /* I am not sure if saving vs_top,vs_base is necessary */
-static object 
-lisp_eval(object x)
-{  /* object *b,*t; */
-   SAVE_CURRENT_FASD;
-   x=fLeval(x);/*FIXME FFN*/
-   /* b=vs_base; */
-   /* t=vs_top; */
-   /* vs_base=vs_top; */
-   /* vs_push(x); */
-   /* Leval();  */
-   /* x=vs_base[0]; */
-   /* vs_base=b; */
-   /* vs_top=t; */
-   RESTORE_FASD;
-   return x;
- }
+  return x;
 
-    
+}
 
 #define CHECK_CH(i)    	   do{if ((i)==EOF && stream_at_end(fas_stream)) bad_eof();}while (0)
 /* grow vector AR of general type */
--- gcl27-2.7.0.orig/o/main.c
+++ gcl27-2.7.0/o/main.c
@@ -1045,15 +1045,15 @@ multiply_stacks(int m) {
   bd  = (stack_multiple*BDSSIZE + (STACK_OVER+1)*BDSGETA)*ELTSIZE(bds_org);
   frs = (stack_multiple*FRSSIZE + (STACK_OVER+1)*FRSGETA)*ELTSIZE(frs_org);
   ihs = (stack_multiple*IHSSIZE + (STACK_OVER+1)*IHSGETA)*ELTSIZE(ihs_org);
-  if (stack_space==0) {enter_mark_origin(&stack_space);}
-  stack_space = alloc_simple_string(vs+bd+frs+ihs);
-  array_allocself(stack_space,1,code_char(0));
-  p=stack_space->st.st_self;
+  if (stack_space==0)
+    enter_mark_origin(&stack_space);
+  massert(!((vs+bd+frs+ihs)%sizeof(fixnum)));
+  stack_space=fSmake_vector(make_fixnum(aet_fix),(vs+bd+frs+ihs)/sizeof(fixnum),Cnil,Cnil,Cnil,0,Ct,OBJNULL);
+  p=stack_space->v.v_self;
   COPYSTACK(vs_org,p,object,vs_limit,vs_top,VSGETA,VSSIZE);
   COPYSTACK(bds_org,p,struct bds_bd,bds_limit,bds_top,BDSGETA,BDSSIZE);
   COPYSTACK(frs_org,p,struct frame,frs_limit,frs_top,FRSGETA,FRSSIZE);
-  COPYSTACK(ihs_org,p,struct invocation_history,ihs_limit,ihs_top,
-	    IHSGETA,IHSSIZE);
+  COPYSTACK(ihs_org,p,struct invocation_history,ihs_limit,ihs_top,IHSGETA,IHSSIZE);
   vs_base=vs_top;
   return stack_multiple;
 }
--- gcl27-2.7.0.orig/o/num_sfun.c
+++ gcl27-2.7.0/o/num_sfun.c
@@ -673,13 +673,12 @@ LFD(Lexp)(void)
 	vs_base[0] = number_exp(vs_base[0]);
 }
 
-LFD(Lexpt)(void)
-{
-	check_arg(2);
-	check_type_number(&vs_base[0]);
-	check_type_number(&vs_base[1]);
-	vs_base[0] = number_expt(vs_base[0], vs_base[1]);
-	vs_popp;
+DEFUN("EXPT",object,fLexpt,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") {
+
+  check_type_number(&vs_base[0]);
+  check_type_number(&vs_base[1]);
+  RETURN1(number_expt(x,y));
+
 }
 
 LFD(Llog)(void)
@@ -823,7 +822,6 @@ gcl_init_num_sfun(void)
 	make_constant("PI", make_longfloat(PI));
 
 	make_function("EXP", Lexp);
-	make_function("EXPT", Lexpt);
 	make_function("LOG", Llog);
 	make_function("SQRT", Lsqrt);
 	make_function("SIN", Lsin);
--- gcl27-2.7.0.orig/o/predicate.c
+++ gcl27-2.7.0/o/predicate.c
@@ -200,6 +200,8 @@ DEFUN("EQL",object,fLeql,LISP,2,2,NONE,O
 bool
 equal1(register object x, register object y) {
 
+  enum type tx,ty;
+
   /*x and y are not == and not Cnil and not immfix*/
 
   /*gcc boolean expression tail position bug*/
@@ -207,22 +209,23 @@ equal1(register object x, register objec
   if (valid_cdr(x)) return !valid_cdr(y)||!equal(x->c.c_car,y->c.c_car) ? FALSE : equal(x->c.c_cdr,y->c.c_cdr);
 
   if (valid_cdr(y)) return FALSE;
+
+#define BASE_T(a_) ({enum type _t=(a_)->d.t;\
+  _t==t_simple_string ? t_string : (_t==t_simple_bitvector ? t_bitvector : _t);})
+
+  if ((tx=BASE_T(x))!=(ty=BASE_T(y)))
+    return FALSE;
+#undef BASE_T
   
-  switch(x->d.t) {
+  switch(tx) {
 
-  case t_simple_string:
   case t_string:
-    if (y->d.t!=t_simple_string && y->d.t!=t_string)
-      return(FALSE);
     return(string_eq(x, y));
     
   case t_bitvector:
-  case t_simple_bitvector:
     {
       fixnum i, ox, oy;
       
-      if (y->d.t!=t_simple_bitvector && y->d.t!=t_bitvector)
-	return(FALSE);
       if (VLEN(x) != VLEN(y))
 	return(FALSE);
       ox = x->bv.bv_offset;
@@ -297,66 +300,36 @@ equalp1(register object x, register obje
     
   if (listp(y)) return FALSE;
 
-  tx=is_imm_fixnum(x) ? t_fixnum : x->d.t;
-  ty=is_imm_fixnum(y) ? t_fixnum : y->d.t;
+#define BASE_T(a_) ({object _t=(a_);\
+  numberp(_t) ? t_fixnum : (vectorp(_t) ? t_vector : _t->d.t);})
+
+  if ((tx=BASE_T(x))!=(ty=BASE_T(y)))
+    return FALSE;
+
+#undef BASE_T
 
   switch(tx) {
 
   case t_fixnum:
-  case t_bignum:
-  case t_ratio:
-  case t_shortfloat:
-  case t_longfloat:
-  case t_complex:
-    if (ty==t_fixnum||ty==t_bignum||ty==t_ratio ||
-	ty==t_shortfloat||ty==t_longfloat ||
-	ty==t_complex)
-      return(!number_compare(x, y));
-    else
-      return(FALSE);
-    
-  case t_simple_vector:
-  case t_simple_string:
-  case t_simple_bitvector:
+    return(!number_compare(x, y));
+
+  case t_array:
+    if (x->a.a_rank!=y->a.a_rank)
+      return FALSE;
+    if (x->a.a_rank>1 && memcmp(x->a.a_dims,y->a.a_dims,x->a.a_rank*sizeof(*x->a.a_dims)))
+      return FALSE;
+
   case t_vector:
-  case t_string:
-  case t_bitvector:
-    if (TS_MEMBER(ty,TS(t_vector)|TS(t_string)|TS(t_bitvector)|
-		  TS(t_simple_vector)|TS(t_simple_string)|TS(t_simple_bitvector))) {
-      j = VLEN(x);
-      if (j != VLEN(y))
-	return FALSE;
-      goto ARRAY;
+    if ((j=VLEN(x))!=VLEN(y))
+      return FALSE;
+    {
+      fixnum i;
+      for (i = 0;  i < j;  i++)
+	if (!equalp(aref(x, i), aref(y, i)))
+	  return(FALSE);
     }
-    else
-      return(FALSE);
+    return(TRUE);
     
-  case t_array:
-    if (ty==t_array && x->a.a_rank==y->a.a_rank) { 
-      if (x->a.a_rank > 1) {
-	fixnum i;
-	for (i=0; i< x->a.a_rank; i++) {
-	  if (x->a.a_dims[i]!=y->a.a_dims[i])
-	    return(FALSE);
-	}
-      }
-      if (x->a.a_dim != y->a.a_dim)
-	return(FALSE);
-      j=x->a.a_dim;
-      goto ARRAY;
-    }
-    else
-      return(FALSE);
-
-  default:
-    break;
-  }
-  
-  if (tx != ty)
-    return(FALSE);
-  
-  switch (tx) {
-
   case t_character:
     return(char_equal(x, y));
     
@@ -429,18 +402,6 @@ equalp1(register object x, register obje
     return(FALSE);
 
   }
-  
-  
- ARRAY:
-  
-  {
-    fixnum i;
-    
-    for (i = 0;  i < j;  i++)
-      if (!equalp(aref(x, i), aref(y, i)))
-	return(FALSE);
-    return(TRUE);
-  }
 
 }
 
--- gcl27-2.7.0.orig/o/read.d
+++ gcl27-2.7.0/o/read.d
@@ -954,6 +954,7 @@ DEFUNM("SEMICOLON-READER",object,fSsemic
 	  (object str,object c),"") {
 
   fixnum vals=fcall.valp;
+  object *base=vs_top;
 
   do
     { read_char_to(c,str, goto L); }
@@ -1438,7 +1439,8 @@ Lsharp_dot_reader()
 	}
 	if (READeval) {
 	  vs_base[0] = read_object(vs_base[0]);
-	  vs_base[0] = ieval(vs_base[0]);
+	  /*FIXME: assumes no sharing until patch-sharp appears.  Bootstrap requires *fasd-data**/
+	  vs_base[0] = ieval(sSpatch_sharp->s.s_gfdef!=OBJNULL ? patch_sharp(vs_base[0]) : vs_base[0]);
 	} else {
 	  READER_ERROR(vs_base[0],"Sharp dot found with *read-eval* set to nil");
 	}
--- gcl27-2.7.0.orig/o/sequence.d
+++ gcl27-2.7.0/o/sequence.d
@@ -33,74 +33,89 @@ Foundation, 675 Mass Ave, Cambridge, MA
 	I know the following name is not good.
 */
 object
-alloc_simple_vector(l)
-int l;
-{
-	object x;
-
-	x = alloc_object(t_simple_vector);
-	x->sv.sv_hasfillp = FALSE;
-	x->sv.sv_adjustable = FALSE;
-	x->sv.sv_dim = l;
-	x->sv.sv_self = NULL;
-	set_array_elttype(x,aet_object);
-	x->sv.sv_rank = 1;
-	return(x);
+alloc_simple_vector(fixnum l) {
+
+  object x;
+
+  if (l<0 || l>=ARRAY_DIMENSION_LIMIT)
+    TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil)));
+
+  x = alloc_object(t_simple_vector);
+  x->sv.sv_hasfillp = FALSE;
+  x->sv.sv_adjustable = FALSE;
+  x->sv.sv_dim = l;
+  x->sv.sv_self = NULL;
+  set_array_elttype(x,aet_object);
+  x->sv.sv_rank = 1;
+
+  return(x);
+
 }
 
 object
-alloc_vector(l, aet)
-int l;
-enum aelttype aet;
-{
-	object x;
-
-	x = alloc_object(t_vector);
-	x->v.v_hasfillp = TRUE;
-	x->v.v_adjustable = TRUE;
-	x->v.v_displaced = Cnil;
-	x->v.v_dim = l;
-	x->v.v_fillp = l;
-	x->v.v_self = NULL;
-	set_array_elttype(x,(short)aet);
-	x->v.v_rank = 1;
-	return(x);
+alloc_vector(fixnum l,enum aelttype aet) {
+
+  object x;
+
+  if (l<0 || l>=ARRAY_DIMENSION_LIMIT)
+    TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil)));
+
+  x = alloc_object(t_vector);
+  x->v.v_hasfillp = TRUE;
+  x->v.v_adjustable = TRUE;
+  x->v.v_displaced = Cnil;
+  x->v.v_dim = l;
+  x->v.v_fillp = l;
+  x->v.v_self = NULL;
+  set_array_elttype(x,(short)aet);
+  x->v.v_rank = 1;
+
+  return(x);
+
 }
 
 object
-alloc_simple_bitvector(l)
-int l;
-{
-	object x;
-
-	x = alloc_object(t_simple_bitvector);
-	x->sbv.sbv_hasfillp = FALSE;
-	x->sbv.sbv_adjustable = FALSE;
-	x->sbv.sbv_dim = l;
-	x->sbv.sbv_offset = 0;
-	x->sbv.sbv_self = NULL;
-	set_array_elttype(x,aet_bit);
-        x->sbv.sbv_rank = 1;
-	return(x);
+alloc_simple_bitvector(fixnum l) {
+
+  object x;
+
+  if (l<0 || l>=ARRAY_DIMENSION_LIMIT)
+    TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil)));
+
+  x = alloc_object(t_simple_bitvector);
+  x->sbv.sbv_hasfillp = FALSE;
+  x->sbv.sbv_adjustable = FALSE;
+  x->sbv.sbv_dim = l;
+  x->sbv.sbv_offset = 0;
+  x->sbv.sbv_self = NULL;
+  set_array_elttype(x,aet_bit);
+  x->sbv.sbv_rank = 1;
+
+  return(x);
+
 }
 
 object
-alloc_bitvector(l)
-int l;
-{
-	object x;
-
-	x = alloc_object(t_bitvector);
-	x->bv.bv_hasfillp = TRUE;
-	x->bv.bv_adjustable = TRUE;
-	x->bv.bv_displaced = Cnil;
-	x->bv.bv_dim = l;
-	x->bv.bv_fillp = l;
-	x->bv.bv_offset = 0;
-	x->bv.bv_self = NULL;
-	set_array_elttype(x,aet_bit);
-        x->bv.bv_rank = 1;
-	return(x);
+alloc_bitvector(fixnum l) {
+
+  object x;
+
+  if (l<0 || l>=ARRAY_DIMENSION_LIMIT)
+    TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil)));
+
+  x = alloc_object(t_bitvector);
+  x->bv.bv_hasfillp = TRUE;
+  x->bv.bv_adjustable = TRUE;
+  x->bv.bv_displaced = Cnil;
+  x->bv.bv_dim = l;
+  x->bv.bv_fillp = l;
+  x->bv.bv_offset = 0;
+  x->bv.bv_self = NULL;
+  set_array_elttype(x,aet_bit);
+  x->bv.bv_rank = 1;
+
+  return(x);
+
 }
 
 LFD(Lelt)()
--- gcl27-2.7.0.orig/o/string.d
+++ gcl27-2.7.0/o/string.d
@@ -37,37 +37,45 @@ object sKinitial_element;
 object sKelement_type;
 
 object
-alloc_string(l)
-int l;
-{
-	object x;
-
-	x = alloc_object(t_string);
-	x->st.st_hasfillp = TRUE;
-	x->st.st_adjustable = TRUE;
-	set_array_elttype(x,aet_ch);
-	x->st.st_rank = 1;
-	x->st.st_displaced=Cnil;
-	x->st.st_dim = l;
-	x->st.st_fillp = l;
-	x->st.st_self = NULL;
-	return(x);
+alloc_string(fixnum l) {/*FIXME consolidate these through fSmake_vector*/
+
+  object x;
+
+  if (l<0 || l>=ARRAY_DIMENSION_LIMIT)
+    TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil)));
+
+  x = alloc_object(t_string);
+  x->st.st_hasfillp = TRUE;
+  x->st.st_adjustable = TRUE;
+  set_array_elttype(x,aet_ch);
+  x->st.st_rank = 1;
+  x->st.st_displaced=Cnil;
+  x->st.st_dim = l;
+  x->st.st_fillp = l;
+  x->st.st_self = NULL;
+
+  return(x);
+
 }
 
 object
-alloc_simple_string(l)
-int l;
-{
-	object x;
-
-	x = alloc_object(t_simple_string);
-	x->sst.sst_hasfillp = FALSE;
-	x->sst.sst_adjustable = FALSE;
-	set_array_elttype(x,aet_ch);
-	x->sst.sst_rank = 1;
-	x->sst.sst_dim = l;
-	x->sst.sst_self = NULL;
-	return(x);
+alloc_simple_string(fixnum l) {
+
+  object x;
+
+  if (l<0 || l>=ARRAY_DIMENSION_LIMIT)
+    TYPE_ERROR(make_fixnum(l),list(3,sLinteger,make_fixnum(0),MMcons(make_fixnum(ARRAY_DIMENSION_LIMIT),Cnil)));
+
+  x = alloc_object(t_simple_string);
+  x->sst.sst_hasfillp = FALSE;
+  x->sst.sst_adjustable = FALSE;
+  set_array_elttype(x,aet_ch);
+  x->sst.sst_rank = 1;
+  x->sst.sst_dim = l;
+  x->sst.sst_self = NULL;
+
+  return(x);
+
 }
 
 /*
