diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

upgrade to latest swi

Browse Source
This commit is contained in:
Vitor Santos Costa 2013-11-15 01:10:25 +00:00
parent 5b46b6bd1a
commit 4e4f21e1dc
49 changed files with 6726 additions and 3043 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
C/absmi.c
View File

@ -673,6 +673,7 @@ Yap_absmi(int inp)
init_absmi_regs(&absmi_regs);
#if THREADS
regcache = Yap_regp
LOCAL_PL_local_data_p->reg_cache = regcache;
#else
Yap_regp = &absmi_regs;
#endif
@ -707,6 +708,7 @@ Yap_absmi(int inp)
pthread_setspecific(Yap_yaamregs_key, (const void *)&absmi_regs);
LOCAL_ThreadHandle.current_yaam_regs = &absmi_regs;
regcache = &absmi_regs;
LOCAL_PL_local_data_p->reg_cache = regcache;
#else
Yap_regp = &absmi_regs;
#endif

11
C/exec.c
View File

@ -19,6 +19,7 @@ static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
#endif
#include "absmi.h"
#include "pl-shared.h"
#include "yapio.h"
#include "attvar.h"
#ifdef CUT_C
@ -1744,10 +1745,12 @@ Yap_InitYaamRegs( int myworker_id )
#ifdef THREADS
CACHE_REGS
if (myworker_id) {
pthread_setspecific(Yap_yaamregs_key, (const void *)REMOTE_ThreadHandle(myworker_id).default_yaam_regs);
REMOTE_ThreadHandle(myworker_id).current_yaam_regs = REMOTE_ThreadHandle(myworker_id).default_yaam_regs;
REFRESH_CACHE_REGS
}
REGSTORE *rs = REMOTE_ThreadHandle(myworker_id).default_yaam_regs;
pthread_setspecific(Yap_yaamregs_key, (const void *)rs);
REMOTE_PL_local_data_p(myworker_id)->reg_cache = rs;
REMOTE_ThreadHandle(myworker_id).current_yaam_regs = rs;
REFRESH_CACHE_REGS
}
/* may be run by worker_id on behalf on myworker_id */
#else
Yap_regp = &Yap_standard_regs;

4
C/init.c
View File

@ -25,6 +25,7 @@ static char SccsId[] = "%W% %G%";
#include <stdlib.h>
#include "Yap.h"
#include "pl-shared.h"
#include "yapio.h"
#include "alloc.h"
#include "clause.h"
@ -1146,7 +1147,7 @@ Yap_InitThread(int new_id)
REGSTORE *rs = (REGSTORE *)calloc(sizeof(REGSTORE),1);
pthread_setspecific(Yap_yaamregs_key, (const void *)rs);
REMOTE_ThreadHandle(new_id).default_yaam_regs = rs;
REMOTE_ThreadHandle(new_id).current_yaam_regs = REMOTE_ThreadHandle(new_id).default_yaam_regs;
REMOTE_ThreadHandle(new_id).current_yaam_regs = rs;
rs->worker_id_ = new_id;
rs->worker_local_ = REMOTE(new_id);
}
@ -1333,6 +1334,7 @@ Yap_InitWorkspace(UInt Heap, UInt Stack, UInt Trail, UInt Atts, UInt max_table_s
#if THREADS
/* make sure we use the correct value of regcache */
regcache = ((REGSTORE *)pthread_getspecific(Yap_yaamregs_key));
LOCAL_PL_local_data_p->reg_cache = regcache;
#endif
#if USE_SYSTEM_MALLOC
if (Trail < MinTrailSpace)

53
C/pl-yap.c
View File

@ -1038,7 +1038,7 @@ PL_dispatch(int fd, int wait)
YAP: YAP_Atom YAP_AtomOfTerm(Term) */
int PL_get_atom__LD(term_t ts, atom_t *a ARG_LD)
{
CACHE_REGS
REGS_FROM_LD
YAP_Term t = Yap_GetFromSlot(ts PASS_REGS);
if ( !IsAtomTerm(t))
return 0;
@ -1048,27 +1048,33 @@ int PL_get_atom__LD(term_t ts, atom_t *a ARG_LD)
void PL_put_term__LD(term_t d, term_t s ARG_LD)
{
CACHE_REGS
REGS_FROM_LD
Yap_PutInSlot(d,Yap_GetFromSlot(s PASS_REGS) PASS_REGS);
}
term_t PL_new_term_ref__LD(ARG1_LD)
{
CACHE_REGS
REGS_FROM_LD
term_t to = Yap_NewSlots(1 PASS_REGS);
return to;
}
int PL_is_variable__LD(term_t ts ARG_LD)
{
CACHE_REGS
REGS_FROM_LD
YAP_Term t = Yap_GetFromSlot(ts PASS_REGS);
return YAP_IsVarTerm(t);
}
X_API int PL_unify__LD(term_t t1, term_t t2 ARG_LD)
{
REGS_FROM_LD
return Yap_unify(Yap_GetFromSlot(t1 PASS_REGS),Yap_GetFromSlot(t2 PASS_REGS));
}
int PL_unify_atom__LD(term_t t, atom_t at ARG_LD)
{
CACHE_REGS
REGS_FROM_LD
YAP_Term cterm = MkAtomTerm(YAP_AtomFromSWIAtom(at));
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS),cterm);
}
@ -1077,11 +1083,44 @@ int PL_unify_atom__LD(term_t t, atom_t at ARG_LD)
YAP long int unify(YAP_Term* a, Term* b) */
int PL_unify_integer__LD(term_t t, intptr_t i ARG_LD)
{
CACHE_REGS
REGS_FROM_LD
Term iterm = MkIntegerTerm(i);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS),iterm);
}
/* SWI: int PL_unify_integer(term_t ?t, long n)
YAP long int unify(YAP_Term* a, Term* b) */
X_API int PL_unify_int64__LD(term_t t, int64_t n ARG_LD)
{
REGS_FROM_LD
#if SIZEOF_INT_P==8
Term iterm = MkIntegerTerm(n);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS),iterm);
#elif USE_GMP
YAP_Term iterm;
char s[64];
MP_INT rop;
#ifdef _WIN32
snprintf(s, 64, "%I64d", (long long int)n);
#elif HAVE_SNPRINTF
snprintf(s, 64, "%lld", (long long int)n);
#else
sprintf(s, "%lld", (long long int)n);
#endif
mpz_init_set_str (&rop, s, 10);
iterm = YAP_MkBigNumTerm((void *)&rop);
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS),iterm);
#else
if ((long)n == n)
return PL_unify_integer(t, n);
fprintf(stderr,"Error in PL_unify_int64: please install GMP\n");
return FALSE;
#endif
}
#ifdef _WIN32
@ -1496,4 +1535,6 @@ recursiveMutexInit(recursiveMutex *m)
}
#endif

11
C/threads.c
View File

@ -187,7 +187,8 @@ kill_thread_engine (int wid, int always_die)
REMOTE_ActiveSignals(wid) = 0L;
if (REMOTE_ScratchPad(wid).ptr)
free(REMOTE_ScratchPad(wid).ptr);
REMOTE_ThreadHandle(wid).current_yaam_regs = NULL;
REMOTE_PL_local_data_p(wid)->reg_cache =
REMOTE_ThreadHandle(wid).current_yaam_regs = NULL;
if (REMOTE_ThreadHandle(wid).start_of_timesp)
free(REMOTE_ThreadHandle(wid).start_of_timesp);
if (REMOTE_ThreadHandle(wid).last_timep)
@ -266,6 +267,8 @@ setup_engine(int myworker_id, int init_thread)
regcache = standard_regs;
/* create the YAAM descriptor */
REMOTE_ThreadHandle(myworker_id).default_yaam_regs = standard_regs;
REMOTE_ThreadHandle(myworker_id).current_yaam_regs = standard_regs;
REMOTE_PL_local_data_p(myworker_id)->reg_cache = standard_regs;
Yap_InitExStacks(myworker_id, REMOTE_ThreadHandle(myworker_id).tsize, REMOTE_ThreadHandle(myworker_id).ssize);
LOCAL_SourceModule = CurrentModule = REMOTE_ThreadHandle(myworker_id).cmod;
Yap_InitTime( myworker_id );
@ -1002,16 +1005,20 @@ void
Yap_InitFirstWorkerThreadHandle(void)
{
CACHE_REGS
set_system_thread_id(0, NULL);
LOCAL_ThreadHandle.id = 0;
LOCAL_ThreadHandle.in_use = TRUE;
LOCAL_ThreadHandle.default_yaam_regs =
&Yap_standard_regs;
LOCAL_ThreadHandle.current_yaam_regs =
&Yap_standard_regs;
LOCAL_PL_local_data_p->reg_cache =
&Yap_standard_regs;
LOCAL_ThreadHandle.pthread_handle = pthread_self();
pthread_mutex_init(&REMOTE_ThreadHandle(0).tlock, NULL);
pthread_mutex_init(&REMOTE_ThreadHandle(0).tlock_status, NULL);
LOCAL_ThreadHandle.tdetach = MkAtomTerm(AtomFalse);
LOCAL_ThreadHandle.ref_count = 1;
set_system_thread_id(0, NULL);
}

9
C/tracer.c
View File

@ -144,6 +144,15 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
LOCK(Yap_heap_regs->low_level_trace_lock);
sc = Yap_heap_regs;
vsc_count++;
fprintf(stderr,"in %p\n");
CELL * gc_ENV = ENV;
while (gc_ENV != NULL) { /* no more environments */
fprintf(stderr,"%ld\n", LCL0-gc_ENV);
gc_ENV = (CELL *) gc_ENV[E_E]; /* link to prev
* environment */
}
UNLOCK(Yap_heap_regs->low_level_trace_lock);
return;
#ifdef THREADS
LOCAL_ThreadHandle.thread_inst_count++;
#endif

2
H/absmi.h
View File

@ -160,6 +160,7 @@ register struct yami* P1REG asm ("bp"); /* can't use yamop before Yap.h */
#ifdef LOW_LEVEL_TRACER
#include "tracer.h"
#endif
#include "pl-shared.h"
#ifdef DEBUG
/**********************************************************************
* *
@ -198,6 +199,7 @@ restore_absmi_regs(REGSTORE * old_regs)
#ifdef THREADS
pthread_setspecific(Yap_yaamregs_key, (void *)old_regs);
LOCAL_ThreadHandle.current_yaam_regs = old_regs;
LOCAL_PL_local_data_p->reg_cache = old_regs;
#else
Yap_regp = old_regs;
#endif

71
H/iswiatoms.h
View File

@ -28,9 +28,9 @@
YAP_AtomToInt(Yap_LookupAtom("append"));
YAP_AtomToInt(Yap_LookupAtom("=:="));
YAP_AtomToInt(Yap_LookupAtom("=\\="));
YAP_AtomToInt(Yap_LookupAtom("arity"));
YAP_AtomToInt(Yap_LookupAtom("argument"));
YAP_AtomToInt(Yap_LookupAtom("argumentlimit"));
YAP_AtomToInt(Yap_LookupAtom("arity"));
YAP_AtomToInt(Yap_LookupAtom("as"));
YAP_AtomToInt(Yap_LookupAtom("ascii"));
YAP_AtomToInt(Yap_LookupAtom("asin"));
@ -46,8 +46,8 @@
YAP_AtomToInt(Yap_LookupAtom("@<"));
YAP_AtomToInt(Yap_LookupAtom("@=<"));
YAP_AtomToInt(Yap_LookupAtom("atan"));
YAP_AtomToInt(Yap_LookupAtom("atanh"));
YAP_AtomToInt(Yap_LookupAtom("atan2"));
YAP_AtomToInt(Yap_LookupAtom("atanh"));
YAP_AtomToInt(Yap_LookupAtom("atom"));
YAP_AtomToInt(Yap_LookupAtom("atom_garbage_collection"));
YAP_AtomToInt(Yap_LookupAtom("atomic"));
@ -56,9 +56,10 @@
YAP_AtomToInt(Yap_LookupAtom("attributes"));
YAP_AtomToInt(Yap_LookupAtom("attvar"));
YAP_AtomToInt(Yap_LookupAtom("autoload"));
YAP_AtomToInt(Yap_LookupAtom("backquoted_string"));
YAP_AtomToInt(Yap_LookupAtom("back_quotes"));
YAP_AtomToInt(Yap_LookupAtom("\\"));
YAP_AtomToInt(Yap_LookupAtom("backtrace"));
YAP_AtomToInt(Yap_LookupAtom("`"));
YAP_AtomToInt(Yap_LookupAtom("|"));
YAP_AtomToInt(Yap_LookupAtom("base"));
YAP_AtomToInt(Yap_LookupAtom("begin"));
@ -72,6 +73,7 @@
YAP_AtomToInt(Yap_LookupAtom("bool"));
YAP_AtomToInt(Yap_LookupAtom("boolean"));
YAP_AtomToInt(Yap_LookupAtom("brace_term_position"));
YAP_AtomToInt(Yap_LookupAtom("brace_terms"));
YAP_AtomToInt(Yap_LookupAtom("break"));
YAP_AtomToInt(Yap_LookupAtom("break_level"));
YAP_AtomToInt(Yap_LookupAtom("btree"));
@ -83,7 +85,6 @@
YAP_AtomToInt(Yap_LookupAtom("c_stack"));
YAP_AtomToInt(Yap_LookupAtom("call"));
YAP_AtomToInt(Yap_LookupAtom("callable"));
YAP_AtomToInt(Yap_LookupAtom("$callpred"));
YAP_AtomToInt(Yap_LookupAtom("canceled"));
YAP_AtomToInt(Yap_LookupAtom("case_sensitive_file_names"));
YAP_AtomToInt(Yap_LookupAtom("catch"));
@ -100,8 +101,8 @@
YAP_AtomToInt(Yap_LookupAtom("choice"));
YAP_AtomToInt(Yap_LookupAtom("class"));
YAP_AtomToInt(Yap_LookupAtom("clause"));
YAP_AtomToInt(Yap_LookupAtom("clauses"));
YAP_AtomToInt(Yap_LookupAtom("clause_reference"));
YAP_AtomToInt(Yap_LookupAtom("clauses"));
YAP_AtomToInt(Yap_LookupAtom("close"));
YAP_AtomToInt(Yap_LookupAtom("close_on_abort"));
YAP_AtomToInt(Yap_LookupAtom("close_on_exec"));
@ -113,6 +114,7 @@
YAP_AtomToInt(Yap_LookupAtom("collected"));
YAP_AtomToInt(Yap_LookupAtom("collections"));
YAP_AtomToInt(Yap_LookupAtom(":"));
YAP_AtomToInt(Yap_LookupAtom(":="));
YAP_AtomToInt(Yap_LookupAtom(","));
YAP_AtomToInt(Yap_LookupAtom("comments"));
YAP_AtomToInt(Yap_LookupAtom("compound"));
@ -132,14 +134,15 @@
YAP_AtomToInt(Yap_LookupAtom("{}"));
YAP_AtomToInt(Yap_LookupAtom("current"));
YAP_AtomToInt(Yap_LookupAtom("current_input"));
YAP_AtomToInt(Yap_LookupAtom("current_locale"));
YAP_AtomToInt(Yap_LookupAtom("current_output"));
YAP_AtomToInt(Yap_LookupAtom("!"));
YAP_AtomToInt(Yap_LookupAtom("cut_call"));
YAP_AtomToInt(Yap_LookupAtom("cut_exit"));
YAP_AtomToInt(Yap_LookupAtom("cut_parent"));
YAP_AtomToInt(Yap_LookupAtom("cut"));
YAP_AtomToInt(Yap_LookupAtom("cyclic_term"));
YAP_AtomToInt(Yap_LookupAtom("cycles"));
YAP_AtomToInt(Yap_LookupAtom("cyclic_term"));
YAP_AtomToInt(Yap_LookupAtom("$and"));
YAP_AtomToInt(Yap_LookupAtom("date"));
YAP_AtomToInt(Yap_LookupAtom("db_reference"));
@ -158,6 +161,7 @@
YAP_AtomToInt(Yap_LookupAtom("debugger_show_context"));
YAP_AtomToInt(Yap_LookupAtom("debugging"));
YAP_AtomToInt(Yap_LookupAtom("dec10"));
YAP_AtomToInt(Yap_LookupAtom("decimal_point"));
YAP_AtomToInt(Yap_LookupAtom("default"));
YAP_AtomToInt(Yap_LookupAtom("defined"));
YAP_AtomToInt(Yap_LookupAtom("delete"));
@ -173,7 +177,6 @@
YAP_AtomToInt(Yap_LookupAtom("directory"));
YAP_AtomToInt(Yap_LookupAtom("discontiguous"));
YAP_AtomToInt(Yap_LookupAtom("div"));
YAP_AtomToInt(Yap_LookupAtom("//"));
YAP_AtomToInt(Yap_LookupAtom("/"));
YAP_AtomToInt(Yap_LookupAtom("$load"));
YAP_AtomToInt(Yap_LookupAtom("$message_queue"));
@ -181,10 +184,13 @@
YAP_AtomToInt(Yap_LookupAtom("domain_error"));
YAP_AtomToInt(Yap_LookupAtom("dos"));
YAP_AtomToInt(Yap_LookupAtom("."));
YAP_AtomToInt(Yap_LookupAtom("dot_lists"));
YAP_AtomToInt(Yap_LookupAtom("dots"));
YAP_AtomToInt(Yap_LookupAtom("double_quotes"));
YAP_AtomToInt(Yap_LookupAtom("**"));
YAP_AtomToInt(Yap_LookupAtom("$parse_quasi_quotations"));
YAP_AtomToInt(Yap_LookupAtom("$profile_node"));
YAP_AtomToInt(Yap_LookupAtom("$quasi_quotation"));
YAP_AtomToInt(Yap_LookupAtom("$query_loop"));
YAP_AtomToInt(Yap_LookupAtom("$recover_and_rethrow"));
YAP_AtomToInt(Yap_LookupAtom("$stream"));
@ -192,7 +198,9 @@
YAP_AtomToInt(Yap_LookupAtom("$throw"));
YAP_AtomToInt(Yap_LookupAtom("$time"));
YAP_AtomToInt(Yap_LookupAtom("$toplevel"));
YAP_AtomToInt(Yap_LookupAtom("duplicate_key"));
YAP_AtomToInt(Yap_LookupAtom("$VAR$"));
YAP_AtomToInt(Yap_LookupAtom("$variable_names"));
YAP_AtomToInt(Yap_LookupAtom("$wakeup"));
YAP_AtomToInt(Yap_LookupAtom("dynamic"));
YAP_AtomToInt(Yap_LookupAtom("e"));
@ -210,6 +218,8 @@
YAP_AtomToInt(Yap_LookupAtom("="));
YAP_AtomToInt(Yap_LookupAtom("erase"));
YAP_AtomToInt(Yap_LookupAtom("erased"));
YAP_AtomToInt(Yap_LookupAtom("erf"));
YAP_AtomToInt(Yap_LookupAtom("erfc"));
YAP_AtomToInt(Yap_LookupAtom("error"));
YAP_AtomToInt(Yap_LookupAtom("eval"));
YAP_AtomToInt(Yap_LookupAtom("evaluable"));
@ -259,6 +269,7 @@
YAP_AtomToInt(Yap_LookupAtom("free_of_attvar"));
YAP_AtomToInt(Yap_LookupAtom("freeze"));
YAP_AtomToInt(Yap_LookupAtom("full"));
YAP_AtomToInt(Yap_LookupAtom("fullstop"));
YAP_AtomToInt(Yap_LookupAtom("functor_name"));
YAP_AtomToInt(Yap_LookupAtom("functors"));
YAP_AtomToInt(Yap_LookupAtom("fx"));
@ -268,6 +279,7 @@
YAP_AtomToInt(Yap_LookupAtom("gc"));
YAP_AtomToInt(Yap_LookupAtom("gcd"));
YAP_AtomToInt(Yap_LookupAtom("gctime"));
YAP_AtomToInt(Yap_LookupAtom("//"));
YAP_AtomToInt(Yap_LookupAtom("getcwd"));
YAP_AtomToInt(Yap_LookupAtom("global"));
YAP_AtomToInt(Yap_LookupAtom("global_shifts"));
@ -279,14 +291,15 @@
YAP_AtomToInt(Yap_LookupAtom("-->"));
YAP_AtomToInt(Yap_LookupAtom("graph"));
YAP_AtomToInt(Yap_LookupAtom("ground"));
YAP_AtomToInt(Yap_LookupAtom("grouping"));
YAP_AtomToInt(Yap_LookupAtom("gvar"));
YAP_AtomToInt(Yap_LookupAtom("halt"));
YAP_AtomToInt(Yap_LookupAtom("has_alternatives"));
YAP_AtomToInt(Yap_LookupAtom("hash"));
YAP_AtomToInt(Yap_LookupAtom("hashed"));
YAP_AtomToInt(Yap_LookupAtom("^"));
YAP_AtomToInt(Yap_LookupAtom("heapused"));
YAP_AtomToInt(Yap_LookupAtom("heap_gc"));
YAP_AtomToInt(Yap_LookupAtom("heapused"));
YAP_AtomToInt(Yap_LookupAtom("help"));
YAP_AtomToInt(Yap_LookupAtom("hidden"));
YAP_AtomToInt(Yap_LookupAtom("hide_childs"));
@ -326,9 +339,11 @@
YAP_AtomToInt(Yap_LookupAtom("jump"));
YAP_AtomToInt(Yap_LookupAtom("kernel"));
YAP_AtomToInt(Yap_LookupAtom("key"));
YAP_AtomToInt(Yap_LookupAtom("key_value_position"));
YAP_AtomToInt(Yap_LookupAtom(">"));
YAP_AtomToInt(Yap_LookupAtom(">="));
YAP_AtomToInt(Yap_LookupAtom("level"));
YAP_AtomToInt(Yap_LookupAtom("lgamma"));
YAP_AtomToInt(Yap_LookupAtom("li"));
YAP_AtomToInt(Yap_LookupAtom("library"));
YAP_AtomToInt(Yap_LookupAtom("limit"));
@ -342,6 +357,7 @@
YAP_AtomToInt(Yap_LookupAtom("local_shifts"));
YAP_AtomToInt(Yap_LookupAtom("local_stack"));
YAP_AtomToInt(Yap_LookupAtom("locale"));
YAP_AtomToInt(Yap_LookupAtom("locale_property"));
YAP_AtomToInt(Yap_LookupAtom("locallimit"));
YAP_AtomToInt(Yap_LookupAtom("localused"));
YAP_AtomToInt(Yap_LookupAtom("lock"));
@ -355,6 +371,10 @@
YAP_AtomToInt(Yap_LookupAtom("lsb"));
YAP_AtomToInt(Yap_LookupAtom("<<"));
YAP_AtomToInt(Yap_LookupAtom("main"));
YAP_AtomToInt(Yap_LookupAtom("map"));
YAP_AtomToInt(Yap_LookupAtom("map_position"));
YAP_AtomToInt(Yap_LookupAtom(">:<"));
YAP_AtomToInt(Yap_LookupAtom(":<"));
YAP_AtomToInt(Yap_LookupAtom("mark"));
YAP_AtomToInt(Yap_LookupAtom("matches"));
YAP_AtomToInt(Yap_LookupAtom("max"));
@ -374,6 +394,7 @@
YAP_AtomToInt(Yap_LookupAtom("message_queue_property"));
YAP_AtomToInt(Yap_LookupAtom("meta_argument"));
YAP_AtomToInt(Yap_LookupAtom("meta_argument_specifier"));
YAP_AtomToInt(Yap_LookupAtom("meta_atom"));
YAP_AtomToInt(Yap_LookupAtom("meta_predicate"));
YAP_AtomToInt(Yap_LookupAtom("min"));
YAP_AtomToInt(Yap_LookupAtom("min_free"));
@ -396,10 +417,12 @@
YAP_AtomToInt(Yap_LookupAtom("newline"));
YAP_AtomToInt(Yap_LookupAtom("next_argument"));
YAP_AtomToInt(Yap_LookupAtom("[]"));
YAP_AtomToInt(Yap_LookupAtom("nl"));
YAP_AtomToInt(Yap_LookupAtom("nlink"));
YAP_AtomToInt(Yap_LookupAtom("no_memory"));
YAP_AtomToInt(Yap_LookupAtom("nodebug"));
YAP_AtomToInt(Yap_LookupAtom("non_empty_list"));
YAP_AtomToInt(Yap_LookupAtom("non_terminal"));
YAP_AtomToInt(Yap_LookupAtom("none"));
YAP_AtomToInt(Yap_LookupAtom("nonvar"));
YAP_AtomToInt(Yap_LookupAtom("noprofile"));
@ -467,16 +490,24 @@
YAP_AtomToInt(Yap_LookupAtom("program"));
YAP_AtomToInt(Yap_LookupAtom("program_counter"));
YAP_AtomToInt(Yap_LookupAtom("prolog"));
YAP_AtomToInt(Yap_LookupAtom("prolog_atom_start"));
YAP_AtomToInt(Yap_LookupAtom("prolog_flag"));
YAP_AtomToInt(Yap_LookupAtom("prolog_flag_access"));
YAP_AtomToInt(Yap_LookupAtom("prolog_flag_option"));
YAP_AtomToInt(Yap_LookupAtom("prolog_flag_type"));
YAP_AtomToInt(Yap_LookupAtom("prolog_identifier_continue"));
YAP_AtomToInt(Yap_LookupAtom("prolog_symbol"));
YAP_AtomToInt(Yap_LookupAtom("prolog_var_start"));
YAP_AtomToInt(Yap_LookupAtom("|:"));
YAP_AtomToInt(Yap_LookupAtom("property"));
YAP_AtomToInt(Yap_LookupAtom("protocol"));
YAP_AtomToInt(Yap_LookupAtom(":-"));
YAP_AtomToInt(Yap_LookupAtom("public"));
YAP_AtomToInt(Yap_LookupAtom("punct"));
YAP_AtomToInt(Yap_LookupAtom("quasi_quotation"));
YAP_AtomToInt(Yap_LookupAtom("quasi_quotation_position"));
YAP_AtomToInt(Yap_LookupAtom("quasi_quotation_syntax"));
YAP_AtomToInt(Yap_LookupAtom("quasi_quotations"));
YAP_AtomToInt(Yap_LookupAtom("?-"));
YAP_AtomToInt(Yap_LookupAtom("?"));
YAP_AtomToInt(Yap_LookupAtom("queue_option"));
@ -505,6 +536,7 @@
YAP_AtomToInt(Yap_LookupAtom("references"));
YAP_AtomToInt(Yap_LookupAtom("rem"));
YAP_AtomToInt(Yap_LookupAtom("rename"));
YAP_AtomToInt(Yap_LookupAtom("repeat"));
YAP_AtomToInt(Yap_LookupAtom("report_error"));
YAP_AtomToInt(Yap_LookupAtom("reposition"));
YAP_AtomToInt(Yap_LookupAtom("representation_error"));
@ -580,6 +612,7 @@
YAP_AtomToInt(Yap_LookupAtom("strong"));
YAP_AtomToInt(Yap_LookupAtom("subterm_positions"));
YAP_AtomToInt(Yap_LookupAtom("suffix"));
YAP_AtomToInt(Yap_LookupAtom("symbol_char"));
YAP_AtomToInt(Yap_LookupAtom("syntax_error"));
YAP_AtomToInt(Yap_LookupAtom("syntax_errors"));
YAP_AtomToInt(Yap_LookupAtom("system"));
@ -598,6 +631,7 @@
YAP_AtomToInt(Yap_LookupAtom("test"));
YAP_AtomToInt(Yap_LookupAtom("text"));
YAP_AtomToInt(Yap_LookupAtom("text_stream"));
YAP_AtomToInt(Yap_LookupAtom("thousands_sep"));
YAP_AtomToInt(Yap_LookupAtom("thread"));
YAP_AtomToInt(Yap_LookupAtom("thread_cputime"));
YAP_AtomToInt(Yap_LookupAtom("thread_get_message_option"));
@ -678,8 +712,8 @@
YAP_AtomToInt(Yap_LookupAtom("wakeup"));
YAP_AtomToInt(Yap_LookupAtom("walltime"));
YAP_AtomToInt(Yap_LookupAtom("warning"));
YAP_AtomToInt(Yap_LookupAtom("weak"));
YAP_AtomToInt(Yap_LookupAtom("wchar_t"));
YAP_AtomToInt(Yap_LookupAtom("weak"));
YAP_AtomToInt(Yap_LookupAtom("when_condition"));
YAP_AtomToInt(Yap_LookupAtom("white"));
YAP_AtomToInt(Yap_LookupAtom("write"));
@ -725,7 +759,6 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_buffer_size),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_busy),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_call),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_callpred),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_catch),3);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_ceil),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_ceiling),1);
@ -755,6 +788,7 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dcut),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dde_error),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_debugging),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_decimal_point),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_detached),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dexit),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dforeign_registered),2);
@ -767,12 +801,15 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_domain_error),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dot),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_doublestar),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dparse_quasi_quotations),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dprof_node),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dquasi_quotation),3);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_drecover_and_rethrow),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dstream),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dthread_init),0);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dthrow),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dtime),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_duplicate_key),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dvard),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dwakeup),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_e),0);
@ -782,12 +819,15 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_epsilon),0);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_equals),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_erased),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_erf),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_erfc),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_error),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_eval),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_evaluation_error),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_exception),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_exception),3);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_existence_error),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_existence_error),3);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_exited),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_exp),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_exports),1);
@ -808,26 +848,31 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_gcd),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_goal_expansion),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_ground),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_grouping),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_hat),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_ifthen),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_import_into),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_input),0);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_input),3);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_input),4);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_integer),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_interrupt),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_io_error),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_is),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_isovar),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_key_value_position),7);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_larger),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_larger_equal),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_lgamma),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_line_count),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_list_position),4);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_listing),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_locale),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_locked),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_log),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_log10),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_lsb),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_lshift),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_map_position),5);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_max),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_max_size),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_message_lines),1);
@ -862,6 +907,8 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_prove),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_prove),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_punct),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_quasi_quotation),4);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_quasi_quotation_position),5);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_random),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_random_float),0);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_rational),1);
@ -869,6 +916,7 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_rdiv),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_redo),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_rem),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_repeat),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_reposition),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_representation_error),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_representation_errors),1);
@ -906,6 +954,7 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_tanh),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_term_expansion),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_term_position),5);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_thousands_sep),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_timeout),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_timeout_error),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_trace),1);

38
H/pl-global.h
View File

@ -36,7 +36,7 @@ typedef enum
CLN_DATA /* Remaining data */
} cleanup_status;
#ifdef O_PLMT
#ifdef THREADS
typedef struct free_chunk *FreeChunk; /* left-over chunk */
@ -262,6 +262,13 @@ typedef struct {
/* #endif */
} procedures;
#ifdef O_LOCALE
struct
{ Table localeTable; /* Name --> locale table */
PL_locale *default_locale; /* System wide default */
} locale;
#endif
} gds_t;
extern gds_t gds;
@ -382,29 +389,16 @@ typedef struct PL_local_data {
} gmp;
#endif
struct regstore_t *reg_cache; /* pointer to YAP registers */
#ifdef O_LOCALE
struct
{ PL_locale *current; /* Current locale */
} locale;
#endif
} PL_local_data_t;
#define usedStack(D) 0
#define features (LD->feature.mask)
extern PL_local_data_t lds;
#define exception_term (LD->exception.term)
#define Suser_input (LD->IO.streams[0])
#define Suser_output (LD->IO.streams[1])
#define Suser_error (LD->IO.streams[2])
#define Scurin (LD->IO.streams[3])
#define Scurout (LD->IO.streams[4])
#define Sprotocol (LD->IO.streams[5])
#define Sdin Suser_input /* not used for now */
#define Sdout Suser_output
#define source_line_no (LD->read_source.line)
#define source_file_name (LD->read_source.file)
#define source_line_pos (LD->read_source.linepos)
#define source_char_no (LD->read_source.character)
#define debugstatus (LD->_debugstatus)

