COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00009 ENDMK
C⊗;


(DEFPROP COMPFCNS
 (NIL COMPL
      COMP
      PRUP
      MKPUSH
      COMPEXP
      COMPLIS
      LOADAC
      COMCOND
      COMBOOL
      COMPANDOR)
VALUE)

(DEFPROP COMPL
 (LAMBDA(FILE)
  (PROG	(Z)
	(EVAL
	 (CONS (QUOTE OUTPUT)
	       (CONS (QUOTE DSK:)
		     (LIST (CONS (CAR FILE) (QUOTE LAP))))))
	(EVAL (CONS (QUOTE INPUT) (CONS (QUOTE DSK:) FILE)))
	(INC  T  NIL)
	(OUTC T NIL)
   LOOP	(SETQ Z (ERRSET (READ)))
	(COND ((ATOM Z) (GO DONE)) ( T   NIL ))
	(SETQ Z (CAR Z))
	(COND ((EQ (CAR Z) (QUOTE DE))
	       (PROG (PROG)
		     (SETQ PROG (COMP (CADR Z) (CADDR Z) (CADDDR Z)))
		     (MAPC (FUNCTION PRINT) PROG)
		     (OUTC NIL NIL)
		     (PRINT (LIST (CADR Z) (LENGTH PROG)))
		     (OUTC T NIL)))
	      (T (PRINT Z)))
	(GO LOOP)
   DONE	(OUTC NIL T)
	(INC NIL T)
	(RETURN (QUOTE ENDCOMP))))
FEXPR)

(DEFPROP COMP
 (LAMBDA(FN VARS EXP)
  ((LAMBDA(N)
    (APPEND (LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
	    (MKPUSH N 1)
	    (COMPEXP EXP (MINUS N) (PRUP VARS 1))
	    (LIST
	     (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE C) N 0 N 0)))
	    (QUOTE ((POPJ P) NIL))))
   (LENGTH VARS)))
EXPR)

(DEFPROP PRUP
 (LAMBDA(VARS N)
  (COND	((NULL VARS) NIL)
	(T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (PLUS N 1))))))
EXPR)

(DEFPROP MKPUSH
 (LAMBDA(N M)
  (COND	((LESSP N M) NIL)
	(T
	 (CONS (LIST (QUOTE PUSH) (QUOTE P) M)
	       (MKPUSH N (PLUS M 1))))))
EXPR)

(DEFPROP COMPEXP
 (LAMBDA(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((EQ EXP  T ) (QUOTE ((MOVEI 1 (QUOTE T)))))
	((ATOM EXP)
	 (LIST
	  (LIST	(QUOTE MOVE)
		1
		(PLUS M (CDR (ASSOC EXP VPR)))
		(QUOTE P))))
	((OR (EQ (CAR EXP) (QUOTE AND))
	     (EQ (CAR EXP) (QUOTE OR))
	     (EQ (CAR EXP) (QUOTE NOT)))
	 ((LAMBDA(L1 L2)
	   (APPEND
	    (COMBOOL EXP M L1 NIL VPR)
	    (LIST (QUOTE (MOVEI 1 (QUOTE T)))
		  (LIST (QUOTE JRST) 0 L2)
		  L1
		  (QUOTE (MOVEI 1 0))
		  L2)))
	  (GENSYM)
	  (GENSYM)))
	((EQ (CAR EXP) (QUOTE COND))
	 (COMCOND (CDR EXP) M (GENSYM) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE))
	 (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 ((LAMBDA(N)
	   (APPEND
	    (COMPLIS (CDR EXP) M VPR)
	    (LOADAC (DIFFERENCE 1 N) 1)
	    (LIST
	     (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE C) N 0 N 0)))
	    (LIST
	     (LIST (QUOTE CALL)
		   N
		   (LIST (QUOTE E) (CAR EXP))
		   (QUOTE S)))))
	  (LENGTH (CDR EXP))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (APPEND
	    (COMPLIS (CDR EXP) M VPR)
	    (COMPEXP
	     (CADDAR EXP)
	     (DIFFERENCE M N)
	     (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
	    (LIST
	     (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE C) N 0 N 0)))))
	  (LENGTH (CDR EXP))))
	( T   NIL )))
EXPR)

(DEFPROP COMPLIS
 (LAMBDA(U M VPR)
  (COND	((NULL U) NIL)
	(T
	 (APPEND (COMPEXP (CAR U) M VPR)
		 (QUOTE ((PUSH P 1)))
		 (COMPLIS (CDR U) (DIFFERENCE M 1) VPR)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(N K)
  (COND	((GREATERP N 0) NIL)
	(T
	 (CONS (LIST (QUOTE MOVE) K N (QUOTE P))
	       (LOADAC (PLUS N 1) (PLUS K 1))))))
EXPR)

(DEFPROP COMCOND
 (LAMBDA(U M L VPR)
  (COND	((NULL U) (LIST L))
	(T
	 ((LAMBDA(L1)
	   (APPEND (COMBOOL (CAAR U) M L1 NIL VPR)
		   (COMPEXP (CADAR U) M VPR)
		   (LIST (LIST (QUOTE JRST) L) L1)
		   (COMCOND (CDR U) M L VPR)))
	  (GENSYM)))))
EXPR)

(DEFPROP COMBOOL
 (LAMBDA(P M L FLG VPR)
  (COND	((ATOM P)
	 (APPEND
	  (COMPEXP P M VPR)
	  (LIST
	   (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T
		((LAMBDA(L1)
		  (APPEND (COMPANDOR (CDR P) M L1 NIL VPR)
			  (LIST (LIST (QUOTE JRST) 0 L))
			  (LIST L1)))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T
		((LAMBDA(L1)
		  (APPEND (COMPANDOR (CDR P) M L1 T VPR)
			  (LIST (LIST (QUOTE JRST) 0 L))
			  (LIST L1)))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE NOT))
	 (COMBOOL (CADR P) M L (NOT FLG) VPR))
	(T
	 (APPEND
	  (COMPEXP P M VPR)
	  (LIST
	   (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		 1
		 L))))))
EXPR)

(DEFPROP COMPANDOR
 (LAMBDA(U M L FLG VPR)
  (COND	((NULL U) NIL)
	(T
	 (APPEND (COMBOOL (CAR U) M L FLG VPR)
		 (COMPANDOR (CDR U) M L FLG VPR)))))
EXPR)