.TITLE	FORK - Fork command stream to a subprocess

;  FORK is a program to implement the PUSH side of a TWENEX-style PUSH/POP
;  capability.  This allows a user to interrupt a program
;  via ^Y and initiate a subprocess running a new DCL session.  All
;  relevant context information from the parent process and DCL session
;  is saved on a file to be restored in the subprocess.  The file is written
;  in the user's default directory, on the assumption that he should be
;  allowed to write there.
;
;  This program is intended to be run via an merge image activation in the
;  context of a DCL internal command.  Specifically, it assumes supervisor
;  mode, registers pointing to DCL internal structures, and no image I/O
;  segment.  The code must be PIC since it gets loaded at an arbitrary point
;  in P1 space.
;
;  Written by:
;	Gary L. Grebus
;	Battelle Memorial Institute
;	Columbus, Ohio
;
;  V1.00 - 7-Sep-1981
;	Initial version.
;
;  System symbols

	$JPIDEF				; $GETJPI symbol definitions
	$DIBDEF				; Symbols for device characteristics
	$ACCDEF				; Symbols for termination message
	$FABDEF				; $FAB offsets
	$PSLDEF				; Codes for access modes
	$LOGDEF				; Logical name block definitions

;  Local symbols

EQUIV_NAM_LEN = 128			; Length of equivalence name buffers
P_NAME_SZ = 15				; Max size of a process name
ENV_REC_SZ = 2 * 64 + 1			; Size of environment record

;  Magic internal definitions for DCL
PRC_W_FLAGS = ^X54			; Offset of flag word in work area
PRC_M_DISABL = ^X4			; Mask for ^Y disable bit
PRC_L_INDFAB = ^X1C			; Offset to indirect FAB
PRC_Q_GLOBAL = ^X28			; Offset to global symbols listhead
PRC_Q_LOCAL = ^X38			; Offset to local symbols listhead
SYM_L_FL = ^X0				; Offsets in symbol entries - link
SYM_B_NESTLEVEL = ^X0B			; Abbrev. point offset 
SYM_T_SYMBOL = ^X0C			; Offset to symbol name
SYM_B_TYPE = ^X0A			; Offset to type field
SYM_K_PERM = ^X01			; Type symbol for permanent symbol

;  Local macros

	.MACRO	MK_DESC	ASCIC_STR, DESC_ADDR
;  Macro to generate a character string descriptor on the stack given
;  the symbolic address of a ASCIC string
	MOVAB	ASCIC_STR+1,-(SP)	; Push address of string
	MOVZBL	ASCIC_STR,-(SP)		; Push the string length
	MOVL	SP,DESC_ADDR		; SP contains the descriptor address
	.ENDM	MK_DESC


	.PAGE
	.SBTTL	RWDATA - Read/write data

	.PSECT	RWDATA RD,WRT,NOEXE,NOSHR,LONG

ENV_RAB:
	$RAB				; Skeleton RAB for environment file

INPUT_NAME:
	.BLKB	EQUIV_NAM_LEN+1		; Buffer for input dev name and count

OUTPUT_NAME:
	.BLKB	EQUIV_NAM_LEN+1		; Buffer for output dev name and count

ERROR_NAME:
	.BLKB	EQUIV_NAM_LEN+1		; Buffer for error dev name and count

IMAGE_NAME:
	.ASCIC	/SYS$SYSTEM:LOGINOUT/	; Name of image to execute in subproc

SYSIN:
	.ASCIC	/SYS$INPUT/		; Logical name for input

SYSOUT:
	.ASCIC	/SYS$OUTPUT/		; Logical name for output

SYSERR:
	.ASCIC	/SYS$ERROR/		; Logical name for error

PROC_NAME:
	.BLKB	P_NAME_SZ+1		; Buffer for process name and count

PROC_NAME_LEN:
	.BLKL	1			; Buffer for $GETJPI to return length
					; of process name
TRM_MBX_CHAN:
	.BLKW	1			; Buffer to hold termination mailbox
					; channel number

