LEX    'RWLEX'
* (c) Copyright PPC Paris et l'Auteur 1987
       CON(2) #E1
       CON(2) 94
       CON(2) 95
       CON(5) 0
       NIBHEX F
       REL(4) 1+(TXTBST)
       CON(4) 0
       CON(5) 0
**************************************************
* RREC$(<num.enr.>,<spec. appareil>)
**************************************************
       CON(3) (TXT001)-(TXTBST)   RREC$
       REL(5) RREC
       CON(1) 15
**************************************************
* WREC <chaÑne>,<num.enr.>,<spec. appareil>
**************************************************
       CON(3) (TXT002)-(TXTBST)   WREC
       REL(5) WREC
       CON(1) 13
TXTBST
TXT001 CON(1) 9
       NIBASC 'RREC$'
       CON(2) 94        token 94
TXT002 CON(1) 7
       NIBASC 'WREC'    token 95
       CON(2) 95
TXTBEN NIBHEX 1FF
ADDRCK EQU    #1C5A5
ARGERR EQU    #0BF19
ATNFLG EQU    #2F442
Attn   EQU    12
BSERR  EQU    #0939A
CHKMAS EQU    #425C
COLLAP EQU    #091FB
COMCK+ EQU    #032AE
CONVUC EQU    #152AA
CSRW5  EQU    #0ED2C
D=AVMS EQU    #1A460
DEVPAR EQU    #1BF0
DRANGE EQU    #1B076
DVCSPp EQU    #7925
EXPEX- EQU    #0F178
EXPEXC EQU    #0F186
EXPPAR EQU    #03FD9
EXPR   EQU    #0F23C
EXPRDC EQU    #05922
FIXDC  EQU    #05493
GETERR EQU    #6791
GETMBX EQU    #3B62
GETPIL EQU    #6E0B
GNXTCR EQU    #03064
HEXASC EQU    #17148
I/OFND EQU    #118BA
ID     EQU    #E1
IVEXPe EQU    #02E35
LEXPIL EQU    #FF
MEMERR EQU    #0944D
MINTK  EQU    94
MTHSTK EQU    #2F599
NXTSTM EQU    #08A48
OUTBY+ EQU    #02CE5
PACKd  EQU    #7B4A
POP1S  EQU    #0BD38
R3=D10 EQU    #03526
R<RSTK EQU    #014DD
RANGE  EQU    #1B07C
READR# EQU    #44FF
REV$   EQU    #1B38E
REVPOP EQU    #0BD31
RNDAHX EQU    #136CB
RSTK<R EQU    #014A8
SNAPBF EQU    #2F7F0
STRGCK EQU    #036BA
STRNGP EQU    #0379D
SYNTXe EQU    #02E2B
WRITE# EQU    #453F
bLEX   EQU    #BFC
eABORT EQU    4
eNODEF EQU    3
ePIL   EQU    2
eTAPE  EQU    1
eXWORD EQU    #23
reclen EQU    512
sSTK   EQU    7
**************************************************
* W R E C
**************************************************
* Routine d'analyse (parse) de l'ordre WREC
WRECp  GOSBVL STRGCK   1er paramÉtre : alpha
       GOSBVL COMCK+
       GONC   syntxe
       GOSBVL GNXTCR
       GOSBVL R3=D10
       GOSBVL EXPPAR   2Éme paramÉtre: alpha
        *              ou numÅrique.
       ?ST=1  0
       GOYES  ivexpe
       GOSBVL COMCK+
       GONC   syntxe
       GOSUB  JUMPER
       CON(5) DVCSPp   3Éme paramÉtre: spÅcifi-
        *              cateur d'appareil HPIL.
       RTNCC
ivexpe ST=1   4
       GOVLNG IVEXPe
syntxe GOVLNG SYNTXe

* Routine de dÅcompilation de l'ordre WREC
WRECd  GOSBVL EXPRDC   1er paramÉtre
       LCASC  ','
       GOSBVL OUTBY+
       GOSBVL EXPRDC   2Éme paramÉtre
       LCASC  ','
       GOSBVL OUTBY+
       GOSUB  JUMPER
       CON(5) PACKd    3Éme paramÉtre: HPIL
       RTN

ERReur GOTO   erreur

       REL(5) WRECd
       REL(5) WRECp
