2015-06-18 01:59:07 +01:00
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L . Damas , V . S . Costa and Universidade do Porto 2015 - *
* *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* *
* File : flags . c *
* Last rev : *
* mods : *
* comments : abstract machine definitions *
* *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/** @file flags.c
@ ingroup Flags
@ {
*/
// this is where we define flags
# define INIT_FLAGS 1
# include "Yap.h"
static bool ro ( Term inp ) ;
static bool nat ( Term inp ) ;
static bool isatom ( Term inp ) ;
static bool boolean ( Term inp ) ;
//static bool string( Term inp );
//static bool list_atom( Term inp );
static bool list_option ( Term inp ) ;
static bool argv ( Term inp ) ;
static bool os_argv ( Term inp ) ;
static bool agc_threshold ( Term inp ) ;
static bool gc_margin ( Term inp ) ;
static bool executable ( Term inp ) ;
static bool sys_thread_id ( Term inp ) ;
static bool mkprompt ( Term inp ) ;
static bool synerr ( Term inp ) ;
static bool indexer ( Term inp ) ;
static bool getenc ( Term inp ) ;
static bool typein ( Term inp ) ;
2015-08-07 22:57:53 +01:00
static bool dqf ( Term t2 ) ;
2015-06-18 01:59:07 +01:00
static void newFlag ( Term fl , Term val ) ;
static Int current_prolog_flag ( USES_REGS1 ) ;
static Int set_prolog_flag ( USES_REGS1 ) ;
# include "Yatom.h"
# include "yapio.h"
# include "eval.h"
# define YAP_FLAG( ID, NAME, WRITABLE, DEF, INIT, HELPER ) { NAME, WRITABLE, DEF, INIT, HELPER }
# define GZERO_FLAG { NULL, false, NULL, NULL, NULL }
# define LZERO_FLAG { NULL, false, NULL, NULL, NULL }
static flag_info global_flags_setup [ ] = {
# include "YapGFlagInfo.h"
GZERO_FLAG
} ;
static flag_info local_flags_setup [ ] = {
# include "YapLFlagInfo.h"
LZERO_FLAG
} ;
static bool indexer ( Term inp ) {
if ( inp = = TermOff | |
inp = = TermSingle | |
inp = = TermCompact | |
inp = = TermMulti | |
inp = = TermOn | |
inp = = TermMax )
return true ;
if ( IsAtomTerm ( inp ) ) {
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , inp , " set_prolog_flag index in {off,single,compact,multi,on,max} " ) ;
return false ;
}
Yap_Error ( TYPE_ERROR_ATOM , inp , " set_prolog_flag in {dec10,error,fail,quiet} " ) ;
return false ;
}
2015-09-21 23:05:36 +01:00
static bool dqf1 ( ModEntry * new , Term t2 USES_REGS ) {
2015-08-07 22:57:53 +01:00
new - > flags & = ~ ( DBLQ_CHARS | DBLQ_CODES | DBLQ_ATOM | DBLQ_STRING ) ;
2015-09-29 23:11:57 +01:00
if ( IsAtomTerm ( t2 ) ) {
if ( t2 = = TermString ) {
new - > flags | = DBLQ_STRING ;
return true ;
} else if ( t2 = = TermAtom ) {
new - > flags | = DBLQ_ATOM ;
return true ;
} else if ( t2 = = TermCodes ) {
new - > flags | = DBLQ_CODES ;
return true ;
} else if ( t2 = = TermChars ) {
new - > flags | = DBLQ_CHARS ;
return true ;
}
/* bad argument, but still an atom */
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , t2 , " bad option %s for backquoted string flag, use one string, arom, codes or chars " , RepAtom ( AtomOfTerm ( t2 ) ) - > StrOfAE ) ;
return false ;
} else {
Yap_Error ( TYPE_ERROR_ATOM , t2 , " set_prolog_flag(double_quotes, %s), should be {string,atom,codes,chars} " , RepAtom ( AtomOfTerm ( t2 ) ) - > StrOfAE ) ;
return false ;
2015-08-07 22:57:53 +01:00
}
}
2015-09-29 23:11:57 +01:00
static bool dqf ( Term t2 ) {
2015-09-21 23:05:36 +01:00
CACHE_REGS
ModEntry * new = Yap_GetModuleEntry ( CurrentModule ) ;
return dqf1 ( new , t2 PASS_REGS ) ;
}
2015-06-18 01:59:07 +01:00
2015-09-29 23:11:57 +01:00
static bool bqf1 ( ModEntry * new , Term t2 USES_REGS ) {
new - > flags & = ~ ( BCKQ_CHARS | BCKQ_CODES | BCKQ_ATOM | BCKQ_STRING ) ;
if ( IsAtomTerm ( t2 ) ) {
if ( t2 = = TermString ) {
new - > flags | = BCKQ_STRING ;
return true ;
} else if ( t2 = = TermAtom ) {
new - > flags | = BCKQ_ATOM ;
return true ;
} else if ( t2 = = TermCodes ) {
new - > flags | = BCKQ_CODES ;
return true ;
} else if ( t2 = = TermChars ) {
new - > flags | = BCKQ_CHARS ;
return true ;
}
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , t2 , " bad option %s for backquoted string flag, use one string, arom, codes or chars " , RepAtom ( AtomOfTerm ( t2 ) ) - > StrOfAE ) ;
return false ;
} else {
Yap_Error ( TYPE_ERROR_ATOM , t2 , " flag %s is not module-scoped " , RepAtom ( AtomOfTerm ( t2 ) ) - > StrOfAE ) ;
return false ;
}
}
2015-06-18 01:59:07 +01:00
static bool isaccess ( Term inp ) {
if ( inp = = TermReadWrite | |
inp = = TermReadOnly )
return true ;
if ( IsAtomTerm ( inp ) ) {
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , inp , " set_prolog_flag access in {read_write,read_only} " ) ;
return false ;
}
Yap_Error ( TYPE_ERROR_ATOM , inp , " set_prolog_flag access in {read_write,read_only} " ) ;
return false ;
}
static bool isground ( Term inp ) {
return Yap_IsGroundTerm ( inp ) ;
}
static bool flagscope ( Term inp ) {
if ( inp = = TermGlobal | |
inp = = TermThread | |
inp = = TermModule )
return true ;
if ( IsAtomTerm ( inp ) ) {
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , inp , " set_prolog_flag access in {global,module,thread} " ) ;
return false ;
}
Yap_Error ( TYPE_ERROR_ATOM , inp , " set_prolog_flag access in {global,module,thread} " ) ;
return false ;
}
static bool mkprompt ( Term inp ) {
CACHE_REGS
if ( IsVarTerm ( inp ) ) {
return Yap_unify ( inp , MkAtomTerm ( Yap_LookupAtom ( LOCAL_Prompt ) ) ) ;
}
if ( ! IsAtomTerm ( inp ) ) {
Yap_Error ( TYPE_ERROR_ATOM , inp , " set_prolog_flag " ) ;
return false ;
}
2015-09-21 23:05:36 +01:00
strncpy ( LOCAL_Prompt , ( const char * ) RepAtom ( AtomOfTerm ( inp ) ) - > StrOfAE , MAX_PROMPT ) ;
2015-06-18 01:59:07 +01:00
return true ;
}
static bool getenc ( Term inp ) {
CACHE_REGS
if ( IsVarTerm ( inp ) ) {
return Yap_unify ( inp , MkAtomTerm ( Yap_LookupAtom ( enc_name ( LOCAL_encoding ) ) ) ) ;
}
if ( ! IsAtomTerm ( inp ) ) {
Yap_Error ( TYPE_ERROR_ATOM , inp , " set_prolog_flag " ) ;
return false ;
}
2015-09-21 23:05:36 +01:00
enc_id ( ( char * ) RepAtom ( AtomOfTerm ( inp ) ) - > StrOfAE ) ;
2015-06-18 01:59:07 +01:00
return true ;
}
/*
static bool enablerl ( Term inp ) {
CACHE_REGS
if ( IsVarTerm ( inp ) ) {
return Yap_unify ( inp , MkAtomTerm ( Yap_LookupAtom ( enc_name ( LOCAL_encoding ) ) ) ) ;
}
if ( ! IsAtomTerm ( inp ) ) {
Yap_Error ( TYPE_ERROR_ATOM , inp , " set_prolog_flag " ) ;
return false ;
}
enc_id ( RepAtom ( AtomOfTerm ( inp ) ) - > StrOfAE ) ;
return true ;
}
*/
static bool typein ( Term inp ) {
CACHE_REGS
if ( IsVarTerm ( inp ) ) {
Term tin = CurrentModule ;
if ( tin = = PROLOG_MODULE )
2015-09-29 23:11:57 +01:00
tin = TermProlog ;
2015-06-18 01:59:07 +01:00
return Yap_unify ( inp , tin ) ;
}
if ( ! IsAtomTerm ( inp ) ) {
Yap_Error ( TYPE_ERROR_ATOM , inp , " set_prolog_flag " ) ;
return false ;
}
CurrentModule = inp ;
if ( inp = = TermProlog ) CurrentModule = PROLOG_MODULE ;
return true ;
}
#if 0
static Int p_has_yap_or ( USES_REGS1 ) {
# ifdef YAPOR
return ( TRUE ) ;
# else
return ( FALSE ) ;
# endif
}
static Int p_has_eam ( USES_REGS1 ) {
# ifdef BEAM
return ( TRUE ) ;
# else
return ( FALSE ) ;
# endif
}
static Int p_has_jit ( USES_REGS1 ) {
# ifdef HAS_JIT
return ( TRUE ) ;
# else
return ( FALSE ) ;
# endif
}
static bool tabling ( Term inp ) {
if ( value = = 0 ) { /* default */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
TabEnt_mode ( tab_ent ) = TabEnt_flags ( tab_ent ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
yap_flags [ TA BLING_MODE_FLAG ] = 0 ;
} else if ( value = = 1 ) { /* batched */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
SetMode_Batched ( TabEnt_mode ( tab_ent ) ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
SetMode_Batched ( yap_flags [ TABLING_MODE_FLAG ] ) ;
} else if ( value = = 2 ) { /* local */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
SetMode_Local ( TabEnt_mode ( tab_ent ) ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
SetMode_Local ( yap_flags [ TABLING_MODE_FLAG ] ) ;
} else if ( value = = 3 ) { /* exec_answers */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
SetMode_ExecAnswers ( TabEnt_mode ( tab_ent ) ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
SetMode_ExecAnswers ( yap_flags [ TABLING_MODE_FLAG ] ) ;
} else if ( value = = 4 ) { /* load_answers */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
SetMode_LoadAnswers ( TabEnt_mode ( tab_ent ) ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
SetMode_LoadAnswers ( yap_flags [ TABLING_MODE_FLAG ] ) ;
} else if ( value = = 5 ) { /* local_trie */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
SetMode_LocalTrie ( TabEnt_mode ( tab_ent ) ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
SetMode_LocalTrie ( yap_flags [ TABLING_MODE_FLAG ] ) ;
} else if ( value = = 6 ) { /* global_trie */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
SetMode_GlobalTrie ( TabEnt_mode ( tab_ent ) ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
SetMode_GlobalTrie ( yap_flags [ TABLING_MODE_FLAG ] ) ;
} else if ( value = = 7 ) { /* CoInductive */
tab_ent_ptr tab_ent = GLOBAL_root_tab_ent ;
while ( tab_ent ) {
SetMode_CoInductive ( TabEnt_mode ( tab_ent ) ) ;
tab_ent = TabEnt_next ( tab_ent ) ;
}
SetMode_CoInductive ( yap_flags [ TABLING_MODE_FLAG ] ) ;
}
}
static bool string ( Term inp ) {
if ( IsVarTerm ( inp ) ) {
Yap_Error ( INSTANTIATION_ERROR , inp , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
if ( IsStringTerm ( inp ) )
return true ;
Term inp0 = inp ;
if ( IsPairTerm ( inp ) ) {
Term hd = HeadOfTerm ( inp ) ;
if ( IsAtomTerm ( hd ) ) {
do {
Term hd = HeadOfTerm ( inp ) ;
if ( ! IsAtomTerm ( hd ) ) {
Yap_Error ( TYPE_ERROR_TEXT , inp0 , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
} while ( IsPairTerm ( inp ) ) ;
} else if ( IsIntTerm ( hd ) ) {
do {
Term hd = HeadOfTerm ( inp ) ;
if ( ! IsIntTerm ( hd ) ) {
Yap_Error ( TYPE_ERROR_TEXT , inp0 , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
if ( IntOfTerm ( hd ) < 0 ) {
Yap_Error ( DOMAIN_ERROR_NOT_LESS_THAN_ZERO , inp0 , " set_prolog_flag in 0... " ) ;
return false ;
}
} while ( IsPairTerm ( inp ) ) ;
} else {
Yap_Error ( TYPE_ERROR_TEXT , inp0 , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
}
if ( inp ! = TermNil ) {
Yap_Error ( TYPE_ERROR_TEXT , inp0 , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
return true ;
}
static bool list_atom ( Term inp ) {
if ( IsVarTerm ( inp ) ) {
Yap_Error ( INSTANTIATION_ERROR , inp , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
Term inp0 = inp ;
if ( IsPairTerm ( inp ) ) {
Term hd = HeadOfTerm ( inp ) ;
do {
if ( ! IsAtomTerm ( hd ) ) {
Yap_Error ( TYPE_ERROR_ATOM , inp0 , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
} while ( IsPairTerm ( inp ) ) ;
}
if ( inp ! = TermNil ) {
Yap_Error ( TYPE_ERROR_LIST , inp0 , " set_prolog_flag in [...] " ) ;
return false ;
}
return true ;
}
# endif
static bool list_option ( Term inp ) {
if ( IsVarTerm ( inp ) ) {
Yap_Error ( INSTANTIATION_ERROR , inp , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
Term inp0 = inp ;
if ( IsPairTerm ( inp ) ) {
do {
Term hd = HeadOfTerm ( inp ) ;
inp = TailOfTerm ( inp ) ;
if ( IsAtomTerm ( hd ) ) {
continue ;
}
if ( IsApplTerm ( hd ) ) {
Functor f = FunctorOfTerm ( hd ) ;
if ( ! IsExtensionFunctor ( f ) & &
ArityOfFunctor ( f ) = = 1 & &
Yap_IsGroundTerm ( hd ) ) {
continue ;
}
if ( ! Yap_IsGroundTerm ( hd ) )
Yap_Error ( INSTANTIATION_ERROR , hd , " set_prolog_flag in \" ... \" " ) ;
return false ;
}
} while ( IsPairTerm ( inp ) ) ;
if ( inp = = TermNil ) {
return true ;
}
Yap_Error ( TYPE_ERROR_LIST , inp0 , " set_prolog_flag in [...] " ) ;
return false ;
} else /* lone option */ {
if ( IsAtomTerm ( inp ) ) {
return true ;
} else if ( IsApplTerm ( inp ) ) {
Functor f = FunctorOfTerm ( inp ) ;
if ( ! IsExtensionFunctor ( f ) & &
ArityOfFunctor ( f ) = = 1 & &
Yap_IsGroundTerm ( ArgOfTerm ( 1 , inp ) ) ) {
return true ;
}
}
}
return false ;
}
static bool agc_threshold ( Term t ) {
t = Deref ( t ) ;
if ( IsVarTerm ( t ) ) {
CACHE_REGS
return Yap_unify ( t , MkIntegerTerm ( GLOBAL_AGcThreshold ) ) ;
} else if ( ! IsIntegerTerm ( t ) ) {
Yap_Error ( TYPE_ERROR_INTEGER , t , " prolog_flag/2 agc_margin " ) ;
return FALSE ;
} else {
Int i = IntegerOfTerm ( t ) ;
if ( i < 0 ) {
Yap_Error ( DOMAIN_ERROR_NOT_LESS_THAN_ZERO , t , " prolog_flag/2 agc_margin " ) ;
return FALSE ;
} else {
GLOBAL_AGcThreshold = i ;
return TRUE ;
}
}
}
static bool gc_margin ( Term t ) {
t = Deref ( t ) ;
if ( IsVarTerm ( t ) ) {
return Yap_unify ( t , Yap_GetValue ( AtomGcMargin ) ) ;
} else if ( ! IsIntegerTerm ( t ) ) {
Yap_Error ( TYPE_ERROR_INTEGER , t , " prolog_flag/2 agc_margin " ) ;
return FALSE ;
} else {
Int i = IntegerOfTerm ( t ) ;
if ( i < 0 ) {
Yap_Error ( DOMAIN_ERROR_NOT_LESS_THAN_ZERO , t , " prolog_flag/2 gc_margin " ) ;
return FALSE ;
} else {
CACHE_REGS
Yap_PutValue ( AtomGcMargin , MkIntegerTerm ( i ) ) ;
return TRUE ;
}
}
}
static Term mk_argc_list ( USES_REGS1 ) {
2015-08-07 22:57:53 +01:00
int i = 1 ;
2015-06-18 01:59:07 +01:00
Term t = TermNil ;
while ( i < GLOBAL_argc ) {
char * arg = GLOBAL_argv [ i ] ;
/* check for -L -- */
if ( arg [ 0 ] = = ' - ' & & arg [ 1 ] = = ' L ' ) {
arg + = 2 ;
while ( * arg ! = ' \0 ' & & ( * arg = = ' ' | | * arg = = ' \t ' ) )
arg + + ;
if ( * arg = = ' - ' & & arg [ 1 ] = = ' - ' & & arg [ 2 ] = = ' \0 ' ) {
/* we found the separator */
int j ;
for ( j = GLOBAL_argc - 1 ; j > i + 1 ; - - j ) {
t = MkPairTerm ( MkAtomTerm ( Yap_LookupAtom ( GLOBAL_argv [ j ] ) ) , t ) ;
}
return t ;
} else if ( GLOBAL_argv [ i + 1 ] & & GLOBAL_argv [ i + 1 ] [ 0 ] = = ' - ' & &
GLOBAL_argv [ i + 1 ] [ 1 ] = = ' - ' & &
GLOBAL_argv [ i + 1 ] [ 2 ] = = ' \0 ' ) {
/* we found the separator */
int j ;
for ( j = GLOBAL_argc - 1 ; j > i + 2 ; - - j ) {
t = MkPairTerm ( MkAtomTerm ( Yap_LookupAtom ( GLOBAL_argv [ j ] ) ) , t ) ;
}
return t ;
}
}
if ( arg [ 0 ] = = ' - ' & & arg [ 1 ] = = ' - ' & & arg [ 2 ] = = ' \0 ' ) {
/* we found the separator */
int j ;
for ( j = GLOBAL_argc - 1 ; j > i ; - - j ) {
t = MkPairTerm ( MkAtomTerm ( Yap_LookupAtom ( GLOBAL_argv [ j ] ) ) , t ) ;
}
return ( t ) ;
}
i + + ;
}
return ( t ) ;
}
static Term mk_os_argc_list ( USES_REGS1 ) {
int i = 0 ;
Term t = TermNil ;
for ( i = 0 ; i < GLOBAL_argc ; i + + ) {
char * arg = GLOBAL_argv [ i ] ;
t = MkPairTerm ( MkAtomTerm ( Yap_LookupAtom ( arg ) ) , t ) ;
}
return ( t ) ;
}
static bool argv ( Term inp ) {
CACHE_REGS
2015-08-07 22:57:53 +01:00
Term t = mk_argc_list ( PASS_REGS1 ) ;
if ( IsAtomOrIntTerm ( t ) )
GLOBAL_Flags [ ARGV_FLAG ] . at = t ;
else {
GLOBAL_Flags [ ARGV_FLAG ] . DBT = Yap_StoreTermInDB ( t , 2 ) ;
}
return false ;
2015-06-18 01:59:07 +01:00
}
static bool os_argv ( Term inp ) {
CACHE_REGS
2015-08-07 22:57:53 +01:00
Term t = mk_os_argc_list ( PASS_REGS1 ) ;
if ( IsAtomOrIntTerm ( t ) )
GLOBAL_Flags [ OS_ARGV_FLAG ] . at = t ;
else {
GLOBAL_Flags [ OS_ARGV_FLAG ] . DBT = Yap_StoreTermInDB ( t , 2 ) ;
}
return false ;
2015-06-18 01:59:07 +01:00
}
static FlagEntry *
GetFlagProp ( Atom a )
{ /* look property list of atom a for kind */
AtomEntry * ae = RepAtom ( a ) ;
FlagEntry * pp ;
READ_LOCK ( ae - > ARWLock ) ;
pp = RepFlagProp ( ae - > PropsOfAE ) ;
while ( ! EndOfPAEntr ( pp ) & & pp - > KindOfPE ! = FlagProperty )
pp = RepFlagProp ( pp - > NextOfPE ) ;
READ_UNLOCK ( ae - > ARWLock ) ;
return pp ;
}
static void
initFlag ( flag_info * f , int fnum , bool global )
{
Atom name = Yap_LookupAtom ( f - > name ) ;
AtomEntry * ae = RepAtom ( name ) ;
WRITE_LOCK ( ae - > ARWLock ) ;
FlagEntry * fprop = RepFlagProp ( Yap_GetAPropHavingLock ( name , FlagProperty ) ) ;
if ( fprop = = NULL ) {
fprop = ( FlagEntry * ) Yap_AllocAtomSpace ( sizeof ( FlagEntry ) ) ;
if ( fprop = = NULL ) {
WRITE_UNLOCK ( ae - > ARWLock ) ;
2015-09-25 10:57:26 +01:00
Yap_Error ( RESOURCE_ERROR_HEAP , TermNil , " not enough space for new Flag %s " , ae - > StrOfAE ) ; return ;
2015-06-18 01:59:07 +01:00
}
fprop - > KindOfPE = FlagProperty ;
fprop - > FlagOfVE = fnum ;
fprop - > rw = f - > writable ;
fprop - > global = global ;
fprop - > type = f - > def ;
fprop - > helper = f - > helper ;
AddPropToAtom ( ae , AbsFlagProp ( fprop ) ) ;
}
WRITE_UNLOCK ( ae - > ARWLock ) ;
}
static bool executable ( Term inp ) {
CACHE_REGS
if ( GLOBAL_argv & & GLOBAL_argv [ 0 ] )
Yap_TrueFileName ( GLOBAL_argv [ 0 ] , LOCAL_FileNameBuf , FALSE ) ;
else
strncpy ( LOCAL_FileNameBuf , Yap_FindExecutable ( ) , YAP_FILENAME_MAX - 1 ) ;
return Yap_unify ( MkAtomTerm ( Yap_LookupAtom ( LOCAL_FileNameBuf ) ) , inp ) ;
}
static bool sys_thread_id ( Term inp )
{
CACHE_REGS
int pid ;
# ifdef HAVE_GETTID_SYSCALL
pid = syscall ( __NR_gettid ) ;
# elif defined(HAVE_GETTID_MACRO)
pid = gettid ( ) ;
# elif defined(__WINDOWS__)
pid = GetCurrentThreadId ( ) ;
# else
pid = 0 ;
# endif
return Yap_unify ( MkIntegerTerm ( pid ) , inp ) ;
}
static bool setYapFlagInModule ( Term tflag , Term t2 , Term mod )
{
2015-09-29 23:11:57 +01:00
CACHE_REGS
2015-06-18 01:59:07 +01:00
FlagEntry * fv ;
ModEntry * new = Yap_GetModuleEntry ( mod ) ;
2015-09-21 23:05:36 +01:00
if ( ! new )
2015-06-18 01:59:07 +01:00
return false ;
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
if ( ! fv & & ! fv - > global ) {
2015-08-07 22:57:53 +01:00
Yap_Error ( DOMAIN_ERROR_PROLOG_FLAG , tflag , " trying to set unknown module flag " ) ;
2015-09-21 23:05:36 +01:00
return false ;
2015-06-18 01:59:07 +01:00
}
if ( mod = = USER_MODULE & & ! setYapFlag ( tflag , t2 ) )
return false ;
// module specific stuff now
if ( fv - > FlagOfVE = = UNKNOWN_FLAG ) {
if ( t2 = = TermError ) {
new - > flags & = ~ ( UNKNOWN_FAIL | UNKNOWN_WARNING ) ;
new - > flags | = ( UNKNOWN_ERROR ) ;
return true ;
} else if ( t2 = = TermFail ) {
new - > flags & = ~ ( UNKNOWN_ERROR | UNKNOWN_WARNING ) ;
new - > flags | = ( UNKNOWN_FAIL ) ;
return true ;
} else if ( t2 = = TermWarning ) {
new - > flags & = ~ ( UNKNOWN_ERROR | UNKNOWN_FAIL ) ;
new - > flags | = ( UNKNOWN_WARNING ) ;
return true ;
}
2015-09-29 23:11:57 +01:00
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , t2 , " bad option %s for unknown flag, use one of error, fail or warning. " , RepAtom ( AtomOfTerm ( tflag ) ) - > StrOfAE ) ;
2015-06-18 01:59:07 +01:00
return false ;
2015-09-29 23:11:57 +01:00
} else if ( fv - > FlagOfVE = = DOUBLE_QUOTES_FLAG ) {
return dqf1 ( new , t2 PASS_REGS ) ;
2015-06-18 01:59:07 +01:00
} else if ( fv - > FlagOfVE = = CHARACTER_ESCAPES_FLAG ) {
if ( t2 = = TermTrue ) {
new - > flags | = M_CHARESCAPE ;
return true ;
} else if ( t2 = = TermFalse ) {
new - > flags & = ~ ( M_CHARESCAPE ) ;
2015-09-29 23:11:57 +01:00
return true ;
2015-06-18 01:59:07 +01:00
}
2015-09-29 23:11:57 +01:00
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , t2 , " bad option %s for character_escapes flag, use true or false " , RepAtom ( AtomOfTerm ( tflag ) ) - > StrOfAE ) ;
2015-06-18 01:59:07 +01:00
return false ;
2015-09-29 23:11:57 +01:00
} else if ( fv - > FlagOfVE = = BACKQUOTED_STRING_FLAG ) {
return bqf1 ( new , t2 PASS_REGS ) ; ;
2015-06-18 01:59:07 +01:00
}
2015-09-29 23:11:57 +01:00
// bad key?
return false ;
2015-06-18 01:59:07 +01:00
}
static Term getYapFlagInModule ( Term tflag , Term mod )
{
FlagEntry * fv ;
ModEntry * new = Yap_GetModuleEntry ( mod ) ;
if ( ! mod )
return false ;
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
if ( ! fv & & ! fv - > global ) {
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , tflag , " trying to set unknown flag " ) ;
return 0L ;
}
// module specific stuff now
if ( fv - > FlagOfVE = = UNKNOWN_FLAG ) {
if ( new - > flags & UNKNOWN_ERROR )
return TermError ;
if ( new - > flags & UNKNOWN_WARNING )
return TermWarning ;
return TermFail ;
} else if ( fv - > FlagOfVE = = CHARACTER_ESCAPES_FLAG ) {
if ( new - > flags & M_CHARESCAPE )
return TermTrue ;
} else if ( fv - > FlagOfVE = = BACKQUOTED_STRING_FLAG ) {
2015-07-06 11:53:50 +01:00
if ( new - > flags & BCKQ_CHARS )
return TermChars ;
if ( new - > flags & BCKQ_CODES )
return TermCodes ;
if ( new - > flags & BCKQ_ATOM )
return TermAtom ;
return TermString ;
} else if ( fv - > FlagOfVE = = DOUBLE_QUOTES_FLAG ) {
if ( new - > flags & DBLQ_CHARS )
return TermChars ;
if ( new - > flags & DBLQ_CODES )
return TermCodes ;
if ( new - > flags & DBLQ_ATOM )
return TermAtom ;
return TermString ;
}
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , tflag , " flag %s is not module-scoped " , RepAtom ( AtomOfTerm ( tflag ) ) - > StrOfAE ) ;
2015-06-18 01:59:07 +01:00
return 0L ;
}
2015-06-18 07:55:07 +01:00
static Int cont_yap_flag ( USES_REGS1 ) {
2015-06-18 01:59:07 +01:00
int i = IntOfTerm ( EXTRA_CBACK_ARG ( 2 , 1 ) ) ;
int gmax = GLOBAL_flagCount ;
int lmax = LOCAL_flagCount ;
Term tflag = Deref ( ARG1 ) ;
EXTRA_CBACK_ARG ( 2 , 1 ) = MkIntTerm ( i + 1 ) ;
if ( IsApplTerm ( tflag ) & & FunctorOfTerm ( tflag ) = = FunctorModule ) {
Term modt = CurrentModule ;
tflag = Yap_StripModule ( tflag , & modt ) ;
while ( i ! = gmax & &
i ! = UNKNOWN_FLAG & &
i ! = CHARACTER_ESCAPES_FLAG & &
i ! = BACKQUOTED_STRING_FLAG ) i + + ;
if ( i = = gmax ) cut_fail ( ) ;
EXTRA_CBACK_ARG ( 2 , 1 ) = MkIntTerm ( i + 1 ) ;
{
Term lab = MkAtomTerm ( Yap_LookupAtom ( global_flags_setup [ i ] . name ) ) ;
Term val = Deref ( ARG2 ) ;
if ( ! Yap_unify ( tflag , lab ) )
return false ;
if ( IsVarTerm ( val ) ) {
Term oval = getYapFlagInModule ( lab , modt ) ;
if ( oval = = 0 )
return false ;
return Yap_unify ( oval , val ) ;
} else {
return setYapFlagInModule ( tflag , val , modt ) ;
}
}
return false ;
}
if ( i > = gmax ) {
Yap_unify ( ARG1 , MkAtomTerm ( Yap_LookupAtom ( local_flags_setup [ i - gmax ] . name ) ) ) ;
if ( i = = gmax + lmax - 1 )
do_cut ( 0 ) ;
} else {
Yap_unify ( ARG1 , MkAtomTerm ( Yap_LookupAtom ( global_flags_setup [ i ] . name ) ) ) ;
}
Term flag = getYapFlag ( Deref ( ARG1 ) ) ;
return Yap_unify ( flag , ARG2 ) ;
}
static Int yap_flag ( USES_REGS1 ) {
Term tflag = Deref ( ARG1 ) ;
if ( IsVarTerm ( tflag ) ) {
EXTRA_CBACK_ARG ( 2 , 1 ) = MkIntTerm ( 0 ) ;
return cont_yap_flag ( PASS_REGS1 ) ;
}
if ( IsApplTerm ( tflag ) & & FunctorOfTerm ( tflag ) = = FunctorModule ) {
Term modt ;
tflag = Yap_StripModule ( tflag , & modt ) ;
if ( IsVarTerm ( tflag ) ) {
EXTRA_CBACK_ARG ( 2 , 1 ) = MkIntTerm ( 0 ) ;
2015-06-18 07:55:07 +01:00
return cont_yap_flag ( PASS_REGS1 ) ;
2015-06-18 01:59:07 +01:00
}
do_cut ( 0 ) ;
if ( ! isatom ( tflag ) ) return false ;
if ( ! isatom ( modt ) ) return false ;
if ( IsVarTerm ( Deref ( ARG2 ) ) ) {
Term flag = getYapFlagInModule ( tflag , modt ) ;
if ( flag = = 0 )
return false ;
return Yap_unify ( flag , ARG2 ) ;
} else {
return setYapFlagInModule ( tflag , Deref ( ARG2 ) , modt ) ;
}
}
do_cut ( 0 ) ;
if ( IsVarTerm ( Deref ( ARG2 ) ) ) {
Term flag = getYapFlag ( Deref ( ARG1 ) ) ;
if ( flag = = 0 )
return false ;
return Yap_unify ( flag , ARG2 ) ;
}
return set_prolog_flag ( PASS_REGS1 ) ;
}
static Int cont_prolog_flag ( USES_REGS1 ) {
int i = IntOfTerm ( EXTRA_CBACK_ARG ( 3 , 1 ) ) ;
while ( i < GLOBAL_flagCount + LOCAL_flagCount ) {
int gmax = GLOBAL_flagCount ;
int lmax = LOCAL_flagCount ;
Term flag , f ;
if ( i > = gmax + lmax ) {
cut_fail ( ) ;
} else if ( i > = gmax ) {
Yap_unify ( ARG1 , ( f = MkAtomTerm ( Yap_LookupAtom ( local_flags_setup [ i - gmax ] . name ) ) ) ) ;
} else {
Yap_unify ( ARG1 , ( f = MkAtomTerm ( Yap_LookupAtom ( global_flags_setup [ i ] . name ) ) ) ) ;
}
EXTRA_CBACK_ARG ( 3 , 1 ) = MkIntTerm ( + + i ) ;
flag = getYapFlag ( f ) ;
if ( ! Yap_unify ( f , ARG2 ) )
return false ;
return setYapFlag ( f , Deref ( ARG3 ) ) ;
}
cut_fail ( ) ;
}
/** @pred prolog_flag(? _Flag_,- _OldValue_,+ _NewValue_)
Obtain the value for a YAP Prolog flag and then set it to a new
value . Equivalent to first calling current_prolog_flag / 2 with the
second argument _OldValue_ unbound and then calling
set_prolog_flag / 2 with the third argument _NewValue_ .
*/
static Int prolog_flag ( USES_REGS1 ) {
if ( IsVarTerm ( Deref ( ARG1 ) ) ) {
EXTRA_CBACK_ARG ( 3 , 1 ) = MkIntTerm ( 0 ) ;
return cont_prolog_flag ( PASS_REGS1 ) ;
}
do_cut ( 0 ) ;
2015-08-07 22:57:53 +01:00
if ( IsVarTerm ( Deref ( ARG2 ) ) ) {
2015-06-18 01:59:07 +01:00
Term flag = getYapFlag ( Deref ( ARG1 ) ) ;
if ( flag = = 0 )
return false ;
2015-08-07 22:57:53 +01:00
return Yap_unify ( flag , ARG2 ) ;
2015-06-18 01:59:07 +01:00
}
return setYapFlag ( Deref ( ARG1 ) , Deref ( ARG3 ) ) ;
}
/** @pred current_prolog_flag(? _Flag_,- _Value_) is iso
Obtain the value for a YAP Prolog flag . Equivalent to calling
yap_flag / 2 with the second argument unbound , and unifying the
returned second argument with _Value_ .
*/
2015-06-18 07:55:07 +01:00
static Int current_prolog_flag ( USES_REGS1 ) {
2015-06-18 01:59:07 +01:00
Term tflag = Deref ( ARG1 ) ;
Term tout = 0 ;
FlagEntry * fv ;
flag_term * tarr ;
if ( IsVarTerm ( tflag ) ) {
EXTRA_CBACK_ARG ( 2 , 1 ) = MkIntTerm ( 0 ) ;
return cont_yap_flag ( PASS_REGS1 ) ;
}
do_cut ( 0 ) ;
if ( ! IsAtomTerm ( tflag ) ) {
Yap_Error ( TYPE_ERROR_ATOM , tflag , " current_prolog_flag/3 " ) ;
return ( FALSE ) ;
}
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
if ( ! fv ) {
// should itself depend on a flag
return FALSE ;
}
if ( fv - > global )
tarr = GLOBAL_Flags ;
else
tarr = LOCAL_Flags ;
tout = tarr [ fv - > FlagOfVE ] . at ;
if ( IsVarTerm ( tout ) )
tout = Yap_FetchTermFromDB ( tarr [ fv - > FlagOfVE ] . DBT ) ;
return ( Yap_unify ( ARG2 , tout ) ) ;
}
void Yap_setModuleFlags ( ModEntry * new , ModEntry * cme )
{
2015-09-29 23:11:57 +01:00
CACHE_REGS
2015-06-18 01:59:07 +01:00
Atom at = new - > AtomOfME ;
2015-09-21 23:05:36 +01:00
if ( at = = AtomProlog | | CurrentModule = = PROLOG_MODULE ) {
new - > flags = M_SYSTEM | UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING ;
if ( at = = AtomUser )
new - > flags = UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING ;
} else if ( cme & &
cme - > flags & & cme ! = new ) {
2015-06-18 01:59:07 +01:00
new - > flags = cme - > flags ;
2015-09-21 23:05:36 +01:00
} else {
new - > flags = ( UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING
) ;
}
//printf("cme=%s new=%s flags=%x\n",cme,at->StrOfAE,new->flags);
}
2015-06-18 01:59:07 +01:00
bool setYapFlag ( Term tflag , Term t2 )
{
FlagEntry * fv ;
flag_term * tarr ;
if ( IsVarTerm ( tflag ) ) {
Yap_Error ( INSTANTIATION_ERROR , tflag , " yap_flag/2 " ) ;
return ( FALSE ) ;
}
if ( IsApplTerm ( tflag ) & & FunctorOfTerm ( tflag ) = = FunctorModule ) {
Term modt ;
tflag = Yap_StripModule ( tflag , & modt ) ;
if ( ! isatom ( tflag ) ) return false ;
if ( ! isatom ( modt ) ) return false ;
return setYapFlagInModule ( tflag , t2 , modt ) ;
}
if ( ! IsAtomTerm ( tflag ) ) {
Yap_Error ( TYPE_ERROR_ATOM , tflag , " yap_flag/2 " ) ;
return ( FALSE ) ;
}
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
if ( ! fv ) {
Term fl = GLOBAL_Flags [ USER_FLAGS_FLAG ] . at ;
if ( fl = = TermSilent ) {
2015-06-18 07:55:07 +01:00
CACHE_REGS
2015-06-18 01:59:07 +01:00
Term t2 = Deref ( ARG2 ) ;
newFlag ( tflag , t2 ) ;
} else if ( fl = = TermWarning ) {
Yap_Warning ( " Flag %s does not exist " , RepAtom ( AtomOfTerm ( fl ) ) - > StrOfAE ) ;
} else {
2015-08-07 22:57:53 +01:00
Yap_Error ( DOMAIN_ERROR_PROLOG_FLAG , fl , " trying to set unknown flag ~s " , AtomName ( AtomOfTerm ( fl ) ) ) ;
2015-06-18 01:59:07 +01:00
}
return FALSE ;
}
if ( fv - > global )
tarr = GLOBAL_Flags ;
else {
CACHE_REGS
tarr = LOCAL_Flags ;
}
if ( ! ( fv - > type ( t2 ) ) )
return false ;
if ( fv - > helper & & ! ( fv - > helper ( t2 ) ) )
return false ;
Term tout = tarr [ fv - > FlagOfVE ] . at ;
if ( IsVarTerm ( tout ) )
Yap_PopTermFromDB ( tarr [ fv - > FlagOfVE ] . DBT ) ;
if ( IsAtomOrIntTerm ( t2 ) )
tarr [ fv - > FlagOfVE ] . at = t2 ;
else {
tarr [ fv - > FlagOfVE ] . DBT = Yap_StoreTermInDB ( t2 , 2 ) ;
}
return true ;
}
Term getYapFlag ( Term tflag )
{
FlagEntry * fv ;
flag_term * tarr ;
if ( IsVarTerm ( tflag ) ) {
Yap_Error ( INSTANTIATION_ERROR , tflag , " yap_flag/2 " ) ;
return ( FALSE ) ;
}
if ( IsApplTerm ( tflag ) & & FunctorOfTerm ( tflag ) = = FunctorModule ) {
Term modt ;
tflag = Yap_StripModule ( tflag , & modt ) ;
if ( ! isatom ( tflag ) ) return false ;
if ( ! isatom ( modt ) ) return false ;
return getYapFlagInModule ( tflag , modt ) ;
}
if ( ! IsAtomTerm ( tflag ) ) {
Yap_Error ( TYPE_ERROR_ATOM , tflag , " yap_flag/2 " ) ;
return ( FALSE ) ;
}
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
if ( ! fv ) {
Term fl = GLOBAL_Flags [ USER_FLAGS_FLAG ] . at ;
if ( fl = = TermSilent ) {
return false ;
} else if ( fl = = TermWarning ) {
Yap_Warning ( " Flag ~s does not exist " , RepAtom ( AtomOfTerm ( fl ) ) - > StrOfAE ) ;
} else {
2015-08-07 22:57:53 +01:00
Yap_Error ( DOMAIN_ERROR_PROLOG_FLAG , fl , " trying to read unknown flag %s " ,
2015-07-06 11:53:50 +01:00
RepAtom ( AtomOfTerm ( fl ) ) - > StrOfAE ) ;
2015-06-18 01:59:07 +01:00
}
return FALSE ;
}
if ( fv - > global )
tarr = GLOBAL_Flags ;
else {
CACHE_REGS
tarr = LOCAL_Flags ;
}
Term tout = tarr [ fv - > FlagOfVE ] . at ;
if ( IsVarTerm ( tout ) )
return Yap_FetchTermFromDB ( tarr [ fv - > FlagOfVE ] . DBT ) ;
else
return tout ;
}
/** @pred set_prolog_flag(+ _Flag_,+ _Value_) is iso
Set the value for YAP Prolog flag ` Flag ` . Equivalent to
calling yap_flag / 2 with both arguments bound .
*/
static Int set_prolog_flag ( USES_REGS1 ) {
Term tflag = Deref ( ARG1 ) , t2 = Deref ( ARG2 ) ;
return setYapFlag ( tflag , t2 ) ;
}
/** @pred source
After executing this goal , YAP keeps information on the source
of the predicates that will be consulted . This enables the use of
[ listing / 0 ] ( @ ref listing ) , ` listing / 1 ` and [ clause / 2 ] ( @ ref clause ) for those
clauses .
The same as ` source_mode ( _ , on ) ` or as declaring all newly defined
static procedures as ` public ` .
*/
static Int source ( USES_REGS1 ) {
setBooleanGlobalPrologFlag ( SOURCE_FLAG , true ) ;
return true ;
}
/** @pred no_source
The opposite to ` source ` .
The same as ` source_mode ( _ , off ) ` .
*/
static Int no_source ( USES_REGS1 ) {
setBooleanGlobalPrologFlag ( SOURCE_FLAG , false ) ;
return true ;
}
/**
@ pred source_mode ( - _O_ , + _N_ )
The state of source mode can either be on or off . When the source mode
is on , all clauses are kept both as compiled code and in a " hidden "
database . _O_ is unified with the previous state and the mode is set
according to _N_ .
*/
static Int
2015-06-18 07:55:07 +01:00
source_mode ( USES_REGS1 )
2015-06-18 01:59:07 +01:00
{
Term targ ;
bool current = trueGlobalPrologFlag ( SOURCE_FLAG ) ;
if ( current & & ! Yap_unify_constant ( ARG1 , TermTrue ) )
return false ;
if ( ! current & & ! Yap_unify_constant ( ARG1 , TermFalse ) )
return false ;
targ = Deref ( ARG2 ) ;
setYapFlag ( TermSource , ARG2 ) ;
return true ;
}
static bool
setInitialValue ( bool bootstrap , flag_func f , const char * s , flag_term * tarr )
{
errno = 0 ;
if ( f = = boolean ) {
if ( ! bootstrap ) { return 0 ; }
if ( ! strcmp ( s , " true " ) ) {
tarr - > at = TermTrue ;
return true ;
}
if ( ! strcmp ( s , " false " ) ) {
tarr - > at = TermFalse ;
return true ;
}
if ( ! strcmp ( s , " on " ) ) {
tarr - > at = TermTrue ;
return true ;
}
if ( ! strcmp ( s , " off " ) ) {
tarr - > at = TermFalse ;
return true ;
}
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , TermNil , " ~s should be either true (on) or false (off) " , s ) ;
return false ;
} else if ( f = = nat ) {
if ( ! bootstrap ) { return 0 ; }
UInt r = strtoul ( s , NULL , 10 ) ;
Term t ;
if ( errno ) {
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , TermNil , " ~s should be a positive integer) " , s ) ;
return false ;
}
CACHE_REGS
t = MkIntegerTerm ( r ) ;
if ( IsIntTerm ( t ) )
tarr - > at = t ;
else {
tarr - > DBT = Yap_StoreTermInDB ( t , 2 ) ;
}
return true ;
} else if ( f = = at2n ) {
if ( ! bootstrap ) { return 0 ; }
if ( ! strcmp ( s , " INT_MAX " ) ) {
tarr - > at = MkIntTerm ( Int_MAX ) ;
return true ;
}
if ( ! strcmp ( s , " MAX_THREADS " ) ) {
tarr - > at = MkIntTerm ( MAX_THREADS ) ;
return true ;
}
if ( ! strcmp ( s , " MAX_WORKERS " ) ) {
tarr - > at = MkIntTerm ( MAX_WORKERS ) ;
return true ;
}
if ( ! strcmp ( s , " INT_MIN " ) ) {
tarr - > at = MkIntTerm ( Int_MIN ) ;
return true ;
}
if ( ! strcmp ( s , " YAP_NUMERIC_VERSION " ) ) {
tarr - > at = MkIntTerm ( atol ( YAP_NUMERIC_VERSION ) ) ;
return true ;
}
if ( ! strcmp ( s , " YAP_NUMERIC_VERSION " ) ) {
tarr - > at = MkIntTerm ( atol ( YAP_NUMERIC_VERSION ) ) ;
return true ;
}
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , TermNil , " ~s should be either true (on) or false (off) " , s ) ;
return false ;
} else if ( f = = isatom ) {
if ( ! bootstrap ) { return false ; }
Atom r = Yap_LookupAtom ( s ) ;
if ( errno ) {
Yap_Error ( DOMAIN_ERROR_OUT_OF_RANGE , TermNil , " ~s should be a positive integer) " , s ) ;
tarr - > at = TermNil ;
}
tarr - > at = MkAtomTerm ( r ) ;
return true ;
} else {
Term t0 ;
if ( bootstrap ) { return false ; }
2015-06-18 07:55:07 +01:00
CACHE_REGS
2015-10-08 02:23:45 +01:00
t0 = Yap_StringToTerm ( s , strlen ( s ) + 1 , & LOCAL_encoding , 1200 , NULL ) ;
2015-06-18 01:59:07 +01:00
if ( ! t0 )
return false ;
if ( IsAtomTerm ( t0 ) | | IsIntTerm ( t0 ) ) {
2015-08-07 22:57:53 +01:00
// do yourself flags
if ( t0 = = MkAtomTerm ( AtomQuery ) ) {
f ( TermNil ) ;
} else {
tarr - > at = t0 ;
}
2015-06-18 01:59:07 +01:00
} else {
tarr - > DBT = Yap_StoreTermInDB ( t0 , 2 ) ;
}
return true ;
}
}
# define PROLOG_FLAG_PROPERTY_DEFS() \
PAR ( " access " , isaccess , PROLOG_FLAG_PROPERTY_ACCESS , " read_write " ) , \
PAR ( " type " , isground , PROLOG_FLAG_PROPERTY_TYPE , " term " ) , \
PAR ( " scope " , flagscope , PROLOG_FLAG_PROPERTY_SCOPE , " global " ) , \
PAR ( " keep " , boolean , PROLOG_FLAG_PROPERTY_KEEP , " false " ) , \
PAR ( NULL , ok , PROLOG_FLAG_PROPERTY_END , 0 )
# define PAR(x,y,z,w) z
typedef enum prolog_flag_property_enum_choices
{
PROLOG_FLAG_PROPERTY_DEFS ( )
} prolog_flag_property_choices_t ;
# undef PAR
# define PAR(x,y,z, w) { x , y, z, w }
static const param2_t prolog_flag_property_defs [ ] =
{
PROLOG_FLAG_PROPERTY_DEFS ( )
} ;
# undef PAR
static Int
do_prolog_flag_property ( Term tflag , Term opts USES_REGS )
{ /* Init current_prolog_flag */
FlagEntry * fv ;
xarg * args ;
prolog_flag_property_choices_t i ;
bool rc = true ;
args = Yap_ArgList2ToVector ( opts , prolog_flag_property_defs , PROLOG_FLAG_PROPERTY_END ) ;
if ( args = = NULL ) {
return FALSE ;
}
if ( ! IsAtomTerm ( tflag ) ) {
if ( IsApplTerm ( tflag ) & & FunctorOfTerm ( tflag ) = = FunctorModule ) {
Term modt = CurrentModule ;
tflag = Yap_YapStripModule ( tflag , & modt ) ;
} else {
Yap_Error ( TYPE_ERROR_ATOM , tflag , " yap_flag/2 " ) ;
return ( FALSE ) ;
}
}
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
for ( i = 0 ; i < PROLOG_FLAG_PROPERTY_END ; i + + ) {
if ( args [ i ] . used ) {
switch ( i ) {
case PROLOG_FLAG_PROPERTY_ACCESS :
if ( fv - > rw )
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermReadWrite , args [ PROLOG_FLAG_PROPERTY_ACCESS ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
else
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermReadOnly , args [ PROLOG_FLAG_PROPERTY_ACCESS ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
break ;
case PROLOG_FLAG_PROPERTY_TYPE :
if ( fv - > type = = boolean )
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermBoolean , args [ PROLOG_FLAG_PROPERTY_TYPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
else if ( fv - > type = = isatom )
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermAtom , args [ PROLOG_FLAG_PROPERTY_TYPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
else if ( fv - > type = = nat )
rc = rc & &
2015-09-21 23:05:36 +01:00
2015-06-18 07:55:07 +01:00
Yap_unify ( TermInteger , args [ PROLOG_FLAG_PROPERTY_TYPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
else if ( fv - > type = = isfloat )
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermFloat , args [ PROLOG_FLAG_PROPERTY_TYPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
else
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermTerm , args [ PROLOG_FLAG_PROPERTY_TYPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
break ;
case PROLOG_FLAG_PROPERTY_KEEP :
rc = rc & & false ;
break ;
case PROLOG_FLAG_PROPERTY_SCOPE :
if ( fv - > global ) {
if ( fv - > FlagOfVE = = UNKNOWN_FLAG | |
fv - > FlagOfVE = = CHARACTER_ESCAPES_FLAG | |
fv - > FlagOfVE = = BACKQUOTED_STRING_FLAG )
2015-06-18 07:55:07 +01:00
Yap_unify ( TermModule , args [ PROLOG_FLAG_PROPERTY_SCOPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermGlobal , args [ PROLOG_FLAG_PROPERTY_SCOPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
} else
rc = rc & &
2015-06-18 07:55:07 +01:00
Yap_unify ( TermThread , args [ PROLOG_FLAG_PROPERTY_SCOPE ] . tvalue ) ;
2015-06-18 01:59:07 +01:00
break ;
case PROLOG_FLAG_PROPERTY_END :
/* break; */
2015-08-07 22:57:53 +01:00
Yap_Error ( DOMAIN_ERROR_PROLOG_FLAG , opts , " Flag not supported by YAP " ) ;
2015-06-18 01:59:07 +01:00
}
}
}
2015-06-18 07:55:07 +01:00
// UNLOCK(GLOBAL_Prolog_Flag[sno].prolog_flaglock);
2015-06-18 01:59:07 +01:00
return rc ;
}
static Int
cont_prolog_flag_property ( USES_REGS1 )
{ /* current_prolog_flag */
int i = IntOfTerm ( EXTRA_CBACK_ARG ( 2 , 1 ) ) ;
while ( i < GLOBAL_flagCount + LOCAL_flagCount ) {
int gmax = GLOBAL_flagCount ;
int lmax = LOCAL_flagCount ;
Term lab ;
if ( i > = gmax + lmax ) {
cut_fail ( ) ;
} else if ( i > = gmax ) {
lab = MkAtomTerm ( Yap_LookupAtom ( local_flags_setup [ i - gmax ] . name ) ) ;
} else {
if ( i = = UNKNOWN_FLAG | |
i = = CHARACTER_ESCAPES_FLAG | |
i = = BACKQUOTED_STRING_FLAG ) {
Term labs [ 2 ] ;
labs [ 0 ] = MkVarTerm ( ) ;
labs [ 1 ] = MkAtomTerm ( Yap_LookupAtom ( global_flags_setup [ i ] . name ) ) ;
lab = Yap_MkApplTerm ( FunctorModule , 2 , labs ) ;
} else {
lab = MkAtomTerm ( Yap_LookupAtom ( global_flags_setup [ i ] . name ) ) ;
}
}
EXTRA_CBACK_ARG ( 2 , 1 ) = MkIntTerm ( + + i ) ;
Yap_unify ( ARG1 , lab ) ;
return do_prolog_flag_property ( lab , Deref ( ARG2 ) PASS_REGS ) ;
}
cut_fail ( ) ;
}
/** @pred prolog_flag_property(+ _Flag_,+ _Prooperties_)
Report a property for a YAP Prolog flag . _Properties_ include
* ` type ( + _Type_ ) ` with _Type_ one of ` boolean ` , ` integer ` , ` float ` , ` atom `
and ` term ` ( that is , any ground term )
* ` access ( + _Access_ ) ` with _Access_ one of ` read_only ` or ` read_write `
* ` scope ( + _Scope_ ) the flag aplies to a ` thread ` , to a ` module ` , or is ` global ` to the system .
*/
static Int
prolog_flag_property ( USES_REGS1 )
{ /* Init current_prolog_flag */
Term t1 = Deref ( ARG1 ) ;
/* make valgrind happy by always filling in memory */
EXTRA_CBACK_ARG ( 2 , 1 ) = MkIntTerm ( 0 ) ;
if ( IsVarTerm ( t1 ) ) {
return ( cont_prolog_flag_property ( PASS_REGS1 ) ) ;
} else {
if ( IsApplTerm ( t1 ) & & FunctorOfTerm ( t1 ) = = FunctorModule ) {
Term modt ;
t1 = Yap_StripModule ( t1 , & modt ) ;
if ( IsAtomTerm ( modt ) ) {
Int rc ;
rc = cont_prolog_flag_property ( PASS_REGS1 ) ;
return rc ;
}
} else if ( IsAtomTerm ( t1 ) ) {
do_cut ( 0 ) ;
return do_prolog_flag_property ( t1 , Deref ( ARG2 ) PASS_REGS ) ;
} else {
Yap_Error ( TYPE_ERROR_ATOM , t1 , " prolog_flag_property/2 " ) ;
}
}
return false ;
}
static void
newFlag ( Term fl , Term val )
{
flag_info f ;
int i = GLOBAL_flagCount ;
GLOBAL_flagCount + + ;
2015-09-21 23:05:36 +01:00
f . name = ( char * ) RepAtom ( AtomOfTerm ( fl ) ) - > StrOfAE ;
2015-06-18 01:59:07 +01:00
f . writable = true ;
f . helper = 0 ;
f . def = ok ;
initFlag ( & f , i , true ) ;
if ( IsAtomOrIntTerm ( val ) ) {
GLOBAL_Flags [ i ] . at = val ;
} else {
GLOBAL_Flags [ i ] . DBT = Yap_StoreTermInDB ( val , 2 ) ;
}
}
static Int
do_create_prolog_flag ( USES_REGS1 )
{
FlagEntry * fv ;
xarg * args ;
prolog_flag_property_choices_t i ;
Term tflag = Deref ( ARG1 ) , tval = Deref ( ARG2 ) , opts = Deref ( ARG3 ) ;
args = Yap_ArgList2ToVector ( opts , prolog_flag_property_defs , PROLOG_FLAG_PROPERTY_END ) ;
if ( args = = NULL ) {
return FALSE ;
}
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
if ( fv ) {
if ( args [ PROLOG_FLAG_PROPERTY_KEEP ] . used & & args [ PROLOG_FLAG_PROPERTY_KEEP ] . tvalue = = TermTrue )
return true ;
} else {
newFlag ( tflag , tval ) ;
fv = GetFlagProp ( AtomOfTerm ( tflag ) ) ;
}
for ( i = 0 ; i < PROLOG_FLAG_PROPERTY_END ; i + + ) {
if ( args [ i ] . used ) {
switch ( i ) {
case PROLOG_FLAG_PROPERTY_KEEP :
break ;
case PROLOG_FLAG_PROPERTY_ACCESS :
if ( args [ PROLOG_FLAG_PROPERTY_ACCESS ] . tvalue = = TermReadWrite )
fv - > rw = true ;
else
fv - > rw = false ;
break ;
case PROLOG_FLAG_PROPERTY_TYPE :
{
Term ttype = args [ PROLOG_FLAG_PROPERTY_TYPE ] . tvalue ;
if ( ttype = = TermBoolean )
fv - > type = boolean ;
else if ( ttype = = TermInteger )
fv - > type = isatom ;
else if ( ttype = = TermFloat )
fv - > type = isfloat ;
else
fv - > type = isground ;
}
break ;
case PROLOG_FLAG_PROPERTY_SCOPE :
return
false ;
case PROLOG_FLAG_PROPERTY_END :
break ;
}
}
}
2015-06-18 07:55:07 +01:00
//UNLOCK(GLOBAL_Prolog_Flag[sno].prolog_flaglock);
2015-06-18 01:59:07 +01:00
return true ;
}
/**
* Init System Prolog flags . This is done in two phases :
* early on , it takes care of the atomic flags that are required by other modules ;
* later , it looks at flags that are structured terms
*
* @ param bootstrap : wether this is done before stack initialization , or afterwards .
* Complex terms can only be built in the second step .
*/
void
Yap_InitFlags ( bool bootstrap ) {
CACHE_REGS
2015-07-06 11:53:50 +01:00
tr_fr_ptr tr0 = TR ;
flag_info * f =
2015-06-18 01:59:07 +01:00
global_flags_setup ;
GLOBAL_flagCount = 0 ;
if ( bootstrap ) {
GLOBAL_Flags = ( union flagTerm * ) Yap_AllocCodeSpace ( sizeof ( union flagTerm ) * ( 2 * sizeof ( global_flags_setup ) / sizeof ( flag_info ) ) ) ;
}
while ( f - > name ! = NULL ) {
bool itf = setInitialValue ( bootstrap , f - > def , f - > init , GLOBAL_Flags + GLOBAL_flagCount ) ;
if ( itf ) {
initFlag ( f , GLOBAL_flagCount , true ) ;
}
GLOBAL_flagCount + + ;
f + + ;
}
LOCAL_flagCount = 0 ;
int nflags = sizeof ( local_flags_setup ) / sizeof ( flag_info ) ;
if ( bootstrap )
LOCAL_Flags = ( union flagTerm * ) Yap_AllocCodeSpace ( sizeof ( union flagTerm ) * nflags ) ;
f =
local_flags_setup ;
while ( f - > name ! = NULL ) {
bool itf = setInitialValue ( bootstrap , f - > def , f - > init , LOCAL_Flags + LOCAL_flagCount ) ;
// Term itf = Yap_StringToTerm(f->init, strlen(f->init)+1, LOCAL_encoding, 1200, &tp);
if ( itf ) {
initFlag ( f , LOCAL_flagCount , false ) ;
}
LOCAL_flagCount + + ;
f + + ;
}
if ( ! bootstrap ) {
Yap_InitCPredBack ( " current_prolog_flag " , 2 , 1 , current_prolog_flag , cont_yap_flag , 0 ) ;
2015-07-06 11:53:50 +01:00
TR = tr0 ;
2015-06-18 01:59:07 +01:00
/** @pred prolog_flag(? _Flag_,- _Value__)
Obtain the value for a YAP Prolog flag , same as current_prolog_flag / 2 _ .
*/
Yap_InitCPredBack ( " prolog_flag " , 3 , 1 , prolog_flag , cont_yap_flag , 0 ) ;
Yap_InitCPredBack ( " prolog_flag " , 2 , 1 , prolog_flag , cont_yap_flag , 0 ) ;
Yap_InitCPred ( " set_prolog_flag " , 2 , set_prolog_flag , SyncPredFlag ) ;
Yap_InitCPred ( " $create_prolog_flag " , 3 , do_create_prolog_flag , SyncPredFlag ) ;
Yap_InitCPredBack ( " yap_flag " , 2 , 1 , yap_flag , cont_yap_flag , 0 ) ;
Yap_InitCPredBack ( " prolog_flag_property " , 2 , 1 , prolog_flag_property , cont_prolog_flag_property , 0 ) ;
Yap_InitCPred ( " source " , 0 , source , SyncPredFlag ) ;
Yap_InitCPred ( " no_source " , 0 , no_source , SyncPredFlag ) ;
Yap_InitCPred ( " source_mode " , 2 , source_mode , SyncPredFlag ) ;
}
}
/* Accessing and changing the flags for a predicate */