{$O+,F+}
unit p3rw;   (* and rule000 *)
interface
uses pscplm,sthunit,sthcom,sthp34,mpaunit,files,p3cmmn;


PROCEDURE pass3_error
	(
		error_number	,
		error_indicator	:	WORD
	)
;

PROCEDURE load_code
	(
	VAR
		code			:	codes
	)
;

function next_code: codes;

PROCEDURE load_arg_1
	(
	VAR
		arg1			: WORD
	)
;

PROCEDURE load_arg_2
	(
	VAR
		arg1			,
		arg2			:	WORD
	)
;

PROCEDURE load_arg_3
	(
	VAR
		arg1			,
		arg2			,
		arg3			:	WORD
	)
;


PROCEDURE store_newline;

PROCEDURE store_code
	(
		code			:	codes
	)
;

PROCEDURE store_code_1
	(
		code			:	codes;
		arg1			:	WORD
	)
;

PROCEDURE store_code_2
	(
		code			:	codes;
		arg1			,
		arg2			:	WORD
	)
;

PROCEDURE store_code_3
	(
		code			:	codes;
		arg1			,
		arg2			,
		arg3			:	WORD
	)
;


PROCEDURE store_code_symbol
	(
		code			:	codes;
		st_addr			:	st_address
	)
;

PROCEDURE store_arg_1
	(
		arg1			:	WORD
	)
;


PROCEDURE store_load_code
	(
	VAR
		i_code			:	codes
	)
;


PROCEDURE copy_1;

PROCEDURE skip
	(
		count			:	WORD
	)
;


PROCEDURE load_symbol
	(
	VAR
		st_addr			:	st_address
	)
;


PROCEDURE store_symbol
	(
		st_addr			:	st_address
	)
;


PROCEDURE load_store_symbol
	(
	VAR
		st_addr			:	st_address
	)
;


PROCEDURE copy_symbol;

PROCEDURE skip_symbol;


  (* RULE000 *)

PROCEDURE load_newline(VAR line_number: WORD);

PROCEDURE copy_newline;

PROCEDURE pass3_option(option, value : WORD);
PROCEDURE copy_option;

implementation
(* ------------------------------------------------------------------------
Error Messages and Warnings:
-.
External Dependencies:
pass3_line  (defined in PASS3CMMN.INC)
linenumber  (defined in RTP86MPA.EXT)
-.
External Effects:
pass3_line  (defined in PASS3CMMN.INC)
elementnumber (defined in RTP86MPA.EXT)
-.
Comments:
-.
Outstanding:
-.
------------------------------------------------------------------------ *)

PROCEDURE pass3_error(error_number, error_indicator: WORD);

BEGIN
elementnumber:= error_indicator;
errormsg(this_pass, error_number);
fatal_error(this_pass, error_number)
END;

PROCEDURE load_code(VAR code : codes);
label 0;
var
line: word;

BEGIN
0: code:= codes(get_byte);
if code=cnewline then
begin
load_newline(line);
goto 0;
end
else
if code=coption then
begin
copy_option;
goto 0;
end;
END (* procedure load_code *);


function next_code: codes; (* look ahead on next code *)
label 0;
var cod: codes;
line: word;
begin
0: cod:= codes(next_byte);
if cod=cnewline then
begin
cod:= codes(get_byte);
load_newline(line);
goto 0;
end
else
if cod=coption then
begin
cod:= codes(get_byte);
copy_option;
goto 0;
end;
next_code:= cod;
end;


PROCEDURE load_arg_1(VAR arg1 : WORD);

BEGIN
arg1:= get_2_byte;
END (* procedure load_arg_1 *);

PROCEDURE load_arg_2(VAR arg1, arg2: WORD);

BEGIN
arg1:= get_2_byte;
arg2:= get_2_byte;
END (* procedure load_arg_2 *);

PROCEDURE load_arg_3(VAR arg1, arg2, arg3: WORD);

BEGIN
arg1:= get_2_byte;
arg2:= get_2_byte;
arg3:= get_2_byte;
END (* procedure load_arg_3 *);

(* $SUBTITLE('------------ PROCEDURE store_newline ') *)
PROCEDURE store_newline;

BEGIN
IF (pass3_line <> linenumber) THEN
BEGIN
put_byte(word(cnewline));
pass3_line:= linenumber;
put_2_byte(pass3_line);
END
END (* procedure store_newline *);

(* $SUBTITLE('------------ PROCEDURE store_code') *)
PROCEDURE store_code(code: codes);

