Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/sql/sqlddl.src

Text File | 1988-05-03 | 41.6 KB | 1,369 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--token.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
  use TEXT_IO;

package TOKEN_INPUT is

  type INPUT_STREAM is private;

  package INTEGER_IO is new TEXT_IO.INTEGER_IO(INTEGER);
    use INTEGER_IO;

  function CREATE_STREAM(CARD_LENGTH : POSITIVE) return INPUT_STREAM;

  procedure SET_STREAM(STREAM : INPUT_STREAM);

  procedure OPEN_INPUT(STREAM : INPUT_STREAM;
                       NAME   : STRING);

  procedure OPEN_INPUT(NAME : STRING);

  procedure CLOSE_INPUT(STREAM : INPUT_STREAM);

  procedure CLOSE_INPUT;

  procedure GET_STRING(STREAM : in  INPUT_STREAM;
                       STR    : out STRING;
                       LAST   : out NATURAL);

  procedure GET_STRING(STR  : out STRING;
                       LAST : out NATURAL);

  function GET_INTEGER(STREAM : INPUT_STREAM) return INTEGER;

  function GET_INTEGER return INTEGER;

  procedure GOBBLE(STREAM : INPUT_STREAM;
                   STR    : STRING);

  procedure GOBBLE(STR : STRING);

private

  type INPUT_RECORD(CARD_LENGTH : POSITIVE) is
    record
      BUFFER : STRING(1..CARD_LENGTH);
      FILE   : FILE_TYPE;
      NEXT   : POSITIVE := 1;
      LAST   : NATURAL := 0;
    end record;

  type INPUT_STREAM is access INPUT_RECORD;

end TOKEN_INPUT;

