;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10; Fonts:(CPTFONT CPTFONTB HL12BI); Patch-file:() -*-

2;;; *      2Explorer compiler changes for running Scheme*
;;;
;;; The changes made to existing functions for Scheme are in boldface.

;;; Copyright (C) 1989, Texas Instruments Incorporated. All rights reserved.

;;  3/22/88 DNG - Fix to not propagate a local variable whose initial value is 
;;		a global Scheme variable.
;;  4/13/88 DNG - Moved EXPORT to file PCS.
;;  8/11/88 DNG - Add warning for incompatibility with Explorer release 6.
;;  4/22/89 DNG - New file "OLD-COMPILER" separated from "COMPILER".

(let ((version (si:get-system-version :compiler)))
  (cond ((and version (< version 6))
	 (load (send fdefine-file-pathname :new-pathname
		     :name "OLD-COMPILER" :canonical-type (local-binary-file-type)
		     :version :newest))
	 (when (< version 5)
	   ;; temporary patch for SPR 6159 - fasdumping package objects
	   (load (send fdefine-file-pathname :new-pathname
		     :name "FIX-6159" :canonical-type (local-binary-file-type)
		     :version :newest))
	   ))
	;; Temporary check for internal pre-release 6 bands:
	((and (eql version 6)
	      (string-lessp sys:*system-name* "REL6H"))
	 (error "The Scheme compiler doesn't work on release 6 yet; it needs REL6H or later."))
	))


