diff --git a/library/WHERE-IS b/library/WHERE-IS index 30f6fd09e..2324fef4a 100644 --- a/library/WHERE-IS +++ b/library/WHERE-IS @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "XEROX-COMMON-LISP" READTABLE "XCL" BASE 10) -(IL:FILECREATED "30-Apr-2023 13:54:00" IL:|{DSK}larry>il>medley>library>WHERE-IS.;2| 17396 +(IL:FILECREATED "30-Jul-2025 16:15:16" IL:|{DSK}matt>Interlisp>medley>library>WHERE-IS.;5| 17827 - :EDIT-BY "lmm" + :EDIT-BY "mth" - :CHANGES-TO (IL:FUNCTIONS ADD-WHERE-IS-DATABASE) + :CHANGES-TO (IL:FUNCTIONS WHERE-IS-READ-COMS WHERE-IS-NOTICE) - :PREVIOUS-DATE "11-Mar-2022 22:40:32" IL:|{DSK}larry>il>medley>library>WHERE-IS.;1|) + :PREVIOUS-DATE "30-Apr-2023 13:54:00" IL:|{DSK}matt>Interlisp>medley>library>WHERE-IS.;1| +) (IL:PRETTYCOMPRINT IL:WHERE-ISCOMS) @@ -204,60 +205,62 @@ (DEFINE-TYPES (WHERE-IS-DEFAULT-DEFINE-TYPES)) (HASH-FILE-SIZE *WHERE-IS-HASH-FILE-SIZE*) (QUIET NIL) - (TEMP-FILE NIL)) - (LET* ((FILE (IF TEMP-FILE - (IF NEW - TEMP-FILE - (IL:COPYFILE DATABASE-FILE TEMP-FILE)) - DATABASE-FILE)) - (HASH-FILE:HASH-FILE (IF NEW - (HASH-FILE:MAKE-HASH-FILE FILE HASH-FILE-SIZE) - (HASH-FILE:OPEN-HASH-FILE FILE :DIRECTION :IO))) - (HASH-FILE::*DELETE-OLD-VERSION-ON-REHASH* T)) - (UNWIND-PROTECT - (DOLIST (PATHNAME (WHERE-IS-FILES FILES)) - (UNLESS QUIET - (FORMAT T ";;; ~A ." (NAMESTRING PATHNAME))) - (LET ((NAMESTRING (WHERE-IS-NAMESTRING PATHNAME))) - (IF (AND (NOT NEW) - (LET ((OLD-WRITE-DATE (WHERE-IS-GET-WRITE-DATE NAMESTRING - HASH-FILE:HASH-FILE))) - (AND OLD-WRITE-DATE (= (FILE-WRITE-DATE PATHNAME) - OLD-WRITE-DATE)))) - (UNLESS QUIET (FORMAT T " up to date.~%")) - (MULTIPLE-VALUE-BIND - (FILE-VARS VALUES) - (WHERE-IS-READ-COMS PATHNAME) - (WHEN FILE-VARS - - (IL:* IL:|;;| "bind the filevars s.t. IL:INFILECOMS? will find them") - - (PROGV FILE-VARS VALUES - (UNLESS QUIET (PRINC ".")) - (DOLIST (TYPE DEFINE-TYPES) - (LET ((NAMES (IL:INFILECOMS? NIL TYPE (FIRST FILE-VARS)))) - (WHEN (CONSP NAMES) - - (IL:* IL:|;;| "IL:INFILECOMS? sometimes returns T.") - - (DOLIST (NAME NAMES) - (WHERE-IS-NOTICE-INTERNAL NAME TYPE NAMESTRING - HASH-FILE:HASH-FILE)))))) - (WHERE-IS-SET-WRITE-DATE NAMESTRING PATHNAME HASH-FILE:HASH-FILE) - (UNLESS QUIET - (PRINC ". done.") - (TERPRI))))))) - (HASH-FILE:CLOSE-HASH-FILE HASH-FILE:HASH-FILE)) - (LET ((PATHNAME (PATHNAME (HASH-FILE::HASH-FILE-STREAM HASH-FILE:HASH-FILE)))) - (COND - (TEMP-FILE (UNLESS QUIET - (FORMAT T ";;; Renaming ~A ... " (NAMESTRING PATHNAME))) - (MULTIPLE-VALUE-BIND (MERGED TRUE-NAME REAL-TRUE-NAME) - (RENAME-FILE PATHNAME DATABASE-FILE) - (UNLESS QUIET - (FORMAT T "~A~%" (NAMESTRING REAL-TRUE-NAME))) - REAL-TRUE-NAME)) - (T PATHNAME))))) + (TEMP-FILE NIL)) (IL:* IL:\; "Edited 29-Jul-2025 23:55 by mth") + (LET* + ((FILE (IF TEMP-FILE + (IF NEW + TEMP-FILE + (IL:COPYFILE DATABASE-FILE TEMP-FILE)) + DATABASE-FILE)) + (HASH-FILE:HASH-FILE (IF NEW + (HASH-FILE:MAKE-HASH-FILE FILE HASH-FILE-SIZE) + (HASH-FILE:OPEN-HASH-FILE FILE :DIRECTION :IO))) + (HASH-FILE::*DELETE-OLD-VERSION-ON-REHASH* T)) + (UNWIND-PROTECT + (DOLIST (PATHNAME (WHERE-IS-FILES FILES)) + (WHEN (PATHNAME-NAME PATHNAME) (IL:* IL:\; "Skip directory entries") + (UNLESS QUIET + (FORMAT T ";;; ~A ." (NAMESTRING PATHNAME))) + (LET ((NAMESTRING (WHERE-IS-NAMESTRING PATHNAME))) + (IF (AND (NOT NEW) + (LET ((OLD-WRITE-DATE (WHERE-IS-GET-WRITE-DATE NAMESTRING + HASH-FILE:HASH-FILE))) + (AND OLD-WRITE-DATE (= (FILE-WRITE-DATE PATHNAME) + OLD-WRITE-DATE)))) + (UNLESS QUIET (FORMAT T " up to date.~%")) + (MULTIPLE-VALUE-BIND + (FILE-VARS VALUES) + (WHERE-IS-READ-COMS PATHNAME) + (WHEN FILE-VARS + + (IL:* IL:|;;| "bind the filevars s.t. IL:INFILECOMS? will find them") + + (PROGV FILE-VARS VALUES + (UNLESS QUIET (PRINC ".")) + (DOLIST (TYPE DEFINE-TYPES) + (LET ((NAMES (IL:INFILECOMS? NIL TYPE (FIRST FILE-VARS)))) + (WHEN (CONSP NAMES) + + (IL:* IL:|;;| "IL:INFILECOMS? sometimes returns T.") + + (DOLIST (NAME NAMES) + (WHERE-IS-NOTICE-INTERNAL NAME TYPE NAMESTRING + HASH-FILE:HASH-FILE)))))) + (WHERE-IS-SET-WRITE-DATE NAMESTRING PATHNAME HASH-FILE:HASH-FILE) + (UNLESS QUIET + (PRINC ". done.") + (TERPRI)))))))) + (HASH-FILE:CLOSE-HASH-FILE HASH-FILE:HASH-FILE)) + (LET ((PATHNAME (PATHNAME (HASH-FILE::HASH-FILE-STREAM HASH-FILE:HASH-FILE)))) + (COND + (TEMP-FILE (UNLESS QUIET + (FORMAT T ";;; Renaming ~A ... " (NAMESTRING PATHNAME))) + (MULTIPLE-VALUE-BIND (MERGED TRUE-NAME REAL-TRUE-NAME) + (RENAME-FILE PATHNAME DATABASE-FILE) + (UNLESS QUIET + (FORMAT T "~A~%" (NAMESTRING REAL-TRUE-NAME))) + REAL-TRUE-NAME)) + (T PATHNAME))))) (DEFUN WHERE-IS-NOTICE-INTERNAL (NAME TYPE FILE-NAME HASH-FILE:HASH-FILE) @@ -318,7 +321,7 @@ NIL (PATHNAME-TYPE PATHNAME))))) -(DEFUN WHERE-IS-READ-COMS (PATHNAME) +(DEFUN WHERE-IS-READ-COMS (PATHNAME) (IL:* IL:\; "Edited 30-Jul-2025 16:13 by mth") (IL:* IL:|;;;| "returns as first value a list of the filevars on PATHNAME, as second value a list of the values for these filevars.") @@ -330,23 +333,28 @@ (DO ((IL:LOAD-VERBOSE-STREAM 'NIL) (ALL-FILE-VARS) (QUEUE (LIST (IL:FILECOMS (STRING-UPCASE (PATHNAME-NAME PATHNAME)))) - (COND - ((CONSP (IL:NLSETQ (IL:LOADVARS QUEUE PATHNAME NIL))) - (MAPCAN #'(LAMBDA (FILE-VAR) - (IF (BOUNDP FILE-VAR) - (LET ((FILE-VARS (IL:INFILECOMS? NIL 'IL:FILEVARS - FILE-VAR))) - (PUSH FILE-VAR ALL-FILE-VARS) - (WHEN (CONSP FILE-VARS) - FILE-VARS)) - (PROG1 NIL - (WARN "Couldn't find ~S on ~A." FILE-VAR (NAMESTRING - PATHNAME)))) - ) - QUEUE)) - (T (WARN "Error attempting to LOADVARS ~S from ~A." QUEUE (NAMESTRING PATHNAME) - ) - 'NIL)))) + (MULTIPLE-VALUE-BIND + (LV-RESULT ERROR-CONDITION) + (IGNORE-ERRORS (IL:LOADVARS QUEUE PATHNAME NIL)) + (COND + ((CONSP LV-RESULT) + (MAPCAN #'(LAMBDA (FILE-VAR) + (IF (BOUNDP FILE-VAR) + (LET ((FILE-VARS (IL:INFILECOMS? NIL 'IL:FILEVARS + FILE-VAR))) + (PUSH FILE-VAR ALL-FILE-VARS) + (WHEN (CONSP FILE-VARS) + FILE-VARS)) + (PROG1 NIL + (WARN "Couldn't find ~S on ~A." FILE-VAR + (NAMESTRING PATHNAME))))) + QUEUE)) + (ERROR-CONDITION (WARN + "Error attempting to LOADVARS ~S from ~A.~%Condition: ~A" + QUEUE (NAMESTRING PATHNAME) + ERROR-CONDITION) + 'NIL) + (T NIL))))) ((NULL QUEUE) (SETQ ALL-FILE-VARS (NREVERSE ALL-FILE-VARS)) (VALUES ALL-FILE-VARS (MAPCAR #'SYMBOL-VALUE ALL-FILE-VARS))) @@ -379,14 +387,15 @@ (IL:PUTPROPS IL:WHERE-IS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:PUTPROPS IL:WHERE-IS IL:FILETYPE :COMPILE-FILE) +(IL:PUTPROPS IL:WHERE-IS IL:COPYRIGHT (IL:NONE)) (IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL (1737 2069 (HASH-FILE-WHERE-IS 1737 . 2069)) (2071 2464 (HASH-FILE-TYPES-OF 2071 . -2464)) (2466 4631 (GET-WHERE-IS-ENTRIES 2466 . 4631)) (4633 5148 (WHERE-IS-READ-FN 4633 . 5148)) (5150 - 5306 (ADD-WHERE-IS-DATABASES 5150 . 5306)) (5308 5695 (ADD-WHERE-IS-DATABASE 5308 . 5695)) (5697 6176 - (DEL-WHERE-IS-DATABASE 5697 . 6176)) (6178 7330 (SAME-WHERE-IS-DATABASE 6178 . 7330)) (7332 8539 ( -CLOSE-WHERE-IS-FILES 7332 . 8539)) (8797 12214 (WHERE-IS-NOTICE 8797 . 12214)) (12216 12960 ( -WHERE-IS-NOTICE-INTERNAL 12216 . 12960)) (12962 13698 (WHERE-IS-FILES 12962 . 13698)) (13700 14065 ( -WHERE-IS-DEFAULT-DEFINE-TYPES 13700 . 14065)) (14067 14486 (WHERE-IS-NAMESTRING 14067 . 14486)) (14488 - 16500 (WHERE-IS-READ-COMS 14488 . 16500)) (16502 16773 (WHERE-IS-SET-WRITE-DATE 16502 . 16773)) ( -16775 17025 (WHERE-IS-GET-WRITE-DATE 16775 . 17025))))) + (IL:FILEMAP (NIL (1763 2095 (HASH-FILE-WHERE-IS 1763 . 2095)) (2097 2490 (HASH-FILE-TYPES-OF 2097 . +2490)) (2492 4657 (GET-WHERE-IS-ENTRIES 2492 . 4657)) (4659 5174 (WHERE-IS-READ-FN 4659 . 5174)) (5176 + 5332 (ADD-WHERE-IS-DATABASES 5176 . 5332)) (5334 5721 (ADD-WHERE-IS-DATABASE 5334 . 5721)) (5723 6202 + (DEL-WHERE-IS-DATABASE 5723 . 6202)) (6204 7356 (SAME-WHERE-IS-DATABASE 6204 . 7356)) (7358 8565 ( +CLOSE-WHERE-IS-FILES 7358 . 8565)) (8823 12278 (WHERE-IS-NOTICE 8823 . 12278)) (12280 13024 ( +WHERE-IS-NOTICE-INTERNAL 12280 . 13024)) (13026 13762 (WHERE-IS-FILES 13026 . 13762)) (13764 14129 ( +WHERE-IS-DEFAULT-DEFINE-TYPES 13764 . 14129)) (14131 14550 (WHERE-IS-NAMESTRING 14131 . 14550)) (14552 + 16882 (WHERE-IS-READ-COMS 14552 . 16882)) (16884 17155 (WHERE-IS-SET-WRITE-DATE 16884 . 17155)) ( +17157 17407 (WHERE-IS-GET-WRITE-DATE 17157 . 17407))))) IL:STOP diff --git a/library/WHERE-IS.DFASL b/library/WHERE-IS.DFASL index 8abe17d16..74605b1d3 100644 Binary files a/library/WHERE-IS.DFASL and b/library/WHERE-IS.DFASL differ