CHAR_BUF:
	.BLKB	DIB$K_LENGTH		; Buffer to hold termination mailbox
					; characteristics.

IOSB:
	.BLKQ	1			; IO Status Block for read on
					; termination mailbox

TRM_MSG_BUF:
	.BLKB	ACC$K_TERMLEN		; Buffer for termination mailbox

SUB_PID:
	.BLKL	1			; Buffer for subprocess PID

BASE_PRI:
	.LONG	6			; Buffer for base priority for subproc

; Skeleton request list for $GETJPI
JPI_LIST:
	.WORD	P_NAME_SZ		; Length of buffer
	.WORD	JPI$_PRCNAM		; Code for process name
JPI_P:	.LONG	0			; Space for buffer address
	.LONG	0			; Space for address of length variable
	.WORD	4			; Length of buffer
	.WORD	JPI$_PRIB		; Code for base priority
JPI_B:	.LONG	0			; Space for buffer address
	.LONG	0,0			; End of list

ENV_FAB_ADR:
	.BLKL	1			; Address of FAB for environment file

ENV_FSPEC:
	.ASCIC	/SYS$LOGIN:FORK.ENV/	;  File spec for environment file

LOGIN_LOG:
	.ASCIC	/SYS$LOGIN/		; Logical name for login device/dir

LOGIN_EQUIV:
	.BLKB	EQUIV_NAM_LEN		; Space for equiv name for above

LOGIN_EQUIV_SZ:
	.BLKL	1			; Current length of above name

CUR_DEFDIR:
	.BLKB	EQUIV_NAM_LEN		; Space for name of current
					; default directory
DEF_PROT:
	.BLKW	1			; Buffer to hold default file 
					; protection.

CUR_DEFDIR_SZ:
	.BLKL	1			; Current length of above string

DISK_LOG:
	.ASCIC	/SYS$DISK/		; Logical name for current disk

SAVE_PRC_FLAGS:
	.BLKW	1			; Saved DCL status flags

ENV_REC:
	.BLKB	ENV_REC_SZ		; Buffer for building records for
					; environment file

	.PAGE

;
;  This PSECT must get loaded at the very lowest address in the image
;
	.PSECT	_AAAA  RD,NOWRT,EXE,SHR,LONG,GBL,PIC
	.ENTRY	FORK,^M<R2,R3,R4,R5,R6>

;  Register usage:
;	R0-R1 - Scratch
;	R2-R6 - Address of string descriptors on stack
;	R11 - Assumed to point to DCL work area

;  Translate logical names for process permanent files
	PUSHAL	INPUT_NAME		; Translate input logical into
	PUSHAL	SYSIN			; INPUT_NAME
	CALLS	#2,TRANS_LOG

	PUSHAL	OUTPUT_NAME		; Translate output logical into
	PUSHAL	SYSOUT			; OUTPUT_NAME
	CALLS	#2,TRANS_LOG

	PUSHAL	ERROR_NAME		; Translate error logical into
	PUSHAL	SYSERR			; ERROR_NAME
	CALLS	#2,TRANS_LOG

;  Do a $GETJPI to get info which we need to supply to subprocess
	MOVAL	PROC_NAME+1,JPI_P	; Fill in buffer addr in $GETJPI list
	MOVAL	PROC_NAME_LEN,JPI_P+4	; Fill in address of length longword
	MOVAL	BASE_PRI,JPI_B		; Fill in address for base priority
	$GETJPI_S	ITMLST=JPI_LIST	; Get the info
	BLBS	R0,5$			; Branch if success
	BRW	ERR_EXIT

;  Build a process name for the subprocess
5$:	SUBL3	PROC_NAME_LEN,-
		#P_NAME_SZ,R0		; Compute nr of unused chars in name
	MOVL	PROC_NAME_LEN,R1	; Get length of name
	MOVC5	#0,.,#^A/ /,-
		R0,PROC_NAME+1[R1]	; Blank fill the name
	SUBL3	#1,#P_NAME_SZ,R0	; Get nr of append positions
	MOVAL	PROC_NAME+2,R1		; Get address of buffer
	ADDL2	R0,R1			; Compute address to get appendix

