My_basic interpreter

General discussion for topics related to the FreeBASIC project or its community.
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

My_basic interpreter

Post by angros47 »

I found this scripting language:

https://github.com/paladin-t/my_basic

It is very lightweight (the interpreter is only 200 kb), and can be used from FreeBasic as well, it seems. All you need to do is to run the makefile, then take the file my_basic.o, and link it in a freebasic project with something like:

fbc file.bas my_basic.o

Here is the converted header:

Code: Select all

#define MB_CODES
#define MB_FUNC_OK 0
#define MB_FUNC_IGNORE 1
#define MB_FUNC_WARNING 2
#define MB_FUNC_ERR 3
#define MB_FUNC_BYE 4
#define MB_FUNC_SUSPEND 5
#define MB_FUNC_END 6
#define MB_LOOP_BREAK 101
#define MB_LOOP_CONTINUE 102
#define MB_SUB_RETURN 103
#define MB_EXTENDED_ABORT 201

enum mb_error_e 
	SE_NO_ERR = 0,
	' Common 
	SE_CM_FUNC_EXISTS,
	SE_CM_FUNC_NOT_EXISTS,
	SE_CM_NOT_SUPPORTED,
	' Parsing 
	SE_PS_OPEN_FILE_FAILED,
	SE_PS_SYMBOL_TOO_LONG,
	SE_PS_INVALID_CHAR,
	SE_PS_INVALID_MODULE,
	' Running 
	SE_RN_EMPTY_PROGRAM,
	SE_RN_PROGRAM_TOO_LONG,
	SE_RN_SYNTAX_ERROR,
	SE_RN_OUT_OF_MEMORY,
	SE_RN_OVERFLOW,
	SE_RN_UNEXPECTED_TYPE,
	SE_RN_INVALID_STRING,
	SE_RN_INTEGER_EXPECTED,
	SE_RN_NUMBER_EXPECTED,
	SE_RN_STRING_EXPECTED,
	SE_RN_VAR_EXPECTED,
	SE_RN_INDEX_OUT_OF_BOUND,
	SE_RN_CANNOT_FIND_WITH_GIVEN_INDEX,
	SE_RN_TOO_MANY_DIMENSIONS,
	SE_RN_RANK_OUT_OF_BOUND,
	SE_RN_INVALID_ID_USAGE,
	SE_RN_DUPLICATE_ID,
	SE_RN_INCOMPLETE_STRUCTURE,
	SE_RN_LABEL_NOT_EXISTS,
	SE_RN_NO_RETURN_POINT,
	SE_RN_COLON_EXPECTED,
	SE_RN_COMMA_EXPECTED,
	SE_RN_COMMA_OR_SEMICOLON_EXPECTED,
	SE_RN_OPEN_BRACKET_EXPECTED,
	SE_RN_CLOSE_BRACKET_EXPECTED,
	SE_RN_NESTED_TOO_MUCH,
	SE_RN_OPERATION_FAILED,
	SE_RN_OPERATOR_EXPECTED,
	SE_RN_ASSIGN_OPERATOR_EXPECTED,
	SE_RN_THEN_EXPECTED,
	SE_RN_ELSE_EXPECTED,
	SE_RN_ENDIF_EXPECTED,
	SE_RN_TO_EXPECTED,
	SE_RN_NEXT_EXPECTED,
	SE_RN_UNTIL_EXPECTED,
	SE_RN_LOOP_VAR_EXPECTED,
	SE_RN_JUMP_LABEL_EXPECTED,
	SE_RN_CALCULATION_ERROR,
	SE_RN_INVALID_EXPRESSION,
	SE_RN_DIVIDE_BY_ZERO,
	SE_RN_WRONG_FUNCTION_REACHED,
	SE_RN_CANNOT_SUSPEND_HERE,
	SE_RN_CANNOT_MIX_INSTRUCTIONAL_AND_STRUCTURED,
	SE_RN_INVALID_ROUTINE,
	SE_RN_ROUTINE_EXPECTED,
	SE_RN_DUPLICATE_ROUTINE,
	SE_RN_INVALID_CLASS,
	SE_RN_CLASS_EXPECTED,
	SE_RN_DUPLICATE_CLASS,
	SE_RN_HASH_AND_COMPARE_MUST_BE_PROVIDED_TOGETHER,
	SE_RN_INVALID_LAMBDA,
	SE_RN_EMPTY_COLLECTION,
	SE_RN_LIST_EXPECTED,
	SE_RN_INVALID_ITERATOR,
	SE_RN_ITERABLE_EXPECTED,
	SE_RN_COLLECTION_EXPECTED,
	SE_RN_COLLECTION_OR_ITERATOR_EXPECTED,
	SE_RN_REFERENCED_TYPE_EXPECTED,
	' Extended abort 
	SE_EA_EXTENDED_ABORT,
	' Extra 
	SE_COUNT
end enum

enum mb_data_e 
	MB_DT_NIL = 0,
	MB_DT_UNKNOWN = 1 shl 0,
	MB_DT_INT = 1 shl 1,
	MB_DT_REAL = 1 shl 2,
	MB_DT_NUM = MB_DT_INT or MB_DT_REAL,
	MB_DT_STRING = 1 shl 3,
	MB_DT_TYPE = 1 shl 4,
	MB_DT_USERTYPE = 1 shl 5,

	MB_DT_ARRAY = 1 shl 7,
	MB_DT_ROUTINE = 1 shl 13
end enum

enum mb_meta_func_e 
	MB_MF_IS = 1 shl 0,
	MB_MF_ADD = 1 shl 1,
	MB_MF_SUB = 1 shl 2,
	MB_MF_MUL = 1 shl 3,
	MB_MF_DIV = 1 shl 4,
	MB_MF_NEG = 1 shl 5,
	MB_MF_CALC = MB_MF_IS or MB_MF_ADD or MB_MF_SUB or MB_MF_MUL or MB_MF_DIV or MB_MF_NEG,
	MB_MF_COLL = 1 shl 6,
	MB_MF_FUNC = 1 shl 7
