Skip to content

WHERE-IS error handling improvement #2235

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Aug 11, 2025
Merged

WHERE-IS error handling improvement #2235

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
179 changes: 94 additions & 85 deletions library/WHERE-IS
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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}<home>larry>il>medley>library>WHERE-IS.;2| 17396
(IL:FILECREATED "30-Jul-2025 16:15:16" IL:|{DSK}<home>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}<home>larry>il>medley>library>WHERE-IS.;1|)
:PREVIOUS-DATE "30-Apr-2023 13:54:00" IL:|{DSK}<home>matt>Interlisp>medley>library>WHERE-IS.;1|
)


(IL:PRETTYCOMPRINT IL:WHERE-ISCOMS)
Expand Down Expand Up @@ -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)

Expand Down Expand Up @@ -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.")

Expand All @@ -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)))
Expand Down Expand Up @@ -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
Binary file modified library/WHERE-IS.DFASL
View file
Open in desktop
Binary file not shown.