{ *************************************************************************** } MODULE mod_parse_global ; { Created 18-APR-1989 MICHIGAN STATE UNIVERSITY, TRIGGER CONTROL SOFTWARE } { *************************************************************************** } INCLUDE mod_common_parse, mod_handle_tracing ; { *************************************************************************** } EXPORT proced_parse_string, {PROCEDURE parse ascii string to extract command array } unmatched_string_start, {INTEGER starting character of unmatched string } unmatched_string_length,{INTEGER length of unmatched string } test_parse, {PROCEDURE test interface to parsing routine } true_length ; {FUNCTION calculate the true length of a string } { *************************************************************************** } IMPORT max_command, {from module MOD_COMMON_PARSE } parse_code, Parse_success, Parse_failure, Parse_asserted, Parse_negated, parse_floating_point, parse_illegal_keyword, Parse_par_still_empty, Parse_par_found_empty, Parse_no_par_found, Parse_lower_boundary, Parse_upper_boundary, Parse_found_keyword, {from module MOD_COMMON_PARSE } command_array, {from module MOD_COMMON_PARSE } keywords, {from module MOD_COMMON_PARSE } keywords_length, {from module MOD_COMMON_PARSE } max_keyword_type, {from module MOD_COMMON_PARSE } {trace_info, trace_warn,}trace_error,{from module MOD_HANDLE_TRACING } inline_tracing, {from module MOD_HANDLE_TRACING } {handle_trc_wrn,} {from module MOD_HANDLE_TRACING } handle_trc_err ; {from module MOD_HANDLE_TRACING } { *************************************************************************** } { *************************************************************************** } CONST fourblanks = 32+256*(32+256*(32+256*32)) ; enough_blanks_is_end_of_line = 16 ; TYPE eachbyte = [BYTE] 0..255 ; fourbyte = [LONG] PACKED RECORD byte : PACKED ARRAY [1..4] OF eachbyte ; END ; parsing_array = PACKED ARRAY [1..500] OF fourbyte ; VAR cur_charnum : INTEGER ; cur_char : CHAR ; cur_parse_status : parse_code ; cur_cmd_num : INTEGER ; cur_parsed_num : INTEGER ; cur_digit_num : INTEGER ; cur_parenth_level : INTEGER ; cur_polarity : parse_code ; cur_float_pol : parse_code ; cur_kw_strt : INTEGER ; cur_kw_length : INTEGER ; p_parsed_command :^command_array;{copy of argument for global reference} p_command_string :^STRING(2000) ;{copy of argument for global reference} consecutive_blanks : INTEGER ; unmatched_string_allowed : BOOLEAN ; unmatched_string_start : INTEGER ; unmatched_string_length : INTEGER ; { *************************************************************************** } { *************************************************************************** } PROCEDURE proced_parse_string ( command_string :^STRING() ; parsed_command :^command_array ; VAR command_count : INTEGER ; allow_a_string : BOOLEAN := FALSE ; VAR parse_status :[OPTIONAL] parse_code ) ; VAR i : INTEGER ; BEGIN unmatched_string_allowed := allow_a_string ; p_parsed_command := parsed_command ; p_command_string := command_string ; inline_initialize_parsing ; FOR i := 1 TO string_length DO BEGIN cur_charnum := i ; cur_char := SUBSTR ( command_string^, i, 1 ) ; IF ( ( cur_kw_strt <> 0 ) AND ( cur_char <> ' ' ) AND ( cur_char <> '(' ) AND ( cur_char <> ')' ) AND ( cur_char <> '!' ) ) THEN inline_keyword {skip the case statement during keywords, } {to allow "weird" characters e.g. "["} ELSE CASE cur_char OF '0': inline_digit ( 0 ) ; '1': inline_digit ( 1 ) ; '2': inline_digit ( 2 ) ; '3': inline_digit ( 3 ) ; '4': inline_digit ( 4 ) ; '5': inline_digit ( 5 ) ; '6': inline_digit ( 6 ) ; '7': inline_digit ( 7 ) ; '8': inline_digit ( 8 ) ; '9': inline_digit ( 9 ) ; '.': inline_decimal ; ' ': inline_space ; '(': inline_open_parenthesis ; ')': inline_close_parenthesis ; '-': inline_minus_sign ; ':': inline_colon ; '!': inline_comment ; '_': inline_keyword ; '$': inline_keyword ; OTHERWISE IF ( FIND_MEMBER ( cur_char, ['A'..'Z'] ) > 0 ) THEN inline_keyword ELSE parsed_illegal_format ( cur_charnum, ' illegal character ' + cur_char + ', code ' + CONVERT(STRING,ORD(cur_char)) ); END ; IF ( consecutive_blanks > enough_blanks_is_end_of_line ) THEN GOTO end_of_command_line END ; IF ( consecutive_blanks = 0 ) THEN inline_space ; end_of_command_line: inline_final_check ; command_count := cur_cmd_num ; IF PRESENT(parse_status) THEN parse_status := cur_parse_status ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_initialize_parsing ; BEGIN { p_parsed_command^ := zero ;} cur_parse_status := Parse_success ; cur_cmd_num := 0 ; cur_parsed_num := 0 ; cur_digit_num := 0 ; cur_parenth_level := -1 ; cur_polarity := Parse_asserted ; consecutive_blanks := 0 ; cur_kw_strt := 0 ; cur_kw_length := 0 ; {reset first command record} p_parsed_command^[1].objid := 0 ; p_parsed_command^[1].objcode := parse_success ; p_parsed_command^[1].itemid := 0 ; p_parsed_command^[1].itemcode := parse_success ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_space ; {this routine is called when an actual } {space char is found in the command } {line and also when there could have } {been a space but there wasn't. } {It does most of the code and id } {assignments } BEGIN consecutive_blanks := consecutive_blanks + 1 ; IF ( cur_digit_num <> 0 ) THEN BEGIN IF ( cur_parenth_level <= 0 ) THEN BEGIN inline_increment_command_number ; p_parsed_command^[cur_cmd_num].objcode := cur_polarity ; p_parsed_command^[cur_cmd_num].objid := cur_parsed_num ; p_parsed_command^[cur_cmd_num].itemid := 0 ; p_parsed_command^[cur_cmd_num].itemcode := Parse_no_par_found ; cur_parenth_level := 0 ; END ELSE BEGIN IF ( p_parsed_command^[cur_cmd_num].itemcode <> Parse_par_still_empty ) THEN inline_increment_command_number ; p_parsed_command^[cur_cmd_num].itemcode := cur_polarity ; p_parsed_command^[cur_cmd_num].itemid := cur_parsed_num ; {prepare next item in parenthesis} p_parsed_command^[cur_cmd_num+1].objid := p_parsed_command^[cur_cmd_num].objid ; p_parsed_command^[cur_cmd_num+1].objcode := p_parsed_command^[cur_cmd_num].objcode ; IF ( p_parsed_command^[cur_cmd_num-1].itemcode = Parse_lower_boundary ) THEN BEGIN IF ( p_parsed_command^[cur_cmd_num].itemcode <> Parse_asserted ) THEN parsed_illegal_format ( cur_charnum, ' illegal range boundary ' ) ELSE p_parsed_command^[cur_cmd_num].itemcode := Parse_upper_boundary ; IF ( p_parsed_command^[cur_cmd_num].itemid < p_parsed_command^[cur_cmd_num-1].itemid ) THEN parsed_illegal_format ( cur_charnum, ' boundaries out of order '); END ; END ; cur_parsed_num := 0 ; cur_polarity := Parse_asserted ; cur_digit_num := 0 ; END ; IF ( cur_kw_strt <> 0 ) THEN BEGIN IF ( cur_parenth_level <= 0 ) THEN BEGIN inline_increment_command_number ; p_parsed_command^[cur_cmd_num].objcode := Parse_found_keyword ; inline_match_keyword ( p_parsed_command^[cur_cmd_num].objid ) ; cur_parenth_level := 0 ; END ELSE BEGIN IF ( p_parsed_command^[cur_cmd_num].itemcode <> Parse_par_still_empty ) THEN inline_increment_command_number ; p_parsed_command^[cur_cmd_num].itemcode := Parse_found_keyword ; inline_match_keyword ( p_parsed_command^[cur_cmd_num].itemid ) ; {prepare next item in parenthesis} p_parsed_command^[cur_cmd_num+1].objid := p_parsed_command^[cur_cmd_num].objid ; p_parsed_command^[cur_cmd_num+1].objcode := p_parsed_command^[cur_cmd_num].objcode ; END ; cur_kw_strt := 0 ; cur_kw_length := 0 ; END ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_increment_command_number ; BEGIN cur_cmd_num := cur_cmd_num + 1 ; IF ( cur_cmd_num > max_command ) THEN BEGIN parsed_illegal_format ( cur_charnum, ' more than ' + CONVERT(STRING,max_command) + ' commands on line' ) ; cur_cmd_num := 1 ; END ; {reset next command record} p_parsed_command^[cur_cmd_num+1].objid := 0 ; p_parsed_command^[cur_cmd_num+1].objcode := parse_success ; p_parsed_command^[cur_cmd_num+1].itemid := 0 ; p_parsed_command^[cur_cmd_num+1].itemcode := parse_success ; END ; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_open_parenthesis ; BEGIN IF ( consecutive_blanks = 0 ) THEN inline_space ; consecutive_blanks := 0 ; IF ( cur_parenth_level < 0 ) THEN BEGIN parsed_illegal_format ( cur_charnum, ' no object found before ''('' ' ) ; cur_cmd_num := cur_cmd_num + 1 ; p_parsed_command^[cur_cmd_num].objid := 0 ; p_parsed_command^[cur_cmd_num].objcode := cur_polarity ; p_parsed_command^[cur_cmd_num].itemcode := Parse_par_still_empty ; cur_parenth_level := 1 ; END ELSE IF ( cur_parenth_level = 0 ) THEN BEGIN cur_parenth_level := cur_parenth_level + 1 ; p_parsed_command^[cur_cmd_num].itemcode := Parse_par_still_empty ; END ELSE IF ( cur_parenth_level > 0 ) THEN BEGIN cur_parenth_level := cur_parenth_level + 1 ; parsed_illegal_format ( cur_charnum, ' illegal nesting of parenthesis ''('' ' ) ; END ; IF ( cur_polarity = Parse_negated ) THEN BEGIN parsed_illegal_format ( cur_charnum, ' no number found after ''-'' ' ) ; cur_polarity := Parse_asserted ; END ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_close_parenthesis ; BEGIN IF ( consecutive_blanks = 0 ) THEN inline_space ; consecutive_blanks := 0 ; IF ( p_parsed_command^[cur_cmd_num].itemcode = Parse_par_still_empty ) THEN p_parsed_command^[cur_cmd_num].itemcode := Parse_par_found_empty ; IF ( cur_polarity = Parse_negated ) THEN parsed_illegal_format ( cur_charnum, ' missing number after ''-'' ' ) ; IF ( p_parsed_command^[cur_cmd_num].itemcode = Parse_lower_boundary ) THEN parsed_illegal_format ( cur_charnum, ' missing number after '':'' ' ) ; IF ( cur_parenth_level <= 0 ) THEN parsed_illegal_format ( cur_charnum, ' no ''('' found before '')'' ' ) ELSE IF ( cur_parenth_level = 1 ) THEN cur_parenth_level := -1 ELSE cur_parenth_level := cur_parenth_level - 1 ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_minus_sign ; BEGIN IF ( consecutive_blanks = 0 ) THEN inline_space ; consecutive_blanks := 0 ; IF ( cur_polarity = Parse_negated ) THEN BEGIN parsed_illegal_format ( cur_charnum, ' no number found after ''-'' ' ) ; cur_polarity := Parse_asserted ; END ; cur_polarity := Parse_negated ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_colon ; BEGIN IF ( consecutive_blanks = 0 ) THEN inline_space ; consecutive_blanks := 0 ; IF ( p_parsed_command^[cur_cmd_num].itemcode <> Parse_asserted ) THEN parsed_illegal_format ( cur_charnum, ' illegal range boundary ' ) ELSE p_parsed_command^[cur_cmd_num].itemcode := Parse_lower_boundary ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_comment ; BEGIN {force the end of line parsing} consecutive_blanks := enough_blanks_is_end_of_line ; inline_space ; END; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_keyword ; BEGIN IF ( cur_kw_strt = 0 ) THEN BEGIN IF ( consecutive_blanks = 0 ) THEN inline_space ; consecutive_blanks := 0 ; cur_kw_strt := cur_charnum ; END ; cur_kw_length := cur_kw_length + 1 ; END ; { *************************************************************************** } {[INLINE]} PROCEDURE inline_match_keyword ( VAR keyword_num : INTEGER ) ; VAR i : INTEGER ; BEGIN FOR i := 1 TO max_keyword_type DO IF ( SUBSTR( p_command_string^, cur_kw_strt, cur_kw_length ) = SUBSTR( keywords[i], 1, keywords_length[i]) ) THEN GOTO found_keyword ; found_keyword: IF ( i <= max_keyword_type ) THEN {we matched the keyword} keyword_num := i ELSE BEGIN keyword_num := ORD(Parse_illegal_keyword) ; IF ( unmatched_string_allowed = TRUE ) THEN BEGIN {we were allowed to find a random string, return its position} unmatched_string_start := cur_kw_strt ; unmatched_string_length := cur_kw_length ; END ELSE {keyword could not be matched, and this is an error} parsed_illegal_format ( cur_charnum, ' unrecognized keyword ''' + SUBSTR( p_command_string^, cur_kw_strt, cur_kw_length ) + '''' ) ; END ; END ; { *************************************************************************** } { define a run time library routine to convert from ASCII text } { to floating point value, cf. VMS Doc for RTL general purpose } FUNCTION OTS$CVT_T_F ( input_string : STRING() ; {i.e. by descriptor } VAR output_float : REAL ; {i.e. by reference } digit_in_fraction : INTEGER := 0 ;{i.e. by value, optional } scale_factor : INTEGER := 0 ; flags_value : INTEGER := 0 ; extension_bits : INTEGER := 0 ) : INTEGER ; EXTERNAL ; { *************************************************************************** } {[INLINE]} PROCEDURE inline_digit ( digit : INTEGER ) ; CONST SS$_NORMAL = 1 ; VAR status : INTEGER ; BEGIN inline_inc_dnum ; IF ( cur_polarity <> parse_floating_point ) THEN {parsing a regular integer, or still integer part of floating point} cur_parsed_num := 10 * cur_parsed_num + digit ELSE BEGIN {include contribution of this new digit, by redoing conversion} {translate ASCII to floating point} status := OTS$CVT_T_F ( INPUT_STRING := SUBSTR ( p_command_string^, cur_charnum - cur_digit_num + 1, cur_digit_num ), OUTPUT_FLOAT := cur_parsed_num::REAL ) ; IF ( status <> SS$_NORMAL ) THEN parsed_illegal_format ( cur_charnum, ' Illegal floating point format ' ); { handle_trc_err ( TAG := 'PRS/GLO%', { MESSAGE := ' status = ' { + CONVERT(STRING,status) { + ' string = "' { + SUBSTR ( p_command_string^, { cur_charnum - cur_digit_num + 1, { cur_digit_num ) { + '" value = ' { + CONVERT(STRING,cur_parsed_num::REAL) ) ; } {restore the sign if necessary} IF ( cur_float_pol = parse_negated ) THEN cur_parsed_num::REAL := - cur_parsed_num::REAL ; END ; END; { *************************************************************************** } {[INLINE]} PROCEDURE inline_decimal ; BEGIN {This cannot be a floating point number yet} IF ( cur_polarity = parse_floating_point ) THEN parsed_illegal_format ( cur_charnum, ' Illegal floating point format ' ); {count the decimal point as a digit, to retrieve the full string later} inline_inc_dnum ; {translate the integral part from INTEGER to REAL, } {in case there is no more digits after the decimal point} cur_parsed_num::REAL := CONVERT( REAL, cur_parsed_num ) ; {incorporate the sign} IF ( cur_polarity = parse_negated ) THEN cur_parsed_num::REAL := - cur_parsed_num::REAL ; {remember the sign, for decoding more digits after the decimal point} cur_float_pol := cur_polarity ; {flag the value as a real number, this will be the return code} cur_polarity := parse_floating_point ; END; { *************************************************************************** } {[INLINE]} PROCEDURE inline_inc_dnum ; BEGIN consecutive_blanks := 0 ; cur_digit_num := cur_digit_num + 1 ; {An Integer, or the integer part of a real cannot show too many digits} {More digits may appear in the decimal part of a real number} IF ( ( cur_digit_num > 9 ) AND ( cur_polarity <> parse_floating_point ) ) THEN BEGIN parsed_illegal_format ( cur_charnum, ' number too large ' + CONVERT(STRING,cur_parsed_num) + '...' ) ; cur_digit_num := 1 ; cur_parsed_num := 0 ; END ; END ; { *************************************************************************** } { *************************************************************************** } {[INLINE]} PROCEDURE inline_final_check ; BEGIN IF ( cur_parenth_level > 0 ) THEN parsed_illegal_format ( cur_charnum, CONVERT(STRING(2),cur_parenth_level) + ' ''('' left unclosed ' ) ; { IF ( cur_cmd_num = 0 ) THEN parsed_illegal_format ( cur_charnum, ' no command on line ' ); } END; { *************************************************************************** } { *************************************************************************** } PROCEDURE parsed_illegal_format ( position : INTEGER ; error_message : STRING() ) ; BEGIN IF ( inline_tracing(trace_error) <> 0 ) THEN handle_trc_err ( TAG := 'PRS/GLO%', MESSAGE := error_message + ' (offset ' + CONVERT(STRING(3),position) + ')' ) ; { WRITELN ( error_message + ' (offset ' { + CONVERT(STRING(3),position) + ')' ) ; } cur_parse_status := Parse_failure ; END; { *************************************************************************** } { *************************************************************************** } PROCEDURE test_parse ; VAR input_string : ^STRING(80) ; i : INTEGER ; b : CHAR ; ESC : CHAR := CHR(27) ; CLEOL : STRING(4) ; CLS : STRING(4) ; SI : CHAR := CHR(15) ; draw_bar : STRING(3) ; buffer : STRING(120) ; rim : STRING(84) ; command_count : INTEGER ; parse_status : parse_code ; parsed_command :^command_array ; BEGIN CLEOL := CHR(27) + '[0K' ; CLS := CHR(27) + '[2J' ; draw_bar := CHR(14) + 'x' + CHR(15) ; rim := draw_bar + ESC+'[0K' + ESC+'[79C' + draw_bar ; NEW ( input_string ) ; NEW ( parsed_command ) ; command_count := 0 ; parse_status := Parse_success ; OPEN ( OUTPUT, CARRIAGE_CONTROL := CARRIAGE$NONE ) ; WRITELN ( ESC,'[?7h', ESC,'(B', ESC,')0', ESC,'[4l', SI, CLS ) ; WRITELN ( goln(1), 'enter string :' ) ; inline_draw_line (3) ; WRITELN ( goln(4), 'previous string :' ) ; WRITELN ( goln(6), '123456789 123456789 123456789 123456789 ', '123456789 123456789 123456789 123456789 ' ) ; inline_draw_box (7,19); REPEAT input_string^ := zero ; WRITELN ( goln(2), CLEOL ) ; READLN ( input_string^ ) ; WRITELN ( goln(5), input_string^ ) ; WRITELN ( ESC, '[21;24r', goln(24), CLEOL, goln(23), CLEOL, goln(22), CLEOL, goln(21), CLEOL ) ; proced_parse_string ( input_string, parsed_command, COMMAND_COUNT := command_count, PARSE_STATUS := parse_status ) ; IF ( parse_status = parse_failure ) THEN WRITELN ( CHR(7), CHR(7) ) ; WRITELN ( ESC, '[8;18r', goln(20), 'parse status -->', ESC, '[', ORD(parse_status):1, 'm', CONVERT(STRING,parse_status), ESC, '[0m<-- ', command_count, ' command(s) found ', CLEOL ) ; WRITELN ( goln(8) ) ; FOR i := 1 TO command_count DO BEGIN CASE parsed_command^[i].itemcode OF parse_asserted : b := '1' ; parse_negated : b := '1' ; OTHERWISE b := '0' ; END ; buffer := draw_bar + ' command # ' + CONVERT(STRING(2),i) + ' object ' + ESC+'[1m'+ CONVERT(STRING,parsed_command^[i].objid) +ESC+'[0m ' + CONVERT(STRING,parsed_command^[i].objcode) + ' item ' + ESC+'['+b+'m'+ CONVERT(STRING,parsed_command^[i].itemid)+ESC+'[0m ' + CONVERT(STRING,parsed_command^[i].itemcode) + ESC+'[0K' ; SUBSTR ( buffer, 102, 3) := draw_bar ; WRITELN ( SUBSTR(buffer,1,104) ) ; END ; FOR i := 8+command_count TO 18 DO WRITELN ( SUBSTR ( rim, 1, 15 ) ) ; UNTIL ( command_count = 0 ) ; WRITELN ( goln(1), CLS, ESC,'[1;24r', SI ) ; END; { *************************************************************************** } {[INLINE]} PROCEDURE inline_draw_line ( line_num : INTEGER ) ; BEGIN WRITELN ( goln(line_num), CHR(14), 'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq', 'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq', CHR(15) ) ; END; { *************************************************************************** } {[INLINE]} PROCEDURE inline_draw_box ( line_top, line_bottom : INTEGER ) ; VAR i : INTEGER ; BEGIN WRITELN ( goln(line_top), CHR(14), 'lqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq', 'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqk' ) ; FOR i := line_top+1 TO line_bottom-1 DO WRITELN ( goln(i), 'x ', ' x' ) ; WRITELN ( goln(line_bottom), 'mqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq', 'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqj', CHR(15) ) ; END; { *************************************************************************** } {[INLINE]} FUNCTION goln ( line_num : INTEGER ) : STRING(7) ; BEGIN IF ( line_num < 10 ) THEN goln := CHR(27) + '[0' + CONVERT(STRING,line_num) + ';1H' ELSE goln := CHR(27) + '[' + CONVERT(STRING,line_num) + ';1H' ; END; { *************************************************************************** } { *************************************************************************** } FUNCTION true_length ( message :^STRING() ) : INTEGER ; VAR parser :^parsing_array ; base : INTEGER ; size : INTEGER ; bytenum : INTEGER ; BEGIN parser::BYTE_DATA := message::BYTE_DATA ; base := apparent_length DIV 4 ; FOR bytenum := (apparent_length MOD 4) DOWNTO 1 DO IF ( parser^[base+1].byte[bytenum] <> 32 ) THEN BEGIN base := base + 1 ; GOTO end_found ; END ; REPEAT IF ( parser^[base]::INTEGER <> fourblanks ) THEN GOTO finer_search ; base := base - 1 ; UNTIL ( base = 1 ) ; finer_search: FOR bytenum := 4 DOWNTO 1 DO IF ( parser^[base].byte[bytenum] <> 32 ) THEN GOTO end_found ; end_found: true_length := 4 * (base-1) + bytenum ; END ; { *************************************************************************** } { *************************************************************************** } END . { DEC/CMS REPLACEMENT HISTORY, Element MOD171_PARSE_GLOBAL.PAS} { *1 26-MAR-1990 09:03:03 TRIGGER "original loading of pascal source"} { DEC/CMS REPLACEMENT HISTORY, Element MOD171_PARSE_GLOBAL.PAS}