end enum

enum mb_meta_status_e 
	MB_MS_NONE = 0,
	MB_MS_DONE = 1 shl 0,
	MB_MS_RETURNED = 1 shl 1
end enum

enum mb_routine_type_e 
	MB_RT_NONE,
	MB_RT_SCRIPT,
	MB_RT_LAMBDA,
	MB_RT_NATIVE
end enum

union mb_value_u 
	integer_ as integer
	float_point as single
	string_ as zstring ptr
	type_ as mb_data_e
	usertype as any ptr
	array as any ptr
	routine as any ptr
	bytes as unsigned byte
end union

type mb_value_t
	type_ as mb_data_e
	value as mb_value_u
end type


extern "C"
declare function mb_init() as integer
declare function mb_dispose() as integer
declare function mb_open(byref s as any ptr) as integer
declare function mb_close(byref s as any ptr) as integer
declare function mb_reset(byref s as any ptr, clrf as unsigned byte) as integer

declare function mb_fork(byref s as any ptr, r as any ptr, clfk as unsigned byte) as integer
declare function mb_join(byref s as any ptr) as integer
declare function mb_get_forked_from(s as any ptr, byref src as any ptr) as integer

declare function mb_register_func(s as any ptr, n as zstring ptr, f as function cdecl (as any ptr, byref as any ptr) as integer) as integer
declare function mb_remove_func(s as any ptr, n as zstring ptr) as integer
declare function mb_remove_reserved_func(s as any ptr, n as zstring ptr) as integer
declare function mb_begin_module(s as any ptr, n as zstring ptr) as integer
declare function mb_end_module(s as any ptr) as integer

declare function mb_attempt_func_begin(s as any ptr, byref l as any ptr) as integer
declare function mb_attempt_func_end(s as any ptr, byref l as any ptr) as integer
declare function mb_attempt_open_bracket(s as any ptr, byref l as any ptr) as integer
declare function mb_attempt_close_bracket(s as any ptr, byref l as any ptr) as integer
declare function mb_has_arg(s as any ptr, byref l as any ptr) as integer
declare function mb_pop_int(s as any ptr, byref l as any ptr, byref val_ as integer) as integer
declare function mb_pop_real(s as any ptr, byref l as any ptr, byref val_ as single) as integer
declare function mb_pop_string(s as any ptr, byref l as any ptr, byref val_ as zstring ptr) as integer
declare function mb_pop_usertype(s as any ptr, byref l as any ptr, byref val_ as any ptr) as integer
declare function mb_pop_value(s as any ptr, byref l as any ptr, byref val_ as mb_value_t) as integer
declare function mb_push_int(s as any ptr, byref l as any ptr, val_ as integer) as integer
declare function mb_push_real(s as any ptr, byref l as any ptr, val_ as single) as integer
declare function mb_push_string(s as any ptr, byref l as any ptr, val_ as zstring ptr) as integer
declare function mb_push_usertype(s as any ptr, byref l as any ptr, val_ as any ptr) as integer
declare function mb_push_value(s as any ptr, byref l as any ptr, val_ as mb_value_t) as integer

declare function mb_begin_class(s as any ptr, byref l as any ptr, n as zstring ptr, byref meta as mb_value_t ptr, c as integer, byref out_ as mb_value_t) as integer
declare function mb_end_class(s as any ptr, byref l as any ptr) as integer
declare function mb_get_class_userdata(s as any ptr, byref l as any ptr, byref d as any ptr) as integer
declare function mb_set_class_userdata(s as any ptr, byref l as any ptr, byref d as any ptr) as integer

declare function mb_get_value_by_name(s as any ptr, byref l as any ptr, n as zstring ptr, byref val_ as mb_value_t) as integer
declare function mb_add_var(s as any ptr, byref l as any ptr, n as zstring ptr, val_ as mb_value_t, force as unsigned byte) as integer
declare function mb_get_var(s as any ptr, byref l as any ptr, byref v as any ptr, redir as unsigned byte) as integer
declare function mb_get_var_name(s as any ptr, v as any ptr, byref n as zstring ptr) as integer
declare function mb_get_var_value(s as any ptr, v as any ptr, byref val_ as mb_value_t) as integer
declare function mb_set_var_value(s as any ptr, v as any ptr, val as mb_value_t) as integer
declare function mb_init_array(s as any ptr, byref l as any ptr, t as mb_data_e, byref d as integer, c as integer, byref a as any ptr) as integer
declare function mb_get_array_len(s as any ptr, byref l as any ptr, a as any ptr, r as integer, byref i as integer) as integer
declare function mb_get_array_elem(s as any ptr, byref l as any ptr, a as any ptr, byref d as integer, c as integer, byref val_ as mb_value_t) as integer
declare function mb_set_array_elem(s as any ptr, byref l as any ptr, a as any ptr, byref d as integer, c as integer, val_ as mb_value_t) as integer
declare function mb_init_coll(s as any ptr, byref l as any ptr, byref coll as mb_value_t) as integer
declare function mb_get_coll(s as any ptr, byref l as any ptr, coll as mb_value_t, idx as mb_value_t, byref val_ as mb_value_t) as integer
declare function mb_set_coll(s as any ptr, byref l as any ptr, coll as mb_value_t, idx as mb_value_t, val_ as mb_value_t) as integer
declare function mb_remove_coll(s as any ptr, byref l as any ptr, coll as mb_value_t, idx as mb_value_t) as integer
declare function mb_count_coll(s as any ptr, byref l as any ptr, coll as mb_value_t, byref c as integer) as integer
declare function mb_keys_of_coll(s as any ptr, byref l as any ptr, coll as mb_value_t, byref keys as mb_value_t, c as integer) as integer
declare function mb_make_ref_value(s as any ptr, val_ as any ptr, byref out_ as mb_value_t, un as sub cdecl (as any ptr, as any ptr), cl as function cdecl (as any ptr, as any ptr) as any ptr, hs as function cdecl (as any ptr, as any ptr) as unsigned integer, cp as function cdecl (as any ptr, as any ptr, as any ptr) as integer, ft as function cdecl (as any ptr, as any ptr, as zstring ptr, as unsigned integer) as integer) as integer
declare function mb_get_ref_value(s as any ptr, byref l as any ptr, val_ as mb_value_t, byref out_ as any ptr) as integer
declare function mb_ref_value(s as any ptr, byref l as any ptr, val_ as mb_value_t) as integer
declare function mb_unref_value(s as any ptr, byref l as any ptr, val_ as mb_value_t) as integer
declare function mb_set_alive_checker(s as any ptr, f as sub cdecl (as any ptr, as any ptr, as sub cdecl (as any ptr, as any ptr, as mb_value_t))) as integer
declare function mb_set_alive_checker_of_value(s as any ptr, byref l as any ptr, val as mb_value_t, f as sub cdecl (as any ptr, as any ptr, as mb_value_t, as sub cdecl (as any ptr, as any ptr, as mb_value_t))) as integer
declare function mb_override_value(s as any ptr, byref l as any ptr, val_ as mb_value_t, m as mb_meta_func_e, f as any ptr) as integer
declare function mb_dispose_value(s as any ptr, val_ as mb_value_t) as integer

