UNIT parse; {-*-Mode: fundamental-mode} INTERFACE {--------------------------------------------------------------------------------------------------------} uses base, dynamic_set, gpc, dictionary, scanner; type check_type_t = (write_calls, write_keywords, write_actions_s, write_actions_c, write_structure, write_reference_error, write_convergence); parse_handle_t = pointer; check_set_t = set of check_type_t; family_name_t = string (32); procedure read_bnf (var ph : parse_handle_t; {the new generated handle} src_bnf : path_name_t; {Backus Nauer Syntax definitions} check_set : check_set_t; {used for diagnostics diagnostic only} var err : boolean); {somthing was wrong} procedure translate_bnf (ph : parse_handle_t; {handle give from read_bnf} family_name : family_name_t; {family Name} dsn_unit : path_name_t; {name of pascal unit, BNF Interpreter} dsn_main : path_name_t; {name of pascal main program} offs : integer); {} procedure close_parser (ph : parse_handle_t); (* ------- Action Commands ------------------------------------------------------------------------------------- Command Channel Syntax Function Operands Comments -------------------------------------------------------------------------------------------------------------- SELECTING A CHANNEL ------------------------------------------------------------- ^A select channel A typically source and destination operand ^^B select channel B typically source operand ^^^C select channel C typically 3rd operand (condition tests etc.) WRITING TO CHANNEL AND FILE ------------------------------------------------------------- 'text' ^A := ^A + 'text' ^A append text `s` ^A := ^A + symbol ^A append last symbol (app_symbol) `S` ^A := ^A + dic(symbol) ^A append last symbols dictionary number (obj_add_ord) `v` ^A := ^A + value ^A append last value (text, Integer, real) (app_value) `c` ^A := nil ^A clear channel (obj_delete) `n` ^A := ^A + newline ^A append newline (obj_add_chr) `'` ^A := ^A + apostr ^A append apostr (obj_add_chr) `"` ^A := ^A + quote ^A append quote (obj_add_chr) ` ` ^A := ^A + blank ^A append blank (obj_add_chr) `w` file := file + ^A ^A append channel A to file (write ^A to file) (out_channel) `T` file := file + symbol table Writes the symbol table (obj_add_dic) `=` ^A := ^^B ^A ^^B assign copy of channel B to A equ. to `c+` (obj_assign) `+` ^A := ^A + ^^B ^A ^^B append copy of channel B to A (obj_add_obj) `i` ^A := ^A + ptr (^^B) ^A ^^B append reference of channel B to A (obj_add_obj_inc) `m` ^A := ^A + ^^B; ^^B:=nil ^A ^^B append channel B to A by moving (obj_move_obj) `M` ^A := ^A + (^^M, ^^^P) ^A ^^M ^^^P append Macro (obj_add_dic_mac) Name=symbol, P=formal parameter, M=macro LOOP ------------------------------------------------------------- `{..b..}` loop control with break begin looping, break the loop, end the loop (break) DIAGNOSTCS & ERROR ------------------------------------------------------------- `d` write diagnostc write diagnostc line to terminal and continue parsing `q` soft error exit to caller soft input data error, stop parsing and return to calling program `e` abort hard input data error, stop parsing and abort the parser TEST (a and b are any sequences of legal statements) Examples: [sa], [s:b], [sa:b], [sabc:xyz] ------------------------------------------------------------- `[sa:b]` if symbol then a else b ^^^C test if last symbol exists in channel C `[ca:b]` if C=nil then a else b ^^^C test if channel C is empty `[ta:b]` if v=text then a else b test if last value is of type Text `[ia:b]` if v=int then a else b test if last value is of type Integer `[ra:b]` if v=real then a else b test if last value is of type Real CONDITIONAL ACTIONS if successful continue executing a else b ------------------------------------------------------------- `[oa:b]` ^A := ^A + ord (s,P) ^A ^^^P conditional append ord (symbol in C) to A (formal parameter) `[Ma:b]` ^A := ^A + exp (s(M),P) ^A ^^M ^^^P conditional macro expansion P=actual paramlist, M=Macro skeletton -------- Action Commands -------------- END ------------------------------------------------------------------*) {!R! page; exit;} {--------open questions ------------------------------------------------------------------------------------- debug control line, column & file_name info from scanner, introduce appl_end ?? abort controllable: abort with diagnostic or soft return to user program (interactive applications) empty case zB. ( '' | A | B ) ---> otherwise legen //case mit 2 varianten mit if then else ??? ist das gut? scanner should convert various integer formats to standard decimal format, leading zeros suppresed 16xA --> 10 2x10 --> 2 0004 --> 4 000 --> 0 (dynamic syntax for number formats???) case sensitivity in dictionary and scanner to be solved (by switch?) priority of keywords: example next, conditional actions : if symbol exists then else control diagnostics and control compile versions through bnf file ??, error concept to be clarified if the use count of call=0 then prevent declaration of procedure's , also action calls predeclatation = 'string' 122 'abc xyz' 12; hunting a sequence problem For \w: line length control and recursion control; Automatic constans for parameter: call (CH1 'immediate' CH2) New Actions: \= assign ^A:=^^B; \+ add ^A:=^A+^^B; Conditional Actions: \?sabc: xyz if symbol in ^^^CH then to abc check if really used and prevent declaring routines: app_data, out_channel, app_symbol, app_value ^^C `i` not working Channel C=nil rule for giving names must be redesigned (why first entry of bnf must be 'program'?) parse complains about non existing Channel if using [t...] [i...] [r...], no Channel is neede! diagnostic `d` points to the next token (no chance to repair??), but generated code should be reduced if binary mode ---> keine tabelle der key woerter generieren ---------- offene Fragen --END ----------------------------------------------------------------------------} {--------- PARSE INTERFACE END ----------------------------------------------------------------------------} {!R! page; exit;} IMPLEMENTATION {-------------------------------------------------------------------------------------------} const apostr = chr (39); type rec_t = (case_begin, case_split, loop_split, option_split, call, call_entry, appl_symbol, appl_value, appl_keyword, appl_action_s, appl_action_c, appl_chn0, appl_chn1, appl_chn2, appl_channel); rec_str_t = string (20); record_p_t = ^record_t; record_t = record next : record_p_t; {pointer to next object in sequence} gp_index : dic_indx; {general purpose index to dictionary} tag : rec_t; case rec_t of case_begin, case_split, loop_split, option_split, call : (split : record_p_t; {case header, case, loop split: 0..infinite} tok0, tok1: set_handle_t;{variable length set of potential tokens} actual_par: record_p_t; {actual parameteter (valid only for calls)} tf : boolean); {token found (valid only for calls)} call_entry : (entry_p : record_p_t; {named header of callable bnf structure} formal_par, {formal parameter list} local_var : record_p_t; {local variable list (channels)} use_cnt : Integer; {use count of substitution} d_chn0 : dic_indx; {default channel 0} d_chn1 : dic_indx; {default channel 1} d_chn2 : dic_indx); {default channel 2} appl_symbol, {application symbol expected} appl_value, {application value: Integer, Real, Text...} appl_keyword, {application keywords: begin end ; => ...etc} appl_action_s, {chain of data string application actions)} appl_action_c, {chain of commands application actions)} appl_chn0, appl_chn1, appl_chn2, {std, aux, test} appl_channel : (); {application channel list} end; parser_cb_p_t = ^parser_cb_t; parser_cb_t = record scan_handle : scan_handle_t; {link to the scanner} dic_handle_calls : dic_handle_t; {symbols for syntax substitutions within bnf} dic_handle_keywords : dic_handle_t; {application keywords: <;> } dic_handle_strings : dic_handle_t; {application actions, strings} dic_handle_actions : dic_handle_t; {application actions, commands} root_entry : record_p_t; {root pointer to chain of callable bnf structures} first_entry : record_p_t; {first entry to bnf structure} global_channels : record_p_t; {list of global channels (CH1, CH2, ...} gd_chn0, gd_chn1, gd_chn2: dic_indx; {global default channels (^CH0 ^^CH1 ^^^CH2)} token_min, token_empty, token_max_keyword, token_finish, token_symbol, token_value, token_max : dic_indx; structure_blanks : Integer; {formatting the output} write_line_numbers : boolean; {formatting the output} output_binary : boolean; {select binary output, default is ASCII} used_app_data, used_out_channel, used_app_symbol, used_app_value : boolean; pgm_name, {'pascal_parser'} pgm_version, {'0.0'} pgm_del_beg, {' ' and tab etc} pgm_sym_beg, {'A..Za..z'} pgm_sym_cont, {'A..Za..z_0..9'} pgm_num_beg, {'0123456789'} pgm_equ_char, {'AaBb....'} pgm_comments, {'{ . (* #'} pgm_include, {'%include ;'} pgm_txt_del, {'" "'} pgm_options {'v123L'} : dic_sym; error_count : integer; {indicates any error in bnf structure} end; var dummy : boolean; {discard useless boolean function return values} dummy_ch : char; {discard useless character function return values} procedure wr_dic (dh: dic_handle_t); var index: dic_indx; begin for index:= 1 to dic_last_indx (dh) do writeln (index:4, ' ', dic_symbol (dh, index)) end; function non_zero_ch (local, global: dic_indx): dic_indx; begin if local<>0 then non_zero_ch:= local else non_zero_ch:= global end; function str_tag (t: rec_t): rec_str_t; begin case t of case_begin :str_tag:='case_begin'; case_split :str_tag:='case_split'; loop_split :str_tag:='loop_split'; option_split :str_tag:='option_split'; call :str_tag:='call'; call_entry :str_tag:='call_entry'; appl_symbol :str_tag:='appl_symbol'; appl_value :str_tag:='appl_value'; appl_keyword:str_tag:='appl_keyword'; appl_action_s:str_tag:='appl_action_s';appl_action_c:str_tag:='appl_action_c';appl_chn0 :str_tag:='appl_chn0'; appl_chn1 :str_tag:='appl_chn1'; appl_chn2 :str_tag:='appl_chn2'; appl_channel:str_tag:='appl_channel'; otherwise str_tag:='?' end end; {!R! page; exit;} procedure read_bnf (var ph: parse_handle_t; src_bnf: path_name_t; check_set: check_set_t; var err: boolean); const sym_begin = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; symbol_cont = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789'; max_iterations = 30; type (* symbol value = [ ] { } (( )) | . ; ( ) *) parser_keywords_t = (illegal, bnf_symbol, bnf_value, eq, eka, ekz, gka, gkz, ka, kz, bar, pnt, semik, par0, par1, (* ^ ^^ ^^^ *) chn0, chn1, chn2); var parser_cb_p : parser_cb_p_t; token : token_t; {last returned token from scanner} result : dic_indx; {last returned result from scanner} call_entry_p : record_p_t; {pointer to call, first used for building then for checking bnf structure} init_token_cnt, change_cnt, {change count, token prediction for substitutions} empty_lo_cnt, {empty loop and option token prediction} empty_case_cnt, {multiple empty token in case list, one empty case allowd} dupl_case_cnt : integer; {duplicate token in case list} i : Integer; {general purpose index} verbose : boolean; {if true talk about any error} error_flag : boolean; {Error flag is redundant, it is true if error_count is <>0} procedure diagnostic (err: err_str_t); begin write (StdErr, 'Error: ', err, chr(7)); write_diagn (parser_cb_p^.scan_handle); abort ('') end; procedure inc_error; begin error_flag:= true; with parser_cb_p^ do error_count:= error_count + 1 end; procedure finish_unexpected (result: Integer); {never returning routine} begin {finish_unexpected} case result of ord (end_of_input) : diagnostic ('EOF not expected'); ord (illegal_char) : diagnostic ('Illegal Character'); ord (not_terminated) : diagnostic ('Oject not terminated'); {String or comment line not terminated} otherwise diagnostic ('Fatal result') {test remove this line if the program is stable} end; end; {finish_unexpected} function new_obj (object_type: rec_t): record_p_t; var p: record_p_t; begin {new_obj} case object_type of case_begin, case_split, loop_split, option_split, call : begin new (p, case_begin); with p^ do begin split := nil; tok0:= nil; tok1:= nil; actual_par:= nil; tf:= true end end; call_entry : begin new (p, call_entry); with p^ do begin entry_p := nil; formal_par:= nil; local_var:= nil; use_cnt :=0; d_chn0:=0; d_chn1:=0; d_chn2:=0 end end; appl_symbol : new (p, appl_symbol); appl_value : new (p, appl_value); appl_keyword : new (p, appl_keyword); appl_action_s: new (p, appl_action_s); appl_action_c: new (p, appl_action_c); appl_chn0 : new (p, appl_chn0); appl_chn1 : new (p, appl_chn1); appl_chn2 : new (p, appl_chn2); appl_channel : new (p, appl_channel) otherwise abort ('Fatal program error in new_object') {test remove this line after module works stable} end; with p^ do begin next:= nil; gp_index:= 0; tag:= object_type end; new_obj := p end; {new_obj} function find_call_entry_p (index: dic_indx; must_be_new: boolean): record_p_t; var p: record_p_t; begin {find_call_entry_p} {returns nil if not found and auto_generate=false} with parser_cb_p^ do begin p := root_entry; while (p<>nil) and then (p^.gp_index<>index) do p:= p^.next; if p=nil then begin p:= new_obj (call_entry); with p^ do begin tag:= call_entry; gp_index:= index; next:= root_entry end; if root_entry=nil then first_entry:= p; {remember first's line subtitution} root_entry:= p end else if must_be_new and (p^.entry_p<>nil) then diagnostic ('Duplicate substitution name'); find_call_entry_p:= p end end; {find_call_entry_p} {!R! page; exit;} function parameter_exists (parameter_list: record_p_t): boolean; var p: record_p_t; begin p:= parameter_list; while p<>nil do with p^ do begin if result=gp_index then break; p:= next end; parameter_exists:= p<>nil end; function parameter_undeclared (c1, c2, c3: record_p_t): boolean; begin parameter_undeclared:= not (parameter_exists (c1) or parameter_exists (c2) or parameter_exists (c3)) end; procedure get_default_channels (var c0, c1, c2: dic_indx; list0, list1: record_p_t); procedure get_d_chn (var d_chn: dic_indx); begin with parser_cb_p^ do begin if next_token (scan_handle, result) = symbol then begin if d_chn<>0 then diagnostic ('Default channel redefined'); d_chn:= result end else diagnostic ('Channel expected after ^ or ^^'); if parameter_undeclared (list0, list1, global_channels) then diagnostic ('Channel not declared') end end; begin {get_default_channels} while (token=keyword) and ((result=ord (chn0)) or (result= ord (chn1)) or (result= ord (chn2))) do begin case result of ord (chn0) : get_d_chn (c0); ord (chn1) : get_d_chn (c1); ord (chn2) : get_d_chn (c2); otherwise end; token:= next_token (parser_cb_p^.scan_handle, result); end end; {get_default_channels} procedure get_parameter_list (var parameter_list : record_p_t; {new list of channels read from input} parameter_list_1 : record_p_t; {existing list to be checked, if must_be_unique is true} must_be_unique : boolean); var p, p1: record_p_t; {first par or delimiter already in token & result} begin p:= nil; while token=symbol do begin if must_be_unique then if parameter_exists (p) or parameter_exists (parameter_list_1) then diagnostic ('duplicate channel') else else with call_entry_p^, parser_cb_p^ do if parameter_undeclared (formal_par, local_var, global_channels) then diagnostic ('Channel not declared') else begin end; new (p1, appl_channel); with p1^ do begin next:= p; gp_index:= result; tag:= appl_channel end; p:= p1; token:= next_token (parser_cb_p^.scan_handle, result); end; if token<>keyword then diagnostic ('parameter list error'); {list always ends with: ) or =} {reverse the order of parameters here, if necessary} parameter_list:= p end; function set_definition (s: dic_sym; var v: dic_sym): boolean; begin with parser_cb_p^ do if dic_symbol (dic_handle_calls, result) <> s then set_definition:= false else begin token:= next_token (scan_handle, result); if (token <> value) (* or (value_type (dic_handle_strings) <> text2_const) *) then diagnostic ('String expected'); if v<>'' then diagnostic ('duplicate definition'); v:= dic_symbol (dic_handle_strings, result); token:= next_token (scan_handle, result); if (token <> keyword) or (result <> ord (semik)) then diagnostic ('; expected'); set_definition:= true end end; {!R! page; exit;} function expression (var pfirst: record_p_t): parser_keywords_t; var p0, p1, {currently build expression} case_list, {used if case expression (|) is detected} append0 : record_p_t; {object chain to be appended by append_object} stop_repeat : boolean; {switch to stop the repeat loop} procedure append_object; begin if append0=nil then diagnostic ('cant append nil obj') else if p0=nil then p0:=append0 else p1^.next:=append0; p1:= append0 end; procedure append_new_obj (object_type: rec_t); begin append0:= new_obj (object_type); append_object end; procedure append_case; var tmp: record_p_t; begin if p0=nil then diagnostic ('empty case expr'); tmp:= new_obj (case_split); with tmp^ do begin next:= case_list; split:= p0 end; case_list:= tmp end; procedure append_chn (chn: rec_t); begin with call_entry_p^, parser_cb_p^ do begin append_new_obj (chn); if next_token (scan_handle, result) <> symbol then diagnostic ('Channel expected'); if parameter_undeclared (formal_par, local_var, global_channels) then diagnostic ('Channel not declared'); append0^.gp_index:= result end end; {!R! page; exit;} begin {expression} p0 := nil; p1 := nil; {test may be redundant} case_list := nil; {if <> nil case expression is active} stop_repeat := false; with parser_cb_p^ do repeat token := next_token (scan_handle, result); case token of finish : begin expression:= illegal; stop_repeat:= true; finish_unexpected (result) end; symbol : begin {result = ord number of symbol string: 1..2**16-1 (in dictionary)} append_new_obj (call); with append0^ do begin split:= find_call_entry_p (result, false); with split^ do begin use_cnt:= use_cnt+1 end end; end; value : begin case value_type (scan_handle) of text1_const : append_new_obj (appl_keyword); text2_const : append_new_obj (appl_action_s); text3_const : append_new_obj (appl_action_c); otherwise diagnostic ('Fatal value_type') end; append0^.gp_index := result; end; keyword: case result of {result = ord number of keyword string 1..2**16-1 (built in dic)} ord (illegal) : diagnostic ('Fatal illegal keyword'); ord (bnf_symbol): append_new_obj (appl_symbol); ord (bnf_value) : append_new_obj (appl_value); ord (ka) : begin if expression (append0) <> kz then diagnostic (') expected'); append_object; {p1 points to last object} while append0<>nil do begin p1:= append0; append0:= append0^.next end end; ord (eka) : begin append0:= new_obj (option_split); append_object; if expression (append0^.split) <> ekz then diagnostic ('] expected'); end; ord (gka) : begin append0:= new_obj (loop_split); append_object; if expression (append0^.split) <> gkz then diagnostic ('} expected'); end; ord (bar) : begin append_case; p0:= nil; p1:= nil end; ord (kz) : begin stop_repeat:= true; expression:= kz end; ord (ekz) : begin stop_repeat:= true; expression:= ekz end; ord (gkz) : begin stop_repeat:= true; expression:= gkz end; ord (pnt) : begin stop_repeat:= true; expression:= pnt end; ord (semik) : begin stop_repeat:= true; expression:= semik end; ord (eq) : begin stop_repeat:= true; expression:= eq end; ord (par0) : if append0=nil then diagnostic ('parameter not valid here') else with append0^ do if tag<>call then diagnostic ('parameter valid only after substitution name') else begin token:= next_token (scan_handle, result); get_parameter_list (actual_par, nil, false); if result <> ord (par1) then diagnostic (') expected') end; ord (par1) : diagnostic (') valid only after parameter list'); ord (chn0) : append_chn (appl_chn0); ord (chn1) : append_chn (appl_chn1); ord (chn2) : append_chn (appl_chn2); otherwise abort ('Fatal result in expression') {test remove this line if program is stable} end; otherwise abort ('Fatal token in expression') {test remove this line if program is stable} end until stop_repeat; if case_list<>nil then begin append_case; p0:= new_obj (case_begin); p0^.split:= case_list end; if p0=nil then diagnostic ('empty expression'); pfirst:= p0 end; {expression} {!R! page; exit;} (*-----------------------------------------------------------------------------------------------*) procedure find_token_all (bnf_list: record_p_t; var sot: set_handle_t; var token_found: boolean); var p: record_p_t; token: set_handle_t; begin {find_token_all} p:= bnf_list; token:=nil; while p<>nil do with p^ do begin token_found:= false; case tag of case_begin, case_split, loop_split, option_split : begin find_token_all (split, token, dummy); set_union (sot, token, sot); if tag=case_begin then begin token_found:= true; break end end; call : begin set_union (sot, tok0, sot); token_found:= tf; if tf then break end; call_entry : abort ('call_entry found in find_token'); appl_symbol : begin set_add_element (sot, parser_cb_p^.token_symbol); token_found:= true; break end; appl_value : begin set_add_element (sot, parser_cb_p^.token_value); token_found:= true; break end; appl_keyword : begin set_add_element (sot, gp_index); token_found:= true; break end; appl_action_s, appl_action_c, appl_chn0, appl_chn1, appl_chn2, appl_channel : ; otherwise abort ('Fatal tag ' + str_tag (tag) + ' in find_token_all') {test remove if program ok} end; p:= next end end; {find_token_all} procedure init_token (ptr_to_obj: record_p_t); var p, p1: record_p_t; token0, token1, acc, t: set_handle_t; ec: Integer; begin {init_token} p:= ptr_to_obj; token0:=nil; token1:=nil; acc:= nil; t:= nil; while p<>nil do with p^ do begin set_make_empty (token0); set_make_empty (token1); case tag of case_begin : begin init_token (split); p1:= split; set_make_empty (acc); ec:= 0; while p1<>nil do with p1^ do begin if set_empty (tok1) then begin ec:= ec+1; if ec>1 then empty_case_cnt:=empty_case_cnt +1 end; set_intersection (tok1, acc, t); if not set_empty (t) then begin dupl_case_cnt:= dupl_case_cnt +1; if verbose then begin set_write (t, parser_cb_p^.dic_handle_keywords); writeln end end; set_union (acc, tok1, acc); p1:= next end end; case_split : begin find_token_all (split, token1, tf); {look only for contents of individual case} if not set_equal (token1, tok1) then change_cnt:= change_cnt + 1; set_assign (token1, tok1); init_token (split); end; loop_split, option_split: begin find_token_all (split, token1, tf); {look for bnf elements in loops and options} if not set_equal (token1, tok1) then change_cnt:= change_cnt + 1; set_assign (token1, tok1); if set_empty (tok1) then empty_lo_cnt := empty_lo_cnt + 1; find_token_all (next, token0, tf); {look for linear following bnf elements} set_exclusion (token0, token1, token0); {exclude elements from linear sequence} if not set_equal (token0, tok0) then change_cnt:= change_cnt + 1; set_assign (token0, tok0); init_token (split); end; call : begin find_token_all (split^.entry_p, token0, tf); if not set_equal (token0, tok0) then change_cnt:= change_cnt + 1; set_assign (token0, tok0); end; call_entry : abort ('call_entry found in init_token'); appl_symbol, appl_value, appl_keyword, appl_action_s, appl_action_c, appl_chn0, appl_chn1, appl_chn2, appl_channel : ; otherwise abort ('Fatal tag ' + str_tag (tag) + ' in init_token') {test rm this line if pgm ok} end; p:= next end end; {init_token} {!R! page; exit;} procedure init_token_global; var p: record_p_t; begin {init_token_global} with parser_cb_p^ do begin change_cnt:=0; empty_lo_cnt:=0; empty_case_cnt:= 0; dupl_case_cnt:= 0; p:= root_entry; while p<>nil do with p^ do begin if verbose then begin write ('Name: '); write (dic_symbol (dic_handle_calls, gp_index)); writeln end; init_token (entry_p); p:= next end; end end; {init_token_global} procedure wr_set_of_token (sh: set_handle_t; dh: dic_handle_t); begin with parser_cb_p^ do begin if set_element_of (sh, token_value) then write (' value'); if set_element_of (sh, token_symbol) then write (' symbol') end; set_write (sh, dh) end; procedure write_ccb (ccb: record_p_t; any_case: boolean); begin with ccb^ do begin if any_case or ((entry_p=nil) or ((use_cnt=0) and (next<>nil))) then begin write ('Substitution: ', gp_index:2, ', use_cnt: ', use_cnt:2, ', Name: ', dic_symbol (parser_cb_p^.dic_handle_calls, gp_index)); if entry_p=nil then begin write (' never declared'); err:= true end; if (use_cnt=0) and (next<>nil) then begin write (' declared but never refereced'); err:= true end; writeln end end end; procedure write_expr (expr_p: record_p_t; blanks: Integer); const offs=2; var p: record_p_t; begin p:= expr_p; while p<>nil do with parser_cb_p^, p^ do begin write (' ':blanks, str_tag (tag):16, ' '); case tag of case_begin : begin writeln; write_expr (split, blanks+2) end; case_split, loop_split, option_split : begin if tag<>case_split then write (' TOK0-> '); wr_set_of_token (tok0, dic_handle_keywords); write (' TOK1-v '); wr_set_of_token (tok1, dic_handle_keywords); if set_empty (tok1) then write ('ERROR: not any token exists'); writeln; write_expr (split, blanks+offs) end; call_entry : begin writeln; abort ('Fatal error: call_entry found in expression') end; call : if split<>nil then begin write (dic_symbol (dic_handle_calls, split^.gp_index)); write (' TOK0-> '); wr_set_of_token (tok0, dic_handle_keywords); writeln end else writeln (' ERROR: unknown substitution'); appl_symbol, appl_value : writeln; appl_keyword : writeln (dic_symbol (dic_handle_keywords, gp_index)); appl_action_s :{writeln (dic_symbol (dic_handle_strings, gp_index)) }; {test} appl_action_c :{writeln (dic_symbol (dic_handle_actions, gp_index)) }; {test} appl_chn0, appl_chn1, appl_chn2, appl_channel : ; otherwise writeln; abort ('Fatal tag in ' + str_tag (tag) + ' write_expr') end; p:= next end end; function bnf_name: dic_sym; begin bnf_name:= dic_symbol (parser_cb_p^.dic_handle_calls, call_entry_p^.gp_index) end; {!R! page; exit;} procedure check_parameter_count (bnf_list: record_p_t; chn0, chn1, chn2: dic_indx); var p, p1: record_p_t; c0, c1, c2: dic_indx; procedure test_action_c; var i: Integer; s: dic_sym; procedure wr_error (txt: family_name_t); begin inc_error; writeln ('Error: ', txt, ', in Substitution: ', bnf_name); writeln ('`', s, '`'); writeln (' ':i, '^'); abort ('First action check failed') end; procedure chk_chn (index: dic_indx); begin if index=0 then wr_error ('Channel undefined') end; function cond_cmnd: boolean; begin cond_cmnd:= true; case s [i] of 's', 'c' : chk_chn (c2); {check existance of ^^^C} 't', 'i', 'r' : ; {no checks needed } 'o' : begin chk_chn (c0); chk_chn (c2) end; {check ^A and ^^B} 'M' : begin chk_chn (c0); chk_chn (c1); chk_chn (c2) end; {check ^A, ^^B and ^^^C} otherwise cond_cmnd:= false end; end; function wr_stmt: char; var cont_loop: boolean; begin wr_stmt:= chr (1); {illegal return code} cont_loop:= true; while cont_loop and (i<=length (s)) do begin case s [i] of 's' : begin chk_chn (c0); parser_cb_p^.used_app_symbol := true end; {check dst} 'v' : begin chk_chn (c0); parser_cb_p^.used_app_value := true end; {check dst} 'w' : begin chk_chn (c0); parser_cb_p^.used_out_channel:= true end; {check dst} 'S', 'c', 'n', apostr, '"', ' ', 'T' : chk_chn (c0); {check dst} 'i', '=', '+', 'm' : begin chk_chn (c0); chk_chn (c1) end; {check dst and src} 'M' : begin chk_chn (c0); chk_chn (c1); chk_chn (c1) end; {check all 3 channels} 'b', 'd', 'e', 'q' : ; {no channels needed} '[' : begin i:= i+1; if (i+3) > length (s) then wr_error ('illegal [..]'); if not cond_cmnd then wr_error ('Condition expected after ['); i:= i+1; if s [i] = ':' then begin i:= i+1; if wr_stmt <> ']' then wr_error ('] expected') end else case wr_stmt of ':' : if wr_stmt <> ']' then wr_error ('] expected'); ']' : ; otherwise wr_error (': or ] expexted') end; i:=i-1 end; ':' : begin cont_loop:= false; wr_stmt:= ':' end; ']' : begin cont_loop:= false; wr_stmt:= ']' end; '{' : begin i:= i+1; if cond_cmnd then i:= i+1; if wr_stmt <> '}' then wr_error ('} expected'); i:= i-1 end; '}' : begin cont_loop:= false; wr_stmt:= '}' end; otherwise wr_error ('Illegal action command') end; i:= i+1 end end; begin {test_action_c} if dic_indx2sym (parser_cb_p^.dic_handle_actions, p^.gp_index, s) then begin i:= 1; dummy_ch:= wr_stmt; if (i-1) <> length (s) then wr_error ('Nesting error 0') end else abort ('Fatal index in test_action_c') end; {test_action_c} function members (sh: set_handle_t): dic_indx; {gives the number of active members in the set} var i, n: dic_indx; begin n:=0; with parser_cb_p^ do for i:= token_min to token_max do if set_element_of (sh, i) then n:= n+1; members:= n end; function channels (chn_list: record_p_t): Integer; {gives the number of channel in parameter list} var p: record_p_t; i: Integer; begin i:= 0; p:= chn_list; while p<>nil do with p^ do begin i:= i+1; p:= next end; channels:= i end; {!R! page; exit;} begin {check_parameter_count} p:= bnf_list; c0:= chn0; c1:= chn1; c2:= chn2; while p<>nil do with parser_cb_p^, p^ do begin case tag of case_begin : check_parameter_count (split, c0, c1, c2); case_split : check_parameter_count (split, c0, c1, c2); loop_split : begin if members (tok1) = 0 then abort ('loop_split: empty'); check_parameter_count (split, c0, c1, c2) end; option_split : begin if members (tok1) = 0 then abort ('option_split: empty'); check_parameter_count (split, c0, c1, c2) end; call : begin if split=nil then abort ('Procedure undeclared'); if channels (actual_par) <> channels (split^.formal_par) then begin writeln ('Wrong Parameter count when referencing ', dic_symbol (dic_handle_calls, split^.gp_index), ' from ', bnf_name); inc_error end end; call_entry : abort ('call_entry found in check_parameter_count'); appl_symbol : ; appl_value : ; appl_keyword : ; appl_action_s : if c0=0 then abort ('Missing Channel (^C)') else used_app_data:= true; appl_action_c : test_action_c; appl_chn0 : c0:= gp_index; appl_chn1 : c1:= gp_index; appl_chn2 : c2:= gp_index; appl_channel : ; otherwise abort ('Fatal tag ' + str_tag (tag) + ' in check_parameter_count') {test, rm if pgm ok} end; p:= next end end; {check_parameter_count} {!R! page; exit;} (*---- read_bnf -------------------------------------------------------------------------------------------*) begin {read_bnf} err:= false; new (parser_cb_p); ph:= parser_cb_p; with parser_cb_p^ do begin error_count:= 0; error_flag:= false; structure_blanks:=1; write_line_numbers:= false; verbose:= false; output_binary:= false; {select the default ASCII output} used_app_data := false; used_out_channel:= false; used_app_symbol := false; used_app_value := false; open_scan_new(scan_handle); dic_new (dic_handle_calls, true); def_scan_dic (scan_handle, dic_handle_calls, [symbol_const]); dic_new (dic_handle_keywords, true);def_scan_dic (scan_handle, dic_handle_keywords, [text1_const]); dic_new (dic_handle_strings, true); def_scan_dic (scan_handle, dic_handle_strings, [text2_const]); {strings} dic_new (dic_handle_actions, true); def_scan_dic (scan_handle, dic_handle_actions, [text3_const]); {cmnds} { delimiter_begin sym_begin symbol_cont num_beg equ_char} def_alphabet (scan_handle, ' ', sym_begin, symbol_cont, '', ''); def_quoting (scan_handle, '/*', '*/', comment_const); {parser comment} def_quoting (scan_handle, '(*', '*)', comment_const); {parser comment} def_quoting (scan_handle, '#', '', comment_const); {parser comment} def_quoting (scan_handle, '%include', ';', include_const); {parser includes a file} def_quoting (scan_handle, '<', '>', text1_const); {extract application keywords} def_quoting (scan_handle, '<.', '.>', text1_const); {extract application keywords, alternative} def_quoting (scan_handle, apostr, apostr, text2_const); {extract application actions strings} def_quoting (scan_handle, '"', '"', text2_const); {extract application actions, alternative} def_quoting (scan_handle, '`', '`', text3_const); {extract application actions commands} def_keyword (scan_handle, 'symbol value = [ ] { } (( )) | . ; ( ) ^ ^^ ^^^'); {parser keywords} def_file (scan_handle, src_bnf); {end of opening scanner and parser} root_entry:= nil; first_entry := nil; pgm_name := ''; pgm_version := ''; pgm_del_beg := ''; pgm_sym_beg := ''; pgm_sym_cont := ''; pgm_num_beg := ''; pgm_equ_char := ''; pgm_comments := ''; pgm_include := ''; pgm_txt_del := ''; pgm_options := ''; {------------------- get definitions from the bnf file --------------------------------------------} repeat token:= next_token (scan_handle, result); if token<>symbol then diagnostic ('Symbol expected'); if dic_symbol (dic_handle_calls, result) = 'bnf_syntax' then break; {and read now the syntax} if set_definition ('name', pgm_name ) then continue; if set_definition ('version', pgm_version ) then continue; if set_definition ('delimiter', pgm_del_beg ) then continue; if set_definition ('symbol_begin', pgm_sym_beg ) then continue; if set_definition ('symbol_continue', pgm_sym_cont) then continue; if set_definition ('number_begin', pgm_num_beg ) then continue; if set_definition ('translate', pgm_equ_char) then continue; if set_definition ('comment', pgm_comments) then continue; if set_definition ('include', pgm_include ) then continue; if set_definition ('text', pgm_txt_del ) then continue; if set_definition ('options', pgm_options ) then continue; inc_error; diagnostic ('Predefinition or bnf_syntax expected'); until false; {------------------- set default values if not delivered by the bnf file itself -------------------} if pgm_name = '' then pgm_name := 'unknown'; if pgm_version = '' then pgm_version := '0.0'; if pgm_del_beg = '' then pgm_del_beg := ' '; if pgm_sym_beg = '' then pgm_sym_beg := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; if pgm_sym_cont = '' then pgm_sym_cont := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789'; if pgm_num_beg = '' then pgm_num_beg := '0123456789'; (* if pgm_equ_char = '' then pgm_equ_char := 'aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ'; *) if pgm_comments = '' then pgm_comments := '{ } (* *)'; (* if pgm_include = '' then pgm_include := '%include ;'; {bnf file MUST decide this: include OR translate} *) if pgm_txt_del = '' then pgm_txt_del := ' " " ' + apostr + ' ' + apostr; {APOLLO append removed} for i:=1 to length (pgm_options) do case pgm_options [i] of '0'..'4' : structure_blanks := ord (pgm_options [i]) - ord ('0'); 'L' : write_line_numbers := true; 'v' : verbose := true; 'b' : output_binary := true; otherwise abort ('Illegal Option ' + pgm_options [i]) end; dic_reset (dic_handle_calls); dic_reset (dic_handle_strings); {!R! page; exit;} {------------------- get global and actual default channels, if any -------------------------------} token:= next_token (scan_handle, result); get_parameter_list (global_channels, nil, true); get_default_channels (gd_chn0, gd_chn1, gd_chn2, nil, nil); if result <> ord (semik) then diagnostic ('^, ^^ or ; expected'); {----------------- get now the bnf expressions ----------------------------------------------------} repeat token:= next_token (scan_handle, result); if token = finish then if result=ord (end_of_input) then break else finish_unexpected (result); if token <> symbol then diagnostic ('Name or EOF expected'); call_entry_p := find_call_entry_p (result, true); {must be a new one} {----------------- get parameter channels,if any ------------------------------------------------} token:= next_token (scan_handle, result); if (token=keyword) and (result = ord (par0)) then begin {list starts with ( } token:= next_token (scan_handle, result); get_parameter_list (call_entry_p^.formal_par, nil, true); if result <> ord (par1) then diagnostic (') expected'); token:= next_token (scan_handle, result); end; {----------------- get local channels, if any ---------------------------------------------------} with call_entry_p^ do begin get_parameter_list (local_var, formal_par, true); get_default_channels (d_chn0, d_chn1, d_chn2, local_var, formal_par); end; {----------------- get bnf expression -----------------------------------------------------------} if (token<>keyword) or (result <> ord (eq)) then diagnostic ('^, ^^ or = expected'); if expression (call_entry_p^.entry_p) <> semik then diagnostic ('; expected'); until false; token_min := 0; token_empty := 0; token_max_keyword := dic_last_indx (dic_handle_keywords); token_finish := 1 + token_max_keyword + ord (finish); token_symbol := 1 + token_max_keyword + ord (symbol); token_value := 1 + token_max_keyword + ord (value); token_max := 1 + token_max_keyword + ord (keyword); {------------------------- initialize tokens -------------------------------------------------------------} init_token_cnt:= 0; repeat init_token_global; if write_convergence in check_set then writeln ('Change=', change_cnt:3, ' empty_lo=', empty_lo_cnt:2, ' empty_case=', empty_case_cnt:2, ' dupl_case=', dupl_case_cnt:2); {test} init_token_cnt:= init_token_cnt+1; until ((change_cnt=0) and (empty_lo_cnt=0) and (empty_case_cnt=0)) or (init_token_cnt >= max_iterations); scan_close (scan_handle); if init_token_cnt >= max_iterations then begin inc_error; writeln ('BNF is faulty, Iteration Count: ', init_token_cnt:1) end; {------------------------- Last consistency checks: Channels, unreachable options, loops etc -------------} call_entry_p:= root_entry; while call_entry_p<>nil do with call_entry_p^ do begin if tag<>call_entry then abort ('Fatal: call_entry expected'); {test ??? } check_parameter_count (entry_p, non_zero_ch (d_chn0, gd_chn0), non_zero_ch (d_chn1, gd_chn1), non_zero_ch (d_chn2, gd_chn2)); call_entry_p:= next end; {------------------------- Write diagnostic info depending on switches set in check_set ------------------} if write_calls in check_set then begin writeln ('dic_handle_calls'); wr_dic (dic_handle_calls) end; if write_keywords in check_set then begin writeln ('dic_handle_keywords');wr_dic (dic_handle_keywords)end; if write_actions_s in check_set then begin writeln ('dic_handle_strings'); wr_dic (dic_handle_strings) end; if write_actions_c in check_set then begin writeln ('dic_handle_actions'); wr_dic (dic_handle_actions) end; if write_structure in check_set then begin call_entry_p:= root_entry; while call_entry_p<>nil do with call_entry_p^ do begin write_ccb (call_entry_p, true); write_expr (entry_p, 1); call_entry_p:= next end end; if write_reference_error in check_set then begin call_entry_p:= root_entry; while call_entry_p<>nil do with call_entry_p^ do begin write_ccb (call_entry_p, false); call_entry_p:= next end end; if error_flag then begin writeln ('Error Count: ', error_count:1); abort ('BNF file not successfully parsed') end; end end; {read_bnf} {!R! page; exit;} {-----------------------TRANSLATE ---------------------------------------------------------------------------} procedure translate_bnf (ph : parse_handle_t; family_name : family_name_t; dsn_unit : path_name_t; dsn_main : path_name_t; offs : integer); const {solving potential name conflicts between predfined names and BNF names} bnf_leader = 'bnf_'; {begin all BNF-defined proc names, never to be used by any pre-defined names} chn_leader = 'chn_'; {begin all BNF-defined channel names, never to be used by any pre-defined names} type base_name_t = string (20); var parser_cb_p : parser_cb_p_t; {handle for pnf structure} line : Integer; {out commented header for sorting the output lines} blanks : Integer; {formatting blanks for readability of output code, pascal style} f : text; {unit/module file variable} { bnf_name : base_name_t; } {main entry substitution name of bnf} {test} base_name : base_name_t; {base name: family_name + '_' + bnf_name} procedure wh; begin if parser_cb_p^.write_line_numbers then write (f, '{', line:6, '} '); if blanks > 0 then write (f, ' ':blanks); line:=line+1 end; procedure r; begin blanks:= blanks + parser_cb_p^.structure_blanks end; procedure l; begin blanks:= blanks - parser_cb_p^.structure_blanks end; procedure wh_ln; begin wh; writeln (f) end; procedure wh_begin_ln; begin r; wh; writeln (f, 'begin'); r end; procedure wh_end_ln; begin l; wh; writeln (f, 'end'); l end; procedure wh_ends_ln; begin l; wh; writeln (f, 'end;'); l end; procedure write_set_numbers (sh: set_handle_t); {writes active members: 1,9,20... } var i: dic_indx; empty: boolean; begin empty:= true; with parser_cb_p^ do for i:= token_min to token_max do if set_element_of (sh, i) then begin if empty then write (f, i:1) else write (f, ',', i:1); empty:= false end; if empty then write (f, '0') end; function members (sh: set_handle_t): dic_indx; {gives the number of active members in the set} var i, n: dic_indx; begin n:=0; with parser_cb_p^ do for i:= token_min to token_max do if set_element_of (sh, i) then n:= n+1; members:= n end; function procedure_name (index: dic_indx): dic_sym; begin procedure_name:= bnf_leader + dic_symbol (parser_cb_p^.dic_handle_calls, index) end; function ch_name (index: dic_indx): dic_sym; begin if index=0 then abort ('Undefined Channel Name'); ch_name:= chn_leader + dic_symbol (parser_cb_p^.dic_handle_calls, index) end; procedure write_channel_list (channel_list: record_p_t); var p: record_p_t; begin p:= channel_list; while p<>nil do with p^, parser_cb_p^ do begin write (f, ch_name (gp_index)); p:= next; if p<>nil then write (f, ', ') {do not append komma after last channel name} end end; procedure write_procedure_head (p: record_p_t); begin with p^ do begin wh; write (f, 'PROCEDURE ', procedure_name (gp_index)); if formal_par<>nil then begin write (f, ' (VAR '); write_channel_list (formal_par); write (f, ': obj_handle_t)') end end end; procedure write_err_free_test; begin writeln (f, 'if err_free then'); wh_begin_ln end; {!R! page; exit;} procedure write_instructions (bnf_list: record_p_t; chn0, chn1, chn2: dic_indx); var p, p1: record_p_t; c0, c1, c2: dic_indx; procedure write_action_c; var i: Integer; s: dic_sym; procedure wr_cond_ln (if_then_else: boolean); begin if if_then_else then begin wh; write (f, 'if '); if s [i+1]=':' then write (f, 'not ') end else begin wh; write (f, 'while ') end; case s [i] of 's' : write (f, 'obj_sym_exists (', ch_name (c2), ', index_sym)'); 'c' : write (f, '(', ch_name (c2), '=nil)'); 't' : write (f, '(term_val_type=text1_const)'); {test ??? text2_const, text3_const, text4_const} 'i' : write (f, '(term_val_type=Integer_const)'); 'r' : write (f, '(term_val_type=real_const)'); 'o' : write (f, 'obj_add_cond_ord (', ch_name (c0), ', ', ch_name (c2), ', index_sym)'); 'M' : write (f, 'obj_expand_macro (', ch_name (c0), ', ', ch_name (c2), ', ', ch_name (c1), ', index_sym)'); otherwise if if_then_else then begin writeln ('Condition: ', s [i]); abort ('Illegal contition') end else begin write (f, 'true'); i:=i-1 end end; if not if_then_else then begin writeln (f, ' do'); i:= i+1 end end; function wr_stmt: char; var cont_loop: boolean; begin wr_stmt := chr(1); {illegal return code} cont_loop:= true; while cont_loop and (i<=length (s)) do begin case s [i] of 's' : begin wh; writeln (f, 'app_symbol (', ch_name (c0), ');') end; 'S' : begin wh; writeln (f, 'obj_add_ord (', ch_name (c0), ', index_sym);') end; 'v' : begin wh; writeln (f, 'app_value (', ch_name (c0), ');') end; 'c' : begin wh; writeln (f, 'obj_delete (', ch_name (c0), ');') end; 'n' : begin wh; writeln (f, 'obj_add_chr (', ch_name (c0), ', newline);') end; apostr : begin wh; writeln (f, 'obj_add_chr (', ch_name (c0), ', apostr);') end; '"' : begin wh; writeln (f, 'obj_add_chr (', ch_name (c0), ', ', apostr, '"', apostr, ');') end; ' ' : begin wh; writeln (f, 'obj_add_chr (', ch_name (c0), ', ', apostr, ' ', apostr, ');') end; 'w' : begin wh; writeln (f, 'out_channel (', ch_name (c0), ');') end; 'T' : begin wh; writeln (f, 'obj_add_dic (', ch_name (c0), ', appl_handle^.wpar.dic_handle_symbol);') end; 'i' : begin wh; writeln (f, 'obj_inc_obj (', ch_name (c0), ', ', ch_name (c1), ');') end; '=' : begin wh; writeln (f, 'obj_assign (', ch_name (c0), ', ', ch_name (c1), ');') end; '+' : begin wh; writeln (f, 'obj_add_obj (', ch_name (c0), ', ', ch_name (c1), ');') end; 'm' : begin wh; writeln (f, 'obj_mov_obj (', ch_name (c0), ', ', ch_name (c1), ');') end; 'M' : begin wh; writeln (f, 'obj_add_dic_mac (', ch_name (c0), ', ', ch_name (c1), ', ', ch_name (c2), ', index_sym);') end; 'b' : begin wh; writeln (f, 'break;') end; 'd' : begin wh; writeln (f, 'write (', apostr, 'BNF diagnostic', apostr, '); dic_diagnostic (appl_handle^.scan_handle);') end; 'e' : begin wh; writeln (f, 'abort (', apostr, 'BNF abort', apostr, ');') end; 'q' : begin wh; writeln (f, 'err_free:= false;') end; '[' : begin i:= i+1; wr_cond_ln (true); writeln (f); i:= i+1; if s [i] = ':' then begin i:= i+1; r; wh; writeln (f, 'then'); wh_begin_ln; if wr_stmt <> ']' then abort ('] expected'); wh_ends_ln; l end else begin r; wh; writeln (f, 'then'); wh_begin_ln; case wr_stmt of ':' : begin wh_end_ln; wh; writeln (f, 'else'); wh_begin_ln; if wr_stmt <> ']' then abort ('] expected'); wh_ends_ln; l end; ']' : begin wh_ends_ln; l end; otherwise abort (': or ] expexted') end; end; i:=i-1 end; ':' : begin cont_loop:= false; wr_stmt:= ':' end; ']' : begin cont_loop:= false; wr_stmt:= ']' end; '{' : begin i:= i+1; wr_cond_ln (false); wh_begin_ln; if wr_stmt <> '}' then abort ('} expected'); wh_ends_ln; i:= i-1 end; '}' : begin cont_loop:= false; wr_stmt:= '}' end; otherwise abort ('illegal action command') end; i:= i+1 end end; begin {write_action_c} if dic_indx2sym (parser_cb_p^.dic_handle_actions, p^.gp_index, s) then begin i:= 1; dummy_ch:= wr_stmt; {test->} if (i-1) <> length (s) then abort ('nesting error 1') end else abort ('Fatal index in write_action_c') end; {write_action_c} begin {write_instructions} p:= bnf_list; c0:= chn0; c1:= chn1; c2:= chn2; while p<>nil do with parser_cb_p^, p^ do begin case tag of case_begin : begin wh; writeln (f, 'case term of'); r; write_instructions (split, c0, c1, c2); p1:= split; while (p1<>nil) and then not set_empty (p1^.tok1) do p1:= p1^.next; {surch empty case_split} if p1<>nil then begin wh; writeln (f, 'otherwise '); r; r; write_instructions (p1^.split, c0, c1, c2); wh_ends_ln; end {0: test unclear what to tell} else begin wh; writeln (f, 'otherwise write_error ([0]) end;') end; l; end; case_split : if not set_empty (tok1) then {do not write empty cases, they are written after otherwise} begin wh; write_set_numbers (tok1); writeln (f, ':'); wh_begin_ln; write_instructions (split, c0, c1, c2); wh_ends_ln end; loop_split : begin wh; write (f, 'while term'); case members (tok1) of 0: abort ('loop_split: empty'); 1: begin write (f, '='); write_set_numbers (tok1); writeln (f, ' do') end; otherwise write (f, ' in ['); write_set_numbers (tok1); writeln (f, '] do') end; wh_begin_ln; write_instructions (split, c0, c1, c2); wh_ends_ln end; option_split : begin wh; write (f, 'if term'); case members (tok1) of 0: abort ('option_split: empty'); 1: begin write (f, '='); write_set_numbers (tok1); writeln (f, ' then') end; otherwise write (f, ' in ['); write_set_numbers (tok1); writeln (f, '] then') end; wh_begin_ln; write_instructions (split, c0, c1, c2); wh_ends_ln end; call : begin wh; write (f, procedure_name (split^.gp_index)); if actual_par<>nil then begin write (f, ' ('); write_channel_list (actual_par); write (f, ')') end; writeln (f, ';') end; call_entry : ; appl_symbol : begin wh; writeln (f, 'ack_keyword (token_symbol);') end; appl_value : begin wh; writeln (f, 'ack_keyword (token_value);') end; appl_keyword : begin wh; writeln (f, 'ack_keyword (', gp_index:1, ');') end; appl_action_s : if gp_index<>0 then begin wh; if output_binary then writeln (f, 'app_kw (', ch_name (c0), ', ', DIC_SYMBOL (dic_handle_strings, gp_index), ');') else writeln (f, 'app_data (', ch_name (c0), ', ', gp_index:1, ');') end; appl_action_c : write_action_c; appl_chn0 : c0:= gp_index; appl_chn1 : c1:= gp_index; appl_chn2 : c2:= gp_index; appl_channel : ; otherwise abort ('Fatal tag ' + str_tag (tag) + ' in write_instructions') {test, rm if pgm ok} end; p:= next end end; {write_instructions} {!R! page; exit;} procedure write_ch_init (channel_list: record_p_t); var p: record_p_t; begin p:= channel_list; while p<>nil do with p^ do begin wh; writeln (f, ch_name (gp_index), ':= nil;'); p:= next end end; procedure write_ch_dispose (channel_list: record_p_t); var p: record_p_t; begin p:= channel_list; while p<>nil do with p^ do begin wh; writeln (f, 'obj_delete (', ch_name (gp_index), ');'); p:= next end end; procedure write_quoting (s: dic_sym; vt: value_t); var i: Integer; vts: dic_sym; procedure next_str; begin while (i<=length (s)) and (s [i] =' ') do i:=i+1 end; procedure write_str; begin while (i<=length (s)) and (s [i]<>' ') do begin write (f, s [i]); if s [i]=apostr then write (f, apostr); i:=i+1 end; next_str {step to next word if any} {test error: if ' not correctly handled} end; begin i:=1; next_str; case vt of comment_const : vts:='comment_const'; include_const : vts:='include_const'; text1_const : vts:='text1_const'; text2_const : vts:='text2_const'; text3_const : vts:='text3_const'; otherwise abort ('write_quoting: illegal vt') end; while i<=length (s) do begin wh; write (f, 'def_quoting (scan_handle, ', apostr); write_str; write (f, apostr, ', ', apostr); write_str; writeln (f, apostr, ', ', vts, ');'); end end; (* procedure write_keyw (dh: dic_handle_t); {problem?? wegen := INDEX_TO_STRING () faellt weg} const {geloest mit dic_indx2sym, perfomance schlecht} max_words = 10; var words : Integer; index : dic_indx; s : dic_sym; begin index:=1; while dic_indx2sym (dh, index, s) do begin words:= 1; wh; write (f, 'def_keyword (scan_handle, ', apostr); while dic_indx2sym (dh, index, s) and (words <= max_words) do begin if words<>1 then write (f, ' '); write (f, s); index:= index+1; words:= words+1 end; writeln (f, apostr, ');') end end; *) procedure write_keyw (dh: dic_handle_t); {problem?? wegen := INDEX_TO_STRING () faellt weg} const {geloest mit dic_indx2sym, perfomance schlecht} max_words = 10; var words, i : Integer; index : dic_indx; s : dic_sym; begin index:=1; while dic_indx2sym (dh, index, s) do begin words:= 1; wh; write (f, 'def_keyword (scan_handle, ', apostr); while dic_indx2sym (dh, index, s) and (words <= max_words) do begin if words<>1 then write (f, ' '); {duplicate single apostrophes} for i:=1 to length (s) do begin write (f, s[i]); if s[i]=apostr then write (f, apostr) end; {procedure?} index:= index+1; words:= words+1 end; writeln (f, apostr, ');') end end; procedure write_actions_s_const (dh: dic_handle_t); var index : dic_indx; begin for index:=1 to dic_last_indx (dh) do begin wh; writeln (f, 'add_data {', index:3, '} (', apostr, dic_symbol (dh, index), apostr, ');') end end; {!R! page; exit;} procedure write_proc_decl_open; begin wh; writeln (f); wh; writeln (f, 'procedure ', base_name, '_open'); wh; writeln (f, ' (var handle : ', base_name, '_handle_t;'); wh; writeln (f, ' dic_file : path_name_t);'); end; procedure write_proc_decl_use; begin wh; writeln (f); wh; writeln (f, 'procedure ', base_name, '_use'); wh; writeln (f, ' (handle : ', base_name, '_handle_t;'); wh; writeln (f, ' in_path_name,'); wh; writeln (f, ' out_path_name : path_name_t;'); wh; writeln (f, ' var error_code: Integer);'); end; procedure write_proc_decl_close; begin wh; writeln (f); wh; writeln (f, 'procedure ', base_name, '_close'); wh; writeln (f, ' (handle : ', base_name, '_handle_t);'); end; procedure write_unit; var p: record_p_t; {universal, to be used only in local context} begin with parser_cb_p^ do begin {-- UNIT declarations ------------------------------------------------------------------} wh; writeln (f, 'UNIT ', base_name, '_unit;'); wh; writeln (f, 'INTERFACE'); wh; writeln (f, 'USES base, object, dictionary, scanner;'); wh; writeln (f, 'type ', base_name, '_handle_t = pointer;'); write_proc_decl_open; write_proc_decl_use; write_proc_decl_close; wh; writeln (f); wh_ln; {-- INTERFACE part ---------------------------------------------------------------------} wh; writeln (f, 'IMPLEMENTATION'); {-- GLOBAL const -----------------------------------------------------------------------} wh; writeln (f, 'const'); r; wh; writeln (f, 'apostr = chr (39);'); wh; writeln (f, 'newline = chr (10);'); wh; writeln (f, 'token_min =', token_min :3, ';'); wh; writeln (f, 'token_empty =', token_empty :3, ';'); wh; writeln (f, 'token_max_keyword =', token_max_keyword:3, ';'); wh; writeln (f, 'token_finish =', token_finish :3, ';'); wh; writeln (f, 'token_symbol =', token_symbol :3, ';'); wh; writeln (f, 'token_value =', token_value :3, ';'); wh; writeln (f, 'token_max =', token_max :3, ';'); l; wh_ln; {-- GLOBAL type for token set ----------------------------------------------------------} if output_binary then begin wh; writeln (f, '%include ', apostr, pgm_name, '.keyword.include', apostr, ';'); wh_ln end; wh; writeln (f, 'type'); r; wh; writeln (f, 'token_range_t = ', token_min:1, '..', token_max:1, ';'); {problem: firstof/lastof don't work} wh; writeln (f, 'token_set_t = set of token_range_t;'); wh_ln; {-- GLOBAL type for handle -------------------------------------------------------------} wh; writeln (f, 'appl_handle_p_t = ^appl_handle_t;'); wh; writeln (f, 'appl_handle_t = record'); wh; writeln (f, ' scan_handle : scan_handle_t;'); wh; writeln (f, ' wpar : obj_param_t;'); wh; writeln (f, ' dictionary : path_name_t;'); wh; writeln (f, ' end;'); wh_ln; l; {-- PROCEDURE open & interface ---------------------------------------------------------} write_proc_decl_open; wh; writeln (f, 'var appl_handle: appl_handle_p_t;'); if not output_binary then begin wh; writeln (f, 'procedure add_data (s: dic_sym); var index: dic_indx; dummy: boolean;'); r; wh; writeln (f, 'begin dummy:= dic_sym2indx (appl_handle^.wpar.dic_handle_data, s, index, create) end;') end; l; wh_begin_ln; wh; writeln (f, 'new (appl_handle);'); wh; writeln (f, 'handle:= appl_handle;'); wh; writeln (f, 'with appl_handle^ do'); wh_begin_ln; wh; writeln (f, 'open_scan_new (scan_handle);'); wh; writeln (f, 'dictionary:= dic_file;'); wh; write (f, 'dic_new (wpar.dic_handle_symbol, true); '); writeln (f, 'def_scan_dic (scan_handle, wpar.dic_handle_symbol,[symbol_const]);'); wh; write (f, 'dic_new (wpar.dic_handle_value, true); '); writeln (f, 'def_scan_dic (scan_handle, wpar.dic_handle_value, [Integer_const,real_const,text1_const]);'); wh; writeln (f, 'if length (dictionary) <> 0 then DIC_READ (wpar.dic_handle_symbol, dictionary);'); if not output_binary then begin wh; writeln (f, 'dic_new (wpar.dic_handle_data, true);'); write_actions_s_const (dic_handle_strings) end; wh_ln; wh; writeln (f, 'def_alphabet'); r; r; r; wh; writeln (f, '(scan_handle,'); wh; writeln (f, ' ', apostr, pgm_del_beg, apostr, ','); wh; writeln (f, ' ', apostr, pgm_sym_beg, apostr, ','); wh; writeln (f, ' ', apostr, pgm_sym_cont, apostr, ','); wh; writeln (f, ' ', apostr, pgm_num_beg, apostr, ','); wh; writeln (f, ' ', apostr, pgm_equ_char, apostr, ');'); l; l; l; write_quoting (pgm_comments, comment_const); write_quoting (pgm_include, include_const); write_quoting (pgm_txt_del, text1_const); {test ' fails} write_keyw (dic_handle_keywords); wh; writeln (f, 'with wpar do'); wh_begin_ln; wh; writeln (f, 'max_line_length := 110;'); {test could be delivered by bnf or caller ??} wh; writeln (f, 'output_buffer := '''';'); {test could be delivered by bnf or caller ??} wh; writeln (f, 'leader := apostr;'); {test could be delivered by bnf or caller ??} wh; writeln (f, 'trailler := apostr;'); {test could be delivered by bnf or caller ??} wh_end_ln; wh_end_ln; wh_ends_ln; wh_ln; {-- PROCEDURE close & interface --------------------------------------------------------} write_proc_decl_close; wh; writeln (f, 'var appl_handle: appl_handle_p_t;'); wh_begin_ln; wh; writeln (f, 'appl_handle:= handle;'); wh; writeln (f, 'with appl_handle^ do'); wh_begin_ln; wh; writeln (f, 'if length (dictionary) <> 0 then DIC_WRITE (wpar.dic_handle_symbol, dictionary);'); wh; writeln (f, 'scan_close (scan_handle);'); wh; writeln (f, 'dic_dispose (wpar.dic_handle_symbol);'); wh; writeln (f, 'dic_dispose (wpar.dic_handle_value);'); if not output_binary then begin wh; writeln (f, 'dic_dispose (wpar.dic_handle_data);') end; wh_ends_ln; wh; writeln (f, 'dispose (appl_handle);'); wh; writeln (f, 'obj_release_pool;'); wh_ends_ln; wh_ln; {-- PROCEDURE use & interface ----------------------------------------------------------} write_proc_decl_use; wh; writeln (f, 'var'); r; wh; writeln (f, 'appl_handle : appl_handle_p_t;'); wh; writeln (f, 'term : dic_indx;'); wh; writeln (f, 'index_fin : dic_indx;'); wh; writeln (f, 'index_fin1 : dic_indx;'); wh; writeln (f, 'index_sym : dic_indx;'); wh; writeln (f, 'index_sym1 : dic_indx;'); wh; writeln (f, 'index_val : dic_indx;'); wh; writeln (f, 'index_val1 : dic_indx;'); wh; writeln (f, 'term_val_type : value_t;'); wh; writeln (f, 'term_val_type1: value_t;'); wh; writeln (f, 'last_token : token_t;'); wh; writeln (f, 'err_free : boolean;'); wh_ln; if global_channels<>nil then begin wh; write_channel_list (global_channels); writeln (f, ': obj_handle_t; {global channels}'); wh_ln; end; {--------------- local to use: place for more global variables comming from BNF --------} l; {--------------- local to use: write_error ----------------------------------------------} wh; writeln (f, 'procedure write_error (ts: token_set_t);'); wh; writeln (f, 'var tr: token_range_t;'); wh_begin_ln; wh; writeln (f, 'write (StdErr, ', apostr, 'Error: ', apostr, ');'); wh; writeln (f, 'if token_symbol in ts then write (StdErr, ', apostr, 'Symbol', apostr, ') else'); wh; writeln (f, 'if token_finish in ts then write (StdErr, ', apostr, 'EOF', apostr, ') else'); {werkt nicht richtig} wh; writeln (f, 'if token_value in ts then write (StdErr, ', apostr, 'value', apostr, ')'); wh; writeln (f, ' else for tr:=0 to token_max do if tr in ts then write (StdErr, tr:1,', apostr, ' ', apostr, ');'); wh; writeln (f, 'write (StdErr, ', apostr, ' expected', apostr, ');'); wh; writeln (f, 'write_diagn (appl_handle^.scan_handle);'); { wh; writeln (f, 'dic_diagnostic (appl_handle^.scan_handle);'); } wh; writeln (f, 'abort (', apostr, '', apostr, ');'); wh; writeln (f, 'err_free:= false;'); wh_ends_ln; wh_ln; {--------------- local to use: write channel ----------------------------------------} if used_out_channel then begin wh; writeln (f, 'procedure out_channel (var channel: obj_handle_t);'); wh; writeln (f, 'begin if err_free then obj_write (channel, appl_handle^.wpar) end;'); wh_ln; end; {--------------- local to use: append last symbol to channel -------------------------} if used_app_symbol then begin wh; writeln (f, 'procedure app_symbol (var channel: obj_handle_t);'); wh; writeln (f, 'begin if err_free then obj_add_dic_sym (channel, index_sym) end;'); wh_ln; end; {--------------- local to use: write last value ----------------------------------------} if used_app_value then begin wh; writeln (f, 'procedure app_value (var channel: obj_handle_t);'); wh_begin_ln; wh; write_err_free_test; wh; writeln (f, 'with appl_handle^ do case term_val_type of'); r; wh; writeln (f, 'not_value, comment_const, include_const, keyword_const, symbol_const :;'); wh; writeln (f, 'Integer_const : obj_add_dic_int (channel, index_val);'); wh; writeln (f, 'real_const : obj_add_dic_real (channel, index_val);'); wh; writeln (f, 'text1_const, text2_const, text3_const, text4_const'); wh; writeln (f, ' : obj_add_dic_txt (channel, index_val);'); wh; writeln (f, 'otherwise abort (', apostr, 'Fatal Data Type', apostr, ') end;'); l; wh_end_ln; wh_ends_ln; wh_ln; end; {--------------- local to use: append data to channel -----------------------------} if used_app_data then if output_binary then begin wh; writeln (f, 'procedure app_kw (var chn: obj_handle_t; kw: keyw_t);'); wh; writeln (f, 'begin if err_free then obj_add_kw (chn, ord (kw)) end;'); wh_ln end else begin wh; writeln (f, 'procedure app_data (var chn: obj_handle_t; index: dic_indx);'); wh; writeln (f, 'begin if err_free then obj_add_dic_dat (chn, index) end;'); wh_ln end; {--------------- local to use: check KEYWORD and read next token -----------------------} wh; writeln (f, 'procedure ack_keyword (kw: dic_indx);'); wh_begin_ln; wh; write_err_free_test; wh; writeln (f, 'if term=kw'); r; wh; writeln (f, 'then with appl_handle^ do'); wh_begin_ln; wh; writeln (f, 'index_fin := index_fin1;'); wh; writeln (f, 'index_sym := index_sym1;'); wh; writeln (f, 'index_val := index_val1;'); wh; writeln (f, 'term_val_type := term_val_type1;'); wh; writeln (f, 'last_token:= next_token (scan_handle, term);'); wh; writeln (f, 'case last_token of'); r; wh; writeln (f, 'finish : begin index_fin1:= term; term:=token_finish end;'); wh; writeln (f, 'symbol : begin index_sym1:= term; term:=token_symbol end;'); wh; write (f, 'value : begin index_val1:= term; term:=token_value;'); writeln (f, ' term_val_type1:= value_type (scan_handle) end;'); wh; writeln (f, 'keyword: ;'); wh; writeln (f, 'otherwise abort (', apostr, 'Fatal token', apostr, ') end;'); l; wh_end_ln; wh; writeln (f, 'else write_error ([kw])'); l; wh_end_ln; wh_ends_ln; wh_ln; {--------------- write procedure forward declarations ----------------------------------} p:= root_entry; while p<>nil do begin write_procedure_head (p); writeln (f, '; forward;'); p:= p^.next end; {--------------- local to use: BNF SYNTAX converting to procedures ---------------------} wh_ln; p:= root_entry; while p<>nil do with p^ do begin write_procedure_head (p); writeln (f, ';'); if local_var<>nil then begin wh; write (f, 'var '); write_channel_list (local_var); writeln (f, ': obj_handle_t;') end; wh; writeln (f, 'begin'); wh; write_err_free_test; write_ch_init (local_var); write_instructions (entry_p, non_zero_ch (d_chn0, gd_chn0), non_zero_ch (d_chn1, gd_chn1), non_zero_ch (d_chn2, gd_chn2)); write_ch_dispose (local_var); wh_end_ln; wh; writeln (f, 'end;'); wh_ln; p:= next end; {---------------- PROGRAM BODY ---------------------------------------------------------} l; wh_begin_ln; wh; writeln (f, 'err_free := true;'); {test: error handling must be yet 'designed'} wh; writeln (f, 'appl_handle := handle;'); wh; writeln (f, 'index_fin1 := 9999;'); wh; writeln (f, 'index_sym1 := 0;'); wh; writeln (f, 'index_val1 := 0;'); wh; writeln (f, 'term_val_type1:= not_value;'); wh; writeln (f, 'with appl_handle^ do'); wh_begin_ln; wh; writeln (f, 'def_file (scan_handle, in_path_name); {giving the input file}'); wh; writeln (f, 'last_token:= next_token (scan_handle, term); {read the first token of input file}'); wh; writeln (f, 'case last_token of'); r; wh; writeln (f, 'finish : begin index_fin1:= term; term:=token_finish end;'); wh; writeln (f, 'symbol : begin index_sym1:= term; term:=token_symbol end;'); wh; write (f, 'value : begin index_val1:= term; term:=token_value;'); writeln (f, ' term_val_type1:= value_type (scan_handle) end;'); wh; writeln (f, 'keyword: ;'); wh; writeln (f, 'otherwise abort (', apostr, 'Fatal token', apostr, ') end;'); l; wh; writeln (f, 'index_fin := index_fin1;'); wh; writeln (f, 'index_sym := index_sym1;'); wh; writeln (f, 'index_val := index_val1;'); wh; writeln (f, 'term_val_type := term_val_type1;'); wh; writeln (f, 'with wpar do'); wh_begin_ln; if output_binary then begin {open binary output} wh; writeln (f, '{OPEN binary output}'); wh; writeln (f, 'out_bin:= true;'); wh; writeln (f, 'lib_open_write (lib_handle, out_path_name);'); end else begin {open ASCII output} wh; writeln (f, 'out_bin:= false;'); wh; writeln (f, 'assign (f, out_path_name);'); wh; writeln (f, 'rewrite (f);'); end; wh_end_ln; wh_ends_ln; {---------------- calling the root entry of SYNTAX (first line of BNF file -------------} write_ch_init (global_channels); wh; writeln (f, bnf_leader, dic_symbol (dic_handle_calls, first_entry^.gp_index),';'); wh; writeln (f, 'if (last_token<>finish) or (index_fin1<>ord (end_of_input)) then write_error ([ord(finish)]);'); write_ch_dispose (global_channels); wh; writeln (f, 'with appl_handle^.wpar do '); wh_begin_ln; if output_binary then begin {close binary output} wh; writeln (f, '{CLOSE binary output}'); wh; writeln (f, 'lib_close (lib_handle);'); end else begin {close ASCII output} wh; writeln (f, 'if length (output_buffer)<>0 then writeln (f, output_buffer);'); wh; writeln (f, 'output_buffer :='''';'); wh; writeln (f, 'close (f);') end; wh_ends_ln; wh; writeln (f, 'error_code:= ord (not err_free);'); wh_ends_ln; wh; writeln (f, ' {here we could do some initializing actions at start}'); wh; writeln (f, 'END.') end; end; {!R! page; exit;} procedure write_main; begin with parser_cb_p^ do begin {-- MAIN declarations ------------------------------------------------------------------} wh; writeln (f, 'PROGRAM ', base_name, '_main (input, output);'); wh; writeln (f, 'USES base, ', base_name, '_unit;'); wh; writeln (f, 'var h : ', base_name, '_handle_t;'); wh; writeln (f, ' ac, err : integer;'); wh; writeln (f, ' a, src, dst_unit: path_name_t;'); wh; writeln (f); wh; writeln (f, 'procedure write_help (s : err_str_t);'); wh_begin_ln; wh; write (f, 'writeln (StdErr, ', apostr, 'Usage : ', apostr); writeln (f, ' + ParamStr (0) + ', apostr, '[src [dst_unit [dest_main]]]', apostr,')'); wh_ends_ln; l; wh; writeln (f); wh_begin_ln; {' --> ', apostr, ' '' --> ', apostr, apostr, ' } wh; writeln (f, 'src:= ', apostr, apostr, '; dst_unit:= ', apostr, apostr, ';'); wh; writeln (f, 'for ac:=1 to ParamCount do'); wh_begin_ln; wh; writeln (f, 'a:= ParamStr (ac);'); wh; writeln (f, 'if src = ', apostr, apostr, ' then src:= a'); wh; writeln (f, ' else if dst_unit=', apostr, apostr, ' then dst_unit:=a'); wh; writeln (f, ' else write_help (', apostr, 'Too many parameters', apostr, ')'); wh_ends_ln; wh; writeln (f, base_name, '_open (h, ', apostr, apostr, ');'); wh; writeln (f, base_name, '_use (h, src, dst_unit, err);'); wh; writeln (f, base_name, '_close (h)'); l; wh; writeln (f, 'end.') end end; begin {translate_appl} parser_cb_p:= ph; base_name := family_name + parser_cb_p^.pgm_name; line:= 1; blanks:=0; if offs >= 0 then parser_cb_p^.structure_blanks:= offs; {pos value overwrites the value from bnf} assign (f, dsn_unit); rewrite (f); write_unit; close (f); {write the unit} if dsn_main <> '' then {and if needed a sutable main program} begin line:= 1; blanks:=0; assign (f, dsn_main); rewrite (f); write_main; close (f) end end; {translate_appl} (* ----------------------- CLOSE bnf structure ------------------------------------------------------------- *) procedure close_parser (ph : parse_handle_t); var parser_cb_p : parser_cb_p_t; p : record_p_t; procedure dispose_expr (obj: record_p_t); var p, pr: record_p_t; begin p:= obj; while p<>nil do with p^ do begin pr :=p; p:= next; case tag of case_begin, case_split, loop_split, option_split : begin set_make_empty (tok0); set_make_empty (tok1); dispose_expr (split); dispose (pr, option_split); end; call_entry : abort ('Fatal call dispose'); call : begin dispose_expr (actual_par); dispose (pr, call); end; appl_symbol : dispose (pr, appl_symbol); appl_value : dispose (pr, appl_value); appl_keyword : dispose (pr, appl_keyword); appl_action_s : dispose (pr, appl_action_s); appl_action_c : dispose (pr, appl_action_c); appl_chn0 : dispose (pr, appl_chn0); appl_chn1 : dispose (pr, appl_chn1); appl_chn2 : dispose (pr, appl_chn2); appl_channel : dispose (pr, appl_channel); otherwise abort ('Fatal dispose') {test remove this line if program is stable} end end end; begin {close_parser} parser_cb_p:= ph; with parser_cb_p^ do begin dic_dispose (dic_handle_calls); dic_dispose (dic_handle_keywords); dic_dispose (dic_handle_strings); dic_dispose (dic_handle_actions); dispose_expr (global_channels); p:=root_entry; {dispose bnf structure now} while p<>nil do with p^ do begin dispose_expr (entry_p); dispose_expr (formal_par); {macht crash, Segmentation fault} dispose_expr (local_var); root_entry:= p; p:= next ; dispose (root_entry, call_entry); end end; dispose (parser_cb_p); end; {close_parser} (* ----------------------- CLOSE bnf structure -------- END ------------------------------------------------ *) END.