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 (Fmember (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 DEFUN ("concord-object-adjoin", Fconcord_object_adjoin, 3, 3, 0, /*
 788 Cons ITEM onto the front of FEATURE's value of OBJECT only if it's not already there.
 789 */
 790        (object, feature, item))
 791 {
 792   Lisp_Object ret = Fconcord_object_get (object, feature);
 793
 794   if ( NILP (Fmember (item, ret)) )
 795     return Fconcord_object_put (object, feature, Fcons (item, ret));
 796   return Qnil;
 797 }
 798
 799 DEFUN ("concord-object-adjoin*", Fconcord_object_adjoinX, 3, 3, 0, /*
 800 Append ITEM onto the end of FEATURE's value of OBJECT only if it's not already there.
 801 */
 802        (object, feature, item))
 803 {
 804   Lisp_Object ret = Fconcord_object_get (object, feature);
 805
 806   if ( NILP (Fmember (item, ret)) )
 807     return Fconcord_object_put (object, feature, nconc2 (ret, list1 (item)));
 808   return Qnil;
 809 }
 810
 811 struct closure_for_object_spec
 812 {
 813   char* object_id;
 814   Lisp_Object spec;
 815 } *concord_object_spec_closure;
 816
 817 static int
 818 add_feature_to_spec_mapper (CONCORD_Genre genre, char* name)
 819 {
 820   /* This function can GC */
 821   CONCORD_String_Tank st_value;
 822   CONCORD_Feature c_feature;
 823   int status;
 824
 825   c_feature = concord_genre_get_feature (genre, name);
 826   if (c_feature == NULL)
 827     return 0;
 828
 829   status =
 830     concord_obj_get_feature_value_string
 831     (concord_object_spec_closure->object_id, c_feature, &st_value);
 832   if (!status)
 833     {
 834       concord_object_spec_closure->spec
 835         = Fcons (Fcons (intern (name),
 836                         Fcar (Fread_from_string
 837                               (make_ext_string
 838                                ((char*)CONCORD_String_data (&st_value),
 839                                 CONCORD_String_size (&st_value),
 840                                 Qfile_name),
 841                                Qnil, Qnil))),
 842                  concord_object_spec_closure->spec);
 843     }
 844   return 0;
 845 }
 846
 847 DEFUN ("concord-object-spec", Fconcord_object_spec, 1, 1, 0, /*
 848 Return the spec of OBJECT.
 849 */
 850        (object))
 851 {
 852   Lisp_Object obj_string;
 853   char* c_obj;
 854   CONCORD_Genre c_genre;
 855   struct gcpro gcpro1, gcpro2;
 856   int previous_print_readably;
 857
 858   CHECK_CONCORD_OBJECT (object);
 859   previous_print_readably = print_readably;
 860   print_readably = 1;
 861   GCPRO1 (object);
 862   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 863   UNGCPRO;
 864   print_readably = previous_print_readably;
 865   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 866                       C_STRING_ALLOCA, c_obj, Qfile_name);
 867   c_genre = XCONCORD_OBJECT_GENRE(object);
 868   concord_object_spec_closure
 869     = alloca (sizeof (struct closure_for_object_spec));
 870   concord_object_spec_closure->object_id = c_obj;
 871   concord_object_spec_closure->spec = Qnil;
 872   GCPRO2 (object, concord_object_spec_closure->spec);
 873   concord_genre_foreach_feature_name (c_genre,
 874                                       add_feature_to_spec_mapper);
 875   UNGCPRO;
 876   return concord_object_spec_closure->spec;
 877 }
 878
 879 DEFUN ("concord-define-object", Fconcord_define_object, 2, 3, 0, /*
 880 Define an object of which spec is a set of features SPEC.
 881 */
 882        (spec, genre, ds))
 883 {
 884   Lisp_Object id = Fcdr (Fassq (Q_id, spec));
 885   Lisp_Object obj;
 886
 887   if (!NILP (id))
 888     {
 889       Lisp_Object rest = spec;
 890       Lisp_Object cell;
 891
 892       obj = Fconcord_make_object (genre, id, ds);
 893       while (!NILP (rest))
 894         {
 895           cell = Fcar (rest);
 896           Fconcord_object_put (obj, Fcar (cell), Fcdr (cell));
 897           rest = Fcdr (rest);
 898         }
 899       return obj;
 900     }
 901   return Qnil;
 902 }
 903
 904 struct closure_for_each_object
 905 {
 906   Lisp_Object function;
 907   Lisp_Object genre;
 908   Lisp_Object ds;
 909   Lisp_Object ret;
 910 } *for_each_object_closure;
 911
 912 static int
 913 func_for_each_object (CONCORD_String object_id,
 914                       CONCORD_Feature feature,
 915                       CONCORD_String value)
 916 {
 917   struct gcpro gcpro1, gcpro2;
 918   Lisp_Object obj, val, ret;
 919
 920 #if 0
 921   obj = read_from_c_string (CONCORD_String_data (object_id),
 922                             CONCORD_String_size (object_id) );
 923 #else
 924   obj = Fcar (Fread_from_string (make_ext_string
 925                                  ((char*)CONCORD_String_data (object_id),
 926                                   CONCORD_String_size (object_id),
 927                                   Qfile_name),
 928                                  Qnil, Qnil));
 929 #endif
 930   GCPRO1 (obj);
 931   obj = Fconcord_make_object (for_each_object_closure->genre,
 932                               obj,
 933                               for_each_object_closure->ds);
 934 #if 0
 935   val = read_from_c_string (CONCORD_String_data (value),
 936                             CONCORD_String_size (value) );
 937 #else
 938   val = Fcar (Fread_from_string (make_ext_string
 939                                  ((char*)CONCORD_String_data (value),
 940                                   CONCORD_String_size (value),
 941                                   Qfile_name),
 942                                  Qnil, Qnil));
 943 #endif
 944   UNGCPRO;
 945   GCPRO2 (obj, val);
 946   ret = call2 (for_each_object_closure->function, obj, val);
 947   UNGCPRO;
 948   for_each_object_closure->ret = ret;
 949   return !NILP (ret);
 950 }
 951
 952 DEFUN ("concord-for-each-object-in-feature",
 953        Fconcord_foreach_object_in_feature, 2, 4, 0, /*
 954 Do FUNCTION over objects in FEATURE, calling it with two args,
 955 each key and value in the FEATURE table.
 956 Optional argument GENRE specifies the genre of the FEATURE.
 957 When the FUNCTION returns non-nil, it breaks the repeat.
 958 */
 959        (function, feature, genre, ds))
 960 {
 961   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 962   Lisp_CONCORD_DS* lds;
 963   char* genre_name;
 964   CONCORD_Genre c_genre;
 965   char* feature_name;
 966   CONCORD_Feature c_feature;
 967
 968   if (NILP (ds))
 969     ds = Fconcord_genre_ds (genre);
 970   CHECK_CONCORD_DS (ds);
 971   lds = XCONCORD_DS (ds);
 972   if (lds->ds == NULL)
 973     return Qnil;
 974   if ( !STRINGP(feature) )
 975     feature = Fsymbol_name (feature);
 976   if ( !STRINGP(genre) )
 977     genre = Fsymbol_name (genre);
 978   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 979                       C_STRING_ALLOCA, genre_name,
 980                       Qfile_name);
 981   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 982   if (c_genre == NULL)
 983     return Qnil;
 984
 985   CHECK_STRING (feature);
 986   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 987                       C_STRING_ALLOCA, feature_name,
 988                       Qfile_name);
 989   c_feature = concord_genre_get_feature (c_genre, feature_name);
 990   if (c_feature == NULL)
 991     return Qnil;
 992   for_each_object_closure
 993     = alloca (sizeof (struct closure_for_each_object));
 994   for_each_object_closure->function = function;
 995   for_each_object_closure->genre = genre;
 996   for_each_object_closure->ds = ds;
 997   for_each_object_closure->ret = Qnil;
 998   GCPRO4 (for_each_object_closure->function,
 999           for_each_object_closure->genre,
1000           for_each_object_closure->ds,
1001           for_each_object_closure->ret);
1002   concord_feature_foreach_obj_string (c_feature, func_for_each_object);
1003   UNGCPRO;
1004   /* return Qt; */
1005   return for_each_object_closure->ret;
1006 }
1007
1008
1009 static int
1010 concord_name_validate (Lisp_Object keyword, Lisp_Object value,
1011                        Error_behavior errb)
1012 {
1013   if (ERRB_EQ (errb, ERROR_ME))
1014     {
1015       CHECK_SYMBOL (value);
1016       return 1;
1017     }
1018
1019   return SYMBOLP (value);
1020 }
1021
1022 static int
1023 concord_id_validate (Lisp_Object keyword, Lisp_Object value,
1024                      Error_behavior errb)
1025 {
1026   if (ERRB_EQ (errb, ERROR_ME))
1027     {
1028       /* CHECK_SYMBOL (value); */
1029       if ( INTP (value) || CHARP (value) || SYMBOLP (value) )
1030         ;
1031       else
1032         dead_wrong_type_argument (Qsymbolp, value);
1033       return 1;
1034     }
1035
1036   return INTP (value) || CHARP (value) || SYMBOLP (value);
1037 }
1038
1039 static int
1040 concord_object_validate (Lisp_Object data, Error_behavior errb)
1041 {
1042   struct gcpro gcpro1, gcpro2, gcpro3;
1043   Lisp_Object retval;
1044   Lisp_Object valw = Qnil;
1045   Lisp_Object genre = Qnil;
1046   Lisp_Object oid = Qnil;
1047
1048   data = Fcdr (data); /* skip over Qconcord_object */
1049   while (!NILP (data))
1050     {
1051       Lisp_Object keyw = Fcar (data);
1052
1053       data = Fcdr (data);
1054       valw = Fcar (data);
1055       data = Fcdr (data);
1056       if (EQ (keyw, Qgenre))
1057         genre = valw;
1058       else if (EQ (keyw, Q_id))
1059         oid = valw;
1060       else
1061         ABORT ();
1062     }
1063
1064   if (NILP (genre))
1065     {
1066       maybe_error (Qconcord_object, errb, "No genre given");
1067       return 0;
1068     }
1069   if (NILP (oid))
1070     {
1071       maybe_error (Qconcord_object, errb, "No object-id given");
1072       return 0;
1073     }
1074
1075   GCPRO3 (genre, oid, retval);
1076   retval = Fconcord_make_object (genre, oid, Qnil);
1077   UNGCPRO;
1078   if (NILP (retval))
1079     {
1080       maybe_signal_simple_error_2 ("No such Concord-object",
1081                                    oid, genre, Qconcord_object, errb);
1082       return 0;
1083     }
1084
1085   return 1;
1086 }
1087
1088 static Lisp_Object
1089 concord_object_instantiate (Lisp_Object data)
1090 {
1091   struct gcpro gcpro1, gcpro2;
1092   Lisp_Object retval;
1093
1094   GCPRO2 (data, retval);
1095   retval = Fconcord_make_object (Fplist_get (data, Qgenre, Qnil),
1096                                  Fplist_get (data, Q_id, Qnil),
1097                                  Qnil);
1098   UNGCPRO;
1099   return retval;
1100 }
1101
1102
1103 void
1104 syms_of_concord (void)
1105 {
1106   INIT_LRECORD_IMPLEMENTATION (concord_ds);
1107   INIT_LRECORD_IMPLEMENTATION (concord_object);
1108
1109   defsymbol (&Qconcord, "concord");
1110   defsymbol (&Qconcord_dsp, "concord-dsp");
1111   defsymbol (&Qconcord_objectp, "concord-objectp");
1112   defsymbol (&Qconcord_object, "concord-object");
1113   defsymbol (&Qgenre, "genre");
1114   defsymbol (&Q_id, "=id");
1115 #ifdef HAVE_LIBCHISE
1116   defsymbol (&Qcharacter, "character");
1117   defsymbol (&Qfeature, "feature");
1118 #endif
1119
1120   DEFSUBR (Fconcord_open_ds);
1121   DEFSUBR (Fconcord_ds_p);
1122   DEFSUBR (Fconcord_close_ds);
1123   DEFSUBR (Fconcord_ds_directory);
1124
1125   DEFSUBR (Fconcord_assign_genre);
1126   DEFSUBR (Fconcord_genre_directory);
1127   DEFSUBR (Fconcord_genre_ds);
1128   DEFSUBR (Fconcord_feature_list);
1129
1130   DEFSUBR (Fconcord_make_object);
1131   DEFSUBR (Fconcord_object_p);
1132   DEFSUBR (Fconcord_object_id);
1133   DEFSUBR (Fconcord_object_genre);
1134   DEFSUBR (Fconcord_decode_object);
1135   DEFSUBR (Fconcord_object_get);
1136   DEFSUBR (Fconcord_object_put);
1137   DEFSUBR (Fconcord_object_adjoin);
1138   DEFSUBR (Fconcord_object_adjoinX);
1139   DEFSUBR (Fconcord_define_object);
1140   DEFSUBR (Fconcord_object_spec);
1141   DEFSUBR (Fconcord_foreach_object_in_feature);
1142 }
1143
1144 void
1145 structure_type_create_concord (void)
1146 {
1147   struct structure_type *st;
1148
1149   st = define_structure_type (Qconcord_object,
1150                               concord_object_validate,
1151                               concord_object_instantiate);
1152
1153   define_structure_type_keyword (st, Qgenre, concord_name_validate);
1154   define_structure_type_keyword (st, Q_id, concord_id_validate);
1155 }
1156
1157 void
1158 vars_of_concord (void)
1159 {
1160   Fprovide (Qconcord);
1161
1162   staticpro (&Vconcord_ds_hash_table);
1163   Vconcord_ds_hash_table
1164     = make_lisp_hash_table (8, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
1165
1166   staticpro (&Vconcord_genre_hash_table);
1167   Vconcord_genre_hash_table
1168     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1169
1170   staticpro (&Vconcord_genre_object_hash_table);
1171   Vconcord_genre_object_hash_table
1172     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1173 }
1174
1175 void
1176 complex_vars_of_concord (void)
1177 {
1178 #ifdef HAVE_LIBCHISE
1179   Fconcord_assign_genre (Qcharacter, Vchise_system_db_directory);
1180   Fconcord_assign_genre (Qfeature, Vchise_system_db_directory);
1181 #endif
1182 }