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