78
H/pl-incl.h
View File

@ -5,40 +5,6 @@
#include "config.h"
#if USE_GMP
#define O_GMP 1
#endif
#ifdef __WINDOWS__
#include <windows.h>
#include <windows/uxnt.h>
#define O_HASDRIVES 1
#define O_HASSHARES 1
#define EMULATE_DLOPEN 1
#endif
#ifndef PL_CONSOLE
#define PL_KERNEL 1
#endif
#ifdef __MINGW32__
#define O_XOS 1
#endif
#ifndef __unix__
#if defined(_AIX) || defined(__APPLE__) || defined(__unix) || defined(__BEOS__) || defined(__NetBSD__)
#define __unix__ 1
#endif
#endif
#ifdef THREADS
#define O_PLMT 1
#else
#ifdef _REENTRANT
#undef _REENTRANT
#endif
#endif
#if HAVE_ERRNO_H
#include <errno.h>
#endif
@ -64,6 +30,7 @@
#ifdef H
#undef H
#endif
/* vsc: needs defining before getting rid of YAP locks */
static inline int
do_startCritical(void) {
@ -85,13 +52,34 @@ do_endCritical(void) {
#ifdef UNLOCK
#undef UNLOCK
#endif
#include "pl-shared.h"
#include <SWI-Stream.h>
#include <SWI-Prolog.h>
typedef int bool;
typedef int Char; /* char that can pass EOF */
typedef uintptr_t word; /* Anonymous 4 byte object */
#include "pl-shared.h"
#define usedStack(D) 0
#define exception_term (LD->exception.term)
#define Suser_input (LD->IO.streams[0])
#define Suser_output (LD->IO.streams[1])
#define Suser_error (LD->IO.streams[2])
#define Scurin (LD->IO.streams[3])
#define Scurout (LD->IO.streams[4])
#define Sprotocol (LD->IO.streams[5])
#define Sdin Suser_input /* not used for now */
#define Sdout Suser_output
#define source_line_no (LD->read_source.line)
#define source_file_name (LD->read_source.file)
#define source_line_pos (LD->read_source.linepos)
#define source_char_no (LD->read_source.character)
#define debugstatus (LD->_debugstatus)
#if SIZE_DOUBLE==SIZEOF_INT_P
#define WORDS_PER_DOUBLE 1
@ -532,7 +520,6 @@ typedef double real;
#endif
#define PL_unify_time(A,B) PL_unify_int64(A,B)
extern int PL_unify_char(term_t chr, int c, int how);
extern int PL_get_char(term_t chr, int *c, int eof);
extern void PL_cleanup_fork(void);
@ -786,6 +773,10 @@ setBoolean(int *flag, term_t old, term_t new)
}
COMMON(int) f_is_prolog_var_start(wint_t c);
COMMON(int) f_is_prolog_atom_start(wint_t c);
COMMON(int) f_is_prolog_identifier_continue(wint_t c);
COMMON(int) f_is_prolog_symbol(wint_t c);
COMMON(int) PL_get_atom__LD(term_t t1, atom_t *a ARG_LD);
@ -794,7 +785,10 @@ COMMON(int) PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD);
COMMON(int) PL_is_variable__LD(term_t t ARG_LD);
COMMON(term_t) PL_new_term_ref__LD(ARG1_LD);
COMMON(void) PL_put_term__LD(term_t t1, term_t t2 ARG_LD);
COMMON(int) PL_unify__LD(term_t t1, term_t t2 ARG_LD);
COMMON(int) PL_unify_atom__LD(term_t t, atom_t a ARG_LD);
COMMON(int) PL_unify_int64__LD(term_t t1, int64_t ARG_LD);
COMMON(int) PL_unify_int64_ex__LD(term_t t1, int64_t ARG_LD);
COMMON(int) PL_unify_integer__LD(term_t t1, intptr_t i ARG_LD);
COMMON(word) pl_get_prolog_flag(term_t key, term_t value);
@ -803,6 +797,17 @@ COMMON(foreign_t) pl_prolog_flag(term_t name, term_t value, control_t h);
COMMON(struct tm *) PL_localtime_r(const time_t *t, struct tm *r);
#define PL_unify(t1, t2) PL_unify__LD(t1, t2 PASS_LD)
#define PL_unify_int64(t, i) PL_unify_int64__LD(t, i PASS_LD)
#define PL_unify_int64_ex(t, i) PL_unify_int64_ex__LD(t, i PASS_LD)
static inline int
PL_unify_time(term_t t, time_t time) {
GET_LD
return PL_unify_int64(t, (int64_t)time);
}
/* inlines that need ARG_LD */
static inline intptr_t
skip_list(Word l, Word *tailp ARG_LD) {
@ -844,6 +849,7 @@ extern const PL_extension PL_predicates_from_tai[];
extern const PL_extension PL_predicates_from_write[];
extern const PL_extension PL_predicates_from_prologflag[];
extern const PL_extension PL_predicates_from_win[];
extern const PL_extension PL_predicates_from_locale[];
#define enableThreads(val) FALSE

80
H/pl-shared.h
View File

@ -1,82 +1,16 @@
#ifndef PL_SHARED_INCLUDE
#ifndef PL_SHARED_H
#define PL_SHARED_INCLUDE
#define PL_SHARED_H
#if defined(__GNUC__) && !defined(MAY_ALIAS)
#define MAY_ALIAS __attribute__ ((__may_alias__))
#else
#define MAY_ALIAS
#endif
#define COMMON(X) X
#ifndef PL_HAVE_TERM_T
#define PL_HAVE_TERM_T
typedef uintptr_t term_t;
#endif
#if !defined(_FLI_H_INCLUDED) && !defined(PL_INCL_H)
#ifdef __WINDOWS__
#include <windows.h>
#include <windows/uxnt.h>
#endif
typedef int bool;
typedef DBTerm *record_t;
typedef struct mod_entry *module_t;
typedef uintptr_t atom_t;
typedef int (*PL_dispatch_hook_t)(int fd);
typedef struct pred_entry *predicate_t;
typedef uintptr_t PL_fid_t; /* opaque foreign context handle */
#define fid_t PL_fid_t /* avoid AIX name-clash */
typedef uintptr_t word; /* Anonymous 4 byte object */
#endif
#define GLOBAL_LD (LOCAL_PL_local_data_p)
#if !defined(O_PLMT) && !defined(YAPOR)
#define LOCAL_LD (GLOBAL_LD)
#define LD (GLOBAL_LD)
#define ARG1_LD void
#define ARG_LD
#define GET_LD
#define PRED_LD
#define PASS_LD
#define PASS_LD1
#define IGNORE_LD
#else
#define LOCAL_LD (__PL_ld)
#define LD LOCAL_LD
#define GET_LD CACHE_REGS struct PL_local_data *__PL_ld = GLOBAL_LD;
#define ARG1_LD struct PL_local_data *__PL_ld
#define ARG_LD , ARG1_LD
#define PASS_LD1 LD
#define PASS_LD , LD
#define PRED_LD GET_LD
#define IGNORE_LD (void)__PL_ld;
#endif
#if _WIN32
#ifndef THREADS
typedef int pthread_t;
#endif
#endif
#include "pl-basic.h"
#include "SWI-Stream.h"
#define O_LOCALE 1
#include "pl-locale.h" /* Locale objects */
/*******************************
* STREAM I/O *
*******************************/

6
Makefile.in
View File

@ -214,6 +214,7 @@ IOLIB_SOURCES=$(srcdir)/os/pl-buffer.c $(srcdir)/os/pl-ctype.c \
$(srcdir)/os/pl-file.c \
$(srcdir)/os/pl-files.c \
$(srcdir)/os/pl-fmt.c \
$(srcdir)/os/pl-locale.h \
$(srcdir)/os/pl-glob.c \
$(srcdir)/os/pl-option.c \
$(srcdir)/os/pl-os.c \
@ -345,7 +346,7 @@ YAPDOCS=$(srcdir)/docs/yap.tex $(srcdir)/docs/chr.tex \
IOLIB_OBJECTS=pl-buffer.o pl-codelist.o pl-ctype.o pl-dtoa.o pl-error.o \
pl-file.o pl-files.o pl-fmt.o \
pl-glob.o pl-option.o \
pl-glob.o pl-locale.o pl-option.o \
pl-nt.o \
pl-os.o pl-privitf.o \
pl-prologflag.o \
@ -624,6 +625,9 @@ pl-fmt.o: $(srcdir)/os/pl-fmt.c config.h
pl-glob.o: $(srcdir)/os/pl-glob.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir)/include -I$(srcdir) -I$(srcdir)/os @EXTRA_INCLUDES_FOR_WIN32@ $(srcdir)/os/pl-glob.c -o $@
pl-locale.o: $(srcdir)/os/pl-locale.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir)/include -I$(srcdir) -I$(srcdir)/os @EXTRA_INCLUDES_FOR_WIN32@ $(srcdir)/os/pl-locale.c -o $@
pl-option.o: $(srcdir)/os/pl-option.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir)/include -I$(srcdir) -I$(srcdir)/os @EXTRA_INCLUDES_FOR_WIN32@ $(srcdir)/os/pl-option.c -o $@

2
config.h.in
View File

@ -263,6 +263,8 @@
#undef HAVE_SLEEP
#undef HAVE_SNPRINTF
#undef HAVE_SOCKET
#undef HAVE_SRAND
#undef HAVE_SRANDOM
#undef HAVE_STAT
#undef HAVE_STRCHR
#undef HAVE_STRERROR

3
configure vendored
View File

