

(DEFPROP ACC
 (LAMBDA(I RHO TREE ARG)
  (COND	((ATOM RHO) (COND ((EQ RHO I) (BUTLIST (CAR TREE) ARG))))
	((EQ (CAR RHO) ISOM) (COND ((MEMQ I (CDR RHO)) ISOM)))
	((NULL (CDR TREE)) (ACC I RHO TZERO (LIST (CAR TREE) ARG)))
	((ACC I (CAR RHO) (CADR TREE) ARG))
	((ACC I (CDR RHO) (CADDR TREE) ARG))))
EXPR)

(DEFPROP STOR
 (LAMBDA(I RHO TREE ARG RHS)
  (COND	((OR (ATOM RHO) (EQ (CAR RHO) ISOM)) NIL)
	((EQ (CAR RHO) I)
	 (LIST (QUOTE RPLACA) (BUTLIST (CAR TREE) ARG) RHS))
	((EQ (CDR RHO) I)
	 (LIST (QUOTE RPLACD) (BUTLIST (CAR TREE) ARG) RHS))
	((NULL (CDR TREE))
	 (STOR I RHO TZERO (LIST (CAR TREE) ARG) RHS))
	((STOR I (CAR RHO) (CADR TREE) ARG RHS))
	((STOR I (CDR RHO) (CADDR TREE) ARG RHS))))
EXPR)

(DEFPROP BUTLIST
 (LAMBDA (X Y) (COND (X (LIST X Y)) (T Y)))
EXPR)

(DEFPROP ACCESS
 (LAMBDA (I) (ACC I %P TZERO (QUOTE %E)))
EXPR)

(DEFPROP COPYST
 (LAMBDA(S E)
  (COND	((ATOM S) E)
	((AND (NOT (ATOM E))
	      (NOT (ATOM (CDR E)))
	      (MEMQ (CAR E) (QUOTE (CONS LIST))))
	 (LIST (QUOTE CONS)
	       (COPYST (CAR S) (CADR E))
	       (COPYST
		(CDR S)
		(COND ((EQ (CAR E) (QUOTE CONS)) (CADDR E))
		      (T (CONS (QUOTE LIST) (CDDR E)))))))
	(T
	 (LIST (LIST (QUOTE LAMBDA) (QUOTE (A)) (COPYS S (QUOTE A)))
	       E))))
EXPR)

(DEFPROP COPYS
 (LAMBDA(S ANS)
  (COND	((ATOM S) ANS)
	(T
	 (LIST (QUOTE CONS)
	       (COPYS (CAR S) (LIST (QUOTE CAR) ANS))
	       (COPYS (CDR S) (LIST (QUOTE CDR) ANS))))))
EXPR)

(DEFPROP STORST
 (LAMBDA(S RHO ARG)
  (COND	((OR (EQ S EMPTY) (EQ S NILL)) NIL)
	((ATOM S) (STOR S RHO TZERO (QUOTE %E) ARG))
	(T
	 (LIST (QUOTE PROG2)
	       (STORST (CAR S) RHO (LIST (QUOTE CAR) ARG))
	       (STORST (CDR S) RHO (LIST (QUOTE CDR) ARG))))))
EXPR)

(DEFPROP BVPAT
 (LAMBDA(D)
  (VARPAT
   (CADR
    (COND ((MEMQ (CAR D) (QUOTE (MK/-ABSTYPE MK/-ABSRECTYPE)))
	   (CADDR D))
	  (T D)))))
EXPR)

(DEFPROP VARPAT
 (LAMBDA(S)
  (SELECTQ (CAR S)
	   (MK/-EMPTY EMPTY)
	   (MK/-VAR (CADR S))
	   (MK/-STRAINT (VARPAT (CADR S)))
	   (MK/-DUPL (CONS (VARPAT (CADR S)) (VARPAT (CADDR S))))
	   (MK/-BINOP (CONS (VARPAT (CADDR S)) (VARPAT (CADDDR S))))
	   (MK/-LIST (NCONC (MAPCAR (FUNCTION VARPAT) (CDR S)) NILL))
	   (ERROR (CONS S (QUOTE (BAD VARSTRUCT))))))
EXPR)

