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.7+dfsga-6) unstable; urgency=low
 .
   * fast hash-equal in compiler
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.7+dfsga.orig/h/protoize.h
+++ gcl-2.6.7+dfsga/h/protoize.h
@@ -1835,3 +1835,4 @@ obj_to_mpz1(object,MP_INT *,void *);
 int
 obj_to_mpz(object,MP_INT *);
 
+void *gethash(object,object);
--- gcl-2.6.7+dfsga.orig/lsp/gcl_export.lsp
+++ gcl-2.6.7+dfsga/lsp/gcl_export.lsp
@@ -292,4 +292,8 @@ int
 float
 double
 
+define-compiler-macro
+compiler-macro
+compiler-macro-function
+
 ))
--- gcl-2.6.7+dfsga.orig/lsp/gcl_evalmacros.lsp
+++ gcl-2.6.7+dfsga/lsp/gcl_evalmacros.lsp
@@ -85,7 +85,26 @@
                ((endp forms) form))))
   )
                
-(defmacro locally (&rest body) `(let () ,@body))
+(defun parse-body-header (x &optional doc decl ctps &aux (a (car x)))
+  (cond 
+   ((unless (or doc ctps) (and (stringp a) (cdr x))) (parse-body-header (cdr x) a decl ctps))
+   ((unless ctps (when (consp a) (eq (car a) 'declare)))  (parse-body-header (cdr x) doc (cons a decl) ctps))
+   ((when (consp a) (eq (car a) 'check-type)) (parse-body-header (cdr x) doc decl (cons a ctps)))
+   (t (values doc (nreverse decl) (nreverse ctps) x))))
+
+(defmacro locally (&rest body)
+  (multiple-value-bind
+   (doc decls ctps body)
+   (parse-body-header body)
+   `(let (,@(mapcan (lambda (x &aux (z (pop x))(z (if (eq z 'type) (pop x) z)))
+		      (case z
+			    ((ftype inline notinline optimize) nil)
+			    (otherwise (mapcar (lambda (x) (list x x)) x))))
+		   (apply 'append (mapcar 'cdr decls))))
+      ,@(when doc (list doc))
+      ,@decls
+      ,@ctps
+      ,@body)))
 
 (defmacro loop (&rest body &aux (tag (gensym)))
   `(block nil (tagbody ,tag (progn ,@body) (go ,tag))))
@@ -356,3 +375,6 @@
 	     ,@(mapcar #'(lambda (x) `(proclaim ',x)) l)))
 
 (defmacro lambda ( &rest l) `(function (lambda ,@l)))
+
+(defun compiler-macro-function (name)
+  (get name 'compiler-macro-prop))
--- gcl-2.6.7+dfsga.orig/lsp/gcl_predlib.lsp
+++ gcl-2.6.7+dfsga/lsp/gcl_predlib.lsp
@@ -62,6 +62,7 @@
 
 
 ;;; Some DEFTYPE definitions.
+(deftype string-stream nil `(or (satisfies string-input-stream-p) (satisfies string-output-stream-p)))
 (deftype spice nil `(satisfies spice-p))
 (deftype fixnum ()
   `(integer ,most-negative-fixnum ,most-positive-fixnum))
--- gcl-2.6.7+dfsga.orig/lsp/gcl_iolib.lsp
+++ gcl-2.6.7+dfsga/lsp/gcl_iolib.lsp
@@ -256,3 +256,37 @@
 	  (if tp (write-char el strm) (write-byte el strm))))
     seq))
 
+(defmacro with-compilation-unit (opt &rest body)   
+  (declare (optimize (safety 2)))
+  (declare (ignore opt)) 
+  `(progn ,@body))
+
+(defvar *print-lines* nil)
+(defvar *print-miser-width* nil)
+(defvar *print-pprint-dispatch* nil)
+(defvar *print-right-margin* nil)
+
+(defmacro with-standard-io-syntax (&body body)
+  (declare (optimize (safety 2)))
+  `(let* ((*package* (find-package :cl-user))
+	  (*print-array* t)
+	  (*print-base* 10)
+	  (*print-case* :upcase)
+	  (*print-circle* nil)
+	  (*print-escape* t)
+	  (*print-gensym* t)
+	  (*print-length* nil)
+	  (*print-level* nil)
+	  (*print-lines* nil)
+	  (*print-miser-width* nil)
+	  (*print-pprint-dispatch* *print-pprint-dispatch*)
+	  (*print-pretty* nil)
+	  (*print-radix* nil)
+	  (*print-readably* t)
+	  (*print-right-margin* nil)
+	  (*read-base* 10)
+	  (*read-default-float-format* 'single-float)
+	  (*read-eval* t)
+	  (*read-suppress* nil)
+	  (*readtable* (copy-readtable (si::standard-readtable))));FIXME copy?
+     ,@body))
--- gcl-2.6.7+dfsga.orig/o/file.d
+++ gcl-2.6.7+dfsga/o/file.d
@@ -676,6 +676,13 @@ int istart, iend;
 	return(strm);
 }
 
+DEFUN_NEW("STRING-INPUT-STREAM-P",object,fSstring_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_input ? Ct : Cnil;
+}
+DEFUN_NEW("STRING-OUTPUT-STREAM-P",object,fSstring_output_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
+  return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_output ? Ct : Cnil;
+}
+
 object
 make_string_output_stream(line_length)
 int line_length;