WREC   GOSBVL EXPEX-   ) DÅpose les 2 premiers
       D0=D0+ 2        ) paramÉtres
       GOSBVL EXPEXC   ) de l'ordre
       D0=D0+ 2        ) WREC sur la M.S.
       CD1EX
       RSTK=C          RSTK = Math Stack
       ST=0   sSTK
       GOSUB  JUMPER
       CON(5) GETPIL   Cette routine permet
        *              d'Åvaluer le spÅcificateur
        *              d'appareil.
       GOC    ERReur
       C=RSTK
       D1=C            D1 = Math Stack
       GOSUB  JUMPER
       CON(5) GETMBX   Routine de recherche de
        *              l'adresse de la MAILBOX de
        *              la boucle dÅcrite dans le
        *              spÅcificateur d'appareil.
        *              Au retour: D0 ^ M.B.
       GOSUB  VERT10   VÅrification de la prÅsence
        *              de la mÅmoire de masse sur
        *              la boucle.
       A=R0            ) Mise en place de D1 sur
       D1=A            ) le deuxiÉme paramÉtre de
        *              ) l'ordre WREC
       C=D    A        Sauvegarde de l'adresse de
       RSTK=C          la mÅmoire de masse dans
        *              la pile de retour
       A=DAT1 B        ) l'adresse d'Åcriture est-
        *              ) elle en HEXA ?
       LC(2)  15       )
       ?A#C   B        )
       GOYES  rndahx   Non => RNDAHX
       GOSBVL ADDRCK   VÅrification de la validitÅ
        *              de l'adresse (2e param.)
       C=B    A
       GOC    EXEC00
rndahx GOSBVL RNDAHX
       GONC   ivarg
       D1=D1+ 16
       C=A    A
EXEC00 RSTK=C          ) adresse dans la pile de
        *              ) retour
       GOSBVL REVPOP   Renversement de la chaÑne
        *              sur la Mathstack.
       C=0    A        ) La longueur de la chaÑne
       LC(3)  reclen   ) est-elle de 256 octets ?
       ?A#C   A
       GOYES  ivarg    Si non => ERREUR
       C=RSTK          ) Restitution de l'adresse
       A=C    A        ) de l'enregist. dans A(A)
       C=RSTK          ) Mise en place de
        *              ) l'adresse de la mÅmoire
       D=C    A        ) de masse dans D(X).
        *
       GOSUB  JUMPER       *******************
       CON(5) WRITE#       * E C R I T U R E *
        *                  *******************
       GOC    erreur   Au retour de la
        *              routine, si Cy=1,
        *              nous sommes en prÅsence
        *              d'une erreur.
       GOSBVL COLLAP   Remise en place de MTHSTK
       GOVLNG NXTSTM   BASIC continu
ivarg  GOVLNG ARGERR

**************************************************
* La routine VERTAP verifie si le paramÉtre
* pointÅ par D1 correspond bien È une mÅmoire
* de masse d'identificateur appareil 16.
**************************************************
Dvnfnd P=     ePIL     Classe d'erreur 32 È 47
       C=0    A        Erreur 32.
       GOC    erreur   B.E.T.
VERTAP GOSUB  JUMPER
       CON(5) DEVPAR   Routine d'analyse du
        *              spÅcificateur d' appareil
        *              de la fonction. En sortie
        *              D1 ^ Math Stack - 16 pour
        *              un paramÉtre numÅrique.
       GOC    erreur   Si carry: ERREUR
VERT10 ?D=0   X        D[X] contient l'adresse du
        *              pÅriphÅrique. Si D[X] = 0,
       GOYES  Dvnfnd   le pÅriphÅrique n'est pas
        *              prÅsent. On renvoie
        *              "Device Not Found"
       CD1EX           ) Sauvegarde de D1 dans R0
        *              ) pour le retour
       R0=C            ) È BASIC (fin).
       GOSUB  JUMPER   VÅrification de l'AID du
       CON(5) CHKMAS   pÅriphÅrique (16).
       RTNNC           Cy=0 : OK, Cy=1 : ERREUR
**************************************************
* Traitement des erreurs HPIL. P indique la
* classe d'erreur (mÅmoire de masse... etc.) et
* C[0] le numÅro de l'erreur. Le retour È la
* main loop se fait via BSERR.
**************************************************
erreur ?P=    eTAPE
       GOYES  ERROR1
       ?P=    ePIL
       GOYES  ERROR1
       ?P#    eABORT
       GOYES  ERROR0
       GOSUB  JUMPER
       CON(5) GETMBX
       GOSUB  atnchk
       GOC    ERROR0
       GOSUB  JUMPER
       CON(5) GETERR
       GONC   ERROR-
       ?P#    eABORT
       GOYES  ERROR1
ERROR- P=     eABORT
ERROR0 C=P    0
       P=     eNODEF
ERROR1 C=P    1
       P=     2
       LCHEX  FF
       A=C    A
       P=     0
bserr  GOVLNG BSERR    Envoyez l'erreur !
Erreur GOC    erreur   Ralonge
**************************************************
* R R E C $
**************************************************
       NIBHEX CC22     Alpha ou un numÅrique pour
        *              les deux paramÉtres.
RREC   CD0EX           ) Sauvegarde de D0 dans
       RSTK=C          ) la pile de retour
       GOSUB  r<rstk   Sauvegarde de 5 niveaux
       GOSUB  VERTAP   VÅrification mÅm. de masse
       A=R0            R0 = MS-16
       D1=A
       D1=D1+ 16       D1 = M.S.
       C=D    A        ) D[X] = device address
       RSTK=C          ) RSTK = D[X]
       A=DAT1 B        L'adresse est-elle
       LC(2)  15       donnÅe sous forme de
       ?A#C   B        chaÑne ?
       GOYES  rndah2   Non => RNDAHX
       GOSBVL ADDRCK   VÅrification validitÅ
       GOC    EXEC10
