add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
156
CLTL2/CMLFILESYS
Normal file
156
CLTL2/CMLFILESYS
Normal file
@@ -0,0 +1,156 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "18-Oct-93 11:06:53" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFILESYS.;2" 8169
|
||||
|
||||
|previous| |date:| " 3-Aug-91 11:23:10" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFILESYS.;1"
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
|
||||
(PRETTYCOMPRINT CMLFILESYSCOMS)
|
||||
|
||||
(RPAQQ CMLFILESYSCOMS ((FUNCTIONS LISP:DIRECTORY LISP:FILE-AUTHOR LISP:FILE-LENGTH
|
||||
LISP:FILE-POSITION LISP:USER-HOMEDIR-PATHNAME LISP:FILE-WRITE-DATE)
|
||||
(FUNCTIONS LISP:PROBE-FILE LISP:RENAME-FILE LISP:DELETE-FILE)
|
||||
(PROP FILETYPE CMLFILESYS)))
|
||||
|
||||
(LISP:DEFUN LISP:DIRECTORY (PATHNAME)
|
||||
(LISP:WHEN (LISP::LOGICAL-PATHNAME-P PATHNAME)
|
||||
(LISP:SETQ PATHNAME (LISP:TRANSLATE-LOGICAL-PATHNAME PATHNAME)))
|
||||
(LET (GENERATOR FILE)
|
||||
(DECLARE (LISP:SPECIAL GENERATOR))
|
||||
(RESETLST
|
||||
(|if| (EQL \\MACHINETYPE \\MAIKO)
|
||||
|then| (RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY))))
|
||||
(LISP:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (LISP:NAMESTRING PATHNAME))
|
||||
NIL
|
||||
'(SORT RESETLST)))
|
||||
(|while| (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect| (PATHNAME FILE)))))
|
||||
|
||||
(LISP:DEFUN LISP:FILE-AUTHOR (LISP::FILE)
|
||||
|
||||
(* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.")
|
||||
|
||||
(LET ((LISP::AUTHOR (GETFILEINFO LISP::FILE 'AUTHOR)))
|
||||
(LISP:IF LISP::AUTHOR
|
||||
(COERCE LISP::AUTHOR 'LISP:SIMPLE-STRING)
|
||||
NIL)))
|
||||
|
||||
(LISP:DEFUN LISP:FILE-LENGTH (FILE-STREAM)
|
||||
(|if| (AND (STREAMP FILE-STREAM)
|
||||
(OPENP FILE-STREAM))
|
||||
|then| (GETEOFPTR FILE-STREAM)))
|
||||
|
||||
(LISP:DEFUN LISP:FILE-POSITION (LISP::FILE-STREAM &OPTIONAL (LISP:POSITION NIL LISP::POSITIONP)
|
||||
)
|
||||
(LISP:UNLESS (STREAMP LISP::FILE-STREAM)
|
||||
(\\ILLEGAL.ARG LISP::FILE-STREAM))
|
||||
(LISP:IF LISP::POSITIONP
|
||||
(LISP:IF (RANDACCESSP LISP::FILE-STREAM)
|
||||
(PROGN (SETFILEPTR LISP::FILE-STREAM (CASE LISP:POSITION
|
||||
(:START 0)
|
||||
(:END (GETEOFPTR LISP::FILE-STREAM))
|
||||
(T LISP:POSITION)))
|
||||
T)
|
||||
NIL)
|
||||
(GETFILEPTR LISP::FILE-STREAM)))
|
||||
|
||||
(LISP:DEFUN LISP:USER-HOMEDIR-PATHNAME (&OPTIONAL HOST)
|
||||
(DECLARE (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))
|
||||
(LISP:IF (MACHINETYPE 'MAIKO)
|
||||
(LISP:IF (AND HOST (LISP:STRING-NOT-EQUAL (STRING HOST)
|
||||
(UNIX-GETPARM "HOSTNAME")))
|
||||
NIL
|
||||
(LISP:MAKE-PATHNAME :HOST :DSK :DIRECTORY (UNPACKFILENAME.STRING (UNIX-GETENV "HOME")
|
||||
'DIRECTORY
|
||||
'RETURN)))
|
||||
(PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))))
|
||||
|
||||
(LISP:DEFUN LISP:FILE-WRITE-DATE (FILE)
|
||||
|
||||
(* |;;| "Return file's creation date, or NIL if it doesn't exist.")
|
||||
|
||||
(* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time")
|
||||
|
||||
(LET ((TN (LISP:PROBE-FILE FILE)))
|
||||
(LISP:WHEN TN
|
||||
(%CONVERT-INTERNAL-TIME-TO-CLUT (GETFILEINFO TN 'ICREATIONDATE)))))
|
||||
|
||||
(LISP:DEFUN LISP:PROBE-FILE (FILE)
|
||||
|
||||
(* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.")
|
||||
|
||||
(LISP:TYPECASE FILE
|
||||
(STREAM (IF (OPENP FILE)
|
||||
THEN (PATHNAME (FETCH (STREAM FULLNAME) OF FILE))
|
||||
ELSE (LET ((NAMESTRING-IF-EXISTS (INFILEP (FETCH (STREAM FULLNAME)
|
||||
OF FILE))))
|
||||
(AND NAMESTRING-IF-EXISTS (PATHNAME NAMESTRING-IF-EXISTS)))))
|
||||
(LISP:LOGICAL-PATHNAME (LISP:PROBE-FILE (LISP:TRANSLATE-LOGICAL-PATHNAME FILE)))
|
||||
(T (LET ((INFILEP (\\GETFILENAME FILE 'OLD)))
|
||||
(IF INFILEP
|
||||
THEN (PATHNAME INFILEP)
|
||||
ELSE NIL)))))
|
||||
|
||||
(LISP:DEFUN LISP:RENAME-FILE (LISP::FILE LISP::NEW-NAME)
|
||||
|
||||
(* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.")
|
||||
|
||||
(* |;;;| "NEW MESSINESS resulting from acceptance of logical-pathnames: the CLtL2 spec for the first argument, (MERGE-PATHNAMES NEW-NAME FILE), makes no sense if either of FILE or NEW-NAME is a logical-pathname, since the logical-to-normal translation process can do arbitrary weird stuff. Therefore, if either argument is a logical-pathname, we punt and return the new truename as the first argument.")
|
||||
|
||||
(LET* ((LISP::LOGICAL-USED? NIL)
|
||||
(LISP::OLD-PATHNAME (LISP:IF (LISP::LOGICAL-PATHNAME-P LISP::FILE)
|
||||
(PROGN (LISP:SETQ LISP::LOGICAL-USED? T)
|
||||
(LISP:TRANSLATE-LOGICAL-PATHNAME LISP::FILE))
|
||||
(PATHNAME LISP::FILE)))
|
||||
(LISP::NEW-FULLNAME))
|
||||
(LISP:WHEN (LISP::LOGICAL-PATHNAME-P LISP::NEW-NAME)
|
||||
(LISP:SETQ LISP::LOGICAL-USED? T LISP::NEW-NAME (LISP:TRANSLATE-LOGICAL-PATHNAME
|
||||
LISP::NEW-NAME)))
|
||||
(IF (STREAMP LISP::FILE)
|
||||
THEN (IF (OPENP LISP::FILE)
|
||||
THEN (LISP:ERROR "Renaming open streams is not supported: ~S"
|
||||
LISP::FILE)
|
||||
ELSE (LISP:SETQ LISP::NEW-FULLNAME (RENAMEFILE (LISP:SETQ
|
||||
LISP::FILE
|
||||
(FETCH (STREAM
|
||||
FULLNAME
|
||||
)
|
||||
OF LISP::FILE))
|
||||
LISP::NEW-NAME)))
|
||||
ELSE
|
||||
|
||||
(* |;;| "IL:RENAMEFILE will accept logical-pathnames")
|
||||
|
||||
(LISP:SETQ LISP::NEW-FULLNAME (RENAMEFILE (LISP:IF LISP::LOGICAL-USED?
|
||||
LISP::OLD-PATHNAME
|
||||
LISP::FILE)
|
||||
LISP::NEW-NAME)))
|
||||
(IF LISP::NEW-FULLNAME
|
||||
THEN (LISP:VALUES (LISP:IF LISP::LOGICAL-USED?
|
||||
(PATHNAME LISP::NEW-FULLNAME)
|
||||
(LISP:MERGE-PATHNAMES LISP::NEW-NAME LISP::FILE))
|
||||
LISP::OLD-PATHNAME
|
||||
(PATHNAME LISP::NEW-FULLNAME))
|
||||
ELSE (LISP:ERROR "Rename failed"))))
|
||||
|
||||
(LISP:DEFUN LISP:DELETE-FILE (FILE)
|
||||
|
||||
(* * "Delete the specified file.")
|
||||
|
||||
(LET ((TN (LISP:PROBE-FILE FILE)))
|
||||
(LISP:WHEN (STREAMP FILE)
|
||||
(LISP:CLOSE FILE :ABORT T))
|
||||
(LISP:IF TN
|
||||
(LET ((NS (INTERLISP-NAMESTRING TN)))
|
||||
(LISP:UNLESS (DELFILE NS)
|
||||
(LISP:ERROR "Could not delete the file ~S" FILE)))
|
||||
(LISP:UNLESS (STREAMP FILE)
|
||||
(LISP:ERROR "File to be deleted does not exist: ~S" FILE))))
|
||||
T)
|
||||
|
||||
(PUTPROPS CMLFILESYS FILETYPE LISP:COMPILE-FILE)
|
||||
(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
Reference in New Issue
Block a user