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 DEFUN ("concord-object-put", Fconcord_object_put, 3, 3, 0, /*
 652 Store a VALUE of OBJECT's FEATURE.
 653 */
 654        (object, feature, value))
 655 {
 656   struct gcpro gcpro1, gcpro2, gcpro3;
 657   int previous_print_readably;
 658   Lisp_Object obj_string;
 659   char* c_obj;
 660   CONCORD_Genre c_genre;
 661   char* feature_name;
 662   CONCORD_Feature c_feature;
 663   int status;
 664   Lisp_Object value_string;
 665   char* c_value;
 666
 667   CHECK_CONCORD_OBJECT (object);
 668   if ( !STRINGP(feature) )
 669     feature = Fsymbol_name (feature);
 670   previous_print_readably = print_readably;
 671   print_readably = 1;
 672   GCPRO3 (object, feature, value);
 673   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 674   UNGCPRO;
 675   print_readably = previous_print_readably;
 676   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 677                       C_STRING_ALLOCA, c_obj, Qfile_name);
 678   c_genre = XCONCORD_OBJECT_GENRE(object);
 679   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 680                       C_STRING_ALLOCA, feature_name,
 681                       Qfile_name);
 682   c_feature = concord_genre_get_feature (c_genre, feature_name);
 683   if (c_feature == NULL)
 684     {
 685       return Qnil;
 686     }
 687   previous_print_readably = print_readably;
 688   print_readably = 1;
 689   GCPRO3 (object, feature, value);
 690   value_string = Fprin1_to_string (value, Qnil);
 691   UNGCPRO;
 692   print_readably = previous_print_readably;
 693   TO_EXTERNAL_FORMAT (LISP_STRING, value_string,
 694                       C_STRING_ALLOCA, c_value,
 695                       Qfile_name);
 696   status = concord_obj_put_feature_value_str (c_obj, c_feature,
 697                                               (unsigned char*)c_value);
 698   if (status)
 699     return Qnil;
 700   status = chise_feature_sync (c_feature);
 701   if (status)
 702     return Qnil;
 703   if (feature_name[0] == '=')
 704     {
 705       CONCORD_INDEX c_index
 706         = concord_genre_get_index (c_genre, feature_name);
 707
 708       concord_index_strid_put_obj (c_index, c_value, c_obj);
 709       concord_index_sync (c_index);
 710     }
 711   return Qt;
 712 }
 713
 714 struct closure_for_object_spec
 715 {
 716   char* object_id;
 717   Lisp_Object spec;
 718 } *concord_object_spec_closure;
 719
 720 static int
 721 add_feature_to_spec_mapper (CONCORD_Genre genre, char* name)
 722 {
 723   /* This function can GC */
 724   CONCORD_String_Tank st_value;
 725   CONCORD_Feature c_feature;
 726   int status;
 727
 728   c_feature = concord_genre_get_feature (genre, name);
 729   if (c_feature == NULL)
 730     return 0;
 731
 732   status =
 733     concord_obj_get_feature_value_string
 734     (concord_object_spec_closure->object_id, c_feature, &st_value);
 735   if (!status)
 736     {
 737       concord_object_spec_closure->spec
 738         = Fcons (Fcons (intern (name),
 739                         Fcar (Fread_from_string
 740                               (make_ext_string
 741                                ((char*)CONCORD_String_data (&st_value),
 742                                 CONCORD_String_size (&st_value),
 743                                 Qfile_name),
 744                                Qnil, Qnil))),
 745                  concord_object_spec_closure->spec);
 746     }
 747   return 0;
 748 }
 749
 750 DEFUN ("concord-object-spec", Fconcord_object_spec, 1, 1, 0, /*
 751 Return the spec of OBJECT.
 752 */
 753        (object))
 754 {
 755   Lisp_Object obj_string;
 756   char* c_obj;
 757   CONCORD_Genre c_genre;
 758   struct gcpro gcpro1, gcpro2;
 759   int previous_print_readably;
 760
 761   CHECK_CONCORD_OBJECT (object);
 762   previous_print_readably = print_readably;
 763   print_readably = 1;
 764   GCPRO1 (object);
 765   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 766   UNGCPRO;
 767   print_readably = previous_print_readably;
 768   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 769                       C_STRING_ALLOCA, c_obj, Qfile_name);
 770   c_genre = XCONCORD_OBJECT_GENRE(object);
 771   concord_object_spec_closure
 772     = alloca (sizeof (struct closure_for_object_spec));
 773   concord_object_spec_closure->object_id = c_obj;
 774   concord_object_spec_closure->spec = Qnil;
 775   GCPRO2 (object, concord_object_spec_closure->spec);
 776   concord_genre_foreach_feature_name (c_genre,
 777                                       add_feature_to_spec_mapper);
 778   UNGCPRO;
 779   return concord_object_spec_closure->spec;
 780 }
 781
 782 struct closure_for_each_object
 783 {
 784   Lisp_Object function;
 785   Lisp_Object genre;
 786   Lisp_Object ds;
 787   Lisp_Object ret;
 788 } *for_each_object_closure;
 789
 790 static int
 791 func_for_each_object (CONCORD_String object_id,
 792                       CONCORD_Feature feature,
 793                       CONCORD_String value)
 794 {
 795   struct gcpro gcpro1, gcpro2, gcpro3;
 796   Lisp_Object obj, val, ret;
 797
 798 #if 0
 799   obj = read_from_c_string (CONCORD_String_data (object_id),
 800                             CONCORD_String_size (object_id) );
 801 #else
 802   obj = Fcar (Fread_from_string (make_ext_string
 803                                  ((char*)CONCORD_String_data (object_id),
 804                                   CONCORD_String_size (object_id),
 805                                   Qfile_name),
 806                                  Qnil, Qnil));
 807 #endif
 808   GCPRO1 (obj);
 809   obj = Fconcord_make_object (for_each_object_closure->genre,
 810                               obj,
 811                               for_each_object_closure->ds);
 812   UNGCPRO;
 813 #if 0
 814   val = read_from_c_string (CONCORD_String_data (value),
 815                             CONCORD_String_size (value) );
 816 #else
 817   val = Fcar (Fread_from_string (make_ext_string
 818                                  ((char*)CONCORD_String_data (value),
 819                                   CONCORD_String_size (value),
 820                                   Qfile_name),
 821                                  Qnil, Qnil));
 822 #endif
 823   GCPRO3 (obj, val, ret);
 824   ret = call2 (for_each_object_closure->function, obj, val);
 825   UNGCPRO;
 826   for_each_object_closure->ret = ret;
 827   return !NILP (ret);
 828 }
 829
 830 DEFUN ("concord-for-each-object-in-feature",
 831        Fconcord_foreach_object_in_feature, 2, 4, 0, /*
 832 Do FUNCTION over objects in FEATURE, calling it with two args,
 833 each key and value in the FEATURE table.
 834 Optional argument GENRE specifies the genre of the FEATURE.
 835 When the FUNCTION returns non-nil, it breaks the repeat.
 836 */
 837        (function, feature, genre, ds))
 838 {
 839   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 840   Lisp_CONCORD_DS* lds;
 841   char* genre_name;
 842   CONCORD_Genre c_genre;
 843   char* feature_name;
 844   CONCORD_Feature c_feature;
 845
 846   if (NILP (ds))
 847     ds = Fconcord_genre_ds (genre);
 848   CHECK_CONCORD_DS (ds);
 849   lds = XCONCORD_DS (ds);
 850   if (lds->ds == NULL)
 851     return Qnil;
 852   if ( !STRINGP(feature) )
 853     feature = Fsymbol_name (feature);
 854   if ( !STRINGP(genre) )
 855     genre = Fsymbol_name (genre);
 856   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 857                       C_STRING_ALLOCA, genre_name,
 858                       Qfile_name);
 859   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 860   if (c_genre == NULL)
 861     return Qnil;
 862
 863   CHECK_STRING (feature);
 864   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 865                       C_STRING_ALLOCA, feature_name,
 866                       Qfile_name);
 867   c_feature = concord_genre_get_feature (c_genre, feature_name);
 868   if (c_feature == NULL)
 869     return Qnil;
 870   for_each_object_closure
 871     = alloca (sizeof (struct closure_for_each_object));
 872   for_each_object_closure->function = function;
 873   for_each_object_closure->genre = genre;
 874   for_each_object_closure->ds = ds;
 875   for_each_object_closure->ret = Qnil;
 876   GCPRO4 (for_each_object_closure->function,
 877           for_each_object_closure->genre,
 878           for_each_object_closure->ds,
 879           for_each_object_closure->ret);
 880   concord_feature_foreach_obj_string (c_feature, func_for_each_object);
 881   UNGCPRO;
 882   /* return Qt; */
 883   return for_each_object_closure->ret;
 884 }
 885
 886
 887 static int
 888 concord_name_validate (Lisp_Object keyword, Lisp_Object value,
 889                        Error_behavior errb)
 890 {
 891   if (ERRB_EQ (errb, ERROR_ME))
 892     {
 893       CHECK_SYMBOL (value);
 894       return 1;
 895     }
 896
 897   return SYMBOLP (value);
 898 }
 899
 900 static int
 901 concord_object_validate (Lisp_Object data, Error_behavior errb)
 902 {
 903   struct gcpro gcpro1, gcpro2, gcpro3;
 904   Lisp_Object retval;
 905   Lisp_Object valw = Qnil;
 906   Lisp_Object genre = Qnil;
 907   Lisp_Object oid = Qnil;
 908
 909   data = Fcdr (data); /* skip over Qconcord_object */
 910   while (!NILP (data))
 911     {
 912       Lisp_Object keyw = Fcar (data);
 913
 914       data = Fcdr (data);
 915       valw = Fcar (data);
 916       data = Fcdr (data);
 917       if (EQ (keyw, Qgenre))
 918         genre = valw;
 919       else if (EQ (keyw, Q_id))
 920         oid = valw;
 921       else
 922         ABORT ();
 923     }
 924
 925   if (NILP (genre))
 926     {
 927       maybe_error (Qconcord_object, errb, "No genre given");
 928       return 0;
 929     }
 930   if (NILP (oid))
 931     {
 932       maybe_error (Qconcord_object, errb, "No object-id given");
 933       return 0;
 934     }
 935
 936   GCPRO3 (genre, oid, retval);
 937   retval = Fconcord_make_object (genre, oid, Qnil);
 938   UNGCPRO;
 939   if (NILP (retval))
 940     {
 941       maybe_signal_simple_error_2 ("No such Concord-object",
 942                                    oid, genre, Qconcord_object, errb);
 943       return 0;
 944     }
 945
 946   return 1;
 947 }
 948
 949 static Lisp_Object
 950 concord_object_instantiate (Lisp_Object data)
 951 {
 952   struct gcpro gcpro1, gcpro2;
 953   Lisp_Object retval;
 954
 955   GCPRO2 (data, retval);
 956   retval = Fconcord_make_object (Fplist_get (data, Qgenre, Qnil),
 957                                  Fplist_get (data, Q_id, Qnil),
 958                                  Qnil);
 959   UNGCPRO;
 960   return retval;
 961 }
 962
 963
 964 void
 965 syms_of_concord (void)
 966 {
 967   INIT_LRECORD_IMPLEMENTATION (concord_ds);
 968   INIT_LRECORD_IMPLEMENTATION (concord_object);
 969
 970   defsymbol (&Qconcord, "concord");
 971   defsymbol (&Qconcord_dsp, "concord-dsp");
 972   defsymbol (&Qconcord_objectp, "concord-objectp");
 973   defsymbol (&Qconcord_object, "concord-object");
 974   defsymbol (&Qgenre, "genre");
 975   defsymbol (&Q_id, "=id");
 976
 977   DEFSUBR (Fconcord_open_ds);
 978   DEFSUBR (Fconcord_ds_p);
 979   DEFSUBR (Fconcord_close_ds);
 980   DEFSUBR (Fconcord_ds_directory);
 981
 982   DEFSUBR (Fconcord_assign_genre);
 983   DEFSUBR (Fconcord_genre_directory);
 984   DEFSUBR (Fconcord_genre_ds);
 985   DEFSUBR (Fconcord_feature_list);
 986
 987   DEFSUBR (Fconcord_make_object);
 988   DEFSUBR (Fconcord_object_p);
 989   DEFSUBR (Fconcord_object_id);
 990   DEFSUBR (Fconcord_decode_object);
 991   DEFSUBR (Fconcord_object_get);
 992   DEFSUBR (Fconcord_object_put);
 993   DEFSUBR (Fconcord_object_spec);
 994   DEFSUBR (Fconcord_foreach_object_in_feature);
 995 }
 996
 997 void
 998 structure_type_create_concord (void)
 999 {
1000   struct structure_type *st;
1001
1002   st = define_structure_type (Qconcord_object,
1003                               concord_object_validate,
1004                               concord_object_instantiate);
1005
1006   define_structure_type_keyword (st, Qgenre, concord_name_validate);
1007   define_structure_type_keyword (st, Q_id, concord_name_validate);
1008 }
1009
1010 void
1011 vars_of_concord (void)
1012 {
1013   Fprovide (Qconcord);
1014
1015   staticpro (&Vconcord_ds_hash_table);
1016   Vconcord_ds_hash_table
1017     = make_lisp_hash_table (8, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
1018
1019   staticpro (&Vconcord_genre_hash_table);
1020   Vconcord_genre_hash_table
1021     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1022
1023   staticpro (&Vconcord_genre_object_hash_table);
1024   Vconcord_genre_object_hash_table
1025     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1026 }