declare function mb_get_routine(s as any ptr, byref l as any ptr, n as zstring ptr, byref val_ as mb_value_t) as integer
declare function mb_set_routine(s as any ptr, byref l as any ptr, n as zstring ptr, f as function cdecl(as any ptr, byref as any ptr, byref as mb_value_t, as unsigned integer, as any ptr, as function cdecl (as any ptr, byref as any ptr, byref as mb_value_t, as unsigned integer, byref as unsigned integer, as any ptr) as integer, as function cdecl (as any ptr, byref as any ptr, byref as mb_value_t, as unsigned integer, byref as unsigned integer, as any ptr, byref as mb_value_t) as integer) as integer, force as unsigned byte) as integer
declare function mb_eval_routine(s as any ptr, byref l as any ptr, val_ as mb_value_t, args as mb_value_t, argc as unsigned integer, byref ret_ as mb_value_t) as integer
declare function mb_get_routine_type(s as any ptr, val_ as mb_value_t, byref y as mb_routine_type_e) as integer

declare function mb_load_string(s as any ptr, l as zstring ptr, reset as unsigned byte) as integer
declare function mb_load_file(s as any ptr, f as zstring ptr) as integer
declare function mb_run(s as any ptr, clear_parser as unsigned byte) as integer
declare function mb_suspend(ss as any ptr, byref l as any ptr) as integer
declare function mb_schedule_suspend(s as any ptr, t as integer) as integer

declare function mb_debug_get(s as any ptr, n as zstring ptr, byref val_ as mb_value_t) as integer
declare function mb_debug_set(s as any ptr, n as zstring ptr, val_ as mb_value_t) as integer
declare function mb_debug_get_stack_trace(s as any ptr, byref l as any ptr, byref fs as zstring ptr, fc as unsigned integer) as integer
declare function mb_debug_set_stepped_handler(s as any ptr, h as function cdecl (as any ptr, byref as any ptr, as zstring ptr, as integer, as unsigned short, as unsigned short) as integer) as integer

declare function mb_get_type_string(t as mb_data_e) as zstring ptr

declare function mb_raise_error(s as any ptr, byref l as any ptr, err_ as mb_error_e, ret_ as integer) as integer
declare function mb_get_last_error(s as any ptr, byref file as zstring ptr, byref pos_ as integer, byref row_ as unsigned short, byref col_ as unsigned short) as mb_error_e
declare function mb_get_error_desc(err_ as mb_error_e) as zstring ptr
declare function mb_set_error_handler(s as any ptr, h as sub cdecl (as any ptr, as mb_error_e, as zstring ptr, as zstring ptr, as integer, as unsigned short, as unsigned short, as integer)) as integer

declare function mb_set_printer(s as any ptr, p as function cdecl(as zstring ptr, ...) as integer) as integer
declare function mb_set_inputer(s as any ptr, p as function cdecl(as zstring ptr, as zstring ptr, as integer) as integer) as integer

declare function mb_set_import_handler(s as any ptr, h as function cdecl(as any ptr, as zstring ptr) as integer) as integer
declare function mb_set_memory_manager(a as function cdecl (as unsigned integer) as ubyte ptr, f as sub cdecl (as ubyte ptr)) as integer
declare function mb_get_gc_enabled(s as any ptr) as unsigned byte
declare function mb_set_gc_enabled(s as any ptr, gc as unsigned byte) as integer
declare function mb_gc(s as any ptr, byref collected as integer) as integer
declare function mb_get_userdata(s as any ptr, byref d as any ptr) as integer
declare function mb_set_userdata(s as any ptr, d as any ptr) as integer
declare function mb_gets(pmt as zstring ptr, buf as ubyte ptr, s as integer) as integer
declare function mb_memdup(val_ as zstring ptr, size as unsigned integer) as zstring ptr
end extern
and here is a sample:

Code: Select all

#include "my_basic.bi"

dim bas as any ptr

