

(DEFPROP TWISTLIST
 (LAMBDA (X) ((LAMBDA (LX) (RPLACD LX LX)) (LIST X)))
EXPR)

(DEFPROP STRUCTON
 (LAMBDA (X) (PROG2 (SETQ STRUCTCHECK T) X))
EXPR)

(DEFPROP STRUCTOFF
 (LAMBDA (X) (PROG2 (SETQ STRUCTCHECK NIL) X))
EXPR)

(DEFPROP LISTTYPING
 (LAMBDA(OBL TYL TY)
  (PROG	(TY')
   A	(COND ((NULL OBL) (RETURN TY)))
	(SETQ TY' (TYPING (CAR OBL)))
	(COND
	 ((OR (NULL (CAR TYL)) (UNIFYT TY' (CAR TYL) NIL))
	  (SETQ OBL (CDR OBL))
	  (SETQ TYL (CDR TYL))
	  (GO A)))
	(PRINC (QUOTE ILL/-TYPED/ PHRASE:/ ))
	(SPRINT (CAR OBL) %MLPRINDEPTH)
	(TERPRI)
	(PRINC (QUOTE CANT/ MATCH/ ML/ TYPES/ / ))
	(PRINTMTY (TIDY TY'))
	(PRINC (QUOTE / / AND/ / ))
	(PRINTMTY (TIDY (CAR TYL)))
	(TERPRI)
	(ERR NIL)))
EXPR)

(DEFPROP TYPING
 (LAMBDA(OB)
  ((LAMBDA(C L TY TY')
    (SELECTQ
     C
     (MK/-EMPTY (COND (STRUCTCHECK TY) (NULLTY)))
     (MK/-BOOLCONST BOOLTY)
     (MK/-INTCONST INTTY)
     (MK/-TOKCONST TOKTY)
     ((mk=vartype mk=consttype mk=nulltype) TYPETY)
     ((mk=empty mk=tok) TERMTY)
     (mk=truth FORMTY)
     (MK/-FAIL TY)
     (MK/-FAILWITH (LISTTYPING L (LIST TOKTY) TY))
     (MK/-VAR (GETTYPE (CAR L)))
     (MK/-CONSTTYP
      (COND
       ((CHECKABST L)
	(CONS (GETTYPET (CAR L)) (MAPCAR (FUNCTION TYPING) (CDR L))))
       ((GETTYPET (CAR L)))))
     (MK/-VARTYP
      (COND ((ASSOC1 (CAR L) %VARTYPES))
	    (T (PUSHQ (CONS (CAR L) TY) %VARTYPES) TY)))
     ((MK/-INTTYP MK/-BOOLTYP
		 MK/-TERMTYP
		 MK/-FORMTYP
		 MK/-TYPETYP
		 MK/-THMTYP
		 MK/-TOKTYP
		 MK/-NULLTYP
		 MK/-LISTYP
		 MK/-PRODTYP
		 MK/-FUNTYP
		 MK/-SUMTYP)
      (CONS C (MAPCAR (FUNCTION TYPING) L)))
     (MK/-STRAINT
      ((LAMBDA (TY) (LISTTYPING (LIST (CAR L)) (LIST TY) TY))
       (TYPING (CADR L))))
     (MK/-DUPL
      (LIST (QUOTE MK/-PRODTYP) (TYPING (CAR L)) (TYPING (CADR L))))
     (MK/-SEQ (LISTTYPING (CAR L) (TWISTLIST NIL) (TYPING (CADR L))))
     (MK/-LIST
      (LISTTYPING L (TWISTLIST TY) (LIST (QUOTE MK/-LISTYP) TY)))
     (MK/-APPN
      (LISTTYPING L (LIST (LIST (QUOTE MK/-FUNTYP) TY TY') TY) TY'))
     (MK/-BINOP
      (COND
       (STRUCTCHECK (SETQ TY' (LIST (QUOTE MK/-LISTYP) TY))
		    (LISTTYPING (CDR L) (LIST TY TY') TY'))
       ((TYPING
	 (LIST (QUOTE MK/-APPN)
	       (LIST (QUOTE MK/-VAR) (CAR L))
	       (CONS (QUOTE MK/-DUPL) (CDR L)))))))
     (MK/-UNOP
      (TYPING
       (LIST (QUOTE MK/-APPN) (LIST (QUOTE MK/-VAR) (CAR L)) (CADR L))))
     (MK/-ASSIGN
      (PROG (TY)
	    (STRUCTON (SETQ ASSCHECK T))
	    (SETQ TY (TYPING (CAR L)))
	    (STRUCTOFF (SETQ ASSCHECK NIL))
	    (RETURN (LISTTYPING (CDR L) (LIST TY) TY))))
     ((MK/-TEST MK/-TRAP)
      (COND
       ((EQ C (QUOTE MK/-TRAP))
	(SETQ
	 L
	 (CONS
	  (CONS (TRIPLE (QUOTE ONCE) (QUOTE (MK/-LIST)) (CAR L))
		(CADR L))
	  (CDDR L)))))
      (LISTTYPING
       (MAPCAR (FUNCTION CADR) (CAR L))
       (TWISTLIST
	(SELECTQ C (MK/-TEST BOOLTY) (LIST (QUOTE MK/-LISTYP) TOKTY)))
       NIL)
      ((LAMBDA(%%%B E)
	(COND
	 ((CDR L)
	  (SETQ E (CDADR L))
	  (COND
	   ((ATOM (SETQ %%%B (CAADR L))))
	   ((SETQ
	     E
	     (LIST
	      (QUOTE MK/-IN)
	      (LIST (QUOTE MK/-LET)
		    (LIST (QUOTE MK/-VAR) (CDR %%%B))
		    (QUOTE (MK/-TOKCONST)))
	      E))
	    (SETQ %%%B (CAR %%%B))))
	  (SETQ TY' (TYPING E))
	  (SELECTQ %%%B (ONCE (SETQ TY TY')) NIL))
	 ((SELECTQ C (MK/-TEST (SETQ TY NULLTY)) NIL))))
       NIL
       NIL)
      (PROG (%TY)
	    (SETQ %TY TY)
	    (RETURN
	     (LISTTYPING
	      (MAPCAR (FUNCTION CDDR) (CAR L))
	      (MAPCAR
	       (FUNCTION
		(LAMBDA (X) (COND ((EQ (CAR X) (QUOTE ONCE)) %TY))))
	       (CAR L))
	      %TY))))
     (MK/-ABSTR
      (VARBINDINGS (CAR L) C)
      (POPENV
       (LIST (QUOTE MK/-FUNTYP)
	     (STRUCTOFF (TYPING (STRUCTON (CAR L))))
	     (TYPING (CADR L)))))
     (MK/-IN (TYPING (CAR L)) (POPENV (TYPING (CADR L))))
     (MK/-IND (TYPING (CAR L)) (POPTENV (TYPING (CADR L))))
     (MK/-INA (TYPING (CAR L))
	     (ABSSCOPECHK (POPENV (POPTENV (TYPING (CADR L))))))
     ((MK/-LET MK/-LETREF)
      ((LAMBDA(TY)
	(PROG2
	 (VARBINDINGS (CAR L) C)
	 (STRUCTOFF
	  (LISTTYPING (STRUCTON (LIST (CAR L))) (LIST TY) TY))
	 (AND (EQ C (QUOTE MK/-LET)) (RPLACA (CAR ENV) (QUOTE LET)))))
       (TYPING (CADR L))))
     (MK/-LETREC
      (PROG2
       (VARBINDINGS (CAR L) C)
       ((LAMBDA (TY) (LISTTYPING (CDR L) (LIST TY) TY))
	(STRUCTOFF (TYPING (STRUCTON (CAR L)))))
       (RPLACA (CAR ENV) (QUOTE LET))))
     ((MK/-ABSTYPE MK/-ABSRECTYPE)
      (PROG (TYOPS ISOMS EQNL EQN)
	    (SETQ EQNL (CAR L))
	    (SETQ
	     TYOPS
	     (MAPCAR
	      (FUNCTION
	       (LAMBDA(X)
		(PROG (Y)
		      (SETQ Y (GENSYM))
		      (PUTPROP Y (LENGTH (CADR X)) (QUOTE ARITY))
		      (PUTPROP Y (CAR X) (QUOTE ABSNAME))
		      (RETURN (CONS (CAR X) Y)))))
	      EQNL))
	    (AND (EQ C (QUOTE MK/-ABSRECTYPE)) (TYPEBINDINGS TYOPS))
       A    (COND
	     (EQNL
	      (SETQ EQN (CAR EQNL))
	      (SETQ EQNL (CDR EQNL))
	      (PROG (%VARTYPES TY1 TY2)
		    (SETQ
		     %VARTYPES
		     (MAPCAR (FUNCTION (LAMBDA (V) (CONS V (GENSYM))))
			     (CADR EQN)))
		    (SETQ TY2 (TYPING (CDDR EQN)))
		    (COND
		     ((EQ (LENGTH (CADR EQN)) (LENGTH %VARTYPES)))
		     ((PRINC
		       (QUOTE FREE/ VARTYPE/ IN/ ABSTYPE/ EQUATION))
		      (TERPRI)
		      (ERR NIL)))
		    (SETQ
		     TY1
		     (CONS (ASSOC1 (CAR EQN) TYOPS)
			   (MAPCAR (FUNCTION CDR) %VARTYPES)))
		    (PUSHQ
		     (LIST (JUXT (QUOTE rep) (CAR EQN))
			   (QUOTE MK/-FUNTYP)
			   TY1
			   TY2)
		     ISOMS)
		    (PUSHQ
		     (LIST (JUXT (QUOTE abs) (CAR EQN))
			   (QUOTE MK/-FUNTYP)
			   TY2
			   TY1)
		     ISOMS)
		    (RETURN NIL))
	      (GO A)))
	    (AND (EQ C (QUOTE MK/-ABSTYPE)) (TYPEBINDINGS TYOPS))
	    (PUSHQ (CONS (QUOTE ABS) ISOMS) ENV)
	    (SETQ TY (TYPING (CADR L)))
	    (POPENV (RPLACD (CADR ENV) (CDAR ENV))))
      TY)
     (MK/-DEFTYPE
      (PROG (%RECS %NONRECS)
	    (MAPC (FUNCTION TESTTYPE) (CAR L))
	    (TYPEBINDINGS
	     (MAPCAR
	      (FUNCTION
	       (LAMBDA(X)
		(CONS
		 (CAR X)
		 (SHAREPAIR (QUOTE MLTYPE) (BUILDTYPE (CDR X))))))
	      (CAR L))))
      NULLTY)
     (MK/-DEFRECTYPE
      (PROG (%RECS %NONRECS RECL REC)
	    (SETQ %RECS
		  (MAPCAR (FUNCTION TESTTYPE) (SETQ %RECS (CAR L))))
       A    (SETQ RECL %RECS)
       C    (COND ((NULL RECL) (GO B)))
	    (SETQ REC (CAR RECL))
	    (COND ((CDR REC) (SETQ RECL (CDR RECL)) (GO C)))
	    (PUSHQ
	     (CONS
	      (CAR REC)
	      (SHAREPAIR (QUOTE MLTYPE)
			 (BUILDTYPE (ASSOC1 (CAR REC) (CAR L)))))
	     %NONRECS)
	    (SETQ %RECS (OUTQ REC %RECS))
	    (MAPC
	     (FUNCTION
	      (LAMBDA (Y) (RPLACD Y (OUTQ (CAR REC) (CDR Y)))))
	     %RECS)
	    (GO A)
       B    (MAPC (FUNCTION (LAMBDA (X) (RPLACD X (CONS NIL NIL))))
		  %RECS)
	    (PROG (%L)
		  (SETQ %L L)
		  (MAPC
		   (FUNCTION
		    (LAMBDA(X)
		     (FORCESHARE
		      (QUOTE MLTYPE)
		      (RPLAC (CDR X)
			     (BUILDTYPE (ASSOC1 (CAR X) (CAR %L)))))))
		   %RECS))
	    (SETQ %RECTYPES (APPEND %RECS %RECTYPES))
	    (TYPEBINDINGS (APPEND %RECS %NONRECS)))
      NULLTY)
     ((MK/-TYQUOT MK/-QUOT mk=antiquot) (TYPING (CAR L)))
     ((mk=funtype mk=prodtype mk=sumtype)
      (LISTTYPING L (LIST TYPETY TYPETY) TYPETY))
     (mk=typed (LISTTYPING L (LIST TERMTY TYPETY) TERMTY))
     ((mk=comb mk=pair mk=abs mk=cond)
      (LISTTYPING L (LIST TERMTY TERMTY TERMTY) TERMTY))
     ((mk=imp mk=conj) (LISTTYPING L (LIST FORMTY FORMTY) FORMTY))
     (mk=quant (LISTTYPING L (LIST TERMTY FORMTY) FORMTY))
     ((mk=equiv mk=inequiv)
      (LISTTYPING L (LIST TERMTY TERMTY) FORMTY))
     (PARSERR C)))
   (CAR OB)
   (CDR OB)
   (GENSYM)
   (GENSYM)))
EXPR)

(DEFPROP PARSERR
 (LAMBDA(C)
  (PROG	NIL
	(PRINC (QUOTE BAD/ PARSER/ CONSTRUCTOR/ ))
	(PRINC C)
	(TERPRI)
	(ERR NIL)))
EXPR)

(DEFPROP INITMLTYPENV
 (LAMBDA NIL
  (PROG	NIL
	(SETQ NULLTY (QUOTE (MK/-NULLTYP)))
	(SETQ BOOLTY (QUOTE (MK/-BOOLTYP)))
	(SETQ INTTY (QUOTE (MK/-INTTYP)))
	(SETQ TOKTY (QUOTE (MK/-TOKTYP)))
	(SETQ TYPETY (QUOTE (MK/-TYPETYP)))
	(SETQ TERMTY (QUOTE (MK/-TERMTYP)))
	(SETQ FORMTY (QUOTE (MK/-FORMTYP)))
	(SETQ THMTY (QUOTE (MK/-THMTYP)))
	(SETQ %SECTIONS NIL)
	(SETQ %EMT
	      (SETQ %TEMT
		    (SETQ %THISDEC
			  (SETQ	%THISTYDEC
				(SETQ %DEFTYPES
				      (SETQ %RECTYPES
					    (SETQ %TOPVALOPS
						  NIL)))))))))
EXPR)

(DEFPROP TYPECHECK
 (LAMBDA(OB)
  (PROG	(PH ENV TENV ASSCHECK STRUCTCHECK GLASSL TY %VARTYPES)
	(SETQ PH (CAR OB))
	(SETQ ENV %EMT)
	(SETQ TENV %TEMT)
	(SETQ TY (TIDY (TYPING OB)))
	(ABSSCOPECHK TY)
	(COND
	 ((AND (EQ PH (QUOTE MK/-LETREF)) (POLY TY))
	  (PRINC (QUOTE TOP/-LEVEL/ LETREF/ HAS/ POLYTYPE/ ))
	  (PRINTMTY TY)
	  (TERPRI)
	  (ERR NIL)))
	(MAPC (FUNCTION
	       (LAMBDA(X)
		(COND
		 ((POLY (CDR X))
		  (PRINC
		   (QUOTE
		    NON/-LOCAL/ ASSIGNMENT/ TO/ POLYTYPED/ VARIABLE/ ))
		  (PRINC (CAR X))
		  (TERPRI)
		  (ERR NIL)))))
	      GLASSL)
	(OR (EQ TENV %TEMT) (SETQ %THISTYDEC (CAR TENV)))
	(OR (EQ ENV %EMT) (TIDYCDRS (CDR (SETQ %THISDEC (CAR ENV)))))
	(RETURN TY)))
EXPR)

(DEFPROP TIDYCDRS
 (LAMBDA(L)
  (MAPC (FUNCTION (LAMBDA (X) (RPLACD X (TIDY (CDR X))))) L))
EXPR)

(DEFPROP PUTPROPL
 (LAMBDA(L PROP)
  (MAPCAR (FUNCTION (LAMBDA (X) (PUTPROP (CAR X) (CDR X) PROP))) L))
EXPR)

(DEFPROP UPDATETYPES
 (LAMBDA NIL
  (PROG	NIL
	(COND
	 (%SECTIONS (AND %THISDEC (PUSHQ %THISDEC %EMT))
		    (AND %THISTYDEC (PUSHQ %THISTYDEC %TEMT))
		    (GO A)))
	(SETQ %DEFTYPES (APPEND %THISTYDEC %DEFTYPES))
	(COND
	 (%THISDEC
	  (PUTPROPL (CDR %THISDEC) (QUOTE MLTYPE))
	  (MAPC	(FUNCTION
		 (LAMBDA(X)
		  (COND	((EQ (QUOTE MK/-LETREF) (CAR %THISDEC))
			 (PUTPROP (CAR X) T (QUOTE REFVAR)))
			((REMPROP (CAR X) (QUOTE REFVAR))))))
		(CDR %THISDEC))))
   A	(SETQ %THISDEC (SETQ %THISTYDEC NIL))))
EXPR)

(DEFPROP VARBINDINGS
 (LAMBDA (ST BINDER) (PUSHQ (CONS BINDER (LAYER ST)) ENV))
EXPR)

(DEFPROP LAYER
 (LAMBDA(ST)
  (SELECTQ (CAR ST)
	   (MK/-VAR (LIST (CONS (CADR ST) (GENSYM))))
	   (MK/-STRAINT (LAYER (CADR ST)))
	   ((MK/-DUPL MK/-LIST) (LAYERL (CDR ST)))
	   (MK/-BINOP (LAYERL (CDDR ST)))
	   NIL))
EXPR)

(DEFPROP LAYERL
 (LAMBDA(STL)
  (COND (STL (APPEND (LAYER (CAR STL)) (LAYERL (CDR STL))))))
EXPR)

(DEFPROP GETTYPE
 (LAMBDA(%ID)
  (COND	((PROG (NONLOC) (RETURN (GETTYPEID ENV))))
	(T (PRINC (QUOTE UNBOUND/ OR/ NON/-ASSIGNABLE/ VARIABLE/ ))
	   (PRINC %ID)
	   (TERPRI)
	   (ERR NIL))))
EXPR)

(DEFPROP GETTYPEID
 (LAMBDA(E)
  (COND	((NULL E)
	 ((LAMBDA(TY)
	   (COND ((GET %ID (QUOTE REFVAR)) TY)
		 (ASSCHECK NIL)
		 (TY (MUTANT TY NIL))))
	  (GET %ID (QUOTE MLTYPE))))
	(T
	 ((LAMBDA(TY)
	   (COND ((NULL TY)
		  (COND
		   ((EQ (CAAR E) (QUOTE MK/-ABSTR)) (SETQ NONLOC T)))
		  (GETTYPEID (CDR E)))
		 ((EQ (CAAR E) (QUOTE MK/-LETREF))
		  (COND
		   ((AND ASSCHECK NONLOC)
		    (PUSHQ (CONS %ID TY) GLASSL)))
		  TY)
		 (ASSCHECK NIL)
		 ((MEMQ (CAAR E) (QUOTE (LET ABS)))
		  (MUTANT TY (CDR E)))
		 (T TY)))
	  (ASSOC1 %ID (CDAR E))))))
EXPR)

(DEFPROP MUTANT
 (LAMBDA(TY %ENV)
  (COND ((POLY TY) (PROG (%L) (RETURN (MUTANT1 TY)))) (TY)))
EXPR)

(DEFPROP MUTANT1
 (LAMBDA(TY)
  (COND	((INSTOF TY) (MUTANT1 (INSTOF TY)))
	((ATOM TY)
	 (COND ((ASSOC1 TY %L))
	       ((IMMUT TY %ENV) TY)
	       ((CDAR (PUSHQ (CONS TY (GENSYM)) %L)))))
	((GETDEFTYPE TY TENV) TY)
	((CONS (CAR TY) (MAPCAR (FUNCTION MUTANT1) (CDR TY))))))
EXPR)

(DEFPROP IMMUT
 (LAMBDA(%TYV E)
  (AND E
       (OR (AND	(NOT (MEMQ (CAAR E) (QUOTE (LET ABS))))
		(ORL (FUNCTION (LAMBDA (X) (OCCURST %TYV (CDR X))))
		     (CDAR E)))
	   (IMMUT %TYV (CDR E)))))
EXPR)

(DEFPROP GETDEFTYPE
 (LAMBDA(TY TE)
  (COND	((NULL TE)
	 (COND ((REVASSOC1 TY %DEFTYPES)) ((REVASSOC1 TY %RECTYPES))))
	((REVASSOC1 TY (CAR TE)))
	((GETDEFTYPE TY (CDR TE)))))
EXPR)

(DEFPROP TESTTYPE
 (LAMBDA(OB)
  (PROG (%RECS1) (TESTTP (CDR OB)) (RETURN (CONS (CAR OB) %RECS1))))
EXPR)

(DEFPROP TESTTP
 (LAMBDA(OB)
  (SELECTQ (CAR OB)
	   (MK/-VARTYP (PRINC (QUOTE VARIABLE/ TYPE/ IN/ lettype))
		      (TERPRI)
		      (ERR NIL))
	   (MK/-CONSTTYP
	    (COND ((ASSOC (CADR OB) %RECS) (PUSHQ (CADR OB) %RECS1))
		  ((CHECKABST (CDR OB))
		   (MAPC (FUNCTION TESTTP) (CDDR OB)))
		  ((GETTYPET (CADR OB)))))
	   ((MK/-INTTYP MK/-BOOLTYP
		       MK/-TERMTYP
		       MK/-FORMTYP
		       MK/-TYPETYP
		       MK/-THMTYP
		       MK/-TOKTYP
		       MK/-NULLTYP
		       MK/-LISTYP
		       MK/-PRODTYP
		       MK/-FUNTYP
		       MK/-SUMTYP)
	    (MAPC (FUNCTION TESTTP) (CDR OB)))
	   (PARSERR (CAR OB))))
EXPR)

(DEFPROP ABSSCOPECHK
 (LAMBDA (TY) (PROG (%L) (ATCH TY) (RETURN TY)))
EXPR)

(DEFPROP ATCH
 (LAMBDA(TY)
  (COND	((ASSOC TY %L) NIL)
	((INSTOF TY) (ATCH (INSTOF TY)))
	((ATOM TY) NIL)
	(T (PUSHQ TY %L)
	   ((LAMBDA(X)
	     (AND X (OR (EQ (GETTYPET X) (CAR TY)) (TYSCOPERR X))))
	    (GET (CAR TY) (QUOTE ABSNAME)))
	   (ORL (FUNCTION ATCH) (CDR TY)))))
EXPR)

(DEFPROP GETTYPET
 (LAMBDA (%ID) (COND ((GETTYPETID TENV)) ((TYSCOPERR %ID))))
EXPR)

(DEFPROP TYSCOPERR
 (LAMBDA(X)
  (PROG2 (PRINC (QUOTE TYPE/ ))
	 (PRINC X)
	 (PRINC (QUOTE / OUT/ OF/ SCOPE))
	 (TERPRI)
	 (ERR NIL)))
EXPR)

(DEFPROP CHECKABST
 (LAMBDA(IDARGS)
  ((LAMBDA(TY)
    (COND
     ((ATOM TY)
      (COND
       ((OR (EQ (GET TY (QUOTE ARITY)) (LENGTH (CDR IDARGS)))
	    (PROG2 (PRINC (QUOTE BAD/ ARGS/ FOR/ ABSTYPE/ ))
		   (PRINC (CAR IDARGS))
		   (TERPRI)
		   (ERR NIL)))
	T)))))
   (GETTYPET (CAR IDARGS))))
EXPR)

(DEFPROP GETTYPETID
 (LAMBDA(TE)
  (COND	((NULL TE) (ASSOC1 %ID %DEFTYPES))
	((ASSOC1 %ID (CAR TE)))
	((GETTYPETID (CDR TE)))))
EXPR)

(DEFPROP RPLAC
 (LAMBDA(X PR)
  (COND	((OR (ATOM X) (ATOM PR)) (ERR (QUOTE RPLAC)))
	((RPLACA (RPLACD X (CDR PR)) (CAR PR)))))
EXPR)

(DEFPROP BUILDTYPE
 (LAMBDA(OB)
  (SELECTQ
   (CAR OB)
   (MK/-CONSTTYP
    (COND ((ASSOC (CADR OB) %RECS)
	   (PRINC (QUOTE SIMPLE/ RECURSIVE/ letrectype))
	   (TERPRI)
	   (ERR NIL))
	  ((ASSOC1 (CADR OB) %NONRECS))
	  ((CHECKABST (CDR OB))
	   (CONS (GETTYPET (CADR OB)) (BUILDTL (CDDR OB))))
	  ((GETTYPET (CADR OB)))))
   (CONS (CAR OB) (BUILDTL (CDR OB)))))
EXPR)

(DEFPROP BUILDT
 (LAMBDA(OB)
  (SELECTQ
   (CAR OB)
   (MK/-CONSTTYP
    (COND ((ASSOC1 (CADR OB) %RECS))
	  ((ASSOC1 (CADR OB) %NONRECS))
	  ((CHECKABST (CDR OB))
	   (SHARECONS (QUOTE MLTYPE)
		      (GETTYPET (CADR OB))
		      (BUILDTL (CDDR OB))))
	  ((GETTYPET (CADR OB)))))
   (SHARECONS (QUOTE MLTYPE) (CAR OB) (BUILDTL (CDR OB)))))
EXPR)

(DEFPROP BUILDTL
 (LAMBDA(OBL)
  (COND
   (OBL
    (SHARECONS (QUOTE MLTYPE)
	       (BUILDT (CAR OBL))
	       (BUILDTL (CDR OBL))))))
EXPR)

(DEFPROP TYPEBINDINGS
 (LAMBDA (L) (PUSHQ L TENV))
EXPR)

(DEFPROP POPENV
 (LAMBDA (X) (PROG2 (POPQ ENV) X))
EXPR)

(DEFPROP POPTENV
 (LAMBDA (X) (PROG2 (POPQ TENV) X))
EXPR)

(DEFPROP PRINTMTY
 (LAMBDA (TY) (PRINC (EXPTY TY)))
EXPR)

(DEFPROP TIDY
 (LAMBDA(TY)
  (PROG (%L %STAR) (SETQ %STAR (QUOTE *)) (RETURN (TIDYUP TY))))
EXPR)

(DEFPROP TIDYUP
 (LAMBDA(TY)
  (COND	((INSTOF TY) (TIDYUP (INSTOF TY)))
	((ASSOC1 TY %L))
	((ATOM TY)
	 (PUSHQ (CONS TY %STAR) %L)
	 (SETQ %STAR (READLIST (CONS (QUOTE *) (EXPLODE %STAR))))
	 (CDAR %L))
	((GETDEFTYPE TY TENV) TY)
	((SHARECONS (QUOTE MLTYPE) (CAR TY) (TIDYUPL (CDR TY))))))
EXPR)

(DEFPROP TIDYUPL
 (LAMBDA(TYL)
  (COND
   (TYL
    (SHARECONS (QUOTE MLTYPE)
	       (TIDYUP (CAR TYL))
	       (TIDYUPL (CDR TYL))))))
EXPR)

(DEFPROP EXPTY
 (LAMBDA(TIDYTY)
  (COND
   ((GETDEFTYPE TIDYTY %TEMT))
   ((ATOM TIDYTY) TIDYTY)
   ((SELECTQ
     (CAR TIDYTY)
     (MK/-NULLTYP NULLSYM)
     (MK/-INTTYP (QUOTE int))
     (MK/-BOOLTYP (QUOTE bool))
     (MK/-TOKTYP (QUOTE tok))
     (MK/-TYPETYP (QUOTE type))
     (MK/-TERMTYP (QUOTE term))
     (MK/-FORMTYP (QUOTE form))
     (MK/-THMTYP (QUOTE thm))
     ((LAMBDA(ABS ARGS)
       (COND
	(ABS
	 (COND ((NULL ARGS) ABS)
	       ((CDR ARGS) (LIST ARGS ABS))
	       ((LIST (CAR ARGS) ABS))))
	((CONS
	  (CAR ARGS)
	  (SELECTQ (CAR TIDYTY)
		   (MK/-LISTYP (QUOTE (list)))
		   (MK/-PRODTYP (LIST PRODSYM (CADR ARGS)))
		   (MK/-SUMTYP (LIST SUMSYM (CADR ARGS)))
		   (MK/-FUNTYP (LIST ARROWSYM (CADR ARGS)))
		   (ERROR (QUOTE EXPTY)))))))
      (GETDEFTYPE (CAR TIDYTY) %TEMT)
      (MAPCAR (FUNCTION EXPTY) (CDR TIDYTY)))))))
EXPR)

(DEFPROP READTY
 (LAMBDA NIL (MAKETY (READ)))
EXPR)

(DEFPROP MAKETY
 (LAMBDA(E)
  (COND	((NULL E) NULLTY)
	((ATOM E)
	 (SELECTQ E
		  (/. NULLTY)
		  (int INTTY)
		  (bool BOOLTY)
		  ((tok token) TOKTY)
		  (type TYPETY)
		  (term TERMTY)
		  (form FORMTY)
		  (thm THMTY)
		  E))
	((EQ (CADR E) (QUOTE list))
	 (LIST (QUOTE MK/-LISTYP) (MAKETY (CAR E))))
	((EQ (CADR E) ARROWSYM)
	 (LIST (QUOTE MK/-FUNTYP) (MAKETY (CAR E)) (MAKETY (CADDR E))))
	((EQ (CADR E) SUMSYM)
	 (LIST (QUOTE MK/-SUMTYP) (MAKETY (CAR E)) (MAKETY (CADDR E))))
	(T
	 (LIST (QUOTE MK/-PRODTYP)
	       (MAKETY (CAR E))
	       (MAKETY (CADDR E))))))
EXPR)

(DEFPROP INSTOF
 (LAMBDA (TY) (COND ((ATOM TY) (GET TY (QUOTE INSTANCE)))))
EXPR)

(DEFPROP APSUBEL
 (LAMBDA (V BTY) (PUTPROP V BTY (QUOTE INSTANCE)))
EXPR)

(DEFPROP ORL
 (LAMBDA (P L) (AND L (OR (P (CAR L)) (ORL P (CDR L)))))
EXPR)

(DEFPROP PRUNE
 (LAMBDA (TY) (COND ((INSTOF TY) (PRUNE (INSTOF TY))) (TY)))
EXPR)

(DEFPROP OCCURST
 (LAMBDA (V TY) (OCCURSBT V (PRUNE TY)))
EXPR)

(DEFPROP OCCURSBT
 (LAMBDA(%TYV BTY)
  (COND	((ATOM BTY) (EQ %TYV BTY))
	((GETDEFTYPE BTY TENV) NIL)
	((ORL (FUNCTION (LAMBDA (TY) (OCCURST %TYV TY))) (CDR BTY)))))
EXPR)

(DEFPROP POLY
 (LAMBDA (TY) (POLYB (PRUNE TY)))
EXPR)

(DEFPROP POLYB
 (LAMBDA(BTY)
  (COND	((ATOM BTY))
	((GETDEFTYPE BTY TENV) NIL)
	((ORL (FUNCTION POLY) (CDR BTY)))))
EXPR)

(DEFPROP UNIFYT
 (LAMBDA (TY1 TY2 PRL) (UNIFYBT (PRUNE TY1) (PRUNE TY2) PRL))
EXPR)

(DEFPROP UNIFYBT
 (LAMBDA(BTY1 BTY2 PRL)
  (COND	((EQ BTY1 BTY2))
	((ATOM BTY1)
	 (COND ((OCCURSBT BTY1 BTY2) NIL) (T (APSUBEL BTY1 BTY2))))
	((ATOM BTY2)
	 (COND ((OCCURSBT BTY2 BTY1) NIL) (T (APSUBEL BTY2 BTY1))))
	((MEMQQ BTY1 BTY2 PRL) NIL)
	((EQ (CAR BTY1) (CAR BTY2))
	 (UNIFYTL (CDR BTY1)
		  (CDR BTY2)
		  (CONS (CONS BTY1 BTY2) PRL)))))
EXPR)

(DEFPROP UNIFYTL
 (LAMBDA(TYL1 TYL2 PRL)
  (COND	((NULL TYL1))
	((UNIFYT (CAR TYL1) (CAR TYL2) PRL)
	 (UNIFYTL (CDR TYL1) (CDR TYL2) PRL))))
EXPR)

(DEFPROP MEMQQ
 (LAMBDA(A B L)
  (AND L
       (OR (AND (EQ A (CAAR L)) (EQ B (CDAR L)))
	   (MEMQQ A B (CDR L)))))
EXPR)
