MODULE upgrade		(IDENT='V04-000',
			ADDRESSING_MODE(EXTERNAL=GENERAL))
= BEGIN

!****************************************************************************
!*									    *
!*  COPYRIGHT (c) 1978, 1980, 1982, 1984 BY				    *
!*  DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS.		    *
!*  ALL RIGHTS RESERVED.						    *
!* 									    *
!*  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.		    *
!* 									    *
!*									    *
!****************************************************************************

!++
! Facility:	Command Definition Utility, CLI Table Upgrade Module
!
! Abstract:	This module is solely responsible for the upgrading of
!		old format CLI tables to the latest format level.  The
!		module is included in both the CDU and the CLIs, and thus
!		must be completely self-contained.
!
! Environment:	No assumptions may be made about the environment.
!		No own storage is allowed.
!		No external references are allowed.
!
! Author:	Paul C. Anagnostopoulos
! Creation:	8 March 1983
!
! Modifications:
!
!	V04-003	BLS0285			Benn Schreiber		 9-MAR-1984
!		If image name length is 0, then it's a routine address,
!		which counts for 4 bytes.
!
!	V04-002	BLS0270			Benn Schreiber		 9-FEB-1984
!		Correct errors in structure length computation.
!
!	V04-001	PCA1026			Paul C. Anagnostopoulos 25-Jul-1983
!		Add probe to check readability of command table to be
!		converted.  Fix bug in creation of entity block, so that
!		a label is always included.
!--


library 'sys$library:lib';
require 'clitabdef';
require 'cli5def';
require 'cdureq';

!	P S E C T   N A M E S
!	---------   ---------

! The following psect names are chosen so DCL won't break when it links
! with this module.  The leading underscores cause the psect to appear
! at the end of the image.

psect plit = _cdu$plit(align(0),read,nowrite,noexecute);
psect code = _cdu$code(align(0),read,nowrite,execute);


!	T A B L E   O F   C O N T E N T S
!	---------   ---   ---------------

forward routine
	cdu$upgrade_table,
	upgrade_5_to_6,
	upgrade_5_to_6_allocate,
	upgrade_5_to_6_vector: novalue,
	upgrade_5_to_6_command: novalue,
	upgrade_5_to_6_entity: novalue;


!	M A C R O   D E F I N I T I O N S
!	---------   ---------------------

! The following macro will return the length of an ASCIC string which is
! present at a certain offset within a block.  If the offset is within the
! fixed portion of the block, then there is no string.  Or, the byte at the
! offset may not be readable.

macro
	ascic_length(the_block,the_offset) =
		(builtin
			prober;

		if the_offset lequ 8 then
			0
		else if prober(%ref(psl$c_user),%ref(1),the_block+the_offset) then
			1+ch$rchar(the_block+the_offset)
		else
			0
		) %;

! The following macro will translate an old block address into the
! corresponding new block address.  This is done by looking up the old
! address in the vector of old addresses and taking the corresponding entry
! from the vector of new addresses.  Note that the zeroth entry of the vectors
! contains the entry count.

macro
	new_block_address(old_block_address) =
		(bind
			old_block_address_bind = old_block_address: block[,byte];

		incr i from 1 to .old_vector[0] do
			if old_block_address_bind eqla .old_vector[.i] then
				exitloop .new_vector[.i]
		) %;

!++
! Description:	This routine is called whenever a CLI table is about to be
!		used.  Its goal is to upgrade the CLI table to the latest
!		format level, so that no other module need be concerned
!		with any format but the latest.
!
! Parameters:	table		By reference, the address of the CLI table
!				(its primary vector block).
!		new_pointer	Optional, by reference, a longword which is
!				to receive the address of the upgraded table.
!		get_vm		Optional, by reference, the address of a
!				routine with the same interface as LIB$GET_VM,
!				for obtaining virtual memory.
!		free_vm		Optional, by reference, self-explanatory.
!		
!
! Returns:	A status describing what happened.
!
! Notes:
!--

GLOBAL ROUTINE cdu$upgrade_table(table: pointer,
				 new_pointer: ref vector[1,long],
				 get_vm: pointer,
				 free_vm: pointer)
