



		    cv_ascii_to_bcd_.pl1            11/19/82  1449.3rew 11/19/82  0933.8       49500



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* ******************************************************************************
   *								*
   *	Modified by RH Morrison 6/22/76				*
   *								*
   ***************************************************************************** */

cv_ascii_to_bcd_: proc (a_input_ptr, a_output_ptr, a_code);

/* Procedure to convert Multics ascii to GCOS 14 bit binary.

   Arguments are:

   a_input_ptr	pointer to an 80 character aligned input string (input)
   a_output_ptr	pointer to a 14 word aligned output string (input)
   a_code		0 = successful, 1 = unsuccessful (output)

   */


/* DECLARATIONS */

/* fixed bin */

dcl (i,						/* loop index */
     index,					/* index into character arrays */
     interval,					/* half interval search interval */
     j						/* loop index */
     ) fixed bin aligned;

dcl (
     a_code,					/* error code (argument) */
     code init (0)					/* error code (internal) */
     ) fixed bin (35) aligned;


/* pointers */

dcl (
     a_input_ptr,					/* pointer to ascii input string (argument) */
     a_output_ptr,					/* pointer to bcd output string (argument) */
     input_ptr,					/* pointer to ascii input string (internal) */
     output_ptr					/* pointer to bcd output string (internal) */
     ) ptr aligned;


/* bit strings */

dcl (
     ascii_char_not_found				/* ON until match is found with current input char */
     ) bit (1) aligned;


/* built in functions */

dcl (
     divide,
     fixed,
     unspec
     ) builtin;


/* structures */

