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