

(DEFPROP RCONS
 (LAMBDA (X R) (RCONS2 X (RCONS1 R)))
EXPR)

(DEFPROP RCONS1
 (LAMBDA(R)
  (COND	((ATOM R) (ERROR (QUOTE "BAD TOP/-LEVEL ENV")))
	((FULL (CAR R) (CAR R)) (CONS (CONS SECRET (CAR R)) (CDR R)))
	(T R)))
EXPR)

(DEFPROP FULL
 (LAMBDA(Y Z)
  (COND	((OR (ATOM Y) (ATOM Z)) (NOT (EQ Y SECRET)))
	((FULL (CAR Y) (CDR Z)))))
EXPR)

(DEFPROP RCONS2
 (LAMBDA(X R)
  (PROG	(Y YD Z ZD)
	(SETQ Y (SETQ YD (CAR R)))
   L	(COND ((ATOM YD) (GO M)))
	(COND ((EQ (CAR Y) SECRET)
	       (SETQ Z Y)
	       (SETQ ZD YD)
	       (SETQ Y (CDR Y)))
	      (T (SETQ Y (CAR Y))))
	(SETQ YD (CDR YD))
	(GO L)
   M	(SETQ ZD (CDR ZD))
	(COND ((ATOM ZD) (RPLACA Z X) (RETURN R)))
	(SETQ X (CONS SECRET X))
	(GO M)))
EXPR)

(DEFPROP DECPT
 (LAMBDA NIL
  (MEMQ	(CAR %PT)
	(QUOTE
	 (MK/-LET MK/-LETREF MK/-LETREC MK/-ABSTYPE MK/-ABSRECTYPE))))
EXPR)

(DEFPROP DEFTYPT
 (LAMBDA NIL (EQ (CAR %PT) (QUOTE MK/-DEFTYPE)))
EXPR)

(DEFPROP MLEVAL
 (LAMBDA(%PR)
  (PROG	(V)
	(SETQ V ((LAMBDA (%E) (EVAL %PR)) %%E))
	(UPDATETYPES)
	(COND ((DEFTYPT))
	      ((DECPT) (SETQ V (CONS (BVPAT %PT) V))
		       (SETQ %%P (RCONS (CAR V) %%P))
		       (SETQ %%E (RCONS (CDR V) %%E)))
	      (T (PUTPROP LASTVALNAME V (QUOTE MLVAL))
		 (PUTPROP LASTVALNAME %TY (QUOTE MLTYPE))))
	(RETURN V)))
EXPR)

(DEFPROP TML
 (LAMBDA NIL
  (PROG	(B)
	(INITFN
	 (FUNCTION (LAMBDA NIL (PROG2 (PROMPT 52) (INITFN NIL)))))
	(PROMPT 43)
	(SETQ B (ERRSET (TMLLOOPBODY)))
	(PROMPT 52)
	(INITFN NIL)
	(ERR B)))
EXPR)

(DEFPROP TMLTILLEOF
 (LAMBDA NIL (OR (EQ (ERRSET (TMLLOOP)) (QUOTE $EOF$)) (ERR %F)))
EXPR)

(DEFPROP TMLLOOP
 (LAMBDA NIL (PROG (%PT %TY %PR %VAL) (TMLLOOPBODY)))
EXPR)

(DEFPROP TMLLOOPBODY
 (LAMBDA NIL
  (PROG	(IBASE BASE *NOPOINT)
	(SETQ IBASE 12)
	(SETQ BASE 12)
	(SETQ *NOPOINT T)
   L	(AND PRFLAG (TOP%F) (TERPRI))
	(AND (TOP1 (FUNCTION PARSEML)) (TOP%F) (PRML1))
	(GO L)))
EXPR)

(DEFPROP TOP%F
 (LAMBDA NIL (MEMQ %F (QUOTE (NIL mlin))))
EXPR)

(DEFPROP THEORYLD%F
 (LAMBDA NIL (MEMQ %F (QUOTE (newparent draftin))))
EXPR)

