(DECLARE (SETQ NO-DISK-HACKS T))
(DECLARE (REQUIRE UTIL 1 DSK (AID RPG)))
(DECLARE (READ))
(REQUIRE UTIL 1 DSK (AID RPG))

;;;Print out syntax for call to LCOMn

(DEFUN HELP-LCOM NIL 
       (PROG NIL 
	     (TERPRI)
	     (PRINC
	      '
|(COMPL FOO LSP) compiles the DEFUN's in the file FOO.LSP |)
	     (TERPRI)
	     (PRINC '|    and writes the code on FOO.LAP |)
	     (TERPRI)
	     'END-HELP))
 

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

(DEFPROP COMPL
 (LAMBDA(FILE)
  (UWRITE)
  (APPLY (QUOTE EREAD) FILE)
  (SELECT-DISK-INPUT
   (READ-UNTIL-EOF
    WITH
    Z
    DO
    (COND ((OR (EQ (CAR Z) (QUOTE DEFUN)) (AND (EQ (CAR Z) (QUOTE DEFPROP)) (EQ (CADDDR Z) (QUOTE EXPR))))
	   (PROG (PROG)
		 (SETQ PROG
		       (COND ((EQ (CAR Z) (QUOTE DEFUN)) (COMP (CADR Z) (CADDR Z) (CADDDR Z)))
			     (T (COMP (CADR Z) (CADR (CADDR Z)) (CADDR (CADDR Z))))))
		 (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION PRINT) PROG)))
		 (PRINT (LIST (CADR Z) (LENGTH PROG)))))
	  (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
   (APPLY (QUOTE UFILE) (LIST (CAR FILE) (QUOTE LAP)))
   (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 %) 0 0 N N)))
	    (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) (ADD1 N))))))
EXPR)

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

(DEFPROP COMPEXP
 (LAMBDA(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((EQ EXP T) (QUOTE ((MOVEI 1 (QUOTE T)))))
	((NUMBERP EXP) (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((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 %) 0 0 N N)))
		   (LIST (LIST (QUOTE CALL) N (LIST (QUOTE QUOTE) (CAR EXP))))))
	  (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 %) 0 0 N N)))))
	  (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) (SUB1 M) VPR)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(N K)
  (COND ((GREATERP N 0) NIL) (T (CONS (LIST (QUOTE MOVE) K N (QUOTE P)) (LOADAC (ADD1 N) (ADD1 K))))))
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) 0 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)