/* * This file is part of the beastie library. * * The 'utilities' here are a mixture of S7 helper functions and * non-S7 ones. One would expect it'd be easy to separate these off * from each other, but when I tried it, that ended up requiring a * rather bigger rewrite than I expected, and having to separate * util.c into util-scheme.c and util-misc.c (or something), which * felt artificial. Since it's part of the overall design that the S7 * pointer is visible _everywhere_, there seems little real point to this. * * This file is part of Beastie * SPDX-FileCopyrightText: 2023 Norman Gray * SPDX-License-Identifier: BSD-2-Clause */ #if __GNUC__ // when used with -std=c99, gcc doesn't define (eg) vasprintf unless // this macro is defined (defining _ISO99_SOURCE happens in that case, // but isn't sufficient to pull in vasprintf) #ifndef _GNU_SOURCE #define _GNU_SOURCE #endif #endif #include #include #include #include #include #include #include "util.h" #include "config.h" #ifndef BEASTIE_DEBUG #define BEASTIE_DEBUG 0 #endif /* * Produce an error message, and exit with a non-zero status. * If the first character of 'fmt' is '!', then abort instead. */ void error_exit(const char* fmt, ...) { va_list ap; int abort_p = 0; const char* actual_fmt = fmt; va_start(ap, fmt); if (*fmt == '!') { abort_p = 1; actual_fmt = &fmt[1]; } fprintf(stderr, "beastie: "); vfprintf(stderr, actual_fmt, ap); if (abort_p) { fprintf(stderr, " [this shouldn't happen]"); } fprintf(stderr, "\n"); va_end(ap); if (abort_p) { abort(); /* flushes and closes streams */ } else { exit(1); } }; static s7_pointer prepare_beastie_error_v(s7_scheme* sc, const char* fmt, va_list ap) { char* msg; int status = vasprintf(&msg, fmt, ap); if (status < 0) { // make a noise! // (though if we're out of memory, then error_exit might fail, too) error_exit("Can't allocate space in return_beastie_error, for fmt <%s>", fmt); } s7_pointer scheme_msg = s7_make_string(sc, msg); free(msg); return scheme_msg; } s7_pointer prepare_beastie_error(s7_scheme* sc, const char* fmt, ...) { va_list ap; va_start(ap, fmt); s7_pointer msg = prepare_beastie_error_v(sc, fmt, ap); va_end(ap); return msg; } s7_pointer return_beastie_error(s7_scheme* sc, const char* fmt, ...) { va_list ap; va_start(ap, fmt); s7_pointer msg = prepare_beastie_error_v(sc, fmt, ap); va_end(ap); // this should match the behaviour of procedure beastie-error, which calls // (throw 'beastie msg alist), where the msg is a string, and // alist is an alist of possibly useful further information s7_pointer sym = s7_make_symbol(sc, "beastie"); // matches (beastie-error ...) s7_pointer arg = s7_list(sc, 2, msg, s7_nil(sc)); return s7_error(sc, sym, arg); // doesn't return: // as with s7_error, this function's return type is only a convenience } // Gobble a va_list of s7_pointers into a s7_list. // The va_list must be a list of s7_pointers terminated by NULL. static s7_pointer ap2list(va_list ap) { s7_pointer obj = va_arg(ap, s7_pointer); if (obj == NULL) { return GCP(s7_nil(S7)); } else { return GCP(s7_cons(S7, obj, ap2list(ap))); } } // The scheme_* functions are conveninence wrappers of s7_* functions. // All of these return their result wrapped in GCP(...) // Return a list containing the given values. // The arguments must be a list of s7_pointers terminated by NULL // (not terminated by '0', which can be cast to something the wrong size) s7_pointer scheme_make_list(s7_pointer v1, ...) { va_list ap; va_start(ap, v1); s7_pointer args = ap2list(ap); va_end(ap); return GCP(s7_cons(S7, v1, args)); } // this is s7_name_to_value, wrapped with a test which throws an error if the symbol is undefined s7_pointer scheme_name_to_value(const char* sym) { s7_pointer result = s7_name_to_value(S7, sym); if (s7_is_eqv(S7, result, s7_undefined(S7))) { s7_error(S7, s7_make_symbol(S7, "beastie"), s7_list(S7, 2, s7_make_string(S7, "undefined symbol: ~s"), s7_make_string(S7, sym))); } return GCP(result); } // scheme_eval("function-name", s7_pointer, s7_pointer, ..., NULL) s7_pointer scheme_eval(const char* fnname, ...) { va_list ap; s7_pointer fn = scheme_name_to_value(fnname); va_start(ap, fnname); s7_pointer args = ap2list(ap); va_end(ap); #if BEASTIE_DEBUG fprintf(stderr, "scheme_eval: (%s", fnname); for (s7_pointer a = args; !s7_is_null(S7, a); a=s7_cdr(a)) { fprintf(stderr, " "); s7_write(S7, s7_car(a), s7_current_error_port(S7)); } fprintf(stderr, ")\n"); #endif return GCP(s7_call(S7, fn, args)); } s7_pointer scheme_eval_with_let(s7_pointer let, const char* fnname, ...) { va_list ap; if (! s7_is_let(let)) { scheme_eval("beastie-error", s7_make_string(S7, "scheme_eval_with_let: ~a is not a let"), let, NULL); // NOTREACHED return NULL; } s7_pointer fn = s7_let_ref(S7, let, s7_make_symbol(S7, fnname)); if (fn == s7_undefined(S7)) { scheme_eval("beastie-error", s7_make_string(S7, "scheme_eval_with_let: ~a undefined"), s7_make_string(S7, fnname), NULL); // NOTREACHED return NULL; } va_start(ap, fnname); s7_pointer args = ap2list(ap); va_end(ap); return GCP(s7_call(S7, fn, args)); } s7_pointer scheme_symbol_value_ci(s7_pointer symbol) { const char* s = s7_symbol_name(symbol); char* token = alloca(strlen(s)+1); char* d = token; for (; *s != '\0'; d++, s++) { *d = tolower(*s); } *d = '\0'; return GCP(s7_symbol_value(S7, s7_make_symbol(S7, token))); } s7_pointer scheme_trimmed_string(const char* s) { int l = strlen(s); if (l == 0) { return GCP(s7_make_string(S7, "")); } else { return scheme_trimmed_string_with_length(s, l); } } s7_pointer scheme_trimmed_string_with_length(const char* s, int l) { s7_pointer rval; if (l <= 0) { rval = s7_make_string(S7, ""); goto finished; // JUMP OUT } const char* startp = s; const char* endp = &s[l]; assert(endp > startp); while (isspace(*startp)) { startp++; if (startp == endp || *startp == '\0') { // end of string, one way or another, so... rval = s7_make_string(S7, ""); goto finished; // JUMP OUT } } // there is at least one non-whitespace character in the string, and startp= startp); rval = s7_make_string_with_length(S7, startp, endp-startp+1); finished: return GCP(rval); } #if 0 // This is pretty close to runtime.scm:basic-repl*, done by hand. // Calling basic-repl* is neater void basic_repl(void) { s7_pointer error_handler = NULL; printf("1> "); s7_pointer in_sexp = s7_read(S7, s7_current_input_port(S7)); for (int expr_count = 2; ! s7_is_eqv(S7, in_sexp, s7_eof_object(S7)); expr_count++) { s7_call(S7, scheme_name_to_value("eval/catch/global"), s7_cons(S7, in_sexp, s7_nil(S7))); printf("%d> ", expr_count); in_sexp = s7_read(S7, s7_current_input_port(S7)); } } #endif #if 0 // We don't need this function (and if we did in future, we could // probably do it more robustly by calling out to s7 (read)), but keep // it around just in case. // Read a single expression from stdin, and return it as a char*. // The string must not be freed. const char* scheme_read_expr_from_stdin(void) { return scheme_read_expr(&getchar); } // Read a single expression from an input source given as a pointer to // a function int(*)(void), and return it as a char*. // The string must not be freed. const char* scheme_read_expr(int (*read_char)(void)) { static StringBuilder builder = NULL; if (builder == NULL) { builder = make_stringbuilder(); } else { stringbuilder_reset(builder); } enum { in_expr, // looking for a matching close-bracket in_string, // looking for a closing '"' (and spotting \") skipping_comment, // looking for a newline skipping_whitespace, // skipping multiple blanks scanning_initial_token, // looking for whitespace or '(' scanning_initial_whitespace } state = scanning_initial_whitespace; int brace_level = 0; char n_unget = 0; int unget_char = 0; #define UNGETC(c) if (n_unget != 0) { \ fprintf(stderr, "Two characters of pushback in scheme_read_expr!\n"); \ return NULL; \ } else { \ unget_char = c; \ n_unget = 1; \ } #define GETC (n_unget==0 ? (*read_char)() : (n_unget=0, unget_char)) int still_scanning = 1; while (still_scanning) { int c = GETC; if (c == EOF) return NULL; int do_append_c = 1; switch (state) { case in_expr: switch (c) { case '(': brace_level++; break; case ')': if (brace_level == 0) { fprintf(stderr, "stray right bracket (ignored)\n"); do_append_c = 0; } else { brace_level--; if (brace_level == 0) still_scanning = 0; } break; case '"': state = in_string; break; case ';': c = ' '; state = skipping_comment; break; case '\n': case '\r': c = ' '; state = skipping_whitespace; break; default: if (isspace(c)) { c = ' '; state = skipping_whitespace; } // otherwise do nothing, but leave do_append_c==1, so the character is appended break; } break; case in_string: switch (c) { case '\\': // the only thing we have to escape is '"', // to make sure that "...\"..." doesn't end the string stringbuilder_append_c(builder, '\\'); c = GETC; // doesn't matter what it is break; case '"': if (brace_level == 0) { // this is an initial token still_scanning = 0; } else { state = in_expr; } break; } break; case skipping_comment: if (c == '\n' || c == '\r') { state = skipping_whitespace; } do_append_c = 0; break; case skipping_whitespace: if (isspace(c)) { do_append_c = 0; } else { UNGETC(c); do_append_c = 0; state = in_expr; } break; case scanning_initial_whitespace: if (isspace(c)) { do_append_c = 0; } else { switch (c) { case '(': state = in_expr; brace_level++; break; case ')': fprintf(stderr, "stray right bracket (ignored)\n"); do_append_c = 0; break; case '"': state = in_string; break; case ';': state = skipping_comment; do_append_c = 0; break; default: state = scanning_initial_token; break; } } break; case scanning_initial_token: if (isspace(c)) { still_scanning = 0; do_append_c = 0; } else { switch (c) { case '(': UNGETC(c); still_scanning = 0; break; case ')': fprintf(stderr, "stray right bracket (ignored)\n"); do_append_c = 0; still_scanning = 0; break; case '"': UNGETC(c); still_scanning = 0; } } break; default: assert(0); } if (do_append_c) stringbuilder_append_c(builder, c); } stringbuilder_terminate(builder); return builder->buf; } #endif // Convenience function, for debugging // s7w(string, s7_pointer, string) displays the s7_pointer prefixed and suffixed. // s7w4 is a four-argument version, which has a fourth argument which // is non-zero if the output is to go to stderr void s7w4(const char* before, s7_pointer s, const char* after, int stderr_p) { if (before) fprintf((stderr_p ? stderr : stdout), "%s", before); s7_display(S7, s, (stderr_p ? s7_current_error_port(S7) : s7_current_output_port(S7))); if (after) fprintf((stderr_p ? stderr : stdout), "%s", after); } void s7w(const char* before, s7_pointer s, const char* after) { s7w4(before, s, after, 0); } // scheme_printf("scheme format string", s7_pointer..., NULL): // call scheme FORMAT with the arguments. // (this probably makes s7w() somewhat redundant) void scheme_printf(const char* fmt, ...) { s7_pointer fn = scheme_name_to_value("format"); va_list ap; va_start(ap, fmt); s7_pointer args = ap2list(ap); va_end(ap); (void) s7_call(S7, fn, s7_cons(S7, s7_t(S7), s7_cons(S7, s7_make_string(S7, fmt), args))); } /* * Scan the input available from the scanner, until we find the * character 'endwith' at brace level 0. The 'flags' argument is a * mask. If `SCAN_INCLUDE_LAST` is set, then include the matching * 'endwith' character, otherwise leave it on the input. */ static const StringBuilder scan_to_matching_char_sb(int (*in)(void*), // read a character from a scanner void* scanner, // the scanner int startline, // the start line, for error reporting const char* startwith, // to be initially added to the result const char endwith, unsigned int flags) { StringBuilder build_buffer = make_stringbuilder(); if (startwith) stringbuilder_append_s(build_buffer, startwith); int level = 0; char keep_going = 1; char unexpected_eof = 0; while (keep_going) { int c = (*in)(scanner); //printf("c=%c (0x%x)\n", c, c); if (c <= 0) { unexpected_eof = 1; keep_going = 0; } else if (c == '\\') { // escape the following character -- pass both through stringbuilder_append_c(build_buffer, '\\'); c = (*in)(scanner); if (c > 0) { stringbuilder_append_c(build_buffer, c); } else { unexpected_eof = 1; keep_going = 0; } } else if (c == endwith && level == 0) { if (flags & SCAN_INCLUDE_LAST) stringbuilder_append_c(build_buffer, c); keep_going = 0; } else { switch (c) { case '{': level++; break; case '}': level--; break; } stringbuilder_append_c(build_buffer, c); } } if (unexpected_eof) { const char fmt[] = "Unexpected end of input in balanced braces starting on line %d"; // four-byte ints occupy a maximum of 10 digits static const size_t buflen = sizeof(fmt)+10; char buf[buflen]; snprintf(buf, buflen, fmt, startline); // throw an error, so that we break off the parse // (as long as we want this to be callable from a lex-foo // program, we can't reply on beastie-error being present) s7_error(S7, s7_make_symbol(S7, "beastie"), s7_cons(S7, s7_make_string(S7, buf), s7_nil(S7))); } return build_buffer; } // Wrap scan_to_matching_char_sb for s7 s7_pointer scan_to_matching_char(int (*in)(void*), // read a character from a scanner void* scanner, // the scanner int startline, // the start line, for error reporting const char* startwith, // to be initially added to the result const char endwith, unsigned int flags) { StringBuilder sb = scan_to_matching_char_sb(in, scanner, startline, startwith, endwith, flags); s7_pointer rval = GCP(s7_make_string_with_length(S7, sb->buf, sb->len)); stringbuilder_free(sb); return rval; } // StringBuilder functions #define SBVALID(b) assert(b->buf != NULL && b->len <= b->alloc) StringBuilder make_stringbuilder_with_size(size_t initial_alloc) { StringBuilder b; if ((b = (StringBuilder)malloc(sizeof(struct append_buffer))) == NULL) { error_exit("Can't allocate space for append_buffer"); } b->alloc = initial_alloc; b->len = 0; if ((b->buf = (char*)malloc(b->alloc)) == NULL) { error_exit("Can't allocate space for append_buffer"); } SBVALID(b); return b; } StringBuilder make_stringbuilder(void) { return make_stringbuilder_with_size(128); } // StringBuilder make_stringbuilder_with_content(const char* s, size_t slen) // { // StringBuilder b; // if ((b = (StringBuilder)malloc(sizeof(struct append_buffer))) == NULL) { // error_exit("Can't allocate space for append_buffer"); // } // size_t blen = 64; // while (blen <= slen) { // if (blen >= SIZE_MAX/2) error_exit("slen=%zd too big: maximum is %zd", slen, SIZE_MAX/2); // blen *= 2; // } // if ((b->buf = (char*)malloc(blen)) == NULL) { // error_exit("Can't allocate %zd bytes for append_buffer", blen); // } // b->alloc = blen; // if (s != NULL && slen > 0) { // memcpy(b->buf, s, slen); // b->len = slen; // } else { // b->len = 0; // } // SBVALID(b); // return b; // } // append a character to the buffer StringBuilder stringbuilder_append_c(StringBuilder buf, char b) { if (buf->len >= buf->alloc) { // shouldn't ever be '>', but... buf->alloc *= 2; if ((buf->buf = (char*)realloc((void*)buf->buf, buf->alloc)) == NULL) { error_exit("Can't reallocate space for stringbuilder_append_c"); } } buf->buf[buf->len++] = b; SBVALID(buf); return buf; } // append a string+length to the buffer StringBuilder stringbuilder_append_sn(StringBuilder buf, const char* b, size_t blen) { size_t newlen = buf->len + blen; if (newlen >= buf->alloc) { while (buf->alloc < newlen) { buf->alloc *= 2; } if ((buf->buf = (char*)realloc((void*)buf->buf, buf->alloc)) == NULL) { error_exit("Can't reallocate space for append_to_buffer_n"); } } memcpy(&(buf->buf[buf->len]), b, blen); buf->len += blen; SBVALID(buf); return buf; } // append one stringbuilder to another StringBuilder stringbuilder_append_sb(StringBuilder buf, StringBuilder extra) { return stringbuilder_append_sn(buf, extra->buf, extra->len); } // append a null-terminated string to the buffer StringBuilder stringbuilder_append_s(StringBuilder buf, const char* s) { return stringbuilder_append_sn(buf, s, strlen(s)); } StringBuilder stringbuilder_printf(StringBuilder buf, const char* fmt, ...) { char* result; va_list ap; va_start(ap, fmt); if (vasprintf(&result, fmt, ap) < 0) { // make a noise about this error_exit("Can't allocate space in stringbuilder_printf, for fmt <%s>", fmt); } va_end(ap); StringBuilder rval = stringbuilder_append_s(buf, result); free(result); return rval; } #if 0 // more roundabout, but... is vasprintf available everywhere? StringBuilder stringbuilder_printf(StringBuilder buf, const char* fmt, ...) { int written_ok; do { va_list ap; va_start(ap, fmt); size_t avail = buf->alloc - buf->len; size_t nwritten = vsnprintf(&buf->buf[buf->len], avail, fmt, ap); va_end(ap); if (nwritten <= avail) { written_ok = 1; buf->len += nwritten; } else { buf->alloc *= 2; if ((buf->buf = (char*)realloc((void*)buf->buf, buf->alloc)) == NULL) { error_exit("Can't reallocate space for stringbuilder_printf"); } written_ok = 0; } } while (! written_ok); SBVALID(buf); return buf; } #endif // Append a '\0' to the buffer, without incrementing the length StringBuilder stringbuilder_terminate(StringBuilder buf) { stringbuilder_append_c(buf, '\0'); buf->len--; return buf; } // reset the buffer's length to zero, without doing any re/deallocation StringBuilder stringbuilder_reset(StringBuilder buf) { buf->len = 0; return buf; } void stringbuilder_free(StringBuilder buf) { if (buf != NULL) { assert(buf->buf != NULL); free(buf->buf); free(buf); } }