2019-08-26 17:20:50 -04:00
|
|
|
// Copyright 2008 Jeff Bezanson
|
|
|
|
// Copyright 2019 Lassi Kortela
|
|
|
|
// SPDX-License-Identifier: BSD-3-Clause
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// This Scheme only runs on machines with the following characteristics:
|
|
|
|
//
|
|
|
|
// - supports integer word sizes of 8, 16, 32, and 64 bits
|
|
|
|
// - uses unsigned and signed 2's complement representations
|
|
|
|
// - all pointer types are the same size
|
|
|
|
// - there is an integer type with the same size as a pointer
|
|
|
|
//
|
|
|
|
// Some features require:
|
|
|
|
//
|
|
|
|
// - IEEE 754 single- and double-precision floating point
|
|
|
|
//
|
|
|
|
// We assume the LP64 convention for 64-bit platforms.
|
2019-08-26 17:20:50 -04:00
|
|
|
|
2019-08-27 03:20:30 -04:00
|
|
|
#ifdef __DJGPP__
|
|
|
|
#include "scheme_compiler_djgpp.h"
|
|
|
|
#endif
|
|
|
|
|
2019-08-26 17:42:13 -04:00
|
|
|
#ifdef __DMC__
|
2019-08-26 17:46:45 -04:00
|
|
|
#include "scheme_compiler_dmc.h"
|
2019-08-26 17:42:13 -04:00
|
|
|
#endif
|
|
|
|
|
|
|
|
#ifdef __GNUC__
|
2019-08-26 17:46:45 -04:00
|
|
|
#include "scheme_compiler_gnuc.h"
|
2019-08-26 17:42:13 -04:00
|
|
|
#endif
|
|
|
|
|
|
|
|
#ifdef _MSC_VER
|
2019-08-26 17:46:45 -04:00
|
|
|
#include "scheme_compiler_msc.h"
|
2019-08-26 17:42:13 -04:00
|
|
|
#endif
|
|
|
|
|
|
|
|
#ifdef __WATCOMC__
|
2019-08-26 17:46:45 -04:00
|
|
|
#include "scheme_compiler_watcomc.h"
|
2019-08-26 17:42:13 -04:00
|
|
|
#endif
|
|
|
|
|
2019-10-14 04:58:20 -04:00
|
|
|
#undef ALIGN
|
2019-08-26 18:25:11 -04:00
|
|
|
#define ALIGN(x, sz) (((x) + (sz - 1)) & (-sz))
|
2019-08-26 17:20:50 -04:00
|
|
|
|
|
|
|
extern double D_PNAN;
|
|
|
|
extern double D_NNAN;
|
|
|
|
extern double D_PINF;
|
|
|
|
extern double D_NINF;
|
|
|
|
extern float F_PNAN;
|
|
|
|
extern float F_NNAN;
|
|
|
|
extern float F_PINF;
|
|
|
|
extern float F_NINF;
|
|
|
|
|
|
|
|
//// #include "utils.h"
|
|
|
|
|
|
|
|
char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base);
|
|
|
|
int str2int(char *str, size_t len, int64_t *res, uint32_t base);
|
|
|
|
int isdigit_base(char c, int base);
|
|
|
|
|
|
|
|
//// #include "utf8.h"
|
|
|
|
|
|
|
|
extern int locale_is_utf8;
|
|
|
|
|
|
|
|
#ifdef _WIN32
|
|
|
|
extern int wcwidth(uint32_t);
|
|
|
|
#endif
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// is c the start of a utf8 sequence?
|
2019-08-26 17:20:50 -04:00
|
|
|
#define isutf(c) (((c)&0xC0) != 0x80)
|
|
|
|
|
|
|
|
#define UEOF ((uint32_t)-1)
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// convert UTF-8 data to wide character
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_toucs(uint32_t *dest, size_t sz, const char *src, size_t srcsz);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// the opposite conversion
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_toutf8(char *dest, size_t sz, const uint32_t *src, size_t srcsz);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// single character to UTF-8, returns # bytes written
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_wc_toutf8(char *dest, uint32_t ch);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// character number to byte offset
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_offset(const char *str, size_t charnum);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// byte offset to character number
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_charnum(const char *s, size_t offset);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// return next character, updating an index variable
|
2019-08-26 17:20:50 -04:00
|
|
|
uint32_t u8_nextchar(const char *s, size_t *i);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// next character without NUL character terminator
|
2019-08-26 17:20:50 -04:00
|
|
|
uint32_t u8_nextmemchar(const char *s, size_t *i);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// move to next character
|
2019-08-26 17:20:50 -04:00
|
|
|
void u8_inc(const char *s, size_t *i);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// move to previous character
|
2019-08-26 17:20:50 -04:00
|
|
|
void u8_dec(const char *s, size_t *i);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// returns length of next utf-8 sequence
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_seqlen(const char *s);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// returns the # of bytes needed to encode a certain character
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_charlen(uint32_t ch);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// computes the # of bytes needed to encode a WC string as UTF-8
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_codingsize(uint32_t *wcstr, size_t n);
|
|
|
|
|
|
|
|
char read_escape_control_char(char c);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// assuming src points to the character after a backslash, read an
|
|
|
|
// escape sequence, storing the result in dest and returning the number of
|
|
|
|
// input characters processed
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_read_escape_sequence(const char *src, size_t ssz, uint32_t *dest);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// given a wide character, convert it to an ASCII escape sequence stored in
|
|
|
|
// buf, where buf is "sz" bytes. returns the number of characters output.
|
|
|
|
// sz must be at least 3.
|
2019-08-26 17:20:50 -04:00
|
|
|
int u8_escape_wchar(char *buf, size_t sz, uint32_t ch);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// convert a string "src" containing escape sequences to UTF-8
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_unescape(char *buf, size_t sz, const char *src);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// convert UTF-8 "src" to escape sequences.
|
|
|
|
//
|
|
|
|
// sz is buf size in bytes. must be at least 12.
|
|
|
|
//
|
|
|
|
// if escape_quotes is nonzero, quote characters will be escaped.
|
|
|
|
//
|
|
|
|
// if ascii is nonzero, the output is 7-bit ASCII, no UTF-8 survives.
|
|
|
|
//
|
|
|
|
// starts at src[*pi], updates *pi to point to the first unprocessed
|
|
|
|
// byte of the input.
|
|
|
|
//
|
|
|
|
// end is one more than the last allowable value of *pi.
|
|
|
|
//
|
|
|
|
// returns number of bytes placed in buf, including a NUL terminator.
|
|
|
|
//
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi,
|
|
|
|
size_t end, int escape_quotes, int ascii);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// utility predicates used by the above
|
2019-08-26 17:20:50 -04:00
|
|
|
int octal_digit(char c);
|
|
|
|
int hex_digit(char c);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// return a pointer to the first occurrence of ch in s, or NULL if not
|
|
|
|
// found. character index of found character returned in *charn.
|
2019-08-26 17:20:50 -04:00
|
|
|
char *u8_strchr(const char *s, uint32_t ch, size_t *charn);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// same as the above, but searches a buffer of a given size instead of
|
|
|
|
// a NUL-terminated string.
|
2019-08-26 17:20:50 -04:00
|
|
|
char *u8_memchr(const char *s, uint32_t ch, size_t sz, size_t *charn);
|
|
|
|
|
|
|
|
char *u8_memrchr(const char *s, uint32_t ch, size_t sz);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// count the number of characters in a UTF-8 string
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_strlen(const char *s);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// number of columns occupied by a string
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_strwidth(const char *s);
|
|
|
|
|
|
|
|
int u8_is_locale_utf8(const char *locale);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// printf where the format string and arguments may be in UTF-8.
|
|
|
|
// you can avoid this function and just use ordinary printf() if the current
|
|
|
|
// locale is UTF-8.
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t u8_vprintf(const char *fmt, va_list ap);
|
|
|
|
size_t u8_printf(const char *fmt, ...);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// determine whether a sequence of bytes is valid UTF-8. length is in bytes
|
2019-08-26 17:20:50 -04:00
|
|
|
int u8_isvalid(const char *str, int length);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// reverse a UTF-8 string. len is length in bytes. dest and src must both
|
|
|
|
// be allocated to at least len+1 bytes. returns 1 for error, 0 otherwise
|
2019-08-26 17:20:50 -04:00
|
|
|
int u8_reverse(char *dest, char *src, size_t len);
|
|
|
|
|
2019-09-29 05:32:57 -04:00
|
|
|
//// char.c
|
|
|
|
|
|
|
|
value_t builtin_ascii_codepoint_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_char_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_control_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_display_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_whitespace_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_space_or_tab_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_punctuation_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_upper_case_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_lower_case_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_alphanumeric_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_numeric_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_alphabetic_p(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_upcase(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_downcase(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_open_bracket(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_close_bracket(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_mirror_bracket(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_control_to_display(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_display_to_control(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_nth_digit(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_nth_upper_case(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_nth_lower_case(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_digit_value(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_upper_case_value(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_ascii_lower_case_value(value_t *args, uint32_t nargs);
|
|
|
|
|
2019-08-26 17:20:50 -04:00
|
|
|
//// #include "ios.h"
|
|
|
|
|
|
|
|
// this flag controls when data actually moves out to the underlying I/O
|
|
|
|
// channel. memory streams are a special case of this where the data
|
|
|
|
// never moves out.
|
|
|
|
typedef enum { bm_none, bm_line, bm_block, bm_mem } bufmode_t;
|
|
|
|
|
|
|
|
typedef enum { bst_none, bst_rd, bst_wr } bufstate_t;
|
|
|
|
|
|
|
|
#define IOS_INLSIZE 54
|
|
|
|
#define IOS_BUFSIZE 131072
|
|
|
|
|
|
|
|
struct ios {
|
|
|
|
bufmode_t bm;
|
|
|
|
|
|
|
|
// the state only indicates where the underlying file position is relative
|
|
|
|
// to the buffer. reading: at the end. writing: at the beginning.
|
|
|
|
// in general, you can do any operation in any state.
|
|
|
|
bufstate_t state;
|
|
|
|
|
|
|
|
int errcode;
|
|
|
|
|
|
|
|
char *buf; // start of buffer
|
|
|
|
size_t maxsize; // space allocated to buffer
|
|
|
|
size_t size; // length of valid data in buf, >=ndirty
|
|
|
|
size_t bpos; // current position in buffer
|
|
|
|
size_t ndirty; // # bytes at &buf[0] that need to be written
|
|
|
|
|
|
|
|
off_t fpos; // cached file pos
|
|
|
|
size_t lineno; // current line number
|
|
|
|
|
|
|
|
// pointer-size integer to support platforms where it might have
|
|
|
|
// to be a pointer
|
|
|
|
long fd;
|
|
|
|
|
|
|
|
unsigned char readonly : 1;
|
|
|
|
unsigned char ownbuf : 1;
|
|
|
|
unsigned char ownfd : 1;
|
|
|
|
unsigned char _eof : 1;
|
|
|
|
|
|
|
|
// this means you can read, seek back, then read the same data
|
|
|
|
// again any number of times. usually only true for files and strings.
|
|
|
|
unsigned char rereadable : 1;
|
|
|
|
|
|
|
|
char local[IOS_INLSIZE];
|
|
|
|
};
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// low-level interface functions
|
2019-08-26 17:20:50 -04:00
|
|
|
size_t ios_read(struct ios *s, char *dest, size_t n);
|
|
|
|
size_t ios_readall(struct ios *s, char *dest, size_t n);
|
2019-08-28 06:30:07 -04:00
|
|
|
size_t ios_write(struct ios *s, const char *data, size_t n);
|
2019-08-26 17:20:50 -04:00
|
|
|
off_t ios_seek(struct ios *s, off_t pos); // absolute seek
|
|
|
|
off_t ios_seek_end(struct ios *s);
|
|
|
|
off_t ios_skip(struct ios *s, off_t offs); // relative seek
|
|
|
|
off_t ios_pos(struct ios *s); // get current position
|
|
|
|
size_t ios_trunc(struct ios *s, size_t size);
|
|
|
|
int ios_eof(struct ios *s);
|
|
|
|
int ios_flush(struct ios *s);
|
|
|
|
void ios_close(struct ios *s);
|
|
|
|
char *ios_takebuf(struct ios *s,
|
|
|
|
size_t *psize); // release buffer to caller
|
|
|
|
// set buffer space to use
|
|
|
|
int ios_setbuf(struct ios *s, char *buf, size_t size, int own);
|
|
|
|
int ios_bufmode(struct ios *s, bufmode_t mode);
|
|
|
|
void ios_set_readonly(struct ios *s);
|
|
|
|
size_t ios_copy(struct ios *to, struct ios *from, size_t nbytes);
|
|
|
|
size_t ios_copyall(struct ios *to, struct ios *from);
|
|
|
|
size_t ios_copyuntil(struct ios *to, struct ios *from, char delim);
|
|
|
|
// ensure at least n bytes are buffered if possible. returns # available.
|
|
|
|
size_t ios_readprep(struct ios *from, size_t n);
|
|
|
|
// void ios_lock(struct ios *s);
|
|
|
|
// int struct iosrylock(struct ios *s);
|
|
|
|
// int ios_unlock(struct ios *s);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// stream creation
|
2019-08-26 17:20:50 -04:00
|
|
|
struct ios *ios_file(struct ios *s, char *fname, int rd, int wr, int create,
|
|
|
|
int trunc);
|
|
|
|
struct ios *ios_mem(struct ios *s, size_t initsize);
|
|
|
|
struct ios *ios_str(struct ios *s, char *str);
|
|
|
|
struct ios *ios_static_buffer(struct ios *s, char *buf, size_t sz);
|
|
|
|
struct ios *ios_fd(struct ios *s, long fd, int isfile, int own);
|
|
|
|
// todo: ios_socket
|
|
|
|
extern struct ios *ios_stdin;
|
|
|
|
extern struct ios *ios_stdout;
|
|
|
|
extern struct ios *ios_stderr;
|
|
|
|
void ios_init_stdstreams();
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// high-level functions - output
|
2019-08-26 17:20:50 -04:00
|
|
|
int ios_putnum(struct ios *s, char *data, uint32_t type);
|
|
|
|
int ios_putint(struct ios *s, int n);
|
|
|
|
int ios_pututf8(struct ios *s, uint32_t wc);
|
2019-08-26 18:17:52 -04:00
|
|
|
int ios_putstringz(struct ios *s, char *str, int do_write_nulterm);
|
2019-08-26 17:20:50 -04:00
|
|
|
int ios_printf(struct ios *s, const char *format, ...);
|
|
|
|
int ios_vprintf(struct ios *s, const char *format, va_list args);
|
|
|
|
|
|
|
|
void hexdump(struct ios *dest, const char *buffer, size_t len,
|
|
|
|
size_t startoffs);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// high-level stream functions - input
|
2019-08-26 17:20:50 -04:00
|
|
|
int ios_getnum(struct ios *s, char *data, uint32_t type);
|
|
|
|
int ios_getutf8(struct ios *s, uint32_t *pwc);
|
|
|
|
int ios_peekutf8(struct ios *s, uint32_t *pwc);
|
|
|
|
int ios_ungetutf8(struct ios *s, uint32_t wc);
|
|
|
|
int ios_getstringz(struct ios *dest, struct ios *src);
|
|
|
|
int ios_getstringn(struct ios *dest, struct ios *src, size_t nchars);
|
|
|
|
int ios_getline(struct ios *s, char **pbuf, size_t *psz);
|
|
|
|
char *ios_readline(struct ios *s);
|
|
|
|
|
|
|
|
// discard data buffered for reading
|
|
|
|
void ios_purge(struct ios *s);
|
|
|
|
|
|
|
|
// seek by utf8 sequence increments
|
|
|
|
int ios_nextutf8(struct ios *s);
|
|
|
|
int ios_prevutf8(struct ios *s);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// stdio-style functions
|
2019-08-26 17:20:50 -04:00
|
|
|
#define IOS_EOF (-1)
|
|
|
|
int ios_putc(int c, struct ios *s);
|
|
|
|
// wint_t ios_putwc(struct ios *s, wchar_t wc);
|
|
|
|
int ios_getc(struct ios *s);
|
|
|
|
int ios_peekc(struct ios *s);
|
|
|
|
// wint_t ios_getwc(struct ios *s);
|
|
|
|
int ios_ungetc(int c, struct ios *s);
|
|
|
|
// wint_t ios_ungetwc(struct ios *s, wint_t wc);
|
|
|
|
#define ios_puts(str, s) ios_write(s, str, strlen(str))
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// With memory streams, mixed reads and writes are equivalent to performing
|
|
|
|
// sequences of *p++, as either an lvalue or rvalue. File streams behave
|
|
|
|
// similarly, but other streams might not support this. Using unbuffered
|
|
|
|
// mode makes this more predictable.
|
|
|
|
//
|
|
|
|
// Note on "unget" functions:
|
|
|
|
// There are two kinds of functions here: those that operate on sized
|
|
|
|
// blocks of bytes and those that operate on logical units like "character"
|
|
|
|
// or "integer". The "unget" functions only work on logical units. There
|
|
|
|
// is no "unget n bytes". You can only do an unget after a matching get.
|
|
|
|
// However, data pushed back by an unget is available to all read operations.
|
|
|
|
// The reason for this is that unget is defined in terms of its effect on
|
|
|
|
// the underlying buffer (namely, it rebuffers data as if it had been
|
|
|
|
// buffered but not read yet). IOS reserves the right to perform large block
|
|
|
|
// operations directly, bypassing the buffer. In such a case data was
|
|
|
|
// never buffered, so "rebuffering" has no meaning (i.e. there is no
|
|
|
|
// correspondence between the buffer and the physical stream).
|
|
|
|
//
|
|
|
|
// Single-bit I/O is able to write partial bytes ONLY IF the stream supports
|
|
|
|
// seeking. Also, line buffering is not well-defined in the context of
|
|
|
|
// single-bit I/O, so it might not do what you expect.
|
|
|
|
//
|
|
|
|
// implementation notes:
|
|
|
|
// in order to know where we are in a file, we must ensure the buffer
|
|
|
|
// is only populated from the underlying stream starting with p==buf.
|
|
|
|
//
|
|
|
|
// to switch from writing to reading: flush, set p=buf, cnt=0
|
|
|
|
// to switch from reading to writing: seek backwards cnt bytes, p=buf, cnt=0
|
|
|
|
//
|
|
|
|
// when writing: buf starts at curr. physical stream pos, p - buf is how
|
|
|
|
// many bytes we've written logically. cnt==0
|
|
|
|
//
|
|
|
|
// dirty == (bitpos>0 && state==iost_wr), EXCEPT right after switching from
|
|
|
|
// reading to writing, where we might be in the middle of a byte without
|
|
|
|
// having changed it.
|
|
|
|
//
|
|
|
|
// to write a bit: if !dirty, read up to maxsize-(p-buf) into buffer, then
|
|
|
|
// seek back by the same amount (undo it). write onto those bits. now set
|
|
|
|
// the dirty bit. in this state, we can bit-read up to the end of the byte,
|
|
|
|
// then formally switch to the read state using flush.
|
|
|
|
//
|
|
|
|
// design points:
|
|
|
|
// - data-source independence, including memory streams
|
|
|
|
// - expose buffer to user, allow user-owned buffers
|
|
|
|
// - allow direct I/O, don't always go through buffer
|
|
|
|
// - buffer-internal seeking. makes seeking back 1-2 bytes very fast,
|
|
|
|
// and makes it possible for sockets where it otherwise wouldn't be
|
|
|
|
// - tries to allow switching between reading and writing
|
|
|
|
// - support 64-bit and large files
|
|
|
|
// - efficient, low-latency buffering
|
|
|
|
// - special support for utf8
|
|
|
|
// - type-aware functions with byte-order swapping service
|
|
|
|
// - position counter for meaningful data offsets with sockets
|
|
|
|
//
|
|
|
|
// theory of operation:
|
|
|
|
//
|
|
|
|
// the buffer is a view of part of a file/stream. you can seek, read, and
|
|
|
|
// write around in it as much as you like, as if it were just a string.
|
|
|
|
//
|
|
|
|
// we keep track of the part of the buffer that's invalid (written to).
|
|
|
|
// we remember whether the position of the underlying stream is aligned
|
|
|
|
// with the end of the buffer (reading mode) or the beginning (writing mode).
|
|
|
|
//
|
|
|
|
// based on this info, we might have to seek back before doing a flush.
|
|
|
|
//
|
|
|
|
// as optimizations, we do no writing if the buffer isn't "dirty", and we
|
|
|
|
// do no reading if the data will only be overwritten.
|
2019-08-26 17:20:50 -04:00
|
|
|
|
|
|
|
//// #include "socket.h"
|
|
|
|
|
|
|
|
#ifndef _WIN32
|
|
|
|
void closesocket(int fd);
|
|
|
|
#endif
|
|
|
|
|
|
|
|
int open_tcp_port(short portno);
|
|
|
|
int open_any_tcp_port(short *portno);
|
|
|
|
int open_any_udp_port(short *portno);
|
|
|
|
int connect_to_host(char *hostname, short portno);
|
|
|
|
int sendall(int sockfd, char *buffer, int bufLen, int flags);
|
|
|
|
int readall(int sockfd, char *buffer, int bufLen, int flags);
|
|
|
|
int socket_ready(int sock);
|
|
|
|
|
|
|
|
//// #include "timefuncs.h"
|
|
|
|
|
|
|
|
uint64_t i64time();
|
|
|
|
void sleep_ms(int ms);
|
|
|
|
void timeparts(int32_t *buf, double t);
|
|
|
|
|
|
|
|
//// #include "hashing.h"
|
|
|
|
|
|
|
|
uintptr_t nextipow2(uintptr_t i);
|
|
|
|
uint32_t int32hash(uint32_t a);
|
|
|
|
uint64_t int64hash(uint64_t key);
|
|
|
|
uint32_t int64to32hash(uint64_t key);
|
|
|
|
#ifdef BITS64
|
|
|
|
#define inthash int64hash
|
|
|
|
#else
|
|
|
|
#define inthash int32hash
|
|
|
|
#endif
|
|
|
|
uint64_t memhash(const char *buf, size_t n);
|
|
|
|
uint32_t memhash32(const char *buf, size_t n);
|
|
|
|
|
|
|
|
//// #include "htable.h"
|
|
|
|
|
|
|
|
#define HT_N_INLINE 32
|
|
|
|
|
|
|
|
struct htable {
|
|
|
|
size_t size;
|
|
|
|
void **table;
|
|
|
|
void *_space[HT_N_INLINE];
|
|
|
|
};
|
|
|
|
|
|
|
|
// define this to be an invalid key/value
|
|
|
|
#define HT_NOTFOUND ((void *)1)
|
|
|
|
|
|
|
|
// initialize and free
|
|
|
|
struct htable *htable_new(struct htable *h, size_t size);
|
|
|
|
void htable_free(struct htable *h);
|
|
|
|
|
|
|
|
// clear and (possibly) change size
|
|
|
|
void htable_reset(struct htable *h, size_t sz);
|
|
|
|
|
|
|
|
//// #include "bitvector.h"
|
|
|
|
|
|
|
|
// a mask with n set lo or hi bits
|
|
|
|
#define lomask(n) (uint32_t)((((uint32_t)1) << (n)) - 1)
|
|
|
|
#define himask(n) (~lomask(32 - n))
|
|
|
|
#define ONES32 ((uint32_t)0xffffffff)
|
|
|
|
|
|
|
|
uint32_t bitreverse(uint32_t x);
|
|
|
|
|
|
|
|
uint32_t *bitvector_new(uint64_t n, int initzero);
|
|
|
|
uint32_t *bitvector_resize(uint32_t *b, uint64_t oldsz, uint64_t newsz,
|
|
|
|
int initzero);
|
|
|
|
size_t bitvector_nwords(uint64_t nbits);
|
|
|
|
void bitvector_set(uint32_t *b, uint64_t n, uint32_t c);
|
|
|
|
uint32_t bitvector_get(uint32_t *b, uint64_t n);
|
|
|
|
|
|
|
|
uint32_t bitvector_next(uint32_t *b, uint64_t n0, uint64_t n);
|
|
|
|
|
|
|
|
void bitvector_shr(uint32_t *b, size_t n, uint32_t s);
|
|
|
|
void bitvector_shr_to(uint32_t *dest, uint32_t *b, size_t n, uint32_t s);
|
|
|
|
void bitvector_shl(uint32_t *b, size_t n, uint32_t s);
|
|
|
|
void bitvector_shl_to(uint32_t *dest, uint32_t *b, size_t n, uint32_t s,
|
2019-08-26 18:17:52 -04:00
|
|
|
int scrap);
|
2019-08-26 17:20:50 -04:00
|
|
|
void bitvector_fill(uint32_t *b, uint32_t offs, uint32_t c, uint32_t nbits);
|
|
|
|
void bitvector_copy(uint32_t *dest, uint32_t doffs, uint32_t *a,
|
|
|
|
uint32_t aoffs, uint32_t nbits);
|
|
|
|
void bitvector_not(uint32_t *b, uint32_t offs, uint32_t nbits);
|
|
|
|
void bitvector_not_to(uint32_t *dest, uint32_t doffs, uint32_t *a,
|
|
|
|
uint32_t aoffs, uint32_t nbits);
|
|
|
|
void bitvector_reverse(uint32_t *b, uint32_t offs, uint32_t nbits);
|
|
|
|
void bitvector_reverse_to(uint32_t *dest, uint32_t *src, uint32_t soffs,
|
|
|
|
uint32_t nbits);
|
|
|
|
void bitvector_and_to(uint32_t *dest, uint32_t doffs, uint32_t *a,
|
|
|
|
uint32_t aoffs, uint32_t *b, uint32_t boffs,
|
|
|
|
uint32_t nbits);
|
|
|
|
void bitvector_or_to(uint32_t *dest, uint32_t doffs, uint32_t *a,
|
|
|
|
uint32_t aoffs, uint32_t *b, uint32_t boffs,
|
|
|
|
uint32_t nbits);
|
|
|
|
void bitvector_xor_to(uint32_t *dest, uint32_t doffs, uint32_t *a,
|
|
|
|
uint32_t aoffs, uint32_t *b, uint32_t boffs,
|
|
|
|
uint32_t nbits);
|
|
|
|
uint64_t bitvector_count(uint32_t *b, uint32_t offs, uint64_t nbits);
|
|
|
|
uint32_t bitvector_any0(uint32_t *b, uint32_t offs, uint32_t nbits);
|
|
|
|
uint32_t bitvector_any1(uint32_t *b, uint32_t offs, uint32_t nbits);
|
|
|
|
|
|
|
|
//// #include "os.h"
|
|
|
|
|
|
|
|
void path_to_dirname(char *path);
|
|
|
|
void get_cwd(char *buf, size_t size);
|
|
|
|
int set_cwd(char *buf);
|
|
|
|
char *get_exename(char *buf, size_t size);
|
|
|
|
int os_path_exists(const char *path);
|
|
|
|
void os_setenv(const char *name, const char *value);
|
|
|
|
|
2019-08-28 04:11:55 -04:00
|
|
|
value_t builtin_os_open_directory(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_os_read_directory(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_os_close_directory(value_t *args, uint32_t nargs);
|
|
|
|
void os_init(void);
|
|
|
|
|
2019-08-26 17:20:50 -04:00
|
|
|
//// #include "random.h"
|
|
|
|
|
|
|
|
#define random() genrand_int32()
|
|
|
|
#define srandom(n) init_genrand(n)
|
|
|
|
double rand_double();
|
|
|
|
float rand_float();
|
|
|
|
double randn();
|
|
|
|
void randomize();
|
|
|
|
uint32_t genrand_int32();
|
|
|
|
void init_genrand(uint32_t s);
|
|
|
|
uint64_t i64time();
|
|
|
|
|
|
|
|
//// #include "llt.h"
|
|
|
|
|
|
|
|
void llt_init();
|
|
|
|
|
|
|
|
//// #include "ieee754.h"
|
|
|
|
|
|
|
|
union ieee754_float {
|
|
|
|
float f;
|
|
|
|
|
|
|
|
struct {
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
|
|
|
|
unsigned int negative : 1;
|
|
|
|
unsigned int exponent : 8;
|
|
|
|
unsigned int mantissa : 23;
|
|
|
|
#endif
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
|
|
|
|
unsigned int mantissa : 23;
|
|
|
|
unsigned int exponent : 8;
|
|
|
|
unsigned int negative : 1;
|
|
|
|
#endif
|
|
|
|
} ieee;
|
|
|
|
};
|
|
|
|
|
|
|
|
#define IEEE754_FLOAT_BIAS 0x7f
|
|
|
|
|
|
|
|
union ieee754_double {
|
|
|
|
double d;
|
|
|
|
|
|
|
|
struct {
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
|
|
|
|
unsigned int negative : 1;
|
|
|
|
unsigned int exponent : 11;
|
|
|
|
unsigned int mantissa0 : 20;
|
|
|
|
unsigned int mantissa1 : 32;
|
|
|
|
#endif
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
|
|
|
|
unsigned int mantissa1 : 32;
|
|
|
|
unsigned int mantissa0 : 20;
|
|
|
|
unsigned int exponent : 11;
|
|
|
|
unsigned int negative : 1;
|
|
|
|
#endif
|
|
|
|
} ieee;
|
|
|
|
};
|
|
|
|
|
|
|
|
#define IEEE754_DOUBLE_BIAS 0x3ff
|
|
|
|
|
|
|
|
union ieee854_long_double {
|
|
|
|
long double d;
|
|
|
|
|
|
|
|
struct {
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
|
|
|
|
unsigned int negative : 1;
|
|
|
|
unsigned int exponent : 15;
|
|
|
|
unsigned int empty : 16;
|
|
|
|
unsigned int mantissa0 : 32;
|
|
|
|
unsigned int mantissa1 : 32;
|
|
|
|
#endif
|
|
|
|
#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
|
|
|
|
unsigned int mantissa1 : 32;
|
|
|
|
unsigned int mantissa0 : 32;
|
|
|
|
unsigned int exponent : 15;
|
|
|
|
unsigned int negative : 1;
|
|
|
|
unsigned int empty : 16;
|
|
|
|
#endif
|
|
|
|
} ieee;
|
|
|
|
};
|
|
|
|
|
|
|
|
#define IEEE854_LONG_DOUBLE_BIAS 0x3fff
|
|
|
|
|
|
|
|
//// #include "flisp.h"
|
|
|
|
|
|
|
|
struct cons {
|
|
|
|
value_t car;
|
|
|
|
value_t cdr;
|
|
|
|
};
|
|
|
|
|
|
|
|
struct symbol {
|
|
|
|
uintptr_t flags;
|
|
|
|
value_t binding; // global value binding
|
|
|
|
struct fltype *type;
|
|
|
|
uint32_t hash;
|
|
|
|
void *dlcache; // dlsym address
|
|
|
|
// below fields are private
|
|
|
|
struct symbol *left;
|
|
|
|
struct symbol *right;
|
|
|
|
union {
|
|
|
|
char name[1];
|
|
|
|
void *_pad; // ensure field aligned to pointer size
|
|
|
|
};
|
|
|
|
};
|
|
|
|
|
|
|
|
struct gensym {
|
|
|
|
value_t isconst;
|
|
|
|
value_t binding; // global value binding
|
|
|
|
struct fltype *type;
|
|
|
|
uint32_t id;
|
|
|
|
};
|
|
|
|
|
|
|
|
#define TAG_NUM 0x0
|
|
|
|
#define TAG_CPRIM 0x1
|
|
|
|
#define TAG_FUNCTION 0x2
|
|
|
|
#define TAG_VECTOR 0x3
|
|
|
|
#define TAG_NUM1 0x4
|
|
|
|
#define TAG_CVALUE 0x5
|
|
|
|
#define TAG_SYM 0x6
|
|
|
|
#define TAG_CONS 0x7
|
|
|
|
#define UNBOUND ((value_t)0x1) // an invalid value
|
|
|
|
#define TAG_FWD UNBOUND
|
|
|
|
#define tag(x) ((x)&0x7)
|
|
|
|
#define ptr(x) ((void *)((x) & (~(value_t)0x7)))
|
|
|
|
#define tagptr(p, t) (((value_t)(p)) | (t))
|
|
|
|
#define fixnum(x) ((value_t)(((ufixnum_t)(fixnum_t)(x)) << 2))
|
|
|
|
#define numval(x) (((fixnum_t)(x)) >> 2)
|
|
|
|
#ifdef BITS64
|
|
|
|
#define fits_fixnum(x) (((x) >> 61) == 0 || (~((x) >> 61)) == 0)
|
|
|
|
#else
|
|
|
|
#define fits_fixnum(x) (((x) >> 29) == 0 || (~((x) >> 29)) == 0)
|
|
|
|
#endif
|
|
|
|
#define fits_bits(x, b) (((x) >> (b - 1)) == 0 || (~((x) >> (b - 1))) == 0)
|
|
|
|
#define uintval(x) (((unsigned int)(x)) >> 3)
|
|
|
|
#define builtin(n) tagptr((((int)n) << 3), TAG_FUNCTION)
|
|
|
|
#define iscons(x) (tag(x) == TAG_CONS)
|
|
|
|
#define issymbol(x) (tag(x) == TAG_SYM)
|
|
|
|
#define isfixnum(x) (((x)&3) == TAG_NUM)
|
|
|
|
#define bothfixnums(x, y) ((((x) | (y)) & 3) == TAG_NUM)
|
|
|
|
#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && uintval(x) <= OP_ASET)
|
|
|
|
#define isvector(x) (tag(x) == TAG_VECTOR)
|
|
|
|
#define iscvalue(x) (tag(x) == TAG_CVALUE)
|
|
|
|
#define iscprim(x) (tag(x) == TAG_CPRIM)
|
|
|
|
#define selfevaluating(x) (tag(x) < 6)
|
|
|
|
// comparable with ==
|
|
|
|
#define eq_comparable(a, b) (!(((a) | (b)) & 1))
|
|
|
|
#define eq_comparablep(a) (!((a)&1))
|
|
|
|
// doesn't lead to other values
|
|
|
|
#define leafp(a) (((a)&3) != 3)
|
|
|
|
|
|
|
|
#define isforwarded(v) (((value_t *)ptr(v))[0] == TAG_FWD)
|
|
|
|
#define forwardloc(v) (((value_t *)ptr(v))[1])
|
|
|
|
#define forward(v, to) \
|
|
|
|
do { \
|
|
|
|
(((value_t *)ptr(v))[0] = TAG_FWD); \
|
|
|
|
(((value_t *)ptr(v))[1] = to); \
|
|
|
|
} while (0)
|
|
|
|
|
|
|
|
#define vector_size(v) (((size_t *)ptr(v))[0] >> 2)
|
|
|
|
#define vector_setsize(v, n) (((size_t *)ptr(v))[0] = ((n) << 2))
|
|
|
|
#define vector_elt(v, i) (((value_t *)ptr(v))[1 + (i)])
|
|
|
|
#define vector_grow_amt(x) ((x) < 8 ? 5 : 6 * ((x) >> 3))
|
|
|
|
// functions ending in _ are unsafe, faster versions
|
|
|
|
#define car_(v) (((struct cons *)ptr(v))->car)
|
|
|
|
#define cdr_(v) (((struct cons *)ptr(v))->cdr)
|
|
|
|
#define car(v) (tocons((v), "car")->car)
|
|
|
|
#define cdr(v) (tocons((v), "cdr")->cdr)
|
|
|
|
#define fn_bcode(f) (((value_t *)ptr(f))[0])
|
|
|
|
#define fn_vals(f) (((value_t *)ptr(f))[1])
|
|
|
|
#define fn_env(f) (((value_t *)ptr(f))[2])
|
|
|
|
#define fn_name(f) (((value_t *)ptr(f))[3])
|
|
|
|
|
|
|
|
#define set(s, v) (((struct symbol *)ptr(s))->binding = (v))
|
|
|
|
#define setc(s, v) \
|
|
|
|
do { \
|
|
|
|
((struct symbol *)ptr(s))->flags |= 1; \
|
|
|
|
((struct symbol *)ptr(s))->binding = (v); \
|
|
|
|
} while (0)
|
|
|
|
#define isconstant(s) ((s)->flags & 0x1)
|
|
|
|
#define iskeyword(s) ((s)->flags & 0x2)
|
|
|
|
#define symbol_value(s) (((struct symbol *)ptr(s))->binding)
|
|
|
|
#define ismanaged(v) \
|
|
|
|
((((unsigned char *)ptr(v)) >= fromspace) && \
|
|
|
|
(((unsigned char *)ptr(v)) < fromspace + heapsize))
|
|
|
|
#define isgensym(x) (issymbol(x) && ismanaged(x))
|
|
|
|
|
|
|
|
#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS << 3))
|
|
|
|
#define isclosure(x) isfunction(x)
|
|
|
|
#define iscbuiltin(x) \
|
|
|
|
(iscvalue(x) && (cv_class((struct cvalue *)ptr(x)) == builtintype))
|
|
|
|
|
|
|
|
void fl_gc_handle(value_t *pv);
|
|
|
|
void fl_free_gc_handles(uint32_t n);
|
|
|
|
|
|
|
|
// utility for iterating over all arguments in a builtin
|
|
|
|
// i=index, i0=start index, arg = var for each arg, args = arg array
|
|
|
|
// assumes "nargs" is the argument count
|
|
|
|
#define FOR_ARGS(i, i0, arg, args) \
|
|
|
|
for (i = i0; ((size_t)i) < nargs && ((arg = args[i]) || 1); i++)
|
|
|
|
|
|
|
|
#define N_BUILTINS ((int)N_OPCODES)
|
|
|
|
|
|
|
|
extern value_t FL_NIL, FL_T, FL_F, FL_EOF;
|
|
|
|
|
|
|
|
#define FL_UNSPECIFIED FL_T
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// read, eval, print main entry points
|
2019-08-26 17:20:50 -04:00
|
|
|
value_t fl_read_sexpr(value_t f);
|
|
|
|
void fl_print(struct ios *f, value_t v);
|
|
|
|
value_t fl_toplevel_eval(value_t expr);
|
|
|
|
value_t fl_apply(value_t f, value_t l);
|
|
|
|
value_t fl_applyn(uint32_t n, value_t f, ...);
|
|
|
|
|
2019-10-13 17:42:04 -04:00
|
|
|
void display_defaults(struct ios *f, value_t v);
|
|
|
|
void write_simple_defaults(struct ios *f, value_t v);
|
|
|
|
void write_defaults_indent(struct ios *f, value_t v);
|
|
|
|
|
2019-08-26 17:20:50 -04:00
|
|
|
extern value_t printprettysym, printreadablysym, printwidthsym;
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// object model manipulation
|
2019-08-26 17:20:50 -04:00
|
|
|
value_t fl_cons(value_t a, value_t b);
|
|
|
|
value_t fl_list2(value_t a, value_t b);
|
|
|
|
value_t fl_listn(size_t n, ...);
|
|
|
|
value_t symbol(const char *str);
|
|
|
|
char *symbol_name(value_t v);
|
|
|
|
int fl_is_keyword_name(const char *str, size_t len);
|
|
|
|
value_t alloc_vector(size_t n, int init);
|
|
|
|
size_t llength(value_t v);
|
|
|
|
value_t fl_compare(value_t a, value_t b); // -1, 0, or 1
|
|
|
|
value_t fl_equal(value_t a, value_t b); // T or nil
|
|
|
|
int equal_lispvalue(value_t a, value_t b);
|
|
|
|
uintptr_t hash_lispvalue(value_t a);
|
|
|
|
int isnumtok_base(char *tok, value_t *pval, int base);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// safe casts
|
2019-08-26 17:20:50 -04:00
|
|
|
struct cons *tocons(value_t v, char *fname);
|
|
|
|
struct symbol *tosymbol(value_t v, char *fname);
|
|
|
|
fixnum_t tofixnum(value_t v, char *fname);
|
|
|
|
char *tostring(value_t v, char *fname);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// error handling
|
2019-08-26 17:20:50 -04:00
|
|
|
struct fl_readstate {
|
|
|
|
struct htable backrefs;
|
|
|
|
struct htable gensyms;
|
|
|
|
value_t source;
|
|
|
|
struct fl_readstate *prev;
|
|
|
|
};
|
|
|
|
|
|
|
|
struct fl_exception_context {
|
|
|
|
jmp_buf buf;
|
|
|
|
uint32_t sp;
|
|
|
|
uint32_t frame;
|
|
|
|
uint32_t ngchnd;
|
|
|
|
struct fl_readstate *rdst;
|
|
|
|
struct fl_exception_context *prev;
|
|
|
|
};
|
|
|
|
|
|
|
|
extern struct fl_exception_context *fl_ctx;
|
|
|
|
extern uint32_t fl_throwing_frame;
|
|
|
|
extern value_t fl_lasterror;
|
|
|
|
|
|
|
|
#define FL_TRY_EXTERN \
|
|
|
|
struct fl_exception_context _ctx; \
|
|
|
|
int l__tr, l__ca; \
|
|
|
|
fl_savestate(&_ctx); \
|
|
|
|
fl_ctx = &_ctx; \
|
|
|
|
if (!setjmp(_ctx.buf)) \
|
|
|
|
for (l__tr = 1; l__tr; l__tr = 0, (void)(fl_ctx = fl_ctx->prev))
|
|
|
|
|
|
|
|
#define FL_CATCH_EXTERN \
|
|
|
|
else for (l__ca = 1; l__ca; l__ca = 0, fl_restorestate(&_ctx))
|
|
|
|
|
|
|
|
void fl_savestate(struct fl_exception_context *_ctx);
|
|
|
|
void fl_restorestate(struct fl_exception_context *_ctx);
|
|
|
|
extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
|
|
|
|
extern value_t UnboundError;
|
|
|
|
|
|
|
|
struct cvtable {
|
|
|
|
void (*print)(value_t self, struct ios *f);
|
|
|
|
void (*relocate)(value_t oldv, value_t newv);
|
|
|
|
void (*finalize)(value_t self);
|
|
|
|
void (*print_traverse)(value_t self);
|
|
|
|
};
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// functions needed to implement the value interface (struct cvtable)
|
2019-08-26 17:20:50 -04:00
|
|
|
typedef enum {
|
|
|
|
T_INT8,
|
|
|
|
T_UINT8,
|
|
|
|
T_INT16,
|
|
|
|
T_UINT16,
|
|
|
|
T_INT32,
|
|
|
|
T_UINT32,
|
|
|
|
T_INT64,
|
|
|
|
T_UINT64,
|
|
|
|
T_FLOAT,
|
|
|
|
T_DOUBLE
|
|
|
|
} numerictype_t;
|
|
|
|
|
|
|
|
#define N_NUMTYPES ((int)T_DOUBLE + 1)
|
|
|
|
|
2019-08-27 03:20:30 -04:00
|
|
|
#ifdef BITS64
|
|
|
|
#define T_FIXNUM T_INT64
|
|
|
|
#else
|
|
|
|
#define T_FIXNUM T_INT32
|
|
|
|
#endif
|
|
|
|
|
2019-08-26 17:20:50 -04:00
|
|
|
value_t relocate_lispvalue(value_t v);
|
|
|
|
void print_traverse(value_t v);
|
|
|
|
void fl_print_chr(char c, struct ios *f);
|
|
|
|
void fl_print_str(char *s, struct ios *f);
|
|
|
|
void fl_print_child(struct ios *f, value_t v);
|
|
|
|
|
|
|
|
typedef int (*cvinitfunc_t)(struct fltype *, value_t, void *);
|
|
|
|
|
|
|
|
struct fltype {
|
|
|
|
value_t type;
|
|
|
|
numerictype_t numtype;
|
|
|
|
size_t size;
|
|
|
|
size_t elsz;
|
|
|
|
struct cvtable *vtable;
|
|
|
|
struct fltype *eltype; // for arrays
|
|
|
|
struct fltype *artype; // (array this)
|
|
|
|
int marked;
|
|
|
|
cvinitfunc_t init;
|
|
|
|
};
|
|
|
|
|
|
|
|
struct cvalue {
|
|
|
|
struct fltype *type;
|
|
|
|
void *data;
|
|
|
|
size_t len; // length of *data in bytes
|
|
|
|
union {
|
|
|
|
value_t parent; // optional
|
|
|
|
char _space[1]; // variable size
|
|
|
|
};
|
|
|
|
};
|
|
|
|
|
|
|
|
#define CVALUE_NWORDS 4
|
|
|
|
|
|
|
|
struct cprim {
|
|
|
|
struct fltype *type;
|
|
|
|
char _space[1];
|
|
|
|
};
|
|
|
|
|
|
|
|
struct function {
|
|
|
|
value_t bcode;
|
|
|
|
value_t vals;
|
|
|
|
value_t env;
|
|
|
|
value_t name;
|
|
|
|
};
|
|
|
|
|
|
|
|
#define CPRIM_NWORDS 2
|
|
|
|
#define MAX_INL_SIZE 384
|
|
|
|
|
|
|
|
#define CV_OWNED_BIT 0x1
|
|
|
|
#define CV_PARENT_BIT 0x2
|
|
|
|
#define owned(cv) ((uintptr_t)(cv)->type & CV_OWNED_BIT)
|
|
|
|
#define hasparent(cv) ((uintptr_t)(cv)->type & CV_PARENT_BIT)
|
|
|
|
#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
|
|
|
|
#define cv_class(cv) ((struct fltype *)(((uintptr_t)(cv)->type) & ~3))
|
|
|
|
#define cv_len(cv) ((cv)->len)
|
|
|
|
#define cv_type(cv) (cv_class(cv)->type)
|
|
|
|
#define cv_data(cv) ((cv)->data)
|
|
|
|
#define cv_isstr(cv) (cv_class(cv)->eltype == bytetype)
|
|
|
|
#define cv_isPOD(cv) (cv_class(cv)->init != NULL)
|
|
|
|
|
|
|
|
#define cvalue_data(v) cv_data((struct cvalue *)ptr(v))
|
|
|
|
#define cvalue_len(v) cv_len((struct cvalue *)ptr(v))
|
|
|
|
#define value2c(type, v) ((type)cv_data((struct cvalue *)ptr(v)))
|
|
|
|
|
|
|
|
#define valid_numtype(v) ((v) < N_NUMTYPES)
|
|
|
|
#define cp_class(cp) ((cp)->type)
|
|
|
|
#define cp_type(cp) (cp_class(cp)->type)
|
|
|
|
#define cp_numtype(cp) (cp_class(cp)->numtype)
|
|
|
|
#define cp_data(cp) (&(cp)->_space[0])
|
|
|
|
|
|
|
|
// WARNING: multiple evaluation!
|
|
|
|
#define cptr(v) \
|
|
|
|
(iscprim(v) ? cp_data((struct cprim *)ptr(v)) \
|
|
|
|
: cv_data((struct cvalue *)ptr(v)))
|
|
|
|
|
|
|
|
typedef value_t (*builtin_t)(value_t *, uint32_t);
|
|
|
|
|
|
|
|
extern value_t QUOTE;
|
|
|
|
extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
|
|
|
|
extern value_t int64sym, uint64sym;
|
|
|
|
extern value_t longsym, ulongsym, bytesym, wcharsym;
|
|
|
|
extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym,
|
|
|
|
pointersym;
|
|
|
|
extern value_t stringtypesym, wcstringtypesym, emptystringsym;
|
|
|
|
extern value_t unionsym, floatsym, doublesym;
|
|
|
|
extern struct fltype *bytetype, *wchartype;
|
|
|
|
extern struct fltype *stringtype, *wcstringtype;
|
|
|
|
extern struct fltype *builtintype;
|
|
|
|
|
|
|
|
value_t cvalue(struct fltype *type, size_t sz);
|
|
|
|
void add_finalizer(struct cvalue *cv);
|
|
|
|
void cv_autorelease(struct cvalue *cv);
|
|
|
|
void cv_pin(struct cvalue *cv);
|
|
|
|
size_t ctype_sizeof(value_t type, int *palign);
|
|
|
|
value_t cvalue_copy(value_t v);
|
|
|
|
value_t cvalue_from_data(struct fltype *type, void *data, size_t sz);
|
|
|
|
value_t cvalue_from_ref(struct fltype *type, void *ptr, size_t sz,
|
|
|
|
value_t parent);
|
|
|
|
value_t cbuiltin(char *name, builtin_t f);
|
|
|
|
size_t cvalue_arraylen(value_t v);
|
|
|
|
value_t size_wrap(size_t sz);
|
|
|
|
size_t toulong(value_t n, char *fname);
|
|
|
|
value_t cvalue_string(size_t sz);
|
|
|
|
value_t cvalue_static_cstring(const char *str);
|
|
|
|
value_t string_from_cstr(const char *str);
|
|
|
|
value_t string_from_cstrn(const char *str, size_t n);
|
|
|
|
int fl_isstring(value_t v);
|
|
|
|
int fl_isnumber(value_t v);
|
|
|
|
int fl_isgensym(value_t v);
|
|
|
|
int fl_isiostream(value_t v);
|
|
|
|
struct ios *fl_toiostream(value_t v, const char *fname);
|
|
|
|
value_t cvalue_compare(value_t a, value_t b);
|
|
|
|
int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname);
|
|
|
|
|
|
|
|
void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz);
|
|
|
|
|
|
|
|
struct fltype *get_type(value_t t);
|
|
|
|
struct fltype *get_array_type(value_t eltype);
|
|
|
|
struct fltype *define_opaque_type(value_t sym, size_t sz,
|
|
|
|
struct cvtable *vtab, cvinitfunc_t init);
|
|
|
|
|
2019-10-13 19:27:33 -04:00
|
|
|
value_t mk_double(double n);
|
|
|
|
value_t mk_float(float n);
|
2019-08-26 17:20:50 -04:00
|
|
|
value_t mk_uint32(uint32_t n);
|
|
|
|
value_t mk_uint64(uint64_t n);
|
|
|
|
value_t mk_wchar(int32_t n);
|
|
|
|
value_t return_from_uint64(uint64_t Uaccum);
|
|
|
|
value_t return_from_int64(int64_t Saccum);
|
|
|
|
|
|
|
|
numerictype_t effective_numerictype(double r);
|
|
|
|
double conv_to_double(void *data, numerictype_t tag);
|
|
|
|
void conv_from_double(void *data, double d, numerictype_t tag);
|
|
|
|
int64_t conv_to_int64(void *data, numerictype_t tag);
|
|
|
|
uint64_t conv_to_uint64(void *data, numerictype_t tag);
|
|
|
|
int32_t conv_to_int32(void *data, numerictype_t tag);
|
|
|
|
uint32_t conv_to_uint32(void *data, numerictype_t tag);
|
|
|
|
#ifdef BITS64
|
|
|
|
#define conv_to_long conv_to_int64
|
|
|
|
#define conv_to_ulong conv_to_uint64
|
|
|
|
#else
|
|
|
|
#define conv_to_long conv_to_int32
|
|
|
|
#define conv_to_ulong conv_to_uint32
|
|
|
|
#endif
|
|
|
|
|
|
|
|
struct builtinspec {
|
|
|
|
char *name;
|
|
|
|
builtin_t fptr;
|
|
|
|
};
|
|
|
|
|
|
|
|
void assign_global_builtins(struct builtinspec *b);
|
|
|
|
|
2019-08-26 17:37:20 -04:00
|
|
|
// builtins
|
2019-08-26 17:20:50 -04:00
|
|
|
value_t fl_hash(value_t *args, uint32_t nargs);
|
|
|
|
value_t cvalue_byte(value_t *args, uint32_t nargs);
|
|
|
|
value_t cvalue_wchar(value_t *args, uint32_t nargs);
|
|
|
|
|
|
|
|
void fl_init(size_t initial_heapsize);
|
|
|
|
int fl_load_boot_image(void);
|
|
|
|
|
|
|
|
//// #include "buf.h"
|
|
|
|
|
|
|
|
struct buf {
|
|
|
|
size_t cap;
|
|
|
|
size_t fill;
|
|
|
|
size_t scan;
|
|
|
|
size_t mark;
|
|
|
|
char *bytes;
|
|
|
|
};
|
|
|
|
|
|
|
|
struct buf *buf_new(void);
|
|
|
|
char *buf_resb(struct buf *buf, size_t nbyte);
|
|
|
|
void buf_put_ios(struct buf *buf, struct ios *ios);
|
|
|
|
void buf_putc(struct buf *buf, int c);
|
|
|
|
void buf_putb(struct buf *buf, const void *bytes, size_t nbyte);
|
|
|
|
void buf_puts(struct buf *buf, const char *s);
|
|
|
|
void buf_putu(struct buf *buf, uint64_t u);
|
|
|
|
void buf_free(struct buf *buf);
|
|
|
|
|
|
|
|
int buf_scan_end(struct buf *buf);
|
|
|
|
int buf_scan_byte(struct buf *buf, int byte);
|
|
|
|
int buf_scan_bag(struct buf *buf, const char *bag);
|
|
|
|
int buf_scan_bag_not(struct buf *buf, const char *bag);
|
|
|
|
int buf_scan_while(struct buf *buf, const char *bag);
|
|
|
|
int buf_scan_while_not(struct buf *buf, const char *bag);
|
|
|
|
void buf_scan_mark(struct buf *buf);
|
|
|
|
int buf_scan_equals(struct buf *buf, const char *s);
|
|
|
|
|
|
|
|
//// #include "argcount.h"
|
|
|
|
|
|
|
|
void argcount(const char *fname, uint32_t nargs, uint32_t c);
|
|
|
|
|
|
|
|
//// #include "env.h"
|
|
|
|
|
|
|
|
const char *env_get_os_name(void);
|
|
|
|
|
|
|
|
value_t builtin_environment_stack(value_t *args, uint32_t nargs);
|
|
|
|
|
2019-10-14 12:15:45 -04:00
|
|
|
extern char env_build_cc[];
|
|
|
|
extern char env_build_cflags[];
|
|
|
|
extern char env_build_lflags[];
|
|
|
|
extern char env_build_revision[];
|
|
|
|
extern char env_build_date[];
|
|
|
|
|
|
|
|
extern char env_release[];
|
|
|
|
extern char env_release_date[];
|
|
|
|
|
2019-08-26 17:20:50 -04:00
|
|
|
//// #include "libraries.h"
|
|
|
|
|
|
|
|
value_t builtin_import(value_t *args, uint32_t nargs);
|
|
|
|
|
|
|
|
//// #include "builtins.h"
|
|
|
|
|
2019-10-13 17:43:31 -04:00
|
|
|
value_t builtin_features(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_version_alist(value_t *args, uint32_t nargs);
|
|
|
|
|
2019-08-26 17:20:50 -04:00
|
|
|
value_t builtin_pid(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_parent_pid(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_process_group(value_t *args, uint32_t nargs);
|
|
|
|
|
|
|
|
value_t builtin_user_effective_gid(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_user_effective_uid(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_user_real_gid(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_user_real_uid(value_t *args, uint32_t nargs);
|
|
|
|
|
|
|
|
value_t builtin_term_init(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_term_exit(value_t *args, uint32_t nargs);
|
|
|
|
|
|
|
|
value_t builtin_spawn(value_t *args, uint32_t nargs);
|
|
|
|
|
|
|
|
value_t builtin_read_ini_file(value_t *args, uint32_t nargs);
|
|
|
|
|
|
|
|
value_t builtin_color_name_to_rgb24(value_t *args, uint32_t nargs);
|
|
|
|
|
2019-09-02 12:46:27 -04:00
|
|
|
value_t builtin_file_exists(value_t *args, uint32_t nargs);
|
|
|
|
|
2019-08-28 05:49:10 -04:00
|
|
|
value_t builtin_get_environment_variables(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_get_environment_variable(value_t *args, uint32_t nargs);
|
|
|
|
value_t builtin_set_environment_variable(value_t *args, uint32_t nargs);
|
|
|
|
|
2019-08-26 17:20:50 -04:00
|
|
|
//// #include "stringfuncs.h"
|
|
|
|
|
|
|
|
value_t fl_stringp(value_t *args, uint32_t nargs);
|
|
|
|
value_t fl_string_reverse(value_t *args, uint32_t nargs);
|
2019-08-28 09:18:37 -04:00
|
|
|
value_t builtin_string_split(value_t *args, uint32_t nargs);
|
2019-08-26 17:20:50 -04:00
|
|
|
value_t fl_string_sub(value_t *args, uint32_t nargs);
|
2019-08-26 17:42:13 -04:00
|
|
|
|
2019-08-28 05:45:21 -04:00
|
|
|
// util.c
|
|
|
|
|
|
|
|
struct accum {
|
|
|
|
value_t list;
|
|
|
|
value_t tail;
|
|
|
|
};
|
|
|
|
|
|
|
|
#define ACCUM_EMPTY \
|
|
|
|
{ \
|
|
|
|
.list = FL_NIL, .tail = FL_NIL \
|
|
|
|
}
|
|
|
|
|
2019-10-13 17:43:00 -04:00
|
|
|
void accum_init(struct accum *accum);
|
2019-08-28 05:45:21 -04:00
|
|
|
void accum_elt(struct accum *accum, value_t elt);
|
|
|
|
void accum_pair(struct accum *accum, value_t a, value_t d);
|
|
|
|
void accum_name_value(struct accum *accum, const char *name, value_t value);
|
2019-10-13 17:43:00 -04:00
|
|
|
void accum_name_value1(struct accum *accum, const char *name, value_t value);
|
2019-08-28 05:45:21 -04:00
|
|
|
|
2019-10-13 15:56:45 -04:00
|
|
|
struct sv_accum {
|
|
|
|
char **vec;
|
|
|
|
size_t cap;
|
|
|
|
size_t fill;
|
|
|
|
};
|
|
|
|
|
|
|
|
void sv_accum_init(struct sv_accum *accum);
|
|
|
|
void sv_accum_strdup(struct sv_accum *accum, const char *str);
|
|
|
|
|
2019-08-27 03:31:31 -04:00
|
|
|
// boot_image.c
|
|
|
|
|
|
|
|
extern char boot_image[];
|
|
|
|
extern const size_t boot_image_size;
|
|
|
|
|
2019-08-26 17:42:13 -04:00
|
|
|
#include "htableh_inc.h"
|