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


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

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

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

55.1
date     91.08.25.10.26.22;  author jwh;  state Exp;
branches ;
next     54.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

26.1
date     88.09.28.13.20.11;  author bayes;  state Exp;
branches ;
next     25.2;

25.2
date     88.03.30.09.11.34;  author bayes;  state Exp;
branches ;
next     25.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1.1
date     86.06.30.15.49.40;  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
@$TABLES$
$LIST OFF$
{                                                                           }
{ Graphics Low End                                                          }
{                                                                           }
{ Module    = GLE_HPIB                                                      }
{ Programer = BJS                                                           }
{ Date      = 10-10-82                                                      }
{                                                                           }
{ Purpose: To provide IO routines for ascii device handlers.                }

{ Rev history                                                               }
{  Created  - 10-10-82                                                      }
{  Modified - 12-12-83 BDS -- Brought needed general_1 and hpib_1           }
{                             routines in-line.                             }

{     (c) Copyright Hewlett-Packard Company, 1985.
      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                              }

$SEARCH 'GLE_TYPES',
	'GLE_UTLS'$
$modcal$
$ALLOW_PACKED ON$   { JWS 4/10/85 }

$include 'OPTIONS'$  { ******************* COMPILER OPTIONS *************** }
$LINENUM 10000$

module gle_hpib_io;

import gle_types,
       general_0,
       iocomasm;

export
type
  hpib_iocb_ptr = ^ hpib_iocb;
  hpib_iocb = record
		device_addr : anyptr;
		name_size   : gle_shortint;
		address     : integer;
		select_code : integer;
		error       : integer;
	      end;
  timeoutrec = record                          {tttt JS 8/3/83}
		counter: integer;              {tttt JS 8/3/83}
		firsttime: boolean;            {tttt JS 8/3/83}
	       end;                            {tttt JS 8/3/83}

procedure hpib_init  ( anyvar iocb_ptr : anyptr );
procedure hpib_inq_timeout ( anyvar iocb_ptr : anyptr; var value : integer );
procedure hpib_set_timeout ( anyvar iocb_ptr : anyptr; value : integer );
procedure hpib_write ( anyvar iocb_ptr, data_ptr : anyptr );
procedure hpib_read  ( anyvar iocb_ptr, data_ptr : anyptr );
procedure hpib_term  ( anyvar iocb_ptr : anyptr );

implement

import
   iodeclarations,
   {general_1,}
   {hpib_1,}
   gle_utls;

{ The following types must match types declared in GLE_HPGL, and GLE_HPGLI }
type
  ascii_buffer_ptr = ^ascii_buffer;

  ascii_buffer = packed record
		   maximum : integer;
		   current : integer;
		   data    : packed array [1..32767] of char;
		 end;

{||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}

			 {*** general_1 ***}

