@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)<under_accent then make_math_accent(q)
             else make_math_under_accent(q);
@z

@x
procedure make_math_accent(@!q:pointer);
label done,done1;
var p,@!x,@!y:pointer; {temporary registers for box construction}
@y
procedure horizontally_stack_into_box(@!b:pointer;@!f:internal_font_number;@!c:quarterword);
var p:pointer; {new node placed into |b|}
begin
 p:=char_box(f,c); link(p):=list_ptr(b); list_ptr(b):=p;
 width(b):=width(b)+width(p);
end;

procedure make_math_under_accent(@!q:pointer);
label done,done1,done2,done3;
var p,qq,@!x,@!y:pointer; {temporary registers for box construction}
@!a:integer; {address of lig/kern instruction}
@!c:quarterword; {accent character}
@!f:internal_font_number; {its font}
@!i,ii:four_quarters; {its |char_info|}
@!s:scaled; {amount to skew the accent to the right}
@!h:scaled; {height of character being accented}
@!delta,sep:scaled; {space to insert between accentee and accent}
@!w,v,u:scaled; {width of the accentee, not including sub/superscripts}
@!t:four_quarters;
@!m,n:integer;
@!hd:eight_bits;
begin fetch(accent_chr(q));
if char_exists(cur_i) then
  begin i:=cur_i; c:=cur_c; f:=cur_f;@/
  @<Compute under accent skew@>;
  @<Compute separation for under accent@>;
   x:=clean_box(nucleus(q),cur_style); w:=width(x); h:=height(x);
  @<Switch to a larger accent if available and appropriate@>;
  if (math_type(supscr(q))<>empty)or(math_type(subscr(q))<>empty) then
    if math_type(nucleus(q))=math_char then
      @<Swap the subscript and superscript into box |x|@>;
  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
@ @<Switch to a larger accent if available and appropriate@>=
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
@ @<Switch to a larger accent if available and appropriate@>=
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 v<w do begin
      v:=v+u; incr(n);
      if ext_mid(i)<>min_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
@ @<Compute the amount of skew@>=
s:=0;
if math_type(nucleus(q))=math_char then
  begin fetch(nucleus(q));
@y
@ @<Compute under accent skew@>=
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:

@ @<Compute separation for under accent@>=
  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:

@ @<Compute the amount of skew@>=
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
  @<Complain that the user should have said \.{\\mathaccent}@>;
tail_append(get_node(accent_noad_size));
type(tail):=accent_noad; subtype(tail):=normal;
@y
procedure math_ac;
begin if cur_cmd=accent then
  @<Complain that the user should have said \.{\\mathaccent}@>;
tail_append(get_node(accent_noad_size));
type(tail):=accent_noad; subtype(tail):=cur_chr;
@z