src/concord.c

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