Code Index:

package Language::Zcode::Translator::Perl
EOF

NAME

Language::Zcode::Translator::Perl - Translate Z-code into Perl code

routine_start

This sub writes out a string that starts a sub. Basically, we need to handle setting local variables the sub was called with, and declaring an empty eval stack.

The much more complicated situation is when we're restoring a game in which this sub was in the call stack when @save was called. If sub A called B called C, which saved, then when we restore the save, we'll start executing sub C, right after the @save command - and we need to set the local variables and eval stack in C to the values they had when we saved. When we return from C, z_call will call B, which needs to start executing at the command right after the call to C. But when we start executing B, for example, the local variables and eval stack need to be set to the values they had when we called C. (We get that information from the save file.)

Arg 0 of the created sub will be an arrayref. It's empty for normal calls. However, if we restored a game where this sub was in the call stack, then the sub will be called with information giving the sub's state when it called the next sub in the stack (or @save): namely, arg0 will then contain the PC where we should resume execution, and the values to set the eval stack to.

arg1-argn will contain input values for the local variables. If we're restoring, those values will be the values from the appropriate frame of the call stack.

Note: it's legal to pass in too many or too few args. Set only as many values as were passed in, & don't auto-expand array. (Important pre-V5, when local var initial values may not be 0)

package Language::Zcode::Translator::Perl; use strict; use warnings;

@Language::Zcode::Translator::Perl::ISA = qw(Language::Zcode::Translator::Generic); my $indent = ""; # indent subs for readability sub new { my ($class, @arg) = @_; bless {}, $class; } # Write the beginning of the program sub program_start { my $self = shift; my $top = <<'ENDTOP'; #!perl -w use strict; use Getopt::Std; use Language::Zcode::Runtime::Opcodes; # Perl translation of complex opcodes use Language::Zcode::Runtime::State; # save/restore game state use Language::Zcode::Runtime::IO; # All IO stuff # Set constants use vars qw(%Constants); CONSTANTS_HERE ############### # Read user input my %opts; my $Usage = <<"ENDUSAGE"; $0 [-r rows] [-c columns] [-t terminal] [-d] -r, -c say how big to make the screen -t specifies a "dumb" terminal or slightly smarter "win32" terminal (hopefully will be adding more terminals soon) -d debug. Write information about which sub we're in, set \$DEBUG, etc. ENDUSAGE getopts("dr:c:t:", \%opts) or die "$Usage\n"; my $DEBUG = defined $opts{d}; # Build and run the Z-machine my $Z_Result = Language::Zcode::Runtime::Opcodes::Z_machine(%opts); # If Z_Result was an error, do a (non-eval'ed) die to really die. die $Z_Result if $Z_Result; exit; ############################################# ENDTOP # Version-dependent constants in Z-file become true constants in output # file my $cstr = join("", "\%Constants = (\n", map({ " $_ => $Language::Zcode::Util::Constants{$_},\n" } sort keys %Language::Zcode::Util::Constants), ");\n" ); $top =~ s/^CONSTANTS_HERE/$cstr/m; return $top; }

