zorkzero/reds.zil

"REDS file: imitates old parser.
Copyright (C) 1988 Infocom, Inc.  All rights reserved."

<ZZPACKAGE "REDS">

<ENTRY	RED-SP RED-ADV RED-PART
	RED-SV RED-SVN RED-SVNP RED-SVPNPN RED-SVPNN RED-SVNPN RED-SD RED-SVD
	RED-PERS RED-VP RED-NP RED-OF RED-QT RED-QN RED-NPP RED-PP
	RED-POSS RED-ADJ RED-QUOTE>

<ENTRY	RED-O-ADJ RED-O-PP RED-O-NP NUMERIC-ADJ?>

<INCLUDE "BASEDEFS" "FIND" "PBITDEFS" "PDEFS">

<USE "NEWSTRUC" "PARSER" "PMEM" "PSTACK">

<FILE-FLAGS MDL-ZIL? ;ZAP-TO-SOURCE-DIRECTORY?>

<BEGIN-SEGMENT 0> 

<DEFMAC ABS ('NUM)
	<FORM COND (<FORM L? .NUM 0> <FORM - 0 .NUM>)
	           (T .NUM)>>

"Generic reduction, which just returns a list of frobs"
<DEFINE RED-FCN ("OPT" N:FIX TYP:FIX)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "ANY">) (T <RFALSE>)>)>
	<COND (<==? .N 0> T)
	      (<==? .N 1>
	       <POP-PSTACK ,DATA-STACK>)>>

<DEFINE RED-PART RP ("OPT" N:FIX TYP:FIX "AUX" WD)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "?PART">) (T <RFALSE>)>)>
	<COND (<==? .N 0>
	       <RETURN T .RP>)>
	<SET WD <POP-PSTACK ,DATA-STACK>>
	<COND (<AND <NOT <EQUAL? .WD T ,W?OF>>
		    <NOT <WORD-TYPE? .WD ,P-PARTICLE-CODE>>>
	       <RETURN <> .RP>)
	      (<==? .N 1>
	       <RETURN .WD .RP>)
	      (T
	       <POP-PSTACK ,DATA-STACK>)>>

<DEFINE GET-SYNTAX GS (VA:TABLE NUM "OPT" (PREP 0) (GWIM <>) "AUX" LEN)
  <COND (<==? .PREP 1>
	 <SET PREP 0>)>
  <COND (<1? .NUM>
	 <SET LEN ,VERB-ONE-SYNTAX-LEN ;6>)
	(T
	 <SET LEN ,VERB-TWO-SYNTAX-LEN ;10>)>
  <REPEAT ((CT:FIX <ZGET .VA 0>) S2 (P2 <PARSE-PARTICLE2 ,PARSE-RESULT>)
	   (GWIM-NOW <>)
	   (SYN <IF-MUDDLE <CHTYPE <ZREST .VA 2> VERB-SYNTAX>
			   <ZREST .VA 2>>))
    <COND (<AND <==? .PREP <SYNTAX-PREP ;1 .SYN 1>>
		<OR <1? .NUM>
		    <EQUAL? .P2
			    <SET S2 <SYNTAX-GET .SYN ,SYN-PREP 2>>>
		    <AND <0? .S2>
			 <1? .P2>>
		    <AND <T? .GWIM-NOW>
			 <T? <SET S2 <COND (<1? .NUM> .PREP) (T .S2)>>>
			 <ZPUT ,GWIM-MSG 0 .S2>>>>
	   <PARSE-SYNTAX ;3 ,PARSE-RESULT .SYN>
	   <PARSE-ACTION ;4 ,PARSE-RESULT <SYNTAX-ID .SYN>>
	   <PARSE-PARTICLE1 ,PARSE-RESULT .PREP>
	   <RETURN .SYN .GS>)
	  (<L? <SET CT <- .CT 1>> 1>
	   <COND (<AND <T? .GWIM>
		       <F? .GWIM-NOW>>
		  <SET CT <ZGET .VA 0>>
		  <SET GWIM-NOW T>
		  <SET SYN <IF-MUDDLE <CHTYPE <ZREST .VA 2> VERB-SYNTAX>
				      <ZREST .VA 2>>>
		  <AGAIN>)
		 (T
		  <RETURN <> .GS>)>)
	  (T
	   <SET SYN <IF-MUDDLE <CHTYPE <ZREST .SYN .LEN> VERB-SYNTAX>
			       <ZREST .SYN .LEN>>>)>>>

"Reduction for case of verb with no objects.  If OK, win.  Otherwise,
 try defaulting (and go to case of verb with one object)/orphaning..."

<DEFINE RED-SV ("OPT" N:FIX TYP:FIX "AUX" SYN VERB PART DATA:VERB-DATA OBJ)
    ;<COND (<NOT <ASSIGNED? N>>
	   <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP-?P">) (T <RFALSE>)>)>
    <SET PART <POP-PSTACK ,DATA-STACK>>
    <POP-PSTACK ,DATA-STACK>
    <COND (<SET VERB <ROOT-VERB <PARSE-VERB ,PARSE-RESULT>>>
	   <SET DATA <WORD-VERB-STUFF .VERB>>
	   <COND (<AND <1? .PART>
		       <L=? 0 <VERB-ZERO .DATA>:FIX>>
		  ;"Verb can take no args, so this flies"
		  <PARSE-ACTION ,PARSE-RESULT <VERB-ZERO .DATA>>
		  T ;,PARSE-RESULT)
		 (<AND <SET SYN <VERB-ONE .DATA>>
		       <SET SYN <GET-SYNTAX .SYN 1 .PART T>>
		       <SET OBJ <DETERMINE-OBJ <> 1>>>
		  <PARSE-OBJ1 ,PARSE-RESULT .OBJ>
		  T ;,PARSE-RESULT)
		 (<AND <SET SYN <VERB-TWO .DATA>>
		       <SET SYN <GET-SYNTAX .SYN 2 .PART T>>
		       <SET OBJ <DETERMINE-OBJ <> 1>>>
		  <PARSE-OBJ1 ,PARSE-RESULT .OBJ>
		  <ZPUT ,ORPHAN-S ,O-OBJECT <NOUN-PHRASE-OBJ1 .OBJ>>
		  <COND (<SET OBJ <DETERMINE-OBJ <> 2>>
			 <PARSE-OBJ2 ,PARSE-RESULT .OBJ>
			 T ;,PARSE-RESULT)>)>)>>

<DEFINE ROOT-VERB (VERB "AUX" DATA)
	<COND (<AND <T? <WORD-FLAGS .VERB>>
		    <SET DATA <WORD-SEMANTIC-STUFF .VERB>>>
	       <SET VERB .DATA>)>
	.VERB>

<DEFINE RED-SVN ("OPT" N:FIX TYP:FIX
		"AUX" SYN1 SYN2 VERB PART DATA OBJ OBJ1 OBJ2)
   ;<COND (<NOT <ASSIGNED? N>>
	  <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP-?P-NP">) (T <RFALSE>)>)>
   <SET OBJ <POP-PSTACK ,DATA-STACK>>
   <SET PART <POP-PSTACK ,DATA-STACK>>
   ;<PARSE-PARTICLE1 ,PARSE-RESULT .PART>
   <POP-PSTACK ,DATA-STACK>	;"RED-SVNP depends on these POPs"
   <COND (<SET VERB <ROOT-VERB <PARSE-VERB ,PARSE-RESULT>>>
	  <SET DATA <WORD-VERB-STUFF .VERB>>
	  <COND (<AND <ZERO? <PARSE-PARTICLE2 ,PARSE-RESULT>>
		      <SET SYN1 <VERB-ONE .DATA>>
		      <SET SYN1 <GET-SYNTAX .SYN1 1 .PART>>>
		 ;<PARSE-PARTICLE1 ,PARSE-RESULT .PART>	;"SWG 28-Jul-88"
		 <COND (<NOT <SET OBJ1 <DETERMINE-OBJ .OBJ 1>>>
			<PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .OBJ
				      .PART ;<SYNTAX-SEARCH ;B5 .SYN1 1>>)
		       (<AND <EQUAL? ,INTDIR <NOUN-PHRASE-OBJ1 .OBJ1>>
			     <ZAPPLY ,DIR-VERB-WORD?
				     <PARSE-VERB ,PARSE-RESULT>>
			     <PUSH-PSTACK ,DATA-STACK <NP-NAME .OBJ>>>
			<RED-SD 1 .TYP>)
		       (T
			<PARSE-OBJ1 ,PARSE-RESULT .OBJ1>
			,PARSE-RESULT)>)
		(<AND <SET SYN2 <VERB-TWO .DATA>>
		      <SET SYN2 <GET-SYNTAX .SYN2 2 .PART T>>>
		 ;<PARSE-PARTICLE1 ,PARSE-RESULT .PART>	;"SWG 28-Jul-88"
		 <COND (<NOT <SET OBJ1 <DETERMINE-OBJ .OBJ 1>>>
			<PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .OBJ
				      .PART ;<SYNTAX-SEARCH ;B5 .SYN2 1>>)
		       (T
			<PARSE-OBJ1 ,PARSE-RESULT .OBJ1>
			<ZPUT ,ORPHAN-S ,O-OBJECT <NOUN-PHRASE-OBJ1 .OBJ1>>
			<COND (<SET OBJ2 <DETERMINE-OBJ <> 2>>
			       <PARSE-OBJ2 ,PARSE-RESULT .OBJ2>
			       ,PARSE-RESULT)>)>)
		;(T
		 <PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .OBJ
			       .PART ;<SYNTAX-SEARCH ;B5 .SYN1 1>>)>)>>

<DEFINE RED-SVNP ("OPT" N:FIX TYP:FIX "AUX" PART OBJ)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP-NP-P">) (T <RFALSE>)>)>
	<SET PART <POP-PSTACK ,DATA-STACK>>
	<SET OBJ <POP-PSTACK ,DATA-STACK>>
	;"PICK OBJECT UP = PICK UP OBJECT"
	<PUSH-PSTACK ,DATA-STACK .PART>
	<PUSH-PSTACK ,DATA-STACK .OBJ>
	<COND (<NOT <RED-SVN .N .TYP>>
	       <PUSH-PSTACK ,DATA-STACK <PARSE-VERB ,PARSE-RESULT>>
	       <PUSH-PSTACK ,DATA-STACK T>
	       <PARSE-PARTICLE2 ,PARSE-RESULT .PART>
	       <PUSH-PSTACK ,DATA-STACK .OBJ>
	       <RED-SVN .N .TYP>)
	      (T T)>>

<DEFINE RED-SVNPN ("OPT" N:FIX TYP:FIX "AUX" OBJ2 ;PART OBJ1)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP-NP-P-NP">)
		       (T <RFALSE>)>)>
	<SET OBJ2 <POP-PSTACK ,DATA-STACK>>
	<PARSE-PARTICLE2 ,PARSE-RESULT <POP-PSTACK ,DATA-STACK>>
	<SET OBJ1 <POP-PSTACK ,DATA-STACK>>
	;<COND (<AND <EQUAL? <PARSE-VERB ,PARSE-RESULT> ,W?SAY>
		    <EQUAL? <PARSE-PARTICLE2 ,PARSE-RESULT> ,W?TO>
		    <PMEM? .OBJ1>
		    <PMEM-TYPE? .OBJ1 NOUN-PHRASE>
		    <EQUAL? <NOUN-PHRASE-OBJ1 .OBJ1> ,INTQUOTE>>
	       ;"etc."
	       )>
	;<PUSH-PSTACK ,DATA-STACK .PART>
	<PUSH-PSTACK ,DATA-STACK .OBJ1>
	<PUSH-PSTACK ,DATA-STACK .OBJ2>
	<DEC N>
	<RED-SVPNN .N .TYP>>

<DEFINE RED-SVPNN ("OPT" N:FIX TYP:FIX "AUX" N1 N2 (PART <>) OBJ1 OBJ2 SYN)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP-?P-NP-NP">)
		       (T <RFALSE>)>)>
	<SET N2 <POP-PSTACK ,DATA-STACK>>
	<COND (<0? <PARSE-PARTICLE2 ;8 ,PARSE-RESULT>>
	       <PARSE-PARTICLE2 ;8 ,PARSE-RESULT <OR <ZGET ,GWIM-MSG 0> 1>>)>
	<SET N1 <POP-PSTACK ,DATA-STACK>>
	<COND (<==? .N 4>
	       <SET PART <POP-PSTACK ,DATA-STACK>>)>
	<COND (<NOT <SET SYN <ROOT-VERB <PARSE-VERB ,PARSE-RESULT>>>>
	       <PARSER-ERROR 0 ;"No syntax" ,PARSER-ERROR-NOUND>)
	      (<NOT <SET SYN <VERB-TWO <WORD-VERB-STUFF .SYN>>>>
	       <PARSER-ERROR 0 ,PARSER-ERROR-TMNOUN>)
	      (<NOT <SET SYN <GET-SYNTAX .SYN 2 .PART>>>
	       <PARSER-ERROR 0 ;"No syntax" ,PARSER-ERROR-NOUND>)
	      (<NOT <SET OBJ1 <DETERMINE-OBJ .N1 1>>>
	       <PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .N1
			     .PART ;<SYNTAX-SEARCH ;B5 .SYN 1>>)
	      (<NOT <SET OBJ2 <DETERMINE-OBJ .N2 2>>>
	       <PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .N2
			     .PART ;<SYNTAX-SEARCH ;B9 .SYN 2>>)
	      (<ZAPPLY ,DIR-VERB-PRSI? .OBJ2>
	       <PARSER-ERROR 0 ;"Not a direction" ,PARSER-ERROR-NOUND>)
	      (T
	       <POP-PSTACK ,DATA-STACK>
	       <PARSE-OBJ1 ,PARSE-RESULT .OBJ1>
	       <PARSE-OBJ2 ,PARSE-RESULT .OBJ2>
	       T)>>

