gpgscm: Implement tags.

* tests/gpgscm/opdefines.h: Add opcodes to create and retrieve tags.
* tests/gpgscm/scheme.c (T_TAGGED): New macro.
(mk_tagged_value): New function.
(has_tag): Likewise.
(get_tag): Likewise.
(mark): Mark tag.
(opexe_4): Implement new opcodes.
* tests/gpgscm/scheme.h (USE_TAGS): New macro.
--

Tags are similar to property lists, but property lists can only be
attached to symbols.  Tags can not be attached to an existing object,
but a tagged copy can be created.  Once done, the tag can be
manipulated in constant time.

Using this during parsing will enable us to produce meaningful error
messages.

Signed-off-by: Justus Winter <justus@g10code.com>

3 files changed, 91 insertions, 0 deletions

diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h
index c7347fdc6..a2328fa88 100644
--- a/tests/gpgscm/opdefines.h
+++ b/tests/gpgscm/opdefines.h
@@ -149,6 +149,11 @@
     _OP_DEF(opexe_4, "set-symbol-property!",           3,  3,       TST_SYMBOL TST_SYMBOL TST_ANY,   OP_SET_SYMBOL_PROPERTY )
     _OP_DEF(opexe_4, "symbol-property",                2,  2,       TST_SYMBOL TST_SYMBOL,           OP_SYMBOL_PROPERTY  )
 #endif
+#if USE_TAGS
+    _OP_DEF(opexe_4, NULL,                             0,  0,       TST_NONE,                        OP_TAG_VALUE        )
+    _OP_DEF(opexe_4, "make-tagged-value",              2,  2,       TST_ANY TST_PAIR,                 OP_MK_TAGGED        )
+    _OP_DEF(opexe_4, "get-tag",                        1,  1,       TST_ANY,                         OP_GET_TAG          )
+#endif
     _OP_DEF(opexe_4, "quit",                           0,  1,       TST_NUMBER,                      OP_QUIT             )
     _OP_DEF(opexe_4, "gc",                             0,  0,       0,                               OP_GC               )
     _OP_DEF(opexe_4, "gc-verbose",                     0,  1,       TST_NONE,                        OP_GCVERB           )
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 30b59157b..c73a832f0 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -166,6 +166,7 @@ type_to_string (enum scheme_types typ)
 #define ADJ 32
 #define TYPE_BITS 5
 #define T_MASKTYPE      31    /* 0000000000011111 */
+#define T_TAGGED      1024    /* 0000010000000000 */
 #define T_FINALIZE    2048    /* 0000100000000000 */
 #define T_SYNTAX      4096    /* 0001000000000000 */
 #define T_IMMUTABLE   8192    /* 0010000000000000 */
@@ -599,6 +600,59 @@ static long binary_decode(const char *s) {
  return x;
 }
 
+
+
+/* Tags are like property lists, but can be attached to arbitrary
+ * values.  */
+
+#if USE_TAGS
+
+static pointer
+mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr)
+{
+  pointer r, t;
+
+  assert(! is_vector(v));
+
+  r = get_consecutive_cells(sc, 2);
+  if (r == sc->sink)
+    return sc->sink;
+
+  memcpy(r, v, sizeof *v);
+  typeflag(r) |= T_TAGGED;
+
+  t = r + 1;
+  typeflag(t) = T_PAIR;
+  car(t) = tag_car;
+  cdr(t) = tag_cdr;
+
+  return r;
+}
+
+static INLINE int
+has_tag(pointer v)
+{
+  return !! (typeflag(v) & T_TAGGED);
+}
+
+static INLINE pointer
+get_tag(scheme *sc, pointer v)
+{
+  if (has_tag(v))
+    return v + 1;
+  return sc->NIL;
+}
+
+#else
+
+#define mk_tagged_value(SC, X, A, B)	(X)
+#define has_tag(V)			0
+#define get_tag(SC, V)			(SC)->NIL
+
+#endif
+
+
+
 /* Allocate a new cell segment but do not make it available yet.  */
 static int
 _alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells)
@@ -1481,6 +1535,9 @@ E2:  setmark(p);
                mark(p+1+i);
           }
      }
+     /* Mark tag if p has one.  */
+     if (has_tag(p))
+       mark(p + 1);
      if (is_atom(p))
           goto E6;
      /* E4: down car */
@@ -4183,6 +4240,29 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
      CASE(OP_SYMBOL_PROPERTY):  /* symbol-property */
 	  s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
 #endif /* USE_PLIST */
+
+#if USE_TAGS
+     CASE(OP_TAG_VALUE): {      /* not exposed */
+	  /* This tags sc->value with car(sc->args).  Useful to tag
+	   * results of opcode evaluations.  */
+	  pointer a, b, c;
+	  free_cons(sc, sc->args, &a, &b);
+	  free_cons(sc, b, &b, &c);
+	  assert(c == sc->NIL);
+          s_return(sc, mk_tagged_value(sc, sc->value, a, b));
+	}
+
+     CASE(OP_MK_TAGGED):        /* make-tagged-value */
+	  if (is_vector(car(sc->args)))
+	       Error_0(sc, "cannot tag vector");
+          s_return(sc, mk_tagged_value(sc, car(sc->args),
+				       car(cadr(sc->args)),
+				       cdr(cadr(sc->args))));
+
+     CASE(OP_GET_TAG):        /* get-tag */
+	  s_return(sc, get_tag(sc, car(sc->args)));
+#endif /* USE_TAGS */
+
      CASE(OP_QUIT):       /* quit */
           if(is_pair(sc->args)) {
                sc->retcode=ivalue(car(sc->args));
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index 2b5b0665c..5e7d90d90 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -44,6 +44,7 @@ extern "C" {
 # define USE_DL 0
 # define USE_PLIST 0
 # define USE_SMALL_INTEGERS 0
+# define USE_TAGS 0
 #endif
 
 
@@ -76,6 +77,11 @@ extern "C" {
 # define USE_PLIST 0
 #endif
 
+/* If set, then every object can be tagged.  */
+#ifndef USE_TAGS
+# define USE_TAGS 1
+#endif
+
 /* To force system errors through user-defined error handling (see *error-hook*) */
 #ifndef USE_ERROR_HOOK
 # define USE_ERROR_HOOK 1