package body TOKEN_INPUT is

  DEFAULT_STREAM : INPUT_STREAM;

  function CREATE_STREAM(CARD_LENGTH : POSITIVE) return INPUT_STREAM is
  begin
    return new INPUT_RECORD(CARD_LENGTH);
  end CREATE_STREAM;

  procedure SET_STREAM(STREAM : INPUT_STREAM) is
  begin
    DEFAULT_STREAM := STREAM;
  end SET_STREAM;

  procedure OPEN_INPUT(STREAM : INPUT_STREAM;
                       NAME   : STRING) is
  begin
    OPEN(STREAM.FILE,IN_FILE,NAME);
  end OPEN_INPUT;

  procedure OPEN_INPUT(NAME : STRING) is
  begin
    OPEN_INPUT(DEFAULT_STREAM,NAME);
  end OPEN_INPUT;

  procedure CLOSE_INPUT(STREAM : INPUT_STREAM) is
  begin
    CLOSE(STREAM.FILE);
  end CLOSE_INPUT;

  procedure CLOSE_INPUT is
  begin
    CLOSE_INPUT(DEFAULT_STREAM);
  end CLOSE_INPUT;

  function ALPHABETIC(C : CHARACTER) return BOOLEAN is
  begin
    return C in 'A'..'Z' or else C in 'a'..'z' or else C = '_';
  end ALPHABETIC;

  function NUMERIC(C : CHARACTER) return BOOLEAN is
  begin
    return C in '0'..'9' or else C = '_';
  end NUMERIC;

  function WHITESPACE(C : CHARACTER) return BOOLEAN is
  begin
    return C = ' ' or else C = ASCII.HT;
  end WHITESPACE;

  procedure NEXT_LINE(STREAM : INPUT_STREAM) is
  begin
    loop
      GET_LINE(STREAM.FILE,STREAM.BUFFER,STREAM.LAST);
      exit when STREAM.LAST >= 2 and then STREAM.BUFFER(1..2) /= "--";
      exit when STREAM.LAST = 1;
    end loop;
    STREAM.NEXT := 1;
  end NEXT_LINE;

  procedure NEXT_TOKEN(STREAM : INPUT_STREAM) is
  begin
    loop
      if STREAM.NEXT > STREAM.LAST then
        NEXT_LINE(STREAM);
      end if;
      if STREAM.BUFFER(STREAM.NEXT) = '-' and then
          STREAM.NEXT < STREAM.LAST and then
          STREAM.BUFFER(STREAM.NEXT+1) = '-' then
        NEXT_LINE(STREAM);
      end if;
      exit when not WHITESPACE(STREAM.BUFFER(STREAM.NEXT));
      STREAM.NEXT := STREAM.NEXT + 1;
    end loop;
  end NEXT_TOKEN;

  function TOKEN_END(STREAM : INPUT_STREAM) return POSITIVE is
    C   : CHARACTER;
    PTR : POSITIVE;
  begin
    NEXT_TOKEN(STREAM);
    PTR := STREAM.NEXT;
    while PTR <= STREAM.LAST loop
      C := STREAM.BUFFER(PTR);
      exit when WHITESPACE(C);
      case STREAM.BUFFER(STREAM.NEXT) is
        when 'A'..'Z' | 'a'..'z' =>
          exit when not ALPHABETIC(C) and then not NUMERIC(C);
        when '0'..'9' | '-' | '+' =>
          exit when not NUMERIC(C);
        when others =>
          exit when ALPHABETIC(C) or else NUMERIC(C);
      end case;
      PTR := PTR + 1;
    end loop;
    return PTR - 1;
  end TOKEN_END;

  procedure GET_STRING(STREAM : in  INPUT_STREAM;
                       STR    : out STRING;
                       LAST   : out NATURAL) is
    TOKEND,
    TLAST : POSITIVE;
  begin
    TOKEND := TOKEN_END(STREAM);
    TLAST := STR'FIRST + TOKEND - STREAM.NEXT;
    STR(STR'FIRST..TLAST) := STREAM.BUFFER(STREAM.NEXT..TOKEND);
    LAST := TLAST;
    STREAM.NEXT := TOKEND + 1;
  end GET_STRING;

  procedure GET_STRING(STR  : out STRING;
                       LAST : out NATURAL) is
  begin
    GET_STRING(DEFAULT_STREAM,STR,LAST);
  end GET_STRING;

  function GET_INTEGER(STREAM : INPUT_STREAM) return INTEGER is
    TOKEND : POSITIVE;
    INT,
    LAST   : INTEGER;
  begin
    TOKEND := TOKEN_END(STREAM);
    GET(STREAM.BUFFER(STREAM.NEXT..TOKEND),INT,LAST);
    STREAM.NEXT := TOKEND + 1;
    return INT;
  end GET_INTEGER;

  function GET_INTEGER return INTEGER is
  begin
    return GET_INTEGER(DEFAULT_STREAM);
  end GET_INTEGER;

  procedure GOBBLE(STREAM : INPUT_STREAM;
                   STR    : STRING) is
    S    : STRING(1..STREAM.CARD_LENGTH);
    LAST : INTEGER;
  begin
    GET_STRING(STREAM,S,LAST);
    if S(1..LAST) /= STR then
      raise CONSTRAINT_ERROR;
    end if;
  end GOBBLE;

  procedure GOBBLE(STR : STRING) is
  begin
    GOBBLE(DEFAULT_STREAM,STR);
  end GOBBLE;

end TOKEN_INPUT;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--txtprt.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
  use TEXT_IO;

package TEXT_PRINT is

  type LINE_TYPE is limited private;

  type BREAK_TYPE is (BREAK, NO_BREAK);

  type PHANTOM_TYPE is private;

  procedure CREATE_LINE(LINE : in out LINE_TYPE; LENGTH : in POSITIVE);

  procedure SET_LINE(LINE : in LINE_TYPE);

  function CURRENT_LINE return LINE_TYPE;

  procedure SET_INDENT(LINE   : in LINE_TYPE; INDENT : in NATURAL);
  procedure SET_INDENT(INDENT : in NATURAL);

  procedure SET_CONTINUATION_INDENT(LINE   : in LINE_TYPE;
                                    INDENT : in INTEGER);
  procedure SET_CONTINUATION_INDENT(INDENT : in INTEGER);

  function MAKE_PHANTOM(S : STRING) return PHANTOM_TYPE;

  procedure SET_PHANTOMS(LINE         : in LINE_TYPE;
                         START_PHANTOM,
                         END_PHANTOM  : in PHANTOM_TYPE);

  procedure SET_PHANTOMS(START_PHANTOM, END_PHANTOM : in PHANTOM_TYPE);

  procedure PRINT(FILE : in FILE_TYPE;
                  LINE : in LINE_TYPE;
                  ITEM : in STRING;
                  BRK  : in BREAK_TYPE := BREAK);
  procedure PRINT(FILE : in FILE_TYPE;
                  ITEM : in STRING;
                  BRK  : in BREAK_TYPE := BREAK);
  procedure PRINT(LINE : in LINE_TYPE;
                  ITEM : in STRING;
                  BRK  : in BREAK_TYPE := BREAK);
  procedure PRINT(ITEM : in STRING;
                  BRK  : in BREAK_TYPE := BREAK);

  procedure PRINT_LINE(FILE : in FILE_TYPE; LINE : in LINE_TYPE);
  procedure PRINT_LINE(FILE : in FILE_TYPE);
  procedure PRINT_LINE(LINE : in LINE_TYPE);
  procedure PRINT_LINE;

  procedure BLANK_LINE(FILE : in FILE_TYPE; LINE : in LINE_TYPE);
  procedure BLANK_LINE(FILE : in FILE_TYPE);
  procedure BLANK_LINE(LINE : in LINE_TYPE);
  procedure BLANK_LINE;

  generic
    type NUM is range <>;
  package INTEGER_PRINT is

    procedure PRINT(FILE : in FILE_TYPE;
                    LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);
    procedure PRINT(FILE : in FILE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);
    procedure PRINT(LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);
    procedure PRINT(ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);

    procedure PRINT(TO : out STRING; LAST : out NATURAL; ITEM : in NUM);

  end INTEGER_PRINT;

  generic
    type NUM is digits <>;
  package FLOAT_PRINT is

    procedure PRINT(FILE : in FILE_TYPE;
                    LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);
    procedure PRINT(FILE : in FILE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);
    procedure PRINT(LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);
    procedure PRINT(ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK);

    procedure PRINT(TO : out STRING; LAST : out NATURAL; ITEM : in NUM);

  end FLOAT_PRINT;

  NULL_PHANTOM : constant PHANTOM_TYPE;

  LAYOUT_ERROR : exception renames TEXT_IO.LAYOUT_ERROR;

private

  type PHANTOM_TYPE is access STRING;

  type LINE_REC(LENGTH : INTEGER) is
    record
      USED_YET            : BOOLEAN := FALSE;
      INDENT              : INTEGER := 0;
      CONTINUATION_INDENT : INTEGER := 2;
      BREAK               : INTEGER := 1;
      INDEX               : INTEGER := 1;
      DATA                : STRING(1..LENGTH);
      START_PHANTOM,
      END_PHANTOM         : PHANTOM_TYPE := NULL_PHANTOM;
    end record;

  type LINE_TYPE is access LINE_REC;

  NULL_PHANTOM : constant PHANTOM_TYPE := new STRING'("");

end TEXT_PRINT;

package body TEXT_PRINT is

  DEFAULT_LINE : LINE_TYPE;

  procedure CREATE_LINE(LINE : in out LINE_TYPE; LENGTH : in POSITIVE) is
  begin
    LINE := new LINE_REC(LENGTH);
  end CREATE_LINE;

  procedure SET_LINE(LINE : in LINE_TYPE) is
  begin
    DEFAULT_LINE := LINE;
  end SET_LINE;

  function CURRENT_LINE return LINE_TYPE is
  begin
    return DEFAULT_LINE;
  end CURRENT_LINE;

  procedure SET_INDENT(LINE   : in LINE_TYPE; INDENT : in NATURAL) is
  begin
    if INDENT >= LINE.LENGTH then
      raise LAYOUT_ERROR;
    end if;
    if LINE.INDEX = LINE.INDENT + 1 then
      for I in 1..INDENT loop
        LINE.DATA(I) := ' ';
      end loop;
      LINE.INDEX := INDENT + 1;
    end if;
    LINE.INDENT := INDENT;
  end SET_INDENT;

  procedure SET_INDENT(INDENT : in NATURAL) is
  begin
    SET_INDENT(DEFAULT_LINE,INDENT);
  end SET_INDENT;

  procedure SET_CONTINUATION_INDENT(LINE   : in LINE_TYPE;
                                    INDENT : in INTEGER) is
  begin
    if LINE.INDENT + INDENT >= LINE.LENGTH or else LINE.INDENT + INDENT < 0
        then
      raise LAYOUT_ERROR;
    end if;
    LINE.CONTINUATION_INDENT := INDENT;
  end SET_CONTINUATION_INDENT;

  procedure SET_CONTINUATION_INDENT(INDENT : in INTEGER) is
  begin
    SET_CONTINUATION_INDENT(DEFAULT_LINE,INDENT);
  end SET_CONTINUATION_INDENT;

  function MAKE_PHANTOM(S : STRING) return PHANTOM_TYPE is
  begin
    return new STRING'(S);
  end MAKE_PHANTOM;

  procedure SET_PHANTOMS(LINE         : in LINE_TYPE;
                         START_PHANTOM,
                         END_PHANTOM  : in PHANTOM_TYPE) is
  begin
    LINE.START_PHANTOM := START_PHANTOM;
    LINE.END_PHANTOM := END_PHANTOM;
  end SET_PHANTOMS;

  procedure SET_PHANTOMS(START_PHANTOM, END_PHANTOM : in PHANTOM_TYPE) is
  begin
    SET_PHANTOMS(DEFAULT_LINE,START_PHANTOM,END_PHANTOM);
  end SET_PHANTOMS;

  procedure PRINT(FILE : in FILE_TYPE;
                  LINE : in LINE_TYPE;
                  ITEM : in STRING;
                  BRK  : BREAK_TYPE := BREAK) is
    NEW_BREAK, NEW_INDEX : INTEGER;
  begin
    if LINE.INDEX + ITEM'LENGTH + LINE.END_PHANTOM'LENGTH > LINE.LENGTH + 1
        then
      if LINE.INDENT + LINE.CONTINUATION_INDENT + LINE.START_PHANTOM'LENGTH +
          LINE.INDEX - LINE.BREAK + ITEM'LENGTH > LINE.LENGTH then
        raise LAYOUT_ERROR;
      end if;
      if ITEM = " " and then LINE.END_PHANTOM.all = "" then
        return;
      end if;
      PUT_LINE(FILE,LINE.DATA(1..LINE.BREAK-1) & LINE.END_PHANTOM.all);
      for I in 1..LINE.INDENT + LINE.CONTINUATION_INDENT loop
        LINE.DATA(I) := ' ';
      end loop;
      NEW_BREAK := LINE.INDENT + LINE.CONTINUATION_INDENT + 1;
      NEW_INDEX := NEW_BREAK + LINE.START_PHANTOM'LENGTH +
          LINE.INDEX - LINE.BREAK;
      LINE.DATA(NEW_BREAK..NEW_INDEX) := LINE.START_PHANTOM.all &
          LINE.DATA(LINE.BREAK..LINE.INDEX);
      LINE.BREAK := NEW_BREAK;
      LINE.INDEX := NEW_INDEX;
    end if;
    NEW_INDEX := LINE.INDEX + ITEM'LENGTH;
    LINE.DATA(LINE.INDEX..NEW_INDEX-1) := ITEM;
    LINE.INDEX := NEW_INDEX;
    if BRK = BREAK then
      LINE.BREAK := NEW_INDEX;
    end if;
    LINE.USED_YET := TRUE;
  end PRINT;

  procedure PRINT(FILE : in FILE_TYPE;
                  ITEM : in STRING;
                  BRK  : in BREAK_TYPE := BREAK) is
  begin
    PRINT(FILE,DEFAULT_LINE,ITEM,BRK);
  end PRINT;

  procedure PRINT(LINE : in LINE_TYPE;
                  ITEM : in STRING;
                  BRK  : in BREAK_TYPE := BREAK) is
  begin
    PRINT(CURRENT_OUTPUT,LINE,ITEM,BRK);
  end PRINT;

  procedure PRINT(ITEM : in STRING; BRK : in BREAK_TYPE := BREAK) is
  begin
    PRINT(CURRENT_OUTPUT,DEFAULT_LINE,ITEM,BRK);
  end PRINT;

  procedure PRINT_LINE(FILE : in FILE_TYPE; LINE : in LINE_TYPE) is
  begin
    if LINE.INDEX /= LINE.INDENT + 1 then
      PUT_LINE(FILE,LINE.DATA(1..LINE.INDEX-1));
    end if;
    for I in 1..LINE.INDENT loop
      LINE.DATA(I) := ' ';
    end loop;
    LINE.INDEX := LINE.INDENT + 1;
    LINE.BREAK := LINE.INDEX;
  end PRINT_LINE;

  procedure PRINT_LINE(FILE : in FILE_TYPE) is
  begin
    PRINT_LINE(FILE,DEFAULT_LINE);
  end PRINT_LINE;

  procedure PRINT_LINE(LINE : in LINE_TYPE) is
  begin
    PRINT_LINE(CURRENT_OUTPUT,LINE);
  end PRINT_LINE;

  procedure PRINT_LINE is
  begin
    PRINT_LINE(CURRENT_OUTPUT,DEFAULT_LINE);
  end PRINT_LINE;

  procedure BLANK_LINE(FILE : in FILE_TYPE; LINE : in LINE_TYPE) is
  begin
    if LINE.USED_YET then
      NEW_LINE(FILE);
    end if;
  end BLANK_LINE;

  procedure BLANK_LINE(FILE : in FILE_TYPE) is
  begin
    BLANK_LINE(FILE,DEFAULT_LINE);
  end BLANK_LINE;

  procedure BLANK_LINE(LINE : in LINE_TYPE) is
  begin
    BLANK_LINE(CURRENT_OUTPUT,LINE);
  end BLANK_LINE;

  procedure BLANK_LINE is
  begin
    BLANK_LINE(CURRENT_OUTPUT,DEFAULT_LINE);
  end BLANK_LINE;

  package body INTEGER_PRINT is

    procedure PRINT(FILE : in FILE_TYPE;
                    LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
      S : STRING(1..NUM'WIDTH);
      L : NATURAL;
    begin
      PRINT(S,L,ITEM);
      PRINT(FILE,LINE,S(1..L),BRK);
    end PRINT;

    procedure PRINT(FILE : in FILE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
    begin
      PRINT(FILE,DEFAULT_LINE,ITEM,BRK);
    end PRINT;

    procedure PRINT(LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
    begin
      PRINT(CURRENT_OUTPUT,LINE,ITEM,BRK);
    end PRINT;

    procedure PRINT(ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
    begin
      PRINT(CURRENT_OUTPUT,DEFAULT_LINE,ITEM,BRK);
    end PRINT;

    procedure PRINT(TO : out STRING; LAST : out NATURAL; ITEM : in NUM) is
      S : constant STRING := NUM'IMAGE(ITEM);
      F : NATURAL := S'FIRST; -- Bug in DG Compiler -- S'FIRST /= 1 ! ! ! ! ! !
      L : NATURAL;
    begin
      if S(F) = ' ' then
        F := F + 1;
      end if;
      if TO'LENGTH < S'LAST - F + 1 then
        raise LAYOUT_ERROR;
      end if;
      L := TO'FIRST + S'LAST - F;
      TO(TO'FIRST..L) := S(F..S'LAST);
      LAST := L;
    end PRINT;

  end INTEGER_PRINT;

  package body FLOAT_PRINT is

    package NUM_IO is new FLOAT_IO(NUM);
      use NUM_IO;

    procedure PRINT(FILE : in FILE_TYPE;
                    LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
      S : STRING(1..DEFAULT_FORE + DEFAULT_AFT + DEFAULT_EXP + 2);
      L : NATURAL;
    begin
      PRINT(S,L,ITEM);
      PRINT(FILE,LINE,S(1..L),BRK);
    end PRINT;

    procedure PRINT(FILE : in FILE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
    begin
      PRINT(FILE,DEFAULT_LINE,ITEM,BRK);
    end PRINT;

    procedure PRINT(LINE : in LINE_TYPE;
                    ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
    begin
      PRINT(CURRENT_OUTPUT,LINE,ITEM,BRK);
    end PRINT;

    procedure PRINT(ITEM : in NUM;
                    BRK  : in BREAK_TYPE := BREAK) is
    begin
      PRINT(CURRENT_OUTPUT,DEFAULT_LINE,ITEM,BRK);
    end PRINT;

    procedure PRINT(TO : out STRING; LAST : out NATURAL; ITEM : in NUM) is
      S         : STRING(1..DEFAULT_FORE + DEFAULT_AFT + DEFAULT_EXP + 2);
      EXP       : INTEGER;
      E_INDEX   : NATURAL := S'LAST - DEFAULT_EXP;
      DOT_INDEX : NATURAL := DEFAULT_FORE + 1;
      L         : NATURAL := 0;
    begin
      PUT(S,ITEM);
      EXP := INTEGER'VALUE(S(E_INDEX+1..S'LAST));
      if EXP >= 0 and then EXP <= DEFAULT_AFT-1 then
        S(DOT_INDEX..DOT_INDEX+EXP-1) := S(DOT_INDEX+1..DOT_INDEX+EXP);
        S(DOT_INDEX+EXP) := '.';
        for I in E_INDEX..S'LAST loop
          S(I) := ' ';
        end loop;
      end if;
      for I in reverse 1..E_INDEX-1 loop
        exit when S(I) /= '0' or else S(I-1) = '.';
        S(I) := ' ';
      end loop;
      for I in S'RANGE loop
        if S(I) /= ' ' then
          L := L + 1;
          TO(L) := S(I);
        end if;
      end loop;
      LAST := L;
    exception
      when CONSTRAINT_ERROR =>
        raise LAYOUT_ERROR;
    end PRINT;

  end FLOAT_PRINT;

end TEXT_PRINT;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ddldefs.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package DDL_DEFINITIONS is

  type TYPE_TYPE is (SUB_TYPE, REC_ORD, ENUMERATION, INT_EGER, FL_OAT,
      STR_ING);

  type TYPE_NAME_STRING is new STRING;
  type TYPE_NAME        is access TYPE_NAME_STRING;

  type TYPE_DESCRIPTOR(TY_PE : TYPE_TYPE);
  type ACCESS_TYPE_DESCRIPTOR is access TYPE_DESCRIPTOR;

  subtype ACCESS_SUBTYPE_DESCRIPTOR     is ACCESS_TYPE_DESCRIPTOR(SUB_TYPE);
  subtype ACCESS_RECORD_DESCRIPTOR      is ACCESS_TYPE_DESCRIPTOR(REC_ORD);
  subtype ACCESS_ENUMERATION_DESCRIPTOR is ACCESS_TYPE_DESCRIPTOR(ENUMERATION);
  subtype ACCESS_INTEGER_DESCRIPTOR     is ACCESS_TYPE_DESCRIPTOR(INT_EGER);
  subtype ACCESS_FLOAT_DESCRIPTOR       is ACCESS_TYPE_DESCRIPTOR(FL_OAT);
  subtype ACCESS_STRING_DESCRIPTOR      is ACCESS_TYPE_DESCRIPTOR(STR_ING);

  type COMPONENT_NAME_STRING is new STRING;
  type COMPONENT_NAME        is access COMPONENT_NAME_STRING;

  type COMPONENT_DESCRIPTOR;
  type ACCESS_COMPONENT_DESCRIPTOR is access COMPONENT_DESCRIPTOR;

  type COMPONENT_DESCRIPTOR is
    record
      NEXT_COMPONENT,
      PREVIOUS_COMPONENT : ACCESS_COMPONENT_DESCRIPTOR;
      NAME               : COMPONENT_NAME;
      TY_PE,
      PARENT_RECORD      : ACCESS_TYPE_DESCRIPTOR;
    end record;

  type SUBRECORD_INDICATOR is new BOOLEAN;

  type LITERAL_DESCRIPTOR;
  type ACCESS_LITERAL_DESCRIPTOR is access LITERAL_DESCRIPTOR;

  type ENUMERATION_NAME_STRING is new STRING;
  type ENUMERATION_NAME        is access ENUMERATION_NAME_STRING;

  type ENUMERATION_POS is new NATURAL;

  type LITERAL_DESCRIPTOR is
    record
      NEXT_LITERAL,
      PREVIOUS_LITERAL : ACCESS_LITERAL_DESCRIPTOR;
      NAME             : ENUMERATION_NAME;
      POS              : ENUMERATION_POS;
      PARENT_TYPE      : ACCESS_TYPE_DESCRIPTOR;
    end record;

  type STRING_LENGTH is new NATURAL;

  type TYPE_DESCRIPTOR(TY_PE : TYPE_TYPE) is
    record
      NAME         : TYPE_NAME;
      NEXT_TYPE,
      PREVIOUS_TYPE,
      FIRST_SUBTYPE,
      LAST_SUBTYPE : ACCESS_TYPE_DESCRIPTOR;
      case TY_PE is
        when SUB_TYPE =>
          PARENT_TYPE,
          TOP_TYPE,
          NEXT_SUBTYPE,
          PREVIOUS_SUBTYPE : ACCESS_TYPE_DESCRIPTOR;
        when REC_ORD =>
          FIRST_COMPONENT,
          LAST_COMPONENT   : ACCESS_COMPONENT_DESCRIPTOR;
          IS_SUBRECORD     : SUBRECORD_INDICATOR := FALSE;
        when ENUMERATION =>
          FIRST_LITERAL,
          LAST_LITERAL     : ACCESS_LITERAL_DESCRIPTOR;
          LAST_POS         : ENUMERATION_POS := 0;
          MAX_LENGTH       : NATURAL := 0;
        when INT_EGER | FL_OAT =>
          null;
        when STR_ING =>
          LENGTH : STRING_LENGTH;
      end case;
    end record;

end DDL_DEFINITIONS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--listutil.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with DDL_DEFINITIONS;
  use DDL_DEFINITIONS;

package LIST_UTILITIES is

  function FIRST_TYPE_DESCRIPTOR return ACCESS_TYPE_DESCRIPTOR;

  function FIND_TYPE_DESCRIPTOR(NAME : TYPE_NAME_STRING)
      return ACCESS_TYPE_DESCRIPTOR;

  procedure ADD_TYPE(T : ACCESS_TYPE_DESCRIPTOR);

  procedure ADD_SUBTYPE(PARENT : ACCESS_TYPE_DESCRIPTOR;
                        CHILD  : ACCESS_SUBTYPE_DESCRIPTOR);

  procedure ADD_LITERAL(PARENT : ACCESS_ENUMERATION_DESCRIPTOR;
                        CHILD  : ACCESS_LITERAL_DESCRIPTOR);

  procedure ADD_COMPONENT(PARENT : ACCESS_RECORD_DESCRIPTOR;
                          CHILD  : ACCESS_COMPONENT_DESCRIPTOR);

end LIST_UTILITIES;

package body LIST_UTILITIES is

  TYPE_DESCRIPTOR_0,                          -- type listhead -- first & last
  TYPE_DESCRIPTOR_9 : ACCESS_TYPE_DESCRIPTOR; --  type descriptors

  function FIRST_TYPE_DESCRIPTOR return ACCESS_TYPE_DESCRIPTOR is
  begin
    return TYPE_DESCRIPTOR_0;
  end FIRST_TYPE_DESCRIPTOR;

  function FIND_TYPE_DESCRIPTOR(NAME : TYPE_NAME_STRING)
      return ACCESS_TYPE_DESCRIPTOR is
    T : ACCESS_TYPE_DESCRIPTOR := TYPE_DESCRIPTOR_0;
  begin
    while T.NAME.all /= NAME loop
      T := T.NEXT_TYPE; -- CONSTRAINT_ERROR if non-existent type name
    end loop;
    return T;
  end FIND_TYPE_DESCRIPTOR;

  procedure ADD_TYPE(T : ACCESS_TYPE_DESCRIPTOR) is
  begin
    if TYPE_DESCRIPTOR_9 = null then
      TYPE_DESCRIPTOR_0 := T;
    else
      TYPE_DESCRIPTOR_9.NEXT_TYPE := T;
    end if;
    T.PREVIOUS_TYPE := TYPE_DESCRIPTOR_9;
    TYPE_DESCRIPTOR_9 := T;
    T.NEXT_TYPE := null;
  end ADD_TYPE;

  procedure ADD_SUBTYPE(PARENT : ACCESS_TYPE_DESCRIPTOR;
                        CHILD  : ACCESS_SUBTYPE_DESCRIPTOR) is
  begin
    if PARENT.LAST_SUBTYPE = null then
      PARENT.FIRST_SUBTYPE := CHILD;
    else
      PARENT.LAST_SUBTYPE.NEXT_SUBTYPE := CHILD;
    end if;
    CHILD.PREVIOUS_SUBTYPE := PARENT.LAST_SUBTYPE;
    PARENT.LAST_SUBTYPE := CHILD;
    CHILD.NEXT_SUBTYPE := null;
    CHILD.PARENT_TYPE := PARENT;
  end ADD_SUBTYPE;

  procedure ADD_LITERAL(PARENT : ACCESS_ENUMERATION_DESCRIPTOR;
                        CHILD  : ACCESS_LITERAL_DESCRIPTOR) is
  begin
    if PARENT.LAST_LITERAL = null then
      PARENT.FIRST_LITERAL := CHILD;
    else
      PARENT.LAST_LITERAL.NEXT_LITERAL := CHILD;
    end if;
    CHILD.PREVIOUS_LITERAL := PARENT.LAST_LITERAL;
    PARENT.LAST_LITERAL := CHILD;
    CHILD.NEXT_LITERAL := null;
    CHILD.PARENT_TYPE := PARENT;
  end ADD_LITERAL;

  procedure ADD_COMPONENT(PARENT : ACCESS_RECORD_DESCRIPTOR;
                          CHILD  : ACCESS_COMPONENT_DESCRIPTOR) is
  begin
    if PARENT.LAST_COMPONENT = null then
      PARENT.FIRST_COMPONENT := CHILD;
    else
      PARENT.LAST_COMPONENT.NEXT_COMPONENT := CHILD;
    end if;
    CHILD.PREVIOUS_COMPONENT := PARENT.LAST_COMPONENT;
    PARENT.LAST_COMPONENT := CHILD;
    CHILD.NEXT_COMPONENT := null;
    CHILD.PARENT_RECORD := PARENT;
  end ADD_COMPONENT;

end LIST_UTILITIES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--readddl.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with DDL_DEFINITIONS, LIST_UTILITIES, TOKEN_INPUT;
  use DDL_DEFINITIONS, LIST_UTILITIES, TOKEN_INPUT;

package READ_DDL is

  procedure SCAN_DDL(PACKAGE_NAME : out STRING;
                     LAST         : out POSITIVE);

end READ_DDL;

package body READ_DDL is

  procedure PROCESS_DERIVED_TYPE(NEW_NAME : TYPE_NAME) is
    KEYWORD  : STRING(1..7);
    LAST     : POSITIVE;
    STR_LAST : STRING_LENGTH;
  begin
    GET_STRING(KEYWORD,LAST);
    if KEYWORD(1..LAST) = "INTEGER" then
      ADD_TYPE ( new TYPE_DESCRIPTOR'(TY_PE => INT_EGER, NAME => NEW_NAME,
          others => null) );
      GOBBLE(";");
    elsif KEYWORD(1..LAST) = "FLOAT" then
      ADD_TYPE ( new TYPE_DESCRIPTOR'(TY_PE => FL_OAT,   NAME => NEW_NAME,
          others => null) );
      GOBBLE(";");
    elsif KEYWORD(1..LAST) = "STRING" then
      GOBBLE("("); GOBBLE("1"); GOBBLE("..");
      STR_LAST := STRING_LENGTH(GET_INTEGER);
      ADD_TYPE ( new TYPE_DESCRIPTOR'(TY_PE => STR_ING,  NAME => NEW_NAME,
          LENGTH => STR_LAST, others => null) );
      GOBBLE(");");
    else
      raise CONSTRAINT_ERROR; -- unrecognized type keyword
    end if;
  end PROCESS_DERIVED_TYPE;

  procedure PROCESS_ENUMERATION_TYPE(NEW_NAME : TYPE_NAME) is
    PARENT    : ACCESS_ENUMERATION_DESCRIPTOR;
    LITERAL   : ENUMERATION_NAME_STRING(1..80);
    LAST      : POSITIVE;
    DELIMITER : STRING(1..2);
  begin
    PARENT := new TYPE_DESCRIPTOR'(TY_PE => ENUMERATION, NAME => NEW_NAME,
        LAST_POS => 0, MAX_LENGTH => 0, FIRST_LITERAL | LAST_LITERAL => null,
        others => null);
    ADD_TYPE(PARENT);
    loop
      GET_STRING(STRING(LITERAL),LAST);
      PARENT.LAST_POS := PARENT.LAST_POS + 1;
      if LAST > PARENT.MAX_LENGTH then
        PARENT.MAX_LENGTH := LAST;
      end if;
      ADD_LITERAL ( PARENT, new LITERAL_DESCRIPTOR'(
          NAME => new ENUMERATION_NAME_STRING'(LITERAL(1..LAST)),
          POS  => PARENT.LAST_POS, PARENT_TYPE => PARENT, others => null) );
      GET_STRING(DELIMITER,LAST);
      if DELIMITER(1..LAST) = ");" then
        exit;
      elsif DELIMITER(1..LAST) /= "," then
        raise CONSTRAINT_ERROR; -- invalid enumeration literal list
      end if;
    end loop;
  end PROCESS_ENUMERATION_TYPE;

  procedure PROCESS_RECORD_TYPE(NEW_NAME : TYPE_NAME) is
    FIELD_TYPE_NAME : TYPE_NAME_STRING(1..80);
    FIELD_NAME      : COMPONENT_NAME_STRING(1..80);
    FIELD_TYPE      : ACCESS_TYPE_DESCRIPTOR;
    PARENT          : ACCESS_RECORD_DESCRIPTOR;
    FIELD_TYPE_LAST,
    FIELD_LAST      : POSITIVE;
  begin
    PARENT := new TYPE_DESCRIPTOR'(TY_PE => REC_ORD, NAME => NEW_NAME,
        IS_SUBRECORD => FALSE, FIRST_COMPONENT | LAST_COMPONENT => null,
        others => null);
    ADD_TYPE(PARENT);
    loop
      GET_STRING(STRING(FIELD_NAME),FIELD_LAST);
      if FIELD_NAME(1..FIELD_LAST) = "end" then
        GOBBLE("record"); GOBBLE(";");
        exit;
      end if;
      GOBBLE(":");
      GET_STRING(STRING(FIELD_TYPE_NAME),FIELD_TYPE_LAST);
      FIELD_TYPE := FIND_TYPE_DESCRIPTOR(FIELD_TYPE_NAME(1..FIELD_TYPE_LAST));
      if FIELD_TYPE.TY_PE = REC_ORD then
        FIELD_TYPE.IS_SUBRECORD := TRUE;
      end if;
      ADD_COMPONENT ( PARENT, new COMPONENT_DESCRIPTOR' (
          NAME  => new COMPONENT_NAME_STRING'(FIELD_NAME(1..FIELD_LAST)),
          TY_PE => FIELD_TYPE, PARENT_RECORD => PARENT, others => null ) );
      GOBBLE(";");
    end loop;
  end PROCESS_RECORD_TYPE;

  procedure PROCESS_TYPE is
    NAME_STRING    : TYPE_NAME_STRING(1..80);
    NAME           : TYPE_NAME;
    LAST           : POSITIVE;
    TYPE_INDICATOR : STRING(1..6);
  begin
    GET_STRING(STRING(NAME_STRING),LAST);
    NAME := new TYPE_NAME_STRING'(NAME_STRING(1..LAST));
    GOBBLE("is");
    GET_STRING(TYPE_INDICATOR,LAST);
    if TYPE_INDICATOR(1..LAST) = "(" then
      PROCESS_ENUMERATION_TYPE(NAME);
    elsif TYPE_INDICATOR(1..LAST) = "new" then
      PROCESS_DERIVED_TYPE(NAME);
    elsif TYPE_INDICATOR(1..LAST) = "record" then
      PROCESS_RECORD_TYPE(NAME);
    else
      raise CONSTRAINT_ERROR; -- unrecognized type keyword/indicator
    end if;
  end PROCESS_TYPE;

  procedure PROCESS_SUBTYPE is
    CHILD_NAME,
    PARENT_NAME       : TYPE_NAME_STRING(1..80);
    CHILD_LAST,
    PARENT_LAST       : POSITIVE;
    PARENT_DESCRIPTOR : ACCESS_TYPE_DESCRIPTOR;
    CHILD_DESCRIPTOR  : ACCESS_SUBTYPE_DESCRIPTOR;
  begin
    GET_STRING(STRING(CHILD_NAME),CHILD_LAST);
    GOBBLE("is");
    GET_STRING(STRING(PARENT_NAME),PARENT_LAST);
    GOBBLE(";");
    PARENT_DESCRIPTOR := FIND_TYPE_DESCRIPTOR(PARENT_NAME(1..PARENT_LAST));
    CHILD_DESCRIPTOR := new TYPE_DESCRIPTOR' (
        TY_PE  => SUB_TYPE,
        NAME   => new TYPE_NAME_STRING'(CHILD_NAME(1..CHILD_LAST)),
        others => null );
    ADD_TYPE(CHILD_DESCRIPTOR);
    ADD_SUBTYPE(PARENT_DESCRIPTOR, CHILD_DESCRIPTOR);
    if PARENT_DESCRIPTOR.TY_PE = SUB_TYPE then
      CHILD_DESCRIPTOR.TOP_TYPE := PARENT_DESCRIPTOR.TOP_TYPE;
    else
      CHILD_DESCRIPTOR.TOP_TYPE := PARENT_DESCRIPTOR;
    end if;
  end PROCESS_SUBTYPE;

  procedure SCAN_DDL(PACKAGE_NAME : out STRING;
                     LAST         : out POSITIVE) is
    KEYWORD : STRING(1..7);
    KLAST   : POSITIVE;
  begin
    GOBBLE("package");
    GET_STRING(PACKAGE_NAME,LAST);
    GOBBLE("is");
    loop
      GET_STRING(KEYWORD,KLAST);
      if KEYWORD(1..KLAST) = "type" then
        PROCESS_TYPE;
      elsif KEYWORD(1..KLAST) = "subtype" then
        PROCESS_SUBTYPE;
      elsif KEYWORD(1..KLAST) = "end" then
        exit;
      else
        raise CONSTRAINT_ERROR; -- unrecognized keyword
      end if;
    end loop;
  end SCAN_DDL;

