(FILECREATED "27-Aug-85 13:31:25" {TOPAZ}</U1/XEROX/OSOURCES/>EXECFNS.;2
 10505  

      changes to:  (FNS KDELETE)
		   (LISPXMACROS kd KD)

      previous date: "19-Aug-85 09:05:04" 
{TOPAZ}</U1/XEROX/OSOURCES/>EXECFNS.;1)


(* Copyright (c) 1983, 1984, 1985 by Jeffrey S. Shulman
. All rights reserved.)

(PRETTYCOMPRINT EXECFNSCOMS)

(RPAQQ EXECFNSCOMS
 ((INITVARS (*LOGICAL.DEFINITIONS* NIL))
	(LISPXMACROS conn CONN def DEF def? DEF? dir DIR ty TY kd KD del 
		     DEL)
	(FNS DEFINE.LOGICAL.DEVICE LOGICAL? SHOW.LOGICAL.DEFINITIONS 
	     FILE.NAME.COMPAREFN KDELETE DEFAULTFILE)
	(ADVISE (* Advise useful functions to use logical names and 
		   possible file defaults)
		INFILE INFILEP OUTFILE OUTFILEP OPENSTREAM OPENFILE 
		COPYFILE)))

(RPAQ? *LOGICAL.DEFINITIONS*
 NIL)