<DEFINE RED-SVPNPN ("OPT" N:FIX TYP:FIX "AUX" N2)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP-P-NP-P-NP">)
		       (T <RFALSE>)>)>
	<SET N2 <POP-PSTACK ,DATA-STACK>>
	<PARSE-PARTICLE2 ,PARSE-RESULT <POP-PSTACK ,DATA-STACK>>
	<PUSH-PSTACK ,DATA-STACK .N2>
	<RED-SVPNN <- .N 1> .TYP>>

<DEFINE RED-SD ("OPT" N:FIX TYP:FIX "AUX" V)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "DIR=S">) (T <RFALSE>)>)>
	<PARSE-VERB ,PARSE-RESULT <SET V ,W?WALK>>
	<GET-SYNTAX <VERB-ONE <WORD-VERB-STUFF .V>> 1 <>>
	<SETG P-WALK-DIR <WORD-DIR-ID <POP-PSTACK ,DATA-STACK>>>
	;<SETG PRSO ,P-WALK-DIR>
	<PARSE-OBJ1 ,PARSE-RESULT <PMEM-ALLOC NOUN-PHRASE
				    COUNT 1
				    LENGTH ,NOUN-PHRASE-MIN-LENGTH
				    OBJ1 ,P-WALK-DIR>>
	T ;,PARSE-RESULT>

<DEFINE RED-SVD ("OPT" N:FIX TYP:FIX "AUX" DIR)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP-DIR">) (T <RFALSE>)>)>
	<SET DIR <POP-PSTACK ,DATA-STACK>>
	<COND (<ZAPPLY ,DIR-VERB-WORD? <PARSE-VERB ,PARSE-RESULT>>
	       <POP-PSTACK ,DATA-STACK>
	       <PUSH-PSTACK ,DATA-STACK .DIR>
	       <RED-SD <- .N 1> .TYP>)>>

<DEFINE RED-SP ("OPT" N:FIX TYP:FIX "AUX" A)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "SP">) (T <RFALSE>)>)>
	<SET A <POP-PSTACK ,DATA-STACK>>
	<DEC N>
	<COND (<AND <EQUAL? .N 2 ;3>
		    <N==? T .A>>
	       <PARSE-ADV ,PARSE-RESULT <OR <WORD-SEMANTIC-STUFF .A> .A>>)>
	<FLUSH-PSTACK ,DATA-STACK .N>
	,PARSE-RESULT>

<GLOBAL SEARCH-FLAGS:NUMBER 0>

<DEFINE IREDUCE-EXCEPTION (ENP:PMEM NP:PMEM)
  ;"Both ENP and NP are NPs"
  <COND (<==? <NP-NAME .ENP> ,W?ONE>
	 ;"All books except the red one..."
	 <NP-NAME .ENP <NP-NAME .NP>>)>
  <COND (<NOT <NP-QUANT .ENP>>
	 <NP-QUANT .ENP ,NP-QUANT-ALL>)>
  <SETG SEARCH-FLAGS <BOR ,SEARCH-ALL ;15 ,SEARCH-MANY ;16>>
  <DETERMINE-NP 0 0 .ENP>>

<DEFINE REDUCE-EXCEPT-IT (PHR NP)
	<COND (<AND <==? 1 <NOUN-PHRASE-COUNT .PHR>>
		    <==? ,IT <NOUN-PHRASE-OBJ1 .PHR>>>
	       <COND (<ZERO? ,P-IT-OBJECT>
		      <PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .NP>)
		     ;(<NOT <VISIBLE? ,P-IT-OBJECT>>
		      <NOT-HERE ,P-IT-OBJECT>)
		     (T
		      <NOUN-PHRASE-OBJ1 .PHR ,P-IT-OBJECT>)>)>>

<DEFINE REDUCE-EXCEPTION RE (PP:PMEM NP:PMEM "AUX"
			  (ENP:PMEM <PP-NOUN .PP>) NOUN-PHRASE)
  <COND
   (<PMEM-TYPE? .ENP NP>
    ;"Just one thing"
    <COND (<SET NOUN-PHRASE <IREDUCE-EXCEPTION .ENP .NP>>
	   ;"Returns a noun-phrase, which we can then stuff into
	      an NPP to be stuffed into the EXCEPT slot"
	   <REDUCE-EXCEPT-IT .NOUN-PHRASE .ENP>
	   <NP-EXCEPT .NP <PMEM-ALLOC NPP
				      NOUN .ENP
				      NOUN-PHRASE .NOUN-PHRASE>>
	   .NP)>)
   (T
    ;"NPP"
    <REPEAT (RES (NNP:<OR PMEM FALSE> .ENP) (GOOD <>) BAD)
      <COND (<SET RES <IREDUCE-EXCEPTION <SET BAD <NPP-NOUN .NNP>> .NP>>
	     <SET GOOD T>
	     <REDUCE-EXCEPT-IT .RES .BAD>
	     <NPP-NOUN-PHRASE .NNP .RES>)>
      <COND (<NOT <SET NNP <NPP-NEXT .NNP>>>
	     <COND (<T? .GOOD>
		    <NP-EXCEPT .NP .ENP>
		    <RETURN .NP .RE>)
		   (T
		<RETURN <PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .BAD> .RE>)>)>>)>>

<CONSTANT P-NO-INSIDE "No inside">
<CONSTANT P-NO-SURFACE "No surface">
<CONSTANT P-NOTHING "Nothing">

<CONSTANT PREP-BIT <ITABLE 3 0>>

