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