



		    card_codes_.alm                 11/15/82  1807.9rew 11/15/82  1532.4       40428



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" CARD_CODES_ - Reader/Punch Card Code Translation Tables.
"	redesigned 6/25/75 by Noel I. Morris


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


" The reader translation table is referenced by computing an index
" from 12-11-0 rows, 1-2-3-4-5-6-7 rows, and 8-9 rows.  Only one punch
" may be found in the 1-2-3-4-5-6-7 rows.
"
" The punch translation table is referenced by using the ASCII character
" as an index.


	name	card_codes_

	segdef	mcc_reader_codes
	segdef	mcc_punch_codes


" 

mcc_reader_codes:
	vfd	o9/040,o9/071,o9/070,o9/777,o9/067,o9/004,o9/042,o9/032
	vfd	o9/066,o9/777,o9/075,o9/777,o9/065,o9/777,o9/047,o9/025
	vfd	o9/064,o9/777,o9/100,o9/024,o9/063,o9/777,o9/043,o9/777
	vfd	o9/062,o9/026,o9/072,o9/777,o9/061,o9/777,o9/140,o9/777

	vfd	o9/060,o9/132,o9/131,o9/777,o9/130,o9/033,o9/077,o9/007
	vfd	o9/127,o9/027,o9/076,o9/006,o9/126,o9/777,o9/137,o9/005
	vfd	o9/125,o9/777,o9/045,o9/777,o9/124,o9/777,o9/054,o9/777
	vfd	o9/123,o9/777,o9/777,o9/777,o9/057,o9/777,o9/777,o9/777

	vfd	o9/055,o9/122,o9/121,o9/030,o9/120,o9/777,o9/136,o9/037
	vfd	o9/117,o9/010,o9/073,o9/036,o9/116,o9/012,o9/051,o9/035
	vfd	o9/115,o9/777,o9/052,o9/034,o9/114,o9/023,o9/044,o9/777
	vfd	o9/113,o9/022,o9/041,o9/777,o9/112,o9/021,o9/777,o9/031

	vfd	o9/175,o9/172,o9/171,o9/777,o9/170,o9/777,o9/777,o9/777
	vfd	o9/167,o9/777,o9/777,o9/777,o9/166,o9/777,o9/777,o9/777
	vfd	o9/165,o9/777,o9/777,o9/777,o9/164,o9/777,o9/777,o9/777
	vfd	o9/163,o9/777,o9/777,o9/777,o9/176,o9/777,o9/777,o9/777

	vfd	o9/046,o9/111,o9/110,o9/777,o9/107,o9/777,o9/174,o9/017
	vfd	o9/106,o9/777,o9/053,o9/016,o9/105,o9/011,o9/050,o9/015
	vfd	o9/104,o9/777,o9/074,o9/014,o9/103,o9/003,o9/056,o9/013
	vfd	o9/102,o9/002,o9/134,o9/777,o9/101,o9/001,o9/777,o9/777

	vfd	o9/173,o9/151,o9/150,o9/777,o9/147,o9/777,o9/777,o9/777
	vfd	o9/146,o9/777,o9/777,o9/777,o9/145,o9/777,o9/133,o9/777
	vfd	o9/144,o9/777,o9/777,o9/777,o9/143,o9/777,o9/777,o9/777
	vfd	o9/142,o9/777,o9/777,o9/777,o9/141,o9/777,o9/777,o9/000

	vfd	o9/777,o9/162,o9/161,o9/777,o9/160,o9/777,o9/777,o9/777
	vfd	o9/157,o9/777,o9/777,o9/777,o9/156,o9/777,o9/135,o9/777
	vfd	o9/155,o9/777,o9/777,o9/777,o9/154,o9/777,o9/777,o9/777
	vfd	o9/153,o9/777,o9/777,o9/777,o9/152,o9/777,o9/777,o9/020
	vfd	o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777
	vfd	o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777
	vfd	o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777
	vfd	o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777,o9/777

" 

mcc_punch_codes:
	vfd	o12/5403,o12/4401,o12/4201,o12/4101,o12/0005,o12/1023
	vfd	o12/1013,o12/1007,o12/2011,o12/4021,o12/2021,o12/4103
	vfd	o12/4043,o12/4023,o12/4013,o12/4007,o12/6403,o12/2401
	vfd	o12/2201,o12/2101,o12/0043,o12/0023,o12/0201,o12/1011
	vfd	o12/2003,o12/2403,o12/0007,o12/1005,o12/2043,o12/2023
	vfd	o12/2013,o12/2007,o12/0000,o12/2202,o12/0006,o12/0102
	vfd	o12/2102,o12/1042,o12/4000,o12/0022,o12/4022,o12/2022
	vfd	o12/2042,o12/4012,o12/1102,o12/2000,o12/4102,o12/1400
	vfd	o12/1000,o12/0400,o12/0200,o12/0100,o12/0040,o12/0020
	vfd	o12/0010,o12/0004,o12/0002,o12/0001,o12/0202,o12/2012
	vfd	o12/4042,o12/0012,o12/1012,o12/1006,o12/0042,o12/4400
	vfd	o12/4200,o12/4100,o12/4040,o12/4020,o12/4010,o12/4004
	vfd	o12/4002,o12/4001,o12/2400,o12/2200,o12/2100,o12/2040
	vfd	o12/2020,o12/2010,o12/2004,o12/2002,o12/2001,o12/1200
	vfd	o12/1100,o12/1040,o12/1020,o12/1010,o12/1004,o12/1002
	vfd	o12/1001,o12/5022,o12/4202,o12/6022,o12/2006,o12/1022
	vfd	o12/0402,o12/5400,o12/5200,o12/5100,o12/5040,o12/5020
	vfd	o12/5010,o12/5004,o12/5002,o12/5001,o12/6400,o12/6200
	vfd	o12/6100,o12/6040,o12/6020,o12/6010,o12/6004,o12/6002
	vfd	o12/6001,o12/3200,o12/3100,o12/3040,o12/3020,o12/3010
	vfd	o12/3004,o12/3002,o12/3001,o12/5000,o12/4006,o12/3000
	vfd	o12/3400,o12/0000



	end




		    card_dim.pl1                    11/15/82  1807.9rew 11/15/82  1458.6       30438



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* CARD_DIM - This the the common code for all card I/O DIMs. */
/* modified from earlier code by Noel I. Morris, June 1975. */


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


card_attach: proc (ioname, type, ioname2, mode, iostatus, sdb_ptr);

dcl  ioname char (*),				/* name used in attachment */
     type char (*),					/* name of DIM being attached */
     ioname2 char (*),				/* name of DIM being attached to */
     mode char (*),					/* mode of attachment */
     iostatus bit (72) aligned;			/* status bits */

dcl  barea area ((16374)) based (areaptr),		/* allocation area */
     ap ptr;					/* automatic pointer to area */

dcl  error_table_$ionmat fixed bin (35) ext,
     error_table_$no_room_for_dsb fixed bin (35) ext;

dcl  get_system_free_area_ entry (ptr),
     ios_$setsize entry (char (*) aligned, fixed bin, bit (72) aligned),
     ios_$order entry (char (*) aligned, char (*), ptr, bit (72) aligned),
     ios_$changemode entry (char (*) aligned, char (*), char (*), bit (72) aligned);

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

		/*  */

% include card_sdb;

		/*  */

/* This is the "attach" entry point for all card pseudo-DIMs (i.e. raw, mcc, viipunch, & flipper). */

	iostatus = "0"b;

	if sdb_ptr ^= null () then do;		/* previous attachment indicated */
	     substr (iostatus, 1, 36) = unspec (error_table_$ionmat);
	     return;
	end;

	call get_system_free_area_ (ap);
	allocate SDB in (ap -> barea) set (sdb_ptr);
	if sdb_ptr = null () then do;
	     substr (iostatus, 1, 36) = unspec (error_table_$no_room_for_dsb);
	     return;
	end;

	outer_module_name = type;
	attachment_list_ptr = addr (stream_name);
	next_stream_ptr = null ();
	name_size = 32;
	stream = ioname2;
	areaptr = ap;
	modes = "0"b;				/* Clear all mode settings. */

	call ios_$setsize (stream, 972, iostatus);	/* Insure element is one card. */

	return;




/* This is the "detach" entry point for all card pseudo-DIMs. */

card_detach: entry (sdb_ptr, ioname2, mode, iostatus);

	free SDB in (areaptr -> barea);
	substr (iostatus, 52, 1) = "1"b;		/* Your detach bit */

	return;

		/*  */

card_order: entry (sdb_ptr, order, infop, iostatus);

dcl  order char (*),				/* order to be executed */
     infop ptr;					/* pointer to info for order */


	call ios_$order (stream, order, infop, iostatus);/* Relay the call. */

	return;



card_changemode: entry (sdb_ptr, new_mode, old_mode, iostatus);

dcl  new_mode char (*),				/* new mode setting */
     old_mode char (*);				/* previous mode setting */


	call ios_$changemode (stream, new_mode, old_mode, iostatus);
						/* Relay the call. */
	return;



     end card_attach;




		    card_util_.pl1                  11/15/82  1807.9rew 11/15/82  1458.6       43524



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


card_util_: proc;

/* This procedure implements the mapping of mode names to a compact bit string. */
/* The bit string is used when calling the translate entry to set the operations which are performed. */

/* Created by DRV in 1977 */
/* Modified by J. C. Whitmore, Feb 1980, to remove the punch_nl and binary modes (unused) and to increase the */
/*	size of the orig_string variable to 2000 chars for HASP records */


dcl  test_mode char (*);
dcl  new_modes char (*);
dcl  old_modes char (*);
dcl  mode_bits bit (36);
dcl  a_code fixed bin (35);
dcl  string char (*) var;

dcl  last_char fixed bin;
dcl  char char (1);
dcl  orig_len fixed bin;
dcl  orig_string char (2000) aligned;			/* our copy of the card image */
dcl  pos fixed bin;
dcl  i fixed bin;
dcl  n fixed bin;
dcl  mode_len fixed bin;
dcl  val bit (1);
dcl  mode char (32) var;
dcl  ret_modes char (256) var;

dcl 1 modes based (addr (mode_bits)),
    2 trim bit (1) unal,
    2 lower_case bit (1) unal,
    2 add_nl bit (1) unal,
    2 contin bit (1) unal,
    2 pad bit (30) unal;

