!	SYMBOLIZE_MACRO_CODE.TPU
!
!	Table of Contents as of 24-Apr-1991
!
!	Procedure name			Page	Description
!	--------------			----	------------
!
!	symbolize_buffer_contents	   3	Symbolize register information
!	analyse_comment			   4	Analyse a comment
!	symbolize_instruction		   5	Symbolize one instruction
!	decompose_offset		   6	Decompose offset spec
!	find_struct_type		   7	Find structure  for a register
!	decode_param_offset		   8	Decode parameter offset
!	decode_pos			   9	Decode bit position
!	decode_mask			  10	Decode bit mask
!	decode_size			  11	Decode field size
!	decode_register_mask		  12	Decode register mask
!	decode_prv_reg			  13	Decode priv register
!	decode_dpt_store		  14	Decode DPT_STORE macro
!	decode_definition		  15	Decode with user definition
!	symbolize_offset		  16	Symbolize register offset
!	symbolize_constant		  17	Symbolize constant
!	symbolize_bit_pos		  18	Symbolize bit position
!	symbolize_bit_mask		  19	Symbolize bit mask
!	symbolize_field_size		  20	Symbolize field size
!	find_buffer			  21	Find a buffer giving name
!	read_definition			  22	Read macro definitions
!	set_register_type		  23	Set register current type
!	get_register_type		  24	Get register current type
!	write_list			  25	Write line/buffer to list file
!	write_comment			  26	Write a line and a comment
!	find_split_point		  27	Find split point
!	detabulate_line			  28	Convert tabs to spaces
!	dec_to_hexa			  29	Decimal int -> hexa string
!	dec_to_hexa_1			  30	Decimal int -> hexa w/o lead "0"
!	dec_to_binary			  31	Decimal int -> binary string
!	hexa_to_dec			  32	Hexa -> decimal int
!	octal_to_dec			  33	Octal -> decimal int
!	binary_to_dec			  34	Binary -> decimal int
!	compress_buffer			  35	Compress spaces/tabs in a buffer
!	echo_buffer			  36	Write a buffer to sys$output
!	exec_command			  37	Execute a DCL command