dcl  a_table (64) char (1) aligned init (		/* ascii table */
     " ",
     "!",
     """",
     "#",
     "$",
     "%",
     "&",
     "'",
     "(",
     ")",
     "*",
     "+",
     ",",
     "-",
     ".",
     "/",
     "0",
     "1",
     "2",
     "3",
     "4",
     "5",
     "6",
     "7",
     "8",
     "9",
     ":",
     ";",
     "<",
     "=",
     ">",
     "?",
     "@",
     "[",
     "\",
     "]",
     "^",
     "_",
     "a",
     "b",
     "c",
     "d",
     "e",
     "f",
     "g",
     "h",
     "i",
     "j",
     "k",
     "l",
     "m",
     "n",
     "o",
     "p",
     "q",
     "r",
     "s",
     "t",
     "u",
     "v",
     "w",
     "x",
     "y",
     "z"
     );

dcl  b_table (64) bit (6) aligned init (		/* bcd table */
     "010000"b,
     "111111"b,
     "111110"b,
     "001011"b,
     "101011"b,
     "111100"b,
     "011010"b,
     "101111"b,
     "011101"b,
     "101101"b,
     "101100"b,
     "110000"b,
     "111011"b,
     "101010"b,
     "011011"b,
     "110001"b,
     "000000"b,
     "000001"b,
     "000010"b,
     "000011"b,
     "000100"b,
     "000101"b,
     "000110"b,
     "000111"b,
     "001000"b,
     "001001"b,
     "001101"b,
     "101110"b,
     "011110"b,
     "111101"b,
     "001110"b,
     "001111"b,
     "001100"b,
     "001010"b,
     "011111"b,
     "011100"b,
     "100000"b,
     "111010"b,
     "010001"b,
     "010010"b,
     "010011"b,
     "010100"b,
     "010101"b,
     "010110"b,
     "010111"b,
     "011000"b,
     "011001"b,
     "100001"b,
     "100010"b,
     "100011"b,
     "100100"b,
     "100101"b,
     "100110"b,
     "100111"b,
     "101000"b,
     "101001"b,
     "110010"b,
     "110011"b,
     "110100"b,
     "110101"b,
     "110110"b,
     "110111"b,
     "111000"b,
     "111001"b
     );


/* masks */

dcl 1 ascii_string aligned based (input_ptr),		/* for looking at ascii string */
    2 ascii_char (80) char (1) unaligned;

dcl 1 bcd_string aligned based (output_ptr),		/* for looking at bcd string */
    2 bcd_char (80) bit (6) unaligned,
    2 bcd_pad bit (24) unaligned;			/* for filling out to last word boundary */

/*  */

	input_ptr = a_input_ptr;			/* copy arguments */
	output_ptr = a_output_ptr;

	do i = 1 to 80 while (code = 0);		/* per character loop */

	     if ascii_char (i) = " "			/* make quick check for blank */
	     then do;
		bcd_char (i) = "010000"b;
		ascii_char_not_found = "0"b;
	     end;

	     else					/* character is not a blank */
	     do;

		ascii_char_not_found = "1"b;		/* set search flag */
		index = 32;			/* index into character arrayx */
		interval = 32;			/* and search interval */

		do j = 1 to 6 while (ascii_char_not_found); /* half-interval search loop */

		     if ascii_char (i) = a_table (index) /* match found */
		     then do;
			ascii_char_not_found = "0"b;
			bcd_char (i) = b_table (index);
		     end;

		     else				/* match not found */
		     do;
			interval = divide (interval, 2, 17, 0); /* split search interval */
			if fixed (unspec (ascii_char (i)), 9) < fixed (unspec (a_table (index)), 9)
						/* set direction of search */
			then index = index - interval;
			else
			index = index + interval;
		     end;

		end;

		if ascii_char_not_found		/* error, invalid input character */
		then code = 1;

	     end;

	     if code = 0				/* conversion was successful */
	     then bcd_pad = "010000010000010000010000"b;

	     a_code = code;				/* return error code */

	end;

	return;

     end cv_ascii_to_bcd_;




		    gcos_convert_sst.pl1            11/19/82  1449.3rew 11/19/82  0933.9       62550



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* ********************************************************************
   *							*
   *	WRITTEN BY:	P. Haber 		March 21, 1974	*
   *	MODIFIED BY:	R.H. Morrison	September 3, 1974	*
   *							*
   ******************************************************************** */


gcos_convert_sst: gcs: proc;

/* DECLARATIONS */
/* ------------ */


/* fixed bin */
/* ----- --- */

dcl (
     i,
     j,
     k
     ) fixed bin aligned;

dcl (
     code,
     error_table_$badopt ext
     ) fixed bin (35) aligned;


/* pointers */
/* -------- */

dcl (
     rh_ptr,
     sp
     ) ptr aligned;


/* bit strings */
/* --- ------- */


dcl (
     end_of_tape init ("0"b),
     gsr_write_init_was_called init ("0"b),
     tape_is_attached (2) init ("0"b, "0"b)
     ) bit (1) aligned;

dcl (
     rheader init ("0"b)
     ) bit (12) aligned;

dcl (
     status_bits
     ) bit (72) aligned;


/* character strings */
/* --------- ------- */

dcl (
     mode (2) init ("r", "w")
     ) char (1) aligned;

dcl (
     tape_name (2) init ("input", "output")
     ) char (8) aligned;

dcl (
     stream_name (2) init ("gcs_input", "gcs_output")
     ) char (12) aligned;

dcl (
     tape_label (2)
     ) char (32) aligned;

dcl  buffer char (112) aligned;			/* 28 words */


/* built-in functions */
/* -------- --------- */

dcl (
     addr,
     null,
     substr
     ) builtin;


/* masks */
/* ----- */

dcl 1 rheader_mask aligned based (rh_ptr),
    2 pad bit (2) unaligned,
    2 media_code bit (4) unaligned;

dcl 1 status aligned based (sp),
    2 scode fixed bin (35) aligned;


/* conditions */
/* ---------- */

dcl (
     cleanup
     ) condition;


/* external entries */
/* -------- ------- */

dcl  com_err_ ext entry
     options (variable);

dcl  gcos_gsr_write_ ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned,
     bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_$gsr_write_close ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_$gsr_write_init ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  ioa_$nnl ext entry
     options (variable);

dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned,
     bit (72) aligned);

dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$order ext entry
    (char (*) aligned, char (*) aligned, ptr aligned, bit (72) aligned);

dcl  ios_$read ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned,
     bit (72) aligned);

dcl  ios_$read_ptr ext entry
    (ptr, fixed bin aligned, fixed bin aligned);

dcl  ios_$write ext entry
    (char (*) aligned, ptr, fixed bin aligned, fixed bin aligned, fixed bin aligned,
     bit (72) aligned);

/*  */

	rh_ptr = addr (rheader);
	sp = addr (status_bits);
	on condition (cleanup)
	     go to RETURN;

	do i = 1 to 2;

	     call ioa_$nnl ("Type ^a tape label:  ", tape_name (i));
	     call ios_$read_ptr (addr (buffer), 32, j);
	     tape_label (i) = substr (buffer, 1, j-1);

	     call ios_$attach (stream_name (i), "nstd_", tape_label (i), mode (i), status_bits);
	     if scode ^= 0
	     then do;
		call com_err_ (scode, "gcos_convert_sst", "Error attaching ^a", tape_label (i));
		go to RETURN;
	     end;
	     tape_is_attached = "1"b;

	end;

	call gcos_gsr_write_$gsr_write_close (stream_name (2), code);
	call gcos_gsr_write_$gsr_write_init (stream_name (2), code);
	if code ^= 0
	then do;
	     call com_err_ (code, "gcos_convert_sst", "Error in gsr_write_init call");
	     go to RETURN;
	end;
	gsr_write_init_was_called = "1"b;

	do i = 1 to 2;

	     call ios_$read (stream_name (1), addr (buffer), 0, 27, j, status_bits);
	     if substr (status_bits, 1, 3) ^= "100"b	/* not eof */
	     then if scode ^= 0
		then do;
		     call com_err_ (scode, "gcos_convert_sst", "ios_$read call(^d)", i);
		     go to RETURN;
		end;

	     if i = 1
	     then do;
		call ios_$write (stream_name (2), addr (buffer), 0, j, k, status_bits);
		if scode ^= 0
		then do;
		     call com_err_ (scode, "gcos_convert_sst", "ios_$write call error");
		     go to RETURN;
		end;
	     end;

	     else
	     do;
		call ios_$order (stream_name (2), "eof", null, status_bits);
		if scode ^= 0
		then do;
		     call com_err_ (scode, "gcos_convert_sst", "Error writing eof");
		     go to RETURN;
		end;
	     end;

	end;

	do while (^end_of_tape);

	     call ios_$read (stream_name (1), addr (buffer), 0, 27, j, status_bits);
	     if substr (status_bits, 1, 3) = "100"b
	     then end_of_tape = "1"b;
	     else
	     if scode ^= 0
	     then do;
		call com_err_ (0, "gcos_convert_sst", "Error from ios_$read");
		go to RETURN;
	     end;

	     if j = 14				/* bcd image */
	     then media_code = "0010"b;
	     else
	     if j = 27				/* binary image */
	     then media_code = "0001"b;
	     else
	     if j ^= 0
	     then do;
		call com_err_ (0, "gcos_convert_sst", "Unrecognized tape record on ^a", tape_label (1));
		go to RETURN;
	     end;

	     call gcos_gsr_write_ (stream_name (2), addr (buffer), j, rheader, end_of_tape, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, "gcos_convert_sst", "Error from gsr_write_");
		go to RETURN;
	     end;

	end;

	call ios_$order (stream_name (2), "eof", null, status_bits);
	if scode ^= 0
	then do;
	     call com_err_ (scode, "gcos_convert_sst", "Error writing eof");
	     go to RETURN;
	end;

	call ios_$read (stream_name (1), addr (buffer), 0, 27, j, status_bits);
	if scode ^= 0
	then do;
	     call com_err_ (scode, "gcos_convert_sst", "Error reading after second eof");
	     go to RETURN;
	end;

	call ios_$write (stream_name (2), addr (buffer), 0, j, k, status_bits);
	if scode ^= 0
	then call com_err_ (scode, "gcos_convert_sst", "Error writing trailer label");

RETURN:

	do i = 1 to 2;

	     if tape_is_attached (i)
	     then do;
		call ios_$detach (stream_name (i), tape_label (i), "", status_bits);
		if scode ^= 0
		then call com_err_ (scode, "gcos_convert_sst", "Error detaching ^a", tape_label (i));
		tape_is_attached (i) = "0"b;
	     end;

	end;

	if gsr_write_init_was_called
	then do;
	     call gcos_gsr_write_$gsr_write_close (stream_name (i), code);
	     if code ^= 0
	     then call com_err_ (code, "gcos_convert_sst", "error closing stream ""^a""", stream_name (2));
	end;

	return;

     end gcos_convert_sst;




		    gcos_make_tape.pl1              11/19/82  1449.3rew 11/19/82  0934.0       84681



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


