ADDED: push_prolog_flag/2 and pop_prolog_flag/1

Thread-local, nestable save/restore of Prolog flag values.  Both go
through the existing set_prolog_flag/2 code path, so type checks,
read-only checks, thread-local COW, and side effects (character
escapes, module bits, boolean fast mask, ...) stay consistent.  The
push stack lives inside the prolog_flag struct as a linked list of
snapshot frames.  A FF_PUSH_ABSENT sentinel records that the flag did
not exist at push time; pop then removes the local entry.

Author: JanWielemaker

man/overview.plx

@@ -2804,6 +2804,43 @@ both for the calling thread and in the global flag table.  See the
         current_prolog_flag/2, print a warning.  This option is used
         for options set using the commandline option \verb$-D<flag>[=<value>]$.
     \end{description}
+
+    \predicate{push_prolog_flag}{2}{:Key, +Value}
+Save the current thread-local value of \arg{Key} and set it to
+\arg{Value}. If \arg{Key} does not exist, it is created (only in the
+calling thread) and the pushed state records its absence. Nestable and
+paired with pop_prolog_flag/1. These predicates have been designed
+with two main use cases in mind.  First of all scoped compilation
+with different flags.  For example, the code below keeps the clause
+as written.  Without locally modifying this flag the \exam{X = 42}
+is normally moved into the head.
+
+\begin{code}
+:- push_prolog_flag(optimise_unify, false).
+p(X) :-
+    X = 42,
+    format('The answer to the ultimate question~n').
+:- pop_prolog_flag(optimise_unify).
+\end{code}
+
+Second, runtime scoping. For example, execute a goal with \jargon{occurs
+checking}:\footnote{Be aware that the ``pop'' happens when \arg{Goal}
+has completed.  Notably it is not immediately executed if \arg{Goal}
+succeeds with a choice point.}
+
+\begin{code}
+call_with_occurs_check(Goal) :-
+    setup_call_cleanup(
+	push_prolog_flag(occurs_check, true),
+	Goal,
+	pop_prolog_flag(occurs_check)).
+\end{code}
+
+    \predicate{pop_prolog_flag}{1}{:Key}
+Restore the state saved by the matching push_prolog_flag/2. If \arg{Key}
+did not exist at the matching push, it is removed again. Raises
+\except{existence_error(pushed_flag, Key)} if no matching push exists
+on the current thread.
 \end{description}
 
 

man/summary.plx

@@ -519,6 +519,7 @@ suggest predicates from a keyword.
 \predicatesummary{phrase_from_quasi_quotation}{2}{Parse quasi quotation with DCG}
 \predicatesummary{please}{3}{Query/change environment parameters}
 \predicatesummary{plus}{3}{Logical integer addition}
+\predicatesummary{pop_prolog_flag}{1}{Restore a flag saved by push_prolog_flag/2}
 \predicatesummary{portray}{1}{\hook{user} Modify behaviour of print/1}
 \predicatesummary{predicate_property}{2}{Query predicate attributes}
 \predicatesummary{predsort}{3}{Sort, using a predicate to determine the order}
@@ -563,6 +564,7 @@ suggest predicates from a keyword.
 \predicatesummary{protocola}{1}{Append log of the user interaction to file}
 \predicatesummary{protocolling}{1}{On what file is user interaction logged}
 \predicatesummary{public}{1}{Declaration that a predicate may be called}
+\predicatesummary{push_prolog_flag}{2}{Save a flag and set a new value}
 \predicatesummary{put}{1}{Write a character}
 \predicatesummary{put}{2}{Write a character on a stream}
 \predicatesummary{put_assoc}{4}{Add Key-Value to association tree}

src/ATOMS

@@ -703,6 +703,7 @@ A protocol		"protocol"
 A prove			":-"
 A public		"public"
 A punct			"punct"
+A pushed_flag		"pushed_flag"
 A qlf			"qlf"
 A qlf_min_load		"qlf_min_load"
 A quasi_quotation	"quasi_quotation"

src/os/pl-prologflag.c

@@ -250,6 +250,7 @@ setPrologFlag(const char *name, unsigned int flags, ...)
     f->index = 0;
     f->flags = flags;
     f->oneof = NULL;
+    f->pushed = NULL;
     addNewHTableWP(GD->prolog_flag.table, an, f);
     first_def = true;
   }
@@ -326,22 +327,32 @@ clean_prolog_flag(prolog_flag *f)
   oneof *of;
 
   set_flag_type(f, FT_INTEGER);