dcl  space char (1) int static init (" ");
dcl  lower_case char (26) int static init ("abcdefghijklmnopqrstuvwxyz");
dcl  upper_case char (26) int static init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  NL char (1) int static init ("
");

dcl  error_table_$bad_mode ext fixed bin (35);

dcl (substr, rtrim, ltrim, search, verify, reverse, length, translate, copy) builtin;


modes:	entry (new_modes, mode_bits, old_modes, a_code);

	a_code = 0;

	if modes.lower_case then ret_modes = "lower_case,";
	else ret_modes = "^lower_case,";
	if modes.add_nl then ret_modes = ret_modes || "add_nl,";
	else ret_modes = ret_modes || "^add_nl,";
	if modes.contin then ret_modes = ret_modes || "contin,";
	else ret_modes = ret_modes || "^contin,";
	if modes.trim then ret_modes = ret_modes || "trim.";
	else ret_modes = ret_modes || "^trim.";
	old_modes = ret_modes;


	n = verify (reverse (new_modes), " .,;");	/* any thing there? */
	if n = 0 then return;			/* guess not */
	mode_len = length (new_modes) - n + 1;

	do i = 1 repeat i + n while (i < mode_len);
	     n = search (substr (new_modes, i), ",;.");
	     if n = 0 then n = mode_len - i + 2;	/* no breaks, take remaining */
	     mode = ltrim (rtrim (substr (new_modes, i, n - 1))); /* get mode */
	     if substr (mode, 1, 1) = "^" then do;
		val = "0"b;
		pos = 2;
	     end;
	     else do;
		val = "1"b;
		pos = 1;
	     end;
	     if substr (mode, pos) = "trim" then modes.trim = val;
	     else if substr (mode, pos) = "lower_case" then modes.lower_case = val;
	     else if substr (mode, pos) = "add_nl" then modes.add_nl = val;
	     else if substr (mode, pos) = "contin" then modes.contin = val;

	     else a_code = error_table_$bad_mode;
	end;
	return;

translate: entry (mode_bits, string);

	orig_len = length (string);			/* save the original string length */
	last_char = length (rtrim (string));		/* find last non-blank */
	if modes.lower_case & last_char > 0 then do;
	     orig_string = string;			/* copy the string */
	     string = "";				/* we will rebuild it */
	     do i = 1 to last_char;			/* look at each char given */
		char = substr (orig_string, i, 1);	/* get the next char */
		if char = "\" & i < last_char then do;	/* don't convert a trailing \ */
		     i = i + 1;
		     char = substr (orig_string, i, 1); /* skip the escape char */
		     if char = "<" then char = "[";
		     else if char = ">" then char = "]";
		     else if char = "(" then char = "{";
		     else if char = ")" then char = "}";
		end;
		else char = translate (char, lower_case, upper_case);
		string = string || char;		/* add to the input string */
	     end;
	     string = string || copy (" ", orig_len - length (string)); /* pad out to orig length */
	end;
	if modes.trim then string = rtrim (string);
	if modes.contin then do;
	     i = length (rtrim (string));		/* find last non-blank char */
	     if i > 0 then do;
		if substr (string, i, 1) ^= "\" & modes.add_nl then string = string || NL;
		else if substr (string, i, 1) = "\" then string = substr (string, 1, i - 1); /* drop contin mark */
	     end;
	     else if modes.add_nl then string = string || NL;
	end;
	else if modes.add_nl then string = string || NL;
	return;

test_mode: entry (mode_bits, test_mode) returns (bit (1));

	return ("0"b);

     end card_util_;




		    check_cd.alm                    11/15/82  1807.9rew 11/15/82  1532.1       11601



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"	This routine will compute the full word logical checksum
"	of a binary card image pointed to by P.
"	T.P. Skinner April 1968.
"	Modified 7/7/75 by Noel I. Morris
"
"	bit36 = check_cd (p);
"


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


	name	check_cd

	segdef	check_cd


check_cd:	
	eppbp	ap|2,*		get ptr to data
	eppbp	bp|0,*

	lda	bp|0		start with word 0
	eax1	0		initialize index
	ldi	=o4000,dl		turn on overflow mask
	rpt	22,1
	awca	bp|2,1		add words 2 thru 23
	awca	0,dl		add in last carry

	sta	ap|4,*		return computed checksum
	short_return

	end	




		    cpz.alm                         11/15/82  1807.9rew 11/15/82  1532.2        9747



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

"	"	"	"	"	"	"	"	"
"
"	This is the I/O switch transfer vector for the cpz outer module.
"
"	"	"	"	"	"	"	"	"

	name	cpz
	entry	cpzmodule

	segref	cpz_dim,cpz_attach,cpz_detach,cpz_write,cpz_order,cpz_setsize,cpz_getsize
	segref	ios_,no_entry

cpzmodule:
	tra	*+1,6

	tra	cpz_attach
	tra	cpz_detach
	tra	no_entry
	tra	cpz_write
	tra	no_entry
	tra	cpz_order
	tra	no_entry
	tra	no_entry
	tra	cpz_setsize
	tra	cpz_getsize
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry

	end	cpzmodule




		    cpz_status_table_.alm           09/12/83  1116.2rew 09/12/83  1023.8       22320



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" CPZ_STATUS_TABLE_ - Status Tables for the Card Punch.
"	coded 12/5/74 by Noel I. Morris
"	modified 4/79 by R.J.C. Kissel to add major status 0.

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


	include	status_table

	bool	alert,000001	punch alert flag


" 

	status_table	cpz,(1,1,1,1,0,1,0,0,0,0,1,1,0,1,0,0)

" 
	status_entry	1,(Channel Ready)

	substat_entry	1,000000,,(Ready)

" 

	status_entry	2,(Device Busy)

" 

	status_entry	3,(Device Attention)

	substat_entry	3,000000,in+rp+hlt,(Device off line)
	substat_entry	3,XXXXX1,in+rp+hlt,(Hopper empty or Stacker full)
	substat_entry	3,XXXX1X,in+rp+hlt,(Manual Halt)
	substat_entry	3,0XX1XX,in+rp+hlt,(Chad box full)
	substat_entry	3,0X1XXX,in+rp+hlt,(Feed Failure)
	substat_entry	3,X1XXXX,bk+rp+hlt,(Card jam)

" 

	status_entry	4,(Device Data Alert)

	substat_entry	4,000XX1,bk+rp+hlt,(Transfer timing error)
	substat_entry	4,000X1X,bk+rp+hlt,(Transmission parity alert)
	substat_entry	4,0001XX,alert+bk+rp+hlt,(Punch alert)

" 

	status_entry	6,(Command Reject)

	substat_entry	6,0000X1,bk+rp+hlt,(Invalid op code)
	substat_entry	6,00001X,bk+rp+hlt,(Invalid device code)
	substat_entry	6,000100,bk+rp+hlt,(IDCW parity error)

" 

	status_entry	11,(MPC Attention)

	substat_entry	11,000001,in+rp+hlt,(IAI error)
	substat_entry	11,000010,in+rp+hlt,(DAI error)
	substat_entry	11,000100,in+rp+hlt,(DA Transfer error)

" 

	status_entry	12,(MPC Data Alert)

	substat_entry	12,000001,bk+rp+hlt,(Transmission parity error)
	substat_entry	12,000101,bk+rp+hlt,(DAI error)

" 

	status_entry	14,(MPC Command Reject)

	substat_entry	14,000001,bk+rp+hlt,(Illegal procedure)
	substat_entry	14,000010,bk+rp+hlt,(Illegal logical channel)
	substat_entry	14,001000,bk+rp+hlt,(Device reserved)



	end




		    crz.alm                         11/15/82  1807.9rew 11/15/82  1532.2       10377



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

"	"	"	"	"	"	"	"	"
"
"	This is the I/O switch transfer vector for the crz outer module.
"
"	"	"	"	"	"	"	"	"

	name	crz
	entry	crzmodule

	segref	crz_dim,crz_attach,crz_detach,crz_read,crz_setsize,crz_getsize,crz_changemode
	segref	crz_dim,crz_order
	segref	crz_dim,crz_resetread
	segref	ios_,no_entry

crzmodule:
	tra	*+1,6

	tra	crz_attach
	tra	crz_detach
	tra	crz_read
	tra	no_entry
	tra	no_entry
	tra	crz_order
	tra	crz_resetread
	tra	no_entry
	tra	crz_setsize
	tra	crz_getsize
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	crz_changemode
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry

	end	crzmodule




		    crz_status_table_.alm           09/12/83  1116.2rew 09/12/83  1023.8       23769



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" CRZ_STATUS_TABLE_ - Status Tables for the Card Reader.
"	coded 12/1/74 by Noel I. Morris
"	modified 4/79 by R.J.C. Kissel to add major status 0.

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


	include	status_table



" 

	status_table	crz,(1,1,1,1,0,1,0,0,0,0,1,1,0,1,0,0)

" 
	status_entry	1,(Channel Ready)

	substat_entry	1,000001,,(51-column cards)

" 

	status_entry	2,(Device Busy)

" 

	status_entry	3,(Device Attention)

	substat_entry	3,000000,in+rp+hlt,(Device off line)
	substat_entry	3,XXXXX1,in+rp+hlt,(Hopper empty or Stacker full)
	substat_entry	3,XXXX1X,in+rp+hlt,(Manual Halt)
	substat_entry	3,XXX1X1,in+rp+hlt,(Last batch finished)
	substat_entry	3,0X1XXX,in+rp+hlt,(Feed Alert)
	substat_entry	3,1X1XXX,in+rp+hlt,(Sneak Feed)
	substat_entry	3,X1XXXX,bk+rp+hlt,(Card jam)
	substat_entry	3,1X0XXX,bk+rp+hlt,(Read Alert)

" 

	status_entry	4,(Device Data Alert)

	substat_entry	4,000001,bk+rp+hlt,(Transfer timing error)
	substat_entry	4,000X10,bk+rp+hlt,(Validity check)
	substat_entry	4,0001X0,bk+rp+hlt,(Dual read alert)
	substat_entry	4,001000,bk+rp+hlt,(Feed without read)

" 

	status_entry	6,(Command Reject)

	substat_entry	6,0000X1,bk+rp+hlt,(Invalid op code)
	substat_entry	6,00001X,bk+rp+hlt,(Invalid device code)
	substat_entry	6,000100,bk+rp,(IDCW parity error)

" 

	status_entry	11,(MPC Attention)

	substat_entry	11,000001,in+rp+hlt,(IAI error)
	substat_entry	11,000010,in+rp+hlt,(DAI error)
	substat_entry	11,000100,in+rp+hlt,(DA Transfer error)
	substat_entry	11,001000,in+rp+hlt,(Invalid Punch)

" 

	status_entry	12,(MPC Data Alert)

	substat_entry	12,000001,bk+rp+hlt,(Transmission parity error)
	substat_entry	12,000101,bk+rp+hlt,(DAI error)

" 

	status_entry	14,(MPC Command Reject)

	substat_entry	14,000001,bk+rp+hlt,(Illegal procedure)
	substat_entry	14,000010,bk+rp+hlt,(Illegal logical channel)
	substat_entry	14,001000,bk+rp+hlt,(Device reserved)



	end




		    crzcpz_dim.pl1                  07/18/86  1502.0rew 07/18/86  1235.1      247644



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




/****^  HISTORY COMMENTS:
  1) change(86-06-04,Hartogs), approve(86-06-04,MCR7383),
     audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098):
     Changed to user version constant in rcp_device_info.incl.pl1
                                                   END HISTORY COMMENTS */


crzcpz_dim: procedure;

/* Originally coded by Ammons and Ohlin, June 1971 */


/* Modified 8/74 by Noel I. Morris for I/O Interfacer operation. */
/* Modified to combine reader & punch functions, 12/74 by Noel I. Morris	*/
/* Modified by J. C. Whitmore, 6/78, to delay printing messages until blocking */




dcl  stream_name char (*),				/* Name of current stream */
     crzcpz char (*),				/* Name of  DIM  being attached */
     device char (*),				/* Name of device being attached */
    (mode, new_mode, old_mode) char (*),		/* Device attributes */
     iostatus bit (72) aligned,			/* Status */
     element_size fixed bin (17),			/* Number of bits in element */
     offset fixed bin (17),				/* Offset from wkspptr */
     nelem fixed bin (17),				/* Number of elements requested */
     nelemt fixed bin (17),				/* Number of elements actually transmitted */
     sdb_ptr pointer,				/* Pointer to stream data block */
    (xwkspptr, wkspptr) pointer,			/* Pointer to workspace */
     dvname char (6);				/* name of device type */

dcl  error_table_$ionmat ext fixed bin (35),		/* Error code - IOname already attached */
     error_table_$no_room_for_dsb ext fixed bin (35),	/* Error code - No room available for dsb */
     error_table_$invalid_elsize ext fixed bin (35),	/* Error code - Invalid element size */
     error_table_$invalid_read ext fixed bin (35),	/* Error code - Invalid read */
     error_table_$invalid_write ext fixed bin (35),	/* Error code - Invalid write */
     error_table_$net_timeout ext fixed bin (35),		/* Error code - Connect timed out */
     error_table_$no_operation ext fixed bin (35),	/* Error code - io operation not done */
     error_table_$undefined_order_request ext fixed bin (35), /* Error code - it is obvious, right? */
     error_table_$eof_record ext fixed bin (35);		/* Error code - eof found */

dcl  crz_status_table_$crz_status_table_ ext;
dcl  cpz_status_table_$cpz_status_table_ ext;

dcl (addr, addrel, bin, bit, divide, mod, null, rel, substr, unspec) builtin;



dcl 1 sdb aligned based (sdb_ptr),			/* Declare stream data block */
    2 outer_module_name char (32) aligned,
    2 device_name_list_ptr pointer,
    2 device_name,
      3 next_device_ptr pointer,
      3 name_size fixed bin (17),
      3 name char (32) aligned,
    2 ev_list aligned,				/* Event list for ipc_ */
      3 count fixed bin (17),				/* Event count = Always one */
      3 evchan fixed bin (71),			/* Event evchan name */
    2 devx fixed bin,				/* Device index returned by IOI */
    2 punch bit (1),				/* "0"b => reader; "1"b => punch */
    2 rcp_id bit (36),				/* ID for RCP attachment */
    2 areap ptr,					/* pointer to sdb allocation area */
    2 wsegp ptr,					/* pointer to IOI working segment */
    2 stat_tablep ptr,				/* pointer to status analysis table */
    2 running bit (1),				/* "1"b if channel running */
    2 eof_flag bit (1),				/* EOF recogntion - "1" = on - See order call */
    2 iobegin fixed bin (18),				/* index for starting up I/O */
    2 iocur fixed bin (18),				/* index for queuing next I/O record */
    2 movecur fixed bin (18),				/* index for copying next record */
    2 movestop fixed bin (18),			/* index for stopping data copy */
    2 term_idcw bit (36),				/* IDCW for stopping channel */
    2 io_idcw bit (36),				/* IDCW for reading or punching binary card */
    2 wait_flag bit (1) aligned,			/* waiting for special interrupt flag */
    2 marker_count fixed bin,				/* counter for setting marker interrupts */
    2 error_count fixed bin,				/* count of errors */
    2 card_count fixed bin,				/* number of cards read/punched since last reset */
    2 last_iom_stat bit (72),				/* last useful status bits reported */
    2 print_message bit (1),				/* print the following message before blocking */
    2 message char (256) var;				/* last error message not reported */

dcl  workspace (27) bit (36) based (wkspptr) aligned;	/* Workspace allocated by caller */

dcl 1 wseg based (wsegp) aligned,			/* working segment for I/O Interfacer */
    2 dcwlist (0:33),				/* DCW list */
      3 idcw bit (36),				/* Instruction DCW */
      3 dcw bit (36),				/* data transfer DCW */
    2 tdcw bit (36),				/* TDCW to beginning of list */
    2 pad bit (36),
    2 buffer (0:33),				/* card image buffer */
      3 words (27) bit (36);

dcl  i fixed bin (17),				/* Do loop position indicator */
     iostop fixed bin (18),				/* place to stop queuing I/O */
     ionext fixed bin (18),				/* index for terminate IDCW */
     rcode fixed bin (35),				/* IOI error code - 0 = OK */
     ev_done fixed bin,				/* ipc_: 0 = no event yet, 1 = event occured */
     area_ptr pointer,
     wksp_max fixed bin (19),				/* max size of IOI workspace buffer */
     time_max fixed bin (52),				/* max time for IOI connect to complete */
     rcp_state fixed bin,				/* state variable from check_attach */
     temp_iom_stat bit (72) aligned,			/* Space to hold iom status on error */
     listen_based_area area ((16374)) based (area_ptr);	/* Area in listen_ to allocate sdb */

dcl  punch_alert_flag bit (18) aligned static options (constant) init ("000000000000000001"b);
dcl  dev_stat_bits bit (72) aligned int static options (constant) /* bits used by analyze_device_stat_ */
     init ("377700770000"b3 || (12) "0"b3);


dcl  get_system_free_area_ ext entry (ptr),
     ioi_$workspace entry (fixed bin, ptr, fixed bin (18), fixed bin (35)),
     ioi_$connect entry (fixed bin, fixed bin (18), fixed bin (35)),
     ipc_$create_ev_chn ext entry (fixed bin (71), fixed bin (35)),
     ipc_$drain_chn ext entry (fixed bin (71), fixed bin (35)),
     ipc_$delete_ev_chn ext entry (fixed bin (71), fixed bin (35)),
     ipc_$block ext entry (ptr, ptr, fixed bin (35)),
     ipc_$read_ev_chn entry (fixed bin (71), fixed bin, ptr, fixed bin (35)),
     rcp_$attach entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)),
     rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (52),
     fixed bin, fixed bin (35)),
     rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35)),
     analyze_system_fault_ entry (char (*) aligned, bit (72) aligned),
     analyze_device_stat_$rs entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned),
     convert_ipc_code_ entry (fixed bin (35)),
     com_err_ entry options (variable);