gcos_make_tape: gmt: proc;


/* Procedure to create gcos tape in standard system format from ascii file.
   Calling sequence is:

   gmt input_pn tape_label -tape_type

   where


   1) input_pn			is the relative path name of the
   ascii segment to be converted


   2) tape_label			is the label of the tape to be
   written

   3) tape_type			is an optional tape type.  If specified,
   it must be "-9", in which case the tape
   label will become tape_label||",9track".
   If not specified, the tape label will
   become tape_label||",7track"


   */


/* DECLARATIONS */
/* ------------ */


/* fixed bin */

dcl (
     al,						/* argument length */
     i,						/* random variable */
     tape_label_len					/* tape label character count */
     ) fixed bin aligned;

dcl (
     code,					/* error code */
     error_table_$badopt ext
     )fixed bin (35) aligned;


/* pointers */

dcl (
     ap,						/* argument pointer */
     sp						/* pointer to ios status string */
     ) ptr aligned;


/* bit strings */

dcl (
     eof init ("0"b)				/* ON when end of ascii file is read */
     ) bit (1) aligned;

dcl (
     rcrdhdr init ("000010000000"b)			/* record header for gcos tape */
     ) bit (12) aligned;

dcl (
     status_bits					/* ios status string */
     ) bit (72) aligned;


