git.chise.org Git - chise/xemacs-chise.git.1/blob - src/concord.c

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