------------------------------------------------------------------------------ -- Common declarations across most of BUSH including -- -- command line switches and the symbol table. -- -- -- -- Part of BUSH -- ------------------------------------------------------------------------------ -- -- -- Copyright (C) 2001-2005 Ken O. Burtch & FSF -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. This is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with this; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- This is maintained at http://www.pegasoft.ca -- -- -- ------------------------------------------------------------------------------ -- CVS: $Id: world.adb,v 1.3 2005/06/24 01:01:18 ken Exp $ pragma warnings( off ); -- suppress Gnat-specific package warning with ada.command_line.environment; pragma warnings( on ); with system, ada.text_io, ada.strings.fixed, ada.strings.unbounded.text_io, ada.characters.handling, bush_os, scanner_arrays; use ada.text_io, ada.command_line, ada.command_line.environment, ada.strings.fixed, ada.strings.unbounded, ada.strings.unbounded.text_io, ada.characters.handling, bush_os, scanner_arrays; pragma Optimize( time ); package body world is -- -- Symbol Table Utilities -- procedure declareKeyword( id : out identifier; s : string ) is -- Initialize a keyword / internal identifier in the symbol table begin if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- else add id := identifiers_top; -- return id identifiers_top := identifiers_top + 1; -- push stack declare kw : declaration renames identifiers( id ); begin kw.name := To_Unbounded_String( s ); kw.kind := identifier'first; kw.value := Null_Unbounded_String; kw.class := otherClass; -- since keywords are only declared at startup, -- the defaults should be OK for remaining fields. end; end if; end declareKeyword; procedure declareFunction( id : out identifier; s : string ) is -- Initialize a built-in function identifier in the symbol table begin if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- else add id := identifiers_top; -- return id identifiers_top := identifiers_top + 1; -- push stack declare kw : declaration renames identifiers( id ); begin kw.name := To_Unbounded_String( s ); kw.kind := identifier'first; kw.value := Null_Unbounded_String; kw.class := funcClass; end; end if; end declareFunction; procedure declareProcedure( id : out identifier; s : string ) is -- Initialize a built-in procedure identifier in the symbol table begin if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- else add id := identifiers_top; -- return id identifiers_top := identifiers_top + 1; -- push stack declare kw : declaration renames identifiers( id ); begin kw.name := To_Unbounded_String( s ); kw.kind := identifier'first; kw.value := Null_Unbounded_String; kw.class := procClass; end; end if; end declareProcedure; function deleteIdent( id : identifier ) return boolean is -- Delete a keyword / identifier from the symbol table --kind : identifiers; begin if id >= identifiers_top then -- id > top? return false; -- delete fail elsif identifiers( id ).deleted then -- flagged? return false; -- delete fail elsif id = identifiers_top-1 then -- last id? --kind := identifiers( id ).kind; -- don't delete array types, just array vars. if identifiers( id ).list and identifiers( id ).class = otherClass then -- Note: You can't discard the array type: others may be using it. -- Destroying an array will also shift the other array id numbers -- since they are in a linked list! clearArray( arrayID( to_numeric( identifiers( id ).value ) ) ); end if; identifiers_top := identifiers_top - 1; -- pull stack return true; -- delete ok end if; -- else if identifiers( id ).list and identifiers( id ).class = otherClass then clearArray( arrayID( to_numeric( identifiers( id ).value ) ) ); end if; identifiers( id ).deleted := true; -- flag it -- When a variable with the same name is encountered, it will be -- reinitialized with a Kind of new but these will remain unchanged. -- Reset these to defaults to avoid confusing Bush... identifiers( id ).import := false; -- clear these identifiers( id ).export := false; identifiers( id ).list := false; identifiers( id ).field_of := eof_t; identifiers( id ).volatile := false; identifiers( id ).limit := false; identifiers( id ).inspect := false; identifiers( id ).class := otherClass; return true; -- delete ok end deleteIdent; procedure findIdent( name : unbounded_string; id : out identifier ) is -- Return the id of a keyword / identifier in the symbol table. If -- it is not found, return the end-of-file token as the id begin id := eof_t; -- assume bad for i in reverse 1..identifiers_top-1 loop -- from top if i /= eof_t then if identifiers( i ).name = name and not -- exists and identifiers( i ).deleted then -- not deleted? id := i; -- return id exit; -- we're done end if; end if; end loop; end findIdent; procedure init_env_ident( s : string ) is -- Declare an operating system environment variable. 's' is the -- variable string returned by get_env ("var=value" format). eqpos : natural := 0; -- position of the '=' in s begin if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- otherwise for i in 1..s'length loop -- find '=' if s(i) = '=' then -- found? eqpos := i; -- remember exit; -- and done end if; end loop; identifiers( identifiers_top ) := declaration'( -- define name => To_Unbounded_String( s(1..eqpos-1) ), -- identifier kind => string_t, value => To_Unbounded_String( s(eqpos+1..s'length ) ), class => otherClass, import => true, -- must import export => false, volatile => false, limit => false, list => false, field_of => eof_t, inspect => false, deleted => false ); identifiers_top := identifiers_top + 1; -- push stack end if; end init_env_ident; procedure declareIdent( id : out identifier; name : unbounded_string; kind : identifier; class : anIdentifierClass := otherClass ) is -- Declare an identifier in the symbol table, specifying name, kind. -- and (optionally) symbol class. The id is returned. begin if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- otherwise id := identifiers_top; -- return id identifiers_top := identifiers_top+1; -- push stack identifiers( id ) := declaration'( -- define name => name, -- identifier kind => kind, value => Null_Unbounded_String, class => class, import => false, export => false, volatile => false, limit => false, list => false, field_of => eof_t, inspect => false, deleted => false ); end if; end declareIdent; procedure declareIdent( id : out identifier; name : string; kind : identifier; class : anIdentifierClass := otherClass ) is -- Alternate version: use fixed string type for name begin declareIdent( id, to_unbounded_string( name ), kind, class ); end declareIdent; procedure declareStandardConstant( id : out identifier; name : string; kind : identifier; value : string ) is -- Declare a standard constant in the symbol table. The id is not -- returned since we don't change with constants once they are set. begin if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- otherwise declare sc : declaration renames identifiers( identifiers_top ); begin sc.name := to_unbounded_string( name ); -- define sc.kind := kind; -- identifier sc.value := to_unbounded_string( value ); sc.class := constClass; sc.field_of := eof_t; -- since this is only called at startup, the default -- values for the other fields should be OK end; id := identifiers_top; identifiers_top := identifiers_top+1; -- push stack end if; end declareStandardConstant; procedure declareStandardConstant( name : string; kind : identifier; value : string ) is -- Alternative version: return the symbol table id discard_id : identifier; begin declareStandardConstant( discard_id, name, kind, value ); -- declare it end declareStandardConstant; procedure updateFormalParameter( id : identifier; kind : identifier; proc_id : identifier; parameterNumber : integer ) is -- Update a formal parameter (ie. proc.param). The id is not -- returned since we don't change the formal parameters once they are set. begin if parameterNumber = 0 then -- function result? no name suffix identifiers(id).name := identifiers( id ).name; else identifiers(id).name := identifiers( proc_id ).name & "." & identifiers( id ).name; end if; identifiers(id).value := to_unbounded_string( parameterNumber'img ); identifiers(id).class := constClass; identifiers(id).kind := kind; identifiers(id).import := false; identifiers(id).export := false; identifiers(id).volatile := false; identifiers(id).limit := false; identifiers(id).list := false; identifiers(id).field_of := proc_id; identifiers(id).inspect := false; identifiers(id).deleted := false; end updateFormalParameter; procedure declareActualParameter( id : out identifier; proc_id : identifier; parameterNumber : integer; value : unbounded_string ) is -- parameterNumber : integer ); -- Declare an actual parameter (ie. param for proc.param). paramName : unbounded_string; begin id := eof_t; for i in reverse reserved_top..identifiers_top-1 loop if identifiers( i ).field_of = proc_id then if integer'value( to_string( identifiers( i ).value )) = parameterNumber then paramName := identifiers( i ).name; paramName := delete( paramName, 1, index( paramName, "." )); if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- otherwise id := identifiers_top; -- return id identifiers_top := identifiers_top+1; -- push stack identifiers( id ) := declaration'( -- define name => paramName, -- identifier kind => identifiers( i ).kind, value => value, class => constClass, import => false, export => false, volatile => false, limit => false, list => false, field_of => eof_t, inspect => false, deleted => false ); end if; end if; end if; end loop; end declareActualParameter; procedure declareReturnResult( id : out identifier; func_id : identifier ) is -- Declare space for a return result for a user-defined function. This is -- effectively param 0 except that the value isn't zero...it's the return -- result. paramName : unbounded_string; begin paramName := "return result for " & identifiers( func_id ).name; if identifiers_top = identifier'last then -- no room? raise symbol_table_overflow; -- raise error else -- otherwise id := identifiers_top; -- return id identifiers_top := identifiers_top+1; -- push stack identifiers( id ) := declaration'( -- define name => paramName, -- identifier kind => identifiers( func_id ).kind, value => null_unbounded_string, class => constClass, import => false, export => false, volatile => false, limit => false, list => false, field_of => eof_t, inspect => false, deleted => false ); end if; end declareReturnResult; -- Type Conversions function to_numeric( s : unbounded_string ) return long_float is -- Convert an unbounded string to a long float (BUSH's numeric representation) begin if Element( s, 1 ) = '-' then -- leading -? return long_float'value( to_string( s ) ); -- OK for 'value elsif Element( s, 1 ) = ' ' then -- leading space? return long_float'value( to_string( s ) ); -- OK for 'value else -- otherwise add return long_float'value( " " & to_string( s ) ); -- space & 'value end if; end to_numeric; function to_numeric( id : identifier ) return long_float is -- Look up an identifier's value and return it as a long float -- (BUSH's numeric representation). begin return to_numeric( identifiers( id ).value ); end to_numeric; function to_unbounded_string( f : long_float ) return unbounded_string is -- Convert a long_float (BUSH's numeric representation) to an -- unbounded string. If the value is representable as an integer, -- it is returned without a decimal part. f_trunc : long_float := long_float'truncation( f ); begin -- integer value? Try to return without a decimal part -- provided it will fit into a long float's mantissa. if f - f_trunc = 0.0 then -- There's no guarantee that a long_long_integer will fit into -- a long_float's mantissa, so we'll use a decimal type. if f <= long_float( integerOutputType'last ) and f >= long_float( integerOutputType'first ) then return to_unbounded_string( long_long_integer( f )'img ); end if; end if; -- Otherwise, return a long float using 'image return to_unbounded_string( long_float'image( f ) ); end to_unbounded_string; function To_Bush_Boolean( AdaBoolean : boolean ) return unbounded_string is -- convert an Ada boolean into a BUSH boolean (a string containing -- the position, no leading blank). begin return To_Unbounded_String( integer'image( boolean'pos( AdaBoolean ) )(2)&"" ); end To_Bush_Boolean; ----------------------------------------------------------------------------- -- IS KEYWORD -- -- TRUE if the identifier is a keyword. ----------------------------------------------------------------------------- function is_keyword( id : identifier ) return boolean is -- True if an AdaScript keyword. Keywords are defined in the -- first part of the indentifier table. begin return id < reserved_top; end is_keyword; ----------------------------------------------------------------------------- -- TO HIGH ASCII -- -- Set the high bit (bit 8) on a low ASCII (7 bit) character. Also, same for -- an identifier to a high ASCII character. ----------------------------------------------------------------------------- function toHighASCII( ch : character ) return character is pragma suppress( RANGE_CHECK ); -- GCC 3.3.3 (Red Hat Fedora Core 2) falsely reports a out-of-range -- exception. We'll do the range checking manually as a work around... begin if ch > ASCII.DEL then put_line( standard_error, "Internal error: cannot set high bit on character" & character'pos( ch )'img ); raise PROGRAM_ERROR; end if; return character'val( 128+character'pos( ch ) ); end toHighASCII; function toHighASCII( id : identifier ) return character is pragma suppress( RANGE_CHECK ); -- GCC 3.3.3 (Red Hat Fedora Core 2) falsely reports a out-of-range -- exception. We'll do the range checking manually as a work around... begin if id > 127 then put_line( standard_error, "Internal error: cannot set high bit on identifier number" & id'img ); raise PROGRAM_ERROR; end if; return character'val( 128+integer(id) ); end toHighASCII; ----------------------------------------------------------------------------- -- TO LOW ASCII -- -- Clear the high bit (bit 8) on a high ASCII (7 bit) character. Also, same -- for an identifier to a low ASCII character. ----------------------------------------------------------------------------- function toLowASCII( ch : character ) return character is pragma suppress( RANGE_CHECK ); -- GCC 3.3.3 (Red Hat Fedora Core 2) falsely reports a out-of-range -- exception. We'll do the range checking manually as a work around... begin if ch <= ASCII.DEL then put_line( standard_error, "Internal error: cannot clear high bit on character" & character'pos( ch )'img ); raise PROGRAM_ERROR; end if; return character'val( character'pos( ch )-128 ); end toLowASCII; function toLowASCII( id : identifier ) return character is pragma suppress( RANGE_CHECK ); -- GCC 3.3.3 (Red Hat Fedora Core 2) falsely reports a out-of-range -- exception. We'll do the range checking manually as a work around... begin if id <= 128 then put_line( standard_error, "Internal error: cannot clear high bit on identifier number" & id'img ); raise PROGRAM_ERROR; end if; return character'val( integer(id)-128 ); end toLowASCII; function ">"( left, right : aShellWord ) return boolean is begin return left.word > right.word; end ">"; function ">"( left, right : aSourceFile ) return boolean is begin return left.name > right.name; end ">"; procedure findField( recordVar : identifier; fieldNumber: natural; fieldVar : out identifier ) is -- Find fieldNumber'th field of a record varable. This involves looking up the -- record type, searching for the type's fields, checking the type field's -- numbers, constructiong the name of the record's field, and finding it in -- the symbol table. This is not very fast but it works. recordType : identifier; begin recordType := identifiers( recordVar ).kind; fieldVar := eof_t; for candidateType in reverse reserved_top..identifiers_top-1 loop if identifiers( candidateType ).field_of = recordType then if integer'value( to_string( identifiers( candidateType ).value )) = fieldNumber then declare fieldName : unbounded_string; field_t : identifier; dotPos : natural; begin fieldName := identifiers( candidateType ).name; dotPos := length( fieldName ); while dotPos > 1 loop exit when element( fieldName, dotPos ) = '.'; dotPos := dotPos - 1; end loop; fieldName := delete( fieldName, 1, dotPos ); fieldName := identifiers( recordVar ).name & "." & fieldName; findIdent( fieldName, field_t ); fieldVar := field_t; end; end if; end if; end loop; end findField; end world;