(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "27-Jul-90 07:53:18" |{DSK}local>lde>loops>src>SYSTEM>LOOPS-INSTALL.;2| 15503 |changes| |to:| (VARS LOOPS-INSTALLCOMS) |previous| |date:| " 1-Dec-88 12:14:30" |{DSK}local>lde>loops>src>SYSTEM>LOOPS-INSTALL.;1| ) ; Copyright (c) 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT LOOPS-INSTALLCOMS) (RPAQQ LOOPS-INSTALLCOMS ((FNS LOAD-SYSTEM LOAD-SYSTEM1 LS-FIX-DIRS LS-FLOPPY-PROMPT LS-GRAPHIC LS-INSTALL LS-LOAD LS-LOAD? LS-MAKE-FLOPPIES LS-PROMPT LS-PROMPT-DONE LS-SET-DIRS))) (DEFINEQ (load-system (lambda (desc) (* \; "Edited 6-Jul-88 15:22 by raf") (* |;;;| "Just calls LOAD-SYSTEM1 in a seperate process to avoid possibly screwing ourselves...") (or desc (setq desc ls-current-system)) (add.process `(progn (cl:format t "Current system is ~A~%" ',(cl:first desc)) (give.tty.process (\\insurewindow (ttydisplaystream))) (cl:unwind-protect (load-system1 ',desc) (closew (ttydisplaystream)))) 'name (concat "Installing " (cl:first ls-current-system)) 'beforeexit 'don\'t))) (load-system1 (lambda (desc) (* \; "Edited 13-Jul-88 16:39 by raf") (* |;;;| "DESC should be a list of four elements:") (* |;;| "NAME - a string that names the system") (* |;;| "DIRECTORIES - a list of atoms and default values which will be set to the directories/subdirectories where the system is going to live, like this: ") (* |;;|  "((LOOPSDIRECTORY {DSK}LOOPS>) (LOOPSLIBRARY {DSK}LOOPS>LIBRARY>)) ") (* |;;|  "INSTALL-LIST - a list of lists of descriptions of floppies, each of which looks like this:") (* |;;| "(\"Source Floppy 5\" (LOOPSDIRECTORY foo bar baz)(LOOPSLIBRARY mumble frotz))") (* |;;| "There is one list per (MACHINETYPE).") (* |;;| "LOAD-LIST - a list of things that can be loaded once stuff is installed, along with code to load them: ((LOOPS (FILESLOAD FROM LOOPSDIRECTORY foo bar baz))(MUMBLE (FILESLOAD FROM LOOPSLIBRARY mumble))") (* |;;| "Spelling correction is OFF here; DWIM once bit me by turning a COPYFILES into a COPYFILE in an expression that was trying to load COPYFILES...") (let* ((ls-current-system (or desc ls-current-system)) (ls-menu (|create| menu title _ (cl:format nil "~A System" (cl:first ls-current-system)) items _ `((,(|if| (eq (machinetype) 'maiko) |then| "Install from distribution" |else| "Install from floppies") 'install ,(|if| (eq (machinetype) 'maiko) |then| "Gets local directories and builds LOOPSSITE file" |else| "Gets local directories, copies from floppies and builds LOOPSSITE file" )) ("Load into sysout" 'load "Loads installed system into sysout")) menuposition _ (cons (iquotient screenheight 2) (iquotient screenwidth 2)))) (nospellflg t)) (declare (specvars ls-current-system nospellflg)) (|while| (selectq (menu ls-menu) (install (ls-set-dirs (cl:first ls-current-system) (cl:second ls-current-system) 'always) (ls-install (cl:third ls-current-system)) t) (load (ls-set-dirs (cl:first ls-current-system) (cl:second ls-current-system)) (ls-load (cl:fourth ls-current-system)) t) nil) |do| nil)))) (ls-fix-dirs (lambda (item window buttons) (* \; "Edited 21-Mar-88 16:28 by jrb:") (let (|something-changed|) (|for| d |in| (windowprop window 'dirlist) |bind| fmi fmval |do| (setq fmi (fm.getitem (car d) 'dirnames window)) (setq fmval (fm.itemprop fmi 'label)) (|if| (or (not (boundp (car d))) (not (equal fmval (fm.itemprop fmi 'initstate)))) |then| (set (car d) (mkatom fmval)) (setq |something-changed| t))) (|if| |something-changed| |then| (eval (windowprop window 'dirforms))) (notify.event (windowprop window 'donevent)) (closew window)))) (ls-floppy-prompt (lambda (name dont-check) (* \; "Edited 6-Apr-88 19:41 by BANE") (|while| t |bind| bogusname |do| (ls-prompt (concat "Please insert floppy " name)) (* |;;| "This is necessary to reliably detect a floppy swap on an 1186...GRRRR!") (\\floppy.close) (|if| (or dont-check (equal (setq bogusname (floppy.name)) name)) |then| (return) |else| (cl:format t "~%That was ~A!~%" bogusname) (ringbells))))) (LS-GRAPHIC (LAMBDA (ITEM WINDOW CHAR) (* \; "Edited 1-Dec-88 12:10 by bane") (* |;;| "The first AND clause catches the digits 0-9 which FreeMenu passes in as SMALLPs.") (OR (AND (SMALLP CHAR) (IGREATERP CHAR -1) (ILESSP CHAR 10)) (LET ((CHAROBJ (COERCE CHAR 'CL:CHARACTER))) (AND (CL:GRAPHIC-CHAR-P CHAROBJ) (NOT (EQ CHAROBJ #\Space))))))) (ls-install (lambda (insdesc) (* \; "Edited 6-Jul-88 16:09 by raf") (let ((inslist (car insdesc)) floppyrecs) (selectq (machinetype) ((dandelion dove) (setq floppyrecs (assoc (machinetype) inslist)) (|if| floppyrecs |then| (|for| floppyrec |in| (cdr floppyrecs) |do| (|if| (eq (car floppyrec) 'eval) |then| (eval (cadr floppyrec)) |else| (ls-floppy-prompt (car floppyrec)) (|for| dirrec |in| (cdr floppyrec) |do| (cl:format t "~&Connecting to ~A" (eval (car dirrec))) (cndir (eval (car dirrec))) (|for| fname |in| (cdr dirrec) |do| (cl:format t "~&Copying ~A" fname) (copyfile (cl:format nil "{FLOPPY}~A" fname) fname))) (cl:format t "~&Done with ~A" (car floppyrec)))) |else| (cl:break "Can't find distribution description for ~A" (machinetype)))) (dorado (cl:warn "DORADOes do not have floppy drives.")) (maiko (cl:warn "You should already have used TAR to unload the distribution tape.")) (cl:break "Unrecognized machine type ~s" (machinetype)))) (eval (cadr insdesc)))) (ls-load (lambda (loadlist) (* \; "Edited 4-Apr-88 20:31 by jrb:") (* |;;| "LOADLIST can be: ") (* |;;| "A list: it is treated as a list of load command lists and a menu lets the user select which one to load") (* |;;| "NIL: the load command list from LS-CURRENT-SYSTEM is used as above") (* |;;|  "Otherwise: it is treated as the option to select from the load command list from LS-CURRENT-SYSTEM") (or loadlist (setq loadlist (cl:fourth ls-current-system))) (let ((whichll (|for| lle |in| loadlist |bind| (selected _ (menu (|create| menu title _ "Load Which?" items _ (|for| i |in| loadlist |collect| (|if| (cl:symbolp (car i)) |then| (car i) |else| (list (caar i) (caar i) (cadar i)))) menuposition _ (cons (iquotient screenheight 2) (iquotient screenwidth 2))))) |when| (or (and (cl:symbolp (car lle)) (equal selected (car lle))) (and (cl:consp (car lle)) (equal selected (caar lle)))) |do| (return lle)))) (|for| form |in| (cdr whichll) |do| (eval form))))) (ls-load? (lambda (filename which-floppy) (* \; "Edited 30-Mar-88 14:40 by jrb:") (|if| (not (getprop filename 'filedates)) |then| (|if| (not (apply* 'filesload '(noerror) filename)) |then| (|while| (not (getprop filename 'filedates)) |do| (cl:format t "You need to load file ~A and I can't find it~%" filename) (ls-floppy-prompt which-floppy) (|if| (not (apply* 'filesload '(from {floppy}) filename)) |then| (cl:format t "~A wasn't on that floppy; check it and try again~%")))) (cl:format t "Loaded file ~A~%" filename)))) (ls-make-floppies (lambda nil (* \; "Edited 6-Apr-88 17:42 by BANE") (let ((install-list (car (cl:third ls-current-system)))) (ls-set-dirs (cl:first ls-current-system) (cl:second ls-current-system) 'always) (selectq (machinetype) ((dandelion dove) (|for| floppyrec |in| (cdr (assoc (machinetype) install-list)) |unless| (eq (car floppyrec) 'eval) |do| (ls-floppy-prompt (car floppyrec) t) (|for| dirrec |in| (cdr floppyrec) |do| (cl:format t "~&Connecting to ~A" (eval (car dirrec))) (cndir (eval (car dirrec))) (|for| fname |in| (cdr dirrec) |do| (cl:format t "~&Copying ~A" fname) (copyfile fname (cl:format nil "{FLOPPY}~A" fname)))) (cl:format t "~&Done with ~A" (car floppyrec)))) (cl:break "This machine has no floppies I know about; you're on your own..."))))) (ls-prompt (lambda (title-string) (* \; "Edited 1-Apr-88 20:44 by jrb:") (* |;;| "A persistent prompt that won't go away") (let ((fm (freemenu `(((label ,title-string hjustify center)) ((props id donebutton) (label "Click here when done" hjustify center selectedfn ls-prompt-done))) ))) (windowprop fm 'donebutton (create.event)) (movew fm (iquotient screenheight 2) (iquotient screenwidth 2)) (openw fm) (await.event (windowprop fm 'donebutton))))) (ls-prompt-done (lambda (item window buttons) (* \; "Edited 1-Apr-88 20:30 by jrb:") (notify.event (windowprop window 'donebutton)) (closew window))) (ls-set-dirs (lambda (name dirdesc always?) (* \; "Edited 4-Apr-88 20:08 by jrb:") (* |;;| "Don't make the window if all the directory variables are already bound - Do do it if ALWAYS? is true") (* |;;| "Structure of DIRDESC is:") (* |;;| "(((DIRATOM1 \"{directory}name1>\") ...) ") (* |;;| " (forms to run after getting DIRATOMs set))") (let ((dirlist (car dirdesc))) (or (and (not always?) (|for| d |in| dirlist |always| (boundp (car d)))) (let ((dirmenu (freemenu `((props format column) ((props id diratoms) (label ,(cl:format nil "~A directories" name) type display hjustify left) ,@(|for| d |in| dirlist |collect| `(label ,(car d) type display))) ((props id dirnames) (label "Click here when done" hjustify right selectedfn ls-fix-dirs) ,@(|for| d |in| dirlist |collect| `(label ,(or (and (boundp (car d)) (eval (car d))) (cadr d)) id ,(car d) type edit limitchars ls-graphic))))))) (windowprop dirmenu 'dirlist dirlist) (windowprop dirmenu 'dirforms (cadr dirdesc)) (windowprop dirmenu 'donevent (create.event)) (getmousestate) (movew dirmenu (iquotient screenheight 2) (iquotient screenwidth 2)) (openw dirmenu) (await.event (windowprop dirmenu 'donevent))))))) ) (PUTPROPS LOOPS-INSTALL COPYRIGHT ("Venue & Xerox Corporation" 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (623 15405 (LOAD-SYSTEM 633 . 1460) (LOAD-SYSTEM1 1462 . 4743) (LS-FIX-DIRS 4745 . 5597) (LS-FLOPPY-PROMPT 5599 . 6240) (LS-GRAPHIC 6242 . 6704) (LS-INSTALL 6706 . 8571) (LS-LOAD 8573 . 10603) (LS-LOAD? 10605 . 11390) (LS-MAKE-FLOPPIES 11392 . 12837) (LS-PROMPT 12839 . 13495) ( LS-PROMPT-DONE 13497 . 13699) (LS-SET-DIRS 13701 . 15403))))) STOP