= BEGIN

local
	level: long;

builtin
	nullparameter,
	prober;


! The first thing to do is ensure that we can read the table.  If not,
! just return a bad status.  This is done because we may be called
! by DCL when there is no current CLI table.

if not prober(%ref(psl$c_user),%ref(1),.table) then
	return msg(cli$_invtab);

! We need to do is determine the format level of the table.
! Prior to level 6, the primary vector block had a different format, so
! we have to determine the basic format and then the exact level.

level =	(if .table[vec_w_size] eqlu vec_k_length and
	 .table[vec_b_type] eqlu block_k_vector then
		.table[vec_b_strlvl]			! Level 6 or later.
	else
		.table[vec5_b_strlvl]);			! Level 5 or earlier.

! Select on the format level of the table.

selectoneu .level of set

[5]:

	! It's a level 5 table, so we can upgrade it to the latest level.
	! If we were called with only one argument, however, that means that
	! the caller doesn't think we should upgrade an old table.  This is
	! true of the process-permanent table, because the user should
	! understand the implication of upgrading old CLDs, and is thus
	! required to do it by hand.

	(if nullparameter(2) then
		return msg(cli$_oldtab);

	! Call a routine to upgrade the table.  It returns the final status.

	return upgrade_5_to_6(.table,new_pointer[0],.get_vm,.free_vm););

[6]:

	! Level 6 is the current level.

	(if not nullparameter(2) then
		new_pointer[0] = .table;
	return msg(cli$_oktab););

[otherwise]:

	! God knows what this table is.

	return msg(cli$_invtab);
tes;

END;

!++
! Description:	This is the main routine for upgrading a level 5 (VMS V3)
!		CLI table to level 6 (VMS V4).
!
! Parameters:	table		By reference, the address of the CLI table
!				(its primary vector block).
!		new_pointer	By reference, a longword in which to return
!				the address of the new table.
!		get_vm		By reference, see above.
!		free_vm		By reference, see above.
!
! Returns:	By reference, the new primary vector block.
!
! Notes:
!--

ROUTINE upgrade_5_to_6(table: pointer,
		       new_pointer: ref vector[1,long],
		       get_vm: pointer,
		       free_vm: pointer)
= BEGIN

local
	status: long,
	old_vector: ref vector[,long],
	new_vector: ref vector[,long],
	block_count: long initial(0),
	old_block: pointer;


! First we must allocate space for two vectors, with an entry for each of
! the blocks in the old CLI table.  The OLD_VECTOR will contain the
! addresses of the old CLI table blocks, while the NEW_VECTOR will contain
! the address of the corresponding new block.

status = (.get_vm)(%ref(.table[vec5_l_free]/12*4), old_vector);
status = (.get_vm)(%ref(.table[vec5_l_free]/12*4), new_vector);

! Now we can allocate space for new blocks, one for each of the old
! blocks.  This is done by scanning the old CLI table from beginning to
! end, and calling the allocation routine for each one.  As we go, the
! old and new block address vectors will be filled in.  Note that the first
! entry in the vectors will reference the primary vector block.

old_block = .table;
while .old_block lssa .table + .table[vec5_l_free] do (
	increment(block_count);
	old_vector[.block_count] = .old_block;
	old_block = .old_block +
		    upgrade_5_to_6_allocate(.old_block,new_vector[.block_count],.table,.get_vm);
	if .new_vector[.block_count] eqla 0 then
		return msg(cli$_invtab);
);

! Store the block count as the zeroth entry in both vectors, so that the
! vectors are self-describing.

old_vector[0] = new_vector[0] = .block_count;

! Once the new blocks are allocated, we can fill them in.  We make a pass
! over the address vectors, calling a routine for each of the possible
! cases.

incru i from 1 to .block_count do (

	bind
		new_block = .new_vector[.i]: block[,byte];

	(selectoneu .new_block[vec_b_type] of set
	[block_k_vector]:	upgrade_5_to_6_vector;
	[block_k_command]:	upgrade_5_to_6_command;
	[block_k_entity]:	upgrade_5_to_6_entity;
	tes) (new_block,.old_vector[.i],.new_vector,.old_vector,.get_vm);
);