/* character strings */

dcl  nl char (1) unaligned init ("
");						/* new line character */

dcl (
     dim_name init ("nstd_"),				/* name of output dim */
     tape_label_suffix init (",7track")			/* for making tape label */
     ) char (8) aligned;

dcl (
     tape_label					/* actual tape label */
     ) char (32) aligned;

dcl (
     word14					/* buffer for writing tape */
     ) char (56) aligned;

dcl (
     input_buffer					/* for reading segment */
     ) char (84) aligned;

dcl (
     input_pn					/* path-name of input segment */
     ) char (168) aligned;


/* masks */

dcl  arg char (al) based (ap);			/* argument mask */

dcl 1 status aligned based (sp),			/* for checking io status */
    2 scode fixed bin aligned,
    2 pad bit (9) unaligned,
    2 eof bit (1) unaligned;


/* builtin functions */

dcl (
     addr,
     null,
     index,
     substr
     ) builtin;

/* conditions */

dcl (
     cleanup
     ) condition;


/* external entries */

dcl  com_err_ ext entry
     options (variable);

dcl  cu_$arg_ptr ext entry
    (fixed bin aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned);

dcl  cv_ascii_to_bcd_ ext entry
    (ptr aligned, ptr aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_ ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_$gsr_write_close ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_$gsr_write_init ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$order ext entry
    (char (*) aligned, char (*) aligned, ptr aligned, bit (72) aligned);

dcl  ios_$read ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned);

dcl  ios_$setsize ext entry
    (char (*) aligned, fixed bin aligned, bit (72) aligned);

dcl  ios_$write ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned);

/*  */

	go to COMMON;

gcos_make_file: gmf: entry;

	dim_name = "file_";				/* attach output to file */

COMMON:

	sp = addr (status_bits);			/* pointer to ios status string */
	on condition (cleanup)			/* establish cleanup handler */
	     call wrap_up;

	call get_arg (1);				/* fetch ascii file path-name */
	if code ^= 0				/* missing argument */
	then return;

	input_pn = arg;				/* remember (for detaching) */
	call ios_$attach ("gmt_input", "file_", input_pn, "r", status_bits); /* attach file */
	if scode ^= 0				/* error attaching file */
	then do;
	     call com_err_ (scode, "gmt", "Error attaching ^a", input_pn);
	     return;
	end;

	call get_arg (2);				/* fetch tape name */
	if code ^= 0				/* missing argument */
	then do;
	     call wrap_up;
	     return;
	end;

	tape_label_len = al;			/* get length */
	tape_label = arg;				/* and label */

	call get_arg (3);				/* fetch option */
	if code = 0				/* an option is present */
	then do;
	     if dim_name ^= "nstd_"			/* error, tape option for file output */
	     then go to BADOPT;
	     if arg = "-9"				/* request for 9 track tape */
	     then tape_label_suffix = ",9track";
	     else					/* invalid option */
	     do;
