$COPYRIGHT 'COPYRIGHT (C) 1982 BY HEWLETT-PACKARD COMPANY'$
$SYSPROG ON$
$PARTIAL_EVAL ON$
$STACKCHECK ON$
$RANGE OFF$
$DEBUG OFF$
$OVFLCHECK OFF$
(************************************************************************)
(*                                                                      *)
(*      not released    VERSION         2.0                             *)
(*                                                                      *)
(************************************************************************)
(*                                                                      *)
(*                                                                      *)
(*      IOLIB           extensions                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)
(*                                                                      *)
(*                                                                      *)
(*      library      -  IOLIB                                           *)
(*      name         -  EXTLIB                                          *)
(*      module(s)    -  hpib_5                                          *)
(*                                                                      *)
(*      date         -  July 22 , 1982                                  *)
(*      update       -  July 30 , 1982                                  *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

(************************************************************************)
(*                                                                      *)
(*                                                                      *)
(*      GENERAL EXTENSIONS                                              *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

PROGRAM hpib_5_init;


MODULE hpib_5 ;     

        { date    07/22/82
          update  07/30/82
          
          purpose This module contains the LEVEL 5 HPIB GROUP procedures.   
        }


IMPORT  iodeclarations , iocomasm , general_0 , hpib_1 , hpib_3  ;  

EXPORT 
  
  TYPE  hpib_user_proc = PROCEDURE ( parameter : INTEGER );
  TYPE  hpib_isr_block = RECORD
                           state : PACKED ARRAY[0..3] OF BOOLEAN;
                           mask  : INTEGER;
                           procs : ARRAY[0..3] OF hpib_user_proc;
                           parms : ARRAY[0..3] OF INTEGER;
                         END;
  
  VAR   hpib_isr_table : ARRAY[iominisc..iomaxisc] OF ^hpib_isr_block;
  
  PROCEDURE on_srq     ( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  PROCEDURE off_srq    ( isc       : type_isc );
  
  PROCEDURE on_talker  ( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  PROCEDURE off_talker ( isc       : type_isc );
  
  PROCEDURE on_listener( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  PROCEDURE off_listener(isc       : type_isc );
  
  PROCEDURE on_active_ctl
                       ( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  PROCEDURE off_active_ctl
                       ( isc       : type_isc );
  
IMPLEMENT
  
  CONST srqcond        = 0;     srqmask = 128;
        tlkcond        = 1;     tlkmask =  32;
        lstcond        = 2;     lstmask =  16;
        ctlcond        = 3;     ctlmask =  64;
  
  TYPE  coerce = RECORD CASE BOOLEAN OF
                   TRUE:  ( int : INTEGER );
                   FALSE: ( ptr : ANYPTR )
                 END;
        
  
  PROCEDURE hpib_isr_allocate
                       ( isc       : type_isc );
  VAR counter : INTEGER;
  BEGIN
    NEW(hpib_isr_table[isc] );
    WITH hpib_isr_table[isc]^ DO BEGIN
      FOR counter:=srqcond TO ctlcond DO state[counter] := FALSE;
      mask := 0;      
    END; { of WITH DO BEGIN }
  END; { of hpib_isr_allocate }
  
  PROCEDURE hpib_isr_proc
                       ( temp      : ANYPTR  );
  VAR counter : INTEGER;
      happened: BOOLEAN;
      isc     : INTEGER;
      local   : coerce ;
  BEGIN
    local.ptr := temp;                  { coerce for select code }
    isc       := local.int;
    
    { prevent hpib_isr_proc in user_isr in temps }
    iocontrol( isc , 5 , 0 );
    WITH isc_table[isc].io_tmp_ptr^ DO BEGIN
      user_isr.dummy_sl := NIL;
      user_isr.dummy_pr := NIL;
    END; { of WITH isc_table DO BEGIN }
      
    WITH hpib_isr_table[isc]^ DO BEGIN
      FOR counter := srqcond TO ctlcond DO 
        IF state[ counter ] 
          THEN BEGIN
            happened := FALSE;
            CASE counter OF
              srqcond: happened:=requested(isc);
              tlkcond: happened:=talker(isc);
              lstcond: happened:=listener(isc);
              ctlcond: happened:=active_controller(isc);
            END; { of CASE }
            IF happened THEN CALL( procs[counter] , parms[counter] );
          END; { of FOR DO IF bit_set THEN }
      
    { set up hpib_isr_proc in user_isr in temps }
    WITH isc_table[isc].io_tmp_ptr^ DO BEGIN
      user_isr.real_proc := hpib_isr_proc;
    END; { of WITH DO BEGIN }
    
    { re - enable interrupts }
    iocontrol( isc , 5 , mask );
  
  END; { of WITH BEGIN }
END; { of hpib_isr_proc }
  
  PROCEDURE hpib_isr_setup
                       ( isc       : type_isc ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER ;
                         which_cond: INTEGER );
  VAR local : coerce;
  BEGIN
    IF ( isc_table[isc].card_id <> hp98624 ) AND
       ( isc_table[isc].card_id <> internal_hpib )
      THEN io_escape(ioe_not_hpib,isc);
    IF hpib_isr_table[isc] = NIL THEN hpib_isr_allocate(isc);
    WITH hpib_isr_table[isc]^ DO BEGIN
      { set up procedures & parameters in allocated isr proc block }
      procs[which_cond] := your_proc;
      parms[which_cond] := your_parm;
    
      { set up state condition and interrupt mask }
      CASE which_cond OF
        srqcond:  mask:=BINIOR(mask,srqmask);
        tlkcond:  mask:=BINIOR(mask,tlkmask);
        lstcond:  mask:=BINIOR(mask,lstmask);
        ctlcond:  mask:=BINIOR(mask,ctlmask);
      END; { of CASE }
      state[which_cond] := TRUE;
      
      { set up hpib_isr_proc in user_isr in temps }
      WITH isc_table[isc].io_tmp_ptr^ DO BEGIN
        user_isr.real_proc := hpib_isr_proc;
        local.int          := isc;              { type coercion }
        user_parm          := local.ptr;        { type coercion }
      END; { of WITH DO BEGIN }
      
      { enable card }
      iocontrol( isc , 5 , mask );
    END; { of WITH DO BEGIN }
  END; { of hpib_isr_setup }
  
  PROCEDURE hpib_isr_kill
                       ( isc       : type_isc ;
                         which_cond: INTEGER );
  BEGIN
    IF hpib_isr_table[isc] <> NIL THEN 
    WITH hpib_isr_table[isc]^ DO BEGIN
    
      { clear state condition and interrupt mask }
      CASE which_cond OF
        srqcond:  mask:=BINAND(mask,BINCMP(srqmask));
        tlkcond:  mask:=BINAND(mask,BINCMP(tlkmask));
        lstcond:  mask:=BINAND(mask,BINCMP(lstmask));
        ctlcond:  mask:=BINAND(mask,BINCMP(ctlmask));
      END; { of CASE }
      state[which_cond] := FALSE;
      
      { if necessary clear hpib_isr_proc in user_isr in temps }
      IF mask=0 THEN WITH isc_table[isc].io_tmp_ptr^ DO BEGIN
        user_isr.dummy_sl := NIL;
        user_isr.dummy_pr := NIL;
        user_parm         := NIL;
      END; { of WITH isc_table DO BEGIN }
      
      { disable or enable card as specified by the mask  }
      iocontrol( isc , 5 , mask );
    END; { of WITH DO BEGIN }
  END; { of hpib_isr_kill }
  
  
  PROCEDURE on_srq     ( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  BEGIN
    hpib_isr_setup(isc,your_proc,your_parm,srqcond );
  END;
  
  PROCEDURE off_srq    ( isc       : type_isc );
  BEGIN
    hpib_isr_kill(isc,srqcond );
  END;
  
  PROCEDURE on_talker  ( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  BEGIN
    hpib_isr_setup(isc,your_proc,your_parm,tlkcond);
  END;
  
  PROCEDURE off_talker ( isc       : type_isc );
  BEGIN
    hpib_isr_kill(isc,tlkcond );
  END;
  
  PROCEDURE on_listener( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  BEGIN
    hpib_isr_setup(isc,your_proc,your_parm,lstcond );
  END;
  
  PROCEDURE off_listener(isc       : type_isc );
  BEGIN
    hpib_isr_kill(isc,lstcond );
  END;
  
  PROCEDURE on_active_ctl
                       ( isc       : type_isc  ;
                         your_proc : hpib_user_proc ;
                         your_parm : INTEGER );
  BEGIN
    hpib_isr_setup(isc,your_proc,your_parm,ctlcond );
  END;
  
  PROCEDURE off_active_ctl
                       ( isc       : type_isc );
  BEGIN
    hpib_isr_kill(isc,ctlcond );
  END;
        
END; { of hpib_5 }


IMPORT iodeclarations , hpib_5;
VAR counter : INTEGER;
BEGIN
  FOR counter := iominisc TO iomaxisc DO 
    hpib_isr_table[counter] := NIL;
END.    { of hpib_5_init  }  

