View source for JSON package

essai

<code style="font-family:'Noto Mono';font-weight: 1200;background:black;color:lime;tab-size:10;line-height: 1.2;">
<b>with</b> TEXT_IO; with <b>TEXT_IO;</b>

</code>

<pre style="font-family:'Noto Mono';background:black;color:lime;tab-size:10;line-height: 1.2;">--	JSON.ADS	VINCENT MORIN	25/2/2025		UNIVERSITE DE BRETAGNE OCCIDENTALE	(UBO)
-------------------------------------------------------------------------------------------------------------------------
--	1	2	3	4	5	6	7	8	9	0	1	2


with TEXT_IO;
						----
			package			JSON
						----
is

  type ITEM		is private;

  type ITEM_TYPE		is ( OBJECT_ITEM, ARRAY_ITEM,
			     STRING_ITEM, INTEGER_ITEM, FLOAT_ITEM, BOOLEAN_ITEM, NULL_ITEM );

  subtype TERMINAL_TYPE	is ITEM_TYPE range STRING_ITEM .. NULL_ITEM;

  subtype FILE_TYPE		is TEXT_IO.FILE_TYPE;

  MAX_STRING_LENGTH		:constant NATURAL	:= 2**15-1;
  subtype STRING_LENGTH	is NATURAL range 0 .. MAX_STRING_LENGTH;

  type VALUE_DATA (KIND :TERMINAL_TYPE := NULL_ITEM; LENGTH :STRING_LENGTH := 0)
			is record
			  case  KIND
			  is
			    when STRING_ITEM	=> STRING_VAL	:STRING( 1 .. LENGTH );
			    when INTEGER_ITEM	=> INT_VAL	:INTEGER;
			    when FLOAT_ITEM		=> FLOAT_VAL	:LONG_FLOAT;
			    when BOOLEAN_ITEM	=> BOOL_VAL	:BOOLEAN;
			    when NULL_ITEM		=> null;
			  end case;
			end record;


				--  J S O N   I T E M   I / O


  procedure GET			( FILE :in JSON.FILE_TYPE; THE_ITEM :out ITEM );
  procedure PUT			( FILE :in out JSON.FILE_TYPE; THE_ITEM :ITEM );
  function  STRING_OF		( THE_ITEM :ITEM)				return STRING;
  function  ITEM_OF			( THE_STRING :STRING)			return ITEM;


				--  J S O N   I T E M   I N T E R A C T I O N


  function  KIND			( OF_ITEM :ITEM )				return ITEM_TYPE;
  function  IS_PRESENT		( KEY :STRING; IN_OBJECT :ITEM )		return BOOLEAN;
  function  ITEM_BY_KEY		( KEY :STRING; IN_OBJECT :ITEM )		return ITEM;
  function  ITEM_VALUE		( OF_ITEM :ITEM )				return VALUE_DATA;
  function  NUMBER_OF_SUB_ITEMS	( IN_ITEM :ITEM )				return NATURAL;
  procedure FREE			( THE_ITEM :in out ITEM );

  generic
    with procedure APPLY_PROCESS ( ON_ITEM :in out ITEM; LAST_ONE :in BOOLEAN; STOP_PROCESS :out BOOLEAN );
  procedure FOR_EACH_JSON_ITEM	( OF_ARRAY :ITEM );

  generic
    with procedure APPLY_PROCESS ( KEY :STRING; ON_ITEM :in out ITEM; LAST_ONE :in BOOLEAN; STOP_PROCESS :out BOOLEAN );
  procedure FOR_EACH_JSON_FIELD	( OF_OBJECT :ITEM );


  SYNTAX_ERROR, BAD_ITEM_TYPE, VALUE_NOT_FOUND	: exception;


--	1	2	3	4	5	6	7	8	9	0	1	2
-------------------------------------------------------------------------------------------------------------------------

										pragma PAGE;
