385abae
Description: <short summary of the patch>
385abae
 TODO: Put a short summary on the line above and replace this paragraph
385abae
 with a longer explanation of this change. Complete the meta-information
385abae
 with other relevant fields (see below for details). To make it easier, the
385abae
 information below has been extracted from the changelog. Adjust it or drop
385abae
 it.
385abae
 .
385abae
 gcl (2.6.12-60) unstable; urgency=medium
385abae
 .
385abae
   * list_order.18
385abae
Author: Camm Maguire <camm@debian.org>
385abae
385abae
---
385abae
The information above should follow the Patch Tagging Guidelines, please
385abae
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
385abae
are templates for supplementary fields that you might want to add:
385abae
385abae
Origin: <vendor|upstream|other>, <url of original patch>
385abae
Bug: <url in upstream bugtracker>
385abae
Bug-Debian: https://bugs.debian.org/<bugnumber>
385abae
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
385abae
Forwarded: <no|not-needed|url proving that it has been forwarded>
385abae
Reviewed-By: <name and email of someone who approved the patch>
385abae
Last-Update: 2018-01-24
385abae
385abae
--- gcl-2.6.12.orig/lsp/gcl_mislib.lsp
385abae
+++ gcl-2.6.12/lsp/gcl_mislib.lsp
385abae
@@ -166,24 +166,45 @@
385abae
     (setq *load-path* nl))
385abae
   nil)
385abae
 