BEGIN
store_newline;
put_byte(word(code));
END (* procedure store_code *);

(* $SUBTITLE('------------ PROCEDURE store_code_1') *)
PROCEDURE store_code_1(code: codes; arg1: WORD);

BEGIN
store_newline;
put_byte(WORD(code));
put_2_byte(arg1);
END (* procedure store_code_1 *);

(* $SUBTITLE('------------ PROCEDURE store_code_2') *)
PROCEDURE store_code_2(code: codes; arg1, arg2: WORD);

BEGIN
store_newline;
put_byte(WORD(code));
put_2_byte(arg1);
put_2_byte(arg2);
END (* procedure store_code_2 *);

(* $SUBTITLE('------------ PROCEDURE store_code_3') *)
PROCEDURE store_code_3(code: codes; arg1, arg2, arg3: WORD);

BEGIN
store_newline;
put_byte(WORD(code));
put_2_byte(arg1);
put_2_byte(arg2);
put_2_byte(arg3);
END (* procedure store_code_3 *);

(* $SUBTITLE('------------ PROCEDURE store_code_symbol') *)
PROCEDURE store_code_symbol(code: codes; st_addr: st_address);

BEGIN
store_newline;
put_byte(WORD(code));
put_2_byte(st_addr.va_low);
put_2_byte(st_addr.va_high);
END (* procedure store_code_symbol *);

(* $SUBTITLE('------------ PROCEDURE store_arg_1') *)
PROCEDURE store_arg_1(arg1: WORD);

BEGIN
store_newline;
put_2_byte(arg1);
END (* procedure store_arg_1 *);

(* $SUBTITLE('------------ PROCEDURE store_load_code') *)
PROCEDURE store_load_code(VAR i_code: codes);

BEGIN
store_newline;
put_byte(WORD(i_code));
i_code:= codes(get_byte);
END (* procedure store_load_code *);

(* $SUBTITLE('------------ PROCEDURE copy_1') *)
PROCEDURE copy_1;

BEGIN
put_2_byte(get_2_byte);
END (* procedure copy_1 *);

(* $SUBTITLE('------------ PROCEDURE skip') *)
PROCEDURE skip(count: WORD);
VAR dummy: WORD;

BEGIN
WHILE count <> 0 DO
BEGIN
dummy:= get_2_byte;
count:= count - 1
END
END (* procedure skip *);

(* $SUBTITLE('------------ PROCEDURE load_symbol') *)
PROCEDURE load_symbol(VAR st_addr: st_address);

BEGIN
st_addr.va_low:= get_2_byte;
st_addr.va_high:= get_2_byte;
END (* procedure load_symbol *);

(* $SUBTITLE('------------ PROCEDURE store_symbol') *)
PROCEDURE store_symbol(st_addr: st_address);

BEGIN
put_2_byte(st_addr.va_low);
put_2_byte(st_addr.va_high);
END (* procedure store_symbol *);

(* $SUBTITLE('------------ PROCEDURE load_store_symbol') *)
PROCEDURE load_store_symbol(VAR st_addr: st_address);
VAR help: WORD;

BEGIN
help:= get_2_byte;
put_2_byte(help);
st_addr.va_low:= help;
help:= get_2_byte;
put_2_byte(help);
st_addr.va_high:= help;
END (* procedure load_store_symbol *);

(* $SUBTITLE('------------ PROCEDURE copy_symbol') *)
PROCEDURE copy_symbol;

BEGIN
put_2_byte(get_2_byte);
put_2_byte(get_2_byte);
END (* procedure copy_symbol *);

(* $SUBTITLE('------------ PROCEDURE skip_symbol') *)
PROCEDURE skip_symbol;
VAR dummy: WORD;
BEGIN
dummy:= get_2_byte;
dummy:= get_2_byte
END (* procedure skip_symbol *);

(************ RULE000 ***********************)