7$:	CMPW	#^A/_F/,-(R1)		; Is this position already appended?
	BNEQ	9$			; Branch if not
	SUBL2	#2,R0			; Decrement count
	BGTR	7$			; Branch if more positions in name

9$:	MOVW	#^A/_F/,(R1)		; Append the fork appendix
	MOVB	#P_NAME_SZ,PROC_NAME	; Fill in count for name

;  Get a termination mailbox
	$CREMBX_S -
		CHAN=TRM_MBX_CHAN,-
		MAXMSG=#120		; Get mailbox
	BLBS	R0,10$			; Branch if success
	BRW	ERR_EXIT

10$:	MOVAL	CHAR_BUF,-(SP)		; Build desc for char buffer
	MOVL	#DIB$K_LENGTH,-(SP)
	MOVL	SP,R2			; R2 points to descriptor
	$GETCHN_S -
		CHAN=TRM_MBX_CHAN,-
		PRIBUF=(R2)		; Get mailbox unit number
	BLBS	R0,20$			; Branch if success
	BRW	CLEAN_UP

;  Disable ^Y to prevent interruption.  Also prevents main process
;  from getting control if subprocess gets a ^Y
20$:
	MOVW	PRC_W_FLAGS(R11),-
		SAVE_PRC_FLAGS		; Get the current ^Y status
	BISW	#PRC_M_DISABL,-
		PRC_W_FLAGS(R11)	; And disable ^Y

	CALLS	#0,DMP_ENV		; Dump the current environment
					; for use by the subprocess
	BLBS	R0,25$			; Branch if success
	BRW	ENAB_Y

25$:	CALLS	#0,SET_DEFDIR		; Restore default dev/dir to login
					; values

;  Create the subprocess
	MK_DESC	INPUT_NAME,R2		; Make descriptors for string args
	MK_DESC	OUTPUT_NAME,R3
	MK_DESC	IMAGE_NAME,R4
	MK_DESC	PROC_NAME,R5
	MK_DESC	ERROR_NAME,R6

	$CREPRC_S -
		IMAGE=(R4),-
		INPUT=(R2),-
		OUTPUT=(R3),-
		ERROR=(R6),-
		PRCNAM=(R5),-
		PIDADR=SUB_PID,-
		MBXUNT=CHAR_BUF+DIB$W_UNIT,-
		BASPRI=BASE_PRI		; Create a process
	BLBS	R0,30$			; Branch if $CREPRC worked
	BRW	RST_DIR

;  Read termination mailbox and hibernate.  When something hits termination
;  mailbox, we will be reawoken
30$:
	$QIO_S -
		CHAN=TRM_MBX_CHAN,-
		FUNC=#IO$_READVBLK,-
		ASTADR=AST_RTN,-
		IOSB=IOSB,-
		P1=TRM_MSG_BUF,-
		P2=#ACC$K_TERMLEN	; Read for a termination message
	BLBS	R0,40$			; Branch if success
	BRW	RST_DIR

40$:	$HIBER_S			; Go to sleep until subprocess done
	BLBS	IOSB,50$		; Check QIO status.  Branch if ok.
	MOVZWL	IOSB,R0			; Return the I/O error

50$:
	MOVL	TRM_MSG_BUF+ACC$L_FINALSTS,R0 ; Everything worked on our end.
					; Return the process status

;  Erase environment file and reset default dir.
RST_DIR:
	$ERASE	FAB=@ENV_FAB_ADR	; Zap the file
	CALLS	#0,RESET_DEFDIR		; Reset directory

;  Reenable ^Y status.
ENAB_Y:
	MOVW	SAVE_PRC_FLAGS,-
		PRC_W_FLAGS(R11)	; Restore saved ^Y status