385abae
-(defun default-symtab nil (concatenate 'string *tmp-dir* "gcl_symtab"))
385abae
-
385abae
 (defun gprof-output (symtab gmon)
385abae
   (with-open-file
385abae
      (s (format nil "|gprof -S '~a' '~a' '~a'" symtab (kcl-self) gmon))
385abae
      (copy-stream s *standard-output*)))
385abae
 
385abae
+(defun write-symtab (symtab start end &aux (*package* (find-package "KEYWORD")))
385abae
+
385abae
+  (with-open-file
385abae
+   (s symtab :direction :output :if-exists :supersede)
385abae
+
385abae
+   (format s "~16,'0x T ~a~%" start "GCL_MONSTART")
385abae
 
385abae
-(defun gprof-start (&optional (start 0 start-p) (end 0 end-p) (symtab (default-symtab)))
385abae
-  (unless end-p
385abae
-    (multiple-value-bind
385abae
-     (s e)
385abae
-     (gprof-addresses)
385abae
-     (setq start (if start-p start s) end e)))
385abae
-  (when (monstartup start end)
385abae
-    (write-symtab symtab start end)))
385abae
+   (dolist (p (list-all-packages))
385abae
+     (do-symbols (x p)
385abae
+      (when (and (eq (symbol-package x) p) (fboundp x))
385abae
+	(let* ((y (symbol-function x))
385abae
+	       (y (if (and (consp y) (eq 'macro (car y))) (cdr y) y))
385abae
+	       (y (if (compiled-function-p y) (function-start y) 0)))
385abae
+	  (when (<= start y end)
385abae
+	    (format s "~16,'0x T ~s~%" y x))))))
385abae
+
385abae
+   (let ((string-register ""))
385abae
+     (dotimes (i (ptable-alloc-length))
385abae
+       (multiple-value-bind
385abae
+	(x y) (ptable i string-register)
385abae
+	(when (<= start x end)
385abae
+	  (format s "~16,'0x T ~a~%" x y)))))
385abae
+
385abae
+   (format s "~16,'0x T ~a~%" end "GCL_MONEND"))
385abae
+
385abae
+  symtab)
385abae
+
385abae
+(defun gprof-start (&optional (symtab "gcl_symtab") (adrs (gprof-addresses))
385abae
+			      &aux (start (car adrs))(end (cdr adrs)))
385abae
+  (let ((symtab (write-symtab symtab start end)))
385abae
+    (when (monstartup start end)
385abae
+      symtab)))
385abae
 
385abae
-(defun gprof-quit (&optional (symtab (default-symtab)) &aux (gmon (mcleanup)))
385abae
+(defun gprof-quit (&optional (symtab "gcl_symtab") &aux (gmon (mcleanup)))
385abae
   (when gmon
385abae
     (gprof-output symtab gmon)))
385abae
 
385abae
--- gcl-2.6.12.orig/o/fat_string.c
385abae
+++ gcl-2.6.12/o/fat_string.c
385abae
@@ -59,17 +59,16 @@ DEFUN_NEW("PROFILE",object,fSprofile,SI
385abae
 }
385abae
 
385abae
 #endif
385abae
-DEFUN_NEW("FUNCTION-START",object,fSfunction_start,SI
385abae
-       ,1,1,NONE,OO,OO,OO,OO,(object funobj),"")
385abae
-{/* 1 args */
385abae
- if(type_of(funobj)!=t_cfun
385abae
-    && type_of(funobj)!=t_sfun
385abae
-    && type_of(funobj)!=t_vfun
385abae
-    && type_of(funobj)!=t_afun
385abae
-    && type_of(funobj)!=t_gfun)
385abae
-    FEerror("not compiled function",0);
385abae
- funobj=make_fixnum((long) (funobj->cf.cf_self));
385abae
- RETURN1(funobj);
385abae
+DEFUN_NEW("FUNCTION-START",object,fSfunction_start,SI,1,1,NONE,OO,OO,OO,OO,(object funobj),"") {
385abae
+
385abae
+  switch (type_of(funobj)) {
385abae
+  case t_cfun:case t_sfun:case t_vfun:case t_afun:case t_gfun:case t_closure:case t_cclosure:
385abae
+    return make_fixnum((long) (funobj->cf.cf_self));
385abae
+  default:
385abae
+    TYPE_ERROR(funobj,sLcompiled_function);
385abae
+    return Cnil;
385abae
+  }
385abae
+
385abae
 }
385abae
 
385abae
 /* begin fasl stuff*/
385abae
--- gcl-2.6.12.orig/o/gprof.c
385abae
+++ gcl-2.6.12/o/gprof.c
385abae
@@ -12,13 +12,11 @@ DEFUN_NEW("MCLEANUP",object,fSmcleanup,S
385abae
   if (!gprof_on)
385abae
     return Cnil;
385abae
 
385abae
-  massert(getcwd(FN1,sizeof(FN1)));
385abae
-  massert(!chdir(P_tmpdir));
385abae
-  _mcleanup();
385abae
-  massert(!chdir(FN1));
385abae
+  massert((_mcleanup(),1));
385abae
   gprof_on=0;
385abae
-  massert(snprintf(FN1,sizeof(FN1),"%s/gmon.out",P_tmpdir)>0);
385abae
-  return make_simple_string(FN1);
385abae
+
385abae
+  return make_simple_string("gmon.out");
385abae
+
385abae
 }
385abae
 
385abae
 static inline int
385abae
@@ -48,11 +46,10 @@ void
385abae
 gprof_cleanup(void) {
385abae
 
385abae
   FFN(fSmcleanup)();
385abae
-  /*rename gmon?*/
385abae
 
385abae
 }
385abae
 
385abae
-DEFUNM_NEW("GPROF-ADDRESSES",object,fSgprof_addresses,SI,0,0,NONE,OO,OO,OO,OO,(void),"") {
385abae
+DEFUN_NEW("GPROF-ADDRESSES",object,fSgprof_addresses,SI,0,0,NONE,OO,OO,OO,OO,(void),"") {
385abae
 
385abae
   void *min=heap_end,*max=data_start,*c;
385abae
   static void *mintext;
385abae
@@ -77,10 +74,8 @@ DEFUNM_NEW("GPROF-ADDRESSES",object,fSgp
385abae
     mintext=data_start;
385abae
 
385abae
 #ifdef GCL_GPROF
385abae
-    for (i=0;i
385abae
+    for (i=0;i
385abae
       mintext=(void *)c_table.ptable[i].address
385abae
-    for (i=0;i
385abae
-      mintext=(void *)c_table.local_ptable[i].address
385abae
 #endif
385abae
 
385abae
   }
385abae
@@ -88,7 +83,7 @@ DEFUNM_NEW("GPROF-ADDRESSES",object,fSgp
385abae
   if (mintext
385abae
     min=mintext;
385abae
 
385abae
-  RETURN2(make_fixnum((fixnum)min),make_fixnum((fixnum)max));
385abae
+  return MMcons(make_fixnum((fixnum)min),make_fixnum((fixnum)max));
385abae
 
385abae
 }
385abae
 
385abae
@@ -98,40 +93,14 @@ DEFUN_NEW("KCL-SELF",object,fSkcl_self,S
385abae
 
385abae
 }
385abae
 
385abae
-DEFUN_NEW("WRITE-SYMTAB",object,fSwrite_symtab,SI,3,3,NONE,OO,II,OO,OO,
385abae
-     (object symtab,ufixnum start,ufixnum end),"") {
385abae
-
385abae
-  struct package *p;
385abae
-  object l,s,f,*b,*be;
385abae
-  FILE *pp;
385abae
-  ufixnum i;
385abae
-
385abae
-  coerce_to_filename(symtab,FN1);
385abae
-  pp=fopen(FN1,"w");
385abae
-  fprintf(pp,"%016lx T GCL_MONSTART\n",start);
385abae
-  for (p=pack_pointer;p;p=p->p_link)
385abae
-    for (i=0,b=p->p_internal,be=b+p->p_internal_size;b;
385abae
-	 b=i ? NULL : p->p_external,be=b+p->p_external_size,i=1)
385abae
-      for (;b
385abae
-	for (l=*b;consp(l);l=l->c.c_cdr)
385abae
-	  if ((f=(s=l->c.c_car)->s.s_gfdef)!=OBJNULL && s->s.s_hpack==(object)p)
385abae
-	    switch(type_of(f)) {
385abae
-	    case t_cfun:case t_sfun:case t_vfun:case t_afun:case t_gfun:
385abae
-	      if ((ufixnum)f->cf.cf_self>=start && (ufixnum)f->cf.cf_self
385abae
-		fprintf(pp,"%016lx T %-.*s::%-.*s\n",
385abae
-			(ufixnum)f->cf.cf_self,
385abae
-			p->p_name->st.st_fillp,p->p_name->st.st_self,
385abae
-			s->st.st_fillp,s->st.st_self);
385abae
-	      break;
385abae
-	    }
385abae
-  fprintf(pp,"%016lx T GCL_MONEND\n",end);
385abae
-
385abae
-  for (i=0;i
385abae
-    fprintf(pp,"%016lx T %s\n",c_table.ptable[i].address,c_table.ptable[i].string);
385abae
-  for (i=0;i
385abae
-    fprintf(pp,"%016lx t %s\n",c_table.local_ptable[i].address,c_table.local_ptable[i].string);
385abae
-  fclose(pp);
385abae
-
385abae
-  return symtab;
385abae
+DEFUN_NEW("PTABLE-ALLOC-LENGTH",object,fSptable_alloc_length,SI,0,0,NONE,OO,OO,OO,OO,(void),"") {
385abae
+  return make_fixnum(c_table.alloc_length);
385abae
+}
385abae
 
385abae
+DEFUNM_NEW("PTABLE",object,fSptable,SI,2,2,NONE,OI,OO,OO,OO,(ufixnum i,object s),"") {
385abae
+  check_type_string(&s);
385abae
+  massert(i
385abae
+  s->st.st_self=(void *)c_table.ptable[i].string;
385abae
+  s->st.st_fillp=s->st.st_dim=strlen(s->st.st_self);
385abae
+  RETURN2(make_fixnum(c_table.ptable[i].address),s);
385abae
 }