(* ------------------------------------------------------------------------
Pass2Code: 00
separator ::= OPTION(PASSNO,OPT,VALUE)!NEWLINE(LINENO)
Pass3Code: 00
separator ::= OPTION(PASSNO,OPT,VALUE)!NEWLINE(LINENO)
Symbol Table:
- no action.

===========================================================================

Error Messages and Warnings:
e_option
e_option_value
e_version
-.
External Dependencies:
rule_test_set (defined in PASS3CMMN.INC)
-.
External Effects:
sourcenumber (defined in RTP86MPA.EXT)
linenumber  (defined in RTP86MPA.EXT)
elementnumber (defined in RTP86MPA.EXT)
access_check (defined in PASS3CMMN.INC)
range_check  (defined in PASS3CMMN.INC)
index_check  (defined in PASS3CMMN.INC)
overflow_check (defined in PASS3CMMN.INC)

create_size  (defined in PASS3CMMN.INC)
rule_test_set (defined in PASS3CMMN.INC)
-.
Stack Appetite:
-.
Comments:
Compiler options with 'pass_number'='WRD(this_pass)' are not
dumped.

Only the last of successive line numbers are dumped.
-.
Outstanding:
-.
------------------------------------------------------------------------ *)

(* $SUBTITLE('------------ PROCEDURE load_newline') *)
PROCEDURE load_newline
(
VAR
line_number : WORD
);

BEGIN

load_arg_1(line_number);
linenumber:= line_number;

elementnumber:= 0;

(*#BEGINTEST
IF rule_test_set<>[] THEN
WRITELN(testoutput, ' PASS2 LINE: ', line_number:5)
(*ENDTEST#*) 

END (* procedure load_newline *);

(* $SUBTITLE('------------ PROCEDURE copy_newline') *)
PROCEDURE copy_newline;

BEGIN

load_arg_1(linenumber);

elementnumber:= 0;
      store_code_1(cnewline, linenumber);

(*#BEGINTEST
IF rule_test_set<>[] THEN
WRITELN(testoutput, ' PASS2 LINE: ', linenumber:5)
(*ENDTEST#*) 

END (* procedure copy_newline *);

(* $SUBTITLE('------------ PROCEDURE pass3_option') *)
PROCEDURE pass3_option(option, value  : WORD);
var
local_value: word;
BEGIN

CASE option_tokens(option) OF

test_:;
(*#BEGINTEST
begin
IF WORD(czzzz)<value THEN
BEGIN
local_value:= value div 256;
value:= value mod 256;
if testpass3>=0 then
begin
teststh:= teststh or odd(local_value);
local_value:= local_value div 2;
teststh:= teststh and not odd(local_value);
local_value:= local_value div 2;
end
else
local_value:= local_value div 4;

testvmmupdate:= (testvmmupdate or odd(local_value)) and (original_testvmm>=0);
local_value:= local_value div 2;
testvmmupdate:= testvmmupdate and not odd(local_value);
local_value:= local_value div 2;
END;

if testpass3>=0 then
IF value=WORD(caaaa) THEN
rule_test_set:= []
ELSE

IF value>=WORD(czzzz) THEN
rule_test_set:= [ caaaa..czzzz ]
ELSE
rule_test_set:= rule_test_set + [ codes(value) ];
end; (* test_ *)
(*ENDTEST#*)

ixcheck_:
index_check:= true;

noixcheck_:
index_check:= false;

rangecheck_:
range_check:= true;

norangecheck_:
range_check:= false;

accesscheck_:
access_check:= true;

noaccesscheck_:
access_check:= false;

oflowcheck_:
overflow_check:= true;

nooflowcheck_:
overflow_check:= false;

createsize_:
create_size:= value;

(* OTHERWISE *) else
fatal_error(this_pass, e_option)

END  (* - 'this_pass' *)

END (* procedure pass3_option *);

(* $SUBTITLE('------------ PROCEDURE copy_option') *)
PROCEDURE copy_option;

VAR
pass_number ,
option  ,
value  : WORD;

BEGIN

load_arg_3(pass_number, option, value);

CASE modulerange(pass_number) OF

pass3:
pass3_option(option, value) ;

vmm:
BEGIN

IF option=WORD(test_) THEN
if testvmmupdate then
testvmm:= value;
store_code_3(coption, pass_number, option, value)

END;

allpass:
BEGIN

IF option=WORD(sourceno_) THEN
sourcenumber:= value
ELSE

IF option=WORD(versionpass2) THEN
BEGIN

IF pass3_version div 100 < value div 100 THEN
fatal_error(this_pass, e_version);

store_code_3(coption, WORD(allpass), WORD(versionpass3), pass3_version);

END;

store_code_3(coption, pass_number, option, value)

END;

(* OTHERWISE *) else
store_code_3(coption, pass_number, option, value)
END;

(*#BEGINTEST
IF rule_test_set<>[] THEN
WRITELN
(testoutput, ' OPTION: ', pass_number:2, option:6, value:6)
(*ENDTEST#*)

END; (* procedure copy_option *)
END.