{"body":"package Universa::FORTH;\n\nuse v5.18;\nuse warnings;\nuse strict;\nno warnings 'experimental::smartmatch';\n\nuse Universa::FORTH::Words;\nuse Universa::FORTH::Session;\nuse Carp 'croak';\nuse Scalar::Util;\nuse List::Util 'first';\n\n\n# Safety first (before GD):\nEND {\n    undef our $INTERPRETER;\n}\n\n# The real constructor is not all that special here: \nsub new {\n    my ($class, %params) = @_;\n\n    # If the core interpreter is not yet already set up, do so:\n    our $INTERPRETER ||= _new_interpreter($class, %params);\n\n    # Instead of providing the client with the interpreter, provide them with a new\n    # session that can access it. There is a strange bug here we need to watch out\n    # for. apparently we can't pass parameters to new because they dissapear:\n    my $session = Universa::FORTH::Session->new;\n    $session->{'_link'} = $INTERPRETER;\n    $session;\n}\n\n# This shouldn't be called directly, but it is here just in case:\nsub _new_interpreter {\n    my $class = shift;\n\n    my $self = {\n\t'dict'    => {},    # Global dictionary\n\t'builtin' => {},    # Builtin words here (code and eval)\n\t'feature' => {},    # Additional feature references (eg. datastore)\n    };\n    \n    my $interpreter = bless $self, $class;\n    $interpreter->cold; # Load builtins and the provided base dictionary\n    $interpreter;\n}\n\n# feature() returns a true value if an array element in $self->{'feature'} contains\n# that string. It is intended to be used by dictionaries which depend on code not\n# provided by this module to help ensure that their environment is sane:\nsub feature {\n    my ($self, $feature) = @_;\n\n    # We only need to find a feature once:\n    return 0 unless exists($self->{'feature'}->{$feature});\n}\n\n# Just an error throwing helper:\nsub error {\n    my ($self, $message) = @_;\n    print \"error ($message)\\n\";\n}\n\n# The answer I came up with to better handle additional dictionary entries, etc\n# was to support a simple plugin system. Before, mpodules would have to inherit\n# Universa::FORTH which was a bit messy:\nsub add_plugin {\n    my ($self, $object) = @_;\n    my $package = ref $object;\n\n    $object->isa('Universa::FORTH::Plugin')\n\tor die \"Plugin '$package' must inherit 'Universa::Forth::Plugin\\n\";\n\n    # All plugins must have a name to identify them as a 'feature':\n    my $name = $object->name or die \"Plugin '$package$' must have a name\\n\";\n    return warn \"Plugin '$package' already loaded\\n\"\n\tif $self->{'feature'}->{$name};\n    $self->{'feature'}->{$name} = $object; # Store it!\n\n    $object->plugin_init($self);\n}\n\n# The first thing ever run when a FORTH interpreter is being born\n# is cold. This function is responsible for providing all core\n# words into our FORTH program. However, we also load our primary\n# builtin words (not core words) as well:\nsub cold {\n    my $self = shift;\n\n    # The eval core word accepts a string of Perl code and\n    # evaluates it when the word is processed:\n    $self->{'builtin'}->{'eval'} = sub {\n\tmy ($session, $code) = @_;\n\n\teval $code; # TODO: carry $session.\n\tprint $@ if $@;\n    };\n\n    # Most builtin words will use the code core word. The only\n    # difference is that it accepts a code reference:\n    $self->{'builtin'}->{'code'} = sub {\n\tmy ($session, $coderef) = @_;\n\n\t$coderef->($session, @_);\n    };\n\n    # Provide the builtin dictionary:\n    $self->add_dictionary( Universa::FORTH::Words->new );\n}\n\n# forth_exec() is just a dispatcher, more than anything. The real\n# work is mostly done by the forth modes:\nsub forth_exec {\n    my ($self, $session, $chunk) = @_;\n\n    while ($$chunk) {\n\tfor ($session->{'imode'}) {\n\t    when (/^interpret$/) { $self->interpret($session, $chunk) }\n\t    when (/^collect$/)   { $self->collect($session, $chunk)   }\n\t}\n    }\n\n    # Return a reference to the parameter stack. This is really just to help\n    # make code a bit easier during implementation:\n    $session->{'_ps'};\n}\n\n# collect() is responsible for string support; It could be used for\n# more. Its' job is to load in alphanumeric characters until it\n# hits a 'catch_word' thrown into $self->{'_catch'}:\nsub collect {\n    my ($self, $session, $chunk) = @_;\n\n    my $catch_word = $session->{'_catch'}->[0];\n    $$chunk =~ /(.*)\\s$catch_word/;\n    $session->{'_catch'}->[1]->($1) if $1;\n    $$chunk = (split /\\s$catch_word/, $$chunk, 2)[1];\n    $session->{'imode'} = 'interpret';\n}\n\n# Builtins are words provided to us that are defined in the\n# dictionary. Oddly enough, this function can also be used to\n# run user defined 'colon' definitions as well:\nsub run_builtin {\n    my ($self, $session, $word) = @_;\n\n    $self->{'builtin'}->{$self->{'dict'}->{$word}->{'codeword'}}->(\n\t$session, @{ $self->{'dict'}->{$word}->{'params'} }\n    );\n}\n\n# The semi-outer interpreter of FORTH lies here. Its' job is to\n# handle the execution of builtins and core words, as well as\n# bareword literals:\nsub interpret {\n    my ($self, $session, $chunk) = @_;\n    \n    if ( (my $word, $$chunk) = split ' ', $$chunk, 2 ) {\n\n\t# Run a builtin, if possible (See above):\n\tif ( exists($self->{'dict'}->{$word}) ) {\n\t    $self->run_builtin($session, $word);\n\t    return;\n\t}\n\n        # Literals allow for us to perform arithmetic:\n\tif ( Scalar::Util::looks_like_number($word) ) {\n\t    push @{ $session->{'_ps'} }, $word;\n\t    return;\n\t}\n\t\n\t# A bareword is a literal starting with a period.\n\t# For example, .squirrel:\n\tif ($word =~ /^\\./) {\n\t    $word = unpack \"xA*\", $word; # Remove leading period\n\t    push @{ $session->{'_ps'} }, $word;\n\t    return;\n\t}\n\n\t# TODO: Throw an error; Not sure how to handle.\n    }\n}\n\n# IF you wish to add any extra words to the dictionary, you should\n# do so here. Note: Conflicting entries do not get overridden:\nsub add_dictionary {\n    my ($self, $dict, @extra) = @_;\n\n    my %entries    = %{ $dict->populate($self, @extra) };\n    my %dictionary = %{ $self->{'dict'} };\n    @dictionary{ keys %entries } = values %entries;\n    $self->{'dict'} = \\%dictionary;\n}\n\n# Every interpreter needs a convenient way to add words to its'\n# dictionary. This function is never used internally:\nsub add_word {\n    my ($self, $dict, $name, $codeword, @params) = @_;\n    \n    my $entry = {\n\t'codeword' => $codeword,\n\t'params'   => \\@params,\n    };\n    \n    $dict->{'dict'}->{$name} = $entry;\n    $entry;\n}\n\n# This executes if we run this module as a standalone script.\n# It can be useful for interactive testing of the FORTH\n# interpreter and such:\nsub run {\n\n    my $session = __PACKAGE__->new;\n    $session->repl;\n}\n\nsub repl {\n    my ($self, $session) = @_;\n    \n    while ($session->{'active'}) {\n\n\tmy $in_handle  = $session->{'in_handle'};\n\tmy $out_handle = $session->{'out_handle'};\n\n\tprint $out_handle \"> \";\n\tmy $chunk = <$in_handle>;\n\tchomp $chunk;\n\t$chunk =~ s/^\\s+|\\s+$//; # Trim\n\tnext unless $chunk;\n\t\n\t$self->forth_exec($session, \\$chunk);\n\tprint $out_handle \"ok [@{[join ', ', @{ $session->{'_ps'} } ]}]\\n\"; # Stack status\n    }\n}\n\n__PACKAGE__->run unless caller; # We can't use :: here.... at least not right now\n","name":"","extension":"txt","url":"https://www.irccloud.com/pastebin/f26atUZW","modified":1486216270,"id":"f26atUZW","size":6967,"lines":239,"own_paste":false,"theme":"","date":1486216270}