<DEFINE REDUCE-LOCATION RL
	 (PP:PMEM
	  "OPT" (SYN:<OR FALSE VERB-SYNTAX> <>)
		(WHICH:<OR FIX FALSE> <>)
	  "AUX" (SEARCH <COND (.SYN
			       <COND (<==? .WHICH 1>
				      <SYNTAX-SEARCH .SYN 1>)
				     (T
				      <SYNTAX-SEARCH .SYN 2>)>)>)
		(TEST <COND (.SYN
			     <COND (<==? .WHICH 1>
				    <SYNTAX-FIND .SYN 1>)
				   (T
				    <SYNTAX-FIND .SYN 2>)>)>)
		(PREP:VWORD <PP-PREP .PP>)
		(NP:PMEM <PP-NOUN .PP>) (RLOC <>)
		(BIT 0) (MSG <>) "VALUE" <OR PMEM FALSE>)
  <COND (<NOT .SEARCH> <SET SEARCH <BOR ,SEARCH-HELD ,SEARCH-ON-GROUND> ;5>)>
  ;<COND (<NOT .TEST> <SET TEST ,TEST-PREP>)>
  <COPYT ,PREP-BIT 0 6>
  <COND
   (<EQUAL? .PREP ,W?BUT ,W?EXCEPT>
    <RETURN <> .RL>)
   ;(<EQUAL? .PREP ,W?UNDER>
	   <SET BIT ,F?HAS-UNDER>
	   <SET MSG ,P-NO-UNDERSIDE>)
   ;(<EQUAL? .PREP ,W?ABOUT ,W?FOR ,W?TO>)
   (<EQUAL? .PREP ,W?IN ,W?INSIDE>
    <SET BIT ,CONTBIT>
    <SET MSG ,P-NO-INSIDE>)
   (<EQUAL? .PREP ,W?ON ,W?OFF>
    <SET BIT ,SURFACEBIT>
    <SET MSG ,P-NO-SURFACE>)
   ;(<EQUAL? .PREP ,W?BEHIND>
     <SET BIT ,F?HAS-BEHIND>
     <SET MSG ,P-NO-BACKSIDE>)
   (<EQUAL? .PREP ,W?FROM ;,W?OF>
    <SET BIT ,SURFACEBIT>
    <ZPUT ,PREP-BIT 1 ,PERSONBIT>
    <ZPUT ,PREP-BIT 2 ,CONTBIT>
    <SET MSG ,P-NOTHING>)
   (T
    <RETURN <> .RL>)>
  <ZPUT ,PREP-BIT 0 .BIT>
  <COND (<PMEM-TYPE? .NP NP>
	 <COND (<SET RLOC <NP-LOC .NP>:PMEM>
		<SET RLOC <NOUN-PHRASE-OBJ1 <LOCATION-OBJECT .RLOC>:PMEM>>)>
	 <MAKE-FINDER 'FINDER ,FINDER
			'FIND-APPLIC .TEST
			'FIND-RES ,SEARCH-RES
			'FIND-ADJS <NP-ADJS .NP>
			'FIND-NOUN <NP-NAME .NP>
			'FIND-NUM <NUMERIC-ADJ? .NP>>
	 <SET SEARCH <FIND-OBJECTS <COND (<NOT .RLOC> .SEARCH) (T 0)>
				   .RLOC>>
	 ;<FIND-NUM ,FINDER 0>
	 <COND (.SEARCH
		<SET RLOC <PMEM-ALLOC NOUN-PHRASE
					COUNT 1
					LENGTH ,NOUN-PHRASE-MIN-LENGTH
					OBJ1 <FIND-RES-OBJ1 ,SEARCH-RES>
					NP1 .NP>>
		<PMEM-ALLOC LOCATION PREP .PREP OBJECT .RLOC>)
	       (<0? <FIND-RES-COUNT ,SEARCH-RES>:FIX>
		<PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .NP .PREP ;.SEARCH>)
	       (<READY-TO-DISAMBIGUATE? .NP>
		<PARSER-ERROR 0 ,PARSER-ERROR-ORPH-NP
			      .NP <PARSE-VERB ,PARSE-RESULT>>)
	       ;(T
		<PARSER-ERROR ,P-TOO-MANY-OBJECTS-FOR-LOCATION 0 .NP>)>)>>

;<DEFINE DO-TEST-PREP DTP (OBJ:OBJECT VERB:VWORD "AUX" (BIT:TABLE ,PREP-BIT))
  <COND (<0? <ZGET .BIT 0>:FIX> T)
	(T
	 <REPEAT ((CT 0))
	   <COND (<FSET? .OBJ <ZGET .BIT .CT>:FIX> <RETURN T .DTP>)>
	   <COND (<OR <G? <SET CT <+ .CT 1>> 2>
		      <0? <ZGET .BIT .CT>:FIX>>
		  <RETURN <> .DTP>)>>)>>

<COND (<GASSIGNED? DO-TEST-PREP> <SETG TEST-PREP <TABLE ,DO-TEST-PREP>>)>

"Decide what object(s) OBJ refers to.  If OBJ is false, we're looking to
GWIM something.  Otherwise, it's one of NP, NPP, or NOUN-PHRASE.  In the
last case, just return it, because it's already been reduced."

<DEFINE DETERMINE-OBJ DO (OBJ:<OR FALSE PMEM> NUM:FIX "OPT" (PICK <>)
			  "AUX" (VAL <>) RES (COUNT:FIX 0)
			  (SYN:VERB-SYNTAX <PARSE-SYNTAX ;3 ,PARSE-RESULT>)
			  (S-FLAGS:FIX
			   <COND (<==? .NUM 1>	<SYNTAX-SEARCH ;B5 .SYN 1>)
				 (T		<SYNTAX-SEARCH ;B9 .SYN 2>)>)
			  (SEARCH-ACT:FIX
			   <COND (<==? .NUM 1>	<SYNTAX-FIND ;B4 .SYN 1>)
				 (T		<SYNTAX-FIND ;B8 .SYN 2>)>))
	<COND (<NOT .OBJ>	;"Get What I Mean!"
	       <MAKE-FINDER 'FINDER ,FINDER
			    'FIND-APPLIC .SEARCH-ACT
			    'FIND-FLAGS ,FIND-FLAGS-GWIM
			    'FIND-SYNTAX .SYN
			    'FIND-WHICH .NUM
			    'FIND-RES ,SEARCH-RES>
	       <COND (<T? .PICK>
		      <FIND-QUANT ,FINDER ,NP-QUANT-ALL>
		      ;<SET S-FLAGS <BOR .S-FLAGS ,SEARCH-ALL>>)>
	       <COND (<OR <AND <EQUAL? .SEARCH-ACT ,ROOMSBIT>
			       <FIND-RES-OBJ1 ,SEARCH-RES ,ROOMS>>
			  <AND <T? .S-FLAGS>
			       <OR <FIND-OBJECTS .S-FLAGS>
				   <AND .PICK <FIND-RES-COUNT ,SEARCH-RES>>>
			       <ZPUT ,GWIM-MSG 0 <COND (<1? .NUM>
							<SYNTAX-PREP .SYN 1>)
						       (T
							<SYNTAX-PREP .SYN 2>)>>
			       <ZPUT ,GWIM-MSG 1 <FIND-RES-OBJ1 ,SEARCH-RES>>>>
		      ;"Found one thing, so be happy"
		      ;<FIND-NUM ,FINDER 0>
		      <SET RES <PMEM-ALLOC NOUN-PHRASE
					   LENGTH ,NOUN-PHRASE-MIN-LENGTH
					   COUNT 1
					   ;FLAGS ;,NP-FLAG-MULTI
					   OBJ1 <FIND-RES-OBJ1 ,SEARCH-RES>
					   NP1 <>>>)
		     (T
		      ;"This will return an appropriate lossage so the
			 parser will know to continue."
		      <ZPUT ,ORPHAN-S ,O-VERB <PARSE-VERB ,PARSE-RESULT>>
		      <ZPUT ,ORPHAN-S ,O-LEXPTR
			    <COND (<0? ,P-LEN>
				   <ZREST ,TLEXV ;,P-RUNNING <* 2 ,P-LEXELEN>>)
				  (T ,TLEXV ;,P-RUNNING)>>
		      <ZPUT ,ORPHAN-S ,O-SYNTAX <PARSE-SYNTAX ,PARSE-RESULT>>
		      <ZPUT ,ORPHAN-S ,O-WHICH .NUM>
		      <ZPUT ,ORPHAN-S ,O-PART <PARSE-PARTICLE1 ,PARSE-RESULT>>
		      <ZPUT ,ORPHAN-S ,O-OBJECT
			    <NOUN-PHRASE-OBJ1 <PARSE-OBJ1 ,PARSE-RESULT>>>
		      <COND (<SET VAL <PARSE-CHOMPER ,PARSE-RESULT>>
			     <SET VAL <NOUN-PHRASE-OBJ1 .VAL>>)>
		      <ZPUT ,ORPHAN-S ,O-SUBJECT .VAL>
		      <RETURN <PARSER-ERROR 0 ,PARSER-ERROR-ORPH-S
					    <PARSE-OBJ1 ,PARSE-RESULT>>
			      .DO>)>)
	      (<PMEM-TYPE? .OBJ NOUN-PHRASE>
	       ;"Already a winner, so just return it"
	       <RETURN .OBJ .DO>)
	      (<PMEM-TYPE? .OBJ NP>
	       <SETG SEARCH-FLAGS .S-FLAGS>
	       <DETERMINE-NP 0 ;.SEARCH-ACT .NUM .OBJ>)
	      (<0? <ANDB .S-FLAGS ,SEARCH-MANY ;16>>
	       <PARSER-ERROR 0 ,PARSER-ERROR-NOMULT
			       .NUM <PARSE-VERB ,PARSE-RESULT>>)
	      (T
	     ;"Do each noun phrase in turn, since we can take multiple objects"
	       <SETG SEARCH-FLAGS .S-FLAGS>
	       <REPEAT ((NO .OBJ) (CT <>) PTR)
	         <COND (<SET PTR <DETERMINE-NP 0 ;.SEARCH-ACT .NUM .NO T>>
			;"Remember how many objects we have"
			<SET COUNT <+ .COUNT
				      <NOUN-PHRASE-COUNT
				       <NPP-NOUN-PHRASE .NO:PMEM>:PMEM>>>
			;"And how many real objects we have"
			<COND (<ZERO? .CT>
			       <SET PTR <REST-TO-SLOT .PTR NOUN-PHRASE-OBJ1>>
			       <REPEAT ((CNT .COUNT))
				<COND (<DLESS? CNT 0>
				       <RETURN>)
				      (<NOT <EQUAL? ,NOT-HERE-OBJECT
						    <ZGET .PTR 0>>>
				       <SET CT T>
				       <RETURN>)
				      (T <SET PTR <ZREST .PTR 4>>)>>)>
			<COND (<NOT <SET NO <NPP-NEXT .NO:PMEM>>>
			       <COND (<ZERO? .CT>
				      <RETURN <> .DO>)>
			       <RETURN>)>)
		       (T
			<RETURN <> .DO>)>>
	       ;"Build a single noun phrase"
	       <SET RES <PMEM-ALLOC NOUN-PHRASE
				    ;FLAGS ;,NP-FLAG-MULTI
				    LENGTH <+ ,NOUN-PHRASE-MIN-LENGTH
					      <* .COUNT 2> -2>
				    COUNT .COUNT>>
	       ;"Copy everything into the single noun phrase"
	       <REPEAT ((NO .OBJ) (RR <REST-TO-SLOT .RES NOUN-PHRASE-OBJ1>)
			PHRASE TMP)
	         <SET PHRASE <NPP-NOUN-PHRASE .NO:PMEM>>
		 <SET TMP <* 4 <NOUN-PHRASE-COUNT .PHRASE>:FIX>>
		 <COPYT <REST-TO-SLOT .PHRASE NOUN-PHRASE-OBJ1> .RR .TMP>
		 <SET RR <ZREST .RR .TMP>>
		 <COND (<NOT <SET NO <NPP-NEXT .NO:PMEM>>>
			<RETURN>)>>
	       .RES)>>

