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