CLEAN_UP:
	PUSHL	R0			; Save the current condition value
	TSTL	SUB_PID			; Did we create a subprocess?
	BEQL	60$			; Branch if not
	$DELPRC_S	PIDADR=SUB_PID	; Zap subprocess just to be sure

60$:	$DASSGN_S -
		CHAN=TRM_MBX_CHAN	; Clean up the mailbox channel
	POPL	R0			; Restore the saved value

ERR_EXIT:
	RET

;  AST routine invoked when the read on the subprocess termination mailbox
;  completes

AST_RTN:
	.WORD	0
	$WAKE_S				; Wake up our process
	RET

	.PAGE
	.SBTTL	TRANS_LOG - Completely translate a logical name

;  This routine completely translates a logical name passes as a counted
;  ASCII string.  The equivalence string is returned as a counted string.
;  The output buffer is assumed to be EQUIV_NAM_LEN bytes long.  This
;  routine is reentrant and PIC.
;  First parameter is the address of the logical name string.  Second
;  parameter is the address of the buffer to receive the equivalence name
;  string.

	.PSECT	_AAAA	RD,NOWRT,EXE,SHR,LONG,GBL,PIC
	.ENTRY	TRANS_LOG,^M<R2,R3,R4,R5,R6,R7>

;  Register usage:
;	R0-R1 - Scratch
;	R2 - Address of descriptor for current source string
;	R3 - Address of descriptor for current destination string
;	R4-R5 - Scratch.
;	R6 - Length of logical name
;	R7 - Address of output buffer+1

	MOVL	8(AP),R7		; Get addr of dest buffer
	INCL	R7			; plus one (leave space for count)
	MOVL	4(AP),R0		; Get address of input logical name
	MOVZBL	(R0),R6			; Get length of input name
	MOVC3	R6,1(R0),(R7)		; Move logical name into output buffer

	MOVAL	(R7),-(SP)		; Build descriptor for input string
					; in output buffer. Address
	MOVL	R6,-(SP)		; and length
	MOVL	SP,R2			; R2 points to input string

10$:	MOVAL	(R7),-(SP)		; Build desc for output buffer. Addr
	MOVL	#EQUIV_NAM_LEN,-(SP)	; and length
	MOVL	SP,R3			; Pointer to output desc in R3

	$TRNLOG_S -
		LOGNAM=(R2),-
		RSLLEN=(R3),-
		RSLBUF=(R3)		; Translate the current input name
	BLBC	R0,50$			; Quit if error
	
	CMPB	(R7),#^X1B		; Does the equiv name contain an
					; escape prefix?
	BNEQ	20$			; Branch if not
	SUBL2	#4,(R3)			; Else adjust length and
	ADDL2	#4,4(R3)		; and address to skip it

20$:	CMPL	R0,#SS$_NOTRAN		; Are we all done translating?
	BEQL	50$			; Branch if so
	MOVL	R3,R2			; Else make old output into new input
	BRB	10$			; And try again

50$:	MOVB	(R3),-1(R7)		; All done.  Store count into output
					; buffer
	RET				; And return

	.PAGE
	.SBTTL	DMP_ENV - Dump current environment to file

;  Routine to save to a file all of the info necessary to recreate the
;  correct environment within the subprocess. The environment file
;  is written in the login default directory on the assumption that it is
;  a writeable place
;  Also saves the current default directory in CUR_DEFDIR for use
;  by other routines

	.PSECT	_AAAA	RD,NOWRT,EXE,SHR,LONG,GBL,PIC
	.ENTRY	DMP_ENV,^M<>

;  Register usage:
;	R0-R1 - Scratch

;  Create and connect to a file to receive the data
	MOVL	PRC_L_INDFAB(R11),R0	; Address of indirect FAB
	MOVL	R0,ENV_FAB_ADR		; Stash address for latr
	CLRW	FAB$W_IFI(R0)		; Clear the FAB
	$FAB_STORE -
		ALQ=#0,-
		DEQ=#0,-
		FAC=PUT,-
		RAT=CR,-
		RFM=VAR,-
		FOP=PPF,-
		DNA=#0,-
		DNS=#0,-
		FNA=ENV_FSPEC+1,-
		FNS=ENV_FSPEC		; Setup FAB fields
	$CREATE	FAB=@ENV_FAB_ADR	; Create the file
	BLBS	R0,10$			; Branch if success
	RET