{The following procedures have been brought in-line to avoid importing
 general_1 and hpib_1. NOTE: These routines must be duplicates of those
 found in general_1 and hpib_1 and therefore must reflect any modifications
 to those modules.                                                }



  FUNCTION timerexists: boolean;  external;         { tttt JS 8/3/83 }

  FUNCTION timed_out(var rec: timeoutrec): boolean; external; {tttt JS 8/3/83}


  PROCEDURE ioreset     ( select_code : type_isc);
  BEGIN
    WITH isc_table[select_code] DO
    CALL(io_drv_ptr^.iod_init,
	 io_tmp_ptr);
  END; { of ioreset }


  PROCEDURE writechar   ( select_code : type_isc ;
			  value       : CHAR );
  BEGIN
    WITH isc_table[select_code] DO
    CALL(io_drv_ptr^.iod_wtb,
	 io_tmp_ptr,
	 value);
  END; { of writechar }

  PROCEDURE set_timeout ( select_code : type_isc ;
			  time        : REAL            { in seconds } );
  BEGIN
    IF time>8191                { 4 byte timeout  - 1 byte left for shifts }
      THEN BEGIN
	{ error }
	io_escape(ioe_bad_tmo,select_code);
      END; { of IF }
    IF (time>0) AND (time<0.001)
      THEN BEGIN
	{ error }
	io_escape(ioe_bad_tmo,select_code);
      END; { of IF }

    WITH isc_table[select_code] DO BEGIN

      { the table entry used by drivers is in milliseconds }
      user_time:=ROUND(time*1000);

      IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout := user_time;

    END; { of WITH DO BEGIN }

  END; { of set_timeout }

			 {*** hpib_1 ***}

  PROCEDURE send_command( select_code : type_isc ;
			  command     : CHAR );
  BEGIN
    WITH isc_table[select_code] DO
      CALL ( io_drv_ptr^.iod_send,
	     io_tmp_ptr,
	     command);
  END; { of send_command }



  FUNCTION  my_address  ( select_code : type_isc)
	    : type_hpib_addr ;
  BEGIN
    IF isc_table[select_code].io_tmp_ptr <> NIL
      THEN BEGIN
	WITH isc_table[select_code].io_tmp_ptr^ DO
	  IF addressed <> -1
	    THEN BEGIN
	      my_address:=addressed;
	    END
	    ELSE BEGIN
	      { error }
	      io_escape(ioe_not_hpib,select_code);
	    END; { of IF addressed }
      END
      ELSE BEGIN
	{ error }
	io_escape(ioe_not_hpib,select_code);
      END; { of IF io_tmp_ptr }
  END; { of my_address }



  FUNCTION  active_controller
			( select_code : type_isc)
			: BOOLEAN;
  BEGIN
    IF isc_table[select_code].card_type=hpib_card
      THEN BEGIN
	active_controller:=bit_set(iostatus(select_code,3),6);
      END
      ELSE BEGIN
	active_controller := TRUE;
      END; { of IF }
  END; { of active_controller }



  {************************* this function is not used  ********************}
  {FUNCTION  system_controller
			( select_code : type_isc)
			: BOOLEAN;
  BEGIN
    IF isc_table[select_code].card_type=hpib_card
      THEN BEGIN
	system_controller:=bit_set(iostatus(select_code,3),7);
      END
      ELSE BEGIN
	system_controller := TRUE;
      END;  of IF
  END;  of system_controller }



  {************************** this functio is not used *******************}
  {FUNCTION  end_set     ( select_code : type_isc )
			: BOOLEAN ;
  VAR mybool : BOOLEAN;
  BEGIN
    WITH isc_table[select_code] DO
      CALL ( io_drv_ptr^.iod_end,
	     io_tmp_ptr,
	     mybool);
    end_set := mybool;
  END;  of send_command }


  $PAGE$

  FUNCTION  addr_to_talk( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
      timer  : INTEGER;
      hpibrec: timeoutrec;                                    {tttt JS 8/3/83}

  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=device DIV 100;

	WITH isc_table[io_isc] DO BEGIN

	  IF io_tmp_ptr <> NIL
	    THEN BEGIN

	      { set up user timeout - in case system drivers changed it }
	      io_tmp_ptr^.timeout:=user_time;

	      IF io_tmp_ptr^.addressed <> -1
		THEN BEGIN
		  IF ( card_type <> hpib_card ) AND
		     ( device MOD 100 > 31 )
		    THEN io_escape(ioe_misc,io_isc);
		  send_command(io_isc,CHR(talk_constant+(device MOD 100)));
		  send_command(io_isc,'?');
		  send_command(io_isc,CHR(my_address(io_isc)+listen_constant));
		END
		ELSE BEGIN
		  { error }
		  io_escape(ioe_not_hpib,io_isc);
		END; { of IF }
	    END
	    ELSE BEGIN
	    END; { of IF }
	END; { of WITH DO BEGIN }
      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	  { set up user timeout - in case system drivers changed it }
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN
		  { if non controller wait until listener }
		  IF user_time = 0
		    THEN BEGIN
		      REPEAT
			{ wait forever }
		      UNTIL bit_set(iostatus(io_isc,6),10);
		    END
		    ELSE BEGIN
		      { wait for timeout value }
		      IF timerexists THEN BEGIN             {tttt JS 8/3/83}
			hpibrec.firsttime:=true;             {tttt JS 8/3/83}
			hpibrec.counter:=user_time;          {tttt JS 8/3/83}
			REPEAT                               {tttt JS 8/3/83}
			UNTIL timed_out(hpibrec) OR          {tttt JS 8/3/83}
			  bit_set(iostatus(io_isc,6),10);    {tttt JS 8/3/83}
		      END                                    {tttt JS 8/3/83}
		      ELSE BEGIN                             {tttt JS 8/3/83}
			timer:=user_time*3;
			REPEAT
			  timer:=timer-1;
			UNTIL ( timer = 0 ) OR
			      ( bit_set(iostatus(io_isc,6),10) ) ;
		      END;                                   {tttt JS 8/3/83}
		      IF NOT bit_set(iostatus(io_isc,6),10)
			THEN io_escape(ioe_timeout,io_isc);
		    END; { of IF user_time=0 }
		END; { of IF }
	    END; { of IF card_type = hpib_card }
	END; { of WITH DO BEGIN }
      END; { of IF }

    addr_to_talk:=io_isc; { return select code }

  END; { of addr_to_talk }

  $PAGE$

  FUNCTION  addr_to_listen
			( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
      timer  : INTEGER;
      hpibrec: timeoutrec;                                   {tttt JS 8/3/83}

  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=device DIV 100;

	WITH isc_table[io_isc] DO BEGIN

	  IF io_tmp_ptr <> NIL
	    THEN BEGIN

	      { set up user timeout - in case system drivers changed it }
	      io_tmp_ptr^.timeout:=user_time;

	      IF io_tmp_ptr^.addressed <> -1
		THEN BEGIN
		  IF ( card_type <> hpib_card ) AND
		     ( device MOD 100 > 31 )
		    THEN io_escape(ioe_misc,io_isc);
		  send_command(io_isc,CHR(my_address(io_isc)+talk_constant));
		  send_command(io_isc,'?');
		  send_command(io_isc,CHR(listen_constant+(device MOD 100)));
		END
		ELSE BEGIN
		  { error }
		  io_escape(ioe_not_hpib,io_isc);
		END; { of IF }
	    END
	    ELSE BEGIN
	    END; { of IF }
	END; { of WITH DO BEGIN }
      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	  { set up user timeout - in case system drivers changed it }
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN
		  { if non controller wait until talker }
		  IF user_time = 0
		    THEN BEGIN
		      REPEAT
			{ wait forever }
		      UNTIL bit_set(iostatus(io_isc,6),9);
		    END
		    ELSE BEGIN
		      { wait for timeout value }
		      IF timerexists THEN BEGIN             {tttt JS 8/3/83}
			hpibrec.firsttime:=true;             {tttt JS 8/3/83}
			hpibrec.counter:=user_time;          {tttt JS 8/3/83}
			REPEAT                               {tttt JS 8/3/83}
			UNTIL timed_out(hpibrec) OR          {tttt JS 8/3/83}
			  bit_set(iostatus(io_isc,6), 9);    {tttt JS 8/3/83}
		      END                                    {tttt JS 8/3/83}
		      ELSE BEGIN                             {tttt JS 8/3/83}
			timer:=user_time*3;
			REPEAT
			  timer:=timer-1;
			UNTIL ( timer = 0 ) OR
			      ( bit_set(iostatus(io_isc,6),9) ) ;
		      END;                                   {tttt JS 8/3/83}
		      IF NOT bit_set(iostatus(io_isc,6),9)
			THEN io_escape(ioe_timeout,io_isc);
		    END; { of IF user_time=0 }
		END; { of IF }
	    END; { of IF card_type = hpib_card }
	END; { of WITH DO BEGIN }
      END; { of IF }

    addr_to_listen:=io_isc;

  END; { of addr_to_listen }

  $PAGE$


  { set to talk exists because of HPIB_2/HPIB_3 -
    those routines are intended to be the controller
    ( active ) and should not wait for the card to be
    addressed as talker.  addr_to_talk is used by
    data transfer routines.  set_to_talk is used by
    bus control routines.                               }




  {************************ this function is never used ******************}
  {FUNCTION  set_to_talk ( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=addr_to_talk(device);
      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	   set up user timeout - in case system drivers changed it
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN

		  io_escape(ioe_not_act,io_isc);

		END;  of IF
	    END;  of IF card_type = hpib_card
	END;  of WITH DO BEGIN
      END;  of IF

    set_to_talk:=io_isc;  return select code

  END;  of set_to_talk }

  $PAGE$


  { set to listen exists because of HPIB_2/HPIB_3 -
    those routines are intended to be the controller
    ( active ) and should not wait for the card to be
    addressed as listener.  addr_to_listen is used by
    data transfer routines.  set_to_listen is used by
    bus control routines.                               }





  {******************* this function is never used **********************}
  {FUNCTION  set_to_listen
			( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
      timer  : INTEGER;
  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=addr_to_listen(device);

      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	   set up user timeout - in case system drivers changed it
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN

		  io_escape(ioe_not_act,io_isc);

		END;  of IF
	    END;  of IF card_type = hpib_card
	END;  of WITH DO BEGIN
      END;  of IF

    set_to_listen:=io_isc;

  END;  of set_to_listen }






{||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}


procedure hpib_inq_timeout ( anyvar iocb_ptr : anyptr; var value : integer );

begin
  with hpib_iocb_ptr(iocb_ptr)^ do
    begin
      value := isc_table[select_code].user_time;
    end;
end;

procedure hpib_set_timeout ( anyvar iocb_ptr : anyptr; value : integer );

begin
  with hpib_iocb_ptr(iocb_ptr)^ do
    set_timeout (select_code,value/1000);
end;

procedure hpib_init  ( anyvar iocb_ptr : anyptr );

var
  cnt : gle_shortint;

begin
  with hpib_iocb_ptr(iocb_ptr)^ do
    begin
      error := 1;
      try
	address := gle_read_integer ( name_size, device_addr, cnt );
	select_code := address div 100;
	if (select_code >= minrealisc) and
	   (select_code <= maxrealisc) then
	   begin
	     ioreset (select_code);
	     error := 0;
	   end;
      recover
	{ error is set, ignore range and io escapes }
	if (escapecode <> -8) and (escapecode <> -26) then escape(escapecode);
    end;
end;

procedure hpib_write ( anyvar iocb_ptr, data_ptr : anyptr );

var
  i : integer;
  io_isc : type_isc;

begin
  with hpib_iocb_ptr(iocb_ptr)^,ascii_buffer_ptr(data_ptr)^ do
    begin
      io_isc := addr_to_listen(address);
      with isc_table[io_isc].io_drv_ptr^, isc_table[io_isc] do
	begin
	  for i := 1 to current do
	    call (iod_wtb, io_tmp_ptr, data[i] );
	  writechar(io_isc,io_carriage_rtn);
	  writechar(io_isc,io_line_feed);
	end;
      current := 0;
    end;
end;

procedure hpib_read  ( anyvar iocb_ptr, data_ptr : anyptr );

var
  i : integer;
  io_isc : type_isc;

begin
  with hpib_iocb_ptr(iocb_ptr)^,ascii_buffer_ptr(data_ptr)^ do
    begin
      io_isc := addr_to_talk ( address );
      with isc_table[io_isc].io_drv_ptr^, isc_table[io_isc] do
	begin
	  i := 0;
	  repeat
	    i := i + 1;
	    call (iod_rdb, io_tmp_ptr, data[i]);
	  until ( ( i >= maximum ) or ( data[i] = io_line_feed ) );
	  if data[i] = io_line_feed then i := i - 1;
	  if i <> 0 then if data[i] = io_carriage_rtn then i := i - 1;
	  current := i;
	end;
    end;
end;

procedure hpib_term  ( anyvar iocb_ptr : anyptr );

begin
end;

end. { of module gle_hpib_io }

$LIST ON$
@


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


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 600
$TABLES$
$LIST OFF$
{                                                                           }
{ Graphics Low End                                                          }
{                                                                           }
{ Module    = GLE_HPIB                                                      }
{ Programer = BJS                                                           }
{ Date      = 10-10-82                                                      }
{                                                                           }
{ Purpose: To provide IO routines for ascii device handlers.                }

{ Rev history                                                               }
{  Created  - 10-10-82                                                      }
{  Modified - 12-12-83 BDS -- Brought needed general_1 and hpib_1           }
{                             routines in-line.                             }

{     (c) Copyright Hewlett-Packard Company, 1985.
      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                              }

$SEARCH 'GLE_TYPES',
	'GLE_UTLS'$
$modcal$
$ALLOW_PACKED ON$   { JWS 4/10/85 }

$include 'OPTIONS'$  { ******************* COMPILER OPTIONS *************** }
$LINENUM 10000$

module gle_hpib_io;

import gle_types,
       general_0,
       iocomasm;

export
type
  hpib_iocb_ptr = ^ hpib_iocb;
  hpib_iocb = record
		device_addr : anyptr;
		name_size   : gle_shortint;
		address     : integer;
		select_code : integer;
		error       : integer;
	      end;
  timeoutrec = record                          {tttt JS 8/3/83}
		counter: integer;              {tttt JS 8/3/83}
		firsttime: boolean;            {tttt JS 8/3/83}
	       end;                            {tttt JS 8/3/83}

procedure hpib_init  ( anyvar iocb_ptr : anyptr );
procedure hpib_inq_timeout ( anyvar iocb_ptr : anyptr; var value : integer );
procedure hpib_set_timeout ( anyvar iocb_ptr : anyptr; value : integer );
procedure hpib_write ( anyvar iocb_ptr, data_ptr : anyptr );
procedure hpib_read  ( anyvar iocb_ptr, data_ptr : anyptr );
procedure hpib_term  ( anyvar iocb_ptr : anyptr );

implement

import
   iodeclarations,
   {general_1,}
   {hpib_1,}
   gle_utls;

{ The following types must match types declared in GLE_HPGL, and GLE_HPGLI }
type
  ascii_buffer_ptr = ^ascii_buffer;

  ascii_buffer = packed record
		   maximum : integer;
		   current : integer;
		   data    : packed array [1..32767] of char;
		 end;

{||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}

			 {*** general_1 ***}

{The following procedures have been brought in-line to avoid importing
 general_1 and hpib_1. NOTE: These routines must be duplicates of those
 found in general_1 and hpib_1 and therefore must reflect any modifications
 to those modules.                                                }



  FUNCTION timerexists: boolean;  external;         { tttt JS 8/3/83 }

  FUNCTION timed_out(var rec: timeoutrec): boolean; external; {tttt JS 8/3/83}


  PROCEDURE ioreset     ( select_code : type_isc);
  BEGIN
    WITH isc_table[select_code] DO
    CALL(io_drv_ptr^.iod_init,
	 io_tmp_ptr);
  END; { of ioreset }


  PROCEDURE writechar   ( select_code : type_isc ;
			  value       : CHAR );
  BEGIN
    WITH isc_table[select_code] DO
    CALL(io_drv_ptr^.iod_wtb,
	 io_tmp_ptr,
	 value);
  END; { of writechar }

  PROCEDURE set_timeout ( select_code : type_isc ;
			  time        : REAL            { in seconds } );
  BEGIN
    IF time>8191                { 4 byte timeout  - 1 byte left for shifts }
      THEN BEGIN
	{ error }
	io_escape(ioe_bad_tmo,select_code);
      END; { of IF }
    IF (time>0) AND (time<0.001)
      THEN BEGIN
	{ error }
	io_escape(ioe_bad_tmo,select_code);
      END; { of IF }

    WITH isc_table[select_code] DO BEGIN

      { the table entry used by drivers is in milliseconds }
      user_time:=ROUND(time*1000);

      IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout := user_time;

    END; { of WITH DO BEGIN }

  END; { of set_timeout }

			 {*** hpib_1 ***}

  PROCEDURE send_command( select_code : type_isc ;
			  command     : CHAR );
  BEGIN
    WITH isc_table[select_code] DO
      CALL ( io_drv_ptr^.iod_send,
	     io_tmp_ptr,
	     command);
  END; { of send_command }



  FUNCTION  my_address  ( select_code : type_isc)
	    : type_hpib_addr ;
  BEGIN
    IF isc_table[select_code].io_tmp_ptr <> NIL
      THEN BEGIN
	WITH isc_table[select_code].io_tmp_ptr^ DO
	  IF addressed <> -1
	    THEN BEGIN
	      my_address:=addressed;
	    END
	    ELSE BEGIN
	      { error }
	      io_escape(ioe_not_hpib,select_code);
	    END; { of IF addressed }
      END
      ELSE BEGIN
	{ error }
	io_escape(ioe_not_hpib,select_code);
      END; { of IF io_tmp_ptr }
  END; { of my_address }



  FUNCTION  active_controller
			( select_code : type_isc)
			: BOOLEAN;
  BEGIN
    IF isc_table[select_code].card_type=hpib_card
      THEN BEGIN
	active_controller:=bit_set(iostatus(select_code,3),6);
      END
      ELSE BEGIN
	active_controller := TRUE;
      END; { of IF }
  END; { of active_controller }



  {************************* this function is not used  ********************}
  {FUNCTION  system_controller
			( select_code : type_isc)
			: BOOLEAN;
  BEGIN
    IF isc_table[select_code].card_type=hpib_card
      THEN BEGIN
	system_controller:=bit_set(iostatus(select_code,3),7);
      END
      ELSE BEGIN
	system_controller := TRUE;
      END;  of IF
  END;  of system_controller }



  {************************** this functio is not used *******************}
  {FUNCTION  end_set     ( select_code : type_isc )
			: BOOLEAN ;
  VAR mybool : BOOLEAN;
  BEGIN
    WITH isc_table[select_code] DO
      CALL ( io_drv_ptr^.iod_end,
	     io_tmp_ptr,
	     mybool);
    end_set := mybool;
  END;  of send_command }


  $PAGE$

  FUNCTION  addr_to_talk( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
      timer  : INTEGER;
      hpibrec: timeoutrec;                                    {tttt JS 8/3/83}

  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=device DIV 100;

	WITH isc_table[io_isc] DO BEGIN

	  IF io_tmp_ptr <> NIL
	    THEN BEGIN

	      { set up user timeout - in case system drivers changed it }
	      io_tmp_ptr^.timeout:=user_time;

	      IF io_tmp_ptr^.addressed <> -1
		THEN BEGIN
		  IF ( card_type <> hpib_card ) AND
		     ( device MOD 100 > 31 )
		    THEN io_escape(ioe_misc,io_isc);
		  send_command(io_isc,CHR(talk_constant+(device MOD 100)));
		  send_command(io_isc,'?');
		  send_command(io_isc,CHR(my_address(io_isc)+listen_constant));
		END
		ELSE BEGIN
		  { error }
		  io_escape(ioe_not_hpib,io_isc);
		END; { of IF }
	    END
	    ELSE BEGIN
	    END; { of IF }
	END; { of WITH DO BEGIN }
      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	  { set up user timeout - in case system drivers changed it }
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN
		  { if non controller wait until listener }
		  IF user_time = 0
		    THEN BEGIN
		      REPEAT
			{ wait forever }
		      UNTIL bit_set(iostatus(io_isc,6),10);
		    END
		    ELSE BEGIN
		      { wait for timeout value }
		      IF timerexists THEN BEGIN             {tttt JS 8/3/83}
			hpibrec.firsttime:=true;             {tttt JS 8/3/83}
			hpibrec.counter:=user_time;          {tttt JS 8/3/83}
			REPEAT                               {tttt JS 8/3/83}
			UNTIL timed_out(hpibrec) OR          {tttt JS 8/3/83}
			  bit_set(iostatus(io_isc,6),10);    {tttt JS 8/3/83}
		      END                                    {tttt JS 8/3/83}
		      ELSE BEGIN                             {tttt JS 8/3/83}
			timer:=user_time*3;
			REPEAT
			  timer:=timer-1;
			UNTIL ( timer = 0 ) OR
			      ( bit_set(iostatus(io_isc,6),10) ) ;
		      END;                                   {tttt JS 8/3/83}
		      IF NOT bit_set(iostatus(io_isc,6),10)
			THEN io_escape(ioe_timeout,io_isc);
		    END; { of IF user_time=0 }
		END; { of IF }
	    END; { of IF card_type = hpib_card }
	END; { of WITH DO BEGIN }
      END; { of IF }

    addr_to_talk:=io_isc; { return select code }

  END; { of addr_to_talk }

  $PAGE$

  FUNCTION  addr_to_listen
			( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
      timer  : INTEGER;
      hpibrec: timeoutrec;                                   {tttt JS 8/3/83}

  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=device DIV 100;

	WITH isc_table[io_isc] DO BEGIN

	  IF io_tmp_ptr <> NIL
	    THEN BEGIN

	      { set up user timeout - in case system drivers changed it }
	      io_tmp_ptr^.timeout:=user_time;

	      IF io_tmp_ptr^.addressed <> -1
		THEN BEGIN
		  IF ( card_type <> hpib_card ) AND
		     ( device MOD 100 > 31 )
		    THEN io_escape(ioe_misc,io_isc);
		  send_command(io_isc,CHR(my_address(io_isc)+talk_constant));
		  send_command(io_isc,'?');
		  send_command(io_isc,CHR(listen_constant+(device MOD 100)));
		END
		ELSE BEGIN
		  { error }
		  io_escape(ioe_not_hpib,io_isc);
		END; { of IF }
	    END
	    ELSE BEGIN
	    END; { of IF }
	END; { of WITH DO BEGIN }
      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	  { set up user timeout - in case system drivers changed it }
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN
		  { if non controller wait until talker }
		  IF user_time = 0
		    THEN BEGIN
		      REPEAT
			{ wait forever }
		      UNTIL bit_set(iostatus(io_isc,6),9);
		    END
		    ELSE BEGIN
		      { wait for timeout value }
		      IF timerexists THEN BEGIN             {tttt JS 8/3/83}
			hpibrec.firsttime:=true;             {tttt JS 8/3/83}
			hpibrec.counter:=user_time;          {tttt JS 8/3/83}
			REPEAT                               {tttt JS 8/3/83}
			UNTIL timed_out(hpibrec) OR          {tttt JS 8/3/83}
			  bit_set(iostatus(io_isc,6), 9);    {tttt JS 8/3/83}
		      END                                    {tttt JS 8/3/83}
		      ELSE BEGIN                             {tttt JS 8/3/83}
			timer:=user_time*3;
			REPEAT
			  timer:=timer-1;
			UNTIL ( timer = 0 ) OR
			      ( bit_set(iostatus(io_isc,6),9) ) ;
		      END;                                   {tttt JS 8/3/83}
		      IF NOT bit_set(iostatus(io_isc,6),9)
			THEN io_escape(ioe_timeout,io_isc);
		    END; { of IF user_time=0 }
		END; { of IF }
	    END; { of IF card_type = hpib_card }
	END; { of WITH DO BEGIN }
      END; { of IF }

    addr_to_listen:=io_isc;

  END; { of addr_to_listen }

  $PAGE$


  { set to talk exists because of HPIB_2/HPIB_3 -
    those routines are intended to be the controller
    ( active ) and should not wait for the card to be
    addressed as talker.  addr_to_talk is used by
    data transfer routines.  set_to_talk is used by
    bus control routines.                               }




  {************************ this function is never used ******************}
  {FUNCTION  set_to_talk ( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=addr_to_talk(device);
      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	   set up user timeout - in case system drivers changed it
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN

		  io_escape(ioe_not_act,io_isc);

		END;  of IF
	    END;  of IF card_type = hpib_card
	END;  of WITH DO BEGIN
      END;  of IF

    set_to_talk:=io_isc;  return select code

  END;  of set_to_talk }

  $PAGE$


  { set to listen exists because of HPIB_2/HPIB_3 -
    those routines are intended to be the controller
    ( active ) and should not wait for the card to be
    addressed as listener.  addr_to_listen is used by
    data transfer routines.  set_to_listen is used by
    bus control routines.                               }





  {******************* this function is never used **********************}
  {FUNCTION  set_to_listen
			( device      : type_device)
			: type_isc;
  VAR io_isc : type_isc;
      timer  : INTEGER;
  BEGIN

    IF device>iomaxisc
      THEN BEGIN
	io_isc:=addr_to_listen(device);

      END
      ELSE BEGIN
	io_isc:=device;

	WITH isc_table[io_isc] DO BEGIN

	   set up user timeout - in case system drivers changed it
	  IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time;

	  IF card_type=hpib_card THEN
	    BEGIN
	      IF NOT active_controller(io_isc)
		THEN BEGIN

		  io_escape(ioe_not_act,io_isc);

		END;  of IF
	    END;  of IF card_type = hpib_card
	END;  of WITH DO BEGIN
      END;  of IF

    set_to_listen:=io_isc;

  END;  of set_to_listen }






{||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}


procedure hpib_inq_timeout ( anyvar iocb_ptr : anyptr; var value : integer );

begin
  with hpib_iocb_ptr(iocb_ptr)^ do
    begin
      value := isc_table[select_code].user_time;
    end;
end;

procedure hpib_set_timeout ( anyvar iocb_ptr : anyptr; value : integer );

begin
  with hpib_iocb_ptr(iocb_ptr)^ do
    set_timeout (select_code,value/1000);
end;

procedure hpib_init  ( anyvar iocb_ptr : anyptr );

var
  cnt : gle_shortint;

begin
  with hpib_iocb_ptr(iocb_ptr)^ do
    begin
      error := 1;
      try
	address := gle_read_integer ( name_size, device_addr, cnt );
	select_code := address div 100;
	if (select_code >= minrealisc) and
	   (select_code <= maxrealisc) then
	   begin
	     ioreset (select_code);
	     error := 0;
	   end;
      recover
	{ error is set, ignore range and io escapes }
	if (escapecode <> -8) and (escapecode <> -26) then escape(escapecode);
    end;
end;

procedure hpib_write ( anyvar iocb_ptr, data_ptr : anyptr );

var
  i : integer;
  io_isc : type_isc;

begin
  with hpib_iocb_ptr(iocb_ptr)^,ascii_buffer_ptr(data_ptr)^ do
    begin
      io_isc := addr_to_listen(address);
      with isc_table[io_isc].io_drv_ptr^, isc_table[io_isc] do
	begin
	  for i := 1 to current do
	    call (iod_wtb, io_tmp_ptr, data[i] );
	  writechar(io_isc,io_carriage_rtn);
	  writechar(io_isc,io_line_feed);
	end;
      current := 0;
    end;
end;

procedure hpib_read  ( anyvar iocb_ptr, data_ptr : anyptr );

var
  i : integer;
  io_isc : type_isc;

begin
  with hpib_iocb_ptr(iocb_ptr)^,ascii_buffer_ptr(data_ptr)^ do
    begin
      io_isc := addr_to_talk ( address );
      with isc_table[io_isc].io_drv_ptr^, isc_table[io_isc] do
	begin
	  i := 0;
	  repeat
	    i := i + 1;
	    call (iod_rdb, io_tmp_ptr, data[i]);
	  until ( ( i >= maximum ) or ( data[i] = io_line_feed ) );
	  if data[i] = io_line_feed then i := i - 1;
	  if i <> 0 then if data[i] = io_carriage_rtn then i := i - 1;
	  current := i;
	end;
    end;
end;

procedure hpib_term  ( anyvar iocb_ptr : anyptr );

begin
end;

end. { of module gle_hpib_io }

$LIST ON$
@


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


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


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.2
log
@For CATSEYE support
@
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
@@
