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