Reformatted.

[chise/xemacs-chise.git.1] / src / concord.c

diff --git a/src/concord.c b/src/concord.c
index f8b37c8..6d8c212 100644 (file)
--- a/src/concord.c
+++ b/src/concord.c
@@ -1,5 +1,5 @@
 /* XEmacs routines to deal with CONCORD.
-   Copyright (C) 2005,2006 MORIOKA Tomohiko
+   Copyright (C) 2005,2006,2008 MORIOKA Tomohiko
 
 This file is part of XEmacs.
 
@@ -648,10 +648,9 @@ Return the value of OBJECT's FEATURE.
   return Qnil;
 }
 
-DEFUN ("concord-object-put", Fconcord_object_put, 3, 3, 0, /*
-Store a VALUE of OBJECT's FEATURE.
-*/
-       (object, feature, value))
+static Lisp_Object
+concord_object_put (Lisp_Object object, Lisp_Object feature,
+                   Lisp_Object value)
 {
   struct gcpro gcpro1, gcpro2, gcpro3;
   int previous_print_readably;
@@ -664,7 +663,6 @@ Store a VALUE of OBJECT's FEATURE.
   Lisp_Object value_string;
   char* c_value;
 
-  CHECK_CONCORD_OBJECT (object);
   if ( !STRINGP(feature) )
     feature = Fsymbol_name (feature);
   previous_print_readably = print_readably;
@@ -700,7 +698,7 @@ Store a VALUE of OBJECT's FEATURE.
   status = chise_feature_sync (c_feature);
   if (status)
     return Qnil;
-  if (feature_name[0] == '=')
+  if (XSTRING_DATA(feature)[0] == '=')
     {
       CONCORD_INDEX c_index
        = concord_genre_get_index (c_genre, feature_name);
@@ -711,6 +709,86 @@ Store a VALUE of OBJECT's FEATURE.
   return Qt;
 }
 
+DEFUN ("concord-object-put", Fconcord_object_put, 3, 3, 0, /*
+Store a VALUE of OBJECT's FEATURE.
+*/
+       (object, feature, value))
+{
+  Lisp_String* name;
+  Bufbyte *name_str;
+
+  CHECK_CONCORD_OBJECT (object);
+  CHECK_SYMBOL (feature);
+  name = symbol_name (XSYMBOL (feature));
+  name_str = string_data (name);
+  if ( NILP (concord_object_put (object, feature, value)) )
+    return Qnil;
+  if ( EQ (feature, Q_subsumptive)             ||
+       EQ (feature, Q_subsumptive_from)                ||
+       EQ (feature, Q_denotational)            ||
+       EQ (feature, Q_denotational_from)       ||
+       ( ( ((name_str[0] == '-') && (name_str[1] == '>')) ||
+          ((name_str[0] == '<') && (name_str[1] == '-')) )
+        && (memchr (name_str, '*', name->size) == NULL) ) )
+    {
+      Lisp_Object rest = value;
+      Lisp_Object ret;
+      Lisp_Object rev_feature = Qnil;
+      struct gcpro gcpro1;
+
+      GCPRO1 (rev_feature);
+      if (EQ (feature, Q_subsumptive))
+       rev_feature = Q_subsumptive_from;
+      else if (EQ (feature, Q_subsumptive_from))
+       rev_feature = Q_subsumptive;
+      else if (EQ (feature, Q_denotational))
+       rev_feature = Q_denotational_from;
+      else if (EQ (feature, Q_denotational_from))
+       rev_feature = Q_denotational;
+      else
+       {
+         Bytecount length = string_length (name);
+         Bufbyte *rev_name_str = alloca (length + 1);
+
+         memcpy (rev_name_str + 2, name_str + 2, length - 2);
+         if (name_str[0] == '<')
+           {
+             rev_name_str[0] = '-';
+             rev_name_str[1] = '>';
+           }
+         else
+           {
+             rev_name_str[0] = '<';
+             rev_name_str[1] = '-';
+           }
+         rev_name_str[length] = 0;
+         rev_feature = intern (rev_name_str);
+       }
+
+      while (CONSP (rest))
+       {
+         ret = XCAR (rest);
+
+         if ( CONCORD_OBJECT_P (ret) && !EQ (ret, object) )
+           {
+             Lisp_Object ffv;
+
+             ffv = Fconcord_object_get (ret, rev_feature);
+             if (!CONSP (ffv))
+               concord_object_put (ret, rev_feature, list1 (object));
+             else if (NILP (Fmemq (object, ffv)))
+               concord_object_put
+                 (ret, rev_feature,
+                  nconc2 (Fcopy_sequence (ffv), list1 (object)));
+             Fsetcar (rest, ret);
+           }
+         rest = XCDR (rest);
+       }
+      UNGCPRO;
+    }
+  return Qt;
+}
+
 struct closure_for_object_spec
 {
   char* object_id;
@@ -817,7 +895,7 @@ func_for_each_object (CONCORD_String object_id,
                      CONCORD_Feature feature,
                      CONCORD_String value)
 {
-  struct gcpro gcpro1, gcpro2, gcpro3;
+  struct gcpro gcpro1, gcpro2;
   Lisp_Object obj, val, ret;
 
 #if 0
@@ -834,7 +912,6 @@ func_for_each_object (CONCORD_String object_id,
   obj = Fconcord_make_object (for_each_object_closure->genre,
                              obj,
                              for_each_object_closure->ds);
-  UNGCPRO;
 #if 0
   val = read_from_c_string (CONCORD_String_data (value),
                            CONCORD_String_size (value) );
@@ -845,7 +922,8 @@ func_for_each_object (CONCORD_String object_id,
                                  Qfile_name),
                                 Qnil, Qnil));
 #endif
-  GCPRO3 (obj, val, ret);
+  UNGCPRO;
+  GCPRO2 (obj, val);
   ret = call2 (for_each_object_closure->function, obj, val);
   UNGCPRO;
   for_each_object_closure->ret = ret;
@@ -923,6 +1001,23 @@ concord_name_validate (Lisp_Object keyword, Lisp_Object value,
 }
 
 static int
+concord_id_validate (Lisp_Object keyword, Lisp_Object value,
+                    Error_behavior errb)
+{
+  if (ERRB_EQ (errb, ERROR_ME))
+    {
+      /* CHECK_SYMBOL (value); */
+      if ( INTP (value) || CHARP (value) || SYMBOLP (value) )
+       ;
+      else
+       dead_wrong_type_argument (Qsymbolp, value);
+      return 1;
+    }
+
+  return INTP (value) || CHARP (value) || SYMBOLP (value);
+}
+
+static int
 concord_object_validate (Lisp_Object data, Error_behavior errb)
 {
   struct gcpro gcpro1, gcpro2, gcpro3;
@@ -1030,7 +1125,7 @@ structure_type_create_concord (void)
                              concord_object_instantiate);
 
   define_structure_type_keyword (st, Qgenre, concord_name_validate);
-  define_structure_type_keyword (st, Q_id, concord_name_validate);
+  define_structure_type_keyword (st, Q_id, concord_id_validate);
 }
 
 void