! Store the address of the new table in the requested place.

new_pointer[0] = .new_vector[1];

! Free up the memory that was allocated for the address vectors.

status = (.free_vm)(%ref(.table[vec5_l_free]/12*4), old_vector);
status = (.free_vm)(%ref(.table[vec5_l_free]/12*4), new_vector);

return msg(cli$_upgtab);

END;

!++
! Description:	This routine is called to allocate a level 6 block
!		corresponding to an old level 5 block.
!
! Parameters:	old_block	By reference, the old block for which a new
!				one is to be allocated.
!		new_pointer	By reference, a longword to receive the
!				address of the new block.
!		table		By reference, the address of the old CLI
!				table.
!		get_vm		By reference, see above.
!
! Returns:	Length of the old block.
!
! Notes:
!--

ROUTINE upgrade_5_to_6_allocate(old_block: pointer,
				new_pointer: ref vector[1,long],
				table: pointer,
				get_vm: pointer)
= BEGIN

local
	status: long,
	new_block: pointer,
	old_length: long;


! To allocate a new block, we must determine the type of the old block.
! This is not easy.  Once determined, we can allocate space for the new
! block and set up its type and subtype.  We must also determine the length
! of the old block so we can return it.

! First we will determine whether the old block is a vector block.
! This is done by comparing its address to the addresses of the primary
! vector block, the verb name table, and the command block pointer table.

if .old_block eqla .table then (

	! It's the primary vector block.

	old_length = vec5_k_length;
	status = (.get_vm)(%ref(vec_k_length), new_block);
	new_block[vec_b_type] = block_k_vector;
	new_block[vec_b_subtype] = .old_block[vec5_b_cli]+1;

) else if .old_block eqla .table + .table[vec5_l_verbtbl] then (

	! It's the verb name table.

	old_length = .table[vec5_l_verbend] - .table[vec5_l_verbtbl];
	status = (.get_vm)(%ref(vec_k_header_length + .old_length), new_block);
	new_block[vec_b_type] = block_k_vector;
	new_block[vec_b_subtype] = vec_k_verb;

) else if .old_block eqla .table + .table[vec5_l_comdptr] then (

	! It's the command block pointer table.

	old_length = .table[vec5_l_verbend] - .table[vec5_l_verbtbl];
	status = (.get_vm)(%ref(vec_k_header_length + .old_length), new_block);
	new_block[vec_b_type] = block_k_vector;
	new_block[vec_b_subtype] = vec_k_command;

) else (

	local
		chg_length: long,
		cmd_length: long,
		cmdnam_length: long,
		ent_length: long;

	! Because the level 5 table blocks are not self-identifying, it is
	! difficult to determine what kind of block we have.  We will
	! calculate the block length for each of the three other block types,
	! and then decide which one we have.

	chg_length =	chg5_k_length +
			ascic_length(.old_block,.old_block[chg5_w_image]);
	cmdnam_length =	ascic_length(.old_block,.old_block[cmd5_w_image]);
	!
	! If the length is 0 (ascic_length adds 1 for the count byte) then
	! there is no image name.  length will be 4 for routine address
	!
	if .cmdnam_length eql 1
	    then cmdnam_length = 4;
	cmd_length =	cmd5_k_length +	.cmdnam_length +
			ascic_length(.old_block,.old_block[cmd5_w_outputs]);
	ent_length =	ent5_k_length +
			ascic_length(.old_block,.old_block[ent5_w_name]) +
			ascic_length(.old_block,.old_block[ent5_w_label]) +
			ascic_length(.old_block,.old_block[ent5_w_defval]) +
			ascic_length(.old_block,.old_block[ent5_w_prompt]);

	if .chg_length eqlu .old_block[chg5_b_size] then (

		! We have a change block.  This becomes a command block in
		! the new table.

		old_length = .chg_length;
		status = (.get_vm)(%ref(cmd_k_length + 4+1), new_block);
		new_block[cmd_b_type] = block_k_command;
		new_block[cmd_b_subtype] = cmd_k_syntax;

	) else if .cmd_length eqlu .old_block[cmd5_b_size] then (

		! We have a command block.

		old_length = .cmd_length;
		status = (.get_vm)(%ref(cmd_k_length + 4+1 + 12), new_block);
		new_block[cmd_b_type] = block_k_command;
		new_block[cmd_b_subtype] = cmd_k_verb;

	) else if .ent_length eqlu .old_block[ent5_b_size] then (

		! We have an entity block.

		old_length = .ent_length;
		status = (.get_vm)(%ref(ent_k_length + 16 + 16 + 64 + 16), new_block);
		new_block[ent_b_type] = block_k_entity;

	) else (

		! Oh God, who knows what this block is?

		old_length = 0;
		new_block = 0;
	);
);	

