;;; -*- Mode:Common-Lisp; Package:Compiler2; Base:10 -*-
;;;
;;;			      RESTRICTED RIGHTS LEGEND
;;;
;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;			TEXAS INSTRUMENTS INCORPORATED.
;;;				 P.O. BOX 2909
;;;			      AUSTIN, TEXAS 78769
;;;				    MS 2151
;;;
;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.
;;; Copyright (C) 1980 Massachusetts Institute of Technology


;;;;   *-----------------------------------------------------------*
;;;;   |           --  TI Explorer Lisp Compiler  --               |
;;;;   |  This file contains portions of the compiler that are     |
;;;;   |  concerned with supporting compatibility with MacLisp.    |
;;;;   |  This file does not need to be loaded unless MacLisp      |
;;;;   |  support is needed.					   |
;;;;   *-----------------------------------------------------------*

;;;  7/26/85 DNG - File QCOPT split into files P1OPT, P1STYLE, and MACLISP.
;;;  8/17/85 DNG - Include *LEXPR, *EXPR, and *FEXPR.
;;;  4/06/86 DNG - Converted from Zetalisp to Common Lisp.
;;;  5/10/86 DNG - Moved handling of MacLisp CATCH and THROW to here.
;;;------------------ The following done after Explorer release 3.0 ------
;;;  6/23/87 DNG - Drop support for MacLisp CATCH and THROW because the MacLisp 
;;;		and Common Lisp usages of THROW cannot be reliably distinguished
;;;		in Zetalisp mode.  [SPR 5741]
;;;  4/25/89 DNG - Eliminate setting of unused ARGDESC property.

