develooper Front page | perl.perl5.porters | Postings from December 2000

[PATCH 5.7.0] cosmetic change to overloading

Thread Next
From:
Ilya Zakharevich
Date:
December 14, 2000 19:02
Subject:
[PATCH 5.7.0] cosmetic change to overloading
Message ID:
20001214220243.A18437@monk.mps.ohio-state.edu
This cosmetic patch moves the particulars of how the overloading info
is stored in the symbol table from C files to the header files (with
minor speed optimizations too), and adds minimal docs.  Also: obsolete
ifdef'ed stuff is removed.

[I'm planning more changes, but do not want the trivial stuff to be
mixed with important one.]

Enjoy,
Ilya

--- ./gv.c~	Sat Sep  2 13:28:01 2000
+++ ./gv.c	Thu Dec 14 21:51:00 2000
@@ -1156,10 +1156,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
   STRLEN n_a;
-#ifdef OVERLOAD_VIA_HASH
-  GV** gvp;
-  HV* hv;
-#endif
 
   if (mg && amtp->was_ok_am == PL_amagic_generation
       && amtp->was_ok_sub == PL_sub_generation)
@@ -1181,60 +1177,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   amt.fallback = AMGfallNO;
   amt.flags = 0;
 
-#ifdef OVERLOAD_VIA_HASH
-  gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);	/* A shortcut */
-  if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
-    int filled=0;
-    int i;
-    char *cp;
-    SV* sv;
-    SV** svp;
-
-    /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
-
-    if (( cp = (char *)PL_AMG_names[0] ) &&
-	(svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
-      if (SvTRUE(sv)) amt.fallback=AMGfallYES;
-      else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
-    }
-    for (i = 1; i < NofAMmeth; i++) {
-      cv = 0;
-      cp = (char *)PL_AMG_names[i];
-
-        svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
-        if (svp && ((sv = *svp) != &PL_sv_undef)) {
-          switch (SvTYPE(sv)) {
-            default:
-              if (!SvROK(sv)) {
-                if (!SvOK(sv)) break;
-		gv = gv_fetchmethod(stash, SvPV(sv, n_a));
-                if (gv) cv = GvCV(gv);
-                break;
-              }
-              cv = (CV*)SvRV(sv);
-              if (SvTYPE(cv) == SVt_PVCV)
-                  break;
-                /* FALL THROUGH */
-            case SVt_PVHV:
-            case SVt_PVAV:
-	      Perl_croak(aTHX_ "Not a subroutine reference in overload table");
-	      return FALSE;
-            case SVt_PVCV:
-              cv = (CV*)sv;
-              break;
-            case SVt_PVGV:
-              if (!(cv = GvCVu((GV*)sv)))
-                cv = sv_2cv(sv, &stash, &gv, FALSE);
-              break;
-          }
-          if (cv) filled=1;
-	  else {
-	    Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
-		cp,HvNAME(stash));
-	    return FALSE;
-	  }
-        }
-#else
   {
     int filled = 0;
     int i;
@@ -1243,28 +1185,29 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 
     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
 
-    if ((cp = PL_AMG_names[0])) {
-	/* Try to find via inheritance. */
-	gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
-	if (gv)
-	    sv = GvSV(gv);
-
-	if (!gv)
-	    goto no_table;
-	else if (SvTRUE(sv))
-	    amt.fallback=AMGfallYES;
-	else if (SvOK(sv))
-	    amt.fallback=AMGfallNEVER;
-    }
+    /* Try to find via inheritance. */
+    gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
+    if (gv)
+	sv = GvSV(gv);
+
+    if (!gv)
+	goto no_table;
+    else if (SvTRUE(sv))
+	amt.fallback=AMGfallYES;
+    else if (SvOK(sv))
+	amt.fallback=AMGfallNEVER;
 
     for (i = 1; i < NofAMmeth; i++) {
-	SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
+	char *cooky = PL_AMG_names[i];
+	char *cp = AMG_id2name(i); /* Human-readable form, for debugging */
+	STRLEN l = strlen(cooky);
+
 	DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
 		     cp, HvNAME(stash)) );
 	/* don't fill the cache while looking up! */
-	gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+	gv = gv_fetchmeth(stash, cooky, l, -1);
         cv = 0;
-        if(gv && (cv = GvCV(gv))) {
+        if (gv && (cv = GvCV(gv))) {
 	    if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
 		&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
 		/* GvSV contains the name of the method. */
@@ -1293,7 +1236,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 			 GvNAME(CvGV(cv))) );
 	    filled = 1;
 	}
-#endif
 	amt.table[i]=(CV*)SvREFCNT_inc(cv);
     }
     if (filled) {
@@ -1493,7 +1435,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *rig
 	if (off==-1) off=method;
 	msg = sv_2mortal(Perl_newSVpvf(aTHX_
 		      "Operation `%s': no method found,%sargument %s%s%s%s",
-		      PL_AMG_names[method + assignshift],
+		      AMG_id2name(method + assignshift),
 		      (flags & AMGf_unary ? " " : "\n\tleft "),
 		      SvAMAGIC(left)?
 		        "in overloaded package ":
@@ -1522,11 +1464,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *rig
   if (!notfound) {
     DEBUG_o( Perl_deb(aTHX_
   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
-		 PL_AMG_names[off],
+		 AMG_id2name(off),
 		 method+assignshift==off? "" :
 		             " (initially `",
 		 method+assignshift==off? "" :
-		             PL_AMG_names[method+assignshift],
+		             AMG_id2name(method+assignshift),
 		 method+assignshift==off? "" : "')",
 		 flags & AMGf_unary? "" :
 		   lr==1 ? " for right argument": " for left argument",
@@ -1586,7 +1528,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *rig
     PUSHs(lr>0? left: right);
     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
     if (notfound) {
-      PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
+      PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
     }
     PUSHs((SV*)cv);
     PUTBACK;
--- ./perl.h~	Fri Nov 17 19:14:35 2000
+++ ./perl.h	Thu Dec 14 21:48:22 2000
@@ -3047,41 +3047,47 @@ enum {
 };
 
 #define NofAMmeth max_amg_code
+#define AMG_id2name(id) ((char*)PL_AMG_names[id]+1)
 
 #ifdef DOINIT
 EXTCONST char * PL_AMG_names[NofAMmeth] = {
-  "fallback",	"abs",			/* "fallback" should be the first. */
-  "bool",	"nomethod",
-  "\"\"",	"0+",
-  "+",		"+=",
-  "-",		"-=",
-  "*",		"*=",
-  "/",		"/=",
-  "%",		"%=",
-  "**",		"**=",
-  "<<",		"<<=",
-  ">>",		">>=",
-  "&",		"&=",
-  "|",		"|=",
-  "^",		"^=",
-  "<",		"<=",
-  ">",		">=",
-  "==",		"!=",
-  "<=>",	"cmp",
-  "lt",		"le",
-  "gt",		"ge",
-  "eq",		"ne",
-  "!",		"~",
-  "++",		"--",
-  "atan2",	"cos",
-  "sin",	"exp",
-  "log",	"sqrt",
-  "x",		"x=",
-  ".",		".=",
-  "=",		"neg",
-  "${}",	"@{}",
-  "%{}",	"*{}",
-  "&{}",	"<>",
+  /* Names kept in the symbol table.  fallback => "()", the rest has
+     "(" prepended.  The only other place in perl which knows about
+     this convention is AMG_id2name (used for debugging output and
+     'nomethod' only), the only other place which has it hardwired is
+     overload.pm.  */
+  "()",		"(abs",			/* "fallback" should be the first. */
+  "(bool",	"(nomethod",
+  "(\"\"",	"(0+",
+  "(+",		"(+=",
+  "(-",		"(-=",
+  "(*",		"(*=",
+  "(/",		"(/=",
+  "(%",		"(%=",
+  "(**",	"(**=",
+  "(<<",	"(<<=",
+  "(>>",	"(>>=",
+  "(&",		"(&=",
+  "(|",		"(|=",
+  "(^",		"(^=",
+  "(<",		"(<=",
+  "(>",		"(>=",
+  "(==",	"(!=",
+  "(<=>",	"(cmp",
+  "(lt",	"(le",
+  "(gt",	"(ge",
+  "(eq",	"(ne",
+  "(!",		"(~",
+  "(++",	"(--",
+  "(atan2",	"(cos",
+  "(sin",	"(exp",
+  "(log",	"(sqrt",
+  "(x",		"(x=",
+  "(.",		"(.=",
+  "(=",		"(neg",
+  "(${}",	"(@{}",
+  "(%{}",	"(*{}",
+  "(&{}",	"(<>",
 };
 #else
 EXTCONST char * PL_AMG_names[NofAMmeth];

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About