(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Sep-2023 09:22:55" {DSK}briggs>Projects>medley>sources>UFS.;2 78813 :EDIT-BY "briggs" :CHANGES-TO (FNS \UFSCloseFile) :PREVIOUS-DATE "29-Mar-2022 11:29:33" {DSK}briggs>Projects>medley>sources>UFS.;1) (PRETTYCOMPRINT UFSCOMS) (RPAQQ UFSCOMS [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) UFS) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP) DIRECTORY FILEIO)) (INITVARS (\UFS.DEFAULT.EOLC NIL)) (COMS (* ; "Create FDEV function.") (FNS \UFSCreateDevice \UFS.CREATE.DEVICE \UFSOpenDevice \UFSCloseDevice) (INITVARS (\UFSdevice) (\UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor"))) (GLOBALVARS \UFSdevice \UFStopMonitor)) (COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS UFSGENFILESTATE))) (INITRECORDS UFSGENFILESTATE) (SYSRECORDS UFSGENFILESTATE)) (COMS (* ; "UNIX File System's FDEV methods.") (FNS \UFSOpenFile \UFS.OPENP \UFS.RECOGNIZE.FILE \UFS.DIRECTORY.NAME \UFSCloseFile \UFSGetFileName \UFSDeleteFile \UFSRenameFile \UFSReadPages \UFSWritePages \UFSTruncateFile \UFSDirectoryNameP \UFSEventFn \UFSGetFileInfo \UFS.CREATE.PROPS \UFSSetFileInfo \UFSGenerateFiles \UFS.NEXTFILEFN \UFS.FILEINFOFN \UFS.VALID.PROPP \UFS.REGISTER.GFS \UFS.UNREGISTER.GFS \UFS.ABORT.DIRECTORY \UFS.ABORT.CL-DIRECTORY \UFS.CLEANUP.GFS.TABLE)) (COMS (* ; "File Name parsing") (FNS \UFSMakeUnixFormatName \UFSParseNameString \UFSParse-Directory \UFS.PARSE.BODY \UFS.ADJUST.HOST \UFS.FULLNAME \UFS.ADD.HOST.FIELD \UFS.REMOVE.HOST.FIELD \UFS.HANDLE.RELATIVEDIRECTORY) (INITVARS (\UFSDefaultDelimiter "/") (\UFSDefaultDelimiterChar '/) (\UFSDefaultConnDir "./") (\UFSBeforeType '%.) (\UFSBeforeVersion ';) (\UFSDeviceDelimiter '}) (\DSK.DEFAULT.DIRECTORY "~>") (\UFS.DEFAULT.DIRECTORY ".>") (*DSK-UPPER-CASE-FILE-NAMES* NIL) (\UFS.GFS.TABLE (HASHARRAY 20)) (*DSK-HOST-NAME* "{DSK}") (*UFS-HOST-NAME* "{UNIX}")) (GLOBALVARS \UFSDeviceDelimiter \UFSBeforeVersion \UFSBeforeType \UFSDefaultConnDir \UFSDefaultDelimiterChar \UFSDefaultDelimiter \DSK.DEFAULT.DIRECTORY \UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE *DSK-HOST-NAME* *UFS-HOST-NAME*)) (COMS (* ;; "Change UNIX Curent Directory") (FNS CHDIR) (* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") (FNS \DEVICEFILE.EOSERROR) (* ;; "flush/revalidate unvisible stream, like dribble files.") (FNS \UNVISIBLE.PAGED.REVALIDATEFILELST \UNVISIBLE.FLUSH.OPEN.STREAMS) (* ;; " Error handler") (FNS \UFSError)) (COMS (* ; "File Type and EOL handling") (FNS \UFSGetFileType \UFSSetFileType \UFSeol) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DEFAULTFILETYPE 'BINARY) (DEFAULTFILETYPELIST '((NIL . BINARY) (C . TEXT) (H . TEXT) (EL . TEXT) (IM . TEXT) (LISP . TEXT) (LSP . TEXT) (O . BINARY) (OUT . BINARY) (LCOM . BINARY) (DFASL . BINARY) (DRIBBLE . TEXT) (TTY . TEXT) (TXT . TEXT) (Z . BINARY) (HTML . TEXT) (HTM . TEXT) (TEX . TEXT) (PS . TEXT) (PDF . TEXT) (DCOM . BINARY) (SKETCH . BINARY) (TEDIT . BINARY) (TED . BINARY) (DISPLAYFONT . BINARY) (AC . BINARY) (WD . BINARY) (IP . BINARY) (INTERPRESS . BINARY) (PRESS . BINARY) (PSCFONT . BINARY) (RST . BINARY) (BIN . BINARY) (MAIL . BINARY) (SYSOUT . BINARY) (SYSOUT.Z . BINARY) (TAR . BINARY) (INDEX . BINARY) (HASH . BINARY) (NOTEFILE . BINARY) (Z . BINARY) (VIRTUALMEM . BINARY) (VM . BINARY] (GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST)) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * UFSDECLS)) (COMS (* ; "Filetypepatch functions. ") (FNS \UFSGetPrintFileType \UFSGetFileTypeConfirm \UFSPrintTypeMenu) (* ; "for hardcopy") (FNS \UFStoOtherCopyMess \UFStoOtherRenameMess) (* ; "for copyfile,renamefile") (INITVARS (FileTypeConfirmFlg T)) (GLOBALVARS FileTypeMenu FileTypeConfirmFlg)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (PUTPROPS UFS FILETYPE :BCOMPL) (PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILESLOAD (LOADCOMP) DIRECTORY FILEIO) ) (RPAQ? \UFS.DEFAULT.EOLC NIL) (* ; "Create FDEV function.") (DEFINEQ (\UFSCreateDevice (LAMBDA NIL (* ; "Edited 27-Feb-89 18:28 by bvm") (* ;;; "Creates and remembers the local hard disk file device, but does not open the device or any of its associated directories.") (if (AND (BOUNDP (QUOTE \UFSdevice)) (type? FDEV \UFSdevice)) then \UFSdevice else (SETQ \UFSdevice (\UFS.CREATE.DEVICE (QUOTE UNIX) (FUNCTION \UFSEventFn))))) ) (\UFS.CREATE.DEVICE (LAMBDA (NAME EVENTFN) (* ; "Edited 27-Feb-89 18:28 by bvm") (\MAKE.PMAP.DEVICE (create FDEV NODIRECTORIES _ T DEVICENAME _ NAME CLOSEFILE _ (FUNCTION \UFSCloseFile) DELETEFILE _ (FUNCTION \UFSDeleteFile) RENAMEFILE _ (FUNCTION \UFSRenameFile) TRUNCATEFILE _ (FUNCTION \UFSTruncateFile) GETFILEINFO _ (FUNCTION \UFSGetFileInfo) GETFILENAME _ (FUNCTION \UFSGetFileName) OPENFILE _ (FUNCTION \UFSOpenFile) READPAGES _ (FUNCTION \UFSReadPages) SETFILEINFO _ (FUNCTION \UFSSetFileInfo) WRITEPAGES _ (FUNCTION \UFSWritePages) REOPENFILE _ (FUNCTION \UFSOpenFile) GENERATEFILES _ (FUNCTION \UFSGenerateFiles) EVENTFN _ EVENTFN DIRECTORYNAMEP _ (FUNCTION \UFSDirectoryNameP) HOSTNAMEP _ (FUNCTION NILL) OPENP _ (FUNCTION \GENERIC.OPENP) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM)))) ) (\UFSOpenDevice (LAMBDA NIL (* ; "Edited 7-Apr-88 17:46 by masinter") (WITH.MONITOR \UFStopMonitor (LET ((DEV (\UFSCreateDevice))) (\DEFINEDEVICE (QUOTE UNIX) DEV) DEV))) ) (\UFSCloseDevice (LAMBDA NIL (* ; "Edited 13-Aug-87 14:15 by hayata") (WITH.MONITOR \UFStopMonitor (\REMOVEDEVICE \UFSdevice) NIL)) ) ) (RPAQ? \UFSdevice ) (RPAQ? \UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \UFSdevice \UFStopMonitor) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (DATATYPE UFSGENFILESTATE ( (* ;;  "Holds the file-directory-generator state for %"Unix%" file system enumeration.") (FINFOID FIXP) (FILEID FIXP) (* ;  "Current file in list of 1 to TOTALNUM files.") (TOTALNUM FIXP) DIRECTORY DEV (PROPP FLAG) THISFILE (ERRONO FIXP) NAME (LENGTH FIXP) (WDATE FIXP) (RDATE FIXP) (PROTECTION FIXP) AUTHOR (AULEN FIXP) SUBGENERATOR (* ; "Generator for an immediate subdirectory. Recursive function calls descend and return to lower depths") CURRENT-DEPTH (* ;  "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH") MAX-DEPTH (* ;  "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.") FILTER (* ; "The original undefaulted pattern") )) ) (/DECLAREDATATYPE 'UFSGENFILESTATE '(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER POINTER) '((UFSGENFILESTATE 0 FIXP) (UFSGENFILESTATE 2 FIXP) (UFSGENFILESTATE 4 FIXP) (UFSGENFILESTATE 6 POINTER) (UFSGENFILESTATE 8 POINTER) (UFSGENFILESTATE 8 (FLAGBITS . 0)) (UFSGENFILESTATE 10 POINTER) (UFSGENFILESTATE 12 FIXP) (UFSGENFILESTATE 14 POINTER) (UFSGENFILESTATE 16 FIXP) (UFSGENFILESTATE 18 FIXP) (UFSGENFILESTATE 20 FIXP) (UFSGENFILESTATE 22 FIXP) (UFSGENFILESTATE 24 POINTER) (UFSGENFILESTATE 26 FIXP) (UFSGENFILESTATE 28 POINTER) (UFSGENFILESTATE 30 POINTER) (UFSGENFILESTATE 32 POINTER) (UFSGENFILESTATE 34 POINTER)) '36) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'UFSGENFILESTATE '(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER POINTER) '((UFSGENFILESTATE 0 FIXP) (UFSGENFILESTATE 2 FIXP) (UFSGENFILESTATE 4 FIXP) (UFSGENFILESTATE 6 POINTER) (UFSGENFILESTATE 8 POINTER) (UFSGENFILESTATE 8 (FLAGBITS . 0)) (UFSGENFILESTATE 10 POINTER) (UFSGENFILESTATE 12 FIXP) (UFSGENFILESTATE 14 POINTER) (UFSGENFILESTATE 16 FIXP) (UFSGENFILESTATE 18 FIXP) (UFSGENFILESTATE 20 FIXP) (UFSGENFILESTATE 22 FIXP) (UFSGENFILESTATE 24 POINTER) (UFSGENFILESTATE 26 FIXP) (UFSGENFILESTATE 28 POINTER) (UFSGENFILESTATE 30 POINTER) (UFSGENFILESTATE 32 POINTER) (UFSGENFILESTATE 34 POINTER)) '36) (ADDTOVAR SYSTEMRECLST (DATATYPE UFSGENFILESTATE ((FINFOID FIXP) (FILEID FIXP) (TOTALNUM FIXP) DIRECTORY DEV (PROPP FLAG) THISFILE (ERRONO FIXP) NAME (LENGTH FIXP) (WDATE FIXP) (RDATE FIXP) (PROTECTION FIXP) AUTHOR (AULEN FIXP) SUBGENERATOR CURRENT-DEPTH MAX-DEPTH FILTER)) ) (* ; "UNIX File System's FDEV methods.") (DEFINEQ (\UFSOpenFile (LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 6-Jun-90 12:18 by nm") (* ;;; "Open a file.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG ((ACC (SELECTQ ACCESS (INPUT ACCESS-INPUT) (OUTPUT ACCESS-OUTPUT) (BOTH ACCESS-BOTH) (APPEND ACCESS-APPEND) ACCESS-OTHER)) (REC (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (SELECTQ ACCESS (INPUT RECOG-OLD) (OUTPUT RECOG-NEW) ((BOTH APPEND) RECOG-NEW-OLD) RECOG-OTHER))) (EOF-FN (FUNCTION \EOSERROR)) (ERRNO (CREATECELL \FIXP)) OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME CASE.CORRECT.FULLFILENAME) (SETQ CASE.CORRECT.NAME (if (type? STREAM FILE) then (COND ((fetch (UFSSTREAM FILEID) of FILE) (* ; "Already open--this really ought to be an error") (RETURN FILE)) (T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME) of FILE))) (SETQ STRM FILE) (* ; "Re use the old stream") (SUBSTRING FULLNAME (ADD1 (STRPOS "}" FULLNAME)))))) else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV))) (COND ((NOT CASE.CORRECT.NAME) (RETURN NIL)) ((AND (NULL OLDSTREAM) (EQ (fetch (FDEV DEVICENAME) of FDEV) (QUOTE DSK)) (SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV)) (SELECTQ ACCESS (INPUT (* ; "ok if other file is also input") (DIRTYABLE OTHER)) T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...") (CL:ERROR (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV)))) (SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV)) (* ;; "DSK cannot open a directory.") (AND (DSKP FDEV) (DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME) (PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.") (\UFSError CASE.CORRECT.NAME 23 FDEV))) (SETQ CDATE (CREATECELL \FIXP)) (SETQ BYTESIZE (CREATECELL \FIXP)) (SETQ FILEID (OR (\UFSOpenFile-C CASE.CORRECT.FULLFILENAME REC ACC CDATE BYTESIZE ERRNO) (RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV)))) (if (= (IPLUS BYTESIZE 0) -1) then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR)) (SETQ BYTESIZE 0) elseif (EQ ACCESS (QUOTE OUTPUT)) then (SETQ BYTESIZE 0)) (if STRM then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T)) (replace (STREAM DEVICE) of STRM with FDEV) (replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE)) (replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE)) (replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO))) (replace (STREAM VALIDATION) of STRM with CDATE) (replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN) else (SETQ STRM (create STREAM FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T) DEVICE _ FDEV EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE) EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE) EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO)) VALIDATION _ CDATE ENDOFSTREAMOP _ EOF-FN))) (replace (UFSSTREAM FILEID) of STRM with FILEID) (replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC (QUOTE CREATIONDATE) OTHERINFO)) then (IDATE (CADR CINFO)) else 0)) (replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME) (* ; "Save the case sensitive full file name for closef & getfileinfo.") (RETURN STRM)))) ) (\UFS.OPENP (LAMBDA (UNIXNAME DEV) (* ; "Edited 3-Mar-89 11:47 by bvm") (* ;; "Returns first open file having specified unix name") (for S in (fetch (FDEV OPENFILELST) of DEV) bind (COMPAREFN _ (if (EQ (fetch (FDEV DEVICENAME) of DEV) (QUOTE DSK)) then (* ; "We're case-insensitive, and it seems like not all functions return the correct Unix case") (FUNCTION STRING-EQUAL) else (* ; "Exact") (FUNCTION STREQUAL))) thereis (CL:FUNCALL COMPAREFN UNIXNAME (fetch (UFSSTREAM UNIXNAME) of S)))) ) (\UFS.RECOGNIZE.FILE (LAMBDA (FILENAME RECOG DEV) (* ; "Edited 13-Mar-90 11:19 by nm") (* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (ERRNO (CREATECELL \FIXP)) LEN) (SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV) (\UFS.REMOVE.HOST.FIELD FILENAME DEV) (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (NON RECOG-NON) RECOG-NEW-OLD) NAMEAREA ERRNO)) (COND ((FIXP LEN) (SUBSTRING NAMEAREA 1 LEN)) (T (\UFSError FILENAME ERRNO)))))) ) (\UFS.DIRECTORY.NAME (LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 1-Apr-90 23:36 by nm") (* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"ture%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"ture%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.") (if (STREQUAL DIRSTRING "<") then (RPLSTRING NAMEAREA 1 "<") 1 else (WITH.MONITOR (\UFSGetMonitor DEV) (CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV) DIRSTRING NAMEAREA (CREATECELL \FIXP))))) ) (\UFSCloseFile [LAMBDA (STREAMFILE) (* ; "Edited 16-Sep-2023 09:21 by briggs") (* ; "Edited 30-Mar-90 10:39 by nm") (* ; "return stream") (* ;;; "Closes the specified stream.") (* * WITH.MONITOR \UFStopMonitor) (* ;;; "Write out and dispense with buffers for this stream.") (\CLEARMAP STREAMFILE) (PROG ((DEVICE (fetch (STREAM DEVICE) of STREAMFILE)) (CDATE 0) (ERRNO (CREATECELL \FIXP)) (UNIXNAME (fetch (UFSSTREAM UNIXNAME) of STREAMFILE))) (if (OR (NULL UNIXNAME) (NULL (fetch (STREAM ACCESS) of STREAMFILE))) then (* ;  "Already closed! Somebody's trying to close us twice.") (RETURN NIL)) (if (DIRTYABLE STREAMFILE) then (* ; "Open for output") (FDEVOP 'TRUNCATEFILE DEVICE STREAMFILE) (SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE))) (RETURN (if (\UFSCloseFile-C UNIXNAME (fetch (UFSSTREAM FILEID) of STREAMFILE) CDATE ERRNO) then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL) (replace (UFSSTREAM CDATE) of STREAMFILE with NIL) (* ; "Clear open-file state") STREAMFILE else (\UFSError (fetch (STREAM FULLFILENAME) of STREAMFILE) ERRNO]) (\UFSGetFileName (LAMBDA (FILENAME RECOG DEV) (* ; "Edited 24-Feb-89 16:20 by bvm") (* ;; "Recognize filename, return full name") (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE FILENAME RECOG DEV) DEV T)) ) (\UFSDeleteFile (LAMBDA (FILENAME DEV) (* ; "Edited 30-Mar-90 10:46 by nm") (* ; "return deleted file name") (* ; "if error, return NIL") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAME (\UFS.RECOGNIZE.FILE FILENAME (QUOTE OLDEST) DEV))) (COND ((AND NAME (NOT (\UFS.OPENP NAME DEV))) (* ; "file found and not open, so try to delete") (LET ((ERRNO (CREATECELL \FIXP))) (COND ((\UFSDeleteFile-C (\UFS.REMOVE.HOST.FIELD NAME DEV) DEV ERRNO) (* ; "Success") (\UFS.FULLNAME NAME DEV T)) (T (* ; "Failure") (\UFSError NAME ERRNO DEV))))))))) ) (\UFSRenameFile (LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Apr-90 13:46 by nm") (if (NEQ OLD-DEVICE NEW-DEVICE) then (* ;; "Call the generic rename function. ") (LET ((FILE (\GENERIC.RENAMEFILE OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME))) (COND ((AND FILE (EQ \MACHINETYPE \MAIKO) FileTypeConfirmFlg) (* ; "print warnig message") (\UFStoOtherRenameMess OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME))) FILE) else (* ;; "UNIX file system rename.") (LET ((OLDUNIXNAME (\UFS.RECOGNIZE.FILE OLD-NAME (QUOTE OLD) OLD-DEVICE))) (if (AND OLDUNIXNAME (NOT (\UFS.OPENP OLDUNIXNAME OLD-DEVICE))) then (* ; "Old file is found and not open, so proceed") (LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME (QUOTE NEW) NEW-DEVICE)) (ERRNO (CREATECELL \FIXP))) (COND ((\UFSRenameFile-C (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME OLD-DEVICE) (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE) NEW-DEVICE ERRNO) (\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE)) (T (if (EQL (IPLUS ERRNO 0) 18) then (* ; "CrossDeviceError. Should be PARAMETER!") (\GENERIC.RENAMEFILE OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) else (\UFSError (CONCAT OLDUNIXNAME " or " NEWUNIXNAME) ERRNO) NIL)))))))) ) (\UFSReadPages (LAMBDA (stream streamFirstPage buffers) (* ; "Edited 3-Mar-89 14:49 by bvm") (* ;;; "ARG0 -- stream : {stream} data type.") (* ;;; "ARG1 -- streamFirstPage : the 1st page number of file to read.") (* ;;; "ARG2 -- buffers : {VMEMPAGEP} or list of {VMEMPAGEP}. ") (* ; "Write out the buffers to the backing file.") (for buffer inside buffers as streamPageNumber from streamFirstPage bind (fileID _ (fetch (UFSSTREAM FILEID) of stream)) lastStreamPage offset ERRNO first (\UPDATEOF stream) (SETQ lastStreamPage (PLUS (fetch (STREAM EPAGE) of stream) (if (EQ 0 (fetch (STREAM EOFFSET) of stream)) then -1 else 0))) (SETQ ERRNO (CREATECELL \FIXP)) sum (if (LEQ streamPageNumber lastStreamPage) then (OR (\UFSReadPages-C fileID streamPageNumber buffer ERRNO) (\UFSError stream ERRNO) (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE stream)) (if (EQ streamPageNumber lastStreamPage) then (SETQ offset (fetch (STREAM EOFFSET) of stream)) (if (EQ offset 0) then (SETQ offset BYTESPERPAGE) else (\CLEARBYTES buffer offset (- BYTESPERPAGE offset))) offset else BYTESPERPAGE) else (\CLEARWORDS buffer WORDSPERPAGE) 0))) ) (\UFSWritePages (LAMBDA (stream streamFirstPage buffers) (* ; "Edited 3-Mar-89 14:50 by bvm") (* ;;; "ARG0 -- stream : {stream} data type. ") (* ;;; "ARG1 -- streamFirstPage : the 1st page number of file to write. ") (* ;;; "ARG2 -- buffers : {VMEMPAGEP} or list of {VMEMPAGEP}.") (LET ((CSIZE (IPLUS (ITIMES (fetch (STREAM CPAGE) of stream) (fetch (STREAM CBUFMAXSIZE) of stream)) (fetch (STREAM COFFSET) of stream))) (ESIZE (IPLUS (ITIMES (fetch (STREAM EPAGE) of stream) (fetch (STREAM CBUFMAXSIZE) of stream)) (fetch (STREAM EOFFSET) of stream))) REALPAGE REALOFFSET (ERRNO (CREATECELL \FIXP))) (if (IGREATERP ESIZE CSIZE) then (SETQ REALPAGE (fetch (STREAM EPAGE) of stream)) (SETQ REALOFFSET (fetch (STREAM EOFFSET) of stream)) else (SETQ REALPAGE (fetch (STREAM CPAGE) of stream)) (SETQ REALOFFSET (fetch (STREAM COFFSET) of stream))) (for buffer inside buffers as PageNumber from streamFirstPage bind (fileID _ (fetch (UFSSTREAM FILEID) of stream)) size do (SETQ size (COND ((EQ PageNumber REALPAGE) REALOFFSET) (T (fetch (STREAM CBUFMAXSIZE) of stream)))) (OR (\UFSWritePages-C fileID PageNumber buffer size ERRNO) (\UFSError stream ERRNO) (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE stream))))) ) (\UFSTruncateFile (LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 22-Aug-90 16:46 by nm") (* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.") (\UPDATEOF STREAM) (OR (FIXP PAGE#) (SETQ PAGE# (fetch (STREAM EPAGE) of STREAM))) (OR (FIXP OFFSET) (SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ; "Truncate size was set to PAGE# and OFFSET") (PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM) BYTESPERPAGE) (fetch (STREAM EOFFSET) of STREAM))) (needSize (+ (UNFOLD PAGE# BYTESPERPAGE) OFFSET)) (ERRNO (CREATECELL \FIXP))) (if (> needSize curEof) then (* ; "Push 0 to extend file.") (LET ((FILEPTR (\GETFILEPTR STREAM))) (\SETFILEPTR STREAM curEof) (to (- needSize curEof) do (\BOUT STREAM 0)) (\SETFILEPTR STREAM FILEPTR)) elseif T then (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed") (OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM) needSize ERRNO) (RETURN (\UFSError STREAM ERRNO))) else (RETURN)) (* ;; "Set new value to stream") (replace (STREAM EPAGE) of STREAM with PAGE#) (replace (STREAM EOFFSET) of STREAM with OFFSET) (LET ((DT (CREATECELL \FIXP))) (* ;; "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.") (if (\UFSGetFileInfo-C (fetch (UFSSTREAM UNIXNAME) of STREAM) ATTR-WDATE DT ERRNO) then (replace (STREAM VALIDATION) of STREAM with DT))))) ) (\UFSDirectoryNameP (LAMBDA (DIRSPEC DEV) (* ; "Edited 21-Sep-92 15:27 by jds") (* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.") (LET ((DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DEVICE)) "") (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DIRECTORY) (QUOTE RETURN)) (\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC (QUOTE RELATIVEDIRECTORY) (QUOTE RETURN)) DEV) (\UFS.DEFAULT.DIR DEV)))) NAMEAREA LEN) (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.") (COND (DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.") (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV)) (COND ((FIXP LEN) (* ; "LEN holds the length of the %"true%" name of DIRECTORY.") (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) DEV NIL)) (T NIL))) (T NIL)))) ) (\UFSEventFn (LAMBDA (Dev Event) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 3-May-90 17:35 by nm") (WITH.MONITOR \UFStopMonitor (SELECTQ Event ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\UFSCloseDevice) (SELECTQ (MACHINETYPE) ((MAIKO) (\UFSOpenDevice) (* ;; "revalidate open streams (should probably move this into the SELECTQ above) ") (\UNVISIBLE.PAGED.REVALIDATEFILELST Dev) (\PAGED.REVALIDATEFILELST Dev) (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL)))) (CLRHASH \UFS.GFS.TABLE)) NIL)) ((BEFORELOGOUT) (\UNVISIBLE.FLUSH.OPEN.STREAMS Dev) (* ; "flush output buffers.") (\FLUSH.OPEN.STREAMS Dev)) NIL))) ) (\UFSGetFileInfo (LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 30-Mar-90 12:27 by nm") (* ;;; "Get the value of the attribute for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") (* ;;; "Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME then (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (SIZE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then (FOLDHI BUFFER BYTESPERPAGE) else (\UFSError FILENAME ERRNO DEVICE))) (TYPE (\UFSGetFileType FILENAME)) ((CREATIONDATE WRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) (READDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) ((ICREATIONDATE IWRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) then (CL:SUBSEQ BUFFER 0 NAMESIZE) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) then (LET ((ALIST (ASSOC (QUOTE AUTHOR) BUFFER))) (* ; "Copy string out of buffer") (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) 0 NAMESIZE)) BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) NIL))))) ) (\UFS.CREATE.PROPS (LAMBDA NIL (* ; "Edited 2-Mar-89 12:10 by bvm") (* ;; "Returns a data structure suitable for passing to the GetFileInfo ALL routine") (BQUOTE ((LENGTH (\,@ (CREATECELL \FIXP))) (WDATE (\,@ (CREATECELL \FIXP))) (RDATE (\,@ (CREATECELL \FIXP))) (PROTECTION (\,@ (CREATECELL \FIXP))) (AUTHOR (\,@ (ALLOCSTRING MAX-UNAME-LEN)))))) ) (\UFSSetFileInfo (LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 30-Mar-90 12:31 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") (* ;;; " Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME then (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) (if (AND (STRINGP VALUE) (SETQ VALUE (IDATE VALUE))) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) ((ICREATIONDATE IWRITEDATE) (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) (PROTECTION (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) NIL))))) ) (\UFSGenerateFiles [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ;; "Edited 27-Mar-2022 15:55 by rmk: Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults") (* ;; "rmk; Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults") (* ;;  "Edited 25-Mar-2022 23:11 by rmk: Capture current free values of DEFAULTEXT and DEFAULTVERS") (* ;; "Edited 27-Sep-93 16:17 by jds") (DECLARE (SPECVARS DEFAULTEXT DEFAULTVERS)) (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) [PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) (DIRECTORY (OR (LISTGET PARSED 'DIRECTORY) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY) FDEV) (\UFS.DEFAULT.DIR FDEV))) (DEVICE (LISTGET PARSED 'DEVICE)) (NAME (OR (LISTGET PARSED 'NAME) "*")) (EXTENSION (OR (LISTGET PARSED 'EXTENSION) "*")) (VERSION (OR (LISTGET PARSED 'VERSION) "*")) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN (DEFAULTEXT (OR (LISTGET PARSED 'EXTENSION) DEFAULTEXT)) (DEFAULTVERS (OR (LISTGET PARSED 'VERSION) DEFAULTVERS))) (* ;; "rmk: uses the default below, don't want NIL if the pattern includes something else.") (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) [SETQ FILTER (COND ((STREQUAL DIRECTORY "<") (CONCAT "{" (LISTGET PARSED 'HOST) "}" (OR DEVICE "") "<" (PACKFILENAME.STRING 'NAME NAME 'EXTENSION EXTENSION 'VERSION VERSION))) (T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET PARSED 'HOST) 'DEVICE DEVICE 'NAME NAME 'EXTENSION EXTENSION 'VERSION VERSION] (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) [COND ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR] (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND [(< TOTALNUM 0) (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR] (T (COND ((ZEROP TOTALNUM) (RETURN (\NULLFILEGENERATOR))) (T [AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS 'RESETLST)) (FMEMB 'RESETLST OPTIONS)) (RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID] (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN ) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN )) CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH FILTER _ ( PACKFILENAME.STRING 'NAME NAME 'EXTENSION EXTENSION 'VERSION VERSION]) ]) (\UFS.NEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY) (* ;;  "Edited 27-Mar-2022 21:59 by rmk: Add FILTER to construct proper generator for subdirectories") (* ;; "Edited 7-Oct-93 14:31 by jds") (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") (* ; "") (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE)) FILENAME NAMELEN NEWNAME) (COND [SUBGEN (* ;; "We've climbed down through subdirectories, one more to go. The recursive calls and returns walk through subdirectories at lower depths. starting from the top at each call.") (* ;; "The property values are read out of the original, top-level generator, so we have to make sure that those fields are updated at each level up the chain, so they end up in the top-level generator.") (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (T (replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY] (T (* ;; "Not in a sub-directory, so act directly on the top-level generator.") (LET [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE] (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (CL:WHEN (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE ) 0 NAMELEN)) (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE) NEWNAME (fetch (UFSGENFILESTATE DEV) of GENFILESTATE)) ) (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with FILENAME) (COND ((= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T)) (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID) )) (COND ((AND (EQ (CHARCODE >) (NTHCHARCODE FILENAME -1)) (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) T) (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE) (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE ))) [SETQ SUBGEN (\GENERATEFILES (CONCAT FILENAME (FETCH (UFSGENFILESTATE FILTER) OF GENFILESTATE)) (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (* ;;  "Need any legal attributes to cause string allocation.") '(SIZE CREATIONDATE AUTHOR)) '(SORT RESETLST] (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN)) (* ;; "It's a directory, so let's recurse into it.") (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN)) (replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE with SUBGEN) (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE))) (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) (* ;; "We're set up to recurse into the SUBGEN above") (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)) (NAMEONLY NEWNAME) (T FILENAME))) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))]) (\UFS.FILEINFOFN (LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T))))) ) (\UFS.VALID.PROPP (LAMBDA (DESIREDPROPS) (* ; "Edited 3-May-90 14:43 by nm") (AND (SOME (OR (LISTP DESIREDPROPS) (LIST DESIREDPROPS)) (FUNCTION (LAMBDA (PROP) (FMEMB PROP (QUOTE (LENGTH PROTECTION SIZE CREATIONDATE WRITEDATE READDATE ICREATIONDATE IWRITEDATE IREADDATE AUTHOR)))))) T)) ) (\UFS.REGISTER.GFS (LAMBDA (GENFILESTATE) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 4-May-90 16:18 by nm") (UNINTERRUPTABLY (AND (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (PUTHASH GENFILESTATE GENFILESTATE \UFS.GFS.TABLE)))) ) (\UFS.UNREGISTER.GFS (LAMBDA (GENFILESTATE NOTICETOCP) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 4-May-90 16:10 by nm") (* ;; "Make GENFILESTATE, FILEGENOBJ, invalid. If NOTICETOCP, notice to C code to abandon the cached information.") (UNINTERRUPTABLY (AND NOTICETOCP (\UFSFinishFileInfo-C (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE))) (replace (UFSGENFILESTATE FINFOID) of GENFILESTATE with -1) (replace (UFSGENFILESTATE DIRECTORY) of GENFILESTATE with NIL) (replace (UFSGENFILESTATE DEV) of GENFILESTATE with NIL) (PUTHASH GENFILESTATE NIL \UFS.GFS.TABLE))) ) (\UFS.ABORT.DIRECTORY (LAMBDA NIL (DECLARE (SPECVARS FILEGROUP)) (* ; "Edited 8-May-90 13:21 by nm") (bind GFS for GEN in (fetch (FILEGROUP FILEGENERATORS) of FILEGROUP) do (SETQ GFS (fetch (FILEGENOBJ GENFILESTATE) of GEN)) (if (AND (type? UFSGENFILESTATE GFS) (> (fetch (UFSGENFILESTATE FINFOID) of GFS) -1) (\UFS.UNREGISTER.GFS GFS T))))) ) (\UFS.ABORT.CL-DIRECTORY (LAMBDA NIL (DECLARE (SPECVARS GENERATOR)) (* ; "Edited 8-Jun-90 15:09 by nm") (LET ((GFS (fetch (FILEGENOBJ GENFILESTATE) of GENERATOR))) (if (AND (type? UFSGENFILESTATE GFS) (> (fetch (UFSGENFILESTATE FINFOID) of GFS) -1) (\UFS.UNREGISTER.GFS GFS T))))) ) (\UFS.CLEANUP.GFS.TABLE (LAMBDA (NOTICETOCP) (* ; "Edited 8-Jun-90 15:17 by nm") (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL NOTICETOCP)))) T) ) ) (* ; "File Name parsing") (DEFINEQ (\UFSMakeUnixFormatName (LAMBDA (FILE) (* ; "Edited 20-Sep-89 11:22 by jds") (* ;; "Given a file name in INTERLISP format {host}subdir...>name.ext;ver,") (* ;; "convert the directory part to unix /dir/subdir/.../ format. . ") (DECLARE (GLOBALVARS \UFSDefaultDelimiter)) (LET* ((OLDFILE (MKSTRING FILE)) (LEN (NCHARS OLDFILE)) (NEWFILE (ALLOCSTRING LEN)) (NEWINDEX -1) (LASTSLASH -2) (SLASHCHAR (CL:CHAR \UFSDefaultDelimiter 0)) C) (* ;; "Change all %">%" and %"<%" to %"/%" and remove duplicate %"/%"s so that we don't misinterpret /foo//bar as being a relative spec (ugh).") (for I from 0 to (SUB1 LEN) do (CASE (SETQ C (CL:CHAR OLDFILE I)) ((#\/ #\> #\<) (* ; "Make this a slash, suppress it if we already had one") (if (> NEWINDEX LASTSLASH) then (CL:SETF (CL:CHAR NEWFILE (SETQ LASTSLASH (add NEWINDEX 1))) SLASHCHAR))) (T (* ; "Just copy it") (CL:SETF (CL:CHAR NEWFILE (add NEWINDEX 1)) C)))) (if (EQ NEWINDEX (SUB1 LEN)) then (* ; "nothing removed") NEWFILE else (SUBSTRING NEWFILE 1 (ADD1 NEWINDEX))))) ) (\UFSParseNameString (LAMBDA (FILE) (* ; "Edited 20-Sep-89 11:24 by jds") (* ;; "Like UNPACKFILENAME.STRING, with embellishments. Converts the file name to Unix format first, then unpacks it.") (DECLARE (GLOBALVARS \UFSDefaultDelimiter)) (LET* ((OLDFILE (MKSTRING FILE)) (NEWFILE (\UFSMakeUnixFormatName OLDFILE))) (\UFS.ADJUST.HOST (UNPACKFILENAME.STRING NEWFILE)))) ) (\UFSParse-Directory (LAMBDA (PARSE DEV) (* ; "Edited 1-Mar-89 14:45 by bvm") (LET ((DIRECTORY (LISTGET PARSE (QUOTE DIRECTORY)))) (COND (DIRECTORY (if (NEQ (NTHCHAR DIRECTORY -1) \UFSDefaultDelimiterChar) then (* ; "absolute pathname") (CONCAT \UFSDefaultDelimiter DIRECTORY \UFSDefaultDelimiter) elseif (> (NCHARS DIRECTORY) 0) then (* ; "relative pathname") (SELECTQ (NTHCHAR DIRECTORY 1) ((/ ~ %.) DIRECTORY) (CONCAT (\UFS.DEFAULT.DIR DEV) DIRECTORY)) else (* ; "Naked / = top-level dir") DIRECTORY)) (T (\UFS.DEFAULT.DIR DEV))))) ) (\UFS.PARSE.BODY (LAMBDA (PARSEDNAME) (* ; "Edited 1-Mar-89 14:24 by bvm") (* ;; "PARSEDNAME Is the output of unpackfilename. Extract the pieces that make up name.ext;version and return them as a single string.") (CONCAT (OR (LISTGET PARSEDNAME (QUOTE NAME)) "") (LET ((TYPE (LISTGET PARSEDNAME (QUOTE EXTENSION)))) (COND ((AND TYPE (> (NCHARS TYPE) 0)) (CONCAT \UFSBeforeType TYPE)) (T ""))) (LET ((VERSION (LISTGET PARSEDNAME (QUOTE VERSION)))) (COND ((AND VERSION (> (NCHARS VERSION) 0)) (CONCAT \UFSBeforeVersion VERSION)) (T ""))))) ) (\UFS.ADJUST.HOST (LAMBDA (FIELDS) (* ; "Edited 3-Mar-89 14:42 by bvm") (* ;; "Hook for NFS hack to further modify the parse of a dsk/ufs name") FIELDS) ) (\UFS.FULLNAME (LAMBDA (NAME DEV ATOMP) (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) (* ; "Edited 4-May-90 11:07 by nm") (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") (if NAME then (* ; "Pass NIL thru transparently") (if (DSKP DEV) then (SETQ NAME (CONCAT *DSK-HOST-NAME* NAME)) (if *DSK-UPPER-CASE-FILE-NAMES* then (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") (if ATOMP then (MKATOM (U-CASE NAME)) else (U-CASE NAME)) else (if ATOMP then (MKATOM NAME) else NAME)) else (SETQ NAME (CONCAT *UFS-HOST-NAME* NAME)) (if ATOMP then (MKATOM NAME) else NAME)))) ) (\UFS.ADD.HOST.FIELD (LAMBDA (NAME DEV) (* ; "Edited 30-Mar-90 10:26 by nm") (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is different from \UFS.FULLNAME at the point it refers *DSK-UPPER-CASE-FILE-NAMES* .") (if NAME then (SETQ NAME (CONCAT "{" (fetch (FDEV DEVICENAME) of DEV) "}" NAME)))) ) (\UFS.REMOVE.HOST.FIELD (LAMBDA (FILE DEV) (* ; "Edited 10-Sep-92 15:52 by jds") (* ;; "Accepts a full file representation, and returns the file representaion as a string in which HOST field is removed.") (LET* ((PARSE-LIST (UNPACKFILENAME.STRING FILE)) (RELATIVEDIRECTORY (MEMB (QUOTE RELATIVEDIRECTORY) PARSE-LIST)) (DIRECTORY (LISTGET PARSE-LIST (QUOTE DIRECTORY))) PACKED-NAME VERSION DEVICE) (if (DSKP DEV) then (* ;; " Check if FILE contains the valid version field or not so that C code can assume that all file names are valid.") (AND (SETQ VERSION (LISTGET PARSE-LIST (QUOTE VERSION))) (if (STREQUAL VERSION "") then (* ;; "Newest version is specifed. Just removes it.") (LISTPUT PARSE-LIST (QUOTE VERSION) NIL) else (OR (FIXP (MKATOM VERSION)) (CL:ERROR (QUOTE XCL:INVALID-PATHNAME) :PATHNAME FILE))))) (if RELATIVEDIRECTORY then (RPLACA (CDR RELATIVEDIRECTORY) (\UFS.HANDLE.RELATIVEDIRECTORY (CADR RELATIVEDIRECTORY) DEV)) elseif (NOT DIRECTORY) then (LISTPUT PARSE-LIST (QUOTE DIRECTORY) (\UFS.DEFAULT.DIR DEV))) (LISTPUT PARSE-LIST (QUOTE HOST) NIL) (SETQ DEVICE (LISTGET PARSE-LIST (QUOTE DEVICE))) (LISTPUT PARSE-LIST (QUOTE DEVICE) NIL) (SETQ PACKED-NAME (PACKFILENAME.STRING PARSE-LIST)) (* ;; "Trim off the leading <, unless this is a file on the root directory.") (SETQ PACKED-NAME (if (STREQUAL (LISTGET PARSE-LIST (QUOTE DIRECTORY)) "<") then (if (LISTGET PARSE-LIST (QUOTE NAME)) then (SUBSTRING PACKED-NAME 2) else "<") else (if (EQ (NTHCHARCODE PACKED-NAME 1) (CHARCODE <)) then (SUBSTRING PACKED-NAME 2) else PACKED-NAME))) (* ;; "Add back the device spec, if there is one:") (COND (DEVICE (CONCAT DEVICE PACKED-NAME)) (T PACKED-NAME)))) ) (\UFS.HANDLE.RELATIVEDIRECTORY (LAMBDA (DIR DEV) (* ; "Edited 22-Mar-90 11:42 by nm") (* ;;; "DIR is a relative directory. Reformats it to the form which the C subr code can accept. Only case we have to worry about is that no meta characters (i.e. %".%", %"..%", %"~%") is used. In this case, we have to attach the default meta character according to the device.") (if DIR then (COND ((SELCHARQ (NTHCHARCODE DIR 1) (%. (* ;; "%".%" or %"..%" or %".>%" or %"./%" or %"..>%" or %"../%"") (OR (NCHARS DIR 1) (AND (NCHARS DIR 2) (EQMEMB (NTHCHARCODE DIR 2) (CHARCODE (%. > /)))) (AND (NCHARS DIR 3) (EQ (NTHCHAR DIR 2) (QUOTE %.)) (EQMEMB (NTHCHARCODE DIR 3) (CHARCODE (> /)))))) (~ (* ;; "%"~>%" or %"~username%" ") T) NIL) DIR) (T (CONCAT (\UFS.DEFAULT.DIR DEV) DIR))))) ) ) (RPAQ? \UFSDefaultDelimiter "/") (RPAQ? \UFSDefaultDelimiterChar '/) (RPAQ? \UFSDefaultConnDir "./") (RPAQ? \UFSBeforeType '%.) (RPAQ? \UFSBeforeVersion ';) (RPAQ? \UFSDeviceDelimiter '}) (RPAQ? \DSK.DEFAULT.DIRECTORY "~>") (RPAQ? \UFS.DEFAULT.DIRECTORY ".>") (RPAQ? *DSK-UPPER-CASE-FILE-NAMES* NIL) (RPAQ? \UFS.GFS.TABLE (HASHARRAY 20)) (RPAQ? *DSK-HOST-NAME* "{DSK}") (RPAQ? *UFS-HOST-NAME* "{UNIX}") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \UFSDeviceDelimiter \UFSBeforeVersion \UFSBeforeType \UFSDefaultConnDir \UFSDefaultDelimiterChar \UFSDefaultDelimiter \DSK.DEFAULT.DIRECTORY \UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE *DSK-HOST-NAME* *UFS-HOST-NAME*) ) (* ;; "Change UNIX Curent Directory") (DEFINEQ (CHDIR (LAMBDA (PATHNAME) (* ; "Edited 2-Apr-90 01:07 by nm") (* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.") (WITH.MONITOR \UFStopMonitor (LET ((PATH (\ADD.CONNECTED.DIR PATHNAME)) HOST) (if PATH then (SETQ HOST (U-CASE (FILENAMEFIELD PATH (QUOTE HOST)))) (if (OR (EQ HOST (QUOTE DSK)) (EQ HOST (QUOTE UNIX))) then (if (SETQ PATH (DIRECTORYNAME PATH)) then (if (\UFSCHDIR-C PATH) then (DIRECTORYNAME PATH) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "Bad Host Name" HOST)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))))) ) ) (* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") (DEFINEQ (\DEVICEFILE.EOSERROR (LAMBDA (STREAM) (* ; "Edited 3-Mar-89 15:06 by bvm") (SELECTQ (fetch (STREAM ACCESS) of STREAM) (OUTPUT (LISPERROR "END OF FILE" (fetch (STREAM FULLNAME) of STREAM) T)) (INPUT (PROG (BUF VMEMBUF DATASIZE) (OR (SETQ BUF (fetch (STREAM BUFFS) of STREAM)) (replace (STREAM BUFFS) of STREAM with (SETQ BUF (\GETMAPBUFFER)))) (SETQ VMEMBUF (fetch (BUFFER VMEMPAGE) of BUF)) (until (SETQ DATASIZE (\UFSReadPages-C (fetch (UFSSTREAM FILEID) of STREAM) 0 VMEMBUF)) do (BLOCK)) (if (EQ DATASIZE 0) then (LISPERROR "END OF FILE" (fetch (STREAM FULLNAME) of STREAM) T) (RETURN NIL)) (UNINTERRUPTABLY (replace (BUFFER FILEPAGE#) of BUF with 0) (replace (BUFFER BUFFERNEXT) of BUF with NIL) (replace (BUFFER SYSNEXT) of BUF with NIL) (replace (STREAM CBUFSIZE) of STREAM with DATASIZE) (replace (STREAM EOFFSET) of STREAM with DATASIZE) (replace (STREAM COFFSET) of STREAM with 0) (replace (STREAM CBUFPTR) of STREAM with VMEMBUF)) (RETURN T))) (SHOULDNT))) ) ) (* ;; "flush/revalidate unvisible stream, like dribble files.") (DEFINEQ (\UNVISIBLE.PAGED.REVALIDATEFILELST (LAMBDA (DEVICE) (* ; "Edited 3-Mar-89 15:33 by bvm") (* ;;; "This function is writen based on \PAGED.REVALIDATEFILELST") (* ;;; "Revalidate unvisible open files on DEVICE (a PMAP device)") (bind REASON PAGES for STREAM in (fetch (FDEV OPENFILELST) of DEVICE) when (NULL (fetch (STREAM USERVISIBLE) of STREAM)) do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed % % update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) (MAPC (STREAMPROP STREAM (QUOTE AFTERCLOSE)) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM)))) (replace (STREAM ACCESS) of STREAM with NIL) (FDEVOP (QUOTE UNREGISTERFILE) DEVICE DEVICE STREAM)) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM)))) ) (\UNVISIBLE.FLUSH.OPEN.STREAMS (LAMBDA (FDEV) (* ; "Edited 20-Dec-88 10:20 by Hayata") (* ;;; "This function is writen based on \FLUSH.OPEN.STREAMS") (* ;;; "flush unvisible open streams") (for STREAM in (fetch (FDEV OPENFILELST) of FDEV) bind STREAM when (AND (NULL (fetch (STREAM USERVISIBLE) of STREAM)) (DIRTYABLE STREAM)) do (FDEVOP (QUOTE FORCEOUTPUT) FDEV STREAM))) ) ) (* ;; " Error handler") (DEFINEQ (\UFSError (LAMBDA (PATHNAME ERRNO DEV) (* ; "Edited 14-Dec-94 16:46 by jds") (* ;; "If DEV is supplied, we combine it with PATHNAME to get a real name.") (* ;; "Note that codes not explicitly listed here do not signal an error (!!). This may be reasonable for code zero (file not found), but others???") (PROG ((NO (IPLUS ERRNO 0))) (* ;; "errno is fixp cell, changed into a SMALLP using IPLUS, and residing in NO.") (COND (DEV (SETQ PATHNAME (\UFS.FULLNAME PATHNAME DEV)))) (SELECTQ NO (1 (ERROR "Not owner" PATHNAME)) (5 (* ; "I/O error") (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE PATHNAME)) (13 (* ; "Permission denied") (CL:ERROR (QUOTE XCL:FS-PROTECTION-VIOLATION) :PATHNAME PATHNAME)) (21 (ERROR "Is a directory" PATHNAME)) (23 (* ; "File table overflow") (CL:ERROR (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME PATHNAME)) (24 (* ; "LISPERROR 15 is no longer supported (LISPERROR %"TOO MANY FILES OPEN%" |pathname|)") (ERROR "TOO MANY FILES OPEN" PATHNAME)) (27 (ERROR "File too large" PATHNAME)) (28 (* ; "No space left on device") (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME PATHNAME)) (29 (* ; "Illegal seek") (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE PATHNAME)) (30 (* ; "Read only file system") (CL:ERROR (QUOTE XCL:FS-PROTECTION-VIOLATION) :PATHNAME PATHNAME)) (60 (* ; "Connect request or NFS request failed") (ERROR "Connection timed out" PATHNAME)) (62 (* ; "Too many levels of symbolic link (usually a loop of links)") (ERROR "Too many levels of symbolic link in" PATHNAME)) (66 (ERROR "Directory not empty" PATHNAME)) (100 (ERROR "Connection timed out" PATHNAME)) NIL))) ) ) (* ; "File Type and EOL handling") (DEFINEQ (\UFSGetFileType (LAMBDA (FILENAME) (* ; "Edited 19-May-91 11:18 by jds") (LET ((TYPE (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)))) (SETQ TYPE (MKATOM (U-CASE (COND ((AND (EQ (NCHARS TYPE) 0) (* ; "Handle null extension specially") (CDR (CL:ASSOC NIL DEFAULTFILETYPELIST)))) ((CDR (CL:ASSOC TYPE DEFAULTFILETYPELIST :TEST (QUOTE STRING-EQUAL)))) (T DEFAULTFILETYPE))))) (* ; "(SELECTQ TYPE ((TEXT BINARY) TYPE) (CL:ERROR %"Invalid File Type ~A for ~A%" TYPE FILENAME))") (* ;; "TYPE used to be constraied to be TEXT or BINARY, which caused some older user code to tail. AR 11373") TYPE)) ) (\UFSSetFileType [LAMBDA (FILENAME TYPE) (* ; "Edited 7-Mar-2022 20:33 by larry") (* ; "Edited 6-Jun-88 13:48 by HH") (LET [(EXTENSION (MKATOM (U-CASE (LISTGET (\UFSParseNameString FILENAME) 'EXTENSION] (SETQ TYPE (MKATOM (U-CASE TYPE))) (for PAIR in DEFAULTFILETYPELIST WHEN (EQ EXTENSION (CAR PAIR)) DO (RETURN (EQ TYPE (CDR PAIR))) finally (RETURN (EQ TYPE DEFAULTFILETYPE]) (\UFSeol [LAMBDA (FILENAME TYPE RECOG) (* ; "Edited 21-Apr-2021 11:36 by rmk:") (if (AND [SETQ TYPE (SELECTQ (CADR TYPE) (TEXT 'TEXT) (NIL NIL) (PROGN (* ; "Anything else reduces to binary") 'BINARY] (EQ RECOG 'NEW) (NEQ TYPE (\UFSGetFileType FILENAME))) then (* ;  "Warn user that TYPE will not be properly inferred when we next read this file") (PRINTOUT PROMPTWINDOW T "Warning: creating " TYPE " file, but name '" (\UFS.PARSE.BODY (\UFSParseNameString FILENAME)) "' does not have a " TYPE " extension.")) (SELECTQ (OR TYPE (\UFSGetFileType FILENAME)) (TEXT LF.EOLC) (PROGN (* ;  "BINARY or unknown. RMK: Switch default to LF") (OR \UFS.DEFAULT.EOLC LF.EOLC]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ DEFAULTFILETYPE BINARY) (RPAQQ DEFAULTFILETYPELIST ((NIL . BINARY) (C . TEXT) (H . TEXT) (EL . TEXT) (IM . TEXT) (LISP . TEXT) (LSP . TEXT) (O . BINARY) (OUT . BINARY) (LCOM . BINARY) (DFASL . BINARY) (DRIBBLE . TEXT) (TTY . TEXT) (TXT . TEXT) (Z . BINARY) (HTML . TEXT) (HTM . TEXT) (TEX . TEXT) (PS . TEXT) (PDF . TEXT) (DCOM . BINARY) (SKETCH . BINARY) (TEDIT . BINARY) (TED . BINARY) (DISPLAYFONT . BINARY) (AC . BINARY) (WD . BINARY) (IP . BINARY) (INTERPRESS . BINARY) (PRESS . BINARY) (PSCFONT . BINARY) (RST . BINARY) (BIN . BINARY) (MAIL . BINARY) (SYSOUT . BINARY) (SYSOUT.Z . BINARY) (TAR . BINARY) (INDEX . BINARY) (HASH . BINARY) (NOTEFILE . BINARY) (Z . BINARY) (VIRTUALMEM . BINARY) (VM . BINARY))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ UFSDECLS ((MACROS \UFS.FULLNAME.M \UFSGetMonitor \UFS.DEFAULT.DIR \UFS.FILE.RECOGNIZER \UFS.DIRECTORY.RECOGNIZER DSKP) (RECORDS UFSSTREAM NAME&ALLPROPS) (* ;; "File attribute code. For interface between Cfunc and LISPfunc.") (CONSTANTS (ATTR-LENGTH 1) (ATTR-WDATE 2) (ATTR-RDATE 3) (ATTR-CDATE 4) (ATTR-AUTHOR 5) (ATTR-PROTECTION 6) (ATTR-EOL 7) (ATTR-ALL 8)) (* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") (CONSTANTS (RECOG-OLD 0) (RECOG-OLDEST 1) (RECOG-NEW 2) (RECOG-NEW-OLD 3) (RECOG-OTHER 4) (RECOG-NON 5)) (* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") (CONSTANTS (ACCESS-INPUT 0) (ACCESS-OUTPUT 1) (ACCESS-BOTH 2) (ACCESS-APPEND 3) (ACCESS-OTHER 4)) (* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") (CONSTANTS (MAX-UNAME-LEN 512)) (* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") (CONSTANTS (MAX-PATHNAME-LEN 256)) (FILES (LOADCOMP) PMAP) (* ; "For \devicefile.eoserror"))) (DECLARE%: EVAL@COMPILE (PUTPROPS \UFS.FULLNAME.M MACRO [LAMBDA (DIR NAME DEV) (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) (* ;;  "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". ") (* ;; "jds? DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley's {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file system is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") (CL:WHEN NAME (* ; "Pass NIL thru transparently") (SETQ NAME (CONCAT "{" (FETCH (FDEV DEVICENAME) OF DEV) "}" DIR NAME)) (CL:IF (AND (DSKP DEV) *DSK-UPPER-CASE-FILE-NAMES*) (U-CASE NAME) NAME))]) (PUTPROPS \UFSGetMonitor MACRO ((DEV) (SELECTQ (fetch (FDEV DEVICENAME) of DEV) (DSK \DSKtopMonitor) (UNIX \UFStopMonitor) NIL))) (PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV) (SELECTQ (fetch (FDEV DEVICENAME) of DEV) (DSK \DSK.DEFAULT.DIRECTORY) (UNIX \UFS.DEFAULT.DIRECTORY) NIL))) (PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV) (* ;;  "Return a function that will do name recognition for this device") (SELECTQ (fetch (FDEV DEVICENAME) of DEV) (DSK (FUNCTION \DSKGetFileName-C)) (UNIX (FUNCTION \UFSGetFileName-C)) (FUNCTION SHOULDNT)))) (PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV) (SELECTQ (fetch (FDEV DEVICENAME) of DEV) (DSK (FUNCTION \DSKDirectoryNameP-C)) (UNIX (FUNCTION \UFSDirectoryNameP-C)) (FUNCTION SHOULDNT)))) (PUTPROPS DSKP MACRO ((DEV) (EQ (fetch (FDEV DEVICENAME) of DEV) 'DSK))) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS UFSSTREAM ( (* ;;  "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.") (FILEID (fetch F1 of DATUM) (REPLACE F1 OF DATUM WITH NEWVALUE)) (* ; "Unix file handle") (CDATE (fetch F2 of DATUM) (REPLACE F2 OF DATUM WITH NEWVALUE)) (* ; "IDate given to openstream") (UNIXNAME (fetch F5 of DATUM) (REPLACE F5 OF DATUM WITH NEWVALUE)) (* ;  "The name by which Unix knows this file") )) (RECORD NAME&ALLPROPS (NAME . ALLPROPS)) ) (* ;; "File attribute code. For interface between Cfunc and LISPfunc.") (DECLARE%: EVAL@COMPILE (RPAQQ ATTR-LENGTH 1) (RPAQQ ATTR-WDATE 2) (RPAQQ ATTR-RDATE 3) (RPAQQ ATTR-CDATE 4) (RPAQQ ATTR-AUTHOR 5) (RPAQQ ATTR-PROTECTION 6) (RPAQQ ATTR-EOL 7) (RPAQQ ATTR-ALL 8) (CONSTANTS (ATTR-LENGTH 1) (ATTR-WDATE 2) (ATTR-RDATE 3) (ATTR-CDATE 4) (ATTR-AUTHOR 5) (ATTR-PROTECTION 6) (ATTR-EOL 7) (ATTR-ALL 8)) ) (* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") (DECLARE%: EVAL@COMPILE (RPAQQ RECOG-OLD 0) (RPAQQ RECOG-OLDEST 1) (RPAQQ RECOG-NEW 2) (RPAQQ RECOG-NEW-OLD 3) (RPAQQ RECOG-OTHER 4) (RPAQQ RECOG-NON 5) (CONSTANTS (RECOG-OLD 0) (RECOG-OLDEST 1) (RECOG-NEW 2) (RECOG-NEW-OLD 3) (RECOG-OTHER 4) (RECOG-NON 5)) ) (* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") (DECLARE%: EVAL@COMPILE (RPAQQ ACCESS-INPUT 0) (RPAQQ ACCESS-OUTPUT 1) (RPAQQ ACCESS-BOTH 2) (RPAQQ ACCESS-APPEND 3) (RPAQQ ACCESS-OTHER 4) (CONSTANTS (ACCESS-INPUT 0) (ACCESS-OUTPUT 1) (ACCESS-BOTH 2) (ACCESS-APPEND 3) (ACCESS-OTHER 4)) ) (* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") (DECLARE%: EVAL@COMPILE (RPAQQ MAX-UNAME-LEN 512) (CONSTANTS (MAX-UNAME-LEN 512)) ) (* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") (DECLARE%: EVAL@COMPILE (RPAQQ MAX-PATHNAME-LEN 256) (CONSTANTS (MAX-PATHNAME-LEN 256)) ) (FILESLOAD (LOADCOMP) PMAP) (* ; "For \devicefile.eoserror") ) (* ; "Filetypepatch functions. ") (DEFINEQ (\UFSGetPrintFileType (LAMBDA (FILENAME) (* ; "Edited 23-Jul-91 13:40 by jds") (LET ((TYPE (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)))) (SETQ TYPE (MKATOM (U-CASE (COND ((AND (EQ (NCHARS TYPE) 0) (* ; "Handle null extension specially") (CDR (CL:ASSOC NIL DEFAULTFILETYPELIST)))) ((CDR (CL:ASSOC TYPE DEFAULTFILETYPELIST :TEST (QUOTE STRING-EQUAL)))) (T (\UFSGetFileTypeConfirm FILENAME)))))) TYPE)) ) (\UFSGetFileTypeConfirm (LAMBDA (FILENAME) (* ; "Edited 27-Oct-90 17:52 by nm") (* ; "Edited 9-Jan-89 20:43 by H.Komatsubara") (DECLARE (GLOBALVARS FileTypeMenu DEFAULTFILETYPE)) (PROMPTPRINT "Extension of " FILENAME " isn't in DEFAULTFILETYPELIST.% " "Please select FileType.% " "This message can be stopped by setting FileTypeConfirmFlg to NIL.% ") (OR (BOUNDP (QUOTE FileTypeMenu)) (\UFSPrintTypeMenu)) (OR (MENU FileTypeMenu) (RETTO T))) ) (\UFSPrintTypeMenu (LAMBDA NIL (DECLARE (GLOBALVARS FileTypeMenu)) (* ; "Edited 9-Jan-89 11:08 by hayata.abc") (SETQ FileTypeMenu (create MENU TITLE _ "FileType?" ITEMS _ (QUOTE ((TEXT (QUOTE TEXT)) (BINARY (QUOTE BINARY)))) CENTERFLG _ T))) ) ) (* ; "for hardcopy") (DEFINEQ (\UFStoOtherCopyMess [LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 7-Mar-2022 20:48 by larry") (* ; "Edited 9-Jan-89 12:19 by hayata.abc") (* ;; "") (* ;  "Edited 10-Jan-89 01:01 by H.Komatsubara") (DECLARE (GLOBALVARS DEFAULTFILETYPELIST DEFAULTFILETYPE)) (AND (OR (EQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of INSTREAM)) 'DSK) (EQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of INSTREAM)) 'UNIX)) (AND (NEQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of OUTSTREAM)) 'DSK) (NEQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of OUTSTREAM)) 'UNIX)) [NULL (LET [(EXTENSION (U-CASE (FILENAMEFIELD (fetch FULLFILENAME of INSTREAM) 'EXTENSION] (for PAIR in DEFAULTFILETYPELIST do (if (EQUAL (U-CASE (CAR PAIR)) EXTENSION) then (RETURN (CDR PAIR] (PROMPTPRINT "Extension of " (fetch FULLFILENAME of INSTREAM) " isn't in DEFAULTFILETYPELIST." (fetch FULLFILENAME of OUTSTREAM) " was copied as " DEFAULTFILETYPE "." "This message can be stopped by set FileTypeConfirmFlg to NIL."]) (\UFStoOtherRenameMess [LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 7-Mar-2022 20:51 by larry") (* ; "Edited 9-Jan-89 12:19 by hayata.abc") (* ; "Edited 9-Jan-89 11:33 by hayata.abc") (DECLARE (GLOBALVARS DEFAULTFILETYPELIST DEFAULTFILETYPE)) (AND (AND (NEQ (fetch (FDEV DEVICENAME) of NEW-DEVICE) 'DSK) (NEQ (fetch (FDEV DEVICENAME) of NEW-DEVICE) 'UNIX)) [NULL (LET [(EXTENSION (U-CASE (FILENAMEFIELD OLD-NAME 'EXTENSION] (for PAIR in DEFAULTFILETYPELIST do (if (EQUAL (U-CASE (CAR PAIR)) EXTENSION) then (RETURN (CDR PAIR] (PROMPTPRINT "Extension of " OLD-NAME " isn't in DEFAULTFILETYPELIST.% " NEW-NAME " was renamed as " DEFAULTFILETYPE "." "This message can be stopped by set FileTypeConfirmFlg to NIL.% "]) ) (* ; "for copyfile,renamefile") (RPAQ? FileTypeConfirmFlg T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FileTypeMenu FileTypeConfirmFlg) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (8909 10462 (\UFSCreateDevice 8919 . 9284) (\UFS.CREATE.DEVICE 9286 . 10142) ( \UFSOpenDevice 10144 . 10321) (\UFSCloseDevice 10323 . 10460)) (14725 51227 (\UFSOpenFile 14735 . 18029) (\UFS.OPENP 18031 . 18528) (\UFS.RECOGNIZE.FILE 18530 . 19283) (\UFS.DIRECTORY.NAME 19285 . 20028) (\UFSCloseFile 20030 . 21935) (\UFSGetFileName 21937 . 22136) (\UFSDeleteFile 22138 . 22678) ( \UFSRenameFile 22680 . 23845) (\UFSReadPages 23847 . 24982) (\UFSWritePages 24984 . 26204) ( \UFSTruncateFile 26206 . 27703) (\UFSDirectoryNameP 27705 . 28759) (\UFSEventFn 28761 . 29423) ( \UFSGetFileInfo 29425 . 31707) (\UFS.CREATE.PROPS 31709 . 32062) (\UFSSetFileInfo 32064 . 33293) ( \UFSGenerateFiles 33295 . 40175) (\UFS.NEXTFILEFN 40177 . 47815) (\UFS.FILEINFOFN 47817 . 49266) ( \UFS.VALID.PROPP 49268 . 49560) (\UFS.REGISTER.GFS 49562 . 49817) (\UFS.UNREGISTER.GFS 49819 . 50402) (\UFS.ABORT.DIRECTORY 50404 . 50752) (\UFS.ABORT.CL-DIRECTORY 50754 . 51041) (\UFS.CLEANUP.GFS.TABLE 51043 . 51225)) (51262 57946 (\UFSMakeUnixFormatName 51272 . 52293) (\UFSParseNameString 52295 . 52669 ) (\UFSParse-Directory 52671 . 53212) (\UFS.PARSE.BODY 53214 . 53759) (\UFS.ADJUST.HOST 53761 . 53920) (\UFS.FULLNAME 53922 . 55130) (\UFS.ADD.HOST.FIELD 55132 . 55492) (\UFS.REMOVE.HOST.FIELD 55494 . 57164) (\UFS.HANDLE.RELATIVEDIRECTORY 57166 . 57944)) (58762 59375 (CHDIR 58772 . 59373)) (59447 60433 (\DEVICEFILE.EOSERROR 59457 . 60431)) (60506 61743 (\UNVISIBLE.PAGED.REVALIDATEFILELST 60516 . 61361) (\UNVISIBLE.FLUSH.OPEN.STREAMS 61363 . 61741)) (61776 63402 (\UFSError 61786 . 63400)) (63446 65861 ( \UFSGetFileType 63456 . 64057) (\UFSSetFileType 64059 . 64656) (\UFSeol 64658 . 65859)) (74508 75632 ( \UFSGetPrintFileType 74518 . 74930) (\UFSGetFileTypeConfirm 74932 . 75380) (\UFSPrintTypeMenu 75382 . 75630)) (75662 78500 (\UFStoOtherCopyMess 75672 . 77350) (\UFStoOtherRenameMess 77352 . 78498))))) STOP