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.
 .
 gcl (2.6.10-17) unstable; urgency=high
 .
   * 2.6.11pre test 16
Author: Camm Maguire <camm@debian.org>

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

Origin: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: http://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: <YYYY-MM-DD>

--- gcl-2.6.10.orig/clcs/gcl_clcs_condition_definitions.lisp
+++ gcl-2.6.10/clcs/gcl_clcs_condition_definitions.lisp
@@ -3,408 +3,175 @@
 (IN-PACKAGE "CONDITIONS")
 
 (eval-when (compile load eval)
-(pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions
-	 *features*)
-)
+  (pushnew :clos-conditions *features*))
 
 (eval-when (compile load eval)
-(when (and (member :clos-conditions *features*)
-	   (member :defstruct-conditions *features*))
-  (dolist (sym '(simple-condition-format-string simple-condition-format-arguments
-		 type-error-datum type-error-expected-type
-		 case-failure-name case-failure-possibilities
-		 stream-error-stream file-error-pathname package-error-package
-		 cell-error-name arithmetic-error-operation
-		 internal-error-function-name))
-    (when (fboundp sym) (fmakunbound sym)))
-  (setq *features* (remove :defstruct-conditions *features*)))
-)
-
-(DEFINE-CONDITION WARNING (CONDITION)
-  ())
-
-(DEFINE-CONDITION SERIOUS-CONDITION (CONDITION)
-  ())
-
-(DEFINE-CONDITION ERROR (SERIOUS-CONDITION)
-  ())
-
-(DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM)
-  (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING    CONDITION)
-	 		 (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)))
-
-(DEFINE-CONDITION SIMPLE-CONDITION (CONDITION)
-  #-(or clos pcl)
-  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
-  #+(or clos pcl)
-  ((FORMAT-STRING :type string
-		  :initarg :FORMAT-STRING
-		  :reader SIMPLE-CONDITION-FORMAT-STRING)
-   (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS
-		     :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS
-		     :initform '()))
-  #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-)
-  (:REPORT SIMPLE-CONDITION-PRINTER))
-
-(DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING)
-  #-(or clos pcl)
-  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-)
-  #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
-
-(DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION ERROR)
-  #-(or clos pcl)
-  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-)
-  #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
-
-(DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ())
-
-(DEFINE-CONDITION STACK-OVERFLOW    (STORAGE-CONDITION) ())
-
-(DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ())
-
-(DEFINE-CONDITION TYPE-ERROR (ERROR)
-  #-(or clos pcl)
-  (DATUM EXPECTED-TYPE)
-  #+(or clos pcl)
-  ((DATUM :initarg :DATUM
-	  :reader TYPE-ERROR-DATUM)
-   (EXPECTED-TYPE :initarg :EXPECTED-TYPE
-		  :reader TYPE-ERROR-EXPECTED-TYPE))
-  (:report
-    (lambda (condition stream)
-      (format stream "~S is not of type ~S."
-	      (TYPE-ERROR-DATUM CONDITION)
-	      (TYPE-ERROR-EXPECTED-TYPE CONDITION)))))
-
-(DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR)
-  #-(or clos pcl)
-  (FORMAT-STRING (FORMAT-ARGUMENTS '()))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-)
-  #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
-
-(DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR)
- #-(or clos pcl)
- (NAME POSSIBILITIES)
- #+(or clos pcl)
- ((NAME :initarg :NAME
-	:reader CASE-FAILURE-NAME)
-  (POSSIBILITIES :initarg :POSSIBILITIES
-		 :reader CASE-FAILURE-POSSIBILITIES))
-  (:REPORT
-    (LAMBDA (CONDITION STREAM)
-      (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S."
-	      (TYPE-ERROR-DATUM CONDITION)
-	      (CASE-FAILURE-NAME CONDITION)
-	      (CASE-FAILURE-POSSIBILITIES CONDITION)))))
-
-(DEFINE-CONDITION PROGRAM-ERROR (ERROR)
-  ())
-
-(DEFINE-CONDITION CONTROL-ERROR (ERROR)
-  ())
-
-(DEFINE-CONDITION STREAM-ERROR (ERROR)
-  #-(or clos pcl)
-  (STREAM)
-  #+(or clos pcl)
-  ((STREAM :initarg :STREAM
-	   :reader STREAM-ERROR-STREAM)))
-
-(DEFINE-CONDITION END-OF-FILE (STREAM-ERROR)
-  ()
-  (:REPORT (LAMBDA (CONDITION STREAM)
-	     (FORMAT STREAM "Unexpected end of file on ~S."
-		     (STREAM-ERROR-STREAM CONDITION)))))
-
-(DEFINE-CONDITION FILE-ERROR (ERROR)
-  #-(or clos pcl)
-  (PATHNAME)
-  #+(or clos pcl)
-  ((PATHNAME :initarg :PATHNAME
-	     :reader FILE-ERROR-PATHNAME)))
-
-(DEFINE-CONDITION PACKAGE-ERROR (ERROR)
-  #-(or clos pcl)
-  (PACKAGE)
-  #+(or clos pcl)
-  ((PACKAGE :initarg :PACKAGE
-	    :reader PACKAGE-ERROR-PACKAGE)
-   (MESSAGE :initarg :MESSAGE
-	    :reader PACKAGE-ERROR-MESSAGE))
-  (:report
-    (lambda (condition stream)
-      (format stream "A package error occurred on ~S: ~S."
-	      (PACKAGE-ERROR-PACKAGE CONDITION)
-	      (PACKAGE-ERROR-MESSAGE CONDITION)))))
+  (when (and (member :clos-conditions *features*)
+	     (member :defstruct-conditions *features*))
+    (dolist (sym '(simple-condition-format-control simple-condition-format-arguments
+						  type-error-datum type-error-expected-type
+						  case-failure-name case-failure-possibilities
+						  stream-error-stream file-error-pathname package-error-package
+						  cell-error-name arithmetic-error-operation
+						  internal-error-function-name))
+      (when (fboundp sym) (fmakunbound sym)))
+    (setq *features* (remove :defstruct-conditions *features*))))
+
+(define-condition warning (condition) ())
+(define-condition style-warning (warning) ())
+
+(define-condition serious-condition (condition) ())
+(define-condition error (serious-condition) ())
+
+(define-condition simple-condition (condition)
+  ((format-control :type string
+		  :initarg :format-control
+		  :reader simple-condition-format-control
+		  :initform "")
+   (format-arguments :initarg :format-arguments
+		     :reader simple-condition-format-arguments
+		     :initform nil))
+  (:report (lambda (c s) 
+	     (call-next-method)
+	     (apply 'format s 
+		    (simple-condition-format-control c)
+		    (simple-condition-format-arguments c)))))
+
+(define-condition simple-warning (simple-condition warning) ())
+(define-condition simple-error (simple-condition error) ())
+
+(define-condition storage-condition (serious-condition) ())
+(define-condition stack-overflow    (storage-condition) ())
+(define-condition storage-exhausted (storage-condition) ())
+
+(define-condition type-error (error)
+  ((datum :initarg :datum :reader type-error-datum)
+   (expected-type :initarg :expected-type :reader type-error-expected-type))
+  (:report ("~%~s is not of type ~s." datum expected-type)))
+
+(define-condition simple-type-error (simple-condition type-error) ())
+
+(define-condition case-failure (type-error)
+ ((name :initarg :name :reader case-failure-name)
+  (possibilities :initarg :possibilities
+		 :reader case-failure-possibilities))
+  (:report ("~%~s fell through ~s expression.~%wanted one of ~:s." datum name possibilities)))
+
+(define-condition PROGRAM-ERROR (ERROR) ())
+(define-condition control-error (error) ())
+(define-condition parse-error (error) ())
+
+(define-condition print-not-readable (error) 
+  ((object :initarg :object :reader print-not-readable-object))
+  (:report ("~%Object ~s is unreadable: " object)))
+
+(define-condition stream-error (error)
+  ((stream :initarg :stream :reader stream-error-stream))
+  (:report ("~%Stream error on stream ~s: " stream)))
+
+(define-condition reader-error (parse-error stream-error) ())
+
+(define-condition end-of-file (stream-error)
+  ()
+  (:report ("~%Unexpected end of file:")))
+
+(define-condition file-error (error)
+  ((pathname :initarg :pathname :reader file-error-pathname))
+  (:report ("~%File error on ~s:" pathname)))
+(define-condition pathname-error (file-error) ())
+
+(define-condition package-error (error)
+  ((package :initarg :package :reader package-error-package))
+  (:report ("~%Package error on ~s: " package)))
 	      
 
-(DEFINE-CONDITION CELL-ERROR (ERROR)
-  #-(or clos pcl)
-  (NAME)
-  #+(or clos pcl)
-  ((NAME :initarg :NAME
-	 :reader CELL-ERROR-NAME)))
+(define-condition cell-error (error)
+  ((name :initarg :name :reader cell-error-name))
+  (:report ("~%Cell error on ~s: " name)))
 
-(DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR)
+(define-condition unbound-variable (cell-error)
   ()
-  (:REPORT (LAMBDA (CONDITION STREAM)
-	     (FORMAT STREAM "The variable ~S is unbound."
-		     (CELL-ERROR-NAME CONDITION)))))
+  (:report ("~%Unbound variable.")))
   