! Store the address of the new block where requested, and return the length
! of the old block;

new_pointer[0] = .new_block;
return .old_length;

END;

!++
! Description:	This routine is called to fill in a new vector block from
!		the corresponding old block.
!
! Parameters:	new_block	By reference, the new block to be filled in.
!				The type and subtype are already present.
!		old_block	By reference, the corresponding old block.
!		new_vector	By reference, the vector of new block
!				addresses.  Zeroth entry is block count.
!		old_vector	By reference, the vector of old block
!				addresses.
!		get_vm		By reference, see above.
!
! Returns:	Nothing.
!
! Notes:
!--

ROUTINE upgrade_5_to_6_vector(new_block: pointer,
			      old_block: pointer,
			      new_vector: ref vector[,long],
			      old_vector: ref vector[,long],
			      get_vm: pointer)			: novalue

= BEGIN

local
	entry_count: long;


! Select on the subtype of the vector block.

selectoneu .new_block[vec_b_subtype] of set

[vec_k_dcl,
 vec_k_mcr]:

	! We have the primary vector block.  Fill in each field from the
	! old primary vector block.  We cannot determine the overall table
	! size.

	(new_block[vec_w_size] = vec_k_length;
	new_block[vec_w_flags] = 0;
	new_block[vec_b_strlvl] = 6;
	new_block[vec_w_tro_count] = 2;
	new_block[vec_l_verbtbl] = new_block_address(.old_block+.old_block[vec5_l_verbtbl]) - .new_block;
	new_block[vec_l_comdptr] = new_block_address(.old_block+.old_block[vec5_l_comdptr]) - .new_block;
	new_block[vec_l_table_size] = 0;);

[vec_k_verb]:

	! We have the verb name table.  Initialize the new block header.
	! Then copy the verb name entries, converting them from blank
	! padded with bit 7 set to zero padded with bit 7 clear.

	(bind
		new_verb_names = .new_block + vec_k_header_length: vector[,long],
		old_primary = .old_vector[1]: block[,byte],
		old_verb_names = .old_block: vector[,long];

	entry_count = (.old_primary[vec5_l_verbend] - .old_primary[vec5_l_verbtbl]) / 4;
	new_block[vec_w_size] = vec_k_header_length + .entry_count*4;
	new_block[vec_w_flags] = 0;
	new_block[vec_w_tro_count] = 0;

	incr i from 0 to .entry_count-1 do (

		bind
			old_name = old_verb_names[.i]: vector[4,byte],
			new_name = new_verb_names[.i]: vector[4,byte];

		new_name[0] = .old_name[0] and %x'7f';
		new_name[1] = (if .old_name[1] eqlu ' ' then %x'00' else .old_name[1]);
		new_name[2] = (if .old_name[2] eqlu ' ' then %x'00' else .old_name[2]);
		new_name[3] = (if .old_name[3] eqlu ' ' then %x'00' else .old_name[3]);
	););

