github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-28 21:08:23 +00:00
Code Issues Projects Releases Wiki Activity

Rmk131 Mapping MCCS filenames to (Mac?) UTF-8 file names (#2320)

Browse Source 
* Coerce MCCS filename strings to UTF8 filename strings in file-name system calls, coerce system filenames back to MCCS codes

* Add UNICODE-TABLES so MTOUTF8STRING gets defined in right place in the loadup sequence

* ADIR:  Bug fix: UNPACKFILENAME sets FATSTRINGP

* fix virtualkeyboard bug in code assignment

* Unicode canonicalizes non-SMALLP unicodes
This commit is contained in:
rmkaplan
2025-10-27 11:54:56 -07:00
committed by GitHub
parent 8d0011ce2c
commit 54f8b889b9
15 changed files with 1237 additions and 743 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
sources/ADIR
View File

@@ -1,10 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 6-Feb-2025 17:48:54" {DSK}<home>frank>il>medley>sources>ADIR.;6 70091
(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}<sources>ADIR.;62 70135
:CHANGES-TO (FNS INTERPRET.REM.CM)
:EDIT-BY rmk
:PREVIOUS-DATE "20-Jan-2025 13:37:28" {DSK}<home>frank>il>medley>sources>ADIR.;3)
:CHANGES-TO (MACROS \UPF.EXTRACT)
:PREVIOUS-DATE " 6-Feb-2025 17:48:54" {WMEDLEY}<sources>ADIR.;61)
(PRETTYCOMPRINT ADIRCOMS)
@@ -742,7 +744,8 @@
OFFST _ STARTOFFSET
LENGTH _ (ADD1 (IDIFFERENCE ENDOFFSET STARTOFFSET))
BASE _ $$BASE
READONLY _ $$READONLY)))
READONLY _ $$READONLY
FATSTRINGP _ $$FATP)))
(PUTPROPS \UPF.DIRTYPE MACRO [(DIRSTART) (* ; "Edited 20-Apr-2022 20:14 by rmk")
(SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
@@ -1279,14 +1282,14 @@
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3183 16010 (DELFILE 3193 . 3354) (FULLNAME 3356 . 3723) (INFILE 3725 . 3984) (INFILEP
3986 . 4121) (IOFILE 4123 . 4374) (OPENFILE 4376 . 4679) (OPENSTREAM 4681 . 9021) (OUTFILE 9023 . 9285
) (OUTFILEP 9287 . 9423) (RENAMEFILE 9425 . 9731) (SIMPLE.FINDFILE 9733 . 10143) (VMEMSIZE 10145 .
10312) (\COPYSYS 10314 . 14605) (\FLUSHVM 14607 . 15679) (\LOGOUT0 15681 . 16008)) (16509 41169 (
UNPACKFILENAME.STRING 16519 . 38355) (\UPF.DIRECTORY 38357 . 41167)) (42697 45003 (UNPACKFILENAME
42707 . 42893) (LASTCHPOS 42895 . 43589) (FILENAMEFIELD 43591 . 43885) (FILENAMEFIELD.STRING 43887 .
44291) (PACKFILENAME 44293 . 44636) (PACKFILENAME.STRING 44638 . 45001)) (59473 60386 (
FILEDIRCASEARRAY 59483 . 60384)) (60553 67850 (LOGOUT 60563 . 61608) (MAKESYS 61610 . 63239) (SYSOUT
63241 . 64793) (SAVEVM 64795 . 65595) (HERALD 65597 . 65757) (INTERPRET.REM.CM 65759 . 67473) (
\USEREVENT 67475 . 67848)) (68032 69759 (USERNAME 68042 . 68998) (SETUSERNAME 69000 . 69757)))))
(FILEMAP (NIL (3170 15997 (DELFILE 3180 . 3341) (FULLNAME 3343 . 3710) (INFILE 3712 . 3971) (INFILEP
3973 . 4108) (IOFILE 4110 . 4361) (OPENFILE 4363 . 4666) (OPENSTREAM 4668 . 9008) (OUTFILE 9010 . 9272
) (OUTFILEP 9274 . 9410) (RENAMEFILE 9412 . 9718) (SIMPLE.FINDFILE 9720 . 10130) (VMEMSIZE 10132 .
10299) (\COPYSYS 10301 . 14592) (\FLUSHVM 14594 . 15666) (\LOGOUT0 15668 . 15995)) (16496 41156 (
UNPACKFILENAME.STRING 16506 . 38342) (\UPF.DIRECTORY 38344 . 41154)) (42741 45047 (UNPACKFILENAME
42751 . 42937) (LASTCHPOS 42939 . 43633) (FILENAMEFIELD 43635 . 43929) (FILENAMEFIELD.STRING 43931 .
44335) (PACKFILENAME 44337 . 44680) (PACKFILENAME.STRING 44682 . 45045)) (59517 60430 (
FILEDIRCASEARRAY 59527 . 60428)) (60597 67894 (LOGOUT 60607 . 61652) (MAKESYS 61654 . 63283) (SYSOUT
63285 . 64837) (SAVEVM 64839 . 65639) (HERALD 65641 . 65801) (INTERPRET.REM.CM 65803 . 67517) (
\USEREVENT 67519 . 67892)) (68076 69803 (USERNAME 68086 . 69042) (SETUSERNAME 69044 . 69801)))))
STOP

