src/concord.c

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