Verified Commit a615aeef authored by Camil Staps's avatar Camil Staps 🚀

Implement C versions of closeF, endF, errorF, openF, readFC, readLineF,...

Implement C versions of closeF, endF, errorF, openF, readFC, readLineF, stdioF, writeFC, and writeFS
parent fecc8baf
#define MAX_N_FILES 20
#define MAX_FILE_NAME_LENGTH 255
#ifdef MACH_O64
# define NEWLINE_CHAR '\r'
#else
# define NEWLINE_CHAR '\n'
#endif
#define F_READ_TEXT 0
#define F_WRITE_TEXT 1
#define F_APPEND_TEXT 2
#define F_READ_DATA 3
#define F_WRITE_DATA 4
#define F_APPEND_DATA 5
static char *file_modes[]={"r","w",NULL/*a*/,"rb",NULL/*wb*/,NULL/*ab*/};
struct file {
FILE *file_handle;
};
static struct file clean_stdinout;
static struct file clean_stderr;
#define IO_error(s) do { EPRINTF("IO error: %s\n",s); goto IO_error_halt; } while (0)
static int stdio_open=0;
static int last_readLineF_failed=0;
static long clean_get_line(char *dest,long max_length) {
for (long length=1; length<=max_length; length++) {
char c=getchar();
*dest++=c;
if (c==NEWLINE_CHAR)
return length;
}
return -1;
}
......@@ -227,6 +227,12 @@ BC_WORD Fjmp_ap[32] =
, Cjmp_ap32
};
#include "files.h"
BC_WORD *g_asp, *g_bsp, *g_hp;
BC_WORD_S g_heap_free;
int trap_needs_gc = 0;
void* __interpreter_cycle_in_spine[2] = {
(void*) 0,
(void*) Chalt
......
......@@ -52,11 +52,12 @@ char *strsep(char **stringp, const char *delim);
extern char print_buffer[];
# ifdef STDERR_TO_FILE
void stderr_print(int);
# define EPRINTF(...) stderr_print(snprintf(print_buffer, PRINT_BUFFER_SIZE-1, __VA_ARGS__))
# define EPRINTF(...) stderr_print(snprintf(print_buffer, PRINT_BUFFER_SIZE-1, __VA_ARGS__))
# else
extern void ew_print_text(char*,int);
# define EPRINTF(...) ew_print_text(print_buffer, snprintf(print_buffer, PRINT_BUFFER_SIZE-1, __VA_ARGS__))
# define EPRINTF(...) ew_print_text(print_buffer, snprintf(print_buffer, PRINT_BUFFER_SIZE-1, __VA_ARGS__))
# endif
# define EPUTCHAR(c) EPRINTF("%c",c)
extern void w_print_text(char*,int);
extern void w_print_char(char);
# define PRINTF(...) w_print_text(print_buffer, snprintf(print_buffer, PRINT_BUFFER_SIZE-1, __VA_ARGS__))
......@@ -66,9 +67,11 @@ extern void w_print_char(char);
# include "debug_curses.h"
# define EPRINTF debugger_printf
# define PRINTF debugger_printf
# define EPUTCHAR debugger_putchar
# define PUTCHAR debugger_putchar
#else
# define EPRINTF(...) fprintf(stderr,__VA_ARGS__)
# define PRINTF printf
# define EPUTCHAR(c) fputc(c,stderr)
# define PUTCHAR putchar
#endif
definition module specialized
import target
instr_halt :: !Target -> Target
instr_divLU :: !Target -> Target
instr_mulUUL :: !Target -> Target
instr_RtoAC :: !Target -> Target
instr_closeF :: !Target -> Target
instr_endF :: !Target -> Target
instr_errorF :: !Target -> Target
instr_openF :: !Target -> Target
instr_readFC :: !Target -> Target
instr_readLineF :: !Target -> Target
instr_stdioF :: !Target -> Target
instr_writeFC :: !Target -> Target
instr_writeFS :: !Target -> Target
implementation module specialized
import target
instr_halt :: !Target -> Target
instr_halt t = foldl (flip append) t
[ "#ifdef DEBUG_CURSES"
, "\tdebugger_graceful_end();"
, "#endif"
, "#ifdef LINK_CLEAN_RUNTIME"
, "\t{"
, "\t\tEPRINTF(\"Stack trace:\\n\");"
, "\t\tBC_WORD *start_csp = &stack[stack_size >> 1];"
, "\t\tchar _tmp[256];"
, "\t\tfor (; csp>start_csp; csp--) {"
, "\t\t\tprint_label(_tmp, 256, 1, (BC_WORD*)*csp, program, ie->heap, ie->heap_size);"
, "\t\t\tEPRINTF(\"%s\\n\",_tmp);"
, "\t\t}"
, "\t}"
, "\tinterpret_error=&e__ABC_PInterpreter__dDV__Halt;"
, "\tEXIT(ie,1);"
, "\tgoto eval_to_hnf_return_failure;"
, "#else"
, "\treturn 0;"
, "#endif"
]
instr_divLU :: !Target -> Target
instr_divLU t = foldl (flip append) t
[ "{"
, "#if defined(WINDOWS) && WORD_WIDTH==64"
, "\tEPRINTF(\"divLU is not supported on 64-bit Windows\\n\");"
, "#else"
, "# if WORD_WIDTH==64"
, "\t__int128_t num=((__int128_t)bsp[0] << 64) + bsp[1];"
, "# else"
, "\tint64_t num=((int64_t)bsp[0] << 32) + bsp[1];"
, "# endif"
, "\tbsp[1]=num%bsp[2];"
, "\tbsp[2]=num/bsp[2];"
, "\tbsp+=1;"
, "\tpc+=1;"
, "\tEND_INSTRUCTION_BLOCK;"
, "#endif"
, "}"
]
instr_mulUUL :: !Target -> Target
instr_mulUUL t = foldl (flip append) t
[ "{"
, "#if defined(WINDOWS) && WORD_WIDTH==64"
, "\tEPRINTF(\"mulUUL is not supported on 64-bit Windows\\n\");"
, "#else"
, "# if WORD_WIDTH==64"
, "\t__uint128_t res=(__uint128_t)((__uint128_t)bsp[0] * (__uint128_t)bsp[1]);"
, "# else"
, "\tuint64_t res=(uint64_t)bsp[0] * (uint64_t)bsp[1];"
, "# endif"
, "\tbsp[0]=res>>WORD_WIDTH;"
, "\tbsp[1]=(BC_WORD)res;"
, "\tpc+=1;"
, "\tEND_INSTRUCTION_BLOCK;"
, "#endif"
, "}"
]
instr_RtoAC :: !Target -> Target
instr_RtoAC t = foldl (flip append) t
[ "{"
, "char r[22];"
, "int n=sprintf(r,\"%.15g\",*((BC_REAL*)bsp)+0.0);"
, "NEED_HEAP(2+((n+IF_INT_64_OR_32(7,3))>>IF_INT_64_OR_32(3,2)));"
, "hp[0]=(BC_WORD)&__STRING__+2;"
, "hp[1]=n;"
, "memcpy(&hp[2],r,n);"
, "pc+=1;"
, "bsp+=1;"
, "asp[1]=(BC_WORD)hp;"
, "asp+=1;"
, "hp+=2+((n+IF_INT_64_OR_32(7,3))>>IF_INT_64_OR_32(3,2));"
, "}"
]
instr_closeF :: !Target -> Target
instr_closeF t = foldl (flip append) t
[ "{"
, "pc++;"
, "struct file *f=(struct file*)bsp[1];"
, "bsp++;"
, "if (f==&clean_stdinout) {"
, "\tif (!stdio_open)"
, "\t\tIO_error(\"fclose: file not open (stdio)\");"
, "\tstdio_open=0;"
, "\tbsp[0]=(ferror(stdin) || ferror(stdout)) ? 0 : 1;"
, "} else if (f==&clean_stderr) {"
, "\tbsp[0]=1;"
, "} else {"
, "\tfclose(f->file_handle);"
, "\tbsp[0]=ferror(f->file_handle) ? 0 : 1;"
, "\tfree(f);"
, "}"
, "}"
]
instr_endF :: !Target -> Target
instr_endF t = foldl (flip append) t
[ "{"
, "pc++;"
, "struct file *f=(struct file*)bsp[1];"
, "FILE *h;"
, "if (f==&clean_stdinout)"
, "\th=stdin;"
, "else if (f==&clean_stderr)"
, "\tIO_error(\"endF stderr not implemented\");"
, "else"
, "\th=f->file_handle;"
, "char c=getc(h);"
, "if (c==EOF) {"
, "\t*--bsp=1;"
, "} else {"
, "\tungetc(c,h);"
, "\t*--bsp=0;"
, "}"
, "}"
]
instr_errorF :: !Target -> Target
instr_errorF t = foldl (flip append) t
[ "{"
, "pc++;"
, "struct file *f=(struct file*)bsp[1];"
, "if (f==&clean_stdinout)"
, "\t*--bsp=(ferror(stdin) || ferror(stdout)) ? 1 : 0;"
, "else if (f==&clean_stderr)"
, "\t*--bsp=ferror(stderr) ? 1 : 0;"
, "else"
, "\t*--bsp=ferror(f->file_handle) ? 1 : 0;"
, "}"
]
instr_openF :: !Target -> Target
instr_openF t = foldl (flip append) t
[ "{"
, "pc++;"
, "struct file *f=safe_malloc(sizeof(struct file));"
, "BC_WORD *clean_file_name=(BC_WORD*)asp[0];"
, "asp--;"
, "char *file_name=safe_malloc(clean_file_name[1]+1);"
, "memcpy(file_name,&clean_file_name[2],clean_file_name[1]);"
, "file_name[clean_file_name[1]]='\\0';"
, "if (bsp[0]>=6)"
, "\tIO_error(\"openF: illegal mode\");"
, "char *mode=file_modes[bsp[0]];"
, "if (mode==NULL)"
, "\tIO_error(\"openF: unimplemented mode\");"
, "f->file_handle=fopen(file_name,mode);"
, "bsp-=2;"
, "bsp[1]=0;"
, "if (f->file_handle==NULL) {"
, "\tbsp[0]=0;" // not ok
, "\tfree(f);"
, "} else {"
, "\tbsp[0]=1;" // ok
, "\tbsp[2]=(BC_WORD)f;"
, "}"
, "free(file_name);"
, "}"
]
instr_readFC :: !Target -> Target
instr_readFC t = foldl (flip append) t
[ "{"
, "pc++;"
, "struct file *f=(struct file*)bsp[1];"
, "bsp-=2;"
, "if (f==&clean_stdinout) {"
, "\tbsp[1]=getchar();"
, "\tbsp[0]=ferror(stdin) ? 0 : 1;"
, "} else if (f==&clean_stderr) {"
, "\tIO_error(\"FReadC: can't read from StdErr\");"
, "} else {"
, "\tbsp[1]=getc(f->file_handle);"
, "\tbsp[0]=ferror(f->file_handle) ? 0 : 1;"
, "}"
, "}"
]
instr_readLineF :: !Target -> Target
instr_readLineF t = foldl (flip append) t
[ "{"
, "struct file *f=(struct file*)bsp[1];"
, "if (f==&clean_stdinout) {"
, "\thp[0]=(BC_WORD)&__STRING__+2;"
, "\tBC_WORD max_bytes=(heap_free-2)<<IF_INT_64_OR_32(3,2);"
, "\tchar *dest=(char*)&hp[2];"
, "\tif (last_readLineF_failed) {"
, "\t\tBC_WORD *old_string=(BC_WORD*)asp[0];"
, "\t\tmemcpy(dest,&old_string[2],old_string[1]);"
, "\t\tdest+=old_string[1];"
, "\t\tasp[0]=(BC_WORD)hp;"
, "\t} else {"
, "\t\tasp[1]=(BC_WORD)hp;"
, "\t\tasp++;"
, "\t}"
, "\thp[1]=clean_get_line((char*)dest,max_bytes);"
, "\tif (hp[1]==-1) {"
, "\t\thp[1]=max_bytes;"
, "\t\theap_free=0;"
, "\t\tlast_readLineF_failed=1;"
, "\t\tGARBAGE_COLLECT;"
, "\t} else {"
, "\t\tBC_WORD words_used=2+((hp[1]+IF_INT_64_OR_32(7,3))>>IF_INT_64_OR_32(3,2));"
, "\t\thp+=words_used;"
, "\t\theap_free-=words_used;"
, "\t}"
, "\tpc++;"
, "\tlast_readLineF_failed=0;"
, "} else if (f==&clean_stderr) {"
, "\tIO_error(\"freadline: can't read from stderr\");"
, "} else {"
, "\tIO_error(\"readLineF fallthrough\");" // TODO
, "}"
, "}"
]
instr_stdioF :: !Target -> Target
instr_stdioF t = foldl (flip append) t
[ "if (stdio_open)"
, "\tIO_error(\"stdio: already open\");"
, "pc+=1;"
, "stdio_open=1;"
, "bsp[-1]=(BC_WORD)&clean_stdinout;"
, "bsp[-2]=-1;"
, "bsp-=2;"
]
instr_writeFC :: !Target -> Target
instr_writeFC t = foldl (flip append) t
[ "{"
, "pc++;"
, "char c=*bsp++;"
, "struct file *f=(struct file*)bsp[1];"
, "if (f==&clean_stdinout)"
, "\tPUTCHAR(c);"
, "else if (f==&clean_stderr)"
, "\tEPUTCHAR(c);"
, "else"
, "\tputc(c,f->file_handle);"
, "}"
]
instr_writeFS :: !Target -> Target
instr_writeFS t = foldl (flip append) t
[ "{"
, "struct file *f=(struct file*)bsp[1];"
, "BC_WORD *n=(BC_WORD*)asp[0];"
, "int len=n[1];"
, "char *s=(char*)&n[2];"
, "pc++;"
, "asp--;"
, "if (f==&clean_stdinout)"
, "\tfor (;len;len--) PUTCHAR(*s++);"
, "else if (f==&clean_stderr)"
, "\tfor (;len;len--) EPUTCHAR(*s++);"
, "else"
, "\tIO_error(\"writeFS fallthrough\");" // TODO
, "}"
]
......@@ -7,15 +7,13 @@ import interpretergen
:: Target
:: Expr t
append :: !String !Target -> Target
start :: Target
bootstrap :: ![String] -> [String]
collect_instructions :: !Options ![Target] -> [String]
instr_unimplemented :: !Target -> Target
instr_halt :: !Target -> Target
instr_divLU :: !Target -> Target
instr_mulUUL :: !Target -> Target
instr_RtoAC :: !Target -> Target
lit_word :: !Int -> Expr TWord
lit_hword :: !Int -> Expr TPtrOffset
......
......@@ -19,6 +19,9 @@ import interpretergen
.o 1 0
}
append :: !String !Target -> Target
append e t = {t & output=[e:t.output]}
start :: Target
start = {instrs=[], output=[], var_counter=0}
......@@ -67,7 +70,6 @@ where
head = ["INSTRUCTION_BLOCK("+++i+++"):" \\ i <- t.instrs]
out = reverse t.output
append e t :== {t & output=[e:t.output]}
mark t :== append "MARK" t
concat_up_to_mark t=:{output} :==
let (ls,[_:rest]) = span ((<>) "MARK") output in
......@@ -101,85 +103,6 @@ instr_unimplemented t = foldl (flip append) t
, "#endif"
]
instr_halt :: !Target -> Target
instr_halt t = foldl (flip append) t
[ "#ifdef DEBUG_CURSES"
, "\tdebugger_graceful_end();"
, "#endif"
, "#ifdef LINK_CLEAN_RUNTIME"
, "\t{"
, "\t\tEPRINTF(\"Stack trace:\\n\");"
, "\t\tBC_WORD *start_csp = &stack[stack_size >> 1];"
, "\t\tchar _tmp[256];"
, "\t\tfor (; csp>start_csp; csp--) {"
, "\t\t\tprint_label(_tmp, 256, 1, (BC_WORD*)*csp, program, ie->heap, ie->heap_size);"
, "\t\t\tEPRINTF(\"%s\\n\",_tmp);"
, "\t\t}"
, "\t}"
, "\tinterpret_error=&e__ABC_PInterpreter__dDV__Halt;"
, "\tEXIT(ie,1);"
, "\tgoto eval_to_hnf_return_failure;"
, "#else"
, "\treturn 0;"
, "#endif"
]
instr_divLU :: !Target -> Target
instr_divLU t = foldl (flip append) t
[ "{"
, "#if defined(WINDOWS) && WORD_WIDTH==64"
, "\tEPRINTF(\"divLU is not supported on 64-bit Windows\\n\");"
, "#else"
, "# if WORD_WIDTH==64"
, "\t__int128_t num=((__int128_t)bsp[0] << 64) + bsp[1];"
, "# else"
, "\tint64_t num=((int64_t)bsp[0] << 32) + bsp[1];"
, "# endif"
, "\tbsp[1]=num%bsp[2];"
, "\tbsp[2]=num/bsp[2];"
, "\tbsp+=1;"
, "\tpc+=1;"
, "\tEND_INSTRUCTION_BLOCK;"
, "#endif"
, "}"
]
instr_mulUUL :: !Target -> Target
instr_mulUUL t = foldl (flip append) t
[ "{"
, "#if defined(WINDOWS) && WORD_WIDTH==64"
, "\tEPRINTF(\"mulUUL is not supported on 64-bit Windows\\n\");"
, "#else"
, "# if WORD_WIDTH==64"
, "\t__uint128_t res=(__uint128_t)((__uint128_t)bsp[0] * (__uint128_t)bsp[1]);"
, "# else"
, "\tuint64_t res=(uint64_t)bsp[0] * (uint64_t)bsp[1];"
, "# endif"
, "\tbsp[0]=res>>WORD_WIDTH;"
, "\tbsp[1]=(BC_WORD)res;"
, "\tpc+=1;"
, "\tEND_INSTRUCTION_BLOCK;"
, "#endif"
, "}"
]
instr_RtoAC :: !Target -> Target
instr_RtoAC t = foldl (flip append) t
[ "{"
, "char r[22];"
, "int n=sprintf(r,\"%.15g\",*((BC_REAL*)bsp)+0.0);"
, "NEED_HEAP(2+((n+IF_INT_64_OR_32(7,3))>>IF_INT_64_OR_32(3,2)));"
, "hp[0]=(BC_WORD)&__STRING__+2;"
, "hp[1]=n;"
, "memcpy(&hp[2],r,n);"
, "pc+=1;"
, "bsp+=1;"
, "asp[1]=(BC_WORD)hp;"
, "asp+=1;"
, "hp+=2+((n+IF_INT_64_OR_32(7,3))>>IF_INT_64_OR_32(3,2));"
, "}"
]
lit_word :: !Int -> Expr TWord
lit_word i = toString i
......
......@@ -3,7 +3,8 @@ implementation module interpretergen
import StdEnv
import StdMaybe
import ArgEnv
import target
import target, specialized
Start w
# args = getCommandLine
......@@ -3762,6 +3763,17 @@ all_instructions opts t = bootstrap $ collect_instructions opts $ map (\i -> i t
d .= (d + if_i64_or_i32_expr (lit_word 7) (lit_word 3)) &. if_i64_or_i32_expr (lit_word -8) (lit_word -4) :.
d += (B @ 0 <<. if_i64_or_i32_expr (lit_word 3) (lit_word 2)) :.
B @ 0 .= to_word_ptr d @ 0
, instr "closeF" Nothing instr_closeF
, instr "endF" Nothing instr_endF
, instr "errorF" Nothing instr_errorF
, instr "openF" Nothing instr_openF
, instr "readFC" Nothing instr_readFC
, instr "readLineF" Nothing instr_readLineF
, instr "stdioF" Nothing instr_stdioF
, instr "writeFC" Nothing instr_writeFC
, instr "writeFS" Nothing instr_writeFS
, alias "add_arg" $
alias "ccall" $
alias "centry" $
......@@ -3782,21 +3794,15 @@ all_instructions opts t = bootstrap $ collect_instructions opts $ map (\i -> i t
alias "pushLc" $
alias "set_finalizers" $
alias "closeF"
alias "endF"
alias "endSF" $
alias "errorF"
alias "flushF" $
alias "openF"
alias "openSF" $
alias "positionF" $
alias "positionSF" $
alias "readFC"
alias "readFI" $
alias "readFR" $
alias "readFS" $
alias "readFString" $
alias "readLineF"
alias "readLineSF" $
alias "readSFC" $
alias "readSFI" $
......@@ -3807,11 +3813,8 @@ all_instructions opts t = bootstrap $ collect_instructions opts $ map (\i -> i t
alias "seekSF" $
alias "shareF" $
alias "stderrF" $
alias "stdioF"
alias "writeFC"
alias "writeFI" $
alias "writeFR" $
alias "writeFS"
alias "writeFString" $
alias "A_data_IIIla" $
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment