LEX    'KBDLEX'
* (c) Copyright PPC Paris 1986
        ID     #E1
        MSG    0
        POLL   POLHND   Partie "test de la touche"
        ENTRY  KBDe
        CHAR   #D       Ordre 
        KEY    'KBD'    KBD <expression numerique>
        TOKEN  51
        ENDTXT

EXPEX-  EQU    #0F178   Evaluation de l'expression
         *              pointÅe par D0
RNDAHX  EQU    #136CB   Rappel de l'argument au
         *              sommet de la pile dans A
NXTSTM  EQU    #08A48   Retour a Basic
SYSFLG  EQU    #2F6D9   Flags systÉmes
usrflg  EQU    (SYSFLG)+16    Flags utilisateurs
reserv  EQU    #2F98A   Le quartet de Ram reservÅe
         *              utilisÅ par KBD
SFLAGS  EQU    #135FA   System FLAG Set
SFLAGC  EQU    #13601   System FLAG Clear
flUSER  EQU    -9       flag USER (-9 = FFFF7)
FIXDC   EQU    #05493   DÅcompile au moins une
         *              expression numÅrique
FIXP    EQU    #02A6E   Analyse un paramÉtre num.
         *              obligatoire
DEFADR  EQU    #2F967   Adresse de la dÅfinition
         *              de la touche
pKYDF   EQU    #1B      Poll envoyÅ aprÉs chaque
         *              pression de touche
SFLAG?  EQU    #1364C   System FLAG test
ASRW5   EQU    #0ED0A   DÅcalage a droite de A
FINDA   EQU    #023E3   Equivalent de CASE..OF
k#BKSP  EQU    #67      Code physique de [BACK]
kcBKSP  EQU    #7       Code logique  de [BACK]
k#EOL   EQU    #26      Code physique de [ENDLINE]
k#RUN   EQU    #2E      Code physique de [RUN]
k#UP    EQU    #32      Code physique de [^]
k#DOWN  EQU    #33      Code physique de [v]
k#LFT   EQU    #2F      Code physique de [<]

        REL(5) KBDd
        REL(5) KBDp
KBDe    SETHEX          Pour EXPEX-
        GOSBVL EXPEX-
        GOSBVL RNDAHX   A(A) = argument (en hexa)
        GONC   zÅro     ParamÉtre nÅgatif
        LC(1)  4
        ?A<C   A        Si paramÉtre < 4 alors
        GOYES  normal     c'est normal
zÅro    A=0    A        Sinon, tout autre autre
         *              argument est pris pour 0.
normal  ASRC            A(S)=paramÉtre
        A=A+A  S        On le double pour avoir
         *              une valeur dans [2..6]
        LC(2)  flUSER
        ?A=0   S
        GOYES  clear    On dÅsarme le flag User si
         *              paramÉtre nul
        GOSBVL SFLAGS   System FLAG Set
        GONC   Okuser   B.E.T.
clear   GOSBVL SFLAGC   System FLAG Clear
Okuser  D1=(5) usrflg   On met maintenant les
        DAT1=A S        indicateurs È leur valeur
        D1=(4) reserv   ainsi que la ram-rÅservÅe
        DAT1=A S
        GOVLNG NXTSTM   Et on revient a Basic

KBDp    GOVLNG FIXP
KBDd    GOVLNG FIXDC

**************************************************
* POLl HaNDler
* But: tester chaque touche appuyÅe.
* Methode:
*    Si Touche est:
*      [RUN]: action spÅcifique
*      [^]  :   "         "
*      [v]  :   "         "
*      [<]  :   "         "
*      [%]  :   "         "
*    Sinon, si clavier num. ou alphanum., tester
*    Sinon, si clavier alphabet. ou alphanum.,
*          tester.
**************************************************
POLHND  LC(2)  pKYDF
        ?B=C   B
        GOYES  pol
retour  RTNSXM          Retour È l'appelant

