

(DEFPROP easytype
 (LAMBDA (TY) (TYPECL T TY))
EXPR)

(DEFPROP finitetype
 (LAMBDA (TY) (TYPECL NIL TY))
EXPR)

(DEFPROP TYPECL
 (LAMBDA(B TY)
  (SELECTQ (CAR TY)
	   (consttype
	    (SELECTQ (TYPECLASS (CDR TY)) (FINITE T) (EASY B) NIL))
	   (vartype NIL)
	   (funtype (AND (TYPECL NIL (CADR TY)) (TYPECL B (CDDR TY))))
	   ((sumtype prodtype)
	    (AND (TYPECL B (CADR TY)) (TYPECL B (CDDR TY))))
	   (ERR (QUOTE TYPECL))))
EXPR)

(DEFPROP MKCAN
 (LAMBDA(TOK)
  (COND	((TYCONSTP TOK))
	((PUTPROP TOK (CONS (QUOTE consttype) TOK) (QUOTE CANON)))))
EXPR)

(DEFPROP CLEANLINKS
 (LAMBDA NIL
  (MAPC (FUNCTION (LAMBDA (TC) (REMPROP TC (QUOTE CANLINK)))) %TCL))
EXPR)

(DEFPROP NEWTYPERR
 (LAMBDA NIL (PROG2 (CLEANLINKS) (ERR (QUOTE newtypes))))
EXPR)

(DEFPROP NEWTC
 (LAMBDA(X)
  (PROG2 (COND ((TYCONSTP X))
	       ((EQ (CAR (EXPLODE X)) (QUOTE *)) (NEWTYPERR))
	       ((SETQ %TCL (INQ X %TCL))))
	 X))
EXPR)

(DEFPROP NEWCAN
 (LAMBDA(X)
  ((LAMBDA (Y) (COND (Y (NEWCAN Y)) (X))) (GET X (QUOTE CANLINK))))
EXPR)

(DEFPROP NEWCLASS
 (LAMBDA(PH C1 C2)
  (SELECTQ C1
	   (FINITE C2)
	   (EASY (COND ((EQ PH (QUOTE funtype)) NIL) (C2 C1)))
	   NIL))
EXPR)

(DEFPROP TYPECLASS
 (LAMBDA (ID) (GET (CDR (TYCONSTP ID)) (QUOTE TYPECLASS)))
EXPR)

