Move lispusers/PS-SKETCH-PATCH to obsolete/lispusers/ (#2248 )

Incompatible with current font interface, not loaded and sketch seems to work fine without it
update PICK to remove old comment. PICK is still just a hack, incomplete (#2247 )
2026-04-25 20:01:51 +00:00 · 2025-08-11 12:20:11 -07:00 · 2025-08-11 11:56:48 -07:00 · 2025-08-11 11:56:00 -07:00
7 changed files with 116 additions and 106 deletions
--- 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}<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)
@@ -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
+                              (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")
+                              (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)
+                              (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.")
+                                               (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)))))
+                                               (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
--- a/library/WHERE-IS.DFASL
+++ b/library/WHERE-IS.DFASL
--- a/lispusers/PICK
+++ b/lispusers/PICK
@@ -1,11 +1,12 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

-(FILECREATED "11-Aug-2022 17:53:58" {DSK}<home>larry>medley>lispusers>PICK.;3 4261   
+(FILECREATED " 9-Aug-2025 09:20:03" {DSK}<home>larry>il>medley>lispusers>PICK.;2 4413   

-      :CHANGES-TO (VARS PICKCOMS)
-                  (FNS PICK)
+      :EDIT-BY "lmm"

-      :PREVIOUS-DATE "10-Aug-2022 16:57:49" {DSK}<home>larry>medley>lispusers>PICK.;1)
+      :CHANGES-TO (FNS PICK)
+
+      :PREVIOUS-DATE "11-Aug-2022 17:53:58" {DSK}<home>larry>il>medley>lispusers>PICK.;1)


 (PRETTYCOMPRINT PICKCOMS)
@@ -27,14 +28,15 @@
 (DEFINEQ

 (PICK
-  [LAMBDA (TYPE CHOICES)                                     (* ; "Edited 11-Aug-2022 17:15 by lmm")
+  [LAMBDA (TYPE CHOICES)                                     (* ; "Edited  8-Aug-2025 09:06 by lmm")
+                                                             (* ; "Edited 11-Aug-2022 17:15 by lmm")
                                                             (* ; "Edited 10-Aug-2022 16:57 by lmm")
    (SELECTQ (MKATOM (U-CASE (MKSTRING TYPE)))
        (ONEOF                                               (* ; 
                                          "PICK ONEOF A1 A2 A3 ... - just choose from choices listed")
               [CAR (NTH CHOICES (RAND 1 (LENGTH CHOICES])
        (NIL                                                 (* ; 
-                                                         "pick -- choose an issue, a file, a project")
+                                       "PICK (with no parameters) choose an issue, a file, a project")
             [PICK (PICK 'ONEOF '(FILE ISSUE PROJECT])
        (ISSUE                                               (* ; 
                       "pick issue [number] -- display an issue; if none given, choose one at random")
@@ -46,14 +48,9 @@
                     (TITLE))
                    (for S in (GIT-COMMAND (CL:FORMAT NIL "gh issue view -R interlisp/medley ~d" 
                                                  ISSUE)) do (CL:FORMAT STR "~a~&" S)
-                       finally 
-
-                             (* ;; 
-             "this TEDIT call is wrong -- it takes the keyboard and the promptwindow prompt is wrong")
-
-                             [TEDIT STR NIL NIL `(READONLY T TITLE ,(SETQ TITLE (CL:FORMAT NIL 
-                                                                                       "Issue #~d" 
-                                                                                       ISSUE] 
+                       finally [TEDIT STR NIL NIL `(READONLY T TITLE ,(SETQ TITLE
+                                                                       (CL:FORMAT NIL "Issue #~d" 
+                                                                              ISSUE] 

                             (* ;; "if there are comments (or always) show comments too -- the -w switch doesn't work online -- no browser")

@@ -65,23 +62,27 @@
        (DIR 
             (* ;; "pick a directory to choose files from")

-             (PICK 'ONEOF '(LISPUSERS LIBRARY DOCTOOLS SOURCES INTERNAL)))
+             [LIST 'DIRECTORY "Examine directory"
+                   (PICK 'ONEOF '(CLOS CLTL2 FONTS GREETFILES LISPUSERS LIBRARY DOCTOOLS DOCS SOURCES
+                                       INTERNAL])
        (FILE 
              (* ;; " pick a file from a (randomly chosen) directory")

-              [LIST 'FILE (PICK 'ONEOF (DIRECTORY (OR (MEDLEYDIR (OR (CAR CHOICES)
-                                                                     (PICK 'DIR))
-                                                             NIL T)
-                                                      (FETCH (GIT-PROJECT CLONEPATH)
-                                                         OF (CDR (ASSOC (CAR CHOICES)
-                                                                        GIT-PROJECTS])
+              [LIST 'FILE "Examine file"
+                    (PICK 'ONEOF (DIRECTORY (OR (MEDLEYDIR [OR (CAR CHOICES)
+                                                               (CL:THIRD (PICK 'DIR]
+                                                       NIL T)
+                                                (FETCH (GIT-PROJECT CLONEPATH)
+                                                   OF (CDR (ASSOC (CAR CHOICES)
+                                                                  GIT-PROJECTS])
        (PROJECT 
                 (* ;; "pick PROJECT will choose some repo to work on")

-                 [PICK 'ONEOF (PICK 'ONEOF (LIST (MAPCAR GIT-PROJECTS #'CAR)
-                                                 '(CLOS ROOMS ONLINE WEBSITE COMMUNITY ENVOS])
-        (HELP TYPE "Unknown type"])
+                 [LIST 'PROJECT "Examine the fiiles associated with the GITFNS project"
+                       (PICK 'ONEOF (PICK 'ONEOF (LIST (MAPCAR GIT-PROJECTS #'CAR)
+                                                       '(CLOS ROOMS ONLINE WEBSITE COMMUNITY ENVOS])
+        (HELP TYPE "Unknown type to pick from"])
 )
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (735 4238 (PICK 745 . 4236)))))
+  (FILEMAP (NIL (729 4390 (PICK 739 . 4388)))))
 STOP
--- a/lispusers/PICK.LCOM
+++ b/lispusers/PICK.LCOM
--- a/obsolete/lispusers/PS-SKETCH-PATCH
+++ b/obsolete/lispusers/PS-SKETCH-PATCH
--- a/obsolete/lispusers/PS-SKETCH-PATCH.LCOM
+++ b/obsolete/lispusers/PS-SKETCH-PATCH.LCOM
--- a/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT
+++ b/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT
Author	SHA1	Message	Date
rmkaplan	9c93b27d79	Move lispusers/PS-SKETCH-PATCH to obsolete/lispusers/ (#2248 ) Incompatible with current font interface, not loaded and sketch seems to work fine without it	2025-08-11 12:20:11 -07:00
Larry Masinter	e8c5ba90f3	update PICK to remove old comment. PICK is still just a hack, incomplete (#2247 )	2025-08-11 11:56:48 -07:00
Matt Heffron	305c419b1d	WHERE-IS error handling improvement (#2235 ) For loadup --aux reporting of errors during building whereis.hash: Just ignore pathnames that are just a directory. For other errors, report the condition that caused the error, instead of just generic Warning message	2025-08-11 11:56:00 -07:00