10$:	$RAB_STORE -
		RAB=ENV_RAB,-
		FAB=@ENV_FAB_ADR	; Point RAB at FAB
	$CONNECT	RAB=ENV_RAB	; And connect it
	BLBS	R0,20$			; Branch if success
	RET

;  Write out current default directory string
20$:
	PUSHAL	CUR_DEFDIR		; Build desc to CUR_DEFDIR buffer
	PUSHL	#EQUIV_NAM_LEN
	PUSHL	SP			; Param 3 - Address of desc to receive
					; current default dir string
	PUSHAL	CUR_DEFDIR_SZ		; Param 2 - Address to receive length
	PUSHL	#0			; Param 1 - No new default dir
	CALLS	#3,G^SYS$SETDDIR	; Get current default dir string

	$RAB_STORE -
		RAB=ENV_RAB,-
		RBF=CUR_DEFDIR,-
		RSZ=CUR_DEFDIR_SZ	; Point RAB at the string
	$PUT	RAB=ENV_RAB		; and write it to file

;  Write out current default file protection
	PUSHAL	DEF_PROT		; Param 2 - address to receive prot
	PUSHL	#0			; Dummy param 1 - don't change prot
	CALLS	#2,G^SYS$SETDFPROT	; Obtain the protection value
	$RAB_STORE -
		RAB=ENV_RAB,-
		RBF=DEF_PROT,-
		RSZ=#2			; Point RAB at the protection value
	$PUT	RAB=ENV_RAB		; Write the protection value record

;  Write out global CLI symbols
	PUSHAQ	PRC_Q_GLOBAL(R11)	; Param is address of global
					; symbol table listhead
	CALLS	#1,DMP_SYM		; Dump global symbols

;  Write out local CLI symbols
	PUSHAQ	PRC_Q_LOCAL(R11)	; Param is address of local
					; symbol table listhead
	CALLS	#1,DMP_SYM		; Dump local symbols

;  Write out process logicals
	CALLS	#0,DMP_PLOG		; Write records for logical names

	$CLOSE	FAB=@ENV_FAB_ADR	; Close the environment file

	RET

	.PAGE
	.SBTTL	SET_DEFDIR - Routine to alter default dev/dir

;  This routine alters the current default device and directory back to
;  their values at login time.  Logical name environment must be already
;  saved because we will create a new definition for SYS$DISK.

	.PSECT	_AAAA RD,NOWRT,EXE,SHR,LONG,GBL,PIC
	.ENTRY	SET_DEFDIR,^M<R2,R3,R4>

;  Register usage:
;	R0-R4 - Scratch

;  Reset default disk and directory to login defaults
;  Start by finding login default device and directory
	MK_DESC	LOGIN_LOG,R2		; Get desc to logical name
	PUSHAL	LOGIN_EQUIV		; Build desc to equiv name buffer
	PUSHL	#EQUIV_NAM_LEN
	MOVL	SP,R1			; Get addr of dest desc
	$TRNLOG_S -
		LOGNAM=(R2),-
		RSLLEN=LOGIN_EQUIV_SZ,-
		RSLBUF=(R1)		; Translate once to get dev:[dir]

	LOCC	#^A/:/,-
		LOGIN_EQUIV_SZ,-
		LOGIN_EQUIV 		; Find end of device name
	MOVQ	R0,R3			; Save R0,R1 status from LOCC