(DEFPROP TREXP
 (LAMBDA (%P E) (TRE E))
EXPR)

(DEFPROP TRE
 (LAMBDA(E)
  (SELECTQ
   (CAR E)
   ((MK/-BOOLCONST MK/-INTCONST) (CADR E))
   (MK/-TOKCONST (QEVAL (CADR E)))
   (MK/-QUOT
    (SELECTQ (CAADR E)
	     (mk=antiquot (TRE (CADADR E)))
	     (LIST (QUOTE QUOTCH) (TRQ (CADR E)))))
   (MK/-TYQUOT
    ((LAMBDA (Y) (COND ((THEORYLD%F) (QEVAL Y)) (T Y)))
     (LIST (QUOTE TYQUOTCH) (TRQ (CADR E)))))
   (MK/-VAR
    ((LAMBDA(ACFN)
      (COND ((EQ ACFN ISOM) (QUOTE ISOMCLOSURE))
	    (ACFN)
	    ((PRIMVAL (CADR E)))))
     (ACCESS (CADR E))))
   (MK/-FAIL (QUOTE (ERR (QUOTE fail))))
   (MK/-FAILWITH (LIST (QUOTE ERR) (TRE (CADR E))))
   (MK/-EMPTY NIL)
   (MK/-DUPL
    (TESTEVAL (LIST (QUOTE CONS) (TRE (CADR E)) (TRE (CADDR E)))))
   (MK/-LIST
    (TESTEVAL (CONS (QUOTE LIST) (MAPCAR (FUNCTION TRE) (CDR E)))))
   (MK/-STRAINT (TRE (CADR E)))
   (MK/-APPN
    (COND
     ((EQ (CAADR E) (QUOTE MK/-VAR))
      ((LAMBDA(ACFN ARG)
	(COND ((EQ ACFN ISOM) ARG)
	      (ACFN (LIST (QUOTE AP) ACFN ARG))
	      ((FASTAP (CADADR E) ARG))
	      (T (LIST (QUOTE AP) (PRIMVAL (CADADR E)) ARG))))
       (ACCESS (CADADR E))
       (TRE (CADDR E))))
     (T (LIST (QUOTE AP) (TRE (CADR E)) (TRE (CADDR E))))))
   (MK/-BINOP
    (TRE
     (LIST (QUOTE MK/-APPN)
	   (LIST (QUOTE MK/-VAR) (CADR E))
	   (CONS (QUOTE MK/-DUPL) (CDDR E)))))
   (MK/-UNOP
    (TRE
     (CONS (QUOTE MK/-APPN)
	   (CONS (LIST (QUOTE MK/-VAR) (CADR E)) (CDDR E)))))
   (MK/-SEQ
    (LIST
     (QUOTE COND)
     (CONS
      (QUOTE T)
      (NCONC (MAPCAR (FUNCTION TRE) (CADR E))
	     (LIST (TRE (CADDR E)))))))
   (MK/-ASSIGN
    (LIST
     (LIST
      (QUOTE LAMBDA)
      (QUOTE (A))
      (LIST (QUOTE PROG2)
	    (STORST (VARPAT (CADR E)) %P (QUOTE A))
	    (QUOTE A)))
     (CHECKST (CADR E) (TRE (CADDR E)))))
   (MK/-TEST
    ((LAMBDA(%LOOP)
      ((LAMBDA(A)
	(COND (%LOOP (LIST (QUOTE PROG) NIL (CADR %LOOP) A)) (T A)))
       (TRARMS T (CDR E))))
     (GENLOOP (CDR E))))
   (MK/-TRAP
    ((LAMBDA(%LOOP)
      ((LAMBDA(E0 A)
	(COND
	 (%LOOP
	  (LIST (QUOTE PROG)
		(QUOTE (B))
		(CADR %LOOP)
		(LIST (QUOTE SETQ) (QUOTE B) E0)
		A))
	 (T (LIST (LIST (QUOTE LAMBDA) (QUOTE (B)) A) E0))))
       (LIST (QUOTE ERRSET) (TRE (CADR E)))
       (TRARMS NIL (CDDR E))))
     (GENLOOP (CDDR E))))
   (MK/-ABSTR
    (SUBST
     (CONDSHAREOB
      (QUOTE ML)
      (LIST
       (QUOTE LAMBDA)
       (QUOTE (%E))
       ((LAMBDA(CL BODY)
	 (COND ((NULL CL) BODY) (T (GENCHECK CL BODY))))
	(CHECKS (CADR E) (QUOTE (CAR %E)))
	(TREXP (CONS (VARPAT (CADR E)) %P) (CADDR E)))))
     (QUOTE X)
     (QUOTE (CONS (FUNCTION X) %E))))
   ((MK/-IN MK/-INA)
    (LIST
     (LIST (QUOTE LAMBDA)
	   (QUOTE (%E))
	   (TREXP (CONS (BVPAT (CADR E)) %P) (CADDR E)))
     (TRDECL (CADR E))))
   (MK/-IND (TRE (CADDR E)))
   (ERROR (CONS E (QUOTE (BAD ARG TRE))))))
EXPR)

