;;;; -*- Mode:Common-Lisp; Package:PROFILE; Fonts:(CPTFONT HL10B TR10BI); 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.

;;1;;*
;;1;; GLOBAL VARIABLES* (SEE SETF-FORMS FILE)
;;1;; *


;;1;;*
;;1;; MACROS, SUBSTS, AND STRUCTURE DEFINITIONS*
;;1;; *


;1;;Added in Profile 2.2 -dlc*

(DEFSUBST FORM-FOR-INIT-FILE (VARIABLE)
 ;1;Returns the form for an initialization file that will set this variable to its current value.*
  (DECLARE (VALUES FORM))
  (LET ((FORM-FOR-INIT-FILE-PROPERTY (GET VARIABLE 'FORM-FOR-INIT-FILE)))
    (IF (NOT (NULL FORM-FOR-INIT-FILE-PROPERTY))
      (FUNCALL FORM-FOR-INIT-FILE-PROPERTY VARIABLE)
      `(PROFILE-SETQ ,VARIABLE ',(VARIABLE-CURRENT-VALUE VARIABLE))))) 


;1;;Added in Profile 2.3 to not print unreadable values to initialization files.*

(DEFSUBST UNREADABLE-P (VALUE)
 ;1;Returns T or NIL depending on whether VALUE can be sucessfully printed and read back in*
  (DECLARE (VALUES T-OR-NIL))
  (LET ((SI:PRINT-READABLY T))
    (CONDITION-CASE (CONDITION)
	(PRIN1 VALUE 'SI:NULL-STREAM)
      (SYSTEM:PRINT-NOT-READABLE T)
      (:NO-ERROR NIL)))) 



(DEFUN VALID-CVV-TYPE-P (KEYWORD)
  "2Verifies that KEYWORD is a valid CVV keyword.*"
  (OR (GET KEYWORD 'W:CHOOSE-VARIABLE-VALUES-KEYWORD)
     (GET KEYWORD 'W::CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION))) 
 


(DEFUN SYMBOL-PRETTY-NAME (SYMBOL)
  (LET ((NAME (SYMBOL-NAME SYMBOL)))
    (IF (EQL #\* (AREF NAME 0))
      (SETQ NAME (SUBSEQ NAME 1)))
    (IF (EQL #\* (AREF NAME (1- (LENGTH NAME))))
      (SETQ NAME (SUBSEQ NAME 0 (1- (LENGTH NAME)))))
    (STRING-CAPITALIZE NAME :SPACES T))) 



(DEFUN ADD-IN-ORDER (NEW-VARIABLE VARIABLE-LIST
		     &OPTIONAL (NEW-VARIABLE-STRING (PRIN1-TO-STRING NEW-VARIABLE)))
  (COND
    ((NULL VARIABLE-LIST)     ;1An empty list*
     (LIST NEW-VARIABLE))
    ((STRING-LESSP NEW-VARIABLE-STRING (PRIN1-TO-STRING (FIRST VARIABLE-LIST)))    ;1Goes to the start*
     (CONS NEW-VARIABLE VARIABLE-LIST))
    (T
     (CONS (FIRST VARIABLE-LIST)
	   (ADD-IN-ORDER NEW-VARIABLE (REST VARIABLE-LIST) NEW-VARIABLE-STRING))))) 


;1;;Modified in Profile 2.6 to handle NIL as a class (means no classes)*
(DEFUN ADD-VARIABLE (SYMBOL CLASS)
  (LET ((VARIABLE-LIST-SYMBOL (SECOND (ASSOC CLASS *VARIABLE-CLASSES* :TEST #'EQ))))
    (ASSERT (OR (NULL CLASS) (NOT (NULL VARIABLE-LIST-SYMBOL)))
	    ()
            "There is no translation for the variable class ~s" CLASS)
    (UNLESS (OR (MEMBER SYMBOL (SYMBOL-VALUE VARIABLE-LIST-SYMBOL) :TEST #'EQ) (NULL CLASS))   ;1Don't repeat variables*
      (SET VARIABLE-LIST-SYMBOL (ADD-IN-ORDER SYMBOL (SYMBOL-VALUE VARIABLE-LIST-SYMBOL)))))) 


(DEFMACRO PROFILE-SETQ (VARIABLE VALUE)
  "2Similar to LOGIN-SETQ, except that only one variable can be set per form,
and appropriate Profile side effects are also executed.*"
  (DECLARE (VALUES VALUE))
  (let ((value-symbol (gensym)))
  `(let ((,value-symbol ,value))
     ;;Add an undo form to the logout list
     (WHEN (VARIABLE-BOUNDP ,VARIABLE)
       (PUSH `(let ((*profile-restore-p* t))
		(SETF (VARIABLE-CURRENT-VALUE ',',VARIABLE)
		    ',(VARIABLE-CURRENT-VALUE ',VARIABLE)))
	     LOGOUT-LIST))
     1;;Set the variable as indicated*
     (SETF (VARIABLE-CURRENT-VALUE ',VARIABLE) ,VALUE-SYMBOL)
     ;;Record the new value so that the user can go back to it after additional changes are made
     (SETF (GET ',VARIABLE 'VALUE-FROM-INIT-FILE) ,VALUE-SYMBOL)
     ,VALUE-SYMBOL))) 

;1;*
;1; VARIABLE DEFINING MACROS AND FUNCTIONS*
;1;*
;1;This is the old version of the variable defining form. [No longer used]*
;(DEFMACRO define-profile-variable-old  (variable variable-classes &optional	   
;				    (variable-type :any)
;				    pretty-name 
;				    documentation)
;  "2This macro defines a profile variable.*
;2VARIABLE is a symbol.*
;2VARIABLE-CLASSES is a list of keywords designating the classes the VARIABLE is in.*
;2VARIABLE-TYPE is a CVV type keyword.*
;2PRETTY-NAME is the name of the variable used for display purposes. If not specified, something reasonable will be used.*
;2DOCUMENTATION is the documentation string for the variable.  This will default to the already-present string.*"
;  `(define-profile-variable-1 ',variable ',variable-classes ',variable-type
;			      ',pretty-name ',documentation))


;1;;FORM-FOR-INIT-FILE added in Profile 2.2 -dlc*
;1;;This is the new and prefered way of defining profile variables.*

(DEFMACRO DEFINE-PROFILE-VARIABLE (VARIABLE VARIABLE-CLASSES ;1;*&body keywords-and-args
				   &KEY CVV-TYPE DECLARE-SPECIAL-P DOCUMENTATION
				   (GET-VALUE NIL GET-VALUE-P) (SET-EFFECT NIL SET-EFFECT-P)
				   NAME (VARIABLE-INIT NIL VARIABLE-INIT-P) LONG-TIME-TO-SET-P
                                   (FORM-FOR-INIT-FILE () FORM-FOR-INIT-FILE-P)
				   &ALLOW-OTHER-KEYS)
  "2This macro is used to define a profile variable.
After the first two arguments, all arguments are optional keyword arguments, whose
values should be unquoted (they will not be evaluated).

1REQUIRED ARGUMENTS:*
VARIABLE is a symbol.
VARIABLE-CLASSES is a list of keywords designating the classes the VARIABLE is in.

1OPTIONAL KEYWORD ARGUMENTS:*
NAME is the name of the variable used for display purposes. If not specified, something reasonable will be used.
DOCUMENTATION is the documentation string for the variable.  This will default to the already-present string.
CVV-TYPE is a CVV keyword or a list whose first element is a CVV type keyword.
DECLARE-SPECIAL-P is used to declare a profile variable as special.  This is only done with variables unique
to the Profile facility.
GET-VALUE is the form to evaluate to obtain the value of this variable.
SET-EFFECT is the form to evaluate after each time the value of this variable is changed within the Profile interface.
LONG-TIME-TO-SET-P is non-NIL if the variable takes more than a few seconds to set and
execute the proper SET-EFFECT.
FORM-FOR-INIT-FILE is a one-argument lambda expression or function name that will return a form appropriate for
that variable (the argument to the function) to set the variable to the correct value.*
"
  (DECLARE (ARGLIST VARIABLE VARIABLE-CLASSES &KEY CVV-TYPE DECLARE-SPECIAL-P DOCUMENTATION
	    GET-VALUE SET-EFFECT NAME VARIABLE-INIT FORM-FOR-INIT-FILE))
  `(PROGN 'COMPILE
	  ,(WHEN DECLARE-SPECIAL-P
	     `(DEFPARAMETER ,VARIABLE ,(IF VARIABLE-INIT-P
				       VARIABLE-INIT
				       GET-VALUE)
		,DOCUMENTATION))
	  (Define-PROFILE-VARIABLE-1 ',VARIABLE ',VARIABLE-CLASSES ',CVV-TYPE ',NAME ',DOCUMENTATION)
	  ,(WHEN FORM-FOR-INIT-FILE-P
	     `(SETF (GET ',VARIABLE 'FORM-FOR-INIT-FILE) ',FORM-FOR-INIT-FILE))
	  ,(WHEN GET-VALUE-P
	     `(SETF (GET ',VARIABLE 'GET-VALUE) ',GET-VALUE))
	  ,(WHEN SET-EFFECT-P
	     `(PROGN
		,(WHEN LONG-TIME-TO-SET-P
		   `(PUSH ',VARIABLE *VARIABLES-THAT-TAKE-A-LONG-TIME-TO-UPDATE*))
		(SETF (GET ',VARIABLE 'SET-EFFECT) ',SET-EFFECT))))) 

(EXPORT '(PROFILE-SETQ DEFINE-PROFILE-VARIABLE))



(DEFUN DEFINE-PROFILE-VARIABLE-1 (VARIABLE-SYMBOL CLASSES TYPE PRETTY-NAME DOCUMENTATION)
  "2This does the real work of DEFINE-PROFILE-VARIABLE.*"
  (ASSERT (OR *ALLOW-UNBOUND-SYMBOLS-P* (BOUNDP VARIABLE-SYMBOL))
;	    (VARIABLE-SYMBOL)
	  `(,VARIABLE-SYMBOL)
	  "The symbol ~S is unbound." VARIABLE-SYMBOL)
  (IF (NOT (BOUNDP VARIABLE-SYMBOL))
      (FORMAT T "~%The variable ~s is not added as a profile variable because it is unbound."
	      VARIABLE-SYMBOL)
      (PROGN
	(SETF (VARIABLE-INITIAL-VALUE VARIABLE-SYMBOL) (SYMBOL-VALUE VARIABLE-SYMBOL))
	
	;1; If only one class is specified as a symbol, make it a list of one class*
	(WHEN (SYMBOLP CLASSES)
	      (SETQ CLASSES `(,CLASSES)))
	
	;1;Add the variable to each of the classes and add the classes to the variable*
	(LOOP FOR CLASS IN CLASSES
	      DO
	      (ADD-VARIABLE VARIABLE-SYMBOL CLASS))
	(SETF (VARIABLE-CLASSES VARIABLE-SYMBOL) CLASSES)
	
	;1;Check and record the CVV type*
	(ASSERT (OR *ALLOW-ILLEGAL-CVV-TYPES-P*
		    (VALID-CVV-TYPE-P (IF (CONSP TYPE) (CAR TYPE) TYPE)))
		(TYPE)
		"~%TYPE, ~s, is not a valid CVV keyword or function." TYPE)
	(WHEN (AND (EQ :WARN *ALLOW-ILLEGAL-CVV-TYPES-P*)
		   (NOT (VALID-CVV-TYPE-P (IF (CONSP TYPE) (CAR TYPE)
					      TYPE))))
	      (FORMAT T "~%TYPE, ~s, is not a valid CVV keyword or function." TYPE))
	(SETF (VARIABLE-TYPE VARIABLE-SYMBOL) TYPE)
	
	;1;PRETTY (Display) Name of Variable*
	(WHEN (NULL PRETTY-NAME)
	      (SETQ PRETTY-NAME (VARIABLE-NAME VARIABLE-SYMBOL)))
	(SETF (VARIABLE-NAME VARIABLE-SYMBOL) PRETTY-NAME)
	
	(COND
	  ((NULL DOCUMENTATION)
	   (SETQ DOCUMENTATION
		 (OR (DOCUMENTATION VARIABLE-SYMBOL 'VARIABLE)
		     (GET VARIABLE-SYMBOL 'ZWEI::DOCUMENTATION-PROPERTY)))
	   (WHEN (NULL DOCUMENTATION)
		 (CASE *ALLOW-NO-DOCUMENTATION-P*
		   (NIL (FERROR () "~%No documentation for the profile variable ~s" VARIABLE-SYMBOL))
		   (:WARN (FORMAT T "~%No documentation for the profile variable ~s" VARIABLE-SYMBOL)))))
	  (T (SETF (VARIABLE-DOCUMENTATION VARIABLE-SYMBOL) DOCUMENTATION)))))) 


(DEFMACRO UNDEFINE-PROFILE-VARIABLE (VARIABLE &OPTIONAL (VARIABLE-CLASSES :ALL))
  "2Removes the variable from the profile system.
Variable can be removed from selected classes as specified by VARIABLE-CLASSES.
Alternatively, it will be removed from all classes if :ALL is specified.*"
  `(PROGN
     1;;Remove appropriate pointers to this variable*
     (LET ((CLASSES
	    (COND
	      ((GLOBAL:LISTP ',VARIABLE-CLASSES) ',VARIABLE-CLASSES)
	      ((EQ ',VARIABLE-CLASSES :ALL) (GET ',VARIABLE 'CLASSES))
	      (T (NCONS ',VARIABLE-CLASSES)))))
       (LOOP FOR CLASS IN CLASSES
	     FOR CLASS-VARIABLE = (CLASS-KEYWORD-TO-VARIABLE CLASS)
	     UNLESS (NULL CLASS-VARIABLE)
	     DO
	     (SET CLASS-VARIABLE (DELETE ',VARIABLE (SYMEVAL CLASS-VARIABLE) :TEST #'EQ))
	     (SETF (VARIABLE-CLASSES ',VARIABLE) (DELETE CLASS (VARIABLE-CLASSES ',VARIABLE) :TEST #'EQ))))

1     *  1;;If variable has been removed from all classes, get rid of all profile information*
     (WHEN (NULL (VARIABLE-CLASSES ',VARIABLE))
       (REMPROP ',VARIABLE 'VARIABLE-NAME)
       (REMPROP ',VARIABLE 'TYPE)
       (REMPROP ',VARIABLE 'CLASSES)
       (REMPROP ',VARIABLE 'VARIABLE-INIT)
       (REMPROP ',VARIABLE 'GET-VALUE)              ;;also remove GET-VALUE, SET-EFFECT, 
       (REMPROP ',VARIABLE 'SET-EFFECT)             ;;and FORM-FOR-INIT-FILE  12/17/87  slm
       (REMPROP ',VARIABLE 'FORM-FOR-INIT-FILE))))

(DEFMACRO DEFINE-PROFILE-VARIABLE-SET-EFFECT (VARIABLE &BODY BODY)
  "2Defines the side effect of altering the value of a variable.*"
  `(setf (get ',VARIABLE 'SET-EFFECT) '(PROGN . ,BODY)))


(DEFMACRO DEFINE-PROFILE-PSEUDO-VARIABLE (VARIABLE DOCUMENTATION &BODY BODY)
  "2Defines a stupid profile variable that is not changed by other parts of the
system, even though the situation that this variable indicates may be changed.
For example, there is a variable that indicates whether the screen is in reverse video or
not, but this is not updated by other programs when they change things.
BODY is the form to evaluate to obtain the current value of the variable.*"
  `(PROGN
     (DEFCONST ,VARIABLE ,(CAR BODY) ,DOCUMENTATION)
     (SETF (GET ',VARIABLE 'GET-VALUE) '(PROGN . ,BODY)))) 
 

;1;;*
;1;; CLASS DEFINING FORM*
;1;;*

(DEFMACRO DEFINE-VARIABLE-CLASS (VARIABLE-CLASS KEYWORD PRETTY-NAME DOCUMENTATION-STRING)
  `(PROGN 'COMPILE
	  (DEFCONST ,VARIABLE-CLASS () ,DOCUMENTATION-STRING)
	  (PUSHNEW '(,KEYWORD ,VARIABLE-CLASS ,PRETTY-NAME ,DOCUMENTATION-STRING)
		   *VARIABLE-CLASSES* :TEST #'EQUAL))) 


(DEFUN CLASS-KEYWORD-TO-VARIABLE (KEYWORD)
  "2Returns the class variable (or NIL) of the class specified by the keyword.*"
  (SECOND (ASSOC KEYWORD *VARIABLE-CLASSES* :TEST #'EQ))) 

;1;;*
;1;; DEFINITIONS OF CLASSES*
;1;; *

;;color variables added for Profile 3.2  slm 9/87
(DEFINE-VARIABLE-CLASS *COLOR-SYSTEM-VARIABLES* :COLOR "Color System Variables"
  "Variables affecting the behavior of color displays.")


(DEFINE-VARIABLE-CLASS *DISPLAY-VARIABLES* :DISPLAY 2"Display Variables"*
   "2Variables affecting the display.*") 


(DEFINE-VARIABLE-CLASS *COMMON-LISP-VARIABLES* :COMMON "2Common Lisp Globals*"
   "Common Lisp global variables") 


(DEFINE-VARIABLE-CLASS *EVAL-VARIABLES* :EVAL "2Evaluation Variables*"
   "Variables affecting the evaluation of code.") 


(DEFINE-VARIABLE-CLASS *FILE-SYSTEM-VARIABLES* :FILE "2File System Variables*"
   "Variables affecting the file system.") 


(DEFINE-VARIABLE-CLASS *INPUT-VARIABLES* :INPUT "2Input Variables*"
   "Variables affecting the way that input is handled.") 


(DEFINE-VARIABLE-CLASS *MOUSE-VARIABLES* :MOUSE "2Mouse Variables*"
   "Variables affecting the way the mouse works.") 


(DEFINE-VARIABLE-CLASS *ZMACS-VARIABLES* :ZMACS "2Zmacs Variables*"
   "Variables affecting the way the Zmacs editor works.") 

;1;Changed 11/27/85 by Lisa Spell -- so that the Mail Vars will not be first in Profile.*

(DEFINE-VARIABLE-CLASS *MAIL-VARIABLES* :MAIL "2Mail Variables"*
   "Variables affecting the Mail System.") 


(DEFINE-VARIABLE-CLASS *COMPILER-VARIABLES* :COMPILE "2Compiler Variables*"
   "Variables affecting the way the compiler works.") 


(DEFINE-VARIABLE-CLASS *GC-VARIABLES* :GC "2GC Variables*"
   "Variables affecting the way garbage collection (GC) works.") 


(DEFINE-VARIABLE-CLASS *NETWORK-VARIABLES* :NETWORK "2Network Variables*"
   "Variables affecting the way the network works.") 


(DEFINE-VARIABLE-CLASS *ERROR-VARIABLES* :ERROR "2Error Handling Variables*"
   "Variables affecting error handling.") 


(DEFINE-VARIABLE-CLASS *UCL-VARIABLES* :UCL "2UCL Variables*"
   "Variables affecting the Universal Command Loop (UCL).") 


(DEFINE-VARIABLE-CLASS *IMPORTANT-VARIABLES* :IMPORTANT "2Important Variables*"
   "Variables that are most often modified by users.") 


;1;;*
;1;; OTHER VARIABLE UTILITY FUNCTIONS*
;1;; *

;1;;Use 3-arg GET to differentiate NIL value from no value. -Profile 2.2 dlc*

(DEFUN REVERT-PROFILE-VARIABLES (&OPTIONAL (QUERY-P T) (DO-VARIABLES-CHANGED-BY-INIT-FILE-P T))
  "2Reverts all profile variables to their initial values (bindings at boot time).
QUERY-P indicates whether the user should be asked to verify each change.
DO-VARIABLES-CHANGED-BY-INIT-FILE-P should be T unless variables changed by the user in his
init file are not to be reverted.  This should be done if these variables are to be restored after this
function (preventing needless setting of variables and execution of side effects).*"
  (LOOP FOR CLASS IN *VARIABLE-CLASSES*
	FOR VARIABLES = (SYMBOL-VALUE (CLASS-VARIABLE CLASS))
	DO
	(LOOP FOR VARIABLE IN VARIABLES
	      FOR INITIAL-VALUE = (VARIABLE-INITIAL-VALUE VARIABLE)
	      FOR CURRENT-VALUE = (VARIABLE-CURRENT-VALUE VARIABLE)
	      UNLESS (EQUALP INITIAL-VALUE CURRENT-VALUE)
	      DO
	      (WHEN (AND (OR (NOT QUERY-P)
	                 (Y-OR-N-P "Revert the variable ~s from ~s back to ~s, its original value? "
				   VARIABLE CURRENT-VALUE INITIAL-VALUE))
	                 (OR DO-VARIABLES-CHANGED-BY-INIT-FILE-P
			     
	      ;1;This is true if the variable has been set by a profile-setq form*
			     (EQ (GET VARIABLE 'VALUE-FROM-INIT-FILE :NO-PROPERTY) :NO-PROPERTY)))
		(SETF (VARIABLE-CURRENT-VALUE VARIABLE) INITIAL-VALUE))))) 

;1;;Use 3-arg GET to differentiate NIL value from no value. -Profile 2.2 dlc*

(DEFUN RESTORE-INIT-FILE-CHANGES ()
  "2Restores all variables that were set by the user's init file, using PROFILE-SETQ.*"
  (LOOP FOR VARIABLE IN (REMOVE-IF-NOT
			  #'(LAMBDA (VAR)
			      (NEQ (GET VAR 'VALUE-FROM-INIT-FILE :NO-PROPERTY) :NO-PROPERTY))
			  (ALL-PROFILE-VARIABLES))
	DO (SETF (VARIABLE-CURRENT-VALUE VARIABLE) (GET VARIABLE 'VALUE-FROM-INIT-FILE)))) 


(DEFUN UPDATE-VARIABLE-INITIAL-VALUES (&OPTIONAL (QUERY-P NIL))
  "2Changes the initial values of all profile variables to their current values.*"
  (LOOP FOR CLASS IN *VARIABLE-CLASSES*
	FOR VARIABLES = (SYMBOL-VALUE (CLASS-VARIABLE CLASS))
	DO
        (LOOP FOR VARIABLE IN VARIABLES
	      FOR INITIAL-VALUE = (VARIABLE-INITIAL-VALUE VARIABLE)
	      FOR CURRENT-VALUE = (VARIABLE-CURRENT-VALUE VARIABLE)
	      UNLESS (EQUALP INITIAL-VALUE CURRENT-VALUE)
	      DO
	      (WHEN (OR (NOT QUERY-P)
	                (Y-OR-N-P "Change the initial value of variable ~s from ~s to ~s, its current value? "
				  VARIABLE INITIAL-VALUE CURRENT-VALUE))
		(SETF (VARIABLE-INITIAL-VALUE VARIABLE) CURRENT-VALUE))))) 


(ADD-INITIALIZATION "Update initial values of Profile variables."
		    '(UPDATE-VARIABLE-INITIAL-VALUES) '(:WARM)) 

;1;;*
;1;; INITIALIZATION FILE STUFF*
;1;;*
;1;;Check for Unreadable values (rather than just flavor instances) -Profile 2.3 -dlc*
;1;; Added form-for-init-file in Profile 2.2 -dlc*


(DEFUN INIT-FORMS-FOR-FILE ()
  "2Returns the list of initialization forms that must be evaluated at login
to recreate the current environment of profile variables.*"
  (DECLARE (VALUES FORMS-FOR-FILE))
  (LET ((CHANGED-VARIABLES NIL))
    (LOOP FOR CLASS IN *VARIABLE-CLASSES*
	  FOR VARIABLES = (SYMBOL-VALUE (CLASS-VARIABLE CLASS))
          DO
          (LOOP FOR VARIABLE IN VARIABLES
		FOR INITIAL-VALUE = (VARIABLE-INITIAL-VALUE VARIABLE)
	        FOR CURRENT-VALUE = (VARIABLE-CURRENT-VALUE VARIABLE)
		UNLESS (OR (EQUALP INITIAL-VALUE CURRENT-VALUE)
	                   (MEMBER VARIABLE *VARIABLES-NOT-TO-BE-DUMPED* :TEST #'EQ)
			   (AND (INSTANCEP current-value)	;1Some problems sometimes occur dumping instances*
				(UNREADABLE-P CURRENT-VALUE)
				(NOT (GET VARIABLE 'FORM-FOR-INIT-FILE)))	;1Problems we can get around*
			   (MEMBER VARIABLE CHANGED-VARIABLES :TEST #'EQ))	;1Don't include variables twice*
		DO
		(PUSH VARIABLE CHANGED-VARIABLES)))
    `((progn :profile-options
	     (let ((profile:*profile-restore-p* t))
	       ,@(LOOP FOR VARIABLE IN CHANGED-VARIABLES
		       COLLECT (FORM-FOR-INIT-FILE VARIABLE)))))))




(DEFUN WRITE-INIT-FILE ()
  "2Writes any changed profile variables to an initialization file.*"
  ;1;Ask user here whether the information should be stored in her login init file or a profile init file.*
  (LET ((CHOICE-LIST
	 '(("Store options at the end of LOGIN initialization file" :VALUE :LOGIN-INIT	    
	    :DOCUMENTATION "Stores the current profile environment at the end of your LOGIN-INIT file.")
	   ("" :NO-SELECT NIL)
	   ("Store options in a separate PROFILE initialization file" :VALUE :PROFILE-INIT
	    :DOCUMENTATION "Stores the current profile environment in a PROFILE-INIT file that 
                            must be loaded separately (most likely by your LOGIN-INIT file).")
	   ("" :NO-SELECT NIL)
	   ("Store options in a file selected by you." :VALUE :USER-SELECTED-FILE
	    :DOCUMENTATION "Stores the current profile environment in a file selected by you."))))
    
    (CASE (W:MENU-CHOOSE CHOICE-LIST
			  :LABEL `(:FONT FONTS:TR12
			    :STRING
			    ,(FORMAT () "2You can store the profile changes that you have made to one of three files.

1) Your LOGIN initialization file, ~a, which can be modified
to include the changes that you have specified using this Profile facility.

2)  A special PROFILE initialization file, called ~a,
that will contain only information about the Profile variables.
This file will have to be explicitly loaded when you login, probably from
within your LOGIN initialization file.

3) An arbitrary file, selected by you. [You will be prompted for the filename to use].

In the menu below, select the file in which you would like to store the
changes you have made using the Profile facility:~%*"
				(INIT-FILE-PATHNAME "LOGIN") (INIT-FILE-PATHNAME *PROGRAM-NAME*)))
		     :NEAR-MODE '(:MOUSE)
		     :DEFAULT-ITEM (FIRST CHOICE-LIST))
      (1:LOGIN-INIT*
       (ADD-PROFILE-OPTIONS-TO-LOGIN-INIT-FILE (INIT-FORMS-FOR-FILE)))
      (1:PROFILE-INIT*
       (WRITE-NEW-PROFILE-INIT-FILE (INIT-FORMS-FOR-FILE)))
      (1:USER-SELECTED-FILE*
       (WRITE-USER-SELECTED-FILE (INIT-FORMS-FOR-FILE)))
      (1OTHERWISE*
       (BEEP))))) 

;1;Add Binding of *print-escape* et al - Profile 2.2 -dlc*

(DEFUN WRITE-NEW-PROFILE-INIT-FILE (FORMS-FOR-FILE)
  "2Write the list of profile initializations to a new profile init file to be
loaded when the user logs in.*"
  ;1;THINGS TO DO*
  ;1;  - If the login-init file already loads the profile-init file, don't include a 2nd load in the login-init file*
  (LET ((PROFILE-INIT-FILE-PATHNAME (INIT-FILE-PATHNAME *PROGRAM-NAME*)))
    (DUMP-FORMS-TO-FILE PROFILE-INIT-FILE-PATHNAME FORMS-FOR-FILE)
    (WITH-LISP-MODE :COMMON-LISP		;1Write the file in Common-Lisp mode by default*
      (WITH-OPEN-FILE (FILE (INIT-FILE-PATHNAME *PROGRAM-NAME*) :DIRECTION :OUTPUT)
	;1;Remember to read and write the file using same Mode and Radix.*
	(FORMAT FILE ";;; -*- Mode:Common-Lisp; Package:USER; Base:10 -*-~2%")
	(FORMAT FILE ";;; This file was written by the PROFILE utility.")
	(LOOP WITH *PRINT-BASE* = 10. AND *PRINT-ESCAPE* = T
	      AND *PRINT-LEVEL* = () AND *PRINT-LENGTH* = ()
	      FOR FORM IN FORMS-FOR-FILE
	      DO
	      (PPRINT FORM FILE))))		;1Changed from GRIND-TOP-LEVEL - Profile 2.2 -dlc*
    
    
    (WHEN (W::MOUSE-CONFIRM
	    (FORMAT () "Do you want to include a load of your PROFILE file ~
                                  in your LOGIN initialization file?")
	    "Click here to include the load of it; otherwise move mouse away.")
      
      (LET ((INIT-FILE-PATHNAME (INIT-FILE-PATHNAME "login")))
;      (WITH-OPEN-FILE (ISTREAM INIT-FILE-PATHNAME '(:IN :NOERROR))
; These are the new Release3 options for OPEN
	(WITH-OPEN-FILE (ISTREAM INIT-FILE-PATHNAME :CHARACTERS T :DIRECTION :INPUT :ERROR NIL)
	  (IF (ERRORP ISTREAM)
	      (UNLESS (CONDITION-TYPEP ISTREAM 'FS:FILE-NOT-FOUND)
		(FERROR "Error: ~a" ISTREAM)))	1;Bomb on any other error.*
	  1;; Now, open a new version of the file for writing.*
	  1;; Since we're doing simple character copying here, our Lisp-Mode doesn't matter.*
	  (WITH-OPEN-FILE-RETRY (OSTREAM (INIT-FILE-PATHNAME FS:FILE-ERROR) :DIRECTION :OUTPUT)
	    (UNLESS (ERRORP ISTREAM)		1;Copy file if it exists.*
	      (STREAM-COPY-UNTIL-EOF ISTREAM OSTREAM))
	    (FORMAT OSTREAM "~3%;;~%;;This loads the PROFILE init file.~%;;")
	    (FORMAT OSTREAM
		    "~%(when (fboundp 'profile:load-init-file) (profile:load-init-file ~s))~2%"
		    (send PROFILE-INIT-FILE-PATHNAME :short-string-for-printing))
	    (CLOSE OSTREAM)))
	;1; If there are compiled files out there, compile this new one.*
	(WHEN (PROBE-FILE (SEND INIT-FILE-PATHNAME :NEW-TYPE :XLD))
	  (COMPILE-FILE INIT-FILE-PATHNAME)))))) 

;1;Add Binding of *print-escape*  - Profile 2.2 -dlc*

(DEFUN ADD-PROFILE-OPTIONS-TO-LOGIN-INIT-FILE (FORMS-FOR-FILE)
  "2Adds all of the currently changed profile options to the end of the init file.*"
  ;1; If init file doesn't exist, create one.*
  ;1;THINGS TO DO:*
  ;1;  -Check for the possibility of a commented-out :PROFILE-OPTIONS statement (would result in unbalanced parentheses) -DLC Profile 1.8*
  (UNLESS (NULL FORMS-FOR-FILE);1Don't do anything we don't have to*
    (LET* ((INIT-FILE-PATHNAME (INIT-FILE-PATHNAME "LOGIN"))
	   (FILE-ATTRIBUTE-LIST-LISP-MODE :COMMON-LISP)
	   (FILE-ATTRIBUTE-LIST-BASE 10.)
	   (ORIGINAL-LISP-MODE (LISP-MODE))
	   (INIT-FILE-STRING                 ;1Text of current init file*
	    (WITH-OPEN-FILE (INIT-FILE INIT-FILE-PATHNAME :DIRECTION :INPUT :ERROR NIL)
	      (COND
		((ERRORP INIT-FILE)
		 (UNLESS (CONDITION-TYPEP INIT-FILE 'FS:FILE-NOT-FOUND)
		   (FERROR "Error: ~a" INIT-FILE))
		 "");1Return empty string if no init file*
		(T
		 ;1;Use fs:extract-attribute-list since we already have the file opened*
		 (WITH-STACK-LIST* (ATTRIBUTE-LIST NIL (FS:EXTRACT-ATTRIBUTE-LIST INIT-FILE))
		   (SETF FILE-ATTRIBUTE-LIST-LISP-MODE
			 (OR
			   (GETF ATTRIBUTE-LIST :MODE)
			   FILE-ATTRIBUTE-LIST-LISP-MODE))
		   (WHEN (EQ FILE-ATTRIBUTE-LIST-LISP-MODE 'LISP)
		     (SETQ FILE-ATTRIBUTE-LIST-LISP-MODE 'ZETALISP))
		   (SETF FILE-ATTRIBUTE-LIST-BASE
			 (OR (GETF ATTRIBUTE-LIST :BASE)
			     FILE-ATTRIBUTE-LIST-BASE))
		   (WITH-OUTPUT-TO-STRING (STRING-STREAM)
		     (STREAM-COPY-UNTIL-EOF INIT-FILE STRING-STREAM)))))))
	   
	   ;1;;This is a real hack.  It needs to be generalized to handle any amount of whitespace between symbols- DLC*
	   (PROFILE-FORM-START-POSITION
	    (OR
	     ;1;This version is from GRIND-TOP-LEVEL*
	     (SEARCH (THE STRING (STRING "(PROGN :PROFILE-OPTIONS"))
		     (THE STRING (STRING INIT-FILE-STRING)) :TEST #'CHAR-EQUAL)
	     ;1;This version is from PPRINT*
	     (SEARCH (THE STRING (STRING #. (STRING-APPEND "(PROGN" #\NEWLINE "  :PROFILE-OPTIONS")))
		     ;1String-Append at compile-time*
		     (THE STRING (STRING INIT-FILE-STRING)) :TEST #'CHAR-EQUAL)))
	   PROFILE-FORM-END-POSITION)
      
	   ;1;When Empty File, put the mode line in it.*
      (WHEN (STRING-EQUAL "" INIT-FILE-STRING)
	(SETQ INIT-FILE-STRING
	      (FORMAT () ";;; -*- Mode: Common-Lisp; Base: 10; Package: USER -*-~2%")))
      ;1;Get the text of the login-init file without any of the Profile options*
      (WHEN (NOT (NULL PROFILE-FORM-START-POSITION))
	(CONDITION-CASE (CONDITION)
	   (MULTIPLE-VALUE-SETQ (NIL PROFILE-FORM-END-POSITION)
	     (READ-FROM-STRING INIT-FILE-STRING () 'SI:NO-EOF-OPTION :START
			       PROFILE-FORM-START-POSITION))
	   (SYSTEM:READ-END-OF-FILE
	    ;1;This could be a problem because of either the :PROFILE-OPTIONS form being commented out or a real mistake in parens.*
	    (WHEN (CHAR-EQUAL
	      ;1;Find out if there is a semi-colon on this line (if we are in a comment)*
	      (AREF INIT-FILE-STRING
		    (STRING-REVERSE-SEARCH-SET '(#\NEWLINE #\;) INIT-FILE-STRING
					       PROFILE-FORM-START-POSITION))
	      #\NEWLINE)
	     ;1;There is a real mistake in the init file: no closing paren*
	      (W:NOTIFY ()
			 "There appears to be some mismatched parentheses in the file ~a.~@
                               You should check this file yourself.~@
                             [Note that the Profile Initialization forms have been appended to this file.]"
			 INIT-FILE-PATHNAME)
	      ;1;Else the profile init forms appear to just be commented out.  Don't worry about anything.*
))
	   (:NO-ERROR
	    ;1;If everything else looks OK, delete the current Profile Init form from the text.*
	    (SETQ INIT-FILE-STRING
		  (STRING-APPEND (SUBSEQ INIT-FILE-STRING 0 PROFILE-FORM-START-POSITION)
				 (SUBSEQ INIT-FILE-STRING PROFILE-FORM-END-POSITION))))))
      ;1; Actually write out the new LOGIN init file*
      (UNWIND-PROTECT (WITH-OPEN-FILE-RETRY
		       (OUTPUT-FILE (INIT-FILE-PATHNAME FS:FILE-ERROR) :DIRECTION :OUTPUT)
		       (LET ((*PRINT-BASE* FILE-ATTRIBUTE-LIST-BASE)
			     (*PRINT-ESCAPE* T)
			     (*PRINT-LENGTH* NIL)
			     (*PRINT-LEVEL* NIL))
			 (SET-LISP-MODE FILE-ATTRIBUTE-LIST-LISP-MODE)
			 (FORMAT OUTPUT-FILE "~a" INIT-FILE-STRING)
			 (FORMAT OUTPUT-FILE "~3%")
			 (LOOP FOR FORM IN FORMS-FOR-FILE
			       DO (PPRINT FORM OUTPUT-FILE))));1Changed from GRIND-TOP-LEVEL - Profile 2.2 -dlc*
	(SET-LISP-MODE ORIGINAL-LISP-MODE))
      ;1; If there are compiled files out there, compile this new one.*
      (WHEN (PROBE-FILE (SEND INIT-FILE-PATHNAME :NEW-TYPE :XLD))
	(COMPILE-FILE INIT-FILE-PATHNAME))))) 

;1;Add Binding of *print-escape*  and better pathname prompt- Profile 2.2 -dlc*

(DEFUN WRITE-USER-SELECTED-FILE (FORMS-FOR-FILE)
 ;1;;Write the profile options to a file specified by the user*
  (LET ((USER-SELECTED-FILE (SEND (INIT-FILE-PATHNAME *PROGRAM-NAME*) :NEW-TYPE :LISP)))
    (DECLARE (SPECIAL USER-SELECTED-FILE))
    (IF (EQ
      (CATCH 'WRITE-FILE
	(W:CHOOSE-VARIABLE-VALUES '((USER-SELECTED-FILE "File" :PATHNAME))
				   :SUPERIOR *PROFILE-FRAME*
				   :LABEL "Enter file in which to write Profile initialization forms:"
				   :MARGIN-CHOICES '("Write File"
				                    ("Don't Write File" (THROW 'WRITE-FILE :ABORT)))))
      :ABORT)
      (BEEP)
      (DUMP-FORMS-TO-FILE (SEND (FS:PARSE-PATHNAME USER-SELECTED-FILE) :NEW-TYPE :XLD) FORMS-FOR-FILE)
      (WITH-OPEN-FILE (FILE (SEND (FS:PARSE-PATHNAME USER-SELECTED-FILE) :NEW-TYPE :LISP) :DIRECTION :OUTPUT)
	(FORMAT FILE ";;; -*- Mode:Common-Lisp; Package:USER; Base:10 -*-~2%")
	(FORMAT FILE ";;; This file was written by the PROFILE utility.")
	(WITH-LISP-MODE :COMMON-LISP
	   (LOOP WITH *PRINT-BASE* = 10. AND *PRINT-ESCAPE* = T
		 AND *PRINT-LEVEL* = () AND *PRINT-LENGTH* = ()
		 FOR FORM IN FORMS-FOR-FILE
	         DO
		 (PPRINT FORM FILE))));1Changed from GRIND-TOP-LEVEL - Profile 2.2 -dlc*
      (WHEN (W::MOUSE-CONFIRM
	  (FORMAT () "Do you want to include a load of your PROFILE file ~
                                  in your LOGIN initialization file?")
	  "Click here to include the load of it; otherwise move mouse away.")
    
    (LET ((INIT-FILE-PATHNAME (INIT-FILE-PATHNAME "login")))
;      (WITH-OPEN-FILE (ISTREAM INIT-FILE-PATHNAME '(:IN :NOERROR))
; These are the new Release3 options for OPEN
      (WITH-OPEN-FILE (ISTREAM INIT-FILE-PATHNAME :CHARACTERS T :DIRECTION :INPUT :ERROR NIL)
	(IF (ERRORP ISTREAM)
	  (UNLESS (CONDITION-TYPEP ISTREAM 'FS:FILE-NOT-FOUND)
	    (FERROR "Error: ~a" ISTREAM)))            1;Bomb on any other error.*
	1;; Now, open a new version of the file for writing.*
	1;; Since we're doing simple character copying here, our Lisp-Mode doesn't matter.*
	(WITH-OPEN-FILE-RETRY (OSTREAM (INIT-FILE-PATHNAME FS:FILE-ERROR) :DIRECTION :OUTPUT)
	   (UNLESS (ERRORP ISTREAM)                   1;Copy file if it exists.*
	     (STREAM-COPY-UNTIL-EOF ISTREAM OSTREAM))
	   (FORMAT OSTREAM "~3%;;~%;;This loads the PROFILE init file.~%;;")
	   (FORMAT OSTREAM
		   "~%(when (fboundp 'profile:load-init-file) (profile:load-init-file ~s))~2%"
		   (send (fs:parse-pathname USER-SELECTED-FILE) :short-string-for-printing))
	   (CLOSE OSTREAM)))
      (WHEN (PROBE-FILE (SEND INIT-FILE-PATHNAME :NEW-TYPE :XLD))
	  (COMPILE-FILE INIT-FILE-PATHNAME))))))) 


(DEFUN STUPID-VARIABLE-REAL-VALUE (VARIABLE)
  (VARIABLE-CURRENT-VALUE VARIABLE)) 

;1;;Let the user know if the file doesn't exist -Profile 2.2-dlc*

(DEFUN LOAD-INIT-FILE (&OPTIONAL (INIT-FILE (INIT-FILE-PATHNAME *PROGRAM-NAME*)))
  "2Loads the current user's profile initialization file and performs any required
transformations based on those variables.*"
  ;1;Load the file*
  (UNLESS (LOAD INIT-FILE :VERBOSE () :IF-DOES-NOT-EXIST ())
    (W:NOTIFY ()
	       "When attempting to load your Profile initialization file (~a), the file was not found."
	       INIT-FILE))) 
 


(DEFUN CVV-CONSTRAINT-FUNCTION (WINDOW VARIABLE OLD-VALUE NEW-VALUE)
  "2This is the constraint function that is called each time a variable is changed.
Depending on the current variable class, secondary (special-purpose)
constraint functions may also be called.*"
  ;1;If setting the variable has any set effects (side effects),*
  ;1;it may take a while, so refresh the screen first.*
  (WHEN (MEMBER VARIABLE *VARIABLES-THAT-TAKE-A-LONG-TIME-TO-UPDATE* :TEST #'EQ)
    (SEND WINDOW :REFRESH))
  (PERFORM-REQUIRED-ACTIONS VARIABLE)
  ;1;Now check for special constraint functions*
  (LOOP FOR (FUNCTION . VARIABLE-CLASSES) IN *EXTRA-CONSTRAINT-FUNCTIONS*
	WHEN  (MEMBER (SEND (SEND WINDOW :SUPERIOR) :CURRENT-VARIABLE-CLASS)
		      VARIABLE-CLASSES :TEST #'EQ)
        DO
	(FUNCALL FUNCTION WINDOW VARIABLE OLD-VALUE NEW-VALUE))) 


(DEFUN PERFORM-REQUIRED-ACTIONS (&OPTIONAL VARIABLE)
  "2Perform any needed actions after setting or changing one or more
variables.  If VARIABLE is provided, changes are only made because of that variable.
IF VARIABLE is not provided, all actions will be performed based on the current state of
the profile variables.*"
  (IF (NOT (NULL VARIABLE))
    (SI::EVAL1 (GET VARIABLE 'SET-EFFECT))      ;1Eval doesn't work here*
    (PROGN
    (LOOP FOR VARIABLE IN (REMOVE-IF-NOT #'(LAMBDA (VAR)
					           (GET VAR 'SET-EFFECT))
					 (ALL-PROFILE-VARIABLES))
	  DO
          (SI::EVAL1 (GET VARIABLE 'SET-EFFECT)))))) 




(DEFUN PROFILE-VARIABLE-P (VARIABLE)
  "2Predicate checks whether or not VARIABLE has been defined as a
profile variable.*"
  (GET VARIABLE 'CLASSES)) 

;1;;This is used for testing*
;(DEFUN list-non-profile-variables (variable-list)
;  "2Lists all of the variables in VARIABLE-LIST that are not profile variables.*"
;  (LOOP for variable1 in variable-list
;	for variable = (CDR variable1)
;	WHEN (NOT (profile-variable-p variable))
;	collect variable
;	AND DO (FORMAT t "~%~s - ~s" variable (BOUNDP variable))
;	))



(DEFUN ALL-PROFILE-VARIABLES ()
  "2Returns a list of all of the Profile variables, with no element
occurring more than once.*"
  (LOOP WITH VARIABLES-INCLUDED = ()
	FOR CLASS IN *VARIABLE-CLASSES*
	FOR VARIABLES = (SYMBOL-VALUE (CLASS-VARIABLE CLASS))
	DO
        (LOOP FOR VARIABLE IN VARIABLES
	      UNLESS (MEMBER VARIABLE VARIABLES-INCLUDED :TEST #'EQ)
	      DO
	      (PUSH VARIABLE VARIABLES-INCLUDED))
	FINALLY (RETURN VARIABLES-INCLUDED))) 

(DEFUN kbd-arrest (&rest ignore &aux p r)
  2"Arrest the current who-line process when PROFILE:ARREST-CHARACTER is typed"*
  (IF (NULL (SETQ p w:last-who-line-process))
      (BEEP)
    (IF (SETQ r (SEND p :arrest-reasons))
	(DOLIST (x r)
	  (SEND p :revoke-arrest-reason x))
      (SEND p :arrest-reason :user))))

(DEFUN set-kbd-arrest (CHAR)
  2"Assign the character that will become the toggle-key for arrest/unarrest of the
current who-line process."*
  (SETQ w:kbd-global-asynchronous-characters
	(DELETE 'kbd-arrest w:kbd-global-asynchronous-characters
		:test #'(lambda (key item) (EQ key (SECOND item)))))
  (WHEN char
    (PUSH `(,(CHAR-INT char) kbd-arrest) w:kbd-global-asynchronous-characters)))