pol     C=D    A        Sauver D(A) pour SFLAG?
        B=C    A
        LC(2)  flUSER
        GOSBVL SFLAG?
        C=B    A
        D=C    A
        GONC   retour   Retour si USER=0
        D0=(5) usrflg   Test des indicateurs 1, 2
        A=DAT0 WP
        D0=(4) reserv
        C=DAT0 WP
        ?A#C   WP       Retour si Ram-reservÅe
         *              diffÉre des flags 0 È 3.
        GOYES  retour   (protection contre le cas:
         *              USER=1, 1=1 -EDTEXT- )
        LC(1)  6        0110 en binaire
        C=C&A  WP       C <- C et A
        ?C=0   WP       Retour si aucun des deux
        GOYES  retour   flags 1 ou 2 n'est armÅ
        LC(1)  9        1001 en binaire
        C=C&A  WP
        ?C#0   WP       Retour si un des flags 0
        GOYES  retour   ou 3 est armÅ (prÅcaution
         *              supplÅmentaire).

* A ce point, nous savons que le flag 1 ou le flag
* 2 est armÅ.
* Le poll est donc interceptÅ.

* Assertions:
*  - D0 pointe sur les flags utilisateur
*  - A(0:0) contient les flags 1 et 2
*  - P= 0

        A=R0            A(A)=logical key-code
        GOSBVL ASRW5    A(A)=physical keycode
        A=DAT0 S

**************************************************
* Test des touches spÅciales.
* But: tester les touches qui ont une action
*      spÅciale.        
*      Ces touches ne sont pas "laissÅes" ou
*      "bloquÅes". Elles correspondent È une
*      dÅfinition, ou È un traitement qui ne
*      peut Átre gÅnÅralisÅ:
*      [RUN]: renvoie la chaÑne "[RAZ]"
*      [^]: renvoie la chaÑne "[AIDE]"
*      [v]: renvoie la chaÑne "[ERREUR]"
*      [ENDLINE]: autorisÅe dans tous les cas
*      [<]: redÅfinie en touche [BACK]
*      [>]: redÅfinie en touche [g][>]
*      [%]: autorisÅe uniquement en clavier num.
**************************************************
* Assertion: pour chacune des routines
* particuliÉres appelÅes:
* A(A)=physical key-code
* R0 inchangÅ par rapport au dÅbut du poll
* D0 pointe sur le quartet de ram-rÅservÅe
* A(S) contient ce quartet
* Aucun niveau de sous-programme supplÅmentaire
* n'est utilisÅ.
**************************************************
        GOSBVL FINDA
        CON(2) k#RUN
        REL(3) run
        CON(2) k#UP
        REL(3) up
        CON(2) k#DOWN
        REL(3) down
        CON(2) k#EOL
        REL(3) retour
        CON(2) k#LFT
        REL(3) backsp
        CON(2) #8A      %
        REL(3) p100
        NIBHEX 00       fin de la table.

* Si le code n'est pas trouvÅ, l'exÅcution reprend
* ici.

        LC(1)  4 
        CSRC
        C=C&A  S        C=C et A
        ?C=0   S        
        GOYES  alpha    clavier alpha

        GOSUB  ici
ici     C=RSTK          C = la valeur de PC
        B=C    A        qui est sauvegardÅe dans B
        LC(5)  (ret)-(ici)  et È laquelle on va
         *              ajouter un dÅplacement
        B=B+C  A        pour avoir l'adresse de la
         *              fin de la table.
        GOSUB  cherche  Chercher si la touche A(B)
         *              est parmi celles-ci:
        CON(2) #0B      7-9
        CON(2) #0D
        CON(2) #19      4-6
        CON(2) #1B
        CON(2) #27      1-3
        CON(2) #29
        CON(2) #35      0-.
        CON(2) #36
        NIBHEX FF       Fin de la table

ret     LC(1)  4        Mode num.
        CSRC            On a toujours dans A(S) la
        ?A=C   S        valeur des indicateurs. Si
        GOYES  bloquer  la touche n'est pas lÈ, et
         *              si clavier num. seulement,
         *              alors on bloque la touche.