dcl 1 rcp_info like device_info aligned auto;		/* automatic copy of RCP info structure */

dcl 1 ipc_message aligned,
    2 chname fixed bin (71),				/* Chan over which message arrived */
    2 message fixed bin (71),				/* 2-word event message */
    2 sender bit (36),				/* Sending process */
    2 origin,					/* Origin of event message */
      3 devsignal bit (18),				/* 1 = device signal */
      3 ring bit (18),				/* Senders ring number */
    2 channel_index fixed bin;			/* Index in wait list */


/*  */

% include rcp_device_info;

% include status_flags;

/*  */

% include ioi_stat;


/*  */

% include iom_pcw;


/*  */

% include iom_dcw;

%include prt_order_info;


/*  */

crz_attach: entry (stream_name, crzcpz, device, mode, iostatus, sdb_ptr); /* Attach entry */
cpz_attach: entry (stream_name, crzcpz, device, mode, iostatus, sdb_ptr); /* Attach entry */

	iostatus = "0"b;				/* Zero iostatus string */
	if sdb_ptr ^= null () then do;		/* Check for multiple attachments */
	     substr (iostatus, 1, 36) = unspec (error_table_$ionmat); /* If multiple attachment return code */
	     go to exit;
	end;					/* End sdb_ptr not null do group */

	call get_system_free_area_ (area_ptr);		/* Get ptr to area in listen_ before alloc */
	allocate sdb in (listen_based_area) set (sdb_ptr); /* Create stream data block */
	if sdb_ptr = null () then do;			/* If this - then no room for sdb */
	     substr (iostatus, 1, 36) = unspec (error_table_$no_room_for_dsb); /* Send message */
	     go to exit;				/* Exit */
	end;					/* End sdb_ptr null do group */
	sdb.areap = area_ptr;			/* Save area pointer for freeing sdb. */

	outer_module_name = crzcpz;			/* Put name this outer module in sdb */
	device_name_list_ptr = addr (sdb.device_name);	/* Set pointer */
	next_device_ptr = null;			/* Only one device allowed */
	name_size = 32;				/* Set name size */
	name = device;				/* Put attached device name in sdb */

	if outer_module_name = "cpz" then do;		/* If punch ... */
	     punch = "1"b;				/* Set indicator to say punch attached. */
	     dvname = "punch";
	     sdb.stat_tablep = addr (cpz_status_table_$cpz_status_table_);
	end;					/* Set pointer to punch status interpretation table. */
	else do;					/* If reader ... */
	     punch = "0"b;				/* Set indicator to say reader attached. */
	     dvname = "reader";
	     sdb.stat_tablep = addr (crz_status_table_$crz_status_table_);
	end;					/* Set pointer to reader status interpretation table. */

	call ipc_$create_ev_chn (evchan, rcode);	/* Create event channel so that the supervisor */
	if rcode ^= 0 then do;			/* knows who to wake when we are blocked */
	     call convert_ipc_code_ (rcode);
	     go to free;				/* to free sdb */
	end;
	ev_list.count = 1;				/* Initialize event list count */

	device_info_ptr = addr (rcp_info);		/* Get pointer to RCP info for device. */
	rcp_info.version_num = DEVICE_INFO_VERSION_1;			/* Set up the RCP info structure. */
	rcp_info.usage_time = 0;			/* Don't know how long we'll use device. */
	rcp_info.wait_time = 0;			/* We are not willing to wait. */
	rcp_info.system_flag = "0"b;			/* Not system process. */
	rcp_info.device_name = name;			/* Set appropriate device name. */

	call rcp_$attach (dvname, device_info_ptr, evchan, "", rcp_id, rcode);
	if rcode ^= 0 then go to free;		/* Attempt to attach the device. */

