					      (*

 (c) Copyright Hewlett-Packard Company, 1984.
All rights are reserved.  Copying or other
reproduction of this program except for archival
purposes is prohibited without the prior
written consent of Hewlett-Packard Company.


	    RESTRICTED RIGHTS LEGEND

Use, duplication, or disclosure by the Government
is subject to restrictions as set forth in
paragraph (b) (3) (B) of the Rights in Technical
Data and Computer Software clause in
DAR 7-104.9(a).

HEWLETT-PACKARD COMPANY
Fort Collins, Colorado                         *)


$modcal$
$debug off, range off, ovflcheck off$
$stackcheck off, iocheck off$

{{
$search 'KERNEL'$
{}
$search 'IOLIB:KERNEL','OSFS:SYSDEVS'$
{}

$page$
$copyright 'COPYRIGHT (C) 1984 BY HEWLETT-PACKARD COMPANY'$


module prtdvr;

import
  sysglobals,
  iodeclarations,
  asm, sysdevs, mini, misc, fs;

export
  procedure prtio (fp: fibp; request: amrequesttype; anyvar buffer: window;
						   length, position: integer);
implement  {prtdvr}

procedure bep;
  begin write(bellchar); end;

procedure prtio(fp: fibp; request: amrequesttype; anyvar buffer: window;
						   length, position: integer);

const
  uclr_timeout_const = 25;      {HPIB commands during unitclear}

  repeating_timeout  = 333;     {timeout constant after initial timeout}
  timeouts_per_beep  = 40;      {beep period in repeating timeout units}

  SDC      = 4;         {selective device clear}
  LAGbase  = 32;        {listen address group base}
  TAGbase  = 64;        {talk address group base}

  linefeed = chr(10);   {ASCII linefeed}
  formfeed = chr(12);   {ASCII formfeed}
  return   = chr(13);   {ASCII carriage return}

var

  select_code: type_isc;
  sc_table_entry_ptr: ^isc_table_type;
  previous_char_ptr: charptr;
  bus_address: byte;

  channel_is_setup: boolean;
  writing_previous_char: boolean;
  previously_timed_out: boolean;
  timeout_blanked: boolean;
  user_spec_timeout: integer;
  current_timeout: integer;
  timeout_counter: shortint;
  saved_line     : string[42];          { 3.0 bug fix -- 4/12/84 }
  line_needs_restoring : boolean;       { 4/12/84 }
  buf: charptr;
  saved_echo: boolean;                  { 5/9/84 }

$page$

procedure reset_card_and_confirm_timeout;
  var
    saved_escapecode: shortint;
    saved_ioe_sc: integer;
    saved_ioe_result: integer;
  begin {reset_card_and_confirm_timeout}
    saved_escapecode := escapecode;
    saved_ioe_sc := ioe_isc;
    saved_ioe_result := ioe_result;
    try
      with sc_table_entry_ptr^ do
	call(io_drv_ptr^.iod_init, io_tmp_ptr);
    recover
      if (escapecode<>ioescapecode) or (ioe_isc<>select_code) then
	escape(escapecode);
    ioe_isc := saved_ioe_sc;
    ioe_result := saved_ioe_result;
    if (saved_escapecode<>ioescapecode) or (ioe_isc<>select_code) then
      escape(saved_escapecode);
    if ioe_result<>ioe_timeout then
      ioresc(znodevice);
  end; {reset_card_and_confirm_timeout}

procedure clear_unit;
var w:io_word;
  procedure HPIBsdc;
    begin {HPIBsdc}
      with sc_table_entry_ptr^, io_drv_ptr^, io_tmp_ptr^ do
	begin
	  call(iod_send, io_tmp_ptr, '?');
	  timeout := uclr_timeout_const;
	  call(iod_send, io_tmp_ptr, chr(LAGbase+bus_address));
	  call(iod_send, io_tmp_ptr, chr(SDC));
	end; {with}
    end; {HPIBsdc}
  begin {clear_unit}
    with sc_table_entry_ptr^ do
      if card_type=hpib_card then
	try
	  HPIBsdc;         {first attempt}
	recover
	  begin
	    reset_card_and_confirm_timeout;
	    try
	      HPIBsdc;       {second attempt}
	    recover
	      begin
		reset_card_and_confirm_timeout;
		ioresc(ztimeout);
	      end; {recover}
	  end {recover}
      else if card_type = serial_card then                      {12/89 dew - added pllel}
	try
	  call(io_drv_ptr^.iod_init, io_tmp_ptr);
	recover
	  if (escapecode<>ioescapecode) or (ioe_isc<>select_code) then escape(escapecode)
	  else ioresc(znodevice)
      else {parallel_card}                                      {12/89 dew - added pllel}
	try
	  io_tmp_ptr^.timeout := current_timeout;
	  call(io_drv_ptr^.iod_wtc, io_tmp_ptr, 21, 0);  {set the reset type to not present}
	  call(io_drv_ptr^.iod_init, io_tmp_ptr);        {reset driver}
	  call(io_drv_ptr^.iod_rds, io_tmp_ptr, 20, w);  {get peripheral type}
	  if w = 1 then {OUTPUT_ONLY}
	  begin
		call(io_drv_ptr^.iod_wtc, io_tmp_ptr, 20, 11); {set current type to user_spec_output_only}
		call(io_drv_ptr^.iod_wtc, io_tmp_ptr, 21, 11); {set the reset type to same}
	  end
	  else {not a printer there}
		ioresc(znodevice);
	recover
	  begin
	    reset_card_and_confirm_timeout;
	    ioresc(ztimeout);
	  end; {recover}
  end; {clear_unit}

$page$

procedure wrtchar(character: char; last_char: boolean);

  var
    hs_successfully_initiated: boolean;
    previous_hs_completed    : boolean;


  procedure restore_line;
  var dummyc:char;
  begin
    if line_needs_restoring then { 4/12/84 }
    begin
      keybuffer^.echo:=saved_echo;
      keybufops(kdisplay,dummyc);
      line_needs_restoring:=false;
    end;
  end;

$page$

  procedure inform_operator;
  var lmstr : string[42];                      { 3.0 bug fix -- 4/12/84 }
    begin  {inform_operator}

      if not previously_timed_out then
      begin
	timeout_blanked := true;
	timeout_counter := 0;
      end;
      if not line_needs_restoring then
      begin
	saved_line := '* Printer timeout: fix or ';
	if intlevel=0 then saved_line:=saved_line+'<stop> aborts *'
		      else saved_line:=saved_line+'wait auto-abort*' ;
					       { 3.0 bug fix -- 4/12/84 }
	line_needs_restoring := true;
	if menustate=m_none then saved_echo:=keybuffer^.echo
			    else saved_echo:=true;
	menustate := m_none; { 4/12/84 }
	keybuffer^.echo :=false;
      end;
      if timeout_blanked then lmstr:= saved_line
			 else lmstr:= ' ';
      CALL(CRTLLHOOK,CLLDISPLAY,LMSTR,' ');
      timeout_blanked:= (timeout_counter mod 4)<>0;

      if timeout_counter<=1 then bep;
      timeout_counter := timeout_counter+1;
      if timeout_counter>=timeouts_per_beep then
	if intlevel=0 then timeout_counter := 0
	else
	  begin
	    bep;
	    restore_line;
	    ioresc(ztimeout);
	  end; {else}

    end;  {inform_operator}

$page$

  begin {wrtchar}
    try
      with sc_table_entry_ptr^, io_drv_ptr^, io_tmp_ptr^  do
	repeat
	  try
	    previous_hs_completed := false;
	    if not channel_is_setup then
	      begin
		case card_type of
		  hpib_card:
		    begin
		      call(iod_send, io_tmp_ptr, '?');
		      previous_hs_completed := true;
		      timeout := current_timeout;
		      call(iod_send, io_tmp_ptr, chr(TAGbase+addressed));
		      call(iod_send, io_tmp_ptr, chr(LAGbase+bus_address));
		    end; {hpib_card}
		  serial_card:
		    if card_id=hp98626 then  {always set full duplex modem HS}
		      call(iod_wtc, io_tmp_ptr, 13, 1);
		  pllel_card:                                   {12/89 dew - added pllel}
		    begin
		      timeout := current_timeout;
		      call(iod_wtc, io_tmp_ptr, 24, 4); {write verify}
		    end;
		  otherwise
		    {do nothing};
		end; {case}
		channel_is_setup := true;
	      end; {if}
	    call(iod_wtb, io_tmp_ptr, character);
	    previous_char_ptr^ := character;
	    timeout := current_timeout;
	    if last_char then
	      if card_type=hpib_card then
		call(iod_send, io_tmp_ptr, '?');
	    if previously_timed_out then
	      if not writing_previous_char then
		begin
		  restore_line;
		  current_timeout := user_spec_timeout;
		  previously_timed_out := false;
		end; {if}
	    hs_successfully_initiated := true;
	  recover
	    begin
	      reset_card_and_confirm_timeout;
	      channel_is_setup := false;
	      inform_operator;
	      previously_timed_out := true;
	      current_timeout := repeating_timeout;
	      if not (writing_previous_char or previous_hs_completed) then
		begin
		  writing_previous_char := true;
		  wrtchar(previous_char_ptr^, false);
		  writing_previous_char := false;
		end; {if}
	      hs_successfully_initiated := false;
	    end; {recover}
	until hs_successfully_initiated;
    recover
      begin
	restore_line;   { 4/12/84 }
	escape(escapecode);
      end; {recover}
  end; {wrtchar}
$page$

  begin  {prtio}
    ioresult := ord(inoerror);                                 { scs 1/17/83 }
    with unitable^[fp^.funit] do
      begin
	select_code := sc;
	sc_table_entry_ptr := addr(isc_table[select_code]);
	bus_address := ba;
	previous_char_ptr := addr(dvrtemp);
	user_spec_timeout := devid;  {user-specified in CTABLE}
      end; {with}

    buf := addr(buffer);
    channel_is_setup := false;
    current_timeout := user_spec_timeout;
    previously_timed_out  := false;
    writing_previous_char := false;
    line_needs_restoring  := false; { 4/12/84 }

    try
      with sc_table_entry_ptr^, io_tmp_ptr^  do
	begin
	  if card_type=no_card then ioresc(znodevice);
	  while (in_bufptr<>nil) or (out_bufptr<>nil) do {nothing};
	end; {with}

      case request of
	flush:
	  {do nothing};
	clearunit:
	  clear_unit;
	writeeol:
	  begin
	    wrtchar(return, false);
	    wrtchar(linefeed, true)
	  end;
	writebytes:
	  while length>0 do
	    begin
	      wrtchar(buf^, length=1);
	      buf := addr(buf^, 1);
	      length := length-1;
	    end;
	otherwise
	  ioresc(zbadmode);
      end; {case}
    recover
      if (escapecode=-20) and previously_timed_out then
	ioresult := ord(ztimeout)
      else if escapecode<>-10 then
	escape(escapecode);

  end; {prtio}

end. {prtdvr}