<DEFINE CHECK-DIR-ADJS (ADJS:PMEM)
  <REPEAT ((AV <REST-TO-SLOT .ADJS ADJS-COUNT 1>)
	   (CT <ADJS-COUNT .ADJS>) ADJ PT)
    <COND (<L? <SET CT <- .CT 1>> 0>
	   <RETURN>)
	  (<AND <WORD-TYPE? <SET ADJ <ZGET .AV .CT>> ,P-DIR-CODE>
		<SET PT <GETPT ,HERE <WORD-DIR-ID .ADJ>>>
		<EQUAL? <PTSIZE .PT> ,DEXIT>>
	   <ZPUT .AV .CT ,W?NO.WORD>
	   <COND (<NOT <MATCH-OBJECT <GET .PT ,DEXITOBJ> ,FINDER T>>
		  <ZPUT .AV .CT .ADJ>
		  <RETURN>)>
	   <ZPUT .AV .CT .ADJ>)>>>

<DEFINE NUMERIC-ADJ? (NP:PMEM "AUX" ADJS (VAL 0))
 <COND (<SET ADJS <NP-ADJS .NP>>
	<REPEAT ((AV <REST-TO-SLOT .ADJS ADJS-COUNT 1>) (CT <ADJS-COUNT .ADJS>)
		 ADJ)
	  <COND (<L? <SET CT <- .CT 1>> 0>
		 <RETURN>)
		(<EQUAL? <SET ADJ <ZGET .AV .CT>> ,W?INT.NUM>
		 <REPEAT ((VV <NP-LEXEND .NP> ;,TLEXV))
			 <COND (<EQUAL? .ADJ <ZGET .VV 0>>
				<SET VAL <ZGET .VV 1>>
				<RETURN>)
			       (<G? ,P-LEXV <SET VV <ZBACK .VV ,P-LEXELEN>>>
				<RETURN>)>>)>>
	.VAL)>>

;<CONSTANT FIND-OWNER:TABLE <TABLE (LENGTH) 0 0>>
<VOC "HIMSELF" NOUN>
;<VOC "ITSELF" NOUN>
<IFN-P-PS-ADV <VOC "HERSELF" NOUN>>

<DEFINE DETERMINE-NP DN (SEARCH-ACT:<OR FIX TABLE> WHICH:FIX OBJ:PMEM
			 "OPT" (MULTI <>)
			 "AUX" (SYN:<OR VERB-SYNTAX FALSE>
				<COND (<0? .WHICH> <>)
				      (T <PARSE-SYNTAX ,PARSE-RESULT>)>)
			       (ROBJ:PMEM .OBJ) (RLOC:<OR FALSE PMEM> <>) ;RNP
			       QUANT:<OR FIX FALSE> OWNER
			       (RES <>) COUNT:FIX)
  <COND (<PMEM-TYPE? .OBJ NPP>
	 <SET ROBJ <NPP-NOUN .OBJ>>)>
  <COND (<SET RLOC <NP-LOC .ROBJ>>
	 <SET RLOC <LOCATION-OBJECT .RLOC>:PMEM>
	 ;<SET RNP <NOUN-PHRASE-NP1 .RLOC>>
	 <SET RLOC <NOUN-PHRASE-OBJ1 .RLOC>>)>
  <SET QUANT <NP-QUANT .ROBJ>>
  <COND (<AND .QUANT
	      <G? .QUANT ,NP-QUANT-A>
	      <0? <ANDB ,SEARCH-FLAGS ,SEARCH-MANY ;16>>>
	 <RETURN <PARSER-ERROR 0 ,PARSER-ERROR-NOMULT
			       .WHICH <PARSE-VERB ,PARSE-RESULT>>
		 .DN>)>
  <COND (<AND <OR <SET OWNER <NP-OF .ROBJ>>
		  <AND <SET OWNER <NP-ADJS .ROBJ>>
		       <SET OWNER <ADJS-POSS .OWNER>>>
		  ;<SET OWNER .RNP>
		  ;<AND <SET OWNER <NP-LOC .ROBJ>>
		       <SET OWNER <LOCATION-OBJECT .OWNER>>
		       <SET OWNER <NOUN-PHRASE-NP1 .OWNER>>>>
	      <PMEM? .OWNER>>
	 ;<COND (<PMEM-TYPE? .OWNER NOUN-PHRASE>
		<SET OWNER <NOUN-PHRASE-NP1 .OWNER>>)>
	 ;<FIND-RES-COUNT ,OWNER-SR-HERE 0>
	 ;<FIND-RES-COUNT ,OWNER-SR-THERE 0>
	 <MAKE-FINDER	'FINDER ,FINDER
			'FIND-APPLIC .SEARCH-ACT
			;'FIND-QUANT ;<NP-QUANT .OWNER>
			'FIND-SYNTAX .SYN
			'FIND-WHICH .WHICH
			'FIND-RES ,SEARCH-RES
			'FIND-ADJS <NP-ADJS .OWNER>
			'FIND-NUM <NUMERIC-ADJ? .OWNER>
			'FIND-NOUN <NP-NAME .OWNER>
			'FIND-OF <NP-OF .OWNER> ;<OR <NP-OF .ROBJ> .RNP>
			;'FIND-EXCEPTIONS ;<NP-EXCEPT .OWNER>>
	 <FIND-RES-COUNT ,SEARCH-RES 0>
	 <FIND-RES-NEXT ,SEARCH-RES <>>
	 <FIND-OBJECTS ,SEARCH-ALL>	;"Find owner in HERE"
	 <COPYT ,SEARCH-RES ,OWNER-SR-HERE <* 2 ,FIND-RES-LENGTH>>
	 <FIND-RES-COUNT ,SEARCH-RES 0>
	 <FIND-RES-NEXT ,SEARCH-RES <>>
	 <FIND-OWNERS ,OWNERS>	;"Search for other owners."
	 <COPYT ,SEARCH-RES ,OWNER-SR-THERE <* 2 ,FIND-RES-LENGTH>>)>
  <COND (<EQUAL? <NP-NAME .ROBJ> ,W?HIMSELF>	;"ASK TROLL ABOUT HIMSELF"
	 <COND (<AND <EQUAL? 2 .WHICH>
		     <SET COUNT <PARSE-OBJ1 ,PARSE-RESULT>>
		     <SET COUNT <NOUN-PHRASE-OBJ1 .COUNT>>
		     <FSET? .COUNT ,PERSONBIT>>
		<SET RES .COUNT>
		<IFN-P-PS-ADV
			<COND (<FSET? .COUNT ,FEMALE ;,FEMALEBIT>
			       <SET RES ,P-HIM-OBJECT>)>>)
	       (T
		<SET RES ,P-HIM-OBJECT>)>)>
  <IFN-P-PS-ADV
  <COND (<EQUAL? <NP-NAME .ROBJ> ,W?HERSELF ;%<VOC "HERSELF" NOUN>>
	 <COND (<AND <EQUAL? 2 .WHICH>
		     <SET COUNT <PARSE-OBJ1 ,PARSE-RESULT>>
		     <SET COUNT <NOUN-PHRASE-OBJ1 .COUNT>>
		     <FSET? .COUNT ,PERSONBIT>
		     <FSET? .COUNT ,FEMALE ;,FEMALEBIT>>
		<SET RES .COUNT>)
	       (T
		<SET RES ,P-HER-OBJECT>)>)>>
  
  <COND (<T? .RES>
	 <RETURN <PMEM-ALLOC NOUN-PHRASE
			LENGTH ,NOUN-PHRASE-MIN-LENGTH
			COUNT 1
			OBJ1 .RES
			NP1 .ROBJ>
		 .DN>)>
  <MAKE-FINDER	'FINDER ,FINDER
		'FIND-APPLIC .SEARCH-ACT
		'FIND-QUANT .QUANT
		'FIND-SYNTAX .SYN
		'FIND-WHICH .WHICH
		'FIND-RES ,SEARCH-RES
		'FIND-ADJS <NP-ADJS .ROBJ>
		'FIND-NUM <NUMERIC-ADJ? .ROBJ>
		'FIND-NOUN <NP-NAME .ROBJ>
		'FIND-OF <OR <NP-OF .ROBJ> ;.RNP>
		'FIND-EXCEPTIONS <NP-EXCEPT .ROBJ>>
  <FIND-OBJECTS ,SEARCH-FLAGS .RLOC>
  <COND (<AND <ZERO? <FIND-RES-COUNT ,SEARCH-RES>>
	      <T? <NP-ADJS .ROBJ>>>
	 <CHECK-DIR-ADJS <NP-ADJS .ROBJ>>)>
  <COND (<AND <ZERO? <SET COUNT <FIND-RES-COUNT ,SEARCH-RES>>>
	      <SET RLOC <NP-NAME .ROBJ>>
	      <T? <ANDB ,PLURAL-FLAG <WORD-FLAGS .RLOC>>>>
	 <NP-QUANT .ROBJ ,NP-QUANT-ALL ;,NP-QUANT-PLURAL>
	 <NP-NAME .ROBJ <WORD-SEMANTIC-STUFF .RLOC>>
	 <AGAIN>)
	(<ZERO? .COUNT>
	 <COND (<OR <T? .MULTI>
		    <ZAPPLY ,NOT-HERE-VERB?
			    <PARSE-ACTION ,PARSE-RESULT>>>
		<SET RES <PMEM-ALLOC NOUN-PHRASE
				     LENGTH ,NOUN-PHRASE-MIN-LENGTH
				     COUNT 1
				     OBJ1 ,NOT-HERE-OBJECT
				     NP1 .ROBJ>>)>)
	(<OR <1? .COUNT>
	     <T? .QUANT>
	     <SET RES <ZAPPLY <GETP <FIND-RES-OBJ1 ,SEARCH-RES>
				    ,P?GENERIC>
			      ,SEARCH-RES ,FINDER>>
	     ;"Protocol: returns .OBJ if that's the one to use,
				 ,NOT-HERE-OBJECT if 'are none',
				 [,ROOMS if case was handled and msg TELLed,]
				 <> if WHICH-PRINT should be called"
	     ;<AND <SET RES ,P-IT-OBJECT>
		  <NOT <NOT-IN-FIND-RES? .RES ,SEARCH-RES T>>>>
	 <COND (<EQUAL? .RES ,NOT-HERE-OBJECT ;,ROOMS>
		;<THROW ,PARSER-RESULT-DEAD ,PARSE-SENTENCE-ACTIVATION>
		<RETURN <PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .OBJ> .DN>)
	       (<T? .RES>
		<SET COUNT 1>
		<FIND-RES-COUNT ,SEARCH-RES 1>
		<FIND-RES-NEXT ,SEARCH-RES <>>
		<FIND-RES-OBJ1 ,SEARCH-RES
			       <COND (<EQUAL? .RES ,HERE> ,GLOBAL-HERE)
				     (T .RES)>>)>
	 <SET RES <PMEM-ALLOC NOUN-PHRASE
			      ;FLAGS ;<COND (.QUANT ,NP-FLAG-MULTI)
					    (T 0)>
			      LENGTH <+ <* .COUNT 2>
					,NOUN-PHRASE-MIN-LENGTH
					-2>
			      COUNT .COUNT>>
	 <COND (<OR <SET SYN <NP-OF .ROBJ>>	;"Store owner found."
		    <AND <SET SYN <NP-ADJS .ROBJ>>
			 <SET SYN <ADJS-POSS .SYN>>>
		    ;<SET SYN .RNP>>
		<COND (<NOT <OBJECT? .SYN>>
		       <SET SYN <FIND-RES-OWNER ,SEARCH-RES>>
		       <COND (<NP-OF .ROBJ>
			      <NP-OF .ROBJ .SYN>)
			     (T ;<NP-ADJS .ROBJ>
			      <ADJS-POSS <NP-ADJS .ROBJ> .SYN>)
			     ;(T
			      <NOUN-PHRASE-NP1 <LOCATION-OBJECT <NP-LOC .ROBJ>>
					       .SYN>)>)>)>
	 <COND (<SET SYN <DETERMINE-NP-XFER .COUNT .ROBJ ,SEARCH-RES
					 <REST-TO-SLOT .RES NOUN-PHRASE-OBJ1>>>
		<NOUN-PHRASE-COUNT .RES <- .COUNT .SYN>>)>)
	(<READY-TO-DISAMBIGUATE? .ROBJ>
	 <RETURN <PARSER-ERROR 0 ,PARSER-ERROR-ORPH-NP
			       .ROBJ <PARSE-VERB ,PARSE-RESULT>>
		 .DN>)>
  <COND (<AND .RES <PMEM-TYPE? .OBJ NPP>>
	 <NPP-NOUN-PHRASE .OBJ .RES>)>
  ;<FIND-NUM ,FINDER 0>
  .RES>

