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       GCPRO3 (genre, ds, obj);
 549 #if 0
 550       obj = read_from_c_string (CONCORD_String_data (&st_id),
 551                                 CONCORD_String_size (&st_id) );
 552 #else
 553       obj = Fcar (Fread_from_string (make_ext_string
 554                                      ((char*)CONCORD_String_data (&st_id),
 555                                       CONCORD_String_size (&st_id),
 556                                       Qfile_name),
 557                                      Qnil, Qnil));
 558 #endif
 559       UNGCPRO;
 560       return Fconcord_make_object (genre, obj, ds);
 561     }
 562   return Qnil;
 563 }
 564
 565 DEFUN ("concord-object-get", Fconcord_object_get, 2, 2, 0, /*
 566 Return the value of OBJECT's FEATURE.
 567 */
 568        (object, feature))
 569 {
 570   struct gcpro gcpro1, gcpro2;
 571   int previous_print_readably;
 572   Lisp_Object obj_string;
 573   char* c_obj;
 574   CONCORD_Genre c_genre;
 575   char* feature_name;
 576   CONCORD_Feature c_feature;
 577   int status;
 578   CONCORD_String_Tank st_value;
 579
 580   CHECK_CONCORD_OBJECT (object);
 581   if ( !STRINGP(feature) )
 582     feature = Fsymbol_name (feature);
 583   previous_print_readably = print_readably;
 584   print_readably = 1;
 585   GCPRO2 (object, feature);
 586   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 587   UNGCPRO;
 588   print_readably = previous_print_readably;
 589   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 590                       C_STRING_ALLOCA, c_obj, Qfile_name);
 591   c_genre = XCONCORD_OBJECT_GENRE(object);
 592   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 593                       C_STRING_ALLOCA, feature_name,
 594                       Qfile_name);
 595   c_feature = concord_genre_get_feature (c_genre, feature_name);
 596   if (c_feature == NULL)
 597     {
 598       return Qnil;
 599     }
 600   status = concord_obj_get_feature_value_string (c_obj, c_feature,
 601                                                  &st_value);
 602   if (!status)
 603     {
 604       return
 605         Fcar (Fread_from_string (make_ext_string
 606                                  ((char*)CONCORD_String_data (&st_value),
 607                                   CONCORD_String_size (&st_value),
 608                                   Qfile_name),
 609                                  Qnil, Qnil));
 610     }
 611   return Qnil;
 612 }
 613
 614 DEFUN ("concord-object-put", Fconcord_object_put, 3, 3, 0, /*
 615 Store a VALUE of OBJECT's FEATURE.
 616 */
 617        (object, feature, value))
 618 {
 619   struct gcpro gcpro1, gcpro2, gcpro3;
 620   int previous_print_readably;
 621   Lisp_Object obj_string;
 622   char* c_obj;
 623   CONCORD_Genre c_genre;
 624   char* feature_name;
 625   CONCORD_Feature c_feature;
 626   int status;
 627   Lisp_Object value_string;
 628   char* c_value;
 629
 630   CHECK_CONCORD_OBJECT (object);
 631   if ( !STRINGP(feature) )
 632     feature = Fsymbol_name (feature);
 633   previous_print_readably = print_readably;
 634   print_readably = 1;
 635   GCPRO3 (object, feature, value);
 636   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 637   UNGCPRO;
 638   print_readably = previous_print_readably;
 639   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 640                       C_STRING_ALLOCA, c_obj, Qfile_name);
 641   c_genre = XCONCORD_OBJECT_GENRE(object);
 642   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 643                       C_STRING_ALLOCA, feature_name,
 644                       Qfile_name);
 645   c_feature = concord_genre_get_feature (c_genre, feature_name);
 646   if (c_feature == NULL)
 647     {
 648       return Qnil;
 649     }
 650   previous_print_readably = print_readably;
 651   print_readably = 1;
 652   GCPRO3 (object, feature, value);
 653   value_string = Fprin1_to_string (value, Qnil);
 654   UNGCPRO;
 655   print_readably = previous_print_readably;
 656   TO_EXTERNAL_FORMAT (LISP_STRING, value_string,
 657                       C_STRING_ALLOCA, c_value,
 658                       Qfile_name);
 659   status = concord_obj_put_feature_value_str (c_obj, c_feature,
 660                                               (unsigned char*)c_value);
 661   if (status)
 662     return Qnil;
 663   status = chise_feature_sync (c_feature);
 664   if (status)
 665     return Qnil;
 666   if (feature_name[0] == '=')
 667     {
 668       CONCORD_INDEX c_index
 669         = concord_genre_get_index (c_genre, feature_name);
 670
 671       status = concord_index_strid_put_obj (c_index, c_value, c_obj);
 672     }
 673   return Qt;
 674 }
 675
 676 struct closure_for_object_spec
 677 {
 678   char* object_id;
 679   Lisp_Object spec;
 680 } *concord_object_spec_closure;
 681
 682 static int
 683 add_feature_to_spec_mapper (CONCORD_Genre genre, char* name)
 684 {
 685   /* This function can GC */
 686   CONCORD_String_Tank st_value;
 687   CONCORD_Feature c_feature;
 688   int status;
 689
 690   c_feature = concord_genre_get_feature (genre, name);
 691   if (c_feature == NULL)
 692     return 0;
 693
 694   status =
 695     concord_obj_get_feature_value_string
 696     (concord_object_spec_closure->object_id, c_feature, &st_value);
 697   if (!status)
 698     {
 699       concord_object_spec_closure->spec
 700         = Fcons (Fcons (intern (name),
 701                         Fcar (Fread_from_string
 702                               (make_ext_string
 703                                ((char*)CONCORD_String_data (&st_value),
 704                                 CONCORD_String_size (&st_value),
 705                                 Qfile_name),
 706                                Qnil, Qnil))),
 707                  concord_object_spec_closure->spec);
 708     }
 709   return 0;
 710 }
 711
 712 DEFUN ("concord-object-spec", Fconcord_object_spec, 1, 1, 0, /*
 713 Return the spec of OBJECT.
 714 */
 715        (object))
 716 {
 717   Lisp_Object obj_string;
 718   char* c_obj;
 719   CONCORD_Genre c_genre;
 720   struct gcpro gcpro1, gcpro2;
 721   int previous_print_readably;
 722
 723   CHECK_CONCORD_OBJECT (object);
 724   previous_print_readably = print_readably;
 725   print_readably = 1;
 726   GCPRO1 (object);
 727   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 728   UNGCPRO;
 729   print_readably = previous_print_readably;
 730   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 731                       C_STRING_ALLOCA, c_obj, Qfile_name);
 732   c_genre = XCONCORD_OBJECT_GENRE(object);
 733   concord_object_spec_closure
 734     = alloca (sizeof (struct closure_for_object_spec));
 735   concord_object_spec_closure->object_id = c_obj;
 736   concord_object_spec_closure->spec = Qnil;
 737   GCPRO2 (object, concord_object_spec_closure->spec);
 738   concord_genre_foreach_feature_name (c_genre,
 739                                       add_feature_to_spec_mapper);
 740   UNGCPRO;
 741   return concord_object_spec_closure->spec;
 742 }
 743
 744 struct closure_for_each_object
 745 {
 746   Lisp_Object function;
 747   Lisp_Object genre;
 748   Lisp_Object ds;
 749   Lisp_Object ret;
 750 } *for_each_object_closure;
 751
 752 static int
 753 func_for_each_object (CONCORD_String object_id,
 754                       CONCORD_Feature feature,
 755                       CONCORD_String value)
 756 {
 757   Lisp_Object obj, val, ret;
 758
 759 #if 0
 760   obj = read_from_c_string (CONCORD_String_data (object_id),
 761                             CONCORD_String_size (object_id) );
 762 #else
 763   obj = Fcar (Fread_from_string (make_ext_string
 764                                  ((char*)CONCORD_String_data (object_id),
 765                                   CONCORD_String_size (object_id),
 766                                   Qfile_name),
 767                                  Qnil, Qnil));
 768 #endif
 769   obj = Fconcord_make_object (for_each_object_closure->genre,
 770                               obj,
 771                               for_each_object_closure->ds);
 772 #if 0
 773   val = read_from_c_string (CONCORD_String_data (value),
 774                             CONCORD_String_size (value) );
 775 #else
 776   val = Fcar (Fread_from_string (make_ext_string
 777                                  ((char*)CONCORD_String_data (value),
 778                                   CONCORD_String_size (value),
 779                                   Qfile_name),
 780                                  Qnil, Qnil));
 781 #endif
 782   ret = call2 (for_each_object_closure->function, obj, val);
 783   for_each_object_closure->ret = ret;
 784   return !NILP (ret);
 785 }
 786
 787 DEFUN ("concord-for-each-object-in-feature",
 788        Fconcord_foreach_object_in_feature, 2, 4, 0, /*
 789 Do FUNCTION over objects in FEATURE, calling it with two args,
 790 each key and value in the FEATURE table.
 791 Optional argument GENRE specifies the genre of the FEATURE.
 792 When the FUNCTION returns non-nil, it breaks the repeat.
 793 */
 794        (function, feature, genre, ds))
 795 {
 796   Lisp_CONCORD_DS* lds;
 797   char* genre_name;
 798   CONCORD_Genre c_genre;
 799   char* feature_name;
 800   CONCORD_Feature c_feature;
 801
 802   if (NILP (ds))
 803     ds = Fconcord_genre_ds (genre);
 804   CHECK_CONCORD_DS (ds);
 805   lds = XCONCORD_DS (ds);
 806   if (lds->ds == NULL)
 807     return Qnil;
 808   if ( !STRINGP(feature) )
 809     feature = Fsymbol_name (feature);
 810   if ( !STRINGP(genre) )
 811     genre = Fsymbol_name (genre);
 812   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 813                       C_STRING_ALLOCA, genre_name,
 814                       Qfile_name);
 815   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 816   if (c_genre == NULL)
 817     return Qnil;
 818
 819   CHECK_STRING (feature);
 820   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 821                       C_STRING_ALLOCA, feature_name,
 822                       Qfile_name);
 823   c_feature = concord_genre_get_feature (c_genre, feature_name);
 824   if (c_feature == NULL)
 825     return Qnil;
 826   for_each_object_closure
 827     = alloca (sizeof (struct closure_for_each_object));
 828   for_each_object_closure->function = function;
 829   for_each_object_closure->genre = genre;
 830   for_each_object_closure->ds = ds;
 831   for_each_object_closure->ret = Qnil;
 832   concord_feature_foreach_obj_string (c_feature, func_for_each_object);
 833   /* return Qt; */
 834   return for_each_object_closure->ret;
 835 }
 836
 837
 838 static int
 839 concord_name_validate (Lisp_Object keyword, Lisp_Object value,
 840                        Error_behavior errb)
 841 {
 842   if (ERRB_EQ (errb, ERROR_ME))
 843     {
 844       CHECK_SYMBOL (value);
 845       return 1;
 846     }
 847
 848   return SYMBOLP (value);
 849 }
 850
 851 static int
 852 concord_object_validate (Lisp_Object data, Error_behavior errb)
 853 {
 854   Lisp_Object valw = Qnil;
 855   Lisp_Object genre = Qnil;
 856   Lisp_Object oid = Qnil;
 857
 858   data = Fcdr (data); /* skip over Qconcord_object */
 859   while (!NILP (data))
 860     {
 861       Lisp_Object keyw = Fcar (data);
 862
 863       data = Fcdr (data);
 864       valw = Fcar (data);
 865       data = Fcdr (data);
 866       if (EQ (keyw, Qgenre))
 867         genre = valw;
 868       else if (EQ (keyw, Q_id))
 869         oid = valw;
 870       else
 871         ABORT ();
 872     }
 873
 874   if (NILP (genre))
 875     {
 876       maybe_error (Qconcord_object, errb, "No genre given");
 877       return 0;
 878     }
 879   if (NILP (oid))
 880     {
 881       maybe_error (Qconcord_object, errb, "No object-id given");
 882       return 0;
 883     }
 884
 885   if (NILP (Fconcord_make_object (genre, oid, Qnil)))
 886     {
 887       maybe_signal_simple_error_2 ("No such Concord-object",
 888                                    oid, genre, Qconcord_object, errb);
 889       return 0;
 890     }
 891
 892   return 1;
 893 }
 894
 895 static Lisp_Object
 896 concord_object_instantiate (Lisp_Object data)
 897 {
 898   struct gcpro gcpro1, gcpro2;
 899   Lisp_Object retval;
 900
 901   GCPRO2 (data, retval);
 902   retval = Fconcord_make_object (Fplist_get (data, Qgenre, Qnil),
 903                                  Fplist_get (data, Q_id, Qnil),
 904                                  Qnil);
 905   UNGCPRO;
 906   return retval;
 907 }
 908
 909
 910 void
 911 syms_of_concord (void)
 912 {
 913   INIT_LRECORD_IMPLEMENTATION (concord_ds);
 914   INIT_LRECORD_IMPLEMENTATION (concord_object);
 915
 916   defsymbol (&Qconcord, "concord");
 917   defsymbol (&Qconcord_dsp, "concord-dsp");
 918   defsymbol (&Qconcord_objectp, "concord-objectp");
 919   defsymbol (&Qconcord_object, "concord-object");
 920   defsymbol (&Qgenre, "genre");
 921   defsymbol (&Q_id, "=id");
 922
 923   DEFSUBR (Fconcord_open_ds);
 924   DEFSUBR (Fconcord_ds_p);
 925   DEFSUBR (Fconcord_close_ds);
 926   DEFSUBR (Fconcord_ds_directory);
 927
 928   DEFSUBR (Fconcord_assign_genre);
 929   DEFSUBR (Fconcord_genre_directory);
 930   DEFSUBR (Fconcord_genre_ds);
 931   DEFSUBR (Fconcord_feature_list);
 932
 933   DEFSUBR (Fconcord_make_object);
 934   DEFSUBR (Fconcord_object_p);
 935   DEFSUBR (Fconcord_object_id);
 936   DEFSUBR (Fconcord_decode_object);
 937   DEFSUBR (Fconcord_object_get);
 938   DEFSUBR (Fconcord_object_put);
 939   DEFSUBR (Fconcord_object_spec);
 940   DEFSUBR (Fconcord_foreach_object_in_feature);
 941 }
 942
 943 void
 944 structure_type_create_concord (void)
 945 {
 946   struct structure_type *st;
 947
 948   st = define_structure_type (Qconcord_object,
 949                               concord_object_validate,
 950                               concord_object_instantiate);
 951
 952   define_structure_type_keyword (st, Qgenre, concord_name_validate);
 953   define_structure_type_keyword (st, Q_id, concord_name_validate);
 954 }
 955
 956 void
 957 vars_of_concord (void)
 958 {
 959   Fprovide (Qconcord);
 960
 961   staticpro (&Vconcord_ds_hash_table);
 962   Vconcord_ds_hash_table
 963     = make_lisp_hash_table (8, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
 964
 965   staticpro (&Vconcord_genre_hash_table);
 966   Vconcord_genre_hash_table
 967     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
 968 }