private

  type ITEM_DEFINITION (KIND :JSON.ITEM_TYPE);
  type ITEM			is access ITEM_DEFINITION;

  type OBJECT_FIELD;
  type OBJECT_FIELD_ACCESS		is access OBJECT_FIELD;

  type ITEM_LIST_ELEMENT;
  type LIST_OF_ITEMS		is access ITEM_LIST_ELEMENT;

  type STRING_ACCESS		is access STRING;


  type ITEM_DEFINITION (KIND :ITEM_TYPE)	is record
				  case KIND is
				  when  OBJECT_ITEM		=> FIELDS_LIST	: OBJECT_FIELD_ACCESS;
				  when  ARRAY_ITEM		=> ITEMS_LIST	: LIST_OF_ITEMS;
				  when  STRING_ITEM		=> STR_ACCESS	: STRING_ACCESS;
				  when  INTEGER_ITEM	=> INT_VAL	: INTEGER;
				  when  FLOAT_ITEM		=> FLOAT_VAL	: LONG_FLOAT;
				  when  BOOLEAN_ITEM	=> BOOL_VAL	: BOOLEAN;
				  when  NULL_ITEM		=> null;
				  end case;
				end record;


  type OBJECT_FIELD			is record
				  FIELD_KEY	: STRING_ACCESS;
				  FIELD_ITEM	: ITEM;
				  NEXT		: OBJECT_FIELD_ACCESS;
				end record;


  type ITEM_LIST_ELEMENT		is record
				  LIST_ITEM	: ITEM;
				  NEXT		: LIST_OF_ITEMS;
				end record;

	----
end	JSON;
	----

--	1	2	3	4	5	6	7	8	9	0	1	2
-------------------------------------------------------------------------------------------------------------------------
</pre>

The package body :
<pre style="font-family:'Noto Mono';background:black;color:lime;tab-size:10;line-height: 1;">
--	JSON.ADB	VINCENT MORIN	25/2/2025		UNIVERSITE DE BRETAGNE OCCIDENTALE	(UBO)
-------------------------------------------------------------------------------------------------------------------------
--	1	2	3	4	5	6	7	8	9	0	1	2


with UNCHECKED_DEALLOCATION, DIRECT_IO;

						----
			package body		JSON
						----
