LEX    'AW'

* J. Taillandier - 03/1986

       ID     #5C
       MSG    0
       POLL   poll

       ENTRY  mass
       CHAR   #F
       KEY    'AW'
       TOKEN  1
       ENDTXT


in(    EQU    0
FUNCD0 EQU    #2F8BB

RANGE  EQU    #1B07C
ARGERR EQU    #0BF19
REVPOP EQU    #0BD31
DRANGE EQU    #1B076
STSCR  EQU    #0E92C
RCSCR  EQU    #0E954
SPLITA EQU    #0C6BF
SPLITC EQU    #0C940
AD2-15 EQU    #0C363
MP2-12 EQU    #0C432
FLOAT  EQU    #1B322
uRES12 EQU    #0C994
FNRTN1 EQU    #0F216
MP2-15 EQU    #0C43A

       EJECT

poll   ?B=0   B
       GOYES  hVER$0
       RTNSXM          no other polls
hVER$0 C=R3            handle VER$
       D1=C
       A=R2
       D1=D1- (VER$en)-(VER$st)-2
       CD1EX
       ?A>C   A
       GOYES  hVER$1
       D1=C
       R3=C
VER$st LCASC  ' AW:B'
VER$en DAT1=C (VER$en)-(VER$st)-2
hVER$1 RTNSXM




       NIBHEX 411
mass   CD0EX
       D0=(5) (FUNCD0)
       DAT0=C A        save D0 in FUNCD0
       ST=0   in(
       A=0    W
       B=0    W
       GOSUB  stscr
       GOSBVL =REVPOP  pop & reverse string
       C=0    W        for CSRB
       C=A    A        get length in nibbles
       CSRB            length in bytes
       ?C#0   A
       GOYES  mass01
argerr GOVLNG ARGERR
mass01 C=C-1  A        count 1st char
       R0=C            length in R0
mass11 A=DAT1 B
       GOSUB  Arange
       GONC   mass12
       LCASC  '('
       ?C=A   B
       GOYES  mass13
       LCASC  ')'
       ?C=A   B
       GOYES  mass14
       GOTO   argerr   if not in A..Z

mass13 GOSUB  LP
       D1=D1+ 2
       GOTO   mass11

mass14 P=     1
       GOSUB  mass40
       GOSUB  mass+
       GOTO   RP

mass12 R1=A            save char in R1
       C=R0            restore count
       ?C#0   A
       GOYES  mass20   not yet finished
       P=     1
       GOTO   mass90   find component and exit

mass20 R0=C            save count
       D1=D1+ 2
       A=DAT1 B        read next char
       GOSBVL =DRANGE
       GONC   mass21   it is a digit
       GOSUB  Arange
       GONC   mass25   it is in A..Z
       LCASC  'za'
       GOSUB  range
       GONC   mass26   it is in a..z
       LCASC  '('
       ?A=C   B
       GOYES  mass25
       LCASC  ')'
       ?A=C   B
       GOYES  mass28
       GOTO   argerr   otherwise 'Invalid Arg'

mass21 P=     1
       GOTO   mass34   process digit after processing mass

mass25 P=     1
       GOSUB  mass40
       GOSUB  mass+
       GOSUB  cnt-1
       GOTO   mass11

mass26 C=R1            uppercase + lowecase component
       CSL    W
       CSL    W
       C=A    B
       R1=C            new character appended
       GOSUB  cnt-1    update count
       ?C#0   A
       GOYES  mass31
       P=     3        # of nibbles in comp name
       GOTO   mass90

mass28 P=     1
       GOSUB  mass40
       GOSUB  mass+
       GOSUB  cnt-1
       GOTO   RP

mass31 D1=D1+ 2
       A=DAT1 B        read new char
       GOSUB  drange
       GONC   mass32   in 0..9
       GOSUB  Arange
       GONC   mass33
       LCASC  '('
       ?A=C   B
       GOYES  mass3a
       LCASC  ')'
       ?A=C   B
       GOYES  mass3b
       GOTO   argerr   otherwise 'Invalid Arg'

mass3a P=     3
       GOSUB  mass40
       GOSUB  mass+
       GOSUB  LP
       D1=D1+ 2
       GOTO   mass11

mass3b P=     3
       GOSUB  mass40
       GOSUB  mass+
       GOSUB  cnt-1
       GOTO   RP

mass33 P=     3
       GOSUB  mass40   return mass in C[W]
       GOSUB  mass+    update total
       GOSUB  cnt-1
       GOTO   mass11   process new elt

mass32 P=     3
mass34 GOSUB  mass40
       R2=C            save mass in R2
       GOSUB  dig
       ?C=0   A
       GOYES  mass37   end of string
       GOSUB  Arange
       GONC   mass38
       LCASC  '('
       ?A=C   B
       GOYES  mass35
       LCASC  ')'
       ?A=C   B
       GOYES  mass36
       GOTO   argerr

* dig<12: test if number of digits as counted in D[A]
*         is <= 12.
*         RTN if ok, otherwise error exit

dig<12 C=0    A
       LCHEX  C        12
       ?D<=C  A
       RTNYES
       GOTO   argerr

mass35 GOSUB  dig<12
       GOSUB  massad
       GOSUB  LP
       D1=D1+ 2
       GOTO   mass11

mass36 GOSUB  dig<12
       GOSUB  massad
       GOTO   RP

mass38 GOSUB  dig<12
       GOSUB  massad
       GOTO   mass11   process new component

mass37 GOSUB  dig<12
       GOSUB  massad
       GOTO   mass80   exit...

mass90 GOSUB  mass40
       GOSUB  mass+    add it to total
*                      fall into mass80

* Exit

mass80 ?ST=0  in(
       GOYES  mass81
       GOTO   argerr   we have no ) before end
mass81 GOSUB  rcscr    result in C/D
       D0=(5) (FUNCD0)
       A=DAT0 A
       D0=A            restore D0
       D1=D1+ 2        D1 @ end of string
       BCEX   W        from XYEX
       CDEX   W
       BCEX   W
       ACEX   W        C/D to A/B
       GOSBVL =uRES12  pack result
       GOVLNG =FNRTN1

RP     ?ST=1  in(      already found ( ?
       GOYES  RP01
       GOTO   argerr   no, then error
RP01   ST=0   in(      no more in ()
       C=R0
       ?C#0   A
       GOYES  RP02     still chars after )
       GOSUB  add
       GOTO   mass80
RP02   D1=D1+ 2
       A=DAT1 B        what is after )
       GOSUB  drange
       GONC   RP03     in 0..9
       GOSUB  Arange
       GONC   RP04     in A..Z
       LCASC  '('
       ?A=C   B
       GOYES  RP04     we have '..)(..'
       GOTO   argerr   otherwise error

RP04   GOSUB  add
       GOSUB  cnt-1
       GOTO   mass11

RP03   GOSUB  dig      read number
       ?C=0   A
       GOYES  RP051    nothing after last digit

       GOSUB  endRP    process (
       GOTO   mass11   go to next component

RP051  GOSUB  endRP
       GOTO   mass80

LP     ?ST=0  in(
       GOYES  LP01     not already inside ()
       GOTO   argerr   otherwise error
LP01   ST=1   in(
       A=0    W
       B=0    W
       GOSUB  stscr
       GOSUB  cnt-1
       ?C#0   A
       RTNYES
       GOTO   argerr   they have written '...('

* endRP: sub-prgm for byte savings only ....

endRP  GOSUB  dig<12
       SETDEC
       A=B    W
       GOSBVL =FLOAT   result in A
       GOSBVL =SPLITA
       GOSUB  rcscr
       GOSBVL =MP2-15
       GOSUB  stscr
       GOSUB  add      add returns in HEX mode
       RTN

* add: add 2 15-dig numbers on top of scratch
*      scratch math stack and push result on stack

add    GOSUB  rcscr    pop 1st element on top of stack
       BCEX   W        from XYEX
       CDEX   W
       BCEX   W
       ACEX   W
       GOSUB  rcscr    pop second element
       SETDEC
       GOSBVL =AD2-15  add them
       SETHEX
       GOSUB  stscr
       RTN

* dig: process string of digit
* in:  D1 @ first digit
*      # of characters left in R0
*
* out: C=0 A end of string
*      C#0 A non digit char in A[B]
*      both cases number (DEC) in B[W]

dig    B=0    W        prepare image of count
       D=0    A        prepare digit counter
       GOSUB  cnt-1
       A=DAT1 B        read char
dig01  P=     0        for B=A P
       BSL    W
       B=A    P
       D=D+1  A        update digit count
       C=R0
       ?C=0   A
       RTNYES
       GOSUB  cnt-1
       D1=D1+ 2        point to new character
       A=DAT1 B
       GOSUB  drange   use C[A]
       GONC   dig01    character in 0..9
       RTN

drange GOVLNG =DRANGE

Arange LCASC  'ZA'
range  GOVLNG =RANGE

stscr  GOSBVL =STSCR
       P=     0
       RTN

rcscr  GOSBVL =RCSCR
       P=     0
       RTN

* cnt-1

cnt-1  C=R0
       C=C-1  A
       R0=C
       RTN

* massad: multiply mass in R2 by count in B[W]
*         and add to running total on top of scratch stack

massad SETDEC
       A=B    W
       GOSBVL =FLOAT
       C=R2
       GOSBVL =MP2-12
       GOTO   mass+1

* mass+ : add mass in C[W] to running total
*         on top of math stack.
* use: A,B,C,D,D0,P

mass+  SETDEC
       A=C    W        copy mass in A[W] for addition
       GOSBVL =SPLITA  in 15-digit format in A[W]
mass+1 GOSBVL =RCSCR   recall top of scratch in C[W]
       GOSBVL =AD2-15  add them
       GOSBVL =STSCR   push them again
       P=     0
       SETHEX
       RTN

* mass40: get mass from component name
* entry: name in R1[WP] (P=1 or P=3)
* exit: mass in C[W]
* use: A[W],C[W],D0

mass40 A=R1            recover name
       ?P=    1
       GOYES  srch10
       GOTO   srch20
srch10 GOSUB  srch11
       LIST   OFF
       NIBASC 'B'
       NIBHEX 100000000001801
       NIBASC 'C'
       NIBHEX 100000000011021
       NIBASC 'F'
       NIBHEX 100000030489981
       NIBASC 'H'
       NIBHEX 000000000097001
       NIBASC 'K'
       NIBHEX 100000000389093
       NIBASC 'N'
       NIBHEX 100000000760041
       NIBASC 'O'
       NIBHEX 100000000499951
       NIBASC 'P'
       NIBHEX 100000006737903
       NIBASC 'S'
       NIBHEX 100000000006023
       NIBASC 'U'
       NIBHEX 200000000920832
       NIBASC 'V'
       NIBHEX 100000000414905
       NIBASC 'W'
       NIBHEX 200000000058381
       NIBASC 'Y'
       NIBHEX 100000000950988
       NIBHEX 00
       LIST   ON
srch11 C=RSTK          get address
       D0=C
srch12 C=DAT0 2        get name
       ?A=C   WP
       GOYES  srch13
       ?C=0   WP
       GOYES  srch14
       D0=D0+ 2        past name
       D0=D0+ 15       past numeric value
       GOTO   srch12
srch14 GOTO   argerr
srch13 P=     0
       D0=D0+ 2
       C=0    W        prepare register
       C=DAT0 15       read mass
       P=     0
       RTN

* 2 letters components

srch20 GOSUB  srch21
       LIST   OFF
       NIBASC 'cA'
       NIBHEX 200000000000722
       NIBASC 'gA'
       NIBHEX 200000000868701
       NIBASC 'lA'
       NIBHEX 100000004518962
       NIBASC 'mA'
       NIBHEX 200000000000342
       NIBASC 'rA'
       NIBHEX 100000000084993
       NIBASC 'sA'
       NIBHEX 100000000612947
       NIBASC 'tA'
       NIBHEX 200000000000012
       NIBASC 'uA'
       NIBHEX 200000005669691
       NIBASC 'aB'
       NIBHEX 200000000033731
       NIBASC 'eB'
       NIBHEX 000000000812109
       NIBASC 'iB'
       NIBHEX 200000004089802
       NIBASC 'kB'
       NIBHEX 200000000000742
       NIBASC 'rB'
       NIBHEX 100000000040997
       NIBASC 'aC'
       NIBHEX 100000000008004
       NIBASC 'dC'
       NIBHEX 200000000014211
       NIBASC 'eC'
       NIBHEX 200000000021041
       NIBASC 'fC'
       NIBHEX 200000000000152
       NIBASC 'lC'
       NIBHEX 100000000035453
       NIBASC 'mC'
       NIBHEX 200000000000742
       NIBASC 'oC'
       NIBHEX 100000000233985
       NIBASC 'rC'
       NIBHEX 100000000069915
       NIBASC 'sC'
       NIBHEX 200000004509231
       NIBASC 'uC'
       NIBHEX 100000000064536
       NIBASC 'yD'
       NIBHEX 200000000005261
       NIBASC 'rE'
       NIBHEX 200000000062761
       NIBASC 'sE'
       NIBHEX 200000000000452
       NIBASC 'uE'
       NIBHEX 200000000069151
       NIBASC 'eF'
       NIBHEX 100000000074855
       NIBASC 'mF'
       NIBHEX 200000000000752
       NIBASC 'rF'
       NIBHEX 200000000000322
       NIBASC 'aG'
       NIBHEX 100000000002796
       NIBASC 'dG'
       NIBHEX 200000000052751
       NIBASC 'eG'
       NIBHEX 100000000009527
       NIBASC 'eH'
       NIBHEX 000000000062004
       NIBASC 'fH'
       NIBHEX 200000000094871
       NIBASC 'gH'
       NIBHEX 200000000095002
       NIBASC 'oH'
       NIBHEX 200000004039461
       NIBASC ' I'
       NIBHEX 200000005409621
       NIBASC 'nI'
       NIBHEX 200000000028411
       NIBASC 'rI'
       NIBHEX 200000000022291
       NIBASC 'rK'
       NIBHEX 100000000000838
       NIBASC 'aL'
       NIBHEX 200000005509831
       NIBASC 'iL'
       NIBHEX 000000000001496
       NIBASC 'rL'
       NIBHEX 200000000000062
       NIBASC 'uL'
       NIBHEX 200000000079471
       NIBASC 'dM'
       NIBHEX 200000000000852
       NIBASC 'gM'
       NIBHEX 100000000050342
       NIBASC 'nM'
       NIBHEX 100000000083945
       NIBASC 'oM'
       NIBHEX 100000000004959
       NIBASC 'aN'
       NIBHEX 100000007798922
       NIBASC 'bN'
       NIBHEX 100000000460929
       NIBASC 'dN'
       NIBHEX 200000000042441
       NIBASC 'eN'
       NIBHEX 100000000097102
       NIBASC 'iN'
       NIBHEX 100000000000785
       NIBASC 'oN'
       NIBHEX 200000000000552
       NIBASC 'pN'
       NIBHEX 200000002840732
       NIBASC 'sO'
       NIBHEX 200000000002091
       NIBASC 'aP'
       NIBHEX 200000009530132
       NIBASC 'bP'
       NIBHEX 200000000002702
       NIBASC 'dP'
       NIBHEX 200000000004601
       NIBASC 'mP'
       NIBHEX 200000000000541
       NIBASC 'oP'
       NIBHEX 200000000000902
       NIBASC 'rP'
       NIBHEX 200000007709041
       NIBASC 'tP'
       NIBHEX 200000000090591
       NIBASC 'uP'
       NIBHEX 200000000000442
       NIBASC 'aR'
       NIBHEX 200000004520622
       NIBASC 'bR'
       NIBHEX 100000000876458
       NIBASC 'eR'
       NIBHEX 200000000702681
       NIBASC 'hR'
       NIBHEX 200000005509201
       NIBASC 'nR'
       NIBHEX 200000000000222
       NIBASC 'uR'
       NIBHEX 200000000070101
       NIBASC 'bS'
       NIBHEX 200000000057121
       NIBASC 'cS'
       NIBHEX 100000000955944
       NIBASC 'eS'
       NIBHEX 100000000006987
       NIBASC 'iS'
       NIBHEX 100000000558082
       NIBASC 'mS'
       NIBHEX 200000000004051
       NIBASC 'nS'
       NIBHEX 200000000096811
       NIBASC 'rS'
       NIBHEX 100000000002678
       NIBASC 'aT'
       NIBHEX 200000009749081
       NIBASC 'bT'
       NIBHEX 200000004529851
       NIBASC 'cT'
       NIBHEX 100000000000079
       NIBASC 'eT'
       NIBHEX 200000000006721
       NIBASC 'hT'
       NIBHEX 200000001830232
       NIBASC 'iT'
       NIBHEX 100000000000974
       NIBASC 'lT'
       NIBHEX 200000000073402
       NIBASC 'mT'
       NIBHEX 200000002439861
       NIBASC 'eX'
       NIBHEX 200000000003131
       NIBASC 'bY'
       NIBHEX 200000000040371
       NIBASC 'nZ'
       NIBHEX 100000000008356
       NIBASC 'rZ'
       NIBHEX 100000000002219
       NIBHEX 0000     end of table
       LIST   ON
srch21 C=RSTK
       D0=C
srch22 C=DAT0 4        get name
       ?A=C   WP
       GOYES  srch23
       ?C=0   WP
       GOYES  srch24
       D0=D0+ 4
       D0=D0+ 15       past numeric value
       GOTO   srch22
srch24 GOTO   srch14   not in table
srch23 P=     0
       D0=D0+ 4        @ numeric value
       C=0    W
       C=DAT0 15
       P=     0
       RTN
       END