check:	call rcp_$check_attach (rcp_id, device_info_ptr, "", devx, wksp_max, time_max,
	     rcp_state, rcode);			/* Check on progress of attachment. */
	if rcode ^= 0 then go to free;

	go to attach_state (rcp_state);		/* Dispatch on state variable. */

attach_state (1):					/* Short wait needed */
	call ipc_$block (addr (sdb.ev_list), addr (ipc_message), rcode);
	if rcode ^= 0 then do;			/* Wait for attachment to complete. */
	     call convert_ipc_code_ (rcode);
	     go to free;
	end;
	go to check;				/* Perform check again. */

attach_state (2):					/* long wait */
attach_state (3):					/* error occurrence */
	go to free;				/* This is an error condition. */

attach_state (0):					/* Successful attachment */
	call ioi_$workspace (devx, wsegp, 1024, rcode);	/* Get working segment. */
	if rcode ^= 0 then go to free;		/* Check error code */

	do i = 0 to 33;				/* Insert DCWs into working segment */
	     dcwp = addr (dcwlist (i).dcw);		/* Get pointer to place for IOTD. */
	     dcw.address = rel (addr (buffer (i)));	/* Set offset of data buffer. */
	     dcw.tally = bit (bin (27, 12));		/* Set DCW tally. */
	end;

	idcwp = addr (sdb.term_idcw);			/* Get pointer to template terminate IDCW. */
	sdb.term_idcw = "0"b;			/* Clear IDCW. */
	idcw.command = "100000"b;			/* Command is RSS. */
	idcw.device = "000001"b;
	idcw.code = "111"b;
	idcw.chan_cmd = "000010"b;
	idcw.count = bit (bin (1, 6));

	idcwp = addr (sdb.io_idcw);			/* Get pointer to template read/punch IDCW. */
	sdb.io_idcw = "0"b;				/* Clear IDCW. */
	if punch then				/* If punch ... */
	     idcw.command = "001001"b;		/* Command is punch card binary. */
	else					/* If reader ... */
	idcw.command = "000001"b;			/* Command is read card binary. */
	idcw.device = "000001"b;
	idcw.code = "111"b;
	idcw.control = "10"b;

	tdcwp = addr (wseg.tdcw);			/* Get pointer to transfer DCW. */
	wseg.tdcw = "0"b;				/* Clear the DCW. */
	tdcw.address = bit (bin (0, 18));		/* Transfer back to beginning of list. */
	tdcw.type = "10"b;				/* Set type bits. */

	sdb.running = "0"b;				/* Indicate channel not running. */
	sdb.wait_flag = "0"b;			/* Turn off waiting for special flag. */
	sdb.eof_flag = "1"b;			/* Turn on EOF recognition mode */

	sdb.iobegin,				/* Set indices for I/O and data copying. */
	     sdb.iocur,
	     sdb.movecur = 0;
	if punch then sdb.movestop = 32;
	else sdb.movestop = 0;
	sdb.marker_count = 0;			/* Reset marker flag count. */
	sdb.error_count = 0;			/* Reset error count. */
	sdb.card_count = 0;				/* reset usage counter */
	sdb.last_iom_stat = ""b;			/* Reset last reported status */
	sdb.print_message = "0"b;			/* say no message to print */
	sdb.message = "";				/* and clear the status message */

	call ipc_$drain_chn (evchan, rcode);

	return;					/* Return to caller */





free:	substr (iostatus, 1, 36) = unspec (rcode);	/* Return error code. */

	go to detach_it;
						/* Now drop into detach code. */


crz_detach: entry (sdb_ptr, device, mode, iostatus);	/* Detach entry point */
cpz_detach: entry (sdb_ptr, device, mode, iostatus);	/* Detach entry point */

	iostatus = ""b;				/* clear the status */

detach_it:

	call ipc_$delete_ev_chn (evchan, rcode);	/* Delete event channel */

	call rcp_$detach (rcp_id, "0"b, error_count, "", rcode);
	if rcode ^= 0 then				/* Attempt to detach the device. */
	     if substr (iostatus, 1, 36) = ""b then	/* if not aborting an attach */
		substr (iostatus, 1, 36) = unspec (rcode); /* Put error code in return iostatus */

	area_ptr = sdb.areap;			/* Get back pointer to allocation area. */
	free sdb in (listen_based_area);		/* Free-up allocated sdb */

exit:	substr (iostatus, 52, 1) = "1"b;		/* Set ioname detached bit */
	substr (iostatus, 41, 1) = "1"b;		/* Set transaction terminated bit */
	return;


/*  */

crz_read:	entry (sdb_ptr, xwkspptr, offset, nelem, nelemt, iostatus); /* Read entry point */

/* This is the read loop for the Ohlin - Ammons card reader DIM */

	rcode = 0;				/* Clear error code. */
	nelemt = 0;				/* Zero elements transmitted to start */
	wkspptr = addrel (xwkspptr, offset * 27);	/* Copy pointer, and add in offset */
	sdb.last_iom_stat = ""b;			/* reset for each read */
	sdb.wait_flag = "0"b;			/* cancel last wait */
	sdb.print_message = "0"b;			/* and pending message */

	do while (nelemt < nelem);			/* Read as many cards as caller asked for */
	     iostop = mod (sdb.movecur - 1, 34);	/* Compute stopping place for DCW list. */

	     if sdb.iocur ^= iostop then		/* If more DCW's can be queued ... */
		call set_io;			/* Queue up some more I/O. */

	     else if sdb.movecur ^= sdb.movestop then do; /* If we have cards to move ... */

		if eof_flag then			/* Check if EOF recognition is turned on */
		     if wseg.buffer (movecur).words (1) = /* Check for multiple 5-7 punch in column 1 */
		     "002400000000"b3 |
		     (wseg.buffer (movecur).words (1) = "401240124020"b3 /* Check for ++FOF */
		     & wseg.buffer (movecur).words (2) = "201040100000"b3) |
		     (wseg.buffer (movecur).words (1) = "401240125020"b3 /* Check for ++eof */
		     & wseg.buffer (movecur).words (2) = "601050100000"b3) then
			do;
			substr (iostatus, 41, 1) = "1"b; /* Set transaction terminated bit */
			if nelemt = 0 then do;	/* First time through, don't give EOF status. */
			     substr (iostatus, 46, 1) = "1"b; /* Set end-of-data bit */
			     movecur = mod (movecur + 1, 34); /* Now throw card away */
			end;			/* Note that EOF card is looked at twice */
			substr (iostatus, 1, 36) = unspec (error_table_$eof_record);
			return;			/* Return to caller */
		     end;				/* End EOF recognized */

		wkspptr -> workspace =		/* Address where we are putting it */
		     addr (wseg.buffer (movecur)) -> workspace; /* Where it is in buffer */
		wkspptr = addrel (wkspptr, 27);	/* Update workspace pointer */
		nelemt = nelemt + 1;		/* Keep track of number of cards moved */
		sdb.card_count = sdb.card_count + 1;	/* and total cards */
		movecur = mod (movecur + 1, 34);	/* Increment data copy index. */
	     end;

	     else call wait_io;			/* Otherwise, wait for I/O completion. */

	     if rcode ^= 0 then do;
		substr (iostatus, 1, 36) = unspec (rcode);
		substr (iostatus, 41, 1) = "1"b;	/* Set transaction terminated. */
		return;				/* Return to caller immediately. */
	     end;

	end;

	return;					/* Return to caller of crzcpz_read */

/*  */

cpz_write: entry (sdb_ptr, xwkspptr, offset, nelem, nelemt, iostatus); /* Write entry point */

/* This is the write loop for the card punch DIM */

	rcode = 0;				/* Clear the error code. */
	nelemt = 0;				/* Zero elements transmitted to start */
	wkspptr = addrel (xwkspptr, offset * 27);	/* Copy pointer, and add in offset */
	sdb.last_iom_stat = ""b;
	sdb.wait_flag = "0"b;			/* cancel last wait */
	sdb.print_message = "0"b;			/* and pending message */

	do while (nelemt < nelem);			/* Write as many cards as caller asked for */
	     if movecur ^= movestop then do;		/* If room for more cards ... */
		addr (wseg.buffer (movecur)) -> workspace = /* Where data is going in buffer */
		     wkspptr -> workspace;		/* Address where we are getting it from */
		wkspptr = addrel (wkspptr, 27);	/* Update workspace pointer */
		nelemt = nelemt + 1;		/* Keep track of number of cards moved */
		sdb.card_count = sdb.card_count + 1;	/* and total cards */

		iocur = movecur;			/* Set up DCW list for card just copied. */
		call set_io;			/* Patch new element into DCW list. */
		movecur = iocur;			/* Copy next card into next slot for I/O. */
	     end;

	     else call wait_io;			/* Otherwise, wait for I/O to complete. */

	     if rcode ^= 0 then do;
		substr (iostatus, 1, 36) = unspec (rcode);
		substr (iostatus, 41, 1) = "1"b;	/* Set transaction terminated. */
		return;				/* Return to caller immediately. */
	     end;

	end;

	return;					/* Return to caller of cpz_write */