end READ_DDL;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--showddl.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with DDL_DEFINITIONS, TEXT_PRINT;
  use DDL_DEFINITIONS, TEXT_PRINT;

package SHOW_DDL is

  package INT_PRINT is new INTEGER_PRINT(INTEGER);
    use INT_PRINT;

  procedure DISPLAY_DDL(PACKAGE_NAME : STRING);

  procedure PRINT_ENUMERATION_LITERALS(L : ACCESS_LITERAL_DESCRIPTOR);

  function MAX_COMPONENT_NAME_LENGTH(C : ACCESS_COMPONENT_DESCRIPTOR) return
      NATURAL;

end SHOW_DDL;

with DDL_DEFINITIONS, LIST_UTILITIES, TEXT_PRINT;
  use DDL_DEFINITIONS, LIST_UTILITIES, TEXT_PRINT;

package body SHOW_DDL is

  procedure SHOW_SUBTYPE_TREE(T : ACCESS_TYPE_DESCRIPTOR; LEVEL : NATURAL) is
  begin
    if T /= null then
      PRINT("-- ",NO_BREAK);
      for I in 1..LEVEL loop
        PRINT("  ",NO_BREAK);
      end loop;
      PRINT(STRING(T.NAME.all)); PRINT_LINE;
      SHOW_SUBTYPE_TREE(T.FIRST_SUBTYPE,LEVEL+1);
      if T.TY_PE = SUB_TYPE then
        SHOW_SUBTYPE_TREE(T.NEXT_SUBTYPE,LEVEL);
      end if;
    end if;
  end SHOW_SUBTYPE_TREE;

  procedure SHOW_SUBTYPES is
    CURRENT_TYPE : ACCESS_TYPE_DESCRIPTOR := FIRST_TYPE_DESCRIPTOR;
  begin
    PRINT("-- subtype tree"); PRINT_LINE; BLANK_LINE;
    while CURRENT_TYPE /= null loop
      if CURRENT_TYPE.TY_PE /= SUB_TYPE then
        SHOW_SUBTYPE_TREE(CURRENT_TYPE,0);
        BLANK_LINE;
      end if;
      CURRENT_TYPE := CURRENT_TYPE.NEXT_TYPE;
    end loop;
  end SHOW_SUBTYPES;

  function BLANK_LINE_FOLLOWS(T : ACCESS_TYPE_DESCRIPTOR) return BOOLEAN is
  begin
    if T.TY_PE = REC_ORD or else T.NEXT_TYPE = null then
      return TRUE;
    elsif T.NEXT_TYPE.TY_PE /= SUB_TYPE then
      case T.TY_PE is
        when INT_EGER | FL_OAT | STR_ING =>
          if T.TY_PE /= T.NEXT_TYPE.TY_PE or else
              ( T.NEXT_TYPE.NEXT_TYPE /= null and then
                  T.NEXT_TYPE.NEXT_TYPE.TY_PE = SUB_TYPE ) then
            return TRUE;
          end if;
        when others =>
          return TRUE;
      end case;
    end if;
    return FALSE;
  end BLANK_LINE_FOLLOWS;

  function MAX_TYPE_NAME_LENGTH(T : ACCESS_TYPE_DESCRIPTOR) return NATURAL is
    LENGTH : NATURAL := 0;
    Q      : ACCESS_TYPE_DESCRIPTOR := T;
  begin
    while Q /= null loop
      if Q.NAME'LAST > LENGTH then
        LENGTH := Q.NAME'LAST;
      end if;
      exit when BLANK_LINE_FOLLOWS(Q);
      Q := Q.NEXT_TYPE;
    end loop;
    return LENGTH;
  end MAX_TYPE_NAME_LENGTH;

  function MAX_COMPONENT_NAME_LENGTH(C : ACCESS_COMPONENT_DESCRIPTOR) return
      NATURAL is
    LENGTH : NATURAL := 0;
    D      : ACCESS_COMPONENT_DESCRIPTOR := C;
  begin
    while D /= null loop
      if D.NAME'LAST > LENGTH then
        LENGTH := D.NAME'LAST;
      end if;
      D := D.NEXT_COMPONENT;
    end loop;
    return LENGTH;
  end MAX_COMPONENT_NAME_LENGTH;

  procedure PRINT_TYPE_IS(T      : ACCESS_TYPE_DESCRIPTOR;
                          LENGTH : NATURAL) is
  begin
    if T.TY_PE = SUB_TYPE then
      PRINT("subtype ",NO_BREAK);
    else
      PRINT("type ",NO_BREAK);
    end if;
    PRINT(STRING(T.NAME.all),NO_BREAK);
    if T.TY_PE = SUB_TYPE or else T.NEXT_TYPE = null or else
        T.NEXT_TYPE.TY_PE /= SUB_TYPE then
      for I in 1..LENGTH-T.NAME'LAST loop
        PRINT(" ",NO_BREAK);
      end loop;
    end if;
    PRINT(" is",NO_BREAK);
  end PRINT_TYPE_IS;

  procedure PRINT_ENUMERATION_LITERALS(L : ACCESS_LITERAL_DESCRIPTOR) is
            M : ACCESS_LITERAL_DESCRIPTOR := L;
  begin
    loop
      PRINT(STRING(M.NAME.all),NO_BREAK);
      M := M.NEXT_LITERAL;
      if M = null then
        exit;
      else
        PRINT(",");
      end if;
    end loop;
  end PRINT_ENUMERATION_LITERALS;

  procedure PRINT_RECORD_COMPONENTS(C : ACCESS_COMPONENT_DESCRIPTOR) is
    D : ACCESS_COMPONENT_DESCRIPTOR := C;
    LENGTH : NATURAL := MAX_COMPONENT_NAME_LENGTH(D);
  begin
    while D /= null loop
      PRINT(STRING(D.NAME.all),NO_BREAK);
      for I in 1..LENGTH-D.NAME'LAST loop
        PRINT(" ",NO_BREAK);
      end loop;
      PRINT(" : " & STRING(D.TY_PE.NAME.all) & ";"); PRINT_LINE;
      D := D.NEXT_COMPONENT;
    end loop;
  end PRINT_RECORD_COMPONENTS;

  procedure SHOW_SOURCE is
    CURRENT_TYPE : ACCESS_TYPE_DESCRIPTOR := FIRST_TYPE_DESCRIPTOR;
    NAME_LENGTH  : NATURAL := MAX_TYPE_NAME_LENGTH(CURRENT_TYPE);
  begin
    while CURRENT_TYPE /= null loop
      PRINT_TYPE_IS(CURRENT_TYPE,NAME_LENGTH);
      case CURRENT_TYPE.TY_PE is
        when SUB_TYPE =>
          PRINT(" ",NO_BREAK);
          PRINT(STRING(CURRENT_TYPE.PARENT_TYPE.NAME.all),NO_BREAK);
        when REC_ORD =>
          PRINT_LINE; PRINT("  record"); PRINT_LINE; SET_INDENT(6);
          PRINT_RECORD_COMPONENTS(CURRENT_TYPE.FIRST_COMPONENT);
          SET_INDENT(2); PRINT("  end record");
        when ENUMERATION =>
          PRINT(" (",NO_BREAK);
          PRINT_ENUMERATION_LITERALS(CURRENT_TYPE.FIRST_LITERAL);
          PRINT(")",NO_BREAK);
        when INT_EGER =>
          PRINT(" new INTEGER",NO_BREAK);
        when FL_OAT =>
          PRINT(" new FLOAT",NO_BREAK);
        when STR_ING =>
          PRINT(" new STRING(1..",NO_BREAK);
          PRINT(INTEGER(CURRENT_TYPE.LENGTH),NO_BREAK);
          PRINT(")",NO_BREAK);
      end case;
      PRINT(";"); PRINT_LINE;
      if BLANK_LINE_FOLLOWS(CURRENT_TYPE) then
        BLANK_LINE;
        NAME_LENGTH := MAX_TYPE_NAME_LENGTH(CURRENT_TYPE.NEXT_TYPE);
      end if;
      CURRENT_TYPE := CURRENT_TYPE.NEXT_TYPE;
    end loop;
  end SHOW_SOURCE;

  procedure DISPLAY_DDL(PACKAGE_NAME : STRING) is
  begin
    SET_INDENT(0); SET_CONTINUATION_INDENT(2);
    PRINT("package " & PACKAGE_NAME & " is"); PRINT_LINE; BLANK_LINE;
    SET_INDENT(2);
    SHOW_SUBTYPES;
    SHOW_SOURCE;
    SET_INDENT(0);
    PRINT("end " & PACKAGE_NAME & ";"); PRINT_LINE;
  end DISPLAY_DDL;