(DEFPROP PRIMVAL
 (LAMBDA(I)
  (COND	((GET I (QUOTE NUMARGS)) (QEVAL (CLOSURE I)))
	(T (QEVAL (GET I (QUOTE MLVAL))))))
EXPR)

(DEFPROP CLOSURE
 (LAMBDA(I)
  (COND	((GET I (QUOTE CLOSURE)))
	((PUTPROP I (LISPFUNCLOSURE I) (QUOTE CLOSURE)))))
EXPR)

(DEFPROP LISPFUNCLOSURE
 (LAMBDA(I)
  ((LAMBDA(IN)
    (CONS (LIST	(QUOTE LAMBDA)
		(QUOTE (%E))
		(CONS (CAR IN) (LISPARGS (CDR IN) (QUOTE (CAR %E)))))
	  I))
   (GETPRED I)))
EXPR)

(DEFPROP LISPARGS
 (LAMBDA(N A)
  (COND	((ZEROP N) NIL)
	((EQUAL N 1) (LIST A))
	(T
	 (CONS (LIST (QUOTE CAR) A)
	       (LISPARGS (SUB1 N) (LIST (QUOTE CDR) A))))))
EXPR)

(DEFPROP AP
 (LAMBDA (FN ARG) ((CAR FN) (CONS ARG (CDR FN))))
EXPR)

(DEFPROP GETPRED
 (LAMBDA(I)
  ((LAMBDA (N) (COND ((NUMBERP N) (CONS I N)) (T N)))
   (GET I (QUOTE NUMARGS))))
EXPR)

(DEFPROP FASTAP
 (LAMBDA(I ARG)
  (COND
   ((GET I (QUOTE NUMARGS))
    ((LAMBDA (IN) (FAP (CDR IN) ARG (LIST (CAR IN)))) (GETPRED I)))))
EXPR)

(DEFPROP FAP
 (LAMBDA(N A R)
  (COND
   ((ZEROP N) R)
   ((EQUAL N 1) (NCONC R (LIST A)))
   ((NOT (ATOM A))
    (SELECTQ
     (CAR A)
     (CONS (FAP (SUB1 N) (CADDR A) (NCONC R (LIST (CADR A)))))
     (QUOTE
      (COND
       ((ATOM (CDR A)) (ERROR (QUOTE FAP)))
       ((FAP (SUB1 N)
	     (QEVAL (CDADR A))
	     (NCONC R (LIST (QEVAL (CAADR A))))))))
     NIL))))
EXPR)

(DEFPROP GENLOOP
 (LAMBDA (ARMS) (COND ((ISLOOP ARMS) (LIST (QUOTE GO) (GENSYM)))))
EXPR)

(DEFPROP ISLOOP
 (LAMBDA(ARMS)
  (MAPOR (FUNCTION (LAMBDA (A) (EQ (CAR A) (QUOTE ITER))))
	 (NCONC	(COND
		 ((CDR ARMS)
		  (LIST
		   (COND ((ATOM (CAADR ARMS)) (CADR ARMS))
			 (T (CAADR ARMS))))))
		(CAR ARMS))))
EXPR)