-  switch(type)
-  { case FT_TERM:
-      PL_erase(f->value.t);
-      break;
-    case FT_ATOM:
-      PL_unregister_atom(f->value.a);
-      break;
-    default:
-      ;
+  if ( !(f->flags & FF_PUSH_ABSENT) )
+  { switch(type)
+    { case FT_TERM:
+	PL_erase(f->value.t);
+	break;
+      case FT_ATOM:
+	PL_unregister_atom(f->value.a);
+	break;
+      default:
+	;
+    }
   }
   memset(&f->value, 0, sizeof(f->value));
 
   if ( (of=f->oneof) && --of->references == 0 )
   { f->oneof = NULL;
     free_oneof(of);
   }
+
+  while ( f->pushed )
+  { prolog_flag *p = f->pushed;
+    f->pushed = p->pushed;
+    p->pushed = NULL;
+    clean_prolog_flag(p);
+    freeHeap(p, sizeof(*p));
+  }
 }
 
 #ifdef O_PLMT
@@ -350,6 +361,7 @@ copy_prolog_flag(const prolog_flag *f)
 { prolog_flag *copy = allocHeapOrHalt(sizeof(*copy));
 
   *copy = *f;
+  copy->pushed = NULL;
   if ( f->oneof )
     f->oneof->references++;
   switch((f->flags & FT_MASK))
@@ -1087,6 +1099,7 @@ new_prolog_flag(DECL_LD term_t value, unsigned int flags)
   prolog_flag *f = allocHeapOrHalt(sizeof(*f));
   f->index = 0;
   f->oneof = NULL;
+  f->pushed = NULL;
 
   switch( (flags & FT_MASK) )
   { case FT_FROM_VALUE:
@@ -1633,6 +1646,192 @@ PRED_IMPL("create_prolog_flag", 3, create_prolog_flag, PL_FA_ISO)
   return f != NULL;
 }
 
+
+		 /*******************************
+		 *	  PUSH / POP FLAGS	*
+		 *******************************/
+
+/** push_prolog_flag(+Flag, +Value) is det.
+
+Save the current thread-local value of Flag (or that it does not exist)
+and set it to Value.  Nestable.  See pop_prolog_flag/1.
+*/
+
+/** pop_prolog_flag(+Flag) is det.
+
+Restore the last state saved by push_prolog_flag/2.  If Flag was absent
+at the matching push, it is removed again.  Raises existence_error if
+no matching push exists on the current thread.
+*/
+
+#define put_saved_flag_value(val, saved) \
+	LDFUNC(put_saved_flag_value, val, saved)
+
+static bool
+put_saved_flag_value(DECL_LD term_t val, const prolog_flag *saved)
+{ switch(saved->flags & FT_MASK)
+  { case FT_BOOL:
+    case FT_ATOM:
+      return PL_put_atom(val, saved->value.a);
+    case FT_INTEGER:
+      return PL_put_int64(val, saved->value.i);
+    case FT_FLOAT:
+      return PL_put_float(val, saved->value.f);
+    case FT_TERM:
+      return PL_recorded(saved->value.t, val);
+  }
+  assert(0);
+  return false;
+}
+
+#define ensure_local_flag(k, f) \
+	LDFUNC(ensure_local_flag, k, f)
+
+/* Return a thread-local prolog_flag for `k`.  Unlike the copy-on-write
+   set_prolog_flag path, we force a local copy even when only one thread
+   exists: otherwise a second thread created *between* push and pop
+   would cause an internal set_prolog_flag to COW the flag into LD,
+   leaving the pushed chain stranded in the GD entry and making pop
+   fail to find it.
+*/
+static prolog_flag *
+ensure_local_flag(DECL_LD atom_t k, prolog_flag *f)
+{
+#ifdef O_PLMT
+  if ( !(f->flags & FF_ISLOCAL) )
+  { f = copy_prolog_flag(f);
+    register_local_flag(k, f);
+    PL_register_atom(k);
+  }
+#endif
+  return f;
+}
+
+static
+PRED_IMPL("push_prolog_flag", 2, push_prolog_flag, 0)
+{ PRED_LD
+  atom_t k;
+  Module m = MODULE_parse;
+  term_t key   = PL_new_term_ref();
+  term_t value = A2;
+
+  if ( !PL_strip_module(A1, &m, key) ||
+       !PL_get_atom_ex(key, &k) )
+    return false;
+
+  PL_LOCK(L_PLFLAG);
+  prolog_flag *f = NULL;
+#ifdef O_PLMT
+  if ( LD->prolog_flag.table )
+    f = lookupHTableWP(LD->prolog_flag.table, k);
+#endif
+  if ( !f )
+    f = lookupHTableWP(GD->prolog_flag.table, k);
+
+  bool rc;
+  if ( f )
+  { if ( !check_flag_write_access(f, k, 0) )
+    { PL_UNLOCK(L_PLFLAG);
+      return false;
+    }
+    f = ensure_local_flag(k, f);
+    prolog_flag *saved = copy_prolog_flag(f);
+    rc = set_flag_value(f, m, k, value);
+    if ( rc )
+    { saved->pushed = f->pushed;
+      f->pushed = saved;
+    } else
+    { clean_prolog_flag(saved);
+      freeHeap(saved, sizeof(*saved));
+    }
+  } else
+  { prolog_flag *nf = new_prolog_flag(value, FT_FROM_VALUE);
+    if ( nf )
+    { prolog_flag *absent = allocHeapOrHalt(sizeof(*absent));
+      memset(absent, 0, sizeof(*absent));
+      absent->flags = FT_INTEGER|FF_PUSH_ABSENT;
+      nf->pushed = absent;
+#ifdef O_PLMT
+      register_local_flag(k, nf);
+      PL_register_atom(k);
+#else
+      addNewHTableWP(GD->prolog_flag.table, k, nf);
+      PL_register_atom(k);
+#endif
+      rc = true;
+    } else
+    { rc = false;
+    }
+  }
+  PL_UNLOCK(L_PLFLAG);
+
+  return rc;
+}
+
+static
+PRED_IMPL("pop_prolog_flag", 1, pop_prolog_flag, 0)
+{ PRED_LD
+  atom_t k;
+  Module m = MODULE_parse;
+  term_t key = PL_new_term_ref();
+
+  if ( !PL_strip_module(A1, &m, key) ||
+       !PL_get_atom_ex(key, &k) )
+    return false;
+
+  PL_LOCK(L_PLFLAG);
+  prolog_flag *f = NULL;
+  bool in_local = false;
+#ifdef O_PLMT
+  if ( LD->prolog_flag.table )
+  { f = lookupHTableWP(LD->prolog_flag.table, k);
+    in_local = (f != NULL);
+  }
+#endif
+  if ( !f )
+    f = lookupHTableWP(GD->prolog_flag.table, k);
+
+  if ( !f || !f->pushed )
+  { PL_UNLOCK(L_PLFLAG);
+    term_t ex = PL_new_term_ref();
+    return ( PL_put_atom(ex, k) &&
+	     PL_error(NULL, 0, NULL, ERR_EXISTENCE,
+		      ATOM_pushed_flag, ex) );
+  }
+
+  prolog_flag *prev = f->pushed;
+  bool rc;
+
+  if ( prev->flags & FF_PUSH_ABSENT )
+  { f->pushed = NULL;
+#ifdef O_PLMT
+    if ( in_local )
+      deleteHTableWP(LD->prolog_flag.table, k);
+    else
+#endif
+      deleteHTableWP(GD->prolog_flag.table, k);
+    clean_prolog_flag(f);
+    freeHeap(f, sizeof(*f));
+    PL_unregister_atom(k);
+    freeHeap(prev, sizeof(*prev));
+    rc = true;
+  } else
+  { term_t restore = PL_new_term_ref();
+    rc = put_saved_flag_value(restore, prev);
+    if ( rc )
+    { f->pushed = prev->pushed;
+      prev->pushed = NULL;
+      rc = set_flag_value(f, m, k, restore);
+      clean_prolog_flag(prev);
+      freeHeap(prev, sizeof(*prev));
+    }
+  }
+  PL_UNLOCK(L_PLFLAG);
+
+  return rc;
+}
+
+
 bool
 PL_current_prolog_flag(atom_t name, int type, void *value)
 { prolog_flag *f;
@@ -2598,4 +2797,6 @@ BeginPredDefs(prologflag)
   PRED_DEF("create_prolog_flag",   3, create_prolog_flag,   0)
   PRED_DEF("current_prolog_flag",  2, current_prolog_flag,  PL_FA_ISO|NDET)
   PRED_DEF("$current_prolog_flag", 5, dcurrent_prolog_flag, NDET)
+  PRED_DEF("push_prolog_flag",     2, push_prolog_flag,     0)
+  PRED_DEF("pop_prolog_flag",      1, pop_prolog_flag,      0)
 EndPredDefs

src/os/pl-prologflag.h

@@ -41,7 +41,8 @@
 
 #define FF_ISLOCAL	 0x040000	/* Flag is local (internal) */
 #define FF_ISCREATE	 0x080000	/* Called from create_prolog_flag/3 */
-#define FF_MASK		 0x0ff000	/* All FF flags */
+#define FF_PUSH_ABSENT	 0x100000	/* Pushed frame: flag was absent */
+#define FF_MASK		 0x1ff000	/* All FF flags */
 static_assert(FF_ISLOCAL == FF_GLOBAL<<1,
 	      "Private flags must follow public flags");
 
@@ -61,6 +62,7 @@ typedef struct _prolog_flag
     record_t	t;			/* value as term */
   } value;
   oneof        *oneof;
+  struct _prolog_flag *pushed;		/* push_prolog_flag/2 stack */
 } prolog_flag;
 
 		 /*******************************