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

Ï2;;;Ï*	Ï2Compiler extensions for Scheme -- handlers, optimizers, and style checkers.

Ï1;;; Copyright (C) 1988 Texas Instruments Incorporated. All rights reserved.

;;  2/20/88 DNG - This file separated from the compiler patches file.
;;Ï*Ï*		Ï1Added optimization for Ï*memv.
Ï1;;  2/28/88 DNG - Fix bug with nested Ï*letrecÏ1.
;;  3/21/88 DNG - New implementation of Ï*fluid-letÏ1.  More unspecified value warnings.
;;  3/25/88 DNG - Add unspecified value warnings for window functions.
;;  3/30/88 DNG - Fix Ï*lambda-optÏ1 to not do wrong thing with a locally defined function.
;;  4/16/88 DNG - Update Ï*set!Ï1 handler for setting structure fields.  Moved 
;;Ï*		Ï1several compiler optimizers to here from files Ï*"scheme3"Ï1 and 
;;Ï*		"pcs"Ï1 so that they won't be included in the runtime-only system.
;;  4/27/88 DNG - Added warnings for using unspecified value from certain 
;;Ï*		case,Ï1 Ï*cond,Ï1 and Ï*doÏ1 forms.
;;  5/05/88 DNG - Fix bug in Ï*letrecÏ1 when initial value is a global variable.
;;  5/13/88 DNG - Don't optimize Ï*unbound?Ï1 with more than one argument.
;;  4/22/89 DNG - Moved Ï*ENSURE-VALUE-USEDÏ1 to file Ï*"OLD-COMPILER" Ï1since it is now included in release 6.Ï*

(defun scheme:Ï3compile-fileÏ* (input &optional output)
  "Compile and load a Scheme file."
  (let ((pathname (fs:merge-pathname-defaults input fs:load-pathname-defaults nil)))
    (when (null (send pathname :type))
      (setq pathname (send pathname :new-pathname :canonical-type :scheme)))
    (si:with-scheme-on
      (let ((*read-base* 10.) (*print-base* 10.))
	(lisp:compile-file pathname :output-file output :load t)
	))))

(defun scheme:Ï3compileÏ* (expression)
  "Compile an expression, returning an object suitable as an argument to EVAL."
  `(funcall ,(lisp:compile nil `(lambda ()
				  (si:with-scheme-semantics ,expression)))))

(defun (:property si:define-internal p1) (form)
  (if (TOP-LEVEL-DUMMY-FUNCTION-P *CURRENT-COMPILAND*)
      (P1 (si:define-opt form))
    (progn (warn 'si:define-internal :IMPOSSIBLE
			  "~S in invalid context."
			  `(scheme:define ,(second (second form)) . ,(cddr form)))
	   (P1SBIND (list (list (second (second form)) (third form)))
			     'fef-arg-internal-aux nil nil nil)
	   (P1 'si:unspecified))))

(add-optimizer si:define-internal si:define-opt)
(defun si:define-opt (form)
  (if (TOP-LEVEL-DUMMY-FUNCTION-P *CURRENT-COMPILAND*)
      (progn
	(when (QUOTEP (SECOND FORM))
	  (let ((symbol (second (second form))))
	    (when (and (symbolp symbol)
		       (member (CAR-SAFE (THIRD FORM))
			       '(FUNCTION scheme:lambda si:scheme-lambda-with-name) :test #'eq))
	      ;; Need to set this up as a call do FDEFINE because of the way FDEFINE is 
	      ;; handled specially by QC-FILE-COMMON, COMPILE-TOP-LEVEL-FORM, and NOTICE-FDEFINE .
	      (remprop symbol 'compiler:INTEGRABLE)
	      ;;(remprop symbol 'inline) ; no longer used by define-integrable
	      (return-from si:define-opt
		`(progn (fdefine ,(second form) ,(pre-optimize (third form) t) t)
			,(second form))))
	    (when (and QC-FILE-IN-PROGRESS
		       (NOT QC-FILE-LOAD-FLAG))
	      (COMPILATION-DEFINE symbol))))
	`(si:define-globally-for-scheme ,(second form) ,(third form)))
    form))

(add-post-optimizer scheme:Ï3equal?Ï* equal?-opt)
(defun equal?-opt (form)
  (if (/= (length form) 3)
      form
    (flet ((opf (expression)  
	     (let ((type (type-of-expression expression)))
	       (cond ((member type '(fixnum symbol character) :test #'eq)
		      'eq)
		     ((member type '(integer single-float double-float number string)
			      :test #'eq)
		      'equal)
		     (t nil))) ))
      (let ((op (or (opf (third form))
		    (opf (second form)))))
	(if op (cons op (rest form)) form) ))))
(fold-constant-arguments 'scheme:equal?)

(add-optimizer scheme:Ï3unbound?Ï* unbound-opt fboundp)
(defun unbound-opt (form)
  (if (= (length form) 2) ; defaulting to current environment
      (let ((var (second form)))
	(if (lookup-var var)
	    'nil ; lexical variables are always bound
	  `(not (fboundp ',var))))
    form))