(DEFPROP TRARMS
 (LAMBDA(%TEST ARMS)
  (NCONC (COND (%TEST (LIST (QUOTE COND)))
	       (T
		(LIST (QUOTE COND)
		      (LIST (QUOTE (NOT (ATOM B)))
			    (QRETURN (QUOTE (CAR B)))))))
	 (MAPCAR
	  (FUNCTION
	   (LAMBDA(A)
	    (CONS (COND (%TEST (TRE (CADR A))) (T (TRTRAP (CADR A))))
		  (TESTTRAP (CAR A) (TRE (CDDR A))))))
	  (CAR ARMS))
	 (COND ((CDR ARMS) (LIST (TRLAST (CADR ARMS))))
	       ((NOT %TEST) (LIST (QUOTE ((ERR B))))))))
EXPR)

(DEFPROP TRTRAP
 (LAMBDA(E)
  (COND	((AND (EQ (CAR E) (QUOTE MK/-LIST)) (EQ (LENGTH (CDR E)) 1))
	 (LIST (QUOTE EQ) (QUOTE B) (TRE (CADR E))))
	(T (LIST (QUOTE MEMQ) (QUOTE B) (TRE E)))))
EXPR)

(DEFPROP TESTTRAP
 (LAMBDA(SORT ANS)
  (SELECTQ SORT
	   (ONCE (LIST (QRETURN ANS)))
	   (ITER (LIST ANS %LOOP))
	   (ERROR (CONS SORT (QUOTE (BAD SORT IN TESTTRAP))))))
EXPR)

(DEFPROP QRETURN
 (LAMBDA (ANS) (COND (%LOOP (LIST (QUOTE RETURN) ANS)) (T ANS)))
EXPR)

(DEFPROP TRLAST
 (LAMBDA(A)
  ((LAMBDA (Z) (COND ((EQ (LENGTH Z) 1) Z) ((CONS (QUOTE T) Z))))
   (COND ((ATOM (CAR A)) (TESTTRAP (CAR A) (TRE (CDR A))))
	 ((TESTTRAP
	   (CAAR A)
	   (LIST (LIST (QUOTE LAMBDA)
		       (QUOTE (%E))
		       (TREXP (CONS (CDAR A) %P) (CDR A)))
		 (QUOTE (CONS B %E))))))))
EXPR)

(DEFPROP TESTEVAL
 (LAMBDA (E) (COND ((ISCONST E) (QEVAL (EVAL E))) (T E)))
EXPR)

(DEFPROP ISCONST
 (LAMBDA(E)
  (COND	((ATOM E) (OR (NUMBERP E) (MEMQ E (QUOTE (T NIL)))))
	(T
	 (SELECTQ (CAR E)
		  (QUOTE T)
		  ((CONS LIST) (MAPAND (FUNCTION ISCONST) (CDR E)))
		  NIL))))
EXPR)

(DEFPROP TRB
 (LAMBDA(B)
  (SELECTQ
   (CAR B)
   ((MK/-ABSTYPE MK/-ABSRECTYPE) (TRABSTYB (CADR B) (CADDR B)))
   ((LAMBDA(RHS)
     (SELECTQ (CAR B) (MK/-LETREF (COPYST (BVPAT B) RHS)) RHS))
    (CHECKST (CADR B) (TRE (CADDR B))))))
EXPR)

(DEFPROP TRABSTYB
 (LAMBDA(EQNL D)
  (CHECKST (CADR D)
	   (LIST (LIST (QUOTE LAMBDA)
		       (QUOTE (%E))
		       (TREXP (CONS (ISOMPAT EQNL) %P) (CADDR D)))
		 (QUOTE (CONS DUMMY %E)))))
EXPR)

(DEFPROP ISOMPAT
 (LAMBDA(EQNL)
  (CONS	ISOM
	(NCONC (MAPCAR (FUNCTION
			(LAMBDA (EQN) (JUXT (QUOTE abs) (CAR EQN))))
		       EQNL)
	       (MAPCAR (FUNCTION
			(LAMBDA (EQN) (JUXT (QUOTE rep) (CAR EQN))))
		       EQNL))))
EXPR)