BIN
sources/ADIR.LCOM
View File

Binary file not shown.

513
sources/UFS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "18-Dec-2024 12:52:23" {WMEDLEY}<sources>UFS.;39 79633
(FILECREATED "27-Oct-2025 11:10:55" {WMEDLEY}<sources>UFS.;61 91949
:EDIT-BY rmk
:CHANGES-TO (FNS \UFSRenameFile)
:CHANGES-TO (FNS \UFSDeleteFile)
:PREVIOUS-DATE "16-Sep-2023 09:22:55" {WMEDLEY}<sources>UFS.;38)
:PREVIOUS-DATE "17-Oct-2025 08:49:57" {WMEDLEY}<sources>UFS.;60)
(PRETTYCOMPRINT UFSCOMS)
@@ -14,6 +14,11 @@
(RPAQQ UFSCOMS
[(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
UFS)
[COMS
(* ;; "For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed.")
(P (MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING]
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
DIRECTORY FILEIO))
(INITVARS (\UFS.DEFAULT.EOLC NIL))
@@ -130,6 +135,17 @@
(PUTPROPS UFS FILETYPE :BCOMPL)
(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10))
(* ;;
"For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed."
)
(MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING)
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(FILESLOAD (LOADCOMP)
@@ -274,23 +290,160 @@
(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))))
)
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 16-Oct-2025 08:52 by rmk")
(* ; "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)
(* ;; "CASE.CORRECT.NAME is MCCS")
(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)
'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 '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 (MTOUTF8STRING 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 '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 '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
'TYPE OTHERINFO))
VALIDATION _ CDATE
ENDOFSTREAMOP _ EOF-FN)))
(replace (UFSSTREAM FILEID) of STRM with FILEID)
(replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC '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))))))
)
[LAMBDA (FILENAME RECOG DEV) (* ; "Edited 16-Oct-2025 10:19 by rmk")
(* ; "Edited 13-Mar-90 11:19 by nm")
(* ;; "This assumes that input FILENAME is MCCS, returns MCCS")
(* ;; "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)
(MTOUTF8STRING (\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)
(UTF8TOMSTRING (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)))))
)
[LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 15-Oct-2025 16:30 by rmk")
(* ; "Edited 1-Apr-90 23:36 by nm")
(* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"true%" 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 %"true%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.")
(* ;; "DIRSTRING is MCCS, the true name is not")
(if (STREQUAL DIRSTRING "<")
then (RPLSTRING NAMEAREA 1 "<")
1
else (WITH.MONITOR (\UFSGetMonitor DEV)
(CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV)
(MTOUTF8STRING DIRSTRING)
NAMEAREA
(CREATECELL \FIXP)))])
(\UFSCloseFile
[LAMBDA (STREAMFILE) (* ; "Edited 16-Sep-2023 09:21 by briggs")
[LAMBDA (STREAMFILE) (* ; "Edited 16-Oct-2025 13:47 by rmk")
(* ; "Edited 16-Sep-2023 09:21 by briggs")
(* ; "Edited 30-Mar-90 10:39 by nm")
(* ; "return stream")
@@ -314,7 +467,8 @@
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)
(RETURN (if (\UFSCloseFile-C (MTOUTF8STRING UNIXNAME)
(fetch (UFSSTREAM FILEID) of STREAMFILE)
CDATE ERRNO)
then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL)
(replace (UFSSTREAM CDATE) of STREAMFILE with NIL)
@@ -328,11 +482,26 @@
)
(\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)))))))))
)
[LAMBDA (FILENAME DEV) (* ; "Edited 27-Oct-2025 11:10 by rmk")
(* ; "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 '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 (MTOUTF8STRING (\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 18-Dec-2024 12:52 by rmk")
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Oct-2025 08:46 by rmk")
(* ; "Edited 18-Dec-2024 12:52 by rmk")
(* ; "Edited 16-Apr-90 13:46 by nm")
(if (NEQ OLD-DEVICE NEW-DEVICE)
then
@@ -349,8 +518,10 @@
(LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME 'NEW NEW-DEVICE))
(ERRNO (CREATECELL \FIXP)))
(COND
((\UFSRenameFile-C (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME OLD-DEVICE)
(\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE)
((\UFSRenameFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD
OLDUNIXNAME OLD-DEVICE))
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME
NEW-DEVICE))
NEW-DEVICE ERRNO)
(\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE))
(T (if (EQL (IPLUS ERRNO 0)
@@ -372,32 +543,200 @@
)
(\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)))))
)
[LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 16-Oct-2025 08:56 by rmk")
(* ; "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))
else (* ; "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 (MTOUTF8STRING (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))))
)
[LAMBDA (DIRSPEC DEV) (* ; "Edited 16-Oct-2025 10:23 by rmk")
(* ; "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 'DEVICE)
"")
(OR (UNPACKFILENAME.STRING DIRSPEC 'DIRECTORY 'RETURN)
(\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC
'RELATIVEDIRECTORY
'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.")
(UTF8TOMSTRING (\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)))))
)
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 16-Oct-2025 08:49 by rmk")
(* ; "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 'OLD DEVICE)
DEVICE NIL)))
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
(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 (UTF8TOMSTRING (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 '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)))))
)
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 16-Oct-2025 08:51 by rmk")
(* ; "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 'OLD DEVICE)
DEVICE NIL)))
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE PATHNAME)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
(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 16-Oct-2025 11:06 by rmk")
(* ;; "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")
@@ -435,19 +774,22 @@
(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]
(* ;; "DIRECTORY is MCCS, FILTER is UTF8")
[SETQ FILTER (MTOUTF8STRING (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))
@@ -455,7 +797,7 @@
((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))
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ; "DIRECTORY is now UTF8")
(* ;; "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.")
@@ -466,7 +808,8 @@
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
(COND
[(< TOTALNUM 0)
(OR (\UFSError DIRECTORY ERRNO FDEV)
(OR (\UFSError (UTF8TOMSTRING DIRECTORY)
ERRNO FDEV)
(RETURN (\NULLFILEGENERATOR]
(T (COND
((ZEROP TOTALNUM)
@@ -475,6 +818,9 @@
(EQ OPTIONS 'RESETLST))
(FMEMB 'RESETLST OPTIONS))
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
(* ;; "Everything in FILEGENOBJ is UTF8")
(RETURN (create FILEGENOBJ
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN)
@@ -496,24 +842,31 @@
CURRENT-DEPTH _ 1
MAX-DEPTH _
FILING.ENUMERATION.DEPTH
FILTER _ (
PACKFILENAME.STRING
'NAME NAME
'EXTENSION
EXTENSION
'VERSION VERSION])
])
FILTER _
(PACKFILENAME.STRING
'NAME
(AND NAME (MTOUTF8STRING
NAME))
'EXTENSION
(AND EXTENSION (
MTOUTF8STRING
EXTENSION))
'VERSION VERSION])])
(\UFS.NEXTFILEFN
[LAMBDA (GENFILESTATE NAMEONLY)
(* ;; "Edited 16-Oct-2025 16:59 by rmk")
(* ;;
 "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.")
(* ; "")
(* ;; "All the fields of the UFSGENFILESTATE are UTF8. FILENAME is MCCS")
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE))
FILENAME NAMELEN NEWNAME)
(COND
@@ -556,6 +909,9 @@
GENFILESTATE
)
0 NAMELEN))
(* ;; "NEWNAME and DIRECTORY are both UTF8")
(SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY)
of GENFILESTATE)
NEWNAME
@@ -607,8 +963,8 @@
(* ;; "We're set up to recurse into the SUBGEN above")
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))
(NAMEONLY NEWNAME)
(T FILENAME)))
(NAMEONLY (UTF8TOMSTRING NEWNAME))
(T (UTF8TOMSTRING FILENAME))))
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
(\UFS.FILEINFOFN
@@ -720,8 +1076,25 @@
(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)))))
)
[LAMBDA (PATHNAME) (* ; "Edited 16-Oct-2025 18:22 by rmk")
(* ; "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 'HOST]
(if (OR (EQ HOST 'DSK)
(EQ HOST 'UNIX))
then (if (SETQ PATH (DIRECTORYNAME PATH))
then (if (\UFSCHDIR-C (MTOUTF8STRING 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))))])
)
@@ -1184,23 +1557,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (8857 10410 (\UFSCreateDevice 8867 . 9232) (\UFS.CREATE.DEVICE 9234 . 10090) (
\UFSOpenDevice 10092 . 10269) (\UFSCloseDevice 10271 . 10408)) (14673 52047 (\UFSOpenFile 14683 .
17977) (\UFS.OPENP 17979 . 18476) (\UFS.RECOGNIZE.FILE 18478 . 19231) (\UFS.DIRECTORY.NAME 19233 .
19976) (\UFSCloseFile 19978 . 21883) (\UFSGetFileName 21885 . 22084) (\UFSDeleteFile 22086 . 22626) (
\UFSRenameFile 22628 . 24665) (\UFSReadPages 24667 . 25802) (\UFSWritePages 25804 . 27024) (
\UFSTruncateFile 27026 . 28523) (\UFSDirectoryNameP 28525 . 29579) (\UFSEventFn 29581 . 30243) (
\UFSGetFileInfo 30245 . 32527) (\UFS.CREATE.PROPS 32529 . 32882) (\UFSSetFileInfo 32884 . 34113) (
\UFSGenerateFiles 34115 . 40995) (\UFS.NEXTFILEFN 40997 . 48635) (\UFS.FILEINFOFN 48637 . 50086) (
\UFS.VALID.PROPP 50088 . 50380) (\UFS.REGISTER.GFS 50382 . 50637) (\UFS.UNREGISTER.GFS 50639 . 51222)
(\UFS.ABORT.DIRECTORY 51224 . 51572) (\UFS.ABORT.CL-DIRECTORY 51574 . 51861) (\UFS.CLEANUP.GFS.TABLE
51863 . 52045)) (52082 58766 (\UFSMakeUnixFormatName 52092 . 53113) (\UFSParseNameString 53115 . 53489
) (\UFSParse-Directory 53491 . 54032) (\UFS.PARSE.BODY 54034 . 54579) (\UFS.ADJUST.HOST 54581 . 54740)
(\UFS.FULLNAME 54742 . 55950) (\UFS.ADD.HOST.FIELD 55952 . 56312) (\UFS.REMOVE.HOST.FIELD 56314 .
57984) (\UFS.HANDLE.RELATIVEDIRECTORY 57986 . 58764)) (59582 60195 (CHDIR 59592 . 60193)) (60267 61253
(\DEVICEFILE.EOSERROR 60277 . 61251)) (61326 62563 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61336 . 62181)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 62183 . 62561)) (62596 64222 (\UFSError 62606 . 64220)) (64266 66681 (
\UFSGetFileType 64276 . 64877) (\UFSSetFileType 64879 . 65476) (\UFSeol 65478 . 66679)) (75328 76452 (
\UFSGetPrintFileType 75338 . 75750) (\UFSGetFileTypeConfirm 75752 . 76200) (\UFSPrintTypeMenu 76202 .
76450)) (76482 79320 (\UFStoOtherCopyMess 76492 . 78170) (\UFStoOtherRenameMess 78172 . 79318)))))
(FILEMAP (NIL (9321 10874 (\UFSCreateDevice 9331 . 9696) (\UFS.CREATE.DEVICE 9698 . 10554) (
\UFSOpenDevice 10556 . 10733) (\UFSCloseDevice 10735 . 10872)) (15137 63831 (\UFSOpenFile 15147 .
21723) (\UFS.OPENP 21725 . 22222) (\UFS.RECOGNIZE.FILE 22224 . 23654) (\UFS.DIRECTORY.NAME 23656 .
24746) (\UFSCloseFile 24748 . 26807) (\UFSGetFileName 26809 . 27008) (\UFSDeleteFile 27010 . 28204) (
\UFSRenameFile 28206 . 30523) (\UFSReadPages 30525 . 31660) (\UFSWritePages 31662 . 32882) (
\UFSTruncateFile 32884 . 35290) (\UFSDirectoryNameP 35292 . 37155) (\UFSEventFn 37157 . 37819) (
\UFSGetFileInfo 37821 . 42284) (\UFS.CREATE.PROPS 42286 . 42639) (\UFSSetFileInfo 42641 . 44987) (
\UFSGenerateFiles 44989 . 52601) (\UFS.NEXTFILEFN 52603 . 60419) (\UFS.FILEINFOFN 60421 . 61870) (
\UFS.VALID.PROPP 61872 . 62164) (\UFS.REGISTER.GFS 62166 . 62421) (\UFS.UNREGISTER.GFS 62423 . 63006)
(\UFS.ABORT.DIRECTORY 63008 . 63356) (\UFS.ABORT.CL-DIRECTORY 63358 . 63645) (\UFS.CLEANUP.GFS.TABLE
63647 . 63829)) (63866 70550 (\UFSMakeUnixFormatName 63876 . 64897) (\UFSParseNameString 64899 . 65273
) (\UFSParse-Directory 65275 . 65816) (\UFS.PARSE.BODY 65818 . 66363) (\UFS.ADJUST.HOST 66365 . 66524)
(\UFS.FULLNAME 66526 . 67734) (\UFS.ADD.HOST.FIELD 67736 . 68096) (\UFS.REMOVE.HOST.FIELD 68098 .
69768) (\UFS.HANDLE.RELATIVEDIRECTORY 69770 . 70548)) (71366 72511 (CHDIR 71376 . 72509)) (72583 73569
(\DEVICEFILE.EOSERROR 72593 . 73567)) (73642 74879 (\UNVISIBLE.PAGED.REVALIDATEFILELST 73652 . 74497)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 74499 . 74877)) (74912 76538 (\UFSError 74922 . 76536)) (76582 78997 (
\UFSGetFileType 76592 . 77193) (\UFSSetFileType 77195 . 77792) (\UFSeol 77794 . 78995)) (87644 88768 (
\UFSGetPrintFileType 87654 . 88066) (\UFSGetFileTypeConfirm 88068 . 88516) (\UFSPrintTypeMenu 88518 .
88766)) (88798 91636 (\UFStoOtherCopyMess 88808 . 90486) (\UFStoOtherRenameMess 90488 . 91634)))))
STOP

BIN
sources/UFS.LCOM
View File

Binary file not shown.