mb_init()
mb_open(bas)
mb_load_string(bas, "print 22 / 7;", 1)
mb_run(bas, 1)
mb_close(bas)
mb_dispose
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: My_basic interpreter

Post by aurelVZAB »

hmm
interesting ..but how you convert header from .h ..C code to FB .bi code ?
also this one called jwillabasic on github
should be even easier because whole interpreter is in header 300loc
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

Re: My_basic interpreter

Post by angros47 »

There was only one header. my_basic.h, in the project, and I converted it by hand, since it was pretty short.

What is jwillabasic? This one? https://github.com/jwillia3/BASIC
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: My_basic interpreter

Post by srvaldez »

@angros47
interesting, thanks for sharing :)
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: My_basic interpreter

Post by aurelVZAB »

Yes angros47..that one ....
do you know how to conevert it to basic ?
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

Re: My_basic interpreter

Post by angros47 »

With a lot of effort... and a lot of trial-and-error approach.
The source code looks generic enough to be portable.

Have you tried it? What does it allow to do?
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: My_basic interpreter

Post by aurelVZAB »

Yes i tried ...few years back but without succses
hmm i ask Ed_D he reform C code to be much readable but then i give up.
When i visit recently JerryW github page i see that he made some changes...
It is according to Ed benchmarking one of let say "faster" mini-basic interpreters.
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

Re: My_basic interpreter

Post by angros47 »

I had a look at the code: it uses a lot of symbols that are reserved keywords in FreeBasic, so porting it to FreeBasic would make it even more unreadable
Ed Davis
Posts: 37
Joined: Jul 28, 2008 23:24

Re: My_basic interpreter

Post by Ed Davis »

I agree - converting the jwillia Basic from C to FreeBasic would take a while - I think it would take me several days at least.
And I'm not familiar enough with FreeBasic to easily translate things like:

while ((*pc++)()); /* RUN STATEMENT */

I think I saw where FreeBasic has function pointers; but while I've used them in C, I have not used them in FreeBasic.

In the meantime, here is a version of jwillia Basic that can be linked with and called from FreeBasic.
File jw.bas

Code: Select all

extern "C"
  declare function run_file(s as zstring ptr) as integer
  declare function run_string(s as zstring ptr) as integer
end extern

' run a file
'run_file(command())

dim s as string

' run a single line - jwillia basic uses format instead of print:
s = "format " + chr(34) + "Run string" + chr(34)
run_string(s)

' run multiple lines - must be separated with \n
s = "format " + chr(34) + "line 1" + chr(34) + chr(10) + "format " + chr(34) + "line 2" + chr(34)
run_string(s)
And the jwillia Basic interpreter, cleaned up a little, with a couple of functions for calling from FreeBasic - note: _not_ heavily tested:
File basic.c

Code: Select all

#include <stdio.h>
#include <setjmp.h>
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>

#define SYMSZ   16                      /* SYMBOL SIZE */
#define PRGSZ   65536                   /* PROGRAM SIZE */
#define STKSZ   256                     /* STACK SIZE */
#define STRSZ   4096                    /* STRING TABLE SIZE */
#define VARS    512                     /* VARIABLE COUNT */
#define LOCS    8                       /* LOCAL COUNT */

typedef ptrdiff_t       Val;            /* SIGNED INT/POINTER */
typedef int             (*Code)(void);  /* BYTE-CODE */

enum {  NAME=1,NUMBER,STRING,LP,RP,COMMA,ADD,SUBS,MUL,DIV,MOD,
        EQ,LT,GT, NE,LE,GE,AND,OR,FORMAT,SUB,END,RETURN,LOCAL,
        WHILE,FOR,TO,IF,ELSE,THEN,DIM,UBOUND,BYE,BREAK,RESUME
     };
char    *kwd[]= { "AND","OR","FORMAT","SUB","END","RETURN","LOCAL","WHILE",
                  "FOR","TO","IF","ELSE","THEN","DIM","UBOUND","BYE","BREAK","RESUME",0
                };

char    lbuf[256],tokn[SYMSZ],*lp;      /* LEXER STATE */
int     lnum,tok,tokv,ungot;            /* LEXER STATE */
int     (*prg[PRGSZ])(void),(**pc)(void),cpc,lmap[PRGSZ]; /* COMPILED PROGRAM */
Val     stk[STKSZ],*sp;                 /* RUN-TIME STACK */
Val     value[VARS];                    /* VARIABLE VALUES */
char    name[VARS][SYMSZ];              /* VARIABLE NAMES */
int     sub[VARS][LOCS+2];              /* N,LOCAL VAR INDEXES */
int     mode[VARS];                     /* 0=NONE, 1=DIM, 2=SUB */
Val     ret;                            /* FUNCTION RETURN VALUE */
int     cstk[STKSZ], *csp;              /* COMPILER STACK */
int     nvar,cursub,temp,compile,ipc,(**opc)(); /* COMPILER STATE */
char    stab[STRSZ], *stabp;            /* STRING TABLE */
jmp_buf trap;                           /* TRAP ERRORS */

#define A       sp[1]                   /* LEFT OPERAND */
#define B       sp[0]                   /* RIGHT OPERAND */
#define PCV     ((Val)*pc++)            /* GET IMMEDIATE */
#define STEP   return (*pc++)()         /* CONTINUE RUNNING */
#define LOC(N) value[sub[v][N+2]]       /* SUBROUTINE LOCAL */

void err(char *msg) {
    printf("ERROR %d: %s\n",lmap[pc-prg-1],msg);
    longjmp(trap,2);
}

Val *bound(Val *mem, int n) {
    if (n<1 || n>*mem)
        err("BOUNDS");
    return mem+n;
}

int     (*kwdhook)(char *kwd);          /* KEYWORD HOOK */
int     (*funhook)(char *kwd, int n);   /* FUNCTION CALL HOOK */