BADOPT:
		call com_err_ (error_table_$badopt, "gmt", "^a", arg);
		call wrap_up;
		return;
	     end;
	end;

	if dim_name ^= "nstd_"			/* file output */
	then tape_label_suffix = ".bcd";		/* file name = "name.bcd" */

	tape_label = substr (tape_label, 1, tape_label_len)||tape_label_suffix; /* make tape label */

	call ios_$attach ("gmt_output", dim_name, tape_label, "w", status_bits); /* attach tape */
	if scode ^= 0				/* error attaching tape */
	then do;
	     call com_err_ (scode, "gmt", "Error attaching ^a", tape_label);
	     call wrap_up;
	     return;
	end;

	if dim_name ^= "nstd_"			/* not testing */
	then do;
	     call ios_$setsize ("gmt_output", 36, status_bits); /* set element size to full word */
	     if scode ^= 0				/* error setting element size */
	     then do;
		call com_err_ (scode, "gmt", "Error setting element size");
		call wrap_up;
		return;
	     end;
	end;

	call gcos_gsr_write_$gsr_write_init ("gmt_output", code); /* initialize write proc */
	if code ^= 0				/* error in initialization */
	then do;
	     call com_err_ (code, "gmt", "Error initializing gsr_write");
	     call wrap_up;
	     return;
	end;

	input_buffer = tape_label;			/* first write is tape label */
	call cv_ascii_to_bcd_ (addr (input_buffer), addr (word14), code);
	if code ^= 0
	then do;
	     call com_err_ (0, "gmt", "Error converting tape label ^a to bcd", tape_label);
	     call wrap_up;
	     return;
	end;

	if dim_name = "nstd_"			/* output is to tape */
	then do;

	     call ios_$write ("gmt_output", addr (word14), 0, 14, i, status_bits); /* write tape label */
	     if scode ^= 0				/* error writing tape label */
	     then do;
		call com_err_ (scode, "gmt", "Error writing tape label");
		call wrap_up;
		return;
	     end;

	     call ios_$order ("gmt_output", "eof", null, status_bits); /* eof mark follows tape label */
	     if scode ^= 0				/* error in order call */
	     then do;
		call com_err_ (scode, "gmt", "Error in order call to write eof mark");
		call wrap_up;
		return;
	     end;

	end;

	do while (^eof);				/* loop for writing body of tape */

	     input_buffer = "";			/* blank out reading space */

	     call ios_$read ("gmt_input", addr (input_buffer), 0, 84, i, status_bits); /* read a line of input */
	     if scode ^= 0				/* error reading */
	     then do;
		call com_err_ (scode, "gmt", "Error reading ^a", input_pn);
		call wrap_up;
		return;
	     end;

	     i = index (input_buffer, nl);		/* find new_line character */
	     if i ^= 0				/* and blank it out */
	     then substr (input_buffer, i, 1) = " ";

	     if status.eof				/* end of input */
	     then eof = "1"b;			/* remember */

	     call cv_ascii_to_bcd_ (addr (input_buffer), addr (word14), code); /* convert to bcd */
	     if code ^= 0				/* conversion error */
	     then do;
		call com_err_ (0, "gmt", "Invalid input: ^a", input_buffer);
		call wrap_up;
		return;
	     end;

	     call gcos_gsr_write_ ("gmt_output", addr (word14), 14, rcrdhdr, eof, code); /* write bcd */
	     if code ^= 0				/* error writing bcd */
	     then do;
		call com_err_ (code, "gmt", "Error writing tape record");
		call wrap_up;
		return;
	     end;

	end;

	if dim_name = "nstd_"			/* not testing */
	then do i = 1 to 2;				/* put two eof marks at end of tape */

	     call ios_$order ("gmt_output", "eof", null, status_bits);
	     if scode ^= 0				/* error writing eofs */
	     then do;
		call com_err_ (code, "gmt", "Error writing final eofs");
		call wrap_up;
		return;
	     end;

	end;

	call wrap_up;

/*  */

get_arg:	proc (an);

dcl (
     an						/* argument number */
     ) fixed bin aligned;

	     call cu_$arg_ptr (an, ap, al, code);	/* fetch an argument */
	     if code ^= 0				/* print error message */
	     then if an < 3				/* not option */
		then call com_err_ (code, "gmt");
	     return;

	end get_arg;



wrap_up:	proc;					/* do final detaching */

	     call ios_$detach ("gmt_input", input_pn, "", status_bits);
	     call gcos_gsr_write_$gsr_write_close ("gm_output", code);
	     call ios_$detach ("gmt_output", tape_label, "", status_bits);
	     return;

	end wrap_up;


     end gcos_make_tape;




		    gcos_print_file.pl1             11/19/82  1449.3rew 11/19/82  0934.2       80145



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


gcos_print_file: gpf: proc;


/* DECLARATIONS */
/* ------------ */



/* fixed bin */
/* ----- --- */

dcl (
     al,						/* argument length */
     arg_count,					/* argument count */
     i,						/* loop index */
     line_length					/* length of line read */
     ) fixed bin aligned;

dcl (
     bitcnt					/* bit count returned from status_mins */
     ) fixed bin (24) aligned;

dcl (
     code,					/* error code */
     error_table_$noarg ext,
     error_table_$badopt ext
     ) fixed bin (35) aligned;


/* bit strings */
/* --- ------- */

dcl (
     brief init ("0"b),				/* ON if brief option specified */
     data_type,					/* from gcos_read_line_: "1"b = bcd, "0"b = binary */
     end_of_input,					/* ON when end of input is read */
     input_is_a_file init ("1"b),			/* ON if input is from a file */
     input_is_attached init ("0"b),			/* ON if input device is attached */
     nine_track_read_wanted init ("0"b),		/* ON if nine-track tape is to be read */
     no_arguments_were_found init ("1"b),		/* ON until a non-option argument is found */
     input_was_read init ("0"b),			/* ON after first successful write call */
     read_init_was_called init ("0"b)			/* ON after gsr_read_init is called */
     ) bit (1) aligned;