sub routine_start { my ($self, $addr, @params) = @_; my $name = "rtn$addr"; $indent = " " x 4; my $hex_address = sprintf("%x", ($name =~ /\d+/ && $&)); my $start = "sub $name {\n"; my $out_str = <<'ENDRTN1'; # single quotes make life a bit easier my ($t1, $t2, @stack, @locv); if (my @frame = @{shift @_}) { @locv = @{$frame[1]}; @stack = @{$frame[2]}; goto "L$frame[0]"; } else { @locv = (PUT_VALS_HERE); @locv[0 .. ($#_ > $#locv ? $#locv : $#_)] = @_; } ENDRTN1 $out_str =~ s/PUT_VALS_HERE/join(", ", @params)/e; # default values $out_str =~ s/^(?!$)/$indent/gm; return "$start$out_str"; } sub routine_end { $indent = ""; return "}\n\n"; } ##############################################3 # # Opcode translations... # Z_* will later be replaced with values of %parsed # _SW implements conversion to signed word. # Branching "?(label)" and results "-> (result)" are not put into these # translations because they're always handled the same way. # # SPEC 2.2: The operations of numerical comparison, multiplication, # addition, subtraction, division, remainder-after-division and printing of # numbers are signed; bitwise operations are unsigned. # # WARNING!!! If the same Z_* is found twice in the same translation, # and that Z_* is translated to "pop@stack", bad things could happen! # So use temporary variables. # XXX Maybe I should fix this somehow, e.g. s/// add's translation to: # $Z_A = $parsed{a}; $Z_B = $parsed{b}; _SW#\$Z_A# + _SW#$Z_B#; # Then I can use $Z_FOO in the translation without fear. # Only problem is things like make_var, especially var_to_lval my %replace_trans = ( # Arithmetic ops add => "_SW#Z_A# + _SW#Z_B#", 'sub' => "_SW#Z_A# - _SW#Z_B#", mul => "_SW#Z_A# * _SW#Z_B#", div => "int(_SW#Z_A# / _SW#Z_B#)", # Perl: # (13 % -5) == -2; Zcode: 13 % -5 = (13 - (-5 * -2)) = 3 # How many times does $y fit into $x; always round towards zero! # Use commas so we can later set $result = (..., ... , a%b) mod=>'($t1 = _SW#Z_A#, $t2 = _SW#Z_B#, $t1 - $t2*int($t1/$t2))', # logical ops - make sure we get the right number of bits 'or' => "Z_A | Z_B", 'and'=> "Z_A & Z_B", 'not' => "0xffff & ~Z_VALUE", log_shift => '($t1 = _SW#Z_PLACES#) > 0 ' . '? Z_NUMBER << $t1 : (Z_NUMBER & 0xffff) >> -$t1', # The |(...) fills in 1s from the left if bit fifteen (sign bit) is set art_shift => 'do { $t2 = Z_NUMBER; ($t1 = _SW#Z_PLACES#) > 0 ? Z_NUMBER << $t1 : ($t2 >> -$t1) | ($t2>>15 && ~(2**-$t1))}', # Jumps (conditional & unconditional) jump => "goto LZ_LABEL", # Branch instructions just write their conditions: they'll be added to later jz => "Z_A == 0", jg => "_SW#Z_A# > _SW#Z_B#", jl => "_SW#Z_A# < _SW#Z_B#", # jump if all given flags in the given bitmap are set test => '(Z_BITMAP & ($t1 = Z_FLAGS)) == $t1', # Zspec 1.1 'je 5' is illegal. # I need to do _SW for the case of je -1 65535 # XXX If I move this to sub_trans, then I can use grep for > 2 args, # and just test == for 2 args. je => '$t1 = Z_A, grep {_SW#$t1# == _SW#$_#} (_ARG_LIST)', # Stack and Variables # Note: this is where Z_VARIABLE lives - indirect variables. Beware! 'pop' => 'pop @stack', 'push' => 'push @stack, Z_VALUE', pull => 'Z_VARIABLE = pop @stack', store => "Z_VARIABLE = Z_VALUE", load => "Z_VARIABLE", # Spec15.html#inc: "This is signed, so -1 increments to 0." # Spec15.html#dec: "This is signed, so 0 decrements to -1." inc => "++Z_VARIABLE", dec => "--Z_VARIABLE", inc_chk => "_SW#++Z_VARIABLE# > _SW#Z_VALUE#", dec_chk => "_SW#--Z_VARIABLE# < _SW#Z_VALUE#", # Memory access loadb => '$PlotzMemory::Memory[(Z_ARRAY + Z_BYTE_INDEX) & 0xffff]', loadw => '256*$PlotzMemory::Memory[$t1=(Z_ARRAY + 2*Z_WORD_INDEX) & 0xffff] + $PlotzMemory::Memory[$t1 + 1]', storeb => '$PlotzMemory::Memory[(Z_ARRAY + Z_BYTE_INDEX) & 0xffff] = Z_VALUE & 0xff', storew => '$PlotzMemory::Memory[$t1 = (Z_ARRAY + 2*Z_WORD_INDEX) & 0xffff] = ($t2 = Z_VALUE)>>8 & 0xff, $PlotzMemory::Memory[$t1 + 1] = $t2 & 0xff', # Return ret => "return Z_VALUE", ret_popped => "return (pop \@stack)", rtrue => "return 1", rfalse => "return 0", # Print_* # print is equivalent to print_addr with address of the literal string! "print" => '# print "Z_PRINT_STRING" &write_text(&decode_text(Z_LITERAL_STRING))', print_ret => '# print "Z_PRINT_STRING" &write_text(&decode_text(Z_LITERAL_STRING)); &newline(); return(1)', print_num => "&write_text(_SW#Z_VALUE#)", print_addr => "&write_text(&decode_text(Z_BYTE_ADDRESS_OF_STRING))", # This is why we need to store entire program in memory print_paddr => "&write_text(&decode_text(Z_PACKED_ADDRESS_OF_STRING))", # XXX We're doing ASCII. Need to do ZSCII print_char => "&write_zchar(Z_OUTPUT_CHARACTER_CODE)", new_line => "&newline()", # Other I/O "read" => "&z_read(Z_TEXT, Z_PARSE, Z_TIME, Z_ROUTINE)", show_status => "&show_status()", tokenise => "&z_tokenise(Z_TEXT, Z_PARSE, Z_DICTIONARY, Z_FLAG)", # Streams & windows & cursors output_stream => "&output_stream(_SW#Z_NUMBER#)", # arg may be < 0 input_stream => "&input_stream(Z_NUMBER)", split_window => "&split_window(Z_LINES)", set_window => "&set_window(Z_WINDOW)", erase_window => "&erase_window(_SW#Z_WINDOW#)", # arg may be < 0 get_cursor => "&get_cursor(Z_ARRAY)", set_cursor => "&set_cursor(_SW#Z_LINE#, Z_COLUMN, Z_WINDOW)", # < 0 for v6 set_text_style => "&set_text_style(Z_STYLE)", # Objects get_parent => "get_parent(Z_OBJECT)", get_child => "get_child(Z_OBJECT)", get_sibling => "get_sibling(Z_OBJECT)", jin => "Z_OBJ2 == &get_object(&thing_location(Z_OBJ1, 'parent'))", print_obj => "&write_text(&decode_text(&thing_location(Z_OBJECT, 'name')))", insert_obj => "&insert_obj(Z_OBJECT, Z_DESTINATION)", remove_obj => "&remove_obj(Z_OBJECT)", # Properties get_prop => "&get_prop(Z_OBJECT, Z_PROPERTY)", put_prop => "&put_prop(Z_OBJECT, Z_PROPERTY, Z_VALUE)", get_next_prop => "&get_next_prop(Z_OBJECT, Z_PROPERTY)", get_prop_addr => "&get_prop_addr(Z_OBJECT, Z_PROPERTY)", get_prop_len => "&get_prop_len(Z_PROPERTY_ADDRESS)", # Attributes set_attr => "&set_attr(Z_OBJECT, Z_ATTRIBUTE)", clear_attr => "&clear_attr(Z_OBJECT, Z_ATTRIBUTE)", test_attr => "&test_attr(Z_OBJECT, Z_ATTRIBUTE)", # Save/restore # XXX Different for v1-3 save => '&save_state(Z_RESTORE_PC, \@locv, \@stack)', restore => "&restore_state", # Spec "save_undo": terp must return -1 if it doesn't implement save_undo save_undo => "-1", # Spec "restore_undo": illegal for a game to use this if save_undo # returns -1. restore_undo => "0", restart => 'die "Restart\n"', # Misc check_arg_count => '@_ >= Z_ARGUMENT_NUMBER', quit => 'die "Quit\n"', # Spec 15, 'piracy': "Interpreters are asked to be gullible" piracy => "1", random => "&z_random(_SW#Z_RANGE#)", verify => "&z_verify()", nop => 1, # Calls: Z subs are turned into Perl subs # Use Perl's calling stack instead of building a separate one BUT do some # bookkeeping (w/ extra args) to be able to save/restore machine state call_1s => 'z_call(Z_ROUTINE, \@locv, \@stack, Z_NEXT_PC, Z_RESULT_NUM, _ARG_LIST)', ); # All call subs work the same! (store var will be set to undef for call_*n, # and "result = " will be added to call_s). @replace_trans{qw(call_2s call_vs call_vs2 call_1n call_2n call_vn call_vn2)} = ($replace_trans{call_1s}) x 7; #@replace_trans{ qw(call_2n call_vn call_vn2) } = ($replace_trans{call_1n}) x 3; # Translate Z opcode and ops into Perl my %unimplemented; # keep track of unimplemented opcodes sub translate_command { # Keys to %parsed are based on the arguments in the opcode syntax list # in LZ::Parser::Opcode. There's a few others I put in: # - opcode, opcode address are the name & address of the opcode # - result is variable name (or stack top) where we're supposed # to store the result, if any # - negate_jump means negate the condition of jump opcodes # - jump_return means return this value (0 or 1) instead of branching # if the branch condition is met # - op is an arrayref to remaining arguments (used for e.g., call_*) my ($self, $href) = @_; my %parsed = %$href; my $opcode = $parsed{opcode} or return; # totally unknown opcode? my $command = "OOPS. No Command Here\n"; # command to return my %sub_trans = ( # There's nothing to see here. Move along... ); # Build the actual line of Perl code # XXX Only print labels we actually jump to? Requires separate pass. my $label = "L$parsed{opcode_address}: "; # Quetzal stores the byte BEFORE the next command as its restore_pc, # so we'll eventually call a sub and try to goto that address. $label .= "1; L$parsed{restore_pc}: " if exists $parsed{restore_pc}; # Translate, e.g., "local1" to language-specific # code representing second local variable # Treat key "variable" specially - it's used in "indirect opcodes" # (See make_var) foreach my $key (keys %parsed) { my %skip = map {$_=>1} qw(args jump_return label literal_string negate_jump next_pc opcode opcode_address print_string restore_pc); if (!exists $skip{$key}) { #warn "$key $parsed{$key}\n"; warn "undefined $key\n" if !defined $parsed{$key}; $parsed{$key} = $self->make_var($parsed{$key}, $key eq "variable"); } } # Pack addresses foreach my $key (qw(packed_address_of_string routine)) { if (exists $parsed{$key}) { $parsed{$key} = $self->packed_address_str($parsed{$key}, $key); } } # Turn variable number of args (if any) into a Perl list # Btw, call_1n takes no args, so arg_list will be "" for call_1n, too my $arg_list = exists $parsed{args} ? join(", ", map {$self->make_var($_)} @{$parsed{"args"}}) : ""; # Turn Z ops into Perl ops if (exists $replace_trans{$opcode}) { local $_ = $replace_trans{$opcode}; # Put in actual arguments # (Note that sometimes there's a letter before the Z, # but never after the whole key.) # If there are optional args, then some of the args won't exist. # First handle things where we set an lval to an rval s/Z_(\w+)\s+=\s+(.+)/$self->var_to_lval($parsed{lc $1}, $2)/e; s/([+-]{2})Z_(\w+)/$self->var_to_lval($parsed{lc $2}, $1)/e; s/Z_(\w+)/exists $parsed{lc $1} ? $parsed{lc $1}:"undef"/ge; s/_ARG_LIST/$arg_list/; s/, (undef(, )?)?\)(;|$)/)$3/; # clean up unneeded args # Change numbers to signed/unsigned words. s/_SW#(.*?)#/$self->signed_word($1)/ge; # print "$parsed{opcode_address} $command\n"; $command = $_; } elsif (exists $sub_trans{$opcode}) { $command = &{$sub_trans{$opcode}}(); } else { warn "Unimplemented opcode $opcode at $parsed{opcode_address}\n" unless $unimplemented{$opcode}++; $command = "&unimplemented_$opcode"; } # Handle commands that have a "-> (result)" argument # (result has already been translated from e.g. 3 to 'local2') $command = $self->var_to_lval($parsed{result}, $command) if exists $parsed{result}; # Handle branch instructions # Do this AFTER store_result, so we get "goto L3 if $c = $a+$b" # rather than "$c = goto L3 if $c=$a+$b" # (Note: jump doesn't count as a branch instruction!) # (This assumes Perl command is pretty simple) if (exists $parsed{negate_jump}) { my $action; if (exists $parsed{jump_return}) { $action = "return $parsed{jump_return}"; } else { die "no label for command!" unless exists $parsed{label}; $action = "goto L$parsed{label}"; } my $cond .= $parsed{negate_jump} ? "unless" : "if"; $command = "$action $cond $command"; } $command = "$indent$label$command;\n"; return ($command); } # Change the rval created by make_var to an lval (HACKISH!) # Note that when we get called, make_var has already been called on the lval, # generating possibly incorrect # If $lval is an indirect variable (see make_var), then the variable # is really an RVAL which returns a variable that should be treated as an LVAL! # E.g., store [g0f] 17 means "set the variable represented by the number # stored in global_var(15) to 17" so global_var(15) is still treated as an rval. # If global_var(15) is 0 ("sp"), then treat sp as an LVAL, i.e., # push 17 onto the stack # XXX Now that indirect var is treated differently, can I merge this # XXX back into make_var, only called with an extra arg? # Special case: if $rval is ++ or --, then inc/dec the lval. sub var_to_lval { my ($self, $lval, $rval) = @_; local $_ = $lval; # for convenience in //'s. # XXX what's correct protocol for store [sp] sp? # Pop stack before reading indirect variable? my $is_bracket = /bracket_var$/; # $rval = "($rval) % 0x10000"; if ($is_bracket) { # add $rval to args to bracket_var $rval =~ s/^[+-]{2}$/"$&"/; # Yuck! s/$$/, $rval)/; } elsif (/global_var/) { # global_var(number) -> global_var(number, rval) $rval =~ s/^[+-]{2}$/"$&"/; # Yuck! s/\)$/, $rval)/; } elsif (/locv/) { # $locv[num] -> $locv[num] = rval if ($rval eq "++" || $rval eq "--") { my $op = substr($rval, 0, 1); # XXX this wrong. Spec 15#dec/inc say this should be signed! # XXX So it should really be: # $_ = "($_ = ($_ $_ = "($_ = ($_ $op 1) & 0xffff)"; } else { $_ .= " = $rval"; } } elsif (/stack/) { # pop @stack -> $stack[@stack] = rval # push returns number of elements in array. I need the value I pushed. # If indirect variable, this s/// won't happen. s/pop$\@stack$/\$stack[\@stack]/; if ($rval eq "++" || $rval eq "--") { my $op = substr($rval, 0, 1); $_ = "($_ = ($_ $op 1) & 0xffff)"; } else { $_ .= " = $rval"; } } else { warn "Unexpected arg to var_to_lval $lval"; } return $_; } # Create a string describing a variable from the given string. # (e.g., '$locv[2]' from 'local2') # Indirect variables are a special case - stack doesn't get popped. # Usually, it'll be a string describing the stack ("sp"), or a local # or global variable. But if it's an expression in [], then # e.g., [local2] means the value of the variable stored in # $locv[2]. If $locv[2] is 11, then we really want the value stored in # $locv[10]! sub make_var { my ($self, $var, $is_indirect) = @_; my $is_bracket = ($var =~ s/\[(.*)\]/$1/); local $_ = $var; if (/^g([\da-f]+)$/) { # Global variable my $var_num = hex($1); $_ = "&global_var($var_num)"; } elsif (/^local([\da-f]+)$/) { # Local variable $_ = "\$locv[$1]"; } elsif ($_ eq "sp") { # Stack # Spec Version 1.1 (draft7): "an indirect reference to the stack # pointer does not push or pull the top item of the stack - it is read # or written in place." # ADK: From testing (winfrotz2002) it apears this is true for # "load sp". "load [sp]" does pop the stack in getting the number # of the variable to use. But if sp == 0, "load [sp]" still pops # only once. $_ = $is_indirect && !$is_bracket ? '$stack[-1]' : 'pop(@stack)'; } elsif (/^\d+$/) { # Leave the numeric constant as it is } else { # not a number? What is it? warn "Unexpected arg to make_var: '$var'"; # keep the garbage in the output file } # Get the value stored in the variable referenced by the current $_ # Pass in local variables & stack so we have their values. # No, pass in *refs* to local variables & stack, in case the indirect # var is an lval which references e.g. a local variable which we # then need to set within indirect_var! $_ = "bracket_var($_, \\\@locv, \\\@stack)" if $is_bracket; return $_; } # Convert num to signed_word & unsigned_word. Stolen from Games::Rezrov. # Signed word: if high bit is set, take ~ number, else just the number # IF the expression we're sign'ing is just an integer constant, # convert it to a signed word constant now. # Otherwise, the term is a variable, so we just have to put in Perl code # that will convert it at runtime # Note that dzip and zip fail *differently* on test.inf wrt signed numbers! sub signed_word { my ($self, $exp) = @_; # $exp =~ s/^$(.*)$$/$1/ # or die "Unexpected expression '$exp' to signed_word\n"; my $ret; if ($exp =~ /^\d+$/) { $ret = $exp & 0x8000 ? $exp - 0x10000 : $exp; } else { # XXX Aha! $ret = "($exp-0x8000) % 0x10000 - 0x8000" $ret = "unpack('s', pack('s', $exp))"; } return $ret; } # XXX might need to also explicity cast to unsigned # when setting variables - see Games::Rezrov::StoryFile sub unsigned_word { return "unpack('S', pack('s', $_[1]))"; } sub newlineify { my $s = pop; $s =~ s/\n/\\n/g; return $s; } # Write memory to the file, as well as code to read it back # (and to store original dynamic memory) sub write_memory { my ($self) = @_; # Top of package my $str = q( { package PlotzMemory; use vars qw(@Memory); my @Dynamic_Orig; sub get_byte_at { $Memory[$_[0]] } sub set_byte_at { $Memory[$_[0]] = $_[1] & 0xff; } sub get_word_at { ($Memory[$_[0]] << 8) + $Memory[$_[0] + 1]; } sub set_word_at { $Memory[$_[0]] = $_[1]>>8; $Memory[$_[0] + 1] = $_[1] & 0xff; } ); # change each byte to two hex digits my $l = @Language::Zcode::Util::Memory; my $flen = $Language::Zcode::Util::Constants{file_length}; # stated length # Spec1.1: "Padding" # The standard currently states that story file padding beyond the length # specified in the header must be all zero bytes. Many Infocom story files # in fact contain non-zero data in the padding, so interpreters must be # sure to exclude the padding from checksum calculations. my $hexed = ""; for (my $c = 0; $c < $l; $c+=16) { # Add hex "line number" & \n's. my $len = $l - $c; $len = 16 if $len > 16; $hexed .= sprintf("%06x " . " %02x" x $len . "\n", $c, @Language::Zcode::Util::Memory[$c .. $c + $len -1]); } # Actually, this is $#dynamic, not @dynamic my $dynamic_size = $Language::Zcode::Util::Constants{static_memory_address} - 1; $str .= <<"ENDUNPACK"; sub read_memory { # (The map below removes address number and hexifies the other numbers) my \$c = 0; # Addr 0 1 2 3 4 5 6 7 8 9 a b c d e f \@Memory = map {\$c++ % 17 ? hex : ()} qw( $hexed ); \@Dynamic_Orig = \@Memory[0 .. $dynamic_size]; } sub checksum { my \$header_size = 0x40; # don't count header bytes. my \$sum = 0; for (\@Dynamic_Orig[\$header_size .. $dynamic_size -1], \@Memory[$dynamic_size .. $flen-1]) { \$sum += \$_; } # 512K * 256 = 128M: definitely less than 2G max integer size for Perl. # so we don't need to do mod within the for loop \$sum = \$sum % 0x10000; return \$sum; } sub get_dynamic_memory { [\@Memory[0 .. $dynamic_size]]; } sub get_orig_dynamic_memory { [\@Dynamic_Orig]; } my \$restore_mem_ref; sub store_dynamic_memory { \$restore_mem_ref = shift; } # Reset memory EXCEPT the couple bits that get saved even during a restart. sub reset_dynamic_memory { my \$restoring = shift; Language::Zcode::Runtime::IO::store_restart_bits(); \@Memory[0 .. $dynamic_size] = \$restoring ? \@\$restore_mem_ref : \@Dynamic_Orig; } } # End package PlotzMemory ENDUNPACK return $str; } # This functionality is supplied by the "use Language::Zcode::Runtime" at the # top of the program (written in program_start) sub library { return ""; } 1;