src/concord.c

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