end SHOW_DDL;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--simddl.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package SIMPLE_DDL is

  procedure GENERATE_SIMPLE_DDL;

end SIMPLE_DDL;

with DDL_DEFINITIONS, LIST_UTILITIES, SHOW_DDL, TEXT_PRINT;
  use DDL_DEFINITIONS, LIST_UTILITIES, SHOW_DDL, TEXT_PRINT;

package body SIMPLE_DDL is

  use SHOW_DDL.INT_PRINT;

  procedure PRINT_FIELDS(C : ACCESS_COMPONENT_DESCRIPTOR) is
    D : ACCESS_COMPONENT_DESCRIPTOR := C;
    T : ACCESS_TYPE_DESCRIPTOR;
  begin
    while D /= null loop
      T := D.TY_PE;
      if T.TY_PE = SUB_TYPE then
        T := T.TOP_TYPE;
      end if;
      case T.TY_PE is
        when SUB_TYPE =>
          raise PROGRAM_ERROR; -- internal error due to if above
        when REC_ORD =>
          PRINT_FIELDS(T.FIRST_COMPONENT);
        when ENUMERATION =>
          PRINT("FIELD " & STRING(D.NAME.all) & " STRING ",NO_BREAK);
          PRINT(T.MAX_LENGTH + ENUMERATION_POS'IMAGE(T.LAST_POS)'LENGTH - 1);
          PRINT_LINE;
        when INT_EGER =>
          PRINT("FIELD " & STRING(D.NAME.all) & " INTEGER 6"); PRINT_LINE;
        when FL_OAT =>
          PRINT("FIELD " & STRING(D.NAME.all) & " FLOAT 7"); PRINT_LINE;
        when STR_ING =>
          PRINT("FIELD " & STRING(D.NAME.all) & " STRING ",NO_BREAK);
          PRINT(INTEGER(T.LENGTH)); PRINT_LINE;
      end case;
      D := D.NEXT_COMPONENT;
    end loop;
  end PRINT_FIELDS;

  procedure GENERATE_SIMPLE_DDL is
    CURRENT_TYPE : ACCESS_TYPE_DESCRIPTOR := FIRST_TYPE_DESCRIPTOR;
  begin
    SET_INDENT(0); SET_CONTINUATION_INDENT(2);
    while CURRENT_TYPE /= null loop
      if CURRENT_TYPE.TY_PE = REC_ORD and then
          CURRENT_TYPE.IS_SUBRECORD = FALSE then
        PRINT("TABLE " & STRING(CURRENT_TYPE.NAME.all)); PRINT_LINE;
        BLANK_LINE;
        PRINT_FIELDS(CURRENT_TYPE.FIRST_COMPONENT);
        BLANK_LINE;
      end if;
      CURRENT_TYPE := CURRENT_TYPE.NEXT_TYPE;
    end loop;
    PRINT("END"); PRINT_LINE;
  end GENERATE_SIMPLE_DDL;