1(DEFUN (:PROPERTY SI:WITH-SCHEME-SEMANTICS P1) (FORM)
  (LET ((COMPILING-COMMON-LISP ':SCHEME)) ; so COMPILING-SCHEME-P will return true
    (CONS 'PROGN (P1PROGN-1 (CDR FORM)))))*


;; The following three variables are in the Compiler package because they are 
;; referenced by COMPILER:P1 before the Scheme package is created.
1(defparameter compiler:SCHEME-T 'scheme:T)
(defparameter compiler:SCHEME-NIL 'scheme:NIL)
(DEFVAR PCS-INTEGRATE-T-AND-NIL T
  "When true, T and NIL are considered constants instead of variables.")*



(comment ; not finished testing this yet

;;   1        2           3       4     5      6        7       8...
;; (LET   lambda-list outer-vars vars bindp e-lex-cnt lex-cnt . body)
(DEFUN LET-OPT (FORM &OPTIONAL DELETE-ALL)
 ;; 1/25/85 DNG - Call DISCARD on initial value of deleted variable.
 ;; 2/27/85 DNG - Fix for duplicated variable names.
 ;; 3/04/85 DNG - Move check for special variables referenced by the
 ;;               microcode from here to VARS-USED.
 ;; 1/09/86 DNG - Fix handling of doubly-defined variables. [SPR 1518]
 ;; 1/20/86 DNG - Another fix for handling of doubly-defined variables.
 ;; 9/16/86 DNG - Permit deleting variable initialized to (UNDEFINED-VALUE).
 ;; 9/25/86 DNG - Optimize out some variables which are used only once.
 ;;10/02/86 DNG - Don't call DISCARD on a value deleted by PROPAGATE-VALUES.
 ;;10/14/86 DNG - Optimize binding of *STANDARD-OUTPUT* around print functions.
 ;;10/18/86 DNG - Handle more cases of variables used once.
 ;;10/21/86 DNG - Fix for variable used once that depends on special variable bindings.
 ;; 7/02/87 DNG - When substituting the initial value of a variable into its
 ;;		only use in the first body form, check first that it is independent
 ;;		of the value forms of any following bindings.  [SPR 5926]
 ;;12/19/87 DNG - Permit discarding LET with empty binding list even if it 
 ;;		does contain lexical closures.
  (DECLARE (SPECIAL PROPAGATE-ENABLE))
  (UNLESS PROPAGATE-ENABLE
    (RETURN-FROM LET-OPT FORM))
  (LET ((VARS (FOURTH FORM))
	(VLIST (SECOND FORM))
	(CHANGED NIL)
	V
	USED
	(BODY (NTHCDR 7 FORM))
	(NNEWVARS 0)
	(NEW-PROPAGATE 0))
    (DO ((VS VARS)
	 (VL VLIST (CDR VL)))
	((NULL VL))
      (LOOP DO (SETQ V (FIRST VS)
		     VS (REST VS)
		     NNEWVARS (1+ NNEWVARS))
	    UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)))
    (FLET ((USES-SPECIAL-BINDINGS-P (V OLD-VARS)
	     ;; Does the initial value of this variable use any special variables
	     ;; which are bound in this same LET?
	     (VARS-USED (SECOND (VAR-INIT V))
			(LET ((SPECIALS NIL))
			  (DO ((VS VARS (CDR VS)))
			      ((EQ VS OLD-VARS))
			    (WHEN (EQ (VAR-TYPE (CAR VS)) 'FEF-SPECIAL)
			      (PUSH (VAR-LAP-ADDRESS (CAR VS))
				    SPECIALS)))
			  SPECIALS)) ))
    ;; delete unused variables from the lambda list
    (SETQ VLIST
      (LOOP
	FOR VLIST-TAIL ON VLIST
	FOR VAR = (FIRST VLIST-TAIL) ; each variable in lambda list
	DO
	(LOOP DO (SETQ V (NTH (SETQ NNEWVARS (1- NNEWVARS)) VARS))
	      UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)
	      FINALLY (UNLESS (EQ (VAR-NAME V)
				  (IF (ATOM VAR) VAR (FIRST VAR)))
			(WARN 'LET-OPT :BUG "Bug in ~S on ~S" 'LET-OPT VAR)
			(RETURN-FROM LET-OPT FORM)))
	IF (OR (AND (OR (NULL (SETQ USED (VAR-USE-COUNT V)))   ; never referenced
			(ZEROP USED)	   ; value never used
			DELETE-ALL)	   ; called from DISCARD to throw all away
		    (MEMBER (VAR-KIND V)
			    '(FEF-ARG-INTERNAL-AUX FEF-ARG-FREE FEF-ARG-DELETED)
			    :TEST #'EQ)
		    (OR (EQ (VAR-TYPE V) 'FEF-LOCAL)
			DELETE-ALL
			(AND (OR (NEQ (FIRST FORM) 'LET*)
				 (NULL (REST VLIST-TAIL)))
			     (OR (NULL BODY)
				 (AND (NULL (REST BODY))
				      (OR 
					;; Check for references in the body form.
					(AND (< (OPT-SAFETY OPTIMIZE-SWITCH)
						(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
					     (NULL (VARS-USED (FIRST BODY)
							      (LIST (VAR-LAP-ADDRESS V)))))
					;; Can binding be replaced by an optional argument?
					(AND (EQ (VAR-NAME V) '*STANDARD-OUTPUT*)
					     (MEMBER (CAR-SAFE (FIRST BODY))
						     '( PRIN1 PRINT PPRINT PRINC
						       WRITE-CHAR WRITE-STRING WRITE-LINE
						       WRITE-BYTE))
					     (= (LENGTH (FIRST BODY)) 2)
					     (INDEPENDENT-EXPRESSIONS-P
					       (SECOND (FIRST BODY)) (SECOND (VAR-INIT V)))
					     (PROGN
					       ;; (LET ((*STANDARD-OUTPUT* x)) (PRINT a)) ==> (PRINT a x)
					       ;; [such forms are created by the FORMAT optimizer]
					       (SETF (CDDR (FIRST BODY))
						     (LIST (SECOND (VAR-INIT V))))
					       (SETF VAR NIL)
					       T))
					)))))
		    (OR (ATOM VAR)
			DELETE-ALL
			(NO-SIDE-EFFECTS-P (SECOND VAR))))
	       (AND (EQL USED 1)
		    (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
		    (<= (OPT-SAFETY OPTIMIZE-SWITCH)
			(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
		    (NULL (REST BODY))
		    (CONSP (FIRST BODY))
		    (NOT (QUOTES-ANY-ARGS (FIRST (FIRST BODY))))
		    (MEMBER (VAR-LAP-ADDRESS V) (FIRST BODY) :TEST #'EQ)
		    (NOT (USES-SPECIAL-BINDINGS-P V (THIRD FORM)))
		    (LET ((INIT (SECOND (VAR-INIT V))))
		      (AND (DOLIST (X (REST VLIST-TAIL) T)
			     (WHEN (AND (CONSP X)
					(NOT (INDEPENDENT-EXPRESSIONS-P INIT (SECOND X))))
			       (RETURN NIL)))
			   (DO ((ARGS (REST (FIRST BODY)) (REST ARGS)))
			       ((NULL ARGS) NIL)
			     (COND ((EQ (FIRST ARGS) (VAR-LAP-ADDRESS V))
				    ;; (LET ((x (foo a))) (bar x)) ==> (bar (foo a))
				    (SETF (FIRST ARGS) INIT)
				    (SETF VAR NIL)
				    (RETURN T))
				   ((INDEPENDENT-EXPRESSIONS-P INIT (FIRST ARGS)))
				   (T (RETURN NIL)))))))
	       )			   ; variable can be deleted
	DO (PROGN (DEBUG-ASSERT (OR (ATOM VAR)
				    (EQ (SECOND VAR) (SECOND (VAR-INIT V)))
				    (AND (EQUAL (SECOND VAR) '(UNDEFINED-VALUE))
					 (EQ (FIRST (VAR-INIT V)) 'FEF-INI-NONE))
				    (EQ (SECOND (VAR-INIT V)) 'DELETED-VALUE))
				NIL "init mismatch in LET-OPT for ~S" (VAR-NAME V))
		  ;; Now mark the variable deleted.
		  (SETF (VAR-KIND V) 'FEF-ARG-DELETED)
		  (UNLESS (OR (ATOM VAR)
			      (EQ (SECOND (VAR-INIT V)) 'DELETED-VALUE))
		    (DISCARD (SECOND VAR)))
		  (SETQ CHANGED T))
	ELSE COLLECT
	(PROGN
	  (WHEN (AND (EQL USED 1)
		     (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
		     (<= (OPT-SAFETY OPTIMIZE-SWITCH)
			 (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
		     (OR ;;(ZEROP ALTERED-VAR-SET) ; include this when have time to debug it.
		       (INDEPENDENT-EXPRESSIONS-P
			 (SECOND (VAR-INIT V))
			 (IF (AND (EQ (FIRST FORM) 'LET*)
				  (REST VLIST-TAIL))
			     FORM
			   (CONS 'VALUES BODY))))
		     (NOT (USES-SPECIAL-BINDINGS-P V (THIRD FORM))))
	    ;; Local variable used exactly once; try to replace the
	    ;; reference with the initial value expression.
	    (SETQ NEW-PROPAGATE
		  (LOGIOR NEW-PROPAGATE (CDDR (VAR-LAP-ADDRESS V)))))
	  VAR))))
    (IF (AND (NULL VLIST) ; empty lambda list
	     (NULL (FIFTH FORM))	   ;  no BIND
	     (OR (= (SIXTH FORM) (SEVENTH FORM))   ; no lexical closures
		 (COMPILING-FOR-V2))
	     )
      (CONS 'PROGN BODY)	; (LET () body) ==> (PROGN body)
      (PROGN
	(WHEN CHANGED; some variables deleted
	 ;; change the form instead of creating a new list so that
	 ;;  POST-OPTIMIZE won't waste time calling LET-OPT again.
	  (SETF (SECOND FORM) VLIST))
	(IF (AND (NULL (REST VLIST))
		 (CONSP (FIRST VLIST))
		 (NULL (REST BODY))
		 (EQ (VAR-LAP-ADDRESS (SETQ V (LOOKUP-VAR (FIRST (FIRST VLIST))
							  VARS)))
		     (FIRST BODY))
		 (NULL (FIFTH FORM))	   ; no BIND
		 (= (SIXTH FORM) (SEVENTH FORM))   ; no lexical closures
		 )
	    ;;  (let ((a x)) a) ==> x
	    (PROGN (SETF (VAR-KIND V) 'FEF-ARG-DELETED)
		   (SECOND (FIRST VLIST)))
	  (IF (NOT (ZEROP (LOGDIF NEW-PROPAGATE PROPAGATE-VAR-SET)))
	      (LET* ((PROPAGATE-VAR-SET NEW-PROPAGATE)
		     (DONT-PROPAGATE-INTO-LOOP NEW-PROPAGATE)
		     (NEW-FORM (PROPAGATE-VALUES FORM)))
		(IF (EQ NEW-FORM FORM)
		    (LET-OPT FORM) ; remove variables whose use counts have now become 0
		  NEW-FORM))
	    FORM))))))

(add-post-optimizer funcall more-funcall-opt)
(defun more-funcall-opt (form)
  ;; 12/19/87 DNG - Original.     %%% needs more thought %%%
  (let ((fn (second form)))
    (cond ((eq (car-safe fn) 'the-expr)
	   (let ((exp (expr-form fn)))
	     (if (eq (car-safe exp) 'lexical-closure)
		 (progn (setq used-var-set (logior used-var-set (expr-used fn)))
			(setq altered-var-set (logior altered-var-set (expr-altered fn)))
			(update-propagate-var-set)
			(list* (first form) exp (cddr form)))
	       form)))
	  (t form))))

 ) ; end comment