@ -8762,7 +8762,7 @@ _ACEOF
fi
done
for ac_func in signal sigprocmask socket stat
for ac_func in signal sigprocmask socket srand srandom stat
do :
as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`
ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
@ -12423,6 +12423,7 @@ while test $found = no; do
found=oops
else
_JTOPDIR="$_JTOPDIR2"
_JINC="$_JTOPDIR2/include"
fi
fi
done

2
configure.in
View File

@ -1558,7 +1558,7 @@ AC_CHECK_FUNCS(putenv rand random readlink regexec)
AC_CHECK_FUNCS(rename rint sbrk select setbuf)
AC_CHECK_FUNCS(setitimer setlocale setsid setlinebuf sigaction)
AC_CHECK_FUNCS(siggetmask siginterrupt)
AC_CHECK_FUNCS(signal sigprocmask socket stat)
AC_CHECK_FUNCS(signal sigprocmask socket srand srandom stat)
AC_CHECK_FUNCS(strchr strerror stricmp strlwr strncat strncpy strtod)
AC_CHECK_FUNCS(time times tmpnam usleep utime vsnprintf)

3
include/SWI-Prolog.h
View File

@ -139,7 +139,7 @@ typedef unsigned long uintptr_t;
typedef uintptr_t term_t;
#endif
typedef struct mod_entry *module_t;
typedef void *record_t;
typedef struct DB_STRUCT *record_t;
typedef uintptr_t atom_t;
typedef struct pred_entry *predicate_t;
typedef struct open_query_struct *qid_t;
@ -249,6 +249,7 @@ t */
#define CVT_ATOMIC (CVT_NUMBER|CVT_ATOM|CVT_STRING)
#define CVT_WRITE 0x0040 /* as of version 3.2.10 */
#define CVT_WRITE_CANONICAL 0x0080 /* as of version 3.2.10 */
#define CVT_WRITEQ 0x00C0
#define CVT_ALL (CVT_ATOMIC|CVT_LIST)
#define CVT_MASK 0x00ff

4
include/YapError.h
View File

@ -13,6 +13,9 @@
* version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ *
*************************************************************************/
#ifndef YAP_ERROR_H
#define YAP_ERROR_H 1
/* Types of Errors */
typedef enum
{
@ -118,3 +121,4 @@ typedef enum
} yap_error_number;
#endif

1711
include/dswiatoms.h
View File

File diff suppressed because it is too large Load Diff

3
library/dialect/swi/fli/swi.c
View File

@ -41,6 +41,8 @@
#include <yapio.h>
#include "pl-basic.h"
#ifdef USE_GMP
#include <gmp.h>
#endif
@ -54,7 +56,6 @@
extern X_API Atom YAP_AtomFromSWIAtom(atom_t at);
extern X_API atom_t YAP_SWIAtomFromAtom(Atom at);
extern int PL_error(const char *pred, int arity, const char *msg, int id, ...);
static int
do_gc(UInt sz)

72
misc/SWIATOMS
View File

@ -9,7 +9,6 @@
# produce pl-atom.ic, pl-atom.ih, pl-funct.ic and pl-funct.ih.
A abort "abort"
A aborted "$aborted"
A abs "abs"
@ -34,9 +33,9 @@ A anonvar "_"
A append "append"
A ar_equals "=:="
A ar_not_equal "=\\="
A arity "arity"
A argument "argument"
A argumentlimit "argumentlimit"
A arity "arity"
A as "as"
A ascii "ascii"
A asin "asin"
@ -52,8 +51,8 @@ A at_not_equals "\\=@="
A at_smaller "@<"
A at_smaller_eq "@=<"
A atan "atan"
A atanh "atanh"
A atan2 "atan2"
A atanh "atanh"
A atom "atom"
A atom_garbage_collection "atom_garbage_collection"
A atomic "atomic"
@ -62,9 +61,10 @@ A att "att"
A attributes "attributes"
A attvar "attvar"
A autoload "autoload"
A backquoted_string "backquoted_string"
A back_quotes "back_quotes"
A backslash "\\"
A backtrace "backtrace"
A backquoted_string "`"
A bar "|"
A base "base"
A begin "begin"
@ -78,6 +78,7 @@ A bom "bom"
A bool "bool"
A boolean "boolean"
A brace_term_position "brace_term_position"
A brace_terms "brace_terms"
A break "break"
A break_level "break_level"
A btree "btree"
@ -89,7 +90,6 @@ A byte "byte"
A c_stack "c_stack"
A call "call"
A callable "callable"
A callpred "$callpred"
A canceled "canceled"
A case_sensitive_file_names "case_sensitive_file_names"
A catch "catch"
@ -106,8 +106,8 @@ A chmod "chmod"
A choice "choice"
A class "class"
A clause "clause"
A clauses "clauses"
A clause_reference "clause_reference"
A clauses "clauses"
A close "close"
A close_on_abort "close_on_abort"
A close_on_exec "close_on_exec"
@ -119,6 +119,7 @@ A codes "codes"
A collected "collected"
A collections "collections"
A colon ":"
A colon_eq ":="
A comma ","
A comments "comments"
A compound "compound"
@ -138,14 +139,15 @@ A cumulative "cumulative"
A curl "{}"
A current "current"
A current_input "current_input"
A current_locale "current_locale"
A current_output "current_output"
A cut "!"
A cut_call "cut_call"
A cut_exit "cut_exit"
A cut_parent "cut_parent"
A cutted "cut"
A cyclic_term "cyclic_term"
A cycles "cycles"
A cyclic_term "cyclic_term"
A dand "$and"
A date "date"
A db_reference "db_reference"
@ -164,6 +166,7 @@ A debugger_print_options "debugger_print_options"
A debugger_show_context "debugger_show_context"
A debugging "debugging"
A dec10 "dec10"
A decimal_point "decimal_point"
A default "default"
A defined "defined"
A delete "delete"
@ -179,7 +182,6 @@ A digit "digit"
A directory "directory"
A discontiguous "discontiguous"
A div "div"
A gdiv "//"
A divide "/"
A dload "$load"
A dmessage_queue "$message_queue"
@ -187,10 +189,13 @@ A dmutex "$mutex"
A domain_error "domain_error"
A dos "dos"
A dot "."
A dot_lists "dot_lists"
A dots "dots"
A double_quotes "double_quotes"
A doublestar "**"
A dparse_quasi_quotations "$parse_quasi_quotations"
A dprof_node "$profile_node"
A dquasi_quotation "$quasi_quotation"
A dquery_loop "$query_loop"
A drecover_and_rethrow "$recover_and_rethrow"
A dstream "$stream"
@ -198,7 +203,9 @@ A dthread_init "$thread_init"
A dthrow "$throw"
A dtime "$time"
A dtoplevel "$toplevel"
A duplicate_key "duplicate_key"
A dvard "$VAR$"
A dvariable_names "$variable_names"
A dwakeup "$wakeup"
A dynamic "dynamic"
A e "e"
@ -216,6 +223,8 @@ A equal "equal"
A equals "="
A erase "erase"
A erased "erased"
A erf "erf"
A erfc "erfc"
A error "error"
A eval "eval"
A evaluable "evaluable"
@ -265,6 +274,7 @@ A frame_reference "frame_reference"
A free_of_attvar "free_of_attvar"
A freeze "freeze"
A full "full"
A fullstop "fullstop"
A functor_name "functor_name"
A functors "functors"
A fx "fx"
@ -274,6 +284,7 @@ A garbage_collection "garbage_collection"
A gc "gc"
A gcd "gcd"
A gctime "gctime"
A gdiv "//"
A getcwd "getcwd"
A global "global"
A global_shifts "global_shifts"
@ -285,14 +296,15 @@ A goal_expansion "goal_expansion"
A grammar "-->"
A graph "graph"
A ground "ground"
A grouping "grouping"
A gvar "gvar"
A halt "halt"
A has_alternatives "has_alternatives"
A hash "hash"
A hashed "hashed"
A hat "^"
A heapused "heapused"
A heap_gc "heap_gc"
A heapused "heapused"
A help "help"
A hidden "hidden"
A hide_childs "hide_childs"
@ -332,9 +344,11 @@ A join "join"
A jump "jump"
A kernel "kernel"
A key "key"
A key_value_position "key_value_position"
A larger ">"
A larger_equal ">="
A level "level"
A lgamma "lgamma"
A li "li"
A library "library"
A limit "limit"
@ -348,6 +362,7 @@ A local "local"
A local_shifts "local_shifts"
A local_stack "local_stack"
A locale "locale"
A locale_property "locale_property"
A locallimit "locallimit"
A localused "localused"
A lock "lock"
@ -361,6 +376,10 @@ A lower "lower"
A lsb "lsb"
A lshift "<<"
A main "main"
A map "map"
A map_position "map_position"
A map_punify ">:<"
A map_select ":<"
A mark "mark"
A matches "matches"
A max "max"
@ -380,6 +399,7 @@ A message_queue "message_queue"
A message_queue_property "message_queue_property"
A meta_argument "meta_argument"
A meta_argument_specifier "meta_argument_specifier"
A meta_atom "meta_atom"
A meta_predicate "meta_predicate"
A min "min"
A min_free "min_free"
@ -402,10 +422,12 @@ A natural "natural"
A newline "newline"
A next_argument "next_argument"
A nil "[]"
A nl "nl"
A nlink "nlink"
A no_memory "no_memory"
A nodebug "nodebug"
A non_empty_list "non_empty_list"
A non_terminal "non_terminal"
A none "none"
A nonvar "nonvar"
A noprofile "noprofile"
@ -473,16 +495,24 @@ A profile_node "profile_node"
A program "program"
A program_counter "program_counter"
A prolog "prolog"
A prolog_atom_start "prolog_atom_start"
A prolog_flag "prolog_flag"
A prolog_flag_access "prolog_flag_access"
A prolog_flag_option "prolog_flag_option"
A prolog_flag_type "prolog_flag_type"
A prolog_identifier_continue "prolog_identifier_continue"
A prolog_symbol "prolog_symbol"
A prolog_var_start "prolog_var_start"
A prompt "|:"
A property "property"
A protocol "protocol"
A prove ":-"
A public "public"
A punct "punct"
A quasi_quotation "quasi_quotation"
A quasi_quotation_position "quasi_quotation_position"
A quasi_quotation_syntax "quasi_quotation_syntax"
A quasi_quotations "quasi_quotations"
A query "?-"
A question_mark "?"
A queue_option "queue_option"
@ -511,6 +541,7 @@ A redo_in_skip "redo_in_skip"
A references "references"
A rem "rem"
A rename "rename"
A repeat "repeat"
A report_error "report_error"
A reposition "reposition"
A representation_error "representation_error"
@ -586,6 +617,7 @@ A string_position "string_position"
A strong "strong"
A subterm_positions "subterm_positions"
A suffix "suffix"
A symbol_char "symbol_char"
A syntax_error "syntax_error"
A syntax_errors "syntax_errors"
A system "system"
@ -604,6 +636,7 @@ A terminal_capability "terminal_capability"
A test "test"
A text "text"
A text_stream "text_stream"
A thousands_sep "thousands_sep"
A thread "thread"
A thread_cputime "thread_cputime"
A thread_get_message_option "thread_get_message_option"
@ -684,8 +717,8 @@ A wait "wait"
A wakeup "wakeup"
A walltime "walltime"
A warning "warning"
A weak "weak"
A wchar_t "wchar_t"
A weak "weak"
A when_condition "when_condition"
A white "white"
A write "write"
@ -732,7 +765,6 @@ F buffer 1
F buffer_size 1
F busy 2
F call 1
F callpred 2
F catch 3
F ceil 1
F ceiling 1
@ -762,6 +794,7 @@ F dcall 1
F dcut 1
F dde_error 2
F debugging 1
F decimal_point 1
F detached 1
F dexit 2
F dforeign_registered 2
@ -774,12 +807,15 @@ F dmutex 1
F domain_error 2
F dot 2
F doublestar 2
F dparse_quasi_quotations 2
F dprof_node 1
F dquasi_quotation 3
F drecover_and_rethrow 2
F dstream 1
F dthread_init 0
F dthrow 1
F dtime 2
F duplicate_key 1
F dvard 1
F dwakeup 1
F e 0
@ -789,12 +825,15 @@ F eof_action 1
F epsilon 0
F equals 2
F erased 1
F erf 1
F erfc 1
F error 2
F eval 1
F evaluation_error 1
F exception 1
F exception 3
F existence_error 2
F existence_error 3
F exited 1
F exp 1
F exports 1
@ -815,26 +854,31 @@ F frame_finished 1
F gcd 2
F goal_expansion 2
F ground 1
F grouping 1
F hat 2
F ifthen 2
F import_into 1
F input 0
F input 3
F input 4
F integer 1
F interrupt 1
F io_error 2
F is 2
F isovar 1
F key_value_position 7
F larger 2
F larger_equal 2
F lgamma 1
F line_count 1
F list_position 4
F listing 1
F locale 1
F locked 2
F log 1
F log10 1
F lsb 1
F lshift 2
F map_position 5
F max 2
F max_size 1
F message_lines 1
@ -869,6 +913,8 @@ F procedure 2
F prove 1
F prove 2
F punct 2
F quasi_quotation 4
F quasi_quotation_position 5
F random 1
F random_float 0
F rational 1
@ -876,6 +922,7 @@ F rationalize 1
F rdiv 2
F redo 1
F rem 2
F repeat 1
F reposition 1
F representation_error 1
F representation_errors 1
@ -913,6 +960,7 @@ F tan 1
F tanh 1
F term_expansion 2
F term_position 5
F thousands_sep 1
F timeout 1
F timeout_error 2
F trace 1

807
os/ATOMS
View File

@ -1,807 +0,0 @@
# Definition table of atoms functors used somewhere in the C-code.
# format:
#
# A <name> <string>: --> #define ATOM_<name> into <string>
# F <name> <arity> --> #define FUNCTOR_<name><arity>
# (A name should exist as well)
#
# This file is processed using the Unix awk program defineatoms to produce
# pl-atom.ic, pl-atom.ih, pl-funct.ic and pl-funct.ih. If you do not have
# awk you can propagate the changes by hand, but be careful!
A abort "abort"
A aborted "$aborted"
A abs "abs"
A access "access"
A acos "acos"
A agc "agc"
A agc_gained "agc_gained"
A agc_margin "agc_margin"
A agc_time "agc_time"
A alias "alias"
A allow_variable_name_as_functor "allow_variable_name_as_functor"
A alnum "alnum"
A alpha "alpha"
A alternative "alternative"
A and "/\\"
A anonvar "_"
A append "append"
A ar_equals "=:="
A ar_not_equal "=\\="
A argument "argument"
A argumentlimit "argumentlimit"
A ascii "ascii"
A asin "asin"
A assert "assert"
A asserta "asserta"
A at "at"
A at_equals "=@="
A at_exit "at_exit"
A at_larger "@>"
A at_larger_eq "@>="
A at_not_equals "\\=@="
A at_smaller "@<"
A at_smaller_eq "@=<"
A atan "atan"
A atom "atom"
A atom_garbage_collection "atom_garbage_collection"
A atomic "atomic"
A atoms "atoms"
A att "att"
A attributes "attributes"
A attvar "attvar"
A autoload "autoload"
A backquoted_string "backquoted_string"
A backslash "\\"
A backtrace "backtrace"
A bar "|"
A begin "begin"
A binary "binary"
A bind "bind"
A block "block"
A bof "bof"
A bom "bom"
A bool "bool"
A brace_term_position "brace_term_position"
A break "break"
A btree "btree"
A buffer "buffer"
A buffer_size "buffer_size"
A built_in_procedure "built_in_procedure"
A busy "busy"
A byte "byte"
A call "call"
A callable "callable"
A callpred "$callpred"
A canceled "canceled"
A case_sensitive_file_names "case_sensitive_file_names"
A catch "catch"
A ceil "ceil"
A ceiling "ceiling"
A char_type "char_type"
A character "character"
A character_code "character_code"
A character_escapes "character_escapes"
A chars "chars"
A chdir "chdir"
A chmod "chmod"
A choice "choice"
A clause "clause"
A clause_reference "clause_reference"
A close "close"
A close_on_abort "close_on_abort"
A close_option "close_option"
A cm "cm"
A cntrl "cntrl"
A co "co"
A codes "codes"
A collected "collected"
A collections "collections"
A colon ":"
A comma ","
A comments "comments"
A compound "compound"
A context "context"
A context_module "context_module"
A continue "continue"
A core "core"
A core_left "core_left"
A cos "cos"
A cputime "cputime"
A create "create"
A csym "csym"
A csymf "csymf"
A cumulative "cumulative"
A curl "{}"
A current "current"
A current_input "current_input"
A current_output "current_output"
A cut "!"
A cut_call "cut_call"
A cut_exit "cut_exit"
A cut_parent "cut_parent"
A cutted "cut"
A date "date"
A dc_call_prolog "$c_call_prolog"
A db_reference "db_reference"
A dcall "<meta-call>"
A dcall_cleanup "$call_cleanup"
A dcatch "$catch"
A dcut "$cut"
A dde_error "dde_error"
A dde_handle "dde_handle"
A debug "debug"
A debug_on_error "debug_on_error"
A debugger_print_options "debugger_print_options"
A debugger_show_context "debugger_show_context"
A debugging "debugging"
A dec10 "dec10"
A default "default"
A defined "defined"
A delete "delete"
A depth_limit_exceeded "depth_limit_exceeded"
A destroy "destroy"
A detached "detached"
A detect "detect"
A development "development"
A dexit "$exit"
A dforeign_registered "$foreign_registered"
A dgarbage_collect "$garbage_collect"
A digit "digit"
A directory "directory"
A discontiguous "discontiguous"
A div "//"
A divide "/"
A dload "$load"
A dmessage_queue "$message_queue"
A dmutex "$mutex"
A domain_error "domain_error"
A dos "dos"
A dot "."
A dots "dots"
A double_quotes "double_quotes"
A doublestar "**"
A dprof_node "$profile_node"
A dstream "$stream"
A dthread_init "$thread_init"
A dthrow "$throw"
A dtime "$time"
A dwakeup "$wakeup"
A dynamic "dynamic"
A e "e"
A encoding "encoding"
A end "end"
A end_of_file "end_of_file"
A end_of_line "end_of_line"
A end_of_stream "end_of_stream"
A environment "environment"
A eof "eof"
A eof_action "eof_action"
A eof_code "eof_code"
A equal "equal"
A equals "="
A erase "erase"
A erased "erased"
A error "error"
A eval "eval"
A evaluable "evaluable"
A evaluation_error "evaluation_error"
A exception "exception"
A exclusive "exclusive"
A execute "execute"
A exist "exist"
A existence_error "existence_error"
A exit "exit"
A exited "exited"
A exp "exp"
A export "export"
A exported "exported"
A expression "expression"
A externals "externals"
A fact "fact"
A factor "factor"
A fail "fail"
A failure_error "failure_error"
A false "false"
A feature "feature"
A file "file"
A file_name "file_name"
A file_name_variables "file_name_variables"
A file_no "file_no"
A flag "flag"
A flag_value "flag_value"
A float "float"
A float_format "float_format"
A float_fractional_part "float_fractional_part"
A float_integer_part "float_integer_part"
A float_overflow "float_overflow"
A float_underflow "float_underflow"
A floor "floor"
A force "force"
A foreign "foreign"
A foreign_function "$foreign_function"
A foreign_return_value "foreign_return_value"
A fork "fork"
A frame "frame"
A frame_attribute "frame_attribute"
A frame_finished "frame_finished"
A frame_reference "frame_reference"
A free_of_attvar "free_of_attvar"
A freeze "freeze"
A full "full"
A functor_name "functor_name"
A functors "functors"
A fx "fx"
A fy "fy"
A garbage_collected "<garbage_collected>"
A garbage_collection "garbage_collection"
A gc "gc"
A gctime "gctime"
A getcwd "getcwd"
A global "global"
A global_shifts "global_shifts"
A global_stack "global_stack"
A globallimit "globallimit"
A globalused "globalused"
A goal "goal"
A goal_expansion "goal_expansion"
A grammar "-->"
A graph "graph"
A gvar "gvar"
A halt "halt"
A has_alternatives "has_alternatives"
A hash "hash"
A hashed "hashed"
A hat "^"
A heap "heap"
A heaplimit "heaplimit"
A heapused "heapused"
A help "help"
A hidden "hidden"
A hide_childs "hide_childs"
A history_depth "history_depth"
A ifthen "->"
A ignore "ignore"
A ignore_ops "ignore_ops"
A imported "imported"
A imported_procedure "imported_procedure"
A index "index"
A indexed "indexed"
A inf "inf"
A inferences "inferences"
A infinite "infinite"
A informational "informational"
A init_file "init_file"
A initialization "initialization"
A input "input"
A inserted_char "inserted_char"
A instantiation_error "instantiation_error"
A int "int"
A int64_t "int64_t"
A int_overflow "int_overflow"
A integer "integer"
A interrupt "interrupt"
A io_error "io_error"
A io_mode "io_mode"
A ioctl "ioctl"
A is "is"
A iso "iso"
A iso_latin_1 "iso_latin_1"
A isovar "$VAR"
A join "join"
A jump "jump"
A kernel "kernel"
A key "key"
A larger ">"
A larger_equal ">="
A level "level"
A li "li"
A limit "limit"
A line "line"
A line_count "line_count"
A list "list"
A list_position "list_position"
A listing "listing"
A local "local"
A local_shifts "local_shifts"
A local_stack "local_stack"
A locale "locale"
A locallimit "locallimit"
A localused "localused"
A lock "lock"
A locked "locked"
A log "log"
A log10 "log10"
A long "long"
A low "low"
A lower "lower"
A lsb "lsb"
A lshift "<<"
A main "main"
A mark "mark"
A matches "matches"
A max "max"
A max_arity "max_arity"
A max_dde_handles "max_dde_handles"
A max_depth "max_depth"
A max_files "max_files"
A max_path_length "max_path_length"
A max_size "max_size"
A max_variable_length "max_variable_length"
A memory "memory"
A message "message"
A message_lines "message_lines"
A message_queue "message_queue"
A message_queue_property "message_queue_property"
A meta_predicate "meta_predicate"
A min "min"
A min_free "min_free"
A minus "-"
A mismatched_char "mismatched_char"
A mod "mod"
A mode "mode"
A modify "modify"
A module "module"
A module_property "module_property"
A module_transparent "module_transparent"
A modules "modules"
A msb "msb"
A multifile "multifile"
A mutex "mutex"
A mutex_option "mutex_option"
A mutex_property "mutex_property"
A natural "natural"
A newline "newline"
A nil "[]"
A no_memory "no_memory"
A nodebug "nodebug"
A non_empty_list "non_empty_list"
A none "none"
A noprofile "noprofile"
A not "not"
A not_equals "\\="
A not_implemented "not_implemented"
A not_less_than_one "not_less_than_one"
A not_less_than_zero "not_less_than_zero"
A not_provable "\\+"
A not_strickt_equals "\\=="
A not_unique "not_unique"
A number "number"
A number_of_clauses "number_of_clauses"
A numbervar_option "numbervar_option"
A numbervars "numbervars"
A occurs_check "occurs_check"
A octet "octet"
A off "off"
A on "on"
A open "open"
A operator "operator"
A operator_priority "operator_priority"
A operator_specifier "operator_specifier"
A optimise "optimise"
A or "\\/"
A order "order"
A output "output"
A pair "pair"
A paren "paren"
A parent "parent"
A parent_goal "parent_goal"
A past "past"
A past_end_of_stream "past_end_of_stream"
A pattern "pattern"
A pc "pc"
A period "period"
A permission_error "permission_error"
A pi "pi"
A pipe "pipe"
A plain "plain"
A plus "+"
A popcount "popcount"
A portray "portray"
A position "position"
A posix "posix"
A powm "powm"
A predicate_indicator "predicate_indicator"
A predicates "predicates"
A print "print"
A print_message "print_message"
A priority "priority"
A private_procedure "private_procedure"
A procedure "procedure"
A profile_mode "profile_mode"
A profile_no_cpu_time "profile_no_cpu_time"
A profile_node "profile_node"
A program "program"
A program_counter "program_counter"
A prolog "prolog"
A prompt "|:"
A property "property"
A protocol "protocol"
A prove ":-"
A punct "punct"
A query "?-"
A queue_option "queue_option"
A quiet "quiet"
A quote "quote"
A quoted "quoted"
A radix "radix"
A random "random"
A rational "rational"
A rationalize "rationalize"
A rdiv "rdiv"
A read "read"
A read_option "read_option"
A readline "readline"
A real_time "real_time"
A receiver "receiver"
A record "record"
A record_position "record_position"
A redefine "redefine"
A redo "redo"
A references "references"
A rem "rem"
A rename "rename"
A report_error "report_error"
A reposition "reposition"
A representation_error "representation_error"
A representation_errors "representation_errors"
A reset "reset"
A resource_error "resource_error"
A resource_handle "resource_handle"
A retry "retry"
A round "round"
A rshift ">>"
A running "running"
A runtime "runtime"
A save_class "save_class"
A save_option "save_option"
A seek_method "seek_method"
A select "select"
A semicolon ";"
A separated "separated"
A setup_and_call_cleanup "setup_and_call_cleanup"
A shared "shared"
A shared_object "shared_object"
A shared_object_handle "shared_object_handle"
A shell "shell"
A sign "sign"
A signal "signal"
A signal_handler "signal_handler"
A silent "silent"
A sin "sin"
A singletons "singletons"
A size "size"
A skip "skip"
A smaller "<"
A smaller_equal "=<"
A softcut "*->"
A source_sink "source_sink"
A space "space"
A spy "spy"
A sqrt "sqrt"
A stack "stack"
A stack_parameter "stack_parameter"
A stack_shifts "stack_shifts"
A stacks "stacks"
A stand_alone "stand_alone"
A star "*"
A start "start"
A stat "stat"
A static_procedure "static_procedure"
A statistics "statistics"
A status "status"
A stderr "stderr"
A stream "stream"
A stream_option "stream_option"
A stream_or_alias "stream_or_alias"
A stream_position "$stream_position"
A stream_property "stream_property"
A strict_equal "=="
A string "string"
A string_position "string_position"
A subterm_positions "subterm_positions"
A suffix "suffix"
A syntax_error "syntax_error"
A syntax_errors "syntax_errors"
A system "system"
A system_error "system_error"
A system_init_file "system_init_file"
A system_thread_id "system_thread_id"
A system_time "system_time"
A tan "tan"
A term "term"
A term_expansion "term_expansion"
A term_position "term_position"
A terminal "terminal"
A terminal_capability "terminal_capability"
A text "text"
A thread "thread"
A thread_cputime "thread_cputime"
A thread_initialization "thread_initialization"
A thread_local "thread_local"
A thread_local_procedure "thread_local_procedure"
A thread_option "thread_option"
A thread_property "thread_property"
A threads "threads"
A threads_created "threads_created"
A throw "throw"
A tilde "~"
A time "time"
A time_stamp "time_stamp"
A timeout "timeout"
A timeout_error "timeout_error"
A timezone "timezone"
A to_lower "to_lower"
A to_upper "to_upper"
A top "top"
A top_level "top_level"
A toplevel "toplevel"
A trace "trace"
A trace_any "trace_any"
A trace_call "trace_call"
A trace_exit "trace_exit"
A trace_fail "trace_fail"
A trace_gc "trace_gc"
A trace_redo "trace_redo"
A traceinterc "prolog_trace_interception"
A tracing "tracing"
A trail "trail"
A trail_shifts "trail_shifts"
A traillimit "traillimit"
A trailused "trailused"
A transparent "transparent"
A transposed_char "transposed_char"
A transposed_word "transposed_word"
A true "true"
A truncate "truncate"
A tty "tty"
A tty_control "tty_control"
A type "type"
A type_error "type_error"
A undefined "undefined"
A undefined_global_variable "undefined_global_variable"
A undefinterc "$undefined_procedure"
A unicode_be "unicode_be"
A unicode_le "unicode_le"
A unify "unify"
A unique "unique"
A univ "=.."
A unknown "unknown"
A unlimited "unlimited"
A unlock "unlock"
A unlocked "unlocked"
A update "update"
A upper "upper"
A user "user"
A user_error "user_error"
A user_input "user_input"
A user_output "user_output"
A utc "UTC"
A utf8 "utf8"
A v "v"
A var "$VAR$"
A variable "variable"
A variable_names "variable_names"
A variables "variables"
A very_deep "very_deep"
A vmi "vmi"
A volatile "volatile"
A wakeup "wakeup"
A warning "warning"
A wchar_t "wchar_t"
A white "white"
A write "write"
A write_attributes "write_attributes"
A write_option "write_option"
A xdigit "xdigit"
A xf "xf"
A xfx "xfx"
A xfy "xfy"
A xml "xml"
A xor "xor"
A xpceref "@"
A yf "yf"
A yfx "yfx"
A yfy "yfy"
A zero_divisor "zero_divisor"
F abs 1
F access 1
F acos 1
F alias 1
F and 2
F ar_equals 2
F ar_not_equal 2
F asin 1
F assert 1
F asserta 1
F atan 1
F atan 2
F atom 1
F att 3
F backslash 1
F bar 2
F block 3
F bom 1
F brace_term_position 3
F break 1
F break 3
F buffer 1
F buffer_size 1
F busy 2
F call 1
F callpred 2
F catch 3
F ceil 1
F ceiling 1
F chars 1
F chars 2
F clause 1
F close_on_abort 1
F codes 1
F codes 2
F colon 2
F comma 2
F context 2
F cos 1
F cputime 0
F curl 1
F cut_call 1
F cut_exit 1
F date 9
F dcall 1
F dcut 1
F dde_error 2
F debugging 1
F detached 1
F dexit 2
F dforeign_registered 2
F dgarbage_collect 1
F div 2
F divide 2
F dmessage_queue 1
F dmutex 1
F domain_error 2
F dot 2
F doublestar 2
F dprof_node 1
F dstream 1
F dthread_init 0
F dthrow 1
F dtime 2
F dwakeup 1
F e 0
F encoding 1
F end_of_stream 1
F eof_action 1
F equals 2
F erased 1
F error 2
F eval 1
F evaluation_error 1
F exception 1
F exception 3
F existence_error 2
F exited 1
F exp 1
F fail 0
F failure_error 1
F file 1
F file 4
F file_name 1
F file_no 1
F float 1
F float_fractional_part 1
F float_integer_part 1
F floor 1
F foreign_function 1
F frame 3
F frame_finished 1
F goal_expansion 2
F hat 2
F ifthen 2
F input 0
F integer 1
F interrupt 1
F io_error 2
F is 2
F isovar 1
F larger 2
F larger_equal 2
F line_count 1
F list_position 4
F listing 1
F locked 2
F log 1
F log10 1
F lsb 1
F lshift 2
F max 2
F max_size 1
F message_lines 1
F min 2
F minus 1
F minus 2
F mod 2
F mode 1
F msb 1
F newline 1
F not_implemented 2
F not_provable 1
F occurs_check 2
F or 2
F output 0
F permission_error 3
F pi 0
F pipe 1
F plus 1
F plus 2
F popcount 1
F portray 1
F position 1
F powm 3
F print 1
F print_message 2
F procedure 2
F prove 1
F prove 2
F punct 2
F random 1
F rational 1
F rationalize 1
F rdiv 2
F rem 2
F reposition 1
F representation_error 1
F representation_errors 1
F resource_error 1
F retry 1
F round 1
F rshift 2
F semicolon 2
F setup_and_call_cleanup 4
F shared_object 2
F shell 2
F sign 1
F signal 1
F signal 2
F sin 1
F singletons 1
F size 1
F smaller 2
F smaller_equal 2
F softcut 2
F spy 1
F sqrt 1
F star 2
F status 1
F stream 4
F stream_position 4
F string 1
F string 2
F string_position 2
F syntax_error 1
F syntax_error 3
F tan 1
F term_expansion 2
F term_position 5
F timeout 1
F timeout_error 2
F trace 1
F traceinterc 3
F tracing 1
F true 0
F truncate 1
F tty 1
F type 1
F type_error 2
F undefinterc 4
F var 1
F wakeup 3
F warning 3
F xor 2
F xpceref 1
F dc_call_prolog 0
F strict_equal 2

