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