<DEFINE FIND-OWNERS (TBL)
 <REPEAT (OOBJ (LEN <ZGET .TBL 0>))
	<COND (<L? .LEN 1>
	       <RETURN>)
	      (<OBJECT? <SET OOBJ <ZGET .TBL .LEN>>>
	       <COND (<NOT <MATCH-OBJECT .OOBJ ,FINDER T>>
		      <RETURN>)>)
	      (T	;"It's another table!"
	       <FIND-OWNERS .OOBJ>)>
	<SET LEN <- .LEN 1>>>>

<DEFINE READY-TO-DISAMBIGUATE? RTD (NP "AUX" PTR NOUN)
 <COND (<AND <SET PTR <NP-LEXEND .NP>>
	     <SET NOUN <NP-NAME .NP>>>
	<REPEAT ()
		<COND (<==? .NOUN <ZGET .PTR 0>>
		       <RETURN .PTR .RTD>)
		      (<G? ,P-LEXV <SET PTR <- .PTR ,LEXV-ELEMENT-SIZE-BYTES>>>
		       <RETURN <> .RTD>)>>)>>

<DEFINE DETERMINE-NP-XFER ACT (COUNT ROBJ SRES DV "AUX" CT V)
  <SET CT <FIND-RES-SIZE .SRES>>
  <SET V <REST-TO-SLOT .SRES FIND-RES-OBJ1>>
  <REPEAT ()
	<COND (<G? .CT .COUNT>
	       <SET CT .COUNT>)>
	<SET COUNT <- .COUNT .CT>>
	<REPEAT (TMP (NUM 0))
		<COND (<SET TMP <ZGET .V 0>>
		       <ZPUT .DV 0 .TMP>
		       <ZPUT .DV 1 .ROBJ>)
		      (T
		       <INC NUM>)>
		<SET DV <ZREST .DV 4>>
		<SET V <ZREST .V 2>>
		<COND (<L? <SET CT <- .CT 1>> 1>
		       <COND (<ZERO? <SET SRES <FIND-RES-NEXT .SRES>>>
			      <RETURN .NUM .ACT>)>
		       <SET CT ,FIND-RES-MAXOBJ ;<OBJLIST-SIZE .SRES>>
		       <SET V <REST-TO-SLOT .SRES OBJLIST-OBJ1>>
		       <COND (<G? .CT .COUNT>
			      <SET CT .COUNT>)>
		       <SET COUNT <- .COUNT .CT>>)>>>>

<DEFINE RED-O-ADJ ("OPT" N:FIX TYP:FIX)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "O-ADJ">)
		       (T <RFALSE>)>)>
	<COND (<T? ,P-OFLAG>
	       <COPYT ,O-LEXV ,G-LEXV ,LEXV-LENGTH-BYTES>
	       <COPYT ,O-INBUF ,G-INBUF <+ 1 ,INBUF-LENGTH>>
	       <ZPUT ,OOPS-TABLE ,O-START <ZGET ,OOPS-TABLE ,O-AGAIN>>
	       ;<COND (<ZERO? <ZGET ,G-LEXV ,P-OFLAG>>	;"PARSER-ERROR-ORPH-S"
		      <ZPUT ,G-LEXV ,P-OFLAG ,W?NO.WORD>)>
	       <INSERT-ADJS <POP-PSTACK ,DATA-STACK>>
	       ;<SETG P-OFLAG <>>
	       <COPY-INPUT T>
	       <THROW ,PARSER-RESULT-AGAIN ,PARSE-SENTENCE-ACTIVATION>)>>

<DEFINE RED-O-PP ("OPT" N:FIX TYP:FIX "AUX" PP A PREP)
 ;<COND (<NOT <ASSIGNED? N>>
	<IFFLAG (P-DEBUGGING-PARSER <PRINTR "O-PP">) (T <RFALSE>)>)>
 <COND (<AND <T? <SET PP <ABS ,P-OFLAG>>>
	     <EQUAL? ,W?NO.WORD ;0 <ZGET ,O-LEXV .PP>>
	     <SET A <ZGET ,O-LEXV <- .PP ,P-LEXELEN>>>
	     <SET PP <POP-PSTACK ,DATA-STACK>>
	     <OR <AND <==? .N 1> ;<PMEM-TYPE? .PP PP>
		      ;<EQUAL? .A <PP-PREP .PP>>>
		 <AND ;<PMEM-TYPE? .PP NP>
		      <SET PREP <POP-PSTACK ,DATA-STACK>> ;<EQUAL? .A >>>>
	;<ZPUT ,O-LEXV .PP ,W?NO.WORD>
	<COPYT ,O-LEXV ,G-LEXV ,LEXV-LENGTH-BYTES>
	<COPYT ,O-INBUF ,G-INBUF <+ 1 ,INBUF-LENGTH>>
	<ZPUT ,OOPS-TABLE ,O-START <ZGET ,OOPS-TABLE ,O-AGAIN>>
	<INSERT-NP ;.PP <COND (<EQUAL? .A .PREP> 1) (T 0)>>
	;<SETG P-OFLAG <>>
	<COPY-INPUT T>
	<THROW ,PARSER-RESULT-AGAIN ,PARSE-SENTENCE-ACTIVATION>)>>

<DEFINE INSERT-NP ("OPT" (NUM 0) (NP <>) "AUX" (GPTR <ABS ,P-OFLAG>) PPTR TMP)
	<COND (<SET TMP <PARSE-VERB-LEXV ,PARSE-RESULT>>
	       <SET PPTR <ZREST .TMP <* .NUM <* 2 ,P-LEXELEN>>>>
	       <SET TMP <+ 1 </ <- ,TLEXV .TMP> ,LEXV-ELEMENT-SIZE-BYTES>>>)
	      (T
	       <COND ;(.NP
		      <SET PPTR <NP-LEXBEG .NP>>	;"unreliable"
		      <SET TMP <+ 1 </ <- <NP-LEXEND .NP> .PPTR>
				       ,LEXV-ELEMENT-SIZE-BYTES>>>)
		     (T
		      <SET PPTR <ZGET ,OOPS-TABLE ,O-START>
				;<REST-TO-SLOT ,P-LEXV LEXV-START>>
		      <SET TMP <ZGET ,OOPS-TABLE ,O-LENGTH> ;,P-OLEN>)>
	       <SET PPTR <ZREST .PPTR <* .NUM <* 2 ,P-LEXELEN>>>>)
	      ;(T
	       <SET PPTR <ZREST ,P-LEXV
				<* 2 <+ ,P-LEXSTART <* .NUM ,P-LEXELEN>>>>>
	       <SET TMP <GETB ,P-LEXV ,P-LEXWORDS>>)>
	<SET NUM <- .TMP .NUM>>
	<MAKE-ROOM-FOR-TOKENS <+ -1 .NUM> ,G-LEXV .GPTR>
	;<PUTB ,G-LEXV ,P-LEXWORDS <+ -1 .NUM <GETB ,G-LEXV ,P-LEXWORDS>>>
	<REPEAT ()
		<COND (<DLESS? NUM 0> <RETURN>)>
		<INBUF-ADD <LEXV-WORD-LENGTH .PPTR>
			   <LEXV-WORD-OFFSET .PPTR>
			   <SET TMP <+ 3 <* .GPTR 2>>>>
		<SET TMP <ZGET .PPTR 0>>
		<ZPUT ,G-LEXV .GPTR .TMP>
		<COND (<EQUAL? .TMP ,W?INT.NUM ,W?INT.TIM>
		       <ZPUT ,G-LEXV <+ 1 .GPTR> <ZGET .PPTR 1>>)>
		<SET GPTR <+ .GPTR ,LEXV-ELEMENT-SIZE>>
		<SET PPTR <+ .PPTR ,LEXV-ELEMENT-SIZE-BYTES>>>>

