void osdep_writefile( word w_fd, word w_buf, word w_cnt, word w_offset )
{
int fd = nativeint( w_fd );
FILE *fp;
char *buf;
size_t nbytes, res, offset;
#ifdef USE_STDIO
check_standard_filedes();
#endif
assert( fd >= 0 && fd < num_fds );
if (fdarray[fd].fp == 0) {
globals[ G_RESULT ] = fixnum(-1);
return;
}
fp = fdarray[fd].fp;
buf = string_data(w_buf);
nbytes = nativeint(w_cnt);
offset = nativeint(w_offset);
res = fwrite( buf+offset, 1, nbytes, fp );
if (res < nbytes && ferror(fp))
globals[G_RESULT] = fixnum(-1);
else
globals[G_RESULT] = fixnum(res);
fflush(fp); /* Larceny does its own buffering. */
}
void osdep_readfile( word w_fd, word w_buf, word w_cnt )
{
int fd = nativeint( w_fd );
FILE *fp;
char *buf, *resp;
size_t nbytes, res;
#ifdef USE_STDIO
check_standard_filedes();
#endif
assert( fd >= 0 && fd < num_fds );
if (fdarray[fd].fp == 0) {
globals[ G_RESULT ] = fixnum(-1);
return;
}
fp = fdarray[fd].fp;
buf = string_data(w_buf);
nbytes = nativeint(w_cnt);
if ((fdarray[fd].mode & (MODE_TEXT|MODE_INTERMITTENT)) == (MODE_TEXT|MODE_INTERMITTENT))
{
// On some platforms, certainly Win32, fread() is not line buffered on stdin.
resp = fgets( buf, nbytes, fp );
res = (resp == 0 ? 0 : strlen(buf));
}
else
res = fread( buf, 1, nbytes, fp );
if (res == 0 && ferror(fp))
globals[G_RESULT] = fixnum(-1);
else
globals[G_RESULT]= fixnum(res);
}
void osdep_lseekfile( word w_fd, word w_offset, word w_whence )
{
int fd = nativeint( w_fd );
off_t offset = nativeint( w_offset );
int whence_code = nativeint( w_whence );
off_t whence;
FILE *fp;
int res;
if ( whence_code == 0 )
whence = SEEK_SET;
else if ( whence_code == 1 )
whence = SEEK_CUR;
else if ( whence_code == 2 )
whence = SEEK_END;
else assert( 0 );
#ifdef USE_STDIO
check_standard_filedes();
#endif
assert( fd >= 0 && fd < num_fds );
if (fdarray[fd].fp == 0) {
globals[ G_RESULT ] = fixnum(-1);
return;
}
fp = fdarray[fd].fp;
res = fseek( fp, offset, whence );
globals[G_RESULT]= fixnum(res);
}
static value_t fl_length(value_t *args, u_int32_t nargs)
{
argcount("length", nargs, 1);
value_t a = args[0];
cvalue_t *cv;
if (isvector(a)) {
return fixnum(vector_size(a));
}
else if (iscprim(a)) {
cv = (cvalue_t*)ptr(a);
if (cp_class(cv) == bytetype)
return fixnum(1);
else if (cp_class(cv) == wchartype)
return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
}
else if (iscvalue(a)) {
cv = (cvalue_t*)ptr(a);
if (cv_class(cv)->eltype != NULL)
return size_wrap(cvalue_arraylen(a));
}
else if (a == FL_NIL) {
return fixnum(0);
}
else if (iscons(a)) {
return fixnum(llength(a));
}
type_error("length", "sequence", a);
}
value_t fl_current_module_counter(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
{
static uint32_t fallback_counter = 0;
if (jl_current_module == NULL)
return fixnum(++fallback_counter);
else
return fixnum(jl_module_next_counter(jl_current_module));
}
/* remove() is in Standard C */
void osdep_unlinkfile( word w_fn )
{
char *fn = string2asciiz( w_fn );
if (fn == 0) {
globals[ G_RESULT ] = fixnum( -1 );
return;
}
globals[ G_RESULT ] = remove( fn ) ? fixnum(-1) : fixnum(0);
}
void osdep_openfile( word w_fn, word w_flags, word w_mode )
{
char *fn = string2asciiz( w_fn );
int i, flags = nativeint( w_flags );
char newflags[5];
char *p = newflags;
int mode = 0;
FILE *fp;
#ifdef USE_STDIO
check_standard_filedes();
#endif
/* This is a real thin pipe for the semantics ... */
if (flags & 0x01) { *p++ = 'r'; mode |= MODE_READ; }
if (flags & 0x02) { *p++ = 'w'; mode |= MODE_WRITE; }
if (flags & 0x04) *p++ = '+';
if (flags & 0x20) { *p++ = 'b'; mode |= MODE_BINARY; }
*p = '\0';
if (!(mode & MODE_BINARY))
mode |= MODE_TEXT;
if (fn == 0) {
globals[ G_RESULT ] = fixnum( -1 );
return;
}
fp = fopen( fn, newflags );
if (fp == NULL) {
globals[ G_RESULT ] = fixnum( -1 );
return;
}
/* Now register the file and return the table index. */
for ( i=0 ; i < num_fds && fdarray[i].fp != 0 ; i++ )
;
if (i == num_fds) {
int n = max(2*num_fds,5);
struct finfo *narray = (struct finfo*)must_malloc( sizeof(struct finfo)*n );
if (fdarray != 0)
memcpy( narray, fdarray, sizeof(struct finfo)*num_fds );
for ( i=num_fds ; i < n ; i++ )
{
narray[i].fp = 0;
narray[i].mode = 0;
}
i = num_fds;
num_fds = n;
if (fdarray != 0)
free( fdarray );
fdarray = narray;
}
fdarray[i].fp = fp;
fdarray[i].mode = mode;
globals[ G_RESULT ] = fixnum(i);
}
/* Rename is in Standard C. */
void osdep_rename( word w_from, word w_to )
{
if (string_length(w_from) > FILENAME_MAX)
globals[ G_RESULT ] = fixnum(-1);
else
{
char fnbuf[ FILENAME_MAX+1 ];
strcpy( fnbuf, string2asciiz( w_from ) );
globals[ G_RESULT ] = fixnum( rename( fnbuf, string2asciiz(w_to) ) );
}
}
void print_traverse(value_t v)
{
value_t *bp;
while (iscons(v)) {
if (ismarked(v)) {
bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
if (*bp == (value_t)HT_NOTFOUND)
*bp = fixnum(printlabel++);
return;
}
mark_cons(v);
print_traverse(car_(v));
v = cdr_(v);
}
if (!ismanaged(v) || issymbol(v))
return;
if (ismarked(v)) {
bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
if (*bp == (value_t)HT_NOTFOUND)
*bp = fixnum(printlabel++);
return;
}
if (isvector(v)) {
if (vector_size(v) > 0)
mark_cons(v);
unsigned int i;
for(i=0; i < vector_size(v); i++)
print_traverse(vector_elt(v,i));
}
else if (iscprim(v)) {
mark_cons(v);
}
else if (isclosure(v)) {
mark_cons(v);
function_t *f = (function_t*)ptr(v);
print_traverse(f->bcode);
print_traverse(f->vals);
print_traverse(f->env);
}
else {
assert(iscvalue(v));
cvalue_t *cv = (cvalue_t*)ptr(v);
// don't consider shared references to ""
if (!cv_isstr(cv) || cv_len(cv)!=0)
mark_cons(v);
fltype_t *t = cv_class(cv);
if (t->vtable != NULL && t->vtable->print_traverse != NULL)
t->vtable->print_traverse(v);
}
}
/* Standard C does not have a procedure to get the modification time of
a file, but if stat() exists we can use it. If not, return a vector
containing midnight, January 1, 1970 always. This is consistent with
the result returned by osdep_access(), below.
*/
void osdep_mtime( word w_fn, word w_buf )
{
int r = 0;
struct tm *tm;
#ifdef HAVE_STAT
struct stat s;
const char *fn = string2asciiz( w_fn );
r = stat( fn, &s );
#else
struct {
time_t st_mtime;
} s;
s.st_mtime = 0;
#endif
if (r != 0)
{
globals[ G_RESULT ] = fixnum(-1);
return;
}
tm = localtime( &s.st_mtime );
vector_set( w_buf, 0, fixnum( tm->tm_year + 1900 ) );
vector_set( w_buf, 1, fixnum( tm->tm_mon + 1 ) );
vector_set( w_buf, 2, fixnum( tm->tm_mday ) );
vector_set( w_buf, 3, fixnum( tm->tm_hour ) );
vector_set( w_buf, 4, fixnum( tm->tm_min ) );
vector_set( w_buf, 5, fixnum( tm->tm_sec ) );
globals[ G_RESULT ] = fixnum( 0 );
}
/* system() is in ANSI/ISO C. */
void osdep_system( word w_cmd )
{
#ifdef __MWERKS__
/* system() is broken in CodeWarrior 6, at least: once called
with a command, it sticks with that command though it allows
the arguments to be changed.
Examining the code for the function (included in the mwerks libs),
the cause is obvious: it uses strcat on the string returned from
getenv("COMSPEC"). Gag! We might be able to hack around by
preserving COMSPEC around calls to system, but who knows what
else it clobbers. So reimplement system() here.
*/
char *cmd = string2asciiz( w_cmd );
char *comspec = getenv( "COMSPEC" );
STARTUPINFO si;
PROCESS_INFORMATION pi;
char command[1024];
char *p;
int n;
int size;
if (comspec == NULL || strlen(comspec) + strlen(cmd) + sizeof(" /C ") + 1 > sizeof(command))
{
globals[ G_RESULT ] = fixnum(1);
return;
}
strcpy( command, comspec );
strcat( command, " /C " );
strcat( command, cmd );
memset( &si, 0, sizeof( si ) );
si.cb = sizeof(si);
if (CreateProcess( NULL, command, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi) == 0)
{
globals[ G_RESULT ] = fixnum(1);
return;
}
WaitForSingleObject(pi.hProcess, ~0L);
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
globals[ G_RESULT ] = fixnum(0);
#else
char *cmd = string2asciiz( w_cmd );
globals[ G_RESULT ] = fixnum(system( cmd ));
#endif /* __MWERKS__ */
}
// this is for parsing one expression out of a string, keeping track of
// the current position.
JL_DLLEXPORT jl_value_t *jl_parse_string(const char *str, size_t len,
int pos0, int greedy)
{
JL_TIMING(PARSING);
if (pos0 < 0 || pos0 > len) {
jl_array_t *buf = jl_pchar_to_array(str, len);
JL_GC_PUSH1(&buf);
// jl_bounds_error roots the arguments.
jl_bounds_error((jl_value_t*)buf, jl_box_long(pos0));
}
jl_ast_context_t *ctx = jl_ast_ctx_enter();
fl_context_t *fl_ctx = &ctx->fl;
value_t s = cvalue_static_cstrn(fl_ctx, str, len);
value_t p = fl_applyn(fl_ctx, 3, symbol_value(symbol(fl_ctx, "jl-parse-one-string")),
s, fixnum(pos0), greedy?fl_ctx->T:fl_ctx->F);
jl_value_t *expr=NULL, *pos1=NULL;
JL_GC_PUSH2(&expr, &pos1);
value_t e = car_(p);
if (e == fl_ctx->FL_EOF)
expr = jl_nothing;
else
expr = scm_to_julia(fl_ctx, e, NULL);
pos1 = jl_box_long(tosize(fl_ctx, cdr_(p), "parse"));
jl_ast_ctx_leave(ctx);
jl_value_t *result = (jl_value_t*)jl_svec2(expr, pos1);
JL_GC_POP();
return result;
}
static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
{
size_t la = vector_size(a);
size_t lb = vector_size(b);
size_t m, i;
if (eq && (la!=lb)) return fixnum(1);
m = la < lb ? la : lb;
for (i = 0; i < m; i++) {
value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i),
bound-1, eq);
if (d==NIL || numval(d)!=0) return d;
}
if (la < lb) return fixnum(-1);
if (la > lb) return fixnum(1);
return fixnum(0);
}
static void jl_init_ast_ctx(jl_ast_context_t *ast_ctx)
{
fl_context_t *fl_ctx = &ast_ctx->fl;
fl_init(fl_ctx, 4*1024*1024);
if (fl_load_system_image_str(fl_ctx, (char*)flisp_system_image,
sizeof(flisp_system_image))) {
jl_error("fatal error loading system image");
}
fl_applyn(fl_ctx, 0, symbol_value(symbol(fl_ctx, "__init_globals")));
jl_ast_context_t *ctx = jl_ast_ctx(fl_ctx);
ctx->jvtype = define_opaque_type(fl_ctx->jl_sym, sizeof(void*), NULL, NULL);
assign_global_builtins(fl_ctx, julia_flisp_ast_ext);
ctx->true_sym = symbol(fl_ctx, "true");
ctx->false_sym = symbol(fl_ctx, "false");
ctx->error_sym = symbol(fl_ctx, "error");
ctx->null_sym = symbol(fl_ctx, "null");
ctx->ssavalue_sym = symbol(fl_ctx, "ssavalue");
ctx->slot_sym = symbol(fl_ctx, "slot");
ctx->task = NULL;
ctx->module = NULL;
set(symbol(fl_ctx, "*depwarn-opt*"), fixnum(jl_options.depwarn));
}
int stk_create( word *globals )
{
word *stktop;
assert( globals[G_STKP] - SCE_BUFFER >= globals[ G_ETOP ]
&& globals[G_STKP] <= globals[ G_ELIM ] );
stktop = (word*)globals[ G_STKP ];
stktop -= 4;
if (stktop < (word*)globals[ G_ETOP ]) {
supremely_annoyingmsg( "Failed to create stack.");
return 0;
}
*(stktop+STK_CONTSIZE) = fixnum(3); /* header/size field */
*(stktop+STK_RETADDR) = 0xDEADBEEF; /* retaddr: uflow handler */
*(stktop+STK_DYNLINK) = 0xDEADBEEF; /* dynamic link field */
*(stktop+STK_PROC) = 0xDEADBEEF; /* saved procedure */
stk_initialize_underflow_frame( stktop ); /* In client space */
globals[ G_STKP ] = (word)stktop;
globals[ G_STKBOT ] = (word)stktop;
stack_state.stacks_created += 1;
return 1;
}
/* Standard C does not have a procedure to check for input-ready.
Return 1 always to indicate input ready. This is correct for disk
files, but not for intermittent input sources (console, etc).
*/
void osdep_pollinput( word w_fd )
{
#ifdef USE_STDIO
check_standard_filedes();
#endif
globals[ G_RESULT ] = fixnum(1);
}
void stk_initialize_underflow_frame( word *stktop )
{
extern void mem_stkuflow();
*(stktop+STK_CONTSIZE) = fixnum(3); /* header/size field */
*(stktop+STK_RETADDR) = (word)mem_stkuflow; /* retaddr: uflow handler */
*(stktop+STK_DYNLINK) = 0xDEADBEEF; /* dynamic link field */
*(stktop+STK_PROC) = 0; /* saved procedure */
}
static value_t fl_rand32(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
uint32_t r = random();
#ifdef BITS64
return fixnum(r);
#else
return mk_uint32(r);
#endif
}
static value_t fl_time_fromstring(value_t *args, uint32_t nargs)
{
argcount("time.fromstring", nargs, 1);
char *ptr = tostring(args[0], "time.fromstring");
double t = parsetime(ptr);
int64_t it = (int64_t)t;
if ((double)it == t && fits_fixnum(it))
return fixnum(it);
return mk_double(t);
}
/* Standard C does not have a procedure to check whether a file exists.
We use stat() if we have it; many systems do. If not, try to open
the file in read mode to find out if it exists; this is usually OK
(not always). The mode is ignored.
*/
void osdep_access( word w_fn, word w_bits )
{
#ifdef HAVE_STAT
struct stat s;
globals[ G_RESULT ]= fixnum(stat(string2asciiz(w_fn), &s ));
#else
FILE *fp;
const char *fn = string2asciiz( w_fn );
if ((fp = fopen( fn, "r" )) != 0)
{
fclose( fp );
globals[ G_RESULT ] = fixnum(0);
}
else
globals[ G_RESULT ] = fixnum(-1);
#endif
}
void osdep_closefile( word w_fd )
{
int fd = nativeint( w_fd );
#ifdef USE_STDIO
check_standard_filedes();
#endif
assert( fd >= 0 && fd < num_fds );
if (fdarray[fd].fp == 0)
globals[ G_RESULT ] = fixnum(-1);
else if (fclose( fdarray[fd].fp ) == EOF)
globals[ G_RESULT ] = fixnum(-1);
else
globals[ G_RESULT ] = fixnum(0);
fdarray[fd].fp = 0;
fdarray[fd].mode = 0;
}
static value_t julia_to_scm(jl_value_t *v)
{
if (jl_is_symbol(v)) {
return symbol(((jl_sym_t*)v)->name);
}
if (v == jl_true) {
return FL_T;
}
if (v == jl_false) {
return FL_F;
}
if (jl_is_expr(v)) {
jl_expr_t *ex = (jl_expr_t*)v;
value_t args = array_to_list(ex->args);
fl_gc_handle(&args);
value_t hd = julia_to_scm((jl_value_t*)ex->head);
value_t scmv = fl_cons(hd, args);
fl_free_gc_handles(1);
return scmv;
}
if (jl_typeis(v, jl_linenumbernode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)line_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_labelnode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)label_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_gotonode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)goto_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_quotenode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)quote_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_topnode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)top_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_is_long(v) && fits_fixnum(jl_unbox_long(v))) {
return fixnum(jl_unbox_long(v));
}
if (jl_typeis(v,jl_array_any_type)) {
return array_to_list((jl_array_t*)v);
}
value_t opaque = cvalue(jvtype, sizeof(void*));
*(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = v;
return opaque;
}
static value_t fl_rand(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
fixnum_t r;
#ifdef BITS64
r = ((((uint64_t)random())<<32) | random()) & 0x1fffffffffffffffLL;
#else
r = random() & 0x1fffffff;
#endif
return fixnum(r);
}
void larceny_call( word proc, int argc, word *argv, word *result )
{
int i, fresh_stack;
word *p;
/* Allocate and setup a stack frame */
if ((globals[ G_STKP ]-SCE_BUFFER)-FRAMESIZE < globals[ G_ETOP ]) {
hardconsolemsg( "Callback failed -- stack overflow." );
/* Fixme: need to indicate error */
/* Fixme: in general, we must recover from this problem! */
*result = UNDEFINED_CONST;
return;
}
fresh_stack = globals[ G_STKP ] == globals[ G_STKBOT ];
globals[ G_STKP ] -= FRAMESIZE;
p = (word*)globals[ G_STKP ];
p[STK_CONTSIZE] = 5*sizeof(word); /* size in bytes */
p[STK_RETADDR] = 0; /* return address -- set by scheme_start() */
if (fresh_stack)
p[STK_DYNLINK] = globals[ G_CONT ]; /* dynamic link */
else
p[STK_DYNLINK] = 0; /* random */
p[STK_PROC] = 0; /* procedure pointer (fixed) */
p[4] = globals[ G_REG0 ];
p[5] = globals[ G_RETADDR ];
/* Setup arguments in registers -- this gcprotects them */
globals[ G_REG0 ] = proc;
for ( i=0 ; i < argc ; i++ ) /* FIXME: guard against argc > #regs */
globals[ G_REG1+i ] = argv[i];
globals[ G_RESULT ] = fixnum(argc);
/* Check the type and invoke the procedure */
if (tagof( globals[ G_REG0 ] ) != PROC_TAG) {
hardconsolemsg( "Callback failed -- not a procedure." );
/* Fixme: need to indicate error */
*result = UNDEFINED_CONST;
return;
}
scheme_start( globals );
*result = globals[ G_RESULT ];
/* Pop the frame */
p = (word*)globals[ G_STKP ];
globals[ G_REG0 ] = p[4];
globals[ G_RETADDR ] = p[5];
globals[ G_STKP ] += FRAMESIZE;
}
static value_t fl_fixnum(value_t *args, u_int32_t nargs)
{
argcount("fixnum", nargs, 1);
if (isfixnum(args[0])) {
return args[0];
}
else if (iscprim(args[0])) {
cprim_t *cp = (cprim_t*)ptr(args[0]);
return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
}
type_error("fixnum", "number", args[0]);
}
/* a - shooting unit, b - target */
static int
range_damage (Unit *a, Unit *b){
Skill_range s = find_skill(a, S_RANGE)->range;
int hits = 0;
int wounds = 0; /*possible wounds(may be blocked by armour)*/
int final = 0; /*final wounds(not blocked by armour)*/
int attacks = a->count;
/*chances to hit, to wound and to ignore armour. percents.*/
int to_hit = 2 + s.skill;
int to_wound = 5 + (s.strength - utypes[b->t].toughness);
int to_as = 10- utypes[b->t].armor;
#if 1
int r = rnd(0, 2);
to_hit += rnd(-r, r);
to_wound += rnd(-r, r);
to_as += rnd(-r, r);
#endif
fixnum(0, 9, &to_hit);
fixnum(0, 9, &to_wound);
hits = attacks * to_hit / 10;
wounds = hits * to_wound / 10;
final = wounds * to_as / 10;
static value_t julia_to_scm_(fl_context_t *fl_ctx, jl_value_t *v)
{
if (jl_is_symbol(v))
return symbol(fl_ctx, jl_symbol_name((jl_sym_t*)v));
if (v == jl_true)
return jl_ast_ctx(fl_ctx)->true_sym;
if (v == jl_false)
return jl_ast_ctx(fl_ctx)->false_sym;
if (v == jl_nothing)
return fl_cons(fl_ctx, jl_ast_ctx(fl_ctx)->null_sym, fl_ctx->NIL);
if (jl_is_expr(v)) {
jl_expr_t *ex = (jl_expr_t*)v;
value_t args = fl_ctx->NIL;
fl_gc_handle(fl_ctx, &args);
array_to_list(fl_ctx, ex->args, &args);
value_t hd = julia_to_scm_(fl_ctx, (jl_value_t*)ex->head);
if (ex->head == lambda_sym && jl_expr_nargs(ex)>0 && jl_is_array(jl_exprarg(ex,0))) {
value_t llist = fl_ctx->NIL;
fl_gc_handle(fl_ctx, &llist);
array_to_list(fl_ctx, (jl_array_t*)jl_exprarg(ex,0), &llist);
car_(args) = llist;
fl_free_gc_handles(fl_ctx, 1);
}
value_t scmv = fl_cons(fl_ctx, hd, args);
fl_free_gc_handles(fl_ctx, 1);
return scmv;
}
// GC Note: jl_fieldref(v, 0) allocate for LabelNode, GotoNode
// but we don't need a GC root here because julia_to_list2
// shouldn't allocate in this case.
if (jl_typeis(v, jl_labelnode_type))
return julia_to_list2(fl_ctx, (jl_value_t*)label_sym, jl_fieldref(v,0));
if (jl_typeis(v, jl_linenumbernode_type))
return julia_to_list2(fl_ctx, (jl_value_t*)line_sym, jl_fieldref(v,0));
if (jl_typeis(v, jl_gotonode_type))
return julia_to_list2(fl_ctx, (jl_value_t*)goto_sym, jl_fieldref(v,0));
if (jl_typeis(v, jl_quotenode_type))
return julia_to_list2(fl_ctx, (jl_value_t*)inert_sym, jl_fieldref(v,0));
if (jl_typeis(v, jl_newvarnode_type))
return julia_to_list2(fl_ctx, (jl_value_t*)newvar_sym, jl_fieldref(v,0));
if (jl_is_long(v) && fits_fixnum(jl_unbox_long(v)))
return fixnum(jl_unbox_long(v));
if (jl_is_ssavalue(v))
jl_error("SSAValue objects should not occur in an AST");
if (jl_is_slot(v))
jl_error("Slot objects should not occur in an AST");
value_t opaque = cvalue(fl_ctx, jl_ast_ctx(fl_ctx)->jvtype, sizeof(void*));
*(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = v;
return opaque;
}
static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
int eq)
{
size_t la = vector_size(a);
size_t lb = vector_size(b);
size_t m, i;
value_t d, xa, xb, ca, cb;
// first try to prove them different with no recursion
if (eq && (la!=lb)) return fixnum(1);
m = la < lb ? la : lb;
for (i = 0; i < m; i++) {
xa = vector_elt(a,i);
xb = vector_elt(b,i);
if (leafp(xa) || leafp(xb)) {
d = bounded_compare(xa, xb, 1, eq);
if (d!=NIL && numval(d)!=0) return d;
}
else if (tag(xa) < tag(xb)) {
return fixnum(-1);
}
else if (tag(xa) > tag(xb)) {
return fixnum(1);
}
}
ca = eq_class(table, a);
cb = eq_class(table, b);
if (ca!=NIL && ca==cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
for (i = 0; i < m; i++) {
xa = vector_elt(a,i);
xb = vector_elt(b,i);
if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {
d = cyc_compare(xa, xb, table, eq);
if (numval(d)!=0)
return d;
}
}
if (la < lb) return fixnum(-1);
if (la > lb) return fixnum(1);
return fixnum(0);
}
// this is for parsing one expression out of a string, keeping track of
// the current position.
DLLEXPORT jl_value_t *jl_parse_string(const char *str, int pos0, int greedy)
{
value_t s = cvalue_static_cstring(str);
value_t p = fl_applyn(3, symbol_value(symbol("jl-parse-one-string")),
s, fixnum(pos0), greedy?FL_T:FL_F);
jl_value_t *expr=NULL, *pos1=NULL;
JL_GC_PUSH(&expr, &pos1);
value_t e = car_(p);
if (e == FL_T || e == FL_F || e == FL_EOF) {
expr = (jl_value_t*)jl_null;
}
else {
expr = scm_to_julia(e);
}
pos1 = jl_box_long(toulong(cdr_(p),"parse"));
jl_value_t *result = (jl_value_t*)jl_tuple2(expr, pos1);
JL_GC_POP();
return result;
}
static u_int32_t peek(void)
{
char c, *end;
fixnum_t x;
int ch, base;
if (toktype != TOK_NONE)
return toktype;
c = nextchar();
if (ios_eof(F)) return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '[') {
toktype = TOK_OPENB;
}
else if (c == ']') {
toktype = TOK_CLOSEB;
}
else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (c == '`') {
toktype = TOK_BQ;
}
else if (c == '"') {
toktype = TOK_DOUBLEQUOTE;
}
else if (c == '#') {
ch = ios_getc(F); c = (char)ch;
if (ch == IOS_EOF)
lerror(ParseError, "read: invalid read macro");
if (c == '.') {
toktype = TOK_SHARPDOT;
}
else if (c == '\'') {
toktype = TOK_SHARPQUOTE;
}
else if (c == '\\') {
uint32_t cval;
if (ios_getutf8(F, &cval) == IOS_EOF)
lerror(ParseError, "read: end of input in character constant");
if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
cval == (uint32_t)'x') {
read_token('u', 0);
if (buf[1] != '\0') { // not a solitary 'u','U','x'
if (!read_numtok(&buf[1], &tokval, 16))
lerror(ParseError,
"read: invalid hex character constant");
cval = numval(tokval);
}
}
else if (cval >= 'a' && cval <= 'z') {
read_token((char)cval, 0);
tokval = symbol(buf);
if (buf[1] == '\0') /* one character */;
else if (tokval == nulsym) cval = 0x00;
else if (tokval == alarmsym) cval = 0x07;
else if (tokval == backspacesym) cval = 0x08;
else if (tokval == tabsym) cval = 0x09;
else if (tokval == linefeedsym) cval = 0x0A;
else if (tokval == newlinesym) cval = 0x0A;
else if (tokval == vtabsym) cval = 0x0B;
else if (tokval == pagesym) cval = 0x0C;
else if (tokval == returnsym) cval = 0x0D;
else if (tokval == escsym) cval = 0x1B;
else if (tokval == spacesym) cval = 0x20;
else if (tokval == deletesym) cval = 0x7F;
else
lerrorf(ParseError, "read: unknown character #\\%s", buf);
}
toktype = TOK_NUM;
tokval = mk_wchar(cval);
}
else if (c == '(') {
toktype = TOK_SHARPOPEN;
}
else if (c == '<') {
lerror(ParseError, "read: unreadable object");
}
else if (isdigit(c)) {
read_token(c, 1);
c = (char)ios_getc(F);
if (c == '#')
toktype = TOK_BACKREF;
else if (c == '=')
toktype = TOK_LABEL;
else
lerror(ParseError, "read: invalid label");
errno = 0;
x = strtol(buf, &end, 10);
if (*end != '\0' || errno)
lerror(ParseError, "read: invalid label");
tokval = fixnum(x);
}
else if (c == '!') {
// #! single line comment for shbang script support
do {
ch = ios_getc(F);
} while (ch != IOS_EOF && (char)ch != '\n');
return peek();
}
else if (c == '|') {
// multiline comment
int commentlevel=1;
while (1) {
ch = ios_getc(F);
hashpipe_gotc:
if (ch == IOS_EOF)
lerror(ParseError, "read: eof within comment");
if ((char)ch == '|') {
ch = ios_getc(F);
if ((char)ch == '#') {
commentlevel--;
if (commentlevel == 0)
break;
else
continue;
}
goto hashpipe_gotc;
}
else if ((char)ch == '#') {
ch = ios_getc(F);
if ((char)ch == '|')
commentlevel++;
else
goto hashpipe_gotc;
}
}
// this was whitespace, so keep peeking
return peek();
}
else if (c == ';') {
// datum comment
(void)do_read_sexpr(UNBOUND); // skip
return peek();
}
else if (c == ':') {
// gensym
ch = ios_getc(F);
if ((char)ch == 'g')
ch = ios_getc(F);
read_token((char)ch, 0);
errno = 0;
x = strtol(buf, &end, 10);
if (*end != '\0' || buf[0] == '\0' || errno)
lerror(ParseError, "read: invalid gensym label");
toktype = TOK_GENSYM;
tokval = fixnum(x);
}
else if (symchar(c)) {
read_token(ch, 0);
if (((c == 'b' && (base= 2)) ||
(c == 'o' && (base= 8)) ||
(c == 'd' && (base=10)) ||
(c == 'x' && (base=16))) &&
(isdigit_base(buf[1],base) ||
buf[1]=='-')) {
if (!read_numtok(&buf[1], &tokval, base))
lerrorf(ParseError, "read: invalid base %d constant", base);
return (toktype=TOK_NUM);
}
toktype = TOK_SHARPSYM;
tokval = symbol(buf);
}
else {
lerror(ParseError, "read: unknown read macro");
}
}
else if (c == ',') {
toktype = TOK_COMMA;
ch = ios_getc(F);
if (ch == IOS_EOF)
return toktype;
if ((char)ch == '@')
toktype = TOK_COMMAAT;
else if ((char)ch == '.')
toktype = TOK_COMMADOT;
else
ios_ungetc((char)ch, F);
}
else {
if (!read_token(c, 0)) {
if (buf[0]=='.' && buf[1]=='\0') {
return (toktype=TOK_DOT);
}
else {
if (read_numtok(buf, &tokval, 0))
return (toktype=TOK_NUM);
}
}
toktype = TOK_SYM;
tokval = symbol(buf);
}
return toktype;
}
