------------------------------------------------------------------------------ -- BUSH AdaScript Language Parser -- -- -- -- 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: $Header: /home/cvsroot/bush/src/parser.adb,v 1.6 2005/08/31 15:10:44 ken Exp $ pragma warnings( off ); -- suppress Gnat-specific package warning with ada.command_line.environment; pragma warnings( on ); with system, ada.text_io.editing, ada.strings.unbounded.text_io, ada.characters.handling, ada.numerics.float_random, ada.calendar, gnat.regexp, gnat.directory_operations, cgi, bush_os.exec, bush_os.sound, string_util, user_io, script_io, builtins, jobs, signal_flags, parser_tio, parser_strings, parser_numerics, parser_arrays, parser_cal, parser_cgi, parser_cmd, parser_db, parser_mysql, parser_files, parser_lock, parser_units, parser_stats, parser_pen, parser_os, parser_dirops; use ada.text_io, ada.text_io.editing, ada.command_line, ada.command_line.environment, ada.strings.unbounded, ada.strings.unbounded.text_io, ada.characters.handling, gnat.regexp, gnat.directory_operations, bush_os, bush_os.exec, bush_os.sound, user_io, script_io, string_util, builtins, jobs, signal_flags, parser_tio, parser_strings, parser_numerics, parser_arrays, parser_cal, parser_cgi, parser_cmd, parser_db, parser_mysql, parser_files, parser_lock, parser_units, parser_stats, parser_pen, parser_os, parser_dirops; package body parser is --------------------------------------------------------- -- START OF ADASCRIPT PARSER --------------------------------------------------------- procedure RunAndCaptureOutput( s : unbounded_string; results : out unbounded_string; fragment : boolean := true ); -- forward declaration: this runs the commands found in string s procedure CompileRunAndCaptureOutput( commands : unbounded_string; results : out unbounded_string ); procedure ParseBasicShellWord( shell_word : out unbounded_string ) is -- Check token for a shell word. begin shell_word := null_unbounded_string; if token = symbol_t then if identifiers( token ).value = ";" then err( "shell word expected" ); end if; shell_word := identifiers( token ).value; getNextToken; elsif token = word_t then shell_word := identifiers( token ).value; getNextToken; elsif token = cd_t then shell_word := identifiers( token ).name; getNextToken; elsif token = clear_t then shell_word := identifiers( token ).name; getNextToken; elsif token = env_t then shell_word := identifiers( token ).name; getNextToken; elsif token = help_t then shell_word := identifiers( token ).name; getNextToken; elsif token = history_t then shell_word := identifiers( token ).name; getNextToken; elsif token = jobs_t then shell_word := identifiers( token ).name; getNextToken; elsif token = pwd_t then shell_word := identifiers( token ).name; getNextToken; elsif token = trace_t then shell_word := identifiers( token ).name; getNextToken; elsif token = unset_t then shell_word := identifiers( token ).name; getNextToken; elsif token = wait_t then shell_word := identifiers( token ).name; getNextToken; elsif token = alter_t then shell_word := identifiers( token ).name; getNextToken; elsif token = delete_t then shell_word := identifiers( token ).name; getNextToken; elsif token = insert_t then shell_word := identifiers( token ).name; getNextToken; elsif token = select_t then shell_word := identifiers( token ).name; getNextToken; elsif token = update_t then shell_word := identifiers( token ).name; getNextToken; elsif token = strlit_t then shell_word := identifiers( token ).value; discardUnusedIdentifier( token ); getNextToken; elsif identifiers( token ).kind = new_t then shell_word := identifiers( token ).name; discardUnusedIdentifier( token ); getNextToken; elsif token = number_t then err( optional_bold( "shell word") & " expected, not a " & optional_bold( "number" ) ); elsif token = strlit_t then err( optional_bold( "shell word" ) & " expected, not a " & optional_bold( "string literal" ) ); elsif token = charlit_t then err( optional_bold( "shell word" ) & " expected, not a " & optional_bold( "character literal" ) ); elsif token = backlit_t then err( optional_bold( "shell word" ) & " expected, not a " & optional_bold( "backquoted literal" ) ); elsif token = word_t then err( optional_bold( "shell word" ) & " expected, not a " & optional_bold( "(shell immediate) word" ) ); elsif token = eof_t then err( optional_bold( "shell word" ) & " or semi-colon expected" ); elsif is_keyword( token ) then err( optional_bold( "shell word" ) & " expected, not a " & optional_bold( "keyword" ) ); elsif token = symbol_t then err( optional_bold( "shell word" ) & " expected, not a " & optional_bold( "symbol" ) ); elsif identifiers( token ).field_of /= eof_t then err( optional_bold( "shell word" ) & " expected, not a " & optional_bold( "field of a record type" ) ); else err( "shell word expected" ); end if; --if identifiers( token ).kind /= new_t then --else -- err( "shell word expected" ); --end if; end ParseBasicShellWord; procedure ParseFieldIdentifier( record_id : identifier; id : out identifier ) is -- Expect a new identifier, or one declared in this scope, but -- if one from another scope it will need to be redeclared in -- this scope. Use this for record fields that might possibly -- be already declared in a different scope. -- The problem is that a field variable has a name of "r.f" not "f" as it -- appears in the source code. When testing for existence, we need to -- use the full name of the field variable. fieldName : unbounded_string; temp_id : identifier; begin id := eof_t; -- dummy if identifiers( token ).kind /= new_t then if token = number_t then err( optional_bold( "identifier") & " expected, not a " & optional_bold( "number" ) ); elsif token = strlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "string literal" ) ); elsif token = charlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "character literal" ) ); elsif token = backlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "backquoted literal" ) ); elsif token = word_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "(shell immediate) word" ) ); elsif token = eof_t then err( optional_bold( "identifier" ) & " expected" ); elsif is_keyword( token ) then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "keyword" ) ); elsif token = symbol_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "symbol" ) ); elsif identifiers( token ).field_of /= eof_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "field of a record type" ) ); else -- an existing token name fieldName := identifiers( record_id ).name & "." & identifiers( token ).name; findIdent( fieldName, temp_id ); if temp_id /= eof_t then err( "already declared " & optional_bold( to_string( fieldName ) ) ); else -- declare it declareIdent( id, fieldName, new_t, otherClass ); end if; end if; getNextToken; else -- a new token fieldName := identifiers( record_id ).name & "." & identifiers( token ).name; findIdent( fieldName, temp_id ); if temp_id /= eof_t then err( "already declared " & optional_bold( to_string( fieldName ) ) ); else -- declare it discardUnusedIdentifier( token ); declareIdent( id, fieldName, new_t, otherClass ); end if; getNextToken; end if; exception when symbol_table_overflow => err( optional_inverse( "too many identifiers (symbol table overflow)" ) ); end ParseFieldIdentifier; procedure ParseProcedureIdentifier( id : out identifier ) is -- Expect a new identifier, or one declared in this scope, but -- if one from another scope it will need to be redeclared in -- this scope. Use this for procedure names that might possibly -- be declared "forward". -- Also used for record field variables where the variables may -- be declared in a different scope. begin id := eof_t; -- dummy if identifiers( token ).kind /= new_t then if token = number_t then err( optional_bold( "identifier") & " expected, not a " & optional_bold( "number" ) ); elsif token = strlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "string literal" ) ); elsif token = charlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "character literal" ) ); elsif token = backlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "backquoted literal" ) ); elsif token = word_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "(shell immediate) word" ) ); elsif token = eof_t then err( optional_bold( "identifier" ) & " expected" ); elsif is_keyword( token ) then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "keyword" ) ); elsif token = symbol_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "symbol" ) ); elsif identifiers( token ).field_of /= eof_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "field of a record type" ) ); -- if old, don't redeclare if it was a forward declaration elsif identifiers( token ).class = userProcClass then -- a proc? if isLocal( token ) then -- local? if length( identifiers( token ).value ) = 0 then -- forward? id := token; -- then it's else -- not fwd? err( "already declared " & optional_bold( to_string( identifiers( token ).name ) ) ); end if; -- not local? else -- declare it declareIdent( id, identifiers( token ).name, identifiers( token ).kind, identifiers( token ).class); end if; -- otherwise elsif isLocal( token ) then err( "already declared " & optional_bold( to_string( identifiers( token ).name ) ) ); else -- create a new one in this scope declareIdent( id, identifiers( token ).name, identifiers( token ).kind, identifiers( token ).class); end if; getNextToken; else id := token; getNextToken; end if; exception when symbol_table_overflow => err( optional_inverse( "too many identifiers (symbol table overflow)" ) ); end ParseProcedureIdentifier; procedure ParseNewIdentifier( id : out identifier ) is -- expect a token that is a new, not previously declared identifier -- or one previously declared in a different scope that must be re-declared -- in this scope begin id := eof_t; -- dummy if identifiers( token ).kind /= new_t then if token = number_t then err( optional_bold( "identifier") & " expected, not a " & optional_bold( "number" ) ); elsif token = strlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "string literal" ) ); elsif token = backlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "backquoted literal" ) ); elsif token = charlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "character literal" ) ); elsif token = word_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "(shell immediate) word" ) ); err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "character literal" ) ); elsif is_keyword( token ) and token /= eof_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "keyword" ) ); elsif token = symbol_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "symbol" ) ); elsif isLocal( token ) then err( "already declared " & optional_bold( to_string( identifiers( token ).name ) ) ); else -- create a new one in this scope declareIdent( id, identifiers( token ).name, new_t, otherClass ); end if; getNextToken; else id := token; getNextToken; end if; exception when symbol_table_overflow => err( optional_inverse( "too many identifiers (symbol table overflow)" ) ); end ParseNewIdentifier; procedure ParseIdentifier( id : out identifier ) is -- expect a previously declared identifier begin id := eof_t; -- assume failure if token = number_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "number" ) ); elsif token = strlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "string literal" ) ); elsif token = backlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "backquoted literal" ) ); elsif token = charlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "character literal" ) ); elsif token = word_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "(shell immediate) word" ) ); elsif is_keyword( token ) and token /= eof_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "keyword" ) ); elsif token = symbol_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "symbol" ) ); elsif identifiers( token ).kind = new_t or identifiers( token ).deleted then -- if we're skipping a block, it doesn't matter if the identifier is -- declared, but it does if we're executing a block or checking syntax if isExecutingCommand or syntax_check then for i in identifiers'first..identifiers_top-1 loop if i /= token and not identifiers(i).deleted then if typoOf( identifiers(i).name, identifiers(token).name ) then discardUnusedIdentifier( token ); err( optional_bold( to_string( identifiers(token).name ) ) & " is a possible typo of " & optional_bold( to_string( identifiers(i).name ) ) ); exit; end if; end if; end loop; if not error_found then -- token will be eof_t if error has already occurred discardUnusedIdentifier( token ); err( optional_bold( to_string( identifiers( token ).name ) ) & " not declared" ); end if; end if; -- this only appears if err in typo loop didn't occur --if not error_found then -- discardUnusedIdentifier( token ); --end if; else id := token; end if; getNextToken; exception when symbol_table_overflow => err( optional_inverse( "too many identifiers (symbol table overflow)" ) ); end ParseIdentifier; -- Parameters procedure ParseOutParameter( ref : out reference; defaultType : identifier ) is -- syntax: identifier [ (index) ] -- Parse an "out" parameter for a procedure call. Return a reference -- to it. If the variable being referenced doesn't exist, declare it -- (if the pragmas allow it). expr_kind : identifier; expr_value : unbounded_string; array_id2 : arrayID; arrayIndex: long_integer; begin if identifiers( token ).kind = new_t and not onlyAda95 and not restriction_no_auto_declarations and not error_found and (inputMode = interactive or inputMode = breakout) then ParseNewIdentifier( ref.id ); identifiers( ref.id ).kind := defaultType; identifiers( ref.id ).class := otherClass; put_trace( "Assuming " & to_string( identifiers( ref.id ).name ) & " is a new " & to_string( identifiers( defaultType ).name ) & " variable" ); else ParseIdentifier( ref.id ); end if; ref.index := 0; if identifiers( ref.id ).list then -- array variable? ref.kind := identifiers( identifiers( ref.id ).kind ).kind; expect( symbol_t, "(" ); ParseExpression( expr_value, expr_kind ); if getUniType( expr_kind ) = uni_string_t or -- index must be scalar identifiers( getBaseType( expr_kind ) ).list then err( "array index must be a scalar type" ); end if; -- variables are not if isExecutingCommand then -- declared in syntax chk begin arrayIndex := long_integer(to_numeric(expr_value));-- convert to number exception when others => err( "exception raised" ); arrayIndex := 0; end; array_id2 := arrayID( to_numeric( -- array_id2=reference identifiers( ref.id ).value ) ); -- to the array table if indexTypeOK( array_id2, expr_kind ) then -- check and access array if inBounds( array_id2, arrayIndex ) then ref.a_id := array_id2; ref.index := arrayIndex; end if; end if; end if; expect( symbol_t, ")" ); elsif identifiers( getBaseType( identifiers( ref.id ).kind ) ).kind = root_record_t then -- getBaseType( ref.kind ) = root_record_t then -- record variable? -- To do this, search for the i-th field in the formal record declaration -- (the identifier value for the field has the field number). The field name -- contains the full dot qualified name. Get the base field name by removing -- everything except the name after the final dot. Then prefix the name of -- the record being declared (so that "rec_type.f" becomes "my_rec.f"). -- ref.kind := identifiers( identifiers( ref.id ).kind ).kind; ref.kind := identifiers( ref.id ).kind; for i in 1..integer'value( to_string( identifiers( ref.kind ).value ) ) loop for j in 1..identifiers_top-1 loop if identifiers( j ).field_of = ref.kind then if integer'value( to_string( identifiers( j ).value )) = i then declare fieldName : unbounded_string; dont_care_t : identifier; dotPos : natural; begin fieldName := identifiers( j ).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( ref.id ).name & "." & fieldName; declareIdent( dont_care_t, fieldName, identifiers( j ).kind, otherClass ); end; end if; end if; end loop; end loop; else ref.kind := identifiers( ref.id ).kind; end if; end ParseOutParameter; procedure ParseInOutParameter( ref : out reference ) is -- syntax: identifier [ (index) ] -- Parse an "in out" parameter for a procedure call. Return a reference -- to it. The variable being referenced must already exist. expr_kind : identifier; expr_value : unbounded_string; array_id2 : arrayID; arrayIndex: long_integer; begin ParseIdentifier( ref.id ); ref.index := 0; if identifiers( token ).list then -- array variable? expect( symbol_t, "(" ); ParseExpression( expr_value, expr_kind ); expect( symbol_t, ")"); end if; ref.index := 0; if identifiers( ref.id ).list then -- array variable? ref.kind := identifiers( identifiers( ref.id ).kind ).kind; expect( symbol_t, "(" ); ParseExpression( expr_value, expr_kind ); if getUniType( expr_kind ) = uni_string_t or -- index must be scalar identifiers( getBaseType( expr_kind ) ).list then err( "array index must be a scalar type" ); end if; -- variables are not if isExecutingCommand then -- declared in syntax chk begin arrayIndex := long_integer(to_numeric(expr_value));-- convert to number exception when others => err( "exception raised" ); arrayIndex := 0; end; array_id2 := arrayID( to_numeric( -- array_id2=reference identifiers( ref.id ).value ) ); -- to the array table if indexTypeOK( array_id2, expr_kind ) then -- check and access array if inBounds( array_id2, arrayIndex ) then ref.a_id := array_id2; ref.index := arrayIndex; end if; end if; end if; expect( symbol_t, ")"); elsif identifiers( getBaseType( identifiers( ref.id ).kind ) ).kind = root_record_t then -- To do this, search for the i-th field in the formal record declaration -- (the identifier value for the field has the field number). The field name -- contains the full dot qualified name. Get the base field name by removing -- everything except the name after the final dot. Then prefix the name of -- the record being declared (so that "rec_type.f" becomes "my_rec.f"). -- ref.kind := identifiers( identifiers( ref.id ).kind ).kind; ref.kind := identifiers( ref.id ).kind; for i in 1..integer'value( to_string( identifiers( ref.kind ).value ) ) loop for j in 1..identifiers_top-1 loop if identifiers( j ).field_of = ref.kind then if integer'value( to_string( identifiers( j ).value )) = i then declare fieldName : unbounded_string; dont_care_t : identifier; dotPos : natural; begin fieldName := identifiers( j ).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( ref.id ).name & "." & fieldName; declareIdent( dont_care_t, fieldName, identifiers( j ).kind, otherClass ); end; end if; end if; end loop; end loop; else ref.kind := identifiers( ref.id ).kind; end if; end ParseInOutParameter; ----------------------------------- -- Sound ----------------------------------- procedure ParsePlay is expr_val : unbounded_string; expr_type : identifier; pri_val : unbounded_string := to_unbounded_string( integer'image( integer'last ) ); pri_type : identifier; begin expect( sound_play_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if uniTypesOK( expr_type, uni_string_t ) then if token = symbol_t and identifiers( token ).value = "," then expect( symbol_t, "," ); ParseExpression( pri_val, pri_type ); if uniTypesOK( pri_type, uni_numeric_t ) then null; end if; end if; end if; expect( symbol_t, ")" ); if isExecutingCommand then begin Play( expr_val, integer( to_numeric( pri_val ) ) ); exception when others => err( "exception raised" ); end; end if; end ParsePlay; procedure ParsePlayCD is dev_name : unbounded_string := null_unbounded_string; dev_kind : identifier; begin expect( sound_playcd_t ); if token = symbol_t and identifiers( token ).value = "(" then expect( symbol_t, "(" ); ParseExpression( dev_name, dev_kind ); if baseTypesOK( dev_kind, string_t ) then expect( symbol_t, ")" ); end if; end if; if isExecutingCommand then PlayCD( dev_name ); end if; end ParsePlayCD; procedure ParseStopCD is begin expect( sound_stopcd_t ); if isExecutingCommand then StopCD; end if; end ParseStopCD; procedure ParseMute is begin expect( sound_mute_t ); if isExecutingCommand then Mute; end if; end ParseMute; procedure ParseUnmute is begin expect( sound_unmute_t ); if isExecutingCommand then Unmute; end if; end ParseUnmute; -- this stuff should be in parser_sound. ----------------------------------- -- Expressions ----------------------------------- procedure DoUserDefinedFunction( s : unbounded_string; result : out unbounded_string ); -- forward declaration procedure ParseFactor( f : out unbounded_string; kind : out identifier ) is -- Syntax: factor = (expr) | "strlit" | numeric-lit | identifier | built-in fn -- if the identifier is volatile, reload the value from the environment castType : identifier; array_id : identifier; array_id2 : arrayID; arrayIndex: long_integer; type aUniOp is ( noOp, doPlus, doMinus, doNot ); uniOp : aUniOp := noOp; t : identifier; begin if Token = symbol_t and then identifiers( Token ).value = "(" then expect( symbol_t, "(" ); ParseExpression( f, kind ); expect( symbol_t, ")" ); else if Token = symbol_t and identifiers( Token ).value = "+" then uniOp := doPlus; getNextToken; elsif Token = symbol_t and identifiers( Token ).value = "-" then uniOp := doMinus; getNextToken; elsif Token = not_t then uniOp := doNot; getNextToken; end if; if Token = symbol_t and then identifiers( Token ).value = "$?" then f := to_unbounded_string( last_status'img ); kind := uni_numeric_t; getNextToken; elsif Token = symbol_t and then identifiers( Token ).value = "$$" then f := to_unbounded_string( aPID'image( getpid ) ); kind := uni_numeric_t; getNextToken; elsif Token = symbol_t and then identifiers( Token ).value = "$#" then if onlyAda95 then err( "$# not allowed with " & optional_bold( "pragma ada_95" ) & " -- use command_line package" ); end if; if isExecutingCommand then f := to_unbounded_string( integer'image( Argument_Count-optionOffset) ); end if; kind := uni_numeric_t; getNextToken; elsif Token = symbol_t and then identifiers( Token ).value >= "$1" and then identifiers( Token ).value <= "$9" then -- this could be done a little tighter (ie length check) if onlyAda95 then err( "$1..$9 not allowed with " & optional_bold( "pragma ada_95" ) & " -- use command_line package" ); end if; kind := uni_string_t; if isExecutingCommand then begin f := to_unbounded_string( Argument( integer'value( "" & Element( identifiers( Token ).value, 2 ) )+optionOffset ) ); exception when program_error => err( "program_error exception raised" ); kind := eof_t; when others => err( "no such argument" ); kind := eof_t; end; end if; getNextToken; elsif Token = symbol_t and then identifiers( Token ).value = "$0" then if onlyAda95 then err( "$0 not allowed with " & optional_bold( "pragma ada_95" ) & " -- use command_line package" ); end if; if isExecutingCommand then f := to_unbounded_string( Ada.Command_Line.Command_Name ); end if; kind := uni_string_t; getNextToken; elsif Token = symbol_t and then identifiers( Token ).value = "@" then if onlyAda95 then err( "@ is not allowed with " & optional_bold( "pragma ada_95" ) ); f := null_unbounded_string; kind := eof_t; elsif itself_type = new_t then err( "@ is not defined" ); f := null_unbounded_string; kind := eof_t; elsif identifiers( itself_type ).class = procClass then err( "@ is not a variable" ); else f := itself; kind := itself_type; end if; getNextToken; elsif Token = symbol_t and then identifiers( Token ).value = "%" then if onlyAda95 then err( "% is not allowed with " & optional_bold( "pragma ada_95" ) ); f := null_unbounded_string; kind := eof_t; elsif syntax_check then -- % depends on run-time f := to_unbounded_string( "0" ); -- so just use a dummy kind := universal_t; -- typeless value else if last_output_type = eof_t then err( "there has been no output assigned to %" ); else f := last_output; end if; kind := last_output_type; end if; getNextToken; elsif token = number_t then -- numeric literal f := identifiers( token ).value; kind := identifiers( token ).kind; getNextToken; elsif token = charlit_t then -- character literal --if length( identifiers( charlit_t ).value ) > 1 then -- err( "character literal more than 1 character" ); --end if; f := identifiers( token ).value; kind := identifiers( token ).kind; getNextToken; elsif token = strlit_t then -- string literal f := identifiers( token ).value; kind := identifiers( token ).kind; getNextToken; elsif token = backlit_t then -- `cmds` kind := identifiers( token ).kind; CompileRunAndCaptureOutput( identifiers( token ).value, f ); getNextToken; elsif token = get_line_t then -- get line function ParseGetLine( f ); kind := universal_t; elsif token = inkey_t then -- inkey function ParseInkey( f ); kind := character_t; elsif token = end_of_file_t then -- end_of_file function ParseEndOfFile( f ); kind := boolean_t; elsif token = end_of_line_t then -- end_of_line function ParseEndOfLine( f ); kind := boolean_t; elsif token = line_t then -- line function ParseLine( f ); kind := integer_t; -- probably should be something more specific elsif token = name_t then -- name function ParseName( f ); kind := uni_string_t; elsif token = mode_t then -- mode function ParseMode( f ); kind := file_mode_t; elsif token = is_open_t then -- is_open function ParseIsOpen( t ); f := identifiers( t ).value; kind := boolean_t; elsif token = element_t then -- element function ParseStringsElement( f ); kind := character_t; elsif token = slice_t then -- slice function ParseStringsSlice( f ); kind := string_t; elsif token = index_t then -- index function ParseStringsIndex( f ); kind := natural_t; elsif token = index_non_blank_t then -- index_non_blank function ParseStringsIndexNonBlank( f ); kind := natural_t; elsif token = count_t then -- count function ParseStringsCount( f ); kind := natural_t; elsif token = replace_slice_t then -- replace_slice function ParseStringsReplaceSlice( f ); kind := string_t; elsif token = strings_insert_t then -- insert function ParseStringsInsert( f ); kind := string_t; elsif token = overwrite_t then -- overwrite function ParseStringsOverwrite( f ); kind := string_t; elsif token = sdelete_t then -- delete function ParseStringsDelete( f ); kind := string_t; elsif token = trim_t then -- trim function ParseStringsTrim( f ); kind := string_t; elsif token = length_t then -- trim function ParseStringsLength( f ); kind := natural_t; elsif token = head_t then -- head function ParseStringsHead( f ); kind := string_t; elsif token = tail_t then -- tail function ParseStringsTail( f ); kind := string_t; elsif token = field_t then -- field function ParseStringsField( f ); kind := string_t; elsif token = csv_field_t then -- csv_field function ParseStringsCSVField( f ); kind := string_t; elsif token = lookup_t then -- lookup function ParseStringsLookup( f ); kind := string_t; elsif token = to_upper_t then -- to_upper function ParseStringsToUpper( f, kind ); elsif token = to_lower_t then -- to_lower function ParseStringsToLower( f, kind ); elsif token = to_proper_t then -- to_proper function ParseStringsToProper( f, kind ); elsif token = to_basic_t then -- to_basic function ParseStringsToBasic( f, kind ); elsif token = to_escaped_t then -- to_escaped function ParseStringsToEscaped( f, kind ); elsif token = mktemp_t then -- mktemp function ParseStringsMkTemp( f ); kind := string_t; elsif token = val_t then -- val function ParseStringsVal( f ); kind := character_t; elsif token = image_t then -- image function ParseStringsImage( f ); kind := string_t; elsif token = glob_t then -- glob function ParseStringsGlob( f ); kind := boolean_t; elsif token = match_t then -- match function ParseStringsMatch( f ); kind := boolean_t; elsif token = tail_t then -- tail function ParseStringsTail( f ); kind := string_t; elsif token = to_string_t then -- to_string function ParseStringsToString( f ); kind := string_t; elsif token = to_u_string_t then -- to_unbounded_string function ParseStringsToUString( f ); kind := unbounded_string_t; elsif token = is_control_t then -- is_control function ParseStringsIsControl( f ); kind := boolean_t; elsif token = is_graphic_t then -- is_graphic function ParseStringsIsGraphic( f ); kind := boolean_t; elsif token = is_letter_t then -- is_letter function ParseStringsIsLetter( f ); kind := boolean_t; elsif token = is_lower_t then -- is_lower function ParseStringsIsLower( f ); kind := boolean_t; elsif token = is_upper_t then -- is_upper function ParseStringsIsUpper( f ); kind := boolean_t; elsif token = is_basic_t then -- is_basic function ParseStringsIsBasic( f ); kind := boolean_t; elsif token = is_digit_t then -- is_digit function ParseStringsIsDigit( f ); kind := boolean_t; elsif token = is_hex_digit_t then -- is_hex_digit function ParseStringsIsHexDigit( f ); kind := boolean_t; elsif token = is_alphanumeric_t then -- is_alphanumeric function ParseStringsIsAlphanumeric( f ); kind := boolean_t; elsif token = is_special_t then -- is_special function ParseStringsIsSpecial( f ); kind := boolean_t; elsif token = is_slashed_date_t then -- is_slashed_date function ParseStringsIsSlashedDate( f ); kind := boolean_t; elsif token = is_fixed_t then -- is_fixed function ParseStringsIsFixed( f ); kind := boolean_t; elsif token = is_typo_of_t then -- is_typo_of function ParseStringsIsTypoOf( f ); kind := boolean_t; elsif token = random_t then -- random function ParseNumericsRandom( f ); kind := float_t; elsif token = shift_left_t then -- shift_left function ParseNumericsShiftLeft( f ); kind := uni_numeric_t; elsif token = shift_right_t then -- shift_right function ParseNumericsShiftRight( f ); kind := uni_numeric_t; elsif token = rotate_left_t then -- rotate_left function ParseNumericsRotateLeft( f ); kind := uni_numeric_t; elsif token = rotate_right_t then -- rotate_right function ParseNumericsRotateRight( f ); kind := uni_numeric_t; elsif token = shift_right_arith_t then -- ASR function ParseNumericsASR( f ); kind := uni_numeric_t; elsif token = abs_t then -- abs function ParseNumericsAbs( f ); kind := uni_numeric_t; elsif token = sqrt_t then -- sqrt function ParseNumericsSqrt( f ); kind := uni_numeric_t; elsif token = log_t then -- log function ParseNumericsLog( f ); kind := uni_numeric_t; elsif token = exp_t then -- exp function ParseNumericsExp( f ); kind := uni_numeric_t; elsif token = sin_t then -- sin function ParseNumericsSin( f ); kind := uni_numeric_t; elsif token = cos_t then -- cos function ParseNumericsCos( f ); kind := uni_numeric_t; elsif token = tan_t then -- tan function ParseNumericsTan( f ); kind := uni_numeric_t; elsif token = cot_t then -- cot function ParseNumericsCot( f ); kind := uni_numeric_t; elsif token = arcsin_t then -- arcsin function ParseNumericsArcSin( f ); kind := uni_numeric_t; elsif token = arccos_t then -- arccos function ParseNumericsArcCos( f ); kind := uni_numeric_t; elsif token = arctan_t then -- arctan function ParseNumericsArcTan( f ); kind := uni_numeric_t; elsif token = arccot_t then -- arccot function ParseNumericsArcCot( f ); kind := uni_numeric_t; elsif token = sinh_t then -- sinh function ParseNumericsSinH( f ); kind := uni_numeric_t; elsif token = cosh_t then -- cosh function ParseNumericsCosH( f ); kind := uni_numeric_t; elsif token = tanh_t then -- tanh function ParseNumericsTanH( f ); kind := uni_numeric_t; elsif token = coth_t then -- coth function ParseNumericsCotH( f ); kind := uni_numeric_t; elsif token = arcsinh_t then -- arcsinh function ParseNumericsArcSinH( f ); kind := uni_numeric_t; elsif token = arccosh_t then -- arccosh function ParseNumericsArcCosH( f ); kind := uni_numeric_t; elsif token = arctanh_t then -- arctanh function ParseNumericsArcTanH( f ); kind := uni_numeric_t; elsif token = arccoth_t then -- arccoth function ParseNumericsArcCotH( f ); kind := uni_numeric_t; elsif token = floor_t then -- floor function ParseNumericsFloor( f ); kind := uni_numeric_t; elsif token = ceiling_t then -- ceiling function ParseNumericsCeiling( f ); kind := uni_numeric_t; elsif token = rounding_t then -- rounding function ParseNumericsRounding( f ); kind := uni_numeric_t; elsif token = unbiased_rounding_t then -- unbiased rounding function ParseNumericsUnbiasedRounding( f ); kind := uni_numeric_t; elsif token = truncation_t then -- truncation function ParseNumericsTruncation( f ); kind := uni_numeric_t; elsif token = Remainder_t then -- remainder function ParseNumericsRemainder( f ); kind := uni_numeric_t; elsif token = Exponent_t then -- exponent function ParseNumericsExponent( f ); kind := uni_numeric_t; elsif token = Fraction_t then -- fraction function ParseNumericsFraction( f ); kind := uni_numeric_t; elsif token = leading_part_t then -- leading part function ParseNumericsLeadingPart( f ); kind := uni_numeric_t; elsif token = copy_sign_t then -- copy sign function ParseNumericsCopySign( f ); kind := uni_numeric_t; elsif token = sturges_t then -- sturges function ParseNumericsSturges( f ); kind := uni_numeric_t; elsif token = max_t then -- max function ParseNumericsMax( f ); kind := uni_numeric_t; elsif token = min_t then -- min function ParseNumericsMin( f ); kind := uni_numeric_t; elsif token = machine_t then -- machine function ParseNumericsMachine( f ); kind := uni_numeric_t; elsif token = scaling_t then -- scaling function ParseNumericsScaling( f ); kind := uni_numeric_t; elsif token = value_t then -- value function ParseNumericsValue( f ); kind := uni_numeric_t; elsif token = pos_t then -- pos function ParseNumericsPos( f ); kind := positive_t; elsif token = numerics_md5_t then -- md5 function ParseNumericsMd5( f ); kind := string_t; elsif token = serial_t then -- serial function ParseNumericsSerial( f ); kind := natural_t; elsif token = rnd_t then -- rnd function ParseNumericsRnd( f ); kind := positive_t; elsif token = odd_t then -- odd function ParseNumericsOdd( f ); kind := boolean_t; elsif token = even_t then -- even function ParseNumericsEven( f ); kind := boolean_t; elsif token = numerics_re_t then -- complex re ParseNumericsRe( f ); kind := long_float_t; elsif token = numerics_im_t then -- complex im ParseNumericsIm( f ); kind := long_float_t; elsif token = numerics_modulus_t then -- complex modulus ParseNumericsModulus( f ); kind := long_float_t; elsif token = numerics_argument_t then -- complex argument ParseNumericsArgument( f ); kind := long_float_t; elsif token = source_info_symbol_table_size_t then -- Symbol_Table_Sz getNextToken; if onlyAda95 then err( "symbol_table_size is not allowed with pragma ada_95" ); f := null_unbounded_string; kind := eof_t; else f := delete( to_unbounded_string( identifier'image( identifiers_top-1 )), 1, 1 ); kind := natural_t; end if; elsif token = source_info_file_t then -- source_info.file f := basename( getSourceFileName ); kind := string_t; getNextToken; elsif token = source_info_line_t then -- source_info.line f := to_unbounded_string( getLineNo'img ); kind := positive_t; getNextToken; elsif token = source_info_src_loc_t then -- source_info.source_loc. f := to_unbounded_string( getLineNo'img ); f := basename( getSourceFileName ) & ":" & f; kind := string_t; getNextToken; elsif token = source_info_enc_ent_t then -- source_info.enclosing. if blocks_top > block'First then f := getBlockName( block'First ); else f := to_unbounded_string( "script" ); end if; kind := string_t; getNextToken; elsif token = cmd_argcount_t then ParseArgument_Count( f ); kind := uni_numeric_t; elsif token = cmd_argument_t then ParseArgument( f ); kind := uni_string_t; elsif token = cmd_commandname_t then ParseCommand_Name( f ); kind := uni_string_t; elsif token = cmd_envcnt_t then ParseEnvironment_Count( f ); kind := natural_t; elsif token = cmd_envval_t then ParseEnvironment_Value( f ); kind := uni_string_t; elsif token = cgi_parsing_errors_t then -- CGI package ParseParsing_Errors( f ); kind := boolean_t; elsif token = cgi_input_received_t then -- input_received ParseInput_Received( f ); kind := boolean_t; elsif token = cgi_is_index_t then -- is_index ParseIs_Index( f ); kind := boolean_t; elsif token = cgi_cgi_method_t then -- cgi_method ParseCGI_Method( f ); kind := cgi_cgi_method_type_t; elsif token = cgi_value_t then -- value ParseValue( f ); kind := string_t; elsif token = cgi_key_exists_t then -- key_exists ParseKey_Exists( f ); kind := boolean_t; elsif token = cgi_key_count_t then -- key_count ParseKey_Count( f ); kind := natural_t; elsif token = cgi_argument_count_t then -- CGI.argument_cnt ParseCGIArgument_Count( f ); kind := natural_t; elsif token = cgi_key_t then -- CGI.key ParseKey( f ); kind := string_t; elsif token = cgi_key_value_t then -- CGI.key ParseKeyValue( f ); kind := string_t; elsif token = cgi_key_value_exists_t then -- CGI.key_val_exist ParseKey_Value_Exists( f ); kind := boolean_t; elsif token = cgi_my_url_t then -- CGI.my_url ParseMy_URL( f ); kind := string_t; elsif token = cgi_line_count_t then -- CGI.line_count ParseLine_Count( f ); kind := natural_t; elsif token = cgi_line_count_of_value_t then -- CGI.line_cnt_val ParseLine_Count_Of_Value( f ); kind := natural_t; elsif token = cgi_line_t then -- CGI.line ParseCGILine( f ); kind := string_t; elsif token = cgi_value_of_line_t then -- CGI.Value_Of_Line ParseValue_Of_Line( f ); kind := string_t; elsif token = cgi_url_decode_t then -- CGI.URL_Decode ParseURL_Decode( f ); kind := string_t; elsif token = cgi_url_encode_t then -- CGI.URL_Encode ParseURL_Encode( f ); kind := string_t; elsif token = cgi_html_encode_t then -- CGI.HTML_Encode ParseHTML_Encode( f ); kind := string_t; elsif token = cgi_cookie_value_t then -- CGI.Cooke_Value ParseCookie_Value( f ); kind := string_t; elsif token = cgi_cookie_count_t then -- CGI.Cooke_Count ParseCookie_Count( f ); kind := natural_t; elsif token = cal_clock_t then -- Calendar.Clock ParseCalClock( f ); kind := cal_time_t; elsif token = cal_year_t then -- Calendar.Year ParseCalYear( f ); kind := cal_year_number_t; elsif token = cal_month_t then -- Calendar.Month ParseCalMonth( f ); kind := cal_month_number_t; elsif token = cal_day_t then -- Calendar.Day ParseCalDay( f ); kind := cal_day_number_t; elsif token = cal_seconds_t then -- Calendar.Seconds ParseCalSeconds( f ); kind := cal_day_duration_t; elsif token = cal_time_of_t then -- Calendar.Time_Of ParseCalTimeOf( f ); kind := cal_time_t; elsif token = cal_to_julian_t then -- Calendar.To_Julian ParseCalToJulian( f ); kind := long_integer_t; elsif token = cal_to_time_t then -- Calendar.To_Time ParseCalToTime( f ); kind := cal_time_t; elsif token = cal_day_of_week_t then -- Calendar.Day_Of_Week ParseCalDayOfWeek( f ); kind := integer_t; --elsif token = dbi_prepare_t then -- DB.Prepare -- ParseDBIPrepare( f ); -- kind := boolean_t; elsif token = db_engine_of_t then -- DB.Engine_Of ParseDBEngineOf( f ); kind := db_database_type_t; elsif token = db_is_connected_t then -- DB.Is_Connected ParseDBIsConnected( f ); kind := boolean_t; elsif token = db_error_message_t then -- DB.Error_Message ParseDBErrorMessage( f ); kind := string_t; elsif token = db_notice_message_t then -- DB.Notice_Message ParseDBNoticeMessage( f ); kind := string_t; elsif token = db_in_abort_state_t then -- DB.In_Abort_State ParseDBInAbortState( f ); kind := boolean_t; elsif token = db_options_t then -- DB.Options ParseDBOptions( f ); kind := string_t; elsif token = db_will_rollback_on_finalize_t then -- DB.Will_Rollback_On_Finalize ParseDBWillRollbackOnFinalize( f ); kind := boolean_t; elsif token = db_is_trace_t then -- DB.Is_Trace ParseDBIsTrace( f ); kind := boolean_t; elsif token = db_end_of_query_t then -- DB.End_Of_Query ParseDBEndOfQuery( f ); kind := boolean_t; elsif token = db_tuple_t then -- DB.Tuple ParseDBTuple( f ); kind := db_tuple_index_type_t; elsif token = db_tuples_t then -- DB.Tuples ParseDBTuples( f ); kind := natural_t; elsif token = db_columns_t then -- DB.Columns ParseDBColumns( f ); kind := natural_t; elsif token = db_column_name_t then -- DB.Column_Name ParseDBColumnName( f ); kind := string_t; elsif token = db_column_index_t then -- DB.Column_Index ParseDBColumnIndex( f ); kind := db_column_index_type_t; --elsif token = db_column_type_t then -- DB.Column_Type -- ParseDBColumnType( f ); -- kind := db_column_index_type_t; elsif token = db_is_null_t then -- DB.Is_Null ParseDBIsNull( f ); kind := boolean_t; elsif token = db_value_t then -- DB.Value ParseDBValue( f ); kind := universal_t; elsif token = mysql_engine_of_t then -- MYSQL.Engine_Of ParseMySQLEngineOf( f ); kind := db_database_type_t; elsif token = mysql_is_connected_t then -- MYSQL.Is_Connected ParseMySQLIsConnected( f ); kind := boolean_t; elsif token = mysql_error_message_t then -- MYSQL.Error_Message ParseMySQLErrorMessage( f ); kind := string_t; -- elsif token = mysql_notice_message_t then -- MYSQL.Notice_Message -- ParseMySQLNoticeMessage( f ); -- kind := string_t; elsif token = mysql_in_abort_state_t then -- MYSQL.In_Abort_State ParseMySQLInAbortState( f ); kind := boolean_t; elsif token = mysql_options_t then -- MYSQL.Options ParseMySQLOptions( f ); kind := string_t; elsif token = mysql_will_rollback_on_finalize_t then -- MYSQL.Will_Rollback_On_Finalize ParseMySQLWillRollbackOnFinalize( f ); kind := boolean_t; elsif token = mysql_is_trace_t then -- MYSQL.Is_Trace ParseMySQLIsTrace( f ); kind := boolean_t; elsif token = mysql_end_of_query_t then -- MYSQL.End_Of_Query ParseMySQLEndOfQuery( f ); kind := boolean_t; elsif token = mysql_tuple_t then -- MYSQL.Tuple ParseMySQLTuple( f ); kind := mysql_tuple_index_type_t; elsif token = mysql_tuples_t then -- MYSQL.Tuples ParseMySQLTuples( f ); kind := natural_t; elsif token = mysql_columns_t then -- MYSQL.Columns ParseMySQLColumns( f ); kind := natural_t; elsif token = mysql_column_name_t then -- MYSQL.Column_Name ParseMySQLColumnName( f ); kind := string_t; elsif token = mysql_column_index_t then -- MYSQL.Column_Index ParseMySQLColumnIndex( f ); kind := mysql_column_index_type_t; --elsif token = db_column_type_t then -- MYSQL.Column_Type -- ParseDBColumnType( f ); -- kind := db_column_index_type_t; elsif token = mysql_is_null_t then -- MYSQL.Is_Null ParseMySQLIsNull( f ); kind := boolean_t; elsif token = mysql_value_t then -- MYSQL.Value ParseMySQLValue( f ); kind := universal_t; elsif token = os_status_t then -- OS.status ParseOSSTatus( f ); kind := integer_t; elsif token = units_inches2mm_t then -- Units.Inches2MM ParseUnitsInches2MM( f ); kind := long_float_t; elsif token = units_feet2cm_t then -- Units.Feet2CM ParseUnitsFeet2CM( f ); kind := long_float_t; elsif token = units_yards2m_t then -- Units.Yards2M ParseUnitsYards2M( f ); kind := long_float_t; elsif token = units_miles2km_t then -- Units.Miles2KM ParseUnitsMiles2Km( f ); kind := long_float_t; elsif token = units_mm2inches_t then -- Units.MM2Inches ParseUnitsMM2Inches( f ); kind := long_float_t; elsif token = units_cm2inches_t then -- Units.CM2Inches ParseUnitsCM2Inches( f ); kind := long_float_t; elsif token = units_m2yards_t then -- Units.M2Yards ParseUnitsM2Yards( f ); kind := long_float_t; elsif token = units_km2miles_t then -- Units.Km2Miles ParseUnitsKm2Miles( f ); kind := long_float_t; elsif token = units_sqin2sqcm_t then -- Units.SqIn2SqCm ParseUnitsSqIn2SqCm( f ); kind := long_float_t; elsif token = units_sqft2sqm_t then -- Units.SqFt2SqM ParseUnitsSqFt2SqM( f ); kind := long_float_t; elsif token = units_sqyd2sqm_t then -- Units.SqYd2SqM ParseUnitsSqYd2SqM( f ); kind := long_float_t; elsif token = units_acres2hectares_t then -- Units.Acres2Hectares ParseUnitsAcres2Hectares( f ); kind := long_float_t; elsif token = units_sqcm2sqin_t then -- Units.SqCm2SqIn ParseUnitsSqCm2SqIn( f ); kind := long_float_t; elsif token = units_sqm2sqft_t then -- Units.SqM2SqFt ParseUnitsSqM2SqFt( f ); kind := long_float_t; elsif token = units_sqm2sqyd_t then -- Units.SqM2SqYd ParseUnitsSqM2SqYd( f ); kind := long_float_t; elsif token = units_sqkm2sqmiles_t then -- Units.SqKm2SqM ParseUnitsSqKm2SqMiles( f ); kind := long_float_t; elsif token = units_hectares2acres_t then -- Units.Hectares2Acres ParseUnitsHectares2Acres( f ); kind := long_float_t; elsif token = units_oz2grams_t then -- Units.Oz2Grams ParseUnitsOz2Grams( f ); kind := long_float_t; elsif token = units_lb2kg_t then -- Units.Lb2Kg ParseUnitsLb2Kg( f ); kind := long_float_t; elsif token = units_tons2tonnes_t then -- Units.Tons2Tonnes ParseUnitsTons2Tonnes( f ); kind := long_float_t; elsif token = units_grams2oz_t then -- Units.Grams2Oz ParseUnitsGrams2Oz( f ); kind := long_float_t; elsif token = units_kg2lb_t then -- Units.Grams2Oz ParseUnitsKg2Lb( f ); kind := long_float_t; elsif token = units_tonnes2tons_t then -- Units.Tonnes2Tons ParseUnitsTonnes2Tons( f ); kind := long_float_t; elsif token = units_ly2pc_t then -- Units.Ly2Pc ParseUnitsLy2Pc( f ); kind := long_float_t; elsif token = units_pc2ly_t then -- Units.Pc2Ly ParseUnitsPc2Ly( f ); kind := long_float_t; elsif token = units_floz2ml_t then -- Units.FlOz2Ml ParseUnitsFlOz2Ml( f ); kind := long_float_t; elsif token = units_usfloz2ml_t then -- Units.USFlOz2Ml ParseUnitsUSFlOz2Ml( f ); kind := long_float_t; elsif token = units_usfloz2floz_t then -- Units.USFlOz2FlOz ParseUnitsUSFlOz2FlOz( f ); kind := long_float_t; elsif token = units_pints2l_t then -- Units.Pints2L ParseUnitsPints2L( f ); kind := long_float_t; elsif token = units_gal2l_t then -- Units.Gal2L ParseUnitsGal2L( f ); kind := long_float_t; elsif token = units_ml2floz_t then -- Units.Ml2FlOz ParseUnitsMl2FlOz( f ); kind := long_float_t; elsif token = units_ml2usfloz_t then -- Units.Ml2USFlOz ParseUnitsMl2USFlOz( f ); kind := long_float_t; elsif token = units_floz2usfloz_t then -- Units.FlOz2USFlOz ParseUnitsFlOz2USFlOz( f ); kind := long_float_t; elsif token = units_usdrygal2l_t then -- Units.USDryGal2L ParseUnitsUSDryGal2L( f ); kind := long_float_t; elsif token = units_l2usdrygal_t then -- Units.L2USDryGal ParseUnitsL2USDryGal( f ); kind := long_float_t; elsif token = units_usliqgal2l_t then -- Units.USDryLiq2L ParseUnitsUSLiqGal2L( f ); kind := long_float_t; elsif token = units_l2usliqgal_t then -- Units.L2USLiqGal ParseUnitsL2USLiqGal( f ); kind := long_float_t; elsif token = units_troz2g_t then -- Units.Troz2G ParseUnitsTrOz2G( f ); kind := long_float_t; elsif token = units_g2troz_t then -- Units.G2Troz ParseUnitsG2TrOz( f ); kind := long_float_t; elsif token = units_cucm2floz_t then -- Units.CuCm2Oz ParseUnitsCuCm2FlOz( f ); kind := long_float_t; elsif token = units_floz2cucm_t then -- Units.Oz2CuCm ParseUnitsFlOz2CuCm( f ); kind := long_float_t; elsif token = units_cucm2usfloz_t then -- Units.CuCm2USFlOz ParseUnitsCuCm2USFlOz( f ); kind := long_float_t; elsif token = units_usfloz2cucm_t then -- Units.USFlOz2CuCm ParseUnitsUSFlOz2CuCm( f ); kind := long_float_t; elsif token = units_bytes2mb_t then -- Units.Bytes2MB ParseUnitsBytes2MB( f ); kind := long_float_t; elsif token = units_mb2bytes_t then -- Units.MB2Bytes ParseUnitsMB2Bytes( f ); kind := long_float_t; elsif token = units_l2quarts_t then -- Units.L2Quarts ParseUnitsL2Quarts( f ); kind := long_float_t; elsif token = units_l2gal_t then -- Units.L2Gal ParseUnitsL2Gal( f ); kind := long_float_t; elsif token = units_f2c_t then -- Units.F2C ParseUnitsF2C( f ); kind := long_float_t; elsif token = units_c2f_t then -- Units.C2F ParseUnitsC2F( f ); kind := long_float_t; elsif token = units_k2c_t then -- Units.K2C ParseUnitsK2C( f ); kind := long_float_t; elsif token = units_c2k_t then -- Units.C2K ParseUnitsC2K( f ); kind := long_float_t; elsif token = files_exists_t then -- files.file_exists ParseFileExists( f ); kind := boolean_t; elsif token = files_is_absolute_path_t then -- files.is_absolute_path ParseIsAbsolutePath( f ); kind := boolean_t; elsif token = files_is_regular_file_t then -- files.is_regular_file ParseIsRegularFile( f ); kind := boolean_t; elsif token = files_is_directory_t then -- files.is_directory ParseIsDirectory( f ); kind := boolean_t; elsif token = files_is_writable_file_t then -- files.is_writable_file ParseIsWritableFile( f ); kind := boolean_t; elsif token = files_is_writable_t then -- files.is_writable ParseIsWritable( f ); kind := boolean_t; elsif token = files_is_executable_file_t then -- files.is_executable_file ParseIsExecutableFile( f ); kind := boolean_t; elsif token = files_is_executable_t then -- files.is_executable ParseIsExecutable( f ); kind := boolean_t; elsif token = files_is_readable_file_t then -- files.is_readable_file ParseIsReadableFile( f ); kind := boolean_t; elsif token = files_is_readable_t then -- files.is_readable_file ParseIsReadable( f ); kind := boolean_t; elsif token = files_basename_t then -- files.basename ParseBasename( f ); kind := string_t; elsif token = files_dirname_t then -- files.dirname ParseDirname( f ); kind := string_t; elsif token = files_size_t then -- files.size ParseFileSize( f ); kind := long_integer_t; elsif token = files_is_waiting_file_t then -- files.is_waiting_file ParseIsWaitingFile( f ); kind := boolean_t; elsif token = files_last_modified_t then -- files.last_modified ParseFileLastModified( f ); kind := cal_time_t; elsif token = files_last_changed_t then -- files.last_changed ParseFileLastChanged( f ); kind := cal_time_t; elsif token = files_last_accessed_t then -- files.last_accessed ParseFileLastAccessed( f ); kind := cal_time_t; elsif token = dirops_dir_separator_t then -- dir_opts.dir_separator ParseDirOpsDirSeparator( f ); kind := character_t; elsif token = dirops_get_current_dir_t then -- dir_opts.get_current_dir ParseDirOpsGetCurrentDir( f); kind := dirops_dir_name_str_t; elsif token = dirops_dir_name_t then -- dir_opts.dir_name ParseDirOpsDirName( f ); kind := dirops_dir_name_str_t; elsif token = dirops_base_name_t then -- dir_opts.base_name ParseDirOpsBaseName( f ); kind := string_t; elsif token = dirops_file_extension_t then -- dir_opts.file_ext ParseDirOpsFileExtension( f ); kind := string_t; elsif token = dirops_file_name_t then -- dir_opts.file_name ParseDirOpsFileName( f ); kind := string_t; elsif token = dirops_format_pathname_t then -- dir_opts.format_p ParseDirOpsFormatPathname( f ); kind := dirops_path_name_t; elsif token = dirops_expand_path_t then -- dir_opts.expand_p ParseDirOpsExpandPath( f ); kind := dirops_path_name_t; elsif token = arrays_first_t then -- arrays.first ParseArraysFirst( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = arrays_last_t then -- arrays.last ParseArraysLast( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = arrays_length_t then -- arrays.last ParseArraysLength( f ); kind := natural_t; elsif token = stats_average_t then -- stats.average ParseStatsAverage( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = stats_max_t then -- stats.max ParseStatsMax( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = stats_min_t then -- stats.min ParseStatsMin( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = stats_standard_deviation_t then -- stats.standard_deviation ParseStatsStandardDeviation( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = stats_sum_t then -- stats.sum ParseStatsSum( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = stats_variance_t then -- stats.variance ParseStatsVariance( f, kind ); if syntax_check then -- array index type kind := universal_t; -- not known at end if; -- syntax check time elsif token = pen_is_empty_rect_t then -- pen.is_empty_rect ParsePenIsEmptyRect( f ); kind := boolean_t; elsif token = pen_inside_rect_t then -- pen.inside_rect ParsePenInsideRect( f ); kind := boolean_t; elsif token = pen_in_rect_t then -- pen.in_rect ParsePenInRect( f ); kind := boolean_t; elsif token = pen_get_pen_mode_t then -- pen.get_pen_mode ParsePenGetPenMode( f ); kind := pen_pen_mode_t; elsif identifiers( token ).class = userFuncClass then declare funcToken : identifier := token; begin DoUserDefinedFunction( identifiers( funcToken ).value, f ); kind := identifiers( funcToken ).kind; end; elsif identifiers( token ).kind = keyword_t then -- no keywords f := null_unbounded_string; -- (always return something) kind := universal_t; err( "variable, value or expression expected" ); else -- some kind of user ident? ParseIdentifier( t ); if identifiers( t ).volatile then -- volatile user identifier refreshVolatile( t ); f := identifiers( t ).value; kind := identifiers( t ).kind; elsif identifiers( t ).class = subClass or -- type cast identifiers( t ).class = typeClass then if identifiers( getBaseType( t ) ).list then -- array cast? err( "cannot typecast by array types...perhaps you wanted an array variable" ); -- because we can't end if; -- represent array types castType := t; -- in expressiosn (yet) expect( symbol_t, "(" ); ParseExpression( f, kind ); expect( symbol_t, ")" ); if uniTypesOk( castType, kind ) then kind := castType; end if; elsif identifiers( getBaseType( t ) ).list then -- array(index)? array_id := t; -- array_id=array variable expect( symbol_t, "(" ); -- parse index part ParseExpression( f, kind ); -- kind is the index type if getUniType( kind ) = uni_string_t or -- index must be scalar identifiers( getBaseType( kind ) ).list then err( "array index must be a scalar type" ); end if; -- variables are not if isExecutingCommand then -- declared in syntax chk arrayIndex := long_integer(to_numeric(f)); -- convert to number array_id2 := arrayID( to_numeric( -- array_id2=reference identifiers( array_id ).value ) ); -- to the array table if indexTypeOK( array_id2, kind ) then -- check and access array if inBounds( array_id2, arrayIndex ) then f := arrayElement( array_id2, arrayIndex ); end if; end if; end if; expect( symbol_t, ")" ); -- element type is k's k kind := identifiers( identifiers( array_id ).kind ).kind; else -- user identifier f := identifiers( t ).value; kind := identifiers( t ).kind; end if; end if; case uniOp is when noOp => null; when doPlus => if baseTypesOk( kind, uni_numeric_t ) then null; end if; when doMinus => begin if baseTypesOk( kind, uni_numeric_t ) then if isExecutingCommand then f := to_unbounded_string( -to_numeric( f ) ); end if; end if; exception when others => err( "exception raised" ); end; when doNot => begin if baseTypesOk( kind, boolean_t ) then if isExecutingCommand then if to_numeric( f ) = 1.0 then f := to_unbounded_string( "0" ); else f := to_unbounded_string( "1" ); end if; end if; end if; exception when others => err( "exception raised" ); end; when others => err( "unexpected uniary operation error" ); end case; end if; end ParseFactor; procedure ParsePowerTermOperator( op : out unbounded_string ) is -- Syntax: termop = "**" begin -- token value is checked by parseTerm, but not token name if Token /= symbol_t then err( "operator expected"); elsif identifiers( Token ).value /= "**" then err( "** operator expected"); else op := identifiers( token ).value; end if; getNextToken; end ParsePowerTermOperator; procedure ParsePowerTerm( term : out unbounded_string; term_type : out identifier ) is -- Syntax: term = "factor powerterm-op factor" factor1 : unbounded_string; factor2 : unbounded_string; kind1 : identifier; kind2 : identifier; operator : unbounded_string; operation: identifier; begin ParseFactor( factor1, kind1 ); term := factor1; term_type := kind1; while identifiers( Token ).value = "**" loop ParsePowerTermOperator( operator ); ParseFactor( factor2, kind2 ); if baseTypesOk( kind1, kind2 ) then term_type := getBaseType( kind1 ); operation := getUniType( kind1 ); if operation = universal_t then operation := getUniType( kind2 ); end if; if operation = universal_t then operation := uni_string_t; end if; if operation = uni_numeric_t then if operator = "**" then begin if isExecutingCommand then term := to_unbounded_string( to_numeric( term ) ** natural( to_numeric( factor2 ) ) ); end if; exception when program_error => err( "program_error exception raised" ); term := null_unbounded_string; when others => err( "exception raised" ); term := null_unbounded_string; end; else err( "interal error: unknown power operator" ); end if; else err( "operation ** not defined for these types" ); end if; end if; end loop; end ParsePowerTerm; procedure ParseTermOperator( op : out unbounded_string ) is -- Syntax: termop = '*' | '/' | '&' begin -- token value is checked by parseTerm, but not token name if Token = mod_t or Token = rem_t then op := identifiers( token ).name; elsif Token /= symbol_t then err( "operator expected"); elsif identifiers( Token ).value /= "*" and identifiers( Token ).value /= "/" and identifiers( Token ).value /= "&" then err( "term operator expected"); else op := identifiers( token ).value; end if; getNextToken; end ParseTermOperator; procedure ParseTerm( term : out unbounded_string; term_type : out identifier ) is -- Syntax: term = "powerterm term-op powerterm" pterm1 : unbounded_string; pterm2 : unbounded_string; kind1 : identifier; kind2 : identifier; operator : unbounded_string; operation: identifier; begin ParsePowerTerm( pterm1, kind1 ); term := pterm1; term_type := kind1; while identifiers( Token ).value = "*" or identifiers( Token ).value = "/" or identifiers( Token ).value = "&" or Token = mod_t or Token = rem_t loop ParseTermOperator( operator ); ParsePowerTerm( pterm2, kind2 ); term_type := getBaseType( kind2 ); operation := getUniType( kind2 ); if operation = universal_t then operation := getUniType( kind1 ); end if; if operation = universal_t then operation := uni_string_t; end if; if operation = uni_numeric_t then if baseTypesOk( kind1, kind2 ) then if operator = "*" then begin if isExecutingCommand then term := to_unbounded_string( to_numeric( term ) * to_numeric( pterm2 ) ); end if; exception when program_error => err( "program_error exception raised" ); term := null_unbounded_string; when others => err( "exception raised" ); term := null_unbounded_string; end; elsif operator = "/" then begin if isExecutingCommand then term := to_unbounded_string( to_numeric( term ) / to_numeric( pterm2 ) ); end if; exception when program_error => err( "program_error exception raised" ); term := null_unbounded_string; when others => err( "exception raised" ); term := null_unbounded_string; end; elsif operator = "mod" then begin if isExecutingCommand then term := to_unbounded_string( long_long_integer'image( long_long_integer( to_numeric( term ) ) mod long_long_integer( to_numeric( pterm2 ) ) ) ); end if; exception when program_error => err( "program_error exception raised" ); term := null_unbounded_string; when others => err( "exception raised" ); term := null_unbounded_string; end; elsif operator = "rem" then begin if isExecutingCommand then term := to_unbounded_string( long_long_integer'image( long_long_integer( to_numeric( term ) ) rem long_long_integer( to_numeric( pterm2 ) ) ) ); end if; exception when program_error => err( "program_error exception raised" ); term := null_unbounded_string; when others => err( "exception raised" ); term := null_unbounded_string; end; else err( "Internal error: unable to handle term operator" ); end if; end if; elsif operation = uni_string_t then declare base1 : identifier := getBaseType( kind1 ); base2 : identifier := getBaseType( kind2 ); uni1 : identifier := getUniType( kind1 ); uni2 : identifier := getUniType( kind2 ); begin if operator = "&" then if base1 = character_t and base2 = character_t then kind1 := string_t; kind2 := string_t; term_type := string_t; elsif base1 = character_t and uni2 = uni_string_t then kind1 := kind2; elsif uni1 = uni_string_t and base2 = character_t then kind2 := kind1; term_type := kind1; end if; if baseTypesOk( kind1, kind2 ) then if isExecutingCommand then term := term & pterm2; end if; end if; elsif operator = "*" then if baseTypesOk( kind1, natural_t ) then if baseTypesOk( kind2, uni_string_t ) then if isExecutingCommand then term := natural( to_numeric( term ) ) * pterm2; end if; end if; end if; else err( "operation not defined for string types" ); end if; exception when program_error => err( "program_error exception raised" ); term := null_unbounded_string; when others => err( "exception raised" ); term := null_unbounded_string; end; else if operator = "*" then err( "operation * not defined for these types" ); elsif operator = "/" then err( "operation / not defined for these types" ); elsif operator = "&" then err( "operation & not defined for these types" ); end if; end if; end loop; end ParseTerm; procedure ParseSimpleExpressionOperator( op : out unbounded_string ) is -- Syntax: simple-expr-op = '+' | '-' begin -- token value is checked by parseTerm, but not token name if Token /= symbol_t then err( "operator expected"); elsif identifiers( Token ).value /= "+" and identifiers( Token ).value /= "-" then err( "simple expression operator expected"); end if; op := identifiers( token ).value; getNextToken; end ParseSimpleExpressionOperator; procedure ParseSimpleExpression( se : out unbounded_string; expr_type : out identifier ) is -- Syntax: term = "term expr-op term" term1 : unbounded_string; term2 : unbounded_string; kind1 : identifier; kind2 : identifier; operator : unbounded_string; operation: identifier; typesOK : boolean := false; begin ParseTerm( term1, kind1 ); se := term1; expr_type := kind1; while identifiers( Token ).value = "+" or identifiers( Token ).value = "-" loop ParseSimpleExpressionOperator( operator ); ParseTerm( term2, kind2 ); -- Special exception for + and -...allow time arithmetic if (kind1 = cal_time_t) and then (getBaseType(kind2) = duration_t or kind2 = uni_numeric_t or kind2 = universal_t) then typesOK := true; expr_type := cal_time_t; operation := uni_numeric_t; end if; if (kind2 = cal_time_t) and then (getBaseType(kind1) = duration_t or kind1 = uni_numeric_t or kind2 = universal_t) then typesOK := true; expr_type := cal_time_t; operation := uni_numeric_t; end if; -- Otherwise check the types normally if not typesOK then typesOK := baseTypesOk( kind1, kind2 ); expr_type := getBaseType( kind1 ); operation := getUniType( kind1 ); end if; if typesOk then if operation = universal_t then operation := getUniType( kind2 ); end if; if operation = universal_t then operation := uni_string_t; end if; if operation = uni_numeric_t then if operator = "+" then begin if isExecutingCommand then se := to_unbounded_string( to_numeric( se ) + to_numeric( term2 ) ); end if; exception when program_error => err( "program_error exception raised" ); se := null_unbounded_string; when others => err( "exception raised" ); se := null_unbounded_string; end; elsif operator = "-" then begin if isExecutingCommand then se := to_unbounded_string( to_numeric( se ) - to_numeric( term2 ) ); end if; exception when program_error => err( "program_error exception raised" ); se := null_unbounded_string; when others => err( "exception raised" ); se := null_unbounded_string; end; end if; else if operator = "+" then err( "operation + not defined for these types" ); elsif operator = "-" then err( "operation - not defined for these types" ); end if; end if; end if; end loop; --put_line( "Simple Expression value = " & to_string( se ) ); end ParseSimpleExpression; procedure ParseRelationalOperator( op : out unbounded_string ) is -- Syntax: rel-op = >, >=, etc. begin -- token value is checked by parseTerm, but not token name if Token /= symbol_t and Token /= in_t and Token /= not_t then err( "operator expected"); elsif identifiers( Token ).value /= ">=" and identifiers( Token ).value /= ">" and identifiers( Token ).value /= "<" and identifiers( Token ).value /= "<=" and identifiers( Token ).value /= "=" and identifiers( Token ).value /= "/=" and Token /= in_t and Token /= not_t then err( "relational operator expected"); end if; if Token = in_t then op := identifiers( token ).name; elsif Token = not_t then op := to_unbounded_string( "not in" ); getNextToken; if Token /= in_t then err( "relational operator expected"); end if; else op := identifiers( token ).value; end if; getNextToken; end ParseRelationalOperator; procedure ParseRelation( re : out unbounded_string; rel_type : out identifier ) is -- Syntax: relation = "simple-expr" =|>|<|... "simple-expr" se1 : unbounded_string; se2 : unbounded_string; se3 : unbounded_string; kind1 : identifier; kind2 : identifier; kind3 : identifier; operator : unbounded_string; operation: identifier; b : boolean; begin ParseSimpleExpression( se1, kind1 ); re := se1; rel_type := kind1; if identifiers( Token ).value = ">=" or identifiers( Token ).value = ">" or identifiers( Token ).value = "<" or identifiers( Token ).value = "<=" or identifiers( Token ).value = "=" or identifiers( Token ).value = "/=" or Token = in_t or Token = not_t then rel_type := boolean_t; -- always ParseRelationalOperator( operator ); if operator = "in" or operator = "not in" then ParseFactor( se2, kind2 ); if baseTypesOk( kind1, kind2 ) then -- redundant below but expect( symbol_t, ".." ); -- keeps error messages nice ParseFactor( se3, kind3 ); -- should probably restructure if baseTypesOk( kind2, kind3 ) then null; end if; end if; else ParseSimpleExpression( se2, kind2 ); end if; if baseTypesOk( kind1, kind2 ) then operation := getUniType( kind1 ); if operation = universal_t then operation := getUniType( kind2 ); end if; if operation = universal_t then operation := uni_string_t; end if; if operation = uni_numeric_t or else operation = root_enumerated_t or else operation = cal_time_t then begin if operator = ">=" then if isExecutingCommand then b := to_numeric( se1 ) >= to_numeric( se2 ); end if; elsif operator = ">" then if isExecutingCommand then b := to_numeric( se1 ) > to_numeric( se2 ); end if; elsif operator = "<" then if isExecutingCommand then b := to_numeric( se1 ) < to_numeric( se2 ); end if; elsif operator = "<=" then if isExecutingCommand then b := to_numeric( se1 ) <= to_numeric( se2 ); end if; elsif operator = "=" then if isExecutingCommand then b := to_numeric( se1 ) = to_numeric( se2 ); end if; elsif operator = "/=" then if isExecutingCommand then b := to_numeric( se1 ) /= to_numeric( se2 ); end if; elsif operator = "in" then if isExecutingCommand then b := to_numeric( se1 ) in to_numeric( se2 )..to_numeric( se3 ); end if; elsif operator = "not in" then if isExecutingCommand then b := to_numeric( se1 ) not in to_numeric( se2 )..to_numeric( se3 ); end if; else err( "Internal error: couldn't handle relational operator" ); end if; if b then re := to_unbounded_string( "1" ); else re := to_unbounded_string( "0" ); end if; exception when others => err( "exception raised" ); end; elsif operation = uni_string_t then if operator = ">=" then if isExecutingCommand then b := se1 >= se2; end if; elsif operator = ">" then if isExecutingCommand then b := se1 > se2; end if; elsif operator = "<" then if isExecutingCommand then b := se1 < se2; end if; elsif operator = "<=" then if isExecutingCommand then b := se1 <= se2; end if; elsif operator = "=" then if isExecutingCommand then b := se1 = se2; end if; elsif operator = "/=" then if isExecutingCommand then b := se1 /= se2; end if; elsif operator = "in" then err( "in must be used with scalar types" ); elsif operator = "not in" then err( "not in must be used with scalar types" ); else err( "Internal error: couldn't handle relational operator" ); end if; if b then re := to_unbounded_string( "1" ); else re := to_unbounded_string( "0" ); end if; else err( "relational operation not defined for these types" ); end if; end if; end if; end ParseRelation; procedure ParseExpressionOperator( op : out identifier ) is -- Syntax: expr-op = "and" | "or" | "xor" begin if Token /= and_t and Token /= or_t and Token /= xor_t then err( "boolean operator expected"); end if; op := Token; getNextToken; end ParseExpressionOperator; procedure ParseExpression( ex : out unbounded_string; expr_type : out identifier ) is -- Syntax: expr = "relation" and|or|xor "relation" re1 : unbounded_string; re2 : unbounded_string; kind1 : identifier; kind2 : identifier; operator : identifier; last_op : identifier := eof_t; b : boolean; type bitwise_number is mod 2**64; begin ParseRelation( re1, kind1 ); ex := re1; expr_type := kind1; while Token = and_t or Token = or_t or Token = xor_t loop ParseExpressionOperator( operator ); if onlyAda95 and then last_op /= eof_t and then last_op /= operator then err( "mixed boolean operators in expression not allowed with " & optional_bold( "pragam ada_95" ) & " - use parantheses" ); end if; ParseRelation( re2, kind2 ); if baseTypesOk( kind1, kind2 ) then if getUniType( kind1 ) = uni_numeric_t then expr_type := getBaseType( kind1 ); if operator = and_t then begin if isExecutingCommand then re1 := to_unbounded_string( long_float( bitwise_number( to_numeric( re1 ) ) and bitwise_number( to_numeric( re2 ) ) ) ); end if; exception when program_error => err( "program_error exception raised" ); re1 := null_unbounded_string; when others => err( "exception raised" ); re1 := null_unbounded_string; end; elsif operator = or_t then begin if isExecutingCommand then re1 := to_unbounded_string( long_float( bitwise_number( to_numeric( re1 ) ) or bitwise_number( to_numeric( re2 ) ) ) ); end if; exception when program_error => err( "program_error exception raised" ); re1 := null_unbounded_string; when others => err( "exception raised" ); re1 := null_unbounded_string; end; elsif operator = xor_t then begin if isExecutingCommand then re1 := to_unbounded_string( long_float( bitwise_number( to_numeric( re1 ) ) xor bitwise_number( to_numeric( re2 ) ) ) ); end if; exception when program_error => err( "program_error exception raised" ); re1 := null_unbounded_string; when others => err( "exception raised" ); re1 := null_unbounded_string; end; end if; elsif getBaseType( kind1 ) = boolean_t then expr_type := getBaseType( kind1 ); if operator = and_t then if isExecutingCommand then b := re1 = "1" and re2 = "1"; end if; elsif operator= or_t then if isExecutingCommand then b := re1 = "1" or re2 = "1"; end if; elsif operator = xor_t then if isExecutingCommand then b := re1 = "1" xor re2 = "1"; end if; else err( "Internal error: unable to handle boolean operator" ); end if; if b then re1 := to_unbounded_string( "1" ); else re1 := to_unbounded_string( "0" ); end if; else err( "boolean or number expected" ); end if; end if; last_op := operator; end loop; ex := re1; --put_line( "Expression value = " & to_string( ex ) ); end ParseExpression; procedure ParseAssignPart( expr_value : out unbounded_string; expr_type : out identifier ) is -- Syntax: assign-part = " := default_value_expression" -- return value and type for expression begin expect( symbol_t, ":=" ); ParseExpression( expr_value, expr_type ); end ParseAssignPart; procedure ParseArrayAssignPart( array_id : identifier; array_id2: arrayID ) is -- Syntax: array-assign-part = " := ( expr, expr, ... )|second-array" -- others => and positional assignment not (yet) supported -- return value and type for expression expr_value : unbounded_string; expr_type : identifier; arrayIndex : long_integer; lastIndex : long_integer; second_array_id : identifier; second_array_id2 : arrayID; begin -- Note: Array ID will not be valid at syntax check time expect( symbol_t, ":=" ); if token = symbol_t then -- assign (..)? expect( symbol_t, "(" ); -- read constant if isExecutingCommand then arrayIndex := firstBound( array_id2 ); -- low bound lastIndex := lastBound( array_id2 ); -- high bound end if; loop -- read values ParseExpression( expr_value, expr_type ); -- next element if isExecutingCommand then -- not on synchk if not inBounds( array_id2, arrayIndex ) then -- in range? add err( "the array can only hold" & optional_bold( lastIndex'img ) & " elements" ); else assignElement( array_id2, arrayIndex, expr_value ); end if; end if; if arrayIndex = long_integer'last then -- shound never err( "too large for BUSH to store" ); -- happen but else -- check anyway arrayIndex := arrayIndex+1; -- next element end if; -- stop on err exit when error_found or identifiers( token ).value /= ","; -- more? expect( symbol_t, "," ); -- continue end loop; arrayIndex := arrayIndex - 1; -- last added if trace then put_trace( to_string( identifiers( array_id ).name ) & " := " & arrayIndex'img & "elements" ); end if; if isExecutingCommand then -- not on synchk if arrayIndex < lastIndex then -- check sizes err( "array literal has " & optional_bold( arrayIndex'img ) & " elements but the array has" & optional_bold( lastIndex'img ) & " elements" ); end if; end if; expect( symbol_t, ")" ); else -- copying a ParseIdentifier( second_array_id ); -- second array? if isExecutingCommand then if not class_ok( second_array_id, otherClass ) then -- must be arr null; -- and good type elsif baseTypesOK( identifiers( array_id ).kind, identifiers( second_array_id ).kind ) then arrayIndex := firstBound( array_id2 ); -- low bound lastIndex := lastBound( array_id2 ); -- high bound second_array_id2 := arrayID( to_numeric( identifiers( second_array_id ).value ) ); for i in arrayIndex..lastIndex loop -- do the copy expr_value := arrayElement( second_array_id2, i ); assignElement( array_id2, i, expr_value ); end loop; if trace then put_trace( to_string( identifiers( array_id ).name ) & " := " & to_string( identifiers( second_array_id ).name ) ); end if; end if; end if; end if; -- should have put trace here to show assignment results end ParseArrayAssignPart; procedure ParseAnonymousArray( id : identifier ) is -- Syntax: anon-array = " array(expr..expr) of ident [array-assn] -- ParseDeclarationPart was getting complicated so this procedure -- was declared separatly. array_id : arrayID; -- array table index for array variable type_id : arrayID; -- array table index for anon array type ab1 : unbounded_string; -- first array bound kind1 : identifier; -- type of first array bound ab2 : unbounded_string; -- last array bound kind2 : identifier; -- type of last array bound elementType : identifier; -- array elements type elementBaseType : identifier; -- base type of array elements type anonType : identifier; -- identifier for anonymous array type begin -- To create an anonymous array, we have to add a fake array type -- called "an anonymous array" to the symbol table and array table. expect( array_t ); expect( symbol_t, "(" ); ParseExpression( ab1, kind1 ); -- low bound -- should really be a constant expression but we can't handle that if getUniType( kind1 ) = uni_string_t or -- must be scalar identifiers( getBaseType( kind1 ) ).list then err( "array indexes must be scalar types" ); end if; expect( symbol_t, ".." ); ParseExpression( ab2, kind2 ); -- high bound if token = symbol_t and identifiers( token ).value = "," then err( "array of arrays not yet supported" ); elsif baseTypesOk(kind1, kind2 ) then -- indexes good? if isExecutingCommand then -- not on synchk if to_numeric( ab1 ) > to_numeric( ab2 ) then -- bound backwd? if long_integer( to_numeric( ab1 ) ) /= 1 and -- only 1..0 long_integer( to_numeric( ab2 ) ) /= 0 then -- allowed err( "first array bound is higher than last array bound" ); end if; end if; end if; end if; expect( symbol_t, ")" ); -- finished ind expect( of_t ); ParseIdentifier( elementType ); -- Declare anonymous type in symbol table and array table -- -- Note: Bounds are expressions and may not be defined during syntax check -- (Constant assignments, etc. occur only when actually running a script) if not error_found then -- syntax OK, but if execution failed, no elementBaseType := getBaseType( elementType ); if identifiers( elementBaseType ).list then err( "array of arrays not yet supported" ); else declareIdent( anonType, to_unbounded_string( "an anonymous array" ), elementType, typeClass ); identifiers( anonType ).list := true; if class_ok( elementType, typeClass, subClass ) then -- item type OK? if isExecutingCommand then declareArrayType( id => type_id, name => to_unbounded_string( "an anonymous array" ), first => long_integer( to_numeric( ab1 ) ), last => long_integer( to_numeric( ab2 ) ), ind => kind1, blocklvl => blocks_top ); identifiers( anonType ).value := to_unbounded_string( type_id'img ); end if; end if; end if; end if; -- Declare array variable in array table -- -- Note: Bounds are expressions and may not be defined during syntax check -- (Constant assignments, etc. occur only when actually running a script) if isExecutingCommand then declareArray( id => array_id, name => identifiers( id ).value, first => long_integer( to_numeric( ab1 ) ), last => long_integer( to_numeric( ab2 ) ), ind => kind1, blocklvl => blocks_top ); identifiers( id ).value := to_unbounded_string( array_id'img ); end if; -- Change variable into an array if not error_found then -- syntax OK, but if execution failed, no identifiers( id ).list := true; -- var is an array identifiers( id ).kind := anonType; end if; -- Any initial assignment? Then do it. -- -- Note: Array ID will not be valid at syntax check time if token = symbol_t and identifiers( token ).value = ":=" then ParseArrayAssignPart( id, array_id ); end if; end ParseAnonymousArray; procedure ParseArrayDeclaration( id : identifier; arrayType : identifier ) is -- Syntax: array-declaration = " := array_assign" -- ParseDeclarationPart was getting complicated so this procedure -- was declared separatly. array_id : arrayID; type_id : arrayID; begin -- ParseDeclarationPart detected an array type, so let's set up the -- array variable. -- -- Note: Bounds are expressions and may not be defined during syntax check -- (Constant assignments, etc. occur only when actually running a script) if isExecutingCommand then type_id := arrayID( to_numeric( identifiers( getBaseType( arrayType ) ).value ) ); declareArray( id => array_id, name => identifiers( id ).value, first => firstBound( type_id ), last => lastBound( type_id ), ind => indexType( type_id ), blocklvl => blocks_top ); identifiers( id ).value := to_unbounded_string( array_id'img ); end if; -- Change variable into an array identifiers( id ).list := true; -- var is an array identifiers( id ).kind := arrayType; -- Any initial assignment? Then do it. -- -- Note: Array ID will not be valid at syntax check time if token = symbol_t and identifiers( token ).value = ":=" then ParseArrayAssignPart( id, array_id ); end if; end ParseArrayDeclaration; procedure ParseRecordAssignPart( id : identifier; recType : identifier ) is field_no : integer; expr_value : unbounded_string; expr_type : identifier; found : boolean; expected_fields : integer; second_record_id : identifier; begin expect( symbol_t, ":=" ); if token = symbol_t then -- assign (..)? expect( symbol_t, "(" ); -- read constant field_no := 1; begin expected_fields := integer'value( to_string( identifiers( recType ).value ) ); exception when others => expected_fields := 0; end; loop -- read values ParseExpression( expr_value, expr_type ); -- next element found := false; for j in 1..identifiers_top-1 loop if identifiers( j ).field_of = recType then if integer'value( to_string( identifiers( j ).value )) = field_no then found := true; declare fieldName : unbounded_string; field_t : identifier; begin fieldName := identifiers( j ).name; fieldName := delete( fieldName, 1, index( fieldName, "." ) ); fieldName := identifiers( id ).name & "." & fieldName; findIdent( fieldName, field_t ); if field_t = eof_t then err( "unable to find record field " & optional_bold( to_string( fieldName ) ) ); else if baseTypesOK( identifiers( field_t ).kind, expr_type ) then if isExecutingCommand then identifiers( field_t ).value := expr_value; if trace then put_trace( to_string( fieldName ) & " := " & to_string( expr_value ) ); end if; end if; end if; end if; end; end if; end if; end loop; -- for if not found then err( "record literal too long" ); end if; exit when error_found or identifiers( token ).value /= ","; -- more? expect( symbol_t, "," ); field_no := field_no + 1; end loop; expect( symbol_t, ")" ); if expected_fields /= field_no then err( "record literal too short" ); end if; else ParseIdentifier( second_record_id ); -- second rec? if isExecutingCommand then if not class_ok( second_record_id, otherClass ) then -- must be rec null; -- and good type elsif baseTypesOK( identifiers( id ).kind, identifiers( second_record_id ).kind ) then begin expected_fields := integer'value( to_string( identifiers( recType ).value ) ); exception when others => expected_fields := 0; end; declare sourceFieldName : unbounded_string; targetFieldName : unbounded_string; source_field_t : identifier; target_field_t : identifier; begin for field_no in 1..expected_fields loop for j in 1..identifiers_top-1 loop if identifiers( j ).field_of = recType then if integer'value( to_string( identifiers( j ).value )) = field_no then -- find source field sourceFieldName := identifiers( j ).name; sourceFieldName := delete( sourceFieldName, 1, index( sourceFieldName, "." ) ); sourceFieldName := identifiers( second_record_id ).name & "." & sourceFieldName; findIdent( sourceFieldName, source_field_t ); if source_field_t = eof_t then err( "internal error: mismatched source field" ); exit; end if; -- find target field targetFieldName := identifiers( j ).name; targetFieldName := delete( targetFieldName, 1, index( targetFieldName, "." ) ); targetFieldName := identifiers( id ).name & "." & targetFieldName; findIdent( targetFieldName, target_field_t ); if target_field_t = eof_t then err( "internal error: mismatched target field" ); exit; end if; -- copy it identifiers( target_field_t ).value := identifiers( source_field_t ).value; if trace then put_trace( to_string( targetFieldName ) & " := " & to_string( identifiers( target_field_t ).value ) ); end if; end if; -- right number end if; -- field member end loop; -- search loop end loop; -- fields end; end if; end if; end if; end ParseRecordAssignPart; procedure ParseRecordDeclaration( id : identifier; recType : identifier; canAssign : boolean := true ) is -- Syntax: rec-declaration = " := record_assign" begin identifiers( id ).kind := recType; -- if isExecutingCommand then if not error_found then -- Change variable into an record -- Fill record value with ASCII.NUL delimited fields -- -- To do this, search for the i-th field in the formal record declaration -- (the identifier value for the field has the field number). The field name -- contains the full dot qualified name. Get the base field name by removing -- everything except the name after the final dot. Then prefix the name of -- the record being declared (so that "rec_type.f" becomes "my_rec.f"). for i in 1..integer'value( to_string( identifiers( recType ).value ) ) loop for j in 1..identifiers_top-1 loop if identifiers( j ).field_of = recType then if integer'value( to_string( identifiers( j ).value )) = i then declare fieldName : unbounded_string; dont_care_t : identifier; dotPos : natural; begin fieldName := identifiers( j ).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( id ).name & "." & fieldName; declareIdent( dont_care_t, fieldName, identifiers( j ).kind, otherClass ); end; end if; end if; end loop; end loop; end if; if token = symbol_t and identifiers( token ).value = ":=" then if canAssign then ParseRecordAssignPart( id, recType ); end if; end if; end ParseRecordDeclaration; procedure ParseDeclarationPart( id : in out identifier; anon_arrays : boolean ) is -- Syntax: declaration = " : [aliased|constant] ident assign-part" -- Syntax: declaration = " : anonymous-array -- Syntax: declaration = " : array-declaration -- Syntax: declaration = " : record-declaration -- assigns type of identifier and value (if assignment part) -- Note: in some cases, the variable id may change. -- anon_arrays => actually, any nested structure allowed? for records type_token : identifier; expr_value : unbounded_string; expr_type : identifier := eof_t; right_type : identifier; expr_expected : boolean := false; begin expect( symbol_t, ":" ); if token = aliased_t then -- aliased not supported err( "aliased isn't supported" ); elsif token = constant_t then -- handle constant expect( constant_t ); -- by flagging variable identifiers( id ).class := constClass; -- as a constant and expr_expected := true; -- must assign value else identifiers( id ).class := otherClass; -- as a constant and end if; -- Anonymous Array? Handled elsewhere. if token = array_t then -- anonymous array? if not anon_arrays then err( "anonymous arrays not allowed" ); end if; ParseAnonymousArray( id ); -- handle it return; -- and nothing more end if; -- Get the type. ParseIdentifier( type_token ); -- identify type -- Array type? Handled elsewhere. if identifiers( getBaseType( type_token ) ).list then -- array type? if not anon_arrays then err( "nested arrays not yet supported" ); end if; ParseArrayDeclaration( id, type_token ); -- handle it return; -- and nothing more end if; -- Record type? Handled elsewhere. if identifiers( getBaseType( type_token ) ).kind = root_record_t then -- record type? if not anon_arrays then err( "nested records not yet supported" ); end if; ParseRecordDeclaration( id, type_token ); -- handle it return; -- and nothing more end if; -- Verify that the type token is a type and check for types -- not allowed with certain pragmas. if not class_ok( type_token, typeClass, subClass ) then null; elsif onlyAda95 and (type_token = uni_string_t or type_token = uni_numeric_t or type_token = universal_t) then err( "universal/typeless types not allowed with " & optional_bold( "pragam ada_95" ) ); elsif getBaseType( type_token ) = command_t then if onlyAda95 then err( "command types not allowed with " & optional_bold( "pragma ada_95" ) ); elsif not expr_expected then err( "command variables must be constant" ); end if; end if; -- Check for optional assignment if (token = symbol_t and identifiers( token ).value = ":=") or -- assign part? expr_expected then if identifiers( type_token ).limit then err( "limited type variables cannot be assigned a value" ); end if; -- Tricky bit: what about "i : integer := i"? -- Dropping the top of the stack temporarily isn't good enough: if -- the assignment contains backquotes, the name of the command will -- overwrite the hidden variable. The variable must be deleted and -- redeclared later. declare is_constant : boolean := false; var_name : unbounded_string; begin -- Temporarily destroy identifer so that i : integer := i isn't circular var_name := identifiers( id ).name; -- remember name if identifiers( id ).class = constClass then -- a constant? is_constant := true; -- remember it end if; discardUnusedIdentifier( id ); -- discard variable -- Calculate the assignment (ie. using any previous variable i) ParseAssignPart( expr_value, right_type ); -- do := part -- Redeclare temporarily destroyed identifier (ie. declare new i) -- and assign its type declareIdent( id, var_name, type_token, otherClass ); -- declare var if is_constant then -- a constant? identifiers( id ).class := constClass; -- fix class end if; end; -- command types have special limitations if getBaseType( type_token ) = command_t then if baseTypesOk( uni_string_t, right_type ) then type_token := uni_string_t; -- pretend it's a string if not C_is_executable_file( to_string( expr_value ) & ASCII.NUL ) then err( '"' & to_string( expr_value) & '"' & " is not an executable command" ); end if; end if; elsif baseTypesOk( type_token, right_type ) then null; end if; if isExecutingCommand then if getUniType( type_token ) = uni_numeric_t then -- numeric test. universal typelesses could result -- in a non-numeric expression that baseTypesOk -- doesn't catch. declare lf : long_float; begin lf := to_numeric( expr_value ); exception when program_error => err( "program_error exception raised" ); when others => err( "exception raised" ); end; end if; identifiers( id ).value := expr_value; if trace then put_trace( to_string( identifiers( id ).name ) & " := """ & to_string( ToEscaped( expr_value ) ) & """" ); end if; end if; else identifiers( id ).kind := type_token; end if; -- failed somewhere to set a real type? -- blow away half-declared variable if error_found then identifiers( id ).kind := new_t; discardUnusedIdentifier( id ); end if; end ParseDeclarationPart; procedure ParsePragma is type aPragmaType is ( ada_95, asserting, annotate, debug, debug_on, depreciated, export, gcc_errors, import, inspection, inspect_var, noCommandHash, promptChange, restriction, restriction_auto, restriction_external, template, unchecked_import, uninspect_var, unrestricted_template, volatile ); pragmaKind : aPragmaType; expr_val : unbounded_string; results : unbounded_string; var_id : identifier; importType : unbounded_string; begin expect( pragma_t ); if identifiers( token ).name = "ada_95" then pragmaKind := ada_95; elsif identifiers( token ).name = "assert" then pragmaKind := asserting; elsif identifiers( token ).name = "debug" then pragmaKind := debug; elsif identifiers( token ).name = "annotate" then pragmaKind := annotate; elsif identifiers( token ).name = "deprecated" then pragmaKind := depreciated; elsif identifiers( token ).name = "depreciated" then pragmaKind := depreciated; elsif identifiers( token ).name = "export" then pragmaKind := export; elsif identifiers( token ).name = "gcc_errors" then pragmaKind := gcc_errors; elsif identifiers( token ).name = "import" then pragmaKind := import; elsif identifiers( token ).name = "inspect" then pragmaKind := inspect_var; elsif identifiers( token ).name = "inspection_point" then pragmaKind := inspection; elsif identifiers( token ).name = "no_command_hash" then pragmaKind := noCommandHash; elsif identifiers( token ).name = "prompt_script" then pragmaKind := promptChange; elsif identifiers( token ).name = "restriction" then pragmaKind := restriction; elsif identifiers( token ).name = "restrictions" then discardUnusedIdentifier( token ); err( "pragma restriction not restrictions" ); return; elsif identifiers( token ).name = "template" then pragmaKind := template; elsif identifiers( token ).name = "unchecked_import" then pragmaKind := unchecked_import; elsif identifiers( token ).name = "uninspect" then pragmaKind := uninspect_var; elsif identifiers( token ).name = "unrestricted_template" then pragmaKind := unrestricted_template; elsif identifiers( token ).name = "volatile" then pragmaKind := volatile; else discardUnusedIdentifier( token ); err( "unknown pragma" ); return; end if; discardUnusedIdentifier( token ); -- don't declare a new identifier for a pragma -- Parse the pragma parameters (if any) getNextToken; if pragmaKind /= ada_95 and pragmaKind /= inspection and pragmaKind /= noCommandHash then if pragmaKind = debug and (token /= symbol_t or identifiers( token ).value /= "(") then pragmaKind := debug_on; else expect( symbol_t, "(" ); end if; end if; case pragmaKind is when ada_95 => -- pragma ada_95 null; when asserting => -- pragma assert ParseExpression( expr_val, var_id ); when annotate => -- pragma annotate expr_val := identifiers( token ).value; expect( strlit_t ); when debug => -- pragma debug expr_val := identifiers( token ).value; expect( backlit_t ); when debug_on => -- pragma debug (no param) null; when depreciated => -- pragma depreciated expr_val := identifiers( token ).value; expect( strlit_t ); when export => -- pragma export if identifiers( token ).name /= "shell" then discardUnusedIdentifier( token ); err( "only 'shell' convention supported" ); return; else discardUnusedIdentifier( token ); getNextToken; expect( symbol_t, "," ); ParseIdentifier( var_id ); end if; when import | unchecked_import => -- pragma unchecked/import if identifiers( token ).name = "shell" then importType := identifiers( token ).name; discardUnusedIdentifier( token ); getNextToken; expect( symbol_t, "," ); ParseIdentifier( var_id ); elsif identifiers( token ).name = "cgi" then importType := identifiers( token ).name; discardUnusedIdentifier( token ); getNextToken; expect( symbol_t, "," ); ParseIdentifier( var_id ); else discardUnusedIdentifier( token ); err( "only 'shell' or 'cgi' convention supported" ); return; end if; when gcc_errors => -- pragma gcc_errors null; when inspection => -- pragma inspection point null; when noCommandHash => -- pragma no_command_hash null; when promptChange => -- pragma prompt_script expr_val := identifiers( token ).value; expect( backlit_t ); when restriction => -- pragma restriction if identifiers( token ).name = "no_auto_declarations" then discardUnusedIdentifier( token ); getNextToken; pragmaKind := restriction_auto; elsif identifiers( token ).name = "no_external_commands" then discardUnusedIdentifier( token ); getNextToken; pragmaKind := restriction_external; else discardUnusedIdentifier( token ); err( "unknown restriction" ); return; end if; when inspect_var => -- pragma inspect ParseIdentifier( var_id ); when template | unrestricted_template => -- pragma (unrestricted) template if rshOpt then err( "templates are not allowed in a restricted shell" ); else expr_val := identifiers( token ).name; discardUnusedIdentifier( token ); getNextToken; if token = symbol_t and identifiers( token ).value = "," then expect( symbol_t, "," ); expect( strlit_t ); else var_id := eof_t; end if; end if; gccOpt := true; when uninspect_var => -- pragma uninspect ParseIdentifier( var_id ); when volatile => -- pragma volatile ParseIdentifier( var_id ); when others => err( "Internal error: can't handle pragma" ); end case; if pragmaKind /= ada_95 and pragmaKind /= inspection and pragmaKind /= noCommandHash and pragmaKind /= debug_on then expect( symbol_t, ")" ); end if; -- Execute the pragma if isExecutingCommand then case pragmaKind is when ada_95 => onlyAda95 := true; when asserting => if debugOpt then if not syntax_check then -- has no meaning during syntax check if baseTypesOk( boolean_t, var_id ) then if expr_val = "0" then err( "assertion failed" ); end if; end if; end if; end if; when annotate => null; when debug => if debugOpt then if not syntax_check then CompileRunAndCaptureOutput( expr_val, results ); put( results ); end if; end if; when debug_on => debugOpt := true; when depreciated => -- later, this should create a list of depreciation message -- for now, only the entire script is depreciated depreciatedMsg := "This script made obsolete by " & expr_val & '.'; when export => if identifiers( var_id ).class = userProcClass then err( "procedures cannot be exported to the shell environment" ); elsif identifiers( var_id ).class = userFuncClass then err( "functions cannot be exported to the shell environment" ); elsif identifiers( var_id ).list then err( "arrays cannot be exported to the shell environment" ); elsif uniTypesOK( identifiers( var_id ).kind, uni_string_t ) then identifiers( var_id ).export := true; end if; when gcc_errors => gccOpt := true; when import => if identifiers( var_id ).class = userProcClass then err( "procedures cannot be imported" ); elsif identifiers( var_id ).class = userFuncClass then err( "functions cannot be imported" ); elsif identifiers( var_id ).list then err( "arrays cannot be imported" ); elsif uniTypesOK( identifiers( var_id ).kind, uni_string_t ) then identifiers( var_id ).import := true; if processingTemplate and importType = "cgi" then identifiers( var_id ).value := null_unbounded_string; for i in 1..cgi.key_count( to_string( identifiers( var_id ).name ) ) loop identifiers( var_id ).value := identifiers( var_id ).value & to_unbounded_string( cgi.value( to_string( identifiers( var_id ).value ), 1, true ) ); end loop; elsif not processingTemplate and importType = "cgi" then err( "import type cgi must be used in a template" ); else refreshVolatile( var_id ); end if; if trace then put_trace( to_string( identifiers( var_id ).name ) & " := """ & to_string( ToEscaped( identifiers( var_id ).value ) ) & """" ); end if; end if; when inspection => if breakoutOpt then wasSIGINT := true; -- pretend ctrl-c end if; when noCommandHash => clearCommandHash; no_command_hash := true; when restriction_auto => restriction_no_auto_declarations := true; when restriction_external => restriction_no_external_commands := true; when promptChange => promptScript := expr_val; when template | unrestricted_template => templateType := noTemplate; if expr_val = "html" then templateType := htmlTemplate; elsif expr_val = "text" then templateType := textTemplate; else err( "unknown template type" ); end if; if processingTemplate then err( "template already used" ); elsif inputMode = interactive or inputMode = breakout then err( "template is not allowed in an interactive session" ); end if; if var_id = eof_t then templatePath := basename( scriptFilePath ); if length( templatePath ) > 5 and then tail( templatePath, 5 ) = ".bush" then -- Delete( templatePath, length(templatePath)-4, 6 ); Delete( templatePath, length(templatePath)-4, length( templatePath ) ); elsif length( templatePath ) > 4 and then tail( templatePath, 4 ) = ".cgi" then Delete( templatePath, length(templatePath)-3, length( templatePath ) ); end if; templatePath := templatePath & ".tmpl"; else templatePath := identifiers( strlit_t ).value; end if; processingTemplate := true; if pragmaKind = unrestricted_template then unrestrictedTemplate := true; end if; -- Always output CGI header as soon as possible to avoid a HTTP/500 -- error. Give the web server a minimal header to return to the -- browser in case something goes wrong later that would prevent -- the header from being sent. if templateType = htmlTemplate then cgi.put_cgi_header( "Content-type: text/html" ); elsif templateType = textTemplate then cgi.put_cgi_header( "Content-type: text/plain" ); end if; when unchecked_import => if uniTypesOK( identifiers( var_id ).kind, uni_string_t ) then if inEnvironment( var_id ) then identifiers( var_id ).import := true; if processingTemplate then identifiers( var_id ).value := null_unbounded_string; for i in 1..cgi.key_count( to_string( identifiers( var_id ).name ) ) loop identifiers( var_id ).value := identifiers( var_id ).value & to_unbounded_string( cgi.value( to_string( identifiers( var_id ).value ), 1, false) ); end loop; else refreshVolatile( var_id ); end if; if trace then put_trace( to_string( identifiers( var_id ).name ) & " := """ & to_string( ToEscaped( identifiers( var_id ).value ) ) & """" ); end if; end if; end if; when inspect_var => identifiers( var_id ).inspect := true; when uninspect_var => identifiers( var_id ).inspect := false; when volatile => identifiers( var_id ).volatile := true; when others => err( "Internal error: unable to execute pragma" ); end case; end if; end ParsePragma; procedure ParseRecordFields( record_id : identifier; field_no : in out integer ) is -- Syntax: field = declaration [; declaration ... ] field_id : identifier; b : boolean; begin -- ParseNewIdentifier( field_id ); ParseFieldIdentifier( record_id, field_id ); ParseDeclarationPart( field_id, anon_arrays => false ); identifiers( field_id ).class := subClass; -- it is a subtype identifiers( field_id ).field_of := record_id; -- it is a field identifiers( field_id ).value := to_unbounded_string( field_no'img ); expectSemicolon; if not error_found and token /= eof_t and token /= end_t then field_no := field_no + 1; ParseRecordFields( record_id, field_no ); -- the symbol table will overflow before field_no does end if; if error_found then b := deleteIdent( field_id ); end if; end ParseRecordFields; procedure ParseRecordTypePart( newtype_id : identifier ) is -- Syntax: type = "record f1 : t1; ... end record" field_no : integer := 1; b : boolean; begin expect( record_t ); ParseRecordFields( newtype_id, field_no ); expect( end_t ); expect( record_t ); -- if isExecutingCommand then if not error_found then identifiers( newtype_id ).kind := root_record_t; -- a record identifiers( newtype_id ).list := false; -- it isn't an array identifiers( newtype_id ).field_of := eof_t; -- it isn't a field identifiers( newtype_id ).class := typeClass; -- it is a type identifiers( newtype_id ).import := false; -- never import identifiers( newtype_id ).export := false; -- never export identifiers( newtype_id ).value := to_unbounded_string( field_no'img ); -- number of fields in a record variable else -- otherwise b := deleteIdent( newtype_id ); -- discard bad type end if; end ParseRecordTypePart; procedure ParseArrayTypePart( newtype_id : identifier ) is -- Syntax: type = "array(exp1..exp2) of element-type" type_id : arrayID; ab1 : unbounded_string; -- low array bound kind1 : identifier; ab2 : unbounded_string; -- high array bound kind2 : identifier; elementType : identifier; elementBaseType : identifier; -- base type of array elements type b : boolean; begin -- Check the Array Declaration expect( array_t ); expect( symbol_t, "(" ); ParseExpression( ab1, kind1 ); -- should be constant expression but we can't handle those yet if getUniType( kind1 ) = uni_string_t or identifiers( kind1 ).list then err( "array indexes must be scalar types" ); end if; expect( symbol_t, ".." ); ParseExpression( ab2, kind2 ); if token = symbol_t and identifiers( token ).value = "," then err( "array of arrays not yet supported" ); elsif baseTypesOk(kind1, kind2 ) then if isExecutingCommand and not syntax_check then -- ab1/2 undef on synchk if to_numeric( ab1 ) > to_numeric( ab2 ) then if long_integer( to_numeric( ab1 ) ) /= 1 and long_integer( to_numeric( ab2 ) ) /= 0 then err( "first array bound is higher than last array bound" ); end if; end if; end if; end if; expect( symbol_t, ")" ); expect( of_t ); ParseIdentifier( elementType ); -- parent type name -- Finish declaring the array -- -- Note: Bounds are expressions and may not be defined during syntax check -- (Constant assignments, etc. occur only when actually running a script) elementBaseType := getBaseType( elementType ); if identifiers( elementBaseType ).list then err( "array of arrays not yet supported" ); elsif class_ok( elementType, typeClass, subClass ) then -- item type OK? if isExecutingCommand or syntax_check then -- not on synchk declareArrayType( id => type_id, name => identifiers( newtype_id ).name, first => long_integer( to_numeric( ab1 ) ), last => long_integer( to_numeric( ab2 ) ), ind => kind1, blocklvl => blocks_top ); identifiers( newtype_id ).value := to_unbounded_string( type_id'img ); end if; identifiers( newtype_id ).kind := elementType; -- element type identifiers( newtype_id ).list := true; -- it is an array identifiers( newtype_id ).class := typeClass; -- it is a type identifiers( newtype_id ).import := false; -- never import identifiers( newtype_id ).export := false; -- never export else -- otherwise b := deleteIdent( newtype_id ); -- discard bad type end if; end ParseArrayTypePart; procedure ParseType is -- Syntax: type = "type newtype is new oldtype" -- type = "type arraytype is array-type-part" -- NOTE: enumerateds aren't overloadable (yet) newtype_id : identifier; parent_id : identifier; enum_index : integer := 0; b : boolean; begin expect( type_t ); -- "type" ParseNewIdentifier( newtype_id ); -- typename expect( is_t ); -- is if Token = symbol_t and identifiers( token ).value = "(" then -- enumerated -- -- If an error happens during the parsing, some enumerated items -- may be left declared. Should use recursion for parsing the -- items so they can be properly "rolled back". identifiers( newtype_id ).kind := root_enumerated_t; -- the parent is identifiers( newtype_id ).class := typeClass; -- type based on parent_id := newtype_id; -- root enumerated expect( symbol_t, "(" ); -- "(" while token /= eof_t loop -- name [,name] ParseNewIdentifier( newtype_id ); -- enumerated item -- always execute declarations when syntax checking -- because they are needed to test types and interpret -- other statements if isExecutingCommand or syntax_check then -- OK to do it? identifiers( newtype_id ).class := constClass; -- it's a type identifiers( newtype_id ).value := to_unbounded_string( enum_index'img ); identifiers( newtype_id ).kind := parent_id; -- based on parent else -- otherwise b := deleteIdent( newtype_id ); -- discard item end if; enum_index := enum_index + 1; -- next item number exit when error_found or identifiers( token ).value /= ","; -- quit when no "," expect( symbol_t, "," ); -- "," end loop; expect( symbol_t, ")" ); -- closing ")" if error_found or exit_block then -- problems? b := deleteIdent( parent_id ); -- discard parent end if; elsif token = array_t then ParseArrayTypePart( newtype_id ); elsif token = record_t then ParseRecordTypePart( newtype_id ); else -- new type expect( new_t ); -- "new" if token = array_t then err( "omit " & optional_bold( "new" ) & " since array is not derived from another type" ); end if; ParseIdentifier( parent_id ); -- parent type name if class_ok( parent_id, typeClass, subClass ) then -- not a type? if isExecutingCommand or syntax_check then -- OK to do it? identifiers( newtype_id ).kind := parent_id; -- define the type identifiers( newtype_id ).class := typeClass; else -- otherwise b := deleteIdent( newtype_id ); -- discard new type end if; end if; end if; end ParseType; procedure ParseSubtype is -- Syntax: type = "subtype newtype is oldtype" newtype_id : identifier; parent_id : identifier; b : boolean; begin expect( subtype_t ); -- "subtype" ParseNewIdentifier( newtype_id ); -- type name expect( is_t ); -- "is" ParseIdentifier( parent_id ); -- old type if class_ok( parent_id, typeClass, subClass ) then -- not a type? if isExecutingCommand or syntax_check then -- OK to execute? identifiers( newtype_id ).kind := parent_id; -- assign subtype identifiers( newtype_id ).class := subClass; -- subtype class else -- otherwise b := deleteIdent( newtype_id ); -- discard subtype end if; end if; end ParseSubtype; procedure ParseIfBlock is -- Syntax: if-block = "if"... "elsif"..."else"..."end if" expr_val : unbounded_string; expr_type : identifier; b : boolean := false; handled : boolean := false; begin -- if expr then statements expect( if_t ); -- "if" if token = if_t then -- this is from err( "redundant " & optional_bold( "if" ) ); -- GNAT end if; ParseExpression( expr_val, expr_type ); -- expression if not baseTypesOk( boolean_t, expr_type ) then -- not boolean result? err( "boolean expression expected" ); else b := expr_val = "1"; -- convert to boolean end if; expect( then_t ); -- "then" if token = then_t then -- this is from err( "redundant " & optional_bold( "then" ) ); -- GNAT end if; -- elsif expr then statements if b then -- was true? ParseBlock( elsif_t, else_t ); -- handle if block handled := true; -- remember we did it else -- otherwise SkipBlock( elsif_t, else_t ); -- skip if block end if; while token = elsif_t loop -- a(nother) elsif? expect( elsif_t ); -- "elsif" if token = elsif_t then -- this is from err( "redundant " & optional_bold( "elsif" ) ); -- GNAT end if; ParseExpression( expr_val, expr_type ); -- expression if not baseTypesOk( boolean_t, expr_type ) then -- not boolean result? err( "boolean expression expected" ); else b := expr_val = "1"; -- convert to boolean end if; expect( then_t ); -- "then" if token = then_t then -- this is from err( "redundant " & optional_bold( "then" ) ); -- GNAT end if; if b and not handled then -- true (and not previously done) ParseBlock( elsif_t, else_t ); -- handle the elsif block handled := true; -- remember we did it else -- otherwise SkipBlock( elsif_t, else_t ); -- skip elsif block end if; end loop; -- else statements if token = else_t then -- else part? expect( else_t ); -- "else" if token = else_t then -- this is from err( "redundant " & optional_bold( "else" ) ); -- GNAT end if; if not handled then -- nothing handled yet? ParseBlock; -- handle else block else -- otherwise SkipBlock; -- skip else block end if; end if; -- end if expect( end_t ); -- "end if" expect( if_t ); end ParseIfBlock; procedure ParseCaseBlock is -- Syntax: case-block = "case" ident "is" "when" const-ident ["|"...] "=>" ... -- "when others =>" ..."end case" test_id : identifier; case_id : identifier; handled : boolean := false; b : boolean := false; begin -- case id is expect( case_t ); -- "case" ParseIdentifier( test_id ); -- identifier to test if class_ok( test_id, otherClass ) then expect( is_t ); -- "is" end if; -- when const-id => if token /= when_t then -- first when missing? expect( when_t ); -- force error end if; while token = when_t loop expect( when_t ); -- "when" exit when error_found or token = others_t; -- this should be ParseConstantIdentifier b := false; -- assume case fails loop if token = strlit_t then -- strlit allowed if baseTypesOk( identifiers( test_id ).kind, string_t ) then case_id := token; getNextToken; end if; elsif token = charlit_t then -- charlit allowed if baseTypesOk( identifiers( test_id ).kind, character_t ) then case_id := token; getNextToken; end if; elsif token = number_t then -- num lit allowed if uniTypesOk( identifiers( test_id ).kind, uni_numeric_t ) then case_id := token; getNextToken; end if; else -- constant allowed ParseIdentifier( case_id ); -- get the case if identifiers( case_id ).class /= constClass then -- is constant? err( "variable not allowed as a case" ); -- error if not elsif baseTypesOk( identifiers( test_id ).kind, identifiers( case_id ).kind ) then -- types good? null; end if; end if; if not error_found then -- OK? check case b := b or -- against test var identifiers( test_id ).value = identifiers( case_id ).value; end if; exit when error_found or token /= symbol_t or identifiers( token ).value /= "|"; expect( symbol_t, "|" ); -- expect alternate end loop; expect( symbol_t, "=>" ); -- "=>" if b and not handled then -- handled yet? ParseBlock( when_t ); -- if not, handle handled := true; -- and remember done else SkipBlock( when_t ); -- else skip case end if; end loop; -- others part if token /= others_t then -- a little clearer err( "when others expected" ); -- if pointing at end if; -- end case expect( others_t ); -- "others" expect( symbol_t, "=>" ); -- "=>" if not handled then -- not handled yet? ParseBlock; -- handle now else -- else just SkipBlock; -- skip end if; -- end case expect( end_t ); -- "end case" expect( case_t ); end ParseCaseBlock; procedure ParseLoopBlock is -- Syntax: loop-block = "loop" ... "end loop" exit_on_entry : boolean := exit_block; begin pushBlock( newScope => false, newName => "loop loop" ); -- start new scope if syntax_check or exit_block then expect( loop_t ); -- "loop" ParseBlock; -- check loop block goto loop_done; end if; loop expect( loop_t ); -- "loop" ParseBlock; -- handle loop block exit when exit_block or error_found or token = eof_t; topOfBlock; -- jump to top of block end loop; <> pullBlock; -- end of while scope if not syntax_check and not exit_on_entry then -- ignore exit when checking if exit_block and not done then -- exiting and not returning? if trace then Put_trace( "exited loop" ); end if; exit_block := false; -- we handled exit_block end if; end if; expect( end_t ); -- "end loop" expect( loop_t ); end ParseLoopBlock; procedure ParseWhileBlock is -- Syntax: while-block = "while" bool-expr "loop" ... "end loop" expr_val : unbounded_string; expr_type : identifier; b : boolean := false; exiting : boolean := false; exit_on_entry : boolean := exit_block; begin pushBlock( newScope => false, newName => "while loop" ); -- start new scope if syntax_check or exit_block then expect( while_t ); -- "while" if token = while_t then -- this is from err( "redundant " & optional_bold( "while" ) ); -- GNAT end if; ParseExpression( expr_val, expr_type ); -- expression if not baseTypesOk( boolean_t, expr_type ) then -- not boolean? err( "boolean expression expected" ); end if; expect( loop_t ); --- "loop" ParseBlock; -- check while block goto loop_done; end if; loop expect( while_t ); -- "while" ParseExpression( expr_val, expr_type ); -- expression if not baseTypesOk( boolean_t, expr_type ) then -- not boolean? err( "boolean expression expected" ); exit; elsif expr_val /= "1" or error_found or exit_block then -- skipping? expect( loop_t ); -- "loop" SkipBlock; -- skip while block exit; -- and quit end if; -- otherwise do loop if trace then put_trace( "expression is true" ); end if; expect( loop_t ); -- "loop" ParseBlock; -- handle while block exit when exit_block or error_found or token = eof_t; topOfBlock; -- jump to top of block end loop; <> pullBlock; -- end of while scope if not syntax_check and not exit_on_entry then -- ignore exit when checking if exit_block and not done then -- exiting and not returning? if trace then Put_trace( "exited while loop" ); end if; exit_block := false; -- we handled exit_block end if; end if; expect( end_t ); -- "end loop" expect( loop_t ); end ParseWhileBlock; procedure ParseForBlock is -- Syntax: for-block = "for" local-var "in" expr ".." expr "loop" ... "end loop" expr1_val : unbounded_string; expr1_type : identifier; expr2_val : unbounded_string; expr2_type : identifier; expr2_num : long_float; b : boolean := false; test1 : boolean := false; test2 : boolean := false; exiting : boolean := false; for_var : identifier; firstTime : boolean := true; isReverse : boolean := false; exit_on_entry : boolean := exit_block; for_name : unbounded_string; begin pushBlock( newScope => true, newName => "for loop" ); -- start new scope -- well, not strictly a new scope, but we'll need to do this -- to implement automatic declaration of the index variable if syntax_check or exit_block then -- this is complicated enough it should be in it's own nested procedure expect( for_t ); -- "for" for_name := identifiers( token ).name; -- save var name if token = number_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "number" ) ); elsif token = strlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "string literal" ) ); elsif token = backlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "backquoted literal" ) ); elsif token = charlit_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "character literal" ) ); elsif is_keyword( token ) and token /= eof_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "keyword" ) ); elsif token = symbol_t then err( optional_bold( "identifier" ) & " expected, not a " & optional_bold( "symbol" ) ); elsif identifiers( token ).kind = new_t then -- for var discardUnusedIdentifier( token ); -- brand new? toss it end if; -- we'll declare it getNextToken; -- declare after range expect( in_t ); -- "in" if token = reverse_t then -- "reverse"? isReverse := true; expect( reverse_t ); end if; ParseExpression( expr1_val, expr1_type ); -- low range expect( symbol_t, ".." ); -- ".." ParseExpression( expr2_val, expr2_type ); -- high range -- declare for var down here in case older var with same name -- used in for loop range (so that for k in k..k+1 is legit) declareIdent( for_var, for_name, uni_numeric_t); -- declare for var if baseTypesOk( expr1_type, expr2_type ) then -- check types if getUniType( expr1_type ) = uni_numeric_t then null; elsif getUniType( expr1_type ) = root_enumerated_t then null; end if; if not error_found then if isReverse then identifiers( for_var ).kind := expr2_type; -- this type else identifiers( for_var ).kind := expr1_type; -- this type end if; end if; end if; expect( loop_t ); ParseBlock; -- check for block goto abort_loop; end if; loop expect( for_t ); -- "for" if firstTime then if identifiers( token ).kind = new_t then -- for var for_var := token; -- brand new? ok else -- else declare locally declareIdent( for_var, identifiers( token ).name, uni_numeric_t); end if; getNextToken; expect( in_t ); -- "in" if token = reverse_t then -- "reverse"? isReverse := true; expect( reverse_t ); end if; ParseExpression( expr1_val, expr1_type ); -- low range expect( symbol_t, ".." ); -- ".." ParseExpression( expr2_val, expr2_type ); -- high range if error_found then -- errors? goto abort_loop; -- go no further end if; if baseTypesOk( expr1_type, expr2_type ) then -- check types if getUniType( expr1_type ) = uni_numeric_t then null; elsif getUniType( expr1_type ) = root_enumerated_t then null; else err( "numeric or enumerated type expected" ); -- should be err_previous but haven't exported it yet end if; if not error_found then if isReverse then identifiers( for_var ).value := expr2_val; -- for var is identifiers( for_var ).kind := expr2_type; -- this type if isExecutingCommand then expr2_num := to_numeric( expr1_val ); end if; else identifiers( for_var ).value := expr1_val; -- for var is identifiers( for_var ).kind := expr1_type; -- this type if isExecutingCommand then expr2_num := to_numeric( expr2_val ); end if; end if; end if; end if; expect( loop_t ); -- "loop" firstTime := false; -- don't do this again else -- don't interpret for line after first time -- is this necessary any more? while token /= loop_t loop -- skip to getNextToken; -- "loop" end loop; expect( loop_t ); if isReverse then if isExecutingCommand then identifiers( for_var ).value := to_unbounded_string( long_float( to_numeric( identifiers( for_var ).value ) - 1.0 ) ); end if; else if isExecutingCommand then identifiers( for_var ).value := to_unbounded_string( long_float( to_numeric( identifiers( for_var ).value ) + 1.0 ) ); end if; end if; end if; if not isExecutingCommand then -- includes errors or exiting skipBlock; exit; elsif isReverse then if to_numeric( identifiers( for_var ).value ) < expr2_num then skipBlock; exit; end if; elsif to_numeric( identifiers( for_var ).value ) > expr2_num then skipBlock; exit; end if; if trace then put_trace( to_string( identifiers( for_var ).name ) & " := '" & to_string( identifiers( for_var ).value ) & "'" ); end if; ParseBlock; -- handle for block exit when exit_block or error_found or token = eof_t; topOfBlock; -- jump to top of block end loop; <> pullBlock; -- end of while scope if not syntax_check and not exit_on_entry then -- ignore exit when checking if exit_block and not done then -- exiting and not returning? if trace then Put_trace( "exited for loop" ); end if; exit_block := false; -- we handled exit_block end if; end if; expect( end_t ); -- "end loop" expect( loop_t ); end ParseForBlock; procedure ParseDelay is -- Syntax: delay expression -- Source: Ada built-in expr_val : unbounded_string; expr_type : identifier; begin expect( delay_t ); ParseExpression( expr_val, expr_type ); if baseTypesOk( expr_type, duration_t ) then if isExecutingCommand then begin delay duration( to_numeric( expr_val ) ); exception when others => err( "exception raised" ); end; if trace then put_trace( "duration := " & to_string( expr_val ) ); end if; end if; end if; end ParseDelay; procedure ParseTypeset is -- Syntax: typeset identifier is type -- Source: BUSH built-in id : identifier; typeid : identifier := eof_t; b : boolean; begin expect( typeset_t ); if onlyAda95 then discardUnusedIdentifier( token ); err( "typeset is not allowed with " & optional_bold( "pragma ada_95" ) ); return; elsif inputMode /= interactive and inputMode /= breakout then discardUnusedIdentifier( token ); err( "typeset only allowed in an interactive session" ); return; end if; if identifiers( token ).kind = new_t then ParseNewIdentifier( id ); else ParseIdentifier( id ); end if; if token = is_t then expect( is_t ); ParseIdentifier( typeid ); end if; if isExecutingCommand then if typeid = eof_t then identifiers( id ).kind := universal_t; elsif identifiers( id ).list then err( "typeset with array types not yet implemented" ); elsif identifiers( typeid ).list then err( "typeset with array types not yet implemented" ); else identifiers( id ).kind := typeid; end if; else b := deleteIdent( id ); end if; end ParseTypeset; ----------------------------------------------------------------------------- -- PARSE SHELL WORD -- -- Parse and expand a shell word argument. Return a shellWordList containing -- the original pattern, the expanded words and their types. If the first is -- true, the word should be the first word. If there is already shell words -- in the list, any new words will be appended to the list. The caller is -- responsible for clearing (deallocating) the list. -- Expansion is the process of performing substitutions on a shell word. -- -- Bourne shell expansions include: -- TYPE PATTERN EX. WORDS STATUS -- Brace expansion a{.txt,.dat} a.txt a.dat not implemented -- Tilde expansion ~/a.txt /home/ken/a.txt OK -- Variable expansion $HOME/a.txt /home/ken/a.txt no special $ -- Command substituion `echo a.txt` a.txt no $(...) -- Arithmetic expansion - - not implemented -- Word splitting a\ word "a word" OK -- Pathname expansion *.txt a.txt b.txt OK -- -- Since BUSH has to interpret the shell words as part of the byte code -- compilation, word splitting before pathname expansion. This means that -- certain rare expansions will have different results in BUSH than in a -- standard Bourne shell. (Some might call this an improvement over the -- standard.) Otherwise, BUSH conforms to the Bourne shell standard. -- -- The wordType is used to differentiate between words like "|" (a string) -- and | (the pipe operator) which look the same once quotes are removed. ----------------------------------------------------------------------------- procedure ParseShellWord( wordList : in out shellWordList.List; First : boolean := false ) is -- these should be global semicolon_string : constant unbounded_string := to_unbounded_string( ";" ); -- semi-colon, as an unbounded string verticalbar_string : constant unbounded_string := to_unbounded_string( "|" ); -- vertical bar, as an unbounded string ampersand_string : constant unbounded_string := to_unbounded_string( "&" ); -- ampersand, as an unbounded string redirectIn_string : constant unbounded_string := to_unbounded_string( "<" ); -- less than, as an unbounded string redirectOut_string : constant unbounded_string := to_unbounded_string( ">" ); -- greater than, as an unbounded string redirectAppend_string : constant unbounded_string := to_unbounded_string( ">>" ); -- double greater than, as an unbounded string redirectErrOut_string : constant unbounded_string := to_unbounded_string( "2>" ); -- '2' + greater than, as an unbounded string redirectErrAppend_string : constant unbounded_string := to_unbounded_string( "2>>" ); -- '2' + double greater than, as an unbounded string redirectErr2Out_string : constant unbounded_string := to_unbounded_string( "2>&1" ); -- '2' + greater than + ampersand and '1', as an unbounded string itself_string : constant unbounded_string := to_unbounded_string( "@" ); -- itself, as an unbounded string ch : character; inSQuote : boolean := false; -- in single quoted part inDQuote : boolean := false; -- in double quoted part inBQuote : boolean := false; -- in double quoted part inBackslash : boolean := false; -- in backquoted part inDollar : boolean := false; -- $ expansion expansionVar: unbounded_string; -- the $ name escapeGlobs : boolean := false; -- escaping glob chars ignoreTerminatingWhitespace : boolean := false; -- SQL word has whitespace in it (do not use whitespace as a word terminator) expandInSingleQuotes : boolean := false; -- SQL words allow $ expansion for single quotes (for PostgreSQL) stripQuoteMarks : boolean := true; -- SQL words require quotes words left in the word startOfBQuote : integer; addExpansionSQuote : boolean := false; -- SQL, add ' after exp addExpansionDQuote : boolean := false; -- SQL, add " after exp temp_id : identifier; -- for ~ processing shell_word : unbounded_string; word : unbounded_string; wordLen : integer := length( word ); pattern : unbounded_string; wordType : aShellWordType; procedure dollarExpansion is -- perform a dollar expansion by appending a variable's value to the -- shell word. -- NOTE: what about $?, $#, $1, etc? These need to be handed specially here? -- NOTE: special $ expansion, including ${...} should be handled here id : identifier; subword : unbounded_string; ch : character; begin -- put_line( "dollarExpansion for var """ & expansionVar & """" ); -- DEBUG -- Handle Special Substitutions ($#, $? $$, $0...$9 ) if expansionVar = "#" then subword := to_unbounded_string( integer'image( Argument_Count-optionOffset) ); delete( subword, 1, 1 ); elsif expansionVar = "?" then subword := to_unbounded_string( last_status'img ); delete( subword, 1, 1 ); elsif expansionVar = "$" then subword := to_unbounded_string( aPID'image( getpid ) ); delete( subword, 1, 1 ); elsif expansionVar = "0" then subword := to_unbounded_string( Ada.Command_Line.Command_Name ); elsif length( expansionVar ) = 1 and (expansionVar >= "1" and expansionVar <= "9" ) then begin subword := to_unbounded_string( Argument( integer'value( to_string( " " & expansionVar ) )+optionOffset ) ); exception when program_error => err( "program_error exception raised" ); when others => err( "no such argument" ); end; else -- Regular variable substitution findIdent( expansionVar, id ); if id = eof_t then err( optional_bold( to_string( expansionVar ) ) & " not declared" ); else subword := identifiers( id ).value; -- word to substit. if getUniType( id ) = uni_numeric_t then -- a number? if length( subword ) > 0 then -- something there? if element( subword, 1 ) = ' ' then -- leading space delete( subword, 1, 1 ); -- we don't want it end if; end if; end if; end if; end if; -- escapeGlobs affects the variable substitution for i in 1..length( subword ) loop -- each letter ch := element( subword, i ); -- get it if escapeGlobs and not inBackslash then -- esc glob chars? case ch is -- is a glob char? when '*' => pattern := pattern & "\"; -- escape * when '[' => pattern := pattern & "\"; -- escape [ when '\' => pattern := pattern & "\"; -- escape \ when '?' => pattern := pattern & "\"; -- escape * when others => null; -- others? no esc end case; end if; pattern := pattern & ch; -- add the letter word := word & ch; -- add the letter end loop; inDollar := false; -- SQL words require the quote marks to be left intact in the word. -- Unfortunately, this has to be checked after the quote character has -- been processed. This checks for the flag variables to attach a quote -- mark retroactively. if addExpansionSQuote then word := word & "'"; addExpansionSQuote := false; end if; if addExpansionDQuote then word := word & ASCII.Quotation; addExpansionDQuote := false; end if; end dollarExpansion; -- parseShellWord: pathnameExpansion -- -- Perform shell pathname expansion by using the shell word as a glob -- pattern and searching the current directory. Return a list of shell -- words created by the expansion. -- -- Note: file name length is limited to 256 characters. procedure pathnameExpansion( word, pattern : unbounded_string; list : in out shellWordList.List ) is globCriteria : regexp; currentDir : Dir_Type; fileName : string(1..256); fileNameLen : natural; found : boolean := false; noPWD : boolean := false; dirpath : string := to_string( dirname( word ) ); globexpr : string := to_string( basename( pattern ) ); noDir : boolean; isOpen : boolean := false; begin -- put_line( "pathnameExpansion for original pattern """ & pattern & """" ); -- DEBUG -- put_line( "pathnameExpansion for expanded word """ & word & """" ); -- DEBUG -- word is an empty string? it still counts: param is a null string if length( pattern ) = 0 or length( word ) = 0 then shellWordList.Queue( list, aShellWord'( normalWord, pattern, null_unbounded_string ) ); return; end if; -- otherwise, prepare to glob the current directory noDir := globexpr = pattern; globCriteria := Compile( globexpr, Glob => true, Case_Sensitive => true ); begin open( currentDir, dirpath ); isOpen := true; exception when others => noPWD := true; end; -- is the current directory invalid? then param is just the word if noPWD then shellWordList.Queue( list, aShellWord'( normalWord, pattern, word ) ); return; end if; -- Linux/UNIX: skip "." and ".." directory entries read( currentDir, fileName, fileNameLen ); read( currentDir, fileName, fileNameLen ); -- search the directory, adding files that match the glob pattern loop read( currentDir, fileName, fileNameLen ); exit when fileNameLen = 0; if Match( fileName(1..fileNameLen ) , globCriteria ) then if noDir then shellWordList.Queue( list, aShellWord'( normalWord, pattern, to_unbounded_string( fileName( 1..fileNameLen ) ) ) ); else shellWordList.Queue( list, aShellWord'( normalWord, pattern, to_unbounded_string( dirpath & directory_delimiter & fileName( 1..fileNameLen ) ) ) ); end if; found := true; end if; end loop; -- there are no matches? word still counts: the param is just the word if not found then shellWordList.Queue( list, aShellWord'( normalWord, pattern, word ) ); end if; if isOpen then close( currentDir ); end if; exception when ERROR_IN_REGEXP => err( "error in globbing expression """ & globExpr & """" ); if isOpen then close( currentDir ); end if; when DIRECTORY_ERROR => err( "directory error on directory " & dirPath ); end pathnameExpansion; begin word := null_unbounded_string; pattern := null_unbounded_string; wordType := normalWord; -- Get the next unexpanded word. A SQL command is a special case: never -- expand it. We don't want the * in "select *" to be replaced with a list -- of files. -- ignoreTerminatingWhitespace is a workaround and should be redone. We -- need one word but expand the items in the word (for SQL). if token = sql_word_t then shell_word := identifiers( token ).value; ignoreTerminatingWhitespace := true; -- word contains space expandInSingleQuotes := true; stripQuoteMarks := false; getNextToken; else -- Otherwise, get a non-SQL shell word ParseBasicShellWord( shell_word ); end if; -- Null string shell word? Then nothing to do. if length( shell_word ) = 0 then word := null_unbounded_string; pattern := null_unbounded_string; wordType := normalWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; end if; -- Special Cases -- -- The special shell words are always unescaped and never expand. We handle -- them as special cases before beginning the expansion process. ch := Element( shell_word, 1 ); -- next character if ch = ';' then -- semicolon? word := semicolon_string; -- type pattern := semicolon_string; wordType := semicolonWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; elsif ch = '|' then -- vertical bar? word := verticalbar_string; pattern := verticalbar_string; wordType := pipeWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; elsif ch = '&' then -- ampersand? word := ampersand_string; -- type pattern := ampersand_string; wordType := ampersandWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; elsif ch = '<' then -- less than? word := redirectIn_string; -- type pattern := redirectIn_string; wordType := redirectInWord; shellWordList.Queue( wordList, aShellWord'( wordtype, pattern, word ) ); return; elsif ch = '>' then -- greater than? if wordLen > 1 and then Element(shell_word, 2 ) = '>' then -- double greater than? word := redirectAppend_string; -- type pattern := redirectAppend_string; wordType := redirectAppendWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; end if; word := redirectOut_string; -- it's redirectOut pattern := redirectOut_string; wordType := redirectOutWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; elsif ch = '2' and then wordLen > 1 and then Element(shell_word, 2 ) = '>' then -- 2+greater than? if wordLen > 2 and then Element( shell_word, 3 ) = '&' then -- fold error into out? if wordLen > 3 and then Element( shell_word, 4 ) = '1' then word := redirectErr2Out_string; -- type pattern := redirectErr2Out_string; wordType := redirectErr2OutWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; end if; elsif wordLen > 2 and then Element( shell_word, 3 ) = '>' then -- double greater than? word := redirectErrAppend_string; -- it's redirectErrApp pattern := redirectErrAppend_string; wordType := redirectErrAppendWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; end if; word := redirectErrOut_string; -- it's redirectErrOut pattern := redirectErrOut_string; wordType := redirectErrOutWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; elsif ch = '@' then -- itself? word := itself_string; -- it's an itself type pattern := itself_string; wordType := itselfWord; shellWordList.Queue( wordList, aShellWord'( wordType, pattern, word ) ); return; end if; -- There are times when we don't want to expand the word. In the case of -- a syntax check, return the word as-is as a place holder (not sure if -- it's necessary but "> $path" becomes ">" with no path otherwise...at -- least, it's easier for the programmer to debug. if error_found then -- error: return; -- no expansions elsif syntax_check then -- chk? shellWordList.Queue( wordList, aShellWord'( normalWord, pattern, shell_word ) ); return; -- just the word end if; -- as a place holder --------------------------------------------------------------------------- -- We have a word. Perform the expansion: process quotes and other escape -- characters, possibly creating multiple words from one original pattern. --------------------------------------------------------------------------- -- Expand any quotes quotes and handle shell variable substitutions for i in 1..length( shell_word ) loop ch := Element( shell_word, i ); -- next character -- Double Quote? If not escaped by a backslash or single quote, -- we're in a new double quote escape. If we were in a dollar expansion, -- perform the expansion. if ch = '"' and not inSQuote and not inBackslash then -- unescaped "? inDQuote := not inDQuote; -- toggle " flag if inDollar then -- was doing $? dollarExpansion; -- complete it end if; if not stripQuoteMarks then -- SQL word? if inDollar then -- in an exp? addExpansionDQuote := true; -- add after exp else -- else word := word & """"; -- add quote now end if; end if; escapeGlobs := inDQuote; -- inside? do esc -- Single Quote? If not escaped by a backslash or double quote, -- we're in a new single quote escape. If we were in a dollar expansion, -- perform the expansion. elsif ch = ''' and not inDQuote and not inBackslash then -- unescaped '? inSQuote := not inSQuote; -- toggle ' flag if inDollar then -- was doing $? dollarExpansion; -- complete it end if; if not stripQuoteMarks then -- SQL word? if inDollar then -- in an exp? addExpansionSQuote := true; -- add after exp else -- else word := word & "'"; -- add quote now end if; end if; escapeGlobs := inSQuote; -- inside? do esc -- Back Quote? If not escaped by a backslash or single quote, -- we're in a new back quote escape. If we were in a dollar expansion, -- perform the expansion before executing the back quote. elsif ch = '`' and not inSQuote and not inBackslash then -- unescaped `? inBQuote := not inBQuote; -- toggle ` flag if inBQuote and inDollar then -- doing $ ere `? dollarExpansion; -- complete it end if; if inBQuote then -- starting? startOfBQuote := length( word ); -- offset to start else -- ending? if inDollar then -- in a $? dollarExpansion; -- finish it end if; --put_line( "PSW: " & word ); --put_line( "PSW: " & startOfBQuote'img ); --put_line( "PSW: " & length( word )'img ); --put_line( "PSW: " & slice( word, startOfBQuote+1, length( word ) ) ); declare -- to run this backquoted shell word, we need to save the current -- script, compile the command into byte code, and run the commands -- while capturing the output. Substitute the results into the -- shell word and restore the original script. tempStr : unbounded_string := to_unbounded_string( slice( word, startOfBQuote+1, length( word ) ) ); result : unbounded_string; begin delete( word, startOfBQuote+1, length( tempStr ) ); CompileRunAndCaptureOutput( tempStr, result ); word := word & result; end; end if; escapeGlobs := inBQuote; -- inside? do esc -- Backslash? If not escaped by another backslash or single quote, -- we're in a new backslash escape. If we were in a dollar expansion, -- perform the expansion. Keep the backslashes for pathname expansion -- but not for SQL words. elsif ch = '\' and not inSQuote and not inBackslash then -- unescaped \? inBackslash := true; -- \ escape if inDollar then -- in a $? dollarExpansion; -- complete it end if; pattern := pattern & "\"; -- an escaping \ -- Dollar sign? Then begin collecting the letters to the substitution -- variable. elsif ch = '$' and not (inSQuote and not expandInSingleQuotes) and not inBackslash then if inDollar then -- in a $? if length( expansionVar ) = 0 then -- $$ is special expansionVar := expansionVar & ch; -- var is $ dollarExpansion; -- expand it else -- otherwise dollarExpansion; -- complete it inDollar := true; -- start new one end if; else -- not in one? inDollar := true; -- start new one end if; expansionVar := null_unbounded_string; else -- End of quote handling...now we have a character, handle it -- Terminating characters (whitespace or semi-colon) exit when (ch = ' ' or ch = ASCII.HT or ch = ';' or ch = '|' ) and not inDQuote and not inSQuote and not inBQuote and not inBackslash and not ignoreTerminatingWhitespace; -- Looking at a $ expansion? Then collect the letters of the variable -- to substitute but don't add them to the shell word. Apply dollar -- expansions to both word and pattern. if inDollar then -- in a $? expansionVar := expansionVar & ch; -- collect $ name else -- not in $? -- When escaping characters that affect globbing, this is only done -- for the pattern to be used for globbing. Do not escape the -- characters in the word...this will be the fallback word used if -- globbing fails to match any files. -- backslash => user already escaped it if escapeGlobs and not inBackslash then -- esc glob chars? case ch is -- is a glob char? when '*' => pattern := pattern & "\"; -- escape * when '[' => pattern := pattern & "\"; -- escape [ when '\' => pattern := pattern & "\"; -- escape \ when '?' => pattern := pattern & "\"; -- escape * when others => null; -- others? no esc end case; end if; pattern := pattern & ch; -- add the char word := word & ch; -- original word if inBackslash then -- \ escaping? inBackslash := false; -- not anymore end if; end if; end if; end loop; -- expansions done if inDollar then -- last $ not done ? dollarExpansion; -- finish it end if; -- These should never occur because of the tokenizing process, but -- to be safe there should be no open quotes. if inSQuote then err( "Internal error: missing single quote mark" ); elsif inDQuote then err( "Internal error: missing double quote mark" ); end if; -- process special characters for i in 1..length( word ) loop if Element( word, i ) = '~' then -- leading tilda? findIdent( to_unbounded_string( "HOME" ), temp_id ); -- find HOME var pattern := identifiers( temp_id ).value; -- replace w/HOME end if; end loop; -- Don't expand pathname during syntax check if isExecutingCommand then pathnameExpansion( word, pattern, wordList ); if trace then declare theWord : aShellWord; begin if ignoreTerminatingWhitespace then put_trace( "SQL word '" & to_string( toEscaped( pattern ) ) & "' expands to:" ); else put_trace( "shell word '" & to_string( toEscaped( pattern ) ) & "' expands to:" ); end if; for i in 1..shellWordList.length( wordList ) loop shellWordList.Find( wordList, i, theWord ); put_trace( to_string( toEscaped( theWord.word ) ) ); end loop; end; end if; end if; end ParseShellWord; ----------------------------------------------------------------------------- -- PARSE ONE SHELL WORD -- -- Parse and expand one shell word arguments. Return the resulting pattern, -- the expanded word, and the type of word. First should be true if the word -- can be a command. An error occurs if the word can expand into more than -- one word. ----------------------------------------------------------------------------- procedure ParseOneShellWord( wordType : out aShellWordType; pattern, word : in out unbounded_string; First : boolean := false ) is wordList : shellWordList.List; theWord : aShellWord; begin ParseShellWord( wordList, First ); if shellWordList.Length( wordList ) > 1 then err( "one word expected but there were multiple matches" ); else shellWordList.Find( wordList, 1, theWord ); wordType := theWord.wordType; pattern := theWord.pattern; word := theWord.word; end if; shellWordList.Clear( wordList ); end ParseOneShellWord; ----------------------------------------------------------------------------- -- PARSE SHELL WORDS -- -- Parse and expand zero or more shell word arguments. Return the results -- as a shellWordList. First should be true if the first word is a command. -- -- A list of shell words ends with either a semi-colon (the end of a general -- statement) or when a pipe or @ is read in as a parameter. Do not include -- a semi-colon in the parameters. ----------------------------------------------------------------------------- procedure ParseShellWords( wordList : in out shellWordList.List; First : boolean := false ) is theWord : aShellWord; theFirst : boolean := First; begin loop exit when token = symbol_t and identifiers( token ).value = ";"; ParseShellWord( wordList, theFirst ); theFirst := false; shellWordList.Find( wordList, shellWordList.Length( wordList ), theWord ); exit when theWord.wordType = pipeWord; -- pipe always ends a command exit when theWord.wordType = itselfWord; -- itself always ends a command exit when error_found; end loop; end ParseShellWords; procedure ParseVm is -- vm regtype, regnum regtype_val : unbounded_string; regtype_kind : identifier; regnum_val : unbounded_string; regnum_kind : identifier; begin ParseExpression( regtype_val, regtype_kind ); if baseTypesOK( regtype_kind, string_t ) then expect( symbol_t, "," ); ParseExpression( regnum_val, regnum_kind ); if baseTypesOK( regnum_kind, integer_t ) then null; end if; end if; builtins.vm( regtype_val, regnum_val ); end ParseVm; procedure ParseProcedureBlock; procedure ParseFunctionBlock; procedure ParseDeclarations is -- Syntax: declaration = "new-ident decl-part" var_id : identifier; begin while token /= begin_t and token /= eof_t loop if token = pragma_t then ParsePragma; expectSemicolon; elsif token = type_t then ParseType; expectSemicolon; elsif token = subtype_t then ParseSubtype; expectSemicolon; elsif Token = procedure_t then ParseProcedureBlock; elsif Token = function_t then ParseFunctionBlock; else ParseNewIdentifier( var_id ); ParseDeclarationPart( var_id, anon_arrays => true ); -- var id may change... expectSemicolon; end if; end loop; end ParseDeclarations; procedure SkipBlock( termid1, termid2 : identifier := keyword_t ) is old_error : boolean; begin if token = end_t or token = eof_t or token = termid1 or token = termid2 then err( "missing statement or command" ); end if; if syntax_check then -- if we're checking syntax ParseBlock( termid1, termid2 ); -- must process the block to look return; -- for syntax errors end if; --old_error := error_found; -- save error code --error_found := true; -- skip by setting error flag old_error := syntax_check; syntax_check := true; -- if an error happens in the block, we were skipping it anyway... while token /= end_t and token /= eof_t and token /= termid1 and token /= termid2 loop ParseGeneralStatement; -- step through context end loop; --error_found := old_error; -- ignore any error while skipping syntax_check := old_error; end SkipBlock; procedure ParseBlock( termid1, termid2 : identifier := keyword_t ) is -- Syntax: block = "general-stmt [general-stmt...] termid1 | termid2" begin if token = end_t or token = eof_t or token = termid1 or token = termid2 then err( "missing statement or command" ); end if; while token /= end_t and token /= eof_t and token /= termid1 and token /= termid2 loop ParseGeneralStatement; end loop; end ParseBlock; procedure ParseDeclareBlock is begin pushBlock( newScope => true, newName => "declare block" ); expect( declare_t ); ParseDeclarations; expect( begin_t ); ParseBlock; expect( end_t ); pullBlock; end ParseDeclareBlock; procedure ParseBeginBlock is begin pushBlock( newScope => true, newName => "begin block" ); expect( begin_t ); ParseBlock; expect( end_t ); pullBlock; end ParseBeginBlock; procedure ParseFormalParameters( proc_id : identifier; param_no : in out integer ) is -- Syntax: (field = declaration [; declaration ... ] ) -- Fields are implemented using records formal_param_id : identifier; b : boolean; paramName : unbounded_string; type_token : identifier; begin param_no := param_no + 1; ParseNewIdentifier( formal_param_id ); expect( symbol_t, ":" ); -- Check the parameter mode if token = out_t then err( "out parameters not yet supported" ); elsif token = in_t then expect( in_t ); if token = out_t then err( "in out parameters not yet supported" ); end if; elsif token = access_t then err( "access parameters not yet supported" ); end if; -- Check for anonymous array if token = array_t then err( "anonymous array parameters not yet supported" ); end if; -- The name of the type ParseIdentifier( type_token ); -- Check type if identifiers( getBaseType( type_token ) ).list then err( "array parameters not yet supported" ); elsif identifiers( getBaseType( type_token ) ).kind = root_record_t then err( "records not yet supported" ); elsif getBaseType( type_token ) = command_t then err( "commands not yet supported" ); end if; -- Check for default value if token = symbol_t and identifiers( token ).value = ":=" then err( "default values are not supported" ); end if; -- Create the parameter updateFormalParameter( formal_param_id, type_token, proc_id, param_no ); -- Check for further parameters if not error_found and token /= eof_t and not (token = symbol_t and identifiers( token ).value = ")" ) then expectSemicolon; ParseFormalParameters( proc_id, param_no ); -- the symbol table will overflow before field_no does end if; -- Blow away on error if error_found then b := deleteIdent( formal_param_id ); end if; end ParseFormalParameters; procedure ParseFunctionReturnPart( func_id : identifier ) is -- Syntax: (field = declaration [; declaration ... ] ) -- Fields are implemented using records formal_param_id : identifier; b : boolean; paramName : unbounded_string; type_token : identifier; begin expect( return_t ); -- The name of the type ParseIdentifier( type_token ); identifiers( func_id ).kind := type_token; -- Check type if identifiers( getBaseType( type_token ) ).list then err( "array parameters not yet supported" ); elsif identifiers( getBaseType( type_token ) ).kind = root_record_t then err( "records not yet supported" ); elsif getBaseType( type_token ) = command_t then err( "commands not yet supported" ); end if; -- Create the parameter declareIdent( formal_param_id, to_unbounded_string( "return value" ), type_token, otherClass ); updateFormalParameter( formal_param_id, type_token, func_id, 0 ); -- Blow away on error if error_found then b := deleteIdent( formal_param_id ); end if; end ParseFunctionReturnPart; procedure DeclareActualParameters( proc_id : identifier ) is actual_param_t : identifier; param_no : natural; begin if not error_found then -- unlike arrays, user-defined functions and procedures do not have -- a total number of parameters stored in their value field -- functions have an extra, hidden actual parameter for the function -- result (parameter zero). if identifiers( proc_id ).class = userFuncClass then declareReturnResult( actual_param_t, proc_id ); end if; param_no := 1; loop declareActualParameter( actual_param_t, proc_id, param_no, null_unbounded_string ); exit when actual_param_t = eof_t; param_no := param_no + 1; end loop; end if; end DeclareActualParameters; procedure ParseProcedureBlock is -- Syntax: procedure p [(param1...)] OR procedure p [(param1...)] is block -- end p; -- Handle procedure declarations, including forward declarations. -- Note: DoUserDefinedProcedure executes a user-defined procedure created by -- this routine. proc_id : identifier; procStart : natural; procEnd : natural; no_params : integer; begin procStart := firstPos; expect( procedure_t ); ParseProcedureIdentifier( proc_id ); -- A forward declaration? if token /= is_t and not (token = symbol_t and identifiers( token ).value = "(" ) then -- the following is only true for a forward declaration -- (otherwise PPI will return otherClass) if identifiers( proc_id ).class = userProcClass then err( "already forward declared " & optional_bold( to_string( identifiers( proc_id ).name ) ) ); end if; identifiers( proc_id ).class := userProcClass; identifiers( proc_id ).kind := procedure_t; -- otherwise, nothing special for a forward declaration else identifiers( proc_id ).class := userProcClass; identifiers( proc_id ).kind := procedure_t; if token = symbol_t and identifiers( token ).value = "(" then expect( symbol_t, "(" ); no_params := 0; ParseFormalParameters( proc_id, no_params ); expect( symbol_t, ")" ); --identifiers( proc_id ).value := to_unbounded_string( no_params ); end if; pushBlock( newScope => true, newName => to_string (identifiers( proc_id ).name ) ); DeclareActualParameters( proc_id ); expect( is_t ); ParseDeclarations; expect( begin_t ); skipBlock; -- never execute now pullBlock; expect( end_t ); expect( proc_id ); procEnd := lastPos+1; -- include EOL ASCII.NUL identifiers( proc_id ).value := to_unbounded_string( copyByteCodeLines( procStart, procEnd ) ); -- fake initial indent of 1 for byte code (SOH) -- we don't know what the initial indent is (if any) since it may -- not be the first token on the line (though it usually is) end if; expectSemicolon; end ParseProcedureBlock; procedure ParseActualParameters( proc_id : identifier ) is -- Syntax: (field = declaration [; declaration ... ] ) -- Fields are implemented using records expr_value : unbounded_string; expr_type : identifier; --field_id : identifier; --b : boolean; no_param : integer; found : boolean := false; begin expect( symbol_t, "(" ); -- read constant no_param := 1; loop -- read values ParseExpression( expr_value, expr_type ); -- next element -- In a syntax check, the formal parameters aren't created so there's -- no reason to look them up. We're just reading through the parameters -- for the procedure call... if not syntax_check then found := false; for j in 1..identifiers_top-1 loop if identifiers( j ).field_of = proc_id then if integer'value( to_string( identifiers( j ).value )) = no_param then found := true; declare paramName : unbounded_string; formal_param_t : identifier; actual_param_t : identifier; begin formal_param_t := j; if formal_param_t = eof_t then err( "unable to find formal parameter" ); else if baseTypesOK( identifiers( formal_param_t ).kind, expr_type ) then paramName := identifiers( j ).name; paramName := delete( paramName, 1, index( paramName, "." ) ); --findIdent( fieldName, field_t ); declareStandardConstant( actual_param_t, to_string( paramName ), identifiers( formal_param_t ).kind, to_string( expr_value ) ); --would really be a different declare if isExecutingCommand then identifiers( actual_param_t ).value := expr_value; if trace then put_trace( to_string( identifiers( formal_param_t ).name ) & " := " & to_string( expr_value ) ); end if; end if; end if; end if; end; end if; end if; end loop; -- for -- we don't know if there are too few (yet) if not found then err( "parameter not found or too many parameters" ); end if; end if; exit when error_found or identifiers( token ).value /= ","; -- more? expect( symbol_t, "," ); no_param := no_param + 1; end loop; expect( symbol_t, ")" ); end ParseActualParameters; procedure ParseFunctionBlock is -- Syntax: function f OR function p return t is block end p; -- Handle procedure declarations, including forward declarations. -- Note: DoUserDefinedFunction executes a user-defined function created by -- this routine. func_id : identifier; funcStart : natural; funcEnd : natural; no_params : integer; begin funcStart := firstPos; expect( function_t ); ParseProcedureIdentifier( func_id ); identifiers( func_id ).class := userFuncClass; identifiers( func_id ).kind := new_t; if token /= return_t and not (token = symbol_t and identifiers( token ).value = "(" ) then -- the following is only true for a forward declaration -- (otherwise PPI will return otherClass) if identifiers( func_id ).class = userFuncClass then err( "already forward declared " & optional_bold( to_string( identifiers( func_id ).name ) ) ); end if; -- otherwise, nothing special for a forward declaration else if token = symbol_t and identifiers( token ).value = "(" then expect( symbol_t, "(" ); no_params := 0; ParseFormalParameters( func_id, no_params ); expect( symbol_t, ")" ); end if; ParseFunctionReturnPart( func_id ); pushBlock( newScope => true, newName => to_string (identifiers( func_id ).name ) ); DeclareActualParameters( func_id ); expect( is_t ); ParseDeclarations; expect( begin_t ); SkipBlock; -- never execute pullBlock; expect( end_t ); expect( func_id ); funcEnd := lastPos+1; -- include EOL ASCII.NUL identifiers( func_id ).value := to_unbounded_string( copyByteCodeLines( funcStart, funcEnd ) ); -- fake initial indent of 1 for byte code (SOH) -- we don't know what the initial indent is (if any) since it may -- not be the first token on the line (though it usually is) end if; expectSemicolon; end ParseFunctionBlock; procedure DoUserDefinedProcedure( s : unbounded_string ) is -- Execute a user-defined procedure. Based on interpretScript. -- procedure_name [(param1 [,param2...])] -- Note: ParseProcedureBlock compiles / creates the user-defined procedure. -- This routines runs the previously compiled procedure. scriptState : aScriptState; command : unbounded_string := s; resultName : unbounded_string; results : unbounded_string; proc_id : identifier; begin -- Interpret parameters proc_id := token; getNextToken; pushBlock( newScope => true, newName => to_string (identifiers( proc_id ).name ) ); if token = symbol_t and identifiers( token ).value = "(" then ParseActualParameters( proc_id ); end if; if isExecutingCommand then parseNewCommands( scriptState, s ); results := null_unbounded_string; -- no results (yet) expect( procedure_t ); ParseIdentifier( proc_id ); -- we already know the parameter syntax is good so skip to "is" while token /= is_t loop getNextToken; end loop; expect( is_t ); ParseDeclarations; expect( begin_t ); ParseBlock; -- Check to see if we're return-ing early -- Not pretty, but will work. This should be improved. if exit_block and done_sub and not error_found and not syntax_check then done_sub := false; exit_block := false; done := false; end if; expect( end_t ); expect( proc_id ); expectSemicolon; if not done then -- not exiting? expect( eof_t ); -- should be nothing else end if; restoreScript( scriptState ); -- restore original script elsif syntax_check and then length( s ) = 0 then err( "(forward) procedure declaration not completed" ); end if; pullBlock; end DoUserDefinedProcedure; procedure DoUserDefinedFunction( s : unbounded_string; result : out unbounded_string ) is -- Execute a user-defined function. Based on interpretScript. Return value -- for function is result parameter. -- function_name [(param1 [,param2...])] -- Note: ParseFunctionBlock compiles / creates the user-defined function. -- This routines runs the previously compiled function. scriptState : aScriptState; command : unbounded_string := s; func_id : identifier; return_id : identifier; resultName : unbounded_string; results : unbounded_string; begin -- Get the name of the function being called func_id := token; getNextToken; -- Parameters will be in the new scope block pushBlock( newScope => true, newName => to_string (identifiers( func_id ).name ) ); -- Parameters? Create storage space in the symbol table if token = symbol_t and identifiers( token ).value = "(" then ParseActualParameters( func_id ); end if; if isExecutingCommand then -- Prepare to execute. This should probably be a utility function. parseNewCommands( scriptState, s ); results := null_unbounded_string; -- no results (yet) expect( function_t ); -- function ParseIdentifier( func_id ); -- function name while token /= is_t loop -- skip header - syntax is good getNextToken; -- and params are declared end loop; expect( is_t ); -- is ParseDeclarations; -- declaration block expect( begin_t ); -- begin ParseBlock; -- executable block -- Check to see if we're return-ing early -- Not pretty, but will work. This should be improved. if exit_block and done_sub and not error_found and not syntax_check then done_sub := false; exit_block := false; done := false; end if; expect( end_t ); -- end expect( func_id ); -- function_name expectSemicolon; if not done then -- not exiting? expect( eof_t ); -- should be nothing else end if; -- return value is top-most variable called "return value" findIdent( to_unbounded_string( "return value" ), return_id ); result := identifiers( return_id ).value; restoreScript( scriptState ); -- restore original script elsif syntax_check and then length( s ) = 0 then err( "(forward) function declaration not completed" ); end if; pullBlock; -- discard locals end DoUserDefinedFunction; procedure ParseShellCommand is -- Syntax: command-word ( expr [,expr...] ) -- Syntax: command-word param-word [param-word...] cmdNameToken : identifier; cmdName : unbounded_string; expr_val : unbounded_string; expr_type : identifier; ap : argumentListPtr; -- list of parameters to the cmd paramCnt : natural; -- number of parameters in ap firstParam : aScannerState; Success : boolean; exportList : argumentListPtr; -- exported C-string variables exportCnt : natural := 0; -- number of exported variables procedure exportVariables is -- Search for all exported variables and export them to the -- environment so that the program we're running can see them. -- The search must start at the bottom of the symbol table so -- that, in the case of two exported variables with the same -- name, the most recent scope will supercede the older -- declaration. -- The variables exported are stored in exportList/exportCnt. -- Under UNIX/Linux, the application is responsible for storing -- the exported variables as C-strings. The list must be cleared -- afterward. -- Note: this is not very efficient. exportPos : positive := 1; -- position in exportList tempStr : unbounded_string; begin -- count the number of exportable variables for id in 1..identifiers_top-1 loop if identifiers( id ).export and not identifiers( id ).deleted then exportCnt := exportCnt+1; end if; end loop; -- if there are exportable variables, export them and place them -- in exportList. if exportCnt > 0 then exportList := new argumentList( 1..positive( exportCnt ) ); for id in 1..identifiers_top-1 loop if identifiers( id ).export and not identifiers( id ).deleted then tempStr := identifiers( id ).name & "=" & identifiers( id ).value; if trace then put_trace( "exporting '" & to_string( tempStr ) & "'" ); end if; exportList( exportPos ) := new string( 1..length( tempStr )+1 ); exportList( exportPos ).all := to_string( tempStr ) & ASCII.NUL; if putenv( exportList( exportPos ).all ) /= 0 then err( "unable to export " & optional_bold( to_string( identifiers( id ).name) ) ); end if; exportPos := exportPos + 1; end if; end loop; end if; end exportVariables; procedure clearExportedVariables is -- Clear the strings allocated in exportVariables -- should individual strings be deallocated? If so, need to declare -- free? Also, ap list? equalsPos : natural; result : integer; begin if exportCnt > 0 then -- Remove exported items from environment O/S environment for i in exportList'range loop for j in exportList(i).all'range loop if exportList(i)(j) = '=' then equalsPos := j; exit; end if; end loop; C_reset_errno; -- freebsd bug: doesn't return result properly result := putenv( exportList( i )( 1..equalsPos-1 ) & ASCII.NUL ); if result /= 0 and C_errno /= 0 then err( "unable to remove " & optional_bold( exportList( i )( 1..equalsPos-1 ) ) & "from the O/S environment" ); end if; end loop; -- Deallocate memory for i in exportList'range loop free( exportList( i ) ); end loop; free( exportList ); -- deallocate memory exportCnt := 0; end if; end clearExportedVariables; procedure clearParamList is begin for i in ap'range loop free( ap( i ) ); end loop; free( ap ); end clearParamList; function isParanthesis return boolean is -- check for a paranthesis, skipping any white space in front. begin skipWhiteSpace; return token = symbol_t and identifiers( token ).value = "("; -- return script( cmdpos ) = '('; end isParanthesis; -- Word parsing and Parameter counting word : unbounded_string; pattern : unbounded_string; inBackground : boolean; wordType : aShellWordType; -- Pipeline parsing pipe2Next : boolean := false; pipeFromLast : boolean := false; -- I/O Redirection parsing expectRedirectInFile : boolean := false; -- encountered < expectRedirectOutFile : boolean := false; -- encountered > expectRedirectAppendFile : boolean := false; -- encountered >> expectRedirectErrOutFile : boolean := false; -- encountered 2> expectRedirectErrAppendFile : boolean := false; -- encountered 2>> redirectedInputFd : aFileDescriptor := 0; -- input fd (if not 0) redirectedOutputFd : aFileDescriptor := 0; -- output fd (if not 0) redirectedAppendFd : aFileDescriptor := 0; -- output fd (if not 0) redirectedErrOutputFd : aFileDescriptor := 0; -- err out fd (if not 0) redirectedErrAppendFd : aFileDescriptor := 0; -- err out fd (if not 0) result : aFileDescriptor; procedure externalCommandParameters( ap : out argumentListPtr; list : in out shellWordList.List ) is len : positive; theWord : aShellWord; begin if shellWordList.Length( list ) = 0 then ap := new argumentList( 1..0 ); return; end if; len := positive( shellWordList.Length( list ) ); ap := new argumentList( 1..len ); for i in 1..len loop shellWordList.Find( list, long_integer( i ), theWord ); ap( i ) := new string( 1..positive( length( theWord.word ) + 1 ) ); ap( i ).all := to_string( theWord.word ) & ASCII.NUL; end loop; end externalCommandParameters; procedure checkRedirectFile is -- Check for a missing file for a redirection operator. If a file -- was expected (according to the flags) but has not appeared, show -- an appropriate error message. begin if expectRedirectOutFile then err( "expected > file" ); elsif expectRedirectInFile then err( "expected < file" ); elsif expectRedirectAppendFile then err( "expected >> file" ); end if; end checkRedirectFile; wordList : shellWordList.List; shellWord : aShellWord; itselfNext : boolean := false; -- true if a @ was encountered begin -- ParseGeneralStatement just did a resumeScanning. The token should -- still be set to the value of the first word. -- Loop for all commands in a pipeline. <> -- Reset parsing variables related to a single command -- shellWordList.Clear( wordList ); -- discard params -- ParseGeneralStatement has rolled back the scanner after checking for :=. -- Reload the next token. -- getNextToken; -- Expand command variable (if any). Otherwise, parse the first shell -- word. if identifiers( token ).kind /= keyword_t and then identifiers( token ).kind /= new_t and then getBaseType( identifiers( token ).kind ) = command_t then cmdNameToken := token; -- avoid prob below w/discard cmdName := identifiers( token ).value; -- perform alias substitution else cmdNameToken := token; ParseOneShellWord( wordType, pattern, cmdName, First => true ); --if wordType = itselfWord then -- @? -- cmdName := itself; -- use last @ --else -- otherwise itself := cmdName; -- this is new @ --end if; end if; -- AdaScript Syntax: count the number of parameters, generate an argument -- list of the correct length, interpret the parameters "for real". <> inBackground := false; -- assume fg command paramCnt := 0; -- params unknown if isParanthesis then -- parenthesis? -- getNextToken; -- AdaScript syntax expect( symbol_t, "(" ); -- skip paraenthesis markScanner( firstParam ); -- save position while not error_found and not exit_block loop -- count parameters ParseExpression( expr_val, expr_type ); shellWordList.Push( wordList, aShellWord'( normalWord, expr_val, expr_val ) ); paramCnt := paramCnt + 1; if Token = symbol_t and then identifiers( Token ).value = "," then getNextToken; else exit; end if; end loop; expect( symbol_t, ")" ); if token = symbol_t and identifiers( token ).value = "|" then pipe2Next := true; getNextToken; end if; if pipe2Next and onlyAda95 then err( "pipelines are not allowed with " & optional_bold( "pragma ada_95" ) ); end if; if token = symbol_t and identifiers(token).value = "&" then inbackground := true; expect( symbol_t, "&" ); if pipe2Next then err( "no & - piped commands are automatically run in the background" ); elsif pipeFromLast then err( "no & - final piped command always runs in the foreground" ); end if; end if; else -- Bourne shell parameters -- discardUnusedIdentifier( token ); -- Shell-style parameters. Read a series of "words", counting the params. -- Generate an argument list of the correct length and repeat "for real". -- count loop -- markScanner( firstParam ); word := null_unbounded_string; -- Some arguments, | or @ ? go get them... if token /= symbol_t or else identifiers( token ).value /= ";" then ParseShellWords( wordList, First => false ); end if; for i in 1..shellWordList.Length( wordList ) loop shellWordList.Find( wordList, i, shellWord ); if shellWord.wordType = semicolonWord then shellWordList.Clear( wordList, i ); exit; elsif shellWord.wordType = pipeWord then shellWordList.Clear( wordList, i ); pipe2Next := true; exit; elsif shellWord.wordType = itselfWord then shellWordList.Clear( wordList, i ); itselfNext := true; elsif error_found then exit; end if; if shellWord.wordType = redirectOutWord or shellWord.wordType = redirectInWord or shellWord.wordType = redirectAppendWord or shellWord.wordType = redirectErrOutWord or shellWord.wordType = redirectErrAppendWord then if onlyAda95 then err( "command line redirection not allowed with " & optional_bold( "ada_95" ) & ". Use set_output / set_input instead" ); end if; expectRedirectOutFile := true; elsif expectRedirectOutFile then -- redirect filenames expectRedirectOutFile := false; -- not in param list elsif wordType = redirectErr2OutWord then null; -- no file needed end if; end loop; if pipe2Next and onlyAda95 then err( "pipelines not allowed with " & optional_bold( "pragma ada_95" ) ); end if; if shellWordList.length( wordList ) > 0 and onlyAda95 then err( "Bourne shell parameters not allowed with " & optional_bold( "pragma ada_95" ) ); end if; -- create loop --resumeScanning( firstParam ); -- at this point, the token is the first "word". Discard it if it is -- an unused identifier. -- At this point, wordList contains a list of shell word parameters for -- the command. This includes redirections, &, and so forth. Next, -- examine all shell arguments, interpreting them and removing -- them from the list. Set up all I/O redirections as required. When -- this loop is finished, only the command parameters should remain the -- word list. paramCnt := 1; while long_integer( paramCnt ) <= shellWordList.Length( wordList ) loop shellWordList.Find( wordList, long_integer( ParamCnt ), shellWord ); -- put_line( " processing = " & paramCnt'img & " - " & shellWord.pattern & " / " & shellWord.word & "/" & shellWord.wordType'img ); -- There is no check for multiple filenames after redirections. -- This behaviour is the same as BASH: "echo > t.t t2.t" will -- write t2.t to the file t.t in both BASH and BUSH. if expectRedirectOutFile then -- expecting > file? expectRedirectOutFile := false; if redirectedAppendFD > 0 then err( "cannot redirect using both > and >>" ); elsif rshOpt then err( "cannot redirect > in a " & optional_bold( "restricted shell" ) ); elsif pipe2Next then err( "> file should only be after the last pipeline command" ); elsif isExecutingCommand then redirectedOutputFd := open( to_string( shellWord.word ) & ASCII.NUL, O_WRONLY+O_TRUNC+O_CREAT, 8#644# ); if redirectedOutputFd < 0 then err( "Unable to open > file: " & OSerror( C_errno ) ); else result := dup2( redirectedOutputFd, stdout ); if result < 0 then close( redirectedOutputFd ); redirectedOutputFd := 0; err( "unable to set output: " & OSerror( C_errno ) ); end if; end if; end if; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif expectRedirectInFile then expectRedirectInFile := false; -- expecting < file? if pipeFromLast then err( "< file should only be after the first pipeline command" ); elsif isExecutingCommand then redirectedInputFd := open( to_string( shellWord.word ) & ASCII.NUL, O_RDONLY, 8#644# ); if redirectedInputFd < 0 then err( "Unable to open < file: " & OSerror( C_errno ) ); else result := dup2( redirectedInputFd, stdin ); if result < 0 then close( redirectedInputFd ); redirectedInputFd := 0; err( "unable to redirect input: " & OSerror( C_errno ) ); end if; end if; end if; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif expectRedirectAppendFile then expectRedirectAppendFile := false; if redirectedOutputFD > 0 then err( "cannot redirect using both > and >>" ); elsif pipe2Next then err( ">> file should only be after the last pipeline command" ); elsif isExecutingCommand then redirectedAppendFd := open( to_string( shellWord.word ) & ASCII.NUL, O_WRONLY+O_APPEND, 8#644# ); if redirectedAppendFd < 0 then err( "Unable to open >> file: " & OSerror( C_errno ) ); else result := dup2( redirectedAppendFd, stdout ); if result < 0 then close( redirectedAppendFd ); redirectedAppendFd := 0; err( "unable to append output: " & OSerror( C_errno ) ); end if; end if; end if; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif expectRedirectErrOutFile then -- expecting 2> file? expectRedirectErrOutFile := false; if redirectedErrAppendFD > 0 then result := dup2( currentStandardError, stderr ); -- restore stderr if result < 0 then -- check for error err( "unable to restore current error output: " & OSerror( C_errno ) ); end if; close( redirectedErrOutputFd ); -- done with file redirectedErrOutputFD := 0; err( "cannot redirect using both 2> and 2>>" ); elsif pipe2Next then err( "2> file should only be after the last pipeline command" ); elsif isExecutingCommand then redirectedErrOutputFd := open( to_string( shellWord.word ) & ASCII.NUL, O_WRONLY+O_TRUNC+O_CREAT, 8#644# ); if redirectedErrOutputFd < 0 then err( "Unable to open 2> file: " & OSerror( C_errno ) ); elsif rshOpt then err( "cannot redirect 2> in a " & optional_bold( "restricted shell" ) ); else result := dup2( redirectedErrOutputFd, stderr ); if result < 0 then close( redirectedErrOutputFd ); redirectedErrOutputFd := 0; err( "unable to set error output: " & OSerror( C_errno ) ); end if; end if; end if; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif expectRedirectErrAppendFile then expectRedirectErrAppendFile := false; if redirectedErrOutputFD > 0 then result := dup2( currentStandardError, stderr ); -- restore stderr if result < 0 then -- check for error err( "unable to restore current error output: " & OSerror( C_errno ) ); end if; close( redirectedErrOutputFd ); -- done with file redirectedErrOutputFD := 0; err( "cannot redirect using both 2> and 2>>" ); elsif pipe2Next then err( "2>> file should only be after the last pipeline command" ); elsif isExecutingCommand then redirectedErrAppendFd := open( to_string( shellWord.word ) & ASCII.NUL, O_WRONLY+O_APPEND, 8#644# ); if redirectedErrAppendFd < 0 then err( "Unable to open 2>> file: " & OSerror( C_errno ) ); else result := dup2( redirectedErrAppendFd, stderr ); if result < 0 then close( redirectedErrAppendFd ); redirectedErrAppendFd := 0; err( "unable to append error output: " & OSerror( C_errno ) ); end if; end if; end if; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif shellWord.wordType = redirectOutWord then -- >? expect a file? checkRedirectFile; -- check for missing file expectRedirectOutFile := true; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif shellWord.wordType = redirectInWord then -- < ? expect a file checkRedirectFile; -- check for missing file expectRedirectInFile := true; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif shellWord.wordType = redirectAppendWord then -- >> ? expect a file checkRedirectFile; -- check for missing file expectRedirectAppendFile := true; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif shellWord.wordType = redirectErrOutWord then -- 2> ? expect a file checkRedirectFile; -- check for missing file expectRedirectErrOutFile := true; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif shellWord.wordType = redirectErrAppendWord then -- 2>> ? expect a file checkRedirectFile; -- check for missing file expectRedirectErrAppendFile := true; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif shellWord.wordType = redirectErr2OutWord then -- expecting 2>&1 file? if redirectedErrOutputFD > 0 then -- no file for this one result := dup2( currentStandardError, stderr ); -- restore stderr if result < 0 then -- check for error err( "unable to restore current error output: " & OSerror( C_errno ) ); end if; close( redirectedErrOutputFd ); -- done with file redirectedErrOutputFD := 0; err( "cannot redirect using two of 2>, 2>> and 2>&1" ); elsif redirectedErrAppendFD > 0 then -- no file for this one result := dup2( currentStandardError, stderr ); -- restore stderr if result < 0 then -- check for error err( "unable to restore current error output: " & OSerror( C_errno ) ); end if; close( redirectedErrAppendFd ); -- done with file redirectedErrAppendFD := 0; err( "cannot redirect using two of 2>, 2>> and 2>&1" ); elsif pipe2Next then err( "2>&1 file should only be after the last pipeline command" ); else redirectedErrOutputFd := dup2( currentStandardOutput, stderr ); if redirectedErrOutputFd < 0 then redirectedErrOutputFd := 0; err( "unable to set error output: " & OSerror( C_errno ) ); end if; end if; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; elsif shellWord.wordType = ampersandWord then -- & ? if shellWordList.aListIndex( paramCnt ) /= shellWordList.Length( wordList ) then err( "unexpected arguments after &" ); end if; inbackground := true; if pipe2Next then err( "no & - piped commands are automatically run in the background" ); elsif pipeFromLast then err( "no & - final piped command always runs in the foreground" ); end if; shellWordList.Clear( wordList, long_integer( paramCnt ) ); paramCnt := paramCnt-1; end if; paramCnt := paramCnt+1; end loop; checkRedirectFile; -- check for missing file end if; -- End of Parameter Parsing -- At this point, only the command parameters should remain the word list. -- The input/output redirection are in place. Declare the parameters and -- execute the command. if isExecutingCommand then -- no problems? exportVariables; -- make environment -- Create a list of C-strings for the parameters externalCommandParameters( ap, wordList ); if boolean(rshOpt) and then Element( cmdName, 1 ) = '/' then -- rsh & cmd path err( "absolute paths to commands not allowed in " & optional_bold( "restricted shells" ) ); elsif not pipeFromLast and pipe2next then -- first in pipeln? run_inpipe( cmdName, cmdNameToken, ap, Success, -- pipe output background => true, cache => inputMode /= interactive ); elsif pipeFromLast and not pipe2next then -- last in pipeln? run_frompipe( cmdName, cmdNameToken, ap, Success, -- pipe input background => false, cache => inputMode /= interactive ); closePipeline; -- certain cmds (like "less") need to be cleaned up -- with wait4children. Others are OK. Why? -- wait4children -- (child cleanup) -- wait4LastJob? elsif pipeFromLast and pipe2next then -- inside pipeline? run_bothpipe( cmdName, cmdNameToken, ap, Success, -- pipe in & out background => true, cache => inputMode /= interactive ); else -- no pipeline? run( cmdName, cmdNameToken, ap, Success, -- just run it background => inBackground, cache => inputMode /= interactive ); -- run the command end if; clearExportedVariables; -- clear environ discardUnusedIdentifier( cmdNameToken ); -- drop if not ident else -- cmd failure? -- If a pipeline command fails, then commands running in the -- background that accept user input will conflict with the -- command prompt. We've got to wait until the final successful -- pipe command is finished before returning to the command prompt. -- For example, "cat | grep "h" < t.t" will fail because "<" must -- be on the first command. However, cat will already be running -- in the background when the error occurs. BUSH will wait until -- ctrl-d is pressed, at which time the user is presented with the -- command prompt. (This is the same behaviour as BASH.) -- Background commands do not require special handling. if pipeFromLast or pipe2next then -- in a pipeline? wait4LastJob; -- (child cleanup) end if; end if; -- then discard it -- If there was command-line redirection, restore standard input/ -- output to the original destinations. The original files will -- be saved in currentStandardInput/Output. The redirect flags -- should be set properly even if a parsing error occurred. if redirectedOutputFd > 0 then -- output redirect? result := dup2( currentStandardOutput, stdout ); -- restore output if result < 0 then -- check for error err( "unable to restore current output: " & OSerror( C_errno ) ); end if; close( redirectedOutputFd ); -- done with file elsif redirectedInputFd > 0 then -- input redirect? result := dup2( currentStandardInput, stdout ); -- restore input if result < 0 then -- check for error err( "unable to restore current input: " & OSerror( C_errno ) ); end if; close( redirectedInputFd ); -- done with file elsif redirectedAppendFd > 0 then -- append redirect? result := dup2( currentStandardOutput, stdout ); -- restore output if result < 0 then -- check for error err( "unable to restore current output: " & OSerror( C_errno ) ); end if; close( redirectedAppendFd ); -- done with file elsif redirectedErrOutputFd > 0 then -- errout redirect? result := dup2( currentStandardError, stderr ); -- restore stderr if result < 0 then -- check for error err( "unable to restore current error output: " & OSerror( C_errno ) ); end if; close( redirectedErrOutputFd ); -- done with file elsif redirectedErrAppendFd > 0 then -- append redirect? result := dup2( currentStandardError, stderr ); -- restore stderr if result < 0 then -- check for error err( "unable to restore current error output: " & OSerror( C_errno ) ); end if; close( redirectedErrAppendFd ); -- done with file end if; -- restore the semi-colon we threw away at the beginning -- by this point, Token is eof_t, so we'll have to force it to a ';' -- since once Token is eof_t, it's always eof_t in the scanner if ap /= null then -- parameter list? clearParamList; -- discard it shellWordList.Clear( wordList ); end if; -- Comand complete. Look for next in pipeline (if any). pipeFromLast := pipe2Next; -- input from out if pipeFromLast and not error_found and not done then -- OK so far? pipe2Next := false; -- reset pipe flag if not error_found then -- found it? goto next_in_pipeline; -- next piped cmd end if; end if; -- Command ended with @? Re-run with new parameters... if itselfNext then itselfNext := false; goto restart_with_itself; end if; end ParseShellCommand; ----------------------------------------------------------------------------- -- RUN AND CAPTURE OUTPUT -- -- Run the byte code and return the results. Set fragmement to false if the -- byte code is a complete script rather than extracted from as a subscript. -- You usually want to use CompileRunAndCaptureOutput. The only thing that -- uses this procedure directly is the prompt script because the byte code -- is saved. -- -- BUGS: SHOULD BE REWRITTEN TO USE PIPES INSTEAD OF TEMP FILE -- based on interpretScript ----------------------------------------------------------------------------- procedure RunAndCaptureOutput( s : unbounded_string; results : out unbounded_string; fragment : boolean := true ) is scriptState : aScriptState; command : unbounded_string := s; oldStandardOutput : aFileDescriptor; resultFile : aFileDescriptor := -1; resultName : unbounded_string; result : aFileDescriptor; unlinkResult : integer; ch : character := ASCII.NUL; chars : long_integer; begin -- saveScript( scriptState ); -- save current script -- put_token; -- DEBUG results := null_unbounded_string; if isExecutingCommand then -- only for real makeTempFile( resultName ); -- results filename resultFile := open( to_string( resultName ) & ASCII.NUL, -- open results O_WRONLY+O_TRUNC, 8#644# ); -- for writing if resultFile < 0 then -- failed? err( "RunAndCaptureOutput: unable to open file: "& OSerror( C_errno )); elsif trace then -- trace on? put_trace( "results will be captured from file descriptor" & resultFile'img ); end if; end if; if isExecutingCommand or Syntax_Check then -- for real or check parseNewCommands( scriptState, s, fragment ); -- install cmds end if; if isExecutingCommand and resultFile > 0 then -- only for real oldStandardOutput := currentStandardOutput; -- save old stdout result := dup2( resultFile, stdout ); -- redirect stdout if result < 0 then -- error? err( "unable to set output: " & OSerror( C_errno ) ); elsif not error_found then -- no error? currentStandardOutput := resultFile; -- track fd end if; end if; if isExecutingCommand or Syntax_Check then -- for real or check loop -- run commands ParseGeneralStatement; -- general stmts exit when done or error_found or token = eof_t; -- until done, error end loop; -- or reached eof if not done then -- not done? expect( eof_t ); -- should be eof end if; end if; -- Read the results. Don't worry if a syntax check or not. If we were -- redirecting for any reason, get the results and restore standard output -- if commands contain a pipeline, there may have been a fork -- If this is one of the pipeline commands, we'll be exiting -- so check to see that we are still executing something. if not done and resultFile > 0 then -- redirecting? result := dup2( oldStandardOutput, stdout ); -- to original if result < 0 then -- error? err( "unable to restore stdout: " & OSerror( C_errno ) ); else -- no error? currentStandardOutput := oldStandardOutput; -- track fd end if; close( resultFile ); -- reopen results resultFile := open( to_string(resultName) & ASCII.NUL, O_RDONLY, 8#644# ); if resultFile < 0 then -- error? err( "unable to open temp file for reading: " & OSError( C_errno )); else loop -- for all results <> read( chars, resultFile, ch, 1 ); -- slow (one char) if chars = 0 then -- read none? exit; -- done elsif chars < 0 then -- error if C_errno = EAGAIN or C_errno = EINTR then -- retry? goto reread; -- do so end if; -- other error? err( "unable to read results: " & OSError( C_errno ) ); exit; -- and bail end if; results := results & ch; -- add to results end loop; close( resultFile ); -- close and delete end if; unlinkResult := unlink( to_string( resultName ) & ASCII.NUL ); if unlinkResult < 0 then -- unable to delete? err( "unable to unlink temp file: " & OSError( C_errno ) ); end if; if length( results ) > 0 then -- discard last EOL if element( results, length( results ) ) = ASCII.LF then delete( results, length( results ), length( results ) ); if length( results ) > 0 then -- MS-DOS if element( results, length( results ) ) = ASCII.CR then delete( results, length( results ), length( results ) ); end if; end if; end if; end if; -- elsif not syntax_check then -- -- close( resultFile ); end if; -- still executing restoreScript( scriptState ); -- original script end RunAndCaptureOutput; ----------------------------------------------------------------------------- -- COMPILE RUN AND CAPTURE OUTPUT -- -- Compile commands, run the commands and return the results. ----------------------------------------------------------------------------- procedure CompileRunAndCaptureOutput( commands : unbounded_string; results : out unbounded_string ) is byteCode : unbounded_string; scriptState : aScriptState; begin saveScript( scriptState ); -- save current script compileCommand( commands ); byteCode := to_unbounded_string( script.all ); if not error_found then RunAndCaptureOutput( byteCode, results, fragment => false ); end if; restoreScript( scriptState ); -- restore original script end CompileRunAndCaptureOutput; procedure ParseStep is -- debugger: step one instruction forward. Do this by activating SIGINT begin expect( step_t ); if inputMode /= breakout then err( "step can only be used when you break out of a script" ); else done := true; breakoutContinue := true; stepFlag1 := true; put_trace( "stepping" ); end if; end ParseStep; procedure ParseReturn is -- Syntax: return [function-result-expr] -- Return from a subprogram or quit interactive session or resume from a -- breakout. expr_val : unbounded_string; expr_type : identifier; return_id : identifier; begin if inputMode = breakout then expect( return_t ); expectSemicolon; done := true; breakoutContinue := true; syntax_check := true; put_trace( "returning to script" ); elsif inputMode = interactive then if isLoginShell then err( "warning: This is a login shell. Use " & optional_bold( "logout" ) & " to quit." ); else expect( return_t ); expectSemicolon; if isExecutingCommand then DoQuit; end if; end if; else expect( return_t ); if token /= eof_t and token /= symbol_t and identifiers( token ).value /= ";" and identifiers( token ).value /= "|" then if isExecutingCommand then -- return value only exists at run-time. There are better ways to -- do this. findIdent( to_unbounded_string( "return value" ), return_id ); if return_id = eof_t then err( "procedures cannot return a value" ); else -- at this point, we don't know the function id. Maybe we can -- check the block name and derrive it that way. Until we do, -- no type checking on the function result! ParseExpression( expr_val, expr_type ); --if uniTypesOk( expr_type, uni_numeric_t ) then identifiers( return_id ).value := expr_val; if trace then put_trace( "returning """ & to_string( expr_val ) & """" ); end if; end if; --last_status := aStatusCode( to_numeric( expr_val ) ); --end if; else -- for syntax checking, we need to walk the expression ParseExpression( expr_val, expr_type ); end if; expectSemicolon; if isExecutingCommand then DoReturn; end if; else -- no return value? do return expectSemicolon; if isExecutingCommand then DoReturn; end if; end if; end if; end ParseReturn; procedure ParseAssignment is -- Basic variable assignment -- Syntax: var := expression or array(index) := expr var_id : identifier; var_kind : identifier; expr_value : unbounded_string; right_type : identifier; index_value: unbounded_string; index_kind : identifier; array_id : arrayID; arrayIndex : long_integer; begin if inputMode = interactive or inputMode = breakout then if identifiers( token ).kind = new_t and not onlyAda95 and not restriction_no_auto_declarations then ParseNewIdentifier( var_id ); if token = symbol_t and identifiers( token ).value = "(" then err( "cannot automatically declare new arrays" ); discardUnusedIdentifier( var_id ); var_id := eof_t; end if; else ParseIdentifier( var_id ); end if; else ParseIdentifier( var_id ); end if; itself := identifiers( var_id ).value; var_kind := identifiers( var_id ).kind; itself_type := var_kind; if not class_ok( var_id, otherClass ) then null; elsif identifiers( var_kind ).limit then err( "limited variables cannot be assigned a value" ); elsif identifiers( var_id ).kind = root_record_t then err( "cannot assign to an entire record" ); elsif identifiers( var_id ).list then expect( symbol_t, "(" ); ParseExpression( index_value, index_kind ); if getUniType( index_kind ) = uni_string_t or identifiers( index_kind ).list then err( "scalar expression expected" ); end if; expect( symbol_t, ")" ); if isExecutingCommand then array_id := arrayID( to_numeric( identifiers( var_id ).value ) ); arrayIndex := long_integer( to_numeric( index_value ) ); if inBounds( array_id, arrayIndex ) then itself := arrayElement( array_id, arrayIndex ); itself_type := identifiers( itself_type ).kind; else err( "Internal error: unable to find array" ); end if; end if; var_kind := identifiers( var_kind ).kind; -- array of what? end if; ParseAssignPart( expr_value, right_type ); if inputMode = interactive or inputMode = breakout then if identifiers( var_id ).kind = new_t and not onlyAda95 and not restriction_no_auto_declarations and not error_found then var_kind := right_type; identifiers( var_id ).kind := right_type; identifiers( var_id ).class := otherClass; put_trace( "Assuming " & to_string( identifiers( var_id ).name ) & " is a new " & to_string( identifiers( right_type ).name ) & " variable" ); end if; end if; if baseTypesOk( var_kind, right_type ) then if getUniType( var_id ) = uni_numeric_t then -- numeric test. universal typelesses could result -- in a non-numeric expression that baseTypesOk -- doesn't catch. declare lf : long_float; begin if isExecutingCommand then lf := to_numeric( expr_value ); end if; exception when others => err( "'" & to_string( expr_value) & "' is not numeric" ); end; end if; if isExecutingCommand then if identifiers( var_id ).list then --mem_id := long_integer( to_numeric( identifiers( var_id ).value ) ); --arrayIndex := long_integer( to_numeric( index_value ) ); if not inBounds( array_id, arrayIndex ) then err( "exception raised" ); else assignElement( array_id, arrayIndex, expr_value ); if trace then put_trace( to_string( identifiers( var_id ).name ) & "(" & to_string( index_value ) & ")" & " := """ & to_string( ToEscaped( expr_value ) ) & """" ); end if; end if; else identifiers( var_id ).value := expr_value; if trace then -- builtins.env( ident ) would be better if a value is -- returned put_trace( to_string( identifiers( var_id ).name ) & " := """ & to_string( ToEscaped( expr_value ) ) & """" ); end if; end if; end if; end if; itself_type := new_t; end ParseAssignment; procedure ParseVarDeclaration is -- Basic variable declaration -- Syntax: var [,var2 ...] declaration_part -- Array variables can only be declared one-at-a-time var_id : identifier; var2_id : identifier; name : unbounded_string; multi : boolean := false; b : boolean; begin ParseNewIdentifier( var_id ); if token = symbol_t and identifiers( token ).value = "," then expect( symbol_t, "," ); var2_id := token; pragma warnings( off ); -- hide infinite recursion warning ParseVarDeclaration; multi := true; pragma warnings( on ); if error_found then discardUnusedIdentifier( var_id ); else if identifiers( var2_id ).list then err( "multiple arrays cannot be declared in one declaration" ); -- because only the array is assigned values with := -- unless I want to copy all the array elements everytime. -- Also, can't overwrite array ident value field. b := deleteIdent( var2_id ); else -- OK so far? copy declaration leftward through variable list name := identifiers( var_id ).name; identifiers( var_id ) := identifiers( var2_id ); identifiers( var_id ).name := name; -- Record type? Must create fields. if identifiers( getBaseType( identifiers( var_id ).kind ) ).kind = root_record_t then -- record type? -- put_line( "Recursing for " & identifiers( var_id ).name ); -- put_token; ParseRecordDeclaration( var_id, identifiers( var_id ).kind, canAssign => false ); -- copy values for fields declare numFields : natural; source_id, target_id : identifier; begin numFields := natural( to_numeric( identifiers( identifiers( var_id ).kind ).value ) ); -- put_line( "Copying " & numFields'img ); for i in 1..numFields loop findField( var_id, i, source_id ); findField( var2_id, i, target_id ); identifiers( source_id ).value := identifiers( target_id ).value; end loop; end; end if; end if; end if; return; end if; ParseDeclarationPart( var_id, anon_arrays => true ); -- var id may change...won't effect next stmt if error_found then discardUnusedIdentifier( var_id ); end if; end ParseVarDeclaration; procedure ParseGeneralStatement is -- Syntax: env-cmd | clear-cmd | ... expr_value : unbounded_string; expr_type : identifier; cmdStart : aScannerState; must_exit : boolean; eof_flag : boolean := false; term_id : identifier; startToken : identifier; begin -- mark start of line (prior to breakout test which will change token -- to eof ) startToken := Token; markScanner( cmdStart ); -- put( "PGS: " ); put_token; -- DEBUG -- interrupt handling if stepFlag1 then stepFlag1 := false; stepFlag2 := true; elsif stepFlag2 then stepFlag2 := false; wasSIGINT := true; end if; if wasSIGINT then -- control-c? if inputMode = interactive or inputMode = breakout then -- interactive? wasSIGINT := false; -- just ignore elsif not breakoutOpt then -- no breakouts? wasSIGINT := false; -- clear flag DoQuit; -- stop BUSH else -- running script? for i in 1..identifiers_top-1 loop if identifiers( i ).inspect then Put_Identifier( i ); end if; end loop; err( optional_inverse( "Break: return to continue, logout to quit" ) ); -- show stop posn end if; elsif wasSIGWINCH then -- window change? findIdent( to_unbounded_string( "TERM" ), term_id ); checkDisplay( identifiers( term_id ).value ); -- adjust size wasSIGWINCH := false; end if; -- Parse the general statement -- -- built-in? itself := identifiers( token ).value; itself_type := token; if Token = command_t then err( "Bourne shell command command not implemented" ); -- getNextToken; -- ParseShellCommand; elsif Token = typeset_t then ParseTypeSet; elsif Token = pragma_t then ParsePragma; elsif Token = type_t then ParseType; elsif Token = null_t then getNextToken; elsif Token = subtype_t then ParseSubtype; elsif Token = if_t then ParseIfBlock; elsif Token = case_t then ParseCaseBlock; elsif Token = while_t then ParseWhileBlock; elsif Token = for_t then ParseForBlock; elsif Token = loop_t then ParseLoopBlock; elsif Token = return_t then ParseReturn; return; elsif Token = step_t then ParseStep; elsif token = logout_t then --if not isLoginShell and inputMode /= interactive and inputMode /= breakout then -- ^--not as restrictive if not isLoginShell and inputMode /= breakout then err( "warning: this is not a login shell: use " & optional_bold( "return" ) & " to quit" ); end if; getNextToken; expectSemicolon; if not error_found or inputMode = breakout then DoQuit; end if; return; elsif Token = create_t then ParseOpen( create => true ); elsif Token = open_t then ParseOpen; elsif Token = close_t then ParseClose; elsif Token = put_line_t then ParsePutLine; elsif token = symbol_t and identifiers( token ).value = "?" then ParseQuestion; elsif Token = put_t then ParsePut; elsif Token = new_line_t then ParseNewLine; elsif Token = skip_line_t then ParseSkipLine; elsif Token = set_input_t then ParseSetInput; elsif Token = set_output_t then ParseSetOutput; elsif Token = set_error_t then ParseSetError; elsif Token = cmd_setexit_t then ParseSetExitStatus; elsif Token = reset_t then ParseReset; elsif Token = delete_t then getNextToken; if token = symbol_t and identifiers( token ).value = "(" then resumeScanning( cmdStart ); ParseDelete; else discardUnusedIdentifier( token ); resumeScanning( cmdStart ); ParseShellCommand; end if; elsif Token = get_t then ParseGet; elsif Token = os_system_t then ParseOSSystem; elsif Token = delay_t then ParseDelay; elsif Token = locks_lock_t then ParseLockLockFile; elsif Token = locks_unlock_t then ParseLockUnlockFile; elsif token = cgi_put_cgi_header_t then -- CGI.put_cgi_headr ParsePut_CGI_Header; elsif token = cgi_put_HTML_head_t then -- CGI.put_html_head ParsePut_HTML_Head; elsif token = cgi_put_HTML_heading_t then -- CGI.put_html_heading ParsePut_HTML_Heading; elsif token = cgi_put_HTML_tail_t then -- CGI.put_html_tail ParsePut_HTML_Tail; elsif token = cgi_put_error_message_t then -- CGI.put_error_msg ParsePut_Error_Message; elsif token = cgi_put_variables_t then -- CGI.put_variables ParsePut_Variables; elsif token = cgi_set_cookie_t then -- CGI.set_cookie ParseSet_Cookie; elsif token = cal_split_t then -- Calendar.Split ParseCalSplit; elsif Token = sound_play_t then ParsePlay; elsif Token = sound_playcd_t then ParsePlayCD; elsif Token = sound_stopcd_t then ParseStopCD; elsif Token = sound_mute_t then ParseMute; elsif Token = sound_unmute_t then ParseUnmute; elsif Token = replace_t then ParseStringsReplace; elsif Token = csv_replace_t then ParseStringsCSVReplace; elsif Token = split_t then ParseStringsSplit; elsif token = db_connect_t then -- DB.Connect ParseDBConnect; elsif token = db_disconnect_t then -- DB.Disconnect ParseDBDisconnect; elsif token = db_reset_t then -- DB.Reset ParseDBReset; elsif token = db_set_rollback_on_finalize_t then -- DB.SetRollbackOnFinalize ParseDBSetRollbackOnFinalize; elsif token = db_open_db_trace_t then -- DB.OpenDBTrace ParseDBOpenDBTrace; elsif token = db_close_db_trace_t then -- DB.CloseDBTrace ParseDBCloseDBTrace; elsif token = db_set_trace_t then -- DB.SetTrace ParseDBSetTrace; elsif token = db_clear_t then -- DB.Clear ParseDBClear; elsif token = db_prepare_t then -- DB.Prepare ParseDBPrepare; elsif token = db_append_t then -- DB.Append ParseDBAppend; elsif token = db_append_line_t then -- DB.Append_Line ParseDBAppendLine; elsif token = db_append_quoted_t then -- DB.Append_Quoted ParseDBAppendQuoted; elsif token = db_execute_t then -- DB.Execute ParseDBExecute; elsif token = db_execute_checked_t then -- DB.Execute_Checked ParseDBExecuteChecked; elsif token = db_raise_exceptions_t then -- DB.Raise_Exceptions ParseDBRaiseExceptions; elsif token = db_report_errors_t then -- DB.Report_Errors ParseDBReportErrors; elsif token = db_begin_work_t then -- DB.Begin_Work ParseDBBeginWork; elsif token = db_rollback_work_t then -- DB.Rollback_Work ParseDBRollbackWork; elsif token = db_commit_work_t then -- DB.Commit_Work ParseDBCommitWork; elsif token = db_rewind_t then -- DB.Rewind ParseDBRewind; elsif token = db_fetch_t then -- DB.Fetch ParseDBFetch; elsif token = db_show_t then -- DB.Show ParseDBShow; elsif token = db_list_t then -- DB.List ParseDBList; elsif token = db_schema_t then -- DB.Schema ParseDBSchema; elsif token = db_users_t then -- DB.Users ParseDBUsers; elsif token = db_databases_t then -- DB.Databases ParseDBDatabases; elsif token = mysql_connect_t then -- MYSQL.Connect ParseMySQLConnect; elsif token = mysql_disconnect_t then -- MYSQL.Disconnect ParseMySQLDisconnect; elsif token = mysql_reset_t then -- MYSQL.Reset ParseMySQLReset; elsif token = mysql_set_rollback_on_finalize_t then -- MYSQL.SetRollbackOnFinalize ParseMySQLSetRollbackOnFinalize; elsif token = mysql_open_db_trace_t then -- MYSQL.OpenDBTrace ParseMySQLOpenDBTrace; elsif token = mysql_close_db_trace_t then -- MYSQL.CloseDBTrace ParseMySQLCloseDBTrace; elsif token = mysql_set_trace_t then -- MYSQL.SetTrace ParseMySQLSetTrace; elsif token = mysql_clear_t then -- MYSQL.Clear ParseMySQLClear; elsif token = mysql_prepare_t then -- MYSQL.Prepare ParseMySQLPrepare; elsif token = mysql_append_t then -- MYSQL.Append ParseMySQLAppend; elsif token = mysql_append_line_t then -- MYSQL.Append_Line ParseMySQLAppendLine; elsif token = mysql_append_quoted_t then -- MYSQL.Append_Quoted ParseMySQLAppendQuoted; elsif token = mysql_execute_t then -- MYSQL.Execute ParseMySQLExecute; elsif token = mysql_execute_checked_t then -- MYSQL.Execute_Checked ParseMySQLExecuteChecked; elsif token = mysql_raise_exceptions_t then -- MYSQL.Raise_Exceptions ParseMySQLRaiseExceptions; elsif token = mysql_report_errors_t then -- MYSQL.Report_Errors ParseMySQLReportErrors; elsif token = mysql_begin_work_t then -- MYSQL.Begin_Work ParseMySQLBeginWork; elsif token = mysql_rollback_work_t then -- MYSQL.Rollback_Work ParseMySQLRollbackWork; elsif token = mysql_commit_work_t then -- MYSQL.Commit_Work ParseMySQLCommitWork; elsif token = mysql_rewind_t then -- MYSQL.Rewind ParseMySQLRewind; elsif token = mysql_fetch_t then -- MYSQL.Fetch ParseMySQLFetch; elsif token = mysql_show_t then -- MYSQL.Show ParseMySQLShow; elsif token = mysql_list_t then -- MYSQL.List ParseMySQLList; elsif token = mysql_schema_t then -- MYSQL.Schema ParseMySQLSchema; elsif token = mysql_users_t then -- MYSQL.Users ParseMySQLUsers; elsif token = mysql_databases_t then -- MYSQL.Databases ParseMySQLDatabases; elsif token = numerics_set_re_t then -- Set_Re (complex) ParseNumericsSetRe; elsif token = numerics_set_im_t then -- Set_Im (complex) ParseNumericsSetIm; elsif token = arrays_bubble_sort_t then -- Bubble_Sort ParseArraysBubbleSort; elsif token = arrays_bubble_sort_descending_t then -- Bubble_Sort_Desc ParseArraysBubbleSortDescending; elsif token = arrays_heap_sort_t then -- Heap_Sort ParseArraysHeapSort; elsif token = arrays_heap_sort_descending_t then -- Heap_Sort_Desc ParseArraysHeapSortDescending; elsif token = arrays_shuffle_t then -- Shuffle ParseArraysShuffle; elsif token = arrays_reverse_t then -- Reverse ParseArraysReverse; elsif token = arrays_rotate_left_t then -- Rotate_Left ParseArraysRotateLeft; elsif token = arrays_rotate_right_t then -- Rotate_Left ParseArraysRotateRight; elsif token = arrays_shift_left_t then -- Shift_Left ParseArraysShiftLeft; elsif token = arrays_shift_right_t then -- Shift_Right ParseArraysShiftRight; -- elsif token = sdl_init_t then -- SDL.Init -- ParseSDLInit; -- elsif token = sdl_quit_t then -- SDL.Quit -- ParseSDLQuit; elsif token = pen_set_rect_t then -- Pen.Set_Rect ParsePenSetRect; elsif token = pen_offset_rect_t then -- Pen.Offset_Rect ParsePenOffsetRect; elsif token = pen_inset_rect_t then -- Pen.Inset_Rect ParsePenInsetRect; elsif token = pen_intersect_rect_t then -- Pen.Intersect_Rect ParsePenIntersectRect; elsif token = pen_set_pen_mode_t then -- Pen.Set_Pen_Mode ParsePenSetPenMode; elsif token = pen_set_pen_ink_t then -- Pen.Set_Pen_Ink ParsePenSetPenInk; elsif token = pen_set_pen_brush_t then -- Pen.Set_Pen_Brush ParsePenSetPenBrush; elsif token = pen_set_pen_pattern_t then -- Pen.Set_Pen_Pattern ParsePenSetPenPattern; elsif token = pen_move_to_t then -- Pen.Move_To ParsePenMoveTo; elsif token = pen_move_t then -- Pen.Move ParsePenMove; elsif token = pen_line_to_t then -- Pen.Line_To ParsePenLineTo; elsif token = pen_line_t then -- Pen.Line ParsePenLine; elsif token = pen_frame_rect_t then -- Pen.Frame_Rect ParsePenFrameRect; elsif token = pen_fill_rect_t then -- Pen.Fill_Rect ParsePenFillRect; elsif token = pen_frame_ellipse_t then -- Pen.Fill_Ellipse ParsePenFrameEllipse; elsif token = pen_fill_ellipse_t then -- Pen.Fill_Ellipse ParsePenFillEllipse; elsif token = pen_new_screen_canvas_t then -- Pen.New_Screen_Canvas ParsePenNewScreenCanvas; elsif token = pen_new_window_canvas_t then -- Pen.New_Window_Canvas ParsePenNewWindowCanvas; elsif token = pen_new_canvas_t then -- Pen.New_Canvas ParsePenNewCanvas; elsif token = pen_get_pen_ink_t then -- Pen.Get_Pen_Ink ParsePenGetPenInk; elsif token = pen_set_title_t then -- Pen.Set_Title ParsePenSetTitle; elsif token = dirops_change_dir_t then -- Dir_Ops.Change_Dir ParseDirOpsChangeDir; elsif token = dirops_make_dir_t then -- Dir_Ops.Make_Dir ParseDirOpsMakeDir; elsif token = dirops_remove_dir_t then -- Dir_Ops.Remove_Dir ParseDirOpsRemoveDir; elsif Token = else_t then err( "else without if" ); elsif Token = elsif_t then err( "elsif without if" ); elsif Token = with_t then err( "with not implemented" ); elsif Token = use_t then err( "use not implemented" ); elsif Token = task_t then err( "tasks not implemented" ); elsif Token = protected_t then err( "protected types not implemented" ); elsif Token = package_t then err( "packages not implemented" ); elsif Token = exit_t then if blocks_top = block'first then -- not complete. should check err( "no enclosing loop to exit" ); -- not just for no blocks end if; -- but the block type isn't easily checked expect( exit_t ); if token = when_t or token = if_t then -- if to give "expected when" expect( when_t ); ParseExpression( expr_value, expr_type ); if baseTypesOk( boolean_t, expr_type ) then must_exit := expr_value = "1"; end if; else must_exit := true; end if; if isExecutingCommand and must_exit then exit_block := true; if trace then put_trace( "exiting" ); end if; end if; elsif Token = declare_t then ParseDeclareBlock; elsif Token = begin_t then ParseBeginBlock; elsif token = word_t then -- discardUnusedIdentifier( token ); resumeScanning( cmdStart ); ParseShellCommand; elsif token = backlit_t then err( "unexpected backquote literal" ); elsif token = procedure_t then err( "declare procedures in declaration sections" ); elsif token = function_t then err( "declare functions in declaration sections" ); elsif Token = eof_t then eof_flag := true; -- a script could be a single comment without a ; elsif Token = symbol_t and identifiers( token ).value = "@" then err( "@ must appear after a command or in an assignment expression" ); elsif not identifiers( Token ).deleted and identifiers( Token ).list then -- array variable resumeScanning( cmdStart ); -- assume array assignment ParseAssignment; -- looks like a AdaScript command itself_type := new_t; -- except for token type... elsif not identifiers( Token ).deleted and identifiers( token ).class = userProcClass then DoUserDefinedProcedure( identifiers( token ).value ); else -- we need to check the next token then back up -- should really change scanner to double symbol look ahead? getNextToken; -- declarations if Token = symbol_t and (to_string( identifiers( token ).value ) = ":" or to_string( identifiers( token ).value ) = ",") then resumeScanning( cmdStart ); ParseVarDeclaration; else -- assignments -- -- for =, will be treated as a command if we don't force an error -- here for missing :=, since it was probably intended as an assignment if Token = symbol_t and to_string( identifiers( token ).value ) = "=" then expect( symbol_t, ":=" ); elsif Token = symbol_t and to_string( identifiers( token ).value ) = ":=" then resumeScanning( cmdStart ); ParseAssignment; itself_type := new_t; else -- assume it's a shell command and run it -- current token is first "token" of parameter. Blow it away -- if able (ie. "ls file", current token is file but we don't -- need that in our identifier list.) discardUnusedIdentifier( token ); resumeScanning( cmdStart ); ParseShellCommand; end if; end if; end if; if not eof_flag then if token = symbol_t and identifiers( token ).value = "@" then if onlyAda95 then err( "@ is not allowed with " & optional_bold( "pragma ada_95" ) ); -- move to next token or inifinite loop if done = true getNextToken; elsif itself_type = new_t then err( "@ is not defined" ); getNextToken; -- shell commands have no class so we can't do this (without -- changes, anyway...) --elsif class_ok( itself_type, procClass ) then -- lift this? else token := itself_type; if identifiers( token ).class = otherClass then -- not a procedure or keyword? restore value identifiers( token ).value := itself; end if; end if; else itself_type := new_t; expectSemicolon; end if; end if; -- breakout handling -- -- Breakout to a prompt if there was an error and --break is used. -- Don't break out if syntax checking or the error was caused while -- in the break out command prompt. if error_found and then boolean(breakoutOpt) then if not syntax_check and inputMode /= breakout then declare -- we need to save saveMode : anInputMode := inputMode; -- BUSH's state scriptState : aScriptState; -- current script begin wasSIGINT := false; -- clear sig flag saveScript( scriptState ); -- save position error_found := false; -- not a real error script := null; -- no script to run inputMode := breakout; -- now interactive interactiveSession; -- command prompt restoreScript( scriptState ); -- restore original script if breakoutContinue then -- continuing execution? resumeScanning( cmdStart ); -- start of command err( optional_inverse( "resuming here" ) ); -- redisplay line done := false; -- clear logout flag error_found := false; -- not a real error exit_block := false; -- and don't exit syntax_check := false; breakoutContinue := false; -- we handled it end if; inputMode := saveMode; -- restore BUSH's resumeScanning( cmdStart ); -- overwrite EOF token end; end if; end if; exception when symbol_table_overflow => err( optional_inverse( "too many identifiers (symbol table overflow)" ) ); when block_table_overflow => err( optional_inverse( "too many nested statements/blocks (block table overflow)" ) ); end ParseGeneralStatement; procedure ParseMainProgram is program_id : identifier; begin expect( procedure_t ); ParseNewIdentifier( program_id ); identifiers( program_id ).kind := keyword_t; -- not really, but will do for now! pushBlock( newScope => true, newName => to_string (identifiers( program_id ).name ) ); -- Note: pushBlock must be before "is" (single symbol look-ahead) expect( is_t ); ParseDeclarations; expect( begin_t ); ParseBlock; pullBlock; expect( end_t ); expect( program_id ); end ParseMainProgram; ------------------------------------------------------------------------------ -- PARSE -- -- Initiate parsing a compiled set of AdaScript commands. The commands should -- have been compiled by interpretCommands or interpretScript. This subprogram -- doesn't compile byte code. error_found will be true if the commands failed -- because of errors. ------------------------------------------------------------------------------ procedure parse is begin if not error_found then cmdpos := firstScriptCommandOffset; token := identifiers'first; -- dummy, replaced by g_n_t getNextToken; -- load first token while (not error_found and not done) and (token = procedure_t or token = pragma_t or token = trace_t) loop if token = pragma_t then ParsePragma; expectSemicolon; elsif token = procedure_t then ParseMainProgram; expectSemicolon; expect( eof_t ); -- should be nothing else exit; elsif token = trace_t then ParseShellCommand; expectSemicolon; end if; end loop; if not done or token = eof_t then loop ParseGeneralStatement; -- process the first statement exit when done or token = eof_t; -- continue until done end loop; -- or eof hit if not done then -- not exiting? expect( eof_t ); -- should be nothing else end if; end if; end if; end parse; ------------------------------------------------------------------------------ -- PARSE NEW COMMANDS -- -- Switch to a new set of commands. This is used for user-defined procedures, -- functions and back quoted commands. It is up to the caller to restore the -- scanner state. ------------------------------------------------------------------------------ procedure parseNewCommands( scriptState : out aScriptState; commands : unbounded_string; fragment : boolean := true ) is begin saveScript( scriptState ); -- save current script if fragment then -- a fragment of byte code? replaceScriptWithFragment( commands ); -- install proc as script else -- otherwise a complete script? replaceScript( commands ); -- install proc as script end if; -- put_line( toEscaped( to_unbounded_string( script.all ) ) ); -- DEBUG inputMode := fromScriptFile; -- running a script error_found := false; -- no error found exit_block := false; -- not exit-ing a block cmdpos := firstScriptCommandOffset; -- start at first char token := identifiers'first; -- dummy, replaced by g_n_t getNextToken; -- load first token end parseNewCommands; --------------------------------------------------------- -- END OF ADASCRIPT PARSER --------------------------------------------------------- ------------------------------------------------------------------------------ -- Running stuff ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- INTERACTIVE SESSION -- -- Begin an interactive session, processing a set of commands typed in by the -- user. Handle SIGINT at the command prompt as well as restoring standard -- output/etc. as required so that lines can be typed in from the console. -- Continue until the done flag is set. -- This is run by parse, as the command line options dictate. This is also -- used to start a debugging session on interactive breakout. ------------------------------------------------------------------------------ procedure interactiveSession is command : unbounded_string; result : aFileDescriptor; begin loop -- repeatedly updateJobStatus; -- cleanup any background jobs error_found := false; -- no err for prompt if length( promptScript ) = 0 then prompt := defaultPrompt; if terminalWindowNaming then put( ASCII.ESC & "]2;" & "bush" & ASCII.BEL ); -- xterm window title end if; else prompt := null_unbounded_string; CompileRunAndCaptureOutput( promptScript, prompt ); if terminalWindowNaming then put( ASCII.ESC & "]2;" ); for i in 1..length( prompt ) loop if is_graphic( element( prompt, i ) ) then put( element( prompt, i ) ); elsif element( prompt, i ) = ASCII.LF then -- and CR? put( ' ' ); end if; end loop; put( ASCII.BEL ); -- xterm window title end if; end if; put_bold( prompt ); -- show prompt in bold wasSIGINT := false; -- clear for getLine getLine( command, keepHistory => true ); -- read command from keyboard if wasSIGINT then -- control-c? command := null_unbounded_string; -- pretend empty command wasSIGINT := false; -- we handled it new_line; -- user didn't push enter end if; -- has user redirected standard in/out/error? then redirect them for -- the duration of execution of the commands (and restore the original -- values later) if currentStandardInput /= originalStandardInput then result := dup2( currentStandardInput, stdin ); -- restore stdin if result < 0 then put_line( standard_error, "Unable to redirect standard input" ); end if; end if; if currentStandardOutput /= originalStandardOutput then result := dup2( currentStandardOutput, stdout ); -- restore stdout if result < 0 then put_line( standard_error, "Unable to redirect standard output" ); end if; end if; if currentStandardError /= originalStandardError then result := dup2( currentStandardError, stderr ); -- restore stderr if result < 0 then put_line( standard_error, "Unable to redirect standard error" ); end if; end if; error_found := false; -- no err found (prompt) exit_block := false; -- not exit-ing a block fixSpacing( command ); -- strip leading/trailing spaces if length( command ) > 0 then -- something there? if Element( command, length( command ) ) /= ';' then -- missing ending ;? command := command & ";"; -- it's implicit so add it elsif length( command ) > 1 then if Element( command, length( command )-1) = '\' then command := command & ";"; end if; end if; -- w/space in case shell cmd sourceFilesList.Clear( SourceFiles ); sourceFilesList.Push( SourceFiles, aSourceFile'( name => to_unbounded_string( commandLineSource ) ) ); compileCommand( command ); if not error_found then cmdpos := firstScriptCommandOffset; -- start at first char token := identifiers'first; -- dummy, replaced by g_n_t getNextToken; -- load first token while token /= eof_t and not error_found loop ParseGeneralStatement; -- do the command end loop; end if; end if; -- restore original standard input, output, error for the command line result := dup2( originalStandardInput, stdin ); -- restore standard input if result < 0 then put_line( standard_error, "Unable to restore standard input" ); end if; result := dup2( originalStandardOutput, stdout ); -- restore standard output if result < 0 then put_line( standard_error, "Unable to restore standard output" ); end if; result := dup2( originalStandardError, stderr ); -- restore standard error if result < 0 then put_line( standard_error, "Unable to restore standard error" ); end if; exit when done; -- and stop when done end loop; end interactiveSession; ------------------------------------------------------------------------------ -- INTERPRET SCRIPT -- -- Load a script, compile byte code, perform a syntax check (if needed) and -- execute the script (if needed). If -e, scriptPath is a string of commands. -- This is run by parse, as the command line options dictate. -- -- scriptPath: a script to run, or a string of commands (-e). ------------------------------------------------------------------------------ procedure BUSH_interpretScript( C_scriptPath : C_path ) is begin interpretScript( To_Ada( C_scriptPath ) ); end BUSH_interpretScript; procedure interpretScript( scriptPath : string ) is firstLine : aliased unbounded_string; begin if syntax_check then if verboseOpt then Put_Trace( "Checking Syntax" ); end if; else if verboseOpt then Put_Trace( "Executing Script" ); end if; end if; inputMode := fromScriptFile; -- running a script if execOpt then -- -e? if verboseOpt then Put_Trace( "Compiling Byte Code" ); end if; -- put( ASCII.ESC & "]2;" & "bush" & ASCII.BEL ); -- xterm window title sourceFilesList.Clear( SourceFiles ); sourceFilesList.Queue( SourceFiles, aSourceFile'(name => to_unbounded_string (commandLineSource) ) ); scriptFilePath := to_unbounded_string( commandLineSource ); -- script name compileCommand( to_unbounded_string( ScriptPath ) ); -- path is really script else -- else path is a path --put( ASCII.ESC & "]2;" & scriptPath & ASCII.BEL ); -- xterm window title scriptFilePath := to_unbounded_string( scriptPath ); -- script name sourceFilesList.Clear( SourceFiles ); sourceFilesList.Queue( SourceFiles, aSourceFile'(name => scriptFilePath) ); scriptFile := open( scriptPath & ASCII.NUL, 0, 660 ); -- open script if scriptFile < 1 then -- error? scriptFilePath := scriptFilePath & ".bush"; -- try name with ".bush" scriptFile := open( scriptPath & ".bush" & ASCII.NUL, 0, 660 ); end if; if scriptFile > 0 then -- good? error_found := false; -- no error found exit_block := false; -- not exit-ing a block if not LineRead( firstLine'access ) then -- read first line put_line( standard_error, "unable to read first line of script" ); error_found := true; goto error; -- and interpreting end if; if script = null then if verboseOpt then Put_Trace( "Compiling Byte Code" ); end if; compileScript( firstline ); end if; end if; end if; if (scriptFile > 0 or boolean(execOpt)) and not done then -- file open or -e? parse; elsif C_errno = 2 then -- file not found? put_line( standard_error, "unable to open script file '" & scriptPath & "' : file not found" ); error_found := true; elsif C_errno /= 0 then -- some other error? -- use /= 0 in case user aborts with control-c put_line( standard_error, "unable to open script file '" & scriptPath & "' : " & OSerror( C_errno ) ); error_found := true; end if; <> if error_found then -- was there an error? if last_status = 0 then -- no last command status? set_exit_status( Failure ); -- just set to 1 if trace then put_trace("Script exit status is" & failure'img ); end if; else -- otherwise set_exit_status( exit_status( last_status ) ); -- return last status if trace then put_trace("Script exit status is" & last_status'img ); end if; end if; else -- no error? set_exit_status( 0 ); -- return no error if trace then -- -x? show 0 exit status put_trace("Script exit status is 0" ); end if; end if; if not execOpt then -- not -e? close( scriptFile ); -- close the script file end if; end interpretScript; ------------------------------------------------------------------------------ -- INTERPRET COMMANDS -- -- Compile string of commands into byte code, perform a syntax check (if -- needed) and execute the script (if needed). -- This is run by parse, as the command line options dictate. -- -- commandString: a string of uncompressed commands (e.g. from -e). ------------------------------------------------------------------------------ procedure BUSH_interpretCommands( C_commandString : C_cmds ) is begin interpretCommands( To_Ada( C_commandString ) ); end BUSH_interpretCommands; procedure interpretCommands( commandString : string ) is begin interpretCommands( to_unbounded_string( commandString ) ); end interpretCommands; procedure interpretCommands( commandString : unbounded_string ) is begin if syntax_check then if verboseOpt then Put_Trace( "Checking Syntax" ); end if; else if verboseOpt then Put_Trace( "Executing Commands" ); end if; end if; if verboseOpt then Put_Trace( "Compiling Byte Code" ); end if; scriptFilePath := to_unbounded_string( commandLineSource ); -- "script" name sourceFilesList.Clear( SourceFiles ); sourceFilesList.Push( SourceFiles, aSourceFile'( name => basename( scriptFilePath ) ) ); compileCommand( commandString ); parse; if error_found then -- was there an error? if last_status = 0 then -- no last command status? set_exit_status( Failure ); -- just set to 1 if trace then put_trace("Command string exit status is" & failure'img ); end if; else -- otherwise set_exit_status( exit_status( last_status ) ); -- return last status if trace then put_trace("Command string exit status is" & last_status'img ); end if; end if; else -- no error? set_exit_status( 0 ); -- return no error if trace then put_trace("Command string exit status is 0" ); end if; end if; end interpretCommands; procedure SetStandardVariables is -- Define variables that cannot be setup by the scanner. begin -- Standard_Input, Standard_Output and Standard_Error have the -- form of a typical file variable. DoInitFileVariableFields( standard_input_t, originalStandardInput, "", in_file_t ); DoInitFileVariableFields( standard_output_t, originalStandardOutput, "", out_file_t ); DoInitFileVariableFields( standard_error_t, originalStandardError, "", out_file_t ); -- Current_Input, Current_Output and Current_Error are aliases for -- another file (by default, Standard_Input/Output/Error ). identifiers( current_input_t ).value := to_unbounded_string( standard_input_t'img ); identifiers( current_output_t ).value := to_unbounded_string( standard_output_t'img ); identifiers( current_error_t ).value := to_unbounded_string( standard_error_t'img ); end SetStandardVariables; ------------------------------------------------------------------------------ -- INTERPRET -- -- Begin executing things. Specifically, set up the environmental flags based -- on the command line options, run the .profile script(s) and then interpret -- commands or start an interactive session. After the script is run and -- templates have been specified, run the templates. If a script has been -- marked as depreciated, show the appropriate warning. ------------------------------------------------------------------------------ procedure interpret is save_rshOpt : commandLineOption; -- for executing profile save_execOpt : commandLineOption; -- for executing profile home_id : identifier; -- HOME variable begin if optionOffset = 0 then -- no arguments or '-'? if isLoginShell then -- login shell? find profile save_rshOpt := rshOpt; -- if restricted shell save_execOpt := execOpt; -- if cmd line script rshOpt := false; -- turn off for profile -- we're using scriptFile and scriptFilePath as temp variables -- here. They'll be overwritten when the script is interpreted. scriptFile := open( "/etc/bush_profile" & ASCII.NUL, 0, 660 ); -- open script if scriptFile > 0 then -- good? close( scriptFile ); -- close test fd interpretScript( "/etc/bush_profile" ); -- run login script end if; findIdent( to_unbounded_string( "HOME" ), home_id ); if home_id /= eof_t then -- HOME defined? scriptFilePath := identifiers( home_id ).value; if Element( scriptFilePath, length( scriptFilePath ) ) /= '/' then scriptFilePath := scriptFilePath & "/"; end if; scriptFilePath := scriptFilePath & ".bush_profile"; scriptFile := open( to_string( scriptFilePath ) & ASCII.NUL, 0, 660 ); -- open script if scriptFile > 0 then -- profile opened OK? close( scriptFile ); -- close test fd interpretScript( to_string( scriptFilePath ) ); -- do profile end if; end if; rshOpt := save_rshOpt; -- restore rsh setting execOpt := save_execOpt; -- restore -e setting end if; inputMode := interactive; -- we're interactive if traceOpt then -- -x / --trace? trace := true; -- turn on trace end if; interactiveSession; -- start the session else if syntaxOpt then -- -c / --check? syntax_check := true; -- check syntax only interpretScript( Argument( OptionOffset ) ); -- check the script elsif nosyntaxOpt then -- -n / --nocheck? if traceOpt then -- -x / --trace? trace := true; -- turn on trace end if; interpretScript( Argument( OptionOffset ) ); -- run the script else syntax_check := true; -- check syntax only interpretScript( Argument( optionOffset ) ); -- check the script if not error_found then -- no errors? resetScanner; -- discard declarations SetStandardVariables; -- built-in elaboration if traceOpt then -- -x? trace := true; -- turn on trace end if; interpretScript( Argument( optionOffset ) ); -- run the script end if; if length( depreciatedMsg ) > 0 then -- pragma depreciated? put( standard_error, scriptFilePath ); -- show the message put( standard_error, ":" ); -- as a warning put( standard_error, getLineNo'img ); put( standard_error, ":" ); put_line( standard_error, "warning--" & depreciatedMsg ); end if; if processingTemplate then -- doing a template if verboseOpt then Put_Trace( "Processing template " & to_string( templatePath ) ); end if; begin processTemplate; exception when STATUS_ERROR => err( "cannot open template " & optional_bold( to_string( templatePath ) ) & " - file may be locked" ); when NAME_ERROR => err( "template " & optional_bold( to_string( templatePath ) ) & " doesn't exist or is not readable" ); when MODE_ERROR => err( "interal error: mode error on template " & optional_bold( to_string( templatePath ) ) ); when END_ERROR => err( "interal error: end of file reached on template " & optional_bold( to_string( templatePath ) ) ); -- when others => -- err( "unable to open template " & optional_bold( to_string( templatePath ) ) ); end; end if; end if; end if; end interpret; ------------------------------------------------------------------------------ -- Housekeeping ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- START PARSER -- -- Startup this package, performing any set up tasks. In this case, set up -- standard input, standard output and standard error so they can be redirected. -- Also, initialize the random number generator. -- -- The original stdin/out/err must be copied to prevent them from being -- closed and lost. They are needed at the shell prompt to draw the -- prompt and to read typing by the user. For output redirection in -- scripts or commands, we'll always work with duplicates of the -- originals, leaving the originals open for the shell prompt. -- -- When copied, these are probably fd 3,4,5, but will record what dup -- returns to be safe. For example, if fd 0 is closed (by dup2) the file -- actually will remain open until fd 3 is also closed. -- -- currentStandardInput/Output/Error represent the file stdin/out/err has -- been redirected to by Set_Input/Output/Error. If none, the value is -- 0,1,2 respectively. -- -- The standard files standard_input, standard_output and standard_error -- represent the original stdin/out/err...ie the copied fd 4,5,6. ------------------------------------------------------------------------------ procedure startParser is begin originalStandardInput := dup( stdin ); -- record stdin originalStandardOutput := dup( stdout ); -- record stdout originalStandardError := dup( stderr ); -- record stderr currentStandardInput := originalStandardInput; -- no redirection, stdin currentStandardOutput := originalStandardOutput; -- no redirection, stdout currentStandardError := originalStandardError; -- no redirection, stderr SetStandardVariables; -- built-in elaboration Ada.Numerics.Float_Random.Reset( random_generator );-- reset RND generator clearCommandHash; -- initialize cmd table end startParser; ------------------------------------------------------------------------------ -- SHUTDOWN PARSER -- -- Shut down this package, performing any cleanup tasks. In this case, none. ------------------------------------------------------------------------------ procedure shutdownParser is begin null; end shutdownParser; end parser;