(add-optimizer scheme:Ï3lambdaÏ* lambda-opt)
(defun lambda-opt (form) ; (LAMBDA (X) (FOO X)) => FOO
  ;;  4/22/89 DNG - Call PRE-OPTIMIZE so that if the body form is a macro, it will be expanded.
  (let (tm exp)
    (if (and (= (length form) 3)
	     (consp (third form))
	     (consp (setq exp (pre-optimize (third form) nil)))
	     (symbolp (setq tm (first exp)))
	     (equal (second form) (rest exp))
	     (not (getl tm '(post-optimizers opcode))))
	(if (compiling-scheme-p)
	    tm
	  `(function ,tm))
      form)))

(DEFUN (:PROPERTY SCHEME:Ï3SET!Ï* P1) (FORM)
   ;; 10/02/87 DNG - Original.
   ;; 11/16/87 DNG - Permit %CL-FUNCTION as a destination.
   ;; 11/21/87 DNG - Return the value assigned, to match what PC Scheme does.  
   ;;		Moved the warning about using the result to a separate style checker.
   ;; 12/02/87 DNG - Fixed to do macro expansion on the destination and avoid 
   ;;		trying to evaluate SETQ on FUNCTION.
   ;;  3/31/88 DNG - For (SET! v (LAMBDA ...)), use v as the name of the function.
   ;;  4/16/88 DNG - To enable setting structure fields, expand defsubst destinations.
   (LET ((NEW-FORM NIL)
	 (DESTINATION (SECOND FORM)))
      (WHEN (AND (CONSP DESTINATION) ; for TI Scheme, need to macroexpand it.
		 (SYMBOLP (FIRST DESTINATION)))
	(SETQ DESTINATION (PRE-OPTIMIZE DESTINATION NIL
					;; don't optimize but do expand defsubsts
					(GET (FIRST DESTINATION) 'OPTIMIZERS))))
      (COND ((SYMBOLP DESTINATION)
	      (SETQ NEW-FORM (CONS 'SETQ (P1SETQ-1 (LIST* DESTINATION
							  (SI:NAME-FUNCTION DESTINATION (THIRD FORM))
							  (CDDDR FORM)))))
	      (SETQ DESTINATION (SECOND NEW-FORM))
	      (WHEN (AND (CONSP DESTINATION) (EQ (FIRST DESTINATION) 'FUNCTION))
		 (COND ((AND (FBOUNDP (SECOND DESTINATION))
			       (EQ (SYMBOL-PACKAGE (SECOND DESTINATION)) *LISP-PACKAGE*))
			 (WARN 'SCHEME:SET! :PROBABLE-ERROR
			        "Attempting to SET! the global definition of ~S; you'll be sorry!"
				(SECOND DESTINATION))
			 (SETQ NEW-FORM
			        `(FDEFINE (QUOTE ,(SECOND DESTINATION)) ,(THIRD NEW-FORM) 'T)))
		        (T ;; (SETQ (FUNCTION f) x) ==> (SET! (FUNCTION f) x)  to not confuse evaluator
			   (SETQ NEW-FORM (CONS (CAR FORM) (CDR NEW-FORM)))))))
	     ((CONSP DESTINATION)
	       (CASE (FIRST DESTINATION)
		  ( SYMBOL-VALUE		; from expansion of FLUID macro
		   (SETQ NEW-FORM (P1 `(SET ,(SECOND DESTINATION) ,(THIRD FORM)))))
		  ((SCHEME:VECTOR-REF SYS:COMMON-LISP-AR-1)
		   (SETQ NEW-FORM (P1 `(SET-AR-1 ,(SECOND DESTINATION)
						     ,(THIRD DESTINATION)
						      ,(THIRD FORM)))))
		  ( FUNCTION ; from expansion of %CL-FUNCTION macro
		    (WHEN (VALIDATE-FUNCTION-SPEC (SECOND DESTINATION))
		       (SETQ NEW-FORM `(FDEFINE ',(SECOND DESTINATION) ,(P1V (THIRD FORM)) 'T))
		       (WHEN (EQUAL DESTINATION (THIRD NEW-FORM))
			  (SETQ NEW-FORM '(QUOTE NIL)))))
		  )))
      (WHEN (NULL NEW-FORM)
	 (WARN 'SCHEME:SET! :IMPOSSIBLE
	        "Invalid destination argument in ~S" FORM)
	 (SETQ NEW-FORM (P1 (THIRD FORM))))
      NEW-FORM))

(DEFPROP SCHEME:Ï3SET!Ï* P2SETQ P2)

(DEFUN CHECK-UNSPECIFIED (FORM)
  ;; Style checker for Scheme functions whose return value is documented as "unspecified".
  ;; 11/21/87 DNG - Original.
  ;; 12/29/87 DNG - Added handling for IF.
  ;;  4/27/88 DNG - Added handling for DO.
  (WHEN (AND P1VALUE ; value being used
	     (NOT (CONSP P1VALUE)) ; not being returned from the function
	     (NOT (EQ P1VALUE 'TOP-LEVEL-FORM)) ; not a top-level form
	     (NOT (AND (EQ (FIRST FORM) 'SCHEME:IF)
		       (CDDDR FORM))) ; IF is unspecified only if the alternate is not supplied.
	     (NOT (AND (EQ (FIRST FORM) 'SCHEME:DO)
		       (CDR (THIRD FORM))))
	     )
    (WARN 'CHECK-UNSPECIFIED ':IMPLAUSIBLE
	  "Trying to ~A the unspecified value of ~S."
	  (IF (EQ P1VALUE 'D-INDS) "test" "use") FORM)))

(ADD-STYLE-CHECKER SCHEME:SET!		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER SCHEME:SET-CAR!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER SCHEME:SET-CDR!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER SCHEME:STRING-SET!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER SCHEME:STRING-FILL!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER SCHEME:VECTOR-SET!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER SCHEME:VECTOR-FILL!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:close-output-port	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:close-input-port	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:write	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:display	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:newline	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:fresh-line	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:write-char	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:set-line-length!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:when	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:set-fluid!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:bkpt		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:assert	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:gc		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:flush-input	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:set-file-position!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:IF	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:DO	CHECK-UNSPECIFIED)Ï2 ; actually, this one Ï3isÏ* specified in PC SchemeÏ*
(ADD-STYLE-CHECKER scheme:substring-move-left!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:substring-move-right!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:DEFINE	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:FOR-EACH	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:MAPC		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:LOAD		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:TRANSCRIPT-ON	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:TRANSCRIPT-OFF CHECK-UNSPECIFIED)

(ADD-STYLE-CHECKER scheme:window-clear		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-delete		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-set-cursor!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-popup		CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-popup-delete	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-restore-contents CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-set-attribute!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-set-position!	CHECK-UNSPECIFIED)
(ADD-STYLE-CHECKER scheme:window-set-size!	CHECK-UNSPECIFIED)

(DEFUN CHECK-CASE (FORM)
  ;;  4/27/88 DNG - Original.
  (WHEN (AND P1VALUE				; value being used
	     (NOT (CONSP P1VALUE))		; not being returned from the function
	     (NOT (EQ P1VALUE 'TOP-LEVEL-FORM))	; not a top-level form
	     (DOLIST (CLAUSE (CDDR FORM) T)
	       (WHEN (OR (EQ (CAR CLAUSE) 'SCHEME:ELSE)
			 (AND (EQ (CAR FORM) 'SCHEME:COND)
			      (OR (EQ (CAR CLAUSE) 'LISP:T)
				  (EQ (CAR CLAUSE) 'SCHEME:T)
				  (AND (QUOTEP (CAR CLAUSE))
				       (SECOND (CAR CLAUSE)))
				  (AND (SYMBOLP (CAR CLAUSE))
				       (GET (CAR CLAUSE) 'INTEGRABLE)))))
		 (RETURN NIL))) )
    (LET (( SI:WARNINGS-PRINLEVEL 2 ))
      (WARN 'CHECK-UNSPECIFIED ':IMPLAUSIBLE
	    "Trying to ~A the unspecified value of a ~S without an ~A clause:~&~S"
	    (IF (EQ P1VALUE 'D-INDS) "test" "use") (CAR FORM) 'SCHEME:ELSE FORM))))
(ADD-STYLE-CHECKER SCHEME:CASE CHECK-CASE)
(ADD-STYLE-CHECKER SCHEME:COND CHECK-CASE)

(ADD-STYLE-CHECKER SCHEME:DELQ!	ENSURE-VALUE-USED)
(ADD-STYLE-CHECKER SCHEME:DELETE! ENSURE-VALUE-USED)
(ADD-STYLE-CHECKER SCHEME:REVERSE!  ENSURE-VALUE-USED)
(ADD-STYLE-CHECKER SCHEME:SORT!  ENSURE-VALUE-USED)

(add-optimizer scheme:Ï3putpropÏ* name-putprop)
(defun name-putprop (form)
  ;; 12/05/87 DNG - Original.
  (let ((value (third form)))
    (if (and (consp value)
	     (eq (first value) 'scheme:lambda)
	     (quotep (second form))
	     (quotep (fourth form)))
	;; Give the function a name for use by compiler warnings and the debugger.
	(list (first form) (second form)
	      (si:name-function `((:property ,(second (second form))
					     ,(second (fourth form))))
				value)
	      (fourth form))
      form)))


(add-optimizer scheme:Ï3letrecÏ* letrec-opt)
(defun letrec-opt (form)
  ;; 12/19/87 DNG - Original.
  (let ((bindings (second form))
	(body (si:undefinify (cddr form)))
	(vars nil)
	(labels nil))
    (dolist (binding bindings)
      (let ((var (first binding))
	    (val (second binding)))
	(cond ((constantp val)
	       (push binding vars))
	      (t (push (list var (list 'quote 'dummy)) vars)
		 (push (list nil var (si:name-function var val) (car vars))
		       labels)))))
    (setq vars (nreverse vars))
    (if labels
	`(LET* ,vars
	   (LETREC-INTERNAL ,(nreverse labels)
	       . ,body))
      `(LET* ,vars . ,body))))


(DEFUN (:PROPERTY LETREC-INTERNAL P1) (FORM)
  ;; 12/19/87 DNG - Original version adapted from (:PROPERTY %LABELS P1).
  ;;  1/29/88 DNG - Fix bug when initial value is a special variable.
  ;;  2/22/88 DNG - Fix to not permit PASS2 to set the copy-out flag for the 
  ;;		first LETREC variable.  This was a problem when the value expression was 
  ;;		a LET.
  ;;  5/05/88 DNG - Fix to not propagate initial values which are FUNCTION forms.
  (LET ((P1VALUE 'SINGLE-VALUE) ; wish this could be DOWNWARD-ONLY  %%
	)
    (DOLIST (ELT (SECOND FORM))			; for each local function being defined
      (LET* ((VALUE (THIRD ELT))		; the function object
	     (VAR (FIRST (FOURTH ELT)))		; name of local variable which holds the function
	     (V (LOOKUP-VAR VAR))
	     (INIT (SECOND (FOURTH ELT))))	; the dummy initial value to be replaced
	(SETQ VALUE (IF (EQ (CAR-SAFE VALUE) 'SI:SCHEME-LAMBDA-WITH-NAME)
			(LET ((DEFN (PRE-OPTIMIZE VALUE T)))
			  (WITH-STACK-LIST (X VAR V (SECOND DEFN))
			    ;; Bind LOCAL-FUNCTIONS to enable P1 to do tail recursion elimination.
			    (LET ((LOCAL-FUNCTIONS (CONS X LOCAL-FUNCTIONS)))
			      (P1 DEFN))))
		      (P1 VALUE)))
	(IF (ATOM VALUE)
	    (SETF (CAR INIT) 'PROGN
		  (CDR INIT) (LIST VALUE))
	  (SETF (CAR INIT) (CAR VALUE)
		(CDR INIT) (CDR VALUE)))
	;; Since the dummy initial value was a constant, the variable was marked
	;; eligible for value propagation.  However, that is not appropriate if
	;; the function is a closure.
	(UNLESS (MEMBER (CAR INIT) '(QUOTE BREAKOFF-FUNCTION) :TEST #'EQ)
	  (SETQ PROPAGATE-VAR-SET
		(LOGDIF PROPAGATE-VAR-SET
			(CDDR (VAR-LAP-ADDRESS V)))))
	;; Once the first lexical lexical closure has been created, the environment
	;; has been constructed and we can't add any more copied-out values to it.
	;; And even if this is the first closure, we can never use copied-out values
	;; for LETREC variables because they are assigned their values after the closure
	;; is made.
	(DO ((VS (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*) (CDR VS)))
	    ((NULL VS))
	  (WHEN (EQ (VAR-NAME (CAR VS)) VAR)
	    (SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*)
		  (CDR VS))
	    (RETURN)))
	)))
  (P1PROGN (CONS 'LOCALLY (CDDR FORM))))

(defun (:property scheme:Ï3fluid-letÏ* p1) (form)
  ;;  3/21/88 DNG - Original (previously a macro).
  (let* ((bindings (second form))
	 (body (cddr form))
	 (names (sys::binding-names bindings)))
    (P1LET `(let ,(sys::process-bindings bindings)
	      (declare (special . ,names))
	      (let ()
		(declare (unspecial . ,names))
		nil
		. ,body)))))

(unless (assoc 'SCHEME:EQV? TEST-MEMBER-ALIST)
  (push-end '(SCHEME:EQV? . SCHEME:MEMV) TEST-MEMBER-ALIST))

(add-post-optimizer scheme:Ï3eqv?Ï* eqv?-opt)
(defun eqv?-opt (form)
  (if (/= (length form) 3)
      form
    (flet ((opf (expression)  
	     (let ((type (type-of-expression expression)))
	       (cond ((eq type 't) nil)
		     ((member type '(fixnum symbol character) :test #'eq)
		      'eq)
		     ((eq type 'string)
		      'equal)
		     ((member type `( integer short-float single-float double-float
				     number cons list t-or-nil) :test #'eq)
		      'eql)
		     (t nil))) ))
      (let ((op (or (opf (third form))
		    (opf (second form)))))
	(cond (op (cons op (rest form)))
	      ((and (trivial-form-p (second form))
		    (discard-equal-forms form))
	       '(quote t))
	      (t form) )))))
(fold-constant-arguments 'scheme:eqv?)

(optimize-pattern (scheme:memv string t) (si:member-equal 1 2))
(fold-constant-arguments 'scheme:memv)
(optimize-pattern (scheme:memv number t) (si:member-eql 1 2))
(ADD-POST-OPTIMIZER scheme:Ï3memvÏ* MEMQ-EQ)
(ADD-POST-OPTIMIZER scheme:Ï3memvÏ* memv-opt)
(DEFUN memv-opt (FORM)
  (if (not (= (LENGTH FORM) 3))
      form
    (LET ((ITEM (second FORM))
	  (LIST (third FORM)))
      (if (or (and (quotep list)
		   (consp (second list))
		   (loop for value in (second list)
			 always (MEMBER (%DATA-TYPE value)
					'(#.DTP-FIX #.DTP-SYMBOL #.DTP-CHARACTER #.DTP-SMALL-FLONUM)
					:TEST #'EQ)))
	      (EQ-COMPARABLE-P ITEM 'scheme:eqv?))
	  `(MEMQ ,ITEM ,LIST)
	form))))

(defprop scheme:gensym		symbol	function-result-type)
(defprop scheme:print-length	fixnum	function-result-type)
(defprop scheme:line-length	fixnum  function-result-type)
(defprop scheme:runtime		integer	function-result-type)
(defprop scheme:dos-file-size	integer function-result-type)

