libga68/standard.a68.in

{ Process this file with sppp.awk  -*- mode: a68 -*- }

{ standard.a68.in - Standard prelude, a68 part.

  Copyright (C) 2026 Jose E. Marchesi

  GCC is free software; you can redistribute it and/or modify it under
  the terms of the GNU General Public License as published by the Free
  Software Foundation; either version 3, or (at your option) any later
  version.

  GCC is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  License for more details.

  Under Section 7 of GPL version 3, you are granted additional
  permissions described in the GCC Runtime Library Exception, version
  3.1, as published by the Free Software Foundation.

  You should have received a copy of the GNU General Public License
  and a copy of the GCC Runtime Library Exception along with this
  program; see the files COPYING3 and COPYING.RUNTIME respectively.
  If not, see <http://www.gnu.org/licenses/>. }

module Standard =
def
    { 10.2.1 Environment enquiries. }

    { L bits_width are implemented in compiler. }

    { 10.2.3.8.l L bitspack. }

    {iter L  {short short}  {short}  {} {long}  {long long}}
    {iter L_ {short_short_} {short_} {} {long_} {long_long_}}
    pub proc {L_}bits_pack = ([]bool a) {L} bits:
       if int n = UPB a[@1];
          n <= {L_}bits_width
       then {L} bits c := {L} 16r0;
            for i to {L_}bits_width
            do if i > {L_}bits_width - n
                  andth a[@1][i - {L_}bits_width + n]
               then c := c OR ({L} 2r1 SHL ({L_}bits_width - i)) fi
            od;
            c
       fi;
    {reti}

    { 10.3.2.1. Conversion routines. }

    mode Number = union (
                     {iter L {short short} {short} {} {long} {long long}}
                     {L} int
                     {reti {,}}
                     ,
                     {iter L {} {long} {long long}}
                     {L} real
                     {reti {,}}
                  );

    { The definition of mode Integer used by both the RR subwhole and this one.  }
    
    mode Integer = union (
                      {iter L {long long } {long } {} {short } {short short }}
                      {L}int
                      {reti {,}}
                   );
    
    { The whole_powers_of_10 row is used to look up the appropriate power of 10 for
      each integer division required to select the leading in the conversion
      process, for each integer multiplication to eliminate the leading digit,
      and in the lookup operator WHOLEDIGITS to determine the number of digits in
      the integer to be converted.  }
    
    int whole_max_entry := 1;
    long long int whole_p10 := long long 1;
    long long int whole_stop_after = long_long_max_int % long long 10;
    while whole_p10 < whole_stop_after
    do
       whole_p10 *:= long long 10;
       whole_max_entry +:= 1
    od;
    heap [1:whole_max_entry]long long int whole_powers_of_10;
    while whole_max_entry > 0
    do
       whole_powers_of_10[whole_max_entry] := whole_p10;
       whole_p10 %:= long long 10;
       whole_max_entry -:= 1
    od;
    
    { The WHOLEDIGITS operator is used to determine the number of decimal digits in a
      number.  We convert the operand to long long and make it negative if
      necessary, to allow for twos-complement minimum (negative) integer.  }
    
    op WHOLEDIGITS = (Integer number) int:
    begin
          long long int work =
             case number in
                {iter L {long long } {long } {} {short } {short short }}
                {iter K {} {LENG } {LENG LENG } {LENG LENG LENG } {LENG LENG LENG LENG }}
                ({L}int x):
                   {K}(x > {L} 0 | -x | x)
                {reti {,}}
             esac;
          int num_digits := 1;
          for i from (LWB whole_powers_of_10) + 1 to UPB whole_powers_of_10
              while work <= -whole_powers_of_10[i]
          do num_digits +:= 1 od;
          num_digits
    end { WHOLEDIGITS };
    
    { proc whole checks for a too-small width, returning a string of the error
      character if so; it left-pads the result with blanks as necessary and the
      sign as necessary; and it relies on subwhole to do the actual digit
      conversion.  The [] result returned is either exactly the number of chars
      needed (width = 0) to hold the converted integer and negative sign if < 0
      or width characters (width ≠ 0).  }
    
    
    pub proc whole = (Number v, int width) string:
       case v in
          {iter L {long long } {long } {} {short } {short short }}
          ({L}int x):
             if int digits_required = WHOLEDIGITS x;
                bool negative = x < {L}0;
                int signs_required = (negative OR width > 0 | 1 | 0);
                int chars_required = signs_required + digits_required;
                int chars_available = (width = 0 | chars_required | ABS width);
                chars_available < chars_required
             then chars_available * "*"
             else [1:chars_available]char buffer;
                  int spaces_required = chars_available - chars_required;
                  int buf_ch := 1;
                  while buf_ch <= spaces_required
                  do buffer[buf_ch] := " ";
                     buf_ch +:= 1
                  od;
                  if signs_required > 0
                  then buffer[buf_ch] := (negative | "-" | "+");
                       buf_ch +:= 1
                  fi;
                  subwhole(x, buffer, buf_ch);
                  buffer
             fi
          {reti {,}}
       out
          fixed(v, width, 0)
       esac { whole };


    pub proc fixed = (Number v, int width, after) string:
       case v in
          {iter L {} {long} {long long}}
          ({L} real x):
             if int length := ABS width - (x < {L} 0 OR width > 0 | 1 | 0);
                after >= 0 AND (length > after OR width = 0)
             then {L} real y = ABS x;
                  if width = 0
                  then length := (after = 0 | 1 | 0);
                       while y + {L} .5 * {L} .1 ** after >= {L} 10 ** length
                       do length +:= 1 od;
                       length +:= (after = 0 | 0 | after + 1)
                  fi;
                  string s := subfixed (y, length, after);
                  if ~char_in_string (errorchar, loc int, s)
                  then (length > UPB s AND y < {L} 1.0 | "0" +=: s);
                       (x < {L} 0 | "-" |: width > 0 | "+" | "") +=: s;
                       (width /= 0 | (ABS width - UPB s) * " " +=: s);
                       s
                  elif after > 0
                  then fixed (v, width, after - 1)
                  else ABS width * errorchar
                  fi
             else { XXX undefined } skip; ABS width * errorchar
             fi,
          ({L} int x): fixed ({L} real (x), width, after)
          {reti {,}}
       esac;

    pub proc float = (Number v, int width, after, exp) string:
        case v in
           {iter L  {} {long}  {long long}}
           {iter L_ {} {long_} {long_long_}}
           {iter S  {} {LENG}  {LENG LENG}}
           ({L} real x):
              if int before = ABS width - ABS exp - (after /= 0 | after+1 | 0) - 2;
                 SIGN before + SIGN after > 0
              then string s, {L} real y := ABS x, int p := 0;
                   {L_}standardize (y, before, after, p);
                   s := fixed ({S} SIGN x * y, SIGN width * (ABS width - ABS exp - 1),
                               after) + "e" + whole (p, exp);
                   if exp = 0 OR char_in_string (errorchar, loc int, s)
                   then float (x, width, (after /= 0 | after-1 | 0),
                               (exp > 0 | exp+1 | exp-1))
                   else s
                   fi
              else { XXX undefined } skip; ABS width * errorchar
              fi
           {reti {,}}
           ,
           {iter L {short short} {short} {} {long} {long long}}
           {iter R {LENG LENG} {LENG} {} {} {}}
           ({L} int x): float ({L} real ({R} x), width, after, exp)
           {reti {,}}
        esac;

    { The RR proc subwhole looks like
    
      proc ℵ₀ subwhole = (number v, int width) string: { implementation };
    
      We deviate from that design below.  This means that, should someone copy
      proc putf from the RR, they must recognize that the subwhole mentioned
      there is no longer defined here, and make adjustments.
    
      I considered calling this subwhole something else (whole_do_conv for example)
      but that would mean anyone else calling subwhole hoping to get the new
      version would silently get the old subwhole instead.
    
      This subwhole converts digit by digit from left to right.  It relies on the
      caller having padded out the buffer with spaces and sign as required and
      begins filling digits starting at the value passed in buf_ch.  The final
      []char array and final value of buf_ch are returned.  }
    
    proc subwhole = (Integer v, ref []char buffer, ref int buf_ch) void:
       case int char_zero = ABS "0"; v in
          {iter L {long long } {long } {} {short } {short short }}
          {iter K {LENG LENG } {LENG } {} {SHORTEN } {SHORTEN SHORTEN }}
          {iter S {SHORTEN SHORTEN } {SHORTEN } {} {LENG } {LENG LENG }}k
          {iter T {} {SHORTEN } {SHORTEN SHORTEN } {SHORTEN SHORTEN SHORTEN } {SHORTEN SHORTEN SHORTEN SHORTEN }}
          ({L}int number_to_convert):
          begin {L}int work := number_to_convert;
                while buf_ch <= UPB buffer
                do int digit_number = UPB buffer - buf_ch + 1;
                   {L}int p10 = {T}whole_powers_of_10[digit_number];
                   int digit = {S} (work % p10);
                   buffer[buf_ch] := REPR (ABS digit + char_zero);
                   buf_ch +:= 1;
                   work -:= {K}digit * p10
                od
          end
          {reti {,}}
       esac { subwhole };

    { Returns a string of maximum length `width' containing a rounded
      decimal representation of the positive real number `v'; if
      `after' is greater than zero, this string contains a decimal
      point followed by `after' digits. }

    proc subfixed = (Number v, int width, after) string:
       case v in
          {iter L {} {long}    {long long}}
          {iter K {} {LENG}    {LENG LENG}}
          {iter S {} {SHORTEN} {SHORTEN SHORTEN}}
          ({L} real x):
             begin string s, int before := 0;
                   {L} real y := x + {L} .5 * {L} .1 ** after;
                   proc choosedig = (ref {L} real y) char:
                      dig_char ((int c := {S} ENTIER (y *:= {L} 10.0); (c > 9 | c := 9);
                                 y -:= {K} c; c));
                   while y >= {L} 10.0 ** before do before +:= 1 od;
                   y /:= {L} 10.0 ** before;
                   to before do s +:= choosedig (y) od;
                   (after > 0 | s +:= ".");
                   to after do s +:= choosedig (y) od;
                   (UPB s > width | width * errorchar | s)
             end
           {reti {,}}
       esac;

    { Adjusts the value of `y' so that it may be transput according to
      the format $ n(before)d, n(after)d $; `p' is set so that y * 10
      ** p is equal to the original value of `y'.  }

    {iter L  {} {long}  {long long}}
    {iter L_ {} {long_} {long_long_}}
    proc {L_}standardize = (ref {L} real y, int before, after, ref int p) void:
    begin
          {L} real g = {L} 10.0 ** before; {L} real h = g * {L} .1;
          while y >= g do y *:= {L} .1; p +:= 1 od;
          (y /= {L} 0.0 | while y  < h do y *:= {L} 10.0; p -:= 1 od);
          (y + {L} .5 * {L} .1 ** after >= g | y := h; p +:= 1)
    end;
    {reti}

    proc dig_char = (int x) char: "0123456789abcdef"[x+1];

    { Returns true if the absolute value of the result is
      <= L max int }

    {iter L  {short short}     {short}   {} {long} {long long}}
    {iter K  {SHORTEN SHORTEN} {SHORTEN} {} {LENG} {LENG LENG}}
    {iter L_ {short_short_} {short_} {} {long_}   {long_long_}}
    proc string_to_{L_}int = (string s, int radix, ref {L} int i) bool:
     begin
          {L} int lr = {K} radix; bool safe := true;
          {L} int n := {L} 0, {L} int m = {L_}max_int % lr;
          {L} int m1 = {L_}max_int - m * lr;
          for i from 2 to UPB s
          while {L} int dig = {K} char_dig (s[i]);
                safe := n < m OR n = m AND dig <= m1
          do n := n * lr + dig od;
          if safe then i := (s[1] = "+" | n | -n); true else false fi
    end;
    {reti}

    { Returns true if the absolute value of the result is <= L max
      real.  }

    {iter L  {} {long}  {long long}}
    {iter K  {} {LENG}  {LENG LENG}}
    {iter S  {} {SHORTEN} {SHORTEN SHORTEN}}
    {iter L_ {} {long_} {long_long_}}
    pub proc string_to_{L_}real = (string s, ref {L} real r) bool:
    begin
          int e := UPB s + 1;
          char_in_string ("^" { XXX unicode 10^ }, e, s);
          int p := e; char_in_string (".", p, s);
          int j := 1, length := 0, {L} real x := {L} 0.0;
          { Skip leading zeroes:  }
          for i from 2 to e - 1
          while s[i] = "0" OR s[i] = "." OR s[i] = "_."
          do j := i od;
          for i from j + 1 to e - 1 while length < {L_}real_width
          do
             if s[i] /= "."
             then x := x * {L} 10.0 + {K} char_dig (s[j:=i]); length +:= 1
             fi { all significant digits converted.  }
          od;
          { Set preliminary exponent:  }
          int exp := (p > j | p - j - 1 | p - j), expart := 0;
          { Convert exponent part: }
          bool safe := if e < UPB s
                       then {L} int tmp := {K} expart;
                            bool b = string_to_{L_}int (s[e+1:], 10, tmp);
                            expart = {S} tmp;
                            b
                       else true
                       fi;
          { Prepare a representation of L max real to compare with the L
                real value to be delivered: }
          {L} real max_stag := {L_}max_real, int max_exp := 0;
          {L_}standardize (max_stag, length, 0, max_exp); exp +:= expart;
          if ~safe OR (exp > max_exp OR exp = max_exp AND x > max_stag)
          then false
          else r := (s[1] = "+" | x | -x) * {L} 10.0 ** exp; true
          fi
    end;
    {reti}

    proc char_dig = (char x) int:
       (x = "." | 0 | int i; char_in_string (x,i,"0123456789abcdef"); i-1);

    pub proc char_in_string = (char c, ref int i, string s) bool:
    begin bool found := false;
          for k from LWB s to UPB s while ~found
          do (c = s[k] | i := k; found := true) od;
          found
    end;

    { The smallest integral value such that `L max int' may be
      converted without error using the pattern n(L int width)d }

    {iter L  {short short}  {short}  {} {long}  {long long}}
    {iter L_ {short_short_} {short_} {} {long_} {long_long_}}
    pub int {L_}int_width =
       (int c := 1; while {L} 10 ** (c - 1) < {L_}max_int % {L} 10 do c +:= 1 od;
        c);
    {reti}

    { The smallest integral value such that different string are
      produced by conversion of `1.0' and of `1.0 + L small real'
      using the pattern d .n(L real width - 1)d  }

    {iter L  {} {long} {long long}}
    {iter L_ {} {long_} {long_long_}}
    {iter S  {} {SHORTEN} {SHORTEN SHORTEN}}
    pub int {L_}real_width = 1 - {S} ENTIER ({L_}ln ({L_}small_real) / {L_}ln ({L} 10));
    {reti}

    { The smallest integral value such that `L max real' may be
      converted without error using the pattern
      d .n(L real width - 1)d e n(L exp with)d }

    {iter L  {} {long} {long long}}
    {iter L_ {} {long_} {long_long_}}
    {iter S  {} {SHORTEN} {SHORTEN SHORTEN}}
    pub int {L_}exp_width =
       1 + {S} ENTIER ({L_}ln ({L_}ln ({L_}max_real) / {L_}ln ({L} 10)) / {L_}ln ({L} 10));
    {reti}

    skip
fed