(FILECREATED " 9-Jun-86 11:45:06" {QV}<ARI>NOTECARDS>FILE-GROUPS.;11 6885
changes to: (FNS COPY-GROUP)
(FILEVARS FILE-GROUPSCOMS)
previous date: " 2-Jun-86 14:49:42" {QV}<ARI>NOTECARDS>FILE-GROUPS.;10)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FILE-GROUPSCOMS)
(RPAQQ FILE-GROUPSCOMS ((FNS)
(FNS INITIALIZE-FILE-GROUPS FILE-GROUP-MODULES FILE-GROUP-ORDERING
GET-FILE-GROUP SET-FILE-GROUP EXPAND-FILE-GROUP CHECK-FILES-EXIST
CHECK-FILE-GROUP COPY-GROUP LOAD-GROUP LOGICAL-FILE MERGE-FILE-NAMES)
(MACROS DEFINE-FILE-GROUP UNDEFINE-FILE-GROUP)
(RECORDS FILE-GROUP)))
(DEFINEQ
(INITIALIZE-FILE-GROUPS
(LAMBDA NIL (* SCB: "30-Jan-86 12:45")
(RECORD FILE-GROUP (MODULES ORDERING))))
(FILE-GROUP-MODULES
(LAMBDA (FILE-GROUP) (* SCB: "30-Jan-86 12:46")
(fetch (FILE-GROUP MODULES)
of FILE-GROUP)))
(FILE-GROUP-ORDERING
(LAMBDA (FILE-GROUP) (* SCB: "30-Jan-86 12:46")
(fetch (FILE-GROUP ORDERING)
of FILE-GROUP)))
(GET-FILE-GROUP
(LAMBDA (GROUP-NAME) (* SCB: "30-Jan-86 15:09")
(GETPROP GROUP-NAME (QUOTE FILE-GROUP))))
(SET-FILE-GROUP
(LAMBDA (GROUP-NAME GROUP) (* SCB: "30-Jan-86 15:09")
(PUTPROP GROUP-NAME (QUOTE FILE-GROUP)
GROUP)))
(EXPAND-FILE-GROUP
(LAMBDA (GROUP-NAME DONT-EXPAND-GROUPS) (* SCB: " 6-Mar-86 11:15")
(LET* ((FILE-GROUP (GET-FILE-GROUP GROUP-NAME))
(MODULES (FILE-GROUP-MODULES FILE-GROUP))
(ORDERING (FILE-GROUP-ORDERING FILE-GROUP))
(EXPANDED-FILE-NAMES NIL))
(SETQ DONT-EXPAND-GROUPS (MKLIST DONT-EXPAND-GROUPS))
(if (NOT (FMEMB GROUP-NAME DONT-EXPAND-GROUPS))
then
(for MODULE in ORDERING bind REAL-NAME MODULE-DEF do (SETQ MODULE-DEF
(CADR (ASSOC MODULE MODULES)))
(if (NULL MODULE-DEF)
then
(ERROR "No definition for module " MODULE))
(COND
((EQ (QUOTE LOGICAL-FILE)
(CAR MODULE-DEF))
(SETQ REAL-NAME (EVAL MODULE-DEF)))
((AND (EQ (QUOTE FILE-GROUP)
(CAR MODULE-DEF))
(GET-FILE-GROUP (CADR MODULE-DEF)))
(SETQ REAL-NAME (EXPAND-FILE-GROUP (CADR MODULE-DEF)
DONT-EXPAND-GROUPS)))
((ERROR "Unknown module specification " MODULE-DEF)))
(SETQ EXPANDED-FILE-NAMES (NCONC EXPANDED-FILE-NAMES (LDIFFERENCE
(MKLIST REAL-NAME)
EXPANDED-FILE-NAMES)))))
EXPANDED-FILE-NAMES)))
(CHECK-FILES-EXIST
[LAMBDA (FILES) (* DSJ: " 5-Mar-86 17:04")
[for FILE in FILES do (if (NULL (DIRECTORY FILE))
then (* ERROR FILE "does not exist")
(PRINT (CONCAT "Will search for " FILE]
T])
(CHECK-FILE-GROUP
(LAMBDA (GROUP-NAME) (* SCB: "30-Jan-86 15:47")
(OR (GET-FILE-GROUP GROUP-NAME)
(ERROR GROUP-NAME " is not an existing file group."))))
(COPY-GROUP
(LAMBDA (GROUP-NAME DESTINATION DONT-COPY-GROUPS) (* SCB: " 9-Jun-86 11:43")
(CHECK-FILE-GROUP GROUP-NAME)
(LET ((FILES (EXPAND-FILE-GROUP GROUP-NAME DONT-COPY-GROUPS)))
(* Check to see if the files exist before doing the
copy, we don't waste a lot of time copying an
incomplete system.)
(CHECK-FILES-EXIST FILES)
(for FILE in FILES bind DESTINATION-FILE do (SETQ DESTINATION-FILE (MERGE-FILE-NAMES
DESTINATION FILE))
(PRINTOUT T "Copying from " FILE " to " DESTINATION-FILE)
(COPYFILE FILE DESTINATION-FILE)
(PRIN1 " ... done")
(TERPRI))
(TERPRI))))
(LOAD-GROUP
[LAMBDA (GROUP-NAME DONT-LOAD-GROUPS RELOAD-P TRY-DCOM-FIRST-P)
(* DSJ: "19-Mar-86 14:47")
(CHECK-FILE-GROUP GROUP-NAME)
(LET ((FILES (EXPAND-FILE-GROUP GROUP-NAME DONT-LOAD-GROUPS)))
(* Check to see if the files exist before doing the
load, so we don't die in some inconsistent state.)
(CHECK-FILES-EXIST FILES)
(for FILE in FILES
do [if TRY-DCOM-FIRST-P
then (LET ((FILE1 (PACKFILENAME (QUOTE EXTENSION)
(QUOTE DCOM)
(QUOTE BODY)
FILE)))
(if (DIRECTORY FILE1)
then (SETQ FILE FILE1]
(if (NULL RELOAD-P)
then (LOAD? FILE)
else (LOAD FILE])
(LOGICAL-FILE
(LAMBDA (DIRECTORY-PATH NAME) (* SCB: " 2-Jun-86 14:22")
(* DIRECTORY-PATH is either a HOST/DIR spec or a list
of such specs.)
(LET ((DIRS (MKLIST DIRECTORY-PATH)))
(SPELLFILE NAME T T DIRS))))
(MERGE-FILE-NAMES
(LAMBDA (DIRECTORY-PATH NAME) (* SCB: " 9-Jun-86 11:40")
(* MERGES DIRECTORY-PATH AND FILE NAME.
DIRECTORY-PATH OVERRIDES, NAME HAS THE DEFAULT
FIELDS.)
(LET ((PATH-HOST (FILENAMEFIELD DIRECTORY-PATH (QUOTE HOST)))
(PATH-DIR (FILENAMEFIELD DIRECTORY-PATH (QUOTE DIRECTORY))))
(COND
((NULL PATH-HOST)
(ERROR "DIRECTORY-PATH must specify a host" DIRECTORY-PATH)))
(PACKFILENAME (QUOTE HOST)
PATH-HOST
(QUOTE DIRECTORY)
PATH-DIR
(QUOTE BODY)
NAME))))
)
(DECLARE: EVAL@COMPILE
(DEFMACRO DEFINE-FILE-GROUP (NAME . BODY)
(BQUOTE (LET ((MODULES (CDR (ASSOC (QUOTE MODULES)
(QUOTE (\, BODY)))))
(ORDERING (CADR (ASSOC (QUOTE ORDERING)
(QUOTE (\, BODY))))))
(IF (NULL MODULES)
THEN
(ERROR "NO MODULES"))
(IF (NULL ORDERING)
THEN
(ERROR "NO ORDERING"))
(SET-FILE-GROUP (QUOTE (\, NAME))
(CREATE FILE-GROUP MODULES ← MODULES ORDERING ← ORDERING))
(QUOTE DONE))))
(DEFMACRO UNDEFINE-FILE-GROUP (NAME)
(BQUOTE (SET-FILE-GROUP (QUOTE (\, NAME))
NIL)))
)
[DECLARE: EVAL@COMPILE
(RECORD FILE-GROUP (MODULES ORDERING))
]
(PUTPROPS FILE-GROUPS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (678 6134 (INITIALIZE-FILE-GROUPS 688 . 856) (FILE-GROUP-MODULES 858 . 1026) (
FILE-GROUP-ORDERING 1028 . 1198) (GET-FILE-GROUP 1200 . 1365) (SET-FILE-GROUP 1367 . 1546) (
EXPAND-FILE-GROUP 1548 . 2849) (CHECK-FILES-EXIST 2851 . 3178) (CHECK-FILE-GROUP 3180 . 3400) (
COPY-GROUP 3402 . 4185) (LOAD-GROUP 4187 . 5078) (LOGICAL-FILE 5080 . 5429) (MERGE-FILE-NAMES 5431 .
6132)))))
STOP