PROGRAM ralloc2(INPUT,OUTPUT,adr_file,con_file,alloc_file); { COPYRIGHT (c) 1985, 1986 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY TRANSFERRED. THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT CORPORATION. DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. AUTHOR: Paul Rubinfeld CREATION DATE: 11-April-85 1.00 MODIFIED BY: 27-Mar-86 1.06 GMU Add support for automatically-generated uCALL constraints. 19-Feb-86 1.05 CBS Better error message for ;= AT out of bounds 23-Oct-85 1.04 PIR Fixed dump_block to dump all blocks 13-Oct-85 1.03 PIR Fixed collect_set - "Impossible Address Allocation" check 2-Sep-85 1.02 PIR Fixed collect_set - "Impossible Set Allocation" check LINKING INSTRUCTIONS: Use this command to link this program: $ LINK RALLOC2 This program is part of a set of three programs that are used to allocated microcode for the Rigel microprocessror. ALLOC2 uses the output of ALLOC1 (adr_file, con_file) and generates output that is used by ALLO3 (alloc_file). The actual microcode allocation is performed in ALLOC2. INPUTS (generated by ALLOC1) ---------------------------- adr_file - A file which contains a list of all possible MCR address, and the MCR listing line number and page number associated with each MCR instruction ; 11-JUN-84 16:40:07 <--- date and time stamp 0 1312 48 1 1427 50 2 1432 50 ... n l p ^ ^ ^ | | | MCR address -+ | +---- page number | line number-----+ con_file - A file which contains a list of address contraints ; 11-JUN-84 16:40:07 <--- date and time stamp D 1308 -1 0 0 D 1322 3 4 1 B 1371 12 14 128 A 1373 -1 14 75 ... ^ ^ ^ ^ ^ | | | | | constraint type-+ | | | +-- third argument | | | MCR line number-----+ | +-------- second argument | +-------------- first argument if contraint type is A (adress) first argument : -1 (not used) second argument: MCR address being contrained third argument : radix 3 number representing the '*','0', and '1' bit of the address calculated as followed: '*' = 0 '0' = 1 '1' = 2 symbolic address contraint ********010* radix 3 representation 3 2 1 0 ... + 3 x1 + 3 x2 + 3 x1 + 3 x0 if contraint type is B (block) first argument : the first MCR address second argument: the second MCR address; both address must be in the same block third argument : 128 (not used) if contraint type is D (delta) and first argument is -1 first argument : -1 for absolute assignment second argument: MCR address being assigned third argument : absolute physical address assigned if contraint type is D (delta) and first argument is greater than 0 first argument : base MCR address second argument: offset MCR address third argument : delta; the physical address of the offset is the base physical address plus delta. if delta is greater than the constant CALL_DELTA, the difference between the value and CALL_DELTA is the value to be added to the low 4 bits of the base physical address. OUTPUT (used by ALLOC3) ----------------------- bdr_file - A file which contains a list of all possible MCR address, the MCR listing line number and page number associated with each MCR instruction, and the physical address that is assigned to each MCR address. ; 15-JUL-84 16:40:07 <--- date and time stamp 0 1312 48 0 1 1427 50 23 2 1432 50 49 ... n l p a ^ ^ ^ ^ | | | | MCR address -+ | | +---- physical address assigned to MCR address n | | line number-----+ +------------ page number Some definitions: addresses mcr - logical (virtual) address assigned by Micro-II. physical - control store addresses, i.e., an actual address. block - physical addresses that have the same high order four address bits. set - collection of mcr addresses that define the destinations of a microcode case statement, or call return pair. group - collection of mcr addresses and sets that must be in the same block. } CONST max_adr = 2047; { highest control store address} max_rad3_num = 177146 ; { largest rad3 number that can be represented with 11 bits } max_group = 1024; { maximum number of groups } max_group_len = 127; { maximum number of entries in each group } max_group_size = 127; { maximum number of MCR addresses in each group } max_set = 1024; { maximum number of sets } max_set_len = 128; { maximum number of microinstructions in each set } call_delta = 2048; { Delta value above which this is a uCALL constraint } TYPE mcr_adr = -1..max_adr; { MCR address } physical_adr = UNSIGNED ; { physical address } entry_type = (adr_t,set_t); { group list entry type } dont_care_mask = PACKED ARRAY[1..11] OF CHAR; mcr_record = RECORD weight : INTEGER ; { initialized to 0} line : INTEGER; { initialized to 0} page : INTEGER; { initialized to 0} p_adr : physical_adr; { initialized to -1} group :INTEGER; { initialized to 0} setn : INTEGER; { initialized to 0} a_con : RECORD line : INTEGER; { initialized to 0} ones_msk : UNSIGNED ; { initialized to 0} zero_msk : UNSIGNED ; { initialized to 0} END; b_con : RECORD line : INTEGER; { initialized to 0} m_adr : mcr_adr; { initialized to -1} END; d_con : RECORD abs1 : BOOLEAN; { initialized to FALSE} ucall1 : BOOLEAN; { initialized to FALSE } line1 : INTEGER; { initialized to 0} delta1 : UNSIGNED; { initialized to 0} m_adr1 : mcr_adr; { initialized to -1} abs2 : BOOLEAN; { initialized to FALSE} ucall2 : BOOLEAN; { initialized to FALSE } line2 : INTEGER; { initialized to 0} delta2 : UNSIGNED; { initialized to 0} m_adr2 : mcr_adr; { initialized to -1} END END; group_entry = RECORD CASE e_type : entry_type OF adr_t : (m_adr : mcr_adr); { initialized to -1} set_t : (setn : INTEGER); END; group_record = RECORD length : INTEGER; { initialized to 0} size : INTEGER; weight : INTEGER ; blk_ones_msk : UNSIGNED ; blk_zero_msk : UNSIGNED ; entry : ARRAY[1..max_group_len] of group_entry; END; set_record = RECORD abs : BOOLEAN; { initialized to FALSE } weight : INTEGER ; { initialized to 0 } length : INTEGER; { initialized to 0} entry : ARRAY[1..max_set_len] of mcr_adr; delta : ARRAY[1..max_set_len] of UNSIGNED ; END; VAR error,fail : BOOLEAN; debug, quiet : BOOLEAN; fil_nam : VARYING[132] OF CHAR ; adr_stamp, con_stamp : VARYING[80] OF CHAR; adr_file,con_file,alloc_file : TEXT; { file definitions } p_adr : ARRAY[0..max_adr] of INTEGER ; abs_count, a_con_count, b_con_count, d_con_count, float_count, last_mcr_adr,last_set,last_group,dum,ziltch : INTEGER; mcr : ARRAY[0..max_adr] OF mcr_record; { Variable Definition Initialized -------- ---------- ----------- mcr[n].line MCR listing line number 0 mcr[n].page MCR listing page number 0 mcr[n].p_adr physical address assigned to MCR address n -1 mcr[n].group group that MCR address n belongs to 0 mcr[n].setn set that MCR address n belongs to 0 mcr[n].weight MCR weight 0 mcr[n].a_con.line MCR listing line number of adress contraint 0 mcr[n].a_con.ones_msk 1's mask defining address constraint 0 mcr[n].a_con.zero_msk 0's mask defining address constraint 0 mcr[n].b_con.line MCR listing line number of block contraint 0 mcr[n].b_con.m_adr MCR address pair that is in the same block as MCR address n -1 mcr[n].d_con.abs1 TRUE if delta contraint 1 set an absolute address; otherwise FALSE FALSE mcr[n].d_con.ucall1 TRUE if delta constraint 1 is for a uCALL; otherwise FALSE FALSE mcr[n].d_con.line1 first MCR listing line number of delta contraint 0 mcr[n].d_con.delta1 first delta offset 0 mcr[n].d_con.m_adr1 first MCR address pair that offset is computed against -1 mcr[n].d_con.abs2 TRUE if delta contraint 2 set an absolute address; otherwise FALSE FALSE mcr[n].d_con.ucall2 TRUE if delta constraint 2 is for a uCALL; otherwise FALSE FALSE mcr[n].d_con.line2 second MCR listing line number of delta contraint 0 mcr[n].d_con.delta2 second delta offset 0 mcr[n].d_con.m_adr2 second MCR address pair that offset is computed against -1 } group : ARRAY[1..max_group] OF group_record; { Variable Definition Initialized -------- ---------- ----------- group[n].length number of entries in group n 0 group[n].size number of MCR addresses in group n group[n].weight product of size and # of block possibilities 0 group[n].blk_zero_msk group[n].blk_ones_msk group[n].entry[m].e_type entry m type indication: adr_t 'adr_t' if entry is an MCR address 'set_t' if entry is an set number group[n].entry[m].m_adr used if type is 'adr' - MCR address that is in the group -1 group[n].entry[m].setn used if type is 'set' - set number that is in the group } setn : ARRAY[1..max_set] OF set_record; { Variable Definition Initialized -------- ---------- ----------- setn[n].length number of MCR address in the set 0 setn[n].weight set weight 0 setn[n].entry[m] MCR address that is in the set -1 setn[n].delta[m] offset } FUNCTION MASK(zero,one:UNSIGNED):dont_care_mask; VAR ONE_STR, ZERO_STR, OUTSTR : dont_care_mask; ANS_STR : VARYING[4] OF CHAR; INDEX1 : INTEGER; BEGIN one_str := BIN(one,11); zero_str := BIN(zero,11); OUTSTR := ' '; ans_str := '*01X'; FOR INDEX1 := 1 TO 11 DO outstr[index1] := ans_str[ORD(ONE_STR[INDEX1]) + ORD(ZERO_STR[INDEX1]) + ORD(ONE_STR[INDEX1]) - 143]; MASK := OUTSTR; END; PROCEDURE dump_block ( filename : VARYING[T] OF CHAR; grp_num, fail_entry : INTEGER); CONST dot_dmp = '.BLK' ; VAR n, mcr_num, set_len, set_num, set_entry, grp_entry :INTEGER ; dmp_fil_nam : VARYING[132] OF CHAR ; row, col :UNSIGNED; block_num : UNSIGNED; BEGIN dmp_fil_nam := filename + HEX(grp_num,3) + dot_dmp ; OPEN (alloc_file ,dmp_fil_nam,HISTORY:= NEW ); REWRITE (alloc_file ); WRITELN (alloc_file,' '); WRITELN (alloc_file,'GROUP ',grp_num:1,' LENGTH ',group[grp_num].length:3,' SIZE ',group[grp_num].size:3, ' WEIGHT ',group[grp_num].weight:5,' mask ', mask(group[grp_num].blk_zero_msk, group[grp_num].blk_ones_msk)); WRITELN (alloc_file,' TYPE WEIGHT MCR ADR MASK '); { ' mcr 1000 xxxx(xx) xxxx(xxx) ******0000* ' set # 2 2346 ' xxxx(xx) unasssigned *********0* } FOR grp_entry := 1 TO group[grp_num].length DO BEGIN (* each group entry *) IF fail_entry = grp_entry THEN WRITE(alloc_file,'->') ELSE WRITE(alloc_file,' '); IF group[grp_num].entry[grp_entry].e_type = adr_t THEN BEGIN (* mcr type *) mcr_num := group[grp_num].entry[grp_entry].m_adr ; WRITE (alloc_file,' mcr ',mcr[group[grp_num].entry[grp_entry].m_adr].weight:4, ' ',mcr_num:4,'(',HEX(mcr_num,3),') '); IF mcr[mcr_num].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned ', mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk)) ELSE WRITELN(alloc_file, mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),') ', mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk)) END (* mcr type *) ELSE BEGIN (* set type *) set_num := group[grp_num].entry[grp_entry].setn; WRITELN (alloc_file,' set # ',set_num:4, ' ',mcr[group[grp_num].entry[grp_entry].m_adr].weight:4); set_len := setn[set_num].length; FOR set_entry := 1 TO set_len DO BEGIN (* each set entry *) mcr_num := setn[set_num].entry[set_entry]; WRITE (alloc_file,' ', mcr_num:4,'(',HEX(mcr_num,3),') '); IF mcr[mcr_num].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned ', mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk)) ELSE WRITELN(alloc_file, mcr[mcr_num].p_adr:4,'(', HEX(mcr[mcr_num].p_adr,3),') ', mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk)) END (* each set entry *) END (* set type *) END ; (* each group entry *) page(alloc_file); FOR block_num := 0 TO 15 DO BEGIN writeln(alloc_file); WRITELN(alloc_file,' Physical address map for block ',block_num:2); WRITELN(alloc_file,' 0 1 2 3 4 5 6 7'); WRITELN(alloc_file,' +-----------------------------------------------------------------------------------------------------'); FOR row := 0 TO 15 DO BEGIN (* each row *) WRITE(alloc_file,' ',HEX(row,1),' |'); FOR col := 0 TO 7 DO BEGIN (* each column *) n := ( (block_num * 128) + (col * 16) + row)::INTEGER; IF p_adr[n] <> -1 THEN WRITE(alloc_file,p_adr[n]:4,'(',HEX(p_adr[n],3),') ') ELSE WRITE(alloc_file,' '); END ; (* each column *) WRITELN(alloc_file); END ; (* each row *) WRITELN (alloc_file,' '); WRITELN (alloc_file,'END OF FILE '); CLOSE (alloc_file); END; END; (* PROCEDURE DUMP_blk *) (* INIT SETS TH DATA STRUCTURE TO VALUES THAT WOULD NOT NORMALLY BE CONSIDERED DATA *) PROCEDURE INIT; VAR count1,count2,count3,count4 : INTEGER; BEGIN debug := FALSE; quiet := TRUE; last_mcr_adr := 0 ; last_set := 0 ; last_group := 0 ; a_con_count :=0 ; b_con_count :=0 ; d_con_count :=0 ; float_count :=0 ; abs_count := 0; FOR count1 := 0 TO max_adr DO BEGIN p_adr[count1] := -1 ; mcr[count1].weight := 0 ; mcr[count1].line := 0; mcr[count1].page := 0; mcr[count1].p_adr := 2048; mcr[count1].group := 0; mcr[count1].setn := 0; mcr[count1].a_con.line := 0; mcr[count1].a_con.ones_msk := 0; mcr[count1].a_con.zero_msk := 0; mcr[count1].b_con.line := 0; mcr[count1].b_con.m_adr := -1; mcr[count1].d_con.abs1 := FALSE; mcr[count1].d_con.ucall1 := FALSE; mcr[count1].d_con.line1 := 0; mcr[count1].d_con.delta1 := 0; mcr[count1].d_con.m_adr1 := -1; mcr[count1].d_con.abs2 := FALSE; mcr[count1].d_con.ucall2 := FALSE; mcr[count1].d_con.line2 := 0; mcr[count1].d_con.delta2 := 0; mcr[count1].d_con.m_adr2 := -1; END; FOR count2 := 1 TO max_group DO BEGIN group[count2].length := 0; group[count2].size := 0; group[count2].weight := 0 ; group[count2].blk_ones_msk := 0; group[count2].blk_zero_msk := 0; FOR count3 := 1 TO max_group_len DO BEGIN group[count2].entry[count3].e_type := adr_t ; group[count2].entry[count3].m_adr := -1 ; END; setn[count2].weight := 0 ; setn[count2].length := 0; setn[count2].abs := FALSE ; FOR count4 := 1 TO max_set_len DO BEGIN setn[count2].entry[count4] := -1 ; setn[count2].delta[count4] := 0 ; END; END; END; (* GET_FILENAME_AND_DEBUG RETURNS THE FILENAME WITH NO FILE EXTENTION. FUTURE : CREATE A SWITCH CALLED "DEBUG" THAT , WHEN ON, WOULD DISPLAY MESSAGES THAT WOULD INDICATE WHERE THE PROGRAM IS AT THE MOMENT . EX. DOING ALLOCATE STORING MCR# 30 ANOTHER SWITCH CALLED "ERR_FILE" WOULD PUT ALL ERROR MESSAGES IN AN ERROR FILE (.ERR) *) FUNCTION count_dont_cares(bits:UNSIGNED):INTEGER; VAR n, index, sum : INTEGER; BEGIN sum := 0; index := 1; FOR n :=1 TO 11 DO BEGIN IF UAND( UNOT(bits),index) <> 0 THEN sum := sum +1; index := index * 2; END ; count_dont_cares := sum ; END; PROCEDURE get_filename_and_debug ( var filename : VARYING[x] OF CHAR ); VAR com_status,com_line_length : INTEGER; com_line_pt, dum, ziltch, switch_length, ext_length, dot_loc, slash_loc, file_end : INTEGER; left_loc, right_loc : INTEGER; directory, switch, root, com_line, switches : VARYING[132] OF CHAR; fail, have_dot, have_slash : BOOLEAN; [EXTERNAL] FUNCTION LIB$GET_FOREIGN (VAR INPUT_TEXT : VARYING[U] OF CHAR ; PROMPT : VARYING[V] OF CHAR := %IMMED 0; OUT_LEN : INTEGER := %IMMED 0 ) : INTEGER ; EXTERN; BEGIN com_status := LIB$GET_FOREIGN (com_line,'FILENAME>',ziltch); REPEAT BEGIN {parse command line} fail := FALSE; com_line_length := length(com_line); IF com_status <> 1 THEN BEGIN fail := TRUE; writeln('command line failure ',com_status); END; FOR dum:=1 to com_line_length DO IF (com_line[dum] >= 'a') AND (com_line[dum] <= 'z') THEN com_line[dum] := CHR( ORD(com_line[dum]) - 32 ); left_loc := index(com_line,'['); right_loc := index(com_line,']'); IF (left_loc <> 0) OR (right_loc <> 0) THEN BEGIN {directory found} IF (right_loc = com_line_length) OR (right_loc = 0) OR (left_loc = 0) OR (right_loc < left_loc) THEN BEGIN WRITELN(com_line); FOR dum := 1 TO right_loc-1 DO write(' '); WRITELN('^'); WRITELN(' Directory syntax error '); fail := TRUE; END ELSE BEGIN directory := substr(com_line,1,right_loc); com_line := substr(com_line,right_loc+1,com_line_length-right_loc); com_line_length := length(com_line); END END {directory found} ELSE directory := ''; slash_loc := index(com_line,'/'); IF slash_loc = 0 THEN BEGIN slash_loc := com_line_length + 1; file_end := com_line_length; have_slash := FALSE; END ELSE BEGIN file_end := slash_loc-1; have_slash := TRUE END; dot_loc := index(com_line,'.'); IF dot_loc = 0 THEN BEGIN dot_loc := file_end + 1; have_dot := FALSE END ELSE have_dot := TRUE; IF dot_loc > slash_loc THEN BEGIN fail := TRUE; WRITELN(com_line); FOR dum := 1 TO slash_loc-1 DO write(' '); WRITELN('^'); WRITELN(' Option syntax error ') END ELSE BEGIN {good ./} root := substr(com_line,1,dot_loc-1); filename := root; END; {good ./} IF have_slash THEN BEGIN {have switch} com_line_pt := slash_loc; switch_length := com_line_length - slash_loc; IF switch_length = 0 THEN BEGIN WRITELN(com_line); FOR dum := 1 TO com_line_pt DO write(' '); WRITELN('^'); WRITELN(' Option ignored') END ELSE BEGIN {switch parse setup} switches := substr(com_line,slash_loc+1,switch_length); REPEAT BEGIN {parse switches} switch_length := length(switches); slash_loc := index(switches,'/'); IF (slash_loc = 0) OR (slash_loc = switch_length) THEN BEGIN slash_loc := switch_length + 1; have_slash := FALSE END; switch := substr(switches,1,slash_loc-1); IF index('DEBUG',switch) = 1 THEN debug := TRUE ELSE IF index('NODEBUG',switch) = 1 THEN debug := FALSE ELSE IF index('QUIET',switch) = 1 THEN quiet := TRUE ELSE IF index('VERBOSE',switch) = 1 THEN quiet := FALSE ELSE IF index('HELP',switch) = 1 THEN BEGIN WRITELN; WRITELN('Valid switch HELP DEBUG NODEBUG QUIET VERBOSE'); WRITELN('Defaults switches NODEBUG QUIET'); have_slash := FALSE; fail := TRUE END ELSE BEGIN WRITELN(com_line); FOR dum := 1 TO com_line_pt DO write(' '); WRITELN('^'); WRITELN(' Invalid option'); fail := true; have_slash := false END; com_line_pt := com_line_pt + slash_loc; IF have_slash THEN BEGIN switch_length := switch_length - slash_loc; switches := substr(switches,slash_loc+1,switch_length); END; END {parse switches} UNTIL NOT have_slash; END {switch parse setup} END; {have switch} IF fail THEN BEGIN WRITE('FILENAME>'); com_status := 0; READLN(com_line); END; END; {parse command line} UNTIL NOT fail; WRITELN; WRITE(' Switches: '); IF debug THEN write(' DEBUG ') ELSE write(' NODEBUG '); IF quiet THEN writeln(' QUIET ') ELSE writeln(' VERBOSE '); WRITELN; end; (* RAD3_TO_BIN CONVERTS A DECIMAL REPRESENTATION OF A BASE 3 NUMBER TO A BINARY "ONES MASK" AND "ZERO MASK" . IT ACCOMPLISHES THIS BY THINKING OF THE NUMBER AS AN ELEVEN BIT BINARY NUMBER WITH 1'S,0'S,OR X'S BASE 3 BINARY 0 ---> X 1 ---> 0 2 ---> 1 BY SUCCESSIVELY DIVIDING THE BASE 3 NUMBER BY A POSITION WEIGHT , STARTING FROM POSITION ELEVEN, IF THE QUOTIENT IS A "1" THEN SET THE SAME POSITION OF THE "ZERO MASK" TO A "1". IF THE QUOTIENT IS A "2" THEN SET THE SAME POSITION OF THE "ONES MASK" TO A "1". IF THE QUOTIENT IS A "0" THEN SET THE SAME POSITION OF THE "ZERO MASK" AND THE "ONES MASK" TO A "0", EFFECTIVELY BECOMING A "DON'T CARE" ( X ). *) PROCEDURE rad3_to_bin ( rad3_num : UNSIGNED ; VAR mask0,mask1 : UNSIGNED ); CONST bit10 = 10 ; bit0 = 0 ; VAR pos_cnt,num : INTEGER ; mask0_weight,mask1_weight : UNSIGNED ; BEGIN mask0 := 0; mask1 := 0; FOR pos_cnt := bit10 DOWNTO bit0 DO BEGIN num := (rad3_num div (3**pos_cnt)) :: INTEGER ; (* FIND EACH BASE3 POSITION WEIGHT *) rad3_num := rad3_num mod (3**pos_cnt); (* GET THE REMAINDER FOR NEXT POSITION CALCULATION *) CASE num OF 0 :BEGIN mask1_weight := 0; mask0_weight := 0; mask1 := mask1 + (mask1_weight * (2**pos_cnt)); mask0 := mask0 + (mask0_weight * (2**pos_cnt)); END; 1 :BEGIN mask1_weight := 0; mask0_weight := 1; mask1 := mask1 + (mask1_weight * (2**pos_cnt)); mask0 := mask0 + (mask0_weight * (2**pos_cnt)); END; 2 :BEGIN mask1_weight := 1; mask0_weight := 0; mask1 := mask1 + (mask1_weight * (2**pos_cnt)); mask0 := mask0 + (mask0_weight * (2**pos_cnt)); END; END; END; END; (* END PROCEDURE RAD3_TO_BIN *) (* LOAD_DATA READS THE .ADR AND .CON FILES AND STORES THE DATA INTO ITS CORRESPONDING PLACE IN THE DATA STRUCTURE . .ADR FILE - SHOWS ALL MCRS USED AND THE LINE NUMBER WHERE THEY FIRST OCCUR .CON FILE - SHOWS CONSTRAINTS ( A,B,D ) ON MCRS. IT GIVES THE CONSTRAINT TYPE , THE LINE NUMBER WHERE THE CONSTRAINT OCCURS, THE MCR(S) THAT ARE AFFECTED, AND SOME OTHER INFO DEPENDING ON THE CONSTRAINT TYPE (I.E. DELTA,PHYSICAL ADDRESS,BASE 3 ADDRESS ). *) PROCEDURE load_data ( filename : VARYING[z] OF CHAR ); const dot_con = '.con' ; dot_adr = '.adr' ; spaces = ' ' ; (* 25 SPACES *) position1 = 1 ; position7 = 7 ; TYPE constraint = (a,b,d); VAR constr_field : CONSTRAINT ; con_line_num,column3,column4, companion_mcr,tmp_weight, n,num_of_x,comp_mcr,mcr_num,mcr_line_num,page_num : INTEGER ; new_zero_msk,new_ones_msk,not_ones_or_zero, position_of_x,field5,column5,mcr_delta,rad3_adrs,addres : UNSIGNED ; con_fil_nam,adr_fil_nam : VARYING[132] OF CHAR ; print_header : BOOLEAN; have_call_delta : BOOLEAN; BEGIN print_header := FALSE; con_fil_nam := filename + dot_con ; adr_fil_nam := filename + dot_adr ; OPEN (con_file,con_fil_nam,HISTORY:=READONLY); RESET (con_file); READLN (con_file,con_stamp); OPEN (adr_file,adr_fil_nam,HISTORY:=READONLY); RESET (adr_file); READLN (adr_file,adr_stamp); IF ( LENGTH(con_stamp) <> LENGTH(adr_stamp) ) OR ( adr_stamp <> con_stamp) THEN IF NOT quiet THEN WRITELN (' Warning time stamps disagree.',adr_fil_nam ); WHILE NOT EOF(adr_file) DO BEGIN READLN (adr_file,mcr_num,mcr_line_num,page_num); IF (mcr_num >= 0 ) AND (mcr_num <= max_adr ) THEN BEGIN mcr[mcr_num].line := mcr_line_num ; mcr[mcr_num].page := page_num ; END ELSE BEGIN error :=true ; WRITELN ; WRITELN (' LOAD_DATA***ERROR** MCR NUMBER OUT OF RANGE. IN ',adr_fil_nam ); WRITELN ('LINE # =',mcr_line_num:5 ); WRITELN ('PAGE # =',page_num:5 ); WRITELN ('MCR # =',mcr_num:4,'(',HEX(mcr_num,3),') OUT OF RANGE' ); END; END; last_mcr_adr := mcr_num ; CLOSE ( adr_file ); WHILE NOT EOF(con_file) DO BEGIN READLN (con_file,constr_field,con_line_num,column3,column4,column5); CASE constr_field OF a : BEGIN a_con_count := a_con_count + 1 ; mcr_num := column4 ; rad3_adrs := column5 ; IF (mcr_num >= 0 ) AND (mcr_num <= last_mcr_adr) THEN IF (rad3_adrs >= 0 ) AND (rad3_adrs <= max_rad3_num ) THEN BEGIN rad3_to_bin (rad3_adrs,new_zero_msk,new_ones_msk ); new_zero_msk := UOR ( mcr[mcr_num].a_con.zero_msk, new_zero_msk ); new_ones_msk := UOR ( mcr[mcr_num].a_con.ones_msk, new_ones_msk ); IF UAND ( new_zero_msk, new_ones_msk ) = 0 THEN BEGIN (* mask okay *) mcr[mcr_num].a_con.line := con_line_num ; mcr[mcr_num].a_con.zero_msk := new_zero_msk ; mcr[mcr_num].a_con.ones_msk := new_ones_msk ; IF (mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2) AND ( (UOR(mcr[mcr_num].p_adr,new_ones_msk) <> mcr[mcr_num].p_adr) OR ( UOR( UNOT(mcr[mcr_num].p_adr),new_zero_msk) <> UNOT(mcr[mcr_num].p_adr))) THEN BEGIN (* conflict *) error := TRUE; WRITELN ; WRITELN (' LOAD_DATA***ERROR** ABSOLUTE ASSIGNMENT CONFLICTS WITH ADDRESS CONTRAINT. IN ', adr_fil_nam ); WRITELN ('LINE # =',con_line_num:5 ); WRITELN ('MCR # =',mcr_num:4,'(',HEX(mcr_num,3),') MASK = ', mask(new_zero_msk,new_ones_msk) ); IF mcr[mcr_num].d_con.abs1 THEN BEGIN (* use d_con*1 *) WRITELN ('LINE # =',mcr[mcr_num].d_con.line1:5 ); WRITELN ('MCR # =',mcr[mcr_num].d_con.m_adr1:4,'(', HEX(mcr[mcr_num].d_con.m_adr1,3),') @ ', mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' ); END (* use d_con*1 *) ELSE BEGIN (* use d_con*2 *) WRITELN ('LINE # =',mcr[mcr_num].d_con.line2:5 ); WRITELN ('MCR # =',mcr[mcr_num].d_con.m_adr2:4,'(', HEX(mcr[mcr_num].d_con.m_adr2,3),') @ ', mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' ); END (* use d_con*2 *) END; (* conflict *) (* CALCULATE THE WEIGHT OF MCR BY FINDING HOW MANY "X'S" ARE IN THE LOWER 7 BITS AND RAISING 2 TO THIS POWER ( # OF POSSIBILITIES ) AND SUBTRACTING THIS FROM 128 *) not_ones_or_zero := UNOT ( UOR ( new_zero_msk , new_ones_msk ) ) ; position_of_x := %b'00000000001' ; num_of_x := 0 ; FOR n := position1 TO position7 DO BEGIN IF UAND ( position_of_x , not_ones_or_zero ) = position_of_x THEN num_of_x := num_of_x + 1 ; position_of_x := position_of_x * 2 ; END; tmp_weight := 128 - ( 2 ** num_of_x ) ; IF mcr[mcr_num].weight < tmp_weight THEN mcr[mcr_num].weight := tmp_weight; END (* mask okay *) ELSE BEGIN error := true ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** ADDRESS CONSTRAINT CONFLICT IN ',con_fil_nam); WRITELN (' CANNOT MAKE A VALID ADDRESS' ); WRITELN (constr_field,' ',mcr[mcr_num].a_con.line,' ',column3,' ',column4, '(',HEX(column4,3),')' ); WRITELN (spaces, ' MASK = ',mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk)); WRITELN ; WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4, '(',HEX(column4,3),')' ); WRITELN (spaces,' MASK = ',mask(new_zero_msk,new_ones_msk) ); END (* ELSE *) END ELSE BEGIN error :=true ; WRITELN (''); WRITELN (' LOAD_DATA***ERROR** RAD3 ADDRESS OUT OF RANGE IN ',con_fil_nam); WRITELN (' RAD3 ADDRESS = ',column5,' IS OUT OF RANGE'); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4, '(',HEX(column4,3),') ',column5); END ELSE BEGIN error :=true ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** MCR NUMBER OUT OF RANGE IN ',con_fil_nam); WRITELN ('MCR # =',column4:4,' OUT OF RANGE' ); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4, '(',HEX(column4,3),') ',column5); END END; (* CASE A: *) b : BEGIN b_con_count := b_con_count + 1 ; mcr_num := column3 ; comp_mcr := column4 ; IF mcr_num <> comp_mcr THEN BEGIN IF (mcr_num >= 0 ) AND (mcr_num <= last_mcr_adr ) THEN IF (comp_mcr >= 0 ) AND (comp_mcr <= last_mcr_adr ) THEN BEGIN IF mcr[mcr_num].b_con.line = 0 THEN BEGIN mcr[mcr_num].b_con.line := con_line_num ; mcr[mcr_num].b_con.m_adr := comp_mcr ; END ELSE BEGIN error :=true ; comp_mcr := mcr[mcr_num].b_con.m_adr ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** DUPLICATE BLOCK CONSTRAINT IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].b_con.line,' ',column3,'(',HEX(column3,3),') ', comp_mcr,' ',column5,'(',HEX(column5,3),')'); WRITELN (constr_field,' ',con_line_num,' ',column3,'(',HEX(column3,3),') ',column4, '(',HEX(column4,3),') ',column5); END; END ELSE BEGIN error :=true ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** MCR NUMBER IS OUT OF RANGE IN ',con_fil_nam); WRITELN (' MCR =',column4:4,' OUT OF RANGE' ); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END ELSE BEGIN error :=true ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** MCR NUMBER IS OUT OF RANGE IN ',con_fil_nam); WRITELN (' MCR =',column3:4,' OUT OF RANGE' ); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END; END; (* IF MCR <> COMP *) END; d : BEGIN (* d_con *) d_con_count := d_con_count + 1 ; have_call_delta := (column5 >= CALL_DELTA); IF have_call_delta THEN column5 := column5 - CALL_DELTA; IF (column3 >= -1 ) AND (column3 <= last_mcr_adr ) AND (column4 >= 0 ) AND (column4 <= last_mcr_adr ) AND (column5 >= 0 ) AND (column5 <= max_adr) THEN BEGIN (* good mcr range *) IF column3 = -1 THEN BEGIN (* ABSOLUTE PHYSICAL ADDRESS *) abs_count := abs_count + 1; mcr_num := column4 ; addres := column5 ; IF (addres >= 0 ) AND (addres <= max_adr ) THEN BEGIN (* good absolute address *) IF have_call_delta THEN BEGIN (* uCALL constraint from absolute address 0 *) WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** ABSOLUTE CALL CONSTRAINT IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5) END (* uCALL constraint from absolute address 0 *) ELSE IF mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2 THEN BEGIN (* Duplicate absolute address contraint *) WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** DUPLICATE ABSOLUTE ADDRESS CONSTRAINT IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5) END (* Duplicate absolute address contraint *) ELSE IF mcr[mcr_num].d_con.line1 = 0 THEN (* CHECK FOR EMPTY LOCATION *) BEGIN (* use d_con*1 *) mcr[mcr_num].d_con.abs1 := TRUE ; mcr[mcr_num].d_con.m_adr1 := addres::mcr_adr; mcr[mcr_num].p_adr := addres ; mcr[mcr_num].d_con.line1 := con_line_num ; mcr[mcr_num].weight := 1000; p_adr[addres::INTEGER] := mcr_num ; END (* use d_con*1 *) ELSE IF mcr[mcr_num].d_con.line2 = 0 THEN (* CHECK FOR EMPTY LOCATION *) BEGIN (* use d_con*2 *) mcr[mcr_num].d_con.abs2 := TRUE ; mcr[mcr_num].d_con.m_adr2 := addres::mcr_adr; mcr[mcr_num].p_adr := addres ; p_adr[addres::INTEGER] := mcr_num ; mcr[mcr_num].weight := 1000; mcr[mcr_num].d_con.line2 := con_line_num ; END (* use d_con*2 *) ELSE BEGIN (* Extra delta contraint *) error :=true ; comp_mcr := mcr[mcr_num].d_con.m_adr1 ; mcr_delta := mcr[mcr_num].d_con.delta1 ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** EXTRA DELTA CONSTRAINT IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END; (* Extra delta contraint *) IF mcr[mcr_num].a_con.line > 0 THEN BEGIN (* have address contraint *) new_ones_msk := mcr[mcr_num].a_con.ones_msk; new_zero_msk := mcr[mcr_num].a_con.zero_msk; IF (UOR(mcr[mcr_num].p_adr,new_ones_msk) <> mcr[mcr_num].p_adr) OR (* x y y x *) (UOR( UNOT(mcr[mcr_num].p_adr),new_zero_msk) <> UNOT(mcr[mcr_num].p_adr)) THEN (* a b c c b d da *) BEGIN (* conflict *) error := TRUE; WRITELN ; WRITELN (' LOAD_DATA***ERROR** ABSOLUTE ASSIGNMENT CONFLICTS WITH ADDRESS CONTRAINT. IN ', adr_fil_nam ); WRITELN ('LINE # =',con_line_num:5 ); WRITELN ('MCR # =',mcr_num:4,'(',HEX(mcr_num,3),') MASK = ', mask(new_zero_msk,new_ones_msk) ); IF mcr[mcr_num].d_con.abs1 THEN BEGIN (* use d_con*1 *) WRITELN ('LINE # =',mcr[mcr_num].d_con.line1:5 ); WRITELN ('MCR # =',mcr[mcr_num].d_con.m_adr1:4,'(', HEX(mcr[mcr_num].d_con.m_adr1,3),') @ ', mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' ); END (* use d_con*1 *) ELSE BEGIN (* use d_con*2 *) WRITELN ('LINE # =',mcr[mcr_num].d_con.line2:5 ); WRITELN ('MCR # =',mcr[mcr_num].d_con.m_adr2:4,'(', HEX(mcr[mcr_num].d_con.m_adr2,3),') @ ', mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')' ); END (* use d_con*2 *) END (* conflict *) END (* have address contraint *) END (* good absolute address *) ELSE BEGIN (* bad absolute address *) error := true ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** ADDRESS OUT OF RANGE IN ',con_fil_nam); WRITELN ('PHYS ADDRESS =',column5:4,' OUT OF RANGE' ); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',mcr_num,' ',addres); END (* bad absolute address *) END (* ABSOLUTE PHYSICAL ADDRESS *) ELSE BEGIN (* Delta relation *) mcr_delta := column5 ; mcr_num := column4 ; comp_mcr := column3 ; IF mcr[mcr_num].d_con.line1 = 0 THEN BEGIN (* use d_con*1 *) mcr[mcr_num].d_con.line1 := con_line_num ; mcr[mcr_num].d_con.m_adr1 := comp_mcr ; mcr[mcr_num].d_con.delta1 := mcr_delta ; mcr[mcr_num].d_con.ucall1 := have_call_delta; END (* use d_con*1 *) ELSE IF mcr[mcr_num].d_con.line2 = 0 THEN BEGIN (* use d_con*2 *) mcr[mcr_num].d_con.line2 := con_line_num ; mcr[mcr_num].d_con.m_adr2 := comp_mcr ; mcr[mcr_num].d_con.delta2 := mcr_delta ; mcr[mcr_num].d_con.ucall2 := have_call_delta; IF mcr[mcr_num].d_con.delta1 = mcr[mcr_num].d_con.delta2 THEN BEGIN (* duplicate delta *) error := true; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** DUPLICATE DELTA CONSTRAINT IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END; (* duplicate delta *) IF mcr[mcr_num].d_con.ucall1 AND mcr[mcr_num].d_con.ucall2 THEN BEGIN (* duplicate ucall *) error := true; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** DUPLICATE MICROCALL CONSTRAINT IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END; (* duplicate ucall *) IF mcr[mcr_num].d_con.line1 = mcr[mcr_num].d_con.line2 THEN BEGIN (* duplicate line *) error := true; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** DUPLICATE LINE DELTA NUMBER IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END (* duplicate line *) END (* use d_con*2 *) ELSE BEGIN (* Extra delta contraint *) error :=true ; comp_mcr := mcr[mcr_num].d_con.m_adr1 ; mcr_delta := mcr[mcr_num].d_con.delta1 ; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** EXTRA DELTA CONSTRAINT IN ',con_fil_nam); WRITELN (constr_field,' ',mcr[mcr_num].d_con.line1,' ',comp_mcr,' ',column4,' ',mcr_delta); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END (* Extra delta contraint *) END (* Delta relation *) END (* good mcr range *) ELSE BEGIN (* bad mcr range *) error := true; WRITELN (' '); WRITELN (' LOAD_DATA***ERROR** MCR NUMBER OUT OF RANGE IN ',con_fil_nam); WRITELN (' Check ;= AT constraint at line ', con_line_num); WRITELN ('MCR # =',column3:4,' OUT OF RANGE' ); WRITELN (constr_field,' ',con_line_num,' ',column3,' ',column4,' ',column5); END (* bad mcr range *) END (* d_con *) END END; (* WHILE NOT EOF *) CLOSE ( con_file ) ; (* Look for CASE TARGET ERRORS *) IF NOT quiet THEN FOR mcr_num := 1 TO last_mcr_adr DO IF mcr[mcr_num].b_con.line > 0 THEN BEGIN {b con found} companion_mcr := mcr[mcr_num].b_con.m_adr; IF (NOT mcr[companion_mcr].d_con.abs1) AND (mcr[companion_mcr].d_con.line1 > 0) THEN IF mcr[companion_mcr].d_con.delta1 <> 0 THEN BEGIN {warning} IF NOT print_header THEN BEGIN WRITELN (' '); WRITELN (' LOAD_DATA***WARNING** POSSIBLE CASE TARGET - ALIGN LIST CONFLICTS'); WRITELN (' CASE LINE # ALIGN LIST LINE #'); WRITELN (' ----------- -----------------'); print_header := true; END; WRITELN (' ',mcr[mcr_num].b_con.line:5,' ',mcr[companion_mcr].d_con.line1:5); END; {warning} IF (NOT mcr[companion_mcr].d_con.abs2) AND (mcr[companion_mcr].d_con.line2 > 0) THEN IF mcr[companion_mcr].d_con.delta2 <> 0 THEN BEGIN {warning} IF NOT print_header THEN BEGIN WRITELN (' '); WRITELN (' LOAD_DATA***WARNING** POSSIBLE CASE TARGET - ALIGN LIST CONFLICTS'); WRITELN (' CASE LINE # ALIGN LIST LINE #'); WRITELN (' ----------- -----------------'); print_header := true; END; WRITELN (' ',mcr[mcr_num].b_con.line:5,' ',mcr[companion_mcr].d_con.line2:5); END; {warning} END {b con found} END; (* PROCEDURE LOAD_DATA *) (* COLLECT_SETS LOOKS THROUGH ALL MCRS, FIND THE ONES WITH DELTA CONSTRAINTS , AND USES THEM TO FORM SETS *) PROCEDURE collect_sets ; CONST block_msk = %b'11110000000' ; zero_delta = 0 ; VAR a_con_mcr, abs_mcr, companion_mcr, mcr_num, s, set_length, tmp_weight,last_set_len,mcr_entry,tmp_mcr,set_len_minus_one,count,n,m,i : INTEGER ; ones_msk, zero_msk, a_con_delta, adrx, addres, delta, ref_delta, tmp_delta, abs_delta, abs_adr : UNSIGNED ; a_con, two_a_con : BOOLEAN ; s_mcr, b_mcr : INTEGER; s_delta, b_delta, s_ones_msk, b_ones_msk, s_zero_msk, b_zero_msk : UNSIGNED; PROCEDURE put_data_into_set ( set_val,mcr_val : INTEGER ; delta : UNSIGNED ; ccase : INTEGER); VAR len : INTEGER ; BEGIN IF (set_val > max_set) OR (mcr_val < 0) OR (mcr_val > max_adr) OR (delta < 0) OR (delta > max_adr) THEN BEGIN (* parameter error *) WRITELN (' '); WRITELN ('DRY ROT (PUT_DATA_INTO_SET) - BAD VALUE'); WRITELN (' SET # ',set_val:4,' MCR ',mcr_val:4,'(',HEX(mcr_val,3),') DELTA ',delta::INTEGER:4, ' CASE ',ccase:4); END (* parameter error *) ELSE BEGIN (* no parameter error *) setn[set_val].length := setn[set_val].length + 1 ; len := setn[set_val].length ; IF len > max_set_len THEN BEGIN (* length error *) error := true ; WRITELN (' '); WRITELN ('DRY ROT (PUT_DATA_INTO_SET) - TOO MANY ENTRIES IN SET'); WRITELN (' SET # ',set_val:4,' MCR # ',mcr_val:4,' DELTA ',delta::INTEGER:4,' CASE ',ccase:4); END (* length error *) ELSE BEGIN (* assign mcr to set *) IF mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2 THEN setn[set_val].abs := TRUE ; setn[set_val].entry[len] := mcr_val ; setn[set_val].delta[len] := delta ; END (* assign mcr to set *) END (* no parameter error *) END; (* END PROCEDURE PUT_DATA_INTO_SET *) PROCEDURE CHK_FOR_SET (mcr_num: INTEGER; delta: UNSIGNED; companion_mcr: mcr_adr); VAR adj_delta, c_set_num, c_set_len, set_num, set_len, entry_num, c_base_entry, base_entry: INTEGER; flag: BOOLEAN; low_delta, new_delta, c_base_delta, base_delta: UNSIGNED; c_mcr: mcr_adr; BEGIN (* procedure chk_for_set *) IF mcr[mcr_num].setn > 0 THEN BEGIN (* mcr in set *) IF mcr[companion_mcr].setn = 0 THEN BEGIN (* companion not in set *) (* case II - mcr is in a set; companion is not in a set. Add companion to set. *) set_num := mcr[mcr_num].setn; set_len := setn[set_num].length; entry_num := 0; flag :=FALSE; REPEAT BEGIN (* search for companion within set *) entry_num := entry_num +1; IF setn[set_num].entry[entry_num] = mcr_num THEN BEGIN base_delta := setn[set_num].delta[entry_num]; flag := true END END (* search for companion within set *) UNTIL flag OR (entry_num >= set_len); IF NOT flag THEN BEGIN (* impossible *) error := true ; base_delta := -1; WRITELN ('DRY ROT (CHK_FOR_SET) - CASE II - MCR',mcr_num, '(',HEX(mcr_num,3),') SHOULD BE ASSIGNED TO A SET ',set_num:4); END; (* impossible *) adj_delta := (base_delta - delta)::INTEGER; IF adj_delta < 0 THEN BEGIN new_delta := 0; FOR entry_num := 1 to set_len DO setn[set_num].delta[entry_num] := setn[set_num].delta[entry_num] - (base_delta-delta); END ELSE new_delta := adj_delta::UNSIGNED; mcr[companion_mcr].setn := set_num ; put_data_into_set (set_num, companion_mcr, new_delta, 2); END (* companion not in set*) ELSE BEGIN (* companion in set *) (* case IV - mcr is in a set; companion in a set. Merge mcr set into companion set *) set_num := mcr[mcr_num].setn; set_len := setn[set_num].length; c_set_num := mcr[companion_mcr].setn; c_set_len := setn[c_set_num].length; (* find companion entry with companion set *) entry_num := 0; flag := FALSE; REPEAT BEGIN (* search for companion within companion set *) entry_num := entry_num +1; IF setn[c_set_num].entry[entry_num] = companion_mcr THEN BEGIN c_base_delta := setn[c_set_num].delta[entry_num]; c_base_entry := entry_num; flag := true END END (* search for companion within set *) UNTIL flag OR (entry_num >= c_set_len); IF NOT flag THEN BEGIN (* impossible *) error := true ; c_base_entry := 1; c_base_delta := -1; WRITELN ('DRY ROT (CHK_FOR_SET) - CASE IV - MCR ',mcr_num,'(',HEX(mcr_num,3), ') SHOULD BE ASSIGNED COMPANION SET ',c_set_num:4); END; (* impossible *) (* find mcr within mcr set *) entry_num := 0; flag := FALSE; REPEAT BEGIN (* search for mcr within set *) entry_num := entry_num +1; IF setn[set_num].entry[entry_num] = mcr_num THEN BEGIN base_delta := setn[set_num].delta[entry_num]; base_entry := entry_num; flag := true END END (* search for companion within set *) UNTIL flag OR (entry_num >= set_len); IF NOT flag THEN BEGIN (* impossible *) error := true ; base_entry := 1; base_delta := -1; WRITELN ('DRY ROT (CHK_FOR_SET) - CASE IV - MCR ',mcr_num,'(', HEX(mcr_num,3),') SHOULD BE ASSIGNED MCR SET ',set_num:4); END; (* impossible *) IF c_set_num = set_num THEN BEGIN (* same set *) IF base_delta <> (c_base_delta + delta) THEN BEGIN (* error *) WRITELN; WRITELN (' COLLECT SETS***ERROR*** SET ', set_num:4,' HAVE DUPLICATE DELTA' ); WRITELN (' MCR DELTA'); WRITELN (' ',setn[set_num].entry[base_entry]:4,'(', HEX(setn[set_num].entry[base_entry],3),') ', setn[set_num].delta[base_entry]:4); WRITELN (' ',setn[c_set_num].entry[c_base_entry]:4,'(', HEX(setn[c_set_num].entry[c_base_entry],3),') ', setn[c_set_num].delta[c_base_entry]:4); END (* error *) END (* same set *) ELSE BEGIN (* different sets *) (* determine if a negative delta is generated by the merge *) low_delta := 2048; FOR entry_num := 1 TO set_len DO BEGIN new_delta := (setn[set_num].delta[entry_num] - base_delta) + (delta + c_base_delta); IF new_delta::INTEGER < low_delta::INTEGER THEN low_delta := new_delta; END; (* adjust delta's in companion set if a negative delta is generated *) IF low_delta::INTEGER < 0 THEN FOR entry_num := 1 TO c_set_len DO setn[c_set_num].delta[entry_num] := setn[c_set_num].delta[entry_num] - low_delta ELSE low_delta := 0 ; (* move all mcr set entries to the companion set *) FOR entry_num := 1 TO set_len DO BEGIN new_delta := (setn[set_num].delta[entry_num] - base_delta) + (delta + c_base_delta) - low_delta; c_mcr := setn[set_num].entry[entry_num]; mcr[c_mcr].setn := c_set_num; put_data_into_set (c_set_num, c_mcr, new_delta,4) END; (* mark deleted set, i.e., the mcr set, as length 0 *) setn[set_num].length := 0; IF setn[set_num].abs THEN setn[c_set_num].abs := TRUE; END (* different sets *) END (* companion in set *) END (* mcr in set *) ELSE IF mcr[companion_mcr].setn > 0 THEN (* case III - mcr is not in a set; companion is in a set. Add mcr to companion set with adjusted delta *) BEGIN (* case within case *) c_set_num := mcr[companion_mcr].setn ; c_set_len := setn[c_set_num].length ; (* find companion within companion set *) entry_num := 0; flag := false; REPEAT BEGIN entry_num := entry_num +1; IF setn[c_set_num].entry[entry_num] = companion_mcr THEN BEGIN new_delta := setn[c_set_num].delta[entry_num] + delta; flag := TRUE END END (* search for companion within set *) UNTIL flag OR (entry_num >= c_set_len); IF NOT flag THEN BEGIN (* impossible *) error := true ; WRITELN ('DRY ROT (CHK_FOR_SET) - CASE III - '); WRITELN(' MCR ',companion_mcr,'(',HEX(companion_mcr,3), ') SHOULD BE ASSIGNED TO THE COMPAINION SET ',c_set_num:4); END; (* impossible *) mcr[mcr_num].setn := c_set_num ; put_data_into_set (c_set_num,mcr_num,new_delta,3); END (* case within case *) ELSE (* case I - mcr is not in a set; companion is not in a set. Create new set *) BEGIN (* CREATE A NEW SET *) last_set := last_set + 1 ; (* LAST_SET IS THE EFFECTIVE "NEW SET NUMBER" *) IF last_set <= max_set THEN BEGIN (* valid set number *) mcr[mcr_num].setn := last_set ; mcr[companion_mcr].setn := last_set ; c_base_delta := 0 ; IF NOT mcr[companion_mcr].d_con.abs1 AND (mcr[companion_mcr].d_con.delta1 > c_base_delta) THEN c_base_delta := mcr[companion_mcr].d_con.delta1; IF NOT mcr[companion_mcr].d_con.abs2 AND (mcr[companion_mcr].d_con.delta2 > c_base_delta) THEN c_base_delta := mcr[companion_mcr].d_con.delta2; new_delta := c_base_delta + delta ; put_data_into_set (last_set,mcr_num,new_delta,1 ); put_data_into_set (last_set,companion_mcr,c_base_delta,1 ); END (* valid set number *) ELSE BEGIN (* invalid set number *) error := true ; WRITELN ('SET #',last_set:4,' EXCEEDES MAX_SET!!!'); END (* invalid set number *) END (* CREATE A NEW SET *) END; (* procedure chk_for_set *) BEGIN (* BODY OF COLLECT SETS *) IF NOT error THEN BEGIN (* no error *) FOR mcr_num := 0 TO last_mcr_adr DO BEGIN (* sequence *) IF NOT mcr[mcr_num].d_con.abs1 AND (mcr[mcr_num].d_con.line1 > 0) THEN CHK_FOR_SET(mcr_num, mcr[mcr_num].d_con.delta1, mcr[mcr_num].d_con.m_adr1); IF NOT mcr[mcr_num].d_con.abs2 AND (mcr[mcr_num].d_con.line2 > 0) THEN CHK_FOR_SET(mcr_num, mcr[mcr_num].d_con.delta2, mcr[mcr_num].d_con.m_adr2) END; (* sequence *) (* CHECK EACH SET FOR DUPLICATE DELTA'S and CALCULATE THE WEIGHT OF each set *) FOR s:= 1 TO last_set DO BEGIN (* set sequence *) set_length := setn[s].length ; IF set_length >0 THEN BEGIN (* set not empty *) set_len_minus_one := set_length - 1 ; tmp_weight := 0 ; FOR n := 1 TO set_length DO BEGIN (* calculate set weight *) mcr_entry := setn[s].entry[n] ; IF mcr[mcr_entry].weight > tmp_weight THEN tmp_weight := mcr[mcr_entry].weight END; (* calculate set weight *) setn[s].weight := ( tmp_weight * 20 ) + set_length ; FOR count := 1 TO set_len_minus_one DO BEGIN (* each entry *) n := count + 1 ; ref_delta := setn[s].delta[count] ; FOR m := n TO set_length DO BEGIN (* COMPARE REF DELTA *) IF ref_delta = setn[s].delta[m] THEN BEGIN (* error *) error := true ; WRITELN (' ' ); WRITELN (' COLLECT SETS***ERROR*** SET ',S:4,' HAVE DUPLICATE DELTA' ); WRITELN (' MCR DELTA'); WRITELN (' ',setn[s].entry[count]:4,'(',HEX(setn[s].entry[count],3),') ', setn[s].delta[count]:4); WRITELN (' ',setn[s].entry[m]:4,'(',HEX(setn[s].entry[m],3),') ', setn[s].delta[m]:4); END; (* error *) END; (* compare ref delta *) END; (* each entry *) END; (* set not empty *) END; (* set sequence *) (* WITHIN EACH SET, SORT ENTRIES BY DELTA ( SMALLEST DELTA FIRST ) *) FOR s:= 1 TO last_set DO IF setn[s].length > 0 THEN BEGIN (* set sequence *) FOR i:= 1 TO (setn[s].length - 1 ) DO BEGIN (* outer loop *) FOR n:= 1 TO (setn[s].length - 1 ) DO BEGIN (* middle loop *) IF setn[s].delta[n] > setn[s].delta[ (n+1) ] THEN BEGIN (* inner loop *) tmp_delta := setn[s].delta[n] ; tmp_mcr := setn[s].entry[n] ; setn[s].delta[n] := setn[s].delta[ (n+1) ] ; setn[s].entry[n] := setn[s].entry[ (n+1) ] ; setn[s].delta[ (n+1) ] := tmp_delta ; setn[s].entry[ (n+1) ] := tmp_mcr ; END (* inner loop *) END (* middle loop *) END; (* outer loop *) (* check to see if set crosses a block boundary *) two_a_con := FALSE; a_con := FALSE; FOR n:=1 TO setn[s].length DO BEGIN (* check each entry *) mcr_num := setn[s].entry[n]; IF mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2 THEN BEGIN (* abs found *) setn[s].abs := TRUE ; abs_delta := setn[s].delta[n] ; addres := mcr[mcr_num].p_adr ; abs_mcr := mcr_num ; abs_adr := addres ; END; (* abs found *) IF mcr[mcr_num].a_con.line > 0 THEN BEGIN (* a_con found *) IF a_con THEN two_a_con := true ELSE a_con := true; ones_msk := mcr[mcr_num].a_con.ones_msk; zero_msk := mcr[mcr_num].a_con.zero_msk; a_con_delta := setn[s].delta[n]; a_con_mcr := mcr_num; END (* a_con found *) END; (* check each entry *) IF two_a_con THEN FOR n:=1 TO setn[s].length DO BEGIN (* check each entry *) mcr_num := setn[s].entry[n]; delta := setn[s].delta[n]; IF mcr[mcr_num].a_con.line > 0 THEN BEGIN (* found a_con *) IF delta > a_con_delta THEN BEGIN s_mcr := a_con_mcr; b_mcr := mcr_num; s_delta := a_con_delta; b_delta := delta; END ELSE BEGIN s_mcr := mcr_num; b_mcr := a_con_mcr; s_delta := delta; b_delta := a_con_delta; END; s_ones_msk := mcr[s_mcr].a_con.ones_msk; b_ones_msk := mcr[b_mcr].a_con.ones_msk; s_zero_msk := mcr[s_mcr].a_con.zero_msk; b_zero_msk := mcr[b_mcr].a_con.zero_msk; adrx := s_ones_msk + b_delta - s_delta; IF ( UAND(adrx,b_ones_msk) <> b_ones_msk) OR ( UAND( UNOT(adrx),b_zero_msk) <> b_zero_msk ) THEN BEGIN (* error *) error := true ; WRITELN (' ' ); WRITELN (' COLLECT SETS***ERROR*** SET ',S:4,' IMPOSSIBLE ADDRESS CONSTRAINT' ); WRITELN (' MCR DELTA MASK'); WRITELN (' ',s_mcr:4,'(',HEX(s_mcr,3),') ', s_delta:4,' ',mask(s_zero_msk,s_ones_msk)); WRITELN (' ',b_mcr:4,'(',HEX(b_mcr,3),') ', b_delta:4,' ',mask(b_zero_msk,b_ones_msk)); END (* error *) END; (* found a_con *) END; (* check each entry *) IF setn[s].abs THEN FOR n:=1 TO setn[s].length DO BEGIN (* check each entry *) mcr_num := setn[s].entry[n]; delta := setn[s].delta[n]; IF UAND(abs_adr, block_msk) <> UAND( (abs_adr + delta - abs_delta),block_msk) THEN BEGIN WRITELN (' ' ); WRITELN (' COLLECT SETS***ERROR*** SET ',S:4,' CROSSES BLOCK BOUNDARY' ); WRITELN (' MCR DELTA ADR'); WRITELN (' ',abs_mcr:4,'(',HEX(abs_mcr,3),') ', abs_delta:4,' @ ',abs_adr:4,'(',HEX(abs_adr,3),')'); WRITELN (' ',mcr_num:4,'(',HEX(mcr_num,3),') ', delta:4,' crosses block - can not be allocated '); END END; (* check each entry *) (* assign all set entries if set contains an absolute assignment *) IF setn[s].abs THEN FOR n:=1 TO setn[s].length DO BEGIN mcr_num := setn[s].entry[n] ; addres := abs_adr - (abs_delta - setn[s].delta[n]) ; IF ( (mcr[mcr_num].p_adr <> 2048) AND (mcr[mcr_num].p_adr <> addres) ) OR ( (p_adr[addres::INTEGER] <> -1) AND (p_adr[addres::INTEGER] <> mcr_num) ) THEN BEGIN WRITELN; WRITELN (' COLLECT SETS***ERROR*** SET ',S:4,' ABSOLUTE ASSIGNMENT COLLISION'); WRITELN(' MCR ',mcr_num:4,'(',HEX(mcr_num,3),') needs to be at ',addres:4,'(', HEX(addres,3),')'); WRITELN(' MCR ',p_adr[addres::INTEGER]:4,'(',HEX(p_adr[addres::INTEGER],3),') is assigned to ', addres:4,'(',HEX(addres,3),')'); END ELSE BEGIN mcr[mcr_num].p_adr := addres ; p_adr[addres::INTEGER] := mcr_num ; END END ; (* check to make sure there is a zero delta in the set *) IF setn[s].delta[1] <> 0 THEN BEGIN error := true ; WRITELN; WRITELN (' COLLECT SETS***ERROR*** SET ',S:4,' BAD FORM'); WRITELN (' NO DELTA OF 0 FOUND' ); END; END; (* set sequence *) END; (* END IF NOT error *) END; (* END PROCEDURE COLLECT_SETS *) PROCEDURE collect_groups ; CONST position_8 = 8 ; position_11 = 11 ; VAR grp_size,num_of_x,grp_num,grp_entry_type,pass,next,tmp_entry,tmp_set,next_set_num, companion_mcr,mcr_num,group_num,mcr_in_grp,mcr_in_set,set_num,set_len,grp_len,n,m, set_length,set_entry,mcr_grp,comp_mcr_grp,mcr_grp_len,comp_grp_len,entry,new_entry,mcr_entry,next_mcr,next_set : INTEGER ; max_set_weight, max_mcr_weight: INTEGER; merge_error: BOOLEAN ; not_ones_or_zero,position_of_x : UNSIGNED ; PROCEDURE put_data_into_group ( grp_val, mcr_val, ccase : INTEGER ); VAR len,mcr_entry,set_length,set_num,n : INTEGER ; BEGIN IF (grp_val < 0) OR (grp_val > max_group) OR (mcr_val < 0) OR (mcr_val > max_adr) THEN BEGIN (* parameter error *) error := TRUE; WRITELN('DRY ROT (PUT_DATA_INTO_GROUP) - BAD PARAMETER'); WRITELN(' GROUP ',grp_val:4,' MCR ',mcr_val:4,'(',HEX(mcr_val,3),') CASE ',ccase:2); END (* parameter error *) ELSE BEGIN (* no parameter error *) group[grp_val].length := group[grp_val].length + 1 ; len := group[grp_val].length ; IF len > max_group_len THEN BEGIN (* length error *) error := true ; WRITELN('GROUP ',grp_val:3,' HAS EXCEEDED MAXIMUM LENGTH. CASE ',ccase:2 ); END (* length error *) ELSE BEGIN (* no length error *) IF mcr[mcr_val].setn > 0 THEN BEGIN (* mcr is in a set so assign set *) set_num := mcr[mcr_val].setn ; set_length := setn[set_num].length ; group[grp_val].entry[len].e_type := set_t ; group[grp_val].entry[len].setn := set_num ; group[grp_val].size := group[grp_val].size + set_length ; FOR n := 1 TO set_length DO BEGIN (* get each set entry *) mcr_entry := setn[set_num].entry[n] ; IF mcr[mcr_entry].group = 0 THEN mcr[mcr_entry].group := grp_val ELSE BEGIN (* overwrite of a group *) error :=true ; WRITELN (' '); WRITELN (' COLLECT GROUPS ERROR*** OVERWRITE OF MCR GROUP ASSIGNMENT. CASE ', ccase:2); WRITELN ('MCR ',mcr_entry:4,'(',HEX(mcr_entry,3),') IN SET ',set_num:4, ' IS ASSIGNED TO GROUP ', mcr[mcr_entry].group:4); WRITELN ('MCR ',mcr_entry:4,'(',HEX(mcr_entry,3),') IS ALSO ASSIGNED TO GROUP ', grp_val:4); END (* overwrite of a group *) END (* get each set entry *) END (* mcr is in a set so assign set *) ELSE BEGIN (* mcr is not in a set - assign mcr *) group[grp_val].entry[len].e_type := adr_t ; group[grp_val].entry[len].m_adr := mcr_val ; group[grp_val].size := group[grp_val].size + 1 ; IF mcr[mcr_val].group = 0 THEN mcr[mcr_val].group := grp_val ELSE BEGIN (* overwrite of a group *) error :=true ; WRITELN (' '); WRITELN (' COLLECT GROUPS ERROR*** OVERWRITE OF MCR GROUP ASSIGNMENT. CASE ',ccase:2); WRITELN ('MCR ',mcr_val:4,'(',HEX(mcr_val,3),') IS ASSIGNED TO GROUP ', mcr[mcr_val].group:4); WRITELN ('MCR ',mcr_val:4,'(',HEX(mcr_val,3),') IS ALSO ASSIGNED TO GROUP ', grp_val:4); END (* overwrite of a group *) END; (* mcr is not in a set - assign mcr *) IF group[grp_val].size > max_group_size THEN BEGIN (* size error *) error := true ; WRITELN ('SIZE OF GROUP ',grp_val:4,' IS ',group[grp_val].size,' - EXCEEDES MAX_GROUP_SIZE. CASE ', ccase:2 ); END (* size error *) END (* no length error *) END (* no parameter error *) END; (* END PROCEDURE PUT_DATA_INTO_GROUP *) PROCEDURE add_to_blk_msk (group_value ,mcr_value : INTEGER ) ; CONST block_msk = %b'11110000000' ; VAR tmp_mask0,tmp_mask1 : UNSIGNED ; BEGIN IF mcr[mcr_value].d_con.abs1 OR mcr[mcr_value].d_con.abs2 THEN BEGIN (* absolute assignment *) tmp_mask0 := UAND (block_msk ,UNOT(mcr[mcr_value].p_adr) ); tmp_mask1 := UAND (block_msk , mcr[mcr_value].p_adr); group[group_value].blk_zero_msk := UOR (group[group_value].blk_zero_msk , tmp_mask0 ); group[group_value].blk_ones_msk := UOR (group[group_value].blk_ones_msk , tmp_mask1 ); IF UAND (group[group_value].blk_zero_msk,group[group_value].blk_ones_msk) <> 0 THEN BEGIN WRITELN ('GROUP ',group_value:4,' BLOCK MASK ERROR - MASK = ', mask(group[group_value].blk_zero_msk, group[group_value].blk_ones_msk) ); error :=true ; END END (* absoulute assignment *) ELSE IF mcr[mcr_value].a_con.line > 0 THEN BEGIN tmp_mask0 := UAND (block_msk , mcr[mcr_value].a_con.zero_msk); tmp_mask1 := UAND (block_msk , mcr[mcr_value].a_con.ones_msk); group[group_value].blk_zero_msk := UOR (group[group_value].blk_zero_msk , tmp_mask0 ); group[group_value].blk_ones_msk := UOR (group[group_value].blk_ones_msk , tmp_mask1 ); IF UAND (group[group_value].blk_zero_msk,group[group_value].blk_ones_msk) <> 0 THEN BEGIN error :=true ; WRITELN ('GROUP ',group_value:4,' BLOCK MASK ERROR - MASK = ', mask(group[group_value].blk_zero_msk, group[group_value].blk_ones_msk) ); END END END ; (* PROCDURE ADD_TO_BLK_MSK *) BEGIN (* BODY OF COLLECT_GROUPS *) IF NOT error THEN BEGIN (* no error *) FOR mcr_num := 0 TO last_mcr_adr DO BEGIN (* mcr sequence *) mcr_in_grp := %b'00' ; IF mcr[mcr_num].b_con.line > 0 THEN BEGIN (* mcr has b_con *) companion_mcr := mcr[mcr_num].b_con.m_adr ; IF mcr[mcr_num].group > 0 THEN mcr_in_grp := %b'10' ; IF mcr[companion_mcr].group > 0 THEN mcr_in_grp := mcr_in_grp + 1 ; CASE mcr_in_grp OF %b'00' : BEGIN (* MCR AND COMPANION MCR ARE NOT IN A GROUP - add both to a new group *) last_group := last_group + 1 ; (* LAST_GROUP IS THEN EFFECTIVE "NEW GROUP NUMBER" *) IF last_group <= max_group THEN BEGIN (* add mcr anc companion to group *) put_data_into_group (last_group,mcr_num,0); IF mcr[companion_mcr].group = 0 THEN put_data_into_group (last_group,companion_mcr,0); END (* add mcr anc companion to group *) ELSE BEGIN error := true ; WRITELN ('GROUP #',last_group:4,'EXCEEDES MAX_GROUP!!!'); END; END ; (* MCR AND COMPANION MCR ARE NOT IN A GROUP *) %b'01' : BEGIN (* MCR IS NOT IN A GROUP, COMPANION MCR IS - add mcr to companion group *) comp_mcr_grp := mcr[companion_mcr].group ; put_data_into_group (comp_mcr_grp, mcr_num, 1 ); END ; (* MCR IS NOT IN A GROUP, COMPANION MCR IS - add mcr to companion group *) %b'10' : BEGIN (* MCR IS IN A GROUP, COMPANION MCR IS NOT - add companion to mcr group *) mcr_grp := mcr[mcr_num].group ; put_data_into_group (mcr_grp,companion_mcr, 2 ); END ; (* MCR IS IN A GROUP, COMPANION MCR IS NOT - add companion to mcr group *) %b'11' : BEGIN (* MCR AND COMPANION MCR ARE BOTH IN A GROUP - merge companion group with mcr group *) merge_error := FALSE ; mcr_grp := mcr[mcr_num].group ; comp_mcr_grp := mcr[companion_mcr].group ; mcr_grp_len := group[mcr_grp].length ; comp_grp_len := group[comp_mcr_grp].length ; IF (mcr_grp <> comp_mcr_grp) AND (mcr_num <> companion_mcr )THEN BEGIN (* groups are merged *) IF (group[mcr_grp].size + group[comp_mcr_grp].size ) > max_group_size THEN BEGIN error := TRUE ; merge_error := TRUE ; WRITELN (' '); WRITELN ('GROUP ',mcr_grp:4,' AND GROUP ',comp_mcr_grp:4,' CAN NOT BE MERGED'); WRITELN (' COMBINED SIZE EXCEEDS MAX_GROUP_SIZE'); END; IF (mcr_grp_len + comp_grp_len ) > max_group_len THEN BEGIN error := TRUE ; merge_error := TRUE ; WRITELN (' '); WRITELN ('GROUP ',mcr_grp:4,' AND GROUP ',comp_mcr_grp:4,' CAN NOT BE MERGED'); WRITELN (' COMBINED LENGTHS WILL EXCEED MAX_GROUP_LENGTH'); END; IF NOT merge_error THEN BEGIN (* COPY CONTENTS OF COMPANION GROUP TO MCR GROUP *) group[mcr_grp].length := mcr_grp_len + comp_grp_len ; group[mcr_grp].size := group[mcr_grp].size + group[comp_mcr_grp].size ; FOR entry := 1 TO comp_grp_len DO BEGIN (* move each companion entry *) new_entry := mcr_grp_len + entry ; group[mcr_grp].entry[new_entry].e_type := group[comp_mcr_grp].entry[entry].e_type ; IF group[mcr_grp].entry[new_entry].e_type = adr_t THEN BEGIN (* companion entry is a mcr *) group[mcr_grp].entry[new_entry].m_adr := group[comp_mcr_grp].entry[entry].m_adr ; mcr[ group[mcr_grp].entry[new_entry].m_adr ].group := mcr_grp ; END (* companion entry is a mcr *) ELSE BEGIN (* companion entry is a set *) group[mcr_grp].entry[new_entry].setn := group[comp_mcr_grp].entry[entry].setn ; set_num := group[mcr_grp].entry[new_entry].setn ; set_length := setn[set_num].length ; FOR set_entry :=1 TO set_length DO BEGIN (* reassign each set entry to mcr group *) mcr_in_set := setn[set_num].entry[set_entry] ; mcr[mcr_in_set].group := mcr_grp ; END (* reassign each set entry to mcr group *) END (* companion entry is a set *) END ; (* move each companion entry *) (* RE-INITIALIZE COMPANION MCR GROUP *) FOR entry := 1 TO comp_grp_len DO BEGIN (* companion group sequence *) group[comp_mcr_grp].entry[entry].e_type := adr_t ; group[comp_mcr_grp].entry[entry].m_adr := -1 ; END ; (* companion group sequence *) group[comp_mcr_grp].size := 0 ; group[comp_mcr_grp].length := 0 ; group[comp_mcr_grp].weight := 0 ; group[comp_mcr_grp].blk_zero_msk := 0 ; group[comp_mcr_grp].blk_ones_msk := 0 ; END (* COPY CONTENTS OF COMPANION GROUP TO MCR GROUP *) END (* groups are merged *) END (* MCR AND COMPANION MCR ARE BOTH IN A GROUP - merge companion group with mcr group *) END END (* mcr has b_con *) END ; (* mcr sequence *) (* all set and all address constrained mcr that are not yet assigned to a group are assigned to a group *) FOR mcr_num := 0 TO last_mcr_adr DO IF ( ( mcr[mcr_num].group = 0 ) AND ( mcr[mcr_num].setn > 0 )) OR ( ( mcr[mcr_num].group = 0 ) AND ( mcr[mcr_num].setn = 0 ) AND ( mcr[mcr_num].a_con.line > 0 ) ) THEN BEGIN last_group := last_group + 1 ; put_data_into_group ( last_group , mcr_num, 3 ) ; END; (* CREATE BLOCK MASKS FOR GROUPS *) max_set_weight := 0; max_mcr_weight := 0; FOR group_num := 1 TO last_group DO IF group[group_num].size > 0 THEN BEGIN (* group exists *) grp_len := group[group_num].length ; FOR n := 1 TO grp_len DO IF group[group_num].entry[n].e_type = adr_t THEN BEGIN (* entry is a mcr *) mcr_num := group[group_num].entry[n].m_adr ; IF max_mcr_weight < mcr[mcr_num].weight THEN max_mcr_weight := mcr[mcr_num].weight; add_to_blk_msk (group_num,mcr_num) ; END (* entry is a mcr *) ELSE BEGIN (* entry is a set *) set_num := group[group_num].entry[n].setn ; IF max_set_weight < setn[set_num].weight THEN max_set_weight := setn[set_num].weight; set_length := setn[set_num].length ; FOR m := 1 TO set_length DO BEGIN (* sequence thru the set *) mcr_num := setn[set_num].entry[m] ; add_to_blk_msk (group_num,mcr_num) ; END (* sequence thru the set *) END (* entry is a set *) END; (* group exists *) (* FOR EACH GROUP , CREATE THE GROUP WEIGHT ( THE # OF POSSIBILITIES SUBTRACTED FROM 16 THEN MULTIPLIED BY 10 THEN ADDED TO THE SIZE OF THE GROUP ) *) FOR grp_num := 1 TO last_group DO BEGIN not_ones_or_zero := UNOT ( UOR ( group[grp_num].blk_ones_msk , group[grp_num].blk_zero_msk ) ); position_of_x := %b'00010000000' ; num_of_x := 0 ; FOR n := position_8 TO position_11 DO BEGIN IF UAND ( position_of_x , not_ones_or_zero ) = position_of_x THEN num_of_x := num_of_x + 1 ; position_of_x := position_of_x * 2 ; END; (* FOR N *) group[grp_num].weight := ( ( 16 - ( 2 ** num_of_x ) ) * 20 ) + max_set_weight * 10 + max_mcr_weight * 5 + group[grp_num].size ; END; (* FOR GROUP_NUM *) (* WITHIN EACH GROUP, SORT ENTRIES BY WEIGHT *) FOR grp_num := 1 TO last_group DO WITH group[grp_num] DO BEGIN IF size > 0 THEN BEGIN FOR pass := 1 TO ( length - 1 ) DO BEGIN FOR n := 1 TO ( length - 1 ) DO BEGIN next := n + 1 ; grp_entry_type := %b'00' ; IF entry[n].e_type = set_t THEN grp_entry_type := %b'10' ; IF entry[next].e_type = set_t THEN grp_entry_type := grp_entry_type + 1 ; (* SWAP THE TWO ENTRIES IF THE WEIGHT OF THE FIRST IS LESS THAN THE WEIGHT OF THE SECOND *) CASE grp_entry_type OF %b'00' : BEGIN (* ENTRY[ N ].TYPE = ADR_T AND ENTRY[ NEXT].TYPE = ADR_T *) mcr_num := entry[n].m_adr ; next_mcr := entry[next].m_adr ; IF mcr[mcr_num].weight < mcr[next_mcr].weight THEN BEGIN tmp_entry := entry[n].m_adr ; entry[n].m_adr := entry[next].m_adr ; entry[next].m_adr := tmp_entry ; END; END; %b'01' : BEGIN (* ENTRY[ N ].TYPE = ADR_T AND ENTRY[ NEXT].TYPE = SET_T *) mcr_num := entry[n].m_adr ; set_num := entry[next].setn ; IF mcr[mcr_num].weight < setn[set_num].weight THEN BEGIN tmp_entry := entry[n].m_adr ; entry[n].e_type := entry[next].e_type ; entry[n].setn := entry[next].setn ; entry[next].e_type := adr_t ; entry[next].m_adr := tmp_entry ; END; END; %b'10' : BEGIN (* ENTRY[ N ].TYPE = SET_T AND ENTRY[ NEXT].TYPE = ADR_T *) set_num := entry[n].setn ; mcr_num := entry[next].m_adr ; IF setn[set_num].weight < mcr[mcr_num].weight THEN BEGIN tmp_entry := entry[n].setn ; entry[n].e_type := entry[next].e_type ; entry[n].m_adr := entry[next].m_adr ; entry[next].e_type := set_t ; entry[next].setn := tmp_entry ; END; END; %b'11' : BEGIN (* ENTRY[ N ].TYPE = SET_T AND ENTRY[ NEXT].TYPE = SET_T *) set_num := entry[n].setn ; next_set := entry[next].setn ; IF setn[set_num].weight < setn[next_set].weight THEN BEGIN tmp_entry := entry[n].setn ; entry[n].setn := entry[next].setn ; entry[next].setn := tmp_entry ; END; END; END; (* CASE GRP_ENTRY_TYPE *) END; (* FOR N *) END ; (* FOR PASS *) END; (* IF SIZE *) END; (* WITH GRP_NUM *) END; (* END IF NOT ERROR *) END; (* END PROCEDURE COLLECT_GROUPS *) (* SORT GROUPS BY GROUP WEIGHT ONLY *) PROCEDURE sort_groups ; TYPE pointer = RECORD group_num : INTEGER ; weight : INTEGER ; END; VAR grp_priority : ARRAY[1..max_group] OF pointer ; (* grp_priority[n].group_num HOLDS THE NUMBER OF EACH GROUP AND IS INITIALIZED TO 0 *) (* grp_priority[n].weight HOLDS THE WEIGHT OF EACH GROUP AND IS INITIALIZED TO 0 *) temp_priority : pointer ; tmp_grp : ARRAY[1..max_group] OF group_record ; priority,lowest_priority,grp_num,len,grp_entry,num_of_x,n,next_grp_num,pass, next,last,count, loop_cnt,priority_num,mcr_num,set_num,set_len,set_entry,next_priority : INTEGER ; base_blk,x_mask,position : UNSIGNED ; BEGIN IF not error THEN BEGIN lowest_priority := last_group ; (* INITIALIZE GROUP_PRIORITY ARRAY *) FOR priority := 1 TO lowest_priority DO BEGIN grp_priority[priority].group_num := 0 ; grp_priority[priority].weight := 0 ; END; (* FOR PRIORITY *) (* LOAD GRP_PRIORITY ARRAY WITH GROUP#'S AND GROUP WEIGHT'S *) FOR grp_num := 1 TO last_group DO BEGIN grp_priority[grp_num].group_num := grp_num ; grp_priority[grp_num].weight := group[grp_num].weight ; END; (* SORT GRP_PRIORITY ARRAY BY WEIGHT *) FOR loop_cnt := 1 TO (lowest_priority -1 )DO BEGIN FOR priority := 1 TO (lowest_priority -1 )DO BEGIN next_priority := priority + 1; IF grp_priority[priority].weight < grp_priority[next_priority].weight THEN BEGIN (* SWAP ENTRIES IN GRP_PRIORITY ARRAY *) temp_priority.group_num := grp_priority[priority].group_num ; temp_priority.weight := grp_priority[priority].weight ; grp_priority[priority].group_num := grp_priority[next_priority].group_num ; grp_priority[priority].weight := grp_priority[next_priority].weight ; grp_priority[next_priority].group_num := temp_priority.group_num ; grp_priority[next_priority].weight := temp_priority.weight ; END; (* IF GROUP... *) END; (* FOR PRIORITY *) END; (* FOR LOOP_CNT *) (* GO THROUGH EACH GROUP#, CHECK SIZE ORDERING AND FIND GROUPS WITH SIZE = 0 *) (* IF SIZE ORDERING IS OK THEN SUBTRACT NUMBER OF GROUPS WITH SIZE = 0 *) (* FROM LAST_GROUP *) last := lowest_priority - 1 ; count := 0 ; FOR n := 1 TO last DO BEGIN next := n + 1 ; grp_num := grp_priority[n].group_num ; next_grp_num := grp_priority[next].group_num ; IF group[grp_num].weight < group[next_grp_num].weight THEN BEGIN error := true ; WRITELN (' SORT GROUPS ERROR *** '); WRITELN (' SORTING BY WEIGHT DID NOT WORK!!!'); END ELSE IF group[grp_num].size = 0 THEN BEGIN count := count + 1 ; IF ( n = last ) AND ( group[next_grp_num].size = 0 ) THEN BEGIN count := count + 1 ; END; END; (* ELSE *) END; (* FOR N *) last_group := last_group - count ; lowest_priority := last_group ; (* INITIALIZE TMP_GRP ARRAY *) FOR priority := 1 TO lowest_priority DO BEGIN tmp_grp[priority].length := 0 ; tmp_grp[priority].size := 0 ; tmp_grp[priority].weight := 0 ; tmp_grp[priority].blk_zero_msk := 0 ; tmp_grp[priority].blk_ones_msk := 0 ; FOR N := 1 TO max_group_len DO BEGIN tmp_grp[priority].entry[n].e_type := adr_t ; tmp_grp[priority].entry[n].m_adr := -1 ; END; (* FOR N *) END ; (* FOR PRIORITY *) FOR priority := 1 TO lowest_priority DO (* LOAD TMP_GRP ARRAY WITH PRIORITIZED GROUPS *) BEGIN grp_num := grp_priority[priority].group_num ; tmp_grp[priority].size := group[grp_num].size ; tmp_grp[priority].weight := group[grp_num].weight ; tmp_grp[priority].blk_zero_msk := group[grp_num].blk_zero_msk ; tmp_grp[priority].blk_ones_msk := group[grp_num].blk_ones_msk ; tmp_grp[priority].length := group[grp_num].length ; len := tmp_grp[priority].length ; FOR grp_entry := 1 TO len DO BEGIN tmp_grp[priority].entry[grp_entry].e_type := group[grp_num].entry[grp_entry].e_type ; IF tmp_grp[priority].entry[grp_entry].e_type = adr_t THEN BEGIN tmp_grp[priority].entry[grp_entry].m_adr := group[grp_num].entry[grp_entry].m_adr ; END ELSE BEGIN tmp_grp[priority].entry[grp_entry].setn := group[grp_num].entry[grp_entry].setn ; END; END; (* FOR GRP_ENTRY *) END; (* FOR PRIORITY *) (* CLEAR GROUP[N] ARRAY *) FOR grp_num := 1 TO last_group DO BEGIN priority_num := grp_num ; len := group[grp_num].length ; group[grp_num].length := 0 ; group[grp_num].size := 0 ; group[grp_num].weight := 0 ; group[grp_num].blk_zero_msk := 0 ; group[grp_num].blk_ones_msk := 0 ; FOR N := 1 TO len DO BEGIN group[grp_num].entry[n].e_type := adr_t ; group[grp_num].entry[n].m_adr := -1 ; END; (* FOR N *) (* RE-LOAD GROUP[N] ARRAY WITH TMP_GRP[N] ARRAY *) group[grp_num].length := tmp_grp[priority_num].length ; group[grp_num].size := tmp_grp[priority_num].size ; group[grp_num].weight := tmp_grp[priority_num].weight ; group[grp_num].blk_zero_msk := tmp_grp[priority_num].blk_zero_msk ; group[grp_num].blk_ones_msk := tmp_grp[priority_num].blk_ones_msk ; (* FOR EACH ENTRY IN GROUP[N] ; RE-ASSIGN MCR[N].GROUP TO NEW PRIORITIZED GROUP# *) FOR N := 1 TO group[grp_num].length DO BEGIN group[grp_num].entry[n].e_type := tmp_grp[priority_num].entry[n].e_type ; IF group[grp_num].entry[n].e_type = adr_t THEN BEGIN group[grp_num].entry[n].m_adr := tmp_grp[priority_num].entry[n].m_adr ; mcr_num := group[grp_num].entry[n].m_adr ; mcr[mcr_num].group := grp_num ; END ELSE BEGIN group[grp_num].entry[n].setn := tmp_grp[priority_num].entry[n].setn ; set_num := group[grp_num].entry[n].setn ; set_len := setn[set_num].length ; FOR set_entry := 1 TO set_len DO BEGIN mcr_num := setn[set_num].entry[set_entry] ; mcr[mcr_num].group := grp_num ; END ; (* FOR SET_ENTRY *) END; (* ELSE *) END; (* FOR N *) END; (* FOR GRP_NUM *) END; (* IF NOT ERROR *) END; (* PROCEDURE SORT GROUPS *) PROCEDURE check_pat( check_zero_msk, check_ones_msk : UNSIGNED; grp_num : INTEGER; VAR match_count: INTEGER; VAR fail:BOOLEAN) ; VAR care_count, bit_one, n, entry_num, grp_len, set_len, set_num, mcr_num : INTEGER; tmp_zero_msk, tmp_ones_msk : UNSIGNED; BEGIN { writeln('check mask ',MASK(check_zero_msk,CHECK_ones_MSK));} fail := FALSE; match_count := 0; grp_len := group[grp_num].length; FOR entry_num := 1 TO grp_len DO CASE group[grp_num].entry[entry_num].e_type OF adr_t : BEGIN (* address type *) mcr_num := group[grp_num].entry[entry_num].m_adr; IF mcr[mcr_num].a_con.line > 0 THEN BEGIN tmp_zero_msk := mcr[mcr_num].a_con.zero_msk; tmp_ones_msk := mcr[mcr_num].a_con.ones_msk; {writeln(' target ',mask(tmp_zero_msk,tmp_ones_msk));} IF (UAND(tmp_zero_msk,check_zero_msk) = check_zero_msk) AND (UAND(tmp_ones_msk,check_ones_msk) = check_ones_msk) THEN match_count := match_count + 1 ; END END; (* address type *) set_t : BEGIN (* set type *) set_num := group[grp_num].entry[entry_num].setn; set_len := setn[set_num].length; FOR n := 1 TO set_len DO BEGIN (* each set entry *) mcr_num := setn[set_num].entry[n]; IF mcr[mcr_num].a_con.line > 0 THEN BEGIN tmp_zero_msk := mcr[mcr_num].a_con.zero_msk; tmp_ones_msk := mcr[mcr_num].a_con.ones_msk; { writeln(' target ',mask(tmp_zero_msk,tmp_ones_msk));} IF (UAND(tmp_zero_msk,check_zero_msk) = check_zero_msk) AND (UAND(tmp_ones_msk,check_ones_msk) = check_ones_msk) THEN match_count := match_count + 1 ; END END (* each set entry *) END (*set type *) END; (* case *) { writeln(' number of hit ',match_count); } bit_one := 1; care_count := 0; FOR n := 1 TO 7 DO BEGIN IF UAND( UOR(check_zero_msk,check_ones_msk),bit_one) <> 0 THEN care_count := care_count + 1; bit_one := bit_one * 2; END; IF (care_count <= 0) OR (match_count <=0) THEN writeln('DRY ROT (CHECK_PAT) - CHECK PATTERN IS ',MASK(check_zero_msk, check_ones_msk),' CARE COUNT IS ',care_count:4) ELSE IF match_count > (2**(7-care_count)) THEN BEGIN fail := TRUE; { writeln(' check fail'); } END END ; (* procedure analyze *) PROCEDURE analyze( grp_num : INTEGER) ; VAR count, n, entry_num, grp_len, set_len, set_num, mcr_num : INTEGER; zero_msk, ones_msk : UNSIGNED; fail : BOOLEAN; BEGIN grp_len := group[grp_num].length; FOR entry_num := 1 TO grp_len DO CASE group[grp_num].entry[entry_num].e_type OF adr_t : BEGIN (* address type *) mcr_num := group[grp_num].entry[entry_num].m_adr; IF mcr[mcr_num].a_con.line > 0 THEN BEGIN (* have a_con *) zero_msk := UAND(mcr[mcr_num].a_con.zero_msk,%B'00001111111'); ones_msk := UAND(mcr[mcr_num].a_con.ones_msk,%B'00001111111'); IF (zero_msk <> 0) OR (ones_msk <> 0) THEN BEGIN (* got non-zero msk *) check_pat(zero_msk, ones_msk, grp_num, count, fail); IF fail THEN BEGIN (* fail *) WRITELN; WRITELN(' ******ALLOCATE ERROR - TOO MANY ADDRESS CONSTRAINTS IN GROUP'); WRITELN(' MASK ',mask(zero_msk,ones_msk),' OCCURED ',count:3,' TIMES IN GROUP ',grp_num:3); END (* fail *) END (* got non-zero msk *) END (* have a_con *) END; (* address type *) set_t : BEGIN (* set type *) set_num := group[grp_num].entry[entry_num].setn; set_len := setn[set_num].length; FOR n := 1 TO set_len DO BEGIN (* each set entry *) mcr_num := setn[set_num].entry[n]; IF mcr[mcr_num].a_con.line > 0 THEN BEGIN (* have a_con *) zero_msk := UAND(mcr[mcr_num].a_con.zero_msk,%B'00001111111'); ones_msk := UAND(mcr[mcr_num].a_con.ones_msk,%B'00001111111'); IF (zero_msk <> 0) OR (ones_msk <> 0) THEN BEGIN (* got non-zero msk *) check_pat(zero_msk, ones_msk, grp_num, count, fail); IF fail THEN BEGIN (* fail *) WRITELN; WRITELN(' ******ALLOCATE ERROR - TOO MANY ADDRESS CONSTRAINTS IN GROUP'); WRITELN(' MASK ',mask(zero_msk,ones_msk),' OCCURED ',count:3,' TIMES IN GROUP ',grp_num:3); END (* fail *) END (* han-zero mask *) END (* have a_con *) END (* each set entry *) END (*set type *) END ; (* case *) END ; (* procedure analyze *) (* ALLOCATE ATEMPTS TO STORE ALL MCRS. IT CALLS "FIT". "FIT" CALLS "STORE". "STORE" CALLS ITSELF AND DEALLOCATE. *) PROCEDURE allocate ( filename : VARYING[R] OF CHAR ); CONST dot_out = '.out' ; null_adrs = 0 ; TYPE entity_type = (mcr_ty,set_ty,grp_ty); VAR n, addres, mcr_num,set_num,adrs : INTEGER ; block_num,dummy_adrs : UNSIGNED ; first_file,second_file : VARYING[132] OF CHAR ; done,store_fail,fit_fail : BOOLEAN ; (* DEALLOCATE CAN ERASE AN MCR,A SET,OR A GROUP FROM THE PHYSICAL ARRAY. *) PROCEDURE deallocate ( val_type : entity_type ; value_num : INTEGER ; VAR addres : UNSIGNED ); CONST adrs_mask = %b'00001111111' ; VAR mcr_num,ref_mcr,set_num,len,n,m,num_of_entries : INTEGER ; adrs,dummy_adrs : UNSIGNED ; BEGIN CASE val_type OF mcr_ty : BEGIN (* WRITELN ('DEALLOCATING MCR#',value_num); *) (* FOR TEST PURPOSES *) addres := UAND ( adrs_mask, mcr[value_num].p_adr) + 1 ; adrs := mcr[value_num].p_adr ; IF (adrs < 2048) AND NOT (mcr[value_num].d_con.abs1 OR mcr[value_num].d_con.abs2) THEN BEGIN p_adr[adrs::INTEGER] := -1 ; mcr[value_num].p_adr := 2048 ; END; END; (* CASE MCR_TY *) set_ty : BEGIN (* WRITELN ('DEALLOCATING SET#',value_num); *) (* FOR TEST PURPOSES *) ref_mcr := setn[value_num].entry[1] ; addres := UAND ( adrs_mask,mcr[ref_mcr].p_adr) + 1 ; len := setn[value_num].length ; FOR n := 1 TO len DO BEGIN mcr_num := setn[value_num].entry[n] ; adrs := mcr[mcr_num].p_adr ; IF (adrs < 2048) AND NOT (mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2) THEN IF adrs < 2048 THEN BEGIN mcr[mcr_num].p_adr := 2048 ; p_adr[adrs::INTEGER] := -1 ; END; END; (* FOR N *) END; (* CASE SET_TY *) grp_ty : BEGIN (* WRITELN ('DEALLOCATING GROUP#',value_num); *) (* FOR TEST PURPOSES *) num_of_entries := group[value_num].length ; FOR m := 1 TO num_of_entries DO BEGIN IF group[value_num].entry[m].e_type = adr_t THEN BEGIN mcr_num := group[value_num].entry[m].m_adr ; deallocate (mcr_ty,mcr_num,dummy_adrs); END ELSE BEGIN set_num := group[value_num].entry[m].setn ; if not setn[set_num].abs then deallocate (set_ty,set_num,dummy_adrs); END; END; (* FOR M *) END; (* CASE GRP_TY *) END; (* CASE VAL_TYPE *) END; (* PROCEDURE DEALLOCATE *) (* STORE ATTEMPTS TO A ALLOCATE AN MCR OR A SET . WHEN ALLOCATING A SET, IT CALLS ITSELF TO STORE THE FIRST ITEM IN THE SET. IF AN ITEM IN A SET WON'T FIT THEN STORE CALLS DEALLOCATE THEN CALLS ITSELF AGAIN . ( RECURSIVE UNTIL THE SET FITS OR THE ADDRESS BECOMES 128 ) *) PROCEDURE store ( entry_type : entity_type; entry_num : INTEGER ; block,adrs_val : UNSIGNED; VAR fail : BOOLEAN ); VAR mcr_num,mcr_val,ref_mcr,set_num,set_entry,set_len,n : INTEGER ; adrs,ref_adrs,block_adrs,zero,ones,mcr_delta,start_adrs,set_adrs,temp_adrs,temp_delta : UNSIGNED ; done,set_store_fail : BOOLEAN ; BEGIN block_adrs := block * 128 ; CASE entry_type OF mcr_ty : BEGIN (* WRITELN ('STORING MCR#',entry_num); *) (* FOR TEST PURPOSES *) mcr_val := entry_num ; IF (mcr[mcr_val].p_adr < 2048 ) AND NOT (mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2) THEN BEGIN error := true ; WRITELN ('MCR# ',mcr_val,' HAS ALREADY BEEN PLACED'); END ELSE BEGIN done := false ; n := 0 ; IF adrs_val > 0 THEN IF adrs_val < 128 THEN n := adrs_val::INTEGER ELSE fail := true ; IF mcr[mcr_val].a_con.line > 0 THEN BEGIN ones := mcr[mcr_val].a_con.ones_msk ; zero := mcr[mcr_val].a_con.zero_msk ; WHILE (n < 128 ) AND (not done ) DO BEGIN adrs := block_adrs + n ; IF (UAND( adrs,ones) = ones) AND (UAND(UNOT(adrs),zero) = zero) AND (mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2 OR (p_adr[adrs::INTEGER] = -1 ) ) AND NOT ( mcr[mcr_val].d_con.abs1 AND (mcr[mcr_val].p_adr <> adrs) ) AND NOT ( mcr[mcr_val].d_con.abs2 AND (mcr[mcr_val].p_adr <> adrs) ) THEN BEGIN p_adr[adrs::INTEGER] := mcr_val ; mcr[mcr_val].p_adr := adrs ; done := true ; END; (* IF UAND.. *) n := n + 1 ; END; (* WHILE *) IF not done THEN fail := true ; END ELSE BEGIN WHILE (not done) AND (n < 128 ) DO BEGIN adrs := block_adrs + n ; IF (mcr[mcr_val].d_con.abs1 OR mcr[mcr_val].d_con.abs2 OR (p_adr[adrs::INTEGER] = -1 ) ) AND NOT ( mcr[mcr_val].d_con.abs1 AND (mcr[mcr_val].p_adr <> adrs) ) AND NOT ( mcr[mcr_val].d_con.abs2 AND (mcr[mcr_val].p_adr <> adrs) ) THEN BEGIN p_adr[adrs::INTEGER] := mcr_val ; mcr[mcr_val].p_adr := adrs ; done := true ; END; (* IF P_ADR.. *) n := n + 1 ; END; (* WHILE *) IF not done THEN BEGIN fail := true ; END; END; (* IF MCR HAS A_CON *) END; (* IF MCR ALREADY PLACED *) END; (* CASE MCR_TY *) set_ty : BEGIN (* WRITELN ('STORING SET#',entry_num); *) (* FOR TEST PURPOSES *) done := false ; set_store_fail := false ; start_adrs := 0 ; IF adrs_val > 0 THEN IF adrs_val < 128 THEN BEGIN start_adrs := adrs_val ; END ELSE BEGIN (* BLOCK BOUNDS CROSSED *) fail := true ; END; set_num := entry_num ; set_len := setn[set_num].length ; ref_mcr := setn[set_num].entry[1] ; set_entry := 1 ; WHILE (set_entry <= set_len) AND ( not fail ) AND ( not done ) DO BEGIN IF set_entry = 1 THEN BEGIN store (mcr_ty,ref_mcr,block,start_adrs,set_store_fail ); ref_adrs := mcr[ref_mcr].p_adr ; IF set_store_fail THEN BEGIN fail := true ; END; END ELSE BEGIN mcr_num := setn[set_num].entry[set_entry] ; IF mcr[mcr_num].d_con.ucall1 THEN BEGIN temp_adrs := mcr[mcr[mcr_num].d_con.m_adr1].p_adr; temp_delta := mcr[mcr_num].d_con.delta1; IF temp_adrs = -1 THEN WRITELN ('DRY ROT (STORE) - UNASSIGNED COMPANION UCALL ADDRESS, MCR=', HEX(mcr_num,3), ', COMP=', HEX(mcr[mcr_num].d_con.m_adr1,3)); adrs := UOR ( UAND (temp_adrs, %X'FFFFFFF0'), UINT ( (temp_adrs + temp_delta) MOD 16) ); END ELSE IF mcr[mcr_num].d_con.ucall2 THEN BEGIN temp_adrs := mcr[mcr[mcr_num].d_con.m_adr2].p_adr; temp_delta := mcr[mcr_num].d_con.delta2; IF temp_adrs = -1 THEN WRITELN ('DRY ROT (STORE) - UNASSIGNED COMPANION UCALL ADDRESS, MCR=', HEX(mcr_num,3), ', COMP=', HEX(mcr[mcr_num].d_con.m_adr1,3)); adrs := UOR ( UAND (temp_adrs, %X'FFFFFFF0'), UINT ( (temp_adrs + temp_delta) MOD 16) ); END ELSE BEGIN mcr_delta := setn[set_num].delta[set_entry] ; adrs := ref_adrs + mcr_delta ; END; IF adrs < (( block + 1 ) * 128 ) THEN (* CHECK TO SEE IF ADRS HAS CROSSED BLOCK BOUNDS *) BEGIN IF (p_adr[adrs::INTEGER] = -1) OR mcr[mcr_num].d_con.abs1 OR mcr[mcr_num].d_con.abs2 THEN BEGIN (* possible address *) IF mcr[mcr_num].a_con.line > 0 THEN BEGIN (* address contraint *) ones := mcr[mcr_num].a_con.ones_msk ; zero := mcr[mcr_num].a_con.zero_msk ; IF (UAND( adrs,ones) = ones) AND (UAND(UNOT(adrs),zero) = zero) AND NOT ( mcr[mcr_num].d_con.abs1 AND (mcr[mcr_num].p_adr <> adrs) ) AND NOT ( mcr[mcr_num].d_con.abs2 AND (mcr[mcr_num].p_adr <> adrs) ) THEN BEGIN (* assign location *) p_adr[adrs::INTEGER] := mcr_num ; mcr[mcr_num].p_adr := adrs ; END (* assign location *) ELSE BEGIN deallocate (set_ty,set_num,set_adrs); (* WRITELN ('ACON ** SET ADDRESS =',set_adrs,' BLOCK# =', block ); *) IF NOT setn[set_num].abs THEN store (set_ty,set_num,block,set_adrs,set_store_fail); IF set_store_fail THEN fail := true ELSE done := true ; END; END (* address contraint *) ELSE BEGIN (* no address contraint *) IF NOT ( mcr[mcr_num].d_con.abs1 AND (mcr[mcr_num].p_adr <> adrs) ) AND NOT ( mcr[mcr_num].d_con.abs2 AND (mcr[mcr_num].p_adr <> adrs) ) THEN BEGIN p_adr[adrs::INTEGER] := mcr_num ; mcr[mcr_num].p_adr := adrs ; END ELSE fail := TRUE END (* no address contraint *) END (* possible address *) ELSE BEGIN deallocate (set_ty,set_num,set_adrs); (* WRITELN ('******** SET ADDRESS =',set_adrs,' BLOCK# =', block ); *) store (set_ty,set_num,block,set_adrs,set_store_fail); IF set_store_fail THEN BEGIN fail := true ; END ELSE BEGIN done := true ; END; END; END (* IF ADRS .. *) ELSE BEGIN fail := true ; END; END ; (* ELSE *) set_entry := set_entry + 1 ; END; (* WHILE SET_ENTRY *) END ; (* CASE SET_TY *) END; (* CASE ENTRY_TYPE *) END ; (* PROCEDURE STORE *) (* FIT ATTEMPTS TO ALLOCATE ALL GROUPS. IT CALLS STORE FOR EACH ITEM IN A GROUP. IF ANY ITEM IN A GROUP WON'T ALLOCATE THEN FIT CALLS DEALLOCATE AND INCREMENTS THE BLOCK NUMBER SO IT CAN TRY AGAIN. *) PROCEDURE fit ( grp_val : INTEGER ; VAR grp_fit_fail : BOOLEAN ); CONST null_adrs = 0 ; VAR n,mcr_num,set_num,entry,num_of_entries : INTEGER ; block_num, dummy_address, base_adr : UNSIGNED ; backup_done, done,group_fail,store_fail,dummy_fail : BOOLEAN ; BEGIN IF grp_val > 1 THEN BEGIN n := grp_val - 1 ; fit (n,dummy_fail) END; done := false ; block_num := group[grp_val].blk_ones_msk DIV 128 ; num_of_entries := group[grp_val].length ; WHILE (not done ) AND (block_num < 16 ) DO BEGIN (* try each block *) group_fail := false ; store_fail := false ; entry := 1 ; base_adr := block_num * 128 ; IF (UAND(base_adr,group[grp_val].blk_ones_msk) = group[grp_val].blk_ones_msk) AND (UAND( UNOT(base_adr),group[grp_val].blk_zero_msk) = group[grp_val].blk_zero_msk ) THEN WHILE (entry <= num_of_entries) AND (not group_fail) DO BEGIN (* store each entry *) IF group[grp_val].entry[entry].e_type = adr_t THEN BEGIN mcr_num := group[grp_val].entry[entry].m_adr ; store (mcr_ty,mcr_num,block_num,null_adrs,store_fail); END ELSE BEGIN set_num := group[grp_val].entry[entry].setn ; IF NOT setn[set_num].abs THEN store (set_ty,set_num,block_num,null_adrs,store_fail); END; IF store_fail THEN BEGIN (* store fail *) deallocate( grp_ty, grp_val, dummy_address); group_fail := true ; END (* store fail *) ELSE entry := entry + 1 ; END (* store each entry *) ELSE BEGIN group_fail := TRUE; END; IF entry > num_of_entries THEN BEGIN done := true ; end; IF group_fail THEN block_num := block_num + 1 ; END; (* try each block *) IF ( block_num > 15 ) AND ( group_fail ) THEN BEGIN WRITELN ('ALLOCATE ERROR*** CANNOT FIT GROUP#',grp_val); dump_block(fil_nam, grp_val, entry); analyze(grp_val); grp_fit_fail := true ; END; END; (* PROCEDURE FIT *) BEGIN (* BODY OF ALLOCATE *) IF not error THEN BEGIN (* groups made *) fit_fail := false ; (* ALLOCATE ALL GROUPS. *) fit (last_group,fit_fail) ; (* ALLOCATE ALL MCRS THAT ARE NOT IN A GROUP *) addres := -1; FOR mcr_num := 0 TO last_mcr_adr DO IF ( mcr[mcr_num].p_adr = 2048 ) AND ( mcr[mcr_num].group = 0 ) THEN BEGIN (* found floating mcr *) done := FALSE; float_count := float_count + 1 ; REPEAT BEGIN (* look for free adr *) addres := addres + 1; IF p_adr[addres] = -1 THEN done := TRUE; END (* look for free adr *) UNTIL done OR (addres > max_adr); IF NOT done THEN WRITELN ('ALLOCATE ERROR*** MCR#',mcr_num,'CANNOT BE STORED') ELSE BEGIN (* found free adr *) p_adr[addres] := mcr_num; mcr[mcr_num].p_adr := addres END (* found free adr *) END (* found floating mcr *) END (* groups made *) END; (* BODY OF ALLOCATE *) (* VERIFY WILL RE-READ THE ".CON" FILE AND COMPARE THE PHYSICAL PLACEMENT OF THE MCRS WITH THEIR PARTICULAR CONSTRAINTS. IT ALSO CHECKS FOR DUPLICATE ADDRESSING . *) PROCEDURE verify ( filename : VARYING[S] OF CHAR ); CONST blk_msk = %b'11110000000' ; dot_con = '.con' ; VAR adrs_array : ARRAY[0..max_adr] OF UNSIGNED ; mcr_array : ARRAY[0..max_adr] OF INTEGER ; n,mcr_num,addres,line_num,col3,col4,comp_mcr : INTEGER ; zero_msk,ones_msk,phys_adrs,mcr_blk,comp_blk, abs_adrs,mcr_adrs,comp_adrs,mcr_delta,rad3_adrs,col5,comp_delta : UNSIGNED ; con_fil_nam,time_date : VARYING[132] OF CHAR ; con_field : CHAR ; BEGIN IF NOT error THEN BEGIN FOR n := 0 TO max_adr DO BEGIN adrs_array[n] := -1 ; mcr_array[n] := 2048 ; END; (* FIND ALL DUPLICATE MCRS ( MCRS THAT OCCUPY TWO ADDRESSES ) *) FOR addres := 0 TO max_adr DO BEGIN mcr_num := p_adr[addres] ; IF ( mcr_num > -1 ) AND ( mcr_num < 2048 ) THEN IF adrs_array[mcr_num] > -1 THEN BEGIN WRITELN ; WRITELN ('DUPLICATE MCR IN P_ADR '); WRITELN (' MCR ',mcr_num,'(',HEX(mcr_num,3),') IS USED AT ADDRESS',addres,'(',HEX(addres,3),') and', adrs_array[mcr_num],'(',HEX(adrs_array[mcr_num],3),')' ); END ELSE BEGIN adrs_array[mcr_num] := addres :: UNSIGNED ; END; END; (* FOR N *) (* FIND ALL DUPLICATE ADDRESSES ( ADDRESS WITH TWO MCRS POINTING TO IT ) *) FOR mcr_num := 0 TO last_mcr_adr DO BEGIN addres := mcr[mcr_num].p_adr :: INTEGER ; IF addres < 2048 THEN IF mcr_array[addres] < 2048 THEN BEGIN WRITELN ; WRITELN ('DUPLICATE ADDRESS '); WRITELN (' ADDRESS ',addres,'(',HEX(addres,3),') IS USED IN MCR',mcr_num,'(',HEX(mcr_num,3), ') AND',mcr_array[addres],'(',HEX(mcr_array[addres],3),')' ); END ELSE BEGIN mcr_array[addres] := mcr_num ; END ELSE BEGIN WRITELN ; WRITELN ('UNASSIGNED MCR '); WRITELN (' MCR',mcr_num,'(',HEX(mcr_num,3),') HAS NOT BEEN ALLOCATED!!'); END; END; (* FOR N *) (* READ CONSTRAINT FILE AND COMPARE PHYSICAL PLACEMENT OF MCR(S) *) con_fil_nam := filename + dot_con ; (* WITH CONSTRAINTS IN CONSTRAINT FILE *) OPEN ( con_file,con_fil_nam,HISTORY:=READONLY ); RESET ( con_file ); READLN ( con_file,time_date ) ; WHILE NOT EOF( con_file ) DO BEGIN READLN ( con_file,con_field,line_num,col3,col4,col5 ); CASE con_field OF 'A' : BEGIN mcr_num := col4 ; rad3_adrs := col5 ; rad3_to_bin ( rad3_adrs ,zero_msk,ones_msk ); phys_adrs := mcr[mcr_num].p_adr ; IF (UAND( phys_adrs, ones_msk ) <> ones_msk ) OR (UAND( UNOT( phys_adrs ),zero_msk ) <> zero_msk ) THEN BEGIN WRITELN ; WRITELN ('VERIFY ERROR '); WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE '); WRITELN (con_field,' ',line_num,' ',col3,' ',col4,' ',col5 ); END; END; 'B' : BEGIN mcr_num := col3 ; comp_mcr := col4 ; mcr_blk := UAND ( blk_msk , mcr[mcr_num].p_adr ); comp_blk := UAND ( blk_msk , mcr[comp_mcr].p_adr ); IF mcr_blk <> comp_blk THEN BEGIN WRITELN ; WRITELN ('VERIFY ERROR '); WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE '); WRITELN (con_field,' ',line_num,' ',col3,' ',col4,' ',col5 ); END; END; 'D' : BEGIN IF col3 = -1 THEN BEGIN mcr_num := col4 ; abs_adrs := col5 ; phys_adrs := mcr[mcr_num].p_adr ; IF abs_adrs <> phys_adrs THEN BEGIN WRITELN ; WRITELN ('VERIFY ERROR '); WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE '); WRITELN (con_field,' ',line_num,' ',col3,' ',col4,' ',col5 ); END; END ELSE BEGIN mcr_num := col4 ; comp_mcr := col3 ; mcr_delta := col5 ; mcr_adrs := mcr[mcr_num].p_adr ; comp_adrs := mcr[comp_mcr].p_adr ; mcr_blk := UAND ( blk_msk , mcr[mcr_num].p_adr ); comp_blk := UAND ( blk_msk , mcr[comp_mcr].p_adr ); IF mcr_delta > CALL_DELTA THEN { CALL constraint? } BEGIN { Yes, do only 4-bit add } mcr_delta := mcr_delta - CALL_DELTA; comp_delta := UOR ( UAND (comp_adrs, %X'FFFFFFF0'), UINT ( (comp_adrs + mcr_delta) MOD 16) ); END ELSE comp_delta := comp_adrs + mcr_delta; IF (comp_delta <> mcr_adrs ) OR ( mcr_blk <> comp_blk ) THEN BEGIN WRITELN ; WRITELN ('VERIFY ERROR '); WRITELN (' PLACEMENT OF MCR ',mcr_num,'(',HEX(mcr_num,3),') DOES NOT MATCH CONSTRAINT IN CONSTRAINT FILE '); WRITELN (con_field,' ',line_num,' ',col3,' ',col4,' ',col5 ); END; END; (* ELSE *) END; OTHERWISE BEGIN WRITELN ; WRITELN ('VERIFY ERROR ' ); WRITELN (' CONSTRAINT FIELD IN CONSTRAINT FILE IS NOT A,B,OR D '); WRITELN (con_field,' ',line_num,' ',col3,' ',col4,' ',col5 ); END; END; (* CASE *) END; (* WHILE NOT EOF *) CLOSE ( con_file ); END; (* IF NOT ERROR *) END; (* PROCEDURE VERIFY *) (* ALLOC_OUTPUT WRITES THE FINAL OUTPUT FILE (.BDR) TO BE USED BY ALLOC3 *) PROCEDURE alloc_output ( filename : VARYING[o] OF CHAR ); CONST dot_bdr = '.BDR' ; VAR mcr_num,line_num,page_num : INTEGER ; adrs : UNSIGNED ; out_fil_nam : VARYING[132] OF CHAR ; BEGIN IF not error THEN BEGIN out_fil_nam := filename + dot_bdr ; OPEN (alloc_file,out_fil_nam,HISTORY := NEW ); REWRITE (alloc_file ); WRITELN (alloc_file,adr_stamp ); FOR mcr_num := 0 TO last_mcr_adr DO BEGIN line_num := mcr[mcr_num].line ; page_num := mcr[mcr_num].page ; adrs := mcr[mcr_num].p_adr ; WRITELN (alloc_file,' ',mcr_num:4,' ',line_num:5,' ',page_num:3,' ',adrs:4 ); END; (* FOR MCR_NUM *) CLOSE(alloc_file); END; (* IF NOT ERROR *) END; (* PROCEDURE ALLOC_OUTPUT *) (* WRITES OUT THE COMPLETE DATA STRUCTURE SO THAT ERRORS CAN BE TRACED *) PROCEDURE dump ( filename : VARYING[T] OF CHAR ); CONST dot_dmp = '.dmp' ; VAR last_p_adr, final, n, mcr_num,set_num,set_entry,grp_num,grp_entry :INTEGER ; dmp_fil_nam : VARYING[132] OF CHAR ; BEGIN last_p_adr:= max_adr + 1; REPEAT last_p_adr := last_p_adr-1 UNTIL (last_p_adr <= 0) OR (p_adr[last_p_adr] <> -1); dmp_fil_nam := filename + dot_dmp ; OPEN (alloc_file ,dmp_fil_nam,HISTORY:= NEW ); REWRITE (alloc_file ); WRITELN; WRITELN (alloc_file,' LAST MCR =',last_mcr_adr:4,'(',HEX(last_mcr_adr,3),')' ); WRITELN (' LAST MCR ADDRESS =',last_mcr_adr:4,'(',HEX(last_mcr_adr,3),')' ); IF ERROR THEN WRITELN(alloc_file,'NO ADR ALLOCATED') ELSE WRITELN(alloc_file,' LAST ADR ASSIGNED =', last_p_adr:4,'(',HEX(last_p_adr,3),')'); IF ERROR THEN WRITELN(' NO ADR ALLOCATED') ELSE WRITELN(' LAST ADR ALLOCATED =', last_p_adr:4,'(',HEX(last_p_adr,3),')'); WRITELN (alloc_file,' NUMBER OF SETS =',last_set:4 ); WRITELN (alloc_file,' NUMBER OF GROUPS =',last_group:4 ); WRITELN (alloc_file,' NUMBER OF ADDRESS CONSTRAINTS = ',a_con_count:4); WRITELN (alloc_file,' NUMBER OF BLOCK CONSTRAINTS = ',b_con_count:4); WRITELN (alloc_file,' NUMBER OF DELTA CONSTRAINTS = ',d_con_count:4); WRITELN (alloc_file,'NUMBER OF ABSOLUTE ASSIGNMENTS = ',abs_count:4); WRITELN (alloc_file,' NUMBER OF UNCONSTRAINTED MCRS = ',float_count:4); FOR mcr_num := 0 TO last_mcr_adr DO BEGIN WRITELN (alloc_file,' ') ; WRITE(alloc_file,'MCR ',mcr_num:4,'(',HEX(MCR_NUM,3),') LINE ',mcr[mcr_num].line:4,'/',mcr[mcr_num].page:5, ' WT ',mcr[mcr_num].weight:4,' ADR '); IF mcr[mcr_num].p_adr = 2048 THEN WRITE(alloc_file,'unallocated') else WRITE(alloc_file,mcr[mcr_num].p_adr:4,'(',HEX(mcr[mcr_num].p_adr,3),')'); IF mcr[mcr_num].group > 0 THEN WRITE (alloc_file,' Group ',mcr[mcr_num].group:4); IF mcr[mcr_num].setn > 0 THEN WRITE(alloc_file,' SET ',mcr[mcr_num].setn:4); WRITELN (alloc_file,' ') ; IF mcr[mcr_num].a_con.line > 0 THEN WRITELN(alloc_file,' A_CON LINE ',mcr[mcr_num].a_con.line:4, ' MASK ',mask(mcr[mcr_num].a_con.zero_msk,mcr[mcr_num].a_con.ones_msk)); IF mcr[mcr_num].b_con.line > 0 THEN WRITELN (alloc_file,' B_CON LINE ',mcr[mcr_num].b_con.line:4, ' M_ADR ',mcr[mcr_num].b_con.m_adr:4,'(',HEX(mcr[mcr_num].b_con.m_adr,3),')' ); IF mcr[mcr_num].d_con.line1 > 0 THEN BEGIN IF mcr[mcr_num].d_con.ucall1 THEN WRITE (alloc_file,' C_CON1 LINE ',mcr[mcr_num].d_con.line1:4) ELSE WRITE (alloc_file,' D_CON1 LINE ',mcr[mcr_num].d_con.line1:4); IF mcr[mcr_num].d_con.abs1 THEN WRITELN(alloc_file,' absolute address @ ',mcr[mcr_num].d_con.m_adr1:4, '(',HEX(mcr[mcr_num].d_con.m_adr1,3),')') ELSE WRITELN (alloc_file,' base address ',mcr[mcr_num].d_con.m_adr1:4,'(', HEX(mcr[mcr_num].d_con.m_adr1,3),') delta ',mcr[mcr_num].d_con.delta1:4) END; IF mcr[mcr_num].d_con.line2 > 0 THEN BEGIN IF mcr[mcr_num].d_con.ucall2 THEN WRITE(alloc_file,' C_CON2 LINE ',mcr[mcr_num].d_con.line2:4) ELSE WRITE(alloc_file,' D_CON2 LINE ',mcr[mcr_num].d_con.line2:4); IF mcr[mcr_num].d_con.abs2 THEN WRITELN (alloc_file,' absolute address @ ',mcr[mcr_num].d_con.m_adr2:4, '(',HEX(mcr[mcr_num].d_con.m_adr2,3),')') ELSE WRITELN (alloc_file,' base address ',mcr[mcr_num].d_con.m_adr2:4,'(', HEX(mcr[mcr_num].d_con.m_adr2,3),') delta ',mcr[mcr_num].d_con.delta2:4) END END; PAGE(alloc_file); FOR set_num := 1 TO last_set DO BEGIN WRITELN (alloc_file,' '); WRITE (alloc_file,'SET ',set_num:2,' LENGTH ',setn[set_num].length:2,' WEIGHT ',setn[set_num].weight:4); IF setn[set_num].abs THEN WRITELN(alloc_file, ' absolute assignment ') ELSE WRITELN(alloc_file, ' '); WRITELN (alloc_file,' MCR DELTA ADR'); FOR set_entry := 1 TO setn[set_num].length DO BEGIN WRITE (alloc_file,' ',setn[set_num].entry[set_entry]:4, '(',HEX(setn[set_num].entry[set_entry],3),') ',setn[set_num].delta[set_entry]:4); IF mcr[setn[set_num].entry[set_entry]].p_adr < 2048 THEN WRITELN(alloc_file,' ',mcr[setn[set_num].entry[set_entry]].p_adr:4,'(', HEX(mcr[setn[set_num].entry[set_entry]].p_adr,3),')') ELSE WRITELN(alloc_file,' unallocated') END END; PAGE(alloc_file); FOR grp_num := 1 TO last_group DO BEGIN (* each group *) WRITELN (alloc_file,' '); WRITELN (alloc_file,'GROUP ',grp_num:1,' LENGTH ',group[grp_num].length:3,' SIZE ',group[grp_num].size:3, ' WEIGHT ',group[grp_num].weight:5,' mask ', mask(group[grp_num].blk_zero_msk, group[grp_num].blk_ones_msk)); WRITELN (alloc_file,' TYPE ENTRY WEIGHT ADR'); FOR grp_entry := 1 TO group[grp_num].length DO BEGIN (* each group entry *) IF group[grp_num].entry[grp_entry].e_type = adr_t THEN BEGIN (* mcr type *) WRITE (alloc_file,' mcr ',group[grp_num].entry[grp_entry].m_adr:4, '(',HEX(group[grp_num].entry[grp_entry].m_adr,3),') ', mcr[group[grp_num].entry[grp_entry].m_adr].weight:4,' '); IF mcr[group[grp_num].entry[grp_entry].m_adr].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned') ELSE WRITELN(alloc_file, mcr[group[grp_num].entry[grp_entry].m_adr].p_adr:4,'(', HEX(mcr[group[grp_num].entry[grp_entry].m_adr].p_adr,3),')'); END (* mcr type *) ELSE BEGIN (* set type *) WRITE (alloc_file,' set ',group[grp_num].entry[grp_entry].setn:4, ' ',setn[group[grp_num].entry[grp_entry].setn].weight:4,' '); IF mcr[setn[group[grp_num].entry[grp_entry].setn].entry[1]].p_adr = 2048 THEN WRITELN(alloc_file,'unassigned') ELSE WRITELN(alloc_file,mcr[setn[group[grp_num].entry[grp_entry].setn].entry[1]].p_adr:4,'(', HEX(mcr[setn[group[grp_num].entry[grp_entry].setn].entry[1]].p_adr,3),')'); END (* set type *) END (* each group entry *) END; (* each group *) PAGE( alloc_file); IF last_p_adr < last_mcr_adr THEN final := last_mcr_adr ELSE final := last_p_adr; WRITELN(alloc_file,' MCR TO ADR ADR TO MCR'); FOR n := 0 TO final DO BEGIN (* main loop *) IF n <= last_mcr_adr THEN BEGIN WRITE(alloc_file,' ',n:4,'(',HEX(n,3),') '); IF mcr[n].p_adr = 2048 THEN WRITE(alloc_file,'unallocated ') ELSE WRITE(alloc_file,mcr[n].p_adr:4,'(',HEX(mcr[n].p_adr,3),') ') END ELSE WRITE(alloc_file,' '); IF n <= last_p_adr THEN BEGIN WRITE(alloc_file,n:4,'(',HEX(n,3),') '); IF p_adr[n] = -1 THEN WRITELN(alloc_file,'unassigned') ELSE WRITELN(alloc_file,p_adr[n]:4,'(',HEX(p_adr[n],3),')') END ELSE WRITELN(alloc_file,' '); END; (* main loop *) WRITELN (alloc_file,' '); WRITELN (alloc_file,'END OF FILE '); CLOSE (alloc_file); (* END; *) (* IF ERROR *) END; (* PROCEDURE DUMP *) PROCEDURE FIND ; VAR N : INTEGER ; BEGIN FOR N := 0 TO LAST_MCR_ADR DO BEGIN IF ( MCR[N].SETN > 0 ) AND (MCR[N].GROUP = 0 ) THEN BEGIN WRITELN ('SET # ',MCR[N].SETN,' IS NOT IN A GROUP' ); END; (* IF *) END; (* FOR N *) END; (* PROC *) (* BODY OF ALLOC2 *) BEGIN error := false ; init; writeln; writeln('Rigel Pass 2 Allocator V1.06 27-Mar-86'); get_filename_and_debug ( fil_nam ); WRITELN; WRITELN('Loading contraints'); load_data( fil_nam ); WRITELN('Collecting sets'); collect_sets ; WRITELN('Collecting groups'); collect_groups ; WRITELN('Sorting Groups'); sort_groups ; WRITELN('Allocating'); allocate ( fil_nam ); WRITELN('Verifying'); verify ( fil_nam ) ; alloc_output ( fil_nam ); WRITELN('Writing .DMP file'); dump ( fil_nam ); END.