*COMPILE()
*LKED()
*OBJSW=T
*BNF
* -- Decompiled from ereg12 Sat Jul 20 16:16:16 EDT 2002
<ASOBJBE>     ::= NULL.
<ADJN>        ::= NULL.
<DP1PN>       ::= NULL.
<DP1P>        ::= NULL.
<DP2PN>       ::= NULL.
<DP3PN>       ::= NULL.
<DP4PN>       ::= NULL.
<DSTG>        ::= NULL.
<DPSN>        ::= NULL.
<FORTOVO>     ::= NULL.
<NASOBJBE>    ::= NULL.
<NINRN>       ::= NULL.
<NGEV>        ::= NULL.
<NPVINGO>     ::= NULL.
<NPVINGSTG>   ::= NULL.
<NSVINGO>     ::= NULL.
<NPSNWH>      ::= NULL.
<NTHATS>      ::= NULL.
<PSNWH>       ::= NULL.
<PSVINGO>     ::= NULL.
<SECTION>     ::= NULL.
<SECT-NAME>   ::= NULL.
<SOBJBE>      ::= NULL.
<NPSVINGO>    ::= NULL.
<NSNWH>       ::= NULL.
<PNHOWS>      ::= NULL.
<PNSNWH>      ::= NULL.
<PNVINGSTG>   ::= NULL.
<PSTG>        ::= NULL.
<TOBE>        ::= NULL.
<VINGSTGPN>   ::= NULL.
<PNN>         ::= NULL.
<PNTHATS>     ::= NULL.
<PVINGSTG>    ::= NULL.
<QUOTESTG>    ::= NULL.
<SNWH>        ::= NULL.
<SVEN>        ::= NULL.
<VINGOFN>     ::= NULL.
<VINGSTG>     ::= NULL.
<WHETHS>      ::= NULL.
<TANTSTG>     ::= NULL.
<VSUBJ>       ::= NULL.
* ATOMIC SYMBOLS NOT YET IN USE
<UNUSED> ::= <*CS0> / <*CS2> / <*CS3> / <*CS4> / <*CS5> /
             <*CS6> / <*CS7> / <*CS8> / <*CS10> /
             <*GRAM-NODE> / <*INT> / <*NG> /
             <*NULLPRO1> / <*NULLPRO2> / <*NULLC> / <*NULLN> .
<AINSIQUESTG>    ::= NULL.
<AND-ORSTG>      ::= NULL.
<AS-WELL-AS-STG> ::= NULL.
<ASSTG>          ::= NULL.
<ASTGP>          ::= NULL.
<BEDATE>         ::= NULL.
<BEINGO>         ::= NULL.
<BOTHSTG>        ::= NULL.
<C1SHOULD>       ::= NULL.
<COLONSTG>       ::= NULL.
<CPDNUMBR>       ::= NULL.
<CSSTG>          ::= NULL.
<DASHSTG>        ::= NULL.
<DATEVAR>        ::= NULL.
<DAYYEAR>        ::= NULL.
<DMQSTG>         ::= NULL.
<DOSE-OF-N>      ::= NULL.
<EGSTG>          ::= NULL.
<EITHERSTG>      ::= NULL.
<ENVINGO>        ::= NULL.
<ESPECIALLY-STG> ::= NULL.
<ETCSTG>         ::= NULL.
<FORTOVO-N>      ::= NULL.
<FRACTION>       ::= NULL.
<FTIME>          ::= NULL.
<HOWQASTG>       ::= NULL.
<HOWQSTG>        ::= NULL.
<IMPERATIVE>     ::= NULL.
<INTRO-PHRASE>   ::= NULL.
<INTSTG>         ::= NULL.
<LAR1>           ::= NULL.
<LCDA>           ::= NULL.
<LCDN>           ::= NULL.
<LCDVA>          ::= NULL.
<LCS>            ::= NULL.
<LDATE>          ::= NULL.
<LDATER>         ::= NULL.
<LNAME>          ::= NULL.
<LNAMER>         ::= NULL.
<LNSR>           ::= NULL.
<LPRO>           ::= NULL.
<LQNR>           ::= NULL.
<LTVR>           ::= NULL.
<LVSA>           ::= NULL.
<MEDDOSE>        ::= NULL.
<MOREDATE>       ::= NULL.
<MORESPEC>       ::= NULL.
<NAMESTG>        ::= NULL.
<NEG>            ::= NULL.
<NEGV>           ::= NULL.
<NEITHERSTG>     ::= NULL.
<NINRN>          ::= NULL.
<NISTG>          ::= NULL.
<NNN>            ::= NULL.
<NORSTG>         ::= NULL.
<NOTOPT>         ::= NULL.
<NPDOSE>         ::= NULL.
<NPSNWH>         ::= NULL.
<NPSVINGO>       ::= NULL.
<NPVO>           ::= NULL.
<NPWHS>          ::= NULL.
<NQ>             ::= NULL.
<NSNWH>          ::= NULL.
<NSPOS>          ::= NULL.
<NSTGP>          ::= NULL.
<NTHATS>         ::= NULL.
<NUMBRSTG>       ::= NULL.
<NVINGO>         ::= NULL.
<NVSA>           ::= NULL.
<NWHSTG>         ::= NULL.
<OBJBESA>        ::= NULL.
<ORNOT>          ::= NULL.
<PA>             ::= NULL.
<PAREN-FRAG>     ::= NULL.
<PAREN-RV>       ::= NULL.
<PARENSTG>       ::= NULL.
<PART>           ::= NULL.
<PARTICULARLY-STG> ::= NULL.
<PNPVO>          ::= NULL.
<PNSNWH>         ::= NULL.
<PNTHATSVO>      ::= NULL.
<PNVINGSTG>      ::= NULL.
<PNVO>           ::= NULL.
<PROPOS>         ::= NULL.
<PROSENT>        ::= NULL.
<PSNWH>          ::= NULL.
<PSVINGO>        ::= NULL.
<PTIME>          ::= NULL.
<PUISSTG>        ::= NULL.
<PVO-N>          ::= NULL.
<PVO>            ::= NULL.
<PWHNQ-PN>       ::= NULL.
<PWHNQ>          ::= NULL.
<PWHNS-PN>       ::= NULL.
<PWHNS>          ::= NULL.
<PWHQ-PN>        ::= NULL.
<PWHQ>           ::= NULL.
<PWHS-PN>        ::= NULL.
<PWHS>           ::= NULL.
<Q-ASSERT>       ::= NULL.
<Q-INVERT>       ::= NULL.
<Q-OF>           ::= NULL.
<Q-PHRASE>       ::= NULL.
<QN-TIME>        ::= NULL.
<QNREP>          ::= NULL.
<QNS>            ::= NULL.
<QUAL>           ::= NULL.
<QUECOMP>        ::= NULL.
<QUISEG>         ::= NULL.
<QUOTESTG>       ::= NULL.
<RA1>            ::= NULL.
<RDATE>          ::= NULL.
<RNAME>          ::= NULL.
<RNWH>           ::= NULL.
<RSUBJ>          ::= NULL.
<RXMODE>         ::= NULL.
<S-N>            ::= NULL.
<SAWH>           ::= NULL.
<SAWHICHSTG>     ::= NULL.
<SEGADJ>         ::= NULL.
<SN>             ::= NULL.
<SOBJBE>         ::= NULL.
<SOBJBESA>       ::= NULL.
<SPECIMEN>       ::= NULL.
<STOVO-N>        ::= NULL.
<SUB4>           ::= NULL.
<SUB6>           ::= NULL.
<SUB7>           ::= NULL.
<SUB10>          ::= NULL.
<SUB13>          ::= NULL.
<THANSTG>        ::= NULL.
<THATS-N>        ::= NULL.
<TITLE>          ::= NULL.
<TOBE>           ::= NULL.
<TOSTG>          ::= NULL.
<TSUBJVO>        ::= NULL.
<VERB1>          ::= NULL.
<VERB2>          ::= NULL.
<VERSUSSTG>      ::= NULL.
<VINGSTG>        ::= NULL.
<VINGSTGPN>      ::= NULL.
<VOIRESTG>       ::= NULL.
<WH-PHRASE>      ::= NULL.
<WHATS-N>        ::= NULL.
<WHERES>         ::= NULL.
<WHETHS>         ::= NULL.
<WHETHTOVO>      ::= NULL.
<WHEVERS-N>      ::= NULL.
<WHN>            ::= NULL.
<WHNQ-N>         ::= NULL.
<WHNS-N>         ::= NULL.
<WHQ-N>          ::= NULL.
<WHQ>            ::= NULL.
<YESNOQ>         ::= NULL.
* BNF DEFINITIONS
*
* 1. SENTENCE
<SENTENCE>    ::= <TEXTLET> .
<TEXTLET>     ::= <ONESENT> <MORESENT> .
<ONESENT>     ::= <SECTION> <INTRODUCER> <CENTER> <ENDMARK> .
<MORESENT>    ::= <*NULL> / <TEXTLET> .
<INTRODUCER>  ::= AND / OR / BUT / <INT-PHRASE> (':'/ '-')
                   / <*NULL>.
<INT-PHRASE>  ::= FAMILY HISTORY / PREOPERATIVE DIAGNOSIS
                  / POSTOPERATIVE DIAGNOSIS / <*ADJ> / <LNR>.
<CENTER>      ::= (<ASSERTION> / <SEGADJ> / <QUISEG> / <FRAGMENT>
                   / <OBES>) <PAREN-FRAG> .
<PAREN-FRAG>  ::= '(' <FRAGMENT> ')' / '(' <ASSERTION> ')' / <*NULL> .
<SEGADJ>      ::= <NSTGT> / <PDATE> / <LDR> / <PN> .
<QUISEG>      ::= WHO <VERB> <SA> <OBJECT> <SA-LAST> .
<ENDMARK>     ::= '.' / ';' / '#' / '-'.
* 2. CENTER STRINGS
<ASSERTION>   ::= <SA> <SUBJECT> <SA> <TENSE> <SA> <VERB> <SA>
                  <OBJECT> <SA-LAST> .
<FRAGMENT>    ::= <SA> (<TOVO> / <TVO> / <VO> / <VINGO> /<NSTGF>
                   / <BESHOW> / <SVEN> / <VENPASS> /<ASTGF> / <PN>
                   / <WHOSEG>/ <LDATER>) <SA-LAST> .
<NSTGF>       ::= <NSTG> .
<ASTGF>       ::= <ASTG> .
<BESHOW>      ::= <PROC> <BESUBJ> [':' / '-'] [<PDATE>/<SACONJ>]<OBJBE>
                  <SA-LAST>.
<PROC>        ::= <NSTG> [<PDATE>] [':'] / <*NULL> .
<BESUBJ>      ::= <NSTG> / <*NULL> .
<WHOSEG>      ::= WHO <TENSE> <SA> <VERB> <SA> <OBJECT> <SA-LAST> .
<OBES>        ::= <ASTG> <SA> <TENSE> <SA> <VERB> <SA> <SUBJECT>
                  <SA-LAST> .
* 5. SUBJECT STRINGS
<SUBJECT>     ::= THERE / <EKGSTG> / <NSTG> / <*NULLWH> / <*NULLC> / <WHATS-N> .
<EKGSTG>      ::= <LWVR>.
<LWVR>        ::= <LN> <WVVAR> <RWV>.
<WVVAR>       ::= <*N>.
<RWV>         ::= <RWVOPTS> <RWV> / <*NULL>.
<RWVOPTS>     ::= <IN-LEADS> / <PN>.
<IN-LEADS>    ::= (<*P> / - <*NULL>) <LLEADR>.
<LLEADR>      ::= <LN> <LEADVAR> <RLEAD>.
<LEADVAR>     ::= <*EKGLEAD> '-' <*EKGLEAD> /
                  <*EKGLEAD> THROUGH <*EKGLEAD> /
                  <*EKGLEAD> '-' <*Q> /
                  <*EKGLEAD> THROUGH <*Q> / <*EKGLEAD> .
<RLEAD>       ::= <*D> / <*NULL>.
<NSTG>        ::= <LNR> .
<LNR>         ::= <LN> <NVAR> <RN> .
<NVAR>        ::= <*N> / <*PRO> / <*VING> / <*DS> / <QN>/ <NQ> / <Q10S> .
<Q10S>        ::= <*Q>.
* 7. VERB AND VERBAL OBJECT STRINGS
<VERB>        ::= <*NULLFRAG> / <*NULLC> / <LV> <VVAR> <RV> .
<VVAR>        ::= <*TV> / <*V> .
<TENSE>       ::= <LW> <*W> <RW> / <*NULL> / <*NULLC> .
<LVR>         ::= <LV> <*V> <RV>.
<VENO>        ::= <LVENR> <SA> <OBJECT> <SA-LAST> .
<LVENR>       ::= <LV> <*VEN> <RV> .
<VENPASS>     ::= <LVENR> <SA> <PASSOBJ> <SA-LAST> .
<VINGO>       ::= <LVINGR> <SA> <OBJECT> <SA-LAST> .
<LVINGR>      ::= <LV> <*VING> <RV> .
* 8. OBJECT STRINGS
<OBJECT>      ::=  <*NULLFRAG> / <*NULLC> / <NPVINGO> / <NTOVO> / <NPN> /
                   <VENO> / <NSTGO> / <NPDOSE> / <PQUANT> / <PSVINGO> /
                   <DP2> / <DP3> / <DP1>/ <TOVO> / <PN> / <VO> /
                   <NPVINGO> / <ND> / <DSTG> / <THATS> /
                   <VINGO> / <NTOBE> / <OBJECTBE> /
                   <OBJBE> / <SVEN> / <VENPASS> / <NTHATS> / <ASTG> /
                   <NN> / <SOBJBE> / <WHETHS> / <ASSERTION> /
                   <C1SHOULD> / <SVO> / <NA> / <*NULLOBJ> .
<PASSOBJ>     ::= <ASTG> / <ASOBJBE> / <PVINGO> / <PN> / <PDOSE> / <NSTGO> /
                  <TOVO> / <P1> / <DP1> / <*NULLOBJ> / <THATS> /
                  <OBJBE> / <DSTG> / <ASSERTION> <DP1PN> .
<OBJECTBE>    ::= <VINGO> / <VENPASS> / <TOVO> / <OBJBE> / <THATS> /
                   <WHERES>.
<OBJBE>       ::= <ASTG> / <QUANT> / <NSTG> / <PVINGO > / <PN> / <PQUANT> /
                   <PDATE> / <LDR> .
<QUANT>       ::= <QN> (<PDATE> / <*NULL>) / <QPERUNIT> (<PDATE> / <*NULL>)
                   / <NQ> (<PDATE> / <*NULL>).
<NQ>          ::= <*N> <LQR>.
<QPERUNIT>    ::= [THE] <LQR> <PERUNIT> <REG-ADJ>.
<PERUNIT>     ::= (BY / '/') <*N> / '%' / PER <*N> / A <*N> / <*NULL> .
<REG-ADJ>     ::= <*ADJ> / <*NULL>.
<QN>          ::= <LQR> <*N> <RQ> (<*NULL>) <PERUNIT> <SCALESTG> .
<SCALESTG>    ::= <*ADJ> / <IN-DIM> / <*D> / <*NULL>.
<IN-DIM>      ::= (IN / OF) <*N> .
<Q-AGE>        ::= <*Q> .
<PQUANT>      ::= <*P> <QUANT> .
<ASTG>        ::= <LAR> .
<NSTGO>       ::= <NSTG> / <QUANT> / <*NULLC> / <*NULLWH> .
<DSTG>        ::= <LDR> .
<ND>          ::= <NSTGO> <DSTG> .
<LDR>         ::= <LD> <*D> <RD> .
<NTOVO>       ::= <NSTGO> <TOVO> .
<TOVO>        ::= <LP> TO <VO> .
<THATS>       ::= THAT <ASSERTION> .
<C1SHOULD>    ::= (THAT /<*NULL>) <ASSERTION> .
<NTHATS>      ::= <NSTGO> <THATS> .
<TVO>         ::= <TENSE> <SA> <VERB> <SA> <OBJECT> <SA-LAST> .
<VO>          ::= <TENSE> <SA> <LVR> <SA> <OBJECT> <SA-LAST> .
<SVO>         ::= <ASSERTION>.
* 8A. P STRINGS
<PD>          ::= <*P> <LDR> .
<PN>          ::= <LP> <*P> <NSTGO> .
<NPN>         ::= <NSTGO> <PN> .
<PVINGO>      ::= <*P> <VINGO>.
<PSVINGO>     ::= <*P> <SVINGO>.
<NPVINGO>     ::= <NSTGO> <SA> <PVINGO> .
<NPDOSE>      ::= <NSTGO> <PDOSE> .
<PDOSE>       ::= <*P> <*DS> [<*P> <*DS>] .
<P1>          ::= <*P> .
* 8B. DP STRINGS
<DP1>         ::= <*DP> .
<DP2>         ::= <*DP> <NSTGO> .
<DP3>         ::= <NSTGO> <*DP> .
<DP4>         ::= <*DP> OF (NSTGO / <VINGO>) .
* 8D. NOMINALIZATION WITH ZEROED VERB BE
<NA>          ::= <NSTG> <ASTG> .
<NN>          ::= <NSTGO> <NSTGO>.
<SOBJBE>      ::= <SUBJECT> <OBJBE>.
<SVEN>        ::= <SUBJECT> <VENPASS>.
<NTOBE>       ::= <NSTGO> TO BE <OBJBE>.
<SASOBJBE>    ::= <NSTG> AS <OBJBE>.
<ASOBJBE>     ::= AS <OBJBE>.
* 9. SENTENCE ADJUNCT STRINGS
<SA>          ::= <*NULL> / <SAOPTS> <SA> .
<SA-LAST>     ::= <SAOPTS> <SA> / <*NULL>.
<SAOPTS>      ::= <PDATE> / <SUB11> / <SUB9> / <SUB12> / <SUB0> / <PN> /
                  <PD> / <LDR> / <VENPASS> / <VINGO> / <NSTGT> / <RNSUBJ> /
                  <RSUBJ> / <SUB5> / <SUB1> / <SUB2> / <SUB3> / <SUB8> /
                  <TOVO> / <PVINGO> / <PWHERES>.
<PDATE>       ::= (<*P> / <*NULL>) <LDATER> .
<LDATER>      ::= <LDATE> <DATEVAR> <RDATE> .
<DATEVAR>     ::= <*DT> '-' <*DT> / <*DT> / <T-DATE> .
<T-DATE>       ::= THE <*Q>.
<NSTGT>       ::= <LTIME> <NSTG> .
<RNSUBJ>      ::= <WHS-N> / <PWHS>  / <VENPASS> / <PAREN-RN> .
<RSUBJ>       ::= (<*PRO> / <*Q> / <*T>) [<PN> / <*D>].
<SACONJ>      ::= <SA> .
* 10. SUBORDINATE CONJUNCTION STRINGS
<SUB0>        ::= <*CS0> <OBJBE>.
<SUB1>        ::= <*CS1> <ASSERTION> .
<SUB2>        ::= <*CS2> <VENPASS> .
<SUB3>        ::= <*CS3> <VINGO> .
<SUB5>        ::= <*CS5> <SVINGO>.
<SUB6>        ::= <*CS6> <SOBJBE>.
<SUB8>        ::= AS (WAS / WERE /DID) <SUBJECT> .
<SUB9>        ::= <*CS9> <VO>.
<SUB11>       ::= <TM-PHRASE> <ASSERTION>.
<SUB12>       ::= SHOULD <SVO>.
<SVINGO>      ::= <SUBJECT> <SA> <VINGO> .
<TM-PHRASE>   ::= FOLLOWING WHICH / DURING WHICH TIME / DURING WHICH
                  / BEFORE WHICH / AFTER WHICH / AFTER WHICH TIME.
* 11. RN RIGHT ADJUNCTS OF N
<RN>          ::= <RNOPTS> <RN> / <*NULL> .
<RNOPTS>      ::= <PAREN-RN> / <TQVINGO> / <PDATE> / <BPART> / <VENPASS>
                   / <ADJINRN> / <NTIME>
                   / <*DS> / <QUANT> / <LDR> / <PQUANT> / <PDOSE>
                   /<PVINGO> / <TOVO> / <PN> / <VINGO> / <THATS>
                   / <WHERES> / <PWHS> / <WHS-N>
                   / - <TOVO-N> / <WHENS> / <WHOSES>/ <S-N>
                   / - <PERUNIT> / <PAREN-NSTG>  / - <APPOS>.
<TQVINGO>     ::= <TQ> <VINGO>.
<TQ>          ::= <*T> / <*Q>.
<S-N>         ::= <ASSERTION>.
<PAREN-RN>    ::= '(' <RNOPTS> <RN> ')' .
<PAREN-NSTG>  ::= <NSTG> .
<ADJINRN>     ::= <LAR> .
<NTIME>       ::= <N> .
<BPART>       ::= <LNR> / <*ADJ> .
<TOVO-N>      ::= <LP> TO <LVR> <SA> <OBJECT> <SA-LAST> .
<APPOS>       ::= [','] <LNR> .
* 12. LN LEFT ADJUNCTS OF N
<LN>          ::= <TPOS> <QPOS> <APOS> <NPOS> .
<TPOS>        ::= <LTR> / <*NULL> / <LNS>.
<LTR>         ::= <LT> <*T> <RT> .
<LNS>         ::= <TPOS> <*NS> .
<QPOS>        ::= <LQR> / <*NULL> .
<LQR>         ::= <LQ> <QVAR> <RQ> .
<QVAR>        ::= <BP-VALUE> /<*Q> X <*Q> / <RATIO> / <QPER> / <QTH>
                   / <*Q> '-' <*Q> / <*Q> TO <*Q> / <*Q> OR <*Q>
                   / <*Q> OVER <*Q> /  <*Q> '+' <*Q>
                   / <*Q> 'X' <*Q> 'X' <*Q> / <*Q> OF <*Q>
                   / <*Q> 'OUT OF' <*Q> / <*Q> .
<BP-VALUE>    ::= <*Q> '/' P.
<QPER>        ::= <*Q> '/' <*N> .
<RATIO>       ::= <*Q> '/' <*Q>  ['/' <*Q>] .
<QTH>         ::= <*N> TO <*N> .
<APOS>        ::= <ADJADJ> / <*NULL>.
<ADJADJ>      ::= <LAR> / <QN> / - <QPERUNIT> / <NQ>
                     / <ADJADJ> (<LAR> / <QN> / <QPERUNIT> / <NQ>).
<LAR>         ::= <LA> <AVAR> <RA> .
<AVAR>        ::= <*ADJ> / <*VEN> /<*VING> .
<NPOS>        ::= <NNN> / <*NULL> .
<NNN>         ::= <*N> / <*DS> / <*N> (<*ADJ>/<*VEN>)
                       / <NNN> (<*N> / <*DS>).
* 13. RIGHT ADJUNCTS - OTHER THAN RN
<RT>          ::= <*NULL> .
<RQ>          ::= <*D> / <REG-ADJ> / <*NULL> .
<RA>          ::= ENOUGH / <PAREN-ADJ> / <PQUANT> / <FORTOVO> / <PN>
                  / <PVINGO> / <TOVO> / <TOSTG> / <TOVO-N>
                  / <THATS> / <ASSERTION> / <WHETHS> / <*NULL> .
<PAREN-ADJ>   ::= '(' <*ADJ> ')' .
<FORTOVO>     ::= FOR <SUBJECT> <SA> <TOVO> .
<TOSTG>       ::= TO <LAR>.
<RD>          ::= <*NULL> .
<RV>          ::= <PVINGO> / <PDATE> / <PQUANT> / <PN> / <THATS>
                   / <C1SHOULD> / <LDR> / <TOVO> / <NSTGT> / <*NULL>
                   / <QN> .
<RW>          ::= <LDR> / <*NULL> .
<RDATE>       ::= <WHENS> / <*NULL> .
* 14. LEFT ADJUNCTS - OTHER THAN LN
<LT>          ::= <*NULL> / <*Q> /<*D> .
<LA>          ::= <*NULL> / <LDR> / <QN> / <*Q> .
<LQ>          ::= <*D> / <*NULL> / <*ADJ> .
<LV>          ::= <LDR> / <*NULL>.
<LW>          ::= <*D> / <*NULL> .
<LD>          ::= <*NULL> / <*D> .
<LP>          ::= <QN-TIME> / <LDR> / <*NULL> .
<QN-TIME>     ::= <LQR> <*N>.
<LDATE>       ::= <*NULL> / MID / EARLY / LATE / THE / <*D> .
<LTIME>       ::= <*NULL> / <*D> .
* 15. WH-STRINGS
<WHS-N>       ::= (WHO / WHICH / THAT) <ASSERTION>.
<S-N>         ::= <ASSERTION>.
<PWHS>        ::= <*P> WHICH <ASSERTION>.
<WHENS>       ::= <WHEN-PHRASE> <ASSERTION> .
<WHEN-PHRASE> ::= WHEN / AT WHICH TIME / AFTER WHICH / <*NULL>.
<WHATS-N>     ::= WHAT <ASSERTION>.
<WHERES>      ::= WHERE <ASSERTION>.
<PWHERES>     ::= <*P> WHERE <ASSERTION>.
<WHOSES>      ::= WHOSE <ASSERTION>.
<WHETHS>      ::= (WHETHER OR NOT / WHETHER / WHERE / WHEN / HOW
                   / WHY / IF) (<ASSERTION>/<TOVO>) .
* 16. CONJUNCTION STRINGS
<ANDSTG>      ::= (AND / '&') <SACONJ> <Q-CONJ> (EACH / <*NULL>) .
<WITHSTG>  ::= WITH <SACONJ> <Q-CONJ> .
<ORSTG>       ::= OR <Q-CONJ> .
<NORSTG>      ::= NOR <Q-CONJ> .
<INCLUDINGSTG> ::= INCLUDING <Q-CONJ> .
<BUTSTG>      ::= BUT <Q-CONJ> .
<PLUSSTG>     ::= PLUS <Q-CONJ> .
<COMMASTG>    ::= ',' ( <SACONJ> <Q-CONJ> / <*NULL>) .
<ANDORSTG>    ::=  'AND/OR' <Q-CONJ>.
<ASWELLASSTG> ::=  'AS WELL AS' <Q-CONJ>.
<INADDITIONTOSTG> ::= 'IN ADDITION TO' <Q-CONJ>.
<PARTICULARLYSTG> ::= PARTICULARLY <Q-CONJ>.
<Q-CONJ>      ::= <*NULL> .
<LAUX>           ::= NULL.
* TRANSFORMATIONAL DUMMIES
<AGENT>          ::= NULL.
<PNX2>           ::= (<PN> / <PVINGSTG>) <SA> (<PN> / <PVINGSTG>).
* DUMMY NODE FOR WRITING FORMAT
<STOP>           ::= NULL.
<DUMMY>          ::= NULL.
<QUESTION>       ::= NULL.
* FORMAT NODES
<MODAL>          ::= NULL.
<TM-PER>         ::= NULL.
* REGULARIZATION MARKERS:
*      DUMMY BNF DEFINITIONS
<AGE>             ::= NULL.
<AREA-MOD>        ::= NULL.
<BP-MOD>          ::= NULL.
<CHANGE-OF-STATE> ::= NULL.
<CONJOINED>       ::= NULL.
<EMBEDDED>        ::= NULL.
<EVENT-TIME>      ::= NULL.
<HEADCONN>        ::= NULL.
<LCONN>           ::= NULL.
<LCONNR>          ::= NULL.
<LPR>             ::= NULL.
<MODS>            ::= NULL.
<PARSE-CONN>      ::= NULL.
<PREP-CONN>       ::= NULL.
<QUANTITY>        ::= NULL.
<RCONN>           ::= NULL.
<REL-CLAUSE>      ::= NULL.
<RELATION>        ::= NULL.
<RP>              ::= NULL.
<SUB-CONJ>        ::= NULL.
<TIME>            ::= NULL.
<TIME-CONJ>       ::= NULL .
<UNIT>            ::= NULL.
<Y-OF>            ::= NULL.
*LISTS
* ATTRIBUTE LISTS
*    1. BASE ATTRIBUTES USED IN DICTIONARY AND PARSING GRAMMAR.
*       MISSING DIDOMPN. UNUSED PT1.
*    2. SELECTION COMPONENT ADDS: PASS-SEL, LINKC, N-OMITSTG,
*       START-HGRAPH, STAY-HGRAPH, TRY-ATT.
*    3. TRANSFORMATION COMPONENT ADDS:
*       PREFX, DEL-ATT, INDEX, TENSE-ATT, TFORM-ATT,
*       [** ATTRIBUTES ASSIGNED TO TENSE-ATT **]
*       CONDITIONNEL, FUTURE, IMPARFAIT, IMPERTVE, PERF, PRESNT, PROG,
*       [** ATTRIBUTES ASSIGNED TO TFORM-ATT **]
*       TFORTOVO, TNPVINGO, TNPVO, TNSVINGO, TPVO, TRNFILLIN,
*       TRNWH, TSASOBJBE, TSOBJBE, TSVINGO, TTHATS, TWHATSN,
*       TWHETHS.
*    4. REGULARIZATION COMPONENT ADDS: FORMAT-ATT, EMBED-OBJ,
*       EMBED-SUBJ, REFPT-ATT, TYPE-ATT, PT2, SEM-CORE,
*       [** ATTRIBUTES ASSIGNED TO FORMAT-ATT **]
*       FRMT-UNIT, FRMT00, FRMT0, FRMT1, FRMT2, FRMT3, FRMT4,
*       FRMT1-3, FRMT13-MED, FRMT5-MISC, FRMT5-EKG,
*       FRMT4-5, FRMT5, FRMT5F, FRMT5-ALG, FRMT6, NOFRMT.
*    5. FORMAT COMPONENT ADDS:
*       FILLED-PT, FORMAT-PT, TRANSFORM-ATT, UNIT-ATT [NOT USED].
* WD-ATTRIBUTES USED IN DICTIONARY
ATTRIBUTE =
        [* ATTRIBUTES CURRENTLY USED *]
      AASP, ACCUSATIVE, ACT, AFORTO, APREQ, ASENT1,
      ASENT3, ATHAT,
      C, COLLECTIVE, COND,
      DATIVE, DEF, DEM, DEVAL, DLA, DLD, DLP, DLQ, DLTIME, DLV,
      DRA, DRD, DRQ, DRV, DSA,
      F, FUT,
      IMP, INDEF, INDEFINITE, INSTR, INV,
      LESS,
      M, MODAL-AFFIX, MORE, MORPH,
      NCOUNT1, NEG-MEAN, NEG-PREFIX, NEGATIVE, NHUMAN,
      NMONTH, NO-REP, NOMINATIVE, NSCALE, NSENT1, NSENT4,
      NVN, PLACE-HOLDER [for non pronoun it],
      PAST, PERS1, PERS2, PERS3, PLURAL, POST, PRESNT, PREV, PVAL,
      QALL, QNUMBER, QROVING, [* new *] QAGE, QTENS, QDATE, QTESTVAL,
      SAME, SCOPE, SINGULAR, SUBJONCTIF [French],
      TDEM, TIMETAG, TPOSS, TRANSITIVE,
      VBE, VETRE, VHAVE, VMIDDLE, VSE, VVERYVING,
        [* ATTRIBUTES CURRENTLY UNUSED *]
      ACOMPOUND, AGGREGATE, AINPA, AINRN, ARG, ARGPTR, ARGUMENT,
      ASCALE, ASENT2, ASHOULD, AWH,
      CATEGORIES, COMPARATIVE,
      CS0AS, CS1INNER,
      DLCOMP, DLCS, DLOC1, DLOC2, DLOC3, DLT, DLTPRO, DLW,
      DMANNER, DMIDDLE, DMOBILE, DPERM, DPRED, DRN,
      DRW, DSA1, DUNIV, DVERY,
      EACHEVRY,
      NAME, NCLASSIFIER1, NCLASSIFIER2, NCOUNT2, NCOUNT3,
      NCOUNT4, NEGADJ, NEO, NLETTER, NONHUMAN, NONTRANSITIVE,
      NPREQ, NSENT2, NSENT3, NSENTP, NTH, NTITLE,
      POS, PRE, PREFX, PROPOSS, PROSELF,
      QHALF, QMANY,
      REFLEXIVE,
      SUPERLATIVE,
      TQUAN,
      VASP, VCOLLECTIVE, VDO, VENDADJ, VEVENT, VEXP,
      VMANNER, VMOD, VMOTION, VRARE, VRECIP,
      VSENT1, VSENT2, VSENT3, VSENT4,
      W7WORD.
* GR-ATTRIBUTES USED IN GRAMMAR
ATTRIBUTE =
        [* ATTRIBUTES CURRENTLY USED *]
      ANYTHING [DVC1, DVC2],
      CONDITIONNEL, CONJ-LIKE,
      FRMT-UNIT, FRMT0, FRMT00, FRMT1, FRMT2, FRMT3,
      FRMT13-MED, FRMT5-MISC [* 2000 Oct 26 *], FRMT5-EKG,
      FRMT4, FRMT4-5, FRMT5, FRMT5F, FRMT5-ALG, FRMT6, FUTURE,
      IMPARFAIT, IMPERTVE,
      NOFRMT,
      OBJECTPRO, OBJLIST,
      PASS-SEL [CLASS FOR SELECTION LISTS- ALWAYS PASS],
      POBJLIST, PROG,
      TFORTOVO, TNPVINGO, TNTOVO, TNSVINGO, TTOVO,
      TRNFILLIN, TRNWH, TSASOBJBE, TSOBJBE, TSVINGO,
      TTHATS, TWHATSN, TWHETHS,
        [* ATTRIBUTES CURRENTLY UNUSED *]
      BVAL,
      DECIMAL, DPVAL,
      NOTNOBJ, NOTNSUBJ, NPNPN,
      OVAL,
      P-ITIS, PERF, PNPN, POBJECT, PVAL1, PVAL2,
      SENTOBJ, SUB, SVAL,
      TOBJLIST.
* SUBLANGUAGE-ATTRBS
ATTRIBUTE =
        [* LIST TYPE DECLARATIONS *]
      ADJUNCT-TYPE,
      BODYFUNC-PN, BODYLOC-PN, CONN-PN,
      CONN-TYPE,
      INSTR-TYPE,
      NULLNCLASS,
      QUANT-ADVERBIAL,
      TIME-ADVERBIAL, TIME-CLASS [USED TO MARK TIME CLASS LIST],
      VHAVE-TYPE,
        [* ATTRIBUTES CURRENTLY USED *]
      BEREP,
      E-AX [EKG axis], E-EKGPROC [EKG test], E-INTVL [EKG interval],
      E-LEAD [EKG leads], E-WV [EKG wave], EMPTY-SET,
      FAIL-SEL, FEM,
      GENERIC,
      H-AGE, H-ALLERGY, H-AMT,
      H-BECONN, H-BEH,
      H-CELLTYPE, H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS,
      H-CHANGE-SAME, H-CHANGEMK, H-CHEM, H-CONN,
      H-DESCR, H-DEVMED, H-DIAG,
      H-ETHNIC, H-EVID,
      H-FAMILY,
      H-GEOGR,
      H-INDIC, H-INST,
      H-MODAL,
      H-NEG, H-NOCLASS, H-NORMAL, H-NULL,
      H-OBSERVE, H-ORG,
      H-POST, H-PT, H-PTAREA, H-PTFUNC, H-PTLOC, H-PTMEAS,
      H-PTPALP, H-PTPART, H-PTSPEC, H-PTVERB,
      H-RECORD, H-DIET [formerly H-REPAS], H-RESP, H-RESULT,
      H-SHOW,
      H-TMBEG, H-TMEND, H-TMLOC, H-TMDUR, H-TMPREP, H-TMREP,
      H-TRANSP,
      H-TTSURG, H-TTCOMP, H-TTFREQ, H-TTGEN, H-TTMED, H-TTMODE,
      H-TXCLIN, H-TXPROC, H-TXRES, H-TXSPEC, H-TXVAR,
      H-UNDEF [undefined word],
      MASC,
      NO-TYPE, NTIME1, NTIME2, NUNIT,
      PAST,
      TIME-PREFIX, TRANSP,
        [* ATTRIBUTES CURRENTLY UNUSED *]
      G-VRELFAC,
      H-ADJSPINE,
      H-DIMENSION, H-DOCTOR,
      H-ERROR, H-EVENT,
      H-GENERIC, H-GROW,
      H-HOSP,
      H-INGEST, H-INTOX,
      H-LABRES,
      H-MULT,
      H-NORM,
      H-OCCASION,
      H-PART, H-PSYCH, H-PTDESCR,
      H-SET, H-SHAPE, [H-STATUS,]
      H-TRIGGER [weak causative], H-TESTVIEW, H-TIMEQUAL, H-TYPE,
      H-VRX, H-VTEST,
      H-VTENSE,
      V-HEAL.
* NODE-ATTRIBUTES
ATTRIBUTE = FRMT1-3 [New combined F1+F2+F3+F5+F5F],
            FRMT345 [Ambiguous FRMT1-3, FORMAT4 and FRMT5, FRMT5-ALG, FRMT5F],
            FRMT45 [Ambiguous FRMT4, FRMT5-ALG *** not used ***],
            FRMT3-5 [Ambiguous FRMT1-3 and FRMT5, FRMT5-ALG, FRMT5F],
            FRMT5-PTFAM [Ambiguous FRMT5 and FRMT5-ALG, FRMT5F],
            SEM-CORE [NEW NAME FOR HOST-ASP],
            PATHIF [* snopath *], FUT-IMP.
ATTRIBUTE =    [* EKG ATTRIBUTES *]
            E-AX [axis], E-LEAD [EKG leads], E-INTVL [interval],
            E-WV [EKG wave].
ATTRIBUTE = ANTECEDENT, ANALINK, MARK, QLINK, FUT-IMP.
ATTRIBUTE = ASSN-SELATTS [* all SELECT-ATT in ASSERTION *].
ATTRIBUTE =
      AMBIG [* ambiguous expansion *],
      ADVERBIAL-TYPE, ASSIGN-ATT,
      COMMA-NULLFRAG, COMPUTED-ATT,
      DEFERRED, DEL-ATT, DIDOMIT, DIDOMPN, DIRECT,
      EMBED-OBJ, EMBED-SUBJ,
      FILLED-PT, FORMAT-ATT, FORMAT-PT,
      HGRAPH-ATT,
      INDIRECT, INDEX,
      LAST-NODE, LINKC, LN-TO-N-ATT,
      MATCHED, MED-ATT,
      N-OMITSTG, N-TO-LN-ATT, N-TO-RN-ATT,
      NO-RN-ATT, NOT-DISTR-LN-ATT, NOT-DISTR-RN-ATT, NOT-FREE,
      POSTCONJELEM, PRECONJELEM, PVAL-ATT, PT1, PT2,
      REFPT-ATT [IDENTIFIES PN WITH REFPT IN IT], RN-TO-N-ATT,
      SE, SELECT-ATT, SEM-CORE, SHARED-CONNECTIVE,
      START-HGRAPH, STAY-HGRAPH,
      TENSE-ATT, TFORM-ATT, TRANSFORM-ATT, TRY-ATT, TYPE-ATT,
      WORD-POS, UNIT-ATT.
* WORD POSITION ATTRIBUTES
ATTRIBUTE = W001, W002, W003, W004, W005, W006, W007, W008, W009,
      W010, W011, W012, W013, W014, W015, W016, W017, W018, W019,
      W020, W021, W022, W023, W024, W025, W026, W027, W028, W029,
      W030, W031, W032, W033, W034, W035, W036, W037, W038, W039,
      W040, W041, W042, W043, W044, W045, W046, W047, W048, W049,
      W050, W051, W052, W053, W054, W055, W056, W057, W058, W059,
      W060, W061, W062, W063, W064, W065, W066, W067, W068, W069,
      W070, W071, W072, W073, W074, W075, W076, W077, W078, W079,
      W080, W081, W082, W083, W084, W085, W086, W087, W088, W089,
      W090, W091, W092, W093, W094, W095, W096, W097, W098, W099,
      W100, W101, W102, W103, W104, W105, W106, W107, W108, W109,
      W110, W111, W112, W113, W114, W115, W116, W117, W118, W119,
      W120, W121, W122, W123, W124, W125, W126, W127, W128, W129,
      W130, W131, W132, W133, W134, W135, W136, W137, W138, W139,
      W140, W141, W142, W143, W144, W145, W146, W147, W148, W149.
* PHRASE-ATTRIBUTES
ATTRIBUTE = PHRASE-ATT,
      AGE-PHRASE, DATE-PHRASE, DOSE-PHRASE, INFLUENCE-PHRASE,
      PTPART-PHRASE, QUANT-PHRASE, RADIATE-PHRASE, SOURCE-ATT,
      SOURCE-PHRASE, TIME-PHRASE, TIME-POST-PHRASE, TESTENV-PHRASE.
ATTRIBUTE = SAVE-SELECT-ATT [* save Pronoun select-att for antecedent *].
ATTRIBUTE = SUPPORT-ATT [* save SUPPORT-CLASSES *].
* GLOBAL LISTS
*
GLOBAL = $ASCNT [ROUTINE L(X)],
         $ASSIGN-PRE-AND-POST [PRE-POST-CONJELEM],
         $AT-LADJ [HOST-, HOST],
         $AT-RADJ [HOST-, HOST],
         $ATRNSUBJ [HOST-, HOST],
         $CORE-PATH [CORE-],
         $NHUMAN-CHK [CORE-ATT, CORE-SELATT],
         $PRECONJ [COEL1],
         $POSTCONJ [CORE, DOWN1, STACK-FOR-LEFT],
         $RIGHT-TO-HOST [FOLLOWING-ELEMENT, HOST-ELEMENT],
         $STACK-TEST [DOWN1],
         $TO-PRECONJUNCTION-Y [COEL1],
         $UP-CONJ [LEFT-ADJUNCT, RIGHT-ADJUNCT].
GLOBAL = $ASPECTUAL [DEEPEST-COVERB],
         $UP-THROUGH-Q [IMMEDIATE, PRESENT-STRING].
* GLOBAL-REGS
GLOBAL = $ADD-TO-SELATT [T-SEM-CORE-OF-LXR, T-SETUP-NEG-MEAN,]
                        [T-SETUP-TENSE],
         $ASSIGN-FRMT0 [T-LXR-FORMAT-TYPE,T-SUBJECT-CHK],
         $ASSIGN-HOST [T-SEM-CORE-OF-LXR, T-SEM-CORE-OF-PSTG, -QN],
         $BUILD-CONJOINED [T-CONJ-IN-CENTER, T-CONJ-IN-NSTG],
         $BUILD-FRAGMENT [T-EXPAND-REFPT, T-CHANGE-OF-STATE,]
                         [T-WITH-CONJ],
         $BUILD-HEADCONN [T-CONJ-IN-CENTER, T-SAWH, T-CSSTG,]
                         [T-SA-PNCONN],
         $BUILD-LCONNR [T-CONJ-IN-CENTER, T-SAWH, T-CSSTG],
         $BUILD-LCONN-RCONN [T-FIND-CONN, T-CHANGE-OF-STATE,]
                            [T-WITH-CONJ],
         $BUILD-PCONN [T-SA-PNCONN, T-RADJ-CONN, T-REL-CLAUSE],
         $BUILD-RELATION [T-SA-PNCONN, T-FIND-CONN],
         $BUILD-RELCLAUSE [T-REL-CLAUSE, T-EXPAND-REFPT,]
                          [T-CHANGE-OF-STATE, T-WITH-CONJ],
         $COPY-NEG-MODAL [T-CONJ-IN-CENTER, T-SA-PNCONN],
         $FIND-ASSERT [T-REL-CLAUSE, T-EXPAND-REFPT,]
                      [T-CHANGE-OF-STATE, T-WITH-CONJ],
         $FIND-HOST [T-SEM-CORE-OF-LXR, T-HOST-AGE-UNIT],
         $HAS-FAIL-SEL [T-SEM-CORE-OF-LXR, T-LXR-FORMAT-TYPE],
         $HAS-ADJ-TYPE [T-SEM-CORE-OF-LXR, T-LXR-FORMAT-TYPE],
         $HOST-IS-OBJ [T-SEM-CORE-OF-LXR, T-MOVE-S-UP],
         $HOST-OF-PN [T-SEM-CORE-OF-LXR, T-SEM-CORE-OF-PSTG],
         $LNR-HOST [T-SEM-CORE-OF-LXR, T-HOST-AGE-UNIT],
         $IS-A-TYPE [T-LXR-FORMAT-TYPE, T-CHK-FORMAT-TYPE],
         $MOVE-CONJ [T-CONJ-IN-CENTER, T-CONJ-IN-ASSERTION],
         $PN-CONN-TEST [T-SA-PNCONN, T-RADJ-CONN],
         $PRINT-LIST-INFO [T-SEM-CORE-OF-LXR, T-SEM-CORE-OF-REPT],
         $PRINT-NODE-INFO [T-SEM-CORE-OF-LXR, T-SEM-CORE-OF-REPT],
         $PRINT-RESTR [T-SEM-CORE-OF-LXR, T-SEM-CORE-OF-REPT],
         $SET-SEM-CORE [T-SEM-CORE-OF-LXR, T-SETUP-NEG-MEAN,]
                       [T-SETUP-TENSE],
         $TIME-PHRASE [T-SEM-CORE-OF-PSTG, T-SEM-CORE-OF-LXR],
         $TRANSFORM-TO-RIGHT [T-MOVE-S-UP, T-REL-CLAUSE].
* GLOBAL-SEQUENCE
GLOBAL = $DESCENT-TYPE [TSEQ-STRING, TSEQ-ADJUNCT,TSEQ-OBJ],
         $ITERATE-CONJ [TSEQ2,TSEQ3],
         $LXR-TYPE [TSEQ-STRING, TSEQ-ADJUNCT],
         $STRING-TYPE [TSEQ-STRING, TSEQ-ADJUNCT],
         $TFORM-LADJ-RADJ [TSEQ-NSTG3A, TSEQ-DSTG-NNN].
* SUBLANGUAGE SELECTION LISTS
LIST VBE-LIST = VBE.
*  THE FOLLOWING LISTS ARE USED BY SUBLANGUAGE SELECTION AND
*  CONJUNCTION RESTRICTIONS
*
* SUBLANGUAGE-ATTS
*     LIST OF ALL ATTRIBUTES INVOLVED IN SELECTION.  THIS INCLUDES ALL
*     SUBLANGUAGE CLASSES AND THOSE ENGLISH CLASSES WHICH PARTICIPATE
*     IN SELECTION (GIVEN AT BEGINNING OF THE LIST).
*     ANY CLASS ON THIS LIST WILL BE REQUIRED TO CONJOIN TO WORDS OF
*     THE SAME CLASS.  UNLESS THE CLASS ALSO APPEARS ON THE LIST
*     CONJ-EQUIV-CLASSES, WHICH DEFINES AN EQUIVALENCE CLASS FOR
*     CONJUNCTION.
LIST SUBLANGUAGE-ATTS =
        [* English classes *]
     [ASENT1, ASENT2, AASP,]
     [BEREP,]
     [CONJ-LIKE, EMPTY-SET,] FEM,
     [INSTR,] MASC,
     [NSENT1, NSENT2, NSENT3, NSENTP,]
      NTIME1, NTIME2, [NULLNCLASS,] NUNIT,
      QNUMBER,
      VBE, VDO, VHAVE,
        [* Sublanguage classes *]
      E-AX, E-EKGPROC, E-INTVL, E-LEAD, E-WV [for EKGSTG],
      H-AGE, H-ALLERGY, H-AMT,
      H-BECONN, [H-BEH,]
      H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS, H-CHANGE-SAME, H-CONN,
      H-CHEM, [H-CELLTYPE,]
      H-DESCR, H-DEVMED, H-DIAG, [H-DIMENSION, H-DOCTOR,]
      H-ETHNIC, [H-EVENT,] H-EVID,
      H-FAMILY,
      H-GEOGR, [H-GROW, H-HOSP,]
      H-INDIC, H-INST, [H-INTOX,]
     [H-LABRES,]
      H-MODAL,
      H-NEG, [H-NOCLASS,] H-NORMAL, H-NULL,
      H-OBSERVE, [H-OCCASION,] H-ORG,
      H-PT, H-PTAREA, H-PTDESCR, H-PTFUNC, H-PTLOC, H-PTMEAS,
     [H-PTPALP,] H-PTPART, H-PTSPEC, H-PTVERB,
      H-RECORD, H-RESP, H-RESULT,
      H-SHOW, [H-STATUS,]
      H-TMBEG, H-TMEND, H-TMLOC, H-TMDUR, H-TMPREP, H-TMREP,
      H-TTSURG, H-TTCOMP, [H-TTFREQ,] H-TTGEN, H-TTMED, H-TTMODE,
      H-TXCLIN, H-TXPROC, H-TXRES, H-TXSPEC, H-TXVAR,
      H-TESTVIEW, H-TRANSP, [H-TRIGGER,]
      H-VTENSE, H-VTEST.
* CONJ-EQUIV-CLASSES
*     A list used by the parsing grammar (rules appearing in WCONJ9)
*     to determine sublanguage semantic compatibility of conjuncts 
*     (two or more phrases joined by commas, "and", "or", nor",...).
*
*     The following assumptions apply:
*     A. An attribute is always conjunctionally equivalent
*        to itself (full list of attributes is found in
*        SUBLANGUAGE-ATTS list).
*        E.g. 'headache, fever and vomiting' each has identical
*             sublanguage attribute H-INDIC.
*     B. CONJ-EQUIV-CLASSES list is a list of all equivalence
*        classes appearing in sublists (shown below).
*        E.g. 'pain on upper surface and fingers'
*             (H-PTAREA and H-PTPART are conjunction equivalents
*     C. A computed attribute COMPUTED-ATT of a phrase is
*        used first to determine compatibility with its conjoined
*        phrase.  For example, 'fever and stiff neck' are judged
*        CONJ-EQUIVALENT because 'stiff neck' has
*        COMPUTED-ATT = H-INDIC. The lists N-COMP-ATT-LN and
*        N-COMP-ATT-RN contain the word class combinations that
*        that constitute COMPUTED-ATTs.
*
LIST CONJ-EQUIV-CLASSES =
  (H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS, H-CHANGE-SAME,
     H-TXRES, H-RESULT 
     [* creatinine increase H-CHANGE-MORE and MB of 12 H-RESULT *]),
  (H-CHEM, H-INDIC
     [* signs of black widow toxin and venomization *]),
  (H-TXRES, E-WV [* EKG revealed sinus rhythm with Q-waves *]),
  (H-TXRES, H-PTMEAS [* salt content and volume of water *]),
  (H-PTFUNC, H-PTPART [* sensory and motor exam *]),
  (H-PTFUNC, H-TTCOMP [* deficits in mobility and self-care *]),
  (H-PTFUNC, H-TXCLIN
     [* deep tendon reflexes, motor and sensory exam are intact *]),
  (H-PTPART, H-PTAREA, H-PTSPEC),
  (H-PT, H-RECORD),
  (H-PT, H-FAMILY [* according to the patient and his mother *]),
  (H-PTDESCR, H-FAMILY [* no change in Social Hx or Family Hx *]),
  (H-DIAG, H-PTDESCR, H-INDIC, H-RESULT, H-TXRES, H-ORG,
     H-RESP, H-DESCR, H-NORMAL 
     [* normal left vein H-NORMAL but occlusion H-INDIC of distal RCA *]),
  (H-INDIC, H-PTLOC
     [* chest pain unassociated with SOB or radiation *]),
  (H-RESP, H-TTGEN, H-DIAG, H-TTMED
     [* pt's condition, instructions, diagnosis and medications *]),
  (H-INDIC, H-TXCLIN,
     H-RESULT [* pain profile, PE, normal lactate *]),
  (H-TTMED [* allergic to penicillin *], H-DIAG, H-CHEM, H-TXVAR,
     H-DIET
     [* denies reaction to bee stings, latex, iodine or shellfish *]),
  (H-DIAG, H-MODAL [* assessment and plan will be... *]),
  (H-DIAG, H-TTSURG [* status post MI, CABG *],
     H-RESULT [* including CABG and ejection fraction of 20 % *]),
  (H-VTEST, H-TXPROC [* blood sampling and biopsy *]),
  (H-TXCLIN, H-TXPROC [* ... exam and stress test *]),
  (H-TXCLIN, H-TTSURG [* refused surgery or workup *]),
  (H-TXCLIN, H-TTGEN [* examination and consult *]),
  (H-TMLOC, H-TXCLIN, H-TTGEN
     [* history, exam, and medical decision making *]),
  (H-TXPROC, H-RESP [* pleased with procedure and recuperation *]),
  (H-TXPROC, H-TXVAR [* no new ECG or enzyme changes *]),
  (H-TMLOC, H-TXPROC, H-TXRES
     [* his history, exercise tolerance test and EKG changes *]),
  (H-DEVMED, H-TXPROC [* his battery pack and leads *]),
  (H-DEVMED, H-TTGEN [* inhaler and peak flow self-monitoring *]),
  (H-DEVMED, H-TTMED [* IV steroids and nebulizers *]),
  (H-TXSPEC, H-TXVAR,H-TXPROC,H-PTSPEC,H-PTPART,H-ORG[,H-RESULT]),
  (H-TTCOMP, H-TTMED, H-TTSURG[, H-TTGEN, H-DEVMED]),
  (H-TTCOMP, H-TTGEN, H-TXPROC
     [* hospitalization, oxygenation, monitoring *]),
  (H-TTCOMP, H-TTSURG, H-DEVMED [* ...therapy, angioplasty, stent *]),
  (H-TTCOMP, H-INST [* physical therapy and nursing Home Health *]),
  (H-TTCOMP, H-DIET [* hydration and nutrition are adequate *]),
  (H-TTSURG, H-TXPROC 
            [* coronary angiography and cardiac catheterization *]),
  (H-TTSURG, H-DIAG [* left hip arthroplasty and Perth's disease *]),
  (NTIME1, NTIME2 [* last week and again yesterday *]),
  (H-TMBEG, H-CHANGE, H-TMEND, H-TMLOC, H-POST,
     H-CHANGE-MORE, H-CHANGE-LESS, H-CHANGE-SAME),
  (H-TMREP, H-TMDUR [* prolonged and desynchronized *]),
  (H-AMT, H-DESCR [* in severity and frequency *]),
  (NSENT1, NSENT2, NSENT3),
  (NSENT1,
     H-INDIC [* In view of the chest pain and the fact that... *]),
  (H-TTMED, H-CHEM, H-PTFUNC,
     H-TTCOMP [* relieved by drugs and sleep *]),
  (H-TMLOC, H-TXPROC [* by history and electrocardiagrams *]),
  (H-DESCR, H-PTLOC [* nondermatomal and poorly localizing *]),
  (H-TXCLIN, H-TXVAR [french]).
LIST MAJOR-EQUIV-CLASSES =
   H-CHEM, H-ORG,
   H-PT, H-PTAREA, H-PTLOC, H-PTMEAS, H-PTPART, H-PTFUNC, H-PTSPEC,
   H-DIAG, H-INDIC, H-RESP, H-DESCR, H-NORMAL,
   H-TTSURG, H-TTCOMP, H-TTGEN, H-TTMED, H-TTMODE,
   H-TXSPEC, H-TXVAR, H-TXPROC, H-TXRES, H-TXCLIN.
* WITH-EQUIV-CLASSES
*  used in T-PSEUDO-CONJ-WITH series for 'with' that acts
*  like a conjunction.
*  E.g. Chest examination revealed extensive wheezing *with* prolonged
*       expiratory phase .
*  where 'prolonged expiratory phase' is also revealed by chest exam.
LIST WITH-EQUIV-CLASSES =
  (H-INDIC, H-DIAG, H-TXRES, H-RESULT, H-NORMAL,
   E-WV, E-INTVL, E-AX).
LIST WITH-RESULT = H-RESULT.
* HUMAN-LIST
*     USED IN $NHUMAN-CHK; CONTAINS LIST OF HUMAN SUBCLASSES FOR
*     THE SUBLANGUAGE, ADDED ONTO WORDS WHICH ARE ONLY NHUMAN, AND
*     NOT OTHERWISE SUBCLASSIFIED (E.G., 'PERSON', OR 'SHE').
LIST HUMAN-LIST =
     H-FAMILY, H-INST, [H-DOCTOR,] H-PT.
LIST SIGN-SYMP = H-INDIC, H-DIAG.
* LIST NON-PRONOUN-CLASSES
*    CLASSES IN SUBLANGUAGE-ATTS THAT ARE NOT PRONOUNS.
* -- THIS IS CURRENTLY USED FOR PRONOUN-ANTECEDENT RESOLUTION.
*    MAY 7, 2000
LIST NON-PRONOUN-CLASSES =
     H-VTEST, H-VTENSE, [H-TRIGGER,] H-TRANSP, [H-TTFREQ,]
    [H-STATUS,] H-SHOW, H-ETHNIC, H-PTVERB, [H-PTPALP,]
     H-PTLOC, H-PTDESCR, [H-OCCASION,] H-OBSERVE,
     H-NULL, [H-NOCLASS, H-LABRES, H-INTOX, H-HOSP,]
    [H-GROW,] H-EVID, [H-EVENT, H-DOCTOR, H-DIMENSION,]
     H-DESCR, [H-CELLTYPE,] H-CHEM, H-CONN, [H-BEH,]
     H-BECONN, H-AMT, E-WV, [E-INTVL, E-LEAD, E-AX,] VHAVE, VDO, VBE,
     QNUMBER, NUNIT, [NULLNCLASS,] MASC, FEM,
       [* Time antecedents will be done separately *]
     H-TMREP, H-TMPREP, H-TMDUR,
     H-TMLOC, H-TMEND, H-TMBEG,
     NTIME2, NTIME1.
LIST TVO-SUBJECT = H-INST, H-PT.
* NEG-LIST
*     CONTAINS NEGATIVE ATTRIBUTE H-NEG FOR COMPUTED-ATTRIBUTE.
LIST NEG-LIST = H-NEG.
* NO-REP-LIST
*     CONTAINS 'NO-REP' TO DETERMINE IF QNUMBER SHOULD CAUSE COMPUTED
*     ATTRIBUTE FOR CERTAIN WORDS.
LIST NO-REP-LIST = NO-REP.
* SIG-CLASS
*     LIST OF SIGNIFICANT MEDICAL SUBCLASSES.  IF WORD HAS MORE THAN
*     ONE OF THESE, IT IS A HOMOGRAPH, EXCEPT FOR H-CHANGE, [H-STATUS]
*     COMBINATION.
LIST SIG-CLASS =
      EMPTY-SET, [H-BEH,]
      H-CHEM, [H-NOCLASS,]
      H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS, H-CHANGE-SAME,
      H-DIAG, H-EVID, [H-GROW,]
      H-INDIC, H-MODAL, H-NEG, H-NORMAL,
      H-PTAREA, H-PTDESCR, H-PTFUNC, H-PTLOC, H-PTMEAS, H-PTPART,
      H-RESP, [H-STATUS,]
      H-TMEND, H-TMBEG,
      H-TTSURG, H-TTCOMP, H-TTGEN, H-TTMED,
      H-TXCLIN, H-TXPROC, H-TXRES, H-TXSPEC, H-TXVAR,
      H-TRANSP,
      NUNIT.
* MAJOR-SEL-CLASS
*   INDICATES THE MAJOR SUBLANGUAGE CLASSES WHICH IF
*   PARTICIPATING IN A FAILED SELECTION LIST, THE
*   ENTIRE SENTENCE IS REJECTED. [980218]
LIST MAJOR-SEL-CLASS =
   [H-NEG, H-MODAL,]
    H-CHEM, [H-CELLTYPE, H-NOCLASS,] H-ORG,
    H-PT, H-PTAREA, H-PTLOC, H-PTMEAS, H-PTPART, H-PTFUNC, H-PTSPEC,
    H-DIAG, H-INDIC, H-RESP, H-DESCR, H-NORMAL,
    H-TTSURG, H-TTCOMP, H-TTGEN, H-TTMED, H-TTMODE,
    H-TXSPEC, H-TXVAR, H-TXPROC, H-TXRES, H-TXCLIN.
* MOD-CLASS
*    LIST OF MODIFIER SUBCLASSES - WORDS WITH THESE SUBCLASSES MAP
*    INTO MODIFIER FIELDS IN THE FORMATS.
LIST MOD-CLASS =
       H-AMT, H-TMBEG, H-TMEND, H-MODAL, H-EVID, H-NEG, H-TMREP,
       H-TMDUR, H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS, H-CHANGE-SAME,
       H-TRANSP, NUNIT, H-PTAREA, H-PTPART, H-PTLOC,
       H-CHANGEMK, QNUMBER, NTIME1, NTIME2, H-VTENSE, H-TMLOC.
LIST CONN-TYPE-LIST = CONN-TYPE.
LIST CHANGE-LIST = H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS, H-CHANGE-SAME.
* H-PTSPEC-LIST
LIST H-PTSPEC-LIST = H-PTSPEC.
LIST H-TXVAR-LIST = H-TXVAR.
LIST TESTRES-LIST = H-TXRES.
LIST VSENT-LIST = VSENT1,VSENT2,VSENT3.
LIST NONHUMAN-LIST = NONHUMAN.
LIST NUNIT-LIST = NUNIT.
LIST QNUMBER-LIST = QNUMBER.
* AREA-LIST
*   USED BY T-FIXUP-ATOMS TO REMOVE H-PTAREA FROM
*   LIST ALSO CONTAINING H-PTPART- THIS IS DONE TO DETERMINE
*   WHETHER OR NOT WORD WITH H-PTPART AND H-PTAREA HAS ANOTHER SIG>
*   SUBCLASS AND THEREFORE IS A HOMOGRAPH.
LIST AREA-LIST = H-PTAREA.
* CONNECTIVE-LIST CONTAINS LIST OF WORD CLASSES TO BE TREATED AS
*     CONNECTIVES.
LIST CONNECTIVE-LIST =
      H-CONN, H-BECONN, CONJ-LIKE.
* NULLOBJ-LIST IS USED BY SELECTION TSEL-NULLOBJ WHEN OBJECT IS
*      NULLOBJ.
LIST NULLOBJ-LIST = NULLOBJ .
* SENTOBJ-LIST IS USED BY SELECTION TSEL-SENTOBJ FOR SENTENTIAL OBJ
LIST SENTOBJ-LIST = SENTOBJ .
* TIME-MOD-CLASSES
*      LIST OF SUBCLASSES WHICH FORMAT INTO TIME OR MODIFIER SLOTS.
LIST TIME-MOD-CLASSES =
      H-TMBEG, H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS, H-CHANGE-SAME,
      H-TMEND, H-EVID, H-MODAL,
      H-NEG, H-OBSERVE, H-TMDUR, H-TRANSP,
      H-TMLOC, NTIME1.
* PN-NULLOBJ-LIST IS USED IN TSEL-VEN-SUBJ TO CHECK THAT SURFACE SUBJECT
*     IS UNDERLYING OBJECT; THIS IS TRUE ONLY IF PASSOBJ = PN OR NULLOBJ
LIST PN-NULLOBJ-LIST = PN, NULLOBJ.
LIST NULLN-LIST = NULLNCLASS.
* BE-OR-SHOW-LIST IS USED BY TSEL-OBJ-VS FOR 'BE' OR 'SHOW'
* IN BESHOW.
LIST BE-OR-SHOW-LIST = VBE, H-SHOW .
* CONJSEL IS USED IN $WITH-CONJ OF TSEL-P-N TO MARK CONJUNCTION-LIKE
*   USE OF 'WITH', AS IN 'SWELLING WITH TENDERNESS'.
LIST CONJSEL = CONJ-LIKE.
* BECONN-LIST IS USED IN TSEL-VERB-SUBJ TO MARK CONNECTIVE-LIKE USE
*  OF 'BE' AS IN 'FOOT IS A BODYPART'
LIST BECONN-LIST = H-BECONN  .
* CONN-LIST IS USED IN TSEL-VERB-OBJ TO MARK VERBS WHICH ARE H-CONN .
LIST CONN-LIST = H-CONN .
* BEREP-LIST IS USED IN TSEL-VERB-SUBJ TO SET UP A LIST SIMILIAR
* TO LIST BE-S-O BUT HAVING BEREP AS SUBCLASS IN PLACE OF VBE.
LIST BEREP-LIST = BEREP .
* WHERE-LIST
*     LISTS ALLOWABLE HOSTS FOR WHERE + ASSERTION RELATIVE CLAUSE
LIST WHERE-LIST = EMPTY-SET.
LIST NAME-N-PQUANT = 'N-PQUANT'.
LIST WORD-POS-LIST =
            W001, W002, W003, W004, W005, W006, W007, W008, W009,
      W010, W011, W012, W013, W014, W015, W016, W017, W018, W019,
      W020, W021, W022, W023, W024, W025, W026, W027, W028, W029,
      W030, W031, W032, W033, W034, W035, W036, W037, W038, W039,
      W040, W041, W042, W043, W044, W045, W046, W047, W048, W049,
      W050, W051, W052, W053, W054, W055, W056, W057, W058, W059,
      W060, W061, W062, W063, W064, W065, W066, W067, W068, W069,
      W070, W071, W072, W073, W074, W075, W076, W077, W078, W079,
      W080, W081, W082, W083, W084, W085, W086, W087, W088, W089,
      W090, W091, W092, W093, W094, W095, W096, W097, W098, W099,
      W100, W101, W102, W103, W104, W105, W106, W107, W108, W109,
      W110, W111, W112, W113, W114, W115, W116, W117, W118, W119,
      W120, W121, W122, W123, W124, W125, W126, W127, W128, W129,
      W130, W131, W132, W133, W134, W135, W136, W137, W138, W139,
      W140, W141, W142, W143, W144, W145, W146, W147, W148, W149.
* FORMAT-EQUIV-CLASS
LIST FORMAT-EQUIV-CLASS =
       ([H-LABRES,] H-INDIC, H-DIAG, H-DESCR, H-RESULT),
       (H-TXVAR, H-PTFUNC, [H-GROW,] H-TXCLIN, H-PTMEAS).
*include emregtbl_100.txt
LIST H-AGE-LIST = H-AGE.
LIST DOCTOR-LIST = H-INST [H-DOCTOR].
LIST PT-FAM = H-PT, H-FAMILY.
LIST CHANGEMK-LIST = H-CHANGEMK.
LIST REPT-LIST =
     [H-TTGEN,] H-PTVERB [H-TTCOMP, H-TXPROC, H-TTCHIR].
LIST OPERATOR-LIST = [NSENT1,NSENT2,NSENT3,ASENT1,ASENT3,VSENT1,]
                     VSENT2,VSENT3,VSENT4.
LIST TRANSP-LIST =
     H-AMT, H-TMBEG, H-CHANGE, H-CHANGE-MORE, H-CHANGE-LESS,
     H-CHANGE-SAME, H-TMEND, H-EVID,
     H-MODAL, H-NEG, H-OBSERVE, H-TMDUR, H-TMREP, H-TRANSP.
LIST TIME-MOD-NODES =
     H-TTGEN,H-PTVERB,H-TTCOMP,H-VTEST,H-CONN,H-TXSPEC,H-TXVAR,[H-GROW,]
     H-TXCLIN, H-PTFUNC, H-PTMEAS, H-TXRES, H-INDIC,H-TXPROC,
    [H-BEH,] H-PTDESCR, H-DIAG, VBE, VHAVE, H-SHOW, H-TTMED,H-ORG,
     H-INST, [H-DOCTOR,] H-NORMAL, H-AMT, H-NEG, NUNIT, QNUMBER,
     H-RECORD, H-RESULT, H-BECONN.
LIST TIME-ADVERB-LIST = TIME-ADVERBIAL.
* MODAL-LIST
*    CONTAINS MODAL ATTRIBUTE H-MODAL FOR CONSTRUCTION OF SELECT-ATT.
LIST MODAL-LIST = H-MODAL.
LIST GENDER-LIST = MASC, FEM.
LIST NUMBER-LIST = SINGULAR, PLURAL.
LIST PRO-HUMAN-LIST = NHUMAN, NONHUMAN.
LIST CONN-ARGS-CLASSES =
     (H-DIAG, H-PTDESCR, H-INDIC, H-RESULT, H-TXRES,
      [H-ORG, H-STATUS,] H-RESP),
     (H-TXCLIN, H-PTFUNC, H-PTPART),
     (H-TTCOMP, H-TTMED, H-TTSURG, H-TTGEN),
     (H-TTSURG, H-TXPROC).
* END-OF-SELECTION-LISTS USED BY SUBLANGUAGE SELECTION RESTRICTIONS
*
* TYPE LISTS
*
TYPE ADJSET =
     LA, LCDA, LCDN, LCDVA, LCS, LD, LDATE, LN, LNAME, LP, LPRO, LQ,
     LT, LTIME, LV, LVSA, LW, LAUX,
     RA, RA1, RD, RDATE, RN, RNAME, RQ, RV, RW, RWV,
     SA,
        [** CONN GRAMMAR NODES **]
     LCONN, RCONN, RP.
TYPE ADJSET1 =
     AND-ORSTG, ANDSTG, ASSTG, [AS-WELL-AS-STG,] BOTHSTG, BUTSTG,
     COLONSTG, COMMASTG, DASHSTG, EGSTG, EITHERSTG, ESPECIALLY-STG,
     LA, LCDA, LCDN, LCDVA, LCS, LD, LDATE, LN, LNAME, LP, LPRO, LQ,
     LT, LV, LVSA, LW, LAUX,
     NEITHERSTG, NORSTG, ORSTG, PARENSTG, PARTICULARLY-STG,
     QNREP, QUOTESTG,
     RA, RA1, RD, RDATE, RN, RNAME, RQ, RV, RW, RWV,
     SA,
     THANSTG, TOSTG, VERSUSSTG,
        [** CONN GRAMMAR NODES **]
     LCONN, RCONN, RP.
TYPE RNOPTSET   = ADJINRN, PDATE, PN, PQUANT, VENPASS, TOVO , TOVO-N,
                  PWHS, LDR, [NPWHS,] DS, APPOS, PERUNIT, PDOSE,
                  PVINGO, VINGO, WHS-N, WHENS, WHOSES, PAREN-RN, BPART.
TYPE CONJ-NODE  = ANDSTG, ANDORSTG, ASWELLASSTG, BUTSTG, COMMASTG,
                  INADDITIONTOSTG, INCLUDINGSTG, ORSTG, NORSTG, PARTICULARLYSTG,
                  PLUSSTG, WITHSTG, THANSTG,
                  [FRENCH] DMQSTG, NISTG, PUISSTG, AINSIQUESTG.
TYPE SCOPE-NODE = BOTHSTG, EITHERSTG, NEITHERSTG, NISTG.
TYPE SP-NODE    = ANDSTG, ANDORSTG, ASWELLASSTG, BUTSTG, COMMASTG,
                  INADDITIONTOSTG, INCLUDINGSTG, ORSTG, NORSTG, PARTICULARLYSTG,
                  PLUSSTG, WITHSTG, THANSTG,
                  [FRENCH] DMQSTG, NISTG, PUISSTG, INTSTG, AINSIQUESTG.
TYPE LADJSET=
     LA, LCDA, LCDN, LCDVA, LCS, LDATE, LN, LNAME, LP, LPRO, LQ,
     LT, LTIME, LV, LVSA, LW, LAUX,
         [** CONN GRAMMAR NODES **]
     LCONN, LD.
TYPE LXR =
     LAR, LAR1, LDATER, LDR, LNAMER, LNR, LNSR, LQR, LQNR, LTR,
     LTVR, LVENR, LVINGR, LVR, TENSE, VERB, LLEADR [ekg], LWVR [ekg],
        [** CONN GRAMMAR NODES **]
     LCONNR, LPR.
TYPE MINLIST    = PN, D, SUB1, NSTGT, INT, PDATE, TOVO, PVO.
TYPE N-OBJ-IN-STR = [N OR PN OBJECTS OF TYPE STRING]
     ADJN, DP2, DP3, DP4, DP1PN, DP2PN, DP3PN, DP4PN, NA, NASOBJBE,
     ND, NN, NPDOSE, NPN, NPSNWH, NPSVINGO, NPVINGO, NPVINGSTG,
     NSNWH, NTHATS, PN, PNN, PNSNWH, PNTHATS, PNTHATSVO, PNVINGSTG,
     VINGSTGPN, PNX2.
TYPE PSTRING =
     PD, PN, PQUANT, PVINGSTG, PSVINGO, PSNWH, PVINGO.
* MED TYPES.
TYPE ADJAUX = RNWH, NSTGT, CSSTG, RSUBJ, RNSUBJ, SAWH, SN, SNWH.
TYPE N-OMITTING-WH-STRING =
     FORTOVO-N, SAWHICHSTG, S-N, THATS-N, TOVO-N, WHATS-N, WHEVERS-N,
     WHNQ-N, WHNS-N, WHQ-N, WHS-N.
* MED UPDATE
TYPE PDPOBJECT =
     DP1, DP2, DP3, DP4, DPSN,
     DP1PN, DP2PN, DP3PN, DP4PN, DP1P,
     NPN, NPSNWH, NPSVINGO, NPVINGO, NPVINGSTG,
     P1, PN, PNN, PNX2, PNTHATS, PNTHATSVO, PNSNWH, PNVINGSTG,
     PSNWH, PSVINGO, PVINGO, PVINGSTG,
     VINGSTGPN.
TYPE PN-OMITTING-WH-STG =
     PWHNQ-PN, PWHNS-PN, PWHQ-PN, PWHS-PN.
TYPE RADJSET=
     RA, RA1, RD, RDATE, RN, RNAME, RNOPTS, RQ, RT, RV, RW,
        [** CONN GRAMMAR NODES **]
     RCONN, RP, RWV [ekg], RWVOPTS [ekg], RLEAD [ekg].
TYPE RECURSIVE  = TPOS, ADJADJ, NNN, RN, SA, LDR.
TYPE REPETITIVE = RN, RV.
TYPE STGSEG     = ASSERTION, TOVO, VINGO, QN, PVO, SVO.
TYPE STRING =
     ADJINRN, ADJN, APPOS, ASOBJBE, ASSERTION,
     BEINGO, BPART, C1SHOULD, CPDNUMBR,
     DP1, DP2, DP3, DP4, DP1P, DP1PN, DP2PN, DP3PN, DP4PN, DPSN,
     [ETCSTG,] FORTOVO, FORTOVO-N,
     HOWQASTG, HOWQSTG,
     IMPERATIVE,
     LN,
     NA, NASOBJBE, ND, NN, NPN, NPSNWH, NPSVINGO, NPVINGO, NPVINGSTG,
     NQ, NSNWH, NSTGT, NSVINGO, NTHATS, NTOBE, NUMBRSTG, NVSA, NTOVO,
     OBES, OBJBESA, PTIME [* 09/13/2001 *],
     P1, PA, PD, PDATE, PN, PNN, PNSNWH, PNTHATS, PNTHATSVO, PNVINGSTG,
     PROSENT, PQUANT, PSNWH, PSVINGO, PVINGO, PVINGSTG, PWHERES, PWHNQ,
     PWHNQ-PN, PWHNS, PWHNS-PN, PWHQ, PWHQ-PN, PWHS-PN, PARENSTG,
     Q-ASSERT, Q-CONJ, Q-INVERT, Q-PHRASE, QN, QNS, Q-OF, QPERUNIT,
     S-N, SASOBJBE, SAWHICHSTG, SENTENCE, SOBJBE, SOBJBESA, STOVO-N,
     SUB0, SUB1, SUB2, SUB3, SUB4, SUB5, SUB6, SUB7, SUB9, SUB11,
     SVEN, SVINGO, SVO,
     THATS, THATS-N, TOBE, TOVO, TOVO-N, TSUBJVO,
     VENO, VENPASS, VINGO, VINGOFN, VINGSTGPN, VO,
     WHATS-N, WHENS, WHERES, WHETHS, WHETHTOVO, WHEVERS-N, WHNQ-N,
     WHNS-N, WHQ, WHQ-N, WHS-N,
     YESNOQ,
          [*** FRAGMENT GRAMMAR NODES ***]
     ASTGF, ASTGP, NSTGP, [* snopath *]
     BESHOW, FRAGMENT, MEDDOSE, NSTGF, NPDOSE, ONESENT, PDOSE,
     TVO, NPVO, PVO,
     PWHS, SUB8, WHOSES, PNX2
          [*** FRENCH ***]
     [ENVINGO, FTIME, NPWHS, NVINGO, PNPVO, PNVO, PVO-N, SUB10].
TYPE TRANSMITTING-OBJ-STG =
      ASSERTION, C1SHOULD, DP2, FORTOVO-N, NA, ND, NN, NPN, NPSNWH,
      NPSVINGO, NPVINGO, NPVINGSTG, NTHATS, PN, PNTHATSVO,
      PSVINGO, PVINGO, PVINGSTG, TOVO, SASOBJBE, SOBJBE, SVEN, SVO,
      THATS, VENO, VENPASS, VINGO, WHETHS,
      PVO.
TYPE VERBAL    = LVR, LVENR, LVINGR, VERB.
* TRANFORMATION TYPES.
TYPE STATEMENT-EQV-NODES =
       [* Nodes which are equivalent to a format statement *]
     NPWHS, PVO, PVO-N, PWHS, QUANT, VINGO, WHENS, WHS-N.
*RESTR
* GRAMMAR SECTION
* ********** **************************************** **********
*                                                                *
*                          ROUTINES                              *
*                                                                *
* ********** **************************************** **********
*
ROUTINE COEL1-(X) =
  [* GIVEN THAT X AND Y ARE ELEMENTS OF SOME STRING. COEL1- ]
  [* STARTS AT Y AND GOES LEFT OR RIGHT TO X. HOWEVER IF X ]
  [* IS IN A STRING SEGMENT COEL1- WILL NOT GO TO X (COELEMENT ]
  [* ROUTINE DOES IT).IN A SITUATION X1Y1 CONJ X2Y2, COEL1 ]
  [* STARTING AT Y2 WILL GO TO X2. AND IN A SITUATION XY1 CONJ ]
  [* Y2 COEL1- STARTING AT Y2 WILL GO TO X.]
    EITHER $LEFT-OR-RIGHT
    OR ITERATE $TO-PRECONJUNCTION-Y UNTIL $LEFT-OR-RIGHT SUCCEEDS.
 $LEFT-OR-RIGHT =
    EITHER DO L (X) OR DO R (X).
 $TO-PRECONJUNCTION-Y =
    EITHER $PRECONJ OR $ASSIGN-PRECONJELEM.                      (GLOBAL)
 $PRECONJ =
    THE PRESENT-ELEMENT- HAS NODE ATTRIBUTE PRECONJELEM.         (GLOBAL)
 $ASSIGN-PRECONJELEM =
    VERIFY $LOCATE-CONJNODE;
    VERIFY $ASSIGN-PRE-AND-POST [PRE-POST-CONJELEM];
    DO $PRECONJ.
 $LOCATE-CONJNODE =
    ASCEND TO Q-CONJ; GO UP; STORE IN X100.
ROUTINE COEL1(X) =
  [* COEL1(X) IS THE STACKING COUNTERPART OF COEL1-. IN A   ]
  [* SITUATION (X1 CONJ X2)Y , STARTING AT Y COEL1 GOES TO  ]
  [* X1 AND STACKS X2. IN A SITUATION X1Y1 CONJ X2Y2, COEL1 ]
  [* STARTING AT Y1 WILL GO TO X1 AND WILL NOT STACK X2. IF ]
  [* THE PARSE TREE IS X(Y1 CONJ Y2), STARTING AT EITHER Y1 ]
  [* OR Y2 COEL1 GOES TO X.]
    STORE IN X200;
    EITHER $LEFT-OR-RIGHT
    OR ITERATE $TO-PRECONJUNCTION-Y UNTIL $LEFT-OR-RIGHT SUCCEEDS.
 $LEFT-OR-RIGHT =
    EITHER $LEFT-TO-X OR $RIGHT-TO-X.
 $LEFT-TO-X =
    DO L (X); DO STACK-FOR-LEFT.
 $RIGHT-TO-X =
    DO R (X); DO STACK-FOR-RIGHT.
ROUTINE COELEMENT-(X) =
  [* GIVEN THAT X AND Y ARE ELEMENTS OF SOME STRING COELEMENT- ]
  [* STARTS AT Y AND GOES TO X.  IF X IS IN A STRING SEGMENT   ]
  [* COELEMENT- WILL GO ONE LEVEL BELOW THE STRING SEGMENT TO  ]
  [* FIND X.]
    EITHER DO COEL1-(X) OR $STRING-SEGMENT.
 $STRING-SEGMENT = DO COEL1-(STGSEG); DO ELEMENT-(X).
ROUTINE COELEMENT(X) =
  [* THE STACKING COUNTERPART OF COELEMENT-. IF X IS IN A ]
  [* STRING SEGMENT SEG,COELEMENT WILL FIRST GO TO SEG AND ]
  [* STACK THE CONJUNCTS OF SEG IF THERE ARE ANY. COELEMENT ]
  [* WILL THEN GO TO X ONE LEVEL BELOW SEG.  IF X HAS ANY ]
  [* CONJUNCTS THEY WILL BE STACKED. IF X IS NOT IN A STRING ]
  [* SEGMENT THEN COELEMENT IS THE SAME AS COEL1.]
    EITHER DO COEL1(X) OR $STRING-SEGMENT.
 $STRING-SEGMENT = DO COEL1(STGSEG); DO ELEMENT(X).
ROUTINE CORE- =
  [* LOOKS FOR AN ATOMIC NODE OR STRING NODE WHICH IS EITHER ]
  [* THE NODE CURRENTLY BEING 'LOOKED AT' OR ONE THAT LIES ]
  [* BELOW THIS NODE. THE DESCENT DOES NOT PASS THROUGH NODES ]
  [* ON THE LIST ADJSET1.]
    DO $CORE-PATH.                                   (GLOBAL)
 $CORE-PATH =
    ONE OF $AT-ATOM,
           $DESCEND-TO-ATOM,
           $DESCEND-TO-STRING IS TRUE.
 $AT-ATOM = TEST FOR ATOM.
 $DESCEND-TO-ATOM =
    IF PRESENT-ELEMENT- IS APOS OR NPOS
    THEN GO DOWN;
    DESCEND TO ATOM NOT PASSING THROUGH ADJSET1.
 $DESCEND-TO-STRING =
    [* take consideration of N under QN out of core- NVAR:QN *]
    DESCEND TO STRING NOT PASSING THROUGH ADJSET1;
    IF TEST FOR LN
    THEN $RIGHT-TO-CORE.
 $RIGHT-TO-CORE =
    ITERATE GO RIGHT UNTIL TEST FOR CONJ-NODE FAILS;
    DO CORE- .
 $QN-CORE =
    GO DOWN;
    ITERATE GO RIGHT UNTIL TEST FOR N SUCCEEDS.
ROUTINE CORE LOCAL(XX-CORE) =
  [* THE CORE ROUTINE IS THE STACKING COUNTERPART OF CORE-. ]
  [* THE CORE MAY HAVE SEVERAL VALUES BECAUSE OF CONJUNCTION. ]
  [* IF AN ELEMENT X1 OF AN LXR TYPE STRING HAS CONJUNCTS X2, ]
  [* X3, THEN THE CORE OF X2, X3, ETC. IS STACKED.]
    DO $CORE-PATH;
    VERIFY $TO-X-POS-IN-LXR.
 $TO-X-POS-IN-LXR =
    EITHER $ASCNT OR TRUE;
    DO $STACK-CORE-TEST.
  $ASCNT = GO UP;
           TEST FOR AVAR OR NVAR OR QVAR OR VVAR OR LEADVAR OR
                    WVVAR OR DATEVAR OR HEADCONN OR LNAMER OR NQ;
           IF PRESENT-ELEMENT- IS LNAMER OR NQ
           THEN IMMEDIATE-NODE OF IMMEDIATE-NODE IS NVAR.
 $STACK-CORE-TEST = IF $POSTCONJ THEN $STACK-CONJUNCTS.
 $POSTCONJ = THE PRESENT-ELEMENT- HAS NODE ATTRIBUTE POSTCONJELEM.
 $STACK-CONJUNCTS = VERIFY ITERATE $STACK-CORES.
 $STACK-CORES = DO $POSTCONJ;
                STORE IN XX-CORE;
                DO $CORE-PATH;
                STACK;
                GO TO XX-CORE.
ROUTINE DOWN1-(X) =
  [* TESTS WHETHER X IS AN ELEMENT WHICH IS ONE LEVEL BELOW THE ]
  [* NODE THE PROGRAM IS CURRENTLY 'LOOKING AT'.]
    GO DOWN;
    ITERATET GO RIGHT UNTIL TEST FOR X SUCCEEDS.
ROUTINE DOWN1(X) =
  [* DOWN1 IS THE STACKING COUNTERPART OF DOWN1-. IF X HAS ]
  [* CONJUNCTS THEY ARE PLACED ON A RE-EXECUTION STACK.]
    DO DOWN1-(X); DO $STACK-TEST.
 $STACK-TEST = IF $POSTCONJ THEN $STACK-CONJUNCTS.
 $STACK-CONJUNCTS = VERIFY ITERATE $STACK-X.
 $STACK-X = DO $POSTCONJ; STACK.
ROUTINE ELEMENT-(X) =
  [* TESTS WHETHER X IS AN ELEMENT ONE LEVEL BELOW THE NODE THE ]
  [* PROGRAM IS CURRENTLY 'LOOKING AT'. IF NOT, AND A STRING ]
  [* SEGMENT IS ONE LEVEL BELOW THE CURRENT NODE THE SEARCH ]
  [* CONTINUES ONE LEVEL BELOW THE STRING SEGMENT NODE.]
    EITHER DO DOWN1-(X) OR $STRING-SEGMENT.
 $STRING-SEGMENT = DO DOWN1-(STGSEG); DO DOWN1-(X).
ROUTINE ELEMENT(X) =
  [* ELEMENT(X) IS THE STACKING COUNTERPART OF ELEMENT-(X). IF ]
  [* ELEMENT X GOES TO X1 AND X1 HAS CONJUNCTS X2,X3,ETC THEN X2, ]
  [* X3, ETC ARE PLACED ON THE RE-EXECUTION STACK.IF X1 IS ]
  [* IN A STRING SEGMENT S AND S HAS CONJUNCTS THEN THEY   ]
  [* ARE PLACED IN THE RE-EXECUTION STACK.]
    EITHER DO DOWN1(X) OR $STRING-SEGMENT.
 $STRING-SEGMENT = DO DOWN1(STGSEG); DO DOWN1(X).
ROUTINE FOLLOWING-ELEMENT- =
  [* GOES RIGHT TO THE FIRST NODE WHICH IS NOT SP-NODE.]
    DO $RIGHT-TO-HOST [HOST-ELEMENT].
ROUTINE FOLLOWING-ELEMENT =
  [* FOLLOWING-ELEMENT IS THE STACKING COUNTERPART OF ]
  [* FOLLOWING-ELEMENT-.  IT GOES TO THE ]
  [* FOLLOWING-ELEMENT- AND STACKS IT'S CONJUNCTS.]
    STORE IN X200;
    DO $RIGHT-TO-HOST [HOST-ELEMENT];
    DO STACK-FOR-RIGHT.
ROUTINE HOST- =
  [* GOES TO THE CORE OF HOST-ELEMENT ]
    CORE- OF HOST-ELEMENT EXISTS.
ROUTINE HOST =
    EITHER TEST FOR ADJSET OR ASCEND TO ADJSET;
    ONE OF $IN-LADJSET, $IN-RADJSET, $IN-RNSUBJ;
    DO $CORE-PATH .
 $IN-LADJSET =
    DO $AT-LADJ [HOST-ELEMENT];
    DO STACK-FOR-RIGHT.
 $IN-RADJSET =
    DO $AT-RADJ [HOST-ELEMENT];
    DO STACK-FOR-LEFT.
 $IN-RNSUBJ =
    DO $ATRNSUBJ[HOST-ELEMENT];
    DO $STACK-TEST [STARTAT].
ROUTINE HOST-ELEMENT =
  [* STARTS AT OR ASCENDS TO LADJSET OR RADJSET OR RNSUBJ Y. ]
  [* IF Y IS OF TYPE RADJSET OR LADJSET IT GOES TO THE CORE ]
  [* ELEMENT X (TO X IN AN LXR TYPE NODE). IF Y IS RNSUBJ IT ]
  [* ASCENDS TO SA AND THEN GOES TO COELEMENT SUBJECT. ]
  [* ** FRENCH CHANGE IN $AT-RADJ ** *]
    EITHER TEST FOR ADJSET OR ASCEND TO ADJSET PASSING THROUGH ADJINRN;
    ONE OF $AT-LADJ, $AT-RADJ, $ATRNSUBJ IS TRUE.
 $AT-LADJ =
    TEST FOR LADJSET;
    STORE IN X200;
    DO $RIGHT-TO-HOST .
 $RIGHT-TO-HOST =
    EITHER $GO-RIGHT-PAST-C
    OR ITERATE $TO-PRECONJUNCTION-Y [COEL1-]
       UNTIL $GO-RIGHT-PAST-C SUCCEEDS.
 $GO-RIGHT-PAST-C = ITERATE GO RIGHT UNTIL TEST FOR SP-NODE FAILS.
 $AT-RADJ =
    EITHER $IN-RN OR $IN-OTHERS;
    STORE IN X200;
    EITHER $RV-TEST OR $LEFT-TO-HOST.
 $IN-RN =
    TEST FOR RN;
    STORE IN X100;
    GO LEFT;
    IF PRESENT-ELEMENT- IS RNOPTS THEN DO $1;
    GO TO X100.
 $1 = GO UP; DO $IN-RN.
 $IN-OTHERS = TEST FOR RADJSET.
 $RV-TEST =
    TEST FOR RV;
    STORE IN X100;
    ONE OF $L-VVAR, $L-V, $L-VING, $L-VEN.
 $L-VVAR = DO L(VVAR).
 $L-V = DO L(V).
 $L-VING = DO L(VING).
 $L-VEN = DO L(VEN).
 $LEFT-TO-HOST =
    EITHER $LEFT-PAST-C OR ITERATE $TO-PRECONJUNCTION-Y [COEL1]
       UNTIL $LEFT-PAST-C SUCCEEDS.
 $LEFT-PAST-C = ITERATE GO LEFT UNTIL TEST FOR SP-NODE FAILS.
 $ATRNSUBJ =
    BOTH VALUE OF SA IS RNSUBJ
    AND PRESENT-ELEMENT- HAS COELEMENT- SUBJECT OR BESUBJ.
* IMMEDIATE(X) ASCENDS TO X. NODES ON THE STRING LIST ARE NOT
*      PASSED THROUGH.IF THIS ROUTINE STARTS AT Q-CONJ IT WILL GO
*       TO THE HOST NODE(UP TWICE FROM TOP OF Q NEST).
*
ROUTINE IMMEDIATE (X) =
       DO $UP-THROUGH-Q;
       ASCEND TO X PASSING THROUGH Q-CONJ.
 $UP-THROUGH-Q = ITERATET $GO-UP-TWICE UNTIL
                 TEST FOR Q-CONJ FAILS.                         (GLOBAL)
 $GO-UP-TWICE = GO UP; GO UP.
ROUTINE IMMEDIATE-NODE- = GO UP.
ROUTINE IMMEDIATE-NODE  =
       EITHER ITERATE $UP-CONJ [IN LEFT-ADJUNCT ROUTINE] OR TRUE ;
       GO UP.
ROUTINE IMMEDIATE-STRING = ASCEND TO STRING ;
       IF PRESENT-ELEMENT- IS Q-CONJ THEN DO IMMEDIATE-STRING.
ROUTINE INITIALRT =
    [* TESTS THAT THERE IS NO NODE TO THE LEFT OF THE ]
    [* NODE THE PROGRAM IS CURRENTLY 'LOOKING AT'.]
    VERIFY NOT DO PREVIOUS-ELEMENT-.
ROUTINE L (X) = ITERATE GO LEFT UNTIL TEST FOR X SUCCEEDS.
ROUTINE LAST-COELEMENT = EITHER ITERATE GO RIGHT OR TRUE.
ROUTINE LAST-ELEMENT- =
  [* GOES TO LEVEL BELOW THE NODE THE PROGRAM IS CURRENTLY      ]
  [* 'LOOKING AT' AND GOES TO THE RIGHTMOST NODE ON THAT LEVEL. ]
    GO DOWN;
    EITHER ITERATE GO RIGHT OR TRUE.
ROUTINE LAST-ELEMENT =
  [* LAST-ELEMENT IS THE STACKING COUNTERPART OF LAST-ELEMENT-. ]
  [* IT GOES TO THE LAST-ELEMENT- AND STACKS IT'S CONJUNCTS.]
    DO LAST-ELEMENT-;
    DO $STACK-TEST [STARTAT].
ROUTINE LEFT-ADJUNCT =
    EITHER $ASCNT [IN CORE] OR TRUE;
    EITHER $LEFT-TO-LADJ OR $UP-AND-LEFT.
 $LEFT-TO-LADJ =
    DO L (LADJSET); EITHER TEST FOR LN OR DO CORE.
 $UP-AND-LEFT =
    ITERATET $UP-CONJ UNTIL $LEFT-TO-LADJ SUCCEEDS
    [GO UP TO CONJUNCTION AND TRY TO GO LEFT].
 $UP-CONJ =
    IMMEDIATE-NODE- IS Q-CONJ; GO UP [WILL BE AT CONJ-NODE].
ROUTINE LEFT-ADJUNCT-POS =
  [* STARTS AT A CORE NODE Y WHERE Y IS AN ELEMENT OF AN LXR ]
  [* TYPE NODE OR FROM THE CORE ASCENDS TO Y IF Y = AVAR, QVAR ]
  [* OR NVAR. IT THEN GOES LEFT UNTIL IT FINDS A NODE WHICH IS ]
  [* ON THE LADJSET LIST. IF IT FINDS LNAME IN NVAR, IT WILL GO ]
  [* FROM LNAME TO LN.]
    EITHER $ASCNT [CORE] OR TRUE;
    STORE IN X200;
    EITHER DO L(LADJSET) OR ITERATE $TO-PRECONJUNCTION-Y [COEL1-]
                               UNTIL DO L(LADJSET) SUCCEEDS.
ROUTINE LOOKAHEAD(X) =
    GO TO THE CURRENT WORD;
    ITERATET GO TO THE NEXT WORD UNTIL DO X SUCCEEDS.
ROUTINE NELEMRT =
  [* CALLED AFTER AN OPERATOR HAS GONE TO THE NTH ELEMENT OF ]
  [* A STRING (IGNORING SPECIAL PROCESS NODES). IT STACKS THE ]
  [* CONJUNCTS OF THAT ELEMENT.]
    DO $STACK-TEST [STARTAT].
ROUTINE NONSEG-IMMSTG =
    DO IMMEDIATE-STRING;
    EITHER $UP-THRU-SEG OR TRUE.
 $UP-THRU-SEG = TEST FOR STGSEG; DO IMMEDIATE-NODE; TEST FOR STRING.
ROUTINE PRESENT-ELEMENT =
    ITERATET $HOST-OF-CONJ UNTIL TEST FOR Q-CONJ FAILS.
  $HOST-OF-CONJ =
       GO UP [TO CONJ-NODE];
       GO UP [TO HOST OF CONJ-NODE].
ROUTINE PRESENT-ELEMENT- = TRUE.
ROUTINE PREVIOUS-ELEMENT- =
  [* PREVIOUS-ELEMENT- SIMPLIFIED THE PREVIOUS-ELEMENT- IN MDPAR6]
    GO LEFT.
ROUTINE R (X) = ITERATE GO RIGHT UNTIL TEST FOR X SUCCEEDS.
ROUTINE RIGHT-ADJUNCT =
    EITHER $ASCNT OR TRUE;
    EITHER $RIGHT-TO-RADJ OR $UP-AND-RIGHT.
 $RIGHT-TO-RADJ=
    DO R(RADJSET); DO CORE.
 $UP-AND-RIGHT  =
    ITERATE $UP-CONJ [IN LEFT-ADJUNCT ] UNTIL $RIGHT-TO-RADJ SUCCEEDS.
ROUTINE RIGHT-ADJUNCT-POS =
      EITHER $ASCNT [CORE] OR TRUE;
      STORE IN X200;
      EITHER DO R(RADJSET)
      OR ITERATE $TO-PRECONJUNCTION-Y [ COEL1- ]
         UNTIL DO R(RADJSET) SUCCEEDS;
      IF PRESENT-ELEMENT- IS RNAME
      THEN AT IMMEDIATE NVAR DO RIGHT-ADJUNCT-POS.
ROUTINE STACK-FOR-LEFT =
  [* STACK-FOR-LEFT ROUTINES WHICH GO FROM ONE ELEMENT OF A ]
  [* STRING TO ANOTHER ELEMENT OF THE STRING BY GOING LEFT CALL ]
  [* STACK-FOR-LEFT TO HANDLE STACKING. GIVEN THAT X AND Y ARE ]
  [* ELEMENTS OF A STRING, STACK-FOR-LEFT IS ASSUMED TO START AT ]
  [* X AFTER THE ROUTINE WHICH CALLED IT GOES FROM Y TO X.  ]
  [* IN STRUCTURE (X1 CONJ X2) Y, STACK-FOR-LEFT WILL STACK X2. ]
  [* IN STRUCTURE X1 Y1 CONJ X2 Y2, STACK-FOR-LEFT WILL NOT STACK X2.]
    IF $POSTCONJ THEN VERIFY $STACK-IF-NO-Y-RGHT.
 $STACK-IF-NO-Y-RGHT =
    IF $POSTCONJ
    @THEN EITHER ALL OF $NO-Y-TO-RIGHT,
                        $DO-STACK,
                        $STACK-IF-NO-Y-RGHT
          OR TRUE.
 $NO-Y-TO-RIGHT =
    NOT ITERATE GO RIGHT UNTIL TEST FOR X200 SUCCEEDS.
 $DO-STACK = STACK.
ROUTINE STACK-FOR-RIGHT =
  [* STACK-FOR-RIGHT ROUTINES WHICH GO FROM ONE ELEMENT OF A ]
  [* STRING TO ANOTHER ELEMENT OF THE STRING BY GOING RIGHT ]
  [* CALL STACK-FOR-RIGHT TO HANDLE STACKING. GIVEN THAT X AND ]
  [* Y ARE ELEMENTS OF A STRING, STACK-FOR-RIGHT IS ASSUMED TO ]
  [* START AT Y AFTER THE ROUTINE WHICH CALLED IT GOES FROM X ]
  [* TO Y.  IN A SITUATION X1 Y1 CONJ Y2, STACK-FOR-RIGHT ]
  [* STARTING AT Y1 WILL STACK Y2. IN A SITUATION X1 Y1 CONJ X2 ]
  [* Y2, STACK-FOR-RIGHT STARTING AT Y1 WILL NOT STACK Y2.]
    IF $POSTCONJ THEN VERIFY $STACK-IF-NO-Y-LEFT.
 $STACK-IF-NO-Y-LEFT =
    IF $POSTCONJ
    @THEN EITHER ALL OF $NO-Y-TO-LEFT,
                        $DO-STACK,
                        $STACK-IF-NO-Y-LEFT
          OR TRUE.
 $NO-Y-TO-LEFT =
    NOT ITERATE GO LEFT  UNTIL TEST FOR X200 SUCCEEDS.
 $DO-STACK = STACK.
ROUTINE STARTAT (X) = EITHER TEST FOR X OR DO DOWN1-(X).
ROUTINE SUBSUMERT(X) LOCAL(X150) =
  [* SEARCHES FOR A WORD OF GIVEN CLASS (AND SUBCLASS) WHICH ]
  [* IS MATCHED TO ANY ATOMIC NODE ON THE SUBTREE BELOW THE ]
  [* NODE THAT THE PROGRAM IS CURRENTLY 'LOOKING AT', I. E. ]
  [* WHICH IS SUBSUMED BY THE CURRENT NODE.]
    VERIFY $2;
    GO TO THE WORD STARTING THE PRESENT NODE;
    NOT TEST FOR X150;
    ITERATET $1 UNTIL DO X SUCCEEDS.
  $1 = GO TO THE NEXT WORD; NOT TEST FOR X150.
  $2 = GO TO THE WORD FOLLOWING THE PRESENT NODE; STORE IN X150.
* ********** **************************************** **********
*                                                                *
*                  EXTENDED SCOPE ROUTINES                       *
*                                                                *
* ********** **************************************** **********
*
ROUTINE EXTENDED-CORE- LOCAL(X5) =
    [* goes to the core. If the core is NULLWH, this routine ]
    [* goes up to the RN and from there to the host noun. ]
    [* Simplify the same routine in the MDPAR6]
    DO CORE-;
    IF BOTH PRESENT-ELEMENT- IS NULLWH
       AND $PATH1 [WWH1; X5=WHS-N]
    THEN AT X5 DO HOST-.
 $PATH1 = EITHER NONSEG-IMMSTG X5 IS WHS-N
          OR $NESTED.                                        (GLOBAL)
 $NESTED = NONSEG-IMMSTG IS THATS OR TOVO OR PVO OR ASSERTION
           OR VENO OR VENPASS; DO $PATH1.
ROUTINE EXTENDED-CORE =
      DO CORE;
      IF BOTH PRESENT-ELEMENT- IS NULLWH
         AND PRESENT-ELEMENT- HAS NODE ATTRIBUTE N-OMITSTG
             [GO TO WH-STG] @
      THEN IF PRESENT-ELEMENT- IS WHNS-N OR WHNQ-N
           THEN CORE OF WHN EXISTS
           ELSE IF PRESENT-ELEMENT- IS WHQ-N
                THEN FIRST ELEMENT EXISTS
           ELSE HOST EXISTS
      ELSE IF PRESENT-ELEMENT- IS NULLC
           THEN IF PRESENT-ELEMENT- HAS NODE ATTRIBUTE LINKC @
                THEN EXTENDED-CORE EXISTS.
* ROUTINE NONSEGWH IS A VERSION OF NONSEG-IMMEDSTG USED IN WH
* RESTRICTIONS.
*
ROUTINE NONSEGWH = ASCEND TO STRING; EITHER $1 OR TRUE .
  $1 = TEST FOR STGSEG;
       GO UP;
       TEST FOR STRING;
       EITHER $1 OR TRUE.
* PRESENT-STRING -SAME AS PRESENT-ELEMENT
*
ROUTINE PRESENT-STRING = DO $UP-THROUGH-Q [IMMEDIATE(X)] .
* DEEPEST-COVERB
*      STARTS AT ANY ELEMENT EXCEPT THE VERB OF A
*      VERB-CONTAINING STRING (USUALLY AT THE SUBJECT) AND GOES FIRST
*      TO THE VERB IN THE STRING;IF THAT VERB HAS A VERB-CONTAINING
*      OBJECT (OR A PREDICATE CONSISTING OF AN AASP+TOVO) THEN IT
*      GOES TO THE VERB IN THAT OBJECT (OR TOVO), WHERE IT REPEATS
*      THE TEST FOR A VERB-CONTAINING OBJECT. THE ITERATION ENDS ON THE
*      VERB WHICH DOESN'T HAVE A VERB-CONTAINING OBJECT (OR PREDICATE).
*      NOTE RE SN IN $VERBAL: THIS TEST MAKES 'IS' NOT 'SUFFER' THE
*      DEEPEST-COVERB IN 'TO LIVE IS TO SUFFER' AND 'HIS AIM IS NOT TO
*      SUFFER'(1 OF 2 READINGS).
*      USER BEWARE: SHIFT OF SUBJECT-OBJECT RELATION IN THE KERNEL DUE
*      TO PASSIVE MUST BE HANDLED BY THE RESTRICTION USING THE ROUTINE.
ROUTINE DEEPEST-COVERB- LOCAL(X7,XX-COVERB) =
       ITERATE $NEXT-VERB- UNTIL $OBJ-HAS-VERB FAILS.
  $NEXT-VERB- = DO $1; DO $2 .                               (GLOBAL)
  $1 = THE PRESENT-ELEMENT- HAS COELEMENT- VERB OR LVINGR OR LVENR OR
       LVR OR VERB1 X7 .
  $2 = IF X7 IS VERB1 WHERE VALUE IS NOT LTVR THEN PRESENT-ELEMENT-
       HAS COELEMENT- VERB2 X7 .
  $OBJ-HAS-VERB = BOTH $VERBAL- @ AND PRESENT-STRING HAS ELEMENT-
       OBJECT OR PASSOBJ .
  $VERBAL- =
       IF PRESENT-ELEMENT- HAS COELEMENT- OBJECT OR PASSOBJ@
       THEN EITHER CORE- XX-COVERB IS VO OR VINGO OR TOVO OR TOBE
                   OR VENO OR VENPASS OR PVO
                   WHERE XX-COVERB IS NOT OCCURRING IN SN,
            OR $ASPECTUAL IS TRUE.
  $ASPECTUAL = BOTH XX-COVERB IS ADJ:AASP
               AND RIGHT-ADJUNCT OF XX-COVERB IS TOVO OR PVO.     (GLOBAL)
ROUTINE DEEPEST-COVERB = ITERATE $NEXT-VERB UNTIL $OBJ-HAS-VERB FAILS.
  $NEXT-VERB = DO $1; DO $2.                               (GLOBAL)
  $1 = PRESENT-ELEMENT- HAS COELEMENT VERB OR LVINGR OR LVENR OR LVR
          OR VERB1 X7.
  $2 = IF X7 IS VERB1 WHERE VALUE IS NOT LTVR
       THEN PRESENT-ELEMENT- HAS COELEMENT VERB2  X7.
  $OBJ-HAS-VERB = BOTH $VERBAL
         @ AND PRESENT-STRING HAS ELEMENT OBJECT OR PASSOBJ.
  $VERBAL =
       IF PRESENT-ELEMENT HAS COELEMENT OBJECT OR PASSOBJ@
       THEN EITHER CORE- XX-COVERB IS VO OR VINGO OR VENO OR TOVO
                    OR TOBE OR VENPASS OR PVO
                    WHERE XX-COVERB IS NOT OCCURRING IN SN,
            OR $ASPECTUAL [DEEPEST-COVERB-] IS TRUE.
ROUTINE ULTIMATE-HOST = ITERATE $HOSTJUMP UNTIL $PNADJ FAILS.
  $HOSTJUMP = DO HOST; STORE IN X3 .
  $PNADJ = X3 IS OCCURRING IN PN WHERE PN IS OCCURRING AS RN.   (GLOBAL)
ROUTINE ULTIMATE-OBJECT =
    EITHER ITERATE $ASCEND OR TEST FOR OBJECT
    OR PASSOBJ; EITHER $ADJUNCT OR TRUE .
  $ASCEND = ASCEND TO OBJECT OR PASSOBJ PASSING THROUGH
        TRANSMITTING-OBJ-STG   NOT PASSING THROUGH ADJSET .
  $ADJUNCT = ONE OF $ASP, $SNRA, $SNRN, $SN-IN-RV IS TRUE;
             DO $UPAGAIN.
  $SN-IN-RV = BOTH X6 IS OCCURRING AS SN @ AND SN IS OCCURRING AS
              RV WHERE PREVIOUS-ELEMENT- IS OBJECT OR PASSOBJ X40.
  $ASP= EITHER NONSEGWH X6 IS TOVO WHERE TOVO IS OCCURRING AS RA X40
        OR NONSEGWH X6 IS PVO WHERE PVO IS OCCURRING AS RA X40 .
  $SNRA = X6 IS OCCURRING AS SN X8 WHERE X8 IS OCCURRING AS RA X40.
  $SNRN =
    BOTH X6 IS OCCURRING AS SN X8 WHERE X8 IS OCCURRING AS RN X40
    AND IF X40 IS OCCURRING IN PN @ THEN PN IS OCCURRING AS RN OR
          OBJBE X40.
  $UPAGAIN = GO TO X40; DO ULTIMATE-OBJECT .
ROUTINE ULTIMATE-SUBJECT =
  [* ITERATIVELY ASCENDS TO OBJECT OR PASSOBJ PASSING THROUGH ]
  [* VERB-CONTAINING OBJECT STRINGS UNTIL IT FINDS AN OBJECT ]
  [* THAT HAS A COELEMENT SUBJECT. IT ALSO ASCENDS THROUGH ]
  [* PREDICATE NOUNS AND ADJECTIVES AND THEIR ADJUNCTS AS LONG ]
  [* AS THE ADJUNCTS DO NOT CONTAIN THE NODE SUBJECT.  THUS THE ]
  [* ULTIMATE SUBJECT OF X ASCENDS TO THE FIRST NODE SUBJECT ON ]
  [* ANY LEVEL ABOVE X IN THE PARSE TREE. NOTE THAT THE DEEPEST- ]
  [* COVERB DESCENDS MORE NARROWLY, PASSING THROUGH VERB-CONTAINING ]
  [* OBJECT STRINGS AND TOVO AS ADJUNCT OF AASP, BUT NOT THROUGH ]
  [* OTHER PREDICATES OR ADJUNCTS. USE DEEPEST-COVERB (NOT ]
  [* ULTIMATE-SUBJECT) IN SELECTIONAL RESTRICTIONS BECAUSE ]
  [* 'IT' IS THE ULTIMATE SUBJECT OF 'SWIM' IN BOTH        ]
  [*       'IT LIKES TO SWIM' AND 'IT IS FUN TO SWIM' ]
  [* USE ULTIMATE SUBJECT FOR 'IT' PERMUTATIONS.]
    ITERATET $UP-TO-OBJ UNTIL $COELSUBJ SUCCEEDS.
 $UP-TO-OBJ =
    EITHER ASCEND TO OBJECT OR PASSOBJ PASSING THROUGH VENO OR
        VENPASS OR VINGO OR TOVO OR PVO OR VO OR Q-CONJ,
    OR ASCEND TO OBJBE PASSING THROUGH VENO OR VENPASS OR TOVO OR
        VINGO OR PVO OR VO OR Q-CONJ.
 $COELSUBJ = PRESENT-ELEMENT HAS COELEMENT SUBJECT OR BESUBJ OR TPOS.
ROUTINE VERB-COELEMENT- = DO $NEXT-VERB- .
 $NEXT-VERB- = DO $1.                                           (GLOBAL)
 $1 = THE PRESENT-ELEMENT- HAS COELEMENT- VERB OR LVINGR OR
       LVENR OR LVR.
ROUTINE VERB-COELEMENT = DO $NEXT-VERB.
 $NEXT-VERB =  DO $1.                                       (GLOBAL)
 $1 = THE PRESENT-ELEMENT- HAS COELEMENT VERB OR LVINGR OR
      LVENR OR LVR.
* FIRST-FILLED-ATOM
*    AT THE PRESENT LOCATION, LOOK DOWN THE SUBSTREE TO FIND THE
*    FIRST ATOM THAT IS LEXICALLY FILLED.
ROUTINE FIRST-FILLED-ATOM =
    ITERATET $GO-TO-NEXT-NODE
    UNTIL BOTH PRESENT-ELEMENT- IS OF TYPE ATOM
          AND PRESENT-ELEMENT- IS NOT EMPTY SUCCEEDS.
  $GO-TO-NEXT-NODE =
    EITHER GO DOWN
    OR ITERATET GO UP
       UNTIL GO RIGHT SUCCEEDS.
* LAST-FILLED-ATOM
*    AT THE PRESENT LOCATION, LOOK DOWN THE SUBTREE TO FIND THE
*    LAST ATOM THAT IS LEXICALLY FILLED.
ROUTINE LAST-FILLED-ATOM =
    ITERATET $GO-TO-NEXT-NODE
    UNTIL BOTH PRESENT-ELEMENT- IS OF TYPE ATOM
          AND PRESENT-ELEMENT- IS NOT EMPTY SUCCEEDS.
  $GO-TO-NEXT-NODE =
    EITHER DO $LAST-NODE
    OR ITERATET GO UP
       UNTIL GO LEFT SUCCEEDS.
  $LAST-NODE =
    GO DOWN;
    EITHER ITERATE GO RIGHT OR TRUE.
* ********** **************************************** **********
*                                                                *
*                    CONJUNCTION ROUTINES                        *
*                                                                *
* ********** **************************************** **********
*
ROUTINE CO-CONJ(X) LOCAL(X300) =
    STORE IN X200;
    EITHER $COELEMENT OR $STRING-SEGMENT.
 $COELEMENT = DO COEL1-(X); DO $NOT-XY-CONJ-XY.
 $NOT-XY-CONJ-XY =
    ITERATE BOTH PRESENT-STRING- HAS NODE ATTRIBUTE POSTCONJELEM
            @AND NEITHER $Y-TO-RIGHT NOR $Y-TO-LEFT.
 $Y-TO-RIGHT= ITERATE GO RIGHT UNTIL TEST FOR X200 SUCCEEDS.
 $Y-TO-LEFT= ITERATE GO LEFT UNTIL TEST FOR X200 SUCCEEDS.
 $STRING-SEGMENT =
    BOTH $GO-THRU-SEG-TO-X
    @AND EITHER PRESENT-ELEMENT HAS NODE ATTRIBUTE POSTCONJELEM
         OR AT X300 $NOT-XY-CONJ-XY IS TRUE.
 $GO-THRU-SEG-TO-X =
    DO COEL1-(STGSEG);
    STORE IN X300;
    DO ELEMENT-(X).
ROUTINE CONJELEM-  LOCAL(X200) =
  [* SIMILAR TO CONJELEM EXCEPT STARTING NODE MUST BE DIRECTLY ]
  [* BELOW Q-CONJ.]
    STORE IN X200;
    ITERATE $UP-2-IF-CONJ UNTIL $FIND-X200 SUCCEEDS.
 $UP-2-IF-CONJ = IMMEDIATE-NODE- IS Q-CONJ; GO UP.
 $FIND-X200 = ITERATE GO LEFT UNTIL TEST FOR X200 SUCCEEDS.
ROUTINE CONJELEM LOCAL(X200,X600) =
  [* CONJELEM: INVERSE OF CORE-CONJUNCT.]
  [* STARTS AT THE CONJUNCT OF X AND GOES TO X. IN A SITUATION ]
  [* X1Y1 CONJ X2Y2, STARTING AT X2 CONJELEM WILL GO TO X1. ]
  [* GIVEN THAT Z2 IS SEVERAL LEVELS BELOW X2,STARTING AT Z2 ]
  [* CONJELEM WILL GO TO Z1,SEVERAL LEVELS BELOW X1. ]
    EITHER $ATQ OR $UPQ;
    DO $TO-PRECONJUNCTION-Y [COEL1-];
    EITHER TEST FOR X600 OR DESCEND TO X600.
 $ATQ =
    TEST FOR Q-CONJ;
    GO DOWN;
    STORE IN X600;
    STORE IN X200.
 $UPQ =
    STORE IN X600;
    STORE IN X200;
    GO UP;
    ITERATET $UPQ1 UNTIL TEST FOR Q-CONJ SUCCEEDS;
    GO TO X200.
 $UPQ1 =
    STORE IN X200;
    NOT TEST FOR STRING;
    GO UP.
ROUTINE CORE-CONJUNCT =
  [* STARTING AT THE GIVEN NODE, CORE-CONJUNCT DESCENDS TO ]
  [* THE CORE AND THEN GOES TO ITS CONJUNCT.]
    DO $CORE-PATH [CORE-];
    EITHER $ASCNT [CORE] OR TRUE;
    DO $POSTCONJ [STARTAT];
    DO $CORE-PATH.
* GOVERNING-CONJ
*    STARTS IN A Q STRING AND FINDS HEAD CONJUNCTION OF C-Q
*    COMPLEX.
*
ROUTINE GOVERNING-CONJ =
     EITHER TEST FOR Q-CONJ OR ASCEND TO Q-CONJ;
     GO UP [TO CONJ-NODE]; GO DOWN.
ROUTINE PRE-POST-CONJELEM LOCAL(X100,X500) =
  [* GIVEN THAT STRING Q-CONJ HAS ELEMENTS F1 F2 ... FN ]
  [* WHICH ARE CONJUNCTS OF E1 E2 ... EN, I.E. THE NODES TO ]
  [* THE LEFT OF THE SPECIAL PROCESS NODE ONE LEVEL ABOVE ]
  [* Q-CONJ, THEN TO EACH FI THIS ROUTINE ASSIGNS THE NODE ]
  [* ATTRIBUTE PRECONJELEM WITH VALUE EI AND TO EACH EI ]
  [* THE NODE ATTRIBUTE POSTCONJELEM WITH VALUE FI.]
    STORE IN X100;
    DO ELEMENT- (Q-CONJ);  DO LAST-ELEMENT-;
    ITERATE VERIFY $ASSIGN-TEST UNTIL GO LEFT FAILS.
$ASSIGN-TEST =
    EITHER TEST FOR SP-NODE
    OR EITHER $PRECONJ OR
              $ASSIGN-PRE-AND-POST.                             (GLOBAL)
 $ASSIGN-PRE-AND-POST =
    STORE IN X500; STORE IN X0; GO TO X100;
    ITERATE $GO-LEFT UNTIL TEST FOR X500 SUCCEEDS;
      [* this routine grossly assumes that    *]
      [* if X100 has POSTCONJELEMs, then they *]
      [* lie in between X100 and X500         *]
      [*     X100                             *]
      [*      +----- &                        *]
      [*             |                        *]
      [*             +---- Q-CONJ             *]
      [*                   |        X500      *]
      [*                   +---...---+        *]
      [*                                      *]
    EITHER BOTH AT X500, ITERATE GO LEFT
                         UNTIL TEST FOR CONJ-NODE SUCCEEDS
           AND AT X100, ITERATE $POSTCONJ
        OR TRUE;
    DO $ASSIGN-POSTCONJELEM; STORE IN X0; GO TO X500;
    DO $ASSIGN-PRECONJELEM.                                      (GLOBAL)
 $GO-LEFT =
    ITERATET $UPCONJ UNTIL GO LEFT SUCCEEDS;
    STORE IN X100.
 $UPCONJ = GO UP; TEST FOR Q-CONJ; GO UP.
 $ASSIGN-POSTCONJELEM =
    ASSIGN THE PRESENT ELEMENT NODE ATTRIBUTE POSTCONJELEM.
 $ASSIGN-PRECONJELEM =
    ASSIGN THE PRESENT ELEMENT NODE ATTRIBUTE PRECONJELEM.
* ********** **************************************** **********
*                                                                *
*                   ROUTINES FOR SELECTION                       *
*                                                                *
* ********** **************************************** **********
*
ROUTINE COMPLEMENT =
  [* TAKES THE COMPLEMENT OF LIST STORED IN REGISTER X-SUBLIST. ]
  [* THE COMPLETE LIST IS ASSUMED TO BE PRESENT LOCATION. ]
  [* COMPLEMENT CREATES A LIST STORED IN X-COMPLEMENT WHICH ]
  [* CONSISTS OF ALL THOSE ELEMENTS ON CURRENT LIST THAT ARE ]
  [* NOT ON X-SUBLIST. ]
    X-CURRENTLIST:= PRESENT-ELEMENT-;
    X-COMPLEMENT:= NIL;
    ITERATE BOTH X-HEAD2:= HEAD OF X-CURRENTLIST
            AND IF X-SUBLIST DOES NOT HAVE MEMBER X-HEAD2
                THEN $ADD-TO-COMP
    UNTIL X-CURRENTLIST:= SUCCESSORS OF X-CURRENTLIST WHERE
          X-CURRENTLIST IS NIL SUCCEEDS;
    GO TO X-COMPLEMENT.
 $ADD-TO-COMP =
    IF X-ATTL := ATTRIBUTE-LIST OF X-CURRENTLIST
    THEN PREFIX X-HEAD2:X-ATTL TO X-COMPLEMENT
    ELSE PREFIX X-HEAD2 TO X-COMPLEMENT.
ROUTINE CORE-ATT =
  [* RETURNS AN ATTRIBUTE LIST FOR ITS PRESENT LOCATION, ]
  [* LOOKING FOR  AN ATTRIBUTE LIST IN THE FOLLOWING ORDER  ]
  [* 1.  COMPUTED ATTRIBUTE LIST, STORED AS VALUE OF NODE ]
  [*     ATTRIBUTE 'COMPUTED-ATT';                          ]
  [* 2.  SELECTIONAL ATTRIBUTE LIST, STORED AS VALUE OF ]
  [*     NODE ATTRIBUTE 'SELECT-ATT';                       ]
  [* 3.  ATTRIBUTE LIST OF WORD, PRUNED TO CONTAIN ONLY ]
  [*     SELECTIONALLY RELEVANT CLASSES, AS DEFINED BY THE ]
  [*     LIST SUBLANGUAGE-ATTS (USES INTERSECT, TO OBTAIN ]
  [*     INTERSECTION OF SUBLANGUAGE-ATTS AND ATTRIBUTE LIST). ]
  [* 4.  IF INTERSECTION IS NIL AND WORD HAS ATTRIBUTE NHUMAN ]
  [*     OR NAME, LIST HUMAN-LIST IS RETURNED. ]
    EITHER PRESENT-ELEMENT- HAS NODE ATTRIBUTE COMPUTED-ATT
    OR EITHER PRESENT-ELEMENT- HAS NODE ATTRIBUTE SELECT-ATT
       OR EITHER ATTRIBUTE-LIST X-NEWLIST EXISTS
           WHERE BOTH X-SUBLANGUAGE-ATTS := LIST SUBLANGUAGE-ATTS
                 AND INTERSECT OF X-SUBLANGUAGE-ATTS IS NOT NIL
          OR $NHUMAN-CHK.
 $NHUMAN-CHK =
    BOTH PRESENT-ELEMENT- HAS ATTRIBUTE NHUMAN OR NAME
    AND X-INTERSECT := LIST HUMAN-LIST.
ROUTINE CORE-SELATT =
  [* RETURNS AN ATTRIBUTE LIST FOR ITS PRESENT LOCATION, LOOKING ]
  [* FOR AN ATTRIBUTE LIST IN THE FOLLOWING ORDER                ]
  [*  1. SELECT ATTRIBUTE LIST, STORE AS VALUE OF NODE ATTRIBUTE ]
  [*  'SELECT-ATT'.                                              ]
  [*  2.  ATTRIBUTE LIST OF WORD, PRUNED TO CONTAIN ONLY ]
  [*  SELECTIONALLY RELEVANT CLASSES, AS DEFINED BY THE LIST ]
  [*  SUBLANGUAGE-ATTS (USES ROUTINE INTERSECT TO OBTAIN) ]
  [*  INTERSECTION OF SUBLANGUAGE-ATTS AND ATTRIBUTE LIST.   ]
  [*  3. IF WORD HAS NO ATTRIBUTES ON SUBLANGUAGE-ATTS, AND ]
  [*  HAS CLASS NHUMAN, THEN LIST HUMAN-LIST IS RETURN AS VALUE ]
  [*  OF CORE-SELATT.  ]
     EITHER PRESENT-ELEMENT- HAS NODE ATTRIBUTE SELECT-ATT
     OR EITHER ATTRIBUTE-LIST X-NEWLIST EXISTS WHERE
               BOTH X-SUBLANGUAGE-ATTS:= LIST SUBLANGUAGE-ATTS
               AND INTERSECT OF X-SUBLANGUAGE-ATTS IS NOT NIL
        OR $NHUMAN-CHK [CORE-ATT].                     (GLOBAL)
ROUTINE INTERSECT =
[* Takes intersection of list in current location with list stored ]
[* in register X-NEWLIST, and creates the list representing the    ]
[* intersection (including attribute lists of the intersecting     ]
[* elements). the new list representing the intersection is stored ]
[* in register X-INTERSECTION; the routine finishes located at this]
[* list (X-INTERSECTION).                                          ]
[*  ** Note that it is the list stored in X-NEWLIST whose members  ]
[*  ** (and possible attribute lists) are copied.                  ]
[*                                                                 ]
[*** WARNING                                                       ]
[*   If register X-NEWLIST does not point to a list, the routine   ]
[*   will fail; if the routine does not start at an ATOM or a LIST,]
[*   the intersection will be empty.                               ]
    X-CURRENTLIST:= PRESENT-ELEMENT-;
INTERSECT X-NEWLIST WITH X-CURRENTLIST INTO X-INTERSECTION.
ROUTINE RINTERSECT =
    X-CURRENTLIST := PRESENT-ELEMENT-;
    INTERSECT X-NEWLIST WITH X-CURRENTLIST INTO X-INTERSECTION;
    INTERSECT X-CURRENTLIST WITH X-INTERSECTION INTO X-CURRENTLIST;
    GO TO X-INTERSECTION.
ROUTINE UNION =
[* COMPUTES THE SET-THEORETIC UNION OF TWO SETS; ONE SET IS PASSED IN ]
[* STORED IN THE REGISTER X-UNION; ]
[* THE ROUTINE MUST BEGIN FROM THE      ]
[* SECOND LIST (SET); IT CHECKS THAT ]
[* EACH ELEMENT FROM THE CURRENT LIST]
[* (STORED IN X-ADD-TO-UNION) IS EITHER ]
[* ALREADY ON LIST X-UNION OR IF   ]
[* NOT, IT IS PREFIXED TO X-UNION.  ]
[* THE UNION IS RETURNED IN REGISTER   ]
[* X-UNION, WHICH IS ALSO WHERE THE ]
[* ROUTINE LEAVES YOU. IF THE INITIAL  ]
[* LIST IS NIL (EMPTY), UNION WILL ]
[* RETURN WHATEVER LIST IS STORED       ]
[* IN X-UNION.  ]
    IF PRESENT-ELEMENT- IS NOT NIL
    THEN $ADD-TO-UNION
    ELSE GO TO X-UNION.
 $ADD-TO-UNION =
    X-ADD-TO-UNION := PRESENT-ELEMENT-;
    ITERATE BOTH X-ADD-EL-TO-UNION := HEAD OF X-ADD-TO-UNION
            AND IF X-UNION DOES NOT HAVE MEMBER X-ADD-EL-TO-UNION
                THEN IF ATTRIBUTE-LIST X-ATTRB-UNION
                        OF X-ADD-TO-UNION EXISTS
                     THEN PREFIX X-ADD-EL-TO-UNION: X-ATTRB-UNION
                          TO X-UNION
                     ELSE PREFIX X-ADD-EL-TO-UNION TO X-UNION
    UNTIL SUCCESSORS X-ADD-TO-UNION OF X-ADD-TO-UNION IS NIL SUCCEEDS;
    GO TO X-UNION.
* NEW-HOST
*    FINDS POTENTIAL NEW HOST FOR RIGHT-ADJUNCTS OR SA-
*    1- IF OLD HOST IS IN A NEST OF PN'S, THEN NEW HOST WILL BE THE
*       N IN THE NEXT LEVEL UP, IF THERE IS ONE; OTHERWISE
*    2- IF HOST IS NOT IN A NEST OF PN'S THEN NEW HOST WILL BE
*       THE NEXT LEVEL VERB OF THE IMMEDIATE-STRING.
*       [X-START,X-HOST]
*
ROUTINE NEW-HOST =
    AT X-START, IT IS NOT THE CASE THAT FOLLOWING-ELEMENT- EXISTS
                WHERE PRESENT-ELEMENT- IS NOT EMPTY;
    NEITHER X-START IS [NOT] OCCURRING IN OBJECT OR OBJBE
    NOR IMMEDIATE-NODE- OF X-START IS SA;
    X-CONJ := X-HOST [old host];
    BOTH X-CONJ := NIL
         [* RA contains PN, PQUANT *]
         [* RN contains ADJINRN, PD, PDATE, PN, PQUANT, PVO, *]
         [*             VENPASS, WHENS *]
         [* RV contains PD, PDATE, PN, PQUANT *]
         [* SA contains FTIME, INT, LDR, NSTGT PDATE, PN *]
    AND IF X-START IS ADJINRN OR NSTGT OR PN [OR QN] OR PD OR
                              PDATE OR PQUANT OR PVO OR VENPASS
       @THEN DO $UP-TO-RADJ [$NEXT-CORE]
        ELSE NOT TRUE [CANNOT FIND NEW HOST].
 $UP-TO-RADJ =
    AT X-HOST, ITERATE GO UP UNTIL $UP-LIMIT SUCCEEDS.
 $UP-LIMIT =
    [* Limits of search for new RADJSET are:     *]
    [*     (1) found new RADJSET or SA           *]
    [*     (2) the immediate node has lexically  *]
    [*         filled right coelement            *]
    [*     (3) the immediate node has right SA   *]
    BOTH BOTH IMMEDIATE-NODE- IS NOT SA
         AND NOT $RIGHT-NOT-EMPTY
    AND BOTH ITERATET GO UP
             UNTIL BOTH PRESENT-ELEMENT- X-NEWADJ EXISTS
                   AND $SEARCH-FOR-RADJ SUCCEEDS
        AND IF X-IMM IS SA
            THEN BOTH X-START IS NOT ADJINRN
                 AND CORE- X-HOST OF COELEMENT VERBAL OF X-IMM EXISTS
            ELSE AT X-NEWADJ, HOST- X-HOST EXISTS.
 $SEARCH-FOR-RADJ =
    EITHER IMMEDIATE-NODE- X-IMM IS OF TYPE RADJSET
    OR EITHER X-IMM IS SA
       OR EITHER AT X-IMM DO $RIGHT-NOT-EMPTY
          OR AT X-IMM DO $RIGHT-IS-SA.
 $RIGHT-NOT-EMPTY =
    ITERATE GO RIGHT UNTIL PRESENT-ELEMENT- IS NOT EMPTY SUCCEEDS.
 $RIGHT-IS-SA =
    ITERATE GO RIGHT
    UNTIL BOTH PRESENT-ELEMENT- X-IMM IS SA
          AND VALUE X-NEWADJ OF X-IMM EXISTS SUCCEEDS.
 $NEXT-CORE =
    IF X-HOST IS OCCURRING IN PN OR FTIME OR NSTGT OR PDATE
    @THEN IF BOTH PRESENT-ELEMENT- IS OCCURRING IN SA X-NEWADJ
             AND X-START IS NOT ADJINRN
          THEN AT X-NEWADJ CORE- X-HOST OF COELEMENT VERBAL EXISTS
          ELSE IF PRESENT-ELEMENT- IS OCCURRING IN RADJSET X-NEWADJ
               @THEN HOST- X-HOST EXISTS
               ELSE IF X-START IS NOT ADJINRN
                    THEN $NEXT-STRING-V
                    ELSE NOT TRUE
    ELSE $NEXT-STRING-V.
 $NEXT-STRING-V =
    IMMEDIATE STRING EXISTS;
    ITERATE GO UP
       UNTIL EITHER CORE X-HOST OF COELEMENT VERBAL IS NOT EMPTY
             OR PRESENT-ELEMENT- IS OF TYPE RADJSET
                WHERE HOST X-HOST IS NOT EMPTY SUCCEEDS.
* ********* CONJUNCTION ROUTINES FOR TRANSFORMATIONS
ROUTINE CONJUNCT = PRESENT-ELEMENT- HAS NODE ATTRIBUTE POSTCONJELEM.
* EXPAND
*     THE EXPAND ROUTINE OPERATES RECURSIVELY TO EXPAND CONJUNCTS OF
*     CONJUNCTS, AND CAN ALSO HANDLE SEVERAL CONJUNCTIONS ON A SINGLE
*     LEVEL (ALTHOUGH THIS IS VERY RARE).  IT RESETS THE NODE
*     ATTRIBUTES POSTCONJELEM (WHICH POINTS FORWARD TO THE NEXT
*     CONJUNCT OF AN ELEMENT) AND PRECONJELEM (WHICH POINTS BACKWARD
*     TO THE PRECEDING CONJUNCT OF AN ELEMENT) FOR THE NEW
*     STRUCTURE.
*
*     EXPAND STARTS AT NODE X.  IF THERE ARE ANY CONJUNCTIONAL
*     STRINGS [TYPE CONJ-NODE] ON LEVEL BELOW X, EXPAND COMPLETES THE
*     DEFINITION OF Q-CONJ SO THAT IT IS A COMPLETE STRING [I.E.
*     SUBJ VERB1 OBJ1 CONJ VERB2 OBJ2 ==> SUBJ VERB1 OBJ1 CONJ
*     SUBJ VERB2 OBJ2]. NODE X IS INSERTED BETWEEN Q-CONJ AND ITS
*     ELEMENTS SO THAT Q-CONJ=X=ELEMENTS OF Q-CONJ. THE CONJUNCTIONAL
*     STRING IS MOVED FROM THE LEVEL BELOW X UP ONE LEVEL TO THE
*     RIGHT OF X.
*
ROUTINE EXPAND =
      VERIFY ALL OF $REGSTG, $REGVAL, $XCONJ-TEST.
  $REGSTG = PRESENT-ELEMENT- X21 EXISTS [save starting node in X21].
  $REGVAL = LAST-ELEMENT- X22 OF X21 EXISTS
           [Node to be tested for conjunction in X22,]
           [start at rightmost].
  $XCONJ-TEST =
      ITERATET $EXPAND-CONJ UNTIL $TEST-FOR-CONJ FAILS;
      GO UP [to original string];
      ITERATE VERIFY $ASSIGN-ATT UNTIL GO RIGHT FAILS
            [EXPAND if there are conjunctionsi;]
            [EXPAND each conjunction].
  $TEST-FOR-CONJ =
      AT X22
      ITERATET GO LEFT
      UNTIL TEST FOR CONJ-NODE
            WHERE VERIFY ELEMENT- Q-CONJ EXISTS SUCCEEDS;
      STORE IN X22;
      ELEMENT- Q-CONJ X23 EXISTS
            [ complete Q-CONJ so that it is a complete STRING]
            [ i.e. it has same elements as X ].
  $EXPAND-CONJ = BOTH $COMPLETE-Q-CONJ AND $MOVE-CONJ-UP
            [COMPLETE Q-CONJ AND MOVE CONJ-NODE UP ONE LEVEL].
  $COMPLETE-Q-CONJ =
       ALL OF $COMPLETE-FRONT, $COMPLETE-END, $ERASE-PRE-POST
            [COMPLETE FRONT AND END OF Q-CONJ.  ERASE CONJUNCTION]
            [ NODE ATTRIBUTES].
  $COMPLETE-FRONT =
       AT VALUE X25 OF X23
       EITHER ITERATET $INSERT-PREVELEM
              UNTIL $FRONT-INCOMPLETE FAILS
       OR TRUE
            [LOCATE NODE THAT SHOULD BE INSERTED IN FRONT OF Q-CONJ].
  $INSERT-PREVELEM =
       BEFORE X25 INSERT X24 [INSERT NODE AT FRONT OF Q-CONJ];
       STORE IN X25;
       GO TO X24.
  $FRONT-INCOMPLETE =
         [* Go to the corresponding preconjuncts and then left *]
       ITERATET $PRECONJ [COEL1-] UNTIL GO LEFT SUCCEEDS;
         [* which is format equivalent statement *]
       ITERATET GO LEFT UNTIL $FMT-EXPANDABLE SUCCEEDS;
       STORE IN X24.
  $FMT-EXPANDABLE =
         [* statement phrases bypassed by expand conjunction *]
       PRESENT-ELEMENT- IS NOT OF TYPE STATEMENT-EQV-NODES.
  $COMPLETE-END =
       LAST-ELEMENT- X25 OF X23 [Q-CONJ] EXISTS;
       AT X22 EITHER ITERATET $INSERT-NEXTELEM
                     UNTIL $END-INCOMPLETE FAILS
              OR TRUE
         [LOCATE NODES THAT SHOULD BE INSERTED AFTER END OF Q-CONJ].
  $END-INCOMPLETE =
         [* Go to the node to the right of CONJ-NODE *]
       ITERATET $PREVIOUS-CONJ UNTIL GO RIGHT SUCCEEDS;
         [* which is format equivalent statement *]
       ITERATET GO RIGHT UNTIL $FMT-EXPANDABLE SUCCEEDS;
       STORE IN X24.
  $PREVIOUS-CONJ =
       BOTH IMMEDIATE-NODE- IS Q-CONJ
      @AND IMMEDIATE-NODE- EXISTS [GO UP TO NEXT CONJUNCTION LEVEL].
  $INSERT-NEXTELEM =
       AFTER X25 INSERT X24 [INSERT NODE AT END PART OF Q-CONJ];
       STORE IN X25;
       GO TO X24.
  $ERASE-PRE-POST =
       AT VALUE OF X23 ITERATE VERIFY $ERASE-ATT
                       UNTIL GO RIGHT FAILS
           [ERASE PRECONJELEM AND POSTCONJELEM ATTRIBUTES OF ]
           [ELEMENTS OF Q-CONJ AND STARTING NODE RESPECTIVELY].
  $ERASE-ATT =
       BOTH $ERASE-PRE
       AND IF X26 EXISTS
          @THEN BOTH $ERASE-POST AND $RESET-X26 .
  $ERASE-PRE =
       IF PRESENT-ELEMENT- X28 HAS NODE ATTRIBUTE PRECONJELEM X26
       THEN ERASE NODE ATTRIBUTE PRECONJELEM.
  $ERASE-POST =
       IF PRESENT-ELEMENT- HAS NODE ATTRIBUTE POSTCONJELEM X26
       THEN ERASE NODE ATTRIBUTE POSTCONJELEM.
  $MOVE-CONJ-UP = [RENAME Q-CONJ AND MOVE CONJ-NODE UP]
       BOTH $NAME-Q-CONJ AND $MOVE-UP.
  $NAME-Q-CONJ =
       REPLACE X23 BY X23 (X21 (ALL ELEMENTS OF X23))
           [VALUE OF Q-CONJ IS NAME OF STARTING NODE].
  $ERASE-RESET-PRE =
       AT VALUE X27 OF Q-CONJ OF X25
       BOTH $ERASE-PRE
       AND IF X26 EXISTS
           THEN BOTH $RESET-POST AND $RESET-X26.
  $RESET-POST =
      [BOTH AT X21] [ORIGINAL NODE] [PRESENT-ELEMENT- X0 EXISTS]
      [AND] AT X26
       ASSIGN PRESENT ELEMENT NODE ATTRIBUTE POSTCONJELEM
       WITH VALUE X21.
  $RESET-X26 =
       AFTER X26 INSERT <STOP>;
       STORE IN X26;
       DELETE X26 [RESETS X26 TO BE EMPTY];
       GO TO X28 [STARTING POINT FOR $ERASE-ATT].
  $ERASE-RESET-POST =
       AT X27
       IF PRESENT-ELEMENT- HAS NODE ATTRIBUTE POSTCONJELEM X26
       THEN BOTH ERASE NODE ATTRIBUTE POSTCONJELEM
            AND IF X26 EXISTS THEN BOTH $RESET-PRE AND $RESET-X26.
  $RESET-PRE =
      [BOTH AT X21 PRESENT-ELEMENT- X0 EXISTS]
      [AND] AT X26
           ASSIGN PRESENT ELEMENT NODE ATTRIBUTE PRECONJELEM
           WITH VALUE X21.
  $MOVE-UP =
       ALL OF $INSERT-CONJ-UP, $DELETE-LOWERCONJ, $ERASE-RESET-PRE,
              $ERASE-RESET-POST, $EXPAND-NEW, @$RESTORE-REG.
  $INSERT-CONJ-UP = [MOVE CONJ-NODE X22 UP ONE LEVEL]
       AFTER X21 INSERT X22;
       STORE IN X25.
  $DELETE-LOWERCONJ = [DELETE LOWER LEVEL CONJ-NODE]
       DELETE X22;
       STORE IN X22.
  $ASSIGN-ATT =
       IF BOTH PRESENT-ELEMENT- X19 IS OF TYPE CONJ-NODE
                 [CHECK DONT HAVE JUST PUNCTUATION COMMASTG]
               WHERE VERIFY ELEMENT- Q-CONJ EXISTS
          AND $MATCHED-ASSERTS
       THEN ALL OF $CONJ-TO-RIGHT
            [IF THERE IS A CONJ-NODE TO THE RIGHT  ]
            [OF THIS ONE, STORE IT IN X29 AND ERASE]
            [ITS PRECONJELEM NODE ATTRIBUTE],
                   $ASSIGN1
            [ASSIGN PRECONJELEM ND ATT FOR THIS CONJ-ND],
                   $ASSIGN2
            [IF X29 EXISTS ASSIGN PRECONJELEM TO ITS Q-CONJ].
  $MATCHED-ASSERTS =
     [* Routine EXPAND expects same node name on both sides of  *]
     [* CONJ-NODE, so at the following allowed frame will fail: *]
     [*                                                         *]
     [*            ASSERTION ---- &                             *]
     [*                           |                             *]
     [*                           +------- Q-CONJ               *]
     [*                                    |                    *]
     [*                                    FRAGMENT...          *]
       ITERATE GO LEFT UNTIL TEST FOR CONJ-NODE FAILS;
       IF PRESENT-ELEMENT- X191 IS ASSERTION
       THEN VALUE OF Q-CONJ OF X19 IS ASSERTION
       ELSE IF X191 IS FRAGMENT
            THEN VALUE OF Q-CONJ OF X19 IS FRAGMENT.
  $CONJ-TO-RIGHT =
       IF ITERATE GO RIGHT
          UNTIL TEST FOR CONJ-NODE
                WHERE VERIFY ELEMENT- Q-CONJ EXISTS SUCCEEDS
      @THEN $ERASE-RIGHT.
  $ERASE-RIGHT =
       STORE IN X29;
       VALUE OF ELEMENT- Q-CONJ EXISTS;
       ITERATE VERIFY $ERASE-ATT UNTIL GO RIGHT FAILS .
  $ASSIGN1 = DO PRE-POST-CONJELEM.
  $ASSIGN2 = IF BOTH X29 EXISTS
                AND $MATCHED-ASSNS
             THEN AT X29, BOTH DO PRE-POST-CONJELEM AND $RESET-X29.
  $MATCHED-ASSNS =
       IF X191 IS ASSERTION
       THEN VALUE OF Q-CONJ OF X29 IS ASSERTION
       ELSE IF X191 IS FRAGMENT
            THEN VALUE OF Q-CONJ OF X29 IS FRAGMENT.
  $RESET-X29 =
       AFTER X29 INSERT <STOP>;
       STORE IN X29;
       DELETE X29 [THIS EMPTIES REGISTER X29 ];
       GO TO X19 [STARTING POINT FOR $ASSIGN-ATT].
  $EXPAND-NEW =
          [CALL EXPAND FROM VALUE OF Q-CONJ TO EXPAND]
          [NESTED CONJUNCTIONS]
       AT VALUE OF Q-CONJ OF X25, DO EXPAND.
  $RESTORE-REG =
       GO UP [TO Q-CONJ]; GO UP [TO CONJ-NODE];
       ITERATE GO LEFT UNTIL TEST FOR CONJ-NODE FAILS
                 [GO BACK TO ORIGINAL STRING];
       DO $REGSTG [PUT ORIGINAL STRING BACK INTO X21];
       DO $REGVAL
         [PUT LAST COELEMENT OF ORIGINAL STRING BACK INTO X22].
* IS-EVENT: ASSUMED TO BE AT A LIST OF SUBCLASSES. CHECKS LIST TO
*           SEE WHETHER IT HAS A SUBCLASS ON IT CORRESPONDING TO
*           A MEDICAL EVENT. IF IT DOES 'IS-EVENT' RETURNS SUCCESSFUL.
*           OTHERWISE 'IS-EVENT' FAILS.
ROUTINE IS-EVENT =
      PRESENT-ELEMENT- HAS MEMBER SIG-CLASS;
      IF PRESENT-ELEMENT- X-IS-EV HAS MEMBER MOD-CLASS
              [MAKE SURE IT IS MOD A BODYPART OR UNIT MOD]
      THEN BOTH X-NEWLIST:= LIST SIG-CLASS WHERE INTERSECT X-IS-EV
              OF X-IS-EV IS NOT NIL
           AND X-SUBLIST:= LIST MOD-CLASS
                [TEST LIST WITHOUT MODIFIERS]
               WHERE COMPLEMENT OF X-IS-EV IS NOT NIL.
* NEXT-ADJUNCT
ROUTINE NEXT-ADJUNCT(X) =
     IF PRESENT-ELEMENT- IS EMPTY
        THEN $FIND-NEXT-ADJUNCT
     ELSE IF PRESENT-ELEMENT- IS OF TYPE ADJSET
          THEN AT VALUE, DO $AT-ADJUNCT
          ELSE $FIND-LAST-REQUIRED.
 $AT-ADJUNCT =
      [* $AT-ADJUNCT:  EXECUTED AT VALUE OF NON-EMPTY ADJSET-S    *]
      [* AND ADJAUX-ES.                                           *]
      [*      1. IF THIS VALUE IS THE ADJUNCT SOUGHT, RETURN      *]
      [*      2. ELSE, IF THIS VALUE IS AN ADJAUX (SECONDARY      *]
      [* ADJUNCT GROUPING), CALL $AT-ADJUNCT RECURSIVELY TO       *]
      [* LOOK ONE LEVEL FURTHER DOWN                              *]
      [*      3. ELSE LOCATE LAST REQUIRED ELEMENT OF THIS        *]
      [* ADJUNCT STRING AND THEN FIND THE NEXT ADJUNCT THEREAFTER *]
     EITHER TEST FOR X
     OR IF PRESENT-ELEMENT- IS OF TYPE ADJAUX
        THEN AT VALUE, DO $AT-ADJUNCT
        ELSE $FIND-LAST-REQUIRED.
  $FIND-LAST-REQUIRED =
      [* $FIND-LAST-REQUIRED:  EXECUTED AT ANY NONEMPTY NODE, IT   *]
      [* DESCENDS IN THE TREE TO THE LAST ATOM WHICH IS PART OF A  *]
      [* REQUIRED STRING ELEMENT AND THEN CALLS $FIND-NEXT-ADJUNCT *]
     ITERATET
        ITERATET GO LEFT UNTIL $REQUIRED SUCCEEDS
     UNTIL DO LAST-ELEMENT- FAILS;
     DO $FIND-NEXT-ADJUNCT.
 $REQUIRED =
     BOTH PRESENT-ELEMENT- IS NOT OF TYPE ADJSET1
     AND EITHER PRESENT-ELEMENT- IS NOT EMPTY
         OR PRESENT-ELEMENT- IS NVAR.
 $FIND-NEXT-ADJUNCT =
      [* $FIND-NEXT-ADJUNCT GOES RIGHT AND UP THE PARSE TREE  *]
      [* TO THE NEXT NON-EMPTY ELEMENT.  IF THE ELEMENT IS AN *]
      [* ADJSET OR ELEMENT OF AN ADJSET (AS COULD BE THE CASE *]
      [* FOR REPETITIVE ADJSET NODES), IT IS EXAMINED BY      *]
      [* $AT-ADJUNCT.  IF THE ELEMENT IS A REQUIRED STRING    *]
      [* ELEMENT, OR IF THERE ARE NO NON-EMPTY ELEMENTS IN    *]
      [* THE TREE, THE ROUTINE FAILS (NO MORE ADJUNCTS).      *]
     IF ITERATE
           ITERATET GO UP UNTIL GO RIGHT SUCCEEDS
        UNTIL PRESENT-ELEMENT- IS EMPTY FAILS
    @THEN IF PRESENT-ELEMENT- IS OF TYPE ADJSET
        THEN AT VALUE, DO $AT-ADJUNCT
        ELSE IF IMMEDIATE-NODE IS OF TYPE ADJSET
             THEN $AT-ADJUNCT
             ELSE FALSE
     ELSE FALSE.
*        P R O N O U N - A N T E C E D E N T S   R O U T I N E
*
*
* ROUTINE PROPOSE-ANTECEDENTS FINDS A LIST OF POSSIBLE ANTECEDENTS FOR
* A PRONOUN AND ATTACHES THIS LIST TO THE NSTG-HOST OF THIS PRONOUN.
* ***** ****************************************************************
*
*                     CONNECTIVE TRANSFORMATIONS
*
* ***** ****************************************************************
* THIS COMPONENT IS EXECUTED USING OUTPUT TREES FROM THE ENGLISH
* DECOMPOSITION COMPONENT. EACH TRANSFORMATION IN THE CONNECTIVE
* COMPONENT (WITH THE EXCEPTION OF T-FIND-HOST) CREATES A
* CONNECTIVE --PARSE-CONN-- CONNECTING ONE ASSERTION/FRAGMENT
* TO ANOTHER ASSERTION/FRAGMENT. PARSE-CONN HAS THE FOLLOWING
* STRUCTURE:
*      PARSE-CONN = X = SA + LCONNR + SA.
*        WHERE X IS THE NAME OF THE TYPE OF CONNECTIVE SUCH AS
*        'CONJOINED', 'EMBEDDED', ETC.
*      LCONNR = LCONN + HEADCONN + RCONN.
* LCONN AND RCONN ARE THE LEFT AND RIGHT ADJUNCTS OF THE CONECTIVE
* HEADCONN. THE SUBSTRUCTURE OF HEADCONN DEPENDS ON THE TYPE OF
* CONNECTIVE. IT WILL BE DESCRIBED IN EACH TRANSFORMATION.
*   IN GENERAL, WHEN ONE OF THE TRANSFORMATIONS FINDS A RELEVANT
* SUBSTRUCTURE IN AN ASSERTION 'A', IT ATTACHES A CONNECTIVE
* 'PARSE-CONN' TO THE LEFT OF 'A' AND CREATES AN ASSERTION/FRAGMENT
* 'B' FROM 'A' AND ATTACHES IT TO THE RIGHT OF 'A'. 'A' MAY BE
* CHANGED TO 'A1' IN THE PROCESS. WHEN A SUCCESSFUL CONNECTIVE
* TRANSFORMATION IS COMPLETED IN ASSERTION 'A', THE STRUCTURE
*                PARSE-CONN + A1 + B + CONJ-NODE
* REPLACES 'A'. WHEN AN ASSERTION IN 'A' IS MOVED UP, ITS CONJUNCT (IF
* IT HAS ONE) IS ALSO MOVED UP ALONG WITH CONJ-NODE SO THAT WHEN THE
* TRANSFORMATION IS COMPLETED WE HAVE:
*      PARSE-CONN + A1 + B + CONJ-NODE
*        WHERE    CONJ-NODE = CONJ + CONJUNCT OF B.
* WHEN TRANSFORMING ASSERTION 'B', THE FIRST TRANSFORMATION IS
* T-CONJ-IN-ASSERTION WHICH WILL CREATE A CONNECTIVE 'PARSE-CONN' =
* 'CONJOINED' TO THE LEFT OF 'B' AND THE CONJUNCT OF 'B' WILL BE ATTACHED
* TO THE RIGHT OF 'B'. THE ABOVE STRUCTURE WILL THEN BE:
*      PARSE-CONN + A1 + PARSE-CONN + B + CONJUNCT OF B.
T-CONJ-IN-ONESENT = IN SENTENCE:
     AT VALUE OF ELEMENT ONESENT OF TEXTLET
     DO $MOVE-CONJ [T-CONJ-IN-CENTER].
* T-CONJ-IN-CENTER
*      OPERATES WHEN THE VALUE V1 OF ONESENT/CENTER HAS A CONJUNCT
* V2. PARSE-CONN IS ATTACHED TO THE LEFT OF V1. V2 IS MOVED TO THE RIGHT
* OF V1 SO THAT WE HAVE:   PARSE-CONN + V1 + V2   .
*           PARSE-CONN = CONJOINED = SA + LCONNR + SA
*           HEADCONN = FIRST ELEMENT OF CONJ-NODE.
* IF SACONJ IS NOT EMPTY, ITS VALUE SA IS MOVED TO THE FIRST SA OF
* CONJOINED. IF 'NOT' IS IN CONJ-NODE,  DSTG = D = NOT  IS CREATED
* AND ALSO MOVED TO THE FIRST SA OF CONJOINED.
T-CONJ-IN-CENTER = IN CENTER:
     AT VALUE DO $MOVE-CONJ.
  $MOVE-CONJ =
     ITERATET $TRANSFORM-CONJ UNTIL $NEXT-CONJ FAILS.  (GLOBAL)
  $NEXT-CONJ =
     DO R(CONJ-NODE);
     STORE IN X-PCONN;
     VERIFY $GO-LEFT-ONE.
  $GO-LEFT-ONE =
     GO LEFT;
     STORE IN X-ARG1.
  $TRANSFORM-CONJ =
     DO $BUILD-CONJOINED;
     DO $ASSRT-FRAG-UP [MOVE CONJUNCTION TO LEVEL OF FRAG OR ASSERT].
  $BUILD-CONJOINED =
     BEFORE X-ARG1 INSERT
       <PARSE-CONN> (<CONJOINED> (<SA> X-SA (<NULL>)
                                 +<LCONNR> X-CONN
                                 +<SA> X-SA2 (<NULL>)));
     DO $BUILD-X-SA;
     DO $BUILD-LCONNR;
     AT FIRST ELEMENT X-HCONN OF X-PCONN DO $BUILD-HEADCONN;
     DELETE X-HCONN;
     DO $BUILD-NOT.                                             (GLOBAL)
  $ASSRT-FRAG-UP =
      REPLACE X-PCONN BY ALL ELEMENTS OF Q-CONJ OF X-PCONN;
      AT X-ARG1 GO RIGHT [* first ASSN/FRAG of Q-CONJ *];
      BOTH DO $COPY-NEG-MODAL
      AND TRANSFORM PRESENT-ELEMENT-.
  $COPY-NEG-MODAL =                                  [GLOBAL]
       [* distribute NEG and MODAL *]
      IF $NEG-MODAL-IN-CONN
      THEN BOTH $COPY-NEG-MOD AND $ASSIGN-H-NEG.
  $NEG-MODAL-IN-CONN =
      IN X-CONN,
      EITHER ELEMENT- LCONN HAS ELEMENT- LDR
             WHERE CORE- X-CONN-NEG IS H-NEG
      OR EITHER CORE- X-CONN-NEG IS 'NOR'
         OR CORE X-CONN-NEG IS H-NEG.
  $COPY-NEG-MOD =
      IF PRESENT-ELEMENT- IS ASSERTION
         WHERE ELEMENT- NEG X-SA EXISTS
      THEN REPLACE X-SA BY <NEG> (X-CONN-NEG, X-NEG)
           [REPLACE X-SA BY <NEG> (<NG> X-NEG = 'NEG':(H-NEG))]
      ELSE BOTH ELEMENT- SA X-SA EXISTS
           AND IF X-SA IS EMPTY
               THEN REPLACE X-SA BY
                    <SA> (<DSTG> (X-CONN-NEG, X-NEG))
                   [<SA> (<DSTG> (<D> X-NEG = 'NEG':(H-NEG)))]
               ELSE BEFORE VALUE OF X-SA
                   [INSERT <DSTG> (<D> X-NEG = 'NEG':(H-NEG))]
                    INSERT <DSTG> (X-CONN-NEG, X-NEG).
  $ASSIGN-H-NEG =
      BOTH X-NEG-LIST := LIST NEG-LIST
      AND AT X-NEG, ASSIGN NODE ATTRIBUTE SELECT-ATT
                    WITH VALUE X-NEG-LIST.
  $REPLACE-CENTER =
      IF PRESENT-ELEMENT- IS ONESENT
      THEN AT VALUE ITERATET $MAKE-ASSERT-FRAG
                    UNTIL DO R(CENTER) FAILS.
  $MORE =
      ITERATET GO RIGHT UNTIL TEST FOR FRAGMENT OR ASSERTION SUCCEEDS.
  $BUILD-LCONNR =
      AT X-CONN REPLACE PRESENT-ELEMENT- BY
         <LCONNR>X-CONN ( <LCONN> (<NULL>)
                        + <HEADCONN>
                        + <RCONN> (<NULL>)).  (GLOBAL)
  $BUILD-HEADCONN =
      AT X-CONN
      IF X-PCONN IS [FRENCH] AINSIQUESTG
      THEN REPLACE HEADCONN BY
           <HEADCONN> (<P> = 'AINSI_QUE':(H-CONN))
      ELSE REPLACE HEADCONN BY <HEADCONN> (X-HCONN).  (GLOBAL)
  $MAKE-ASSERT-FRAG =
      REPLACE PRESENT-ELEMENT- BY ALL ELEMENTS OF PRESENT-ELEMENT-.
  $BUILD-NOT =
      IN X-PCONN
      IF EITHER ELEMENT- 'NOT' X2 EXISTS
         OR ELEMENT- NOTOPT X2 EXISTS
            WHERE PRESENT-ELEMENT IS NOT EMPTY
      THEN BOTH AT ELEMENT NULL X1 OF X-SA
               DO $BUILD-DSTG
           AND DELETE X2.
  $BUILD-DSTG =
     REPLACE X1 BY <DSTG> ( <D> = 'NOT' ).
  $BUILD-X-SA =
     AT X-PCONN
     IF SACONJ X1 IS NOT EMPTY
     THEN BOTH AT VALUE OF X-SA
               REPLACE PRESENT-ELEMENT-
               BY VALUE OF VALUE OF X1 [SACONJ=SA=...]
          AND BOTH TRANSFORM X-SA
              AND DELETE X1 [SACONJ].
* T-CONJ-IN-ASSERTION
*     IS SIMILAR TO T-CONJ-IN-CENTER. IT OPERATES WHEN
*     ASSERTION HAS A CONJUNCT.
*     IT HANDLES SITUATIONS WHERE CONJOINED ASSERTIONS OR
*     FRAGMENTS ARE NOT UNDER CENTER.
T-CONJ-IN-ASSERTION = IN ASSERTION, FRAGMENT:
     AT PRESENT-ELEMENT- X-PRE
     BOTH DO $MOVE-CONJ [Global in T-CONJ-IN-CENTER]
     AND IF BOTH AT VALUE OF X-PRE, DO R(CONJ-NODE)
                 WHERE STORE IN X-CONJNODE
            AND ELEMENT- Q-CONJ X-QCONJ OF X-CONJNODE EXISTS
         THEN BOTH DO $MOVE-CONJS-UP
              AND AT X-PRE DO $MOVE-CONJ.
 $MOVE-CONJS-UP =
     IF X-PRE IS ASSERTION
     THEN REPLACE X-QCONJ
          BY <Q-CONJ> (<ASSERTION> (ALL ELEMENTS OF X-QCONJ))
     ELSE REPLACE X-QCONJ
          BY <Q-CONJ> (<FRAGMENT> (ALL ELEMENTS OF X-QCONJ));
     AFTER X-PRE INSERT X-CONJNODE, X-NEWCONJNODE;
     DELETE X-CONJNODE.
* T-CONJ-IN-FRAGMENT = IN FRAGMENT:
*   OPERATES WHEN AN NSTG IN FRAGMENT1 HAS A CONJUNCTION NSTG2.
*   WE CREATE PARSE-CONN + FRAGMENT1 + FRAGMENT2
*             HEAD OF PARSE-CONN = FIRST ELEMENT OF CONJ-NODE
*             FRAGMENT2 = SA (SAME AS FRAGMENT1)
*                         + NSTG2
*                         + SA (SAME AS 2ND SA OF FRAGMENT1)
T-CONJ-IN-FRAGMENT = IN FRAGMENT:
       PRESENT-ELEMENT- X-ARG1 EXISTS;
       AT VALUE DO $CONJ-CHK.
  $CONJ-CHK = ITERATET $TRANSFORM-CONJ UNTIL $NEXT-CONJ FAILS.
  $NEXT-CONJ = DO R(CONJ-NODE);
       STORE IN X-PCONN;
       ELEMENT- Q-CONJ EXISTS [* this is not punctuation *].
  $TRANSFORM-CONJ = [CREATE FRAGMENT2 = CONJOINED NSTG]
       DO $BUILD-CONJOINED [GLOBAL IN T-CONJ-IN-CENTER];
       DO $MAKE-NEW-FRAG.
  $MAKE-NEW-FRAG =
       AFTER X-ARG1 INSERT
           <FRAGMENT> X-NEW (ALL ELEMENTS OF Q-CONJ OF X-PCONN);
       DO $GET-SAS [GET SAS OF FRAGMENT1 FOR FRAGMENT2];
       DELETE X-PCONN [DELETE OLD FORM OF CONJUNCTION];
       AT X-ARG1 GO RIGHT [TO NEW FRAGMENT];
       TRANSFORM PRESENT-ELEMENT-.
  $GET-SAS =
       VALUE OF X-ARG1 EXISTS;
       EITHER PRESENT-ELEMENT- IS SA X-SA1 OR X-SA1:= NIL;
       EITHER $RIGHT-TO-SA OR X-SA2:= NIL;
       IF X-SA2 IS NOT NIL
       THEN AFTER VALUE OF X-NEW INSERT X-SA2 [ADD 2ND SA ];
       IF X-SA1 IS NOT NIL
       THEN BEFORE VALUE OF X-NEW INSERT X-SA1 [ADD 1ST SA].
  $RIGHT-TO-SA = DO R(SA);
       STORE IN X-SA2.
* T-CSSTG
*      OPERATES WHEN AN SA IN ASSERTION A = LCS + CSSTG.
*      PARSE-CONN = SUB-CONJ IS ATTACHED TO THE LEFT OF A.
*      THE ASSERTION(S) OF CSSTG IS(ARE) MOVED TO THE RIGHT OF A.
*         HEADCONN = CS  (I.E., THE FIRST ELEMENT OF CSSTG).
*         LCONN = ELEMENTS OF LCS.
*         CSSTG IS REPLACED IN A BY NULL.
T-CSSTG = IN SA, LNR, VERB [ASSERTION, FRAGMENT]:
    IF PRESENT-ELEMENT- IS LNR OR VERB
    THEN DO $BUILD-LNR-CSSTG
    ELSE IF BOTH IMMEDIATE-NODE X-PRE IS ASSERTION OR FRAGMENT
            AND $NOT-PHRASE-ATTS
         THEN DO $SA-CSSTG.
  $NOT-PHRASE-ATTS =
    BOTH ELEMENT- CSSTG EXISTS WHERE VALUE X-SUBX EXISTS
    AND EITHER X-SUBX DOES NOT HAVE NODE ATTRIBUTE PHRASE-ATT
        OR BOTH X-SUBX HAS NODE ATTRIBUTE PHRASE-ATT X-PHR-ATT
           AND X-PHR-ATT DOES NOT HAVE MEMBER TIME-PHRASE OR SOURCE-PHRASE
                                    OR INFLUENCE-PHRASE.
  $BUILD-LNR-CSSTG =
    IF DO R(CSSTG) WHERE
       STORE IN X-SA
    THEN BOTH AT X-SA, VALUE X-PCONN EXISTS
         AND ALL OF $LOOK-FOR-ASSN, $BUILD-SUBCONN.
  $LOOK-FOR-ASSN =
    AT X-SA, ASCEND TO ASSERTION OR FRAGMENT PASSING THROUGH STRING;
    STORE IN X-PRE.
  $SA-CSSTG =
    IF ELEMENT CSSTG X-SA EXISTS WHERE VALUE X-PCONN EXISTS
    THEN $BUILD-SUBCONN.
  $BUILD-SUBCONN =
    BEFORE X-PRE INSERT
           <PARSE-CONN> (<SUB-CONJ> (<SA> (<NULL>)
                                    +<LCONNR> X-CONN
                                    +<SA> (<NULL>)) ) ;
    DO $BUILD-LCONNR  [GLOBAL IN T-CONJ-IN-CENTER];
    AT FIRST ELEMENT X-HCONN OF X-PCONN DO $BUILD-HEADCONN;
    DELETE X-HCONN;
    DO $BUILD-LCONN;
    DO $MOVE-ASSERT.
  $BUILD-LCONN =
    REPLACE LCONN OF X-CONN
    BY <LCONN> (ALL ELEMENTS OF COELEMENT- LCS X-LCS OF X-SA);
    DELETE X-LCS.
  $MOVE-ASSERT =
    AFTER X-PRE INSERT ALL ELEMENTS OF X-PCONN;
    AT X-PRE DO $TRANSFORM-TO-RIGHT [GLOBAL IN T-MOVE-S-UP];
    DELETE X-SA.
* T-SA-PNCONN
*   OPERATES WHEN SA IN ASSERTION A (OR SA IN OBJECT OF A = NN/NPN/
* PNN) = PN WHERE P = H-CONN.
*      PARSE-CONN = RELATION IS ATTACHED TO THE LEFT OF A.
*      HEADCONN = P OF PN.
*      LCONN = ELEMENTS OF LP OF PN.
*      FRAGMENT B = NSTG [WHICH IS COPIED FROM NSTG OF NSTGO OF PN]
*      IS ATTACHED TO LEFT OF A.
*      PN IS REPLACED BY NULL IN A.
T-SA-PNCONN = IN ASSERTION, FRAGMENT:
      AT PRESENT-ELEMENT- X-PRE,
      EITHER BOTH $SA-IN-LEVEL [TEST SA IN ASSERTION],
             AND $SA-IN-OBJECT [SA IN OBJ = NPN, NN, PNN]
      OR TRUE.
  $SA-IN-LEVEL =
      AT VALUE ITERATE $FIND-SAPCONN
               UNTIL DO R(SA) FAILS.
  $FIND-SAPCONN =
      PRESENT-ELEMENT- X-SA EXISTS;
      AT VALUE ITERATE IF $SA-HAS-PCONN
                       THEN $BUILD-PCONN
               UNTIL DO R(PN) FAILS;
      GO TO X-SA.
  $SA-HAS-PCONN =
      BOTH PRESENT-ELEMENT- X-PN IS PN
      AND [EITHER] $PN-CONN-TEST
          [OR $P-IS-HCONN].
  $PN-CONN-TEST =
      EITHER BOTH P X-HCONN HAS NODE ATTRIBUTE SELECT-ATT
             @AND PRESENT-ELEMENT- HAS MEMBER CONN-LIST
      OR $IS-CONN-TYPE.
  $IS-CONN-TYPE =
      BOTH X-PN HAS NODE ATTRIBUTE ADVERBIAL-TYPE
      @AND PRESENT-ELEMENT- HAS MEMBER CONN-TYPE;
      AT X-PN ELEMENT P X-HCONN EXISTS.
  $SA-IN-OBJECT =
      VALUE OF ELEMENT OBJECT IS NN OR NPN OR PNN;
      DO $SA-IN-LEVEL.
  $BUILD-PCONN =
      DO $BUILD-RELATION;
      DO $BUILD-LCONN;
      IF DO $IN-RELCLAUSE
      THEN DO $MOVE-PCONN
      ELSE DO $MAKE-FRAG.                                     [GLOBAL]
  $IN-RELCLAUSE =
      AT X-PRE, DO L(PARSE-CONN);
      STORE IN X-PCONN;
      DO $FOUND-RELCLAUSE.
  $FOUND-RELCLAUSE =
        [* FIND PARSE-CONN REL-CLAUSE *]
      DO L(PARSE-CONN);
      STORE IN X-REL;
      VALUE IS REL-CLAUSE;
      CORE- HAS NODE ATTRIBUTE INDEX X-NDX;
      CORE- OF NSTG OF NSTGO OF X-PN HAS NODE ATTRIBUTE INDEX X-PNDX;
      X-NDX IS IDENTICAL TO X-PNDX.
  $MOVE-PCONN =
        [* REVERSE THE ORDER OF OPERANDS *]
      BEFORE X-REL INSERT <PARSE-CONN> (ALL ELEMENTS OF X-PCONN);
      AT X-PN REPLACE PRESENT-ELEMENT- BY <NULL>;
      BOTH BEFORE X-REL INSERT X-PRE
      AND DELETE X-PRE;
      BOTH DELETE X-REL
      AND DELETE X-PCONN.
  $BUILD-RELATION =
      BEFORE X-PRE INSERT
         <PARSE-CONN> (<RELATION> (<SA> X-SA1 (<NULL>)
                                  +<LCONNR> X-CONN
                                  +<SA> X-SA2 (<NULL>)));
      DO $BUILD-LCONNR [GLOBAL IN T-CONJ-IN-CENTER];
      DO $BUILD-HEADCONN.                            (GLOBAL)
  $BUILD-LCONN =
      IF LP X-LA OF X-PN IS NOT EMPTY
      THEN REPLACE LCONN OF X-CONN BY <LCONN> (ALL ELEMENTS OF X-LA).
  $MAKE-FRAG =
      AFTER X-PRE INSERT
         <FRAGMENT> X-FRAG ( <SA> (<NULL>)
                           + ALL ELEMENTS OF NSTGO OF X-PN);
      AT X-PN REPLACE PRESENT-ELEMENT- BY <NULL>;
      AT X-FRAG, DO $COPY-NEG-MODAL [Global in T-CONJ-IN-CENTER];
      TRANSFORM X-FRAG.
* T-FIND-CONN
*   OPERATES WHEN THERE IS A CONNECTIVE OR H-BECONN IN ASSERTION A.
* IT FINDS H-CONN/H-BECONN AND ITS TWO ARGUMENTS. A IS REPLACED BY
* PARSE-CONN + FRAGMENT1 + FRAGMENT2   WHERE:
*         PARSE-CONN = RELATION = SA. + LCONNR + SA.
*   AND   FRAGMENT1 = NSTG (THE FIRST ARGUMENT OF H-CONN/H-BECONN).
*   AND   FRAGMENT2 = NSTG (THE SECOND ARGUMENT OF H-CONN/H-BECONN).
*         HEADCONN = ATOM CORRESPONDING TO WORD WHICH IS H-CONN/H-BECONN.
* THE SEARCH FOR H-CONN/H-BECONN AND ITS ARGUMENTS IS AS FOLLOWS:
*    1) CORE-SELATT OF CORE OF VERB HAS MEMBER CONN-LIST.
*         FRAGMENT1 = NSTG OF SUBJECT.
*         FRAGMENT2 = NSTG OF OBJECT.
*       CONTENTS OF RV IN ASSERTION ARE MOVED TO RV OF VERB.
*         HEADCONN = V
*         LCONN = ELEMENTS OF LV
*         RCONN = ELEMENTS OF RV
*       ALL SA'S TO THE LEFT OF VERB ARE MOVED INTO THE FIRST SA OF
*       RELATION. ALL SA'S TO THE RIGHT OF VERB ARE MOVED INTO THE
*       LAST SA OF RELATION.
*      EX.: 'FEVER CAUSES HEADACHE.'
*            FRAGMENT1 = 'FEVER'
*            FRAGMENT2 = 'HEADACHE'
*            HEADCONN = V = 'CAUSE'
*    2) VERB IS VBE/BEREP AND OBJECT = ASTG WHERE:
*         CORE-SELATT OF ADJ = H-CONN/C-BECONN  AND
*         RA = PN
*         FRAGMENT1 = NSTG OF SUBJECT
*         FRAGMENT2 = NSTG OF NSTGO OF PN
*         HEADCONN = ADJ + LPR
*           WHERE  LPR = LP = ELEMENTS OF LP OF PN  +  P OF PN.
*       EX.: 'FEVER IS COMPATABLE WITH HEADACHE.'
*         FRAGMENT1 = 'FEVER'
*         FRAGMENT2 = 'HEADACHE'
*         HEADCONN = 'COMPATABLE WITH'
*    3) VERB IS VBE/BEREP  AND
*         OBJECT = NSTG  WHERE
*             CORE N = H-CONN/H-BECONN  AND
*             RN = PN
*         FRAGMENT1 = NSTG OF SUBJECT
*         FRAGMENT2 = NSTG OF PN
*         HEADCONN = N + LPR
*      EX.: 'FEVER IS CAUSE OF HEADACHE.'
*             FRAGMENT1 = 'FEVER'
*             FRAGMENT2 = 'HEADACHE'
*             HEADCONN = 'CAUSE OF'.
*    4) VERB IS VBE/BEREP  AND
*         OBJECT = PN  WHERE
*           P = H-CONN/H-BECONN
*         FRAGMENT1 = NSTG O  F SUBJECT
*         FRAGMENT2 = NSTG O  F PN
*         HEADCONN = P
*      EX.: 'HEADACHE IS DUE TO FEVER.'
*            FRAGMENT1 = 'HEADACHE'
*            FRAGMENT2 = 'FEVER'
*            HEADCONN = 'DUE : TO'.
*     5) VERB IS VBE/BEREP  AND
*          SUBJECT = NSTG  WHERE
*            N IS H-CONN/BECONN  AND
*            RN = PN
*          FRAGMENT1 = NSTG OF OBJECT
*          FRAGMENT2 = NSTG OF PN
*          HEADCONN = N + LPR
*      EX.: 'CAUSE OF HEADACHE IS FEVER.'
*            FRAGMENT1 = 'FEVER'
*            FRAGMENT2 = 'HEADACHE'
*            HEADCONN = 'CAUSE OF'
T-FIND-CONN = IN ASSERTION:
    PRESENT-ELEMENT- X-PRE EXISTS;
    EITHER $VERB-CONN-CHK
    OR IF X-VERB HAS MEMBER H-BECONN
       THEN BOTH $OBJ-SUB-CONN AND $CHANGE.
  $VERB-CONN-CHK =
       BOTH BOTH BOTH $GET-VERB-CORE
                 AND X-HCONN HAS NODE ATTRIBUTE SELECT-ATT X-VERB
            AND X-VERB HAS MEMBER H-CONN
       AND $VERB-CHECK.
  $GET-VERB-CORE =
     BOTH CORE X-HCONN OF VERB X-VB IS '[]'
     AND ITERATE GO RIGHT
         UNTIL PRESENT-ELEMENT- IS VING OR VEN OR TV FAILS;
     STORE IN X-HCONN.
  $CHANGE =
      [* Remove this substatement and next if T-CHANGE-OF-STATE *]
      [* is reinstituted.                                       *]
     IF CORE-SELATT OF CORE- OF X-CONN HAS MEMBER H-TMBEG OR
        H-TMEND OR H-CHANGE OR H-CHANGE-MORE OR H-CHANGE-LESS OR
        H-CHANGE-SAME
     THEN $BUILD-CHANGE-CONN.
  $BUILD-CHANGE-CONN =
     AT IMMEDIATE RELATION X-RELATION OF X-CONN
     REPLACE X-RELATION
     BY <CHANGE-OF-STATE> (ALL ELEMENTS OF X-RELATION).
  $OBJ-SUB-CONN =
        IF VALUE OF VALUE OF VALUE OF OBJECT IS ASTG X-ARG2
        THEN IF EITHER $OBJ-IS-CONN
                OR $OBJ-IS-EVENT
             THEN $BUILD-CONNFRAG
             ELSE TRUE [DO NOT SPLIT]
        ELSE EITHER $OBJ-OTHER-CONN
             OR TRUE [do not split].
  $OBJ-IS-CONN =
       CORE-SELATT OF CORE- X-TEMP OF X-ARG2 HAS MEMBER CONNECTIVE-LIST;
       X-HCONN:= X-TEMP;
       DO $SUBJ-ARG1;
       DO $ARG2-N [GET 'FEVER' IN 'HEADACHE IS CAUSE-OF FEVER'].
  $OBJ-IS-EVENT = ALL OF $SUBJ-ARG1, $ARE-EQUIV
        [2 INDEPENDENT EVENTS SUCH AS 'HEADACHE WAS PAINFUL'].
  $OBJ-OTHER-CONN =
        IF AT OBJECT
           BOTH CORE IS PN X-PN
           AND EITHER CORE-SELATT OF P X-TEMP HAS MEMBER
                      CONNECTIVE-LIST WHERE BOTH X-HCONN:= X-TEMP
                                            AND $SUBJ-ARG1
               OR ALL OF $ARG2-PN, $SUBJ-ARG1, $ARE-EQUIV
        THEN BOTH $ARG2-PN AND $BUILD-CONNFRAG
                  [SPLIT INTO 2 FRAGMENTS]
        ELSE $SUBJ-N-CONN [SEE IF SUBJECT IS CONNECTIVE].
  $OBJ-N-CONN =
      IF AT OBJECT BOTH CORE X-HCONN IS N
                  @AND BOTH CORE-SELATT X-S EXISTS
                       AND ALL OF $ARG2-N, $SUBJ-ARG1, $ARE-EQUIV
      THEN $BUILD-CONN-N-N
      ELSE $SUBJ-N-CONN.
  $SUBJ-N-CONN =
      IF EITHER BOTH CORE-SELATT OF CORE- X-TEMP OF SUBJECT HAS
                     MEMBER CONNECTIVE-LIST
                AND BOTH X-HCONN:= X-TEMP
                    AND $OBJ-ARG1
         OR AT X-TEMP BOTH RIGHT-ADJUNCT IS PN X-PN
                           WHERE NSTGO X-ARG2 EXISTS
                      AND BOTH $OBJ-ARG1
                          AND $ARE-EQUIV
      THEN $BUILD-CONNFRAG
      ELSE IF X-VERB HAS MEMBER H-BECONN
              WHERE [X-HCONN := CORE OF X-VB] DO $GET-VERB-CORE
           THEN $VERB-CHECK.
  $ARE-EQUIV =
      EITHER X-S HAS MEMBER CONNECTIVE-LIST
      OR $ARE-FRMT-EQUIV.
  $ARE-FRMT-EQUIV =
      DO $SETUP-X1-X2;
      X-LISTOFLISTS := LIST FORMAT-EQUIV-CLASS;
      ITERATET SUCCESSORS X-LISTOFLISTS OF X-LISTOFLISTS IS NOT NIL
      UNTIL BOTH X-NEWLIST := HEAD OF X-LISTOFLISTS
            AND $CHK-X1-X2 SUCCEEDS.
  $SETUP-X1-X2 =
      BOTH CORE-ATT X1 OF CORE- OF X-ARG1 EXISTS
      AND CORE-ATT X2 OF CORE- OF X-ARG2 EXISTS.
  $CHK-X1-X2 =
      BOTH INTERSECT OF X1 IS NOT NIL
      AND INTERSECT OF X2 IS NOT NIL.
  $OBJ-ARG1 = AT X-PRE BOTH CORE IS N
                      @AND IMMEDIATE NSTG X-ARG1 EXISTS.
  $VERB-CHECK =
      IF X-VERB HAS MEMBER H-CHANGE OR H-CHANGE-MORE OR H-CHANGE-LESS
                        OR H-CHANGE-SAME
      THEN $SUBJ-TO-FRAG
      ELSE $VERB-CONN.
  $SUBJ-TO-FRAG = VALUE OF SUBJECT OF X-PRE IS NSTG X-ARG2;
      PRESENT-ELEMENT- IS NOT EMPTY;
      DO $BUILD-RELATION;
      DO $BUILD-FRAG2;
      DO $BUILD-CHANGE-CONN.
  $BUILD-FRAG2 = AFTER X-PRE INSERT
                      <FRAGMENT>X-FRAG (<SA> (<NULL>) + X-ARG2);
      REPLACE X-ARG2 BY <NULL>;
      TRANSFORM X-FRAG.
  $VERB-CONN =
      BOTH EITHER VALUE OF SUBJECT IS NSTG X-ARG1
           OR VALUE X-ARG1 OF SUBJECT IS NOT NULL [6.12.97]
      AND EITHER VALUE OF OBJECT IS NSTGO X-ARG2
          OR VALUE OF OBJECT IS OBJECTBE WHERE VALUE X-ARG2 EXISTS;
      DO $MOVE-STRING-RV;
      DO $BUILD-CONNFRAG.
  $MOVE-STRING-RV =
      AT X-PRE [ASSERTION]
      IF RV X1 IS NOT EMPTY
      THEN IF RV X-RV OF VERB IS NOT EMPTY
           THEN AFTER LAST-ELEMENT OF X-RV
                INSERT VALUE OF X1
           ELSE REPLACE X-RV BY X1;
      REPLACE VALUE OF X1 BY <NULL>.
  $ARG2-PN =
      NSTGO X-ARG2 OF X-PN EXISTS.
  $SUBJ-ARG1 =
      AT X-PRE VALUE OF SUBJECT IS NSTG X-ARG1 .
  $BUILD-CONNFRAG =
      ALL OF $BUILD-RELATION ,
             $BUILD-FRAGS, $BUILD-LCONN-RCONN,
             $MOVE-SAS, $REPLCE-ASSRT ARE TRUE .
  $BUILD-FRAGS =
      BEFORE X-PRE INSERT <FRAGMENT> X1 ( <SA> (<NULL>)
                                        + X-ARG1
                                        + <SA> (<NULL>) )
                        + <FRAGMENT> X2 ( <SA> (<NULL>)
                                        + ALL ELEMENTS OF X-ARG2
                                        + <SA> (<NULL>) );
      TRANSFORM X2;
      IF $IS-NMOD-FRAG THEN $ERASE-X1
      ELSE TRANSFORM X1.
  $IS-NMOD-FRAG =
    [* Verify if the present structure is an NMOD structure  *]
    [* created by T-REL-CLAUSE.  In which case, X1 is        *]
    [* duplicated from x and should be erased. The structure *]
    [*                                                       *]
    [*   PARSE-CONN----x----PARSE-CONN----X1----X2           *]
    [*       |                  |                            *]
    [*       ...NMOD            ...H-CONN                    *]
    [*                                                       *]
    [* is simply:                                            *]
    [*                                                       *]
    [*   PARSE-CONN----x----X2                               *]
    [*       |                                               *]
    [*       ...H-CONN                                       *]
    [*                                                       *]
      AT X1, GO LEFT;
      PRESENT-ELEMENT- X1-CONN IS PARSE-CONN;
      GO LEFT;
      PRESENT-ELEMENT- IS ASSERTION OR FRAGMENT;
      GO LEFT;
      PRESENT-ELEMENT- X-NMOD IS PARSE-CONN;
      EITHER BOTH VALUE IS REL-CLAUSE
             AND CORE- OF LCONNR OF VALUE IS '[NMOD]'
      OR BOTH VALUE IS SUB-CONJ
         AND CORE- OF LCONNR OF VALUE IS '[WHILE]'.
  $ERASE-X1 =
      AT X-NMOD, REPLACE PRESENT-ELEMENT- BY X1-CONN, XNEW-CONN;
      AT VALUE OF XNEW-CONN, BOTH LCONNR X-CONN EXISTS
                             AND BOTH FIRST SA X-SA1 EXISTS
                                 AND SECOND SA X-SA2 EXISTS;
      BOTH DELETE X1-CONN
      AND DELETE X1.
  $BUILD-LCONN-RCONN =
      IF LEFT-ADJUNCT-POS X-LA [???] OF X-HCONN IS NOT EMPTY
      THEN AT X-CONN REPLACE LCONN BY <LCONN> (ALL ELEMENTS OF X-LA);
      IF RIGHT-ADJUNCT-POS X-RA OF X-HCONN IS NOT EMPTY
      THEN AT X-CONN REPLACE RCONN BY <RCONN> (ALL ELEMENTS OF X-RA).
  $MOVE-SAS =
      AT VALUE OF X-PRE ITERATE VERIFY $MOVE-TO-SA1
                        UNTIL $TEST-FOR-SA FAILS;
      AT VERB OF X-PRE ITERATET $MOVE-TO-SA2
                       UNTIL $TEST-FOR-SA FAILS.
  $MOVE-TO-SA1 =
      BOTH X-MOVE := X-SA1
      AND $MOVE-TO-SA.
  $MOVE-TO-SA =
      IF PRESENT-ELEMENT X1 IS NOT EMPTY
      THEN IF X-MOVE IS EMPTY
           THEN REPLACE X-MOVE BY X-MOVE (ALL ELEMENTS OF X1)
           ELSE AFTER LAST-ELEMENT OF X-MOVE INSERT ALL ELEMENTS OF X1.
  $TEST-FOR-SA =
      GO RIGHT;
      PRESENT-ELEMENT- IS NOT VERB;
      IF PRESENT-ELEMENT- IS NOT SA THEN $TEST-FOR-SA.
  $MOVE-TO-SA2 =
      BOTH X-MOVE := X-SA2
      AND $MOVE-TO-SA.
  $REPLCE-ASSRT =
      DELETE X-PRE.
  $ARG2-N =
      AT X-HCONN RIGHT-ADJUNCT IS PN X-PN
                 WHERE NSTGO X-ARG2 EXISTS.
  $BUILD-CONN-N-N =
      DO $BUILD-RELATION;
      DO $BUILD-FRAGS;
      AFTER LAST-ELEMENT OF HEADCONN OF X-CONN
           INSERT <LPR> ( <LP> (ALL ELEMENTS OF LP OF X-PN)
                        + P OF X-PN
                        + <RP> (<NULL>));
      DELETE X-PN;
      ALL OF $BUILD-LCONN-RCONN, $MOVE-SAS, $REPLCE-ASSRT ARE TRUE.
* T-RVEN-CONN
*     OPERATES WHEN RIGHT-ADJUNCT = VENPASS WHERE VEN = H-CONN.
*     PARSE-CONN = RELATION IS ATTACHED TO LEFT OF IMMEDIATE ASSERTION
*        OR FRAGMENT A.
*     HEADCONN = VEN OF VENPASS
*     LCONN = ELEMENTS OF LV OF LVENR
*     FRAGMENT B = NSTG [WHICH IS A COPY OF NSTG OF NSTGO OF SA:PN]
*        IS ATTACHED TO RIGHT OF A.
*     VENPASS IN A IS REPLACED BY NULL.
T-RVEN-CONN = IN VENPASS:
      PRESENT-ELEMENT- X-VENP EXISTS;
      IF BOTH ASCEND TO RADJSET
              WHERE AT X-VENP DO $VEN-CONN-TEST
         AND NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
      THEN $SPLIT.
  $VEN-CONN-TEST =
      BOTH CORE- X-HCONN OF LVENR HAS NODE ATTRIBUTE SELECT-ATT
           WHERE PRESENT-ELEMENT- HAS MEMBER CONN-LIST
      AND EITHER BOTH LAST-ELEMENT- X-SA OF X-VENP IS NOT EMPTY
                 AND VALUE X-SUBJ OF X-SA IS PN
                     WHERE ELEMENT P IS 'PAR' OR 'BY'
          OR EITHER BOTH ELEMENT- PASSOBJ X-SUBJ IS NOT EMPTY
                    AND IF VALUE OF X-SUBJ IS PN
                       @THEN STORE IN X-SUBJ
             OR BOTH RIGHT-ADJUNCT-POS X-RV OF X-HCONN IS NOT EMPTY
                AND VALUE X-SUBJ OF X-RV IS PN
                    WHERE ELEMENT- P IS 'DE' OR 'PAR' OR 'BY' OR 'OF'.
  $SPLIT =
      AT X-VENP ASCEND TO ASSERTION OR FRAGMENT
                PASSING THROUGH STRING;
      STORE IN X-PRE;
      DO $BUILD-VENCONN.
  $BUILD-VENCONN =
      ALL OF $BUILD-RELATION [GLOBAL IN T-SA-PNCONN],
             $BUILD-CONN-ADJ,
             $MAKE-FRAG.
  $BUILD-CONN-ADJ =
      IF LV X-LV OF X-HCONN IS NOT EMPTY
      THEN REPLACE LCONN OF X-CONN BY <LCONN> (ALL ELEMENTS OF X-LV);
      IF BOTH X-SA EXISTS
         AND P OF X-SUBJ IS NOT EMPTY
      THEN REPLACE RCONN OF X-CONN BY <RCONN> (P OF X-SUBJ).
  $MAKE-FRAG =
      AFTER X-PRE INSERT
         <FRAGMENT>X-FRAG ( <SA> (<NULL>)
                          + ALL ELEMENTS OF NSTGO OF X-SUBJ);
      AT X-VENP REPLACE PRESENT-ELEMENT- BY <NULL>;
      TRANSFORM X-FRAG.
* T-RVING-CONN
*     OPERATES WHEN RIGHT-ADJUNCT = VINGO WHERE VING = H-CONN.
*     PARSE-CONN = RELATION IS ATTACHED TO LEFT OF IMMEDIATE ASSERTION
*        OR FRAGMENT A.
*     HEADCONN = VING OF VINGO
*     LCONN = ELEMENTS OF LV OF LVINGR
*     FRAGMENT B = NSTG [WHICH IS A COPY OF NSTG OF NSTGO OF SA:PN]
*        IS ATTACHED TO RIGHT OF A.
*     VINGO IN A IS REPLACED BY NULL.
T-RVING-CONN = IN VINGO:
      PRESENT-ELEMENT- X-VINGP EXISTS;
      IF BOTH ASCEND TO RADJSET
              WHERE AT X-VINGP DO $VING-CONN-TEST
         AND NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
      THEN $SPLIT.
  $VING-CONN-TEST =
    BOTH CORE- X-HCONN OF LVINGR HAS NODE ATTRIBUTE SELECT-ATT
         WHERE BOTH PRESENT-ELEMENT- HAS MEMBER CONN-LIST
               AND PRESENT-ELEMENT- DOES NOT HAVE MEMBER H-SHOW
                   OR H-PTLOC
    AND EITHER BOTH ELEMENT- OBJECT X-SUBJ IS NOT EMPTY
               AND IF VALUE OF X-SUBJ IS PN
                  @THEN STORE IN X-SUBJ
        OR BOTH RIGHT-ADJUNCT-POS X-RV OF X-HCONN IS NOT EMPTY
           AND VALUE X-SUBJ OF X-RV IS PN
               WHERE ELEMENT- P IS 'TO'.
  $SPLIT =
      AT X-VINGP ASCEND TO ASSERTION OR FRAGMENT
                 PASSING THROUGH STRING;
      STORE IN X-PRE;
      DO $BUILD-VINGCONN.
  $BUILD-VINGCONN =
      ALL OF $BUILD-RELATION [GLOBAL IN T-SA-PNCONN],
             $BUILD-CONN-ADJ,
             $MAKE-FRAG.
  $BUILD-CONN-ADJ =
      IF LV X-LV OF X-HCONN IS NOT EMPTY
      THEN REPLACE LCONN OF X-CONN BY <LCONN> (ALL ELEMENTS OF X-LV);
      IF P OF X-SUBJ IS NOT EMPTY
      THEN REPLACE RCONN OF X-CONN BY <RCONN> (P OF X-SUBJ).
  $MAKE-FRAG =
      EITHER BOTH VALUE OF X-SUBJ IS NSTGO
             AND AFTER X-PRE INSERT
                 <FRAGMENT>X-FRAG ( <SA> (<NULL>)
                                  + ALL ELEMENTS OF NSTGO OF X-SUBJ)
      OR BOTH VALUE OF X-SUBJ IS NPN X-NPN
         AND AFTER X-PRE INSERT
             <ASSERTION>X-FRAG
                    (<SA> (<NULL>)
                    +<SUBJECT> (ALL ELEMENTS OF NSTGO OF X-NPN)
                    +<SA> (<NULL>)
                    +<NEG> (<NULL>)
                    +<TENSE> (<NULL>)
                    +<SA> (<NULL>)
                    +<VERB> (<LV> (<NULL>)
                            +<VVAR> (<V> = '[]' : (VBE))
                            +<NEGV> (<NULL>)
                            +<RV> (<NULL>))
                    +<SA> (<NULL>)
                    +<OBJECT> (<OBJECTBE> (ALL ELEMENTS OF PN OF X-NPN))
                    +<RV> (<NULL>)
                    +<SA> (<NULL>));
      AT X-VINGP REPLACE PRESENT-ELEMENT- BY <NULL>;
      TRANSFORM X-FRAG.
* T-RADJ-CONN
*     OPERATES WHEN RIGHT-ADJUNCT = PN WHERE P = H-CONN.
*     PARSE-CONN = RELATION IS ATTACHED TO LEFT OF IMMEDIATE ASSERTION
*        OR FRAGMENT A.
*     HEADCONN = P OF PN
*     LCONN = ELEMENTS OF LN OF PN
*     FRAGMENT B = NSTG [WHICH IS A COPY OF NSTG OF NSTGO OF PN]
*        IS ATTACHED TO RIGHT OF A.
*     PN IN A IS REPLACED BY NULL.
T-RADJ-CONN = IN PN:
      PRESENT-ELEMENT- X-PN EXISTS
      WHERE STORE IN X-CORE;
      IF BOTH ONE OF $PN-IN-OBJECTBE, $PN-IN-RADJ
         AND NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
      THEN EITHER $SHARE-CONNECTIVE
           OR $SPLIT.
  $PN-IN-RADJ =
      ASCEND TO OBJECT OR RV OR FRAGMENT PASSING THROUGH N-OBJ-IN-STR
      WHERE AT X-PN DO $PN-CONN-TEST [GLOBAL IN T-SA-PNCONN].
  $PN-IN-OBJECTBE =
      AT X-PN, BOTH IMMEDIATE OBJECTBE EXISTS
               AND DO $PN-CONN-TEST [GLOBAL IN T-SA-PNCONN].
  $SHARE-CONNECTIVE =
      BOTH ELEMENT- P X-P OF X-PN HAS NODE ATTRIBUTE
           SHARED-CONNECTIVE X-CONN
      AND BOTH AFTER X-CONN INSERT X-P
          AND $MAKE-FRAG.
  $MAKE-FRAG =
      AT X-PN ASCEND TO ASSERTION OR FRAGMENT
                  PASSING THROUGH STRING;
      STORE IN X-PRE;
      AFTER X-PRE INSERT
          <FRAGMENT> X-FRAG ( <SA> (<NULL>)
                            + ALL ELEMENTS OF NSTGO OF X-PN);
     [AT X-PN REPLACE PRESENT-ELEMENT- BY <NULL>;]
      DELETE X-PRE;
      TRANSFORM X-FRAG.
  $SPLIT =
     IF X-PN IS OCCURRING IN ADJSET
     THEN $1
     ELSE IF IMMEDIATE OBJECT EXISTS
             WHERE BOTH CORE- OF COELEMENT- VERBAL IS VBE OR H-TTGEN
                   AND COELEMENT- SUBJECT X-SUBJ EXISTS
          THEN $2.
  $2 = AT X-SUBJ ASCEND TO ASSERTION OR FRAGMENT
                 PASSING THROUGH STRING;
       STORE IN X-PRE;
       ALL OF $BUILD-PCONN, $IMPLICIT-FUTURE.
  $1 = AT X-PN BOTH HOST- X-PNHOST EXISTS
               AND ASCEND TO ASSERTION OR FRAGMENT
                   PASSING THROUGH STRING;
       STORE IN X-PRE;
       BOTH DO $BUILD-PCONN
       AND DO $IMPLICIT-FUTURE.
  $IMPLICIT-FUTURE =
     [* Structure "TTGEN pour TTT" (in order to) implies FUTURE *]
     [* Structure "TTGEN for TXCLIN" (in order to) implies FUTURE *]
     IF BOTH BOTH X-PNHOST IS H-TTGEN
             AND CORE- OF X-CONN IS 'POUR' OR 'POUR QUE'
                 OR 'AFIN QUE' OR 'AFIN DE'
                 OR 'IN ORDER TO' OR 'IN ORDER FOR' OR 'FOR'
        AND CORE- OF NSTG OF X-FRAG IS H-TTSURG OR H-TTMED
                 OR H-TTCOMP OR H-TTGEN OR H-TXCLIN [OR H-INST]
     THEN DO $BUILD-FUTURE.
  $BUILD-FUTURE =
     X-TENSEATT := SYMBOL FUT-IMP;
     X-TENSELIST := NIL;
     BOTH PREFIX X-TENSEATT TO X-TENSELIST
     AND AT CORE- OF NSTG OF X-FRAG
         ASSIGN PRESENT ELEMENT NODE ATTRIBUTE TENSE-ATT
                WITH VALUE X-TENSELIST.
* T-OBJBE-CONN
*     OPERATES WHEN OBJECT = PN WHERE P = H-CONN.
*     PARSE-CONN = RELATION IS ATTACHED TO LEFT OF IMMEDIATE ASSERTION
*        OR FRAGMENT A.
*     HEADCONN = P OF PN
*     LCONN = ELEMENTS OF LN OF PN
*     FRAGMENT B = NSTG [WHICH IS A COPY OF NSTG OF NSTGO OF PN]
*        IS ATTACHED TO THE RIGHT OF A
*     PN IN A IS REPLACED BY NULL.
T-OBJBE-CONN = IN PN:
      PRESENT-ELEMENT- X-PN EXISTS
      WHERE STORE IN X-CORE;
      IF BOTH ASCEND TO OBJECT OR RV PASSING THROUGH N-OBJ-IN-STR
              WHERE AT X-PN
                    EITHER DO $PN-CONN-TEST [GLOBAL IN T-SA-PNCONN]
                    OR $P-IS-BECONN
         AND NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
      THEN ITERATET DO $MAKE-FRAG
           UNTIL DO $CONJ-IN-PN FAILS.
  $CONJ-IN-PN =
      AT ELEMENT- NSTGO OF X-PN ELEMENT- CONJ-NODE X-CONJ EXISTS.
  $P-IS-BECONN = ATTRIBUTE-LIST OF X-HCONN HAS MEMBER BECONN-LIST.
  $MAKE-FRAG =
      AT X-PN ASCEND TO ASSERTION OR FRAGMENT
                  PASSING THROUGH STRING;
      STORE IN X-PRE;
      BEFORE X-PRE INSERT
        <PARSE-CONN> (<CONJOINED> (<SA> X-SA (<NULL>)
                                  +<LCONNR> X-CONN
                                  +<SA> X-SA2 (<NULL>)));
      DO $BUILD-LCONNR;
      AT FIRST ELEMENT X-HCONN OF X-CONJ DO $BUILD-HEADCONN;
      AFTER X-PRE INSERT
          <FRAGMENT> X-FRAG ( <SA> (<NULL>)
                            + ALL ELEMENTS OF Q-CONJ OF X-CONJ);
      DELETE X-CONJ;
      TRANSFORM X-FRAG.
* T-MOVE-S-UP
*   OPERATES WHEN VALUE OF SUBJECT/OBJECT OF ASSERTION A IS AN
*   ASSERTION B.
*      PARSE-CONN = EMBEDDED   IS ATTACHED TO THE LEFT OF A.
*      B IS MOVED TO THE RIGHT OF A.
*      IN A, ASSERTION B IS REPLACED BY <NULL>, WHICH IS ASSIGNED NODE
*            ATTRIBUTE EMBED-SUBJ/EMBED-OBJ.
T-MOVE-S-UP = IN ASSERTION:
     BOTH $EMBEDDED-SUBJ
     AND $EMBEDDED-OBJ.
  $EMBEDDED-SUBJ =
     IF VALUE OF SUBJECT X-ELEM OF PRESENT-ELEMENT- X-PRE IS SN X-S
        WHERE ELEMENT- ASSERTION X-ASSERT EXISTS
     THEN $MOVE-UP.
  $MOVE-UP =
     BEFORE X-PRE INSERT
        <PARSE-CONN> (<EMBEDDED> (<SA> (<NULL>)
                                 +<LCONNR> X-CONN
                                 +<SA> (<NULL>)));
     DO $BUILD-LCONNR [GLOBAL IN T-CONJ-IN-CENTER];
     EITHER $EMBED-OBJ OR $EMBED-SUBJ;
     DO $MOVE-S.
  $EMBED-SUBJ =
     IF X-ELEM IS SUBJECT
     THEN AT X-CONN REPLACE HEADCONN BY
          <HEADCONN> X-HEADCONN (<GRAM-NODE> = '[EMBEDDED-SUBJ]').
  $EMBED-OBJ =
     IF X-ELEM IS OBJECT
     THEN AT X-CONN REPLACE HEADCONN BY
          <HEADCONN> X-HEADCONN (<GRAM-NODE> = '[EMBEDDED-OBJ]').
  $MOVE-S =
     AFTER X-PRE INSERT ALL ELEMENTS OF IMMEDIATE-NODE- OF X-ASSERT;
     AT X-ASSERT BOTH REPLACE PRESENT-ELEMENT BY <NULL>X-NULL
                 AND IF COELEMENT- CONJ-NODE X-TEMP OF X-NULL EXISTS
                       [WHERE ELEMENT- Q-CONJ IS EMPTY]
                     THEN DELETE X-TEMP;
     AT X-PRE IF FOLLOWING-ELEMENT IS NOT ASSERTION OR FRAGMENT
              @THEN DELETE PRESENT-ELEMENT-;
     AT X-PRE DO $TRANSFORM-TO-RIGHT;
     DO $SET-NODE-ATTS.
  $TRANSFORM-TO-RIGHT =
     BOTH FOLLOWING-ELEMENT- EXISTS
     @AND TRANSFORM PRESENT-ELEMENT-.
  $DELETE = AT X-DEL REPLACE PRESENT-ELEMENT- BY <NULL>.
  $SET-NODE-ATTS =
     EITHER BOTH X-HEADCONN SUBSUMES '[EMBEDDED-SUBJ]'
            AND AT X-NULL
                ASSIGN PRESENT ELEMENT NODE ATTRIBUTE EMBED-SUBJ
     OR BOTH X-HEADCONN SUBSUMES '[EMBEDDED-OBJ]'
        AND AT X-NULL
            ASSIGN PRESENT ELEMENT NODE ATTRIBUTE EMBED-OBJ.
  $EMBEDDED-OBJ =
     BOTH $WRITE-ELEMTRACE
     AND
     IF BOTH ELEMENT- OBJECT X-ELEM EXISTS
        AND EITHER ELEMENT- ASSERTION X-ASSERT OF OBJECT X-S EXISTS
            OR EITHER CORE- X-S OF X-S HAS ELEMENT- ASSERTION X-ASSERT
               OR EITHER X-S IS NTHATS OR PNTHATS
                         WHERE BOTH ELEMENT- THATS X-S EXISTS
                               AND X-S HAS ELEMENT- ASSERTION X-ASSERT
                  OR $VSENT-VERB
     THEN $MOVE-UP.
  $WRITE-ELEMTRACE =
     WRITE ON DIAG '*** ELEMENT- TRACE ***'; WRITE ON DIAG END OF LINE;
     WRITE ON DIAG IDENTIFICATION;
     WRITE ON DIAG SENTEXT [SOURCE];
    [WRITE ON DIAG PARSE TREE WITH WORD FORMS;]
     WRITE ON DIAG END OF LINE.
  $VSENT-VERB =
    [EITHER]CORE-SELATT OF CORE- OF VERB OF X-PRE HAS MEMBER VSENT3
    [OR ATTRIBUTE-LIST OF CORE- OF VERB OF X-PRE HAS MEMBER VSENT3];
     X-OBJ:= X-ELEM;
     DO $HOST-IS-OBJ [get OBJECT of VERB];
     AT X-HOST [CORE of OBJECT] IMMEDIATE NSTG X-ARG1 EXISTS;
     REPLACE PRESENT-ELEMENT- BY
              [* make it into a separate FRAGMENT and move up *]
           <FRAGMENT> (<SA>(<NULL>)
                      + X-ARG1
                      +<SA>(<NULL>)).
* T-SENTENTIAL-OP
*    OPERATES WHEN 1. SUBJECT NOUN IS USED AS AN NSENT1,NSENT2 OR NSENT3.
*                  2. VERB IS USED AS A VSENT1,VSENT2,VSENT3,VSENT4.
*                  3. OBJECT ADJ IS A VSENT1, ASENT1, ASENT3.
*     IT ASSIGNS ASSERTION FORMAT-ATT WITH VALUE FRMT00 SIGNIFYING
*     THAT ASSERTION IS A SENTENTIAL OPERATOR.
*
T-SENTENTIAL-OP = IN ASSERTION:
        IF BOTH PRESENT-ELEMENT- DOES NOT HAVE ATTRIBUTE PHRASE-ATT
                [* special phrases e.g. INFO-SOURCE *]
           AND ONE OF $SUBJ-OP, $VERB-OP, $OBJ-OP
        THEN $ASSIGN-00.
  $SUBJ-OP = AT CORE- OF SUBJECT DO $OPERATOR-CHK.
  $VERB-OP = AT CORE- OF VERB DO $OPERATOR-CHK.
  $OBJ-OP = AT CORE- OF OBJECT DO $OPERATOR-CHK.
  $OPERATOR-CHK =
     BOTH PRESENT-ELEMENT- HAS NODE ATTRIBUTE SELECT-ATT
     @AND PRESENT-ELEMENT- HAS MEMBER OPERATOR-LIST.
  $ASSIGN-00 = BOTH X-TYPE:= LIST FRMT00-LIST
               AND ASSIGN NODE ATTRIBUTE FORMAT-ATT WITH VALUE X-TYPE.
* T-ASSERT-TO-CONJ
*     OPERATES WHEN AN LNR HAS TWO OR MORE ASSERTIONS (ASSERT A, ASSERT B,
*   ETC. ) AS RIGHT SISTERS.  ASSERT A AND ASSERT B ARE CREATED BY
*   ENGLISH TFORMS T-RN-WH AND/OR T-RN-FILLIN.
*   THE FOLLOWING SITUATIONS ARE COVERED BY T-ASSERT-TO-CONJ:
*         (1) LNR + ASSERT A + ASSERT B
*         (2) LNR + ASSERT A + ASSERT B + CONJ-NODE OF B
*         (3) LNR + ASSERT A + CONJ-NODE OF A + ASSERT B
*         (4) LNR + ASSERT A + CONJ-NODE OF A + ASSERT B + CONJ-NODE OF B
*     T-ASSERT-TO-CONJ TRANSFORMS ASSERT B INTO ANDSTG = CONJ-NODE OF A
*     (SITUATIONS (1) AND (2)).  IF CONJ-NODE OF ASSERT A ALREADY EXISTS,
*     ANDSTG IS BUILT CONTAINING ASSERT B.  THIS ANDSTG IS INSERTED AFTER
*     $POSTCONJ OF ASSERT A (3,4).
*     WHEN CONJ-NODE OF B EXISTS, IT IS INSERTED AFTER $POSTCONJ
*     OF A (= COPY OF B IN NEWLY CREATED ANDSTG) (4).
*     ORIGINAL ASSERT B AND ITS CONJ-NODES ARE DELETED IN ALL SITUATIONS.
*     IN ADDITION, NODE ATTRIBUTES PRECONJELEM AND POSTCONJELEM ARE SET
*     TO AND FROM ELEMENTS IN NEWLY CREATED CONJ-NODES.
T-ASSERT-TO-CONJ = IN LNR, LAR:
     IF GO RIGHT
     @THEN BOTH STORE IN X-FIRST [1ST ASSERTION]
           AND EITHER ITERATE $FIND-NEXT
               OR TRUE.
  $FIND-NEXT =
     AT X-FIRST
     GO RIGHT;
     EITHER $INSERT-ASSERT
     OR $INSERT-CONJ.
  $INSERT-ASSERT =
     TEST FOR ASSERTION OR FRAGMENT;
     STORE IN X-MOVE;
     DO $CREATE-CONJ.
  $INSERT-CONJ =
     TEST FOR CONJ-NODE;
     BOTH GO RIGHT
    @AND IF TEST FOR CONJ-NODE
        @THEN AT PRESENT-ELEMENT- X-MOVE DO $CREATE-CONJ
         ELSE $INSERT-ASSERT.
  $CREATE-CONJ =
     AT X-FIRST, EITHER ITERATE $POSTCONJ
                 OR TRUE;
     STORE IN X-ADDTOCONJ;
       [* Adjust the case when X-ADDTOCONJ is just *]
       [* an argument of CONJ-NODE X-MOVE, in this *]
       [* case, (pre)conjunct is the desired node. *]
     IF VALUE OF ELEMENT- Q-CONJ OF X-MOVE
        IS IDENTICAL TO X-ADDTOCONJ
     THEN X-ADDTOCONJ HAS NODE ATTRIBUTE PRECONJELEM X-ADDTOCONJ;
     IF X-MOVE IS ASSERTION OR FRAGMENT
     THEN $BUILD-CONJ
     ELSE X-MOVE IS OF TYPE CONJ-NODE
                    WHERE DO $CONJ-MOVE.
  $BUILD-CONJ =
     AFTER X-ADDTOCONJ
     INSERT <ANDSTG> X-NEWCONJ ('[&]'
                               + <NULL> [NOT]
                               + <SACONJ> (<NULL>)
                               + <Q-CONJ> (X-MOVE ));
     DELETE X-MOVE;
     AT X-NEWCONJ
     DO PRE-POST-CONJELEM [ROUTINE SETS PRE- AND POST- CONJELEMS].
  $CONJ-MOVE =
     AFTER X-ADDTOCONJ INSERT X-MOVE [, X-NEWCONJ];
     AT X-ADDTOCONJ GO RIGHT WHERE STORE IN X-NEWCONJ;
     DELETE X-MOVE;
     AT X-NEWCONJ
     DO PRE-POST-CONJELEM [ROUTINE SETS PRE- AND POST- CONJELEMS].
* T-EXPAND-REFPT
*   OPERATES ON PN WHEN:
*      1) THERE IS A NODE ATTRIBUTE TIME-ADVERBIAL ON PN AND
*         N IS PN IS NOT NTIME1/NTIME2/H-TMLOC/H-AGE
*  OR  2) HOST OF PN IS NTIME1/NTIME2/H-TMLOC
* ASSERTION A IS FOUND BY GOING UP TO ASSERTION FROM PN.
*      PARSE-CONN = REL-CLAUSE IS ATTACHED TO THE LEFT OF A.
*      HEADCONN = 'T-EXPAND-REFPT'.
*      FRAGMENT B = NSTG OF PN IS ATTACHED TO THE RIGHT OF A. IF N IS
*                  *H-HOSP THERE IS A FURTHER CHECK - SEE $CHECK-H-HOSP.
T-EXPAND-REFPT = IN PN: TRUE.
  $SPLIT =
     ALL OF $MARKIT-REFPT, $BUILD-RELCONN, $BUILD-FRAGMENT,
            $SET-LN-RN-NULL.
  $MARKIT-REFPT =
     AT X-PN ASSIGN NODE ATTRIBUTE REFPT-ATT.
  $HAVE-TIME-PN =
     PRESENT-ELEMENT- X-PN EXISTS;
     CORE-SELATT X-P OF P EXISTS;
     EITHER BOTH X-PN HAS NODE ATTRIBUTE ADVERBIAL-TYPE
            @AND PRESENT-ELEMENT- HAS MEMBER TIME-ADVERBIAL
     OR X-P HAS MEMBER H-TMPREP;
     X-P DOES NOT HAVE MEMBER NTIME1 OR NTIME2 OR H-TMLOC OR
         H-AGE.
  $HOST-IS-TIME =
     HOST X-N OF X-PN IS NTIME1 OR NTIME2 OR H-TMLOC.
  $CHECK-NSTGO-CLASSES =
     DO $CHECK-SELATT [AND $CHECK-H-HOSP].
  $CHECK-SELATT =
     AT X-PN
     CORE-SELATT X-S OF CORE X-N OF NSTG X2 OF NSTGO DOES NOT
            HAVE MEMBER NTIME1 OR NTIME2 OR H-TMLOC OR H-AGE
                     OR H-FAMILY OR H-PT.
  $BUILD-RELCONN =
      AT X-PN DO $FIND-ASSERT [GLOBAL IN T-REL-CLAUSE];
      DO $BUILD-RELCLAUSE [GLOBAL IN T-REL-CLAUSE];
      AT X-CONN REPLACE HEADCONN
               BY <HEADCONN> (<GRAM-NODE> = '[EXPAND-REFPT]').
  $SET-LN-RN-NULL =
      AT LEFT-ADJUNCT-POS OF X-N DO $SET-LN-NULL;
      AT RIGHT-ADJUNCT-POS [RN] OF X-N REPLACE VALUE BY <NULL> .
  $SET-LN-NULL =
      REPLACE PRESENT-ELEMENT- BY <LN> (<TPOS>(<NULL>)
                          +<QPOS> (<NULL>)
                          +<APOS> (<NULL>)).
  $CHECK-H-HOSP =
       IF X-S HAS MEMBER H-HOSP
       THEN ONE OF $CHECK-TPOS, $CHECK-OTHER-LN, $CHECK-RN.
  $CHECK-TPOS =
       AT TPOS OF LEFT-ADJUNCT-POS X-LN OF X-N
       BOTH CORE- IS NOT NULL
       @ AND PRESENT-ELEMENT- IS NOT 'THIS' [* English *]
             OR 'CE' OR 'CES' OR 'CETTE' OR 'CETTES' [* French *].
  $CHECK-OTHER-LN =
       QPOS OF X-LN IS EMPTY;
       BOTH COELEMENT- APOS OF X-LN IS NOT EMPTY
      @AND CORE IS 'PRESENT' OR 'CURRENT'.
  $CHECK-RN = RIGHT-ADJUNCT OF X-N IS NOT EMPTY .
* T-CHANGE-OF-STATE
*   OPERATES WHEN CORE OF LXR IS H-CHANGE/H-TMBEG/H-TMEND.
* ASSERTION A IS FOUND BY GOING UP TO ASSERTION FROM LXR.
*      PARSE-CONN = CHANGE-OF STATE  IS INSERTED TO LEFT OF A.
*      HEADCONN = LXR CONTAINING H-CHANGE/H-TMBEG/H-TMEND.
* IF HOST OF CORE OF LXR [FOUND BY GOING TO POINTER IN N.A.  SEM-CORE
* ASSIGNED BY T-FIND-HOST] IS:
*   A) A NOUN
*         INSERT FRAGMENT B TO THE RIGHT OF A.
*         FRAGMENT B = IMMEDIATE NSTG OF HOST.
*   B) A VERB
*         ASSERTION B IS A COPY OF ASSERTION A. REPLACE LXR IN B
*         CONTAINING H-CHANGE/H-TMBEG/H-TMEND BY <NULL>.
* IF X = 'BEGIN' SET SA [OF B] = DSTG = D = 'NOT'.
[T-CHANGE-OF-STATE = IN LTR, LNR, VERBAL, DSTG, LAR, LAR1,]
[                         NNN, LQR:]
[    IF BOTH CORE-SELATT X-S OF CORE X-CORE HAS MEMBER H-CHANGE]
[            OR H-TMBEG OR H-TMEND]
[       AND PRESENT-ELEMENT- HAS NODE ATTRIBUTE SEM-CORE X-HOST]
[    THEN BOTH $SETUP]
[         AND EITHER $HOST-IS-N]
[             OR $HOST-IS-V.]
  $HOST-IS-N =
       IF X-HOST IS N
       THEN BOTH $NSTG-FRAG AND $CHNGE-OF-STATE.
  $HOST-IS-V =
       IF X-HOST IS V
       THEN BOTH $COPY-ASSRT AND $CHNGE-OF-STATE .
  $NSTG-FRAG =
       AT X-HOST IMMEDIATE NSTG X2 EXISTS;
       DO $BUILD-FRAGMENT [GLOBAL- IN T-EXPAND-REFPT];
       DO $TEST-FOR-BEGIN.
  $SETUP =
     PRESENT-ELEMENT- X-LXR EXISTS;
     DO $FIND-ASSERT [GLOBAL IN T-REL-CLAUSE].
  $COPY-ASSRT =
       AT X-PRE ASSIGN NODE ATTRIBUTE PT1 WITH VALUE X-LXR;
       AFTER X-PRE INSERT <NULL> X-NULL;
       REPLACE X-NULL BY X-PRE ;
       AT X-PRE FOLLOWING-ELEMENT- X1 EXISTS;
       X1 HAS NODE ATTRIBUTE PT1 [GO TO LXR IN NEW ASSERTION];
       REPLACE PRESENT-ELEMENT- BY <NULL>;
       DO $TEST-FOR-BEGIN.
  $CHNGE-OF-STATE = BEFORE X-PRE INSERT
         <PARSE-CONN> (<CHANGE-OF-STATE> (<SA>(<NULL>)
                                         +<LCONNR> X-CONN
                                         +<SA>(<NULL>)));
       DO $BUILD-LCONNR [GLOBAL IN T-CONJ-IN-CENTER];
       AT CORE- X-HCONN OF X-LXR
       DO $BUILD-HEADCONN [GLOBAL IN T-CONJ-IN-CENTER];
       DO $BUILD-LCONN-RCONN [GLOBAL IN T-FIND-CONN].
   $TEST-FOR-BEGIN = IF X-CORE IS 'BEGIN'
                     THEN $BUILD-NOT.
  $BUILD-NOT = AT X1 ELEMENT SA EXISTS;
       AT ELEMENT NULL [OF SA] REPLACE PRESENT-ELEMENT- BY
                    <DSTG>(<D> ='NOT') .
* T-WITH-CONJ
*   OPERATES ON PN  WHERE
*      P IS 'WITH'  AND
*      P HAS NODE ATTRIBUTE SELECT-ATT WITH VALUE CONJ-LIKE.
*      PARSE-CONN = PREP-CONN
*      HEADCONN = 'WITH'
* ASSERTION A IS FOUND BY GOING UP FROM PN.
* FRAGMENT B = NSTG OF PN  IS ATTACHED TO THE RIGHT OF A.
T-WITH-CONJ = IN PN:
    IF EITHER BOTH P X-CORE IS 'AVEC' OR 'WITH' OR '[AVEC]' OR '[WITH]'
              AND BOTH X-CORE DOES NOT HAVE NODE ATTRIBUTE PVAL-ATT
                  AND BOTH X-CORE HAS  NODE ATTRIBUTE SELECT-ATT
                      @AND TEST FOR CONJ-LIKE
       OR PRESENT-ELEMENT- X-PN HAS NODE ATTRIBUTE ADVERBIAL-TYPE
          WHERE PRESENT-ELEMENT- HAS MEMBER CONN-TYPE
    THEN ALL OF $SETUP, $BUILD-FRAGMENT,
                $BUILD-PREPCONN, $DELETE-PN.
  $SETUP =
       PRESENT-ELEMENT- X-PN EXISTS;
       NSTG X2 OF NSTGO EXISTS;
       DO $FIND-ASSERT [GLOBAL - IN T-REL-CLAUSE].
  $DELETE-PN = REPLACE X-PN BY <NULL> .
  $BUILD-FRAGMENT =
      AFTER X-PRE INSERT
        <FRAGMENT>X1 ( <SA> (<NULL>)
                     + X2
                     + <SA> (<NULL>));
      TRANSFORM X1.                                       (GLOBAL)
  $BUILD-PREPCONN =
     BEFORE X-PRE INSERT
       <PARSE-CONN> (<PREP-CONN> (<SA> (<NULL>)
                                 +<LCONNR> X-CONN
                                 +<SA> (<NULL>)));
     DO $BUILD-LCONNR [GLOBAL IN T-CONJ-IN-CENTER];
     AT X-CORE
     STORE IN X-HCONN;
     DO $BUILD-HEADCONN [GLOBAL IN T-CONJ-IN-CENTER];
     DO $BUILD-LCONN-RCONN.
* T-SETUP-PN-PDATE
T-SETUP-PN-PDATE = IN NSTGT, PDATE:
     IF PRESENT-ELEMENT- X-PRE IS NSTGT
     THEN $SETUP-PN
     ELSE DO $FIX-P [PRESENT-ELEMENT- IS PDATE].
  $FIX-P =
    [IF DATEPREP IS EMPTY]
    [THEN REPLACE VALUE BY <P> = 'P':(H-TMPREP);]
     X-LIST := LIST TIME-ADVERB-LIST;
     AT X-PRE ASSIGN NODE ATTRIBUTE ADVERBIAL-TYPE WITH VALUE X-LIST.
  $SETUP-PN =
     AFTER X-PRE [NSTGT]
     INSERT <PN> X-PN
                 ( <LP> (<NULL>)
                 + <P> = '[P]' : (H-TMPREP)
                 + <NSTGO> (NSTG));
     X-LIST := LIST TIME-ADVERB-LIST;
     IF ELEMENT- LTIME OF X-PRE EXISTS
     THEN REPLACE ELEMENT- LP OF X-PN BY <LP> (VALUE OF LTIME);
     AT X-PN ASSIGN NODE ATTRIBUTE ADVERBIAL-TYPE WITH VALUE X-LIST;
     DELETE X-PRE;
     TRANSFORM X-PN.
* T-SETUP-NEG-MEAN
* [OBSOLETE] DICTIONARY NO LONGER HAS NEG-MEAN.
T-SETUP-NEG-MEAN = IN LXR, NNN, DSTG:
     IF $CHK-FOR-NEG-MEAN
     THEN BOTH $ADD-NEG-MEAN
          AND $SET-SELATT-NEG.
  $CHK-FOR-NEG-MEAN =
     BOTH CORE-SELATT OF CORE- X-HOST HAS MEMBER H-CHANGE OR
          H-CHANGE-MORE OR H-CHANGE-LESS OR H-CHANGE-SAME OR
          H-MODAL OR H-TMEND OR H-TMBEG OR H-CONN
     AND X-HOST IS H-CHANGE OR H-CHANGE-MORE OR H-CHANGE-LESS
         OR H-CHANGE-SAME OR H-MODAL OR H-TMEND OR H-TMBEG
         OR H-CONN: NEG-MEAN;
     AT X-HOST NOT $NEGMEAN-DONE.
  $NEGMEAN-DONE = ITERATE DO R(N)
          UNTIL PRESENT-ELEMENT- IS '[NEG-MEAN]' SUCCEEDS.
  $ADD-NEG-MEAN =
     AFTER LAST-COELEMENT OF X-HOST
     INSERT <GRAM-NODE> X-NEGMEAN = '[NEG-MEAN]'.
  $SET-SELATT-NEG =
     X-TYPE := SYMBOL MODS;
     AT X-NEGMEAN
     BOTH X-ADDATT := SYMBOL H-NEG
     AND BOTH $ADD-TO-SELATT [GLOBAL IN T-SEM-CORE-OF-LXR]
         AND $SET-SEM-CORE [T-SEM-CORE-OF-LXR].
* T-SETUP-FUT-TENSE
*    BUILDS TENSE FOR AUXILIARY FUTURE TENSE.
*    BY ASSIGNING SELECT-ATT H-VTENSE, TYPE-ATT TENSE AND
*    SEM-CORE TO VERB CORE.
T-SETUP-FUT-TENSE = IN TENSE:
     IF BOTH CORE- X-CORE OF PRESENT-ELEMENT- X-PRE IS W:FUT
        AND BOTH X-CORE IS NOT H-MODAL
            AND X-CORE IS NOT H-NEG
     THEN ALL OF $ASSIGN-SELECT-ATT, $ASSIGN-TYPE-ATT, $HOST-VERB.
  $ASSIGN-SELECT-ATT =
     X-SEL := SYMBOL H-VTENSE;
     X-SELATT := NIL;
     PREFIX X-SEL TO X-SELATT;
     AT X-CORE, ASSIGN NODE ATTRIBUTE SELECT-ATT WITH VALUE X-SELATT.
  $ASSIGN-TYPE-ATT =
     X-SEL := SYMBOL TENSE;
     X-SELATT := NIL;
     PREFIX X-SEL TO X-SELATT;
     AT X-CORE, ASSIGN NODE ATTRIBUTE TYPE-ATT WITH VALUE X-SELATT.
  $HOST-VERB =
    [* TENSE is now under LV of VERB *]
     EITHER HOST- X-HOST OF X-PRE EXISTS
     OR CORE- X-HOST OF COELEMENT- VERBAL EXISTS;
     AT X-CORE, ASSIGN NODE ATTRIBUTE SEM-CORE WITH VALUE X-HOST.
* T-SETUP-TENSE
*    FORMATS TENSE AS MODIFIER TO VERBAL (NODE ATTRIBUTE TENSE-ATT)
*    OR NEAREST HOST-.
T-SETUP-TENSE = IN VERBAL, LNR, LCONNR:
     IF BOTH $CHK-FOR-TENSEATT AND NOT $DONE-ALREADY
     THEN $ADD-TENSE.
  $DONE-ALREADY = X-HOST EXISTS;
     ITERATE DO R(GRAM-NODE)
     UNTIL VERIFY CORE-SELATT HAS MEMBER H-VTENSE SUCCEEDS.
  $CHK-FOR-TENSEATT =
     CORE- X-HOST HAS NODE ATTRIBUTE TENSE-ATT X-TENSELIST.
  $ADD-TENSE =
     ALL OF $IMP, $PRES, $PAST, $FUT, $FUTURE, $FUT-IMP, $PERF, $PROG.
  $PROG =
     IF X-TENSELIST HAS MEMBER PROG
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[PROG]'
          AND $SET-SELATT-VTENSE.
  $PERF =
     IF X-TENSELIST HAS MEMBER PERF
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[PERF]'
          AND $SET-SELATT-VTENSE.
  $FUT =
     IF X-TENSELIST HAS MEMBER FUT
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[FUT]'
          AND $SET-SELATT-VTENSE.
  $FUTURE =
     IF X-TENSELIST HAS MEMBER FUTURE
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[FUTURE]'
          AND $SET-SELATT-VTENSE.
  $FUT-IMP =
     IF X-TENSELIST HAS MEMBER FUT-IMP [FUTURE]
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[FUT-IMP]'
          AND $SET-SELATT-VTENSE.
  $PAST =
     IF X-TENSELIST HAS MEMBER PAST
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[PAST]'
          AND $SET-SELATT-VTENSE.
  $PRES =
     IF X-TENSELIST HAS MEMBER PRESNT
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[PRESENT]'
          AND $SET-SELATT-VTENSE.
  $IMP =
     IF X-TENSELIST HAS MEMBER IMPERTVE
     THEN BOTH AFTER LAST-COELEMENT OF X-HOST
               INSERT <GRAM-NODE> X-TENSE = '[IMPERATIVE]'
          AND $SET-SELATT-VTENSE.
  $SET-SELATT-VTENSE =
     X-TYPE := SYMBOL TENSE;
     AT X-TENSE
     BOTH X-ADDATT := SYMBOL H-VTENSE
     AND BOTH $ADD-TO-SELATT [GLOBAL IN T-SEM-CORE-OF-LXR]
         AND $SET-SEM-CORE [T-SEM-CORE-OF-LXR].
* T-NAMESTG
T-NAMESTG = IN NAMESTG:
     AT PRESENT-ELEMENT X-PRE
     IF CORE- OF TITLE OF LEFT-ADJUNCT-POS OF CORE- X-CORE IS
                NOT EMPTY
     @THEN IF PRESENT-ELEMENT- IS 'DR.' OR 'DR' OR 'DOCTOR' OR
              'DOCTORS' OR 'MD' OR 'M.D.' OR 'MDS'
           THEN $ASSIGN-DOCTOR
           ELSE $REMOVE-DR;
     IF CORE- OF RNAME OF LNAMER OF X-PRE IS NOT EMPTY
     @THEN IF PRESENT-ELEMENT- IS 'M.D.' OR 'MD'
           THEN $ASSIGN-DOCTOR.
  $ASSIGN-DOCTOR =
     X-TEMP := LIST DOCTOR-LIST;
     DO $ASSIGN-SELECTATT.
  $ASSIGN-SELECTATT =
     AT X-CORE
     ASSIGN NODE ATTRIBUTE SELECT-ATT WITH VALUE X-TEMP.
  $REMOVE-DR =
     X-TEMP := LIST PT-FAM;
     DO $ASSIGN-SELECTATT.
* T-SEM-CORE-OF-REPT
T-SEM-CORE-OF-REPT = IN LNR:
      AT CORE- X-CORE OF PRESENT-ELEMENT- X-PRE
         DO $NOUN-PLURAL-REPT.
  $NOUN-PLURAL-REPT =
      IF BOTH $LOOK-FOR-PLURAL
         AND $REPT
      THEN $SET-SELATT-REP.
  $LOOK-FOR-PLURAL =
      BOTH X-CORE IS NOT NULLN
      AND BOTH X-CORE IS NOT NUNIT OR NTIME1
               WHERE ONE OF $LQR-PLURAL, $LAR-PLURAL,
                            $N-PLURAL, $LTR-PLURAL
          AND AT X-CORE STORE IN X-HOST.
  $LQR-PLURAL =
     AT LQR X-PLURAL OF QPOS OF LEFT-ADJUNCT X-LN OF X-CORE
     DO $LQR-CHECK.
  $LQR-CHECK =
     CORE- IS NOT '1'.
  $LAR-PLURAL =
     EITHER AT LAR [LAR1] X-PLURAL OF ADJADJ OF APOS OF X-LN
            DO $LAR-CHECK
     OR AT LAR X-PLURAL OF ADJINRN OF RIGHT-ADJUNCT OF X-CORE
        DO $LAR-CHECK.
  $LAR-CHECK =
     BOTH CORE- IS NTH
     @AND PRESENT-ELEMENT- IS NOT '1ST'.
  $N-PLURAL =
     X-CORE HAS COELEMENT- N X-PLURAL
     WHERE PRESENT-ELEMENT- IS 'PLURAL'.
  $LTR-PLURAL =
     CORE- OF ELEMENT- LTR X-PLURAL OF ELEMENT- TPOS OF X-LN
     HAS ATTRIBUTE EACHEVRY.
  $REPT =
     ALL OF $NOT-NULLN, $HOST-CHECK, $NO-REP.
  $HOST-CHECK =
     CORE-SELATT OF X-HOST HAS MEMBER REPT-LIST.
  $NOT-NULLN =
     X-HOST IS NOT NULLN.
  $NO-REP =
     AT X-CORE
     IF CORE-SELATT OF PRESENT-ELEMENT- HAS MEMBER H-TTGEN OR H-TXVAR
     THEN PRESENT-ELEMENT- IS NOT H-TTGEN OR H-TXVAR:NO-REP.
  $SET-SELATT-REP =
     AT CORE- [N, Q, T, ADJ] OF X-PLURAL
     BOTH X-ADDATT := SYMBOL H-TMREP
     AND BOTH $ADD-TO-SELATT
         AND $ADD-HOSTATT.
  $ADD-HOSTATT =
     VERIFY X-TYPE := SYMBOL TIME;
     VERIFY X-HOST := X-CORE;
     DO $SET-SEM-CORE [T-SEM-CORE-OF-LXR].
  $ADD-TO-SELATT =
     AT PRESENT-ELEMENT- X-PE
     DO $CHECK-SELATT.
  $CHECK-SELATT =
     IF CORE-SELATT OF X-PE EXISTS
     THEN EITHER $SEL-ATT
          OR $ATTRIBUTE
     ELSE BOTH X-SELATT-LIST := NIL
          AND $ADD-TO-SELATT-LIST.
  $SEL-ATT =
     BOTH X-PE HAS NODE ATTRIBUTE SELECT-ATT X-SELATT-LIST
     AND $ADD-TO-SELATT-LIST.
  $ATTRIBUTE =
     BOTH $CREATE-SELATT-LIST
     AND $ADD-TO-SELATT-LIST.
  $CREATE-SELATT-LIST =
     ATTRIBUTE-LIST X-NEWLIST EXISTS;
     X-SUBLANGUAGE-ATTS := LIST SUBLANGUAGE-ATTS;
     INTERSECT OF X-SUBLANGUAGE-ATTS EXISTS;
     X-SELATT-LIST := X-INTERSECTION [X-SELATT-LIST MAY BE NIL].
  $ADD-TO-SELATT-LIST =
     BOTH EITHER $ATT-ALREADY-ON-LIST
          OR PREFIX X-ADDATT TO X-SELATT-LIST
     AND AT X-PE
         ASSIGN PRESENT ELEMENT NODE ATTRIBUTE SELECT-ATT
                WITH VALUE X-SELATT-LIST.
  $ATT-ALREADY-ON-LIST =
     X-SELATT-LIST HAS MEMBER X-ADDATT
   [DO NOT ADD ATTRIBUTE TO LIST IF ALREADY ON LIST].
* T-HOST-AGE-UNIT
T-HOST-AGE-UNIT = IN QN, LQR, LNR:
       ONE OF $LNR-CHK, $QN-CHK, $LQR-CHK.
  $LNR-CHK = PRESENT-ELEMENT- X-PRE IS LNR;
       VERIFY X-HOST:= NIL;
       IF CORE-SELATT OF CORE- X-CORE HAS MEMBER NTIME1
       THEN $AGE-CHK [CHECK IF LNR IS AN AGE MOD]
       ELSE IF X-S HAS MEMBER NUNIT
            THEN $FIND-UNIT-HOST [IS LNR A UNIT MOD-3 DEGREES]
            ELSE IF X-CORE IS NULLN WHERE CORE-ATT HAS MEMBER NUNIT
                 THEN IF $LNR-HOST [T-SEM-CORE-OF-LXR-HOST IN X-HOST]
                      THEN IF $IS-PT-FAM ['PT OF 3]
                           THEN BOTH $SET-N-TO-YEAR
                                AND $SET-AGE-MK [SET RN TO ADJ=OLD]
                           ELSE IF $HOST-IS-AGE [AGE OF 3, AGE IS 3]
                                THEN BOTH $SET-N-TO-YEAR
                                     AND $UNIT-TO-AGE-MK
                               ELSE $SET-UNIT-HOST [FEVER OF 103].
  $AGE-CHK = [IS LNR AN AGE MODIFIER]
       IF AT RIGHT-ADJUNCT X-HOST OF X-CORE DO $AGE-MK-CHK
       THEN $UNIT-TO-AGE-MK [SET UNIT HOST TO AGE MARKER]
       ELSE IF AT X-PRE BOTH $FIND-HOST
                        AND $HOST-IS-AGE
           THEN $UNIT-TO-AGE-MK.
  $UNIT-TO-AGE-MK = [X-HOST POINTS TO AGE MARKER]
       X-TYPE:= SYMBOL UNIT;
       AT X-CORE DO $SET-SEM-CORE.
  $FIND-UNIT-HOST = [FIND HOST OF UNIT OF MEASUREMENT-'103 DEGREES']
       X-HOST := NIL;
       AT X-PRE EITHER $FIND-HOST OR TRUE;
       DO $SET-UNIT-HOST.
  $SET-UNIT-HOST = X-TYPE:= SYMBOL UNIT;
      AT X-CORE DO $ASSIGN-HOST.
  $SET-AGE-HOST = X-TYPE:= SYMBOL AGE;
       AT X-CORE DO $ASSIGN-HOST.
  $IS-PT-FAM = X-HOST HAS MEMBER H-PT OR H-FAMILY.
  $HOST-IS-AGE = X-HOST IS H-AGE.
  $SET-AGE-MK = [ADD AGE MARKER TO RN]
       BEFORE VALUE OF RIGHT-ADJUNCT-POS OF X-CORE
       INSERT <ADJINRN> (<LAR> (<LA> (<NULL>)
                               +<AVAR> (<ADJ> X-AGE = '[OLD]':(H-AGE))
                               +<RA> (<NULL>)));
       DO $SET-AGE-HOST
        [Set HOST-AGE pointing to X-HOST at AGE MARKER];
       X-HOST:= X-AGE;
       DO $UNIT-TO-AGE-MK [SET UNIT-HOST POINTING TO AGE MARKER].
  $SET-N-TO-YEAR = AT X-CORE REPLACE PRESENT-ELEMENT-
       BY <N>X-TEMP = '[YEAR]':(NTIME1);
       X-CORE:= X-TEMP.
  $SCALESTG-AGE = ['3 DAYS OLD','3 DAYS OF AGE']
       AT CORE- OF SCALESTG DO $AGE-MK-CHK.
  $AGE-MK-CHK =
       EITHER BOTH PRESENT-ELEMENT- X-HOST IS 'OLD'
              AND $SET-AGE-ATT
       OR PRESENT-ELEMENT- IS PN
          WHERE BOTH ELEMENT- P IS 'DE' OR 'OF'
                AND CORE- X-HOST OF NSTGO IS 'A3GE' OR 'AGE'.
  $SET-AGE-ATT = VERIFY X-TEMP:= LIST H-AGE-LIST;
       ASSIGN NODE ATTRIBUTE SELECT-ATT WITH VALUE X-TEMP.
  $LQR-CHK = X-PRE IS LQR;
       IF PRESENT-ELEMENT- IS OCCURRING IN LN OR QN OR NQ
       THEN TRUE [DO NOT CHECK FOR AGE]
       ELSE IF PRESENT-ELEMENT- IS OCCURRING IN RN
               WHERE HOST- X-HOST EXISTS
            THEN BOTH $SETUP-QN [CHANGE LQR TO QN]
                 AND $QN-CHK.
  $SETUP-QN = [REPLACE LQR IN RN BY QN FOR REGULARITY]
       AT X-PRE REPLACE PRESENT-ELEMENT- BY
        <QN>X-TEMP (X-PRE
                   +<N>='NULLN'
                   +<SCALESTG>(<NULL>));
       X-PRE:= X-TEMP;
       IF EITHER $IS-PT-FAM ['PT 3' CHANGED TO 'PT 3 YEAR']
          OR $HOST-IS-AGE ['AGE 3' CHANGED TO 'AGE 3 YEAR']
       THEN $SET-N-TO-YEAR;
       DO $QN-CHK.
  $QN-CHK = X-PRE IS QN;
       IF ELEMENT- N X-CORE IS NTIME1
       THEN IF $SCALESTG-AGE
            THEN BOTH $SET-UNIT-HOST [UNIT points to AGE MARKER]
                 AND BOTH X-CORE:= X-HOST
                     AND $FIND-AGE-HOST
            ELSE $HOST-CHK
       ELSE $FIND-UNIT-HOST.
  $FIND-AGE-HOST = X-HOST:= NIL;
        AT X-PRE EITHER $FIND-HOST OR TRUE;
       DO $SET-AGE-HOST.
  $HOST-CHK =
     IF $FIND-HOST
     THEN IF $HOST-IS-AGE
          THEN $SET-UNIT-HOST
          ELSE IF X-HOST IS H-PT OR H-FAMILY [$IS-PT-FAM] [*GRI*]
               THEN BOTH $SET-SCALESTG-AGEMK
                    AND $QN-CHK.
  $SET-SCALESTG-AGEMK = [Change NULL SCALESTG to ADJ=OLD]
       BEFORE VALUE OF SCALESTG OF X-PRE
       INSERT <ADJ> = 'OLD':(H-AGE).
* T-DISTRIBUTE-INTRO
*     distributes INTRODUCER to all its arguments, i.e.
*     ASSERTION and/or FRAGMENT.
* *** This will remove the need for T-FORMAT-INTRO.
* *** For some reasons, this rule is put on
*     the transformation stack twice.
T-DISTRIBUTE-INTRO = IN ASSERTION, FRAGMENT:
   IF ALL OF $ADD-SA, $NOT-ALREADY-DONE, $INTRO-NOT-EMPTY
   THEN DO $DISTRIBUTE-INTRO.
  $ADD-SA =
     IF VALUE OF PRESENT-ELEMENT- IS NOT SA
     THEN BEFORE VALUE OF PRESENT-ELEMENT-
          INSERT <SA> (<NULL>).
  $NOT-ALREADY-DONE =
     CORE- OF SA OF PRESENT-ELEMENT- IS NOT ':'.
  $INTRO-NOT-EMPTY =
     AT IMMEDIATE CENTER OF PRESENT-ELEMENT- X-ASSERT, GO LEFT;
     CORE- OF PRESENT-ELEMENT- X-PRE [IS NOT EMPTY] IS ':'.
  $DISTRIBUTE-INTRO =
     IF VALUE OF PRESENT-ELEMENT- IS NOT SA
     THEN BEFORE VALUE OF PRESENT-ELEMENT-
          INSERT <SA> (ALL ELEMENTS OF X-PRE)
     ELSE IF SA X-SA OF PRESENT-ELEMENT- IS EMPTY
          THEN REPLACE X-SA BY <SA> (ALL ELEMENTS OF X-PRE)
          ELSE BEFORE VALUE OF X-SA INSERT ALL ELEMENTS OF X-PRE.
* T-FORMAT-INTRO
*     assigns PATHIF to ASSERTION and FRAGMENT.
T-FORMAT-INTRO = IN ASSERTION, FRAGMENT:
   IF ALL OF $INTRO-NOT-EMPTY, $CHK-N-ATTS, $SAVE-SELATTS,
   THEN $FIND-TYPE.
  $INTRO-NOT-EMPTY =
   AT IMMEDIATE CENTER OF PRESENT-ELEMENT- X-ASSERT, GO LEFT;
   PRESENT-ELEMENT- X-PRE IS NOT EMPTY;
   CORE- X-CORE OF VALUE [LAR/LNR] EXISTS.
  $SAVE-SELATTS = [* puts this SELECT-ATTs on the ASSN-SELATTS *]
       IF X-ASSERT HAS NODE ATTRIBUTE ASSN-SELATTS X-ASSNSELS
       THEN DO $STORE-ASSNSELS
       ELSE BOTH X-ASSNSELS := NIL
            AND DO $STORE-ASSNSELS.
  $STORE-ASSNSELS =
       X-UNION := CORE-ATT OF X-CORE;
       X-ASSNSELS := UNION OF X-ASSNSELS;
       AT X-ASSERT, ASSIGN NODE ATTRIBUTE ASSN-SELATTS WITH
                    VALUE X-ASSNSELS.
  $CHK-N-ATTS = NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
                [$HAS-COMPUTED-HOST].
  $FIND-TYPE = IF $CHECK-IT THEN DO $FIND-FORMAT-TYPE.
  $CHECK-IT =
       CORE-SELATT X-S OF X-CORE EXISTS;
       X-NEWLIST:= LIST FRMT-CLASS;
       INTERSECT X-SIG OF X-S IS NOT NIL.
  $FIND-FORMAT-TYPE = X-LIST:= LIST FORMAT-TYPE;
       ITERATE $THROUGH-LIST
       UNTIL SUCCESSORS X-LIST OF X-LIST IS NIL SUCCEEDS.
  $THROUGH-LIST = ATTRIBUTE-LIST X-NEWLIST OF X-LIST EXISTS;
        IF INTERSECT OF X-SIG IS NOT NIL
        THEN $IS-A-TYPE.
* T-LXR-FORMAT-TYPE
*   ASSIGNS TYPE OF FORMATS TO A SENTENCE.
T-LXR-FORMAT-TYPE = IN LXR, NNN, DSTG:
       IF ALL OF $GET-REG, $CHK-N-ATTS, $IN-ASSRT, $SAVE-SELATTS,
                 $NOT-IN-TIME, $NOT-IN-ADJUNCT, $NOT-FRMT00
       THEN $FIND-TYPE.
  $GET-REG = CORE- X-CORE OF PRESENT-ELEMENT- X-PRE EXISTS.
  $SAVE-SELATTS = [* puts this SELECT-ATTs on the ASSN-SELATTS *]
       IF X-ASSERT HAS NODE ATTRIBUTE ASSN-SELATTS X-ASSNSELS
       THEN DO $STORE-ASSNSELS
       ELSE BOTH X-ASSNSELS := NIL
            AND DO $STORE-ASSNSELS.
  $STORE-ASSNSELS =
       X-UNION := CORE-ATT OF X-CORE;
       X-ASSNSELS := UNION OF X-ASSNSELS;
       AT X-ASSERT, ASSIGN NODE ATTRIBUTE ASSN-SELATTS WITH
                    VALUE X-ASSNSELS.
  $CHK-N-ATTS = NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
                [$HAS-COMPUTED-HOST].
  $IN-ASSRT =
       ASCEND TO ASSERTION OR FRAGMENT PASSING THROUGH STRING;
       STORE IN X-ASSERT.
  $NOT-IN-TIME =
      IF ASCEND TO PN PASSING THROUGH STRING
     @THEN PRESENT-ELEMENT- DOES NOT HAVE NODE ATTRIBUTE REFPT-ATT
         [* is TMREFPT - not significant in this decision *].
  $NOT-IN-ADJUNCT =
       [* Bypass adverbial ADJUNCT or TIME or TESTENV *]
      IF ASCEND TO PN PASSING THROUGH STRING
     @THEN IF PRESENT-ELEMENT- X-PHR-PN HAS NODE ATTRIBUTE
              ADVERBIAL-TYPE X-PHRASE-ATT
           THEN X-PHRASE-ATT DOES NOT HAVE MEMBER ADJUNCT-TYPE
                                      OR TIME-ADVERBIAL
           ELSE IF X-PHR-PN HAS NODE ATTRIBUTE PHRASE-ATT X-PHRASE-ATT
                THEN X-PHRASE-ATT DOES NOT HAVE MEMBER TIME-PHRASE
                                      OR TESTENV-PHRASE.
  $NOT-FRMT00 = NOT $IS-FRMT00.
  $IS-FRMT00 =
       BOTH X-ASSERT HAS NODE ATTRIBUTE FORMAT-ATT
       @AND PRESENT-ELEMENT- HAS MEMBER FRMT00.
  $ASSIGN-FRMT0 = X-LIST:= LIST FRMT0-LIST;
       DO $IS-A-TYPE.                                           (GLOBAL)
  $HAS-FAIL-SEL = X-CORE HAS NODE ATTRIBUTE FAIL-SEL.           (GLOBAL)
  $HAS-COMPUTED-HOST =
       EITHER X-CORE HAS NODE ATTRIBUTE LN-TO-N-ATT
       OR X-CORE HAS NODE ATTRIBUTE RN-TO-N-ATT.
  $HAS-ADJ-TYPE =
       BOTH X-CORE HAS NODE ATTRIBUTE ADVERBIAL-TYPE
       @AND PRESENT-ELEMENT- HAS MEMBER ADJUNCT-TYPE.           (GLOBAL)
  $FIND-TYPE = IF $CHECK-IT THEN DO $FIND-FORMAT-TYPE.
  $CHECK-IT =
       CORE-SELATT X-S OF X-CORE EXISTS;
       X-NEWLIST:= LIST FRMT-CLASS;
       INTERSECT X-SIG OF X-S IS NOT NIL.
  $CORE-ATT-SIG = X-CORE HAS NODE ATTRIBUTE COMPUTED-ATT X-S;
                  DO $CHECK-IT.
  $FIND-FORMAT-TYPE = X-LIST:= LIST FORMAT-TYPE;
       ITERATE $THROUGH-LIST
       UNTIL SUCCESSORS X-LIST OF X-LIST IS NIL SUCCEEDS.
  $THROUGH-LIST = ATTRIBUTE-LIST X-NEWLIST OF X-LIST EXISTS;
        IF INTERSECT OF X-SIG IS NOT NIL
        THEN $IS-A-TYPE.
  $IS-A-TYPE = X-HEAD:= HEAD OF X-LIST [TYPE OF FORMAT];
       IF X-ASSERT HAS NODE ATTRIBUTE FORMAT-ATT X-TYPE-LIST
       THEN $ADD-ON-TYPE
       ELSE $SETUP-TYPE-ATT.                      (GLOBAL)
  $ADD-ON-TYPE = EITHER X-TYPE-LIST HAS MEMBER X-HEAD
                 OR BOTH PREFIX X-HEAD TO X-TYPE-LIST
                    AND AT X-ASSERT ASSIGN NODE ATTRIBUTE FORMAT-ATT
                        WITH VALUE X-TYPE-LIST.
  $SETUP-TYPE-ATT = X-TYPE-LIST:= NIL;
       PREFIX X-HEAD TO X-TYPE-LIST;
       AT X-ASSERT ASSIGN NODE ATTRIBUTE FORMAT-ATT WITH VALUE
           X-TYPE-LIST.
* T-SEM-CORE-OF-LXR
*   THIS IS THE ONLY TRANSFORMATION (OTHER THAN SEQUENCING ONES) THAT
*   DOES NOT CREATE A CONNECTIVE. ITS FUNCTION IS TO FIND THE HOST OF
*   A CERTAIN LXR NODE AND TO ASSIGN TO IT A NODE ATTRIBUTE SEM-CORE
*   POINTING TO THE HOST.
*   T-SEM-CORE-OF-LXR OPERATES WHERE THE CORE X OF AN LXR
*     A) HAS NODE ATTRIBUTE N-TO-LN-ATT/N-TO-RN-ATT POINTING TO Y. THIS
*        MEANS THAT X IS PART OF A PHRASE WHICH HAS A COMPUTED ATTRIBUTE.
*        IN THIS CASE, THE CORE OF Y IS THE 'HOST' OF X.
*       EX.: IN 'THE END OF FEVER...', 'FEVER' IS THE HOST OF 'END'.
*  OR B) X HAS AN ATTRIBUTE ON LIST TRANSP-LIST.
*  OR C) X IS AN NTIME1 OR NTIME2 WORD.
*  OR D) X IS AN LNR IN A PN WHICH HAS THE NODE ATTRIBUTE TIME-ADVERBIAL.
*   THE HOST FOR CASES (B),(C),(D) ARE FOUND AS FOLLOWS:
*     1) IF LXR IS IN SA OR RV, HOST MAY BE ONE OF FOLLOWING:
*          A) VERB COELEMENT.
*          B) NSTG/ASTG IN FRAGMENT.
*          C) HEADCONN IN LCONNR.
*          D) VERB COELEMENT OF IMMEDIATE OBJECT (PASSING THROUGH STRINGS
*          WITH COMPOUND OBJECTS).
*  OR 2) IF LXR IS LAR OR LAR1 OR LQNR, HOST MAY BE ONE OF FOLLOWING:
*          A) REGULAR HOST
*          B) COELEMENT SUBJECT OF IMMEDIATE OBJECT.
*  OR 3) IF LXR IS VERBAL, HOST MAY BE ONE OF FOLLOWING:
*          A) CORE N OF COELEMENT OBJECT (PASSING THROUGH OBJECTS WITH
*             COMPOUND OBJECT STRINGS).
*          B) CORE OF COELEMENT SUBJECT IF OBJECT IS NULLOBJ.
*  OR 4) IF LXR IS LNR, HOST MAY BE ONE OF FOLLOWING:
*          A) IF IN PN, EITHER HOST OF PN
*                    OR IF PN IS IN SA OR RV SEE (1) ABOVE FOR
*          B) AT IMMEDIATE OBJECT (PASSING THROUGH COMPOUND OBJECT STRINGS)
*             GO TO COELEMENT SUBJECT.
*          C) AT IMMEDIATE SUBJECT, EITHER COELEMENT OBJECT
*                       HAS VALUE OBJBE- HOST IS CORE OF OBJECT
*                                   OTHERWISE COELEMENT VERB IS HOST.
*  OR 5) IF IN LP, GO TO COELEMENT P.
*  OR 6) IF IN LV OR RV OF VERB WHICH ITSELF HAS A SEM-CORE, SEM-CORE
*        IS THE SAME AS SEM-CORE OF VERB.
*  OR 7) GOT TO REGULAR HOST (IT SHOULD NOT BE EMPTY).
*  $ASSIGN-HOST CHECKS THAT THE SEM-CORE CAN SUPPORT A TIME OR MOD
*        NODE. IF IT CANNOT THEN $WRONG-HOST TRIES TO FIND ANOTHER
*        SEM-CORE THAT CAN.  LQNR IS AN EXCEPTION- IT ALWAYS GETS A
*        SEM-CORE WHICH IS USED BY VARIOUS FORMATTING TRANSFORMATIONS.
*  $WRONG-HOST TRIES TO FIND ANOTHER HOST:
*     1) IF INCORRECT HOST IS P, THEN NEW SEM-CORE POINTS TO LNR IN
*        NSTGO OF PN.
*     2) IF INCORRECT HOST IS OCCURRING IN LNR IN PN, THEN NEW SEM-CORE
*        WILL POINT TO HOST OF PN.
*     3) IF ALL OTHER ATTEMPTS FAIL, GO UP TO STRING CONTAINING VERBAL
*        ELEMENT, WHICH WILL BE THE NEW VALUE OF SEM-CORE.
T-SEM-CORE-OF-LXR = IN LXR, DSTG, NNN :
      CORE- X-CORE OF PRESENT-ELEMENT- X-PRE EXISTS;
      X-PRE EXISTS;
      EITHER $EXCLUDE
      OR $SEM-CORE-CHK;
      IF X-PRE IS LNR THEN $PLURAL-CHK.
  $SEM-CORE-CHK =
      IF ALL OF $NOT-TIME-PHRASE, $IS-MODIFIER-CHK, $NOT-TRANSP-HGRAPH
      THEN ONE OF $MOD-AND-SIG-CHK, $COMP-ATT, $FIND-AND-ASSGN.
  $NOT-TRANSP-HGRAPH =
         [* Erase H-TRANSP homograph from SELECT-ATT of core *]
      IF BOTH CORE-SELATT X-SELATT OF X-CORE HAS MEMBER H-TRANSP
         AND NEITHER X-CORE HAS NODE ATTRIBUTE N-TO-RN-ATT
             NOR X-CORE HAS NODE ATTRIBUTE N-TO-LN-ATT
      THEN BOTH $ERASE-TRANSP AND FALSE.
  $ERASE-TRANSP =
      X-SUBLIST := NIL;
      BOTH X-TEMP := SYMBOL H-TRANSP
      AND PREFIX X-TEMP TO X-SUBLIST;
      X-SELATT := COMPLEMENT OF X-SELATT;
      AT X-CORE, ASSIGN NODE ATTRIBUTE SELECT-ATT WITH VALUE X-SELATT.
  $FIND-AND-ASSGN =
      IF $FIND-HOST
      THEN $ASSIGN-HOST
      ELSE BOTH AT X-CORE DO $ADD-TO-TYPE-ATT [ASSIGN TYPE]
           AND $MESS2 [CANNOT FIND HOST-WRITE OUT MESSAGE].
  $MOD-AND-SIG-CHK =
      X-SUBLIST:= LIST MOD-CLASS;
      COMPLEMENT OF X-S IS NOT NIL [X-S HAS SIG. CLASSES ALSO];
      X-HOST:= X-CORE [HOST IS ITSELF];
      DO $HOST-IS-OK
     [IF X-S HAS MEMBER H-CHANGE]
        [* H-CHANGE becomes H-CHANGEMK when there is *]
        [* another component of change *]
     [THEN $CHANGE-TO-MK].
  $CHANGE-TO-MK = [* remove H-CHANGE, add H-CHANGEMK]
     [X-SUBLIST:= LIST CHANGE-LIST;]
      COMPLEMENT X-S OF X-S EXISTS [REMOVE H-CHANGE];
      X-UNION:= LIST CHANGEMK-LIST;
      UNION X-S OF X-S EXISTS [ADD H-CHANGEMK];
      AT X-CORE ASSIGN NODE ATTRIBUTE SELECT-ATT WITH VALUE X-S.
  $IS-MODIFIER-CHK =
      CORE-SELATT X-S OF X-CORE EXISTS;
      DO $ISIT-OTHER-MODFR.
  $ISIT-OTHER-MODFR =
      X-MODIF-CLASSES := LIST MODIFIER-CLASSES;
      ITERATET SUCCESSORS X-MODIF-CLASSES OF X-MODIF-CLASSES
                      IS NOT NIL
      UNTIL $IS-MOD-CLASS SUCCEEDS.
  $IS-MOD-CLASS =
     X-NEWLIST := ATTRIBUTE-LIST [LIST OF SUBCLASSES FOR TYPE];
     INTERSECT OF X-S IS NOT NIL;
     X-TYPE := HEAD OF X-MODIF-CLASSES.
  $CLASSFR-LQR =
     X-TYPE := SYMBOL MODS;
     AT X-CORE DO $SET-SEM-CORE.
  $PLURAL-CHK =
       IF BOTH $PLURAL-EXISTS AND NOT $LQR-PLURAL
               [IF HAVE LQR QUANTITY, PLURAL QUANTFR IS REDUNDANT]
       THEN BOTH X-TYPE:= SYMBOL QUANTITY
            AND BOTH AT X-CORE DO $SET-SEM-CORE
                AND $SET-SELATT-QNUMBER.
  $LQR-PLURAL =
      LQR OF QPOS OF LEFT-ADJUNCT OF X-HOST IS NOT EMPTY.
  $PLURAL-EXISTS = X-HOST := X-CORE;
      X-CORE HAS COELEMENT- N X-CORE
        WHERE PRESENT-ELEMENT- IS 'PLURAL'.
  $SET-SELATT-QNUMBER =
      AT X-CORE ['PLURAL']
      BOTH X-ADDATT := SYMBOL QNUMBER
      AND $ADD-TO-SELATT.
  $EXCLUDE =
      EITHER X-PRE [PRESENT-ELEMENT-] IS LCONNR OR LQNR,
      OR EITHER X-PRE IS LQR
                WHERE PRESENT-ELEMENT- IS OCCURRING IN QN OR NQ,
         OR ONE OF $HAS-FAIL-SEL [T-LXR-FORMAT-TYPE],
                   $HAS-ADJ-TYPE [T-LXR-FORMAT-TYPE].
  $COMP-ATT =
      AT CORE- X-CORE EITHER $GET-RN-ATT
                      OR $GET-LN-ATT;
      AT CORE- [OF X-TEMP] STORE IN X-HOST;
      AT X-CORE DO $SET-SEM-CORE.
  $GET-LN-ATT =
    [* CANNOT USE ATTRIBUTE N-TO-LN-ATT ONLY BECAUSE IF LNR *]
    [* IS CONJOINED,VALUE OF N-TO-LN-ATT MAY BE POINTING TO *]
    [* WRONG NODE DUE TO EXPANSION -- WHEN NODE WITH        *]
    [* N-TO-LN-ATT IS COPIED ITS VALUE IS COPIED ALSO --    *]
    [* HOWEVER, THE VALUE OF THE COPY SHOULD POINT TO ITS   *]
    [* OWN N-TO-LN-ATT AND NOT TO THE VALUE OF THE ORIGINAL.*]
    [* FOR EX., IN  OR 'AGE''NO HISTORY OF DIARRHEA OR      *]
    [* OTHER FOCAL SIGNS', LTR = 'NO' IS VALUE OF N-TO-LN-ATT *]
    [* FOR ORIGINAL 'HISTORY' AND COPY OF 'HISTORY'. HOWEVER, *]
    [* THERE ARE 2 DIFFERENT LTR'S AND EACH N-TO-LN-ATT     *]
    [* SHOULD POINT TO ITS CORRESPONDING LTR.               *]
      PRESENT-ELEMENT- HAS NODE ATTRIBUTE N-TO-LN-ATT X-LNATT;
      DO $TEST-IT.
  $TEST-IT =
      LEFT-ADJUNCT-POS X-LN OF X-CORE EXISTS;
      EITHER X-LNATT IS OCCURRING IN LN X-LN1 [POINTING TO CORRECT LN]
             WHERE BOTH X-LN1 IS IDENTICAL TO X-LN
                   AND X-LNATT EXISTS [IT IS THE CORRECT HOST]
      OR $REASSIGN-NLN-ATT [WRONG LN - GET CORRECT ONE].
  $REASSIGN-NLN-ATT =
      IF X-LNATT IS LQR THEN AT QPOS OF X-LN DESCEND TO LQR
              WHERE DO $SAVE-IN-XTEMP
      ELSE IF X-LNATT IS LTR
           THEN AT TPOS OF X-LN DESCEND TO LTR
                WHERE DO $SAVE-IN-XTEMP
           ELSE IF X-LNATT IS LAR [LAR1]
                THEN BOTH AT APOS OF X-LN DESCEND TO LAR [LAR1]
                          WHERE DO $SAVE-IN-XTEMP
                     AND ITERATET $ANOTHER-LAR1
                         UNTIL $AT-WRONG-LAR1 FAILS
               [ LAR1 IS RECURSIVE- MUST FIND THE CORRECT ONE ]
                ELSE IF X-LNATT IS NNN
                     THEN BOTH AT NPOS OF X-LN DESCEND TO N WHERE
                                  DO $SAVE-IN-XTEMP
                          AND ITERATET $ANOTHER-N
                              UNTIL $AT-WRONG-N FAILS;
      AT X-CORE ASSIGN PRESENT ELEMENT NODE ATTRIBUTE N-TO-LN-ATT
         WITH VALUE X-TEMP;
      X-TEMP EXISTS.
  $SAVE-IN-XTEMP = STORE IN X-TEMP.
  $ANOTHER-LAR1 =
      AT X-TEMP DO L(ADJADJ);
      ELEMENT LAR [LAR1] X-TEMP EXISTS.
  $ANOTHER-N = AT X-TEMP DO L(NNN);
       ELEMENT N X-TEMP EXISTS.
  $AT-WRONG-LAR1 =
      IMMEDIATE-NODE OF X-OLD EXISTS;
      DO R(LAR) [R(LAR1)];
      STORE IN X-OLD.
  $AT-WRONG-N = IMMEDIATE-NODE OF X-OLD EXISTS;
       DO R(N);
       STORE IN X-OLD.
  $GET-RN-ATT =
       [* CANNOT USE ONLY ATTRIBUTE N-TO-RN-ATT BECAUSE IF *]
       [* LNR IS CONJOINED, POINTER WILL BE POINTING TO    *]
       [* WRONG NODE DUE TO EXPANSION.                     *]
       [*   'STIFF AND PAINFUL ARMS'.                      *]
       [* RESET N-TO-RN-ATT TO APPROPRIATE RIGHT-ADJUNCT.  *]
     PRESENT-ELEMENT- HAS NODE ATTRIBUTE N-TO-RN-ATT;
     EITHER LNR OF NSTG OF NSTGO OF RIGHT-ADJUNCT OF X-CORE EXISTS
     OR LAR OF RIGHT-ADJUNCT OF X-CORE EXISTS;
     STORE IN X-TEMP;
     AT X-CORE ASSIGN NODE ATTRIBUTE N-TO-RN-ATT WITH VALUE X-TEMP;
     X-TEMP EXISTS [RETURN TO X-TEMP].
  $NOT-TIME-PHRASE =
      NOT $IN-TIME-PHRASE.
  $IN-TIME-PHRASE =
      VERIFY CORE- IS NOT H-TMLOC;
      IF PRESENT-ELEMENT- IS LQR OR NNN OR LAR [LAR1]
      THEN EITHER ASCEND TO LN,
           OR TRUE;
      ASCEND TO PN OR PDATE;
      DO $TIME-PHRASE [T-SEM-CORE-OF-PSTG].
  $FIND-HOST =
      ONE OF $SA-RV-HOST, $ADJ-HOST, $VERB-HOST,
             $LNR-HOST, $P-HOST, $REGULAR-HOST .   (GLOBAL)
  $REGULAR-HOST =
      EITHER X-PRE IS NOT LNR OR LAR OR LAR1 OR LQNR OR PN ,
      OR X-PRE IS NOT OF TYPE VERBAL;
      DO $REG-HOST.
  $REG-HOST =
      HOST X-HOST EXISTS WHERE PRESENT-ELEMENT- IS NOT EMPTY.
  $SA-RV-HOST =
      IMMEDIATE-NODE- IS SA OR RV;
      ONE OF $COEL-VERB, $N-IN-FRAG-N, $COEL-BESHOW,
             $CONN-IN-LCONNR, $UP-TO-VERB;
      CORE- X-HOST EXISTS WHERE PRESENT-ELEMENT- IS NOT EMPTY.
  $COEL-VERB =
      BOTH COELEMENT VERBAL EXISTS
     @AND EITHER PRESENT-ELEMENT- IS NOT EMPTY
          OR COELEMENT SUBJECT EXISTS
             WHERE PRESENT-ELEMENT- IS NOT EMPTY.
  $UP-TO-VERB =
      IMMEDIATE-NODE IS OF TYPE N-OBJ-IN-STR
          WHERE AT IMMEDIATE OBJECT DO $COEL-VERB.
  $COEL-BESHOW = [* new structure FRAGMENT BESHOW 12/94 *]
      IMMEDIATE-NODE IS FRAGMENT;
      ELEMENT- BESHOW EXISTS;
      ELEMENT- NSTG OF ELEMENT BESUBJ EXISTS.
  $N-IN-FRAG-N =
      IMMEDIATE-NODE IS FRAGMENT
      WHERE ELEMENT- NSTG EXISTS.
  $CONN-IN-LCONNR =
      CORE- X-HOST OF COELEMENT LCONNR EXISTS.
  $ADJ-HOST =
      EITHER $LAR1-AREA-LOC OR $OTHER-ADJ.
  $LAR1-AREA-LOC =
      [* in 'LOWER EXTREMITY SYMPTOM', *]
      [* 'EXTREMITY' is the HOST of 'LOWER' *]
      BOTH PRESENT-ELEMENT- IS LAR [LAR1]
           WHERE CORE-SELATT OF CORE- HAS MEMBER H-PTAREA OR H-PTLOC
      AND $NPOS-IS-HOST
           [IF CORE OF NPOS IS H-PTPART OR H-PTAREA].
  $NPOS-IS-HOST = AT IMMEDIATE APOS, CORE-SELATT OF CORE X-HOST OF
                    COELEMENT NPOS HAS MEMBER H-PTPART OR H-PTAREA.
  $OTHER-ADJ =
     PRESENT-ELEMENT- IS LAR OR LAR1 OR LQNR
     WHERE EITHER HOST X-HOST EXISTS
           OR EITHER AT IMMEDIATE ADJINRN HOST X-HOST EXISTS
              OR $PRED-ADJ.
  $LNR-HOST = [* 'condition' IN 'improvement of condition' *]
     PRESENT-ELEMENT- IS LNR;
     EITHER BOTH X-S HAS MEMBER H-PTAREA
            AND $HOST-OF-AREA
     OR EITHER BOTH X-S HAS MEMBER H-PTPART
               AND $HOST-OF-BP
        OR IF CORE OF RN IS PN XX-PN
              WHERE P IS 'DE' OR '[DE]' OR 'OF' OR '[OF]'
           THEN CORE X-HOST OF LNR OF NSTG OF NSTGO OF XX-PN EXISTS
           ELSE IF IMMEDIATE PN X-PN EXISTS
                THEN $HOST-OF-PN.
  $HOST-OF-BP =
       BOTH RIGHT-ADJUNCT OF X-CORE IS PN XX-PN
            WHERE P IS 'AVEC' OR '[AVEC]' OR 'WITH' OR 'IN'
       AND CORE- X-HOST OF NSTGO OF XX-PN EXISTS.
  $PRED-ADJ = IMMEDIATE OBJECT OF IMMEDIATE OBJBE EXISTS;
                    CORE X-HOST OF COELEMENT SUBJECT EXISTS.
  $VERB-HOST =
       PRESENT-ELEMENT- IS OF TYPE VERBAL;
       COELEMENT- OBJECT X-OBJ EXISTS;
       ONE OF $HOST-IS-OBJ, $SUBJ.
  $HOST-IS-OBJ =
       X-OBJ IS NOT EMPTY;
       CORE X-HOST OF X-OBJ EXISTS;
       BOTH X-HOST IS NOT EMPTY
       AND IF PRESENT-ELEMENT- IS OF TYPE N-OBJ-IN-STR
              [for compound objects]
           THEN EITHER $GET-NSTG-OBJ
                OR AT LAST-ELEMENT- OF ELEMENT- PSTRING DO $IN-OBJ
           ELSE AT X-HOST DO $NOT-NHUMAN.                       (GLOBAL)
  $GET-NSTG-OBJ = AT ELEMENT- NSTGO OF X-HOST
      [ITERATET COELEMENT- NSTGO EXISTS]
      [UNTIL AT CORE- X-HOST DO $NOT-NHUMAN SUCCEEDS]
       ITERATET GO RIGHT [ fails if cannot go right ]
       UNTIL BOTH PRESENT-ELEMENT- X-PREELEM IS NSTGO
                  WHERE AT CORE- X-HOST DO $NOT-NHUMAN
             AND GO TO X-PREELEM SUCCEEDS.
  $NOT-NHUMAN = PRESENT-ELEMENT- IS NOT NHUMAN.
  $HOST-OF-AREA = ONE OF $LN-HOST, $RN-HOST.
  $LN-HOST =
       LEFT-ADJUNCT X-LN OF X-CORE EXISTS;
       EITHER $APOS-HOST OR $NPOS-HOST.
  $APOS-HOST =
       APOS OF X-LN IS NOT EMPTY;
       DO $BP-HOST.
  $BP-HOST =
       CORE-SELATT OF CORE- X-HOST HAS MEMBER H-PTPART OR H-PTAREA.
  $NPOS-HOST = NPOS OF X-LN IS NOT EMPTY;
      DO $BP-HOST.
  $RN-HOST =
       RIGHT-ADJUNCT OF X-CORE EXISTS;
       IF PRESENT-ELEMENT- IS PN
       THEN BOTH P IS 'DE' OR 'OF' OR '[DE]' AND NSTGO EXISTS;
       DO $BP-HOST.
  $BP-MISSING = X-HOST:= NIL [BODY-PART IS MISSING].
  $IN-OBJ = PRESENT-ELEMENT- IS OF TYPE STRING
       WHERE ELEMENT- VERBAL EXISTS;
       AT CORE X-HOST , DO $NOT-NHUMAN.
  $SUBJ = CORE OF X-OBJ IS EMPTY;
       AT X-OBJ CORE X-HOST OF COELEMENT SUBJECT IS N OR VING.
  $HOST-OF-OBJ =
     IF ASCEND TO OBJBE PASSING THROUGH TYPE N-OBJ-IN-STR
     THEN AT IMMEDIATE OBJECT
          CORE- X-HOST OF COELEMENT SUBJECT IS NOT EMPTY
     ELSE ASCEND TO OBJECT PASSING THROUGH TYPE N-OBJ-IN-STR
          WHERE DO $VERB-IS-HOST.
  $HOST-OF-SUBJ = IMMEDIATE SUBJECT EXISTS;
                  EITHER $OBJ-IS-HOST OR $VERB-IS-HOST.
  $OBJ-IS-HOST = AT COELEMENT- OBJECT X-OBJ, DESCEND TO OBJBE;
              DO $HOST-IS-OBJ.
  $VERB-IS-HOST =
     DO $COEL-VERB;
     CORE- X-HOST EXISTS WHERE PRESENT-ELEMENT- IS NOT EMPTY.
  $P-HOST = COELEMENT- P X-HOST OF IMMEDIATE LP EXISTS.
  $HOST-OF-PN =
       AT X-PN ONE OF $REG-HOST, $SA-RV-HOST, $HOST-OF-OBJ.   (GLOBAL)
  $ASSIGN-HOST =
       ONE OF $NO-HOST, $HOST-IS-OK, $SEM-CORE-OF-HOST,
              $WRONG-HOST, $MESS1.
  $NO-HOST = BOTH X-HOST IS NIL [COULD NOT FIND HOST]
       AND $SET-SEM-CORE [ASSIGN TYPE-SIGNAL COULD NOT FIND HOST].
  $SEM-CORE-OF-HOST =
        [FOR PN, PDATE, DSTG IN LV OR RV OF VERBAL]
       EITHER AT X-HOST DO $CHECK-ITS-SEM-CORE
       OR AT IMMEDIATE VERBAL OF X-HOST DO $CHECK-ITS-SEM-CORE.
  $CHECK-ITS-SEM-CORE = VERIFY X-OLDHOST:= X-HOST;
       EITHER PRESENT-ELEMENT- HAS NODE ATTRIBUTE SEM-CORE X-HOST
       OR BOTH EITHER PRESENT-ELEMENT- HAS NODE ATTRIBUTE N-TO-RN-ATT
               OR PRESENT-ELEMENT- HAS NODE ATTRIBUTE N-TO-RN-ATT
         @AND CORE- X-HOST EXISTS;
       EITHER $HOST-IS-OK
       OR BOTH AT X-OLDHOST STORE IN X-HOST
                  [SET X-HOST BACK TO ORIGINAL]
          AND NOT TRUE [FAIL $SEM-CORE-OF-HOST AND TRY $WRONG-HOST].
  $HOST-IS-OK =
       ONE OF $H-NULL-HOST, $HOST-OF-LQR, $LCONNR-HOST, $HOST-CHK.
  $H-NULL-HOST =
       EITHER CORE-ATT X-HOST-CORE-ATT OF X-HOST IS NIL
       OR X-HOST-CORE-ATT HAS MEMBER H-NULL OR H-TRANSP.
  $LCONNR-HOST = BOTH X-HOST IS OCCURRING IN LCONNR
                 AND $SET-SEM-CORE.
  $HOST-CHK =
     PRESENT-ELEMENT- X-IT EXISTS; [SAVE PRESENT NODE]
     IF CORE-ATT [CORE-SELATT] X-S OF X-HOST EXISTS
     THEN BOTH $CHK-NOT-HOST
          AND $CHK-IS-HOST
     ELSE X-HOST IS OCCURRING IN VERBAL;
     AT X-IT DO $SET-SEM-CORE.
  $HOST-OF-LQR =
       EITHER X-PRE IS LQR
       OR X-S HAS MEMBER H-AMT OR H-TRANSP;
       AT X-PRE DO $SET-SEM-CORE.
  $CHK-NOT-HOST =
     X-NEWLIST := LIST NOT-HOST-CLASSES;
     IF X-NEWLIST HAS MEMBER X-TYPE
        WHERE ATTRIBUTE-LIST X-TEMP EXISTS
          [LIST OF SUBCLASSES NOT PERMITTED AS HOST]
          [OF THIS TYPE OF MODIFIER]
     THEN X-S DOES NOT HAVE MEMBER X-TEMP.
  $CHK-IS-HOST =
     [FIND LIST OF ALLOWABLE HOSTS FOR MODIFIER TYPE]
     X-NEWLIST := LIST HOST-CLASSES;
     IF X-NEWLIST HAS MEMBER X-TYPE
        WHERE ATTRIBUTE-LIST X-TEMP EXISTS
     THEN EITHER X-S HAS MEMBER X-TEMP
          OR X-HOST IS 'POUR-CENT' OR 'PERCENT'
             OR 'PER' OR 'REQUIRE'.
  $SET-SEM-CORE =
    IF X-HOST IS NOT IDENTICAL TO X-IT
    THEN BOTH $ADD-TO-TYPE-ATT [ASSIGN OR ADD TO TYPE-ATT N.A.]
         AND IF X-HOST IS NOT NIL
             THEN ASSIGN NODE ATTRIBUTE SEM-CORE WITH VALUE X-HOST.
  $ADD-TO-TYPE-ATT =
       EITHER PRESENT-ELEMENT- X-IT HAS NODE ATTRIBUTE TYPE-ATT X-TEMP
       OR X-TEMP:= NIL;
       IF X-TEMP DOES NOT HAVE MEMBER X-TYPE
       THEN $ADD-TYPE-ATT.
  $ADD-TYPE-ATT =
       BOTH PREFIX X-TYPE TO X-TEMP
       AND AT X-IT ASSIGN NODE ATTRIBUTE TYPE-ATT WITH VALUE X-TEMP.
  $INIT-TYPE-REG = X-TEMP := NIL.
  $WRONG-HOST =
     ONE OF $N-TO-RIGHT, $NEXT-N, $GO-TO-SUBJ, $VERB-OF-STRING.
  $N-TO-RIGHT =
     VERIFY BOTH X-HOST IS P
            AND CORE- X-HOST OF COELEMENT- NSTGO OF X-HOST EXISTS;
     EITHER $HOST-IS-OK
     OR AT IMMEDIATE LXR
        DO $WRONG-HOST.
  $NEXT-N = AT PRESENT-ELEMENT- X-PN ITERATE $NEXT-PN
                                     UNTIL $HOST-IS-OK SUCCEEDS.
  $NEXT-PN = IMMEDIATE PN X-PN OF X-PN EXISTS;
             DO $HOST-OF-PN.
  $GO-TO-SUBJ =
     X-PRE IS OF TYPE VERBAL;
     CORE- X-HOST OF COELEMENT SUBJECT OF X-OBJ [COEL OBJ OF X-PRE]
            IS NOT EMPTY;
     AT X-PRE, DO $HOST-IS-OK.
  $VERB-OF-STRING =
     AT PRESENT-ELEMENT- X-TEMP
     ITERATE $NEXT-STRING-V
     UNTIL AT X-PRE DO $HOST-IS-OK SUCCEEDS.
  $NEXT-STRING-V =
     IMMEDIATE-STRING X-TEMP OF X-TEMP EXISTS;
     ELEMENT VERBAL EXISTS WHERE PRESENT-ELEMENT- IS NOT EMPTY;
     CORE X-HOST EXISTS;
     DO $SET-XHOST.
  $SET-XHOST =
     IF PRESENT-ELEMENT- IS IDENTICAL TO X-CORE
        [* SEM-CORE of VERB is itself *]
     THEN EITHER $HAS-SIG-CLASS
                 [IF VERB HAS SIG CLASS OTHER THAN MOD]
          OR $NEXT-STRING-V [GO UP TO NEXT STRING].
  $HAS-SIG-CLASS = X-NEWLIST:= LIST SIG-CLASS;
     X-SIG := INTERSECT OF X-S [MED SUBCLASS LIST OF VERB];
     X-SUBLIST:= LIST MOD-CLASS [MODIFIER SUBCLASSES];
     COMPLEMENT OF X-SIG IS NOT NIL [LIST WITHOUT MODIFIER].
  $MESS1 =
     DO $PRINT-ERROR;
     DO $PRINT-RESTR;
     IF X-HOST EXISTS
     @THEN $PRINT-NODE-INFO;
     IF X-S EXISTS
     @THEN $PRINT-LIST-INFO;
     WRITE ON DIAG '  HOST is not on list: assign to NIL';
     WRITE ON DIAG END OF LINE;
     X-HOST:= NIL [* cannot find HOST *];
     AT X-CORE DO $SET-SEM-CORE.
  $MESS2 =
     DO $PRINT-ERROR;
     DO $PRINT-RESTR;
     WRITE ON DIAG '  cannot find HOST for ';
     AT X-PRE  DO $PRINT-NODE-INFO;
     WRITE ON DIAG END OF LINE;
     X-HOST:= NIL [NO HOST FOR MODIFIER];
     IF X-CORE EXISTS
     @THEN $SET-SEM-CORE.
  $PRINT-NODE-INFO =
     VERIFY WRITE ON DIAG '  ';
     VERIFY WRITE ON DIAG NODE NAME;
     VERIFY WRITE ON DIAG ' = ';
     WRITE ON DIAG WORDS SUBSUMED.       (GLOBAL)
  $PRINT-LIST-INFO =
     WRITE ON DIAG LIST ELEMENT;
     WRITE ON DIAG '.'.                  (GLOBAL)
  $PRINT-ERROR =
     WRITE ON DIAG ' *** WARNING';
     WRITE ON DIAG ' CONDITION ***';
     WRITE ON DIAG END OF LINE.          (GLOBAL)
  $PRINT-RESTR =
     WRITE ON DIAG 'Transformation in ';
     VERIFY WRITE ON DIAG NODE NAME;
     WRITE ON DIAG ' = ';
     VERIFY WRITE ON DIAG WORDS SUBSUMED;
     WRITE ON DIAG END OF LINE.
* T-SEM-CORE-OF-PSTG
*    For PDATE and PN with ADVERBIAL-TYPE:TIME-ADVERBIAL.
T-SEM-CORE-OF-PSTG = IN PN, PDATE, PD:
     AT PRESENT-ELEMENT- X-PRE
     IF $TIME-PHRASE
     THEN ALL OF $SET-TYPE, $HOST-OF-TIME,
                 $ASSIGN-HOST [T-SEM-CORE-OF-LXR].
  $TIME-PHRASE =
     EITHER PRESENT-ELEMENT- X-PN IS PDATE OR PD
     OR EITHER PRESENT-ELEMENT- IS PN
               WHERE BOTH PRESENT-ELEMENT- HAS NODE ATTRIBUTE
                          ADVERBIAL-TYPE
                    @AND PRESENT-ELEMENT- HAS MEMBER TIME-ADVERBIAL
        OR EITHER BOTH CORE-SELATT OF CORE- OF NSTGO OF X-PN
                       HAS MEMBER NTIME1
                  AND ELEMENT- P OF X-PN IS H-TMPREP
           OR EITHER X-PN HAS NODE ATTRIBUTE REFPT-ATT
              OR CORE-SELATT OF HOST- OF X-PN HAS MEMBER NTIME1
                 OR NTIME2 OR H-TMLOC
      [* Note that we still need to set ADVERBIAL-TYPE *]
      [* on X-PN to have member TIME-ADVERBIAL global  *].
  $HOST-OF-TIME =
     EITHER DO $HOST-OF-PDATE
     OR DO $HOST-OF-PN [T-SEM-CORE-OF-LXR].
  $HOST-OF-PDATE =
     IMMEDIATE-NODE- OF X-PN IS SA [OR RV];
     IMMEDIATE-NODE- IS FRAGMENT
     WHERE ELEMENT- PN EXISTS;
     CORE- X-HOST OF ELEMENT- NSTGO EXISTS.
  $SET-TYPE =
     X-TYPE := SYMBOL EVENT-TIME;
     X-CORE:= X-PN.
* T-SEM-CORE-OF-QN
*       FINDS SEM-CORE FOR TIME QN
*
T-SEM-CORE-OF-QN = IN QN:
     IF BOTH AT PRESENT-ELEMENT- X-PRE ELEMENT N IS NTIME1
        AND X-PRE DOES NOT HAVE NODE ATTRIBUTE SEM-CORE
     THEN IF ALL OF $SET-TYPE, $FIND-HOST
          THEN $ASSIGN-HOST.
  $SET-TYPE = X-TYPE:= SYMBOL EVENT-TIME;
     X-CORE:= X-PRE.
* T-FROM-TO-TIME
*   OPERATES ON PN -PN1- WHEN IT HAS THE NODE ATTRIBUTE TIME-ADVERBIAL
*   AND P IS 'FROM'/'BETWEEN'/'SINCE'/'POST'/'AFTER'.
*   THE FOLLOWING CONSTRUCTION IS SEARCHED FOR:
*   1) A NESTED PN - I.E., A PN2 IN PN1  WHERE
*          P OF PN2 = 'TO'/'TIL'/'UNTIL'   AND
*          N OF PN2 IS NTIME1 [OR H-EVENT] OR H-AGE
*                OR IS A TIME NOUN - I.E., H-TMBEG, H-CHANGE, H-TMEND, H-TMDUR,
*                                          OR H-TMREP
*                OR IS A NOMINAL NOUN - I.E., NVN
*                                       AND H-TTMED, H-TTGEN, H-TTCOMP
*                E.G., 'FROM ADMISSION TO DISCHARGE'.
*   2) P IS 'BETWEEN' AND THERE IS A CONJUNCTION IN PN, E.G., 'BETWEEN
*      ADMISSION AND DISCHARGE'. THE CONJUNCTION IS EXPANDED UP TO PN
*      SO THERE IS A PN1 AND PN2. THE P OF PN2 IS REPLACED BY 'TO'.
*   3) P IS 'BETWEEN', AND N IS PLURAL AND *H-EVENT
*                                      OR NVN AND H-TTMED/H-VMO/H-TTCOMP.
* ASSERTION A IS FOUND BY GOING UP FROM PN.
*      PARSE-CONN = TIME-CONN IS ATTACHED TO THE LEFT OF A.
*      HEADCONN = P OF PN1.
* ASSERTION B IS CREATED AND ATTACHED TO THE RIGHT OF A AS FOLLOWS:
*   FOR (1) AND (2) ABOVE, ASSERTION B IS A COPY OF ASSERTION A, BUT
*   IN IT, PN2 REPLACES PN1. IN ASSERTION A, PN2 (AND CONJ-NODE) IS
*   DELETED.
*     FOR (3) ABOVE, 'PLURAL' OF N IN PN IN ASSERTION A IS REMOVED.
*   ASSERTION B IS A COPY OF 'A'. P IN 'B' IS CHANGED TO 'TO'.
*     EX.:   IN 'BETWEEN ADMISSION AND DISCHARGE'
*          ASSERTION A CONTAINS 'BETWEEN ADMISSION' AND
*          ASSERTION B CONTAINS 'TO DISCHARGE'.
*            IN 'BETWEEN ADMISSIONS'
*          'A' CONTAINS - 'BETWEEN ADMISSION' AND
*          'B' CONTAINS - 'TO ADMISSION'.
T-FROM-TO-TIME = IN PN:
      IF BOTH ELEMENT- P X-HCONN IS
              [ENGLISH] 'FROM' OR 'BETWEEN' OR 'SINCE' OR
                                  'POST' OR 'AFTER' OR
              [FRENCH] 'DE' OR ['DEPUIS' OR 'APRE2S' OR] 'ENTRE'
         AND BOTH PRESENT-ELEMENT- X1 HAS NODE ATTRIBUTE
                  ADVERBIAL-TYPE
             @AND PRESENT-ELEMENT- HAS MEMBER [IS] TIME-ADVERBIAL
      THEN ONE OF $NESTED-PN, $CONJOINED, $DE-SEULE, $PASS.
  $DE-SEULE =
      X-HCONN IS 'DE'.
  $PASS = TRUE
      [* glcb2: since starting, after treatment, after discharge *].
  $NESTED-PN = DO $FIND-NEXT.
  $CONJOINED = X-HCONN IS 'BETWEEN';
      EITHER AT X1 BOTH $FIND-CONJUNCT AND $EXPAND-CONJ
      OR $PLURAL-NOUN.
  $FIND-CONJUNCT = DESCEND TO Q-CONJ PASSING THROUGH PN OR LN;
                   STORE IN X-CONJ;
                   ITERATE GO UP UNTIL TEST FOR PN SUCCEEDS.
  $EXPAND-CONJ =
      AT IMMEDIATE-NODE- OF X-CONJ
      ITERATE AT IMMEDIATE-NODE DO EXPAND
      UNTIL TEST FOR PN SUCCEEDS;
      X1 HAS CONJUNCT X2 WHERE FIRST ELEMENT X3 OF
         IMMEDIATE-NODE OF IMMEDIATE Q-CONJ EXISTS;
      DO $MAKE-P-TO.
  $MAKE-P-TO = REPLACE P OF X2 BY <P> = '[A2]' : ('A2') [TO].
  $PLURAL-NOUN =
      BOTH CORE- X-CORE OF ELEMENT- NSTGO OF X1 HAS
           COELEMENT N X3 WHERE N IS 'PLURAL'
      AND $NOMINAL [??? 'BOTH' ADDED. WAS NOT IN WRITTEN RESTRICTION].
  $FIND-NEXT = AT ELEMENT- NSTGO OF X1
               ITERATE NEXT-ADJUNCT PN X2 EXISTS
               UNTIL VERIFY BOTH $CHECK-P2 AND $CHECK-N SUCCEEDS.
  $CHECK-N = EITHER CORE-SELATT X-S OF CORE- X-CORE OF ELEMENT-
                    NSTGO HAS MEMBER NTIME1
             OR ONE OF $TIME-NOUN, $NOMINAL, $EVENT-AGE.
  $TIME-NOUN = X-S HAS MEMBER H-TMBEG
          [OR H-CHANGE OR H-TMEND OR H-TMDUR OR H-TMREP].
  $NOMINAL = X-CORE IS NVN;
             X-S HAS MEMBER H-TTMED [ OR H-TTGEN OR H-TTCOMP].
  $EVENT-AGE =
    BOTH X-S HAS MEMBER H-AGE
        [* add PN : QUANT *]
    AND IF BOTH X-S HAS MEMBER H-AGE
           AND RIGHT-ADJUNCT-POS OF X-CORE EXISTS
               WHERE VERIFY $PN-QUANT
        THEN AT X-PN-AGE ASSIGN NODE ATTRIBUTE ADVERBIAL-TYPE
                         WITH VALUE X-ADJ-TYPE.
  $PN-QUANT =
    VALUE IS PN X-PN-AGE;
    BOTH ELEMENT- P EXISTS
    AND ELEMENT- P IS 'OF';
    VALUE OF X-PN-AGE IS QUANT;
    X-ADJ-TYPE := NIL;
    X-ADJ := SYMBOL ADJUNCT-TYPE;
    PREFIX X-ADJ TO X-ADJ-TYPE.
  $CHECK-P2 =
       AT X2 ELEMENT- P X3 IS 'A2' OR 'UNTIL' OR 'TO' OR 'TIL'.
  $BUILD-TIME-CONJ =
       DO $FIND-ASSERT [T-REL-CLAUSE];
       BEFORE X-PRE INSERT
         <PARSE-CONN> (<TIME-CONJ> (<SA> (<NULL>)
                                   +<LCONNR> X-CONN
                                   +<SA> (<NULL>)));
       DO $BUILD-LCONNR [GLOBAL IN T-CONJ-IN-CENTER];
       DO $BUILD-HEADCONN [GLOBAL IN T-CONJ-IN-CENTER];
       AFTER LAST-ELEMENT OF HEADCONN OF X-CONN
             INSERT <NULL> X-NULL;
       REPLACE X-NULL BY X3 ;
       LAST-ELEMENT- X4 OF HEADCONN OF X-CONN EXISTS;
       DO $ASSIGN-PTRS;
       AFTER X-PRE INSERT <NULL> X-NULL;
       REPLACE X-NULL BY X-PRE ;
       AT X-PRE FOLLOWING-ELEMENT- X-NEW EXISTS;
       IF X4 IS P
       THEN $FIX-PS
       ELSE IF X4 IS N [IT IS PLURAL]
            THEN $FIX-PLURAL
            ELSE $FIX-AND.
  $ASSIGN-PTRS =
       AT X-PRE ASSIGN NODE ATTRIBUTE PT1 WITH VALUE X1;
       IF X2 EXISTS
       THEN AT X-PRE ASSIGN NODE ATTRIBUTE PT2 WITH VALUE X2.
  $FIX-PS = REPLACE X2 BY <NULL>;
            X-NEW HAS NODE ATTRIBUTE PT1 X1;
            X-NEW HAS NODE ATTRIBUTE PT2 X2;
            REPLACE X1 BY X2.
  $FIX-PLURAL = DELETE X3 [REMOVE PLURAL FROM ORIGINAL ASSERTION];
                X-NEW HAS NODE ATTRIBUTE PT1 X2;
                DO $MAKE-P-TO.
  $FIX-AND = DELETE X3 [REMOVE CONJ-NODE FROM ORIGINAL ASSERTION].
* ***** *************************************************************
*
*                      SEQUENCING TRANSFORMATIONS
*
* ***** *************************************************************
TSEQ-STRING = IN STRING, CENTER:
    EITHER $EXCEPTION [DO NOT TRANSFORM]
    OR BOTH IF DO DOWN1-(VERBAL)
               WHERE PRESENT-ELEMENT- IS NOT EMPTY
           @THEN TRANSFORM PRESENT-ELEMENT-
             [PUT VERB IN TRANSFORM STACK FIRST,]
             [IT WILL BE TRANSFORMED LAST]
       AND $TRANSFORM-ELEMENTS.
  $TRANSFORM-ELEMENTS =
       AT VALUE EITHER ITERATE GO RIGHT OR TRUE;
       IF PRESENT-ELEMENT- IS EMPTY
       THEN IF $LEFT-NOT-MTY
           @THEN ITERATE VERIFY $WHAT-TO-DO
                 UNTIL $LEFT-NOT-MTY FAILS
            ELSE TRUE
       ELSE ITERATE VERIFY $WHAT-TO-DO
            UNTIL $LEFT-NOT-MTY FAILS.
  $LEFT-NOT-MTY = ITERATE GO LEFT
       UNTIL BOTH PRESENT-ELEMENT- IS NOT OF TYPE VERBAL
            AND PRESENT-ELEMENT- IS NOT EMPTY SUCCEEDS.
  $WHAT-TO-DO =
       IF ONE OF $VERBAL-TYPE, $ATOM-TYPE, $IS-TEXTLET
       THEN TRUE [DO NOT TRANSFORM]
       ELSE IF $TRANSFORM-TYPE
           @THEN TRANSFORM PRESENT-ELEMENT-.
  $EXCEPTION = ONE OF $IS-EMPTY,$HAS-Q-CONJ, $IS-LN, $HAS-FAIL-SEL
                    [T-FIXUP-ATOMS], $HAS-ADJ-TYPE [T-FIXUP-ATOMS].
  $IS-EMPTY = PRESENT-ELEMENT- IS EMPTY.
  $HAS-Q-CONJ = PRESENT-ELEMENT- HAS ELEMENT- Q-CONJ.
  $IS-LN = PRESENT-ELEMENT- IS LN [TRANSFORMED BY TSEQ-ADJUNCT].
  $TRANSFORM-TYPE =
        ONE OF $STRING-TYPE, $LXR-TYPE, $ADJSET-TYPE,
               $CONJ-TYPE, $OBJ-TYPE, $IS-CENTER, $DESCENT-TYPE.
  $IS-TEXTLET =
        PRESENT-ELEMENT- IS TEXTLET X-TXT;
        ITERATE $TRANS-TEXT
        UNTIL VALUE OF COELEMENT MORESENT OF X-TEMP IS TEXTLET
              X-TXT FAILS.
  $TRANS-TEXT =
      AT ONESENT X-TEMP OF X-TXT
      BOTH TRANSFORM ELEMENT CENTER
      AND TRANSFORM ELEMENT INTRODUCER.
  $IS-CENTER = PRESENT-ELEMENT- IS CENTER.
  $VERBAL-TYPE = PRESENT-ELEMENT- IS OF TYPE VERBAL.
  $ATOM-TYPE = PRESENT-ELEMENT- IS OF TYPE ATOM.
  $STRING-TYPE = PRESENT-ELEMENT- IS OF TYPE STRING.
  $ADJSET-TYPE = PRESENT-ELEMENT- IS OF TYPE ADJSET.
  $LXR-TYPE = EITHER PRESENT-ELEMENT- IS OF TYPE LXR
              OR PRESENT-ELEMENT- IS DSTG.
  $CONJ-TYPE = PRESENT-ELEMENT- HAS ELEMENT- Q-CONJ X1;
       IF COELEMENT SACONJ IS NOT EMPTY
                @THEN TRANSFORM VALUE;
        X1 EXISTS.
  $OBJ-TYPE = PRESENT-ELEMENT- IS OBJECT OR OBJBE OR PASSOBJ
       WHERE PRESENT-ELEMENT- IS NOT EMPTY.
  $DESCENT-TYPE = EITHER DESCEND TO LXR
         OR EITHER DESCEND TO STRING NOT PASSING THROUGH LXR
                OR DESCEND TO DSTG NOT PASSING THROUGH LXR;
       IF PRESENT-ELEMENT- IS OF TYPE STRING
       THEN VERIFY NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
       ELSE VERIFY AT CORE NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE.
* TSEQ-OBJ
TSEQ-OBJ = IN OBJECT, OBJBE, PASSOBJ:
   IF PRESENT-ELEMENT- IS NOT EMPTY
   THEN EITHER PRESENT-ELEMENT- IS OBJBE
               WHERE PRESENT-ELEMENT- IS OCCURRING IN OBJECT
                     [TRANSFORMED ALREADY]
        OR IF $DESCENT-TYPE [GLOBLA IN TSEQ-STRING]
          @THEN TRANSFORM PRESENT-ELEMENT-.
* TSEQ-ADJUNCT
TSEQ-ADJUNCT = IN ADJSET:
      IF PRESENT-ELEMENT- IS NOT EMPTY
      THEN AT VALUE
           ITERATE VERIFY IF $NOT-EMPTY
                          THEN EITHER $IS-ADJADJ
                               OR IF ONE OF $STRING-LXR-TYPE,
                                            $DESCENT-TYPE,
                                            $NNN-TYPE
                                  @THEN TRANSFORM PRESENT-ELEMENT-
           UNTIL GO RIGHT FAILS.
  $STRING-LXR-TYPE = EITHER $STRING-TYPE
                     OR $LXR-TYPE;
                     VERIFY NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE.
  $IS-ADJADJ = VALUE IS ADJADJ;
       ITERATET VERIFY $TRANSFORM-LAR1
       UNTIL VALUE IS ADJADJ FAILS [TRANSFORM ALL];
       IF VALUE IS NOT EMPTY [ BOTTOMMOST ADJADJ]
      @THEN TRANSFORM PRESENT-ELEMENT-.
  $TRANSFORM-LAR1 = GO RIGHT;
       IF PRESENT-ELEMENT- IS OF TYPE LXR
       THEN TRANSFORM PRESENT-ELEMENT-.
  $NOT-EMPTY = PRESENT-ELEMENT IS NOT EMPTY.
  $NNN-TYPE =
       EITHER BOTH ELEMENT- N EXISTS
                   WHERE VERIFY NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE
              AND BOTH TRANSFORM ELEMENT- N
                  AND ELEMENT- ADJ EXISTS
       OR DESCEND TO NNN NOT PASSING THROUGH LXR;
       VERIFY NONE OF $HAS-FAIL-SEL, $HAS-ADJ-TYPE.
TSEQ-DSTG-NNN = IN DSTG,NNN:
       IF VALUE IS DSTG OR NNN
      @THEN TRANSFORM PRESENT-ELEMENT-.
TSEQ-LXR = IN LXR:
   BOTH IF CORE IS OF TYPE STRING
       @THEN TRANSFORM PRESENT-ELEMENT-
   AND BOTH IF ELEMENT RADJSET IS NOT EMPTY
           @THEN TRANSFORM PRESENT-ELEMENT-
       AND BOTH IF ELEMENT LADJSET IS NOT EMPTY
               @THEN TRANSFORM PRESENT-ELEMENT-
           AND AT VALUE
               ITERATE IF TEST FOR PARENSTG OR DASHSTG
                      @THEN TRANSFORM PRESENT-ELEMENT
               UNTIL GO RIGHT FAILS.
  $IS-EMPTY = PRESENT-ELEMENT- IS EMPTY.
* T-REL-CLAUSE
*   OPERATES WHEN AN LNR HAS AN ASSERTION B TO ITS RIGHT. THE ASSERTION
* WAS CREATED BY AN ENGLISH TRANSFORMATION WHICH ASSIGNED TO B THE
* NODE ATTRIBUTE TFORM-ATT, POINTING TO A LIST.THE LIST CONTAINS THE
* NAME OF THE TRANSFORMATION CREATING THE ASSERTION - IN THIS CASE
* WHMOD OR NMOD [T-RN-WH OR TRN-FILLIN].
*      ASSERTION A IS FOUND BY GOING UP FROM B.
*      PARSE-CONN = REL-CLAUSE IS ATTACHED TO THE LEFT OF A.
*      B IS MOVED TO THE RIGHT OF A.
*      B IS DELETED FROM A.
*      HEADCONN = GRAM-NODE = '[WHMOD] / [NMOD]' [TRN-WH/TRN-FILLIN].
T-REL-CLAUSE = IN LNR, LAR, LAR1:
      IF FOLLOWING-ELEMENT- OF PRESENT-ELEMENT- X-LNR
                 IS ASSERTION OR FRAGMENT X-ASSERT
      THEN $REL-CLAUSE.
  $REL-CLAUSE =
      DO $FIND-ASSERT;
      EITHER ONE OF $IS-NMOD, $IS-RELATION
         [* Add $BUILD-REL-CONN to complete $BUILD-RELCLAUSE *]
      OR ALL OF $BUILD-RELCLAUSE, $BUILD-REL-CONN, $INDEX-REL-CONN.
  $IS-NMOD =
      X-PRE IS FRAGMENT WHERE ELEMENT- NSTG EXISTS;
      DO $IS-LONE-HOST;
      BOTH X-ASSERT HAS NODE ATTRIBUTE TFORM-ATT
      @AND PRESENT-ELEMENT- DOES NOT HAVE MEMBER TRNWH;
      REPLACE X-PRE BY ALL ELEMENTS OF X-NSTG;
      DELETE X-LNR;
      BOTH TRANSFORM X-ASSERT
      AND IF CONJUNCT OF X-ASSERT EXISTS @
          THEN TRANSFORM PRESENT-ELEMENT-.
  $IS-LONE-HOST =
      STORE IN X-NSTG;
          [* Make sure that this is not in a segment *]
      BOTH AT X-PRE EITHER GO LEFT
                    OR GO RIGHT [ -- wrong test ! ]
      AND SUBJECT OF X-ASSERT IS NOT EMPTY;
          [* WARNING: This is not a sufficient condition !  *]
          [*  For lack of a means to compare subtrees, this *]
          [*  condition stays for the time being.           *]
          [*  The ideal condition is that host LNR and LNR  *]
          [*  of SUBJECT of X-ASSERT are exact copy of each *]
          [*  other.                                        *]
      BOTH AT VALUE OF LN OF LNR X-LNR OF X-NSTG,
           ITERATE PRESENT-ELEMENT IS EMPTY
           UNTIL GO RIGHT FAILS
      AND ELEMENT- RN OF X-LNR IS EMPTY.
  $IS-RELATION = EITHER $PN-RELATION OR $FIX-RELATION [- FIX XF??].
  $FIX-RELATION = X-ASSERT IS ASSERTION;
      CORE OF OBJECT IS PN X-PN;
      DO $PN-CONN-TEST;
      DO $BUILD-PCONN;
      DELETE X-ASSERT;
      DO $CHECK-FOR-NULL.
  $PN-RELATION = X-ASSERT IS FRAGMENT WHERE CORE IS PN X-PN;
      DO $PN-CONN-TEST;
      DO $BUILD-PCONN [GLOBAL IN T-SA-PNCONN];
      DELETE X-ASSERT;
      DO $CHECK-FOR-NULL.
  $CHECK-FOR-NULL = [TEMP - UNTIL XF IS FIXED ?]
      AT X-LNR ITERATE IF FOLLOWING-ELEMENT- IS NULL
                       @THEN DELETE PRESENT-ELEMENT-
                UNTIL GO RIGHT FAILS.
  $FIND-ASSERT =
     ASCEND TO ASSERTION OR FRAGMENT PASSING THROUGH TYPE STRING;
     STORE IN X-PRE.
  $BUILD-RELCLAUSE =
      BEFORE X-PRE INSERT
         <PARSE-CONN> (<REL-CLAUSE> (<SA> (<NULL>)
                                    +<LCONNR> X-CONN
                                    +<SA> (<NULL>)));
      DO $BUILD-LCONNR [GLOBAL IN T-CONJ-IN-CENTER]. (GLOBAL)
  $INDEX-REL-CONN =
      BOTH EITHER CORE- X-CORE OF X-LNR HAS NODE ATTRIBUTE INDEX X-NDX
           OR X-CORE IS QN WHERE
              ELEMENT- N HAS NODE ATTRIBUTE INDEX X-NDX
      AND AT CORE- OF X-CONN ASSIGN NODE ATTRIBUTE INDEX
                            WITH VALUE X-NDX.
  $BUILD-REL-CONN =
      IF X-ASSERT HAS NODE ATTRIBUTE TFORM-ATT
         WHERE PRESENT-ELEMENT- HAS MEMBER TRNWH
      THEN AT X-CONN REPLACE HEADCONN
                     BY <HEADCONN> ( <GRAM-NODE> X-HDCONN = 'WH' ) [WHMOD]
      ELSE AT X-CONN REPLACE HEADCONN
                     BY <HEADCONN> ( <GRAM-NODE> X-HDCONN = '[NMOD]');
      EITHER DO $REPLACE-WHMOD OR TRUE;
      AFTER X-PRE INSERT ALL ELEMENTS OF IMMEDIATE-NODE OF X-ASSERT;
      AT X-LNR ITERATET DELETE PRESENT-ELEMENT- UNTIL GO RIGHT FAILS;
      AT X-PRE DELETE FOLLOWING-ELEMENT-;
      AT X-PRE DO $TRANSFORM-TO-RIGHT [GLOBAL IN T-MOVE-S-UP].
  $REPLACE-WHMOD =
      VALUE X-WH OF X-ASSERT EXISTS;
      IF X-WH IS WH-PHRASE OR WHEN-PHRASE OR TM-PHRASE
      THEN AT VALUE, STORE IN X-WH;
     [X-WH IS 'WHERE' OR 'WHEN']
     [   OR 'WHICH' OR 'WHILE' OR 'WHOM' OR 'WHOSE' OR 'WHO']
     [   OR 'OU2' OR 'DONT' OR 'QUI' OR 'QUE';]
      DO $STORE-WORDPOS;
      ONE OF $WHERE, $WHEN, $WHICH, $WHILE, $WHO, $WHOM, $WHOSE,
             $OU2, $DONT, $QUI, $QUE, $OTHERS;
      DO $RESTORE-WORDPOS;
      DELETE X-WH.
  $STORE-WORDPOS =
      X-WH HAS NODE ATTRIBUTE WORD-POS X-WDPOS.
  $RESTORE-WORDPOS =
      AT X-WHN ASSIGN NODE ATTRIBUTE WORD-POS WITH VALUE X-WDPOS.
  $WHERE =
      BOTH X-WH IS 'WHERE'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'WHERE'.
  $WHEN =
      BOTH X-WH IS 'WHEN'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'WHEN'.
  $WHICH =
      BOTH X-WH IS 'WHICH'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'WHICH'.
  $WHILE =
      BOTH X-WH IS 'WHILE'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'WHILE'.
  $WHO =
      BOTH X-WH IS 'WHO'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'WHO'.
  $WHOM =
      BOTH X-WH IS 'WHOM'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'WHOM'.
  $WHOSE =
      BOTH X-WH IS 'WHOSE'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'WHOSE'.
  $OU2 =
      BOTH X-WH IS 'OU2'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'OU2'.
  $DONT =
      BOTH X-WH IS 'DONT'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'DONT'.
  $QUI =
      BOTH X-WH IS 'QUI'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'QUI'.
  $QUE =
      BOTH X-WH IS 'QUE'
      AND REPLACE X-HDCONN BY <N> X-WHN = 'QUE'.
  $OTHERS = TRUE
       [* cannot access the subsumed word *]
     [REPLACE X-HDCONN BY X-WH, X-NEWWH].
* T-CHECK-FRMT-TYPE
*     trims FORMAT-ATT list down to one single FORMAT FOR
*     EACH KERNEL SENTENCE.  IF THIS FAILS, ISSUE A WARNING.
* *** JUNE 12, 1997
*     THIS BEGINS TO ASSUME SOME OF THE WELL-FORMEDNESS CONDITIONS
T-CHECK-FRMT-TYPE = IN ASSERTION, FRAGMENT:
       IF PRESENT-ELEMENT- X-ASSERT HAS NODE ATTRIBUTE FORMAT-ATT
          X-TYPE-LIST
       THEN EITHER $FRMT5-ALG
            OR ALL OF $GET-ASSNSELS, $ADJUST-TYPE-LIST, $CHK-TYPE-LIST
       ELSE $CHK-NOFRMT.
  $GET-ASSNSELS =
       EITHER X-ASSERT HAS NODE ATTRIBUTE ASSN-SELATTS X-ASSNSELS
       OR X-ASSNSELS := NIL.
  $ADJUST-TYPE-LIST =
       IF BOTH X-TYPE-LIST HAS MEMBER FRMT5-PTFAM
          AND BOTH X-TYPE-LIST HAS MEMBER FRMT1-3
              AND X-TYPE-LIST HAS MEMBER FRMT4
       THEN BOTH X-FMTLIST := SYMBOL FRMT345
            AND BOTH X-TYPE-LIST := NIL
                AND PREFIX X-FMTLIST TO X-TYPE-LIST.
  $FRMT5-ALG =
    BOTH ONE OF $GET-SECTION-ALLERGIES, $GET-INTRO-ALLERGIES
    AND BOTH X-TYPE-LIST := LIST FRMT5-ALG-LIST
        AND DO $ASSIGN-FRMT.
  $GET-SECTION-ALLERGIES =
       IMMEDIATE-NODE OF X-ASSERT IS CENTER;
       DO L(SECTION);
       AT VALUE OF SECT-NAME,
       ITERATET GO RIGHT
       UNTIL PRESENT-ELEMENT- IS 'ALLERGIES' OR 'SENSITIVITIES'
             SUCCEEDS.
  $GET-INTRO-ALLERGIES =
       IMMEDIATE-NODE OF X-ASSERT IS CENTER;
       DO L(INTRODUCER);
       VALUE IS LNR
       WHERE CORE- IS 'ALLERGIES' OR 'SENSITIVITIES'.
  $CHK-TYPE-LIST =
    IF SUCCESSORS OF X-TYPE-LIST IS NOT NIL
        [* There is more than one format type,     *]
        [* resolve ambiguity in format if possible.*]
    THEN $CHK-MORE
    ELSE IF BOTH X-TYPE-LIST HAS MEMBER FRMT3-5 OR FRMT345
            AND X-TYPE-LIST HAS MEMBER FRMT13-MED
         THEN DO $CHOSE-FRMT3-MED
         ELSE IF BOTH X-TYPE-LIST HAS MEMBER FRMT3-5 OR FRMT345
                 AND X-ASSNSELS HAS MEMBER H-TTSURG
              THEN DO $CHOSE-FRMT3
              ELSE IF X-TYPE-LIST HAS MEMBER FRMT3-5
                   THEN DO $CHOSE-FRMT5
                   ELSE IF X-TYPE-LIST HAS MEMBER FRMT345 OR FRMT-UNIT
                        THEN $CHK-NOFRMT.
  $CHK-MORE= IF NOT $OK-CONDITION THEN $PRINT-MESSG
             ELSE $ASSIGN-FRMT.
  $OK-CONDITION =
       ONE OF $REMOVE-FRMT0, [$REMOVE-FRMT2,] $REMOVE-FRMT6,
             [$REMOVE-FRMT1,] $CHK-FRMT5-EKG, $CHK-FRMT345,
              $INDIC-HISTORY, $CHK-FRMT3-5, $CHK-FRMT3-4,
              $REMOVE-FRMT-UNIT, $PE-CHK;
       DO $CHK-TYPE-LIST [* subsequent rounds of elimination *].
  $CHK-FRMT3-4 =
       BOTH X-TYPE-LIST HAS MEMBER FRMT1-3 OR FRMT13-MED
       AND X-TYPE-LIST HAS MEMBER FRMT4;
        [* if VERB is a VBE/BEREP or SHOW or change, *]
        [* use SUBJECT as the main cue (topical) to  *]
        [* disambiguate the format.                  *]
       EITHER
          BOTH CORE-ATT X-VERB OF CORE- OF ELEMENT- VERB OF X-ASSERT HAS
                MEMBER VBE OR H-BECONN [* new 991027 *]
                OR BEREP OR H-SHOW OR H-CHANGE
                OR H-CHANGE-MORE OR H-CHANGE-LESS OR H-CHANGE-SAME
          AND CORE-ATT X-SUBJ OF CORE- X-SUBJ-CORE OF ELEMENT- SUBJECT
                OF X-ASSERT IS NOT NIL
       OR X-ASSERT IS FRAGMENT
          WHERE CORE-ATT X-SUBJ OF CORE- X-SUBJ-CORE OF
                       ELEMENT- NSTG IS NOT NIL;
       IF BOTH X-SUBJ-CORE HAS NODE ATTRIBUTE COMPUTED-ATT
          AND X-SUBJ HAS MEMBER H-RESULT
       THEN CORE-SELATT X-SUBJ OF X-SUBJ-CORE IS NOT NIL;
       IF X-SUBJ HAS MEMBER H-TXVAR OR H-TXSPEC OR H-ORG
                 OR H-PTSPEC OR H-TXRES
         [AND BOTH DO $FIND-SECTION]
         [  AND X-SECTION IS 'LAB' OR 'LABORATORY-DATA']
         [           OR 'HOSPITAL-COURSE']
       THEN DO $CHOSE-FRMT4
       ELSE IF X-SUBJ HAS MEMBER H-TTGEN OR H-TTCOMP OR H-TTSURG
               OR H-TTMED OR H-TTMODE
            THEN DO $CHOSE-FRMT3
            ELSE BOTH X-SUBJ DOES NOT HAVE MEMBER H-NULL OR H-PT OR
                      H-FAMILY
                 AND DO $CHOSE-FRMT5.
  $INDIC-HISTORY =
       X-TYPE-LIST HAS MEMBER FRMT345;
        [* if SUBJECT is a TXCLIN or TXPROC, *]
        [*    VERB is comparable to VSHOW    *]
        [*    predicate is H-TTSURG or H-INDIC *]
        [* it is a structure of illness H-TXRES *]
       ALL OF $IMPLIED-HISTORY, $CHOSE-FRMT5, $ADD-TXRES.
  $IMPLIED-HISTORY =
    CORE-ATT X-SUBJ OF CORE- OF ELEMENT- SUBJECT OF X-ASSERT
             HAS MEMBER H-TXCLIN OR H-TXPROC;
    EITHER BOTH CORE-ATT X-VERB OF CORE- OF ELEMENT- VERB
                OF X-ASSERT HAS MEMBER H-SHOW
           AND CORE-ATT X-OBJ OF CORE- X-OBJCORE OF NSTGO OF
               ELEMENT- OBJECT OF X-ASSERT IS NOT NIL
    OR BOTH X-VERB HAS MEMBER VBE OR BEREP
       AND VALUE OF OBJBE OF OBJECTBE OF ELEMENT- OBJECT
                 OF X-ASSERT IS PN
           WHERE CORE-ATT X-OBJ OF CORE- X-OBJCORE OF ELEMENT-
                 NSTGO IS NOT NIL;
    X-OBJ HAS MEMBER H-TTSURG OR H-INDIC [OR H-DIAG].
  $ADD-TXRES = [* an H-TTSURG implies a past illness *]
    IF X-OBJ HAS MEMBER H-TTSURG
    THEN $INSERT-TXRES.
  $INSERT-TXRES =
    X-ADD := SYMBOL H-TXRES;
    PREFIX X-ADD TO X-OBJ;
    IF X-OBJCORE HAS NODE ATTRIBUTE COMPUTED-ATT
    THEN AT X-OBJCORE ASSIGN NODE ATTRIBUTE COMPUTED-ATT
                      WITH VALUE X-OBJ
    ELSE AT X-OBJCORE ASSIGN NODE ATTRIBUTE SELECT-ATT
                      WITH VALUE X-OBJ.
  $CHK-FRMT3-5 =
          [* Resolve ambiguity between FORMAT5 and FORMAT1-3 *]
          [* if fails, choose FORMAT5.                       *]
    X-TYPE-LIST HAS MEMBER FRMT3-5;
    EITHER BOTH X-TYPE-LIST HAS MEMBER FRMT5 OR FRMT5-PTFAM OR FRMT5F
                                    OR FRMT5-ALG
           AND X-TYPE-LIST DOES NOT HAVE MEMBER FRMT1-3 OR FRMT13-MED
    OR EITHER BOTH X-TYPE-LIST HAS MEMBER FRMT1-3 OR FRMT13-MED
              AND X-TYPE-LIST DOES NOT HAVE MEMBER FRMT5
                  OR FRMT5-PTFAM OR FRMT5F OR FRMT5-ALG
       OR BOTH BOTH X-TYPE-LIST DOES NOT HAVE MEMBER FRMT5
                    OR FRMT5-PTFAM OR FRMT5F OR FRMT5-ALG
               AND X-TYPE-LIST DOES NOT HAVE MEMBER FRMT1-3
                   OR FRMT13-MED
          AND $CHOSE-FRMT5;
    DO $REMOVE-FRMT3-5.
  $REMOVE-FRMT3-5 =
       X-SUBLIST:= LIST FRMT3-5-LIST;
       COMPLEMENT X-TYPE-LIST OF X-TYPE-LIST EXISTS.
  $PE-CHK =
       X-TYPE-LIST HAS MEMBER FRMT5 OR FRMT5-PTFAM OR FRMT5F
                           OR FRMT5-ALG;
       EITHER BOTH DO $FIND-INTRO
              AND X-INTRO IS 'PE' ['PE-10CC OF FLUID' IS FRMT5]
       OR BOTH DO $FIND-SECTION
          AND X-SECTION IS 'PHYSICAL-EXAM' OR 'PHYSICAL-EXAMINATION';
       DO $CHOSE-FRMT5.
  $REMOVE-FRMT0 =
       X-TYPE-LIST HAS MEMBER FRMT0;
       X-SUBLIST:= LIST FRMT0-LIST;
       COMPLEMENT X-TYPE-LIST OF X-TYPE-LIST EXISTS.
  $REMOVE-FRMT1 =
       X-TYPE-LIST HAS MEMBER FRMT1;
       X-TYPE-LIST HAS MEMBER FRMT1-3 OR FRMT13-MED OR FRMT4 OR
                    FRMT5 OR FRMT5F OR FRMT5-ALG OR FRMT5-PTFAM;
       X-SUBLIST := LIST FRMT1-LIST;
       DO $REMOVE-IT.
  $REMOVE-IT = COMPLEMENT X-TYPE-LIST OF X-TYPE-LIST EXISTS.
  $REMOVE-FRMT2 =
       X-TYPE-LIST HAS MEMBER FRMT2;
       X-TYPE-LIST HAS MEMBER [FRMT3] FRMT1-3;
       X-SUBLIST:= LIST FRMT2-LIST;
       COMPLEMENT X-TYPE-LIST OF X-TYPE-LIST EXISTS.
  $REMOVE-FRMT6 = X-TYPE-LIST HAS MEMBER FRMT6;
       X-SUBLIST:= LIST FRMT6-LIST;
       COMPLEMENT X-TYPE-LIST OF X-TYPE-LIST EXISTS.
  $REMOVE-FRMT-UNIT =
       X-TYPE-LIST HAS MEMBER FRMT-UNIT;
       X-TYPE-LIST HAS MEMBER FRMT1-3 OR FRMT13-MED OR FRMT4 OR
                       FRMT5-PTFAM OR FRMT5 OR FRMT5-ALG OR
                       FRMT5F OR FRMT6;
       X-SUBLIST:= LIST FRMT-UNIT-LIST;
       COMPLEMENT X-TYPE-LIST OF X-TYPE-LIST EXISTS.
  $CHK-FRMT5-EKG =
       X-TYPE-LIST HAS MEMBER FRMT5-EKG;
       DO $CHOSE-FRMT5-EKG.
  $CHK-FRMT345 = [* this removes FRMT345 *]
    X-TYPE-LIST HAS MEMBER FRMT345;
    ONE OF $IS-A-FRMT4, $IS-A-FRMT35, $IS-A-FRMT5S,
           $IS-A-FRMT45, $IS-A-FRMT13;
    DO $REMOVE-FRMT345.
  $IS-A-FRMT4 = [* case FRMT4 and FRMT345 *]
    BOTH X-TYPE-LIST HAS MEMBER FRMT4
    AND X-TYPE-LIST DOES NOT HAVE MEMBER FRMT5 OR FRMT5F OR FRMT5-PTFAM
                    OR FRMT5-ALG OR FRMT5-EKG OR FRMT5-MISC
                    OR FRMT1-3 OR FRMT13-MED OR FRMT3-5.
  $IS-A-FRMT35 = [* case FRMT3-5 and FRMT345 *]
    BOTH X-TYPE-LIST HAS MEMBER FRMT3-5
    AND BOTH X-TYPE-LIST DOES NOT HAVE MEMBER FRMT4
        AND DO $CHK-FRMT3-5.
  $IS-A-FRMT5S = [* case FRMT5's and FRMT345 *]
    BOTH X-TYPE-LIST HAS MEMBER FRMT5 OR FRMT5F OR FRMT5-EKG
                             OR FRMT5-PTFAM OR FRMT5-ALG
                             OR FRMT5-MISC
    AND X-TYPE-LIST DOES NOT HAVE MEMBER FRMT1-3 OR FRMT4
                                      OR FRMT45 OR FRMT3-5.
  $IS-A-FRMT45 =
    BOTH X-TYPE-LIST HAS MEMBER FRMT5 OR FRMT5F
                         OR FRMT5-PTFAM OR FRMT5-ALG
    AND X-TYPE-LIST HAS MEMBER FRMT4.
  $IS-A-FRMT13 =
    BOTH X-TYPE-LIST HAS MEMBER FRMT1-3 OR FRMT13-MED
    AND X-TYPE-LIST DOES NOT HAVE MEMBER FRMT5 OR FRMT5F
           OR FRMT5-PTFAM OR FRMT5-ALG OR FRMT5-EKG OR FRMT5-MISC
           OR FRMT4 OR FRMT45 OR FRMT3-5.
  $REMOVE-FRMT345 =
       X-SUBLIST:= LIST FRMT345-LIST;
       COMPLEMENT X-TYPE-LIST OF X-TYPE-LIST EXISTS.
  $ASSIGN-FRMT =
       AT X-ASSERT ASSIGN NODE ATTRIBUTE FORMAT-ATT
                   WITH VALUE X-TYPE-LIST.
  $ASSIGN-NOFRMT = X-TYPE-LIST:= LIST NOFRMT-LIST;
        DO $ASSIGN-FRMT.
  $PRINT-MESSG =
       WRITE ON DIAG ' *** ERROR ';
       WRITE ON DIAG 'CONDITION:';
       WRITE ON DIAG ' More than 1 ';
       WRITE ON DIAG 'FORMAT type.';
       WRITE ON DIAG END OF LINE;
       AT X-TYPE-LIST WRITE ON DIAG LIST ELEMENT.
  $CHK-NOFRMT =
    ONE OF [$IS-H-CHANGE,] $CHK-INTRO, $CHOSE-FRMT5, $ASSIGN-NOFRMT.
  $CHK-INTRO =
    ONE OF $CHOSE-4-5, $CHOSE-UNIT, $CHOSE-MED, $CHOSE-PT.
  $CHOSE-PT =
    EITHER X-INTRO EXISTS OR $FIND-INTRO;
    BOTH X-INTRO IS H-PTPART OR H-PTFUNC
    AND DO $CHOSE-FRMT5.
  $CHOSE-MED =
    EITHER BOTH EITHER X-INTRO EXISTS OR $FIND-INTRO
           AND X-INTRO IS 'ME'
    OR BOTH EITHER X-SECTION EXISTS OR $FIND-SECTION
       AND X-SECTION IS 'MEDICATIONS';
    DO $CHOSE-FRMT3-MED.
  $CHOSE-4-5 =
    X-TYPE-LIST HAS MEMBER FRMT345;
   [BOTH DO $FIND-INTRO AND] DO $FIND-SECTION;
    IF [EITHER X-INTRO IS 'PE'--PHYSICAL-EXAM-- OR 'AS' --ASSESSMENT--
                       OR 'IP'--IMPRESSION-- OR 'OB' --OBJECTIVE--,]
       [OR] X-SECTION IS 'PHYSICAL-EXAM' OR 'PHYSICAL-EXAMINATION'
       THEN DO $CHOSE-FRMT5
       ELSE IF DO $HAS-TTSURG
            THEN DO $CHOSE-FRMT3
            ELSE IF [EITHER X-INTRO IS 'HI'--HISTORY-- OR 'PL'--PLAN--,]
                    [OR] X-SECTION IS 'LAB' OR 'LABORATORY-DATA'
                    OR 'HOSPITAL-COURSE'
                 THEN DO $CHOSE-FRMT4.
  $HAS-TTSURG =
    X-ASSNSELS HAS MEMBER H-TTSURG.
  $CHOSE-FRMT3 = X-TYPE-LIST:= LIST [FRMT3-LIST] FRMT1-3-LIST;
       DO $ASSIGN-FRMT
      [* Strange condition for FORMAT13-MED *]
      [IF ONE OF $OBJECT-EMPTY, $SUBJECT-EMPTY, $NSTG-CORE-EMPTY]
      [THEN $CHANGE-TO-MED].
  $CHOSE-FRMT5-EKG = X-TYPE-LIST:= LIST FRMT5-EKG-LIST;
       DO $ASSIGN-FRMT.
  $CHOSE-FRMT3-MED = X-TYPE-LIST:= LIST FRMT13-MED-LIST;
       DO $ASSIGN-FRMT.
  $OBJECT-EMPTY =
       EITHER VALUE XX-NSTG OF OBJECT IS NULLOBJ
                          WHERE DO $BUILD-COND [BUILD NSTG]
       OR CORE OF OBJECT IS EMPTY WHERE IMMEDIATE LNR XX-LNR EXISTS.
  $SUBJECT-EMPTY = EITHER VALUE XX-NSTG OF SUBJECT IS NSTG
                          WHERE CORE OF LNR XX-LNR IS EMPTY
                   OR SUBJECT IS EMPTY WHERE DO $BUILD-SUBJ.
  $NSTG-CORE-EMPTY = CORE OF LNR XX-LNR OF NSTG IS EMPTY.
  $CHANGE-TO-MED = AT CORE OF XX-LNR [* ??? *]
       REPLACE PRESENT-ELEMENT- BY <GRAM-NODE> = '[MEDICATION]': (H-TTMED).
  $CHOSE-FRMT4 = X-TYPE-LIST := LIST FRMT4-LIST;
       DO $ASSIGN-FRMT.
  $CHOSE-FRMT5 =
    IF CORE-ATT X-SUBJ-ATT OF CORE- OF ELEMENT- SUBJECT OF X-ASSERT
       HAS MEMBER H-FAMILY
    THEN X-TYPE-LIST := LIST FRMT5F-LIST
    ELSE IF $FRMT5-ALG
         THEN X-TYPE-LIST := LIST FRMT5-ALG-LIST
         ELSE X-TYPE-LIST := LIST FRMT5-LIST;
    DO $ASSIGN-FRMT.
  $CHOSE-UNIT = X-TYPE-LIST HAS MEMBER FRMT-UNIT;
    IF BOTH $FIND-INTRO AND $FIND-SECTION
    THEN IF [EITHER X-INTRO IS 'ME' OR 'PL']
            [OR] X-SECTION IS 'MEDICATIONS'
         THEN $CHOSE-FRMT3-MED.
  $FIND-INTRO = IMMEDIATE-NODE OF X-ASSERT IS CENTER;
       DO L(INTRODUCER);
       ITERATET $NEXT-INTRO
       UNTIL PRESENT-ELEMENT- IS NOT EMPTY SUCCEEDS;
       CORE- X-INTRO OF VALUE EXISTS.
  $NEXT-INTRO = ASCEND TO MORESENT PASSING THROUGH STRING;
       DO L(ONESENT);
       ELEMENT- INTRODUCER EXISTS.
  $FIND-SECTION = IMMEDIATE-NODE OF X-ASSERT IS CENTER;
       DO L(SECTION);
       ITERATET $NEXT-SECTION
       UNTIL PRESENT-ELEMENT- IS NOT EMPTY SUCCEEDS;
       SECOND ELEMENT [CORE-] X-SECTION [OF VALUE] EXISTS.
  $NEXT-SECTION = ASCEND TO MORESENT PASSING THROUGH STRING;
       DO L(ONESENT);
       ELEMENT- SECTION EXISTS.
  $IS-H-CHANGE =
       ONE OF $CHANGE-VERB, $CHANGE-FRAG, $CHANGE-OBJ, $CHANGE-DOSE.
  $CHANGE-DOSE = NOT TRUE [* to be added *].
  $CHANGE-VERB =
       BOTH CORE-SELATT X-SEL OF CORE OF VERB X-VERB HAS MEMBER
               H-CHANGE OR H-CHANGE-MORE OR H-CHANGE-LESS OR
               H-CHANGE-SAME WHERE DO $NO-DOSE
       AND AT X-VERB IF DO L(SUBJECT)
              WHERE PRESENT-ELEMENT- X-SUBJ EXISTS
           THEN $ADD-COND-IN-SUBJ.
  $ADD-COND-IN-SUBJ = IF CORE X-C OF X-SUBJ IS EMPTY
                 THEN AT X-SUBJ DO $CHANGE-TO-COND
                 ELSE BOTH CORE-SELATT OF X-C HAS MEMBER H-PTPART
                           OR H-PTAREA OR H-PT
                      AND AT X-SUBJ DO $ADD-COND.
  $NO-DOSE = X-SEL DOES NOT HAVE MEMBER H-AMT.
  $CHANGE-TO-COND =
       IF SUBJECT IS EMPTY
       THEN $BUILD-SUBJ
       ELSE IF CORE X-CORE OF SUBJECT IS EMPTY
       THEN $BUILD-CORE.
  $BUILD-SUBJ = AT SUBJECT REPLACE PRESENT-ELEMENT- BY
                  <SUBJECT> (<NSTG> XX-NSTG);
        DO $BUILD-COND.
  $BUILD-COND = AT XX-NSTG REPLACE PRESENT-ELEMENT- BY
       <NSTG> (<LNR>XX-LNR (<LN>X-LN
                           +<NVAR> (<NULL>X-CORE)
                           +<RN> (<NULL>)));
       DO $BUILD-LN;
       DO $BUILD-CORE.
  $ADD-COND =
       LNR XX-LNR OF NSTG OF X-SUBJ EXISTS;
       AT XX-LNR REPLACE PRESENT-ELEMENT- BY
        <LNR> (<LN> X-LN
              +<NVAR> (<NULL> X-CORE)
              +<RN> (<PN> (<P> = '[OF]' [DE]
                          +<NSTGO> (<NSTG> (XX-LNR)))));
        DO $BUILD-LN;
        DO $BUILD-CORE.
  $BUILD-LN = AT X-LN REPLACE PRESENT-ELEMENT- BY
       <LN> (<TPOS> (<NULL>)
            +<QPOS> (<NULL>)
            +<APOS> (<NULL>)).
  $BUILD-CORE =
       AT X-CORE REPLACE PRESENT-ELEMENT- BY
           <N> = '[CONDITION]': (H-INDIC);
       TRANSFORM X-ASSERT.
  $CHANGE-FRAG = X-ASSERT IS FRAGMENT;
       CORE-SELATT OF CORE XX-CORE OF NSTG HAS MEMBER H-CHANGE
       OR H-CHANGE-MORE OR H-CHANGE-LESS OR H-CHANGE-SAME;
       DO $CHANGE-COND.
  $CHANGE-COND =
       IF XX-CORE IS OCCURRING IN LNR
       THEN $ADD-OF-COND
       ELSE BOTH SUBJECT X-SUBJ OF X-ASSERT EXISTS
            AND $ADD-COND-IN-SUBJ.
  $ADD-OF-COND =
       RIGHT-ADJUNCT-POS XX-RN OF XX-CORE EXISTS;
       REPLACE XX-RN BY
        <RN> (<PN> (<P> = '[DE]' [OF]
                   +<NSTGO> (<NSTG> (<LNR> (<LN>X-LN
                                           +<NVAR> (<NULL>X-CORE)
                                           +XX-RN)))));
       DO $BUILD-LN;
       DO $BUILD-CORE.
  $CHANGE-OBJ = X-ASSERT IS ASSERTION;
       EITHER CORE-SELATT OF CORE XX-CORE OF OBJECT HAS MEMBER
              H-CHANGE OR H-CHANGE-MORE OR H-CHANGE-LESS OR
              H-CHANGE-SAME
       OR $CORE-IS-STRING;
       DO $CHANGE-COND.
  $CORE-IS-STRING = XX-CORE IS NPN OR NN OR PNN OR PN;
       NSTGO OF XX-CORE EXISTS;
       CORE-SELATT OF CORE XX-CORE HAS MEMBER H-CHANGE
       OR H-CHANGE-MORE OR H-CHANGE-LESS OR H-CHANGE-SAME.
* T-SUBJECT-CHK
*   OPERATES WHEN SUBJECT IS H-FAMILY AND NOT H-PT AND FORMAT-ATT IS
*   NOT FRMT00. T-SUBJECT-CHK ASSIGNS ASSERTION/FRAGMENT FORMAT-ATT
*   WITH THE VALUE FRMT0 WHICH IS USED FOR PATIENT DESCRIPTOR.
* -- OBSOLETE WITH FORMAT5F (FOR FAMILY MEMBER)
T-SUBJECT-CHK = IN ASSERTION, FRAGMENT:
       IF EITHER AT PRESENT-ELEMENT- X-ASSERT, SUBJECT EXISTS
          OR ELEMENT NSTG EXISTS
      @THEN AT CORE X1, DO $FAM-CHK.
  $FAM-CHK =
     EITHER $IS-FRMT00
     OR IF CORE-SELATT X-S OF X1 HAS MEMBER H-FAMILY
        THEN EITHER X-S HAS MEMBER H-PT
             OR EITHER [BOTH X1 IS PRO]
                       [AND $REMOVE-FAMILY]
                       AT X-ASSERT DO $CONFIRM-FRMT5F
                OR AT X-ASSERT DO $ASSIGN-FRMT0 [T-LXR-FORMAT-TYPE].
  $REMOVE-FAMILY =
     [* takes H-FAMILY out of a PRO -- temporary *]
     X-SUBLIST := LIST PT-FAM;
     COMPLEMENT X-S OF X-S IS NOT NIL.
  $CONFIRM-FRMT5F =
     EITHER PRESENT-ELEMENT- HAS NODE ATTRIBUTE FORMAT-ATT
            WHERE PRESENT-ELEMENT- HAS MEMBER FRMT5F
     OR BOTH X-TYPE-LIST := LIST FRMT5F-LIST
        AND AT X-ASSERT ASSIGN NODE ATTRIBUTE FORMAT-ATT WITH
            VALUE X-TYPE-LIST.
  $IS-FRMT00 =
     BOTH PRESENT-ELEMENT- HAS NODE ATTRIBUTE FORMAT-ATT
    @AND PRESENT-ELEMENT- HAS MEMBER FRMT00.
* T-REMOVE-INTRO
*   removes INTRODUCER
* *** This rule goes with T-DISTRIBUTE-INTRO.
T-REMOVE-INTRO = IN CENTER:
  IF BOTH PREVIOUS-ELEMENT- IS INTRODUCER X-INTRO
     AND CORE- OF X-INTRO IS ':'
  THEN REPLACE X-INTRO BY <INTRODUCER> (<NULL>).
* T-PNCH-TREE - WRITES OUT RESULTANT TREE
* END-REGS
*CLOSE(A)