dcl (
     status_bits					/* returned status from ios_ calls */
     ) bit (72) aligned;

dcl (
     line						/* bit equivalent of line read by gcos_read_line_ */
     ) bit (980) aligned;


/* character strings */
/* --------- ------- */

dcl (
     option					/* fixed location for option arguments */
     ) char (4) aligned;

dcl (
     device_name init ("file_")			/* attach name for input device */
     ) char (8) aligned;

dcl (
     input_pn					/* input path-name or tape label */
     ) char (168) aligned;


/* pointers */
/* -------- */

dcl (
     ap,						/* argument pointer */
     line_ptr,					/* pointer to bit string read by gcos_read_line_ */
     sp						/* pointer to returned status bits from ios_ */
     ) ptr aligned;


/* conditions */
/* ---------- */

dcl (
     cleanup
     ) condition;


/* built in functions */
/* ----- -- --------- */

dcl (
     addr,
     null,
     substr
     ) builtin;


/* masks */
/* ----- */

dcl  arg_mask char (al) unaligned based (ap);		/* argument mask */

dcl 1 status aligned based (sp),			/* for checking returned status from ios_ calls */
    2 scode fixed bin (35) aligned;			/* error code portion of status */


/* external entries */
/* -------- ------- */

dcl  com_err_ ext entry
     options (variable);

dcl  cu_$arg_count ext entry
    (fixed bin aligned);

dcl  cu_$arg_ptr ext entry
    (fixed bin aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned);