;  Set the default disk to login value.  Actually, we create a new logical
;  in Supervisor mode and don't alter the real SYS$DISK definition.
	SUBL3	R0,LOGIN_EQUIV_SZ,-
		R0			; Comput nr of chars in dev name
	INCL	R0			; Include ":" in the count
	PUSHAL	LOGIN_EQUIV		; Build desc to the device name
	PUSHL	R0
	MOVL	SP,R1			; Address of descriptor
	MK_DESC	DISK_LOG,R2		; Get desc to logical SYS$DISK
	$CRELOG_S -
		TBLFLG=#2,-
		LOGNAM=(R2),-
		EQLNAM=(R1),-
		ACMODE=#PSL$C_SUPER	; Redefine SYS$DISK

;  Set default directory to login value
	INCL	R4			; Adjust saved pointer past ":"
	DECL	R3			; and adjust length
	PUSHL	R4			; Build desc to directory part of 
					; LOGIN_EQUIV.
	PUSHL	R3
	MOVL	SP,R2			; Address of descriptor
	CLRQ	-(SP)			; Dummy params 2 and 3
	PUSHL	R2			; 1st param is new def dir string
	CALLS	#3,G^SYS$SETDDIR	; Reset directory
	RET

	.PAGE
	.SBTTL	RESET_DEFDIR - Restore saved dev/dir

;  Routine to restore the default disk and directory values present
;  before FORK processing.  The default directory name was saved by
;  DMP_ENV.  The new definition for SYS$DISK made by SET_DEFDIR is
;  deleted.

	.PSECT	_AAAA RD,NOWRT,EXE,SHR,LONG,GBL,PIC
	.ENTRY	RESET_DEFDIR,^M<R2>

;  Register usage:
;	R0-R2 - Scratch

;  Reset default disk logical name by deleting other definition
	MK_DESC	DISK_LOG,R2		; Get desc to SYS$DISK string
	$DELLOG_S -
		TBLFLG=#2,-
		LOGNAM=(R2)		; Zap the definition

;  Reset default directory string
	PUSHAL	CUR_DEFDIR		; Build desc to save directory name
	PUSHL	CUR_DEFDIR_SZ
	MOVL	SP,R1			; Address of desc
	CLRQ	-(SP)			; Dummy param 2 and 3
	PUSHL	R1			; Param 1 is new def dir string
	CALLS	#3,G^SYS$SETDDIR	; Set directory names
	RET

	.PAGE
	.SBTTL	DMP_PLOG - Write environment records for logical names

;  Routine to write the contents of the process logical nmae table to
;  the environment file.  The logical name table is chased directly
;  and a record is written for each logical name found.  Format of the
;  records is:
;	+0) access mode of the entry
;	+1) length of logical name
;	+2) logical name
;	+n+2) length of equiv name
;	+n+3) equiv name
;  We do not dump any logicals for process permanents, since these are
;  already created in the subprocess by LOGINOUT (redefining them would
;  cause trouble).

	.PSECT	_AAAA RD,NOWRT,EXE,SHR,LONG,PIC,GBL
	.ENTRY	DMP_PLOG,^M<R2,R3,R4,R5,R6,R7>

;  Register usage
;  R0-R5 - Scratch
;  R6 - Pointer to current logical name block
;  R7 - Pointer to logical name listhead

	$RAB_STORE -
		RAB=ENV_RAB,-
		RBF=ENV_REC		; Point RAB at record buffer
	MOVL	G^LOG$AL_LOGTBL+8,R7	; Get address of name table listhead
	MOVL	R7,R6			; Copy pointer

10$:	MOVL	LOG$L_LTFL(R6),R6	; Get pointer to next logical name blk
	CMPL	R6,R7			; Do we point back to listhead?
	BEQL	20$			; Branch if so

;  Build a record and write it
	MOVAL	ENV_REC,R3		; R3 points to destination
	MOVB	LOG$B_AMOD(R6),(R3)+	; Store access mode byte
	MOVZBL	LOG$T_NAME(R6),R0	; Get length of logical name
	INCL	R0			; Incr to allow for count byte
	CMPB	LOG$T_NAME+1(R6)[R0],-
		#^X1B			; Equiv name for a PPF?
	BEQL	10$			; Skip it if so
	MOVZBL	LOG$T_NAME(R6)[R0],R1	; Get length of equiv name
	ADDL2	R1,R0			; Sum of lengths
	INCL	R0			; plus one for equiv name count
	ADDW3	#1,R0,-
		ENV_RAB+RAB$W_RSZ	; Length of names plus 1 for
					; access mode is record length
	MOVC3	R0,LOG$T_NAME(R6),(R3)	; Move names to buffer
	$PUT	RAB=ENV_RAB		; Write the record
	BRB	10$			; Loop for next name

