(FILECREATED " 6-Feb-85 14:19:31" {ERIS}<LISPCORE>SOURCES>DFILE.;16 49199
changes to: (FNS DIRECTORY.FILL.PATTERN)
previous date: "12-Jan-85 22:40:09" {ERIS}<LISPCORE>SOURCES>DFILE.;15)
(* Copyright (c) 1982, 1983, 1984, 1985 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 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)
(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)
(LISPXMACROS DIR NDIR)
(INITVARS (UPPERCASEFILENAMES T))
(GLOBALRESOURCES \FILDIRSCRATCH)
(VARS DIRCOMMANDS FILEINFOTYPES)
(DECLARE: DONTCOPY (RECORDS FILEGROUP)
(MACROS .NULL.PATTERNP. DTAB)
(GLOBALVARS UPPERCASEFILENAMES DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES)))
(COMS (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)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* 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 " 7-Sep-84 12:25")
(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)
(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 [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 FILE)
(* bvm: "26-DEC-81 17:07")
[SETA SPELLFILE 2 (SELECTQ (SYSTEMTYPE)
[(D ALTO)
(\GENERATEFILES (COND
((NEQ FILE ROOTNAME)
(PACKFILENAME (QUOTE HOST)
HOST
(QUOTE DIRECTORY)
DIRECTORY
(QUOTE NAME)
(QUOTE *)))
(T (QUOTE *]
(PROGN (SETA SPELLFILE 5 (COND
(EXTENSION 150994945)
(T 134217729)))
(LOGAND [SETA SPELLFILE 3 (OR (COND
(EXTENSION
(* extension misspelled)
(LGTJFN
DIRECTORY NAME
(QUOTE *)
VERSION 32833)))
(PROGN
(* name misspelled)
(LGTJFN DIRECTORY
(QUOTE *)
EXTENSION VERSION
32833))
(PROGN
(* Can't have both name and extension misspelled)
(RETURN NIL]
262143]
(SETA SPELLFILE 1 (FUNCTION SPELLFILE1))
(FIXSPELL ROOTNAME NIL SPELLFILE (QUOTE NO-MESSAGE])
(SPELLFILE1
[LAMBDA (ARR) (* bvm: " 6-May-84 21:57")
(* This generates files for a given host/directory, but
returns names with the host/directory stripped off for
fixspell matching.)
(DECLARE (USEDFREE EXTENSION VERSION))
(GLOBALRESOURCE (\FILDIRSCRATCH)
(PROG (FL FIELDS NAME1 EXT1 VERS#1)
LP (COND
((NULL (SETQ FL (\GENERATENEXTFILE (ELT ARR 2)
(NULL VERSION)
\FILDIRSCRATCH)))
(RETURN)))
[COND
((LISTP FL)
(SETQ FL (CONCATCODES FL]
(SETQ FIELDS (UNPACKFILENAME FL))
FIELDLP
(COND
(FIELDS (* 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)
(SETQ FIELDS (CDDR FIELDS))
(GO FIELDLP)))
(AND VERSION (NUMBERP VERSION)
(IGREATERP VERSION 0)
(NEQ VERSION VERS#1)
(GO RETRY)) (* Skip if versions mismatch, so fixspell only works on
names)
(OR (EQ (NULL EXTENSION)
(NULL EXT1))
(GO RETRY))
(RETURN (PACKFILENAME (QUOTE NAME)
NAME1
(QUOTE EXTENSION)
EXT1))
RETRY
(SETQ NAME1 NIL)
(SETQ EXT1 NIL)
(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)
(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 "16-Nov-84 16:30")
(RESETLST (PROG (VALUE COLUMNS NAMEFLG DELETEDONLY FILEGROUP PRINTFLG OUTFILE PROMPTFLG
LASTHOST&DIR DESIREDPROPS PFLG HEADINGS)
(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 (ERROR
"OLDVERSIONS directory command not yet implemented")
[OR (FIXP (CADR COMTAIL))
(RPLACD COMTAIL (CONS 1 (CDR COMTAIL]
(pop COMTAIL))
(TRIMTO (ERROR "TRIMTO directory command not yet implemented")
(SETQ PRINTFLG T)
[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)))
((DELETE COLLECT))
(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.)
(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))
(WITH-RESOURCE \FILDIRSCRATCH (while (DIRECTORY.NEXTFILE FILEGROUP \FILDIRSCRATCH)
do (DODIRCOMMANDS COMMANDS FILEGROUP)))
(if PRINTFLG
then (TAB 0 0))
(RETURN VALUE])
(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 SCRATCH) (* lmm " 5-Oct-84 18:13")
(PROG (TEM)
LP (COND
((SETQ TEM (\GENERATENEXTFILE (CAR (fetch FILEGENERATORS of FG))
NIL SCRATCH))
[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) (* lmm " 5-Oct-84 18:33")
(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 *))
(? (CHARCODE #))
(GETCASEARRAY BASE (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: "14-May-84 15:19")
(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 (\GETBASEBYTE CASEBASE (SETQ TESTCHAR (NTHCHARCODE TESTNAME
FIRSTCHAR]
(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: "14-May-84 17:43")
(PROG ((COMTAIL COMMANDS)
(I 0)
(FILENAME (fetch LITERALNAME of FILEGROUP))
COM FILE NAMEPRINTED TEM ATTRVALUE OLDERP DATE)
(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)
(SETQ OLDERP (EQ COM (QUOTE OLDERTHAN)))
(SETQ DATE (pop COMTAIL))
(COND
([OR [COND
(TEM (* Read recently?)
(AND (SETQ TEM (DIRGETFILEINFO FILEGROUP (QUOTE IREADDATE)))
(IGEQ TEM DATE]
(EQ OLDERP (PROGN (* Written recently? ICREATIONDATE is a required prop,
so no null check)
(OR (IGEQ (DIRGETFILEINFO FILEGROUP (QUOTE
ICREATIONDATE))
DATE)
(AND (SETQ TEM (DIRGETFILEINFO FILEGROUP
(QUOTE
IWRITEDATE)))
(IGEQ TEM DATE]
(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]
((TRIMTO OLDVERSIONS) (* Not implemented, but user might continue from error
in DIRECTORY)
(pop COMTAIL))
((DELETED UNDELETE) (* Not implemented)
)
(NOP)
(COND
[(SETQ TEM (FASSOC COM FILEINFOTYPES))
(DTAB (CADR TEM))
(COND
((SETQ ATTRVALUE (DIRGETFILEINFO FILEGROUP COM))
(COND
((FIXP ATTRVALUE)
(PRINTNUM (OR (CDDR TEM)
(LIST (QUOTE FIX)
(CADR TEM)))
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])
)
(ADDTOVAR LISPXMACROS (DIR (DODIR (NLAMBDA.ARGS LISPXLINE)))
(NDIR (DODIR (NLAMBDA.ARGS LISPXLINE)
(QUOTE (P COLUMNS 20))
(QUOTE *)
"")))
(ADDTOVAR LISPXCOMS DIR NDIR)
(RPAQ? UPPERCASEFILENAMES T)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \FILDIRSCRATCH)
(QUOTE RESOURCES)
(QUOTE (NEW (CONS]
)
)
(/SETTOPVAL (QUOTE \\FILDIRSCRATCH.GLOBALRESOURCE))
(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
(OBS . OLDVERSIONS)
OLDVERSIONS
(OLD OLDERTHAN 90)
OLDERTHAN
(OU . OUT)
OUT P PAUSE (PR . PROTECTION)
PROMPT
(SI . SIZE)
(TI . WRITEDATE)
UNDELETE
(VERBOSE AUTHOR CREATIONDATE SIZE READDATE WRITEDATE)
(KEEP . TRIMTO)))
(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)
(AND (SELCHARQ (CAR PATTERN)
[%. (AND (EQ (CAR (SETQ PATTERN (CDR PATTERN)))
(CHARCODE *))
(SETQ PATTERN (CDR PATTERN]
( (*)
(SETQ PATTERN (CDR PATTERN)))
T)
(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)
)
)
(DEFINEQ
(PFCOPYBYTES
[LAMBDA (SRCFIL DSTFIL START END FLG) (* rmk: " 7-Apr-84 14:44")
(* 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 (SPECVARS . T)
(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)
(COND
((DISPLAYSTREAMP DSTRM)
(SETQ FONTARRAY (FONTMAPARRAY NIL (QUOTE DISPLAY)))
(SETQ MAXFONT (ARRAYSIZE FONTARRAY))
(RESETSAVE NIL (LIST (QUOTE 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) (* rmk: "31-AUG-83 16:12")
(DISPLAYSTREAMP (\OUTSTREAMARG STREAM T])
(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 . 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 6 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]
[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 (\BIN SSTRM)
EOLC SSTRM NIL #CHARS)))
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS DFILE COPYRIGHT ("Xerox Corporation" T 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2367 14204 (FINDFILE 2377 . 3221) (SPELLFILE 3223 . 9339) (SPELLFILE.MATCHINGDIRS 9341
. 10254) (SPELLFILE.SPELL 10256 . 11581) (SPELLFILE1 11583 . 13260) (SPELLFILEDIR 13262 . 14202)) (
14659 35328 (DODIR 14669 . 15464) (FILDIR 15466 . 15599) (DIRECTORY 15601 . 22062) (DIRECTORY.PARSE
22064 . 23059) (DIRECTORY.FILL.PATTERN 23061 . 23586) (DIRCONJ 23588 . 23984) (DIRECTORY.NEXTFILE
23986 . 24911) (CONCATCODES 24913 . 25181) (DMATCH 25183 . 25729) (DIRECTORY.MATCH.SETUP 25731 . 26552
) (DIRECTORY.MATCH 26554 . 27145) (DIRECTORY.MATCH1 27147 . 28775) (DODIRCOMMANDS 28777 . 32075) (
DIRPRINTNAME 32077 . 33901) (DPRIN1 33903 . 34050) (DIRFILENAME 34052 . 34647) (DIRGETFILEINFO 34649
. 34854) (DREAD 34856 . 35326)) (37702 45364 (PFCOPYBYTES 37712 . 42605) (DISPLAYP.D 42607 . 42760) (
COMPUTEPRETTYPARMS 42762 . 43359) (FONTMAPARRAY 43361 . 45362)))))
STOP