sprit-forth/source/core.cpp

// sprit-forth: A portable subroutine-threaded Forth.
// Copyright (C) 2023  Clyne Sullivan <clyne@bitgloo.com>
//
// This library is free software; you can redistribute it and/or modify it
// under the terms of the GNU Library General Public License as published by
// the Free Software Foundation; either version 2 of the License, or (at your
// option) any later version.
//
// This library is distributed in the hope that it will be useful, but WITHOUT
// ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
// FOR A PARTICULAR PURPOSE.  See the GNU Library General Public License for
// more details.
//
// You should have received a copy of the GNU Library General Public License
// along with this library; if not, write to the Free Software Foundation, Inc.,
// 51 Franklin St, Fifth Floor, Boston, MA  02110-1301, USA.

#include "core.hpp"
#include "state.hpp"

#include <cctype>
#include <cstring>

void jump(FuncList ip)
{
    // IP is incremented before its next execution.
    IP = ip - 1;
}

// LITERAL's run-time semantics: push the given value onto the stack.
static auto literall = WordWrap<[] {
    *++SP = (Cell)*++IP;
}>();

void compileliteral()
{
    comma((Cell)literall);
    comma(*SP--);
}

bool haskey()
{
    return DICT[DIdxSrcLen] > 0;
}

void addkey(int k)
{
    --DICT[DIdxSource];
    ++DICT[DIdxSrcLen];

    auto ptr = reinterpret_cast<char *>(DICT[DIdxSource]);
    *ptr = static_cast<char>(k);
}

int key()
{
    // Block until input is available.
    while (!haskey())
        getinput();

    auto ptr = reinterpret_cast<char *>(DICT[DIdxSource]);
    ++DICT[DIdxSource];
    --DICT[DIdxSrcLen];

    return *ptr;
}

Cell *comma(Cell n)
{
    const auto ptr = reinterpret_cast<Cell *>(HERE);
    *ptr = n;
    HERE += sizeof(Cell);
    return ptr;
}

Addr aligned(Addr addr)
{
    return (addr + (sizeof(Cell) - 1)) & ~(sizeof(Cell) - 1);
}

void align()
{
    HERE = aligned(HERE);
}

static void readword(int ch)
{
    int k;
    do {
        k = key();
    } while (k == ch);

    // Collect the word's text.
    char *ptr;
    do {
        ptr = reinterpret_cast<char *>(HERE);
        *ptr = k;
        ++HERE;

        if (!haskey())
            break;

        k = key();
    } while (k != ch);

    // Add a null terminator.
    ptr = reinterpret_cast<char *>(HERE);
    *ptr = '\0';
    ++HERE;
}

void word()
{
    auto here = (char *)HERE;
    ++HERE;

    readword(*SP);

    here[0] = strlen(here + 1);
    HERE = (Cell)here;
    *SP = HERE;
}

void colon()
{
    // Collect (and store) the word's name.
    align();
    auto name = HERE;
    readword(' ');
    align();

    // Build the Word structure.
    comma(HERE + 4 * sizeof(Cell)); // exec ptr
    comma(name);                    // name ptr
    *++SP = (Cell)comma(0);         // link (to be set by semic())
    comma(0);                       // immediate

    // The word's execution begins with a prologue that technically performs
    // the "call" to this word.
    // By including this in the word's definition, execution can avoid caring
    // about if it is running words or routines (i.e. pre-defined words).
    comma((Cell)+[](FuncList *ip) {
        ++ip;
        *++RP = (Cell)IP;
        jump((FuncList)*ip);
    });
    // The actual function list will begin one Cell beyond here.
    comma(HERE + sizeof(Cell));

    // Enter compiling state.
    STATE = -1;
}

void semic()
{
    // Add exit routine.
    comma((Cell)fexit);

    // Complete the new word's linkage to make it usable.
    auto link = (Cell *)*SP--;
    *link = LATEST;
    LATEST = (Cell)(link - 2);

    // Exit compilation state.
    STATE = 0;
}

// TODO define in Forth? ": ' bl word find drop ;"
void tick()
{
    // Get the name to look up.
    auto name = (char *)HERE;
    readword(' ');

    // Look up the name and push the result.
    int len = HERE - (Cell)name - 1;
    auto word = find(name, len);
    *++SP = (Cell)word;

    // Deallocate `name`.
    HERE = (Cell)name;
}