void initbasic(int comp) {
    pc=prg;
    sp=stk+STKSZ;
    csp=cstk+STKSZ;
    stabp=stab;
    compile=comp;
}

int bad(char *msg) {
    printf("ERROR %d: %s\n", lnum, msg);
    longjmp(trap,1);
    return 0;
}

void emit(int opcode()) {
    lmap[cpc]=lnum;
    prg[cpc++]=opcode;
}

void inst(int opcode(void), Val x) {
    emit(opcode);
    emit((Code)x);
}

int BYE_(void) {
    longjmp(trap,4);
    return 0;
}

int BREAK_(void) {
    longjmp(trap,3);
    return 0;
}

int RESUME_(void) {
    pc=opc? opc:pc;
    opc=pc;
    cpc=ipc;
    STEP;
}

int NUMBER_(void) {
    *--sp=PCV;
    STEP;
}

int LOAD_(void) {
    *--sp=value[PCV];
    STEP;
}

int STORE_(void) {
    value[PCV]=*sp++;
    STEP;
}

int ECHO_(void) {
    printf("%d\n",*sp++);
    STEP;
}

int FORMAT_(void) {
    char *f;
    Val n=PCV, *ap=(sp+=n)-1;
    for (f=stab + *sp++; *f; f++)
        if (*f=='%')
            printf("%d", (int)*ap--);
        else if (*f=='$')
            printf("%s", (char*)*ap--);
        else
            putchar(*f);
    putchar('\n');
    STEP;
}

int ADD_(void) {
    A+=B;
    sp++;
    STEP;
}

int SUBS_(void) {
    A-=B;
    sp++;
    STEP;
}

int MUL_(void) {
    A*=B;
    sp++;
    STEP;
}

int DIV_(void) {
    if (!B)
        sp+=2,err("DIVISION BY ZERO");
    A/=B;
    sp++;
    STEP;
}

int MOD_(void) {
    if (!B)
        sp+=2,err("MODULUS OF ZERO");
    A%=B;
    sp++;
    STEP;
}

int EQ_(void) {
    A = (A == B) ? -1 : 0;
    sp++;
    STEP;
}

int LT_(void) {
    A=(A<B) ? -1 : 0;
    sp++;
    STEP;
}

int GT_(void) {
    A=(A>B) ? -1 : 0;
    sp++;
    STEP;
}

int NE_(void) {
    A=(A!=B) ? -1 : 0;
    sp++;
    STEP;
}

int LE_(void) {
    A=(A<=B) ? -1 : 0;
    sp++;
    STEP;
}

int GE_(void) {
    A=(A>=B) ? -1 : 0;
    sp++;
    STEP;
}

int AND_(void) {
    A&=B;
    sp++;
    STEP;
}

int OR_(void) {
    A|=B;
    sp++;
    STEP;
}

int JMP_(void) {
    pc=prg+(int)*pc;
    STEP;
}

int FALSE_(void) {
    if (*sp++)
        pc++;
    else
        pc=prg+(int)*pc;
    STEP;
}

int FOR_(void) {
    if (value[PCV] >= *sp)
        pc=prg+(int)*pc, sp++;
    else
        pc++; /* was:PCV; */
    STEP;
}

int NEXT_(void) {
    value[PCV]++;
    STEP;
}

int CALL_(void) {
    Val v=PCV, n=sub[v][1], x, *ap=sp;
    while (n--) {
        x=LOC(n);
        LOC(n)=*ap;
        *ap++=x;
    }
    for (n=sub[v][1]; n<sub[v][0]; n++)
        *--sp=LOC(n);
    *--sp=pc-prg;
    pc=prg+value[v];
    STEP;
}

int RETURN_(void) {
    int v=PCV, n=sub[v][0];
    pc=prg+*sp++;
    while (n--)
        LOC(n)=*sp++;
    STEP;
}

int SETRET_(void) {
    ret=*sp++;
    STEP;
}

int RV_(void) {
    *--sp=ret;
    STEP;
}

int DROP_(void) {
    sp+=PCV;
    STEP;
}

int DIM_(void) {
    int v=PCV, n=*sp++;
    Val *mem=calloc(sizeof(Val),n+1);
    mem[0]=n;
    value[v]=(Val)mem;
    STEP;
}

int LOADI_(void) {
    Val x=*sp++;
    x=*bound((Val*)value[PCV],x);
    *--sp=x;
    STEP;
}

int STOREI_(void) {
    Val x=*sp++, i=*sp++;
    *bound((Val*)value[PCV],i)=x;
    STEP;
}

int UBOUND_(void) {
    *--sp=*(Val*)value[PCV];
    STEP;
}

int find(char *var) {
    int     i;
    for (i=0; i<nvar && strcmp(var,name[i]); i++)
        ;
    if (i==nvar)
        strcpy(name[nvar++], var);
    return i;
}

int read(void) {        /* READ TOKEN */
    char *p,*d,**k, *pun="(),+-*/\\=<>", *dub="<><=>=";
    if (ungot)
        return ungot=0, tok; /* UNGOT PREVIOUS */
    while (isspace(*lp))
        lp++;      /* SKIP SPACE */
    if (!*lp || *lp=='#')
        return tok=0; /* END OF LINE */
    if (isdigit(*lp))               /* NUMBER */
        return tokv=strtol(lp,&lp,0), tok=NUMBER;
    if ((p=strchr(pun,*lp)) != 0 && lp++) { /* PUNCTUATION */
        for (d=dub; *d && strncmp(d,lp-1,2); d+=2)
            ;
        if (!*d)
            return tok=(p-pun)+LP;
        return lp++, tok=((d-dub)/2)+NE;
    } else if (isalpha(*lp)) {      /* IDENTIFIER */
        for (p=tokn; isalnum(*lp) || *lp == '_'; )
            *p++=(char)toupper(*lp++);
        for (*p=0, k=kwd; *k && strcmp(tokn,*k); k++)
            ;
        if (*k)
            return tok=(k-kwd)+AND;
        return tokv=find(tokn), tok=NAME;
    } else if (*lp=='"' && lp++) {  /* STRING */
        for (p=stabp; *lp && *lp!='"'; )
            *stabp++=*lp++;
        return *stabp++=0, lp++, tokv=p-stab, tok=STRING;
    } else
        return bad("BAD TOKEN");
}