--- gcl-2.6.7+dfsga.orig/o/structure.c
+++ gcl-2.6.7+dfsga/o/structure.c
@@ -155,8 +155,8 @@ DEFUN_NEW("STRUCTURE-SET",object,structu
 }
 #ifdef STATIC_FUNCTION_POINTERS
 object
-structure_set(object x,object name,fixnum i) {
-  return FFN(structure_set)(x,name,i);
+structure_set(object x,object name,fixnum i,object v) {
+  return FFN(structure_set)(x,name,i,v);
 }
 #endif
 
--- gcl-2.6.7+dfsga.orig/pcl/gcl_pcl_macros.lisp
+++ gcl-2.6.7+dfsga/pcl/gcl_pcl_macros.lisp
@@ -385,7 +385,7 @@
 ;(warn "****** Things will go faster if you fix define-compiler-macro")
 )
 
-#-cmu
+#-(or cmu gcl)
 (defmacro define-compiler-macro (name arglist &body body)
   #+(or lucid kcl)
   `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
--- gcl-2.6.7+dfsga.orig/clcs/gcl_clcs_kcl_cond.lisp
+++ gcl-2.6.7+dfsga/clcs/gcl_clcs_kcl_cond.lisp
@@ -107,7 +107,7 @@
     ("FEundefined_function" :undefined-function "The function ~S is undefined."
      internal-undefined-function :name)
     ("FEinvalid_function" :invalid-function "~S is invalid as a function."
-     internal-type-error) ; |obj|
+     internal-undefined-function :name) ; |obj|
     ("FEinvalid_variable" :invalid-variable "~S is an invalid variable."
      internal-program-error) ; |obj|
     ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\
--- gcl-2.6.7+dfsga.orig/cmpnew/gcl_cmpenv.lsp
+++ gcl-2.6.7+dfsga/cmpnew/gcl_cmpenv.lsp
@@ -40,6 +40,7 @@
   (setq *next-cfun* 0)
   (setq *last-label* 0)
   (setq *objects* nil)
+  (setq *hash-eq* nil)
   (setq *constants* nil)
   (setq *local-funs* nil)
   (setq *global-funs* nil)
@@ -457,13 +458,18 @@
 					  decl var)
 				   (push (cons var  'register) ts)
 				   ))
+			((:dynamic-extent dynamic-extent)
+			 (dolist (var (cdr decl))
+			   (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s."
+				  decl var)
+			   (push (cons var :dynamic-extent) ts)))
 			((fixnum character double-float short-float array atom bignum bit
 				 bit-vector common compiled-function complex cons float hash-table
 				 integer keyword list long-float nil null number package pathname
 				 random-state ratio rational readtable sequence simple-array
-				 simple-bit-vector simple-string simple-vector single-float
+				 simple-bit-vector simple-string simple-base-string simple-vector single-float
 				 standard-char stream string string-char symbol t vector
-				 signed-byte unsigned-byte :dynamic-extent)
+				 signed-byte unsigned-byte)
 			 (let ((type (if (eq stype ':dynamic-extent) stype
 				       (type-filter stype))))
 			   (when type
--- gcl-2.6.7+dfsga.orig/cmpnew/gcl_cmpwt.lsp
+++ gcl-2.6.7+dfsga/cmpnew/gcl_cmpwt.lsp
@@ -68,8 +68,21 @@
 
 (defvar *fasd-data*)
 
+(defvar *hash-eq* nil)
+(defun memoized-hash-equal (x depth);FIXME implement all this in lisp
+  (declare (fixnum depth))
+  (unless *hash-eq* (setq *hash-eq* (make-hash-table :test 'eq)))
+  (or (gethash x *hash-eq*)
+      (setf (gethash x *hash-eq*)
+	    (if (> depth 3) 0
+	      (if (typep x 'cons)
+		  (logxor (setq depth (the fixnum (1+ depth)))
+			  (memoized-hash-equal (car x) depth) 
+			  (memoized-hash-equal (cdr x) depth))
+	      (si::hash-equal x depth))))))
+
 (defun push-data-incf (x)
-  (vector-push-extend (cons (si::hash-equal x -1000) x) (data-vector))
+  (vector-push-extend (cons (memoized-hash-equal x -1000) x) (data-vector))
   (incf *next-vv*))
 
 (defun wt-data1 (expr)
@@ -92,7 +105,7 @@
 (defun verify-data-vector(vec &aux v)
   (dotimes (i (length vec))
 	   (setq v (aref vec i))
-	   (let ((has (si::hash-equal (cdr v) -1000)))
+	   (let ((has (memoized-hash-equal (cdr v) -1000)))
 	     (cond ((not (eql (car v) has))
 		    (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~%  The changed form will be the one put in the compiled file" (cdr v)))))
 	   (setf (aref vec i) (cdr v)))
@@ -100,7 +113,7 @@
   )
 
 (defun add-init (x &optional endp)
-  (let ((tem (cons (si::hash-equal x -1000) x)))
+  (let ((tem (cons (memoized-hash-equal x -1000) x)))
     (setf (data-inits)
 		    (if endp
 			(nconc (data-inits) (list tem))