/*  */

set_io:	proc;					/* procedure to set IDCW's to perform I/O */

	     ionext = mod (iocur + 1, 34);		/* Compute place for terminate IDCW. */

	     dcwlist (ionext).idcw = term_idcw;		/* Insert stopper first. */
	     dcwlist (iocur).idcw = io_idcw;		/* Now insert I/O IDCW. */

	     if running then do;			/* If channel is running ... */
		marker_count = marker_count + 1;	/* Bump the marker count. */
		if marker_count >= 17 then do;	/* Place a marker at half-way point. */
		     idcwp = addr (dcwlist (iocur).idcw); /* Get pointer to current IDCW. */
		     idcw.control = "11"b;		/* Make IDCW store marker status. */
		     marker_count = 0;		/* Reset the marker counter. */
		end;
	     end;

	     iocur = ionext;			/* Set index for next slot for I/O. */

	     if ^running then call start_io;		/* Fire up the IOM. */

	     return;

	end set_io;

/*  */

start_io:	proc;					/* procedure to start up card I/O */

	     if ^wait_flag then if iocur ^= iobegin then do; /* If something to do ... */
		     marker_count = 0;		/* Reset the marker count. */
		     running = "1"b;		/* Turn on running flag. */
		     call ioi_$connect (devx, 2*iobegin, rcode); /* Fire up the IOM. */
		end;

	     return;

	end start_io;





wait_io:	proc;					/* procedure to wait for card I/O */

	     if ^sdb.running then			/* If channel is idle ... */
		call start_io;			/* Give it something to do. */

	     call ipc_$read_ev_chn (sdb.evchan, ev_done, addr (ipc_message), rcode);
	     if rcode ^= 0 then do;
bad_ipc:		call convert_ipc_code_ (rcode);
		return;
	     end;

	     if ev_done = 0 then do;			/* no event yet, print pending message and block */

		if sdb.print_message then do;		/* if waiting, tell why once */
		     call com_err_ (0, name, sdb.message);
		     sdb.print_message = "0"b;
		end;

		call ipc_$block (addr (sdb.ev_list), addr (ipc_message), rcode);
		if rcode ^= 0 then go to bad_ipc;

	     end;

	     call stat_check;			/* Examine status. */

	     return;

	end wait_io;

/*  */

stat_check: proc;					/* Card I/O status check entry  */

dcl  lx fixed bin,
     flags bit (18) aligned;

	     flags = "0"b;				/* Clear flags. */

	     imp = addr (ipc_message.message);		/* Get address of ioi status message */
	     if imess.level = "111"b then do;		/* If this is a special interupt... */
		wait_flag = "0"b;			/* Reset this in case waiting for special */
		return;				/* And all done */
	     end;

	     if imess.st then do;			/* If status is really present */
		if imess.time_out then do;		/* if termination caused by a time out */
		     rcode = error_table_$net_timeout;	/* this is a reasonable error */
		     running = "0"b;		/* not running any more */
		     return;
		end;

		temp_iom_stat = imess.status;		/* make a double word iom_stat */
		if bin (imess.level) <= 5 then do;	/* If system fault, terminate, or marker ... */
		     if imess.er then		/* If error occurred ... */
			if imess.level = "001"b then do; /* If system fault ... */
			     call analyze_system_fault_ (name, temp_iom_stat);
			     sdb.message = "Waiting for interrupt after last system fault error.";
			     sdb.print_message = "0"b; /* print this later if needed */
			     sdb.last_iom_stat = ""b;
			     sdb.error_count = sdb.error_count + 1; /* add them up */
			     sdb.wait_flag = "1"b;	/* wait for special status */
			end;
			else do;			/* Must be terminate status. */
			     call analyze_device_stat_$rs (sdb.message, stat_tablep, temp_iom_stat, flags);
						/* Analyze the status. */
			     sdb.wait_flag = (flags & halt_flag) ^= "0"b; /* Set wait flag based on examined status. */
			     if flags & report_flag then do; /* should we report this */
				sdb.error_count = sdb.error_count + 1;
				if (temp_iom_stat & dev_stat_bits) ^= sdb.last_iom_stat then do;
				     sdb.last_iom_stat = (temp_iom_stat & dev_stat_bits); /* save a message */
				     if ^sdb.wait_flag then do;
					call com_err_ (0, name, sdb.message);
					sdb.print_message = "0"b; /* say message was printed */
				     end;
				     else sdb.print_message = "1"b; /* print message unless returning */
				end;
			     end;
			     else sdb.print_message = "0"b; /* suppress the message */
			end;

		     lx = bin (imess.offset);		/* Copy list index for this status */
		     if flags & backup_flag then lx = lx - mod (lx, 2);
						/* If backup flag ON, go back to IDCW. */

		     iobegin = mod (divide (lx + 1, 2, 17, 0), 34);
						/* Compute place to start next block of I/O. */
		     if punch then do;		/* If running punch ... */
			movestop = mod (iobegin - 2, 34); /* Set place for stopping data copy. */
			if flags & punch_alert_flag then /* If punch alert ... */
			     iobegin = mod (iobegin - 1, 34); /* Back up still one more card. */
		     end;
		     else movestop = iobegin;		/* For reader, set place for stopping data copy. */
		     running = imess.run;		/* Indicate if channel still running. */
		end;
	     end;

	     return;

	end stat_check;



crz_setsize: entry (sdb_ptr, element_size, iostatus);	/* Set size entry point */
cpz_setsize: entry (sdb_ptr, element_size, iostatus);	/* Set size entry point */

	if element_size ^= 972 then			/* 972 bits equals 27 words */
	     substr (iostatus, 1, 36) = unspec (error_table_$invalid_elsize); /* Send message */
	else
	substr (iostatus, 41, 1) = "1"b;		/* Set transaction terminated bit */

	return;					/* Return to caller */


crz_getsize: entry (sdb_ptr, element_size, iostatus);	/* Get size entry point */
cpz_getsize: entry (sdb_ptr, element_size, iostatus);	/* Get size entry point */

	element_size = 972;				/* Set element size */
	iostatus = "0"b;				/* Zero iostatus string */
	substr (iostatus, 41, 1) = "1"b;		/* Set transaction terminated bit */

	return;					/* Return to caller */


crz_changemode: entry (sdb_ptr, new_mode, old_mode, iostatus); /* Change mode entry point */

	old_mode = "r";				/* Set old mode */
	iostatus = "0"b;				/* Zero iostatus string */
	substr (iostatus, 41, 1) = "1"b;		/* Set transaction terminated bit */
	if new_mode ^= "" & new_mode ^= "r" then	/* Check for legal mode */
	     substr (iostatus, 1, 36) = unspec (error_table_$invalid_write);

	return;					/* Return to caller */


cpz_changemode: entry (sdb_ptr, new_mode, old_mode, iostatus); /* Change mode entry point */

	old_mode = "w";				/* Set old mode */
	iostatus = "0"b;				/* Zero iostatus string */
	substr (iostatus, 41, 1) = "1"b;		/* Set transaction terminated bit */
	if new_mode ^= "" & new_mode ^= "w" then	/* Check for legal mode */
	     substr (iostatus, 1, 36) = unspec (error_table_$invalid_read);

	return;					/* Return to caller */


crz_resetread: entry (sdb_ptr, iostatus);		/* Resetread entry point. */

	iostatus = "0"b;
	do while (running);				/* Wait until channel stops. */
	     call wait_io;
	end;
	wait_flag = "0"b;				/* Now, reset the waiting for special flag. */

	iobegin,					/* Reset all indices. */
	     iocur,
	     movestop,
	     movecur = 0;

	return;

crz_order: entry (sdb_ptr, request, orderp, iostatus);	/* Order entry point */

dcl  request char (*);				/* order request */

	iostatus = "0"b;

	if request = "eof_off" | request = "off" then	/* Check for off message */
	     do;
	     eof_flag = "0"b;			/* Turn off the flag */
out:	     substr (iostatus, 41, 1) = "1"b;		/* Set terminate iostatus */
	     return;
	end;

	if request = "eof_on" | request = "on" then
	     do;
	     eof_flag = "1"b;			/* Turn the flag on */
	     goto out;
	end;

/* If we get here - "request" was not valid */

	substr (iostatus, 1, 36) = unspec (error_table_$undefined_order_request);
	go to out;


cpz_order: entry (sdb_ptr, request, orderp, iostatus);	/* Order entry point */

	iostatus = "0"b;

	if request = "runout" then do;		/* To run out the remaining cards in buffer. */
	     wait_flag = "0"b;			/* Turn off wait flag. */
	     do while (iocur ^= iobegin);		/* Try until all remaining cards are punched. */
		call wait_io;
		if rcode ^= 0 then do;
		     substr (iostatus, 1, 36) = unspec (rcode);
		     go to out;
		end;
	     end;
	     go to out;
	end;

	if request = "get_error_count" then do;
	     if orderp = null then do;		/* bad news for this entry */
		substr (iostatus, 1, 36) = unspec (error_table_$no_operation);
		go to out;
	     end;

	     ret_error_count = sdb.error_count;		/* give it to the caller */
	     go to out;				/* and we are done */
	end;

	if request = "reset" then do;			/* reset the card counter */
	     sdb.card_count = 0;
	     go to out;
	end;

	if request = "get_count" then do;		/* report the number of cards punched */
	     if orderp = null then do;		/* bad news for this entry */
		substr (iostatus, 1, 36) = unspec (error_table_$no_operation);
		go to out;
	     end;
	     unspec (counts) = ""b;			/* clear everything */
	     counts.line_count = sdb.card_count;	/* assume one card equals one line */
	     go to out;
	end;

/*	if we pass here, the order is not defined */

	substr (iostatus, 1, 36) = unspec (error_table_$undefined_order_request);
	go to out;


     end;




		    flipper_.alm                    11/15/82  1807.9rew 11/15/82  1531.8       10782



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

