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