package Anarres::Mud::Driver::Efun::Core; use strict; use warnings; use vars qw($VERSION @ISA); # XXX Where should I be requiring these: before or after bootstrap? use Anarres::Mud::Driver::Compiler::Type qw(:all); # We do this twice?! # Efuns need to be normal functions in a program symbol table but # will not inherit or issue a warning if redefined. # Note that we don't actually register all available efuns. We # register only those which are visible as efuns to the LPC code. # We may have more efuns, an individual efun typecheck_call method # may decide to rebless the node into a different efun class. # For example, map => map_array or map_mapping. In this way we # can use the Perl object oriented dispatch mechanism to speed up # many operations where a pure Perl conditional would be slower. require DynaLoader; $VERSION = 0.10; @ISA = qw(DynaLoader); bootstrap Anarres::Mud::Driver::Efun::Core; use Anarres::Mud::Driver::Compiler::Type qw(:all); # We do this twice?! use Anarres::Mud::Driver::Program::Efun qw(register); use Anarres::Mud::Driver::Program::Method; { # As traditional, [ flags, return type, argtype .... ] my $pflags = M_PURE | M_NOMASK; # This just lets me format nicely. my %efuns = ( # Common stuff copy => [ 0, T_UNKNOWN, T_UNKNOWN, ], # Object stuff this_object => [ 0, T_OBJECT, ], previous_object => [ 0, T_OBJECT, T_INTEGER, ], all_previous_objects=> [ 0, T_OBJECT->array ], file_name => [ 0, T_STRING, T_OBJECT, ], find_object => [ 0, T_OBJECT, T_STRING, ], load_object => [ 0, T_OBJECT, T_STRING, ], clone_object => [ 0, T_OBJECT, T_STRING, ], destruct => [ 0, T_INTEGER, T_OBJECT, ], children => [ 0, T_OBJECT->array, T_STRING, ], objects => [ 0, T_OBJECT->array, ], # String stuff implode => [ M_PURE, T_STRING, T_STRING->array, T_STRING ], explode => [ M_PURE, T_STRING->array, T_STRING, T_STRING ], lower_case => [ M_PURE, T_STRING, T_STRING, ], upper_case => [ M_PURE, T_STRING, T_STRING, ], strlen => [ M_PURE, T_INTEGER, T_STRING, ], replace_string => [ M_PURE, T_STRING, T_STRING, T_STRING, T_STRING, ], substr => [ M_PURE, T_STRING, T_STRING, T_INTEGER, T_INTEGER, # off T_INTEGER, T_INTEGER, ],# end subchar => [ M_PURE, T_INTEGER, T_STRING, # offset T_INTEGER, ], # from end? capitalize => [ M_PURE, T_STRING, T_STRING, ], strsrch => [ M_PURE, T_INTEGER, T_STRING, T_STRING, ], regexp => [ M_PURE, T_INTEGER, T_STRING, T_STRING, ], # XXX varargs sprintf => [ M_PURE, T_STRING, T_STRING, T_ARRAY, ], sscanf => [ M_PURE, T_STRING, T_STRING, T_ARRAY, ], # Array stuff member_array => [ M_PURE, T_INTEGER, T_UNKNOWN, T_ARRAY, ], unique_array => [ M_PURE, T_ARRAY->array, T_ARRAY, T_CLOSURE], # XXX We can map mappings. :-( map => [ 0, T_ARRAY, T_ARRAY, T_CLOSURE, ], filter => [ 0, T_ARRAY, T_ARRAY, T_CLOSURE, ], allocate => [ 0, T_ARRAY, T_INTEGER, T_UNKNOWN, ], # Mapping stuff keys => [ M_PURE, T_STRING->array, T_MAPPING, ], values => [ M_PURE, T_ARRAY, T_MAPPING, ], map_delete => [ 0, T_UNKNOWN, T_MAPPING,T_STRING,], # Type stuff to_int => [ M_PURE, T_INTEGER, T_STRING, ], to_string => [ M_PURE, T_STRING, T_INTEGER, ], typeof => [ M_PURE, T_STRING, T_UNKNOWN, ], sizeof => [ M_PURE, T_INTEGER, T_UNKNOWN, ], intp => [ $pflags, T_BOOL, T_UNKNOWN, ], stringp => [ $pflags, T_BOOL, T_UNKNOWN, ], arrayp => [ $pflags, T_BOOL, T_UNKNOWN, ], mapp => [ $pflags, T_BOOL, T_UNKNOWN, ], functionp => [ $pflags, T_BOOL, T_UNKNOWN, ], classp => [ $pflags, T_BOOL, T_UNKNOWN, ], objectp => [ $pflags, T_BOOL, T_UNKNOWN, ], clonep => [ M_PURE, T_BOOL, T_UNKNOWN, ], undefinedp => [ M_PURE, T_BOOL, T_UNKNOWN, ], # Closure stuff # XXX varargs evaluate => [ 0, T_UNKNOWN, T_CLOSURE, T_ARRAY, ], # Reflection function_exists => [ 0, T_OBJECT, T_STRING, T_INTEGER, ], functions => [ 0, T_OBJECT, T_INTEGER, ], variables => [ 0, T_OBJECT, T_INTEGER, ], inherits => [ M_PURE, T_INTEGER, T_STRING, T_OBJECT, ], call_stack => [ 0, T_STRING->array, T_INTEGER, ], # File stuff file_size => [ 0, T_INTEGER, T_STRING, ], read_file => [ 0, T_STRING, T_STRING, ], write_file => [ 0, T_INTEGER, T_STRING, T_STRING, ], # System stuff time => [ 0, T_INTEGER, ], debug_message => [ 0, T_STRING, T_STRING, ], error => [ 0, T_INTEGER, T_STRING, ], catch => [ 0, T_STRING, T_UNKNOWN, ], shutdown => [ 0, T_INTEGER, ], trace => [ 0, T_INTEGER, T_INTEGER, ], ); # We call this as an exported function since ISA isn't yet set up. foreach (keys %efuns) { register(__PACKAGE__ . "::" . $_, @{ $efuns{$_} }); } } { package Anarres::Mud::Driver::Efun::Core::time; sub generate_call { "time()" } } { package Anarres::Mud::Driver::Efun::Core::debug_message; sub generate_call { "print STDERR $_[1], '\\n'" } } { package Anarres::Mud::Driver::Efun::Core::previous_object; sub invoke { undef } } { package Anarres::Mud::Driver::Efun::Core::file_name; sub generate_call { "Anarres::Mud::Driver::Program::package_to_path(ref($_[1]))" } } { package Anarres::Mud::Driver::Efun::Core::find_object; # sub generate_call { "undef" } sub invoke { undef } } { package Anarres::Mud::Driver::Efun::Core::to_string; # XXX This only works for CONSTANT integers, of course. # sub generate_call { '"' . $_[1] . '"' } # This works for any integer which is about to be evaluated as # a string by Perl. 6 . 7 == "67"; sub generate_call { ('' . $_[1]) } } { package Anarres::Mud::Driver::Efun::Core::strlen; sub generate_call { "length($_[1])" } } { package Anarres::Mud::Driver::Efun::Core::error; sub generate_call { "die('LPC: ' . $_[1])" } } { package Anarres::Mud::Driver::Efun::Core::catch; sub generate_call { "do { eval { $_[1] }; $@; }"; } } { package Anarres::Mud::Driver::Efun::Core::implode; sub generate_call { "join($_[2], \@{ $_[1] })" } } { package Anarres::Mud::Driver::Efun::Core::explode; # invoke is an XSUB } { package Anarres::Mud::Driver::Efun::Core::replace_string; # invoke is an XSUB } { package Anarres::Mud::Driver::Efun::Core::intp; # sub generate_call { "(defined($_[1]) && !ref($_[1]))" } # invoke is an XSUB } { package Anarres::Mud::Driver::Efun::Core::stringp; # sub generate_call { "(defined($_[1]) && !ref($_[1]))" } # invoke is an XSUB } { package Anarres::Mud::Driver::Efun::Core::arrayp; sub generate_call { "ref($_[1]) eq 'ARRAY'" } } { package Anarres::Mud::Driver::Efun::Core::mapp; sub generate_call { "ref($_[1]) eq 'HASH'" } } { package Anarres::Mud::Driver::Efun::Core::objectp; sub generate_call { "ref($_[1]) =~ /::/" } # XXX } { package Anarres::Mud::Driver::Efun::Core::clonep; sub generate_call { "ref($_[1]) =~ /::/" } # XXX } { package Anarres::Mud::Driver::Efun::Core::undefinedp; sub generate_call { "defined($_[1])" } } { package Anarres::Mud::Driver::Efun::Core::keys; sub generate_call { "keys(\%{$_[1]})" } } { package Anarres::Mud::Driver::Efun::Core::values; sub generate_call { "values(\%{$_[1]})" } } { package Anarres::Mud::Driver::Efun::Core::map_delete; sub generate_call { "delete(\${$_[1]}->{$_[2]})" } } { package Anarres::Mud::Driver::Efun::Core::regexp; sub generate_call { "XXX($_[1] =~ m/$_[2]/)" } } { package Anarres::Mud::Driver::Efun::Core::clone_object; sub generate_call { "$_[1]\->new()" } } { package Anarres::Mud::Driver::Efun::Core::this_object; sub generate_call { '$self' } } { package Anarres::Mud::Driver::Efun::Core::strsrch; sub generate_call { "index($_[1], $_[2])" } } { package Anarres::Mud::Driver::Efun::Core::lower_case; sub generate_call { "lc($_[1])" } } { package Anarres::Mud::Driver::Efun::Core::upper_case; sub generate_call { "uc($_[1])" } } { package Anarres::Mud::Driver::Efun::Core::substr; # invoke is an XSUB } { package Anarres::Mud::Driver::Efun::Core::subchar; # invoke is an XSUB } { package Anarres::Mud::Driver::Efun::Core::capitalize; sub generate_call { "ucfirst($_[1])" } } { package Anarres::Mud::Driver::Efun::Core::allocate; sub generate_call { my $val = defined $_[2] ? $_[2] : 'undef'; return "[ ($val) x $_[1] ]" } } { package Anarres::Mud::Driver::Efun::Core::to_int; sub generate_call { "(0 + ($_[1]))" } } { package Anarres::Mud::Driver::Efun::Core::copy; sub invoke { $_[1] } # XXX dclone - but not for objects. } { package Anarres::Mud::Driver::Efun::Core::inherits; sub generate_call { "($_[2])->isa(XXX_to_package($_[1]))" } } { package Anarres::Mud::Driver::Efun::Core::sizeof; sub generate_call { # XXX Arse - use typechecking info! # XXX Deal with ints 'do { my $__a = ' . $_[1] . '; my $__r = ref($__a); ' . # ($#$__a + 1) ? '$__r eq "ARRAY" ? scalar(@{$__a}) : ' . '$__r eq "HASH" ? scalar(keys %{$__a}) : ' . '$__r eq "" ? length($__a) : ' . 'die "Cannot take sizeof($__r)"; }'; } } { package Anarres::Mud::Driver::Efun::Core::file_size; use Fcntl qw(:mode); sub invoke { my @stat = stat($_[1]); return -1 unless @stat; return -2 if ($stat[2] & S_IFDIR); return $stat[2]; } } { package Anarres::Mud::Driver::Efun::Core::map; use Anarres::Mud::Driver::Compiler::Type qw(:all); sub typecheck_call { my ($self, $program, $values, @rest) = @_; my $val = $values->[1]; my $func = $values->[2]; $func = $func->infer(T_CLOSURE); unless ($func) { $program->error("Argument 2 to map must be a closure."); } if (my $arr = $val->infer(T_ARRAY)) { # $values->[0] = "(pointer to map_array)"; $values->[1] = $arr; $arr->typecheck($program, undef, @rest) unless $arr == $val; return $arr->type; } elsif (my $map = $val->infer(T_MAPPING)) { # $values->[0] = "(pointer to map_mapping)"; $values->[1] = $map; $map->typecheck($program, undef, @rest) unless $map == $val; return $map->type; } elsif (my $str = $val->infer(T_STRING)) { $values->[1] = $str; $str->typecheck($program, undef, @rest) unless $str == $val; return $str->type; } else { $program->error("Argument 1 to map must be a mapping " . "or an array."); return undef; } } } 1;