X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fconcord.c;h=73b6047aa30c3e1241a2cc73f1de04c098d069ea;hb=586931afc9456a8b76a07a231ec15734a30e0f80;hp=2d9c0a7024ab043cea7e4a46e81cd41e93b25d68;hpb=39b387e2eb5ce5b8231a8f7eaa73c97656082c60;p=chise%2Fxemacs-chise.git.1 diff --git a/src/concord.c b/src/concord.c index 2d9c0a7..73b6047 100644 --- a/src/concord.c +++ b/src/concord.c @@ -1,5 +1,5 @@ /* XEmacs routines to deal with CONCORD. - Copyright (C) 2005,2006 MORIOKA Tomohiko + Copyright (C) 2005,2006,2008 MORIOKA Tomohiko This file is part of XEmacs. @@ -33,12 +33,17 @@ Boston, MA 02111-1307, USA. */ EXFUN (Fread_from_string, 3); +EXFUN (Fconcord_decode_object, 4); +EXFUN (Fconcord_object_put, 3); +EXFUN (Fconcord_object_get, 2); + Lisp_Object Qconcord; Lisp_Object Qconcord_object; Lisp_Object Qgenre, Q_id; Lisp_Object Vconcord_ds_hash_table; Lisp_Object Vconcord_genre_hash_table; +Lisp_Object Vconcord_genre_object_hash_table; typedef struct Lisp_CONCORD_DS Lisp_CONCORD_DS; @@ -362,20 +367,30 @@ print_concord_object (Lisp_Object obj, struct gcpro gcpro1, gcpro2; if (print_readably) - error ("printing unreadable object #", - lcobj->header.uid); - - write_c_string ("#genre)), - printcharfun); - write_c_string (":", printcharfun); - write_c_string (concord_genre_get_name (lcobj->genre), printcharfun); - write_c_string (";", printcharfun); - GCPRO2 (obj, printcharfun); - print_internal (lcobj->id, printcharfun, escapeflag); - UNGCPRO; - write_c_string ("\">", printcharfun); + { + write_c_string ("#s(concord-object", printcharfun); + write_c_string (" genre ", printcharfun); + write_c_string (concord_genre_get_name (lcobj->genre), printcharfun); + write_c_string (" =id ", printcharfun); + GCPRO2 (obj, printcharfun); + print_internal (lcobj->id, printcharfun, escapeflag); + UNGCPRO; + write_c_string (")", printcharfun); + } + else + { + write_c_string ("#genre)), + printcharfun); + write_c_string (":", printcharfun); + write_c_string (concord_genre_get_name (lcobj->genre), printcharfun); + write_c_string (";", printcharfun); + GCPRO2 (obj, printcharfun); + print_internal (lcobj->id, printcharfun, escapeflag); + UNGCPRO; + write_c_string ("\">", printcharfun); + } } static void @@ -404,42 +419,90 @@ DEFINE_LRECORD_IMPLEMENTATION ("concord_object", concord_object, concord_object_description, Lisp_CONCORD_Object); -DEFUN ("concord-make-object", - Fconcord_make_object, 1, 3, 0, /* +static Lisp_Object +concord_genre_cache_get_object (Lisp_Object genre, Lisp_Object id) +{ + Lisp_Object obj_hash; + + obj_hash = Fgethash (genre, Vconcord_genre_object_hash_table, Qunbound); + if (UNBOUNDP (obj_hash)) + return Qunbound; + return Fgethash (id, obj_hash, Qunbound); +} + +static Lisp_Object +concord_genre_cache_put_object (Lisp_Object genre, Lisp_Object id, + Lisp_Object object) +{ + Lisp_Object obj_hash; + + obj_hash = Fgethash (genre, Vconcord_genre_object_hash_table, Qunbound); + if (UNBOUNDP (obj_hash)) + { + obj_hash + = make_lisp_hash_table (256, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + Fputhash (genre, obj_hash, Vconcord_genre_object_hash_table); + } + return Fputhash (id, object, obj_hash); +} + +DEFUN ("concord-make-object", Fconcord_make_object, 1, 3, 0, /* Make and return a Concord-object from ID and GENRE. Optional argument DS specifies the data-source of the GENRE. */ - (id, genre, ds)) + (genre, id, ds)) { Lisp_CONCORD_DS* lds; - char* genre_name; + Lisp_Object genre_string; + char* genre_name_str; CONCORD_Genre c_genre; Lisp_CONCORD_Object* lcobj; Lisp_Object retval; + if (!NILP (id)) + { + retval = concord_genre_cache_get_object (genre, id); + if (!UNBOUNDP (retval)) + { + return retval; + } + } if (NILP (ds)) ds = Fconcord_genre_ds (genre); CHECK_CONCORD_DS (ds); lds = XCONCORD_DS (ds); if (lds->ds == NULL) return Qnil; - if ( !STRINGP(genre) ) - genre = Fsymbol_name (genre); - TO_EXTERNAL_FORMAT (LISP_STRING, genre, - C_STRING_ALLOCA, genre_name, + if ( STRINGP(genre) ) + genre_string = genre; + else + genre_string = Fsymbol_name (genre); + TO_EXTERNAL_FORMAT (LISP_STRING, genre_string, + C_STRING_ALLOCA, genre_name_str, Qfile_name); - c_genre = concord_ds_get_genre (lds->ds, genre_name); + c_genre = concord_ds_get_genre (lds->ds, genre_name_str); if (c_genre == NULL) return Qnil; lcobj = allocate_concord_object (); lcobj->genre = c_genre; lcobj->id = id; XSET_CONCORD_OBJECT (retval, lcobj); + if (!NILP (id)) + { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + GCPRO4 (retval, id, genre, ds); + concord_genre_cache_put_object (genre, id, retval); +#if 1 + if (!EQ (Fconcord_object_get (retval, Q_id), id)) + Fconcord_object_put (retval, Q_id, id); +#endif + UNGCPRO; + } return retval; } -DEFUN ("concord-object-p", - Fconcord_object_p, 1, 1, 0, /* +DEFUN ("concord-object-p", Fconcord_object_p, 1, 1, 0, /* Return t if OBJECT is a concord-object. */ (object)) @@ -447,8 +510,7 @@ Return t if OBJECT is a concord-object. return CONCORD_OBJECT_P (object) ? Qt : Qnil; } -DEFUN ("concord-object-id", - Fconcord_object_id, 1, 1, 0, /* +DEFUN ("concord-object-id", Fconcord_object_id, 1, 1, 0, /* Return an id of Concord-object OBJECT. */ (object)) @@ -457,8 +519,7 @@ Return an id of Concord-object OBJECT. return XCONCORD_OBJECT_ID (object); } -DEFUN ("concord-decode-object", - Fconcord_decode_object, 2, 4, 0, /* +DEFUN ("concord-decode-object", Fconcord_decode_object, 2, 4, 0, /* Make and return a Concord-object from FEATURE and VALUE. Optional argument GENRE specifies the GENRE of the object. Optional argument DS specifies the data-source of the GENRE. @@ -475,6 +536,7 @@ Optional argument DS specifies the data-source of the GENRE. CONCORD_String_Tank st_id; int status; Lisp_Object obj; + int previous_print_readably; struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; if (NILP (ds)) @@ -505,16 +567,21 @@ Optional argument DS specifies the data-source of the GENRE. return Qnil; } + previous_print_readably = print_readably; + print_readably = 1; GCPRO5 (feature, value, genre, ds, value_string); value_string = Fprin1_to_string (value, Qnil); UNGCPRO; + print_readably = previous_print_readably; TO_EXTERNAL_FORMAT (LISP_STRING, value_string, C_STRING_ALLOCA, strid, Qfile_name); status = concord_index_strid_get_obj_string (c_index, strid, &st_id); if (!status) { - GCPRO3 (genre, ds, obj); + Lisp_Object retval; + + GCPRO4 (genre, ds, obj, retval); #if 0 obj = read_from_c_string (CONCORD_String_data (&st_id), CONCORD_String_size (&st_id) ); @@ -525,19 +592,20 @@ Optional argument DS specifies the data-source of the GENRE. Qfile_name), Qnil, Qnil)); #endif + retval = Fconcord_make_object (genre, obj, ds); UNGCPRO; - return Fconcord_make_object (obj, genre, ds); + return retval; } return Qnil; } -DEFUN ("concord-object-get", - Fconcord_object_get, 2, 2, 0, /* +DEFUN ("concord-object-get", Fconcord_object_get, 2, 2, 0, /* Return the value of OBJECT's FEATURE. */ (object, feature)) { struct gcpro gcpro1, gcpro2; + int previous_print_readably; Lisp_Object obj_string; char* c_obj; CONCORD_Genre c_genre; @@ -549,9 +617,12 @@ Return the value of OBJECT's FEATURE. CHECK_CONCORD_OBJECT (object); if ( !STRINGP(feature) ) feature = Fsymbol_name (feature); + previous_print_readably = print_readably; + print_readably = 1; GCPRO2 (object, feature); obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil); UNGCPRO; + print_readably = previous_print_readably; TO_EXTERNAL_FORMAT (LISP_STRING, obj_string, C_STRING_ALLOCA, c_obj, Qfile_name); c_genre = XCONCORD_OBJECT_GENRE(object); @@ -577,13 +648,12 @@ Return the value of OBJECT's FEATURE. return Qnil; } -DEFUN ("concord-object-put", - Fconcord_object_put, 3, 3, 0, /* -Store a VALUE of OBJECT's FEATURE. -*/ - (object, feature, value)) +static Lisp_Object +concord_object_put (Lisp_Object object, Lisp_Object feature, + Lisp_Object value) { struct gcpro gcpro1, gcpro2, gcpro3; + int previous_print_readably; Lisp_Object obj_string; char* c_obj; CONCORD_Genre c_genre; @@ -593,12 +663,14 @@ Store a VALUE of OBJECT's FEATURE. Lisp_Object value_string; char* c_value; - CHECK_CONCORD_OBJECT (object); if ( !STRINGP(feature) ) feature = Fsymbol_name (feature); + previous_print_readably = print_readably; + print_readably = 1; GCPRO3 (object, feature, value); obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil); UNGCPRO; + print_readably = previous_print_readably; TO_EXTERNAL_FORMAT (LISP_STRING, obj_string, C_STRING_ALLOCA, c_obj, Qfile_name); c_genre = XCONCORD_OBJECT_GENRE(object); @@ -610,9 +682,12 @@ Store a VALUE of OBJECT's FEATURE. { return Qnil; } + previous_print_readably = print_readably; + print_readably = 1; GCPRO3 (object, feature, value); value_string = Fprin1_to_string (value, Qnil); UNGCPRO; + print_readably = previous_print_readably; TO_EXTERNAL_FORMAT (LISP_STRING, value_string, C_STRING_ALLOCA, c_value, Qfile_name); @@ -623,6 +698,94 @@ Store a VALUE of OBJECT's FEATURE. status = chise_feature_sync (c_feature); if (status) return Qnil; + if (XSTRING_DATA(feature)[0] == '=') + { + CONCORD_INDEX c_index + = concord_genre_get_index (c_genre, feature_name); + + concord_index_strid_put_obj (c_index, c_value, c_obj); + concord_index_sync (c_index); + } + return Qt; +} + +DEFUN ("concord-object-put", Fconcord_object_put, 3, 3, 0, /* +Store a VALUE of OBJECT's FEATURE. +*/ + (object, feature, value)) +{ + Lisp_String* name; + Bufbyte *name_str; + + CHECK_CONCORD_OBJECT (object); + CHECK_SYMBOL (feature); + name = symbol_name (XSYMBOL (feature)); + name_str = string_data (name); + if ( NILP (concord_object_put (object, feature, value)) ) + return Qnil; + if ( EQ (feature, Q_subsumptive) || + EQ (feature, Q_subsumptive_from) || + EQ (feature, Q_denotational) || + EQ (feature, Q_denotational_from) || + ( ( ((name_str[0] == '-') && (name_str[1] == '>')) || + ((name_str[0] == '<') && (name_str[1] == '-')) ) + && (memchr (name_str, '*', name->size) == NULL) ) ) + { + Lisp_Object rest = value; + Lisp_Object ret; + Lisp_Object rev_feature = Qnil; + struct gcpro gcpro1; + + GCPRO1 (rev_feature); + if (EQ (feature, Q_subsumptive)) + rev_feature = Q_subsumptive_from; + else if (EQ (feature, Q_subsumptive_from)) + rev_feature = Q_subsumptive; + else if (EQ (feature, Q_denotational)) + rev_feature = Q_denotational_from; + else if (EQ (feature, Q_denotational_from)) + rev_feature = Q_denotational; + else + { + Bytecount length = string_length (name); + Bufbyte *rev_name_str = alloca (length + 1); + + memcpy (rev_name_str + 2, name_str + 2, length - 2); + if (name_str[0] == '<') + { + rev_name_str[0] = '-'; + rev_name_str[1] = '>'; + } + else + { + rev_name_str[0] = '<'; + rev_name_str[1] = '-'; + } + rev_name_str[length] = 0; + rev_feature = intern (rev_name_str); + } + + while (CONSP (rest)) + { + ret = XCAR (rest); + + if ( CONCORD_OBJECT_P (ret) && !EQ (ret, object) ) + { + Lisp_Object ffv; + + ffv = Fconcord_object_get (ret, rev_feature); + if (!CONSP (ffv)) + concord_object_put (ret, rev_feature, list1 (object)); + else if (NILP (Fmemq (object, ffv))) + concord_object_put + (ret, rev_feature, + nconc2 (Fcopy_sequence (ffv), list1 (object))); + Fsetcar (rest, ret); + } + rest = XCDR (rest); + } + UNGCPRO; + } return Qt; } @@ -671,11 +834,15 @@ Return the spec of OBJECT. char* c_obj; CONCORD_Genre c_genre; struct gcpro gcpro1, gcpro2; + int previous_print_readably; CHECK_CONCORD_OBJECT (object); + previous_print_readably = print_readably; + print_readably = 1; GCPRO1 (object); obj_string = Fprin1_to_string (XCONCORD_OBJECT_ID(object), Qnil); UNGCPRO; + print_readably = previous_print_readably; TO_EXTERNAL_FORMAT (LISP_STRING, obj_string, C_STRING_ALLOCA, c_obj, Qfile_name); c_genre = XCONCORD_OBJECT_GENRE(object); @@ -690,6 +857,31 @@ Return the spec of OBJECT. return concord_object_spec_closure->spec; } +DEFUN ("concord-define-object", Fconcord_define_object, 2, 3, 0, /* +Define an object of which spec is a set of features SPEC. +*/ + (spec, genre, ds)) +{ + Lisp_Object id = Fcdr (Fassq (Q_id, spec)); + Lisp_Object obj; + + if (!NILP (id)) + { + Lisp_Object rest = spec; + Lisp_Object cell; + + obj = Fconcord_make_object (genre, id, ds); + while (!NILP (rest)) + { + cell = Fcar (rest); + Fconcord_object_put (obj, Fcar (cell), Fcdr (cell)); + rest = Fcdr (rest); + } + return obj; + } + return Qnil; +} + struct closure_for_each_object { Lisp_Object function; @@ -703,6 +895,7 @@ func_for_each_object (CONCORD_String object_id, CONCORD_Feature feature, CONCORD_String value) { + struct gcpro gcpro1, gcpro2; Lisp_Object obj, val, ret; #if 0 @@ -715,8 +908,9 @@ func_for_each_object (CONCORD_String object_id, Qfile_name), Qnil, Qnil)); #endif - obj = Fconcord_make_object (obj, - for_each_object_closure->genre, + GCPRO1 (obj); + obj = Fconcord_make_object (for_each_object_closure->genre, + obj, for_each_object_closure->ds); #if 0 val = read_from_c_string (CONCORD_String_data (value), @@ -728,7 +922,10 @@ func_for_each_object (CONCORD_String object_id, Qfile_name), Qnil, Qnil)); #endif + UNGCPRO; + GCPRO2 (obj, val); ret = call2 (for_each_object_closure->function, obj, val); + UNGCPRO; for_each_object_closure->ret = ret; return !NILP (ret); } @@ -742,6 +939,7 @@ When the FUNCTION returns non-nil, it breaks the repeat. */ (function, feature, genre, ds)) { + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; Lisp_CONCORD_DS* lds; char* genre_name; CONCORD_Genre c_genre; @@ -778,7 +976,12 @@ When the FUNCTION returns non-nil, it breaks the repeat. for_each_object_closure->genre = genre; for_each_object_closure->ds = ds; for_each_object_closure->ret = Qnil; + GCPRO4 (for_each_object_closure->function, + for_each_object_closure->genre, + for_each_object_closure->ds, + for_each_object_closure->ret); concord_feature_foreach_obj_string (c_feature, func_for_each_object); + UNGCPRO; /* return Qt; */ return for_each_object_closure->ret; } @@ -800,6 +1003,8 @@ concord_name_validate (Lisp_Object keyword, Lisp_Object value, static int concord_object_validate (Lisp_Object data, Error_behavior errb) { + struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object retval; Lisp_Object valw = Qnil; Lisp_Object genre = Qnil; Lisp_Object oid = Qnil; @@ -831,7 +1036,10 @@ concord_object_validate (Lisp_Object data, Error_behavior errb) return 0; } - if (NILP (Fconcord_make_object (oid, genre, Qnil))) + GCPRO3 (genre, oid, retval); + retval = Fconcord_make_object (genre, oid, Qnil); + UNGCPRO; + if (NILP (retval)) { maybe_signal_simple_error_2 ("No such Concord-object", oid, genre, Qconcord_object, errb); @@ -844,9 +1052,15 @@ concord_object_validate (Lisp_Object data, Error_behavior errb) static Lisp_Object concord_object_instantiate (Lisp_Object data) { - return Fconcord_make_object (Fplist_get (data, Q_id, Qnil), - Fplist_get (data, Qgenre, Qnil), - Qnil); + struct gcpro gcpro1, gcpro2; + Lisp_Object retval; + + GCPRO2 (data, retval); + retval = Fconcord_make_object (Fplist_get (data, Qgenre, Qnil), + Fplist_get (data, Q_id, Qnil), + Qnil); + UNGCPRO; + return retval; } @@ -879,6 +1093,7 @@ syms_of_concord (void) DEFSUBR (Fconcord_decode_object); DEFSUBR (Fconcord_object_get); DEFSUBR (Fconcord_object_put); + DEFSUBR (Fconcord_define_object); DEFSUBR (Fconcord_object_spec); DEFSUBR (Fconcord_foreach_object_in_feature); } @@ -908,4 +1123,8 @@ vars_of_concord (void) staticpro (&Vconcord_genre_hash_table); Vconcord_genre_hash_table = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + + staticpro (&Vconcord_genre_object_hash_table); + Vconcord_genre_object_hash_table + = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); }