<DEFINE TEST-SR ACT (NP "AUX" A (CT 0) (LEN <FIND-RES-COUNT ,ORPHAN-SR>))
	<COND (<ZERO? .LEN>
	       <RETURN <> .ACT>)
	      (<WORD-TYPE? <SET A <NP-NAME .NP>> ,P-QUANT-CODE>
	       <RETURN .A .ACT>)
	      (<ZERO? <SET A <NP-ADJS .NP>>>
	       <SET A <PMEM-ALLOC ADJS LEXPTR <NP-LEXBEG .NP>>>)
	      (<NOT <G? ,ADJS-MAX-COUNT <SET CT <ADJS-COUNT .A>>>>
	       <RETURN <> .ACT>)>
	<ZPUT <REST-TO-SLOT .A ADJS-COUNT 1> .CT <NP-NAME .NP>>
	<ADJS-COUNT .A <+ 1 .CT>>
	<FIND-ADJS ,FINDER .A>
	<FIND-NUM ,FINDER <NUMERIC-ADJ? .NP>>
	<FIND-NOUN ,FINDER <NP-NAME ,ORPHAN-NP>>
	<FIND-RES-COUNT ,SEARCH-RES 0>
	<FIND-RES-NEXT ,SEARCH-RES <>>
	<REPEAT ((VEC <REST-TO-SLOT ,ORPHAN-SR FIND-RES-OBJ1>)
		 (SZ <FIND-RES-SIZE ,ORPHAN-SR>)
		 (REM .LEN))
		<COND (<NOT <MATCH-OBJECT <ZGET .VEC 0> ,FINDER T>>
		       <RETURN .A .ACT>)
		      ;(T <SET LEN <- .LEN 1>>)>
		<COND (<L? <SET REM <- .REM 1>> 1>
		       <RETURN>)
		      (<L? <SET SZ <- .SZ 1>> 1>
		       <COND (T ;<ZERO? <SET SR <FIND-RES-NEXT ,ORPHAN-SR>>>
			      <RETURN>)>
		       ;<SET SZ ,FIND-RES-MAXOBJ ;<OBJLIST-SIZE ,ORPHAN-SR>>
		       ;<SET VEC <REST-TO-SLOT ,ORPHAN-SR OBJLIST-NEXT>>)
		      (T <SET VEC <ZREST .VEC 2>>)>>
	<COND (<NOT <0? .CT>>
	       <ADJS-COUNT .A .CT>)>
	<COND (<NOT <0? <FIND-RES-COUNT ,SEARCH-RES>>>
	       .A)>>

<DEFINE RED-O-NP ("OPT" N:FIX TYP:FIX "AUX" A NP (PP <>))
 ;<COND (<NOT <ASSIGNED? N>>
	<IFFLAG (P-DEBUGGING-PARSER <PRINTR "O-NP">) (T <RFALSE>)>)>
 <COND (<EQUAL? .N 2>
	<SET PP <POP-PSTACK ,DATA-STACK>>)>
 <SET NP <POP-PSTACK ,DATA-STACK>>
 <COND (<AND <PMEM-TYPE? .NP NOUN-PHRASE>
	     <EQUAL? <NOUN-PHRASE-OBJ1 .NP> ,INTQUOTE>>
	<SET NP <NOUN-PHRASE-NP1 .NP>>
	<COND (<ZERO? ,P-OFLAG>
	       <SET PP </ <- <NP-LEXBEG .NP> ,P-LEXV> 2>>
	       <MAKE-ROOM-FOR-TOKENS 1 ,G-LEXV .PP>
	       <ZPUT ,G-LEXV .PP ,W?SAY>
	       <COPY-INPUT>
	       <THROW ,PARSER-RESULT-AGAIN ,PARSE-SENTENCE-ACTIVATION>)>)>
 <COND (<T? ,P-OFLAG>
	<COND (<AND <ZERO? .PP>
		    <WORD-TYPE? <NP-NAME .NP> ,P-ADJ-CODE>
		    ;<ZERO? <NP-LOC .NP>>
		    <ZERO? <NP-QUANT .NP>>
		    <SET A <TEST-SR .NP>>>	;"Try as adjective instead."
	       <PUSH-PSTACK ,DATA-STACK .A>
	       <RED-O-ADJ 1 .TYP>		;"Never returns?"
	       <RFALSE>)>
	<COPYT ,O-LEXV ,G-LEXV ,LEXV-LENGTH-BYTES>
	<COPYT ,O-INBUF ,G-INBUF <+ 1 ,INBUF-LENGTH>>
	<SET N <ABS ,P-OFLAG>>
	<COND (<EQUAL? ,W?NO.WORD ;0 <ZGET ,G-LEXV .N>>
	       ;"PARSER-ERROR-ORPH-S: delete NO.WORD?"
	       ;<PUTB ,G-LEXV ,P-LEXWORDS <- <GETB ,G-LEXV ,P-LEXWORDS> 1>>
	       <INSERT-NP 0 .NP>)
	      (T
	       <PROG ((A1 <>))
		<COND (<SET A <NP-NAME .NP>>
		       <ZPUT ,G-LEXV .N .A>
		       <SET A <NP-LEXEND .NP>>
		       <INBUF-ADD <LEXV-WORD-LENGTH .A>
				  <LEXV-WORD-OFFSET .A>
				  <+ 3 <* .N 2>>>)>
		<COND (<SET A <NP-ADJS .NP>>
		       <INSERT-ADJS .A>)>
		<COND (<T? .PP>
		       ;<SET PP <NP-LOC .NP>>
		       <MAKE-ROOM-FOR-TOKENS 2 ,G-LEXV <+ .N ,P-LEXELEN>>
		       <ZPUT ,G-LEXV <+ .N ,P-LEXELEN> <LOCATION-PREP .PP>>
		       <SET A <LOCATION-OBJECT .PP>>
		       <COND (<PMEM-TYPE? .A NOUN-PHRASE>
			      <SET A <NOUN-PHRASE-NP1 .A>>)
			     (<PMEM-TYPE? .A NPP>
			      <SET A <NPP-NOUN .A>>)>
		       <ZPUT ,G-LEXV <+ .N <* 2 ,P-LEXELEN>> <NP-NAME .A>>)>
		<COND (<AND <SET A <NP-QUANT .NP>>
			    ;<T? <NP-NAME .NP>>>
		       <PROG ((PTR .N))
			<REPEAT (WD)
			 <COND (<G? 0 <SET PTR <- .PTR ,P-LEXELEN>>>
				<SET PTR <OR .A1 .N>>
				<MAKE-ROOM-FOR-TOKENS 1 ,G-LEXV .PTR>
				<RETURN>)
			       (<OR <EQUAL? <SET WD <ZGET ,G-LEXV .PTR>>
					    ,W?THE>
				    <WORD-TYPE? .WD ,P-QUANT-CODE>>
				<RETURN>)
			       (<WORD-TYPE? .WD ,P-ADJ-CODE>
				<SET A1 .PTR>)
			       (T
				<SET PTR <OR .A1 .N>>
				<MAKE-ROOM-FOR-TOKENS 1 ,G-LEXV .PTR>
				<RETURN>)>>
			<ZPUT ,G-LEXV .PTR <GET-QUANTITY-WORD .A>>>)>>)>
	<ZPUT ,OOPS-TABLE ,O-START <ZGET ,OOPS-TABLE ,O-AGAIN>>
	;<SETG P-OFLAG <>>
	<COPY-INPUT ;T>
	<THROW ,PARSER-RESULT-AGAIN ,PARSE-SENTENCE-ACTIVATION>)>>

<DEFINE RED-PERS ACT ("OPT" N:FIX TYP:FIX "AUX" X:PMEM)
 ;<COND (<NOT <ASSIGNED? N>>
	<IFFLAG (P-DEBUGGING-PARSER <PRINTR "PERS">) (T <RFALSE>)>)>
 <COND (<NOT <EQUAL? .N 2 3>>
	T)
       (<OR <AND <==? <SET X <POP-PSTACK ,DATA-STACK>> ,W?COMMA>
		 <EQUAL? .N 2>>
	    <AND <==? .X ,W?TO>
		 ;<EQUAL? .N 3>>>
	<SET X <POP-PSTACK ,DATA-STACK>>
	<COND (<EQUAL? .N 3>
	       <COND ;(<NOT <ZAPPLY ,ASKING-VERB-WORD?
				   <POP-PSTACK ,DATA-STACK>>>
		      <RETURN <> .ACT>)
		     (<NOT <WORD-TYPE? <ZGET ,P-RUNNING 0> ,P-VERB-CODE>>
		      <RETURN <> .ACT>)>)>
	<HACK-TELL .X>)>>

<DEFINE HACK-TELL ACT (X "AUX" NP)
	<PARSE-VERB ,PARSE-RESULT ,W?TELL>
	<GET-SYNTAX <VERB-ONE <WORD-VERB-STUFF ,W?TELL>> 1 <>>
	<COND (<NOT <SET NP <DETERMINE-OBJ .X 1>>>
	       <RETURN <PARSER-ERROR 0 ,PARSER-ERROR-NOOBJ .X> .ACT>)>
	<PARSE-VERB-LEXV ,PARSE-RESULT ,TLEXV>
	<PARSE-CHOMPER ,PARSE-RESULT .NP>
	<SET X <NOUN-PHRASE-OBJ1 .NP>>
	<COND (<EQUAL? .X ,WINNER ,PLAYER ,ME>
	       T)
	      <IFN-P-PS-ADV
	      (<EQUAL? .X ,YOU>
	       T)>
	      (T
	       <IGNORE-FIRST-WORD ,W?YOU>
	       <COND (<L? ,P-LEN 1>
		      <SETG P-CONT <>>)
		     (T
		      <SETG P-CONT ,TLEXV>)>
	       <COND (<OR <EQUAL? ,M-FATAL <HACK-TELL-1 .NP>>
			  <ZERO? ,P-CONT>>
		      <SETG P-CONT -1>
		      <THROW ,PARSER-RESULT-DEAD
			     ,PARSE-SENTENCE-ACTIVATION>)>
	       ;<SETG WINNER <PARSE-CHOMPER ,PARSE-RESULT>>)>
	T>

<DEFINE HACK-TELL-1 ACT (NP "AUX" X NUM CT)
	<SETG PRSO-NP <NOUN-PHRASE-NP1 .NP>>
	<SET X <NOUN-PHRASE-OBJ1 .NP>>
	<COND (<L? 1 <SET CT <NOUN-PHRASE-COUNT .NP>>>
	       <COND (<L=? .CT <SET NUM <NOUN-PHRASE-FLAGS .NP>>>
		      <RETURN <> .ACT>)>
	       <NOUN-PHRASE-FLAGS .NP <+ 1 .NUM>>
	       <SETG PRSO-NP	<ZGET <REST-TO-SLOT .NP NOUN-PHRASE-NP1>
					<* 2 .NUM>>>
	       <SET X		<ZGET <REST-TO-SLOT .NP NOUN-PHRASE-OBJ1>
					<* 2 .NUM>>>
	       <TELL D .X ":|">)>
	<IF-P-BE-VERB
		<SETG PRSQ <>>
		<SETG PRSS <>>>
	<SET X <PERFORM ,V?TELL .X>>
	<PARSE-ACTION ,PARSE-RESULT 0 ;"for DONT-UNDERSTAND">
	.X>