dcl  gcos_read_line_ ext entry
    (ptr aligned, fixed bin aligned, bit (1) aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_read_line_$read_line_init ext entry
    (bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_write_line_ ext entry
    (ptr aligned, bit (1) aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_read_$gsr_read_close ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$setsize ext entry
    (char (*) aligned, fixed bin aligned, bit (72) aligned);

/*  */
	line_ptr = addr (line);			/* pointer to bit string read by gcos_read_line_ */
	sp = addr (status_bits);			/* pointer to returned status bits from ios_ */

	on condition (cleanup)			/* establish cleanup handler */
	     call detach_input;

	call cu_$arg_count (arg_count);		/* get number of arguments */
	if arg_count = 0				/* error, no arguments */
	then do;
	     call com_err_ (error_table_$noarg, "gcos_print_file", "");
	     return;
	end;


/*  */

	do i = 1 to arg_count;			/* ARGUMENT LOOP */

	     call cu_$arg_ptr (i, ap, al, code);	/* fetch an argument */
	     if code ^= 0				/* fatal error */
	     then do;
		call com_err_ (code, "gcos_print_file", "Error fetching argument (^d)", i);
		call detach_input;
		return;
	     end;

	     if substr (arg_mask, 1, 1) = "-"		/* argument is an option */
	     then do;

		option = arg_mask;			/* fix the argument */

		if option = "-ti"			/* input is from tape */
		then do;
		     input_is_a_file = "0"b;
		     device_name = "nstd_";
		end;

		else
		if option = "-fi"			/* input is from a file */
		then do;
		     input_is_a_file = "1"b;
		     device_name = "file_";
		end;

		else
		if option = "-9"			/* request to read nine-track tape */
		then nine_track_read_wanted = "1"b;

		else
		if option = "-7"			/* request to read seven-track tape */
		then nine_track_read_wanted = "0"b;

		else
		if option = "-bf"			/* brief option */
		then brief = "1"b;			/* remember */

		else
		if option = "-lg"			/* long option */
		then brief = "0"b;			/* remember */

		else				/* unrecognized option */
		do;
		     call com_err_ (error_table_$badopt, "gcos_print_file", option);
		     return;
		end;

	     end;

	     else					/* argument is not an option */
	     do;

		no_arguments_were_found = "0"b;

		call detach_input;
		if input_is_a_file
		then do;
		     if nine_track_read_wanted	/* error, tape option on file request */
		     then do;
			call com_err_ (0, "gcos_print_file", "Nine track read specified for file input:  ^a", input_pn);
			go to END_LOOP;
		     end;
		     input_pn = arg_mask;		/* set path-name of input file */

		end;

		else				/* tape input */
		do;
		     input_pn = arg_mask||",7track";	/* make up tape label */
		     if nine_track_read_wanted
		     then substr (input_pn, al+2, 1) = "9";
		end;

		call ios_$attach ("input_stream", device_name, input_pn, "r", status_bits);
		if scode ^= 0			/* error attaching input stream */
		then do;
		     call com_err_ (scode, "gcos_print_file", "Error attaching ^a", input_pn);
		     return;
		end;
		else				/* input stream attached */
		input_is_attached = "1"b;		/* remember */

		if input_is_a_file			/* input is from a file */
		then do;
		     call ios_$setsize ("input_stream", 36, status_bits); /* set input size to full word */
		     if scode ^= 0			/* error setting input size */
		     then do;
			call com_err_ (scode, "gcos_print_file", "Error setting element size on input_stream");
			call detach_input;
			return;
		     end;
		end;

		call gcos_read_line_$read_line_init (input_is_a_file, code); /* initialization for reads */
		if code ^= 0
		then do;
		     call com_err_ (0, "gcos_print_file", "Error in read initialization call");
		     call detach_input;
		     return;
		end;
		read_init_was_called = "1"b;		/* remember call was made */

		end_of_input = "0"b;
		do while (^end_of_input);

		     call gcos_read_line_ (line_ptr, line_length, data_type, end_of_input, code);
						/* read a line of output */
		     if code ^= 0			/* error reading line */
		     then do;
			call com_err_ (code, "gcos_print_file", "Error reading from ^a", input_pn);
			call detach_input;
			return;
		     end;

		     if line_length ^= 0		/* something was read */
		     then do;
			input_was_read = "1"b;	/* remember */

			call gcos_write_line_ (line_ptr, data_type, brief, code); /* write the line */
			if code > 1		/* error writing line */
			then do;
			     call com_err_ (code, "gcos_print_file", "Error writing into user_output");
			     call detach_input;
			     return;
			end;

		     end;

		end;

		if ^input_was_read			/* implies no input was read */
		then call com_err_ (0, "gcos_print_file", "Zero length input: ^a", input_pn);

	     end;

END_LOOP:

	end;					/* END OF ARGUMENT LOOP */

	if no_arguments_were_found			/* all arguments were options */
	then call com_err_ (error_table_$noarg, "gcos_print_file", "");

	call detach_input;

	return;

/*  */

/* INTERNAL PROCEDURES */



detach_input: proc;

	     if input_is_attached
	     then do;

		call ios_$detach ("input_stream", input_pn, "", status_bits);
		if scode ^= 0
		then call com_err_ (scode, "gcos_print_file", "Error detaching ^a", input_pn);

	     end;

	     input_is_attached = "0"b;

	     if read_init_was_called
	     then do;
		call gcos_gsr_read_$gsr_read_close ("input_stream", code);
		read_init_was_called = "0"b;
	     end;

	     return;

	end detach_input;



     end gcos_print_file;




		    gcos_read_line_.pl1             11/19/82  1449.3rew 11/19/82  0934.5       35919



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


gcos_read_line_: proc (a_line_ptr, a_line_len, a_data_type, a_eof, a_code);



/* DECLARATIONS */
/* ------------ */


/* fixed bin */
/* ----- --- */

dcl (
     a_line_len,					/* length of read line in words (argument) */
     i,						/* loop index */
     j,						/* word count from ios_$read call */
     junk (14)					/* buffer for ios_$read call */
     ) fixed bin aligned;

dcl (
     a_code					/* error code (argument) */
     )fixed bin (35) aligned;


/* bit strings */
/* --- ------- */

dcl (
     a_data_type,					/* 1 = bcd, 2 = binary (argument) */
     a_eof,					/* ON when eof is encountered (argument) */
     a_input_is_a_file				/* ON when input is a file (argument) */
     ) bit (1) aligned;

dcl (
     record_hdr					/* record header from imcv format */
     ) bit (12) aligned;

dcl  status_bits bit (72) aligned;			/* returned status from ios_ */


/* pointers */
/* -------- */

dcl (
     a_line_ptr,					/* pointer to read line (argument) */
     line_ptr,					/* pointer to read line (internal) */
     rh_ptr,					/* pointer to record header data */
     sp						/* pointer to status returned from ios_ */
     ) ptr aligned;


/* built in functions */
/* ----- -- --------- */

dcl (
     addr,
     null,
     substr
     ) builtin;


/* masks */
/* ----- */

dcl 1 record_hdr_mask aligned based (rh_ptr),		/* for looking at record header */
    2 pad bit (2) unaligned,
    2 media_code bit (4) unaligned;

dcl 1 status aligned based (sp),			/* ios_ status mask */
    2 scode fixed bin (35) aligned;			/* error code portion */

dcl  line bit (a_line_len*36) aligned based (line_ptr);	/* for returning read line as bit string */


/* external entries */
/* -------- ------- */

dcl  gcos_gsr_read_ ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_read_$gsr_read_init ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  ios_$read ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned);

/*  */

	rh_ptr = addr (record_hdr);			/* pointer to record header data */
	sp = addr (status_bits);			/* pointer to status returned from ios_ */
	call gcos_gsr_read_ ("input_stream", line_ptr, a_line_len, record_hdr, a_eof, a_code); /* read a line */
	if a_code ^= 0
	then return;

	if a_eof					/* an end of file was encountered */
	then do;
	     line_ptr = null;			/* return appropriate arguments */
	     a_line_len = 0;
	     return;
	end;

	a_line_ptr -> line = line;			/* return line as bit string */

	if media_code = "0010"b			/* bcd line */
	then a_data_type = "1"b;
	else					/* binary line */
	a_data_type = "0"b;

	return;



read_line_init: entry (a_input_is_a_file, a_code);

	rh_ptr = addr (record_hdr);			/* pointer to record header data */
	sp = addr (status_bits);			/* pointer to status returned from ios_ */
	call gcos_gsr_read_$gsr_read_init ("input_stream", a_code);
	if a_code = 0				/* successful initialization */
	then if ^a_input_is_a_file			/* input is system standard tape */
	     then do i = 1 to 2;			/* get rid of tape label, tape mark */
		call ios_$read ("input_stream", addr (junk (1)), 0, 14, j, status_bits);
		if substr (status_bits, 1, 3) ^= "100"b /* not an EOF mark */
		then if scode ^= 0			/* actual error */
		     then do;
			a_code = scode;		/* return error code */
			return;
		     end;
	     end;

	return;



     end gcos_read_line_;




		    gcos_write_line_.pl1            11/19/82  1449.3rew 11/19/82  0934.7       25974



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


gcos_write_line_: proc (a_line_ptr, a_data_type, a_brief, a_code);


/* DECLARATIONS */
/* ------------ */


/* fixed bin */
/* ----- --- */

dcl (
     i,						/* random variable */
     write_size					/* number of words to write */
     ) fixed bin aligned;

dcl (
     a_code					/* error code (argument) */
     ) fixed bin (35) aligned;


/* pointers */
/* -------- */

dcl (
     a_line_ptr,					/* pointer to input line (argument) */
     line_ptr,					/* pointer to input line */
     write_ptr					/* pointer to output line */
     ) ptr aligned;


/* bit strings */
/* --- ------- */

dcl (
     a_brief,					/* ON if brief option specified by caller (argument) */
     a_data_type,					/* "1"b = bcd, "0"b = binary (argument) */
     brief,					/* ON if brief option specified by caller */
     data_is_bcd					/* ON if data is bcd */
     ) bit (1) aligned;

/* character strings */
/* --------- ------- */

dcl  nl char (1) aligned init ("
");						/* new line character a la VLV */

dcl (
     ascii					/* output line */
     ) char (85) aligned;


/* built in functions */
/* ----- -- --------- */

dcl (
     addr,
     substr
     ) builtin;


/* external entries */
/* -------- ------- */

dcl  cv_bcd_to_ascii_ ext entry
    (ptr aligned, ptr aligned);

dcl  cv_bin_to_ascii_ ext entry
    (ptr aligned, ptr aligned, fixed bin (35) aligned);

dcl  ios_$write_ptr ext entry
    (ptr aligned, fixed bin aligned, fixed bin aligned);

/*  */

	line_ptr = a_line_ptr;			/* copy in arguments */
	data_is_bcd = a_data_type;
	brief = a_brief;

	write_ptr = addr (ascii);			/* set internal variables */
	if brief
	then write_size = 81;
	else
	write_size = 85;
	ascii = "";

	if data_is_bcd
	then do;

	     a_code = 0;

	     call cv_bcd_to_ascii_ (line_ptr, write_ptr);
	     if brief
	     then substr (ascii, 81, 1) = nl;
	     else
	     substr (ascii, 82, 4) = "BCD"||nl;

	end;

	else					/* binary card */
	do;

	     call cv_bin_to_ascii_ (write_ptr, write_ptr, a_code);
	     if a_code ^= 0
	     then do;
		if brief
		then return;
		else
		do;
		     write_size = 27;
		     ascii = "---UNINTERPRETED BINARY IMAGE"||nl;
		end;
	     end;
	     else
	     do;
		if brief
		then substr (ascii, 81, 1) = nl;
		else
		substr (ascii, 82, 4) = "BIN"||nl;
	     end;

	end;

	call ios_$write_ptr (write_ptr, 0, write_size);

	return;

     end gcos_write_line_;





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