(DEFUN *EXPR (&QUOTE &REST L)
  (MAPC #'COMPILATION-DEFINE L)
  NIL)
(DEFF *LEXPR #'*EXPR)
(DEFF *FEXPR #'*EXPR)

(comment ; old way
(DEFUN *LEXPR (&QUOTE &REST L)
  (DOLIST (X L)
    (COMPILATION-DEFINE X)
    (SETF (GET X 'ARGDESC)
	  '((#o1005 (FEF-ARG-OPT FEF-QT-EVAL))))))

(DEFUN *EXPR (&QUOTE &REST L)
  (DOLIST (X L)
    (COMPILATION-DEFINE X)
    (SETF (GET X 'ARGDESC)
	  '((#o1005 (FEF-ARG-OPT FEF-QT-EVAL))))))

(DEFUN *FEXPR (&QUOTE &REST L)
  (DOLIST (X L)
    (COMPILATION-DEFINE X)
    (SETF (GET X 'ARGDESC)
	  '((#o1005 (FEF-ARG-OPT FEF-QT-QT))))))
)

;; 5/10/86 DNG - Moved SUBSTITUTE-FUNCTION-NAME to file P1OPT.

;;;   MacLisp floating point arithmetic

(ADD-OPTIMIZER +$ SUBSTITUTE-FUNCTION-NAME)
(ADD-OPTIMIZER -$ SUBSTITUTE-FUNCTION-NAME)
(ADD-OPTIMIZER *$ SUBSTITUTE-FUNCTION-NAME)
(ADD-OPTIMIZER /$ SUBSTITUTE-FUNCTION-NAME)
(ADD-OPTIMIZER 1+$ SUBSTITUTE-FUNCTION-NAME)
(ADD-OPTIMIZER 1-$ SUBSTITUTE-FUNCTION-NAME)


;;; modify signp to be (AND (NUMBERP <form>) (<op> <form>)) if form is an atom
;;; and therefore can't have side effects
(ADD-OPTIMIZER SIGNP SIGNP-EXPAND)
(DEFUN SIGNP-EXPAND (X)
  (LET ((OP (CADR X))
	(OPND (CADDR X)))
     (COND ((ATOM OPND)(SIGNP-OPTIMIZE OP OPND))		;IF ATOM, OPTIMIZE IT
	   (T X))))

(DEFUN SIGNP-OPTIMIZE (OPERATION OPERAND)
  (PROG (NEW-FORM NOTP)
    (SETQ NEW-FORM
	  (LIST (COND ((STRING-EQUAL OPERATION 'E) 'ZEROP)
		      ((STRING-EQUAL OPERATION 'N) (SETQ NOTP T) 'ZEROP)
		      ((STRING-EQUAL OPERATION 'L) 'MINUSP)
		      ((STRING-EQUAL OPERATION 'GE) (SETQ NOTP T) 'MINUSP)
		      ((STRING-EQUAL OPERATION 'G) 'PLUSP)
		      ((STRING-EQUAL OPERATION 'LE) (SETQ NOTP T) 'PLUSP)
		      (T
		       (WARN 'BAD-SIGNP ':IMPOSSIBLE
			     "~S is not a valid SIGNP condition." OPERATION)
		       'PROGN))
		OPERAND))
    (AND NOTP (SETQ NEW-FORM (LIST 'NOT NEW-FORM)))
   (RETURN `(AND (NUMBERP ,OPERAND) ,NEW-FORM))))

;;; Convert catches and throws

(ADD-OPTIMIZER #!Z CATCH CATCH-*CATCH)
(DEFUN CATCH-*CATCH (FORM)
  ;; 10/11/86 DNG - Modified to permit using the same symbol for Common Lisp and Zetalisp CATCH.
  ;;  6/23/87 DNG - Give warning on MacLisp CATCH.
  (IF (AND (<= (LENGTH FORM) 3)
	   (CONSP (SECOND FORM))
	   (ATOM (THIRD FORM))
	   (OR (NOT (EQ #!C 'CATCH #!Z 'CATCH))
	       (AND (NOT COMPILING-COMMON-LISP)
		    (NEQ (FIRST (SECOND FORM)) 'QUOTE)
		    )))
      ;; Looks like an old MacLisp catch; convert it
      (LET ((NEW `(*CATCH ',(THIRD FORM) ,(SECOND FORM))))
	(UNLESS (OR (NOT (EQ #!C 'CATCH #!Z 'CATCH))
		    RUN-IN-MACLISP-SWITCH)
	  ;; Give a non-suppressable error message because, although we can usually do the
	  ;; right thing with CATCH, the old form of THROW cannot be reliably recognized. [SPR 5741]
	  (LET ((SI:WARNINGS-PRINLEVEL 2))
	    (WARN 'MACLISP-CATCH ':VERY-OBSOLETE
		  "Apparent archaic usage: ~S~%Use ~S instead and convert the THROWs also."
		  FORM NEW) ))
	NEW)
    ;; Else assume Common Lisp catch.
    (IF (EQ #!C 'CATCH #!Z 'CATCH)
	FORM
      `(*CATCH . ,(REST FORM)))))

(ADD-OPTIMIZER #!Z THROW THROW-*THROW)
(DEFUN THROW-*THROW (FORM)
  ;; 10/11/86 DNG - Modified to permit using the same symbol for Common Lisp and Zetalisp THROW.
  ;;  6/23/87 DNG - Don't assume MacLisp usage unless RUN-IN-MACLISP-SWITCH is on. [SPR 5741]
  (IF (AND (<= (LENGTH FORM) 3)
	   (CONSP (SECOND FORM))
	   (ATOM (THIRD FORM))
	   (OR (NOT (EQ #!C 'THROW #!Z 'THROW))
	       (AND (NOT COMPILING-COMMON-LISP)
		    RUN-IN-MACLISP-SWITCH)))
      ;; Looks like an old MacLisp throw; convert it.
      `(*THROW ',(THIRD FORM) ,(SECOND FORM))
    ;; Else assume Common Lisp throw.
    (IF (EQ #!C 'THROW #!Z 'THROW)
	FORM
      `(*THROW . ,(REST FORM)))))

;;;   Style-checkers for things that don't work in Maclisp.

(DEFUN NOT-MACLISP (FORM)
    (AND RUN-IN-MACLISP-SWITCH
	 (WARN 'NOT-IN-MACLISP ':MACLISP
	       "~S is not implemented in Maclisp." (CAR FORM))))

;These symbols don't exist in Maclisp, though they could, but they are likely losers.
(ADD-STYLE-CHECKER LISTP NOT-MACLISP)
(ADD-STYLE-CHECKER NLISTP NOT-MACLISP)
(ADD-STYLE-CHECKER NSYMBOLP NOT-MACLISP)
																
;These functions can't be added to Maclisp by a user.
(ADD-STYLE-CHECKER INTERN-LOCAL NOT-MACLISP)
(ADD-STYLE-CHECKER INTERN-SOFT NOT-MACLISP)
(ADD-STYLE-CHECKER INTERN-LOCAL-SOFT NOT-MACLISP)
(ADD-STYLE-CHECKER MAKE-ARRAY NOT-MACLISP)
(ADD-STYLE-CHECKER G-L-P NOT-MACLISP)
(ADD-STYLE-CHECKER ARRAY-LEADER NOT-MACLISP)
(ADD-STYLE-CHECKER STORE-ARRAY-LEADER NOT-MACLISP)
(ADD-STYLE-CHECKER MULTIPLE-VALUE NOT-MACLISP)
(ADD-STYLE-CHECKER MULTIPLE-VALUE-LIST NOT-MACLISP)
(ADD-STYLE-CHECKER DO-NAMED NOT-MACLISP)
(ADD-STYLE-CHECKER BLOCK    NOT-MACLISP)
(ADD-STYLE-CHECKER TAGBODY  NOT-MACLISP)
(ADD-STYLE-CHECKER RETURN-FROM NOT-MACLISP)
(ADD-STYLE-CHECKER RETURN-LIST NOT-MACLISP)
(ADD-STYLE-CHECKER BIND NOT-MACLISP)
(ADD-STYLE-CHECKER COMPILER-LET NOT-MACLISP)
(ADD-STYLE-CHECKER LOCAL-DECLARE NOT-MACLISP)
(ADD-STYLE-CHECKER CONS-IN-AREA NOT-MACLISP)
(ADD-STYLE-CHECKER LIST-IN-AREA NOT-MACLISP)
(ADD-STYLE-CHECKER NCONS-IN-AREA NOT-MACLISP)
(ADD-STYLE-CHECKER VARIABLE-LOCATION NOT-MACLISP)
(ADD-STYLE-CHECKER VARIABLE-BOUNDP NOT-MACLISP)
(ADD-STYLE-CHECKER VALUE-CELL-LOCATION NOT-MACLISP)
(ADD-STYLE-CHECKER CAR-LOCATION NOT-MACLISP)
(ADD-STYLE-CHECKER PROPERTY-CELL-LOCATION NOT-MACLISP)
(ADD-STYLE-CHECKER FUNCTION-CELL-LOCATION NOT-MACLISP)
(ADD-STYLE-CHECKER FSET NOT-MACLISP)
(ADD-STYLE-CHECKER FBOUNDP NOT-MACLISP)
(ADD-STYLE-CHECKER FSYMEVAL NOT-MACLISP)
(ADD-STYLE-CHECKER SYMBOL-FUNCTION NOT-MACLISP)
(ADD-STYLE-CHECKER CLOSURE NOT-MACLISP)
																
;Return with more than one argument won't work in Maclisp.
(ADD-STYLE-CHECKER RETURN RETURN-STYLE)
(DEFUN RETURN-STYLE (FORM)
    (AND RUN-IN-MACLISP-SWITCH
	 (CDDR FORM)
	 (WARN 'NOT-IN-MACLISP ':MACLISP
	       "Returning multiple values doesn't work in Maclisp")))
																
;Named PROGs don't work in Maclisp.  PROG variables can't be initialized.
;Also, lots of tags and things like a GO to a RETURN are ugly.
(ADD-STYLE-CHECKER PROG PROG-STYLE)
(DEFUN PROG-STYLE (FORM)
    (PROG (PROGNAME)
	  (AND (ATOM (CADR FORM))
	       (CADR FORM)
	       (PROGN (SETQ PROGNAME (CADR FORM))
		      (SETQ FORM (CDR FORM))))
	  (COND (RUN-IN-MACLISP-SWITCH
		 (AND PROGNAME (NEQ PROGNAME T)
		      (WARN 'NOT-IN-MACLISP ':MACLISP
			    "The PROG name ~S is used; PROG names won't work in Maclisp."
			    PROGNAME))
		 (DOLIST (VAR (CADR FORM))
		   (OR (ATOM VAR)
		       (RETURN
			 (WARN 'NOT-IN-MACLISP ':MACLISP
			       "The PROG variable ~S is initialized; this won't work in Maclisp."
			       (CAR VAR)))))))))
																
;; Check a LAMBDA for things that aren't allowed in Maclisp.
;; Called only if RUN-IN-MACLISP-SWITCH is set.
(DEFUN LAMBDA-STYLE (LAMBDA-EXP)
  (DO ((VARLIST (CADR LAMBDA-EXP) (CDR VARLIST)) (KWDBARF)) ((NULL VARLIST))
    (COND ((ATOM (CAR VARLIST))
	   (AND (NOT KWDBARF)
		(MEMBER (CAR VARLIST) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
		(SETQ KWDBARF T)
		(WARN 'NOT-IN-MACLISP ':MACLISP
		      "Lambda-list keywords such as ~S don't work in Maclisp."
		      (CAR VARLIST))))
	  (T (WARN 'NOT-IN-MACLISP ':MACLISP
		   "The lambda-variable ~S is initialized; this won't work in Maclisp."
		   (CAAR VARLIST))))))