-(DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR)
-  ()
-  (:REPORT (LAMBDA (CONDITION STREAM)
-	     (FORMAT STREAM "The function ~S is undefined."
-		     (CELL-ERROR-NAME CONDITION)))))
-
-(DEFINE-CONDITION ARITHMETIC-ERROR (ERROR)
-  #-(or clos pcl)
-  (OPERATION OPERANDS)
-  #+(or clos pcl)
-  ((OPERATION :initarg :OPERATION
-	      :reader ARITHMETIC-ERROR-OPERATION)))
-
-(DEFINE-CONDITION DIVISION-BY-ZERO         (ARITHMETIC-ERROR)
-  ())
-
-(DEFINE-CONDITION FLOATING-POINT-OVERFLOW  (ARITHMETIC-ERROR)
-  ())
-
-(DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR)
-  ())
-
-(DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) ()
-  (:REPORT "Abort failed."))
-
-#+kcl
-(progn
-(define-condition internal-error ( error)
-  #-(or clos pcl)
-  ((function-name nil))
-  #+(or clos pcl)
-  ((function-name :initarg :function-name
-		  :reader internal-error-function-name
-		  :initform 'nil))
+(define-condition unbound-slot (cell-error)
+  ((instance :initarg :instance :reader unbound-slot-instance))
+  (:report ("~%Slot is unbound in ~s: " instance)))
+
+(define-condition undefined-function (cell-error) nil
+  (:report ("~%Undefined function.")))
+
+(define-condition arithmetic-error (error)
+  ((operation :initarg :operation :reader arithmetic-error-operation)
+   (operands :initarg :operands :reader arithmetic-error-operands))
+  (:report ("~%Arithmetic error when performing ~s on ~s: " operation operands)))
+
+(define-condition division-by-zero (arithmetic-error) ())
+(define-condition floating-point-overflow (arithmetic-error) ())
+(define-condition floating-point-invalid-operation (arithmetic-error) ())
+(define-condition floating-point-inexact (arithmetic-error) ())
+(define-condition floating-point-underflow (arithmetic-error) ())
+
+(define-condition abort-failure (control-error) () (:report "~%Abort failed."))
+
+(define-condition internal-condition (condition)
+  ((function-name :initarg :function-name :reader internal-condition-function-name
+		  :initform nil))
   (:report (lambda (condition stream)
-	     (when (internal-error-function-name condition)
-	       (format stream "Error in ~S [or a callee]: "
-		       (internal-error-function-name condition)))
-	     #+(or clos pcl)(call-next-method))))
+	     (when (internal-condition-function-name condition)
+	       (format stream "Condition in ~S [or a callee]: "
+		       (internal-condition-function-name condition)))
+	     (call-next-method))))
 
-(defun internal-simple-error-printer (condition stream)
-  (when (internal-error-function-name condition)
-    (format stream "Error in ~S [or a callee]: "
-	    (internal-error-function-name condition)))
-  (apply #'format stream (simple-condition-format-string    condition)
-	 		 (simple-condition-format-arguments condition)))
-
-(define-condition internal-simple-error 
-    (internal-error #+(or clos pcl) simple-condition)
-  #-(or clos pcl)
-  ((function-name nil) format-string (format-arguments '()))
-  #+(or clos pcl)
+(define-condition internal-warning (internal-condition warning)
   ()
-  #-(or clos pcl)(:conc-name %%internal-simple-error-)
-  (:report internal-simple-error-printer))
+  (:report (lambda (condition stream)
+	     (when (internal-condition-function-name condition)
+	       (format stream "Warning in ~S [or a callee]: "
+		       (internal-condition-function-name condition)))
+	     (call-next-method))))
 
-(define-condition internal-type-error 
-    (#+(or clos pcl) internal-error type-error)
-  #-(or clos pcl)
-  ((function-name nil))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:conc-name %%internal-type-error-)
-  #-(or clos pcl)(:report (lambda (condition stream)
-			    (when (internal-error-function-name condition)
-			      (format stream "Error in ~S [or a callee]: "
-				      (internal-error-function-name condition)))
-			    (format stream "~S is not of type ~S."
-				    (type-error-datum condition)
-				    (type-error-expected-type condition)))))
-
-(define-condition internal-package-error 
-   (#+(or clos pcl) internal-error package-error)
- #-(or clos pcl)
- ((function-name nil))
- #+(or clos pcl)
- ()
- #-(or clos pcl)(:conc-name %%internal-package-error-)
- #-(or clos pcl)(:report (lambda (condition stream)
-			    (when (internal-error-function-name condition)
-			      (format stream "Error in ~S [or a callee]: "
-				      (internal-error-function-name condition)))
-			    (format stream "A package error occurred on ~S: ~S."
-				    (package-error-package condition)
-				    (package-error-message condition)))))
-
-(define-condition internal-simple-program-error 
-    (#+(or clos pcl) internal-simple-error program-error)
-  #-(or clos pcl)
-  ((function-name nil) format-string (format-arguments '()))
-  #+(or clos pcl)
+(define-condition internal-error (internal-condition error)
   ()
-  #-(or clos pcl)(:conc-name %%internal-simple-program-error-)
-  #-(or clos pcl)(:report internal-simple-error-printer))
+  (:report (lambda (condition stream)
+	     (when (internal-condition-function-name condition)
+	       (format stream "Error in ~S [or a callee]: "
+		       (internal-condition-function-name condition)))
+	     (call-next-method))))
 
-(define-condition internal-simple-control-error 
-    (#+(or clos pcl) internal-simple-error control-error)
-  #-(or clos pcl)
-  ((function-name nil) format-string (format-arguments '()))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:conc-name %%internal-simple-control-error-)
-  #-(or clos pcl)(:report internal-simple-error-printer))
+(define-condition internal-simple-condition (internal-condition simple-condition) ())
+(define-condition internal-simple-error (internal-error simple-error) ())
+(define-condition internal-simple-warning (internal-warning simple-warning) ())
+
+(defun symcat (x y) (values (intern (concatenate 'string (string x) (string y)) 'conditions)))
+
+#.`(progn 
+     ,@(mapcar (lambda (x) 
+		 `(define-condition ,(symcat "INTERNAL-SIMPLE-" x)  (internal-simple-condition ,x) ())) 
+	       `(stack-overflow storage-exhausted print-not-readable end-of-file style-warning type-error
+				unbound-variable unbound-slot undefined-function division-by-zero
+				case-failure abort-failure
+				,@(mapcar (lambda (x) (symcat "FLOATING-POINT-" x)) 
+					  '(overflow underflow invalid-operation inexact))
+				,@(mapcar (lambda (x) (symcat x "-ERROR"))
+					  '(program control parse stream reader file
+						    package cell arithmetic pathname)))))
 
-(define-condition internal-unbound-variable 
-    (#+(or clos pcl) internal-error unbound-variable)
-  #-(or clos pcl)
-  ((function-name nil))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:conc-name %%internal-unbound-variable-)
-  #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
-			    (when (internal-error-function-name condition)
-			      (format stream "Error in ~S [or a callee]: "
-				      (internal-error-function-name condition)))
-			    (FORMAT STREAM "The variable ~S is unbound."
-				    (CELL-ERROR-NAME CONDITION)))))
-
-(define-condition internal-undefined-function 
-    (#+(or clos pcl) internal-error undefined-function)
-  #-(or clos pcl)
-  ((function-name nil))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:conc-name %%internal-undefined-function-)
-  #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
-			    (when (internal-error-function-name condition)
-			      (format stream "Error in ~S [or a callee]: "
-				      (internal-error-function-name condition)))
-			    (FORMAT STREAM "The function ~S is undefined."
-				    (CELL-ERROR-NAME CONDITION)))))
-
-(define-condition internal-end-of-file 
-    (#+(or clos pcl) internal-error end-of-file)
-  #-(or clos pcl)
-  ((function-name nil))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:conc-name %%internal-end-of-file-)
-  #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
-			    (when (internal-error-function-name condition)
-			      (format stream "Error in ~S [or a callee]: "
-				      (internal-error-function-name condition)))
-			    (FORMAT STREAM "Unexpected end of file on ~S."
-				    (STREAM-ERROR-STREAM CONDITION)))))
-
-(define-condition internal-simple-file-error
-    (#+(or clos pcl) internal-simple-error file-error)
-  #-(or clos pcl)
-  ((function-name nil) format-string (format-arguments '()))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:conc-name %%internal-simple-file-error-)
-  #-(or clos pcl)(:report internal-simple-error-printer))
 
-(define-condition internal-simple-stream-error 
-    (#+(or clos pcl) internal-simple-error stream-error)
-  #-(or clos pcl)
-  ((function-name nil) format-string (format-arguments '()))
-  #+(or clos pcl)
-  ()
-  #-(or clos pcl)(:conc-name %%internal-simple-stream-error-)
-  #-(or clos pcl)(:report internal-simple-error-printer))
 
-#-(or pcl clos)
-(defun internal-error-function-name (condition)
-  (etypecase condition
-    (internal-error                
-     (%%internal-error-function-name condition))
-    (internal-simple-error         
-     (%%internal-simple-error-function-name condition))
-    (internal-type-error 
-     (%%internal-type-error-function-name condition))
-    (internal-simple-program-error
-     (%%internal-simple-program-error-function-name condition))
-    (internal-simple-control-error
-     (%%internal-simple-control-error-function-name condition))
-    (internal-unbound-variable  
-     (%%internal-unbound-variable-function-name condition))
-    (internal-undefined-function 
-     (%%internal-undefined-function-function-name condition))
-    (internal-end-of-file        
-     (%%internal-end-of-file-function-name condition))
-    (internal-simple-file-error  
-     (%%internal-simple-file-error-function-name condition))
-    (internal-simple-stream-error 
-     (%%internal-simple-stream-error-function-name condition))))
-)
-
-#-(or clos pcl)
-(progn
-
-(DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION)
-  (ETYPECASE CONDITION
-    (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-STRING  CONDITION))
-    (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-STRING    CONDITION))
-    (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION))
-    (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-STRING      CONDITION))
-    #+kcl(internal-simple-error
-	  (%%internal-simple-error-format-string condition))
-    #+kcl(internal-simple-program-error
-	  (%%internal-simple-program-error-format-string condition))
-    #+kcl(internal-simple-control-error
-	  (%%internal-simple-control-error-format-string condition))
-    #+kcl(internal-simple-file-error
-	  (%%internal-simple-file-error-format-string condition))
-    #+kcl(internal-simple-stream-error
-	  (%%internal-simple-stream-error-format-string condition))))
-
-(DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION)
-  (ETYPECASE CONDITION
-    (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS  CONDITION))
-    (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-ARGUMENTS    CONDITION))
-    (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION))
-    (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-ARGUMENTS      CONDITION))
-    #+kcl(internal-simple-error
-	  (%%internal-simple-error-format-arguments condition))
-    #+kcl(internal-simple-program-error
-	  (%%internal-simple-program-error-format-arguments condition))
-    #+kcl(internal-simple-control-error
-	  (%%internal-simple-control-error-format-arguments condition))
-    #+kcl(internal-simple-file-error
-	  (%%internal-simple-file-error-format-arguments condition))
-    #+kcl(internal-simple-stream-error
-	  (%%internal-simple-stream-error-format-arguments condition))))
+(defvar *simple-condition-class* (find-class 'simple-condition))
+(defvar *internal-simple-condition-class* (find-class 'internal-simple-condition))
 
 (defun simple-condition-class-p (type)
-  (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR
-		 #+kcl internal-simple-error
-		 #+kcl internal-simple-program-error
-		 #+kcl internal-simple-control-error
-		 #+kcl internal-simple-file-error
-		 #+kcl internal-simple-stream-error)))
-)
-
-#+(or clos pcl)
-(progn
-(defvar *simple-condition-class* (find-class 'simple-condition))
+  (let ((type (if (symbolp type) (find-class type nil) type)))
+    (when (typep type 'standard-class)
+      (member *simple-condition-class* 
+	      (pcl::class-precedence-list type)))))
+
+(defun internal-simple-condition-class-p (type)
+  (when (symbolp type)
+    (setq type (find-class type)))
+  (and (typep type 'standard-class)
+       (member *internal-simple-condition-class* 
+	       (pcl::class-precedence-list type))))
 
-(defun simple-condition-class-p (TYPE)
-  (when (symbolp TYPE)
-    (setq TYPE (find-class TYPE)))
-  (and (typep TYPE 'standard-class)
-       (member *simple-condition-class* 
-	       (#+pcl pcl::class-precedence-list
-		#-pcl clos::class-precedence-list
-		  type))))
-)
 
--- gcl-2.6.10.orig/clcs/gcl_clcs_conditions.lisp
+++ gcl-2.6.10/clcs/gcl_clcs_conditions.lisp
@@ -1,175 +1,49 @@
 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
 
-(in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL"))
+(in-package "CONDITIONS" :USE '("LISP" "PCL"))
 
-#+kcl
 (eval-when (compile load eval)
-(when (fboundp 'remove-clcs-symbols)
-  (remove-clcs-symbols))
-)
-
-;DEFINE-CONDITION
-;MAKE-CONDITION
-;condition printing
-;(define-condition CONDITION ...)
-;CONDITIONP
-;CONDITION-CLASS-P
-;SIMPLE-CONDITION-P
-;SIMPLE-CONDITION-CLASS-P
-
-#-(or clos pcl)
-(progn
-(DEFUN CONDITION-PRINT (CONDITION STREAM DEPTH)
-  DEPTH ;ignored
-  (COND (*PRINT-ESCAPE*
-         (FORMAT STREAM "#<~S.~D>" (TYPE-OF CONDITION) (UNIQUE-ID CONDITION)))
-        (T
-         (CONDITION-REPORT CONDITION STREAM))))
-
-(DEFSTRUCT (CONDITION :CONC-NAME
-                      (:CONSTRUCTOR |Constructor for CONDITION|)
-                      (:PREDICATE NIL)
-                      (:PRINT-FUNCTION CONDITION-PRINT))
-  (-DUMMY-SLOT- NIL))
-
-(EVAL-WHEN (EVAL COMPILE LOAD)
-
-(DEFMACRO PARENT-TYPE     (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'PARENT-TYPE))
-(DEFMACRO SLOTS           (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'SLOTS))
-(DEFMACRO CONC-NAME       (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'CONC-NAME))
-(DEFMACRO REPORT-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'REPORT-FUNCTION))
-(DEFMACRO MAKE-FUNCTION   (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'MAKE-FUNCTION))
-
-);NEHW-LAVE
-
-(DEFUN CONDITION-REPORT (CONDITION STREAM)
-  (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE)))
-      ((NOT TYPE) (FORMAT STREAM "The condition ~A occurred." (TYPE-OF CONDITION)))
-    (LET ((REPORTER (REPORT-FUNCTION TYPE)))
-      (WHEN REPORTER
-        (FUNCALL REPORTER CONDITION STREAM)
-        (RETURN NIL)))))
-
-(SETF (MAKE-FUNCTION   'CONDITION) '|Constructor for CONDITION|)
-
-(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)
-  (LET ((FN (MAKE-FUNCTION TYPE)))
-    (COND ((NOT FN) (ERROR 'SIMPLE-TYPE-ERROR
-			   :DATUM TYPE
-			   :EXPECTED-TYPE '(SATISFIES MAKE-FUNCTION)
-			   :FORMAT-STRING "Not a condition type: ~S"
-			   :FORMAT-ARGUMENTS (LIST TYPE)))
-          (T (APPLY FN SLOT-INITIALIZATIONS)))))
-
-(EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time
-
-(DEFUN PARSE-NEW-AND-USED-SLOTS (SLOTS PARENT-TYPE)
-  (LET ((NEW '()) (USED '()))
-    (DOLIST (SLOT SLOTS)
-      (IF (SLOT-USED-P (CAR SLOT) PARENT-TYPE)
-          (PUSH SLOT USED)
-          (PUSH SLOT NEW)))
-    (VALUES NEW USED)))
-
-(DEFUN SLOT-USED-P (SLOT-NAME TYPE)
-  (COND ((EQ TYPE 'CONDITION) NIL)
-        ((NOT TYPE) (ERROR "The type ~S does not inherit from CONDITION." TYPE))
-        ((ASSOC SLOT-NAME (SLOTS TYPE)))
-        (T
-         (SLOT-USED-P SLOT-NAME (PARENT-TYPE TYPE)))))
-
-);NEHW-LAVE
-
-(DEFMACRO DEFINE-CONDITION (NAME (PARENT-TYPE) SLOT-SPECS &REST OPTIONS)
-  (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*)) ;Bind for the INTERN -and- the FORMAT
-                       (INTERN (FORMAT NIL "Constructor for ~S" NAME)))))
-    (LET ((SLOTS (MAPCAR #'(LAMBDA (SLOT-SPEC)
-			     (IF (ATOM SLOT-SPEC) (LIST SLOT-SPEC) SLOT-SPEC))
-			 SLOT-SPECS)))
-      (MULTIPLE-VALUE-BIND (NEW-SLOTS USED-SLOTS)
-          (PARSE-NEW-AND-USED-SLOTS SLOTS PARENT-TYPE)
-	(LET ((CONC-NAME-P     NIL)
-	      (CONC-NAME       NIL)
-	      (REPORT-FUNCTION NIL)
-	      (DOCUMENTATION   NIL))
-	  (DO ((O OPTIONS (CDR O)))
-	      ((NULL O))
-	    (LET ((OPTION (CAR O)))
-	      (CASE (CAR OPTION) ;Should be ECASE
-		(:CONC-NAME (SETQ CONC-NAME-P T)
-		 	    (SETQ CONC-NAME (CADR OPTION)))
-		(:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION))
-						   `(LAMBDA (CONDITION STREAM)
-						      (DECLARE (IGNORE CONDITION))
-						      (WRITE-STRING ,(CADR OPTION) STREAM))
-						   (CADR OPTION))))
-		(:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION)))
-		(OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option."
-				   "Invalid DEFINE-CONDITION option: ~S" OPTION)))))
-	  (IF (NOT CONC-NAME-P) (SETQ CONC-NAME (INTERN (FORMAT NIL "~A-" NAME) *PACKAGE*)))
-          ;; The following three forms are compile-time side-effects. For now, they affect
-          ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, 
-          ;; and CONC-NAME, the compiler could easily make them local.
-          (SETF (PARENT-TYPE NAME) PARENT-TYPE)
-          (SETF (SLOTS NAME)       SLOTS)
-          (SETF (CONC-NAME NAME)   CONC-NAME)
-          ;; Finally, the expansion ...
-          `(PROGN (DEFSTRUCT (,NAME
-                              (:CONSTRUCTOR ,CONSTRUCTOR)
-                              (:PREDICATE NIL)
-			      (:COPIER NIL)
-                              (:PRINT-FUNCTION CONDITION-PRINT)
-                              (:INCLUDE ,PARENT-TYPE ,@USED-SLOTS)
-                              (:CONC-NAME ,CONC-NAME))
-                    ,@NEW-SLOTS)
-		  (SETF (DOCUMENTATION ',NAME 'TYPE) ',DOCUMENTATION)
-                  (SETF (PARENT-TYPE ',NAME) ',PARENT-TYPE)
-                  (SETF (SLOTS ',NAME) ',SLOTS)
-                  (SETF (CONC-NAME ',NAME) ',CONC-NAME)
-                  (SETF (REPORT-FUNCTION ',NAME) ,(IF REPORT-FUNCTION `#',REPORT-FUNCTION))
-                  (SETF (MAKE-FUNCTION ',NAME) ',CONSTRUCTOR)
-                  ',NAME))))))
-
-(defun conditionp (object)
-  (typep object 'condition))
-
-(defun condition-class-p (object)
-  (and (symbolp object)
-       (MAKE-FUNCTION object)))
-
-)
-
+  (when (fboundp 'remove-clcs-symbols)
+    (remove-clcs-symbols)))
 
+(eval-when (compile load eval)
+  (defvar *condition-class-list* nil))
 
-#+(or clos pcl)
-(progn
+(defun slot-sym (base slot)
+  (values (intern (concatenate 'string (string base) "-" (string slot)))))
 
-(eval-when (compile load eval)
-(defvar *condition-class-list* nil) ; list of (class-name initarg1 type1...)
-)
+(defun coerce-to-fn (x y)
+  (cond ((stringp x) `(lambda (c s) (declare (ignore c)) (write-string ,x s)))
+	((symbolp x) x)
+	((atom x) nil)
+	((eq (car x) 'lambda) x)
+	((stringp (car x))
+	 `(lambda (c s) 
+	    (declare (ignorable c))
+	    (call-next-method)
+	    (format s ,(car x) ,@(mapcar (lambda (st) `(if (slot-boundp c ',st) (,(slot-sym y st) c) 'unbound)) (cdr x)))))))
 
 (DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS)
   (unless (or parent-list (eq name 'condition))
 	  (setq parent-list (list 'condition)))
   (let* ((REPORT-FUNCTION nil)
+	 (DEFAULT-INITARGS nil)
 	 (DOCUMENTATION nil))
     (DO ((O OPTIONS (CDR O)))
 	((NULL O))
       (LET ((OPTION (CAR O)))
 	(CASE (CAR OPTION)
-	  (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION))
-					     `(LAMBDA (CONDITION STREAM)
-					        (DECLARE (IGNORE CONDITION))
-					        (WRITE-STRING ,(CADR OPTION) STREAM))
-					     (CADR OPTION))))
+	  (:REPORT (SETQ REPORT-FUNCTION (coerce-to-fn (cadr option) name)))
+	  (:DEFAULT-INITARGS (SETQ DEFAULT-INITARGS OPTION))
 	  (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION)))
 	  (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option."
 			     "Invalid DEFINE-CONDITION option: ~S" OPTION)))))
     `(progn
        (eval-when (compile)
-	 #+pcl (setq pcl::*defclass-times* '(compile load eval)))
-       (defclass ,name ,parent-list
-	 ,slot-specs)
+	 (setq pcl::*defclass-times* '(compile load eval)))
+       ,(if default-initargs
+       `(defclass ,name ,parent-list ,slot-specs ,default-initargs)
+       `(defclass ,name ,parent-list ,slot-specs))
        (eval-when (compile load eval)
 	 (pushnew '(,name ,parent-list
 		    ,@(mapcan #'(lambda (slot-spec)
@@ -181,7 +55,7 @@
 						 t))))))
 		       SLOT-SPECS))
 		  *condition-class-list*)
-	 #+kcl (setf (get ',name #+akcl 'si::s-data #-akcl 'si::is-a-structure) nil)
+	 (setf (get ',name 'si::s-data) nil)
 ;	 (setf (get ',name 'documentation) ',documentation)
 	 )
       ,@(when REPORT-FUNCTION
@@ -192,15 +66,12 @@
       ',NAME)))
 
 (eval-when (compile load eval)
-(define-condition condition ()
-  ())
+  (define-condition condition () ())
 
-#+pcl
 (when (fboundp 'pcl::proclaim-incompatible-superclasses)
   (mapc
-   #'pcl::proclaim-incompatible-superclasses
-   '((condition pcl::metaobject))))
-)
+   'pcl::proclaim-incompatible-superclasses
+   '((condition pcl::metaobject)))))
 
 (defun conditionp (object)
   (typep object 'condition))
@@ -208,7 +79,7 @@
 (DEFMETHOD PRINT-OBJECT ((X condition) STREAM)
   (IF *PRINT-ESCAPE* 
       (FORMAT STREAM "#<~S.~D>" (class-name (class-of x)) (UNIQUE-ID x))
-      (FORMAT STREAM "The condition ~A occurred." (TYPE-OF x))))
+      (FORMAT STREAM "~A: " (class-name (class-of x)))));(TYPE-OF x)
 
 (defvar *condition-class* (find-class 'condition))
 
@@ -226,8 +97,8 @@
     (ERROR 'SIMPLE-TYPE-ERROR
 	   :DATUM TYPE
 	   :EXPECTED-TYPE '(SATISFIES condition-class-p)
-	   :FORMAT-STRING "Not a condition type: ~S"
+	   :FORMAT-CONTROL "Not a condition type: ~S"
 	   :FORMAT-ARGUMENTS (LIST TYPE)))
   (apply #'make-instance TYPE SLOT-INITIALIZATIONS))
 
-)
+
--- gcl-2.6.10.orig/clcs/gcl_clcs_handler.lisp
+++ gcl-2.6.10/clcs/gcl_clcs_handler.lisp
@@ -35,28 +35,31 @@
 ;;;  by all the other routines.
 
 (DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME)
-  #+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS))
   (COND ((CONDITIONP DATUM)
 	 (IF ARGUMENTS
 	     (CERROR "Ignore the additional arguments."
 		     'SIMPLE-TYPE-ERROR
 		     :DATUM ARGUMENTS
 		     :EXPECTED-TYPE 'NULL
-		     :FORMAT-STRING "You may not supply additional arguments ~
+		     :FORMAT-CONTROL "You may not supply additional arguments ~
 				     when giving ~S to ~S."
 		     :FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME)))
 	 DATUM)
         ((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM))
-         (APPLY #'MAKE-CONDITION DATUM ARGUMENTS))	 
+	 (let* ((n (if (symbolp datum) datum (class-name datum)))
+		(c (find-class (symcat (if (simple-condition-class-p n) "INTERNAL-" "INTERNAL-SIMPLE-") n) nil)))
+	   (if c
+	       (apply 'make-condition (class-name c) (append arguments (list :function-name (si::ihs-fname si::*ihs-top*))));FIXME
+	     (apply #'make-condition datum arguments))))
         ((STRINGP DATUM)
 	 (MAKE-CONDITION DEFAULT-TYPE
-                         :FORMAT-STRING DATUM
+                         :FORMAT-CONTROL DATUM
                          :FORMAT-ARGUMENTS ARGUMENTS))
         (T
          (ERROR 'SIMPLE-TYPE-ERROR
 		:DATUM DATUM
 		:EXPECTED-TYPE '(OR SYMBOL STRING)
-		:FORMAT-STRING "Bad argument to ~S: ~S"
+		:FORMAT-CONTROL "Bad argument to ~S: ~S"
 		:FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM)))))
 
 (DEFUN ERROR (DATUM &REST ARGUMENTS)
@@ -69,11 +72,11 @@
     (APPLY #'ERROR DATUM ARGUMENTS))
   NIL)
 
-(DEFUN BREAK (&OPTIONAL (FORMAT-STRING "Break") &REST FORMAT-ARGUMENTS)
+(DEFUN BREAK (&OPTIONAL (FORMAT-CONTROL "Break") &REST FORMAT-ARGUMENTS)
   (WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.")
     (INVOKE-DEBUGGER
       (MAKE-CONDITION 'SIMPLE-CONDITION
-		      :FORMAT-STRING    FORMAT-STRING
+		      :FORMAT-CONTROL   FORMAT-CONTROL
 		      :FORMAT-ARGUMENTS FORMAT-ARGUMENTS)))
   NIL)
 
--- gcl-2.6.10.orig/clcs/gcl_clcs_kcl_cond.lisp
+++ gcl-2.6.10/clcs/gcl_clcs_kcl_cond.lisp
@@ -36,28 +36,28 @@
 (defvar *internal-error-parms* nil)
 
 (defun clcs-universal-error-handler (error-name correctable function-name
-			             continue-format-string error-format-string
+			             continue-format-control error-format-string
 			             &rest args
 				     &aux (internal-error-parms
 					   (list error-name correctable function-name
-						 continue-format-string error-format-string)))
+						 continue-format-control error-format-string)))
   (when (equal internal-error-parms *internal-error-parms*)
     (format t "Universal error handler called recursively ~S~%"
 	    internal-error-parms)
 	    (return-from clcs-universal-error-handler))
   (let* ((*internal-error-parms* (list error-name correctable function-name
-				       continue-format-string error-format-string))
+				       continue-format-control error-format-string))
 	 (e-d (find-internal-error-data error-name)))
     (if e-d
 	(let ((condition-name (car e-d)))
 	  (if correctable
 	      (with-simple-restart 
-	       (continue "~a" (apply #'format nil continue-format-string args))
+	       (continue "~a" (apply #'format nil continue-format-control args))
 	       (apply #'error condition-name
 		   :function-name function-name
 		      (let ((k-a (mapcan #'list (cdr e-d) args)))
 			(if (simple-condition-class-p condition-name)
-			    (list* :format-string error-format-string
+			    (list* :format-control error-format-string
 				   :format-arguments args
 				   k-a)
 			  k-a))))
@@ -65,12 +65,12 @@
 		   :function-name function-name
 		   (let ((k-a (mapcan #'list (cdr e-d) args)))
 		     (if (simple-condition-class-p condition-name)
-			 (list* :format-string error-format-string
+			 (list* :format-control error-format-string
 				:format-arguments args
 				k-a)
 		       k-a)))))
       (error 'internal-simple-error :function-name function-name
-	     :format-string error-format-string :format-arguments args))))
+	     :format-control error-format-string :format-arguments args))))
 
 (defun set-internal-error (error-keyword error-format condition-name
 					 &rest keyword-list)
@@ -87,9 +87,9 @@
 
 (defparameter *internal-error-list*
   '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S."
-     internal-type-error :datum :expected-type)
+     internal-simple-type-error :datum :expected-type)
     ("FEpackage_error" :package-error "A package error occurred on ~S: ~S."
-     internal-package-error :package :message) ; |<function>| |top - base|
+     internal-simple-package-error :package :message) ; |<function>| |top - base|
     ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." 
      internal-simple-program-error) ; |<function>| |top - base|
 ;    ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments."
@@ -103,13 +103,13 @@
     ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S."
      internal-simple-program-error) ; |<function>| |key|
     ("FEunbound_variable" :unbound-variable "The variable ~S is unbound."
-     internal-unbound-variable :name) ; |sym|
+     internal-simple-unbound-variable :name) ; |sym|
     ("FEundefined_function" :undefined-function "The function ~S is undefined."
-     internal-undefined-function :name)
+     internal-simple-undefined-function :name)
     ("FEinvalid_function" :invalid-function "~S is invalid as a function."
-     internal-undefined-function :name) ; |obj|
+     internal-simple-undefined-function :name) ; |obj|
     ("FEinvalid_variable" :invalid-variable "~S is an invalid variable."
-     internal-program-error) ; |obj|
+     internal-simple-program-error) ; |obj|
     ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\
 but only ~R ~:*~[were~;was~:;were~] supplied."
      internal-simple-program-error) ; |<function>| |n| |top - base|
@@ -135,7 +135,7 @@ but only ~R ~:*~[were~;was~:;were~] supp
     ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args"
      internal-simple-control-error)
     ("end_of_stream" :error "Unexpected end of ~S."
-     internal-end-of-file :stream)
+     internal-simple-end-of-file :stream)
     ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option."
      internal-simple-control-error)
     ("open_stream" :error "The file ~A already exists."
--- gcl-2.6.10.orig/clcs/gcl_clcs_macros.lisp
+++ gcl-2.6.10/clcs/gcl_clcs_macros.lisp
@@ -134,8 +134,8 @@
 (DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION)
   (ERROR 'SIMPLE-TYPE-ERROR
 	 :DATUM ASSERTION
-	 :EXPECTED-TYPE NIL			; This needs some work in next revision. -kmp
-	 :FORMAT-STRING "The assertion ~S failed."
+	 :EXPECTED-TYPE '(NOT NULL)
+	 :FORMAT-CONTROL "~%The assertion ~S failed."
 	 :FORMAT-ARGUMENTS (LIST ASSERTION)))
 
 (DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS)
--- gcl-2.6.10.orig/clcs/gcl_clcs_restart.lisp
+++ gcl-2.6.10/clcs/gcl_clcs_restart.lisp
@@ -195,13 +195,13 @@
 					     ,TEMP-VAR)))))
 		       DATA)))))))
 
-(DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-STRING
+(DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-CONTROL
 					     &REST FORMAT-ARGUMENTS)
 			       &BODY FORMS)
   `(RESTART-CASE (PROGN ,@FORMS)
      (,RESTART-NAME ()
         :REPORT (LAMBDA (STREAM)
-		  (FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS))
+		  (FORMAT STREAM ,FORMAT-CONTROL ,@FORMAT-ARGUMENTS))
       (VALUES NIL T))))
 
 (DEFUN ABORT          ()      (INVOKE-RESTART 'ABORT)
--- gcl-2.6.10.orig/clcs/package.lisp
+++ gcl-2.6.10/clcs/package.lisp
@@ -32,7 +32,7 @@
 	  INVOKE-RESTART-INTERACTIVELY ABORT CONTINUE MUFFLE-WARNING
 	  STORE-VALUE USE-VALUE INVOKE-DEBUGGER RESTART CONDITION
 	  WARNING SERIOUS-CONDITION SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-ERROR
-	  SIMPLE-CONDITION-FORMAT-STRING SIMPLE-CONDITION-FORMAT-ARGUMENTS
+	  SIMPLE-CONDITION-FORMAT-CONTROL SIMPLE-CONDITION-FORMAT-ARGUMENTS
 	  STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED TYPE-ERROR
 	  TYPE-ERROR-DATUM TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR
 	  PROGRAM-ERROR CONTROL-ERROR STREAM-ERROR STREAM-ERROR-STREAM
--- gcl-2.6.10.orig/cmpnew/gcl_cmpcatch.lsp
+++ gcl-2.6.10/cmpnew/gcl_cmpcatch.lsp
@@ -89,9 +89,9 @@
   (wt-nl "vs_base=vs_top=base+" *vs* ";")
   (base-used)
   (wt-nl "for(p= " loc ";!endp(p);p=MMcdr(p))vs_push(MMcar(p));")
-  (wt-nl "if(active)unwind(fr,tag);else{")
+  (wt-nl "if(active)unwind(fr,tag);")
   (unwind-exit 'fun-val nil (if top-data (car top-data)))
-  (wt "}}")
+  (wt "}")
   )
 
 (defun c1throw (args &aux (info (make-info)) tag)
--- gcl-2.6.10.orig/cmpnew/gcl_cmpeval.lsp
+++ gcl-2.6.10/cmpnew/gcl_cmpeval.lsp
@@ -602,7 +602,7 @@
   (cond
    ((eq val nil) (c1nil))
    ((eq val t) (c1t))
-   ((si:fixnump val)
+   ((when (si:fixnump val) (< most-negative-fixnum val))
     (list 'LOCATION (make-info :type 'fixnum)
           (list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val))
 		val)))
--- gcl-2.6.10.orig/cmpnew/gcl_cmpmain.lsp
+++ gcl-2.6.10/cmpnew/gcl_cmpmain.lsp
@@ -163,7 +163,6 @@
                            (h-file *default-h-file*)
                            (data-file *default-data-file*)
 			   (c-debug nil)
-                           #+aosvs (ob-file nil)
                            (system-p *default-system-p*)
 			   (print nil)
                            (load nil)
@@ -174,15 +173,11 @@
 			   (*compile-print* (or print *compile-print*))
                            (*package* *package*)
 			   (*DEFAULT-PATHNAME-DEFAULTS* #"")
-			   (*data* (list (make-array 50 :fill-pointer 0
-						     :adjustable t
-						     )
-					 nil ;inits
-					 nil
-					 ))
+			   (*data* (list (make-array 50 :fill-pointer 0 :adjustable t) nil nil))
 			   *init-name* 	
 			   (*fasd-data* *fasd-data*)
                            (*error-count* 0))
+
   (declare (special *c-debug* *init-name* system-p))
 
   (cond (*compiler-in-use*
@@ -201,37 +196,29 @@ Cannot compile ~a.~%"
     (return-from compile-file1 (values)))
 
   (when *compile-verbose*
-    (format t "~&Compiling ~a.~%"
-            (namestring (merge-pathnames input-pathname #".lsp"))))
+    (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #".lsp"))))
 
   (and *record-call-info* (clear-call-table))
 
   (with-open-file
-          (*compiler-input* (merge-pathnames input-pathname #".lsp"))
-
-
-    (cond ((numberp *split-files*)
-	   (if (< (file-length *compiler-input*) *split-files*)
-	       (setq *split-files* nil)
-	     ;;*split-files* = ( section-length split-file-names next-section-start-file-position
-	     ;;                           package-ops)
-	     (setq *split-files* (list *split-files* nil 0 nil)))))
-
-    (cond ((consp *split-files*)
-	   (file-position *compiler-input* (third *split-files*))
-	   (setq output-file
-		 (make-pathname :directory (pathname-directory output-file)
-				:name (format nil "~a~a"
-					      (length (second *split-files*))
-					      (pathname-name (pathname output-file)))
-				:type "o"))
-	   
-	   (push (pathname-name output-file)   (second *split-files*))
-	   ))
+   (*compiler-input* (merge-pathnames input-pathname #".lsp"))
+   
+   
+   (cond ((numberp *split-files*)
+	  (if (< (file-length *compiler-input*) *split-files*)
+	      (setq *split-files* nil)
+	    (setq *split-files* (list *split-files* nil 0 nil)))))
+   
+   (cond ((consp *split-files*)
+	  (file-position *compiler-input* (third *split-files*))
+	  (setq output-file
+		(make-pathname :directory (pathname-directory output-file)
+			       :name (format nil "~a~a" (length (second *split-files*)) (pathname-name (pathname output-file)))
+			       :type "o"))
+	  
+	  (push (pathname-name output-file)   (second *split-files*))))
 	   
     
-	 
-    
   (let* ((eof (cons nil nil))
          (dir (or (and (not (null output-file))
                        (pathname-directory output-file))
@@ -240,20 +227,18 @@ Cannot compile ~a.~%"
                         (pathname-name output-file))
                    (pathname-name input-pathname)))
 	 (device (or (and (not (null output-file))
-                        (pathname-device output-file))
-                   (pathname-device input-pathname)))
-
+			  (pathname-device output-file))
+		     (pathname-device input-pathname)))
+	 
          (o-pathname (get-output-pathname o-file "o" name dir device))
          (c-pathname (get-output-pathname c-file "c" name dir device))
          (h-pathname (get-output-pathname h-file "h" name dir device))
-         (data-pathname (get-output-pathname data-file "data" name dir device))
-;	 (i-pathname  (get-output-pathname data-file "i" name dir))
-         #+aosvs (ob-pathname (get-output-pathname ob-file "ob" name dir device))
-         )
-    (declare (special dir name ))
+         (data-pathname (get-output-pathname data-file "data" name dir device)))
 
+    (declare (special dir name ))
+    
     (init-env)
-
+    
     (and (boundp 'si::*gcl-version*)
 	 (not system-p)
 	 (add-init `(si::warn-version ,si::*gcl-major-version*
@@ -261,20 +246,12 @@ Cannot compile ~a.~%"
 				      ,si::*gcl-extra-version*)))
 
     (when (probe-file "./gcl_cmpinit.lsp")
-      (load  "./gcl_cmpinit.lsp"
-            :verbose *compile-verbose*))
+      (load "./gcl_cmpinit.lsp" :verbose *compile-verbose*))
+
+    (with-open-file (*compiler-output-data* data-pathname :direction :output)
 
-    (with-open-file (*compiler-output-data*
-                      data-pathname
-                     :direction :output)
-    (progn 
-      (setq *fasd-data*      		      
-	    (cond  ((if system-p (eq *fasd-data* :system-p)
-		      *fasd-data*)
-		    (list
-		     (si::open-fasd *compiler-output-data* :output nil nil)
-		     ;(si::open-fasd *compiler-output-i* :output nil nil)
-		     ))))
+      (when *fasd-data*
+	(setq *fasd-data* (list (si::open-fasd *compiler-output-data* :output nil nil))))
 
       (wt-data-begin)
 
@@ -287,8 +264,7 @@ Cannot compile ~a.~%"
 			  (get-dispatch-macro-character #\# #\, rtb))))
 	  (if (and prev (eq prev (get-dispatch-macro-character
 				  #\# #\, (si:standard-readtable))))
-	      (set-dispatch-macro-character #\# #\,
-					    'si:sharp-comma-reader-for-compiler rtb)
+	      (set-dispatch-macro-character #\# #\, 'si:sharp-comma-reader-for-compiler rtb)
 	    (setq prev nil))
 	  
 	  ;; t1expr the package ops again..
@@ -308,60 +284,22 @@ Cannot compile ~a.~%"
 		   ((and *split-files* (check-end form eof))
 		    (setf (fourth *split-files*) (reverse (third *data*)))
 		    (return nil))
-		   ((eq form eof) (return nil)))
-		  )
+		   ((eq form eof) (return nil))))
 	    
-	    
-            (when prev (set-dispatch-macro-character #\# #\, prev rtb))))))
+            (when prev (set-dispatch-macro-character #\# #\, prev rtb)))))
       
       (setq *init-name* (init-name input-pathname system-p))
-;    (let ((x (merge-pathnames #".o" o-pathname)))
-;      (with-open-file (s x :if-does-not-exist :create)
-;		      (setq *init-name* (init-name x system-p)))
-;      (mdelete-file x))
 
       (when (zerop *error-count*)
         (when *compile-verbose* (format t "~&End of Pass 1.  ~%"))
         (compiler-pass2 c-pathname h-pathname system-p ))
-	
-
-      (wt-data-end)
 
-      ) ;;; *compiler-output-data* closed.
+      (wt-data-end)) ;;; *compiler-output-data* closed.
 
     (init-env)
 
     (if (zerop *error-count*)
 
-        #+aosvs
-        (progn
-          (when *compile-verbose* (format t "~&End of Pass 2.  ~%"))
-          (when data-file
-            (with-open-file (in fasl-pathname)
-              (with-open-file (out data-pathname :direction :output)
-                (si:copy-stream in out))))
-          (cond ((or fasl-file ob-file)
-                 (compiler-cc c-pathname ob-pathname)
-                 (cond ((probe-file ob-pathname)
-                        (when fasl-file
-                              (compiler-build ob-pathname fasl-pathname)
-                              (when load (load fasl-pathname)))
-                        (unless ob-file (mdelete-file ob-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))))
-                (*compile-verbose*
-                 (print-compiler-info)
-                 (format t "~&Finished compiling ~a.~%" (namestring output-file)
-			 )))
-          (unless c-file (mdelete-file c-pathname))
-          (unless h-file (mdelete-file h-pathname))
-          (unless fasl-file (mdelete-file fasl-pathname)))
-
-
         (progn
           (when *compile-verbose* (format t "~&End of Pass 2.  ~%"))
 	  (cond (*record-call-info*
@@ -497,11 +435,10 @@ Cannot compile ~a.~%"
 				  (ci *cmpinclude*)
 				  (ci (when (stringp ci) (subseq ci 1 (1- (length ci)))))
 				  (ci (concatenate 'string si::*system-directory* "../h/" ci))
-				  (system-p (when (or (eq system-p 'disassemble) (probe-file ci)) system-p)))
+				  (system-p (when (probe-file ci) system-p)))
   (declare (special *init-name*))
   (with-open-file (st c-pathname :direction :output)
-    (let ((*compiler-output1* (if (eq system-p 'disassemble) *standard-output*
-				st)))
+    (let ((*compiler-output1* st))
       (declare (special *compiler-output1*))
     (with-open-file (*compiler-output2* h-pathname :direction :output)
       (cond ((and 
@@ -515,19 +452,9 @@ Cannot compile ~a.~%"
 	        (make-pathname :name
 	          (pathname-name h-pathname)
 	           :type (pathname-type h-pathname)))
-
-              #+aosvs (string-downcase (namestring h-pathname))
               "\"")
 
       (catch *cmperr-tag* (ctop-write *init-name*))
-      (if system-p
-	  (wt
-	   "
-
-#ifdef SYSTEM_SPECIAL_INIT
-SYSTEM_SPECIAL_INIT
-#endif
-"))
 
       (terpri *compiler-output1*)
       ;; write ctl-z at end to make sure preprocessor stops!
--- gcl-2.6.10.orig/configure
+++ gcl-2.6.10/configure
@@ -8456,6 +8456,297 @@ _ACEOF
 fi
 done
 
+for ac_func in feenableexcept
+do :
+  ac_fn_c_check_func "$LINENO" "feenableexcept" "ac_cv_func_feenableexcept"
+if test "x$ac_cv_func_feenableexcept" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_FEENABLEEXCEPT 1
+_ACEOF
+
+fi
+done
+
+
+for ac_header in dis-asm.h
+do :
+  ac_fn_c_check_header_mongrel "$LINENO" "dis-asm.h" "ac_cv_header_dis_asm_h" "$ac_includes_default"
+if test "x$ac_cv_header_dis_asm_h" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_DIS_ASM_H 1
+_ACEOF
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for init_disassemble_info in -lopcodes" >&5
+$as_echo_n "checking for init_disassemble_info in -lopcodes... " >&6; }
+if ${ac_cv_lib_opcodes_init_disassemble_info+:} false; then :
+  $as_echo_n "(cached) " >&6
+else
+  ac_check_lib_save_LIBS=$LIBS
+LIBS="-lopcodes  $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h.  */
+
+/* Override any GCC internal prototype to avoid an error.
+   Use char because int might match the return type of a GCC
+   builtin and then its argument prototype would still apply.  */
+#ifdef __cplusplus
+extern "C"
+#endif
+char init_disassemble_info ();
+int
+main ()
+{
+return init_disassemble_info ();
+  ;
+  return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+  ac_cv_lib_opcodes_init_disassemble_info=yes
+else
+  ac_cv_lib_opcodes_init_disassemble_info=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+    conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_opcodes_init_disassemble_info" >&5
+$as_echo "$ac_cv_lib_opcodes_init_disassemble_info" >&6; }
+if test "x$ac_cv_lib_opcodes_init_disassemble_info" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_LIBOPCODES 1
+_ACEOF
+
+  LIBS="-lopcodes $LIBS"
+
+fi
+
+	for ac_func in print_insn_alpha
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_alpha" "ac_cv_func_print_insn_alpha"
+if test "x$ac_cv_func_print_insn_alpha" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_ALPHA 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_alpha" >>confdefs.h
+
+else
+  for ac_func in print_insn_avr
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_avr" "ac_cv_func_print_insn_avr"
+if test "x$ac_cv_func_print_insn_avr" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_AVR 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_avr" >>confdefs.h
+
+else
+  for ac_func in print_insn_big_arm
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_big_arm" "ac_cv_func_print_insn_big_arm"
+if test "x$ac_cv_func_print_insn_big_arm" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_BIG_ARM 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN insn_big_arm" >>confdefs.h
+
+else
+  for ac_func in print_insn_big_mips
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_big_mips" "ac_cv_func_print_insn_big_mips"
+if test "x$ac_cv_func_print_insn_big_mips" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_BIG_MIPS 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN insn_big_mips" >>confdefs.h
+
+else
+  for ac_func in print_insn_big_powerpc
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_big_powerpc" "ac_cv_func_print_insn_big_powerpc"
+if test "x$ac_cv_func_print_insn_big_powerpc" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_BIG_POWERPC 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN insn_big_powerpc" >>confdefs.h
+
+else
+  for ac_func in print_insn_hppa
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_hppa" "ac_cv_func_print_insn_hppa"
+if test "x$ac_cv_func_print_insn_hppa" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_HPPA 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_hppa" >>confdefs.h
+
+else
+  for ac_func in print_insn_i386
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_i386" "ac_cv_func_print_insn_i386"
+if test "x$ac_cv_func_print_insn_i386" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_I386 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_i386" >>confdefs.h
+
+else
+  for ac_func in print_insn_ia64
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_ia64" "ac_cv_func_print_insn_ia64"
+if test "x$ac_cv_func_print_insn_ia64" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_IA64 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_ia64" >>confdefs.h
+
+else
+  for ac_func in print_insn_little_arm
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_little_arm" "ac_cv_func_print_insn_little_arm"
+if test "x$ac_cv_func_print_insn_little_arm" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_LITTLE_ARM 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN insn_little_arm" >>confdefs.h
+
+else
+  for ac_func in print_insn_little_mips
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_little_mips" "ac_cv_func_print_insn_little_mips"
+if test "x$ac_cv_func_print_insn_little_mips" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_LITTLE_MIPS 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN insn_little_mips" >>confdefs.h
+
+else
+  for ac_func in print_insn_little_powerpc
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_little_powerpc" "ac_cv_func_print_insn_little_powerpc"
+if test "x$ac_cv_func_print_insn_little_powerpc" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_LITTLE_POWERPC 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN insn_little_powerpc" >>confdefs.h
+
+else
+  for ac_func in print_insn_m68k
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_m68k" "ac_cv_func_print_insn_m68k"
+if test "x$ac_cv_func_print_insn_m68k" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_M68K 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_m68k" >>confdefs.h
+
+else
+  for ac_func in print_insn_s390
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_s390" "ac_cv_func_print_insn_s390"
+if test "x$ac_cv_func_print_insn_s390" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_S390 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_s390" >>confdefs.h
+
+else
+  for ac_func in print_insn_sh64
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_sh64" "ac_cv_func_print_insn_sh64"
+if test "x$ac_cv_func_print_insn_sh64" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_SH64 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_sh64" >>confdefs.h
+
+else
+  for ac_func in print_insn_sh
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_sh" "ac_cv_func_print_insn_sh"
+if test "x$ac_cv_func_print_insn_sh" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_SH 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_sh" >>confdefs.h
+
+else
+  for ac_func in print_insn_sparc
+do :
+  ac_fn_c_check_func "$LINENO" "print_insn_sparc" "ac_cv_func_print_insn_sparc"
+if test "x$ac_cv_func_print_insn_sparc" = xyes; then :
+  cat >>confdefs.h <<_ACEOF
+#define HAVE_PRINT_INSN_SPARC 1
+_ACEOF
+
+$as_echo "#define PRINT_INSN print_insn_sparc" >>confdefs.h
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+done
+
+fi
+
+done
+
 
 #if test $use = "386-linux" ; then
 	for ac_header in asm/sigcontext.h
--- gcl-2.6.10.orig/configure.in
+++ gcl-2.6.10/configure.in
@@ -2419,6 +2419,26 @@ int joe=SIGEMT;
 AC_MSG_RESULT(no))
 
 AC_CHECK_FUNCS(sigaltstack)
+AC_CHECK_FUNCS(feenableexcept)
+
+AC_CHECK_HEADERS(dis-asm.h,
+	AC_CHECK_LIB(opcodes,init_disassemble_info)
+	AC_CHECK_FUNCS(print_insn_alpha,AC_DEFINE([PRINT_INSN],[print_insn_alpha],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_avr,AC_DEFINE([PRINT_INSN],[print_insn_avr],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_big_arm,AC_DEFINE([PRINT_INSN],[insn_big_arm],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_big_mips,AC_DEFINE([PRINT_INSN],[insn_big_mips],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_big_powerpc,AC_DEFINE([PRINT_INSN],[insn_big_powerpc],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_hppa,AC_DEFINE([PRINT_INSN],[print_insn_hppa],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_i386,AC_DEFINE([PRINT_INSN],[print_insn_i386],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_ia64,AC_DEFINE([PRINT_INSN],[print_insn_ia64],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_little_arm,AC_DEFINE([PRINT_INSN],[insn_little_arm],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_little_mips,AC_DEFINE([PRINT_INSN],[insn_little_mips],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_little_powerpc,AC_DEFINE([PRINT_INSN],[insn_little_powerpc],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_m68k,AC_DEFINE([PRINT_INSN],[print_insn_m68k],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_s390,AC_DEFINE([PRINT_INSN],[print_insn_s390],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_sh64,AC_DEFINE([PRINT_INSN],[print_insn_sh64],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_sh,AC_DEFINE([PRINT_INSN],[print_insn_sh],[instruction disassemble routine]),
+	AC_CHECK_FUNCS(print_insn_sparc,AC_DEFINE([PRINT_INSN],[print_insn_sparc],[instruction disassemble routine]))))))))))))))))))
 
 #if test $use = "386-linux" ; then
 	AC_CHECK_HEADERS(asm/sigcontext.h)
--- gcl-2.6.10.orig/h/386-macosx.h
+++ gcl-2.6.10/h/386-macosx.h
@@ -196,3 +196,28 @@ if (realpath (buf, fub) == 0) {
 #else
 #define RELOC_H "mach32_i386_reloc.h"
 #endif
+
+
+#define UC(a_) ((ucontext_t *)a_)
+#define SF(a_) ((siginfo_t *)a_)
+
+#define FPE_CODE(i_,v_) make_fixnum(FFN(fSfpe_code)(*(fixnum *)&UC(v_)->uc_mcontext->__fs.__fpu_fsw,UC(v_)->uc_mcontext->__fs.__fpu_mxcsr))
+#define FPE_ADDR(i_,v_) make_fixnum(UC(v_)->uc_mcontext->__fs.__fpu_fop ? UC(v_)->uc_mcontext->__fs.__fpu_ip : (fixnum)SF(i_)->si_addr)
+#define FPE_CTXT(v_) list(3,make_fixnum((fixnum)&UC(v_)->uc_mcontext->__ss), \
+			  make_fixnum((fixnum)&UC(v_)->uc_mcontext->__fs.__fpu_stmm0), \
+			  make_fixnum((fixnum)&UC(v_)->uc_mcontext->__fs.__fpu_xmm0))
+
+
+#define MC(b_) v.uc_mcontext->b_
+#define REG_LIST(a_,b_) MMcons(make_fixnum(a_*sizeof(b_)),make_fixnum(sizeof(b_)))
+#define MCF(b_) ((MC(__fs)).b_)
+
+#ifdef __x86_64__
+#define FPE_RLST "RAX RBX RCX RDX RDI RSI RBP RSP R8 R9 R10 R11 R12 R13 R14 R15 RIP RFLAGS CS FS GS"
+#else
+#error Missing reg list
+#endif
+
+#define FPE_INIT ({ucontext_t v;list(3,MMcons(make_simple_string(({const char *s=FPE_RLST;s;})),REG_LIST(21,MC(__ss))),	\
+				     REG_LIST(8,MCF(__fpu_stmm0)),REG_LIST(16,MCF(__fpu_xmm0)));})
+
--- gcl-2.6.10.orig/h/att_ext.h
+++ gcl-2.6.10/h/att_ext.h
@@ -564,14 +564,15 @@ EXTER object sLcompiled_function,sLpathn
 EXTER object sLinteger,sLratio,sLshort_float,sLstandard_char,sLfixnum,sLpositive_fixnum, sLcomplex;
 EXTER object sLsingle_float,sLpackage,sLbignum,sLrandom_state,sLdouble_float,sLstream,sLbit,sLreadtable;
 EXTER object sLlong_float,sLhash_table,sLstructure,sLboolean;
+EXTER object sLdivision_by_zero,sLfloating_point_inexact,sLfloating_point_invalid_operation;
+EXTER object sLfloating_point_overflow,sLfloating_point_underflow;
 
 #ifdef ANSI_COMMON_LISP
 /* new ansi types */
 EXTER object sLarithmetic_error,sLbase_char,sLbase_string,sLbroadcast_stream,sLbuilt_in_class;
-EXTER object sLcell_error,sLclass,sLconcatenated_stream,sLcondition,sLcontrol_error,sLdivision_by_zero;
+EXTER object sLcell_error,sLclass,sLconcatenated_stream,sLcondition,sLcontrol_error;
 EXTER object sLecho_stream,sLend_of_file,sLerror,sLextended_char,sLfile_error,sLfile_stream;
-EXTER object sLfloating_point_inexact,sLfloating_point_invalid_operation,sLfloating_point_overflow;
-EXTER object sLfloating_point_underflow,sLgeneric_function,sLlogical_pathname,sLmethod,sLpackage_error;
+EXTER object sLgeneric_function,sLlogical_pathname,sLmethod,sLpackage_error;
 EXTER object sLparse_error,sLprint_not_readable,sLprogram_error,sLreader_error,sLserious_condition;
 EXTER object sLsimple_base_string,sLsimple_condition,sLsimple_type_error,sLsimple_warning,sLstandard_class;
 EXTER object sLstandard_generic_function,sLstandard_method,sLstandard_object,sLstorage_condition;
@@ -627,7 +628,6 @@ EXTER object sSPmemory;
 EXTER object sSPinit;
 object sLfset();
 object MakeAfun();
-extern  object Cstd_key_defaults[];   
 extern object call_proc0();
 /* extern object call_proc(); */
 /* extern object call_vproc(); */
--- gcl-2.6.10.orig/h/compdefs.h
+++ gcl-2.6.10/h/compdefs.h
@@ -111,3 +111,4 @@ Scons
 EQ(x,y)
 aset
 stp_ordinary
+SIGNED_CHAR(x)
--- gcl-2.6.10.orig/h/compprotos.h
+++ gcl-2.6.10/h/compprotos.h
@@ -174,3 +174,4 @@ int putc(int,void *);
 #endif
 void vfun_wrong_number_of_args(object);
 void ihs_overflow (void);
+double object_to_double(object);
--- gcl-2.6.10.orig/h/gclincl.h.in
+++ gcl-2.6.10/h/gclincl.h.in
@@ -99,6 +99,9 @@
 /* Define to 1 if you have the <dirent.h> header file. */
 #undef HAVE_DIRENT_H
 
+/* Define to 1 if you have the <dis-asm.h> header file. */
+#undef HAVE_DIS_ASM_H
+
 /* have struct dirent d_type field */
 #undef HAVE_D_TYPE
 
@@ -108,6 +111,9 @@
 /* Define to 1 if you have the <elf.h> header file. */
 #undef HAVE_ELF_H
 
+/* Define to 1 if you have the `feenableexcept' function. */
+#undef HAVE_FEENABLEEXCEPT
+
 /* Have finite function */
 #undef HAVE_FINITE
 
@@ -144,6 +150,9 @@
 /* use libbfd */
 #undef HAVE_LIBBFD
 
+/* Define to 1 if you have the `opcodes' library (-lopcodes). */
+#undef HAVE_LIBOPCODES
+
 /* long long is available */
 #undef HAVE_LONG_LONG
 
@@ -168,6 +177,54 @@
 /* output_bfd element present */
 #undef HAVE_OUTPUT_BFD
 
+/* Define to 1 if you have the `print_insn_alpha' function. */
+#undef HAVE_PRINT_INSN_ALPHA
+
+/* Define to 1 if you have the `print_insn_avr' function. */
+#undef HAVE_PRINT_INSN_AVR
+
+/* Define to 1 if you have the `print_insn_big_arm' function. */
+#undef HAVE_PRINT_INSN_BIG_ARM
+
+/* Define to 1 if you have the `print_insn_big_mips' function. */
+#undef HAVE_PRINT_INSN_BIG_MIPS
+
+/* Define to 1 if you have the `print_insn_big_powerpc' function. */
+#undef HAVE_PRINT_INSN_BIG_POWERPC
+
+/* Define to 1 if you have the `print_insn_hppa' function. */
+#undef HAVE_PRINT_INSN_HPPA
+
+/* Define to 1 if you have the `print_insn_i386' function. */
+#undef HAVE_PRINT_INSN_I386
+
+/* Define to 1 if you have the `print_insn_ia64' function. */
+#undef HAVE_PRINT_INSN_IA64
+
+/* Define to 1 if you have the `print_insn_little_arm' function. */
+#undef HAVE_PRINT_INSN_LITTLE_ARM
+
+/* Define to 1 if you have the `print_insn_little_mips' function. */
+#undef HAVE_PRINT_INSN_LITTLE_MIPS
+
+/* Define to 1 if you have the `print_insn_little_powerpc' function. */
+#undef HAVE_PRINT_INSN_LITTLE_POWERPC
+
+/* Define to 1 if you have the `print_insn_m68k' function. */
+#undef HAVE_PRINT_INSN_M68K
+
+/* Define to 1 if you have the `print_insn_s390' function. */
+#undef HAVE_PRINT_INSN_S390
+
+/* Define to 1 if you have the `print_insn_sh' function. */
+#undef HAVE_PRINT_INSN_SH
+
+/* Define to 1 if you have the `print_insn_sh64' function. */
+#undef HAVE_PRINT_INSN_SH64
+
+/* Define to 1 if you have the `print_insn_sparc' function. */
+#undef HAVE_PRINT_INSN_SPARC
+
 /* have putenv call */
 #undef HAVE_PUTENV
 
@@ -327,6 +384,9 @@
 /* system pagewidth */
 #undef PAGEWIDTH
 
+/* instruction disassemble routine */
+#undef PRINT_INSN
+
 /* have sigcontext in signal.h */
 #undef SIGNAL_H_HAS_SIGCONTEXT
 
--- gcl-2.6.10.orig/h/globals.h
+++ gcl-2.6.10/h/globals.h
@@ -17,6 +17,7 @@ EXTER char *alloca_val;
 EXTER object keyword_package;
 
 EXTER object sLlist;
+EXTER object sLstring;
 EXTER object sLcons;
 EXTER object sLhash_table;
 
--- gcl-2.6.10.orig/h/gnuwin95.h
+++ gcl-2.6.10/h/gnuwin95.h
@@ -145,3 +145,11 @@ extern DBEGIN_TY _dbegin;
 
 /* End for cmpinclude */
 
+#define SF(a_) ((siginfo_t *)a_)
+
+#define FPE_CODE(i_,v_) make_fixnum(fSfpe_code(FFN(fSfnstsw)(),FFN(fSstmxcsr)()))
+/* #define FPE_CODE(i_,v_) make_fixnum((fixnum)SF(i_)->si_code) */
+#define FPE_ADDR(i_,v_) make_fixnum((fixnum)SF(i_)->si_addr)
+#define FPE_CTXT(v_) Cnil
+
+#define FPE_INIT Cnil
--- gcl-2.6.10.orig/h/linux.h
+++ gcl-2.6.10/h/linux.h
@@ -150,3 +150,41 @@ do { int c = 0; \
    (a_)=q;\
  }\
 } while(0)
+
+
+#define UC(a_) ((ucontext_t *)a_)
+#define SF(a_) ((siginfo_t *)a_)
+
+#if defined(__x86_64__) || defined(__i386__)
+
+/* #define FPE_CODE(i_) make_fixnum((fixnum)SF(i_)->si_code) */
+#define FPE_CODE(i_,v_) make_fixnum(FFN(fSfpe_code)(UC(v_)->uc_mcontext.fpregs->swd,UC(v_)->uc_mcontext.fpregs->mxcsr))
+#define FPE_ADDR(i_,v_) make_fixnum(UC(v_)->uc_mcontext.fpregs->fop ? UC(v_)->uc_mcontext.fpregs->rip : (fixnum)SF(i_)->si_addr)
+#define FPE_CTXT(v_) list(3,make_fixnum((fixnum)&UC(v_)->uc_mcontext.gregs),	\
+			    make_fixnum((fixnum)&UC(v_)->uc_mcontext.fpregs->_st), \
+			    make_fixnum((fixnum)&UC(v_)->uc_mcontext.fpregs->_xmm))
+
+#define MC(b_) v.uc_mcontext.b_
+#define REG_LIST(a_) MMcons(make_fixnum(sizeof(a_)),make_fixnum(sizeof(*a_)))
+#define MCF(b_) (((struct _fpstate *)MC(fpregs))->b_)
+
+#ifdef __x86_64__
+#define FPE_RLST "R8 R9 R10 R11 R12 R13 R14 R15 RDI RSI RBP RBX RDX RAX RCX RSP RIP EFL CSGSFS ERR TRAPNO OLDMASK CR2"
+#elif defined(__i386__)
+#define FPE_RLST "GS FS ES DS EDI ESI EBP ESP EBX EDX ECX EAX TRAPNO ERR EIP CS EFL UESP SS"
+#else
+#error Missing reg list
+#endif
+
+#define FPE_INIT ({ucontext_t v;list(3,MMcons(make_simple_string(({const char *s=FPE_RLST;s;})),REG_LIST(MC(gregs))),\
+				     REG_LIST(MCF(_st)),REG_LIST(MCF(_xmm)));})
+
+#else
+
+#define FPE_CODE(i_,v_) make_fixnum((fixnum)SF(i_)->si_code)
+#define FPE_ADDR(i_,v_) make_fixnum((fixnum)SF(i_)->si_addr)
+#define FPE_CTXT(v_) Cnil
+
+#define FPE_INIT Cnil
+
+#endif
--- gcl-2.6.10.orig/h/make-init.h
+++ gcl-2.6.10/h/make-init.h
@@ -77,13 +77,5 @@
 
 #undef DO_INIT
 #define DO_INIT(x) x
-  
-  
 
-	   
-	   
-	   
-
-  
-
-  
+#include <signal.h>
--- gcl-2.6.10.orig/h/mingw.h
+++ gcl-2.6.10/h/mingw.h
@@ -219,3 +219,24 @@ extern int mingwlisten(FILE *);
 #define DBEGIN _dbegin
 
 #define NOFREE_ERR
+
+#define FPE_CODE(i_,v_) make_fixnum(fSfpe_code(FFN(fSfnstsw)(),FFN(fSstmxcsr)()))
+#define FPE_ADDR(i_,v_) make_fixnum(0)
+#define FPE_CTXT(v_) Cnil
+
+#define FPE_INIT Cnil
+
+#define FE_INVALID 1
+#define FE_DIVBYZERO 4
+#define FE_OVERFLOW 8
+#define FE_UNDERFLOW 16
+#define FE_INEXACT 32
+
+#define FPE_FLTDIV 3
+#define FPE_FLTOVF 4
+#define FPE_FLTUND 5
+#define FPE_FLTRES 6
+#define FPE_FLTINV 7
+
+
+
--- gcl-2.6.10.orig/info/gcl-si.info
+++ gcl-2.6.10/info/gcl-si.info
@@ -4907,6 +4907,27 @@ File: gcl-si.info,  Node: Operating Syst
      This function causes execution to be suspended for N seconds.  N
      may be any non-negative, non-complex number.
 
+ -- Function: BREAK-ON-FLOATING-POINT-EXCEPTIONS (&key division-by-zero
+     floating-point-invalid-operation floating-point-overflow
+     floating-point-underflow floating-point-inexact) Package:SI
+
+     Break on the specified IEEE floating point error conditions.  With
+     no arguments, report the exceptions currently trapped.  Disable the
+     break by setting the key to nil, e.g.
+
+     > (break-on-floaing-point-exceptions :division-by-zero t)
+     (DIVISION-BY-ZERO)
+
+     > (break-on-floaing-point-exceptions) (DIVISION-BY-ZERO)
+
+     > (break-on-floaing-point-exceptions :division-by-zero nil) NIL
+
+     On some of the most common platforms, the offending instruction
+     will be disassembled, and the register arguments looked up in the
+     saved context and reported in as operands.  Within the error
+     handler, addresses may be disassembled, and other registers
+     inspected, using the functions defined in gcl_fpe.lsp.
+
 
 File: gcl-si.info,  Node: Structures,  Next: Iteration and Tests,  Prev: Operating System,  Up: Top
 
@@ -7285,6 +7306,8 @@ Appendix A Function and Variable Index
 * BOUNDP:                                Symbols.             (line 230)
 * BREAK:                                 User Interface.      (line 120)
 * BREAK-FUNCTION:                        System Definitions.  (line 676)
+* BREAK-ON-FLOATING-POINT-EXCEPTIONS:    Operating System Definitions.
+                                                              (line 207)
 * BUTLAST:                               Lists.               (line 281)
 * BY:                                    GCL Specific.        (line  39)
 * BYE:                                   GCL Specific.        (line 213)
@@ -8184,25 +8207,25 @@ Node: Symbols134272
 Node: Operating System144030
 Node: Command Line144238
 Node: Operating System Definitions148244
-Node: Structures154601
-Node: Iteration and Tests156153
-Node: User Interface159603
-Node: Doc168629
-Node: Type171878
-Node: GCL Specific174538
-Node: Bignums182965
-Node: C Interface185655
-Node: Available Symbols185819
-Node: System Definitions186298
-Node: Regular Expressions216605
-Node: Debugging222695
-Node: Source Level Debugging in Emacs222899
-Node: Low Level Debug Functions227144
-Node: Miscellaneous228144
-Node: Environment228358
-Node: Inititialization228983
-Node: Low Level X Interface229527
-Node: Compiler Definitions230124
-Node: Function and Variable Index235419
+Node: Structures155543
+Node: Iteration and Tests157095
+Node: User Interface160545
+Node: Doc169571
+Node: Type172820
+Node: GCL Specific175480
+Node: Bignums183907
+Node: C Interface186597
+Node: Available Symbols186761
+Node: System Definitions187240
+Node: Regular Expressions217547
+Node: Debugging223637
+Node: Source Level Debugging in Emacs223841
+Node: Low Level Debug Functions228086
+Node: Miscellaneous229086
+Node: Environment229300
+Node: Inititialization229925
+Node: Low Level X Interface230469
+Node: Compiler Definitions231066
+Node: Function and Variable Index236361
 
 End Tag Table
--- gcl-2.6.10.orig/info/gcl-si/Function-and-Variable-Index.html
+++ gcl-2.6.10/info/gcl-si/Function-and-Variable-Index.html
@@ -329,6 +329,7 @@ Previous: <a href="Compiler-Definitions.
 <tr><td></td><td valign="top"><a href="Symbols.html#index-BOUNDP"><code>BOUNDP</code></a>:</td><td>&nbsp;</td><td valign="top"><a href="Symbols.html#Symbols">Symbols</a></td></tr>
 <tr><td></td><td valign="top"><a href="User-Interface.html#index-BREAK"><code>BREAK</code></a>:</td><td>&nbsp;</td><td valign="top"><a href="User-Interface.html#User-Interface">User Interface</a></td></tr>
 <tr><td></td><td valign="top"><a href="System-Definitions.html#index-BREAK_002dFUNCTION"><code>BREAK-FUNCTION</code></a>:</td><td>&nbsp;</td><td valign="top"><a href="System-Definitions.html#System-Definitions">System Definitions</a></td></tr>
+<tr><td></td><td valign="top"><a href="Operating-System-Definitions.html#index-BREAK_002dON_002dFLOATING_002dPOINT_002dEXCEPTIONS"><code>BREAK-ON-FLOATING-POINT-EXCEPTIONS</code></a>:</td><td>&nbsp;</td><td valign="top"><a href="Operating-System-Definitions.html#Operating-System-Definitions">Operating System Definitions</a></td></tr>
 <tr><td></td><td valign="top"><a href="Lists.html#index-BUTLAST"><code>BUTLAST</code></a>:</td><td>&nbsp;</td><td valign="top"><a href="Lists.html#Lists">Lists</a></td></tr>
 <tr><td></td><td valign="top"><a href="GCL-Specific.html#index-BY"><code>BY</code></a>:</td><td>&nbsp;</td><td valign="top"><a href="GCL-Specific.html#GCL-Specific">GCL Specific</a></td></tr>
 <tr><td></td><td valign="top"><a href="GCL-Specific.html#index-BYE"><code>BYE</code></a>:</td><td>&nbsp;</td><td valign="top"><a href="GCL-Specific.html#GCL-Specific">GCL Specific</a></td></tr>
--- gcl-2.6.10.orig/info/gcl-si/Operating-System-Definitions.html
+++ gcl-2.6.10/info/gcl-si/Operating-System-Definitions.html
@@ -377,6 +377,36 @@ be any non-negative, non-complex number.
 
 </dd></dl>
 
+<dl>
+<dt><a name="index-BREAK_002dON_002dFLOATING_002dPOINT_002dEXCEPTIONS"></a>Function: <strong>BREAK-ON-FLOATING-POINT-EXCEPTIONS</strong> <em>(&amp;key division-by-zero</em></dt>
+<dd><p>floating-point-invalid-operation
+                                                floating-point-overflow
+                                                floating-point-underflow
+                                                floating-point-inexact)
+Package:SI
+</p>
+<p>Break on the specified IEEE floating point error conditions.  With no
+arguments, report the exceptions currently trapped.  Disable the break
+by setting the key to nil, e.g.
+</p>
+<p>&gt; (break-on-floaing-point-exceptions :division-by-zero t)
+   (DIVISION-BY-ZERO)
+</p>
+<p>&gt; (break-on-floaing-point-exceptions)
+   (DIVISION-BY-ZERO)
+</p>
+<p>&gt; (break-on-floaing-point-exceptions :division-by-zero nil)
+   NIL
+</p>
+<p>On some of the most common platforms, the offending instruction will be
+disassembled, and the register arguments looked up in the saved context
+and reported in as operands.  Within the error handler, addresses may be
+disassembled, and other registers inspected, using the functions defined
+in gcl_fpe.lsp.
+</p>
+</dd></dl>
+
+
 <hr>
 <div class="header">
 <p>
--- gcl-2.6.10.orig/info/system.texi
+++ gcl-2.6.10/info/system.texi
@@ -427,3 +427,32 @@ be any non-negative, non-complex number.
 
 
 @end defun
+
+@defun BREAK-ON-FLOATING-POINT-EXCEPTIONS (&key division-by-zero
+                                                floating-point-invalid-operation
+                                                floating-point-overflow
+                                                floating-point-underflow
+                                                floating-point-inexact)
+Package:SI
+
+Break on the specified IEEE floating point error conditions.  With no
+arguments, report the exceptions currently trapped.  Disable the break
+by setting the key to nil, e.g.
+
+   > (break-on-floaing-point-exceptions :division-by-zero t)
+   (DIVISION-BY-ZERO)
+
+   > (break-on-floaing-point-exceptions)
+   (DIVISION-BY-ZERO)
+
+   > (break-on-floaing-point-exceptions :division-by-zero nil)
+   NIL
+
+On some of the most common platforms, the offending instruction will be
+disassembled, and the register arguments looked up in the saved context
+and reported in as operands.  Within the error handler, addresses may be
+disassembled, and other registers inspected, using the functions defined
+in gcl_fpe.lsp.
+
+@end defun
+
--- /dev/null
+++ gcl-2.6.10/lsp/gcl_fpe.lsp
@@ -0,0 +1,147 @@
+(in-package :fpe :use '(:lisp))
+
+(import 'si::(disassemble-instruction feenableexcept fedisableexcept fld *fixnum *float *double
+				      +fe-list+ +mc-context-offsets+ floating-point-error 
+				      function-by-address))
+(export '(break-on-floating-point-exceptions read-instruction))
+
+(eval-when
+    (eval compile)
+
+  (defconstant +feallexcept+ (reduce 'logior (mapcar 'caddr +fe-list+)))
+
+
+  (defun moff (i r) (* i (cdr r)))
+  
+  (defun stl (s &aux (s (if (stringp s) (make-string-input-stream s) s))(x (read s nil 'eof)))
+    (unless (eq x 'eof) (cons x (stl s))))
+
+  (defun ml (r) (when r (make-list (truncate (car r) (cdr r)))))
+
+  (defun mcgr (r &aux (i -1))
+    (mapcar (lambda (x y) `(defconstant ,x ,(moff (incf i) r))) (when r (stl (pop r))) (ml r)))
+  
+  (defun mcr (p r &aux (i -1))
+    (mapcar (lambda (x) `(defconstant ,(intern (concatenate 'string p (write-to-string (incf i))) :fpe) ,(moff i r)))
+	    (ml r)))
+
+  (defmacro deft (n rt args &rest code)
+  `(progn
+     (clines ,(nstring-downcase 
+	       (apply 'concatenate 'string
+			   (symbol-name rt) " " (symbol-name n) "("
+			   (apply 'concatenate 'string 
+				  (mapcon (lambda (x) (list* (symbol-name (caar x)) " " (symbol-name (cadar x)) 
+							     (when (cdr x) (list ", ")))) args))
+			   ") "
+			   code)))
+     (defentry ,n ,(mapcar 'car args) (,rt ,(string-downcase (symbol-name n)))))))
+
+#.`(progn ,@(mcgr (first +mc-context-offsets+)))
+#.`(progn ,@(mcr "ST" (second +mc-context-offsets+)))
+#.`(progn ,@(mcr "XMM" (third +mc-context-offsets+)))
+
+
+(defconstant +top-readtable+ (let ((*readtable* (copy-readtable)))
+			       (set-syntax-from-char #\, #\Space)
+			       (set-syntax-from-char #\; #\a)
+			       (set-macro-character #\0 '0-reader)
+			       (set-macro-character #\$ '0-reader)
+			       (set-macro-character #\- '0-reader)
+			       (set-macro-character #\% '%-reader)
+			       (set-macro-character #\( 'paren-reader)
+			       *readtable*))
+(defconstant +sub-readtable+ (let ((*readtable* (copy-readtable +top-readtable+)))
+			       (set-syntax-from-char #\0 #\a)
+			       *readtable*))
+(defvar *offset* 0)
+(defvar *insn* nil)
+(defvar *context* nil)
+
+
+(defun rf (addr w)
+  (ecase w (4 (*float addr)) (8 (*double addr))))
+
+(defun ref (addr p w &aux (i -1)) 
+  (if p 
+      (map-into (make-list (truncate 16 w)) (lambda nil (rf (+ addr (* w (incf i))) w)))
+    (rf addr w)))
+
+(defun gref (addr &aux (z (symbol-name *insn*))(lz (length z))(lz (if (eql (aref z (- lz 3)) #\2) (- lz 3) lz))
+		  (f (eql #\F (aref z 0))))
+  (ref addr (unless f (eql (aref z (- lz 2)) #\P)) (if (or f (eql (aref z (1- lz)) #\D)) 8 4)))
+
+(defun reg-lookup (x) (*fixnum (+ (car *context*) (symbol-value x))))
+
+(defun st-lookup (x) (fld (+ (cadr *context*) (symbol-value x))))
+(defun xmm-lookup (x) (gref (+ (caddr *context*) (symbol-value x))))
+
+
+(defun lookup (x &aux (z (symbol-name x)))
+  (case (aref z 0)
+    (#\X (xmm-lookup x))
+    (#\S (st-lookup x))
+    (otherwise (reg-lookup x))))
+
+(defun %-reader (stream subchar &aux (*readtable* +sub-readtable+)(*package* (find-package :fpe)))
+  (declare (ignore subchar))
+  (let ((x (read stream)))
+    (lookup (if (eq x 'st)
+		(intern (concatenate 'string (symbol-name x)
+				     (write-to-string
+				      (if (eql (peek-char nil stream nil 'eof) #\()
+					  (let ((ch (read-char stream))(x (read stream))(ch (read-char stream)))
+					    (declare (ignore ch))
+					    x)
+					0))) :fpe) x))))
+
+(defun 0-reader (stream subchar &aux a (s 1)(*readtable* +sub-readtable+))
+
+  (when (eql subchar #\$) (setq a t subchar (read-char stream)))
+  (when (eql subchar #\-) (setq s -1 subchar (read-char stream)))
+  (assert (eql subchar #\0))
+  (assert (eql (read-char stream) #\x))
+
+  (let* ((*read-base* 16)(x (* s (read stream))))
+    (if a x (let ((*offset* x)) (read stream)))))
+
+(defun paren-reader (stream subchar &aux (*readtable* +sub-readtable+))
+  (declare (ignore subchar))
+  (let* ((x (read-delimited-list #\) stream)))
+    (gref (+ *offset* (pop x) (if x (* (pop x) (car x)) 0)))))
+
+(defun read-operands (s context &aux (*context* context))
+  (read-delimited-list #\; s))
+
+(defun read-instruction (addr context &aux (*readtable* +top-readtable+)
+			      (i (car (disassemble-instruction addr)))(s (make-string-input-stream i))
+			      (*insn* (read s)))
+  (cons i (cons *insn* (when context (read-operands s context)))))
+
+
+(defun fe-enable (a)
+  (declare (fixnum a))
+  (fedisableexcept)
+  (feenableexcept a))
+
+
+#.`(let ((fpe-enabled 0))
+     (defun break-on-floating-point-exceptions 
+       (&key suspend ,@(mapcar (lambda (x) `(,(car x) (logtest ,(caddr x) fpe-enabled))) +fe-list+) &aux r)
+       (fe-enable
+	(if suspend 0
+	  (setq fpe-enabled 
+		(logior
+		 ,@(mapcar (lambda (x)
+			     `(cond (,(car x) (push ,(intern (symbol-name (car x)) :keyword) r) ,(caddr x))
+				    (0))) +fe-list+)))))
+       r))
+
+(defun floating-point-error (code addr context)
+  (break-on-floating-point-exceptions :suspend t)
+  (unwind-protect
+    (let* ((fun (function-by-address addr))(m (read-instruction addr context)))
+      ((lambda (&rest r) (apply 'error (if (find-package :conditions) r (list (format nil "~s" r)))))
+		 (or (caar (member code +fe-list+ :key 'cadr)) 'arithmetic-error) 
+		 :operation (list :insn (pop m) :op (pop m) :fun fun :addr addr) :operands m))
+    (break-on-floating-point-exceptions)))
--- /dev/null
+++ gcl-2.6.10/lsp/gcl_fpe_test.lsp
@@ -0,0 +1,211 @@
+#.`(defun test-fpe (f a r &optional chk &aux cc (o (mapcan (lambda (x) (list x t)) (si::break-on-floating-point-exceptions))))
+     (flet ((set-break (x) (when (keywordp r)
+			     (apply 'si::break-on-floating-point-exceptions (append (unless x o) (list r x))))))
+       (let* ((rr (handler-case (unwind-protect (progn (set-break t) (apply f a)) (set-break nil))
+				,@(mapcar (lambda (x &aux (x (car x))) `(,x (c) (setq cc c) ,(intern (symbol-name x) :keyword)))
+					  (append si::+fe-list+ '((arithmetic-error)(error)))))))
+	 (print (list* f a r rr (when cc (list cc (arithmetic-error-operation cc) (arithmetic-error-operands cc)))))
+	 (assert (eql r rr))
+	 (when (and chk cc)
+	   (unless (eq 'fnop (cadr (member :op (arithmetic-error-operation cc))))
+	     (assert (every 'eql (symbol-name f) (symbol-name (cadr (member :op (arithmetic-error-operation cc))))))
+	     (assert (or (every 'equalp (mapcar (lambda (x) (if (numberp x) x (coerce x 'list))) a)
+				(arithmetic-error-operands cc))
+			 (every 'equalp (nreverse (mapcar (lambda (x) (if (numberp x) x (coerce x 'list))) a))
+				(arithmetic-error-operands cc)))))))))
+
+(defun l/ (x y) (declare (long-float x y)) (/ x y))
+(defun s/ (x y) (declare (short-float x y)) (/ x y))
+(defun lsqrt (x) (declare (long-float x)) (the long-float (sqrt x)))
+
+(test-fpe 'l/ (list 1.0 2.0) 0.5)
+(test-fpe 'l/ (list 1.0 0.0) :division-by-zero)
+(test-fpe 'l/ (list 0.0 0.0) :floating-point-invalid-operation)
+(test-fpe 'l/ (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow)
+(test-fpe 'l/ (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow)
+(test-fpe 'l/ (list 1.2 1.3) :floating-point-inexact)
+
+(test-fpe 's/ (list 1.0s0 2.0s0) 0.5s0)
+(test-fpe 's/ (list 1.0s0 0.0s0) :division-by-zero)
+(test-fpe 's/ (list 0.0s0 0.0s0) :floating-point-invalid-operation)
+(test-fpe 's/ (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow)
+(test-fpe 's/ (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow)
+(test-fpe 's/ (list 1.2s0 1.3s0) :floating-point-inexact)
+
+(test-fpe 'lsqrt (list 4.0) 2.0)
+(test-fpe 'lsqrt (list -1.0) :floating-point-invalid-operation)
+(test-fpe 'lsqrt (list 1.2) :floating-point-inexact))
+
+
+#+(or x86_64 i386)
+(progn
+  (eval-when
+      (compile eval)
+    (defmacro deft (n rt args &rest code)
+      `(progn
+	 (clines ,(nstring-downcase 
+		   (apply 'concatenate 'string
+			  (symbol-name rt) " " (symbol-name n) "("
+			  (apply 'concatenate 'string 
+				 (mapcon (lambda (x) (list* (symbol-name (caar x)) " " (symbol-name (cadar x)) 
+							    (when (cdr x) (list ", ")))) args)) ") " code)))
+	 (defentry ,n ,(mapcar 'car args) (,rt ,(string-downcase (symbol-name n)))))))
+  
+  (deft fdivp object ((object x) (object y))
+    "{volatile double a=lf(x),b=lf(y),c;"
+    "__asm__ __volatile__ (\"fldl %1;fldl %0;fdivp %%st,%%st(1);fstpl %2;fwait\" "
+    ": \"=m\" (a), \"=m\" (b) : \"m\" (c));"
+    "return make_longfloat(c);}")
+  
+  (deft divpd object ((object x) (object y) (object z))
+    "{__asm__ __volatile__ (\"movapd %0,%%xmm0;movapd %1,%%xmm1;divpd %%xmm0,%%xmm1;movapd %%xmm1,%2\" "
+    ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));"
+    "return z;}")
+  
+  (deft divpdm object ((object x) (object y) (object z))
+    "{__asm__ __volatile__ (\"movapd %1,%%xmm1;divpd %0,%%xmm1;movapd %%xmm1,%2\" "
+    ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));"
+    "return z;}")
+  
+  (deft divps object ((object x) (object y) (object z))
+    "{__asm__ __volatile__ (\"movaps %0,%%xmm0;movaps %1,%%xmm1;divps %%xmm0,%%xmm1;movaps %%xmm1,%2\" "
+    ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));"
+    "return z;}")
+  
+  (deft divpsm object ((object x) (object y) (object z))
+    "{__asm__ __volatile__ (\"movaps %1,%%xmm1;divps %0,%%xmm1;movaps %%xmm1,%2\" "
+    ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));"
+    "return z;}")
+  
+  (deft divsd object ((object x) (object y))
+    "{volatile double a=lf(x),b=lf(y),c;"
+    "__asm__ __volatile__ (\"movsd %0,%%xmm0;movsd %1,%%xmm1;divsd %%xmm1,%%xmm0;movsd %%xmm0,%2\" "
+    ": \"=m\" (a), \"=m\" (b) : \"m\" (c));"
+    "return make_longfloat(c);}")
+  
+  (deft divsdm object ((object x) (object y))
+    "{volatile double a=lf(x),b=lf(y),c;"
+    "__asm__ __volatile__ (\"movsd %0,%%xmm0;divsd %1,%%xmm0;movsd %%xmm0,%2\" "
+    ": \"=m\" (a), \"=m\" (b) : \"m\" (c));"
+    "return make_longfloat(c);}")
+  
+  (deft divss object ((object x) (object y))
+    "{volatile float a=sf(x),b=sf(y),c;"
+    "__asm__ __volatile__ (\"movss %0,%%xmm0;movss %1,%%xmm1;divss %%xmm1,%%xmm0;movss %%xmm0,%2\" "
+    ": \"=m\" (a), \"=m\" (b) : \"m\" (c));"
+    "return make_shortfloat(c);}")
+  
+  (deft divssm object ((object x) (object y))
+    "{volatile float a=sf(x),b=sf(y),c;"
+    "__asm__ __volatile__ (\"movss %0,%%xmm0;divss %1,%%xmm0;movss %%xmm0,%2\" "
+    ": \"=m\" (a), \"=m\" (b) : \"m\" (c));"
+    "return make_shortfloat(c);}")
+  
+  (deft sqrtpd object ((object x) (object y) (object z))
+    "{__asm__ __volatile__ (\"movapd %0,%%xmm0;movapd %1,%%xmm1;sqrtpd %%xmm0,%%xmm1;movapd %%xmm1,%2\" "
+    ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));"
+    "return z;}")
+  
+  (eval-when
+      (compile load eval)
+    (deft c_array_self fixnum ((object x)) "{return (fixnum)x->a.a_self;}")
+    (defun c-array-eltsize (x) (ecase (array-element-type x) (short-float 4) (long-float 8)))
+    (defun make-aligned-array (alignment size &rest r
+					 &aux (ic (member :initial-contents r)) y
+					 (c (cadr ic))
+					 (r (append (ldiff r ic) (cddr ic)))
+					 (a (apply 'make-array (+ alignment size) (list* :static t r))))
+      (setq y (map-into
+	       (apply 'make-array size
+		      :displaced-to a
+		      :displaced-index-offset (truncate (- alignment (mod (c_array_self a) alignment)) (c-array-eltsize a))
+		      r)
+	       'identity c))
+      (assert (zerop (mod (c_array_self y) 16)))
+      y))
+  
+  (setq fa (make-aligned-array 16 4 :element-type 'short-float :initial-contents '(1.2s0 2.3s0 3.4s0 4.1s0))
+	fb (make-aligned-array 16 4 :element-type 'short-float)
+	fc (make-aligned-array 16 4 :element-type 'short-float :initial-contents '(1.3s0 2.4s0 3.5s0 4.6s0))
+	fx (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element most-positive-short-float))
+	fm (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element least-positive-normalized-short-float))
+	fn (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element -1.0s0))
+	fr (make-aligned-array 16 4 :element-type 'short-float))
+  
+  (setq da (make-aligned-array 16 2 :element-type 'long-float :initial-contents '(1.2 2.3))
+	db (make-aligned-array 16 2 :element-type 'long-float)
+	dc (make-aligned-array 16 2 :element-type 'long-float :initial-contents '(1.3 2.4))
+	dx (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element most-positive-long-float))
+	dm (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element least-positive-normalized-long-float))
+	dn (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element -1.0))
+	dr (make-aligned-array 16 2 :element-type 'long-float))
+  
+  (test-fpe 'fdivp (list 1.0 2.0) 0.5 t)
+  (test-fpe 'fdivp (list 1.0 0.0) :division-by-zero t)
+  (test-fpe 'fdivp (list 0.0 0.0) :floating-point-invalid-operation t)
+  (test-fpe 'fdivp (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow);fstpl
+  (test-fpe 'fdivp (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow);fstpl
+  (test-fpe 'fdivp (list 1.2 1.3) :floating-point-inexact);post args
+  
+  (test-fpe 'divpd (list da da dr) dr t)
+  (test-fpe 'divpd (list db da dr) :division-by-zero t)
+  (test-fpe 'divpd (list db db dr) :floating-point-invalid-operation t)
+  (test-fpe 'divpd (list dm dx dr) :floating-point-overflow t)
+  (test-fpe 'divpd (list dx dm dr) :floating-point-underflow t)
+  (test-fpe 'divpd (list da dc dr) :floating-point-inexact t)
+  
+  (test-fpe 'divpdm (list da da dr) dr t)
+  (test-fpe 'divpdm (list db da dr) :division-by-zero t)
+  (test-fpe 'divpdm (list db db dr) :floating-point-invalid-operation t)
+  (test-fpe 'divpdm (list dm dx dr) :floating-point-overflow t)
+  (test-fpe 'divpdm (list dx dm dr) :floating-point-underflow t)
+  (test-fpe 'divpdm (list da dc dr) :floating-point-inexact t)
+  
+  
+  (test-fpe 'divps (list fa fa fr) fr t)
+  (test-fpe 'divps (list fb fa fr) :division-by-zero t)
+  (test-fpe 'divps (list fb fb fr) :floating-point-invalid-operation t)
+  (test-fpe 'divps (list fm fx fr) :floating-point-overflow t)
+  (test-fpe 'divps (list fx fm fr) :floating-point-underflow t)
+  (test-fpe 'divps (list fa fc fr) :floating-point-inexact t)
+  
+  (test-fpe 'divpsm (list fa fa fr) fr t)
+  (test-fpe 'divpsm (list fb fa fr) :division-by-zero t)
+  (test-fpe 'divpsm (list fb fb fr) :floating-point-invalid-operation t)
+  (test-fpe 'divpsm (list fm fx fr) :floating-point-overflow t)
+  (test-fpe 'divpsm (list fx fm fr) :floating-point-underflow t)
+  (test-fpe 'divpsm (list fa fc fr) :floating-point-inexact t)
+  
+  
+  
+  (test-fpe 'divsd (list 1.0 2.0) 0.5 t)
+  (test-fpe 'divsd (list 1.0 0.0) :division-by-zero t)
+  (test-fpe 'divsd (list 0.0 0.0) :floating-point-invalid-operation t)
+  (test-fpe 'divsd (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t)
+  (test-fpe 'divsd (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t)
+  (test-fpe 'divsd (list 1.2 2.3) :floating-point-inexact t)
+  
+  (test-fpe 'divsdm (list 1.0 2.0) 0.5 t)
+  (test-fpe 'divsdm (list 1.0 0.0) :division-by-zero t)
+  (test-fpe 'divsdm (list 0.0 0.0) :floating-point-invalid-operation t)
+  (test-fpe 'divsdm (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t)
+  (test-fpe 'divsdm (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t)
+  (test-fpe 'divsdm (list 1.2 2.3) :floating-point-inexact t)
+  
+  (test-fpe 'divss (list 1.0s0 2.0s0) 0.5s0 t)
+  (test-fpe 'divss (list 1.0s0 0.0s0) :division-by-zero t)
+  (test-fpe 'divss (list 0.0s0 0.0s0) :floating-point-invalid-operation t)
+  (test-fpe 'divss (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t)
+  (test-fpe 'divss (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t)
+  (test-fpe 'divss (list 1.2s0 2.3s0) :floating-point-inexact t)
+  
+  (test-fpe 'divssm (list 1.0s0 2.0s0) 0.5s0 t)
+  (test-fpe 'divssm (list 1.0s0 0.0s0) :division-by-zero t)
+  (test-fpe 'divssm (list 0.0s0 0.0s0) :floating-point-invalid-operation t)
+  (test-fpe 'divssm (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t)
+  (test-fpe 'divssm (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t)
+  (test-fpe 'divssm (list 1.2s0 2.3s0) :floating-point-inexact t)
+  
+  (test-fpe 'sqrtpd (list da db dr) dr t)
+  (test-fpe 'sqrtpd (list dn db dr) :floating-point-invalid-operation t)
+  (test-fpe 'sqrtpd (list da db dr) :floating-point-inexact t))
--- gcl-2.6.10.orig/lsp/gcl_predlib.lsp
+++ gcl-2.6.10/lsp/gcl_predlib.lsp
@@ -755,6 +755,7 @@
 	 (case type
 	   ,@(mapcar (lambda (x) `(,x (,(get x 'type-predicate) object))) 
 	   	     '(string list vector bit-vector array character float cons))
+	   (function (unless (symbolp object) (functionp object)));FIXME
 	   (otherwise (typep object type)))
        (return-from coerce object))
      (case ctp
--- gcl-2.6.10.orig/lsp/gcl_top.lsp
+++ gcl-2.6.10/lsp/gcl_top.lsp
@@ -95,7 +95,8 @@
 	(cond
 	 (*multiply-stacks* (setq *multiply-stacks* nil))
 	 ((probe-file "init.lsp") (load "init.lsp"))))
-      (and (or (fboundp *top-level-hook*) (functionp *top-level-hook*))(funcall *top-level-hook*)))
+      (when (if (symbolp *top-level-hook*) (fboundp *top-level-hook*) (functionp *top-level-hook*))
+	(funcall *top-level-hook*)))
 
     (when (boundp '*system-banner*)
       (format t *system-banner*)
--- gcl-2.6.10.orig/lsp/makefile
+++ gcl-2.6.10/lsp/makefile
@@ -10,7 +10,7 @@ CAT=cat
 APPEND=../xbin/append
 
 OBJS	= gcl_sharp.o gcl_arraylib.o gcl_assert.o gcl_defmacro.o gcl_defstruct.o \
-	  gcl_describe.o gcl_evalmacros.o \
+	  gcl_describe.o gcl_evalmacros.o gcl_fpe.o \
 	  gcl_iolib.o gcl_listlib.o gcl_mislib.o gcl_module.o gcl_numlib.o \
 	  gcl_packlib.o gcl_predlib.o \
 	  gcl_seq.o gcl_seqlib.o gcl_setf.o gcl_top.o gcl_trace.o gcl_sloop.o \
--- gcl-2.6.10.orig/o/alloc.c
+++ gcl-2.6.10/o/alloc.c
@@ -1253,15 +1253,16 @@ DEFUN_NEW("ALLOCATE-GROWTH",object,fSall
 
 
 
-DEFUN_NEW("ALLOCATE-CONTIGUOUS-PAGES",object,fSallocate_contiguous_pages,SI,1,2,NONE,OI,OO,OO,OO,(fixnum npages,...),"") {
+DEFUN_NEW("ALLOCATE-CONTIGUOUS-PAGES",object,fSallocate_contiguous_pages,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") {
 
   int nargs=VFUN_NARGS;
   object really_do;
   va_list ap;
+  fixnum npages=fixint(onpages);
   
   really_do=Cnil;
   if (nargs>=2) {
-    va_start(ap,npages);
+    va_start(ap,onpages);
     really_do=va_arg(ap,object);
     va_end(ap);
   }
@@ -1295,15 +1296,16 @@ DEFUN_NEW("MAXIMUM-CONTIGUOUS-PAGES",obj
 }
 
 
-DEFUN_NEW("ALLOCATE-RELOCATABLE-PAGES",object,fSallocate_relocatable_pages,SI,1,2,NONE,OI,OO,OO,OO,(fixnum npages,...),"") {
+DEFUN_NEW("ALLOCATE-RELOCATABLE-PAGES",object,fSallocate_relocatable_pages,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") {
 
   int nargs=VFUN_NARGS;
   object really_do;
   va_list ap;
+  fixnum npages=fixint(onpages);
   
   really_do=Cnil;
   if (nargs>=2) {
-    va_start(ap,npages);
+    va_start(ap,onpages);
     really_do=va_arg(ap,object);
     va_end(ap);
   }
@@ -1321,17 +1323,18 @@ DEFUN_NEW("ALLOCATE-RELOCATABLE-PAGES",o
 
 }
 
-DEFUN_NEW("ALLOCATE",object,fSallocate,SI,2,3,NONE,OO,IO,OO,OO,(object type,fixnum npages,...),"") {
+DEFUN_NEW("ALLOCATE",object,fSallocate,SI,2,3,NONE,OO,OO,OO,OO,(object type,object onpages,...),"") {
 
   int nargs=VFUN_NARGS;
   object really_do;
   va_list ap;
   struct typemanager *tm;
+  fixnum npages=fixint(onpages);
   int t;
   
   really_do=Cnil;
   if (nargs>=3) {
-    va_start(ap,npages);
+    va_start(ap,onpages);
     really_do=va_arg(ap,object);
     va_end(ap);
   }
@@ -1339,9 +1342,9 @@ DEFUN_NEW("ALLOCATE",object,fSallocate,S
   CHECK_ARG_RANGE(2,3);
   t= t_from_type(type);
   if (t == t_contiguous) 
-    RETURN1(FUNCALL(2,FFN(fSallocate_contiguous_pages)(npages,really_do)));
+    RETURN1(FUNCALL(2,FFN(fSallocate_contiguous_pages)(make_fixnum(npages),really_do)));
   else if (t==t_relocatable) 
-    RETURN1(FUNCALL(2,FFN(fSallocate_relocatable_pages)(npages,really_do)));
+    RETURN1(FUNCALL(2,FFN(fSallocate_relocatable_pages)(make_fixnum(npages),really_do)));
 
 
   if  (npages <= 0)
@@ -1493,7 +1496,7 @@ DEFUN_NEW("SET-STARTING-RELBLOCK-HEAP-MU
   return (object)starting_relb_heap_mult;
 }
   
-DEFUNM_NEW("SET-HOLE-SIZE",object,fSset_hole_size,SI,1,2,NONE,OI,IO,OO,OO,(fixnum npages,...),"") {
+DEFUNM_NEW("SET-HOLE-SIZE",object,fSset_hole_size,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") {
 
   printf("This function is obsolete -- use SET-STARTING-HOLE-DIVISOR instead\n");
 
--- gcl-2.6.10.orig/o/array.c
+++ gcl-2.6.10/o/array.c
@@ -66,7 +66,7 @@ DEFUNO_NEW("AREF", object, fLaref, LISP,
        NONE, OO, OO, OO, OO,void,Laref,(object x,object oi, ...),"")
 { int n = VFUN_NARGS;
   int i1;
-  fixnum i=fix(oi);
+  fixnum i=n>1 ? fix(oi) : 0;
   va_list ap;
   if (type_of(x) == t_array)
     {int m ;
@@ -349,12 +349,13 @@ DEFUNO_NEW("SVSET", object, fSsvset, SI,
 */ 
 
 
-DEFUN_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI,
-      IO,OO,OO,(fixnum n,fixnum elt_type,object staticp,...),"")
+DEFUN_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OO,
+      OO,OO,OO,(object on,object oelt_type,object staticp,...),"")
   
 { 
     int displaced_index_offset=0;
     int Inargs = VFUN_NARGS - 3;
+    fixnum n=fixint(on),elt_type=fixint(oelt_type);
     va_list Iap;object fillp;object initial_element;object displaced_to;object V9;
     Inargs = VFUN_NARGS - 3 ;
     { object x;
@@ -442,7 +443,7 @@ DEFUN_NEW("MAKE-VECTOR1",object,fSmake_v
 object 
 fSmake_vector1_1(fixnum n,fixnum elt_type,object staticp) {
   VFUN_NARGS=3;
-  return FFN(fSmake_vector1)(n,elt_type,staticp);
+  return FFN(fSmake_vector1)(make_fixnum(n),make_fixnum(elt_type),staticp);
 }
 
 
@@ -507,8 +508,8 @@ DEFUNO_NEW("MAKE-VECTOR",object,fSmake_v
   /* 8 args */
 
   VFUN_NARGS = 8;
-  x = FFN(fSmake_vector1)(Mfix(x1),  /* n */
-		     fix(fSget_aelttype(x0)), /*aelt type */
+  x = FFN(fSmake_vector1)(x1,  /* n */
+		     fSget_aelttype(x0), /*aelt type */
 		     x6, /* staticp */
 		     x3, /* fillp */ 
 		     initial_elt, /* initial element */
--- gcl-2.6.10.orig/o/main.c
+++ gcl-2.6.10/o/main.c
@@ -999,3 +999,91 @@ init_main(void) {
 #ifdef SGC
 #include "writable.h"
 #endif
+
+#ifdef PRINT_INSN
+
+#include "dis-asm.h"
+
+static char b[4096],*bp;
+
+static int
+my_fprintf(void *v,const char *f,...) {
+  va_list va;
+  int r;
+  va_start(va,f);
+  bp+=(r=vsnprintf(bp,sizeof(b)-(bp-b),f,va));
+  va_end(va);
+  return r;
+}
+
+static int
+my_read(bfd_vma memaddr, bfd_byte *myaddr, unsigned int length, struct disassemble_info *dinfo) {
+  memcpy(myaddr,(void *)memaddr,length);
+  return 0;
+}
+
+static void
+my_pa(bfd_vma addr,struct disassemble_info *dinfo) {
+  dinfo->fprintf_func(dinfo->stream,"%p",(void *)addr);
+}
+
+#endif
+
+DEFUN_NEW("DISASSEMBLE-INSTRUCTION",object,fSdisassemble_instruction,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") {
+
+#ifdef HAVE_PRINT_INSN_I386
+
+  static disassemble_info i;
+  /* static int k; */
+  int j;
+
+  /* if (!k) {init_disassemble_info(&i,NULL,my_fprintf);k=1;} */
+  memset(&i,0,sizeof(i));
+  i.fprintf_func=my_fprintf;
+  i.read_memory_func=my_read;
+  i.print_address_func=my_pa;
+  bp=b;
+  
+  j=PRINT_INSN(addr,&i);
+  my_fprintf(NULL," ;");
+  return MMcons(make_simple_string(b),make_fixnum(j));
+
+#else
+
+  return MMcons(make_simple_string("fnop ;"),make_fixnum(0));
+
+#endif
+}
+
+typedef struct {
+  enum type tt;
+  struct typemanager *tp;
+} Tbl;
+
+#define Tblof(a_)       {(a_),tm_of(a_)}
+#define tblookup(a_,b_) ({Tbl *tb=tb1;(b_)=(a_);for (;tb->tt && tb->b_!=(b_);tb++);tb->tt;})
+#define mtm_of(a_)      (a_)>=t_other ? NULL : tm_of(a_)
+
+DEFUN_NEW("FUNCTION-BY-ADDRESS",object,fSfunction_by_address,SI,1,1,NONE,OI,OO,OO,OO,(fixnum ad),"") {
+
+  ufixnum m=-1,mm,j;
+  void *o;
+  object x,xx=Cnil;
+  Tbl tb1[]={Tblof(t_sfun),Tblof(t_cfun),Tblof(t_vfun),Tblof(t_afun),Tblof(t_gfun),Tblof(t_closure),Tblof(t_cclosure),{0}};
+  struct typemanager *tp;
+  enum type tt;
+  struct pageinfo *v;
+
+  if (VALID_DATA_ADDRESS_P(ad))
+    for (v=cell_list_head;v;v=v->next)
+      if (tblookup(mtm_of(v->type),tp))
+	for (o=pagetochar(page(v)),j=tp->tm_nppage;j--;o+=tp->tm_size)
+	  if (tblookup(type_of((x=o)),tt))
+	    if (!is_free(x) && (mm=ad-(ufixnum)x->sfn.sfn_self)<m) {
+	      m=mm;
+	      xx=x;
+	    }
+  
+  return xx;
+
+}
--- gcl-2.6.10.orig/o/predicate.c
+++ gcl-2.6.10/o/predicate.c
@@ -333,12 +333,12 @@ DEFUNO_NEW("FUNCTIONP",object,fLfunction
 	    || t == t_closure|| t == t_afun
 	    || t == t_vfun)
 		x0 = Ct;
-	/* else if (t == t_symbol) { */
-	/* 	if (x0->s.s_gfdef != OBJNULL && */
-	/* 	    x0->s.s_mflag == FALSE) */
-	/* 		x0 = Ct; */
-	/* 	else */
-	/* 		x0 = Cnil; } */
+	else if (t == t_symbol) {
+		if (x0->s.s_gfdef != OBJNULL &&
+		    x0->s.s_mflag == FALSE)
+			x0 = Ct;
+		else
+			x0 = Cnil; }
 	else if (t == t_cons) {
 		x = x0->c.c_car;
 		if (x == sLlambda || x == sLlambda_block ||
--- gcl-2.6.10.orig/o/typespec.c
+++ gcl-2.6.10/o/typespec.c
@@ -487,6 +487,11 @@ DEF_ORDINARY("SIGNED-SHORT",sLsigned_sho
 DEF_ORDINARY("UNSIGNED-SHORT",sLunsigned_short,LISP,"");
 DEF_ORDINARY("*",sLA,LISP,"");
 DEF_ORDINARY("PLUSP",sLplusp,LISP,"");
+DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,"");
+DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,"");
 
 #ifdef ANSI_COMMON_LISP
 /* New ansi types */
@@ -501,17 +506,12 @@ DEF_ORDINARY("CLASS",sLclass,LISP,"");
 DEF_ORDINARY("CONCATENATED-STREAM",sLconcatenated_stream,LISP,"");
 DEF_ORDINARY("CONDITION",sLcondition,LISP,"");
 DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,"");
-DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,"");
 DEF_ORDINARY("ECHO-STREAM",sLecho_stream,LISP,"");
 DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,"");
 DEF_ORDINARY("ERROR",sLerror,LISP,"");
 DEF_ORDINARY("EXTENDED-CHAR",sLextended_char,LISP,"");
 DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,"");
 DEF_ORDINARY("FILE-STREAM",sLfile_stream,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,"");
-DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,"");
 DEF_ORDINARY("GENERIC-FUNCTION",sLgeneric_function,LISP,"");
 DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,"");
 DEF_ORDINARY("METHOD",sLmethod,LISP,"");
--- gcl-2.6.10.orig/o/unixtime.c
+++ gcl-2.6.10/o/unixtime.c
@@ -271,7 +271,7 @@ DEFUN_NEW("CURRENT-TIMEZONE",object,fScu
   
   /* Now UTC = (local time + bias), in units of minutes, so */
   /*fprintf ( stderr, "Bias = %ld\n", tzi.Bias );*/
-  return (object)tzi.Bias/60;                                    
+  return (object)(tzi.Bias/60);
   
 #elif defined NO_SYSTEM_TIME_ZONE
   return (object)0;
--- gcl-2.6.10.orig/o/usig.c
+++ gcl-2.6.10/o/usig.c
@@ -19,6 +19,9 @@ Foundation, 675 Mass Ave, Cambridge, MA
 
 */
 
+#define _GNU_SOURCE 1
+#include <fenv.h>
+
 #ifdef __MINGW32__
 #include <sys/types.h>          /* sigset_t */
 #endif
@@ -67,7 +70,7 @@ gcl_signal(int signo, void (*handler) (/
 #endif      
       ;
     sigemptyset(&action.sa_mask);
-    sigaddset(&action.sa_mask,signo);
+    /* sigaddset(&action.sa_mask,signo); */
     sigaction(signo,&action,0);
 #else
 #ifdef HAVE_SIGVEC
@@ -131,13 +134,128 @@ unblock_sigusr_sigio(void)
 #endif
 }
 
+DEFCONST("+MC-CONTEXT-OFFSETS+",sSPmc_context_offsetsP,SI,FPE_INIT,"");
+
+#if defined(__x86_64__) || defined(__i386__)
+
+#define ASM __asm__ __volatile__
+
+DEFUN_NEW("FLD",object,fSfld,SI,1,1,NONE,OI,OO,OO,OO,(fixnum val),"") {
+  double d;
+  ASM ("fldt %1;fstpl %0" : "=m" (d): "m" (*(char *)val));
+  RETURN1(make_longfloat(d));
+}
+
+#endif
+
+DEFUN_NEW("*FIXNUM",fixnum,fSAfixnum,SI,1,1,NONE,II,OO,OO,OO,(fixnum addr),"") {
+  RETURN1(*(fixnum *)addr);
+}
+DEFUN_NEW("*FLOAT",object,fSAfloat,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") {
+  RETURN1(make_shortfloat(*(float *)addr));
+}
+DEFUN_NEW("*DOUBLE",object,fSAdouble,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") {
+  RETURN1(make_longfloat(*(double *)addr));
+}
+
+DEFUN_NEW("FEENABLEEXCEPT",fixnum,fSfeenableexcept,SI,1,1,NONE,II,OO,OO,OO,(fixnum x),"") {
+
+#ifdef HAVE_FEENABLEEXCEPT
+
+  x=feenableexcept(x);
+
+#elif defined(__x86_64__) || defined(__i386__)
+#define ASM __asm__ __volatile__
+  {
+    unsigned short s;
+    unsigned int i;
+    ASM("fnstcw %0" :: "m" (s));
+    s=(s|FE_ALL_EXCEPT)&(~x);
+    ASM("fldcw %0" : "=m" (s));
+    ASM("stmxcsr %0" :: "m" (i));
+    i=(i|(FE_ALL_EXCEPT<<7))&(~(x<<7));
+    ASM("ldmxcsr %0" : "=m" (i));
+  }    
+#endif
+
+  RETURN1(x);
+
+}
+
+DEFUN_NEW("FEDISABLEEXCEPT",fixnum,fSfedisableexcept,SI,0,0,NONE,IO,OO,OO,OO,(void),"") {
+
+  fixnum x;
+
+#ifdef HAVE_FEENABLEEXCEPT
+
+  feclearexcept(FE_ALL_EXCEPT);
+  x=fedisableexcept(FE_ALL_EXCEPT);
+
+#elif defined(__x86_64__) || defined(__i386__)
+#define ASM __asm__ __volatile__
+  {
+    unsigned int i;
+    ASM("fnclex");
+    ASM("stmxcsr %0" :: "m" (i));
+    i=(i|(FE_ALL_EXCEPT<<7));
+    ASM("ldmxcsr %0" : "=m" (i));
+    x=0;
+  }
+#endif
+
+  RETURN1(x);
+}
+
+#if defined(__x86_64__) || defined(__i386__)
+
+#define FE_TEST(x87sw_,mxcsr_,excepts_) ((x87sw_)&(excepts_))|(~((mxcsr_)>>7)&excepts_)
+
+DEFUN_NEW("FPE_CODE",fixnum,fSfpe_code,SI,2,2,NONE,II,OO,OO,OO,(fixnum x87sw,fixnum mxcsr),"") {
+
+  RETURN1(FE_TEST(x87sw,mxcsr,FE_INVALID) ? FPE_FLTINV :
+	  (FE_TEST(x87sw,mxcsr,FE_DIVBYZERO) ? FPE_FLTDIV :
+	   (FE_TEST(x87sw,mxcsr,FE_OVERFLOW) ? FPE_FLTOVF :
+	    (FE_TEST(x87sw,mxcsr,FE_UNDERFLOW) ? FPE_FLTUND :
+	     (FE_TEST(x87sw,mxcsr,FE_INEXACT) ? FPE_FLTRES : 0)))));
+}
+
+#if defined(__MINGW32__) || defined(__CYGWIN__)
+
+DEFUN_NEW("FNSTSW",fixnum,fSfnstsw,SI,0,0,NONE,II,OO,OO,OO,(void),"") {
+  unsigned short t;
+  ASM ("fnstsw %0" :: "m" (t));
+  RETURN1(t);
+}
+DEFUN_NEW("STMXCSR",fixnum,fSstmxcsr,SI,0,0,NONE,II,OO,OO,OO,(void),"") {
+  unsigned int t;
+  ASM ("stmxcsr %0" :: "m" (t));
+  RETURN1(t);
+}
+
+#endif
+#endif
+
 
 static void
-sigfpe1(void)
-{
-	gcl_signal(SIGFPE, sigfpe1);
-	FEerror("Floating-point exception.", 0);
+sigfpe3(int sig,void *i,void *v) {
+
+  unblock_signals(SIGFPE,SIGFPE);
+#ifdef __MINGW32__
+  gcl_signal(SIGFPE,sigfpe3);
+#endif
+  ifuncall3(sSfloating_point_error,FPE_CODE(i,v),FPE_ADDR(i,v),FPE_CTXT(v));
+
 }
+
+DEFCONST("+FE-LIST+",sSPfe_listP,SI,list(5,
+					 list(3,sLdivision_by_zero,make_fixnum(FPE_FLTDIV),make_fixnum(FE_DIVBYZERO)),
+					 list(3,sLfloating_point_overflow,make_fixnum(FPE_FLTOVF),make_fixnum(FE_OVERFLOW)),
+					 list(3,sLfloating_point_underflow,make_fixnum(FPE_FLTUND),make_fixnum(FE_UNDERFLOW)),
+					 list(3,sLfloating_point_inexact,make_fixnum(FPE_FLTRES),make_fixnum(FE_INEXACT)),
+					 list(3,sLfloating_point_invalid_operation,make_fixnum(FPE_FLTINV),make_fixnum(FE_INVALID))),"");
+
+DEF_ORDINARY("FLOATING-POINT-ERROR",sSfloating_point_error,SI,"");
+
 static void
 sigpipe(void)
 {
@@ -180,7 +298,7 @@ sigio(void)
 
 void
 install_default_signals(void)
-{	gcl_signal(SIGFPE, sigfpe1);
+{	gcl_signal(SIGFPE, sigfpe3);
 	gcl_signal(SIGPIPE, sigpipe);
 	gcl_signal(SIGINT, sigint);
 	gcl_signal(SIGUSR1, sigusr1);
--- gcl-2.6.10.orig/pcl/impl/gcl/gcl_pcl_impl_low.lisp
+++ gcl-2.6.10/pcl/impl/gcl/gcl_pcl_impl_low.lisp
@@ -173,7 +173,7 @@ static object set_cclosure (object resul
 
   /* If we are currently using fast linking,     */
   /* make sure to remove the link for result_cc. */
-  /*  (VFUN_NARGS=2,fSuse_fast_links_2(sLnil,result_cc));*/
+  /*  (VFUN_NARGS=2,fSuse_fast_links_2(Cnil,result_cc));*/
   fSuse_fast_links_2(Cnil,result_cc);
 
 /*  use_fast_links(3,Cnil,result_cc); */
--- gcl-2.6.10.orig/pcl/makefile
+++ gcl-2.6.10/pcl/makefile
@@ -37,8 +37,12 @@ $(addsuffix .c,$(AFILES)) $(addsuffix .d
 	for i in gazonk* ; do \
 		j=$$(echo $$i | sed 's,\..*$$,,1');k="gazonk$$(echo $$j | cut -f3 -d\_)";\
 		l=$$(echo $$i | sed 's,^.*\.,,1');\
-		cat $$i | sed   -e "s,$$j\.h,gcl_pcl_$$k.h,1" \
-				-e "s,init_.*$$j,init_gcl_pcl_$$k,g" >gcl_pcl_$$k.$$l && rm $$i; done
+		if test "$$l" = "data" ; then\
+			cp $$i gcl_pcl_$$k.$$l;\
+		else\
+			cat $$i | sed   -e "s,$$j\.h,gcl_pcl_$$k.h,1"\
+				-e "s,init_.*$$j,init_gcl_pcl_$$k,g" >gcl_pcl_$$k.$$l && rm $$i;\
+		fi; done
 
 %.o: %.c %.h %.data
 	$(CC) $(CFLAGS) -c $< -o $@
--- gcl-2.6.10.orig/unixport/init_ansi_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_ansi_gcl.lsp.in
@@ -5,6 +5,7 @@
 (make-package "ANSI-LOOP" :use '("LISP"))
 (make-package "DEFPACKAGE" :use '("LISP"))
 (make-package "TK" :use '("LISP" "SLOOP"))
+(make-package "FPE" :use '("LISP"))
 
 @LI-PCL-PACKAGE@
 
@@ -18,6 +19,7 @@
 (rename-package 'user 'common-lisp-user '(cl-user user))
 
 (in-package "SYSTEM")
+(use-package :fpe)
 
 (defvar *command-args* nil)
  ;; if ANY header or license information is printed by the
--- gcl-2.6.10.orig/unixport/init_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_gcl.lsp.in
@@ -5,8 +5,10 @@
 (make-package "ANSI-LOOP" :use '("LISP"))
 (make-package "DEFPACKAGE" :use '("LISP"))
 (make-package "TK" :use '("LISP" "SLOOP"))
+(make-package "FPE" :use '("LISP"))
 
 (in-package "SYSTEM")
+(use-package :fpe)
 
 (defvar *command-args* nil)
  ;; if ANY header or license information is printed by the
--- gcl-2.6.10.orig/unixport/init_pcl_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_pcl_gcl.lsp.in
@@ -5,6 +5,7 @@
 (make-package "ANSI-LOOP" :use '("LISP"))
 (make-package "DEFPACKAGE" :use '("LISP"))
 (make-package "TK" :use '("LISP" "SLOOP"))
+(make-package "FPE" :use '("LISP"))
 
 @LI-PCL-PACKAGE@
 
@@ -14,6 +15,7 @@
   (flet () si:*load-pathname* nil))
 
 (in-package "SYSTEM")
+(use-package :fpe)
 
 (defvar *command-args* nil)
  ;; if ANY header or license information is printed by the
--- gcl-2.6.10.orig/unixport/init_pre_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_pre_gcl.lsp.in
@@ -5,8 +5,10 @@
 (make-package "ANSI-LOOP" :use '("LISP"))
 (make-package "DEFPACKAGE" :use '("LISP"))
 (make-package "TK" :use '("LISP" "SLOOP"))
+(make-package "FPE" :use '("LISP"))
 
 (in-package "SYSTEM")
+(use-package :fpe)
 
 (defvar *command-args* nil)
  ;; if ANY header or license information is printed by the
--- gcl-2.6.10.orig/unixport/sys_ansi_gcl.c
+++ gcl-2.6.10/unixport/sys_ansi_gcl.c
@@ -51,6 +51,7 @@ gcl_init_system(object no_init)
   ar_check_init(gcl_defpackage,no_init);
   ar_check_init(gcl_make_defpackage,no_init);
   ar_check_init(gcl_sharp,no_init);
+  ar_check_init(gcl_fpe,no_init);
 
 	
   ar_check_init(gcl_cmpinline,no_init);
--- gcl-2.6.10.orig/unixport/sys_gcl.c
+++ gcl-2.6.10/unixport/sys_gcl.c
@@ -48,6 +48,7 @@ gcl_init_system(object no_init) {
   ar_check_init(gcl_defpackage,no_init);
   ar_check_init(gcl_make_defpackage,no_init);
   ar_check_init(gcl_sharp,no_init);
+  ar_check_init(gcl_fpe,no_init);
 
 	
   ar_check_init(gcl_cmpinline,no_init);
--- gcl-2.6.10.orig/unixport/sys_pcl_gcl.c
+++ gcl-2.6.10/unixport/sys_pcl_gcl.c
@@ -51,6 +51,7 @@ gcl_init_system(object no_init)
   ar_check_init(gcl_defpackage,no_init);
   ar_check_init(gcl_make_defpackage,no_init);
   ar_check_init(gcl_sharp,no_init);
+  ar_check_init(gcl_fpe,no_init);
 
 	
   ar_check_init(gcl_cmpinline,no_init);
--- gcl-2.6.10.orig/unixport/sys_pre_gcl.c
+++ gcl-2.6.10/unixport/sys_pre_gcl.c
@@ -49,6 +49,7 @@ gcl_init_system(object no_init)
   lsp_init("../lsp/gcl_defpackage.lsp");
   lsp_init("../lsp/gcl_make_defpackage.lsp");
   lsp_init("../lsp/gcl_sharp.lsp");
+  lsp_init("../lsp/gcl_fpe.lsp");
 
   lsp_init("../cmpnew/gcl_cmpinline.lsp");
   lsp_init("../cmpnew/gcl_cmputil.lsp");