<DEFINE RED-VP ("OPT" N:FIX TYP:FIX "AUX" VERB (A1 T) (A2 T))
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "VP">) (T <RFALSE>)>)>
	<COND (<G? .N 2>
	       <SET A1 <POP-PSTACK ,DATA-STACK>>)>
	<SET VERB <POP-PSTACK ,DATA-STACK>>
	<COND (<G? .N 2>
	       <SET A2 <POP-PSTACK ,DATA-STACK>>
	       <COND (<EQUAL? .N 4>
		      <POP-PSTACK ,DATA-STACK>)>)>
	<PARSE-VERB ,PARSE-RESULT .VERB>
	<PARSE-VERB-LEXV ,PARSE-RESULT ,TLEXV>
	<COND (<N==? .A1 T>
	       <PARSE-ADV ,PARSE-RESULT <OR <WORD-SEMANTIC-STUFF .A1> .A1>>)
	      (<N==? .A2 T>
	       <PARSE-ADV ,PARSE-RESULT <OR <WORD-SEMANTIC-STUFF .A2> .A2>>)>
	T>

"Basic NP reduction.  Doesn't do any checking at this level, just copies
 everything into a structure for later use."

<DEFINE RED-NP ("OPT" N:FIX TYP:FIX
		 "AUX" NAME (QUANT ,NP-QUANT-NONE) LEXB (LEXE ,TLEXV) ADJ)
  ;<COND (<NOT <ASSIGNED? N>>
	 <IFFLAG (P-DEBUGGING-PARSER <PRINTR "ADJ*-NOUN">) (T <RFALSE>)>)>
  <SET NAME <POP-PSTACK ,DATA-STACK>>
  <COND (<EQUAL? .NAME 1>
	 <SET NAME <>>)>
  <COND (<WORD-TYPE? <ZGET .LEXE 0> ,P-COMMA-CODE ,P-EOI-CODE>
	 ;<EQUAL? ,W?COMMA <ZGET .LEXE 0>>
	 <SET LEXE <ZBACK .LEXE ,LEXV-ELEMENT-SIZE-BYTES>>)>
  <COND (<==? <SET ADJ <POP-PSTACK ,DATA-STACK>> 1>
	 <SET LEXB .LEXE>
	 <SET ADJ <>>)
	(T
	 <SET LEXB <ADJS-LEXPTR .ADJ>>
	 <COND (<T? <ADJS-QUANT .ADJ>>
		<SET QUANT <ADJS-QUANT .ADJ>>)>)>
  <PMEM-ALLOC NP NAME .NAME ADJS .ADJ
		 LEXBEG .LEXB LEXEND .LEXE QUANT .QUANT>>

"Reduction for FOO OF BARS"
<DEFINE RED-OF ("OPT" N:FIX TYP:FIX "AUX" ONP:PMEM NP:PMEM TMP A)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "NP-OF-NP">) (T <RFALSE>)>)>
	<SET ONP <POP-PSTACK ,DATA-STACK>>
	<COND (<==? <POP-PSTACK ,DATA-STACK> ,W?OF>
	       <COND (<AND <NP-QUANT <SET NP <POP-PSTACK ,DATA-STACK>>>
			   <NOT <NP-NAME .NP>>
			   <NOT <NP-ADJS .NP>>>
		      ;"ALL OF THE BOOKS = ALL BOOKS"
		      <NP-QUANT .ONP <NP-QUANT .NP>>
		      .ONP)
		     (T
		      <NP-OF .NP .ONP>
		      .NP)>)>>

"Reduction for case of a quantity by itself"
<DEFINE RED-QT ("OPT" N:FIX TYP:FIX "AUX" Q)
 ;<COND (<NOT <ASSIGNED? N>>
	<IFFLAG (P-DEBUGGING-PARSER <PRINTR "QUANT">) (T <RFALSE>)>)>
 <SET Q <POP-PSTACK ,DATA-STACK>>
 <COND (<NOT <EQUAL? .Q ,W?A ,W?AN>>
	<PMEM-ALLOC NP QUANT <GET-QUANTITY .Q>
			LEXBEG ,TLEXV LEXEND ,TLEXV>)>>

<DEFINE GET-QUANTITY-WORD (Q "AUX" TBL)
 <COND (<SET TBL <INTBL? .Q ,NP-QUANT-TBL ,NP-QUANT-TBL-LEN *204*>>
	<ZGET .TBL 1>)>>

<DEFINE GET-QUANTITY (Q:VWORD "AUX" TBL)
 <COND (<SET TBL <INTBL? .Q <ZREST ,NP-QUANT-TBL 2> ,NP-QUANT-TBL-LEN *204*>>
	<ZGET <ZBACK .TBL 2> 0>)>>

"Quantity followed by a noun phrase:  ALL RED BOOKS"
<DEFINE RED-QN ("OPT" N:FIX TYP:FIX "AUX" NP:PMEM Q)
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "QUANT-NP">) (T <RFALSE>)>)>
	<SET NP <POP-PSTACK ,DATA-STACK>>
	<COND ;(<NOT <EQUAL? <NP-QUANT .NP> ,NP-QUANT-NONE ,NP-QUANT-PLURAL>>
	       <PARSER-ERROR ,P-DONT-UNDERSTAND-TWO-QUANTITIES>)
	      (T
	       ;"We don't distinguish ALL THE BOOKS from ALL THE BOOK."
	       <NP-LEXBEG .NP <- <NP-LEXBEG .NP> ,LEXV-ELEMENT-SIZE-BYTES>>
	       <NP-QUANT .NP <GET-QUANTITY <POP-PSTACK ,DATA-STACK>>>
	       .NP)>>

"Basic top-level noun phrase reduction"
<DEFINE RED-NPP RED ("OPT" N:FIX TYP:FIX
		"AUX" NPP:PMEM ONPP:PMEM PP:PMEM NP (RLOC <>)
		      (X1 <>) (X2 <>) (KLUDGE-FLAG <>))
  ;<COND (<NOT <ASSIGNED? N>>
	 <IFFLAG (P-DEBUGGING-PARSER <PRINTR "NPP">) (T <RFALSE>)>)>
  <COND (<==? .N 1>
	 ;"Just an NP, so nothing interesting to do"
	 <POP-PSTACK ,DATA-STACK>)
	(<==? .N 2>
	 ;"NP/NPP followed by PP"
	 <SET PP <POP-PSTACK ,DATA-STACK>>
	 <SET ONPP <POP-PSTACK ,DATA-STACK>>
	 <COND (<EQUAL? <PP-PREP .PP> ,W?BUT ,W?EXCEPT>
		;"An exception, which isn't the same as a location"
		<COND
		 (<NOT <PMEM-TYPE? .ONPP NP>>;"Can't have exceptions to an NPP"
		  <RETURN <PARSER-ERROR 0 ,PARSER-ERROR-NOUND> .RED>)
		 (<NOT <NP-QUANT .ONPP>>
		  <COND	;"PUT ALL IN FOO BUT BAR?"
			(<NOT <PSTACK-EMPTY? ,DATA-STACK>>
			 <SET X1 <POP-PSTACK ,DATA-STACK>>
			 <COND (<NOT <PSTACK-EMPTY? ,DATA-STACK>>
				<SET X2 <POP-PSTACK ,DATA-STACK>>
				<COND (<AND <PMEM? .X2>
					    <PMEM-TYPE? .X2 NP>
					    <NP-QUANT .X2>
					    <REDUCE-EXCEPTION .PP .X2>>
				       <SET KLUDGE-FLAG T>)>
				<PUSH-PSTACK ,DATA-STACK .X2>)>
			 <PUSH-PSTACK ,DATA-STACK .X1>)>
		  <COND (<NOT .KLUDGE-FLAG>;"Doesn't make much sense otherwise"
			 <RETURN <PARSER-ERROR 0 ,PARSER-ERROR-NOUND> .RED>)>)
		 (<NOT <REDUCE-EXCEPTION .PP .ONPP>> ;"Try to make sense of it"
		  <RETURN <> .RED>)>)
	       (<NOT <SET RLOC <REDUCE-LOCATION .PP>>>
		;"Died, set up orphaning and severity"
		<RETURN <> .RED>)>
	 <COND (<NOT .RLOC> .ONPP)
	       (<PMEM-TYPE? .ONPP NP>
		;"We have NP (disguised as NPP) followed by PP,
		   so glue them together"
		<COND (<NP-LOC .ONPP>
		       <PARSER-ERROR 0 ,PARSER-ERROR-TMNOUN
				     <LOCATION-PREP .RLOC>>)
		      (T
		       <NP-LOC .ONPP .RLOC>
		       .ONPP)>)
	       (T
		;"We have NPP followed by PP. NPP is produced only
		   by NP CONJ NP"
		<REPEAT ((OONPP:<OR PMEM FALSE> .ONPP) NP:PMEM)
			<COND (<NOT <NP-LOC <SET NP <NPP-NOUN .OONPP>>>>
			       <NP-LOC .NP .RLOC>)>
			<COND (<NOT <SET OONPP <NPP-NEXT .OONPP>>>
			       <RETURN .ONPP .RED>)
			      (<PMEM-TYPE? .OONPP NP>
			       <NP-LOC .OONPP .RLOC>
			       <RETURN .ONPP .RED>)>>)>)
	(T
	 ;"Case of NPP AND NP"
	 <SET NP <POP-PSTACK ,DATA-STACK>>
	 <COND (<EQUAL? <POP-PSTACK ,DATA-STACK>
			,W?AND ;,W?OR ,W?COMMA>
		<COND (<AND <PMEM-TYPE? <SET NPP <POP-PSTACK ,DATA-STACK>> NP>
			    <NP-EXCEPT .NPP>>
		       ;"Prefer all (but foo and bar) over
			  (all but foo) and bar..."
		       <RETURN <> .RED>)>
		<SET NP <PMEM-ALLOC NPP NOUN .NP>>
		<COND (<PMEM-TYPE? .NPP NP>
		       <PMEM-ALLOC NPP NEXT .NP
				   NOUN .NPP>)
		      (T
		       <REPEAT ((NN:PMEM .NPP) TEMP:<OR FALSE PMEM>)
		         <COND (<NOT <SET TEMP <NPP-NEXT .NN>>>
				<NPP-NEXT .NN .NP>
				<RETURN>)>
			 <SET NN .TEMP>>
		       .NPP)>)>)>>

