TeX's vpackage subroutine

vpackage.p

function vpackage(p: pointer; h: scaled; m: small_number; l: scaled): pointer;
      label common_ending, exit;
      var r: pointer; {the box node that will be returned}
      w, d, x: scaled; {width, depth, and natural height}
      s: scaled; {shift amount}
      g: pointer; {points to a glue specification}
      o: glue_ord; {order of infinity}
      begin
        last_badness := 0;
        r := get_node(box_node_size);                                        {function}
        type(r) := vlist_node;                                               {macro}
        subtype(r) := min_quarterword;                                       {macro}
        shift_amount(r) := 0;                                                {macro}
        list_ptr(r) := p;                                                    {macro}
        w := 0;
        d := 0;
        x := 0;
        total_stretch[normal] := 0;
        total_shrink[normal] := 0;
        total_stretch[fil] := 0;
        total_shrink[fil] := 0;
        total_stretch[fill] := 0;
        total_shrink[fill] := 0;
        total_stretch[filll] := 0;
        total_shrink[filll] := 0
        while p <> null do begin
          if is_char_node(p) then                                            {macro}
            confusion("vpack")                                               {procedure}
          else
            case type(p) of                                                  {macro}
              hlist_node, vlist_node, rule_node, unset_node:
                begin
                  x := x + d + height(p);                                    {macro}
                  d := depth(p);                                             {macro}
                  if type(p) >= rule_node then                               {macro}
                    s := 0
                  else
                    s := shift_amount(p);                                    {macro}
                  if width(p) + s > w then                                   {macro}
                    w := width(p) + s;                                       {macro}
                end
              whatsit_node:
                {empty statement}
              glue_node:
                begin
                  x := x + d;
                  d := 0;
                  g := glue_ptr(p);                                          {macro}
                  x := x + width(g);                                         {macro}
                  o := stretch_order(g);                                     {macro}
                  total_stretch[o] := total_stretch[o] + stretch(g);         {macro}
                  o := shrink_order(g);                                      {macro}
                  total_shrink[o] := total_shrink[o] + shrink(g);            {macro}
                  if subtype(p) >= a_leaders then begin                      {macro}
                    g := leader_ptr(p);                                      {macro}
                    if width(g) > w then                                     {macro}
                      w := width(g);                                         {macro}
                  end;
                end
              kern_node:
                begin
                  x := x + d + width(p);                                     {macro}
                  d := 0;
                end;
              othercases
                {empty statement}
            endcases;
          p := link(p);                                                      {macro}
        end
        width(r):=w;                                                         {macro}
        if d > l then begin
          x := x + d - l;
          depth(r) := l;                                                     {macro}
        end
        else
          depth(r) := d;                                                     {macro}
        if m = additional then
          h := x + h;
        height(r) := h;                                                      {macro}
        x := h - x; {now x is the excess to be made up}
        if x = 0 then begin
          glue_sign(r) := normal;                                            {macro}
          glue_order(r) := normal;                                           {macro}
          set_glue_ratio_zero(glue_set(r));                                  {macros}
          return;
        end
        else if x > 0 then begin
          if total_stretch[filll] <> 0 then
            o := filll
          else if total_stretch[fill] <> 0 then
            o := fill
          else if total_stretch[fil] <> 0 then
            o:=fil
          else
            o := normal
          glue_order(r) := o;                                                {macro}
          glue_sign(r) := stretching;                                        {macro}
          if total_stretch[o] <> 0 then
            glue_set(r) := unfloat(x/total_stretch[o])                       {macros}
          else begin
            glue_sign(r) := normal;                                          {macro}
            set_glue_ratio_zero(glue_set(r)); {there's nothing to stretch}   {macros}
          end;
          if o = normal then
            if list_ptr(r) <> null then begin                                {macro}
              last_badness := badness(x, total_stretch[normal]);             {function}
              if last_badness > vbadness then begin
                print_ln;                                                    {procedure}
                if last_badness > 100 then
                  print_nl("Underfull")                                      {procedure}
                else
                  print_nl("Loose");                                         {procedure}
                print(" \vbox (badness ");                                   {procedure}
                print_int(last_badness);                                     {procedure}
                goto common_ending;
              end;
            end
          return;
        end
        else begin
          if total_shrink[filll] <> 0 then
            o := filll
          else if total_shrink[fill] <> 0 then
            o := fill
          else if total_shrink[fil] <> 0 then
            o := fil
          else
            o := normal
          glue_order(r) := o;                                                {macro}
          glue_sign(r) := shrinking;                                         {macro}
          if total_shrink[o] <> 0 then
            glue_set(r) := unfloat((-x)/total_shrink[o])                     {macros}
          else begin
            glue_sign(r) := normal;                                          {macro}
            set_glue_ratio_zero(glue_set(r)); {there's nothing to shrink}    {macros}
          end;
          if (total_shrink[o] < -x) and
             (o = normal) and
             (list_ptr(r) <> null) then begin                                {macro}
            last_badness := 1000000;
            set_glue_ratio_one(glue_set(r)); {use the maximum shrinkage}     {macros}
            if (-x-total_shrink[normal] > vfuzz) or
               (vbadness < 100) then begin
              print_ln;                                                      {procedure}
              print_nl("Overfull \vbox (");                                  {procedure}
              print_scaled(-x-total_shrink[normal]);                         {procedure}
              print("pt too high");                                          {procedure}
              goto common_ending;
            end
          end
          else if o = normal then
            if list_ptr(r) <> null then begin                                {macro}
              last_badness := badness(-x,total_shrink[normal]);              {function}
              if last_badness > vbadness then begin
                print_ln;                                                    {procedure}
                print_nl("Tight \vbox (badness ");                           {procedure}
                print_int(last_badness);                                     {procedure}
                goto common_ending;
              end;
            end
          return;
        end
    common_ending:
        if output_active then
          print(") has occurred while \output is active")                    {procedure}
        else begin
          if pack_begin_line <> 0 then begin {it's actually negative}
            print(") in alignment at lines ");                               {procedure}
            print_int(abs(pack_begin_line));                                 {procedure}
            print("--");                                                     {procedure}
          end
          else
            print(") detected at line ");                                    {procedure}
          print_int(line);                                                   {procedure}
          print_ln;                                                          {procedure}
        end;
        begin_diagnostic;                                                    {procedure}
        show_box(r);                                                         {procedure}
        end_diagnostic(true)                                                 {procedure}
    exit:
        vpackage:=r;
      end;