(DEFPROP GENCHECK
 (LAMBDA(CL ANS)
  (LIST	(QUOTE COND)
	(LIST (COND ((EQ (LENGTH CL) 1) (CAR CL))
		    (T (CONS (QUOTE AND) CL)))
	      ANS)
	(QUOTE ((ERR (QUOTE varstruct))))))
EXPR)

(DEFPROP CHECKST
 (LAMBDA(S ANS)
  ((LAMBDA(CL)
    (COND ((NULL CL) ANS)
	  (T
	   (LIST (LIST (QUOTE LAMBDA)
		       (QUOTE (A))
		       (GENCHECK CL (QUOTE A)))
		 ANS))))
   (CHECKS S (QUOTE A))))
EXPR)

(DEFPROP CHECKS
 (LAMBDA(S ARG)
  (SELECTQ (CAR S)
	   ((MK/-EMPTY MK/-VAR) NIL)
	   (MK/-STRAINT (CHECKS (CADR S) ARG))
	   (MK/-DUPL (CHECKS2 (CDR S) ARG))
	   (MK/-BINOP (CONS ARG (CHECKS2 (CDDR S) ARG)))
	   (MK/-LIST
	    (CONS (LIST	(QUOTE EQ)
			(LIST (QUOTE LENGTH) ARG)
			(LENGTH (CDR S)))
		  (CHECKSL (CDR S) ARG)))
	   (ERROR (CONS S (QUOTE (BAD VARSTRUCT))))))
EXPR)

(DEFPROP CHECKS2
 (LAMBDA(S2 ARG)
  (NCONC (CHECKS (CAR S2) (LIST (QUOTE CAR) ARG))
	 (CHECKS (CADR S2) (LIST (QUOTE CDR) ARG))))
EXPR)

(DEFPROP CHECKSL
 (LAMBDA(SL ARG)
  (COND	((NULL SL) NIL)
	(T
	 (NCONC	(CHECKS (CAR SL) (LIST (QUOTE CAR) ARG))
		(CHECKSL (CDR SL) (LIST (QUOTE CDR) ARG))))))
EXPR)

(DEFPROP TRDECL
 (LAMBDA(D)
  (SELECTQ
   (CAR D)
   ((MK/-LET MK/-LETREF MK/-ABSTYPE MK/-ABSRECTYPE)
    (LIST (QUOTE CONS) (TRB D) (QUOTE %E)))
   (MK/-LETREC
    (LIST (LIST	(QUOTE LAMBDA)
		(QUOTE (%E))
		(LIST (QUOTE RPLACA)
		      (QUOTE %E)
		      (TREXP (CONS (VARPAT (CADR D)) %P) (CADDR D))))
	  (QUOTE (CONS NIL %E))))
   (ERROR (CONS D (QUOTE (BAD DECL))))))
EXPR)

(DEFPROP TRAN
 (LAMBDA(%PT)
  (COND	((DEFTYPT) NIL)
	((DECPT) (TTDECL %%P %PT))
	(T (TREXP %%P %PT))))
EXPR)

(DEFPROP TTDECL
 (LAMBDA(%P PT)
  (SELECTQ (CAR PT)
	   ((MK/-LET MK/-LETREF MK/-ABSTYPE MK/-ABSRECTYPE) (TRB PT))
	   (MK/-LETREC (LIST (QUOTE CAR) (TRDECL PT)))
	   (ERROR (QUOTE TTDECL))))
EXPR)

(DEFPROP TRQ
 (LAMBDA (E) (PROG2 (RPLACAQ E) E))
EXPR)

(DEFPROP RPLACAQ
 (LAMBDA(E)
  (SELECTQ (CAR E)
	   (mk=antiquot (RPLACA (CDR E) (TRE (CADR E))))
	   ((mk=nulltype mk=consttype
			 mk=vartype
			 mk=empty
			 mk=tok
			 mk=truth))
	   ((mk=funtype mk=sumtype
			mk=prodtype
			mk=typed
			mk=comb
			mk=pair
			mk=cond
			mk=abs
			mk=imp
			mk=conj
			mk=equiv
			mk=inequiv
			mk=quant)
	    (MAPC (FUNCTION RPLACAQ) (CDR E)))
	   (ERROR (CONS E (QUOTE (BAD ARG TRQ))))))
EXPR)