end SIMPLE_DDL;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--damesddl.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package DAMES_DDL is

  procedure GENERATE_DAMES_DDL;

end DAMES_DDL;

with DDL_DEFINITIONS, LIST_UTILITIES, SHOW_DDL, TEXT_PRINT;
  use DDL_DEFINITIONS, LIST_UTILITIES, SHOW_DDL, TEXT_PRINT;

package body DAMES_DDL is

  use SHOW_DDL.INT_PRINT;

  START_PHANTOM : constant PHANTOM_TYPE := MAKE_PHANTOM("""");
  END_PHANTOM   : constant PHANTOM_TYPE := MAKE_PHANTOM(""" &");

  procedure PRINT_FIELD_NAME(C          : in     ACCESS_COMPONENT_DESCRIPTOR;
                             FIRST_TIME : in out BOOLEAN;
                             SEPARATOR  : in     STRING) is
  begin
    if FIRST_TIME then
      FIRST_TIME := FALSE;
    else
      PRINT(SEPARATOR & """ &"); PRINT_LINE;
    end if;
    PRINT("""" & STRING(C.NAME.all),NO_BREAK);
  end PRINT_FIELD_NAME;

  procedure PRINT_FIELDS(C          : ACCESS_COMPONENT_DESCRIPTOR;
                         FIRST_TIME : BOOLEAN := TRUE;
                         SEPARATOR  : STRING  := ";") is
    D  : ACCESS_COMPONENT_DESCRIPTOR := C;
    T  : ACCESS_TYPE_DESCRIPTOR;
    FT : BOOLEAN := FIRST_TIME;
  begin
    while D /= null loop
      T := D.TY_PE;
      if T.TY_PE = SUB_TYPE then
        T := T.TOP_TYPE;
      end if;
      case T.TY_PE is
        when SUB_TYPE =>
          raise PROGRAM_ERROR; -- internal error due to if above
        when REC_ORD =>
          if D.PARENT_RECORD.IS_SUBRECORD = TRUE then
            PRINT_FIELDS(T.FIRST_COMPONENT,FT,SEPARATOR); FT := FALSE;
          else
            PRINT_FIELD_NAME(D,FT,SEPARATOR); PRINT(" "" &"); PRINT_LINE;
            SET_INDENT(5);
            PRINT_FIELDS(T.FIRST_COMPONENT,TRUE,",");
            SET_INDENT(3);
          end if;
        when ENUMERATION =>
          PRINT_FIELD_NAME(D,FT,SEPARATOR); PRINT(" (",NO_BREAK);
          PRINT_ENUMERATION_LITERALS(T.FIRST_LITERAL); PRINT(")",NO_BREAK);
        when INT_EGER =>
          PRINT_FIELD_NAME(D,FT,SEPARATOR); PRINT(" INTEGER");
        when FL_OAT =>
          PRINT_FIELD_NAME(D,FT,SEPARATOR); PRINT(" FLOAT");
        when STR_ING =>
          PRINT_FIELD_NAME(D,FT,SEPARATOR); PRINT(" STRING 1..",NO_BREAK);
          PRINT(INTEGER(T.LENGTH));
      end case;
      D := D.NEXT_COMPONENT;
    end loop;
  end PRINT_FIELDS;

  procedure GENERATE_DAMES_DDL is
    CURRENT_TYPE : ACCESS_TYPE_DESCRIPTOR := FIRST_TYPE_DESCRIPTOR;
    FIRST_TIME   : BOOLEAN := TRUE;
  begin
    SET_CONTINUATION_INDENT(2); SET_PHANTOMS(START_PHANTOM,END_PHANTOM);
    while CURRENT_TYPE /= null loop
      if CURRENT_TYPE.TY_PE = REC_ORD and then
          CURRENT_TYPE.IS_SUBRECORD = FALSE then
        if FIRST_TIME then
          FIRST_TIME := FALSE;
        else
          BLANK_LINE;
        end if;
        SET_INDENT(2);
        PRINT("DEFINE_TABLE(""" & STRING(CURRENT_TYPE.NAME.all) & """,");
        PRINT_LINE; SET_INDENT(3);
        PRINT_FIELDS(CURRENT_TYPE.FIRST_COMPONENT);
        PRINT(""");"); PRINT_LINE;
      end if;
      CURRENT_TYPE := CURRENT_TYPE.NEXT_TYPE;
    end loop;
    SET_INDENT(0); SET_PHANTOMS(NULL_PHANTOM,NULL_PHANTOM);
  end GENERATE_DAMES_DDL;

end DAMES_DDL;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--main.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with DAMES_DDL, READ_DDL, SHOW_DDL, SIMPLE_DDL, TEXT_IO, TEXT_PRINT,
    TOKEN_INPUT;
  use DAMES_DDL, READ_DDL, SHOW_DDL, SIMPLE_DDL, TEXT_IO, TEXT_PRINT,
      TOKEN_INPUT;

procedure MAIN is

  LINE         : LINE_TYPE;
  PACKAGE_NAME : STRING(1..80);
  LAST         : NATURAL;

  procedure PRINT_RULE is
  begin
    PRINT("---------------------------------------" &
          "---------------------------------------"); PRINT_LINE;
  end PRINT_RULE;

begin
  SET_STREAM(CREATE_STREAM(80)); OPEN_INPUT("BOATS.ADA");
  CREATE_LINE(LINE,79); SET_LINE(LINE);
  SCAN_DDL(PACKAGE_NAME,LAST);
  DISPLAY_DDL(PACKAGE_NAME(1..LAST)); PRINT_RULE;
  GENERATE_SIMPLE_DDL; PRINT_RULE;
  GENERATE_DAMES_DDL;
  CLOSE_INPUT;
end MAIN;