(ADDTOVAR LISPXMACROS
 [conn (/CNDIR (LOGICAL? (CAR LISPXLINE))
				    (AND (LISTP (CDR LISPXLINE))
					 (PROG1 (CADR LISPXLINE)
						(FRPLACA (CDR LISPXLINE]
	  [CONN (/CNDIR (LOGICAL? (CAR LISPXLINE))
			(AND (LISTP (CDR LISPXLINE))
			     (PROG1 (CADR LISPXLINE)
				    (FRPLACA (CDR LISPXLINE]
	  (def (DEFINE.LOGICAL.DEVICE (CAR LISPXLINE)
				      (CADR LISPXLINE)))
	  (DEF (DEFINE.LOGICAL.DEVICE (CAR LISPXLINE)
				      (CADR LISPXLINE)))
	  (def? (SHOW.LOGICAL.DEFINITIONS (CAR LISPXLINE)))
	  (DEF? (SHOW.LOGICAL.DEFINITIONS (CAR LISPXLINE)))
	  [dir (DODIR (CONS (OR (LOGICAL? (CAR LISPXLINE))
				(QUOTE *.*;*))
			    (CDR LISPXLINE]
	  [DIR (DODIR (CONS (OR (LOGICAL? (CAR LISPXLINE))
				(QUOTE *.*;*))
			    (CDR LISPXLINE]
	  [ty (RESETVAR **COMMENT**FLG NIL
			(COPYALLBYTES (LOGICAL? (CAR LISPXLINE))
				      (OR (DEFAULTFILE
					    (LOGICAL? (CADR LISPXLINE))
					    (LOGICAL? (CAR LISPXLINE)))
					  T)
				      (CADDR LISPXLINE]
	  [TY (RESETVAR **COMMENT**FLG NIL
			(COPYALLBYTES (LOGICAL? (CAR LISPXLINE))
				      (OR (DEFAULTFILE
					    (LOGICAL? (CADR LISPXLINE))
					    (LOGICAL? (CAR LISPXLINE)))
					  T)
				      (CADDR LISPXLINE]
	  (kd (KDELETE (LOGICAL? (CAR LISPXLINE))
		       (CADR LISPXLINE)))
	  (KD (KDELETE (LOGICAL? (CAR LISPXLINE))
		       (CADR LISPXLINE)))
	  (del (DODIR (CONS (LOGICAL? (CAR LISPXLINE))
			    (CDR LISPXLINE))
		      (QUOTE (DELETE))
		      ""
		      (QUOTE L)))
	  (DEL (DODIR (CONS (LOGICAL? (CAR LISPXLINE))
			    (CDR LISPXLINE))
		      (QUOTE (DELETE))
		      ""
		      (QUOTE L))))

(ADDTOVAR LISPXCOMS
 CONN DIR TY DEL)
(DEFINEQ

(DEFINE.LOGICAL.DEVICE

  [LAMBDA (LOGICAL.NAME FILE)                (* jss: "30-Jun-84 12:49")


          (* * This command implements the TOPS-20 DEFINE command. The ALIST of 

	  LOGICAL.NAME and FILE will be stored on *LOGICAL.DEFINITIONS*.

	  The LISPX macros CONN, TY and SEE have been modified to call LOGICAL? which will 

	  translate any known logical names into full file names.)



    (PROG (ALIST)
          (SETQ LOGICAL.NAME (U-CASE LOGICAL.NAME))
          (COND
	    [(SETQ ALIST (FASSOC LOGICAL.NAME *LOGICAL.DEFINITIONS*))
                                             (* It already exists.

					     Redefine or remove.)

	      (COND
		(FILE [OR (AND *LOGICAL.DEFINITIONS*
			       (PUTASSOC LOGICAL.NAME FILE 
					 *LOGICAL.DEFINITIONS*))
			  (SETQ *LOGICAL.DEFINITIONS*
			    (LIST (CONS LOGICAL.NAME FILE]
		      (printout
 T LOGICAL.NAME " redefined to be " FILE T))
		(T (DREMOVE ALIST *LOGICAL.DEFINITIONS*)
		   (printout
 T LOGICAL.NAME " removed." T]
	    (T [OR (AND *LOGICAL.DEFINITIONS* (PUTASSOC LOGICAL.NAME FILE 
						 *LOGICAL.DEFINITIONS*))
		   (SETQ *LOGICAL.DEFINITIONS* (LIST (CONS LOGICAL.NAME 
							   FILE]
	       (printout
 T LOGICAL.NAME " defined to be " FILE T)))
          (RETURN T])

(LOGICAL?

  [LAMBDA (FILENAME)                         (* jss: "25-Jul-85 14:49")


          (* * Replaces any known device names on *LOGICAL.DEFINITIONS* by their full file names, returning the file name.)



    (
PROG
 (DEVICE DEVICEFILE TEMP)
          (
RETURN
 (
COND

		    ((
NULL
 (
ATOM
 FILENAME))
		      FILENAME)
		    ([
SETQ
 DEVICE (
U-CASE
 (
FILENAMEFIELD
 FILENAME
							 (
QUOTE
 DEVICE]
		      (
COND

			((
SETQ
 DEVICEFILE (
CDR
 (
FASSOC
 DEVICE 
						 *LOGICAL.DEFINITIONS*)))
                                             (* Construct the new file name)

			  (
PACKFILENAME
 (
QUOTE
 BODY)
					DEVICEFILE
					(
QUOTE
 DEVICE)
					NIL
					(
QUOTE
 BODY)
					FILENAME))
			(T FILENAME)))
		    (T FILENAME])

(SHOW.LOGICAL.DEFINITIONS

  [LAMBDA (DEVICE)                           (* jss: "30-Jun-84 12:49")


          (* * This function will list the logical definition of DEVICE.

	  If DEVICE is NIL or * then all logical definitions will be shown.)



    (PROG (DEFLIST)
          (SETQ DEVICE (U-CASE DEVICE))
          [COND
	    ((OR (NULL DEVICE)
		 (EQ DEVICE (QUOTE *)))
	      (SETQ DEFLIST *LOGICAL.DEFINITIONS*))
	    (T (SETQ DEFLIST (LIST (FASSOC DEVICE *LOGICAL.DEFINITIONS*]
                                             (* First see if there is anything to 

					     print.)

          (COND
	    ([AND (NULL (CAR DEFLIST))
		  (OR (NULL DEVICE)
		      (EQ DEVICE (QUOTE *]
	      (printout
 T "No logical definitions stored." T)
	      (RETURN NIL))
	    ((NULL (CAR DEFLIST))
	      (printout
 T "No logical definition found for " DEVICE T)
	      (RETURN NIL)))
          (MAPC [SORT DEFLIST (FUNCTION (LAMBDA (A B)
			  (ALPHORDER (CAR A)
				     (CAR B]
		(FUNCTION (LAMBDA (PAIR)
		    (printout
 T (CAR PAIR)
			      " defined as "
			      (CDR PAIR)
			      T])

(FILE.NAME.COMPAREFN

  [LAMBDA (FILE1 FILE2)                      (* jss: " 5-Jun-85 15:19")


          (* * This function is used to by SORT to sort two file names. It uses ALPHORDER unless the name and extention fields

	  are equal and there is a version number. In that case it uses ILESSP.)



    (
COND

      ([
OR
 (
NEQ
 (
FILENAMEFIELD
 FILE1 (
QUOTE
 NAME))
		(
FILENAMEFIELD
 FILE2 (
QUOTE
 NAME)))
	   (
NEQ
 (
FILENAMEFIELD
 FILE1 (
QUOTE
 EXTENSION))
		(
FILENAMEFIELD
 FILE2 (
QUOTE
 EXTENSION)))
	   (
NULL
 (
FILENAMEFIELD
 FILE1 (
QUOTE
 VERSION)))
	   (
NULL
 (
FILENAMEFIELD
 FILE2 (
QUOTE
 VERSION]
	(
ALPHORDER
 FILE1 FILE2))
      (T (
ILESSP
 (
FILENAMEFIELD
 FILE1 (
QUOTE
 VERSION))
		 (
FILENAMEFIELD
 FILE2 (
QUOTE
 VERSION])

(KDELETE

  [LAMBDA (FILES NVERSIONS)                  (* jss: "27-Aug-85 13:31")


          (* * This function performs the same function as the TOPS-20 KDELETE command. It is also invoked by the KD 

	  lispxmacro. It is *NOT* undoable. If NVERSIONS is non-NIL then it leaves the last NVERSIONS of the file.)



    (
PROG
 (DELETE.LIST FILE.LST TEMP)
          (
OR
 (
AND
 (
NUMBERP
 NVERSIONS)
		   (
IGEQ
 NVERSIONS 0))
	      (
SETQ
 NVERSIONS 1))

          (* * WHEN is for UNIX since it has no version numbers)



          [for
 F in
 (
SORT
 (
DIRECTORY
 FILES)
			  (
FUNCTION
 FILE.NAME.COMPAREFN))
	     when
 (
FILENAMEFIELD
 F (
QUOTE
 VERSION))
	     do
 [
COND

		  ([
AND
 (
EQUAL
 (
FILENAMEFIELD
 (
CAR
 FILE.LST)
					      (
QUOTE
 HOST))
			       (
FILENAMEFIELD
 F (
QUOTE
 HOST)))
			(
EQUAL
 (
FILENAMEFIELD
 (
CAR
 FILE.LST)
					      (
QUOTE
 NAME))
			       (
FILENAMEFIELD
 F (
QUOTE
 NAME)))
			(
EQUAL
 (
FILENAMEFIELD
 (
CAR
 FILE.LST)
					      (
QUOTE
 EXTENSION))
			       (
FILENAMEFIELD
 F (
QUOTE
 EXTENSION]
		    (
SETQ
 FILE.LST (
CONS
 F FILE.LST)))
		  (T (
AND
 FILE.LST (
SETQ
 DELETE.LIST
			    (
APPEND
 (
FNTH
 FILE.LST (
ADD1
 NVERSIONS))
				    DELETE.LIST)))
		     (
SETQ
 FILE.LST (
LIST
 F]
	     finally
 (
AND
 FILE.LST (
SETQ
 DELETE.LIST
			    (
APPEND
 (
FNTH
 FILE.LST (
ADD1
 NVERSIONS))
				    DELETE.LIST]
          (
AND
 (
NULL
 DELETE.LIST)
	       (
RETURN
 NIL))
          (printout
 T 3 (
PACKFILENAME
 (
QUOTE
 HOST)
				      (
FILENAMEFIELD
 (
CAR
 DELETE.LIST)
						     (
QUOTE
 HOST))
				      (
QUOTE
 DIRECTORY)
				      (
FILENAMEFIELD
 (
CAR
 DELETE.LIST)
						     (
QUOTE
 DIRECTORY)))
		    T)
          (for
 FILE in
 (
REVERSE
 DELETE.LIST)
	     do
 (printout
 T (
FILENAMEFIELD
 FILE (
QUOTE
 NAME))
			  "." # (
AND
 (
SETQ
 TEMP (
FILENAMEFIELD

					 FILE
					 (
QUOTE
 EXTENSION)))
				     (
PRIN1
 TEMP))
			  ";"
			  (
FILENAMEFIELD
 FILE (
QUOTE
 VERSION))
			  21
			  (
COND

			    ((
DELFILE
 FILE)
			      "deleted")
			    (T "can't delete"))
			  T))
          (
RETURN
 NIL])

(DEFAULTFILE

  (LAMBDA (FILE1 FILE2)                      (* jss: " 2-APR-83 16:59")


          (* * This function returns the file name FILE1 with the file NAME and EXTENSION 

	  field filled in from FILE2 if empty.)



    (COND
      (FILE1 (PACKFILENAME (APPEND (UNPACKFILENAME FILE1)
				   (LIST (QUOTE NAME)
					 (FILENAMEFIELD FILE2
							(QUOTE NAME)))
				   (LIST (QUOTE EXTENSION)
					 (FILENAMEFIELD FILE2
							(QUOTE EXTENSION)))
				   )))
      (T NIL))))
)

(PUTPROPS INFILE READVICE
 [NIL (BEFORE NIL (SETQ FILE (LOGICAL? FILE])

(PUTPROPS INFILEP READVICE
 [NIL (BEFORE NIL (SETQ FILE (LOGICAL? FILE])

(PUTPROPS OUTFILE READVICE
 [NIL (BEFORE NIL (SETQ FILE (LOGICAL? FILE])

(PUTPROPS OUTFILEP READVICE
 [NIL (BEFORE NIL (SETQ FILE (LOGICAL? FILE])

(PUTPROPS OPENSTREAM READVICE
 [NIL (BEFORE NIL (SETQ FILE (LOGICAL? FILE])

(PUTPROPS OPENFILE READVICE
 [NIL (BEFORE NIL (SETQ FILE (LOGICAL? FILE])

(PUTPROPS COPYFILE READVICE
 [NIL
	    (BEFORE NIL (PROGN [OR TOFILE (SETQ TOFILE
						(FILENAMEFIELD
						  FROMFILE
						  (QUOTE NAME]
			       (COND [[AND (NULL (FILENAMEFIELD
						   TOFILE
						   (QUOTE NAME)))
					   (EQ (QUOTE FLOPPY)
					       (FILENAMEFIELD
						 TOFILE
						 (QUOTE HOST]
				      (* If FLOPPY.MODE is SYSOUT then 
					 leave it, otherwise default it)
				      (AND (NEQ (QUOTE SYSOUT)
						(FLOPPY.MODE))
					   (SETQ TOFILE
						 (DEFAULTFILE
						   (LOGICAL? TOFILE)
						   (LOGICAL? FROMFILE]
				     (T (* Default it)
					(SETQ TOFILE (DEFAULTFILE
						(LOGICAL? TOFILE)
						(LOGICAL? FROMFILE])
(READVISE INFILE INFILEP OUTFILE OUTFILEP OPENSTREAM OPENFILE COPYFILE)
(PUTPROPS EXECFNS COPYRIGHT ("Jeffrey S. Shulman" 1983 1984 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2426 9218 (DEFINE.LOGICAL.DEVICE 2436 . 3715) (LOGICAL? 3717
 . 4505) (SHOW.LOGICAL.DEFINITIONS 4507 . 5620) (FILE.NAME.COMPAREFN 5622
 . 6439) (KDELETE 6441 . 8723) (DEFAULTFILE 8725 . 9216)))))
STOP