"	"	"	"	"	"	"	"	"
"
"	This is the I/O switch transfer vector for the flipper outer module.
"
"	"	"	"	"	"	"	"	"

	name	flipper_
	entry	flipper_module,flippermodule

	segref	card_dim,card_attach,card_detach
	segref	card_dim,card_changemode,card_order
	segref	flipper_dim,flipper_write,flipper_getsize
	segref	ios_,no_entry

flipper_module: flippermodule:
	tra	*+1,6

	tra	card_attach
	tra	card_detach
	tra	no_entry
	tra	flipper_write
	tra	no_entry
	tra	card_order
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	flipper_getsize
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	card_changemode
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry

	end	flipper_




		    flipper_dim.pl1                 11/15/82  1807.9rew 11/15/82  1458.4       35343



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* Flip cards "outer module".  Assumes card_out_stream attached to punch and creates and punches
   flip card(s) for specified number of characters   coded by MAP, 3/70  */

/* Modified by J. Stern on 7/29/71 to add standard SDB declaration
   and to delete "flipper_attach" and "flipper_detach" entry points.  Common
   attach and detach entry points for all card pseudo-DIMs are now in card_dim.  */

/* Last modified 6/27/75 by Noel I. Morris	*/


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


flipper_write: proc (sdb_ptr, wksp, off, nel, nelt, iostatus);

dcl  wksp ptr,					/* pointer to caller's workspace */
     off fixed bin,					/* offset of caller's data */
     nel fixed bin,					/* number of elements to transmit */
     nelt fixed bin,				/* number of elements actually transmitted */
     iostatus bit (72) aligned;			/* status bits */

dcl  nleft fixed bin,				/* number of elements remaining to transmit */
     in ptr,					/* input pointer */
     out ptr,					/* output pointer */
     len fixed bin,					/* length of data on each iteration */
     pos fixed bin,					/* cell position on flip card */
     num fixed bin (9),				/* numeric value of ASCII character */
     i fixed bin,					/* character index */
     j fixed bin;					/* cell index */

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

dcl  card (0:159) bit (6) unal;			/* flip card cells */

dcl  wks char (nleft) based unal;			/* caller's workspace */

dcl  fliptab$flip_codes (0:127, 0:5) bit (6) ext unaligned;

dcl (addr, bin, min, substr, unspec) builtin;


		/*  */

% include card_sdb;

		/*  */

	iostatus = "0"b;				/* Clear status bits. */
	out = addr (card);				/* Get pointer to flip card image. */
	in = addr (substr (wksp -> wks, off+1));	/* Get pointer to caller's data. */
	nelt = 0;					/* Initialize count of elements transmitted. */

	do nleft = nel by -22 while (nleft > 0);	/* Process 22 characters at a time. */
	     card = "0"b;				/* Clear the card image. */
	     card (1), card (159) = "000101"b;		/* Insert 7-9 punches in columns 1 and 80. */
	     pos = 154;				/* Set position of first cell. */

	     len = min (22, nleft);			/* Take up to 22 characters. */
	     do i = 0 to len - 1;			/* Process each character. */
		num = bin (unspec (substr (in -> wks, i+1, 1)), 9);
						/* Grab a character and convert to binary. */
		do j = 0 to 5;			/* Fill in cells to make flip character. */
		     card (pos) = fliptab$flip_codes (num, j);
		     pos = pos - 2;			/* Chars go from right to left so card can be flipped. */
		end;
		pos = pos - 2;			/* Leave some blank space. */
		if pos <= 0 then pos = pos + 155;	/* After 11 characters, do bottom row. */
	     end;

	     call ios_$write (stream, out, 0, 1, j, iostatus);
	     if substr (iostatus, 1, 36) then return;

	     nelt = nelt + len;			/* Increment elements transmitted. */
	     in = addr (substr (in -> wks, len+1));	/* Step input pointer. */
	end;

	return;


		/*  */

flipper_getsize: entry (sdb_ptr, size, iostatus);

dcl  size fixed bin;

	iostatus = "0"b;

	size = 9;					/* Works with 9-bit elements only */

	return;



     end flipper_write;




		    fliptab.alm                     11/15/82  1807.9rew 11/15/82  1532.3       25767



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

	name	fliptab

	segdef	flip_codes

flip_codes:
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700

	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700

	oct	000000000000
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	000004102000
	oct	000412210000
	oct	002112040000
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	000404040000
	oct	000303030000
	oct	010204102000

	oct	162121211600
	oct	001000370000
	oct	232525253500
	oct	212525253700
	oct	340404043700
	oct	352525252200
	oct	370505050700
	oct	202122243000
	oct	122525251200
	oct	342424243700
	oct	777777777700
	oct	777777777700
	oct	040012002100
	oct	777777777700
	oct	210012000400
	oct	777777777700

	oct	777777777700
	oct	372424243700
	oct	372525251200
	oct	372121212100
	oct	372121211600
	oct	372525252100
	oct	372424242000
	oct	372121252700
	oct	370404043700
	oct	212137212100
	oct	030101013700
	oct	370404122100
	oct	370101010100
	oct	371004103700
	oct	371004023700
	oct	372121213700

	oct	372424243400
	oct	372125233700
	oct	372424263500
	oct	352525252700
	oct	202037202000
	oct	370101013700
	oct	300601063000
	oct	370204023700
	oct	211204122100
	oct	201007102000
	oct	212725352100
	oct	372121000000
	oct	777777777700
	oct	000021213700
	oct	777777777700
	oct	010101010100

	oct	777777777700
	oct	372424243700
	oct	372525251200
	oct	372121212100
	oct	372121211600
	oct	372525252100
	oct	372424242000
	oct	372121252700
	oct	370404043700
	oct	212137212100
	oct	030101013700
	oct	370404122100
	oct	370101010100
	oct	371004103700
	oct	371004023700
	oct	372121213700

	oct	372424243400
	oct	372125233700
	oct	372424263500
	oct	352525252700
	oct	202037202000
	oct	370101013700
	oct	300601063000
	oct	370204023700
	oct	211204122100
	oct	201007102000
	oct	212725352100
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700
	oct	777777777700


	end	




		    mcc_.alm                        11/15/82  1807.9rew 11/15/82  1531.9       10557



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

"	"	"	"	"	"	"	"	"
"
"	This is the I/O switch transfer vector for the mcc outer module.
"
"	"	"	"	"	"	"	"	"

	name	mcc_
	entry	mcc_module,mccmodule

	segref	card_dim,card_attach,card_detach
	segref	card_dim,card_order
	segref	mcc_dim,mcc_read,mcc_write
	segref	mcc_dim,mcc_changemode,mcc_getsize
	segref	ios_,no_entry

mcc_module: mccmodule:
	tra	*+1,6

	tra	card_attach
	tra	card_detach
	tra	mcc_read
	tra	mcc_write
	tra	no_entry
	tra	card_order
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	mcc_getsize
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	mcc_changemode
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry

	end	mcc_




		    mcc_dim.pl1                     11/15/82  1807.9rew 11/15/82  1458.5       73269



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* "Outer module" to read Multics card codes.  Major facelifting of a Ken Thompson original by MAP, 12/69.
   Deals only with character (9 bit) elements; if 80 or less requested, will read one card; if >80 requested,
   will read number of cards necessary to get nel.  Assumes reader attached.  . */

/* Last modified by J. Stern on 7/29/71 to add standard SDB declaration
   and to delete "mcc_attach" and "mcc_detach" entry points.  Common
   attach and detach entry points for all card pseudo-DIMs are now in raw_dim. */


/* Rewritten 6/27/75 by Noel I. Morris	*/


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


mcc_read: proc (sdb_ptr, wksp, off, nel, nelt, iostatus);

dcl  wksp ptr,					/* ptr to caller's workspace */
     off fixed bin,					/* offset of data */
     nel fixed bin,					/* number of elements to transmit */
     nelt fixed bin,				/* number actually transmitted */
     iostatus bit (72) aligned;			/* status bits */

