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