int want(int type) {
    return !(ungot=read()!=type);
}

void need(int type) {
    if (!want(type))
        bad("SYNTAX ERROR");
}

#define LIST(BODY) if (!want(0)) do {BODY;} while (want(COMMA))

int (*bin[])()= {ADD_,SUBS_,MUL_,DIV_,MOD_,EQ_,LT_,GT_, NE_,LE_,GE_,AND_,OR_};
void base(void);                 /* BASIC EXPRESSION */

void factor(void) {
    int (*o)();

    base();
    while (want(0), MUL<=tok && tok<=MOD)
        o=bin[tok-ADD], read(), base(), emit(o);
}

void addition(void) {
    int (*o)();

    factor();
    while (want(0), ADD<=tok && tok<=SUBS)
        o=bin[tok-ADD], read(), factor(), emit(o);
}

void relation(void) {
    int (*o)();

    addition();
    while (want(0), EQ<=tok && tok<=GE)
        o=bin[tok-ADD], read(), addition(), emit(o);
}

void expr(void) {
    int (*o)();

    relation();
    while (want(0), AND<=tok && tok<=OR)
        o=bin[tok-ADD], read(), relation(), emit(o);
}

void base(void) {                /* BASIC EXPRESSION */
    int neg=want(SUBS)? (inst(NUMBER_,0),1): 0;
    if (want(NUMBER))
        inst(NUMBER_, tokv);
    else if (want(STRING))
        inst(NUMBER_, (Val)(stab+tokv));
    else if (want(NAME)) {
        int var=tokv;
        if (want(LP))
            if (mode[var]==1) /* DIM */
                expr(), need(RP), inst(LOADI_, var);
            else {
                int n=0;
                LIST(if (tok==RP) break; expr(); n++);
                need(RP);
                if (!funhook || !funhook(name[var],n)) {
                    if (mode[var]!=2 || n!=sub[var][1])
                        bad("BAD SUB/ARG COUNT");
                    inst(CALL_, var);
                    emit(RV_);
                }
            }
        else            inst(LOAD_, var);
    } else if (want(LP))
        expr(), need(RP);
    else if (want(UBOUND))
        need(LP),need(NAME),need(RP),inst(UBOUND_,tokv);
    else
        bad("BAD EXPRESSION");
    if (neg)
        emit(SUBS_);    /* NEGATE */
}

void stmt(void) {        /* STATEMENT */
    int     n,var;
    switch (read()) {
        case FORMAT:
            need(STRING), inst(NUMBER_, tokv);
            n=0;
            if (want(COMMA))
                LIST(expr(); n++);
            inst(FORMAT_, n);
            break;
        case SUB:       /* CSTK: {SUB,INDEX,JMP} */
            if (!compile)
                bad("SUB MUST BE COMPILED");
            compile++;                      /* MUST BALANCE WITH END */
            need(NAME), mode[cursub=var=tokv]=2; /* SUB NAME */
            n=0;
            LIST(need(NAME);
                 sub[var][n+++2]=tokv);          /* PARAMS */
            *--csp=cpc+1, inst(JMP_,0);     /* JUMP OVER CODE */
            sub[var][0]=sub[var][1]=n;      /* LOCAL=PARAM COUNT */
            value[var]=cpc;                 /* ADDRESS */
            *--csp=var, *--csp=SUB;         /* FOR "END" CLAUSE */
            break;
        case LOCAL:
            LIST(need(NAME);
                 sub[cursub][sub[cursub][0]+++2]=tokv;);
            break;
        case RETURN:
            if (temp)
                inst(DROP_, temp);
            if (!want(0))
                expr(), emit(SETRET_);
            inst(RETURN_, cursub);
            break;
        case WHILE:     /* CSTK: {WHILE,TEST-FALSE,TOP} */
            compile++;                      /* BODY IS COMPILED */
            *--csp=cpc, expr();
            *--csp=cpc+1, *--csp=WHILE, inst(FALSE_, 0);
            break;
        case FOR:       /* CSTK: {FOR,TEST-FALSE,I,TOP}; STK:{HI} */
            compile++;                      /* BODY IS COMPILED */
            need(NAME), var=tokv, temp++;
            need(EQ), expr(), inst(STORE_,var);
            need(TO), expr();
            *--csp=cpc, inst(FOR_,var), emit(0);
            *--csp=var, *--csp=cpc-1, *--csp=FOR;
            break;
        case IF:        /* CSTK: {IF,N,ENDS...,TEST-FALSE} */
            expr(), inst(FALSE_,0), *--csp=cpc-1;
            if (want(THEN)) {
                stmt();
                prg[*csp++]=(Code)cpc;
            } else
                compile++, *--csp=0, *--csp=IF;
            break;
        case ELSE:
            n=csp[1]+1;
            inst(JMP_,0);                   /* JUMP OVER "ELSE" */
            *--csp=IF, csp[1]=n, csp[2]=cpc-1; /* ADD A FIXUP */
            prg[csp[2+n]]=(Code)cpc;        /* PATCH "ELSE" */
            csp[2+n]=!want(IF)? 0:          /* "ELSE IF" */
                     (expr(), inst(FALSE_,0), cpc-1);
            break;
        case END:
            need(*csp++), compile--;                /* MATCH BLOCK */
            if (csp[-1]==SUB) {
                inst(RETURN_, *csp++);
                prg[*csp++]=(Code)cpc;          /* PATCH JUMP */
            } else if (csp[-1]==WHILE) {
                prg[*csp++]=(Code)(cpc+2);      /* PATCH TEST */
                inst(JMP_, *csp++);             /* LOOP TO TEST */
            } else if (csp[-1]==FOR) {
                prg[*csp++]=(Code)(cpc+4);      /* PATCH TEST */
                inst(NEXT_, *csp++);            /* INCREMENT */
                inst(JMP_, *csp++);             /* LOOP TO TEST */
                temp--;                         /* ONE LESS TEMP */
            } else if (csp[-1]==IF) {
                for (n=*csp++; n--; )           /* PATCH BLOCK ENDS */
                    prg[*csp++]=(Code)cpc;
                if ((n=*csp++) != 0)
                    prg[n]=(Code)cpc; /* PATCH "ELSE" */
            }
            break;
        case NAME:
            var=tokv;
            if (want(EQ))
                expr(), inst(STORE_, var);
            else if (want(LP))
                expr(),need(RP),need(EQ),expr(),inst(STOREI_,var);
            else if (!kwdhook || !kwdhook(tokn)) {
                int n=0;
                LIST(expr(); n++);
                if (!funhook || !funhook(name[var],n)) {
                    if (mode[var]!=2 || n!=sub[var][1])
                        bad("BAD SUB/ARG COUNT");
                    inst(CALL_, var);
                }
            }
            break;
        case DIM:
            need(NAME), mode[var=tokv]=1;   /* SET VAR MODE TO DIM */
            need(LP), expr(), need(RP), inst(DIM_, var);
            break;
        case RESUME:
            if (!want(0))
                expr();
            emit(RESUME_);
            break;
        case BREAK:
            emit(BREAK_);
            break;
        case BYE:
            emit(BYE_);
            break;
        case GT:
            expr();
            emit(ECHO_);
            break;
        default:
            if (tok) bad("BAD STATEMENT");
    }
    if (!want(0))           bad("TOKENS AFTER STATEMENT");
}

