IMD 1.17: 14/03/2012 8:38:12 LAN: B3466A 3.5" DS  €LAN    p#LANDECST__éK D“!9€CĂLANASMT___éKP“!R€ÉLANSRMT___éKiŹ“"A€Ž.SRM_DRVT__éKř¨“#7€§ĎSRMDAMT___éK \“%€[SRMAMT____éKü#“%9€"6LANT______éKÉ“&V€ČoIOMPXT____éKč“'"€\DCT_______éKé“)&€čaDC_DRVT___éKďt“0$€sňIOMPXDECSTéKc “F!€ ŢSRM_TYPESTéKo“GP€ýSRM_ERRST_éK„ “H€ _PACKETST__éKŹ€“P€iCOMDCLT___éK “S6€žMAKE_LANT_éK/“A€bREADMET___5“ ()€yREADMET___éK7“ €˛ ˙˙@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@{ LAN CARD DECLARATIONS } { changes/bug fix history rev 3.22c added DRIVER_BUFFER to LAN_INFO_REC moved CARD_STATE to preserve long word alignment } $SYSPROG$ { $SEARCH 'IOLIB:KERNEL.CODE'$ } MODULE LANDECS; IMPORT sysglobals, iodeclarations; EXPORT CONST HP98643 = 21; memory_size = hex('4000'); { total ram on the card } init_size = 24; { 24 bytes in the init_block } init_words = init_size div 2; { 12 words in the init_block } TYPE UNS3  = 0..7; HEX_DIGIT = 0..15; UNSWORD = 0..65535; LINK_ADDRESS_TYPE = PACKED ARRAY[1..6] OF CHAR; BPOINTER = ^CHAR; { lan card interface types } ID_REG_TYPE = PACKED RECORD BYTE0 : BYTE;  CASE INTEGER OF 1: (IDB : BYTE); 2: (RL : BOOLEAN; ID : 0..127); 3: (BIT7: BOOLEAN; PID : 0..3;  SID : 0..31); 4: (RESET : BYTE); END; SC_REG_TYPE = PACKED RECORD BYTE2 : BYTE; CASE INTEGER OF 1:(CONTROL: BYTE); 2:(STATUS : BYTE); 3:(IE : BOOLEAN; IR : BOOLEAN; INTLEVEL : 0..3; LOCK : BOOLEAN; ACK : BOOLEAN; JAB : BOOLEAN; REV : BOOLEAN); END; CSR0_TYPE = PACKED RECORD CASE INTEGER OF 1:(UW : UNSWORD); 2:(ERR : BOOLEAN; { read } BABL : BOOLEAN; { read, clear only } { clear by 1 } CERR : BOOLEAN; { read, clear only } MISS : BOOLEAN; { read, clear only } MERR : BOOLEAN; { read, clear only } RINT : BOOLEAN; { read, clear only } TINT : BOOLEAN; { read, clear only } IDON : BOOLEAN; { read, clear only } INTR : BOOLEAN; { read } INEA : BOOLEAN; { read, write }  RXON : BOOLEAN; { read } TXON : BOOLEAN; { read } TDMD : BOOLEAN; { read, set by 1 } STOP : BOOLEAN; { read, set by 1 } STRT : BOOLEAN; { read, set by 1 } INIT : BOOLEAN { read, set by 1 } ); END; MODE_TYPE = PACKED RECORD { INIT BLOCK MODE WORD } CASE INTEGER OF 1:(PROM : BOOLEAN;  RES : BYTE; INTL : BOOLEAN; DRTY : BOOLEAN; COLL : BOOLEAN; DTRC : BOOLEAN; LOOP : BOOLEAN; DTX : BOOLEAN; DRX : BOOLEAN); 2:(ALL : UNSWORD); END; LADRF_TYPE = PACKED RECORD CASE INTEGER OF 1:(BITS : PACKED ARRAY [0..63] OF BOOLEAN);  2:(INT1,INT2 :INTEGER); END; INIT_BLOCK_TYPE = PACKED RECORD case integer of 0:(all24 : packed array[1..init_size] of char); 1:(all12 : packed array[1..init_words] of unsword); 2:(MODE : MODE_TYPE; PADR : LINK_ADDRESS_TYPE; LADRF: LADRF_TYPE; RDRAL: UNSWORD;  RLEN : UNS3; zip0 : 0..31; RDRAH: BYTE; TDRAL: UNSWORD; TLEN : UNS3; zip1 : 0..31;  TDRAH: BYTE); END; rx_status_type = PACKED RECORD { also built into rx_ring_elt_type } OWN : BOOLEAN; ERR : BOOLEAN; FRAM : BOOLEAN;  OFLO : BOOLEAN; CRC : BOOLEAN; BUFF : BOOLEAN; STP : BOOLEAN; ENP : BOOLEAN; END; rx_ring_elt_type = PACKED RECORD CASE INTEGER OF 1:(RMD0_0:BYTE; RMD0_1:BYTE; RMD1_0:BYTE; RMD1_1:BYTE; RMD2_0:BYTE; RMD2_1:BYTE; RMD3_0:BYTE; RMD3_1:BYTE); 2:(LADR : UNSWORD; OWN : BOOLEAN;   ERR : BOOLEAN; FRAM : BOOLEAN; OFLO : BOOLEAN; CRC : BOOLEAN; BUFF : BOOLEAN; STP : BOOLEAN; ENP : BOOLEAN; HADR : BYTE; BCNT : SHORTINT; MCNT : SHORTINT); { MESSAGE SIZE } END; tx_status1_type = PACKED RECORD { built into tx_ring_elt_type } OWN : BOOLEAN; ERR : BOOLEAN; res0 : BOOLEAN; MORE : BOOLEAN;  ONE : BOOLEAN; DEF : BOOLEAN; STP : BOOLEAN; ENP : BOOLEAN; END; tx_status2_type = PACKED RECORD { built into tx_ring_elt_type }  BUFF : BOOLEAN; UFLO : BOOLEAN; res1 : BOOLEAN; LCOL : BOOLEAN; LCAR : BOOLEAN; RTRY : BOOLEAN;  zz : 0..3; { 2 bits of TDR } END; tx_ring_elt_type = PACKED RECORD CASE INTEGER OF 1:(TMD0_0:BYTE; TMD0_1:BYTE;  TMD1_0:BYTE; TMD1_1:BYTE; TMD2_0:BYTE; TMD2_1:BYTE; TMD3 :UNSWORD); 2:(LADR  : UNSWORD; OWN : BOOLEAN; ERR : BOOLEAN; res0 : BOOLEAN; MORE : BOOLEAN; ONE : BOOLEAN;  DEF : BOOLEAN; STP : BOOLEAN; ENP : BOOLEAN; HADR : BYTE; BCNT : SHORTINT;  BUFF : BOOLEAN; UFLO : BOOLEAN; res1 : BOOLEAN; LCOL : BOOLEAN; LCAR : BOOLEAN; RTRY : BOOLEAN; TDR : 0..1023); END; CONST max_ring_elts = 128; default_rx_buffer_size = 320; default_num_rx_buffers = 32; default_num_tx_buffers = 4; default_mode = 0; TYPE RX_BUFFERS = ARRAY [1..max_ring_elts] OF RX_RING_ELT_TYPE; TX_BUFFERS = ARRAY [1..max_ring_elts] OF TX_RING_ELT_TYPE; LBUFFER_TYPE = PACKED ARRAY[1..(MEMORY_SIZE-INIT_SIZE)] OF CHAR; RAM_AREA_TYPE = PACKED RECORD INIT_BLOCK : INIT_BLOCK_TYPE; BUFFERS : LBUFFER_TYPE; END; NOVBYTE = PACKED RECORD N0 : BYTE; N1 : HEX_DIGIT;  DATA1: HEX_DIGIT; N2 : BYTE; N3 : HEX_DIGIT; DATA2: HEX_DIGIT; END; NOVBANK_TYPE = PACKED RECORD FLAG : NOVBYTE; ZEROES1 : NOVBYTE; STATION : ARRAY[1..6] OF NOVBYTE; ZEROES2 : ARRAY[1..7] OF NOVBYTE; CHECK : NOVBYTE; END; NOVRAM_TYPE = PACKED RECORD CASE INTEGER OF 1:( NRAM : ARRAY[1..32] OF NOVBYTE); 2:( BANK1: NOVBANK_TYPE; BANK2: NOVBANK_TYPE); END; RDP_TYPE = PACKED RECORD CASE INTEGER OF  1:(UW : UNSWORD); 2:(CSR0 : CSR0_TYPE); END; LANCARD_TYPE = PACKED RECORD ID_REG : ID_REG_TYPE; SC_REG : SC_REG_TYPE; NOVRAM_STORE : SHORTINT; gap1 : PACKED ARRAY[0..16376] OF BYTE; RDP : RDP_TYPE; { LANCE DATA PORT } RAP : UNSWORD; { LANCE ADDRESS PORT } gap2 : PACKED ARRAY[0..16378] OF BYTE; RAM_AREA : RAM_AREA_TYPE; NOVRAM : NOVRAM_TYPE; END; CARD_BASE_PTR = ^LANCARD_TYPE; CARD_STATE_TYPE = (CS_PRE_INIT, CS_INIT_FAILED,  CS_ACK_ERROR, CS_CARD_RESET, CS_LANCE_READY, CS_HW_FAILED ); RX_RING_ELT_PTR = ^RX_RING_ELT_TYPE; RX_RING_PTR = ^RX_BUFFERS; TX_RING_ELT_PTR = ^TX_RING_ELT_TYPE; TX_RING_PTR = ^TX_BUFFERS; { LAN FRAME HEADERS } ENET_HDR_PTR = ^ETHERNET_HDR_TYPE; ETHERNET_HDR_TYPE = PACKED RECORD DESTINATION : LINK_ADDRESS_TYPE; SOURCE : LINK_ADDRESS_TYPE; ETYPE : UNSWORD; END; IEEE_HDR_PTR = ^IEEE802_HDR_TYPE; IEEE802_HDR_TYPE = PACKED RECORD  DESTINATION : LINK_ADDRESS_TYPE; SOURCE : LINK_ADDRESS_TYPE; LENGTH : UNSWORD; DSAP,SSAP,CNTRL : BYTE; END; IEEE_EXT_HDR_PTR = ^IEEE802_HP_EXT_TYPE; IEEE802_HP_EXT_TYPE = PACKED RECORD DESTINATION : LINK_ADDRESS_TYPE; SOURCE : LINK_ADDRESS_TYPE; LENGTH : UNSWORD;  DSAP,SSAP,CNTRL : BYTE; HF1,HF2,HF3 : BYTE; { FILLERS } DXSAP,SXSAP : UNSWORD; END; GPADDR = PACKED RECORD CASE INTEGER OF 0:(PAD : BYTE; H8 : BYTE; L16 : UNSWORD); 1:(INT : INTEGER); 2:(RXR : RX_RING_PTR); 3:(TXR : TX_RING_PTR); 4:(ENH : ENET_HDR_PTR); 5:(IEE1: IEEE_HDR_PTR); 6:(IEE2: IEEE_EXT_HDR_PTR); 7:(PTR : ANYPTR); END; CONST LAN_MAX_FRAME_LEN = 1514; LAN_MIN_FRAME_LEN = 60; CRC_SIZE = 4; { io_control/io_status operation codes } { available codes are 5,6,7 } L_GET_INTLEVEL = 8; { read only } L_CARD_STATE = 9; L_FORCE_INTERRUPT = 10; { write only } L_RECONFIG = 11; L_MODE = 12; L_NUM_RX_BUFS = 13; L_RX_BUF_SIZE = 14; L_NUM_TX_BUFS = 15; L_GET_TX_BUF_SIZE = 16; { read only } L_SET_MULTICAST_ALL=17; { write only } L_INIT_STATS = 18; { write only } L_GET_STATS_LSW = 18; { read only } L_GET_STATS_MSW = 19; { read only } L_REJECT_FRAME = 20; { write only } L_GET_FRAME_SIZE = 20; { read only } L_LINK_ADDR1 = 21; { ..26 } L_SET_MMASK = 27; { set multicast mask bit } L_CLR_MMASK  = 28; { clear milticast mask bit } { = 29; currently unused } L_SET_UISR = 30; L_CLEAR_UISR = 31; L_INPUT_BUSY = 32; L_OUTPUT_BUSY = 33; L_ABORT = 34; L_INPUT = 0; L_OUTPUT = 1; L_ALL_IO = 2; L_SET_DEFAULT_CONFIG = 35; L_SKIP_BYTES = 36; { = 37..39 currently unused } L_MMASK0 = 40; { base value of multicast mask bits } { covers 40..103 ie 6 4 values } { term_char values set for eot_proc examination } LB_PENDING = -1; { io in progress } LB_EOT = 0; { buffer sent/received from card } LB_SHORT = 1; { buffer was not big enough to  receive all of the in comming frame } LB_TX_ERROR = 2; { transmit failed on card } LB_ABORT = 3; { transmit abort called for, probably stop key } { this eot call can be ignored } { output operations can be attempted } LB_RESET = 4; { card reset, buffer may not have been sent } { output operations can be attempted } LB_HW_FAILED = 5; { buffer may not have been sent } { don't try to do I/O with the card } TYPE LAN_STATS_TYPE = (LHW_MERR, LHW_BABL, LHW_RESTARTS, {receiver stats} LRX_NO_ERRORS, LRX_FRAME_ERR, LRX_OFLO_ERR, LRX_CRC_ERR, LRX_BUFF_ERR, LRX_MISS_ERR, LRX_OTHER_ERR, {transmit stats} LTX_REQUESTS, LTX_NO_ERRORS, LTX_NO_HEART, LTX_ONE, LTX_MORE, LTX_DEF, LTX_UFLO_ERR, LTX_LCOL_ERR, LTX_LCAR_ERR, LTX_RETRY_ERR ); LAN_STATS_PTR = ^LAN_STATS_DATA; LAN_STATS_DATA= ARRAY[LAN_STATS_TYPE] OF INTEGER; LAN_BUFS_PTR = ^LAN_BUFS; LAN_BUFS = ARRAY[0..max_ring_elts-1] OF ANYPTR; LAN_INFO_PTR = ^LAN_INFO_REC; LAN_SC_PROC = PROCEDURE (SC:INTEGER); LAN_FUNNY_PROC = RECORD CASE BOOLEAN OF TRUE : ( REAL_PROC : LAN_SC_PROC );  FALSE: ( DUMMY_PR : ANYPTR; DUMMY_SL : ANYPTR); END; LAN_INFO_REC = RECORD io_temps : pio_tmp_ptr; outbuf_proc : lan_funny_proc; perm_isr : io_funny_proc; {-----DON'T MESS WITH ANYTHING BELOW HERE-----} {----------USE IOSTATUS AND IOCONTROL---------} lan_stats : lan_stats_ptr;  local_link_address : link_address_type; card_state : card_state_type; init_block : init_block_type; {for use on next init} {-----------card config params-------------}  rx_buffer_size : integer; { size of one rx_buffer } num_rx_buffers : integer; { number of rx buffers } num_tx_buffers : integer; { max tx buffers } {-----------reciever params----------------} rxr_1,rxr_n,rx_ring : rx_ring_elt_ptr; {-----------transmitter params-------------} tx_buffer_size : integer; { entire tx buffer space } txr_1,txr_n,tx_ring_f,tx_ring_l : tx_ring_elt_ptr; txd_1,txd_n : gpaddr; { first and end of tx data space } tx_count : integer;{ number of outstanding tx requests } tx_used : gpaddr; { start of oldest data space } tx_next : gpaddr; { next usable data space } tx_user_buffs : lan_bufs_ptr;{outstanding user buffers} tx_ub_in,tx_ub_out : integer; {-----------misc info-----------------------} driver_buffer : anyptr; last_rx_size : shortint; { size of current frame } skip_bytes : shortint; copy_bytes : shortint; card_intlevel : shortint; do_card_start : boolean; alloc_ok : boolean; END; IMPLEMENT END.   TTL LANASM - LAN DRIVER ASSEMBLY SUPPORT PAGE ******************************************************************************* * LAN LANASM ******************************************************************************* * * Date: 18/06/86 * Author: Robert Quist * * fixes/changes history * 15 jan 88 : changed START_TIMER & TIME_EXPIRED to use the PWS timer code * uses a timer record instead of just an integer. * must check timer presence and fake it. ******************************************************************************* sprint nosyms llen 132 page ******************************************************************************** * The following lines are used to tell the LINKER/LOADER what this module * looks like in PASCAL terms. ******************************************************************************** MNAME LANASM SRC MODULE LANASM; SRC IMPORT SYSGLOBALS,LANDECS; SRC EXPORT SRC SRC TYPE SRC TIMER_REC = RECORD SRC TIME : INTEGER; SRC FLAG : SHORTINT; SRC END; SRC WWINDOW = PACKED ARRAY[1..MAXINT] OF SHORTINT; SRC FUNCTION B_OR(B1,B2:BYTE):BYTE; SRC FUNCTION W_OR(B1,B2:SHORTINT):SHORTINT; SRC FUNCTION HW_READ_LOCAL_ADDRESS SRC (VAR CARD:LANCARD_TYPE; SRC VAR LOCAL_LINK_ADDRESS: LINK_ADDRESS_TYPE) SRC :BOOLEAN; SRC PROCEDURE START_TIMER(VAR TIME : TIMER_REC); SRC FUNCTION TIME_EXPIRED(VAR TIME : TIMER_REC):BOOLEAN; SRC PROCEDURE CHECKSUM1(VAR CS:SHORTINT; ANYVAR BUF:WWINDOW; SIZE:INTEGER); SRC END; { of extdc } PAGE ******************************************************************************* * * SYMBOLS FOR EXPORT AS PROCEDURE NAMES * ******************************************************************************* DEF LANASM_B_OR DEF LANASM_W_OR DEF LANASM_HW_READ_LOCAL_ADDRESS DEF LANASM_LANASM DEF LANASM_START_TIMER DEF LANASM_TIME_EXPIRED DEF LANASM_CHECKSUM1 ******************************************************************************* * SYMBOLS FOR INTERNAL USE ******************************************************************************* timer_present equ 1 sysflag2 equ $FFFFFEDA REFA CHECK_TIMER in system POWERUP code LMODE CHECK_TIMER PAGE LANASM_W_OR EQU * RETURN THE BITWISE OR OF THE TWO WORD ARGUMENTS MOVEA.L (SP)+,A0 POP RETURN ADDRESS MOVE.W (SP)+,D0 OR.W (SP)+,D0 MOVE.W D0,(SP) JMP (A0) LANASM_B_OR EQU * RETURN THE BITWISE OR OF THE TWO BYTE ARGUMENTS MOVEA.L (SP)+,A0 POP RETURN ADDRESS MOVE.B (SP)+,D0 OR.B (SP)+,D0 MOVE.B D0,(SP) JMP (A0) PAGE hwr_nextb equ * move.w (a3)+,d0 get first nibble andi.w #$F,d0 clear high bits for add later asl.b #4,d0 first nibble * 16 move.w (a3)+,d1 get second nibble andi.b #$F,d1 or.b d1,d0 plus second nibble rts LANASM_HW_READ_LOCAL_ADDRESS EQU * MOVEA.L (SP)+,A0 RETURN ADDRESS MOVEA.L (SP)+,A1 LINK ADDRESS MOVEA.L (SP)+,A2 CARD BASE ADDRESS * A3 NOVRAM BANK ADDRESS * D7 checksum movea.l a2,a3 adda.l #$C000,a3 check the bank flag bsr hwr_nextb tst.b d0 beq.s hw_r1 adda.l #$040,a3 use bank 2 hw_r1 bsr hwr_nextb get leading zeroes to moveq #0,d7 initialize the checksum move.b d0,d7 moveq #5,d2 set loop count for 6 passes hw_r2 bsr hwr_nextb add.w d0,d7 add it to checksum move.b d0,(a1)+ move it to returned link address dbra d2,hw_r2 moveq #6,d2 set loop count for 7 more hw_r3 bsr hwr_nextb add.w d0,d7 add it to checksum dbra d2,hw_r3 bsr hwr_nextb get the stored checksum andi.w #$FF,d7 mod 256 of computed checksum cmp.b d0,d7 seq (sp) set return code jmp (a0) PAGE ************************************************************************* * START_TIMER   timing setup * * ASSUMES: * - sp+4 points to location of a timer record * the TIME field is a delay in milliseconds * RETURNS: * - The TIME field contains a value to match against the timer * (no timer present then this field is a scaled count) ************************************************************************* LANASM_START_TIMER equ * movea.l 4(sp),a0 get addr of timer rec btst #timer_present,sysflag2 bne.s soft_start st 4(a0) set the first time flag jmp CHECK_TIMER soft_start equ * * scale the time out value for use as a counter move.l (a0),d0 move.l d0,d1 scale the timeout value lsl.l #4,d1 n*16 lsl.l #5,d0 n*32 add.l d1,d0 lsr.l #1,d0 To = ((n*16)+(n*32))/2 move.l d0,(a0) move.l (sp)+,(sp) move the return address rts ************************************************************************* * FUNCTION TIME_EXPIRED(VAR TIME: INTEGER):BOOLEAN; * ASSUMES: * - sp+4 points to a timer record (set up by start_timer) ************************************************************************* LANASM_TIME_EXPIRED EQU * clr.b 8(sp) clear the function value btst #timer_present,sysflag2 bne.s soft_check move.l 4(sp),-(sp)  copy the timer rec address jsr CHECK_TIMER bpl.s timex1 timex0 move.b #1,8(sp) timex1 move.l (sp)+,(sp) move the return address rts soft_check equ * movea.l 4(sp),a0 subq.l #1,(a0) bpl timex1 bra timex0 ************************************************************************* * PROCEDURE CHECKSUM1(VAR CS:SHORTINT; ANYVAR BUF:WWINDOW; SIZE:INTEGER); * compute 1s compliment 16 bit checksum ************************************************************************* LANASM_CHECKSUM1 equ * movea.l (sp)+,a2 return move.l (sp)+,d0 size movea.l (sp)+,a1 buf address movea.l (sp)+,a0 checksum address moveq #0,d1 checksum value bra.s cs_1 cs_0 move.w (a1)+,d2 addx.w d2,d1 cs_1 dbra d0,cs_0 moveq #0,d2 addx.w d2,d1 not.w d1 move.w d1,(a0) jmp (a2) ************************************************************************* LANASM_LANASM EQU * MODULE INIT BODY RTS END $MODCAL$ $DEBUG OFF$ $RANGE OFF$ $ALLOW_PACKED ON$ { this version of LANSRM is designed to use the IP-UDP protocols } { lines with comment patch #1 are needed to clear out_bufptr. The LAN driver should have cleared it before calling any wrapper procedure. } MODULE LANSRM; { $SEARCH 'IOLIB:KERNEL'$ } { $SEARCH 'IOLIB:LANASM','IOLIB:LANDECS'$ } $SEARCH 'LANDECS'$ IMPORT SYSGLOBALS,LANDECS, IODECLARATIONS,GENERAL_0, ASM; EXPORT { $INCLUDE 'IOLIB:IOMPXDECS.TEXT'$ } $INCLUDE 'IOMPXDECS.TEXT'$ TYPE lsrm_unit_ptr = ^lsrm_unit_entry; lsrm_unit_entry = record hostladdr : link_address_type; mynode : shortint; { fake SRM node } hostnode : shortint; { fake SRM node } my_ip : integer; { IP } host_ip : integer; { IP } my_port : shortint; { UDP } host_port : shortint; { UDP } session : shortint; sequence : byte; connected : boolean; end; lsrm_table_type = array [unitnum] of lsrm_unit_entry; lsrm_table_ptr = ^lsrm_table_type; check_type = (is_ok,is_done,is_reject); VAR iompx_info : iompx_info_ptr; lsrm_unit_table : lsrm_table_ptr; lastunit : unitnum; lastsc : type_isc; procedure lansrm_init(var srmbuf : buf_info_type); function lansrm_connect:boolean;  procedure lansrm_ok(var sc:integer); procedure lansrm_reset(sc : integer); procedure lansrm_init_unit(un : integer); IMPLEMENT $LINENUM 5000$ $SEARCH 'LANDECS','LANASM'$ IMPORT LANASM; TYPE timeout_arr=array[1..4] of integer; CONST e _broadcast = #255#255#255#255#255#255; ip_protocol = hex('0800'); arp_protocol = hex('0806'); udp_service_port = 570; { UDP server port number } udp_my_port = 570; { UDP my port number } { Modified 1/2/91 JWH - now same as BASIC : } { connect_timeout is now a variable - it is set in } { routine lansrm_connect } { connect_timeout = 0500; .5 seconds } boot_connect_timeout = 20000; { 20 seconds } broadcast_connect_timeout = 4000; { 4 seconds } { Modified 1/2/91 JWH - now same as BASIC : } { connect_tries = 2; } connect_tries = 3; { Modified 1/2/91 JWH - now same as BASIC : } { op_timeout = timeout_arr[15000, 5000, 700, 20000]; } op_timeout = timeout_arr[60000, 15000, 5000, 60000]; op_tries = 3; { PACKET CODES } lsrm_request_code = 1; { want to connect } lsrm_reply_code = 129; tfr_request_code = 2; { data movement } tfr_reply_code = 130; { p_version = 10; }  { protocol version } p_version = 11; { protocol version } { RETURN CODES } L_NO_ERROR = 0; L_LENGTHEN_TIMEOUT = 1; L_SERVER_BUSY = 2; { NI on server } L_BAD_SEQUENCE_NUMBER = 3; { NI } L_BAD_SESSION= 4;  { NEED TO RECONNECT } L_BAD_SIZE = 5; { NI } L_BAD_PACKET = 6; { NI } L_ABORTED = 7; { SERVER GOING DOWN, NI on server } ip_sap = 6; udp_protocol = 17; ip_version = 4; TYPE byte_ptr = ^byte; cp = ^char; bits1 = 0..1; bits2 = 0..3; bits3 = 0..7; bits4 = 0..15; bits5 = 0..31; bits6 = 0..63; bits7 = 0..127; bits8 = 0..255; bits13= 0..8191; bits14= 0..16383; bits16= 0..65535; bits21= 0..2097151; bits24= 0..16777215; ether_hdr_ptr = ^ether_hdr_type; ether_hdr_type = packed record e_destination, e_source : link_address_type; ether_type : shortint;  end; ip_hdr_ptr = ^ip_hdr; ip_hdr = packed record version : bits4; ihl : bits4; service : bits8; length : bits16; id : bits16; flags  : bits3; frag_offset : bits13; ttl : bits8; protocol: bits8; hdr_check : shortint; ip_source : integer; ip_destination : integer; end;  udp_hdr_ptr = ^udp_hdr; udp_hdr = packed record udp_source, udp_destination : bits16; udp_len : bits16; udp_chk : bits16; end; arp_ptr = ^arp_rec; arp_rec = packed record htype : bits16; ptype : bits16; hal : bits8; pal : bits8; arp_op: bits16; senderl : link_address_type; senderp : integer;  targetl : link_address_type; targetp : integer; end; { lan_srm packet formats } lsrm_request_ptr = ^lsrm_request_type; lsrm_request_type = packed record { OUTBOUND } rec_type : shortint;{ 1 } ret_code : shortint;{ 0 } option_code : shortint;{ reserved @ 0 } host_node : shortint; version : shortint;{ protocol version } my_station : link_address_type; end; lsrm_reply_ptr = ^lsrm_reply_type; lsrm_reply_type = packed record { INBOUND } rec_type : shortint; { 129 }  ret_code : shortint; host_ip : integer; { may contain the host ip address } my_ip : integer; { IP } option_code: shortint; { reserved @ 0 }   host_node : shortint; { host SRM node } version : shortint; my_node : shortint; my_station : link_address_type; { for verification } host_flag : byte; { = 0 get ip & station from headers, <> 0 use host_ip field & ARP to get station } {sys_name : string255; not used } end; tfr_request_ptr = ^tfr_request_type; tfr_data_type = packed array[1..lan_max_frame_len] of char; tfr_data_ptr = ^tfr_data_type; tfr_request_type = packed record { DATA IN & OUT } rec_type : shortint; { 2 | 130 } ret_code : shortint; session_id : shortint; { echoed from last packet } version : shortint; { constant } host_node : shortint; { same as in contact record }  unum : byte; { unum + sequence_no } sequence_no: byte; { seen as single field by server } {data : tfr_data_type;} end; lsrm_sctable_eptr = ^lsrm_sctable_entry;  lsrm_sctable_entry = record localaddr : link_address_type; mpxinw : iompx_rec; end; lsrm_sctable_type = array [type_isc] of lsrm_sctable_entry; lsrm_sctable_ptr  = ^lsrm_sctable_type; link_address_ptr = ^link_address_type; CONST ll_hdr_size = sizeof(ether_hdr_type); ip_size = sizeof(ip_hdr); udp_size = sizeof(udp_hdr); req_size = sizeof(lsrm_request_type); reply_size = sizeof(lsrm_reply_type); tfr_req_size = sizeof(tfr_request_type); VAR lsrm_sctable : lsrm_sctable_ptr; inworkbuf, outworkbuf : BUFxINFOxPTR; current_ip : ip_hdr_ptr; { ip/udp } op_done : shortint; { Added 1/2/91 JWH : } connect_timeout : integer; FUNCTION buffer_busy( VAR b_info: buf_info_type ): BOOLEAN; BEGIN WITH b_info DO buffer_busy := active_isc <> no_isc; END; { buffer_busy } PROCEDURE iobuffer ( VAR b_info: buf_info_type ;  t_count : INTEGER ) ; BEGIN WITH b_info DO BEGIN { what about IOBUFFER to a already existant buffer ? } { - the space will be thrown away. } NEWBYTES(buf_ptr,t_count); act_tfr  := no_tfr; active_isc:= no_isc; buf_size := t_count; buf_empty := buf_ptr; buf_fill := buf_ptr; drv_tmp_ptr := NIL; eot_proc.dummy_sl := NIL; eot_proc.dummy_pr := NIL;  eot_parm := NIL; {JPC 02/22/82} dma_priority := FALSE ; END; { of WITH DO } END; { iobuffer } FUNCTION buffer_data(VAR b_info : buf_info_type ): INTEGER; BEGIN WITH b_info DO buffer_data:=INTEGER(buf_fill)-INTEGER(buf_empty); END; { buffer_data } PROCEDURE buffer_reset(VAR b_info: buf_info_type ) ; BEGIN WITH b_info DO BEGIN IF active_isc = no_isc THEN BEGIN buf_fill:=buf_ptr; buf_empty:=buf_ptr; END ELSE io_escape(ioe_buf_busy,no_isc); END; { of WITH DO } END; { buffer_reset } FUNCTION buffer_space(VAR b_info: buf_info_type): INTEGER; BEGIN WITH b_info DO BEGIN IF ( buffer_data(b_info)=0 ) AND ( active_isc = no_isc ) THEN buffer_reset(b_info); buffer_space:=buf_size+INTEGER(buf_ptr)-INTEGER(buf_fill); END; { of WITH DO } END; { buffer_space } procedure init_buffer(var buf : buf_info_type;  anyvar data : integer; size : integer); begin with buf do begin buf_ptr := addr(data); buf_size := size; buf_empty := buf_ptr; buf_fill := buf_ptr; act_tfr := no_tfr; active_isc  := no_isc; drv_tmp_ptr:= nil; eot_proc.dummy_sl := nil; eot_proc.dummy_pr := nil; eot_parm := nil; dma_priority := false; end; end; { init_buffer } FUNCTION transfer_setup ( device : type_device; t_tfr : user_tfr_type; t_dir : dir_of_tfr ; VAR b_info: buf_info_type ; VAR t_cnt : INTEGER ): type_isc ; VAR io_isc : type_isc; BEGIN IF device>iomaxisc THEN io_isc := device DIV 100 ELSE io_isc := device; IF isc_table[io_isc].io_tmp_ptr = NIL THEN io_escape(ioe_no_driver,io_isc); WITH b_info DO  BEGIN { test for tfr count } IF t_cnt=0 THEN io_escape(ioe_bad_cnt,no_isc); { test for another tfr on this buffer } IF active_isc <> no_isc THEN io_escape(ioe_buf_busy,no_isc) ELSE BEGIN IF buffer_data(b_info)=0 THEN buffer_reset(b_info); END; { configure card based on direction and check for available space/data } IF t_dir= to_memory THEN BEGIN IF (t_tfr<>dummy_tfr_1) and (t_tfr<>dummy_tfr_2) THEN IF isc_table[io_isc].io_tmp_ptr^.in_bufptr <> NIL THEN io_escape(ioe_isc_busy,io_isc); IF buffer_space(b_info)dummy_tfr_1) and (t_tfr<>dummy_tfr_2) THEN isc_table[io_isc].io_tmp_ptr^.in_bufptr := ADDR( b_info ); END ELSE BEGIN { from_memory } IF isc_table[io_isc].io_tmp_ptr^.out_bufptr <> NIL THEN io_escape(ioe_isc_busy,io_isc); IF buffer_data(b_info)0 then begin if skip>src.term_count then skip := src.term_count; src.buf_empty := ADDR(cp(src.buf_empty)^,skip); src.term_count := src.term_count - skip; end; if move>0 then begin if move>src.term_count then move := src.term_count; if move>dest.term_count then move := dest.term_count; moveleft(cp(src.buf_empty)^,cp(dest.buf_fill)^,move); src.term_count := src.term_count - move; src.buf_empty := ADDR(cp(src.buf_empty)^,move); dest.term_count := move; dest.buf_fill := ADDR(cp(dest.buf_fill)^,move); end; end; { copy_buffer_data } procedure build_frame(var dest : buf_info_type; var unit_r : lsrm_unit_entry; var sc_r : lsrm_sctable_entry; anyvar buf1: tfr_data_type; size1 : shortint;   anyvar buf2: tfr_data_type; size2 : shortint); var tempp : anyptr; begin buffer_reset(dest); tempp := dest.buf_fill; { build the protocol stack into the buffer } with ether_hdr_ptr(tempp)^ do begin  e_destination := unit_r.hostladdr; e_source := sc_r.localaddr; ether_type := ip_protocol; end; tempp := addr(cp(tempp)^,ll_hdr_size); with ip_hdr_ptr(tempp)^ do begin version := ip_version; ihl := ip_size div 4; service := 0; length := ip_size + udp_size + size1 + size2; id := 0; flags := 0; frag_offset := 0; ttl := 255; protocol:= udp_protocol; hdr_check := 0; ip_source := unit_r.my_ip; ip_destination := unit_r.host_ip; checksum1(hdr_check,cp(tempp)^,ip_size div 2); end; tempp := addr(cp(tempp)^,ip_size); with udp_hdr_ptr(tempp)^ do begin udp_source := unit_r.my_port; udp_destination := unit_r.host_port; udp_len := udp_size + size1 + size2; udp_chk := 0; { no check sum } end; tempp := addr(cp(tempp)^,udp_size); { copy the data buffer(s) } if size1>0 then begin moveleft(buf1,cp(tempp)^,size1); tempp := addr(cp(tempp)^,size1); end; if size2>0 then begin moveleft(buf2,cp(tempp)^,size2); tempp := addr(cp(tempp)^,size2); end; dest.buf_fill := tempp; end; { build_frame } procedure eot_rearm(buf : ANYPTR); begin with BUFxINFOxPTR(buf)^ do begin if (term_char=lb_eot) or (term_char=lb_short) then begin active_isc := lastsc; { re-arm this buffer } eot_proc.dummy_pr := nil ; { kill the eot proc } end; end; end; { eot_rearm } procedure check_frame(var source : buf_info_type; var unit_r : lsrm_unit_entry; var sc_r : lsrm_sctable_entry; var ok : check_type; var data : anyptr; var size : shortint); label 1; var check : shortint; tempbuf : buf_info_type; begin ok := is_reject; data := source.buf_empty; with ether_hdr_ptr(data)^ do begin if ether_type=arp_protocol then with arp_ptr(addr(cp(data)^,14))^ do begin { arp } if lsrm_unit_table^[lastunit].my_ip=0 then goto 1; if not((htype=1) and { ethernet } (ptype=ip_protocol) and { ip } (arp_op=1) and { request } (targetp = unit_r.my_ip) ) then goto 1;  { now try to reply } e_source := sc_r.localaddr ; e_destination := senderl; targetl := senderl; targetp := senderp; senderl := e_source; senderp := unit_r.my_ip; arp_op := 2; {reply} check := buffer_data(source); init_buffer(tempbuf,cp(data)^,check); tempbuf.buf_fill := addr(cp(tempbuf.buf_fill)^,check); try transfer(lastsc,overlap,from_memory,tempbuf,check); recover begin end; { might not work } ok := is_done; goto 1; end else if (ether_type<>ip_protocol) then goto 1 else if (e_destination<>sc_r.localaddr) then begin if (e_destination<>e_broadcast) then goto 1; end; end; current_ip := addr(cp(data)^,14); { locate the IP header } { check ip for udp protocol } with current_ip^ do begin if not (version=ip_version) and (protocol=udp_protocol) then goto 1; if length>lan_max_frame_len then goto 1; data := addr(current_ip^,ihl*4); { locate the UDP header } end; { check udp port number } if udp_hdr_ptr(data)^.udp_destination <> unit_r.my_port then goto 1;   { looks like the right stuff so now check it in detail } with current_ip^ do begin checksum1(check,current_ip^,ihl*2); if check<>0 then goto 1; { checksum failed } if frag_offset<>0 then goto 1; { can't handle fragments } end; with udp_hdr_ptr(data)^ do begin size := udp_len-8; data := addr(cp(data)^,udp_size); { point to data area } end; ok := is_ok; 1: end; { check_frame } function get_host_ip:integer; begin get_host_ip := current_ip^.ip_source; end; { get_my_ip } procedure get_host_station(RBUF:BUFxINFOxPTR); begin { this will use ARP to find the host station address } end; PROCEDURE WRAPPER1(TEMP : ANYPTR; VAR B:BOOLEAN); { adds lower level protocol stuff to lsrm_reqest packet } BEGIN with iompx_rec_ptr(temp)^ do begin isc_table[scode].io_tmp_ptr^.out_bufptr := nil; { patch #1 } build_frame(outworkbuf^,lsrm_unit_table^[lastunit],  lsrm_sctable^[scode], cp(user_buffer^.buf_empty)^,buffer_data(user_buffer^), user_buffer,0); { these are dummy arguments } transfer(scode,serial_fastest,from_memory,outworkbuf^,buffer_data(outworkbuf^)); end; { with mpxr^ } b := false; { its gone } END; {WRAPPER1} PROCEDURE CHECKER1(TEMP : ANYPTR; VAR B:BOOLEAN); label 1; VAR mpxr : iompx_rec_ptr; lutable: lsrm_unit_ptr;  sctable: lsrm_sctable_eptr; dsize : shortint; { total frame size } tempp : anyptr; ok : check_type; BEGIN mpxr := temp; b := true; with mpxr^ do if in_buffer<>nil then begin lutable := addr(lsrm_unit_table^[lastunit]); sctable := addr(lsrm_sctable^[scode]); check_frame(in_buffer^,lutable^,sctable^,ok,tempp,dsize); if ok=is_done then { signal that this data is accepted & setup to re-arm the buffer }  begin b:= false; user_buffer^.eot_proc.real_proc := eot_rearm; end; if ok<>is_ok then goto 1; if dsizesctable^.localaddr then goto 1; { save addresses } lutable^.my_ip := my_ip; lutable^.hostnode := host_node; { adjust addresses/ports as required } if host_flag=0 then lutable^.host_ip := get_host_ip else lutable^.host_ip := host_ip; lutable^.host_port := udp_service_port; with lutable^ do begin session := -1; sequence := 0; mynode := my_node; if host_flag<>0 then get_host_station(in_buffer); hostladdr := ether_hdr_ptr(in_buffer^.buf_empty)^.e_source; end; end; { tell caller to complete the transfer } b := false; in_buffer^.term_count := 0; { checked/moved it all }  with user_buffer^ do begin cp(buf_fill)^ := 'G'; buf_fill := addr(cp(buf_fill)^,1); term_count := 1; end; end; { with mpxr } 1: END; {CHECKER1} { normal operations wrapper procedure } PROCEDURE WRAPPER2(TEMP : ANYPTR; VAR B:BOOLEAN); VAR mpxr : iompx_rec_ptr; lutable : lsrm_unit_ptr; sctable : lsrm_sctable_eptr; old_seq : byte; do_rx, do_tx : boolean; op_timer : timer_rec; op_retries : integer; lastsize : integer; procedure load_work_buf; var tfr: tfr_request_type; begin with mpxr^ do begin with tfr do begin rec_type :=  tfr_request_code; ret_code := 0; session_id := lutable^.session; version := p_version; host_node := lutable^.hostnode; unum := lastunit; sequence_no := lutable^.sequence; end; { with } build_frame(outworkbuf^,lutable^, sctable^, tfr,sizeof(tfr), cp(user_buffer^.buf_empty)^,buffer_data(user_buffer^)); end; { with } end; { load_work_buf } BEGIN { WRAPPER2 } mpxr := temp; with mpxr^ do begin isc_table[scode].io_tmp_ptr^.out_bufptr := nil; { patch #1 } lutable := addr(lsrm_unit_table^[lastunit]); sctable := addr(lsrm_sctable^[scode]); with lutable^ do begin if not connected then if lansrm_connect then connected := true else io_escape(ioe_dc_conn,lastsc); end; { don't send the first byte of data } with user_buffer^ do begin buf_empty := addr(cp(buf_empty)^,1); end; load_work_buf; with sctable^.mpxinw do user_buffer := user_buffer^.eot_parm; { goto next input buffer } op_retries := op_tries; lastsize := buffer_data(outworkbuf^); do_rx := true; do_tx := true; repeat op_done := -1; if do_rx then with sctable^.mpxinw do begin do_rx := false; buffer_reset(user_buffer^); transfer(scode,dummy_tfr_2,to_memory,user_buffer^,lan_max_frame_len); end; if do_tx then begin with outworkbuf^ do buf_empty := buf_ptr; { reset buf_empty } transfer(scode,overlap_fastest,from_memory,outworkbuf^,lastsize); while outworkbuf^.active_isc<>no_isc do; { wait for this to go out } end; do_tx := true; { start timeout timeing } op_timer.time := op_timeout[op_retries]; start_timer(op_timer); op_retries := op_retries-1; { wait for packet received or timeout } repeat until (op_done<>-1) or time_expired(op_timer); { set do_rx in case of need to loop again } do_rx := op_done>0; case op_done of 0:; { ok } 1,2:{ lengthen timeout or server busy } begin { go to long timeout } op_retries := op_tries+1; do_tx := false; { don't resend the packet } end; 4:io_escape(ioe_dc_conn,lastsc); { bad_session } 7:io_escape(ioe_sr_fail,lastsc); { server going down } otherwise { timeout or unimplemented return code } if (op_retries<=0) then with sctable^.mpxinw do begin user_buffer^.active_isc := no_isc; { stop the transfer }  buffer_reset(user_buffer^); lsrm_unit_table^[lastunit].connected := false; io_escape(ioe_sr_fail,lastsc); end; end; { case } until op_done=0; { fix up the callers buf_empty pointer } with user_buffer^ do buf_empty := addr(cp(buf_empty)^,buffer_data(user_buffer^)); end; { with mpxr^ } b := false; { tell caller the xfr is done } END; {WRAPPER2} PROCEDURE CHECKER2(TEMP : ANYPTR; VAR B:BOOLEAN); VAR mpxr : iompx_rec_ptr; BEGIN mpxr := temp; with mpxr^ do begin if in_buffer=nil then begin { get data from inworkbuf } if inworkbuf^.active_isc = no_isc then begin { copy every thing } copy_buffer_data(inworkbuf^,user_buffer^,0,maxint); { if no more data in the source then switch to next buffer } if inworkbuf^.term_count=0 then inworkbuf := inworkbuf^.eot_parm; if user_b uffer^.term_count=0 then io_escape(ioe_no_data,no_isc); b := false; { data has been moved } end else io_escape(ioe_sr_fail,no_isc); end else b := true; { reject it } end; END; { CHECKER2 } PROCEDURE CHECKER3(TEMP : ANYPTR; VAR B:BOOLEAN); label 1; VAR mpxr : iompx_rec_ptr; lutable: lsrm_unit_ptr; tempp : anyptr; dsize : shortint; ok : check_type; BEGIN mpxr := temp; b := true; { reject it } with mpxr^ do begin lutable := addr(lsrm_unit_table^[lastunit]); if in_buffer<>nil then with in_buffer^ do begin check_frame(in_buffer^,lutable^,lsrm_sctable^[scode],ok,tempp,dsize); if ok=is_done then { signal that this data is accepted & setup to re-arm the buffer } begin b:= false; user_buffer^.eot_proc.real_proc := eot_rearm; end; if ok<>is_ok then goto 1;  { check the reply contents } with tfr_request_ptr(tempp)^ do begin if not ((rec_type=tfr_reply_code) and (version = p_version) and (host_node = lutable^.hostnode) and  (sequence_no=lutable^.sequence) and (unum=lastunit)) then goto 1; op_done := ret_code; end; if op_done=0 then begin { set the next expected sequence number } lutable^.sequence := (lutable^.sequence+1) mod 256; lutable^.session := tfr_request_ptr(tempp)^.session_id; {skip all lsrm header then move the data} tempp := addr(cp(tempp)^,tfr_req_size); dsize := dsize - tfr_req_size; if dsize>0 then begin with user_buffer^ do begin if dsize>term_count then dsize := term_count; moveleft(cp(tempp)^,cp(buf_fill)^,dsize); term_count := dsize; buf_fill := ADDR(cp(buf_fill)^,dsize); end; end; end; b := false; { tell caller its processed } end; { with in_buffer } end; { with mpxr } 1: END; {CHECKER3} function lansrm_connect:boolean; VAR mpxout, mpxin : iompx_rec; lutable : lsrm_unit_ptr; utable : ^unitentry; bufin : buf_info_type; datai : char; bufout : buf_info_type; datao : lsrm_request_type; timer : timer_rec; tries : integer; i : integer; done : boolean; farea[-300] : link_address_ptr; BEGIN { lansrm_connect } done := false; lutable := addr(lsrm_unit_table^[lastunit]); utable := addr(unitable^[lastunit]); with lutable^ , iompx_info^ do begin with utable^ do begin TRY { setup the input side } CALL(register_iompx_buf,  sc,TO_MEMORY,bufin,mpxin,FALSE,lutable,checker1); { setup the output side } CALL(register_iompx_buf, sc,FROM_MEMORY,bufout,mpxout,FALSE,lutable,wrapper1); { start the input transfer for one byte }  init_buffer(bufin,datai,1); datai := 'F'; transfer(sc,dummy_tfr_2,to_memory,bufin,1); { build & transmit the request } with datao do begin rec_type := lsrm_request_code; ret_code := 0; option_code := 0; host_node := BA; { from unitable^ } version := p_version; my_station := lsrm_sctable^[lastsc].localaddr; end; { if boot device then use the host address else use the broadcast } { Enhanced 1/2/91 JWH to set the connect_timeout variable JWH } if BA=127 then begin lutable^.hostladdr := farea^; connect_tim eout := boot_connect_timeout; end else begin lutable^.hostladdr := e_broadcast; connect_timeout := broadcast_connect_timeout; end; my_port := udp_my_port;  init_buffer(bufout,datao,sizeof(datao)); bufout.buf_fill := addr(bufout.buf_ptr^,sizeof(datao)); tries := connect_tries; repeat { send the request and start the timer } transfer(sc,serial_fastest,from_memory,bufout,sizeof(datao)); timer.time := connect_timeout; start_timer(timer); repeat if (not done) and (not buffer_busy(bufin)) then begin done := datai='G'; if not done then { restart the input transfer } begin buffer_reset(bufin); datai := 'F'; transfer(sc,dummy_tfr_2,to_memory,bufin,1); end; end; { while } until done or time_expired(timer); if not done then tries := tries-1; until done or (tries=0); RECOVER { suppress every error } begin end; call(unregister_iompx_buf,sc,TO_MEMORY,bufin); call(unregister_iompx_buf,sc,FROM_MEMORY,bufout); end; end; {with lsrm_isc_table} lansrm_connect := done; END; { lansrm_connect } { called by table before it does a hook up } procedure lansrm_ok(var sc : integer); begin if iompx_info<>nil then begin if (sc>=minrealisc) and (sc<=maxrealisc) then begin if (iompx_info^.isc_iompx_table[sc].capable) and (isc_table[sc].card_id = hp98643) then SC := -SC;  end; end; end; { lansrm_ok } procedure lansrm_reset(sc:integer); begin with lsrm_sctable^[sc].mpxinw do begin user_buffer^.active_isc := no_isc; inworkbuf := user_buffer^.eot_parm; inworkbuf^.active_isc := no_isc; end; end; { lansrm_reset } procedure lansrm_init_unit(un: integer); begin with lsrm_unit_table^[un] do begin hostladdr := e_broadcast; mynode := 0; hostnode := 0; my_ip  := 0; host_ip := -1; my_port := udp_my_port; host_port := udp_service_port; session := -1; sequence := 0; connected := false; end; end; { lansrm_init_unit } { if IOMPX is installed then scan the select codes for a LAN card & driver using IOMPX for each one found, register the srm driver buffer & a working buffer if any suitable interfaces were found, allocate & initialize the shadow unit table } procedure lansrm_init(var srmbuf : buf_info_type); VAR i, sc : integer; ok : boolean; ans : iompx_ans_rec; lutable : lsrm_unit_ptr; mpxout, mpxin : iompx_rec_ptr; inworkbuf2 : BUFxINFOxPTR;  BMSUS[-292] : PACKED ARRAY [1..4] OF CHAR; BEGIN { LANSRM_INIT } mpxout := nil; mpxin := nil; { allocate & init the shadow unit table } if lsrm_unit_table=nil then begin { modify boot MSUS for power up from LAN } if ORD(BMSUS[1])=HEX('E2') then begin { booted from LAN } BMSUS[2] := #8; { unit 8 } BMSUS[4] := #127; { boot node } end; if iompx_info=nil then begin call(io_error_link,iompx_request,ans.s); ok := ans.s=iompx_answer; if ok then iompx_info := ans.ptr; end; if ok then begin ok := false; for sc := minrealisc to maxrealisc do with iompx_info^ do begin  if isc_iompx_table[sc].capable then with isc_table[sc] do begin if (card_id=hp98643) then begin { register the buffers } if lsrm_sctable=nil then new(lsrm_sctable); { allocate sha dow sc table } ok := true; { at least one setup } with lsrm_sctable^[sc] do for i := 1 to 6 do begin localaddr[i] := chr(iostatus(sc,l_link_addr1-1+i)); end; if inworkbuf=nil then begin new(inworkbuf); IOBUFFER(inworkbuf^,LAN_MAX_FRAME_LEN); new(inworkbuf2); IOBUFFER(inworkbuf2^,LAN_MAX_FRAME_LEN);  { chain link the buffers thru eot_parm } inworkbuf^.eot_parm := inworkbuf2; inworkbuf2^.eot_parm := inworkbuf; new(outworkbuf); IOBUFFER(outworkbuf^,LAN_MAX_FRAME_LEN);  end; { setup the input side } { need unique registration records for each select code } new(mpxin); CALL(register_iompx_buf, sc,TO_MEMORY,srmbuf,mpxin^,FALSE,lutable,checker2); with lsrm_sctable^[sc] do begin CALL(register_iompx_buf, sc,TO_MEMORY,inworkbuf^,mpxinw,FALSE,lutable,checker3); lansrm_reset(sc); { fix up data structures used by wrapper2 etc. } end; { setup the output side } new(mpxout); CALL(register_iompx_buf, sc,FROM_MEMORY,srmbuf,mpxout^,FALSE,lutable,wrapper2);  end; end; end; if ok then begin new(lsrm_unit_table); for i := 0 to maxunit do lansrm_init_unit(i); end else iompx_info := nil; { no LAN } end; end; END; { lansrm_init } END. { MODULE LANSRM }  (* (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 *) $copyright 'COPYRIGHT (C) 1983 BY HEWLETT-PACKARD COMPANY'$ $range off$ $debug off$ $modcal$ $sysprog$ $ucsd$ module srm; { $SEARCH 'IOLIB:KERNEL'$ } {INTERNAL ONLY BEGIN} { $SEARCH 'LANSRM','IOLIB:LANDECS'$ } $SEARCH 'LANSRM','LANDECS'$ {INTERNAL ONLY END} import iodeclarations, sysglobals, loader {INTERNAL ONLY BEGIN} ,lansrm, landecs {INTERNAL ONLY END} ; export { $include 'INIT:SRM_TYPES'$ $include 'INIT:SRM_ERRS'$ } $include 'SRM_TYPES'$ $include 'SRM_ERRS'$ var packet_ptr : pk_ptr; defaulttimeout : integer; {timeout values in milliseconds} waitforlocktimeout : integer; copytimeout : integer; srmsavesc  : shortint; {INTERNAL ONLY BEGIN} { srmux_on : srmux_array; } { Moved to MISC 8/10/90 JWH } srmux_on : srmux_array; { Moved back 10/31/90 JWH } { TESTING ONLY !!!! } { usage_array : array[damrequesttype] of integer; } {INTERNAL ONLY END} procedure srm_init; procedure resetcard(unum : unitnum); procedure packetout(unum : unitnum); procedure packetin(unum : unitnum; sendreq : integer); procedure areyoualivepack(unum  : unitnum); procedure catpack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type;   rtpass : name_type; max : integer; indx : integer); procedure catpasspack(unum : unitnum; nfns : integer; nsaptr : pnsa;  path : path_start_type; wd : file_id_type; rtpass : name_type; max : integer; indx : integer); procedure changeprotectpack(unum  : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type; nps : integer; psaptr : ppsa); procedure changevolpack(unum : unitnum; vpass : name_type; newname  : name_type; newpass : name_type); procedure closepack(unum : unitnum; fid : file_id_type); procedure copypack(unum : unitnum; srcfid : file_id_type; srcoff : integer; destfid : file_id_type; destoff : integer; req : integer); procedure createpack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type; nps : integer;  psaptr : ppsa; ftype : gang_file_codes; mode : integer; maxrec : integer; ext1 : integer; ext2 : integer;  xaddr : integer); procedure createlinkpack(unum : unitnum; oldnfns : integer; oldnsaptr : pnsa; oldpath : path_start_type;  oldwd : file_id_type; oldrtpass : name_type; newnfns : integer; newnsaptr : pnsa; newpath : path_start_type;  newwd : file_id_type; newrtpass : name_type; purgeold : boolean); procedure exchangepack(unum : unitnum; fid1 : file_id_type; fid2 : file_id_type); procedure fileinfopack(unum : unitnum; fid : file_id_type); procedure gangcleanpack(unum : unitnum; savewd  : boolean); procedure lockpack(unum : unitnum; fid : file_id_type; wait : boolean); procedure openpack(unum : unitnum; nfns : integer;  nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type; share : integer; opn : gang_open_type); procedure pospack(unum : unitnum; fid : file_id_type; typepos : position_type; boffset : integer); procedure purgepack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type); procedure sendreadpack(unum : unitnum;   fid : file_id_type; access : integer; req : integer; off : integer; dat : anyptr); procedure seteofpack(unum : unitnum;  fid : file_id_type; usecurptr : boolean; boffset : integer); procedure unlockpack(unum : unitnum; fid : file_id_type); procedure volpack(unum : unitnum); procedure sendwritepack(unum : unitnum; fid : file_id_type; access : integer; req : integer; off : integer; dat  : anyptr); procedure setdefaulttimeout(time : integer); procedure setcopytimeout(time : integer); procedure setwaitforlocktimeout(time : integer); {INTERNAL ONLY BEGIN} { Added for SRM-UX } procedure chmodpack(unum : unitnum;  nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; fid : file_id_type; rtpass : name_type; nmode : integer); procedure chownpack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd  : file_id_type; fid : file_id_type; rtpass : name_type; nmode : integer); procedure chgrppack(unum : unitnum; nfns : integer;  nsaptr : pnsa; path : path_start_type; wd : file_id_type; fid : file_id_type; rtpass : name_type; nmode : integer); procedure rmtexecpack(unum : unitnum; path : path_start_type; wd : file_id_type; { working directory } rtpass : name_type; cmdstring : anyptr; cmdstringlen : integer); { function is_srmux_unit(unum : unitnum) : boolean; } { Moved to MISC JWH } function is_srmux_unit(unum : unitnum) : boolean; { back 10/31/90 JWH } {INTERNAL ONLY END} var dumbuf : ^buf_info_type; implement const packetouttimeout = 1000; {timeout values in milliseconds} ayatimeout = 1000; var srm_inited : boolean; waitingforlock: boolean; (****************************************************************************) procedure maptoioresult(status : integer); begin if ioresult = ord(inoerror) then if status <> 0 then case status of ios_bad_select_code : ioresult := ord(ibadunit); ios_attach_table_full  : ioresult := ord(itoomanyopen); ios_invalid_file_size : ioresult := ord(inotvalidsize); ios_invalid_file_id : ioresult := ord(ilostfile); ios_bad_file_name, ios_file_pathname_missing  : ioresult := ord(ibadtitle); ios_illegal_byte_number : ioresult := ord(ibadvalue); ios_successful_completion, ios_no_reply : ioresult := ord(inoerror); ios_system_down,  ios_volume_offline, ios_volume_not_found, ios_volume_down : ioresult := ord(znodevice); ios_file_unopened : ioresult := ord(inotopen); ios_password_not_allowed, ios_no_capability_for_file, ios_invalid_protect_code, ios_password_not_found, ios_duplicate_passwords : ioresult := ord(ibadpass); ios_access_to_file_not_allowed : ioresult := ord(inoaccess); ios_unsupported_dir  ectory_operation, ios_link_to_directory_not_allowed : ioresult := ord(inotondir); ios_deadlock_detected, ios_conflicting_share_modes, ios_file_locked_please_retry : ioresult := ord(ifilelocked); ios_file_in_use, ios_purge_on_open : ioresult := ord(inotclosed); ios_insufficient_disk_space : ioresult := ord(inoroom); ios_duplicate_filenames : ioresult := ord(idupfile); ios_phys_eof_encountered, ios_eof_encountered : ioresult := ord(ieof); ios_file_not_found : ioresult := ord(inofile); ios_volume_in_use : ioresult := ord(znotready); ios_file_not_directory  : ioresult := ord(ifilenotdir); ios_directory_not_empty : ioresult := ord(idirnotempty); ios_invalid_file_code : ioresult := ord(ibadfiletype); ios_rename_across_volumes : ioresult := 57; { For now } otherwise ioresult := ord(isrmcatchall); end; end; (****************************************************************************) procedure initdumbuf; begin with dumbuf^ do begin buf_ptr := nil; act_tfr := no_tfr; active_isc := no_isc; buf_size := 0; buf_empty := nil; buf_fill := nil; drv_tmp_ptr := nil; eot_proc.dummy_sl := nil; eot_proc.dummy_pr := nil; eot_parm := nil; dma_priority := false; end; end; (****************************************************************************) (****************************************************************************) procedure srm_init; begin if not srm_inited then begin new(packet_ptr.mp); new(dumbuf); {INTERNAL ONLY BEGIN} lansrm_init(dumbuf^); { RDQ } {INTERNAL ONLY END} markuser; srm_inited := true; end; initdumbuf; defaulttimeout := 240000; {3.1}{timeout values in milliseconds} waitforlocktimeout := 0; copytimeout := 240000; { modified for 3.1 6/11/85 jws } end; (****************************************************************************) procedure resetcard(unum : unitnum); begin with isc_table[unitable^[unum].sc] do call(io_drv_ptr^.iod_init, io_tmp_ptr); end; (****************************************************************************) procedure setdefaulttimeout(time: integer); begin defaulttimeout := time; {time is in milliseconds} end; (****************************************************************************) procedure setwaitforlocktimeout(time: integer); begin waitforlocktimeout := time; {time is in milliseconds} end; (****************************************************************************) procedure setcopytimeout(time: integer); begin copytimeout := time; {time is in milliseconds} end; (****************************************************************************) procedure setintegertimeout(sc : type_isc; time: integer); begin with isc_table[sc] do begin user_time := time;  {time is in milliseconds} if io_tmp_ptr <> nil then io_tmp_ptr^.timeout := time; end; end; (****************************************************************************) function do_buffer_data(var b_info : buf_info_type) : integer; begin with b_info do do_buffer_data := integer(buf_fill) - integer(buf_empty); end; (****************************************************************************) procedure do_buffer_reset(var b_info : buf_info_type); begin with b_info do if active_isc <> no_isc then io_escape(ioe_buf_busy,no_isc) else begin buf_fill := buf_ptr; buf_empty := buf_ptr; end; end; (****************************************************************************) fun  ction do_buffer_space(var b_info : buf_info_type) : integer; begin with b_info do begin if (do_buffer_data(b_info) = 0) and (active_isc = no_isc) then do_buffer_reset(b_info); do_buffer_space := buf_size + integer(buf_ptr) - integer(buf_fill); end; end; (****************************************************************************) {INTERNAL ONLY BEGIN} procedure do_transfer(sc : type_isc; dir : dir_of_tfr; count  : integer; tfr_end : boolean); var lcount : integer; utfr : user_tfr_type; begin with isc_table[sc], dumbuf^ do begin utfr := serial_fastest; if not tfr_end then lcount := count else  if dir = from_memory then lcount := do_buffer_data(dumbuf^) else lcount := do_buffer_space(dumbuf^); if io_tmp_ptr = nil then io_escape(ioe_no_driver,sc); if lcount = 0 then io_escape(ioe_bad_cnt,no_isc);  { if iompx capable then use registered transfer } { otherwise use normal transfer} if iompx_info<>nil then with iompx_info^ do if isc_iompx_table[sc].capable then utfr := dummy_tfr_1; if active_isc <> no_isc then io_escape(ioe_buf_busy,no_isc); if do_buffer_data(dumbuf^) = 0 then do_buffer_reset(dumbuf^); with io_tmp_ptr^ do if dir = to_memory then begin if do_buffer_space(dumbuf^) < lcount then io_escape(ioe_no_space,sc); if utfr<>dummy_tfr_1 then if in_bufptr <> nil then io_escape(ioe_isc_busy,sc) else in_bufptr := dumbuf; end else begin if do_buffer_data(dumbuf^) < lcount then io_escape(ioe_no_data,sc); if out_bufptr <> nil then io_escape(ioe_isc_busy,sc) else out_bufptr := dumbuf; end; drv_tmp_ptr := io_tmp_ptr; act_tfr  := no_tfr; usr_tfr := utfr; b_w_mode := false; {byte mode} direction := dir; term_char := -1; {no term char} term_count := lcount; end_mode  := tfr_end; call(io_drv_ptr^.iod_tfr,io_tmp_ptr,dumbuf); end; end; {INTERNAL ONLY END} (****************************************************************************) procedure dorecover(unum : unitnum); begin ioresult := ord(isrmcatchall); if (escapecode <> ioescapecode) then begin if srmsavesc = 0 then srmsavesc := escapecode end else if (ioe_result = ioe_timeout) then ioresult := ord(ztimeout); resetcard(unum); end; (****************************************************************************) procedure packetout(unum : unitnum); var ip : ^integer; begin with unitable^[unum] do try initdumbuf; setintegertimeout(sc,packetouttimeout); packet_ptr.mp^[8] := chr(unitable^[unum].ba); packet_ptr.mp^[9] := chr(0); packet_ptr.mp^[10] := chr(0); packet_ptr.mp^[11] := chr(0); ip := addr(packet_ptr.mp^[17]); {request type} if ip^ = req_are_you_alive then packet_ptr.mp^[12] := chr(2) else packet_ptr.mp^[12] := chr(7); dumbuf^.buf_ptr := anyptr(packet_ptr.mp); dumbuf^.buf_size := sizeof(msg_packet_type); dumbuf^.buf_empty := addr(packet_ptr.mp^[8]); ip := addr(packet_ptr.mp^[13]); {packet length} dumbuf^.buf_fill := addr(packet_ptr.mp^[12+1+ip^]); do_transfer(sc,from_memory,0,true); recover dorecover(unum); end; (****************************************************************************) procedure packetin(unum  : unitnum; sendreq : integer); type ayastatustype = packed record srmnode : byte; linkerrs : byte; computerid : shortint; end; ayastatusp  tr = ^ayastatustype; var count : integer; begin with unitable^[unum] do try initdumbuf; if sendreq = req_are_you_alive then setintegertimeout(sc,ayatimeout) else if (sendreq = req_flock) and (waitingforlock) then  setintegertimeout(sc,waitforlocktimeout) else if (sendreq = req_copy) or (sendreq = req_create) then { 3.0 BUG FIX 3/16/84 } setintegertimeout(sc,copytimeout) else setintegertimeout(sc,defaulttimeout); with packet_ptr.rhead^, packet_ptr.rread^ do begin repeat fillchar(linkfiller, 28, chr(0)); dumbuf^.buf_ptr := anyptr(packet_ptr.mp); dumbuf^.buf_size := sizeof(msg_packet_type);  dumbuf^.buf_empty := anyptr(packet_ptr.mp); dumbuf^.buf_fill := addr(packet_ptr.mp^[9]); if sendreq <> req_read then begin do_transfer(sc,to_memory,0,true); end else  begin count := size_from_gang_error + 4; do_transfer(sc,to_memory,count,false); if message_length > size_from_gang_error then if return_request_type <> -req_read then  begin do_transfer(sc,to_memory,0,true); end else begin count := size_from_read - size_from_gang_error; do_transfer(sc,to_memory,count,false); count := actual; if count > 0 then begin dumbuf^.buf_ptr := anyptr(user_sequencing_field); dumbuf^.buf_size := 512; dumbuf^.buf_empty := anyptr(user_sequencing_field); dumbuf^.buf_fill := anyptr(user_sequencing_field); do_transfer(sc,to_memory,count,false); end;  end; end; until return_request_type = -sendreq; if sendreq <> req_are_you_alive then maptoioresult(status) else if ayastatusptr(addr(status))^.srmnode <> 1 then  ioresult := ord(znodevice); end; recover dorecover(unum); end; (****************************************************************************) procedure setup_smh(var smh : send_header_type; ml,  srt, usf : integer); begin with smh do begin message_length := ml; send_request_type := srt; user_sequencing_field := usf; end; end; (****************************************************************************) procedure setup_vnh(var vnh : volume_header_type; unum : unitnum); begin with vnh do begin filler1 := 0; driver_name := ' '; catalogue_organization  := ' '; device_address_present.i := 1; with device_address do begin address1 := unitable^[unum].du; {unit number} haddress := 0; unit_num := 0; volume_num := 0; end; volume_name := ' '; end; end; (****************************************************************************) procedure setup_fnh(var fnh : file_header_type; num : integer;  wd : file_id_type; pt : path_start_type; rp : name_type); begin with fnh do begin num_file_name_sets := num; working_directory := wd; filler1 := 0; path_type := pt; root_password := rp; end; end; (****************************************************************************) procedure areyoualivepack(unum : unitnum); begin with packet_ptr.sareyoualive^ do   begin setup_smh(send_mess_header, size_to_are_you_alive, req_are_you_alive, 0); end; packetout(unum); if ioresult = ord(inoerror) then packetin(unum,req_are_you_alive); if ioresult <> ord(inoerror) then packet_ptr.rareyoualive^.return_mess_header.status := 0; end; (****************************************************************************) procedure catpack(unum : unitnum; nfns : integer;  nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type; max : integer; indx : integer); begin with packet_ptr.scat^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; setup_smh(send_mess_header, size_to_cat+nfns*36, req_catalog, 0); max_num_files := max;  file_index := indx; filler1 := 0; setup_vnh(volume_name_header,unum); filler2 := 0; setup_fnh(file_name_header, nfns, wd, {working directory} path, rtpass);{root password} end; packetout(unum); packetin(unum,req_catalog); end; (****************************************************************************) procedure catpasspack(unum : unitnum; nfns : integer;  nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type; max : integer; indx : integer); begin with packet_ptr.scatpass^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; setup_smh(send_mess_header, size_to_catprotect+nfns*36, req_catprotect, 0); max_num_passwords := max; filler1 := 0; password_index := indx; setup_vnh(volume_name_header,unum); filler2 := 0; setup_fnh(file_name_header, nfns, wd, {working directory}  path, rtpass);{root password} end; packetout(unum); packetin(unum,req_catprotect); end; (****************************************************************************) procedure changeprotectpack(unum : unitnum;  nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type;  nps : integer; psaptr : ppsa); begin with packet_ptr.schangeprotect^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; ppsa(addr(pnsa(addr(start_name_sets))^[nfns+1]))^ := psaptr^; setup_smh(send_mess_header, size_to_changeprotect+nfns*36+nps*24, req_changeprotect, 0); setup_vnh(volume_name_header,unum); setup_fnh(file_name_header, nfns,  wd, {working directory} path, rtpass);{root password} num_protect_code_sets := nps; end; packetout(unum); packetin(unum,req_changeprotect); end; (****************************************************************************) procedure changevolpack(unum : unitnum; vpass : name_type; newname : name_type; newpass : name_type); begin with packet_ptr.schangevolume^ do begin setup_smh(send_mess_header, size_to_change_vol_label, req_label, 0); setup_vnh(volume_name_header,unum); password := vpass; new  _volume_name := newname; new_vol_password := newpass; end; packetout(unum); packetin(unum,req_label); end; (****************************************************************************) procedure closepack(unum : unitnum;  fid : file_id_type); begin with packet_ptr.sclose^ do begin setup_smh(send_mess_header, size_to_close, req_close, 0); file_id := fid; directory_password:= ' '; file_password := ' '; filler5.i := 0; nodeallocate.i := 0; end; packetout(unum); packetin(unum,req_close); end; (****************************************************************************) procedure copypack(unum : unitnum; srcfid : file_id_type; srcoff : integer; destfid : file_id_type; destoff : integer; req : integer); begin with packet_ptr.scopy^ do begin setup_smh(send_mess_header, size_to_copy, req_copy, 0); source_file_id := srcfid; source_offset := srcoff; destination_file_id := destfid; destination_offset := destoff; requested := req; end; packetout(unum); packetin(unum,req_copy); end; (****************************************************************************) procedure createpack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass  : name_type; nps : integer; psaptr : ppsa; ftype : gang_file_codes; mode : integer; maxrec : integer;  ext1 : integer; ext2 : integer; xaddr : integer); begin with packet_ptr.screatefile^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; if nps > 0 then ppsa(addr(pnsa(addr(start_name_sets))^[nfns+1]))^ := psaptr^; setup_smh(send_mess_header, size_to_create+nfns*36+nps*24, req_create, 0); setup_vnh(volume_name_header,unum); setup_fnh(file_name_header,  nfns, wd, {working directory} path, rtpass);{root password} file_code := ftype; record_mode := mode; max_record_size := maxrec;  first_extent := ext1; contiguous_first_extent.i := 0; {false} secondary_extent := ext2; max_file_size := maxint; boot_start_address := xaddr; num_protect_code_sets := nps; label_included_flag.i := 0; {false} end; packetout(unum); packetin(unum,req_create); end; (****************************************************************************) procedure createlinkpack(unum : unitnum;  oldnfns : integer; oldnsaptr : pnsa; oldpath : path_start_type; oldwd : file_id_type; oldrtpass : name_type; newnfns : integer; newnsaptr : pnsa; newpath : path_start_type; newwd : file_id_type; newrtpass : name_type; purgeold : boolean); begin with packet_ptr.screatelink^ do begin pnsa(addr(start_name_sets))^ := oldnsaptr^; pnsa(addr(pnsa(addr(start_name_sets))^[oldnfns+1]))^ := newnsaptr^; set  up_smh(send_mess_header, size_to_createlink+oldnfns*36+newnfns*36, req_createlink, 0); setup_vnh(volume_name_header,unum); setup_fnh(old_file_name_header, oldnfns,  oldwd, {working directory} oldpath, oldrtpass);{root password} setup_fnh(new_file_name_header, newnfns, newwd, {working directory} newpath, newrtpass);{root password} purge_old_link.i := ord(purgeold); end; packetout(unum); packetin(unum,req_createlink); end; (****************************************************************************) procedure exchangepack(unum : unitnum; fid1 : file_id_type; fid2 : file_id_type); begin with packet_ptr.sexchange^ do begin setup_smh(send_mess_header, size_to_xchg_open,  req_xchg_open, 0); file_id_1 := fid1; file_id_2 := fid2; end; packetout(unum); packetin(unum,req_xchg_open); end; (****************************************************************************) procedure fileinfopack(unum : unitnum; fid : file_id_type); begin with packet_ptr.sfileinfo^ do begin setup_smh(send_mess_header, size_to_info, req_info, 0); implicit_unlock.i := 1; file_id := fid; end; packetout(unum); packetin(unum,req_info); end; (****************************************************************************) procedure gangcleanpack(unum : unitnum; savewd : boolean); begin with packet_ptr.sgangclean^ do begin setup_smh(send_mess_header, size_to_gang_cleanup, req_gang_cleanup, 0); keep_protected_directories.i := ord(savewd);  end; packetout(unum); end; (****************************************************************************) procedure lockpack(unum : unitnum; fid : file_id_type; wait : boolean); begin waitingforlock := wait; with packet_ptr.slock^ do begin setup_smh(send_mess_header, size_to_flock, req_flock, 0); file_id := fid; wait_for_lock.i := ord(wait); end;  packetout(unum); packetin(unum,req_flock); end; (****************************************************************************) procedure openpack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; rtpass : name_type; share : integer; opn : gang_open_type); begin with packet_ptr.sopen^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; setup_smh(send_mess_header, size_to_open+nfns*36, req_open, 0); setup_vnh(volume_name_header,unum); setup_fnh(file_name_header, nfns, wd, {working directory} path, rtpass);{root password} filler2 := 0; filler3 := 0; share_code := share; filler4.id  := 0; filler1 := 0; open_type := opn; end; packetout(unum); packetin(unum,req_open); end; (****************************************************************************) procedure pospack(unum : unitnum; fid : file_id_type; typepos : position_type; boffset : integer); begin with packet_ptr.spos^ do begin setup_smh(send_mess_header, size_to_position,    req_position, 0); implicit_unlock.i := 1; file_id := fid; filler3 := 0; type_of_position := typepos; byte_offset := boffset; end; packetout(unum); packetin(unum,req_position); end; (****************************************************************************) procedure purgepack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type;  wd : file_id_type; rtpass : name_type); begin with packet_ptr.spurge^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; setup_smh(send_mess_header, size_to_purge+nfns*36, req_purgelink, 0); setup_vnh(volume_name_header,unum); setup_fnh(file_name_header, nfns, wd, {working directory} path, rtpass);{root password} end; packetout(unum); packetin(unum,req_purgelink); end; (****************************************************************************) procedure sendreadpack(unum : unitnum; fid : file_id_type;  access : integer; req : integer; off : integer; dat : anyptr); begin with packet_ptr.sread^ do begin setup_smh(send_mess_header, size_to_read, req_read, integer(dat)); implicit_unlock.i := 1; file_id := fid; access_code := access; filler3[1] := 0; filler3[2] := 0; requested := req; offset := off; end; packetout(unum); end; (****************************************************************************) procedure seteofpack(unum : unitnum; fid : file_id_type;  usecurptr : boolean; boffset : integer); begin with packet_ptr.sseteof^ do begin setup_smh(send_mess_header, size_to_set_eof, req_set_eof, 0); implicit_unlock.i := 1; file_id := fid; use_current_ptr.i := ord(usecurptr); byte_offset := boffset; end; packetout(unum); packetin(unum,req_set_eof); end; (****************************************************************************) procedure unlockpack(unum : unitnum; fid : file_id_type); begin with packet_ptr.sunlock^ do begin setup_smh(send_mess_header, size_to_funlock, req_funlock, 0); file_id := fid; explicit_unlock.i := ord(true); end; packetout(unum); packetin(unum,req_funlock); end; (****************************************************************************) procedure volpack(unum : unitnum); begin with packet_ptr.svol^ do begin setup_smh(send_mess_header, size_to_volstatus, req_volstatus, 0); setup_vnh(volume_name_header,unum); end; packetout(unum); packetin(unum,req_volstatus); end; (****************************************************************************) procedure sendwritepack(unum : unitnum; fid : file_id_type; access : integer; req : integer; off : integer; dat : anyptr); begin with packet_ptr.swrite^ do begin setup_smh(send_mess_header, size_to_write + req, req_write,  integer(dat)); implicit_unlock.i := 1; file_id := fid; access_code := access; filler3[1] := 0; filler3[2] := 0; requested := req; offset := off; filler8.  i := 0; flush_buffer.i := 1; moveleft(charptr(dat)^,data,req); end; packetout(unum); end; (****************************************************************************) {INTERNAL ONLY BEGIN} { Added for SRM-UX : } procedure chmodpack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; fid : file_id_type; rtpass : name_type; nmode : integer); var nsap : pnsa; var nsa : name_set_array; var i : integer; begin { Set up the packet, and send it : } with packet_ptr.schmod^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; setup_smh(send_mess_header, size_to_hfs_chmod + 36*nfns, req_hfs_chmod, 0); setup_vnh(volume_name_header.old_header,unum); setup_fnh(file_name_header,nfns,wd,path,rtpass); volume_name_header.delta_mask := hex('fffffe00'); { ???????????? } volume_name_header.ordinary_perm := nmode; { ?????????? } volume_name_header.dir_perm := nmode; { ?????????? } end; packetout(unum); packetin(unum,req_hfs_chmod); end; procedure chownpack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type; fid : file_id_type;  rtpass : name_type; nmode : integer); begin { Set up the packet, and send it : } with packet_ptr.schown^ do begin pnsa(addr(start_name_sets))^ := nsaptr^; setup_smh(send_mess_header,  size_to_hfs_chown + 36*nfns, req_hfs_chown, 0); setup_vnh(volume_name_header.old_header,unum); setup_fnh(file_name_header,nfns,wd,path,rtpass); volume_name_header.new_owner := nmode; end; packetout(unum); packetin(unum,req_hfs_chown); end; procedure chgrppack(unum : unitnum; nfns : integer; nsaptr : pnsa; path : path_start_type; wd : file_id_type;  fid : file_id_type; rtpass : name_type; nmode : integer); begin { Set up the packet, and send it : } with packet_ptr.schgrp^ do begin pnsa(addr(start_name_sets))^ := nsaptr^;  setup_smh(send_mess_header, size_to_hfs_chgrp + 36*nfns, req_hfs_chgrp, 0); setup_vnh(volume_name_header.old_header,unum); setup_fnh(file_name_header,nfns,wd,path,rtpass); volume_name_header.new_owner := nmode; end; packetout(unum); packetin(unum,req_hfs_chgrp); end; procedure rmtexecpack(unum : unitnum; path : path_start_type; wd : file_id_type; { working directory }  rtpass : name_type; cmdstring : anyptr; cmdstringlen : integer); type cp = ^char; var i : integer; begin with packet_ptr.srmtexec^ do begin setup_smh(send_mess_header, size_to_rmt_exec + cmdstringlen, req_rmt_exec, 0); setup_vnh(volume_name_header,unum); cmd_size := cmdstringlen; directory_id := wd; filler1  := 0; path_type := path; volume_pword := rtpass; spare1 := 0; spare2 := 0; moveleft(cp(cmdstring)^,cmd,cmdstringlen); end; packetout(unum); packetin(unum,req_rmt_exec); end; function is_srmux_unit(unum : unitnum) : boolean; begin is_srmux_unit := srmux_on[unum]; end; {INTERNAL ONLY END} (****************************************************************************) end{module srm}.    (* (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 *) $copyright 'COPYRIGHT (C) 1983 BY HEWLETT-PACKARD COMPANY'$ $range off$ $debug off$ $modcal$ $ALLOW_PACKED ON$ { JWS 4/10/85 } program init_srm {INTERNAL ONLY BEGIN} (INPUT,OUTPUT) {INTERNAL ONLY END} ; module srmdammodule; {{ $SEARCH 'SRM_DRV', 'IOLIB:KERNEL' {INTERNAL ONLY BEGIN} { ,'LANSRM','IOLIB:LANDECS' } {INTERNAL ONLY END} {} $SEARCH 'SRM_DRV', 'LANSRM','LANDECS'$ {} import sysglobals, misc, bootdammodule, iodeclarations, {INTERNAL ONLY BEGIN} lansrm, landecs, {INTERNAL ONLY END} srm {INTERNAL ONLY BEGIN} ,asm {INTERNAL ONLY END} ; export procedure srmdaminit; procedure srmdam(anyvar f : fib;  unum : unitnum; request : damrequesttype); { SRM/UX TESTING ONLY !!! } { procedure reset_counters; procedure show_counter_values; function srmux_mapfkind(ftype : gang_file_codes) : filekind; } implement type passarray = array[1..8] of passentry; const extentsize = 8*512; {arbitrary choice -- multiple of common block sizes} constpassarray= passarray[ passentry[pbits:hex('80000000'),pword:'MANAGER' ],  passentry[pbits:hex('40000000'),pword:'READ' ], passentry[pbits:hex('20000000'),pword:'WRITE' ], passentry[pbits:hex('10000000'),pword:'SEARCH' ], passentry[pbits:hex('08000000'),pword:'PURGELINK' ], passentry[pbits:hex('04000000'),pword:'CREATELINK'], passentry[pbits:hex('FFFFFFFF'),pword:'ALL' ], passentry[pbits:hex('00000000'),pword:'NONE' ] ]; allcapabilities = access_capabilities[32 of true]; nocapabilities = access_capabilities[32 of false]; temp_file_pass = '>TEMP_FILE_PASS<'; {password on temporary files} BDATTYPE = -5791; BDATTYPE_500 = -5663; { fix for BDAT 500 file } BASICBINTYPE = -5775; BASICPROGTYPE = -5808; SYSTMTYPE = -5822; DATATYPE = -5622; CODETYPE = -5582; TEXTTYPE = -5570; {INTERNAL ONLY BEGIN} { Added for SRM/UX : } PIPETYPE = -5812; BDEVTYPE = -5811; CDEVTYPE = -5810; MISCTYPE = -5809; NETTYPE = -5806; SOCKTYPE = -5805; {INTERNAL ONLY END} var passwordarrayptr : ^passarray; tempcounter : shortint; {=================================================} { TESTING ONLY !!!!!!!!!! } { procedure reset_counters; var i : damrequesttype; begin for i := getvolumename to openunit do usage_array[i] := 0; end; procedure show_counter_values; var i : damrequesttype; var c : char; begin for i := getvolumename to openunit do begin writeln(i,' request made ',usage_array[i] : 6,' times.'); if i = closefile then read(c); if i = catalog then read(c); end; end; procedure log_srmdam_request(req : damrequesttype); begin usage_array[req] := usage_array[req] + 1; end; } {=================================================} (****************************************************************************) procedure setioresult(result : integer); begin  if ioresult = ord(inoerror) then ioresult := result; end; (****************************************************************************) function mapfkind(ftype : gang_file_codes) : filekind; var fk: filekind; begin mapfkind := datafile; f  or fk := lastfkind downto untypedfile do if efttable^[fk] = ftype.si2 then mapfkind := fk; end; (****************************************************************************) function srmux_mapfkind(ftype : gang_file_codes) : filekind; LABEL 1; var fk: filekind; assigned : boolean; what : shortint; begin srmux_mapfkind := datafile; assigned := false; for fk := lastfkind downto untypedfile do if efttable^[fk] = ftype.si2 then begin srmux_mapfkind := fk; assigned := true; end; if not assigned then { just defaulted to datafile - do something ! } begin what := ftype.si2; { Pipetype : } if what = -5812 then begin srmux_mapfkind := fkind9; GOTO 1; end; { Bdevtype : } if what = -5811 then begin srmux_mapfkind := fkind10; GOTO 1; end; { Cdevtype : } if what = -5810 then begin srmux_mapfkind := fkind11; GOTO 1; end; { Othertype : } if what = -5809 then begin srmux_mapfkind := fkind12; GOTO 1; end; { Nettype : } if what = -5806 then begin srmux_mapfkind := fkind13; GOTO 1; end; { Socktype : } if what = -5805 then begin srmux_mapfkind := fkind14; GOTO 1; end; { Otherwise just leave it alone } end; 1: end; (****************************************************************************) procedure paoc16tostr(anyvar paoc : name_type; anyvar strng : string255); var i : shortint; begin i := sizeof(paoc); while (paoc[i] = ' ') and (i > 0) do i := i - 1; setstrlen(strng,0); strmove(i,paoc,1,strng,1); end; (****************************************************************************) procedure strtopaoc16(anyvar strng : string255; anyvar paoc : name_type); begin paoc := ' '; if strlen(strng) < 17 then strmove(strlen(strng),strng,1,paoc,1); end; (****************************************************************************) procedure setup_fns(var f : fib; anyvar fns : file_name_set); begin with f, fns do if strlen(ftid) = 0 then setioresult(ord(ibadtitle)) else begin strtopaoc16(ftid,file_name); strtopaoc16(ffpw,password) end; end; (****************************************************************************) procedure setup_fns3(var f : fib; anyvar nsa : name_set_array_three); var n : integer; tempioresult : integer; tempstr : string[16]; begin with f do if (not fisnew) or fnosrmtemp then setup_fns(f,nsa) else if (strlen(ftid) = 0) and (not fanonymous) then setioresult(ord(ibadtitle)) else begin with nsa[1] do begin password := ' ';  file_name := 'WORKSTATIONS'; end; with nsa[2] do begin password := ' '; file_name := 'TEMP_FILES'; end; with nsa[3] do begin password  := temp_file_pass; setstrlen(tempstr,0); tempioresult := ioresult; strwrite(tempstr,1,n,srmnode(unitable^[funit].sc),'_',fanonctr:1); ioresult := tempioresult; strtopaoc16(tempstr,file_name); end; end; end; (****************************************************************************) procedure check_protectcode_set_array( nps : integer; var psa : protectcode_set_array); { 9-May-1983 RAM This routine has been added to check for right angle brackets ('>') in passwords. If any are found, ioresult is set to ord(ibadpass). This is because the parsing routines normally used with file opens terminate passwords at the first '>', therefore it is not possible to use them in passwords in normal operation. If they are really desired, they can still be created by calling the lower level packet routines directly. Note that temporary files still have an "illegal" passwo rd. This routine is called from srm_create_file and from srm_set_pass. } var n : integer; i : integer; begin for n := 1 to nps do for i := 1 to name_type_len do if psa[n].password[i] = '>' then setioresult(ord(ibadpass)); end; (****************************************************************************) procedure parseoptparm( foptstring : string255ptr; var sharemode : integer; var lockable : boolean;  var nps : integer; var psa : protectcode_set_array; modeonly : boolean); type tokentype = (none,mode,pass,cap); statetype = (needmodeorpass,needpass,needcap); acstrarrtype = array [ac_manager .. ac_createlink] of string[10]; const tokenlen = 16; acstrarray = acstrarrtype['MANAGER','READ','WRITE', 'SEARCH','PURGELINK','CREATELINK']; var typeoftoken : tokentype; state : statetype; sindx : integer; delim : char; ac : ac_manager..ac_createlink; token : string[16]; ok : boolean; procedure getuntildelim(del1 : char; del2 : char); var startindx : integer; begin delim := chr(0); startindx := sindx; while (sindx <= strlen(foptstring^)) and (delim = chr(0)) do if (foptstring^[sindx] <> del1) and (foptstring^[sindx] <> del2) then sindx := sindx + 1 else delim := foptstring^[sindx]; if (sindx - startindx) <= tokenlen then token := str(foptstring^,startindx,sindx - startindx) else setioresult(ord(ibadvalue)); if sindx <= strlen(foptstring^) then sindx  := sindx + 1; end; begin {parseoptparm} sharemode := exclusive_share_code; lockable := false; state := needmodeorpass; nps := 0; sindx := 1; if foptstring <> nil then while (sindx <= strlen(foptstring^)) and (ioresult = ord(inoerror)) do begin case state of needmodeorpass: begin getuntildelim(',', ':'); if delim = ':' then begin typeoftoken := pass; state := needcap; end else begin typeoftoken  := mode; state := needpass; end; if modeonly then sindx := strlen(foptstring^) + 1; end; needpass : begin getuntildelim(':', ':'); if delim = ':' then begin typeoftoken := pass; state := needcap; end else setioresult(ord(ibadvalue)); end; needcap : begin getuntildelim(',', ';');  typeoftoken := cap; if delim = ',' then state := needcap else if delim = ';' then state := needpass; end;  end; {case} if ioresult = ord(inoerror) then case typeoftoken of mode : begin upc(token); if token = 'EXCLUSIVE' then sharemode := exclusive_share_code else if token = 'SHARED' then sharemode := shared_share_code else if token = 'LOCKABLE' then begin sharemode := shared_share_code;   lockable := true; end else setioresult(ord(ibadvalue)); end; pass : begin nps := nps + 1;  with psa[nps] do begin strtopaoc16(token,password); capabilities := nocapabilities; end; end; cap : begin  upc(token); ok := false; with psa[nps] do if token = 'ALL' then begin capabilities := allcapabilities;  ok := true; end else for ac := ac_manager to ac_createlink do if token = acstrarray[ac] then begin  capabilities[ac] := true; ok := true; end; if not ok then setioresult(ord(ibadvalue)); end; end;  end; end; (****************************************************************************) procedure srm_close_fileid(unum : unitnum; var fileid : integer); begin if fileid = 0 then fileid := -1 else if (fileid > 0) and (fileid <> unitable^[unum].dvrtemp) then with packet_ptr.rhead^ do begin closepack(unum,fileid); if status = 0 then fileid := -1; end; end; (****************************************************************************) procedure srm_close_pathid(unum : unitnum; var pathid : integer; savepathid : boolean); begin if not savepathid then srm_close_fileid(unum,pathid); end; (****************************************************************************) procedure translatedate(var srmdate : date_type; var systemdate : daterec; var systemtime : timerec); var time  : integer; begin with srmdate do begin with systemdate do begin month := date.month; day := date.day; year := date.year; {RDQ 21MAR88 map 0..27 to 100..127}  if year < 28 then year := year + 100; end; with systemtime do begin time := seconds_since_midnight; hour := time div 3600; minute := (time-(hour*3600)) div 60; centisecond := (time mod 60) * 100; end; end; end; (****************************************************************************) procedure srm_get_dir_info(anyvar dircatentry : catentry; var dirid : integer; unum : unitnum; long : boolean; dir_is_dvrtemp: boolean); const zerodate = daterec[year:0,day:0,month:0]; zerotime = timerec[hour:0,minute:0,centisecond:0]; var n : integer; tempioresult : integer; begin with dircatentry, unitable^[unum] do begin setstrlen(cname,0); volpack(unum); with packet_ptr.rvol^, packet_ptr.rhead^ do begin if status = 0 then if not exist { .value } then { Changed for SRM-UX } setioresult(ord(ilostunit)) {set ioresult to no volume} else begin paoc16tostr(volume_name,cname);  cextra1 := -1; {max_file_size div 32} cpsize := -1; clsize := -1; cextra2 := interleave; cstart := -1; cblocksize  := 1; ccreatedate := zerodate; ccreatetime := zerotime; clastdate := zerodate; clasttime := zerotime; setstrlen(cinfo,0); tempioresult := ioresult; { Changed for SRM-UX : } {INTERNAL ONLY BEGIN} if is_srmux_unit(unum) then strwrite(cinfo,1,n,'SRM/UX ',sc:1,',',ba:1,',',du:1) else {INTERNAL ONLY END} strwrite(cinfo,1,n,'SRM ',sc:1,',',ba:1,',',du:1); ioresult := tempioresult; if dirid > 0 then begin fileinfopack(unum,dirid); with packet_ptr.rfileinfo^, file_info do if status <> 0 then begin ioresult := tempioresult; if dir_is_dvrtemp then dirid := 0; end  else begin if file_name <> ' ' then paoc16tostr(file_name,cname); if long then begin translatedate(creation_date,ccreatedate,ccreatetime); translatedate(last_access_date,clastdate,clasttime); end; end; end; end; end;  end; end; (****************************************************************************) procedure srm_get_vol_name(anyvar f : vid; unum : unitnum); var dircatentry : catentry; begin srm_get_dir_info(dircatentry,unitable^[unum].dvrtemp,unum,false,true); f := dircatentry.cname; end; (****************************************************************************) procedure srm_set_pass(anyvar f : fib; unum : unitnum); type catarray = array[0..maxint] of passentry; catarrayptr = ^catarray; var volpass : name_type; fns : file_name_set; nps : integer; done : boolean; i : integer; j : integer; catindx : integer; catentryindx : integer; tempcapbits : record case boolean of true : (i : integer); false : (b : access_capabilities); end; psa : protectcode_set_array; begin with f do begin setup_fns(f,fns); if ioresult = ord(inoerror) then begin for i := 1 to fpeof do with psa[i], catarrayptr(fwindow)^[i-1] do begin strtopaoc16(pword,password); tempcapbits.i := pbits; capabilities := tempcapbits.b; nps := i; end; strtopaoc16(fvid,volpass); check_protectcode_set_array(nps,psa); if ioresult = ord(inoerror) then changeprotectpack(unum,1,addr(fns),start_alternate,pathid, volpass,nps,addr(psa)); end; end; end; (****************************************************************************) procedure srm_cat_pass(anyvar f : fib; unum : unitnum); type catarray = array[0..maxint] of passentry; catarrayptr = ^catarray; var volpass : name_type; fns : file_name_set; done : boolean; i : integer; j : integer; catindx : integer; catentryindx : integer; tempcapbits : record case boolean of true : (i : integer); false : (b : access_capabilities); end; begin catentryindx := 0; done := false; with f, packet_ptr.rcatpass^ do begin setup_fns(f, fns); if ioresult = ord(inoerror) then begin strtopaoc16(fvid,volpass); fop tstring := anyptr(passwordarrayptr); catindx := fpos + 1; while (catentryindx < fpeof) and (not done) and (ioresult = ord(inoerror)) do begin catpasspack(unum,1,addr(fns),start_alternate,  pathid,volpass,24,catindx); if ioresult = ord(inoerror) then begin i := 1; if actual_num_passwords < 24 then done := true; while i <= actual_num_passwords do if catentryindx < fpeof then begin with password_info[i], catarrayptr(fwindow)^[catentryindx] do begin paoc16tostr(password,pword); tempcapbits.b := capabilities; pbits := tempcapbits.i; end; i := i + 1; catentryindx := catentryindx + 1; end else begin i := 25; done := true; end; catindx := catindx + 24;  end; end; end; fpeof := catentryindx; end; end; (****************************************************************************) procedure srm_catalog(anyvar f : fib; unum : unitnum); type catarray = array[0..maxint] of catentry; catarrayptr = ^catarray; ac_char_arr = array [ac_manager..ac_createlink] of char; const ac_chars = ac_char_arr['M','R','W','S','P','C']; var volpass : name_type; fns  : file_name_set; done : boolean; i : integer; j : integer; catindx : integer; catentryindx : integer; ac : access_code_type; temp_num : integer; { Added for SRM-UX } leading : boolean; begin catentryindx := 0; done := false; with f, packet_ptr.rcat^ do begin strtopaoc16(fvid,volpass); catindx := fpos + 1; while (catentryindx < fpeof) and not done do begin catpack(unum,0,addr(fns),start_alternate, pathid,volpass,7,catindx); if ioresult <> ord(inoerror) then done := true else begin i := 1; if actual_num_files < 7 then done := true; while i <= actual_num_files do if catentryindx < fpeof then begin with cat_info[i], catarrayptr(fwindow)^[catentryindx] do begin  paoc16tostr(file_name,cname); {=============================================================} if is_srmux_unit(unum) then begin ceft := file_code.si2;  ckind := srmux_mapfkind(file_code); end {=============================================================} else { same as before } begin  ceft := file_code.si2; ckind := mapfkind(file_code); end; cpsize := physical_size; clsize := logical_eof;  cstart := -1; translatedate(creation_date,ccreatedate,ccreatetime); translatedate(last_access_date,clastdate,clasttime); cblocksize:= -1; cextra1 := -1;  cextra2 := -1; if not is_srmux_unit(unum) then begin setstrlen(cinfo,ord(ac_createlink)+1); for ac := ac_manager to ac_createlink  do if capabilities[ac] then cinfo[ord(ac) + 1] := ac_chars[ac] else cinfo[ord(ac) + 1] := ' '; case share_code of exclusive_share_code : cinfo := cinfo + ' EXCLUSIVE'; shared_share_code : cinfo := cinfo + ' SHARED'; { closed_share_code : cinfo := cinfo + ' CLOSED'; } corrupt_share_code : cinfo := cinfo + ' CORRUPT'; otherwise cinfo := cinfo + ' CLOSED'; end; { CASE }  end { Not an SRM-UX unit } else begin { Is an SRM-UX unit } setstrlen(cinfo,17); { SRM-UX size needed } { Initialize to no permissions : } cinfo[1] := ' '; { for now } if ckind = untypedfile then cinfo[1] := 'd'; { for now } cinfo[2] := '0'; cinfo[3] := '0'; cinfo[4] := '0';  cinfo[5] := 'm'; {===========================================================================} { Handle the special Hp-ux files that could show up for an SRM/UX user : } { Put an appropriate character in front of the mode, set the type and } { kind to 0. This is what the HFSDAM does now when we encounter a file of } { one of these types on an HFS disk shared with HP/UX. } case ckind of fkind9 : begin  cinfo[1] := 'p'; { Pipe } ceft := 0; ckind := fkind8; { 0 } end; fkind10 : begin cinfo[1] := 'b'; { Bdev } ceft := 0; ckind := fkind8; { 0 } end;  fkind11 : begin cinfo[1] := 'c'; { Cdev } ceft := 0; ckind := fkind8; { 0 } end;  fkind12 : begin cinfo[1] := 'o'; { Other } ceft := 0; ckind := fkind8; { 0 } end; fkind13 : begin cinfo[1] := 'n'; { Network } ceft := 0; ckind := fkind8; { 0 }  end; fkind14 : begin cinfo[1] := 's'; { Socket } ceft := 0; ckind := fkind8; { 0 }  end; otherwise ; { do nothing } end; { case } {===========================================================================} { Just set the darn things brute force, there is no need to be cute : } temp_num := 0; if capabilities[ac_owner_r] then temp_num := temp_num + 4;  if capabilities[ac_owner_w] then temp_num := temp_num + 2; if capabilities[ac_owner_x] then temp_num := temp_num + 1; if temp_num > 0 then   cinfo[2] := chr(ord('0') + temp_num); temp_num := 0; if capabilities[ac_group_r] then temp_num := temp_num + 4; if capabilities[ac_group_w] then temp_num := temp_num + 2; if capabilities[ac_group_x] then temp_num := temp_num + 1; if temp_num > 0 then cinfo[3] := chr(ord('0') + temp_num); temp_num := 0; if capabilities[ac_other_r] then temp_num := temp_num + 4; if capabilities[ac_other_w] then  temp_num := temp_num + 2; if capabilities[ac_other_x] then temp_num := temp_num + 1; if temp_num > 0 then cinfo[4] := chr(ord('0') + temp_num); { Keep filling in cinfo fields ... : } temp_num := creation_date.id; { has uid now } leading := true; cinfo[6] := chr(ord('0') + temp_num div 10000); if (cinfo[6] = '0') then cinfo[6] := ' ' else leading := false; cinfo[7] := chr(ord('0') +  (temp_num div 1000) mod 10); if ((cinfo[7] = '0') and leading) then cinfo[7] := ' ' else leading := false;  cinfo[8] := chr(ord('0') + (temp_num div 100) mod 10); if ((cinfo[8] = '0') and leading) then cinfo[8] := ' ' else  leading := false; cinfo[9] := chr(ord('0') + (temp_num div 10) mod 10); if ((cinfo[9] = '0') and leading) then  cinfo[9] := ' ' else leading := false; cinfo[10] := chr(ord('0') + temp_num mod 10); cinfo[11] := 'u';  temp_num := last_access_date.id; { has gid now } leading := true; cinfo[12] := chr(ord('0') + temp_num div 10000); if (cinfo[12] = '0') then  cinfo[12] := ' ' else leading := false; cinfo[13] := chr(ord('0') + (temp_num div 1000) mod 10);  if ((cinfo[13] = '0') and leading) then cinfo[13] := ' ' else leading := false; cinfo[14] := chr(ord('0') +  (temp_num div 100) mod 10); if ((cinfo[14] = '0') and leading) then cinfo[14] := ' ' else leading := false; cinfo[15] := chr(ord('0') + (temp_num div 10) mod 10); if ((cinfo[15] = '0') and leading) then cinfo[15] := ' ' else  leading := false; cinfo[16] := chr(ord('0') + temp_num mod 10); cinfo[17] := 'g'; case share_code of   exclusive_share_code : cinfo := cinfo + ' EX'; shared_share_code : cinfo := cinfo + ' SH'; corrupt_share_code : cinfo := cinfo + ' CO'; otherwise  cinfo := cinfo + ' CL'; end; { CASE } end; { Is an SRM-UX unit } end; i := i + 1; catentryindx := catentryindx + 1; end  else begin i := 8; done := true; end; catindx := catindx + 7; end; end; fpeof := catentryindx; end; end; { srm_catalog } (****************************************************************************) procedure srm_open_dir(anyvar f : fib; unum : unitnum; opentype : gang_open_type;  openparent:boolean); var volpass : name_type; lentitle : integer; sindx : integer; pindx : integer; nindx : integer; i : integer; path : path_start_type; saveid  : file_id_type; origpathid : file_id_type; last : boolean; alreadyopen : boolean; nfns : integer; nsa : name_set_array; procedure getpaoc(anyvar paoc : name_type; del1 : char;  del2 : char); var done : boolean; begin with f do begin done := false; while (sindx <= lentitle) and (pindx <= name_type_len) and (not done) do if (ftitle[sindx] = del1) or (ftitle[sindx] = del2) then  done := true else begin paoc[pindx] := ftitle[sindx]; pindx := pindx + 1; sindx := sindx + 1; end; if (sindx > lentitle) then begin  if del1 = '>' then ioresult := ord(ibadpass); end else begin if (ftitle[sindx] <> del1) and (ftitle[sindx] <> del2) then begin if del1 = '>' then ioresult := ord(ibadpass) else ioresult := ord(ibadtitle); end else if (del1 = '>') then if (ftitle[sindx] <> '>') then ioresult := ord(ibadpass); end; end; end; begin last := false; alreadyopen := false; sindx := 1; with f do begin origpathid := pathid; lentitle := strlen(ftitle); setstrlen(ftid,0); if pathid = -1 then begin setstrlen(fvid,0); setstrlen(ffpw,0); end; if (sindx <= lentitle) then if ftitle[sindx] = '<' then {get volume password} begin sindx := sindx + 1; pindx := 1; volpass := ' '; getpaoc(volpass,'>','>'); paoc16tostr(volpass,fvid); sindx := sindx + 1; end; path := start_alternate; if ioresult = ord(inoerror) then if (sindx <= lentitle) then if ftitle[sindx] = '/' then begin path := start_root; sindx := sindx + 1; end; if pathid = -1 then if path = start_root then pathid := 0 else pathid := unitable^[unum].dvrtemp; if sindx > lentitle then begin last := true; setstrlen(ftitle,0); end else if (ftitle[lentitle] = '/') then setioresult(ord(ibadtitle)); with packet_ptr.ropen^ do while (not last) and (ioresult = ord(inoerror)) do begin nfns := 0; while (sindx <= lentitle) and (nfns < 6) and (ioresult = ord(inoerror)) do begin with nsa[nfns+1] do   begin if (ftitle[sindx] = '/') then ioresult := ord(ibadtitle) else begin file_name := ' '; password := ' '; pindx := 1; getpaoc(file_name,'<','/'); nindx := pindx; if ioresult = ord(inoerror) then if (sindx <= lentitle) then if (ftitle[sindx] = '<') then begin sindx := sindx + 1; pindx := 1; getpaoc(password,'>','>'); sindx := sindx + 1; if sindx <= lentitle then if ftitle[sindx] <> '/' then if nindx > lentitle then  ioresult := ord(ibadtitle) else begin pindx := nindx; getpaoc(file_name,'/','/'); end; end; if ioresult = ord(inoerror) then if (sindx > lentitle) then begin last := true; setstrlen(ftitle,0); end; end; end; if ioresult = ord(inoerror) then nfns := nfns + 1; sindx  := sindx + 1; end; if ioresult = ord(inoerror) then begin if not (last and openparent) then begin openpack(unum,nfns,addr(nsa),path,  pathid,volpass,shared_share_code,opentype); if ioresult <> ord(inoerror) then begin if last then begin ioresult := ord(inoerror);  openparent := true; end; end else begin saveid := file_id; if alreadyopen then  srm_close_pathid(unum,pathid,false) else alreadyopen := true; pathid := saveid; path := start_alternate;  end; end; if ioresult = ord(inoerror) then begin if last and openparent then begin if (nfns <= 1) then begin if pathid = -1 then setioresult(ord(inodirectory)); end else begin openpack(unum,nfns-1,addr(nsa),path, pathid,volpass,shared_share_code,opentype); if ioresult <> ord(inoerror) then begin if alreadyopen then  srm_close_pathid(unum,pathid,false); end else begin saveid := file_id; if alreadyopen then srm_close_pathid(unum,pathid,false); pathid := saveid; end; end; if ioresult = ord(inoerr or) then with nsa[nfns] do begin paoc16tostr(file_name,ftid); ftitle := ftid; if password <> ' ' then  paoc16tostr(password,ffpw); end; end; end; end; end; if ((origpathid <> -1) and (origpathid = pathid)) or (pathid = unitable^[unum].dvrtemp) then fsavepathid := true else fsavepathid := false; end; end; (****************************************************************************) procedure srm_set_unit_prefix(anyvar f : fib;  unum : unitnum); var savpathid : integer; begin with f, unitable^[unum] do begin srm_open_dir(f,unum,open_protected_directory,false); if ioresult = ord(inoerror) then begin if strlen(ftitle) > 0 then setioresult(ord(inounit)) else begin savpathid := pathid; pathid := dvrtemp; dvrtemp := savpathid; end; srm_close_pathid(unum,pathid,false); end; srm_get_vol_name(uvid,unum); end; end; (****************************************************************************) procedure doopenpack(unum : unitnum; var f : fib; nfns : integer; anyvar nsa : name_set_array; path : path_start_type; volpass : name_type; sharecode : integer; lockable : boolean); type trickrec  = record case boolean of true :(i : integer); false :(chs : packed array [1..2] of char; si2 : shortint); end; var temprec : trickrec; begin with f, packet_ptr.ropen^ do begin if lockable and fistextvar then setioresult(ord(inotlockable)) else openpack(unum,nfns,addr(nsa),path,pathid,volpass, sharecode,open_data);  if ioresult = ord(inoerror) then if file_code.si2 = 3 then {directory} begin setioresult(ord(inotondir)); closepack(unum,file_id); end else begin  fileid := file_id; fpeof := open_logical_eof; fleof := open_logical_eof; feft := file_code.si2; fkind := mapfkind(file_code); flockable := lockable; flocked := not lockable; {default to locked unless lockable} if (feft = BDATTYPE) {BDAT file} or (feft = BDATTYPE_500) {fix for BDAT 500 file} or (feft = BASICBINTYPE) {BIN file} or (feft = BASICPROGTYPE) then {PROG file} begin temprec.chs := ' '; temprec.si2 := max_record_size div 2; fstartaddress := temprec.i; end else fstartaddress := boot_start_address; if not fbuffered then am := amtable^[untypedfile] else if fistextvar then am := amtable^[fkind] else am := amtable^[datafile]; end; end; end; (****************************************************************************) procedure srm_open_file(anyvar f : fib;  unum : unitnum); type trickrec = record case boolean of true :(i : integer); false :(si1 : shortint; si2 : shortint); end; var volpass   : name_type; fns : file_name_set; temprec : trickrec; sharemode : integer; nps : integer; psa : protectcode_set_array; lockable : boolean; begin with f do begin setup_fns(f, fns); parseoptparm(foptstring,sharemode,lockable,nps,psa,true); if ioresult = ord(inoerror) then begin strtopaoc16(fvid,volpass); doopenpack(unum,f,1,fns,start_alternate,volpass,sharemode,lockable); end; end; end; (****************************************************************************) procedure srm_create_dir (anyvar f : fib; unum : unitnum); type catentryptr = ^catentry; const dirfilecode = gang_file_codes[i:3]; var volpass : name_type; fns : file_name_set; begin with f, catentryptr(fwindow)^ do if strlen(cname) = 0 then setioresult(ord(ibadtitle)) else begin with fns do begin password := ' '; strtopaoc16(cname,file_name); end; strtopaoc16(fvid,volpass); createpack(unum,1,addr(fns),start_alternate,pathid,volpass,0,nil, dirfilecode,directory_records,0,0,0,0); end; end; (****************************************************************************) procedure srm_create_file(anyvar f : fib; unum : unitnum); const dirfilecode = gang_file_codes[i:3]; type trickrec = record case boolean of true :(i : integer); false :(si1 : shortint; si2 : shortint); end; var volpass : name_type; nsa : name_set_array_three; ext1 : integer; temprec : trickrec; sharemode : integer; maxrec : integer; nps : integer; usefeft : gang_file_codes; psa : protectcode_set_array; i : integer; ac : ac_manager..ac_purgelink; lockable : boolean; begin with f, nsa[3] do begin strtopaoc16(fvid,volpass); repeat ioresult := ord(inoerror); fanonctr := tempcounter; tempcounter := tempcounter + 1; usefeft.i := feft; {BDAT file} {fix for BDAT 500 file} if (feft = BDATTYPE) or (feft = BDATTYPE_500) then begin temprec.i := fstartaddress; maxrec := temprec.si2 * 2; if maxrec < 1 then maxrec := 1; end else maxrec := 256; if fpos > 0 then ext1 := fpos else ext1 := extentsize; parseoptparm(foptstring,sharemode,lockable,nps,psa,false);  check_protectcode_set_array(nps,psa); if (nps > 0) and (nps < 24) and (ioresult = ord(inoerror)) then begin nps := nps + 1; with psa[nps] do begin password := temp_file_pass;  capabilities := nocapabilities; if nps > 1 then for i := 1 to nps-1 do for ac := ac_manager to ac_purgelink do if psa[i].capabilities[ac] then  capabilities[ac] := true; end; end; if (not fanonymous) and (ioresult = ord(inoerror)) then begin setup_fns(f,nsa); foldfileid := -1; openpack(unum,1,addr(nsa),start_alternate,pathid,volpass,sharemode,open_data); if ioresult = ord(inofile) then begin ioresult := ord(inoerror); nsa[1].password := ' '; createpack(unum,1,addr(nsa),start_alternate,pathid,volpass, nps,addr(psa),usefeft,data_records, maxrec,ext1,extentsize,fstartaddress); if ioresult = ord(inoerror) then if feft <> SYSTMTYPE then fnosrm temp := true else begin {SYSTM files must go through temp first} nsa[1].password := temp_file_pass; openpack(unum,1,addr(nsa),start_alternate,pathid,  volpass,sharemode,open_data); end; end; if (ioresult = ord(inoerror)) and (not fnosrmtemp) then begin foldfileid := packet_ptr.ropen^.file_id; fileinfopack(unum,foldfileid); with packet_ptr.rfileinfo^.file_info do begin if (not capabilities[ac_manager]) and (not capabilities[ac_purgelink]) then setioresult(ord(ibadpass)) {won't be able to purge old} else {this test added in version 2.2 on 4-May-83} if file_code.si2 = 3 then {disallow rewrite on directory} setioresult(ord(inotondir)); if ioresult <> ord(inoerror) then srm_close_fileid(unum,foldfileid); end; end; end; if (ioresult = ord(inoerror)) and (not fnosrmtemp) then begin setup_fns3(f,nsa); if ioresult = ord(inoerror) then begin password := ' '; createpack(unum,3,addr(nsa),start_root,pathid,volpass, nps,addr(psa),usefeft,data_records, maxrec,ext1,extentsize,fstartaddress); if ioresult = ord(inofile) then begin ioresult := ord(inoerror); createpack(unum,2,addr(nsa),start_root,pathid,volpass, 0,nil,dirfilecode,directory_records,0,0,0,0); if ioresult <> ord(inoerror) then ioresult := ord(ineedtempdir) else createpack(unum,3,addr(nsa),start_root,pathid,volpass, nps,addr(psa),usefeft,data_records, maxrec,ext1,extentsize,fstartaddress); end else if ioresult = ord(idupfile) then begin ioresult := ord(inoerror); password := temp_file_pass; purgepack(unum,3,addr(nsa),start_root,pathid,volpass); ioresult := ord(inoerror); password := ' '; createpack(unum,3,addr(nsa),start_root,pathid,volpass, nps,addr(psa),usefeft,data_records, maxrec,ext1,extentsize,fstartaddress); end; end; end; until (ioresult <> ord(idupfile)); if ioresult <> ord(inoerror) then srm_close_fileid(unum,foldfileid) else if fnosrmtemp then begin nsa[1].password := temp_file_pass; doopenpack(unum,f,1,nsa,start_alternate,volpass,sharemode,lockable); end else begin password := temp_file_pass; doopenpack(unum,f,3,nsa,start_root,volpass,exclusive_share_code,lockable); end; end; end; (****************************************************************************) procedure srm_change_name(anyvar f : fib; unum : unitnum); type fidptr = ^fid; var volpass : name_type; path1 : path_start_type; nfns1 : integer; fns1 : file_name_set; path2 : path_start_type; nfns2 : integer; fns2 : file_name_set; begin  with f, unitable^[unum] do begin srm_open_dir(f,unum,open_directory,true); if ioresult = ord(inoerror) then setup_fns(f, fns1); if ioresult = ord(inoerror) then with fns2 do begin file_name :=  ' '; password := ' '; if strpos('/',fidptr(fwindow)^) = 0 then if (strpos('<',fidptr(fwindow)^) = 0) then strtopaoc16(fidptr(fwindow)^,file_name); if file_name = ' ' then setioresult(ord(ibadtitle)); end; if ioresult = ord(inoerror) then begin strtopaoc16(fvid,volpass); createlinkpack(unum,1,addr(fns1),start_alternate,pathid,volpass, 1,addr(fns2),start_alternate,pathid,volpass,true); end; srm_close_pathid(unum,pathid,fsavepathid); end; end; (****************************************************************************) procedure srm_dup_link(anyvar f : fib;  unum : unitnum); var volpass : name_type; volpass2 : name_type; path1 : path_start_type; nfns1 : integer; fns1 : file_name_set; path2 : path_start_type; nfns2 : integer; fns2  : file_name_set; begin with f, unitable^[unum] do begin srm_open_dir(f,unum,open_directory,true); if ioresult = ord(inoerror) then setup_fns(f, fns1); if ioresult = ord(inoerror) then srm_open_dir(fibp(fwindow)^,unum,open_directory,true); if ioresult = ord(inoerror) then setup_fns(fibp(fwindow)^, fns2); if ioresult = ord(inoerror) then begin strtopaoc16(fvid,volpass); strtopaoc16(fibp(fwindow)^.fvid,volpass2);  createlinkpack(unum,1,addr(fns1),start_alternate,pathid,volpass, 1,addr(fns2),start_alternate,fibp(fwindow)^.pathid,volpass2, fpurgeoldlink); end; srm_close_pathid(unum,pathid,fsavepathid); srm_close_pathid(unum,fibp(fwindow)^.pathid,fibp(fwindow)^.fsavepathid); end; end; (****************************************************************************) procedure srm_purge_name(anyvar f : fib; unum : unitnum); var volpass : name_type; fns : file_name_set; begin with f do begin setup_fns(f, fns); if ioresult = ord(inoerror) then begin strtopaoc16(fvid,volpass); purgepack(unum,1,addr(fns),start_alternate,pathid,volpass); end; end; end; (****************************************************************************) procedure srm_purge_file(anyvar f : fib; unum : unitnum); var volpass : name_type; path : path_start_type; nfns : integer; nsa : name_set_array_three; begin with f do if (strlen(ftid) = 0) and not fisnew then setioresult(ord(ibadtitle)) else begin if fmodified then if not (flockable and not flocked) then begin seteofpack(funit,fileid,false,fleof); if ioresult = ord(ilostfile) then fileid := -1; end; if fisnew and (not fanonymous) and (not fnosrmtemp) then srm_close_fileid(unum,foldfileid); srm_close_fileid(unum,fileid); setup_fns3(f,nsa); if ioresult <> ord(ibadtitle) then begin if (fisnew) and (not fnosrmtemp) then  begin path := start_root; nfns := 3; end else begin path := start_alternate; nfns := 1; end;  strtopaoc16(fvid,volpass); if fisnew then nsa[nfns].password := temp_file_pass; purgepack(unum,nfns,addr(nsa),path,pathid,volpass); end; if not (fisnew and fanonymous) then srm_close_pathid(unum,pathid,fsavepathid); end; end; (****************************************************************************) procedure srm_stretch(anyvar f : fib; unum : unitnum); var volpass : name_ type; neweof : integer; begin with f do begin neweof := ((fpos div extentsize) + 1) * extentsize; seteofpack(funit,fileid,false,neweof); if ioresult = ord(inoerror) then begin fpeof := neweof; fmodified := true; end; end; end; (****************************************************************************) procedure srm_close_file(anyvar f : fib; unum : unitnum); var volpass : name_type; nsa1 : name_set_array_three; fns : file_name_set; tempioresult : integer; ext1 : integer; saveleof : integer; savefileid : file_id_type; usefeft : gang_file_codes; pcs  : protect_code_set; begin with f do begin if fmodified then if not (flockable and not flocked) then begin seteofpack(funit,fileid,false,fleof); if ioresult = ord(ilostfile) then fileid := -1; end; if not fisnew then srm_close_fileid(unum,fileid) else if ioresult <> ord(inoerror) then srm_purge_file(f,unum) else begin strtopaoc16(fvid,volpass); setup_fns3(f,nsa1); setup_fns(f,fns); if (ioresult = ord(inoerror)) and (not fnosrmtemp) then if not foverwritten then begin if not fanonymous then begin  srm_close_fileid(unum,foldfileid); purgepack(unum,1,addr(fns),start_alternate,pathid,volpass); end; if ioresult = ord(inofile) then ioresult := ord(inoerror);  if ioresult <> ord(inoerror) then srm_purge_file(f,unum); end else begin if foldfileid < 0 then foverwritten := false else  begin exchangepack(unum,foldfileid,fileid); srm_close_fileid(unum,foldfileid); srm_close_pathid(unum,pathid,fsavepathid); end; srm_purge_file(f,unum); end; if (ioresult = ord(inoerror)) and (not foverwritten) then if feft <> SYSTMTYPE then {not SYSTM file} begin srm_close_fileid(unum,fileid); if (ioresult = ord(inoerror)) and (not fnosrmtemp) then createlinkpack(unum,3,addr(nsa1),start_root,pathid,volpass, 1,addr(fns),start_alternate,pathid,volpass,true); if ioresult <> ord(inoerror) then srm_purge_file(f,unum) else begin fns.password := temp_file_pass; with pcs do begin password := temp_file_pass; capabilities := nocapabilities; end; tempioresult := ioresult; changeprotectpack(unum,1,addr(fns),start_alternate,  pathid,volpass,1,addr(pcs)); ioresult := tempioresult; end; end else begin {SYSTM file} savefileid := fileid; saveleof := fleof; fpos := saveleof; if fpos > 0 then ext1 := fpos else ext1 := extentsize; usefeft.i := feft; fns.password := ' '; createpack(unum,1,addr(fns),start_alternate,pathid, volpass,0,nil,usefeft,data_records, 256,ext1,extentsize,fstartaddress);   if ioresult = ord(inoerror) then doopenpack(unum,f,1,fns,start_alternate,volpass,exclusive_share_code,false); if ioresult = ord(inoerror) then copypack(unum,savefileid,0,fileid,0,saveleof);  srm_close_fileid(unum,fileid); srm_close_pathid(unum,pathid,fsavepathid); fileid := savefileid; srm_purge_file(f,unum); end; end; srm_close_pathid(unum,pathid,fsavepathid); end; end; (****************************************************************************) procedure srm_get_vol_date(anyvar f : datetimerec; unum : unitnum); type fibptr = ^fib; var tempfibspace : packed array [1..sizeof(fib,0)] of char; begin with fibptr(addr(tempfibspace))^, packet_ptr.rfileinfo^.file_info do begin funit := unum; pathid := -1; fileid := -1; fpos := 0; fkind := datafile; feft := DATATYPE; fisnew := true; fanonymous:= true; fmodified := false; foptstring:= nil; fnosrmtemp:= false; setstrlen(ftid,0); srm_create_file(fibptr(addr(tempfibspace))^,unum); if ioresult = ord(inoerror) then begin fileinfopack(unum,fileid); if ioresult = ord(inoerror) then with f do translatedate(creation_date,date,time); srm_purge_file(fibptr(addr(tempfibspace))^,unum); end; end; end; (****************************************************************************) procedure srm_lock_file(anyvar f : fib; unum : unitnum); begin with f, packet_ptr.rlock^ do begin lockpack(unum,fileid,fwaitonlock); if ioresult = ord(inoerror) then if not success.value then setioresult(ord(ifilelocked)) else begin fileinfopack(unum,fileid); if ioresult = ord(inoerror) then with packet_ptr.rfileinfo^.file_info do begin fpeof := logical_eof; fleof := logical_eof; flocked := true; end; end; end; end; (****************************************************************************) procedure srm_unlock_file(anyvar f : fib; unum : unitnum); begin with f do begin if ioresult = ord(inoerror) then begin call(am,addr(f),flush,f,0,0); flastpos := -1; if ioresult = ord(inoerror) then begin if fmodified then seteofpack(unum,fileid,false,fleof); if ioresult = ord(inoerror) then unlockpack(unum,fileid); if ioresult = ord(inoerror) then flocked := false; end; end; end; end; (****************************************************************************) procedure srm_strip(anyvar f : fib); var s : string[255]; findx : integer; sindx : integer; namelen : integer; passlen : integer; i : integer; ch : char; skip  : boolean; inpass : boolean; nopassyet : boolean; begin namelen := 0; passlen := 0; findx := 1; sindx := 0; setstrlen(s,255); inpass := false; nopassyet := true; with f do begin if ftitle[1] = '<' then {skip over volume password} repeat findx := findx + 1; if (findx > name_type_len + 3) or (findx > strlen(ftitle)) then setioresult(ord(ibadpass)); until (ftitle[findx-1] = '>') or (ioresult <> ord(inoerror)); while (findx <= strlen(ftitle)) and (ioresult = ord(inoerror)) do begin skip := false; ch := ftitle[findx]; if inpass then begin skip   := true; if ch = '>' then inpass := false else passlen := passlen + 1; end else if ch = '/' then begin nopassyet := true; inpass := false; namelen := 0; passlen := 0; end else if ch = '<' then if nopassyet then begin nopassyet := false; inpass := true;  skip := true; end; if not skip then begin if ch = '/' then begin if s[sindx] = '/' then setioresult(ord(ibadtitle)); end  else namelen := namelen + 1; sindx := sindx + 1; s[sindx] := ch; end; findx := findx + 1; if (namelen > name_type_len) then setioresult(ord(ibadtitle)) else if (passlen > name_type_len) then setioresult(ord(ibadpass)); end; if ioresult = ord(inoerror) then begin setstrlen(s,sindx); i := 0; while (s[sindx-i] <> '/') and (i < sindx) do i := i + 1; if i = 0 then setioresult(ord(ibadtitle)) else begin setstrlen(ftid,0); strmove(i,s,sindx-i+1,ftid,1); setstrlen(ftitle,0); strmove(sindx-i,s,1,ftitle,1); end; end; end; end; {****************************************************************************} {INTERNAL ONLY BEGIN} procedure pipe_am(fp : fibp; request : amrequesttype; anyvar buffer : window; bufsize : integer; position: integer); LABEL 1; const lf = 10; cr = 13; wbsize = 512; rbase = 256; rbsize = 256; var i : integer; eolchar : char; done : boolean; { freptcnt = # of bytes in write part of fbuffer } procedure flushdata; begin with fp^, unitable^[funit] do begin if freptcnt>0 then call(tm,fp,writebytes,fbuffer,freptcnt,0); freptcnt := 0; end; end; { flushdata } { freptcnt = # of bytes in write part of fbuffer } procedure writedata(anyvar buffer : window; size : integer); begin with fp^, unitable^[funit] do begin if (freptcnt+size)>wbsize then flushdata; if ioresult=ord(inoerror) then begin if size>=wbsize then call(tm,fp,writebytes,buffer,size,0) else begin moveleft(buffer,fbuffer[freptcnt],size); freptcnt := freptcnt + size; end; end; end; end; { writedata } { flastpos is # of bytes in read part of fbuffer. fstartaddress is index of next byte in read part of fbuffer. expects that the TM may not transfer all the requested data and that it will report the actual # of bytes in FLASTPOS . IMPLIED in the logic of this code is the expectation that the a call to the TM will result in at least one byte of data OR an error. } procedure readdata(anyvar buffer : window; size : integer); LABEL 2; var move : integer; bindex : integer; begin bindex := 0; with fp^, unitable^[funit] do while (size>0) and (ioresult=ord(inoerror)) do begin if flastpos>0 then begin if size=1 then { special case size 1 for speed } begin buffer[bindex] := fbuffer[fstartaddress]; size := 0; fstartaddress := fstartaddress + 1; flastpos := flastpos - 1; GOTO 2; end  else begin if flastpos>=size then move := size else move := flastpos; moveleft(fbuffer[fstartaddress],buffer[bindex],move); bindex := bindex + move; size :=  size - move; fstartaddress := fstartaddress + move; flastpos := flastpos - move; end; end; if (size>=rbsize) then begin { the SIZE of data requested won't fit in the read part of fbuffer so request 512 or SIZE which ever is smaller to be placed directly in the callers buffer .... the TM can't accurately handle partial reads unless .... the request to it is for 512 bytes or less. }  if size > 512 then move := 512 else move := rbsize; call(tm,fp,readbytes,buffer[bindex],move,0); { accept what shows up } size := size - flastpos; bindex := bindex + flastpos;  flastpos := 0; { show no data in fbuffer } end else if size>0 then begin { SIZE requested will fit in read part of fbuffer so try to fill the read part of fbuffer } call(tm,fp,readbytes,fbuffer[rbase],rbsize,0); fstartaddress := rbase; end; end; 2: end; { readdata } begin { pipe_am } with fp^, unitable^[funit] do begin if feft=uxfile_eft then eolchar:=chr(lf) { eol for ux files }  else eolchar:=chr(cr); { Normal eol for data file} case request of flush : begin flushdata; if ioresult=ord(inoerror) then call(tm,fp,flush,buffer,bufsize,position); end; writeeol : writedata(eolchar,1); writebytes : writedata(buffer,bufsize); readbytes : begin flushdata; { ensure all outbound data is gone }  readdata(buffer,bufsize); if ioresult<>ord(inoerror) then GOTO 1; if fistextvar then begin feoln := buffer[bufsize-1] = eolchar;  for i := 0 to bufsize - 1 do if buffer[i]=eolchar then buffer[i] := ' '; end; end; readtoeol : begin flushdata; { ensure all outbound data is gone } if ioresult<>ord(inoerror) then GOTO 1; feoln := false; done := false; i := 0; repeat i := i + 1; readdata(buffer[i],1);  if ioresult<>ord(inoerror) then begin i := i - 1; done := true; end else if (buffer[i]=eolchar) then  begin i := i - 1; done := true; fstartaddress := fstartaddress - 1; flastpos := flastpos + 1; end else done := i=bufsize; until done; buffer[0]:=chr(i); end; otherwise call(tm, fp, request, buffer, bufsize, position); end; { case } end; 1: end; { pipe_am } {****************************************************************************} function rmt_exec(anyvar f : fib; unum : unitnum; request : damrequesttype):boolean; var volpass : name_type; slen, sindx : integer; procedure getvolpass; var vsize : integer; i : integer; begin with f do begin vsize := 0; i := 2; while ftitle[i]<>'>' do begin  vsize := vsize + 1; volpass[vsize] := ftitle[i]; i := i + 1; end; end; end; { getvolpass } begin { rmt_exec } rmt_exec := false; with f do begin sindx := strpos('//',ftitle);   if sindx>1 then if (ftitle[sindx-1]<>'>') or (ftitle[1]<>'<') or (sindx>(passleng+3)) then sindx := 0; if sindx>0 then begin sindx := strpos('//',lastfid^); if sindx>0 then begin  slen := strlen(lastfid^); volpass := ' '; if ftitle[1]='<' then getvolpass; with packet_ptr.rrmtexec^ do begin rmt_exec := true; pathid := unitable^[unum].dvrtemp; rmtexecpack(unum,start_alternate,pathid,volpass, addr(lastfid^[sindx+2]),slen-sindx-1); if ioresult=ord(inoerror) then begin fileid := file_id; fpeof := minint; fleof := maxint; feft := uxfile_eft; fkind := uxfile; flockable := false; flocked := true; fstartaddress := 0; freptcnt := 0; fnosrmtemp := true;  fisnew := false; { to keep close simple } am := pipe_am {amtable^[fkind]} ; ffpw := '>remote execute<'; ftid := ''; end; end; { with } end; { if sindx } end; { if sindx } end; { with f } end; { rmt_exec } {INTERNAL ONLY END} (****************************************************************************) procedure srmdaminit; {INTERNAL ONLY BEGIN} var i : integer; {INTERNAL ONLY END} begin srm_init; passwordarrayptr := addr(constpassarray); {INTERNAL ONLY BEGIN} { Not sure this is needed ; also done in INIT in Kernel. JWH 8/10/90 } for i := 1 to 50 do srmux_on[i] := false; {INTERNAL ONLY END} end; {INTERNAL ONLY BEGIN} { Added for SRM-UX : } { This routine calls chmodpack, chownpack or chgrppack to carry out } { the requested command. These commands may only be requested from } { the FILER. Note that the name srmux_change_mode is a misnomer, } { 'cause it handles chown and chgrp requests as well. } { JWH 6/22/90. } procedure srmux_change_mode(f : fib; unum : unitnum); type command_array = array[0..maxint] of h_setpasswd_entry; command_arrayptr = ^command_array; var nsa : name_set_array; begin with f do begin with command_arrayptr(fwindow)^[0] do begin { writeln(new_value); writeln(command); } setup_fns(f,nsa); case command of hfs_chmod : chmodpack(funit, 1, { nfns }  addr(nsa), start_alternate, pathid, fileid, ' ', new_value); hfs_chown : chownpack(funit, 1, { nfns } addr(nsa), start_alternate, pathid, fileid,  ' ', new_value); hfs_chgrp : chgrppack(funit, 1, { nfns } addr(nsa), start_alternate,  pathid, fileid, ' ', new_value); otherwise ; end; { case } end; end; { with packet_ptr.rchmod^ do begin writeln('Status is : ',return_mess_header.status); end; writeln('leaving change mode'); } end; {INTERNAL ONLY END} (****************************************************************************) {INTERNAL ONLY BEGIN} procedure srm_srmdam(anyvar f : fib; unum : unitnum; request : damrequesttype); var holdpathid : integer; savepathid : integer; savefileid : integer; saveftid : tid; saveffpw  : passtype; savefvid : vid; saveftitle : fid; savefsavepathid : boolean; fisafib : boolean; begin ioresult := ord(inoerror); srmsavesc := 0; lockup; fisafib := false;  try with f, unitable^[unum] do if offline then ioresult := ord(znodevice) else begin if request in [opendirectory, openparentdir, closedirectory,  catalog, catpasswords, setpasswords, openfile, createfile, overwritefile, makedirectory,  closefile, changename, duplicatelink, purgename, lockfile, unlockfile, purgefile,  setunitprefix, stretchit ] then {f is a fib} begin fisafib := true; if strlen(ftid) > tidleng then {fix uninitialized fib strings}  setstrlen(ftid,0); if strlen(ffpw) > passleng then setstrlen(ffpw,0); if strlen(fvid) > vidleng then setstrlen(fvid,0); savepathid := pathid; {save fib fields to be restored on error} savefileid := fileid; savefsavepathid := fsavepathid; saveftid := ftid; saveffpw := ffpw; savefvid := fvid; if strlen(ftitle) > fidleng then setstrlen(saveftitle,0) else saveftitle := ftitle; end; { TESTING ONLY !!!!!!!!!! } { if is_srmux_unit(unum) then log_srmdam_request(request); } case request of opendirectory, openparentdir : begin srm_open_dir(f,unum,open_directory,request = openparentdir); if ioresult = ord(inoerror) then  srm_get_dir_info(fwindow^,pathid,unum,true,false); end; closedirectory : begin fsavepathid := false; srm_close_pathid(unum,pathid,false);  end; catalog : srm_catalog(f,unum); catpasswords : begin srm_open_dir(f,unum,open_directory,true); if ioresult = ord(inoerror) then  begin srm_cat_pass(f,unum); srm_close_pathid(unum,pathid,fsavepathid); end; end; setpasswords : { Changed for SRM-UX : } if not is_srmux_unit(unum) then begin srm_open_dir(f,unum,open_directory,true); if ioresult = ord(inoerror) then begin srm_set_pass(f,unum); srm_close_pathid(unum,pathid,fsavepathid); end; end  else begin { they want us to change mode, etc. } { It's the FILER calling from the hfs_access routine } srm_open_dir(f,unum,open_directory,true); if ioresult = ord(inoerror) then begin srmux_change_mode(f,unum); srm_close_pathid(unum,pathi d,fsavepathid); end; { else writeln('the opendir thing did not work'); } end; { is SRM-UX request } openfile : if not rmt_exec(f,unum,request) then begin fisnew := false; fnosrmtemp := true; {default case} srm_open_dir(f,unum,open_directory,true ); if ioresult = ord(inoerror) then begin srm_open_file(f,unum); if ioresult <> ord(inoerror) then  srm_close_pathid(unum,pathid,fsavepathid); end; end; createfile, overwritefile : if not rmt_exec(f,unum,request) then  begin fisnew := true; fnosrmtemp := false; foverwritten := request = overwritefile; if not fanonymous then  srm_open_dir(f,unum,open_directory,true ); if ioresult = ord(inoerror) then begin srm_create_file(f,unum);  if ioresult <> ord(inoerror) then if not fanonymous then srm_close_pathid(unum,pathid,fsavepathid); end; end;  makedirectory : begin holdpathid := pathid; srm_open_dir(f,unum,open_directory,false); if ioresult = ord(inoerror) then begin srm_create_dir (f,unum); srm_close_pathid(unum,pathid,fsavepathid); end; pathid := holdpathid;  end; closefile : if (fisnew and fanonymous) then srm_purge_file(f,unum) else srm_close_file(f,unum); changename : srm_change_name(f,unum); duplicatelink : srm_dup_link(f,unum); purgename : begin holdpathid := pathid; srm_open_dir(f,unum,open_directory,true); if ioresult = ord(inoerror) then begin srm_purge_name(f,unum); srm_close_pathid(unum,pathid,fsavepathid); end;  pathid := holdpathid; end; lockfile : srm_lock_file(f,unum); unlockfile : srm_unlock_file(f,unum); purgefile : srm_purge_file(f,unum); setunitprefix : srm_set_unit_prefix(f,unum); stretchit : srm_stretch(f,unum); getvolumename : srm_get_vol_name(f,unum); getvolumedate : srm_get_vol_date(f,unum); setvolumedate, crunch : {do nothing, but no error}; stripname : srm_strip(f); { Used by the FILER to distinguish SRM and SRM/UX } { Added for 3.23+ and 3.24 JWH 11/12/90 } setvolumename : begin if is_srmux_unit(unum) then setioresult(ord(ibadvalue)) else setioresult(ord(ibadrequest)); end; otherwise setioresult(ord(ibad request)); end; if (ioresult <> ord(inoerror)) and fisafib then {restore fib for subsequent calls} begin pathid := savepathid; fileid := savefileid; fsavepathid := savefsavepathid; ftid := saveftid; ffpw := saveffpw; fvid := savefvid; if strlen(saveftitle) > 0 then ftitle := saveftitle; end; if ioresult = ord(isrmcatchall) then if srmsavesc <> 0 then escape(srmsavesc); end; recover begin if escapecode = ioescapecode then setioresult(ord(isrmcatchall)) else begin lockdown; escape(escapecode); end; end; lockdown; end; {srm_srmdam} procedure lan_srmdam(anyvar f : fib; unum : unitnum; request : damrequesttype); begin lastunit := unum; lastsc := unitable^[lastunit].sc; lansrm_reset(lastsc); with lsrm_unit_table^[lastunit] do begin srm_srmdam(f,unum,request); end; end; procedure srmdam(anyvar f : fib; unum : unitnum;  request : damrequesttype); {decide which dam should be installed} begin ioresult := 0; with f, unitable^[unum] do if offline then ioresult := ord(znodevice) else begin if iompx_info = nil then begin dam := srm_srmdam; volpack(unum); with packet_ptr.rvol^ do begin if srm_ux_flag then srmux_on[unum] := true else srmux_on[unum] := false; end; end else begin if (isc_table[sc].card_id = hp98643) then begin if iompx_info^.isc_iompx_table[sc].capable then begin if pad=0 then lansrm_init_unit(unum); pad := 1; { shadow unit has been reset } dam := lan_srmdam; srmux_on[unum] := true; { Only possibility } end else ioresult := ord(znodevice); end else  begin dam := srm_srmdam; volpack(unum); with packet_ptr.rvol^ do begin if srm_ux_flag then srmux_on[unum] := true else srmux_on[unum] := false; end; end; end; { complete the call } call(dam,f,unum,request); end; end; {srmdam} {INTERNAL ONLY END} end; {srmdammodule} import srmdammodule; begin {program init_srm} srmdaminit; end.  (* (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 *) $copyright 'COPYRIGHT (C) 1983 BY HEWLETT-PACKARD COMPANY'$ $range off$ $debug off$ $modcal$ module srmammodule; { $SEARCH 'SRM_DRV', 'IOLIB:KERNEL' {INTERNAL ONLY BEGIN} { ,'LANSRM','IOLIB:LANDECS' } {INTERNAL ONLY END} { $ } {} $SEARCH 'SRM_DRV', 'LANSRM','LANDECS'$ {} import sysglobals, misc, iodeclarations, {INTERNAL ONLY BEGIN} lansrm, landecs, {INTERNAL ONLY END} srm; export procedure srmam(fp   : fibp; request : amrequesttype; anyvar buffer : window; bufsize : integer; position: integer); implement type pointer = ^char; (*****************************************************************************) procedure srm_read(anyvar f : fib; startoffset : integer; bytecount : integer; ramaddress : charptr); var sent : integer; access: integer; offset: integer; begin if bytecount > 0 then with f, packet_ptr.rhead^ {INTERNAL ONLY BEGIN} ,packet_ptr.rread^ {INTERNAL ONLY END} do begin access := random_access; offset := startoffset; sent := 0; if bytecount > 512 then  begin sendreadpack(funit,fileid,access,512,offset,ramaddress); sent := 512; ramaddress := addr(ramaddress^,512); access := sequential_access; offset := 0; while (bytecount - sent > 512) and (ioresult = ord(inoerror)) do begin sendreadpack(funit,fileid,access,512,offset,ramaddress); sent := sent + 512; ramaddress := addr(ramaddress^,512);  packetin(funit,req_read); end; end; if ioresult = ord(inoerror) then begin sendreadpack(funit,fileid,access,bytecount-sent,offset,ramaddress); packetin(funit,req_read); {INTERNAL ONLY BEGIN} { conditionaly record actual number of bytes received } if (fleof=maxint) and (fpeof=minint) then flastpos := actual; {INTERNAL ONLY END} end; if (bytecount > 512) and (ioresult = ord(inoerror)) then packetin(funit,req_read); if ioresult <> ord(inoerror) then resetcard(funit); end; end; { srm_read } (*****************************************************************************) procedure srm_write(anyvar f : fib; startoffset : integer; bytecount : integer; ramaddress : charptr); var sent : integer; access: integer; offset: integer; begin if bytecount > 0 then with f, packet_ptr.rhead^ , packet_ptr.rwrite^ do begin access := random_access; offset := startoffset; sent := 0; if bytecount > 512 then begin sendwritepack(funit,fileid,access,512,offset,ramaddress); sent  := 512; ramaddress := addr(ramaddress^,512); access := sequential_access; offset := 0; while (bytecount - sent > 512) and (ioresult = ord(inoerror)) do begin sendwritepack(funit,fileid,access,512,offset,ramaddress); sent := sent + 512; ramaddress := addr(ramaddress^,512); packetin(funit,req_write); end; end; if ioresult = ord(inoerror) then begin sendwritepack(funit,fileid,access,bytecount-sent,offset,ramaddress); packetin(funit,req_write); end; if (bytecount > 512) and (ioresult = ord(inoerror)) then packetin(funit,req_write); if ioresult <> ord(inoerror) then resetcard(funit); end; end; { srm_write } (*****************************************************************************) procedure srm_clearunit(anyvar f : fib); var u  : unitnum; keepworkdirs : boolean; begin with f, unitable^[funit], isc_table[sc] do if (card_id <> hp98629) {INTERNAL ONLY BEGIN} and (card_id <> hp98643) {INTERNAL ONLY END} then {this is not a theodore or LAN card } ioresult := ord(znodevice) else begin {INTERNAL ONLY BEGIN} if card_id=hp98643 then { force driver to reset & restart the card } call(io_drv_ptr^.iod_wtc,io_tmp_ptr,l_card_state, ord(cs_lance_ready)) else {I NTERNAL ONLY END} resetcard(funit); areyoualivepack(funit); if ioresult = ord(inoerror) then volpack(funit); if ioresult <> ord(inoerror) then ioresult := ord(znodevice) else begin keepworkdirs := false; if strlen(uvid) > 0 then keepworkdirs := true else for u := 1 to maxunit do if sc = unitable^[u].sc then if ba = unitable^[u].ba then if strlen(unitable^[u].uvid) > 0 then keepworkdirs := true; gangcleanpack(funit, keepworkdirs); end; end; end; (*****************************************************************************) {INTERNAL ONLY BEGIN} procedure srm_srmam(fp : fibp; request : amrequesttype; anyvar buffer : window; bufsize : integer; position: integer); begin ioresult := ord(inoerror); srmsavesc := 0; lockup; try with fp^ do if (request <> clearunit) and (unitable^[funit].offline) then ioresult := ord(znodevice) else case request of readbytes :begin if flockable and (not flocked) then  ioresult := ord(ifileunlocked) else srm_read(fp^,position,bufsize,addr(buffer)); end; writebytes :begin if flockable and (not flocked) then ioresult := ord(ifileunlocked) else srm_write(fp^,position,bufsize,addr(buffer)); end; clearunit :begin srm_clearunit(fp^); end; flush : {do nothing, but no error}; otherwise ioresult := ord(ibadrequest); end; if ioresult = ord(isrmcatchall) then if srmsavesc <> 0 then escape(srmsavesc);  recover begin if escapecode = ioescapecode then ioresult := ord(isrmcatchall) else begin lockdown; escape(escapecode); end; end; lockdown; end; {srm_srmam} procedure lan_srmam(fp:fibp; request:amrequesttype; anyvar buffer:window; bufsize,position:integer); begin lastunit := fp^.funit; lastsc := unitable^[lastunit].sc; lansrm_reset(lastsc); with lsrm_unit_table^[lastunit] do begin  srm_srmam(fp,request,buffer,bufsize,position); end; end; { lan_srmam} procedure srmam(fp:fibp; request:amrequesttype; anyvar buffer:window; bufsize,position:integer); begin with fp^ do if (request <> clearunit) and (unitable^[funit].offline) then ioresult := ord(znodevice) else with unitable^[funit] do begin if iompx_info = nil then tm := srm_srmam else begin if (isc_table[sc].card_id = hp98643) then begin if iompx_info^.isc_iompx_table[sc].capable then begin if pad=0 then lansrm_init_unit(funit); pad := 1; { the shadow unit has been reset } tm := lan_srmam; end else ioresult := ord(znodevice); end else tm := srm_srmam; end; call(tm,fp,request,buffer,bufsize,position); end;  end; {srmam} {INTERNAL ONLY END} end. {srmammodule} $MODCAL$ PROGRAM LAN(INPUT,OUTPUT); $DEBUG OFF$ $RANGE OFF$ $STACKCHECK OFF$ $OVFLCHECK OFF$ { bug fix/changes history disallowed dummy_tfr_1 and dummy_tfr_2 transfer requests. 3.22A fixed MOVE_DATA_TO to also discard input if in_bufptr=nil. added  code in LAN_INIT to fix the heap pointer. added code in LAN_TFR to call OPS_PROCS for TO_MEMORY transfers. Gives an OPS_PROC a chance to supply data immediately. 3.22C in LAN_TFR defined dummy_tfr_1 and dummy_tfr_2 to mean than the buffer involved must be registered. for these 'must be registered' type transfers, for from_memory transfers, OUT_BUFPTR is still used/required for to_memory transfers, IN_BUFPTR is ignored. } MODULE LANDVR; $SEARCH 'LANDECS','LANASM' { ,'IOLIB:KERNEL.CODE'} $ IMPORT SYSGLOBALS, IODECLARATIONS, GENERAL_0, ASM, LANDECS, LANASM, ISR; EXPORT function laninit(var ehp:anyptr):boolean; IMPLEMENT $INCLUDE 'IOMPXDECS.TEXT'$ $LINENUM 2000$ CONST ack_timeout_count = 1000; { just a count } init_timeout = 30; { milli secs } init_ladrf = ladrf_type[int1 : 0,int2 : 0]; rmd1_0_init = HEX('80'); { sets OWN, clears others } clear_mcnt = 0; tmd1_0_init = 0; { clears OWN & all others } tmd1_0_return = HEX('83'); { sets OWN, STP & ENP } tmd3_return = 0; { clears all bits } csr0_init = csr0_type[ ERR :false, BABL:TRUE , CERR:TRUE , MISS:TRUE, MERR:TRUE , RINT:TRUE , TINT:TRUE , IDON:TRUE,  INTR:false, INEA:TRUE , RXON:false, TXON:false, TDMD:false, STOP:false, STRT:TRUE , INIT:TRUE ]; csr0_init_ack = csr0_type[ ERR :false, BABL:TRUE , CERR:TRUE , MISS:TRUE , MERR:TRUE , RINT:TRUE , TINT:TRUE , IDON:TRUE , INTR:false, INEA:TRUE , RXON:false, TXON:false, TDMD:false, STOP:false, STRT:false, INIT:false]; csr0_start = csr0_type[ ERR :false, BABL:TRUE , CERR:TRUE , MISS:TRUE, MERR:TRUE , RINT:TRUE , TINT:TRUE , IDON:TRUE, INTR:false, INEA:TRUE , RXON:false, TXON:false, TDMD:false, STOP:false, STRT:TRUE , INIT:false]; csr0_intr_ack = csr0_type[ ERR :false, BABL:false, CERR:false, MISS:false, MERR:false, RINT:false, TINT:false, IDON:TRUE, INTR:false, INEA:TRUE , RXON:false, TXON:false,  TDMD:false, STOP:false, STRT:false, INIT:false]; tdmd_inea = csr0_type[ ERR :false, BABL:false, CERR:false, MISS:false, MERR:false, RINT:false, TINT:false, IDON:false, INTR:false, INEA:TRUE , RXON:false, TXON:false, TDMD:TRUE , STOP:false, STRT:false, INIT:false]; type scan_result_type = (scan_ok, scan_done, scan_error, scan_nop); isr_tx_status_type = (isr_tx_done,isr_tx_none,isr_tx_retry); io_wp = ^io_word; bp = ^buf_info_type; cp = ^char; fp = ^frame_type; frame_type = packed array[1..lan_max_frame_len] of char; term_char_type = -1..255; ioclass = (lan_input,lan_output,lan_all_io); var lmpx_info : iompx_info_ptr; function read_csr0(var info : lan_info_rec; card : card_base_ptr):csr0_type; var tcount : integer; begin { Read the RDP register on the LANCE } tcount := ack_timeout_count; with info, card^ do begin repeat READ_CSR0 := rdp.csr0; tcount := tcount - 1; until sc_reg.ack or (tcount<=0) ; if not sc_reg.ack then begin card_state := cs_ack_error; id_reg.reset := 1; { reset the card } READ_CSR0.UW := 0; { no status info } end; end; { with } end; { read_csr0 } procedure write_rdp(var info : lan_info_rec; card : card_base_ptr; data : unsword); var tcount : integer; begin { Write the RDP register on the LANCE } tcount := ack_timeout_count; with info, card^ do begin repeat rdp.uw := data; tcount := tcount - 1; until sc_reg .ack or (tcount<=0); if not sc_reg.ack then begin card_state := cs_ack_error; id_reg.reset := 1; { reset the card } end; end; { with } end; { write_rdp } procedure clean_up(io_info : pio_tmp_ptr;  info : lan_info_ptr; tc : term_char_type; class : ioclass); { called only when tc = lb_abort, lb_reset or lb_hw_failed } var i : integer; can_continue : boolean;  tempbp: ^buf_info_type; next1, next2 : iompx_rec_ptr; ans : iompx_ans_rec; begin { clean_up } { check for IOMPX availability } if lmpx_info=nil then begin call(io_error_link,iompx_request,ans.s); if ans.s=iompx_answer then begin lmpx_info := ans.ptr; lmpx_info^.isc_iompx_table[io_info^.my_isc].capable := true ; end; end; with io_info^ do begin { clean up input side } { can continue from aborts and resets } if class<>lan_output then begin if in_bufptr<>nil then with bp(in_bufptr)^ do begin term_char := tc; TRY if eot_proc.dummy_pr<>nil then  call(eot_proc.real_proc,in_bufptr); RECOVER term_char := lb_abort; { cancel the transfer } can_continue := (tc=lb_abort) or (tc=lb_reset); if not (can_continue and ((term_char=lb_pending) or (term_char=lb_reset))) then begin in_bufptr := nil; active_isc:=no_isc; end; end; { now check for registered buffers } if lmpx_info<>nil then begin next1 := lmpx_info^.isc_iompx_table[my_isc].checkers; while next1<>nil do with next1^, user_buffer^ do begin next2 := next; { eot proc may decide to un-register } if active_isc<>no_isc then  begin term_char := tc; TRY if eot_proc.dummy_pr<>nil then call(eot_proc.real_proc,user_buffer); RECOVER begin end; end;  next1 := next2; end; { while .. with next1 } end; end; { clean up output side } { can continue from aborts but not resets } { allow re transmit on reset } if class<>lan_input then if out_bufptr<>nil then begin tempbp := out_bufptr; with tempbp^ do begin term_char := tc; out_bufptr := nil; { dis-connect & de-activate } active_isc := no_isc; TRY  if eot_proc.dummy_pr<>nil then call(eot_proc.real_proc,tempbp); RECOVER term_char := lb_abort; { cancel the transfer } if (tc=lb_abort) and (term_char=lb_pending) then begin out_bufptr := tempbp; { re-connect and re-activate } active_isc := my_isc; end; end; end; { notify all user buffers on the card of the request } { can continue from aborts but not resets or failures} if class=lan_all_io then for i := 0 to max_ring_elts-1 do begin tempbp := info^.tx_user_buffs^[i]; { take a copy } info^.tx_user_buffs^[i] := nil; { zap original } if tempbp<>nil then with tempbp^ do begin term_char := tc; active_isc:= no_isc; { de-activate the buffer } TRY if eot_proc.dummy_pr<>nil then call(eot_proc.real_proc,tempbp); RECOVER  term_char := lb_abort; { cancel the transfer } if (term_char<>lb_pending) or (tc<>lb_abort) then tempbp:=nil; { disconnect it } { fix if call is abort } if tc=lb_abort then info^.tx_user_buffs^[i ]:=tempbp; end; end; end; { try to call outbuf_proc } if tc<>lb_hw_failed then with info^, io_info^ do begin TRY if out_bufptr=nil then if outbuf_proc.dummy_pr<>nil then  call(outbuf_proc.real_proc,my_isc); RECOVER begin end; end; end; { clean_up } procedure card_start(io_info : pio_tmp_ptr); const p2 = #1#2#4#8#16#32#64#128; var card : card_base_ptr; temp_addr : gpaddr; i,nb : integer; info : lan_info_ptr; rx_temp : ^rx_buffers; tx_temp : ^tx_buffers; done : boolean; timeout : timer_rec; csr0 : csr0_type; tc : term_char_type; begin { card_start } info := ADDR(io_info^.drv_misc); card := io_info^.card_addr; with card^, info^ do if card_state<>cs_hw_failed then begin { ========== load the init block ========== } { reset the card so that handshake operations are not needed } id_reg.reset := 1; card_state := cs_card_reset; alloc_ok := false; { set notice that output buffers must be re-allocated } { set up LANCE registers 1, 2 and 3 }  temp_addr.ptr := ADDR(ram_area.init_block); rap := 1; { register 1 } rdp.uw := temp_addr.L16; rap := 2; { register 2 } rdp.uw := temp_addr.H8; rap := 3; { register 3 } rdp.uw := 4; { bwsp=1, acon=0, bcon=0 } { fill in the init_block pieces } TRY with init_block do { temp init block } begin { note byte swapping } padr[1]:=local_link_address[2]; padr[2]:=local_link_address[1];  padr[3]:=local_link_address[4]; padr[4]:=local_link_address[3]; padr[5]:=local_link_address[6]; padr[6]:=local_link_address[5]; i := num_rx_buffers*rx_buffer_size; tx_buffer_size := memory_size -init_size -num_rx_buffers*sizeof(rx_ring_elt_type) -num_tx_buffers*sizeof(tx_ring_elt_type) -num_rx_buffers*rx_buffer_size;  if (tx_buffer_size < lan_max_frame_len ) or (i=ORD(p2[i]) then nb:=i-1; num_rx_buffers := ORD(p2[nb+1]); { recieve ring is the first part of buffers } temp_addr.ptr := ADDR(ram_area.buffers); rxr_1 := temp_addr.ptr; {address of first rcv ring elt} rx_temp := temp_addr.ptr; rdraL := temp_addr.L16; rdraH := temp_addr.H8; rlen := nb; zip0 := 0; { point to transmit ring } { fixup num_tx_buffers } nb := 0; for i := 1 to 8 do if num_tx_buffers>=ORD(p2[i]) then nb:=i-1; num_tx_buffers := ORD(p2[nb+1]); { transmit ring is the second part of buffers } temp_addr.int := temp_addr.int +  (num_rx_buffers*sizeof(rx_ring_elt_type)); rxr_n := temp_addr.ptr; { last + 1 rcv ring elt } txr_1 := temp_addr.ptr; { first tx ring elt } tx_ring_f := txr_1; tx_ring_l := txr_1;  tx_temp := temp_addr.ptr; tdraL := temp_addr.L16; tdraH := temp_addr.H8; tlen := nb; zip1 := 0; { initialize the recieve ring } { recieve buffers is the third part of buffers } temp_addr.int := temp_addr.int + (num_tx_buffers*sizeof(tx_ring_elt_type)); txr_n := temp_addr.ptr; {last + 1 tx ring elt} for i := 1 to num_rx_buffers do with rx_temp^[ i] do begin ladr :=temp_addr.L16; hadr :=temp_addr.H8; rmd1_0:=rmd1_0_init; { set own , clear all others } bcnt :=-rx_buffer_size; mcnt :=clear_mcnt;  temp_addr.int := temp_addr.int+rx_buffer_size; end; { for .. with } rx_ring := rxr_1; { where to start looking for inbound messages } { initialize the transmit ring } { the trasmit buffer space is the fourth part of buffers } for i := 1 to num_tx_buffers do tx_temp^[i].tmd1_0 := tmd1_0_init; { initialize the remaining pointers etc. } txd_1.ptr := temp_addr.ptr; { first of tx buffer space }  temp_addr.int := temp_addr.int+tx_buffer_size; txd_n.ptr := temp_addr.ptr; {last + 1 of tx buffer space} tx_count := 0; { no outstanding tx requests } tx_next.ptr := txd_1.ptr; { first usable space } tx_used.ptr := nil; { no used space } end; { with init_block } RECOVER card_state := cs_init_failed; if card_state=cs_card_reset then begin {move the init_block from driver info to card ram_area }  ram_area.init_block:=init_block; { start up the card } rap := 0; rdp.csr0 := csr0_init; timeout.time := init_timeout; start_timer(timeout); done := FALSE; repeat if sc_reg.ir then begin csr0 := read_csr0(info^,card); if csr0.idon then with csr0 do begin if not (init and strt and txon and inea) then begin id_reg.reset := 1; io_escape(ioe_crd_dwn,io_info^.my_isc); end; { acknowledge the init done } write_rdp(info^,card,csr0_init_ack.uw); done := TRUE; if card_state=cs_card_reset then card_state := cs_lance_ready; end; end; until time_expired(timeout) or done; if not done then begin id_reg.reset := 1; card_state := cs_hw_failed; end;  do_card_start := FALSE; { operation complete } lan_stats^[lhw_restarts] := lan_stats^[lhw_restarts]+1; end; { if card_state .. } tx_ub_in := 0; tx_ub_out := 0; { reset tx user buffer control } last_rx_size := 0;  { no input frames available yet } end; { with card, info^ } { enable card interupts } if info^.card_state = cs_lance_ready then begin tc := lb_reset; card^.sc_reg.ie := TRUE; end else tc := lb_hw_failed; { notify all user buffers of card reset/hw_failure } clean_up(io_info,info,tc,lan_all_io); end; { card_start } procedure card_reset(info : lan_info_ptr; card : card_base_ptr); begin with card^ do  begin id_reg.reset := 1; { reset the card } sc_reg.control := 0; { disable interupts } end; info^.card_state := cs_card_reset; end; { card_reset } procedure lan_init(temp : ANYPTR); { stop key/cleario/abort transfer } var io_info : pio_tmp_ptr; info : lan_info_ptr; old_level: integer; begin { lan_init } io_info := temp; with io_info^ do begin info := ADDR(drv_misc); old_level := intlevel; if old_levelscan_nop; SCAN_INBOUND := done; end; end; { with } end; { scan_inbound } procedure next_baddr(info : lan_info_ptr; var ring : rx_ring_elt_ptr; var bufptr : gpaddr); begin ring := ADDR(ring^,sizeof(rx_ring_elt_type)); with info^ do if ring = rxr_n then ring := rxr_1;  with ring^ do begin bufptr.int := 0; bufptr.L16 := ladr; bufptr.H8 := hadr; end; end; { next_baddr } function inbound_ready(info : lan_info_ptr; var bufptr : gpaddr;  var size : shortint):boolean; var done : boolean; result : scan_result_type; begin done := FALSE; INBOUND_READY := FALSE; with info^ do repeat result := scan_inbound(info,size); case result of scan_error : skip_bad_frame(info); scan_ok : begin if (size > lan_max_frame_len) or (size < lan_min_frame_len) then begin skip_bad_frame(inf o); lan_stats^[lrx_other_err]:=lan_stats^[lrx_other_err]+1; end else with rx_ring^ do begin bufptr.int := 0; bufptr.L16 := ladr; bufptr.H8 := hadr; if last_rx_size=0 then with io_temps^ do begin { user validation checks } last_rx_size := size; skip_bytes := 0; { set defaults } copy_bytes := size; lan_stats^[lrx_no_errors]:=lan_stats^[lrx_no_errors]+1; if perm_isr.dummy_pr<>nil then begin call(perm_isr.real_proc,bufptr.enh);{ give first rx buffer seg.}  end else if user_isr.dummy_pr<>nil then begin call(user_isr.real_proc,bufptr.enh);{ give first rx buffer seg.} end; end; { with io_temps } if copy_bytes=0 then skip_frame(info) else begin INBOUND_READY := TRUE; done := TRUE; end; end; { with rx_ring } end; {scan_ok} scan_done : done := TRUE; { no frames ready } end; { case } until done; end; {inbound_ready} procedure lan_read_buffer(info : lan_info_ptr); var size,bsize : shortint; baddr : gpaddr; ring : rx_ring_elt_ptr; working, target : BUFxINFOxPTR; io_info : pio_tmp_ptr; ibp : bp; function move_data_to: BUFxINFOxPTR; var demux : boolean; begin move_data_to := nil; if inbound_ready(info,baddr,size) then begin demux := false; if lmpx_info<>nil then if lmpx_info^. isc_iompx_table[io_info^.my_isc].checkers<>nil then begin move_data_to := info^.driver_buffer;  demux := true; end; if not demux then begin with io_info^ do begin if (in_bufptr<>nil) then begin if (bp(in_bufptr)^.active_isc<>no_isc) then move_data_to := in_bufptr else while inbound_ready(info,baddr,size) do skip_frame(info); end else while inbound_ready(info,baddr,size) do skip_frame(info); end; end; end; end; { move_data_to } begin { lan_read_buffer } io_info := info^.io_temps; working := move_data_to; while working<>nil do begin  with info^, working^ do begin { move data from card buffer(s) to user buffer } { adjust term_count (available buffer capacity) and size (bytes to move from card) } term_char := lb_eot; { assume normal completion } if term_count>=size then term_count := size else begin size := term_count; term_char := lb_short; end; {data was lost} ring := rx_ring; { assumed that skip_bytes is <= size } { this is enforced by L_SKIP_BYTES and inbound_ready } while skip_bytes>0 do begin if size > rx_buffer_size then bsize := rx_buffer_size else bsize := size; if skip_bytes0 then next_baddr(info,ring,baddr); end; while size>0 do   begin if size > rx_buffer_size then bsize := rx_buffer_size else bsize := size; moveleft(cp(baddr.ptr)^,cp(buf_fill)^,bsize); buf_fill := ADDR(cp(buf_fill)^,bsize);  size := size - bsize; if size>0 then next_baddr(info,ring,baddr); end; skip_frame(info); { let the card have its buffer(s) back } with io_info^ do if working=in_bufptr then begin  in_bufptr := nil; { disconnect the users buffer } active_isc := no_isc; { un_busy the buffer } TRY if eot_proc.dummy_pr<>nil then { call the buffers eot proc } call (eot_proc.real_proc,working); RECOVER begin end; end else begin { call scanner giving the working buffer pointer and a var target buffer pointer. The scanner is to return target as nil (unable to find a buffer) or pointing to a buffer which has the data already copied to it. The target buffer could be in_bufptr. } call(lmpx_info^.iompx_scanner,working,target); if target<>nil then with target^ do begin if working^.term_count=0 then term_char := lb_eot else term_char := lb_short; if target=in_bufptr then in_bufptr:=nil; active_isc := no_isc; TRY if eot_proc.dummy_pr<>nil then { call the buffers eot proc } call (eot_proc.real_proc,target); RECOVER begin end; end; with BUFxINFOxPTR(driver_buffer)^ do begin {reset & re-activate the driver buffer} buf_fill := buf_ptr; buf_empty := buf_ptr; term_count := lan_max_frame_len; active_isc := my_isc; end; end; { with io_info^ ... } end; { with info^, working etc.. } working := move_data_to; end; { while working<>nil } end; { lan_read_buffer } function check_out(io_info : pio_tmp_ptr):boolean; var info : lan_info_ptr; card : card_base_ptr; ubuf : bp; begin { check_out } CHECK_OUT := FALSE; info := ADDR(io_info^.drv_misc); card := io_info^.card_addr; with info^, tx_ring_l^ do if not own then { if LANCE does not own it then continue } begin  ubuf := tx_user_buffs^[tx_ub_out]; CHECK_OUT := TRUE; if ERR then begin { tranmission failed } if ubuf<>nil then ubuf^.term_char := lb_tx_error; if LCOL then lan_stats^[ltx_lcol_err] := lan_stats^[ltx_lcol_err]+1; if LCAR then lan_stats^[ltx_lcar_err] := lan_stats^[ltx_lcar_err]+1; if RTRY then lan_stats^[ltx_retry_err] := lan_stats^[ltx_retry_err]+1; if UFLO then begin { semi nasty failure } lan_stats^[ltx_uflo_err] := lan_stats^[ltx_uflo_err]+1; card_reset(info,card); card_start(io_info); CHECK_OUT := FALSE; ubuf := nil; end; end else begin { packet was sent }  if ubuf<>nil then ubuf^.term_char := lb_eot; { packet was sent } if ONE then lan_stats^[ltx_one] := lan_stats^[ltx_one]+1 else if MORE then lan_stats^[ltx_more] := lan_stats^[ltx_more]+1 else if NOT DEF then lan_stats^[ltx_no_errors] := lan_stats^[ltx_no_errors]+1; if DEF then lan_stats^[ltx_def] := lan_stats^[ltx_def]+1; end; if ubuf<>nil then with ubuf^ do begin tx_user_buffs^[tx_ub_out]:=nil; active_isc := no_isc; { no longer busy } TRY if eot_proc.dummy_pr<>nil then call(eot_proc.real_proc,ubuf); RECOVER begin end; end; tx_ub_out := (tx_ub_out+1) mod max_ring_elts; end; {  with ... } end; { check_out } procedure de_allocate(info:lan_info_ptr); begin with info^ do begin with tx_ring_l^ do begin tx_count := tx_count - 1; if tx_count=0 then begin tx_next := txd_1; { reset to start of tx_buffer space } tx_used := tx_next; end else begin tx_used.int := 0; tx_used.L16 := ladr; tx_used.H8 := hadr; tx_used.int := tx_used.int - bcnt; { bcnt is always negative } end; end; tx_ring_l := ADDR(tx_ring_l^,sizeof(tx_ring_elt_type)); if tx_ring_l=txr_n then tx_ring_l:=txr_1; end; end; {de_allocate} procedure lan_isr(isribptr: pisrib); var io_info : pio_tmp_ptr; info : lan_info_ptr; card : card_base_ptr; stat : csr0_type; status : rx_status_type; done : boolean; begin { lan_isr } io_info := ADDR(isribptr^); info := ADDR(io_info^.drv_misc); card := io_info^.card_addr; with card^ do begin if sc_reg.jab then begin { nasty failure } card_reset(info,card); card_start(io_info); end; stat := read_csr0(info^,card); write_rdp(info^,card,w_or(stat.uw,CSR0_INTR_ACK.uw)); with stat do if ERR then with info^ do begin if MERR then lan_stats^[lhw_merr] := lan_stats^[lhw_merr]+1; if BABL then lan_stats^[lhw_babl] := lan_stats^[lhw_babl]+1; if CERR then lan_stats^[ltx_no_heart] := lan_stats^[ltx_no_heart]+1; if MISS then lan_stats^[lrx_miss_err] := lan_stats^[lrx_miss_err]+1; if (MERR or BABL) then begin { fatal failure } card_reset(info,card); card_state := cs_hw_failed; clean_up(io_info,info,lb_hw_failed,lan_all_io); escape(0); { get out now } end; end; with info^ do begin { check for out going data } done := tx_count=0; while not done do begin if check_out(io_info) then begin de_allocate(info); {return space to pool} done := tx_count=0;  end else done := TRUE; end; { try to read any input } lan_read_buffer(info); { check to see if the card should be re-started/re-configured } if do_card_start then card_start(io_info); end; { with info } end; { with card } end; { lan_isr } procedure lan_rds(temp : ANYPTR; reg : io_word; var v: io_word); { READ CARD REGISTERS } type cp = ^char; int_wrd = record case boolean of  TRUE :(i:integer); FALSE:(w1:io_word; w2:io_word); end; var io_info : pio_tmp_ptr; info : lan_info_ptr; card : card_base_ptr; lreg : int_wrd; i : integer; function get_hl(anyvar val:int_wrd; high:boolean):io_word; begin if high then get_hl := val.w1 else get_hl := val.w2; end; begin io_info := temp; with io_info^ do begin info := ADDR(drv_misc); card := card_addr; lreg.w1 := 0; lreg.w2 := reg; with info^ do case lreg.i of L_GET_INTLEVEL: v := card_intlevel; L_CARD_STATE : v := ord(card_state); L_RECONFIG : v := ord(do_card_start); L_MODE : v := init_block.mode.all; L_NUM_RX_BUFS : v := num_rx_buffers; L_RX_BUF_SIZE : v := rx_buffer_size; L_NUM_TX_BUFS : v := num_tx_buffers; L_GET_TX_BUF_SIZE: v := tx_buffer_size;  L_GET_STATS_LSW: v := get_hl(lan_stats,false); L_GET_STATS_MSW: v := get_hl(lan_stats,true); L_GET_FRAME_SIZE: v := last_rx_size; L_LINK_ADDR1..L_LINK_ADDR1+5: v := ord(local_link_address[reg-20]);   L_INPUT_BUSY : v := ord(in_bufptr<>nil); L_OUTPUT_BUSY : v := ord(out_bufptr<>nil); otherwise if (reg>=L_MMASK0) and (reg<=L_MMASK0+63) then begin reg := reg-L_MMASK0; if (reg mod 16) > 7 then reg := reg-8 else reg := reg+8; v := ord(init_block.ladrf.bits[reg]); end else io_escape(ioe_rds_wtc,io_info^.my_isc); end; { case } end; end; { lan_rds } procedure init_lan_stats(var stats:lan_stats_data); var i : lan_stats_type; begin for i := lhw_merr to ltx_retry_err do stats[i]:=0; end; procedure lan_wtc(temp : ANYPTR; reg : io_word; v: io_word); { WRITE TO CARD REGISTERS } type cp = ^char; var io_info : pio_tmp_ptr; info : lan_info_ptr; card : card_base_ptr; lreg : record case boolean of TRUE :(i:integer);  FALSE:(w1:io_word; w2:io_word); end; i : integer; procedure fake_interrupt; var old_level : integer; begin old_level := intlevel; if old_level0; L_MODE : init_block.mode.all := v; L_NUM_RX_BUFS : num_rx_buffers := v; L_RX_BUF_SIZE : rx_buffer_size := v;  L_NUM_TX_BUFS : num_tx_buffers := v; L_SET_MULTICAST_ALL:begin {set/clear all multicast mask bits} if v<>0 then v := -1; { all ones } init_block.ladrf.int1 := v;  init_block.ladrf.int2 := v; end; L_INIT_STATS : init_lan_stats(lan_stats^); L_REJECT_FRAME : copy_bytes := 0; { used to signal packet reject } L_LINK_ADDR1..L_LINK_ADDR1+5:  local_link_address[reg-20] := chr(v); L_SET_UISR : perm_isr := io_info^.user_isr; L_CLEAR_UISR : perm_isr.dummy_pr := nil; L_ABORT : begin{ L_INPUT, L_OUTPUT, L_ALL_IO } case v of L_INPUT : clean_up(io_info,info,lb_abort,lan_input); L_OUTPUT: clean_up(io_info,info,lb_abort,lan_output); L_ALL_IO: clean_up(io_info,info,lb_abort,lan_all_io);  otherwise io_escape(ioe_misc,io_info^.my_isc); end; end; L_SET_MMASK, L_CLR_MMASK : begin if (V<0) or (V>63) then io_escape(ioe_misc,io_info^.my_isc); if (V mod 16) > 7 then V := V-8 else V := V+8; init_block.ladrf.bits[V]:=(lreg.i=L_SET_MMASK);  end; L_SET_DEFAULT_CONFIG : begin if hw_read_local_address(card^,local_link_address) then begin init_block.mode.ALL := default_mode; { prom. etc. all false }   init_block.ladrf := init_ladrf; { initialize the filter to all zeroes } {set rcv variables} rx_buffer_size := default_rx_buffer_size; num_rx_buffers := default_num_rx_buffers; {set tx variables} num_tx_buffers := default_num_tx_buffers; init_lan_stats(lan_stats^); end else begin card_reset(info,card); card_state := cs_hw_failed;  clean_up(io_info,info,lb_hw_failed,lan_all_io); io_escape(ioe_crd_dwn,io_info^.my_isc); end; end; L_SKIP_BYTES : begin { called from user_isr or perm_isr } if v<0 then io_escape(ioe_misc,io_info^.my_isc); if v>=copy_bytes then copy_bytes := 0 else begin skip_bytes := v; copy_bytes := copy_bytes-v;  end; end; otherwise io_escape(ioe_rds_wtc,io_info^.my_isc); end; { case } end; end; { lan_wtc } procedure lan_write_buffer(info : lan_info_ptr);  type cp = ^char; var ubufptr : bp; required : integer; avail1,avail2 : integer; old_level,hi_level : integer; card : card_base_ptr; begin { lan_write_buffer } old_level := intlevel; TRY  with info^, io_temps^ do begin lan_stats^[ltx_requests]:=lan_stats^[ltx_requests]+1; if old_level>card_intlevel then hi_level := old_level else hi_level := card_intlevel; ubufptr := out_bufptr; { snapshot out_bufptr } if ubufptr=nil then escape(0); { request aborted } card := card_addr; if ubufptr^.term_counttx_buffer_size then io_escape(ioe_no_space,io_temps^.my_isc); { will never ever fit } repeat { wait for a ring element and enough space to free up } setintlevel(hi_level); { block ISR during space check } if out_bufptr=nil then escape(0); { request aborted } alloc_ok := false; if tx_count=0 then begin avail1 := tx_buffer_size; avail2 := 0; end else if tx_next.int>tx_used.int then begin avail1 := txd_n.int-tx_next.int; avail2 := tx_used.int-txd_1.int;  end else begin avail1 := tx_used.int-tx_next.int; avail2 := 0; end; alloc_ok := (tx_count=required) or (avail2>=required)); setintlevel(old_level); { let ISR run again } if not alloc_ok then with card^ do begin if old_level>=card_intlevel then begin  repeat until sc_reg.ir; { wait for interrupt request } TRY lan_isr(pisrib(io_temps)); { call the ISR procedure } RECOVER begin end; end; end; until alloc_ok; setintlevel(hi_level); { block ISR until pointers are set } if out_bufptr=nil then escape(0); { request aborted } if not alloc_ok then setintlevel(old_level); { let ISR run } until alloc_ok; { move from ram to the allocated space on the card } with bp(out_bufptr)^ do begin if avail1=txd_n.int then tx_next := txd_1; tx_ring_f := ADDR(tx_ring_f^,sizeof(tx_ring_elt_type)); if tx_ring_f = txr_n then tx_ring_f := txr_1; with bp(out_bufptr)^ do if eot_proc.dummy_pr=nil then begin { cleanup & disconnect now if no eot_proc } term_char := lb_eot; active_isc := no_isc; out_bufptr := nil;  end; tx_user_buffs^[tx_ub_in] := out_bufptr; tx_ub_in := (tx_ub_in+1) mod max_ring_elts; out_bufptr := nil; { disconnect user buffer } setintlevel(old_level); { clean up intlevel } end; { with info^ ... } RECOVER begin setintlevel(old_level); if escapecode<>0 then escape(escapecode); end; { call outbuf_proc if out_bufptr is nil } with info^, io_temps^ do begin if out_bufptr=nil then if outbuf_proc.dummy_pr<>nil then call(outbuf_proc.real_proc,my_isc); end; end; { lan_write_buffer } procedure lan_tfr(temp : ANYPTR; v : ANYPTR); label 1; var io_info : pio_tmp_ptr; info : lan_info_ptr; buffer : BUFxINFOxPTR; utimer : timer_rec; u_reg_rec: iompx_rec_ptr; continue : boolean; need_reg : boolean; { buffer must be registered } begin io_info := temp; info := ADDR(io_info^.drv_misc); buffer := v; with io_info^, buffer^ do begin need_reg := (usr_tfr=dummy_tfr_1) or (usr_tfr=dummy_tfr_2); if need_reg then begin if (lmpx_info=nil) then io_escape(ioe_no_driver,my_isc) else  if act_tfr<>no_tfr then io_escape(ioe_bad_tfr,my_isc); end; term_char := lb_pending; { set for eot proc use } if info^.card_state<>cs_lance_ready then begin if direction = to_memory then in_bufptr := nil else out_bufptr:= nil; term_char := lb_hw_failed; io_escape(ioe_crd_dwn,my_isc); end; if (direction=from_memory) and (lmpx_info<>nil) then begin if (act_tfr=no_tfr) or need_reg then begin call(lmpx_info^.find_iompx_buf, my_isc,direction,buffer^,u_reg_rec); if u_reg_rec<>nil then with u_reg_rec^ do begin if not need_reg then out_bufptr := nil; call(ops_proc,u_reg_rec,continue); if continue then out_bufptr := v else goto 1; { all done } end else { buffer not registered } if need_reg then io_escape(ioe_bad_tfr,my_isc); end; end; if direction=to_memory then begin { read } { is this a registered buffer ? } if lmpx_info<>nil then call(lmpx_info^.find_iompx_buf,  my_isc,direction,buffer^,u_reg_rec) else u_reg_rec := nil; { for optional registered buffers, free in_bufptr now for required reqisteded buffers, ignore in_bufptr then give the ops_proc (checker) a chance to supply the data. } if u_reg_rec<>nil then begin with u_reg_rec^ do begin if not need_reg then in_bufptr := nil; in_buffer := nil; { signal, call comming from iod_tfr } call(ops_proc,u_reg_rec,continue); end end else if need_reg then io_escape(ioe_bad_tfr,my_isc) else continue := true; if continue then begin { da ta to come from ISR } active_isc := my_isc; { let ISR use the buffer } { If the read has not been satisfied and there is data in card buffer(s) then force an interrupt to get data moveing. } if (in_bufptr<>nil) then if iostatus(my_isc,L_GET_FRAME_SIZE)<>0 then iocontrol(my_isc,L_FORCE_INTERRUPT,0); end else begin { ops_proc supplied the data } if term_count=0 then term_char := lb_eot else term_char := lb_short; TRY if eot_proc.dummy_pr<>nil then { call the buffers eot proc } call (eot_proc.real_proc,buffer); RECOVER begin end; goto 1; { all done } end; end { read } else begin { write } active_isc := my_isc; { show transfer in progress } lan_write_buffer(info); end; { write } { check requested tfr mode and either wait or continue } if (usr_tfr<=serial_fastest) then begin { serial transfer } if timeout=0 then repeat until active_isc=no_isc else begin utimer.time := timeout; start_timer(utimer); repeat until (active_isc=no_isc) or time_expired(utimer); if active_isc<>no_isc then io_escape(ioe_timeout,my_isc); end; end; { else overlapped transfer } end; { with io_info^, buffer^ } 1: end; { lan_tfr } function lan_setup(sc : integer):boolean; { this procedure is used only during powerup } var info : lan_info_ptr; card : card_base_ptr; i,nb : integer; d_buf: BUFxINFOxPTR; begin info := ADDR(isc_table[sc].io_tmp_ptr^.drv_misc); card := isc_table[sc].io_tmp_ptr^.card_addr; with info^, init_block do { init_block here is in temp area } begin if hw_read_local_address(card^,local_link_address) then begin card_state := cs_pre_init; mode.ALL := default_mode; { prom etc all false } { copy link address to the init block } { NOTE byte swapping } padr[1]:=local_link_address[2]; padr[2]:=local_link_address[1]; padr[3]:=local_link_address[4]; padr[4]:=local_link_address[3]; padr[5]:=local_link_address[6]; padr[6]:=local_link_address[5]; ladrf:= init_ladrf; { initialize the filter to all zeroes } {set rcv variables} rx_buffer_size := default_rx_buffer_size; num_rx_buffers := default_num_rx_buffers; {set tx variables} num_tx_buffers := default_num_tx_buffers; {set default interface hooks} io_temps := isc_table[sc].io_tmp_ptr; card_intlevel := card^.sc_reg.intlevel+3; do_card_start := FALSE; { card init block etc & copy are same } new(lan_stats); init_lan_stats(lan_stats^); new(tx_user_buffs);  for i := 0 to max_ring_elts-1 do tx_user_buffs^[i]:=nil; tx_ub_in := 0; tx_ub_out := 0; perm_isr.dummy_pr := nil; outbuf_proc.dummy_pr := nil; new(d_buf); newbytes(d_buf^.buf_ptr,lan_max_frame_len);  with d_buf^ do begin {init. the driver buffer} buf_fill := buf_ptr; buf_empty := buf_ptr; term_count := lan_max_frame_len; active_isc := sc; end; driver_buffer := d_buf; end else card_state := cs_hw_failed; end; {with} with isc_table[sc] do begin { hook up the drivers } new(io_drv_ptr); io_drv_ptr^ := dummy_drivers; with io_drv_ptr^ do begin iod_init := lan_init; iod_isr := lan_isr; iod_rds := lan_rds; iod_wtc := lan_wtc; iod_tfr := lan_tfr; end; end; lan_setup := info^.card_state=cs_pre_init; end; {lan_setup} function laninit(var ehp:anyp tr):boolean; var sc, i : integer; lan_card : card_base_ptr; ok : boolean; cp : ^char; begin { laninit } { scan selectcode table for LAN cards } ok := false; for sc := iominisc to iomaxisc do with isc_table[sc] do begin if (card_type=other_card) and ((card_id=0) or (card_id=hp98643)) then begin lan_card := card_ptr; if (lan_card^.id_reg.idb mod 128) = hp98643 then begin  card_id := hp98643; { fix it } TRY { has this card been setup already ? } i := iostatus(sc,l_reconfig); { if the above call worked then driver is already setup } RECOVER { check escape code etc.} if (escapecode=ioescapecode) and (ioe_result=ioe_no_driver) then begin { fixup the heap as required } mark(cp); if ord(cp)iomaxisc then sc := device div 100 else sc := device; if isc_table[sc].io_tmp_ptr=nil then  io_escape(ioe_no_driver,sc); with iompx_info^.isc_iompx_table[sc] do if not capable then io_escape(ioe_no_driver,sc) else if t_dir = to_memory then begin bhead := addr(checkers); btail:= addr(ctail); end else begin bhead := addr(wrappers); btail:= addr(wtail); end; with reg_rec do begin user_buffer := addr(b_info); user_area := user_temps; scode  := sc; in_buffer := nil; ops_proc := operations; end; old_level := intlevel; setintlevel(6); { head insertion or empty list } if front or (bhead^=nil) then begin reg_rec.next := bhead^ ; bhead^ := addr(reg_rec); if btail^=nil then btail^ := bhead^; end else begin { tail insertion into non empty list } reg_rec.next := nil; btail^^.next := addr(reg_rec); btail^ := addr(reg_rec); end; setintlevel(old_level); end; { register_buffer } procedure unregister_buffer(device : type_device; t_dir : dir_of_tfr; VAR b_info : buf_info_type); label 1; var io_isc : type_isc; old_level : integer; back, now : iompx_rec_ptr; bhead, btail : ^iompx_rec_ptr; sc : type_isc; begin if device>iomaxisc then sc := device div 100  else sc := device; if isc_table[sc].io_tmp_ptr=nil then io_escape(ioe_no_driver,sc); with iompx_info^.isc_iompx_table[sc] do if t_dir = to_memory then begin bhead := addr(checkers); btail:= addr(ctail); end else begin bhead := addr(wrappers); btail:= addr(wtail); end; back := nil; old_level := intlevel; setintlevel(6); now := bhead^; while now <> nil do begin if now^.user_buffer = addr(b_info) then begin if back=nil then bhead^ := now^.next else back^.next := now^.next; if now=btail^ then btail^ := back; goto 1; end  else begin back := now; now := now^.next; end; end; 1: setintlevel(old_level); end; { unregister_buffer } procedure copy_buffer_data(var src,dest : buf_info_type; move : integer); var size : integer; begin size := src.term_count; if move>size then move := size; if move>dest.term_count then move := dest.term_count; moveleft(cp(src.buf_empty)^,cp(dest.buf_fill)^,move); src.term_count := src.term_count - move; src.buf_empty := ADDR(cp(src.buf_empty)^,move); dest.term_count := move; dest.buf_fill := ADDR(cp(dest.buf_fill)^,move); end; { copy_buffer_data } procedure scanner(working : BUFxINFOxPTR;  VAR target : BUFxINFOxPTR); var sc : type_isc; regp, nxtp : iompx_rec_ptr; reject : boolean; size : integer; begin target := nil; sc := working^.active_isc; regp := iompx_info^.isc_iompx_table[sc].checkers; while regp<>nil do begin with regp^ do begin nxtp := next; { chain now } if user_buffer^.active_isc=sc then begin in_buffer := working; call(ops_proc,regp,reject); if not reject then begin regp := nil; target := user_buffer; end; end; { if } end; { with } if regp<>nil then regp := nxtp; end; { while } if target=nil then with isc_table[sc].io_tmp_ptr^ do begin if in_bufptr<>nil then if BUFxINFOxPTR(in_bufptr)^.active_isc<>no_isc then begin target := in_bufptr; copy_buffer_data(working^,target^,working^.term_count); end; end; end; { scanner } procedure find_registered_buf(device : type_device; t_dir : dir_of_tfr; VAR b_info : buf_info_type;  VAR reg_rec: iompx_rec_ptr); label 1; var sc : type_isc; begin if device>iomaxisc then sc := device div 100 else sc := device; if t_dir=from_memory then reg_rec := iompx_info^.isc_iompx_table[sc].wrappers else reg_rec := iompx_info^.isc_iompx_table[sc].checkers; while reg_rec<>nil do with reg_rec^ do begin if user_buffer = ADDR(b_info) then goto 1; reg_rec := next; end;    1: end; { find_registered_buf } procedure iompxerr(errorcode : integer; VAR s : io_string); var spp : iompx_ans_ptr; begin if errorcode <> iompx_request then call(old_errlink,errorcode,s)  else begin s := iompx_answer; spp := addr(s); spp^.ptr:= iompx_info; end; end; { iompxerr } function iompx_init(var ehp:anyptr):boolean; var i : integer; begin iompx_init := iompx_info=nil; if iompx_info=nil then begin mark(iompx_info); if ord(iompx_info)>> CLAIM CARD! <<<*) ; * end; * end; * * Remember that the readio operations above * can bus error! * ************************************************* ************************************************* * * One of the arguments to all routines is a * structure I call SCT:select_code_table. * This is a structure allocated by the higher * level Modcal code, the last 34 bytes of * which I INITIALIZE AFTER MODCAL HAS * INITIALIZED THE FRONT PART. * * THE C_ADR FIELD MUST BE INITIALIZED BEFORE * CALLING THIS ROUTINE: * * procedure ALVINIT ( * var SCT: select_code_table ); * * This routine also resets the card. This * routine should be used at INITIALIZE time * but not at RESET (that's CONTROL 0;1). * ************************************************* page ************************************************* * * Equivalences: * * set_serial, clear_serial * CONTROL_BFD(REG<=8) * * serial_line - DIRECT_STATUS(REG<=8) * * set_baud_rate * * ID := DIRECT_STATUS(REG<=3); * DIRECT_CONTROL(REG<=20,VAL<=speed); * if I" D=1 then * DIRECT_CONTROL(REG<=21,VAL<=speed); * * ('speed' must go through a mapping!) * * set_char_length - CONTROL_BFD(REG<=34) * * set_stop_bits - CONTROL_BFD(REG<=35) * * set_parity - CONTROL_BFD(REG<=36) * *  break - DIRECT_CONTROL(REG<=6) * * abort - DIRECT_CONTROL(REG<=125,VAL<=0) * this also aborts transfers! * * clear - DIRECT_CONTROL(REG<=101,VAL<=0) * * ioreset - CONTROL_BFD(REG<=0,VAL<=1) * * readchar - ENTER_DATA(COUNT<=1) * (ENTER_DATA will terminate on * a control block!!!) * * writechar - OUTPUT_DATA(COUNT<=1) * * set_timeout - write to value in * select_code_table (units=1ms) * * LEVEL 2 functions - supersets of readchar * & writechar * * handshake transfer - ENTER_DATA or * OUTPUT_DATA (ENTER_DATA will * terminate on a control block!!!) * * outbound transfer_end - OUTPUT_DATA then *  OUTPUT_END * * inbound transfer_end - ENTER_DATA * * overlapped transfers - set up the transfer * control block and then call * START_TRANSFER_IN or * START_TRANSFER_OUT. * ************************************************* list ttl comdcl: common I/O declarations page include COMDCL list ttl dc_decls: common Data Comm declarations page ******************************************************************************** * Data Comm card RAM locations * * (byte offsets from base address) * RESET_ID equ $000000 INT_DMA equ $000002 SEMAPHORE equ $000004 INT_COND equ $004000 COMMAND equ $004002 DATA_REG equ $004004 PRIMARY_ADDR equ $004006 DSDP equ $004008 ERROR_CODE equ $00400C ************************** Data Structures Descriptor ************************** ATTRIBUTES equ $000000 TR_QUEUE_ADDR equ $000002 PRIM_0_ADDR equ $000006 ****************************** Queue ****************************************** TXENDBLOCKSPACE equ $000000 RXDATABUFF_NUMB equ  $000001 TXBUFF equ $000004 RXBUFF equ $000024 CTRL_AREA equ $000000 DATA_AREA equ $000010 ****************************** Buffer record ********************************** ADDR equ $000000 SIZE equ $000004 FILL equ $000008 EMPTY equ $00000C ****************************** Control block ********************************** POINTER equ $000000 TERMFIELD equ $000004 MODEFIELD equ $000006 CTRLBLKSIZE equ $000008 ****************************** select_code_table ****************************** ovrlaper equ AVAIL_OFF+00 .. 1 ; word usr0mask equ AVAIL_OFF+02 ; byte which_RXbuf equ AVAIL_OFF+03  ; byte last_enter_term equ AVAIL_OFF+04 ; byte last_enter_mode equ AVAIL_OFF+05 ; byte intbits equ AVAIL_OFF+06 ; 8 bits * unused 07 * The following 26 bytes are saved at interrupt term_and_mode equ AVAIL_OFF+08 .. 09 ; Encompasses the two below term equ AVAIL_OFF+08 ; byte mode equ AVAIL_OFF+09 ; byte data_address equ AVAIL_OFF+10 .. 13 ; pointer data_number equ AVAIL_OFF+14 .. 17 ; integer outer_tx_count equ AVAIL_OFF+18 .. 21 ; integer timeout_counter equ AVAIL_OFF+22 .. 25 ; integer inner_counter equ AVAIL_OFF+26 .. 29 ; integer inner_tx_count equ AVAIL_OFF+30 .. 33 ; integer * This is where they are saved: int_savespace equ AVAIL_OFF+34 .. 59 SR_image equ AVAIL_OFF+60 .. 61 ; word RCR_hook equ AVAIL_OFF+62 .. 69 ; procedure err_hook equ AVAIL_OFF+70 .. 77 ; procedure trc_hook equ AVAIL_OFF+78 .. 85 ; procedure bt6_hook equ AVAIL_OFF+86 .. 93 ; procedur# e bt7_hook equ AVAIL_OFF+94 .. 101 ; procedure sctablebytes equ AVAIL_OFF+102 ; size of the entire table for allocation error_int equ 0 ; Bits for interrupt rx_int equ 1 ; register tx_int equ 2 ON_INTR_int  equ 3 RC_reset_int equ 4 trace_int equ 5 ******************************************************************************** list ttl dc_buff: buffer utilities page * **** * * ***** ***** ***** **** *** *  * * * * * * * * * * * * * * * * * * * * * * * **** * * ***** ***** ***** **** *** * * * * * * * * * * * * * *  * * * * * * * * * * **** *** * * ***** * * *** ******************************************************************************** *  * * routine gain_access: gets access to SEMAPHORE on card for buffer * * =========== utilities. If access is not gained in a * * preset time, an escape is performed.  * * * * At entry: * * a3.l = card base address ($00xx0001) * *  * * Upon normal exit: * * If escape performed then * * Timeout occurred * * Otherwise * * Access was gained * * SR has been set to disable all but level 7 interrupt. The * * SR has been pushed on the stack and RELEASE_ACCESS MUST BE * * CALLED AT THE SAME LEVEL ON THE STACK!!!!! * *  * * This bashes d2.l. * * * ******************************************************************************** gain_access equ * move.l (sp)+,d2 ; Get return address trap #11 get into supervisor, save SR scs * scs move sr,-(sp) ; Push on old SR move.l d2,-(sp) ; and push on return address ori #$2700,sr lock out all interrupts scs * scs move.w 4(sp),d2 ; Now get old SR into d2 * scs and.w #$F0FF,d2 ; Strip off old int level * scs or.w #$0600,d2  ; Set interrupt level 6 * scs move d2,sr ; and put into SR btst #timer_present,sysflag2 check if timer present tttt JS beq.s gatimed if so then go use it tttt JS move.l #157500,d2 [CALIBRATED 1 SEC] ; Initialize counter galoop tst.b SEMAPHORE(a3) ; Fetch semaphore bit in bit 7 (sign) bpl.s gadone ; If bit 7 true then done! subq.l #1,d2 ; Loop for preset time bne.s galoop *  Timed out: escape, but first... gaterr addq #4,sp pop return addres scs move (sp)+,sr restore user mode scs * scs move 4(sp),sr ; Get old SR back bra lunched ; Now escape * gatimed tst.b semaphore(a3) first do quick test tttt JS bpl.s gadone before timing tttt JS move.b #1,-(sp) set up timing record tttt JS move.l #  #1000,-(sp) MS followed by boolean tttt JS gatlp1 move.l #254,d2 quick loop -- 1 ms @ 16 MHz tttt JS gatlp2 tst.b semaphore(a3) check semaphore tttt JS bpl.s gatexit if ok then get out tttt JS subq.l #1,d2 else hang in tight loop tttt JS bne gatlp2 tttt JS pea (sp) now check the timer tttt JS jsr check_timer  parameter is ptr to record tttt JS bpl gatlp1 if not timeout do tight loop tttt JS addq #6,sp else fix the stack tttt JS bra gaterr and do timeout escape tttt JS gatexit addq #6,sp normal exit is here tttt JS rts tttt JS page ******************************************************************************** *  * * routine release_access: releases access to SEMAPHORE on card which * * ============== was previously gained with gain_access. * * Read the notes with the above routine to * * see description of stack funnies. * * THIS MUST BE CALLED WITH A BSR INSTRUCTION! * *  * * At entry: * * a3.l = card base address ($00xx0001) * *  * * Upon normal exit: * * no registers are bashed. * * * ******************************************************************************** release_access equ * move.b d0,SEMAPHORE(a3) ; Store don't-care into semaphore. move.w 4(sp),-(sp) switch SR and return address scs tst.b m68ktype is this a 68000? tttt JS bne.s release_10or12 br if not tttt JS move.l 2(sp),4(sp) scs move.w (sp)+,(sp) scs rte restore user mode, return scs * release_10or12 equ * clr.w 6(sp) fake vector offset word where SR was tttt JS rte and do an rte back to user mode tttt JS gadone rts  ; Now return to the return address. page ******************************************************************************** * * * routine find_TRBUF: Sets up pointer in a2 to point to the record * * =========== describing the card's TRBUFF structure. * * * * routine find_TXBUF: Sets up pointer in a2 to point to the record * * =========== describing the card's TXBUFF structure. * * * * routine find_RXBUF: Sets up pointer in a2 to point to the record * * =========== describing the card's RXBUFF structure. * * * * At entry:  * * a3.l = card base address ($00xx0001) * * * * Upon exit: * * $  a2.l = buffer record base address (CTRLBUFF_ADDR, * * CTRLBUFF_SIZE, CTRLBUFF_FILL, CTRLBUFF_EMPTY, * * DATABUFF_ADDR, etc). (shifted, +1+selectcode) * * This bashes a1, d4 and d5. * * * ******************************************************************************** find_TRBUF equ * moveq #0,d5 movea.l #TR_QUEUE_ADDR,a2 bra.s findTR find_TXBUF equ * moveq #TXBUFF,d5 bra.s find find_RXBUF equ * moveq #RXBUFF,d5 find movea.l #PRIM_0_ADDR,a2 findTR clr.l d4 movep.w DSDP(a3),d4 ror.w #7,d4 add.l a3,d4 movea.l d4,a1  ; a1 points to Data Struct Descriptor clr.l d4 adda.l a2,a1 ; add offset to which queue table movep.w 0(a1),d4 ror.w #7,d4 add.l a3,d4 add.l d5,d4 movea.l d4,a2 ; a2 points to buffer record rts page ******************************************************************************** * * * routine find_RX_DATA: Sets up pointers to point to the appropriate * * ============ receive data buffer. This is to be used after * * the routine find_RXBUF which sets up the * * pointer (in a2) to the receive control buffer * *  descriptor record structure. * * * * At entry: * * a3.l = card base address ($00xx0001) * * a2.l = Buffer record base address (CTRLBUFF_ADDR, * * CTRLBUFF_SIZE, CTRLBUFF_FILL, CTRLBUFF_EMPTY, * * DATABUFF0_ADDR, etc). (shifted, +1+selectcode) * * a4.l = pointer to select_code_table structure * * * * Upon exit:  * * a1.l = data area base address (shifted, +1+selectcode) * * d4.l = address of first byte PAST data area (shifted, +1+sc) * * d5.l = XXxxxxBUFF_SIZE (unshifted, not adjusted) * * * ******************************************************************************** find_RX_DATA equ * movea.l #DATA_AREA,a1 clr.l d5 ; compute offset for WHICH rx data move.b which_RXbuf(a4),d5 ; buffer we are using asl.l #4,d5 adda.l d5,a1 bra.s findare ; Now go do the rest of it! page ******************************************************************************** * * * routine find_DATA_AREA: Sets up pointers to point to the data buffer. * * ============== This is to be used in conjunction with the * *  routines find_XXBUF which will set up the * * pointer (in a2) to the buffer we are using. * * THIS SHOULD NOT BE USED WITH THE RECEIVE * *  BUFFER! USE THE PREVIOUS ROUTINE INSTEAD! * * * * routine find_CTRL_AREA: Sets up pointers to point to the ctrl buffer. * * ============== This is to be used in conjunction with the * * routines find_XXBUF which will set up the * * pointer (in a2) to the buffer we are using. * * $  * * At entry: * * a3.l = card base address ($00xx0001) * * a2.l = Data buffer record base address (CTRLBUFF_ADDR, * * CTRLBUFF_SIZE, CTRLBUFF_FILL, CTRLBUFF_EMPTY, * * DATABUFF_ADDR, etc). (shifted, +1+selectcode) * *  * * Upon exit: * * a1.l = data area base address (shifted, +1+selectcode) * * d4.l = address of first byte PAST data area (shifted, +1+sc) * * d5.l = XXxxxxBUFF_SIZE (unshifted, not adjusted) * * * ******************************************************************************** find_DATA_AREA equ * movea.l #DATA_AREA,a1 bra.s findare find_CTRL_AREA equ * movea.l #CTRL_AREA,a1 findare adda.l a2,a1 ; a1 points to data/ctrl part of record clr.l d5 movep.w SIZE(a1),d5 ror.w #8,d5 ; d5 = SIZE in bytes clr.l d4 movep.w ADDR(a1),d4 ror.w #7,d4 add.l a3,d4 movea.l d4,a1 ; a1 points to front of buffer area add.l d5,d4 add.l d5,d4 ; d4 points past end of buffer area rts ttl dc_comm: command module page * *** *** * * * * *** * * **** * * * * * ** ** ** ** * * ** * * * * * * * * * * * * * * * * * * * * * * * * * * * * ***** * ** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *** *** * * * * * * * * **** ******************************************************************************** * * * procedure ALVINIT(var SCT: select_code_table) * *  * ******************************************************************************** alvinit equ * movea.l (sp)+,a0 movea.l (sp)+,a4 pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 move.l #sctablebytes-1-AVAIL_OFF,d2 clrloop clr.b  AVAIL_OFF(a4,d2) dbf d2,clrloop move.b INT_DMA(a3),d0 ; This SR is used to andi.w #$0030,d0 ; set the interrupt level addi.w #$0230,d0 ; equal to that of the asl.w #4,d0 ; card. move.w d0,SR_image(a4) CLR.B WHICH_RXBUF(A4) ; ( SPRyyy TM 6/15/82 ) bsr chk_err ; See if card is giving * ; overlapped error bsr do_reset ; This can escape if card bad bra check_ov_error ; Escape if any error page ******************************************************************************** * * * routine eir: Enables interrupts on this card only.  * * === * * * * At entry: * *  a3.l = card's base address ($00xx0001) * * * * Upon normal exit: * * No registers are changed. * * * ******************************************************************************** eir equ * move.b #$80% ,INT_DMA(a3) ; Set enable-interrupt bit true rts ******************************************************************************** * * * routine dir: Disables interrupts on this card only. * * === * * * * At entry:  * * a3.l = card's base address ($00xx0001) * * * * Upon normal exit:  * * No registers are changed. * * * ******************************************************************************** dir equ * clr.b INT_DMA(a3) ; Clear enable-interrupt bit rts page ************************************************* * * * procedure DIRECT_CONTROL (  * * var SCT: select_code_table; * * REG: 1..127 & 256 & 257; * * VAL: 0..255 ); * * * ************************************************* direct_control equ * movea.l (sp)+,a0 move.w (sp)+,d1 ; VAL move.w (sp)+,d2 ; REG movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 bsr check_ov_error ; Escape if any error move.b d1,DATA_REG(a3) ; Send VAL move.b d2,COMMAND(a3) ; then REG cmp.b #125,d2 bne.s not125 bsr outxfr_done ; For ctrl 125 (abort) bsr inxfr_done ; abort transfers not125 equ * * (tm) mod - 12/02/81 Tim Mikkelsen CMP.W #256,D2 (tm) CHECK FOR ABORT TFR IN BEQ INXFR_DONE (tm) CMP.W #257,D2 (tm) CHECK FOR ABORT TFR OUT BEQ OUTXFR_DONE (tm) btst #timer_present,sysflag2 check if timer present tttt JS beq.s ctltime  if so then go use it tttt JS move.l #181851,d0 [CALIBRATED 1 SEC] ; Now start counter for timeout ctloop tst.b COMMAND(a3) beq.s ctldun ; Done when COMMAND=0 subq.l #1,d0 bne.s ctloop ; Otherwise decrement counter bra lunched ; & escape ctldun bra check_ov_error ctltime move.b #1,-(sp) set up timer record tttt JS 8/11/83 move.l #1000,-(sp) tttt JS 8/11/83 ctltlop tst.b command(a3) see if done tttt JS 8/11/83 beq.s ctlexit if so then return tttt JS 8/11/83 pea (sp) else push pointer to time rec tttt JS 8/11/83 jsr check_timer and see if timed out yet tttt JS 8/11/83 bpl ctltlop no -- keep trying tttt JS 8/11/83 addq #6,sp yes, give one more try tttt JS 5/3/84 moveq #10,d0 using short count tttt JS 5/3/84 bra ctloop in normal timing loop tttt JS 5/3/84 ctlexit addq #6,sp normal exit -- clean stack tttt JS 8/11/83 bra check_ov_error and go check errors tttt JS 8/11/83 page ************************************************* * * * procedure DIRECT_STATUS ( * * var SCT: select_code_table; * * REG: 1..127; * * var VAL: word ); * * * * These registers are intercepted: * * 0: Gives value from RESET_ID * * 1: Returns true if hardware interrupts * * 2: Returns bit 2 = in xfr a% ctive; * * bit 3 = out xfr active * * 5: Returns 2 bits saying state of Rx * * buffer * * 9: Returns last ENTER TERM * * 10: Returns last ENTER MODE  * * 11: Returns # bytes available in Tx * * queue, or 0 if there's not 3 * * control block positions available * * * ************************************************* direct_status equ * movea.l (sp)+,a0 movea.l (sp)+,a1 ; addr(VAL) move.w (sp)+,d0 ; REG movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 bsr check_ov_error ; Escape if any error clr.w d1  ; d1 will hold result move.l a1,-(sp) tst.b d0 beq.s sts0 cmpi.b #2,d0 ; Check for intercepted regs blt.s sts1 beq.s sts2 cmpi.b #5,d0 beq.s sts5 cmpi.b #9,d0 beq.s sts9 cmpi.b #10,d0 beq.s sts10 cmpi.b #11,d0 beq.s sts11 add.b #128,d0 move.b d0,term(a4) ; Send TERM bsr direct_command move.b mode(a4),d1 gotsts movea.l (sp)+,a1 move.w d1,(a1) ; Return value bra check_ov_error * * Special intercepted registers * sts0 move.b RESET_ID(a3),d1 bra.s gotsts sts1 btst #7,INT_DMA(a3) sne d1 and.w #$0001,d1 bra.s gotsts sts2 movea.l BUFI_OFF(a4),a2 move.l a2,d0 beq.s sts2a bset #2,d1 sts2a movea.l BUFO_OFF(a4),a2 move.l a2,d0 beq.s gotsts bset #3,d1 bra.s gotsts sts5 bsr find_RXBUF bsr dir bsr RX_stuff_avail move.w d0,d1 bsr eir bra.s gotsts sts9 move.b last_enter_term(a4),d1 bra.s gotsts sts10 move.b last_enter_mode(a4),d1 bra.s gotsts sts11 bsr find_TXBUF bsr dir bsr find_CTRL_AREA bsr TXCTRLBUFFroom clr.w d1 subi.l #12,d3 blt.s gotsts bsr find_DATA_AREA bsr TXDATABUFFroom move.w d3,d1 bsr eir bra gotsts page ******************************************************************************** * * * routine put_INTMASK: Sends the value in usr0mask to the card. * * =========== * * * * At entry: * * a3.l = card base address ($00xx0001) * * a4.l = address of sc_subtabletype structure * * sc_subtabletype.usr0mask has value to send to card. * *  * * This bashes term and mode in the select code subtable. * * * * This bashes d0.  * * * ******************************************************************************** put_INTMASK equ * move.b #121,term(a4) ; Send the new driver interrupt mask move.b usr0mask(a4),mode(a4) ; down with control #121 *** bra direct_command ******************************************************************************** *  * * routine direct_command * * ============== * * * *  Uses: a3.l = Base address of card * * a4.l = Address of SCT: select_code_table * * * * This bashes d0. &  * * * ******************************************************************************** direct_command equ * move.b mode(a4),DATA_REG(a3) move.b term(a4),COMMAND(a3) ; Send TERM btst #timer_present,sysflag2 is timer available? tttt JS 8/11/83 beq.s dctime if so go use it tttt JS 8/11/83 move.l #181851,d0 [CALIBRATED 1 SEC] ; Now start counter for timeout dcloop tst.b COMMAND(a3) beq.s dcdone ; Done when COMMAND=0 subq.l #1,d0 bne.s dcloop ; Otherwise decrement counter bra lunched ; & escape dcdone move.b DATA_REG(a3),mode(a4) rts dctime move.b #1,-(sp) set up timer record tttt JS 8/11/83 move.l #1000,-(sp) for 1 sec wait tttt JS 8/11/83 dctloop tst.b command(a3) see if done  tttt JS 8/11/83 beq.s dctexit if so then return tttt JS 8/11/83 pea (sp) check timer tttt JS 8/11/83 jsr check_timer tttt JS 8/11/83 bpl dctloop  if not timeout, br tttt JS 8/11/83 addq #6,sp timeout, clean stk tttt JS 5/3/84 moveq #10,d0 and try once more tttt JS 5/3/84 bra dcloop with short count tttt JS 5/3/84 dctexit addq #6,sp normal exit, cleanup tttt JS 8/11/83 bra dcdone and return tttt JS 8/11/83 page ******************************************************************************** *  * * routine get_INTMASK: Reads the value of usr0mask from the card. * * =========== * *  * * At entry: * * a3.l = card base address ($00xx0001) * * a4.l = address of sc_subtabletype structure * * * * At exit: * * sc_subtabletype.usr0mask has value from the card. * * * * This bashes term and mode in the select code subtable. * *  * * This bashes d0. * * * ******************************************************************************** get_INTMASK equ * move.b #121+128,term(a4) ; Get the current interrupt mask bsr direct_command move.b mode(a4),usr0mask(a4) ; from register #121 rts ******************************************************************************** * * * do_reset: resets the card, waits for it to complete powerup and * * ======== then gets INTMASK again. * *  * * Uses: a3.l = Base address of card * * a4.l = Address of SCT: select_code_table * *  * * This leaves interrupts ENABLED * * * * This bashes d0. &  * * * ******************************************************************************** do_reset equ * bsr outxfr_done ; Abort transfers bsr inxfr_done bsr dir ; Disable card interrupts to prevent * ; conflicts move.b #$80,RESET_ID(a3) ; Send reset ($80) to card bsr gain_access ; Wait until SEMAPHORE is freed bsr release_access ; and then give it back bsr get_INTMASK bra eir page ******************************************************************************** *  * * routine check_ov_error: If the 'ovrlaper' location is nonzero then * * ============== this escapes with that error. * *  * * Uses: a3.l = Base address of card ($00xx0001) * * a4.l = Address of SCT: select_code_table * * * * This leaves interrupts ENABLED * * * ******************************************************************************** check_ov_error equ * bsr dir move.l d0,-(sp) clr.l d0 move.w ovrlaper(a4),d0 clr.w ovrlaper(a4) bsr eir tst.w d0 bne.s escape move.l (sp)+,d0 rts ****************************** Escapes ***************************************** lunched equ * moveq #crd_dwn,d0 bra.s escape time_err equ * moveq #tmo_err,d0 ******************************************************************************** * * *  routine escape: performs Pascal "escape" function. Error exit * * ====== number is to be passed in d0. * * * * Uses: a3.l = Base address of card * * a4.l = Address of SCT: select_code_table * * a5.l = Global pointer for escape arguments * * d0.l = Escape number * * * * This leaves interrupts ENABLED * *  * ******************************************************************************** escape equ * ; Escape point for errors move.l d0,IOE_RSLT(a5) clr.l d5 ; Tim's magic escape stuff move.b IO_SC(a4),d5 move.l d5,IOE_SC(a5) move.w #IOE_ERROR,ESC_CODE(a5) move.b #$80,INT_DMA(a3) ;Re-enable card interrupts if off trap #10 ttl dc_inter: hardware interrupt handler page * ***** * * ***** ***** ****  **** * * **** ***** * * ** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ** * *** **** **** * * ****  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ***** * * * ***** * * * * *** * * ******************************************************************************** * * * DATA COMM CARD TOP LEVEL INTERRUPT SERVICE ROUTINE * * '  * * This is reached thru the softpoll table for the appropriate * * interrupt level. * *  * * This handles a hardware interrupt from the data comm card. First it * * enquires to find out what interrupt conditions are pending, then it * * calls the appropriate routines to handle the conditions. * * * * At entry: * * a5.l = pointer to globals area  * * * * During this routine: * * a3.l = card's base address ($00xx0001) * *  a4.l = address of sc_subtabletype structure * * * ******************************************************************************** top_isr equ * movea.l (sp)+,a0 ; Save return addr movea.l (sp)+,a4 ; Get sc_subtabletype pea (a0) ; Replace ret addr movea.l C_ADR(a4),a3 ; Get card base addr addq.l #1,a3 ; Now a3.l = OUR base address of card ********** TRY SECTION: RECOVER IS AT END OF ISR movem.l a3/a4,-(sp) move.l RCVR_BLK(a5),-(sp) move.l a6,-(sp) pea recover_section move.l sp,RCVR_BLK(a5) ********** END OF 'TRY' keyword move.w term_and_mode(a4),int_savespace(a4) movem.l term_and_mode+2(a4),d0-d5 movem.l d0-d5,int_savespace+2(a4) move.b INT_COND(a3),intbits(a4) ;Get all the interrupt condition bits * From now on, each handler routine checks for its particular interrupting * condition and then jumps to the next. This is done primarily for speed. page ******************************************************************************** * * * routine remcont_reset_isr: Takes care of communicating a * * ================= card's remote-control-reset to the * * operating system * *  * ******************************************************************************** remcont_reset_isr equ * btst #RC_reset_int,intbits(a4) ; Test for bit #4 for this condition beq.s error_isr lea RCR_hook(a4),a1 bsr try_hook ******************************************************************************** * * * routine error_isr: Handles the communication of an error from the * * ========= interface card back to BASIC, or the hook. * * * * At entry: * * a3.l = card base address ($00xx0001) * * a4.l = address of SCT: select_code_table * * * * Upon normal exit:  * * * * The 'chk_err' routine is used also at powerup time. * *  * ******************************************************************************** error_isr equ * btst #error_int,intbits(a4) ; Test for bit #0 for this condition beq.s data_rx_isr bsr chk_err bra.s data_rx_isr chk_' err clr.w d0 move.b ERROR_CODE(a3),d0 ; fetch error number beq.s errdone ; ignore ERROR_CODE=0 clr.b ERROR_CODE(a3) add.w #300,d0 ; add offset move.w d0,ovrlaper(a4) lea err_hook(a4),a1 bsr try_hook errdone rts page ******************************************************************************** * * * routine data_rx_isr: Handles moving received data to the user's * * =========== buffer for an inbound TRANSFER. * * * ********************************************************************************  data_rx_isr equ * btst #rx_int,intbits(a4) ; Test for bit #1 for this condition beq.s data_tx_isr bsr do_inxfr ******************************************************************************** *  * * routine data_tx_isr: Handles moving transmit data from the user's * * =========== buffer to the card for an outbound TRANSFER. * *  * ******************************************************************************** data_tx_isr equ * btst #tx_int,intbits(a4) ; Test for bit #2 for this condition beq.s ON_INTR_isr bsr do_outxfr ******************************************************************************** * * * routine ON_INTR_isr: Handles the communication of an ON INTR trigger * * =========== from the interface card back to BASIC. * * * ******************************************************************************** ON_INTR_isr equ * btst #ON_INTR_int,intbits(a4) ; Test for bit #3 for this condition beq trace_isr bclr #ON_INTR_int,usr0mask(a4) beq.s OIisr1 ; If already 0 don't send again bsr put_INTMASK OIisr1 lea USER_ISR(a4),a1 bsr try_hook_P (TM) 7/30/82 bug 158 trace_isr equ * btst #trace_int,intbits(a4) ; Test for bit #5 for this condition beq.s bit_6_isr lea trc_hook(a4),a1 bsr try_hook bit_6_isr equ * btst #6,intbits(a4) ; Test for bit #6 for this condition beq.s bit_7_isr lea bt6_hook(a4),a1 bsr try_hook page bit_7_isr equ * btst #7,intbits(a4) ; Test for bit #7 for this condition beq.s end_isr lea bt7_hook(a4),a1 bsr try_hook * -------------------------- End of the ISR ------------------------------------ end_isr equ * ********** RECOVER SECTION FROM 'TRY' ABOVE ***** move.l 8(sp),RCVR_BLK(a5) adda.l #12,sp bra.s rcvdone recover_section equ * ; On escape, flag overlapped error movea.l (sp)+,a6 ; to background move.l (sp)+,RCVR_BLK(a5) * Body of 'RECOVER' block: cmpi.w #IOE_ERROR,ESC_CODE(a5) bne.s rcvdone ; Throw away non-I/O errors move.b IO_SC(a4),d0 cmp.b IOE_SC(a5),d0 bne.s rcvdone move.w IOE_RSLT(a5),ovrlaper(a4) * That was it! rcvdone movem.l (sp)+,a3/a4 bsr eir move.w int_savespace(a4),term_and_mode(a4) movem.l int_savespace+2(a4),d0-d5 movem.l d0-d5,term_and_mode+2(a4) rts ; Return from ISR try_hook move.l (a1),d0 beq.s hook1 movem.l a3/a4,-(sp) movea.l d0,a0 HOOK4 move.l 4(a1),d0 (tm) 12/03/81 beq.s hook3 (tm) If there is static link - push it move.l d0,-(sp) (tm) Roger Ison said this is okay hook3 jsr (a0) hook2 movem.l (sp)+,a3/a4 hook1 rts try_hook_P move.l (a1),d0 (TM) 7/30/82 bug 158 beq.s hook1 movem.l a3/a4,-(sp) movea.l d0,a0 MOVE.L 8(A1),-(SP) (TM) 7/30/82 bug 158 BRA HOOK4 (TM) 7/30/82 b( ug 158 page ************************************************* * * * routine do_inxfr: Transfers data in until: * * - User buffer filled; * * - Card buffer empty; or  * * - Control block reached. * * * * At entry: * * a3.l = card base address ($00xx0001) * * a4.l = address of select_code_table * * * ************************************************* do_inxfr equ * movea.l BUFI_OFF(a4),a2 beq inxdone move.l TCNT_OFF(a2),data_number(a4) beq inxdn1 move.l TFIL_OFF(a2),data_address(a4)  inxfr1 bsr find_RXBUF ; Set up a2.l = buffer descriptor record * base address inxfr4 bsr RX_stuff_avail ; See if buffer is empty tst.b d0 ; If so, just sit here & wait beq inxexit bsr ctrlblknext ; If a control block is next, then tst.b d0 bne.s inxfr3 tst.l data_number(a4) ; see if chars to transfer beq.s inxdone ; yes, go do it movea.l BUFI_OFF(a4),a1 move.w TCHR_OFF(a1),d0 ; Check for term char desired bge.s inxfr5 ; Yes - goto slow section bsr getchars ; move some data * ; & go back to check for ctrl blk bra.s inxfr1 inxfr5 equ * ; SLOW ENTER - search for char  move.b d0,-(sp) ; Save search char move.l data_number(a4),-(sp) move.l #1,data_number(a4) bsr getchars move.l (sp)+,data_number(a4) subq.l #1,data_number(a4) move.b (sp)+,d0 ; Check for term chr movea.l data_address(a4),a0 cmp.b -1(a0),d0 ; If equal, exit beq.s inxdone bra.s inxfr1 inxfr3 bsr getctrlblk ; Get it, and check for the special cmpi.b #255,term(a4) ; case TERM=255 bne.s inxfr2 move.b mode(a4),which_RXbuf(a4) ;If so, do the buffer switch bra.s inxfr1 ; And go back for more inxfr2 move.w term_and_mode(a4),last_enter_term(a4) * ; Otherwise save the control block & leave movea.l BUFI_OFF(a4),a2 tst.b TEND_OFF(a2) ; If EOI term bit set tghen beq.s inxfr1 ; leave else ignore inxdone movea.l BUFI_OFF(a4),a2 move.l data_address(a4),TFIL_OFF(a2) move.l data_number(a4),TCNT_OFF(a2) inxdn1 bsr inxfr_done move.l a2,d0 beq.s inxex1 lea T_PR_OFF(a2),a1 bra try_hook_P (TM) 7/30/82 bug 158 inxexit equ * movea.l BUFI_OFF(a4),a2 move.l data_address(a4),TFIL_OFF(a2) move.l data_number(a4),TCNT_OFF(a2) beq.s inxdn1 BUG 1249 TM 01/08/82 inxex1 rts page ************************************************* * * * routine do_outxfr: Transfers data out til: * * - User buffer emptied; or * * - Card buffer filled. * *  * * At entry: * * a3.l = card base address ($00xx0001) * * a4.l = address of select_code_table * * * * During execution: * * a2.l = address of xfr record * * * ************************************************* do_outxfr equ * movea.l BUFO_OFF(a4),a2 move.l a2,d0 beq.s  outxex1 move.l TCNT_OFF(a2),data_number(a4) beq.s outxd0 move.l TEMP_OFF(a2),data_address(a4) bsr find_TXBUF ; a2 = buff descr rec addr outx1 move.l data_number(a4),-(sp) bsr putchars ; Send some chars move.l (sp)+,d0  cmp.l data_number(a4),d0 beq.s outxit ; If no chars transferred tst.l data_number(a4) ; then exit bne.s outx1 ; Check buffer empty outxdun movea.l BUFO_OFF(a4),a2 move.l data_address(a4),TEMP_OFF(a2) move.l data_number(a( 4),TCNT_OFF(a2) outxd0 movea.l BUFO_OFF(a4),a2 tst.b TEND_OFF(a2) ; Check for END termination beq.s outxdn1 bsr find_TXBUF ; a2 = buff descr rec addr bsr try_sending_EOF tst.b d0 ; If couldn't send it then beq.s outxex1 ; return, wait for next interrupt outxdn1 bsr outxfr_done move.l a2,d0 beq.s outxex1 lea T_PR_OFF(a2),a1 bra try_hook_P (TM) 7/30/82 bug 158 outxit movea.l BUFO_OFF(a4),a2 move.l data_address(a4),TEMP_OFF(a2) move.l data_number(a4),TCNT_OFF(a2) outxex1 rts page ************************************************* * * * routine outxfr_done: Terminates the * * outbound transfer, if any. * * * * routine inxfr_done: Terminates the inbound * * transfer, if any. * * * * At entry:  * * a3.l = card base address ($00xx0001) * * a4.l = address of select_code_table * * * ************************************************* outxfr_done equ * bclr #tx_int,usr0mask(a4) beq.s outxd1 ; If already 0 don't send again bsr put_INTMASK outxd1 lea BUFO_OFF(a4),a0 bra.s xfrdun inxfr_done equ * bclr #rx_int,usr0mask(a4) beq.s inxd1 ; If already 0 don't send again bsr put_INTMASK inxd1 lea BUFI_OFF(a4),a0 xfrdun movea.l (a0),a2 move.l a2,d0 beq.s rtsin move.b #255,T_SC_OFF(a2) clr.b TACT_OFF(a2) clr.l (a0) rtsin rts page ************************************************* *  * * routine wait_outxfrdone: waits until an * * outbound transfer is complete * * (if any). Also has timeout * * escape. * *  * * routine wait_inxfrdone: waits until an * * inbound transfer is complete * * (if any). Also has timeout * * escape. * * * *  At entry: * * a3.l = card base address ($00xx0001) * * a4.l = address of select_code_table * * * * This bashes nothing. * *  * * This routine may escape! * * * * MODIFIED by Tim Mikkelsen 12/02/81 * * from 12/01/81 code to 11/23/81 * *  * ************************************************* wait_outxfrdone equ * movem.l d0/d2/a0,-(sp) movea.l BUFO_OFF(a4),a0 bra.s wait wait_inxfrdone equ * movem.l d0/d2/a0,-(sp) movea.l BUFO_OFF(a4),a0 wait move.l a0,d2 ; 0=no xfr block beq.s waitdun cmpi.b #5,TUSR_OFF(A0) ; >4 = interrupt blt.s waitdun move.l timeout(a4),d2 btst #timer_present,sysflag2 is timer available ? tttt JS 8/11/83 beq.s wait_timer if so then use it tttt JS 8/11/83 wait1 move.l #256,d0 [UNCALIBRATED] - guess based upon check_tfr loop wait2 tst.b TACT_OFF(a0) ; 0=inactive (tm) tst.l -> tst.b beq.s waitdun subq.l #1,d0 ; Timeout computation bne.s  wait2 tst.l d2 beq.s wait1 subq.l #1,d2 bug fix -- was d0 tttt JS 8/11/83 bne.s wait1 bra time_err waitdun movem.l (sp)+,d0/d2/a0 rts wait_timer equ * tst.l d2 check for infinite timeout tttt JS 8/11/83 beq wait1 use loops if infinite tttt JS 8/11/83 move.b #1,-(sp) set up timer record tttt JS 8/11/83 move.l d2,-(sp) d2 has ms to wait tttt JS 8/11/83 wait3 tst.b tact_off(a0) xfr)  done? tttt JS 8/11/83 beq.s wait4 if so then exit loop tttt JS 8/11/83 pea (sp) push ptr to time rec tttt JS 8/11/83 jsr check_timer and check the timer tttt JS 8/11/83 bpl  wait3 if no timeout, keep trying tttt JS 8/11/83 bra time_err timeout -- go escape tttt JS 8/11/83 wait4 addq #6,sp normal exit -- clean stack tttt JS 8/11/83 bra waitdun and return  tttt JS 8/11/83 page ************************************************* * * * procedure START_TRANSFER_IN ( * * var SCT: select_code_table ); * *  * * This starts the card doing a transfer. * * The calling code must have already * * linked the transfer block in to the * * select_code_table structure. * *  * * During use: * * a3.l = card base address ($00xx0001) * * a4.l = address of select_code_table * * * ************************************************* START_TRANSFER_IN equ * movea.l (sp)+,a0 movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 trap #11 get into supervisor mode scs * scs move sr,-(sp) ; Funny code to disable move SR_image(a4),sr ; interrupts bset #rx_int,usr0mask(a4) bsr put_INTMASK bsr do_inxfr move (sp)+,sr bra check_ov_error ; Will enable ints page ************************************************* *  * * procedure START_TRANSFER_OUT ( * * var SCT: select_code_table ); * * * * This starts the card doing a transfer. * * The calling code must have already * * linked the transfer block in to the * * select_code_table structure. * * * * During use: * * a3.l = card base address ($00xx0001) * * a4.l = address of select_code_table * * * ************************************************* START_TRANSFER_OUT equ * movea.l (sp)+,a0 movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 trap #11 scs * scs move sr,-(sp) ; Funny code to disable move SR_image(a4),sr ; interrupts bset #tx_int,usr0mask(a4) bsr put_INTMASK bsr  do_outxfr move (sp)+,sr bra check_ov_error ; Will enable ints ttl dc_rxbuf: Rx buffer utilities page * **** * * **** * * ***** ***** ***** **** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **** * **** * * ***** ***** ***** **** * * * * * * * * * * * * * * * * * * * * * *  * * * * * * * * * * * **** *** * * ***** * * ******************************************************************************** *  * * routine set_RXBUF_a6: Routine to set a6 as the base address * * ============ pointer to whichever Rx buffer is being used. * *  * * At entry: * * a2.l = data buffer base address (shifted, +1+selectcode) * * a3.l = card base address ($00xx0001) * * )  a4.l = pointer to sc_subtabletype structure * * * * Upon exit: * * a6.l =  Base address of DATA_BUFFERS[WHICH_RXBUF] * * This also bashes d0. * * * ******************************************************************************** set_RXBUF_a6 equ * clr.l d0 ; Setup d0.l=offset move.b which_RXbuf(a4),d0 ; to which Rx buffer asl.l #4,d0 ; being used lea DATA_AREA(a2,d0),a6 rts page ******************************************************************************** * * * routine RX_BUFF_bytes: Function which returns the number of * *  ============= characters until the first control block in * * the Receive Buffer. If there are no control * * blocks, this just returns the number of * *  characters in the buffer. This only works * * on the current Rx data buffer, and does not * * extract TERM=255 control blocks! * *  * * At entry: * * a2.l = data buffer base address (shifted, +1+selectcode) * * a3.l = card base address ($00xx0001) * * a4.l = pointer to sc_subtabletype structure * * * * Upon exit:  * * d0.l = Number of characters. * * a1, d4 and d5 are left with values from find_RX_DATA. * * This also bashes a0, d1 and d2.  * * * * This routine uses the card's SEMAPHORE to gain access. * * * * This routine calls gain_access, release_access, and find_RX_DATA. * * * ******************************************************************************** RX_BUFF_bytes equ *  bsr find_RX_DATA ; Setup a1 = data buffer base addr * d4 = end of data buffer addr * d5 = RXDATABUFF_SIZE move.l a6,-(sp) bsr set_RXBUF_a6 clr.l d0 ; Get garbage out of top of d0, d1 clr.l d1 movep.w CTRL_AREA+EMPTY(a2),d1 ; Fetch pointers (bytes in wrong order) bsr gain_access ; Need access to FILL pointers movep.w FILL(a6),d0 movep.w CTRL_AREA+FILL(a2),d2 bsr release_access cmp.w d2,d1 ; If the two ctrl block pointers are not beq.s RBb1 ; equal, then we want to use the pointer ror.w #7,d1 ; field from the next control block to  add.l a3,d1 ; indicate how much data may be removed movea.l d1,a0 movep.w POINTER(a0),d0 ; --- Use it as the "FILL" pointer RBb1 ror.w #8,d0 ; Switch bytes for FILL movep.w EMPTY(a6),d1 ; and get EMPTY and switch bytes ror.w #8,d1 ; d0="FILL", d1=EMPTY sub.w d1,d0 ; Compute d0 := FILL-EMPTY bge.s RBb2 add.w d5,d0 ; If negative, add data buffer size RBb2 movea.l (sp)+,a6 * rts ; Now d0 = ("FILL"-EMPTY) mod SIZE --- of data buffer page ******************************************************************************** * * * routine getctrlblk: Routine which gets a control block from the * * ========== Receive buffer. It must have already been * * determined that there is a control block at * * the front of the buffer, since this routine * * does NOT check for that condition. The TERM * * and MODE fields of the removed block are left * * in the appropriate (.term and .mode) in the * * sc_subtabletype structure. * * * * At entry:  * * a2.l = RX buffer record base address from find_RXBUF * * a3.l = card base address ($00xx0001) * * a4.l = pointer to sc_subtabletype structure  * * * * Upon exit: * * sc_subtabletype.term = TERM field of control block (8 bits) * *  sc_subtabletype.mode = MODE field of control block (8 bits) * * a1, d4 and d5 are left with the values from find_CTRL_AREA. * * This bashes d0, d2, and a0. * *  * * This routine uses the card's SEMAPHORE to gain access. * * * * This routine calls gain_access, release_access, and find_CTRL_AREA. * * * ******************************************************************************** getctrlblk equ * bsr find_CTRL_AREA  ; Setup a1 = ctrl buffer base addr * d4 = end of ctrl buffer addr * d5 = TRCTRLBUFF_SIZE clr.l d0 ; Clear top of d0 movep.w CTRL_AREA+EMPTY(a2),d0 ; Get control buffer EMPTY pointer ror.w #7,d0 ; Now make it into a 68000 pointer add.l a3,d0 movea.l d0,a0 ; Move to a0 so we can use it move.b TERMFIELD(a0),term(a4) ; Store term & mode fields move.b MODEFIELD(a0),mode(a4) add.w #CTRLBLKSIZE,d0 ; Bump pointer by control block size cmp.w d0,d4 ; and check for wraparound. bne.s gcb1 move.w a1,d0 ; If so, set to front of buffer gcb1 bclr  #0,d0 ; Make it into a Z80 rol.w #7,d0 ; type pointer with bytes reversed bsr gain_access ; Now store the updated EMPTY pointer movep.w d0,CTRL_AREA+EMPTY(a2) bsr release_access rts ;<<d3 then set d0 := d3 bgt.s gc1 move.l d3,d0 gc1 move.l data_number(a4),d2 ; Fetch number of positions available cmp.l d0,d2 ; If d0>d2 then set d0 := d2 bgt.s gc2 move.l d2,d0 gc2 move.l d0,d3 ; d3.l saves number of chars actually * ; transferred below beq.s gcdone ; If zero, no work to be done clr.w last_enter_term(a4) ; This also clears last_enter_mode. subq.w #1,d0 ; Make offset correct for dbf instr. movea.l data_address(a4),a0 ; Get character pointer into a0 gcloop move.b (a2),(a0)+ ; Transfer a character & bump dest ptr addq.w #2,a2 ; Bump source pointer (odd bytes) dbf d0,g+ cloop ; Then decrement d0 & loop sub.l d3,d2 ; Decrement datacnt by # bytes move.l d2,data_number(a4) ; Now store adjusted address and move.l a0,data_address(a4) ; number fields move.l a2,d1  ; Store pointer for computations cmp.l a2,d4 ; Now check to see if EMPTY was moved bne.s gc3 ; past end of buffer. If so, set to move.l a1,d1 ; the front of the buffer. gc3 bclr #0,d1 ; Fix up the 68000 pointer to be the rol.w #7,d1 ; card's type of pointer bsr gain_access movep.w d1,EMPTY(a6) ; Remember d1 = card's EMPTY pointer. bsr release_access gcdone movem.l (sp)+,a6/a2 rts page ******************************************************************************** * * * routine RX_stuff_avail: Routine which determines whether there is  * * ============== ANYTHING (data or control blocks) in the * * Receive buffer. This consumes any TERM=255 * * control blocks before returning the function. * *  * * At entry: * * a2.l = RX buffer record base address from find_RXBUF * * a3.l = card base address ($00xx0001) * * a4.l = pointer to sc_subtabletype structure * * * * Upon exit:  * * d0.l = $00 if buffer is empty, * * $01 if ctrl buffer is empty and data buffer is not, * * $02 if data buffer is empty and ctrl buffer is not, * * $03 if both data and ctrl buffers are not empty. * * a1 and d4 are left with the values from find_RX_DATA. * * This bashes d0, d1, d2, d3, d4, d5, a0 and a1. * * * * This routine uses the card's SEMAPHORE to gain access. * *  * * This routine calls gain_access and release_access. * * * ******************************************************************************** RX_stuff_avail equ * bsr find_RX_DATA ; Setup a1 = data buffer base addr * d4 = end of data buffer addr * d5 = RXDATABUFF_SIZE move.l a6,-(sp) bsr  set_RXBUF_a6 bsr gain_access movep.w FILL(a6),d3 ; Fetch FILL & EMPTY (bytes reversed but movep.w CTRL_AREA+FILL(a2),d1 bsr release_access ; we're just checking equality) clr.l d2 clr.l d0 movep.w CTRL_AREA+EMPTY(a2),d2 cmp.w d1,d2 ; Compare ctrl buff FILL & EMPTY bne.s setbit1 ; If not equal, then set bit 1 chkdata movep.w EMPTY(a6),d2 cmp.w d3,d2 ; Compare data buff FILL & EMPTY beq.s return addq.b #1,d0 ; And set bit 0 if not equal return movea.l (sp)+,a6 rts setbit1 addq.b #2,d0 ; Set "ctrl not empty" bit ror.w #7,d2 ; Something in control buffer - see if *  ; this control block is at the head of add.l a3,d2 ; the queue (bytes reversed!) movea.l d2,a0 movep.w POINTER(a0),d1 movep.w EMPTY(a6),d2 cmp.w d2,d1 ; if POINTER field<>DATABUFF_EMPTY bne.s chkdata +  ; then go check data buff cmpi.b #255,TERMFIELD(a0) ; else if it's a TERM=255 control block bne.s chkdata ; No, go back and check data buff bsr getctrlblk ; Otherwise consume the control block move.b mode(a4),which_RXbuf(a4) ;and switch to new data buffer movea.l (sp)+,a6 bra.s RX_stuff_avail ; And go back and re-compute result page ******************************************************************************** *  * * routine ctrlblknext: Routine which determines whether the next * * =========== thing to be consumed from the Receive buffer * *  is a control block. THE RESULT OF THIS * * FUNCTION IS NOT VALID UNLESS RX_BUFFER_empty * * RETURNS FALSE!!! * *  * * At entry: * * a2.l = RX buffer record base address from find_RXBUF * * a3.l = card base address ($00xx0001)  * * * * Upon exit: * * d0.b = $FF if control block is next, $00 if data is next. * * This bashes d2, d5 and a0. * * * ******************************************************************************** ctrlblknext equ * bsr gain_access movep.w CTRL_AREA+FILL(a2),d2 ; Check if ctrl buffer is empty bsr release_access clr.l d0 movep.w CTRL_AREA+EMPTY(a2),d0 ; Fetch ctrl buffer EMPTY pointer cmp.w d0,d2 ; If equal then return d0.b=$00 beq.s cbn1 ror.w #7,d0 add.l a3,d0 movea.l d0,a0 movep.w POINTER(a0),d0 ; Fetch the POINTER field from the clr.l d5 ; Setup d5.l=offset move.b which_RXbuf(a4),d5 ; to which Rx buffer asl.l #4,d5 ; being used movem.l d0/a6,-(sp) bsr set_RXBUF_a6 movep.w EMPTY(a6),d2 ; first ctrl block and compare to the movem.l (sp)+,d0/a6 cmp.w d0,d2 ; data buffer EMPTY pointer seq d0  ; Then set d0 if equal rts cbn1 clr.l d0 rts ttl dc_trans: Handshake transfer code page * ***** **** *** * * *** ***** ***** **** * * * * * * ** * * * * *  * * * * * * * * * * * * * * * * * * **** ***** * ** *** *** *** **** * * * * * * * * * * * * * * * * * * * * *  * * * * * * * * * * * * * * *** * ***** * * in_timeout equ 6 [UNCALIBRATED 1 MS] out_timeout equ 7 [UNCALIBRATED 1 MS] ************************************************* *  * * procedure OUTPUT_DATA ( * * var SCT: select_code_table; * * PTR: ^ data_bytes; * * COUNT: longword ); * *  * * This operation may hang waiting for space. * * * * This routine calls find_TXBUF and putchars. * * * ************************************************* output_data equ * movea.l (sp)+,a0 move.l (sp)+,d1 ; COUNT movea.l (sp)+,a1 ; PTR movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 move.l a1,data_address(a4) ; init, ialize address/count move.l d1,data_number(a4) bsr check_ov_error ; Escape if o/v error bsr wait_outxfrdone move.l timeout(a4),timeout_counter(a4) move.l #out_timeout,inner_counter(a4) bsr find_TXBUF ; Set up a2.l = buffer descriptor record * base address beq.s outdone btst #timer_present,sysflag2 check for timer tttt JS 8/11/83 beq.s outtimer if got it, use it tttt JS 8/11/83 out_2 tst.l data_number(a4) ; And transfer characters until done beq.s outdone bsr putchars subq.l #1,inner_counter(a4) ; Test for timeout condition bne.s out_2 move.l #out_timeout,inner_counter(a4) tst.l timeout_counter(a4) beq.s out_2 subq.l #1,timeout_counter(a4) beq time_err ; if so, escape bra.s out_2 outdone rts * outtimer tst.l timeout(a4) see if infinit timeout tttt JS 8/11/83 beq out_2 if so don't use this tttt JS 8/11/83 move.b #1,-(sp) else setup timer record tttt JS 8/11/83 move.l timeout(a4),-(sp) tttt JS 8/11/83 outtloop tst.l data_number(a4) check if all done tttt JS 8/11/83 beq.s  outtexit if so then get out tttt JS 8/11/83 bsr putchars else send chars tttt JS 8/11/83 pea (sp) push ptr to time rec tttt JS 8/11/83 jsr check_timer and check the timer  tttt JS 8/11/83 bpl outtloop if not timeout keep going tttt JS 8/11/83 bra time_err else do timeout escape tttt JS 8/11/83 outtexit addq #6,sp normal exit -- cleanup tttt JS 8/11/83 rts  and return tttt JS 8/11/83 page ************************************************* * * * procedure ENTER_DATA ( * * var SCT: select_code_table; * * PTR: ^ data_bytes; * * var COUNT:longword ); * * * * COUNT initially passes the number of bytes * * which the upper level wants to read. THE * * ROUTINE DOES NOT NECESSARILY READ THIS MANY! * * Upon exit COUNT will be reflect the number * * of data bytes entered, whether or not there * * is an escape. * * * * escape(EOD): Terminated by reaching a control* * block. TERM&MODE may be read with STATUS * * 9 and 10. * * * * This routine calls find_RXBUF, * * getctrlblk, getchars, ctrlblknext, and * * RX_BUFFER_EMPTY. * * * ************************************************* enter_data equ * movea.l (sp)+,a0 movea.l (sp)+,a2 ; addr(COUNT) movea.l (sp)+,a1 ; PTR movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 move.l a1,data_address(a4) ; initialize address bsr check_ov_error ; Escape if o/v error bsr wait_inxfrdone move.l timeout(a4),timeout_counter(a4) move.l #in_timeout,inner_counter(a4) move.l (a2),data_number(a4) move.l a2,-(sp) btst #timer_present,sysflag2 is timer present? tttt JS 8/11/83 bne.s in_1 if not, continue tttt JS 8/11/83 move.b #1,-(sp) else stack time rec tttt JS 8/11/83 move.l timeout(a4),-(sp) tttt JS 8/11/83 bra.s in_1 in_0 bsr eir tst.l data_number(a4) ; See if all characters transferred beq.s in_exit ; If so, leave in_1 bsr find_RXBUF ; Set up a2.l = buffer descriptor record * base address btst #timer_present,sysflag2 using timer? ,  tttt JS 8/11/83 bne.s in_1b if not then skip tttt JS 8/11/83 tst.l timeout(a4) infinite timeout? tttt JS 8/11/83 beq.s in_4 then skip checking tttt JS 8/11/83 pea (sp)  push ptr to time re tttt JS 8/11/83 jsr check_timer and check timer tttt JS 8/11/83 bpl.s in_4 if not timeout, keep trying tttt JS 8/11/83 addq #6,sp else clean stack tttt JS 8/11/83 bra.s in_1c and do timeout stuff tttt JS 8/11/83 in_1b subq.l #1,inner_counter(a4) ; Test for timeout condition bne.s in_4 move.l #in_timeout,inner_counter(a4) tst.l timeout_counter(a4) beq.s in_4 subq.l #1,timeout_counter(a4) bne.s in_4 in_1c movea.l (sp)+,a0 move.l (a0),d0 sub.l data_number(a4),d0 move.l d0,(a0) bra time_err in_4 bsr dir bsr RX_stuff_avail ; See if buffer is empty tst.b d0 ; If so, just sit here & wait beq.s in_0 bsr ctrlblknext ; If a control block is next, then tst.b d0 beq.s in_3 bsr getctrlblk ; Get it, and check for the special cmpi.b #255,term(a4) ; case TERM=255 bne.s in_2 move.b mode(a4),which_RXbuf(a4) ;If so, do the buffer switch bra.s in_1 ; And go back for more in_2 move.w term_and_mode(a4),last_enter_term(a4) * ; Otherwise save the control block & leave in_exit btst #timer_present,sysflag2 using timer? tttt JS 8/11/83 bne.s in_ex2 no -- skip ahead tttt JS 8/11/83 addq.l #6,sp else clean stack tttt JS 8/11/83 in_ex2 bsr eir movea.l (sp)+,a0 move.l (a0),d0 sub.l data_number(a4),d0 move.l d0,(a0) tst.l data_number(a4) beq outdone ; If nonzero then early EOI; escape moveq #EOD_SEEN,d0 bra escape in_3 tst.l data_number(a4) ; see if chars to transfer beq.s in_exit ; yes, go do it bsr getchars ; move some data bra in_0 ; & go back to check for ctrl blk page ************************************************* *  * * procedure OUTPUT_END ( * * var SCT: select_code_table ); * * * * Equivalent to the BASIC OUTPUT Sc;END. * *  * * This operation may hang waiting for space. * * * * This routine calls find_TXBUF and * * try_sending_EOF. * *  * ************************************************* output_end equ * movea.l (sp)+,a0 movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 bsr check_ov_error ; Escape if o/v error bsr wait_outxfrdone bsr find_TXBUF ; Set up a2.l = buffer descriptor record * base address move.l timeout(a4),outer_tx_count(a4) move.l #sEtimeout,inner_tx_count(a4) tst.l outer_tx_count(a4) infinite loop? tttt JS 5/3/84 beq.s trysend yes, normal loop tttt JS 5/3/84 btst #timer_present,sysflag2 timer avail? tttt JS 5/3/84 beq.s try_timer if so, use it tttt JS 5/3/84 trysend bsr try_sending_EOF tst.b d0 bne.s sentEOF subq.l #1,inner_tx_count(a4) bne.s trysend move.l #sEtimeout,inner_tx_count(a4) tst.l outer_tx_count(a4) beq.s trysend subq.l #1,outer_tx_count(a4) bne.s trysend bra time_err sentEOF rts try_timer move.b #1,-(sp) setup timer record tttt JS 5/3/84 move.l timeout(a4),-(sp) tttt JS 5/3/84 try_timer2 bsr try_sending_EOF tttt JS 5/3/84 tst.b -  d0 successful? tttt JS 5/3/84 bne.s try_timer3 yes, get out tttt JS 5/3/84 pea (sp) point to timer rec tttt JS 5/3/84 jsr check_timer and check timer  tttt JS 5/3/84 bpl try_timer2 if no timeout, loop tttt JS 5/3/84 addq #6,sp timeout, one more try tttt JS 5/3/84 move.l #1,outer_tx_count(a4) with short count tttt JS 5/3/84 bra trysend  tttt JS 5/3/84 try_timer3 addq #6,sp clean stack tttt JS 5/3/84 rts and return tttt JS 5/3/84 page ************************************************* * * * procedure CONTROL_BFD ( * * var SCT: select_code_table; * * REG: 0..127; * * VAL: 0..255); * *  * * Control register 0 is intercepted and * * if MODE=0 no action is performed, otherwise * * the card is reset IMMEDIATELY. * * * * This operation may hang waiting for space. * * * * The ranges of REG & VAL are not checked * * for validity. * * * * This routine calls find_TXBUF and putctrlblk* * * ************************************************* control_bfd equ * movea.l (sp)+,a0 move.w (sp)+,d1 ; VAL move.w (sp)+,d2 ; REG movea.l (sp)+,a4 ; SCT pea (a0) movea.l c_adr(a4),a3 addq.l #1,a3 bsr check_ov_error ; Escape if o/v error * (tm) moved by Tim Mikkelsen 12/02/81 move.b d2,term(a4) (tm) ; Intercept CONTROL 0 beq.s ctrl0 (tm)  bsr wait_outxfrdone move.b d1,mode(a4) bsr find_TXBUF ; Set up a2.l = buffer descriptor record bra putctrlblk ; base address ctrl0 tst.b d1 beq.s ctrldun bsr wait_inxfrdone bra do_reset ctrldun rts ttl dc_txbuf: Tx buffer utilities page * ***** * * **** * * ***** ***** ***** **** * * * * * * * * * * * * * * * * * * * * * *  * * * * * * * **** * * ***** ***** ***** **** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *  **** *** * * ***** * * sEtimeout equ 11 [UNCALIBRATED] pcbtimeout equ 11 [CALIBRATED 1 MS] ******************************************************************************** *  * * routine TXCTRLBUFFroom: Function which returns the number of byte * * ============== positions as yet unused in the Transmit ctrl * * Buffer.  * * * * routine TXDATABUFFroom: Function which returns the number of byte * * ============== positions as yet unused in the Transmit data * * Buffer. * * * * At entry:  * * a2.l = TXBUFF base address (shifted, +1+selectcode) * * a3.l = card base address ($00xx0001) * * d5.l = TXDATABUFF_SIZE or TXCTRLBUFF_SIZE * * -  (unshifted, not adjusted) * * * * Upon exit: * *  d0.l = TXDATABUFF_FILL or TXCTRLBUFF_FILL (unshifted) * * d3.l = Number of bytes left * * This also bashes d2. * *  * * This routine uses the card's SEMAPHORE to gain access. * * * * This routine calls gain_access and release_access. * * * ******************************************************************************** TXCTRLBUFFroom equ * clr.l d0  ; Get garbage out of top of d0&d3 clr.l d3 movep.w CTRL_AREA+FILL(a2),d0 bsr gain_access ; Need access to EMPTY movep.w CTRL_AREA+EMPTY(a2),d3 ; Fetch pointers (bytes in wrong order) bra.s room1 TXDATABUFFroom equ * clr.l d0  ; Get garbage out of top of d0&d3 clr.l d3 movep.w DATA_AREA+FILL(a2),d0 bsr gain_access ; Need access to EMPTY movep.w DATA_AREA+EMPTY(a2),d3 ; Fetch pointers (bytes in wrong order) room1 bsr release_access ror.w #8,d0 ; Switch bytes in d0 & d3 ror.w #8,d3 sub.w d0,d3 ; Compute d3 := EMPTY-FILL subq.w #1,d3 ; (EMPTY-FILL-1) bge.s room2 add.w d5,d3 ; If negative, add size room2 rts ; Return (EMPTY-FILL-1) mod SIZE page ******************************************************************************** * * * routine putchars: Routine which takes characters from the * * ======== area sc_subtabletype.data_address sized by * * sc_subtabletype.data_number and moves * *  them to the Transmit buffer. The number of * * characters actually transfered is the minimum * * of: (1) the number of characters available; * * (2) the number of byte positions left in the * * Transmit buffer; and (3) the number of byte * * positions in the Transmit buffer until the * * wraparound point. THIS NUMBER CAN BE ZERO. * * This alters data_address and data_number to * * reflect where to start going next time this * * is called. The entire transfer is done when * * data_number goes to zero. * * * * At entry:  * * a2.l = TX buffer record base address (shifted, +1+selectcode) * * a3.l = card base address ($00xx0001) * * a4.l = pointer to sc_subtabletype structure * *  * * Upon exit: * * data_number and data_address are updated, plus FILL in the * * card's Transmit buffer. * * a1, d4 and d5 are left with the values from find_DATA_AREA. * * This bashes d0, d1, d2, d3, d4, d5, a0, and a1. * * .  * * Interrupts: * * This does its own enabling/disabling. Interrupts are left ON. * *  * * This routine uses the card's SEMAPHORE to gain access. * * * * This routine calls gain_access, release_access, TXDATABUFFroom, * * and find_DATA_AREA. * * * ******************************************************************************** putchars equ * bsr find_DATA_AREA ; Setup a1 = data buffer base addr * d4 = end of data buffer addr * d5 = TXDATABUFF_SIZE bsr dir bsr TXDATABUFFroom ; d3.l = available buffer positions move.l d0,d1 ; d0.l = d1.l = TXDATABUFF_FILL move.l d4,d0 andi.l #$0000FFFE,d0 asr.l #1,d0 ; d0.l = unshifted TXDATABUFF_END sub.l d1,d0  ; d0.l = remaining positions to wrap cmp.l d0,d3 ; If d0>d3 then set d0 := d3 bgt.s pc1 move.l d3,d0 pc1 move.l data_number(a4),d2 ; Fetch number of chars avail into d2 cmp.l d0,d2 ; If d0>d2 then set d0 := d2 bgt.s pc2 move.l d2,d0 pc2 move.l d0,d3 ; d3.l saves number of chars actually * ; transferred below beq.s pcdone ; If zero, no work to be done subq.w #1,d0 ; Make offset correct for dbf instr. movea.l data_address(a4),a0 ; Get character pointer into a0 lsl.w #1,d1 add.l a3,d1 movem.l a1,-(sp) ; Save a1 so we can use the register movea.l d1,a1  ; Now a1 is useable pointer pcloop move.b (a0)+,(a1) ; Transfer a character & bump source ptr addq.w #2,a1 ; Bump destination pointer (odd bytes) dbf d0,pcloop ; Then decrement d0 & loop sub.l d3,d2 move.l d2,data_number(a4) ; Now store adjusted number and move.l a0,data_address(a4) ; address fields move.l a1,d1 ; Move 68000 FILL pointer into d1 movem.l (sp)+,a1 ; Restore a1 before we forget! cmp.l d1,d4 ; Now check to see if FILL was moved bne.s pc3 ; past end of buffer. If so, set to move.l a1,d1 ; the front of the buffer. pc3 bclr #0,d1 ; Fix up the 68000 pointer to be the rol.w #7,d1 ; card's type of pointer bsr gain_access movep.w d1,DATA_AREA+FILL(a2) ; Remember d1 = card's FILL pointer. bsr release_access pcdone bra eir page ******************************************************************************** * * * routine putctrlblk: Routine which puts a control block into the * * ========== Transmit buffer area of the card. The * * appropriate pointers are updated to reflect * * the control block. This routine also contains * * a timeout mechanism which will be adjusted * * to the proper values later. If a timeout * * occurs, an escape is done with NO DAMAGE to * * the buffer. The only thing that can cause the * * timeout is < 4 positions left in the control * * buffer. SEMAPHORE timeout is not handled * * by this routine. *.  * * * At entry: * * sc_subtabletype.term = TERM field for control block (8 bits) * *  sc_subtabletype.mode = MODE field for control block (8 bits) * * a2.l = TX buffer record base address (shifted, +1+selectcode) * * a3.l = card base address ($00xx0001) * * a4.l = pointer to sc_subtabletype structure * * * * Upon exit: * * FILL in the card's transmit control buffer is updated. * * a1, d4 and d5 are left with the values from find_CTRL_AREA. * * This bashes d0, d1, d2, d3, d4, d5, a0 and a1. * * This uses inner/outer_tx_count for computing timeouts. * * * * Interrupts: * * This does its own enabling/disabling. Interrupts are left ON. * * * * This routine uses the card's SEMAPHORE to gain access. * *  * * This routine calls TXCTRLBUFFroom, escape, gain_access, find_CTRL_AREA,* * eir, dir and release_access. * * * ******************************************************************************** putctrlblk equ * bsr find_CTRL_AREA ; Setup a1 = ctrl buffer base addr * d4 = end of ctrl buffer addr *  d5 = TXCTRLBUFF_SIZE move.l timeout(a4),outer_tx_count(a4) move.l #pcbtimeout,inner_tx_count(a4) ; Load timeout value * btst #timer_present,sysflag2 timer present? tttt JS 8/11/83 beq.s pcbtime  if so then use it tttt JS 8/11/83 * pcbwait bsr dir bsr TXCTRLBUFFroom ; Get d3 = #bytes available in buffer cmpi.l #4,d3 ; and d0 = CTRLBUFF_FILL (unshifted) bge.s roomok ; If >=4 bytes, can go ahead! bsr eir subq.l #1,inner_tx_count(a4) bne.s pcbwait ; Loop, then if it times out give an move.l #pcbtimeout,inner_tx_count(a4) tst.l outer_tx_count(a4) beq.s pcbwait subq.l #1,outer_tx_count(a4) bne.s pcbwait bra time_err ; escape(timeout). roomok lsl.w #1,d0 ; Make CTRLBUFF_FILL into a 68000 add.l a3,d0 ; pointer movea.l d0,a0 ; Put in a0 to use it. movep.w DATA_AREA+FILL(a2),d0 ; Get the DATA_FILL pointer to put movep.w d0,POINTER(a0) ; into the POINTER FIELD move.w term_and_mode(a4),d0 movep.w d0,TERMFIELD(a0) adda.l #CTRLBLKSIZE,a0 ; Bump pointer by TWO bytes move.l a0,d1 ; Move 68000 FILL pointer into d1 cmp.l d1,d4 ; Now check to see if FILL was moved bne.s pcb1 ; past end of buffer. If so, set to move.l a1,d1 ; the front of the buffer. pcb1 bclr #0,d1  ; Fix up the 68000 pointer to be the rol.w #7,d1 ; card's type of pointer bsr gain_access movep.w d1,CTRL_AREA+FILL(a2) bsr release_access bra eir * pcbtime tst.l timeout(a4) see if infinite timeout tttt JS 8/11/83 beq pcbwait if so use other loops tttt JS 8/11/83 move.b #1,-(sp) else setup time record tttt JS 8/11/83 move.l timeout(a4),-(sp) tttt JS 8/11/83 pcbtloop bsr dir /  loop checks copied from tttt JS 8/11/83 bsr TXCTRLBUFFroom code above tttt JS 8/11/83 cmpi.l #4,d3 tttt JS 8/11/83 bge.s troomok ok -- leave  tttt JS 8/11/83 bsr eir tttt JS 8/11/83 pea (sp) push ptr to time rec tttt JS 8/11/83 jsr check_timer timeout? tttt JS 8/11/83 bpl pcbtloop  no, do loop again tttt JS 8/11/83 addq #6,sp yes, clean stack and do tttt JS 5/3/84 move.l #1,outer_tx_count(a4) quick final check tttt JS 5/3/84 bra pcbwait tttt JS 5/3/84 troomok addq #6,sp normal exit -- cleanup stk tttt JS 8/11/83 bra roomok and return tttt JS 8/11/83 page ************************************************* *  * * routine try_sending_EOF: tries to send EOF * * and returns immediately if * * unsuccessful. * * * * At entry:  * * a2.l = TX buffer-record base addr * * a3.l = card base address * * a4.l = pointer to sc_subtabletype * * * * Upon exit: * *  d0.l = 0 if unsuccessful; * * 1 if successful. * * * * This bashes d0,d1,d2,d3,d4,d5,a0 & a1 * * * ************************************************* try_sending_EOF equ * moveq #4,d1 clr.l d0 move.b TXENDBLOCKSPACE-TXBUFF(a2),d0 beq.s sE3 ; If it's zero jump down & wait for 4 move.l d0,d1 ; bytes in the control queue sE1 bsr find_DATA_AREA ; Setup a1 = data buffer base addr * d4 = end of data buffer addr * d5 = TXDATABUFF_SIZE sE1loop bsr dir bsr  TXDATABUFFroom ; Now hang until enough space becomes cmp.l d1,d3 ; available in the data queue bge.s sE2 bsr eir noroom clr.l d0 rts sE2 moveq #8,d1 ; if TXENDBLOCKSPACE#0 then wait for *  ; 8 bytes, not 4. sE3 bsr find_CTRL_AREA ; Setup a1 = ctrl buffer base addr * d4 = end of ctrl buffer addr * d5 = TXCTRLBUFF_SIZE sE3loop bsr dir bsr TXCTRLBUFFroom ; Now hang until enough space becomes cmp.l d1,d3 ; available in the ctrl queue bge.s sE4 bsr eir bra.s noroom sE4 tst.b TXENDBLOCKSPACE-TXBUFF(a2) ; There's enough room now!! If zero beq.s sE6 ; then just send 1 block below move.w #$0501,term_and_mode(a4) bsr putctrlblk clr.l data_number(a4) ; Followed by some space move.b TXENDBLOCKSPACE-TXBUFF(a2),data_number+3(a4) move.l #$FFFF0000,data_address(a4) ; kluge so it isn't left pointing * to nowhere & get bus error! sE5 bsr putchars tst.l data_number(a4) ; Hang until all sent bne.s sE5 sE6 move.w #$0500,term_and_mode(a4) bsr putctrlblk moveq #1,d0 rts end  (* (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 *) $MODCAL ON$ $PARTIAL_EVAL ON$ $STACKCHECK ON$ $RANGE OFF$ $DEBUG OFF$ $OVFLCHECK OFF$ $PAGE$ { $SEARCH 'IOLIB:KERNEL'$ } (************************************************************************) (* *) (* RELEASED VERSION 3.1 *) (* *) (************************************************************************) (* *) (* *) (* IOLIB DC_DRIVERS  *) (* *) (* *) (************************************************************************) (*  *) (* *) (* library - IOLIB *) (* name - DC_DRIVERS  *) (* module(s) - init_dc *) (* - extd *) (*  *) (* author - Tim Mikkelsen *) (* phone - 303-226-3800 ext. 2910 *) (* *) (* date - Oct 20 , 1981 *) (* update - Aug 11 , 1983 by J Schmidt *) (* release - Jul 12 , 1985 *) (*  *) (* source - IOLIB:DC_DRV.TEXT *) (* object - IOLIB:DC_DRV.CODE *) (* *) (*  *) (************************************************************************) $PAGE$ (************************************************************************) (*  *) (* *) (* BUG FIX HISTORY - after release 1.0 *) (*  *) (* *) (* BUG # BY / ON LOC DESCRIPTION *) (* ----- ----------- -------------- ---------------------- *) (*  *) (* 1283 T Mikkelsen idc_wtc IOCONTROL(s,0,1) gives *) (* 01/08/82 error, but should work. *) (* IOCONTROL(s,513,x) *) (* would give an error. *) (* *) (* zzzz T Mikkelsen idc_init An error during init *) (*  06/16/82 init_dc can blow away the work *) (* station. *) (* *) (* bbbb T Mikkelsen init_d0 c No bug sheet. *) (* 07/12/82 Setting up a machine *) (* number ID if card is a *) (* Ganglia.  *) (* *) (* cccc T Mikkelsen init_dc No bug sheet. *) (* 08/16/82 intdc Hunting for 98629 and *) (*  98628_dsndl. *) (* See IODECLARATIONS also.*) (* *) (* 367 T Mikkelsen dc_initialize Allow eXecute of driver *) (* 09/22/82 and have it install *) (* itself in the system. *) (* *) (* uuuu T Mikkelsen init_dc Differentiate between *) (* 09/28/82 628 and 629 card for *) (* the card type. *) (*  See IODECLARATIONS also.*) (* *) (* J Schmidt init_dc Remove machine # setup *) (************************************************************************) $PAGE$ (************************************************************************) (* *) (* *) (* This is the source code for an external procedures library *) (* to be used for general purpose interfacing on the HP 9826. *) (* *) (* The library consists of 3 primary sets of modules - *) (* *) (* 1. KERNEL modules *) (* 2. driver modules *) (*  3. IOLIB modules *) (* *) (* The KERNEL modules consist of the following modules - *) (*  *) (* 1. iodeclarations ( contains static r/w space ) *) (* 2. iocomasm *) (* 3. general_0 ( initialization & low level *) (* routines like ioread/iowrite) *) (* The KERNEL modules also have an executable program segement *) (* that gets executed at the time it is loaded. This program *) (* initializes the static read/write memory. This program also *) (* allocates the temporary storage for any card that exists - *) (* independent of whether there is or is not a driver for it. *) (*  *) (* The driver modules consist of the actual assembly or PASCAL *) (* routines that deal with a specific interface card. There is *) (* also an executable program segment for each driver module. *) (* This program searches the select code table in the static r/w *) (* initialized by the KERNEL general_0 module for all select codes *) (* that have the right interface card ( HPIB drivers will search *) (* for the 98624 interface ). This program will then set up the *) (* driver tables to point to the correct drivers. *) (* *) (* The rest of the IOLIB modules are high-level modules that are *) (*0  used by an end user in his/her application program. *) (* *) (* The KERNEL and some set of driver modules will exist in the *) (* SYSTEM.INITLIB file as object code ( not EXPORT text ). The *) (* export text will reside on the SYSTEM.LIBRARY file. The rest *) (* of the library will reside on the SYSTEM.LIBRARY. *) (*  *) (************************************************************************) $PAGE$ (************************************************************************) (* *) (*  *) (* REFERENCES : *) (* *) (*  *) (* 1. 9826 I/O Designers Guide ( Loyd Nelson ) *) (* *) (* 2. 68000 Manual ( Motorola ) *) (* *) (* 3. Pascal alpha site ERS ( Roger Ison ) *) (* *) (* 4. Pascal I/O Library ERS ( Tim Mikkelsen ) *) (* *) (* 5. 9826 HPL EIO & IOD listings ( Bob Hallissy ) *) (*  *) (* 6. 9826 HPL Misc. I/O Doc. ( Bob Hallissy ) *) (* *) (* 7. 9826 card documentation ( Mfg. Specs. ) *) (*  *) (* 8. Pascal I/O Library IRS ( Tim Mikkelsen ) *) (* *) (* 9. 98628 Data comm documentation ( Carl Dierschow ) *) (* *) (* *) (************************************************************************) $PAGE$ PROGRAM dc_initialize ( INPUT , OUTPUT ); $PAGE$ (************************************************************************) (* *) (*  *) (* DATA COMM DRIVERS *) (* *) (* *) (************************************************************************) EXTERNAL MODULE extdc; { by Tim Mikkelsen date 10/20/81 update 11/03/81 purpose This module is a declaration of the importation text for  the external drivers. note The assembly language code that is imported needs to be called 'extdc'. The routines need to be called 'extdc_@@@@@@' } IMPORT sysglobals, iodeclarations; EXPORT PROCEDURE alvinit ( temp : ANYPTR ); PROCEDURE alvinisr ( temp : PISRIB ); PROCEDURE enter_data ( temp : ANYPTR ; x : ANYPTR ; VAR c: INTEGER ); PROCEDURE output_data ( temp : ANYPTR ; x : ANYPTR ; cnt : INTEGER ); PROCEDURE output_end ( temp : ANYPTR ); PROCEDURE direct_status ( temp : ANYPTR ; reg : io_word; VAR1  x : io_word); PROCEDURE direct_control ( temp : ANYPTR ; reg : io_word; val : io_word ); PROCEDURE control_bfd ( temp : ANYPTR ; reg : io_word; val  : io_word ); PROCEDURE start_tfr_in ( temp : ANYPTR ); PROCEDURE start_tfr_out ( temp : ANYPTR ); END; { of extdc } $PAGE$ (************************************************************************) (*  *) (* *) (* DATA COMM DRIVERS *) (* *) (*  *) (************************************************************************) MODULE intdc; { by Tim Mikkelsen date 10/20/81 update 08/16/82  purpose This module contains the internal drivers. } IMPORT sysglobals , iodeclarations ; EXPORT TYPE dc_err_type = PACKED ARRAY { zzzz TM 6/16/82 } [minrealisc..maxrealisc] OF io_word ; { zzzz TM 6/16/82 } dc_err_ptr = ^dc_err_type ; { zzzz TM 6/16/82 } VAR dc_init_fault : BOOLEAN ; { zzzz TM 6/16/82 } dc_error : dc_err_ptr ;  { zzzz TM 6/16/82 } PROCEDURE idc_init ( temp : ANYPTR ); PROCEDURE idc_isr ( temp : PISRIB ); PROCEDURE idc_rdb ( temp : ANYPTR ; VAR x : CHAR); PROCEDURE idc_wtb ( temp : ANYPTR ; val : CHAR); PROCEDURE idc_rdw ( temp : ANYPTR ; VAR x : io_word); PROCEDURE idc_wtw ( temp : ANYPTR ; val : io_word); PROCEDURE idc_rds ( temp : ANYPTR ; reg : io_word; VAR x : io_word); PROCEDURE idc_wtc ( temp : ANYPTR ; reg : io_word; val : io_word ); PROCEDURE idc_tfr ( temp : ANYPTR ; bcb : ANYPTR ); IMPLEMENT IMPORT isr , general_0 , extdc ; PROCEDURE idc_init ( temp : ANYPTR ); VAR dummyword : io_word; dummy_isc : INTEGER; { bbbb TM 7/12/82 } BEGIN control_bfd ( temp , 0 , 1 ); dummy_isc := io_find_isc(temp); { bbbb TM 7/12/82 } { make sure card is still async } direct_status( temp , 3 , dummyword ); WITH isc_table[ dummy_isc ] DO BEGIN card_id := hp_datacomm; { TM 7/8/82 } IF dummyword = 1 THEN card_id := hp98628_async; { TM 7/8/82 }  IF dummyword = 2 THEN card_id := hp98628_dsndl; { cccc TM 8/16/82 } END; { of WITH DO BEGIN } { TM 7/8/82 } IF dc_init_fault { zzzz TM 6/16/82 } THEN BEGIN { zzzz TM 6/16/82 } IF dc_error^[dummy_isc]<>0 { zzzz TM 6/16/82 } THEN BEGIN { zzzz TM 6/16/82 }  io_escape(dc_error^[dummy_isc], { zzzz TM 6/16/82 } dummy_isc); { zzzz TM 6/16/82 } END; { of IF dc_error <> 0 } { zzzz TM 6/16/82 } END; { of IF dc_init_fault } { zzzz TM 6/16/82 } { set up Ganglia card ID } { bbbb TM 7/12/82 } IF ioread_byte(dummy_isc,HEX('402F'))=3 { bbbb TM 7/12/82 } THEN BEGIN  { bbbb TM 7/12/82 } { card is ganglia } { bbbb TM 7/12/82 } isc_table[ dummy_isc ].card_id := hp98629; { cccc TM 8/16/82 } { iowrite_byt1 e(dummy_isc , { bbbb TM 7/12/82 } { HEX('4061') , io_model_number DIV 256 ); { bbbb TM 7/12/82 } { iowrite_byte(dummy_isc , { bbbb TM 7/12/82 } { HEX('4061') + 2 , io_model_number MOD 256 ); { bbbb TM 7/12/82 } END; { of IF } { bbbb TM 7/12/82 } END; { of idc_init } PROCEDURE idc_isr ( temp : PISRIB ); BEGIN alvinisr( temp ); END; { of idc_isr } PROCEDURE idc_rdb ( temp : ANYPTR ; VAR x : CHAR); VAR count : INTEGER; BEGIN { this can escape with an eod escape } count := 1; enter_data( temp , ADDR(x) , count ); END; { of idc_rdb } PROCEDURE idc_wtb ( temp : ANYPTR ; val : CHAR); BEGIN { this can escape with an eod escape } output_data( temp , ADDR(val) , 1 ); END; { of idc_wtb } PROCEDURE idc_rdw ( temp : ANYPTR ; VAR x : io_word); VAR count : INTEGER; BEGIN { this can escape with an eod escape } count := 2; enter_data( temp , ADDR(x) , count ); END; { of idc_rdw } PROCEDURE idc_wtw ( temp : ANYPTR ; val : io_word); BEGIN { this can escape with an eod escape } output_data( temp , ADDR(val) , 2 ); END; { of idc_wtw } PROCEDURE idc_rds ( temp : ANYPTR ; reg : io_word; VAR x : io_word); BEGIN direct_status ( temp , reg , x ); END; { of idc_rds } PROCEDURE idc_wtc ( temp : ANYPTR ; reg : io_word; val : io_word ); VAR dummyword : io_word; BEGIN { range of valid registers - 000-127 buffered control 257-383 direct control 512 abrt tfr in 513 abrt tfr out } IF ( ( reg >= 257 ) AND ( reg <= 383 ) ) OR ( reg = 512 ) OR ( reg = 513 ) { bug 1283 - TM:1/8/82} THEN BEGIN direct_control ( temp , reg-256 , val ); END ELSE BEGIN IF ( ( reg >= 000 ) AND ( reg <= 127 ) ) { bug 1283 - TM:1/8/82} THEN BEGIN control_bfd ( temp , reg , val ); IF ( reg = 0 ) THEN BEGIN { make sure card is still async } direct_status( temp , 3 , dummyword ); WITH isc_table[ io_find_isc(temp) ] DO IF dummyword = 1 THEN card_id := hp98628_async ELSE card_id := hp_datacomm; END; { of IF reg=0 }  END ELSE BEGIN io_escape(ioe_misc,io_find_isc(temp)); END; { of IF reg<=127 } END; { of IF >=257 } END; { of idc_wtc } PROCEDURE idc_tfr ( temp : ANYPTR ; bcb : ANYPTR ); VAR b_info : ^buf_info_type; io_isc : type_isc ; tmpptr : pio_tmp_ptr; tmpcnt : INTEGER ; mycount: INTEGER ; done : BOOLEAN ; BEGIN b_info := ANYPTR( bcb ); tmpptr := ANYPTR( temp ); io_isc := tmpptr^.my_isc ; WITH b_info^ DO BEGIN IF ( usr_tfr = serial_DMA ) OR ( usr_tfr = overlap_DMA ) OR ( b_w_mode = TRUE ) { word } THEN BEGIN { error } IF direction = from_memory THEN tmpptr^.out_bufptr := NIL  ELSE tmpptr^.in_bufptr := NIL; io_escape( ioe_bad_tfr , io_isc ); END; { mark buffer busy } active_isc := io_isc ; IF usr_tfr < overlap_INTR THEN BEGIN { serial transfer - handled here }  IF direction = from_memory THEN BEGIN { serial output tfr } output_data ( temp , buf_empty , term_count ); buf_empty := ANYPTR( INTEGER(buf_empty) + term_count); term_count:= 0; IF end_mode THEN output_end( temp ); END ELSE BEGIN { serial input tfr } done := false; mycount := term_count; { tfr size } REPEAT IF term_2 char = -1 THEN BEGIN { serial input - no term } TRY enter_data( temp , buf_fill , mycount ); term_count := term_count - mycount; buf_fill := ANYPTR( INTEGER(buf_fill) + mycount); done := TRUE; RECOVER BEGIN IF ( escapecode = ioescapecode ) AND ( ioe_result = ioe_eod_seen ) AND  ( ioe_isc = io_isc ) THEN BEGIN term_count := term_count - mycount; buf_fill := ANYPTR( INTEGER(buf_fill) + mycount); mycount := term_count; IF end_mode THEN BEGIN done := TRUE; END; { of IF end_mode } END ELSE BEGIN  escape(escapecode); END; { of IF } END; { of TRY RECOVER BEGIN } END ELSE BEGIN { serial input - termination } TRY  REPEAT tmpcnt :=1 ; enter_data( temp , buf_fill , tmpcnt ); buf_fill := ANYPTR( INTEGER(buf_fill) + 1 ); term_count := term_count -1;  UNTIL ( term_count = 0 ) OR ( CHARPTR(INTEGER(buf_fill)-1)^=CHR(term_char)) ; done := TRUE; RECOVER BEGIN IF ( escapecode = ioescapecode ) AND  ( ioe_result = ioe_eod_seen ) AND ( ioe_isc = io_isc ) THEN BEGIN { I use tmpcnt because the eod may or may not have been caught with the character } term_count := term_count - tmpcnt; buf_fill := ANYPTR( INTEGER(buf_fill) + tmpcnt ); IF end_mode THEN BEGIN  done := TRUE; END; { of IF end_mode } END ELSE BEGIN escape(escapecode); END; { of IF } END; { of TRY RECOVER BEGIN } END; { of IF term_char } UNTIL done; END; { of IF direction } { mark buffer not busy } IF direction = from_memory THEN tmpptr^.out_bufptr := NIL ELSE tmpptr^.in_bufptr := NIL; active_isc := no_isc; drv_tmp_ptr := NIL; IF eot_proc.dummy_pr <> NIL {JPC 02/22/82} THEN BEGIN { call user eot procedure } CALL ( eot_proc.real_proc, eot_parm ); {JPC 02/22/82} END; { of IF } END ELSE BEGIN { overlap transfer - handled by drivers } IF direction = to_memory THEN BEGIN start_tfr_in ( temp );  END ELSE BEGIN start_tfr_out ( temp ); END; { of IF direction } END; { of IF overlap } END; { of WITH b_info } END; { of idc_tfr } END; { of intdc } $PAGE$ MODULE init_dc; { by  Tim Mikkelsen date 10/20/81 update 08/11/83 by J Schmidt -- vers number only purpose This module initializes the data comm drivers. } IMPORT iodeclarations ; EXPORT VAR dc_drivers : drv_table_type; PROCEDURE io_init_dc; IMPLEMENT IMPORT sysglobals , isr , general_0 , extdc , intdc ; PROCEDURE io_init_dc; VAR io_isc : type_isc; dummyword : io_word; io_lvl : io_2 byte; BEGIN io_revid := io_revid + ' S3.2'; { SERIAL revision added 2/5/82 TM } { set up the driver tables } WITH dc_drivers DO BEGIN dc_drivers := dummy_drivers ; iod_init := idc_init; iod_isr := idc_isr; iod_rdb := idc_rdb; iod_wtb := idc_wtb; iod_rdw := idc_rdw; iod_wtw := idc_wtw; iod_rds := idc_rds; iod_wtc := idc_wtc; iod_tfr := idc_tfr; END; { of WITH } { set up drivers for the interfaces }  FOR io_isc:=iominisc TO iomaxisc DO WITH isc_table[io_isc] DO BEGIN IF ( card_id = hp98628_async ) OR ( card_id = hp98628_dsndl ) OR ( card_id = hp98629 ) THEN BEGIN card_id := hp_datacomm;  card_type := serial_card; { uuuu TM 9/28/82 } END; IF card_id = hp_datacomm THEN BEGIN io_drv_ptr:=ADDR(dc_drivers); { if the card exists then link in an ISR for it } { ??? - what happens if an ISR fires during init } io_lvl:=((ioread_byte(io_isc,3) DIV 16) MOD 4)+3; IF io_tmp_ptr^.myisrib.INTREGADDR <> NIL THEN BEGIN { if isr exists then unlink it }  ISRUNLINK(io_lvl , { level } ADDR(io_tmp_ptr^.myisrib)); { isrib info } END; { of IF } PERMISRLINK(io_drv_ptr^.iod_isr, { isr }  ANYPTR(INTEGER(card_ptr)+3), { card address } 192, { intr. mask } 192, { intr. value } io_lvl,  { level } ADDR(io_tmp_ptr^.myisrib)); { isrib info } END; { of IF card_type = hp_datacomm } END; { of FOR io_isc WITH isc_table[io_isc] BEGIN } { call the actual driver initialization } dc_init_fault := FALSE; { set fault flag zzzz TM 6/16/82 } FOR io_isc:=iominisc TO iomaxisc DO WITH isc_table[io_isc] DO IF card_id = hp_datacomm THEN BEGIN TRY  { zzzz TM 6/16/82 } alvinit( io_tmp_ptr ); direct_status( io_tmp_ptr , 3 , dummyword ); IF dummyword = 1 THEN card_id := hp98628_async; IF dummyword = 2 THEN card_id := hp98628_dsndl; { cccc TM 8/16/82 } { set up Ganglia card ID } { bbbb TM 7/16/82 } IF ioread_byte(io_isc,HEX('402F'))=3 { bbbb TM 7/16/82 } THEN BEGIN  { bbbb TM 7/16/82 } { card is ganglia } { bbbb TM 7/16/82 } card_id := hp98629; { cccc TM 8/16/82 } card_type := srm_card; { uuuu TM 9/28/82 } {iowrite_byte(io_isc , { bbbb TM 7/16/82 } {HEX('4061') , io_model_number DIV 256 ); { bbbb TM 7/16/82 } {iowrite_byte(io_isc , { bbbb TM 7/16/82 } {HEX('4061') + 2 , io_model_number MOD 256 ); { bbbb TM 7/16/82 } END; { of IF } { bbbb TM 7/16/82 } RECOVER BEGIN { zzzz TM 6/16/82 } IF ESCAPECODE<>ioescapecode THEN ESCAPE(ESCAPECODE);{ zzzz TM 6/16/82 } IF ioe_isc <> io_isc THEN ESCAPE(ESCAPECODE);{ zzzz TM 6/16/82 } IF NOT dc_init_fault { zzzz TM 6/16/82 } THEN BEGIN { zzzz TM 6/16/82 } dc_init_fault := TRUE ; { zzzz TM 6/16/82 } NEW(dc_error); { get space } { zzzz TM 6/16/3 82 } FOR dummyword:=minrealisc TO maxrealisc DO { zzzz TM 6/16/82 } dc_error^[dummyword]:=0; { clear space } { zzzz TM 6/16/82 } END; { of IF NOT dc_init_fault } { zzzz TM 6/16/82 } dc_error^[io_isc] := ioe_result; { set this err} { zzzz TM 6/16/82 } END; { of RECOVER BEGIN } { zzzz TM 6/16/82 } END; { of WITH IF } END; { of io_init_dc } END; { of MODULE init_dc } $PAGE$ IMPORT init_dc , LOADER ; { 367 TM 9/22/82 } BEGIN io_init_dc; MARKUSER; { 367 TM 9/22/82 } END. { of dc_initialize }  CONST iompx_request = hex('4D50585E'); { MPX^ } iompx_answer = 'IOMPX READY'; TYPE BUFxINFOxPTR = ^buf_info_type; iompx_rec_ptr = ^iompx_rec; iompx_rec = record { a registration record } next  : iompx_rec_ptr; { pointer to next record } user_buffer : BUFxINFOxPTR; { buffer involved in the transfer } user_area : anyptr; { pointer to optional scratch area } in_buffer : BUFxINFOxPTR; { pointer to data comming from interface } ops_proc : io_proc_vb; { WRAPPER/CHECKER procedure } scode : type_isc; { select code of the associated interface } end; { the user_area is intended for the use of the ops_proc (it is not used by any system code) in_buffer is only valid at the time ops_proc is called as part of a TO_MEMORY type of transfer } iompx_sc_rec = record { a list head record } wrappers, { one per select code } wtail, checkers, ctail : iompx_rec_ptr; capable : boolean; { padding to long word desired } end; isc_iompx_type = array[minrealisc..maxrealisc] of iompx_sc_rec; register_iompx_proc = procedure (device : type_device; { select code } t_dir : dir_of_tfr; { input / output } VAR b_info : buf_info_type; { buffer to register } VAR reg_rec : iompx_rec; { registration record }  front : boolean; { register first or last } user_temps : anyptr; { user scratch area } operations : io_proc_vb); { wrapper/recognizer } unregister_iompx_proc = procedure (device : type_device; { select code } t_dir : dir_of_tfr; { input / output } VAR b_info : buf_info_type); { buffer to unregister } iompx_scanner_proc = procedure (working : BUFxINFOxPTR; VAR target : BUFxINFOxPTR); find_iompx_buf_proc =procedure (device : type_device; { select code } t_dir : dir_of_tfr; { TO / FROM_MEMORY } VAR b_info : buf_info_type; { buffer to find } VAR reg_rec: iompx_rec_ptr); { registration record containing b_info as user_buffer } iompx_info_ptr = ^iompx_info_rec; iompx_info_rec = record { the interface record } isc_iompx_table : isc_iompx_type; register_iompx_buf : register_iompx_proc; unregister_iompx_buf : unregister_iompx_proc; { the following are for driver interface only } iompx_scanner : iompx_scanner_proc; find_iompx_buf : find_iompx_buf_proc; end; iompx_ans_ptr = ^iompx_ans_rec; iompx_ans_rec = record case integer of 1:(s : io_string); 2:(s5 : string[11]; ptr : iompx_info_ptr); end; type { byte = 0..255; } halfword = -32768..32767; $include 'PACKETS'$ type ptrmp = msg_packet_ptr; ptrsareyoualive = ^send_are_you_alive; ptrrareyoualive = ^return_are_you_alive; ptrscat = ^send_catalog3 ue; ptrrcat = ^return_catalogue; ptrscatpass = ^send_cat_passwords; ptrrcatpass = ^return_cat_passwords; ptrschangeprotect= ^send_change_protect_codes; ptrrchangeprotect= ^return_change_protect_codes; ptrschangevolume = ^send_change_volume_label; ptrrchangevolume = ^return_change_volume_label; ptrsclose = ^send_closeafile; ptrrclose = ^return_closeafile; ptrscopy = ^send_copy; ptrrcopy = ^return_copy; ptrscreatefile = ^send_createafile; ptrrcreatefile = ^return_createafile; ptrscreatelink = ^send_createlink; ptrrcreatelink = ^return_createlink; ptrsexchange = ^send_xchg_open; ptrrexchange = ^return_xchg_open; ptrsfileinfo = ^send_fileinfo; ptrrfileinfo  = ^return_fileinfo; ptrsgangclean = ^send_gang_cleanup; ptrrgangclean = ^return_gang_cleanup; ptrsinit = ^send_initialize; ptrrinit = ^return_initialize; ptrslock = ^send_lockafile; ptrrlock = ^return_lockafile; ptrsopen = ^send_openafile; ptrropen = ^return_openafile; ptrspos = ^send_positiontoarecord; ptrrpos = ^return_positiontoarecord; ptrspurge = ^send_purgelink; ptrrpurge = ^return_purgelink; ptrsread = ^send_readarecord; ptrrread = ^return_readarecord; ptrssetdate = ^send_set_date; ptrrsetdate = ^return_set_date; ptrsseteof = ^send_set_eof; ptrrseteof = ^return_set_eof; ptrsunlock = ^send_unlockafile; ptrrunlock = ^return_unlockafile; ptrsvol = ^send_volume_status; ptrrvol = ^return_volume_status; ptrswrite = ^send_writearecord; ptrrwrite = ^return_writearecord; ptrshead = ^send_header_type; ptrrhead = ^return_header_type; {INTERNAL ONLY BEGIN} { Added for SRM-UX } ptrschmod = ^send_hfs_chmod; ptrrchmod = ^return_hfs_chmod; ptrschown = ^send_hfs_chown; ptrrchown = ^return_hfs_chown; ptrschgrp = ^send_hfs_chown; { used for chgrp too } ptrrchgrp = ^return_hfs_chown; { used for chgrp too } ptrsrmtexec = ^send_rmt_exec; ptrrrmtexec = ^return_rmt_exec; {INTERNAL ONLY END} pk_ptr = record case integer of 0 : (mp : ptrmp); 1 : (sareyoualive : ptrsareyoualive); 2 : (rareyoualive : ptrrareyoualive); 3 : (scat : ptrscat); 4 : (rcat : ptrrcat); 5 : (scatpass : ptrscatpass);  6 : (rcatpass : ptrrcatpass); 7 : (schangeprotect: ptrschangeprotect); 8 : (rchangeprotect: ptrrchangeprotect); 9 : (schangevolume : ptrschangevolume); 10 : (rchangevolume : ptrrchangevolume); 11 : (sclose : ptrsclose); 12 : (rclose : ptrrclose); 13 : (scopy : ptrscopy); 14 : (rcopy : ptrrcopy); 15 : (screatefile : ptrscreatefile); 16 : (rcreatefile : ptrrcreatefile); 17 : (screatelink : ptrscreatelink); 18 : (rcreatelink : ptrrcreatelink); 19 : (sexchange : ptrsexchange); 20 : (rexchange : ptrrexchange); 21 : (sfileinfo : ptrsfileinfo); 22 : (rfileinfo : ptrrfileinfo); 23 : (sgangclean : ptrsgangclean); 24 : (rgangclean : ptrrgangclean); 25 : (sinit : ptrsinit); 26 : (rinit : ptrrinit); 27 : (slock : ptrslock); 28 : (rlock : ptrrlock); 29 : (sopen : ptrsopen);  30 : (ropen : ptrropen); 31 : (spos : ptrspos); 32 : (rpos : ptrrpos); 33 : (spurge : ptrspurge); 34 : (rpurge : ptrrpurge); 35 : (sread : ptrsread); 36 : (rread  : ptrrread); 37 : (ssetdate : ptrssetdate); 38 : (rsetdate : ptrrsetdate); 39 : (sseteof : ptrsseteof); 40 : (rseteof : ptrrseteof); 41 : (sunlock : ptrsunlock); 42 : (runlock : ptrrun4 lock); 43 : (svol : ptrsvol); 44 : (rvol : ptrrvol); 45 : (swrite : ptrswrite); 46 : (rwrite : ptrrwrite); 47 : (shead : ptrshead); 48 : (rhead : ptrrhead); {INTERNAL ONLY BEGIN} 49 : (srmtexec : ptrsrmtexec); 50 : (rrmtexec : ptrrrmtexec); 51 : (schmod : ptrschmod); 52 : (rchmod : ptrrchmod); 53 : (schown : ptrschown); 54 : (rchown : ptrrchown);  55 : (schgrp : ptrschgrp); 56 : (rchgrp : ptrrchgrp); {INTERNAL ONLY END} end; name_set_array_three = array [1..3] of file_name_set; name_set_array = array [1..6] of file_name_set; pnsa = ^name_set_array; protectcode_set_array = array [1..24] of protect_code_set; ppsa = ^protectcode_set_array; { Added for SRM-UX : } {Moved to MISC 8/10/90 JWH } { Restored from MISC 8/10/90 JWH } srmux_array = array[1..50] of boolean; CONST ios_error_base = 31000; ios_software_bug = 31000; ios_bad_select_code = 31001; ios_unallocated_extent = 31002; ios_ds_rom_missing = 31003;  ios_unsupported_dam = 31004; ios_device_drivers_dont_match = 31005; ios_invalid_ios_request = 31006; ios_attach_table_full = 31007; ios_improper_mass_storage_device = 31008; ios_directory_formats_dont_match = 31009; ios_invalid_file_size = 31010; ios_invalid_file_id = 31011; ios_volume_recoverable_error = 31012; ios_volume_io_error = 31013; ios_file_pathname_missing = 31014; ios_illegal_byte_number = 31015; ios_corrupt_directory = 31016; ios_successful_completion = 31017; ios_system_down = 31018; ios_file_unopened = 31019; ios_volume_offline = 31020; ios_volume_labels_dont_match = 31021; ios_password_not_allowed = 31022; ios_access_to_file_not_allowed = 31023; ios_unsupported_directory_operation = 31024; ios_conflicting_share_modes = 31025; ios_bad_file_name = 31026; ios_file_in_use = 31027; ios_insufficient_disk_space = 31028; ios_duplicate_filenames  = 31029; ios_phys_eof_encountered = 31030; ios_no_capability_for_file = 31031; ios_file_not_found = 31032; ios_volume_in_use = 31033; ios_file_not_directory  = 31034; ios_directory_not_empty = 31035; ios_volume_not_found = 31036; ios_invalid_protect_code = 31037; ios_volume_unrecoverable_error = 31038; ios_password_not_found = 31039; ios_duplicate_passwords = 31040; ios_deadlock_detected = 31041; ios_link_to_directory_not_allowed = 31042; ios_rename_across_volumes = 31043; ios_volume_down = 31044; ios_eof_encountered = 31045; ios_invalid_file_code = 31046; ios_file_locked_please_retry = 31047; ios_no_reply = 31048; ios_purge_on_open = 31049;  ios_error_top = 31049; { Dave Hendricks' errors start at 31050 } {**************************************************************************** * +----------------------------------------------------------------------+ * * | | * * | G A N G L 4 I A M E S S A G E F O R M A T S | * * | | * * | A N D R E L A T E D D E F I N I T I O N S | * * |  | * * +----------------------------------------------------------------------+ * ****************************************************************************} CONST name_type_len = 16; {+----------------------------------------------------------------------+ | Message Packet Sizes For Messages That Are Sent To Ganglia | +----------------------------------------------------------------------+} size_to_are_you_alive = 12; size_to_cat =  128; (* plus 36 *`# file name sets *) size_to_catprotect = 128; (* plus 36 * # file name sets *) size_to_changeprotect = 116; (* plus (36 * # file name sets) + (24 * # file name sets) *) size_to_change_vol_label= 132;  size_to_close = 56; size_to_copy = 32; size_to_create = 152; (* plus (36 * # file name sets) + (24 * # protect code sets) *) size_to_createlink = 144; (* plus 36 * # file name sets *) size_to_flock = 20; size_to_funlock = 20; size_to_gang_cleanup = 16; size_to_info = 20; size_to_init_vol = 172; (* plus 24 * # protect code sets *) size_to_open = 132; (* plus 36 * # file name sets *) size_to_position = 28; size_to_purge = 112; (* plus 36 * # file name sets *) size_to_read = 40; size_to_set_eof = 28; size_to_set_date = 44; size_to_volstatus = 84; size_to_write = 48; (* plus the size of the record <= 512 *) size_to_xchg_data = 140; (* plus 36 * # file name sets *) size_to_xchg_open = 20; {INTERNAL ONLY BEGIN} { srm_ux only } size_to_rmt_exec = 120; { plus cmd length } size_to_hfs_chmod = 132; (* plus 36 * # file name sets *) size_to_hfs_chown = 132; (* plus 36 * # file name sets *) size_to_hfs_chgrp = 132; (* plus 36 * # file name sets *) {INTERNAL ONLY END} {+----------------------------------------------------------------------+ | Message Packet Sizes For Messages Ganglia Will Send Back | +----------------------------------------------------------------------+} size_from_are_you_alive = 16;  size_from_cat = 24; (* plus 68 * # entries returned *) size_from_catprotect = 24; { plus 20 * # prot code entries returned } size_from_changeprotect = 16; size_from_change_vol_label=16; size_from_close = 16; size_from_copy = 20; size_from_create = 16; size_from_createlink = 16; size_from_flock = 20; size_from_funlock = 16; size_from_gang_cleanup = 16; size_from_gang_error = 16; size_from_info =  88; size_from_init_vol = 16; size_from_open = 52; size_from_position = 16; size_from_purge = 16; size_from_read = 36; (* plus the size of the record <= 512 *) size_from_set_eof = 16;  size_from_set_date = 16; size_from_volstatus = 40; size_from_write = 20; size_from_xchg_data = 16; size_from_xchg_open = 16; {INTERNAL ONLY BEGIN} { srm_ux only } size_from_rmt_exec = 20; size_from_hfs_chmod = 16; size_from_hfs_chown = 16; size_from_hfs_chgrp = 16; {INTERNAL ONLY END} {+----------------------------------------------------------------------+ | Ganglia Message Request Types, Modes, And Codes  | +----------------------------------------------------------------------+} {*** File Access Method Requests ***} req_old_read =0; {Old read packet} req_write =1; {Write a record to an open file.} req_position 5  =2; {Position an open file.} req_read =3; {Read a record from an open file.} req_set_eof =4; {*** Sharing Requests ***} req_flock =8; {Lock an open file for exclusive use.} req_funlock  =9; {Unlock an open file.} req_info =10; req_close =13; {Close an open file.} {*** Directory Access Requests ***} req_open =14; req_purgelink =15; req_catalog =16; {List all the files in a directory.} req_create =17; req_createlink =18; req_changeprotect =19; {Change the passwords on a file.} req_catprotect =20; {List all the passwords on a file.} req_xchg_data =21; {*** Volume Access Requests ***} req_volstatus =22; req_init_vol =23; req_label =24; {*** File Transfer Requests ***} req_xchg_open =29; req_copy =30; {*** HFS Permissions Requests ***} req_hfs_chmod =31; { added for SRM-UX } req_hfs_chown =32; { added for SRM-UX } req_hfs_chgrp =33; { added for SRM-UX } { changed for SRM-UX; (this constant is never used anywhere?!) } req_HIGHEST_IOS_req =33; {*** Ganglia Requests ***} req_gang_cleanup =1000; req_are_you_alive =1001; {INTERNAL ONLY BEGIN} {*** srm_ux ***} req_rmt_exec =1200; {INTERNAL ONLY END} {*** Record Modes ***} data_records =  0; directory_records = 1; {*** Share Codes ***} exclusive_share_code = 0; shared_share_code = 1; closed_share_code = 2; corrupt_share_code = 3; {*** Access Codes ***} random_access = 0; sequential_access = 1; primitive_access = 2; TYPE {+----------------------------------------------------------------------+ | Enumerated Types And Minor Structures Used To Make Up More | | Major Structures Described In The Next Section  | +----------------------------------------------------------------------+} { Changed for SRM-UX : } { modified for SRM-UX; last 12 bits now have HP-UX mode from stat structure in SRM-UX CAT return packets; (Basic CAT stmt will only output last 9 bits) these bits still unused in other structures } { access_code_type = (ac_manager, ac_read, ac_write, ac_search, ac_purgelink, ac_createlink, ac_execute, ac_generic1,ac_generic09,ac_generic17, ac_generic2,ac_generic10,ac_generic18, ac_generic3,ac_generic11,ac_generic19, ac_generic4,ac_generic12,ac_generic20, ac_generic5,ac_generic13,ac_generic21, ac_generic6,ac_generic14,ac_generic22, ac_generic7,ac_generic15,ac_generic23, ac_generic8,ac_generic16,ac_generic24, ac_generic25); } access_code_type = (ac_manager, ac_read, ac_write, ac_search, ac_purgelink, ac_createlink,  ac_execute, ac_generic1, ac_generic09,ac_generic17,ac_generic2, ac_generic10, ac_generic18,ac_generic3, ac_generic11,ac_generic19,ac_generic4, ac_generic12,ac_generic20,ac_generic5, ac_setuid, ac_setgid, ac_sticky, ac_owner_r, ac_owner_w, ac_owner_x, ac_group_r, ac_group_w, ac_group_x, ac_other_r, ac_other_w, ac_other_x); file_id_type = integer; {*** Filler Definitions Used In Padding Out Message Packet Layouts ***} gang_boolean_filler = boolean; gang_32bit_filler = integer; gang_16bit_filler = -32768..32767; long_boolean = record case integer of 1: (i : integer); 2: (fill1: gang_16bit_filler; fill2: gang_boolean_filler; value: boolean); end; gang_file_codes = packed record case integer of 0 : (i: integer); 1 : (si1: shortint; si2: shortint); 2 : (firstword: -32768..32767; division_code: 0..63; dcd_system_type: 0..15; dcd_file_type: 0..63); end; gang_open_type = (open_data, 5  {Normal data file} open_protected_directory, {Directory not closed on cleanup} open_directory {Directory closed on cleanup} ); name_type = packed array [1..name_type_len] of char; path_start_type = (start_root, {Start search at root directory} start_alternate {Start search at a working directory.} ); position_type = (pos_absolute, {Position at absolute location in file} pos_seq {Position relative to current record} ); {+----------------------------------------------------------------------+ | Data Structures Which Are Part Of Message Packet Layouts | +----------------------------------------------------------------------+} access_capabilities = packed array [ access_code_type ] of boolean; { modified for SRM-UX; id field now has owner or group id in CAT return packets; still treated as fill (don't care) in other data structures } date_type = record { fill: gang_16bit_filler; } id : shortint; { was fill : gang_16bit_filler; } date: packed record month: 0..12; day : 0..31; year : 0..127; {LAF 880101 range is now 0..127, not 0..100} end; seconds_since_midnight : integer end; device_address_type = record address1 : integer; haddress : integer; unit_num : integer; volume_num : integer end; file_header_type = record num_file_name_sets : integer;  working_directory : file_id_type; filler1 : gang_16bit_filler; path_type : path_start_type; root_password : name_type; end; { Modified for SRM-UX } file_info_type = record file_name  : name_type; open_flag : long_boolean; share_code : integer; file_code : gang_file_codes; record_mode : integer; max_record_size : integer; max_file_size : integer; { owner uid is in id field if SRM-UX CAT return packet } creation_date : date_type; { group uid is in id field if SRM-UX CAT return packet } last_access_date : date_type; capabilities : access_capabilities; logical_eof : integer; physical_size : integer; end; file_name_set = record file_name : name_type; password : name_type; filler : gang_32bit_filler end; linkfillertype = packed record requeue: boolean; zit1: byte; { unused } zit2: integer; { unused } oddbytefiller: byte; { unused } destaddr: byte; sourceaddr: byte; { These three bytes } len_lobyte:  byte; { are filled in by } len_hibyte: byte; { the transmitting card } level: byte; end; msg_packet_type = packed array [1..800 {or so} ] of char; msg_packet_ptr = ^msg_packet_type; owner_id_type = record id : integer; end; protect_code_set = record capabilities : access_capabilities; password : name_type; filler : gang_32bit_filler end; return_header_type = record linkfiller : linkfillertype; message_length : integer; return_request_type : integer; user_sequencing_field : integer; status : integer end; send_header_type = record linkfiller : linkfillertype;  message_length : integer; send_request_type : integer; user_sequencing_field : integer end; volume_header_type = record filler1 : gang_32bit_filler; driver_name : name_type; catalogue_organization : name_type; device_address_present : long_boolean; device_address : device_address_type; volume_name : name_type; end; volume_info_type = record free_blocks : integer; bad_blocks 6  : integer; media_origin : integer; interleave : integer; volume_label : name_type; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Are You Alive ?! | +----------------------------------------------------------------------+} send_are_you_alive = record send_mess_header : send_header_type; end; return_are_you_alive = record return_mess_header : return_header_type; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Catalogue | +----------------------------------------------------------------------+} send_catalogue = record send_mess_header : send_header_type; max_num_files : integer; file_index : integer; filler1 : gang_32bit_filler; {actual_num_files} volume_name_header : volume_header_type; file_name_header : file_header_type; filler2 : gang_32bit_filler; start_name_sets : integer end; return_catalogue = record return_mess_header : return_header_type; filler1 : gang_32bit_filler; {file_index} actual_num_files : integer; cat_info : array [1..7] of file_info_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Catalogue Protect Codes | +----------------------------------------------------------------------+} send_cat_passwords = record send_mess_header : send_header_type; max_num_passwords : integer; filler1 : gang_32bit_filler; {actual_passwords} password_index : integer; volume_name_header : volume_header_type; file_name_header : file_header_type; filler2 : gang_32bit_filler; start_name_sets : integer end; return_cat_passwords = record return_mess_header : return_header_type; actual_num_passwords : integer; filler1 : gang_32bit_filler; password_info : array [1..24] of record password : name_type; capabilities : access_capabilities end end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Change Protect Codes | +----------------------------------------------------------------------+} send_change_protect_codes = record send_mess_header : send_header_type; volume_name_header : volume_header_type; file_name_header : file_header_type; num_protect_code_sets : integer; start_name_sets : integer end; return_change_protect_codes = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Change Volume Label | +----------------------------------------------------------------------+} send_change_volume_label = record send_mess_header : send_header_type; volume_name_header  : volume_header_type; password : name_type; new_volume_name : name_type; new_vol_password : name_type; end; return_change_volume_label = record return_mess_header : return_header_type end;  {+----------------------------------------------------------------------+ | Send and return record layouts for request: Close A File | +----------------------------------------------------------------------+} send_closeafile = record send_mess_header : send_header_type; file_id : file_id_type; directory_password : name_type; file_password : name_type; filler5 : long_boolean; nodeallocate : long_boolean; en6 d; return_closeafile = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Copy File To File | +----------------------------------------------------------------------+} send_copy = record send_mess_header : send_header_type; source_file_id : file_id_type; source_offset : integer; destination_file_id : file_id_type; destination_offset : integer; requested : integer; end; return_copy = record return_mess_header : return_header_type; actual : integer; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Create A File | +----------------------------------------------------------------------+} send_createafile = record send_mess_header  : send_header_type; volume_name_header : volume_header_type; file_name_header : file_header_type; file_code : gang_file_codes; record_mode : integer; max_record_size : integer;  first_extent : integer; {Size in logical records.} contiguous_first_extent : long_boolean; secondary_extent : integer; max_file_size : integer; boot_start_address : integer; num_protect_code_sets : integer; label_included_flag : long_boolean; start_name_sets : integer end; return_createafile = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Create A Link (Rename) | +----------------------------------------------------------------------+} send_createlink = record send_mess_header : send_header_type; volume_name_header : volume_header_type; old_file_name_header : file_header_type; new_file_name_header : file_header_type; purge_old_link : long_boolean; start_name_sets : integer end; return_createlink = record return_mess_header : return_header_type; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Exchange files | +----------------------------------------------------------------------+} send_xchg_data = record send_mess_header : send_header_type; volume_name_header : volume_header_type; file_name_header1 : file_header_type; file_name_header2 : file_header_type; start_name_sets : integer; end; return_xchg_data = record return_mess_header : return_header_type; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Exchange open files | +----------------------------------------------------------------------+} send_xchg_open = record send_mess_header : send_header_type; file_id_1 : file_id_type; file_id_2  : file_id_type; end; return_xchg_open = record return_mess_header : return_header_type; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: File Information | +----------------------------------------------------------------------+} send_fileinfo = record send_mess_header : send_header_type; implicit_unlock : long_boolean; file_id : file_id_type end;  return_fileinfo = record return_mess_header : return_header_type; current_record : integer; file_info : file_info_type; end; {+----------------------------------------------------------------------+ | Send and 7 return record layouts for request: Ganglia Cleanup | +----------------------------------------------------------------------+} send_gang_cleanup = record send_mess_header : send_header_type; keep_protected_directories: long_boolean; end; return_gang_cleanup = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Initialize A Volume | +----------------------------------------------------------------------+} send_initialize = record send_mess_header : send_header_type; volume_name_header : volume_header_type; password : name_type; num_protect_code_sets : integer; new_volume_name : name_type; new_cat_organization : name_type; sectors_per_block : integer; format_media : long_boolean; interleave_factor : integer; filler3 : gang_32bit_filler; physical_sector_size : integer; new_password : {global_}name_type; start_protect_code_sets : integer; init_root_password : {global_}name_type; end; return_initialize = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Lock A File | +----------------------------------------------------------------------+} send_lockafile = record send_mess_header : send_header_type; file_id : file_id_type; wait_for_lock : long_boolean end; return_lockafile = record return_mess_header : return_header_type; success : long_boolean end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Open A File | +----------------------------------------------------------------------+} send_openafile = record send_mess_header : send_header_type; volume_name_header : volume_header_type; file_name_header : file_header_type; filler2  : integer; filler3 : integer; share_code : integer; filler4 : owner_id_type; filler1 : gang_16bit_filler; open_type : gang_open_type; start_name_sets : integer end; return_openafile = record return_mess_header : return_header_type; file_id : file_id_type; record_mode : integer; max_record_size : integer; max_file_size : integer; file_code : gang_file_codes; open_logical_eof : integer; sharebits : integer; sec_ext_size : integer; boot_start_address : integer; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Position To A Record | +----------------------------------------------------------------------+} send_positiontoarecord = record send_mess_header : send_header_type; implicit_unlock : long_boolean; file_id : file_id_type; filler3 : gang_16bit_filler; type_of_position : position_type; byte_offset : integer end; return_positiontoarecord = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Purge Link | +----------------------------------------------------------------------+} send_purgelink = record send_mess_header : send_header_type; volume_name_header : volume_header_type; file_name_header : file_header_type; start_name_sets : integer end; return_purgelink = recor7 d return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Read A Record | +----------------------------------------------------------------------+} send_readarecord = record send_mess_header : send_header_type; implicit_unlock : long_boolean; file_id : file_id_type; access_code : integer; filler3 : array [1..2] of gang_32bit_filler; requested : integer; offset : integer end; return_readarecord = record return_mess_header : return_header_type; actual : integer; filler1 : array [1..4] of gang_32bit_filler; data : packed array[1..512] of char; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Set Date | +----------------------------------------------------------------------+} send_set_date = record send_mess_header : send_header_type; implicit_unlock : long_boolean; file_id : file_id_type; set_access_date : long_boolean; access_date : date_type; set_creation_date: long_boolean; creation_date : date_type end; return_set_date = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Set Eof | +----------------------------------------------------------------------+} send_set_eof = record send_mess_header : send_header_type;  implicit_unlock : long_boolean; file_id : file_id_type; use_current_ptr : long_boolean; byte_offset : integer end; return_set_eof = record return_mess_header : return_header_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Unlock A File | +----------------------------------------------------------------------+} send_unlockafile = record send_mess_header : send_header_type; file_id : file_id_type; explicit_unlock : long_boolean; end; return_unlockafile = record return_mess_header : return_header_type; end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Volume Status | +----------------------------------------------------------------------+} send_volume_status = record send_mess_header : send_header_type; volume_name_header : volume_header_type; end; { Modified for SRM-UX } return_volume_status = record return_mess_header : return_header_type; fill1 : gang_16bit_filler; srm_ux_flag : boolean; { FALSE if SRM ; TRUE if SRM-UX } exist : boolean; interleave : integer; volume_name : name_type end; {+----------------------------------------------------------------------+ | Send and return record layouts for request: Write A Record | +----------------------------------------------------------------------+} send_writearecord = record send_mess_header : send_header_type; implicit_unlock : long_boolean; file_id : file_id_type; access_code : integer; filler3 : array [1..2] of gang_32bit_filler; requested : integer; offset : integer; filler8 : long_boolean;  flush_buffer : long_boolean; data : packed array [1..512] of char end; return_writearecord = record return_mess_header : return_header_type; actual : integer; end; {INTERNAL ONLY BEGIN} {+--8 --------------------------------------------------------------------+ | Send and return record layouts for request: remote execute | +----------------------------------------------------------------------+} send_rmt_exec = record  send_mess_header : send_header_type; volume_name_header: volume_header_type; cmd_size : integer; directory_id : file_id_type; filler1 : gang_16bit_filler; path_type : path_start_type; volume_pword : name_type; spare1 : integer; spare2 : integer; cmd : packed array [1..512] of char; end; return_rmt_exec = record return_mess_header : return_header_type; file_id  : file_id_type; end; {INTERNAL ONLY END} {^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^} { the following definitions were added for SRM-UX } {+----------------------------------------------------------------------+ | Send and return record layouts for request: HFS chmod | +----------------------------------------------------------------------+} { use build_volname_header on old_header variant 1st; then fill in fields specific to chmod } volume_header_chmod = record case boolean of false: ( old_header : volume_header_type); true: ( filler1 : gang_32bit_filler; driver_name : name_type; catalogue_organization : name_type; device_address_present : long_boolean; actual_device_address : integer; delta_mask : integer; { specific for chmod } ordinary_perm : integer; { specific for chmod } dir_perm : integer; { specific for chmod } volume_name : name_type; ); end; send_hfs_chmod = record send_mess_header : send_header_type; volume_name_header : volume_header_chmod; file_name_header : file_header_type; filler1 : integer; filler2 : integer; filler3 : integer; filler4 : integer; filler5 : integer; start_name_sets : integer { dummy field } end; return_hfs_chmod = record  return_mess_header : return_header_type; end; {+----------------------------------------------------------------------+ | Send and return record layouts for requests: HFS chown and HFS chgrp | +----------------------------------------------------------------------+} { use build_volname_header on old_header variant 1st; then fill in fields specific to chown and chgrp } volume_header_chown = record case boolean of false: ( old_header : volume_header_type); true: ( new_owner : integer; { specific for chown and chgrp; will be new group for chgrp } driver_name : name_type; catalogue_organization : name_type; device_address_present : long_boolean; device_address : device_address_type; volume_name : name_type; ); end; send_hfs_chown = record send_mess_header : send_header_type; volume_name_header : volume_header_chown; file_name_header : file_header_type; filler1 : integer; filler2 : integer; filler3 : integer; filler4 : integer; filler5 : integer; start_name_sets : integer { dummy field } end; return_hfs_chown = record return_mess_header : return_header_type; end;  TTL IOLIB COMDCL - common equates and definitions PAGE ******************************************************************************** * * modified: 02/22/82 JPC added parm to user EOT & ISR proc's * 08/01/83 JS added 8 timer_present and sysflag2 equ's * 03/25/85 JS added got_68020, cache_ctl equ's * * ******************************************************************************** * * HPL CONVENTIONS * * * Much of this code is taken intact from the 9826 HPL * language system EIO ROM ( extended I/O ROM ). * This was written by Bob Hallissy ( originally John Nairn ). * The Pascal that will be calling this code uses * the stack for parameter passage. The HPL code * uses the Ax and Dx registers for all parameters. * The Pascal driver entry points on the previous pages * take care of getting the parameters into the correct * registers. * * * GENERAL HPL ENTRY/EXIT CONDITIONS: * * A1.L = CARD ADDRESS * A2.L = DRIVER TEMP ADDRESS * UNLESS OTHERWISE INDICATED, THESE REGISTERS ARE UNALTERED. * * * NEW ENTRY/EXIT CONDITIONS FOR PASCAL USE : * * A3.L = BUFFER CONTROL BLOCK ADDRESS *  In addition to the A1/A2 convention, Pascal will use * A3 for a pointer to the buffer control block. * The HPL system kept much of the transfer * information in the s.c. temps. * * TIMEOUT(A2) = contains timeout information * Timeout was a global temp in HPL and a timeout * generated an error. * In PASCAL each card has a timeout value stored in * its temporary area. A timeout error *  generates an ESCAPE ( which can be trapped ). * * ******************************************************************************** PAGE ******************************************************************************** * * * DRIVER TEMPS TEMPLATE * * OFFSET FROM A2 * * HPL DECLARATIONS ( MODIFIED ) * * ******************************************************************************** ISR_ENTRY EQU 0 ..19 PASCAL ISR LINK & UNLINK area USER_ISR EQU 20  user ISR: do NOT change the proc/stat link/parm ordering!!! H_ISR_PR EQU 20 ..23 procedure ptr H_ISR_SL EQU 24 ..27 static link H_ISR_PM EQU 28 ..31 parameter C_ADR EQU 32 ..35 card address BUFI_OFF EQU 36 ..39 buffer pointer offset BUFO_OFF EQU 40 ..43 buffer pointer offset EIRB_OFF EQU 44 eir byte IO_SC EQU 45 select code ( i.e. 7, 22, etc. ) TIMEOUT EQU 46 ..49 timeout value * =0 : no timeout * #0 : value of timeout MA_W EQU 50 ..51 word access to my address MA EQU 51 byte access to my address AVAIL_OFF EQU 52 ..?? standard space taken from temps * 52 ..83 normal cards ( 32 bytes ) * 52 ..179 98628 card ( 128 bytes ) PAGE ******************************************************************************** * *  TRANSFER OFFSETS IN BUFFER CONTROL BLOCK * * OFFSET FROM A3 * * PASCAL DECLARATION * ******************************************************************************** TTMP_OFF EQU 0 ..3 pointer to driver temp offset T_SC_OFF EQU 5 transfer select code TACT_OFF EQU 7 actual transfer mode TUSR_OFF EQU 9 transfer mode * 00 - not used * 01 serial DMA * 02 serial FHS * 03 serial FASTEST ( DMA or FHS ) * 04 - not used * ---------------- *  05 overlp INTR * 06 overlp DMA * 07 overlp FHS ( BURST ) * 08 overlp FASTEST ( DMA or BURST ) * 9  09 overlp OVERLAP ( DMA or INTR ) T_BW_OFF EQU 10 transfer byte/word indicator * 0 = byte / 1 = word TEND_OFF EQU 11 transfer EOI/END indicator *  0 = no eoi / 1 = eoi sent or searched for TDIR_OFF EQU 13 transfer direction * 0 = input / 1 = output TCHR_OFF EQU 14 ..15 transfer terminate character *  -1 = no termination character TCNT_OFF EQU 16 ..19 transfer count TBUF_OFF EQU 20 ..23 transfer buffer pointer TBSZ_OFF EQU 24 ..27 transfer buffer maximum size TEMP_OFF EQU 28 ..31 transfer empty pointer pointer TFIL_OFF EQU 32 ..35 transfer fill pointer T_PR_OFF EQU 36 ..39 transfer pointer to eot procedure * NIL no procedure T_SL_OFF EQU 40 ..43 transfer eot proc static link T_PM_OFF EQU 44 ..47 transfer eot proc parameter T_DMAPRI EQU 48 dma priority request * * TRANSFER EQUATES * TT_INT EQU 1 interrupt TT_DMA EQU 2 DMA TT_BURST EQU 3 burst TT_FHS  EQU 4 fast handshake TTL IOLIB IOCOMASM - escape support PAGE ******************************************************************************** * * EXTERNAL REFERANCES for escape * ******************************************************************************** REFA iodeclarations reference the io lib var. area REFA sysglobals SPC 2 ******************************************************************************** * * Escape code values * ******************************************************************************** NO_CARD EQU 1 no interface NOT_HPIB EQU 2 not an hpib interface NO_ACTL EQU 3 no active controller NO_DVC EQU 4 sc ( not device ) specified NO_SPACE EQU 5 not enough space in the buffer NO_DATA EQU 6 not enough data left in the buffer TFR_ERR EQU 7 tfr error SC_BUSY EQU 8 sc is currently busy BUF_BUSY EQU 9 the buffer is busy TCNTERR EQU 10 bad count BADTMO EQU 11 bad timeout value NO_DRV EQU 12  no driver NO_DMA EQU 13 no dma installed NO_WORD EQU 14 no word transfers allowed NOT_TALK EQU 15 not addressed as talker NOT_LSTN EQU 16 not addressed as listener TMO_ERR EQU 17 timeout NO_SCTL EQU 18 not system controller BAD_RDS EQU 19 bad read status / write control BAD_SCT EQU 20 bad set/clear/test CRD_DWN EQU 21 interface is dead EOD_SEEN EQU 22 end of data has happened IO_MISC EQU 23 misc. error SPC 3 IOE_ERROR EQU -26 io sub system error escape code SPC 3 IOE_RSLT EQU IODECLARATIONS-66 IOE_SC EQU IODECLARATIONS-70 SPC 3 ESC_CODE EQU SYSGLOBALS-2 RCVR_BLK EQU SYSGLOBALS-10 TIMER_PRESENT EQU 1 JS 8/1/83 SYSFLAG2 BIT -- 0=>TIMER PRESENT GOT_68020 EQU 4  JS 3/25/85 SYSFLAG2 BIT -- 1=>68020 PRESENT SYSFLAG2 EQU $FFFFFEDA JS 8/1/83 CACHE_CTL EQU $5F400E JS 3/25/85 *********************************************************************** * STREAM FILE TO MAKE LAN AND SRM DRIVERS *********************** *********************************************************************** cLANDECS n aLANASM n cLANSRM n cSRM_DRV n 9  cSRMDAM n cSRMAM n cDC_DRV n aDC n cLAN n cIOMPX n ********************************************************************* * NOW LINKEM TO PRODUCE THE ACTUAL MODULES ************************** ********************************************************************* loLANDVR. lnLANDVR x Copyright Hewlett-Packard Co.,1987,1991 All rights reserved. diLAN aiLANASM aiLANDECS alkq loIOMPX. lnIOMPX x Copyright Hewlett-Packard Co.,1991 All rights reserved. diIOMPX alkq lh1 oDATA_COMM. lnDATA_COMM dx Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iDC_DRV aiDC alkq lh1 oSRM. lnSRM x Copyright Hewlett-Packard Co.,1983,1991 All rights reserved. iSRMDAM aiSRMAM aiSRM_DRV aiLANSRM aiLANDECS aiLANASM alkq lh1 oLAN. lnIOMPX dx Copyright Hewlett-Packard Co.,1991 All rights reserved. iIOMPX al lnLANDVR dx Copyright Hewlett-Packard Co.,1991 All rights reserved. iLAN aiLANASM aiLANDECS alkq *********************************************************************** * DONE BUILDING AND LINKING VARIOUS LAN AND SRM THINGS **************** ***********************************************************************  This floppy contains the source for various Pascal Workstation network drivers (LANDVR, IOMPX, DATA_COMM, SRM, LAN). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_ALL.TEXT) which shows how to build and link the drivers is also included.  This floppy contains the source for various Pascal Workstation network drivers (LANDVR, IOMPX, DATA_COMM, SRM, LAN). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_LAN.TEXT) which shows how to build and link the drivers is also included. *************************************************************** Copyright Hewlett-Packard Company, 1994. All rights are reserved. Copying or other reproduction of this product 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 xr_1,txr_n,tx_ring_f,tx_ring_l : tx_ring_elt_ptr; txd_1,txd_n : gpaddr; { first and end of tx data space } tx_count : integer;{ number of outstanding tx requests } tx_used : gpaddr; { start of oldest data space } tx_next : gpaddr; { next usable data space } tx_user_buffs : lan_bufs_ptr;{outstanding user buffers} tx_ub_in,tx_ub_out : integer; {-----------misc info-----------------------} driver_buffer : anyptr; last_rx_size : shortint; { size of current frame } skip_bytes : shortint; copy_bytes : shortint; card_intlevel : shortint; do_card_start : boolean; alloc_ok : boolean; END; IMPLEMENT END.  MNAME PLLEL_ASM SRC MODULE PLLEL_ASM; SRC IMPORT IODECLARATIONS; SRC EXPORT SRC TYPE SRC TIMER_REC = RECORD SRC TIME : INTEGER; SRC FLAG : IO_WORD; SRC END; SRC SRC :  PROCEDURE START_TIMER(VAR TIME : TIMER_REC); SRC FUNCTION TIME_EXPIRED(VAR TIME : TIMER_REC):BOOLEAN; SRC PROCEDURE ABORT_IO; SRC PROCEDURE STBSY; SRC PROCEDURE STCLR; SRC FUNCTION GETDMA:INTEGER; {returns dma channel (0,1) being used} SRC FUNCTION DROPDMA:INTEGER; {returns dma final count+1; 0, not -1, means normal completion} SRC SRC END; { PLLEL_ASM } DEF PLLEL_ASM_PLLEL_ASM DEF PLLEL_ASM_START_TIMER DEF PLLEL_ASM_TIME_EXPIRED DEF PLLEL_ASM_ABORT_IO DEF PLLEL_ASM_STBSY DEF PLLEL_ASM_STCLR DEF PLLEL_ASM_GETDMA DEF PLLEL_ASM_DROPDMA * include IOLIB:COMDCL include COMDCL ************************************************************************* * START_TIMER  timing setup * * ASSUMES: * - sp+4 points to location of a timer record * the TIME field is a delay in milliseconds * RETURNS: * - The TIME field contains a value to match against the timer * (no timer present then this field is a scaled count) ************************************************************************* REFA CHECK_TIMER in system POWERUP code LMODE CHECK_TIMER PLLEL_ASM_START_TIMER equ * movea.l 4(sp),a0 get addr of timer rec btst #timer_present,sysflag2 bne.s soft_start st 4(a0) set the first time flag jmp CHECK_TIMER soft_start equ * * scale the time out value for use as a counter move.l (a0),d0 lsl.l #4,d0 x 16 move.l d0,(a0)  move.l (sp)+,(sp) move the return address rts ************************************************************************* * FUNCTION TIME_EXPIRED(VAR TIME: INTEGER):BOOLEAN; * ASSUMES: * - sp+4 points to a timer record (set up by start_timer) ************************************************************************* PLLEL_ASM_TIME_EXPIRED EQU * clr.b 8(sp) clear the function value btst #timer_present,sysflag2 bne.s soft_check move.l 4(sp),-(sp) copy the timer rec address jsr CHECK_TIMER bpl.s timex1 timex0 move.b #1,8(sp) timex1 move.l (sp)+,(sp) move the return address rts soft_check equ * movea.l 4(sp),a0 subq.l #1,(a0) bpl timex1 bra timex0 ************************************************************************* * pascal wrapper routines for the iocomasm driver routines that have * assembly only interfaces. ************************************************************************* refa pllel_util refa abort_io refa stbsy  refa stclr refa itxfr refa getdma refa dma_stbsy refa dropdma lmode pllel_util lmode abort_io lmode stbsy lmode stclr lmode itxfr lmode getdma lmode dma_stbsy lmode dropdma gettmp equ * movea.l pllel_util-4(a5),a2 rts ************************************************************************* * PROCEDURE ABORT_IO ************************************************************************* PLLEL_ASM_ABORT_IO equ * bsr gettmp jsr abort_io rts ************************************************************************* * PROCEDURE STBSY ************************************************************************* PLLEL_ASM_STBSY equ * bsr gettmp jsr itxfr move.l d3,d0 jsr stbsy rts ************************************************************************* * PROCEDURE STCLR ************************************************************************* PLLEL_ASM_STCLR equ * bsr gettmp jsr stclr rts ************************************************************************* * FUNCTION GETDMA:INTEGER * o acquires DMA channel * o set up DMA address * o set up DMA count * o set up DMA arm word for priority and ARMS! * o returns the channel, either 0 or 1. ************************************************************************* PLLEL_ASM_GETDMA equ * bsr gettmp jsr itxfr move.l d3,d0 movea.l c_adr(a2),a1 jsr getdma addq.w #8,d2 ;dma priority move.w d2,(a4) ;arm DMA channel sub #$81,d3 moveq:  #0,d0 move.b d3,d0 move.l d0,4(sp) ;return channel # rts ************************************************************************* * PROCEDURE DROPDMA ************************************************************************* PLLEL_ASM_DROPDMA equ * bsr gettmp jsr DROPDMA move.l d4,4(sp) rts * * module initialization * PLLEL_ASM_PLLEL_ASM EQU * RTS end  TTL IOLIB RS - RS232 DRIVERS ****************************************************************************** * * COPYRIGHT (C) 1985 BY HEWLETT-PACKARD COMPANY * ****************************************************************************** * * * IOLIB RS * * ****************************************************************************** * * * * Library - IOLIB * * Purpose - This set of assembly language code is intended to be used as * a PASCAL module for I/O drivers for use by the external I/O * procedures library. * * * Date - 8-6-82 * Update - 6-5-84 BY J Schmidt * Release - 7-12-85 * * * Source - RS: RS.TEXT * Object - RS: RS.CODE * * * * ****************************************************************************** * * * RELEASED VERSION 3.1 * * ****************************************************************************** * * CHANGES (since 2.0): * {aaa} -- changes for ignore parity error register 20. * * CHANGES for 3.0 * {ttt} -- timing changes for 680xx -- JS 8/3/83, 5/3/84 * * CHANGES for 3.1 * (jws} -- new default setups, add control/status 21, 22. 6/5/85 * * CHANGES for 3.23 *  {dew1} -- fixed timing problem with reset. DW 12/89 * ****************************************************************************** PAGE ****************************************************************************** * * * The following lines are used to tell the LINKER/LOADER what this * module looks like in PASCAL terms. * * Note that it is possible to create assembly modules that are functions. * These routines are called through an indirect pointer using the CALL * facility which does NOT permit functions. * * This module is called 'RS' ( upper or lower case - doesn't matter ) * independent of the file name ( by use of the MNAME pseudo-op ). * * All the externally used procedures are called 'RS_@@@@@@@@' in * this module. If you are using assembly to access them use the * 'RS_@@@@@@@' name. If you are using Pascal use the '@@@@@@@' * name. * ******************************************************************************* MNAME RS SRC MODULE RS; SRC IMPORT iodeclarations; SRC EXPORT SRC SRC PROCEDURE rs_init ( temp : ANYPTR ); SRC PROCEDURE rs_isr ( temp : PISRIB ); SRC PROCEDURE rs_rdb ( temp : ANYPTR ; VAR x : CHAR ); SRC PROCEDURE rs_wtb ( temp : ANYPTR ; val : CHAR ); SRC PROCEDURE rs_rdw ( temp : ANYPTR ; VAR x : io_word); SRC PROCEDURE rs_wtw ( temp : ANYPTR ; val : io_word); SRC PROCEDURE rs_rds ( temp : ANYPTR ; reg : io_word; SRC VAR x : io_word); SRC PROCEDURE rs_wtc ( temp : ANYPTR ; reg : io_word; SRC  val : io_word ); SRC PROCEDURE rs_tfr ( temp : ANYPTR ; bcb : ANYPTR); SRC END; { of RS } PAGE ****************************************************************************** * * SYMBOLS FOR EXPORT AS PROCEDURE NAMES * ****************************************************************************** DEF RS_RS DEF RS_RS_INIT DEF RS_RS_ISR DEF RS_RS_RDB DEF RS_RS_WTB DEF RS_R; S_RDW DEF RS_RS_WTW DEF RS_RS_RDS DEF RS_RS_WTC DEF RS_RS_TFR ****************************************************************************** * * SYMBOLS FOR IMPORT * ****************************************************************************** LMODE ABORT_IO,LOGEOT REFA ABORT_IO,LOGEOT REFA DELAY_TIMER,CHECK_TIMER ttt JS 8/3/83 LMODE DELAY_TIMER,CHECK_TIMER ttt JS 8/3/83 INCLUDE COMDCL  page * * REGISTER USAGE SUMMARY (of utility routines) * * Global Usage * a5 -- Pascal Global Base * a6 -- Pascal Stack Frame * a7 -- Stack Pointer * a1 -- Card Address * a2 -- Driver Attributes ('temp' space) * * ROUTINE a0 a3 a4 d0 d1 d2 d3 d4 d5 d6 d7 * ---------------------------------------------------------- * queue_space - - - - - - O - - - - * queue_empty - - - -  - - - - - - T * queue_full - - - - - - - - - - T * inqueue - - G - - I - - - - G * outqueue - - G - - O - - - - G * init_queue -  - - - - - - - - - - * check_queue - - - - - - - - - - T * check_dsr_cts - - - - - - - - - - T * wait - - I - - - - G - L T * send  - - P - - - I L - L T * get_char - - L T - O P L - L L * wait_send - - L - - - I L - L L * wait_get - - P L - O L L - L L *  check_error - - - - - - - - - - - * soft_reset* - - - - - - - - - T T * connect* - - - - - - - - - L L * disconnect - - - - - - - - - - - * rdivu - - - I O - - - - - - * check_xfer_in - - - - - - - - - - - * check_xfer_out - - - - - - - - - - - * clear_xfer+ - I - - - - - - - - - * set_xfer - I - - - - - - - - - * dump_buffer G I L L - O L L - L L * * NOTATION (in order of importance) * O : output parameter * I : input parameter * G : used by routine (register has consistent meaning throughout routine * P : used to pass parameter to called routines * T : used by routine (temporary) * L : possible usage by called routines * - : not used by routine * * NOTE: the registers used by routines to do an ioescape have been * left out since they do not effect other routines. * * *This routine calls ABORT_IO which uses other registers not listed * +This routine calls LOGEOT which uses other registers not listed page * * ROUTINE USAGE SUMMARY * * ROUTINE CALLS * ------- ----- * queue_space * queue_empty * queue_full * inqueue * outqueue * init_queue * check_queue * check_dsr_cts * wait check_queue, check_dsr_cts (both indirectly) * send wait, check_dsr_cts * get_char outqueue, queue_space, send * wait_send send, check_error * wait_get wait, check_error, get_char, check_queue * check_error ioescape * soft_reset init_queue, ABORT_IO *  connect soft_reset * disconnect * rdivu * check_xfer_in ioescape * check_xfer_out ioescape * clear_xfer * set_xfer * dump_buffer queue_empt; y, get_char, clear_xfer, LOGEOT * ioescape * init init_queue, ABORT_IO * rdb connect, check_error, check_xfer_in, wait_get * wtb connect, check_error, check_xfer_out, wait_send *  rdw connect, check_error, check_xfer_in, wait_get * wtw connect, check_error, check_xfer_out, wait_send * rds queue_empty, get_char, check_error, rdivu, ioescape, * connect * wtc check_error, soft_reset, connect, disconnect, rdivu, * ioescape * isr queue_space, queue_full, inqueue, check_dsr_cts, * send, dump_buffer, LOGEOT * tfr connect, check_error, dump_buffer, set_xfer page * * * ROUTINE CALLED BY * ------- --------- * queue_space get_char, isr * queue_empty dump_buffer, rds (6, 10) * queue_full isr * inqueue  isr * outqueue get_char * init_queue init, soft_reset * check_queue wait_get (with wait) * check_dsr_cts isr, send (with and without wait) * wait wait_get, wait_send, send * send  isr, wait_send, get_char * get_char rds(6), dump_buffer, wait_get * wait_send wtb, wtw * wait_get rdb, rdw, * check_error rdb, wtb, rdw, wtw, rds(6), wtc(6), tfr, * wait_send, wait_get * soft_reset wtc(14), connect * connect rdb, wtb, rdw, wtw, wtc(12), tfr * disconnect wtc(12) * rdivu rds(3), wtc(3) * check_xfer_in rdb, rdw, * check_xfer_out wtb, wtw * clear_xfer  isr, dump_buffer * set_xfer tfr * dump_buffer tfr, isr * ioescape rds, wtc, tfr, check_error, check_xfer_in, * check_xfer_out * ABORT_IO init, soft_reset * LOGEOT isr, dump_buffer TTL RS232 DRIVERS page ***************************************************************************** * * module initialization -- none required. * ***************************************************************************** RS_RS EQU * RTS ***************************************************************************** * * 98626 card register mnemonics * ***************************************************************************** RESET_REG EQU 1 write only ID_REG EQU 1 read only INTR_SW EQU 3 interrupt switches BAUD_SW EQU 5 baud rate switch bank LINE_SW EQU 7 line characteristic switches * * UART registers * DATA EQU 17 receive/transmit buffer (dlab=0) INTR_EN EQU 19 interrupt enable register(dlab=0) DIV0 EQU 17 divisor latch (LSB)  (DLAB=1) DIV1 EQU 19 divisor latch (MSB) (DLAB=1) INTR_ID EQU 21 interrupt identification LINE_CONT EQU 23 line control register MODEM_CONT EQU 25 modem control register LINE_STAT EQU 27 line status register MODEM_STAT EQU 29 modem status register page ****************************************************************************** * * ATTRIBUTE space offset mnemonics * (do not mix -- word boundary problems) * the word address is assumed to be EVEN * starting at AVAIL_OFF * ****************************************************************************** *  size * ---- S_ERROR EQU AVAIL_OFF 4 pending error number IN_ISR EQU S_ERROR+4 1 XIN_ACT EQU IN_ISR+1 1 CONNECTED EQU XIN_ACT+1 1 < MODEM_ON EQU CONNECTED+1 1 RECEIVING EQU MODEM_ON+1 1 XMITTING EQU RECEIVING+1 1 S_MODEM EQU XMITTING+1 1 modem status copy S_LINE EQU S_MODEM+1 1 line status copy S_HANDSH  EQU S_LINE+1 1 contains current handshake XON_CHAR EQU S_HANDSH+1 1 XOFF_CHAR EQU XON_CHAR+1 1 ENQ_CHAR EQU XOFF_CHAR+1 1 ACK_CHAR EQU ENQ_CHAR+1 1 CONV_CHAR EQU ACK_CHAR+1 1 IGNORE_PE EQU CONV_CHAR+1 1 {aaa} *empty 1 {aaa} Q_DESCRIPT EQU IGNORE_PE+2 {aaa} Q_SIZE EQU Q_DESCRIPT 2 Q_IN EQU Q_DESCRIPT+2 2 Q_OUT  EQU Q_DESCRIPT+4 2 Q_BUFFER EQU Q_DESCRIPT+6 134 the rest is internal buffer {aaa} DEF_BAUD EQU Q_BUFFER+134 2 jws Note: stuck here for DEF_LINE EQU DEF_BAUD+2 1 jws code compatibility. *empty 1 jws * --- * 164 total space used {jws} ****************************************************************************** * * constants (mnemonics) * ****************************************************************************** TEMP_SIZE EQU 160 BUFFER_SIZE EQU TEMP_SIZE-Q_BUFFER+AVAIL_OFF DC1 EQU 17 ASCII CHARACTER 17 DC3 EQU 19 ASCII CHARACTER 19 ENQ EQU 5 ASCII CHARACTER 5 ACK EQU 6 ASCII CHARACTER 6 UNDERSCORE EQU 95 ASCII CHARACTER 95 OVERRUN_ERROR EQU 314 receive buffer overflow error ACK_SIZE EQU 80 hysteresis for ENQ/ACK handshake XOFF_SIZE EQU 40 when to send XOFF XON_SIZE EQU BUFFER_SIZE-XOFF_SIZE REG_MAX EQU 22 maximum control/status register number {aaa} TTL RS232 DRIVERS -- initialize page ***************************************************************************** * * driver initialization * ***************************************************************************** RS_RS_INIT EQU * * * Pascal interface overhead * MOVEA.L (SP)+,A0 * get return address MOVEA.L (SP)+,A2 * get temp address MOVEA.L C_ADR(A2),A1 * get card address PEA (A0) * restore return address * * Assembler initialize entry point * ON ENTRY: A1 and A2 are set to card address and * temp space address (respectively) * ASM_INIT EQU * * * Stop transfers and Reset the card * JSR ABORT_IO * stop transfers * -- RESET CARD -- ST RESET_REG(A1) * write to reg 1 * * wait at least 25us * MOVE.L #40,-(SP) USE DELAY ROUTINE dew1 12/89 JSR DELAY_TIMER DELAY FOR 40us * * global attribute initialization * * -- init queue descriptors -- BSR INIT_QUEUE * -- init pseudo registers -- CLR.B XIN_ACT(A2) CLR.B IN_ISR(A2) CLR.L S_ERROR(A2) CLR.B S_MODEM(A2) CLR.B S_LINE(A2) CLR.B CONNECTED(A2) CLR.B MODEM_ON(A2) CLR.B IGNORE_PE(A2) {aaa} *  -- set flags -- MOVE.B #1,RECEIVING(A2) MOVE.B #1,XMITTING(A2) * -- default characters -- MOVE.B #DC1,XON_CHAR(A2) MOVE.B #DC3,XOFF_CHAR(A2) MOVE.B #ENQ,ENQ_CHAR(A2) MOVE.B #ACK,ACK_CHAR(A2) MOVE.B #UNDERSCORE,CONV_CHAR(A2) * * Set defaults from the switches (done after attribute initialization * just in case the card is not completely reset already) * * -- set<  baud rate from DEF_BAUD -- * BSET #7,LINE_CONT(A1) * set DLAB to get to divisor latches MOVE.B DEF_BAUD(A2),DIV1(A1) jws MOVE.B DEF_BAUD+1(A2),DIV0(A1) jws * -- SET LINE CHARACTERISTICS -- jws MOVE.B DEF_LINE(A2),D0 * get handshake and line status defaults MOVE.B D0,D1 * ANDI.B #$3F,D0 * mask and set default line status MOVE.B D0,LINE_CONT(A1) * (also restores dlab) *  -- SAVE HANDSHAKE -- ANDI.B #$C0,D1 * handshake is top two bits LSR.B #5,D1 * adjust it (for jump tables) MOVE.B D1,S_HANDSH(A2) * save it RTS * * baud rate/divisor table (for switches) jws-- not presently used * *BAUD DC.W 3072 * 50 Baud * DC.W 2048 * 75 * DC.W 1396 * 110 * DC.W 1142 * 134.5 * DC.W 1024 * 150 * DC.W 768 * 200 * DC.W 512 * 300 * DC.W 256 * 600 * DC.W 128 * 1200 * DC.W 85 * 1800 * DC.W 64 * 2400 * DC.W 43 * 3600 * DC.W 32 * 4800 * DC.W 21 * 7200 * DC.W 16 * 9600 * DC.W 8 * 19200 TTL RS232 DRIVERS -- read byte page ***************************************************************************** * * read byte * ***************************************************************************** RS_RS_RDB EQU * * * Pascal interface overhead * MOVEA.L (SP)+,A0  get return address MOVEA.L (SP)+,A3 get VAR address MOVEA.L (SP)+,A2 get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * Card overhead (any of the three can do an ioescape) * BSR CONNECT make sure the card is active BSR CHECK_ERROR check for errors saved by ISRs BSR CHECK_XFER_IN make sure no input transfers active BSR WAIT_GET get character with wait MOVE.B D2,(A3) return the character RTS TTL RS232 DRIVERS -- write byte page ***************************************************************************** * * write byte * ***************************************************************************** RS_RS_WTB EQU * * * Pascal interface overhead * MOVEA.L (SP)+,A0 get return address MOVE.B (SP)+,D3 get char to be written MOVEA.L (SP)+,A2 get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * Card overhead * BSR CONNECT autoconnect BSR CHECK_ERROR check for errors found by ISRs BSR CHECK_XFER_OUT make sure no output transfers are active BSR WAIT_SEND  send the character RTS TTL RS232 DRIVERS -- read word page ***************************************************************************** * * read word * ***************************************************************************** RS_RS_RDW EQU * MOVEA.L (SP)+,A0 get return address MOVEA.L (SP)+,A3 get VAR address MOVEA.L (SP)+,A2 get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * Card overhead (any of the three can do an ioescape) * BSR CONNECT make sure the card is active BSR CHECK_ERROR check for erro= rs saved by ISRs BSR CHECK_XFER_IN make sure no input transfers are active BSR WAIT_GET get character with wait LSL.W #8,D2 shift first character BSR WAIT_GET  get second character MOVE.W D2,(A3) return the word RTS TTL RS232 DRIVERS -- write word page ***************************************************************************** * * write word * ***************************************************************************** RS_RS_WTW EQU * MOVEA.L (SP)+,A0 get return address MOVE.W (SP)+,D3 get word to be written MOVEA.L (SP)+,A2  get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * Card overhead (any of the three can do an ioescape) * BSR CONNECT make sure the card is active BSR CHECK_ERROR check for errors saved by ISRs BSR CHECK_XFER_OUT make sure no output transfers are active ROR.W #8,D3 position the first character BSR WAIT_SEND send it ROR.W #8,D3 position the second character BSR WAIT_SEND send it RTS TTL RS232 DRIVERS -- status page ***************************************************************************** * * read status *---------------------------------------------------------------------------- * CONVENTION: A3 -- place to put the result (word sized) * ***************************************************************************** RS_RS_RDS EQU * * * Pascal Interface Overhead * MOVEA.L (SP)+,A0 get return address MOVEA.L (SP)+,A3 get VAR address MOVE.W (SP)+,D1 get register number MOVEA.L (SP)+,A2 get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * Check for legal registers and jump to correct register handler *  TST.W D1 check for negative register number BLT.S STS_ERROR if so goto common ioescape routine CMP.W #REG_MAX,D1 check for too large register number BGT.S STS_ERROR  CLR.W (A3) clear the top half of the return word ADDQ.L #1,A3 point a3 to lower half byte of return word LSL.W #1,D1 get ready for (word) table jump MOVE.W STS_TABLE(D1),D1 get offset from status table JMP STS_TABLE(D1) do the indexed jump STS_TABLE EQU * DC.W STS_0-STS_TABLE ID register DC.W STS_1-STS_TABLE Interrupt status register DC.W  STS_2-STS_TABLE Busy bits register DC.W STS_3-STS_TABLE Baud rate DC.W STS_4-STS_TABLE Character control register DC.W STS_5-STS_TABLE Modem control register DC.W STS_6-STS_TABLE  Data in register DC.W STS_7-STS_TABLE Optional circuits register DC.W STS_8-STS_TABLE Interrupt Enable Mask register DC.W STS_9-STS_TABLE Interrupt Cause register DC.W STS_10-STS_TABLE UART Status register DC.W STS_11-STS_TABLE Modem Status register DC.W STS_12-STS_TABLE Connect/Disconnect register DC.W STS_13-STS_TABLE Hardware handshake register DC.W STS_14-STS_TABLE Error status register DC.W STS_15-STS_TABLE Current Xon Character DC.W STS_16-STS_TABLE Current Xoff Character DC.W STS_17-STS_TABLE Current ENQ Character DC.W STS_18-STS_TABLE=  Current ACK Character DC.W STS_19-STS_TABLE Current FE/PE convert Character DC.W STS_20-STS_TABLE Ignore FE/PE DC.W STS_21-STS_TABLE Default baud rate jws DC.W STS_22-STS_TABLE  Default line settings jws STS_ERROR EQU * MOVEQ #BAD_RDS,D0 BRA IOESCAPE error number is passed in d0 *----------------------------------------------------------------------------- STS_0 EQU *  -- ID register -- MOVE.B ID_REG(A1),(A3) get id from card RTS *----------------------------------------------------------------------------- STS_1 EQU * -- Interrupt Status -- MOVE.B INTR_SW(A1),(A3) get result from card RTS *----------------------------------------------------------------------------- STS_2 EQU * -- "Busy Bits" -- MOVE.B INTR_SW(A1),D7 --> interrupt enabled bit (1) AND.B #$80,D7 LSR.B #6,D7 move it to correct position TST.L BUFI_OFF(A2) --> transfer active bit (0) BNE.S SET_BIT_0 TST.L BUFO_OFF(A2) BEQ.S DO_BIT_4  neither transfer is active SET_BIT_0 EQU * set transfer active bit BSET #0,D7 DO_BIT_4 EQU * --> not transmitting bit (4) TST.B XMITTING(A2) BNE.S DO_BIT_5  BSET #4,D7 DO_BIT_5 EQU * --> not receiving bit (5) TST.B RECEIVING(A2) BNE.S END_STS_2 BSET #5,D7 END_STS_2 EQU * store away result MOVE.B D7,(A3) RTS *----------------------------------------------------------------------------- STS_3 EQU * -- Baud rate -- SUBQ.L #1,A3 this routine returns a word * * Get divisor (a critical section since it uses DLAB) * MOVE.B INTR_SW(A1),D7 save card interrupt status CLR.B INTR_SW(A1) disable interrupts BSET #7,LINE_CONT(A1) get access to divisor latches MOVE.B DIV1(A1),D0 get upper half of divisor LSL.W #8,D0 MOVE.B DIV0(A1),D0 get lower half of divisor BCLR #7,LINE_CONT(A1) reset DLAB so normal operation can resume MOVE.B D7,INTR_SW(A1) restore interrupts * * Check for special divisors which division is inexact * STS_3B TST.W D0 - infinite baud rate ? - BNE.S IS85 RTS return zero baud rate IS85 CMP.W #85,D0 - 1800 baud ? - BNE.S IS77 MOVE.W #1800,(A3) RTS IS77 CMP.W #77,D0 - 2000 baud ? - BNE.S IS43 MOVE.W #2000,(A3) RTS IS43 CMP.W #43,D0 - 3600 baud ? - BNE.S IS21 MOVE.W #3600,(A3) RTS IS21 CMP.W #21,D0 - 7200 baud ? - BNE.S REGULAR MOVE.W #7200,(A3) RTS REGULAR EQU * * * Compute baud rate by: baud_rate = (freq/16) / divisor * MOVE.L #153600,D1 BSR RDIVU do the division MOVE.W D1,(A3) store away the answer (d1) RTS *----------------------------------------------------------------------------- STS_4 EQU * -- Character control -- MOVE.B LINE_CONT(A1),D7 get line control AND.B #$3F,D7 remove top two bits MOVE.B S_HANDSH(A2),D6 get handshake LSL.B #5,D6  move it to top two bits OR.B D6,D7 combine to form register result MOVE.B D7,(A3) RTS *----------------------------------------------------------------------------- STS_5 EQU * >  -- Modem control -- MOVE.B MODEM_CONT(A1),(A3) read directly from the UART RTS *----------------------------------------------------------------------------- STS_6 EQU * -- Data in -- BSR  CHECK_ERROR check for errors trapped by ISRs BSR QUEUE_EMPTY read from buffer if not empty BEQ.S READ_UART else read directly from UART MOVE.B INTR_SW(A1),D5 save interrupt state CLR.B INTR_SW(A1) disable card interrupts for critical section BSR GET_CHAR (get character with handshake) MOVE.B D2,(A3) MOVE.B D5,INTR_SW(A1) restore interrupt state  RTS READ_UART EQU * MOVE.B DATA(A1),(A3) RTS *----------------------------------------------------------------------------- STS_7 EQU * -- Optional circuits -- MOVEQ #0,D7 RETURN 0 IF 98644 MOVE.B ID_REG(A1),D6 GET ID REG BCLR #7,D6 CLEAR REMOTE BIT CMP.B #66,D6 BRANCH IF 98644 BEQ.S STS_7B MOVE.B BAUD_SW(A1),D7 read from the card hardware LSR.B #4,D7 right justify (and get rid of baud info) STS_7B MOVE.B D7,(A3) RTS *----------------------------------------------------------------------------- STS_8 EQU * -- interrupt enable mask -- MOVE.B INTR_EN(A1),(A3) read directly from the UART RTS *----------------------------------------------------------------------------- STS_9 EQU * -- interrupt cause -- MOVE.B INTR_ID(A1),(A3) read directly from the UART RTS *----------------------------------------------------------------------------- STS_10 EQU * -- UART status -- MOVE.B INTR_SW(A1),D7 save card interrupt condition CLR.B INTR_SW(A1) disable interrupts for critical section MOVE.B S_LINE(A2),D6 get accumulated line status CLR.B S_LINE(A2) reset it since it is read destructive  MOVE.B D7,INTR_SW(A1) restore interrupts (end critical section) AND.B #$1E,D6 only use the read destructive bits OR.B LINE_STAT(A1),D6 combine it with the current status BSR QUEUE_EMPTY  use internal buffer to determine bit 0 BEQ.S DONT_SET BSET #0,D6 set receive buffer full bit DONT_SET EQU * MOVE.B D6,(A3) RTS *----------------------------------------------------------------------------- STS_11 EQU * -- modem status -- MOVE.B INTR_SW(A1),D7 save card interrupt condition CLR.B INTR_SW(A1) disable interrupts for critical section MOVE.B S_MODEM(A2),D6 get accumulated copy of modem status CLR.B S_MODEM(A2) clear it since it is read destructive MOVE.B D7,INTR_SW(A1) restore interrupts (end critical section) AND.B #$0F,D6  only use the read destructive bits OR.B MODEM_STAT(A1),D6 combine it with the current status MOVE.B D6,(A3) RTS *----------------------------------------------------------------------------- STS_12 EQU *  -- connect/disconnect -- MOVE.B CONNECTED(A2),(A3) get the pseudo-register RTS *----------------------------------------------------------------------------- STS_13 EQU * -- hardware handshake register -- MOVE.B MODEM_ON(A2),(A3) RTS *----------------------------------------------------------------------------- STS_14 EQU * -- current error status -- MOVE.B INTR_SW(A1),D7 save interrupt s> tate CLR.B INTR_SW(A1) disable interrupts MOVE.W S_ERROR+2(A2),-1(A3) get (lower word of) the error * this is a word register! CLR.L S_ERROR(A2) the read is destructive MOVE.B D7,INTR_SW(A1) restore interrupt state RTS *----------------------------------------------------------------------------- STS_15 EQU * -- Current Xon character -- MOVE.B XON_CHAR(A2),(A3) RTS *----------------------------------------------------------------------------- STS_16 EQU * -- Current Xoff character -- MOVE.B XOFF_CHAR(A2),(A3) RTS *----------------------------------------------------------------------------- STS_17 EQU * -- Current ENQ character -- MOVE.B ENQ_CHAR(A2),(A3) RTS *----------------------------------------------------------------------------- STS_18 EQU *  -- Current ACK character -- MOVE.B ACK_CHAR(A2),(A3) RTS *----------------------------------------------------------------------------- STS_19 EQU * -- Current FE/PE convert character -- MOVE.B CONV_CHAR(A2),(A3) RTS *----------------------------------------------------------------------------- STS_20 EQU * -- Ignore FE/PE {aaa} MOVE.B IGNORE_PE(A2),(A3) {aaa} RTS  {aaa} TTL RS232 DRIVERS -- control page *----------------------------------------------------------------------------- STS_21 EQU * -- Default baud rate jws  SUBQ.L #1,A3 return a word jws MOVE.W DEF_BAUD(A2),D0 get default divisor jws BRA STS_3B same as status 3 from hr jws *----------------------------------------------------------------------------- STS_22 EQU * -- Default line switch jws MOVE.B DEF_LINE(A2),(A3) jws RTS * ***************************************************************************** * * write control *---------------------------------------------------------------------------- * CONVENTION: D0.W -- value of the control * ***************************************************************************** RS_RS_WTC EQU * * * Pascal Interface Overhead * MOVEA.L (SP)+,A0 get return address MOVE.W (SP)+,D0 get value MOVE.W (SP)+,D1 get register number MOVEA.L (SP)+,A2 get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * Check for legal registers and jump to correct register handler * TST.W D1 check for negative register number BMI.S CONT_ERROR if so goto common ioescape routine CMP.W #REG_MAX,D1 check for too large register number BGT.S CONT_ERROR LSL.W #1,D1 get ready for (word) table jump MOVE.W CONT_TABLE(D1),D1 get offset from status table JMP CONT_TABLE(D1) do the indexed jump CONT_TABLE EQU * DC.W CONT_0-CONT_TABLE Reset DC.W CONT_1-CONT_TABLE Break DC.W CONT_ERROR-CONT_TABLE Register 2 Undefined DC.W CONT_3-CONT_TABLE Baud rate DC.W CONT_4-CONT_TABLE Character control register DC.W CONT_5-CONT_TABLE Modem control register DC.W CONT_6-CONT_TABLE Data out register DC.W CONT_7-CONT_TABLE Optional circuits register DC.W CONT_ERROR-CONT_TABLE Register 8 Undefined DC.W CONT_ERROR-CONT_TABLE Register 9 Undefined DC.W CON? T_ERROR-CONT_TABLE Register 10 Undefined DC.W CONT_ERROR-CONT_TABLE Register 11 Undefined DC.W CONT_12-CONT_TABLE Connect/Disconnect register DC.W CONT_13-CONT_TABLE Hardware handshake register DC.W  CONT_14-CONT_TABLE Soft reset register DC.W CONT_15-CONT_TABLE Redefine Xon Character DC.W CONT_16-CONT_TABLE Redefine Xoff Character DC.W CONT_17-CONT_TABLE Redefine ENQ Character DC.W CONT_18-CONT_TABLE Redefine ACK Character DC.W CONT_19-CONT_TABLE Redefine FE/PE convert Character DC.W CONT_20-CONT_TABLE Ignore FE/PE {aaa} DC.W CONT_21-CONT_TABLE Set default baud rate DC.W CONT_22-CONT_TABLE Set default line control CONT_ERROR EQU * MOVEQ #BAD_RDS,D0 BRA IOESCAPE error number is passed in d0 *----------------------------------------------------------------------------- CONT_0  EQU * -- reset -- TST.W D0 BNE ASM_INIT initialize if any bit is set RTS *----------------------------------------------------------------------------- CONT_1 EQU *  -- send break -- TST.W D0 BEQ.S EXIT_C1 no-op if control value is zero * * set and hold break for 400ms * BSET #6,LINE_CONT(A1) set the break bit in UART MOVE.L #400000,-(SP) USE DELAY ROUTINE ttt JS 8/3/83 WAIT_BREAK EQU * JSR DELAY_TIMER CALL DELAY ROUTINE ttt JS 8/3/83 * * release break and wait 60ms for break to clear * BCLR #6,LINE_CONT(A1) clear the break bit in UART  MOVE.L #60000,-(SP) SETUP FOR DELAY ROUTINE ttt JS 8/3/83 WAIT_BREAK2 EQU * JSR DELAY_TIMER CALL DELAY ROUTINE ttt JS 8/3/83 EXIT_C1 RTS *----------------------------------------------------------------------------- CONT_3 EQU * -- Baud rate -- * * check for overflow -- a baud rate with a resulting divisor more than * sixteen bits long. * (underflow is not checked because it cannot be generated with a word * length baud rate) * CMP.W #5,D0 5 is the lowest baud rate possible BGE.S CALC_DIV MOVEQ #IO_MISC,D0 value out of range -- io misc error BRA IOESCAPE * * calculate divisor : div = (freq/16) / baud_rate * CALC_DIV EQU * MOVE.L #153600,D1 d1 := freq/16 BSR RDIVU d1.w := d1.l / d0.w ( freq/16 / baud ) * * move the divisor to hardware (critical section: uses DLAB) *  MOVE.B INTR_SW(A1),D7 save card interrupt state CLR.B INTR_SW(A1) disable card interrupts BSET #7,LINE_CONT(A1) set DLAB to get access to divisor latches MOVE.B D1,DIV0(A1) set lower half of divisor latch LSR.W #8,D1 MOVE.B D1,DIV1(A1) set upper half of divisor latch BCLR #7,LINE_CONT(A1) clear DLAB for normal use MOVE.B D7,INTR_SW(A1) restore card interrupt state RTS *----------------------------------------------------------------------------- CONT_4 EQU * -- Character Control -- MOVE.B D0,D7 save a copy of control value AND.B #$3F,D0  use only bottom 6 bits MOVE.B D0,LINE_CONT(A1) for line control AND.B #$C0,D7 handshake is top two bits LSR.B #5,D7 shift it for later use CMP.B S_HANDSH(A2),D7  if handshake changed BEQ.S EXIT_C4 MOVE.B INTR_SW(A1),D6 save interrupt state CLR.B INTR_SW(A1) disable interrupts MOVE.B D7,S_HANDSH(A2) save new handshake MOVE.B #1,RECEI? VING(A2) \ MOVE.B #1,XMITTING(A2) / reset the handshake flags MOVE.B D6,INTR_SW(A1) restore interrupt state EXIT_C4 RTS *----------------------------------------------------------------------------- CONT_5  EQU * -- modem control -- MOVE.B D0,MODEM_CONT(A1) write directly to UART RTS *----------------------------------------------------------------------------- CONT_6 EQU * -- Data out -- BSR CHECK_ERROR check for errors trapped by ISRs MOVE.B D0,DATA(A1) write directly to UART RTS *----------------------------------------------------------------------------- CONT_7 EQU *  -- Optional Circuits -- MOVE.B ID_REG(A1),D6 GET ID REG BCLR #7,D6 CLEAR REMOTE BIT CMP.B #66,D6 IS THIS A 98644 ? BEQ.S CONT_7R YES, NO OP  LSL.B #4,D0 left justify MOVE.B D0,BAUD_SW(A1) write directly to card hardware CONT_7R RTS *----------------------------------------------------------------------------- CONT_12 EQU * -- connect/disconnect -- TST.B D0 check for d0=0 BEQ DISCONNECT disconnect will do return CMP.B #1,D0 BEQ CONNECT connect will return VAL_ERR EQU * MOVEQ #IO_MISC,D0 illegal value for register BRA IOESCAPE *----------------------------------------------------------------------------- CONT_13 EQU * -- hardware handshake -- TST.B D0  check for too small value BLT.S VAL_ERR (located in cont_12) CMP.B #1,D0 check for too large value BGT.S VAL_ERR MOVE.B D0,MODEM_ON(A2) assign modem flag RTS *----------------------------------------------------------------------------- CONT_14 EQU * -- soft reset -- TST.W D0 any bit will do reset BEQ.S EXIT_14 zero value does nothing BSR SOFT_RESET EXIT_14 RTS *----------------------------------------------------------------------------- CONT_15 EQU * -- redefine Xon character -- MOVE.B D0,XON_CHAR(A2) RTS *----------------------------------------------------------------------------- CONT_16 EQU * -- redefine Xoff character -- MOVE.B D0,XOFF_CHAR(A2) RTS *----------------------------------------------------------------------------- CONT_17 EQU * -- redefine ENQ character -- MOVE.B D0,ENQ_CHAR(A2) RTS *----------------------------------------------------------------------------- CONT_18 EQU * -- redefine ACK character -- MOVE.B D0,ACK_CHAR(A2) RTS *----------------------------------------------------------------------------- CONT_19 EQU * -- redefine FE/PE convert character -- MOVE.B D0,CONV_CHAR(A2) RTS *----------------------------------------------------------------------------- CONT_20 EQU * -- Ignore PE/FE -- {aaa} TST.B D0 check for too small value {aaa} BLT.S VAL_ERR2  {aaa} CMP.B #1,D0 check for too large value {aaa} BGT.S VAL_ERR2 {aaa} MOVE.B D0,IGNORE_PE(A2) assign modem flag {aaa}  RTS {aaa} VAL_ERR2 EQU * {aaa} MOVEQ #IO_MISC,D0 illegal value for register{aaa} BRA IOESCAPE @  {aaa} *----------------------------------------------------------------------------- CONT_21 EQU * -- Set default baud rate {jws} CMP.W #5,D0 check for overflow {jws}  BGE.S CALC_DIV21 if ok then skip {jws} MOVEQ #IO_MISC,D0 else give error {jws} BRA IOESCAPE {jws} CALC_DIV21 EQU *  {jws} MOVE.L #153600,D1 calculate divisor {jws} BSR RDIVU same as CONT_3 {jws} MOVE D1,DEF_BAUD(A2) save divisor as DEF_BAUD {jws} RTS *---------------------------------------------------------------------------- CONT_22 EQU * -- Set default line sw. {jws} MOVE.B D0,DEF_LINE(A2) {jws} RTS  {jws} TTL RS232 DRIVERS -- interrupt service routines page ***************************************************************************** * * interrupt service routine * ***************************************************************************** RS_RS_ISR EQU * * * pascal interface overhead * MOVEA.L (SP)+,A0 get return address MOVEA.L (SP)+,A2 get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * verify there is an interrupt * MOVE.B INTR_ID(A1),D0 get interrupt cause BTST #0,D0 make sure an interrupt is pending BEQ.S INTR_EXIST RTS no interrupt-- return * * jump to appropriate interrupt handler * INTR_EXIST EQU * MOVE.B #1,IN_ISR(A2) mark isr processing EXT.W D0 MOVE.W INTR_TABLE(D0),D0 (get appropriate address) JMP INTR_TABLE(D0) (jump to the proper case) INTR_TABLE EQU * DC.W MODEM_INTR-INTR_TABLE modem change interrupt DC.W OUTPUT_INTR-INTR_TABLE output empty interrupt DC.W INPUT_INTR-INTR_TABLE input available interrupt DC.W ERROR_INTR-INTR_TABLE error interrupt page * * Check for possible unexpected interrupts, if found clear the interrupt * (different for each type of interrupt) and disable that type of * interrupt. ERROR_INTR EQU * MOVE.B LINE_STAT(A1),D0 clear the interrupt (by reading line status) OR.B D0,S_LINE(A2) save line status for user BCLR #2,INTR_EN(A1) disable interrupts since it should not happen BRA END_ISR MODEM_INTR EQU * TST.B MODEM_ON(A2) modem handshake on? BEQ.S ABORT_MODEM -- no abort MOVE.L BUFO_OFF(A2),D7 output transfer active? BNE.S XFER_OUT -- yes do transfer ABORT_MODEM EQU * MOVE.B MODEM_STAT(A1),D0 clear the interrupt (by reading modem status) OR.B D0,S_MODEM(A2) save modem status for user BCLR #3,INTR_EN(A1) disable interrupt so it won't happen again BRA END_ISR OUTPUT_INTR EQU * MOVE.L BUFO_OFF(A2),D7 output interrupt transfer active ?  BNE.S XFER_OUT -- yes do transfer BCLR #1,INTR_EN(A1) -- no disable interrupt BRA END_ISR page * * Do the output interrupt transfer * (but only if the THRE and the modem lines are high) * XFER_OUT EQU * MOVEA.L D7,A3 a3 := buffer control block MOVE.B LINE_STAT(A1),D7 check for THRE OR.B D7,S_LINE(A2) save line status for user BTST #5,D7 BEQ E@ ND_ISR TST.B MODEM_ON(A2) BEQ.S MOVE_OUT BSR CHECK_DSR_CTS BNE END_ISR MOVE_OUT EQU * CLR.W D7 clear d7.w MOVEA.L TEMP_OFF(A3),A0 a0 := buffer empty pointer MOVE.B (A0)+,D7 d7 := character MOVE.B D7,DATA(A1) write the character MOVE.L A0,TEMP_OFF(A3) update empty pointer SUBQ.L #1,TCNT_OFF(A3) decrement the count BLE.S END_XOUT count=0, transfer ends CMP.W TCHR_OFF(A3),D7 character = term. char ? BNE END_ISR END_XOUT EQU * TST.B TEND_OFF(A3) end condition enabled ? BEQ.S CLR_XOUT TST.B MODEM_ON(A2) modem handshake on ? BEQ.S CLR_XOUT ANDI.B #$F5,INTR_EN(A1) disable output and modem interrupts LOOP_LAST EQU * MOVE.B LINE_STAT(A1),D7 wait for everything transferred OR.B D7,S_LINE(A2) before dropping RTS NOT.B D7 AND.B #$60,D7 BNE.S LOOP_LAST BCLR #1,MODEM_CONT(A1) drop RTS is the EOI condition BSR CLEAR_XFER clear the transfer  JSR LOGEOT call the eot procedure BRA END_ISR CLR_XOUT EQU * ANDI.B #$F5,INTR_EN(A1) disable output and modem interrupts BSR CLEAR_XFER clear the transfer JSR LOGEOT call the eot procedure BRA END_ISR page * * Input interrupts are normally active in order to fill the internal * buffer * INPUT_INTR EQU * MOVE.B LINE_STAT(A1),D1 MOVE.B DATA(A1),D2  get the input byte (clears interrupt) OR.B D1,S_LINE(A2) preserve line status for user TST.B MODEM_ON(A2) BEQ.S CHECK_BREAK skip modem stuff if handshake off * * check for both CD and DSR * MOVE.B MODEM_STAT(A1),D0 OR.B D0,S_MODEM(A2) preserve modem status for user NOT D0 ANDI #$A0,D0 mask appropriate bits BNE INPUT_END if zero then they were set previously * * ignore character if break received * CHECK_BREAK EQU * BTST #4,D1 if break received, BNE INPUT_END then ignore character * * convert Framing and Parity errors to specified character * MOVE.B D1,D0 save line status for later use ANDI #$0C,D0 check for PARITY and FRAMING errors BEQ.S NO_CONVERT TST.B IGNORE_PE(A2) {aaa} BNE.S NO_CONVERT  {aaa} MOVE.B CONV_CHAR(A2),D2 convert the character NO_CONVERT EQU * * * jump to appropriate handshake handler * MOVE.B S_HANDSH(A2),D0 EXT.W D0 MOVE.W HAND_TABLE(D0),D0 get address to jump JMP HAND_TABLE(D0) HAND_TABLE EQU * DC.W ENQ_HAND-HAND_TABLE DC.W XON_HAND-HAND_TABLE DC.W NO_HAND-HAND_TABLE DC.W NO_HAND-HAND_TABLE page XON_HAND EQU * * * Do host part of the handshake -- check for Xon and Xoff * CMP.B XON_CHAR(A2),D2 BNE.S CHECK_XOFF MOVE.B #1,XMITTING(A2) turn transmitting back on TST.L BUFO_OFF(A2) \ BEQ INPUT_END \  BSET #1,INTR_EN(A1) \ enable interrupts if output TST.B MODEM_ON(A2) / transfer is active BEQ INPUT_END / BSET #3,INTR_EN(A1) / BRA INPUT_END CHECK_XOFF EQU * CMP.B XOFF_CHAR(A2),D2 BNE.S TERM_HAND CLR.B XMITTING(A2) turn transmitting off MOVE.B #$1,INTR_EN(A1) turn any possible output interrupts off BRA INPUT_END * * Do termA inal part of the handshake * TERM_HAND EQU * TST.B RECEIVING(A2) if receiving is on, might have BEQ.S PUTINQ to turn it off BSR QUEUE_SPACE d3 := space left in queue CMP.W #XOFF_SIZE,D3 BGE.S PUTINQ * * Have to turn receiving off * MOVE.B XOFF_CHAR(A2),D3 prepare to send Xoff BSR SEND send character BNE.S PUTINQ send did not succeed  CLR.B RECEIVING(A2) no longer expecting input BRA.S PUTINQ but put present char in queue page ENQ_HAND EQU * CMP.B ENQ_CHAR(A2),D2 IF char <> ENQ BNE PUTINQ  THEN put char in queue BSR QUEUE_SPACE ELSE CMP.W #ACK_SIZE,D3 IF queue_space <= 80 BGE.S SEND_ACK CLR.B RECEIVING(A2) receiving := false BRA  INPUT_END SEND_ACK EQU * MOVE.B ACK_CHAR(A2),D3 set up parameter in D3 BSR SEND send ACK BEQ INPUT_END CLR.B RECEIVING(A2) not receiving since ACK not sent BRA INPUT_END * * Put character (d2) in queue, and check for overrun. * NO_HAND EQU * PUTINQ EQU * BSR QUEUE_FULL IF queue_full BEQ.S OVERRUN THEN overrun_error BSR INQUEUE  ELSE inqueue(char) INPUT_END EQU * ANDI #$02,D1 check for overrun error BEQ.S CHECK_XIN OVERRUN EQU * MOVE.L #OVERRUN_ERROR,S_ERROR(A2) * * If transfer in is active then do the transfer * CHECK_XIN EQU * TST.B XIN_ACT(A2) check for transfer active BEQ.S END_ISR MOVEA.L BUFI_OFF(A2),A3 a3 := buffer control block pointer BSR DUMP_BUFFER END_ISR EQU * CLR.B IN_ISR(A2) not in isr any longer RTS TTL RS232 DRIVERS -- transfer page ***************************************************************************** * * transfer * ***************************************************************************** RS_RS_TFR EQU * * * Pascal interface overhead * MOVEA.L (SP)+,A0 get return address MOVEA.L (SP)+,A3 get buffer control block address MOVEA.L (SP)+,A2 get temp address MOVEA.L C_ADR(A2),A1 get card address PEA (A0) restore return address * * Card overhead * BSR CONNECT BSR CHECK_ERROR * * Check for unsupported transfer modes *  ( done by table jump also ) * TST.B T_BW_OFF(A3) word mode? BNE.S WORD_ERR -- is unsupported MOVE.B TUSR_OFF(A3),D1 d1.w := offset into transfer table EXT.W D1 ADD.W D1,D1 d1.w := word offset into table MOVE.W XFER_TABLE(D1),D1 JMP XFER_TABLE(D1) XFER_TABLE EQU * DC.W XFER_ERR-XFER_TABLE not used DC.W DMA_ERR-XFER_TABLE serial DMA -- not supported DC.W SER_FHS-XFER_TABLE serial FHS DC.W SER_FHS-XFER_TABLE serial fastest -- same as serial FHS DC.W XFER_ERR-XFER_TABLE not used DC.W INTR_XFER-XFER_TABLE overlap INTR DC.W DMA_ERR-XFER_TABLE overlap DMA -- not supported DC.W XFER_ERR-XFER_TABLE overlap FHS -- not supported DC.W INTR_XFER-XFER_TABLE overlap FASTEST -- same as overlap INTR DC.W INTR_XFER-XFER_TABLE overlap overlap -- same as overlap INTR page * * Error escapes * END_ERR EQU * DMA_ERR EQU * XFER_ERR EQU * BSR CLEAR_XFER MOVEQ #TFR_ERR,D0 BRA IOESCAPE WORD_ERR EQU * BSR CLEAR_XFER A  MOVEQ #NO_WORD,D0 BRA IOESCAPE * * Set the actual mode for transfers * SER_FHS EQU * MOVE.B #TT_FHS,TACT_OFF(A3) set the actual mode TST.B TDIR_OFF(A3) jump to correct direction handler BNE.S OUTPUT_XFER BRA.S INPUT_XFER INTR_XFER EQU * MOVE.B #TT_INT,TACT_OFF(A3) set actual mode to INTR TST.B TDIR_OFF(A3) jump to correct direction handler BNE.S OUTPUT_XFER * BRA.S INPUT_XFER * * Input transfer setup. * INPUT_XFER EQU * TST.B TEND_OFF(A3) end condition not allowed on input xfers BNE.S END_ERR BSR DUMP_BUFFER do most of transfers with intr enabled BEQ.S EXIT_TFR if transfer done, then exit CLR.B INTR_SW(A1) disable interrupts for critical section MOVE.B #1,XIN_ACT(A2) BSR SET_XFER set interface busy BSR DUMP_BUFFER make sure that buffer is empty (prevent deadlock) * if eot the following code will exit * so no explicit exit is done BSET #7,INTR_SW(A1) end of critical section BRA.S CHECK_FHS end of input transfer setup page * * Output transfer setup * OUTPUT_XFER EQU * CLR.B INTR_SW(A1) disable interrupts for critical section BSR SET_XFER set interface busy BSET #1,MODEM_CONT(A1) set RTS TST.B XMITTING(A2) if not transmitting, don't enable interrupts BEQ.S CHECK_FHS BSET #1,INTR_EN(A1) enable output interrupts TST.B MODEM_ON(A2) if modem handshake BEQ.S CHECK_FHS BSET #3,INTR_EN(A1) enable modem interrupts * * IF serial transfer THEN wait until transfer is done * CHECK_FHS EQU * BSET #7,INTR_SW(A1) end of critical section CMPI.B #TT_FHS,TACT_OFF(A3) BNE.S EXIT_TFR WAIT_FHS EQU * CMPI.B #255,T_SC_OFF(A3) wait until buffer is not busy BNE.S WAIT_FHS EXIT_TFR EQU * RTS TTL RS232 DRIVERS -- transfer support routines page ****************************************************************************** * * TRANSFER SUPPORT ROUTINES * ****************************************************************************** * * DUMP BUFFER * transfer from the internal queue to user queue * * ON ENTRY: a3 - points to buffer control block * ON EXIT : IF transfer was completed * THEN d2.L=0 and Z=1 * ELSE d2.L=1 and Z=0 * USES: a0 - current fill pointer to user input buffer * d2 - character being transfered *----------------------------------------------------------------------------- DUMP_BUFFER EQU * MOVEA.L TFIL_OFF(A3),A0 get fill pointer CLR.W D2 clear top half of D2 (for later compares) DUMP_LOOP EQU * BSR QUEUE_EMPTY BEQ.S EXIT_DUMP BSR GET_CHAR d2 := character  MOVE.B D2,(A0)+ put it in the linear buffer SUBQ.L #1,TCNT_OFF(A3) decrement count BLE.S END_XIN CMP.W TCHR_OFF(A3),D2 BNE.S DUMP_LOOP END_XIN EQU * MOVE.L A0,TFIL_OFF(A3) update fill pointer CLR.B XIN_ACT(A2) BSR CLEAR_XFER JSR LOGEOT CLR.L D2 set Z flag to mark transfer ended RTS EXIT_DUMP EQU * MOVE.L A0,TFIL_OFF(A3)  update fill pointer MOVEQ #1,D2 clear Z flage to mark transfer still active RTS page *----------------------------------------------------------------------------- * CLEAR_XFER * make a transfer B inactive (unlink temp space and buffer control block) * ON ENTRY: a3 - points to the buffer control block *----------------------------------------------------------------------------- CLEAR_XFER EQU * CLR.B TACT_OFF(A3) clear actual transfer mode MOVE.B #255,T_SC_OFF(A3) set the buffer not busy TST.B TDIR_OFF(A3) BNE.S CLEAR_OUT CLR.L BUFI_OFF(A2) clear input transfer RTS CLEAR_OUT EQU * CLR.L BUFO_OFF(A2) clear output transfer RTS *----------------------------------------------------------------------------- * SET_XFER * make a transfer active (link temp space with buffer control block) * ON ENTRY: a3 - the buffer control block *----------------------------------------------------------------------------- SET_XFER EQU * MOVE.B IO_SC(A2),T_SC_OFF(A3) set the buffer busy TST.B TDIR_OFF(A3) BNE.S SET_OUT MOVE.L  A3,BUFI_OFF(A2) set sc's input active RTS SET_OUT EQU * MOVE.L A3,BUFO_OFF(A2) set sc's output active RTS *----------------------------------------------------------------------------- * CHECK_XFER_IN, CHECK_XFER_OUT * gives an error if a transfer is active * USES: d0 -- only if an ioescape is to be given *----------------------------------------------------------------------------- CHECK_XFER_IN EQU * TST.L BUFI_OFF(A2)  BNE.S BUSY_ERR RTS CHECK_XFER_OUT EQU * TST.L BUFO_OFF(A2) BNE.S BUSY_ERR RTS BUSY_ERR EQU * MOVEQ #SC_BUSY,D0 BRA IOESCAPE TTL RS232 DRIVERS -- common utilities  page ***************************************************************************** * * Useful Subroutines * ***************************************************************************** * * IOESCAPE * ON ENTRY: d0.L -- contains the escape code *---------------------------------------------------------------------------- IOESCAPE EQU * MOVE.L D0,IOE_RSLT(A5) * put ioe_result CLR.L D0 *<<< BUG FIX >>> MOVE.B IO_SC(A2),D0 * get select code of card MOVE.L D0,IOE_SC(A5) * put ioe_sc MOVE.W #IOE_ERROR,ESC_CODE(A5) * escapecode := ioe_error TRAP #10 * do Pascal escape *---------------------------------------------------------------------------- * RDIVU * unsigned integer divide rounded. * ON ENTRY: d0.w -- divisor (unchanged by this routine) * d1.l -- dividend * ON EXIT: d1.w -- rounded quotient *---------------------------------------------------------------------------- RDIVU EQU * DIVU D0,D1 do truncated division SWAP D1 get access to remainder LSL.W #1,D1  multiply remainder by 2 BCS.S ROUND if carry then remainder*2>divisor CMP.W D1,D0 remainder*2 > divisor ? BLE.S ROUND round up if so. *  --do not round -- SWAP D1 get quotient RTS ROUND EQU * --round up-- SWAP D1 get old quotient ADDQ.W #1,D1 increment (do the rounding) RTS page *---------------------------------------------------------------------------- * CONNECT * connects the card if not connected already. * * uses : d6,d7 by called routines *---------------------------------------------------------------------------- CONNECT EQU * TST.B CONNECTED(A2) IF connected THEN do nothing BNE.S EXIT_CONNECT BSET #0,MODEM_CONT(A1) set DTR BSR SOFT_RESET B  initialize the dynamic data MOVE.B #1,INTR_EN(A1) enable receive interrupts MOVE.B #1,CONNECTED(A2) set connected BSET #7,INTR_SW(A1) enable card interrupts EXIT_CONNECT EQU * RTS *----------------------------------------------------------------------------- * DISCONNECT * disconnect and disable interrupts *----------------------------------------------------------------------------- DISCONNECT EQU * BCLR  #7,INTR_SW(A1) disable card interrupts CLR.B CONNECTED(A2) set disconnected ANDI.B #$FC,MODEM_CONT(A1) drop DTR and RTS NOP CLR.B INTR_EN(A1) disable all UART interrupts RTS page *----------------------------------------------------------------------------- * SOFT_RESET * initialize the "dynamic" attributes of the drivers * * uses : d6,d7 as temporary *----------------------------------------------------------------------------- SOFT_RESET EQU * JSR ABORT_IO abort transfers MOVE.B INTR_SW(A1),D6 save interrupt state CLR.B INTR_SW(A1) disable interrupts ANDI.B #1,INTR_EN(A1) disable modem and transmit interrupts BSR INIT_QUEUE MOVE.B DATA(A1),D7 destroy any data CLR.B S_LINE(A2) MOVE.B LINE_STAT(A1),D7 reset the line status (destructive read)  CLR.B S_MODEM(A2) MOVE.B MODEM_STAT(A1),D7 reset the modem status (destructive read) CLR.L S_ERROR(A2) MOVE.B #1,RECEIVING(A2) MOVE.B #1,XMITTING(A2) MOVE.B D6,INTR_SW(A1) restore the interrupt state RTS *---------------------------------------------------------------------------- * CHECK_ERROR * check for errors recorded in interrupt service routines (ISRs) * USES: D0,D7 only if doing ioescape *---------------------------------------------------------------------------- CHECK_ERROR EQU * TST.L S_ERROR(A2) is error present BNE.S ERROR_EXIST RTS return if not error ERROR_EXIST EQU * MOVE.B INTR_SW(A1),D7 save interrupt condition CLR.B INTR_SW(A1) disable interrupt for critical section MOVE.L S_ERROR(A2),D0 get error CLR.L S_ERROR(A2) clear errors  MOVE.B D7,INTR_SW(A1) restore interrupts BRA IOESCAPE do pascal escape page *----------------------------------------------------------------------------- * WAIT_SEND * This routine waits for the transmitting flag then sends * a character. It escapes if SEND returns with an error. * NOTE: this routine cannot be called by ISRs!!! * ON ENTRY: d3.B -- character to be sent * USES : a4 -- used by called routines *  d4,d6,d7 -- by called routines *----------------------------------------------------------------------------- WAIT_SEND EQU * * * Wait for xmitting flag (no timeouts !!) * (the wait is important for Xon/Xoff as host) *  TST.B XMITTING(A2) BEQ.S WAIT_SEND * * Send the character * OK_XMIT EQU * BSR SEND send character with timeout BSR CHECK_ERROR check for errors found by send RTS *----------------------------------------------------------------------------- * WAIT_GET * wait until the queue is empty before getting a character * ON EXIT: D2.B contains the character * (the rest of D2 is not altered!) * USES: A4.L -- parameter to WAIT * D0,D3,D4,D6,D7 -- used by called routines *----------------------------------------------------------------------------- WAIT_GET EQU * * * Wait (with timeout) for queue not empty * C  LEA CHECK_QUEUE,A4 \ call wait with the not queue empty BSR WAIT / function BSR CHECK_ERROR check for wait error BSR GET_CHAR BSR CHECK_ERROR RTS  page *----------------------------------------------------------------------------- * GET_CHAR * get a character with software handshake. * ON ENTRY : the queue is not empty! * ON EXIT: D2.B contains the character *  (the rest of D2 is not altered!) * USES: D3 -- space left in queue/temporary for character * D0.W -- handshake type & temporary * A4,D4,D6,D7 -- temporary *----------------------------------------------------------------------------- GET_CHAR EQU * * * Read the character ( and pass it back ) * BSR OUTQUEUE get the character (into D2) * * Check for and do handshake overhead * TST.B RECEIVING(A2)  if receiving BNE.S READ_END then no overhead needed * * Jump to appropriate handshake handler * MOVE.B S_HANDSH(A2),D0 get handshake EXT.W D0 MOVE.W H_TABLE(D0),D0 JMP H_TABLE(D0)  H_TABLE EQU * DC.W ENQ_H-H_TABLE DC.W XON_H-H_TABLE DC.W READ_END-H_TABLE no handshake (no overhead) DC.W READ_END-H_TABLE no handshake page * * ENQ/ACK handshake--send ACK if queue can handle more than 80 chars * ENQ_H EQU * BSR QUEUE_SPACE returns space left in D3 CMP.W #ACK_SIZE,D3 BLT.S READ_END space not big enough to send ACK * * Send character to indicate card is receiving and set receiving flag * MOVE.B ACK_CHAR(A2),D3 send ack BRA.S SEND_HAND * * Xon/Xoff handshake--send Xon if queue can handle more characters * XON_H EQU * BSR QUEUE_SPACE d3 := space left in queue CMP.W #XON_SIZE,D3 BLT.S READ_END space not big enough to send XON * * Send character to indicate card is receiving and set receiving flag * MOVE.B XON_CHAR(A2),D3 SEND_HAND EQU * send handshake character (in D3) MOVE.B #1,INTR_EN(A1) only have receive interrupt enabled BSR SEND send char which is in d2 BNE.S RESTORE MOVE.B #1,RECEIVING(A2)  turn receiving back on RESTORE EQU * recalculate interrupt enable mask MOVE.B INTR_SW(A1),D7 save interrupt status CLR.B INTR_SW(A1) critical section TST.L BUFO_OFF(A2) BEQ.S END_RESTORE TST.B XMITTING(A2) BEQ.S END_RESTORE BSET #1,INTR_EN(A1) TST.B MODEM_ON(A2) BEQ.S END_RESTORE BSET #3,INTR_EN(A1) END_RESTORE EQU * MOVE.B D7,INTR_SW(A1)  end critical section READ_END EQU * RTS page *----------------------------------------------------------------------------- * SEND * ON ENTRY: d3.B -- character to be sent * ON EXIT : IF character sent *  THEN Z=1 * ELSE Z=0, S_ERROR updated to newest error * USES : a4 -- parameter to WAIT * d7 -- temporary * d6 -- by called routines *----------------------------------------------------------------------------- SEND EQU * BSET #1,MODEM_CONT(A1) set RTS * * Wait (with timeout) for transmit registers empty * LOOP_THRE EQU * MOVE.B LINE_STAT(A1),D7 OR.B D7,S_LINE(A2) save line status for user AND.B #$20,D7 look at THRE bit BEQ.S LOOP_THRE TST.B MODEM_ON(A2) skip modem stuff if modem handshake off BEQ.S XMIT_CHAR * * Modem checking depends on if this routiC ne was called from an ISR * TST.B IN_ISR(A2) BEQ.S NOT_ISR BSR CHECK_DSR_CTS BEQ.S XMIT_CHAR modem lines are up, goto transmit MOVE.L #316,S_ERROR(A2) CTS false error RTS  side effect -- Z:=0 * * Wait (with timeout) for DSR and CTS * NOT_ISR EQU * LEA CHECK_DSR_CTS,A4 \ call WAIT with appropriate BSR WAIT / function parameter BEQ.S  XMIT_CHAR no errors, goto transmit RTS (Z=0 still) * * Send the character (in d3) * XMIT_CHAR EQU * MOVE.B D3,DATA(A1) do actual transmit CLR.B D7  indicate no errors (Z := 1) RTS page *----------------------------------------------------------------------------- * WAIT * this function waits with timeout for a condition to happen, * if the condition does not happen within the timeout, then * S_ERROR(A2) is marked with the timeout error. * ON ENTRY: A4.L points to the routine which will determine if * the condition is met. This routine should have *  the following conditions: * --uses at the most d7,d6 * --returns Z=1 if the condition is met * --all routines should have similar timing * ON EXIT: IF error is found *  THEN Z=0, S_ERROR indicates the error * ELSE Z=1 * USES : D4.L -- timeout counter * D7,D6 -- can be used by called routine (see above) *----------------------------------------------------------------------------- WAIT EQU * JSR (A4) check the condition BEQ.S EXIT_WAIT exit if condition met (Z=1) MOVE.L TIMEOUT(A2),D4 BEQ.S WAIT_LOOP2 infinite timeout if value is 0. BTST #TIMER_PRESENT,SYSFLAG2 SEE IF TIMER EXISTS ttt JS 8/3/83 BEQ.S WAIT_TMR IF SO GO USE IT ttt JS 8/3/83 MOVE.L D4,D7 \ LSL.L #1,D7  \ initialize counter LSL.L #2,D4 \ (multiply by 54) ADD.L D7,D4 | MOVE.L D4,D7 / LSL.L #3,D4 / ADD.L D7,D4  / WAIT_LOOP EQU * TST.L S_ERROR(A2) check for errors saved during wait BNE.S EXIT_WAIT exit (Z=0) JSR (A4) check the condition BEQ.S EXIT_WAIT  exit if conditon met (Z=1) SUBQ.L #1,D4 counter := counter - 1 BPL.S WAIT_LOOP MOVE.L #TMO_ERR,S_ERROR(A2) save the timeout error (Z:=0) RTS WAIT_LOOP2 EQU * wait loop for infinite timeout TST.L S_ERROR(A2) check for errors saved by ISRs BNE.S EXIT_WAIT exit (Z=0) JSR (A4) BNE.S WAIT_LOOP2 EXIT_WAIT EQU * RTS WAIT_TMR EQU * MOVE.B #1,-(SP) SET UP TIMER RECORD ttt JS 8/3/83 MOVE.L D4,-(SP) D4 HAS MS TO WAIT ttt JS 8/3/83 WAIT_TMR1 EQU * ttt JS 8/3/83 TST.L S_ERROR(A2) CHECK FOR ERRORS ttt JS 8/3/83 BNE.S WAIT_TEXIT BR IF ERROR ttt JS 8/3/83 JSR (A4) CHECK CONDITION ttt JS 8/3/83 BEQ.S WAIT_TEXIT BR IF CONDITION MET ttt JS 8/3/83  PEA (SP) POINT TO TIMER REC ttt JS 8/3/83 JSR CHECK_TIMER AND CHECK TIMER ttt JS 8/3/83 BPL WAIT_TMR1 IF NO TIMEOUT BRANCH ttt JS 8/3/83 ADDQ #6,SP D TIMEOUT, BUT GET ONE ttt JS 5/3/84 MOVEQ #20,D4 MORE CHANCE WITH ttt JS 5/3/84 BRA WAIT_LOOP SHORT COUNT ttt JS 5/3/84 WAIT_TEXIT EQU * ttt JS 8/3/83 ADDQ #6,SP CLEANUP STACK ttt JS 8/3/83 RTS AND DONE! ttt JS 8/3/83 page ****************************************************************************** * * CHECK_DSR_CTS, CHECK_QUEUE * * FUNCTIONs to be used with WAIT, they all return Z=1 when the * condition is met. * * USES: the function is allowed to use only d6 and d7 * ****************************************************************************** * * condition: queue is empty * CHECK_QUEUE EQU * MOVE.W Q_OUT(A2),D7 (12) CMP.W Q_IN(A2),D7 (12) Z=1 if empty EORI #$04,CCR (20) invert the Z bit (Z=1 if full)  RTS (----> 44 ) * * condition: DSR=1 and CTS=1 (ok to send with modem handshake) * CHECK_DSR_CTS EQU * MOVE.B MODEM_STAT(A1),D7 (12) OR.B D7,S_MODEM(A2) (16) save modem status for user NOT.B D7 ( 4) AND #$30,D7 ( 8) if both DSR and CTS were true, Z=0 NOP ( 4) RTS (----> 44 ) TTL RS232 DRIVERS -- queue utilities page ***************************************************************************** * * Buffer routines * ***************************************************************************** *---------------------------------------------------------------------------- * INIT_QUEUE * initializes the queue descriptor. *---------------------------------------------------------------------------- INIT_QUEUE EQU * MOVE.W #BUFFER_SIZE,Q_SIZE(A2) * initialize queue_size CLR.W Q_IN(A2) * queue_in := 0 CLR.W Q_OUT(A2) * queue_out := 0 RTS *----------------------------------------------------------------------------- * QUEUE_EMPTY * tells if queue is empty. * ON EXIT: Z=empty (IF EMPTY THEN Z:=1 ELSE Z:=0) * USES : D7 *----------------------------------------------------------------------------- QUEUE_EMPTY EQU * MOVE.W Q_OUT(A2),D7 CMP.W Q_IN(A2),D7 * RETURN( queue_in = queue_out ) RTS *----------------------------------------------------------------------------- * QUEUE_FULL * tells if queue is full. * ON EXIT: Z=full (IF FULL THEN Z:=1 ELSE Z:=0) * USES : D7 *----------------------------------------------------------------------------- QUEUE_FULL EQU * MOVE.W Q_IN(A2),D7 * ADDQ.W #1,D7 * CMP.W Q_OUT(A2),D7 * queue_out = queue_in+1 ? BNE.S CHECK_OR * RTS * ( YES so return with Z=1) CHECK_OR EQU * CMP.W Q_SIZE(A2),D7 * queue_in+1 = queue_size ?  BEQ.S CHECK_AND * RTS * ( NO so return with Z=0) CHECK_AND EQU * MOVE.W Q_OUT(A2),D7 * queue_out = 0 ? RTS * ( ANSWER is result of function ) page *----------------------------------------------------------------------------- * INQUEUE * puts a character in the queue * ON ENTRY: d2.B - character to be put in the queue * buffer NOT full !! * USES : a4.L - queue_addr * d7.W - queue_in *----------------------------------------------------------------------------- INQUEUE EQU * MOVE.W Q_IN(A2),D7 * MOVE.B D  D2,Q_BUFFER(A2,D7.W) * (queue_addr+queue_in)^ := char ADDQ.W #1,D7 * queue_in := queue_in+1 CMP.W Q_SIZE(A2),D7 * BGE.S RESET_IN * IF queue_in >= queue_size MOVE.W D7,Q_IN(A2) * RTS * RESET_IN EQU * * CLR.W Q_IN(A2) * THEN queue_in := 0 RTS * *----------------------------------------------------------------------------- * OUTQUEUE * take the next character out of the queue * ON ENTRY: buffer NOT full * ON EXIT : d2.B - character from the queue * USES : a4.L - queue_addr *  d7.W - queue_in *----------------------------------------------------------------------------- OUTQUEUE EQU * MOVE.W Q_OUT(A2),D7 * MOVE.B Q_BUFFER(A2,D7.W),D2 * char := (queue_addr+queue_out)^ ADDQ.W #1,D7 * queue_out := queue_out+1 CMP.W Q_SIZE(A2),D7 ** BGE.S RESET_OUT * IF queue_out >= queue_size MOVE.W D7,Q_OUT(A2) * RTS * RESET_OUT EQU * * CLR.W Q_OUT(A2) * THEN queue_out := 0 RTS ** page *----------------------------------------------------------------------------- * QUEUE_SPACE * returns amount of space remaining in the queue * ON EXIT: d3.W - contains the space remaining in the queue. *----------------------------------------------------------------------------- QUEUE_SPACE EQU * MOVE.W Q_OUT(A2),D3 * SUB.W Q_IN(A2),D3 * IF queue_in >= queue_out BGT.S OUT_GREATER * SUBQ.W #1,D3 * THEN queue_space := ADD.W Q_SIZE(A2),D3 * queue_size + queue_out-queue_in - 1 RTS OUT_GREATER EQU * SUBQ.W #1,D3 * ELSE queue_space := RTS * queue_out-queue_in - 1 END  (* (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 'IOLIB:KERNEL.CODE'$ } $COPYRIGHT 'COPYRIGHT (C) 1985 BY HEWLETT-PACKARD COMPANY'$ $MODCAL ON$ $PARTIAL_EVAL ON$ $STACKCHECK ON$ $RANGE OFF$ $DEBUG OFF$ $OVFLCHECK OFF$ $PAGE$ (************************************************************************) (* *) (* RELEASED VERSION 3.1 *) (*  *) (************************************************************************) (* *) (*  *) (* IOLIB RS_DRIVERS *) (* *) (* *) (************************************************************************) (* *) (* *) (* library - IOLIB E  *) (* name - RS_DRIVERS *) (* module(s) - init_rs *) (* - rs *) (* *) (* date - 6 August 1982 *) (* update - 5 June 1985 *) (* release - 12 Jul  1985 *) (* *) (* source - IOLIB:RS_DRV.TEXT *) (* object - IOLIB:RS_DRV.CODE  *) (* *) (************************************************************************) $PAGE$ (************************************************************************) (*  *) (* *) (* BUG FIX HISTORY *) (*  *) (* ------ for 3.0 release *) (* jws J Schmidt io_init_rs Find 98644 cards *) (* 3/5/84 *) (* ------ for 3.1 release *) (* jws2 J Schmidt io_init_rs Add default setups *) (* 6/5/85 using control regs *) (*  21 and 22. *) (* *) (* *) (*  *) (* *) (* *) (* *) (*  *) (* *) (************************************************************************) $PAGE$ (************************************************************************) (* *) (* *) (* This is the source code for an external procedures library  *) (* to be used for general purpose interfacing on the HP 9826. *) (* *) (* The library consists of 3 primary sets of modules - *) (*  *) (* 1. KERNEL modules *) (* 2. driver modules *) (* 3. IOLIB modules  *) (* *) (* The KERNEL modules consist of the following modules - *) (* *) (*  1. iodeclarations ( contains static r/w space ) *) (* 2. iocomasm *) (* 3. general_0 ( initialization & low level *) (* routines like ioread/iowrite) *) (* The KERNEL modules also have an executable program segement *) (* that gets executed at the time it is loaded. This program *) (* initializes the static read/write memory. This program also *) (E * allocates the temporary storage for any card that exists - *) (* independent of whether there is or is not a driver for it. *) (* *) (* The driver modules consist of the actual assembly or PASCAL *) (* routines that deal with a specific interface card. There is *) (* also an executable program segment for each driver module. *) (* This program searches the select code table in the static r/w *) (* initialized by the KERNEL general_0 module for all select codes *) (* that have the right interface card ( HPIB drivers will search *) (* for the 98624 interface ). This program will then set up the *) (* driver tables to point to the correct drivers. *) (* *) (* The rest of the IOLIB modules are high-level modules that are *) (* used by an end user in his/her application program. *) (* *) (* The KERNEL and some set of driver modules will exist in the *) (* INITLIB file as object code ( not EXPORT text ). The *) (*  export text will reside on the IO file. The rest *) (* of the library will reside on the IO file. *) (* *) (************************************************************************) $PAGE$ (************************************************************************) (* *) (*  *) (* REFERENCES : *) (* *) (* *) (* 1. 9826 I/O Designers Guide ( Loyd Nelson ) *) (* *) (* 2. 68000 Manual ( Motorola ) *) (*  *) (* 3. Pascal Language System Users Manual ( 9826-90070 ) *) (* *) (* 4. Pascal Procdure Library Users Manual( 9826-90074 ) *) (*  *) (* 5. 9826 card documentation ( Mfg. Specs. ) *) (* *) (* 6. Pascal I/O Library IRS  ( Tim Mikkelsen ) *) (* *) (* 7. 98626A ERS ( Mfg. Specs. ) *) (*  *) (* *) (************************************************************************) PROGRAM rs_initialize ( INPUT , OUTPUT ); $PAGE$ (************************************************************************) (* *) (* *) (* RS-232 CARD DRIVERS *) (*  *) (* *) (************************************************************************) EXTERNAL MODULE rs; { update 2/14/83 purpose This module is a declaration of the importation text for the external drivers. note The assembly language code that is imported needs to be called 'rs'. The routines need to F be called 'rs_@@@@@@' } IMPORT sysglobals, iodeclarations ; EXPORT PROCEDURE rs_init ( temp : ANYPTR ); PROCEDURE rs_isr ( temp : PISRIB ); PROCEDURE rs_rdb ( temp : ANYPTR ; VAR x : CHAR); PROCEDURE rs_wtb ( temp : ANYPTR ; val : CHAR); PROCEDURE rs_rdw ( temp : ANYPTR ; VAR x : io_word); PROCEDURE rs_wtw ( temp : ANYPTR ; val : io_word); PROCEDURE rs_rds ( temp : ANYPTR ; reg : io_word; VAR x : io_word); PROCEDURE rs_wtc ( temp : ANYPTR ; reg : io_word; val : io_word ); PROCEDURE rs_tfr ( temp : ANYPTR ; bcb : ANYPTR ); END; { of rs } $PAGE$ MODULE init_rs; { update 3/5/84 jws  purpose This module initializes the RS 232 drivers. } IMPORT iodeclarations ; EXPORT VAR rs_drivers : drv_table_type; PROCEDURE io_init_rs; IMPLEMENT IMPORT sysglobals , isr , general_0 ,  rs ; PROCEDURE io_init_rs; TYPE baudarraytype = ARRAY [0..15] of io_word; {jws2 } CONST baudarray = baudarraytype[50,75,110,134,150,200, 300,600,1200,1800,2400,3600, 4800,7200,9600,19200]; {jws2 } VAR io_isc : type_isc; dummyword : io_word; io_lvl : io_byte; io_baudsw : io_word; {jws2} io_linesw : io_word; {jws2} BEGIN io_revid := io_revid + ' R3.2'; { set up the driver tables } WITH rs_drivers DO BEGIN rs_drivers := dummy_drivers ; iod_init := rs_init; iod_isr := rs_isr; iod_rdb := rs_rdb; iod_wtb := rs_wtb; iod_rdw := rs_rdw; iod_wtw := rs_wtw; iod_rds := rs_rds; iod_wtc := rs_wtc; iod_tfr := rs_tfr; END; { of WITH } { set up drivers for the interfaces } FOR io_isc:=iominisc TO iomaxisc DO WITH isc_table[io_isc] DO BEGIN IF (card_id = hp98626) or (card_id=hp98644) { jws 3/5/84 } THEN BEGIN io_drv_ptr:=ADDR(rs_drivers); { if the card exists then link in an ISR for it } { ??? - what happens if an ISR fires during init } io_lvl:=((ioread_byte(io_isc,3) DIV 16) MOD 4)+3; IF io_tmp_ptr^.myisrib.INTREGADDR <> NIL THEN BEGIN { if isr exists then unlink it } ISRUNLINK(io_lvl , { level } ADDR(io_tmp_ptr^.myisrib)); { isrib info } END; { of IF } PERMISRLINK(io_drv_ptr^.iod_isr, { isr } ANYPTR(INTEGER(card_ptr)+3), { card address } 192, { intr. mask } 192, { intr. value } io_lvl, { level  } ADDR(io_tmp_ptr^.myisrib)); { isrib info } END; { of IF card_type = hp98626 } END; { of FOR io_isc WITH isc_table[io_isc] BEGIN } { call the actual driver initialization } FOR io_isc:=iominisc TO iomaxisc DO WITH isc_table[io_isc] DO IF (card_id = hp98626) OR (card_id = hp98644) { jws 3/5/84 } THEN BEGIN io_baudsw:=0; { jws2 } io_linesw:=0;  { jws2 } IF card_id=hp98626 THEN BEGIN { jws2 } io_baudsw:=ioread_byte(io_isc,5) MOD 16; { baud switch - jws2 } io_linesw:=ioread_byte(io_isc,7); { pickup line control- jws2 } END { jws2 } ELSE BEGIN { jws2 } io_baudsw:=10; { defaults for 98644 } { jws2 } io_linesw:=3; F  { jws2 } END; iocontrol(io_isc,21,baudarray[io_baudsw]); { jws2 } iocontrol(io_isc,22,io_linesw); { set defaults } { jws2 } CALL( io_drv_ptr^.iod_init, io_tmp_ptr ); END; { of WITH IF } END; { of io_init_rs } END; { of MODULE init_rs } $PAGE$ IMPORT init_rs , LOADER ; BEGIN io_init_rs; MARKUSER; END. { of rs_initialize }  TTL IOLIB IOCOMASM - common assembly routines PAGE ******************************************************************************** * * COPYRIGHT (C) 1985, 1985 BY HEWLETT-PACKARD COMPANY * ******************************************************************************** * * * IOLIB IOCOMASM * * ******************************************************************************** * * * * Library - IOLIB * Module - IOCOMASM * Author - Tim Mikkelsen * Phone - 303-226-3800 ext. 2910 * * Purpose - This set of assembly language * code is intended to be used as * a support module for I/O drivers * * Date - 08/18/81 * Update - 03/25/85 * Release - 7/12/85 * * *  Source - IOLIB:COMASM.TEXT * Object - IOLIB:COMASM.CODE * * ******************************************************************************** * * * RELEASED * VERSION 3.1 * * ******************************************************************************** PAGE ******************************************************************************** * * PASCAL DEFINITION OF MODULE * ******************************************************************************** MNAME IOCOMASM SRC MODULE IOCOMASM; SRC IMPORT iodeclarations; SRC EXPORT SRC FUNCTION dma_request ( temp : ANYPTR ) : INTEGER; SRC PROCEDURE dma_release ( temp : ANYPTR ); SRC FUNCTION bit_set ( v : INTEGER ; SRC  b : INTEGER ) : BOOLEAN ; SRC FUNCTION binand ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SRC FUNCTION binior ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SRC FUNCTION bineor ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SRC FUNCTION bincmp ( x : INTEGER ) : INTEGER ; SRC FUNCTION binasr ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binasl ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binlsr ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binlsl ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC END; { IOCOMASM } SPC 5 DEF IOCOMASM_iocomasm DEF IOCOMASM_dma_request DEF IOCOMASM_dma_release DEF IOCOMASM_bit_set DEF IOCOMASM_binand DEF IOCOMASM_binior DEF IOCOMASM_bineor DEF IOCOMASM_bincmp DEF IOCOMASM_binasr DEF IOCOMASM_binasl DEF IOCOMASM_binlsr DEF IOCOMASM_binlsl PAGE ******************************************************************************** * * SYMBOLS FOR EXPORT - COMMON ASSEMBLY LANGUAGE ROUTINES * * THE SYMBOLS DO NOT HAVE PASCAL ENTRY * POINTS SINCE THEY ARE ONLY USED BY * ASSEMBLY LANGUAGE MODULES OR WITH EXTERNAL DECLARATIONS * ******************************************************************************** DEF DROPDMA DEF GETDMA DEF TESTDMA DEF LOGINT DEF LOGEOT DEF STBSY DEF STCLR DEF DMA_STBSY DEF ITXFR DEF ABORT_IO DEF WAIT_TFR  DEF CHECK_TFR DEF TIMEREXISTS USED AS PASCAL EXTERNAL PROC DEF TIMED_OUT USED AS PASCAL EXTERNAL PROC SPC 3 * ***************************************************************************** * * IMPORTED SYMBOLS * *************G **************************************************************** * REFA CHECK_TIMER USED TO GET AT TIMER ROUTINE IN POWERUP REFA ASM_FLUSH_ICACHE USED TO FLUSH 68020 AFTER DMA XFR * JWH 9/24/90 : LMODE CHECK_TIMER LMODE ASM_FLUSH_ICACHE LMODE save_dtt1 jwh 9/24/90 TTL IOLIB IOCOMASM - pascal binary functions PAGE * * module initialization * IOCOMASM_IOCOMASM EQU * RTS * * bit test * IOCOMASM_BIT_SET EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get bit # MOVE.L (SP)+,D1 get numeric value CLR.B D2 clear indicator BTST D0,D1 test bit in value BEQ.S BITT_EXIT MOVEQ #1,D2  if bit set set indicator BITT_EXIT MOVE.B D2,(SP) push result JMP (A0) return * * binary and * IOCOMASM_BINAND EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get last param MOVE.L (SP)+,D1 get first param AND.L D0,D1 perform AND MOVE.L D1,(SP) push result JMP (A0) return * * binary inclusive or * IOCOMASM_BINIOR EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get last param MOVE.L (SP)+,D1 get first param OR.L D0,D1 perform OR MOVE.L D1,(SP) push result JMP (A0)  return * * binary exclusive or * IOCOMASM_BINEOR EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get last param MOVE.L (SP)+,D1 get first param EOR.L D0,D1 perform XOR MOVE.L D1,(SP) push result JMP (A0) return * * binary complement * IOCOMASM_BINCMP EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get param NOT.L D0 perform complement MOVE.L D0,(SP) push result JMP (A0) return SPC 5 TTL IOLIB IOCOMASM - common equates and definitions PAGE INCLUDE IOLIB:COMDCL TTL IOLIB IOCOMASM - error escape PAGE ******************************************************************************** * * Error escapes * ******************************************************************************** CTMO_ERR MOVEQ #TMO_ERR,D0 timeout BRA.S ESC_ERR TERR_C MOVEQ #TCNTERR,D0 bad transfer specification BRA.S ESC_ERR TERR_B MOVEQ #TFR_ERR,D0 bad transfer specification BRA.S ESC_ERR TERR_D MOVEQ #NO_DMA,D0 DMA not installed * BRA.S ESC_ERR SPC 4 ESC_ERR EXT.L D0 MOVE.L D0,IOE_RSLT(A5) save io error MOVE.B IO_SC(A2),D0 \ get sc for error MOVE.L D0,IOE_SC(A5) / MOVE.W #IOE_ERROR,ESC_CODE(A5) give i/o error TRAP #10  escape TTL IOLIB IOCOMASM - transfer support PAGE ******************************************************************************** * * ABORT_IO * * USED DURING INITIALIZATION/RESET TO MAKE SURE THERE * IS NO ACTIVE BUFFER LEFT AROUND. * * ENTRY: A2.L = TEMP POINTER * * USES: D1,D2,D3 AND ROUTINE DROPDMA (WHICH USES A0) * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** ABORT_IO TRAP  #11 GET INTO SUPERVISOR MODE, SAVE SR scs * scs MOVE SR,-(SP) \ PREVENT INTERRUPTS FOR A MOMENT. ORI #$2700,SR / ABORT_IO3 BSR ITXFR IS THERE A TRANSFER IN PROGRESS? BEQ.S  ABORT_IO2 IF NOT, DO NOTHING CMP.B #TT_DMA,D1 ELSE IS IT A DMA? BEQ.S ABORT_IO1 IF NOT, SKIP BSR DROPDMA ELSE FREE UP THE DMA CH, GET COUNT MOVE.L D4,TCNT_OFF(A3) fix up count G  SUB.L D4,D3 fix up actual count TST.B TDIR_OFF(A3) BNE.S AB_OUT ADD.L D3,TFIL_OFF(A3) if input then update fill BRA.S ABORT_IO1 AB_OUT ADD.L D3,TEMP_OFF(A3) if output then update empty ABORT_IO1 MOVE.B #255,T_SC_OFF(A3) UNBUSY THE BUFFER CLR.B TACT_OFF(A3) SET TRANSFER TYPE TO NONE CLR.L (A4) clear buffer ptr BRA ABORT_IO3 see if there is another ABORT_IO2 MOVE (SP)+,SR RESTORE USER MODE scs RTS scs * scs RTE RESTORE INTERRUPT LEVEL & RETURN PAGE ******************************************************************************** * * CHECK_TFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFER IN THE OPPOSITE DIRECTION. * ( this is called by a tfr routine on cards * that can't do bi-directional tfrs ) * ( gpio and hpib modules use this routine ) * ( with a timeout wait ) * * ENTRY: A2.L = TEMP POINTER * A3.L = BUF CTL BLK POINTER * * EXIT : IF NOT TRANSFER, RETURN * IF TRANSFER, THEN wait until finished *  or until timeout ( if any ) * ******************************************************************************** CHECK_TFR TST.B TDIR_OFF(A3) base test on direction BNE.S CHKT_IN ( if this is in , check out ) CHKT_OUT LEA BUFO_OFF(A2),A4 IS THERE AN output BUFFER ACTIVE? MOVE.L (A4),D1 BRA.S CHKWAIT IF SO , THEN WAIT SPC 2 CHKT_IN LEA BUFI_OFF(A2),A4 is there an input tfr MOVE.L (A4),D1 *  BRA.S CHKWAIT SPC 3 CHKWAIT BEQ.S CHKEXIT exit if no tfr MOVE.L TIMEOUT(A2),D2 get timeout value BEQ.S CHECK_TFR if timeout = 0 then try forever BTST #TIMER_PRESENT,SYSFLAG2 CHECK IF TIMER PRESENT JS 8/3/83 BEQ.S CHKT_TIM IF SO THEN USE IT JS 8/3/83 LSL.L #8,D2 CHKLOOP MOVE.L (A4),D1 check the buffer again BEQ.S CHKEXIT if finished in time then return SUBQ.L #1,D2 decrement BNE.S CHKLOOP BRA CTMO_ERR CHKEXIT RTS SPC 3 CHKT_TIM MOVE.B #1,-(SP) SET UP TIMER RECORD JS 8/3/83 MOVE.L D2,-(SP) JS 8/3/83 CHKT_TIM1 MOVE.L (A4),D1 TRANSFER ACTIVE ? JS 8/3/83 BEQ.S CHKT_TIM2 NO -- EXIT JS 8/3/83 PEA (SP) ELSE CHECK TIMER JS 8/3/83 JSR CHECK_TIMER  JS 8/3/83 BPL CHKT_TIM1 BRANCH IF NOT TIMED OUT JS 8/3/83 BRA CTMO_ERR ELSE DO TIMEOUT ESCAPE JS 8/3/83 CHKT_TIM2 ADDQ.L #6,SP CLEAN TIMER RECORD FROM STACK JS 8/3/83 RTS AND RETURN JS 8/3/83 PAGE ******************************************************************************** * * WAIT_TFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFER. * ( with a timeout wait ) * * ENTRY: A2.L = TEMP POINTER * * EXIT : IF NOT TRANSFER, RETURN * IF TRANSFER, THEN wait until finished * or until timeout ( if any ) * * USES: NO REGS OTHER THAN RETURN VALUES. * * ******************************************************************************** WAIT_TFR BSR ITXFR quick check for tfr BEQ.S WT_DONE and exit MOVE.L TIMEOUT(A2),D6 get timeout value BEQ.S WAIT_TFR if timeout = 0 then try forever BTST #TIMER_PRESENT,SYSFLAG2 IF TIMER PRESENT USE IT JS 8/3/83 BEQ.S WT_TIM BRANCH IF WE HAVE IT JS 8/3/83 LSL.L #5,D6 WT_LOOP BSR.S ITXFR H  try BEQ.S WT_DONE if finished in time then return SUBQ.L #1,D6 decrement BNE.S WT_LOOP BRA CTMO_ERR WT_DONE RTS SPC 3 WT_TIM MOVE.B #1,-(SP) SET UP TIMER RECORD JS 8/3/83 MOVE.L D6,-(SP) JS 8/3/83 WT_TIM1 BSR.S ITXFR CHECK FOR ACTIVE TRANSFER JS 8/3/83 BEQ.S WT_TIM2 NONE -- EXIT JS 8/3/83 PEA (SP)  CHECK TIMER JS 8/3/83 JSR CHECK_TIMER JS 8/3/83 BPL WT_TIM1 LOOK AGAIN IF NOT TIMED OUT JS 8/3/83 BRA CTMO_ERR ELSE DO TIMEOUT ESCAPE JS 8/3/83 WT_TIM2 ADDQ.L #6,SP CLEAN UP TIMER RECORD JS 8/3/83 RTS AND RETURN JS 8/3/83 PAGE ******************************************************************************** * * ITXFR * *  ROUTINE TO CHECK FOR ACTIVE TRANSFER. * * ENTRY: A2.L = TEMP POINTER * * EXIT : IF NOT TRANSFER, RET with zero flag set * IF TRANSFER, RET with not zero * D1.W = ACTUAL TFR TYPE *  D2.W = TERMINATING CHAR FROM TEMPS * D3.L = TRANSFER COUNT FROM TEMPS * A0.L = DATA POINTER FROM TEMPS ( either emtpy or fill ) * A3.L = BUF CTL BLK POINTER FROM TEMPS * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** ITXFR LEA BUFI_OFF(A2),A4 IS THERE AN input BUFFER ACTIVE? MOVE.L (A4),D1 BNE.S ITXFR3 IF NOT, SKIP LEA BUFO_OFF(A2),A4 is there an output tfr MOVE.L (A4),D1 BEQ.S ITXFR1 -no ITXFR3 MOVEA.L D1,A3 \ CLR.L D1 ELSE GET BUFFER TYPE WORD MOVE.B TACT_OFF(A3),D1 / CLR.L D2 MOVE.W TCHR_OFF(A3),D2 GET TERMINATING CHAR MOVE.L TCNT_OFF(A3),D3 GET COUNT MOVEA.L TEMP_OFF(A3),A0 GET EMPTY POINTER TST.B TDIR_OFF(A3) check direction BNE.S ITXFR2 \ IF INPUT MOVEA.L TFIL_OFF(A3),A0 / THEN GET FILL POINTER ITXFR2 MOVEQ #1,D5 set not zero STCLR1 EQU * ITXFR1 RTS PAGE ******************************************************************************** * * STCLR * * ROUTINE TO SET A BUFFER & SELECT CODE NOT BUSY * * ENTRY: gets buf ptr from ITXFR routine * * assumes only one tfr per select code * * USES: A3,D0 * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** STCLR BSR ITXFR GET BUFFER POINTER FROM TEMPS BEQ.S STCLR1 IF ALREADY CLEAR, SKIP MOVE.B #255,T_SC_OFF(A3) CLEAR S.C. INDICATOR IN THE BUF CTL BLK CLR.B TACT_OFF(A3)  clear tfr type CLR.L (A4) CLEAR BUF POINTER IN SC TEMPS *RTS SPC 5 ******************************************************************************** * * LOGEOT * * CALL THE USER PROC AT END OF TRANSFER * * PASCAL ROUTINE * * modified to pass a user parameter: JPC 02/22/82 * ******************************************************************************** LOGEOT LEA T_PR_OFF(A3),A0 point to procedure/static link/parameter H_EOT1 MOVE.L (A0),D0 is there a proc? BEQ.S H_EOT3 skip if not MOVEM.L A1-A4,-(SP) save dedicated regs (8/10/82 JPC) MOVE.L 8(A0),-(SP) push the parameter MOVE.L 4(A0),D1 is there a static link? BEQ.S H_EOT2 Roger Ison says it is okay to try MOVE.L D1,-(SP) and call proc with static link H_EOT2 MOVEA.L D0,A0 procedure address JSR (A0) callH  it MOVEM.L (SP)+,A1-A4 restore dedicated regs (8/10/82 JPC) H_EOT3 RTS PAGE ******************************************************************************** * * LOGINT * * THIS ROUTINE WAS CALLED H_LOG * * CALL THE USER PROC WHEN AN ISR SAYS TO * * PASCAL ROUTINE * * modified to pass a user parameter: JPC 02/22/82 * ******************************************************************************** LOGINT LEA H_ISR_PR(A2),A0 point to procedure/static link/parameter BRA H_EOT1 call it (if it exists) PAGE ******************************************************************************** * * DMA_STBSY * * ROUTINE TO SET A BUFFER BUSY * * ENTRY: * D0.W = TRANSFER COUNT TO BE PUT IN TCNT_OFF(A2) * AND TO BE ADDED TO E/F COUNT. * A0.L = pointer to DMA temps * A2.L = POINTER TO DRIVER TEMPS * A3.L = POINTER TO BUFFER CTL BLOCK * A4.L = POINTER TO TERMINATION ROUTINE * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** DMA_STBSY MOVE.L A4,DMAISR(A0) SAVE THE TERMINATION ROUTINE CLR.L DMASL(A0) CLEAR THE STATIC LINK * BRA.S STBSY SET THE BUFFER BUSY SPC 5 ******************************************************************************** * * STBSY * * ROUTINE TO SET A BUFFER BUSY * * ENTRY: * D0.W = TRANSFER COUNT TO BE PUT IN TCNT_OFF(A2) * AND TO BE ADDED TO E/F COUNT. * A2.L = POINTER TO DRIVER TEMPS * A3.L = POINTER TO BUFFER CTL BLOCK * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** STBSY MOVE.L D0,TCNT_OFF(A3) COPY TFR COUNT INTO TEMPS. TST.B TDIR_OFF(A3) \ BNE.S STBSY1 \  MOVE.L A3,BUFI_OFF(A2) MAKE SELECT CODE BUSY BRA.S STBSY2 / STBSY1 MOVE.L A3,BUFO_OFF(A2) / STBSY2 MOVE.B IO_SC(A2),T_SC_OFF(A3) SET UP BUFFER ACTIVE SELECT CODE RTS DONE! TTL IOLIB IOCOMASM - dma support PAGE ******************************************************************************** * * DMA RESOURCE MANAGEMENT ROUTINES * * ******************************************************************************** SPC 3 ******************************************************************************** * * DMA RESOURCE temporaries * * These resource temporaries need to be aligned with the offsets * generated by the main Pascal library. This is not an automatic * operation - it must be done by hand if ANY new declarations are * added in the iodeclarations in front of the dma resource temps. * ******************************************************************************** DMAFLAG EQU iodeclarations-61 boolean indicating presence of dma hardware SPC 2 DMA0 EQU iodeclarations-8 DMAISR_0 EQU iodeclarations-8 \ DMASL_0 EQU iodeclarations-4 channel 0 temps DMA_SC_0 EQU iodeclarations-9 /  SPC 2 DMA1 EQU iodeclarations-18 DMAISR_1 EQU iodeclarations-18 \ DMASL_1 EQU iodeclarations-14 channel 1 temps DMA_SC_1 EQU iodeclarations-19 / SPC 2 DMAISR EQU 0 isr pointer DMASL EQU 4 static link DMA_SC EQU -1 allocated s.c. SPC 2 DMACH0 EQU $500000 address of dma channel 0 DMACH1 EQU $500008 address of dma channel 1 ******************************************************************************** * * ADDRESS CONSTANTS * ******************************************************************************** H_INT_CA EQU $478000 ADDRESS OF INTERNAL HPIB INTERFACE I  TTL IOLIB IOCOMASM - pascal dma procedures PAGE * * request a dma channel * IOCOMASM_DMA_REQUEST EQU * MOVEA.L (SP)+,A4 save return address MOVEA.L (SP)+,A2 get sc temp MOVEA.L C_ADR(A2),A1 get card ptr TRAP #11 GET INTO SUPERVISOR MODE scs * scs MOVE SR,-(SP) JUST IN CASE CALLER DIDN'T DISABLE ORI #$2700,SR INTERRUPTS, I WILL. BSR TESTDMA SEE IF DMA IS INSTALLED  BEQ.S DR_FAIL IF NOT, return -1 SUBQ.W #1,D3 turn $82/$81 to $81/$80 ANDI.W #1,D3 determine channel EXT.L D3 MOVE.B IO_SC(A2),DMA_SC(A0) ELSE CLAIM THIS CHANNEL FOR CALLER * following 3 lines for 68040 support JWH 2/15/91 btst #3,SYSFLAG2 bne no_40 jsr WRITE_68040 jsr ASM_FLUSH_ICACHE no_40 BRA.S DR_GOOD DR_FAIL MOVE.L #-1,D3 return -1 DR_GOOD MOVE (SP)+,SR restore int. state MOVE.L D3,(SP) assign return value - channel ( or -1 ) JMP (A4) return addr SPC 4 * * release a dma channel * IOCOMASM_DMA_RELEASE EQU * MOVEA.L (SP)+,A0 save return address MOVEA.L (SP)+,A2 get sc temp MOVEA.L C_ADR(A2),A1 get card ptr PEA (A0) push return address BRA DROPDMA release it SPC 4 TTL IOLIB IOCOMASM - assembly dma procedures PAGE ******************************************************************************** * * GETDMA * * ROUTINE TO OBTAIN CONTROL OF A DMA CHANNEL * GET EITHER DMA CHANNEL, TRYING FOR CH 1 FIRST. * * ENTR: CONDITIONS ARE THE SAME AS FOR THE tfr DRIVER ENTRY POINT. * * EXIT: IF DMA IS NOT INSTALLED, 'no dma' escape is generated. * IF DMA IS INSTALLED, THE ALGORITHM WAITS FOR A CHANNEL TO * BECOME AVAILABLE AND THEN: * LOGS USE OF DMA CHANNEL * SETS UP ADDRESS AND COUNT REGISTERS. * CONSTRUCTS CARD ARM AND DMA ARM MASKS AS FOLLOWS: * D2.W = DMA ARM BYTE WITH BITS 1, 2 DEFINED BY * CONTENTS OF D1 AND BIT 0 = 1. * D3.B = CARD ENABLE BYTE WITH BITS 0, 1 DEFINED BY * WHICH DMA CHANNEL WAS GRANTED AND BIT 7=1. * A4.L = ADDRESS OF DMA CHANNEL ARM WORD. * * NOTE: IF THE REQUEST IS FOR INTERNAL HP-IB AS INDICATED BY A1, * ONLY CHANNEL 0 WILL BE GRANTED. * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** GETDMA TRAP #11  GET INTO SUPERVISOR MODE scs * scs MOVE SR,-(SP) JUST IN CASE CALLER DIDN'T DISABLE ORI #$2700,SR INTERRUPTS, I WILL. CMPI.L #$010001,D0 \ make sure count <=65536 BPL TERR_C  / BSR.S TESTDMA SEE IF DMA IS INSTALLED BEQ TERR_D IF NOT, GIVE ERROR MOVE.B IO_SC(A2),DMA_SC(A0) ELSE CLAIM THIS CHANNEL FOR CALLER * added for 68040 support JWH 2/15/91 btst #3,SYSFLAG2  bne not_40 jsr WRITE_68040 jsr ASM_FLUSH_ICACHE not_40 MOVEA.L D2,A4 A4 = ADDRESS OF DMA CHANNEL HARDWARE. SPC 1 MOVE.L TEMP_OFF(A3),D2 \ TST.B TDIR_OFF(A3) \ BNE.S GETDMA1  SET UP ADDRESS MOVE.L TFIL_OFF(A3),D2 / GETDMA1 MOVE.L D2,(A4)+ / SPC 1 SUBQ.L #1,D0 COUNT REGISTERS (COUNT REG MOVE.W D0,(A4)+ MUST BE COUNT-1) ADDQ.L #1,D0 SPC 2 CLR.W D2 MOVE.B TDIR_OFF(A3),D2 MOVE DIRECTION BIT INTO B2 OF D2 LSL #2,D2 IN ORDER TO CONSTRUCT DMA ARM SPC 2 TST.B T_BW_OFF(A3) IF BYTE TRANSFER BEQ.S GETDMA2 THEN SKIP ADDQ.W #2,I D2 ELSE SET BIT 1 OF DMA ARM. GETDMA2 TST.B T_DMAPRI(A3) check for dma priority requested BEQ.S GETDMA3 ADDQ.W #8,D2 if set then set pri bit GETDMA3 ADDQ.W #1,D2 SET BIT0 OF DMA ARM MOVE (SP)+,SR scs RTS scs * scs RTE SPC 6 ******************************************************************************** * *  TESTDMA * * THIS ROUTINE TESTS FOR PRESENCE OF DMA HARDWARE AND WAITS FOR * A CHANNEL TO BECOME AVAILABLE. * * ENTRY: A1 = CARD ADDRESS * * EXIT: IF NO DMA IS INSTALLED, RET with zero flag set * IF DMA IS INSTALLED, RET with not zero set * A0.L = ADDRESS OF DMA FLAG FOR AVAILABLE CHANNEL * D2.L = ADDRESS OF AVAILABLE DMA CHANNEL * D3.B = CARD ENABLE BYTE FOR AVAILABLE CHANNEL * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** TESTDMA LEA DMAFLAG(A5),A0 \ TST.B (A0) DO RET 1 IF NO DMA BEQ.S TESTDMA_C / CMPA.L #H_INT_CA,A1 IF THIS IS A REQUEST FOR THE INTERNAL BEQ.S TESTDMA_A HP-IB, THEN CAN'T TRY FOR CH 1 SO SKIP. LEA DMA1(A5),A0 ELSE ASSUME WE CAN GET CH 1 MOVE.L #DMACH1,D2 * tm MOVEQ #$82,D3 MOVE.B #$82,D3 CMPI.B #255,DMA_SC(A0) CAN WE? BEQ.S TESTDMA_B IF SO, THEN RET 3 TESTDMA_A LEA DMA0(A5),A0 ELSE ASSUME WE CAN GET CH 0 MOVE.L #DMACH0,D2 * tm MOVEQ #$81,D3 MOVE.B #$81,D3 CMPI.B #255,DMA_SC(A0) CAN WE? BEQ.S TESTDMA_B IF HARDWARE PRESENT BUT BUSY,same as not there CLR D5 RTS TESTDMA_B MOVEQ #1,D5 ELSE WE GOT A CH TESTDMA_C RTS SPC 6 ******************************************************************************** * * DROPDMA * * ROUTINE TO FREE UP A DMA CHANNEL * * ENTRY: A2.L = POINTER TO DRIVER TEMPS * * EXIT: D4.W = FINAL DMA CHANNEL COUNT * CHANNEL IS DISARMED. * * USES: A0 * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** DROPDMA EQU * TRAP #11 scs * scs MOVE SR,-(SP) JUST IN CASE CALLER DIDN'T DISABLE ORI #$2700,SR INTERRUPTS, I WILL. BTST #GOT_68020,SYSFLAG2 CHECK IF WE HAVE 68020 BEQ.S DODROP IF NOT THEN SKIP JSR ASM_FLUSH_ICACHE FLUSH ICACHE ON 68020 MOVE CACHE_CTL,D4 GET EXT. CACHE CONTROL WORD ANDI #$63,D4 SET DISABLE MOVE D4,CACHE_CTL TURN CACHE OFF BSET #2,D4 SET ENABLE BIT MOVE D4,CACHE_CTL TURN CACHE BACK ON DODROP MOVEQ #0,D4 ASSUME DMA CHA ALREADY DROPPED... MOVE.B DMA_SC_0(A5),D0 \ CMP.B IO_SC(A2),D0 / IS IT CH 0? BNE.S DROPDMA0 IF NOT, SKIP LEA DMA0(A5),A4 GET A POINTER TO THE CHANNEL R/W LEA DMACH0,A0 POINT A0 TO CH 0 BRA.S DROPDMA1 GO DO IT SPC 2 DROPDMA0 MOVE.B DMA_SC_1(A5),D0 \ CMP.B IO_SC(A2),D0 / IS IT CH 1? BNE.S DROPDMA2 IF NOT, DO NOTHING LEA DMA1(A5),A4 GET A POINTER TO THE CHANNEL R/W LEA DMACH1,A0 POINT A0 TO CH 1 DROPDMA1 equ * * next 3 lines for 68040 support JWH 2/15/91 btst #3,SYSFLAG2 bne same_old jsr copy_68040 same_old MOVE.B #255,DMA_SC(A4) clear s.c. CLR.L DMASL(A4) clear static link CLR.L DMAISR(A4) clear isr pointer MOVE.L (A0)+,D4 DISARM CH BY READING ADDRESS CLR.L D4 MOVE.W (A0),D4 GET FINAL COUNT INTO D0 ADD.W #1,D4 J FIX UP COUNT TO INDICATE LEFT OVER TFR'S DROPDMA2 MOVE (SP)+,SR scs RTS scs * scs RTE PAGE * ******************************************************************************* * WRITE_68040 JEFF HENDERSHOT 2/15/91. * * THIS ROUTINE IS CALLED IN CASE WE HAVE A 68040 AND WE HAVE ACTUALLY * CLAIMED A DMA CHANNEL. BASICALLY, ONCE A DMA CHANNEL HAS ACTUALLY * BEEN ASSIGNED, WE HAVE TO FORCE WRITETHROUGH CACHING MODE AND * FLUSH CACHES. WHEN ALL DMA CHANNELS ARE RELEASED WE CAN RESTORE * COPYBACK MODE IF THAT WAS THE MODE WE ENCOUNTERED HERE. * * CALLED BY : DMA_REQUEST and GETDMA, right after a DMA channel has * actually been claimed. Note - we do not call this from * TESTDMA because TESTDMA does not assign channels * * ALGORITHM: ASSUMES 68040 (PUT TEST BEFORE CALLING) * * IF DTT1 CONTAINS SOMETHING NON-ZERO * SAVE CONTENTS OF DTT1 (IN SAVE_DTT1) * PUT 0 (WRITETHROUGH MODE) IN DTT1 * EXIT ******************************************************************************** SAVE_DTT1 DC.L $00000000 save place for DTT1 * WRITE_68040 trap #11 supervisor mode move.l d0,-(sp) save d0 movec DTT1,d0 grab DTT1 cmpi.l #$00000000,d0 if 0 don't ... beq bag_it bother, already in writethrough move.l d0,SAVE_DTT1 else saveit move.l #0,d0 and force ... movec d0,DTT1 writethrough mode bag_it move.l (sp)+,d0 restore d0 move (sp)+,SR and SR also RTS ********************************************************************************* * COPY_68040 JEFF HENDERSHOT 2/15/91. * * THIS ROUTINE IS CALLED IN CASE WE HAVE A 68040 AND WE ARE * DROPPING A DMA CHANNEL. BASICALLY, ONCE A DMA CHANNEL HAS ACTUALLY * BEEN ASSIGNED, WE HAVE TO FORCE WRITETHROUGH CACHING MODE AND * FLUSH CACHES. WHEN ALL DMA CHANNELS ARE RELEASED WE CAN RESTORE * COPYBACK MODE (IF THAT MODE WAS SAVED EARLIER) * * CALLED BY : DROPDMA, right after the channel is released * * ENTRY: A0 contains DMACH0 or DMACH1 * * ALGORITHM: ASSUMES 68040 (PUT TEST BEFORE CALLING) * * IF SAVE_DTT1 HAS A NON-ZERO VALUE (COPYBACK MODE) * IF CHANNEL 0 RELEASED * IF CHANNEL 1 NOT IN USE * RESTORE DTT1 *  ZERO OUT SAVE_DTT1 * EXIT * IF CHANNEL 1 RELEASED * IF CHANNEL 0 NOT IN USE * RESTORE DTT1 * ZERO OUT SAVE_DTT1 * EXIT ******************************************************************************** COPY_68040 equ * move.l d0,-(sp) save d0 move.l SAVE_DTT1,d0 cmpi.l #0,d0 anything there ?  beq OUTTA_HERE bail out if not move.l a1,-(sp) a1 needed in either case cmpa.l #DMACH0,a0 was it channel 0 released ? bne hadta_be_one if not then one lea DMA1(A5),a1 see if .. CMPI.B #$FF,DMA_SC(a1) channel 1 busy BNE DONT if so don't restore DTT1 BRA PUT_IT otherwise do restore it hadta_be_one equ * no other choice lea DMA0(A5),a1 CMPI.B #$FF,DMA_SC(a1) channel 0 busy ? BNE DONT if so don't restore DTT1 PUT_IT trap #11 otherwise do save it movec d0,DTT1 d0 has SAVE_DTT1 move.l #0,SAVE_DTT1 clear save spotJ  move (sp)+,SR restore SR also DONT movea.l (sp)+,a1 restore a1 OUTTA_HERE move.l (sp)+,d0 restore d0 RTS ****************************************************************************** * * TIMEREXISTS: PASCAL FUNCTION TO SEE IF TIMER EXISTS * * FUNCTION TIMEREXISTS: BOOLEAN; EXTERNAL; * * RETURNS TRUE IF TIMER PRESENT, ELSE FALSE * * J SCHMIDT 8/2/83 * ***************************************************************************** * TIMEREXISTS EQU * BTST #TIMER_PRESENT,SYSFLAG2 CHECK BIT FOR TIMER PRESENT SEQ 4(SP) SET FUNCTION RESULT 0=>TRUE RTS AND RETURN * *************************************************************************** * * TIMED_OUT: PASCAL FUNCTION TO SEE IF TIMEOUT HAS OCCURRED * * FUNCTION TIMED_OUT(VAR REC: TIMEOUTREC): BOOLEAN; EXTERNAL; * * TIMEOUTREC= PACKED RECORD * COUNT: INTEGER { SET TO TIMEOUT IN MS } * FIRSTTIME: BOOLEAN; {SET THIS TO TRUE FOR FIRST * CALL } * END; * * RETURNS: TRUE IF TIMEOUT PERIOD EXPIRED, ELSE FALSE * * CAUTION: WILL SMASH BOTH PARTS OF TIMEOUTREC PARAMETER * * J SCHMIDT 8/2/83 * * REMOVED ADDQ.L #4,SP AFTER SMI JWS 5/3/84 ***************************************************************************** * TIMED_OUT MOVEA.L (SP)+,A0 SAVE RETURN ADDRESS JSR CHECK_TIMER CALL CHECK_TIMER USING PARAMETER ON STK SMI (SP) SET RESULT OF FUNCTION JMP (A0) AND RETURN WITH SP POINTING TO RESULT * ***************************************************************************** * * Bit shifting routines * ***************************************************************************** * IOCOMASM_binasr equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift asr.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return IOCOMASM_binlsr equ  * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift lsr.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return IOCOMASM_binasl equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift asl.l d0,d1 Shift the value move.l d1,(sp)  Push the resulting return value jmp (a0) Return IOCOMASM_binlsl equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift lsl.l d0,d1  Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return end  TTL IOLIB COMDCL - common equates and definitions PAGE ******************************************************************************** * * modified: 02/22/82 JPC added parm to user EOT & ISR proc's * 08/01/83 JS added timer_present and sysflag2 equ's * 03/25/85 JS added got_68020, cache_ctl equ's * * ******************************************************************************** * * HPL CONVENTIONS * * * Much of this code is taken intact from the 9826 HPL * language system EIO ROM ( extended I/O ROM ). * This was written by Bob Hallissy ( originally John Nairn ). * The Pascal that will be calling this code uses * the stack for parameter passage. The HPK L code * uses the Ax and Dx registers for all parameters. * The Pascal driver entry points on the previous pages * take care of getting the parameters into the correct * registers. * * * GENERAL HPL ENTRY/EXIT CONDITIONS: * * A1.L = CARD ADDRESS * A2.L = DRIVER TEMP ADDRESS * UNLESS OTHERWISE INDICATED, THESE REGISTERS ARE UNALTERED. * * * NEW ENTRY/EXIT CONDITIONS FOR PASCAL USE : * * A3.L = BUFFER CONTROL BLOCK ADDRESS *  In addition to the A1/A2 convention, Pascal will use * A3 for a pointer to the buffer control block. * The HPL system kept much of the transfer * information in the s.c. temps. * * TIMEOUT(A2) = contains timeout information * Timeout was a global temp in HPL and a timeout * generated an error. * In PASCAL each card has a timeout value stored in * its temporary area. A timeout error *  generates an ESCAPE ( which can be trapped ). * * ******************************************************************************** PAGE ******************************************************************************** * * * DRIVER TEMPS TEMPLATE * * OFFSET FROM A2 * * HPL DECLARATIONS ( MODIFIED ) * * ******************************************************************************** ISR_ENTRY EQU 0 ..19 PASCAL ISR LINK & UNLINK area USER_ISR EQU 20  user ISR: do NOT change the proc/stat link/parm ordering!!! H_ISR_PR EQU 20 ..23 procedure ptr H_ISR_SL EQU 24 ..27 static link H_ISR_PM EQU 28 ..31 parameter C_ADR EQU 32 ..35 card address BUFI_OFF EQU 36 ..39 buffer pointer offset BUFO_OFF EQU 40 ..43 buffer pointer offset EIRB_OFF EQU 44 eir byte IO_SC EQU 45 select code ( i.e. 7, 22, etc. ) TIMEOUT EQU 46 ..49 timeout value * =0 : no timeout * #0 : value of timeout MA_W EQU 50 ..51 word access to my address MA EQU 51 byte access to my address AVAIL_OFF EQU 52 ..?? standard space taken from temps * 52 ..83 normal cards ( 32 bytes ) * 52 ..179 98628 card ( 128 bytes ) PAGE ******************************************************************************** * *  TRANSFER OFFSETS IN BUFFER CONTROL BLOCK * * OFFSET FROM A3 * * PASCAL DECLARATION * ******************************************************************************** TTMP_OFF EQU 0 ..3 pointer to driver temp offset T_SC_OFF EQU 5 transfer select code TACT_OFF EQU 7 actual transfer mode TUSR_OFF EQU 9 transfer mode * 00 - not used * 01 serial DMA * 02 serial FHS * 03 serial FASTEST ( DMA or FHS ) * 04 - not used * ---------------- *  05 overlp INTR * 06 overlp DMA * 07 overlp FHS ( BURST ) * 08 overlp FASTEST ( DMA or BURST ) *  09 overlp OVERLAP ( DMA or INTR ) T_BW_OFF EQU 10 transfer byte/word indicator * 0 = byte / 1 = word TEND_OFF EQU 11 transfer EOI/END indicator *  0 = no eoi / 1 = eoi sent or searched for TDIR_OFF EQU 13 transfer direction * 0 = input / 1 = output TCHR_OFF EQU 14 ..15 transfer terminate character * K  -1 = no termination character TCNT_OFF EQU 16 ..19 transfer count TBUF_OFF EQU 20 ..23 transfer buffer pointer TBSZ_OFF EQU 24 ..27 transfer buffer maximum size TEMP_OFF EQU 28 ..31 transfer empty pointer pointer TFIL_OFF EQU 32 ..35 transfer fill pointer T_PR_OFF EQU 36 ..39 transfer pointer to eot procedure * NIL no procedure T_SL_OFF EQU 40 ..43 transfer eot proc static link T_PM_OFF EQU 44 ..47 transfer eot proc parameter T_DMAPRI EQU 48 dma priority request * * TRANSFER EQUATES * TT_INT EQU 1 interrupt TT_DMA EQU 2 DMA TT_BURST EQU 3 burst TT_FHS  EQU 4 fast handshake TTL IOLIB IOCOMASM - escape support PAGE ******************************************************************************** * * EXTERNAL REFERANCES for escape * ******************************************************************************** REFA iodeclarations reference the io lib var. area REFA sysglobals SPC 2 ******************************************************************************** * * Escape code values * ******************************************************************************** NO_CARD EQU 1 no interface NOT_HPIB EQU 2 not an hpib interface NO_ACTL EQU 3 no active controller NO_DVC EQU 4 sc ( not device ) specified NO_SPACE EQU 5 not enough space in the buffer NO_DATA EQU 6 not enough data left in the buffer TFR_ERR EQU 7 tfr error SC_BUSY EQU 8 sc is currently busy BUF_BUSY EQU 9 the buffer is busy TCNTERR EQU 10 bad count BADTMO EQU 11 bad timeout value NO_DRV EQU 12  no driver NO_DMA EQU 13 no dma installed NO_WORD EQU 14 no word transfers allowed NOT_TALK EQU 15 not addressed as talker NOT_LSTN EQU 16 not addressed as listener TMO_ERR EQU 17 timeout NO_SCTL EQU 18 not system controller BAD_RDS EQU 19 bad read status / write control BAD_SCT EQU 20 bad set/clear/test CRD_DWN EQU 21 interface is dead EOD_SEEN EQU 22 end of data has happened IO_MISC EQU 23 misc. error SPC 3 IOE_ERROR EQU -26 io sub system error escape code SPC 3 IOE_RSLT EQU IODECLARATIONS-66 IOE_SC EQU IODECLARATIONS-70 SPC 3 ESC_CODE EQU SYSGLOBALS-2 RCVR_BLK EQU SYSGLOBALS-10 TIMER_PRESENT EQU 1 JS 8/1/83 SYSFLAG2 BIT -- 0=>TIMER PRESENT GOT_68020 EQU 4  JS 3/25/85 SYSFLAG2 BIT -- 1=>68020 PRESENT SYSFLAG2 EQU $FFFFFEDA JS 8/1/83 CACHE_CTL EQU $5F400E JS 3/25/85 @@@L @@@@@@@@@@@@@@@@L @@@@@@@@@@@@@@@@M  M  N  N  O  O