(********************************) (* TLP124.pas *) (* LOLITA V03.1 *) (* le 09/05/89 *) (********************************) (*----------------------------------------------------------------------*) (* VERSION MS-PASCAL, JUILLET 1986, P.CHOUR. SUPELEC - SOREFI *) (* ACCES AU LECTEUR DE CARTE, GESTION DE LA PROCEDURE DE TRANSMISSION *) (*----------------------------------------------------------------------*) unit LTLP124; (* gestion du lecteur TLP124 *) interface uses DOS,CAMvars,LOLIIO; (******** Procédures publiques **********) procedure T1_ENTREE_SORTIE(CC: integer; var XDATA:PDU; var STAT:integer); procedure T1_INIT_UART(AD : word); procedure T1_PLED (CC : integer; (* contexte carte *) CODE_ACT : boolean; (* VRAI si ALLUMER, FAUX si ETEINDRE led(s) *) VERTE : boolean; (* VRAI si activer led VERTE *) ROUGE : boolean; (* VRAi si activer led ROUGE *) var STAT : integer); (* compte-rendu d'exécution *) procedure T1_PCLA (CC : integer; (* contexte carte *) EFF : boolean; (* VRAI si effaçage préalable *) POSITION : integer; (* coordonnée afficheur début saisie *) ECHO : boolean; (* VRAI si saisie avec écho *) CAR_ECHO : char; (* caractère d'écho *) NB_ARRET : integer; (* nombre de caractères d'arrˆt *) var ARRET : string; (* tableau des caratères d'arrˆt de *) NB_A_SAISIR : integer; (* nombre de caratères à saisir *) TEMPO : integer; (* tempo inter-caractères lors de la saisie *) var BUFFER : string; (* tableau des caratères saisis *) var NB_SAISIS : integer; (* nombre de caractères saisis *) var STAT : integer); (* compte-rendu d'exécution *) procedure T1_PAFF (CC : integer; (* contexte-carte *) EFF : boolean; (* VRAi si effa‡age préalable *) POSITION : integer; (* coordonnée afficheur début affichage *) NBCAR : integer; (* nombre de caractères à afficher *) var MESS : string; (* tableau des caractères à afficher *) var NB_AFF : integer; (* nombre de caractères affichés *) var STAT : integer); (* compte-rendu d'exécution *) (*************************) implementation const ACK = $60; (* acquitement tlp *) NACK = $E0; (* non acquitement *) ETX = 3; (* fin de texte *) FAUX = false; VRAI = true; KERR_LECT = -1; (* erreur bus ISAM *) KERR_DEB_AFF = 48; (* débordement de l'afficheur *) KERR_TEMPO = 44; (* tempo échue *) KERR_PINPAD = 46; (* autre *) type T_RANG = array[1..2] of integer; T_ECRAN = array[1..2,1..8] of char; var (* statiques au module *) RANG : T_RANG; (* Position corante afficheur pin-pad *) ECRAN : T_ECRAN; (* Contenu de l'afficheur du pin-pad *) function TLP_ASC (T : integer) : char;forward; function ASC_TLP (CAR : char) : integer;forward; procedure ARRETER (N_AR : integer; var ARRET : string; var AR_10 : boolean; var AR_1B : boolean; var AR_1C : boolean);forward; procedure CLAVIER (CC : integer; ORDRE : byte; POSITION : integer; NB_A_SAISIR : integer; var BUFFER : string; var NB_SAISIS : integer; var CAR_ARR : char; TEMPO : integer; ECHO : boolean; AR_10 : boolean; AR_1B : boolean; AR_1C : boolean; var STAT : integer); forward; procedure EFFACE (CC : integer; var STAT : integer);forward; procedure AFFICHE (CC : integer; POSITION : integer; (* coordonnée afficheur début d'affichage *) var MESS : string; NBCAR : integer; var STAT : integer);forward; procedure PINPAD_INIT (CC : integer; TEMPO : integer; CAR_ECHO : char; var STAT : integer);forward; (***********************) (* Initialisation UART *) (***********************) procedure T1_INIT_UART(AD : word); var REGS : registers; begin with REGS do begin AX := UART_7bits or UART_paire or UART_1stop or UART_9600; DX := AD; INTR($14,REGS); end; end; (******************* ORDRES ELEMENTAIRES ***********************) (********************************************) (* INTERPRETATION DU STATUS DU TLP *) (* En entree : COMD : commande TLP en cours *) (* STATUS : STATUS TLP *) (* STAT : Status E/S *) (* En sortie : si STAT < 0, alors STAT : *) (* STAT := bit8+comd+stat *) (* sinon *) (* si STATUS <> 0 alors STAT *) (* est un resume de STATUS *) (********************************************) procedure T1_INTSTATUS(var CC : CONTEXTE_CARTE; ME1,ME2,STATUS : integer; var STAT : integer); var S7_4,S3_0 : integer; begin { write('STATUS=',STATUS);readln; } if STAT = 0 then begin if STATUS > 0 then begin S7_4 := (STATUS div 16) and $0F; S3_0 := (STATUS and $0F); if (STATUS >= 1) and (STATUS <= 9) then STAT := 6 (* erreur acces tlp *) else if STATUS = $A0 then STAT := 8 (* carte non supportée *) else begin if S7_4 in [1..14] then begin case S3_0 of 4,6 : STAT := 1; (* carte douteuse *) 3 : STAT := 7; (* erreur parite carte *) 5 : STAT := 10; (* Erreur signalée par la carte *) 7 : STAT := 0; 2 : STAT := 12; (* carte muette *) else STAT := 11; (* ??? *) end; end else begin if S7_4 = 15 then begin case S3_0 of 0 : STAT := 2; (* defaut Vcc carte *) 7 : STAT := 3; (* carte arrachee *) 8 : STAT := 4; (* probleme d'ecriture dans la carte *) 11: STAT := 5; (* carte absente *) else STAT := 11; end; if STAT=3 then CC^.INIT_CTX := true; end; end; end; end else STAT := STATUS; end; end; procedure PREP_XDATA(ADR1,APPLIC,A1,A2 : integer;L:integer); begin XDATA[2]:=$06; XDATA[3]:=ADR1; (* @ physique du connecteur sur le TLP *) XDATA[4]:=$00; XDATA[5]:=18+L; XDATA[7]:=$01; XDATA[8]:=$04; XDATA[9]:=$FF; XDATA[10]:=$FF; XDATA[12]:=$FF; XDATA[13]:=APPLIC; XDATA[15]:=A1; XDATA[16]:=A2; XDATA[17]:=L ; end; procedure T1_P_XDATAentrant(ADR1,APPLIC,A1,A2 : integer;L:integer); begin PREP_XDATA(ADR1,APPLIC,A1,A2,L); XDATA[1]:=L+16; XDATA[6]:=$DA; XDATA[11]:=2*(L+5); end; procedure T1_P_XDATAsortant(ADR1,APPLIC,A1,A2 : integer;L:integer); begin PREP_XDATA(ADR1,APPLIC,A1,A2,L); XDATA[1]:=16; XDATA[6]:=$DB; XDATA[11]:=$0A; end; (*****************************************) (* procedure d'emission/reception *) (* En entree : XDATA : buffer a emettre *) (* UART : numero de voie *) (* En sortie : STAT = -1 pb émission *) (* = 0, pas d'erreur *) (*****************************************) procedure T1_EMIREC( var XDATA : PDU; UART : word; TMAX : integer; var STAT : integer); var REPET : integer; (* compteur de repetitions *) XBUFFER,EDATA:PDU; NACKE,NACKR:boolean; (* NACK a emettre , NACK recu *) (* variables pour RECEPTION et EMISSION *) NR : integer; I,J : integer; (***********************************) (* CALCUL DU LRC D'UNE TRAME *) (***********************************) function LRC(var BLOC:PDU;NBOCT:integer):integer; var VAR_LRC:integer; I : integer; begin VAR_LRC:=BLOC[0]; for I:=1 to (NBOCT-1) do VAR_LRC:=VAR_LRC xor BLOC[I]; LRC:=VAR_LRC; end; (*****************************) (* CONVERSION A LA MODE BULL *) (*****************************) procedure PREP_EBUFFER; var I,J : integer; begin if NACKE then EDATA[0]:=NACK else EDATA[0]:=ACK; EDATA[EDATA[1]+2]:=LRC(EDATA,2+EDATA[1]); { writeln('emission'); } for I:=0 to EDATA[1]+2 do begin { write(EDATA[I]:2,' '); } J:=2*I; XBUFFER[J] := (EDATA[I] div 16)+48; XBUFFER[J+1] := (EDATA[I] mod 16)+48; end; XBUFFER[2*(EDATA[1]+2)+2] := ETX; NACKE := false; end; (********************) (* EMISSION -> TLP *) (********************) procedure EMISSION; begin SEND(UART,2*(EDATA[1]+2)+3,XBUFFER,STAT); end; (***********************) (* RECEPTION <-- TLP *) (***********************) procedure RECEPTION; var LG : integer; begin CLEAR_BUF(UART); LG := sizeof(XBUFFER); RECEIVE(UART,LG,ETX,TMAX,XBUFFER,STAT); if STAT=0 then NR := (LG-1) div 2; (* nombre d'octets recus sans le ETX *) end; (************************************) (* TEST LA VALIDITE DE LA RECEPTION *) (************************************) procedure TEST_REC; var I,J : integer; TEMP : integer; C1,C2 : char; begin for I:=0 to (NR-1) do begin (* formatage du buffer réception *) J:=I*2; C1 := chr(XBUFFER[J]); C2 := chr(XBUFFER[J+1]); TEMP := (ord(C1)-48)*16+ord(C2)-48; if (TEMP<0) or (TEMP>255) then STAT := -1 else XDATA[I] := TEMP; end; { writeln('reception'); for I:= 0 to NR-1 do write(XDATA[I]:2,' '); } NACKR := XDATA[0] = NACK; (* Si le TLP a mal recu, il le signale*) NACKE := XDATA[NR-1] <> LRC(XDATA,NR-1); (* si le LRC est faux, erreur *) if NACKE or NACKR then STAT := -1; (* STAT résume le tout *) end; begin (* EMIREC *) VALIDATION_IT(UART,true); for I:=1 to XDATA[1]+1 do EDATA[I] := XDATA[I]; (* sauvegarde... *) REPET := 0; (* nb de repetitions *) NACKE := false; (* pas d'erreur en émission DE LA PART DU TLP *) NACKR := false; (* pas d'erreur en réception DE LA PART DU TLP *) repeat STAT := 0; (* a priori, pas d'erreur d'E/S *) NR := 0; (* Nb octets recus = 0 *) PREP_EBUFFER; (* formatage du buffer émission *) EMISSION; (* émission dudit buffer *) if STAT = 0 then begin (* si émission ok, attente réception TLP *) RECEPTION; (* réception à proprement parlé *) { writeln; write('Reception STAT=',STAT:2); writeln(' Nb octets : ',NR:2); for I:=0 to NR-1 do begin J := 2*I; write(chr(XBUFFER[J]),chr(XBUFFER[J+1]),'-'); end; if NR<>0 then write(chr(XBUFFER[J+2])); readln; } if (STAT = 0) then TEST_REC; (* si réception Ok, test LRC..., formatage *) end; (* du buffer de réception *) REPET := REPET+1; (* compteur de répétition+1 *) (* on sort de la boucle si pas d'erreur d'E/S (STAT=0) *) (* ou si le nb max de répétition est dépassé *) until (STAT = 0) or (REPET >= REPETMAX); if REPET >= REPETMAX then STAT := -1; VALIDATION_IT(UART,false); end; (* decodage trame standard : XDATA *) procedure T1_ENTREE_SORTIE(CC: integer; var XDATA:PDU; var STAT:integer); var YDATA : PDU; I : integer; begin for I:=0 to 255 do YDATA[I]:=XDATA[I]; with CONTEXT[CC]^ do begin case XDATA[1] of OMHT : begin XDATA[1]:=10; XDATA[2]:=$06; XDATA[3]:=ADRLEC; XDATA[4]:=$00; XDATA[5]:=$0C; XDATA[6]:=$4D; XDATA[7]:=$01; XDATA[8]:=$03; XDATA[9]:=$FF; XDATA[10]:=$FF; XDATA[11]:=$02; T1_EMIREC(XDATA,ADRUART,TCOURT,STAT); if (STAT = 0) then begin YDATA[3] := XDATA[12]; YDATA[4] := XDATA[13]; YDATA[5] := 0; T1_INTSTATUS(CONTEXT[CC],YDATA[3],YDATA[4],XDATA[6],STAT); end; end; OMST : begin (* mise sous tension de la carte *) XDATA[1] :=10; (* initialisation *) XDATA[2] :=$06; XDATA[3] :=ADRLEC; XDATA[4] :=$00; XDATA[5] :=$15; XDATA[6] :=$6E; XDATA[7] :=$01; XDATA[8] :=$03; XDATA[9] :=$00; XDATA[10]:=$00; (* type de carte *) XDATA[11]:=$00; T1_EMIREC(XDATA,ADRUART,TCOURT,STAT); (* execution *) if (STAT = 0) then begin (* si carte AFNOR, alors carte asynchrone *) if XDATA[1]=$15 then begin if XDATA[10] in [0,1,2] then YDATA[5]:=ASYNCH else if XDATA[10]=3 then begin YDATA[5] :=SYNCH; XDATA[11]:=2; (* longueur pour forcer ME1 et ME2 *) XDATA[12]:=$90; (* ME1 ok *) XDATA[13]:=$00; (* ME2 *) end; if (STAT=0) then begin (* pas de pb et donnees contenant au moins *) if ((XDATA[1]=21) and (XDATA[11] in [2..11])) then begin (* ME1 et ME2 *) YDATA[6]:= XDATA[11]-2; (* recuperation longueur donnees - ME1&ME2 *) YDATA[3]:= XDATA[10+XDATA[11]]; (* ME1 avant dernier octet des données *) YDATA[4]:= XDATA[11+XDATA[11]]; (* ME2 dernier octet des données *) for I:=0 to YDATA[6]-1 do YDATA[7+I]:=XDATA[12+I]; (* donnees recupérées *) (* WARNING VOIR LA DOC SUR LES COUPLEURS TLP : *) (* ILS RAJOUTTENT UN TA1 ET TD1 DANS LES DONNEES SYSTEMES *) (* Cf DOC CARTE M4, PAGE 51 *) (* IL FAUT DONC MODIFIER T0 (TD0) EN CONSEQUENCE *) (* IL FAUT EGALEMENT COMPLEMENTER TS *) YDATA[7] := not YDATA[7]; (* TS *) YDATA[8] := YDATA[8] or $90; (* T0 *) end; end; T1_INTSTATUS(CONTEXT[CC],YDATA[3],YDATA[4],XDATA[6],STAT); end else STAT := -1; end; end; OS : begin T1_P_XDATAsortant(ADRLEC,APPLIC,XDATA[3],XDATA[4],XDATA[5]); XDATA[14] := YDATA[2]; T1_EMIREC(XDATA,ADRUART,TCOURT,STAT); if (STAT = 0) then begin YDATA[3] := XDATA[18+YDATA[5]]; (* ME1 *) YDATA[4] := XDATA[18+YDATA[5]+1]; (* ME2 *) YDATA[5] := XDATA[17]; (* taille recue *) (* bug coorigé le 9/10/89 *) if YDATA[5]>0 then for I:=0 TO YDATA[5]-1 do YDATA[6+I]:=XDATA[18+I]; T1_INTSTATUS(CONTEXT[CC],YDATA[3],YDATA[4],XDATA[6],STAT); end; end; OE : begin T1_P_XDATAentrant(ADRLEC,APPLIC,XDATA[3],XDATA[4],XDATA[5]); XDATA[14] := YDATA[2]; if YDATA[5]>0 then for I:=0 TO YDATA[5]-1 do XDATA[I+18]:=YDATA[6+I]; T1_EMIREC(XDATA,ADRUART,TCOURT,STAT); if (STAT = 0) then begin YDATA[3] := XDATA[18+YDATA[5]]; (* ME1 *) YDATA[4] := XDATA[18+YDATA[5]+1]; (* ME2 *) YDATA[5] := 0; (* pas de donnee en entrant *) T1_INTSTATUS(CONTEXT[CC],YDATA[3],YDATA[4],XDATA[6],STAT); end; end; end; (* case *) for I:=0 to 255 do XDATA[I]:=YDATA[I]; end; end; (* T1_ENTREE_SORTIE *) (************************************************************) (* *) (* Nom Procedure: T1_PAFF *) (* *) (* Param entree : CC, contexte *) (* EFF effacement avant affichage *) (* POSITION position écran *) (* NBCAR nb de car a afficher *) (* MESS caracteres a afficher *) (* *) (* Param sortie : STAT status ou nb car affiches *) (* *) (* Globales : rang[pctx->ADRUART] *) (* ecran[pctx->ADRUART][] *) (* *) (* Description : affiche sur l ecran du pin-pad. *) (* *) (************************************************************) procedure T1_PAFF (CC : integer; EFF : boolean; POSITION : integer; NBCAR : integer; var MESS : string; var NB_AFF : integer; (* nombre de caractères affichés *) var STAT : integer); begin (* of T1_PAFF () *) NB_AFF := 0; PINPAD_INIT (CC, 0, chr(0), STAT); if (STAT <> 0) then PINPAD_INIT (CC, 0, chr(0), STAT); if (EFF) then EFFACE (CC, STAT); if (STAT = 0) then AFFICHE (CC, POSITION, MESS, NBCAR, STAT); case STAT of 0 : NB_AFF := NBCAR; 1..9 : STAT := KERR_LECT; (* erreur bus ISAM *) $72 : STAT := KERR_DEB_AFF; (* débordement de l'afficheur *) $7F : STAT := KERR_TEMPO; (* tempo échue *) else begin if STAT = NBCAR then STAT := 0 else STAT := KERR_PINPAD; (* autre *) end; end; end; (* of T1_PAFF () *) (************************************************************) (* *) (* Nom Fonction : T1_PCLA *) (* *) (* Param entree : CC, contexte *) (* EFF VRAi si effacement. *) (* ECHO saisie avec echo *) (* CAR_ECHO caractere d'echo *) (* NB_ARR nb de caracteres d'arret *) (* ARRET liste de car d'arret *) (* NB_A_SAISIR max de car a saisir *) (* TEMPO time-out entre 2 frappes *) (* *) (* Param sortie : STAT status ou nb car saisis *) (* BUFFER caracteres saisis *) (* *) (* Globales : *) (* *) (* *) (* Description : saisie de caractere sur le pin-pad. *) (* *) (************************************************************) procedure T1_PCLA (CC : integer; EFF : boolean; POSITION : integer; ECHO : boolean; CAR_ECHO : char; NB_ARRET : integer; var ARRET : string; NB_A_SAISIR : integer; TEMPO : integer; var BUFFER : string; var NB_SAISIS : integer; var STAT : integer); const KTEMPO_DFL = 0; var AR_10, AR_1B, AR_1C : boolean; CAR_ARR : char; (* caractère d'arrˆt provocant fin saisie *) ORDRE,ADRESSE,I : integer; ESPACES : string; begin (* of T1_PCLA() *) NB_SAISIS := 0; for I := 1 to 8 do ESPACES [I] := ' '; ADRESSE := CONTEXT[CC]^.ADRUART; PINPAD_INIT (CC, TEMPO, CAR_ECHO, STAT); if (STAT <> 0) then PINPAD_INIT (CC, TEMPO, CAR_ECHO, STAT); if (STAT = 0) then begin ARRETER (NB_ARRET, ARRET, AR_10, AR_1B, AR_1C); ORDRE := $E2; if (ECHO) then ORDRE := ORDRE or $04; if (CAR_ECHO <> chr(0)) then ORDRE := ORDRE or $08; if (TEMPO >= 0) then ORDRE := ORDRE or $10; if (STAT = 0) then begin CLAVIER (CC, ORDRE, POSITION, NB_A_SAISIR, BUFFER, NB_SAISIS, CAR_ARR, TEMPO, ECHO, AR_10, AR_1B, AR_1C, STAT); end; end; end; (* of T1_PCLA() *) (************************************************************) (* *) (* Nom procedure: T1_PLED *) (* *) (* Param entree : CC, contexte *) (* CODE_ACT VRAI si allumer led(s) *) (* VERTE, VRAI si activer led VERTE *) (* ROUGE, VRAI si activer led ROUGE *) (* *) (* Param sortie : STAT status ou nb leds actionnees*) (* *) (* Globales : *) (* *) (* Description : switch les voyants du pin-pad. *) (* *) (************************************************************) procedure T1_PLED (CC : integer; CODE_ACT : boolean; VERTE : boolean; ROUGE : boolean; var STAT : integer); const KLED_ROUGE = $80; (* code Led Rouge *) KLED_VERTE = $40; (* code Led Verte *) KACT_ALLUM = $81; (* allumer une ou plusieurs Leds *) KACT_ETEIN = $91; (* éteindre une ou plusieurs Leds *) begin (* of T1_PLED() *) case CONTEXT[CC]^.TLECT of TLP124,TLU502 : begin PINPAD_INIT (CC, 0, chr(0), STAT); if (STAT <> 0 ) then PINPAD_INIT (CC, 0, chr(0), STAT); if (STAT = 0) then begin XDATA [1] := 11; XDATA [2] := $06; XDATA [3] := $71; (* @ physique du pin-pad sur le bus ISAM *) XDATA [4] := 0; XDATA [5] := 5; if CODE_ACT then XDATA [6] := KACT_ALLUM and $FF else XDATA [6] := KACT_ETEIN and $FF; XDATA [7] := 1; XDATA [8] := 3; XDATA [9] := $FF; XDATA [10] := $FF; XDATA [11] := $FF; XDATA[12] := 0; if VERTE then XDATA [12] := XDATA[12] xor (KLED_VERTE and $FF); if ROUGE then XDATA [12] := XDATA[12] xor (KLED_ROUGE and $FF); T1_EMIREC (XDATA, CONTEXT[CC]^.ADRUART, TCOURT, STAT); if (STAT = 0) then STAT := XDATA[6]; (* status lecteur rendu *) end; end; else STAT := -1; end; end; (* of T1_PLED() *) (************************************************************) (* *) (* Nom procedure : PINPAD_INIT *) (* *) (* Param entree : CC, contexte-carte courant. *) (* TEMPO, temporisation. *) (* CAR_ECHO, caractère d'écho. *) (* *) (* Param sortie : STAT *) (* *) (* Globales : *) (* *) (* Description : *) (* *) (************************************************************) procedure PINPAD_INIT { (CC : integer; TEMPO : integer; CAR_ECHO : char; var STAT : integer) }; var CURSEUR : char; begin (* of PINPAD_INIT () *) CURSEUR := '?'; XDATA[1] := 14; XDATA[2] := $06; XDATA[3] := $71; (* @ physique du pin-pad sur le bus ISAM *) XDATA[4] := $00; XDATA[5] := 5; XDATA[6] := $80; (* Initialisation *) XDATA[7] := $04; XDATA[8] := $03; XDATA[9] := $FF; XDATA[10] := $FF; XDATA[11] := $FF; XDATA[12] := $83; if (TEMPO > 0) then XDATA[13] := TEMPO else XDATA[13] := $FF; XDATA[14] := ord(CURSEUR); (* 20;*) XDATA[15] := ASC_TLP (car_echo); T1_EMIREC (XDATA, CONTEXT[CC]^.ADRUART, TCOURT, STAT); if (STAT = 0) then STAT := XDATA[6]; (* status lecteur rendu *) end; (* of PINPAD_INIT () *) (************************************************************) (* *) (* Nom procedure : AFFICHE *) (* *) (* Param entree : CC, contexte-carte courant. *) (* POSITION , coordonnée début affichage *) (* MESS, message à afficher. *) (* NBCAR nb caractères valides. *) (* *) (* Param sortie : STAT *) (* *) (* Globales : *) (* *) (* Description : *) (* *) (************************************************************) procedure AFFICHE { (CC : integer; POSITION : integer; var MESS : string; NBCAR : integer; var STAT : integer) }; var I : integer; begin (* of AFFICHE () *) XDATA [1] := 18; XDATA [2] := $06; XDATA [3] := $71; (* @ physique du pin-pad sur le bus ISAM *) XDATA [4] := $00; XDATA [5] := 5; XDATA [6] := $A4; (* Affichage sur 1 champ *) XDATA [7] := NBCAR and $FF; (* Nombre d'octets du bloc de données *) XDATA [8] := $03; XDATA [9] := 8 - POSITION; (* rang du digit origine de l'affichage *) XDATA [10] := $FF; (* non significatif *) XDATA [11] := NBCAR and $FF; (* nombre de caractères à afficher *) for I := 1 to NBCAR do XDATA [11 + I] := ASC_TLP(MESS[I]); T1_EMIREC (XDATA, CONTEXT[CC]^.ADRUART, TCOURT, STAT); if (STAT = 0) then STAT := XDATA [6]; (* status lecteur rendu *) end; (* of AFFICHE () *) (************************************************************) (* *) (* Nom procedure : EFFACE *) (* *) (* Param entree : CC, contexte-carte courant. *) (* *) (* Param sortie : STAT *) (* *) (* Globales : *) (* *) (* Description : *) (* *) (************************************************************) procedure EFFACE { (CC : integer; var STAT : integer) }; begin (* of EFFACE () *) XDATA [1] := 10; XDATA [2] := $06; XDATA [3] := $71; (* @ physique du pin-pad sur le bus ISAM *) XDATA [4] := 0; XDATA [5] := 5; XDATA [6] := $A4; (* Affichage sur 1 champ *) XDATA [7] := 1; XDATA [8] := $03; XDATA [9] := 7; (* position courante du curseur *) XDATA [10] := $FF; XDATA [11] := 00; T1_EMIREC (XDATA, CONTEXT[CC]^.ADRUART, TCOURT, STAT); if STAT = 0 then STAT := XDATA [6]; (* status lecteur rendu *) end; (* of EFFACE () *) (************************************************************) (* *) (* Nom procedure : CLAVIER *) (* *) (* Param entree : CC, contexte-carte courant. *) (* ORDRE, *) (* NB, *) (* BUFFER, *) (* ARRET, *) (* TEMPO, temporisation globale saisie *) (* ECHO, *) (* AR_10, *) (* AR_1B, *) (* AR_1C, *) (* *) (* Param sortie : STAT *) (* *) (* Globales : *) (* *) (* Description : *) (* *) (************************************************************) procedure CLAVIER { (CC : integer; (* contexte carte *) ORDRE : byte; (* ordre de saisie clavier *) POSITION : integer; (* coordonnée début de saisie *) NB_A_SAISIR: integer; (* nombre de caractères à saisir *) var BUFFER : string; (* tableau des caractères saisis *) var NB_SAISIS : integer; (* nombre de caractères saisis *) var CAR_ARR : char; (* caractère d'arrˆt *) TEMPO : integer; (* tempo inter-caractères *) ECHO : boolean; (* VRAI si écho *) AR_10 : boolean; AR_1B : boolean; AR_1C : boolean; var STAT : integer) }; (* Mise en commentaire pour cause de forward *) var I, J, ADRESSE, X : integer; FIN : boolean; begin (* of CLAVIER () *) ADRESSE := CONTEXT[CC]^.ADRUART; (* XADTA[12] contient les conditions de fin d'écoute *) if (AR_10 and AR_1B and AR_1C) then begin X := 1; XDATA [12] := $FF; (* sortie sur appui d'une touche de fonction *) end else begin if (AR_10 or AR_1B or AR_1C) then begin X := 0; if (not AR_10) then begin XDATA [12] := $10; X := X + 1; end; if (not AR_1B) then begin XDATA [12] := $1B; X := X + 1; end; if (not AR_1C) then begin XDATA [12] := $1C; X := X + 1; end; end else begin X := 1; XDATA [12] := 0; (* sortie sur max de caractères saisis *) end; end; XDATA [1] := 10 + X; XDATA [2] := $06; XDATA [3] := $71; (* @ physique du pin-pad sur le bus ISAM *) XDATA [4] := 0; XDATA [5] := 10 + 2 + (NB_A_SAISIR and $FF); XDATA [6] := ORDRE; (* Affichage sur 1 champ *) XDATA [7] := $02; XDATA [8] := $03; XDATA [9] := 8 - POSITION; XDATA [10] := 0; XDATA [11] := NB_A_SAISIR; (* XADAT[12] octet des conditions de sortie *) (* XDATA[13] octet des contions de sortie suite *) T1_EMIREC (XDATA, CONTEXT[CC]^.ADRUART, TEMPO+5, STAT); (* XDATA[6], octet STAT des E/S *) (* XDATA[11], nombre de caractères saisis si STAT = 0 *) (* XDATA[14]..XDATA[I], données saisies *) NB_SAISIS := 0; BUFFER := ''; case STAT of $00, $7F : begin if STAT = $7F then STAT := 44; (* time-out *) NB_SAISIS := XDATA [11]; (* nb de car saisis *) for I := 1 to NB_SAISIS do BUFFER [I] := chr (XDATA [13 + I] + $30); I := 1; FIN := false; while (I <= NB_SAISIS) and (not FIN) do begin if ord(BUFFER[I]) > $39 then begin FIN := true; if ord(BUFFER[I]) - $30 = $10 then CAR_ARR := '?' else if ord(BUFFER[I]) - $30 = $1B then CAR_ARR := '*' else if ord(BUFFER[I]) - $30 = $1C then CAR_ARR := '#' else CAR_ARR := chr(0); end else I := I + 1; end; if FIN then begin NB_SAISIS := I; BUFFER[I] := CAR_ARR; end; BUFFER[0] := chr(NB_SAISIS); end; else STAT := -1; end; end; (* of CLAVIER () *) (************************************************************) (* *) (* Nom procedure : ARRETER *) (* *) (* Param entree : CC, contexte-carte courant. *) (* ORDRE, *) (* N, *) (* *) (* Param sortie : STAT *) (* *) (* Globales : *) (* *) (* Description : *) (* *) (************************************************************) procedure ARRETER { (N_AR : integer; var ARRET : string; var AR_10 : boolean; var AR_1B : boolean; var AR_1C : boolean) }; var I : integer; BOOL_10 : boolean; BOOL_1B : boolean; BOOL_1C : boolean; begin (* of ARRETER () *) AR_10 := FAUX; AR_1B := FAUX; AR_1C := FAUX; for I := 1 to N_AR do begin if (ARRET[I] = '?') then BOOL_10 := true else BOOL_10 := false; if (ARRET[I] = '*') then BOOL_1B := true else BOOL_1B := false; if (ARRET[I] = '#') then BOOL_1C := true else BOOL_1C := false; AR_10 := AR_10 or BOOL_10; AR_1B := AR_1B or BOOL_1B; AR_1C := AR_1C or BOOL_1C; end; end; (* of ARRETER () *) (************************************************************) (* *) (* Nom procedure : ASC_TLP *) (* *) (* Param entree : C, un caractère à convertir *) (* ORDRE, *) (* N, *) (* *) (* Param sortie : *) (* *) (* Globales : *) (* *) (* Description : *) (* *) (************************************************************) function ASC_TLP { (CAR : char) : integer }; var VAL, RES : integer; begin (* of ASC_TLP () *) VAL := ord(CAR); if ((VAL >= $20) and (VAL <= $5F)) then RES := VAL else if ((VAL >= ord('a')) and (VAL <= ord('z'))) then RES := (VAL - ord ('a') + ord('A')) else RES := ord (' '); ASC_TLP := RES; end; (* of ASC_TLP () *) (************************************************************) (* *) (* Nom procedure : TLP_ASC *) (* *) (* Param entree : C, un caractère à convertir *) (* ORDRE, *) (* N, *) (* *) (* Param sortie : *) (* *) (* Globales : *) (* *) (* Description : *) (* *) (************************************************************) function TLP_ASC { (T : integer) : char }; var CAR : char; begin (* of TLP_ASC() *) if (T <= 9) then CAR := chr (ord('0') + T) else if (T = $0B) then CAR := '.' else if (T = $10) then CAR := '?' else if (T = $1B) then CAR := '*' else if (T = $1C) then CAR := '#' else CAR := chr(0); TLP_ASC := CAR; end; (* of TLP_ASC () *) end. (************************ Fin de TLP124.pas ********************************)