;  All records written.  Write a zero length terminator
20$:	CLRW	ENV_RAB+RAB$W_RSZ	; Zero the length field
	$PUT	RAB=ENV_RAB		; Write terminator
	RET

	.PAGE
	.SBTTL	DMP_SYM - Dump CLI symbols from CLI symbol table

;  This routine is used to dump the contents of a CLI symbol table
;  to the environment file.  For each symbol, one record is written to
;  the file.  The record consists of two counted strings, the symbol name
;  and the value.  Following the last symbol, a zero length record is
;  written as a delimiter.  Symbols which were defined as allowing an
;  abbreviation have a count value which indicates the number of characters
;  in the shortest abbreviation.  This count is used to reinsert the
;  "*" abbreviation character into the symbol record.  Symbols marked as
;  permanent ($STATUS and $SEVERITY) are not processed.

	.PSECT	_AAAA RD,NOWRT,EXE,SHR,LONG,GBL,PIC
	.ENTRY	DMP_SYM,^M<R6,R7>

;  Register usage
;	R0-R1 - Scratch
;	R6 - Pointer to current symbol table entry
;	R7 - Scratch

	$RAB_STORE -
		RAB=ENV_RAB,-
		RBF=ENV_REC		; Point RAB at the buffer
	MOVL	4(AP),R6		; Get copy of listhead pointer

10$:	MOVL	SYM_L_FL(R6),R6		; Point to next symbol in table
	CMPL	R6,4(AP)		; Are we back to listhead?
	BEQL	20$			; Branch out if so

	CMPB	SYM_B_TYPE(R6),-
		#SYM_K_PERM		; Is this a permanent symbol?
	BEQL	10$			; Branch if so and skip it.

	MOVZBL	SYM_T_SYMBOL(R6),R0	; Get length of symbol name
	MOVZBL	SYM_T_SYMBOL+1(R6)[R0],-
		R1			; Get length of value
	ADDL2	R0,R1			; Compute length of text
	ADDL2	#2,R1			; Plus 2 for total record length

	MOVW	R1,ENV_RAB+RAB$W_RSZ	; Store record length in RAB
	MOVC3	R1,SYM_T_SYMBOL(R6),-
		ENV_REC			; Move symbol info into buffer

	MOVZBL	SYM_B_NESTLEVEL(R6),R1	; Is abbreviation allowed?
	BEQL	15$			; Branch if not

;  R1 contains nr of chars in the symbol name after the abbreviation point
	CLRL	R7			; Clear dest register
	SUBB3	R1,ENV_REC,R7		; Compute nr of chars before abbrev
					; point
	INCL	R7			; plus one for count byte gives
					; offset in record of abbrev point.
	SUBW3	R7,ENV_RAB+RAB$W_RSZ,R1	; Compute nr of chars in record after
					; abbrev point
	MOVC3	R1,ENV_REC[R7],-
		ENV_REC+1[R7]		; Slide all chars down by 1
	MOVB	#^A/*/,ENV_REC[R7]	; Stuff in abbrev character
	INCB	ENV_REC			; Bump count field in record
	INCW	ENV_RAB+RAB$W_RSZ	; Bump record length

15$:	$PUT	RAB=ENV_RAB		; Write the record
	BRB	10$			; Loop thru all symbols

;  Write zero length record as terminator
20$:	CLRW	ENV_RAB+RAB$W_RSZ	; Zero length field
	$PUT	RAB=ENV_RAB		; Write terminator
	RET

	.END	FORK