@x @d normal=0 {the most common case when several cases are named} @y @d normal=0 {the most common case when several cases are named} @d under_accent=2 {|subtype| of under math accents} @d nesting=1 {add this to an accent |subtype| to make it nesting} @z @x primitive("mathaccent",math_accent,0);@/ @!@:math_accent_}{\.{\\mathaccent} primitive@> @y primitive("mathaccent",math_accent,normal);@/ @!@:math_accent_}{\.{\\mathaccent} primitive@> primitive("nestingmathaccent",math_accent,normal+nesting);@/ @!@:nesting_math_accent_}{\.{\\nestingmathaccent} primitive@> primitive("mathunderaccent",math_accent,under_accent);@/ @!@:math_under_accent_}{\.{\\mathunderaccent} primitive@> primitive("nestingmathunderaccent",math_accent,under_accent+nesting);@/ @!@:nesting_math_under_accent_}{\.{\\nestingmathunderaccent} primitive@> @z @x math_accent: print_esc("mathaccent"); @y math_accent: case chr_code of normal: print_esc("mathaccent"); normal+nesting: print_esc("nestingmathaccent"); under_accent: print_esc("mathunderaccent"); under_accent+nesting:print_esc("nestingmathunderaccent"); othercases print("Unknown accent!") endcases; @z @x accent_noad: make_math_accent(q); @y accent_noad: if subtype(q); @; x:=clean_box(nucleus(q),cur_style); w:=width(x); h:=height(x); @; if (math_type(supscr(q))<>empty)or(math_type(subscr(q))<>empty) then if math_type(nucleus(q))=math_char then @; shift_amount(y):=half(w-width(y))-s; width(y):=0; p:=new_kern(sep); link(x):=p; link(p):=y; p:=new_kern(-sep-x_height(f)); link(y):=p; y:=vpack(x,natural); width(y):=w; depth(y):=depth(y)+height(y)-h; height(y):=h; info(nucleus(q)):=y; math_type(nucleus(q)):=sub_box; end; end; procedure make_math_accent(@!q:pointer); label done,done1,done2; var p,qq,@!x,@!y:pointer; {temporary registers for box construction} @z @x @!w:scaled; {width of the accentee, not including sub/superscripts} @y @!w,v,u:scaled; {width of the accentee, not including sub/superscripts} @!t:four_quarters; @!m,n:integer; @!hd:eight_bits; @z @x y:=char_box(f,c); @y @z @x @ @= loop@+ begin if char_tag(i)<>list_tag then goto done; y:=rem_byte(i); i:=char_info(f)(y); if not char_exists(i) then goto done; if char_width(f)(i)>w then goto done; c:=y; end; done: @y @ @= loop@+ begin if char_tag(i)=ext_tag then begin y:=new_null_box; type(y):=hlist_node; i:=font_info[exten_base[f]+rem_byte(i)].qqqq;@/ c:=ext_rep(i); t:=char_info(f)(c); u:=char_width(f)(t); v:=0; hd:=height_depth(t); height(y):=char_height(f)(hd); depth(y):=char_depth(f)(hd); c:=ext_bot(i); t:=char_info(f)(c); @+if c<>min_quarterword then v:=v+char_width(f)(t); c:=ext_mid(i); t:=char_info(f)(c); @+if c<>min_quarterword then v:=v+char_width(f)(t); c:=ext_top(i); t:=char_info(f)(c); @+if c<>min_quarterword then v:=v+char_width(f)(t); n:=0; if u>0 then while vmin_quarterword then v:=v+u; end; c:=ext_bot(i); if c<>min_quarterword then horizontally_stack_into_box(y,f,c); c:=ext_rep(i); for m:=1 to n do horizontally_stack_into_box(y,f,c); c:=ext_mid(i); if c<>min_quarterword then begin horizontally_stack_into_box(y,f,c); c:=ext_rep(i); for m:=1 to n do horizontally_stack_into_box(y,f,c); end; c:=ext_top(i); if c<>min_quarterword then horizontally_stack_into_box(y,f,c); goto done2; end; if char_tag(i)<>list_tag then goto done; y:=rem_byte(i); i:=char_info(f)(y); if not char_exists(i) then goto done; if char_width(f)(i)>w then goto done; c:=y; end; done: y:=char_box(f,c); done2: @z % % Here is the logic for finding the accentee: % We pass by accent_noads as long as they are of the opposite kind % or of same kind and also nesting. This logic is necessary to make % \Hat{\uhat{\hat A}} align the two hats properly. @x @ @= s:=0; if math_type(nucleus(q))=math_char then begin fetch(nucleus(q)); @y @ @= s:=0; qq:=q; if odd(subtype(q)) then while (math_type(nucleus(qq))=sub_mlist)and (type(info(nucleus(qq)))=accent_noad)and ((subtype(qq)=subtype(q))or(subtype(qq) div 2<>subtype(q) div 2)) do qq:=info(nucleus(qq)); if math_type(nucleus(qq))=math_char then begin fetch(nucleus(qq)); ii:=char_info(cur_f)(skew_char[cur_f]); if char_tag(ii)=lig_tag then begin a:=lig_kern_start(cur_f)(ii); ii:=font_info[a].qqqq; if skip_byte(ii)>stop_flag then begin a:=lig_kern_restart(cur_f)(ii); ii:=font_info[a].qqqq; end; loop@+ begin if qo(next_char(ii))=cur_c then begin if op_byte(ii)>=kern_flag then if skip_byte(ii)<=stop_flag then s:=char_kern(cur_f)(ii); goto done1; end; if skip_byte(ii)>=stop_flag then goto done1; a:=a+qo(skip_byte(ii))+1; ii:=font_info[a].qqqq; end; end; end; done1: @ @= sep:=0; ii:=i; if char_tag(ii)=lig_tag then begin a:=lig_kern_start(f)(ii); ii:=font_info[a].qqqq; if skip_byte(ii)>stop_flag then begin a:=lig_kern_restart(f)(ii); ii:=font_info[a].qqqq; end; loop@+ begin if qo(next_char(ii))=c then begin if op_byte(ii)>=kern_flag then if skip_byte(ii)<=stop_flag then sep:=char_kern(f)(ii); goto done3; end; if skip_byte(ii)>=stop_flag then goto done3; a:=a+qo(skip_byte(ii))+1; ii:=font_info[a].qqqq; end; end; done3: @ @= s:=0; qq:=q; {while odd(subtype(qq))and(math_type(nucleus(qq))=sub_mlist)and (type(info(nucleus(qq)))=accent_noad) do} if odd(subtype(q)) then while (math_type(nucleus(qq))=sub_mlist)and (type(info(nucleus(qq)))=accent_noad)and ((subtype(qq)=subtype(q))or(subtype(qq) div 2<>subtype(q) div 2)) do qq:=info(nucleus(qq)); if math_type(nucleus(qq))=math_char then begin fetch(nucleus(qq)); @z @x procedure math_ac; begin if cur_cmd=accent then @; tail_append(get_node(accent_noad_size)); type(tail):=accent_noad; subtype(tail):=normal; @y procedure math_ac; begin if cur_cmd=accent then @; tail_append(get_node(accent_noad_size)); type(tail):=accent_noad; subtype(tail):=cur_chr; @z