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