sprit-forth/source/core.cpp

// sprit-forth: A portable subroutine-threaded Forth.
// Copyright (C) 2024  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 <cctype>
#include <cstring>

static State state;

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

void compileliteral()
{
    // LITERAL's run-time semantics: push the given value onto the stack.
    comma((Cell)WordWrap<[] {
        Forth.push((Cell)*++Exec.ip);
    }>);
    comma(Forth.pop());
}

bool haskey()
{
    return Forth.sourcei < Forth.sourceu;
}

void addkey(int k)
{
    auto addr = Forth.source + Forth.sourceu++;
    auto ptr = reinterpret_cast<char *>(addr);
    *ptr = static_cast<char>(k);
}

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

    auto ptr = reinterpret_cast<char *>(Forth.source);
    int idx = Forth.sourcei++;
    return ptr[idx];
}

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

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

void align()
{
    Forth.here = aligned(Forth.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 *>(Forth.here);
        *ptr = k;
        ++Forth.here;

        if (!haskey())
            break;

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

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

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

    readword(*Forth.sp);

    here[0] = strlen(here + 1);
    Forth.here = (Cell)here;
    *Forth.sp = Forth.here;
}

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

    // Build the Word structure.
    Forth.push(Forth.here);
    comma(Forth.here + 4 * sizeof(Cell)); // exec ptr
    comma(name);                          // name ptr
    comma(0);                             // link
    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;
        Forth.rpush((Cell)Exec.ip);
        jump((FuncList)*ip);
    });
    // The actual function list will begin one Cell beyond here.
    comma(Forth.here + sizeof(Cell));

    // Enter compiling state.
    Forth.compxt = *Forth.sp;
    Forth.state = -1;
}

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

    // Complete the new word's linkage to make it usable.
    auto word = reinterpret_cast<Word *>(Forth.pop());
    Forth.add(*word);

    // Exit compilation state.
    Forth.state = 0;
}

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

    // Look up the name and push the result.
    int len = Forth.here - name - 1;
    auto word = Forth.find((char *)name, len);
    Forth.push((Cell)word);

    // Deallocate `name`.
    Forth.here = name;
}