1.1 --- a/src/sml/ME/ctree.sml	Sat Mar 05 14:36:49 2005 +0100
     1.2 +++ b/src/sml/ME/ctree.sml	Sat Mar 05 17:26:21 2005 +0100
     1.3 @@ -1231,6 +1231,8 @@
     1.4    | update_loc pt (p,_) x = 
     1.5      let val (_,lres) = get_obj g_loc pt p
     1.6      in appl_obj (repl_loc (Some x,lres)) pt p end;
     1.7 +(*WN050305 for handling cut_tree in cappend_atomic -- TODO redesign !*)
     1.8 +fun update_loc' pt p iss = appl_obj (repl_loc iss) pt p;
     1.9  
    1.10  (*13.8.02---------------------------
    1.11  fun get_loc EmptyPtree _ = None
    1.12 @@ -1824,7 +1826,7 @@
    1.13  	    in cut_levup (cuts @ cuts') clevup' pt pt'' (P, p) (get_nd pt P)
    1.14  	    end
    1.15      end;
    1.16 -
    1.17 + 
    1.18  
    1.19  fun cut_tree pt (pos,_) =
    1.20      if not (existpt pos pt) 
    1.21 @@ -1870,14 +1872,39 @@
    1.22    apfst (append_atomic p loc f r f' s) (cut_tree pt (p,Frm))
    1.23  );
    1.24  fun cappend_atomic pt p loc f r f' s = 
    1.25 -let val _= writeln("##@cappend_atomic: pos ="^pos2str p)
    1.26 -    val _= writeln("##@cappend_atomic before cut_tree: loc ="^istate2str loc)
    1.27 -    val (pt', cs) = cut_tree pt (p,Frm)
    1.28 +let val _= writeln("##@cappend_atomic: pos ="^pos2str p);
    1.29 +    val _= writeln("##@cappend_atomic arg loc ="^istate2str loc);
    1.30 +    val _= if existpt  p pt
    1.31 +	   then writeln("##@cappend_atomic before cut_ loc ="^
    1.32 +			istates2str (get_obj g_loc pt p))
    1.33 +	   else  writeln("##@cappend_atomic pos not existent before cut_");
    1.34 +    val (pt', cs) = cut_tree pt (p,Frm);
    1.35 +    val _= if existpt  p pt'
    1.36 +	   then writeln("##@cappend_atomic after cut_ loc ="^
    1.37 +		   istates2str (get_obj g_loc pt' p))
    1.38 +	   else  writeln("##@cappend_atomic pos not existent after cut_");
    1.39 +    val pt'' = append_atomic p loc f r f' s pt';
    1.40 +    val _= writeln("##@cappend_atomic after append: loc ="^
    1.41 +		   istates2str (get_obj g_loc pt'' p));
    1.42 +in (pt'', cs) end;
    1.43 +
    1.44 +fun cappend_atomic pt p loc f r f' s = 
    1.45 +let val (pt', cs) = cut_tree pt (p,Frm)
    1.46      val pt'' = append_atomic p loc f r f' s pt'
    1.47 -    val _= writeln("##@cappend_atomic after append: loc ="^
    1.48 -		   istates2str (get_obj g_loc pt'' p))
    1.49  in (pt'', cs) end;
    1.50  
    1.51 +fun cappend_atomic pt p ist_res f r f' s = 
    1.52 +    if existpt p pt andalso get_obj g_tac pt p=Empty_Tac
    1.53 +    then (*after Take: transfer Frm and respective istate*)
    1.54 +	let val (ist_form, f) = (get_loc pt (p,Frm), 
    1.55 +				 get_obj g_form pt p)
    1.56 +	    val (pt, cs) = cut_tree pt (p,Frm)
    1.57 +	    val pt = append_atomic p e_istate f r f' s pt
    1.58 +	    val pt = update_loc' pt p (Some ist_form, Some ist_res)
    1.59 +	in (pt, cs) end
    1.60 +    else apfst (append_atomic p ist_res f r f' s) (cut_tree pt (p,Frm));
    1.61 +
    1.62 +
    1.63  (* called by Take *)
    1.64  fun append_form p l f pt = 
    1.65  (writeln("##@append_form: pos ="^pos2str p);