git.chise.org Git - chise/xemacs-chise.git.1/blob - src/concord.c

   1 /* XEmacs routines to deal with CONCORD.
   2    Copyright (C) 2005,2006,2008,2010 MORIOKA Tomohiko
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: Not in FSF. */
  22
  23 /* Written by MORIOKA Tomohiko */
  24
  25 #include <config.h>
  26 #include "lisp.h"
  27 #include "sysfile.h"
  28 #include "buffer.h"
  29 #include <errno.h>
  30 #include "elconcord.h"
  31 #ifdef HAVE_LIBCHISE
  32 #  include <chise.h>
  33 #endif
  34
  35
  36 EXFUN (Fread_from_string, 3);
  37
  38
  39 Lisp_Object Qconcord;
  40 Lisp_Object Qconcord_object;
  41 Lisp_Object Qgenre, Q_id;
  42 #ifdef HAVE_LIBCHISE
  43 Lisp_Object Qcharacter;
  44 Lisp_Object Qfeature;
  45 #endif
  46
  47 Lisp_Object Vconcord_ds_hash_table;
  48 Lisp_Object Vconcord_genre_hash_table;
  49 Lisp_Object Vconcord_genre_object_hash_table;
  50
  51
  52 /*
  53  * data source
  54  */
  55
  56 Lisp_Object Qconcord_dsp;
  57
  58 static Lisp_CONCORD_DS*
  59 allocate_concord_ds (void)
  60 {
  61   Lisp_CONCORD_DS* lds
  62     = alloc_lcrecord_type (Lisp_CONCORD_DS, &lrecord_concord_ds);
  63
  64   lds->ds = NULL;
  65   return lds;
  66 }
  67
  68 static Lisp_Object
  69 mark_concord_ds (Lisp_Object object)
  70 {
  71   return Qnil;
  72 }
  73
  74 static void
  75 print_concord_ds (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  76 {
  77   Lisp_CONCORD_DS* lds = XCONCORD_DS (obj);
  78
  79   if (print_readably)
  80     error ("printing unreadable object #<concord_ds 0x%x>", lds->header.uid);
  81
  82   write_c_string ("#<concord_ds \"", printcharfun);
  83   write_c_string (concord_ds_location (lds->ds), printcharfun);
  84   write_c_string ("\">", printcharfun);
  85 }
  86
  87 static void
  88 finalize_concord_ds (void *header, int for_disksave)
  89 {
  90   Lisp_CONCORD_DS *lds = (Lisp_CONCORD_DS *) header;
  91
  92   if (for_disksave)
  93     {
  94       Lisp_Object object;
  95       XSET_CONCORD_DS (object, lds);
  96
  97       signal_simple_error
  98         ("Can't dump an emacs containing concord_ds objects", object);
  99     }
 100   if ( lds->ds != NULL)
 101     concord_close_ds (lds->ds);
 102 }
 103
 104 DEFINE_LRECORD_IMPLEMENTATION ("concord_ds", concord_ds,
 105                                mark_concord_ds, print_concord_ds,
 106                                finalize_concord_ds, 0, 0, 0,
 107                                Lisp_CONCORD_DS);
 108
 109 DEFUN ("concord-close-ds", Fconcord_close_ds, 1, 1, 0, /*
 110 Close concord-ds CONCORD-DS.
 111 */
 112        (concord_ds))
 113 {
 114   Lisp_CONCORD_DS* lds;
 115   lds = XCONCORD_DS (concord_ds);
 116   if ( lds->ds != NULL)
 117     concord_close_ds (lds->ds);
 118   lds->ds = NULL;
 119   return Qnil;
 120 }
 121
 122 DEFUN ("concord-ds-p", Fconcord_ds_p, 1, 1, 0, /*
 123 Return t if OBJECT is a concord-ds.
 124 */
 125        (object))
 126 {
 127   return CONCORD_DS_P (object) ? Qt : Qnil;
 128 }
 129
 130 DEFUN ("concord-open-ds", Fconcord_open_ds, 1, 4, 0, /*
 131 Return a new concord-ds object opened on DIRECTORY.
 132 Optional arguments TYPE and SUBTYPE specify the concord_ds type.
 133 Optional argument MODE gives the permissions to use when opening DIRECTORY,
 134 and defaults to 0755.
 135 */
 136        (directory, type, subtype, mode))
 137 {
 138   Lisp_Object retval;
 139   Lisp_CONCORD_DS* lds = NULL;
 140   CONCORD_DS ds;
 141   int modemask;
 142   char *pathname;
 143   struct gcpro gcpro1;
 144
 145   CHECK_STRING (directory);
 146   GCPRO1 (directory);
 147   directory = Ffile_name_as_directory (Fexpand_file_name (directory, Qnil));
 148   UNGCPRO;
 149
 150   retval = Fgethash (directory, Vconcord_ds_hash_table, Qunbound);
 151   if (!UNBOUNDP (retval))
 152     {
 153       return retval;
 154     }
 155
 156   TO_EXTERNAL_FORMAT (LISP_STRING, directory,
 157                       C_STRING_ALLOCA, pathname,
 158                       Qfile_name);
 159
 160   if (NILP (mode))
 161     {
 162       modemask = 0755;          /* rwxr-xr-x */
 163     }
 164   else
 165     {
 166       CHECK_INT (mode);
 167       modemask = XINT (mode);
 168     }
 169
 170   ds = concord_open_ds (CONCORD_Backend_Berkeley_DB,
 171                         pathname, 0, modemask);
 172   if ( ds == NULL )
 173     return Qnil;
 174
 175   lds = allocate_concord_ds ();
 176   lds->ds = ds;
 177   XSET_CONCORD_DS (retval, lds);
 178   Fputhash (directory, retval, Vconcord_ds_hash_table);
 179   return retval;
 180 }
 181
 182 DEFUN ("concord-ds-directory", Fconcord_ds_directory, 1, 1, 0, /*
 183 Return directory of concord-ds DS.
 184 */
 185        (ds))
 186 {
 187   Lisp_CONCORD_DS* lds;
 188   char* directory;
 189
 190   CHECK_CONCORD_DS (ds);
 191   lds = XCONCORD_DS (ds);
 192   if (lds->ds == NULL)
 193     return Qnil;
 194
 195   directory = concord_ds_location (lds->ds);
 196   if (directory == NULL)
 197     return Qnil;
 198
 199   return build_ext_string (directory, Qfile_name);
 200 }
 201
 202
 203 DEFUN ("concord-assign-genre", Fconcord_assign_genre, 2, 2, 0, /*
 204 Assign data-source DIRECTORY to GENRE.
 205 */
 206        (genre, directory))
 207 {
 208   struct gcpro gcpro1;
 209
 210   CHECK_SYMBOL (genre);
 211   if ( CONCORD_DS_P (directory) )
 212     {
 213     }
 214   else
 215     {
 216       CHECK_STRING (directory);
 217       GCPRO1 (directory);
 218       directory
 219         = Ffile_name_as_directory (Fexpand_file_name (directory, Qnil));
 220       UNGCPRO;
 221     }
 222   Fputhash (genre, directory, Vconcord_genre_hash_table);
 223   return directory;
 224 }
 225
 226 DEFUN ("concord-genre-directory", Fconcord_genre_directory, 1, 1, 0, /*
 227 Return pathname of GENRE.
 228 */
 229        (genre))
 230 {
 231   Lisp_Object retval;
 232   CHECK_SYMBOL (genre);
 233
 234   retval = Fgethash (genre, Vconcord_genre_hash_table, Qunbound);
 235   if ( STRINGP (retval) )
 236     return retval;
 237   else if ( CONCORD_DS_P (retval) )
 238     return Fconcord_ds_directory (retval);
 239   return Qnil;
 240 }
 241
 242 DEFUN ("concord-genre-ds", Fconcord_genre_ds, 1, 1, 0, /*
 243 Return concord-ds of GENRE.
 244 */
 245        (genre))
 246 {
 247   Lisp_Object retval;
 248
 249   CHECK_SYMBOL (genre);
 250
 251   retval = Fgethash (genre, Vconcord_genre_hash_table, Qunbound);
 252   if ( UNBOUNDP (retval) )
 253     retval = Vchise_system_db_directory;
 254   if ( STRINGP (retval) )
 255     {
 256       retval = Fconcord_open_ds (retval, Qnil, Qnil, Qnil);
 257       if ( !NILP (retval) )
 258         Fputhash (genre, retval, Vconcord_genre_hash_table);
 259       return retval;
 260     }
 261   else if ( CONCORD_DS_P (retval) )
 262     return retval;
 263   return Qnil;
 264 }
 265
 266
 267 struct closure_to_list_feature
 268 {
 269   Lisp_Object feature_list;
 270 } *concord_feature_list_closure;
 271
 272 static int
 273 add_feature_to_list_mapper (CONCORD_Genre genre, char* name)
 274 {
 275   /* This function can GC */
 276   concord_feature_list_closure->feature_list
 277     = Fcons (intern (name), concord_feature_list_closure->feature_list);
 278   return 0;
 279 }
 280
 281 DEFUN ("concord-feature-list", Fconcord_feature_list, 1, 2, 0, /*
 282 Return the list of all existing features in GENRE.
 283 */
 284        (genre, ds))
 285 {
 286   Lisp_CONCORD_DS* lds;
 287   char* genre_name;
 288   CONCORD_Genre c_genre;
 289   struct gcpro gcpro1;
 290
 291   CHECK_SYMBOL (genre);
 292   if (NILP (ds))
 293     ds = Fconcord_genre_ds (genre);
 294   CHECK_CONCORD_DS (ds);
 295   lds = XCONCORD_DS (ds);
 296   if (lds->ds == NULL)
 297     return Qnil;
 298   genre = Fsymbol_name (genre);
 299   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 300                       C_STRING_ALLOCA, genre_name,
 301                       Qfile_name);
 302   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 303   if (c_genre == NULL)
 304     return Qnil;
 305   concord_feature_list_closure
 306     = alloca (sizeof (struct closure_to_list_feature));
 307   concord_feature_list_closure->feature_list = Qnil;
 308   GCPRO1 (concord_feature_list_closure->feature_list);
 309   concord_genre_foreach_feature_name (c_genre,
 310                                       add_feature_to_list_mapper);
 311   UNGCPRO;
 312   return concord_feature_list_closure->feature_list;
 313 }
 314
 315
 316 /*
 317  * Concord-object
 318  */
 319
 320 Lisp_Object Qconcord_objectp;
 321
 322 static Lisp_CONCORD_Object*
 323 allocate_concord_object (void)
 324 {
 325   Lisp_CONCORD_Object* lcobj
 326     = alloc_lcrecord_type (Lisp_CONCORD_Object, &lrecord_concord_object);
 327
 328   lcobj->genre = NULL;
 329   lcobj->id = Qunbound;
 330   return lcobj;
 331 }
 332
 333 static Lisp_Object
 334 mark_concord_object (Lisp_Object object)
 335 {
 336   mark_object (XCONCORD_OBJECT_ID(object));
 337   return Qnil;
 338 }
 339
 340 static void
 341 print_concord_object (Lisp_Object obj,
 342                       Lisp_Object printcharfun, int escapeflag)
 343 {
 344   Lisp_CONCORD_Object* lcobj = XCONCORD_OBJECT (obj);
 345   struct gcpro gcpro1, gcpro2;
 346
 347 #if 0
 348   if ( print_readably )
 349     {
 350 #endif
 351       write_c_string ("#s(concord-object", printcharfun);
 352       write_c_string (" genre ", printcharfun);
 353       write_c_string (concord_genre_get_name (lcobj->genre), printcharfun);
 354       write_c_string (" =id ", printcharfun);
 355       GCPRO2 (obj, printcharfun);
 356       print_internal (lcobj->id, printcharfun, escapeflag);
 357       UNGCPRO;
 358       write_c_string (")", printcharfun);
 359 #if 0
 360     }
 361   else
 362     {
 363       write_c_string ("#<concord-object \"", printcharfun);
 364       write_c_string (concord_genre_get_name (lcobj->genre), printcharfun);
 365       write_c_string (";", printcharfun);
 366       GCPRO2 (obj, printcharfun);
 367       print_internal (lcobj->id, printcharfun, escapeflag);
 368       UNGCPRO;
 369       write_c_string ("\">", printcharfun);
 370     }
 371 #endif
 372 }
 373
 374 static void
 375 finalize_concord_object (void *header, int for_disksave)
 376 {
 377   Lisp_CONCORD_Object* lcobj = (Lisp_CONCORD_Object *) header;
 378
 379   if (for_disksave)
 380     {
 381       Lisp_Object object;
 382       XSET_CONCORD_OBJECT (object, lcobj);
 383
 384       signal_simple_error
 385         ("Can't dump an emacs containing concord_object objects", object);
 386     }
 387 }
 388
 389 static int
 390 concord_object_equal (Lisp_Object cobj1, Lisp_Object cobj2, int depth)
 391 {
 392   return internal_equal ( XCONCORD_OBJECT_ID(cobj1),
 393                           XCONCORD_OBJECT_ID(cobj2), depth);
 394 }
 395
 396 static const struct lrecord_description concord_object_description[] = {
 397   { XD_LISP_OBJECT, offsetof (Lisp_CONCORD_Object, id) },
 398   { XD_END }
 399 };
 400
 401 DEFINE_LRECORD_IMPLEMENTATION ("concord_object", concord_object,
 402                                mark_concord_object, print_concord_object,
 403                                finalize_concord_object,
 404                                concord_object_equal, 0,
 405                                concord_object_description,
 406                                Lisp_CONCORD_Object);
 407
 408 static Lisp_Object
 409 concord_genre_cache_get_object (Lisp_Object genre, Lisp_Object id)
 410 {
 411   Lisp_Object obj_hash;
 412
 413   obj_hash = Fgethash (genre, Vconcord_genre_object_hash_table, Qunbound);
 414   if (UNBOUNDP (obj_hash))
 415     return Qunbound;
 416   return Fgethash (id, obj_hash, Qunbound);
 417 }
 418
 419 static Lisp_Object
 420 concord_genre_cache_put_object (Lisp_Object genre, Lisp_Object id,
 421                                 Lisp_Object object)
 422 {
 423   Lisp_Object obj_hash;
 424
 425   obj_hash = Fgethash (genre, Vconcord_genre_object_hash_table, Qunbound);
 426   if (UNBOUNDP (obj_hash))
 427     {
 428       obj_hash
 429         = make_lisp_hash_table (256, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
 430       Fputhash (genre, obj_hash, Vconcord_genre_object_hash_table);
 431     }
 432   return Fputhash (id, object, obj_hash);
 433 }
 434
 435 DEFUN ("concord-make-object", Fconcord_make_object, 1, 3, 0, /*
 436 Make and return a Concord-object from ID and GENRE.
 437 Optional argument DS specifies the data-source of the GENRE.
 438 */
 439        (genre, id, ds))
 440 {
 441   Lisp_CONCORD_DS* lds;
 442   Lisp_Object genre_string;
 443   char* genre_name_str;
 444   CONCORD_Genre c_genre;
 445   Lisp_CONCORD_Object* lcobj;
 446   Lisp_Object retval;
 447
 448   if (!NILP (id))
 449     {
 450       retval = concord_genre_cache_get_object (genre, id);
 451       if (!UNBOUNDP (retval))
 452         {
 453           return retval;
 454         }
 455     }
 456   if (NILP (ds))
 457     ds = Fconcord_genre_ds (genre);
 458   CHECK_CONCORD_DS (ds);
 459   lds = XCONCORD_DS (ds);
 460   if (lds->ds == NULL)
 461     return Qnil;
 462   if ( STRINGP(genre) )
 463     genre_string = genre;
 464   else
 465     genre_string = Fsymbol_name (genre);
 466   TO_EXTERNAL_FORMAT (LISP_STRING, genre_string,
 467                       C_STRING_ALLOCA, genre_name_str,
 468                       Qfile_name);
 469   c_genre = concord_ds_get_genre (lds->ds, genre_name_str);
 470   if (c_genre == NULL)
 471     return Qnil;
 472   lcobj = allocate_concord_object ();
 473   lcobj->genre = c_genre;
 474   lcobj->id = id;
 475   XSET_CONCORD_OBJECT (retval, lcobj);
 476   if (!NILP (id))
 477     {
 478       struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 479
 480       GCPRO4 (retval, id, genre, ds);
 481       concord_genre_cache_put_object (genre, id, retval);
 482 #if 1
 483       if (!EQ (Fconcord_object_get (retval, Q_id), id))
 484         Fconcord_object_put (retval, Q_id, id);
 485 #endif
 486       UNGCPRO;
 487     }
 488   return retval;
 489 }
 490
 491 DEFUN ("concord-object-p", Fconcord_object_p, 1, 1, 0, /*
 492 Return t if OBJECT is a concord-object.
 493 */
 494        (object))
 495 {
 496   return CONCORD_OBJECT_P (object) ? Qt : Qnil;
 497 }
 498
 499 DEFUN ("concord-object-id", Fconcord_object_id, 1, 1, 0, /*
 500 Return an id of Concord-object OBJECT.
 501 */
 502        (object))
 503 {
 504   CHECK_CONCORD_OBJECT (object);
 505   return XCONCORD_OBJECT_ID (object);
 506 }
 507
 508 DEFUN ("concord-object-genre", Fconcord_object_genre, 1, 1, 0, /*
 509 Return genre of Concord-object OBJECT.
 510 */
 511        (object))
 512 {
 513   CHECK_CONCORD_OBJECT (object);
 514   return intern (concord_genre_get_name (XCONCORD_OBJECT_GENRE (object)));
 515 }
 516
 517 DEFUN ("concord-decode-object", Fconcord_decode_object, 2, 4, 0, /*
 518 Make and return a Concord-object from FEATURE and VALUE.
 519 Optional argument GENRE specifies the GENRE of the object.
 520 Optional argument DS specifies the data-source of the GENRE.
 521 */
 522        (feature, value, genre, ds))
 523 {
 524   Lisp_CONCORD_DS* lds;
 525   char* genre_name;
 526   CONCORD_Genre c_genre;
 527   char* feature_name;
 528   CONCORD_INDEX c_index;
 529   Lisp_Object value_string;
 530   char* strid;
 531   CONCORD_String_Tank st_id;
 532   int status;
 533   Lisp_Object obj;
 534   int previous_print_readably;
 535   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 536
 537   if (NILP (ds))
 538     ds = Fconcord_genre_ds (genre);
 539   CHECK_CONCORD_DS (ds);
 540   lds = XCONCORD_DS (ds);
 541   if (lds->ds == NULL)
 542     return Qnil;
 543   if ( !STRINGP(feature) )
 544     feature = Fsymbol_name (feature);
 545   if ( !STRINGP(genre) )
 546     genre = Fsymbol_name (genre);
 547   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 548                       C_STRING_ALLOCA, genre_name,
 549                       Qfile_name);
 550   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 551   if (c_genre == NULL)
 552     {
 553       return Qnil;
 554     }
 555
 556   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 557                       C_STRING_ALLOCA, feature_name,
 558                       Qfile_name);
 559   c_index = concord_genre_get_index (c_genre, feature_name);
 560   if (c_index == NULL)
 561     {
 562       return Qnil;
 563     }
 564
 565   previous_print_readably = print_readably;
 566   print_readably = 1;
 567   GCPRO5 (feature, value, genre, ds, value_string);
 568   value_string = Fprin1_to_string (value, Qnil);
 569   UNGCPRO;
 570   print_readably = previous_print_readably;
 571   TO_EXTERNAL_FORMAT (LISP_STRING,
 572                       value_string, C_STRING_ALLOCA, strid,
 573                       Qfile_name);
 574   status = concord_index_strid_get_obj_string (c_index, strid, &st_id);
 575   if (!status)
 576     {
 577       Lisp_Object retval;
 578
 579       GCPRO4 (genre, ds, obj, retval);
 580 #if 0
 581       obj = read_from_c_string (CONCORD_String_data (&st_id),
 582                                 CONCORD_String_size (&st_id) );
 583 #else
 584       obj = Fcar (Fread_from_string (make_ext_string
 585                                      ((char*)CONCORD_String_data (&st_id),
 586                                       CONCORD_String_size (&st_id),
 587                                       Qfile_name),
 588                                      Qnil, Qnil));
 589 #endif
 590       retval = Fconcord_make_object (genre, obj, ds);
 591       UNGCPRO;
 592       return retval;
 593     }
 594   return Qnil;
 595 }
 596
 597 DEFUN ("concord-object-get", Fconcord_object_get, 2, 2, 0, /*
 598 Return the value of OBJECT's FEATURE.
 599 */
 600        (object, feature))
 601 {
 602   struct gcpro gcpro1, gcpro2;
 603   int previous_print_readably;
 604   Lisp_Object obj_string;
 605   char* c_obj;
 606   CONCORD_Genre c_genre;
 607   char* feature_name;
 608   CONCORD_Feature c_feature;
 609   int status;
 610   CONCORD_String_Tank st_value;
 611
 612   CHECK_CONCORD_OBJECT (object);
 613   if ( !STRINGP(feature) )
 614     feature = Fsymbol_name (feature);
 615   previous_print_readably = print_readably;
 616   print_readably = 1;
 617   GCPRO2 (object, feature);
 618   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 619   UNGCPRO;
 620   print_readably = previous_print_readably;
 621   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 622                       C_STRING_ALLOCA, c_obj, Qfile_name);
 623   c_genre = XCONCORD_OBJECT_GENRE(object);
 624   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 625                       C_STRING_ALLOCA, feature_name,
 626                       Qfile_name);
 627   c_feature = concord_genre_get_feature (c_genre, feature_name);
 628   if (c_feature == NULL)
 629     {
 630       return Qnil;
 631     }
 632   status = concord_obj_get_feature_value_string (c_obj, c_feature,
 633                                                  &st_value);
 634   if (!status)
 635     {
 636       return
 637         Fcar (Fread_from_string (make_ext_string
 638                                  ((char*)CONCORD_String_data (&st_value),
 639                                   CONCORD_String_size (&st_value),
 640                                   Qfile_name),
 641                                  Qnil, Qnil));
 642     }
 643   return Qnil;
 644 }
 645
 646 static Lisp_Object
 647 concord_object_put (Lisp_Object object, Lisp_Object feature,
 648                     Lisp_Object value)
 649 {
 650   struct gcpro gcpro1, gcpro2, gcpro3;
 651   int previous_print_readably;
 652   Lisp_Object obj_string;
 653   char* c_obj;
 654   CONCORD_Genre c_genre;
 655   char* feature_name;
 656   CONCORD_Feature c_feature;
 657   int status;
 658   Lisp_Object value_string;
 659   char* c_value;
 660
 661   if ( !STRINGP(feature) )
 662     feature = Fsymbol_name (feature);
 663   previous_print_readably = print_readably;
 664   print_readably = 1;
 665   GCPRO3 (object, feature, value);
 666   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 667   UNGCPRO;
 668   print_readably = previous_print_readably;
 669   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 670                       C_STRING_ALLOCA, c_obj, Qfile_name);
 671   c_genre = XCONCORD_OBJECT_GENRE(object);
 672   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 673                       C_STRING_ALLOCA, feature_name,
 674                       Qfile_name);
 675   c_feature = concord_genre_get_feature (c_genre, feature_name);
 676   if (c_feature == NULL)
 677     {
 678       return Qnil;
 679     }
 680   previous_print_readably = print_readably;
 681   print_readably = 1;
 682   GCPRO3 (object, feature, value);
 683   value_string = Fprin1_to_string (value, Qnil);
 684   UNGCPRO;
 685   print_readably = previous_print_readably;
 686   TO_EXTERNAL_FORMAT (LISP_STRING, value_string,
 687                       C_STRING_ALLOCA, c_value,
 688                       Qfile_name);
 689   status = concord_obj_put_feature_value_str (c_obj, c_feature,
 690                                               (unsigned char*)c_value);
 691   if (status)
 692     return Qnil;
 693   status = chise_feature_sync (c_feature);
 694   if (status)
 695     return Qnil;
 696   if (XSTRING_DATA(feature)[0] == '=')
 697     {
 698       CONCORD_INDEX c_index
 699         = concord_genre_get_index (c_genre, feature_name);
 700
 701       concord_index_strid_put_obj (c_index, c_value, c_obj);
 702       concord_index_sync (c_index);
 703     }
 704   return Qt;
 705 }
 706
 707 DEFUN ("concord-object-put", Fconcord_object_put, 3, 3, 0, /*
 708 Store a VALUE of OBJECT's FEATURE.
 709 */
 710        (object, feature, value))
 711 {
 712   Lisp_String* name;
 713   Bufbyte *name_str;
 714
 715   CHECK_CONCORD_OBJECT (object);
 716   CHECK_SYMBOL (feature);
 717   name = symbol_name (XSYMBOL (feature));
 718   name_str = string_data (name);
 719   if ( NILP (concord_object_put (object, feature, value)) )
 720     return Qnil;
 721   if ( EQ (feature, Q_subsumptive)              ||
 722        EQ (feature, Q_subsumptive_from)         ||
 723        EQ (feature, Q_denotational)             ||
 724        EQ (feature, Q_denotational_from)        ||
 725        ( ( ((name_str[0] == '-') && (name_str[1] == '>')) ||
 726            ((name_str[0] == '<') && (name_str[1] == '-')) )
 727          && (memchr (name_str, '*', name->size) == NULL) ) )
 728     {
 729       Lisp_Object rest = value;
 730       Lisp_Object ret;
 731       Lisp_Object rev_feature = Qnil;
 732       struct gcpro gcpro1;
 733
 734       GCPRO1 (rev_feature);
 735       if (EQ (feature, Q_subsumptive))
 736         rev_feature = Q_subsumptive_from;
 737       else if (EQ (feature, Q_subsumptive_from))
 738         rev_feature = Q_subsumptive;
 739       else if (EQ (feature, Q_denotational))
 740         rev_feature = Q_denotational_from;
 741       else if (EQ (feature, Q_denotational_from))
 742         rev_feature = Q_denotational;
 743       else
 744         {
 745           Bytecount length = string_length (name);
 746           Bufbyte *rev_name_str = alloca (length + 1);
 747
 748           memcpy (rev_name_str + 2, name_str + 2, length - 2);
 749           if (name_str[0] == '<')
 750             {
 751               rev_name_str[0] = '-';
 752               rev_name_str[1] = '>';
 753             }
 754           else
 755             {
 756               rev_name_str[0] = '<';
 757               rev_name_str[1] = '-';
 758             }
 759           rev_name_str[length] = 0;
 760           rev_feature = intern (rev_name_str);
 761         }
 762
 763       while (CONSP (rest))
 764         {
 765           ret = XCAR (rest);
 766
 767           if ( CONCORD_OBJECT_P (ret) && !EQ (ret, object) )
 768             {
 769               Lisp_Object ffv;
 770
 771               ffv = Fconcord_object_get (ret, rev_feature);
 772               if (!CONSP (ffv))
 773                 concord_object_put (ret, rev_feature, list1 (object));
 774               else if (NILP (Fmemq (object, ffv)))
 775                 concord_object_put
 776                   (ret, rev_feature,
 777                    nconc2 (Fcopy_sequence (ffv), list1 (object)));
 778               Fsetcar (rest, ret);
 779             }
 780           rest = XCDR (rest);
 781         }
 782       UNGCPRO;
 783     }
 784   return Qt;
 785 }
 786
 787 struct closure_for_object_spec
 788 {
 789   char* object_id;
 790   Lisp_Object spec;
 791 } *concord_object_spec_closure;
 792
 793 static int
 794 add_feature_to_spec_mapper (CONCORD_Genre genre, char* name)
 795 {
 796   /* This function can GC */
 797   CONCORD_String_Tank st_value;
 798   CONCORD_Feature c_feature;
 799   int status;
 800
 801   c_feature = concord_genre_get_feature (genre, name);
 802   if (c_feature == NULL)
 803     return 0;
 804
 805   status =
 806     concord_obj_get_feature_value_string
 807     (concord_object_spec_closure->object_id, c_feature, &st_value);
 808   if (!status)
 809     {
 810       concord_object_spec_closure->spec
 811         = Fcons (Fcons (intern (name),
 812                         Fcar (Fread_from_string
 813                               (make_ext_string
 814                                ((char*)CONCORD_String_data (&st_value),
 815                                 CONCORD_String_size (&st_value),
 816                                 Qfile_name),
 817                                Qnil, Qnil))),
 818                  concord_object_spec_closure->spec);
 819     }
 820   return 0;
 821 }
 822
 823 DEFUN ("concord-object-spec", Fconcord_object_spec, 1, 1, 0, /*
 824 Return the spec of OBJECT.
 825 */
 826        (object))
 827 {
 828   Lisp_Object obj_string;
 829   char* c_obj;
 830   CONCORD_Genre c_genre;
 831   struct gcpro gcpro1, gcpro2;
 832   int previous_print_readably;
 833
 834   CHECK_CONCORD_OBJECT (object);
 835   previous_print_readably = print_readably;
 836   print_readably = 1;
 837   GCPRO1 (object);
 838   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 839   UNGCPRO;
 840   print_readably = previous_print_readably;
 841   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 842                       C_STRING_ALLOCA, c_obj, Qfile_name);
 843   c_genre = XCONCORD_OBJECT_GENRE(object);
 844   concord_object_spec_closure
 845     = alloca (sizeof (struct closure_for_object_spec));
 846   concord_object_spec_closure->object_id = c_obj;
 847   concord_object_spec_closure->spec = Qnil;
 848   GCPRO2 (object, concord_object_spec_closure->spec);
 849   concord_genre_foreach_feature_name (c_genre,
 850                                       add_feature_to_spec_mapper);
 851   UNGCPRO;
 852   return concord_object_spec_closure->spec;
 853 }
 854
 855 DEFUN ("concord-define-object", Fconcord_define_object, 2, 3, 0, /*
 856 Define an object of which spec is a set of features SPEC.
 857 */
 858        (spec, genre, ds))
 859 {
 860   Lisp_Object id = Fcdr (Fassq (Q_id, spec));
 861   Lisp_Object obj;
 862
 863   if (!NILP (id))
 864     {
 865       Lisp_Object rest = spec;
 866       Lisp_Object cell;
 867
 868       obj = Fconcord_make_object (genre, id, ds);
 869       while (!NILP (rest))
 870         {
 871           cell = Fcar (rest);
 872           Fconcord_object_put (obj, Fcar (cell), Fcdr (cell));
 873           rest = Fcdr (rest);
 874         }
 875       return obj;
 876     }
 877   return Qnil;
 878 }
 879
 880 struct closure_for_each_object
 881 {
 882   Lisp_Object function;
 883   Lisp_Object genre;
 884   Lisp_Object ds;
 885   Lisp_Object ret;
 886 } *for_each_object_closure;
 887
 888 static int
 889 func_for_each_object (CONCORD_String object_id,
 890                       CONCORD_Feature feature,
 891                       CONCORD_String value)
 892 {
 893   struct gcpro gcpro1, gcpro2;
 894   Lisp_Object obj, val, ret;
 895
 896 #if 0
 897   obj = read_from_c_string (CONCORD_String_data (object_id),
 898                             CONCORD_String_size (object_id) );
 899 #else
 900   obj = Fcar (Fread_from_string (make_ext_string
 901                                  ((char*)CONCORD_String_data (object_id),
 902                                   CONCORD_String_size (object_id),
 903                                   Qfile_name),
 904                                  Qnil, Qnil));
 905 #endif
 906   GCPRO1 (obj);
 907   obj = Fconcord_make_object (for_each_object_closure->genre,
 908                               obj,
 909                               for_each_object_closure->ds);
 910 #if 0
 911   val = read_from_c_string (CONCORD_String_data (value),
 912                             CONCORD_String_size (value) );
 913 #else
 914   val = Fcar (Fread_from_string (make_ext_string
 915                                  ((char*)CONCORD_String_data (value),
 916                                   CONCORD_String_size (value),
 917                                   Qfile_name),
 918                                  Qnil, Qnil));
 919 #endif
 920   UNGCPRO;
 921   GCPRO2 (obj, val);
 922   ret = call2 (for_each_object_closure->function, obj, val);
 923   UNGCPRO;
 924   for_each_object_closure->ret = ret;
 925   return !NILP (ret);
 926 }
 927
 928 DEFUN ("concord-for-each-object-in-feature",
 929        Fconcord_foreach_object_in_feature, 2, 4, 0, /*
 930 Do FUNCTION over objects in FEATURE, calling it with two args,
 931 each key and value in the FEATURE table.
 932 Optional argument GENRE specifies the genre of the FEATURE.
 933 When the FUNCTION returns non-nil, it breaks the repeat.
 934 */
 935        (function, feature, genre, ds))
 936 {
 937   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 938   Lisp_CONCORD_DS* lds;
 939   char* genre_name;
 940   CONCORD_Genre c_genre;
 941   char* feature_name;
 942   CONCORD_Feature c_feature;
 943
 944   if (NILP (ds))
 945     ds = Fconcord_genre_ds (genre);
 946   CHECK_CONCORD_DS (ds);
 947   lds = XCONCORD_DS (ds);
 948   if (lds->ds == NULL)
 949     return Qnil;
 950   if ( !STRINGP(feature) )
 951     feature = Fsymbol_name (feature);
 952   if ( !STRINGP(genre) )
 953     genre = Fsymbol_name (genre);
 954   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 955                       C_STRING_ALLOCA, genre_name,
 956                       Qfile_name);
 957   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 958   if (c_genre == NULL)
 959     return Qnil;
 960
 961   CHECK_STRING (feature);
 962   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 963                       C_STRING_ALLOCA, feature_name,
 964                       Qfile_name);
 965   c_feature = concord_genre_get_feature (c_genre, feature_name);
 966   if (c_feature == NULL)
 967     return Qnil;
 968   for_each_object_closure
 969     = alloca (sizeof (struct closure_for_each_object));
 970   for_each_object_closure->function = function;
 971   for_each_object_closure->genre = genre;
 972   for_each_object_closure->ds = ds;
 973   for_each_object_closure->ret = Qnil;
 974   GCPRO4 (for_each_object_closure->function,
 975           for_each_object_closure->genre,
 976           for_each_object_closure->ds,
 977           for_each_object_closure->ret);
 978   concord_feature_foreach_obj_string (c_feature, func_for_each_object);
 979   UNGCPRO;
 980   /* return Qt; */
 981   return for_each_object_closure->ret;
 982 }
 983
 984
 985 static int
 986 concord_name_validate (Lisp_Object keyword, Lisp_Object value,
 987                        Error_behavior errb)
 988 {
 989   if (ERRB_EQ (errb, ERROR_ME))
 990     {
 991       CHECK_SYMBOL (value);
 992       return 1;
 993     }
 994
 995   return SYMBOLP (value);
 996 }
 997
 998 static int
 999 concord_id_validate (Lisp_Object keyword, Lisp_Object value,
1000                      Error_behavior errb)
1001 {
1002   if (ERRB_EQ (errb, ERROR_ME))
1003     {
1004       /* CHECK_SYMBOL (value); */
1005       if ( INTP (value) || CHARP (value) || SYMBOLP (value) )
1006         ;
1007       else
1008         dead_wrong_type_argument (Qsymbolp, value);
1009       return 1;
1010     }
1011
1012   return INTP (value) || CHARP (value) || SYMBOLP (value);
1013 }
1014
1015 static int
1016 concord_object_validate (Lisp_Object data, Error_behavior errb)
1017 {
1018   struct gcpro gcpro1, gcpro2, gcpro3;
1019   Lisp_Object retval;
1020   Lisp_Object valw = Qnil;
1021   Lisp_Object genre = Qnil;
1022   Lisp_Object oid = Qnil;
1023
1024   data = Fcdr (data); /* skip over Qconcord_object */
1025   while (!NILP (data))
1026     {
1027       Lisp_Object keyw = Fcar (data);
1028
1029       data = Fcdr (data);
1030       valw = Fcar (data);
1031       data = Fcdr (data);
1032       if (EQ (keyw, Qgenre))
1033         genre = valw;
1034       else if (EQ (keyw, Q_id))
1035         oid = valw;
1036       else
1037         ABORT ();
1038     }
1039
1040   if (NILP (genre))
1041     {
1042       maybe_error (Qconcord_object, errb, "No genre given");
1043       return 0;
1044     }
1045   if (NILP (oid))
1046     {
1047       maybe_error (Qconcord_object, errb, "No object-id given");
1048       return 0;
1049     }
1050
1051   GCPRO3 (genre, oid, retval);
1052   retval = Fconcord_make_object (genre, oid, Qnil);
1053   UNGCPRO;
1054   if (NILP (retval))
1055     {
1056       maybe_signal_simple_error_2 ("No such Concord-object",
1057                                    oid, genre, Qconcord_object, errb);
1058       return 0;
1059     }
1060
1061   return 1;
1062 }
1063
1064 static Lisp_Object
1065 concord_object_instantiate (Lisp_Object data)
1066 {
1067   struct gcpro gcpro1, gcpro2;
1068   Lisp_Object retval;
1069
1070   GCPRO2 (data, retval);
1071   retval = Fconcord_make_object (Fplist_get (data, Qgenre, Qnil),
1072                                  Fplist_get (data, Q_id, Qnil),
1073                                  Qnil);
1074   UNGCPRO;
1075   return retval;
1076 }
1077
1078
1079 void
1080 syms_of_concord (void)
1081 {
1082   INIT_LRECORD_IMPLEMENTATION (concord_ds);
1083   INIT_LRECORD_IMPLEMENTATION (concord_object);
1084
1085   defsymbol (&Qconcord, "concord");
1086   defsymbol (&Qconcord_dsp, "concord-dsp");
1087   defsymbol (&Qconcord_objectp, "concord-objectp");
1088   defsymbol (&Qconcord_object, "concord-object");
1089   defsymbol (&Qgenre, "genre");
1090   defsymbol (&Q_id, "=id");
1091 #ifdef HAVE_LIBCHISE
1092   defsymbol (&Qcharacter, "character");
1093   defsymbol (&Qfeature, "feature");
1094 #endif
1095
1096   DEFSUBR (Fconcord_open_ds);
1097   DEFSUBR (Fconcord_ds_p);
1098   DEFSUBR (Fconcord_close_ds);
1099   DEFSUBR (Fconcord_ds_directory);
1100
1101   DEFSUBR (Fconcord_assign_genre);
1102   DEFSUBR (Fconcord_genre_directory);
1103   DEFSUBR (Fconcord_genre_ds);
1104   DEFSUBR (Fconcord_feature_list);
1105
1106   DEFSUBR (Fconcord_make_object);
1107   DEFSUBR (Fconcord_object_p);
1108   DEFSUBR (Fconcord_object_id);
1109   DEFSUBR (Fconcord_object_genre);
1110   DEFSUBR (Fconcord_decode_object);
1111   DEFSUBR (Fconcord_object_get);
1112   DEFSUBR (Fconcord_object_put);
1113   DEFSUBR (Fconcord_define_object);
1114   DEFSUBR (Fconcord_object_spec);
1115   DEFSUBR (Fconcord_foreach_object_in_feature);
1116 }
1117
1118 void
1119 structure_type_create_concord (void)
1120 {
1121   struct structure_type *st;
1122
1123   st = define_structure_type (Qconcord_object,
1124                               concord_object_validate,
1125                               concord_object_instantiate);
1126
1127   define_structure_type_keyword (st, Qgenre, concord_name_validate);
1128   define_structure_type_keyword (st, Q_id, concord_id_validate);
1129 }
1130
1131 void
1132 vars_of_concord (void)
1133 {
1134   Fprovide (Qconcord);
1135
1136   staticpro (&Vconcord_ds_hash_table);
1137   Vconcord_ds_hash_table
1138     = make_lisp_hash_table (8, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
1139
1140   staticpro (&Vconcord_genre_hash_table);
1141   Vconcord_genre_hash_table
1142     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1143
1144   staticpro (&Vconcord_genre_object_hash_table);
1145   Vconcord_genre_object_hash_table
1146     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1147 }
1148
1149 void
1150 complex_vars_of_concord (void)
1151 {
1152 #ifdef HAVE_LIBCHISE
1153   Fconcord_assign_genre (Qcharacter, Vchise_system_db_directory);
1154   Fconcord_assign_genre (Qfeature, Vchise_system_db_directory);
1155 #endif
1156 }