git.chise.org Git - chise/xemacs-chise.git-/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     error ("printing unreadable object #<concord_object 0x%x>",
 366            lcobj->header.uid);
 367
 368   write_c_string ("#<concord_object \"", printcharfun);
 369   write_c_string (concord_ds_location
 370                   (concord_genre_get_data_source (lcobj->genre)),
 371                   printcharfun);
 372   write_c_string (":", printcharfun);
 373   write_c_string (concord_genre_get_name (lcobj->genre), printcharfun);
 374   write_c_string (";", printcharfun);
 375   GCPRO2 (obj, printcharfun);
 376   print_internal (lcobj->id, printcharfun, escapeflag);
 377   UNGCPRO;
 378   write_c_string ("\">", printcharfun);
 379 }
 380
 381 static void
 382 finalize_concord_object (void *header, int for_disksave)
 383 {
 384   Lisp_CONCORD_Object* lcobj = (Lisp_CONCORD_Object *) header;
 385
 386   if (for_disksave)
 387     {
 388       Lisp_Object object;
 389       XSET_CONCORD_OBJECT (object, lcobj);
 390
 391       signal_simple_error
 392         ("Can't dump an emacs containing concord_object objects", object);
 393     }
 394 }
 395
 396 static const struct lrecord_description concord_object_description[] = {
 397   { XD_LISP_OBJECT, offsetof (Lisp_CONCORD_Object, id) },
 398   { XD_END }
 399 };
 400
 401 DEFINE_LRECORD_IMPLEMENTATION ("concord_object", concord_object,
 402                                mark_concord_object, print_concord_object,
 403                                finalize_concord_object, 0, 0,
 404                                concord_object_description,
 405                                Lisp_CONCORD_Object);
 406
 407 DEFUN ("concord-make-object",
 408        Fconcord_make_object, 1, 3, 0, /*
 409 Make and return a Concord-object from ID and GENRE.
 410 Optional argument DS specifies the data-source of the GENRE.
 411 */
 412        (id, genre, ds))
 413 {
 414   Lisp_CONCORD_DS* lds;
 415   char* genre_name;
 416   CONCORD_Genre c_genre;
 417   Lisp_CONCORD_Object* lcobj;
 418   Lisp_Object retval;
 419
 420   if (NILP (ds))
 421     ds = Fconcord_genre_ds (genre);
 422   CHECK_CONCORD_DS (ds);
 423   lds = XCONCORD_DS (ds);
 424   if (lds->ds == NULL)
 425     return Qnil;
 426   if ( !STRINGP(genre) )
 427     genre = Fsymbol_name (genre);
 428   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 429                       C_STRING_ALLOCA, genre_name,
 430                       Qfile_name);
 431   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 432   if (c_genre == NULL)
 433     return Qnil;
 434   lcobj = allocate_concord_object ();
 435   lcobj->genre = c_genre;
 436   lcobj->id = id;
 437   XSET_CONCORD_OBJECT (retval, lcobj);
 438   return retval;
 439 }
 440
 441 DEFUN ("concord-object-p",
 442        Fconcord_object_p, 1, 1, 0, /*
 443 Return t if OBJECT is a concord-object.
 444 */
 445        (object))
 446 {
 447   return CONCORD_OBJECT_P (object) ? Qt : Qnil;
 448 }
 449
 450 DEFUN ("concord-object-id",
 451        Fconcord_object_id, 1, 1, 0, /*
 452 Return an id of Concord-object OBJECT.
 453 */
 454        (object))
 455 {
 456   CHECK_CONCORD_OBJECT (object);
 457   return XCONCORD_OBJECT_ID (object);
 458 }
 459
 460 DEFUN ("concord-decode-object",
 461        Fconcord_decode_object, 2, 4, 0, /*
 462 Make and return a Concord-object from FEATURE and VALUE.
 463 Optional argument GENRE specifies the GENRE of the object.
 464 Optional argument DS specifies the data-source of the GENRE.
 465 */
 466        (feature, value, genre, ds))
 467 {
 468   Lisp_CONCORD_DS* lds;
 469   char* genre_name;
 470   CONCORD_Genre c_genre;
 471   char* feature_name;
 472   CONCORD_INDEX c_index;
 473   Lisp_Object value_string;
 474   char* strid;
 475   CONCORD_String_Tank st_id;
 476   int status;
 477   Lisp_Object obj;
 478   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 479
 480   if (NILP (ds))
 481     ds = Fconcord_genre_ds (genre);
 482   CHECK_CONCORD_DS (ds);
 483   lds = XCONCORD_DS (ds);
 484   if (lds->ds == NULL)
 485     return Qnil;
 486   if ( !STRINGP(feature) )
 487     feature = Fsymbol_name (feature);
 488   if ( !STRINGP(genre) )
 489     genre = Fsymbol_name (genre);
 490   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 491                       C_STRING_ALLOCA, genre_name,
 492                       Qfile_name);
 493   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 494   if (c_genre == NULL)
 495     {
 496       return Qnil;
 497     }
 498
 499   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 500                       C_STRING_ALLOCA, feature_name,
 501                       Qfile_name);
 502   c_index = concord_genre_get_index (c_genre, feature_name);
 503   if (c_index == NULL)
 504     {
 505       return Qnil;
 506     }
 507
 508   GCPRO5 (feature, value, genre, ds, value_string);
 509   value_string = Fprin1_to_string (value, Qnil);
 510   UNGCPRO;
 511   TO_EXTERNAL_FORMAT (LISP_STRING,
 512                       value_string, C_STRING_ALLOCA, strid,
 513                       Qfile_name);
 514   status = concord_index_strid_get_obj_string (c_index, strid, &st_id);
 515   if (!status)
 516     {
 517       GCPRO3 (genre, ds, obj);
 518 #if 0
 519       obj = read_from_c_string (CONCORD_String_data (&st_id),
 520                                 CONCORD_String_size (&st_id) );
 521 #else
 522       obj = Fcar (Fread_from_string (make_ext_string
 523                                      ((char*)CONCORD_String_data (&st_id),
 524                                       CONCORD_String_size (&st_id),
 525                                       Qfile_name),
 526                                      Qnil, Qnil));
 527 #endif
 528       UNGCPRO;
 529       return Fconcord_make_object (obj, genre, ds);
 530     }
 531   return Qnil;
 532 }
 533
 534 DEFUN ("concord-object-get",
 535        Fconcord_object_get, 2, 2, 0, /*
 536 Return the value of OBJECT's FEATURE.
 537 */
 538        (object, feature))
 539 {
 540   struct gcpro gcpro1, gcpro2;
 541   Lisp_Object obj_string;
 542   char* c_obj;
 543   CONCORD_Genre c_genre;
 544   char* feature_name;
 545   CONCORD_Feature c_feature;
 546   int status;
 547   CONCORD_String_Tank st_value;
 548
 549   CHECK_CONCORD_OBJECT (object);
 550   if ( !STRINGP(feature) )
 551     feature = Fsymbol_name (feature);
 552   GCPRO2 (object, feature);
 553   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 554   UNGCPRO;
 555   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 556                       C_STRING_ALLOCA, c_obj, Qfile_name);
 557   c_genre = XCONCORD_OBJECT_GENRE(object);
 558   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 559                       C_STRING_ALLOCA, feature_name,
 560                       Qfile_name);
 561   c_feature = concord_genre_get_feature (c_genre, feature_name);
 562   if (c_feature == NULL)
 563     {
 564       return Qnil;
 565     }
 566   status = concord_obj_get_feature_value_string (c_obj, c_feature,
 567                                                  &st_value);
 568   if (!status)
 569     {
 570       return
 571         Fcar (Fread_from_string (make_ext_string
 572                                  ((char*)CONCORD_String_data (&st_value),
 573                                   CONCORD_String_size (&st_value),
 574                                   Qfile_name),
 575                                  Qnil, Qnil));
 576     }
 577   return Qnil;
 578 }
 579
 580 DEFUN ("concord-object-put",
 581        Fconcord_object_put, 3, 3, 0, /*
 582 Store a VALUE of OBJECT's FEATURE.
 583 */
 584        (object, feature, value))
 585 {
 586   struct gcpro gcpro1, gcpro2, gcpro3;
 587   Lisp_Object obj_string;
 588   char* c_obj;
 589   CONCORD_Genre c_genre;
 590   char* feature_name;
 591   CONCORD_Feature c_feature;
 592   int status;
 593   Lisp_Object value_string;
 594   char* c_value;
 595
 596   CHECK_CONCORD_OBJECT (object);
 597   if ( !STRINGP(feature) )
 598     feature = Fsymbol_name (feature);
 599   GCPRO3 (object, feature, value);
 600   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 601   UNGCPRO;
 602   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 603                       C_STRING_ALLOCA, c_obj, Qfile_name);
 604   c_genre = XCONCORD_OBJECT_GENRE(object);
 605   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 606                       C_STRING_ALLOCA, feature_name,
 607                       Qfile_name);
 608   c_feature = concord_genre_get_feature (c_genre, feature_name);
 609   if (c_feature == NULL)
 610     {
 611       return Qnil;
 612     }
 613   GCPRO3 (object, feature, value);
 614   value_string = Fprin1_to_string (value, Qnil);
 615   UNGCPRO;
 616   TO_EXTERNAL_FORMAT (LISP_STRING, value_string,
 617                       C_STRING_ALLOCA, c_value,
 618                       Qfile_name);
 619   status = concord_obj_put_feature_value_str (c_obj, c_feature,
 620                                               (unsigned char*)c_value);
 621   if (status)
 622     return Qnil;
 623   status = chise_feature_sync (c_feature);
 624   if (status)
 625     return Qnil;
 626   return Qt;
 627 }
 628
 629 struct closure_for_object_spec
 630 {
 631   char* object_id;
 632   Lisp_Object spec;
 633 } *concord_object_spec_closure;
 634
 635 static int
 636 add_feature_to_spec_mapper (CONCORD_Genre genre, char* name)
 637 {
 638   /* This function can GC */
 639   CONCORD_String_Tank st_value;
 640   CONCORD_Feature c_feature;
 641   int status;
 642
 643   c_feature = concord_genre_get_feature (genre, name);
 644   if (c_feature == NULL)
 645     return 0;
 646
 647   status =
 648     concord_obj_get_feature_value_string
 649     (concord_object_spec_closure->object_id, c_feature, &st_value);
 650   if (!status)
 651     {
 652       concord_object_spec_closure->spec
 653         = Fcons (Fcons (intern (name),
 654                         Fcar (Fread_from_string
 655                               (make_ext_string
 656                                ((char*)CONCORD_String_data (&st_value),
 657                                 CONCORD_String_size (&st_value),
 658                                 Qfile_name),
 659                                Qnil, Qnil))),
 660                  concord_object_spec_closure->spec);
 661     }
 662   return 0;
 663 }
 664
 665 DEFUN ("concord-object-spec", Fconcord_object_spec, 1, 1, 0, /*
 666 Return the spec of OBJECT.
 667 */
 668        (object))
 669 {
 670   Lisp_Object obj_string;
 671   char* c_obj;
 672   CONCORD_Genre c_genre;
 673   struct gcpro gcpro1, gcpro2;
 674
 675   CHECK_CONCORD_OBJECT (object);
 676   GCPRO1 (object);
 677   obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil);
 678   UNGCPRO;
 679   TO_EXTERNAL_FORMAT (LISP_STRING, obj_string,
 680                       C_STRING_ALLOCA, c_obj, Qfile_name);
 681   c_genre = XCONCORD_OBJECT_GENRE(object);
 682   concord_object_spec_closure
 683     = alloca (sizeof (struct closure_for_object_spec));
 684   concord_object_spec_closure->object_id = c_obj;
 685   concord_object_spec_closure->spec = Qnil;
 686   GCPRO2 (object, concord_object_spec_closure->spec);
 687   concord_genre_foreach_feature_name (c_genre,
 688                                       add_feature_to_spec_mapper);
 689   UNGCPRO;
 690   return concord_object_spec_closure->spec;
 691 }
 692
 693 struct closure_for_each_object
 694 {
 695   Lisp_Object function;
 696   Lisp_Object genre;
 697   Lisp_Object ds;
 698   Lisp_Object ret;
 699 } *for_each_object_closure;
 700
 701 static int
 702 func_for_each_object (CONCORD_String object_id,
 703                       CONCORD_Feature feature,
 704                       CONCORD_String value)
 705 {
 706   Lisp_Object obj, val, ret;
 707
 708 #if 0
 709   obj = read_from_c_string (CONCORD_String_data (object_id),
 710                             CONCORD_String_size (object_id) );
 711 #else
 712   obj = Fcar (Fread_from_string (make_ext_string
 713                                  ((char*)CONCORD_String_data (object_id),
 714                                   CONCORD_String_size (object_id),
 715                                   Qfile_name),
 716                                  Qnil, Qnil));
 717 #endif
 718   obj = Fconcord_make_object (obj,
 719                               for_each_object_closure->genre,
 720                               for_each_object_closure->ds);
 721 #if 0
 722   val = read_from_c_string (CONCORD_String_data (value),
 723                             CONCORD_String_size (value) );
 724 #else
 725   val = Fcar (Fread_from_string (make_ext_string
 726                                  ((char*)CONCORD_String_data (value),
 727                                   CONCORD_String_size (value),
 728                                   Qfile_name),
 729                                  Qnil, Qnil));
 730 #endif
 731   ret = call2 (for_each_object_closure->function, obj, val);
 732   for_each_object_closure->ret = ret;
 733   return !NILP (ret);
 734 }
 735
 736 DEFUN ("concord-for-each-object-in-feature",
 737        Fconcord_foreach_object_in_feature, 2, 4, 0, /*
 738 Do FUNCTION over objects in FEATURE, calling it with two args,
 739 each key and value in the FEATURE table.
 740 Optional argument GENRE specifies the genre of the FEATURE.
 741 When the FUNCTION returns non-nil, it breaks the repeat.
 742 */
 743        (function, feature, genre, ds))
 744 {
 745   Lisp_CONCORD_DS* lds;
 746   char* genre_name;
 747   CONCORD_Genre c_genre;
 748   char* feature_name;
 749   CONCORD_Feature c_feature;
 750
 751   if (NILP (ds))
 752     ds = Fconcord_genre_ds (genre);
 753   CHECK_CONCORD_DS (ds);
 754   lds = XCONCORD_DS (ds);
 755   if (lds->ds == NULL)
 756     return Qnil;
 757   if ( !STRINGP(feature) )
 758     feature = Fsymbol_name (feature);
 759   if ( !STRINGP(genre) )
 760     genre = Fsymbol_name (genre);
 761   TO_EXTERNAL_FORMAT (LISP_STRING, genre,
 762                       C_STRING_ALLOCA, genre_name,
 763                       Qfile_name);
 764   c_genre = concord_ds_get_genre (lds->ds, genre_name);
 765   if (c_genre == NULL)
 766     return Qnil;
 767
 768   CHECK_STRING (feature);
 769   TO_EXTERNAL_FORMAT (LISP_STRING, feature,
 770                       C_STRING_ALLOCA, feature_name,
 771                       Qfile_name);
 772   c_feature = concord_genre_get_feature (c_genre, feature_name);
 773   if (c_feature == NULL)
 774     return Qnil;
 775   for_each_object_closure
 776     = alloca (sizeof (struct closure_for_each_object));
 777   for_each_object_closure->function = function;
 778   for_each_object_closure->genre = genre;
 779   for_each_object_closure->ds = ds;
 780   for_each_object_closure->ret = Qnil;
 781   concord_feature_foreach_obj_string (c_feature, func_for_each_object);
 782   /* return Qt; */
 783   return for_each_object_closure->ret;
 784 }
 785
 786
 787 static int
 788 concord_name_validate (Lisp_Object keyword, Lisp_Object value,
 789                        Error_behavior errb)
 790 {
 791   if (ERRB_EQ (errb, ERROR_ME))
 792     {
 793       CHECK_SYMBOL (value);
 794       return 1;
 795     }
 796
 797   return SYMBOLP (value);
 798 }
 799
 800 static int
 801 concord_object_validate (Lisp_Object data, Error_behavior errb)
 802 {
 803   Lisp_Object valw = Qnil;
 804   Lisp_Object genre = Qnil;
 805   Lisp_Object oid = Qnil;
 806
 807   data = Fcdr (data); /* skip over Qconcord_object */
 808   while (!NILP (data))
 809     {
 810       Lisp_Object keyw = Fcar (data);
 811
 812       data = Fcdr (data);
 813       valw = Fcar (data);
 814       data = Fcdr (data);
 815       if (EQ (keyw, Qgenre))
 816         genre = valw;
 817       else if (EQ (keyw, Q_id))
 818         oid = valw;
 819       else
 820         ABORT ();
 821     }
 822
 823   if (NILP (genre))
 824     {
 825       maybe_error (Qconcord_object, errb, "No genre given");
 826       return 0;
 827     }
 828   if (NILP (oid))
 829     {
 830       maybe_error (Qconcord_object, errb, "No object-id given");
 831       return 0;
 832     }
 833
 834   if (NILP (Fconcord_make_object (oid, genre, Qnil)))
 835     {
 836       maybe_signal_simple_error_2 ("No such Concord-object",
 837                                    oid, genre, Qconcord_object, errb);
 838       return 0;
 839     }
 840
 841   return 1;
 842 }
 843
 844 static Lisp_Object
 845 concord_object_instantiate (Lisp_Object data)
 846 {
 847   return Fconcord_make_object (Fplist_get (data, Q_id, Qnil),
 848                                Fplist_get (data, Qgenre, Qnil),
 849                                Qnil);
 850 }
 851
 852
 853 void
 854 syms_of_concord (void)
 855 {
 856   INIT_LRECORD_IMPLEMENTATION (concord_ds);
 857   INIT_LRECORD_IMPLEMENTATION (concord_object);
 858
 859   defsymbol (&Qconcord, "concord");
 860   defsymbol (&Qconcord_dsp, "concord-dsp");
 861   defsymbol (&Qconcord_objectp, "concord-objectp");
 862   defsymbol (&Qconcord_object, "concord-object");
 863   defsymbol (&Qgenre, "genre");
 864   defsymbol (&Q_id, "=id");
 865
 866   DEFSUBR (Fconcord_open_ds);
 867   DEFSUBR (Fconcord_ds_p);
 868   DEFSUBR (Fconcord_close_ds);
 869   DEFSUBR (Fconcord_ds_directory);
 870
 871   DEFSUBR (Fconcord_assign_genre);
 872   DEFSUBR (Fconcord_genre_directory);
 873   DEFSUBR (Fconcord_genre_ds);
 874   DEFSUBR (Fconcord_feature_list);
 875
 876   DEFSUBR (Fconcord_make_object);
 877   DEFSUBR (Fconcord_object_p);
 878   DEFSUBR (Fconcord_object_id);
 879   DEFSUBR (Fconcord_decode_object);
 880   DEFSUBR (Fconcord_object_get);
 881   DEFSUBR (Fconcord_object_put);
 882   DEFSUBR (Fconcord_object_spec);
 883   DEFSUBR (Fconcord_foreach_object_in_feature);
 884 }
 885
 886 void
 887 structure_type_create_concord (void)
 888 {
 889   struct structure_type *st;
 890
 891   st = define_structure_type (Qconcord_object,
 892                               concord_object_validate,
 893                               concord_object_instantiate);
 894
 895   define_structure_type_keyword (st, Qgenre, concord_name_validate);
 896   define_structure_type_keyword (st, Q_id, concord_name_validate);
 897 }
 898
 899 void
 900 vars_of_concord (void)
 901 {
 902   Fprovide (Qconcord);
 903
 904   staticpro (&Vconcord_ds_hash_table);
 905   Vconcord_ds_hash_table
 906     = make_lisp_hash_table (8, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
 907
 908   staticpro (&Vconcord_genre_hash_table);
 909   Vconcord_genre_hash_table
 910     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
 911 }