#!/usr/bin/perl ################################################################################ ### ### ### RPL ### ### PERL Reverse Polish Lisp Interpreter ### ### ### ### (c) YLS 2000 ### ### landrin@multimania.fr ### ### ### ### ### ################################################################################ # Copyright (c) 2000 YLS, All Rights Reserved. # # This software can be redistributed or modified under the terms of the GNU # # General Public License as published by the Free Software Foundation, version # # 2 or later. # # # # YLS MAKES NO REPRESENTATIONS OR WARRANTIES ABOUT THE SUITABILITY OF THE # # SOFTWARE, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE # # IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, # # OR NON-INFRINGEMENT. YLS SHALL NOT BE LIABLE FOR ANY DAMAGES SUFFERED BY # # LICENSEE AS A RESULT OF USING, MODIFYING OR DISTRIBUTING THIS SOFTWARE OR # # ITS DERIVATIVES. # # THIS SOFTWARE IS NOT DESIGNED OR INTENDED FOR USE OR RESALE AS ON-LINE # # CONTROL EQUIPMENT IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE PERFORMANCE, # # SUCH AS IN THE OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR # # COMMUNICATION SYSTEMS, AIR TRAFFIC CONTROL, DIRECT LIFE SUPPORT MACHINES, OR # # WEAPONS SYSTEMS, IN WHICH THE FAILURE OF THE SOFTWARE COULD LEAD DIRECTLY TO # # DEATH, PERSONAL INJURY, OR SEVERE PHYSICAL OR ENVIRONMENTAL DAMAGE # # ("HIGH RISK ACTIVITIES"). YLS SPECIFICALLY DISCLAIMS ANY EXPRESS OR IMPLIED # # WARRANTY OF FITNESS FOR HIGH RISK ACTIVITIES. # # # VERSION 1.05 package RPL ; BEGIN { use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); $VERSION = 1.05 ; # $VERSION = do{my@r=q$Revision: 1.05 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r}; @ISA = qw(Exporter); @EXPORT = qw(); @EXPORT_OK = qw(&PrintStack &PrintThing &PrintBar &BuiltinDescribe &Run &Execute &Parse $BltnError $BltnTable $UserTable); %EXPORT_TAGS = ( 'PRINT' => qw!&PrintStack &PrintThing &PrintBar! , 'HELP' => qw!&BuiltinDescribe! , 'RUN' => qw!&Run! , 'EXEC' => qw!&Execute! , 'PARSE' => qw!&Parse! , 'TABLES' => qw!$BltnError $BltnTable $UserTable! , ) ; } ################################################################################ ################################################################################ ### ### Data, memory and stack printing ### ### PrintStack # Args: 1_ (arry)stack [ 2_ (scal)max [ 3_ (scal)width ] ] # Returns: (scal)stack_image # # Prints a stack sub PrintStack($) { my($stk,$max,$wth,$ind,$thg,$str) ; $stk = shift ; $max = shift || 40 ; $wth = shift || 80 ; if($max>@{$stk}) { $max = @{$stk} ; } $ind = 0 ; $str = "" ; while($ind<$max) { $str = sprintf("%03.3s: %*.*s\n",$ind,$wth-5,$wth-5, PrintThing($stk->[$ind])) . $str ; $ind ++ ; } return $str ; } ### PrintThing # Args: 1_ (????)thing # Returns: (scal)string # # Prints a 'thing': scalar, array ref, hash ref, func ref, etc... sub PrintThing($) { my($thg,@thg,$str,$itm) ; $thg = shift ; $str = "" ; if(ref($thg) eq 'REF') { return "\\ ${$thg}" ; } if(ref($thg) eq 'SCALAR') { return "\'${$thg}\'" ; } if(ref($thg) eq 'ARRAY') { if(@{$thg}) { @thg = @{$thg} ; $str = "[ ".PrintThing(shift(@thg)) ; for $itm (@thg) { $str .= ", ".PrintThing($itm) ; } $str .= " ]" ; return $str ; } return "[ ]" ; } if(ref($thg) eq 'HASH') { if(@{$thg}) { @thg = @{$thg} ; $itm = shift(@thg) ; $str = "{ ".$itm." => ".$thg->{$itm} ; for $itm (@thg) { $str .= ", ".$itm." => ".$thg->{$itm} ; } $str .= " }" ; return $str ; } return "{ }" } if(ref($thg) eq 'CODE') { return "BUILTIN(&{$thg})" ; } if(!ref($thg)) { return "$thg" ; } return "UNKNOWN($thg)" ; } ### PrintBar # Args: 1_ (scal)char [2_ (scal) width [3_ (scal)header] ] # Returns: (scal)bar # # Prints a bar, repeating the given character sub PrintBar($;$$) { my($chr,$wth,$inc) ; $chr = shift ; $wth = shift || 80 ; $inc = shift || "" ; while(length($inc)<$wth) { $inc .= $chr ; } return $inc ; } ################################################################################ ################################################################################ ### ### Type, printing and checking oddities ### sub BuiltinDescribe($) { my $thg = shift ; if(exists($BltnTable->{$thg})) { return "BUILTIN : ".$thg."\n" . " Arg count : ".sprintf("%u",$BltnTable->{$thg}->[1])."\n" . " Type check: ".sprintf("%x",$BltnTable->{$thg}->[2])."\n" . " ".$BltnTable->{$thg}->[3]."\n" ; } else { return "NO SUCH BUILTIN : ".$thg."\n" ; } } sub IsANumber($) { my $thg = shift ; if(ref($thg)) { return 0 ; } if($thg =~ m/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/gso) { return 1 ; } return 0 ; } sub IsAString($) { my $thg = shift ; if(ref($thg) eq 'SCALAR') { return 1 ; } return 0 ; } sub IsABuiltin($) { my $thg = shift ; if(exists($BltnTable->{$thg})) { return 1 ; } return 0 ; } sub IsABlock($) { my $thg = shift ; if(ref($thg) eq 'ARRAY') { return 1 ; } return 0 ; } sub Equals($$) { my $thg1 = shift ; my $thg2 = shift ; if($thg1 eq $thg2) { return 1 ; } if(ref($thg1) eq ref($thg2)) { if(ref($thg1) eq 'SCALAR') { return Equals(${$thg1},${$thg2}) ; } if( (ref($thg1) eq 'ARRAY') && (scalar(@{$thg1}) == scalar(@{$thg2})) ) { for(my $i=0;$i[$i],$thg2->[$i])) { return 0 ; } } } if( (ref($thg1) eq 'HASH') && (scalar(keys %{$thg1}) == scalar(keys %{$thg2})) ) { for my $k (keys %{$thg1}) { if(!defined($thg2->{$k})) { return 0 ; } if(!Equals($thg1->{$k},$thg2->{$k})) { return 0 ; } } } } return 0 ; } sub Print($) { my($thg,@thg,$str,$itm) ; $thg = shift ; $str = "" ; if(ref($thg) eq 'REF') { return Print(${$thg}) ; } if(ref($thg) eq 'SCALAR') { return Print(${$thg}) ; } if(ref($thg) eq 'ARRAY') { if(@{$thg}) { @thg = @{$thg} ; $str = "[ ".Print(shift(@thg)) ; for $itm (@thg) { $str .= " ".Print($itm) ; } $str .= " ]" ; return $str ; } return "[ ]" ; } if(!ref($thg)) { $thg = "$thg" ; $thg =~ s/([^\\]|^)\\t/$1\t/gso ; $thg =~ s/([^\\]|^)\\n/$1\n/gso ; $thg =~ s/([^\\]|^)\\r/$1\r/gso ; $thg =~ s/([^\\]|^)\\f/$1\f/gso ; $thg =~ s/([^\\]|^)\\a/$1\a/gso ; $thg =~ s/([^\\]|^)\\([^\\]|$)/$1$2/gso ; $thg =~ s/([^\\]|^)\\\\/$1\\/gso ; return $thg ; } return "UNKNOWN($thg)" ; } ################################################################################ ################################################################################ ### ### Execution routines ### ### Run # Args: 1_ (arry)exec_tree # Returns: (none) # # Executes a program-tree, and prints the result stack, or the error status sub Run($) { my $ext = shift ; my($stk,$var,$stat,$err) ; $stk = [] ; $var = {} ; ($stat,$err) = Execute($ext,$stk,$var) ; if(!$stat) { print "\nOK\n" ; } else { print "\nERR ".$stat." > ".$err."\n" ; } print PrintBar("=",80,"== STACK ") . "\n" ; print PrintStack($stk) ; print PrintBar("=",80) . "\n" ; } ################################################################################ ### Execute # Args: 1_ (arry)exec_tree 2_ (arry)arg_stack # Returns: [(scal)status,(scal)err_mesg] # # Execute a RPL program, on a stack, calling builtins for # flow control and operations sub Execute($$$) { my($ext, $stk, $var) ; $ext = shift ; $stk = shift ; $var = shift ; my($inst, @inst, $stat, $err, $argn) ; @inst = @{$ext} ; while(@inst) { $inst = shift @inst ; if(ref($inst) eq 'ARRAY') { #print ">>DBG Dumping block ".PrintThing($inst)." on stack\n" ; unshift @{$stk}, $inst ; } elsif(ref($inst) eq 'SCALAR') { #print ">>DBG Dumping $inst on stack\n" ; unshift @{$stk}, $inst ; } elsif(!ref($inst)) { if(exists($BltnTable->{$inst})) { # Beg Builtin-lookup #print ">>DBG Calling $inst in BltnTable\n" ; CHECK: { # BegChecks # Definition Check if( (!defined($BltnTable->{$inst})) || (scalar(@{$BltnTable->{$inst}})<4) ) { ($stat,$err) = @{$BltnError->{'NOBLTN'}} ; last CHECK ; } # Implementation Check if( (!defined($BltnTable->{$inst}->[0])) || (ref($BltnTable->{$inst}->[0]) ne 'CODE') ) { ($stat,$err) = @{$BltnError->{'UNIMPL'}} ; last CHECK ; } # Argument count check if(scalar(@{$stk})<$BltnTable->{$inst}->[1]) { ($stat,$err) = @{$BltnError->{'TOOFEWARG'}} ; last CHECK ; } # Argument type check $argn = 0 ; while($argn<$BltnTable->{$inst}->[1]) { if( ( (($BltnTable->{$inst}->[2]>>($argn*4+0))&0x1) && (!IsANumber($stk->[$argn])) ) || ( (($BltnTable->{$inst}->[2]>>($argn*4+1))&0x1) && (!IsAString($stk->[$argn])) ) || ( (($BltnTable->{$inst}->[2]>>($argn*4+2))&0x1) && (!IsABuiltin($stk->[$argn])) ) || ( (($BltnTable->{$inst}->[2]>>($argn*4+3))&0x1) && (!IsABlock($stk->[$argn])) ) ) { ($stat,$err) = ($BltnError->{'INVARGTYP'}->[0], $BltnError->{'INVARGTYP'}->[1]." (".$stk->[$argn].")") ; last CHECK ; } $argn++ ; } ($stat,$err) = $BltnTable->{$inst}->[0]->($stk,$var) ; } # End Checks if($stat) { #print ">>DBG Call for $inst returned $stat>$err\n" ; $err = "ERROR IN \'".$inst."\' [".$err."]\n" ; last ; } } # End Builtin-lookup elsif(exists($UserTable->{$inst})) { # Beg User's Lookup #print ">>DBG Calling $inst in UserTable\n" ; CHECK: { # BegChecks # Definition Check if( (!defined($UserTable->{$inst})) || (scalar(@{$UserTable->{$inst}})<4) ) { ($stat,$err) = @{$BltnError->{'NOUSER'}} ; last CHECK ; } # Implementation Check if( (!defined($UserTable->{$inst}->[0])) || (ref($UserTable->{$inst}->[0]) ne 'CODE') ) { ($stat,$err) = @{$BltnError->{'UNIMPL'}} ; last CHECK ; } # Argument count check if(scalar(@{$stk})<$UserTable->{$inst}->[1]) { ($stat,$err) = @{$BltnError->{'TOOFEWARG'}} ; last CHECK ; } # Argument type check $argn = 0 ; while($argn<$UserTable->{$inst}->[1]) { if( ( (($UserTable->{$inst}->[2]>>($argn*4+0))&0x1) && (!IsANumber($stk->[$argn])) ) || ( (($UserTable->{$inst}->[2]>>($argn*4+1))&0x1) && (!IsAString($stk->[$argn])) ) || ( (($UserTable->{$inst}->[2]>>($argn*4+2))&0x1) && (!IsABuiltin($stk->[$argn])) ) || ( (($UserTable->{$inst}->[2]>>($argn*4+3))&0x1) && (!IsABlock($stk->[$argn])) ) ) { ($stat,$err) = ($BltnError->{'INVARGTYP'}->[0], $BltnError->{'INVARGTYP'}->[1]." (".$stk->[$argn].")") ; last CHECK ; } $argn++ ; } ($stat,$err) = $UserTable->{$inst}->[0]->($stk,$var) ; } # End Checks if($stat) { #print ">>DBG Call for $inst returned $stat>$err\n" ; $err = "ERROR IN \'".$inst."\' [".$err."]\n" ; last ; } } # End User's Lookup else { #print ">>DBG Dumping $inst on stack\n" ; unshift @{$stk}, $inst ; } } else { #print ">>DBG Data incoherence in $inst\n" ; $err = "DATA INCOHERENCE [".$inst."]\n" ; $stat = -1 ; last ; } #print ">>DBG ".PrintBar("=")."\n" ; #print PrintStack($stk) ; #print ">>DBG ".PrintBar("=")."\n" ; } if($stat) { #print ">>DBG Leaving on ".$stat." (".$cntr."): ".$err."\n" ; return ($stat,$err) ; } return (0,"") ; } ################################################################################ ################################################################################ ### ### Built-in tables ### ################################################################################ ### BUILT-IN ERRORS TABLE FORMAT # # 'BUILTIN_ERROR' => [ # $errnum , # $errmsg , # ] *BltnError = \{ '' => [ 0, "" ] , 'OK' => [ 0, "" ] , 'UNHDLD' => [ 1, "Unhandled error" ] , 'RNTERR' => [ 2, "Run time error" ] , 'DTINCR' => [ 3, "Incoherent data" ] , 'SYSERR' => [ 4, "System error" ] , 'IOSERR' => [ 5, "IO error" ] , 'EXCERR' => [ 6, "Exec error" ] , 'NOBLTN' => [ 7, "Unknown built-in operator" ] , 'UNIMPL' => [ 8, "Not implemented" ] , 'NOUSER' => [ 9, "Unknown user-defined operator" ] , 'TOOFEWARG' => [ 10, "Too few arguments" ] , 'INVARGTYP' => [ 11, "Invalid argument type" ] , 'INVARGVAL' => [ 12, "Invalid argument value" ] , 'NOSUCHVAR' => [ 30, "No such variable" ] , 'PARSERR' => [ 40, "Parse Error" ] , 'RESERVED' => [ 99, "Reserved error" ] , } ; ################################################################################ ### BUILT-IN COMMANDS TABLE FORMAT # # 'BUILTIN_NAME' => [ # \&func_name , # $arity , # $arg_check , # $description , # ] # # sub func_name($) : handler function, returns ($errnum,$errmsg), arguments are # the stack as an array reference and # the variables as a hash reference # $arity : number of arguments we ask for # $arg_check : argument type check, a 4-bit group for each argument, 'or'-ed # 1 for INTEGER, 2 for STRING, 4 for BUILTIN, 8 for COMPOUND # $description : a short description string *BltnTable = \{ '' => undef , '\'' => [ undef , 0 , 0 , "" ] , ' ' => [ sub { return 0 ; } , 0 , 0 , "" ] , 'NOP' => [ \&NOP , 0 , 0 , "" ] , 'ERR' => [ \&ERR , 2 , 0x21 , "Aborts with specified error" ] , 'DIE' => [ \&DIE , 1 , 0x2 , "Dies with the specified message" ] , 'HELP' => [ \&HELP , 1 , 0x4 , "Returns the description of a builtin" ] , 'DUMP' => [ \&DUMP , 0 , 0 , "Prints the stack" ] , 'PRINT' => [ \&PRINT , 1 , 0 , "Prints an object" ] , 'FLSE' => [ \&FLSE , 0 , 0 , "Always False" ] , 'TRUE' => [ \&TRUE , 0 , 0 , "Always True" ] , 'EQL' => [ \&EQL , 2 , 0 , "Tests if two objects are equal" ] , 'NOT' => [ \&NOT , 1 , 0x1 , "Boolean negation" ] , 'AND' => [ \&AND , 2 , 0x11 , "Boolean conjunction" ] , 'OR' => [ \&OR , 2 , 0x11 , "Boolean disjunction" ] , 'NUMB' => [ \&NUMB , 1 , 0 , "Boolean type test for a number" ] , 'STRG' => [ \&STRG , 1 , 0 , "Boolean type test for a string" ] , 'COMP' => [ \&COMP , 1 , 0 , "Boolean type test for a compound object" ] , 'BLTN' => [ \&BLTN , 1 , 0 , "Boolean type test for a builtin command" ] , '<' => [ \&NLT , 2 , 0x11 , "Boolean " ] , '>' => [ \&NGT , 2 , 0x11 , "Boolean " ] , '<=' => [ \&NLE , 2 , 0x11 , "Boolean " ] , '>=' => [ \&NGE , 2 , 0x11 , "Boolean " ] , '==' => [ \&NEQ , 2 , 0x11 , "Boolean " ] , '!=' => [ \&NNQ , 2 , 0x11 , "Boolean " ] , 'INC' => [ \&INC , 1 , 0x1 , "Numeric 1-incrementation" ] , 'DEC' => [ \&DEC , 1 , 0x1 , "Numeric 1-decrementation" ] , '+' => [ \&NADD , 2 , 0x11 , "Numeric addition" ] , '-' => [ \&NSUB , 2 , 0x11 , "Numeric substaction" ] , '*' => [ \&NMUL , 2 , 0x11 , "Numeric product" ] , '/' => [ \&NDIV , 2 , 0x11 , "Numeric quotient" ] , '@' => [ \&NPOW , 2 , 0x11 , "Numeric power" ] , '%' => [ \&IMOD , 2 , 0x11 , "Integer remainder" ] , ':' => [ \&IQOT , 2 , 0x11 , "Integer exact division" ] , '|' => [ \&BOR , 2 , 0x11 , "Bitwise or" ] , '&' => [ \&BAND , 2 , 0x11 , "Bitwise and" ] , '^' => [ \&BXOR , 2 , 0x11 , "Bitwise xor" ] , '~' => [ \&BCMP , 1 , 0x1 , "Bitwise 1-complement" ] , 'UNDEF' => [ \&UNDEF , 0 , 0 , "Pushes 'undef'" ] , 'ISDEF' => [ \&ISDEF , 1 , 0 , "Tells wether first object on stack is 'undef'" ] , 'EXEC' => [ \&EXEC , 1 , 0x8 , "Execution of a portion of code" ] , 'IF' => [ \&IF , 2 , 0x81 , "'If then' control structure" ] , 'IFE' => [ \&IFE , 3 , 0x881 , "'If then else' control structure" ] , 'LOOP' => [ \&LOOP , 1 , 0x8 , "Loops until code execution return false" ] , 'BRK' => [ \&BRK , 1 , 0x8 , "Breaks a compound object" ] , 'GRP' => [ \&GRP , 1 , 0x1 , "Builds a compound object" ] , 'CAT' => [ \&CAT , 2 , 0x88 , "Concatenes two compound objects" ] , 'GSZ' => [ \&GSZ , 1 , 0x8 , "Size of a compound object" ] , 'STR' => [ \&STR , 1 , 0 , "Makes a string from an object" ] , 'OBJ' => [ \&OBJ , 1 , 0x2 , "Parse a string into objects" ] , 'DEP' => [ \&DEP , 0 , 0 , "Depth of the stack" ] , 'DROP' => [ \&DROP , 1 , 0 , "Drops the first object on stack" ] , 'DUP' => [ \&DUP , 1 , 0 , "Duplicates the first object on stack" ] , 'SWAP' => [ \&SWAP , 2 , 0 , "Swaps the two first objects on stack" ] , 'CLRSTK' => [ \&CLRSTK , 0 , 0 , "Clears the stack" ] , 'DROPN' => [ \&DROPN , 1 , 0x1 , "Drops the N first object on stack" ] , 'DUPN' => [ \&DUPN , 1 , 0x1 , "Duplicates the N first objects on stack in order" ] , 'PEEK' => [ \&PEEK , 1 , 0x1 , "Gets the object on level stack[0]" ] , 'POKE' => [ \&POKE , 2 , 0x1 , "Puts the object stack[1] on level stack[0]" ] , 'PONG' => [ \&PONG , 2 , 0x1 , "Inserts the object stack[1] on level stack[0]" ] , 'ROLSTK' => [ \&ROLSTK , 0 , 0 , "Rolls down the last object on stack, if any" ] , 'ROTSTK' => [ \&ROTSTK , 0 , 0 , "Rolls up the first object on stack, if any" ] , 'STOV' => [ \&STOV , 2 , 0x2 , "Stores a value in a variable" ] , 'RCLV' => [ \&RCLV , 1 , 0x2 , "Recalls a variable's value" ] , 'CALV' => [ \&CALV , 1 , 0x2 , "Execute a variable's content" ] , 'EXSV' => [ \&EXSV , 1 , 0x2 , "Tells wether a variable is defined" ] , 'VARS' => [ \&VARS , 0 , 0 , "Lists all existing variables" ] , 'DELV' => [ \&DELV , 1 , 0x2 , "Undefines a variable" ] , } ; ################################################################################ ### USER TABLE (same format as builtin table) $UserTable = { '?' => [ sub { print "RPL 1.02\n" ; return (0,"") ; } , 0 , 0 , "Version information" ] , } ; ################################################################################ ################################################################################ ### ### Built-in functions ### sub NOP($$) { return (0,"") ; } sub ERR($$) { my $stk = shift ; return (shift @{$stk},${shift @{$stk}}) ; } sub DIE($$) { my $stk = shift ; die ${shift @{$stk}}."\n" ; } sub HELP($$) { my $stk = shift ; unshift @{$stk}, BuiltinDescribe(shift @{$stk}) ; return (0,"") ; } sub DUMP($$) { my $stk = shift ; print PrintBar("-") . "\n" ; print PrintStack($stk) ; print PrintBar("-") . "\n" ; return (0,"") ; } sub PRINT($$) { local $| = 1 ; my $stk = shift ; print Print(shift @{$stk}) ; return (0,"") ; } sub FLSE($$) { my $stk = shift ; unshift @{$stk}, 0 ; return (0,"") ; } sub TRUE($$) { my $stk = shift ; unshift @{$stk}, 1 ; return (0,"") ; } sub EQL($$) { my $stk = shift ; unshift @{$stk}, Equals(shift @{$stk},shift @{$stk}) ; return (0,"") ; } sub NOT($$) { my $stk = shift ; unshift @{$stk}, ((shift @{$stk})?0:1) ; return (0,"") ; } sub AND($$) { my $stk = shift ; my $bln1 = shift @{$stk} ; my $bln2 = shift @{$stk} ; unshift @{$stk}, (($bln1 && $bln2)?1:0) ; return (0,"") ; } sub OR($$) { my $stk = shift ; my $bln1 = shift @{$stk} ; my $bln2 = shift @{$stk} ; unshift @{$stk}, (($bln1 || $bln2)?1:0) ; return (0,"") ; } sub NUMB($$) { my $stk = shift ; unshift @{$stk}, IsANumber(shift @{$stk}) ; return (0,"") ; } sub STRG($$) { my $stk = shift ; unshift @{$stk}, IsAString(shift @{$stk}) ; return (0,"") ; } sub COMP($$) { my $stk = shift ; unshift @{$stk}, IsABlock(shift @{$stk}) ; return (0,"") ; } sub BLTN($$) { my $stk = shift ; unshift @{$stk}, (exists($BltnTable->{(shift @{$stk})})?1:0) ; return (0,"") ; } sub NLT($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, (($num2<$num1)?1:0) ; return (0,"") ; } sub NGT($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, (($num2>$num1)?1:0) ; return (0,"") ; } sub NLE($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, (($num2<=$num1)?1:0) ; return (0,"") ; } sub NGE($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, (($num2>=$num1)?1:0) ; return (0,"") ; } sub NEQ($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, (($num2==$num1)?1:0) ; return (0,"") ; } sub NNQ($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, (($num2!=$num1)?1:0) ; return (0,"") ; } sub INC($$) { my $stk = shift ; my $ind = shift @{$stk} ; unshift @{$stk}, $ind+1 ; return (0,"") ; } sub DEC($$) { my $stk = shift ; my $ind = shift @{$stk} ; unshift @{$stk}, $ind-1 ; return (0,"") ; } sub NADD($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2+$num1) ; return (0,"") ; } sub NSUB($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2-$num1) ; return (0,"") ; } sub NMUL($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2*$num1) ; return (0,"") ; } sub NDIV($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; if($num2==0) { return ($BltnError->{'INVARGVAL'}->[0],$BltnError->{'INVARGVAL'}->[1]." ($num2)") ; } unshift @{$stk}, ($num2/$num1) ; return (0,"") ; } sub NPOW($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2**$num1) ; return (0,"") ; } sub IMOD($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2%$num1) ; return (0,"") ; } sub IQOT($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, int($num2/$num1) ; return (0,"") ; } sub BOR($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2|$num1) ; return (0,"") ; } sub BAND($$) { my $stk = shift ; if(@{$stk}<2) { return @{$BltnError->{'TOOFEWARG'}} ; } my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2&$num1) ; return (0,"") ; } sub BXOR($$) { my $stk = shift ; my $num1 = shift @{$stk} ; my $num2 = shift @{$stk} ; unshift @{$stk}, ($num2^$num1) ; return (0,"") ; } sub BCMP($$) { my $stk = shift ; my $num = shift @{$stk} ; unshift @{$stk}, (~$num) ; return (0,"") ; } sub UNDEF($$) { my $stk = shift ; unshift @{$stk}, undef ; return (0,"") ; } sub ISDEF($$) { my $stk = shift ; my $thg = shift @{$stk} ; unshift @{$stk}, (defined($thg)?1:0) ; return (0,"") ; } sub EXEC($$) { my $stk = shift ; my $var = shift ; return Execute(shift @{$stk},$stk,$var) ; } sub IF($$) { my $stk = shift ; my $var = shift ; my $cnd = shift @{$stk} ; my $blk = shift @{$stk} ; if($cnd) { return Execute($blk,$stk,$var) ; } return (0,"") ; } sub IFE($$) { my $stk = shift ; my $var = shift ; my $cnd = shift @{$stk} ; my $def = shift @{$stk} ; my $blk = shift @{$stk} ; if($cnd) { return Execute($blk,$stk,$var) ; } return Execute($def,$stk,$var) ; } sub LOOP($$) { my $stk = shift ; my $var = shift ; my $blk = shift @{$stk} ; my $stat = 0 ; my $err = "" ; my $bln = 0 ; while(1) { ($stat,$err) = Execute($blk,$stk,$var) ; if($stat) { return ($stat,$err) ; } if(!@{$stk}) { return @{$BltnError->{'TOOFEWARG'}} ; } $bln = shift @{$stk} ; if(!IsANumber($bln)) { return ($BltnError->{'INVARGTYP'}->[0],$BltnError->{'INVARGTYP'}->[1]." ($bln)") ; } if(!$bln) { last ; } } return (0,"") ; } sub BRK($$) { my $stk = shift ; my $blk = shift @{$stk} ; unshift @{$stk}, reverse(@{$blk}) ; unshift @{$stk}, scalar(@{$blk}) ; return (0,"") ; } sub GRP($$) { my $stk = shift ; my $sz = shift @{$stk} ; my @blk = () ; if(@{$stk}<$sz) { return ($BltnError->{'INVARGVAL'}->[0],$BltnError->{'INVARGVAL'}->[1]." ($sz)") ; } @blk = reverse(splice(@{$stk},0,$sz)) ; unshift @{$stk}, \@blk ; return (0,"") ; } sub CAT($$) { my $stk = shift ; my $blk1 = shift @{$stk} ; my $blk2 = shift @{$stk} ; my @blk = () ; push @blk, @{$blk2}, @{$blk1} ; unshift @{$stk}, \@blk ; return (0,"") ; } sub GSZ($$) { my $stk = shift ; unshift @{$stk}, scalar(@{(shift @{$stk})}) ; return (0,"") ; } sub STR($$) { my $stk = shift ; my $thg = shift @{$stk} ; unshift @{$stk}, \Print($thg) ; return (0,"") ; } sub OBJ($$) { my $stk = shift ; my $str = shift @{$stk} ; my $code ; ($code,$str) = Parse("[ ".${$str}." ]") ; if(ref($code) ne 'ARRAY') { return ($BltnError->{'PARSERR'}->[0],$BltnError->{'PARSERR'}->[1]." (".substr($str,0,10).")") ; } unshift @{$stk}, @{$code} ; return (0,"") ; } sub DEP($$) { my $stk = shift ; unshift @{$stk}, scalar(@{$stk}) ; return (0,"") ; } sub DROP($$) { my $stk = shift ; shift @{$stk} ; return (0,"") ; } sub DUP($$) { my $stk = shift ; my $thg = shift @{$stk} ; unshift @{$stk}, $thg ; unshift @{$stk}, $thg ; return (0,"") ; } sub SWAP($$) { my $stk = shift ; my $th1 = shift @{$stk} ; my $th2 = shift @{$stk} ; unshift @{$stk}, $th1 ; unshift @{$stk}, $th2 ; return (0,"") ; } sub CLRSTK($$) { my $stk = shift ; @{$stk} = () ; return (0,"") ; } sub DROPN($$) { my $stk = shift ; my $num = shift @{$stk} ; if(@{$stk}<$num) { return ($BltnError->{'INVARGVAL'}->[0],$BltnError->{'INVARGVAL'}->[1]." ($num)") ; } if($num>0) { splice(@{$stk},0,$num) ; } return (0,"") ; } sub DUPN($$) { my $stk = shift ; my $num = shift @{$stk} ; my @blk = () ; if(@{$stk}<$num) { return ($BltnError->{'INVARGVAL'}->[0],$BltnError->{'INVARGVAL'}->[1]." ($num)") ; } if($num>0) { @blk = splice(@{$stk},0,$num) ; unshift @{$stk}, @blk ; unshift @{$stk}, @blk ; } return (0,"") ; } sub PEEK($$) { my $stk = shift ; my $num = shift @{$stk} ; if(@{$stk}<$num) { return ($BltnError->{'INVARGVAL'}->[0],$BltnError->{'INVARGVAL'}->[1]." ($num)") ; } if($num>0) { unshift @{$stk}, $stk->[$num-1] ; } return (0,"") ; } sub POKE($$) { my $stk = shift ; my $num = shift @{$stk} ; my $thg = shift @{$stk} ; if(@{$stk}<$num) { return ($BltnError->{'INVARGVAL'}->[0],$BltnError->{'INVARGVAL'}->[1]." ($num)") ; } if($num>0) { $stk->[$num-1] = $thg ; } return (0,"") ; } sub PONG($$) { my $stk = shift ; my $num = shift @{$stk} ; my $thg = shift @{$stk} ; if(@{$stk}<$num) { return ($BltnError->{'INVARGVAL'}->[0],$BltnError->{'INVARGVAL'}->[1]." ($num)") ; } if($num>0) { splice(@{$stk},$num-1,0,$thg) ; } return (0,"") ; } sub ROLSTK($$) { my $stk = shift ; if(@{$stk}) { unshift @{$stk}, (pop @{$stk}) ; } return (0,"") ; } sub ROTSTK($$) { my $stk = shift ; if(@{$stk}) { push @{$stk}, (shift @{$stk}) ; } return (0,"") ; } sub STOV($$) { my $stk = shift ; my $var = shift ; my $name = shift @{$stk} ; my $val = shift @{$stk} ; $var->{${$name}} = $val ; return (0,"") ; } sub RCLV($$) { my $stk = shift ; my $var = shift ; my $name = shift @{$stk} ; if(!exists($var->{${$name}})) { return ($BltnError->{'NOSUCHVAR'}->[0],$BltnError->{'NOSUCHVAR'}->[1]." (${$name})") ; } unshift @{$stk}, $var->{${$name}} ; return (0,"") ; } sub CALV($$) { my $stk = shift ; my $var = shift ; my $name = shift @{$stk} ; if(!exists($var->{${$name}})) { return ($BltnError->{'NOSUCHVAR'}->[0],$BltnError->{'NOSUCHVAR'}->[1]." (${$name})") ; } return Execute($var->{${$name}},$stk,$var) ; } sub EXSV($$) { my $stk = shift ; my $var = shift ; my $name = shift @{$stk} ; unshift @{$stk}, (exists($var->{${$name}})?1:0) ; return (0,"") ; } sub VARS($$) { my $stk = shift ; my $var = shift ; my @var = () ; for my $v (keys(%{$var})) { push @var, \$v ; } unshift @{$stk}, \@var ; return (0,"") ; } sub DELV($$) { my $stk = shift ; my $var = shift ; my $name = shift @{$stk} ; if(!exists($var->{${$name}})) { return ($BltnError->{'NOSUCHVAR'}->[0],$BltnError->{'NOSUCHVAR'}->[1]." (${$name})") ; } delete $var->{${$name}} ; return (0,"") ; } ################################################################################ ################################################################################ ### ### RPL program parsing ### ### Parse # Args: 1_ (scal)code_string # Returns: [(scal)exec_ref,(scal)remain_string] # # Parses a RPL program string-representation, returning the parsed code # as an array ref or an error string, and the remaining unparsed string sub Parse($) { my $str = shift ; my($t,@code) ; ($t,$str) = split(/\[\s*/gso,$str,2) ; #print ">>DBG Comment: $t\n" ; while($str !~ m/^\s*$/gso) { if($str =~ m/^\s*\]/gso) { ($t,$str) = split(/^\s*\]\s*/gso,$str,2) ; #print ">>DBG End match, cut |$t|\n" ; last ; } elsif($str =~ m/^\s*\[/gso) { my $block ; ($block,$str) = Parse($str) ; #print ">>DBG Block match, remains |$str|\n" ; if(ref($block) ne 'ARRAY') { return ("",$str) ; } #print ">>DBG Block is @{$block}\n" ; push @code, $block ; } elsif($str =~ m/^\s*«/gso) { my $chunk ; ($t,$chunk,$str) = split(/^\s*«([^"]*)»/gso,$str,3) ; #print ">>DBG Built-in match for [$chunk], remains |$str|\n" ; push @code, $chunk ; } elsif($str =~ m/^\s*"/gso) { my $chunk ; ($t,$chunk,$str) = split(/^\s*"([^"]*)"/gso,$str,3) ; #print ">>DBG String match for [$chunk], remains |$str|\n" ; push @code, \$chunk ; } elsif($str =~ m/^\s*'/gso) { my $chunk ; ($t,$chunk,$str) = split(/^\s*'([^']*)'/gso,$str,3) ; #print ">>DBG Quoted match for [$chunk], remains |$str|\n" ; push @code, \$chunk ; } elsif($str =~ m/^\s*[^\[\]]/gso) { # Redundant, but kept for later use my $chunk ; ($t,$chunk,$str) = split(/^\s*([^\s\]]+)(?=[\s\]])/gso,$str,3) ; #print ">>DBG Atom match for [$chunk], remains |$str|\n" ; if(exists($BltnTable->{$chunk})) { push @code, $chunk ; } elsif($chunk =~ m/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/gso) { push @code, $chunk ; } else { push @code, \$chunk ; } } else { return ("",$str) ; } } return (\@code,$str) ; } ### ### THE END !!! ### ################################################################################ ################################################################################ ################################################################################ 1;