8
os/SWI-Stream.h
View File

@ -168,7 +168,11 @@ typedef struct io_stream
int io_errno; /* Save errno value */
void * exception; /* pending exception (record_t) */
void * context; /* getStreamContext() */
intptr_t reserved[2]; /* reserved for extension */
intptr_t reserved[0]; /* reserved for extension */
struct PL_locale * locale; /* Locale associated to stream */
#if 0 /* We used them all :-( */
intptr_t reserved[0]; /* reserved for extension */
#endif
} IOSTREAM;
#define SmakeFlag(n) (1<<(n-1))
@ -378,6 +382,8 @@ PL_EXPORT(void) Ssetbuffer(IOSTREAM *s, char *buf, size_t size);
PL_EXPORT(int64_t) Stell64(IOSTREAM *s);
PL_EXPORT(int) Sseek64(IOSTREAM *s, int64_t pos, int whence);
PL_EXPORT(int) Ssetlocale(IOSTREAM *s, struct PL_locale *n, struct PL_locale **old);
#ifdef __WINDOWS__
#if defined(_WINSOCKAPI_) || defined(NEEDS_SWINSOCK)
PL_EXPORT(SOCKET) Swinsock(IOSTREAM *s);

70
os/pl-ctype.c
View File

@ -205,32 +205,37 @@ mkfunction(iswpunct)
mkfunction(iswspace)
static const char_type char_types[] =
{ { ATOM_alnum, fiswalnum },
{ ATOM_alpha, fiswalpha },
{ ATOM_csym, fiscsym },
{ ATOM_csymf, fiscsymf },
{ ATOM_ascii, fisascii },
{ ATOM_white, iswhite },
{ ATOM_cntrl, fiswcntrl },
{ ATOM_digit, fiswdigit },
{ ATOM_graph, fiswgraph },
{ ATOM_lower, fiswlower },
{ ATOM_upper, fiswupper },
{ ATOM_punct, fiswpunct },
{ ATOM_space, fiswspace },
{ ATOM_end_of_file, iseof },
{ ATOM_end_of_line, iseol },
{ ATOM_newline, isnl },
{ ATOM_period, isperiod },
{ ATOM_quote, isquote },
{ ATOM_lower, fupper, flower, 1, CTX_CHAR },
{ ATOM_upper, flower, fupper, 1, CTX_CHAR },
{ ATOM_to_lower, ftoupper, ftolower, 1, CTX_CHAR },
{ ATOM_to_upper, ftolower, ftoupper, 1, CTX_CHAR },
{ ATOM_paren, fparen, rparen, 1, CTX_CHAR },
{ ATOM_digit, fdigit, rdigit, 1, CTX_CODE },
{ ATOM_xdigit, fxdigit, rxdigit, 1, CTX_CODE },
{ NULL_ATOM, NULL }
{ { ATOM_alnum, fiswalnum },
{ ATOM_alpha, fiswalpha },
{ ATOM_csym, fiscsym },
{ ATOM_csymf, fiscsymf },
{ ATOM_prolog_var_start, f_is_prolog_var_start },
{ ATOM_prolog_atom_start, f_is_prolog_atom_start },
{ ATOM_prolog_identifier_continue, f_is_prolog_identifier_continue },
{ ATOM_prolog_symbol, f_is_prolog_symbol },
{ ATOM_csymf, fiscsymf },
{ ATOM_ascii, fisascii },
{ ATOM_white, iswhite },
{ ATOM_cntrl, fiswcntrl },
{ ATOM_digit, fiswdigit },
{ ATOM_graph, fiswgraph },
{ ATOM_lower, fiswlower },
{ ATOM_upper, fiswupper },
{ ATOM_punct, fiswpunct },
{ ATOM_space, fiswspace },
{ ATOM_end_of_file, iseof },
{ ATOM_end_of_line, iseol },
{ ATOM_newline, isnl },
{ ATOM_period, isperiod },
{ ATOM_quote, isquote },
{ ATOM_lower, fupper, flower, 1, CTX_CHAR },
{ ATOM_upper, flower, fupper, 1, CTX_CHAR },
{ ATOM_to_lower, ftoupper, ftolower, 1, CTX_CHAR },
{ ATOM_to_upper, ftolower, ftoupper, 1, CTX_CHAR },
{ ATOM_paren, fparen, rparen, 1, CTX_CHAR },
{ ATOM_digit, fdigit, rdigit, 1, CTX_CODE },
{ ATOM_xdigit, fxdigit, rxdigit, 1, CTX_CODE },
{ NULL_ATOM, NULL }
};
@ -681,7 +686,7 @@ so we ignore possible problems.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int
initLocale(void)
init_locale(void)
{ int rc = TRUE;
if ( !setlocale(LC_CTYPE, "") )
@ -741,9 +746,16 @@ PRED_IMPL("setlocale", 3, setlocale, 0)
if ( PL_compare(A2, A3) != 0 )
{ if ( !setlocale(lcp->category, locale) )
{ if ( errno == ENOENT )
return PL_existence_error("locale", A3);
return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setlocale");
}
}
#ifdef O_LOCALE
updateLocale(lcp->category, locale);
#endif
succeed;
}
}
@ -753,7 +765,7 @@ PRED_IMPL("setlocale", 3, setlocale, 0)
#else
#define initLocale() 1
#define init_locale() 1
static
PRED_IMPL("setlocale", 3, setlocale, 0)
@ -836,7 +848,7 @@ initEncoding(void)
{ if ( !LD->encoding )
{ char *enc;
if ( !initLocale() )
if ( !init_locale() )
{ LD->encoding = ENC_ISO_LATIN_1;
} else if ( (enc = setlocale(LC_CTYPE, NULL)) )
{ LD->encoding = ENC_ANSI; /* text encoding */

13
os/pl-ctype.h
View File

@ -1,11 +1,10 @@
/* $Id$
Part of SWI-Prolog
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
Copyright (C): 1985-2013, University of Amsterdam
VU University Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -53,8 +52,8 @@ extern const char _PL_char_types[]; /* array of character types */
#define makeLower(c) ((c) >= 'A' && (c) <= 'Z' ? toLower(c) : (c))
#define matchingBracket(c) ((c) == '[' ? ']' :\
'{' ? '}' :\
'(' ? ')' : EOS)
(c) == '{' ? '}' :\
(c) == '(' ? ')' : EOS)
#define Control(c) ((c) == '?' ? 127 : (c) - '@')

1
os/pl-dtoa.h
View File

@ -25,6 +25,7 @@
#ifndef PL_DTOA_H_INCLUDED
#define PL_DTOA_H_INCLUDED
#define dtoa PL_dtoa /* avoid library conflicts */
#define strtod PL_strtod /* avoid library conflicts */
COMMON(char *) dtoa(double dd, int mode, int ndigits,

29
os/pl-error.c
View File

@ -97,6 +97,28 @@ PL_get_intptr_ex(term_t t, intptr_t *i)
}
int
PL_get_size_ex(term_t t, size_t *i)
{ int64_t val;
if ( !PL_get_int64_ex(t, &val) )
fail;
if ( val < 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_not_less_than_zero, t);
#if SIZEOF_VOIDP < 8
#if SIZEOF_LONG == SIZEOF_VOIDP
if ( val > (int64_t)ULONG_MAX )
return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_size_t);
#endif
#endif
*i = (size_t)val;
return TRUE;
}
int
PL_get_bool_ex(term_t t, int *i)
{ if ( PL_get_bool(t, i) )
@ -268,6 +290,11 @@ PL_resource_error(const char *resource)
return rc;
}
int
PL_no_memory(void)
{ return PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_memory);
}
word
@ -275,7 +302,7 @@ notImplemented(char *name, int arity)
{ return (word)PL_error(NULL, 0, NULL, ERR_NOT_IMPLEMENTED_PROC, name, arity);
}
X_API int PL_error(const char *pred, int arity, const char *msg, int id, ...)
int PL_error(const char *pred, int arity, const char *msg, PL_error_code id, ...)
{
GET_LD
char msgbuf[50];

21
os/pl-error.h
View File

@ -19,9 +19,13 @@
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef COMMON
#define COMMON(type) extern type
#endif
typedef enum
{ ERR_NO_ERROR = 0,
/* Used in os-directory and maybe elsewhere */
@ -47,8 +51,10 @@ typedef enum
/* Only used on SWI-Prolog itself */
ERR_AR_OVERFLOW, /* void */
ERR_AR_TYPE, /* atom_t expected, Number value */
ERR_AR_DOMAIN, /* atom_t domain, Number value */
ERR_AR_UNDEF, /* void */
ERR_AR_UNDERFLOW, /* void */
ERR_PTR_TYPE, /* atom_t expected, Word value */
ERR_BUSY, /* mutexes */
ERR_CHARS_TYPE, /* char *, term */
ERR_CLOSED_STREAM, /* IOSTREAM * */
@ -60,6 +66,7 @@ typedef enum
ERR_MODIFY_THREAD_LOCAL_PROC, /* Procedure proc */
ERR_NOT_EVALUABLE, /* functor_t func */
ERR_NOT_IMPLEMENTED_PROC, /* name, arity */
ERR_IMPORT_PROC, /* proc, dest, [already-from] */
ERR_OCCURS_CHECK, /* Word, Word */
ERR_PERMISSION_PROC, /* op, type, Definition */
ERR_SHARED_OBJECT_OP, /* op, error */
@ -70,6 +77,12 @@ typedef enum
#define MSG_ERRNO ((char *)(-1))
int PL_error(const char *pred, int arity, const char *msg, int id, ...);
int printMessage(atom_t severity, ...);
void unallocStream(IOSTREAM *s);
COMMON(int) PL_error(const char *pred, int arity, const char *msg,
PL_error_code id, ...);
COMMON(int) PL_no_memory(void);
COMMON(int) printMessage(atom_t severity, ...);
#ifdef ARG_LD
COMMON(int) PL_get_atom_ex__LD(term_t t, atom_t *a ARG_LD);
#endif
COMMON(int) PL_get_module_ex(term_t name, module_t *m);
COMMON(int) PL_get_arg_ex(int n, term_t term, term_t arg);

722
os/pl-file.c
View File

@ -55,6 +55,7 @@ handling times must be cleaned, but that not only holds for this module.
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#include <fcntl.h>
#endif
#ifdef HAVE_BSTRING_H
#include <bstring.h>
@ -298,7 +299,7 @@ freeStream(IOSTREAM *s)
/* name must be registered by the caller */
static void
setFileNameStream(IOSTREAM *s, atom_t name)
setFileNameStream_unlocked(IOSTREAM *s, atom_t name)
{ stream_context *ctx = getStreamContext(s);
if ( ctx->filename )
@ -310,6 +311,17 @@ setFileNameStream(IOSTREAM *s, atom_t name)
}
int
setFileNameStream(IOSTREAM *s, atom_t name)
{ LOCK();
setFileNameStream_unlocked(s, name);
PL_register_atom(name);
UNLOCK();
return TRUE;
}
atom_t
fileNameStream(IOSTREAM *s)
{ atom_t name;
@ -326,7 +338,7 @@ static void init_yap(void);
#endif
void
initIO()
initIO(void)
{ GET_LD
const atom_t *np;
int i;
@ -334,14 +346,13 @@ initIO()
streamAliases = newHTable(16);
streamContext = newHTable(16);
PL_register_blob_type(&stream_blob);
#ifdef __unix__
{ int fd;
if ( (fd=Sfileno(Sinput)) < 0 || !isatty(fd) ||
(fd=Sfileno(Soutput)) < 0 || !isatty(fd) )
if ( false(Sinput, SIO_ISATTY) ||
false(Soutput, SIO_ISATTY) )
{ /* clear PLFLAG_TTY_CONTROL */
PL_set_prolog_flag("tty_control", PL_BOOL, FALSE);
}
#endif
}
ResetTty();
#if __YAP_PROLOG__
/* needs to be done after tty hacking */
@ -1221,19 +1232,24 @@ current input context.
static
PRED_IMPL("$input_context", 1, input_context, 0)
{ PRED_LD
term_t tail = PL_copy_term_ref(A1);
term_t head = PL_new_term_ref();
term_t tail = PL_copy_term_ref(A1);
term_t head = PL_new_term_ref();
term_t stream = PL_new_term_ref();
InputContext c = input_context_stack;
for(c=input_context_stack; c; c=c->previous)
{ atom_t file = c->term_file ? c->term_file : ATOM_minus;
int line = c->term_file ? c->term_line : 0;
if ( !PL_unify_list(tail, head, tail) ||
!PL_unify_term(head, PL_FUNCTOR, FUNCTOR_input3,
PL_put_variable(stream);
if ( !PL_unify_stream_or_alias(stream, c->stream) ||
!PL_unify_list(tail, head, tail) ||
!PL_unify_term(head, PL_FUNCTOR, FUNCTOR_input4,
PL_ATOM, c->type,
PL_ATOM, file,
PL_INT, line) )
PL_INT, line,
PL_TERM, stream) )
return FALSE;
}
@ -1357,21 +1373,23 @@ closeOutputRedirect(redir_context *ctx)
term_t out = PL_new_term_ref();
term_t diff, tail;
closeStream(ctx->stream);
_PL_get_arg(1, ctx->term, out);
if ( ctx->out_arity == 2 )
{ diff = PL_new_term_ref();
_PL_get_arg(2, ctx->term, diff);
tail = PL_new_term_ref();
} else
{ diff = tail = 0;
}
if ( Sclose(ctx->stream) == 0 )
{ _PL_get_arg(1, ctx->term, out);
if ( ctx->out_arity == 2 )
{ diff = PL_new_term_ref();
_PL_get_arg(2, ctx->term, diff);
tail = PL_new_term_ref();
} else
{ diff = tail = 0;
}
rval = PL_unify_wchars_diff(out, tail, ctx->out_format,
ctx->size/sizeof(wchar_t),
(wchar_t*)ctx->data);
if ( rval && tail )
rval = PL_unify(tail, diff);
rval = PL_unify_wchars_diff(out, tail, ctx->out_format,
ctx->size/sizeof(wchar_t),
(wchar_t*)ctx->data);
if ( rval && tail )
rval = PL_unify(tail, diff);
} else
rval = FALSE;
if ( ctx->data != ctx->buffer )
Sfree(ctx->data);
@ -1673,287 +1691,348 @@ setCloseOnExec(IOSTREAM *s, int val)
return TRUE;
}
/* returns TRUE: ok, FALSE: error, -1: not available
*/
static int
set_stream(IOSTREAM *s, term_t stream, atom_t aname, term_t a ARG_LD)
{ if ( aname == ATOM_alias ) /* alias(name) */
{ atom_t alias;
int i;
if ( !PL_get_atom_ex(a, &alias) )
return FALSE;
if ( (i=standardStreamIndexFromName(alias)) >= 0 )
{ LD->IO.streams[i] = s;
if ( i == 0 )
LD->prompt.next = TRUE; /* changed standard input: prompt! */
return TRUE;
}
LOCK();
aliasStream(s, alias);
UNLOCK();
return TRUE;
} else if ( aname == ATOM_buffer ) /* buffer(Buffering) */
{ atom_t b;
#define SIO_ABUF (SIO_FBUF|SIO_LBUF|SIO_NBUF)
if ( !PL_get_atom_ex(a, &b) )
return FALSE;
if ( b == ATOM_full )
{ s->flags &= ~SIO_ABUF;
s->flags |= SIO_FBUF;
} else if ( b == ATOM_line )
{ s->flags &= ~SIO_ABUF;
s->flags |= SIO_LBUF;
} else if ( b == ATOM_false )
{ Sflush(s);
s->flags &= ~SIO_ABUF;
s->flags |= SIO_NBUF;
} else
{ return PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_buffer, a);
}
return TRUE;
} else if ( aname == ATOM_buffer_size )
{ int size;
if ( !PL_get_integer_ex(a, &size) )
return FALSE;
if ( size < 1 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, a);
Ssetbuffer(s, NULL, size);
return TRUE;
} else if ( aname == ATOM_eof_action ) /* eof_action(Action) */
{ atom_t action;
if ( !PL_get_atom_ex(a, &action) )
return FALSE;
if ( action == ATOM_eof_code )
{ s->flags &= ~(SIO_NOFEOF|SIO_FEOF2ERR);
} else if ( action == ATOM_reset )
{ s->flags &= ~SIO_FEOF2ERR;
s->flags |= SIO_NOFEOF;
} else if ( action == ATOM_error )
{ s->flags &= ~SIO_NOFEOF;
s->flags |= SIO_FEOF2ERR;
} else
{ PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_eof_action, a);
return FALSE;
}
return TRUE;
} else if ( aname == ATOM_type ) /* type(Type) */
{ atom_t type;
if ( !PL_get_atom_ex(a, &type) )
return FALSE;
if ( type == ATOM_text )
{ if ( false(s, SIO_TEXT) && Ssetenc(s, LD->encoding, NULL) != 0 )
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_encoding, ATOM_stream, stream);
s->flags |= SIO_TEXT;
} else if ( type == ATOM_binary )
{ if ( true(s, SIO_TEXT) && Ssetenc(s, ENC_OCTET, NULL) != 0 )
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_encoding, ATOM_stream, stream);
s->flags &= ~SIO_TEXT;
} else
{ return PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_type, a);
}
return TRUE;
} else if ( aname == ATOM_close_on_abort ) /* close_on_abort(Bool) */
{ int close;
if ( !PL_get_bool_ex(a, &close) )
return FALSE;
if ( close )
s->flags &= ~SIO_NOCLOSE;
else
s->flags |= SIO_NOCLOSE;
return TRUE;
} else if ( aname == ATOM_record_position )
{ int rec;
if ( !PL_get_bool_ex(a, &rec) )
return FALSE;
if ( rec )
s->position = &s->posbuf;
else
s->position = NULL;
return TRUE;
} else if ( aname == ATOM_line_position )
{ int lpos;
if ( !PL_get_integer_ex(a, &lpos) )
return FALSE;
if ( s->position )
s->position->linepos = lpos;
else
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_line_position, ATOM_stream, stream);
return TRUE;
} else if ( aname == ATOM_file_name ) /* file_name(Atom) */
{ atom_t fn;
if ( !PL_get_atom_ex(a, &fn) )
return FALSE;
setFileNameStream(s, fn);
return TRUE;
} else if ( aname == ATOM_timeout )
{ double f;
atom_t v;
if ( PL_get_atom(a, &v) && v == ATOM_infinite )
{ s->timeout = -1;
return TRUE;
}
if ( !PL_get_float_ex(a, &f) )
return FALSE;
s->timeout = (int)(f*1000.0);
if ( s->timeout < 0 )
s->timeout = 0;
return TRUE;
} else if ( aname == ATOM_tty ) /* tty(bool) */
{ int val;
if ( !PL_get_bool_ex(a, &val) )
return FALSE;
if ( val )
set(s, SIO_ISATTY);
else
clear(s, SIO_ISATTY);
return TRUE;
} else if ( aname == ATOM_encoding ) /* encoding(atom) */
{ atom_t val;
IOENC enc;
if ( !PL_get_atom_ex(a, &val) )
return FALSE;
if ( (enc = atom_to_encoding(val)) == ENC_UNKNOWN )
{ bad_encoding(NULL, val);
return FALSE;
}
if ( Ssetenc(s, enc, NULL) == 0 )
return TRUE;
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_encoding, ATOM_stream, stream);
#ifdef O_LOCALE
} else if ( aname == ATOM_locale ) /* locale(Locale) */
{ PL_locale *val;
if ( !getLocaleEx(a, &val) )
return FALSE;
if ( Ssetlocale(s, val, NULL) == 0 )
return TRUE;
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_locale, ATOM_stream, stream);
#endif
} else if ( aname == ATOM_representation_errors )
{ atom_t val;
if ( !PL_get_atom_ex(a, &val) )
return FALSE;
clear(s, SIO_REPXML|SIO_REPPL);
if ( val == ATOM_error )
;
else if ( val == ATOM_xml )
set(s, SIO_REPXML);
else if ( val == ATOM_prolog )
set(s, SIO_REPPL);
else
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_representation_errors, a);
return TRUE;
} else if ( aname == ATOM_newline )
{ atom_t val;
if ( !PL_get_atom_ex(a, &val) )
return FALSE;
if ( val == ATOM_posix )
s->newline = SIO_NL_POSIX;
else if ( val == ATOM_dos )
s->newline = SIO_NL_DOS;
else if ( val == ATOM_detect )
{ if ( false(s, SIO_INPUT) )
return PL_error(NULL, 0, "detect only allowed for input streams",
ERR_DOMAIN, ATOM_newline, a);
s->newline = SIO_NL_DETECT;
} else
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_newline, a);
return TRUE;
} else if ( aname == ATOM_close_on_exec ) /* close_on_exec(bool) */
{ int val;
if ( !PL_get_bool_ex(a, &val) )
return FALSE;
return setCloseOnExec(s, val);
} else
{ assert(0);
return FALSE;
}
}
typedef struct set_stream_info
{ atom_t name;
int flags;
} set_stream_info;
#define SS_READ 0x01
#define SS_WRITE 0x02
#define SS_BOTH (SS_READ|SS_WRITE)
#define SS_NOPAIR (0x4|SS_BOTH)
#define SS_INFO(name, flags) { name, flags }
static const set_stream_info ss_info[] =
{ SS_INFO(ATOM_alias, SS_NOPAIR),
SS_INFO(ATOM_buffer, SS_BOTH),
SS_INFO(ATOM_buffer_size, SS_BOTH),
SS_INFO(ATOM_eof_action, SS_READ),
SS_INFO(ATOM_type, SS_BOTH),
SS_INFO(ATOM_close_on_abort, SS_BOTH),
SS_INFO(ATOM_record_position, SS_BOTH),
SS_INFO(ATOM_line_position, SS_NOPAIR),
SS_INFO(ATOM_file_name, SS_BOTH),
SS_INFO(ATOM_timeout, SS_BOTH),
SS_INFO(ATOM_tty, SS_BOTH),
SS_INFO(ATOM_encoding, SS_BOTH),
SS_INFO(ATOM_locale, SS_BOTH),
SS_INFO(ATOM_representation_errors, SS_WRITE),
SS_INFO(ATOM_newline, SS_BOTH),
SS_INFO(ATOM_close_on_exec, SS_BOTH),
SS_INFO((atom_t)0, 0)
};
static
PRED_IMPL("set_stream", 2, set_stream, 0)
{ PRED_LD
IOSTREAM *s;
atom_t aname;
int arity;
atom_t sblob, aname;
stream_ref *ref;
PL_blob_t *type;
int rc, arity;
const set_stream_info *info;
term_t aval = PL_new_term_ref();
term_t stream = A1;
term_t attr = A2;
if ( !PL_get_stream_handle(stream, &s) )
return FALSE;
if ( PL_get_name_arity(attr, &aname, &arity) )
{ if ( arity == 1 )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, attr, a);
if ( aname == ATOM_alias ) /* alias(name) */
{ atom_t alias;
int i;
if ( !PL_get_atom_ex(a, &alias) )
goto error;
if ( (i=standardStreamIndexFromName(alias)) >= 0 )
{ LD->IO.streams[i] = s;
if ( i == 0 )
LD->prompt.next = TRUE; /* changed standard input: prompt! */
goto ok;
}
LOCK();
aliasStream(s, alias);
UNLOCK();
goto ok;
} else if ( aname == ATOM_buffer ) /* buffer(Buffering) */
{ atom_t b;
#define SIO_ABUF (SIO_FBUF|SIO_LBUF|SIO_NBUF)
if ( !PL_get_atom_ex(a, &b) )
goto error;
if ( b == ATOM_full )
{ s->flags &= ~SIO_ABUF;
s->flags |= SIO_FBUF;
} else if ( b == ATOM_line )
{ s->flags &= ~SIO_ABUF;
s->flags |= SIO_LBUF;
} else if ( b == ATOM_false )
{ Sflush(s);
s->flags &= ~SIO_ABUF;
s->flags |= SIO_NBUF;
} else
{ PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_buffer, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_buffer_size )
{ int size;
if ( !PL_get_integer_ex(a, &size) )
goto error;
if ( size < 1 )
{ PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, a);
goto error;
}
Ssetbuffer(s, NULL, size);
goto ok;
} else if ( aname == ATOM_eof_action ) /* eof_action(Action) */
{ atom_t action;
if ( !PL_get_atom_ex(a, &action) )
return FALSE;
if ( action == ATOM_eof_code )
{ s->flags &= ~(SIO_NOFEOF|SIO_FEOF2ERR);
} else if ( action == ATOM_reset )
{ s->flags &= ~SIO_FEOF2ERR;
s->flags |= SIO_NOFEOF;
} else if ( action == ATOM_error )
{ s->flags &= ~SIO_NOFEOF;
s->flags |= SIO_FEOF2ERR;
} else
{ PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_eof_action, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_type ) /* type(Type) */
{ atom_t type;
if ( !PL_get_atom_ex(a, &type) )
return FALSE;
if ( type == ATOM_text )
{ if ( false(s, SIO_TEXT) && Ssetenc(s, LD->encoding, NULL) != 0 )
{ PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_encoding, ATOM_stream, stream);
goto error;
}
s->flags |= SIO_TEXT;
} else if ( type == ATOM_binary )
{ if ( true(s, SIO_TEXT) && Ssetenc(s, ENC_OCTET, NULL) != 0 )
{ PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_encoding, ATOM_stream, stream);
goto error;
}
s->flags &= ~SIO_TEXT;
} else
{ PL_error("set_stream", 2, NULL, ERR_DOMAIN,
ATOM_type, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_close_on_abort ) /* close_on_abort(Bool) */
{ int close;
if ( !PL_get_bool_ex(a, &close) )
goto error;
if ( close )
s->flags &= ~SIO_NOCLOSE;
else
s->flags |= SIO_NOCLOSE;
goto ok;
} else if ( aname == ATOM_record_position )
{ int rec;
if ( !PL_get_bool_ex(a, &rec) )
goto error;
if ( rec )
s->position = &s->posbuf;
else
s->position = NULL;
goto ok;
} else if ( aname == ATOM_line_position )
{ int lpos;
if ( !PL_get_integer_ex(a, &lpos) )
goto error;
if ( s->position )
{ s->position->linepos = lpos;
} else
{ PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_line_position, ATOM_stream, stream);
goto error;
}
goto ok;
} else if ( aname == ATOM_file_name ) /* file_name(Atom) */
{ atom_t fn;
if ( !PL_get_atom_ex(a, &fn) )
goto error;
PL_register_atom(fn);
LOCK();
setFileNameStream(s, fn);
UNLOCK();
goto ok;
} else if ( aname == ATOM_timeout )
{ double f;
atom_t v;
if ( PL_get_atom(a, &v) && v == ATOM_infinite )
{ s->timeout = -1;
goto ok;
}
if ( !PL_get_float_ex(a, &f) )
goto error;
s->timeout = (int)(f*1000.0);
if ( s->timeout < 0 )
s->timeout = 0;
goto ok;
} else if ( aname == ATOM_tty ) /* tty(bool) */
{ int val;
if ( !PL_get_bool_ex(a, &val) )
goto error;
if ( val )
set(s, SIO_ISATTY);
else
clear(s, SIO_ISATTY);
goto ok;
} else if ( aname == ATOM_encoding ) /* encoding(atom) */
{ atom_t val;
IOENC enc;
if ( !PL_get_atom_ex(a, &val) )
goto error;
if ( (enc = atom_to_encoding(val)) == ENC_UNKNOWN )
{ bad_encoding(NULL, val);
goto error;
}
if ( Ssetenc(s, enc, NULL) == 0 )
goto ok;
PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_encoding, ATOM_stream, stream);
goto error;
} else if ( aname == ATOM_representation_errors )
{ atom_t val;
if ( !PL_get_atom_ex(a, &val) )
goto error;
clear(s, SIO_REPXML|SIO_REPPL);
if ( val == ATOM_error )
;
else if ( val == ATOM_xml )
set(s, SIO_REPXML);
else if ( val == ATOM_prolog )
set(s, SIO_REPPL);
else
{ PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_representation_errors, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_newline )
{ atom_t val;
if ( !PL_get_atom_ex(a, &val) )
goto error;
if ( val == ATOM_posix )
s->newline = SIO_NL_POSIX;
else if ( val == ATOM_dos )
s->newline = SIO_NL_DOS;
else if ( val == ATOM_detect )
{ if ( false(s, SIO_INPUT) )
{ PL_error(NULL, 0, "detect only allowed for input streams",
ERR_DOMAIN, ATOM_newline, a);
goto error;
}
s->newline = SIO_NL_DETECT;
} else
{ PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_newline, a);
goto error;
}
goto ok;
} else if ( aname == ATOM_close_on_exec ) /* close_on_exec(bool) */
{ int val;
if ( !PL_get_bool_ex(a, &val) )
goto error;
switch ( setCloseOnExec(s, val) )
{ case TRUE: goto ok;
case FALSE: goto error;
default: goto type_error;
}
}
if ( PL_get_name_arity(attr, &aname, &arity) && arity == 1 )
{ for(info = ss_info; info->name; info++)
{ if ( info->name == aname )
goto found;
}
}
return PL_domain_error("stream_attribute", attr);
} else
return PL_type_error("stream_attribute", attr);
type_error:
PL_error("set_stream", 2, NULL, ERR_TYPE,
PL_new_atom("stream_attribute"), attr);
goto error;
found:
_PL_get_arg(1, attr, aval);
ok:
releaseStream(s);
return TRUE;
error:
releaseStream(s);
return FALSE;
if ( !PL_get_atom(stream, &sblob) )
return not_a_stream(stream);
ref = PL_blob_data(sblob, NULL, &type);
if ( type == &stream_blob ) /* got a stream handle */
{ if ( ref->read && ref->write && /* stream pair */
info->flags & SS_NOPAIR )
return PL_error("set_stream", 2, NULL, ERR_PERMISSION,
aname, ATOM_stream_pair, stream);
rc = TRUE;
if ( ref->read && (info->flags&SS_READ))
{ if ( !(s = getStream(ref->read)) )
return symbol_no_stream(sblob);
rc = set_stream(s, stream, aname, aval PASS_LD);
releaseStream(ref->read);
}
if ( rc && ref->write && (info->flags&SS_WRITE) )
{ if ( !(s = getStream(ref->write)) )
return symbol_no_stream(sblob);
rc = set_stream(s, stream, aname, aval PASS_LD);
releaseStream(ref->write);
}
} else if ( PL_get_stream_handle(stream, &s) )
{ rc = set_stream(s, stream, aname, aval PASS_LD);
releaseStream(s);
} else
rc = FALSE;
if ( rc < 0 ) /* not on this OS */
return PL_domain_error("stream_attribute", attr);
return rc;
}
#ifdef _MSC_VER /* defined in pl-nt.c */
extern int ftruncate(int fileno, int64_t length);
#define HAVE_FTRUNCATE
@ -3029,6 +3108,9 @@ static const opt_spec open4_options[] =
{ ATOM_wait, OPT_BOOL },
{ ATOM_encoding, OPT_ATOM },
{ ATOM_bom, OPT_BOOL },
#ifdef O_LOCALE
{ ATOM_locale, OPT_LOCALE },
#endif
{ NULL_ATOM, 0 }
};
@ -3047,6 +3129,9 @@ openStream(term_t file, term_t mode, term_t options)
atom_t lock = ATOM_none;
int wait = TRUE;
atom_t encoding = NULL_ATOM;
#ifdef O_LOCALE
PL_locale *locale = NULL;
#endif
int close_on_abort = TRUE;
int bom = -1;
char how[10];
@ -3058,7 +3143,12 @@ openStream(term_t file, term_t mode, term_t options)
if ( options )
{ if ( !scan_options(options, 0, ATOM_stream_option, open4_options,
&type, &reposition, &alias, &eof_action,
&close_on_abort, &buffer, &lock, &wait, &encoding, &bom) )
&close_on_abort, &buffer, &lock, &wait,
&encoding, &bom
#ifdef O_LOCALE
, &locale
#endif
) )
return FALSE;
}
@ -3158,12 +3248,18 @@ openStream(term_t file, term_t mode, term_t options)
ATOM_open, ATOM_source_sink, file);
return NULL;
}
setFileNameStream(s, fn_to_atom(path));
setFileNameStream_unlocked(s, fn_to_atom(path));
} else
{ return NULL;
}
s->encoding = enc;
#ifdef O_LOCALE
if ( locale )
{ Ssetlocale(s, locale, NULL);
releaseLocale(locale); /* acquired by scan_options() */
}
#endif
if ( !close_on_abort )
s->flags |= SIO_NOCLOSE;
@ -3512,7 +3608,8 @@ do_close(IOSTREAM *s, int force)
Sclearerr(s);
} else
{ Sflush(s);
Sclose(s);
if ( Sclose(s) < 0 )
PL_clear_exception();
}
return TRUE;
@ -3819,6 +3916,15 @@ stream_encoding_prop(IOSTREAM *s, term_t prop ARG_LD)
}
#ifdef O_LOCALE
static int
stream_locale_prop(IOSTREAM *s, term_t prop ARG_LD)
{ if ( s->locale )
return unifyLocale(prop, s->locale, TRUE);
return FALSE;
}
#endif
static int
stream_reperror_prop(IOSTREAM *s, term_t prop ARG_LD)
{ atom_t a;
@ -3895,7 +4001,7 @@ stream_close_on_exec_prop(IOSTREAM *s, term_t prop ARG_LD)
if ( (fd = Sfileno(s)) < 0)
return FALSE;
#if defined(F_SETFD) && defined(FD_CLOEXEC)
#if defined(F_GETFD) && defined(FD_CLOEXEC)
if ( (fd_flags = fcntl(fd, F_GETFD)) == -1)
return FALSE;
@ -3937,6 +4043,9 @@ static const sprop sprop_list [] =
{ FUNCTOR_close_on_abort1,stream_close_on_abort_prop },
{ FUNCTOR_tty1, stream_tty_prop },
{ FUNCTOR_encoding1, stream_encoding_prop },
#ifdef O_LOCALE
{ FUNCTOR_locale1, stream_locale_prop },
#endif
{ FUNCTOR_bom1, stream_bom_prop },
{ FUNCTOR_newline1, stream_newline_prop },
{ FUNCTOR_representation_errors1, stream_reperror_prop },
@ -4169,10 +4278,8 @@ PRED_IMPL("is_stream", 1, is_stream, 0)
atom_t a;
if ( PL_get_atom(A1, &a) &&
get_stream_handle(a, &s, 0) )
{ releaseStream(s);
get_stream_handle(a, &s, SH_UNLOCKED) )
return TRUE;
}
return FALSE;
}
@ -4400,7 +4507,8 @@ PRED_IMPL("current_output", 1, current_output, PL_FA_ISO)
static
PRED_IMPL("byte_count", 2, byte_count, 0)
{ IOSTREAM *s;
{ PRED_LD
IOSTREAM *s;
if ( getStreamWithPosition(A1, &s) )
{ int64_t n = s->position->byteno;
@ -5025,15 +5133,13 @@ struct PL_local_data *Yap_InitThreadIO(int wid)
if (wid)
p = (struct PL_local_data *)malloc(sizeof(struct PL_local_data));
else
p = (struct PL_local_data *)calloc(sizeof(struct PL_local_data), 1);
return &lds;
if (!p) {
Yap_Error(OUT_OF_HEAP_ERROR, 0L, "Creating thread %d\n", wid);
return p;
}
#if THREADS
if (wid) {
memcpy(p, Yap_local[0]->PL_local_data_p_, sizeof(struct PL_local_data));
}
memcpy(p, Yap_local[0]->PL_local_data_p_, sizeof(struct PL_local_data));
#endif
return p;
}
@ -5099,6 +5205,9 @@ init_yap(void)
initMutexes();
#endif
/* we need encodings first */
#ifdef O_LOCALE
initLocale();
#endif
initCharTypes();
initPrologFlags();
setPrologFlagMask(PLFLAG_TTY_CONTROL);
@ -5111,6 +5220,9 @@ init_yap(void)
PL_register_extensions(PL_predicates_from_read);
PL_register_extensions(PL_predicates_from_tai);
PL_register_extensions(PL_predicates_from_prologflag);
#ifdef O_LOCALE
PL_register_extensions(PL_predicates_from_locale);
#endif
#ifdef __WINDOWS__
PL_register_extensions(PL_predicates_from_win);
#endif

1
os/pl-file.h
View File

@ -43,6 +43,7 @@ COMMON(int) getTextOutputStream__LD(term_t t, IOSTREAM **s ARG_LD);
COMMON(int) getBinaryOutputStream__LD(term_t t, IOSTREAM **s ARG_LD);
COMMON(int) reportStreamError(IOSTREAM *s);
COMMON(int) streamStatus(IOSTREAM *s);
COMMON(int) setFileNameStream(IOSTREAM *s, atom_t name);
COMMON(atom_t) fileNameStream(IOSTREAM *s);
COMMON(int) getSingleChar(IOSTREAM *s, int signals);
COMMON(int) readLine(IOSTREAM *in, IOSTREAM *out, char *buffer);

26
os/pl-files.c
View File

@ -105,14 +105,13 @@ LastModifiedFile(const char *name, double *tp)
if ( rc )
{ double t;
fprintf(stderr, "wt.dwHighDateTime=%ld wt.dwLowDateTime=%ld\n",wt.dwHighDateTime, wt.dwLowDateTime);
t = (double)wt.dwHighDateTime * (4294967296.0 * ntick nano);
t += (double)wt.dwLowDateTime * (ntick nano);
t -= SEC_TO_UNIX_EPOCH;
*tp = t;
fprintf(stderr, " t=%f\n", t);
return TRUE;
return TRUE;
}
}
@ -662,7 +661,8 @@ PRED_IMPL("time_file", 2, time_file, 0)
static
PRED_IMPL("time_file64", 2, time_file64, 0)
{ char *fn;
{ GET_LD
char *fn;
if ( PL_get_file_name(A1, &fn, 0) )
{ int64_t time;
@ -680,7 +680,8 @@ PRED_IMPL("time_file64", 2, time_file64, 0)
static
PRED_IMPL("size_file", 2, size_file, 0)
{ char *n;
{ PRED_LD
char *n;
if ( PL_get_file_name(A1, &n, 0) )
{ int64_t size;
@ -902,7 +903,7 @@ PRED_IMPL("tmp_file_stream", 3, tmp_file_stream, 0)
static
PRED_IMPL("swi_delete_file", 1, delete_file, 0)
PRED_IMPL("delete_file", 1, delete_file, 0)
{ PRED_LD
char *n;
atom_t aname;
@ -944,9 +945,6 @@ PRED_IMPL("make_directory", 1, make_directory, 0)
if ( !PL_get_file_name(A1, &n, 0) )
return FALSE;
#if __MINGW32__
#define mkdir(A, B) mkdir(A)
#endif
if ( mkdir(n, 0777) == 0 )
return TRUE;
else
@ -1126,13 +1124,12 @@ PRED_IMPL("file_name_extension", 3, file_name_extension, 0)
static
PRED_IMPL("prolog_to_os_filename", 2, prolog_to_os_filename, 0)
{
#ifdef O_XOS
PRED_LD
{ PRED_LD
term_t pl = A1;
term_t os = A2;
#ifdef O_XOS
wchar_t *wn;
if ( !PL_is_variable(pl) )
@ -1160,8 +1157,7 @@ PRED_IMPL("prolog_to_os_filename", 2, prolog_to_os_filename, 0)
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, pl);
#else /*O_XOS*/
return PL_unify(A1, A2);
return PL_unify(pl, os);
#endif /*O_XOS*/
}
@ -1202,7 +1198,7 @@ BeginPredDefs(files)
PRED_DEF("exists_directory", 1, exists_directory, 0)
PRED_DEF("tmp_file", 2, tmp_file, 0)
PRED_DEF("tmp_file_stream", 3, tmp_file_stream, 0)
PRED_DEF("swi_delete_file", 1, delete_file, 0)
PRED_DEF("delete_file", 1, delete_file, 0)
PRED_DEF("delete_directory", 1, delete_directory, 0)
PRED_DEF("make_directory", 1, make_directory, 0)
PRED_DEF("same_file", 2, same_file, 0)

640
os/pl-fmt.c
View File

@ -1,11 +1,10 @@
/* $Id$
Part of SWI-Prolog
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2007, University of Amsterdam
Copyright (C): 1985-2013, University of Amsterdam
VU University Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -32,9 +31,10 @@ source should also use format() to produce error messages, etc.
#include "pl-utf8.h"
#include <ctype.h>
static char * formatNumber(bool split, int div, int radix,
static char * formatInteger(PL_locale *locale, int div, int radix,
bool smll, Number n, Buffer out);
static char * formatFloat(int how, int arg, Number f, Buffer out);
static char * formatFloat(PL_locale *locale, int how, int arg,
Number f, Buffer out);
#define MAXRUBBER 100
@ -65,6 +65,13 @@ typedef struct
#define FMT_ARG(c, a) return (void)Sunlock(fd), \
PL_error(NULL, 0, NULL, \
ERR_FORMAT_ARG, c, a)
#define FMT_EXEPTION() return (void)Sunlock(fd), FALSE
static PL_locale prolog_locale =
{ 0,0,LOCALE_MAGIC,1,
L".", NULL
};
static int
@ -140,12 +147,6 @@ outstring(format_state *state, const char *s, size_t len)
}
static int
outstring0(format_state *state, const char *s)
{ return outstring(state, s, strlen(s));
}
static int
oututf8(format_state *state, const char *s, size_t len)
{ const char *e = &s[len];
@ -162,6 +163,12 @@ oututf8(format_state *state, const char *s, size_t len)
}
static int
oututf80(format_state *state, const char *s)
{ return oututf8(state, s, strlen(s));
}
static int
outtext(format_state *state, PL_chars_t *txt)
{ switch(txt->encoding)
@ -390,6 +397,7 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
switch(c)
{ case '~':
{ int arg = DEFAULT; /* Numeric argument */
int mod_colon = FALSE; /* Used colon modifier */
/* Get the numeric argument */
c = get_chr_from_text(fmt, ++here);
@ -424,6 +432,11 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
c = get_chr_from_text(fmt, ++here);
}
if ( c == ':' )
{ mod_colon = TRUE;
c = get_chr_from_text(fmt, ++here);
}
/* Check for user defined format */
if ( format_predicates &&
(s = lookupHTable(format_predicates, (void*)((intptr_t)c))) )
@ -505,6 +518,7 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
tmp_buffer b;
buffer b1;
} u;
PL_locale *l;
NEED_ARG;
if ( !valueExpression(argv, &n PASS_LD) )
@ -516,10 +530,16 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
}
SHIFT;
if ( c == 'f' && mod_colon )
l = fd->locale;
else
l = &prolog_locale;
initBuffer(&u.b);
formatFloat(c, arg, &n, &u.b1);
rc = formatFloat(l, c, arg, &n, &u.b1) != NULL;
clearNumber(&n);
rc = outstring0(&state, baseBuffer(&u.b, char));
if ( rc )
rc = oututf80(&state, baseBuffer(&u.b, char));
discardBuffer(&u.b);
if ( !rc )
goto out;
@ -530,6 +550,7 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
case 'D': /* grouped integer */
case 'r': /* radix number */
case 'R': /* Radix number */
case 'I': /* Prolog 1_000_000 */
{ number i;
tmp_buffer b;
@ -543,13 +564,42 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
FMT_ARG(f, argv);
}
SHIFT;
if ( arg == DEFAULT )
arg = 0;
initBuffer(&b);
if ( c == 'd' || c == 'D' )
{ formatNumber(c == 'D', arg, 10, TRUE, &i, (Buffer)&b);
} else
{ if ( arg < 1 || arg > 36 )
{ PL_locale ltmp;
PL_locale *l;
static char grouping[] = {3,0};
if ( c == 'D' )
{ ltmp.thousands_sep = L",";
ltmp.decimal_point = L".";
ltmp.grouping = grouping;
l = &ltmp;
} else if ( mod_colon )
{ l = fd->locale;
} else
{ l = NULL;
}
if ( arg == DEFAULT )
arg = 0;
if ( !formatInteger(l, arg, 10, TRUE, &i, (Buffer)&b) )
FMT_EXEPTION();
} else if ( c == 'I' )
{ PL_locale ltmp;
char grouping[2];
grouping[0] = (arg == DEFAULT ? 3 : arg);
grouping[1] = '\0';
ltmp.thousands_sep = L"_";
ltmp.grouping = grouping;
if ( !formatInteger(&ltmp, 0, 10, TRUE, &i, (Buffer)&b) )
FMT_EXEPTION();
} else /* r,R */
{ if ( arg == DEFAULT )
FMT_ERROR("r,R requires radix specifier");
if ( arg < 1 || arg > 36 )
{ term_t r = PL_new_term_ref();
PL_put_integer(r, arg);
@ -557,10 +607,11 @@ do_format(IOSTREAM *fd, PL_chars_t *fmt, int argc, term_t argv, Module m)
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_radix, r);
}
formatNumber(FALSE, 0, arg, c == 'r', &i, (Buffer)&b);
if ( !formatInteger(NULL, 0, arg, c == 'r', &i, (Buffer)&b) )
FMT_EXEPTION();
}
clearNumber(&i);
rc = outstring0(&state, baseBuffer(&b, char));
rc = oututf80(&state, baseBuffer(&b, char));
discardBuffer(&b);
if ( !rc )
goto out;
@ -887,107 +938,172 @@ emit_rubber(format_state *state)
** Fri Aug 19 22:26:41 1988 jan@swivax.UUCP (Jan Wielemaker) */
static void
lappend(const wchar_t *l, int def, Buffer out)
{ if ( l )
{ const wchar_t *e = l+wcslen(l);
while (--e >= l)
{ int c = *e;
if ( c < 128 )
{ addBuffer(out, c, char);
} else
{ char buf[6];
char *e8, *s;
e8=utf8_put_char(buf, c);
for(s=e8; --s>=buf; ) /* must be reversed as we reverse */
{ addBuffer(out, *s, char); /* in the end */
}
}
}
} else
{ addBuffer(out, def, char);
}
}
static void
revert_string(char *s, size_t len)
{ char *e = &s[len-1];
for(; e>s; s++,e--)
{ int c = *e;
*e = *s;
*s = c;
}
}
static char *
formatNumber(bool split, int div, int radix, bool smll, Number i,
formatInteger(PL_locale *locale, int div, int radix, bool smll, Number i,
Buffer out)
{ switch(i->type)
{ const char *grouping = NULL;
if ( !locale )
{ locale = &prolog_locale;
} else
{ if ( locale->grouping && locale->grouping[0] &&
locale->thousands_sep && locale->thousands_sep[0] )
grouping = locale->grouping;
}
switch(i->type)
{ case V_INTEGER:
{ int64_t n = i->value.i;
char buf[100];
char *tmp, *end, *s;
int before = (div == 0);
int digits = 0;
bool negative = FALSE;
if ( div+3 > (int)sizeof(buf) ) /* 0.000NNNN with div digits after 0. */
{ tmp = PL_malloc(div+3);
end = tmp+div+3;
} else
{ tmp = buf;
end = tmp+sizeof(buf);
}
s = end; /* i.e. start at the end */
*--s = EOS;
if ( n < 0 )
{ n = -n;
negative = TRUE;
}
if ( n == 0 && div == 0 )
{ *--s = '0';
{ addBuffer(out, '0', char);
} else
{ while( n > 0 || div >= 0 )
{ int before = FALSE; /* before decimal point */
int negative = FALSE;
int gsize = 0;
int dweight;
negative = (n < 0);
while( n != 0 || div >= 0 )
{ if ( div-- == 0 && !before )
{ *--s = '.';
before = 1;
{ if ( !isEmptyBuffer(out) )
lappend(locale->decimal_point, '.', out);
before = TRUE;
if ( grouping )
gsize = grouping[0];
}
if ( split && before && (digits++ % 3) == 0 && digits != 1 )
*--s = ',';
*--s = digitName((int)(n % radix), smll);
if ( !negative )
dweight = (int)(n % radix);
else
dweight = -(int)(n % -radix);
addBuffer(out, digitName(dweight, smll), char);
n /= radix;
if ( --gsize == 0 && n != 0 )
{ lappend(locale->thousands_sep, ',', out);
if ( grouping[1] == 0 )
gsize = grouping[0];
else if ( grouping[1] == CHAR_MAX )
gsize = 0;
else
gsize = *++grouping;
}
}
if ( negative )
*--s = '-';
addBuffer(out, '-', char);
}
addMultipleBuffer(out, s, end-s, char);
if ( tmp != buf )
PL_free(tmp);
revert_string(baseBuffer(out, char), entriesBuffer(out, char));
addBuffer(out, EOS, char);
return baseBuffer(out, char);
}
#ifdef O_GMP
case V_MPZ:
{ size_t len = mpz_sizeinbase(i->value.mpz, radix);
{ GET_LD
size_t len = mpz_sizeinbase(i->value.mpz, radix);
char tmp[256];
char *buf;
int rc = TRUE;
if ( len+2 > sizeof(tmp) )
buf = PL_malloc(len+2);
else
buf = tmp;
mpz_get_str(buf, radix, i->value.mpz);
EXCEPTION_GUARDED({ LD->gmp.persistent++;
mpz_get_str(buf, radix, i->value.mpz);
LD->gmp.persistent--;
},
{ LD->gmp.persistent--;
rc = PL_rethrow();
});
if ( !rc )
return NULL;
if ( !smll && radix > 10 )
{ char *s;
for(s=buf; *s; s++)
*s = toupper(*s);
}
if ( split || div > 0 )
{ int before = (int)(len-div);
int leading;
char *s = buf;
if ( *s == '-' )
{ addBuffer(out, *s, char);
s++;
}
if ( split )
{ leading = before % 3;
if ( leading == 0 )
leading = 3;
} else
{ leading = (int)len;
}
for(; *s; s++)
{ if ( before-- == 0 && div > 0 )
{ addBuffer(out, '.', char);
} else if ( leading-- == 0 && before > 0 )
{ addBuffer(out, ',', char);
leading = 2;
if ( grouping || div > 0 )
{ int before = FALSE; /* before decimal point */
int gsize = 0;
char *e = buf+strlen(buf)-1;
while(e >= buf || div >= 0)
{ if ( div-- == 0 && !before )
{ if ( !isEmptyBuffer(out) )
lappend(locale->decimal_point, '.', out);
before = TRUE;
if ( grouping )
gsize = grouping[0];
}
addBuffer(out, *e, char);
e--;
if ( --gsize == 0 && e >= buf && *e != '-' )
{ lappend(locale->thousands_sep, ',', out);
if ( grouping[1] == 0 )
gsize = grouping[0];
else if ( grouping[1] == CHAR_MAX )
gsize = 0;
else
gsize = *++grouping;
}
addBuffer(out, *s, char);
}
addBuffer(out, EOS, char);
revert_string(baseBuffer(out, char), entriesBuffer(out, char));
} else
{ addMultipleBuffer(out, buf, strlen(buf), char);
addBuffer(out, EOS, char);
}
if ( buf != tmp )
PL_free(buf);
addBuffer(out, EOS, char);
return baseBuffer(out, char);
}
#endif /*O_GMP*/
@ -998,8 +1114,187 @@ formatNumber(bool split, int div, int radix, bool smll, Number i,
}
static int
countGroups(const char *grouping, int len)
{ int groups = 0;
int gsize = grouping[0];
while(len>0)
{ len -= gsize;
if ( len > 0 )
groups++;
if ( grouping[1] == 0 )
{ if ( len > 1 )
groups += (len-1)/grouping[0];
return groups;
} else if ( grouping[1] == CHAR_MAX )
{ return groups;
} else
{ gsize = *++grouping;
}
}
return groups;
}
static int
ths_to_utf8(char *u8, const wchar_t *s, size_t len)
{ char *e = u8+len-7;
for( ; u8<e && *s; s++)
u8 = utf8_put_char(u8,*s);
*u8 = EOS;
return *s == 0;
}
static int
same_decimal_point(PL_locale *l1, PL_locale *l2)
{ if ( l1->decimal_point && l2->decimal_point &&
wcscmp(l1->decimal_point, l2->decimal_point) == 0 )
return TRUE;
if ( !l1->decimal_point && !l2->decimal_point )
return TRUE;
return FALSE;
}
static int
utf8_dp(PL_locale *l, char *s, int *len)
{ if ( l->decimal_point )
{ if ( !ths_to_utf8(s, l->decimal_point, 20) )
return FALSE;
*len = strlen(s);
} else
{ *s++ = '.';
*s = EOS;
*len = 1;
}
return TRUE;
}
/* localizeDecimalPoint() replaces the decimal point as entered by the
local sensitive print functions by the one in the specified locale.
This is overly complicated. Needs more testing, in particular for
locales with (in UTF-8) multibyte decimal points.
*/
static int
localizeDecimalPoint(PL_locale *locale, Buffer b)
{ if ( locale == GD->locale.default_locale ||
same_decimal_point(GD->locale.default_locale, locale) )
return TRUE;
if ( locale->decimal_point && locale->decimal_point[0] )
{ char *s = baseBuffer(b, char);
char *e;
char dp[20]; int dplen;
char ddp[20]; int ddplen;
if ( !utf8_dp(locale, dp, &dplen) ||
!utf8_dp(GD->locale.default_locale, ddp, &ddplen) )
return FALSE;
if ( *s == '-' )
s++;
for(e=s; *e && isDigit(*e); e++)
;
if ( strncmp(e, ddp, ddplen) == 0 )
{ if ( dplen == ddplen )
{ memcpy(e, dp, dplen);
} else
{ char *ob = baseBuffer(b, char);
if ( dplen > ddplen && !growBuffer(b, dplen-ddplen) )
return PL_no_memory();
e += baseBuffer(b, char) - ob;
memmove(&e[dplen-ddplen], e, strlen(e)+1);
memcpy(e, dp, dplen);
}
}
}
return TRUE;
}
static int
groupDigits(PL_locale *locale, Buffer b)
{ if ( locale->thousands_sep && locale->thousands_sep[0] &&
locale->grouping && locale->grouping[0] )
{ char *s = baseBuffer(b, char);
char *e;
int groups;
if ( *s == '-' )
s++;
for(e=s; *e && isDigit(*e); e++)
;
groups = countGroups(locale->grouping, (int)(e-s));
if ( groups > 0 )
{ char *o;
char *grouping = locale->grouping;
int gsize = grouping[0];
char ths[20];
int thslen;
if ( !ths_to_utf8(ths, locale->thousands_sep, sizeof(ths)) )
return FALSE;
thslen = strlen(ths);
if ( !growBuffer(b, thslen*groups) )
return PL_no_memory();
memmove(&e[groups*thslen], e, strlen(e)+1);
e--;
for(o=e+groups*thslen; e>=s; )
{ *o-- = *e--;
if ( --gsize == 0 && e>=s )
{ o -= thslen-1;
memcpy(o, ths, thslen);
o--;
if ( grouping[1] == 0 )
gsize = grouping[0];
else if ( grouping[1] == CHAR_MAX )
gsize = 0;
else
gsize = *++grouping;
}
}
}
}
return TRUE;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
formatFloat(PL_locale *locale, int how, int arg, Number f, Buffer out)
formats a floating point number to a buffer. `How' is the format
specifier ([eEfgG]), `arg' the argument.
MPZ/MPQ numbers printed using the format specifier `f' are written using
the following algorithm, courtesy of Jan Burse:
Given: A rational n/m
Seeked: The ration rounded to d fractional digits.
Algorithm: Compute (n*10^d+m//2)//m, and place period at d.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static char *
formatFloat(int how, int arg, Number f, Buffer out)
formatFloat(PL_locale *locale, int how, int arg, Number f, Buffer out)
{ if ( arg == DEFAULT )
arg = 6;
@ -1007,50 +1302,150 @@ formatFloat(int how, int arg, Number f, Buffer out)
{
#ifdef O_GMP
mpf_t mpf;
mpz_t t1, t2;
int neg;
case V_MPZ:
mpf_init2(mpf, arg*4);
mpf_set_z(mpf, f->value.mpz);
goto print;
{ switch(how)
{ case 'f':
{ mpz_init(t1);
mpz_init(t2);
mpz_ui_pow_ui(t1, 10, arg);
mpz_mul(t1, f->value.mpz, t1);
neg = (mpz_cmp_ui(t1, 0) < 0) ? 1 : 0;
mpz_abs(t1, t1);
goto print_mpz;
}
case 'e':
case 'E':
case 'g':
case 'G':
{ mpf_init2(mpf, arg*4);
mpf_set_z(mpf, f->value.mpz);
goto print_mpf;
}
}
}
case V_MPQ:
{ char tmp[12];
int size;
int written;
int written = 0;
int fbits;
int digits = 0;
int padding = 0;
switch(how)
{ case 'f':
case 'g':
{ mpz_init(t1);
mpz_init(t2);
mpz_ui_pow_ui(t1, 10, arg);
mpz_mul(t1, mpq_numref(f->value.mpq), t1);
mpz_tdiv_q_ui(t2, mpq_denref(f->value.mpq), 2);
if (mpq_cmp_ui(f->value.mpq, 0, 1) < 0)
{ mpz_sub(t1, t1, t2);
neg=1;
} else
{ mpz_add(t1, t1, t2);
neg=0;
}
mpz_tdiv_q(t1, t1, mpq_denref(f->value.mpq));
mpz_abs(t1, t1);
print_mpz:
if (mpz_cmp_ui(t1, 0) != 0)
{ size = mpz_sizeinbase(t1, 10) + 1; /* reserve for <null> */
if ( !growBuffer(out, size) )
{ PL_no_memory();
return NULL;
}
digits = written = gmp_snprintf(baseBuffer(out, char), size, "%Zd", t1);
}
size = digits;
if (neg) size++; /* leading - */
if (arg) size++; /* decimal point */
if (digits <= arg) /* leading '0's */
{ padding = (arg-digits+1);
size += padding;
}
size++; /* NULL terminator */
if ( !growBuffer(out, size) )
{ PL_no_memory();
return NULL;
}
if (!digits)
{ memset(out->base, '\0', 1);
}
if (neg)
{ memmove(out->base+1, out->base, digits+1);
memset(out->base, '-', 1);
written++;
}
if (padding)
{ memmove(out->base+neg+padding, out->base+neg, written-neg+1);
memset(out->base+neg, '0', padding);
written += padding;
}
if (arg)
{ memmove(out->base+written-(arg-1), out->base+written-arg, arg+1);
if ( locale->decimal_point && locale->decimal_point[0] )
*(out->base+written-arg) = locale->decimal_point[0];
else
*(out->base+written-arg) = '.';
written++;
}
out->top = out->base + written;
mpz_clear(t1);
mpz_clear(t2);
break;
}
case 'e':
case 'E':
case 'g':
case 'G':
{ mpz_t iv;
{ switch(how)
{ case 'g':
case 'G':
{ mpz_t iv;
mpz_init(iv);
mpz_set_q(iv, f->value.mpq);
fbits = (int)mpz_sizeinbase(iv, 2) + 4*arg;
mpz_clear(iv);
break;
}
default:
fbits = 4*arg;
}
mpf_init2(mpf, fbits);
mpf_set_q(mpf, f->value.mpq);
mpz_init(iv);
mpz_set_q(iv, f->value.mpq);
fbits = (int)mpz_sizeinbase(iv, 2) + 4*arg;
mpz_clear(iv);
break;
}
default:
fbits = 4*arg;
print_mpf:
Ssprintf(tmp, "%%.%dF%c", arg, how);
size = 0;
written = arg+4;
while(written >= size)
{ size = written+1;
if ( !growBuffer(out, size) ) /* reserve for -.e<null> */
{ PL_no_memory();
return NULL;
}
written = gmp_snprintf(baseBuffer(out, char), size, tmp, mpf);
}
mpf_clear(mpf);
out->top = out->base + written;
break;
}
}
mpf_init2(mpf, fbits);
mpf_set_q(mpf, f->value.mpq);
print:
Ssprintf(tmp, "%%.%dF%c", arg, how);
size = 0;
written = arg+4;
while(written >= size)
{ size = written+1;
if ( !growBuffer(out, size) ) /* reserve for -.e<null> */
outOfCore();
written = gmp_snprintf(baseBuffer(out, char), size, tmp, mpf);
}
mpf_clear(mpf);
out->top = out->base + written;
return baseBuffer(out, char);
break;
}
#endif
case V_INTEGER:
@ -1066,14 +1461,25 @@ formatFloat(int how, int arg, Number f, Buffer out)
{ size = written+1;
if ( !growBuffer(out, size) )
outOfCore();
{ PL_no_memory();
return NULL;
}
written = snprintf(baseBuffer(out, char), size, tmp, f->value.f);
}
out->top = out->base + written;
return baseBuffer(out, char);
break;
}
default:
assert(0);
return NULL;
}
return NULL;
if ( locale )
{ if ( !localizeDecimalPoint(locale, out) ||
!groupDigits(locale, out) )
return NULL;
}
return baseBuffer(out, char);
}

4
os/pl-glob.c
View File

@ -516,10 +516,10 @@ expand(const char *pattern, GlobInfo info)
continue;
strcpy(path, current);
strcat(path, prefix);
strcpy(&path[clen], prefix);
if ( (d=opendir(path[0] ? OsPath(path, tmp) : ".")) )
{ size_t plen = strlen(path);
{ size_t plen = clen+prefix_len;
if ( plen > 0 && path[plen-1] != '/' )
path[plen++] = '/';

929
os/pl-locale.c Normal file
View File

@ -0,0 +1,929 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2013, VU University Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#include "pl-incl.h"
#include "pl-locale.h"
#if defined(__sun) || __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1070
#undef HAVE_WCSDUP /* No prototype, so better use our own */
#endif
#ifdef O_LOCALE
#include <locale.h>
#define LOCK() PL_LOCK(L_LOCALE) /* MT locking */
#define UNLOCK() PL_UNLOCK(L_LOCALE)
#undef LD /* fetch LD once per function */
#define LD LOCAL_LD
#define LSTR_MAX 16
#ifndef HAVE_LOCALECONV
typedef struct
{ char *decimal_point;
char *thousands_sep;
char *grouping;
} lconv;
struct lconv *
localeconv(void)
{ static struct lconv defl =
{ ".",
",",
"\003\003"
};
return &defl;
}
#endif
#ifndef HAVE_WCSDUP
static wchar_t *
my_wcsdup(const wchar_t *in)
{ wchar_t *copy = malloc((wcslen(in)+1)*sizeof(wchar_t));
if ( copy )
return wcscpy(copy, in);
return NULL;
}
#define wcsdup(ws) my_wcsdup(ws)
#endif
static wchar_t *
ls_to_wcs(const char *in, const wchar_t *on_error)
{ wchar_t buf[LSTR_MAX];
mbstate_t state;
memset(&state, 0, sizeof(state));
mbsrtowcs(buf, &in, LSTR_MAX, &state);
if ( in == NULL )
{ return wcsdup(buf);
} else
{ Sdprintf("Illegal locale string: %s\n", in);
return wcsdup(on_error);
}
}
static int
init_locale_strings(PL_locale *l, struct lconv *conv)
{ if ( conv )
{ l->decimal_point = ls_to_wcs(conv->decimal_point, L".");
l->thousands_sep = ls_to_wcs(conv->thousands_sep, L",");
l->grouping = strdup(conv->grouping);
return TRUE;
} else
{ l->decimal_point = wcsdup(L".");
l->thousands_sep = wcsdup(L",");
l->grouping = strdup("\003");
return FALSE;
}
}
static PL_locale *
new_locale(PL_locale *proto)
{ PL_locale *new = PL_malloc(sizeof(*new));
if ( new )
{ memset(new, 0, sizeof(*new));
new->magic = LOCALE_MAGIC;
if ( proto )
{ new->decimal_point = wcsdup(proto->decimal_point);
new->thousands_sep = wcsdup(proto->thousands_sep);
new->grouping = strdup(proto->grouping);
} else
{ init_locale_strings(new, localeconv());
}
}
return new;
}
static void
free_locale_strings(PL_locale *l)
{ free(l->decimal_point);
free(l->thousands_sep);
free(l->grouping);
}
static void
free_locale(PL_locale *l)
{ if ( l )
{ free_locale_strings(l);
if ( l->alias )
PL_unregister_atom(l->alias);
PL_free(l);
}
}
static void
update_locale(PL_locale *l, int category, const char *locale)
{ free_locale_strings(l);
init_locale_strings(l, localeconv());
}
static int
alias_locale(PL_locale *l, atom_t alias)
{ int rc;
LOCK();
if ( !GD->locale.localeTable )
GD->locale.localeTable = newHTable(16);
if ( addHTable(GD->locale.localeTable, (void*)alias, l) )
{ l->alias = alias;
PL_register_atom(alias);
rc = TRUE;
} else
{ GET_LD
term_t obj = PL_new_term_ref();
PL_put_atom(obj, alias);
rc = PL_error("locale_create", 2, "Alias name already taken",
ERR_PERMISSION, ATOM_create, ATOM_locale, obj);
}
UNLOCK();
return rc;
}
/*******************************
* LOCALE BLOB *
*******************************/
typedef struct locale_ref
{ PL_locale *data;
} locale_ref;
static int
write_locale_ref(IOSTREAM *s, atom_t aref, int flags)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
(void)flags;
Sfprintf(s, "<locale>(%p)", ref->data);
return TRUE;
}
static void
acquire_locale_ref(atom_t aref)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
(void)ref;
}
static int
release_locale_ref(atom_t aref)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
LOCK();
if ( ref->data->references == 0 )
free_locale(ref->data);
else
ref->data->symbol = 0;
UNLOCK();
return TRUE;
}
static int
save_locale_ref(atom_t aref, IOSTREAM *fd)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
(void)fd;
return PL_warning("Cannot save reference to <locale>(%p)", ref->data);
}
static atom_t
load_locale_ref(IOSTREAM *fd)
{ (void)fd;
return PL_new_atom("<saved-locale-ref>");
}
static PL_blob_t locale_blob =
{ PL_BLOB_MAGIC,
PL_BLOB_UNIQUE,
"locale",
release_locale_ref,
NULL,
write_locale_ref,
acquire_locale_ref,
save_locale_ref,
load_locale_ref
};
/*******************************
* PROLOG HANDLE *
*******************************/
int
unifyLocale(term_t t, PL_locale *l, int alias)
{ GET_LD
term_t b;
if ( l->alias && alias )
return PL_unify_atom(t, l->alias);
if ( l->symbol )
return PL_unify_atom(t, l->symbol);
if ( (b=PL_new_term_ref()) &&
PL_put_blob(b, &l, sizeof(l), &locale_blob) )
{ PL_get_atom(b, &l->symbol);
assert(l->symbol);
return PL_unify(t, b);
}
return FALSE;
}
int
getLocale(term_t t, PL_locale **lp)
{ GET_LD
atom_t a;
if ( PL_get_atom(t, &a) )
{ PL_locale *l = NULL;
PL_blob_t *bt;
locale_ref *ref;
if ( a == ATOM_current_locale )
{ GET_LD
l = LD->locale.current;
} else if ( (ref=PL_blob_data(a, NULL, &bt)) && bt == &locale_blob )
{ l = ref->data;
} else if ( GD->locale.localeTable )
{ Symbol s;
if ( (s=lookupHTable(GD->locale.localeTable, (void*)a)) )
l = s->value;
}
if ( l )
{ assert(l->magic == LOCALE_MAGIC);
*lp = acquireLocale(l);
return TRUE;
}
}
return FALSE;
}
int
getLocaleEx(term_t t, PL_locale **lp)
{ GET_LD
if ( getLocale(t, lp) )
return TRUE;
if ( PL_is_atom(t) )
return PL_existence_error("locale", t);
else
return PL_type_error("locale", t);
}
/*******************************
* PROLOG BINDING *
*******************************/
static int /* locale_property(Mutex, alias(Name)) */
locale_alias_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->alias )
return PL_unify_atom(prop, l->alias);
return FALSE;
}
static int /* locale_property(Locale, decimal_point(Atom)) */
locale_decimal_point_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->decimal_point && l->decimal_point[0] )
return PL_unify_wchars(prop, PL_ATOM, (size_t)-1, l->decimal_point);
return FALSE;
}
static int /* locale_property(Locale, thousands_sep(Atom)) */
locale_thousands_sep_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->thousands_sep && l->thousands_sep[0] )
return PL_unify_wchars(prop, PL_ATOM, (size_t)-1, l->thousands_sep);
return FALSE;
}
static int /* locale_property(Locale, grouping(List)) */
locale_grouping_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->grouping && l->grouping[0] )
{ term_t tail = PL_copy_term_ref(prop);
term_t head = PL_new_term_ref();
char *s;
for(s=l->grouping; ; s++)
{ if ( !PL_unify_list(tail, head, tail) )
return FALSE;
if ( s[1] == 0 || (s[1] == s[0] && s[2] == 0) )
return ( PL_unify_term(head, PL_FUNCTOR, FUNCTOR_repeat1,
PL_INT, (int)s[0]) &&
PL_unify_nil(tail)
);
if ( s[0] == CHAR_MAX )
return PL_unify_nil(tail);
if ( !PL_unify_integer(head, s[0]) )
return FALSE;
}
}
return FALSE;
}
typedef struct
{ functor_t functor; /* functor of property */
int (*function)(); /* function to generate */
} lprop;
static const lprop lprop_list [] =
{ { FUNCTOR_alias1, locale_alias_property },
{ FUNCTOR_decimal_point1, locale_decimal_point_property },
{ FUNCTOR_thousands_sep1, locale_thousands_sep_property },
{ FUNCTOR_grouping1, locale_grouping_property },
{ 0, NULL }
};
typedef struct
{ TableEnum e; /* Enumerator on mutex-table */
PL_locale *l; /* current locale */
const lprop *p; /* Pointer in properties */
int enum_properties; /* Enumerate the properties */
} lprop_enum;
static int
get_prop_def(term_t t, atom_t expected, const lprop *list, const lprop **def)
{ GET_LD
functor_t f;
if ( PL_get_functor(t, &f) )
{ const lprop *p = list;
for( ; p->functor; p++ )
{ if ( f == p->functor )
{ *def = p;
return TRUE;
}
}
PL_error(NULL, 0, NULL, ERR_DOMAIN, expected, t);
return -1;
}
if ( PL_is_variable(t) )
return 0;
PL_error(NULL, 0, NULL, ERR_TYPE, expected, t);
return -1;
}
static int
advance_lstate(lprop_enum *state)
{ if ( state->enum_properties )
{ state->p++;
if ( state->p->functor )
return TRUE;
state->p = lprop_list;
}
if ( state->e )
{ Symbol s;
if ( (s = advanceTableEnum(state->e)) )
{ state->l = s->value;
return TRUE;
}
}
return FALSE;
}
static void
free_lstate(lprop_enum *state)
{ if ( state->e )
freeTableEnum(state->e);
else if ( state->l )
releaseLocale(state->l);
freeForeignState(state, sizeof(*state));
}
static int
get_atom_arg(term_t t, atom_t *a)
{ GET_LD
term_t t2 = PL_new_term_ref();
return PL_get_arg(1, t, t2) && PL_get_atom(t2, a);
}
/** locale_property(?Locale, ?Property) is nondet.
*/
static
PRED_IMPL("locale_property", 2, locale_property, PL_FA_NONDETERMINISTIC)
{ PRED_LD
term_t locale = A1;
term_t property = A2;
lprop_enum statebuf;
lprop_enum *state;
switch( CTX_CNTRL )
{ case FRG_FIRST_CALL:
{ memset(&statebuf, 0, sizeof(statebuf));
state = &statebuf;
if ( PL_is_variable(locale) )
{ switch( get_prop_def(property, ATOM_locale_property,
lprop_list, &state->p) )
{ case 1:
{ atom_t alias;
if ( state->p->functor == FUNCTOR_alias1 &&
get_atom_arg(property, &alias) )
{ Symbol s;
if ( (s=lookupHTable(GD->locale.localeTable, (void*)alias)) )
return unifyLocale(locale, s->value, FALSE);
else
return FALSE;
}
state->e = newTableEnum(GD->locale.localeTable);
goto enumerate;
}
case 0:
state->e = newTableEnum(GD->locale.localeTable);
state->p = lprop_list;
state->enum_properties = TRUE;
goto enumerate;
case -1:
return FALSE;
}
} else if ( getLocale(locale, &state->l) )
{ switch( get_prop_def(property, ATOM_locale_property,
lprop_list, &state->p) )
{ case 1:
goto enumerate;
case 0:
state->p = lprop_list;
state->enum_properties = TRUE;
goto enumerate;
case -1:
return FALSE;
}
} else
{ return FALSE;
}
}
case FRG_REDO:
state = CTX_PTR;
break;
case FRG_CUTTED:
state = CTX_PTR;
free_lstate(state);
succeed;
default:
assert(0);
}
enumerate:
if ( !state->l ) /* first time, enumerating locales */
{ Symbol s;
assert(state->e);
if ( (s=advanceTableEnum(state->e)) )
{ state->l = s->value;
} else
{ freeTableEnum(state->e);
assert(state != &statebuf);
return FALSE;
}
}
{ term_t arg = PL_new_term_ref();
if ( !state->enum_properties )
_PL_get_arg(1, property, arg);
for(;;)
{ if ( (*state->p->function)(state->l, arg PASS_LD) )
{ if ( state->enum_properties )
{ if ( !PL_unify_term(property,
PL_FUNCTOR, state->p->functor,
PL_TERM, arg) )
goto error;
}
if ( state->e )
{ if ( !unifyLocale(locale, state->l, TRUE) )
goto error;
}
if ( advance_lstate(state) )
{ if ( state == &statebuf )
{ lprop_enum *copy = allocForeignState(sizeof(*copy));
*copy = *state;
state = copy;
}
ForeignRedoPtr(state);
}
if ( state != &statebuf )
free_lstate(state);
return TRUE;
}
if ( !advance_lstate(state) )
{ error:
if ( state != &statebuf )
free_lstate(state);
return FALSE;
}
}
}
}
static int
set_chars(term_t t, wchar_t **valp)
{ wchar_t *s;
if ( PL_get_wchars(t, NULL, &s, CVT_ATOM|CVT_EXCEPTION) )
{ free(*valp);
if ( (*valp = wcsdup(s)) )
return TRUE;
return PL_no_memory();
}
return FALSE;
}
#define MAX_GROUPING 10
static int
get_group_size_ex(term_t t, int *s)
{ int i;
if ( PL_get_integer_ex(t, &i) )
{ if ( i > 0 && i < CHAR_MAX )
{ *s = i;
return TRUE;
}
return PL_domain_error("digit_group_size", t);
}
return FALSE;
}
static int
set_grouping(term_t t, char **valp)
{ GET_LD
char s[MAX_GROUPING];
term_t tail = PL_copy_term_ref(t);
term_t head = PL_new_term_ref();
char *o = s;
while(PL_get_list_ex(tail, head, tail))
{ int g;
if ( o-s+2 >= MAX_GROUPING )
return PL_representation_error("digit_groups");
if ( PL_is_functor(head, FUNCTOR_repeat1) )
{ if ( !PL_get_nil_ex(tail) )
return FALSE;
_PL_get_arg(1, head, head);
if ( get_group_size_ex(head, &g) )
{ *o++ = g;
goto end;
}
return FALSE;
}
if ( get_group_size_ex(head, &g) )
{ *o++ = g;
} else
return FALSE;
}
if ( PL_get_nil_ex(tail) )
{ *o++ = CHAR_MAX; /* no more grouping */
end:
*o++ = '\0';
free(*valp);
if ( (*valp = strdup(s)) )
return TRUE;
return PL_no_memory();
}
return FALSE;
}
/** locale_create(-Locale, +Default, +Options) is det.
*/
static
PRED_IMPL("locale_create", 3, locale_create, 0)
{ PRED_LD
PL_locale *def, *new;
char *lname;
if ( PL_get_chars(A2, &lname, CVT_LIST|CVT_STRING|REP_MB) )
{ const char *old;
LOCK();
if ( (old=setlocale(LC_NUMERIC, lname)) )
{ new = new_locale(NULL);
setlocale(LC_NUMERIC, old);
} else
{ assert(0); /* keep compiler happy */
return FALSE;
}
UNLOCK();
if ( !old )
{ if ( errno == ENOENT )
return PL_existence_error("locale", A2);
else
return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setlocale");
}
} else
{ if ( !getLocaleEx(A2, &def) )
return FALSE;
new = new_locale(def);
releaseLocale(def);
}
if ( new )
{ atom_t alias = 0;
term_t tail = PL_copy_term_ref(A3);
term_t head = PL_new_term_ref();
term_t arg = PL_new_term_ref();
while(PL_get_list_ex(tail, head, tail))
{ atom_t pname;
int parity;
if ( !PL_get_name_arity(head, &pname, &parity) ||
parity != 1 ||
!PL_get_arg(1, head, arg) )
{ PL_type_error("locale_property", head);
goto error;
}
if ( pname == ATOM_alias )
{ if ( !PL_get_atom_ex(arg, &alias) )
goto error;
} else if ( pname == ATOM_decimal_point )
{ if ( !set_chars(arg, &new->decimal_point) )
goto error;
} else if ( pname == ATOM_thousands_sep )
{ if ( !set_chars(arg, &new->thousands_sep) )
goto error;
} else if ( pname == ATOM_grouping )
{ if ( !set_grouping(arg, &new->grouping) )
goto error;
}
}
if ( !PL_get_nil_ex(tail) )
{
error:
free_locale(new);
return FALSE;
}
if ( alias && !alias_locale(new, alias) )
goto error;
return unifyLocale(A1, new, TRUE);
} else
{ return PL_no_memory();
}
}
static
PRED_IMPL("locale_destroy", 1, locale_destroy, 0)
{ PL_locale *l;
if ( getLocaleEx(A1, &l) )
{ if ( l->alias )
{ Symbol s;
atom_t alias = l->alias;
LOCK();
if ( (s=lookupHTable(GD->locale.localeTable, (void*)alias)) )
deleteSymbolHTable(GD->locale.localeTable, s);
l->alias = 0;
PL_unregister_atom(alias);
UNLOCK();
}
releaseLocale(l);
return TRUE;
}
return FALSE;
}
/** set_locale(+Locale) is det.
*/
static
PRED_IMPL("set_locale", 1, set_locale, 0)
{ PRED_LD
PL_locale *l;
if ( getLocaleEx(A1, &l) )
{ PL_locale *ol = LD->locale.current;
if ( l != ol )
{ IOSTREAM **sp;
LD->locale.current = l; /* already acquired */
if ( ol )
releaseLocale(ol);
if ( (sp=_PL_streams()) ) /* set locale of standard streams */
{ int i;
for(i=0; i<5; i++)
Ssetlocale(sp[i], l, NULL);
}
}
return TRUE;
}
return FALSE;
}
/** current_locale(-Locale) is det.
*/
static
PRED_IMPL("current_locale", 1, current_locale, 0)
{ PRED_LD
if ( LD->locale.current )
return unifyLocale(A1, LD->locale.current, TRUE);
return FALSE;
}
/*******************************
* C INTERFACE *
*******************************/
static void
initDefaultsStreamsLocale(PL_locale *l)
{ IOSTREAM *s = S__getiob();
int i;
for(i=0; i<2; i++, s++)
{ if ( !s->locale )
s->locale = acquireLocale(l);
}
}
void
initLocale(void)
{ GET_LD
PL_locale *def;
if ( !setlocale(LC_NUMERIC, "") )
{ DEBUG(0, Sdprintf("Failed to set LC_NUMERIC locale\n"));
}
if ( (def = new_locale(NULL)) )
{ alias_locale(def, ATOM_default);
def->references++;
GD->locale.default_locale = def;
LD->locale.current = acquireLocale(def);
initDefaultsStreamsLocale(def);
}
}
void
updateLocale(int category, const char *locale)
{ update_locale(GD->locale.default_locale, category, locale);
}
int
initStreamLocale(IOSTREAM *s)
{ GET_LD
PL_locale *l;
if ( LD ) /* a Prolog thread */
l = LD->locale.current;
else
l = GD->locale.default_locale;
if ( l )
s->locale = acquireLocale(l);
return TRUE;
}
PL_locale *
acquireLocale(PL_locale *l)
{ LOCK();
l->references++;
UNLOCK();
return l;
}
void
releaseLocale(PL_locale *l)
{ LOCK();
if ( --l->references == 0 && l->symbol == 0 && l->alias == 0 )
free_locale(l);
UNLOCK();
}
/*******************************
* PUBLISH PREDICATES *
*******************************/
BeginPredDefs(locale)
PRED_DEF("locale_property", 2, locale_property, PL_FA_NONDETERMINISTIC)
PRED_DEF("locale_create", 3, locale_create, 0)
PRED_DEF("locale_destroy", 1, locale_destroy, 0)
PRED_DEF("set_locale", 1, set_locale, 0)
PRED_DEF("current_locale", 1, current_locale, 0)
EndPredDefs
#endif /*O_LOCALE*/

50
os/pl-locale.h Normal file
View File

@ -0,0 +1,50 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2013, VU University Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef PL_LOCALE_H_INCLUDED
#define PL_LOCALE_H_INCLUDED
#define LOCALE_MAGIC 37838743
typedef struct PL_locale
{ atom_t alias; /* named alias (if any) */
atom_t symbol; /* blob handle */
int magic; /* LOCALE_MAGIC */
int references; /* Reference count */
/* POSIX locale properties */
wchar_t *decimal_point; /* Radix character */
wchar_t *thousands_sep; /* Separator for digit group left of radix character */
char *grouping; /* Grouping */
} PL_locale;
#define PL_HAVE_PL_LOCALE 1
COMMON(void) initLocale(void);
COMMON(void) updateLocale(int category, const char *locale);
COMMON(PL_locale *) acquireLocale(PL_locale *l);
COMMON(void) releaseLocale(PL_locale *l);
COMMON(int) initStreamLocale(IOSTREAM *s);
COMMON(int) unifyLocale(term_t t, PL_locale *l, int alias);
COMMON(int) getLocale(term_t t, PL_locale **lp);
COMMON(int) getLocaleEx(term_t t, PL_locale **lp);
#endif /*PL_LOCALE_H_INCLUDED*/

69
os/pl-option.c
View File

@ -19,7 +19,7 @@
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#include "pl-incl.h"
@ -39,6 +39,7 @@ typedef union
long *l; /* long value */
int *i; /* integer value */
uintptr_t *sz; /* size_t value */
double *f; /* double value */
char **s; /* string value */
word *a; /* atom value */
term_t *t; /* term-reference */
@ -93,37 +94,30 @@ scan_options(term_t options, int flags, atom_t optype,
{ if ( s->name == name )
{ switch((s->type & OPT_TYPE_MASK))
{ case OPT_BOOL:
{ atom_t aval;
{ int bval;
if ( !PL_get_atom(val, &aval) )
fail;
if ( aval == ATOM_true || aval == ATOM_on )
*values[n].b = TRUE;
else if ( aval == ATOM_false || aval == ATOM_off )
*values[n].b = FALSE;
else
goto itemerror;
if ( !PL_get_bool_ex(val, &bval) )
return FALSE;
*values[n].b = bval;
break;
}
case OPT_INT:
{ if ( !PL_get_integer(val, values[n].i) )
goto itemerror;
{ if ( !PL_get_integer_ex(val, values[n].i) )
return FALSE;
break;
}
case OPT_LONG:
{ if ( !PL_get_long(val, values[n].l) )
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].l = LONG_MAX;
else
goto itemerror;
}
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].l = LONG_MAX;
else if ( !PL_get_long_ex(val, values[n].l) )
return FALSE;
break;
}
case OPT_NATLONG:
{ if ( !PL_get_long(val, values[n].l) )
goto itemerror;
{ if ( !PL_get_long_ex(val, values[n].l) )
return FALSE;
if ( *(values[n].l) <= 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_not_less_than_one, val);
@ -131,31 +125,46 @@ scan_options(term_t options, int flags, atom_t optype,
break;
}
case OPT_SIZE:
{ if ( !PL_get_uintptr(val, values[n].sz) )
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].sz = (size_t)-1;
else
goto itemerror;
}
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].sz = (size_t)-1;
else if ( !PL_get_size_ex(val, values[n].sz) )
return FALSE;
break;
}
case OPT_DOUBLE:
{ if ( !PL_get_float_ex(val, values[n].f) )
return FALSE;
break;
}
case OPT_STRING:
{ char *str;
if ( !PL_get_chars(val, &str, CVT_ALL) ) /* copy? */
goto itemerror;
if ( !PL_get_chars(val, &str, CVT_ALL|CVT_EXCEPTION) ) /* copy? */
return FALSE;
*values[n].s = str;
break;
}
case OPT_ATOM:
{ atom_t a;
if ( !PL_get_atom(val, &a) )
goto itemerror;
if ( !PL_get_atom_ex(val, &a) )
return FALSE;
*values[n].a = a;
break;
}
#ifdef O_LOCALE
case OPT_LOCALE:
{ PL_locale *l;
PL_locale **lp = values[n].ptr;
if ( !getLocaleEx(val, &l) )
return FALSE;
*lp = l;
break;
}
#endif
case OPT_TERM:
{ *values[n].t = val;
val = PL_new_term_ref(); /* can't reuse anymore */

6
os/pl-option.h
View File

@ -19,7 +19,7 @@
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef OPTION_H_INCLUDED
@ -33,6 +33,8 @@
#define OPT_LONG (5)
#define OPT_NATLONG (6) /* > 0 */
#define OPT_SIZE (7) /* size_t */
#define OPT_DOUBLE (8)
#define OPT_LOCALE (9)
#define OPT_TYPE_MASK 0xff
#define OPT_INF 0x100 /* allow 'inf' */
@ -43,7 +45,7 @@ typedef struct
int type; /* Type of option */
} opt_spec, *OptSpec;
COMMON(int) scan_options(term_t list, int flags, atom_t name,
COMMON(int) scan_options(term_t list, int flags, atom_t name,
const opt_spec *specs, ...);
#endif /*OPTION_H_INCLUDED*/

24
os/pl-os.c
View File

@ -43,8 +43,7 @@ is supposed to give the POSIX standard one.
#include "pl-incl.h"
#include "pl-ctype.h"
#include "pl-utf8.h"
#undef abs
#include <math.h> /* avoid abs() problem with msvc++ */
#include <math.h>
#include <stdio.h> /* rename() and remove() prototypes */
#if TIME_WITH_SYS_TIME
@ -203,11 +202,6 @@ static char errmsg[64];
consult a file or to execute a query.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifdef HAVE_CLOCK_GETTIME
#define timespec_to_double(ts) \
((double)(ts).tv_sec + (double)(ts).tv_nsec/(double)1000000000.0)
#endif
#ifndef __WINDOWS__ /* defined in pl-nt.c */
#ifdef HAVE_TIMES
@ -224,6 +218,11 @@ static char errmsg[64];
#endif /*_SC_CLK_TCK*/
#endif /*HAVE_TIMES*/
#ifdef HAVE_CLOCK_GETTIME
#define timespec_to_double(ts) \
((double)(ts).tv_sec + (double)(ts).tv_nsec/(double)1000000000.0)
#endif
double
CpuTime(cputime_kind which)
{
@ -398,7 +397,7 @@ setOSPrologFlags(void)
uintptr_t
UsedMemory(void)
{ GET_LD
{ //GET_LD
#if defined(HAVE_GETRUSAGE) && defined(HAVE_RU_IDRSS)
struct rusage usage;
@ -1478,12 +1477,9 @@ AbsoluteFile(const char *spec, char *path)
}
strcpy(path, GD->paths.CWDdir);
if ( file[0] != EOS )
strcpy(&path[GD->paths.CWDlen], file);
if ( strchr(file, '.') || strchr(file, '/') )
return canonisePath(path);
else
return path;
strcpy(&path[GD->paths.CWDlen], file);
return canonisePath(path);
}

7
os/pl-os.h
View File

@ -3,9 +3,10 @@
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
Copyright (C): 1985-2011, University of Amsterdam
VU University Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -19,7 +20,7 @@
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_SYS_PARAM_H /* get MAXPATHLEN */

2
os/pl-prologflag.c
View File

@ -1315,7 +1315,9 @@ cleanupPrologFlags(void)
{ Table t = GD->prolog_flag.table;
GD->prolog_flag.table = NULL;
#ifdef O_PLMT
t->free_symbol = freeSymbolPrologFlagTable;
#endif
destroyHTable(t);
}
}

47
os/pl-read.c
View File

@ -113,22 +113,43 @@ addUTF8Buffer(Buffer b, int c)
}
}
/*******************************
* UNICODE CLASSIFIERS *
*******************************/
/*******************************
* UNICODE CLASSIFIERS *
*******************************/
#define CharTypeW(c, t, w) \
((unsigned)(c) <= 0xff ? (_PL_char_types[(unsigned)(c)] t) \
: (uflagsW(c) & w))
((unsigned)(c) <= 0xff ? (_PL_char_types[(unsigned)(c)] t) \
: (uflagsW(c) & (w)))
#define PlBlankW(c) CharTypeW(c, <= SP, U_SEPARATOR)
#define PlUpperW(c) CharTypeW(c, == UC, U_UPPERCASE)
#define PlIdStartW(c) (c <= 0xff ? (isLower(c)||isUpper(c)||c=='_') \
: uflagsW(c) & U_ID_START)
#define PlIdContW(c) CharTypeW(c, >= UC, U_ID_CONTINUE)
#define PlSymbolW(c) CharTypeW(c, == SY, 0)
#define PlPunctW(c) CharTypeW(c, == PU, 0)
#define PlSoloW(c) CharTypeW(c, == SO, 0)
#define PlBlankW(c) CharTypeW(c, == SP, U_SEPARATOR)
#define PlUpperW(c) CharTypeW(c, == UC, U_UPPERCASE)
#define PlIdStartW(c) (c <= 0xff ? (isLower(c)||isUpper(c)||c=='_') \
: uflagsW(c) & U_ID_START)
#define PlIdContW(c) CharTypeW(c, >= UC, U_ID_CONTINUE)
#define PlSymbolW(c) CharTypeW(c, == SY, U_SYMBOL)
#define PlPunctW(c) CharTypeW(c, == PU, 0)
#define PlSoloW(c) CharTypeW(c, == SO, U_OTHER)
#define PlInvalidW(c) (uflagsW(c) == 0)
int
f_is_prolog_var_start(wint_t c)
{ return PlIdStartW(c) && (PlUpperW(c) || c == '_');
}
int
f_is_prolog_atom_start(wint_t c)
{ return PlIdStartW(c) != 0;
}
int
f_is_prolog_identifier_continue(wint_t c)
{ return PlIdContW(c) || c == '_';
}
int
f_is_prolog_symbol(wint_t c)
{ return PlSymbolW(c) != 0;
}
int
unicode_separator(pl_wchar_t c)

3
os/pl-rl.c
View File

@ -73,6 +73,9 @@ SWI-Prolog.h and SWI-Stream.h
#ifdef HAVE_CLOCK
#include <time.h>
#endif
#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
#ifdef __WINDOWS__
#include <io.h>
#endif

108
os/pl-stream.c
View File

@ -21,7 +21,7 @@
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#if defined(__WINDOWS__)|| defined(__WIN32)
#ifdef __WINDOWS__
#include "windows/uxnt.h"
#ifdef _YAP_NOT_INSTALLED_
#include <config.h>
@ -57,6 +57,7 @@ locking is required.
#endif
#define PL_KERNEL 1
#define O_LOCALE 1
#include <wchar.h>
#define NEEDS_SWINSOCK
#include "SWI-Stream.h"
@ -96,10 +97,6 @@ locking is required.
#include SYSLIB_H
#endif
#ifndef MB_LEN_MAX
#define MB_LEN_MAX 6
#endif
#define ROUND(p, n) ((((p) + (n) - 1) & ~((n) - 1)))
#define UNDO_SIZE ROUND(PL_MB_LEN_MAX, sizeof(wchar_t))
@ -139,9 +136,12 @@ STRYLOCK(IOSTREAM *s)
#endif
#include "pl-error.h"
#ifdef O_LOCALE
#include "pl-locale.h"
#endif
extern int fatalError(const char *fm, ...);
extern int PL_handle_signals(void);
extern int PL_handle_signals();
extern IOENC initEncoding(void);
extern int reportStreamError(IOSTREAM *s);
extern record_t PL_record(term_t t);
@ -1134,9 +1134,10 @@ Speekcode(IOSTREAM *s)
start = s->bufp;
if ( s->position )
{ IOPOS psave = *s->position;
{ IOPOS *psave = s->position;
s->position = NULL;
c = Sgetcode(s);
*s->position = psave;
s->position = psave;
} else
{ c = Sgetcode(s);
}
@ -1328,6 +1329,8 @@ ScheckBOM(IOSTREAM *s)
{ s->encoding = bd->encoding;
s->bufp += bd->bomlen;
s->flags |= SIO_BOM;
if ( s->position )
s->position->byteno += bd->bomlen;
return 0;
}
}
@ -1481,6 +1484,27 @@ Ssetenc(IOSTREAM *s, IOENC enc, IOENC *old)
return 0;
}
#ifdef O_LOCALE
int
Ssetlocale(IOSTREAM *s, PL_locale *new, PL_locale **old)
{ PL_locale *lo = s->locale;
if ( old )
*old = s->locale;
if ( new == s->locale )
return 0;
if ( new )
s->locale = acquireLocale(new);
else
s->locale = NULL;
if ( lo )
releaseLocale(lo);
return 0;
}
#endif
/*******************************
* FLUSH *
*******************************/
@ -1775,6 +1799,8 @@ Sclose(IOSTREAM *s)
if ( s->message )
free(s->message);
if ( s->locale )
releaseLocale(s->locale);
if ( s->references == 0 )
unallocStream(s);
else
@ -1898,7 +1924,6 @@ Svprintf(const char *fm, va_list args)
break; \
} \
default: \
c = '\0'; /* make compiler happy */\
break; \
}
@ -2256,11 +2281,9 @@ Svsprintf(char *buf, const char *fm, va_list args)
int
Svdprintf(const char *fm, va_list args)
{ int rval;
IOSTREAM *s = Serror;
//IOSTREAM *s = Sopen_file("/home/vsc/cout.txt", "append");
IOSTREAM *s = Serror;
//Slock(s);
Slock(s);
rval = Svfprintf(s, fm, args);
#if defined(_DEBUG) && defined(__WINDOWS__)
Sputc('\0', s);
@ -2269,8 +2292,7 @@ Svdprintf(const char *fm, va_list args)
#endif
if ( Sflush(s) != 0 )
rval = -1;
//Sunlock(s);
//Sclose(s);
Sunlock(s);
return rval;
}
@ -2681,7 +2703,7 @@ Sclose_file(void *handle)
do
{ rc = close((int) h);
} while ( rc == -1 && errno == EINTR );
} while ( rc == -1 && errno == EINTR );
return rc;
}
@ -2750,8 +2772,7 @@ IOFUNCTIONS Sttyfunctions =
application instead of returning EINVAL on wrong values of fd. As we
provide the socket-id through Sfileno, this code crashes on
tcp_open_socket(). As ttys and its detection is of no value on Windows
anyway, we skip this. Second, Windows doesn't have fork(), so FD_CLOEXEC
is of no value.
anyway, we skip this.
For now, we use PL_malloc_uncollectable(). In the end, this is really
one of the object-types we want to leave to GC.
@ -2797,16 +2818,25 @@ Snew(void *handle, int flags, IOFUNCTIONS *functions)
}
#endif
#ifndef __WINDOWS__ /* (*) */
{ int fd;
if ( (fd = Sfileno(s)) >= 0 )
{ if ( isatty(fd) )
{
#ifndef __WINDOWS__ /* (*) */
if ( isatty(fd) )
s->flags |= SIO_ISATTY;
#ifdef F_SETFD
#endif
#if defined(F_SETFD)
fcntl(fd, F_SETFD, FD_CLOEXEC);
#elif defined(__WINDOWS__)
SetHandleInformation((HANDLE)_get_osfhandle(fd),
HANDLE_FLAG_INHERIT, 0);
#endif
}
}
#ifdef O_LOCALE
initStreamLocale(s);
#endif
return s;
@ -3132,9 +3162,9 @@ Sopen_pipe(const char *command, const char *type)
{ int flags;
if ( *type == 'r' )
flags = SIO_INPUT|SIO_FBUF;
flags = SIO_INPUT|SIO_RECORDPOS|SIO_FBUF;
else
flags = SIO_OUTPUT|SIO_FBUF;
flags = SIO_OUTPUT|SIO_RECORDPOS|SIO_FBUF;
return Snew((void *)fd, flags, &Spipefunctions);
}
@ -3161,7 +3191,8 @@ typedef struct
size_t size; /* size of buffer */
size_t *sizep; /* pointer to size */
size_t allocated; /* allocated size */
char **buffer; /* allocated buffer */
char *buffer; /* allocated buffer */
char **bufferp; /* Write-back location */
int malloced; /* malloc() maintained */
} memfile;
@ -3197,29 +3228,29 @@ Swrite_memfile(void *handle, char *buf, size_t size)
return -1;
}
if ( !mf->malloced )
{ if ( *mf->buffer )
memcpy(nb, *mf->buffer, mf->allocated);
{ if ( mf->buffer )
memcpy(nb, mf->buffer, mf->allocated);
mf->malloced = TRUE;
}
} else
{ if ( !(nb = realloc(*mf->buffer, ns)) )
{ if ( !(nb = realloc(mf->buffer, ns)) )
{ errno = ENOMEM;
return -1;
}
}
mf->allocated = ns;
*mf->buffer = nb;
*mf->bufferp = mf->buffer = nb;
}
memcpy(&(*mf->buffer)[mf->here], buf, size);
memcpy(&mf->buffer[mf->here], buf, size);
mf->here += size;
if ( mf->here > mf->size )
{ mf->size = mf->here;
if ( mf->sizep ) /* make externally known */
*mf->sizep = mf->size;
(*mf->buffer)[mf->size] = '\0';
mf->buffer[mf->size] = '\0';
}
return size;
@ -3237,7 +3268,7 @@ Sread_memfile(void *handle, char *buf, size_t size)
size = mf->size - mf->here;
}
memcpy(buf, &(*mf->buffer)[mf->here], size);
memcpy(buf, &mf->buffer[mf->here], size);
mf->here += size;
return size;
@ -3323,7 +3354,7 @@ and other output predicates to create strings.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
IOSTREAM *
Sopenmem(char **buffer, size_t *sizep, const char *mode)
Sopenmem(char **bufp, size_t *sizep, const char *mode)
{ memfile *mf = malloc(sizeof(memfile));
int flags = SIO_FBUF|SIO_RECORDPOS|SIO_NOMUTEX;
size_t size;
@ -3334,12 +3365,14 @@ Sopenmem(char **buffer, size_t *sizep, const char *mode)
}
mf->malloced = FALSE;
mf->bufferp = bufp;
mf->buffer = *bufp;
switch(*mode)
{ case 'r':
flags |= SIO_INPUT;
if ( sizep == NULL || *sizep == (size_t)-1 )
size = (*buffer ? strlen(*buffer) : 0);
size = (mf->buffer ? strlen(mf->buffer) : 0);
else
size = *sizep;
mf->size = size;
@ -3349,10 +3382,10 @@ Sopenmem(char **buffer, size_t *sizep, const char *mode)
flags |= SIO_OUTPUT;
mf->size = 0;
mf->allocated = (sizep ? *sizep : 0);
if ( *buffer == NULL || mode[1] == 'a' )
if ( mf->buffer == NULL || mode[1] == 'a' )
mf->malloced = TRUE;
if ( *buffer )
*buffer[0] = '\0';
if ( mf->buffer )
mf->buffer[0] = '\0';
if ( sizep )
*sizep = mf->size;
break;
@ -3364,7 +3397,6 @@ Sopenmem(char **buffer, size_t *sizep, const char *mode)
mf->sizep = sizep;
mf->here = 0;
mf->buffer = buffer;
return Snew(mf, flags, &Smemfunctions);
}
@ -3506,7 +3538,7 @@ SinitStreams(void)
for(i=0; i<=2; i++)
{ IOSTREAM *s = &S__iob[i];
if ( !isatty(i) )
if ( !isatty(i) && s->functions == &Sttyfunctions )
{ s->flags &= ~SIO_ISATTY;
s->functions = &Sfilefunctions; /* Check for pipe? */
}

2
os/pl-string.h
View File

@ -27,7 +27,7 @@
COMMON(char *) store_string(const char *s);
COMMON(void) remove_string(char *s);
//COMMON(char) digitName(int n, int small);
COMMON(char) digitName(int n, int small);
COMMON(int) digitValue(int b, int c);
COMMON(bool) strprefix(const char *string, const char *prefix);
COMMON(bool) strpostfix(const char *string, const char *postfix);

6
os/pl-table.c
View File

@ -109,13 +109,15 @@ destroyHTable(Table ht)
static int lookups;
static int cmps;
void
int
exitTables(int status, void *arg)
{ (void)status;
(void)arg;
Sdprintf("hashstat: Anonymous tables: %d lookups using %d compares\n",
lookups, cmps);
return 0;
}
#endif
@ -173,7 +175,7 @@ rehashHTable(Table ht, Symbol map)
{ Symbol *newentries, *oldentries;
int newbuckets, oldbuckets;
int i;
#ifdef O_PLMT
#if P_PLMT
int safe_copy = (ht->mutex != NULL);
#else
int safe_copy = TRUE;

2
os/pl-tai.c
View File

@ -23,8 +23,8 @@
#define __MINGW_USE_VC2005_COMPAT /* Get Windows time_t as 64-bit */
#include <math.h>
#include "pl-incl.h"
#include <math.h>
#include "libtai/taia.h"
#include "libtai/caltime.h"
#include <stdio.h>

9
os/pl-text.c
View File

@ -280,9 +280,12 @@ PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD)
encodings[1] = ENC_WCHAR;
encodings[2] = ENC_UNKNOWN;
wflags = ((flags&CVT_WRITE_CANONICAL)
? PL_WRT_QUOTED|PL_WRT_IGNOREOPS|PL_WRT_NUMBERVARS
: PL_WRT_NUMBERVARS);
if ( (flags&CVT_WRITEQ) == CVT_WRITEQ )
wflags = PL_WRT_QUOTED|PL_WRT_NUMBERVARS;
else if ( (flags&CVT_WRITE_CANONICAL) )
wflags = PL_WRT_QUOTED|PL_WRT_IGNOREOPS|PL_WRT_NUMBERVARS;
else
wflags = PL_WRT_NUMBERVARS;
for(enc = encodings; *enc != ENC_UNKNOWN; enc++)
{ size_t size;

7
os/pl-text.h
View File

@ -81,4 +81,11 @@ COMMON(int) get_atom_ptr_text(Atom atom, PL_chars_t *text);
COMMON(int) get_atom_text(atom_t atom, PL_chars_t *text);
COMMON(int) get_string_text(atom_t atom, PL_chars_t *text ARG_LD);
static inline int
text_get_char(const PL_chars_t *t, size_t i)
{ assert(t->canonical);
return t->encoding == ENC_ISO_LATIN_1 ? t->text.t[i]&0xff
: t->text.w[i];
}
#endif /*PL_TEXT_H_INCLUDED*/

40
os/pl-thread.h
View File

@ -1,15 +1,30 @@
#ifndef PL_THREAD_H
/* Part of SWI-Prolog
#define PL_THREAD_H 1
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2012, University of Amsterdam
VU University Amsterdam
#if defined(THREADS) && !defined(O_PLMT)
#define O_PLMT 1
#endif
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
#if defined(O_PLMT) // && defined(PL_KERNEL)
/* Support PL_LOCK in the interface */
#if THREADS
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef PL_THREAD_H_DEFINED
#define PL_THREAD_H_DEFINED
#ifdef THREADS
#include <pthread.h>
typedef pthread_mutex_t simpleMutex;
@ -67,9 +82,10 @@ extern counting_mutex _PL_mutexes[]; /* Prolog mutexes */
#define L_STOPTHEWORLD 19
#define L_FOREIGN 20
#define L_OS 21
#define L_LOCALE 23
#ifdef __WINDOWS__
#define L_DDE 22
#define L_CSTACK 23
#define L_DDE 24
#define L_CSTACK 25
#endif
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@ -128,8 +144,6 @@ compile-time
#define IOLOCK recursiveMutex
#endif
#else
#define PL_LOCK(X)
#define PL_UNLOCK(X)
@ -138,3 +152,5 @@ typedef void * IOLOCK;
#endif
#endif

3951
os/pl-umap.c
View File

File diff suppressed because it is too large Load Diff