[vec_k_command]:

	! We have the command block pointer table.  Initialize the new
	! block header.  Then copy the pointers, translating them to point
	! at the new command blocks.

	(bind
		new_command_block_pointers = .new_block + vec_k_header_length: vector[,long],
		old_primary = .old_vector[1]: block[,byte],
		old_command_block_pointers = .old_block: vector[,long];

	entry_count = (.old_primary[vec5_l_verbend] - .old_primary[vec5_l_verbtbl]) / 4;
	new_block[vec_w_size] = vec_k_header_length + .entry_count*4;
	new_block[vec_w_flags] = 0;
	new_block[vec_w_tro_count] = .entry_count;

	incr i from 0 to .entry_count-1 do
		new_command_block_pointers[.i] = (if .old_command_block_pointers[.i] eqlu 0 then 0 else
			new_block_address(old_command_block_pointers[.i+1]+.old_command_block_pointers[.i]) -
				.new_vector[1]);
	);

tes;

return;

END;

!++
! Description:	This routine is called to fill in a new command block from
!		the corresponding old block.
!
! Parameters:	new_block	By reference, the new block to be filled in.
!				The type and subtype are already present.
!		old_block	By reference, the corresponding old block.
!		new_vector	By reference, the vector of new block
!				addresses.  Zeroth entry is block count.
!		old_vector	By reference, the vector of old block
!				addresses.
!		get_vm		By reference, see above.
!
! Returns:	Nothing.
!
! Notes:
!--

ROUTINE upgrade_5_to_6_command(new_block: pointer,
			       old_block: pointer,
			       new_vector: ref vector[,long],
			       old_vector: ref vector[,long],
			       get_vm: pointer)			: novalue

= BEGIN

local
	variable_ptr: pointer;


! Set up to add information to the variable portion of the new block.

variable_ptr = new_block[cmd_z_variable];

! Split up depending upon whether we are to build a verb command block
! or a syntax change command block.

if .new_block[cmd_b_subtype] eqlu cmd_k_verb then (

	! We are building a verb command block.  Fill in the new block from
	! the old one.

	new_block[cmd_w_flags] = 0;
	new_block[cmd_v_abbrev] = .old_block[cmd5_v_abrev];
	new_block[cmd_v_nostat] = .old_block[cmd5_v_nostat];
	new_block[cmd_v_foreign] = .old_block[cmd5_v_foreign];
	new_block[cmd_v_immed] = .old_block[cmd5_v_immed];
	new_block[cmd_v_mcrparse] = .old_block[cmd5_v_mcrparse];
	new_block[cmd_v_parms] = new_block[cmd_v_quals] = new_block[cmd_v_disallows] = true;
	new_block[cmd_w_tro_count] = 3;
	new_block[cmd_l_parms] = (if .old_block[cmd5_w_parms] eqlu 0 then 0 else
		new_block_address(.old_block+.old_block[cmd5_w_parms]) - .new_vector[1]);
	new_block[cmd_l_quals] = (if .old_block[cmd5_w_quals] eqlu 0 then 0 else
		new_block_address(.old_block+.old_block[cmd5_w_quals]) - .new_vector[1]);
	new_block[cmd_l_disallow] = 0;
	new_block[cmd_b_handler] = (if .old_block[cmd5_w_image] eqlu 0 then 0 else cmd_k_user);
	new_block[cmd_v_minparm] = .old_block[cmd5_v_minparm];
	new_block[cmd_v_maxparm] = .old_block[cmd5_v_maxparm];
	new_block[cmd_b_verbtyp] = 0;
	new_block[cmd_w_name] = 0;
	if .old_block[cmd5_w_image] eqlu 0 then
		new_block[cmd_w_image] = 0
	else (
		bind
			routine_longword = .old_block + .old_block[cmd5_w_image]: long;

		new_block[cmd_w_image] = .variable_ptr - .new_block;
		variable_ptr[0,0,32,0] = .routine_longword;
		variable_ptr[4,0,8,0] = 0;
		variable_ptr = .variable_ptr + 4+1;
	);
	if .old_block[cmd5_w_outputs] eqlu 0 then
		new_block[cmd_w_outputs] = 0
	else (
		bind
			outputs_list = .old_block + .old_block[cmd5_w_outputs]: vector[,byte];

		new_block[cmd_w_outputs] = .variable_ptr - .new_block;
		ch$move(1+.outputs_list[0],outputs_list[0], .variable_ptr);
		variable_ptr = .variable_ptr + 1+.outputs_list[0];
	);
	new_block[cmd_w_prefix] = 0;

) else (

	! We are building a syntax change command block.  Fill in the new
	! block from the old one as much as possible.

	new_block[cmd_w_flags] = 0;
	new_block[cmd_v_parms] = .old_block[chg5_v_parms];
	new_block[cmd_v_quals] = .old_block[chg5_v_quals];
	new_block[cmd_v_disallows] = true;
	new_block[cmd_w_tro_count] = 3;
	new_block[cmd_l_parms] = (if .old_block[chg5_w_parms] eqlu 0 then 0 else
		new_block_address(.old_block+.old_block[chg5_w_parms]) - .new_vector[1]);
	new_block[cmd_l_quals] = (if .old_block[chg5_w_quals] eqlu 0 then 0 else
		new_block_address(.old_block+.old_block[chg5_w_quals]) - .new_vector[1]);
	new_block[cmd_l_disallow] = 0;
	new_block[cmd_b_handler] = (if not .old_block[chg5_v_image] then cmd_k_same
				   else if .old_block[chg5_w_image] eqlu 0 then cmd_k_none
				   else cmd_k_user);
	new_block[cmd_v_minparm] = .old_block[chg5_v_minparm];
	new_block[cmd_v_maxparm] = .old_block[chg5_v_maxparm];
	new_block[cmd_b_verbtyp] = 0;
	new_block[cmd_w_name] = 0;
	if .old_block[chg5_w_image] eqlu 0 then
		new_block[cmd_w_image] = 0
	else (
		bind
			routine_longword = .old_block + .old_block[chg5_w_image]: long;

		new_block[cmd_w_image] = .variable_ptr - .new_block;
		variable_ptr[0,0,32,0] = .routine_longword;
		variable_ptr[4,0,8,0] = 0;
		variable_ptr = .variable_ptr + 4+1;
	);
	new_block[cmd_w_outputs] = 0;
	new_block[cmd_w_prefix] = 0;
);