int interp(FILE *sf, char *script) {      /* INTERPRETER LOOP */
    for (;;) {
        int code=setjmp(trap);                  /* RETURN ON ERROR */
        if (code==1 && sf!=stdin) return 1;     /* FILE SYNTAX ERROR */
        if (code==2) opc=pc;                    /* FAULT */
        if (code==3) pc=opc?opc:pc, cpc=ipc;    /* "BREAK" */
        if (code==4) return 0;                  /* "BYE" */
        for (;;) {
            if (sf==stdin) printf("%d> ",lnum+1);
            if (sf!=NULL) {
                if (!fgets(lp=lbuf,sizeof lbuf,sf))
                    break;
            } else if (script != NULL) {
                lp = strchr(script, '\n');
                if (!lp) {
                    strcpy(lbuf, script);
                    script = NULL;
                } else {
                    int len = lp - script + 1;
                    memcpy(lbuf, script, len);
                    lbuf[len] = '\0';
                    script += len;
                }
                lp = lbuf;
            } else
                break;
            lnum++, ungot=0, stmt();        /* PARSE AND COMPILE */
            if (compile) continue;          /* CONTINUE COMPILING */
            opc=pc, pc=prg+ipc;             /* START OF IMMEDIATE */
            emit(BREAK_);
            while ((*pc++)());              /* RUN STATEMENT */
        }
        ipc=cpc+1, compile=0, fclose(sf), sf=stdin; /* DONE COMPILING */
        emit(BYE_);
        while ((*pc++)());                      /* RUN PROGRAM */
    }
}

int PRINTS_(void) {
    puts((char*)*sp++);
    STEP;
}

int kwdhook_(char *msg) {
    if (!strcmp(msg,"PRINTS"))
        expr(), emit(PRINTS_);
    else	return 0;
    return 1;
}

int run_file(char *fn) {
    FILE *sf=stdin;
    initbasic(0);
    kwdhook=kwdhook_;
    if (fn)
        if ((sf=fopen(fn,"r")) != 0)
            compile++;
        else {
            printf("CANNOT OPEN: %s\n", fn);
            return 255;
        }
    return interp(sf, NULL);
}

int run_string(char *s) {
    initbasic(0);
    kwdhook=kwdhook_;
    return interp(NULL, s);
}

#if defined(TESTING)
int main(int argc, char **argv) {
    FILE *sf=stdin;
    initbasic(0);
    kwdhook=kwdhook_;
    if (argv[1])
        if ((sf=fopen(argv[1],"r")) != 0)
            compile++;
        else {
            printf("CANNOT OPEN: %s\n", argv[1]);
            return 255;
        }
    return interp(sf);
}
#endif
Compile the C code with:
gcc -c basic.c

Then compile with FreeBasic:
fbc jw.bas basic.o

Run:
jw

Code: Select all

Run string
line 1
line 2
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: My_basic interpreter

Post by aurelVZAB »

Hmm i never think that this is possible
if my small brain can understand this that .o file is a object file ..right?
uff C is in some moments so awkward to me ....!"##%&%&&

Yes Ed this while loop is strange ..
But it looks to me that Interpreter loop run in
two FOR loops because i see for ;;

Code: Select all