alpha   GOSUB  lÈ
lÈ      C=RSTK          MÁme ruse que prÅcÅdemment
        B=C    A
        LC(5)  (bloquer)-(lÈ)
        B=B+C  A
        GOSUB  cherche
        CON(2) #01      Q-P
        CON(2) #0A
        CON(2) #0F      A-L
        CON(2) #17
        CON(2) #1D      Z-M
        CON(2) #23
        CON(2) #2A      -
        CON(2) #2A
        CON(2) #31      esp
        CON(2) #31
        CON(2) #37      ,
        CON(2) #37
        CON(2) #6A      LC
        CON(2) #6A
        CON(2) #71      q-'
        CON(2) #7B
        CON(2) #7F      a-;
        CON(2) #88
        CON(2) #8D      z-m
        CON(2) #93
        CON(2) #98      "
        CON(2) #98
        NIBHEX FF       Fin de la table

**************************************************
* bloquer
* But: renvoyer une dÅfinition du type:
*      DEF KEY " <touche> " , "" ;
*      afin de bloquer la touche.
**************************************************
bloquer D1=(5) DEFADR
        LCHEX  400      dÅfinition du type ";"
         *              de longueur nulle.
        DAT1=C 3
        GOTO   rtn      retour avec une dÅfinition

**************************************************
* cherche
* But: chercher une touche dans une table.
*      Si la touche est trouvÅe, alors retour par
*      RTNSXM (touche autorisÅe).
*      sinon, retour a l'adresse B(A)
* Note: Les appels doivent Átre comme suit:
*       GOSUB  cherche
*       CON(2) t1
*       CON(2) t2
*       CON(2) t3
*       CON(2) t4
*        :
*       NIBHEX FF
*       La table doit Átre triÅe en ordre
*       croissant. La touche est trouvÅe
*       si elle est comprise dans [t1..t2],
*       [t3..t4]...
**************************************************
cherche C=RSTK          Adresse de retour=adresse
         *              du dÅbut de la table
        CD0EX           D0=adresse de la table
boucle  C=DAT0 B        C(B) = borne infÅrieure de
         *              l'intervalle
        ?A<C   B        Touche < (table)
        GOYES  Fin      
        D0=D0+ 2
        C=DAT0 B        C(B) = borne supÅrieure de
        D0=D0+ 2        l'intervalle
        ?A>C   B        Touche > (table + 1)
        GOYES  boucle
        RTNSXM          trouvÅe => autorisÅe

Fin     C=B    A
        RSTK=C          Retour a l'adresse B(A)
        RTN

**************************************************
* def
* But: renvoyer une dÅfinition situÅe juste aprÉs
* l'appel È "def".
* L'appel doit Átre structurÅ comme suit:
*       GOSUB  def
*       CON(1) longueur
*       NIBASC 'dÅfinition'
**************************************************
def     C=RSTK          C(A)=adresse de retour = 
        D0=C            adresse de dÅbut de table.
        C=0    A        longueur sur 1 quartet
        D1=(5) DEFADR
        C=DAT0 WP       On la rappelle, et on la
        DAT1=C B        met sur un octet
        D1=D1+ 2        dans DEFADR.
        LC(1)  2        UDK - terminating
        DAT1=C WP       (User defining key)
        D1=D1+ 1
        CD0EX           C(A)=adresse de la table
        C=C+1  A        C(A)=adresse de la dÅf.
        DAT1=C A
rtn     XM=0            Poll interceptÅ
        ST=1   0        Returning a definition
        RTN

run     GOSUB  def      Appel È la routine "def": 
        CON(1) 5        longueur de la dÅfinition
        NIBASC '[RAZ]'  texte de la dÅfinition
up      GOSUB  def
        CON(1) 6
        NIBASC '[AIDE]'
down    GOSUB  def
        CON(1) 8
        NIBASC '[ERREUR]'
backsp  C=0    W        [BACK] remplace [<]
        LC(1)  kcBKSP   code logique
        P=     5
        LC(2)  k#BKSP   code physique dans C(9:5)
        R0=C            Ni vu, ni connu,
         *              on subtilise !
Retour  RTNSXM
p100    LC(1)  4        0100: mode numÅrique
        CSRC
        ?A=C   S        Mode numÅrique seulement ?
        GOYES  Retour   Oui: on autorise [%]
        GOTO   bloquer  Non: on bloque 

        END