rndah2 GOSBVL RNDAHX
       GONC   Ivarg
       D1=D1+ 16
       B=A    A
EXEC10 AD1EX
       C=0    A
       LC(3)  (reclen)+16  ( 210H = 528D
        *                 (Soit la longueur de
        *                ( l'enregistrement plus
        *               ( 16 quartets d'en-tÁte)
       A=A-C  A        A[A] = MS-528
       GOSBVL D=AVMS
       C=A    A        C[A] = AVMEMS
       ?C<D   A        Y a-t-il assez de mem. ?
       GOYES  memerr   Non: Erreur
       R1=C            Sauvegarde de MS-528
       D1=C            D1 = Math Stack - 512
       D1=D1+ 16
       A=B    A        A[A] = # enreg. È lire
       C=RSTK          ) Restitution de
       D=C    A        ) dev. add. dans D[X]
        *
       GOSUB  JUMPER      *****************
       CON(5) READR#      * L E C T U R E *
        *                 *****************
       GOC    Erreur
       A=R1            A[A] = MS-528
       D1=A
       C=0    W        ) construction e l'en-tÁte
        *              ) de la chaÑne avant le
        *              ) retour È BASIC
       LCHEX  2000F    ) C(W)= 000000000002000F
       DAT1=C W        O.K.
       AD1EX
       R1=A
       P=     4        ) Restitution de 5 niveaux
       GOSBVL RSTK<R   ) de pile
       C=RSTK          ) puis de
       D0=C            ) D0  (4 niveaux & PC)
       C=R1            Restitution pointeur
       D1=C            D1 = MS+528
       GOSBVL REV$     On retourne l'ordre des
        *              caractÉres sur la M.Stack.
       GOVLNG EXPR     Retour È BASIC.
Ivarg  GOTO   ivarg
memerr GOVLNG MEMERR
**************************************************
* ROUTINE R<RSTK
* Cette routine sauvegarde 5 niveaux de pile
**************************************************
r<rstk P=     4
       GOVLNG R<RSTK   I N D I S P E N S A B L E !
        *              Pour l'exÅcution d'une
        *              fonction faisant appel È
        *              des routines HPIL.
**************************************************
* ROUTINE ATNCHK
* Cette routine a ÅtÅ pompÅe dans les IDS V, elle
* n'est pas supportÅe. Elle permet la sortie
* de l'erreur Aborted lorsque l'on arrÁte l'exÅcu-
* tion des routines HPIL en appuyant deux fois sur
* la touche ATTN.
**************************************************
atnchk ?ST=0  Attn
       GOYES  ATNCHc
       RSTK=C
       CD0EX
       D0=(5) ATNFLG
       C=DAT0 S
       D0=C
       C=RSTK
       ?C=0   S
       GOYES  ATNCHc
       C=C+1  S
       GOC    ATNCHc
       P=     eABORT
       RTNSC
ATNCHc RTNCC
**************************************************
* Routine Jumper:
* Cette routine permet l'accÉs aux diffÅrents
* points d'entrÅes du module HPIL
**************************************************
JUMPER RSTK=C
       CD1EX
       D1=(5) SNAPBF
       DAT1=C A
       D1=(2) (SNAPBF)+5
       C=RSTK
       DAT1=C W
       D1=(4) (SNAPBF)+21
       DAT1=A W
       D1=(2) (SNAPBF)+37
       C=B    A
       CPEX   5
       P=     6
       C=0    P
       GONC   JUMP05
       C=C-1  P
JUMP05 P=     7
       C=0    P
       C=C-1  P
       DAT1=C 8
       SETHEX
       P=     0
       LC(3)  bLEX
       GOSBVL I/OFND
       GONC   JUMP90
       LC(2)  LEXPIL
       B=C    A
       A=0    A
       A=A+1  A
JUMP10 C=DAT1 6
       ?C=0   B
       GOYES  JUMP90
       ?B#C   B
       GOYES  JUMP20
       CSR    W
       CSR    A
       ?A<C   B
       GOYES  JUMP20
       CSR    A
       CSR    A
       C=C-A  B
       GONC   JUMP30
JUMP20 D1=D1+ 11
       GONC   JUMP10
JUMP90 LC(4)  eXWORD
       GOTO   bserr
JUMP30 D1=D1+ 6
       C=DAT1 A
       B=C    A
       C=RSTK
       D1=C
       D1=D1+ 5
       CD1EX
       RSTK=C
       C=DAT1 A
       C=C+B  A
       RSTK=C
       D1=(5) (SNAPBF)+21
       A=DAT1 W
       D1=D1+ 16
       C=DAT1 8
       B=C    A
       P=     7
       C=C+1  P
       GOC    JUMP50
       SETDEC
JUMP50 P=     6
       ?C#0   P
       GOYES  JUMP60
JUMP60 P=C    5
       D1=(4) (SNAPBF)+5
       C=DAT1 W
       D1=(2) SNAPBF
       RSTK=C
       C=DAT1 A
       D1=C
       C=RSTK
       RTN
       END