github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-26 17:13:17 +00:00
Code Issues Projects Releases Wiki Activity

DIRECTORY: minor cleanup, comments

Browse Source
This commit is contained in:
rmkaplan
2022-04-24 13:36:50 -07:00
parent eb33dcc7eb
commit 9f5a43abd1
2 changed files with 139 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

231
sources/DIRECTORY
View File

@@ -1,11 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 5-Mar-2022 09:04:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;8 27503
(FILECREATED "29-Mar-2022 10:53:16" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;15 28665
:CHANGES-TO (FNS DIRECTORY FILDIR)
:CHANGES-TO (FNS DIRECTORY)
:PREVIOUS-DATE " 5-Mar-2022 08:46:23"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;7)
:PREVIOUS-DATE "29-Mar-2022 08:29:33"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;14)
(* ; "
@@ -49,8 +49,14 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
(DIRECTORY
[LAMBDA (FILES COMMANDS DEFAULTEXT DEFAULTVERS)
(DECLARE (SPECVARS COMMANDS DEFAULTEXT DEFAULTVERS)) (* ; "Edited 4-Mar-2022 23:17 by rmk")
(DECLARE (SPECVARS COMMANDS DEFAULTEXT DEFAULTVERS)) (* ; "Edited 29-Mar-2022 10:53 by rmk")
(* ; "Edited 26-Mar-2022 09:41 by rmk")
(* ; "Edited 4-Mar-2022 23:17 by rmk")
(* ; "Edited 30-Apr-92 14:55 by jds")
(CL:UNLESS DEFAULTEXT
(SETQ DEFAULTEXT '*))
(CL:UNLESS DEFAULTVERS
(SETQ DEFAULTVERS '*))
(PROG (VALUE COLUMNS NAMEFLG DELETEDONLY FILEGROUP PRINTFLG OUTFILE PROMPTFLG LASTHOST&DIR
DESIREDPROPS PFLG HEADINGS VALUES-WANTED (FILING.ENUMERATION.DEPTH
FILING.ENUMERATION.DEPTH))
@@ -114,7 +120,8 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
(IGEQ (CADR COMTAIL)
0))
THEN (CADR COMTAIL)
ELSEIF (EQ T (CADR COMTAIL))
ELSEIF (MEMB (U-CASE (CADR COMTAIL))
'(T ALL))
THEN MAX.SMALLP
ELSE (\ILLEGAL.ARG (CADR COMTAIL]
@@ -205,17 +212,46 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
(while (DIRECTORY.NEXTFILE FILEGROUP) do (DODIRCOMMANDS COMMANDS FILEGROUP))
(COND
(PRINTFLG (TAB 0 0))))
(RETURN (OR VALUE (COND
((NOT VALUES-WANTED)
(CL:VALUES])
(* ;; "DREVERSE because files are pushed.")
(RETURN (OR (DREVERSE VALUE)
(CL:UNLESS VALUES-WANTED (CL:VALUES])
(DIRECTORY.PARSE
(LAMBDA (FG) (* bvm%: "14-May-84 12:55") (* ;; "This pushes file generators on FILEGROUP for each of the atomic filespecifications it comes to.") (DECLARE (USEDFREE FILEGROUP DESIREDPROPS DEFAULTEXT DEFAULTVERS)) (PROG (TEMP) (RETURN (COND ((NLISTP FG) (push FILEGROUP (\GENERATEFILES (SETQ FG (DIRECTORY.FILL.PATTERN FG DEFAULTEXT DEFAULTVERS)) DESIREDPROPS (QUOTE (SORT RESETLST)))) (DIRECTORY.MATCH.SETUP FG)) ((SETQ TEMP (DIRCONJ (CADR FG))) (CONS TEMP (CONS (DIRECTORY.PARSE (CAR FG)) (DIRECTORY.PARSE (CADDR FG))))) ((SETQ TEMP (DIRCONJ (CAR FG))) (CONS TEMP (CONS (DIRECTORY.PARSE (CADR FG)) (DIRECTORY.PARSE (CADDR FG))))) (T (ERROR "Bad file-group conjunction" (CADR FG)))))))
)
[LAMBDA (FG) (* ; "Edited 26-Mar-2022 18:49 by rmk")
(* bvm%: "14-May-84 12:55")
(* ;;
 "This pushes file generators on FILEGROUP for each of the atomic filespecifications it comes to.")
(DECLARE (USEDFREE FILEGROUP DESIREDPROPS DEFAULTEXT DEFAULTVERS))
(LET (TEMP)
(COND
((NLISTP FG)
[push FILEGROUP (\GENERATEFILES (SETQ FG (DIRECTORY.FILL.PATTERN FG DEFAULTEXT
DEFAULTVERS))
DESIREDPROPS
'(SORT RESETLST]
(DIRECTORY.MATCH.SETUP FG))
[(SETQ TEMP (DIRCONJ (CADR FG))) (* ; "Infix operator")
(CONS TEMP (CONS (DIRECTORY.PARSE (CAR FG))
(DIRECTORY.PARSE (CADDR FG]
[(SETQ TEMP (DIRCONJ (CAR FG))) (* ; "Prefix operator")
(CONS TEMP (CONS (DIRECTORY.PARSE (CADR FG))
(DIRECTORY.PARSE (CADDR FG]
(T (ERROR "Bad file-group conjunction" (CADR FG])
(DIRECTORY.FILL.PATTERN
(LAMBDA (PATTERN DEFAULTEXT DEFAULTVERS) (* bvm%: " 6-Feb-85 14:16") (DECLARE (GLOBALVARS \CONNECTED.DIRECTORY)) (PACKFILENAME.STRING (QUOTE BODY) PATTERN (QUOTE NAME) (QUOTE *) (QUOTE VERSION) (OR DEFAULTVERS (QUOTE *)) (QUOTE EXTENSION) (OR DEFAULTEXT (QUOTE *)) (QUOTE DIRECTORY) (AND (NOT (FILENAMEFIELD PATTERN (QUOTE HOST))) \CONNECTED.DIRECTORY)))
)
[LAMBDA (PATTERN DEFAULTEXT DEFAULTVERS) (* ; "Edited 26-Mar-2022 17:54 by rmk")
(* bvm%: " 6-Feb-85 14:16")
(DECLARE (GLOBALVARS \CONNECTED.DIRECTORY))
(PACKFILENAME.STRING 'BODY PATTERN 'NAME '* 'VERSION (OR DEFAULTVERS '*)
'EXTENSION
(OR DEFAULTEXT '*)
'DIRECTORY
(AND (NOT (FILENAMEFIELD.STRING PATTERN 'HOST))
\CONNECTED.DIRECTORY])
(DIRCONJ
(LAMBDA (CONJ) (* rmk%: "29-OCT-81 11:01") (* ;; "Returns canonical form of directory conjunction, NIL if invalid") (SELECTQ CONJ ((OR +) (QUOTE OR)) ((AND *) (QUOTE AND)) ((- ANDNOT) (QUOTE ANDNOT)) NIL))
@@ -242,7 +278,8 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
)
(DODIRCOMMANDS
[LAMBDA (COMMANDS FILEGROUP) (* ; "Edited 30-Apr-92 15:03 by jds")
[LAMBDA (COMMANDS FILEGROUP) (* ; "Edited 29-Mar-2022 08:16 by rmk")
(* ; "Edited 30-Apr-92 15:03 by jds")
(PROG ((COMTAIL COMMANDS)
(I 0)
(FILENAME (fetch LITERALNAME of FILEGROUP))
@@ -259,82 +296,80 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
(SETQ I 0)))
(while COMTAIL
do (SELECTQ (SETQ COM (pop COMTAIL))
(P (DIRPRINTNAME FILEGROUP))
(PP (DIRPRINTNAME FILEGROUP T))
(COUNTSIZE (add VALUE (DIRGETFILEINFO FILEGROUP 'SIZE)))
(PAUSE (READC T)
(SETQ I (IPLUS I 2)))
(@ (* ;
 "Arbitrary predicate -- next thing is form")
(AND NAMEFLG (DIRFILENAME FILEGROUP))
(COND
((NOT (EVAL (pop COMTAIL)))
(RETURN))))
((OLDERTHAN NEWERTHAN)
[LET ((COMDATE (pop COMTAIL))
DT)
(COND
([OR [EQ (EQ COM 'OLDERTHAN)
(OR (AND (SETQ DT (DIRGETFILEINFO FILEGROUP
'ICREATIONDATE))
(IGEQ DT COMDATE))
(AND (SETQ DT (DIRGETFILEINFO FILEGROUP
'IWRITEDATE))
(IGEQ DT COMDATE]
(AND (EQ COM 'OLDERTHAN)
(AND (SETQ DT (DIRGETFILEINFO FILEGROUP
'IREADDATE))
(IGEQ DT COMDATE]
(P (DIRPRINTNAME FILEGROUP))
(PP (DIRPRINTNAME FILEGROUP T))
(COUNTSIZE (add VALUE (DIRGETFILEINFO FILEGROUP 'SIZE)))
(PAUSE (READC T)
(SETQ I (IPLUS I 2)))
(@ (* ;
 "Arbitrary predicate -- next thing is form")
(AND NAMEFLG (DIRFILENAME FILEGROUP))
(COND
((NOT (EVAL (pop COMTAIL)))
(RETURN))))
((OLDERTHAN NEWERTHAN)
[LET ((COMDATE (pop COMTAIL))
DT)
(COND
([OR [EQ (EQ COM 'OLDERTHAN)
(OR (AND (SETQ DT (DIRGETFILEINFO FILEGROUP 'ICREATIONDATE)
)
(IGEQ DT COMDATE))
(AND (SETQ DT (DIRGETFILEINFO FILEGROUP 'IWRITEDATE))
(IGEQ DT COMDATE]
(AND (EQ COM 'OLDERTHAN)
(AND (SETQ DT (DIRGETFILEINFO FILEGROUP 'IREADDATE))
(IGEQ DT COMDATE]
(* ;; "Only check Read date for the OLDERTHAN case, where it is useful for archiving. NEWERTHAN is only interested in files actually created recently")
(RETURN])
(BY (SETQ COM (pop COMTAIL))
(COND
((AND (SETQ ATTRVALUE (DIRGETFILEINFO FILEGROUP 'AUTHOR))
(NOT (STRPOS COM ATTRVALUE NIL NIL NIL NIL UPPERCASEARRAY)))
(RETURN))))
(DELETE (DTAB 12)
(PRIN1 (COND
((DELFILE (DIRFILENAME FILEGROUP))
"deleted")
(T "can't delete"))))
(PROMPT (OR (DREAD (pop COMTAIL))
(RETURN)))
(PRINT (DPRIN1 (pop COMTAIL)))
(COLLECT (SETQ VALUE (NCONC1 VALUE (DIRFILENAME FILEGROUP))))
(OLDVERSIONS (* ;
 "Not implemented, but user might continue from error in DIRECTORY")
(COND
((NEQ (CAR COMTAIL)
1)
(ERROR "can't count more than 1 version")))
(COND
((STRING.EQUAL (INFILEP (DIRFILENAME FILEGROUP))
(INFILEP (PACKFILENAME 'VERSION NIL 'BODY FILENAME)))
(RETURN])
(BY (SETQ COM (pop COMTAIL))
(COND
((AND (SETQ ATTRVALUE (DIRGETFILEINFO FILEGROUP 'AUTHOR))
(NOT (STRPOS COM ATTRVALUE NIL NIL NIL NIL UPPERCASEARRAY)))
(RETURN))))
(DELETE (DTAB 12)
(PRIN1 (COND
((DELFILE (DIRFILENAME FILEGROUP))
"deleted")
(T "can't delete"))))
(PROMPT (OR (DREAD (pop COMTAIL))
(RETURN)))
(PRINT (DPRIN1 (pop COMTAIL)))
(COLLECT (PUSH VALUE (DIRFILENAME FILEGROUP)))
(OLDVERSIONS (* ;
 "Not implemented, but user might continue from error in DIRECTORY")
(COND
((NEQ (CAR COMTAIL)
1)
(ERROR "can't count more than 1 version")))
(COND
((STRING.EQUAL (INFILEP (DIRFILENAME FILEGROUP))
(INFILEP (PACKFILENAME 'VERSION NIL 'BODY FILENAME)))
(* ;; "Used to be EQ, but that fails for dsk files?")
(* ;; "Used to be EQ, but that fails for dsk files?")
(RETURN)))
(pop COMTAIL))
((DELETED UNDELETE) (* ; "Not implemented")
)
(NOP)
(LET ((TYPE (FASSOC COM FILEINFOTYPES)))
(COND
[TYPE (DTAB (CADR TYPE))
(RETURN)))
(pop COMTAIL))
((DELETED UNDELETE) (* ; "Not implemented")
)
(NOP)
(LET ((TYPE (FASSOC COM FILEINFOTYPES)))
(COND
[TYPE (DTAB (CADR TYPE))
(COND
((SETQ ATTRVALUE (DIRGETFILEINFO FILEGROUP COM))
(COND
((SETQ ATTRVALUE (DIRGETFILEINFO FILEGROUP COM))
(COND
((FIXP ATTRVALUE)
(PRINTNUM (OR (CDDR TYPE)
(LIST 'FIX (CADR TYPE)))
ATTRVALUE))
((AND (LISTP ATTRVALUE)
(LISTP (CAR ATTRVALUE)))
(PRINTDEF ATTRVALUE (POSITION)))
(T (PRIN1 ATTRVALUE]
(T (SHOULDNT])
((FIXP ATTRVALUE)
(PRINTNUM (OR (CDDR TYPE)
(LIST 'FIX (CADR TYPE)))
ATTRVALUE))
((AND (LISTP ATTRVALUE)
(LISTP (CAR ATTRVALUE)))
(PRINTDEF ATTRVALUE (POSITION)))
(T (PRIN1 ATTRVALUE]
(T (SHOULDNT])
(DIRPRINTNAME
(LAMBDA (FILEGROUP FLG) (DECLARE (USEDFREE LASTHOST&DIR NAMEPRINTED)) (* ; "Edited 27-Apr-90 10:07 by nm") (COND ((NOT NAMEPRINTED) (PROG ((STREAM (GETSTREAM NIL (QUOTE OUTPUT))) (FULLNAME (fetch STRINGNAME of FILEGROUP)) (LASTNAME (CAR LASTHOST&DIR)) DIFFERENT DIRECTORYEND) (for I from 1 bind THISCHAR LASTCHAR do (* ; "Scan for end of directory name, and notice whether it matches previously printed directory") (SELCHARQ (SETQ THISCHAR (NTHCHARCODE FULLNAME I)) (NIL (RETURN)) ((} < > / %)) (SETQ DIRECTORYEND I)) NIL) (COND ((AND (NOT DIFFERENT) (COND ((NULL (SETQ LASTCHAR (NTHCHARCODE LASTNAME I)))) ((> LASTCHAR \MAXTHINCHAR) (* ; "Fat chars don't go thru casearray") (NEQ LASTCHAR THISCHAR)) ((> THISCHAR \MAXTHINCHAR)) (T (* ; "Two thin chars, are they really different?") (NEQ (GETCASEARRAY UPPERCASEARRAY LASTCHAR) (GETCASEARRAY UPPERCASEARRAY THISCHAR))))) (SETQ DIFFERENT I)))) (COND ((AND DIFFERENT DIRECTORYEND (OR (NEQ DIRECTORYEND (CADR LASTHOST&DIR)) (<= DIFFERENT DIRECTORYEND))) (TAB 0 0) (* ; "New directory") (TERPRI) (SPACES 3) (for I from 1 to DIRECTORYEND do (\OUTCHAR STREAM (NTHCHARCODE FULLNAME I))) (SETQ LASTHOST&DIR (LIST FULLNAME DIRECTORYEND)))) (DTAB 20) (for I from (ADD1 (OR DIRECTORYEND 0)) do (COND ((AND FLG (EQ (NTHCHARCODE FULLNAME I) (CHARCODE ;))) (RETURN))) (\OUTCHAR STREAM (OR (NTHCHARCODE FULLNAME I) (RETURN)))) (SPACES 1) (SETQ NAMEPRINTED T)))))
@@ -344,8 +379,20 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
(LAMBDA (STR) (* lmm "20-OCT-78 02:53") (DTAB (NCHARS STR)) (PRIN1 STR)))
(DIRFILENAME
(LAMBDA (FILEGROUP) (* ; "Edited 28-Jul-87 14:55 by bvm:") (DECLARE (USEDFREE FILE FILENAME)) (* ; "These might be used freely by user predicates, with @ commands") (OR (fetch LITERALNAME of FILEGROUP) (replace LITERALNAME of FILEGROUP with (SETQ FILE (SETQ FILENAME (MKATOM (LET ((NAME (fetch STRINGNAME of FILEGROUP))) (COND ((AND *UPPER-CASE-FILE-NAMES* (NOT (U-CASEP NAME))) (U-CASE NAME)) (T NAME)))))))))
)
[LAMBDA (FILEGROUP)
(* ;; "Edited 28-Mar-2022 11:08 by rmk: Don't convert to atoms, always return strings")
(* ;; "Edited 28-Jul-87 14:55 by bvm:")
(DECLARE (USEDFREE FILE FILENAME)) (* ;
 "These might be used freely by user predicates, with @ commands")
(IF (fetch LITERALNAME of FILEGROUP)
ELSE (SETQ FILENAME (fetch STRINGNAME of FILEGROUP))
(CL:WHEN (AND *UPPER-CASE-FILE-NAMES* (NOT (U-CASEP FILENAME)))
(SETQ FILENAME (U-CASE FILENAME)))
(SETQ FILE FILENAME)
(replace LITERALNAME of FILEGROUP with FILENAME])
(DIRGETFILEINFO
(LAMBDA (FILEGROUP ATTRIBUTE) (* bvm%: " 5-May-84 15:19") (\GENERATEFILEINFO (CAR (fetch FILEGENERATORS of FILEGROUP)) ATTRIBUTE))
@@ -418,10 +465,10 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
)
(PUTPROPS DIRECTORY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1330 25982 (DODIR 1340 . 1887) (FILDIR 1889 . 2169) (DIRECTORY 2171 . 12442) (
DIRECTORY.PARSE 12444 . 13152) (DIRECTORY.FILL.PATTERN 13154 . 13538) (DIRCONJ 13540 . 13760) (
DIRECTORY.NEXTFILE 13762 . 14355) (DMATCH 14357 . 14732) (DIRECTORY.MATCH.SETUP 14734 . 15268) (
DIRECTORY.MATCH 15270 . 15687) (DIRECTORY.MATCH1 15689 . 17802) (DODIRCOMMANDS 17804 . 23577) (
DIRPRINTNAME 23579 . 24995) (DPRIN1 24997 . 25082) (DIRFILENAME 25084 . 25513) (DIRGETFILEINFO 25515
. 25667) (DREAD 25669 . 25980)))))
(FILEMAP (NIL (1325 27144 (DODIR 1335 . 1882) (FILDIR 1884 . 2164) (DIRECTORY 2166 . 12883) (
DIRECTORY.PARSE 12885 . 14179) (DIRECTORY.FILL.PATTERN 14181 . 14711) (DIRCONJ 14713 . 14933) (
DIRECTORY.NEXTFILE 14935 . 15528) (DMATCH 15530 . 15905) (DIRECTORY.MATCH.SETUP 15907 . 16441) (
DIRECTORY.MATCH 16443 . 16860) (DIRECTORY.MATCH1 16862 . 18975) (DODIRCOMMANDS 18977 . 24447) (
DIRPRINTNAME 24449 . 25865) (DPRIN1 25867 . 25952) (DIRFILENAME 25954 . 26675) (DIRGETFILEINFO 26677
. 26829) (DREAD 26831 . 27142)))))
STOP

BIN
sources/DIRECTORY.LCOM
View File

Binary file not shown.