! Now we can fill in the final size of the new block.

new_block[cmd_w_size] = .variable_ptr - .new_block;

return;

END;

!++
! Description:	This routine is called to fill in a new entity block from
!		the corresponding old block.
!
! Parameters:	new_block	By reference, the new block to be filled in.
!				The type and subtype are already present.
!		old_block	By reference, the corresponding old block.
!		new_vector	By reference, the vector of new block
!				addresses.  Zeroth entry is block count.
!		old_vector	By reference, the vector of old block
!				addresses.
!		get_vm		By reference, see above.
!
! Returns:	Nothing.
!
! Notes:
!--

ROUTINE upgrade_5_to_6_entity(new_block: pointer,
			      old_block: pointer,
			      new_vector: ref vector[,long],
			      old_vector: ref vector[,long],
			      get_vm: pointer)			: novalue

= BEGIN

local
	status: long,
	variable_ptr: pointer;


! Set up to add information to the variable portion of the new block.

variable_ptr = new_block[ent_z_variable];

! Now fill in the new entity block from the old one.  Note that we cannot
! differentiate between qualifiers and keywords.

new_block[ent_b_subtype] =
	(if .old_block[ent5_w_number] lequ 8 then ent_k_parameter else ent_k_qualifier);
new_block[ent_w_flags] = 0;
new_block[ent_v_val] = .old_block[ent5_v_val];
new_block[ent_v_neg] = .old_block[ent5_v_neg];
new_block[ent_v_deftrue] = .old_block[ent5_v_deftrue];
new_block[ent_v_batdef] = .old_block[ent5_v_batdef];
new_block[ent_v_valreq] = .old_block[ent5_v_valreq];
new_block[ent_v_list] = .old_block[ent5_v_list];
new_block[ent_v_concat] = .old_block[ent5_v_concat];
new_block[ent_v_impcat] = .old_block[ent5_v_impcat];
new_block[ent_v_verb] = .old_block[ent5_v_verb];
new_block[ent_v_parm] = .old_block[ent5_v_parm];
new_block[ent_v_mcroptdelim] = .old_block[ent5_v_mcroptdlm];
new_block[ent_v_mcrignore] = .old_block[ent5_v_mcrignore];
new_block[ent_w_tro_count] = 3;
new_block[ent_l_next] = (if .old_block[ent5_b_next] eqlu 0 then 0 else
	new_block_address(.old_block+.old_block[ent5_b_next]) - .new_vector[1]);