is

  DEBUG		: BOOLEAN		:= FALSE;


			---
  procedure		GET		( FILE :in JSON.FILE_TYPE; THE_ITEM :out ITEM )
  			---
  is
    use TEXT_IO;

		------
  package		PARSER
		------
  is

    function  READ_OBJECT		return JSON.ITEM;

	------
  end	PARSER;
	------

  package body				PARSER
					------
  is


    type TOKEN_TYPE		is ( END_TOKEN, LEFT_ACCOLADE, RIGHT_ACCOLADE, LEFT_CROCHET, RIGHT_CROCHET,
			     COMMA, COLON, CHAINE, ENTIER, FLOTTANT );

    type TOKEN (KIND :TOKEN_TYPE := END_TOKEN)	is record
			  case KIND is
			  when CHAINE	=> STR_LENGTH	: NATURAL;
			  when ENTIER	=> INT_VALUE	: INTEGER;
			  when FLOTTANT	=> FLOAT_VALUE	: LONG_FLOAT;
			  when others	=> null;
			  end case;
			end record;

    TOKEN_BUFFER		: STRING( 1 .. 512 );



			--------------------
  procedure		PROCESS_SYNTAX_ERROR		( ENCOUNTERED, EXPECTED : TOKEN_TYPE := END_TOKEN )
  			--------------------
  is
    use TEXT_IO;
  begin
    PUT( "syntax error ! (" & COUNT'IMAGE( TEXT_IO.LINE( FILE ) )
		  & ':' & COUNT'IMAGE( TEXT_IO.COL( FILE )-1 ) & ") : " );

    if  ENCOUNTERED = END_TOKEN  and  EXPECTED = END_TOKEN
    then
      PUT_LINE( "unexpected end of file " );

    else
      if  EXPECTED /= END_TOKEN
      then
        PUT( "expected " & TOKEN_TYPE'IMAGE( EXPECTED ) );
      end if;

      if  ENCOUNTERED /= END_TOKEN
      then
        PUT_LINE( " encountered " & TOKEN_TYPE'IMAGE( ENCOUNTERED ) );
      else
        NEW_LINE;
      end if;

    end if;

    raise PROGRAM_ERROR;

  end	PROCESS_SYNTAX_ERROR;
	--------------------



			---
  procedure		GET			( THE_TOKEN :out TOKEN )
			---
  is
    use TEXT_IO;
    C	: CHARACTER;
  begin
    THE_TOKEN := ( KIND=> END_TOKEN );

			-----------
			SKIP_BLANKS:
    loop
      if  END_OF_FILE( FILE )  then  return;  end if;
      GET( FILE, C );
      exit when  not (C = ' '  or  C = ASCII.HT);
      if  END_OF_FILE( FILE )  then  return;  end if;

    end loop	SKIP_BLANKS;
		-----------

    if  DEBUG
    then
      PUT( C & TEXT_IO.COUNT'IMAGE( TEXT_IO.LINE( FILE ) ) & ':'
	   & TEXT_IO.COUNT'IMAGE( TEXT_IO.COL(FILE )-1 ) & '.' );
    end if;

    case  C  is

      when  '{'
	  => THE_TOKEN := ( KIND=> LEFT_ACCOLADE  );

      when  '}'
	  => THE_TOKEN := ( KIND=> RIGHT_ACCOLADE );

      when  '['
	  => THE_TOKEN := ( KIND=> LEFT_CROCHET   );

      when  ']'
	  => THE_TOKEN := ( KIND=> RIGHT_CROCHET  );

      when  ','
	  => THE_TOKEN := ( KIND=> COMMA );

      when  ':'
	  => THE_TOKEN := ( KIND=> COLON );

      when  '"'
	  =>		------------
			GET_A_STRING:
        declare
	LEN		: NATURAL		:= 0;
	INDEX_BUFFER	: POSITIVE	:= 1;
        begin
	loop
	  GET( FILE, C );

	  if  DEBUG
	  then
	    PUT( C & TEXT_IO.COUNT'IMAGE( TEXT_IO.LINE( FILE ) ) & ':'
		 & TEXT_IO.COUNT'IMAGE( TEXT_IO.COL( FILE )-1 ) & '.' );
	  end if;

            exit when  C = '"';
	  TOKEN_BUFFER( INDEX_BUFFER ) := C;
	  LEN := LEN + 1;
	  INDEX_BUFFER := INDEX_BUFFER + 1;
	end loop;
	THE_TOKEN := ( KIND=> CHAINE, STR_LENGTH=> LEN );

        end	GET_A_STRING;
		------------

      when  others
	  => raise SYNTAX_ERROR;

    end case;

    if  DEBUG
    then
      PUT( "token " & TOKEN_TYPE'IMAGE( THE_TOKEN.KIND ) & " at"
	 & TEXT_IO.COUNT'IMAGE( TEXT_IO.LINE( FILE ) ) & ':'
	 & TEXT_IO.COUNT'IMAGE( TEXT_IO.COL( FILE )-1 )
         );
      if THE_TOKEN.KIND = CHAINE
      then  PUT_LINE( "  " & '"' & TOKEN_BUFFER( 1 .. THE_TOKEN.STR_LENGTH ) & '"' );
      else  NEW_LINE;
      end if;
    end if;

  exception
    when END_ERROR | SYNTAX_ERROR => PROCESS_SYNTAX_ERROR;

  end	GET;
	---



			----------
  procedure		GET_VERIFY	( WHAT_IS_EXPECTED :TOKEN_TYPE; THE_TOKEN :out TOKEN )
			----------
  is
  begin
    GET( THE_TOKEN );
    if  THE_TOKEN.KIND /= WHAT_IS_EXPECTED
    then
      PROCESS_SYNTAX_ERROR( ENCOUNTERED=> THE_TOKEN.KIND, EXPECTED=> WHAT_IS_EXPECTED );
    end if;

  end	GET_VERIFY;
	----------



  function  GET_OBJECT	return JSON.ITEM;
  function  GET_ARRAY	return JSON.ITEM;



			--------
  function		GET_ITEM		( THE_TOKEN :TOKEN )	return JSON.ITEM
			--------
  is
  begin

    case  THE_TOKEN.KIND  is

      when  LEFT_ACCOLADE
	  => return GET_OBJECT;

      when  LEFT_CROCHET
	  => return GET_ARRAY;

      when  CHAINE
 	  => return new ITEM_DEFINITION'( KIND=> STRING_ITEM,
				    STR_ACCESS=> new STRING'(TOKEN_BUFFER( 1 .. THE_TOKEN.STR_LENGTH )) );

      when  ENTIER
	  => return new ITEM_DEFINITION'( KIND=> INTEGER_ITEM, INT_VAL=> THE_TOKEN.INT_VALUE );

      when  FLOTTANT
	  => return new ITEM_DEFINITION'( KIND=> FLOAT_ITEM, FLOAT_VAL=> THE_TOKEN.FLOAT_VALUE );

      when  others
	  => raise SYNTAX_ERROR;

    end case;

  exception
    when SYNTAX_ERROR
         => PROCESS_SYNTAX_ERROR( THE_TOKEN.KIND );
	  raise PROGRAM_ERROR;

  end	GET_ITEM;
	--------



			----------
    function		GET_OBJECT		return JSON.ITEM
			----------
    is
      THE_TOKEN		: TOKEN;
      FIELDS_LIST_HEAD,
      FIELDS_LIST_LAST	: OBJECT_FIELD_ACCESS	:= null;

    begin
      GET( THE_TOKEN );
      if  THE_TOKEN.KIND = RIGHT_ACCOLADE  then  return new ITEM_DEFINITION'( OBJECT_ITEM, null );  end if;
      if  THE_TOKEN.KIND /= CHAINE  then  PROCESS_SYNTAX_ERROR;  end if;

      loop

        declare
	KEY	: STRING_ACCESS		:= new STRING'(TOKEN_BUFFER( 1 .. THE_TOKEN.STR_LENGTH ));
	OFA	: OBJECT_FIELD_ACCESS;
        begin
	GET_VERIFY( COLON, THE_TOKEN );
	GET( THE_TOKEN );
	OFA := new OBJECT_FIELD'( KEY, GET_ITEM( THE_TOKEN ), null );

	if  FIELDS_LIST_HEAD = null  then
	  FIELDS_LIST_HEAD := OFA; FIELDS_LIST_LAST := OFA;
	else
	  FIELDS_LIST_LAST.all.NEXT := OFA; FIELDS_LIST_LAST := OFA;
	end if;
        end;

        GET( THE_TOKEN );
        if  THE_TOKEN.KIND = COMMA
        then
	GET_VERIFY( CHAINE, THE_TOKEN );
        else
	if  THE_TOKEN.KIND /= RIGHT_ACCOLADE
	then
	  PROCESS_SYNTAX_ERROR( ENCOUNTERED=> THE_TOKEN.KIND, EXPECTED=> RIGHT_ACCOLADE );
	end if;
	exit;
        end if;

      end loop;

      return new ITEM_DEFINITION'( OBJECT_ITEM, FIELDS_LIST_HEAD );

    end	GET_OBJECT;
	----------


			---------
    function		GET_ARRAY			return JSON.ITEM
			---------
    is
      THE_TOKEN		: TOKEN;
      STRUC_LIST_HEAD,
      STRUC_LIST_LAST	: LIST_OF_ITEMS	:= null;

    begin
      GET( THE_TOKEN );
      if  THE_TOKEN.KIND = RIGHT_CROCHET  then  return new ITEM_DEFINITION'( ARRAY_ITEM, null );  end if;

			-------------
			PROCESS_ITEMS:
      loop

        declare
	LOI	: LIST_OF_ITEMS	:= new ITEM_LIST_ELEMENT'( GET_ITEM( THE_TOKEN ), null );
        begin
	if  STRUC_LIST_HEAD = null  then
	  STRUC_LIST_HEAD := LOI; STRUC_LIST_LAST := LOI;
	else
	  STRUC_LIST_LAST.all.NEXT := LOI; STRUC_LIST_LAST := LOI;
	end if;
        end;

        GET( THE_TOKEN );
        if  THE_TOKEN.KIND = COMMA
        then
	GET( THE_TOKEN );
        else
	if  THE_TOKEN.KIND = RIGHT_CROCHET
	then  exit PROCESS_ITEMS;
	else  PROCESS_SYNTAX_ERROR( ENCOUNTERED=> THE_TOKEN.KIND, EXPECTED=> RIGHT_CROCHET );
	end if;
        end if;

      end loop	PROCESS_ITEMS;
		-------------

      return new ITEM_DEFINITION'( ARRAY_ITEM, STRUC_LIST_HEAD );

    end	GET_ARRAY;
	----------



			-----------
    function		READ_OBJECT		return JSON.ITEM
  			-----------
    is
      THE_TOKEN	: TOKEN;
    begin
      GET( THE_TOKEN );
      if  THE_TOKEN.KIND = LEFT_ACCOLADE  then
        return GET_OBJECT;
      else  raise SYNTAX_ERROR;
      end if;

    exception
      when SYNTAX_ERROR
	  => PROCESS_SYNTAX_ERROR;
	     raise PROGRAM_ERROR;

    end	READ_OBJECT;
	-----------


		------
  end		PARSER;
		------

--	1	2	3	4	5	6	7	8	9	0	1	2
-------------------------------------------------------------------------------------------------------------------------


  begin
    THE_ITEM := PARSER.READ_OBJECT;

  end	GET;
	---

			---
  procedure		PUT		( FILE :in out JSON.FILE_TYPE; THE_ITEM :ITEM )
			---
  is
			  -------
    procedure		  LAY_ONE		( ITEM :JSON.ITEM; AT_COL :TEXT_IO.COUNT )
			  -------
    is
      use TEXT_IO;
			    -----------------
      procedure		    PUT_OBJECT_FIELDS	( OF_OBJECT :JSON.ITEM )
			    -----------------
      is
			      -----------------
        procedure		      PROCESS_ONE_FIELD	( KEY	     :STRING;
						  ITEM	     :in out JSON.ITEM;
						  LAST_ONE     :in BOOLEAN;
						  STOP_PROCESS :out BOOLEAN )
			      -----------------
        is
        begin
	SET_COL( AT_COL+2 );
	PUT( '"' & KEY & '"' & " : " );

	LAY_ONE( ITEM, TEXT_IO.COL );

	if  not LAST_ONE  then  PUT( ',' );  end if; NEW_LINE;
	STOP_PROCESS := FALSE;

        end	  PROCESS_ONE_FIELD;
		  -----------------

        procedure PUT_FOR_EACH_FIELD is new FOR_EACH_JSON_FIELD( PROCESS_ONE_FIELD );

      begin
	PUT_FOR_EACH_FIELD( OF_OBJECT );

      end	PUT_OBJECT_FIELDS;
	-----------------

			    ---------------
      procedure		    PUT_ARRAY_ITEMS	(THE_ITEM :JSON.ITEM )
			    ---------------
      is
        START_COL	: TEXT_IO.COUNT	:= TEXT_IO.COL;

			      ----------------
	procedure		      PROCESS_ONE_ITEM	( ITEM	     :in out JSON.ITEM;
						  LAST_ONE     :in BOOLEAN;
						  STOP_PROCESS :out BOOLEAN )
			      ----------------
	is
	begin
	  NEW_LINE;

	  LAY_ONE( ITEM, START_COL+2 );

	  if  not LAST_ONE  then  PUT( ',' );  end if;
	  STOP_PROCESS := FALSE;

	end	    PROCESS_ONE_ITEM;
		    ----------------

	procedure PUT_FOR_EACH_ITEM is new FOR_EACH_JSON_ITEM( PROCESS_ONE_ITEM );

      begin
        PUT_FOR_EACH_ITEM( ITEM );

      end	PUT_ARRAY_ITEMS;
	---------------

    begin
      SET_COL( AT_COL );

      case KIND( ITEM ) is

      when OBJECT_ITEM
	 =>
	 PUT( '{' );
	 PUT_OBJECT_FIELDS( ITEM );
	 SET_COL( AT_COL+1 );
	 PUT( '}' );

      when ARRAY_ITEM
	 =>
	 PUT( '[' );
	 PUT_ARRAY_ITEMS( ITEM );
	 SET_COL( AT_COL+1 );
	 PUT( ']' );

      when STRING_ITEM
	 =>
	 PUT( '"' & ITEM.all.STR_ACCESS.all & '"' );

      when INTEGER_ITEM
	 =>
	 PUT( INTEGER'IMAGE( ITEM.all.INT_VAL ) );

      when FLOAT_ITEM
	 =>
	 declare
	  package LONG_FLOAT_IO	is new FLOAT_IO( LONG_FLOAT );
	  begin
	    LONG_FLOAT_IO.PUT( ITEM.all.FLOAT_VAL );
	  end;

      when BOOLEAN_ITEM
	 =>
	 PUT( BOOLEAN'IMAGE( ITEM.all.BOOL_VAL ) );

      when NULL_ITEM
	 =>
	 PUT( "null" );

      end case;

    end	  LAY_ONE;
	  -------

  begin
    TEXT_IO.SET_OUTPUT( FILE );
    LAY_ONE( THE_ITEM, AT_COL=> 1 );
    TEXT_IO.SET_OUTPUT( TEXT_IO.STANDARD_OUTPUT );

  end	PUT;
	---


			---------
  function		STRING_OF		( THE_ITEM : ITEM)			return STRING
			---------
  is
    TEMP_FILE_NAME	:constant STRING	:= "JSON$$$.tmp";
  begin
		------------------
		WRITE_ITEM_TO_FILE:
    declare
      TEMP_FILE	: TEXT_IO.FILE_TYPE;
      use TEXT_IO;
    begin
      CREATE( TEMP_FILE, OUT_FILE, TEMP_FILE_NAME );
      JSON.PUT( TEMP_FILE, THE_ITEM );
      CLOSE( TEMP_FILE );

    end	WRITE_ITEM_TO_FILE;
	------------------

		-------------------
		READ_FILE_TO_STRING:
    declare
      package CHAR_IO is new DIRECT_IO( CHARACTER );
      use CHAR_IO;
      TEMP_FILE	: CHAR_IO.FILE_TYPE;
    begin
      CHAR_IO.OPEN( TEMP_FILE, IN_FILE, TEMP_FILE_NAME );
      declare
        ITEM_STRING_LENGTH	:constant INTEGER	:= INTEGER( CHAR_IO.SIZE( TEMP_FILE ) );
        ITEM_STRING		: STRING( 1 .. ITEM_STRING_LENGTH );
      begin
        for I in ITEM_STRING'RANGE loop
	READ( TEMP_FILE, ITEM_STRING( I ) );
        end loop;
        DELETE( TEMP_FILE );
        return  ITEM_STRING;
      end;

    end	READ_FILE_TO_STRING;
	-------------------

  end	STRING_OF;
	---------



			-------
  function		ITEM_OF		( THE_STRING :STRING)		return ITEM
  			-------
  is
    TEMP_FILE_NAME	:constant STRING	:= "JSON$$$.tmp";
    OUT_ITEM	: ITEM;

  begin
    declare
      package CHAR_IO is new DIRECT_IO( CHARACTER );
      use CHAR_IO;
      TEMP_FILE	: CHAR_IO.FILE_TYPE;
    begin
      CREATE( TEMP_FILE, OUT_FILE, TEMP_FILE_NAME );
      for I in THE_STRING'RANGE loop
        WRITE( TEMP_FILE, THE_STRING( I ) );
      end loop;
      CLOSE( TEMP_FILE );
    end;

    declare
      use TEXT_IO;
      TEMP_FILE	: JSON.FILE_TYPE;
    begin
      TEXT_IO.OPEN( TEMP_FILE, IN_FILE, TEMP_FILE_NAME );
      JSON.GET( TEMP_FILE, OUT_ITEM );
      OPEN( TEMP_FILE, IN_FILE, TEMP_FILE_NAME );
      DELETE( TEMP_FILE );
    end;
    return  OUT_ITEM;

  end	ITEM_OF;
	-------



			--  J S O N   S T R U C T U R E   I N T E R A C T I O N


			----
  function 		KIND		( OF_ITEM :ITEM )		return ITEM_TYPE
  is
  begin
    return  OF_ITEM.all.KIND;

  end	KIND;
	----



			----------
  function 		IS_PRESENT	( KEY :STRING; IN_OBJECT :ITEM )	return BOOLEAN
  			----------
  is
    SEARCH_KEY	: STRING		renames KEY;
    KEY_SEEN	: BOOLEAN		:= FALSE;

		-------
    procedure	PROCESS	( THE_KEY	     :STRING;
			  THE_ITEM     :in out ITEM;
			  LAST_ONE     :in BOOLEAN;
			  STOP_PROCESS :out BOOLEAN )
    is		-------
    begin
      if  THE_KEY = SEARCH_KEY  then  KEY_SEEN := TRUE;  end if;
      STOP_PROCESS := KEY_SEEN;

    end	PROCESS;
	-------

    procedure SCAN is new FOR_EACH_JSON_FIELD( PROCESS );


  begin
    if  IN_OBJECT.all.KIND /= OBJECT_ITEM  then  raise BAD_ITEM_TYPE;  end if;

    SCAN( IN_OBJECT );
    return  KEY_SEEN;

  end	IS_PRESENT;
	----------



			-----------
  function		ITEM_BY_KEY	( KEY :STRING; IN_OBJECT :ITEM )	return ITEM
			-----------
  is
    SEARCH_KEY		: STRING		renames KEY;
    FOUND_ITEM		: ITEM		:= null;

		-------
    procedure	PROCESS	( THE_KEY	     :STRING;
			  THE_ITEM     :in out ITEM;
			  LAST_ONE     :in BOOLEAN;
			  STOP_PROCESS :out BOOLEAN )
    is		-------
    begin
      if  THE_KEY = SEARCH_KEY  then  FOUND_ITEM := THE_ITEM;  end if;
      STOP_PROCESS := (FOUND_ITEM /= null);

    end	PROCESS;
	-------

    procedure SCAN is new FOR_EACH_JSON_FIELD( PROCESS );


  begin
    if  IN_OBJECT.all.KIND /= OBJECT_ITEM  then  raise BAD_ITEM_TYPE;  end if;

    SCAN( IN_OBJECT );
    if  FOUND_ITEM = null  then  raise VALUE_NOT_FOUND;  end if;
    return  FOUND_ITEM;

  end	ITEM_BY_KEY;
	------------



			----------
  function		ITEM_VALUE		( OF_ITEM :ITEM )		return VALUE_DATA
			----------
  is
  begin
    case KIND( OF_ITEM ) is

      when OBJECT_ITEM | ARRAY_ITEM
	 =>
	  raise BAD_ITEM_TYPE;

      when STRING_ITEM
	 =>
	  declare
	    THE_STRING	: STRING	renames	OF_ITEM.all.STR_ACCESS.all;
	    STRING_LENGTH	:constant NATURAL	:= THE_STRING'LENGTH;
	  begin
	    return ( STRING_ITEM, STRING_LENGTH, THE_STRING );
	  end;

      when INTEGER_ITEM
	 =>
	  return ( INTEGER_ITEM, 0, OF_ITEM.all.INT_VAL );

      when FLOAT_ITEM
	 =>
	  return ( FLOAT_ITEM, 0, OF_ITEM.all.FLOAT_VAL );

      when BOOLEAN_ITEM
	 =>
	  return ( BOOLEAN_ITEM, 0, OF_ITEM.all.BOOL_VAL );

      when NULL_ITEM
	 =>
	  return ( NULL_ITEM, 0 );

      end case;

  end	ITEM_VALUE;
	----------



			-------------------
  function		NUMBER_OF_SUB_ITEMS		( IN_ITEM :ITEM )		return NATURAL
			-------------------
  is
    COUNT		: NATURAL	:= 0;
  begin
     case KIND( IN_ITEM ) is

      when OBJECT_ITEM
	 =>
	  declare
	    THE_LIST	: OBJECT_FIELD_ACCESS	:= IN_ITEM.all.FIELDS_LIST;
	  begin
	    while  THE_LIST /= null  loop
	      COUNT := COUNT + 1;
	      THE_LIST := THE_LIST.all.NEXT;
	    end loop;
	  end;

      when ARRAY_ITEM
	 =>
	  declare
	    THE_LIST	: LIST_OF_ITEMS	:= IN_ITEM.all.ITEMS_LIST;
	  begin
	    while  THE_LIST /= null  loop
	      COUNT := COUNT + 1;
	      THE_LIST := THE_LIST.all.NEXT;
	    end loop;
	  end;

      when others => null;

      end case;
      return COUNT;

  end	NUMBER_OF_SUB_ITEMS;
	-------------------



			----
  procedure		FREE			( THE_ITEM :in out ITEM )
			----
  is
    procedure FREE is new UNCHECKED_DEALLOCATION( ITEM_DEFINITION, ITEM );
    procedure FREE is new UNCHECKED_DEALLOCATION( OBJECT_FIELD, OBJECT_FIELD_ACCESS );
    procedure FREE is new UNCHECKED_DEALLOCATION( ITEM_LIST_ELEMENT, LIST_OF_ITEMS );
    procedure FREE is new UNCHECKED_DEALLOCATION( STRING, STRING_ACCESS );
  begin
     case KIND( THE_ITEM ) is

      when OBJECT_ITEM
	 =>
	  declare
	    THE_LIST	: OBJECT_FIELD_ACCESS	:= THE_ITEM.all.FIELDS_LIST;
	    SUITE		: OBJECT_FIELD_ACCESS;
	  begin
	    while  THE_LIST /= null  loop
	      FREE( THE_LIST.all.FIELD_KEY );
	      FREE( THE_LIST.all.FIELD_ITEM );
	      SUITE := THE_LIST.all.NEXT;
	      FREE( THE_LIST );
	      THE_LIST := SUITE;
	    end loop;
	  end;

      when ARRAY_ITEM
	 =>
	  declare
	    THE_LIST	: LIST_OF_ITEMS	:= THE_ITEM.all.ITEMS_LIST;
	    SUITE		: LIST_OF_ITEMS;
	  begin
	    while  THE_LIST /= null  loop
	      FREE( THE_LIST.all.LIST_ITEM );
	      SUITE := THE_LIST.all.NEXT;
	      FREE( THE_LIST );
	      THE_LIST := SUITE;
	    end loop;
	  end;

      when others => null;

      end case;

      THE_ITEM.all := ( KIND=> NULL_ITEM );

  end	FREE;
	----



			------------------
  procedure		FOR_EACH_JSON_ITEM		( OF_ARRAY :JSON.ITEM )
			------------------
  is
  begin
    if  OF_ARRAY = null  or else  OF_ARRAY.all.KIND /= ARRAY_ITEM  then  raise BAD_ITEM_TYPE;  end if;

    declare
      STOP_PROCESS		: BOOLEAN;
      ITEM_LIST		: LIST_OF_ITEMS	:= OF_ARRAY.all.ITEMS_LIST;
      LAST_ONE		: BOOLEAN;
    begin
      loop
        exit when  ITEM_LIST = null;
        LAST_ONE := (ITEM_LIST.all.NEXT = null);
        APPLY_PROCESS( ITEM_LIST.all.LIST_ITEM, LAST_ONE, STOP_PROCESS );
        exit when  STOP_PROCESS;
        ITEM_LIST := ITEM_LIST.all.NEXT;
      end loop;
    end;

  end	FOR_EACH_JSON_ITEM;
	------------------



			-------------------
  procedure		FOR_EACH_JSON_FIELD		( OF_OBJECT :JSON.ITEM )
			-------------------
  is
  begin
    if  OF_OBJECT = null  or else  OF_OBJECT.all.KIND /= OBJECT_ITEM  then  raise BAD_ITEM_TYPE;  end if;

    declare
      FIELDS		: OBJECT_FIELD_ACCESS	:= OF_OBJECT.all.FIELDS_LIST;
      STOP_PROCESS		: BOOLEAN;
      LAST_ONE		: BOOLEAN;
    begin
      while  FIELDS /= null  loop
        LAST_ONE := (FIELDS.all.NEXT = null);
        APPLY_PROCESS( FIELDS.all.FIELD_KEY.all, FIELDS.all.FIELD_ITEM, LAST_ONE, STOP_PROCESS );
        exit when  STOP_PROCESS;
        FIELDS := FIELDS.all.NEXT;
      end loop;
    end;

  end	FOR_EACH_JSON_FIELD;
	-------------------



	----
end	JSON;
	----

--	1	2	3	4	5	6	7	8	9	0	1	2
-------------------------------------------------------------------------------------------------------------------------

</pre>