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-30) unstable; urgency=medium
 .
   * Version_2_7_0pre33
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-27

--- gcl27-2.7.0.orig/ansi-tests/macro-function.lsp
+++ gcl27-2.7.0/ansi-tests/macro-function.lsp
@@ -132,6 +132,12 @@
      i a b))
   (a (b c)) 2 1 2)
 
+(deftest macro-function.16
+    (progn (defmacro f nil nil)
+	   (prog1 (macrolet ((m (&environment env) (macro-function 'f env))) (macrolet ((f nil nil)) (flet ((f nil nil)) (m))))
+	     (fmakunbound 'f)))
+  nil)
+
 
 
 ;;; Error tests
--- gcl27-2.7.0.orig/clcs/gcl_clcs_condition_definitions.lisp
+++ gcl27-2.7.0/clcs/gcl_clcs_condition_definitions.lisp
@@ -113,10 +113,11 @@
   ((function-name :initarg :function-name
 		  :reader internal-condition-function-name
 		  :initform nil))
-  (:report (lambda (condition stream)
-	     (when (internal-condition-function-name condition)
-	       (format stream "Condition in ~S [or a callee]: "
-		       (internal-condition-function-name condition)))
+  (:report (lambda (condition stream &aux (x (internal-condition-function-name condition)))
+	     (when x
+	       (if (stringp x);FIXME compiler context
+		   (format stream x)
+		   (format stream "Condition in ~S [or a callee]: " x)))
 	     (call-next-method))))
 
 
--- gcl27-2.7.0.orig/clcs/gcl_clcs_conditions.lisp
+++ gcl27-2.7.0/clcs/gcl_clcs_conditions.lisp
@@ -28,6 +28,7 @@
   (let* ((report-function nil)
 	 (default-initargs nil)
 	 (documentation nil))
+    (declare (ignore documentation))
     (do ((o options (cdr o)))
 	((null o))
       (let ((option (car o)))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpblock.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpblock.lsp
@@ -62,44 +62,6 @@
 	   (lambda (x) (setf (blk-ref-clb x) t))
 	   (lambda (x) (setf (blk-ref x) t))))
 
-;; (defun ref-blks1 (form blks &aux (i (cadr form)))
-;;   (dolist (blk blks)
-;;     (when (member blk (info-bref-ccb i))
-;;       (setf (blk-ref-ccb blk) t))
-;;     (when (member blk (info-bref-clb i))
-;;       (setf (blk-ref-clb blk) t))
-;;     (when (member blk (info-bref i))
-;;       (setf (blk-ref blk) t))))
-
-;; (defun ref-blks (form blks &optional l)
-;;   (cond ((not l) 
-;; 	 (cond (*fast-ref* (ref-blks1 form blks))
-;; 	       ((let* ((l (list (info-bref (cadr form)) (info-bref-ccb (cadr form)) (info-bref-clb (cadr form))))
-;; 		       (l (mapcar (lambda (x) (intersection x blks)) l))
-;; 		       (l (mapcar (lambda (y) (mapcar (lambda (x) (cons x nil)) y)) l)))
-;; 		  (ref-blks form blks l)
-;; 		  (let* (y (x (member-if (lambda (x) (setq y (member nil x :key 'cdr))) l)))
-;; 		    (when y
-;; 		      (cmpwarn "~s Blk ~s reffed in info but not in form" (length (ldiff l x)) (blk-name (caar y)))))))))
-;; 	((atom form))
-;; 	((eq (car form) 'return-from)
-;; 	 (let* ((bref (cddr form))
-;; 		(v (pop bref))
-;; 		(clb (pop bref))
-;; 		(ccb (car bref)))
-;; 	   (when (member v blks)
-;; 	     (cond (ccb (setf (blk-ref-ccb v) t) 
-;; 			(let* ((x (cadr l))(x (assoc v x)))
-;; 			  (if x (rplacd x t) (cmpwarn "ccb Block ~s reffed in form but not in info" (blk-name v)))))
-;; 		   (clb (setf (blk-ref-clb v) t)
-;; 			(let* ((x (caddr l))(x (assoc v x))) 
-;; 			  (if x (rplacd x t) (cmpwarn "clb Block ~s reffed in form but not in info" (blk-name v)))))
-;; 		   ((setf (blk-ref v) t)
-;; 		    (let* ((x (car l))(x (assoc v x))) 
-;; 		      (if x (rplacd x t) (cmpwarn "nil Block ~s reffed in form but not in info" (blk-name v))))))
-;; 	     (keyed-cmpnote (list 'blk-ref (blk-name v)) "Block ~s is referred with barrier ~s" (blk-name v) (if ccb 'cb (if clb 'lb))))
-;; 	   (ref-blks (cdddr form) blks l)));FIXME?
-;; 	(t (ref-blks (car form) blks l) (ref-blks (cdr form) blks l))))
 
 (defun prune-mch (l &optional tag-conflict-p)
   (remove-if (lambda (x &aux (v (pop x))(tp (pop x))(st (pop x))(m (car x)))
@@ -130,7 +92,7 @@
     (when (or (blk-ref-ccb blk) (blk-ref-clb blk))
       (set-volatile info))
     (when (info-type info)
-      (mapc (lambda (x &aux (y x)(v (pop x))(tp (pop x))(st (pop x))(m (car x))
+      (mapc (lambda (x &aux (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)
@@ -145,49 +107,6 @@
     (cond ((or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))(list 'block info blk body))
 	  (body))))
 
-;; (defun c1block (args &aux (info (make-info)))
-;;   (when (endp args) (too-few-args 'block 1 0))
-;;   (cmpck (not (symbolp (car args)))
-;;          "The block name ~s is not a symbol." (car args))
-;;   (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil :exit *c1exit*))
-;;          (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args)))))
-;;     (labels ((nb (b) (if (and (eq (car b) 'return-from) (eq blk (caddr b))) (nb (seventh b)) b))) (setq body (nb body)))
-;;     (add-info info (cadr body))
-;;     (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk)))
-;;     (ref-blks body (list blk))
-;;     (when (or (blk-ref-ccb blk) (blk-ref-clb blk))
-;;       (incf *setjmps*))
-;;     (cond ((or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))(list 'block info blk body))
-;; 	  (body))))
-
-;; (defun c1block (args &aux (info (make-info)))
-;;   (when (endp args) (too-few-args 'block 1 0))
-;;   (cmpck (not (symbolp (car args)))
-;;          "The block name ~s is not a symbol." (car args))
-;;   (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil :exit *c1exit*))
-;;          (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args)))))
-;;     (add-info info (cadr body))
-;;     (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk)))
-;;     (ref-blks body (list blk))
-;;     (when (or (blk-ref-ccb blk) (blk-ref-clb blk))
-;;       (incf *setjmps*))
-;;     (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))
-;; 	(list 'block info blk body)
-;;       body)))
-
-;; (defun c1block (args &aux (info (make-info)))
-;;   (when (endp args) (too-few-args 'block 1 0))
-;;   (cmpck (not (symbolp (car args)))
-;;          "The block name ~s is not a symbol." (car args))
-;;   (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil :exit *c1exit*))
-;;          (body (let ((*blocks* (cons blk *blocks*))) (c1progn (cdr args)))))
-;;     (when (or (blk-ref-ccb blk) (blk-ref-clb blk))
-;;       (incf *setjmps*))
-;;     (add-info info (cadr body))
-;;     (setf (info-type info) (type-or1 (info-type (cadr body)) (blk-type blk)))
-;;     (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))
-;; 	(list 'block info blk body)
-;;       body)))
 
 (defun c2block (blk body)
   (cond ((blk-ref-ccb blk) (c2block-ccb blk body))
@@ -266,113 +185,6 @@
 				 info)
 			       blk ccb clb c1fv val))))))));FIXME infer-tp here, or better in blk-var-null, etc.
 
-;; (defun c1return-from (args &aux (name (car args)) ccb clb inner)
-;;   (cond ((endp args) (too-few-args 'return-from 1 0))
-;;         ((and (not (endp (cdr args))) (not (endp (cddr args))))
-;;          (too-many-args 'return-from 2 (length args)))
-;;         ((not (symbolp (car args)))
-;;          "The block name ~s is not a symbol." (car args)))
-;;   (dolist (blk *blocks* (cmperr "The block ~s is undefined." name))
-;;     (case blk
-;; 	  (cb (setq ccb t inner (or inner 'cb)))
-;; 	  (lb (setq clb t inner (or inner 'lb)))
-;; 	  (t (when (eq (blk-name blk) name)
-;; 	       (let* ((*c1exit* (cons (blk-name blk) (blk-exit blk)))
-;; 		      (val (c1expr (cadr args)))
-;; 		      (c1fv (when ccb (c1inner-fun-var))))
-;; 		 (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val))))
-;; 		 (return (list 'return-from
-;; 			       (let ((info (copy-info (cadr val))))
-;; 				 (setf (info-type info) nil)
-;; 				 (cond (ccb (pushnew blk (info-ref-ccb info)))
-;; 				       (clb (pushnew blk (info-ref-clb info)))
-;; 				       ((pushnew blk (info-ref info))))
-;; 				 (when c1fv (add-info info (cadr c1fv)))
-;; 				 info)
-;; 			       blk ccb clb c1fv val))))))))
-
-;; (defun c1return-from (args &aux (name (car args)) ccb clb inner)
-;;   (cond ((endp args) (too-few-args 'return-from 1 0))
-;;         ((and (not (endp (cdr args))) (not (endp (cddr args))))
-;;          (too-many-args 'return-from 2 (length args)))
-;;         ((not (symbolp (car args)))
-;;          "The block name ~s is not a symbol." (car args)))
-;;   (dolist (blk *blocks* (cmperr "The block ~s is undefined." name))
-;;     (case blk
-;; 	  (cb (setq ccb t inner (or inner 'cb)))
-;; 	  (lb (setq clb t inner (or inner 'lb)))
-;; 	  (t (when (eq (blk-name blk) name)
-;; 	       (let* ((*c1exit* (cons (blk-name blk) (blk-exit blk)))
-;; 		      (val (c1expr (cadr args)))
-;; 		      (c1fv (when ccb (c1inner-fun-var))))
-;; 		 (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val))))
-;; 		 (return (list 'return-from
-;; 			       (let ((info (copy-info (cadr val))))
-;; 				 (setf (info-type info) nil)
-;; 				 (pushnew blk (info-blocks info))
-;; 				 (when *make-fast-ref*
-;; 				   (cond (ccb (pushnew blk (info-vref-ccb info)))
-;; 					 (clb (pushnew blk (info-vref-clb info)))
-;; 					 ((pushnew blk (info-vref info)))))
-;; 				 (when c1fv (add-info info (cadr c1fv)))
-;; 				 info)
-;; 			       blk ccb clb c1fv val))))))))
-
-;; (defun c1return-from (args &aux (name (car args)) ccb clb inner)
-;;   (cond ((endp args) (too-few-args 'return-from 1 0))
-;;         ((and (not (endp (cdr args))) (not (endp (cddr args))))
-;;          (too-many-args 'return-from 2 (length args)))
-;;         ((not (symbolp (car args)))
-;;          "The block name ~s is not a symbol." (car args)))
-;;   (dolist (blk *blocks* (cmperr "The block ~s is undefined." name))
-;;     (case blk
-;; 	  (cb (setq ccb t inner (or inner 'cb)))
-;; 	  (lb (setq clb t inner (or inner 'lb)))
-;; 	  (t (when (eq (blk-name blk) name)
-;; 	       (let* ((*c1exit* (cons (blk-name blk) (blk-exit blk)))
-;; 		      (val (c1expr (cadr args)))
-;; 		      (c1fv (when ccb (c1inner-fun-var))))
-;; 		 (setf (blk-type blk) (type-or1 (blk-type blk) (info-type (cadr val))))
-;; 		 (return (list 'return-from
-;; 			       (let ((info (copy-info (cadr val))))
-;; 				 (setf (info-type info) nil)
-;; 				 (pushnew blk (info-blocks info))
-;; 				 (cond (ccb (pushnew blk (info-bref-ccb info)))
-;; 				       (clb (pushnew blk (info-bref-clb info)))
-;; 				       ((pushnew blk (info-bref info))))
-;; 				 (when c1fv (add-info info (cadr c1fv)))
-;; 				 info)
-;; 			       blk clb ccb c1fv val))))))))
-
-;; (defun c1return-from (args)
-;;   (cond ((endp args) (too-few-args 'return-from 1 0))
-;;         ((and (not (endp (cdr args))) (not (endp (cddr args))))
-;;          (too-many-args 'return-from 2 (length args)))
-;;         ((not (symbolp (car args)))
-;;          "The block name ~s is not a symbol." (car args)))
-;;   (do ((blks *blocks* (cdr blks))
-;;        (name (car args))
-;;        ccb clb inner)
-;;       ((endp blks)
-;;        (cmperr "The block ~s is undefined." name))
-;;       (case (car blks)
-;;             (cb (setq ccb t inner (or inner 'cb)))
-;;             (lb (setq clb t inner (or inner 'lb)))
-;;             (t (when (eq (blk-name (car blks)) name)
-;; 		 (let* ((blk (car blks))
-;; 			(*c1exit* (cons (blk-name (car blks)) (blk-exit (car blks))))
-;; 			(val (c1expr (cadr args))))
-;; 		   (cond
-;; 		    (ccb (ref-inner inner) (setf (blk-ref-ccb blk) t))
-;; 		    (clb (setf (blk-ref-clb blk) t))
-;; 		    (t (setf (blk-ref blk) t)))
-;; 		   (setf (blk-type (car blks)) (type-or1 (blk-type (car blks)) (info-type (cadr val))))
-;; 		   (return (list 'return-from
-;; 				 (let ((info (copy-info (cadr val))))
-;; 				   (setf (info-type info) nil)
-;; 				   (pushnew blk (info-blocks info))
-;; 				   info)
-;; 				 blk clb ccb val))))))))
 
 (defun c2return-from (blk ccb clb c1fv val)
   (declare (ignore c1fv))
@@ -380,17 +192,6 @@
         (clb (c2return-clb blk val))
         (t (c2return-local blk val))))
 
-;; (defun c2return-from (blk clb ccb c1fv val)
-;;   (declare (ignore c1fv))
-;;   (cond (ccb (c2return-ccb blk val))
-;;         (clb (c2return-clb blk val))
-;;         (t (c2return-local blk val))))
-
-;; (defun c2return-from (blk clb ccb val)
-;;   (cond (ccb (c2return-ccb blk val))
-;;         (clb (c2return-clb blk val))
-;;         (t (c2return-local blk val))))
-
 (defun c2return-local (blk val)
   (let ((*value-to-go* (blk-value-to-go blk))
         (*exit* (blk-exit blk)))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpcall.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpcall.lsp
@@ -42,8 +42,8 @@
 
 ;;Like macro-function except it searches the lexical environment,
 ;;to determine if the macro is shadowed by a function or a macro.
-(defun cmp-macro-function (name)
-  (or (c1local-fun name) (macro-function name)))
+(defun cmp-macro-function (name &aux (fun (local-fun-obj name)))
+  (if fun (unless (fun-src fun) (fun-fn fun)) (macro-function name)))
 
 ;; (defun sf (s)
 ;;   (declare (optimize (safety 1)))
@@ -213,6 +213,8 @@
 	 (sl (sublis s ll)))
     (blla sl args last `((tail-recur ,tag ,s)))))
 
+(defmacro tail-recur (&rest r) (declare (ignore r)))
+
 (defun c1tail-recur (args)
   (let* ((s (cadr args))
 	 (ts (or (car (member (car args) *ttl-tags* :key 'car)) (baboon)))
@@ -227,50 +229,6 @@
 	       (setq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s))
 	       (go ,(tag-name ttl-tag))))))
 
-;; (defun c1tail-recur (args)
-;;   (let* ((tag (pop args))
-;; 	 (s (car args))
-;; 	 (ts (or (car (member tag *ttl-tags* :key (lambda (x) (tag-name (car x))))) (baboon)))
-;; 	 (ttl-tag (pop ts))
-;; 	 (nv (mapcar (lambda (x) (car (member (cdr x) *vars* 
-;; 					      :key (lambda (x) (when (var-p x) (var-name x)))))) s))
-;; 	 (ov (mapcar (lambda (x) (car (member (car x) (car ts) 
-;; 					      :key (lambda (x) (when (var-p x) (var-name x)))))) s))
-;; 	 (*vars* (mapc (lambda (x) (set-var-noreplace x)) (append nv ov)))
-;; 	 (*tags* (cons ttl-tag *tags*)))
-;;     (c1expr `(progn
-;; 	       (setq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s))
-;; 	       (go ,tag)))))
-
-;; (defun c1tail-recur (args)
-;;   (let* ((tag (pop args))
-;; 	 (s (car args))
-;; 	 (ts (or (car (member tag *ttl-tags* :key (lambda (x) (tag-name (car x))))) (baboon)))
-;; 	 (ttl-tag (pop ts))
-;; 	 (nv (mapcar (lambda (x) (car (member (cdr x) *vars* 
-;; 					      :key (lambda (x) (when (var-p x) (var-name x)))))) s))
-;; 	 (ov (mapcar (lambda (x) (car (member (car x) (car ts) 
-;; 					      :key (lambda (x) (when (var-p x) (var-name x)))))) s))
-;; 	 (*vars* (mapc (lambda (x) (setf (var-store x) t)) (append nv ov)))
-;; 	 (*tags* (cons ttl-tag *tags*)))
-;;     (c1expr `(progn
-;; 	       (setq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s))
-;; 	       (go ,tag)))))
-
-;; (defun c1tail-recur (args)
-;;   (let* ((tag (pop args))
-;; 	 (s (car args))
-;; 	 (ts (or (car (member tag *ttl-tags* :key (lambda (x) (tag-name (car x))))) (baboon)))
-;; 	 (ttl-tag (pop ts))
-;; 	 (nv (mapcar (lambda (x) (car (member (cdr x) *vars* 
-;; 					      :key (lambda (x) (when (var-p x) (var-name x)))))) s))
-;; 	 (ov (mapcar (lambda (x) (car (member (car x) (car ts) 
-;; 					      :key (lambda (x) (when (var-p x) (var-name x)))))) s))
-;; 	 (*vars* (mapc (lambda (x) (setf (var-store x) t)) (append nv ov)))
-;; 	 (*tags* (cons ttl-tag *tags*)))
-;;     (c1expr `(progn
-;; 	       (psetq ,@(mapcan (lambda (x) (list (car x) (cdr x))) s))
-;; 	       (go ,tag)))))
     
 (setf (get 'tail-recur 'c1) 'c1tail-recur)
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpcatch.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpcatch.lsp
@@ -29,9 +29,8 @@
 (si:putprop 'throw 'c1throw 'c1special)
 (si:putprop 'throw 'c2throw 'c2)
 
-(defun c1catch (args &aux (info (make-info :type #t* :flags (iflags sp-change volatile))) tag)
+(defun c1catch (args &aux (info (make-info :type #t* :flags (iflags sp-change volatile))))
   (when (endp args) (too-few-args 'catch 1 0))
-  (setq tag (c1arg (car args) info))
   (let* ((tag (c1arg (pop args) info))
 	 (in (mch))
 	 (body (unwind-protect (c1progn args) 
@@ -42,65 +41,6 @@
     (add-info info (cadr body))
     (list 'catch info tag body)))
 
-;; (defun c1catch (args &aux (info (make-info :type #t* :sp-change 1)) tag)
-;;   (incf *setjmps*)
-;;   (when (endp args) (too-few-args 'catch 1 0))
-;;   (setq tag (c1arg (car args) info))
-;;   (let (vl (nt (tmpsym)))
-;;     (dolist (v *vars*) (when (var-p v) 
-;; 			 (push (list v (var-mt v) (var-tag v)) vl)
-;; 			 (setf (var-tag v) nt (var-mt v) (var-type v))))
-;;     (setq args
-;; 	  (unwind-protect
-;; 	      (do (nargs)
-;; 		  ((not 
-;; 		    (let* ((*catch-tags* (cons nt *catch-tags*))
-;; 			   (nv (with-restore-vars
-;; 				(catch nt
-;; 				  (setq nargs (c1progn (cdr args))) nil))))
-;; 		      (when nv
-;; 			(do nil ((not (setq nv (pop *tvc*))) t) (setf (var-type nv) (var-mt nv))))))
-;; 		   nargs))
-;; 	    (dolist (v vl) 
-;; 	      (when (caddr v)
-;; 		(unless (type>= (cadr v) (var-mt (car v)))
-;; 		  (pushnew (car v) *tvc*)))
-;; 	      (setf (var-mt (car v)) (type-or1 (var-mt (car v)) (cadr v))
-;; 		    (var-tag (car v)) (caddr v))))))
-
-;;   (add-info info (cadr args))
-;;   (list 'catch info tag args))
-
-;; (defun c1catch (args &aux (info (make-info :type #t* :sp-change 1)) tag)
-;;   (incf *setjmps*)
-;;   (when (endp args) (too-few-args 'catch 1 0))
-;;   (setq tag (c1expr (car args)))
-;;   (add-info info (cadr tag))
-;;   (let (vl (nt (tmpsym)))
-;;     (dolist (v *vars*) (when (var-p v) 
-;; 			 (push (list v (var-mt v) (var-tag v)) vl)
-;; 			 (setf (var-tag v) nt (var-mt v) (var-type v))))
-;;     (setq args
-;; 	  (unwind-protect
-;; 	      (do (nargs)
-;; 		  ((not 
-;; 		    (let* ((*catch-tags* (cons nt *catch-tags*))
-;; 			   (nv (with-restore-vars
-;; 				(catch nt
-;; 				  (setq nargs (c1progn (cdr args))) nil))))
-;; 		      (when nv
-;; 			(do nil ((not (setq nv (pop *tvc*))) t) (setf (var-type nv) (var-mt nv))))))
-;; 		   nargs))
-;; 	    (dolist (v vl) 
-;; 	      (when (caddr v)
-;; 		(unless (type>= (cadr v) (var-mt (car v)))
-;; 		  (pushnew (car v) *tvc*)))
-;; 	      (setf (var-mt (car v)) (type-or1 (var-mt (car v)) (cadr v))
-;; 		    (var-tag (car v)) (caddr v))))))
-
-;;   (add-info info (cadr args))
-;;   (list 'catch info tag args))
-
 (si:putprop 'push-catch-frame 'set-push-catch-frame 'set-loc)
 
 (defun c2catch (tag body &aux (*vs* *vs*))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpenv.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpenv.lsp
@@ -325,7 +325,8 @@
 		      (push var ss)))
 		   ((ignore ignorable)
 		    (dolist (var (cdr decl))
-		      (cmpck (not (symbolp var)) "The ignore declaration ~s contains a non-symbol ~s."
+		      (cmpck (not (typep var '(or symbol (cons (member function) (cons function-name null)))))
+			     "The ignore declaration ~s is illegal ~s."
 			     decl var)
 		      (when (eq stype 'ignorable)
 			(push 'ignorable is))
@@ -341,7 +342,7 @@
 			  (cond ((unless (get var 'tmp) (eq stype 'hint)) (push (cons var type) cps) ;FIXME
 				 (push (cons var (global-type-bump type)) ts))
 				((push (cons var type) ts)))))))
-		   (class
+		   (class ;FIXME pcl
 		    (cmpck (cdddr decl) "The type declaration ~s is illegal." decl)
 		    (let ((type (max-vtp (or (caddr decl) (car decl)))))
 		      (when type
@@ -366,11 +367,13 @@
 		      (push (cons var 'dynamic-extent) ts)))
 		   (otherwise
 		    (let ((type (unless (member stype *alien-declarations*) (max-vtp stype))))
-		      (if (unless (eq type t) type)
-			  (dolist (var (cdr decl))
-			    (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-				   decl var)
-			    (push (cons var type) ts))
+		      (if type
+			  (unless (eq type t)
+			    (dolist (var (cdr decl))
+			      (cmpck (not (symbolp var))
+				     "The type declaration ~s contains a non-symbol ~s."
+				     decl var)
+			      (push (cons var type) ts)))
 			(push decl others))))))))))
 
   (dolist (l ctps) 
@@ -387,184 +390,6 @@
 			body))))
   (values body ss ts is others (when doc-p doc) cps)))
 
-;; (defun c1body (body doc-p &aux ss is ts others cps)
-;;   (multiple-value-bind
-;;    (doc decls ctps body)
-;;    (parse-body-header body (unless doc-p ""))
-;;    (dolist (decl decls)
-;;      (dolist (decl (cdr decl))
-;;        (cmpck (not (consp decl)) "The declaration ~s is illegal." decl)
-;;        (let ((dtype (car decl)))
-;; 	 (if (consp dtype)
-;; 	     (let* ((dtype (max-vtp dtype))
-;; 		    (stype (if (consp dtype) (car dtype) dtype)))
-;; 	       (case stype
-;; 		     (satisfies (push decl others))
-;; 		     (otherwise
-;; 		      (dolist (var (cdr decl))
-;; 			(cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 			       decl var)
-;; 			(push (cons var dtype) ts)))))
-;; 	   (let ((stype dtype))
-;; 	     (cmpck (not (symbolp stype)) "The declaration ~s is illegal." decl)
-;; 	     (case stype
-;; 		   (special
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The special declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push var ss)))
-;; 		   ((ignore ignorable)
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The ignore declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (when (eq stype 'ignorable)
-;; 			(push 'ignorable is))
-;; 		      (push var is)))
-;; 		   ((optimize ftype inline notinline)
-;; 		    (push decl others))
-;; 		   ((hint type)
-;; 		    (cmpck (endp (cdr decl))  "The type declaration ~s is illegal." decl)
-;; 		    (let ((type (max-vtp (cadr decl))))
-;; 		      (when type
-;; 			(dolist (var (cddr decl))
-;; 			  (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var)
-;; 			  (push (cons var type) ts)))))
-;; 		   (class
-;; 		    (cmpck (cdddr decl) "The type declaration ~s is illegal." decl)
-;; 		    (let ((type (max-vtp (or (caddr decl) (car decl)))))
-;; 		      (when type
-;; 			(let ((var (cadr decl)))
-;; 			  (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 				 decl var)
-;; 			  (push (cons var type) ts)))))
-;; 		   (object
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The object declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push (cons var 'object) ts)))
-;; 		   (:register
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The register declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push (cons var  'register) ts)))
-;; 		   ((:dynamic-extent dynamic-extent)
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push (cons var 'dynamic-extent) ts)))
-;; 		   (otherwise
-;; 		    (let ((type (max-vtp stype)))
-;; 		      (unless (eq type t)
-;; 			(dolist (var (cdr decl))
-;; 			  (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 				 decl var)
-;; 			  (push (cons var type) ts)))))))))))
-
-;;   (dolist (l ctps) 
-;;     (when (and (cadr l) (symbolp (cadr l))) 
-;;       (let ((tp (max-vtp (caddr l)))) 
-;; 	(unless (eq tp t) 
-;; 	  (push (cons (cadr l) tp) cps)))))
-
-;;   (let ((s (> (effective-safety (mapcar (lambda (x) `(declare ,x)) others)) 0)))
-;;     (when cps
-;;       (unless s
-;; ;	  (setq body `((let ,(mapcar (lambda (x) (list (car x) (car x))) cps) ,@body)))
-;; 	(setq ts (nconc cps ts))))
-;;     (when (and ctps s)
-;;       (setq body (nreconc ctps body))))
-;;   (values body ss ts is others (when doc-p doc) cps)))
-
-;; (defun c1body (body doc-p &aux ss is ts others cps)
-;;   (multiple-value-bind
-;;    (doc decls ctps body)
-;;    (parse-body-header body (unless doc-p ""))
-;;    (dolist (decl decls)
-;;      (dolist (decl (cdr decl))
-;;        (cmpck (not (consp decl)) "The declaration ~s is illegal." decl)
-;;        (let ((dtype (car decl)))
-;; 	 (if (consp dtype)
-;; 	     (let* ((dtype (max-vtp dtype))
-;; 		    (stype (if (consp dtype) (car dtype) dtype)))
-;; 	       (case stype
-;; 		     (satisfies (push decl others))
-;; 		     (otherwise
-;; 		      (dolist (var (cdr decl))
-;; 			(cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 			       decl var)
-;; 			(push (cons var dtype) ts)))))
-;; 	   (let ((stype dtype))
-;; 	     (cmpck (not (symbolp stype)) "The declaration ~s is illegal." decl)
-;; 	     (case stype
-;; 		   (special
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The special declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push var ss)))
-;; 		   ((ignore ignorable)
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The ignore declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (when (eq stype 'ignorable)
-;; 			(push 'ignorable is))
-;; 		      (push var is)))
-;; 		   ((optimize ftype inline notinline)
-;; 		    (push decl others))
-;; 		   ((hint type)
-;; 		    (cmpck (endp (cdr decl))  "The type declaration ~s is illegal." decl)
-;; 		    (let ((type (max-vtp (cadr decl))))
-;; 		      (when type
-;; 			(dolist (var (cddr decl))
-;; 			  (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 				 decl var)
-;; 			  (cond ((eq stype 'hint) (push (cons var type) cps) 
-;; 				 (push (cons var (global-type-bump type)) ts))
-;; 				((push (cons var type) ts)))))))
-;; 		   (class
-;; 		    (cmpck (cdddr decl) "The type declaration ~s is illegal." decl)
-;; 		    (let ((type (max-vtp (or (caddr decl) (car decl)))))
-;; 		      (when type
-;; 			(let ((var (cadr decl)))
-;; 			  (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 				 decl var)
-;; 			  (push (cons var type) ts)))))
-;; 		   (object
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The object declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push (cons var 'object) ts)))
-;; 		   (:register
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The register declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push (cons var  'register) ts)))
-;; 		   ((:dynamic-extent dynamic-extent)
-;; 		    (dolist (var (cdr decl))
-;; 		      (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 			     decl var)
-;; 		      (push (cons var 'dynamic-extent) ts)))
-;; 		   (otherwise
-;; 		    (let ((type (max-vtp stype)))
-;; 		      (unless (eq type t)
-;; 			(dolist (var (cdr decl))
-;; 			  (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
-;; 				 decl var)
-;; 			  (push (cons var type) ts)))))))))))
-
-;;   (dolist (l ctps) 
-;;     (when (and (cadr l) (symbolp (cadr l))) 
-;;       (let ((tp (max-vtp (caddr l)))) 
-;; 	(unless (eq tp t) 
-;; 	  (push (cons (cadr l) tp) cps)))))
-
-;;   (let ((s (> (effective-safety (mapcar (lambda (x) `(declare ,x)) others)) 0)))
-;;     (when cps
-;;       (unless s
-;; ;	  (setq body `((let ,(mapcar (lambda (x) (list (car x) (car x))) cps) ,@body)))
-;; 	(setq ts (nconc cps ts))))
-;;     (when (and ctps s)
-;;       (setq body (nreconc ctps body))))
-;;   (values body ss ts is others (when doc-p doc) cps)))
 
 (defun c1decl-body (decls body &aux dl)
   (let ((*function-declarations* *function-declarations*)
@@ -627,129 +452,6 @@
 	    ((eq (car c1b) 'decl-body) (setf (third c1b) (nunion dl (third c1b))) c1b)
 	    ((list 'decl-body (copy-info (cadr c1b)) dl c1b))))))
 
-;; (defun c1decl-body (decls body &aux dl)
-;;   (let ((*function-declarations* *function-declarations*)
-;; 	(*alien-declarations* *alien-declarations*)
-;; 	(*notinline* *notinline*)
-;; 	(*inline* *inline*)
-;; 	(*space* *space*)
-;; 	(*compiler-check-args* *compiler-check-args*)
-;; 	(*compiler-new-safety* *compiler-new-safety*)
-;; 	(*compiler-push-events* *compiler-push-events*)
-;; 	(*safe-compile* *safe-compile*))
-;;     (dolist (decl decls dl)
-;;       (case (car decl)
-;; 	    (optimize
-;; 	     (dolist (d (cdr decl)) (push d dl))
-;; 	     (local-compile-decls (cdr decl)))
-;; 	    (ftype
-;; 	     (if (or (endp (cdr decl))
-;; 		     (not (consp (cadr decl)))
-;; 		     (not (eq (caadr decl) 'function))
-;; 		     (endp (cdadr decl)))
-;; 		 (cmpwarn "The function declaration ~s is illegal." decl)
-;; 	       (dolist (fname (cddr decl))
-;; 		 (add-function-declaration
-;; 		  fname (cadadr decl) (cddadr decl)))))
-;; 	    (function
-;; 	     (if (or (endp (cdr decl))
-;; 		     (endp (cddr decl))
-;; 		     (not (symbolp (cadr decl))))
-;; 		 (cmpwarn "The function declaration ~s is illegal." decl)
-;; 	       (add-function-declaration
-;; 		(cadr decl) (caddr decl) (cdddr decl))))
-;; 	    (inline
-;; 	      (dolist (fun (cdr decl))
-;; 		(if (symbolp fun)
-;; 		    (progn (push (list 'inline fun) dl)
-;; 			   (pushnew fun *inline*)
-;; 			   (setq *notinline* (remove fun *notinline*)))
-;; 		  (cmpwarn "The function name ~s is not a symbol." fun))))
-;; 	    (notinline
-;; 	     (dolist (fun (cdr decl))
-;; 	       (if (symbolp fun)
-;; 		   (progn (push (list 'notinline fun) dl)
-;; 			  (pushnew fun *notinline*)
-;; 			  (setq *inline* (remove fun *inline*)))
-;; 		 (cmpwarn "The function name ~s is not a symbol." fun))))
-;; 	    (declaration
-;; 	     (dolist (x (cdr decl))
-;; 	       (if (symbolp x)
-;; 		   (unless (member x *alien-declarations*)
-;; 		     (push x *alien-declarations*))
-;; 		 (cmpwarn "The declaration specifier ~s is not a symbol."
-;; 			  x))))
-;; 	    (otherwise
-;; 	     (unless (member (car decl) *alien-declarations*)
-;; 	       (cmpwarn "The declaration specifier ~s is unknown." (car decl))))))
-;;     (let ((c1b (c1progn body)))
-;;       (cond ((null dl) c1b)
-;; 	    ((unless *safe-compile* (eq (car c1b) 'lit)) c1b)
-;; 	    ((eq (car c1b) 'decl-body) (setf (third c1b) (nunion dl (third c1b))) c1b)
-;; 	    ((list 'decl-body (copy-info (cadr c1b)) dl c1b))))))
-
-;; (defun c1decl-body (decls body &aux (dl nil))
-;;   (if (null decls)
-;;       (c1progn body)
-;;     (let ((*function-declarations* *function-declarations*)
-;; 	  (*alien-declarations* *alien-declarations*)
-;; 	  (*notinline* *notinline*)
-;; 	  (*inline* *inline*)
-;; 	  (*space* *space*)
-;; 	  (*compiler-check-args* *compiler-check-args*)
-;; 	  (*compiler-new-safety* *compiler-new-safety*)
-;; 	  (*compiler-push-events* *compiler-push-events*)
-;; 	  (*safe-compile* *safe-compile*))
-;;       (dolist (decl decls dl)
-;; 	(case (car decl)
-;; 	      (optimize
-;; 	       (dolist (d (cdr decl)) (push d dl))
-;; 	       (local-compile-decls (cdr decl)))
-;;               (ftype
-;;                (if (or (endp (cdr decl))
-;;                        (not (consp (cadr decl)))
-;;                        (not (eq (caadr decl) 'function))
-;;                        (endp (cdadr decl)))
-;;                    (cmpwarn "The function declaration ~s is illegal." decl)
-;; 		 (dolist (fname (cddr decl))
-;; 		   (add-function-declaration
-;; 		    fname (cadadr decl) (cddadr decl)))))
-;;               (function
-;;                (if (or (endp (cdr decl))
-;;                        (endp (cddr decl))
-;;                        (not (symbolp (cadr decl))))
-;;                    (cmpwarn "The function declaration ~s is illegal." decl)
-;; 		 (add-function-declaration
-;; 		  (cadr decl) (caddr decl) (cdddr decl))))
-;;               (inline
-;; 		(dolist (fun (cdr decl))
-;; 		  (if (symbolp fun)
-;; 		      (progn (push (list 'inline fun) dl)
-;; 			     (pushnew fun *inline*)
-;; 			     (setq *notinline* (remove fun *notinline*)))
-;; 		    (cmpwarn "The function name ~s is not a symbol." fun))))
-;;               (notinline
-;;                (dolist (fun (cdr decl))
-;; 		 (if (symbolp fun)
-;;                      (progn (push (list 'notinline fun) dl)
-;;                             (pushnew fun *notinline*)
-;; 			    (setq *inline* (remove fun *inline*)))
-;; 		   (cmpwarn "The function name ~s is not a symbol." fun))))
-;;               (declaration
-;;                (dolist (x (cdr decl))
-;;                  (if (symbolp x)
-;;                      (unless (member x *alien-declarations*)
-;; 		       (push x *alien-declarations*))
-;; 		   (cmpwarn "The declaration specifier ~s is not a symbol."
-;; 			    x))))
-;;               (otherwise
-;;                (unless (member (car decl) *alien-declarations*)
-;;                  (cmpwarn "The declaration specifier ~s is unknown." (car decl))))))
-;;       (setq body (c1progn body))
-;;       (cond ((null dl) body)
-;; 	    ((eq (car body) 'decl-body) (setf (third body) (nunion dl (third body))) body)
-;; 	    ((list 'decl-body (copy-info (cadr body)) dl body))))))
-
 (si:putprop 'decl-body 'c2decl-body 'c2)
 
 (defun local-compile-decls (decls)
@@ -809,7 +511,7 @@
 		     "free type declaration ~s ~s" (car d) (cdr d))
       (c1infer-tp (list (car d) (cdr d)))))
   (dolist (x is)
-    (unless (or (eq x 'ignorable) (member x vnames))
+    (unless (or (eq x 'ignorable) (member x vnames :test 'equal))
       (cmpwarn "Ignore/ignorable declaration was found for not bound variable ~s." x))))
 
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpeval.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpeval.lsp
@@ -81,14 +81,14 @@
       res))
 
 (defun c1expr (form)
-  (setq form (catch *cmperr-tag*
+  (catch *cmperr-tag*
     (cond ((symbolp form)
            (cond ((constantp form) 
 		  (let ((val (symbol-value form)))
 		    (or 
 		     (c1constant-value val nil)
 		     `(location ,(make-info :type (object-type val)) (VV ,(add-constant form))))))
-;                 ((c1var form))))
+					;                 ((c1var form))))
                  ((c1expr-avct (c1var form))))) ;FIXME pcl
           ((consp form)
            (let ((fun (car form)))
@@ -100,52 +100,6 @@
 				 (cmperr "Sharp-comma-macro was found in a bad place."))
 				(t (cmperr "The function ~s is illegal." fun))))))
           (t (c1constant-value form t)))))
-  (if (eq form '*cmperr-tag*) (c1nil) form))
-
-;; (defun c1expr (form)
-;;   (setq form (catch *cmperr-tag*
-;;     (cond ((symbolp form)
-;;            (cond ((constantp form) 
-;; 		  (let ((val (symbol-value form)))
-;; 		    (or 
-;; 		     (c1constant-value val nil)
-;; 		     `(location ,(make-info :type (object-type val)) (VV ,(add-constant form))))))
-;;                  ((c1var form))))
-;; ;                 ((c1expr-avct (c1var form))))) ;FIXME pcl
-;;           ((consp form)
-;;            (let ((fun (car form)))
-;; 	     (c1expr-avct (cond ((symbolp fun)
-;; 				 (c1symbol-fun form))
-;; 				((and (consp fun) (eq (car fun) 'lambda))
-;; 				 (c1symbol-fun (cons 'funcall form)))
-;; 				((and (consp fun) (eq (car fun) 'si:|#,|))
-;; 				 (cmperr "Sharp-comma-macro was found in a bad place."))
-;; 				(t (cmperr "The function ~s is illegal." fun))))))
-;;           (t (c1constant-value form t)))))
-;;   (if (eq form '*cmperr-tag*) (c1nil) form))
-
-;; (defun c1expr (form)
-;;   (setq form (catch *cmperr-tag*
-;;     (cond ((symbolp form)
-;;            (cond ((constantp form) 
-;; 		  (let ((val (symbol-value form)))
-;; 		    (or 
-;; 		     (c1constant-value val nil)
-;; 		     `(location ,(make-info :type (object-type val)) (VV ,(add-constant form))))))
-;;                  ((c1var form))))
-;;           ((consp form)
-;;            (let* ((fun (car form))
-;; 		  (res (cond ((symbolp fun)
-;; 			      (c1symbol-fun form))
-;; 			     ((and (consp fun) (eq (car fun) 'lambda))
-;; 			      (c1symbol-fun (cons 'funcall form)))
-;; 			     ((and (consp fun) (eq (car fun) 'si:|#,|))
-;; 			      (cmperr "Sharp-comma-macro was found in a bad place."))
-;; 			     (t (cmperr "The function ~s is illegal." fun))))
-;; 		  (atp (atomic-tp (info-type (cadr res)))))
-;; 	     (or (when (ignorable-form res) (atomic-type-constant-value atp)) res)))
-;;           (t (c1constant-value form t)))))
-;;   (if (eq form '*cmperr-tag*) (c1nil) form))
 
 (si::putprop 'si:|#,| 'c1sharp-comma 'c1special)
 (si::putprop 'load-time-value 'c1load-time-value 'c1special)
@@ -203,14 +157,7 @@
 
 (defun fix-opt (opt)
   (let ((a (cddr opt)))
-    (unless (typep (car a ) 'fixnum)
-      (if *compiler-in-use*
-	  (cmpwarn "Obsolete optimization: use fix-opt ~s"  opt))
-      
-      (setf (cddr opt)
-	    (cons (logior (if (car a) 2 0)
-			  (if (cadr a) 1 0))
-		  (cddr a))))
+    (cmpck (not (typep (car a ) 'fixnum)) "Obsolete optimization: use fix-opt ~s"  opt)
     (when (listp (car opt))
       (unless (flag-p (caddr opt) nt)
 	(let ((s (uniq-sig (list (mapcar 'cmp-norm-tp (car opt)) (cmp-norm-tp (cadr opt))))))
@@ -643,20 +590,10 @@
 (defmacro inlinable-fn (a) 
   `(or (constantp ,a) (and (consp ,a) (member (car ,a) '(function lambda)))))
 
-(defun and-compiler-macro (form env)
-  (declare (ignore env))
-  (cond ((endp (cdr form)))
-	((endp (cddr form)) (cadr form))
-	((cmp-macroexpand form))))
-;	(`(if ,(cadr form) ,(and-compiler-macro `(and ,@(cddr form)) nil)))))
-(si::putprop 'and 'and-compiler-macro 'si::compiler-macro-prop)
-	   
-(defun or-compiler-macro (form env)
-  (declare (ignore env))
+(define-compiler-macro or (&whole form)
   (cond ((endp (cdr form)) nil)
 	((endp (cddr form)) (cadr form))
-	((cmp-macroexpand `(,(car form) ,(cadr form) (or ,@(cddr form)))))))
-(si::putprop 'or 'or-compiler-macro 'si::compiler-macro-prop)
+	((cmp-macroexpand `(,(pop form) ,(pop form) (or ,@form))))))
 
 (defvar *basic-inlines* nil)
 
@@ -890,7 +827,6 @@
 ;; 	      (cons (bind-all-vars (caddr form))
 ;; 		    (if (cadddr form) (list (bind-all-vars (cadddr form))))))))
 		
-(defvar *in-inline* nil)
 ;(defvar *callees* nil)
 
 (defun maybe-reverse-type-prop (dt f)
@@ -1454,104 +1390,16 @@
 	(let* ((tag (make-ttl-tag));(tmpsym)
 	       (tsrc (ttl-tag-src src tag))
 	       (tagged-sir (make-tagged-sir sir tag (cadr src) ttag))
-	       (*src-inline-recursion* (maybe-cons-tagged-sir tagged-sir src env)))
+	       (*src-inline-recursion* (maybe-cons-tagged-sir tagged-sir src env))
+	       (*top-level-src-p* (member src *top-level-src*)))
 	  (catch tagged-sir (mi4 fun args la tsrc env inls)))))))
 
-;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl)))
-;;   (when (maybe-inline-src fun fms src)
-;;     (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms))))
-;;       (unless (prev-sir sir)
-;; 	(let* ((tag (tmpsym))
-;; 	       (tsrc (ttl-tag-src src tag))
-;; 	       (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env)))
-;; 	  (catch tag (mi4 fun args la tsrc env inls)))))))
-
-;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl)))
-;;   (when (maybe-inline-src fun fms src)
-;;     (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms))))
-;;       (unless (prev-sir sir)
-;; 	(let* ((tag (tmpsym))
-;; 	       (tsrc (ttl-tag-src src tag))
-;; 	       (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env)))
-;; 	  (with-restore-vars
-;; 	   (prog1 (catch tag (mi4 fun args la tsrc env inls))
-;; 	     (keep-vars))))))))
-
-;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl)))
-;;   (when (maybe-inline-src fun fms src)
-;;     (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms))))
-;;       (if (prev-sir sir)
-;; 	  (let ((tag (sir-tag sir))) (when tag (throw tag nil)))
-;; 	(let* ((tag (tmpsym))
-;; 	       (tsrc (ttl-tag-src src tag))
-;; 	       (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env)))
-;; 	  (with-restore-vars
-;; 	   (prog1 (catch tag (mi4 fun args la tsrc env inls))
-;; 	     (keep-vars))))))))
-
-;; (defun mi3 (fun args la fms ttag envl inls &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl)))
-;;   (when src
-;;     (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms))))
-;;       (if (prev-sir sir)
-;; 	  (let ((tag (sir-tag sir))) (when tag (throw tag nil)))
-;; 	(let* ((tag (tmpsym))
-;; 	       (tsrc (ttl-tag-src src tag))
-;; 	       (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env)))
-;; 	  (with-restore-vars
-;; 	   (prog1 (catch tag (mi4 fun args la tsrc env inls))
-;; 	     (keep-vars))))))))
-
-;; (defun mi3 (fun args la fms ttag envl &aux (src (under-env (pop envl) (inline-src fun))) (env (car envl)))
-;;   (when src
-;;     (let ((sir (cons (sir-name fun) (mapcar (lambda (x) (when x (info-type (cadr x)))) fms))))
-;;       (if (prev-sir sir)
-;; 	  (let ((tag (sir-tag sir))) (when tag (throw tag nil)))
-;; 	(let* ((tag (tmpsym))
-;; 	       (tsrc (ttl-tag-src src tag))
-;; 	       (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env)))
-;; 	  (with-restore-vars
-;; 	   (prog1 (catch tag (mi4 fun args la tsrc env))
-;; 	     (keep-vars))))))))
-
-;; (defun mi3 (fun args la fms ttag envl &aux  (src (under-env (pop envl) (inline-src fun))) (env (car envl)))
-;;   (when src
-;;     (let ((sir (cons (if (symbolp fun) fun (tmpsym))
-;; 		     (mapcar (lambda (x) (when x (info-type (cadr x)))) fms))))
-;;       (if (prev-sir sir)
-;; 	  (let ((tag (sir-tag sir))) (when tag (throw tag nil)))
-;; 	(let* ((tag (tmpsym))
-;; 	       (tsrc (ttl-tag-src src tag))
-;; 	       (*src-inline-recursion* (maybe-cons-sir sir tag ttag src env)))
-;; 	  (with-restore-vars
-;; 	   (prog1 (catch tag (mi4 fun args la tsrc env))
-;; 	     (keep-vars))))))))
-
-;; (defun mod-env (ce e l);FIXME
-;;   (if ce (append e l) l))
-
-;; (defun mod-env (ce e l);FIXME
-;;   (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*));FIXME
   l)
 
 
-;; (defun mod-env (ce e l);FIXME
-;;   (if ce (append (remove-if-not (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) e) l))
-
-;; (defun mod-env (ce e l);FIXME
-;;   (if ce (append (remove-if (lambda (x) (or (symbolp x) (is-fun-var x))) e) l) l))
-
-
-;; (defun mod-env (ce e l);FIXME
-;;   (let* ((r (if ce (append (remove-if-not (lambda (x) (or (symbolp x) (is-fun-var x))) (ldiff l e)) e) l))
-;; 	 ;; (vp (member-if 'var-p l))
-;; 	 ;; (ol (when vp (mapcar (lambda (x) (cond ((var-p x) (var-name x)) (x))) l)))
-;; 	 ;; (or (when vp (mapcar (lambda (x) (cond ((var-p x) (var-name x)) (x))) r)))
-;; 	 ) 
-;; ;    (unless (equal or ol) (print ol) (print or))
-;;     r))
 
 (defvar *lexical-env-mask* nil)
 
@@ -1564,29 +1412,6 @@
 	  (*funs*   (mod-env (pop ,e) *funs*)))
      ,@forms))
 
-;; (defmacro under-env (env &rest forms &aux (e (tmpsym)))
-;;   `(let* ((,e ,env)
-;; 	  (*vars*   (mod-env ,e (pop ,e) *vars*))
-;; 	  (*blocks* (mod-env ,e (pop ,e) *blocks*))
-;; 	  (*tags*   (mod-env ,e (pop ,e) *tags*))
-;; 	  (*funs*   (mod-env ,e (pop ,e) *funs*)))
-;;      ,@forms))
-
-;; (defmacro under-env (env form &aux (e (tmpsym)))
-;;   `(let* ((,e ,env)
-;; 	  (*vars*   (mod-env ,e (pop ,e) *vars*))
-;; 	  (*blocks* (mod-env ,e (pop ,e) *blocks*))
-;; 	  (*tags*   (mod-env ,e (pop ,e) *tags*))
-;; 	  (*funs*   (mod-env ,e (pop ,e) *funs*)))
-;;      ,form))
-
-;; (defmacro under-env (env form &aux (e (tmpsym)))
-;;   `(let* ((,e ,env)
-;; 	  (*vars* (if ,e (pop ,e) *vars*))
-;; 	  (*blocks* (if ,e (pop ,e) *blocks*))
-;; 	  (*tags* (if ,e (pop ,e) *tags*))
-;; 	  (*funs* (if ,e (pop ,e) *funs*)))
-;;      ,form))
 
 (defun barrier-cross-p (fun &aux (f (local-fun-p fun)))
   (not (tailp (member-if-not 'fun-p *funs*)
@@ -1671,19 +1496,25 @@
     (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 (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))
-		 (f nargs (cdr f)))
-		((or p (endp f) (endp a))
-		 (or p f (and a (not (eq (car a) '*))))) ; (when (setq nargs (nreverse n)) nil)))
-	      (unless (or (eq '* (car a)) (type-and (car a) (info-type (cadar f))))
-		(cmpwarn "The type of the form ~s is not ~s, but ~s."
-			 (car r) (cmp-unnorm-tp (car a)) (cmp-unnorm-tp (info-type (cadar f))))
-		(setq p t)))
-	(cmpwarn "inlining of ~a prevented due to argument type mismatch: ~a ~a~%" 
-		 fn (mapcar 'cmp-unnorm-tp at) (mapcar 'cmp-unnorm-tp nat))
-	(setf (info-type info) nil)))
+      (let* (p
+	     (m (do ((a at (if (eq (car a) '*) a (cdr a)))
+		     (r args (cdr r))
+		     (f nargs (cdr f)))
+		    ((or (endp f) (endp a))
+		     (or f (and a (not (eq (car a) '*)))))
+		  (unless (or (eq '* (car a)) (type-and (car a) (info-type (cadar f))))
+		    (setq p t)))))
+	(when m
+	  (funcall (if (eq (symbol-package fn) #.(find-package 'cl)) 'cmpwarn 'cmpstyle-warn)
+		   "Wrong number of args in call to ~s:~% ~a ~a ~a~%"
+		   fn (cons fn args) (mapcar 'cmp-unnorm-tp at) (mapcar 'cmp-unnorm-tp nat)))
+	(when p
+	  (keyed-cmpnote
+	   (list fn 'inline)
+	   "inlining of ~a prevented due to argument type mismatch:~% ~a ~a ~a~%"
+	   fn (cons fn args) (mapcar 'cmp-unnorm-tp at) (mapcar 'cmp-unnorm-tp nat)))
+	(when (or p m)
+	  (setf (info-type info) nil))))
 
     (do ((a at (if (eq '* (car a)) a (cdr a)))
 	 (r args (cdr r))
@@ -1691,67 +1522,6 @@
 	((or (endp f) (endp a)) nargs)
 	(maybe-reverse-type-prop (car a) (car f)))))
 
-;; (defun make-c1forms (fn args last info)
-;;   (let* ((at (get-arg-types fn))
-;; 	 (nargs (c1args args info))
-;; 	 (c1l (when last (c1expr last)))
-;; 	 (nargs (if (when last (not (type>= #tnull (info-type (cadr c1l)))))
-;; 		    (progn (add-info info (cadr c1l)) (nconc nargs (list c1l)))
-;; 		  nargs))
-;; 	 (nat (mapcar (lambda (x) (info-type (cadr x))) nargs))
-;; 	 (ss (gethash fn *sigs*));FIXME?
-;; 	 (at (if (and ss (not (car ss))) nat at)))
-
-;;     (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
-;;       (when (do (p ;n
-;; 		 (a at (if (eq (car a) '*) a (cdr a)))
-;; 		 (r args (cdr r))
-;; 		 (f nargs (cdr f)))
-;; 		((or p (endp f) (endp a))
-;; 		 (or p f (and a (not (eq (car a) '*))))) ; (when (setq nargs (nreverse n)) nil)))
-;; 		(check-form-type (car a) (car f) (car r))
-;; 					;	      (push (and-form-type (or (car a) '*) (car f) (car r)) n)
-;; 		(setq p (when (info-type (cadar f)) (null (info-type (cadar f))))))
-;; 	(cmpwarn "inlining of ~a prevented due to argument type mismatch: ~a ~a~%" 
-;; 		 fn at nat)
-;; 	(setf (info-type info) nil)))
-
-;;     (do ((a at (if (eq '* (car a)) a (cdr a)))
-;; 	 (r args (cdr r))
-;; 	 (f nargs (cdr f)))
-;; 	((or (endp f) (endp a)) nargs)
-;; 	(maybe-reverse-type-prop (car a) (car f)))))
-
-;; (defun make-c1forms (fn args last info &aux (*provisional-inline* t))
-;;   (let* ((at (get-arg-types fn))
-;; 	 (nargs (c1args (append args (when last (list last))) info))
-;; 	 (nat (mapcar (lambda (x) (info-type (cadr x))) nargs))
-;; 	 (ss (gethash fn *sigs*));FIXME?
-;; 	 (at (if (and ss (not (car ss))) nat at)))
-
-;;     (mapc (lambda (x) (setf (info-type (cadr x)) (coerce-to-one-value (info-type (cadr x))))) nargs)
-
-;;     (unless (or (local-fun-p fn) (eq fn (cadr *current-form*)));FIXME
-;;       (when (do (p ;n
-;; 		 (a at (if (eq (car a) '*) a (cdr a)))
-;; 		 (r args (cdr r))
-;; 		 (f nargs (cdr f)))
-;; 		((or p (endp f) (endp a))
-;; 		 (or p f (and a (not (eq (car a) '*))))) ; (when (setq nargs (nreverse n)) nil)))
-;; 		(check-form-type (car a) (car f) (car r))
-;; 					;	      (push (and-form-type (or (car a) '*) (car f) (car r)) n)
-;; 		(setq p (when (info-type (cadar f)) (null (info-type (cadar f))))))
-;; 	(cmpwarn "inlining of ~a prevented due to argument type mismatch: ~a ~a~%" 
-;; 		 fn at nat)
-;; 	(setf (info-type info) nil)))
-
-;;     (do ((a at (if (eq '* (car a)) a (cdr a)))
-;; 	 (r args (cdr r))
-;; 	 (f nargs (cdr f)))
-;; 	((or (endp f) (endp a)) nargs)
-;; 	(maybe-reverse-type-prop (car a) (car f)))))
 
 (defun make-ordinary (fn &aux *c1exit*);FIXME *c1exit*
   (let* ((s (sgen "ORDS"))(g (sgen "ORDG"))
@@ -1920,7 +1690,7 @@
       (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)))))
 	 (keyed-cmpnote (list fun 'nil-arg)
-			"Setting return type on call to ~s to nil due to nil-typed form ~s"
+			"Setting return type on call to ~s to nil due to nil-typed form:~%~s"
 			fun x)
 	 (setf (info-type info) nil))
 	(last)
@@ -1969,102 +1739,38 @@
 ;; 	(foo (gethash (car (atomic-tp (info-type (cadr ff)))) *fun-ev-hash*))))
 ;  (when (member (car ff) '(foo location)) (gethash (car (atomic-tp (info-type (cadr ff)))) *fun-ev-hash*)))
 
-(defun mi1c (fun args last info &optional ff prov &aux (*in-inline* t)(*prov* prov))
+(defun mi1c (fun args last info &optional ff prov &aux (*prov* prov))
 
   (let* ((otp (info-type info))
 	 (fms (make-c1forms fun args last info))
 	 (last (when (and last (nth (length args) fms)) last))
-	 (tp (type-from-args fun fms last info))
-	 (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun))))))
-    (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last))))
+	 (tp (type-from-args fun fms last info)))
+    (or
+     (when (or tp (eq otp tp))
+       (mi2 fun args last fms (ff-env (or ff fun))))
+     (when (member-if-not 'identity fms :key (lambda (x) (info-type (cadr x))))
+       (c1progn args fms))
+     (mi5 (or (when (symbolp fun) fun) ff) info fms last))))
+
 
+(defvar *prov-src* nil)
 
-(defun mi1b (fun args last info &optional ff)
+(defun mi1b (fun args last info &optional ff &aux (ops *prov-src*)(*prov-src* *prov-src*))
   (with-restore-vars
    (let ((res (mi1c fun args last info ff t)))
      (cond ((iflag-p (info-flags (cadr res)) provisional)
 	    (keyed-cmpnote 'provisional "~s has provisional functions, res address ~s" fun (address res)))
-	   (t (keep-vars) res)))))
+	   (t (keep-vars) (mapc 'eliminate-src (ldiff *prov-src* ops)) res)))))
 
 (defun mi1a (fun args last info &optional ff &aux (i1 (copy-info info)));FIXME side-effects on info
   (or (mi1b fun args last info ff)
       (prog1 (mi1c fun args last i1 ff)
 	(setf (info-type info) (info-type i1)))))
 
-;; (defun mi1a (fun args last info &optional ff &aux (*in-inline* t))
-
-;;   (let* ((otp (info-type info))
-;; 	 (fms (make-c1forms fun args last info))
-;; 	 (last (when (and last (nth (length args) fms)) last))
-;; 	 (tp (type-from-args fun fms last info))
-;; 	 (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun))))))
-;;     (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last))))
-
-;; (defun mi1a (fun args last info &aux (*in-inline* t))
-
-;;   (let* ((af (member fun '(apply funcall)))
-;; 	 (ff (when af (c1arg (pop args) info)))
-;; 	 (fun (if ff (coerce-ff ff) fun));FIXME, e.g. when funcall
-;; 	 (otp (info-type info))
-;; 	 (fms (make-c1forms fun args last info))
-;; 	 (last (when (and last (nth (length args) fms)) last))
-;; 	 (tp (type-from-args fun fms last info))
-;; 	 (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun))))))
-;;     (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last))))
-
-;; (defun mi1a (fun args last info &aux (*in-inline* t))
-
-;;   (let* ((af (member fun '(apply funcall)))
-;; 	 (ff (when af (c1expr (pop args))))
-;; 	 (fun (if ff (coerce-ff ff) fun));FIXME, e.g. when funcall
-;; 	 (otp (info-type info))
-;; 	 (fms (make-c1forms fun args last info))
-;; 	 (last (when (and last (nth (length args) fms)) last))
-;; 	 (tp (type-from-args fun fms last info))
-;; 	 (inl (when (or tp (eq otp tp)) (mi2 fun args last fms (ff-env (or ff fun))))))
-;;     (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last))))
-
-;; (defun mi1a (fun args last info &aux (*in-inline* t) *provisional-inline*)
-
-;;   (let* ((fms (make-c1forms fun args last info))
-;; 	 (af (member fun '(apply funcall)))
-;; 	 (args (if af (cdr args) args))
-;; 	 (ff (when af (pop fms)))
-;; 	 (fun (if ff (coerce-ff ff) fun))
-;; 	 (tp (type-from-args fun fms last info))
-;; 	 (inl (when tp (mi2 fun args last fms (ff-env ff)))))
-;;     (or (uui inl) (mi5 (or (when (symbolp fun) fun) (uu ff)) info (uu fms) last))))
-
-;; (defun mi1a (fun args last info &aux (*in-inline* t))
-
-;;   (let* ((fms (make-c1forms fun args last info))
-;; 	 (af (member fun '(apply funcall)))
-;; 	 (args (if af (cdr args) args))
-;; 	 (ff (when af (pop fms)))
-;; 	 (fun (if ff (coerce-ff ff) fun))
-;; 	 (tp (type-from-args fun fms last info))
-;; 	 (inl (when tp (mi2 fun args last fms (ff-env ff)))))
-;;     (uu (or inl (mi5 (or (when (symbolp fun) fun) ff) info fms last)))))
-
-
-
-;; (defun unprovfn (f &optional b fun &aux (args (pop f)) (env (caar f)))
-;;   (under-env env (c1function args nil b fun)))
-;; (defun unfoo (f)
-;;   (c1function (caddr f) nil (cadddr f)))
 
 (defun current-env nil (list *lexical-env-mask* *vars* *blocks* *tags* *funs*))
 
 
-;; (defun uu (f)
-;;   (cond ((atom f) f)
-;; 	((eq (car f) 'provfn) (unprovfn (cddr f)))
-;; 	((setf (car f) (uu (car f)) (cdr f) (uu (cdr f)) f f))))
-;; (defun uu (f)
-;;   (cond ((atom f) f)
-;; 	((eq (car f) 'foo) (unfoo f))
-;; 	((let* ((a (car f))(d (cdr f)) (ua (uu a))(ud (uu d)))
-;; 	   (if (and (eq a ua) (eq d ud)) f (cons ua ud))))))
 
 (defun mi1 (fn args &optional last ff)
   (let* ((tp (get-return-type fn))
@@ -2080,61 +1786,42 @@
 	(setf (info-type (cadr res)) (type-and t1 (if (type= t1 t2) tp t2)))))
     res))
 
-;; (defun mi1 (fn args &optional last)
-;;   (let* ((tp (get-return-type fn))
-;; 	 (sp (if (get fn 'no-sp-change) 0 1))
-;; 	 (info (make-info :type tp :sp-change sp))
-;;  	 (res (mi1a fn args last info)))
-;;     (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) #t(member t)))))
-;; 		  (setq t1 (tb t1) t2 (tb t2))))
-;; 	(setf (info-type (cadr res)) (type-and t1 t2))))
-;;     res))
-
-;; (defun mi1 (fn args &optional last)
-;;   (let* ((tp (get-return-type fn))
-;; 	 (sp (if (get fn 'no-sp-change) 0 1))
-;; 	 (info (make-info :type tp :sp-change sp))
-;;  	 (res (mi1a fn args last info)))
-;;     (when tp (setf (info-type (cadr res)) (type-and (info-type info) (info-type (cadr res)))));FIXME
-;;     res))
-
-;; (defun mi1 (fn args &optional last)
-;;   (let* ((tp (get-return-type fn))
-;; 	 (sp (if (get fn 'no-sp-change) 0 1))
-;; 	 (info (make-info :type tp :sp-change sp))
-;; 	 (res (mi1a fn args last info)))
-;;     (setf (info-type (cadr res)) (type-and (info-type info) (info-type (cadr res))))
-;;     res))
 
-(defun local-fun-p (fname)
+(defun local-fun-obj (fname)
   (typecase fname
     (function (fn-get fname 'fun))
     (fun fname)
-    (symbol (car (member-if (lambda (x) (when (fun-p x) (when (eq fname (fun-name x)) (not (member x *lexical-env-mask*))))) *funs*)))))
-
-(defun cmp-expand-macro-w (fd x)
-  (macroexpand-helper
-   (and *record-call-info* (add-macro-callee (car x)))
-   `(funcall *macroexpand-hook* ',fd ',x ',*macrolet-env*)
-   x))
+    (symbol (car (member-if (lambda (x)
+			      (when (fun-p x)
+				(unless (member x *lexical-env-mask*)
+				  (eq fname (fun-name x)))))
+			    *funs*)))))
+
+(defun local-fun-p (fname &aux (fun (local-fun-obj fname)))
+  (when (and fun (fun-src fun)) fun))
+
+(defun local-macro-p (fname &aux (fun (local-fun-obj fname)))
+  (when fun (unless (fun-src fun) fun)))
+
+(defun funs-to-macrolet-env nil
+  `(nil ,(mapcan (lambda (x)
+		   (when (fun-p x)
+		     (unless (member x *lexical-env-mask*)
+		       `(,(if (fun-src x) `(,(fun-name x) function ,(lambda (&rest r) (declare (ignore r)) nil)) `(,(fun-name x) macro ,(fun-fn x)))))))
+		 *funs*)
+	nil))
 
 (defun c1symbol-fun (whole &aux (fname (car whole)) (args (cdr whole)) fd)
   (values
    (cond ((setq fd (get fname 'c1special)) (funcall fd args))
 	 ((and (setq fd (get fname 'co1special)) (funcall fd fname args)))
-	 ((setq fd (caddar (member fname (cadr *macrolet-env*) :key 'car)))
-	  (c1expr (cmp-expand-macro-w fd whole)));FIXME scope level with local funs
+	 ((setq fd (local-macro-p fname))
+	  (c1expr (cmp-expand-macro-w (fun-fn fd) whole)))
 	 ((local-fun-p fname) (mi1 fname args))
-	 ((let ((fn (get fname 'si::compiler-macro-prop)) (res (cons fname args)))
-	    (and fn
-		 (not (member fname *notinline*))
-		 (let ((fd (funcall fn res nil)));(cmp-eval `(funcall ',fn ',res nil))))
-		   (and (not (eq res fd))
-			(c1expr fd))))))
+	 ((unless (member fname *notinline*)
+	    (let* ((fn (compiler-macro-function fname))
+		   (res (if fn (funcall fn whole nil) whole)));FIXME cmp-expand-macro-w?
+	      (unless (eq whole res) (c1expr res)))))
 	 ((and (setq fd (get fname 'co1))
 	       (inline-possible fname)
 	       (funcall fd fname args)))
@@ -2236,9 +1923,10 @@
 ;; 	   (list 'progn info (nreverse fl))))))
 
 
-(defun truncate-progn-at-nil-return-p (rp forms)
+(defun truncate-progn-at-nil-return-p (rp forms c1forms)
   (when (and rp (not (info-type (cadar rp))))
     (keyed-cmpnote 'nil-return "progn truncated at nil return, eliminating ~s" forms)
+    (eliminate-src (cons 'progn (nthcdr (length c1forms) forms)))
     t))
 
 
@@ -2247,7 +1935,7 @@
   (flet ((collect (f i)
 	   (setq rp (last (if rp (rplacd rp f) (setq r f))))
 	   (add-info info i)))
-    (do ((forms forms (cdr forms))) ((or (not forms) (truncate-progn-at-nil-return-p rp forms)))
+    (do ((forms forms (cdr forms))) ((or (not forms) (truncate-progn-at-nil-return-p rp forms c1forms)))
       (let ((form (or (pop c1forms) (if (cdr forms) (c1arg (car forms)) (c1expr (car forms))))))
 	(cond ((and (cdr forms) (ignorable-form form)))
 	      ((eq (car form) 'progn) (collect (third form) (cadr form)))
@@ -2255,59 +1943,10 @@
     (cond ((cdr r)
 	   (setf (info-type info) (info-type (cadar rp)))
 	   (list 'progn info r))
-	  ((car r))
+	  ((the list (car r)));FIXME
 	  ((c1nil)))))
 
 
-;; (defun c1progn (forms &aux r rp)
-;;   (cond ((endp forms) (c1nil))
-;; 	((endp (cdr forms)) (c1expr (car forms)))
-;; 	((let ((info (make-info)))
-;; 	   (flet ((collect 
-;; 		   (f i) 
-;; 		   (setq rp (last (if rp (rplacd rp f) (setq r f))))
-;; 		   (add-info info i)))
-;; 		 (do ((forms forms (cdr forms))) ((not forms))
-;; 		     (let ((form (if (cdr forms) (c1arg (car forms)) (c1expr (car forms)))))
-;; 		       (cond ((and (cdr forms) (ignorable-form form)))
-;; 			     ((eq (car form) 'progn) (collect (third form) (cadr form)))
-;; 			     ((collect (cons form nil) (cadr form))))))
-;; 		 (cond ((cdr r)
-;; 			(setf (info-type info) (info-type (cadar rp)))
-;; 			(list 'progn info r))
-;; 		       ((car r))
-;; 		       ((c1nil))))))))
-
-;; (defun c1progn (forms &aux r rp)
-;;   (cond ((endp forms) (c1nil))
-;; 	((endp (cdr forms)) (c1expr (car forms)))
-;; 	((let ((info (make-info)))
-;; 	   (flet ((collect 
-;; 		   (f i) 
-;; 		   (setq rp (last (if rp (rplacd rp f) (setq r f))))
-;; 		   (add-info info i)))
-;; 		 (do ((forms forms (cdr forms))) ((not forms))
-;; 		     (let* ((*c1exit* (unless (cdr forms) *c1exit*))
-;; 			    (form (c1expr (car forms))))
-;; 		       (cond ((and (cdr forms) (ignorable-form form)))
-;; 			     ((eq (car form) 'progn) (collect (third form) (cadr form)))
-;; 			     ((collect (cons form nil) (cadr form))))))
-;; 		 (cond ((cdr r)
-;; 			(setf (info-type info) (info-type (cadar rp)))
-;; 			(list 'progn info r))
-;; 		       ((car r))
-;; 		       ((c1nil))))))))
-
-;(defun c1progn (forms &aux (fl nil))
-;  (let ((info (make-info)))
-;    (dolist (form forms)
-;      (setq form (c1expr form))
-;      (push form fl)
-;      (add-info info (cadr form)))
-;    (unless fl (push (c1nil) fl))
-;    (setf (info-type info) (info-type (cadar fl)))
-;    (list 'progn info (reverse fl))))
-
 ;;; Should be deleted.
 (defun c1progn* (forms info)
   (setq forms (c1progn forms))
@@ -2765,7 +2404,7 @@
   form)
 
 
-(define-compiler-macro typep (&whole form &rest args)
+(define-compiler-macro typep (&whole form &rest args);FIXME compiler-in-use
   (with-restore-vars
    (let* ((info (make-info))
 	  (nargs (c1args args info))
@@ -2781,7 +2420,7 @@
 	   (form)))));FIXME hash here
 
 
-(define-compiler-macro vector-push-extend (&whole form &rest args)
+(define-compiler-macro vector-push-extend (&whole form &rest args);FIXME compiler-in-use
   (let* ((vref (when (symbolp (cadr args)) (c1vref (cadr args))));FIXME local-aliases
 	 (var (car vref)))
     (when vref
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpflet.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpflet.lsp
@@ -98,13 +98,14 @@
 				      (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp))
 		       (setf (var-type v) tp (var-store v) st))
 		     (ldiff-nf *restore-vars* ,rv))))
-	     (prog1
-		 (let (*restore-vars* (*restore-vars-env* *vars*))
-		   (unwind-protect (progn ,@body) (pop-restore-vars)))
-	       (mapc (lambda (l)
-		       (when (member (car l) *restore-vars-env*)
-			 (pushnew l *restore-vars* :key 'car)))
-		     ,rv)))))
+       (declare (ignorable #'keep-vars))
+       (prog1
+	   (let (*restore-vars* (*restore-vars-env* *vars*))
+	     (unwind-protect (progn ,@body) (pop-restore-vars)))
+	 (mapc (lambda (l)
+		 (when (member (car l) *restore-vars-env*)
+		   (pushnew l *restore-vars* :key 'car)))
+	       ,rv)))))
 
 
 (defun ref-environment (&aux inner)
@@ -160,39 +161,9 @@
 (defun ref-funs (form funs)
   (ref-obs form funs 
 	   (lambda (x) (setf (fun-ref-ccb x) t))
-	   (lambda (x))
+	   (lambda (x) (declare (ignore x)))
 	   (lambda (x) (setf (fun-ref x) t))))
 
-;; (defun ref-funs1 (form funs &aux (i (cadr form)))
-;;   (dolist (fun funs)
-;;     (when (member fun (info-fref-ccb i))
-;;       (setf (fun-ref-ccb fun) t))
-;;     (when (member fun (info-fref i))
-;;       (setf (fun-ref fun) t))))
-
-;; (defun ref-funs (form funs &optional l)
-;;   (cond ((not l) 
-;; 	 (cond (*fast-ref* (ref-funs1 form funs))
-;; 	       ((let* ((l (list (info-fref (cadr form)) (info-fref-ccb (cadr form))))
-;; 		       (l (mapcar (lambda (x) (intersection x funs)) l))
-;; 		       (l (mapcar (lambda (y) (mapcar (lambda (x) (cons x nil)) y)) l)))
-;; 		  (ref-funs form funs l)
-;; 		  (let* (y (x (member-if (lambda (x) (setq y (member nil x :key 'cdr))) l)))
-;; 		    (when y
-;; 		      (cmpwarn "~s Fun ~s reffed in info but not in form" (length (ldiff l x)) (var-name (caar y)))))))))
-;; 	((atom form))
-;; 	((eq (car form) 'call-local)
-;; 	 (let* ((fref (caddr form))
-;; 		(f (pop fref))
-;; 		(ccb (car fref)))
-;; 	   (when (member f funs)
-;; 	     (if ccb (setf (fun-ref-ccb f) t) (setf (fun-ref f) t))
-;; 	     (let* ((x (if ccb (cadr l) (car l)))(x (assoc f x)))
-;; 	       (if x (rplacd x t) (cmpwarn "~a Fun ~s reffed in form but not in info" (if ccb "ccb" "nil") (fun-name f))))
-;; 	     (keyed-cmpnote (list 'fun-ref (fun-name f)) "Fun ~s is referred with barrier ~s" (fun-name f) (when ccb 'cb)))
-;; 	   (ref-funs (cdddr form) funs l)))
-;; 	(t (ref-funs (car form) funs l) (ref-funs (cdr form) funs l))))
-
 (defun effective-safety-src (src &aux (n (pop src))(ll (pop src)))
   (multiple-value-bind
    (doc decls ctps body)
@@ -205,7 +176,7 @@
 (defvar *local-fun-inline-limit* 200)
 
 (defun c1flet-labels (labels args &aux body ss ts is other-decl (info (make-info))
-			     defs1 fnames (ofuns *funs*) (*funs* *funs*))
+			     defs1 fnames (ofuns *funs*) (*funs* *funs*)(*top-level-src* *top-level-src*))
 
   (when (endp args) (too-few-args 'flet 1 0))
 
@@ -216,7 +187,7 @@
       (cmpck (member (car def) fnames) "The function ~s was already defined." (car def))
       (push (car def) fnames))
     (let* ((def (effective-safety-src def))
-	   (src (si::block-lambda (cadr def) (car def) (cddr def)))
+	   (src (mark-toplevel-src (si::block-lambda (cadr def) (car def) (cddr def))))
 	   (fun (make-fun :name (car def) :src src :info (make-info :type nil :flags (iflags sp-change)))))
       (push fun *funs*)
       (unless (< (cons-count src) *local-fun-inline-limit*)
@@ -232,7 +203,7 @@
   (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
   
   (c1add-globals ss)
-  (check-vdecl nil ts is)
+  (check-vdecl (mapcar (lambda (x) `(function ,(fun-name (car x)))) defs1) ts is)
   (setq body (c1decl-body other-decl body))
   
   (let ((nf (mapcar 'car defs1)))
@@ -248,6 +219,8 @@
   (add-info info (cadr body))
   (setf (info-type info) (info-type (cadr body)))
 
+  (mapc (lambda (x &aux (x (car x))) (unless (or (fun-ref x) (fun-ref-ccb x)) (eliminate-src (fun-src x)))) defs1)
+
   (let* ((funs (mapcar 'car defs1))
 	 (fns (mapcar (lambda (x) (caddr (fun-c1   x))) (remove-if-not 'fun-ref funs)))
 	 (cls (mapcar (lambda (x) (caddr (fun-c1cb x))) (remove-if-not 'fun-ref-ccb funs))))
@@ -317,17 +290,16 @@
 
 (defvar *macrolet-env* nil)
 
-(defun c1macrolet (args &aux body ss ts is other-decl env
-                        (*funs* *funs*) (*vars* *vars*) (*macrolet-env* *macrolet-env*))
-  (when (endp args) (too-few-args 'macrolet 1 0))
-  (dolist (def (car args))
-    (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def)))))
-    (cmpck (or (endp def) (endp (cdr def)))
+(defun push-macrolet-env (defs)
+  (dolist (def defs)
+    (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
            "The macro definition ~s is illegal." def)
-    (let* ((n (car def))
-	   (b (eval (si::defmacro-lambda n (cadr def) (cddr def)))))
-      (push (list n 'macro b) env)))
-  (when env (setq *macrolet-env* (list nil (append (cadr *macrolet-env*) (nreverse env)) nil)))
+    (push (make-fun :name (car def) :fn (eval (si::defmacro-lambda (pop def) (pop def) def)))
+	  *funs*)))
+
+(defun c1macrolet (args &aux body ss ts is other-decl (*funs* *funs*))
+  (when (endp args) (too-few-args 'macrolet 1 0))
+  (push-macrolet-env (car args))
   (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
   (c1add-globals ss)
   (check-vdecl nil ts is)
@@ -414,14 +386,14 @@
 		 (keyed-cmpnote (list (fun-name fun) 'local) "returning trial value for local fun ~s" key)
 		 (pushnew *fun-stack* (fourth tmp))
 		 (fifth tmp))
-		((let* ((i (keyed-cmpnote (list (fun-name fun) 'local) "processing local fun ~s" key))
+		((let* ((ii (keyed-cmpnote (list (fun-name fun) 'local) "processing local fun ~s" key))
 			(*fun-stack* (cons (fun-stack key prev) *fun-stack*))
 			(res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun)))
 			(fun-stack-prev (pop *fun-stack*))
 			(recursive-p (fourth fun-stack-prev))
 			(i (cadr res))
 			(callees (all-callees i)))
-		   (declare (ignore i))
+		   (declare (ignore ii))
 		   (when recursive-p
 		     (setf (info-flags (fun-info fun)) (logior (info-flags (fun-info fun)) (iflags compiler))))
 		   (cond ((iflag-p (info-flags i) provisional)
@@ -441,137 +413,11 @@
 			  (set fun res))))))))
 
 
-;; (defun make-fun-c1 (fun ccb env &optional osig
-;; 			&aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))) tmp (*fun-stack* (cons (cons fun ccb) *fun-stack*)))
 
-;;   (labels ((set                 (fun val)      (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val)))
-;; 	   (ifunp               (key pred l)   (car (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l)))
-;; 	   (ifunm               (pred i)       (or  (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i))))
-;; 	   (calls-blocked-fun-p (fun i)        (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i))
-;; 	   (unfinished-p        (fun i)        (ifunm (lambda (x y) (not y)) i))
-;; 	   (blocked-above       nil            (member-if (lambda (x &aux (y (pop x))) (eq t (if x (fun-c1cb y) (fun-c1 y)))) (cdr *fun-stack*))))
-;; ;	   (recursive-p         (fun i)        (ifunm (lambda (x y) (when y (eq x fun))) i)))
-	  
-;; 	  (cond ((eq c1 t) 
-;; 		 (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun))
-;; 		 nil)
-;; 		((unless osig c1))
-;; 		((let* ((c1 (or c1 (set fun t)))
-;; 			(res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun)))
-;; 			(i (cadr res))
-;; 			(sig (car (fun-call fun))))
-;; 		   (cond ((setq tmp (calls-blocked-fun-p fun i))
-;; 			  (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs ~s" (fun-name fun) tmp)
-;; 			  (set fun nil))
-;; 			 ((setq tmp (unfinished-p fun i))
-;; 			  (cond ((blocked-above)
-;; 				 (keyed-cmpnote (list (fun-name fun) 'recursion) "setting unfinished fun ~s to nil, ufun ~s" (fun-name fun) tmp)
-;; 				 (set fun nil))
-;; 				((eq c1 t)
-;; 				 (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing unfinished local fun ~s: ~s" (fun-name fun) tmp)
-;; 				 (set fun res)
-;; 				 (make-fun-c1 fun ccb env sig))
-;; 				((set fun res) )))
-;; 			 ;; ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump?
-;; 			 ;;  (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig)
-;; 			 ;;  (set fun res)
-;; 			 ;;  (make-fun-c1 fun ccb env sig))
-;; 			 ((set fun res))))))))
-
-;; (defun make-fun-c1 (fun ccb env &optional osig
-;; 			&aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))) tmp (*fun-stack* (cons (cons fun ccb) *fun-stack*)))
-
-;;   (labels ((set                 (fun val)      (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val)))
-;; 	   (ifunp               (key pred l)   (car (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l)))
-;; 	   (ifunm               (pred i)       (or  (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i))))
-;; 	   (calls-blocked-fun-p (fun i)        (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i))
-;; 	   (unfinished-p        (fun i)        (ifunm (lambda (x y) (not y)) i))
-;; 	   (blocked-above       nil            (member-if (lambda (x &aux (y (pop x))) (eq t (if x (fun-c1cb y) (fun-c1 y)))) (cdr *fun-stack*)))
-;; 	   (recursive-p         (fun i)        (ifunm (lambda (x y) (when y (eq x fun))) i)))
-	  
-;; 	  (cond ((eq c1 t) 
-;; 		 (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun))
-;; 		 nil)
-;; 		((unless osig c1))
-;; 		((let* ((c1 (or c1 (set fun t)))
-;; 			(res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun)))
-;; 			(i (cadr res))
-;; 			(sig (car (fun-call fun))))
-;; 		   (cond ((setq tmp (calls-blocked-fun-p fun i))
-;; 			  (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs ~s" (fun-name fun) tmp)
-;; 			  (set fun nil))
-;; 			 ((setq tmp (unfinished-p fun i))
-;; 			  (cond ((blocked-above)
-;; 				 (keyed-cmpnote (list (fun-name fun) 'recursion) "setting unfinished fun ~s to nil, ufun ~s" (fun-name fun) tmp)
-;; 				 (set fun nil))
-;; 				((eq c1 t)
-;; 				 (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing unfinished local fun ~s: ~s" (fun-name fun) tmp)
-;; 				 (set fun res)
-;; 				 (make-fun-c1 fun ccb env sig))
-;; 				((set fun res) )))
-;; 			 ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump?
-;; 			  (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig)
-;; 			  (set fun res)
-;; 			  (make-fun-c1 fun ccb env sig))
-;; 			 ((set fun res))))))))
-
-;; (defun make-fun-c1 (fun ccb env &optional osig &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))))
-
-;;   (labels ((set                 (fun val)          (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val)))
-;; 	   (ifunp               (key pred l)       (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x)))) l))
-;; 	   (ifunm               (pred i)           (or  (ifunp 'fun-c1 pred (info-ref i)) (ifunp 'fun-c1cb pred (info-ref-ccb i))))
-;; 	   (calls-blocked-fun-p (fun i)            (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i))
-;; 	   (recursive-p         (fun i)            (ifunm (lambda (x y) (or (not y) (eq x fun))) i)))
-
-;; 	  (cond ((eq c1 t) 
-;; 		 (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun))
-;; 		 nil)
-;; 		((unless osig c1) c1)
-;; 		((let* ((c1 (or c1 (set fun t)))
-;; 			(res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun)))
-;; 			(i (cadr res))
-;; 			(sig (car (fun-call fun))))
-;; 		   (declare (ignore c1));FIXME
-;; 		   (cond ((calls-blocked-fun-p fun i) 
-;; 			  (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs" (fun-name fun))
-;; 			  (set fun nil))
-;; 			 ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump?
-;; 			  (set fun res)
-;; 			  (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig)
-;; 			  (make-fun-c1 fun ccb env sig))
-;; 			 ((set fun res))))))))
-
-;; (defun make-fun-c1 (fun ccb env &optional osig &aux (c1 (if ccb (fun-c1cb fun) (fun-c1 fun))))
-
-;;   (labels ((set                 (fun val)          (if ccb (setf (fun-c1cb fun) val) (setf (fun-c1 fun) val)))
-;; 	   (ifunp               (key pred fun l)   (member-if (lambda (x) (when (fun-p x) (funcall pred x (funcall key x) fun))) l))
-;; 	   (ifunm               (pred fun i)       (or  (ifunp 'fun-c1 pred fun (info-ref i)) (ifunp 'fun-c1cb pred fun (info-ref-ccb i))))
-;; ;	   (calls-blocked-fun-p (fun i)            (ifunm (lambda (x y) (unless (eq x fun) (eq y t))) i)) FIXME
-;; 	   (calls-blocked-fun-p (fun i)            (ifunm (lambda (x y z) (unless (eq x z) (eq y t))) fun i))
-;; 	   (recursive-p         (fun i)            (ifunm (lambda (x y z) (or (not y) (eq x z))) fun i)))
-
-;; 	  (cond ((eq c1 t) 
-;; 		 (keyed-cmpnote (list (fun-name fun) 'recursion) "recursive call to local fun ~s" (fun-name fun))
-;; 		 nil)
-;; 		((unless osig c1) c1)
-;; 		((let* ((c1 (or c1 (set fun t)))
-;; 			(res (under-env env (c1function (list (fun-src fun)) (if ccb 'cb 'lb) fun)))
-;; 			(i (cadr res))
-;; 			(sig (car (fun-call fun))))
-;; 		   (declare (ignore c1));FIXME
-;; 		   (cond ((calls-blocked-fun-p fun i) 
-;; 			  (keyed-cmpnote (list (fun-name fun) 'recursion) "local fun ~s calls unfinalized funs" (fun-name fun))
-;; 			  (set fun nil))
-;; 			 ((when (recursive-p fun i) (not (eq (cadr osig) (cadr sig))));FIXME bump?
-;; 			  (set fun res)
-;; 			  (keyed-cmpnote (list (fun-name fun) 'recursion) "reprocessing recursive local fun ~s: ~s ~s" (fun-name fun) osig sig)
-;; 			  (make-fun-c1 fun ccb env sig))
-;; 			 ((set fun res))))))))
-
-(defun c1local-fun (fname &optional cl &aux ccb inner)
+(defun c1local-fun (fname &optional cl &aux ccb inner (lf (local-fun-p fname)))
   (dolist (fun *funs*)
     (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun)))
-	  ((when (eq (fun-name fun) fname) (not (member fun *lexical-env-mask*)))
+	  ((eq fun lf)
 	   (let* ((cl (or ccb cl))
 		  (env (fn-get (fun-fn fun) 'df))
 		  (fm (make-fun-c1 fun cl env))
@@ -582,82 +428,6 @@
 	     (when c1fv (add-info info (cadr c1fv)))
 	     (return (list 'call-local info (list fun cl ccb) c1fv fm)))))))
 
-;; (defun c1local-fun (fname &optional cl &aux ccb inner)
-;;   (dolist (fun *funs*)
-;;     (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun)))
-;; 	  ((eq (fun-name fun) fname)
-;; 	   (let* ((cl (or ccb cl))
-;; 		  (env (fn-get (fun-fn fun) 'df))
-;; 		  (fm (make-fun-c1 fun cl env))
-;; 		  (lam (cadr (caddr fm)))
-;; 		  (info (if lam (copy-info (cadr lam)) (make-info)))
-;; 		  (c1fv (when ccb (c1inner-fun-var))));FIXME fm
-;; 	     (setf (info-type info) (cadar (fun-call fun)));FIXME
-;; 	     (if cl (pushnew fun (info-ref-ccb info)) (pushnew fun (info-ref info)))
-;; 	     (when c1fv (add-info info (cadr c1fv)))
-;; 	     (return (list 'call-local info (list fun cl ccb) c1fv lam)))))))
-
-;; (defun c1local-fun (fname &optional cl &aux ccb inner)
-;;   (dolist (fun *funs*)
-;;     (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun)))
-;; 	  ((eq (fun-name fun) fname)
-;; 	   (let* ((cl (or ccb cl))
-;; 		  (env (fn-get (fun-fn fun) 'df))
-;; 		  (fm (if cl (make-local-fun fun-c1cb cb fun env) (make-local-fun fun-c1 lb fun env)))
-;; 		  (lam (cadr (caddr fm)))
-;; 		  (info (if lam (copy-info (cadr lam)) (make-info)))
-;; 		  (c1fv (when ccb (c1inner-fun-var))));FIXME fm
-;; 	     (setf (info-type info) (cadar (fun-call fun)));FIXME
-;; 	     (if cl (pushnew fun (info-ref-ccb info)) (pushnew fun (info-ref info)))
-;; 	     (when c1fv (add-info info (cadr c1fv)))
-;; 	     (return (list 'call-local info (list fun cl ccb) c1fv lam)))))))
-
-;; (defun c1local-fun (fname &optional cl &aux ccb inner)
-;;   (dolist (fun *funs*)
-;;     (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun)))
-;; 	  ((eq (fun-name fun) fname)
-;; 	   (let* ((cl (or ccb cl))
-;; 		  (env (fn-get (fun-fn fun) 'df))
-;; 		  (fm (if cl (make-local-fun fun-c1cb cb fun env) (make-local-fun fun-c1 lb fun env)))
-;; 		  (lam (cadr (caddr fm)))
-;; 		  (info (if lam (copy-info (cadr lam)) (make-info)))
-;; 		  (c1fv (when ccb (c1inner-fun-var))));FIXME fm
-;; 	     (setf (info-type info) (cadar (fun-call fun)));FIXME
-;; 	     (if cl (pushnew fun (info-fref-ccb info)) (pushnew fun (info-fref info)))
-;; 	     (when c1fv (add-info info (cadr c1fv)))
-;; 	     (return (list 'call-local info (list fun cl ccb) c1fv lam)))))))
-
-;; (defun c1local-fun (fname &optional cl &aux ccb inner)
-;;   (macrolet ((pf (fun ref c1 b) 
-;; 		 `(unless (,ref ,fun) 
-;; 		    (setf (,ref ,fun) t)
-;; 		    (when (eq (car (,c1 ,fun)) 'provfn)
-;; 		      (unprovfn (,c1 ,fun) ,b ,fun)))))
-;; 	    (dolist (fun *funs*)
-;; 	      (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun)))
-;; 		    ((eq (fun-name fun) fname)
-;; 		     (cond ((or ccb cl)
-;; 			    (ref-inner inner) 
-;; 			    (pf fun fun-ref-ccb fun-c1cb 'cb))
-;; 			   ((pf fun fun-ref fun-c1 'lb)))
-;; 		     (setf (info-type (fun-info fun)) (cadar (fun-call fun)))
-;; 		     (return (list 'call-local (fun-info fun) (list fun ccb))))))))
-
-;; (defun c1local-fun (fname &optional cl &aux ccb inner)
-;;   (macrolet ((pf (fun ref c1 b &aux (s (tmpsym))) 
-;; 		 `(let ((,s (fun-prov ,fun)))
-;; 		    (unless (,ref ,fun) 
-;; 		      (setf (,ref ,fun) t
-;; 			    (,c1 ,fun) (process-local-fun-env (fourth ,s) ,b ,fun (fun-src ,fun) (info-type (cadr ,s))))))))
-;; 	    (dolist (fun *funs*)
-;; 	      (cond ((not (fun-p fun)) (setq ccb (or (eq fun 'cb) ccb) inner (or inner fun)))
-;; 		    ((eq (fun-name fun) fname)
-;; 		     (cond ((or ccb cl)
-;; 			    (ref-inner inner) 
-;; 			    (pf fun fun-ref-ccb fun-c1cb 'cb))
-;; 			   ((pf fun fun-ref fun-c1 'lb)))
-;; 		     (setf (info-type (fun-info fun)) (cadar (fun-call fun)))
-;; 		     (return (list 'call-local (fun-info fun) (list fun ccb))))))))
 
 
 (defun sch-local-fun (fname)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpfun.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpfun.lsp
@@ -156,71 +156,28 @@
       (list* (car all) (car (last all)) (butlast (cdr all)))))
     (close-inline-blocks)))
 
-;; (defun c1apply-optimize (info requireds rest body args
-;;                               &aux (vl nil) (fl nil))
-;;   (do ()
-;;       ((or (endp (cdr args)) (endp requireds)))
-;;       (push (pop requireds) vl)
-;;       (push (pop args) fl))
-
-;;   (cond ((cdr args)	;;; REQUIREDS is NIL.
-;;          (cmpck (null rest)
-;;                 "APPLY passes too many arguments to LAMBDA expression.")
-;;          (push rest vl)
-;;          (push (list 'call-global info 'list* args) fl)
-;;          (list 'let info (reverse vl) (reverse fl) body))
-;;         (requireds	;;; ARGS is singleton.
-;;          (let ((temp (make-var :kind 'LEXICAL :ref t)))
-;;               (push temp vl)
-;;               (push (car args) fl)
-;;               (list 'let info (reverse vl) (reverse fl)
-;;                     (list 'apply-optimize
-;;                           (cadr body) temp requireds rest body))))
-;;         (rest (push rest vl)
-;;               (push (car args) fl)
-;;               (list 'let info (reverse vl) (reverse fl) body))
-;;         (t
-;;          (let ((temp (make-var :kind 'LEXICAL :ref t)))
-;;               (push temp vl)
-;;               (push (car args) fl)
-;;               (list 'let info (reverse vl) (reverse fl)
-;;                     (list 'apply-optimize
-;;                           (cadr body) temp requireds rest body))))
-;;         )
-;;   )
-
-
-;; c2apply alters argument order
-(let ((l (gensym "LV")))
-  (defun apply-bind (form args &aux (la (car (last args))))
-    (if (eq l la)
-	form
-      (let* ((b (mapcar (lambda (x) (list (gensym) x)) (butlast args)))
-	     (v (mapcar 'car b)))
-	`(let (,@b (,l ,la))
-	   (apply ,@v ,l))))))
-
-(defun fn-bind (form args)
-  (if (or (symbolp (car args)) (constantp (car args))) form
-    (let ((s (sgen "FN-BIND")));sgen?
-      `(let ((,s ,(pop args))) (,(car form) ,s ,@args)))))
-
-(define-compiler-macro funcall (&whole form &rest args) (fn-bind form args))
-;(define-compiler-macro apply (&whole form &rest args) (apply-bind form args))
-(define-compiler-macro apply (&whole form &rest args) (fn-bind form args))
+;FIXME c1symbol-fun, eliminate mi1b
+(defmacro try-provisional-functions (&rest body);ensure body has no side-effects for double eval
+  `(or
+    (with-restore-vars
+	(let* ((*prov* t)(ops *prov-src*)(*prov-src* *prov-src*)(res (progn ,@body)))
+	  (unless (iflag-p (info-flags (cadr res)) provisional)
+	    (keep-vars) (mapc 'eliminate-src (ldiff *prov-src* ops)) res)))
+    (progn ,@body)))
 
 (defun c1apply (args)
   (when (or (endp args) (endp (cdr args)))
     (too-few-args 'apply 2 (length args)))
-  (let* ((ff (c1arg (pop args)))
-	 (fid (coerce-ff ff)))
-    (if (eq fid 'funcall) (c1apply args) (mi1 fid (butlast args) (car (last args)) ff))))
-	
+  (try-provisional-functions
+   (let* ((ff (c1arg (car args)))(args (cdr args))(fid (coerce-ff ff)))
+     (if (eq fid 'funcall) (c1apply args) (mi1 fid (butlast args) (car (last args)) ff)))))
+
 (defun c1funcall (args)
   (when (endp args) (too-few-args 'funcall 1 0))
-  (let* ((ff (c1arg (pop args)))
-	 (fid (coerce-ff ff)))
-    (case fid (funcall (c1funcall args))(apply (c1apply args)) (otherwise (mi1 fid args nil ff)))))
+  (try-provisional-functions
+   (let* ((ff (c1arg (car args)))(args (cdr args))(fid (coerce-ff ff)))
+     (case fid (funcall (c1funcall args))(apply (c1apply args)) (otherwise (mi1 fid args nil ff))))))
+
 
 ;; (defun c1funcall-apply (args &optional last)
 ;;   (mi1 (if last 'apply 'funcall) args (car last)))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpif.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpif.lsp
@@ -24,10 +24,6 @@
 
 (si:putprop 'if 'c1if 'c1special)
 (si:putprop 'if 'c2if 'c2)
-(si:putprop 'and 'c1and 'c1)
-(si:putprop 'and 'c2and 'c2)
-(si:putprop 'or 'c1or 'c1)
-(si:putprop 'or 'c2or 'c2)
 
 (si:putprop 'jump-true 'set-jump-true 'set-loc)
 (si:putprop 'jump-false 'set-jump-false 'set-loc)
@@ -37,8 +33,7 @@
 ;; (si:putprop 'case 'c2case 'c2)
 
 (defun note-branch-elimination (test-form val elim-form)
-;  (let ((*suppress-compiler-notes* t) (*suppress-compiler-warnings* t))
-;    (c1expr elim-form))
+  (eliminate-src elim-form)
   (keyed-cmpnote (list 'branch-elimination test-form)
 		 "Test form ~S is ~S,~%;; eliminating branch ~S~%" test-form val elim-form))
 
@@ -759,261 +754,6 @@
 		 (dolist (l r)
 		   (setf (var-type (car l)) (cadr l))))))))))
 
-;; (defun c1if (args &aux info f)
-;;   (when (or (endp args) (endp (cdr args)))
-;;         (too-few-args 'if 2 (length args)))
-;;   (unless (or (endp (cddr args)) (endp (cdddr args)))
-;;           (too-many-args 'if 3 (length args)))
-;;   (setq f (c1fmla-constant (car args)))
-
-;;   (case f
-;;         ((t) 
-;; 	 (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 	 (c1expr (cadr args)))
-;;         ((nil) 
-;; 	 (note-branch-elimination (car args) nil (cadr args))
-;; 	 (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
-;;         (otherwise
-;;          (setq info (make-info))
-;; 	 (let* ((fmla (c1fmla f info))
-;; 		(inf (delete +gen+ (fmla-infer-tp fmla) :key 'car))
-;; 		(inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf))
-;; 		(fmlae (fmla-eval-const fmla))
-;; 		(fmlae (if (notevery 'cadr inf) nil fmlae))
-;; 		(fmlae (if (notevery 'cddr inf) t   fmlae)))
-;; 	   (when inf 
-;; 	     (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf))
-;; 			  "inferring types on form ~s, ~s" f inf))
-;; 	   (if (not (eq fmlae 'boolean))
-
-;;  	       (cond (fmlae 
-;;   		      (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 		      (maybe-progn-fmla fmla (cadr args) info))
-;;   		     (t (note-branch-elimination (car args) nil (cadr args)) 
-;; 			(maybe-progn-fmla fmla (caddr args) info)))
-	     
-;; 	     (let (r)
-;; 	       (dolist (l inf)
-;; 		 (let ((v (car l)))
-;; 		   (when v
-;; 		     (push (list v (var-type v) (cdr l)) r))))
-;; 	       (unwind-protect
-
-;; 		   (let* ((tbl (c1branch t   r args info))
-;; 			  (fbl (c1branch nil r args info))
-;; 			  (tb (car tbl))
-;; 			  (fb (car fbl))
-;; 			  (trv (append (cadr tbl) (cadr fbl))))
-
-;; 		     (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb))))
-
-;; 		     (do (rv) ((not (setq rv (pop r))))
-;; 			 (setf (var-type (car rv)) (cadr rv))
-;; 			 (if (info-type (cadr fb))
-;; 			     (unless (info-type (cadr tb))
-;; 			       (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv)))))
-;; 			   (when (info-type (cadr tb))
-;; 			     (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv)))))))
-
-;; 		     (do (rv) ((not (setq rv (pop trv))))
-;; 			 (setf (var-store (car rv)) (if (eq (var-store (car rv)) (caddr rv)) (var-store (car rv)) +opaque+))
-;; 			 (do-setq-tp (car rv) (list args nil) (type-or1 (var-type (car rv)) (cadr rv))))
-
-;; 		     (list 'if info fmla tb fb))
-
-;; 		 (dolist (l r)
-;; 		   (setf (var-type (car l)) (cadr l))))))))))
-
-;; (defun c1if (args &aux info f)
-;;   (when (or (endp args) (endp (cdr args)))
-;;         (too-few-args 'if 2 (length args)))
-;;   (unless (or (endp (cddr args)) (endp (cdddr args)))
-;;           (too-many-args 'if 3 (length args)))
-;;   (setq f (c1fmla-constant (car args)))
-
-;;   (case f
-;;         ((t) 
-;; 	 (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 	 (c1expr (cadr args)))
-;;         ((nil) 
-;; 	 (note-branch-elimination (car args) nil (cadr args))
-;; 	 (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
-;;         (otherwise
-;;          (setq info (make-info))
-;; 	 (let* ((fmla (c1fmla f info))
-;; 		(inf (delete +gen+ (fmla-infer-tp fmla) :key 'car))
-;; 		(inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf))
-;; 		(fmlae (fmla-eval-const fmla))
-;; 		(fmlae (if (notevery 'cadr inf) nil fmlae))
-;; 		(fmlae (if (notevery 'cddr inf) t   fmlae)))
-;; 	   (when inf 
-;; 	     (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf))
-;; 			  "inferring types on form ~s, ~s" f inf))
-;; 	   (if (not (eq fmlae 'boolean))
-
-;;  	       (cond (fmlae 
-;;   		      (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 		      (maybe-progn-fmla fmla (cadr args) info))
-;;   		     (t (note-branch-elimination (car args) nil (cadr args)) 
-;; 			(maybe-progn-fmla fmla (caddr args) info)))
-	     
-;; 	     (let (r)
-;; 	       (dolist (l inf)
-;; 		 (let ((v (car l)))
-;; 		   (when v
-;; 		     (push (list v (var-type v) (cdr l)) r))))
-;; 	       (unwind-protect
-
-;; 		   (let* ((tbl (c1branch t   r args info))
-;; 			  (fbl (c1branch nil r args info))
-;; 			  (tb (car tbl))
-;; 			  (fb (car fbl))
-;; 			  (trv (append (cadr tbl) (cadr fbl))))
-
-;; 		     (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb))))
-
-;; 		     (do (rv) ((not (setq rv (pop r))))
-;; 			 (setf (var-type (car rv)) (cadr rv))
-;; 			 (unless (info-type (cadr tb))
-;; 			   (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv)))))
-;; 			 (unless (info-type (cadr fb))
-;; 			   (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv))))))
-
-;; 		     (do (rv) ((not (setq rv (pop trv))))
-;; 			 (do-setq-tp (car rv) (list args nil) (type-or1 (var-type (car rv)) (cadr rv))))
-
-;; 		     (list 'if info fmla tb fb))
-
-;; 		 (dolist (l r)
-;; 		   (setf (var-type (car l)) (cadr l))))))))))
-
-;; (defun c1if (args &aux info f)
-;;   (when (or (endp args) (endp (cdr args)))
-;;         (too-few-args 'if 2 (length args)))
-;;   (unless (or (endp (cddr args)) (endp (cdddr args)))
-;;           (too-many-args 'if 3 (length args)))
-;;   (setq f (c1fmla-constant (car args)))
-
-;;   (case f
-;;         ((t) 
-;; 	 (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 	 (c1expr (cadr args)))
-;;         ((nil) 
-;; 	 (note-branch-elimination (car args) nil (cadr args))
-;; 	 (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
-;;         (otherwise
-;;          (setq info (make-info))
-;; 	 (let* ((fmla (c1fmla f info))
-;; 		(inf (delete +gen+ (fmla-infer-tp fmla) :key 'car))
-;; 		(inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf))
-;; 		(fmlae (fmla-eval-const fmla))
-;; 		(fmlae (if (notevery 'cadr inf) nil fmlae))
-;; 		(fmlae (if (notevery 'cddr inf) t   fmlae)))
-;; 	   (when inf 
-;; 	     (keyed-cmpnote (list* 'type-inference (mapcar (lambda (x) (var-name (car x))) inf))
-;; 			  "inferring types on form ~s, ~s" f inf))
-;; 	   (if (not (eq fmlae 'boolean))
-
-;;  	       (cond (fmlae 
-;;   		      (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 		      (maybe-progn-fmla fmla (cadr args) info))
-;;   		     (t (note-branch-elimination (car args) nil (cadr args)) 
-;; 			(maybe-progn-fmla fmla (caddr args) info)))
-	     
-;; 	     (let (r)
-;; 	       (dolist (l inf)
-;; 		 (let ((v (car l)))
-;; 		   (when v
-;; 		     (push (list v (var-type v) (cdr l)) r))))
-;; 	       (unwind-protect
-
-;; 		   (let* ((tbl (c1branch t   r args info))
-;; 			  (fbl (c1branch nil r args info))
-;; 			  (tb (car tbl))
-;; 			  (fb (car fbl))
-;; 			  (trv (append (cadr tbl) (cadr fbl))))
-
-;; 		     (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb))))
-
-;; 		     (do (rv) ((not (setq rv (pop r))))
-;; 			 (setf (var-type (car rv)) (cadr rv))
-;; 			 (unless (info-type (cadr tb))
-;; 			   (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv)))))
-;; 			 (unless (info-type (cadr fb))
-;; 			   (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv))))))
-
-;; 		     (do (rv) ((not (setq rv (pop trv))))
-;; 			 (do-setq-tp (car rv) nil (type-or1 (var-type (car rv)) (cadr rv))))
-
-;; 		     (list 'if info fmla tb fb))
-
-;; 		 (dolist (l r)
-;; 		   (setf (var-type (car l)) (cadr l))))))))))
-
-;; (defun c1if (args &aux info f)
-;;   (when (or (endp args) (endp (cdr args)))
-;;         (too-few-args 'if 2 (length args)))
-;;   (unless (or (endp (cddr args)) (endp (cdddr args)))
-;;           (too-many-args 'if 3 (length args)))
-;;   (setq f (c1fmla-constant (car args)))
-
-;;   (case f
-;;         ((t) 
-;; 	 (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 	 (c1expr (cadr args)))
-;;         ((nil) 
-;; 	 (note-branch-elimination (car args) nil (cadr args))
-;; 	 (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
-;;         (otherwise
-;;          (setq info (make-info))
-;; 	 (let* ((fmla (c1fmla f info))
-;; 		(inf (delete +gen+ (fmla-infer-tp fmla) :key 'car))
-;; 		(inf (remove-if (lambda (x) (fmla-is-changed (car x) fmla)) inf))
-;; 		(fmlae (fmla-eval-const fmla))
-;; 		(fmlae (if (notevery 'cadr inf) nil fmlae))
-;; 		(fmlae (if (notevery 'cddr inf) t   fmlae)))
-;; 	   (when inf 
-;; 	     (keyed-cmpnote (list* 'type-inference (mapcar 'car inf))
-;; 			  "inferring types on form ~s, ~s" f inf))
-;; 	   (if (not (eq fmlae 'boolean))
-
-;;  	       (cond (fmlae 
-;;   		      (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
-;; 		      (maybe-progn-fmla fmla (cadr args) info))
-;;   		     (t (note-branch-elimination (car args) nil (cadr args)) 
-;; 			(maybe-progn-fmla fmla (caddr args) info)))
-	     
-;; 	     (let (r)
-;; 	       (dolist (l inf)
-;; 		 (let ((v (car (member (car l) *vars* :key (lambda (x) (when (var-p x) (var-name x)))))))
-;; 		   (when v
-;; 		     (push (list v (var-type v) (cdr l)) r))));;FIXME return in this from from infer-tp
-;; 	       (unwind-protect
-
-;; 		   (let* ((tbl (c1branch t   r args info))
-;; 			  (fbl (c1branch nil r args info))
-;; 			  (tb (car tbl))
-;; 			  (fb (car fbl))
-;; 			  (trv (append (cadr tbl) (cadr fbl))))
-
-;; 		     (setf (info-type info) (type-or1 (info-type (cadr tb)) (info-type (cadr fb))))
-
-;; 		     (do (rv) ((not (setq rv (pop r))))
-;; 			 (setf (var-type (car rv)) (cadr rv))
-;; 			 (unless (info-type (cadr tb))
-;; 			   (do-setq-tp (car rv) nil (type-and (cdr (caddr rv)) (var-type (car rv)))))
-;; 			 (unless (info-type (cadr fb))
-;; 			   (do-setq-tp (car rv) nil (type-and (car (caddr rv)) (var-type (car rv))))))
-
-;; 		     (do (rv) ((not (setq rv (pop trv))))
-;; 			 (do-setq-tp (car rv) nil (type-or1 (var-type (car rv)) (cadr rv))))
-
-;; 		     (list 'if info fmla tb fb))
-
-;; 		 (dolist (l r)
-;; 		   (setf (var-type (car l)) (cadr l))))))))))
-
-
 
 (defun t-and (x y)
   (cond ((eq x 'boolean) (when y 'boolean))
@@ -1500,7 +1240,7 @@
 	     `(<= ,n ,s ,x))))))
 
 (define-compiler-macro case (&whole form &rest args)
-  (if (type>= #tfixnum (nil-to-t (info-type (cadr (with-restore-vars (c1arg (car args)))))))
+  (if (when *compiler-in-use* (type>= #tfixnum (nil-to-t (info-type (cadr (with-restore-vars (c1arg (car args))))))))
       (let* ((s (pop args))
 	     (oth (member-if (lambda (x &aux (x (car x))) (or (eq x t) (eq x 'otherwise))) args))
 	     (rem (ldiff args oth))
@@ -1509,150 +1249,3 @@
 	      (cond ((unless (cdr rem) (when ff `(if ,ff ,(f rem) ,(f oth)))))
 		    ((convert-case-to-switch (cdr form))))))
     form))
-
-;; (define-compiler-macro case (&whole form &rest args)
-;;   (if (type>= #tfixnum (nil-to-t (info-type (cadr (with-restore-vars (c1arg (car args)))))))
-;;       (let* ((s (pop args))
-;; 	     (oth (member-if (lambda (x &aux (x (car x))) (or (eq x t) (eq x 'otherwise))) args))
-;; 	     (rem (ldiff args oth))
-;; 	     (ff (when rem (conv-kl (caar rem) s))))
-;; 	(flet ((f (x) (let ((d (cdar x))) (if (cdr d) (cons 'progn d) (car d)))))
-;; 	      (cond ((unless (cdr rem) (when ff `(if ,ff ,(f rem) ,(f oth)))))
-;; 		    ((convert-case-to-switch (cdr form) nil)))))
-;;     form))
-
-;; (defun c1case (args &optional (default nil))
-;;   (when (endp args) (too-few-args 'case 1 0))
-;;   (let* ((info (make-info :type #tnil))
-;;          (key-form (with-restore-vars (c1arg (car args) info)))
-;;          (clauses nil) or-list)
-;;     (cond #+switch((unless (atomic-tp (info-type (second key-form)));FIXME
-;; 	     (type>= #tfixnum (nil-to-t (info-type (second key-form)))))
-;; 	   (return-from c1case  (c1expr (convert-case-to-switch args default ))))
-;; 	  ((return-from c1case (c1expr (cmp-macroexpand `(,(if default 'ecase 'case) ,@args))))))
-;;     (dolist (clause (cdr args))
-;;       (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
-;;       (case (car clause)
-;;             ((nil))
-;;             ((t otherwise)
-;;              (when default
-;;                    (cmperr (if (eq default 't)
-;;                                "ECASE had an OTHERWISE clause."
-;;                                "CASE had more than one OTHERWISE clauses.")))
-;;              (setq default (with-restore-vars
-;; 			    (prog1
-;; 				(c1progn (cdr clause))
-;; 			      (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list)))))
-;; 	     (setf (info-type info) (type-or1 (info-type info) (info-type (cadr default))))
-;;              (add-info info (cadr default)))
-;;             (t (let* ((keylist
-;;                        (cond ((consp (car clause))
-;;                               (mapcar (lambda (key) (if (symbolp key) key (add-object key)))
-;;                                       (car clause)))
-;;                              ((symbolp (car clause)) (list (car clause)))
-;;                              (t (list (add-object (car clause))))))
-;;                       (body (with-restore-vars 
-;; 			     (prog1 
-;; 				 (c1progn (cdr clause))
-;; 			       (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list))))))
-;;                  (add-info info (cadr body))
-;; 		 (setf (info-type info) (type-or1 (info-type info) (info-type (cadr body))))
-;;                  (push (cons keylist body) clauses)))))
-;;     (dolist (l or-list) (setf (var-type (car l)) (type-or1 (var-type (car l)) (cadr l))))
-;;     (list 'case info key-form (reverse clauses) (or default (c1nil)))))
-
-;; (defun c1case (args &optional (default nil))
-;;   (when (endp args) (too-few-args 'case 1 0))
-;;   (let* ((info (make-info :type #tnil))
-;;          (key-form (with-restore-vars (c1expr* (car args) info)))
-;;          (clauses nil) or-list)
-;;     (cond #+switch((unless (atomic-tp (info-type (second key-form)));FIXME
-;; 	     (type>= #tfixnum (nil-to-t (info-type (second key-form)))))
-;; 	   (return-from c1case  (c1expr (convert-case-to-switch args default ))))
-;; 	  ((return-from c1case (c1expr (cmp-macroexpand `(,(if default 'ecase 'case) ,@args))))))
-;;     (dolist (clause (cdr args))
-;;       (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
-;;       (case (car clause)
-;;             ((nil))
-;;             ((t otherwise)
-;;              (when default
-;;                    (cmperr (if (eq default 't)
-;;                                "ECASE had an OTHERWISE clause."
-;;                                "CASE had more than one OTHERWISE clauses.")))
-;;              (setq default (with-restore-vars
-;; 			    (prog1
-;; 				(c1progn (cdr clause))
-;; 			      (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list)))))
-;; 	     (setf (info-type info) (type-or1 (info-type info) (info-type (cadr default))))
-;;              (add-info info (cadr default)))
-;;             (t (let* ((keylist
-;;                        (cond ((consp (car clause))
-;;                               (mapcar (lambda (key) (if (symbolp key) key (add-object key)))
-;;                                       (car clause)))
-;;                              ((symbolp (car clause)) (list (car clause)))
-;;                              (t (list (add-object (car clause))))))
-;;                       (body (with-restore-vars 
-;; 			     (prog1 
-;; 				 (c1progn (cdr clause))
-;; 			       (dolist (l *restore-vars*) (push (list (car l) (var-type (car l))) or-list))))))
-;;                  (add-info info (cadr body))
-;; 		 (setf (info-type info) (type-or1 (info-type info) (info-type (cadr body))))
-;;                  (push (cons keylist body) clauses)))))
-;;     (dolist (l or-list) (setf (var-type (car l)) (type-or1 (var-type (car l)) (cadr l))))
-;;     (list 'case info key-form (reverse clauses) (or default (c1nil)))))
-
-;; (defun c2case (key-form clauses default
-;;                &aux (cvar (cs-push t t)) (*vs* *vs*) (*inline-blocks* 0))
-;;   (setq key-form (car (inline-args (list key-form) '(t))))
-;;   (wt-nl "{object V" cvar "= " key-form ";")
-
-;;   (dolist (clause clauses)
-;;     (let* ((label (next-label))
-;;            (keylist (car clause))
-;;            (local-label nil))
-;;       (do ()
-;;           ((<= (length keylist) 5))
-;;         (when (null local-label) (setq local-label (next-label)))
-;;         (wt-nl "if(")
-;;         (dotimes (i 5)
-;;           (cond ((symbolp (car keylist))
-;;                  (wt "(V" cvar "== ")
-;;                  (case (car keylist)
-;;                    ((t) (wt "Ct"))
-;;                    ((nil) (wt "Cnil"))
-;;                    (otherwise (wt (vv-str (add-symbol (car keylist))))))
-;;                  (wt ")"))
-;;                 (t (wt "eql(V" cvar "," (vv-str (car keylist)) ")")))
-;;           (when (< i 4) (wt-nl "|| "))
-;;           (pop keylist))
-;;         (wt ")")
-;;         (wt-go local-label))
-
-;;       (wt-nl "if(")
-;;       (do ()
-;;           ((endp keylist))
-;;         (cond ((symbolp (car keylist))
-;;                (wt "(V" cvar "!= ")
-;;                (case (car keylist)
-;;                  ((t) (wt "Ct"))
-;;                  ((nil) (wt "Cnil"))
-;;                  (otherwise (wt (vv-str (add-symbol (car keylist))))))
-;;                (wt ")"))
-;;               (t (wt "!eql(V" cvar "," (vv-str (car keylist)) ")")))
-;;         (unless (endp (cdr keylist)) (wt-nl "&& "))
-;;         (pop keylist))
-;;       (wt ")")
-;;       (wt-go label)
-;;       (when local-label (wt-label local-label))
-;;       (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause)))
-;;       (wt-label label)))
-
-;;   (if (eq default 't)
-;;       (progn (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");")
-;; 	     (unwind-exit nil 'jump))
-;;       (c2expr default))
-
-;;   (wt "}")
-;;   (close-inline-blocks))
-
-
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpinline.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpinline.lsp
@@ -1169,8 +1169,3 @@
 (defun c-cast (aet)
   (or (cdr (assoc aet +c-type-string-alist+)) (baboon)))
 
-(defun default-init (type)
-  (let ((type (promoted-c-type type)))
-    (when (member type +c-local-var-types+)
-      (cmpwarn "The default value of NIL is not ~S." type)))
-  (c1nil))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmplabel.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmplabel.lsp
@@ -198,9 +198,7 @@
        ((eq ue 'frame) (wt-nl "frs_pop();"))
        ((eq ue 'tail-recursion-mark)
         (cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind)
-                                              (return))
-;              (t (baboon))
-)
+                                              (return)))
         ;;; Never reached
         )
        ((eq ue 'jump))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmplam.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmplam.lsp
@@ -57,13 +57,7 @@
 ;;; Body' is body possibly surrounded by a LET* (if &aux parameters are
 ;;; supplied) and an implicit block.
 
-(defmacro ck-spec (condition)
-  `(unless ,condition
-           (cmperr "The parameter specification ~s is illegal." spec)))
-
-(defmacro ck-vl (condition)
-  `(unless ,condition
-           (cmperr "The lambda list ~s is illegal." vl)))
+
 
 
 (defun wfs-error ()
@@ -114,11 +108,6 @@
   `(lambda ,info ,(list (nreverse requireds) narg) ,doc ,body))
 
 
-(defun the-parameter (name)
-  (cmpck (not (symbolp name)) "The parameter ~s is not a symbol." name)
-  (cmpck (constantp name) "The constant ~s is being bound." name)
-  name)
-
 (defvar *rest-on-stack* nil)  ;; non nil means put rest arg on C stack.
 
 (defun need-to-set-vs-pointers (lambda-list)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmplet.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmplet.lsp
@@ -36,7 +36,11 @@
 	  (var-type v) (ensure-known-type (if *compiler-new-safety* (var-type v) (type-and t1 (var-dt v))))
 	  (var-mt v) (var-type v)
 	  (var-loc v) (unless (and (eq (var-loc v) 'object)
-				   (unless (eq t (var-type v)) (var-type v))) (var-loc v)))
+				   (unless (eq t (var-type v)) (var-type v)))
+			(var-loc v)))
+    (unless (var-type v)
+      (cmpwarn "Type mismatches binding declared ~s variable ~s to type ~s."
+	       (cmp-unnorm-tp (var-dt v)) (var-name v) (cmp-unnorm-tp t1)))
     (keyed-cmpnote (list (var-name v) 'type-propagation 'type 'init-type)
 		   "Setting init type of ~s to ~s" (var-name v) (cmp-unnorm-tp (var-type v)))))
 
@@ -106,41 +110,7 @@
 		 (if nf (setf (car nf) np) (setf body np)))))
 	    ((push var nv) (when star (ref-vars form (cdr vs))) (push form nf))))))
 
-;; (defun trim-vars (vars forms body &optional star &aux (bp (have-provfn body)))
-
-;;   (do* (nv nf (vs vars (cdr vs)) (fs forms (cdr fs)) 
-;; 	   (av (append vars *vars*)) (fv (cdr av) (cdr fv)))
-;;       ((or (endp vs) (endp fs)) (list nv nf body))
-;;       (let ((var (car vs)) (form (car fs)))
-;; 	(cond ((and (eq (var-kind var) 'LEXICAL)
-;; 		    (not (eq t (var-ref var))) ;;; This field may be IGNORE.
-;; 		    (not (var-ref-ccb var))
-;; 		    (not (provisional-block-trim (var-name var) bp fs star)))
-;; 	       (unless (ignorable-form form) 
-;; 		 (let* ((*vars* (if nf (if star fv *vars*) av))
-;; 			(f (if nf (car nf) body))
-;; 			(np (new-c1progn form f)))
-;; 		   (if nf (setf (car nf) np) (setf body np)))))
-;; 	      ((push var nv) (push form nf))))))
-
-;; (defun trim-vars (vars forms body &optional star)
-
-;;   (do* (nv nf (vs vars (cdr vs)) (fs forms (cdr fs)) 
-;; 	   (av (append vars *vars*)) (fv (cdr av) (cdr fv)))
-;;       ((or (endp vs) (endp fs)) (list nv nf body))
-;;       (let ((var (car vs)) (form (car fs)))
-;; 	(cond ((and (eq (var-kind var) 'LEXICAL)
-;; 		    (not (eq t (var-ref var))) ;;; This field may be IGNORE.
-;; 		    (not (var-ref-ccb var))
-;; 		    (not *provisional-inline*));FIXME
-;; 	       (unless (ignorable-form form) 
-;; 		 (let* ((*vars* (if nf (if star fv *vars*) av))
-;; 			(f (if nf (car nf) body))
-;; 			(np (new-c1progn form f)))
-;; 		   (if nf (setf (car nf) np) (setf body np)))))
-;; 	      ((push var nv) (push form nf))))))
-
-(defun mvars (args ss is ts star inls)
+(defun mvars (args ss is ts star inls);FIXME truncate this and make-c1forms at nil type
   (mapcar (lambda (x)
 	    (let* ((n (if (atom x) x (pop x)))
 		   (f (unless (atom x) (car x)))
@@ -150,98 +120,8 @@
 	      (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v)))
 	      (maybe-reverse-type-prop (var-type v) fm)
 	      (when star (push-var v fm))
-	      (cons v fm))) args))
-
-;; (defun mvars (args ss is ts star inls)
-;;   (mapcar (lambda (x)
-;; 	    (let* ((n (if (atom x) x (pop x)))
-;; 		   (f (unless (atom x) (car x)))
-;; 		   (v (c1make-var n ss is ts))
-;; 		   (fm (if (and inls (eq f (caar inls))) (cdr (pop inls)) (c1arg f))));FIXME check
-;; 	      (set-var-init-type v (info-type (cadr fm)))
-;; 	      (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v)))
-;; 	      (maybe-reverse-type-prop (var-type v) fm)
-;; 	      (when star (push v *vars*))
-;; 	      (cons v fm))) args))
-
-;; (defun mvars (args ss is ts star inls &aux *c1exit*)
-;;   (mapcar (lambda (x)
-;; 	    (let* ((n (if (atom x) x (pop x)))
-;; 		   (f (unless (atom x) (car x)))
-;; 		   (v (c1make-var n ss is ts))
-;; 		   (fm (if (and inls (eq f (caar inls))) (cdr (pop inls)) (c1expr f))));FIXME check
-;; 	      (set-var-init-type v (info-type (cadr fm)))
-;; 	      (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v)))
-;; 	      (maybe-reverse-type-prop (var-type v) fm)
-;; 	      (when star (push v *vars*))
-;; 	      (cons v fm))) args))
-
-;; (defun mvars (args ss is ts info star &aux *c1exit* (ov *vars*))
-;;   (mapcar (lambda (x)
-;; 	    (let* ((n (if (atom x) x (pop x)))
-;; 		   (f (unless (atom x) (car x)))
-;; 		   (v (c1make-var n ss is ts))
-;; 		   (fm (if (and *inline-forms* 
-;; 				(eq f (caar *inline-forms*))) (cdr (pop *inline-forms*)) (c1expr f))))
-;; 	      (let ((*vars* ov)) (add-info info (cadr fm)));FIXME?  top-level info
-;; 	      (set-var-init-type v (info-type (cadr fm)))
-;; 	      (when (eq (car fm) 'var) (pushnew (caaddr fm) (var-aliases v)))
-;; 	      (maybe-reverse-type-prop (var-type v) fm)
-;; 	      (when star (push v *vars*))
-;; 	      (cons v fm))) args))
-
-;; (defun fsl (sl)
-;;   (labels ((m (tg q &aux (v (member tg q :key 'car))) (if v (m (cdar v) (cdr v)) tg)))
-;; 	  (mapl (lambda (x) (setf (cdar x) (m (cdar x) (cdr x)))) sl)))
-
-;; (defun c1replace-check (sl f)
-;;   (cond ((atom f) (assert (not (assoc f sl))))
-;; 	(t (c1replace-check sl (car f)) (c1replace-check sl (cdr f)))))
-
-;; (defun c1replace-body (sl f);FIXME push refs to slot of var to avoid walk
-;;   (unless (atom f)
-;;     (labels ((set (v &aux (s (assoc (car v) sl))) (when s (setf (car v) (cdr s)))))
-;; 	    (case (car f)
-;; 		  (var (if (info-p (cadr f)) (set (third f)) (c1replace-body sl (cdr f))))
-;; 		  (infer-tp  (set (cddr f));FIXME
-;; 			     (c1replace-body sl (cdddr f)))
-;; 		  (otherwise (c1replace-body sl (car f)) (c1replace-body sl (cdr f)))))))
-  
-;; (defun c1replace (form)
-;;   (let* ((nm (pop form)) (info (pop form)) (vars (pop form)) (fms (pop form))
-;; 	 (q (mapcar 'cons vars fms))
-;; 	 (nf (append fms form))
-;; 	 (ch (reduce 'nunion (mapcar (lambda (x &aux (x (cadr x))) (union (info-ch x) (union (info-ref-ccb x) (info-ref-clb x)))) nf)))
-;; 	 (sl (remove-if (lambda (x) (not (eq (cadr x) 'var))) q))
-;; 	 (sl (mapcar (lambda (x) (cons (car x) (car (third (cdr x))))) sl))
-;; 	 (sl (labels ((bad (x) (or (member x ch) (member (var-kind x) '(global special)))))
-;; 		     (remove-if (lambda (x) (or (bad (car x)) (bad (cdr x)))) sl)))
-;; 	 (sl (remove-if-not (lambda (x) (type>= (var-type (car x)) (var-type (cdr x)))) sl))
-;; 	 (sl (fsl (nreverse sl)))
-;; 	 (q (remove-if (lambda (x) (assoc (car x) sl)) q)))
-
-;;     (mapc (lambda (x) (mapc (lambda (y) (setf (car y) (cdr x))(push y (var-store (cdr x)))) (var-store (car x)))) sl)
-;; ;    (c1replace-check sl nf)
-     
-;;     (list* nm info (mapcar 'car q) (mapcar 'cdr q) form)))
-
-;; (defun c1replace (form)
-;;   (let* ((nm (pop form)) (info (pop form)) (vars (pop form)) (fms (pop form))
-;; 	 (q (mapcar 'cons vars fms))
-;; 	 (nf (append fms form))
-;; 	 (ch (reduce 'nunion (mapcar (lambda (x &aux (x (cadr x))) (union (info-ch x) (union (info-ref-ccb x) (info-ref-clb x)))) nf)))
-;; 	 (sl (remove-if (lambda (x) (not (eq (cadr x) 'var))) q))
-;; 	 (sl (mapcar (lambda (x) (cons (car x) (car (third (cdr x))))) sl))
-;; 	 (sl (labels ((bad (x) (or (member x ch) (member (var-kind x) '(global special)))))
-;; 		     (remove-if (lambda (x) (or (bad (car x)) (bad (cdr x)))) sl)))
-;; 	 (sl (remove-if-not (lambda (x) (type>= (var-type (car x)) (var-type (cdr x)))) sl))
-;; 	 (sl (fsl (nreverse sl)))
-;; 	 (q (remove-if (lambda (x) (assoc (car x) sl)) q)))
-    
-;;     (when sl (c1replace-body sl nf));FIXME push refs to slot of var to avoid walk
-;; ;      (c1replace-check sl nf)
-    
-;;     (list* nm info (mapcar 'car q) (mapcar 'cdr q) form)))
+	      (cons v fm)))
+	  args))
 
 (defun push-var (var form)
   (push var *vars*)
@@ -264,11 +144,15 @@
 
     (unless star (mapc (lambda (x) (push-var (car x) (cdr x))) vs))
 
+    (when (member-if-not 'identity forms :key (lambda (x) (info-type (cadr x))))
+      (eliminate-src body)
+      (setq body nil))
+
     (c1add-globals (set-difference ss vnames))
     (check-vdecl vnames ts is)
     (setq body (c1decl-body other-decls body))
 
-    (unless (single-type-p (info-type (cadr body))) 
+    (unless (single-type-p (info-type (cadr body))) ;FIXME infinite recursion
       (let ((mv (car (member-if 'is-mv-var vars))))
 	(when mv
 	  (ref-vars (c1var (var-name mv)) (list mv)))))
@@ -497,54 +381,3 @@
     block-p ))
 
 
-;; ---------- stack-let for consing on stack ---------
-
-;; Usage:  (stack-let ((a (cons 1 2)) (b (cons 3 4))) (foo a) (print b) 7)
-;;  where foo must not keep a copy of `a', since the cons will be formed
-;;  on the c stack.
-
-(setf (get 'stack-let 'c1special) 'c1stack-let)
-
-(defmacro stack-let (&rest x) (cons `let x))
-
-(defun c1stack-let (args &aux npairs nums)
-  (let ((pairs (car args)))
-    (dolist (v pairs)
-	    (push
-	     (cond ((atom v) v)
-		   ((let ((var (car v))
-			  (val (second v)))
-		      (and (consp val)
-			   (or (eq (car val) 'cons)
-			       (and (eq (car val) 'list)
-				    (null (cddr val))
-				    (setq val `(cons ,(second val) nil))))
-			   (progn
-			     (push (cs-push t t) nums)
-			     `(,var (stack-cons ,(car nums) ,@ (cdr val)))))))
-		   (t (cmpwarn "Stack let = regular let for ~a ~a"
-			       v (cdr args))
-		      v))
-	     npairs))
-    (let ((result (c1expr (cons 'let (cons (nreverse npairs) (cdr args))))))
-      (list 'stack-let (second result) nums result))))
-
-(setf (get 'stack-let 'c2) 'c2stack-let)
-
-(defun c2stack-let (nums form)
-  (let ((n (cs-push t t)))
-    (wt-nl "{Cons_Macro" n ";")
-    (c2expr form)
-    (wt "}")
-    (wt-h
-     "#define Cons_Macro" n (format nil " struct cons ~{STcons~a ~^,~};" nums)
-     )))
-
-;;FIXME update this
-;(push '((fixnum t t) t #.(flags) 
-;	"(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1),
-;              STcons#0.c_cdr=(#2),(object)&STcons#0)")
-;        (get 'stack-cons 'inline-always))    
-
-;; ---------- end stack-let for consing on stack ---------
-
--- gcl27-2.7.0.orig/cmpnew/gcl_cmploc.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmploc.lsp
@@ -164,46 +164,6 @@
          (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
         (t (baboon))))
 
-;; (defun set-loc (loc &aux fd)
-;;   (cond ((eq *value-to-go* 'return) (set-return loc))
-;;         ((member *value-to-go* '(trash expr))
-;; 	 (let ((tr (eq *value-to-go* 'trash)))
-;; 	   (cond ((and (consp loc)
-;; 		       (rassoc (car loc) +inline-types-alist+)
-;; 		       (cadr loc))
-;; 		  (wt-nl (if tr "(void)" "") "(") 
-;; 		  (wt-inline t (caddr loc) (cadddr loc))
-;; 		  (wt ")" (if tr ";" "")))
-;; 		 ((and (consp loc) (eq (car loc) 'SIMPLE-CALL))
-;; 		  (wt-nl (if tr "(void)" "") loc (if tr ";" ""))))))
-;;         ((eq *value-to-go* 'top)
-;;          (unless (eq loc 'fun-val) (set-top loc)))
-;; 	((multiple-values-p)
-;; 	 (let ((*values-to-go* *value-to-go*) *extend-vs-top*)
-;; 	   (do ((loc loc nil)) ((null *values-to-go*))
-;; 	       (let ((*value-to-go* (pop *values-to-go*)))
-;; 		 (set-loc loc)))
-;; 	   (when *mvb-vals* 
-;; 	     (wt-nl)
-;; 	     (when (and *extend-vs-top* (> (var-space *mv-var*) 0))
-;; 	       (let ((l (var-loc *mv-var*)))
-;; 		 (wt-nl "for (vs_top=vs_top<V" l "? V" l ": vs_top;vs_top<V" l "+" (var-space *mv-var*) ";) *vs_top++=Cnil;")))
-;; 	     (reset-top)
-;; 	     (wt-nl "vals_set=1;"))))
-;; 	((setq fd (cdr (assoc (car (rassoc *value-to-go* +return-alist+)) +wt-loc-alist+)))
-;; 	 (wt-nl "VMR" *reservation-cmacro* "(")
-;; 	 (funcall fd loc)
-;; 	 (wt ");"))
-;; ;        ((setq fd (cdr (assoc *value-to-go* +set-return-alist+))) (values (funcall fd loc)))
-;;         ((or (not (consp *value-to-go*))
-;;              (not (symbolp (car *value-to-go*))))
-;;          (baboon))
-;;         ((setq fd (get (car *value-to-go*) 'set-loc))
-;;          (values (apply fd loc (cdr *value-to-go*))))
-;;         ((setq fd (get (car *value-to-go*) 'wt-loc))
-;;          (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
-;;         (t (baboon))))
-
 (defun wt-loc (loc)
   (cond ((eq loc nil) (wt "Cnil"))
         ((eq loc t) (wt "Ct"))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpmain.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpmain.lsp
@@ -30,7 +30,6 @@
 
 (export '(*compile-print* *compile-verbose*));FIXME
 (import 'si::(*tmp-dir* *cc* *ld* *objdump*))
-(import 'si::*error-p* 'compiler)
 
 ;;; This had been true with Linux 1.2.13 a.out or even older
 ;;; #+linux   (push :ld-not-accept-data  *features*)
@@ -82,8 +81,7 @@
     (unless (and (zerop code) (zerop result))
       (cerror "Continues anyway."
               "(SYSTEM ~S) returned a non-zero value ~D ~D."
-              string code result)
-      (setq *error-p* t))
+              string code result))
     (values result)))
 
 ;; If this is t we use fasd-data on all but system-p files.   If it
@@ -125,14 +123,15 @@
 		(caddr x)))
 	si::*sig-discovery-props*))
 
-(defun compile-file (fn &rest l &aux w e)
+(defun compile-file (fn &rest l &aux w e (*error-count* 0))
   (values
    (handler-bind
-       ((style-warning (lambda (c) (declare (ignore c)) (setq w t)))
-	(warning (lambda (c) (declare (ignore c)) (setq w t e t)))
-	(error (lambda (c) (declare (ignore c)) (setq w t e t))))
+       ((style-warning
+	 (lambda (c) (declare (ignore c)) (setq w t)))
+	((or error (and warning (not style-warning)))
+	 (lambda (c) (declare (ignore c)) (setq w t e t))))
        (apply 'compile-file2 fn l))
-   w e))
+   w (or e (plusp *error-count*))))
 
 (defun compile-file2  (filename &rest args
 		       &aux (*print-pretty* nil)
@@ -177,7 +176,7 @@
 					(unless (member :output-file args)
 					  (list :output-file
 						(get-output-pathname filename "o" nil nil nil)))))))
-		(unless *keep-gaz* (mdelete-file gaz))
+		(unless *keep-gaz* (delete-file gaz))
 		(when tem (truename tem))))))
 	 ((setf (car *split-files*) (+ (third *split-files*) section-length))))))
 
@@ -211,25 +210,23 @@
 			   (*DEFAULT-PATHNAME-DEFAULTS* #p"")
 			   *data*
 			   (*fasd-data* *fasd-data*)
-                           (*error-count* 0)
 			   (*init-name* *init-name*)
 			   (*function-filename* *function-filename*))
   (declare (ignore external-format))
 ;  (declare (special *c-debug* system-p))
 
-  (cond (*compiler-in-use*
-         (format t "~&The compiler was called recursively.~%~
-Cannot compile ~a.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*)))
-         (setq *error-p* t)
-         (return-from compile-file1 (values)))
-        (t (setq *error-p* nil)
-           (setq *compiler-in-use* t)))  
+  (when *compiler-in-use*
+    (catch *cmperr-tag*
+      (cmperr "~&The compiler was called recursively.~%~
+Cannot compile ~a.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*))))
+    (return-from compile-file1 (values)))
+  (setq *compiler-in-use* t)
   
   (unless (probe-file (merge-pathnames input-pathname *compiler-default-type*))
-    (format t "~&The source file ~a is not found.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*)))
-    (setq *error-p* t)
+    (catch *cmperr-tag*
+      (cmperr "~&The source file ~a is not found.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*))))
     (return-from compile-file1 (values)))
-  
+
   (when *compile-verbose*
     (format t "~&;; Compiling ~a.~%" (namestring (merge-pathnames input-pathname *compiler-default-type*))))
   
@@ -351,20 +348,17 @@ Cannot compile ~a.~%" (namestring (merge
 	 (cond (*record-call-info*
 		(dump-fn-data (get-output-pathname output-file "fn" name dir device))))
 	 (cond (o-file
-		(compiler-cc c-pathname o-pathname  )
+		(compiler-cc c-pathname o-pathname)
 		(cond ((probe-file o-pathname)
 		       (compiler-build o-pathname data-pathname)
 		       (when load (load o-pathname))
                        (when *compile-verbose*
 			 (print-compiler-info)
 			 (format t "~&;; Finished compiling ~a.~%" (namestring output-file))))
-		      (t 
-		       (format t "~&Your C compiler failed to compile the intermediate file.~%")
-		       (setq *error-p* t))))
+		      ((catch *cmperr-tag* (cmperr "~&Your C compiler failed to compile the intermediate file.~%")))))
 	       (*compile-verbose*
 		(print-compiler-info)
-		(format t "~&;; Finished compiling ~a.~%" (namestring output-file)
-			)))
+		(format t "~&;; Finished compiling ~a.~%" (namestring output-file))))
 	 (unless c-file (delete-file c-pathname))
 	 (unless h-file (delete-file h-pathname))
 	 (unless (or data-file #+ld-not-accept-data t system-p) (delete-file data-pathname))
@@ -374,8 +368,7 @@ Cannot compile ~a.~%" (namestring (merge
 	 (when (probe-file c-pathname) (delete-file c-pathname))
 	 (when (probe-file h-pathname) (delete-file h-pathname))
 	 (when (probe-file data-pathname) (delete-file data-pathname))
-	 (format t "~&No FASL generated.~%")
-	 (setq *error-p* t)
+	 (catch *cmperr-tag* (cmperr "No FASL generated.~%"))
 	 (values))))))
 
 (defun gazonk-name ()
@@ -530,37 +523,36 @@ Cannot compile ~a.~%" (namestring (merge
 	     (st gaz :direction :output)
 	     (prin1-cmp tem st))
 	   (let (*fasd-data*)
-	     (compile-file gaz 
-			   :h-file t 
-			   :c-file t
-			   :data-file t
-			   :o-file t))
-	   (let ((cn (get-output-pathname gaz "c" gaz ))
-		 (dn (get-output-pathname gaz "data" gaz ))
-		 (hn (get-output-pathname gaz "h" gaz ))
-		 (on (get-output-pathname gaz "o" gaz )))
-	     (with-open-file (st cn)
-			     (do () ((let ((a (read-line st)))
-				       (when (>= (si::string-match 
-						  #v"gazonk_[0-9]*_[0-9]*.h" a) 0)
-					 (format t "~%~d~%" a)
-					 a))))
-			     (si::copy-stream st *standard-output*))
-	     (with-open-file (st dn)
-			     (princ
-			      (let (f) (do nil ((eq 'eof (car (push (read st nil 'eof) f))) 
-						(vec-to-list (nreverse (cdr f))))))))
-	     (with-open-file (st hn)
-			     (si::copy-stream st *standard-output*))
-	     (when *disassemble-objdump*
-	       (si::copy-stream (open (concatenate 'string "|objdump --source " (namestring on)))
-				*standard-output*))
-	     (delete-file cn)
-	     (delete-file dn)
-	     (delete-file hn)
-	     (delete-file on)
-	     (unless *keep-gaz* (delete-file gaz))
-	     nil)))))
+	     (multiple-value-bind (f w e)
+		 (compile-file gaz :h-file t :c-file t :data-file t :o-file t)
+	       (declare (ignore f w))
+	       (unless e
+		 (let ((cn (get-output-pathname gaz "c" gaz ))
+		       (dn (get-output-pathname gaz "data" gaz ))
+		       (hn (get-output-pathname gaz "h" gaz ))
+		       (on (get-output-pathname gaz "o" gaz )))
+		   (with-open-file (st cn)
+		     (do () ((let ((a (read-line st)))
+			       (when (>= (si::string-match
+					  #v"gazonk_[0-9]*_[0-9]*.h" a) 0)
+				 (format t "~%~d~%" a)
+				 a))))
+		     (si::copy-stream st *standard-output*))
+		   (with-open-file (st dn)
+		     (princ
+		      (let (f) (do nil ((eq 'eof (car (push (read st nil 'eof) f)))
+					(vec-to-list (nreverse (cdr f))))))))
+		   (with-open-file (st hn)
+		     (si::copy-stream st *standard-output*))
+		   (when *disassemble-objdump*
+		     (si::copy-stream (open (concatenate 'string "|objdump --source " (namestring on)))
+				      *standard-output*))
+		   (delete-file cn)
+		   (delete-file dn)
+		   (delete-file hn)
+		   (delete-file on)
+		   (unless *keep-gaz* (delete-file gaz))
+		   nil))))))))
 
 (defun compiler-pass2 (c-pathname h-pathname system-p
 				  &aux 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpmulti.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpmulti.lsp
@@ -251,88 +251,11 @@
     (unwind-exit in nil (cons 'values (length forms)))
     (close-inline-blocks)))
 
-;; (defun c2values (forms)
-;;   (if *mv-var*
-;;     (let* ((*inline-blocks* 0)
-;; 	   (types (mapcar (lambda (x) (let ((x (coerce-to-one-value (info-type (cadr x))))) (if (type>= #tboolean x) t x))) forms))
-;; 	   (i 0)
-;; 	   (s (mapcar (lambda (x &aux (x (when x (write-to-string (incf i))))) (strcat "@" x "(#" x ")@")) (cdr forms)))
-;; 	   (s (strcat "({" (apply 'strcat s) "#0;})"))
-;; 	   (s (cons s (mapcar 'inline-type (cdr types))))
-;; 	   (in (list (inline-type (car types)) (flags) s (inline-args forms types))))
-;;       (unwind-exit in nil (cons 'values (length forms)))
-;;       (close-inline-blocks))
-;;    (prog1 (c2expr (or (car forms) (c1nil)))
-;; 	  (let ((*value-to-go* 'trash))
-;; 	    (dolist (f (cdr forms)) (c2expr f))))))
-
-;; (defun c2values (forms)
-;;   (if *mv-var*
-;;     (let* ((*inline-blocks* 0)
-;; 	   (types (mapcar (lambda (x) (let ((x (info-type (cadr x)))) (if (type>= #tboolean x) t x))) forms))
-;; 	   (i 0)
-;; 	   (s (mapcar (lambda (x &aux (x (when x (write-to-string (incf i))))) (strcat "@" x "(#" x ")@")) (cdr forms)))
-;; 	   (s (strcat "({" (apply 'strcat s) "#0;})"))
-;; 	   (s (cons s (mapcar 'inline-type (cdr types))))
-;; 	   (in (list (inline-type (car types)) (flags) s (inline-args forms types))))
-;;       (unwind-exit in nil (cons 'values (length forms)))
-;;       (close-inline-blocks))
-;;    (c2expr (car forms))))
-
-;; (defun c2values (forms &aux (base *vs*) (*vs* *vs*))
-;;   (when (and (eq *value-to-go* 'return-object)
-;; 	     (cdr forms)
-;; 	     (consp *current-form*)
-;; 	     (eq 'defun (car *current-form*))
-;; 	     (single-type-p (get-return-type (cadr *current-form*))))
-;;     (cmpwarn "Trying to return multiple values. ~%;But ~a was proclaimed to have single value.~%;Only first one will assured."
-;; 	     (cadr *current-form*)))
-  
-;;   (cond 
-;;    (*mv-var*
-;;     (let* ((*inline-blocks* 0)
-;; 	   (types (mapcar (lambda (x) (let ((x (info-type (cadr x)))) (if (type>= #tboolean x) t x))) forms))
-;; 	   (in (list (inline-type (car types))
-;; 		     (flags)
-;; 		     (list* (si::string-concatenate 
-;; 			     "({"
-;; 			     (apply 'si::string-concatenate
-;; 				    (let ((i 0)) 
-;; 				      (mapcan (lambda (x) (declare (ignore x))
-;; 						(let ((s (write-to-string (incf i))))
-;; 						  (list (si::string-concatenate "@" s "(#" s ")@")))) (cdr forms))))
-;; 			     "#0;})")
-;; 			    (mapcar 'inline-type (cdr types)))
-;; 		    (inline-args forms types))))
-;;       (unwind-exit in nil (cons 'values (length forms)))
-;;       (close-inline-blocks)
-;;       (return-from c2values nil)))
-;;    ((null forms)
-;;     (wt-nl "vs_base=vs_top=base+" base ";")
-;;     (base-used)
-;;     (wt-nl "vs_base[0]=Cnil;"))
-;;    (t
-;;     (dolist** (form forms)
-;; 	      (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* form)));FIXME
-;;     (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
-;;     (base-used)))
-;;   (unwind-exit 'fun-val nil (cons 'values (length forms))))
-
-
-(defun multiple-value-check (vrefs form)
-  (and (cdr vrefs)
-       (eq (car form) 'call-global)
-       (let ((fname (third form)))
-	 (cond ((and (symbolp fname)
-		     (single-type-p (get-return-type fname)))
-		(cmpwarn "~A was proclaimed to have only one return value. ~%;But you appear to want multiple values." fname))))))
-		
+
 (defun c1multiple-value-bind (args &aux (info (make-info))
                                    (vars nil) (vnames nil) init-form
                                    ss is ts body other-decls
-                                   (*vars* *vars*)
-;				   (ov *vars*)
-				   )
+                                   (*vars* *vars*))
   (when (or (endp args) (endp (cdr args)))
     (too-few-args 'multiple-value-bind 2 (length args)))
 
@@ -351,17 +274,22 @@
 
   (setq init-form (c1arg (cadr args) info))
 
+  (unless (let ((x (info-type (cadr init-form))))
+	    (if (cmpt x) (not (member nil x)) x))
+    (eliminate-src body)
+    (return-from c1multiple-value-bind init-form))
+
+  (when (single-type-p (info-type (cadr init-form)))
+    (return-from c1multiple-value-bind
+      (c1let-* (cons (cons (list (caar args) (cadr args)) (cdar args)) (cddr args)) t
+	       (cons init-form (mapcar (lambda (x) (declare (ignore x)) (c1nil)) (cdar args))))))
+
   (setq vars (nreverse vars))
   (let* ((tp (info-type (second init-form)))
-	 (tp (if (cmpt tp) (unless (member nil tp) tp) tp));FIXME
-	 (def (when tp #tnull))
-	 (tp (cond ((not tp) tp)
-		   ((single-type-p tp) (list tp))
-		   ((eq tp '*) (make-list (length vars) :initial-element t))
-		   ((cdr tp)))))
+	 (tp (if (eq tp '*) (make-list (length vars) :initial-element t) (cdr tp))))
     (do ((v vars (cdr v)) (t1 tp (cdr t1)))
 	((not v))
-	(set-var-init-type (car v) (if t1 (car t1) def))))
+	(set-var-init-type (car v) (if t1 (car t1) #tnull))))
 
   (dolist (v vars) (push-var v init-form))
 
@@ -398,8 +326,6 @@
 				   (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)
 				   top-data lbs)
 
-  (multiple-value-check vars init-form)
-
   (let* ((mv (make-var :type #tfixnum :kind 'lexical :loc (cs-push #tfixnum t)))
 	 (nv (1- (length vars)))
 	 (ns1 (stack-space init-form))
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpspecial.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpspecial.lsp
@@ -49,7 +49,7 @@
 (defun c1declare (args)
   (cmperr "The declaration ~s was found in a bad place." (cons 'declare args)))
 
-(defun c1the (args &aux info form type dtype);FIXME rethink this whole function
+(defun c1the (args &aux info form dtype);FIXME rethink this whole function
   (when (or (endp args) (endp (cdr args)))
     (too-few-args 'the 2 (length args)))
   (unless (endp (cddr args))
@@ -266,7 +266,7 @@
   (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
   
   (let* ((funid (si::funid (car args)))
-	 (funid (if (consp funid) (effective-safety-src funid) funid))
+	 (funid (mark-toplevel-src (if (consp funid) (effective-safety-src funid) funid)))
 	 (fn (afe (cons 'ce (current-env)) (funid-to-fn funid)))
 	 (tp (if fn (object-type fn) #tfunction))
 	 (info (make-info :type tp)))
@@ -279,146 +279,11 @@
 	   `(function ,info (call-global ,info ,funid)))
 	  ((let* ((fun (or f (make-fun :name 'lambda :src funid :c1cb t :fn fn :info (make-info :type '*))))
 		  (fd (if *prov* (list fun) (process-local-fun b fun funid tp))))
-	   (add-info info (cadadr fd))
-	   (when *prov* (setf (info-flags info) (logior (info-flags info) (iflags provisional))))
-	   `(function ,info ,fd))))))
-
-;; (defun c1function (args &optional (b 'cb) f &aux fd)
-
-;;   (when (endp args) (too-few-args 'function 1 0))
-;;   (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
-  
-;;   (let* ((funid (si::funid (car args)))
-;; 	 (funid (if (consp funid) (effective-safety-src funid) funid))
-;; 	 (fn (afe (cons 'ce (current-env)) (funid-to-fn funid)))
-;; 	 (tp (if fn (object-type fn) #tfunction))
-;; 	 (info (make-info :type tp)))
-;;     (cond ((setq fd (c1local-fun funid t))
-;; 	   (add-info info (cadr fd))
-;; 	   `(function ,info ,fd))
-;; 	  ((symbolp funid) 
-;; 	   (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0))
-;; 	   `(function ,info (call-global ,info ,funid)))
-;; 	  ((setq fd (process-local-fun b (or f (make-fun :name 'lambda :src funid :c1cb t :fn fn :info (make-info :type '*))) funid tp))
-;; 	   (add-info info (cadadr fd))
-;; 	   `(function ,info ,fd)))))
-
-;; (defun c1function (args &optional (provisional *provisional-inline*) b f)
-
-;;   (when (endp args) (too-few-args 'function 1 0))
-;;   (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
-  
-;;   (let* ((funid (si::funid (car args)))
-;; 	 (fn (funid-to-fn funid))
-;; 	 (tp (if fn (object-type fn) #tfunction))
-;; 	 (info (make-info :type tp)))
-;;     (cond ((and provisional (not (when (symbolp funid) (not (local-fun-p funid)))));FIXME
-;; 	   (let* ((df (fun-def-env fn))
-;; 		  (ce (current-env))
-;; 		  (res (list 'provfn info args (list ce df))))
-;; 	     (afe (cons 'ce ce) fn)
-;; 	     (afe (cons 'df df) fn)
-;; 	     (afe (cons 'prov res) fn)
-;; 	     res))
-;; 	  ((symbolp funid)
-;; 	   (let ((fd (c1local-fun funid t)))
-;; 	     (unless fd
-;; 	       (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0)))
-;; 	     (list 'function info (or fd (list 'call-global info funid)))))
-
-;; 	  ((let ((r (process-local-fun (or b 'cb) (or f (make-fun :name 'lambda :src funid :info (make-info :type '*))) funid tp)))
-;; 	     (add-info info (cadadr r))
-;; 	     (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects)))
-;; 	     `(function ,info ,r))))))
-
-;; (defun c1function (args &optional (provisional *provisional-inline*) b f)
-
-;;   (when (endp args) (too-few-args 'function 1 0))
-;;   (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
-  
-;;   (let* ((funid (si::funid (car args)))
-;; 	 (fn (funid-to-fn funid))
-;; 	 (tp (if fn (object-type fn) #tfunction))
-;; ;	 (tp (if fn (cmp-norm-tp `(member ,fn)) #tfunction))
-;; 	 (info (make-info :type tp)))
-;;     (cond (provisional
-;; 	   (or ;(gethash fn *fun-tp-hash*)
-;; 	       (setf (gethash fn *fun-tp-hash*)
-;; 		     (list 'provfn info args
-;; 			   (setf (gethash fn *fun-ev-hash*) (list (current-env) (fun-def-env fn)))))))
-;; 	  ((symbolp funid)
-;; 	   (let ((fd (c1local-fun funid t)))
-;; 	     (unless fd
-;; 	       (setf (info-sp-change info) (if (null (get funid 'no-sp-change)) 1 0)))
-;; 	     (list 'function info (or fd (list 'call-global info funid)))))
-
-;; 	  ((let ((r (process-local-fun (or b 'cb) (or f (make-fun :name 'lambda :src funid :info (make-info :type '*))) funid tp)))
-;; 	     (add-info info (cadadr r))
-;; 	     (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects)))
-;; 	     `(function ,info ,r))))))
-
-;; (defun c1function (args &optional (provisional *provisional-inline*) env)
-
-;;   (when (endp args) (too-few-args 'function 1 0))
-;;   (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
-  
-;;   (let* ((fun (car args))
-;; 	 (fid (si::funid-sym-p fun))
-;; 	 (fn (funid-to-fun (or fid fun)))
-;; 	 (tp (if fn `(member ,fn) #tfunction))  ; intentionally unnormalized
-;; 	 (info (make-info :type tp)))
-;;     (cond (provisional
-;; 	   (or (gethash fn *fun-tp-hash*)
-;; 	       (setf (gethash fn *fun-tp-hash*)
-;; 		     (list 'foo info args
-;; 			   (setf (gethash fn *fun-ev-hash*) (list *vars* *blocks* *tags* *funs*))))))
-;; 	  (fid
-;; 	   (let ((fd (c1local-fun fid t)))
-;; 	     (unless fd
-;; 	       (setf (info-sp-change info) (if (null (get fid 'no-sp-change)) 1 0)))
-;; 	     (list 'function info (or fd (list 'call-global info fid)))))
-
-;; 	  ((and (consp fun) (eq (car fun) 'lambda))
-;; 	   (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun)
-;; 	   (let ((r (process-local-fun-env env 'cb (make-fun :name 'lambda :src fun :info (make-info :type '*)) fun tp)))
-;; 	     (add-info info (cadadr r))
-;; 	     (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects)))
-;; 	     `(function ,info ,r)))
-;; 	  ((cmperr "The function ~s is illegal." fun)))))
-
-;; (defun c1function (args &optional (provisional *provisional-inline*) b f)
-
-;;   (when (endp args) (too-few-args 'function 1 0))
-;;   (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
-  
-;;   (let* ((fun (car args))
-;; 	 (fid (si::funid-sym-p fun))
-;; ;	 (ff (car (member fun *funs* :key (lambda (x) (when (fun-p x) (fun-src x))))))
-;; ;	 (fid (if ff (fun-name ff) fid))
-;; 	 (fn (funid-to-fun (or fid fun)))
-;; 	 (tp (if fn `(member ,fn) #tfunction))
-;; 	 (info (make-info :type tp)))
-;;     (cond (provisional
-;; 	   (or (gethash fn *fun-tp-hash*);FIXME?
-;; 	       (setf (gethash fn *fun-tp-hash*)
-;; 		     (list 'foo info args
-;; 			   (setf (gethash fn *fun-ev-hash*) (list *vars* *blocks* *tags* *funs*))))))
-;; 	  (fid
-;; 	   (let ((fd (c1local-fun fid)))
-;; 	     (unless fd
-;; 	       (setf (info-sp-change info) (if (null (get fid 'no-sp-change)) 1 0)))
-;; 	     (list 'function info (or fd (list 'call-global info fid)))))
-;; 	  ((and (consp fun) (eq (car fun) 'lambda))
-;; 	   (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun)
-;; 	   (let ((r (process-local-fun 
-;; 		     (or b 'cb)
-;; 		     (or f 
-;; ;			 (car (member ff *funs* :key (lambda (x) (when (fun-p x) (fun-src x)))))
-;; 			 (make-fun :name 'lambda :src fun :info (make-info :type '*))) fun tp)))
-;; 	     (add-info info (cadadr r))
-;; 	     (setf (info-flags info) (logandc2 (info-flags info) (iflags side-effects)))
-;; 	     `(function ,info ,r)))
-;; 	  ((cmperr "The function ~s is illegal." fun)))))
+	     (add-info info (cadadr fd))
+	     (when *prov*
+	       (pushnew funid *prov-src*)
+	       (setf (info-flags info) (logior (info-flags info) (iflags provisional))))
+	     `(function ,info ,fd))))))
 
 (defun update-closure-indices (cl)
   (mapc (lambda (x &aux (y (var-ref-ccb (car x))))
@@ -465,139 +330,6 @@
 					-1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lam))))))
 		  (unwind-exit (list 'vv (fun-vv fun)))))))))
 
-;; (defun c2function (funob);FIXME
-;;   (case (car funob)
-;;         (call-global
-;;          (unwind-exit (list 'symbol-function (add-symbol (caddr funob)))))
-;;         (call-local
-;; 	 (let* ((funob (caddr funob))(fun (pop funob)))
-;; 	   (unwind-exit (if (cadr funob) (list 'ccb-vs (fun-ref-ccb fun)) (list 'vs* (fun-ref fun))))))
-;;         (otherwise
-;; 	 (let* ((fun (pop funob))
-;; 		(lam (car funob))
-;; 		(cl (fun-call fun))
-;; 		(sig (car cl))
-;; 		(at (car sig))
-;; 		(rt (cadr sig))
-;; 		(ha (mapcar (lambda (x) `',x) (export-call cl)))
-;; 		(clc `(let ((si::f #'(lambda nil nil)))
-;; 			(si::add-hash si::f ,@ha)
-;; ;			(si::call si::f)
-;; 			si::f)))
-	   
-;; 	   (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam)
-;; 		    *local-funs* :key 'fourth)
-	   
-;; 	   (cond (*clink*
-;; 		  (let ((clc (cons '|#,| clc)))
-;; 		    (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) 
-;; 				       (or (fun-vv fun) clc)
-;; 				       (new-proclaimed-argd at rt) (argsizes at rt (xa lam))
-;; 				       *clink*))
-;; 		    (unless (fun-vv fun)
-;; 		      (setf (fun-vv fun) clc))))
-;; 		 (t  
-;; 		  (unless (fun-vv fun)
-;; 		    (setf (fun-vv fun)
-;; 			  (cons '|#,| `(init-function 
-;; 					,clc
-;; 					,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun)))
-;; 					nil nil
-;; 					-1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lam))))))
-;; 		  (unwind-exit (list 'vv (fun-vv fun)))))))))
-
-;; (defun c2function (funob);FIXME
-;;   (case (car funob)
-;;         (call-global
-;;          (unwind-exit (list 'symbol-function (add-symbol (caddr funob)))))
-;;         (call-local
-;; 	 (let* ((funob (caddr funob))(fun (pop funob)))
-;; 	   (unwind-exit (if (cadr funob) (list 'ccb-vs (fun-ref-ccb fun)) (list 'vs* (fun-ref fun))))))
-;;         (otherwise
-;; 	 (let* ((fun (pop funob))
-;; 		(lam (car funob))
-;; 		(cl (fun-call fun))
-;; 		(sig (car cl))
-;; 		(at (car sig))
-;; 		(rt (cadr sig))
-;; 		(ha (mapcar (lambda (x) `',x) (export-call cl)))
-;; 		(clc `(let ((si::f #'(lambda nil nil)))
-;; 			(si::add-hash si::f ,@ha)
-;; 			(si::call si::f))))
-	   
-;; 	   (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun lam)
-;; 		    *local-funs* :key 'fourth)
-	   
-;; 	   (cond (*clink*
-;; 		  (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) 
-;; 				     (or (fun-vv fun) (1+ *next-vv*))
-;; 				     (new-proclaimed-argd at rt) (argsizes at rt (xa lam))
-;; 				     *clink*))
-;; 		  (unless (fun-vv fun)
-;; 		    (push-data-incf nil)
-;; 		    (setf (fun-vv fun) *next-vv*)
-;; 		    (add-init `(si::setvv ,(fun-vv fun) ,clc) t)))
-;; 		 (t  
-;; 		  (unless (fun-vv fun)
-;; 		    (push-data-incf nil)
-;; 		    (setf (fun-vv fun) *next-vv*)
-;; 		    (add-init
-;; 		     `(si::setvv ,(fun-vv fun)
-;; 				 (si::init-function 
-;; 				  ,clc
-;; 				  ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun)))
-;; 				  nil nil
-;; 				  -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa lam)))) t))
-;; 		  (unwind-exit (list 'vv (fun-vv fun)))))))))
-
-;; (defun c2function (funob);FIXME
-;;   (case (car funob)
-;;         (call-global
-;;          (unwind-exit (list 'symbol-function (add-symbol (caddr funob)))))
-;;         (call-local
-;; 	 (let* ((funob (caddr funob))
-;; 		(fun (pop funob)))
-;; 	   (if (car funob)
-;; 	       (unwind-exit (list 'ccb-vs (fun-ref-ccb fun)))
-;; 	     (unwind-exit (list 'vs* (fun-ref fun))))))
-;;         (otherwise
-;; 	 (let* ((fun (pop funob))
-;; 		(funob (car funob))
-;; 		(cl (fun-call fun))
-;; 		(sig (pop cl))
-;; 		(cle (pop cl))
-;; 		(at (car sig))
-;; 		(rt (cadr sig))
-;; 		(ha (mapcar (lambda (x) `',x) (cons sig (cons cle cl))))
-;; 		(clc `(let ((si::f #'(lambda nil nil)))
-;; 			(si::add-hash si::f ,@ha)
-;; 			(si::call si::f))))
-	   
-;; 	   (pushnew (list 'closure (if (null *clink*) nil (cons 0 0)) *ccb-vs* fun funob)
-;; 		    *local-funs* :key 'fourth)
-	   
-;; 	   (cond (*clink*
-;; 		  (unwind-exit (list 'make-cclosure (fun-cfun fun) (fun-name fun) 
-;; 				     (or (fun-vv fun) (1+ *next-vv*))
-;; 				     (new-proclaimed-argd at rt) (argsizes at rt (xa funob))
-;; 				     *clink*))
-;; 		  (unless (fun-vv fun)
-;; 		    (push-data-incf nil)
-;; 		    (setf (fun-vv fun) *next-vv*)
-;; 		    (add-init `(si::setvv ,(fun-vv fun) ,clc) t)))
-;; 		 (t  
-;; 		  (unless (fun-vv fun)
-;; 		    (push-data-incf nil)
-;; 		    (setf (fun-vv fun) *next-vv*)
-;; 		    (add-init
-;; 		     `(si::setvv ,(fun-vv fun)
-;; 				 (si::init-function 
-;; 				  ,clc
-;; 				  ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun)))
-;; 				  nil nil
-;; 				  -1 ,(new-proclaimed-argd at rt) ,(argsizes at rt (xa funob)))) t))
-;; 		  (unwind-exit (list 'vv (fun-vv fun)))))))))
-
 (si:putprop 'symbol-function 'wt-symbol-function 'wt-loc)
 (si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc)
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptag.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptag.lsp
@@ -86,46 +86,6 @@
 	   (lambda (x) (setf (tag-ref-clb x) t))
 	   (lambda (x) (setf (tag-ref x) t))))
 
-;; (defun ref-tags1 (form tags &aux (i (cadr form)))
-;;   (dolist (tag tags)
-;;     (when (member tag (info-tref-ccb i))
-;;       (setf (tag-ref-ccb tag) t))
-;;     (when (member tag (info-tref-clb i))
-;;       (setf (tag-ref-clb tag) t))
-;;     (when (member tag (info-tref i))
-;;       (setf (tag-ref tag) t))))
-
-;; (defun ref-tags (form tags &optional l)
-;;   (cond ((not l) 
-;; 	 (cond (*fast-ref* (ref-tags1 form tags))
-;; 	       ((let* ((l (list (info-tref (cadr form)) (info-tref-ccb (cadr form)) (info-tref-clb (cadr form))))
-;; 		       (l (mapcar (lambda (x) (intersection x tags)) l))
-;; 		       (l (mapcar (lambda (y) (mapcar (lambda (x) (cons x nil)) y)) l)))
-;; 		  (ref-tags form tags l)
-;; 		  (let* (y (x (member-if (lambda (x) (setq y (member nil x :key 'cdr))) l)))
-;; 		    (when y
-;; 		      (cmpwarn "~s Tag ~s reffed in info but not in form" (length (ldiff l x)) (tag-name (caar y)))))))))
-;; 	((atom form))
-;; 	((eq (car form) 'go)
-;; 	 (let* ((tref (cddr form))
-;; 		(tag (pop tref))
-;; 		(ccb (pop tref))
-;; 		(clb (car tref)))
-;; 	   (when (member tag tags)
-;; 	     (cond (ccb (setf (tag-ref-ccb tag) t) 
-;; 			(let* ((x (cadr l))(x (assoc tag x)))
-;; 			  (if x (rplacd x t) (cmpwarn "ccb Tag ~s reffed in form but not in info" (tag-name tag)))))
-;; 		   (clb (setf (tag-ref-clb tag) t)
-;; 			(let* ((x (caddr l))(x (assoc tag x))) 
-;; 			  (if x (rplacd x t) (cmpwarn "clb Tag ~s reffed in form but not in info" (tag-name tag)))))
-;; 		   ((setf (tag-ref tag) t)
-;; 		    (let* ((x (car l))(x (assoc tag x))) 
-;; 		      (if x (rplacd x t) (cmpwarn "nil Tag ~s reffed in form but not in info" (tag-name tag))))))
-;; 	     (keyed-cmpnote (list 'tag-ref (tag-name tag)) "Tag is referred with barrier ~s" (tag-name tag) (if ccb 'cb (if clb 'lb))))
-;; 	   (ref-tags tref tags l)));FIXME?
-;; 	(t (ref-tags (car form) tags l) (ref-tags (cdr form) tags l))))
-
-
 
 ;FIXME separate pass with no repetitive allocation
 (defvar *ft* nil)
@@ -175,6 +135,7 @@
 	l))
 
 (defun mch-z (z i &aux (f (cdr (assoc z *ft*))))
+  (declare (ignore i));FIXME
   (if f (mch-set z (or-mch f)) (mch)));FIXME ccb-ch (if i (or-mch f) f)
 ;; The right way to do this is to throw ccb assignments via tag-throw on go into something like *ft*
 
@@ -253,7 +214,9 @@
                        (*value-to-go* 'trash))
                   (c2expr (car l))
                   (wt-label *exit*))
-                (unless (type>= #tnil (info-type (cadar l))) (unwind-exit nil)))));(eq (caar l) 'go)
+		;gcc lintian, lacking noreturn attributes prevents
+		;(unless (type>= #tnil (info-type (cadar l))) (unwind-exit nil))
+		(unwind-exit nil))))
     (cond (written (setq written nil))
           ((typep (car l) 'tag)
 	   (wt-switch-case (tag-switch (car l)))
@@ -415,7 +378,8 @@
 					    ((not skip)
 					     (when cs
 					       (setq st (type-and st (tp-not rt)) cs nil))
-					     t)))
+					     t)
+					    (t (eliminate-src b) nil)))
 				    body))
 	       (body (mapcar (lambda (x) (if (tgs-p x) (make-tag :name x :ref t :switch (if (typep x 'fixnum) x "default")) x)) body))
 	       trv
@@ -429,213 +393,6 @@
 	      (car ls)
 	    (list 'switch info switch-op-1 body)))))
 
-;; (defun c1switch(form &aux (*tags* *tags*) st ls)
-;;   (let* ((switch-op  (car form))
-;; 	 (body (cdr form))
-;; 	 (info (make-info :type #tnull))
-;; 	 (switch-op-1 (c1arg switch-op info)))
-;;     (cond ((and (typep (second switch-op-1 ) 'info)
-;; 		(type>= #tfixnum (setq st (info-type (second switch-op-1)))))
-;; 	   ;;optimize into a C switch:
-;; 	   ;;If we ever get GCC to do switch's with an enum arg,
-;; 	   ;;which don't do bounds checking, then we will
-;; 	   ;;need to carry over the restricted range.
-;; 	   ;;more generally the compiler should carry along the original type
-;; 	   ;;decl, not just the coerced one.  This needs another slot in
-;; 	   ;;info.
-;; 	   (or (member t body) (setq body (append body (list t))))
-;; 	   ;; Remove duplicate tags in C switch statement -- CM 20031112
-;; 	   (setq body
-;; 		 (let (tags new-body)
-;; 		   (dolist (b body)
-;; 		     (cond ((or (symbolp b) (integerp b))
-;; 			    (unless (member b tags)
-;; 			      (push b tags)
-;; 			      (push b new-body)))
-;; 			   (t
-;; 			    (push b new-body))))
-;; 		   (nreverse new-body)))
-;; 	   (setq body
-;; 		 (let* (skip cs new-body dfp rt)
-;; 		   (dolist (b body (nreverse new-body))
-;; 		     (cond ((or (symbolp b) (integerp b))
-;; 			    (unless cs (setq cs t skip t))
-;; 			    (let* ((e (info-type (second (c1arg b))))
-;; 				   (df (type>= #tsymbol e))
-;; 				   (e (if df (cmp-norm-tp `(and integer (not ,rt))) e)))
-;; 			      (cond ((and df dfp) (cmperr "default tag must be last~%"))
-;; 				    ((type-and (info-type (second switch-op-1)) e)
-;; 				     (setq skip nil dfp df rt (type-or1 rt e) 
-;; 					   st (type-and st (cmp-norm-tp `(not ,e))))
-;; 				     (push b new-body))
-;; 				    ((keyed-cmpnote 'branch-elimination
-;; 						    "Eliminating unreachable switch ~s" b)))))
-;; 			   ((not skip) (setq cs nil) (push b new-body))))))
-;; 	   (when (and (not st) 
-;; 		      (not (cdr (setq ls (member-if 'consp body))))
-;; ;		      (= 1 (count-if (lambda (x) (or (consp x) (symbolp x))) body));FIXME
-;; 		      (ignorable-form switch-op-1))
-;; 	     (return-from c1switch (c1expr (car ls))))
-;; 	   (setq body
-;; 		 (mapcar
-;; 		  (lambda (x)
-;; 		      (cond ((or (symbolp x) (integerp x))
-;; 			     (let ((tag (make-tag :name x :ref
-;; 						  nil
-;; 						  :ref-ccb nil
-;; 						  :ref-clb nil)))
-;; 			       (cond((typep x #tfixnum)
-;; 				     (setf (tag-ref tag) t)
-;; 				     (setf (tag-switch tag) x))
-;; 				    ((eq t x)
-;; 				     (setf (tag-ref tag) t)
-;; 				     (setf (tag-switch tag) "default")))
-;; 			       tag))
-;; 			    (t x)))
-;; 		  body))
-;; 	   (let ((d (c1arg `(tagbody ,@body) info)))
-;; 	     (setf (info-type info) (info-type (cadr d)))
-;; 	     (list* 'switch info switch-op-1 (cddr d))))
-;; 	  ((c1expr (cmp-macroexpand-1 (cons 'switch form)))))))
-
-;; (defun c1switch(form  &aux (*tags* *tags*) st ls)
-;;   (let* ((switch-op  (car form))
-;; 	 (body (cdr form))
-;; 	 (switch-op-1 (c1expr switch-op)))
-;;     (cond ((and (typep (second switch-op-1 ) 'info)
-;; 		(type>= #tfixnum (setq st (info-type (second switch-op-1)))))
-;; 	   ;;optimize into a C switch:
-;; 	   ;;If we ever get GCC to do switch's with an enum arg,
-;; 	   ;;which don't do bounds checking, then we will
-;; 	   ;;need to carry over the restricted range.
-;; 	   ;;more generally the compiler should carry along the original type
-;; 	   ;;decl, not just the coerced one.  This needs another slot in
-;; 	   ;;info.
-;; 	   (or (member t body) (setq body (append body (list t))))
-;; 	   ;; Remove duplicate tags in C switch statement -- CM 20031112
-;; 	   (setq body
-;; 		 (let (tags new-body)
-;; 		   (dolist (b body)
-;; 		     (cond ((or (symbolp b) (integerp b))
-;; 			    (unless (member b tags)
-;; 			      (push b tags)
-;; 			      (push b new-body)))
-;; 			   (t
-;; 			    (push b new-body))))
-;; 		   (nreverse new-body)))
-;; 	   (setq body
-;; 		 (let* (skip cs new-body dfp rt)
-;; 		   (dolist (b body (nreverse new-body))
-;; 		     (cond ((or (symbolp b) (integerp b))
-;; 			    (unless cs (setq cs t skip t))
-;; 			    (let* ((e (info-type (second (c1expr b))))
-;; 				   (df (type>= #tsymbol e))
-;; 				   (e (if df (cmp-norm-tp `(and integer (not ,rt))) e)))
-;; 			      (cond ((and df dfp) (cmperr "default tag must be last~%"))
-;; 				    ((type-and (info-type (second switch-op-1)) e)
-;; 				     (setq skip nil dfp df rt (type-or1 rt e) 
-;; 					   st (type-and st (cmp-norm-tp `(not ,e))))
-;; 				     (push b new-body))
-;; 				    ((keyed-cmpnote 'branch-elimination
-;; 						    "Eliminating unreachable switch ~s" b)))))
-;; 			   ((not skip) (setq cs nil) (push b new-body))))))
-;; 	   (when (and (not st) 
-;; 		      (not (cdr (setq ls (member-if 'consp body))))
-;; ;		      (= 1 (count-if (lambda (x) (or (consp x) (symbolp x))) body));FIXME
-;; 		      (ignorable-form switch-op-1))
-;; 	     (return-from c1switch (c1expr (car ls))))
-;; 	   (setq body
-;; 		 (mapcar
-;; 		  (lambda (x)
-;; 		      (cond ((or (symbolp x) (integerp x))
-;; 			     (let ((tag (make-tag :name x :ref
-;; 						  nil
-;; 						  :ref-ccb nil
-;; 						  :ref-clb nil)))
-;; 			       (cond((typep x #tfixnum)
-;; 				     (setf (tag-ref tag) t)
-;; 				     (setf (tag-switch tag) x))
-;; 				    ((eq t x)
-;; 				     (setf (tag-ref tag) t)
-;; 				     (setf (tag-switch tag) "default")))
-;; 			       tag))
-;; 			    (t x)))
-;; 		  body))
-;; 	   (let ((tem (c1tagbody `(,@ body switch-finish-label))))
-;; 	     (add-info (cadr tem) (cadr switch-op-1))
-;; 	     (list* 'switch (cadr tem) switch-op-1 (cddr tem))))
-;; 	  (t (c1expr (cmp-macroexpand-1 (cons 'switch form)))))))
-
-;; (defun c1switch(form  &aux (*tags* *tags*) st ls)
-;;   (let* ((switch-op  (car form))
-;; 	 (body (cdr form))
-;; 	 (switch-op-1 (c1expr switch-op)))
-;;     (cond ((and (typep (second switch-op-1 ) 'info)
-;; 		(type>= #tfixnum (setq st (info-type (second switch-op-1)))))
-;; 	   ;;optimize into a C switch:
-;; 	   ;;If we ever get GCC to do switch's with an enum arg,
-;; 	   ;;which don't do bounds checking, then we will
-;; 	   ;;need to carry over the restricted range.
-;; 	   ;;more generally the compiler should carry along the original type
-;; 	   ;;decl, not just the coerced one.  This needs another slot in
-;; 	   ;;info.
-;; 	   (or (member t body) (setq body (append body (list t))))
-;; 	   ;; Remove duplicate tags in C switch statement -- CM 20031112
-;; 	   (setq body
-;; 		 (let (tags new-body)
-;; 		   (dolist (b body)
-;; 		     (cond ((or (symbolp b) (integerp b))
-;; 			    (unless (member b tags)
-;; 			      (push b tags)
-;; 			      (push b new-body)))
-;; 			   (t
-;; 			    (push b new-body))))
-;; 		   (nreverse new-body)))
-;; 	   (setq body
-;; 		 (let* (skip cs new-body dfp rt)
-;; 		   (dolist (b body (nreverse new-body))
-;; 		     (cond ((or (symbolp b) (integerp b))
-;; 			    (unless cs (setq cs t skip t))
-;; 			    (let* ((e (info-type (second (c1expr b))))
-;; 				   (df (type>= #tsymbol e))
-;; 				   (e (if df (cmp-norm-tp `(and integer (not ,rt))) e)))
-;; 			      (cond ((and df dfp) (cmperr "default tag must be last~%"))
-;; 				    ((type-and (info-type (second switch-op-1)) e)
-;; 				     (setq skip nil dfp df rt (type-or1 rt e) 
-;; 					   st (type-and st (cmp-norm-tp `(not ,e))))
-;; 				     (push b new-body))
-;; 				    ((keyed-cmpnote 'branch-elimination
-;; 						    "Eliminating unreachable switch ~s" b)))))
-;; 			   ((not skip) (setq cs nil) (push b new-body))))))
-;; 	   (when (and (not st) 
-;; 		      (not (cdr (setq ls (member-if 'consp body))))
-;; ;		      (= 1 (count-if (lambda (x) (or (consp x) (symbolp x))) body));FIXME
-;; 		      (ignorable-form switch-op-1))
-;; 	     (return-from c1switch (c1expr (car ls))))
-;; 	   (setq body
-;; 		 (mapcar
-;; 		  (lambda (x)
-;; 		      (cond ((or (symbolp x) (integerp x))
-;; 			     (let ((tag (make-tag :name x :ref
-;; 						  nil
-;; 						  :ref-ccb nil
-;; 						  :ref-clb nil)))
-;; 			       (cond((typep x #tfixnum)
-;; 				     (setf (tag-ref tag) t)
-;; 				     (setf (tag-switch tag) x))
-;; 				    ((eq t x)
-;; 				     (setf (tag-ref tag) t)
-;; 				     (setf (tag-switch tag) "default")))
-;; 			       tag))
-;; 			    (t x)))
-;; 		  body))
-;; 	   (let ((tem (c1tagbody
-;; 			`(,@ body
-;; 			  switch-finish-label))))
-;; 	     (nconc (list 'switch (cadr tem) switch-op-1)
-;; 		    (cddr tem))
-;; 	     ))
-;; 	  (t (c1expr (cmp-macroexpand-1 (cons 'switch form)))))))
 
 (defun c2switch (op body &aux (*inline-blocks* 0)(*vs* *vs*))
   (let ((args (inline-args (list op) `(,#tfixnum))))
@@ -646,18 +403,6 @@
     (unwind-exit nil)
     (close-inline-blocks)))
 
-;; (defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*))
-;;   (let ((args (inline-args (list op) `(,#tfixnum))))
-;;     (wt-nl "")
-;;     (wt-inline-loc "switch(#0){" args)
-;;     (cond (ref-ccb (c2tagbody-ccb body))
-;; 	  (ref-clb (c2tagbody-clb body))
-;; 	  (t (c2tagbody-local body)))
-;;     (wt "}")
-;;     (unwind-exit nil)
-;;     (close-inline-blocks)))
-	
-
 
 ;; SWITCH construct for Common Lisp. (TEST &body BODY) (in package SI)
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptop.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptop.lsp
@@ -219,17 +219,11 @@
                     (when *compile-print* (print-current-form))
                     (t1expr (cmp-macroexpand-1 form)))
                    ((get fun 'c1) (t1ordinary form))
-                   ((setq fd (macro-function fun *macrolet-env*))
-		    (let ((res
-			   (cmp-expand-macro fd fun (copy-list (cdr form)))
-			   ))
-		      (t1expr res)))
-                   (t (t1ordinary form))
-                   ))
+                   ((setq fd (cmp-macro-function fun))
+		    (t1expr (cmp-expand-macro-w fd form)))
+                   (t (t1ordinary form))))
             ((consp fun) (t1ordinary form))
-            (t (cmperr "~s is illegal function." fun)))
-           )))
-  )
+            (t (cmperr "~s is illegal function." fun)))))))
 
 (defun declaration-type (type)
   (cond ((equal type "") "void")
@@ -480,7 +474,8 @@
 			(ndbctxt (portable-source (cddr form) t))))))
 	       (multiple-value-bind `(,(car form) ,(cadr form) ,(portable-source (caddr form))
 				      ,@(let ((r (remove-if (lambda (x) (or (not (si::specialp x)) 
-									    (is-declared-special x (cdddr form)))) (cadr form))))
+									    (is-declared-special x (cdddr form))))
+							    (cadr form))))
 					  (when r `((declare (special ,@r)))))
 				      ,@(ndbctxt (portable-source (cdddr form) t))))
 	       ((case ccase ecase) `(,(car form) ,(portable-source (cadr form))
@@ -524,7 +519,7 @@
     (dolist (bb (cdr l))
       (let ((b (if (member (car bb) '(type ftype)) (cdr bb) bb)))
 	(cond ((eq (car b) 'optimize) (if ro (push `(declare ,b) dd) (push `(declare ,b) ad)))
-	      ((eq (car b) 'class)
+	      ((eq (car b) 'class);FIXME pcl
 	       (unless (<= (length b) 3)
 		 (cmperr "Unknown class declaration: ~s" b))
 	       (if (member (cadr b) auxs) (push `(declare ,b) ad) (push `(declare ,b) dd)))
@@ -537,42 +532,6 @@
 		  (when q
 		    (push `(declare (,@z ,@q)) dd))))))))))
 
-;; (defun split-decls (auxs decls &aux ad dd)
-;;   (dolist (l decls (list (nreverse ad) (nreverse dd)))
-;;     (dolist (bb (cdr l))
-;;       (let ((b (if (eq (car bb) 'type) (cdr bb) bb)))
-;; 	(cond ((eq (car b) 'optimize) (push `(declare ,b) dd))
-;; 	      ((eq (car b) 'class)
-;; 	       (unless (<= (length b) 3)
-;; 		 (cmperr "Unknown class declaration: ~s" b))
-;; 	       (if (member (cadr b) auxs) (push `(declare ,b) ad) (push `(declare ,b) dd)))
-;; 	      ((multiple-value-bind
-;; 		(tt q)
-;; 		(list-split (cdr b) auxs)
-;; 		(let ((z (if (eq b bb) (list (car bb)) (list (car bb) (cadr bb)))))
-;; 		  (when tt
-;; 		    (push `(declare (,@z ,@tt)) ad))
-;; 		  (when q
-;; 		    (push `(declare (,@z ,@q)) dd))))))))))
-
-;; (defun split-decls (auxs decls &aux ad dd)
-;;   (dolist (l decls (list (nreverse ad) (nreverse dd)))
-;;     (dolist (bb (cdr l))
-;;       (let ((b (if (eq (car bb) 'type) (cdr bb) bb)))
-;; 	(cond ((eq (car b) 'optimize) (push `(declare ,b) dd))
-;; 	      ((eq (car b) 'class)
-;; 	       (unless (<= (length b) 3)
-;; 		 (cmperr "Unknown class declaration: ~s" b))
-;; 	       (if (member (cadr b) auxs) (push `(declare ,b) ad) (push `(declare ,b) dd)))
-;; 	      ((eq (car b) 'special) (push `(declare ,b) ad))
-;; 	      ((multiple-value-bind
-;; 		(tt q)
-;; 		(list-split (cdr b) auxs)
-;; 		(let ((z (if (eq b bb) (list (car bb)) (list (car bb) (cadr bb)))))
-;; 		  (when tt
-;; 		    (push `(declare (,@z ,@tt)) ad))
-;; 		  (when q
-;; 		    (push `(declare (,@z ,@q)) dd))))))))))
 
 (defun split-ctps (auxs ctps)
   (let (ad dd)
@@ -666,6 +625,9 @@
 (defun effective-safety (decls)
   (max (decl-safety decls) (this-safety-level)))
 
+(defun remove-ignore-decls (decls)
+  (mapcar (lambda (x) (remove-if (lambda (y) (when (consp y) (eq (car y) 'ignore))) x)) decls))
+
 (defun new-defun-args (args tag)
   (let* ((nm (si::funid-to-sym (car args)))
 	 (args (ttl-tag-src args tag nm))
@@ -680,7 +642,7 @@
 	    (sl (effective-safety decls))
 	    (s (> sl 0))
 	    (od (split-decls regs decls))
-	    (rd (pop od))
+	    (rd (remove-ignore-decls (pop od)))
 	    (oc (split-ctps regs ctps))
 	    (rc (pop oc))
 	    ;FIXME check-type must refer to top regular variable binding, but must be beneath argument number logic
@@ -691,7 +653,7 @@
 	    (nr (length regs))
 	    (regs (or regs (when narg (list +first+))))
 	    (m (min 63 (mll ll)))
-	    (args `(,@(car od) ,@oc ,@args))
+	    (args `(,@(remove-ignore-decls (car od)) ,@oc ,@args))
 	    (opts (if narg (cons narg opts) opts))
 	    (args (if narg (cons `(declare ((integer ,(- m) ,m) ,narg)) args) args))
 	    (rc (if narg (cons `(declare (hint (integer ,(- m) ,m) ,narg)) rc) rc))
@@ -862,9 +824,9 @@
 (defun c1bind-reg-clv (args)
   (declare (ignore args))
   (list 'bind-reg-clv (make-info :type #tt :flags (iflags side-effects))))
-(defun c2bind-reg-clv (&aux x clb var)
+(defun c2bind-reg-clv (&aux x var)
   (do nil
-      ((not (setq x (pop *reg-clv*) clb (pop x) var (car x))));FIXME ? eliminate clb var here
+      ((not (setq x (pop *reg-clv*) var (cadr x))))
       (wt-nl)
       (setf (var-ref var) (vs-push));FIXME ? clb and ccb vars just appear in info-ref-ccb, only need push clb
       (wt-vs (var-ref var)) (wt "= " `(gen-loc :object (cvar ,(var-loc var))) ";")
@@ -969,7 +931,7 @@
 	 (sig (lam-e-to-sig l))
 	 (rd (cdar *recursion-detected*))
 	 (rep (when rd (not (type<= (cadr sig) (cadr osig)))))
-	 (sig (if (and osig rep)  (list (car sig) (bbump-tp (cadr sig))) sig)))
+	 (sig (if (and osig rep)  (list (car sig) (bbump-tp (type-or1 (cadr osig) (cadr sig)))) sig)))
     (setf (car e) sig); (cadr e) *callees*)
     (cond (rep
 	   (keyed-cmpnote (list name 'recursion) "Reprocessing ~s: ~s ~s" name osig sig)
@@ -1011,7 +973,117 @@
       (when (symbol-package name) (unless (eq name 'lambda) (push (cons name (apply 'si::make-function-plist e)) si::*sig-discovery-props*))))
     l))
 
-(defun t1defun (args &aux *warning-note-stack*)
+;; top-level lex-ref walker
+
+;; (defvar *unused* nil)
+;; (defvar *lsyms* nil)
+
+
+;; (defun decl-ref (x decls)
+;;   (dolist (d decls (specialp x))
+;;     (dolist (c (cdr d))
+;;       (case (car c)
+;; 	((ignore ignorable special)
+;; 	 (when (member x (cdr c) :test 'equal)
+;; 	   (return-from decl-ref t)))))))
+
+;; (defun unused-bindings (form)
+;;   (if (atom form)
+;;       (let ((x (car (member-if (lambda (x) (when (car x) (eq (caar x) form))) *lsyms*)))) (when x (setf (cdar x) t)))
+;;       (case (car form)
+;; 	((let let* flet labels macrolet)
+;; 	 (multiple-value-bind (doc decls) (parse-body-header (cddr form))
+;; 	   (declare (ignore doc))
+;; 	   (let* ((c (mapcar (lambda (x) (if (atom x) (list x) x)) (cadr form)))
+;; 		  (b (mapcar (lambda (x)
+;; 			       (case (car form)
+;; 				 ((let let*) (list (cons (car x) (decl-ref (car x) decls)) nil))
+;; 				 ((flet labels) (list nil (cons (car x) (decl-ref `(function ,(car x)) decls))))
+;; 				 (macrolet (list nil x))))
+;; 			     c))
+;; 		  (d (cons *lsyms* (maplist 'identity b)))
+;; 		  (b (nreconc b *lsyms*)))
+;; 	     (mapc (lambda (x &aux (*lsyms* (case (car form) (let* (pop d))(labels b)(otherwise *lsyms*))))
+;; 		     (unused-bindings (case (car form)
+;; 					((let let*) (cadr x))
+;; 					(otherwise (cons 'lambda (cdr x))))))
+;; 		   c)
+;; 	     (let ((*lsyms* b)) (mapc 'unused-bindings (cddr form)))
+;; 	     (mapc (lambda (x) (unless (cdr (or (car x) (cadr x))) (push x *unused*)))
+;; 		   (ldiff b *lsyms*)))))
+;; 	((quote go declare))
+;; 	((block return-from eval-when) (mapc 'unused-bindings (cddr form)))
+;; 	(tagbody (mapc (lambda (x) (typecase x ((or integer symbol))(otherwise (unused-bindings x)))) (cdr form)))
+;; 	(the (unused-bindings (caddr form)))
+;; 	(setq (do ((form (cddr form) (cddr form)))((not form))(unused-bindings (car form))))
+;; 	(lambda (unused-bindings (blla (cadr form) nil '(foo) (cddr form))))
+;; 	(function (let ((x (cadr form)))
+;; 		    (etypecase x
+;; 		      ((or symbol (cons (member setf) (cons symbol null)))
+;; 		       (let ((x (car (member x *lsyms* :key 'caadr :test 'equal))))
+;; 			 (when x (unless (cdadr x) (setf (cdadr x) t)))))
+;; 		      ((cons (member lambda) t) (unused-bindings x)))))
+;; 	(otherwise (let* ((form (if (symbolp (car form)) form (cons 'funcall form)));?
+;; 			  (x (car (member (car form) *lsyms* :key 'caadr)))
+;; 			  (fd (or (let ((c (cadr x))) (when (consp (cdr c)) (eval (defmacro-lambda (pop c) (pop c) c))))
+;; 				  (unless x (macro-function (car form)))))
+;; 			  (f1 (if fd (funcall fd form nil) form)))
+;; 		     (cond ((eq form f1) (when x (setf (cdadr x) t)) (mapc 'unused-bindings (cdr form)))
+;; 			   ((unused-bindings f1))))))))
+
+
+
+;; (defun get-unused-bindings (form &aux *unused*)
+;;   (unused-bindings form)
+;;   (mapc (lambda (x)
+;; 	  (cmpwarn "The ~a ~s is not used.~%" (if (car x) "variable" "function") (car (or (car x) (cadr x)))))
+;; 	*unused*)
+;;   *unused*)
+
+;; The entire purpose of this function is to detect unused variables in eliminated code
+;; It could be expanded to support functions, blocks, and tags
+;; It could be eliminated if the unused variable warning is eliminated.
+(defun lex-refs (form)
+  (typecase form
+    (null)
+    (symbol
+     (let ((x (car (member form *vars* :key (lambda (x) (when (var-p x) (var-name x)))))))
+       (when x (set-var-reffed x))))
+    (cons
+     (case (car form)
+       ((let let*)
+	(let* ((b (mapcar (lambda (x) (make-var :name (if (consp x) (car x) x))) (cadr form)))
+	       (d (cons *vars* (maplist 'identity b)))
+	       (b (nreconc b *vars*)))
+	  (mapc (lambda (x &aux (*vars* (if (eq 'let* (car form)) (pop d) *vars*)))
+		  (when (consp x) (lex-refs (cadr x))))
+		(cadr form))
+	  (let ((*vars* b)) (mapc 'lex-refs (cddr form)))))
+       ((flet labels macrolet)
+	(let* ((m (eq (car form) 'macrolet))
+	       (b (mapcar (lambda (x) (make-fun :name (car x) :src (unless m (si::block-lambda (cadr x) (car x) (cddr x)))
+						:fn (if m (eval (defmacro-lambda (pop x) (pop x) x)) (lambda (&rest r) (declare (ignore r)) nil))))
+			  (cadr form)))
+	       (b (nreconc b *funs*)))
+	  (mapc (lambda (x &aux (*funs* (if (eq 'labels (car form)) b *funs*))) (lex-refs (cons 'lambda (cdr x)))) (cadr form))
+	  (let ((*funs* b)) (mapc 'lex-refs (cddr form)))))
+       ((quote go declare))
+       ((block return-from eval-when) (mapc 'lex-refs (cddr form)))
+       (tagbody (mapc (lambda (x) (typecase x ((or integer symbol))(otherwise (lex-refs x)))) (cdr form)))
+       (the (lex-refs (caddr form)))
+       (setq (do ((form (cddr form) (cddr form)))((not form))(lex-refs (car form))))
+       (lambda (lex-refs (blla (cadr form) nil '(foo) (cddr form))))
+       (function (let ((x (cadr form))) (typecase x ((cons (member lambda) t) (lex-refs x)))))
+       (otherwise (let* ((form (if (symbolp (car form)) form (cons 'funcall form)));?
+			 (fd (cmp-macro-function (car form)))
+			 (f1 (if fd (funcall fd form nil) form)))
+		    (if (eq form f1) (mapc 'lex-refs (cdr form)) (lex-refs f1))))))))
+
+(defun eliminate-src (src)
+  (when *top-level-src-p* (lex-refs src)))
+
+
+(defun t1defun (args &aux *warning-note-stack* *top-level-src*)
 
   (when (or (endp args) (endp (cdr args)))
     (too-few-args 'defun 2 (length args)))
@@ -1031,8 +1103,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 (si::readable-sig osig) (si::readable-sig sig))
+      (cmpstyle-warn "signature change on function ~s,~%   ~s -> ~s~%"
+		     fname (si::readable-sig osig) (si::readable-sig sig))
       (setq *new-sigs-in-file* 
 	    (some
 	     (lambda (x) 
@@ -1199,8 +1271,6 @@
 		      (*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*)
@@ -1302,7 +1372,6 @@
 ;;Macros for conditionally writing vs_base ..preamble, and for setting
 ;;up the return.
 (defun wt-V*-macros (cm return-type)
-  (declare (ignore return-type))
 
   (push (cons cm *max-vs*) *reservations*)
   
@@ -1401,35 +1470,20 @@
 
 
 (defun if1 (f)
-  (flet ((tbp (l) (member-if (lambda (x) (or (tag-p x) (blk-p x))) l)))
-	(not (or (info-ch f) 
-		 (tbp (info-ref     f))
-		 (tbp (info-ref-ccb f))
-		 (tbp (info-ref-clb f))
-		 (/= 0 (logand (info-flags f) (iflags side-effects compiler)))))))
-
-;; (defun if1 (f)
-;;   (not (or (info-ch f) (info-blocks f) (info-tags f)
-;; 	   (iflag-p (info-flags f) side-effects))))
+  (when (info-type f)
+    (flet ((tbp (l) (member-if (lambda (x) (or (tag-p x) (blk-p x))) l)))
+      (not (or (info-ch f)
+	       (tbp (info-ref     f))
+	       (tbp (info-ref-ccb f))
+	       (tbp (info-ref-clb f))
+	       (/= 0 (logand (info-flags f) (iflags side-effects compiler))))))))
   
-(defun ignorable-form-old (f)
-  (cond ((> (changed-length (cadr f)) 0) nil)
-	((side-effects-p f) nil)
-	(t)))
-
 (defun ignorable-form (f)
   (case (car f)
 	(function t)
 	((cadd-dladdress infer-tp) nil)
 	(otherwise (if1 (cadr f)))))
 
-;; (defun ignorable-form (f)
-;;   (or (eq (car f) 'function)
-;;       (if1 (cadr f))))
-
-;; (defun ignorable-form (f)
-;;   (if1 (cadr f)))
-
 
 ;;Checks the register slots of variables, and finds which
 ;;variables should be in registers, zero'ing the register slot
@@ -1546,16 +1600,9 @@
 ;;   (maybe-eval (not (macro-function n)) (cons 'defmacro w));FIXME?
 ;;   (push `(mflag ,n) *top-level-forms*))
 
-(defun t1macrolet (args &aux env (*funs* *funs*) (*vars* *vars*) (*macrolet-env* *macrolet-env*))
+(defun t1macrolet (args &aux  (*funs* *funs*))
   (when (endp args) (too-few-args 'macrolet 1 0))
-  (dolist (def (car args))
-    (let* ((x (car def))(y (si::funid-sym x))) (unless (eq x y) (setq def (cons y (cdr def)))))
-    (cmpck (or (endp def) (endp (cdr def)))
-           "The macro definition ~s is illegal." def)
-    (let* ((n (car def))
-	   (b (eval (si::defmacro-lambda n (cadr def) (cddr def)))))
-      (push (list n 'macro b) env)))
-  (when env (setq *macrolet-env* (list nil (append (cadr *macrolet-env*) (nreverse env)) nil)))
+  (push-macrolet-env (car args))
   (mapc 't1expr (cdr args)))
 
 (defun t1defmacro (args &aux (w args)(n (pop args))
@@ -1815,123 +1862,6 @@
 	  ";})"))))
 
 
-;; (defmacro defentry (n args c &optional (lt t))
-;;   (let* ((cp (consp c))
-;; 	 (c (if (and cp (eq (car c) 'static)) (cdr c) c))
-;; 	 (m (if cp (cadr c) c))
-;; 	 (m (if (symbolp m) (string-downcase m) m))
-;; 	 (rt (intern (symbol-name (if cp (car c) lt)) 'keyword))
-;; 	 (tps (mapcar (lambda (x) (intern (string (if (consp x) (car x) x)) 'keyword)) args))
-;; 	 (decl (reduce (lambda (y x) (strcat y (if (> (length y) 0) "," "") x)) args :initial-value ""))
-;; 	 (decl (concatenate 'string (string-downcase rt) " " m "(" decl ");"))
-;; 	 (syms (mapcar (lambda (x) (declare (ignore x)) (tmpsym)) args)))
-;;   `(defun ,n ,syms 
-;;      (declare (optimize (safety 2)))
-;;      ,@(mapcar (lambda (x y) `(check-type ,x ,(get y 'lisp-type))) syms tps)
-;;      (lit ,rt 
-;; 	  (cstr "({") (cstr ,decl) 
-;; 	  ,@(when (eq rt :void) `((cstr "(")))
-;; 	  (cstr ,m) (cstr "(")
-;; 	  ,@(mapcon (lambda (x y z) `((unbox ,(car z) ,(car y))
-;; 				      (cstr ,(if (cdr x) (if (consp (car x)) "+" ",") "")))) args syms tps)
-;; 	  (cstr ")")
-;; 	  ,@(when (eq rt :void) `((cstr ",Cnil)")))
-;; 	  (cstr ";})")))))
-
-
-;; (defmacro defentry1 (n args c &optional (lt t))
-;;   (let* ((cp (consp c))
-;; 	 (c (if (and cp (eq (car c) 'static)) (cdr c) c))
-;; 	 (m (if cp (cadr c) c))
-;; 	 (rt (if cp (intern (symbol-name (car c)) 'keyword) :t))
-;; 	 (syms (mapcar (lambda (x) (declare (ignore x)) (tmpsym)) args)))
-;;     `(progn
-;;        (defdlfun2 (,rt ,m) ,@(mapcar (lambda (x) (intern (symbol-name x) 'keyword)) args))
-;;        (defun ,n ,syms (,(mdlsym m "") ,@syms)))))
-
-;; (defun t1defentry (args &aux type cname (cfun (next-cfun)) cfspec static)
-;;   (when (or (endp args) (endp (cdr args)) (endp (cddr args)))
-;;         (too-few-args 'defentry 3 (length args)))
-;;   (cmpck (not (symbolp (car args)))
-;;          "The function name ~s is not a symbol." (car args))
-;;   (dolist (x (cadr args))
-;;     (cmpck (not (member x '(object char int fixnum float double string)))
-;;            "The C-type ~s is illegal." x))
-;;   (setq cfspec (caddr args))
-;;   (cond ((symbolp cfspec)
-;;          (setq type 'object)
-;;          (setq cname (string-downcase (symbol-name cfspec))))
-;;         ((stringp cfspec)
-;;          (setq type 'object)
-;;          (setq cname cfspec))
-;; 	((and (consp cfspec) (eq (car cfspec) 'static)
-;; 	      (setq static t cfspec (cdr cfspec)) nil))
-;;         ((and (consp cfspec)
-;;               (member (car cfspec) '(void object char int fixnum float double string))
-;;               (consp (cdr cfspec))
-;;               (or (symbolp (cadr cfspec)) (stringp (cadr cfspec)))
-;;               (endp (cddr cfspec)))
-;;          (setq cname (if (symbolp (cadr cfspec))
-;;                         (string-downcase (symbol-name (cadr cfspec)))
-;;                         (cadr cfspec)))
-;;          (setq type (car cfspec)))
-;;         (t (cmperr "The C function specification ~s is illegal." cfspec)))
-;;   (push (list 'defentry (car args) cfun (cadr args) (if static (list 'static type) type) cname)
-;;         *top-level-forms*)
-;;   (push (cons (car args) cfun) *global-funs*))
-
-;; (defun t2defentry (fname cfun arg-types type cname)
-;;   (declare (ignore arg-types type cname))
-;;   (wt-h "static void " (c-function-name "L" cfun fname) "();")
-;;   (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname)))))
-
-;; (defun t3defentry (fname cfun arg-types type cname)
-;;   (wt-h 
-;;    (if (and (consp type) (eq (car type) 'static) (setq type (cadr type))) "static " "")
-;;    (if (eq type 'string) "char *" (string-downcase (symbol-name type)))
-;;    " " cname "("
-;;    (with-output-to-string 
-;;     (s)
-;;     (do ((l arg-types (cdr l))) ((not l) (princ ");"s ))
-;;       (princ (if (eq (car l) 'string) "char *" (string-downcase (symbol-name (car l)))) s)
-;;       (when (cdr l) (princ "," s)))))
-;;   (wt-comment "function definition for " fname)
-;;   (wt-nl1 "static void " (c-function-name "L" cfun fname) "()")
-;;   (wt-nl1 "{	object *old_base=vs_base;")
-;;   (case type
-;;     (void)
-;;     (string (wt-nl "char *x;"))
-;;     (t (wt-nl (string-downcase (symbol-name type)) " x;")))
-;;   (when *safe-compile* (wt-nl "check_arg(" (length arg-types) ");"))
-;;   (unless (eq type 'void) (wt-nl "x="))
-;;   (wt-nl cname "(")
-;;   (unless (endp arg-types)
-;;           (do ((types arg-types (cdr types))
-;;                (i 0 (1+ i)))
-;;               (nil)
-;;               (declare (fixnum i))
-;;               (case (car types)
-;;                     (object (wt-nl "vs_base[" i "]"))
-;;                     (otherwise
-;;                      (wt-nl "object_to_"
-;;                             (string-downcase (symbol-name (car types)))
-;;                             "(vs_base[" i "])")))
-;;               (when (endp (cdr types)) (return))
-;;               (wt ",")))
-;;   (wt ");")
-;;   (wt-nl "vs_top=(vs_base=old_base)+1;")
-;;   (wt-nl "vs_base[0]=")
-;;   (case type
-;;         (void (wt "Cnil"))
-;;         (object (wt "x"))
-;;         (char (wt "code_char(x)"))
-;;         ((fixnum int) (when (zerop *space*) (wt "CMP")) (wt "make_fixnum(x)"))
-;; 	(string (wt "make_simple_string(x)"))
-;;         (float (wt "make_shortfloat(x)"))
-;;         (double (wt "make_longfloat(x)"))
-;;         )
-;;   (wt ";")
-;;   (wt-nl1 "}"))
 
 (defun t1defla (args) (declare (ignore args)))
 
--- gcl27-2.7.0.orig/cmpnew/gcl_cmptype.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmptype.lsp
@@ -622,11 +622,9 @@
 	    (mapcar (lambda (x) (real-imag-tp (si::tp-type (cdr x)) rp))
 		    (range-decomp t1)))))
 (defun complex-real-type-propagator (f t1)
-  (declare (ignore f))
   (complex-real-imag-type-propagator f t1 t))
 
 (defun complex-imag-type-propagator (f t1)
-  (declare (ignore f))
   (complex-real-imag-type-propagator f t1 nil))
 (si::putprop 'si::complex-real 'complex-real-type-propagator 'type-propagator)
 (si::putprop 'si::complex-imag 'complex-imag-type-propagator 'type-propagator)
@@ -1190,9 +1188,6 @@
 	(t)))
 
 
-(defun check-form-type (type form original-form)
-  (when (and (null (type-and type (info-type (cadr form)))) type (info-type (cadr form)))
-        (cmpwarn "The type of the form ~s is not ~s, but ~s." original-form (cmp-unnorm-tp type) (cmp-unnorm-tp (info-type (cadr form))))))
 
 
 (defun c-structure-def-propagator (f t1)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmputil.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmputil.lsp
@@ -35,36 +35,25 @@
 (defconstant *cmperr-tag* (cons nil nil))
 
 (defun cmperr (string &rest args &aux (*print-case* :upcase))
-  (print-current-form)
-  (format t "~&;;; ")
-  (apply #'format t string args)
+  (print-current-form *error-output*)
+  (si::error-format "ERROR: ")
+  (apply #'si::error-format string args)
+  (force-output *error-output*)
   (incf *error-count*)
-  (throw *cmperr-tag* '*cmperr-tag*))
+  (throw *cmperr-tag* (c1nil)))
 
 (defmacro cmpck (condition string &rest args)
   `(if ,condition (cmperr ,string ,@args)))
 
-(defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
-  (print-current-form)
-  (format t
-          ";;; ~S requires at most ~R argument~:p, ~
-          but ~R ~:*~[were~;was~:;were~] supplied.~%"
-          name
-          upper-bound
-          n)
-  (incf *error-count*)
-  (throw *cmperr-tag* '*cmperr-tag*))
-
-(defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
-  (print-current-form)
-  (format t
-          ";;; ~S requires at least ~R argument~:p, ~
-          but only ~R ~:*~[were~;was~:;were~] supplied.~%"
-          name
-          lower-bound
-          n)
-  (incf *error-count*)
-  (throw *cmperr-tag* '*cmperr-tag*))
+(defun too-many-args (name upper-bound n)
+  (cmperr "~S requires at most ~R argument~:p, ~
+           but ~R ~:*~[were~;was~:;were~] supplied.~%"
+          name upper-bound n))
+
+(defun too-few-args (name lower-bound n)
+  (cmperr "~S requires at least ~R argument~:p, ~
+           but only ~R ~:*~[were~;was~:;were~] supplied.~%"
+          name lower-bound n))
 
 (defvar *warning-note-stack*)
 
@@ -87,22 +76,23 @@
 	((not *warning-note-stack*))
       (funcall (pop *warning-note-stack*)))))
   
-(defun print-sri-stack nil
-  (let ((*print-length* 2)
-	(*print-level* 2)
-	(f (cadr *current-form*)))
-    (dolist (s *src-inline-recursion*)
-      (unless (eq (caar s) f)
-	(format t ";   inlining ~s~%" (cons (name-sir (car s)) (cdr s)))))))
 
 (defun cmpwarn (string &rest args &aux (*print-case* :upcase))
   (unless *suppress-compiler-warnings*
     (maybe-to-wn-stack
-     (print-current-form)
-     (print-sri-stack)
-     (format t ";; Warning: ")
-     (apply #'format t string args)
-     (terpri)))
+     (warn 'warning
+	   :function-name (print-current-form nil)
+	   :format-control "~?"
+	   :format-arguments (list string args))))
+  nil)
+
+(defun cmpstyle-warn (string &rest args &aux (*print-case* :upcase))
+  (unless *suppress-compiler-warnings*
+    (maybe-to-wn-stack
+     (warn 'style-warning
+	   :function-name (print-current-form nil)
+	   :format-control "~?"
+	   :format-arguments (list string args))))
   nil)
 
 (defvar *suppress-compiler-notes* t)
@@ -114,11 +104,10 @@
 
 (defun cmpnote (string &rest args &aux (*print-case* :upcase))
   (maybe-to-wn-stack
-   (print-current-form)
-   (print-sri-stack)
-   (format t ";; Note: ")
-   (apply #'format t string args)
-   (terpri))
+   (print-current-form *debug-io*)
+   (format *debug-io* ";; Note: ")
+   (apply #'format *debug-io* string args)
+   (terpri *debug-io*))
   nil)
 
 (defun do-keyed-cmpnote (k string &rest args &aux (*print-case* :upcase))
@@ -132,26 +121,19 @@
   `(when *note-keys*
      (do-keyed-cmpnote ,key ,string ,@args)))
 
-;; (defun keyed-cmpnote (key string &rest args &aux (*print-case* :upcase))
-;;   (when *note-keys*
-;;     (let ((keys (if (atom key) (list key) key)))
-;;       (when (intersection keys *note-keys* :test (lambda (x y) (or (eq x y) (eq 'all y))))
-;; 	(apply 'cmpnote string args)))))
-;; (declaim (inline keyed-cmpnote))
-
-(defun print-current-form ()
-  (when *first-error*
-    (setq *first-error* nil)
-    (fresh-line)
-    (cond
-     ((and (consp *current-form*)
-	   (eq (car *current-form*) 'si:|#,|))
-      (format t "; #,~s is being compiled.~%" (cdr *current-form*)))
-     (t
-      (let ((*print-length* 2)
-	    (*print-level* 2))
-	(format t "; ~s is being compiled.~%" *current-form*)))))
-  nil)
+(defun print-current-form (&optional (strm t)
+			   &aux (*print-length* 2)(*print-level* 2)(f *current-form*))
+  (when (or (eq *first-error* t)
+	    (not (eq (car *first-error*) *current-form*))
+	    (not (eq (cdr *first-error*) *src-inline-recursion*)))
+    (setq *first-error* (cons *current-form* *src-inline-recursion*))
+    (let ((args (list ";; When compiling ~s~%~{;;   inlining ~s~%~}"
+		      (if (and (consp f) (eq (car f) '|#,|)) (cdr f) f)
+		      (mapcan (lambda (s) (unless (eq (caar s) f) (list (cons (name-sir (car s)) (cdr s)))))
+			      (butlast *src-inline-recursion*)))))
+      (if (eq *error-output* strm)
+	  (apply 'si::error-format args)
+	  (apply 'format strm args)))))
 
 (defun undefined-variable (sym &aux (*print-case* :upcase))
   (cmpwarn
@@ -159,27 +141,16 @@
            ;; The compiler will assume this variable is a global.~%"
    sym))
 
-(defun baboon (&aux (*print-case* :upcase))
-  (print-current-form)
-  (format t ";;; A bug was found in the compiler.  Contact Taiichi.~%")
-  (incf *error-count*)
-  (break)
-;  (throw *cmperr-tag* '*cmperr-tag*)
-)
+(defun baboon nil (cmperr "A bug was found in the compiler.  Contact Taiichi.~%"))
 
 (defun cmp-eval (form)
   (multiple-value-bind 
    (x y) (cmp-toplevel-eval `(eval ',form))
-   (if x
-       (let ((*print-case* :upcase))
-	 (incf *error-count*)
-	 (print-current-form)
-	 (format t
-		 ";;; The form ~s was not evaluated successfully.~%~
-                  ;;; You are recommended to compile again.~%"
-		 form)
-	 nil)
-     y)))
+    (cond (x
+	   (cmpwarn "The form ~s was not evaluated successfully.  You are recommended to compile again.~%"
+		    form)
+	   `(error "Evaluation of ~s failed at compile time." ',form))
+	  (y))))
 
 ;(si::putprop 'setf 'c1setf 'c1special)
 
@@ -199,34 +170,37 @@
 ;				   args)))))
 
 (defmacro macroexpand-helper (pre meth form)
-  (let ((c (sgen "MHC"))(x (sgen "MHX"))(e (sgen "MHE")))
+  (let ((c (sgen "MHC"))(x (sgen "MHX")))
     `(let ((,c (when (consp ,form) (car ,form))))
        ,@(when pre `(,pre))
        (cond ((not ,c) ,form)
 	     ((not (symbolp ,c)) ,form)
-	     ((and (not (assoc ,c (cadr *macrolet-env*))) (not (macro-function ,c))) ,form)
-	     ((let* ((,x (multiple-value-list (cmp-toplevel-eval `,,meth)))
-		     (,e (car ,x)))
-		(cond ((not ,e) (cadr ,x))
-		      ((let ((*print-case* :upcase))
-			 (incf *error-count*)
-			 (print-current-form)
-			 (format t ";;; The macro form ~s was not expanded successfully.~%" ,form)
-			 `(error "Macro-expansion of ~s failed at compile time." ',,form))))))))))
+	     ((not (cmp-macro-function ,c)) ,form);FIXME needed?
+	     ((let* ((,x (multiple-value-list (cmp-toplevel-eval `,,meth))))
+		(cond ((car ,x)
+		       (cmpwarn "The macro form ~s was not expanded successfully.~%" ,form)
+		       `(error "Macro-expansion of ~s failed at compile time." ',,form))
+		      ((cadr ,x)))))))))
 
 (defun cmp-macroexpand (form)
-  (macroexpand-helper nil `(macroexpand ',form ',*macrolet-env*) form))
+  (macroexpand-helper nil `(macroexpand ',form ',(funs-to-macrolet-env)) form))
 
 (defun cmp-macroexpand-1 (form)
-  (macroexpand-helper nil `(macroexpand-1 ',form ',*macrolet-env*) form))
+  (macroexpand-helper nil `(macroexpand-1 ',form ',(funs-to-macrolet-env)) form))
 
 (defun cmp-expand-macro (fd fname args)
   (let ((x (cons fname args)))
     (macroexpand-helper
      (and *record-call-info* (add-macro-callee fname))
-     `(funcall *macroexpand-hook* ',fd ',x ',*macrolet-env*)
+     `(funcall *macroexpand-hook* ',fd ',x ',(funs-to-macrolet-env))
      x)))
 
+(defun cmp-expand-macro-w (fd x)
+  (macroexpand-helper
+   (and *record-call-info* (add-macro-callee (car x)))
+   `(funcall *macroexpand-hook* ',fd ',x ',(funs-to-macrolet-env))
+   x))
+
 (defvar *compiler-break-enable* nil)
 
 (defun cmp-toplevel-eval (form)
--- gcl27-2.7.0.orig/cmpnew/gcl_cmpvar.lsp
+++ gcl27-2.7.0/cmpnew/gcl_cmpvar.lsp
@@ -178,12 +178,20 @@
     (setf (var-dt var) (var-type var))
     var))
 
+(defvar *top-level-src* nil)
+(defvar *top-level-src-p* t)
+
+(defun mark-toplevel-src (src)
+  (when *top-level-src-p*
+    (pushnew src *top-level-src*))
+  src)
+
 (defun check-vref (var)
-  (unless *in-inline*
+  (when *top-level-src-p*
     (when (and (eq (var-kind var) 'LEXICAL)
 	       (not (var-reffed var))
 	       (not (var-ref var)));;; This field may be IGNORE or IGNORABLE here.
-      (cmpwarn "The variable ~s is not used." (var-name var)))))
+      (cmpstyle-warn "The variable ~s is not used." (var-name var)))))
 
 (defun var-cb (v)
   (or (var-ref-ccb v) (eq 'clb (var-loc v))))
@@ -350,7 +358,7 @@
 (defun get-var (o &aux (vp (var-p o)))
   (or (get-top-var-binding (if vp (get-vbind o) o)) (when vp o)))
 
-(defun c1vref (name &aux ccb clb)
+(defun c1vref (name &optional setq &aux ccb clb)
   (dolist (var *vars*
                (let ((var (sch-global name)))
                  (unless var
@@ -366,122 +374,15 @@
       (cond ((eq var 'cb) (setq ccb t))
             ((eq var 'lb) (setq clb t))
             ((or (when (eq (var-name var) name) (not (member var *lexical-env-mask*))) (eq var name))
+	     (unless setq
+	       (when (eq (var-ref var) 'IGNORE)
+		 (unless (var-reffed var)
+		   (cmpstyle-warn "The ignored variable ~s is used." name))))
 	     (set-var-reffed var)
 	     (keyed-cmpnote (list 'var-ref (var-name var))
 			    "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb)))
 	     (return-from c1vref (list* var (if (eq (var-kind var) 'lexical) (list ccb clb) '(nil nil))))))))
 
-;; (defun c1vref (name &optional setq &aux ccb clb)
-;;   (dolist (var *vars*
-;;                (let ((var (sch-global name)))
-;;                     (unless var
-;;                       (unless (or (si:specialp name) (constantp name)) (undefined-variable name))
-;;                       (setq var (make-var :name name
-;;                                           :kind 'GLOBAL
-;;                                           :loc (add-symbol name)
-;;                                           :type (or (get name 'cmp-type) t)
-;; 					  :ref t));FIXME
-;;                       (push var *undefined-vars*))
-;;                     (list var ccb)))
-;;       (cond ((eq var 'cb) (setq ccb t))
-;;             ((eq var 'lb) (setq clb t))
-;;             ((or (eq (var-name var) name) (eq var name))
-;; 	     (set-var-reffed var)
-;; 	     (keyed-cmpnote (list 'var-ref (var-name var))
-;; 			    "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb)))
-;; 	     (let ((nv (if setq var (get-var var))))
-;; 	       (return-from c1vref (if (eq var nv) (list var ccb clb) (c1vref nv setq))))))))
-
-;; (defun c1vref (name &optional setq &aux ccb clb)
-;;   (dolist (var *vars*
-;;                (let ((var (sch-global name)))
-;;                     (unless var
-;;                       (unless (or (si:specialp name) (constantp name)) (undefined-variable name))
-;;                       (setq var (make-var :name name
-;;                                           :kind 'GLOBAL
-;;                                           :loc (add-symbol name)
-;;                                           :type (or (get name 'cmp-type) t)
-;; 					  :ref t));FIXME
-;;                       (push var *undefined-vars*))
-;;                     (list var ccb)))
-;;       (cond ((eq var 'cb) (setq ccb t))
-;;             ((eq var 'lb) (setq clb t))
-;;             ((or (eq (var-name var) name) (eq var name))
-;; 	     (set-var-reffed var)
-;; 	     (keyed-cmpnote (list 'var-ref (var-name var))
-;; 			    "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb)))
-;; 	     (return-from c1vref (list (if setq var (get-var var)) ccb clb))))))
-
-;; (defun c1vref (name &aux ccb clb)
-;;   (dolist (var *vars*
-;;                (let ((var (sch-global name)))
-;;                     (unless var
-;;                       (unless (or (si:specialp name) (constantp name)) (undefined-variable name))
-;;                       (setq var (make-var :name name
-;;                                           :kind 'GLOBAL
-;;                                           :loc (add-symbol name)
-;;                                           :type (or (get name 'cmp-type) t)
-;; 					  :ref t));FIXME
-;;                       (push var *undefined-vars*))
-;;                     (list var ccb)))
-;;       (cond ((eq var 'cb) (setq ccb t))
-;;             ((eq var 'lb) (setq clb t))
-;;             ((eq (var-name var) name)
-;; 	     (set-var-reffed var)
-;; 	     (keyed-cmpnote (list 'var-ref (var-name var))
-;; 			    "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb)))
-;; 	     (let ((l (list var ccb clb)))
-;; 	       (push l (var-store var))
-;; 	       (return-from c1vref l))))))
-
-;; (defun c1vref (name &aux ccb clb)
-;;   (dolist (var *vars*
-;;                (let ((var (sch-global name)))
-;;                     (unless var
-;;                       (unless (or (si:specialp name) (constantp name)) (undefined-variable name))
-;;                       (setq var (make-var :name name
-;;                                           :kind 'GLOBAL
-;;                                           :loc (add-symbol name)
-;;                                           :type (or (get name 'cmp-type) t)
-;; 					  :ref t));FIXME
-;;                       (push var *undefined-vars*))
-;;                     (list var ccb)))
-;;       (cond ((eq var 'cb) (setq ccb t))
-;;             ((eq var 'lb) (setq clb t))
-;;             ((eq (var-name var) name)
-;; 	     (set-var-reffed var)
-;; 	     (keyed-cmpnote (list 'var-ref (var-name var))
-;; 			    "Making variable ~s reference with barrier ~s" (var-name var) (if ccb 'cb (if clb 'lb)))
-;;              (return-from c1vref (list var ccb clb))))))
-
-;; (defun c1vref (name &optional noref &aux ccb clb inner)
-;;   (dolist (var *vars*
-;;                (let ((var (sch-global name)))
-;;                     (unless var
-;;                       (unless (or (si:specialp name) (constantp name)) (undefined-variable name))
-;;                       (setq var (make-var :name name
-;;                                           :kind 'GLOBAL
-;;                                           :loc (add-symbol name)
-;;                                           :type (or (get name 'cmp-type) t)
-;; 					  :ref t));FIXME
-;;                       (push var *undefined-vars*))
-;;                     (list var ccb)))
-;;       (cond ((eq var 'cb) (setq ccb t inner (or inner 'cb)))
-;;             ((eq var 'lb) (setq clb t inner (or inner 'lb)))
-;;             ((eq (var-name var) name)
-;;              (when (eq (var-ref var) 'IGNORE)
-;; 	       (cmpwarn "The ignored variable ~s is used." name)
-;; 	       (unless noref (setf (var-ref var) t)))
-;;              (cond (ccb 
-;; 		    (ref-inner inner) 
-;; 		    (setf (var-ref-ccb var) t));FIXME think noref
-;;                    (clb 
-;; 		    (when (eq (var-kind var) 'lexical) (setf (var-loc var) 'clb))
-;; 		    (setf (var-ref var) t));FIXME
-;; 		   (t (unless noref (setf (var-ref var) t))
-;; 		      (setf (var-register var) (1+ (var-register var)))))
-;;              (return-from c1vref (list var ccb))))))
-
 (defun c2var-kind (var)
   (when (and (eq (var-kind var) 'LEXICAL)
            (not (var-ref-ccb var))
@@ -491,25 +392,8 @@
 	  ((and (boundp '*c-gc*) *c-gc* 'OBJECT)))))
 
 
-;; (defun c2var-kind (var)
-;;   (if (and (eq (var-kind var) 'LEXICAL)
-;;            (not (var-ref-ccb var))
-;;            (not (eq (var-loc var) 'clb)))
-;;       (if (eq (var-loc var) 'OBJECT)
-;;           'OBJECT
-;;           (let ((type (var-type var)))
-;;                (cond ((car (member type +c-local-var-types+ :test 'type<=)))
-;;                      ((and (boundp '*c-gc*) *c-gc* 'OBJECT))
-;; 		     (t nil))))
-;;       nil)
-;;   )
-
 (defun c2var (vref c1fv stores) (declare (ignore c1fv stores)) (unwind-exit (cons 'var vref) nil 'single-value))
 
-;; (defun c2var (vref c1fv) (declare (ignore c1fv)) (unwind-exit (cons 'var vref) nil 'single-value))
-
-;; (defun c2var (vref) (unwind-exit (cons 'var vref) nil 'single-value))
-
 (defun c2location (loc) (unwind-exit loc nil 'single-value))
 
 
@@ -620,7 +504,8 @@
       (setq t1 (ensure-known-type (coerce-to-one-value t1)))
       (let* ((tp (type-and (var-dt v) t1)))
 	(unless (or tp (not (and (var-dt v) t1)))
-	  (cmpwarn "Type mismatches between ~s/~s and ~s/~s." (var-name v) (cmp-unnorm-tp (var-dt v)) (car form) (cmp-unnorm-tp t1)))
+	  (cmpwarn "Type mismatches setting declared ~s variable ~s to type ~s from form ~s."
+	       (cmp-unnorm-tp (var-dt v)) (var-name v) (cmp-unnorm-tp t1) (car form)))
 	(keyed-cmpnote (list (var-name v) 'type-propagation 'type)
 		       "Setting var-type on ~s from ~s to ~s, form ~s, max ~s" 
 		       (var-name v) (cmp-unnorm-tp (var-type v)) (cmp-unnorm-tp tp) (car form) (cmp-unnorm-tp (var-mt v)))
@@ -647,12 +532,7 @@
     (unless (type>= type it)
       (let ((nt (type-and type it)))
 	(unless nt
-	  (unless type
-	    (cmpwarn "NOT setting form type from ~s to ~s" (cmp-unnorm-tp it) (cmp-unnorm-tp type))
-	    (return-from sft nil))
-	  (cmpwarn "Setting form type ~s to orthogonal type ~s"
-		   (cmp-unnorm-tp it) (cmp-unnorm-tp type))
-	  (setq nt type))
+	  (keyed-cmpnote (list 'nil-arg) "Setting form type ~s to nil" (cmp-unnorm-tp it)))
 	(when (or (eq form (c1nil)) (eq form (c1t)));FIXME
 	  (unless (type= it nt)
 	    (return-from sft nil)))
@@ -683,7 +563,7 @@
 (defun c1setq1 (name form &aux (info (make-info)) type form1 name1)
   (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
   (cmpck (constantp name) "The constant ~s is being assigned a value." name)
-  (setq name1 (c1vref name))
+  (setq name1 (c1vref name t))
   (when (member (var-kind (car name1)) '(special global));FIXME
     (setf (info-flags info) (logior (iflags side-effects) (info-flags info))))
 ;  (push-changed (car name1) info)
--- gcl27-2.7.0.orig/cmpnew/gcl_lfun_list.lsp
+++ gcl27-2.7.0/cmpnew/gcl_lfun_list.lsp
@@ -8,6 +8,9 @@
 
 (dolist (l '((((stream) string) . get-output-stream-string)
 	     (((simple-vector seqind) t) . svref)
+	     (((t *) string) . print)
+	     (((t *) string) . prin1)
+	     (((t *) string) . princ)
 	     (((si::function-identifier) boolean) . fboundp)
 	     (((structure) structure) . si::structure-def)
 	     (((t t t t t t t) pathname) . si::init-pathname)
--- gcl27-2.7.0.orig/configure
+++ gcl27-2.7.0/configure
@@ -3149,7 +3149,9 @@ case $use in
 	case $use in
 	    ia64*)
 		def_dlopen="yes" ; def_custreloc="no" ;;
-	    	    	esac;;
+	    hppa*) # FIXME
+		def_pic="yes" ;;
+	esac;;
 esac
 
 # Check whether --enable-widecons was given.
@@ -5798,6 +5800,9 @@ case $use in
 		assert_arg_to_cflags -mlong-calls
 		TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags
 		if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1
+
+printf "%s\n" "#define SET_STACK_POINTER \"copy %0,%%sp\\n\\t\"" >>confdefs.h
+
 		;;
 	    mips*)
 		case $canonical in
@@ -8377,12 +8382,16 @@ printf "%s\n" "#define CSTACK_ALIGNMENT
 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_alignment" >&5
 printf "%s\n" "$cstack_alignment" >&6; }
 
+cstack_max=-1;
 # Check whether --enable-cstackmax was given.
 if test ${enable_cstackmax+y}
 then :
   enableval=$enable_cstackmax; if test "$enableval" != "" ; then
+	         cstack_max=$enableval;
+
 printf "%s\n" "#define CSTACKMAX $enableval" >>confdefs.h
- fi
+
+	       fi
 fi
 
 
@@ -8728,19 +8737,19 @@ main (void)
 		FILE *fp = fopen("conftest1","w");
 
 		for (i=2,k=1;i;k=i,i<<=1);
-		    l=$cstack_address;
-		    l=$cstack_direction==1 ? (l<k ? k-1 : -1) : l;
-		    for (i=j=k;j && i<l;j>>=1,i|=j);
-			if (j<(k>>3)) i=0;
-			   j=1;
-			   j<<=$PAGEWIDTH;
-			   j<<=4;
-			   j--;
-			   i+=j;
-			   i&=~j;
-			   fprintf(fp,"0x%lx",i);
-			   fclose(fp);
-			   return 0;
+		l=$cstack_address;
+		l=$cstack_direction==1 ? (l<k ? k-1 : $cstack_max) : l;
+		for (i=j=k;j && i<l;j>>=1,i|=j);
+		if (j<(k>>3)) i=0;
+		j=1;
+		j<<=$PAGEWIDTH;
+		j<<=4;
+		j--;
+		i+=j;
+		i&=~j;
+		fprintf(fp,"0x%lx",i);
+		fclose(fp);
+		return 0;
 
   ;
   return 0;
--- gcl27-2.7.0.orig/configure.in
+++ gcl27-2.7.0/configure.in
@@ -84,8 +84,8 @@ case $use in
 	case $use in
 	    ia64*)
 		def_dlopen="yes" ; def_custreloc="no" ;;
-	    dnl hppa*)
-	    dnl 	def_pic="yes" ;;
+	    hppa*) # FIXME
+		def_pic="yes" ;;
 	esac;;
 esac
 
@@ -446,6 +446,7 @@ case $use in
 		assert_arg_to_cflags -mlong-calls
 		TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags
 		if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1
+		AC_DEFINE([SET_STACK_POINTER],["copy %0,%%sp\n\t"],[asm string to set the stack pointer])
 		;;
 	    mips*)
 		case $canonical in
@@ -1363,8 +1364,12 @@ AC_RUN_IFELSE(
 AC_DEFINE_UNQUOTED(CSTACK_ALIGNMENT,$cstack_alignment,[C stack alignment])
 AC_MSG_RESULT($cstack_alignment)
 
+cstack_max=-1;
 AC_ARG_ENABLE([cstackmax],[  --enable-cstackmax=xxxx will ensure that the cstack begins below xxxx or fail],
-	      [if test "$enableval" != "" ; then AC_DEFINE_UNQUOTED([CSTACKMAX],$enableval,[cstack max]) fi])
+	      [if test "$enableval" != "" ; then
+	         cstack_max=$enableval;
+		 AC_DEFINE_UNQUOTED([CSTACKMAX],$enableval,[cstack max])
+	       fi])
 
 
 AC_MSG_CHECKING(CSTACK_ADDRESS)
@@ -1589,19 +1594,19 @@ AC_RUN_IFELSE(
 		FILE *fp = fopen("conftest1","w");
 
 		for (i=2,k=1;i;k=i,i<<=1);
-		    l=$cstack_address;
-		    l=$cstack_direction==1 ? (l<k ? k-1 : -1) : l;
-		    for (i=j=k;j && i<l;j>>=1,i|=j);
-			if (j<(k>>3)) i=0;
-			   j=1;
-			   j<<=$PAGEWIDTH;
-			   j<<=4;
-			   j--;
-			   i+=j;
-			   i&=~j;
-			   fprintf(fp,"0x%lx",i);
-			   fclose(fp);
-			   return 0;
+		l=$cstack_address;
+		l=$cstack_direction==1 ? (l<k ? k-1 : $cstack_max) : l;
+		for (i=j=k;j && i<l;j>>=1,i|=j);
+		if (j<(k>>3)) i=0;
+		j=1;
+		j<<=$PAGEWIDTH;
+		j<<=4;
+		j--;
+		i+=j;
+		i&=~j;
+		fprintf(fp,"0x%lx",i);
+		fclose(fp);
+		return 0;
 	    ]])],
     [mem_top=`cat conftest1`],[mem_top="0x0"])
 AC_MSG_RESULT($mem_top)
--- gcl27-2.7.0.orig/gcl-tk/demos/gc-monitor.lisp
+++ gcl27-2.7.0/gcl-tk/demos/gc-monitor.lisp
@@ -38,12 +38,12 @@
   (setf (fill-pointer *values-array*) 0)
   (let ((max-size 0) (ar *values-array*) (i 0) (width 7.0s0)
 	(ht ".15c"))
-    (declare (seqind max-size) (short-float width)(type (array (t)) ar))
+    (declare (si::seqind max-size) (short-float width)(type (array (t)) ar))
     (dolist (v *gc-monitor-types*)
       (let ((fp (fill-pointer *values-array*))
 	    )
 	(multiple-value-call 'push-multiple-values (si::allocated v))
-	(setq max-size (max max-size (aref ar (the seqind (+ fp 1)))))))
+	(setq max-size (max max-size (aref ar (the si::seqind (+ fp 1)))))))
 					;  (nfree npages maxpage nppage gccount nused)
     (dolist (v *gc-monitor-types*)
       (let* ((nfree (aref ar i))
@@ -56,11 +56,11 @@
 	     (tot (* npages nppage))
 	     (width-used (the short-float
 			      (/ (the short-float
-				      (* wid (the seqind
+				      (* wid (the si::seqind
 						  (- tot
-						     (the seqind nfree)))))
+						     (the si::seqind nfree)))))
 				 tot))))
-	(declare (seqind nppage npages  tot)
+	(declare (si::seqind nppage npages  tot)
 		 (short-float  wid))
 	(setq i (+ i 1))
     	(funcall (get v 'canvas) :delete "graph")
@@ -152,7 +152,3 @@
     (draw-status nil))
   (setq si::*after-gbc-hook* 'draw-status)
   )
-
-
-
-  
\ No newline at end of file
--- gcl27-2.7.0.orig/gcl-tk/tinfo.lsp
+++ gcl27-2.7.0/gcl-tk/tinfo.lsp
@@ -503,7 +503,7 @@
 
 (defun insert-string (win string beg end)
   (and (> end beg)
-  (let ((ar (make-array  (- end beg) :element-type 'string-char
+  (let ((ar (make-array  (- end beg) :element-type 'character
 			:displaced-to string :displaced-index-offset beg)))
     (funcall win :insert 'insert ar))))
 
--- gcl27-2.7.0.orig/gcl-tk/tkl.lisp
+++ gcl27-2.7.0/gcl-tk/tkl.lisp
@@ -188,9 +188,8 @@
 (defvar *string-streams* (list (make-string-input-stream "") (make-string-input-stream "")))
 
 (defmacro with-tk-command (&body body)
-  `(let (tk-command (*command-strings* *command-strings*))
-     (declare (type string tk-command))
-     (setq tk-command (grab-tk-command))
+  `(let ((tk-command (grab-tk-command)) (*command-strings* *command-strings*))
+     (declare (string tk-command))
      ,@ body))
 
 (defun grab-tk-command( &aux x)
@@ -199,11 +198,11 @@
    ((cdr *command-strings*))
    (t 
     (setq x (list (make-array 70
-			      :element-type 'standard-char
+			      :element-type 'character
 			      :fill-pointer 0 :adjustable t))
 	  )
     (or *command-strings* (error "how??"))
-  
+
     (setq *command-strings* (nconc *command-strings* x))))
   (let ((x (car *command-strings*)))
     (setq  *command-strings* (cdr *command-strings*))
--- gcl27-2.7.0.orig/git.tag
+++ gcl27-2.7.0/git.tag
@@ -1,2 +1,2 @@
-"Version_2_7_0pre32"
+"Version_2_7_0pre33"
 
--- gcl27-2.7.0.orig/h/alpha-linux.h
+++ gcl27-2.7.0/h/alpha-linux.h
@@ -23,4 +23,4 @@
 #define CLEAR_CACHE imb()
 
 /*FIXME probe broken in recent kernels, no access*/
-#define DEFINED_REAL_MAXPAGE (1UL<<18) /*FIXME brk probe broken*/
+/* #define DEFINED_REAL_MAXPAGE (1UL<<18) /\*FIXME brk probe broken*\/ */
--- gcl27-2.7.0.orig/h/bsd.h
+++ gcl27-2.7.0/h/bsd.h
@@ -31,7 +31,7 @@ filecpy(save, original, stsize - sizeof(
 #define NUMBER_OPEN_FILES getdtablesize() 
 
 
-extern char etext;
+extern char etext[];
 
 #define INIT_ALLOC heap_end = core_end = PCEI(sbrk(0),PAGESIZE);
 
--- gcl27-2.7.0.orig/h/compprotos.h
+++ gcl27-2.7.0/h/compprotos.h
@@ -58,6 +58,8 @@ object number_plus(object,object);
 object number_signum(object);
 object number_times(object,object);
 object princ(object,object);
+object prin1(object,object);
+object print(object,object);
 object read_char1(object,object);
 object structure_ref(object,object,fixnum);
 object structure_set(object,object,fixnum,object);
@@ -73,7 +75,6 @@ void frs_overflow(void);
 void intdivrem(object,object,fixnum,object *,object *);
 void princ_char(int,object);
 void princ_str(char *,object);
-void princ_str(char *,object);
 void sethash(object,object,object);
 void setq(object,object);
 void super_funcall_no_event(object);
--- gcl27-2.7.0.orig/h/lu.h
+++ gcl27-2.7.0/h/lu.h
@@ -24,9 +24,9 @@ typedef unsigned long   ufixnum;
 #define FRSTWRDF(t_,a_...)   ufixnum h:1,a_,   st:3,t:5,t_:5,    f:1,m:1,e:1
 #define FIRSTWORD            ufixnum h:1,w:LM(17),st:3,t:5,tt:5,    f:1,m:1,e:1
 #define FSTPWORD             ufixnum h:1,w:LM(17),st:3,tp:10,             emf:3
-#define MARKWORD             ufixnum h:1,w:LM(14),     t:5,tt:5,       mf:2,e:1
-#define SGCMWORD             ufixnum h:1,w:LM(14),     t:5,tt:5,       mf:2,e:1
-#define TYPEWORD             ufixnum h:1,w:LM(14),     t:5,tt:5,          emf:3
+#define MARKWORD             ufixnum h:1,xx:LM(14),    t:5,tt:5,       mf:2,e:1
+#define SGCMWORD             ufixnum h:1,xx:LM(14),    t:5,tt:5,       mf:2,e:1
+#define TYPEWORD             ufixnum h:1,xx:LM(14),    t:5,tt:5,          emf:3
 
 #endif
 
--- gcl27-2.7.0.orig/h/m68k-linux.h
+++ gcl27-2.7.0/h/m68k-linux.h
@@ -79,4 +79,4 @@ int cacheflush(void *,int,int,int);
 
 #define NEED_STACK_CHK_GUARD
 
-#define DEFINED_REAL_MAXPAGE (1UL<<18) /*FIXME brk probe broken*/
+/* #define DEFINED_REAL_MAXPAGE (1UL<<18) /\*FIXME brk probe broken*\/ */
--- gcl27-2.7.0.orig/h/object.h
+++ gcl27-2.7.0/h/object.h
@@ -424,7 +424,7 @@ EXTER fixnum new_holepage,starting_hole_
 EXTER ulfixnum cumulative_allocation,recent_allocation;
 EXTER ufixnum wait_on_abort;
 EXTER double gc_alloc_min,mem_multiple,gc_page_min,gc_page_max;
-EXTER bool multiprocess_memory_pool;
+EXTER char *multiprocess_memory_pool;
 
 EXTER char *new_rb_start;		/*  desired relblock start after next gc  */
 EXTER char *rb_start;           	/*  relblock start  */
@@ -472,7 +472,7 @@ ufmax(ufixnum a,ufixnum b) {
 }
 
 INLINE int
-emsg(const char *s,...) {
+oemsg(int fd,const char *s,...) {
   va_list args;
   ufixnum n=0;
   void *v=NULL;
@@ -483,9 +483,12 @@ emsg(const char *s,...) {
   va_start(args,s);
   vsnprintf(v,n,s,args);
   va_end(args);
-  return write(2,v,n-1) ? n : -1;
+  return write(fd,v,n-1) ? n : -1;
 }
 
+#define omsg(a_...) oemsg(1,a_)
+#define emsg(a_...) oemsg(2,a_)
+
 EXTER char *heap_end;			/*  heap end  */
 EXTER char *core_end;			/*  core end  */
 EXTER 
--- gcl27-2.7.0.orig/h/pool.h
+++ gcl27-2.7.0/h/pool.h
@@ -19,6 +19,7 @@ static struct pool {
   ufixnum n;
   ufixnum s;
 } *Pool;
+static ufixnum pool_pid,pool_n,pool_s;
 
 static struct flock f,pl,*plp=&pl;
 static char gcl_pool[PATH_MAX];
@@ -62,8 +63,13 @@ open_pool(void) {
 
   if (pool==-1) {
 
-    massert(!home_namestring1("~",1,FN1,sizeof(FN1)));
-    massert(snprintf(gcl_pool,sizeof(gcl_pool),"%sgcl_pool",FN1)>=0);
+    struct stat ss;
+    massert(!lstat(multiprocess_memory_pool,&ss));
+    massert(S_ISDIR(ss.st_mode));
+
+    massert(snprintf(gcl_pool,sizeof(gcl_pool),"%s%sgcl_pool",
+		     multiprocess_memory_pool,
+		     multiprocess_memory_pool[strlen(multiprocess_memory_pool)-1]=='/' ? "" : "/")>=0);
     massert((pool=open(gcl_pool,O_CREAT|O_RDWR,0644))!=-1);
     massert(!ftruncate(pool,sizeof(struct pool)));
     massert((Pool=mmap(NULL,sizeof(struct pool),PROT_READ|PROT_WRITE,MAP_SHARED,pool,0))!=(void *)-1);
@@ -155,6 +161,24 @@ get_pool(void) {
   
 }
 
+static void
+pool_stat(void) {
+
+#ifndef NO_FILE_LOCKING
+  if (multiprocess_memory_pool) {
+
+    open_pool();
+    lock_pool();
+    pool_pid=Pool->pid;
+    pool_n=Pool->n;
+    pool_s=Pool->s;
+    unlock_pool();
+
+  }
+#endif
+
+}
+
 
 static void
 pool_check(void) {
--- gcl27-2.7.0.orig/h/sh4-linux.h
+++ gcl27-2.7.0/h/sh4-linux.h
@@ -57,4 +57,4 @@
 
 #define NEED_STACK_CHK_GUARD
 
-#define DEFINED_REAL_MAXPAGE (1UL<<18) /*FIXME brk probe broken*/
+/* #define DEFINED_REAL_MAXPAGE (1UL<<18) /\*FIXME brk probe broken*\/ */
--- gcl27-2.7.0.orig/h/unrandomize.h
+++ gcl27-2.7.0/h/unrandomize.h
@@ -62,17 +62,26 @@
 	exit(-1);
       }
     }
-#if defined(CSTACKMAX) && CSTACK_DIRECTION < 0
+#if defined(CSTACKMAX)
+#if CSTACK_DIRECTION < 0
+#define CSTACK_OFFSET (1L<<PAGEWIDTH)
+#define MAP_GROWSDOWN_FLAG MAP_GROWSDOWN
+#define CSTACK_SET CSTACKMAX-4*CSTACK_ALIGNMENT
+#else
+#define CSTACK_OFFSET (1L<<23)/*FIXME configurable*/
+#define MAP_GROWSDOWN_FLAG 0
+#define CSTACK_SET CSTACKMAX-CSTACK_OFFSET+4*CSTACK_ALIGNMENT
+#endif
     if ((void *)&argc > (void *)CSTACKMAX) {
-      if (mmap((void *)CSTACKMAX-(1L << PAGEWIDTH),(1L << PAGEWIDTH),
-	       PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_PRIVATE|MAP_ANON|MAP_STACK|MAP_GROWSDOWN,-1,0)==(void *)-1) {
-	printf("cannot mmap new stack %d\n",errno);
-	exit(-1);
-      }
+      if (mmap((void *)CSTACKMAX-CSTACK_OFFSET,(1L << PAGEWIDTH),
+	       PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_PRIVATE|MAP_ANON|MAP_STACK|MAP_GROWSDOWN_FLAG,-1,0)==(void *)-1) {
+	  printf("cannot mmap new stack %d\n",errno);
+	  exit(-1);
+	}
 #ifdef SET_STACK_POINTER
-      {void *p=(void *)CSTACKMAX-4*CSTACK_ALIGNMENT;asm volatile (SET_STACK_POINTER::"r" (p):"memory");}
+      {void *p=(void *)CSTACK_SET;asm volatile (SET_STACK_POINTER::"r" (p):"memory");}
 #else
-#error Cannot set stack pointer
+#error SET_STACK_POINTER undefined
 #endif
     }
 #endif
--- gcl27-2.7.0.orig/lsp/gcl_assert.lsp
+++ gcl27-2.7.0/lsp/gcl_assert.lsp
@@ -51,8 +51,9 @@
 		:interactive (lambda nil
 			       (mapcar (lambda (x)
 					 (format *query-io* "~&type a form to be evaluated for ~s:~%" x)
-					 (eval (read *query-io*))) places))
-		:test (lambda (c) places)
+					 (eval (read *query-io*)))
+				       places))
+		:test (lambda (c) (declare (ignore c)) places)
 		(declare (dynamic-extent r))
 		(values-list r))))
 
--- gcl27-2.7.0.orig/lsp/gcl_autoload.lsp
+++ gcl27-2.7.0/lsp/gcl_autoload.lsp
@@ -108,9 +108,9 @@
 
 ;;; C Interface.
 
-(defmacro Clines (&rest r) nil)
-(defmacro defCfun (&rest r) nil)
-(defmacro defentry (&rest r) nil)
+(defmacro Clines (&rest r) (declare (ignore r)) nil)
+(defmacro defCfun (&rest r) (declare (ignore r)) nil)
+(defmacro defentry (&rest r) (declare (ignore r)) nil)
 
 (defmacro defla (&rest r) (cons 'defun r))
 
--- gcl27-2.7.0.orig/lsp/gcl_bit.lsp
+++ gcl27-2.7.0/lsp/gcl_bit.lsp
@@ -92,7 +92,7 @@
 (setf (get 'bit-array-op 'compiler::cmp-inline) t)
 
 (defun copy-bit-vector (a i b j n)
-  (bit-array-op (lambda (x y) y) a b t i j i n))
+  (bit-array-op (lambda (x y) (declare (ignore x)) y) a b t i j i n))
 
 
 ;FIXME array-dimensions allocates....
@@ -129,7 +129,7 @@
 (defbitfn bit-andc2 (lambda (x y) (& x (~ y))))
 (defbitfn bit-orc1  (lambda (x y) (\| (~ x) y)))
 (defbitfn bit-orc2  (lambda (x y) (\| x (~ y))))
-(defbitfn bit-not   (lambda (x y) (~ x)))
+(defbitfn bit-not   (lambda (x y) (declare (ignore y)) (~ x)))
 
 (defun baset (v x &rest r)
   (declare (optimize (safety 1))(dynamic-extent r))
--- gcl27-2.7.0.orig/lsp/gcl_callhash.lsp
+++ gcl27-2.7.0/lsp/gcl_callhash.lsp
@@ -282,7 +282,7 @@
   (do-all-symbols (s) (let ((x (needs-recompile s))) (when x (pushnew (caar x) q))))
   (when q
     (format t "~%Pass 1 signature discovery on ~s functions ..." (length q))
-    (mapc (lambda (x) (format t "~s " x) (compile x)) q)
+    (mapc (lambda (x) (format t "~s~%" x) (compile x)) q)
     (gen-discovery-props)))
 
 (defun do-recomp2 (sp fl &aux *sig-discovery-props* *compile-verbose* r)
@@ -294,13 +294,14 @@
 	(push (list s sig) r))))
   (write-sys-proclaims1 sp r))
 
+;;FIXME not always idempotent
 (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)))))
     (when cdebug (compiler::cdebug))
-    (format t "~%Recompiling original source files ...")
+    (format t "~%Recompiling original source files ...~%")
     (mapc (lambda (x) (format t "~s~%" x) (compile-file x)) (remove nil fl))))
 
 (defun gen-all-ftype-symbols (&aux r)
--- gcl27-2.7.0.orig/lsp/gcl_defmacro.lsp
+++ gcl27-2.7.0/lsp/gcl_defmacro.lsp
@@ -234,6 +234,7 @@
      (when nap
        (case kk
 	     ((nil &optional) (unless n (bind s +kev+ (let ((q (extra (na s)))) (if (eq nap t) q `(when ,nap ,q))))))
+	     (&allow-other-keys (bind s +kev+ nap))
 	     (&key
 	      (unless aok
 		(let ((aop (tsym)))
--- gcl27-2.7.0.orig/lsp/gcl_defseq.lsp
+++ gcl27-2.7.0/lsp/gcl_defseq.lsp
@@ -49,16 +49,17 @@
 		       `((el (p i) (if l (if from-end (caar p) (car p)) (aref ,seq i)))
 			 (hd (p i) (if l (if from-end (car p) p) i))))
 		   ,@(unless nokey `((key (x) (if ,kf (funcall ,kf x) x))))
-                   (test-no-key (x y)
-		     (if (case ,tsc
-			   (0 (eq x y))
-			   (1 (eql x y))
-			   (2 (equal x y))
-			   (3 (equalp x y))
-			   (4 (funcall x y))
-			   (otherwise (funcall ,ts x y)))
-			 (not test-not) test-not))
+                     (test-no-key (x y)
+		       (if (case ,tsc
+			     (0 (eq x y))
+			     (1 (eql x y))
+			     (2 (equal x y))
+			     (3 (equalp x y))
+			     (4 (funcall x y))
+			     (otherwise (funcall ,ts x y)))
+			   (not test-not) test-not))
 		     (test (x y) (test-no-key x ,(if nokey 'y '(key y)))))
+	    (declare (ignorable #'test ,@(unless list `(#'el #'hd))))
 	    (when (case ,tsc
 		    ((1 2 3)
 		     (or ,@(unless list
--- gcl27-2.7.0.orig/lsp/gcl_defstruct.lsp
+++ gcl27-2.7.0/lsp/gcl_defstruct.lsp
@@ -341,7 +341,7 @@
 (defun update-sdata-included (name &aux r (i (sdata-includes (get name 's-data))))
   (when i
     (let ((to (cmp-norm-tp `(and ,(sdata-name i) (not (or ,@(sdata-included i))))))
-	  (tn (cmp-norm-tp name))(ntn (cmp-norm-tp `(not ,name))))
+	  (tn (cmp-norm-tp name)))
       (labels ((find-updates (x &aux (tp (car x)))
 		 (when (unless (tp<= #tstructure tp) (tp-and #tstructure tp))
 		   (let ((ntp (if (tp-and to tp) (tp-or tn tp) tp)));FIXME negative
@@ -353,6 +353,7 @@
 	(mapl #'find-updates (gethash (tsrch #tstructure) *uniq-tp*));FIXME more systematic
 	(mapl #'find-updates (gethash t *uniq-tp*))
 	(maphash (lambda (x y)
+		   (declare (ignore y))
 		   (mapl #'update-sig (car x))
 		   (if (cmpt (cadr x)) (mapl #'update-sig (cdadr x)) (update-sig (cdr x))))
 		 *uniq-sig*)))
@@ -674,12 +675,13 @@
 			      (vector `(copy-seq x)))))))
 	 ,@(mapcar (lambda (y) 
 		     (let* ((sn (pop y))
-			   (nm (if no-conc sn
-				 (intern (si:string-concatenate (string conc-name) (string sn)))))
-			   (di (pop y))
-			   (st (pop y))
-			   (ro (pop y))
-			   (offset (pop y)))
+			    (nm (if no-conc sn
+				    (intern (si:string-concatenate (string conc-name) (string sn)))))
+			    (di (pop y))
+			    (st (pop y))
+			    (ro (pop y))
+			    (offset (pop y)))
+		       (declare (ignore di ro))
 		       `(defun ,nm (x)
 			   (declare (optimize (safety 2)))
 			   (check-type x ,ctp)
--- gcl27-2.7.0.orig/lsp/gcl_deftype.lsp
+++ gcl27-2.7.0/lsp/gcl_deftype.lsp
@@ -493,11 +493,8 @@
 (deftype not (&whole w &rest r)
   (and-or-norm 'not w r));x and-or-flatten
 
-(deftype satisfies (&whole w pred &aux (tp (get pred 'predicate-type)))
-  (cond ((not tp) w)
-	((eq 'satisfies (car (expand-deftype tp))) w)
-	((normalize-type tp))))
-
+(deftype satisfies (&whole w pred &aux (tp (get pred 'predicate-type)));Note: guard against infinite recursion
+  (if tp (normalize-type tp) w))
 
 (deftype eql (&rest r)
   (when r
--- gcl27-2.7.0.orig/lsp/gcl_evalmacros.lsp
+++ gcl27-2.7.0/lsp/gcl_evalmacros.lsp
@@ -35,7 +35,7 @@
   (defmacro ?cons (f x &aux (s (sgen "?CONS"))) `(let ((,s ,x)) (if (cdr ,s) (cons ,f ,s) (car ,s))))
   (defmacro ?list (x &aux (s (sgen "?LIST"))) `(let ((,s ,x)) (when ,s (list ,s))))
   (defmacro zcollect (v r rp np &aux (s (sgen "ZCOLLECT")))
-    `(let ((,s ,v)) (setf rp (if rp (rplacd rp (list ,s)) (setq r ,s)) rp np)))
+    `(let ((,s ,v)) (setf ,rp (if ,rp (rplacd ,rp (list ,s)) (setq ,r ,s)) ,rp ,np)))
   (defmacro ?let (k kf r) `(let ((r ,r)) (if (eq ,k ,kf) r `(let ((,,k ,,kf)) (declare (ignorable ,,k)) ,r))))
   (defmacro ?key (x &aux (s (sgen "?KEY"))) `(if (or (constantp ,x) (symbolp ,x)) ,x ',s)))
 
@@ -330,20 +330,44 @@
 	,@body))
 
 ;FIXME try labels
+(defconstant +nontype-declare-keywords+ ;FIXME sync c1body
+  '(special ignore ignorable optimize ftype inline notinline hint
+    class object :register :dynamic-extent dynamic-extent))
+
 (defmacro dotimes ((var form &optional val) &rest body
-		   &aux (s (sgen "DOTIMES"))(m (sgen "DOTIMES")))
+		   &aux (s (sgen "DOTIMES"))(m (sgen "DOTIMES"))
+		     (t1 (load-time-value (list nil)))(t2 (load-time-value (list nil))))
   (declare (optimize (safety 1)))
-  `(let ((,s (block nil ,form)))
-     (check-type ,s integer)
-     (let ((,m (min (max 0 ,s) most-positive-fixnum)))
-       (do ((,var 0 (1+ ,var)))
-	   ((>= ,var ,m)
-	    (when (> ,s most-positive-fixnum)
-	      (let ((,var ,var)) ,@body)
-	      (do ((,var (1+ most-positive-fixnum) (1+ ,var)))((>= ,var ,s)) ,@body))
-	    ,val)
-	 ,@body))))
-
+  (unless (car t1)
+    (setf (car t1) (object-tp most-positive-fixnum)))
+  (unless (car t2)
+    (setf (car t2) (cmp-norm-tp `(integer ,(1+ most-positive-fixnum)))))
+  (multiple-value-bind
+	(doc decls) (parse-body-header body)
+    (declare (ignore doc))
+    (let* ((dtypes (mapcan (lambda (x)
+			     (mapcan (lambda (y)
+				       (when (consp y)
+					 (unless (member (car y) +nontype-declare-keywords+)
+					   (when (member var (cdr y))
+					     (list (if (eq (car y) 'type) (cadr y) (car y)))))))
+				     (cdr x)))
+			   decls))
+	   (dtypes (if dtypes (cmp-norm-tp (cons 'and dtypes)) t)))
+
+      `(let ((,s (block nil ,form)))
+	 (check-type ,s integer)
+	 (let ((,m (min (max 0 ,s) most-positive-fixnum)))
+	   (do ((,var 0 (1+ ,var)))
+	       ((>= ,var ,m)
+		(when (> ,s most-positive-fixnum)
+		  ,@(when (tp-and (car t1) dtypes)
+		      `((let ((,var most-positive-fixnum)) (declare (ignorable ,var)) ,@body)))
+		  ;; non-negative-bignum a bumped type
+		  ,@(when (tp-and (car t2) dtypes)
+		      `((do ((,var (1+ most-positive-fixnum) (1+ ,var)))((>= ,var ,s)) ,@body))))
+		,val)
+	     ,@body))))))
 
 (defmacro declaim (&rest l)
   (declare (optimize (safety 2)))
--- gcl27-2.7.0.orig/lsp/gcl_lr.lsp
+++ gcl27-2.7.0/lsp/gcl_lr.lsp
@@ -164,12 +164,9 @@
 	(not (zerop (mpz_tstbit x y))))
     (minusp x)))
 
+(declaim (inline immfixp))
 (defun immfixp (x)
   (lit :boolean "is_imm_fixnum(" (:object x) ")"))
-(putprop 'immfixp t 'compiler::cmp-inline)
-;(declaim (inline immfixp))
-(setf (get 'immfix 'si::type-predicate) 'immfixp)
-(setf (get 'immfixp 'si::predicate-type) 'immfix)
 
 (defun mpz_sgn (x)
   (declare (optimize (safety 1)))
--- gcl27-2.7.0.orig/lsp/gcl_make_pathname.lsp
+++ gcl27-2.7.0/lsp/gcl_make_pathname.lsp
@@ -36,13 +36,14 @@
 
 (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 y) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x)))
+(defconstant +glob-to-regexp-alist+ (list (cons #v"{[^}]*}" (lambda (x y) (declare (ignore y)) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x)))
 					  (cons #v"\\[[^\\]*\\]"
 						(lambda (x y)
+						  (declare (ignore y))
 						  (string-concatenate "(" (substitute #\^ #\! (subseq x 0 2)) (subseq x 2) ")")))
-					  (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) "\\."))))
+					  (cons #v"\\*" (lambda (x y) (declare (ignore x)) (if (plusp (length y)) (string-concatenate "([^" y "]*)") "(.*)")))
+					  (cons #v"\\?" (lambda (x y) (declare (ignore x)) (if (plusp (length y)) (string-concatenate "([^" y "])") "(.)")))
+					  (cons #v"\\." (lambda (x y) (declare (ignore x y))"\\."))))
 
 (defconstant +physical-pathname-defaults+ '(("" "" "" "")
 					    ("" "" "" "")
--- gcl27-2.7.0.orig/lsp/gcl_mislib.lsp
+++ gcl27-2.7.0/lsp/gcl_mislib.lsp
@@ -75,19 +75,19 @@
   (check-type ut integer)
   (check-type tz rational)
   (let ((ut (- ut +secs-to-1970+  (* (- tz (this-tz)) 3600))))
-    (multiple-value-bind
-	(s n h d m y w yd dstp off) (localtime ut)
-    (when (when tzp (> dstp 0))
-      (multiple-value-setq (s n h d m y w yd dstp1) (localtime (- ut 3600))))
-    (values s
-	    n
-	    (+ h (- dstp (or dstp1 dstp)))
-	    d
-	    (1+ m)
-	    (+ 1900 y)
-	    (if (zerop w) 6 (1- w))
-	    (unless tzp (> dstp 0))
-	    (if tzp tz (+ (truncate (- off) 3600) dstp))))))
+    (multiple-value-bind (s n h d m y w yd dstp off) (localtime ut)
+      (declare (ignore yd))
+      (when (when tzp (> dstp 0))
+	(multiple-value-setq (s n h d m y w yd dstp1) (localtime (- ut 3600))))
+      (values s
+	      n
+	      (+ h (- dstp (or dstp1 dstp)))
+	      d
+	      (1+ m)
+	      (+ 1900 y)
+	      (if (zerop w) 6 (1- w))
+	      (unless tzp (> dstp 0))
+	      (if tzp tz (+ (truncate (- off) 3600) dstp))))))
 
 (defun encode-universal-time (s n h d m y &optional (tz (this-tz) tzp))
   (declare (optimize (safety 2)))
@@ -227,6 +227,12 @@
     (heaprep))
   (values))
 
+(defun pool-watch (&optional (s 3) (c 10) &aux (x (pool-stat)))
+  (when (plusp c)
+    (format t "master pid ~s ~s processes ~s pages~%" (pop x) (pop x) (car x))
+    (sleep s)
+    (pool-watch s (1- c))))
+
 (defun gprof-output (symtab gmon)
   (with-open-file
      (s (format nil "|gprof -S '~a' '~a' '~a'" symtab (kcl-self) gmon))
--- gcl27-2.7.0.orig/lsp/gcl_packlib.lsp
+++ gcl27-2.7.0/lsp/gcl_packlib.lsp
@@ -109,6 +109,7 @@
 				,ql ,(if inh `(cons ,p (package-use-list ,p)) p))
 			  (next-var))))
 	 (,name nil (let ((f (next-var))) (values f (car f) ,a ,p))))
+	 (declare (ignorable #'inh-match))
 	,@body))))
 
 ;; (defmacro with-package-iterator ((name packlist key &rest keys) &rest body
--- gcl27-2.7.0.orig/lsp/gcl_predlib.lsp
+++ gcl27-2.7.0/lsp/gcl_predlib.lsp
@@ -257,6 +257,7 @@
           (random-state . random-state-p)
           (structure . structurep)
           (function . functionp)
+          (immfix . immfixp)
 	  (improper-cons . improper-consp)
           ;; (compiled-function . compiled-function-p)
           ;; (non-generic-compiled-function . non-generic-compiled-function-p)
@@ -264,7 +265,6 @@
 	  ))
 
 (dolist (l +type-alist+)
-  (putprop (car l) (cdr l) 'type-predicate)
   (when (symbolp (cdr l)) 
     (putprop (cdr l) (car l) 'predicate-type)))
 
--- gcl27-2.7.0.orig/lsp/gcl_s.lsp
+++ gcl27-2.7.0/lsp/gcl_s.lsp
@@ -61,8 +61,17 @@
        ,@(mapcar (lambda (z &aux (x (pop z))(s (pop z))(m (car z))(n (intern (string-concatenate "*" (string-upcase x)))))
 		   `(idefun ,n (x o s y)
 			    (declare (fixnum x o)(boolean s))
-			    (if s (lit ,x "((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]=" (,x y))
-			     (lit ,x "((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]")))) +ks+)))
+			    ,(if (when (eq n '*fixnum) (member :sparc64 *features*));Possibly unaligned access
+				 `(if s
+				      ;FIXME there does not appear any useful way to lift thie branch into lisp for possible branch elimination
+				      (lit :fixnum "((" (:fixnum x) "&(sizeof(fixnum)-1)) ? "
+					   "({fixnum _t=" (:fixnum y) ";unsigned char *p1=(void *)(((fixnum *)" (:fixnum x) ")+" (:fixnum o) "),*p2=(void *)&_t,*pe=p1+sizeof(fixnum);for (;p1<pe;) *p1++=*p2++;_t;}) : "
+					   "({((fixnum *)" (:fixnum x) ")[" (:fixnum o) "]=" (:fixnum y) ";}))")
+				      (lit :fixnum "((" (:fixnum x) "&(sizeof(fixnum)-1)) ? "
+					   "({fixnum _t;unsigned char *p1=(void *)(((fixnum *)" (:fixnum x) ")+" (:fixnum o) "),*p2=(void *)&_t,*pe=p1+sizeof(fixnum);for (;p1<pe;) *p2++=*p1++;_t;}) : "
+					   "((fixnum *)" (:fixnum x) ")[" (:fixnum o) "])"))
+				 `(if s (lit ,x "((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]=" (,x y))
+				      (lit ,x "((" ,(strcat x) "*)" (:fixnum x) ")[" (:fixnum o) "]"))))) +ks+)))
   (defmacro mfff nil
    `(progn
       (idefun address (x) (lit :fixnum "((fixnum)" (:object x) ")"))
--- gcl27-2.7.0.orig/lsp/gcl_sc.lsp
+++ gcl27-2.7.0/lsp/gcl_sc.lsp
@@ -28,11 +28,11 @@
    `(labels ((lower-case-p (x) (<= #.(char-code #\a) x #.(char-code #\z)))
 	     (upper-case-p (x) (<= #.(char-code #\A) x #.(char-code #\Z)))
 	     (char-upcase (x) 
-		     (if (lower-case-p x)
-			 (+ x #.(- (char-code #\A) (char-code #\a))) x))
+	       (if (lower-case-p x)
+		   (+ x #.(- (char-code #\A) (char-code #\a))) x))
 	     (char-downcase (x) 
-			    (if (upper-case-p x)
-				(+ x #.(- (char-code #\a) (char-code #\A))) x))
+	       (if (upper-case-p x)
+		   (+ x #.(- (char-code #\a) (char-code #\A))) x))
 	     (aref (s i) (*uchar (c-array-self s) i nil nil))
 	     (aset (v s i) (*uchar (c-array-self s) i t v))
 	     (char= (x z) (= x z))
@@ -41,7 +41,9 @@
 	     (char-equal (x z) (or (= x z) (= (char-upcase x) (char-upcase z))))
 	     (char-greaterp (x z) (> (char-upcase x) (char-upcase z)))
 	     (char-lessp    (x z) (< (char-upcase x) (char-upcase z))))
-	    ,@body))
+      (declare (ignorable #'lower-case-p #'upper-case-p #'char-upcase #'char-downcase #'aref #'aset
+			  #'char= #'char< #'char> #'char-equal #'char-greaterp #'char-lessp))
+      ,@body))
 
 (defmacro defstr (name (s1 s2) = &body body)
    `(defun ,name (,s1 ,s2  &key (start1 0) end1 (start2 0) end2)
--- gcl27-2.7.0.orig/lsp/gcl_seq.lsp
+++ gcl27-2.7.0/lsp/gcl_seq.lsp
@@ -180,9 +180,11 @@
   (unless (member rs seqs) (when fp (setf (fill-pointer rs) lp)))
   (block exit
 	 (apply 'map nil
-		(lambda (x &rest r) 
+		(lambda (x &rest r)
+		  (declare (ignore x))
 		  (when (if lp (= j lp) (endp h)) (return-from exit))
 		  (let ((tmp (apply g r))) 
-		    (if lp (setf (aref rs j) tmp j (1+ j)) (setf (car h) tmp h (cdr h))))) rs seqs))
+		    (if lp (setf (aref rs j) tmp j (1+ j)) (setf (car h) tmp h (cdr h)))))
+		rs seqs))
   (when fp (setf (fill-pointer rs) j))
   rs)
--- gcl27-2.7.0.orig/lsp/gcl_seqlib.lsp
+++ gcl27-2.7.0/lsp/gcl_seqlib.lsp
@@ -267,7 +267,7 @@
   (check-type sequence proper-sequence)
   (check-type start (or null seqind))
   (check-type end (or null seqind))
-  (nsubstitute-if item (lambda (x) t) sequence :start start :end end))
+  (nsubstitute-if item (lambda (x) (declare (ignore x)) t) sequence :start start :end end))
 
 (defun replace (s1 s2 &key (start1 0) end1 (start2 0) end2 &aux (os1 s1) s3)
   (declare (optimize (safety 1))(notinline make-list)(dynamic-extent s3))
--- gcl27-2.7.0.orig/lsp/gcl_serror.lsp
+++ gcl27-2.7.0/lsp/gcl_serror.lsp
@@ -74,8 +74,9 @@
 							(go ,tag))))
 					tcases)
 			       (return-from ,block ,form))
-		 ,@(mapcan (lambda (x &aux (tag (pop x))(type (pop x))(ll (pop x))(body x))
-			     (list tag `(return-from ,block (let ,(when ll `((,(car ll) ,var))) ,@body))))
+		  ,@(mapcan (lambda (x &aux (tag (pop x))(type (pop x))(ll (pop x))(body x))
+			      (declare (ignore type))
+			      (list tag `(return-from ,block (let ,(when ll `((,(car ll) ,var))) ,@body))))
 			   tcases))))))))
 
 (defmacro ignore-errors (&rest forms)
@@ -119,7 +120,7 @@
      ,@forms))
 
 (defun process-args (args &optional fc fa others);FIXME do this without consing, could be oom
-  (cond ((not args) (nconc (nreverse others) (when (and fc fa) (list (apply 'format nil fc fa)))))
+  (cond ((not args) (nconc (nreverse others) (when fc (list (apply 'format nil fc fa)))))
 	((eq (car args) :format-control)
 	 (process-args (cddr args) (cadr args) fa others))
 	((eq (car args) :format-arguments)
@@ -136,17 +137,32 @@
 	       (apply 'format nil datum args))
 	   datum))
 	((symbolp datum)
-	 (let ((args (process-args args)))
-	   (substitute 
-	    #\^ #\~ 
-	    (coerce-to-string
-	     (if args
-		 (apply 'string-concatenate (cons datum (make-list (length args) :initial-element " ~s")))
-	       (string datum))
-	     args))))
+	 (let* ((args (process-args args))
+		(fn (member :function-name args))
+		(args (if fn (nconc (ldiff args fn) (cddr fn)) args)))
+	   (string-concatenate
+	    (or (cadr fn) "")
+	    (substitute
+	     #\^ #\~
+	     (coerce-to-string
+	      (apply 'string-concatenate  datum (if args ": " "") (make-list (length args) :initial-element " ~a"))
+	      args)))))
 	("unknown error")))
 
-(defun warn (datum &rest arguments)
+(defun put-control-string (strm strng)
+  (when (tty-stream-p strm)
+    (let ((pos (c-stream-int strm)))
+      (format strm strng)
+      (c-set-stream-int strm pos))))
+
+(defvar *error-color* "92")
+
+(defun error-format (control &rest arguments)
+  (put-control-string *error-output* (concatenate 'string (string 27) "[1;" *error-color* "m"))
+  (apply 'format *error-output* control arguments)
+  (put-control-string *error-output* (concatenate 'string (string 27) "[0m")))
+
+(defun warn (datum &rest arguments);FIXME? &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name))))
   (declare (optimize (safety 2)))
   (let ((c (process-error datum arguments 'simple-warning)))
     (check-type c (or string (satisfies warningp)) "a warning condition")
@@ -155,7 +171,8 @@
     (restart-case
      (signal c)
      (muffle-warning nil :report "Skip warning."  (return-from warn nil)))
-    (format *error-output* "~&Warning: ~a~%" c)
+    (error-format "~&~a~%" c)
+    (force-output *error-output*)
     nil))
 (putprop 'cerror t 'compiler::cmp-notinline)
 
@@ -208,17 +225,18 @@
 	(*print-length* *debug-print-level*)
 	(*print-case* :upcase))
     (terpri *error-output*)
-    (format *error-output* (if (and correctable *break-enable*) "~&Correctable error: " "~&Error: "))
+    (error-format (if (and correctable *break-enable*) "Correctable error:" "Error:"))
     (let ((*indent-formatted-output* t))
-      (when (stringp condition) (format *error-output* condition)))
+      (when (stringp condition) (error-format condition)))
     (terpri *error-output*)
     (if (> (length *link-array*) 0)
-	(format *error-output* "Fast links are on: do (si::use-fast-links nil) for debugging~%"))
-    (format *error-output* "Signalled by ~:@(~S~).~%" (or *sig-fn-name* "an anonymous function"))
+	(error-format "Fast links are on: do (si::use-fast-links nil) for debugging~%"))
+    (error-format "Signalled by ~:@(~S~).~%" (or *sig-fn-name* "an anonymous function"))
     (when (and correctable *break-enable*)
-      (format *error-output* "~&If continued: ")
-      (funcall (restart-report-function correctable) *error-output*))
+      (error-format "~&If continued: "))
     (force-output *error-output*)
+    (when (and correctable *break-enable*)
+      (funcall (restart-report-function correctable) *debug-io*))
     (when *break-enable* (break-level condition))))
 
 
@@ -241,7 +259,6 @@
 	    (if p-e-p "" "dbl:")
 	    (if (eq *package* (find-package 'user)) "" (package-name *package*))
 	    *break-level*))
-  (force-output *error-output*)
 
   (setq - (dbl-read *debug-io* nil *top-eof*))
   (when (eq - *top-eof*) (bye -1))
@@ -313,13 +330,14 @@
 	(*print-case* :upcase))
     (terpri *error-output*)
     (cond (format-string
-	   (format *error-output* "~&Break: ")
+	   (error-format "~&Break: ")
 	   (let ((*indent-formatted-output* t))
-	     (apply 'format *error-output* format-string args))
+	     (apply 'error-format format-string args))
 	   (terpri *error-output*)
 	   (setq message (apply 'format nil format-string args)))
-	  (t (format *error-output* "~&Break.~%")
-	     (setq message ""))))
+	  (t (error-format "~&Break.~%")
+	     (setq message "")))
+    (force-output *error-output*))
   (with-simple-restart 
    (continue "Return from break.")
    (break-level message))
--- gcl27-2.7.0.orig/lsp/gcl_setf.lsp
+++ gcl27-2.7.0/lsp/gcl_setf.lsp
@@ -133,50 +133,44 @@
 (push :setf *features*)
 
 (defun get-setf-method-multiple-value (form &optional env &aux tem); (*setf-set* (setf-set))
-  (cond ((symbolp form)
-	 (let ((store (setf-gensym)))
-	   (values nil nil (list store) `(setq ,form ,store) form)))
-	((or (not (consp form)) (not (symbolp (car form))))
-	 (error "Cannot get the setf-method of ~S." form))
-	((multiple-value-bind 
-	  (t1 exp) (macroexpand form env)
-	  (when exp (setq tem t1)))
-	 (get-setf-method-multiple-value tem env))
-;	((and env (setq tem (assoc (car form) (second env))))
-;	 (setq tem (macroexpand form env))
-;	 (if (eq form tem) (error "Cannot get setf-method for ~a" form))
-;	 (return-from get-setf-method-multiple-value
-;		      (get-setf-method-multiple-value tem  env)))
-	((get (car form) 'setf-method)
-	 (apply (get (car form) 'setf-method) env (cdr form)))
-	((or (get (car form) 'setf-update-fn)
-	     (setq tem (get (car form) 'si::structure-access)))
-	 (let ((vars (mapcar (lambda (x) (setf-gensym)) (cdr form)))
-	       (store (setf-gensym)))
-	   (values vars (cdr form) (list store)
-	           (cond (tem (setf-structure-access (car vars) (car tem) (cdr tem) store))
-			 ((let ((f (get (car form) 'setf-update-fn)))
-			    `(,f ,@vars ,store))))
-		   (cons (car form) vars))))
-	((get (car form) 'setf-lambda)
-	 (let* ((vars (mapcar (lambda (x) (setf-gensym)) (cdr form)))
-		(store (setf-gensym))
-		(f (get (car form) 'setf-lambda)))
-		;; this looks bogus to me.  What if l is compiled?--wfs
-;		(f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l)))))
-	   (values vars (cdr form) (list store)
-		   (funcall (apply f vars) store)
-		   (cons (car form) vars))))
-	((macro-function (car form))
-	 (get-setf-method-multiple-value (macroexpand form env)))
-	(t 
-	 (let ((vars (mapcar (lambda (x) (setf-gensym)) (cdr form)))
-	       (store (setf-gensym)))
-	   (values vars (cdr form) (list store)
-	           `(funcall
-		     #'(setf ,(car form))
-		     ,store ,@vars )
-		   (cons (car form) vars))))))
+  (flet ((mvars (form) (mapcar (lambda (x) (declare (ignore x)) (setf-gensym)) (cdr form))))
+    (cond ((symbolp form)
+	   (let ((store (setf-gensym)))
+	     (values nil nil (list store) `(setq ,form ,store) form)))
+	  ((or (not (consp form)) (not (symbolp (car form))))
+	   (error "Cannot get the setf-method of ~S." form))
+	  ((multiple-value-bind
+		 (t1 exp) (macroexpand form env)
+	     (when exp (setq tem t1)))
+	   (get-setf-method-multiple-value tem env))
+	  ((get (car form) 'setf-method)
+	   (apply (get (car form) 'setf-method) env (cdr form)))
+	  ((or (get (car form) 'setf-update-fn)
+	       (setq tem (get (car form) 'si::structure-access)))
+	   (let ((vars (mvars form))
+		 (store (setf-gensym)))
+	     (values vars (cdr form) (list store)
+	             (cond (tem (setf-structure-access (car vars) (car tem) (cdr tem) store))
+			   ((let ((f (get (car form) 'setf-update-fn)))
+			      `(,f ,@vars ,store))))
+		     (cons (car form) vars))))
+	  ((get (car form) 'setf-lambda)
+	   (let* ((vars (mvars form))
+		  (store (setf-gensym))
+		  (f (get (car form) 'setf-lambda)))
+	     (values vars (cdr form) (list store)
+		     (funcall (apply f vars) store)
+		     (cons (car form) vars))))
+	  ((macro-function (car form))
+	   (get-setf-method-multiple-value (macroexpand form env)))
+	  (t
+	   (let ((vars (mvars form))
+		 (store (setf-gensym)))
+	     (values vars (cdr form) (list store)
+	             `(funcall
+		       #'(setf ,(car form))
+		       ,store ,@vars )
+		     (cons (car form) vars)))))))
 
 
 ;;;; SETF definitions.
@@ -247,7 +241,7 @@
 (defsetf fill-pointer c-set-adjvector-fillp)
 ;(defsetf symbol-plist si:set-symbol-plist)
 (defsetf symbol-plist (x) (y) `(c-set-symbol-plist ,x ,y))
-(defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v))
+(defsetf gethash (k h &optional d) (v) `(progn ,d (si:hash-set ,k ,h ,v)))
 (defsetf row-major-aref si::aset1)
 (defsetf readtable-case si::set-readtable-case)
 
@@ -346,7 +340,7 @@
 	      `(mask-field ,btemp ,access-form)))))
 
 (defun setf-expand-values (places newvalue env)
-  (let* ((syms (mapcar (lambda (x) (setf-gensym)) places))
+  (let* ((syms (mapcar (lambda (x) (declare (ignore x)) (setf-gensym)) places))
 	 (expns (mapcar (lambda (x y) (setf-expand-1 x y env)) places syms))
 	 binds decls ctps alist
 	 (setters (mapcar (lambda (x)
@@ -355,8 +349,8 @@
 							 (push (cons (car x) (cadr x)) alist)
 							 (push x binds)))
 					 (cadr x))
-				   (multiple-value-bind (doc dec ctp body)
-				       (parse-body-header (cddr x))
+				   (multiple-value-bind (doc dec ctp body) (parse-body-header (cddr x))
+				     (declare (ignore doc));FIXME?
 				     (setq decls (nconc decls dec) ctps (nconc ctps ctp))
 				     `(progn ,@body)))
 				  (x)))
--- gcl27-2.7.0.orig/lsp/gcl_subtypep.lsp
+++ gcl27-2.7.0/lsp/gcl_subtypep.lsp
@@ -26,7 +26,7 @@
    ((setq tem (coerce-to-standard-class ctp)) (normalize-instance tem));FIXME don't want to normalize a nil type, redundant code
    ((si-classp ctp) (si-class-name ctp));built-in
    ((setq tem (get ctp 's-data)) (or (sdata-type tem) `(structure ,ctp)))
-   (t (print (list 'bad-type type)) nil)))
+   (t (warn 'warning :format-control "Expanding unknown type ~s to nil:" :format-arguments (list type)) nil)))
 
 (defun expand-deftype (type &aux (e (just-expand-deftype type)))
   (unless (eq type e)
--- gcl27-2.7.0.orig/lsp/gcl_sym.lsp
+++ gcl27-2.7.0/lsp/gcl_sym.lsp
@@ -3,13 +3,11 @@
 ;; (export '(macro-function))
 (in-package :si)
 
-(defun macro-function (x &optional env)
+(defun macro-function (x &optional env &aux l)
   (declare (optimize (safety 2)))
   (check-type x symbol)
   (check-type env proper-list)
-  (cond ((when env
-	   (let* ((l (cdr (assoc x (cadr env)))))
-	     (when (eq (car l) 'macro) (cadr l)))))
+  (cond ((setq l (cdr (assoc x (cadr env)))) (when (eq (car l) 'macro) (cadr l)))
 	((unless (zerop (c-symbol-mflag x)) (c-symbol-gfdef x)))))
 
 (defun special-operator-p (x)
--- gcl27-2.7.0.orig/lsp/gcl_top.lsp
+++ gcl27-2.7.0/lsp/gcl_top.lsp
@@ -27,7 +27,7 @@
 
 (in-package :si)
 
-(export '(loc *tmp-dir* *error-p* *debug-print-level* *break-readtable* *break-enable*
+(export '(loc *tmp-dir* *debug-print-level* *break-readtable* *break-enable*
 	      vs ihs-vs ihs-fun frs-vs frs-bds frs-ihs bds-var bds-val super-go))
 
 ;FIXME ?
@@ -168,7 +168,6 @@
 		      (terpri))
 		    nil))
 	      (setq *evalhook* nil *applyhook* nil)
-	      (terpri *error-output*)
 	      (break-current)))
 	   nil)
        (emergency-reset)))))
@@ -207,8 +206,6 @@
    (let ((tem (or val (and (boundp sym) (symbol-value sym)))))
       (if tem (set sym (coerce-slash-terminated tem)))))
 
-(defvar *error-p* nil)
-
 (defun process-some-args (args &optional compile &aux *load-verbose*)
   (when args
     (let ((x (pop args)))
@@ -235,9 +232,10 @@
 	   (file (cdr (assoc :compile compile)))
 	   (o (cdr (assoc :o compile)))
 	   (compile (remove :o (remove :compile compile :key 'car) :key 'car))
-+	   (compile (cons (cons :output-file (or o (merge-pathnames ".o" file))) compile))
-	   (result (system:error-set `(apply 'compile-file ,file ',(mapcan (lambda (x) (list (car x) (cdr x))) compile)))))
-      (bye (if (or *error-p* (equal result '(nil))) 1 0)))))
+	   (compile (cons (cons :output-file (or o (merge-pathnames ".o" file))) compile)))
+      (multiple-value-bind (r w e) (apply 'compile-file file (mapcan (lambda (x) (list (car x) (cdr x))) compile))
+	(declare (ignore r w))
+	(bye (if e 1 0))))))
 
 (defun dbl-read (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil))
 
--- gcl27-2.7.0.orig/lsp/gcl_type.lsp
+++ gcl27-2.7.0/lsp/gcl_type.lsp
@@ -182,7 +182,7 @@
 (defun atomic-ntp-array-dimensions (ntp)
   (unless (or (cadr ntp) (caddr ntp))
     (when (car ntp)
-      (lreduce (lambda (y x) (when (equal y x) y))
+      (lreduce (lambda (&rest xy) (when (equal (car xy) (cadr xy)) (car xy)))
 	       (car ntp)
 	       :key (lambda (x)
 		      (case (car x)
@@ -203,7 +203,7 @@
 (defun atomic-ntp-array-rank (ntp)
   (unless (or (cadr ntp) (caddr ntp))
     (when (car ntp)
-      (lreduce (lambda (y x) (when (equal y x) y))
+      (lreduce (lambda (&rest xy) (when (equal (car xy) (cadr xy)) (car xy)))
 	       (car ntp)
 	       :key (lambda (x)
 		      (case (car x)
@@ -675,7 +675,7 @@
 	 (rs +rs+))
     (declare (special rs));FIXME to prevent unroll of +rs+
     (or (caar (member-if (lambda (x)
-			   (let* ((f (pop x))
+			   (let* ((x (cdr x))
 				  (z (mapcan
 				      (lambda (y)
 					(lremove-duplicates
--- gcl27-2.7.0.orig/lsp/gcl_typecase.lsp
+++ gcl27-2.7.0/lsp/gcl_typecase.lsp
@@ -125,7 +125,7 @@
 (defun mkinfm (f tp z &aux (z (?-add 'progn z)))
   (if (tp>= tp #tt) z `(infer-tp ,f ,tp ,z)))
 
-(define-compiler-macro typecase (&whole w x &rest ff)
+(define-compiler-macro typecase (x &rest ff)
   (let* ((bind (unless (symbolp x) (list (list (gensym) x))));FIXME sgen?
 	 (f (or (caar bind) x))
 	 (o (member-if (lambda (x) (or (eq (car x) t) (eq (car x) 'otherwise))) ff));FIXME
@@ -162,7 +162,10 @@
 (defconstant +xi+ (let* ((a (type-and-list (list (cmp-norm-tp `(and number (not immfix))))))
 			 (rl (cdr (assoc 'tp8 +rs+)))
 			 (i (lremove-duplicates (mapcar (lambda (x) (cdr (assoc (cadr x) rl))) a)))
-			 (mi (apply 'min i))(xi (apply 'max i))(m (apply '+ i)))
+;			 (mi (apply 'min i))
+			 (xi (apply 'max i))
+;			 (m (apply '+ i))
+			 )
 ;		    (assert (= mi 1))
 ;		    (assert (= m (/ (* xi (1+ xi)) 2)))
 		    xi))
--- gcl27-2.7.0.orig/lsp/gcl_typeof.lsp
+++ gcl27-2.7.0/lsp/gcl_typeof.lsp
@@ -127,7 +127,7 @@
 (defun cons-type-of (x);recurse?
   (if (improper-consp x) 'improper-cons 'proper-cons))
 
-(mapc (lambda (x &aux (z (caddr x)))
+(mapc (lambda (x)
 	(setf (aref +type-of-dispatch+ (tp7-ind (eval (cadr x))))
 	      (let* ((x (car x))(x (if (listp x) (car x) x)))
 		(case
--- gcl27-2.7.0.orig/mod/gcl_ansi_io.lsp
+++ gcl27-2.7.0/mod/gcl_ansi_io.lsp
@@ -55,7 +55,7 @@
 	      (if (pprint-quit x h ,s -1)
 		  (return-from do-pref nil)
 		  (write-string ,prefix ,s)))
-	    (do-suf (x h) (write-string ,suffix ,s))
+	    (do-suf (x h) (declare (ignore x h)) (write-string ,suffix ,s));FIXME
 	    (do-pprint (x h &aux (,count 0))
 	      (macrolet
 		  ((pprint-pop nil
--- gcl27-2.7.0.orig/o/alloc.c
+++ gcl27-2.7.0/o/alloc.c
@@ -792,6 +792,13 @@ too_full_p(struct typemanager *tm) {
 
 }
 
+DEFUN("POOL-STAT",object,fSpool_stat,SI,0,0,NONE,OO,OO,OO,OO,(void),"") {
+
+  pool_stat();
+  RETURN1(MMcons(make_fixnum(pool_pid),MMcons(make_fixnum(pool_n),MMcons(make_fixnum(pool_s),Cnil))));
+
+}
+
 static inline bool
 do_gc_p(struct typemanager *tm,fixnum n) {
 
--- gcl27-2.7.0.orig/o/assignment.c
+++ gcl27-2.7.0/o/assignment.c
@@ -161,7 +161,6 @@ DEFUN("FUNCTION-NAME",object,fSfunction_
 DEFUN("FSET",object,fSfset,SI,2,2,NONE,OO,OO,OO,OO,(object sym,object function),"") {
 
   object x;
-  extern int initializing_boot;
 
   if (type_of(sym)!=t_symbol)
     sym=ifuncall1(sSfunid_to_sym,sym);
@@ -174,9 +173,6 @@ DEFUN("FSET",object,fSfset,SI,2,2,NONE,O
       FEerror("~S, a special form, cannot be redefined.",
 	      1, sym);
   }
-  if (sym->s.s_hpack == lisp_package &&
-      sym->s.s_gfdef != OBJNULL && !initializing_boot && sLwarn->s.s_gfdef)
-    ifuncall2(sLwarn,make_simple_string("~S is being redefined."),sym);
   sym = clear_compiler_properties(sym,function);
   if (type_of(function) == t_function) {
     sym->s.s_gfdef = function;
@@ -259,10 +255,6 @@ DEFUN("FMAKUNBOUND",object,fLfmakunbound
   }
   remf(&(rsym->s.s_plist),sStraced);
   clear_compiler_properties(rsym,Cnil);
-  if (rsym->s.s_hpack == lisp_package &&
-      rsym->s.s_gfdef != OBJNULL && !raw_image) {
-    ifuncall2(sLwarn, make_simple_string("~S is being redefined."), rsym);
-  }
 
   rsym->s.s_gfdef = OBJNULL;
   rsym->s.s_mflag = FALSE;
--- gcl27-2.7.0.orig/o/error.c
+++ gcl27-2.7.0/o/error.c
@@ -35,7 +35,7 @@ object sSterminal_interrupt;
 void
 assert_error(const char *a,unsigned l,const char *f,const char *n) {
 
-  if (!raw_image && core_end && core_end==sbrk(0) && errno!=ENOMEM)
+  if (!raw_image && core_end && core_end==sbrk(0) && errno!=ENOMEM && ihs_top>=ihs_org)
     FEerror("The assertion ~a on line ~a of ~a in function ~a failed: ~a",5,
 	    make_simple_string(a),make_fixnum(l),
 	    make_simple_string(f),make_simple_string(n),make_simple_string(strerror(errno)));
--- gcl27-2.7.0.orig/o/file.d
+++ gcl27-2.7.0/o/file.d
@@ -709,6 +709,53 @@ fSmake_string_input_stream_int(object x,
 }
 #endif
 
+static bool
+tty_stream_p(object strm) {
+
+  if (type_of(strm)!=t_stream)
+    return(FALSE);
+
+  switch (strm->sm.sm_mode) {
+  case smm_input:
+  case smm_output:
+  case smm_io:
+    return(strm->sm.sm_fp && isatty(fileno(strm->sm.sm_fp)) ? TRUE : FALSE);
+
+  case smm_socket:
+  case smm_probe:
+  case smm_string_input:
+  case smm_string_output:
+    return(FALSE);
+
+  case smm_broadcast:
+  case smm_concatenated:
+    {
+      object x;
+      for (x=strm->sm.sm_object0;!endp(x);x=x->c.c_cdr)
+	if (!tty_stream_p(x->c.c_car))
+	  return(FALSE);
+      return(TRUE);
+    }
+
+  case smm_file_synonym:
+  case smm_synonym:
+    return(tty_stream_p(symbol_value(strm->sm.sm_object0)));
+
+  case smm_two_way:
+  case smm_echo:
+    return(tty_stream_p(STREAM_INPUT_STREAM(strm)) && tty_stream_p(STREAM_OUTPUT_STREAM(strm)));
+
+  default:
+    FEerror("Illegal stream mode for ~S.",1,strm);
+    return(FALSE);
+
+  }
+
+}
+
+DEFUN("TTY-STREAM-P",object,fStty_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  return tty_stream_p(x)  ? Ct : Cnil;
+}
 DEFUN("STRING-INPUT-STREAM-P",object,fSstring_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
   return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_input ? Ct : Cnil;
 }
--- gcl27-2.7.0.orig/o/gbc.c
+++ gcl27-2.7.0/o/gbc.c
@@ -304,7 +304,6 @@ enter_mark_origin(object *p) {
 
 /* Whenever two arrays are linked together by displacement,
    if one is live, the other will be made live */
-#define mark_displaced_field(ar) mark_object(ar->a.a_displaced)
 
 #define LINK_ARRAY_MARKED(x_) ((*(unsigned long *)(x_))&0x1)
 #define MARK_LINK_ARRAY(x_) ((*(unsigned long *)(x_))|=1UL)
@@ -1123,12 +1122,12 @@ GBC(enum type t) {
       gc_time=0;
 
 #ifdef SGC
-    emsg("[%s for %ld %s pages..",
+    omsg("[%s for %ld %s pages..",
 	 (sgc_enabled ? "SGC" : "GC"),
 	 (sgc_enabled ? sgc_count_type(t) : tm_of(t)->tm_npage),
 	 (tm_table[(int)t].tm_name)+1);
 #else
-    emsg("[%s for %ld %s pages..",
+    omsg("[%s for %ld %s pages..",
 	 ("GC"),
 	 (tm_of(t)->tm_npage),
 	 (tm_table[(int)t].tm_name)+1);
@@ -1254,9 +1253,9 @@ GBC(enum type t) {
   if (sSAnotify_gbcA->s.s_dbind != Cnil) {
     
     if (gc_recursive)
-      emsg("(T=...).GC finished]\n");
+      omsg("(T=...).GC finished]\n");
     else
-      emsg("(T=%d).GC finished]\n",gc_start);
+      omsg("(T=%d).GC finished]\n",gc_start);
 
   }
   
--- gcl27-2.7.0.orig/o/main.c
+++ gcl27-2.7.0/o/main.c
@@ -289,8 +289,7 @@ get_gc_environ(void) {
     massert(gc_page_max>=0.0);
   }
 
-  multiprocess_memory_pool=
-    (e=getenv("GCL_MULTIPROCESS_MEMORY_POOL")) && (*e=='t' || *e=='T');
+  multiprocess_memory_pool=getenv("GCL_MULTIPROCESS_MEMORY_POOL");
 
   wait_on_abort=0;
   if ((e=getenv("GCL_WAIT_ON_ABORT")))
@@ -582,6 +581,11 @@ main(int argc, char **argv, char **envp)
 #include "unrandomize.h"
 #endif
 
+  vs_top = vs_base = vs_org;
+  ihs_top = ihs_org-1;
+  bds_top = bds_org-1;
+  frs_top = frs_org-1;
+
   gcl_init_alloc(alloca(1));
 
   setbuf(stdin, stdin_buf); 
@@ -597,11 +601,6 @@ main(int argc, char **argv, char **envp)
   ARGV = argv;
   ENVP = envp;
   
-  vs_top = vs_base = vs_org;
-  ihs_top = ihs_org-1;
-  bds_top = bds_org-1;
-  frs_top = frs_org-1;
-
   if (raw_image) {
 
     printf("GCL (GNU Common Lisp)  %s  %ld pages\n",LISP_IMPLEMENTATION_VERSION,real_maxpage);
--- gcl27-2.7.0.orig/o/makefile
+++ gcl27-2.7.0/o/makefile
@@ -112,9 +112,6 @@ $(DECL): $(HDIR)/make-decl.h $(INI_FILES
 grab_defs: grab_defs.c
 	${CC} $(OFLAGS) -o grab_defs  grab_defs.c
 
-wpool: wpool.o
-	$(CC) $(LDFLAGS) -o $@ $<
-
 $(GCLIB): ${ALIB} 
 	rm -f gcllib.a
 	$(AR) gcllib.a ${ALIB}
--- gcl27-2.7.0.orig/o/makefun.c
+++ gcl27-2.7.0/o/makefun.c
@@ -87,7 +87,7 @@ DEFUN("INIT-FUNCTION",object,fSinit_func
   d=data!=Cnil ? data : m;
   i=sSPinit;
   i=i ? i->s.s_dbind : i;
-  if (is_text_addr(addr)||get_pageinfo(addr)||!i||i==OBJNULL)
+  if (is_text_addr(addr)||(get_pageinfo(addr)&&!is_bigger_fixnum(addr))||!i||i==OBJNULL)
     s=addr;
   else {
     massert(type_of(addr)==t_fixnum);
--- gcl27-2.7.0.orig/o/sfasli.c
+++ gcl27-2.7.0/o/sfasli.c
@@ -125,7 +125,7 @@ LFD(build_symbol_table)(void) {
   {
     fixnum i;
 
-    min_text=(void *)&etext;
+    min_text=etext;
     for (i=0;i<c_table.alloc_length;i++) {
       void *p=(void *)c_table.ptable[i].address;
       min_text=p<min_text ? p : min_text;
--- gcl27-2.7.0.orig/o/sgbc.c
+++ gcl27-2.7.0/o/sgbc.c
@@ -912,7 +912,7 @@ sgc_quit(void) {
 
 fixnum debug_fault =0;
 fixnum fault_count =0;
-extern char etext;
+
 static void
 memprotect_handler(int sig, long code, void *scp, char *addr) {
   
--- gcl27-2.7.0.orig/pcl/gcl_pcl_boot.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_boot.lisp
@@ -628,15 +628,15 @@ work during bootstrapping.
          (bind-args (,lambda-list ,method-args)
 	   ,@body)))))
 
-(defmacro fast-lexical-method-functions 
-  ((lambda-list next-method-call args rest-arg &rest lmf-options)
-   &body body)
- `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
-    (bind-lexical-method-functions (,@lmf-options)
-      (let ,(mapcar (lambda (x) (list x x)) args)
-	(declare (ignorable ,@args))
-        (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
-		   ,@body)))))
+(defmacro fast-lexical-method-functions ((lambda-list next-method-call args rest-arg &rest lmf-options)
+					 &body body)
+  `(bind-fast-lexical-method-macros
+    (,args ,rest-arg ,next-method-call)
+    (bind-lexical-method-functions
+     (,@lmf-options)
+     (bind-args
+      (,lambda-list (list* ,@args ,rest-arg))
+      ,@body))))
 
 (defun call-no-next-method (method-name-declaration &rest args)
   (destructuring-bind (name qualifiers specializers)
@@ -941,7 +941,7 @@ work during bootstrapping.
 	       (declare (dynamic-extent cnm-args))
 	       (call-next-method-body ,method-name-declaration cnm-args))
 	     (next-method-p () (next-method-p-body)))
-;	(declare (ignorable #'call-next-method #'next-method-p))
+	(declare (ignorable #'call-next-method #'next-method-p))
 	,@body)))
 
 (defmacro bind-args ((lambda-list args) &body body)
--- gcl27-2.7.0.orig/pcl/gcl_pcl_env.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_env.lisp
@@ -193,10 +193,10 @@
 				  (lisp::package-hashtable-free external))
 			 #-cmu 0))
     #-cmu (do-external-symbols (sym object)
-;	    (declare (ignore sym))
+	    (declare (ignore sym))
 	    (incf external-count))
     #-cmu (do-symbols (sym object)
-;	    (declare (ignore sym))
+	    (declare (ignore sym))
 	    (incf internal-count))
     #-cmu (decf internal-count external-count)
     (format stream "It has ~D internal and ~D external symbols (~D total).~%"
--- gcl27-2.7.0.orig/pcl/gcl_pcl_impl_low.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_impl_low.lisp
@@ -53,17 +53,21 @@
 
 (defun allocate-funcallable-instance-2 ()
   (let (dummy)
+    (declare (ignore dummy))
     (lambda (&rest args)
       (declare (ignore args))
       (setq dummy (make-dummy-var));use dummy to ensure freshly allocated closure
       (called-fin-without-function))))
 
+(defun fun-to-funcallable-instance (fin);This cannot be inlines
+  (c-set-t-tt fin (logior 1 (c-t-tt fin)))
+  (the si::funcallable-std-instance fin))
+
 (defun allocate-funcallable-instance-1 ()
   (let ((fin (allocate-funcallable-instance-2))
 	(env (make-list funcallable-instance-closure-size :initial-element nil)))
     (si::set-function-environment fin env)
-    (c-set-t-tt fin (logior 1 (c-t-tt fin)))
-    (the si::funcallable-std-instance fin)))
+    (fun-to-funcallable-instance fin)))
 
 (defun funcallable-instance-p (x) (typep x 'funcallable-std-instance))
 (defun std-instance-p (x) (typep x 'std-instance))
--- gcl27-2.7.0.orig/pcl/gcl_pcl_init.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_init.lisp
@@ -139,7 +139,7 @@
   (when (eq slot-names 't)
     ;; FIXME this should be in the -t- and -nil- functions eventually
     ;; loop through initargs looking for errors
-    (doplist (initarg val) initargs)
+    (doplist (initarg val) initargs (declare (ignore val)))
     (return-from shared-initialize
 		 (progn 
 		   (call-initialize-function
@@ -150,7 +150,7 @@
   (when (eq slot-names 'nil)
     ;; FIXME this should be in the -t- and -nil- functions eventually
     ;; loop through initargs looking for errors
-    (doplist (initarg val) initargs)
+    (doplist (initarg val) initargs (declare (ignore val)))
     (return-from shared-initialize
 		 (progn
 		   (call-initialize-function
@@ -251,11 +251,12 @@
     ;; against the total set that we know are legal.
     (push :allow-other-keys legal)
     (doplist (key val) initargs
-       (unless (memq key legal)
-	 (if error-p
-	     (error 'program-error :format-control "Invalid initialization argument ~S for class ~S"
-		    :format-arguments (list key  (class-name class)))
-	     (return-from check-initargs-2-plist nil)))))
+	     (declare (ignore val))
+	     (unless (memq key legal)
+	       (if error-p
+		   (error 'program-error :format-control "Invalid initialization argument ~S for class ~S"
+			  :format-arguments (list key  (class-name class)))
+		   (return-from check-initargs-2-plist nil)))))
   t)
 
 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
--- gcl27-2.7.0.orig/pcl/gcl_pcl_macros.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_macros.lisp
@@ -130,6 +130,7 @@
 
 (eval-when (compile load eval)
   (defun extract-declarations (body &optional environment)
+    (declare (ignore environment))
     (multiple-value-bind (doc decls ctps body) (si::parse-body-header body)
       (values doc decls (nconc ctps body)))))
 
--- gcl27-2.7.0.orig/pcl/gcl_pcl_std_class.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_std_class.lisp
@@ -398,11 +398,12 @@
 		(loop for (option value . more) on slot by #'cddr
 		      when (and (member option '(:allocation :type :initform
 							     :documentation))
+				(progn value t)
 				(not (eq unsupplied
-					 (getf more option unsupplied)))) do
-					 (error 'program-error :format-control
-							 "Duplicate slot option ~S for slot ~S."
-							 :format-arguments (list option slot-name))))
+					 (getf more option unsupplied))))
+		      do (error 'program-error :format-control
+				"Duplicate slot option ~S for slot ~S."
+				:format-arguments (list option slot-name))))
 	  ;;
 	  ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
 	  ;; appears more than once in :DEFAULT-INITARGS class option.
--- gcl27-2.7.0.orig/pcl/gcl_pcl_vector.lisp
+++ gcl27-2.7.0/pcl/gcl_pcl_vector.lisp
@@ -227,7 +227,6 @@
 
 (defun pv-table-lookup (pv-table pv-wrappers)
   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
-	 (call-list (pv-table-call-list pv-table))
 	 (cache (or (pv-table-cache pv-table)
 		    (setf (pv-table-cache pv-table)
 			  (get-cache (- (length slot-name-lists)
@@ -237,7 +236,7 @@
 				     2)))))
     (or (probe-cache cache pv-wrappers)
 	(let* ((pv (compute-pv slot-name-lists pv-wrappers))
-	       (calls '#());(compute-calls call-list pv-wrappers)
+	       (calls '#())
 	       (pv-cell (cons pv calls))
 	       (new-cache (fill-cache cache pv-wrappers pv-cell)))
 	  (unless (eq new-cache cache)
@@ -319,6 +318,8 @@
 		     cache))))))
 
 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
+  (declare (optimize (safety 1)))
+  (check-type pv-size si::seqbnd)
   (if (not (if (atom wrappers)
 	       (eq cwrapper wrappers)
 	       (dolist (wrapper wrappers nil)
@@ -982,10 +983,24 @@
 	  (make-method-initargs-form-internal1
 	   initargs (cddr lmf) args lmf-params restp)))))
 
+(defun split-declarations-moving-ignores (body req-args &aux r)
+  (multiple-value-bind (outer-decls inner-decls body)
+      (split-declarations body req-args)
+    (values
+     (mapcar (lambda (x)
+	       (cons 'declare
+		     (remove-if (lambda (y)
+				  (when (and (consp y) (member (car y) '(ignore ignorable)))
+				    (push y r)))
+				(cdr x))))
+	     outer-decls)
+     (cons (cons 'declare r) inner-decls)
+     body)))
+
 (defun make-method-initargs-form-internal1 
     (initargs body req-args lmf-params restp)
   (multiple-value-bind (outer-decls inner-decls body)
-      (split-declarations body req-args)
+      (split-declarations-moving-ignores body req-args)
     (let* ((rest-arg (when restp '.rest-arg.))
 	   (args+rest-arg (if restp (append req-args (list rest-arg)) req-args)))
       `(list* :fast-function
--- gcl27-2.7.0.orig/unixport/init_raw.lsp.in
+++ gcl27-2.7.0/unixport/init_raw.lsp.in
@@ -32,7 +32,7 @@
       (remprop s 'deftype-form)))
   (let* ((p (find-package "PCL"))(x (when p (find-symbol "DO-SATISFIES-DEFTYPE" p))))
     (when (and x (fboundp x))
-      (setf (symbol-function x) (lambda (x y) nil)))))
+      (setf (symbol-function x) (lambda (x y) (declare (ignore x y)) nil)))))
 
 (do-symbols (s)
   (when (get s 'proclaimed-function)
