704 lines
15 KiB
C
704 lines
15 KiB
C
/*
|
|
* The fLisp parser and interpreter
|
|
* Copyright (C) 2025 Fcalva
|
|
*
|
|
* This program is free software; you can redistribute it and/or
|
|
* modify it under the terms of the GNU General Public License
|
|
* as published by the Free Software Foundation; either version 2
|
|
* of the License, or (at your option) any later version.
|
|
*
|
|
* This program 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 General Public License for more details.
|
|
*
|
|
* You should have received a copy of the GNU General Public License
|
|
* along with this program; if not, see
|
|
* <https://www.gnu.org/licenses/>.
|
|
*/
|
|
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
#include <stdio.h>
|
|
#include <math.h>
|
|
|
|
#include "fixed.h"
|
|
#include "types.h"
|
|
#include "config.h"
|
|
#include "code_defs.h"
|
|
#include "byte_defs.h"
|
|
#include "exec_common.h"
|
|
|
|
typedef struct {
|
|
|
|
u32 pos;
|
|
u32 size;
|
|
|
|
} AllocBlock;
|
|
|
|
#define EXT_BLOCK 4096
|
|
|
|
void *internal_buf;
|
|
AllocBlock *blocks;
|
|
u32 *usage; // bitmap for usage, by 8byte chunks
|
|
size_t internal_size;
|
|
u32 block_count;
|
|
|
|
// Utils
|
|
|
|
void runtime_err(char *s){
|
|
fprintf(stderr,"Runtime Error : %s\n", s);
|
|
exit(1);
|
|
}
|
|
|
|
int evaluate(Value val){
|
|
if(val.tag.is_array)
|
|
return 0;
|
|
switch(val.tag.type){
|
|
case T_null:
|
|
return 0;
|
|
case T_int:
|
|
return val.v4B.value;
|
|
case T_fix:
|
|
return val.v4B.value;
|
|
case T_float:
|
|
return FL_EPSILON > fabs((float)val.v4B.value);
|
|
case T_str:
|
|
return 0;
|
|
case T_fn:
|
|
return 0;
|
|
default:
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
int alloc_extend(u32 size){
|
|
size = (size/EXT_BLOCK+1)*EXT_BLOCK;
|
|
internal_buf = realloc(internal_buf, internal_size+size);
|
|
usage = realloc(usage, sizeof(u32)*(internal_size+size)/32/8);
|
|
if(!internal_buf || !usage)
|
|
return 1;
|
|
memset(usage+(internal_size/32/8), 0, sizeof(u32)*size/32/8);
|
|
internal_size += size;
|
|
return 0;
|
|
}
|
|
|
|
int block_cmpfunc(const void *_a, const void *_b){
|
|
const AllocBlock *a = _a;
|
|
const AllocBlock *b = _b;
|
|
return b->pos - a->pos;
|
|
}
|
|
|
|
AllocBlock *get_block(u32 pos){
|
|
AllocBlock tmp = {.pos = pos};
|
|
AllocBlock *ret = bsearch(&tmp, blocks, block_count, sizeof(AllocBlock),
|
|
block_cmpfunc);
|
|
return ret;
|
|
}
|
|
|
|
int alloc_init(){
|
|
blocks = malloc(sizeof(AllocBlock));
|
|
block_count = 0;
|
|
internal_buf = NULL;
|
|
internal_size = 0;
|
|
usage = NULL;
|
|
if(!blocks || alloc_extend(EXT_BLOCK))
|
|
return 1;
|
|
// First 32bytes are reserved for null + alignement
|
|
usage[0] = 0xF;
|
|
return 0;
|
|
}
|
|
|
|
void alloc_clean(){
|
|
free(internal_buf);
|
|
free(blocks);
|
|
free(usage);
|
|
}
|
|
|
|
u32 flisp_alloc(u32 size){
|
|
u32 pos = 32;
|
|
u32 curr_free = 0;
|
|
while(pos < internal_size){
|
|
if(usage[pos/32/8]){
|
|
for(u32 opos = pos; pos < opos+32;){
|
|
if((usage[pos/32/8]>>((pos/8)%32)) & 1)
|
|
curr_free = 0;
|
|
else
|
|
curr_free+=8;
|
|
pos+=8;
|
|
if(curr_free >= size)
|
|
break;
|
|
}
|
|
}
|
|
else {
|
|
curr_free += 32*8;
|
|
pos+=32*8;
|
|
}
|
|
if(curr_free >= size){
|
|
blocks = realloc(blocks, sizeof(AllocBlock)*(block_count+1));
|
|
if(!blocks)
|
|
return 0;
|
|
AllocBlock *block = &blocks[block_count++];
|
|
block->pos = pos-curr_free;
|
|
block->size = size;
|
|
for(u32 i = block->pos; i < block->pos+size; i+=8){
|
|
usage[i/32/8] |= 1<<((i/8)%32);
|
|
}
|
|
// Unvirtualize the memory
|
|
memset(get_addr(block->pos),0xB00B5069,size);
|
|
return block->pos;
|
|
}
|
|
}
|
|
if(alloc_extend(size))
|
|
return 0;
|
|
|
|
// Try again after extending the buffer
|
|
return flisp_alloc(size);
|
|
}
|
|
|
|
// TODO : make it efficient
|
|
u32 flisp_realloc(u32 pos, u32 size){
|
|
if(!pos)
|
|
return flisp_alloc(size);
|
|
u32 new = flisp_alloc(size);
|
|
if(!new)
|
|
return 0;
|
|
AllocBlock *block = get_block(pos);
|
|
memcpy(get_addr(new),get_addr(pos),block->size);
|
|
flisp_free(pos);
|
|
return new;
|
|
}
|
|
|
|
void flisp_free(u32 pos){
|
|
AllocBlock *ret = get_block(pos);
|
|
if(!ret)
|
|
return;
|
|
i32 bpos = (size_t)(ret-blocks)/sizeof(AllocBlock);
|
|
memset(get_addr(ret->pos), 0, ret->size);
|
|
memmove(ret, ret+1, sizeof(AllocBlock) * (block_count-bpos-1));
|
|
block_count--;
|
|
}
|
|
|
|
void *get_addr(u32 pos){
|
|
return internal_buf + pos;
|
|
}
|
|
|
|
Value write(Value a);
|
|
|
|
void print_ast1(Statement *base, i32 indent){
|
|
i32 close_parent = 1;
|
|
printf("# ");
|
|
for(int i = 0; i < indent; i++)
|
|
printf(" ");
|
|
switch(base->type){
|
|
case ST_None:
|
|
printf("(none\n");
|
|
break;
|
|
case ST_Call:
|
|
printf("(call<%lx>\n", (u64)base->func);
|
|
break;
|
|
case ST_Const:
|
|
write(base->cons);
|
|
printf("\n");
|
|
close_parent = 0;
|
|
break;
|
|
case ST_Var:
|
|
printf("<%d>\n", base->var_id);
|
|
close_parent = 0;
|
|
break;
|
|
case ST_Block:
|
|
printf("(block\n");
|
|
break;
|
|
case ST_Varuse:
|
|
printf("(use<%d>\n", base->var_id);
|
|
break;
|
|
case BI_var:
|
|
printf("(var<%d>:<%d>\n", base->var_id, base->var_type.type);
|
|
break;
|
|
case BI_if:
|
|
printf("(if\n");
|
|
break;
|
|
case BI_else:
|
|
printf("(else\n");
|
|
break;
|
|
case BI_while:
|
|
printf("(while\n");
|
|
break;
|
|
case BI_is:
|
|
printf("(is<%d>\n", base->var_type.type);
|
|
break;
|
|
case BI_cast:
|
|
printf("(cast<%d>\n", base->var_type.type);
|
|
break;
|
|
default:
|
|
printf("(other<%d>\n", base->type);
|
|
break;
|
|
}
|
|
for(int i = 0; i < base->child_n; i++)
|
|
print_ast1(base->children[i], indent+1);
|
|
|
|
if(close_parent){
|
|
printf("# ");
|
|
for(int i = 0; i < indent; i++)
|
|
printf(" ");
|
|
printf(")\n");
|
|
}
|
|
}
|
|
|
|
void print_ast(Statement *base){
|
|
#if LOG
|
|
printf("# AST :\n");
|
|
print_ast1(base, 0);
|
|
#endif
|
|
}
|
|
|
|
Value str_to_val(char *str, i32 len){
|
|
if(len < 0)
|
|
len = strlen(str);
|
|
Value retv;
|
|
retv.tag = (Tag){.is_array = 0, .type = T_str};
|
|
#if LOG
|
|
printf("str (%d) : %s\n", len, str);
|
|
#endif
|
|
if(len > 4){
|
|
u32 nstr = flisp_alloc(len);
|
|
if(!nstr){
|
|
retv.tag = ntag;
|
|
return retv;
|
|
}
|
|
retv.vstr.pos = nstr;
|
|
memcpy(get_addr(nstr),str,len);
|
|
}
|
|
else {
|
|
for(i32 i = 0; i < len; i++)
|
|
retv.vstr.str[i] = str[i];
|
|
}
|
|
retv.vstr.len = len;
|
|
return retv;
|
|
}
|
|
|
|
void clean_strval(Value str){
|
|
if(str.vstr.len < 5)
|
|
return;
|
|
flisp_free(str.vstr.pos);
|
|
}
|
|
|
|
// Lesser special functions
|
|
|
|
Value is(Tag tag, Value b){
|
|
Value ret = {.tag = {0,T_int}};
|
|
ret.v4B.value = tag.is_array == b.tag.is_array && tag.type == b.tag.type;
|
|
return ret;
|
|
}
|
|
|
|
typedef Value (cast_fn_t)(Value);
|
|
|
|
Value int_to_fix(Value x){
|
|
x.tag.type = T_fix;
|
|
x.v4B.value = fix(x.v4B.value);
|
|
return x;
|
|
}
|
|
|
|
Value int_to_flt(Value x){
|
|
x.tag.type = T_float;
|
|
x.v4B.vfl = (float)x.v4B.value;
|
|
return x;
|
|
}
|
|
|
|
Value fix_to_int(Value x){
|
|
x.tag.type = T_int;
|
|
x.v4B.value = ffloor(x.v4B.value);
|
|
return x;
|
|
}
|
|
|
|
Value fix_to_flt(Value x){
|
|
x.tag.type = T_float;
|
|
x.v4B.vfl = f2float(x.v4B.value);
|
|
return x;
|
|
}
|
|
|
|
Value flt_to_int(Value x){
|
|
x.tag.type = T_int;
|
|
x.v4B.value = (i32)(x.v4B.vfl);
|
|
return x;
|
|
}
|
|
|
|
Value flt_to_fix(Value x){
|
|
x.tag.type = T_fix;
|
|
x.v4B.value = fixfloat(x.v4B.vfl);
|
|
return x;
|
|
}
|
|
|
|
char tmpbuf[256];
|
|
|
|
Value int_to_str(Value x){
|
|
i32 len = snprintf(tmpbuf, 256, "%d", x.v4B.value);
|
|
len = len > 256 ? 256:len;
|
|
Value retv = str_to_val(tmpbuf, len);
|
|
return retv;
|
|
}
|
|
|
|
Value fix_to_str(Value x){
|
|
i32 len = snprintf(tmpbuf, 256, "%f", f2float(x.v4B.value));
|
|
len = len > 256 ? 256:len;
|
|
Value retv = str_to_val(tmpbuf, len);
|
|
return retv;
|
|
}
|
|
|
|
Value flt_to_str(Value x){
|
|
i32 len = snprintf(tmpbuf, 256, "%f", x.v4B.vfl);
|
|
len = len > 256 ? 256:len;
|
|
Value retv = str_to_val(tmpbuf, len);
|
|
return retv;
|
|
}
|
|
|
|
Value vstr_to(Value x, i32 type){
|
|
char *str;
|
|
Value retv;
|
|
if(x.vstr.len > 4)
|
|
str = get_addr(x.vstr.pos);
|
|
else
|
|
str = x.vstr.str;
|
|
char *nstr = malloc(x.vstr.len+1);
|
|
if(!nstr){
|
|
retv.tag = ntag;
|
|
clean_strval(x);
|
|
return retv;
|
|
}
|
|
memcpy(nstr, str, x.vstr.len);
|
|
clean_strval(x);
|
|
nstr[x.vstr.len] = '\0';
|
|
i32 ret = 0;
|
|
switch(type){
|
|
case T_int:
|
|
ret = sscanf(nstr, "%d", &retv.v4B.value);
|
|
break;
|
|
case T_fix:
|
|
ret = sscanf(nstr, "%f", &retv.v4B.vfl);
|
|
x.v4B.value = fix(x.v4B.vfl);
|
|
break;
|
|
case T_float:
|
|
ret = sscanf(nstr, "%f", &retv.v4B.vfl);
|
|
break;
|
|
default:
|
|
break;
|
|
}
|
|
free(nstr);
|
|
if(!ret){
|
|
retv.tag = ntag;
|
|
return retv;
|
|
}
|
|
retv.tag = (Tag){.is_array = 0, .type = type};
|
|
|
|
return retv;
|
|
}
|
|
|
|
Value str_to_int(Value x){
|
|
return vstr_to(x,T_int);
|
|
}
|
|
|
|
Value str_to_fix(Value x){
|
|
return vstr_to(x,T_fix);
|
|
}
|
|
|
|
Value str_to_flt(Value x){
|
|
return vstr_to(x,T_float);
|
|
}
|
|
|
|
// [from][to]
|
|
cast_fn_t *cast_table[4][4] = {
|
|
{NULL , int_to_fix, int_to_flt, int_to_str},
|
|
{fix_to_int, NULL , fix_to_flt, fix_to_str},
|
|
{flt_to_int, flt_to_fix, NULL , flt_to_str},
|
|
{str_to_int, str_to_fix, str_to_flt, NULL }
|
|
};
|
|
|
|
Value cast(Tag type, Value b){
|
|
if(type.type == b.tag.type)
|
|
return b;
|
|
if(type.type == T_null || b.tag.type == T_null || type.type == T_fn
|
|
|| b.tag.type == T_fn || type.is_array || b.tag.is_array){
|
|
b.tag.type = T_null;
|
|
return b;
|
|
}
|
|
return cast_table[b.tag.type-1][type.type-1](b);
|
|
}
|
|
|
|
// Generic builtins
|
|
|
|
Value add(Value a, Value b){
|
|
if(a.tag.is_array || b.tag.is_array)
|
|
runtime_err("Add : Invalid types");
|
|
if(a.tag.type != b.tag.type)
|
|
runtime_err("Add : Types do not match");
|
|
switch(a.tag.type){
|
|
case T_int:
|
|
case T_fix:
|
|
a.v4B.value += b.v4B.value;
|
|
break;
|
|
case T_float:
|
|
a.v4B.vfl += b.v4B.vfl;
|
|
break;
|
|
case T_str:
|
|
if(a.vstr.len + b.vstr.len > 4){
|
|
runtime_err("not implem");
|
|
}
|
|
else {
|
|
for(int i = 0; i < b.vstr.len; i++)
|
|
a.vstr.str[a.vstr.len + i] = b.vstr.str[i];
|
|
a.vstr.len += b.vstr.len;
|
|
}
|
|
break;
|
|
default:
|
|
runtime_err("Add : Invalid types");
|
|
}
|
|
return a;
|
|
}
|
|
|
|
Value sub(Value a, Value b){
|
|
if(a.tag.is_array || b.tag.is_array)
|
|
runtime_err("Sub : Invalid types");
|
|
if(a.tag.type != b.tag.type)
|
|
runtime_err("Sub : Types do not match");
|
|
switch(a.tag.type){
|
|
case T_int:
|
|
case T_fix:
|
|
a.v4B.value -= b.v4B.value;
|
|
break;
|
|
case T_float:
|
|
a.v4B.vfl -= b.v4B.vfl;
|
|
break;
|
|
default:
|
|
runtime_err("Sub : Invalid types");
|
|
}
|
|
return a;
|
|
}
|
|
|
|
Value mul(Value a, Value b){
|
|
if(a.tag.is_array || b.tag.is_array)
|
|
runtime_err("Mul : Invalid types");
|
|
if(a.tag.type != b.tag.type)
|
|
runtime_err("Mul : Types do not match");
|
|
switch(a.tag.type){
|
|
case T_int:
|
|
a.v4B.value *= b.v4B.value;
|
|
break;
|
|
case T_fix:
|
|
a.v4B.value = fmul(a.v4B.value, b.v4B.value);
|
|
break;
|
|
case T_float:
|
|
a.v4B.vfl *= b.v4B.vfl;
|
|
break;
|
|
default:
|
|
runtime_err("Mul : Invalid types");
|
|
}
|
|
return a;
|
|
}
|
|
|
|
Value divv(Value a, Value b){
|
|
if(a.tag.is_array || b.tag.is_array)
|
|
runtime_err("Div : Invalid types");
|
|
if(a.tag.type != b.tag.type)
|
|
runtime_err("Div : Types do not match");
|
|
switch(a.tag.type){
|
|
case T_int:
|
|
a.v4B.value /= b.v4B.value;
|
|
break;
|
|
case T_fix:
|
|
a.v4B.value = fdiv(a.v4B.value, b.v4B.value);
|
|
break;
|
|
case T_float:
|
|
a.v4B.vfl /= b.v4B.vfl;
|
|
break;
|
|
default:
|
|
runtime_err("Div : Invalid types");
|
|
}
|
|
return a;
|
|
}
|
|
|
|
Value mod(Value a, Value b){
|
|
if(a.tag.is_array || b.tag.is_array)
|
|
runtime_err("Mod : Invalid types");
|
|
if(a.tag.type != b.tag.type)
|
|
runtime_err("Mod : Types do not match");
|
|
switch(a.tag.type){
|
|
case T_int:
|
|
a.v4B.value /= b.v4B.value;
|
|
break;
|
|
case T_fix:
|
|
a.v4B.value = fdiv(a.v4B.value, b.v4B.value);
|
|
break;
|
|
case T_float:
|
|
a.v4B.vfl = (int)a.v4B.vfl % (int)b.v4B.vfl;
|
|
break;
|
|
default:
|
|
runtime_err("Mod : Invalid types");
|
|
}
|
|
return a;
|
|
}
|
|
|
|
Value sml(Value a, Value b){
|
|
Value returnv;
|
|
returnv.tag = (Tag){.is_array=0,.type=T_int};
|
|
if(a.tag.is_array || b.tag.is_array)
|
|
runtime_err("Sml : Invalid types");
|
|
if(a.tag.type != b.tag.type)
|
|
runtime_err("Sml : Types do not match");
|
|
switch(a.tag.type){
|
|
case T_int:
|
|
case T_fix:
|
|
returnv.v4B.value = a.v4B.value < b.v4B.value;
|
|
break;
|
|
case T_float:
|
|
returnv.v4B.value = a.v4B.vfl < b.v4B.vfl;
|
|
break;
|
|
default:
|
|
runtime_err("Sml : Invalid types");
|
|
}
|
|
return returnv;
|
|
}
|
|
|
|
Value sml_eq(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value eq(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value gt_eq(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value gt(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value not(Value a){
|
|
|
|
}
|
|
|
|
Value and(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value or(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value len(Value a){
|
|
|
|
}
|
|
|
|
Value push(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value pop(Value a, Value b){
|
|
|
|
}
|
|
|
|
Value write(Value a){
|
|
switch(a.tag.type){
|
|
case T_null:
|
|
case T_any:
|
|
printf("null");
|
|
break;
|
|
case T_int:
|
|
printf("%d",a.v4B.value);
|
|
break;
|
|
case T_fix:
|
|
printf("%f",f2float(a.v4B.value));
|
|
break;
|
|
case T_float:
|
|
printf("%f",a.v4B.vfl);
|
|
break;
|
|
case T_str:
|
|
char *nstr;
|
|
nstr = malloc(a.vstr.len+1);
|
|
if(a.vstr.len > 4){
|
|
char *str = get_addr(a.vstr.pos);
|
|
memcpy(nstr, str, a.vstr.len);
|
|
}
|
|
else{
|
|
memcpy(nstr, a.vstr.str, a.vstr.len);
|
|
}
|
|
nstr[a.vstr.len] = '\0';
|
|
printf("%s",nstr);
|
|
free(nstr);
|
|
break;
|
|
case T_fn:
|
|
printf("<fn @%lx>", (u64)get_fnsig(&a));
|
|
break;
|
|
default:
|
|
break;
|
|
}
|
|
return (Value){.tag={0,T_null}};
|
|
}
|
|
|
|
Value nwline(){
|
|
printf("\n");
|
|
return (Value){.tag={0,T_null}};
|
|
}
|
|
|
|
const Tag tany = {0,T_null};
|
|
const Tag tint = {0,T_int};
|
|
const Tag tfix = {0,T_fix};
|
|
const Tag tfloat = {0,T_float};
|
|
const Tag tstr = {0,T_str};
|
|
const Tag tfn = {0,T_fn};
|
|
const Tag tvec = {1,T_null};
|
|
|
|
#define BICAST(x) ((bi_fn_t*)(x))
|
|
|
|
FnSig builtins[] = {
|
|
{{tany,tany},2,1,{.bi = BICAST(add)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(sub)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(mul)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(divv)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(mod)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(sml)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(sml_eq)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(eq)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(gt_eq)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(gt)}},
|
|
{{tany} ,1,1,{.bi = BICAST(not)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(and)}},
|
|
{{tany,tany},2,1,{.bi = BICAST(or)}},
|
|
{{tvec} ,1,1,{.bi = BICAST(len)}},
|
|
{{tvec,tany},2,1,{.bi = BICAST(push)}},
|
|
{{tvec,tint},2,1,{.bi = BICAST(pop)}},
|
|
{{tany} ,1,1,{.bi = BICAST(write)}},
|
|
{{0} ,0,1,{.bi = BICAST(nwline)}}
|
|
};
|
|
|
|
char *bi_names[] = {
|
|
"+",
|
|
"-",
|
|
"*",
|
|
"/",
|
|
"%",
|
|
"<",
|
|
"<=",
|
|
"=",
|
|
">=",
|
|
">",
|
|
"!",
|
|
"and",
|
|
"or",
|
|
"len",
|
|
"push",
|
|
"pop",
|
|
"write",
|
|
"newline"
|
|
};
|
|
|
|
void symbol_map_add_bi(HashMap *map){
|
|
Tag fntag = {0,T_fn};
|
|
for(int i = BI_add; i < BI__end; i++){
|
|
MapItem *ret = hashmap_insert(map, bi_names[i-BI_add]);
|
|
ret->type = *((i16*)&fntag);
|
|
ret->fnsig = &builtins[i-BI_add];
|
|
ret->is_const = 1;
|
|
}
|
|
}
|