new_block[ent_l_syntax] = (if .old_block[ent5_w_syntax] eqlu 0 then 0 else
	new_block_address(.old_block+.old_block[ent5_w_syntax]) - .new_vector[1]);

! For the user type definition, we have to create a skeleton type block as
! a header for the keyword entity blocks.

if .old_block[ent5_w_keywords] eqlu 0 then
	new_block[ent_l_user_type] = 0
else (
	local
		type_block: pointer;

	status = (.get_vm)(%ref(type_k_length), type_block);
	type_block[type_w_size] = type_k_length;
	type_block[type_b_type] = block_k_type;
	type_block[type_b_subtype] = type_k_type;
	type_block[type_w_flags] = 0;
	type_block[type_w_tro_count] = 1;
	type_block[type_l_keywords] = new_block_address(.old_block+.old_block[ent5_w_keywords]) - .new_vector[1];
	type_block[type_w_name] = type_block[type_w_prefix] = 0;
	new_block[ent_l_user_type] = .type_block - .new_vector[1];
);

! Continue filling in the entity block.  Note that we can't get the entity
! number except for parameters.

new_block[ent_b_number] =
	(if .new_block[ent_b_subtype] eqlu ent_k_parameter then .old_block[ent5_w_number] else 0);
new_block[ent_b_valtype] = .old_block[ent5_b_valtype];
new_block[ent_w_name] = .variable_ptr - .new_block;
if .old_block[ent5_w_name] lequ 8 then (
	variable_ptr[0,0,8,0] = 2;
	variable_ptr[1,0,8,0] = 'P';
	variable_ptr[2,0,8,0] = '0' + .old_block[ent5_w_name];
	variable_ptr = .variable_ptr + 1+2;
) else (
	bind
		entity_name = .old_block + .old_block[ent5_w_name]: vector[,byte];

	ch$move(1+.entity_name[0],entity_name[0], .variable_ptr);
	variable_ptr = .variable_ptr + 1+.entity_name[0];
);
if .old_block[ent5_w_label] eqlu 0 then
	new_block[ent_w_label] = .new_block[ent_w_name]
else (
	bind
		entity_label = .old_block + .old_block[ent5_w_label]: vector[,byte];

	new_block[ent_w_label] = .variable_ptr - .new_block;
	ch$move(1+.entity_label[0],entity_label[0], .variable_ptr);
	variable_ptr = .variable_ptr + 1+.entity_label[0];
);
if .old_block[ent5_w_prompt] eqlu 0 then
	new_block[ent_w_prompt] = 0
else (
	bind
		entity_prompt = .old_block + .old_block[ent5_w_prompt]: vector[,byte];

	new_block[ent_w_prompt] = .variable_ptr - .new_block;
	ch$move(1+.entity_prompt[0],entity_prompt[0], .variable_ptr);
	variable_ptr = .variable_ptr + 1+.entity_prompt[0];
);
if .old_block[ent5_w_defval] eqlu 0 then
	new_block[ent_w_defval] = 0
else (
	bind
		entity_defval = .old_block + .old_block[ent5_w_defval]: vector[,byte];

	new_block[ent_w_defval] = .variable_ptr - .new_block;
	variable_ptr[0,0,8,0] = 1+.entity_defval[0];
	ch$move(1+.entity_defval[0],entity_defval[0], .variable_ptr+1);
	variable_ptr = .variable_ptr + 1 + 1+.entity_defval[0];
);

! Now we can fill in the final size of the new block.

new_block[ent_w_size] = .variable_ptr - .new_block;

return;

END;

END
ELUDOM
