static foreign_t p_random(term_t rnd) { double fli; long int t1, t2, t3; t1 = (a1 * 171) % 30269; t2 = (b1 * 172) % 30307; t3 = (c1 * 170) % 30323; fli = (t1/30269.0) + (t2/30307.0) + (t3/30323.0); a1 = (short)t1; b1 = (short)t2; c1 = (short)t3; return PL_unify_float(rnd, fli-(int)(fli)); }
static foreign_t pl_gsl_sf_bessel_J0(term_t x_term, term_t out_term) { double x; double y; int rval; if ( PL_get_float(x_term, &x) ) { y = gsl_sf_bessel_j0(x); rval = PL_unify_float(out_term, y); return rval; } PL_fail; }
word pl_get_time(term_t t) { double stime; #ifdef HAVE_GETTIMEOFDAY struct timeval tp; gettimeofday(&tp, NULL); stime = (double)tp.tv_sec + (double)tp.tv_usec/1000000.0; #else #ifdef HAVE_FTIME struct timeb tb; ftime(&tb); stime = (double)tb.time + (double)tb.millitm/1000.0; #else stime = (double)time((time_t *)NULL); #endif #endif return PL_unify_float(t, stime); }
static foreign_t current_alarms(term_t time, term_t goal, term_t id, term_t status, term_t matching) { Event ev; term_t next = PL_new_term_ref(); term_t g = PL_new_term_ref(); term_t tail = PL_copy_term_ref(matching); term_t head = PL_new_term_ref(); term_t av = PL_new_term_refs(4); pthread_t self = pthread_self(); LOCK(); ev = TheSchedule()->first; for(; ev; ev = ev->next) { atom_t s; double at; fid_t fid; if ( !pthread_equal(self, ev->thread_id) ) continue; fid = PL_open_foreign_frame(); if ( ev->flags & EV_DONE ) s = ATOM_done; else if ( ev == TheSchedule()->scheduled ) s = ATOM_next; else s = ATOM_scheduled; if ( !PL_unify_atom(status, s) ) goto nomatch; PL_recorded(ev->goal, g); if ( !PL_unify_term(goal, PL_FUNCTOR, FUNCTOR_module2, PL_ATOM, PL_module_name(ev->module), PL_TERM, g) ) goto nomatch; at = (double)ev->at.tv_sec + (double)ev->at.tv_usec / 1000000.0; if ( !PL_unify_float(time, at) ) goto nomatch; if ( !unify_timer(id, ev) ) goto nomatch; PL_discard_foreign_frame(fid); if ( !PL_put_float(av+0, at) || /* time */ !PL_recorded(ev->goal, av+1) || /* goal */ !PL_put_variable(av+2) || /* id */ !unify_timer(av+2, ev) || !PL_put_atom(av+3, s) || /* status */ !PL_cons_functor_v(next, FUNCTOR_alarm4, av) ) { PL_close_foreign_frame(fid); UNLOCK(); return FALSE; } if ( PL_unify_list(tail, head, tail) && PL_unify(head, next) ) { continue; } else { PL_close_foreign_frame(fid); UNLOCK(); return FALSE; } nomatch: PL_discard_foreign_frame(fid); } UNLOCK(); return PL_unify_nil(tail); }
static foreign_t archive_header_prop(term_t archive, term_t field) { archive_wrapper *ar; functor_t prop; if ( !get_archive(archive, &ar) ) return FALSE; if ( !PL_get_functor(field, &prop) ) return PL_type_error("compound", field); if ( ar->status != AR_NEW_ENTRY ) return PL_permission_error("access", "archive_entry", archive); if ( prop == FUNCTOR_filetype1 ) { __LA_MODE_T type = archive_entry_filetype(ar->entry); atom_t name; term_t arg = PL_new_term_ref(); _PL_get_arg(1, field, arg); switch(type&AE_IFMT) { case AE_IFREG: name = ATOM_file; break; case AE_IFLNK: name = ATOM_link; break; case AE_IFSOCK: name = ATOM_socket; break; case AE_IFCHR: name = ATOM_character_device; break; case AE_IFBLK: name = ATOM_block_device; break; case AE_IFDIR: name = ATOM_directory; break; case AE_IFIFO: name = ATOM_fifo; break; default: return PL_unify_integer(arg, (type&AE_IFMT)); } return PL_unify_atom(arg, name); } else if ( prop == FUNCTOR_mtime1 ) { time_t stamp = archive_entry_mtime(ar->entry); term_t arg = PL_new_term_ref(); _PL_get_arg(1, field, arg); return PL_unify_float(arg, (double)stamp); } else if ( prop == FUNCTOR_size1 ) { int64_t size = archive_entry_size(ar->entry); term_t arg = PL_new_term_ref(); _PL_get_arg(1, field, arg); return PL_unify_int64(arg, size); } else if ( prop == FUNCTOR_link_target1 ) { __LA_MODE_T type = archive_entry_filetype(ar->entry); const wchar_t *target = NULL; switch(type&AE_IFMT) { case AE_IFLNK: target = archive_entry_symlink_w(ar->entry); break; } if ( target ) { term_t arg = PL_new_term_ref(); _PL_get_arg(1, field, arg); return PL_unify_wchars(arg, PL_ATOM, (size_t)-1, target); } return FALSE; } else if ( prop == FUNCTOR_format1 ) { const char *s = archive_format_name(ar->archive); if ( s ) { char lwr[50]; char *o; term_t arg = PL_new_term_ref(); _PL_get_arg(1, field, arg); for(o=lwr; *s && o < lwr+sizeof(lwr); ) *o++ = tolower(*s++); *o = '\0'; return PL_unify_atom_chars(arg, lwr); } } return PL_domain_error("archive_header_property", field); }