head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.20.13;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.00.52;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.39.29;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.18.07;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.12.34.56;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.46.00;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.23.43;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.24.55;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.08.34;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.08.00;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.23.07;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.07.27;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.13.19;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.54.16;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.41.00;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.48.18;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.06.06;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.56.34;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.41.33;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.24.29;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.46.55;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.31.33;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.22.58;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.35.56;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.14.42;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.27.55;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.03.09;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.36.38;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.43.55;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.05.02;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.42.36;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.27.07;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.55.14;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.24.26;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.13.00.05;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.21.12;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.09.38.27;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.10.15.06;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.58.06;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.43.13;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.56.09;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.12.30;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.15.08.17;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.24.04;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.36.55;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.09.13;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.15.10.00;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.23.15;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.12.37;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.38.24;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.45.58;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.14.21.55;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.43.13;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.13.32.10;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.17.41.38;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.16.28.37;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.35.28;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.45.10;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.30.00;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.14.22.42;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@					      (*

 (c) Copyright Hewlett-Packard Company, 1983.
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 'DRVASM', 'IOLIB:KERNEL'$


program init_bkgnd;

module bkgnd;

import
  sysglobals, misc, iodeclarations;

export
  type
    uep_type = {unit entry pointer}
      ^unitentry;
    bi_type = {background info}
      record
	iores               : iorsltwd;      {ioresult                       }
	set_in_use          : boolean;       {allocation flag                }
	async               : boolean;       {overlapped transfer flag       }
	feot                : eotproc;       {end of transfer procedure      }
	fibptr              : fibp;          {file information block ptr     }
	read_operation      : boolean;       {transfer direction flag        }
	buffered_transfer   : boolean;       {amigo driver flag              }
	xfr_chain_semaphore : boolean;       {driver semaphore               }
	bx_tries            : shortint;      {number of previous tries       }
	bx_strt_rcrd        : integer;       {record address                 }
	bx_bufptr           : charptr;       {R/W address pointer            }
	bx_length           : integer;       {total transfer byte count      }
	bx_tfr_length       : integer;       {intermediate tfr byte count    }
	bdx_chain_semaphore : boolean;       {data transfer semaphore        }
	bdx_pre_eoi         : boolean;       {premature eoi flag             }
	bdx_nb              : integer;       {data transfer byte count       }
	bdx_proc            : io_proc;       {data transfer completion proc  }
	buf_info            : buf_info_type; {as defined by the iolibrary    }
      end;
    bip_type = ^bi_type;
$page$

  procedure initialize_bkgnd;
  procedure allocate_bkgnd_info  (uep: uep_type);
  procedure deallocate_bkgnd_info(uep: uep_type);
  procedure abort_bkgnd_process  (uep: uep_type);
  procedure ioresc_bkgnd         (uep: uep_type; ior: iorsltwd);
  function  unit_busy            (uep: uep_type): boolean;
  procedure unit_wait            (uep: uep_type);

implement {bkgnd}

const
  n = 3;  {number of bkgnd info sets}

type
  bia_type = array[0..n-1] of bi_type;

var
  bia_ptr: ^bia_type;
  index: shortint;


procedure initialize_bkgnd;
  var
    local_index: shortint;
  begin {initialize_bkgnd}
    if bia_ptr=nil then
      new(bia_ptr);
    for local_index := 0 to n-1 do
      bia_ptr^[local_index].set_in_use := false;
    index := 0;
  end; {initialize_bkgnd}


function bip_valid(bip: bip_type): boolean;
  var
    local_index: shortint;
  begin {bip_valid}
    bip_valid := false;
    for local_index := 0 to n-1 do
      if bip=addr(bia_ptr^[local_index]) then
	bip_valid := true;
  end; {bip_valid}
$page$

procedure allocate_bkgnd_info(uep: uep_type);
  var
    bip: bip_type;
  begin {allocate_bkgnd_info}
    lockup;
    repeat
      bip := addr(bia_ptr^[index]);
      index := index+1;
      if index>=n then index := 0;
    until not bip^.set_in_use;
    uep^.dvrtemp := integer(bip);
    with bip^ do
      begin
	iores      := inoerror;
	set_in_use := true;
	async      := false;
      end; {with}
  end; {allocate_bkgnd_info}


procedure deallocate_bkgnd_info(uep: uep_type);
  var
    saved_ioresult: integer;
  begin {deallocate_bkgnd_info}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      with bip_type(uep^.dvrtemp)^ do
	begin
	  set_in_use := false;
	  uep^.dvrtemp := ord(iores);
	  lockdown;
	  if async then {call the eot procedure}
	    begin
	      saved_ioresult := ioresult;
	      ioresult := uep^.dvrtemp;
	      call(feot, fibptr);
	      ioresult := saved_ioresult;
	    end; {if}
	end; {with}
  end; {deallocate_bkgnd_info}


procedure abort_bkgnd_process(uep: uep_type);
  begin {abort_bkgnd_process}
    if escapecode<>-10 then  {prevent any eot procedure call while deallocating}
      bip_type(uep^.dvrtemp)^.async := false;
    deallocate_bkgnd_info(uep);
    if escapecode<>-10 then escape(escapecode);
  end; {abort_bkgnd_process}


procedure ioresc_bkgnd(uep: uep_type; ior: iorsltwd);
  begin {ioresc_bkgnd}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      bip_type(uep^.dvrtemp)^.iores := ior;
    escape(-10);
  end; {ioresc_bkgnd}
$page$

function unit_busy(uep: uep_type): boolean;
  begin {unit_busy}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      unit_busy := true
    else
      begin
	unit_busy := false;
	ioresult := uep^.dvrtemp;
      end; {else}
  end; {unit_busy}


procedure unit_wait(uep: uep_type);
  begin {unit_wait}
    while unit_busy(uep) do {nothing};
  end; {unit_wait}


end; {bkgnd}
$page$
$copyright 'COPYRIGHT (C) 1983 BY HEWLETT-PACKARD COMPANY'$


module discHPIB;

import
  sysglobals, iodeclarations, drvasm, bkgnd;

export
  function  Simon_no_DMA       (uep: uep_type): boolean;
  function  Simon_DMA          (uep: uep_type): boolean;
  procedure HPIBcheck_sc       (uep: uep_type);
  procedure HPIBwait_for_ppol  (uep: uep_type);
  procedure HPIBshort_msge_out (uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  procedure HPIBamigo_clear    (uep: uep_type);
  procedure HPIBshort_msge_in  (uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  function  HPIBamigo_identify (uep: uep_type): shortint;
  procedure HPIBget_amigo_ident(uep: uep_type; var ident: shortint);
  procedure HPIBupon_ppol_resp (uep: uep_type; proc: io_proc);
  procedure HPIBupon_dxfr_comp (uep: uep_type; sec: byte; bp: charptr; nb: integer; proc: io_proc);

implement {discHPIB}


const
  standard_tc = 5000;   {standard byte timeout value milliseconds}
  short_tc = 25;        {short byte timeout value milliseconds}
  SDC = 4;              {selective device clear}
  LAG_base = 32;        {listen address group base}
  TAG_base = 64;        {talk address group base}
  SCG_base = 96;        {secondary command group base}


procedure delay_timer(microsec_value: integer); external;


procedure confirm_timeout_and_reset_card(uep: uep_type);
  begin {confirm_timeout_and_reset_card}
    if (escapecode<>ioescapecode) or (ioe_isc<>uep^.sc) then escape(escapecode);
    if ioe_result<>ioe_timeout then ioresc_bkgnd(uep, znodevice);
    with isc_table[uep^.sc] do
      call(io_drv_ptr^.iod_init, io_tmp_ptr);
    ioresc_bkgnd(uep, ztimeout);
  end; {confirm_timeout_and_reset_card}

$page$

function Simon_no_DMA(uep: uep_type): boolean;
  begin {Simon_no_DMA}
    with isc_table[uep^.sc] do
      Simon_no_DMA := (card_id=hp98625) and not dma_here;
  end; {Simon_no_DMA}


function Simon_DMA(uep: uep_type): boolean;
  begin {Simon_DMA}
    with isc_table[uep^.sc] do
      Simon_DMA := (card_id=hp98625) and dma_here;
  end; {Simon_DMA}


procedure HPIBcheck_sc(uep: uep_type);
  begin {HPIBcheck_sc}
    with isc_table[uep^.sc] do
      begin
	if card_type<>hpib_card then
	  ioresc_bkgnd(uep, znodevice);
	with io_tmp_ptr^ do
	  while (in_bufptr<>nil) or (out_bufptr<>nil) do {nothing};
      end; {with}
  end; {HPIBcheck_sc}


procedure HPIBwait_for_ppol(uep: uep_type);
  var
    pprb: packed array[0..7] of boolean;        {parallel poll response byte}
  begin {HPIBwait_for_ppol}
    try
      with isc_table[uep^.sc], io_drv_ptr^ do
	repeat
	  call(iod_ppoll, io_tmp_ptr, charptr(addr(pprb))^);
	until pprb[uep^.ba];
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBwait_for_ppol}
$page$

procedure address_for_msge_out(var isc_te: isc_table_type; ba, sec: byte; tc: integer);
  var
    dummy_char: char;
  begin {address_for_msge_out}
    with isc_te, io_drv_ptr^ do
      begin
	call(iod_send, io_tmp_ptr, '?');
	io_tmp_ptr^.timeout := tc;
	call(iod_send, io_tmp_ptr, chr(TAG_base+io_tmp_ptr^.addressed));
	call(iod_send, io_tmp_ptr, chr(LAG_base+ba));
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
	call(iod_send, io_tmp_ptr, chr(SCG_base+sec));
	call(iod_ppoll, io_tmp_ptr, dummy_char);  {enforce timeout}
      end; {with}
  end; {address_for_msge_out}

procedure HPIBshort_msge_out(uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  var
    isc_te_ptr: ^isc_table_type;
  begin {HPIBshort_msge_out}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_out(isc_te_ptr^, uep^.ba, sec, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  while nb>1 do
	    begin
	      call(iod_wtb,  io_tmp_ptr, bp^);
	      bp := addr(bp^, 1);
	      nb := nb-1;
	    end; {while}
	  call(iod_set,  io_tmp_ptr, ord(eoi_line));
	  call(iod_wtb,  io_tmp_ptr, bp^);
	  call(iod_send, io_tmp_ptr, '?');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBshort_msge_out}

procedure HPIBamigo_clear(uep: uep_type);
  var
    isc_te_ptr: ^isc_table_type;
  begin {HPIBamigo_clear}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_out(isc_te_ptr^, uep^.ba, 16, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  call(iod_set,  io_tmp_ptr, ord(eoi_line));
	  call(iod_wtb,  io_tmp_ptr, chr(0));  {disable parity check}
	  call(iod_send, io_tmp_ptr, chr(SDC));
	  call(iod_send, io_tmp_ptr, '?');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBamigo_clear}
$page$

procedure address_for_msge_in(var isc_te: isc_table_type; ba, sec: byte; tc: integer);
  var
    dummy_char: char;
  begin {address_for_msge_in}
    with isc_te, io_drv_ptr^ do
      begin
	call(iod_send, io_tmp_ptr, '?');
	io_tmp_ptr^.timeout := tc;
	call(iod_send, io_tmp_ptr, chr(LAG_base+io_tmp_ptr^.addressed));
	call(iod_send, io_tmp_ptr, chr(TAG_base+ba));
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
	call(iod_send, io_tmp_ptr, chr(SCG_base+sec));
	call(iod_ppoll, io_tmp_ptr, dummy_char);  {enforce timeout}
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
      end; {with}
  end; {address_for_msge_in}


procedure premature_eoi(uep: uep_type);
  begin {premature_eoi}
    with isc_table[uep^.sc] do
      call(io_drv_ptr^.iod_send, io_tmp_ptr, '_');
    ioresc_bkgnd(uep, zbadhardware);  {all "expected" premature eoi's have to be trapped}
  end; {premature_eoi}


procedure HPIBshort_msge_in(uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  var
    isc_te_ptr: ^isc_table_type;
    eoi_set: boolean;
  begin {HPIBshort_msge_in}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_in(isc_te_ptr^, uep^.ba, sec, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  while nb>1 do
	    begin
	      call(iod_rdb,  io_tmp_ptr, bp^);
	      call(iod_end,  io_tmp_ptr, eoi_set);
	      if eoi_set then premature_eoi(uep);
	      bp := addr(bp^, 1);
	      nb := nb-1;
	    end; {while}
	  call(iod_rdb,  io_tmp_ptr, bp^);
	  call(iod_send, io_tmp_ptr, '_');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBshort_msge_in}
$page$

function HPIBamigo_identify(uep: uep_type): shortint;
  var
    isc_te_ptr: ^isc_table_type;
    ident: {the two identify bytes}
      record case integer of
	0: (word: shortint);
	1: (upper_char, lower_char: char);
      end;
    eoi_set: boolean;
  begin {HPIBamigo_identify}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_in(isc_te_ptr^, {"ba"} 31, {"sec"} uep^.ba, short_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  call(iod_rdb,  io_tmp_ptr, ident.upper_char);
	  call(iod_end,  io_tmp_ptr, eoi_set);
	  if eoi_set then premature_eoi(uep);
	  call(iod_rdb,  io_tmp_ptr, ident.lower_char);
	  call(iod_send, io_tmp_ptr, chr(TAG_base+io_tmp_ptr^.addressed));
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
    HPIBamigo_identify := ident.word;
  end; {HPIBamigo_identify}


procedure HPIBget_amigo_ident(uep: uep_type; var ident: shortint);
  begin {HPIBget_amigo_ident}
    ident := HPIBamigo_identify(uep);
  end; {HPIBget_amigo_ident}


procedure HPIBupon_ppol_resp(uep: uep_type; proc: io_proc);
  {
    NOTE: when SIMON drivers become available, this routine needs to
    be modified to utilize the "interrupt on parallel poll response"
    capability of SIMON.  However, until then, this will have to do.
  }
  var
    pprb: packed array[0..7] of boolean;        {parallel poll response byte}
  begin {HPIBupon_ppol_resp}
    try
      with isc_table[uep^.sc], io_drv_ptr^ do
	repeat
	  call(iod_ppoll, io_tmp_ptr, charptr(addr(pprb))^);
	until pprb[uep^.ba];
    recover
      confirm_timeout_and_reset_card(uep);
    call(proc, uep);
  end; {HPIBupon_ppol_resp}
$page$

procedure enter_bdx_chain(uep: uep_type);  forward;
procedure initiate_transfer(uep: uep_type);  forward;
procedure upon_transfer_complete(uep: anyptr); forward;

procedure HPIBupon_dxfr_comp(uep: uep_type; sec: byte; bp: charptr; nb: integer; proc: io_proc);
  var
    isc_te_ptr: ^isc_table_type;
    t_dir: dir_of_tfr;
  begin {HPIBupon_dxfr_comp}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      with bip_type(uep^.dvrtemp)^ do
	begin

	  if read_operation then
	    begin
	      address_for_msge_in (isc_te_ptr^, uep^.ba, sec, standard_tc);
	      t_dir := to_memory;
	    end {then}
	  else
	    begin
	      address_for_msge_out(isc_te_ptr^, uep^.ba, sec, standard_tc);
	      t_dir := from_memory;
	    end; {else}

	  bdx_nb := nb;
	  bdx_proc := proc;

	  with isc_te_ptr^, buf_info do
	    begin
	      drv_tmp_ptr         :=  io_tmp_ptr;
	      active_isc          :=  no_isc;
	      {  act_tfr is set by the driver  }
	      if dma_here
		then usr_tfr      :=  overlap_FASTEST  {DMA, or BURST FHS if both channels are busy}
		else usr_tfr      :=  serial_FHS;      {unlike BURST FHS, won't lock out interrupts}
	      b_w_mode            :=  false;
	      {  end_mode is setup in initiate_transfer  }
	      direction           :=  t_dir;
	      term_char           :=  -1;
	      {  term_count is setup in initiate_transfer  }
	      buf_ptr             :=  anyptr(bp);
	      buf_size            :=  nb;
	      buf_empty           :=  anyptr(bp);
	      buf_fill            :=  anyptr(bp);
	      eot_proc.real_proc  :=  upon_transfer_complete;
	      eot_parm            :=  uep;
	      dma_priority        :=  card_id=hp98625;
	    end; {with}

	  bdx_chain_semaphore := false;
	  enter_bdx_chain(uep);

	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBupon_dxfr_comp}
$page$

procedure enter_bdx_chain(uep: uep_type);
  begin {enter_bdx_chain}
    with bip_type(uep^.dvrtemp)^ do
      if not test_and_toggle(bdx_chain_semaphore) then
	repeat
	  initiate_transfer(uep);
	until test_and_toggle(bdx_chain_semaphore);
  end; {enter_bdx_chain}

procedure initiate_transfer(uep: uep_type);
  var
    maximum_term_count: integer;
  begin {initiate_transfer}
    with bip_type(uep^.dvrtemp)^, isc_table[uep^.sc], buf_info do
      begin
	if (usr_tfr=serial_FHS) or (card_id=hp98625)
	  then maximum_term_count := maxint  {"no" limitation}
	  else maximum_term_count := 65536;  {DMA hardware/9914 driver limitation}
	if bdx_nb<=maximum_term_count
	  then term_count := bdx_nb
	  else term_count := maximum_term_count;
	bdx_nb := bdx_nb-term_count;
	end_mode := (direction=to_memory) or (bdx_nb=0);
	call(io_drv_ptr^.iod_tfr, io_tmp_ptr, addr(buf_info));
      end; {with}
  end; {initiate_transfer}

procedure upon_transfer_complete(uep: anyptr);
  var
    unaddressing_char: char;
  begin {upon_transfer_complete}
    with bip_type(uep_type(uep)^.dvrtemp)^, isc_table[uep_type(uep)^.sc], io_drv_ptr^, buf_info do
      try
	if direction=to_memory then  {check for premature transfer termination}
	  if bdx_nb=0
	    then bdx_pre_eoi := term_count<>0
	    else call(iod_end, io_tmp_ptr, bdx_pre_eoi)
	else
	  bdx_pre_eoi := false;
	if (bdx_nb>0) and not bdx_pre_eoi then {re-initiate the transfer}
	  enter_bdx_chain(uep)
	else {unaddress the bus and call the specified end-of-transfer procedure}
	  begin
	    if direction=to_memory
	      then unaddressing_char := '_'     {untalk}
	      else unaddressing_char := '?';    {unlisten}
	    call(iod_send, io_tmp_ptr, unaddressing_char);
	    call(bdx_proc, uep);
	  end; {else}
      recover
	confirm_timeout_and_reset_card(uep);
  end; {upon_transfer_complete}

end; {discHPIB}

$page$

import
  loader, bkgnd;

begin {init_bkgnd}
  initialize_bkgnd;  {allocate temp space}
  markuser;          {make temp space and modules permanent}
end. {init_bkgnd}



@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 561
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 561
					      (*

 (c) Copyright Hewlett-Packard Company, 1983.
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 'DRVASM', 'IOLIB:KERNEL'$


program init_bkgnd;

module bkgnd;

import
  sysglobals, misc, iodeclarations;

export
  type
    uep_type = {unit entry pointer}
      ^unitentry;
    bi_type = {background info}
      record
	iores               : iorsltwd;      {ioresult                       }
	set_in_use          : boolean;       {allocation flag                }
	async               : boolean;       {overlapped transfer flag       }
	feot                : eotproc;       {end of transfer procedure      }
	fibptr              : fibp;          {file information block ptr     }
	read_operation      : boolean;       {transfer direction flag        }
	buffered_transfer   : boolean;       {amigo driver flag              }
	xfr_chain_semaphore : boolean;       {driver semaphore               }
	bx_tries            : shortint;      {number of previous tries       }
	bx_strt_rcrd        : integer;       {record address                 }
	bx_bufptr           : charptr;       {R/W address pointer            }
	bx_length           : integer;       {total transfer byte count      }
	bx_tfr_length       : integer;       {intermediate tfr byte count    }
	bdx_chain_semaphore : boolean;       {data transfer semaphore        }
	bdx_pre_eoi         : boolean;       {premature eoi flag             }
	bdx_nb              : integer;       {data transfer byte count       }
	bdx_proc            : io_proc;       {data transfer completion proc  }
	buf_info            : buf_info_type; {as defined by the iolibrary    }
      end;
    bip_type = ^bi_type;
$page$

  procedure initialize_bkgnd;
  procedure allocate_bkgnd_info  (uep: uep_type);
  procedure deallocate_bkgnd_info(uep: uep_type);
  procedure abort_bkgnd_process  (uep: uep_type);
  procedure ioresc_bkgnd         (uep: uep_type; ior: iorsltwd);
  function  unit_busy            (uep: uep_type): boolean;
  procedure unit_wait            (uep: uep_type);

implement {bkgnd}

const
  n = 3;  {number of bkgnd info sets}

type
  bia_type = array[0..n-1] of bi_type;

var
  bia_ptr: ^bia_type;
  index: shortint;


procedure initialize_bkgnd;
  var
    local_index: shortint;
  begin {initialize_bkgnd}
    if bia_ptr=nil then
      new(bia_ptr);
    for local_index := 0 to n-1 do
      bia_ptr^[local_index].set_in_use := false;
    index := 0;
  end; {initialize_bkgnd}


function bip_valid(bip: bip_type): boolean;
  var
    local_index: shortint;
  begin {bip_valid}
    bip_valid := false;
    for local_index := 0 to n-1 do
      if bip=addr(bia_ptr^[local_index]) then
	bip_valid := true;
  end; {bip_valid}
$page$

procedure allocate_bkgnd_info(uep: uep_type);
  var
    bip: bip_type;
  begin {allocate_bkgnd_info}
    lockup;
    repeat
      bip := addr(bia_ptr^[index]);
      index := index+1;
      if index>=n then index := 0;
    until not bip^.set_in_use;
    uep^.dvrtemp := integer(bip);
    with bip^ do
      begin
	iores      := inoerror;
	set_in_use := true;
	async      := false;
      end; {with}
  end; {allocate_bkgnd_info}


procedure deallocate_bkgnd_info(uep: uep_type);
  var
    saved_ioresult: integer;
  begin {deallocate_bkgnd_info}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      with bip_type(uep^.dvrtemp)^ do
	begin
	  set_in_use := false;
	  uep^.dvrtemp := ord(iores);
	  lockdown;
	  if async then {call the eot procedure}
	    begin
	      saved_ioresult := ioresult;
	      ioresult := uep^.dvrtemp;
	      call(feot, fibptr);
	      ioresult := saved_ioresult;
	    end; {if}
	end; {with}
  end; {deallocate_bkgnd_info}


procedure abort_bkgnd_process(uep: uep_type);
  begin {abort_bkgnd_process}
    if escapecode<>-10 then  {prevent any eot procedure call while deallocating}
      bip_type(uep^.dvrtemp)^.async := false;
    deallocate_bkgnd_info(uep);
    if escapecode<>-10 then escape(escapecode);
  end; {abort_bkgnd_process}


procedure ioresc_bkgnd(uep: uep_type; ior: iorsltwd);
  begin {ioresc_bkgnd}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      bip_type(uep^.dvrtemp)^.iores := ior;
    escape(-10);
  end; {ioresc_bkgnd}
$page$

function unit_busy(uep: uep_type): boolean;
  begin {unit_busy}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      unit_busy := true
    else
      begin
	unit_busy := false;
	ioresult := uep^.dvrtemp;
      end; {else}
  end; {unit_busy}


procedure unit_wait(uep: uep_type);
  begin {unit_wait}
    while unit_busy(uep) do {nothing};
  end; {unit_wait}


end; {bkgnd}
$page$
$copyright 'COPYRIGHT (C) 1983 BY HEWLETT-PACKARD COMPANY'$


module discHPIB;

import
  sysglobals, iodeclarations, drvasm, bkgnd;

export
  function  Simon_no_DMA       (uep: uep_type): boolean;
  function  Simon_DMA          (uep: uep_type): boolean;
  procedure HPIBcheck_sc       (uep: uep_type);
  procedure HPIBwait_for_ppol  (uep: uep_type);
  procedure HPIBshort_msge_out (uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  procedure HPIBamigo_clear    (uep: uep_type);
  procedure HPIBshort_msge_in  (uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  function  HPIBamigo_identify (uep: uep_type): shortint;
  procedure HPIBget_amigo_ident(uep: uep_type; var ident: shortint);
  procedure HPIBupon_ppol_resp (uep: uep_type; proc: io_proc);
  procedure HPIBupon_dxfr_comp (uep: uep_type; sec: byte; bp: charptr; nb: integer; proc: io_proc);

implement {discHPIB}


const
  standard_tc = 5000;   {standard byte timeout value milliseconds}
  short_tc = 25;        {short byte timeout value milliseconds}
  SDC = 4;              {selective device clear}
  LAG_base = 32;        {listen address group base}
  TAG_base = 64;        {talk address group base}
  SCG_base = 96;        {secondary command group base}


procedure delay_timer(microsec_value: integer); external;


procedure confirm_timeout_and_reset_card(uep: uep_type);
  begin {confirm_timeout_and_reset_card}
    if (escapecode<>ioescapecode) or (ioe_isc<>uep^.sc) then escape(escapecode);
    if ioe_result<>ioe_timeout then ioresc_bkgnd(uep, znodevice);
    with isc_table[uep^.sc] do
      call(io_drv_ptr^.iod_init, io_tmp_ptr);
    ioresc_bkgnd(uep, ztimeout);
  end; {confirm_timeout_and_reset_card}

$page$

function Simon_no_DMA(uep: uep_type): boolean;
  begin {Simon_no_DMA}
    with isc_table[uep^.sc] do
      Simon_no_DMA := (card_id=hp98625) and not dma_here;
  end; {Simon_no_DMA}


function Simon_DMA(uep: uep_type): boolean;
  begin {Simon_DMA}
    with isc_table[uep^.sc] do
      Simon_DMA := (card_id=hp98625) and dma_here;
  end; {Simon_DMA}


procedure HPIBcheck_sc(uep: uep_type);
  begin {HPIBcheck_sc}
    with isc_table[uep^.sc] do
      begin
	if card_type<>hpib_card then
	  ioresc_bkgnd(uep, znodevice);
	with io_tmp_ptr^ do
	  while (in_bufptr<>nil) or (out_bufptr<>nil) do {nothing};
      end; {with}
  end; {HPIBcheck_sc}


procedure HPIBwait_for_ppol(uep: uep_type);
  var
    pprb: packed array[0..7] of boolean;        {parallel poll response byte}
  begin {HPIBwait_for_ppol}
    try
      with isc_table[uep^.sc], io_drv_ptr^ do
	repeat
	  call(iod_ppoll, io_tmp_ptr, charptr(addr(pprb))^);
	until pprb[uep^.ba];
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBwait_for_ppol}
$page$

procedure address_for_msge_out(var isc_te: isc_table_type; ba, sec: byte; tc: integer);
  var
    dummy_char: char;
  begin {address_for_msge_out}
    with isc_te, io_drv_ptr^ do
      begin
	call(iod_send, io_tmp_ptr, '?');
	io_tmp_ptr^.timeout := tc;
	call(iod_send, io_tmp_ptr, chr(TAG_base+io_tmp_ptr^.addressed));
	call(iod_send, io_tmp_ptr, chr(LAG_base+ba));
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
	call(iod_send, io_tmp_ptr, chr(SCG_base+sec));
	call(iod_ppoll, io_tmp_ptr, dummy_char);  {enforce timeout}
      end; {with}
  end; {address_for_msge_out}

procedure HPIBshort_msge_out(uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  var
    isc_te_ptr: ^isc_table_type;
  begin {HPIBshort_msge_out}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_out(isc_te_ptr^, uep^.ba, sec, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  while nb>1 do
	    begin
	      call(iod_wtb,  io_tmp_ptr, bp^);
	      bp := addr(bp^, 1);
	      nb := nb-1;
	    end; {while}
	  call(iod_set,  io_tmp_ptr, ord(eoi_line));
	  call(iod_wtb,  io_tmp_ptr, bp^);
	  call(iod_send, io_tmp_ptr, '?');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBshort_msge_out}

procedure HPIBamigo_clear(uep: uep_type);
  var
    isc_te_ptr: ^isc_table_type;
  begin {HPIBamigo_clear}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_out(isc_te_ptr^, uep^.ba, 16, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  call(iod_set,  io_tmp_ptr, ord(eoi_line));
	  call(iod_wtb,  io_tmp_ptr, chr(0));  {disable parity check}
	  call(iod_send, io_tmp_ptr, chr(SDC));
	  call(iod_send, io_tmp_ptr, '?');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBamigo_clear}
$page$

procedure address_for_msge_in(var isc_te: isc_table_type; ba, sec: byte; tc: integer);
  var
    dummy_char: char;
  begin {address_for_msge_in}
    with isc_te, io_drv_ptr^ do
      begin
	call(iod_send, io_tmp_ptr, '?');
	io_tmp_ptr^.timeout := tc;
	call(iod_send, io_tmp_ptr, chr(LAG_base+io_tmp_ptr^.addressed));
	call(iod_send, io_tmp_ptr, chr(TAG_base+ba));
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
	call(iod_send, io_tmp_ptr, chr(SCG_base+sec));
	call(iod_ppoll, io_tmp_ptr, dummy_char);  {enforce timeout}
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
      end; {with}
  end; {address_for_msge_in}


procedure premature_eoi(uep: uep_type);
  begin {premature_eoi}
    with isc_table[uep^.sc] do
      call(io_drv_ptr^.iod_send, io_tmp_ptr, '_');
    ioresc_bkgnd(uep, zbadhardware);  {all "expected" premature eoi's have to be trapped}
  end; {premature_eoi}


procedure HPIBshort_msge_in(uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  var
    isc_te_ptr: ^isc_table_type;
    eoi_set: boolean;
  begin {HPIBshort_msge_in}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_in(isc_te_ptr^, uep^.ba, sec, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  while nb>1 do
	    begin
	      call(iod_rdb,  io_tmp_ptr, bp^);
	      call(iod_end,  io_tmp_ptr, eoi_set);
	      if eoi_set then premature_eoi(uep);
	      bp := addr(bp^, 1);
	      nb := nb-1;
	    end; {while}
	  call(iod_rdb,  io_tmp_ptr, bp^);
	  call(iod_send, io_tmp_ptr, '_');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBshort_msge_in}
$page$

function HPIBamigo_identify(uep: uep_type): shortint;
  var
    isc_te_ptr: ^isc_table_type;
    ident: {the two identify bytes}
      record case integer of
	0: (word: shortint);
	1: (upper_char, lower_char: char);
      end;
    eoi_set: boolean;
  begin {HPIBamigo_identify}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_in(isc_te_ptr^, {"ba"} 31, {"sec"} uep^.ba, short_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  call(iod_rdb,  io_tmp_ptr, ident.upper_char);
	  call(iod_end,  io_tmp_ptr, eoi_set);
	  if eoi_set then premature_eoi(uep);
	  call(iod_rdb,  io_tmp_ptr, ident.lower_char);
	  call(iod_send, io_tmp_ptr, chr(TAG_base+io_tmp_ptr^.addressed));
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
    HPIBamigo_identify := ident.word;
  end; {HPIBamigo_identify}


procedure HPIBget_amigo_ident(uep: uep_type; var ident: shortint);
  begin {HPIBget_amigo_ident}
    ident := HPIBamigo_identify(uep);
  end; {HPIBget_amigo_ident}


procedure HPIBupon_ppol_resp(uep: uep_type; proc: io_proc);
  {
    NOTE: when SIMON drivers become available, this routine needs to
    be modified to utilize the "interrupt on parallel poll response"
    capability of SIMON.  However, until then, this will have to do.
  }
  var
    pprb: packed array[0..7] of boolean;        {parallel poll response byte}
  begin {HPIBupon_ppol_resp}
    try
      with isc_table[uep^.sc], io_drv_ptr^ do
	repeat
	  call(iod_ppoll, io_tmp_ptr, charptr(addr(pprb))^);
	until pprb[uep^.ba];
    recover
      confirm_timeout_and_reset_card(uep);
    call(proc, uep);
  end; {HPIBupon_ppol_resp}
$page$

procedure enter_bdx_chain(uep: uep_type);  forward;
procedure initiate_transfer(uep: uep_type);  forward;
procedure upon_transfer_complete(uep: anyptr); forward;

procedure HPIBupon_dxfr_comp(uep: uep_type; sec: byte; bp: charptr; nb: integer; proc: io_proc);
  var
    isc_te_ptr: ^isc_table_type;
    t_dir: dir_of_tfr;
  begin {HPIBupon_dxfr_comp}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      with bip_type(uep^.dvrtemp)^ do
	begin

	  if read_operation then
	    begin
	      address_for_msge_in (isc_te_ptr^, uep^.ba, sec, standard_tc);
	      t_dir := to_memory;
	    end {then}
	  else
	    begin
	      address_for_msge_out(isc_te_ptr^, uep^.ba, sec, standard_tc);
	      t_dir := from_memory;
	    end; {else}

	  bdx_nb := nb;
	  bdx_proc := proc;

	  with isc_te_ptr^, buf_info do
	    begin
	      drv_tmp_ptr         :=  io_tmp_ptr;
	      active_isc          :=  no_isc;
	      {  act_tfr is set by the driver  }
	      if dma_here
		then usr_tfr      :=  overlap_FASTEST  {DMA, or BURST FHS if both channels are busy}
		else usr_tfr      :=  serial_FHS;      {unlike BURST FHS, won't lock out interrupts}
	      b_w_mode            :=  false;
	      {  end_mode is setup in initiate_transfer  }
	      direction           :=  t_dir;
	      term_char           :=  -1;
	      {  term_count is setup in initiate_transfer  }
	      buf_ptr             :=  anyptr(bp);
	      buf_size            :=  nb;
	      buf_empty           :=  anyptr(bp);
	      buf_fill            :=  anyptr(bp);
	      eot_proc.real_proc  :=  upon_transfer_complete;
	      eot_parm            :=  uep;
	      dma_priority        :=  card_id=hp98625;
	    end; {with}

	  bdx_chain_semaphore := false;
	  enter_bdx_chain(uep);

	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBupon_dxfr_comp}
$page$

procedure enter_bdx_chain(uep: uep_type);
  begin {enter_bdx_chain}
    with bip_type(uep^.dvrtemp)^ do
      if not test_and_toggle(bdx_chain_semaphore) then
	repeat
	  initiate_transfer(uep);
	until test_and_toggle(bdx_chain_semaphore);
  end; {enter_bdx_chain}

procedure initiate_transfer(uep: uep_type);
  var
    maximum_term_count: integer;
  begin {initiate_transfer}
    with bip_type(uep^.dvrtemp)^, isc_table[uep^.sc], buf_info do
      begin
	if (usr_tfr=serial_FHS) or (card_id=hp98625)
	  then maximum_term_count := maxint  {"no" limitation}
	  else maximum_term_count := 65536;  {DMA hardware/9914 driver limitation}
	if bdx_nb<=maximum_term_count
	  then term_count := bdx_nb
	  else term_count := maximum_term_count;
	bdx_nb := bdx_nb-term_count;
	end_mode := (direction=to_memory) or (bdx_nb=0);
	call(io_drv_ptr^.iod_tfr, io_tmp_ptr, addr(buf_info));
      end; {with}
  end; {initiate_transfer}

procedure upon_transfer_complete(uep: anyptr);
  var
    unaddressing_char: char;
  begin {upon_transfer_complete}
    with bip_type(uep_type(uep)^.dvrtemp)^, isc_table[uep_type(uep)^.sc], io_drv_ptr^, buf_info do
      try
	if direction=to_memory then  {check for premature transfer termination}
	  if bdx_nb=0
	    then bdx_pre_eoi := term_count<>0
	    else call(iod_end, io_tmp_ptr, bdx_pre_eoi)
	else
	  bdx_pre_eoi := false;
	if (bdx_nb>0) and not bdx_pre_eoi then {re-initiate the transfer}
	  enter_bdx_chain(uep)
	else {unaddress the bus and call the specified end-of-transfer procedure}
	  begin
	    if direction=to_memory
	      then unaddressing_char := '_'     {untalk}
	      else unaddressing_char := '?';    {unlisten}
	    call(iod_send, io_tmp_ptr, unaddressing_char);
	    call(bdx_proc, uep);
	  end; {else}
      recover
	confirm_timeout_and_reset_card(uep);
  end; {upon_transfer_complete}

end; {discHPIB}

$page$

import
  loader, bkgnd;

begin {init_bkgnd}
  initialize_bkgnd;  {allocate temp space}
  markuser;          {make temp space and modules permanent}
end. {init_bkgnd}



@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 12:27:56 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 561
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 561
					      (*

 (c) Copyright Hewlett-Packard Company, 1983.
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 'DRVASM', 'IOLIB:KERNEL'$


program init_bkgnd;

module bkgnd;

import
  sysglobals, misc, iodeclarations;

export
  type
    uep_type = {unit entry pointer}
      ^unitentry;
    bi_type = {background info}
      record
	iores               : iorsltwd;      {ioresult                       }
	set_in_use          : boolean;       {allocation flag                }
	async               : boolean;       {overlapped transfer flag       }
	feot                : eotproc;       {end of transfer procedure      }
	fibptr              : fibp;          {file information block ptr     }
	read_operation      : boolean;       {transfer direction flag        }
	buffered_transfer   : boolean;       {amigo driver flag              }
	xfr_chain_semaphore : boolean;       {driver semaphore               }
	bx_tries            : shortint;      {number of previous tries       }
	bx_strt_rcrd        : integer;       {record address                 }
	bx_bufptr           : charptr;       {R/W address pointer            }
	bx_length           : integer;       {total transfer byte count      }
	bx_tfr_length       : integer;       {intermediate tfr byte count    }
	bdx_chain_semaphore : boolean;       {data transfer semaphore        }
	bdx_pre_eoi         : boolean;       {premature eoi flag             }
	bdx_nb              : integer;       {data transfer byte count       }
	bdx_proc            : io_proc;       {data transfer completion proc  }
	buf_info            : buf_info_type; {as defined by the iolibrary    }
      end;
    bip_type = ^bi_type;
$page$

  procedure initialize_bkgnd;
  procedure allocate_bkgnd_info  (uep: uep_type);
  procedure deallocate_bkgnd_info(uep: uep_type);
  procedure abort_bkgnd_process  (uep: uep_type);
  procedure ioresc_bkgnd         (uep: uep_type; ior: iorsltwd);
  function  unit_busy            (uep: uep_type): boolean;
  procedure unit_wait            (uep: uep_type);

implement {bkgnd}

const
  n = 3;  {number of bkgnd info sets}

type
  bia_type = array[0..n-1] of bi_type;

var
  bia_ptr: ^bia_type;
  index: shortint;


procedure initialize_bkgnd;
  var
    local_index: shortint;
  begin {initialize_bkgnd}
    if bia_ptr=nil then
      new(bia_ptr);
    for local_index := 0 to n-1 do
      bia_ptr^[local_index].set_in_use := false;
    index := 0;
  end; {initialize_bkgnd}


function bip_valid(bip: bip_type): boolean;
  var
    local_index: shortint;
  begin {bip_valid}
    bip_valid := false;
    for local_index := 0 to n-1 do
      if bip=addr(bia_ptr^[local_index]) then
	bip_valid := true;
  end; {bip_valid}
$page$

procedure allocate_bkgnd_info(uep: uep_type);
  var
    bip: bip_type;
  begin {allocate_bkgnd_info}
    lockup;
    repeat
      bip := addr(bia_ptr^[index]);
      index := index+1;
      if index>=n then index := 0;
    until not bip^.set_in_use;
    uep^.dvrtemp := integer(bip);
    with bip^ do
      begin
	iores      := inoerror;
	set_in_use := true;
	async      := false;
      end; {with}
  end; {allocate_bkgnd_info}


procedure deallocate_bkgnd_info(uep: uep_type);
  var
    saved_ioresult: integer;
  begin {deallocate_bkgnd_info}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      with bip_type(uep^.dvrtemp)^ do
	begin
	  set_in_use := false;
	  uep^.dvrtemp := ord(iores);
	  lockdown;
	  if async then {call the eot procedure}
	    begin
	      saved_ioresult := ioresult;
	      ioresult := uep^.dvrtemp;
	      call(feot, fibptr);
	      ioresult := saved_ioresult;
	    end; {if}
	end; {with}
  end; {deallocate_bkgnd_info}


procedure abort_bkgnd_process(uep: uep_type);
  begin {abort_bkgnd_process}
    if escapecode<>-10 then  {prevent any eot procedure call while deallocating}
      bip_type(uep^.dvrtemp)^.async := false;
    deallocate_bkgnd_info(uep);
    if escapecode<>-10 then escape(escapecode);
  end; {abort_bkgnd_process}


procedure ioresc_bkgnd(uep: uep_type; ior: iorsltwd);
  begin {ioresc_bkgnd}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      bip_type(uep^.dvrtemp)^.iores := ior;
    escape(-10);
  end; {ioresc_bkgnd}
$page$

function unit_busy(uep: uep_type): boolean;
  begin {unit_busy}
    if bip_valid(bip_type(uep^.dvrtemp)) then
      unit_busy := true
    else
      begin
	unit_busy := false;
	ioresult := uep^.dvrtemp;
      end; {else}
  end; {unit_busy}


procedure unit_wait(uep: uep_type);
  begin {unit_wait}
    while unit_busy(uep) do {nothing};
  end; {unit_wait}


end; {bkgnd}
$page$
$copyright 'COPYRIGHT (C) 1983 BY HEWLETT-PACKARD COMPANY'$


module discHPIB;

import
  sysglobals, iodeclarations, drvasm, bkgnd;

export
  function  Simon_no_DMA       (uep: uep_type): boolean;
  function  Simon_DMA          (uep: uep_type): boolean;
  procedure HPIBcheck_sc       (uep: uep_type);
  procedure HPIBwait_for_ppol  (uep: uep_type);
  procedure HPIBshort_msge_out (uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  procedure HPIBamigo_clear    (uep: uep_type);
  procedure HPIBshort_msge_in  (uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  function  HPIBamigo_identify (uep: uep_type): shortint;
  procedure HPIBget_amigo_ident(uep: uep_type; var ident: shortint);
  procedure HPIBupon_ppol_resp (uep: uep_type; proc: io_proc);
  procedure HPIBupon_dxfr_comp (uep: uep_type; sec: byte; bp: charptr; nb: integer; proc: io_proc);

implement {discHPIB}


const
  standard_tc = 5000;   {standard byte timeout value milliseconds}
  short_tc = 25;        {short byte timeout value milliseconds}
  SDC = 4;              {selective device clear}
  LAG_base = 32;        {listen address group base}
  TAG_base = 64;        {talk address group base}
  SCG_base = 96;        {secondary command group base}


procedure delay_timer(microsec_value: integer); external;


procedure confirm_timeout_and_reset_card(uep: uep_type);
  begin {confirm_timeout_and_reset_card}
    if (escapecode<>ioescapecode) or (ioe_isc<>uep^.sc) then escape(escapecode);
    if ioe_result<>ioe_timeout then ioresc_bkgnd(uep, znodevice);
    with isc_table[uep^.sc] do
      call(io_drv_ptr^.iod_init, io_tmp_ptr);
    ioresc_bkgnd(uep, ztimeout);
  end; {confirm_timeout_and_reset_card}

$page$

function Simon_no_DMA(uep: uep_type): boolean;
  begin {Simon_no_DMA}
    with isc_table[uep^.sc] do
      Simon_no_DMA := (card_id=hp98625) and not dma_here;
  end; {Simon_no_DMA}


function Simon_DMA(uep: uep_type): boolean;
  begin {Simon_DMA}
    with isc_table[uep^.sc] do
      Simon_DMA := (card_id=hp98625) and dma_here;
  end; {Simon_DMA}


procedure HPIBcheck_sc(uep: uep_type);
  begin {HPIBcheck_sc}
    with isc_table[uep^.sc] do
      begin
	if card_type<>hpib_card then
	  ioresc_bkgnd(uep, znodevice);
	with io_tmp_ptr^ do
	  while (in_bufptr<>nil) or (out_bufptr<>nil) do {nothing};
      end; {with}
  end; {HPIBcheck_sc}


procedure HPIBwait_for_ppol(uep: uep_type);
  var
    pprb: packed array[0..7] of boolean;        {parallel poll response byte}
  begin {HPIBwait_for_ppol}
    try
      with isc_table[uep^.sc], io_drv_ptr^ do
	repeat
	  call(iod_ppoll, io_tmp_ptr, charptr(addr(pprb))^);
	until pprb[uep^.ba];
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBwait_for_ppol}
$page$

procedure address_for_msge_out(var isc_te: isc_table_type; ba, sec: byte; tc: integer);
  var
    dummy_char: char;
  begin {address_for_msge_out}
    with isc_te, io_drv_ptr^ do
      begin
	call(iod_send, io_tmp_ptr, '?');
	io_tmp_ptr^.timeout := tc;
	call(iod_send, io_tmp_ptr, chr(TAG_base+io_tmp_ptr^.addressed));
	call(iod_send, io_tmp_ptr, chr(LAG_base+ba));
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
	call(iod_send, io_tmp_ptr, chr(SCG_base+sec));
	call(iod_ppoll, io_tmp_ptr, dummy_char);  {enforce timeout}
      end; {with}
  end; {address_for_msge_out}

procedure HPIBshort_msge_out(uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  var
    isc_te_ptr: ^isc_table_type;
  begin {HPIBshort_msge_out}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_out(isc_te_ptr^, uep^.ba, sec, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  while nb>1 do
	    begin
	      call(iod_wtb,  io_tmp_ptr, bp^);
	      bp := addr(bp^, 1);
	      nb := nb-1;
	    end; {while}
	  call(iod_set,  io_tmp_ptr, ord(eoi_line));
	  call(iod_wtb,  io_tmp_ptr, bp^);
	  call(iod_send, io_tmp_ptr, '?');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBshort_msge_out}

procedure HPIBamigo_clear(uep: uep_type);
  var
    isc_te_ptr: ^isc_table_type;
  begin {HPIBamigo_clear}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_out(isc_te_ptr^, uep^.ba, 16, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  call(iod_set,  io_tmp_ptr, ord(eoi_line));
	  call(iod_wtb,  io_tmp_ptr, chr(0));  {disable parity check}
	  call(iod_send, io_tmp_ptr, chr(SDC));
	  call(iod_send, io_tmp_ptr, '?');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBamigo_clear}
$page$

procedure address_for_msge_in(var isc_te: isc_table_type; ba, sec: byte; tc: integer);
  var
    dummy_char: char;
  begin {address_for_msge_in}
    with isc_te, io_drv_ptr^ do
      begin
	call(iod_send, io_tmp_ptr, '?');
	io_tmp_ptr^.timeout := tc;
	call(iod_send, io_tmp_ptr, chr(LAG_base+io_tmp_ptr^.addressed));
	call(iod_send, io_tmp_ptr, chr(TAG_base+ba));
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
	call(iod_send, io_tmp_ptr, chr(SCG_base+sec));
	call(iod_ppoll, io_tmp_ptr, dummy_char);  {enforce timeout}
	if card_id<>hp98625 then  {delay to avoid Chinook bug}
	  delay_timer(85 {microseconds});
      end; {with}
  end; {address_for_msge_in}


procedure premature_eoi(uep: uep_type);
  begin {premature_eoi}
    with isc_table[uep^.sc] do
      call(io_drv_ptr^.iod_send, io_tmp_ptr, '_');
    ioresc_bkgnd(uep, zbadhardware);  {all "expected" premature eoi's have to be trapped}
  end; {premature_eoi}


procedure HPIBshort_msge_in(uep: uep_type; sec: byte; bp: charptr; nb: shortint);
  var
    isc_te_ptr: ^isc_table_type;
    eoi_set: boolean;
  begin {HPIBshort_msge_in}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_in(isc_te_ptr^, uep^.ba, sec, standard_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  while nb>1 do
	    begin
	      call(iod_rdb,  io_tmp_ptr, bp^);
	      call(iod_end,  io_tmp_ptr, eoi_set);
	      if eoi_set then premature_eoi(uep);
	      bp := addr(bp^, 1);
	      nb := nb-1;
	    end; {while}
	  call(iod_rdb,  io_tmp_ptr, bp^);
	  call(iod_send, io_tmp_ptr, '_');
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBshort_msge_in}
$page$

function HPIBamigo_identify(uep: uep_type): shortint;
  var
    isc_te_ptr: ^isc_table_type;
    ident: {the two identify bytes}
      record case integer of
	0: (word: shortint);
	1: (upper_char, lower_char: char);
      end;
    eoi_set: boolean;
  begin {HPIBamigo_identify}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      address_for_msge_in(isc_te_ptr^, {"ba"} 31, {"sec"} uep^.ba, short_tc);
      with isc_te_ptr^, io_drv_ptr^ do
	begin
	  call(iod_rdb,  io_tmp_ptr, ident.upper_char);
	  call(iod_end,  io_tmp_ptr, eoi_set);
	  if eoi_set then premature_eoi(uep);
	  call(iod_rdb,  io_tmp_ptr, ident.lower_char);
	  call(iod_send, io_tmp_ptr, chr(TAG_base+io_tmp_ptr^.addressed));
	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
    HPIBamigo_identify := ident.word;
  end; {HPIBamigo_identify}


procedure HPIBget_amigo_ident(uep: uep_type; var ident: shortint);
  begin {HPIBget_amigo_ident}
    ident := HPIBamigo_identify(uep);
  end; {HPIBget_amigo_ident}


procedure HPIBupon_ppol_resp(uep: uep_type; proc: io_proc);
  {
    NOTE: when SIMON drivers become available, this routine needs to
    be modified to utilize the "interrupt on parallel poll response"
    capability of SIMON.  However, until then, this will have to do.
  }
  var
    pprb: packed array[0..7] of boolean;        {parallel poll response byte}
  begin {HPIBupon_ppol_resp}
    try
      with isc_table[uep^.sc], io_drv_ptr^ do
	repeat
	  call(iod_ppoll, io_tmp_ptr, charptr(addr(pprb))^);
	until pprb[uep^.ba];
    recover
      confirm_timeout_and_reset_card(uep);
    call(proc, uep);
  end; {HPIBupon_ppol_resp}
$page$

procedure enter_bdx_chain(uep: uep_type);  forward;
procedure initiate_transfer(uep: uep_type);  forward;
procedure upon_transfer_complete(uep: anyptr); forward;

procedure HPIBupon_dxfr_comp(uep: uep_type; sec: byte; bp: charptr; nb: integer; proc: io_proc);
  var
    isc_te_ptr: ^isc_table_type;
    t_dir: dir_of_tfr;
  begin {HPIBupon_dxfr_comp}
    try
      isc_te_ptr := addr(isc_table[uep^.sc]);
      with bip_type(uep^.dvrtemp)^ do
	begin

	  if read_operation then
	    begin
	      address_for_msge_in (isc_te_ptr^, uep^.ba, sec, standard_tc);
	      t_dir := to_memory;
	    end {then}
	  else
	    begin
	      address_for_msge_out(isc_te_ptr^, uep^.ba, sec, standard_tc);
	      t_dir := from_memory;
	    end; {else}

	  bdx_nb := nb;
	  bdx_proc := proc;

	  with isc_te_ptr^, buf_info do
	    begin
	      drv_tmp_ptr         :=  io_tmp_ptr;
	      active_isc          :=  no_isc;
	      {  act_tfr is set by the driver  }
	      if dma_here
		then usr_tfr      :=  overlap_FASTEST  {DMA, or BURST FHS if both channels are busy}
		else usr_tfr      :=  serial_FHS;      {unlike BURST FHS, won't lock out interrupts}
	      b_w_mode            :=  false;
	      {  end_mode is setup in initiate_transfer  }
	      direction           :=  t_dir;
	      term_char           :=  -1;
	      {  term_count is setup in initiate_transfer  }
	      buf_ptr             :=  anyptr(bp);
	      buf_size            :=  nb;
	      buf_empty           :=  anyptr(bp);
	      buf_fill            :=  anyptr(bp);
	      eot_proc.real_proc  :=  upon_transfer_complete;
	      eot_parm            :=  uep;
	      dma_priority        :=  card_id=hp98625;
	    end; {with}

	  bdx_chain_semaphore := false;
	  enter_bdx_chain(uep);

	end; {with}
    recover
      confirm_timeout_and_reset_card(uep);
  end; {HPIBupon_dxfr_comp}
$page$

procedure enter_bdx_chain(uep: uep_type);
  begin {enter_bdx_chain}
    with bip_type(uep^.dvrtemp)^ do
      if not test_and_toggle(bdx_chain_semaphore) then
	repeat
	  initiate_transfer(uep);
	until test_and_toggle(bdx_chain_semaphore);
  end; {enter_bdx_chain}

procedure initiate_transfer(uep: uep_type);
  var
    maximum_term_count: integer;
  begin {initiate_transfer}
    with bip_type(uep^.dvrtemp)^, isc_table[uep^.sc], buf_info do
      begin
	if (usr_tfr=serial_FHS) or (card_id=hp98625)
	  then maximum_term_count := maxint  {"no" limitation}
	  else maximum_term_count := 65536;  {DMA hardware/9914 driver limitation}
	if bdx_nb<=maximum_term_count
	  then term_count := bdx_nb
	  else term_count := maximum_term_count;
	bdx_nb := bdx_nb-term_count;
	end_mode := (direction=to_memory) or (bdx_nb=0);
	call(io_drv_ptr^.iod_tfr, io_tmp_ptr, addr(buf_info));
      end; {with}
  end; {initiate_transfer}

procedure upon_transfer_complete(uep: anyptr);
  var
    unaddressing_char: char;
  begin {upon_transfer_complete}
    with bip_type(uep_type(uep)^.dvrtemp)^, isc_table[uep_type(uep)^.sc], io_drv_ptr^, buf_info do
      try
	if direction=to_memory then  {check for premature transfer termination}
	  if bdx_nb=0
	    then bdx_pre_eoi := term_count<>0
	    else call(iod_end, io_tmp_ptr, bdx_pre_eoi)
	else
	  bdx_pre_eoi := false;
	if (bdx_nb>0) and not bdx_pre_eoi then {re-initiate the transfer}
	  enter_bdx_chain(uep)
	else {unaddress the bus and call the specified end-of-transfer procedure}
	  begin
	    if direction=to_memory
	      then unaddressing_char := '_'     {untalk}
	      else unaddressing_char := '?';    {unlisten}
	    call(iod_send, io_tmp_ptr, unaddressing_char);
	    call(bdx_proc, uep);
	  end; {else}
      recover
	confirm_timeout_and_reset_card(uep);
  end; {upon_transfer_complete}

end; {discHPIB}

$page$

import
  loader, bkgnd;

begin {init_bkgnd}
  initialize_bkgnd;  {allocate temp space}
  markuser;          {make temp space and modules permanent}
end. {init_bkgnd}



@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
