(FILECREATED " 9-Jun-86 12:16:14" {ERIS}<LISPCORE>SOURCES>DFILE.;31 71487
changes to: (FNS SPELLFILE.SPELL SPELLFILE1 DIRECTORY.MATCH1 SPELLFILE.SPELL1)
(VARS DFILECOMS)
(MACROS .NULL.PATTERNP.)
previous date: "13-May-86 14:00:05" {ERIS}<LISPCORE>SOURCES>DFILE.;29)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved. The following
program was created in 1982 but has not been published within the meaning of the copyright law, is
furnished under license, and may not be used, copied and/or disclosed except in accordance with the
terms of said license.)
(PRETTYCOMPRINT DFILECOMS)
(RPAQQ DFILECOMS
((COMS (* "File name spelling correction")
(FNS FINDFILE SPELLFILE SPELLFILE.MATCHINGDIRS SPELLFILE.SPELL SPELLFILE.SPELL1
SPELLFILE1 SPELLFILEDIR)
(BLOCKS (NIL FINDFILE SPELLFILE SPELLFILE1 SPELLFILEDIR SPELLFILE.MATCHINGDIRS
SPELLFILE.SPELL (LOCALVARS . T)
(GLOBALVARS DWIMFLG NOSPELLFLG SPELLFILE USERNAME)))
(INITVARS (NOFILESPELLFLG T))
[DECLARE: DONTEVAL@LOAD DOCOPY (VARS (SPELLFILE (ARRAY 2)))
(ADDVARS (ERRORTYPELST (23 (SPELLFILE (CADR ERRORMESS)
NIL NOFILESPELLFLG]
(ADDVARS (DIRECTORIES)))
(COMS (* DIRECTORY)
(LISPXMACROS DIR NDIR)
(FNS DODIR FILDIR DIRECTORY DIRECTORY.PARSE DIRECTORY.FILL.PATTERN DIRCONJ
DIRECTORY.NEXTFILE CONCATCODES DMATCH DIRECTORY.MATCH.SETUP DIRECTORY.MATCH
DIRECTORY.MATCH1 DODIRCOMMANDS DIRPRINTNAME DPRIN1 DIRFILENAME DIRGETFILEINFO
DREAD)
(INITVARS (UPPERCASEFILENAMES T))
(VARS DIRCOMMANDS FILEINFOTYPES)
(DECLARE: DONTCOPY (RECORDS FILEGROUP)
(MACROS .NULL.PATTERNP. DTAB)
(GLOBALVARS UPPERCASEFILENAMES DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES)))
(COMS (* "Pretty version of COPYBYTES for terminal display")
(FNS PFCOPYBYTES DISPLAYP.D COMPUTEPRETTYPARMS FONTMAPARRAY)
(INITVARS (\FONTMAPCACHE))
(ALISTS (FONTDEFS STANDARD PARC))
(DECLARE: DONTEVAL@LOAD DOCOPY
(P (MOVD (QUOTE DISPLAYP.D)
(QUOTE DISPLAYP))
(FONTSET (QUOTE PARC))
(SETSEPR (QUOTE (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
24 25 26))
1 FILERDTBL)))
(DECLARE: DONTCOPY (MACROS PFPRINCHAR PFOUTCHAR PFTERPRI PFBIN)))
(LOCALVARS . T)))
(* "File name spelling correction")
(DEFINEQ
(FINDFILE
[LAMBDA (FILE NSFLG DIRLST) (* rmk: "27-JUL-82 20:51")
(* If file has an explicit directory on it and that file exists, don't fool
around with the directory packing in SPELLFILE, simply return.
When there is no explicit directory list, we do the INFILEP check first,
thereby giving priority to the connected directory.
This is really a non-feature because the order of priorities should be as
defined by the appearance of T in DIRECTORIES, but we adjust the priorities
here for backward compatibility. Should be removed when the coast is clear.)
(COND
((AND (FILENAMEFIELD FILE (QUOTE DIRECTORY))
(INFILEP FILE)))
(DIRLST (SPELLFILE FILE T NSFLG DIRLST))
((INFILEP FILE))
((SPELLFILE FILE T NSFLG DIRLST])
(SPELLFILE
[LAMBDA (FILE NOPRINTFLG NSFLG DIRLST) (* lmm " 5-May-85 00:35")
(DECLARE (SPECVARS NAME EXTENSION VERSION SPELLVAL DIRHOSTS HOST)
(GLOBALVARS \FILEDEVICENAMES))
(PROG (SPELLVAL VAL DIRHOSTS HOST DEVICE DIRECTORY NAME EXTENSION VERSION FILEDATES
(FIELDS (UNPACKFILENAME.STRING FILE))
(DIRS (OR DIRLST DIRECTORIES))
(APPFLG (QUOTE MUST-APPROVE))
(NSFLG (OR NSFLG NOSPELLFLG (NULL DWIMFLG)))
(ROOTNAME FILE))
(OR FILE (RETURN))
FLDLP
(COND
(FIELDS (SELECTQ (CAR FIELDS)
(NAME (SETQ NAME (CADR FIELDS)))
(VERSION (SETQ VERSION (CADR FIELDS)))
(EXTENSION (SETQ EXTENSION (CADR FIELDS)))
(DIRECTORY (SETQ DIRECTORY (CADR FIELDS)))
(HOST (SETQ HOST (CADR FIELDS)))
(DEVICE (* Pseudo-devices FOO: can be used to
denote a list of directories)
(OR [AND (NULL DEVICE)
(NULL DIRECTORY)
(SETQ DIRS (GETPROP (SETQ DEVICE (CADR FIELDS))
(QUOTE DIRECTORIES]
(RETURN)))
(RETURN))
(SETQ FIELDS (CDDR FIELDS))
(GO FLDLP)))
[AND HOST (COND
((HOSTNAMEP HOST))
([AND (NOT NSFLG)
(SETQ HOST (FIXSPELL HOST NIL \FILEDEVICENAMES (QUOTE NO-MESSAGE]
(AND (SETQ VAL (INFILEP (PACKFILENAME.STRING (QUOTE HOST)
HOST
(QUOTE BODY)
FILE)))
(GO RET)))
(T (* It is pointless to go on if we
don't have a valid host.)
(RETURN NIL]
[COND
((OR HOST DEVICE DIRECTORY VERSION)
(* ROOTNAME is what fixspell gets called on.
important that extra characters get stripped out so that spelling corrector
metric is applied to what is really being corrected, otherwise, e.g.
with directory supplied, any two short names will match)
(SETQ ROOTNAME (MKATOM (PACKFILENAME (QUOTE NAME)
NAME
(QUOTE EXTENSION)
EXTENSION]
[COND
([AND (NEQ ROOTNAME FILE)
(NULL DIRLST)
(SETQ FILEDATES (GETPROP ROOTNAME (QUOTE FILEDATES)))
(SETQ SPELLVAL (OR (INFILEP ROOTNAME)
(AND VERSION (OR DIRECTORY HOST)
(INFILEP (PACKFILENAME.STRING (QUOTE DIRECTORY)
DIRECTORY
(QUOTE HOST)
HOST
(QUOTE NAME)
NAME
(QUOTE EXTENSION)
EXTENSION]
(COND
([for X in FILEDATES thereis (AND (OR (EQ (CDR X)
SPELLVAL)
(EQ (CDR X)
FILE))
(STREQUAL (CAR X)
(FILEDATE SPELLVAL]
(* attacks problem where sombody wants a specific file, e.g.
makefile wants the source, the file is around, but with a different verson
number, e.g. was ftped from maxc, and user didnt loadfrom symbolic but instead
just started editing with compiled file having been loaded.
This is a rare case; users should LOADFROM! Also, since we don't know where
this fully-qualified name came from, we must ask for correction.)
(SETQ VAL SPELLVAL) (* works by looking to see if latest
verson of rootname in fact has same
filedate as requested file.)
(GO RET]
[COND
[DIRECTORY (COND
((DIRECTORYNAMEP DIRECTORY HOST) (* User supplied directory is valid)
(GO SPELLNAME)))
(* Try to spelling correct directory with hostname stripped off for spelling
metric. If HOST, then only consider directories on that host.
Otherwise, keep a list of the hosts associated with the host-free directories.)
(COND
([AND (NOT NSFLG)
(SETQ DIRS (SPELLFILE.MATCHINGDIRS DIRS HOST))
(SETQ VAL (FIXSPELL DIRECTORY NIL DIRS (QUOTE NO-MESSAGE)
NIL
(FUNCTION (LAMBDA (DIR)
(* Check file only for directories
that are close enough)
(AND (SETQ DIR (SPELLFILEDIR DIR))
(RETFROM (QUOTE FIXSPELL)
DIR]
(GO RET))
(T (RETURN]
(T (* Here if directory wasn't specified
in the filename. Search only
directories on DIRS which match HOST,
if specified.)
(for DIR in DIRS when [PROGN (SELECTQ DIR
((NIL T)
(SETQ DIR (DIRECTORYNAME DIR T)))
NIL)
(AND [OR (NULL HOST)
(STREQUAL HOST (LISTGET (UNPACKFILENAME.STRING
DIR)
(QUOTE HOST]
(SETQ VAL (INFILEP (PACKFILENAME.STRING
(QUOTE DIRECTORY)
DIR
(QUOTE NAME)
NAME
(QUOTE EXTENSION)
EXTENSION
(QUOTE VERSION)
VERSION]
do [SETQ APPFLG (COND
(NOPRINTFLG (QUOTE NO-MESSAGE))
(T (QUOTE NEEDNOTAPPROVE]
(GO RET]
(COND
([AND (NULL DIRLST)
[LISTP (SETQ VAL (GETPROP FILE (QUOTE FILEDATES]
(LITATOM (CDAR VAL))
(SETQ VAL (INFILEP (PACKFILENAME.STRING (QUOTE VERSION)
NIL
(QUOTE BODY)
(CDAR VAL]
[SETQ APPFLG (COND
(NOPRINTFLG (QUOTE NO-MESSAGE))
(T (QUOTE NEEDNOTAPPROVE]
(GO RET)))
SPELLNAME
(COND
([OR NSFLG (NOT (SETQ VAL (SPELLFILE.SPELL HOST DIRECTORY NAME EXTENSION VERSION
ROOTNAME FILE]
(RETURN))) (* SPELLFILE1 and hence FIXSPELL
return name without host/directory,
since matching against ROOTNAME;
hence, the packfilename below)
[COND
((NEQ FILE ROOTNAME)
(SETQ VAL (MKATOM (PACKFILENAME (QUOTE BODY)
VAL
(QUOTE HOST)
HOST
(QUOTE DIRECTORY)
DIRECTORY
(QUOTE VERSION)
VERSION]
RET (RETURN (AND (OR (EQ APPFLG (QUOTE NO-MESSAGE))
(FIXSPELL1 FILE VAL (EQ APPFLG (QUOTE MUST-APPROVE))
NIL APPFLG))
VAL])
(SPELLFILE.MATCHINGDIRS
[LAMBDA (DIRS HOST) (* bvm: "26-DEC-81 17:01")
(COND
[HOST (for DIR DHOST in DIRS
when (EQ HOST (LISTGET [SETQ DIR (OR (LISTP DIR)
(UNPACKFILENAME (SELECTQ DIR
((NIL T)
(DIRECTORYNAME DIR T))
DIR]
(QUOTE HOST))) collect (LISTGET DIR (QUOTE DIRECTORY]
(T (for DIR UDIR DHOST in DIRS
unless (PROG1 (MEMB (SETQ DIR (LISTGET [SETQ UDIR
(OR (LISTP DIR)
(UNPACKFILENAME (SELECTQ DIR
((NIL T)
(DIRECTORYNAME
DIR T))
DIR]
(QUOTE DIRECTORY)))
$$VAL)
(AND (SETQ DHOST (LISTGET UDIR (QUOTE HOST)))
(NCONC1 [OR (FASSOC DIR DIRHOSTS)
(CAR (push DIRHOSTS (CONS DIR]
DHOST))) collect DIR])
(SPELLFILE.SPELL
[LAMBDA (HOST DIRECTORY NAME EXTENSION VERSION ROOTNAME) (* bvm: " 9-Jun-86 12:15")
(* * "Try to spelling-correct ROOTNAME against existing files. HOST DIRECTORY NAME EXTENSION VERSION are the unpacked fields of the originally supplied file, while ROOTNAME is just the name/extension we are willing to fix up.
For efficiency, assume that either the name or the extension, but not both, is misspelled.")
(COND
([AND VERSION (NOT (AND (FIXP VERSION)
(IGREATERP VERSION 0] (* Can't deal with funny versions)
(SETQ VERSION NIL)))
(RESETLST (*
"RESETLST is for the \GENERATEFILES inside SPELLFILE.SPELL1")
(OR (COND
(EXTENSION (*
"If non-null extension, then try all extensions of files with this name.")
(SPELLFILE.SPELL1 HOST DIRECTORY NAME (QUOTE *)
VERSION ROOTNAME)))
(SPELLFILE.SPELL1 HOST DIRECTORY (QUOTE *)
EXTENSION VERSION ROOTNAME])
(SPELLFILE.SPELL1
[LAMBDA (HOST DIRECTORY NAME EXTENSION VERSION ROOTNAME) (* bvm: " 6-Jun-86 11:31")
(* * "Try to spelling-correct ROOTNAME against all the files matching the fields supplied.")
(DECLARE (SPECVARS VERSION)) (* Used by SPELLFILE1)
(SETA SPELLFILE 2 (\GENERATEFILES (PACKFILENAME.STRING (QUOTE HOST)
HOST
(QUOTE DIRECTORY)
DIRECTORY
(QUOTE NAME)
NAME
(QUOTE EXTENSION)
EXTENSION
(QUOTE VERSION)
(OR VERSION ""))
NIL
(QUOTE RESETLST))) (*
"If no version specified, enumerate only highest version")
(SETA SPELLFILE 1 (FUNCTION SPELLFILE1))
(FIXSPELL ROOTNAME NIL SPELLFILE (QUOTE NO-MESSAGE])
(SPELLFILE1
[LAMBDA (ARR) (* bvm: " 6-Jun-86 11:12")
(* * "Name generator for a FIXSPELL -- generates files for a given host/directory, but returns names with the host/directory stripped off for fixspell matching.")
(DECLARE (USEDFREE VERSION))
(PROG (FL NAME1 EXT1 VERS#1)
LP (COND
([NULL (SETQ FL (\GENERATENEXTFILE (ELT ARR 2)
(NULL VERSION]
(RETURN)))
(for FIELDS on (UNPACKFILENAME.STRING FL) by (CDDR FIELDS)
do (* Ignore host and directory, assuming
we only generate appropriate ones.)
(SELECTQ (CAR FIELDS)
(NAME (SETQ NAME1 (CADR FIELDS)))
(EXTENSION (SETQ EXT1 (CADR FIELDS)))
(VERSION (SETQ VERS#1 (CADR FIELDS)))
NIL))
[COND
([OR (NOT VERSION)
(AND VERS#1 (EQ VERSION (MKATOM VERS#1] (* Skip if versions mismatch, so
fixspell only works on names)
(RETURN (PACKFILENAME.STRING (QUOTE NAME)
NAME1
(QUOTE EXTENSION)
EXT1]
(SETQ NAME1 (SETQ EXT1 (SETQ VERS#1 NIL)))
(GO LP])
(SPELLFILEDIR
[LAMBDA (DIR) (* rmk: "13-NOV-81 22:13")
(* If HOST, returns fullname of file
on {HOST}DIR, otherwise searches the
hosts associated with DIR for the
first one with file.)
(DECLARE (USEDFREE HOST DIRHOSTS NAME EXTENSION VERSION))
(COND
(HOST (INFILEP (PACKFILENAME (QUOTE HOST)
HOST
(QUOTE DIRECTORY)
DIR
(QUOTE NAME)
NAME
(QUOTE EXTENSION)
EXTENSION
(QUOTE VERSION)
VERSION)))
(T (for H in (OR (CDR (FASSOC DIR DIRHOSTS))
(QUOTE (NIL))) when (SETQ H (INFILEP (PACKFILENAME (QUOTE HOST)
H
(QUOTE DIRECTORY)
DIR
(QUOTE NAME)
NAME
(QUOTE EXTENSION)
EXTENSION
(QUOTE VERSION)
VERSION)))
do (RETURN H])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL FINDFILE SPELLFILE SPELLFILE1 SPELLFILEDIR SPELLFILE.MATCHINGDIRS SPELLFILE.SPELL
(LOCALVARS . T)
(GLOBALVARS DWIMFLG NOSPELLFLG SPELLFILE USERNAME))
]
(RPAQ? NOFILESPELLFLG T)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ SPELLFILE (ARRAY 2))
(ADDTOVAR ERRORTYPELST (23 (SPELLFILE (CADR ERRORMESS)
NIL NOFILESPELLFLG)))
)
(ADDTOVAR DIRECTORIES )
(* DIRECTORY)
(ADDTOVAR LISPXMACROS (DIR (DODIR (NLAMBDA.ARGS LISPXLINE)))
(NDIR (DODIR (NLAMBDA.ARGS LISPXLINE)
(QUOTE (P COLUMNS 20))
(QUOTE *)
"")))
(DEFINEQ
(DODIR
[LAMBDA (LISPXLINE EXTRACOMS DEFAULTEXT DEFAULTVERS NOP) (* rmk: "29-OCT-81 17:01")
(PROG ((FILE (CAR LISPXLINE))
(TAIL (CDR LISPXLINE))
CONJ)
LP (COND
((SETQ CONJ (DIRCONJ (CAR TAIL))) (* The files can be strung out in the
line separated by conjunctions.)
(SETQ FILE (LIST FILE CONJ (CADR TAIL)))
(SETQ TAIL (CDDR TAIL))
(GO LP)))
(AND EXTRACOMS (SETQ TAIL (APPEND TAIL EXTRACOMS)))
(OR NOP (FMEMB (QUOTE P)
TAIL)
(FMEMB (QUOTE PP)
TAIL)
(SETQ TAIL (CONS (QUOTE P)
TAIL)))
(RETURN (DIRECTORY FILE TAIL DEFAULTEXT DEFAULTVERS])
(FILDIR
[LAMBDA (FILEGROUP) (* lmm " 4-OCT-83 03:27")
(DIRECTORY FILEGROUP])
(DIRECTORY
[LAMBDA (FILES COMMANDS DEFAULTEXT DEFAULTVERS)
(DECLARE (SPECVARS COMMANDS DEFAULTEXT DEFAULTVERS)) (* lmm " 9-May-86 17:21")
(PROG (VALUE COLUMNS NAMEFLG DELETEDONLY FILEGROUP PRINTFLG OUTFILE PROMPTFLG LASTHOST&DIR
DESIREDPROPS PFLG HEADINGS VALUES-WANTED)
(DECLARE (SPECVARS VALUE COLUMNS NAMEFLG FILEGROUP DESIREDPROPS LASTHOST&DIR))
(PROG ([COMTAIL (SETQ COMMANDS (if (LISTP COMMANDS)
then (APPEND COMMANDS)
else (SETQ COMMANDS (LIST (OR COMMANDS (QUOTE COLLECT]
COM TEM)
COMLP
(SELECTQ (SETQ COM (CAR COMTAIL))
((PAUSE P PP)
(SETQ PFLG (SETQ PRINTFLG COMTAIL)))
(OLDVERSIONS [OR (FIXP (CADR COMTAIL))
(RPLACD COMTAIL (CONS 1 (CDR COMTAIL]
(pop COMTAIL))
(BY (RPLACA (SETQ COMTAIL (CDR COMTAIL))
(MKSTRING (CAR COMTAIL)))
(push DESIREDPROPS (QUOTE AUTHOR)))
(COLLECT (SETQ VALUES-WANTED T))
(DELETE)
(COUNTSIZE (SETQ VALUE 0)
(push DESIREDPROPS (QUOTE SIZE)))
((PROMPT PRINT)
(SETQ COMTAIL (CDR COMTAIL))
[push HEADINGS (LIST NIL (NCHARS (CAR COMTAIL]
(if (EQ COM (QUOTE PROMPT))
then (SETQ PROMPTFLG T)
else (SETQ PRINTFLG T)))
(@ (SETQ COMTAIL (CDR COMTAIL))
(if (FNTYP (SETQ COM (CAR COMTAIL)))
then [RPLACA COMTAIL (CONS COM (QUOTE (FILENAME]
(SETQ NAMEFLG T)
elseif (FMEMB (QUOTE FILENAME)
(FREEVARS COM))
then (SETQ NAMEFLG T)))
(COLUMNS (SETQ COLUMNS (CADR COMTAIL))
(SETQ PRINTFLG T)
(RPLNODE COMTAIL (QUOTE NOP)
(CDDR COMTAIL)))
(OUT (SETQ OUTFILE (CADR COMTAIL))
(RPLNODE COMTAIL (QUOTE NOP)
(CDDR COMTAIL)))
((DELETED UNDELETE)
(ERROR "DELETED/UNDELETE directory commands are not supported")
(SETQ DELETEDONLY T))
((OLDERTHAN NEWERTHAN)
(push DESIREDPROPS (QUOTE ICREATIONDATE)
(QUOTE IWRITEDATE))
(if (EQ COM (QUOTE OLDERTHAN))
then (push DESIREDPROPS (QUOTE IREADDATE)))
(RPLACA (SETQ COMTAIL (CDR COMTAIL))
(if (NUMBERP (SETQ COM (CAR COMTAIL)))
then (* A number of days)
[IDIFFERENCE (IDATE)
(TIMES COM (DEFERREDCONSTANT (IDIFFERENCE
(IDATE "2-JAN-77 00:00"
)
(IDATE "1-JAN-77 00:00"
]
elseif (IDATE COM)
else (\ILLEGAL.ARG COM))))
(if (STRINGP COM)
then (RPLNODE COMTAIL (QUOTE PRINT)
(CONS (MKSTRING COM)
(CDR COMTAIL)))
(GO COMLP)
elseif (SETQ TEM (FASSOC COM FILEINFOTYPES))
then (push DESIREDPROPS COM)
(push HEADINGS (LIST COM (CADR TEM)))
(SETQ PRINTFLG T)
elseif (LISTP COM)
then (FRPLNODE2 COMTAIL (APPEND COM (CDR COMTAIL)))
(GO COMLP)
elseif (FIXSPELL COM NIL (NCONC (MAPCAR FILEINFOTYPES (FUNCTION CAR))
DIRCOMMANDS)
NIL COMTAIL NIL NIL T)
then (GO COMLP)
else (ERROR "invalid DIRECTORY command" COM)))
(AND (SETQ COMTAIL (CDR COMTAIL))
(GO COMLP)))
(SETQ FILEGROUP (create FILEGROUP
PATTERN ← (DIRECTORY.PARSE FILES)
FILEGENERATORS ← FILEGROUP))(* DIRECTORY.PARSE smashes generators
on FILEGROUP for each atomic file
specification it finds.)
(RESETLST
(if (OR PRINTFLG OUTFILE PROMPTFLG)
then
(if PROMPTFLG
then (RESETSAVE (SETTERMTABLE ASKUSERTTBL)))
(RESETSAVE (OUTPUT T))
[if OUTFILE
then (if (OPENP OUTFILE)
then (OUTPUT OUTFILE)
else (OUTFILE OUTFILE)
(RESETSAVE NIL (QUOTE (PROGN (CLOSEF? (OUTPUT]
[if (AND PFLG (NEQ (CAR PFLG)
(QUOTE PAUSE)))
then (* Postpone print commands until after
predicate commands)
(SETQ COMTAIL COMMANDS)
(bind SEENP PREVTAIL
do (SELECTQ (CAR COMTAIL)
((P PP)
(SETQ SEENP (OR PREVTAIL T)))
((BY COLUMNS @ OUT OLDERTHAN NEWERTHAN)
(pop COMTAIL))
(PROGN (if (AND SEENP (NEQ COMTAIL (CDR PFLG)))
then (* Move the P or PP to before COMTAIL)
(RPLACD PREVTAIL (CONS (CAR PFLG)
COMTAIL))
(if (NEQ SEENP T)
then (RPLACD SEENP (CDDR SEENP))
else (pop COMMANDS)))
(RETURN)))
(SETQ COMTAIL (CDR (SETQ PREVTAIL COMTAIL]
[if (AND HEADINGS (for X in HEADINGS thereis (CAR X)))
then (TERPRI)
(for X in (REVERSE HEADINGS) bind (I ← 22)
do (TAB I)
(if (CAR X)
then (PRIN1 (CAR X)))
(add I (CADR X]
(SETQ PRINTFLG T)
(TAB 0 0))
(while (DIRECTORY.NEXTFILE FILEGROUP) do (DODIRCOMMANDS COMMANDS FILEGROUP))
(if PRINTFLG
then (TAB 0 0)))
(RETURN (OR VALUE (COND
((NOT VALUES-WANTED)
(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])
(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])
(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])
(DIRECTORY.NEXTFILE
[LAMBDA (FG) (* bvm: " 8-Jul-85 19:32")
(PROG (TEM)
LP (COND
((SETQ TEM (\GENERATENEXTFILE (CAR (fetch FILEGENERATORS of FG))
NIL))
[COND
((LISTP TEM) (* Old style enumerator returns
charlist)
(SETQ TEM (CONCATCODES TEM]
[COND
((STRINGP TEM)
(replace STRINGNAME of FG with TEM)
(replace LITERALNAME of FG with NIL))
(T (replace LITERALNAME of FG with (AND (LITATOM TEM)
(U-CASEP TEM)
TEM))
(replace STRINGNAME of FG with (SETQ TEM (MKSTRING TEM]
(RETURN FG))
((replace FILEGENERATORS of FG with (CDR (fetch FILEGENERATORS of FG)))
(GO LP))
(T (RETURN])
(CONCATCODES
[LAMBDA (CHARCODES) (* bvm: " 6-May-84 21:56")
(PROG [(STR (ALLOCSTRING (LENGTH CHARCODES]
(for X in CHARCODES as I from 1 do (RPLCHARCODE STR I X))
(RETURN STR])
(DMATCH
[LAMBDA (PAT TESTNAME) (* bvm: " 4-May-84 13:16")
(COND
((OR (EQ PAT T)
(NULL PAT))
T)
(T (SELECTQ (CAR PAT)
(OR (OR (DMATCH (CADR PAT)
TESTNAME)
(DMATCH (CDDR PAT)
TESTNAME)))
(AND (AND (DMATCH (CADR PAT)
TESTNAME)
(DMATCH (CDDR PAT)
TESTNAME)))
(ANDNOT (AND (NOT (DMATCH (CDDR PAT)
TESTNAME))
(DMATCH (CADR PAT)
TESTNAME)))
(DIRECTORY.MATCH PAT TESTNAME])
(DIRECTORY.MATCH.SETUP
[LAMBDA (FILENAME) (* bvm: " 6-May-86 14:35")
(SELCHARQ (CAR (SETQ FILENAME (CHCON FILENAME)))
({ (do (* Throw out hostname/device part,
because the canonical name might be
different from the one in the pattern)
(SELCHARQ (pop FILENAME)
(} (RETURN))
NIL)))
NIL)
[for TAIL on FILENAME bind (BASE ← (UPPERCASEARRAY))
do (* Coerce to uppercase)
(RPLACA TAIL (SELCHARQ (CAR TAIL)
(ESCAPE (CHARCODE *))
(COND
((LEQ (CAR TAIL)
\MAXTHINCHAR)
(GETCASEARRAY BASE (CAR TAIL)))
(T (CAR TAIL]
FILENAME])
(DIRECTORY.MATCH
[LAMBDA (PATTERN TESTNAME) (* bvm: " 4-May-84 13:01")
(PROG ((FIRSTCHAR 1))
(SELCHARQ (NTHCHARCODE TESTNAME 1)
(({ %[)
(do (* Throw out hostname/device part,
because the canonical name might be
different from the one in the pattern)
(SELCHARQ (NTHCHARCODE TESTNAME (add FIRSTCHAR 1))
((} %])
(RETURN (add FIRSTCHAR 1)))
NIL)))
NIL)
(RETURN (DIRECTORY.MATCH1 PATTERN TESTNAME FIRSTCHAR])
(DIRECTORY.MATCH1
[LAMBDA (PATTERN TESTNAME FIRSTCHAR) (* bvm: " 6-Jun-86 12:24")
(PROG ([CASEBASE (ffetch (ARRAYP BASE) of (\DTEST UPPERCASEARRAY (QUOTE ARRAYP]
(NAMELIMIT (NCHARS TESTNAME))
PATCHAR TESTCHAR)
LP (COND
((IGREATERP FIRSTCHAR NAMELIMIT) (* Run out of name, so rest of pattern
better be "null")
(RETURN (.NULL.PATTERNP. PATTERN)))
[(NULL PATTERN)
(* Name left, but no pattern. This is always a mismatch unless last matched
pattern character was ";" in which case what follows is the version.
Have to hope that the device generated only the newest version)
(RETURN (EQ PATCHAR (CHARCODE ;]
(T (COND
[(EQ (SETQ PATCHAR (CAR PATTERN))
(CHARCODE *)) (* Matches any number of characters.
Thus, see if we have a match ANYWHERE
on remainder of TESTNAME)
(RETURN (OR (.NULL.PATTERNP. (SETQ PATTERN (CDR PATTERN)))
(do (COND
((DIRECTORY.MATCH1 PATTERN TESTNAME FIRSTCHAR)
(RETURN T)))
(add FIRSTCHAR 1) repeatuntil (IGREATERP FIRSTCHAR NAMELIMIT]
((OR (EQ PATCHAR (COND
((LEQ (SETQ TESTCHAR (NTHCHARCODE TESTNAME FIRSTCHAR))
\MAXTHINCHAR)
(\GETBASEBYTE CASEBASE TESTCHAR))
(T TESTCHAR)))
(SELCHARQ PATCHAR
(# (* Matches anything)
T)
(; (* Would match except for different
delimiter)
(EQ TESTCHAR (CHARCODE !)))
NIL))
(pop PATTERN)
(add FIRSTCHAR 1)
(GO LP))
(T (RETURN NIL])
(DODIRCOMMANDS
[LAMBDA (COMMANDS FILEGROUP) (* bvm: " 8-Jul-85 19:04")
(PROG ((COMTAIL COMMANDS)
(I 0)
(FILENAME (fetch LITERALNAME of FILEGROUP))
COM FILE NAMEPRINTED ATTRVALUE)
(DECLARE (SPECVARS FILENAME FILE NAMEPRINTED I)
(USEDFREE VALUE))
(COND
([AND COLUMNS (NOT (ILESSP (SETQ I (ITIMES (IQUOTIENT (IPLUS (POSITION)
COLUMNS -1)
COLUMNS)
COLUMNS))
(IDIFFERENCE (LINELENGTH)
30]
(SETQ I 0)))
(while COMTAIL
do (SELECTQ (SETQ COM (pop COMTAIL))
(P (DIRPRINTNAME FILEGROUP))
(PP (DIRPRINTNAME FILEGROUP T))
(COUNTSIZE (add VALUE (DIRGETFILEINFO FILEGROUP (QUOTE 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 (QUOTE OLDERTHAN))
(OR (AND (SETQ DT (DIRGETFILEINFO FILEGROUP (QUOTE
ICREATIONDATE
)))
(IGEQ DT COMDATE))
(AND (SETQ DT (DIRGETFILEINFO FILEGROUP (QUOTE
IWRITEDATE
)))
(IGEQ DT COMDATE]
(AND (EQ COM (QUOTE OLDERTHAN))
(AND (SETQ DT (DIRGETFILEINFO FILEGROUP (QUOTE 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 (QUOTE 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)
(if (NEQ (CAR COMTAIL)
1)
then (ERROR "can't count more than 1 version"))
(if (EQ (INFILEP (DIRFILENAME FILEGROUP))
(INFILEP (PACKFILENAME (QUOTE VERSION)
NIL
(QUOTE BODY)
FILENAME)))
then (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
((FIXP ATTRVALUE)
(PRINTNUM (OR (CDDR TYPE)
(LIST (QUOTE 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)) (* lmm "16-Nov-84 16:07")
(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)
(OR (NULL (SETQ LASTCHAR (NTHCHARCODE LASTNAME I)))
(NEQ (GETCASEARRAY UPPERCASEARRAY LASTCHAR)
(GETCASEARRAY UPPERCASEARRAY THISCHAR]
(SETQ DIFFERENT I]
[COND
((AND DIFFERENT DIRECTORYEND (OR (NEQ DIRECTORYEND (CADR LASTHOST&DIR))
(ILEQ DIFFERENT DIRECTORYEND)))
(* New directory)
(TAB 0 0)
(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])
(DPRIN1
[LAMBDA (STR) (* lmm "20-OCT-78 02:53")
(DTAB (NCHARS STR))
(PRIN1 STR])
(DIRFILENAME
[LAMBDA (FILEGROUP) (* bvm: "29-Jun-84 12:08")
(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 (PROG ((NAME (fetch STRINGNAME of FILEGROUP)))
(RETURN (COND
((AND UPPERCASEFILENAMES
(NOT (U-CASEP NAME)))
(U-CASE NAME))
(T NAME])
(DIRGETFILEINFO
[LAMBDA (FILEGROUP ATTRIBUTE) (* bvm: " 5-May-84 15:19")
(\GENERATEFILEINFO (CAR (fetch FILEGENERATORS of FILEGROUP))
ATTRIBUTE])
(DREAD
[LAMBDA (PROMPT) (* lmm "21-OCT-78 01:28")
(PROG1 [PROG NIL
LP (PROGN (TAB I 0)
(PRIN1 PROMPT))
(SELECTQ (READC T)
((Y y)
(PRIN1 (QUOTE "Yes")
T)
(RETURN T))
((N n)
(PRIN1 (QUOTE "No")
T)
(RETURN))
(? (PRIN1 (QUOTE "Y or N: ")
T)
(GO LP))
(PROGN (PRIN1 "" T)
(GO LP]
(add I (NCHARS PROMPT)
5])
)
(RPAQ? UPPERCASEFILENAMES T)
(RPAQQ DIRCOMMANDS ((- . PAUSE)
(AU . AUTHOR)
BY COLLECT (COLLECT? PROMPT " ? " COLLECT)
COUNTSIZE
(DA . CREATIONDATE)
(DATE . CREATIONDATE)
(DEL . DELETE)
(DEL? . DELETE?)
DELETE
(DELETE? PROMPT " delete? " DELETE)
DELETED
(LE LENGTH "(" BYTESIZE ")")
NEWERTHAN OLDVERSIONS (OLD OLDERTHAN 90)
OLDERTHAN
(OU . OUT)
OUT P PAUSE (PR . PROTECTION)
PROMPT
(SI . SIZE)
(TI . WRITEDATE)
UNDELETE
(VERBOSE AUTHOR CREATIONDATE SIZE READDATE WRITEDATE)
TRIMTO
(DELVER OLDVERSIONS DELETE)))
(RPAQQ FILEINFOTYPES ((WRITEDATE 22)
(READDATE 22)
(CREATIONDATE 22)
(LENGTH 9)
(BYTESIZE 2)
(PROTECTION 6 FIX 6 8)
(SIZE 5)
(AUTHOR 11)
(TYPE 7)
(FILETYPE 6 FIX 6 8)))
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD FILEGROUP (STRINGNAME LITERALNAME PATTERN . FILEGENERATORS))
]
(DECLARE: EVAL@COMPILE
[PUTPROPS .NULL.PATTERNP. MACRO (LAMBDA (PATTERN)
(* True if PATTERN is the null pattern, which basically means
it is a tail of "*.*;*")
(OR (NULL PATTERN)
(NULL (SELCHARQ (CAR PATTERN)
(%. (SELCHARQ (CAR (SETQ PATTERN (CDR PATTERN
)))
((*)
(SETQ PATTERN (CDR PATTERN)))
PATTERN))
((*)
(SETQ PATTERN (CDR PATTERN)))
PATTERN))
(AND (EQ (CAR PATTERN)
(CHARCODE ;))
(OR (NULL (SETQ PATTERN (CDR PATTERN)))
(AND (EQ (CAR PATTERN)
(CHARCODE *))
(NULL (CDR PATTERN]
(PUTPROPS DTAB DMACRO ((N)
(TAB (PROG1 I (add I N 1))
0)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS UPPERCASEFILENAMES DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES)
)
)
(* "Pretty version of COPYBYTES for terminal display")
(DEFINEQ
(PFCOPYBYTES
[LAMBDA (SRCFIL DSTFIL START END FLG) (* AJB "26-Sep-85 18:11")
(* Copy bytes from SRCFIL to DSTFIL a la COPYBYTES, but with the following
differences: -
(a) CHANGECHAR lines are eliminated -
(b) comments are printed a la **COMMENT**FLG -
(c) spaces at the beginning of the line are reduced by 1/2 unless FLG is set
(-
This works for both D and Tenex EOL conventions, assuming that the start and
end positions are in terms of true bytes on the file))
(DECLARE (GLOBALVARS CHANGECHAR COMMENTFLG **COMMENT**FLG))
(RESETLST (PROG ((SSTRM (\INSTREAMARG SRCFIL))
(DSTRM (\OUTSTREAMARG DSTFIL))
(#SPACES 0)
(CHANGECHARCODE (AND CHANGECHAR (CHCON1 CHANGECHAR)))
(COMMENTCHARCODE (AND COMMENTFLG (CHCON1 COMMENTFLG)))
(HPOS 0)
EOLC LMAR RMAR FONTARRAY CHARCODE EOLFLG STRFLG #CHARS MAXFONT)
(DECLARE (SPECVARS . T))
(COND
((IMAGESTREAMP DSTRM)
(SETQ FONTARRAY (FONTMAPARRAY NIL (QUOTE DISPLAY)))
(SETQ MAXFONT (ARRAYSIZE FONTARRAY))
(RESETSAVE NIL (LIST (FUNCTION DSPFONT)
(DSPFONT NIL DSTRM)
DSTRM))
(SETQ HPOS (DSPXPOSITION NIL DSTRM))
(SETQ LMAR (DSPLEFTMARGIN NIL DSTRM))
(SETQ RMAR (DSPRIGHTMARGIN NIL DSTRM))
(DSPFONT (ELT FONTARRAY 1)
DSTRM))
((NOT (\OUTTERMP DSTRM))
(ERROR "PFCOPYBYTES FOR TERMINAL ONLY")))
(SETQ EOLC (fetch EOLCONVENTION of SSTRM))
(SETQ #CHARS (COND
(END (SETFILEPTR SSTRM START)
(* Doesn't call \SETFILEPTR cause
START has to be checked)
(IDIFFERENCE (COND
((EQ END -1)
(\GETEOFPTR SSTRM))
(T END))
START))
(START (FIX START))
(T (* Stop on end of file)
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM FN)
(replace ENDOFSTREAMOP
of STREAM with FN]
SSTRM
(fetch ENDOFSTREAMOP of SSTRM)))
(replace ENDOFSTREAMOP of SSTRM with (FUNCTION NILL))
MAX.SMALL.INTEGER)))
(COND
((AND START (ILEQ #CHARS 0))
(RETURN T)))
LP [COND
((ILEQ #CHARS 0)
(COND
(START (RETURN T))
(T (* Just keep the counter going until
EOF)
(SETQ #CHARS MAX.SMALL.INTEGER]
(SETQ CHAR (PFBIN))
INTERP
[SELCHARQ CHAR
(SPACE (add #SPACES 1)
(GO LP))
((EOL CR)
(COND
((OR FLG (NULL **COMMENT**FLG))
(* Be literal, don't shrink)
(PFTERPRI))
(T (SETQ EOLFLG T) (* postpone printing c.r.s to handle
blank lines such as occur before
comments printed n middle of page)
(SETQ #SPACES 0)))
(GO LP))
(%% (PFPRINCHAR CHAR)
(SELCHARQ (SETQ CHAR (PFBIN))
((EOL CR)
(PFTERPRI))
(PFOUTCHAR CHAR))
(GO LP))
(%" (SETQ STRFLG (NULL STRFLG)))
(TAB (add #SPACES 8)
(GO LP))
(NIL (AND EOLFLG (TERPRI DSTRM)) (* This is the EOF when we are copying
the whole file)
(RETURN T))
(COND
((AND (EQ CHAR CHANGECHARCODE)
(NULL STRFLG)
(EQ (\CHECKEOLC (\PEEKBIN SSTRM)
EOLC SSTRM T)
(CHARCODE EOL))) (* Ignore changechar only when
followed by EOL; otherwise, it may be
the important BQUOTE character.)
(GO LP))
((ILEQ CHAR (CHARCODE ↑Z))
[COND
((AND FONTARRAY (EQ CHAR (CHARCODE ↑F)))
(COND
((AND (IGEQ MAXFONT (SETQ CHAR (PFBIN)))
(NEQ CHAR 0))
(DSPFONT (ELT FONTARRAY CHAR)
DSTRM]
(GO LP))
((AND (EQ CHAR (CHARCODE %())
**COMMENT**FLG
(NULL STRFLG))
(COND
((AND (EQ (SETQ CHAR (PFBIN))
COMMENTCHARCODE)
(EQ (\PEEKBIN SSTRM)
(CHARCODE SPACE)))
(SETQ #SPACES 0)
(SETQ EOLFLG NIL)
[add #CHARS (IDIFFERENCE (\GETFILEPTR SSTRM)
(PROGN (SKREAD SSTRM "(*")
(\GETFILEPTR SSTRM]
(* The difference between the file pointer at beginning of comment and that
after SKREAD is number of characters in the comment.
However, the file pointer is actually after the *, but the %( has already been
counted. Hence, effectively back up first filepointer by one, compute
difference and subtract from #chars)
(PRIN1 **COMMENT**FLG DSTRM)
(GO LP))
(T (PFPRINCHAR (CHARCODE %())(* We already read the next character,
so just interpret it)
(GO INTERP]
(PFPRINCHAR CHAR)
(GO LP])
(DISPLAYP.D
[LAMBDA (STREAM) (* AJB "23-Sep-85 14:53")
(LET ((STRM (\OUTSTREAMARG STREAM T)))
(AND STRM (OR (DISPLAYSTREAMP STRM)
(IMAGESTREAMTYPEP STRM (QUOTE TEXT])
(COMPUTEPRETTYPARMS
[LAMBDA (FILE)
(DECLARE (GLOBALVARS COMMENTFONT FIRSTCOL COMMENTLINELENGTH))
(* bvm: "31-MAR-82 17:10")
(PROG ((LEN (LINELENGTH NIL FILE)))
(SETQ FIRSTCOL (FIX (FTIMES LEN .6)))
(COND
(FONTCHANGEFLG (OR FILEFLG (RESETSAVE NIL (LIST (QUOTE DSPFONT)
[DSPFONT NIL (OR FILE (SETQ FILE (
OUTPUTDSP
]
FILE)))
(COND
((LISTP COMMENTFONT)
(SETQ COMMENTLINELENGTH (CONS (FIX (FTIMES LEN 1.15))
(FIX (FTIMES LEN 1.22])
(FONTMAPARRAY
[LAMBDA (FONTCLASSES IMAGETYPES) (* rmk: "14-Sep-84 13:43")
(* Makes a font array from a font-mapping list of fontclasses.
The array provides a fast map from prettyfont# to font classes/descriptors -
This function caches the last array. If IMAGETYPES is given, then the FD's are
pre-computed for the imagetypes it. Otherwise, the first use of the fontclass
for that imagetype would cause the fontcreate to be done.)
(DECLARE (GLOBALVARS \FONTMAPCACHE))
(PROG (FA (MAXFONT 0)
(MINFONT 100))
[COND
((NULL \FONTMAPCACHE))
((OR (NULL FONTCLASSES)
(EQUAL FONTCLASSES (CAR \FONTMAPCACHE)))
[if (AND IMAGETYPES (CDR \FONTMAPCACHE))
then (for I (FA ← (CDR \FONTMAPCACHE)) from 1 to (ARRAYSIZE (CDR \FONTMAPCACHE))
do (for D inside IMAGETYPES do (FONTCREATE (ELT FA I)
NIL NIL NIL D]
(RETURN (CDR \FONTMAPCACHE]
[for F PRETTYFONT# in FONTCLASSES do (SETQ PRETTYFONT# (fetch (FONTCLASS PRETTYFONT#)
of F))
(COND
((IGREATERP PRETTYFONT# MAXFONT)
(SETQ MAXFONT PRETTYFONT#)))
(COND
((ILESSP PRETTYFONT# 1)
(ERROR "Invalid font number" PRETTYFONT# F))
((ILESSP PRETTYFONT# MINFONT)
(SETQ MINFONT PRETTYFONT#]
(SETQ FA (ARRAY MAXFONT))
(for F in FONTCLASSES do (SETA FA (fetch (FONTCLASS PRETTYFONT#) of F)
F)
(for D inside IMAGETYPES
do (FONTCREATE F NIL NIL NIL D)))
(for I from 1 to MAXFONT unless (ELT FA I) do (SETA FA I (ELT FA MINFONT)))
(RPLACD (RPLACA (OR \FONTMAPCACHE (SETQ \FONTMAPCACHE (CONS)))
(COPY FONTCLASSES))
FA)
(RETURN FA])
)
(RPAQ? \FONTMAPCACHE )
(ADDTOVAR FONTDEFS (STANDARD (FONTCHANGEFLG)
(FILELINELENGTH . 72)
(COMMENTLINELENGTH . 72)
(LAMBDAFONTLINELENGTH . 72)
(FIRSTCOL . 48)
(PRETTYLCOM . 14)
(LISTFILESTR . "
")
(FONTPROFILE (DEFAULTFONT)
(USERFONT)
(COMMENTFONT)
(LAMBDAFONT)
(SYSTEMFONT)
(CLISPFONT)
(CHANGEFONT)
(PRETTYCOMFONT)
(BIGFONT)
(LITTLEFONT)
(BOLDFONT)))
[PARC (FONTCHANGEFLG . ALL)
(FILELINELENGTH . 102)
(COMMENTLINELENGTH 116 . 126)
(LAMBDAFONTLINELENGTH . 95)
(FIRSTCOL . 60)
(PRETTYLCOM . 25)
(FONTPROFILE (DEFAULTFONT 1 (GACHA 10)
(GACHA 8)
(TERMINAL 8))
(BOLDFONT 2 (HELVETICA 10 BRR)
(HELVETICA 8 BRR)
(MODERN 8 BRR))
(LITTLEFONT 3 (HELVETICA 8)
(HELVETICA 6 MIR)
(MODERN 8 MIR))
(BIGFONT 4 (HELVETICA 12 BRR)
(HELVETICA 10 BRR)
(MODERN 10 BRR))
(USERFONT BOLDFONT)
(COMMENTFONT LITTLEFONT)
(LAMBDAFONT BIGFONT)
(SYSTEMFONT)
(CLISPFONT BOLDFONT)
(CHANGEFONT)
(PRETTYCOMFONT BOLDFONT)
(FONT1 DEFAULTFONT)
(FONT2 BOLDFONT)
(FONT3 LITTLEFONT)
(FONT4 BIGFONT)
(FONT5 5 (HELVETICA 10 BIR)
(HELVETICA 8 BIR)
(MODERN 8 BIR))
(FONT6 6 (HELVETICA 10 BRR)
(HELVETICA 8 BRR)
(MODERN 8 BRR))
(FONT7 7 (GACHA 12)
(GACHA 12)
(TERMINAL 12])
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (QUOTE DISPLAYP.D)
(QUOTE DISPLAYP))
(FONTSET (QUOTE PARC))
(SETSEPR (QUOTE (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26))
1 FILERDTBL)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS PFPRINCHAR MACRO ((CC)
(COND (EOLFLG (TERPRI DSTRM)
(SETQ EOLFLG NIL)
(SETQ HPOS LMAR)))
(COND ((NOT (ZEROP #SPACES))
(FRPTQ (COND ((OR FLG STRFLG)
#SPACES)
(T (FOLDHI #SPACES 2)))
(PFOUTCHAR (CHARCODE SPACE)))
(SETQ #SPACES 0)))
(PFOUTCHAR CC)))
[PUTPROPS PFOUTCHAR MACRO ((CC)
([LAMBDA (WIDTH)
(COND ((AND WIDTH (IGREATERP (add HPOS WIDTH)
RMAR))
(* past RIGHT margin, force eol)
(TERPRI DSTRM)
(SETQ HPOS WIDTH)))
(\OUTCHAR DSTRM CC]
(\STREAMCHARWIDTH CC DSTRM \PRIMTERMTABLE]
[PUTPROPS PFTERPRI MACRO (NIL (PROGN (TERPRI DSTRM)
(SETQ HPOS LMAR)
(SETQ EOLFLG NIL)
(SETQ #SPACES 0]
(PUTPROPS PFBIN MACRO (NIL (\CHECKEOLC (\INCHAR SSTRM #CHARS)
EOLC SSTRM NIL #CHARS)))
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS DFILE COPYRIGHT ("Xerox Corporation" T 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2881 21713 (FINDFILE 2891 . 3818) (SPELLFILE 3820 . 14079) (SPELLFILE.MATCHINGDIRS
14081 . 15785) (SPELLFILE.SPELL 15787 . 17058) (SPELLFILE.SPELL1 17060 . 18288) (SPELLFILE1 18290 .
19824) (SPELLFILEDIR 19826 . 21711)) (22474 51502 (DODIR 22484 . 23349) (FILDIR 23351 . 23488) (
DIRECTORY 23490 . 31578) (DIRECTORY.PARSE 31580 . 32986) (DIRECTORY.FILL.PATTERN 32988 . 33535) (
DIRCONJ 33537 . 34020) (DIRECTORY.NEXTFILE 34022 . 35211) (CONCATCODES 35213 . 35485) (DMATCH 35487 .
36290) (DIRECTORY.MATCH.SETUP 36292 . 37416) (DIRECTORY.MATCH 37418 . 38248) (DIRECTORY.MATCH1 38250
. 40777) (DODIRCOMMANDS 40779 . 46945) (DIRPRINTNAME 46947 . 49409) (DPRIN1 49411 . 49558) (
DIRFILENAME 49560 . 50499) (DIRGETFILEINFO 50501 . 50712) (DREAD 50714 . 51500)) (54723 66638 (
PFCOPYBYTES 54733 . 62822) (DISPLAYP.D 62824 . 63082) (COMPUTEPRETTYPARMS 63084 . 64061) (FONTMAPARRAY
64063 . 66636)))))
STOP