<DEFINE RED-PP PP ("OPT" N:FIX TYP:FIX
		   "AUX" TMP NOUN:PMEM (PREP:<OR VWORD FALSE> <>))
	;<COND (<NOT <ASSIGNED? N>>
	       <IFFLAG (P-DEBUGGING-PARSER <PRINTR "PP">) (T <RFALSE>)>)>
	<SET NOUN <POP-PSTACK ,DATA-STACK>>
  <COND (<==? .N 2>
	 <SET PREP <POP-PSTACK ,DATA-STACK>>)
	(<==? <SET TMP <POP-PSTACK ,DATA-STACK>> ,W?OF>
	 <COND (<==? <SET PREP <POP-PSTACK ,DATA-STACK>> ,W?OUT>
		<SET PREP ,W?FROM>)
	       (T
		<RETURN <> .PP>)>)
	(<==? .TMP ,W?NOT>
	 <COND (<EQUAL? <SET PREP <POP-PSTACK ,DATA-STACK>> ,W?BUT ,W?EXCEPT>
		T)
	       (T
		<RETURN <> .PP>)>)>
  <COND (.PREP <PMEM-ALLOC PP PREP .PREP NOUN .NOUN>)>>

<ADD-WORD MY ADJ>
<ADD-WORD ME NOUN>
<ADD-WORD YOUR ADJ>
<ADD-WORD YOU NOUN>
<ADD-WORD ITS ADJ>
<ADD-WORD IT NOUN>
<ADD-WORD HIS ADJ>
<ADD-WORD HIM NOUN>
<IFN-P-PS-ADV
	<ADD-WORD HER ADJ>
	<ADD-WORD HER NOUN>>
;<ADD-WORD OUR ADJ>
;<ADD-WORD US NOUN>
;<ADD-WORD THEIR ADJ>
;<ADD-WORD THEM NOUN>

<DEFINE RED-POSS RP ("OPT" N:FIX TYP:FIX "AUX" (OBJ 0) WD A)
 ;<COND (<NOT <ASSIGNED? N>>
	<IFFLAG (P-DEBUGGING-PARSER <PRINTR "POSSESSIVE">) (T <RFALSE>)>)>
 <COND (<==? .N 3>
	<COND (<N==? <POP-PSTACK ,DATA-STACK> ,W?S>
	       <PARSER-ERROR 0 ,PARSER-ERROR-NOUND>)
	      (<N==? <POP-PSTACK ,DATA-STACK> ,W?APOSTROPHE>
	       <PARSER-ERROR 0 ,PARSER-ERROR-NOUND>)
	      (T
	       <POP-PSTACK ,DATA-STACK>)>)>>

<CONSTANT LAST-OBJECT 0>

<DEFINE RED-ADJ RA ("OPT" N:FIX TYP:FIX "AUX" A1 A2 CT AD)
  ;<COND (<NOT <ASSIGNED? N>>
	 <IFFLAG (P-DEBUGGING-PARSER <PRINTR "ADJ*">) (T <RFALSE>)>)>
  ;"We die after four adjectives for now, since we don't have arbitrary
     storage allocation.  Other possibilities exist for the future..."
  <COND (<0? .N> 1)
	(T
	 <COND (<==? <SET A1 <POP-PSTACK ,DATA-STACK>> 1>
		<SET A1 <PMEM-ALLOC ADJS LEXPTR ,TLEXV>>)>
	 <SET A2 <POP-PSTACK ,DATA-STACK>>
	 <COND (<PMEM? .A2>	;"NP"
		<ADJS-POSS .A1 .A2>
		<RETURN .A1 .RA>)
	       (<EQUAL? .A2 ,W?MY>
	        <ADJS-POSS .A1 ,PLAYER>
		<RETURN .A1 .RA>)
	       (<EQUAL? .A2 ,W?YOUR>
		<COND (T ;<NOT <==? ,WINNER ,PLAYER>>
		       <ADJS-POSS .A1 ,WINNER>)>
		<RETURN .A1 .RA>)
	       (<EQUAL? .A2 ,W?HIS>	;"ASK TROLL ABOUT HIS AX"
		<COND (<AND <SET AD <PARSE-OBJ1 ,PARSE-RESULT>>
			    <SET AD <NOUN-PHRASE-OBJ1 .AD>>
			    <FSET? .AD ,PERSONBIT>>
		       <ADJS-POSS .A1 .AD>
		       <IFN-P-PS-ADV
				<COND (<FSET? .AD ,FEMALE ;,FEMALEBIT>
				       <ADJS-POSS .A1 ,P-HIM-OBJECT>)>>)
		      (T
		       <ADJS-POSS .A1 ,P-HIM-OBJECT>)>
		<RETURN .A1 .RA>)>
	 <IFN-P-PS-ADV
	 <COND (<EQUAL? .A2 ,W?HER>
		<COND (<AND <SET AD <PARSE-OBJ1 ,PARSE-RESULT>>
			    <SET AD <NOUN-PHRASE-OBJ1 .AD>>
			    <FSET? .AD ,PERSONBIT>
			    <FSET? .AD ,FEMALE ;,FEMALEBIT>>
		       <ADJS-POSS .A1 .AD>)
		      (T
		       <ADJS-POSS .A1 ,P-HER-OBJECT>)>
		<RETURN .A1 .RA>)>>
	 <COND (<EQUAL? .A2 ,W?ITS>
		<COND (<AND <SET AD <PARSE-OBJ1 ,PARSE-RESULT>>
			    <SET AD <NOUN-PHRASE-OBJ1 .AD>>
			    <NOT <FSET? .AD ,PERSONBIT>>>
		       <ADJS-POSS .A1 .AD>)
		      (T
		       <ADJS-POSS .A1 ,P-IT-OBJECT>)>)
	       (<BAND ,POSSESSIVE <WORD-FLAGS .A2>>
		<ADJS-POSS .A1 <WORD-SEMANTIC-STUFF .A2>>)
	       (<EQUAL? .A2 ,W?A ,W?AN ;,W?ANY>
		<ADJS-QUANT .A1 ,NP-QUANT-A>)
	       (<EQUAL? .A2 ,W?THE>
		T)
	       (<WORD-TYPE? .A2 ,P-ADJ-CODE>
		<SET AD <COND (T ;<CHECK-EXTENDED?> .A2)
			      ;(T <WORD-ADJ-ID .A2>)>>
		<COND (<L? <SET CT <ADJS-COUNT .A1:PMEM>>:FIX ,ADJS-MAX-COUNT>
		       ;"Make sure the adjective isn't already here..."
		       <REPEAT ((VV:<PRIMTYPE TABLE>
				 <REST-TO-SLOT .A1:PMEM ADJS-COUNT 1>)
				(TCT:FIX <ADJS-COUNT .A1:PMEM>))
			       <COND (<0? .TCT>
				      <ZPUT .VV 0 .A2>
				      <ADJS-COUNT .A1 <+ .CT 1>>
				      <RETURN>)>
			       <COND (<==? .AD <COND (T ;<CHECK-EXTENDED?>
						      <ZGET .VV 0>)
						     ;(T <WORD-ADJ-ID
							 <ZGET .VV 0>>)>>
				      <RETURN>)>
			       <SET VV <ZREST .VV 2>>
			       <SET TCT <- .TCT 1>>>)>)
	       (T <RETURN <> .RA>)>
	 .A1)>>

<OBJECT INTQUOTE
	(LOC GLOBAL-OBJECTS)
	(DESC "quotation")>

<DEFINE RED-QUOTE ACT ("OPT" N:FIX TYP:FIX "AUX" NP)
 ;<COND (<NOT <ASSIGNED? N>>
	<IFFLAG (P-DEBUGGING-PARSER <PRINTR "QUOTE">) (T <RFALSE>)>)>
 <COND (<EQUAL? ,W?QUOTE <POP-PSTACK ,DATA-STACK>>
	;<COND (<EQUAL? .N 3>
	       <SET NP <POP-PSTACK ,DATA-STACK>>
	       <COND (<EQUAL? ,W?QUOTE <POP-PSTACK ,DATA-STACK>>
		      <RETURN .NP .ACT>)
		     (T <RETURN <> .ACT>)>)
	      (<NOT <SPEAKING-VERB? <PARSE-ACTION ,PARSE-RESULT>>>
	       <RETURN <> .ACT>)>
	<SET NP <PMEM-ALLOC NP NAME ,W?QUOTE
			    LEXBEG <ZBACK ,P-RUNNING <* 2 ,P-LEXELEN> ;<* 2>>
			    ;"Back up over NO.WORD">>
	<REPEAT ()
	 <SET N <ZGET ,P-RUNNING 0>>
	 <COND (<OR <L? <SETG P-LEN <- ,P-LEN 1>> 0>
		    <EQUAL? .N ,W?QUOTE ,W?END.OF.INPUT>>
		<COND (<EQUAL? .N ,W?QUOTE>
		       <NP-LEXEND .NP ,P-RUNNING>
		       <SETG P-RUNNING <ZREST ,P-RUNNING <* 2 ,P-LEXELEN>>>)
		      (T
		       <NP-LEXEND .NP <ZBACK ,P-RUNNING <* 2 ,P-LEXELEN>>>)>
		;<SETG P-RUNNING <ZREST ,P-RUNNING <* 2 ,P-LEXELEN>>>
		<COND (T ;<NOT <EQUAL? .N ,W?QUOTE>>	;"LOOK UP 'WORM'"
		       <SETG P-WORDS-AGAIN </ <- ,P-RUNNING
						 <ZGET ,OOPS-TABLE ,O-START>>
					      <* 2 ,P-LEXELEN>>>
		       ;<SETG P-WORDS-AGAIN <- ,P-WORDS-AGAIN 1>>)>
		<RETURN>)>
	 <SETG P-RUNNING <ZREST ,P-RUNNING <* 2 ,P-LEXELEN>>>>
	<PMEM-ALLOC NOUN-PHRASE
		    COUNT 1 LENGTH ,NOUN-PHRASE-MIN-LENGTH
		    OBJ1 ,INTQUOTE NP1 .NP>)>>

<END-SEGMENT>
<ENDPACKAGE>