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