(DEFPROP PUTTYPES
 (LAMBDA(SL)
  (PROG	(X Y Z N %TCL CDL PH CD L M OK)
   P1	(COND ((NULL SL) (GO P2)))
	(SETQ N (LENGTH (SETQ Z (CAR SL))))
	(SETQ SL (CDR SL))
	(COND (Z (SETQ X (NEWTC (CAR Z)))))
	(COND
	 ((OR (ASSOC X SL) (TYCONSTP X)) (NEWTYPERR))
	 ((EQ N 1))
	 ((OR (*LESS N 3) (NOT (EQ (CADR Z) (QUOTE =)))) (NEWTYPERR))
	 ((EQ N 3) (SETQ Y (NEWCAN (NEWTC (CADDR Z))))
		   (COND ((EQ Y X)) ((PUTPROP X Y (QUOTE CANLINK)))))
	 ((NOT
	   (SETQ
	    PH
	    (SELECTQ (CADDDR Z)
		     (# (QUOTE prodtype))
		     (/+ (QUOTE sumtype))
		     (/-> (QUOTE funtype))
		     NIL)))
	  (NEWTYPERR))
	 ((EQ N 5)
	  (SETQ
	   CDL
	   (CONS
	    (CONS
	     X
	     (TRIPLE PH (NEWTC (CADDR Z)) (NEWTC (CADR (CDDDR Z)))))
	    CDL)))
	 ((NEWTYPERR)))
	(GO P1)
   P2	(MAPC
	 (FUNCTION (LAMBDA (X) (SETQ CDL (SUBST (NEWCAN X) X CDL))))
	 %TCL)
   P3	(SETQ L CDL)
   Q	(COND
	 (L (SETQ CD (CAR L))
	    (COND
	     ((SETQ Z (ASSOC1 (CDDDR CD) (GET (CADDR CD) (CADR CD))))
	      (PUTPROP (CAR CD) (CDR Z) (QUOTE CANLINK))
	      (SETQ CDL (SUBST (CDR Z) (CAR CD) (OUTQ CD CDL)))
	      (GO P3))
	     (T (SETQ L (CDR L)) (GO Q)))))
   P4	(SETQ L CDL)
   R	(COND ((NULL L) (GO P5)))
	(SETQ CD (CAR L))
	(SETQ M (SETQ L (CDR L)))
   S	(COND
	 (M
	  (COND
	   ((EQUAL (CDR CD) (CDAR M))
	    (PUTPROP (CAR CD) (CAAR M) (QUOTE CANLINK))
	    (SETQ CDL (SUBST (CAAR M) (CAR CD) (OUTQ CD CDL)))
	    (GO P4))
	   (T (SETQ M (CDR M)) (GO S)))))
	(GO R)
   P5	(MAPC
	 (FUNCTION
	  (LAMBDA(CD)
	   ((LAMBDA(X Y)
	     (COND
	      ((AND X Y)
	       ((LAMBDA(Z)
		 (COND
		  (Z (PUTPROP (CAR CD) Z (QUOTE CANON))
		     (RPLACD (RPLACA Z (QUOTE consttype)) (CAR CD)))))
		(ASSOC1
		 Y
		 (ASSOC1 X (GET (CADR CD) (QUOTE SHARETRIPLE))))))))
	    (TYCONSTP (CADDR CD))
	    (TYCONSTP (CDDDR CD)))))
	 CDL)
	(MAPC
	 (FUNCTION
	  (LAMBDA(TC)
	   (PUTPROP TC (MKCAN (NEWCAN TC)) (QUOTE CANON))))
	 %TCL)
	(MAPC
	 (FUNCTION
	  (LAMBDA(CD)
	   ((LAMBDA(X PH Y Z)
	     (PROG2
	      (PUTPROP X
		       (TRIPLE PH (TYCONSTP Y) (TYCONSTP Z))
		       (QUOTE EQTYPE))
	      (ADDPROP Y (CONS Z (TYCONSTP X)) PH)))
	    (CAR CD)
	    (CADR CD)
	    (CADDR CD)
	    (CDDDR CD))))
	 CDL)
   P6	(SETQ OK T)
	(MAPC
	 (FUNCTION
	  (LAMBDA(CD)
	   (COND
	    ((TYPECLASS (CAR CD)))
	    (((LAMBDA(C)
	       (COND
		(C (PUTPROP (CAR CD) C (QUOTE TYPECLASS))
		   (SETQ OK NIL))))
	      (NEWCLASS (CADR CD)
			(TYPECLASS (CADDR CD))
			(TYPECLASS (CDDDR CD))))))))
	 CDL)
	(COND (OK) ((GO P6)))
	(CLEANLINKS)
	(RETURN (QUOTE %NOVAL))))
EXPR)

(DEFPROP CLASHERR
 (LAMBDA (X Y) (PRINX (QUOTE "CLASH WITH EXISTING ") (ERR%F X Y)))
EXPR)

(DEFPROP REPEATERR
 (LAMBDA (X Y) (PRINX (QUOTE "REPEATED ") (ERR%F X Y)))
EXPR)

(DEFPROP ASKC
 (LAMBDA(Q)
  (PROG	(ANS)
	(REMC (QUOTE ANCESTRY))
	(SETQ ANS (ASK Q))
	(AND (*GREAT (LENGTH ANS) 6) (RPLACD (CDR (CDDDDR ANS)) NIL))
	(SETQ %CURRENT (COND ((NULL ANS) COR) ((implode ANS))))
	(PUTC (QUOTE ANCESTRY) (LIST (QUOTE PPLAMB)))
	(RETURN %CURRENT)))
EXPR)

(DEFPROP GETC
 (LAMBDA (P) (GET %CURRENT P))
EXPR)

(DEFPROP PUTC
 (LAMBDA (P V) (PUTPROP %CURRENT V P))
EXPR)

(DEFPROP REMC
 (LAMBDA (P) (REMPROP %CURRENT P))
EXPR)

(DEFPROP THEORYP
 (LAMBDA NIL (GETC (QUOTE THY)))
EXPR)

(DEFPROP DRAFTP
 (LAMBDA NIL (GETC (QUOTE DFT)))
EXPR)

(DEFPROP COREP
 (LAMBDA NIL (EQ %CURRENT COR))
EXPR)

(DEFPROP THEORYERR
 (LAMBDA (TOK) (AND (THEORYP) (TOP%F) (ERR TOK)))
EXPR)

(DEFPROP EXISTHY
 (LAMBDA(TOK)
  (OR (EQ TOK (QUOTE PPLAMB)) (ISDSK (CONS TOK (QUOTE THY)))))
EXPR)

(DEFPROP AXFCTP
 (LAMBDA (%F %TOK) (NOT (ATOM (ERRSET (APPLY %F (LIST DASH %TOK))))))
EXPR)

(DEFPROP INITC
 (LAMBDA NIL
  (PROG	NIL
	(SETQ %F NIL)
	(SETQ %CURRENT COR)
	(NULLIFY (PARENT . XTR)
		 (TYPES . XTR)
		 (CONSTS . XTR)
		 (AXIOMS . XTR)
		 (FACTS . XTR))
   K	(COND
	 ((ATOM (ERRSET (TRYINITC)))
	  (REMC (QUOTE DFT))
	  (REMC (QUOTE THY))
	  (PRINT (QUOTE (TRY AGAIN)))
	  (GO K)))))
EXPR)

(DEFPROP TRYINITC
 (LAMBDA NIL
  (COND	((NOT (EQ (ASKC (QUOTE THEORY)) COR))
	 (PUTC (QUOTE THY) (CONS %CURRENT (QUOTE THY)))
	 (THYIN %CURRENT))
	((EQ (ASKC (QUOTE DRAFT)) COR))
	((EXISTHY %CURRENT) (CLASHERR (QUOTE THEORY) %CURRENT))
	((ISDSK (PUTC (QUOTE DFT) (CONS %CURRENT (QUOTE DFT))))
	 (DFTIN %CURRENT))
	(T (NULLIFY1 (CONS %CURRENT (QUOTE FCT)))
	   (PRINC (QUOTE (START NEW DRAFT))))))
EXPR)

(DEFPROP THYIN
 (LAMBDA(TOK)
  (AND (NOT (MEMQ TOK (GETC (QUOTE ANCESTRY))))
       (PROG2 (GETPUTNEW (CONS TOK (QUOTE THY)))
	      (XTR (QUOTE PARENT) TOK)
	      (TERPRI
	       (PRINC (LIST (QUOTE THEORY) TOK (QUOTE LOADED)))))))
EXPR)

(DEFPROP DFTIN
 (LAMBDA(TOK)
  (PROG	(%DFTPARENT %DFTTYPES %DFTCONSTS)
	(GETPUTNEW (CONS TOK (QUOTE DFT)))
	(AND (DRAFTP)
	     (PROG2 (PRXTR (QUOTE PARENT) %DFTPARENT)
		    (PRXTR (QUOTE TYPES) %DFTTYPES)
		    (PRXTR (QUOTE CONSTS) %DFTCONSTS)))
	(OPENCOPY (QUOTE (AXIOMS . XTR)))
	(OPENP (QUOTE DSK:) (CONS TOK (QUOTE DFT)))
	(COND
	 ((FINDP (EXPLODE (QUOTE NEWAXIOMS)))
	  (SKIPTO LF)
	  (COPYTILLEOF)))
	(CLOSEO)
	(TERPRI (PRINC (LIST (QUOTE DRAFT) TOK (QUOTE LOADED))))))
EXPR)

(DEFPROP draftin
 (LAMBDA(TOK)
  ((LAMBDA(%F)
    (COND ((THEORYP) (ERR (QUOTE draftin)))
	  ((EXISTHY TOK) (CLASHERR (QUOTE THEORY) TOK))
	  ((PROG2 (AND (OPENP (QUOTE DSK:) (CONS TOK (QUOTE FCT)))
		       (CHECKTOKSTILLEOF (QUOTE FACT)))
		  (ProtectIO (FUNCTION DFTIN) (LIST TOK))
		  (CONCAT (QUOTE (FACTS . XTR))
			  (CONS TOK (QUOTE FCT)))))))
   (QUOTE draftin)))
EXPR)

(DEFPROP CHECKTOKSTILLEOF
 (LAMBDA(FUN)
  (PROG	(TOK TOKL)
   K	(COND ((EQ (SETQ TOK (ERRSET (READ))) (QUOTE $EOF$)))
	      ((AXFCTP FUN (SETQ TOK (CAR TOK))) (CLASHERR FUN TOK))
	      ((MEMQ TOK TOKL) (REPEATERR FUN TOK))
	      ((SETQ TOKL (CONS TOK TOKL))
	       (SKIPTO (QUOTE /"))
	       (SKIPTO (QUOTE /"))
	       (GO K)))))
EXPR)

(DEFPROP GETPUTNEW
 (LAMBDA(F)
  (PROG	(%ANC %TYPES %CONSTS)
	(SETQ %ANC (GETC (QUOTE ANCESTRY)))
	(GETNEW F)
	(PUTTYPES (APPLY (FUNCTION APPEND) %TYPES))
	(MAPC (FUNCTION
	       (LAMBDA(TOK/-TY/-FUN)
		(PROG2 (RPLACA (CDR TOK/-TY/-FUN)
			       (EVAL (CADR TOK/-TY/-FUN)))
		       (PUTCON TOK/-TY/-FUN))))
	      %CONSTS)
	(PUTC (QUOTE ANCESTRY) %ANC)))
EXPR)

(DEFPROP GETNEW
 (LAMBDA(F)
  (ProtectIO
   (FUNCTION
    (LAMBDA(F %F)
     (PROG2
      (OPENERR (QUOTE DSK:) F)
      (AND (EQ %F (QUOTE newparent))
	   (COND ((NOT (EQ (READ) (QUOTE THEORY)))
		  (ERR%F (QUOTE "BAD HEADER") (CAR F)))
		 ((SETQ %ANC (CONS (CAR F) %ANC)) (SKIPTO LF))))
      ((LAMBDA (%%P) (TMLTILLEOF)) INITENV))))
   (LIST F
	 (SELECTQ (CDR F)
		  (DFT (QUOTE draftin))
		  (THY (QUOTE newparent))
		  (ERROR (QUOTE GETNEW))))))
EXPR)

(DEFPROP XTR
 (LAMBDA(SEC ARG)
  (COND	((TOP%F)
	 (AND (OR (DRAFTP) (MEMQ SEC (QUOTE (AXIOMS FACTS))))
	      (PRXTR SEC (LIST ARG))))
	((AND (EQ %F (QUOTE draftin)) (DRAFTP))
	 (PROG2 (PUSHNCONC (JUXT (QUOTE %DFT) SEC) ARG) NIL))))
EXPR)

(DEFPROP PRXTR
 (LAMBDA(SEC ARGS)
  (ProtectIO
   (FUNCTION
    (LAMBDA(F %PRFN ARGS)
     (PROG2
      (OPENCOPY F)
      (MAPC (FUNCTION (LAMBDA (A) (TERPRI (%PRFN (TERPRI A)))))
	    ARGS))))
   (LIST (CONS SEC (QUOTE XTR)) (PRFNOF SEC) ARGS)))
EXPR)

(DEFPROP PRFNOF
 (LAMBDA(SEC)
  (SELECTQ SEC
	   (PARENT (FUNCTION PRPAR))
	   (TYPES (FUNCTION PRTYPES))
	   (CONSTS (FUNCTION PRCON))
	   ((AXIOMS FACTS) (FUNCTION PRFACT))
	   (ERROR (QUOTE PRFNOF))))
EXPR)

(DEFPROP PRPAR
 (LAMBDA (TOK) (PRINX (QUOTE "newparent `") TOK (QUOTE "` ;;")))
EXPR)

(DEFPROP PRTYPES
 (LAMBDA(SL)
  (OR (NULL SL)
      (PROG (TOKL)
	    (PRINC (QUOTE "newtypes [ ``"))
       L1   (SETQ TOKL (CAR SL))
       L2   (PRINC (CAR TOKL))
	    (COND ((SETQ TOKL (CDR TOKL)) (PRINC (QUOTE " ")) (GO L2))
		  ((SETQ SL (CDR SL))
		   (PRINX (QUOTE "`` ;") CR LF TAB (QUOTE "   ``"))
		   (GO L1)))
	    (PRINC (QUOTE "`` ] ;;")))))
EXPR)

(DEFPROP PRCON
 (LAMBDA(TOK/-TY/-FUN)
  ((LAMBDA(TOK TY FUN)
    (PRINX FUN
	   (QUOTE " ( `")
	   TOK
	   (QUOTE "` , ")
	   (printtype TY)
	   (QUOTE " ) ;;")))
   (CAR TOK/-TY/-FUN)
   (CADR TOK/-TY/-FUN)
   (CDDR TOK/-TY/-FUN)))
EXPR)

(DEFPROP PRFACT
 (LAMBDA(TOK/-FCT)
  ((LAMBDA(%PRINTTYPES TOK FCT)
    (PRINX TOK (QUOTE "  ") (printform FCT)))
   T
   (CAR TOK/-FCT)
   (CDR TOK/-FCT)))
EXPR)

(DEFPROP GETAXFCT
 (LAMBDA(%F TOK FL)
  (ProtectIO
   (FUNCTION
    (LAMBDA(TOK FL)
     (PROG NIL
      K	   (COND ((NULL FL) (ERR %F))
		 ((FINDAXFCT TOK (CAR FL)) (RETURN (READFACT)))
		 (T (SETQ FL (CDR FL)) (GO K))))))
   (LIST TOK FL)))
EXPR)

(DEFPROP FINDAXFCT
 (LAMBDA(TOK F)
  (AND (OPENP (QUOTE DSK:) F)
       (FINDP (NCONC (LIST LF) (explode TOK) (QUOTE (/  / ))))))
EXPR)

(DEFPROP READFACT
 (LAMBDA NIL
  ((LAMBDA(VAL/-TY)
    (COND ((EQ (CAR (CDR VAL/-TY)) (QUOTE MK/-FORMTYP))
	   (mkfreethm (CAR VAL/-TY)))
	  ((ERROR (QUOTE READFACT)))))
   (READQUOT)))
EXPR)

(DEFPROP newparent
 (LAMBDA(TOK)
  (OR (THEORYERR (QUOTE newparent))
      (COND ((TOP%F) (THYIN TOK))
	    ((NOT (MEMQ TOK %ANC))
	     (GETNEW (CONS TOK (QUOTE THY)))
	     (XTR (QUOTE PARENT) TOK)))))
EXPR)

(DEFPROP newtypes
 (LAMBDA(SL)
  (OR (THEORYERR (QUOTE newtypes))
      (PROG2 (COND ((TOP%F) (PUTTYPES SL))
		   (T (PUSHNCONC (QUOTE %TYPES) SL)))
	     (XTR (QUOTE TYPES) SL))))
EXPR)

(DEFPROP NEWCON
 (LAMBDA(TOK TY FUN)
  (OR (THEORYERR FUN)
      ((LAMBDA(TOK/-TY/-FUN)
	(PROG2 (COND ((CONSTP TOK) (CLASHERR (QUOTE CONSTANT) TOK))
		     ((TOP%F) (PUTCON TOK/-TY/-FUN))
		     ((ASSOC TOK %CONSTS)
		      (REPEATERR (QUOTE "NEW CONSTANT") TOK))
		     (T (PUSHNCONC (QUOTE %CONSTS) TOK/-TY/-FUN)))
	       (XTR (QUOTE CONSTS) TOK/-TY/-FUN)))
       (TRIPLE TOK TY FUN))))
EXPR)

(DEFPROP PUTCON
 (LAMBDA(TOK/-TY/-FUN)
  (PROG2 (PUTPROP (CAR TOK/-TY/-FUN) (CADR TOK/-TY/-FUN) (QUOTE const))
	 (SELECTQ (CDDR TOK/-TY/-FUN)
		  (newolinfix
		   (OLINFIX (CAR TOK/-TY/-FUN) (QUOTE PAIRED)))
		  (newolcinfix
		   (OLINFIX (CAR TOK/-TY/-FUN) (QUOTE CURRIED)))
		  NIL)))
EXPR)

(DEFPROP newconstant
 (LAMBDA (TOK TY) (NEWCON TOK TY (QUOTE newconstant)))
EXPR)

(DEFPROP newolinfix
 (LAMBDA (TOK TY) (NEWCON TOK TY (QUOTE newolinfix)))
EXPR)

(DEFPROP newolcinfix
 (LAMBDA (TOK TY) (NEWCON TOK TY (QUOTE newolcinfix)))
EXPR)

(DEFPROP NEWAXIOMS
 (LAMBDA NIL
  (SELECTQ %F
	   (draftin (CHECKTOKSTILLEOF (QUOTE AXIOM))
		    (ERR (QUOTE $EOF$)))
	   (newparent (CLOSEI) (ERR (QUOTE $EOF$)))
	   (ERR (QUOTE NEWAXIOMS))))
EXPR)

(DEFPROP NEWAXFCT
 (LAMBDA(FUN TOK FCT)
  (COND	((AXFCTP FUN TOK) (CLASHERR FUN TOK))
	(T (XTR (JUXT FUN (QUOTE S)) (CONS TOK FCT))
	   (mkfreethm FCT))))
EXPR)

(DEFPROP newaxiom
 (LAMBDA(TOK FM)
  (COND	((THEORYERR (QUOTE newaxiom)))
	((NEWAXFCT (QUOTE AXIOM) TOK (FACTOF (mkfreethm FM))))))
EXPR)

(DEFPROP newfact
 (LAMBDA (TOK TH) (NEWAXFCT (QUOTE FACT) TOK (FACTOF TH)))
EXPR)

(DEFPROP AXIOM
 (LAMBDA(TOK1 TOK2)
  (GETAXFCT
   (QUOTE AXIOM)
   TOK2
   (LIST
    (COND ((MEMQ TOK1 (LIST %CURRENT DASH))
	   (COND ((THEORYP)) (T (QUOTE (AXIOMS . XTR)))))
	  ((MEMQ TOK1 (GETC (QUOTE ANCESTRY)))
	   (CONS TOK1 (QUOTE THY)))))))
EXPR)

(DEFPROP FACT
 (LAMBDA(TOK1 TOK2)
  (GETAXFCT
   (QUOTE FACT)
   TOK2
   (COND ((MEMQ TOK1 (LIST %CURRENT DASH))
	  (CONS	(QUOTE (FACTS . XTR))
		(COND ((COREP) NIL)
		      ((LIST (CONS %CURRENT (QUOTE FCT)))))))
	 ((MEMQ TOK1 (GETC (QUOTE ANCESTRY)))
	  (LIST (CONS TOK1 (QUOTE FCT)))))))
EXPR)

(DEFPROP firm
 (LAMBDA NIL
  (COND	((COREP) (ERR (QUOTE firm)))
	((ProtectIO (FUNCTION FIRM) NIL))))
EXPR)

(DEFPROP FIRM
 (LAMBDA NIL
  (PROG	NIL
	(CONCAT (CONS %CURRENT (QUOTE FCT)) (QUOTE (FACTS . XTR)))
	(NULLIFY (FACTS . XTR))
	(AND (DRAFTP)
	     (MAKE (DRAFTP)
		   (PARENT . XTR)
		   (TYPES . XTR)
		   (CONSTS . XTR)
		   (OR (NULLP (QUOTE (AXIOMS . XTR)))
		       (PRINX CR
			      LF
			      (QUOTE "NEWAXIOMS();;")
			      CR
			      LF
			      (AXIOMS . XTR)))))))
EXPR)

(DEFPROP maketheory
 (LAMBDA(TOK)
  (COND	((DRAFTP) (ProtectIO (FUNCTION MAKETHY) (LIST TOK)))
	((ERR (QUOTE maketheory)))))
EXPR)

(DEFPROP MAKETHY
 (LAMBDA(TOK)
  (PROG	NIL
	(COND ((EQ TOK DASH) (SETQ TOK %CURRENT))
	      ((EQ TOK %CURRENT))
	      ((OR (EXISTHY TOK) (ISDSK (CONS TOK (QUOTE DFT))))
	       (ERR (QUOTE maketheory))))
	(firm)
	(MAKE (CONS TOK (QUOTE THY))
	      (QUOTE "





	THEORY ")
	      TOK
	      (QUOTE "

")	      (COPY (DRAFTP)))
	(REMC (QUOTE DFT))
	(COND ((EQ TOK %CURRENT)
	       (NULLIFY1 (CONS %CURRENT (QUOTE DFT))))
	      (T (MAKE (CONS TOK (QUOTE FCT))
		       (COPY (CONS %CURRENT (QUOTE FCT))))
		 (PUTPROP TOK
			  (GETC (QUOTE ANCESTRY))
			  (QUOTE ANCESTRY))
		 (REMC (QUOTE ANCESTRY))
		 (SETQ %CURRENT TOK)))
	(PUTC (QUOTE THY) (CONS TOK (QUOTE THY)))))
EXPR)
