From 87188cb219a81b0e8700d946d282f8f7bf7057df Mon Sep 17 00:00:00 2001 From: Bryce Carson Date: Sat, 2 Nov 2024 23:48:36 -0600 Subject: [PATCH] Significant step forward in writing the langauge API --- src/api/r.org | 2773 ++++++++++++++++++++----------------------------- 1 file changed, 1141 insertions(+), 1632 deletions(-) diff --git a/src/api/r.org b/src/api/r.org index 92cacdd99..7f77cd0ea 100644 --- a/src/api/r.org +++ b/src/api/r.org @@ -35,11 +35,6 @@ changed so that no references to "Scheme" occur in the code. #+end_src #+begin_src C :noweb no-export :noweb-ref PREDECLARATIONS - #define sixth CAR(nthcdr(6)) - #define seventh CAR(nthcdr(7)) - #define eighth CAR(nthcdr(8)) - #define ninth CAR(nthcdr(9)) - bool R_initialized_once = false; extern int R_running_as_main_program; /* location within The R sources: ../unix/system.c */ static bool initR(tic_mem *tic, const char *code); @@ -178,10 +173,13 @@ can define it right now. For now the =memory= parameter can be ignored. R_initialized_once = true; } SEXP RESULT; - if (R_initialized_once) RESULT = Rf_eval(CSTR2LANGSXP(code), R_GlobalEnv); + SEXP LANG = PROTECT(CSTR2LANGSXP(code)) + if (R_initialized_once) RESULT = PROTECT(Rf_eval(LANG, R_GlobalEnv)); #if defined ebug /* -DEBUG=ON */ Rprintf("%s", RESULT); #endif + UNPROTECT(1); + if (R_initialized_once) UNPROTECT(1); } #+end_src @@ -398,8 +396,7 @@ and not undefine it. } #+end_src -* DONE License :ARCHIVE: -CLOSED: [2024-10-17 Thu 19:27] +* License Copyright © 2024 Bryce Carson Except where otherwise noted, the following license is applicable to all code @@ -436,862 +433,979 @@ version 1.3. */ #+end_src -* Planned work :ARCHIVE: +* Planned work ** Debugging R programs in TIC-80 Integrate the R debugger, browser, etc. into TIC-80. ** A final example -Write a game on the TIC-80 virtual console using R! -* TODO Writing the R language integration for TIC-80 -** temp -#+begin_src C - #define CSTR2LANGSXP(x) Rf_coerceVector(Rf_mkString(x), LANGSXP) -#+end_src +Write a /largeR/ game on the TIC-80 virtual console using R! -** Defining R functions for the TIC-80 API +* TODO Writing the R API for TIC-80 The TIC-80 API functions need to be defined in the global environment after initializing R, and if they're writtin in C then they need to be registered with R, rather than R code evaluated by R. -#+begin_comment -Most of these functions can probably be translated from the Scheme language -integration into R, given both use symbolic expressions and CAR and CDR. -#+end_comment +** Macros and PREDECLARATIONS +Every function wrapping an internal TIC-80 C API must eventually call an +internal API function, as in the following example. These functions each +require, as their first argument, ~tic_mem *tic~. -** TODO trace -Print to the standard error stream (in a DEBUG build) in addition to the TIC-80 console. - -#+name: define trace -#+begin_src C :noweb no-export - SEXP r_trace(SEXP *args, tic_mem *rho) { - const char *text = "Hello, woRld!"; - u8 color; - ((tic_core *) rho)->api.trace(memory, text, color ? color : 15); - return R_NilValue - } -#+end_src +#+begin_example C + core->api.print(tic, text, x, y, color, fixed, scale, alt) +#+end_example -The quoted definition of ~tic_api_trace~ in the next chunk gives the arguments -that are required of the callback to the TIC-80 core (after work has been done -in R). This function is called eventually by the trace function available in the -~tic_core->api~ struct. +That is made easier by defining the following symbols and macros to reference +them. -#+name: trace -#+begin_src C - void tic_api_trace(tic_mem* memory, const char* text, u8 color) - { - tic_core* core = (tic_core*)memory; - core->data->trace(core->data->data, text ? text : "nil", color); - } +#+begin_src C :noweb-ref PREDECLARATIONS + tic_mem *mem; + static SEXP RTicRam; + #define RTICAPI ((tic_core *)RTicRam)->api + #define RTICRAM R_ExternalPtrAddr(RTicRam) #+end_src -#+begin_comment -It would benefit *me* if I worked my way through André Müller's [[https://hackingcpp.com/cpp/lang/memory_basics.html][Hacking C++]]. -It's an amazing resource. I really like the memory diagrams. -#+end_comment +The example then becomes as follows. -#+name: scheme_trace -#+begin_src C -s7_pointer scheme_trace(s7_scheme* sc, s7_pointer args) -{ - // trace(message color=15) - tic_core* core = getSchemeCore(sc); tic_mem* tic = (tic_mem*)core; - const char* msg = s7_string(s7_car(args)); - const int argn = s7_list_length(sc, args); - const s32 color = argn > 1 ? s7_integer(s7_cadr(args)) : 15; - core->api.trace(tic, msg, color); - return s7_nil(sc); -} -#+end_src - -Each API has its own argument types that are accepted by the API functions, with -Python API functions only using ~pkpy_vm *vm~, the Scheme API using ~int32_t -argc~ and ~Janet *argv~, and the Scheme API using ~s7_scheme *sc~ and -~s7_pointer args~; in each case, however, one of these arguments points to a -location in memory which contains a =tic_core= struct, and hence can be used to -access the following ~core->api~, which is the API struct. - -What makes it especially confusing /and interesting/ is the following example -from the =scheme.c= file providing the Scheme API integration. Every function -returns an =s7_pointer= which can be used as the ~args~ argument to any other -function. Always, the return value is either ~nil~ (in the LISP sense) or a -pointer of various types (boolean, real, integer), but the function definition -and declaration specify simply ~s7_pointer~. This is similar to ~SEXP~ in R, -where everything is a symbolic expression. - -#+name: scheme_fft -#+begin_src C - s7_pointer scheme_fft(s7_scheme* sc, s7_pointer args) - { - // fft(int start_freq, int end_freq=-1) -> float_value - tic_core* core = getSchemeCore(sc); - tic_mem* tic = (tic_mem*)core; +#+begin_example C + RTICAPI.print(RTICRAM, text, x, y, color, fixed, scale, alt); +#+end_example - const int argn = s7_list_length(sc, args); - const s32 start_freq = argn > 0 ? s7_integer(s7_car(args)) : -1; - const s32 end_freq = argn > 1 ? s7_integer(s7_cadr(args)) : -1; +To handle conversion between R SEXPTYPEs and standard C types the following +macros are declared. - return s7_make_real(sc, core->api.fft(tic, start_freq, end_freq)); - } +#+begin_src C :noweb-ref PREDECLARATIONS + #define drIntp(x) *((int *)x) + #define drDblp(x) *((int *)x) + #define drLglp(x) *((int *)x) + #define drChrpp(x) *((char **)x) + #define ARGS(x) Rf_elt(args, x) #+end_src -** Defining BTN, a boolean TIC-80 API function -I know that when TIC-80 calls my initialization code that the R interpreter will -be initialized either by ~Rf_initEmbeddedR~ (if I don't implement a custom -initialization routine), and once this is done registration of the TIC-80 API -functions with the R interpreter takes place. - -These functions, when called by the R function ~.Primitive~, will receive a -number of arguments. While R is running embedded it needs access to the TIC-80 -=tic_mem *= typed object so that it can call the internal C API of TIC-80. This -is stored as a global variable in the scope that the primitive (implemented in -C) R function ~`TIC-80`~ will have access to. - -#+name: define btn -#+begin_src C - /* s7_pointer scheme_btn(s7_scheme* sc, s7_pointer args) */ - /* { */ - /* // btn(id) -> pressed */ - /* tic_core* core = getSchemeCore(sc); tic_mem* tic = (tic_mem*)core; */ - /* const s32 id = s7_integer(s7_car(args)); */ - - /* return s7_make_boolean(sc, core->api.btn(tic, id)); */ - /* } */ - - /* (LISTSXP) args is done by functions and macros defined in Rinternals.h, I - ,* don't need to do it. SEXP is a variant-type, so treat it as such; "a SEXP is - ,* simply a pointer to a SEXPREC", the underlying variant type.*/ - SEXP r_btn(SEXP args) { - /* btn(id) - ,* ⮑ pressed */ - /* TODO: convert the ARGS into an integer, and provide it to - ,* core->api.btn(tic_mem *tic, s32 id), returning a boolean from this function - ,* (as SEXP automatically promoted). */ - SEXP id = PROTECT(allocVector(INTSXP, 1)); - INT(id)[0] = first; - SEXP /*LGLSXP*/ btn = core->api.btn(tic_mem *tic, (s32) id); - UNPROTECT(1); - return btn; - } -#+end_src - -I think that's sufficient? - -** Defining print... a complex function -The TIC-80 print function has much more going on for it than btn or trace. It -will operate with the graphical system of TIC-80 and cause something to appear -on the screen. - -#+begin_comment -This code cannot handle named arguments! I need to determine how to do that! -#+end_comment +Functions in the R TIC-80 API which require more attention in C programming may +make use of the following macros. These macros are /only useful for C +constants/, as everything within =args= is already protected from garbage +collection because =...= is in use already in the =.External= interface. +However, any /wholly new SEXPs/ created from values extracted from =args= will +need to be protected. References to existing SEXPs will not require further +protection. #+begin_src C :noweb-ref PREDECLARATIONS - #define RSTRT(x) SEXP x(SEXP args) { int protected_count = 0; const int argn = length(args); + #define CSTR2LANGSXP(x) Rf_coerceVector(Rf_mkString(x), LANGSXP) + #define RSTRT(x) SEXP x(SEXP args) { int protected_count = 0; const int argn = Rf_length(args); #define RUNP UNPROTECT(protected_count); #define REND } - #define ProtectAndIncrement(x) (++protected_count, PROTECT(x)) - #define psint(x) ProtectAndIncrement(ScalarInteger(x)) - #define pslgl(x) ProtectAndIncrement(ScalarLogical(x)) - #define psstr(x) ProtectAndIncrement(ScalarString(x)) - #define CADNR(x) CAR(nthcdr(x)) -#+end_src - -While I thought that would've been much more complex I think I did it! - -** The Scheme Core -The function =getSchemeCore= returns a pointer to a =tic_core= object, using an -s7 Scheme pointer to locate a value from a name ~_TIC80~ which the interpreter -is managing. The function converts the name to a Scheme value and returns the -pointer to that object, converted from a Scheme pointer to a void pointer -(assumedly), and automatically type promoted to the return value of ~tic_core -*~. - -#+begin_src C - static const char* TicCore = "_TIC80"; - - tic_core* getSchemeCore(s7_scheme* sc) - { - return s7_c_pointer(s7_name_to_value(sc, TicCore)); - } -#+end_src - -The address of the Scheme value with the name ~_TIC80~ is the address of the -TIC-80 core. The memory of the fantasy computer is located at this address as -well, and ~tic_core->currentVM~ points back to this start of memory as well (I -think). This creates a sort of ring of memory. - -** The TIC Core and TIC memory -#+begin_src C :noweb-ref struct tic_mem - struct tic_mem - { - tic80 product; - tic_ram* ram; - tic_cartridge cart; - - tic_ram* base_ram; - - char saveid[TIC_SAVEID_SIZE]; - - <> - }; -#+end_src - -The field ~product~ has type =tic80=, whose defintion is quoted here. - -#+begin_src C - typedef struct - { - struct - { - void (*trace)(const char* text, u8 color); - void (*error)(const char* info); - void (*exit)(); - } callback; - - struct - { - TIC80_SAMPLETYPE* buffer; - s32 count; - } samples; - - u32 *screen; - } tic80; + #define psint(x) ProtectAndIncrement(Rf_ScalarInteger(x)) + #define pslgl(x) ProtectAndIncrement(Rf_ScalarLogical(x)) + #define psstr(x) ProtectAndIncrement(Rf_ScalarString(x)) #+end_src -The union struct called "input", which was unimportant to earlier discussion, is -defined here so the quoted definition (though unused apart from as a quotation -for discussion) is not incomplete. +** Procedures to initialize, close, and re-initialize R +Both =initScheme= and =closeScheme= begin with casting ~tic_mem *tic~ to a +~tic_core *~, effectively mapping from one area of memory to another (like a +hashmap or simply shifting the memory until the child struct is aligned with the +parent struct). +# Adjust the prior sentence because it's inaccurate. +This map permits access within =closeScheme= to the =currentVM= member of the +TIC-80 core memory. This is only my basic understanding, and some of it is +adventurous bullshitting; I really don't know if that was true, what I said, and +I don't much care if it wasn't because I'm writing this as I still work to +understand what I'm reading, so this is only a draft paragraph. -#+name: union struct tic_mem.input -#+begin_src C - union - { - struct - { - #if RETRO_IS_BIG_ENDIAN - u8 padded:5; - u8 keyboard:1; - u8 mouse:1; - u8 gamepad:1; - #else - u8 gamepad:1; - u8 mouse:1; - u8 keyboard:1; - u8 padded:5; - #endif - }; +In the Lua integration the manner to initialize Lua is the use of a pointer to a +=lua_State= type (which is actually a thread, but indirectly refers to the state +associated with the thread). Every Lua C API function requires a pointer of this +type as its first argument, so calling the procedure ~lua_newstate~ creates a +fresh, independent thread of execution. That's all that is required to embed and +then instantiate a Lua 5.4 interpreter within a larger application. - u8 data; - } input; -#+end_src +The general design of TIC-80 relies on an embedded language API using pointers +to the interpreter as the first argument of many of its functions. This is an +active design choice and is likely related to memory management in TIC-80, which +is necessarily complicated by the fact that langauge interpreters are of +different sizes, as are their language codes which say ~Hello, world!~. It's a +complicated topic. I won't think on it. -** TODO The TIC API functions -Every function wrapping an internal TIC-80 C API must eventually call an api -function, like so. These functions each require, as their first argument, -~tic_mem *tic~. +R is not designed to be embedded in the same sense as other languages, it is not +an extension language for other programs, it is /the main program/ and even has +built-in variables implying it is assumed to be true that +=R_running_as_main_program=, even when embedded, and a potential ~longjmp~ +complicates matters more. Still, we will push on towards our goal despite my +ignorance and inexperience. -#+begin_example C - core->api.print(tic, text, x, y, color, fixed, scale, alt) -#+end_example +R expects the arguments from the operating system shell to be passed along to +it---"Yes, even when embedded."---and thus we need fake arguments. For now, +we'll borrow the code from the /Writing R Extensions/ manual to pass +~Rf_initEmbeddedR~ some fake arguments, and we'll write a procedure to handle +restarting R as necessary and tracking the current interpreter (there can be +only one). +#+name: kill R #+begin_src C - tic_mem *mem; - static SEXP RTicRam = R_MakeExternalPtr((void *) tic); #+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - RSTRT(r_print) - /* print(text x=0 y=0 color=15 fixed=false scale=1 smallfont=false) - ,* ⮑ width*/ - const char* text = psstr(first); - const s32 x = argn > 1 ? psint(second) : 0; - const s32 y = argn > 2 ? psint(third) : 0; - const u8 color = argn > 3 ? psint(fourth) : 15; - const bool fixed = argn > 4 ? pslgl(fifth) : false; - const s32 scale = argn > 5 ? psint(sixth) : 1; - const bool alt = argn > 6 ? pslgl(seventh) : false; +That is defined separately, and not as a macro, so that the code can be re-used. - RUNP; +#+begin_src C :noweb no-export :noweb-ref cartridge commands + void R_CleanUp(Rboolean saveact, int status, int RunLast) { ; } - return ScalarLogical(core->api.print(R_ExternalPtrAddr(RTicRam), text, x, y, color, fixed, scale, alt)); - REND -#+end_src + void R_Suicide(const char *message) + { + char pp[1024]; + snprintf(pp, 1024, "Fatal error, but can't kermit: %s\n"\ + "Execute me, please.\n", message); + R_ShowMessage(pp); + exit(1); -With the preprocessor macros and the R API function ~R_ExternalPtrAddr~ I have -sufficiently simplified the defintion of an =.External= R function to the point -I'm happy to write these and edit the ones which I already have copied from -the s7 Scheme API. + while(1); + } -#+begin_src C :noweb-ref define C symbols to be callable from R - RSTRT(r_cls) - /* cls(color=0) - ,* ⮑ nil */ + static tic_mem *tic_memory_static; - const u8 color = (argn > 0) ? psInt(first) : 0; + void R_ShowMessage(const char *s) { + /* Always use the sixteenth color. */ + ((tic_core *) tic_memory_static)->api.trace(tic_memory_static, s, 15); + } - core->api.cls(R_ExternalPtrAddr(RTicMem), color); + /* This function is called with code, which is the entirety of the studio + ,,* editor's code buffer (i.e. the entire game code as one string). */ + static bool initR(tic_mem *tic, const char *code) { + RTicRam = R_MakeExternalPtr((void *) tic, NULL, NULL) - RUNP; + closeR(tic); - return R_NilValue - REND -#+end_src + /* embdRAV: embedded R argument vector. */ + static char *embdRAV[] = { "TIC-80", "--quiet", "--vanilla" }; -It isn't so bad to write these now. I can focus on /handling the arguments/, -regardless of their number, rather than acquiring the number of arguments and -protecting them. + /* Without this nothing in R will work. */ + setEnvironmentVariablesIfUnset(); + static bool R_Initialized = false; -#+begin_src C :noweb-ref define C symbols to be callable from R - RSTRT(r_pix) - /* pix(x y color = 0) - ,* ⮑ nil - ,* pix(x y) - ,* ⮑ color */ - const s32 x = psint(first); - const s32 y = psint(second); + R_running_as_main_program = 0; - if (argn == 3) { - const u8 color = psint(third); - core->api.pix(tic, x, y, color, false); - RUNP; - return R_NilValue; - } else { - RUNP; - return ScalarInteger(core->api.pix(R_ExternalPtrAddr(RTicMem), x, y, 0, true)); + if (!R_Initialized) { + R_Initialized = (bool) Rf_initEmbeddedR(sizeof(embdRAV)/sizeof(embdRAV[0]), \ + embdRAV); + R_running_as_main_program = 0; + /* Declared in Rinterface.h, defined in Rf_initEmbeddedR. */ + R_Interactive = false; } - REND -#+end_src - -PIX is a setter and getter function; if provided with a color it will set the -pixel at that position to that color (returning ~nil~, ~NULL~ in R), otherwise -it will return the color of the pixel at that position. - -#+begin_src C :noweb-ref define C symbols to be callable from R - RSTRT(r_line) - /* line(x0 y0 x1 y1 color) - ,* ⮑ nil */ - const s32 x0 = psint(first); - const s32 y0 = psint(second); - const s32 x1 = psint(third); - const s32 y1 = psint(fourth); - const u8 color = psint(fifth); - - core->api.line(R_ExternalPtrAddr(RTicMem), x0, y0, x1, y1, color); - RUNP; - return R_NilValue; - REND -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_rect(SEXP args) - { - // rect(x y w h color) - int protected_count = 0; - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x = ProtInc(ScalarInteger(CADR(args))); - const s32 y = ProtInc(ScalarInteger(CADDR(args))); - const s32 w = ProtInc(ScalarInteger(CADDDR(args))); - const s32 h = ProtInc(ScalarInteger(CADDDDR(args))); - const u8 color = ScalarInteger(s7_list_ref(sc, args, 4)); - core->api.rect(tic, x, y, w, h, color); - UNPROTECT(protected_count); - return R_NilValue; - } -#+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_rectb(SEXP args) - { - // rectb(x y w h color) - int protected_count = 0; - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x = ProtInc(ScalarInteger(first)); - const s32 y = ProtInc(ScalarInteger(second)); - const s32 w = ProtInc(ScalarInteger(third)); - const s32 h = ProtInc(ScalarInteger(fourth)); - const u8 color = ProtInc(ScalarInteger(fifth)); - core->api.rectb(tic, x, y, w, h, color); - UNPROTECT(protected_count); - return R_NilValue; - } -#+end_src + <> -=parseTransparentColorsArg= is a helper function which is used elsewhere in the API. + Rf_eval(CSTR2LANGSXP("if (exists(\"BOOT\") && is.function(BOOT)) { BOOT() } " \ + "else { BOOT <- function() `{`; ## Tricky NOP. }"), + R_GlobalEnv); -#+begin_src C :noweb-ref define C symbols to be callable from R - void parseTransparentColorsArg(SEXP colorkey, u8* out_transparent_colors, u8* out_count) - { - ,*out_count = 0; - if (s7_is_list(sc, colorkey)) - { - const s32 arg_color_count = length(colorkey); - const u8 color_count = arg_color_count < TIC_PALETTE_SIZE ? (u8)arg_color_count : TIC_PALETTE_SIZE; - for (u8 i=0; i 3) - { - SEXP colorkey = ProtInc(fourth); - parseTransparentColorsArg(sc, colorkey, trans_colors, &trans_count); + static void closeR(tic_mem *tic) { + tic_core *core; + if ((core = (((tic_core *) tic))->currentVM) != NULL) { + Rf_endEmbeddedR(0); + core->currentVM = NULL; } - - const s32 scale = argn > 4 ? ProtInc(ScalarInteger(fourth ) ) : 1; - const s32 flip = argn > 5 ? ProtInc(ScalarInteger(fifth ) ) : 0; - const s32 rotate = argn > 6 ? ProtInc(ScalarInteger(CAR(nthcdr(6 ) ) ) ) : 0; - const s32 w = argn > 7 ? ProtInc(ScalarInteger(CAR(nthcdr(7 ) ) ) ) : 1; - const s32 h = argn > 8 ? ProtInc(ScalarInteger(CAR(nthcdr(8 ) ) ) ) : 1; - core->api.spr(tic, id, x, y, w, h, trans_colors, trans_count, scale, (tic_flip)flip, (tic_rotate) rotate); - UNPROTECT(protected_count); - return R_NilValue } #+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_btn(SEXP args) - { - // btn(id) -> pressed - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 id = ScalarInteger(CADR(args)); +** Callbacks +It might not be advisable to define the ~TIC~ function in the R API as +~`TIC-80`~, but because R allows non-syntactic names I'll use it so that the +actual name of the machine can be used. If the machine were called ~MANE~ we'd +want to use that, but if we were forced to use ~main~ that'd be a nice homophone +at least. The =exists= function doesn't use symbols, it uses strings to lookup +symbols so that is why that part differs in the chunk below. - return s7_make_boolean(sc, core->api.btn(tic, id)); +#+begin_src C :noweb-ref cartridge commands + static void callRFn_TIC80(tic_mem* tic) { + #if !defined R_INTERNALS_H_ + #error "R_GlobalEnv not defined because Rinternals.h not properly included... somehow." + #endif + /* if (exists("TIC-80") && is.function(`TIC-80`)) `TIC-80`() */ + Rf_eval(Rf_mkString("if (exists(\"TIC-80\") && is.function(`TIC-80`)) "\ + "`TIC-80`()"), + R_GlobalEnv); } #+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_btnp(SEXP args) - { - // btnp(id hold=-1 period=-1) -> pressed - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 id = ScalarInteger(CADR(args)); - - const int argn = length(args); - const s32 hold = argn > 1 ? ScalarInteger(CADDR(args)) : -1; - const s32 period = argn > 2 ? ScalarInteger(CADDDR(args)) : -1; - - return s7_make_boolean(sc, core->api.btnp(tic, id, hold, period)); - } -#+end_src +Previously, the following macro only generated R code defining syntactic +identifiers; after reviewing the help page for quoting in R, it makes more sense +for it to always quote the name to be called as a function if that name exists +and is a function (the latter test also using back-quoting, but no matter). This +allows the calling of both syntactic and non-syntactic names in R, allowing the +macro to generate the C code which will call any defined R function in the +global environment. An obvious extension would be the definition of another +macro expanding to a call of this one with supplied, alternative environment. An +inobvious (to me, at first) issue is that anything which is a non-syntactic name +in R is absolutely a non-syntactic name in C and cannot be used! The ability to +define a C function to call an R function with any name does not help me in the +way I originally intended, unless I rewrite the macro to use another argument +(if supplied) as the R function name that will be called in R, while the +argument =f= is the C function identifier. That's too much work for now and zero +benefit, so I continue using the previous code block to define the C function to +call a non-syntactic name in R as a function. -#+begin_src C :noweb-ref define C symbols to be callable from R - u8 get_note_base(char c) { - switch (c) { - case 'C': return 0; - case 'D': return 2; - case 'E': return 4; - case 'F': return 5; - case 'G': return 7; - case 'A': return 9; - case 'B': return 11; - default: return 255; - } - } -#+end_src +#+name: comment on the following block of preprocessor definitions +#+begin_comment +The callback functions below are okay. If you're reading this, coming from the +current mess in the [[Debugging segfaults]] section then references to R_GlobalEnv +in this code block aren't related to the references to that environment in the +backtrace quoted in the mentioned section. +#+end_comment -#+begin_src C :noweb-ref define C symbols to be callable from R - u8 get_note_modif(char c) { - switch (c) { - case '-': return 0; - case '#': return 1; - default: return 255; +#+name: proprocessor definitions to define cartridge callback functions +#+begin_src C :noweb-ref cartridge commands + #define defineCallRFnInEnvironment_(f, e, ...) \ + static void callRFn_##f(tic_mem *tic, ##__VA_ARGS__) { \ + Rf_eval(Rf_mkString("if (exists(\""#f"\") && is.function(`"#f"`)) " \ + "`"#f"`() else stop(\""#f" is not a defined function!\")"),\ + e); \ } - } + /* i.e., if (exists("f") && is.function(`f`)) `f`(), allowing call of syntactic + ,* and non-syntactic names. */ + #define defineCallRFn_(f, ...) defineCallRFnInEnvironment_(f, R_GlobalEnv, ...) + defineCallRFn_(BOOT) + /* s32 row/index, void *data as well as the tic_mem *tic parameters. */ + defineCallRFn_(MENU, s32 index, void *data) + defineCallRFn_(BDR, s32 row, void *data) + defineCallRFn_(SCN, s32 row, void *data) + #undef defineCallRFn_ + #undef defineCallRFnInEnvironment_ #+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - u8 get_note_octave(char c) { - if (c >= '0' && c <= '8') - return c - '0'; - else - return 255; - } -#+end_src +**** Exporting a =tic_script= for *TIC-80* to use at compile-time +This constant is used by TIC-80 to setup the cartridge, both for editing in the +"studio" and the runtime evaluat (use-package emacsql-sqlite :after 'emacsql) +ion of the script. -#+begin_src C :noweb-ref define C symbols to be callable from R - typedef struct +#+name: TIC EXPORT +#+begin_src c + /* DEFAULT visibility*/ + /* EXPORT_SCRIPT -> RScriptConfig if static, else ScriptConfig */ + TIC_EXPORT const tic_script EXPORT_SCRIPT(R) = { - s7_scheme* sc; - SEXP callback; - } RemapData; -#+end_src + /* The first five members of the struct have the sum total following + ,* size. */ + /* sizeof(u8) + 3 * sizeof(char *) */ + /* R's id is determined by counting up from 10, beginning with Lua, all of + the other languages TIC-80 supports. Python was the 10th langauge supported, + with .id 20. */ + .id = 21, + .name = "r", + .fileExtension = ".r", + .projectComment = "##", + { + .init = initR, -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_sfx(SEXP a, SEXP args) - { - // sfx(id note=-1 duration=-1 channel=0 volume=15 speed=0) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 id = ScalarInteger(CADR(args)); + .close = closeR, + .tick = callRFn_TIC80, + .boot = callRFn_BOOT, - const int argn = length(args); - int note = -1; - int octave = -1; - if (argn > 1) { - SEXP note_ptr = CADDR(args); - if (s7_is_integer(note_ptr)) { - const s32 raw_note = ScalarInteger(note_ptr); - if (raw_note >= 0 || raw_note <= 95) { - note = raw_note % 12; - octave = raw_note / 12; - } - /* else { */ - /* char buffer[100]; */ - /* snprintf(buffer, 99, "Invalid sfx note given: %d\n", raw_note); */ - /* tic->data->error(tic->data->data, buffer); */ - /* } */ - } else if (s7_is_string(note_ptr)) { - const char* note_str = ScalarString(note_ptr); - const u8 len = ScalarString_length(note_ptr); - if (len == 3) { - const u8 modif = get_note_modif(note_str[1]); - note = get_note_base(note_str[0]); - octave = get_note_octave(note_str[2]); - if (note < 255 || modif < 255 || octave < 255) { - note = note + modif; - } else { - note = octave = 255; - } - } - /* if (note == 255 || octave == 255) { */ - /* char buffer[100]; */ - /* snprintf(buffer, 99, "Invalid sfx note given: %s\n", note_str); */ - /* tic->data->error(tic->data->data, buffer); */ - /* } */ - } - } + .callback = + { + .scanline = callRFn_SCN, + .border = callRFn_BDR, + .menu = callRFn_MENU, + }, + }, - const s32 duration = argn > 2 ? ScalarInteger(CADDDR(args)) : -1; - const s32 channel = argn > 3 ? ScalarInteger(CADDDDR(args)) : 0; + .getOutline = getROutline, + .eval = evalR, - s32 volumes[TIC80_SAMPLE_CHANNELS] = {MAX_VOLUME, MAX_VOLUME}; - if (argn > 4) { - SEXP volume_arg = s7_list_ref(sc, args, 4); - if (s7_is_integer(volume_arg)) { - volumes[0] = volumes[1] = ScalarInteger(volume_arg) & 0xF; - } else if (s7_is_list(sc, volume_arg) && length(volume_arg) == 2) { - volumes[0] = ScalarInteger(CADR(volume_arg)) & 0xF; - volumes[1] = ScalarInteger(CADDR(volume_arg)) & 0xF; - } - } - const s32 speed = argn > 5 ? ScalarInteger(s7_list_ref(sc, args, 5)) : 0; + .blockCommentStart = NULL, + .blockCommentEnd = NULL, + .blockCommentStart2 = NULL, + .blockCommentEnd2 = NULL, + .singleComment = "##", + .blockStringStart = "\"", + .blockStringEnd = "\"", + .stdStringStartEnd = "\"", + .blockEnd = NULL, + .lang_isalnum = r_isalnum, + .api_keywords = RAPIKeywords, + .api_keywordsCount = COUNT_OF(RAPIKeywords), + .useStructuredEdition = false, - core->api.sfx(tic, id, note, octave, duration, channel, volumes[0], volumes[1], speed); - return R_NilValue - } + .keywords = RKeywords, + .keywordsCount = COUNT_OF(RKeywords), + + .demo = {DemoRom, sizeof DemoRom}, + .mark = {MarkRom, sizeof MarkRom, "rmark.tic"}, + }; #+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - static void remapCallback(void* data, s32 x, s32 y, RemapResult* result) - { - RemapData* remap = (RemapData*)data; - s7_scheme* sc = remap->sc; +On line three of the current source file---/exempli gratia/---if =MACROVAR(it)= +was invoked its argument would expand to =it3=. When used in the first define +below, =it3= will be a pointer to an array of tic_scripts, which is iterated +over (explaning the =it= argument). ~*script~ is modified, but the type +specifier is ~const~, so what's going on with the syntax that I don't remember? +Does it only apply to the first declared variable in the identifier list? - // (callback index x y) -> (list index flip rotate) - SEXP callbackResult = s7_call(sc, remap->callback, - s7_cons(sc, s7_make_integer(sc, result->index), - s7_cons(sc, s7_make_integer(sc, x), - s7_cons(sc, s7_make_integer(sc, y), - R_NilValue)))); +~Scripts~ is an array of =tic_script *=-typed objects, that is it is an array of +pointers to =tic_script= objects. - if (s7_is_list(sc, callbackResult) && length(callbackResult) == 3) - { - result->index = ScalarInteger(CADR(callbackResult)); - result->flip = (tic_flip)ScalarInteger(CADDR(callbackResult)); - result->rotate = (tic_rotate)ScalarInteger(CADDDR(callbackResult)); - } +#+name: FOREACH_LANG +#+begin_src C + #define FOREACH_LANG(script) \ + for(const tic_script **MACROVAR(it) = tic_scripts(), *script = *MACROVAR(it); \ + ,*MACROVAR(it); \ + script = *++MACROVAR(it)) + + #define CONCAT2(a, b) a ## b + #define CONCAT(a, b) CONCAT2(a, b) + #define MACROVAR(name) CONCAT(name, __LINE__) + + + const tic_script** tic_scripts() + { + return Scripts; } -#+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_map(SEXP args) + static const tic_script *Scripts[MAX_SUPPORTED_LANGS + 1] = { - // map(x=0 y=0 w=30 h=17 sx=0 sy=0 colorkey=-1 scale=1 remap=nil) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x = ScalarInteger(CADR(args)); - const s32 y = ScalarInteger(CADDR(args)); - const s32 w = ScalarInteger(CADDDR(args)); - const s32 h = ScalarInteger(CADDDDR(args)); - const s32 sx = ScalarInteger(s7_list_ref(sc, args, 4)); - const s32 sy = ScalarInteger(s7_list_ref(sc, args, 5)); + #if defined(TIC_RUNTIME_STATIC) + #if defined (TIC_BUILD_WITH_LUA) + &EXPORT_SCRIPT(Lua), + #endif - const int argn = length(args); + #if defined(TIC_BUILD_WITH_RUBY) + &EXPORT_SCRIPT(Ruby), + #endif - static u8 trans_colors[TIC_PALETTE_SIZE]; - u8 trans_count = 0; - if (argn > 6) { - SEXP colorkey = s7_list_ref(sc, args, 6); - parseTransparentColorsArg(sc, colorkey, trans_colors, &trans_count); + #if defined(TIC_BUILD_WITH_JS) + &EXPORT_SCRIPT(Js), + #endif + + #if defined(TIC_BUILD_WITH_MOON) + &EXPORT_SCRIPT(Moon), + #endif + + #if defined(TIC_BUILD_WITH_FENNEL) + &EXPORT_SCRIPT(Fennel), + #endif + + #if defined(TIC_BUILD_WITH_SCHEME) + &EXPORT_SCRIPT(Scheme), + #endif + + #if defined(TIC_BUILD_WITH_SQUIRREL) + &EXPORT_SCRIPT(Squirrel), + #endif + + #if defined(TIC_BUILD_WITH_WREN) + &EXPORT_SCRIPT(Wren), + #endif + + #if defined(TIC_BUILD_WITH_WASM) + &EXPORT_SCRIPT(Wasm), + #endif + + #if defined(TIC_BUILD_WITH_JANET) + &EXPORT_SCRIPT(Janet), + #endif + + #if defined(TIC_BUILD_WITH_PYTHON) + &EXPORT_SCRIPT(Python), + #endif + + #endif + + NULL, + }; +#+end_src + +**** Providing lists of syntax elements for highlighting and outline generation +#+name: SYNTAX HIGHLIGHTING AND OUTLINE GENERATION +#+begin_src C :noweb no-export + <> + + <> + + <> +#+end_src + +***** Syntax highlighting the reserved words in R +Syntax highlighting is not always easy, especially when regular expressions are +involved. What we are using in TIC-80 is a more naive approach, but one which is +easier to maintain because it is less powerful and less flexible. It is at the +opposite side of the spectrum from a full parser or a language server. + +The simple system in TIC-80 merely highlights all keywords of a language in one +colour, and all other syntax elements in another colour (presumably, the default +foreground colour). + +R has only a few reserved words, and very little of it is "critical syntax" +characters. The seemingly fundamental syntax characters ~{~ and ~(~ are actually +function calls, which could be shadowed if desired. + +Reserved words cannot be used as syntactic names, but as non-syntactic names +they can be used, so ~`if`~ is a different symbol or name than ~if~ and may be +used otherwise, as with ~`function`~. + +#+name: Specify the reserved words for automatic syntax +#+begin_src c + static const char* const RKeywords [] = + { + "if", "else", "repeat", "while", "function", "for", "in", "next", "break", + "TRUE", "FALSE", "NULL", "Inf", "NaN", "NA", "NA_integer_", "NA_real_", + "NA_complex_", "NA_character_", + /* et cetera, see ?dots */ + "...", "..1", "..2", "..3", "..4", "..5", "..6", "..7", "..8", "..9", + }; +#+end_src + +****** =..n=: variadic argument access across the natural numbers +The entirety of the natural numbers are reserved words when the occur after the +characters ~..~, becuase any ordinal number is usable to access a member of the +dotted argument (how R cleverly deals with variadic arguments). The functions +which otherwise handle these variadic argument list members are not reserved +words, for example ~..length()~ or even ~..n()~ are not reserved. + +***** Outline generation +Generating and outline will provide the editor with the ability to jump to +different areas of the script being written. + +#+name: OUTLINE GENERATION +#+begin_src C + /* A naive edit of the Python function to check if a character is a valid + ,* character within an identifier. */ + static bool r_isalnum(char c) { + return ( + (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + || (c == '_') || (c == '.') + ); + } + + static const tic_outline_item* getROutline(const char* code, s32* size) + { + enum{Size = sizeof(tic_outline_item)}; + ,*size = 0; + + static tic_outline_item* items = NULL; + + if(items) + { + free(items); + items = NULL; } - const s32 scale = argn > 7 ? ScalarInteger(s7_list_ref(sc, args, 7)) : 1; + const char* ptr = code; - RemapFunc remap = NULL; - RemapData data; - if (argn > 8) + while(true) { - remap = remapCallback; - data.sc = sc; - data.callback = s7_list_ref(sc, args, 8); + static const char FuncString[] = "<- function("; + + ptr = strstr(ptr, FuncString); + + if(ptr) + { + ptr += sizeof FuncString - 1; + + const char* start = ptr; + const char* end = start; + + while(*ptr) + { + char c = *ptr; + + if(r_isalnum(c)); + else + { + end = ptr; + break; + } + ptr++; + } + + if(end > start) + { + items = realloc(items, (*size + 1) * Size); + + items[*size].pos = start; + items[*size].size = (s32)(end - start); + + (*size)++; + } + } + else break; } - core->api.map(tic, x, y, w, h, sx, sy, trans_colors, trans_count, scale, remap, &data); - return R_NilValue + + return items; + } +#+end_src + +***** R API implementation keywords +The API keywords are either callbacks to the TIC-80 virtual machine---which can +be thought of as an operating system interface---or the user-facing API +functions. The following definitions are simply taken from the file =scheme.c=, +which implements the s7 Scheme integration, and the obvious changes made (Scheme +changed to R). + +While [[https://github.com/nesbox/TIC-80/discussions/2100][in this GitHub discussion]] nesbox claims that one can simply place your +source files, with their respective langauge file suffixes, in "demos/" and the +build process will take care of generating a .tic.dat file, that doesn't appear +to be true [[https://github.com/nesbox/TIC-80/commit/87e91e7dd903dac7a9c232d1127a32b0d4a8dc54][given this commit]] and the inability for me to build solely due to +these files not being created automatically by a CMake build target. That's an +issue that will need to be opened. + +After taking the time to understand the macros used in the definition of +RAPIKeywords, borrowed from SchemeAPIKeywords, I would /not/ bother to do it any +other way, as in the way Python or Janet did it. It is really, really neat. I +like this. + +#+name: R API implementation keywords +#+begin_src C + static const char* RAPIKeywords[] = { + #define TIC_CALLBACK_DEF(name, ...) #name, + TIC_CALLBACK_LIST(TIC_CALLBACK_DEF) + #undef TIC_CALLBACK_DEF + + #define API_KEYWORD_DEF(name, ...) #name, + TIC_API_LIST(API_KEYWORD_DEF) + #undef API_KEYWORD_DEF + }; + + static const u8 DemoRom[] = + { + /* Automatically built from ../../demos/rdemo.r */ + #include "../build/assets/rdemo.tic.dat" + }; + + static const u8 MarkRom[] = + { + /* Automatically built from ../../demos/bunny/rbenchmark.r */ + #include "../build/assets/rmark.tic.dat" + }; +#+end_src + +** Functions +*** Drawing +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_circ(SEXP args) { + // circ(x y radius color) + const s32 x = drInt(ARGS(1)); + const s32 y = drInt(ARGS(2)); + const s32 radius = drInt(ARGS(3)); + const s32 color = drInt(ARGS(4)); + + RTICAPI.circ(RTICRAM, x, y, radius, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_mget(SEXP args) + SEXP r_circb(SEXP args) { - // mget(x y) -> tile_id + // circb(x y radius color) tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; const s32 x = ScalarInteger(CADR(args)); const s32 y = ScalarInteger(CADDR(args)); - return s7_make_integer(sc, core->api.mget(tic, x, y)); + const s32 radius = ScalarInteger(CADDDR(args)); + const s32 color = ScalarInteger(CADDDDR(args)); + core->api.circb(tic, x, y, radius, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_mset(SEXP args) + SEXP r_elli(SEXP args) { - // mset(x y tile_id) + // elli(x y a b color) tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; const s32 x = ScalarInteger(CADR(args)); const s32 y = ScalarInteger(CADDR(args)); - const u8 tile_id = ScalarInteger(CADDDR(args)); - core->api.mset(tic, x, y, tile_id); - return R_NilValue + const s32 a = ScalarInteger(CADDDR(args)); + const s32 b = ScalarInteger(CADDDDR(args)); + const s32 color = ScalarInteger(s7_list_ref(sc, args, 4)); + core->api.elli(tic, x, y, a, b, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_peek(SEXP args) + SEXP r_ellib(SEXP args) { - // peek(addr bits=8) -> value + // ellib(x y a b color) tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 addr = ScalarInteger(CADR(args)); - const int argn = length(args); - const s32 bits = argn > 1 ? ScalarInteger(CADDR(args)) : 8; - return s7_make_integer(sc, core->api.peek(tic, addr, bits)); + const s32 x = ScalarInteger(CADR(args)); + const s32 y = ScalarInteger(CADDR(args)); + const s32 a = ScalarInteger(CADDDR(args)); + const s32 b = ScalarInteger(CADDDDR(args)); + const s32 color = ScalarInteger(s7_list_ref(sc, args, 4)); + core->api.ellib(tic, x, y, a, b, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_poke(SEXP args) + SEXP r_tri(SEXP args) { - // poke(addr value bits=8) + // tri(x1 y1 x2 y2 x3 y3 color) tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 addr = ScalarInteger(CADR(args)); - const s32 value = ScalarInteger(CADDR(args)); - const int argn = length(args); - const s32 bits = argn > 2 ? ScalarInteger(CADDDR(args)) : 8; - core->api.poke(tic, addr, value, bits); - return R_NilValue + const s32 x1 = ScalarInteger(CADR(args)); + const s32 y1 = ScalarInteger(CADDR(args)); + const s32 x2 = ScalarInteger(CADDDR(args)); + const s32 y2 = ScalarInteger(CADDDDR(args)); + const s32 x3 = ScalarInteger(s7_list_ref(sc, args, 4)); + const s32 y3 = ScalarInteger(s7_list_ref(sc, args, 5)); + const s32 color = ScalarInteger(s7_list_ref(sc, args, 6)); + core->api.tri(tic, x1, y1, x2, y2, x3, y3, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_peek1(SEXP args) + SEXP r_trib(SEXP args) { - // peek1(addr) -> value + // trib(x1 y1 x2 y2 x3 y3 color) tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 addr = ScalarInteger(CADR(args)); - return s7_make_integer(sc, core->api.peek1(tic, addr)); + const s32 x1 = ScalarInteger(CADR(args)); + const s32 y1 = ScalarInteger(CADDR(args)); + const s32 x2 = ScalarInteger(CADDDR(args)); + const s32 y2 = ScalarInteger(CADDDDR(args)); + const s32 x3 = ScalarInteger(s7_list_ref(sc, args, 4)); + const s32 y3 = ScalarInteger(s7_list_ref(sc, args, 5)); + const s32 color = ScalarInteger(s7_list_ref(sc, args, 6)); + core->api.trib(tic, x1, y1, x2, y2, x3, y3, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_poke1(SEXP args) + SEXP r_ttri(SEXP args) { - // poke1(addr value) + // ttri(x1 y1 x2 y2 x3 y3 u1 v1 u2 v2 u3 v3 texsrc=0 chromakey=-1 z1=0 z2=0 z3=0) tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 addr = ScalarInteger(CADR(args)); - const s32 value = ScalarInteger(CADDR(args)); - core->api.poke1(tic, addr, value); - return R_NilValue + const s32 x1 = ScalarInteger(CADR(args)); + const s32 y1 = ScalarInteger(CADDR(args)); + const s32 x2 = ScalarInteger(CADDDR(args)); + const s32 y2 = ScalarInteger(CADDDDR(args)); + const s32 x3 = ScalarInteger(s7_list_ref(sc, args, 4)); + const s32 y3 = ScalarInteger(s7_list_ref(sc, args, 5)); + const s32 u1 = ScalarInteger(s7_list_ref(sc, args, 6)); + const s32 v1 = ScalarInteger(s7_list_ref(sc, args, 7)); + const s32 u2 = ScalarInteger(s7_list_ref(sc, args, 8)); + const s32 v2 = ScalarInteger(s7_list_ref(sc, args, 9)); + const s32 u3 = ScalarInteger(s7_list_ref(sc, args, 10)); + const s32 v3 = ScalarInteger(s7_list_ref(sc, args, 11)); + + const int argn = length(args); + const tic_texture_src texsrc = (tic_texture_src)(argn > 12 ? ScalarInteger(s7_list_ref(sc, args, 12)) : 0); + + static u8 trans_colors[TIC_PALETTE_SIZE]; + u8 trans_count = 0; + + if (argn > 13) + { + SEXP colorkey = s7_list_ref(sc, args, 13); + parseTransparentColorsArg(sc, colorkey, trans_colors, &trans_count); + } + + bool depth = argn > 14 ? true : false; + const s32 z1 = argn > 14 ? ScalarInteger(s7_list_ref(sc, args, 14)) : 0; + const s32 z2 = argn > 15 ? ScalarInteger(s7_list_ref(sc, args, 15)) : 0; + const s32 z3 = argn > 16 ? ScalarInteger(s7_list_ref(sc, args, 16)) : 0; + + core->api.ttri(tic, x1, y1, x2, y2, x3, y3, u1, v1, u2, v2, u3, v3, texsrc, trans_colors, trans_count, z1, z2, z3, depth); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_peek2(SEXP args) + SEXP r_clip(SEXP args) { - // peek2(addr) -> value + // clip(x y width height) + // clip() tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 addr = ScalarInteger(CADR(args)); - return s7_make_integer(sc, core->api.peek2(tic, addr)); + const int argn = length(args); + if (argn != 4) { + core->api.clip(tic, 0, 0, TIC80_WIDTH, TIC80_HEIGHT); + } else { + const s32 x = ScalarInteger(CADR(args)); + const s32 y = ScalarInteger(CADDR(args)); + const s32 w = ScalarInteger(CADDDR(args)); + const s32 h = ScalarInteger(CADDDDR(args)); + core->api.clip(tic, x, y, w, h); + } + return R_NilValue; } #+end_src - #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_poke2(SEXP args) + SEXP r_font(SEXP args) { - // poke2(addr value) + // font(text x y chromakey char_width char_height fixed=false scale=1 alt=false) -> width tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 addr = ScalarInteger(CADR(args)); - const s32 value = ScalarInteger(CADDR(args)); - core->api.poke2(tic, addr, value); - return R_NilValue + const char* text = ScalarString(CADR(args)); + const s32 x = ScalarInteger(CADDR(args)); + const s32 y = ScalarInteger(CADDDR(args)); + + static u8 trans_colors[TIC_PALETTE_SIZE]; + u8 trans_count = 0; + SEXP colorkey = CADDDDR(args); + parseTransparentColorsArg(sc, colorkey, trans_colors, &trans_count); + + const s32 w = ScalarInteger(s7_list_ref(sc, args, 4)); + const s32 h = ScalarInteger(s7_list_ref(sc, args, 5)); + const int argn = length(args); + const s32 fixed = argn > 6 ? ScalarLogical(sc, s7_list_ref(sc, args, 6)) : false; + const s32 scale = argn > 7 ? ScalarInteger(s7_list_ref(sc, args, 7)) : 1; + const s32 alt = argn > 8 ? ScalarLogical(sc, s7_list_ref(sc, args, 8)) : false; + + return s7_make_integer(sc, core->api.font(tic, text, x, y, trans_colors, trans_count, w, h, fixed, scale, alt)); } #+end_src +=parseTransparentColorsArg= is a helper function which is used elsewhere in the API. + #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_peek4(SEXP args) + void parseTransparentColorsArg(/* LISTSXP */SEXP colorkey, + u8* out_transparent_colors, u8* out_count) { - // peek4(addr) -> value - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 addr = ScalarInteger(CADR(args)); - return s7_make_integer(sc, core->api.peek4(tic, addr)); + ,*out_count = 0; + if (s7_is_list(sc, colorkey)) + { + const s32 arg_color_count = length(colorkey); + const u8 color_count = arg_color_count < TIC_PALETTE_SIZE ? (u8)arg_color_count : TIC_PALETTE_SIZE; + for (u8 i=0; iapi.poke4(tic, addr, value); - return R_NilValue + SEXP r_spr(SEXP args) { + // spr(id x y colorkey=-1 scale=1 flip=0 rotate=0 w=1 h=1) + static u8 trans_colors[TIC_PALETTE_SIZE]; + u8 trans_count = 0; + if (argn > 3) + { + /* DONE: DOES NOT NEED protection and unprotection becausse the LISTSXP is a + ,* part of the args. */ + SEXP *colorkey = &ARGS(4); + parseTransparentColorsArg(sc, + /*Within the Scheme API*/ colorkey, /*is a LIST, so here it should be a LISTSXP.*/ + trans_colors, &trans_count); + } + const s32 scale = argn > 4 ? drIntp(ARGS(5)) : 1; + const s32 flip = argn > 5 ? drIntp(ARGS(6)) : 0; + const s32 rotate = argn > 6 ? drIntp(ARGS(7)) : 0; + const s32 w = argn > 7 ? drIntp(ARGS(8)) : 1; + const s32 h = argn > 8 ? drIntp(ARGS(9)) : 1; + RTICAPI.spr(RTICRAM, + (s32) drIntp(ARGS(1)), + (s32) drIntp(ARGS(2)), + (s32) drIntp(ARGS(3)), + w, h, trans_colors, trans_count, scale, + (tic_flip) flip, + (tic_rotate) rotate); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_memcpy(SEXP args) - { - // memcpy(dest source size) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 dest = ScalarInteger(CADR(args)); - const s32 source = ScalarInteger(CADDR(args)); - const s32 size = ScalarInteger(CADDDR(args)); + SEXP r_print(SEXP args) { + /* print(text x=0 y=0 color=15 fixed=false scale=1 smallfont=false) + ,* ⮑ width*/ + const char *text = (const char *) drChrpp(ARGS(1)); + const s32 x = argn > 1 ? drIntp(ARGS(2)): 0; + const s32 y = argn > 2 ? drIntp(ARGS(3)): 0; + const u8 color = argn > 3 ? drIntp(ARGS(4)): 15; + const bool fixed = argn > 4 ? drIntp(ARGS(5)): false; + const s32 scale = argn > 5 ? drIntp(ARGS(6)): 1; + const bool alt = argn > 6 ? drIntp(ARGS(7)): false; - core->api.memcpy(tic, dest, source, size); - return R_NilValue + return Rf_ScalarLogical(RTICAPI.print(RTICRAM, text, x, y, color, fixed, scale, alt)); } #+end_src +With the preprocessor macros and the R API function ~R_ExternalPtrAddr~ I have +sufficiently simplified the defintion of an =.External= R function to the point +I'm happy to write these and edit the ones which I already have copied from +the s7 Scheme API. + #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_memset(SEXP args) - { - // memset(dest value size) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 dest = ScalarInteger(CADR(args)); - const s32 value = ScalarInteger(CADDR(args)); - const s32 size = ScalarInteger(CADDDR(args)); + SEXP r_cls(SEXP args) { + /* cls(color=0) + ,* ⮑ nil */ + const u8 color = (argn > 0) ? drIntp(ARGS(1)) : 0; + RTICAPI.cls(RTICRAM, color); - core->api.memset(tic, dest, value, size); - return R_NilValue + return R_NilValue; } #+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_trace(SEXP args) - { - // trace(message color=15) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const char* msg = ScalarString(CADR(args)); - const int argn = length(args); - const s32 color = argn > 1 ? ScalarInteger(CADDR(args)) : 15; - core->api.trace(tic, msg, color); - return R_NilValue - } -#+end_src +It isn't so bad to write these now. I can focus on /handling the arguments/, +regardless of their number, rather than acquiring the number of arguments and +protecting intermediate values. #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_pmem(SEXP args) - { - // pmem(index value) - // pmem(index) -> value - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 index = ScalarInteger(CADR(args)); - const int argn = length(args); - s32 value = 0; - bool shouldSet = false; - if (argn > 1) - { - value = ScalarInteger(CADDR(args)); - shouldSet = true; + SEXP r_pix(SEXP args) { + /* pix(x y color = 0) + ,* ⮑ nil + ,* pix(x y) + ,* ⮑ color */ + const s32 x = drIntp(ARGS(1)); + const s32 y = drIntp(ARGS(2)); + + if (argn == 3) { + const u8 color = drIntp(ARGS(3)); + RTICAPI.pix(RTICRAM, x, y, color, false); + return R_NilValue; + } else { + return Rf_ScalarInteger(RTICAPI.pix(RTICRAM, x, y, 0, true)); } - return s7_make_integer(sc, (s32)core->api.pmem(tic, index, value, shouldSet)); } #+end_src +PIX is a setter and getter function; if provided with a color it will set the +pixel at that position to that color (returning ~nil~, ~NULL~ in R), otherwise +it will return the color of the pixel at that position. + #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_time(SEXP args) - { - // time() -> ticks - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - return s7_make_real(sc, core->api.time(tic)); + SEXP r_line(SEXP args) { + /* line(x0 y0 x1 y1 color) + ,* ⮑ nil */ + const s32 x0 = drIntp(ARGS(1)); + const s32 y0 = drIntp(ARGS(2)); + const s32 x1 = drIntp(ARGS(3)); + const s32 y1 = drIntp(ARGS(4)); + const u8 color = drIntp(ARGS(5)); + + RTICAPI.line(RTICRAM, x0, y0, x1, y1, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_tstamp(SEXP args) + SEXP r_rect(SEXP args) { - // tstamp() -> timestamp - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - return s7_make_integer(sc, core->api.tstamp(tic)); + // rect(x y w h color) + const s32 x = drIntp(ARGS(1)); + const s32 y = drIntp(ARGS(2)); + const s32 w = drIntp(ARGS(3)); + const s32 h = drIntp(ARGS(4)); + const u8 color = drIntp(ARGS(5)); + RTICAPI.rect(RTICRAM, x, y, w, h, color); + return R_NilValue; } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_exit(SEXP args) + SEXP r_rectb(SEXP args) { - // exit() - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - core->api.exit(tic); - return R_NilValue + // rectb(x y w h color) + const s32 x = drIntp(ARGS(1)); + const s32 y = drIntp(ARGS(2)); + const s32 w = drIntp(ARGS(3)); + const s32 h = drIntp(ARGS(4)); + const u8 color = drIntp(ARGS(5)); + RTICAPI.rectb(RTICRAM, x, y, w, h, color); + return R_NilValue; } #+end_src +**** TODO =map=, which optionally uses a callback function written in the chosen API language +=remapCallback= uses a pointer to call a given Scheme function, stored in ~remap->callback~. + #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_font(SEXP args) + typedef struct { - // font(text x y chromakey char_width char_height fixed=false scale=1 alt=false) -> width - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const char* text = ScalarString(CADR(args)); - const s32 x = ScalarInteger(CADDR(args)); - const s32 y = ScalarInteger(CADDDR(args)); + s7_scheme* sc; + SEXP callback; + } RemapData; - static u8 trans_colors[TIC_PALETTE_SIZE]; - u8 trans_count = 0; - SEXP colorkey = CADDDDR(args); - parseTransparentColorsArg(sc, colorkey, trans_colors, &trans_count); + static void remapCallback(void* data, s32 x, s32 y, RemapResult* result) + { + RemapData* remap = (RemapData*)data; + s7_scheme* sc = remap->sc; + + /* NOTE: Call the callback function. */ + // (callback index x y) -> (list index flip rotate) + SEXP callbackResult = s7_call(sc, remap->callback, + s7_cons(sc, s7_make_integer(sc, result->index), + s7_cons(sc, s7_make_integer(sc, x), + s7_cons(sc, s7_make_integer(sc, y), + R_NilValue)))); + + if (s7_is_list(sc, callbackResult) && length(callbackResult) == 3) + { + result->index = ScalarInteger(CADR(callbackResult)); + result->flip = (tic_flip)ScalarInteger(CADDR(callbackResult)); + result->rotate = (tic_rotate)ScalarInteger(CADDDR(callbackResult)); + } + } + + SEXP r_map(SEXP args) + { + // map(x=0 y=0 w=30 h=17 sx=0 sy=0 colorkey=-1 scale=1 remap=nil) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 x = ScalarInteger(CADR(args)); + const s32 y = ScalarInteger(CADDR(args)); + const s32 w = ScalarInteger(CADDDR(args)); + const s32 h = ScalarInteger(CADDDDR(args)); + const s32 sx = ScalarInteger(s7_list_ref(sc, args, 4)); + const s32 sy = ScalarInteger(s7_list_ref(sc, args, 5)); - const s32 w = ScalarInteger(s7_list_ref(sc, args, 4)); - const s32 h = ScalarInteger(s7_list_ref(sc, args, 5)); const int argn = length(args); - const s32 fixed = argn > 6 ? ScalarLogical(sc, s7_list_ref(sc, args, 6)) : false; + + static u8 trans_colors[TIC_PALETTE_SIZE]; + u8 trans_count = 0; + if (argn > 6) { + SEXP colorkey = s7_list_ref(sc, args, 6); + parseTransparentColorsArg(sc, colorkey, trans_colors, &trans_count); + } + const s32 scale = argn > 7 ? ScalarInteger(s7_list_ref(sc, args, 7)) : 1; - const s32 alt = argn > 8 ? ScalarLogical(sc, s7_list_ref(sc, args, 8)) : false; - return s7_make_integer(sc, core->api.font(tic, text, x, y, trans_colors, trans_count, w, h, fixed, scale, alt)); + RemapFunc remap = NULL; + RemapData data; + if (argn > 8) + { + remap = remapCallback; + data.sc = sc; + data.callback = s7_list_ref(sc, args, 8); + } + core->api.map(tic, x, y, w, h, sx, sy, trans_colors, trans_count, scale, remap, &data); + return R_NilValue; + } +#+end_src + +*** Input +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_key(SEXP args) + { + //key(code=-1) -> pressed + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const int argn = length(args); + const tic_key code = argn > 0 ? ScalarInteger(CADR(args)) : -1; + return s7_make_boolean(sc, core->api.key(tic, code)); } #+end_src +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_keyp(SEXP args) + { + // keyp(code=-1 hold=-1 period=-1) -> pressed + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const int argn = length(args); + const tic_key code = argn > 0 ? ScalarInteger(CADR(args)) : -1; + const s32 hold = argn > 1 ? ScalarInteger(CADDR(args)) : -1; + const s32 period = argn > 2 ? ScalarInteger(CADDDR(args)) : -1; + return s7_make_boolean(sc, core->api.keyp(tic, code, hold, period)); + } +#+end_src #+begin_src C :noweb-ref define C symbols to be callable from R /* This API function does not use the convenience macros because it doesn't need ,* to protect any values from garbage collection, because every use of an R API @@ -1300,7 +1414,7 @@ it will return the color of the pixel at that position. { /* mouse() ,* ⮑ x y left middle right scrollx scrolly */ - tic_mem *tic = (tic_mem *)R_ExternalPtrAddr(RTicMem); + tic_mem *tic = (tic_mem *) RTICRAM; tic_core* core = (tic_core *)tic; const tic_point point = core->api.mouse(tic); @@ -1315,160 +1429,27 @@ it will return the color of the pixel at that position. ScalarInteger(mouse->scrolly))); } #+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - RSTRT(r_circ) - // circ(x y radius color) - const s32 x = psint(first); - const s32 y = psint(second); - const s32 radius = psint(third); - const s32 color = psint(fourth); - - core->api.circ(tic, x, y, radius, color); - - RUNP; - return R_NilValue; - REND -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_circb(SEXP args) - { - // circb(x y radius color) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x = ScalarInteger(CADR(args)); - const s32 y = ScalarInteger(CADDR(args)); - const s32 radius = ScalarInteger(CADDDR(args)); - const s32 color = ScalarInteger(CADDDDR(args)); - core->api.circb(tic, x, y, radius, color); - return R_NilValue - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_elli(SEXP args) - { - // elli(x y a b color) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x = ScalarInteger(CADR(args)); - const s32 y = ScalarInteger(CADDR(args)); - const s32 a = ScalarInteger(CADDDR(args)); - const s32 b = ScalarInteger(CADDDDR(args)); - const s32 color = ScalarInteger(s7_list_ref(sc, args, 4)); - core->api.elli(tic, x, y, a, b, color); - return R_NilValue - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_ellib(SEXP args) - { - // ellib(x y a b color) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x = ScalarInteger(CADR(args)); - const s32 y = ScalarInteger(CADDR(args)); - const s32 a = ScalarInteger(CADDDR(args)); - const s32 b = ScalarInteger(CADDDDR(args)); - const s32 color = ScalarInteger(s7_list_ref(sc, args, 4)); - core->api.ellib(tic, x, y, a, b, color); - return R_NilValue - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_tri(SEXP args) - { - // tri(x1 y1 x2 y2 x3 y3 color) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x1 = ScalarInteger(CADR(args)); - const s32 y1 = ScalarInteger(CADDR(args)); - const s32 x2 = ScalarInteger(CADDDR(args)); - const s32 y2 = ScalarInteger(CADDDDR(args)); - const s32 x3 = ScalarInteger(s7_list_ref(sc, args, 4)); - const s32 y3 = ScalarInteger(s7_list_ref(sc, args, 5)); - const s32 color = ScalarInteger(s7_list_ref(sc, args, 6)); - core->api.tri(tic, x1, y1, x2, y2, x3, y3, color); - return R_NilValue - } -#+end_src - #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_trib(SEXP args) + SEXP r_btn(SEXP args) { - // trib(x1 y1 x2 y2 x3 y3 color) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x1 = ScalarInteger(CADR(args)); - const s32 y1 = ScalarInteger(CADDR(args)); - const s32 x2 = ScalarInteger(CADDDR(args)); - const s32 y2 = ScalarInteger(CADDDDR(args)); - const s32 x3 = ScalarInteger(s7_list_ref(sc, args, 4)); - const s32 y3 = ScalarInteger(s7_list_ref(sc, args, 5)); - const s32 color = ScalarInteger(s7_list_ref(sc, args, 6)); - core->api.trib(tic, x1, y1, x2, y2, x3, y3, color); - return R_NilValue + // btn(id) -> pressed + return Rf_ScalarLogical(RTICAPI.btn(RTICRAM, (s32) ARGS(1))); } #+end_src #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_ttri(SEXP args) + SEXP r_btnp(SEXP args) { - // ttri(x1 y1 x2 y2 x3 y3 u1 v1 u2 v2 u3 v3 texsrc=0 chromakey=-1 z1=0 z2=0 z3=0) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 x1 = ScalarInteger(CADR(args)); - const s32 y1 = ScalarInteger(CADDR(args)); - const s32 x2 = ScalarInteger(CADDDR(args)); - const s32 y2 = ScalarInteger(CADDDDR(args)); - const s32 x3 = ScalarInteger(s7_list_ref(sc, args, 4)); - const s32 y3 = ScalarInteger(s7_list_ref(sc, args, 5)); - const s32 u1 = ScalarInteger(s7_list_ref(sc, args, 6)); - const s32 v1 = ScalarInteger(s7_list_ref(sc, args, 7)); - const s32 u2 = ScalarInteger(s7_list_ref(sc, args, 8)); - const s32 v2 = ScalarInteger(s7_list_ref(sc, args, 9)); - const s32 u3 = ScalarInteger(s7_list_ref(sc, args, 10)); - const s32 v3 = ScalarInteger(s7_list_ref(sc, args, 11)); - - const int argn = length(args); - const tic_texture_src texsrc = (tic_texture_src)(argn > 12 ? ScalarInteger(s7_list_ref(sc, args, 12)) : 0); - - static u8 trans_colors[TIC_PALETTE_SIZE]; - u8 trans_count = 0; - - if (argn > 13) - { - SEXP colorkey = s7_list_ref(sc, args, 13); - parseTransparentColorsArg(sc, colorkey, trans_colors, &trans_count); - } - - bool depth = argn > 14 ? true : false; - const s32 z1 = argn > 14 ? ScalarInteger(s7_list_ref(sc, args, 14)) : 0; - const s32 z2 = argn > 15 ? ScalarInteger(s7_list_ref(sc, args, 15)) : 0; - const s32 z3 = argn > 16 ? ScalarInteger(s7_list_ref(sc, args, 16)) : 0; - - core->api.ttri(tic, x1, y1, x2, y2, x3, y3, u1, v1, u2, v2, u3, v3, texsrc, trans_colors, trans_count, z1, z2, z3, depth); - return R_NilValue - } -#+end_src + // btnp(id hold=-1 period=-1) -> pressed + const s32 id = drIntp(ARGS(1)); + const int argn = Rf_length(args); + const s32 hold = argn > 1 ? drIntp(ARGS(2)) : -1; + const s32 period = argn > 2 ? drIntp(ARGS(3)) : -1; -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_clip(SEXP args) - { - // clip(x y width height) - // clip() - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const int argn = length(args); - if (argn != 4) { - core->api.clip(tic, 0, 0, TIC80_WIDTH, TIC80_HEIGHT); - } else { - const s32 x = ScalarInteger(CADR(args)); - const s32 y = ScalarInteger(CADDR(args)); - const s32 w = ScalarInteger(CADDDR(args)); - const s32 h = ScalarInteger(CADDDDR(args)); - core->api.clip(tic, x, y, w, h); - } - return R_NilValue + return Rf_ScalarLogical(RTICAPI.btnp(RTICRAM, id, hold, period)); } #+end_src - +*** Sound #+begin_src C :noweb-ref define C symbols to be callable from R SEXP r_music(SEXP args) { @@ -1483,607 +1464,397 @@ it will return the color of the pixel at that position. const s32 tempo = argn > 5 ? ScalarInteger(s7_list_ref(sc, args, 5)) : -1; const s32 speed = argn > 6 ? ScalarInteger(s7_list_ref(sc, args, 6)) : -1; core->api.music(tic, track, frame, row, loop, sustain, tempo, speed); - return R_NilValue + return R_NilValue; } #+end_src +These API functions are related to sound processing. #+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_sync(SEXP args) - { - // sync(mask=0 bank=0 tocart=false) - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const int argn = length(args); - const u32 mask = argn > 0 ? (u32)ScalarInteger(CADR(args)) : 0; - const s32 bank = argn > 1 ? ScalarInteger(CADDR(args)) : 0; - const bool tocart = argn > 2 ? ScalarLogical(sc, CADDDR(args)) : false; - core->api.sync(tic, mask, bank, tocart); - return R_NilValue + u8 get_note_base(char c) { + switch (c) { + case 'C': return 0; + case 'D': return 2; + case 'E': return 4; + case 'F': return 5; + case 'G': return 7; + case 'A': return 9; + case 'B': return 11; + default: return 255; + } } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_vbank(SEXP args) - { - // vbank(bank) -> prev - // vbank() -> prev - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const int argn = length(args); - const s32 prev = ((tic_core*)tic)->state.vbank.id; - if (argn == 1) { - const s32 bank = ScalarInteger(CADR(args)); - core->api.vbank(tic, bank); + u8 get_note_modif(char c) { + switch (c) { + case '-': return 0; + case '#': return 1; + default: return 255; } - return s7_make_integer(sc, prev); } -#+end_src -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_reset(SEXP args) + u8 get_note_octave(char c) { + if (c >= '0' && c <= '8') + return c - '0'; + else + return 255; + } + + SEXP r_sfx(SEXP a, SEXP args) { - // reset() - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - core->api.reset(tic); - return R_NilValue - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_key(SEXP args) - { - //key(code=-1) -> pressed - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const int argn = length(args); - const tic_key code = argn > 0 ? ScalarInteger(CADR(args)) : -1; - return s7_make_boolean(sc, core->api.key(tic, code)); - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_keyp(SEXP args) - { - // keyp(code=-1 hold=-1 period=-1) -> pressed - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const int argn = length(args); - const tic_key code = argn > 0 ? ScalarInteger(CADR(args)) : -1; - const s32 hold = argn > 1 ? ScalarInteger(CADDR(args)) : -1; - const s32 period = argn > 2 ? ScalarInteger(CADDDR(args)) : -1; - return s7_make_boolean(sc, core->api.keyp(tic, code, hold, period)); - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_fget(SEXP args) - { - // fget(sprite_id flag) -> bool - tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 sprite_id = ScalarInteger(CADR(args)); - const u8 flag = ScalarInteger(CADDR(args)); - return s7_make_boolean(sc, core->api.fget(tic, sprite_id, flag)); - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_fset(SEXP args) - { - // fset(sprite_id flag bool) + // sfx(id note=-1 duration=-1 channel=0 volume=15 speed=0) tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; - const s32 sprite_id = ScalarInteger(CADR(args)); - const u8 flag = ScalarInteger(CADDR(args)); - const bool val = ScalarLogical(sc, CADDDR(args)); - core->api.fset(tic, sprite_id, flag, val); - return R_NilValue - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_fft(SEXP args) - { - // fft(int start_freq, int end_freq=-1) -> float_value - tic_core* core = R_GlobalEnv; - tic_mem* tic = (tic_mem*)core; + const s32 id = ScalarInteger(CADR(args)); const int argn = length(args); - const s32 start_freq = argn > 0 ? ScalarInteger(CADR(args)) : -1; - const s32 end_freq = argn > 1 ? ScalarInteger(CADDR(args)) : -1; - - return s7_make_real(sc, core->api.fft(tic, start_freq, end_freq)); - } -#+end_src - -#+begin_src C :noweb-ref define C symbols to be callable from R - SEXP r_ffts(SEXP args) - { - // ffts(int start_freq, int end_freq=-1) -> float_value - tic_core* core = R_GlobalEnv; - tic_mem* tic = (tic_mem*)core; - const int argn = length(args); - const s32 start_freq = argn > 0 ? ScalarInteger(CADR(args)) : -1; - const s32 end_freq = argn > 1 ? ScalarInteger(CADDR(args)) : -1; - - return s7_make_real(sc, core->api.ffts(tic, start_freq, end_freq)); - } -#+end_src - -** Procedures to initialize, close, and re-initialize R -Both =initScheme= and =closeScheme= begin with casting ~tic_mem *tic~ to a -~tic_core *~, effectively mapping from one area of memory to another (like a -hashmap or simply shifting the memory until the child struct is aligned with the -parent struct). -# Adjust the prior sentence because it's inaccurate. -This map permits access within =closeScheme= to the =currentVM= member of the -TIC-80 core memory. This is only my basic understanding, and some of it is -adventurous bullshitting; I really don't know if that was true, what I said, and -I don't much care if it wasn't because I'm writing this as I still work to -understand what I'm reading, so this is only a draft paragraph. - -In the Lua integration the manner to initialize Lua is the use of a pointer to a -=lua_State= type (which is actually a thread, but indirectly refers to the state -associated with the thread). Every Lua C API function requires a pointer of this -type as its first argument, so calling the procedure ~lua_newstate~ creates a -fresh, independent thread of execution. That's all that is required to embed and -then instantiate a Lua 5.4 interpreter within a larger application. - -The general design of TIC-80 relies on an embedded language API using pointers -to the interpreter as the first argument of many of its functions. This is an -active design choice and is likely related to memory management in TIC-80, which -is necessarily complicated by the fact that langauge interpreters are of -different sizes, as are their language codes which say ~Hello, world!~. It's a -complicated topic. I won't think on it. - -R is not designed to be embedded in the same sense as other languages, it is not -an extension language for other programs, it is /the main program/ and even has -built-in variables implying it is assumed to be true that -=R_running_as_main_program=, even when embedded, and a potential ~longjmp~ -complicates matters more. Still, we will push on towards our goal despite my -ignorance and inexperience. - -R expects the arguments from the operating system shell to be passed along to -it---"Yes, even when embedded."---and thus we need fake arguments. For now, -we'll borrow the code from the /Writing R Extensions/ manual to pass -~Rf_initEmbeddedR~ some fake arguments, and we'll write a procedure to handle -restarting R as necessary and tracking the current interpreter (there can be -only one). - -#+name: kill R -#+begin_src C -#+end_src - -That is defined separately, and not as a macro, so that the code can be re-used. - -#+begin_src C :noweb no-export :noweb-ref cartridge commands - void R_CleanUp(Rboolean saveact, int status, int RunLast) { ; } - - void R_Suicide(const char *message) - { - char pp[1024]; - snprintf(pp, 1024, "Fatal error, but can't kermit: %s\n"\ - "Execute me, please.\n", message); - R_ShowMessage(pp); - exit(1); - - while(1); - } - - static tic_mem *tic_memory_static; - - void R_ShowMessage(const char *s) { - /* Always use the sixteenth color. */ - ((tic_core *) tic_memory_static)->api.trace(tic_memory_static, s, 15); - } - - /* This function is called with code, which is the entirety of the studio - ,,* editor's code buffer (i.e. the entire game code as one string). */ - static bool initR(tic_mem *tic, const char *code) { - tic_memory_static = tic; - - closeR(tic); - - /* embdRAV: embedded R argument vector. */ - static char *embdRAV[] = { "TIC-80", "--quiet", "--vanilla" }; - - /* Without this nothing in R will work. */ - setEnvironmentVariablesIfUnset(); - static bool R_Initialized = false; - - R_running_as_main_program = 0; - - if (!R_Initialized) { - R_Initialized = (bool) Rf_initEmbeddedR(sizeof(embdRAV)/sizeof(embdRAV[0]), \ - embdRAV); - R_running_as_main_program = 0; - /* Declared in Rinterface.h, defined in Rf_initEmbeddedR. */ - R_Interactive = false; - } - - <> - - Rf_eval(CSTR2LANGSXP("if (exists(\"BOOT\") && is.function(BOOT)) { BOOT() } " \ - "else { BOOT <- function() `{`; ## Tricky NOP. }"), - R_GlobalEnv); - - return R_Initialized; - } - - static void closeR(tic_mem *tic) { - tic_core *core; - if ((core = (((tic_core *) tic))->currentVM) != NULL) { - Rf_endEmbeddedR(0); - core->currentVM = NULL; - } - } -#+end_src - -** Cartidge callback commands -It might not be advisable to define the ~TIC~ function in the R API as -~`TIC-80`~, but because R allows non-syntactic names I'll use it so that the -actual name of the machine can be used. If the machine were called ~MANE~ we'd -want to use that, but if we were forced to use ~main~ that'd be a nice homophone -at least. The =exists= function doesn't use symbols, it uses strings to lookup -symbols so that is why that part differs in the chunk below. - -#+begin_src C :noweb-ref cartridge commands - static void callRFn_TIC80(tic_mem* tic) { - #if !defined R_INTERNALS_H_ - #error "R_GlobalEnv not defined because Rinternals.h not properly included... somehow." - #endif - /* if (exists("TIC-80") && is.function(`TIC-80`)) `TIC-80`() */ - Rf_eval(Rf_mkString("if (exists(\"TIC-80\") && is.function(`TIC-80`)) "\ - "`TIC-80`()"), - R_GlobalEnv); - } -#+end_src - -Previously, the following macro only generated R code defining syntactic -identifiers; after reviewing the help page for quoting in R, it makes more sense -for it to always quote the name to be called as a function if that name exists -and is a function (the latter test also using back-quoting, but no matter). This -allows the calling of both syntactic and non-syntactic names in R, allowing the -macro to generate the C code which will call any defined R function in the -global environment. An obvious extension would be the definition of another -macro expanding to a call of this one with supplied, alternative environment. An -inobvious (to me, at first) issue is that anything which is a non-syntactic name -in R is absolutely a non-syntactic name in C and cannot be used! The ability to -define a C function to call an R function with any name does not help me in the -way I originally intended, unless I rewrite the macro to use another argument -(if supplied) as the R function name that will be called in R, while the -argument =f= is the C function identifier. That's too much work for now and zero -benefit, so I continue using the previous code block to define the C function to -call a non-syntactic name in R as a function. - -#+name: comment on the following block of preprocessor definitions -#+begin_comment -The callback functions below are okay. If you're reading this, coming from the -current mess in the [[Debugging segfaults]] section then references to R_GlobalEnv -in this code block aren't related to the references to that environment in the -backtrace quoted in the mentioned section. -#+end_comment - -#+name: proprocessor definitions to define cartridge callback functions -#+begin_src C :noweb-ref cartridge commands - #define defineCallRFnInEnvironment_(f, e, ...) \ - static void callRFn_##f(tic_mem *tic, ##__VA_ARGS__) { \ - Rf_eval(Rf_mkString("if (exists(\""#f"\") && is.function(`"#f"`)) " \ - "`"#f"`() else stop(\""#f" is not a defined function!\")"),\ - e); \ - } - /* i.e., if (exists("f") && is.function(`f`)) `f`(), allowing call of syntactic - ,* and non-syntactic names. */ - #define defineCallRFn_(f, ...) defineCallRFnInEnvironment_(f, R_GlobalEnv, ...) - defineCallRFn_(BOOT) - /* s32 row/index, void *data as well as the tic_mem *tic parameters. */ - defineCallRFn_(MENU, s32 index, void *data) - defineCallRFn_(BDR, s32 row, void *data) - defineCallRFn_(SCN, s32 row, void *data) - #undef defineCallRFn_ - #undef defineCallRFnInEnvironment_ -#+end_src - -**** Exporting a =tic_script= for *TIC-80* to use at compile-time -This constant is used by TIC-80 to setup the cartridge, both for editing in the -"studio" and the runtime evaluat (use-package emacsql-sqlite :after 'emacsql) -ion of the script. - -#+name: TIC EXPORT -#+begin_src c - /* DEFAULT visibility*/ - /* EXPORT_SCRIPT -> RScriptConfig if static, else ScriptConfig */ - TIC_EXPORT const tic_script EXPORT_SCRIPT(R) = - { - /* The first five members of the struct have the sum total following - ,* size. */ - /* sizeof(u8) + 3 * sizeof(char *) */ - /* R's id is determined by counting up from 10, beginning with Lua, all of - the other languages TIC-80 supports. Python was the 10th langauge supported, - with .id 20. */ - .id = 21, - .name = "r", - .fileExtension = ".r", - .projectComment = "##", - { - .init = initR, - - .close = closeR, - .tick = callRFn_TIC80, - .boot = callRFn_BOOT, - - .callback = - { - .scanline = callRFn_SCN, - .border = callRFn_BDR, - .menu = callRFn_MENU, - }, - }, - - .getOutline = getROutline, - .eval = evalR, - - .blockCommentStart = NULL, - .blockCommentEnd = NULL, - .blockCommentStart2 = NULL, - .blockCommentEnd2 = NULL, - .singleComment = "##", - .blockStringStart = "\"", - .blockStringEnd = "\"", - .stdStringStartEnd = "\"", - .blockEnd = NULL, - .lang_isalnum = r_isalnum, - .api_keywords = RAPIKeywords, - .api_keywordsCount = COUNT_OF(RAPIKeywords), - .useStructuredEdition = false, - - .keywords = RKeywords, - .keywordsCount = COUNT_OF(RKeywords), - - .demo = {DemoRom, sizeof DemoRom}, - .mark = {MarkRom, sizeof MarkRom, "rmark.tic"}, - }; -#+end_src - -On line three of the current source file---/exempli gratia/---if =MACROVAR(it)= -was invoked its argument would expand to =it3=. When used in the first define -below, =it3= will be a pointer to an array of tic_scripts, which is iterated -over (explaning the =it= argument). ~*script~ is modified, but the type -specifier is ~const~, so what's going on with the syntax that I don't remember? -Does it only apply to the first declared variable in the identifier list? - -~Scripts~ is an array of =tic_script *=-typed objects, that is it is an array of -pointers to =tic_script= objects. - -#+name: FOREACH_LANG -#+begin_src C - #define FOREACH_LANG(script) \ - for(const tic_script **MACROVAR(it) = tic_scripts(), *script = *MACROVAR(it); \ - ,*MACROVAR(it); \ - script = *++MACROVAR(it)) + int note = -1; + int octave = -1; + if (argn > 1) { + SEXP note_ptr = CADDR(args); + if (s7_is_integer(note_ptr)) { + const s32 raw_note = ScalarInteger(note_ptr); + if (raw_note >= 0 || raw_note <= 95) { + note = raw_note % 12; + octave = raw_note / 12; + } + /* else { */ + /* char buffer[100]; */ + /* snprintf(buffer, 99, "Invalid sfx note given: %d\n", raw_note); */ + /* tic->data->error(tic->data->data, buffer); */ + /* } */ + } else if (s7_is_string(note_ptr)) { + const char* note_str = ScalarString(note_ptr); + const u8 len = ScalarString_length(note_ptr); + if (len == 3) { + const u8 modif = get_note_modif(note_str[1]); + note = get_note_base(note_str[0]); + octave = get_note_octave(note_str[2]); + if (note < 255 || modif < 255 || octave < 255) { + note = note + modif; + } else { + note = octave = 255; + } + } + /* if (note == 255 || octave == 255) { */ + /* char buffer[100]; */ + /* snprintf(buffer, 99, "Invalid sfx note given: %s\n", note_str); */ + /* tic->data->error(tic->data->data, buffer); */ + /* } */ + } + } - #define CONCAT2(a, b) a ## b - #define CONCAT(a, b) CONCAT2(a, b) - #define MACROVAR(name) CONCAT(name, __LINE__) + const s32 duration = argn > 2 ? ScalarInteger(CADDDR(args)) : -1; + const s32 channel = argn > 3 ? ScalarInteger(CADDDDR(args)) : 0; + s32 volumes[TIC80_SAMPLE_CHANNELS] = {MAX_VOLUME, MAX_VOLUME}; + if (argn > 4) { + SEXP volume_arg = s7_list_ref(sc, args, 4); + if (s7_is_integer(volume_arg)) { + volumes[0] = volumes[1] = ScalarInteger(volume_arg) & 0xF; + } else if (s7_is_list(sc, volume_arg) && length(volume_arg) == 2) { + volumes[0] = ScalarInteger(CADR(volume_arg)) & 0xF; + volumes[1] = ScalarInteger(CADDR(volume_arg)) & 0xF; + } + } + const s32 speed = argn > 5 ? ScalarInteger(s7_list_ref(sc, args, 5)) : 0; - const tic_script** tic_scripts() + core->api.sfx(tic, id, note, octave, duration, channel, volumes[0], volumes[1], speed); + return R_NilValue; + } +#+end_src +*** Memory +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_sync(SEXP args) { - return Scripts; + // sync(mask=0 bank=0 tocart=false) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const int argn = length(args); + const u32 mask = argn > 0 ? (u32)ScalarInteger(CADR(args)) : 0; + const s32 bank = argn > 1 ? ScalarInteger(CADDR(args)) : 0; + const bool tocart = argn > 2 ? ScalarLogical(sc, CADDDR(args)) : false; + core->api.sync(tic, mask, bank, tocart); + return R_NilValue; } +#+end_src - static const tic_script *Scripts[MAX_SUPPORTED_LANGS + 1] = +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_vbank(SEXP args) { - #if defined(TIC_RUNTIME_STATIC) - #if defined (TIC_BUILD_WITH_LUA) - &EXPORT_SCRIPT(Lua), - #endif - - #if defined(TIC_BUILD_WITH_RUBY) - &EXPORT_SCRIPT(Ruby), - #endif - - #if defined(TIC_BUILD_WITH_JS) - &EXPORT_SCRIPT(Js), - #endif - - #if defined(TIC_BUILD_WITH_MOON) - &EXPORT_SCRIPT(Moon), - #endif - - #if defined(TIC_BUILD_WITH_FENNEL) - &EXPORT_SCRIPT(Fennel), - #endif - - #if defined(TIC_BUILD_WITH_SCHEME) - &EXPORT_SCRIPT(Scheme), - #endif - - #if defined(TIC_BUILD_WITH_SQUIRREL) - &EXPORT_SCRIPT(Squirrel), - #endif - - #if defined(TIC_BUILD_WITH_WREN) - &EXPORT_SCRIPT(Wren), - #endif - - #if defined(TIC_BUILD_WITH_WASM) - &EXPORT_SCRIPT(Wasm), - #endif - - #if defined(TIC_BUILD_WITH_JANET) - &EXPORT_SCRIPT(Janet), - #endif - - #if defined(TIC_BUILD_WITH_PYTHON) - &EXPORT_SCRIPT(Python), - #endif - - #endif + // vbank(bank) -> prev + // vbank() -> prev + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const int argn = length(args); - NULL, - }; + const s32 prev = ((tic_core*)tic)->state.vbank.id; + if (argn == 1) { + const s32 bank = ScalarInteger(CADR(args)); + core->api.vbank(tic, bank); + } + return s7_make_integer(sc, prev); + } #+end_src - -**** Providing lists of syntax elements for highlighting and outline generation -#+name: SYNTAX HIGHLIGHTING AND OUTLINE GENERATION -#+begin_src C :noweb no-export - <> - - <> - - <> +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_peek(SEXP args) + { + // peek(addr bits=8) -> value + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + const int argn = length(args); + const s32 bits = argn > 1 ? ScalarInteger(CADDR(args)) : 8; + return s7_make_integer(sc, core->api.peek(tic, addr, bits)); + } #+end_src -***** Syntax highlighting the reserved words in R -Syntax highlighting is not always easy, especially when regular expressions are -involved. What we are using in TIC-80 is a more naive approach, but one which is -easier to maintain because it is less powerful and less flexible. It is at the -opposite side of the spectrum from a full parser or a language server. - -The simple system in TIC-80 merely highlights all keywords of a language in one -colour, and all other syntax elements in another colour (presumably, the default -foreground colour). - -R has only a few reserved words, and very little of it is "critical syntax" -characters. The seemingly fundamental syntax characters ~{~ and ~(~ are actually -function calls, which could be shadowed if desired. - -Reserved words cannot be used as syntactic names, but as non-syntactic names -they can be used, so ~`if`~ is a different symbol or name than ~if~ and may be -used otherwise, as with ~`function`~. - -#+name: Specify the reserved words for automatic syntax -#+begin_src c - static const char* const RKeywords [] = - { - "if", "else", "repeat", "while", "function", "for", "in", "next", "break", - "TRUE", "FALSE", "NULL", "Inf", "NaN", "NA", "NA_integer_", "NA_real_", - "NA_complex_", "NA_character_", - /* et cetera, see ?dots */ - "...", "..1", "..2", "..3", "..4", "..5", "..6", "..7", "..8", "..9", - }; +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_poke(SEXP args) + { + // poke(addr value bits=8) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + const s32 value = ScalarInteger(CADDR(args)); + const int argn = length(args); + const s32 bits = argn > 2 ? ScalarInteger(CADDDR(args)) : 8; + core->api.poke(tic, addr, value, bits); + return R_NilValue; + } #+end_src -****** =..n=: variadic argument access across the natural numbers -The entirety of the natural numbers are reserved words when the occur after the -characters ~..~, becuase any ordinal number is usable to access a member of the -dotted argument (how R cleverly deals with variadic arguments). The functions -which otherwise handle these variadic argument list members are not reserved -words, for example ~..length()~ or even ~..n()~ are not reserved. - -***** Outline generation -Generating and outline will provide the editor with the ability to jump to -different areas of the script being written. +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_peek1(SEXP args) + { + // peek1(addr) -> value + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + return s7_make_integer(sc, core->api.peek1(tic, addr)); + } +#+end_src -#+name: OUTLINE GENERATION -#+begin_src C - /* A naive edit of the Python function to check if a character is a valid - ,* character within an identifier. */ - static bool r_isalnum(char c) { - return ( - (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || (c >= '0' && c <= '9') - || (c == '_') || (c == '.') - ); +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_poke1(SEXP args) + { + // poke1(addr value) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + const s32 value = ScalarInteger(CADDR(args)); + core->api.poke1(tic, addr, value); + return R_NilValue; } +#+end_src - static const tic_outline_item* getROutline(const char* code, s32* size) +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_peek2(SEXP args) { - enum{Size = sizeof(tic_outline_item)}; - ,*size = 0; + // peek2(addr) -> value + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + return s7_make_integer(sc, core->api.peek2(tic, addr)); + } +#+end_src - static tic_outline_item* items = NULL; +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_poke2(SEXP args) + { + // poke2(addr value) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + const s32 value = ScalarInteger(CADDR(args)); + core->api.poke2(tic, addr, value); + return R_NilValue; + } +#+end_src - if(items) - { - free(items); - items = NULL; - } +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_peek4(SEXP args) + { + // peek4(addr) -> value + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + return s7_make_integer(sc, core->api.peek4(tic, addr)); + } +#+end_src - const char* ptr = code; +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_poke4(SEXP args) + { + // poke4(addr value) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 addr = ScalarInteger(CADR(args)); + const s32 value = ScalarInteger(CADDR(args)); + core->api.poke4(tic, addr, value); + return R_NilValue; + } +#+end_src - while(true) - { - static const char FuncString[] = "<- function("; +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_memcpy(SEXP args) + { + // memcpy(dest source size) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 dest = ScalarInteger(CADR(args)); + const s32 source = ScalarInteger(CADDR(args)); + const s32 size = ScalarInteger(CADDDR(args)); - ptr = strstr(ptr, FuncString); + core->api.memcpy(tic, dest, source, size); + return R_NilValue; + } +#+end_src - if(ptr) - { - ptr += sizeof FuncString - 1; +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_memset(SEXP args) + { + // memset(dest value size) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 dest = ScalarInteger(CADR(args)); + const s32 value = ScalarInteger(CADDR(args)); + const s32 size = ScalarInteger(CADDDR(args)); - const char* start = ptr; - const char* end = start; + core->api.memset(tic, dest, value, size); + return R_NilValue; + } +#+end_src - while(*ptr) - { - char c = *ptr; +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_pmem(SEXP args) + { + // pmem(index value) + // pmem(index) -> value + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 index = ScalarInteger(CADR(args)); + const int argn = length(args); + s32 value = 0; + bool shouldSet = false; + if (argn > 1) + { + value = ScalarInteger(CADDR(args)); + shouldSet = true; + } + return s7_make_integer(sc, (s32)core->api.pmem(tic, index, value, shouldSet)); + } +#+end_src - if(r_isalnum(c)); - else - { - end = ptr; - break; - } - ptr++; - } +*** Utilities +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_fget(SEXP args) + { + // fget(sprite_id flag) -> bool + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 sprite_id = ScalarInteger(CADR(args)); + const u8 flag = ScalarInteger(CADDR(args)); + return s7_make_boolean(sc, core->api.fget(tic, sprite_id, flag)); + } +#+end_src - if(end > start) - { - items = realloc(items, (*size + 1) * Size); +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_fset(SEXP args) + { + // fset(sprite_id flag bool) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 sprite_id = ScalarInteger(CADR(args)); + const u8 flag = ScalarInteger(CADDR(args)); + const bool val = ScalarLogical(sc, CADDDR(args)); + core->api.fset(tic, sprite_id, flag, val); + return R_NilValue; + } +#+end_src +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_mget(SEXP args) + { + // mget(x y) -> tile_id + return Rf_ScalarInteger(RTICAPI.mget(RTICRAM, (s32) drIntp(ARGS(1)), (s32) drIntp(ARGS(2)))); + } +#+end_src - items[*size].pos = start; - items[*size].size = (s32)(end - start); +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_mset(SEXP args) + { + // mset(x y tile_id) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const s32 x = ScalarInteger(CADR(args)); + const s32 y = ScalarInteger(CADDR(args)); + const u8 tile_id = ScalarInteger(CADDDR(args)); + core->api.mset(tic, x, y, tile_id); + return R_NilValue; + } +#+end_src +*** System +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_reset(SEXP args) + { + // reset() + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + core->api.reset(tic); + return R_NilValue; + } +#+end_src +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_trace(SEXP args) + { + // trace(message color=15) + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + const char* msg = ScalarString(CADR(args)); + const int argn = length(args); + const s32 color = argn > 1 ? ScalarInteger(CADDR(args)) : 15; + core->api.trace(tic, msg, color); + return R_NilValue; + } +#+end_src - (*size)++; - } - } - else break; - } +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_time(SEXP args) + { + // time() -> ticks + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + return s7_make_real(sc, core->api.time(tic)); + } +#+end_src - return items; +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_tstamp(SEXP args) + { + // tstamp() -> timestamp + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + return s7_make_integer(sc, core->api.tstamp(tic)); } #+end_src -***** R API implementation keywords -The API keywords are either callbacks to the TIC-80 virtual machine---which can -be thought of as an operating system interface---or the user-facing API -functions. The following definitions are simply taken from the file =scheme.c=, -which implements the s7 Scheme integration, and the obvious changes made (Scheme -changed to R). +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_exit(SEXP args) + { + // exit() + tic_core* core = R_GlobalEnv; tic_mem* tic = (tic_mem*)core; + core->api.exit(tic); + return R_NilValue; + } +#+end_src -While [[https://github.com/nesbox/TIC-80/discussions/2100][in this GitHub discussion]] nesbox claims that one can simply place your -source files, with their respective langauge file suffixes, in "demos/" and the -build process will take care of generating a .tic.dat file, that doesn't appear -to be true [[https://github.com/nesbox/TIC-80/commit/87e91e7dd903dac7a9c232d1127a32b0d4a8dc54][given this commit]] and the inability for me to build solely due to -these files not being created automatically by a CMake build target. That's an -issue that will need to be opened. +*** TODO Special API functions +These functions are used when live-coding music or demos at conventions. -After taking the time to understand the macros used in the definition of -RAPIKeywords, borrowed from SchemeAPIKeywords, I would /not/ bother to do it any -other way, as in the way Python or Janet did it. It is really, really neat. I -like this. +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_fft(SEXP args) + { + // fft(int start_freq, int end_freq=-1) -> float_value + tic_core* core = R_GlobalEnv; + tic_mem* tic = (tic_mem*)core; -#+name: R API implementation keywords -#+begin_src C - static const char* RAPIKeywords[] = { - #define TIC_CALLBACK_DEF(name, ...) #name, - TIC_CALLBACK_LIST(TIC_CALLBACK_DEF) - #undef TIC_CALLBACK_DEF + const int argn = length(args); + const s32 start_freq = argn > 0 ? ScalarInteger(CADR(args)) : -1; + const s32 end_freq = argn > 1 ? ScalarInteger(CADDR(args)) : -1; - #define API_KEYWORD_DEF(name, ...) #name, - TIC_API_LIST(API_KEYWORD_DEF) - #undef API_KEYWORD_DEF - }; + return s7_make_real(sc, core->api.fft(tic, start_freq, end_freq)); + } +#+end_src - static const u8 DemoRom[] = +#+begin_src C :noweb-ref define C symbols to be callable from R + SEXP r_ffts(SEXP args) { - /* Automatically built from ../../demos/rdemo.r */ - #include "../build/assets/rdemo.tic.dat" - }; + // ffts(int start_freq, int end_freq=-1) -> float_value + tic_core* core = R_GlobalEnv; + tic_mem* tic = (tic_mem*)core; + const int argn = length(args); + const s32 start_freq = argn > 0 ? ScalarInteger(CADR(args)) : -1; + const s32 end_freq = argn > 1 ? ScalarInteger(CADDR(args)) : -1; - static const u8 MarkRom[] = - { - /* Automatically built from ../../demos/bunny/rbenchmark.r */ - #include "../build/assets/rmark.tic.dat" - }; + return s7_make_real(sc, core->api.ffts(tic, start_freq, end_freq)); + } #+end_src ** TODO The default cartridge @@ -2457,56 +2228,6 @@ headers I include might be redundant, and I will try to clean these up later. #include "api/renv.h" #+end_src -** Failed symbol registration :ARCHIVE: -This is not symbolic programming, but I wish it were! Oh, R, oh, LISP, how I -miss both of these. I can't wait to finish learning enough of C to say I can -manage my way through a complex project so that I can readily forget much of it -until I need it again. Woe unto future me, should I need it again! - -**** A failed approach to registering functions with R -A naive approach, or a "clever" approach I tried to take, is to define all of -the C functions that R can call using functions defined through a C macro and -calling them using the ~.C~ interface, however there is a much better system -built-in to R which I will use instead. - -The following use of preprocessor directives is inappropriate, as the literal -macro argument will be substituted, not evaluated at run-time. - -#+name: iterate over the R API keywords, defining each R function (erroneous) -#+begin_src C - #define defineRFn_(keyword) Rf_eval(Rf_mkString("t80."#keyword" <- function(...) .C(r_"#keyword", ...);"), R_GlobalEnv); - #define doDefineRFunction(keyword) defineRFn_(keyword) - for (int kiwi = 0; kiwi <= config->api_keywordsCount; kiwi++) { - doDefineRFunction(config->api_keywords[kiwi]); - } - #undef doDefineRFunction - #undef defineRFn_ -#+end_src - -This won't work because neither parameterized macro will evaluate the given -expressions. Using C string functions and a character buffer would allow me to -construct the R expressions dynamically, but there's no need to take this -correct, but naive, approach. Use the functionality built-in to R's C API! - -#+name: iterate over the R API keywords, defining each R function -#+begin_src C - tic_script *config = (tic_get_script(tic)); - char command_string[100]; - for (int kw = 0; kw <= config->api_keywordsCount; kw++) { - memset(command_string, '\0', sizeof('\0')); - - #define cmdstr(f, ...) f(command_string, __VA_ARGS__) - cmdstr(strcpy, "t80."); - cmdstr(strcat, config->api_keywords[kw]); - cmdstr(strcat, " <- \(...) .C(r_"); - cmdstr(strcat, config->api_keywords[kw]); - cmdstr(strcat, ", ...);"); - #undef cmdstr - - Rf_eval(Rf_mkString(command_string), R_GlobalEnv); - } -#+end_src - ** DONE Registering symbols in R from C CLOSED: [2024-10-19 Sat 22:01] "Symbols need to be registered with R from C to be used in R," is what I wrote @@ -2600,7 +2321,7 @@ Presumably, all of these functions will then be available in R as functions which have the given name (e.g. "tri") and will call ~.External("tri")~ (keeping with the example). -** Meshing the event loops of TIC-80 and R +** TODO Meshing the event loops of TIC-80 and R There is a section in the /R Extensions/ manual which focuses on meshing the event loops of R and the alternative front-end. There are two event loops in R which need special attention. @@ -2608,7 +2329,6 @@ which need special attention. *** make provision for other R events whilst waiting for input from the front-end *** ensure the front-end is not frozen out during the event loop waiting for responses from sockets - * Creating build assets at build-time from source files The is a build/assets directory in the TIC-80 sources containing DAT formatted files which are needed to include benchmarks for various scripting language @@ -3008,214 +2728,3 @@ CLOSED: [2024-10-25 Fri 19:31] } } #+end_src - -* BUGS :ARCHIVE: -- The bunny benchmark for R does not appear in the directory listing of =bunny=. -** DONE Bug-fixing the creation of new R-based cartridges -CLOSED: [2024-10-17 Thu 19:19] -*** DONE Are the demo and benchmark cartridges created correctly? -CLOSED: [2024-10-17 Thu 19:17] -What I found was that with only building for R that I can't create a new Scheme -cartridge, but with the same effect that a Lua cartridge is created. R has been -included in the build, so because the cartridge is the same as the Lua cartridge -I'm going to do a check and make sure that I haven't made a file copying error -(blindly copying the Lua demo, which I know I did at one point before I -successfully built the DAT files myself). - -I'm now confident that the DAT files are derived from my R-based source files, -and not Lua-based source files. The next step is to test if that was a -sufficient fix, indicating the problem was a file copying error (from a -different test build), or another issue. - -After testing I am certain that it was not a user error caused by copying a -Lua-based file. The =new= command is not creating an R cartridge---using the -demo or default cartridge---correctly, so I need to work out why that is with a -more involved search of the sources and then some debugging. - -*** A new cart can be created with "new r", but when going to the editor the R demo cartridge is not used (the Lua cartridge is used). - -*** DONE Is the =.id=, =.name=, or =.fileExtension= field to blame? -CLOSED: [2024-10-17 Thu 19:17] -Looking at the Scheme language integration it seems my mistake may be calling -the command with a lower-case ~r~, when I should call it with an upper-case ~R~, -if and only if the ~.name~ member of the ~const tic_script~ object in my -language integration has that casing. - -#+begin_example C - TIC_EXPORT const tic_script EXPORT_SCRIPT(R) = - { - /* The first five members of the struct have the sum total following - ,* size. */ - /* sizeof(u8) + 3 * sizeof(char *) */ - .id = 42, - .name = "r", - .fileExtension = ".r", - .projectComment = "##" -#+end_example - -Unfortunatley, as shown by the quotation, that is not the case. - -Perhaps it is the arbitrary ~.id~ I chose. How are the other IDs determined? I -looked at the IDs of every other type of TIC-80 scripting language and noted -these before sorting them. I now know what ID to give R; this should be -documented in the TIC-80 Wiki. - -- lua :: 10 -- ruby :: 11 -- js :: 12 -- moonscript :: 13 -- fennel :: 14 -- squirrel :: 15 -- wren :: 16 -- wasm :: 17 -- janet :: 18 -- scheme :: 19 -- python :: 20 -- r :: 21 - -I thought that my R integration might have an issue because of the name, but -like Moonscript the name is prefixed with a period in the file extension, so -that wasn't a problem. I don't know why I thought that might have been an issue, -but I'm only noting my thinking process here. - -It looks like R is the eleventh language added to TIC-80. There is room for five -more languages, given I saw a "maximum number of langauges" elsewhere in the -codebase set to sixteen. - -*** DONE Is =tic_add_script= rejecting the script? -CLOSED: [2024-10-17 Thu 19:16] -This procedure is used at runtime to add scripts to the ~Scripts~ array. The -macro is expanded to something much more complex, which serves to actually look -at potential script shared objects. - -#+begin_src C - void tic_add_script(const tic_script* script) - { - s32 index = 0; - FOREACH_LANG(it) - { - if(it->id == script->id || strcmp(it->name, script->name) == 0) - { - // script already exists - return; - } - - index++; - } - - if(index < MAX_SUPPORTED_LANGS) - { - Scripts[index] = script; - qsort(Scripts, index + 1, sizeof Scripts[0], compareScripts); - } - } -#+end_src - -- How is the ~Scripts~ array used? -- [X] How is ~it~ defined at runtime? ~it~ likely means "iterator", the current one. - -It doesn't appear that ~it~ is defined in /any way/. It is a literal macro -argument used in concatenation of an identifier, and no more. - -~Scripts~ is only used within =script.c=; it is only used within the functions -~tic_add_script~, ~tic_get_script~, and ~tic_scripts~. Collectively, =script.c= -defines functionality for compile-time and run-time population of the =Scripts= -array, which is used for autocompletion of certain command-line commands within -the TIC-80 console (~new~ in particular). - -~tic_get_script~ checks if the argument ~memory~ (of type =tic_mem *=) has the -same id as any of the =tic_scripts= in =Scripts=. If none of the scripts match, -either an uninitialized =tic_script= called ~empty~ is returned or the address -of the whole array is returned (effectively returning the first member of the -array). ~tic_scripts~ returns the address of the whole array forthright. - -** DONE Compilation error due to ambiguous type and storage class -CLOSED: [2024-10-17 Thu 19:20] -When compiling the API definitions in =r.c=, I experienced an issue with the -type and storage class definition of the function ~Rf_mainloop~. The compiler -doesn't know how what type or storage class to assign to the function because it -was meant as a function call outside of any other functions, which is illegal -and illogical in C, so it was merely an identifier that the C compiler didn't -know how to handle. - -A reproducible example would cover other types of constant objects as well, like -numbers and strings. - -#+begin_src C - #include - - 0; - 'a'; - "A"; - printf(); - - int main(void) { return 0 }; -#+end_src - -This will produce, similarly, the errors observed in the following journal-like entry. - -When a function call or any expression occurs /outside of a function definition -called from a call chain beginning within main/, an error will occur due to -conflicting types deriving from the compiler trying to resolve an expression of -some type as a declaration. That is, only delcarations of data types may occur -outside of function bodies, and only the main function can begin a chain of -function calls. A function call is illegal outside of these chains; expressions -of any kind other than declarations are illegal outside of these chains. -#+begin_src text - [ 10%] Building C object CMakeFiles/r.dir/src/api/r.c.o - /home/bryce/Documents/src/c/TIC-80/src/api/r.c:42:1: warning: data definition has no type or storage class - 42 | Rf_mainloop(); - | ^~~~~~~~~~~ - /home/bryce/Documents/src/c/TIC-80/src/api/r.c:42:1: warning: type defaults to ‘int’ in declaration of ‘Rf_mainloop’ [-Wimplicit-int] - /home/bryce/Documents/src/c/TIC-80/src/api/r.c:42:1: error: conflicting types for ‘Rf_mainloop’; have ‘int()’ - In file included from /home/bryce/Documents/src/c/TIC-80/src/api/r.c:33: - /usr/include/R/Rinterface.h:85:6: note: previous declaration of ‘Rf_mainloop’ with type ‘void(void)’ - 85 | void mainloop(void); - | ^~~~~~~~ -#+end_src - -** DONE Opening packages stored in any one of the R package libraries fails -CLOSED: [2024-10-17 Thu 19:23] -The definition of =R_Home= is critical when =R_OpenLibraryFile= is called. If -that identifier is not defined then there are big problems! - -Indeed, after making a small change to =initR= to ensure that =Rf_initEmbeddedR= -is called before =Rf_mainloop= and debugging =Rf_initEmbeddedR= I see the -following error. - -#+begin_example text - Thread 1 "tic80" hit Breakpoint 1, Rf_initEmbeddedR (argc=2, - argv=0x7fffffffdca0) at ../unix/Rembedded.c:60 - 60 { - (gdb) list - 55 char *argv[]= {"REmbeddedPostgres", "--gui=none", "--silent"}; - 56 Rf_initEmbeddedR(sizeof(argv)/sizeof(argv[0]), argv); - 57 */ - 58 - 59 int Rf_initEmbeddedR(int argc, char **argv) - 60 { - 61 Rf_initialize_R(argc, argv); - 62 R_Interactive = TRUE; /* Rf_initialize_R set this based on isatty */ - 63 setup_Rmainloop(); - 64 return(1); - (gdb) n - 61 Rf_initialize_R(argc, argv); - (gdb) n - Fatal error: R home directory is not defined - [Thread 0x7fff73f8f6c0 (LWP 26036) exited] - [Thread 0x7fff7cd8f6c0 (LWP 26035) exited] - [Thread 0x7fff7d78f6c0 (LWP 26034) exited] - [Thread 0x7fff7e18f6c0 (LWP 26030) exited] - [Thread 0x7fff7eb8f6c0 (LWP 26029) exited] - [Thread 0x7fff7f58f6c0 (LWP 26028) exited] - [Thread 0x7fff7ff8f6c0 (LWP 26027) exited] - [Thread 0x7fff90f8f6c0 (LWP 26026) exited] - [Thread 0x7fff9198f6c0 (LWP 26025) exited] - [Thread 0x7fff9498f6c0 (LWP 26020) exited] - [Thread 0x7fffe4ef16c0 (LWP 26016) exited] - [Thread 0x7ffff6d4a840 (LWP 26013) exited] - [Thread 0x7fff9978f6c0 (LWP 26019) exited] - [New process 26013] - [Inferior 1 (process 26013) exited with code 02] - (gdb) -#+end_example