home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _6aa31097ba3ca6f036061406953b5a73 < prev    next >
Text File  |  2000-03-15  |  9KB  |  347 lines
  1. #      Stackobj.pm
  2. #
  3. #      Copyright (c) 1996 Malcolm Beattie
  4. #
  5. #      You may distribute under the terms of either the GNU General Public
  6. #      License or the Artistic License, as specified in the README file.
  7. #
  8. package B::Stackobj;  
  9. use Exporter ();
  10. @ISA = qw(Exporter);
  11. @EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
  12.         VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
  13. %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
  14.         flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
  15.                  VALID_UNSIGNED REGISTER TEMPORARY)]);
  16.  
  17. use Carp qw(confess);
  18. use strict;
  19. use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
  20.  
  21. # Types
  22. sub T_UNKNOWN () { 0 }
  23. sub T_DOUBLE ()  { 1 }
  24. sub T_INT ()     { 2 }
  25. sub T_SPECIAL () { 3 }
  26.  
  27. # Flags
  28. sub VALID_INT ()    { 0x01 }
  29. sub VALID_UNSIGNED ()    { 0x02 }
  30. sub VALID_DOUBLE ()    { 0x04 }
  31. sub VALID_SV ()        { 0x08 }
  32. sub REGISTER ()        { 0x10 } # no implicit write-back when calling subs
  33. sub TEMPORARY ()    { 0x20 } # no implicit write-back needed at all
  34. sub SAVE_INT ()     { 0x40 } #if int part needs to be saved at all
  35. sub SAVE_DOUBLE ()     { 0x80 } #if double part needs to be saved at all
  36.  
  37.  
  38. #
  39. # Callback for runtime code generation
  40. #
  41. my $runtime_callback = sub { confess "set_callback not yet called" };
  42. sub set_callback (&) { $runtime_callback = shift }
  43. sub runtime { &$runtime_callback(@_) }
  44.  
  45. #
  46. # Methods
  47. #
  48.  
  49. sub write_back { confess "stack object does not implement write_back" }
  50.  
  51. sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
  52.  
  53. sub as_sv {
  54.     my $obj = shift;
  55.     if (!($obj->{flags} & VALID_SV)) {
  56.     $obj->write_back;
  57.     $obj->{flags} |= VALID_SV;
  58.     }
  59.     return $obj->{sv};
  60. }
  61.  
  62. sub as_int {
  63.     my $obj = shift;
  64.     if (!($obj->{flags} & VALID_INT)) {
  65.     $obj->load_int;
  66.     $obj->{flags} |= VALID_INT|SAVE_INT;
  67.     }
  68.     return $obj->{iv};
  69. }
  70.  
  71. sub as_double {
  72.     my $obj = shift;
  73.     if (!($obj->{flags} & VALID_DOUBLE)) {
  74.     $obj->load_double;
  75.     $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
  76.     }
  77.     return $obj->{nv};
  78. }
  79.  
  80. sub as_numeric {
  81.     my $obj = shift;
  82.     return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
  83. }
  84.  
  85. sub as_bool {
  86.     my $obj=shift;
  87.     if ($obj->{flags} & VALID_INT ){
  88.         return $obj->{iv}; 
  89.     }
  90.     if ($obj->{flags} & VALID_DOUBLE ){
  91.         return $obj->{nv}; 
  92.     }
  93.     return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
  94. }
  95.  
  96. #
  97. # Debugging methods
  98. #
  99. sub peek {
  100.     my $obj = shift;
  101.     my $type = $obj->{type};
  102.     my $flags = $obj->{flags};
  103.     my @flags;
  104.     if ($type == T_UNKNOWN) {
  105.     $type = "T_UNKNOWN";
  106.     } elsif ($type == T_INT) {
  107.     $type = "T_INT";
  108.     } elsif ($type == T_DOUBLE) {
  109.     $type = "T_DOUBLE";
  110.     } else {
  111.     $type = "(illegal type $type)";
  112.     }
  113.     push(@flags, "VALID_INT") if $flags & VALID_INT;
  114.     push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
  115.     push(@flags, "VALID_SV") if $flags & VALID_SV;
  116.     push(@flags, "REGISTER") if $flags & REGISTER;
  117.     push(@flags, "TEMPORARY") if $flags & TEMPORARY;
  118.     @flags = ("none") unless @flags;
  119.     return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
  120.            class($obj), join("|", @flags));
  121. }
  122.  
  123. sub minipeek {
  124.     my $obj = shift;
  125.     my $type = $obj->{type};
  126.     my $flags = $obj->{flags};
  127.     if ($type == T_INT || $flags & VALID_INT) {
  128.     return $obj->{iv};
  129.     } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
  130.     return $obj->{nv};
  131.     } else {
  132.     return $obj->{sv};
  133.     }
  134. }
  135.  
  136. #
  137. # Caller needs to ensure that set_int, set_double,
  138. # set_numeric and set_sv are only invoked on legal lvalues.
  139. #
  140. sub set_int {
  141.     my ($obj, $expr,$unsigned) = @_;
  142.     runtime("$obj->{iv} = $expr;");
  143.     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
  144.     $obj->{flags} |= VALID_INT|SAVE_INT;
  145.     $obj->{flags} |= VALID_UNSIGNED if $unsigned; 
  146. }
  147.  
  148. sub set_double {
  149.     my ($obj, $expr) = @_;
  150.     runtime("$obj->{nv} = $expr;");
  151.     $obj->{flags} &= ~(VALID_SV | VALID_INT);
  152.     $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
  153. }
  154.  
  155. sub set_numeric {
  156.     my ($obj, $expr) = @_;
  157.     if ($obj->{type} == T_INT) {
  158.     $obj->set_int($expr);
  159.     } else {
  160.     $obj->set_double($expr);
  161.     }
  162. }
  163.  
  164. sub set_sv {
  165.     my ($obj, $expr) = @_;
  166.     runtime("SvSetSV($obj->{sv}, $expr);");
  167.     $obj->invalidate;
  168.     $obj->{flags} |= VALID_SV;
  169. }
  170.  
  171. #
  172. # Stackobj::Padsv
  173. #
  174.  
  175. @B::Stackobj::Padsv::ISA = 'B::Stackobj';
  176. sub B::Stackobj::Padsv::new {
  177.     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
  178.     $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
  179.     $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
  180.     bless {
  181.     type => $type,
  182.     flags => VALID_SV | $extra_flags,
  183.     sv => "PL_curpad[$ix]",
  184.     iv => "$iname",
  185.     nv => "$dname"
  186.     }, $class;
  187. }
  188.  
  189. sub B::Stackobj::Padsv::load_int {
  190.     my $obj = shift;
  191.     if ($obj->{flags} & VALID_DOUBLE) {
  192.     runtime("$obj->{iv} = $obj->{nv};");
  193.     } else {
  194.     runtime("$obj->{iv} = SvIV($obj->{sv});");
  195.     }
  196.     $obj->{flags} |= VALID_INT|SAVE_INT;
  197. }
  198.  
  199. sub B::Stackobj::Padsv::load_double {
  200.     my $obj = shift;
  201.     $obj->write_back;
  202.     runtime("$obj->{nv} = SvNV($obj->{sv});");
  203.     $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
  204. }
  205. sub B::Stackobj::Padsv::save_int {
  206.     my $obj = shift;
  207.     return $obj->{flags} & SAVE_INT;
  208. }
  209.  
  210. sub B::Stackobj::Padsv::save_double {
  211.     my $obj = shift;
  212.     return $obj->{flags} & SAVE_DOUBLE;
  213. }
  214.  
  215. sub B::Stackobj::Padsv::write_back {
  216.     my $obj = shift;
  217.     my $flags = $obj->{flags};
  218.     return if $flags & VALID_SV;
  219.     if ($flags & VALID_INT) {
  220.         if ($flags & VALID_UNSIGNED ){
  221.             runtime("sv_setuv($obj->{sv}, $obj->{iv});");
  222.         }else{
  223.             runtime("sv_setiv($obj->{sv}, $obj->{iv});");
  224.         }     
  225.     } elsif ($flags & VALID_DOUBLE) {
  226.     runtime("sv_setnv($obj->{sv}, $obj->{nv});");
  227.     } else {
  228.     confess "write_back failed for lexical @{[$obj->peek]}\n";
  229.     }
  230.     $obj->{flags} |= VALID_SV;
  231. }
  232.  
  233. #
  234. # Stackobj::Const
  235. #
  236.  
  237. @B::Stackobj::Const::ISA = 'B::Stackobj';
  238. sub B::Stackobj::Const::new {
  239.     my ($class, $sv) = @_;
  240.     my $obj = bless {
  241.     flags => 0,
  242.     sv => $sv    # holds the SV object until write_back happens
  243.     }, $class;
  244.     if ( ref($sv) eq  "B::SPECIAL" ){
  245.     $obj->{type}= T_SPECIAL;    
  246.     }else{
  247.         my $svflags = $sv->FLAGS;
  248.         if ($svflags & SVf_IOK) {
  249.         $obj->{flags} = VALID_INT|VALID_DOUBLE;
  250.         $obj->{type} = T_INT;
  251.                 if ($svflags & SVf_IVisUV){
  252.                     $obj->{flags} |= VALID_UNSIGNED;
  253.                     $obj->{nv} = $obj->{iv} = $sv->UVX;
  254.                 }else{
  255.                     $obj->{nv} = $obj->{iv} = $sv->IV;
  256.                 }
  257.         } elsif ($svflags & SVf_NOK) {
  258.         $obj->{flags} = VALID_INT|VALID_DOUBLE;
  259.         $obj->{type} = T_DOUBLE;
  260.         $obj->{iv} = $obj->{nv} = $sv->NV;
  261.         } else {
  262.         $obj->{type} = T_UNKNOWN;
  263.         }
  264.     }
  265.     return $obj;
  266. }
  267.  
  268. sub B::Stackobj::Const::write_back {
  269.     my $obj = shift;
  270.     return if $obj->{flags} & VALID_SV;
  271.     # Save the SV object and replace $obj->{sv} by its C source code name
  272.     $obj->{sv} = $obj->{sv}->save;
  273.     $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
  274. }
  275.  
  276. sub B::Stackobj::Const::load_int {
  277.     my $obj = shift;
  278.     if (ref($obj->{sv}) eq "B::RV"){
  279.        $obj->{iv} = int($obj->{sv}->RV->PV);
  280.     }else{
  281.        $obj->{iv} = int($obj->{sv}->PV);
  282.     }
  283.     $obj->{flags} |= VALID_INT;
  284. }
  285.  
  286. sub B::Stackobj::Const::load_double {
  287.     my $obj = shift;
  288.     if (ref($obj->{sv}) eq "B::RV"){
  289.         $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
  290.     }else{
  291.         $obj->{nv} = $obj->{sv}->PV + 0.0;
  292.     }
  293.     $obj->{flags} |= VALID_DOUBLE;
  294. }
  295.  
  296. sub B::Stackobj::Const::invalidate {}
  297.  
  298. #
  299. # Stackobj::Bool
  300. #
  301.  
  302. @B::Stackobj::Bool::ISA = 'B::Stackobj';
  303. sub B::Stackobj::Bool::new {
  304.     my ($class, $preg) = @_;
  305.     my $obj = bless {
  306.     type => T_INT,
  307.     flags => VALID_INT|VALID_DOUBLE,
  308.     iv => $$preg,
  309.     nv => $$preg,
  310.     preg => $preg        # this holds our ref to the pseudo-reg
  311.     }, $class;
  312.     return $obj;
  313. }
  314.  
  315. sub B::Stackobj::Bool::write_back {
  316.     my $obj = shift;
  317.     return if $obj->{flags} & VALID_SV;
  318.     $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
  319.     $obj->{flags} |= VALID_SV;
  320. }
  321.  
  322. # XXX Might want to handle as_double/set_double/load_double?
  323.  
  324. sub B::Stackobj::Bool::invalidate {}
  325.  
  326. 1;
  327.  
  328. __END__
  329.  
  330. =head1 NAME
  331.  
  332. B::Stackobj - Helper module for CC backend
  333.  
  334. =head1 SYNOPSIS
  335.  
  336.     use B::Stackobj;
  337.  
  338. =head1 DESCRIPTION
  339.  
  340. See F<ext/B/README>.
  341.  
  342. =head1 AUTHOR
  343.  
  344. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  345.  
  346. =cut
  347.