int interp(FILE *sf, char *script) {      /* INTERPRETER LOOP */
    for (;;) {
        int code=setjmp(trap);                  /* RETURN ON ERROR */
        if (code==1 && sf!=stdin) return 1;     /* FILE SYNTAX ERROR */
        if (code==2) opc=pc;                    /* FAULT */
        if (code==3) pc=opc?opc:pc, cpc=ipc;    /* "BREAK" */
        if (code==4) return 0;                  /* "BYE" */
        for (;;) {
            if (sf==stdin) printf("%d> ",lnum+1);
            if (sf!=NULL) {
                if (!fgets(lp=lbuf,sizeof lbuf,sf))
                    break;
            } else if (script != NULL) {
                lp = strchr(script, '\n');
                if (!lp) {
                    strcpy(lbuf, script);
                    script = NULL;
                } else {
                    int len = lp - script + 1;
                    memcpy(lbuf, script, len);
                    lbuf[len] = '\0';
                    script += len;
                }
                lp = lbuf;
            } else
                break;
            lnum++, ungot=0, stmt();        /* PARSE AND COMPILE */
            if (compile) continue;          /* CONTINUE COMPILING */
            opc=pc, pc=prg+ipc;             /* START OF IMMEDIATE */
            emit(BREAK_);
            while ((*pc++)());              /* RUN STATEMENT */
        }
        ipc=cpc+1, compile=0, fclose(sf), sf=stdin; /* DONE COMPILING */
        emit(BYE_);
        while ((*pc++)());                      /* RUN PROGRAM */
    }
..so it looks to me that this :
while ((*pc++)());

means ...
WHILE (pc <> 0) : pc=pc+1 : WEND
but because i don't know what is for;;
(..i am so stupid for C programming ..heh)

is for ;; -> run for loop forever
or is like forEACH statment ?
ahh just thining aloud...
this will really use take a lot of time i mean too much ??? right ?
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: My_basic interpreter

Post by counting_pine »

Here's a rough translate of interp() to FB:

Code: Select all

function interp(sf as FILE ptr, script as ubyte ptr) as integer
 while true
  dim as integer code = setjmp(trap)
  select case code
  case 1 '' file syntax error
   if sf <> stdin then return 1
  case 2 '' fault
   opc = pc
  case 3 '' "BREAK"
   if opc then pc = opc
   cpc = ipc
  case 4 '' "BYE"
   return 0
  end select

  while true
   if sf = stdin then printf "%d> ", lnum+1
   if sf <> NULL then
    lp = lbuf
    if fgets(lp, sizeof(lbuf), sf) = 0 then exit while
   elseif script <> NULL then
    lp = strchr(script, asc(!"\n"))
    if lp = 0 then
     strcpy(lbuf, script)
     script = NULL
    else
     dim as integer len_ = lp - script + 1
     memcpy(lbuf, script, len_)
     lbuf[len] = asc(!"\0")
     script += len_
    end if
    lp = lbuf
   else
    exit while
   end if
   lnum += 1: ungot = 0: stmt()     '' parse and compile
   if (compile) then continue while '' continue compiling
   opc = pc: pc = prg + ipc         '' start of immediate
   emit(BREAK_)
   while *pc <> 0: pc += 1: wend
  wend
  ipc = cpc + 1: compile = 0: fclose(sf): sf = stdin '' done compiling
  emit(BYE_)
  while *pc <> 0: pc += 1: wend '' run program
 wend
end function
'while *pc <> 0: pc += 1: wend' basically just scans for the end of a null-terminated stringarray.
Ed Davis
Posts: 37
Joined: Jul 28, 2008 23:24

Re: My_basic interpreter

Post by Ed Davis »

counting_pine wrote:Here's a rough translate of interp() to FB: ...

'while *pc <> 0: pc += 1: wend' basically just scans for the end of a null-terminated string.
But the actual C code is:

Code: Select all

 while ((*pc++)());
Which says to call the function that pc points to, and then point to the next function in the list. And keep doing it until the return from the function call is !0.
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: My_basic interpreter

Post by aurelVZAB »

Which says to call the function that pc points to, and then point to the next function in the list. And keep doing it until the return from the function call is !0.
WOW..that is complications
so that is have inside -> () ??
is that work in recursion?
..and why auch a complications ?
paul doe
Moderator
Posts: 1730
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: My_basic interpreter

Post by paul doe »

aurelVZAB wrote:...
WOW..that is complications
It's a simple way to implement the instruction dispatcher:

Code: Select all

type as function() as long INSTRUCTION

function foo() as long
  ? "Foo"
  return( 1 )
end function

function bar() as long
  ? "Bar"
  return( 1 )
end function

function baz() as long
  ? "Baz"
  return( 0 )
end function

dim as INSTRUCTION cs( ... ) = { @foo, @bar, @baz } '' cs stands for 'code segment'
dim as INSTRUCTION ptr pc = @cs( 0 ) '' pc stands for 'program counter'

'' Execute 'program'
do while( *pc() ) : pc += 1 : loop

sleep()
Last edited by paul doe on Jan 28, 2021 21:07, edited 2 times in total.
Ed Davis
Posts: 37
Joined: Jul 28, 2008 23:24

Re: My_basic interpreter

Post by Ed Davis »

aurelVZAB wrote:
Which says to call the function that pc points to, and then point to the next function in the list. And keep doing it until the return from the function call is !0.
WOW..that is complications
so that is have inside -> () ??
is that work in recursion?
..and why auch a complications ?
You think that is bad, see where pc is defined:

Code: Select all

int     (*prg[PRGSZ])(void),(**pc)(void),cpc,lmap[PRGSZ]; /* COMPILED PROGRAM */
There is actually a very good reason for using "while ((*pc++)())", and it is an common C idiom used when one is writing interpreters, command dispatchers and so forth. While K&R doesn't have this specific example, it explains pointers to function in enough details that you can figure it out.
Anyway, this probably isn't the right place to discuss C, and we've kind of hi-jacked the thread (It was about My_basic). If you want to discuss it more, feel free to email me.
Post Reply