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-16) unstable; urgency=high
 .
   * 2.6.11pre test 15
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/cmpnew/gcl_cmpcall.lsp
+++ gcl-2.6.10/cmpnew/gcl_cmpcall.lsp
@@ -348,7 +348,7 @@
 			       fname leng
 			       (length argtypes))))
 	     (unless
-	      (cddr (setq link-info (assoc fname *function-links*)))
+	      (cddr (setq link-info (car (member-if (lambda (x) (and (eq fname (car x)) (stringp (cadr x)))) *function-links*))))
 	      (setq link-string
 		    (with-output-to-string
 		     (st)
@@ -359,7 +359,7 @@
 			((null v))
 			(cond ((eq (car v) '*)
 			       (setq vararg t)
-			       (princ "#?"  st));#? ensures 'first' vararg is initialized
+			       (princ (if (eq v argtypes) "#?" "#*")  st))
 			      (t 
 			       (if com  (princ "," st) (setq com t))
 			       (format st "#~a" i))))
@@ -502,6 +502,7 @@
          (unless (and (inline-possible (caddr funob))
                       (or (get (caddr funob) 'Lfun)
                           (get (caddr funob) 'Ufun)
+                          (get (caddr funob) 'proclaimed-function)
                           (assoc (caddr funob) *global-funs*)))
            (let ((temp (list 'vs (vs-push))))
                 (if *safe-compile*
--- gcl-2.6.10.orig/cmpnew/gcl_cmpopt.lsp
+++ gcl-2.6.10/cmpnew/gcl_cmpopt.lsp
@@ -352,7 +352,9 @@
    (get '/= 'inline-always))
 
 ;;1+
- (push '((t) t #.(flags ans)"one_plus(#0)")
+ ;; (push '((t) t #.(flags ans)"one_plus(#0)")
+ ;;   (get '1+ 'inline-always))
+ (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(1))")
    (get '1+ 'inline-always))
 (push '((fixnum-float) short-float #.(flags)"(double)(#0)+1")
    (get '1+ 'inline-always))
@@ -363,7 +365,9 @@
 
 
 ;;1-
- (push '((t) t #.(flags ans)"one_minus(#0)")
+ ;; (push '((t) t #.(flags ans)"one_minus(#0)")
+ ;;   (get '1- 'inline-always))
+ (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(-1))")
    (get '1- 'inline-always))
 (push '((fixnum) fixnum #.(flags)"(#0)-1")
    (get '1- 'inline-always))
--- gcl-2.6.10.orig/cmpnew/gcl_cmptop.lsp
+++ gcl-2.6.10/cmpnew/gcl_cmptop.lsp
@@ -115,6 +115,7 @@
 
 (si:putprop 'eval-when 't1eval-when 't1)
 (si:putprop 'progn 't1progn 't1)
+(si:putprop 'macrolet 't1macrolet 't1)
 (si:putprop 'defun 't1defun 't1)
 (si:putprop 'defmacro 't1defmacro 't1)
 (si:putprop 'clines 't1clines 't1)
@@ -264,7 +265,7 @@
                     (when *compile-print* (print-current-form))
                     (t1expr (cmp-macroexpand-1 form)))
                    ((get fun 'c1) (t1ordinary form))
-                   ((setq fd (macro-function fun))
+                   ((setq fd (or (macro-function fun) (cadr (assoc fun *funs*))))
 		    (let ((res
 			   (cmp-expand-macro fd fun (copy-list (cdr form)))
 			   ))
@@ -432,6 +433,13 @@
 	  (compile-flag
 	   (cmp-eval (cons 'progn (cdr args)))))))
 
+(defun t1macrolet(args &aux (*funs* *funs*))
+  (dolist (def (car args))
+    (push (list (car def)
+                (caddr (si:defmacro* (car def) (cadr def) (cddr def))))
+          *funs*))
+  (dolist (form (cdr args))
+    (t1expr form)))
 
 (defvar *compile-ordinaries* nil)
 
@@ -825,10 +833,11 @@
 (defun t3defun-vararg (fname cfun lambda-expr sp &aux  reqs *vararg-use-vs*
 			     block-p labels (deflt t) key-offset
 			     (*inline-blocks* 0) rest-var
-			     (ll (lambda-list lambda-expr)) va-start
+			     (ll (lambda-list lambda-expr))
 			     (is-var-arg (or (ll-rest ll)
 					     (ll-optionals ll)
-					     (ll-keywords-p ll))))
+					     (ll-keywords-p ll)))
+			     (first (unless (car ll) is-var-arg)))
   (dolist (v (car ll))
 	  (push (list 'cvar (next-cvar)) reqs))
  
@@ -846,9 +855,8 @@
 		(wt ",")
 		(setq tmp (concatenate 'string tmp ","))))))
     (when is-var-arg
-      (when reqs (progn (wt ",") (setq tmp (concatenate 'string tmp ","))))
-      (wt "object first,...")
-      (setq tmp (concatenate 'string tmp "object,...")))
+      (when first (wt "object first") (setq tmp (concatenate 'string tmp "object")))
+      (wt ",...") (setq tmp (concatenate 'string tmp ",...")))
     (wt ")")
     (wt-h "static object " (c-function-name "LI" cfun fname) "(" tmp ");"))
 
@@ -874,7 +882,7 @@
 	  (cons fname (car ll))))
 	(*unwind-exit* *unwind-exit*))
     (wt-nl1 "{	")
-    (when is-var-arg	  (wt-nl "va_list ap;"))
+    (when is-var-arg (wt-nl "va_list ap;"))
     (wt-nl "int narg = VFUN_NARGS;")
 
     (assign-down-vars (cadr lambda-expr) cfun
@@ -915,8 +923,8 @@
   ;  (if *vararg-use-vs* t (progn (wt-nl "Vcs[0]=Vcs[0];")))
 
   ;;; start va_list at beginning
-    (if (or (ll-optionals ll) (ll-rest ll) (ll-keywords-p ll))
-	(unless va-start (setq va-start t) (wt-nl "va_start(ap,first);")))
+    (when is-var-arg
+      (wt-nl "va_start(ap," (if first "first" (car (last reqs))) ");"))
       
   ;;; Check arguments.
     (when (and (or *safe-compile* *compiler-check-args*) (car ll))
@@ -946,19 +954,15 @@
 	    (*unwind-exit* *unwind-exit*)
 	    (*ccb-vs* *ccb-vs*))
 	(wt-nl "narg = narg - " (length reqs) ";")
-	(let ((first t))
-	  (dolist** (opt (ll-optionals ll))
-		    (push (next-label) labels)
-		    (wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ")
-		    (wt-go (car labels))
-		    (wt-nl "else {" )
-		    (unless va-start (setq va-start t) (wt-nl "va_start(ap,first);"))
-		    (c2bind-loc (car opt) (if first (list 'first-var-arg) (list 'next-var-arg)))
-		    (setq first nil)
-		    (wt "}")
-		    (when (caddr opt) (c2bind-loc (caddr opt) t)))
-	  (when (and (not first) (or (ll-rest ll) (ll-keywords ll)))
-	    (wt-nl "first=va_arg(ap,object);"))))
+	(dolist** (opt (ll-optionals ll))
+		  (push (next-label) labels)
+		  (wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ")
+		  (wt-go (car labels))
+		  (wt-nl "else {" )
+		  (c2bind-loc (car opt) (if first (list 'first-var-arg) (list 'next-var-arg)))
+		  (setq first nil)
+		  (wt "}")
+		  (when (caddr opt) (c2bind-loc (caddr opt) t))))
       (setq labels (nreverse labels))
       
       (let ((label (next-label)))
@@ -981,7 +985,6 @@
 	  (setq rest-var (cs-push))
 	  (cond ((ll-optionals ll))
 		(t (wt-nl "narg= narg - " (length (car ll)) ";")))
-	  (unless va-start (setq va-start t) (wt-nl "va_start(ap,first);"))
 	  (wt-nl "V" rest-var " = ")
 	  
 	  (let ((*rest-on-stack*
@@ -992,16 +995,15 @@
 		       (wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));"))
 		      (t (wt "make_list(narg);")))
 	      (cond (*rest-on-stack*
-		     (wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR_NEW(narg,first,ap));"
+		     (wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR_NEW(narg," (if first "first" "OBJNULL") ",ap));"
 			 ))
-		    (t  (wt "list_vector_new(narg,first,ap);"))))
+		    (t  (wt "list_vector_new(narg," (if first "first" "OBJNULL") ",ap);"))))
 	    (c2bind-loc (ll-rest ll) (list 'cvar rest-var)))))
     (when (ll-keywords-p ll)
       (cond ((ll-rest ll))
 	    ((ll-optionals ll))
 	    (t (wt-nl "narg= narg - " (length (car ll)) ";")))
       
-      (unless va-start (setq va-start t) (wt-nl "va_start(ap,first);"))
       (setq deflt (mapcar 'caddr (ll-keywords ll)))
       (let ((vkdefaults nil)
 	    (n (length (ll-keywords ll))))
@@ -1076,7 +1078,7 @@
 	      (t (wt-nl "parse_key_new_new(")))
 	(if (eql 0 *cs*)(setq *cs* 1))
 	(wt "narg," (if *vararg-use-vs* "base " (progn (setq *vcs-used* t) "Vcs "))
-	    "+" key-offset",(struct key *)(void *)&LI" cfun "key,first,ap);")
+	    "+" key-offset",(struct key *)(void *)&LI" cfun "key," (if first "first" "OBJNULL") ",ap);")
 	
 	))
     
@@ -1114,7 +1116,7 @@
     
     ;;; End va_list at function end
 
-    (when va-start (setq va-start nil) (wt-nl "va_end(ap);"))
+    (when is-var-arg (wt-nl "va_end(ap);"))
 
 ;;; Use base if defined for lint
     (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];"))
@@ -1383,12 +1385,10 @@
 
    ))
 
-
-
 (defun t1ordinary (form &aux tem )
   (setq *non-package-operation* t)
   ;; check for top level functions
-  (cond (*compile-ordinaries*
+  (cond ((or *compile-ordinaries* (when (listp form) (member (car form) '(let let* flet labels))))
 	 (maybe-eval nil form)
 	 (let ((gen (gensym "progn 'compile")))
 	   (proclaim `(function ,gen nil t))
@@ -1789,3 +1789,25 @@
 
 
 
+(defun fset-fn-name (form)
+  (when (eq (car form) 'location)
+    (when (listp (caddr form))
+      (when (eq 'vv (caaddr form))
+	(let ((s (car (rassoc (cadr (caddr form)) *objects* :key 'car))))
+	  (when s `(defun ,s)))))))
+
+(defun c1fset (args)
+  (let* ((info (make-info))
+	 (fn (c1expr* (pop args) info))
+	 (*current-form* (or (fset-fn-name fn) *current-form*))
+	 (lam (c1expr* (car args) info)))
+    (when *record-call-info* 
+      (when (info-referred-array (cadr lam))
+	(set-closure)))
+    (list 'si::fset info fn lam)))
+
+(defun c2fset (&rest args)
+  (c2call-global 'si::fset args nil t))
+
+(si::putprop 'si::fset 'c1fset  'c1)
+(si::putprop 'si::fset 'c2fset  'c2)
--- gcl-2.6.10.orig/cmpnew/gcl_cmpvar.lsp
+++ gcl-2.6.10/cmpnew/gcl_cmpvar.lsp
@@ -167,7 +167,7 @@
           (let ((type (var-type var)))
                (declare (object type))
                (cond ((type>= 'fixnum type) 'FIXNUM)
-		     ((type>= 'integer type) 'INTEGER)
+;		     ((type>= 'integer type) 'INTEGER)
                      ((type>= 'CHARACTER type) 'CHARACTER)
                      ((type>= 'long-float type) 'LONG-FLOAT)
                      ((type>= 'short-float type) 'SHORT-FLOAT)
--- gcl-2.6.10.orig/cmpnew/gcl_collectfn.lsp
+++ gcl-2.6.10/cmpnew/gcl_collectfn.lsp
@@ -188,6 +188,8 @@
   (sloop::sloop for (ke val) in-table *call-table*
 	 do (progn ke) (setf (fn-no-emit val) 1)))
 
+(defun set-closure ()
+  (setf (fn-def (current-fn)) 'closure))
   
 (defun make-proclaims ( &optional (st *standard-output*)
 				  &aux (ht (make-hash-table :test 'equal))
@@ -201,15 +203,18 @@
   (sloop::sloop with ret with at
 		for (ke val) in-table *call-table* 
 		do
-		(cond ((or (eql 1 (fn-no-emit val))
+		(cond ((eq (fn-def val) 'closure)
+		       (push ke (gethash 'proclaimed-closure ht)))
+		      ((or (eql 1 (fn-no-emit val))
 			   (not (eq (fn-def val) 'defun))))
 		      (t (setq ret (get-value-type ke))
 			 (setq at (fn-arg-types val))
-			 (push ke   (gethash (list at ret)  ht)))))
+			 (push ke   (gethash (list at ret) ht)))))
   (sloop::sloop for (at fns) in-table ht
 		do 
 		(print
-		 `(proclaim '(ftype (function ,@ at) ,@ fns))
+		 (if (symbolp at) `(mapc (lambda (x) (setf (get x 'compiler::proclaimed-closure) t)) '(,@fns))
+		   `(proclaim '(ftype (function ,@ at) ,@ fns)))
 		 st)))
 		 
 (defun setup-sys-proclaims()
--- gcl-2.6.10.orig/h/compdefs.h
+++ gcl-2.6.10/h/compdefs.h
@@ -109,11 +109,5 @@ ON_STACK_MAKE_LIST
 SAFE_CDR(x)
 Scons
 EQ(x,y)
-IDECL(x,y,z)
-SETQ_IO(x,y,z,w)
-SETQ_II(x,y,z,w)
-ISETQ_FIX(x,y,z)
 aset
-save_avma
-restore_avma
 stp_ordinary
--- gcl-2.6.10.orig/h/compprotos.h
+++ gcl-2.6.10/h/compprotos.h
@@ -153,15 +153,8 @@ object on_stack_cons(object,object);
 object on_stack_list(int,...);
 object on_stack_list_vector_new(int,object,va_list);
 object on_stack_make_list(int);
-int obj_to_mpz(object,MP_INT *);
-int obj_to_mpz1(object,MP_INT *,void *);
-int mpz_to_mpz(MP_INT *,MP_INT *);
-int mpz_to_mpz1(MP_INT *,MP_INT *,void *);
-void isetq_fix(MP_INT *,int);
-MP_INT * otoi(object);
 object read_byte1(object,object);
 int not_a_variable(object);
-object make_integer(MP_INT *);
 object cmod(object);
 object ctimes(object,object);
 object cdifference(object,object);
@@ -179,3 +172,5 @@ int feof(void *);
 int getc(void *);
 int putc(int,void *);
 #endif
+void vfun_wrong_number_of_args(object);
+void ihs_overflow (void);
--- gcl-2.6.10.orig/h/defun.h
+++ gcl-2.6.10/h/defun.h
@@ -8,10 +8,14 @@
 EXTER ret fname ();
 
 #define DEFUN_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) EXTER ret fname args;
+#define DEFUNM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) EXTER ret fname args;
 
 #define DEFUNO_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \
 EXTER ret fname args;
 
+#define DEFUNOM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \
+EXTER ret fname args;
+
 
 #define DO_INIT(x)   
 #define DEFUNL DEFUN
--- gcl-2.6.10.orig/h/make-init.h
+++ gcl-2.6.10/h/make-init.h
@@ -40,6 +40,14 @@
 #define DEFUNO_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \
   {extern void Mjoin(fname,_init)();Mjoin(fname,_init)();}
 
+#undef DEFUNM_NEW
+#define DEFUNM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) \
+  {extern void Mjoin(fname,_init)(); Mjoin(fname,_init)();}
+
+#undef DEFUNOM_NEW
+#define DEFUNOM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \
+  {extern void Mjoin(fname,_init)();Mjoin(fname,_init)();}
+
 #undef DEFCOMP
 #define DEFCOMP(type, fun,doc) Ineed_in_image(fun);
 
--- gcl-2.6.10.orig/h/notcomp.h
+++ gcl-2.6.10/h/notcomp.h
@@ -82,6 +82,11 @@ void old(void) \
    pack == LISP ? LISP_makefun(string,fname,argd) : \
    error("Bad pack variable in MAKEFUN\n"))
 
+#define MAKEFUNM(pack,string,fname,argd) \
+  (pack == SI ? SI_makefunm(string,fname,argd) : \
+   pack == LISP ? LISP_makefunm(string,fname,argd) : \
+   error("Bad pack variable in MAKEFUN\n"))
+
 #define SI 0
 #define LISP 1
 
@@ -119,6 +124,12 @@ void Mjoin(fname,_init) () {\
 }\
 STATD ret FFN(fname) args
 
+#define DEFUNM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) STATD ret FFN(fname) args;\
+void Mjoin(fname,_init) () {\
+   MAKEFUNM(pack,string,(ret (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));\
+}\
+STATD ret FFN(fname) args
+
 /* eg.
    A function taking from 2 to 8 args
    returning object the first args is object, the next 6 int, and last defaults to object.
@@ -134,6 +145,16 @@ void Mjoin(fname,_init) () {\
 }\
 LFD(old)(void) \
 {   Iinvoke_c_function_from_value_stack((object (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56))); \
+    return;} \
+STATD  ret FFN(fname) args
+
+#define DEFUNOM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \
+STATD  ret FFN(fname) args; \
+void Mjoin(fname,_init) () {\
+   MAKEFUNM(pack,string,(ret (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));\
+}\
+LFD(old)(void) \
+{   Iinvoke_c_function_from_value_stack((object (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56))); \
     return;} \
 STATD  ret FFN(fname) args
 
--- gcl-2.6.10.orig/h/object.h
+++ gcl-2.6.10/h/object.h
@@ -427,6 +427,12 @@ object make_si_sfun();
   new=Xxvl; \
   if (n >= 65) FEerror("va_list too long",0); \
   for (i=0 ; i < (n); i++) new[i]=i ? va_arg(vl,object) : fst;}
+#define COERCE_VA_LIST_KR_NEW(new,fst,vl,n) \
+ object Xxvl[65]; \
+ {int i; \
+  new=Xxvl; \
+  if (n >= 65) FEerror("va_list too long",0); \
+  for (i=0 ; i < (n); i++) new[i]=i||fst==OBJNULL ? va_arg(vl,object) : fst;}
 #endif
 
 
--- gcl-2.6.10.orig/h/protoize.h
+++ gcl-2.6.10/h/protoize.h
@@ -33,7 +33,7 @@
 /* array.c::OF */ extern object fSmake_vector1_1 (fixnum n,fixnum elt_type,object staticp); 
 /* array.c:738:OF */ extern void adjust_displaced (object x, long diff); /* (x, diff) object x; int diff; */
 /* array.c:790:OF */ extern void gset (void *p1, void *val, int n, int typ); /* (p1, val, n, typ) char *p1; char *val; int n; int typ; */
-/* array.c:831:OF */ extern object fScopy_array_portion (object x, object y,fixnum i1,fixnum i2, object n1); /* (x, y, i1, i2, n1) object x; object y; int i1; int i2; int n1; */
+/* array.c:831:OF */ extern object fScopy_array_portion (object x, object y,object i1,object i2, object n1); /* (x, y, i1, i2, n1) object x; object y; int i1; int i2; int n1; */
 /* array.c:879:OF */ extern void array_allocself (object x, int staticp, object dflt); /* (x, staticp, dflt) object x; int staticp; object dflt; */
 /* array.c:920:OF */ extern void siLfill_pointer_set (void); /* () */
 /* array.c:923:OF */ extern object fSfill_pointer_set (object x,fixnum i); /* (x, i) object x; int i; */
@@ -52,7 +52,6 @@
 /* array.c:1023:OF */ extern object fLarray_dimension (object x,fixnum i); /* (x, i) object x; int i; */
 /* array.c:1090:OF */ extern void siLreplace_array (void); /* () */
 /* array.c:1093:OF */ extern object fSreplace_array (object old, object new); /* (old, new) object old; object new; */
-/* array.c:1132:OF */ extern object fLarray_total_size (object x); /* (x) object x; */
 /* array.c:1140:OF */ extern object fSaset_by_cursor (object array, object val, object cursor); /* (array, val, cursor) object array; object val; object cursor; */
 /* array.c:1160:OF */ extern void gcl_init_array_function (void); /* () */
 /* assignment.c:62:OF */ extern void setq (object sym, object val); /* (sym, val) object sym; object val; */
@@ -312,6 +311,8 @@ typedef void (*funcvoid)(void);
 /* /\* makefun.c:131:OF *\/ extern void LISP_makefun (char *strg, object (*fn) (/\* ??? *\/), unsigned int argd); /\* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; *\/ */
 /* makefun.c:122:OF */ extern void SI_makefun (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */
 /* makefun.c:131:OF */ extern void LISP_makefun (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */
+/* makefun.c:122:OF */ extern void SI_makefunm (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */
+/* makefun.c:131:OF */ extern void LISP_makefunm (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */
 /* makefun.c:167:OF */ extern object fSinvoke (object x); /* (x) object x; */
 /* mapfun.c:324:OF */ extern void gcl_init_mapfun (void); /* () */
 /* multival.c:32:OF */ extern void Lvalues (void); /* () */
--- gcl-2.6.10.orig/lsp/gcl_arraylib.lsp
+++ gcl-2.6.10/lsp/gcl_arraylib.lsp
@@ -42,26 +42,14 @@
 
 (proclaim '(optimize (safety 2) (space 3)))
 
+(defvar *baet-hash* (make-hash-table :test 'equal))
 (defun best-array-element-type (type)
-  (cond ((or (eql t type) (null type))
-	 t)
-	((memq type '(bit unsigned-char signed-char
-				    unsigned-short
-				    signed-short fixnum))
-	       type)
-	((subtypep type 'fixnum)
-	 (dolist (v '(bit unsigned-char signed-char
-				    unsigned-short
-				    signed-short)
-		    'fixnum)
-		 (cond ((subtypep type v)
-			(return v)))))
-	((eql type 'character) 'string-char)
-	(t (or (dolist (v '(string-char bit short-float
-				    long-float))
-		   (cond ((subtypep type v)
-			  (return v))))
-	       t))))
+  (or (gethash type *baet-hash*)
+      (setf (gethash type *baet-hash*)
+	    (if type
+		(car (member type '(string-char bit signed-char unsigned-char signed-short unsigned-short
+					fixnum short-float long-float t)
+			     :test 'subtypep)) t)))))
 	 
 (defun upgraded-array-element-type (type &optional environment)
   (declare (ignore environment))
--- gcl-2.6.10.orig/lsp/gcl_predlib.lsp
+++ gcl-2.6.10/lsp/gcl_predlib.lsp
@@ -132,6 +132,17 @@
           (random-state . random-state-p)
           (structure . si:structurep)
           (function . functionp)
+	  (vector . vectorp)
+	  (bit-vector . bit-vector-p)
+	  (array . arrayp)
+	  (string . stringp)
+	  (float . floatp)
+	  (complex . complexp)
+	  (real . realp)
+	  (simple-array . simple-array-p)
+	  (simple-vector . simple-vector-p)
+	  (simple-string . simple-string-p)
+	  (simple-bit-vector . simple-bit-vector-p)
           (compiled-function . compiled-function-p)
           (common . commonp)
           )
@@ -140,32 +151,41 @@
   (si:putprop (caar l) (cdar l) 'type-predicate)
   (si:putprop (cdar l) (caar l) 'predicate-type))
 
-(defun class-of (object)
-  (declare (ignore object))
-  nil)
-(defun classp (object)
-  (declare (ignore object))
-  nil)
-(defun class-precedence-list (object)
-  (declare (ignore object))
-  nil)
-(defun find-class (object)
-  (declare (ignore object))
-  nil)
+
+(eval-when
+ (compile eval)
+ (defmacro clh nil
+  `(progn
+     ,@(mapcar (lambda (x &aux (f (when (equal x "FIND-CLASS") `(&optional ep))) (z (intern (string-concatenate "SI-" x))))
+		 `(defun ,z (o ,@f &aux e (x (find-symbol ,x :user)))
+		    (cond ((and x (fboundp x) (fboundp (find-symbol "CLASSP" :user)))
+			   (prog1 (funcall x o ,@(cdr f))
+			     (fset ',z (symbol-function x))))
+			  ((setq e (get ',z 'early)) (values (funcall e o ,@(cdr f)))))))
+	       '("CLASSP" "CLASS-PRECEDENCE-LIST" "FIND-CLASS" "CLASS-OF" "CLASS-NAME")))))
+(clh)
+
+;; (defun class-of (object)
+;;   (declare (ignore object))
+;;   nil)
+;; (defun classp (object)
+;;   (declare (ignore object))
+;;   nil)
+;; (defun class-precedence-list (object)
+;;   (declare (ignore object))
+;;   nil)
+;; (defun find-class (object)
+;;   (declare (ignore object))
+;;   nil)
 
 ;;; TYPEP predicate.
 ;;; FIXME --optimize with most likely cases first
 (defun typep (object type &optional env &aux tp i tem)
   (declare (ignore env))
-  (when (classp type)
-    (return-from typep (if (member type (class-precedence-list (funcall 'class-of object))) t nil)))
   (if (atom type)
       (setq tp type i nil)
       (setq tp (car type) i (cdr type)))
   (if (eq tp 'structure-object) (setq tp 'structure))
-  (unless i 
-    (let ((f (get tp 'type-predicate)))
-      (when f (return-from typep (funcall f object)))))
   (case tp
     (member (member object i))
     (not (not (typep object (car i))))
@@ -252,11 +272,14 @@
 		  (match-dimensions (array-dimensions object) (cadr i))
 		(eql (array-rank object) (cadr i))))))
     (t 
-     (cond ((setq tem (get tp 'si::s-data))
+     (cond ((si-classp tp)
+	    (if (member type (si-class-precedence-list (si-class-of object))) t nil))
+	   ((setq tem (if (structurep tp) tp (get tp 'si::s-data)))
 	    (structure-subtype-p object tem))
+	   ((setq tem (get tp 'type-predicate))
+	    (funcall tem object))
            ((setq tem (get tp 'deftype-definition))
-	      (typep object
-		     (apply tem i)))))))
+	      (typep object (apply tem i)))))))
 
 
 ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
@@ -270,9 +293,9 @@
     (if (atom type)
         (setq tp type i nil)
         (setq tp (car type) i (cdr type)))
-    (if (get tp 'deftype-definition)
-        (setq type (apply (get tp 'deftype-definition) i))
-        (return-from normalize-type (if (atom type) (list type) type)))))
+    (cond ((si-classp tp) (return-from normalize-type (list (si-class-name tp))))
+	  ((get tp 'deftype-definition) (setq type (apply (get tp 'deftype-definition) i)))
+	  ((return-from normalize-type (if (atom type) (list type) type))))))
 
 
 ;;; KNOWN-TYPE-P answers if the given type is a known base type.
@@ -311,14 +334,14 @@
 ;;; SUBTYPEP predicate.
 (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)
   (declare (ignore env))
-  (let ((c1 (classp type1)) (c2 (classp type2)))
+  (let ((c1 (si-classp type1)) (c2 (si-classp type2)))
     (when (and c1 c2)
       (return-from subtypep 
-		   (if (member type2 (class-precedence-list type1))
+		   (if (member type2 (si-class-precedence-list type1))
 		       (values t t) (values nil t))))
     (when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object)))
       (return-from subtypep 
-		   (if (member (find-class type2) (class-precedence-list type1))
+		   (if (member (si-find-class type2) (si-class-precedence-list type1))
 		       (values t t) (values nil t))))
     (when (or c1 c2)
       (return-from subtypep (values nil t))))
@@ -726,43 +749,29 @@
 (deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high))
 (deftype double-float (&optional (low '*) (high '*)) `(long-float ,low ,high))
 
-(defun coerce (object type &aux (ot type))
-  (when (typep object type)
-        ;; Just return as it is.
-        (return-from coerce object))
-;  (when (classp type)
-;    (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S~%" object type))
-  (setq type (normalize-type type))
-  (case (car type)
-    (list
-     (do ((l nil (cons (aref object i) l))
-          (i (1- (length object)) (1- i)))
-         ((< i 0) l)
-	 (declare (fixnum i))))
-    ((array simple-array)
-     (unless (or (endp (cdr type))
-                 (endp (cddr type))
-                 (eq (caddr type) '*)
-                 (endp (cdr (caddr type))))
-             (error "Cannot coerce to an multi-dimensional array."))
-     (do ((seq (make-sequence ot (length object)))
-          (i 0 (1+ i))
-	  (lo (listp object))
-	  (o object (if lo (cdr o) o))
-          (l (length object)))
-         ((>= i l) seq)
-	 (declare (fixnum i l))
-	 (setf (aref seq i) (if lo (car o) (aref o i)))))
-    (character (character object))
-    (float (float object))
-    ((short-float) (float object 0.0S0))
-    ((single-float double-float long-float) (float object 0.0L0))
-    (complex
-     (if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*))
-         (complex (realpart object) (imagpart object))
-         (complex (coerce (realpart object) (cadr type))
-                  (coerce (imagpart object) (cadr type)))))
-    (t (error "Cannot coerce ~S to ~S." object type))))
+
+#.`(defun coerce (object type &aux (l (listp type))(ctp (if l (car type) type))(i (when l (cdr type))))
+     (when 
+	 (case type
+	   ,@(mapcar (lambda (x) `(,x (,(get x 'type-predicate) object))) 
+	   	     '(string list vector bit-vector array character float cons))
+	   (otherwise (typep object type)))
+       (return-from coerce object))
+     (case ctp
+       	((string list vector bit-vector simple-string simple-vector simple-bit-vector array cons null member) 
+	 (replace (make-sequence type (length object)) object))
+	(function (symbol-function object))
+	(character (character object))
+	(float (float object))
+	((short-float) (float object 0.0S0))
+	((single-float double-float long-float) (float object 0.0L0))
+	(complex
+	 (let* ((re (realpart object))(im (imagpart object))
+		(rt (car i))(rt (unless (eq rt '*) rt))
+		(re (if rt (coerce re rt) re))(im (if rt (coerce im rt) im)))
+	   (complex re im)))
+       (t (cond ((let ((nt (normalize-type type))) (unless (eq nt type) (coerce object nt))))
+		(t (error "Cannot coerce ~S to ~S." object type))))))
 
 ;; set by unixport/init_kcl.lsp
 ;; warn if a file was comopiled in another version
--- gcl-2.6.10.orig/lsp/gcl_top.lsp
+++ gcl-2.6.10/lsp/gcl_top.lsp
@@ -95,7 +95,7 @@
 	(cond
 	 (*multiply-stacks* (setq *multiply-stacks* nil))
 	 ((probe-file "init.lsp") (load "init.lsp"))))
-      (and (functionp *top-level-hook*)(funcall   *top-level-hook*)))
+      (and (or (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/sys-proclaim.lisp
+++ gcl-2.6.10/lsp/sys-proclaim.lisp
@@ -13,7 +13,7 @@
 (PROCLAIM
     '(FTYPE (FUNCTION () T) ALLOC-SPICE))
 (PROCLAIM
-    '(FTYPE (FUNCTION (T) T) PATCH-SHARP))
+    '(FTYPE (FUNCTION (T) T) SI-CLASS-OF PATCH-SHARP))
 (PROCLAIM
     '(FTYPE (FUNCTION (*) T) MAKE-CONTEXT))
 (PROCLAIM
@@ -224,16 +224,16 @@
             ANSI-LOOP::LOOP-EMIT-FINAL-VALUE
             ANSI-LOOP::LOOP-MINIMAX-OPERATIONS
             ANSI-LOOP::LOOP-MINIMAX-INFINITY-DATA
-            ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS CLASSP
+            ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS
             ANSI-LOOP::LOOP-UNIVERSE-ITERATION-KEYWORDS
-            CLASS-PRECEDENCE-LIST ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS
-            CLASS-OF ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS
+            ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS
+            ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS
             ANSI-LOOP::LOOP-UNIVERSE-TYPE-SYMBOLS
             ANSI-LOOP::LOOP-UNIVERSE-TYPE-KEYWORDS INFO-GET-FILE
             ANSI-LOOP::LOOP-UNIVERSE-ANSI BEST-ARRAY-ELEMENT-TYPE
             SIMPLE-ARRAY-P BYTE-POSITION
             ANSI-LOOP::LOOP-UNIVERSE-IMPLICIT-FOR-REQUIRED IHS-VISIBLE
-            FIND-CLASS BYTE-SIZE SLOOP::AVERAGING-SLOOP-MACRO
+            BYTE-SIZE SLOOP::AVERAGING-SLOOP-MACRO
             NORMALIZE-TYPE SIGNUM SETUP-INFO KNOWN-TYPE-P SINH
             ANSI-LOOP::LOOP-COLLECTOR-CLASS SLOOP::REPEAT-SLOOP-MACRO
             CIS ANSI-LOOP::LOOP-COLLECTOR-HISTORY PRINT-IHS
@@ -254,7 +254,7 @@
             ANSI-LOOP::LOOP-CONSTANT-FOLD-IF-POSSIBLE BAD-SEQ-LIMIT)) 
 (PROCLAIM '(FTYPE (FUNCTION (STRING *) *) GET-COMMAND-ARG)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T *) T) FILE-SEARCH WARN DELETE-DUPLICATES
+    '(FTYPE (FUNCTION (T *) T) SI-FIND-CLASS FILE-SEARCH WARN DELETE-DUPLICATES
             NTH-STACK-FRAME UPGRADED-ARRAY-ELEMENT-TYPE
             SLOOP::LOOP-ADD-TEMPS SLOOP::ADD-FROM-DATA MAKE-ARRAY
             ANSI-LOOP::LOOP-WARN BIT INFO-SEARCH LIST-MATCHES
--- gcl-2.6.10.orig/o/alloc.c
+++ gcl-2.6.10/o/alloc.c
@@ -786,7 +786,7 @@ inline object on_stack_cons(object x, ob
 }
 
 
-DEFUN_NEW("ALLOCATED",object,fSallocated,SI,1,1,NONE,OO,OO,OO,OO,(object typ),"")
+DEFUNM_NEW("ALLOCATED",object,fSallocated,SI,1,1,NONE,OO,OO,OO,OO,(object typ),"")
 { struct typemanager *tm=(&tm_table[t_from_type(typ)]);
   tm = & tm_table[tm->tm_type];
   if (tm->tm_type == t_relocatable)
@@ -1481,19 +1481,19 @@ DEFUN_NEW("GPROF-QUIT",object,fSgprof_qu
 
 #endif
 
-DEFUN_NEW("SET-STARTING-HOLE-DIVISOR",fixnum,fSset_starting_hole_divisor,SI,1,1,NONE,II,OO,OO,OO,(fixnum div),"") {
+DEFUN_NEW("SET-STARTING-HOLE-DIVISOR",object,fSset_starting_hole_divisor,SI,1,1,NONE,II,OO,OO,OO,(fixnum div),"") {
   if (div>0 && div <100)
     starting_hole_div=div;
-  return starting_hole_div;
+  return (object)starting_hole_div;
 }
   
-DEFUN_NEW("SET-STARTING-RELBLOCK-HEAP-MULTIPLE",fixnum,fSset_starting_relb_heap_multiple,SI,1,1,NONE,II,OO,OO,OO,(fixnum mult),"") {
+DEFUN_NEW("SET-STARTING-RELBLOCK-HEAP-MULTIPLE",object,fSset_starting_relb_heap_multiple,SI,1,1,NONE,II,OO,OO,OO,(fixnum mult),"") {
   if (mult>=0)
     starting_relb_heap_mult=mult;
-  return starting_relb_heap_mult;
+  return (object)starting_relb_heap_mult;
 }
   
-DEFUN_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,OI,IO,OO,OO,(fixnum npages,...),"") {
 
   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
@@ -63,9 +63,10 @@ extern short aet_sizes[];
 #define N_FIXNUM_ARGS 6
 
 DEFUNO_NEW("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT,
-       NONE, OO, II, II, II,void,Laref,(object x,fixnum i, ...),"")
+       NONE, OO, OO, OO, OO,void,Laref,(object x,object oi, ...),"")
 { int n = VFUN_NARGS;
   int i1;
+  fixnum i=fix(oi);
   va_list ap;
   if (type_of(x) == t_array)
     {int m ;
@@ -75,7 +76,7 @@ DEFUNO_NEW("AREF", object, fLaref, LISP,
        FEerror(" ~a has wrong rank",1,x);
      if (rank == 1) return fLrow_major_aref(x,i);
      if (rank == 0) return fLrow_major_aref(x,0);
-     va_start(ap,i);
+     va_start(ap,oi);
      m = 0;
      k = i;
      /* index into 1 dimensional array */
@@ -90,7 +91,7 @@ DEFUNO_NEW("AREF", object, fLaref, LISP,
 	 if (m <= rank)
 	   { i1 = i1 * x->a.a_dims[m];
 	     if (m < N_FIXNUM_ARGS)
-	       { k = va_arg(ap,fixnum);}
+	       { k = fixint(va_arg(ap,object));}
 	     else {object x = va_arg(ap,object);
 		   check_type(x,t_fixnum);
 		   k = Mfix(x);}
@@ -874,12 +875,13 @@ gset(void *p1, void *val, int n, int typ
    */
 
 DEFUN_NEW("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4,
-      5,NONE,OO,OI,IO,OO,(object x,object y,fixnum i1,fixnum i2,object n1o),
+      5,NONE,OO,OO,OO,OO,(object x,object y,object oi1,object oi2,object n1o),
    "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \
 elements if N1 is supplied otherwise, doing the length of X - I1 \
 elements.  If the types of the arrays are not the same, this has \
 implementation dependent results.")
-{ enum aelttype typ1=Iarray_element_type(x);
+{ fixnum i1=fix(oi1),i2=fix(oi2);
+  enum aelttype typ1=Iarray_element_type(x);
   enum aelttype typ2=Iarray_element_type(y);
   int n1=fix(n1o),nc;
   if (VFUN_NARGS==4)
@@ -1158,10 +1160,9 @@ DEFUNO_NEW("REPLACE-ARRAY",object,fSrepl
   return old;
 }
 
-DEFUN_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1,
-       NONE,OO,OO,OO,OO,(object x),"")
+DEFUN_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1,NONE,IO,OO,OO,OO,(object x),"")
 { x = IisArray(x);
-  return make_fixnum(x->a.a_dim);
+  return (object)(fixnum)x->a.a_dim;
 }
 
 
--- gcl-2.6.10.orig/o/bind.c
+++ gcl-2.6.10/o/bind.c
@@ -913,7 +913,7 @@ object Cstd_key_defaults[15]={Cnil,Cnil,
 int
 parse_key_new_new(int n, object *base, struct key *keys, object first, va_list ap)
 {object *new;
- COERCE_VA_LIST_NEW(new,first,ap,n);
+ COERCE_VA_LIST_KR_NEW(new,first,ap,n);
 
  /* from here down identical to parse_key_rest */
  new = new + n ;
@@ -1015,7 +1015,7 @@ parse_key_new_new(int n, object *base, s
 int
 parse_key_rest_new(object rest, int n, object *base, struct key *keys, object first,va_list ap)
 {object *new;
- COERCE_VA_LIST_NEW(new,first,ap,n);
+ COERCE_VA_LIST_KR_NEW(new,first,ap,n);
 
  /* copy the rest arg */
  {object *p = new;
--- gcl-2.6.10.orig/o/catch.c
+++ gcl-2.6.10/o/catch.c
@@ -47,7 +47,7 @@ FFN(Fcatch)(VOL object args)
 	frs_pop();
 }
 
-DEFUN_NEW("ERROR-SET",object,fSerror_set,SI
+DEFUNM_NEW("ERROR-SET",object,fSerror_set,SI
 	   ,1,1,NONE,OO,OO,OO,OO,(volatile object x0),
        "Evaluates the FORM in the null environment.  If the evaluation \
 of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first \
--- gcl-2.6.10.orig/o/cfun.c
+++ gcl-2.6.10/o/cfun.c
@@ -91,6 +91,7 @@ make_cclosure_new(void (*self)(), object
 	cc->cc.cc_env = env;
 	cc->cc.cc_data = data;
 	cc->cc.cc_turbo = NULL;
+	turbo_closure(cc);
 	return(cc);
 }
 
@@ -331,7 +332,7 @@ turbo_closure(object fun)
   object l,*block;
   int n;
 
-  if(fun->cc.cc_turbo==NULL)
+  if(1)/*(fun->cc.cc_turbo==NULL)*/
     {BEGIN_NO_INTERRUPT;
      for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr);
     {
--- gcl-2.6.10.orig/o/error.c
+++ gcl-2.6.10/o/error.c
@@ -615,7 +615,7 @@ DEFUN_NEW("SCH-FRS-BASE",object,fSsch_fr
 	RETURN1(x0);
 }
 
-DEFUN_NEW("INTERNAL-SUPER-GO",object,fSinternal_super_go,SI
+DEFUNM_NEW("INTERNAL-SUPER-GO",object,fSinternal_super_go,SI
        ,3,3,NONE,OO,OO,OO,OO,(object tag,object x1,object x2),"")
 {
 	frame_ptr fr;
--- gcl-2.6.10.orig/o/eval.c
+++ gcl-2.6.10/o/eval.c
@@ -1107,7 +1107,7 @@ call_applyhook(object fun)
 }
 
 
-DEFUNO_NEW("FUNCALL",object,fLfuncall,LISP
+DEFUNOM_NEW("FUNCALL",object,fLfuncall,LISP
        ,1,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lfuncall,(object fun,...),"")
 { va_list ap;
   object *new;
@@ -1120,7 +1120,7 @@ DEFUNO_NEW("FUNCALL",object,fLfuncall,LI
 }
 
 
-DEFUNO_NEW("APPLY",object,fLapply,LISP
+DEFUNOM_NEW("APPLY",object,fLapply,LISP
        ,2,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lapply,(object fun,...),"")
 {	int m,n=VFUN_NARGS;
 	object list;
@@ -1144,7 +1144,7 @@ DEFUNO_NEW("APPLY",object,fLapply,LISP
       }
 	
 
-DEFUNO_NEW("EVAL",object,fLeval,LISP
+DEFUNOM_NEW("EVAL",object,fLeval,LISP
        ,1,1,NONE,OO,OO,OO,OO,void,Leval,(object x0),"")
 {
 	object *lex = lex_env;
--- gcl-2.6.10.orig/o/fasdump.c
+++ gcl-2.6.10/o/fasdump.c
@@ -512,8 +512,9 @@ do_hash(object obj, int dot)
    }
  
 static void write_fasd(object obj);
-static object
-FFN(write_fasd_top)(object obj, object x)
+DEFUN_NEW("WRITE-FASD-TOP",object,fSwrite_fasd_top,SI,2,2,NONE,OO,OO,OO,OO,(object obj, object x),"")
+/* static object */
+/* FFN(write_fasd_top)(object obj, object x) */
 {struct fasd *fd = (struct fasd *) x->v.v_self;
   if (fd->direction == sKoutput)
     SETUP_FASD_IN(fd);
@@ -534,8 +535,9 @@ FFN(write_fasd_top)(object obj, object x
 #define MAYBE_PATCH(result) \
   if (needs_patching)  result =fasd_patch_sharp(result,0)
 
-static object
-FFN(read_fasd_top)(object x)
+DEFUN_NEW("READ-FASD-TOP",object,fSread_fasd_top,SI,1,1,NONE,OO,OO,OO,OO,(object x),"")
+/* static object */
+/* FFN(read_fasd_top)(object x) */
 {  struct fasd *fd = (struct fasd *)  x->v.v_self;
    VOL int e=0;
    object result;
@@ -580,8 +582,9 @@ object sLeq;
 object sSPinit;
 void Lmake_hash_table();
 
-static object
-FFN(open_fasd)(object stream, object direction, object eof, object tabl)
+DEFUN_NEW("OPEN-FASD",object,fSopen_fasd,SI,4,4,NONE,OO,OO,OO,OO,(object stream, object direction, object eof, object tabl),"")
+/* static object */
+/* FFN(open_fasd)(object stream, object direction, object eof, object tabl) */
 {  object str=Cnil;
    object result;
    if(direction==sKinput)
@@ -631,8 +634,9 @@ FFN(open_fasd)(object stream, object dir
     return result;
   }}
 
-static object
-FFN(close_fasd)(object ar)
+DEFUN_NEW("CLOSE-FASD",object,fSclose_fasd,SI,1,1,NONE,OO,OO,OO,OO,(object ar),"")
+/* static object */
+/* FFN(close_fasd)(object ar) */
 {  struct fasd *fd= (struct fasd *)(ar->v.v_self);
    check_type(ar,t_vector);
    if (type_of(fd->table)==t_vector)
@@ -1054,8 +1058,9 @@ find_sharing(object x)
 	return;
 }
 
-static object
-FFN(find_sharing_top)(object x, object table)
+DEFUN_NEW("FIND-SHARING-TOP",object,fSfind_sharing_top,SI,2,2,NONE,OO,OO,OO,OO,(object x, object table),"")
+/* static object */
+/* FFN(find_sharing_top)(object x, object table) */
 {sharing_table=table;
  find_sharing(x);
  return Ct;
@@ -1518,7 +1523,7 @@ read_fasl_vector(object in)
      if (ch== d_begin_dump){
        unreadc_stream(ch,in);
        break;}}
- {object ar=FFN(open_fasd)(in,sKinput,0,Cnil);
+ {object ar=FFN(fSopen_fasd)(in,sKinput,0,Cnil);
   int n=fix(current_fasd.table_length);
   object result,last;
   { BEGIN_NO_INTERRUPT;
@@ -1534,13 +1539,13 @@ read_fasl_vector(object in)
   gset( current_fasd.table->v.v_self,0,n,aet_object);
   END_NO_INTERRUPT;
   }  
-  result=FFN(read_fasd_top)(ar);
+  result=FFN(fSread_fasd_top)(ar);
   if (type_of(result) !=t_vector) goto ERROR;
   last=result->v.v_self[result->v.v_fillp-1];
   if(type_of(last)!=t_cons || last->c.c_car !=sSPinit)
     goto ERROR;
   current_fasd.table->v.v_self = 0;
-  FFN(close_fasd)(ar);
+  FFN(fSclose_fasd)(ar);
   if (orig != in)
     close_stream(in);
   return result;
@@ -1584,10 +1589,10 @@ object IfaslInStream;
 static void
 init_fasdump(void)
 {
-  make_si_sfun("READ-FASD-TOP",read_fasd_top,1);
-  make_si_sfun("WRITE-FASD-TOP",write_fasd_top,2);
-  make_si_sfun("OPEN-FASD",open_fasd,4);  
-  make_si_sfun("CLOSE-FASD",close_fasd,1);
-/*  make_si_sfun("FASD-I-DATA",fasd_i_macro,1); */
-  make_si_sfun("FIND-SHARING-TOP",find_sharing_top,2);
+/*   make_si_sfun("READ-FASD-TOP",read_fasd_top,1); */
+/*   make_si_sfun("WRITE-FASD-TOP",write_fasd_top,2); */
+/*   make_si_sfun("OPEN-FASD",open_fasd,4);   */
+/*   make_si_sfun("CLOSE-FASD",close_fasd,1); */
+/* /\*  make_si_sfun("FASD-I-DATA",fasd_i_macro,1); *\/ */
+/*   make_si_sfun("FIND-SHARING-TOP",find_sharing_top,2); */
 }
--- gcl-2.6.10.orig/o/funlink.c
+++ gcl-2.6.10/o/funlink.c
@@ -22,6 +22,25 @@ vpush_extend(void *,object);
 object sLAlink_arrayA;
 int Rset = 0;
 
+DEFVAR("*LINK-LIST*",sSAlink_listA,SI,0,"");
+
+static inline void
+append_link_list(object sym,int n) {
+
+  object x;
+  int i;
+
+  if (!Rset || !sSAlink_listA->s.s_dbind) return;
+  for (x=sSAlink_listA->s.s_dbind;x!=Cnil && x->c.c_car->c.c_car!=sym;x=x->c.c_cdr);
+  if (x==Cnil) 
+    sSAlink_listA->s.s_dbind=MMcons((x=list(6,sym,make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0))),sSAlink_listA->s.s_dbind);
+  else 
+    x=x->c.c_car;
+  for (x=x->c.c_cdr,i=0;i<n;i++,x=x->c.c_cdr);
+  x->c.c_car=one_plus(x->c.c_car);
+}
+
+
 /* cleanup link */
 void
 call_or_link(object sym, void **link )
@@ -54,7 +73,9 @@ call_or_link(object sym, void **link )
 #endif         
 	 (*(void (*)())(fun->cf.cf_self))();
        }
-   else funcall(fun);}
+   else {
+     append_link_list(sym,0);
+     funcall(fun);}}
 
 void
 call_or_link_closure(object sym, void **link, void **ptr)
@@ -70,7 +91,9 @@ call_or_link_closure(object sym, void **
      *link = (void *) (fun->cf.cf_self);
      MMccall(fun, fun->cc.cc_turbo);}
     else
-      {MMccall(fun, fun->cc.cc_turbo);}
+      { 
+	append_link_list(sym,1);
+	MMccall(fun, fun->cc.cc_turbo);}
     return;}
  if (Rset==0) funcall(fun);
    else
@@ -83,7 +106,9 @@ call_or_link_closure(object sym, void **
          *link = (void *) (fun->cf.cf_self);
 	 (*(void (*)())(fun->cf.cf_self))();
        }
-   else funcall(fun);}
+   else {
+     	append_link_list(sym,2);
+	funcall(fun);}}
 
 /* for pushing item into an array, where item is an address if array-type = t
 or a fixnum if array-type = fixnum */
@@ -260,6 +285,7 @@ clean_link_array(object *ar, object *ar_
 value.  This function is called by the static lnk function in the reference
 file */
 
+
 static object
 call_proc(object sym, void **link, int argd, va_list ll)
 {object fun;
@@ -268,6 +294,7 @@ call_proc(object sym, void **link, int a
  fun=sym->s.s_gfdef;
  if (fun && (type_of(fun)==t_sfun
 	     || type_of(fun)==t_gfun
+	     || type_of(fun)==t_afun
 	     || type_of(fun)== t_vfun)
 	     && Rset) /* the && Rset is to allow tracing */
    {object (*fn)();
@@ -285,6 +312,20 @@ call_proc(object sym, void **link, int a
 	   goto   AFTER_LINK;
 	 }
       }
+    else if (type_of(fun)==t_afun) {
+      ufixnum at=F_TYPES(fun->sfn.sfn_argd)>>F_TYPE_WIDTH;
+      ufixnum ma=F_MIN_ARGS(fun->sfn.sfn_argd);
+      ufixnum xa=F_MAX_ARGS(fun->sfn.sfn_argd);
+      ufixnum rt=F_RESULT_TYPE(fun->sfn.sfn_argd);
+
+      nargs=SFUN_NARGS(argd);
+      if (nargs<ma || nargs > xa)
+	goto WRONG_ARGS;
+      if (((argd>>8)&0x3)!=rt)
+	  FEerror("Return type mismatch in call to  ~s",1,sym);
+      if ((argd>>12)!=at)
+	  FEerror("Arg type mismatch in call to  ~s",1,sym);
+    }
     else /* t_gfun,t_sfun */
       { nargs= SFUN_NARGS(argd);
 	if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) 
@@ -310,6 +351,9 @@ call_proc(object sym, void **link, int a
      register object *base;
      enum ftype result_type;
      /* we check they are valid functions before calling this */
+
+     append_link_list(sym,3);
+
      if(type_of(sym)==t_symbol) fun = symbol_function(sym);
      else fun = sym;
      vs_base= (base =   vs_top);
@@ -356,6 +400,7 @@ call_proc_new(object sym, void **link, i
  fun=sym->s.s_gfdef;
  if (fun && (type_of(fun)==t_sfun
 	     || type_of(fun)==t_gfun
+	     || type_of(fun)==t_afun
 	     || type_of(fun)== t_vfun)
      && Rset) /* the && Rset is to allow tracing */
    {object (*fn)();
@@ -373,6 +418,20 @@ call_proc_new(object sym, void **link, i
 	   goto   AFTER_LINK;
 	 }
      }
+    else if (type_of(fun)==t_afun) {
+      ufixnum at=F_TYPES(fun->sfn.sfn_argd)>>F_TYPE_WIDTH;
+      ufixnum ma=F_MIN_ARGS(fun->sfn.sfn_argd);
+      ufixnum xa=F_MAX_ARGS(fun->sfn.sfn_argd);
+      ufixnum rt=F_RESULT_TYPE(fun->sfn.sfn_argd);
+
+      nargs=SFUN_NARGS(argd);
+      if (nargs<ma || nargs > xa)
+	goto WRONG_ARGS;
+      if (((argd>>8)&0x3)!=rt)
+	  FEerror("Return type mismatch in call to  ~s",1,sym);
+      if ((argd>>12)!=at)
+	  FEerror("Arg type mismatch in call to  ~s",1,sym);
+    }
    else /* t_gfun,t_sfun */
      { nargs= SFUN_NARGS(argd);
      if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) 
@@ -398,6 +457,9 @@ call_proc_new(object sym, void **link, i
      object fun;
      register object *base;
      enum ftype result_type;
+
+     append_link_list(sym,4);
+
      /* we check they are valid functions before calling this */
      if(type_of(sym)==t_symbol) fun = symbol_function(sym);
      else fun = sym;
--- gcl-2.6.10.orig/o/hash.d
+++ gcl-2.6.10/o/hash.d
@@ -490,7 +490,7 @@ LFD(Lmaphash)()
 	vs_popp;
 }
 
-DEFUN_NEW("NEXT-HASH-TABLE-ENTRY",object,fSnext_hash_table_entry,SI,2,2,NONE,OO,OO,OO,OO,(object table,object ind),"For HASH-TABLE and for index I return three values: NEXT-START, the next KEY and its  VALUE.   NEXT-START will be -1 if there are no more entries, otherwise it will be a value suitable for passing as an index")
+DEFUNM_NEW("NEXT-HASH-TABLE-ENTRY",object,fSnext_hash_table_entry,SI,2,2,NONE,OO,OO,OO,OO,(object table,object ind),"For HASH-TABLE and for index I return three values: NEXT-START, the next KEY and its  VALUE.   NEXT-START will be -1 if there are no more entries, otherwise it will be a value suitable for passing as an index")
 { int i = fix(ind);
   check_type_hash_table(&table);
   if ( i < 0) { FEerror("needs non negative index",0);}
--- gcl-2.6.10.orig/o/list.d
+++ gcl-2.6.10/o/list.d
@@ -251,7 +251,7 @@ object on_stack_list_vector_new(int n,ob
 #ifdef WIDE_CONS
  set_type_of(p,t_cons);
 #endif
- p->c_car= jj ? va_arg(ap,object) : first;
+ p->c_car= jj||first==OBJNULL ? va_arg(ap,object) : first;
  jj=1;
  if (--n == 0)
    {p->c_cdr = Cnil;
@@ -281,7 +281,7 @@ object list_vector_new(int n,object firs
 {object ans,*p;
  
  if (n == 0) return Cnil;
- ans = make_cons(first,Cnil);
+ ans = make_cons(first==OBJNULL ? va_arg(ap,object) : first,Cnil);
  p = & (ans->c.c_cdr); 
  while (--n > 0)
    { *p = make_cons(va_arg(ap,object),Cnil);
--- gcl-2.6.10.orig/o/macros.c
+++ gcl-2.6.10/o/macros.c
@@ -167,7 +167,7 @@ macro_def(object form)
 		return(Cnil);
 }
 
-DEFUNO_NEW("MACROEXPAND",object,fLmacroexpand,LISP
+DEFUNOM_NEW("MACROEXPAND",object,fLmacroexpand,LISP
        ,1,2,NONE,OO,OO,OO,OO,void,Lmacroexpand,(object form,...),"")
 {	int n=VFUN_NARGS;
 	object envir;
--- gcl-2.6.10.orig/o/main.c
+++ gcl-2.6.10/o/main.c
@@ -230,7 +230,7 @@ minimize_image(void) {
   
 }
 
-DEFUN_NEW("SET-LOG-MAXPAGE-BOUND",fixnum,fSset_log_maxpage_bound,SI,1,1,NONE,II,OO,OO,OO,(fixnum l),"") {
+DEFUN_NEW("SET-LOG-MAXPAGE-BOUND",object,fSset_log_maxpage_bound,SI,1,1,NONE,II,OO,OO,OO,(fixnum l),"") {
 
   void *end,*dend;
   fixnum def=sizeof(fixnum)*8-1;
@@ -245,7 +245,7 @@ DEFUN_NEW("SET-LOG-MAXPAGE-BOUND",fixnum
     update_real_maxpage();
   }
 
-  return log_maxpage_bound;
+  return (object)log_maxpage_bound;
 
 }
 
@@ -597,10 +597,10 @@ segmentation_catcher(int i) {
 /* } */
 
 DEFUNO_NEW("BYE",object,fLbye,LISP
-       ,0,1,NONE,OI,OO,OO,OO,void,Lby,(fixnum exitc),"")
+       ,0,1,NONE,OO,OO,OO,OO,void,Lby,(object exitc),"")
 {	int n=VFUN_NARGS;
 	int exit_code;
-	if (n>=1) exit_code=exitc;else exit_code=0;
+	if (n>=1) exit_code=fix(exitc);else exit_code=0;
 
 /*	printf("Bye.\n"); */
 	exit(exit_code);
@@ -609,7 +609,7 @@ DEFUNO_NEW("BYE",object,fLbye,LISP
 
 
 DEFUN_NEW("QUIT",object,fLquit,LISP
-       ,0,1,NONE,OI,OO,OO,OO,(fixnum exitc),"")
+       ,0,1,NONE,OO,OO,OO,OO,(object exitc),"")
 {	return FFN(fLbye)(exitc); }
  
 /* DEFUN_NEW("EXIT",object,fLexit,LISP */
--- gcl-2.6.10.orig/o/makefile
+++ gcl-2.6.10/o/makefile
@@ -15,7 +15,7 @@ DECL     := $(HDIR)/new_decl.h
 ALIB     := ${LIBFILES} ${EXTRA_LIB}
 
 
-OBJS:=$(addsuffix .o,main alloc gbc bitop typespec eval macros lex bds frame predicate reference assignment\
+OBJS:=$(addsuffix .o,typespec main alloc gbc bitop eval macros lex bds frame predicate reference assignment\
 	bind let conditional block iteration mapfun prog multival catch symbol cfun cmpaux package big number\
 	num_pred num_comp num_arith num_sfun num_co num_log num_rand earith character sequence list hash\
 	array string regexpr structure toplevel file read backq print format pathname unixfsys unixfasl\
--- gcl-2.6.10.orig/o/makefun.c
+++ gcl-2.6.10/o/makefun.c
@@ -107,16 +107,96 @@ DEFUN_NEW("SET-KEY-STRUCT",object,fSset_
 }
      
 
+#define collect(top_,next_,val_) ({object _x=MMcons(val_,Cnil);\
+                                   if (top_==Cnil) top_=next_=_x; \
+                                   else next_=next_->c.c_cdr=_x;})
+
+
+static void
+put_fn_procls(object sym,fixnum argd,fixnum oneval,object def,object rdef) {
+
+  unsigned int atypes=F_TYPES(argd) >> F_TYPE_WIDTH;
+  unsigned int minargs=F_MIN_ARGS(argd);
+  unsigned int maxargs=F_MAX_ARGS(argd);
+  unsigned int rettype=F_RESULT_TYPE(argd);
+  unsigned int i;
+  object ta=Cnil,na=Cnil;
+
+  for (i=0;i<minargs;i++,atypes >>=F_TYPE_WIDTH) 
+    switch(maxargs!=minargs ? F_object : atypes & MASK_RANGE(0,F_TYPE_WIDTH)) {
+    case F_object:
+      collect(ta,na,def);
+      break;
+    case F_int:
+      collect(ta,na,sLfixnum);
+      break;
+    case F_shortfloat:
+      collect(ta,na,sLshort_float);
+      break;
+    case F_double_ptr:
+      collect(ta,na,sLlong_float);
+      break;
+    default:
+      FEerror("Bad sfn declaration",0);
+      break;
+    }
+  if (maxargs!=minargs)
+    collect(ta,na,sLA);
+  putprop(sym,ta,sSproclaimed_arg_types);
+  ta=na=Cnil;
+  if (oneval) 
+    switch(rettype) {
+    case F_object:
+      ta=rdef;
+      break;
+    case F_int:
+      ta=sLfixnum;
+      break;
+    case F_shortfloat:
+      ta=sLshort_float;
+      break;
+    case F_double_ptr:
+      ta=sLlong_float;
+      break;
+    default:
+      FEerror("Bad sfn declaration",0);
+      break;
+    }
+  else
+/*     ta=MMcons(sLA,Cnil); */
+    ta=sLA;
+  putprop(sym,ta,sSproclaimed_return_type);
+  if (oneval)
+    putprop(sym,Ct,sSproclaimed_function);
+
+}
+
 void
 SI_makefun(char *strg, void *fn, unsigned int argd)
 { object sym = make_si_ordinary(strg);
  fSfset(sym, fSmakefun(sym,fn,argd));
+ put_fn_procls(sym,argd,1,Ct,Ct);
 }
 
 void
 LISP_makefun(char *strg, void *fn, unsigned int argd)
 { object sym = make_ordinary(strg);
  fSfset(sym, fSmakefun(sym,fn,argd));
+ put_fn_procls(sym,argd,1,Ct,Ct);
+}
+
+void
+SI_makefunm(char *strg, void *fn, unsigned int argd)
+{ object sym = make_si_ordinary(strg);
+ fSfset(sym, fSmakefun(sym,fn,argd));
+ put_fn_procls(sym,argd,0,Ct,Ct);
+}
+
+void
+LISP_makefunm(char *strg, void *fn, unsigned int argd)
+{ object sym = make_ordinary(strg);
+ fSfset(sym, fSmakefun(sym,fn,argd));
+ put_fn_procls(sym,argd,0,Ct,Ct);
 }
 
 
--- gcl-2.6.10.orig/o/num_arith.c
+++ gcl-2.6.10/o/num_arith.c
@@ -258,11 +258,7 @@ one_plus(object x)
 	switch (type_of(x)) {
 
 	case t_fixnum:
-	  
-	  if (fix(x)< MOST_POSITIVE_FIX-1) {
-	    return make_fixnum(fix(x)+1);
-	  }
-	  MPOP(return,addss,1,fix(x));
+	  return fixnum_add(fix(x),1);
 	case t_bignum:
 	  MPOP(return,addsi,1,MP(x));
 	case t_ratio:
@@ -446,7 +442,7 @@ one_minus(object x)
 	switch (type_of(x)) {
 
 	case t_fixnum:
-	  MPOP(return,addss,fix(x),-1);
+	  return fixnum_sub(fix(x),1);
 	case t_bignum:
 	  MPOP(return,addsi,-1,MP(x));
 	case t_ratio:
--- gcl-2.6.10.orig/o/num_sfun.c
+++ gcl-2.6.10/o/num_sfun.c
@@ -352,7 +352,7 @@ number_abs(object x) {
   switch(type_of(x)) {
 
   case t_complex:
-    if (number_zerop(x)) return x;
+    if (number_zerop(x)) return x->cmp.cmp_real;
     r=number_abs(x->cmp.cmp_real);
     i=number_abs(x->cmp.cmp_imag);
     if (number_compare(r,i)<0) {
--- gcl-2.6.10.orig/o/predicate.c
+++ gcl-2.6.10/o/predicate.c
@@ -333,13 +333,13 @@ 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_cons) {
+	/* 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 ||
 		    x == sSlambda_block_expanded ||
--- gcl-2.6.10.orig/o/regexpr.c
+++ gcl-2.6.10/o/regexpr.c
@@ -90,7 +90,7 @@ DEFUN_NEW("COMPILE-REGEXP",object,fScomp
 }
 
 
-DEFUN_NEW("STRING-MATCH",object,fSstring_match,SI,2,4,NONE,OO,OI,IO,OO,(object pattern,object string,...),
+DEFUN_NEW("STRING-MATCH",object,fSstring_match,SI,2,4,NONE,OO,OO,OO,OO,(object pattern,object string,...),
       "Match regexp PATTERN in STRING starting in string starting at START \
 and ending at END.  Return -1 if match not found, otherwise \
 return the start index  of the first matchs.  The variable \
@@ -120,9 +120,9 @@ be over written.   \
   end=string->st.st_fillp;
   if (nargs>2) {
     va_start(ap,string);
-    start=va_arg(ap,fixnum);
+    start=fixint(va_arg(ap,object));
     if (nargs>3)
-      end=va_arg(ap,fixnum);
+      end=fixint(va_arg(ap,object));
     va_end(ap);
   }
   if (start < 0 || end > string->st.st_fillp || start > end)
--- gcl-2.6.10.orig/o/structure.c
+++ gcl-2.6.10/o/structure.c
@@ -59,9 +59,9 @@ DEFUN_NEW("STRUCTURE-DEF",object,fSstruc
   return (x)->str.str_def;
 }
 
-DEFUN_NEW("STRUCTURE-LENGTH",fixnum,fSstructure_length,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {
+DEFUN_NEW("STRUCTURE-LENGTH",object,fSstructure_length,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {
   check_type_structure(x);
-  return S_DATA(x)->length;
+  return (object)S_DATA(x)->length;
 }
 
 DEFUN_NEW("STRUCTURE-REF",object,structure_ref,SI,3,3,NONE,OO,OI,OO,OO,(object x,object name,fixnum i),"") {
--- gcl-2.6.10.orig/o/typespec.c
+++ gcl-2.6.10/o/typespec.c
@@ -427,6 +427,9 @@ LFD(Ltype_of)(void)
 	}
 }
 
+DEF_ORDINARY("PROCLAIMED-ARG-TYPES",sSproclaimed_arg_types,SI,"");
+DEF_ORDINARY("PROCLAIMED-RETURN-TYPE",sSproclaimed_return_type,SI,"");
+DEF_ORDINARY("PROCLAIMED-FUNCTION",sSproclaimed_function,SI,"");
 DEF_ORDINARY("COMMON",sLcommon,LISP,"");
 DEF_ORDINARY("NULL",sLnull,LISP,"");
 DEF_ORDINARY("CONS",sLcons,LISP,"");
--- gcl-2.6.10.orig/o/unixfsys.c
+++ gcl-2.6.10/o/unixfsys.c
@@ -784,14 +784,14 @@ LFD(Ldirectory)()
 #include <sys/types.h>
 #include <dirent.h>
 
-DEFUN_NEW("OPENDIR",fixnum,fSopendir,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {
+DEFUN_NEW("OPENDIR",object,fSopendir,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {
   DIR *d;
   char filename[MAXPATHLEN];
   check_type_string(&x);
   memcpy(filename,x->st.st_self,x->st.st_fillp);
   filename[x->st.st_fillp]=0;
   d=opendir(filename);
-  return (fixnum)d;
+  return (object)d;
 }
 
 #ifdef HAVE_D_TYPE
--- gcl-2.6.10.orig/o/unixtime.c
+++ gcl-2.6.10/o/unixtime.c
@@ -260,7 +260,7 @@ int usleep ( unsigned int microseconds )
 
 #endif
 
-DEFUN_NEW("CURRENT-TIMEZONE",fixnum,fScurrent_timezone,SI,0,0,NONE,IO,OO,OO,OO,(void),"") {
+DEFUN_NEW("CURRENT-TIMEZONE",object,fScurrent_timezone,SI,0,0,NONE,IO,OO,OO,OO,(void),"") {
 
 #if defined(__MINGW32__)
 
@@ -271,19 +271,19 @@ DEFUN_NEW("CURRENT-TIMEZONE",fixnum,fScu
   
   /* Now UTC = (local time + bias), in units of minutes, so */
   /*fprintf ( stderr, "Bias = %ld\n", tzi.Bias );*/
-  return tzi.Bias/60;                                    
+  return (object)tzi.Bias/60;                                    
   
 #elif defined NO_SYSTEM_TIME_ZONE
-  return 0;
+  return (object)0;
 #elif defined __CYGWIN__
   struct tm gt,lt;
   fixnum _t=0;
   gmtime_r(&_t, &gt);
   localtime_r(&_t, &lt);
-  return (lt.tm_mday == gt.tm_mday) ? -(lt.tm_hour) : (24 - lt.tm_hour);
+  return (object)((lt.tm_mday == gt.tm_mday) ? -(lt.tm_hour) : (24 - lt.tm_hour));
 #else
   fixnum _t=time(0);
-  return -localtime(&_t)->tm_gmtoff/3600;
+  return (object)(-localtime(&_t)->tm_gmtoff/3600);
 #endif
 }
 
--- gcl-2.6.10.orig/pcl/gcl_pcl_cache.lisp
+++ gcl-2.6.10/pcl/gcl_pcl_cache.lisp
@@ -418,6 +418,13 @@
 
 )
 
+(defmacro mdotimes ((var form &optional ret) &rest body &aux (v (gensym)))
+  `(do ((,v ,form)
+	(,var 0 (1+ ,var)))
+       ((>= ,var ,v) ,ret)
+     (declare (fixnum ,var ,v))
+     ,@body))
+
 #+structure-wrapper
 (progn
 
@@ -425,7 +432,7 @@
 (defun make-wrapper-cache-number-vector ()
   (let ((cnv (make-array #.wrapper-cache-number-vector-length
 			 :element-type 'fixnum)))
-    (dotimes (i #.wrapper-cache-number-vector-length)
+    (mdotimes (i #.wrapper-cache-number-vector-length)
       (setf (aref cnv i) (get-wrapper-cache-number)))
     cnv))
 
@@ -514,7 +521,7 @@
 	  (values si::*all-t-s-type* si::*standard-slot-positions*)
 	  (values (make-array size :element-type 'unsigned-char)
 		  (let ((array (make-array size :element-type 'unsigned-short)))
-		    (dotimes (i size)
+		    (mdotimes (i size)
 		      (declare (fixnum i))
 		      (setf (aref array i) (* #.(si::size-of t) i))))))
     (make-wrapper-internal :length size
@@ -791,7 +798,7 @@
 	 (old-vector (cache-vector old-cache))
 	 (new-vector (get-cache-vector size)))
     (declare (simple-vector old-vector new-vector))
-    (dotimes (i size)
+    (mdotimes (i size)
       (setf (svref new-vector i) (svref old-vector i)))
     (setf (cache-vector new-cache) new-vector)
     new-cache))
@@ -913,7 +920,7 @@
     (declare (type field-type field)
 	     (type non-negative-fixnum result mask nkeys)
 	     (simple-vector cache-vector))
-    (dotimes (i nkeys)
+    (mdotimes (i nkeys)
       (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
 	     (wcn (wrapper-cache-number-vector-ref wrapper field)))
 	(declare (type non-negative-fixnum wcn))
@@ -1140,7 +1147,7 @@
 
 (defconstant *local-cache-functions*
   '((cache () .cache.)
-    (nkeys () (cache-nkeys .cache.))
+    (nkeys () (the non-negative-fixnum (cache-nkeys .cache.)))
     (line-size () (cache-line-size .cache.))
     (vector () (cache-vector .cache.))
     (valuep () (cache-valuep .cache.))
@@ -1206,7 +1213,7 @@
 	  (let ((list (make-list (nkeys)))
 		(vector (vector)))
 	    (declare (simple-vector vector))
-	    (dotimes (i (nkeys) list)
+	    (mdotimes (i (nkeys) list)
 	      (setf (nth i list) (cache-vector-ref vector (+ location i)))))))
     ;;
     ;; Given a line number, return true IFF the line's
@@ -1223,7 +1230,7 @@
 	(declare (simple-vector cache-vector))
 	(if (= (nkeys) 1)
 	    (eq wrappers (cache-vector-ref cache-vector loc))
-	    (dotimes (i (nkeys) t)
+	    (mdotimes (i (nkeys) t)
 	      (unless (eq (pop wrappers)
 			  (cache-vector-ref cache-vector (+ loc i)))
 		(return nil))))))
@@ -1264,7 +1271,7 @@
       (let ((cache-vector (vector))
 	    (wrappers-mismatch-p (null wrappers)))
 	(declare (simple-vector cache-vector))
-	(dotimes (i (nkeys) wrappers-mismatch-p)
+	(mdotimes (i (nkeys) wrappers-mismatch-p)
 	  (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
 	    (when (or (null wrapper)
 		      (invalid-wrapper-p wrapper))
@@ -1375,7 +1382,7 @@
   (with-local-cache-functions (cache)
     (let ((location (if (= (nkeys) 1) 0 1))
 	  (limit (funcall (limit-fn) (nlines))))
-      (dotimes (i (nlines) cache)
+      (mdotimes (i (nlines) cache)
 	(when (and (not (location-reserved-p location))
 		   (line-full-p i))
 	  (let* ((home-loc (compute-primary-cache-location-from-location 
@@ -1399,7 +1406,7 @@
       (declare (type non-negative-fixnum location limit))
       (when (location-reserved-p location)
 	(setq location (next-location location)))
-      (dotimes (i (the non-negative-fixnum (1+ limit)))
+      (mdotimes (i (the non-negative-fixnum (1+ limit)))
 	(when (location-matches-wrappers-p location wrappers)
 	  (return-from probe-cache (or (not (valuep))
 				       (location-value location))))
@@ -1413,7 +1420,7 @@
 (defun map-cache (function cache &optional set-p)
   (with-local-cache-functions (cache)
     (let ((set-p (and set-p (valuep))))
-      (dotimes (i (nlines) cache)
+      (mdotimes (i (nlines) cache)
 	(unless (or (line-reserved-p i) (not (line-valid-p i nil)))
 	  (let ((value (funcall function (line-wrappers i) (line-value i))))
 	    (when set-p
@@ -1429,7 +1436,7 @@
   (with-local-cache-functions (cache)
     (let ((count 0))
       (declare (type non-negative-fixnum count))
-      (dotimes (i (nlines) count)
+      (mdotimes (i (nlines) count)
 	(unless (line-reserved-p i)
 	  (when (line-full-p i)
 	    (incf count)))))))
@@ -1437,7 +1444,7 @@
 (defun entry-in-cache-p (cache wrappers value)
   (declare (ignore value))
   (with-local-cache-functions (cache)
-    (dotimes (i (nlines))
+    (mdotimes (i (nlines))
       (unless (line-reserved-p i)
 	(when (equal (line-wrappers i) wrappers)
 	  (return t))))))
@@ -1503,7 +1510,7 @@
 		      (to-loc (line-location to-line)))
 		  (declare (type non-negative-fixnum from-loc to-loc))
 		  (modify-cache to-cache-vector
-				(dotimes (i (line-size))
+				(mdotimes (i (line-size))
 				  (setf (cache-vector-ref to-cache-vector
 							  (+ to-loc i))
 					(cache-vector-ref from-cache-vector
@@ -1534,7 +1541,7 @@
 		     (fill-cache-from-cache-p nil ncache cache line))
 		   (try-one-fill (wrappers value)
 		     (fill-cache-p nil ncache wrappers value)))
-	    (if (and (dotimes (i (nlines) t)
+	    (if (and (mdotimes (i (nlines) t)
 		       (when (and (null (line-reserved-p i))
 				  (line-valid-p i wrappers))
 			 (unless (try-one-fill-from-line i) (return nil))))
@@ -1563,7 +1570,7 @@
 				  (fill-cache-p t ncache wrappers value))))
 	       (try-one-fill (wrappers value)
 		 (fill-cache-p nil ncache wrappers value)))
-	(dotimes (i (nlines))
+	(mdotimes (i (nlines))
 	  (when (and (null (line-reserved-p i))
 		     (line-valid-p i wrappers))
 	    (do-one-fill-from-line i)))
@@ -1638,7 +1645,7 @@
 	   (declare (type non-negative-fixnum from-loc to-loc)
 		    (simple-vector cache-vector))
 	   (modify-cache cache-vector
-			 (dotimes (i (line-size))
+			 (mdotimes (i (line-size))
 			   (setf (cache-vector-ref cache-vector (+ to-loc i))
 				 (cache-vector-ref cache-vector (+ from-loc i)))
 			   (setf (cache-vector-ref cache-vector (+ from-loc i))
--- gcl-2.6.10.orig/pcl/gcl_pcl_pkg.lisp
+++ gcl-2.6.10/pcl/gcl_pcl_pkg.lisp
@@ -214,6 +214,7 @@
 		    call-next-method
 		    change-class
 		    class-name
+		    classp
 		    class-of
 		    compute-applicable-methods
 		    defclass
--- gcl-2.6.10.orig/unixport/init_ansi_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_ansi_gcl.lsp.in
@@ -1,4 +1,5 @@
 (make-package "COMPILER" :use '("LISP"))
+(import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
 (make-package "SLOOP" :use '("LISP"))
 (make-package "SERROR" :use '("LISP" "SLOOP"))
 (make-package "ANSI-LOOP" :use '("LISP"))
@@ -166,12 +167,12 @@
 		      (import (list s) "USER"))
  
 ;(shadowing-import (list 'pcl::classp) "SYSTEM")
- (setf (symbol-function 'si::classp) (symbol-function 'pcl::classp))
- (setf (symbol-function 'si::class-of) (symbol-function 'pcl::class-of))
- (setf (symbol-function 'si::class-precedence-list) 
-       (symbol-function 'pcl::class-precedence-list))
- (setf (symbol-function 'si::find-class) 
-       (symbol-function 'pcl::find-class))
+ ;; (setf (symbol-function 'si::classp) (symbol-function 'pcl::classp))
+ ;; (setf (symbol-function 'si::class-of) (symbol-function 'pcl::class-of))
+ ;; (setf (symbol-function 'si::class-precedence-list) 
+ ;;       (symbol-function 'pcl::class-precedence-list))
+ ;; (setf (symbol-function 'si::find-class) 
+ ;;       (symbol-function 'pcl::find-class))
  
  (do-external-symbols (s "CONDITIONS")
 		      (if (member s clcs_shadow)
--- gcl-2.6.10.orig/unixport/init_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_gcl.lsp.in
@@ -1,4 +1,5 @@
 (make-package "COMPILER" :use '("LISP"))
+(import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
 (make-package "SLOOP" :use '("LISP"))
 (make-package "SERROR" :use '("LISP" "SLOOP"))
 (make-package "ANSI-LOOP" :use '("LISP"))
--- gcl-2.6.10.orig/unixport/init_pcl_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_pcl_gcl.lsp.in
@@ -1,4 +1,5 @@
 (make-package "COMPILER" :use '("LISP"))
+(import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
 (make-package "SLOOP" :use '("LISP"))
 (make-package "SERROR" :use '("LISP" "SLOOP"))
 (make-package "ANSI-LOOP" :use '("LISP"))
--- gcl-2.6.10.orig/unixport/init_pre_gcl.lsp.in
+++ gcl-2.6.10/unixport/init_pre_gcl.lsp.in
@@ -1,4 +1,5 @@
 (make-package "COMPILER" :use '("LISP"))
+(import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
 (make-package "SLOOP" :use '("LISP"))
 (make-package "SERROR" :use '("LISP" "SLOOP"))
 (make-package "ANSI-LOOP" :use '("LISP"))