(DEFPROP READQUOT
 (LAMBDA NIL
  (PROG	(%PT %TY %PR %VAL)
	(COND ((NOT (EQ (READCH) (QUOTE /")))
	       (ERROR (QUOTE READQUOT)))
	      ((TOP1 (FUNCTION PARSEQUOT)) (RETURN (CONS %VAL %TY)))
	      ((ERR (QUOTE READOL))))))
EXPR)

(DEFPROP PARSEQUOT
 (LAMBDA (N) (LIST (QUOTE MK/-QUOT) (PARSEOL N)))
EXPR)

(DEFPROP PRML1
 (LAMBDA NIL
  (COND	((NULL PRFLAG) (PRINC (QUOTE /.)))
	((DEFTYPT))
	((DECPT) (PRLET (CAR %VAL) (CDR %VAL) %TY))
	(T (PRVALTY %VAL %TY))))
EXPR)

(DEFPROP TOP1
 (LAMBDA(PARSEFN)
  (PROG2 (INITLEAN)
	 (AND ((LAMBDA(B)
		(COND ((NOT (ATOM B)))
		      ((EQ B CTRLDSYM) NIL)
		      ((ERR B))))
	       (ERRSET (GNT)))
	      (ERRTRAP (QUOTE %PT) PARSEFN 0)
	      (OR (NOT (ISTMLOP %PT))
		  (PROG2 (ERRTRAP (QUOTE %VAL) (FUNCTION EVTMLOP) %PT)
			 NIL))
	      (OR (THEORYLD%F)
		  (ERRTRAP (QUOTE %TY) (FUNCTION TYPECHECK) %PT))
	      (ERRTRAP (QUOTE %PR) (FUNCTION TRAN) %PT)
	      (ERRTRAP (QUOTE %VAL) (FUNCTION MLEVAL) %PR))))
EXPR)

(DEFPROP ERRTRAP
 (LAMBDA(ID %FN %ARG)
  (PROG	(B)
	(SETQ B (ERRSET (APPLY %FN (LIST %ARG))))
	(COND ((NOT (ATOM B)) (SET ID (CAR B)) (RETURN T))
	      ((AND (EQ ID (QUOTE %PT)) (EQ B CTRLDSYM)) (RETURN NIL))
	      ((THEORYLD%F) (ERR (SELECTQ B ($EOF$ B) %F)))
	      ((EQ %F (QUOTE mlin))
	       (AND (EQ B (QUOTE mlin)) (ERR B))))
	(PRINC
	 (ASSOC1 ID
		 (QUOTE
		  ((%PT . PARSE) (%TY . TYPECHECK)
				 (%PR . TRANSLATION)
				 (%VAL . EVALUATION)))))
	(PRINX (QUOTE / FAILED/ ) (AND B (PRINC B)))
	(AND (EQ %F (QUOTE mlin))
	     (ERR (PRINC (QUOTE / DURING/ mlin/ ))))
	(TERPRI)))
EXPR)

(DEFPROP ISTMLOP
 (LAMBDA (%PT) (GET (CAR %PT) (QUOTE TMLOP)))
EXPR)

(DEFPROP EVTMLOP
 (LAMBDA(%PT)
  (SELECTQ
   (CAR %PT)
   (MK/-BEGIN
    (begin (COND ((NULL (CDR %PT)) (QUOTE %NONAME)) ((CADR %PT)))))
   (MK/-END
    (end
     (COND ((NULL (CDR %PT))
	    (COND (%DUMP (CDAR %DUMP)) ((ERR (QUOTE end)))))
	   ((ASSOC1 (CADR %PT) %DUMP))
	   ((ERR (JUXT (QUOTE end/ ) (CADR %PT)))))))
   (ERROR (CONS (CAR %PT) (QUOTE (NOT A TMLOP))))))
EXPR)

(DEFPROP begin
 (LAMBDA(TOK)
  (PROG	NIL
	(PUSHQ (LIST TOK %SECTIONS %%P %%E %EMT %TEMT %DUMP) %DUMP)
	(SETQ %SECTIONS T)
	(SETQ %%P (CONS INITSECTION %%P))
	(SETQ %%E (CONS INITSECTION %%E))))
EXPR)

(DEFPROP end
 (LAMBDA(SEC)
  (PROG	(TENV)
	(SETQ TENV (CAR (CDDDDR SEC)))
	(COND
	 ((ATOM
	   (ERRSET (ABSSCOPECHK (GET LASTVALNAME (QUOTE MLTYPE)))))
	  (ERR (QUOTE end))))
	(SETQ %SECTIONS (CAR SEC))
	(SETQ %%P (CADR SEC))
	(SETQ %%E (CADDR SEC))
	(SETQ %EMT (CADDDR SEC))
	(SETQ %TEMT (CAR (CDDDDR SEC)))
	(SETQ %DUMP (CADR (CDDDDR SEC)))))
EXPR)