dcl  i fixed bin,					/* index */
     code fixed bin (35),				/* error code */
     j fixed bin,					/* count of cards punched or read */
     cardx fixed bin,
     in ptr,					/* input pointer */
     out ptr,					/* output pointer */
     len fixed bin,					/* length of caller's string */
     nleft fixed bin,				/* number of characters left to transmit */
     character char (1) aligned,			/* single ASCII character */
     num fixed bin,					/* translation table index */
     zone fixed bin (3),				/* zone bits */
     one_seven bit (7) aligned,			/* rows 1 thru 7 */
     eight_nine fixed bin (2),			/* rows 8 and 9 */
     illeg_char bit (1) aligned,			/* "1"b if illegal character code read */
     NL char (1) static init ("
");

dcl 1 raw aligned,					/* raw column binary card image */
    2 col (1:80) bit (12) unal,			/* 80 columns */
    2 pad bit (12) unal;				/* padding to word boundary */

dcl  card_image char (80) ;			/* ASCII card image */

dcl  wks char (nleft) based unal;			/* used to reference caller's workspace */

dcl  card_codes_$mcc_reader_codes (0:255) char (1) unal ext, /* reader translation table */
     card_codes_$mcc_punch_codes (0:127) bit (12) unal ext, /* punch translation table */
     error_table_$eof_record fixed bin (35) ext,
     error_table_$short_record fixed bin (35) ext;

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

dcl (addr, bin, index, min, substr, unspec, length, divide) builtin;

/*  */

% include card_sdb;

/*  */

	iostatus = "0"b;				/* Clear status bits. */
	in = addr (raw);				/* Set input pointer. */
	out = addr (substr (wksp -> wks, off+1));	/* Get pointer into caller's workspace. */
	nelt = 0;					/* Initialize number of chars xmitted. */
	nleft = nel;

	do cardx = 1 to divide (nel + 79, 80, 17, 0);


/* Read a card. */

	     call ios_$read (stream, in, 0, 1, j, iostatus); /* Read a card. */
	     if substr (iostatus, 1, 36) & substr (iostatus, 1, 36) ^= unspec (error_table_$eof_record) then do;
bad_read:		substr (iostatus, 46, 1) = "0"b;	/* Make sure trouble is noticed */
		return;
	     end;

	     if j = 0 then				/* If nothing was read ... */
		if substr (iostatus, 46, 1) then return;
		else go to bad_read;


/* Convert column binary to ASCII card image. */

	     card_image = "";			/* initialize to all blank */
	     do i = 1 to 80;			/* Process 80 columns. */
		zone = bin (substr (raw.col (i), 1, 3), 3); /* Get zone bits. */
		one_seven = substr (raw.col (i), 4, 7); /* Get rows 1 thru 7. */
		eight_nine = bin (substr (raw.col (i), 11, 2)); /* Get rows 8 and 9. */

		illeg_char = "0"b;			/* Clear illegal punch flag. */

		if one_seven then do;		/* If any punches in rows 1 thru 7 ... */
		     num = index (one_seven, "1"b);	/* Look for a punch. */
		     if substr (one_seven, num+1) then	/* Must only be one punch. */
			illeg_char = "1"b;		/* Otherwise, punch is illegal. */
		     else
		     num = 8 - num;			/* Compute index from punch. */
		end;
		else				/* If no punches in rows 1 thru 7 ... */
		num = 0;				/* Index is 0. */

		if illeg_char then			/* If punch was illegal ... */
		     unspec (character) = (9)"1"b;	/* Use ASCII 777 for this case. */
		else do;
		     num = (zone * 8 + num) * 4 + eight_nine;
						/* Compute index from punches. */
		     character = card_codes_$mcc_reader_codes (num);
		end;				/* Get correct character from table. */
		substr (card_image, i, 1) = character;	/* Insert character in ASCII card image. */
	     end;

	     len = length (card_image);

/* Copy card image into caller's workspace. */

	     len = min (len, nleft);			/* Copy as much as caller has room for. */
	     substr (out -> wks, 1, len) = card_image;	/* Copy the card image. */
	     nelt = nelt + len;			/* Count these chars as being transmitted. */
	     nleft = nleft - len;
	     out = addr (substr (out -> wks, len+1));	/* Step output pointer. */
	end;
	if nel ^= nelt then substr (iostatus, 1, 36) = unspec (error_table_$short_record);
	return;


mcc_write: entry (sdb_ptr, wksp, off, nel, nelt, iostatus);

	iostatus = "0"b;				/* Clear status bits. */
	out = addr (raw);				/* Set output pointer. */
	in = addr (substr (wksp -> wks, off+1));	/* Get pointer into caller's workspace. */
	nelt = 0;					/* Clear count of chars transferred. */

	raw.pad = "0"b;				/* Clear padding in column binary card image. */

	do nleft = nel repeat nleft - len while (nleft > 0); /* Process characters until exhausted. */


/* Examine input to get a line or 80 characters, whichever is shortest. */

	     i = index (in -> wks, NL);		/* Search for end of line in input. */
	     if i = 0 then				/* If no NL can be found ... */
		i, len = min (80, nleft);		/* Take up to 80 characters. */
	     else if i > 81 then			/* If line too long ... */
		i, len = 80;			/* Take only 80 characters. */
	     else do;
		len = i;				/* NL can be no further than 81 chars into string. */
		i = len - 1;			/* We do not copy the NL. */
	     end;


/* Copy the input and convert to column binary card image. */

	     card_image = (81)" ";			/* initialize to all blank */
	     card_image = substr (in -> wks, 1, i);	/* Copy up to but not including NL. */

	     do i = 1 to 80;			/* Process each column. */
		character = substr (card_image, i, 1);	/* Extract a character. */
		num = bin (unspec (character), 9);	/* Convert to binary integer. */
		raw.col (i) = card_codes_$mcc_punch_codes (num);
	     end;					/* Look up and insert column binary punches. */


/* Write out the card and step to next one. */

	     call ios_$write (stream, out, 0, 1, j, iostatus); /* Write out the card. */
	     if substr (iostatus, 1, 36) ^= "0"b | j = 0 then do; /* If error ... */
		substr (iostatus, 46, 1) = "0"b;
		return;
	     end;

	     nelt = nelt + len;			/* Increment count of characters transferred. */
	     in = addr (substr (in -> wks, len+1));	/* Step pointer to next line. */
	end;

	return;

mcc_getsize: entry (sdb_ptr, el_size, iostatus);
dcl  el_size fixed bin;

	iostatus = "0"b;				/* Clear status bits. */

	el_size = 9;				/* Size is 9 bits. */

	return;



mcc_changemode: entry (sdb_ptr, new_mode, old_mode, iostatus);

dcl  new_mode char (*),				/* new mode setting */
     old_mode char (*);				/* old mode setting */


	old_mode = "";
	iostatus = "0"b;


	return;



     end mcc_read;




		    raw_.alm                        11/15/82  1807.9rew 11/15/82  1532.0       10431



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

"	"	"	"	"	"	"	"	"
"
"	This is the I/O switch transfer vector for the raw outer module.
"
"	"	"	"	"	"	"	"	"

	name	raw_
	entry	raw_module,rawmodule

	segref	card_dim,card_attach,card_detach
	segref	card_dim,card_changemode,card_order
	segref	raw_dim,raw_read,raw_write,raw_getsize
	segref	ios_,no_entry

raw_module: rawmodule:
	tra	*+1,6

	tra	card_attach
	tra	card_detach
	tra	raw_read
	tra	raw_write
	tra	no_entry
	tra	card_order
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	raw_getsize
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	card_changemode
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry

	end	raw_




		    raw_dim.pl1                     11/15/82  1807.9rew 11/15/82  1458.3       34776



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* "Outer module" of peripheral package to return "raw" (unconverted) data from the card reader.
   coded by MAP, 12/69. */

/* Last modified by J. Stern on 8/1/71 to add standard SDB declaration
   and to reject attempted multiple attachments.  */

/* Last modifier 6/27/75 by Noel I. Morris	*/


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


raw_read: proc (sdb_ptr, wksp, off, nel, nelt, iostatus);

dcl  wksp ptr,					/* pointer to caller's workspace */
     off fixed bin,					/* offset into caller's workspace */
     nel fixed bin,					/* number of elements to be transmitted */
     nelt fixed bin,				/* number of elements actually transmitted */
     iostatus bit (72) aligned;			/* status bits */

dcl  nleft fixed bin,				/* elements remaining to be transferred */
     in ptr,					/* input pointer */
     out ptr,					/* output pointer */
     j fixed bin;					/* elements transmitted from reader or to punch */

dcl  raw_card bit (972) aligned;			/* buffer for raw card */

dcl  wks (0:1) bit (960) based unal;			/* caller's workspace */

dcl  error_table_$eof_record ext fixed bin(35);

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

dcl (addr, substr) builtin;


		/*  */

% include card_sdb;


		/*  */

	iostatus = "0"b;				/* Clear status bits. */
	in = addr (raw_card);			/* Set input pointer. */
	out = addr (wksp -> wks (off));		/* Set output pointer. */
	nelt = 0;					/* clear elements transmitted. */

	do nleft = nel by -1 while (nleft > 0);		/* Handle one elements at a time. */
	     call ios_$read (stream, in, 0, 1, j, iostatus);
	     if substr (iostatus, 1, 36) & substr(iostatus, 1, 36) ^= unspec(error_table_$eof_record) then do;
bad_read:		substr (iostatus, 46, 1) = "0"b;
		return;
	     end;
	     if j = 0 then
		if substr (iostatus, 46, 1) then return;
		else go to bad_read;

	     out -> wks (0) = raw_card;		/* Copy the card. */

	     nelt = nelt + 1;			/* Count one element transmitted. */
	     out = addr (out -> wks (1));		/* Step output pointer. */
	end;

	return;


		/*  */

raw_write: entry (sdb_ptr, wksp, off, nel, nelt, iostatus);

	iostatus = "0"b;				/* Clear status bits. */
	out = addr (raw_card);			/* Set output pointer. */
	in = addr (wksp -> wks (off));		/* Set input pointer. */
	nelt = 0;					/* Clear count of elements transmitted. */

	do nleft = nel by -1 while (nleft > 0);		/* Handle one element at a time. */
	     raw_card = in -> wks (0);		/* Copy one element. */

	     call ios_$write (stream, out, 0, 1, j, iostatus);
	     if substr (iostatus, 1, 36) ^= "0"b | j = 0 then do;
		substr (iostatus, 46, 1) = "0"b;
		return;
	     end;

	     nelt = nelt + 1;			/* Count one element transmitted. */
	     in = addr (in -> wks (1));		/* Step input pointer. */
	end;

	return;


		/*  */

raw_getsize: entry (sdb_ptr, el_size, iostatus);

dcl  el_size fixed bin;				/* element size */


	iostatus = "0"b;

	el_size = 960;				/* Element size is one raw card image. */

	return;



     end raw_read;




		    viipunch_.alm                   11/15/82  1807.9rew 11/15/82  1532.0       11250



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

"	"	"	"	"	"	"	"	"
"
"	This is the I/O switch transfer vector for the viipunch outer module.
"
"	"	"	"	"	"	"	"	"

	name	viipunch_
	entry	viipunch_module,viipunchmodule

	segref	card_dim,card_attach,card_detach
	segref	card_dim,card_changemode,card_order
	segref	viipunch_dim,viipunch_read,viipunch_write
	segref	viipunch_dim,viipunch_getsize
	segref	ios_,no_entry

viipunch_module: viipunchmodule:
	tra	*+1,6

	tra	card_attach
	tra	card_detach
	tra	viipunch_read
	tra	viipunch_write
	tra	no_entry
	tra	card_order
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	viipunch_getsize
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	card_changemode
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry
	tra	no_entry

	end	viipunch_




		    viipunch_dim.pl1                11/15/82  1807.9rew 11/15/82  1458.4       99819



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* "Outer module" to read 7punch decks.  Reads to EOF card, returns number of elements as
   bits.  See CTSS manual for 7punch format.  coded by MAP, 1/70  */

/* updated for new io switch, MAP, 3/70 */

/* Modified by B. Greenberg  3/73  for  accepting previously mispunched
   decks, punching correct tag fields, and decimal sequence field in cols. 76-80 */
/* Modified by J. Stern on 7/29/71 to add standard SDB declaration
   and to delete "viipunch_attach" and "viipunch_detach" entry points.  Common
   attach and detach entry points for all card pseudo-DIMs are now in card_dim. */


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



viipunch_read: proc (sdb_ptr, wksp, off, nel, nelt, iostatus);

dcl  dsb_ptr ptr,					/* pointer to stream data block */
     wksp ptr,					/* pointer to caller's workspace */
     off fixed bin (24),				/* offset into caller's workspace */
     nel fixed bin (24),				/* number of elements to transmit */
     nelt fixed bin (24),				/* number of elements actually transmitted */
     iostatus bit (72) aligned;			/* IOS_ status bits */

dcl  last_sw bit (1) aligned,				/* non-zero after reading last card */
     in ptr,					/* input pointer */
     out ptr,					/* output pointer */
     seqno fixed bin (15),				/* card sequence number */
     nleft fixed bin (24),				/* number of elements left to transfer */
     bad_tag_sw bit (1) aligned,			/* to fix cards mangled by Padlipsky */
     wdct bit (12) aligned,				/* word count on card */
     len fixed bin,					/* data copy length */
     i fixed bin,					/* iteration variable */
     j fixed bin,					/* useful variable */
     len2 fixed bin,				/* used for repeated data */
     bitcnt fixed bin (24),				/* bit count of 7punch deck */
     same_sw bit (1) aligned,				/* used to detect repeated data */
     number fixed bin,				/* for computing sequence number field */
     tenth fixed bin;				/* for computing sequence number field */

dcl  wks bit (nleft) unal based;			/* caller's workspace */

dcl 1 card aligned,					/* 7punch card declaration */
    2 w0,						/* first word */
     (3 seven bit (3),				/* "111"b */
      3 cnthi bit (6),				/* high-order word count */
      3 five bit (3),				/* "101"b */
      3 cntlo bit (6),				/* low-order word count */
      3 tag bit (3),				/* non-zero on last card */
      3 seq bit (15)) unal,				/* card sequence number */
    2 cksm bit (36),				/* checksum */
    2 data bit (792),				/* data words */
   (2 blank (3) bit (12),				/* blank field */
    2 id (5) bit (12)) unal;				/* sequence number field */

dcl  error_table_$eof_record ext fixed bin(35);

dcl  ios_$read entry (char (*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned),
     ios_$write entry (char (*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned),
     com_err_ entry options (variable),
     check_cd entry (ptr) returns (bit (36) aligned);

dcl (addr, divide, bin, bit, length, min, string, substr, unspec) builtin;


		/*  */

% include card_sdb;

		/*  */

	iostatus = "0"b;				/* Clear status bits. */
	in = addr (card);				/* Set input pointer to card image. */
	out = addr (substr (wksp -> wks, off+1));	/* Set output pointer into caller's workspace. */
	nelt = 0;					/* Initialize count of elements transmitted. */

	last_sw = "0"b;				/* Clear last card switch. */
	seqno = 0;				/* Initialize card sequence number. */
	nleft = nel;				/* Get number of elements remaining to be transmitted. */

	do while (nleft > 0);			/* Loop, reading cards. */
	     call read_7_card;			/* Read and check a card. */

	     if seqno = 0 then if card.tag then		/* If first card ... */
		bad_tag_sw = "1"b;			/* It should not have non-zero tag. */
	     else
		bad_tag_sw = "0"b;

	     wdct = card.cnthi || card.cntlo;		/* Get word count. */
	     len = min (bin (wdct, 12) * 36, nleft);	/* Compute elements to be taken from card. */

	     if len = 0 then			/* If zero word count ... */
		if card.tag = "011"b then do;		/* If this is a bit count card ... */
		     nelt = bin (substr (card.data, 1, 36), 35);
		     last_sw = "1"b;		/* Return correct element count and set switch. */
		end;
		else if bad_tag_sw | (card.tag = "000"b) then do;
		     call com_err_ (0, "viipunch_read", "Zero word count on card ^d.", seqno);
		     go to error_return;		/* Should never have zero word count otherwise. */
		end;
		else;

	     else if len <= length (card.data) then	/* If data is on card ... */
		substr (out -> wks, 1, len) = card.data;/* Copy it into caller's workspace. */

	     else do j = 0 to len by 36;		/* Otherwise, copy repeated word. */
		len2 = min (36, len - j);		/* Compute elements to transfer. */
		substr (out -> wks, j+1, len2) = card.data;
	     end;					/* Copy single word. */

	     nleft = nleft - len;			/* Decrement count of elements left. */
	     out = addr (substr (out -> wks, len+1));	/* Bump pointer into caller's workspace. */
	     nelt = nelt + len;			/* Return count of elements transmitted so far. */

	     if ^bad_tag_sw then			/* If not ignoring bad tags ... */
		if card.tag & "001"b then		/* If card has non-zero tag ... */
		     last_sw = "1"b;		/* Set last card switch. */

	     seqno = seqno + 1;			/* Bump card sequence number. */
	end;

	return;


		/*  */

read_7_card: proc;

	call ios_$read (stream, in, 0, 1, j, iostatus);	/* Read one card. */
	if substr (iostatus, 1, 36) & substr(iostatus, 1, 36) ^= unspec(error_table_$eof_record) then do;
bad_read:	     substr (iostatus, 46, 1) = "0"b;		/* Clear this bit. */
	     go to error_return;			/* And take error return. */
	end;

	if j = 0 then				/* If no elements were read ... */
	     if substr (iostatus, 46, 1) then		/* Did we get an EOF? */
		if last_sw then			/* Was it expected? */
		     go to reof;			/* If so, transfer. */
		else do;				/* Unexpected EOF. */
		     call com_err_ (0, "viipunch_read", "Premature EOF after card ^d.", seqno - 1);
		     go to bad_read;
		end;
	     else go to bad_read;			/* Read zero cards. */

	if last_sw then do;				/* Should have gotten EOF after last read. */
	     call com_err_ (0, "viipunch_read", "Missing EOF after card ^d.", seqno - 1);
	     go to bad_read;
	end;

	if card.seven ^= "111"b | card.five ^= "101"b then do;
	     call com_err_ (0, "viipunch_read", "Non 7-punched card after card ^d.", seqno - 1);
	     go to bad_read;
	end;

	if bin (card.seq, 15) ^= seqno then do;		/* If sequence error ... */
	     call com_err_ (0, "viipunch_read", "Card sequence error. Expected ^d; read ^d.", seqno, bin (card.seq, 15));
	     go to bad_read;
	end;

	if card.cksm then				/* If checksum is not blank ... */
	     if card.cksm ^= check_cd (in) then do;	/* Compre against computed checksum. */
		call com_err_ (0, "viipunch_read", "Checksum error on card ^d.", seqno);
		go to bad_read;
	     end;

	return;


     end read_7_card;


		/*  */

viipunch_write: entry (sdb_ptr, wksp, off, nel, nelt, iostatus);

	iostatus = "0"b;				/* Clear status bits. */
	out = addr (card);				/* Set output pointer. */
	in = addr (substr (wksp -> wks, off+1));	/* Set input pointer. */
	nelt = 0;					/* Initialize count of elements transmitted. */

	string (card.w0) = "0"b;			/* Clear first word in card image. */
	card.seven = "111"b;			/* Set 7punch bits. */
	card.five = "101"b;				/* Set 7-9 punch. */
	string (card.blank) = "0"b;			/* Clear blank field. */

	seqno = 0;				/* Initialize sequence number. */
	bitcnt, nleft = nel;			/* Set number of elements remaining to be transmitted. */

	do while (nleft > 0);			/* Iterate until all elements processed. */
	     len = min (length (card.data), nleft);	/* Compute number of elements to process. */
	     card.data = substr (in -> wks, 1, len);	/* Copy the data. */
	     in = addr (substr (in -> wks, len+1));	/* Bump input pointer. */
	     nleft = nleft - len;			/* Decrement elements remaining to be transmitted. */

	     if substr (card.data, 1, length (card.data)-36) = substr (card.data, 37) then do;
		same_sw = "1"b;			/* If data is replicated on card ... */
		do while (same_sw & (nleft > 0));	/* Search to end of replication. */
		     len2 = min (36, nleft);		/* Compute number of elements to test. */
		     if substr (in -> wks, 1, len2) = substr (card.data, 1, 36) then do;
			len = len + len2;		/* Data still replicated.  Skip over it. */
			in = addr (substr (in -> wks, len2+1));
			nleft = nleft - len2;
		     end;
		     else				/* Data no longer replicated. */
			same_sw = "0"b;		/* Clear replication switch. */
		end;
	     end;

	     wdct = bit (divide (len + 35, 36, 12, 0));	/* Compute word count for card. */
	     card.cnthi = wdct;			/* Set high order part of word count. */
	     card.cntlo = substr (wdct, 7);		/* And low order part. */

	     call write_7_card;			/* Write out the card. */

	     nelt = nelt + len;			/* Bump elements transmitted. */
	end;

	card.cnthi, card.cntlo = "0"b;		/* Clear word count. */
	card.data = bit (bin (bitcnt, 36));		/* Set bitcount on card. */
	card.tag = "011"b;				/* Set tag indicating bitcount card. */

	call write_7_card;				/* Write out the bit count card. */

	return;


		/*  */

write_7_card: proc;

	card.seq = bit (bin (seqno, 15));		/* Set the sequence number on card. */

	card.cksm = check_cd (out);			/* Insert the checksum. */

	number = seqno;				/* Set sequence number for ID field. */
	string (card.id) = "0"b;			/* Clear the ID field. */
	do i = 5 to 1 by -1;			/* Convert each digit to column binary representation. */
	     tenth = divide (number, 10, 17, 0);	/* Compute number of 10's. */
	     j = number - tenth * 10;			/* Get a digit. */
	     substr (card.id (i), j+3, 1) = "1"b;	/* Insert correct column binary bit. */
	     number = tenth;			/* Iterate for next digit. */
	end;

	call ios_$write (stream, out, 0, 1, j, iostatus);	/* Write out the card image. */
	if substr (iostatus, 1, 36) | j = 0 then do;	/* Check for error. */
	     substr (iostatus, 46, 1) = "0"b;
	     go to error_return;
	end;

	seqno = seqno + 1;				/* Bump card sequence number. */

	return;


     end write_7_card;


		/*  */

error_return:
reof:
	return;


		/*  */

viipunch_getsize: entry (sdb_ptr, elsize, iostatus);

dcl  elsize fixed bin;				/* element size */


	iostatus = "0"b;				/* Clear status bits. */

	elsize = 1;				/* Element size is 1 bit. */

	return;



     end viipunch_read;




		    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