!									Page 1
!
!	This TPU file is a tool used to analyze deassembled macro code.
!
!	Run it using the command :
!
!	   $ EDIT/TPU/NOSECT/NODISPL/COMMAND=<this_file> source_code[.MAR]
!
!	Output is written to a .LIS file, in the default directory.
!
!	It try to symbolize information using register usage (ie convert
!	120(R5) as UCB$W_STS if R5 point a UCB), fields, flags and masks
!	contents (ie #4 as UCB$V_ONLINE).
!
!	The source code is scanned line by line, to compose a complete,
!	valid instruction. This instruction is then analysed and each element
!	(label, instruction, parameters) is isolated. The symbolization is
!	tried to the following elements :
!
!		. each parameter is scanned to locale "offset(register)"
!		  specification. If found, symbolization using register
!		  type is tried (see bellow for more information on register
!		  type definition).
!
!		. for bit or mask related instructions (BBC, BITL, EXTZV ...)
!		  bit position, bit mask, field size and/or field position
!		  are symbolized.
!
!		. for MFPR, MTPR instructions, priviledgied register is
!		  symbolized.
!
!		. register masks (PUSHR, POPR, .ENTRY) are symbolized.
!
!		. DPT_STORE macro is also symbolized.
!
!	After that, the line is retabulated and written to list file.
!
!	Register type definition :
!
!	To help this procedure to find register type, you can add comments
!	in source file to specify the register type. This comment must have
!	the following format :
!
!		; register_name => [structure_name]
!		; R5 => UCB
!
!	Where :
!
!		. register_name is R0 to R11,AP,FP,SP,PC or ALL.
!
!		. structure_name is the name of the structure pointed by the
!		  register. The procedure try to locate in SYS$LIBRARY:LIB.MLB,
!		  SYS$LIBRARY:STARLET.MLB and SYS$DISK:[]USER_DEFINITIONS.MLB
!		  a definition nammed "$<structure_name>DEF".
!		  To reset register type, omit the structure name (ie 
!		  "; R5 =>"). You can think it's a good idea to reset all
!		  registers (using "; ALL =>") at the beginning of a new
!		  routine.
!
!	Parameter type definition :
!
!	You can also force a parameter to be symbolized using specific type
!	(ie "MOVL #44,R0 symbolized as "MOVL #SS$_NORMAL,R0"). To do that, you
!	can create a comment just before (or at end of) the concerned line,
!	formatted as :
!
!		; parameter_name => format structure_type [related_field]
!		; P1 => CONSTANT SS : symbolize constant using $ssdef
!		; P3 => MASK UCB UCB$STS : symbolize bit mask related to UCB$STS
!		; P4 => CONSTANT DC $DC_ : symbolize $DC_ constant using $DCDEF
!		; P4 => CONSTANT DC $DT_ : symbolize $DT_ constant using $DCDEF
!
!	Where :
!
!		. parameter_name is P1 to Pn.
!
!		. format is :
!			- "CONSTANT" for xx$_name,xx$C_name or xx$K_name fields.
!			- "MASK" for xx$M_name fields.
!			- "POSITION" for xx$V_name fields.
!			- "SIZE" for xx$S_name fields.
!			- "OFFSET" for xx$B_name, xx$W_name, xx$L_name ...
!
!		. structure_type is is the name of the structure used to
!		  symbolize the parameter.
!
!		. related_field is the name of the relevant field used for
!		  symbolization.
!
!	Note : due to the basic work made in parameter evaluation, some
!	unexpected results can be found when trying to analyse ascii (.ASCI?, 
!	^A/.../) specifications.
!
!	Original version on 9-Apr-1991 by Francois FOUCHET
!
!	Given AS IS to DECUS France / Donne dans l'etat a DECUS France
!
!	**** USE IT AT YOUR OWN RISK ****
!	**** UTILISATION A VOS RISQUES ET PERILS ***
!

!									Page 2
!	Constants declaration
!
constant
	reg_list:="/R0/R1/R2/R3/R4/R5/R6/R7/R8/R9/R10/R11/AP/FP/SP/PC/ALL/",
	reg_mask:="R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10R11AP FP IV DV ",
	quote :="""",
	tabul :="							",
	spaces :="        ",
	min_parameter_size := 4,
	max_parameter_size_with_comment := 38,
	max_parameter_size_without_comment := 56,
	comment_tabul := 7,
	max_comment_size := 22;
!
variable
	global_value1,
	global_value2,
	par1,
	par2,
	par3,
	par4,
	params_definition,
	comments;

!									Page 3
!
!	This procedure read each line in a buffer, decompose it and try to
! symbolize register dependent information. Result is written in list_buffer.
!
procedure symbolize_buffer_contents(	! Symbolize register information
		buffer_);		! Buffer to symbolize
    local src_line,pos,old_pos;
    old_pos:=mark(none);
    params_definition:="";
    ! for each line
    position(beginning_of(buffer_));
    loop
        ! end of buffer
        exitif mark(none) = end_of(current_buffer);
        comments:="";
        ! get one line
        src_line:=edit(current_line,trim_leading,off);
        loop
            ! locate a comment
            pos:=index(src_line+";",";");
            ! analyse the comment
            analyse_comment(substr(src_line,pos+1,999));
            ! continuation line ?
            src_line:=edit(substr(src_line,1,pos-1),trim_trailing,off);
            exitif substr(src_line,length(src_line),1) <> "-";
            ! yes, append next line
            move_vertical(1);
            src_line:=substr(src_line,1,length(src_line)-1)+current_line;
        endloop;
        ! trim current line
        edit(src_line,trim,compress,off);
        if src_line <> ""
        then
            if src_line <> ascii(12)
            then
                ! symbolize the line
                symbolize_instruction(src_line);
                params_definition:="";
                loop
                    exitif comments = "";
                    write_comment("");
                endloop;
            else
                write_list(current_line);
            endif;
        else
            write_list(current_line);
        endif;
        move_vertical(1);
    endloop;
    position(old_pos);
endprocedure;

!									Page 4
!
!	This procedure analyse a comment. It try to locate special register or
! parameter specification (as R? => ????, P? => ????). If found, appropriate
! global variables are loaded.
!
procedure analyse_comment ( 		! Analyse a comment
		line_comment);		! Comment to analyse
    local com,reg,pos;
    if comments <> ""
    then
        comments:=comments+" "+edit(line_comment,trim,compress,not_in_place);
    else
        comments:=edit(line_comment,trim,compress,not_in_place);
    endif;
    com:=edit(line_comment,collapse,upper,off,not_in_place);
    reg:=substr(com,1,index(com,"=>")-1);
    if index(reg_list,"/"+reg+"/") > 0
    then
        set_register_type(reg,substr(com,index(com,"=>")+2));
    else
        if substr(reg,1,1) = "P"
        then
            pos:=index(line_comment,"=>");
            params_definition:=params_definition
              +"/"
              +edit(substr(line_comment,1,pos+1),collapse,upper,off)
              +edit(substr(line_comment,pos+2,999),trim,compress,upper,off)
              +"/";
        endif;
    endif;
endprocedure;

!									Page 5
!
!	This procedure get a instruction, decompose it, try to symbolize
! register dependant information, according to instruction type, reformat the
! line and write it to list_buffer.
!
procedure symbolize_instruction (	! Symbolize one instruction
		instr);			! Instruction to symbolize
    local src_line,label_name,instruct,pos1,pos2,param_count,
	ptr,defs,max_parameter_size;
    src_line:=instr;
    ! locate label
    pos1:=index(src_line,":");
    pos2:=index(src_line+" "," ");
    ! find fist " " or ","
    if pos1 < pos2
    then
        ! we have a label
        label_name:=substr(src_line,1,pos1-1);
        src_line:=edit(substr(src_line,pos1+1,999),trim_leading,off);
        pos2:=index(src_line+" "," ");
    else
        label_name:="";
    endif;
    ! locate instruction
    instruct:=substr(src_line,1,pos2-1);
    src_line:=substr(src_line,pos2+1,999);
    ! convert " ," to ","
    loop
        pos1:=index(src_line," ,");
        exitif pos1=0;
        src_line:=substr(src_line,1,pos1-1)+substr(src_line,pos1+1,999);
    endloop;
    ! convert ", " to ","
    loop
        pos1:=index(src_line,", ");
        exitif pos1=0;
        src_line:=substr(src_line,1,pos1)+substr(src_line,pos1+2,999);
    endloop;
    ! convert " =" to "="
    loop
        pos1:=index(src_line," =");
        exitif pos1=0;
        src_line:=substr(src_line,1,pos1-1)+substr(src_line,pos1+1,999);
    endloop;
    ! convert "= " to "="
    loop
        pos1:=index(src_line,"= ");
        exitif pos1=0;
        src_line:=substr(src_line,1,pos1)+substr(src_line,pos1+2,999);
    endloop;
    ! locate parameters
    param_count:=0;
    loop
        exitif src_line = "";
        param_count:=param_count+1;
        pos1:=index(src_line+" "," ");
        pos2:=index(src_line+",",",");
        ! get separator (" " or ",")
        if pos1 < pos2
        then
            pos2:=pos1;
        endif;
        ptr:=index(params_definition,"/P"+str(param_count)+"=>");
        if ptr <> 0
        then
            defs:=substr(params_definition,ptr,999);
            defs:=substr(defs,index(defs,">")+1,999);
            defs:=substr(defs,1,index(defs,"/")-1);
            global_value1:=decode_definition(substr(src_line,1,pos2-1),defs);
        else
            global_value1:=decode_param_offset(substr(src_line,1,pos2-1));
        endif;
        global_value2:=substr(src_line,pos2,1);
        ! define par"n" and sep"n" symbol
        execute("par"+str(param_count)+":=global_value1");
        execute("sep"+str(param_count)+":=global_value2");
        src_line:=substr(src_line,pos2+1,999);
    endloop;
    !
    !	Here, the line is decomposed. Symbolize elements.
    !
    ! symbolize flags value
    case instruct
        ["BBC","BBCC","BBCCI","BBCS","BBS","BBSC","BBSS","BBSSI"] :
            decode_pos(par1,par2);
        ["BICB2","BICB3","BICL2","BICL3","BICW2","BICW3"] :
            decode_mask(par1,par2);
        ["BISB2","BISB3","BISL2","BISL3","BISW2","BISW3"] :
            decode_mask(par1,par2);
        ["BITB","BITW","BITL"] :
            decode_mask(par1,par2);
        ["EXTZ","EXTZV"] :
            decode_pos(par1,par3);
            decode_size(par2,par3);
        ["FFC","FFS"] :
            decode_pos(par1,par3);
            decode_size(par2,par3);
        ["CMPV","CMPZV"] :
            decode_pos(par1,par3);
            decode_size(par2,par3);
        ["INSV"] :
            decode_pos(par2,par4);
            decode_size(par3,par4);
        ["PUSHR","POPR"] :
            decode_register_mask(par1);
        [".ENTRY"] :
            decode_register_mask(par2);
        ["MFPR"] :
            decode_prv_reg(par1);
        ["MTPR"] :
            decode_prv_reg(par2);
        ["DPT_STORE"] :
            if param_count >= 4
            then
                decode_dpt_store(par1,par2,par4);
            endif;
    endcase;
    !
    !	Recompose new source line
    !
    if label_name <> ""
    ! work for label
    then
        if length(label_name) > 6
        then
            ! if long label, write it alone on a line
            write_list(label_name+":");
            src_line:="	";
        else
            ! else, store it on line
            src_line:=label_name+":	";
        endif;
    else
        src_line:="	";
    endif;
    ! add instruction
    src_line:=src_line+instruct;
    if length(instruct) > 7
    then
       ! if long instruction, write line
       write_comment(src_line+" -");
       src_line:="	";
    endif;
    ! add parameters
    if param_count <> 0
    then
        if comments <> ""
        then
            max_parameter_size := max_parameter_size_with_comment;
        else
            max_parameter_size := max_parameter_size_without_comment;
        endif;
        src_line:=src_line+"	";
        pos1:=1;
        pos2:=0;
        loop
            exitif pos1 > param_count;
            ! get parameter value
            execute("global_value1:=par"+str(pos1));
            execute("global_value2:=sep"+str(pos1));
            ! split line if too long or contains a "=" sign
            if (((((pos2+length(global_value1)) > max_parameter_size)
              or (index(global_value1+src_line,"=") <> 0)))
              and (pos1 <> 1))
            then
                write_comment(src_line+" -");
                src_line:="		";
                pos2:=0;
            endif;
            ! split long parameters
            loop
                exitif length(global_value1) <= max_parameter_size;
                ptr:=find_split_point(global_value1,max_parameter_size);
                if ptr < min_parameter_size
                then
                    pos2:=pos2+length(global_value1);
                    src_line:=src_line+global_value1;
                    global_value1:="";
                else
                    write_comment(src_line
                      +substr(global_value1,1,ptr-1)
                      +" -");
                    src_line:="		";
                    pos2:=0;
                    global_value1:="  "+substr(global_value1,ptr,999);
                endif;
            endloop;
            ! add parameter to line
            src_line:=src_line+global_value1;
            pos2:=pos2+length(global_value1);
            ! add seperator if not last paramater
            if pos1 < param_count
            then
                src_line:=src_line+global_value2;
                pos2:=pos2+length(global_value2);
            endif;
            pos1:=pos1+1;
        endloop;
    endif;
    ! edit source line
    if instruct <> ""
    then
        write_comment(src_line);
    endif;
endprocedure;

!									Page 6
!
!	This procedure decompose a offset specification, as W^#120. It
! isolate the numeric value, loading leading characters (W^# in this case)
! in the lead parameter. Offset is overwritten. "<" and ">" characters
! are removed.
!
procedure decompose_offset (		! Decompose offset spec
		offset,			! Offset specification (modified)
		lead);			! Leading characters (written)
    ! remove leading chars
    offset:=edit(translate(offset,"  ","<>"),collapse);
    case substr(offset,1,1)
        ["@"] :
           lead:=lead+substr(offset,1,1);
           offset:=substr(offset,2,999);
    endcase;
    case substr(offset,1,2)
        ["W^","B^","L^","I^","S^"] :
           lead:=lead+substr(offset,1,2);
           offset:=substr(offset,3,999);
    endcase;
    case substr(offset,1,1)
        ["#"] :
           lead:=lead+substr(offset,1,1);
           offset:=substr(offset,2,999);
    endcase;
    ! convert string to decimal
    case substr(offset,1,2)
        ["^X"] :
            offset:=str(hexa_to_dec(substr(offset,3,999)));
        ["^D"] :
            offset:=substr(offset,3,999);
        ["^O"] :
            offset:=str(octal_to_dec(substr(offset,3,999)));
        ["^B"] :
            offset:=str(binary_to_dec(substr(offset,3,999)));
    endcase;
endprocedure;

!									Page 7
!
!	This procedure decompose a register specification (as W^^X10[R4](R2))
! in leading characters ("W^"), offset (16 in decimal base), other
! qualifiers ("[R4]") and register name ("(R2)"). Register name is extracted
! and the type associated  (if any) with the register (by a "; R? =>"
! comment) is returned as procedure result. If the type is not currently
! defined, the procedure returns a empty string.
!
procedure find_struct_type (		! Find structure  for a register
		spec,			! Input register specification
		lead,			! Leading characters (written)
		offset,			! Offset specification (written)
		other_qual,		! Other qualifiers (written)
		reg_name);		! Register specification (written)
					! Returns register type (string) or ""
    local pos,param;
    pos:=index(spec,"(");
    if pos <> 0
    then
        reg_name:=substr(spec,pos,999);
        param:=substr(spec,1,pos-1);
        pos:=index(param,"[");
        if pos <> 0
        then
            offset:=substr(param,1,pos-1);
            other_spec:=substr(param,pos,999);
        else
            offset:=param;
            other_spec:="";
        endif;
        lead:="";
        decompose_offset(offset,lead);
        return get_register_type(substr(reg_name,2,index(reg_name,")")-2));
    else
        lead:="";
        offset:="";
        other_qual:="";
        reg_name:=spec;
        return "";
    endif;
endprocedure;

!									Page 8
!
!	This procedure get a register specification (as W^^X10[R4](R2)) and
! symbolize it (as W^UCB$L_ASTQBL[R4](R2)).
!
procedure decode_param_offset (		! Decode parameter offset
		param);			! Full register specification
					! Returns (symbolized) parameter
    local reg_name,lead,offset,other_qual,struct_type;
    lead:="";
    offset:="";
    other_qual:="";
    reg_name:="";
    struct_type:=find_struct_type(param,lead,offset,other_qual,reg_name);
    if struct_type <> ""
    then
        symbolize_offset(offset,struct_type);
        if offset <> ""
        then
            return lead+offset+other_qual+reg_name;
        endif;
    endif;
    return param;
endprocedure;

!									Page 9
!
!	This procedure get a bit position specification (as ^B#4) and a
! base register specification (as W^UCB$W_STS(R5)), to symbolize the bit
! position (as ^B#UCB$V_ONLINE).
!
procedure decode_pos (			! Decode bit position
		bit_pos,		! Bit position specification (modified)
		reg_base);		! Base register specification
    local reg_name,lead,offset,other_qual,struct_type;
    lead:="";
    offset:="";
    other_qual:="";
    reg_name:="";
    struct_type:=find_struct_type(reg_base,lead,offset,other_qual,reg_name);
    if struct_type <> ""
    then
        symbolize_bit_pos(bit_pos,struct_type,offset);
    endif;
endprocedure;

!									Page 10
!
!	This procedure get a bit mask specification (as ^B#16) and a
! base register specification (as W^UCB$W_STS(R5)), to symbolize the bit
! mask (as ^B#UCB$M_ONLINE).
!
procedure decode_mask (			! Decode bit mask
		bit_mask,		! Bit mask specification (modified)
		reg_base);	    	! Base register specification
    local reg_name,lead,offset,other_qual,struct_type;
    lead:="";
    offset:="";
    other_qual:="";
    reg_name:="";
    struct_type:=find_struct_type(reg_base,lead,offset,other_qual,reg_name);
    if struct_type <> ""
    then
        symbolize_bit_mask(bit_mask,struct_type,offset);
    endif;
endprocedure;

!									Page 11
!
!	This procedure get a field size specification (as #2) and a
! base register specification (as W^IRP$W_FUNC(R2)), to symbolize the field
! size (as #IRP$S_FMOD).
!
procedure decode_size (			! Decode field size
		field_size,		! Field size specification
		reg_base);		! Base register specification    
    local reg_name,lead,offset,other_qual,struct_type;
    lead:="";
    offset:="";
    other_qual:="";
    reg_name:="";
    struct_type:=find_struct_type(reg_base,lead,offset,other_qual,reg_name);
    if struct_type <> ""
    then
        symbolize_field_size(field_size,struct_type,offset);
    endif;
endprocedure;

!									Page 12
!
!	This procedure get a register mask specification (as ^B#12) and
! symbolize it (as ^M<R2,R3>).
!
procedure decode_register_mask (	! Decode register mask
		register_mask);		! Register mask specification (modified)
    local lead,spec_value,bit_pos,bit_symbol;
    spec_value:=register_mask;
    lead:="";
    decompose_offset(spec_value,lead);
    spec_value:=dec_to_binary(int(spec_value));
    bit_pos:=0;
    bit_symbol:="";
    loop
        exitif bit_pos > 15;
        if substr(spec_value,32-bit_pos,1) = "1"
        then
            bit_symbol:=bit_symbol
              +edit(substr(reg_mask,(bit_pos*3)+1,3),trim)
              +",";
        endif;
        bit_pos:=bit_pos+1;
    endloop;
    register_mask:=lead+"^M<"+substr(bit_symbol,1,length(bit_symbol)-1)+">";
endprocedure;

!									Page 13
!
!	This procedure get a priviledgied register specification (as #19) and
! symbolize it (as #PR$_ASTLVL).
!
procedure decode_prv_reg (		! Decode priv register
		reg_number); 		! Register specification
    constant struct_type := "PR";
    local old_pos,macro_buffer,pos,symbol_name,lead,reg_num;
    macro_buffer:=find_buffer(struct_type);
    if macro_buffer = 0
    then
        set_register_type("PRIV",struct_type);
        macro_buffer:=find_buffer(struct_type);
    endif;
    if macro_buffer <> 0
    then
        old_pos:=mark(none);
        lead:="";
        reg_num:=reg_number;
        decompose_offset(reg_num,lead);
        position(beginning_of(macro_buffer));
        loop
            symbol_name:="";
            pos:=search_quietly(" "&reg_num&line_end,forward,exact);
            exitif pos=0;
            position(pos);
            symbol_name:=substr(current_line,index(current_line," ")+1,999);
            symbol_name:=substr(symbol_name,1,index(symbol_name," ")-1);
            exitif substr(symbol_name,1,4) = "PR$_";
            move_horizontal(1);
        endloop;
        if symbol_name <> ""
        then
            reg_number:=lead+symbol_name;
        endif;
        position(old_pos);
    endif;
endprocedure;

!									Page 14
!
!	This procedure get DPT store parameters (P1,P2 and P4) and symbolize
! offset and contents (P2 and P4). For example : "DPT_STORE UCB,120,W,4"
! symbolized as "DPT_STORE UCB,UCB$L_STS,W,UCB$M_ONLINE".
!
procedure decode_dpt_store (		! Decode DPT_STORE macro
		struct_type,		! Structure type
		offset,			! Offset in structure
		contents); 		! Offset contents
    if find_buffer(struct_type) = 0
    then
        set_register_type("TEMP",struct_type);
    endif;
    symbolize_offset(offset,struct_type);
    symbolize_bit_mask(contents,struct_type,offset);
endprocedure;

!									Page 15
!
!	This procedure symbolize a parameter using user definition (given by a
! "; P? =>" comment. See header comments for more information on parameter
! type specification.
!
procedure decode_definition (		! Decode with user definition
		param,			! Parameter to decode (modified)
		defs);			! Parameter definition
    local pos,param_type,param_struct,param_value,param_field,lead;
    param_value:=param;
    pos:=index(defs," ");
    param_type:=substr(defs,1,pos-1);
    param_struct:=substr(defs,pos+1,999);
    pos:=index(param_struct+" "," ");
    param_field:=substr(param_struct,pos+1,999);
    param_struct:=substr(param_struct,1,pos-1);
    lead:="";
    decompose_offset(param_value,lead);
    if find_buffer(param_struct) = 0
    then
        read_definition(param_struct);
    endif;
    case param_type
        ["OFFSET"] : symbolize_offset(param_value,param_struct);
        ["CONSTANT"] : symbolize_constant(param_value,param_struct,param_field);
        ["MASK"] : symbolize_bit_mask(param_value,param_struct,param_field);
        ["POSITION"] : symbolize_bit_pos(param_value,param_struct,param_field);
        ["SIZE"] : symbolize_field_size(param_value,param_struct,param_field);
    endcase;
    return lead+param_value;
endprocedure;

!									Page 16
!
!	This procedure get a offset specification (as 120) and a structure
! type (as UCB) to symbolize the offset (as UCB$B_STS). Symbolization is
! made using macro structure definition located in a buffer. Offset
! specification is searched. The name of the first symbol found is returned
! (except for "V","M","S","C","K" or "_" symbol type).
!
procedure symbolize_offset (		! Symbolize register offset
		offset,			! Offset to symbolize (modified)
		struct_type);		! Related structure
    local old_pos,macro_buffer,pos,symbol_name;
    macro_buffer:=find_buffer(struct_type);
    if macro_buffer <> 0
    then
        old_pos:=mark(none);
        position(beginning_of(macro_buffer));
        loop
            symbol_name:="";
            pos:=search_quietly(" "&offset&line_end,forward,exact);
            exitif pos=0;
            position(pos);
            symbol_name:=substr(current_line,index(current_line," ")+1,999);
            symbol_name:=substr(symbol_name,1,index(symbol_name," ")-1);
            exitif index("VMSCK_",
              substr(symbol_name,length(struct_type)+2,1))=0;
            move_horizontal(1);
        endloop;
        if symbol_name <> ""
        then
            offset:=symbol_name;
        endif;
        position(old_pos);
    endif;
endprocedure;

!									Page 17
!
!	This procedure get a constant specification (as 44), a structure
! type (as SS) and a field type (as SS$_) to symbolize the constant
! (as SS$_ABORT). Symbolization is made using macro structure definition
! located in a buffer. Constant specification is searched. The name of the
! first "C","K" or "_" symbol containing the field parameter is returned.
!
procedure symbolize_constant (		! Symbolize constant
		offset,			! Offset specification (modified)
		struct_type,		! Related structure
		field);			! Related field type
    local old_pos,macro_buffer,pos,symbol_name;
    macro_buffer:=find_buffer(struct_type);
    if macro_buffer <> 0
    then
        old_pos:=mark(none);
        position(beginning_of(macro_buffer));
        loop
            symbol_name:="";
            pos:=search_quietly(" "&offset&line_end,forward,exact);
            exitif pos=0;
            position(pos);
            symbol_name:=substr(current_line,index(current_line," ")+1,999);
            symbol_name:=substr(symbol_name,1,index(symbol_name," ")-1);
            if index("CK_",substr(symbol_name,length(struct_type)+2,1))<>0
            then
                exitif field = "";
                exitif index(symbol_name,field) <> 0;
            endif;
            move_horizontal(1);
        endloop;
        if symbol_name <> ""
        then
            offset:=symbol_name;
        endif;
        position(old_pos);
    endif;
endprocedure;

!									Page 18
!
!	This procedure get a bit position specification (as 4), a structure
! type (as UCB) and a field name (as UCB$W_STS) to symbolize the bit
! position (as UCB$V_ONLINE). Symbolization is made using macro structure
! definition located in a buffer. Offset specification is searched to
! extract offset value. Each line is then examined. If the line contains
! a bit position ("V" field), with the same value as the bit position, then
! this field name is returned. Else next line is scanned, only if field type is
! "V" or "S", or if field offset value is the same as the reference field.
!
procedure symbolize_bit_pos (		! Symbolize bit position
		bit_pos,		! Bit position to symbolize (modified)
		struct_type,		! Related structure type
		field);			! Related field
    local old_pos,macro_buffer,pos,symbol_name,cur_value,lead,
	spec_value,cur_offset,symbol_type,exact_match;
    macro_buffer:=find_buffer(struct_type);
    if macro_buffer <> 0
    then
        old_pos:=mark(none);
        if field = ""
        then
            field:=struct_type+"$V_"
        endif;
        spec_value:=bit_pos;
        lead:="";
        decompose_offset(spec_value,lead);
        pos:=search_quietly(field,forward,exact,macro_buffer);
        if pos <> 0
        then
            position(pos);
            move_horizontal(-current_offset);
            if index(current_line," "+field+" ") <> 0
            then
                exact_match:=1;
                symbol_name:=substr(current_line,index(current_line," ")+1,999);
                cur_offset:=edit(substr(symbol_name,index(symbol_name," ")+1,
                                    999),collapse);
                move_vertical(1);
            else
                exact_match:=0;
                cur_offset:="";
            endif;
            pos:=mark(none);
            loop
                exitif mark(none)=end_of(current_buffer);
                symbol_name:=substr(current_line,index(current_line," ")+1,999);
                cur_value:=edit(substr(symbol_name,index(symbol_name," ")+1,
				999),collapse);
                symbol_type:=substr(symbol_name,length(struct_type)+2,1);
                exitif (cur_value <> cur_offset)
			and (index("VS",symbol_type)=0)
                        and (exact_match=1);
                if (cur_value = spec_value) and (symbol_type = "V")
                then
                    bit_pos:=lead+substr(symbol_name,1,
			index(symbol_name," ")-1);
                    exitif 1=1;
                endif;
                move_vertical(1);
            endloop;
            position(old_pos);
        endif;
    endif;
endprocedure;

!									Page 19
!
!	This procedure get a bit mask specification (as 16), a structure
! type (as UCB) and a field name (as UCB$W_STS) to symbolize the bit
! mask (as UCB$M_ONLINE). Symbolization is made using macro structure
! definition located in a buffer. Offset specification is searched to
! extract offset value. The mask is then converted in binary format. For
! each bit set, we try to find the "V" field (as described in
! symbolize_bit_pos procedure). If found, the "V" symbol is overwritten by
! a "M" symbol and the corresponding bit is set to "0". At end,
! unsymbolized bits are converted to hexa specification, and added to the
! symbolized bit mask list.
!
procedure symbolize_bit_mask (		! Symbolize bit mask
		bit_mask,		! Bit mask to symbolize
		struct_type,		! Related structure type
		field);			! Related field
    local old_pos,macro_buffer,pos,symbol_name,cur_value,lead,
	spec_value,cur_offset,symbol_type,bit_pos,bit_symbol,exact_match;
    on_error
        if old_pos <> 0
        then
            position(old_pos);
        endif;
    endon_error;
    macro_buffer:=find_buffer(struct_type);
    if macro_buffer <> 0
    then
        old_pos:=mark(none);
        if field = ""
        then
            field:=struct_type+"$V_"
        endif;
        pos:=search_quietly(field,forward,exact,macro_buffer);
        if pos <> 0
        then
            spec_value:=bit_mask;
            lead:="";
            bit_symbol:="";
            decompose_offset(spec_value,lead);
            spec_value:=dec_to_binary(int(spec_value));
            position(pos);
            move_horizontal(-current_offset);
            if index(current_line," "+field+" ") <> 0
            then
                exact_match:=1;
                symbol_name:=substr(current_line,index(current_line," ")+1,999);
                cur_offset:=edit(substr(symbol_name,index(symbol_name," ")+1,
                                    999),collapse);
                move_vertical(1);
            else
                exact_match:=0;
                cur_offset:="";
            endif;
            symbol_name:=substr(current_line,index(current_line," ")+1,999);
            cur_offset:=edit(substr(symbol_name,
                index(symbol_name," ")+1,999),collapse);
            bit_pos:=0;
            loop
                exitif bit_pos > 31;
                if substr(spec_value,32-bit_pos,1) = "1"
                then
                    position(pos);
                    loop
                        exitif mark(none)=end_of(current_buffer);
                        symbol_name:=substr(current_line,
                               index(current_line," ")+1,999);
                        cur_value:=edit(substr(symbol_name,
                               index(symbol_name," ")+1,999),collapse);
                        symbol_type:=substr(symbol_name,
                               length(struct_type)+2,1);
                        exitif (cur_value <> cur_offset)
                               and (index("VS",symbol_type)=0)
                               and (exact_match=1);
                        if (cur_value = str(bit_pos)) and (symbol_type = "V")
                        then
                            symbol_name:=substr(symbol_name,1,
                                 index(symbol_name," ")-1);
                            bit_symbol:=bit_symbol+"!"+
                                 substr(symbol_name,1,length(struct_type)+1)+
                                 "M"+
                                 substr(symbol_name,length(struct_type)+3,999);
                            spec_value:=substr(spec_value,1,32-bit_pos)
                                 +"0"
                                 +substr(spec_value,33-bit_pos,32);
                            exitif 1=1;
                        endif;
                        move_vertical(1);
                    endloop;
                endif;
                bit_pos:=bit_pos+1;
            endloop;
            if bit_symbol <> ""
            then
                if spec_value <> "00000000000000000000000000000000"
                then
                    bit_mask:=bit_mask
                        +"!^X"+dec_to_hexa_1(binary_to_dec(spec_value));
                endif;
                bit_symbol:=substr(bit_symbol,2,999);
                if index(bit_symbol,"!") <> 0
                then
                    bit_symbol:="<"+bit_symbol+">";
                endif;
                bit_mask:=lead+bit_symbol;
            endif;
            position(old_pos);
        endif;
    endif;
endprocedure;

!									Page 20
!
!	This procedure get an field size specification (as 2), a structure
! type (as IRP) and a field name (as IRP$W_FUNC) to symbolize the field
! size (as IRP$S_FMOD). Symbolization is made using macro structure
! definition located in a buffer. Offset specification is searched to
! extracted offset value. Each line is then examined. If the line contains
! a bit position ("S" field), with the same value as the field size, then
! this field name is returned. Else next line is scanned, only if field type is
! "V" or "S", or if field offset value is the same as the reference field.
!
procedure symbolize_field_size (	! Symbolize field size
		field_size,		! Field size to symbolize
		struct_type,		! Related structure
		field);			! Related field
    local old_pos,macro_buffer,pos,symbol_name,cur_value,lead,
	spec_value,cur_offset,symbol_type,exact_match;
    macro_buffer:=find_buffer(struct_type);
    if macro_buffer <> 0
    then
        old_pos:=mark(none);
        if field = ""
        then
            field:=struct_type+"$S_"
        endif;
        spec_value:=field_size;
        lead:="";
        decompose_offset(spec_value,lead);
        pos:=search_quietly(field,forward,exact,macro_buffer);
        if pos <> 0
        then
            position(pos);
            move_horizontal(-current_offset);
            if index(current_line," "+field+" ") <> 0
            then
                exact_match:=1;
                symbol_name:=substr(current_line,index(current_line," ")+1,999);
                cur_offset:=edit(substr(symbol_name,index(symbol_name," ")+1,
                                    999),collapse);
                move_vertical(1);
            else
                exact_match:=0;
                cur_offset:="";
            endif;
            symbol_name:=substr(current_line,index(current_line," ")+1,999);
            cur_offset:=edit(substr(symbol_name,index(symbol_name," ")+1,
				999),collapse);
            loop
                exitif mark(none)=end_of(current_buffer);
                symbol_name:=substr(current_line,index(current_line," ")+1,999);
                cur_value:=edit(substr(symbol_name,index(symbol_name," ")+1,
				999),collapse);
                symbol_type:=substr(symbol_name,length(struct_type)+2,1);
                exitif (cur_value <> cur_offset)
                       and (index("VS",symbol_type)=0)
                       and (exact_match=1);
                if (cur_value = spec_value) and (symbol_type = "S")
                then
                    field_size:=lead+substr(symbol_name,1,
			index(symbol_name," ")-1);
                    exitif 1=1;
                endif;
                move_vertical(1);
            endloop;
            position(old_pos);
        endif;
    endif;
endprocedure;

!									Page 21
!
!	This procedure scan the buffer list to find a buffer nammed "MACRO_"
! followed by the given buffer name.
!
procedure find_buffer (			! Find a buffer giving name
		buffer_name);		! Buffer name to find
					! Returns buffer pointer or zero
    local buffer_ptr;
    buffer_ptr := get_info(buffers,"first");
    loop
        exitif buffer_ptr = 0;
        exitif "MACRO_"+buffer_name = get_info(buffer_ptr,"name");
        buffer_ptr := get_info(buffers,"next");
    endloop;
    return buffer_ptr;
endprocedure;

!									Page 22
!
!	This procedure read a macro definition nammed "$<struct_type>DEF"
! from user and system macro library, and write the definition in a buffer
! nammed "MACRO_<struct_type>". For example, "read_definition("UCB")" read
! $UCBDEF definition in MACRO_UCB buffer. User definitions are read first.
! User library is located by default in SYS$DISK:[]USER_DEFINITIONS.MLB, but
! can be located anywhere if the logical USER_DEFINITIONS is defined.
!
procedure read_definition (		! Read macro definitions
		struct_type);		! Structure type to read
    local old_pos,buf,user_lib;
    old_pos:=mark(none);
    ! try to locate definition in macro library
    if get_info(exec_buffer,"type") <> unspecified
    then
        erase(exec_buffer);
    endif;
    ! find user library location
    user_lib:=file_parse("USER_DEFINITIONS","SYS$DISK:[].MLB");
    exec_command("$ LIBRARY/EXTRACT=$"+struct_type+"DEF/OUTPUT=SYS$OUTPUT"
        +"/MACRO "+user_lib);
    exec_command("$ LIBRARY/EXTRACT=$"+struct_type+"DEF/OUTPUT=SYS$OUTPUT"
        +"/MACRO SYS$LIBRARY:STARLET");
    exec_command("$ LIBRARY/EXTRACT=$"+struct_type+"DEF/OUTPUT=SYS$OUTPUT"
        +"/MACRO SYS$LIBRARY:LIB");
    ! copy output to buffer
    create_buffer("MACRO_"+struct_type);
    buf:=find_buffer(struct_type);
    set(no_write,buf);
    position(buf);
    compress_buffer(exec_buffer);
    copy_text(exec_buffer);
    position(old_pos);
endprocedure;

!									Page 23
!
!	This procedure associate a type with a register. The type is loaded in
! a global variable nammed "REG_<register_name>".
!
procedure set_register_type (		! Set register current type
		reg,			! Register name
		reg_typ);		! Register type
    local reg_str,reg_name;
    if reg <> "ALL"
    then
        execute("reg_"+reg+":="+quote+reg_typ+quote);
    else
        reg_str:=substr(reg_list,2,index(reg_list,"/ALL/"));
        loop
            reg_name:=substr(reg_str,1,index(reg_str,"/")-1);
            exitif reg_name = "";
            execute("reg_"+reg_name+":="+quote+reg_typ+quote);
            reg_str:=substr(reg_str,index(reg_str,"/")+1,999);
        endloop;
    endif;
    if reg_typ <> ""
    then
        if find_buffer(reg_typ) = 0
        then
            read_definition(reg_typ);
        endif;
    endif;
endprocedure;

!									Page 24
!
!	This procedure read the type associated with a register. The type is
! located in a global variable nammed "REG_<register_name>". 
!
procedure get_register_type (		! Get register current type
		reg);			! Register name
					! Returns register type (or "")
    on_error
        return "";
    endon_error;
    execute("global_value_1:=reg_"+reg);
    return global_value_1;
endprocedure;

!									Page 25
!
!	This procedure write a line (or a buffer) in the list file, at the
! current point.
!
procedure write_list (			! Write line/buffer to list file
		added_comment);		! Line (or buffer) to write
    local old_pos;
    old_pos:=mark(none);
    position(list_buffer);
    copy_text(added_comment);
    split_line;
    if get_info(sysoutput_buffer,"type") = unspecified
    then
        sysoutput_buffer:=create_buffer("sysoutput");
        set(no_write,sysoutput_buffer);
    endif;
    position(sysoutput_buffer);
    erase(sysoutput_buffer);
    copy_text(added_comment);
    echo_buffer(sysoutput_buffer);
    position(old_pos);
endprocedure;

!									Page 26
!
!	This procedure write a line to list file, adding a comment if
! needed at end of line. The comment cames from the COMMENTS global variable.
!
procedure write_comment (		! Write a line and a comment
		cur_line);		! Line to write
    local ptr;
    if comments <> ""
    then
        ptr:=find_split_point(comments,max_comment_size);
        if ptr < 7
        then
            ptr:=max_comment_size;
        endif;
        write_list(cur_line
          +substr(tabul,1,
            comment_tabul-(length(detabulate_line(cur_line))/8))
          +"; "+substr(comments,1,ptr-1));
        comments:=edit(substr(comments,ptr,999),trim_leading);
    else
        write_list(cur_line);
    endif;
endprocedure;

!									Page 27
!
!	This procedure locate a split point in a string. A line can be splitted
! before a " ","!","@","&","-" or "," character. String length+1 is returned
! if split point can't be found.
!
procedure find_split_point (		! Find split point
		string_to_split,	! Line to split
		split_point);		! Split point maximum position
    local ptr;
    if length(string_to_split) > split_point
    then
        ptr:=split_point+1;
        loop
            exitif ptr <=0;
            exitif index(" !@&-,",substr(string_to_split,ptr,1)) <> 0;
            ptr:=ptr-1;
        endloop;
    else
        ptr:=length(string_to_split)+1;
    endif;
    return ptr;
endprocedure;

!									Page 28
!
!	This procedure replace all <tab> character of a line by the
! corresponding space equivalent. Tabulation are assumed to be each 8
! characters.
!
procedure detabulate_line ( 		! Convert tabs to spaces
		line_with_tabs);	! Line to detabulate
    local line_with_spaces,pos,len;
    line_with_spaces:=line_with_tabs;
    loop
        pos:=index(line_with_spaces,"	")-1;
        exitif pos<0;
        len:=8-(pos-((pos/8)*8));
        line_with_spaces:=substr(line_with_spaces,1,pos)
          +substr(spaces,1,len)
          +substr(line_with_spaces,pos+2,999);
    endloop;
    return line_with_spaces;
endprocedure;

!									Page 29
!	Convert decimal integer to hexa string
!
procedure dec_to_hexa (dec_value) 	! Decimal int -> hexa string
    return fao("!XL",dec_value);
endprocedure;

!									Page 30
!	Convert decimal integer to hexa string without leading zero
!
procedure dec_to_hexa_1 (dec_value) 	! Decimal int -> hexa w/o lead "0"
    local hexa_value;
    hexa_value:=dec_to_hexa (dec_value);
    loop;
        exitif length(hexa_value) <= 1;
        exitif substr(hexa_value,1,1) <> "0";
        hexa_value:=substr(hexa_value,2,99);
    endloop;
    return hexa_value;
endprocedure;

!									Page 31
!	Convert decimal integer to binary string
!
procedure dec_to_binary (dec_value) 	! Decimal int -> binary string
    local hex_value,bin_value;
    hex_value:=fao("!XL",dec_value);
    bin_value:="";
    loop
        exitif hex_value = "";
        case substr(hex_value,1,1)
            ["0"] : bin_value:=bin_value+"0000";
            ["1"] : bin_value:=bin_value+"0001";
            ["2"] : bin_value:=bin_value+"0010";
            ["3"] : bin_value:=bin_value+"0011";
            ["4"] : bin_value:=bin_value+"0100";
            ["5"] : bin_value:=bin_value+"0101";
            ["6"] : bin_value:=bin_value+"0110";
            ["7"] : bin_value:=bin_value+"0111";
            ["8"] : bin_value:=bin_value+"1000";
            ["9"] : bin_value:=bin_value+"1001";
            ["A"] : bin_value:=bin_value+"1010";
            ["B"] : bin_value:=bin_value+"1011";
            ["C"] : bin_value:=bin_value+"1100";
            ["D"] : bin_value:=bin_value+"1101";
            ["E"] : bin_value:=bin_value+"1110";
            ["F"] : bin_value:=bin_value+"1111";
        endcase;
        hex_value:=substr(hex_value,2,999);
    endloop;
    return bin_value;
endprocedure;

!									Page 32
!	Convert hexa string to decimal value
!
procedure hexa_to_dec (hexa_value)		! Hexa -> decimal int
    local dec_value,count;
    dec_value:=0;
    count:=1;
    loop
        dec_value:=(dec_value*16)
		+index("123456789ABCDEF",substr(hexa_value,count,1));
        count:=count+1;
        exitif count > length(hexa_value);
    endloop;
    return dec_value;
endprocedure;

!									Page 33
!	Convert octal string to decimal value
!
procedure octal_to_dec (octal_value)		! Octal -> decimal int
    local dec_value,count;
    dec_value:=0;
    count:=1;
    loop
        dec_value:=(dec_value*8)
		+index("1234567",substr(octal_value,count,1));
        count:=count+1;
        exitif count > length(octal_value);
    endloop;
    return dec_value;
endprocedure;

!									Page 34
!	Convert binary string to decimal value
!
procedure binary_to_dec (binary_value)		! Binary -> decimal int
    local dec_value,count;
    dec_value:=0;
    count:=1;
    loop
        dec_value:=(dec_value*2)
		+index("12",substr(binary_value,count,1));
        count:=count+1;
        exitif count > length(binary_value);
    endloop;
    return dec_value;
endprocedure;

!									Page 35
!
!	Compress a buffer (compress and trim spaces/tabs)
!
procedure compress_buffer (buf)		! Compress spaces/tabs in a buffer
    edit(buf,compress,trim,off);
endprocedure;

!									Page 36
!	Write a buffer to sys$output
!
procedure echo_buffer(buf)	! Write a buffer to sys$output
    set(success,off);
    write_file(buf,"sys$output:");
    set(success,on);
endprocedure;

!									Page 37
!	Send a command to the sub process witch execute it
!
procedure exec_command(cde_line)	! Execute a DCL command
    if get_info(exec_buffer,"type") = unspecified
    then
        exec_buffer := create_buffer("exec");
        set(no_write,exec_buffer);
    endif;
    if get_info(exec_process,"type") = unspecified
    then
        ! create DCL sub-process
        set(success,off);
        exec_process := create_process(exec_buffer,"$ set noon");
        set(success,on);
        send("$ set message/facil/text/sever/ident",exec_process);
    endif;
    send(cde_line,exec_process);
endprocedure;

!									Page 38
!	Main procedure
!
set(message_flags, 15);
!
! create list buffer
!
list_buffer := create_buffer("list");
position(beginning_of(list_buffer));
!
! get input file (or default it) and read it in main buffer
!
input_file := file_parse(get_info(command_line,'file_name'),".MAR");
main_buffer := create_buffer("main",input_file);
set(no_write,main_buffer);
!
! symbolize buffer contents
!
symbolize_buffer_contents(main_buffer);
!
! write output file
!
write_file(list_buffer,file_parse("sys$disk:[].lis",input_file));
!
! and exit ...
!
set(success,off);
quit;