;;; -*- Mode:LISP; Package:TAPE; Base:10; Readtable:COMMON-LISP -*- ;;; All files contained in this directory are copyright ;;; (c) GigaMos Systems, Inc. 1988 ;;; All Rights Reserved ;;; Inquiries concerning copyright release or licensing should be directed ;;; to GigaMos Legal Affairs at the following address: ;;; GigaMos Systems, Inc. ;;; 650 Suffolk St. ;;; Lowell, Massachusetts 01854 ;;; Phone: (617) 458-9100 ;;; This file is executed when the user invokes: ;;; (tape:install-distribution-tape) ;;; (tape:distribution-installation-forms (send terminal-io :send-if-handles :clear-window) (format t "~&~ ******************************************************~%~ ** THIS IS THE SOFTWARE OPTIONS DISTRIBUTION TAPE **~%~ ** FOR GIGAMOS SYSTEMS LAMBDA SOFTWARE RELEASE 4.0 **~%~ ** All files contained in this tape are copyright **~%~ ** \(c\) GigaMos Systems, Inc. 1988 **~%~ ** All Rights Reserved **~%~ ** Inquiries concerning copyright release or **~%~ ** licensing should be directed to GigaMos Legal **~%~ ** Affairs at the following address: **~%~ ** GigaMos Systems, Inc. **~%~ ** 650 Suffolk St. **~%~ ** Lowell, Massachusetts 01854 **~%~ ** Phone: \(617\) 458-9100 **~%~ ******************************************************~%") (cond ((not (y-or-n-p "~&Is 4.0 OPTIONS the product you wanted to install?")) ;; make sure the user is installing the product he thought he ;; was going to install. (format t "~&~ *****************************~%~ ** INSTALLATION ABORTING **~%~ *****************************~%") (tape:rewind)) ((or (not (>= 125 (si:get-system-version)))) (beep) (format t "~&~ ******************************************************~%~ ** ERROR: **~%~ ** This machine is running an incorrect **~%~ ** Lambda system version for installing this tape. **~%~ ** INSTALLATION ABORTING **~%~ ******************************************************~%") (beep) (tape:rewind)) ('else ;;Do the installation (send-if-handles terminal-io :set-more-p t) ; (send-if-handles terminal-io :set-font-map '(cptfont cptfontb)) (block install-script (tagbody start-install-options (let((options '((CUSTOMER-SITE () () "Sample customer site file directory" "Restore the CUSTOMER-SITE directory if... 1] you haven't previously installed your Lambda(s), or 2] you haven't performed custom network configuration [\"site files\"] before, or 3] you plan to load some of the software options (listed with ***). \ This directory contains example site files; they can also be used as the default site files if you have systems named LAMBDA-A, LAMBDA-B, etc.") ((HACKS DEMO) (MAKE-SYSTEM :HACKS :NO-RELOAD-SYSTEM-DECLARATION) () "Miscellaneous demo programs" "Restore the DEMO directory if... you want to review programs that illustrate programming techniques. [NOTE: These programs are for demonstration purposes only, and no warranty or support is implied or expressed.]") (EXAMPLES () () "Example programs" "Restore the EXAMPLES directory if... you want to review programs that illustrate Lambda programming techniques. [NOTE: These programs are for demonstration purposes only, and no warranty or support is implied or expressed.]") (FONTS () () "Window system font directory" "Restore the FONTS directory if... you want to make all the window system display fonts available. [NOTE: Some fonts are not pre-loaded in the LISP world, and must be retrieved from the SYS HOST before they can be used.]") ((FONT-EDITOR WINDOW FONT-EDITOR) (make-system :font-editor :noconfirm) T "FONT-EDITOR system" "Restore FONT-EDITOR if... you want to develop your own fonts. [You should probably select FONTS also.]") (GATEWAY (MAKE-SYSTEM :GATEWAY :NOCONFIRM) T "On-Line Documentation Manager" "Restore and load ODM [***] if... 1] you want to develop your own on-line manual, or 2] to access the on-line LISP Machine Manual.") ((KERMIT NETWORK KERMIT) (MAKE-SYSTEM :KERMIT :NOCONFIRM) T "Kermit File Transfer and Login system" "Restore and load the KERMIT [***] if... you use Kermit to communicate between your Lambda system and other types of computers.") ((MEDIUM-RESOLUTION-COLOR VIDEO-DEVICE) (MAKE-SYSTEM :MEDIUM-RESOLUTION-COLOR :NOCONFIRM) T "Medium-Res Color system" "Restore and load the MEDIUM-RESOLUTION-COLOR system [***] if... your Lambda system includes the Medium-Resolution color graphics monitor.") ((MICROCODE UBIN) () () "Microcode directory" "Restore the UBIN directory if you want to... save a file-system copy of the 4.0 microcode. [NOTE: the microcode file can be used to restore a microcode partition; refer to the function SI:LOAD-LMC-FILE.]") (OBJECTLISP (MAKE-SYSTEM :OBJECTLISP :NOCONFIRM) T "ObjectLISP object-oriented programming language" "Restore and load the OBJECTLISP system [***] if... you want to develop programs using the ObjectLISP language.") ((SITE-EDITOR NETWORK EDIT) (MAKE-SYSTEM :SITE-EDITOR :NOCONFIRM) T "Site Data Editor" "Restore and load the SITE-EDITOR system [***] if... you want to use the on-line site file (network configuration) utility.") ((TIGER HARDCOPY) (MAKE-SYSTEM :TIGER :NOCONFIRM) T "Tiger printer software" "Restore and load TIGER if... you use Tiger hardcopy software with printers physically attached to your Lambda(s).") ((WINDOW-MAKER WINDOW WINDOW-MAKER) (MAKE-SYSTEM 'WINDOW-MAKER :NOCONFIRM) T "Window program generator" "Restore and load the WINDOW-MAKER system [***] if... you want to run the Window-Maker, which is a utility for generating full-screen window-handling code. [Also requires FONTS.]") (ZWEI (MAKE-SYSTEM :ISPELL :NOCONFIRM :NO-RELOAD-SYSTEM-DECLARATION) () "Zwei miscellany [SPELL-CHECK and TEACH-ZMACS]" "Restore miscellaneous Zwei files if... 1] you want the spelling checker [restore dictionary and load ISPELL] 2] you want to run TEACH-ZMACS, the ZMacs tutorial [Meta-X Teach ZMacs]."))) ;;;Options that are not systems but are normally referred to by ;;;the SYS logical really to be restored to the ;;;top-level RELEASE-4; directory on the system host (options-that-must-be-in-release-4 '(fonts microcode zwei)) ;;; ;;;Other local vars ;;; ;;;;;Parameters you can modify to change this program: (??tape-is-sorted?? t) ;Are files on tape definitely in pathname order? ; -If NIL, program has to search entire tape; ; -If T, program knows when it can stop restoring (??debug?? nil) ;Verbose mode for debugging ;;;;;Vars whose values we set but user may change (under certain conditions): (*host* (send (fs:get-pathname-host "SYS") :host)) (load-requires-restore-p t) ;Do files need to be restored? ;;;;;Installation state vars (selected nil) ;Option/choice alist from menu (selected-something-p nil) ;Did user actually select anything? (aborted nil) ;Did user abort from menu? (commands-to-eval nil) ;Generated commands to be EVAL'd (systems-to-copy nil) ;System def files to copy into SYS:SITE; skip-sample-systems-copy ;If non-NIL, don't ask, don't bother to copy *.SYSTEM (directories-to-restore nil);Directories to be restored (directories-pending nil) ;Directories not [already or in process of being] restored ;;;;;Status/control vars (normal-completion nil) ;Flag - did we terminate normally? (phase 0) ;Sequential phase of installation we're in (catch-last-directory ;Throw tag - escape when done with tape 'catch-last-directory) ) ;;;Local functions (labels((optname(option) (if (atom (first option)) (first option) (first(first option)))) (optdir(option) (cons 'RELEASE-4 (if (atom (first option)) (ncons(first option)) (rest(first option))))) (optdo(option) (second option)) (optsystem(option) (third option)) (opttext(option) (fourth option)) (optwhen(option) (fifth option)) (abort-install(&optional fmt &rest args) (beep) (warn "Aborting installation~@[~% [~a]~]" (if fmt (apply #'format nil fmt args))) (return-from install-script)) (wait-for-proceed() (fquery '(:type :tyi :clear-input t :choices :any :list-choices nil) "~2%Type any character to proceed:") (format t "Ok~&")) (read-carefully() (format t "~2%Please read the above text") (dotimes(i 5) (format t ".") (sleep 1 "Read carefully"))) (ask-y-or-n (fmt &rest args) (clear-input) (apply #'y-or-n-p fmt args)) (debugf(fmt &rest args) (if ??debug?? (apply #'format t fmt args))) (boldly(fmt &rest args &aux fatstring) (setq fatstring (zl:make-array 20. :type 'art-fat-string :fill-pointer 0.)) (apply #'format fatstring fmt args) (dotimes (i (string-length fatstring)) (setf (char-font (char fatstring i)) 1)) fatstring) (clear-screen () (send-if-handles *standard-output* :clear-window)) (phasen(fmt &rest args) (unless (zerop phase) (wait-for-proceed)) (incf phase) (clear-screen) (format t "~%**** Phase ~d: ~a **** ~2%" phase (apply #'boldly fmt args))) (phaseskip() (format t "~&[Skipping phase ~d]" phase)) (directory-under-p (got want) (cond ((null want) t) ((null got) nil) ((string-equal (car got)(car want)) (directory-under-p (cdr got) (cdr want))))) (directory-check (got wanted-p) ;;This is how we know to stop restoring a sorted tape: (when (and ??tape-is-sorted?? wanted-p) (debugf "~%Got ~s, removing from ~s " got directories-pending) (setq directories-pending (remove got directories-pending :test #'directory-under-p)) (debugf "...leaves ~s" directories-pending)) wanted-p) (directory-wanted-p (got want) (debugf "~&Got=~s wanted=~s" got want) ;;System directories have important stuff, like SYSDCL; always restore (or (member (second got) '("SYS" "SYS2" "IO" "IO1") :test #'string-equal) (directory-check got (directory-under-p got want)))) ) ;Labeled functions ;;; ;;;Begin ;;; (phasen "Introduce software options available on this distribution tape") (format t "~% There are multiple software options included in this distribution. You will be presented with a menu; you can choose which options, if any, to restore and/or load. \ The available options are:~2%") (mapcar #'(lambda(option) (format t "~& ~35a - ~a" (optname option) (opttext option))) options) (when (ask-y-or-n "~2%Do you want more information on the options?") (mapcar #'(lambda(option) (format t "~2%~a: ~a" (optname option) (opttext option)) (format t "~%~a~&" (optwhen option))) options)) (phasen "Installation parameters") ;;; ;;;What is the sys host? ;;; (format t "~% Distributed software files must be restored to the SYS HOST. On a multi-host Lambda network, the SYS HOST is one particular Lambda host that acts as a central location for system and site files.") (format t "~2%Your SYS HOST is the physical host named `~a'." *host*) (setq *host* (do((host *host*) (times 0) (dontparse t)) ((and (not dontparse) (si:parse-host host t)) (prog1 (setq host (si:parse-host host)) (format t "~%OK - restore option files to ~a" host))) (cond ((eq host :abort) (abort-install "cannot determine SYS HOST")) ((> times 5) (if (ask-y-or-n "Do you want to abort the installation?") (setq host :abort) (setq times 0))) ((null host) (setq host (or (prompt-and-read :string-or-nil "~&Enter a different host name, ~ or just press or to abort the installation: ") :abort)) (setq dontparse t)) ((null (si:parse-host host t)) (beep) (format t "~%But `~a' is not the name of a known host." host) (setq host nil) (incf times)) ((ask-y-or-n "Is `~a' the host you want to restore option files to?" (si:parse-host host)) (setq dontparse nil)) (t (setq host nil))))) ;;; ;;;Can user load without restoring? ;;; (format t "~2% In the normal course of selecting software options, you choose whether to restore the files; for some options, you can also load the software. \ RESTORE == [copy from tape to disk] LOAD == [load files into LISP as executable code] \ Of course you must restore the files for each software option before you can load the software into LISP. \ If this is your first pass through this installation procedure, you must choose to restore files for any option you select. \ But if you have previously restored all the options files you need, and if you are performing this installation only to LOAD options, you need not be restricted. \ In other words, at the next prompt, answer: \ `NO' if this is not your first installation, and you do not need to restore files for each software option you will select. \ 'YES' if this is your first installation, and you have not restored optional files, or if you are loading a new set of options, or if you are not certain.") (read-carefully) (setq load-requires-restore-p (yes-or-no-p "Do you need to restore software option files?")) (if load-requires-restore-p (format t "~%OK - must restore files to load options.") (format t "~%OK - can load software options without restoring files.")) ;; ;;Present options menu ;; (phasen "Select software options") (format t "~% Now make your selections with the following menu. Use the mouse to click the boxes under the columns to indicate whether you want the option restored and/or loaded.") (read-carefully) (tagbody start-choose-options (multiple-value-setq(selected aborted) (tv:multiple-choose "4.0 Software Options" (loop for option in options as name = (optname option) collect (list name (format nil "~:(~a~)" name) (if (optdo option) '(restore load) '(restore)))) `((restore "Restore files" nil nil nil ,load-requires-restore-p) (load "Load into world" ,load-requires-restore-p nil nil nil)))) (loop for choice in selected ;;Set flag - something to do?? (setq selected-something-p (or selected-something-p (or (cdr choice))))) ;;;Got item/choices alist `selected' (unless (cond (aborted (format t "~%You aborted out of the choice menu... ")) ((or (null selected) (null selected-something-p)) (format t "~%You didn't select any options... ")) (t t)) (beep) (cond ((ask-y-or-n "Do you want to see the menu again?") (go start-choose-options)) ((ask-y-or-n "Do you want to restart the installation?") (go start-install-options)) (t (abort-install "user exited menu"))))) ;;If they want MEDIUM-RES, they need HACKS (let((medium-res (cdr(assoc 'medium-resolution-color selected))) (hacks (assoc 'hacks selected))) (when medium-res (setq hacks (or hacks (car(push (ncons 'hacks) selected)))) (unless (cdr hacks) (format t "~% **Note: you selected Medium-Resolution-Color, which requires the HACKS [`DEMO'] system.")) (if (or load-requires-restore-p (ask-y-or-n "Select HACKS also?")) (rplacd (last hacks) (copy-list medium-res))))) ;;If they want WINDOW-MAKER, they need FONTS (let((window-maker (cdr(assoc 'window-maker selected))) (fonts (assoc 'fonts selected))) (when window-maker (setq fonts (or fonts (car (push (ncons 'fonts) selected)))) (unless (cdr fonts) (format t "~% **Note: you selected Window-Maker, which requires some of the files in FONTS.")) (if (or load-requires-restore-p (ask-y-or-n "Select FONTS also?")) (rplacd (last fonts) (copy-list '(restore)))))) ;;If they want any systems to MAKE-SYSTEM, they need CUSTOMER-SITE (let((systems (count-if #'(lambda(choice &aux option) (and (cdr choice) (setq option (find (car choice) options :key #'optname)) (optsystem option))) selected)) (sitefiles (assoc 'customer-site selected))) (when (plusp systems) (setq sitefiles (or sitefiles (car (push (ncons 'customer-site) selected)))) (unless (cdr sitefiles) (format t "~% **Note: you selected some system~P requiring a system definition file. The definition files are included in the sample site file directory 'CUSTOMER-SITE;'." systems) (when (or (ask-y-or-n "Do you want to restore the CUSTOMER-SITE files from tape?") (not (if (ask-y-or-n "Are the required system definition files already located in your SYS:SITE; directory??") (setq skip-sample-systems-copy t)))) (format t "~%Ok - we will restore CUSTOMER-SITE.") (rplacd (last sitefiles) (ncons 'restore)))))) ;;;Review options, setup todo lists (format t "~2&--------------------") (loop for choice in selected as choicename = (car choice) as restore = (member 'restore (cdr choice)) as load = (member 'load (cdr choice)) as option = (find choicename options :key #'optname) as optname = (optname option) as optdir = (optdir option) as optsystem = (optsystem option) as optdo = (optdo option) do (debugf "~%Choice=~s,~@[ restore~]~@[ load~]" choicename restore load) (debugf "~% Name=~s, dir=~s, system=~s, do=~s" optname optdir optsystem optdo) (if (null option) (warn "Bug in options installation??? Skipping choice ~a!" (or (catch-error (string choicename) nil) choice)) (when (or restore load) (when (and restore optdir) (setq optdir (mapcar #'string optdir)) ;Dir-list elts are strings!!! (push optdir directories-to-restore) (push optdir directories-pending)) (when (and load optdo) (push optdo commands-to-eval) (debugf "~%Command to eval: ~s" optdo)) (when (and load optsystem) (push (if (eq optsystem t) optname optsystem) systems-to-copy) (debugf "~%System to copy=~a" (car systems-to-copy))) (format t "~%For ~a: " optname) (format t "~@[restore ~s~]~@[~* + ~]~@[load via ~s~]" (and restore optdir) (and restore load) (and load optdo))))) (unless (yes-or-no-p "~2%Do you want to restore/load as listed above [NO means abort installation] ?") (abort-install)) ;;;Site files... system files... (phasen "Assure 'SYS:SITE;' system site files are available") (if (or (and (null systems-to-copy) ;;;Following are the systems that really ought to be in SYS:; (not (intersection options-that-must-be-in-release-4 (mapcar #'car selected)))) (if (null load-requires-restore-p) (yes-or-no-p "Please confirm - Are all Release 4 optional .SYSTEM files in your SYS:SITE; directory?"))) (progn (format t "~%It appears that copying the SYS:SITE; .SYSTEM files is not required.") (phaseskip)) (progn (if systems-to-copy (format t "~%~ To load some system~P you selected, we must copy the corresponding system definition file~:P into your site file directory. It is important to determine at this time whether your site files are set up for Release 4." (length systems-to-copy)) (format t "~%~ For you to use the software you selected, we must be sure that your site files are set up for Release 4.")) (format t "~% This means that the directory 'SYS:SITE;' must be properly established and accessible. \ Also, any files restored from this tape will go into the 'RELEASE-4;' directory. If your source hierarchy is 'RELEASE-4;' loading the systems from this tape will not work properly, leading to unpredictable problems. \ So, to be properly set up for Release 4, the pathname translations for the SYS host for system source directories should point to the 'RELEASE-4' directory on your system host.~%") (wait-for-proceed) ;;Try to figure out the state of the site files (let*((current-site (fs:translated-pathname (pathname "SYS:SITE;*.*#>"))) (trans-srcs (fs:translated-pathname (pathname "SYS:SOMEWHERE;*.*#>"))) (trans-dir (pathname-directory trans-srcs)) (src-dir (if (atom trans-dir) (ncons trans-dir) (butlast trans-dir))) (current-srcs (make-pathname :defaults trans-srcs :directory src-dir)) (sys-host (send current-srcs :host)) sys-host-up (local-host (send si:local-host :name)) (amnesia-p (eq si:local-host (si:parse-host 'amnesia))) (rel4-p (equal src-dir '("RELEASE-4"))) (vanilla-p (and rel4-p (not amnesia-p) (eq (si:parse-host 'lambda-a t) sys-host)))) ;;This is hairy, mostly because of all the text (cond (vanilla-p (format t "~% It appears you are booted with completely defaulted 4.0 site information; your SYS HOST is called LAMBDA-A, and this host knows its proper name, ~a." local-host)) (amnesia-p (beep) (format t "~% It appears you are booted as AMNESIA, which means that your system's PACK-NAME contains a host name that is not contained in the loaded site information. I have to conclude that either 1] you have created your own site files in the past, and need to modify and reload them for release 4, or 2] you have changed the pack name incorrectly. In either case, you can not perform this installation until you resolve this, at which time you can start over and repeat the procedure.") (format t "~2% Recommendations: 1] Go to the SYS HOST and use SI:SET-SYS-HOST to point to your custom site files; run (UPDATE-SITE-CONFIGURATION-INFO); then save a band; then redo this installation. SI:SET-SYS-HOST works one of two ways: a] Point to directory on this host, e.g. \(SI:SET-SYS-HOST \"LM\" NIL NIL \"MY-SITEFILES;\"\) b] Point to remote host/directory, e.g. \(SI:SET-SYS-HOST \"AHOST\" :LISPM #o3020 \"MY-SITEFILES;\"\) 2] Execute \(SI:GET-PACK-NAME\) to see the current host name strings. Then, execute \(SI:SET-PACK-NAME\) to set the correct host name strings and reboot. For example: \(SI:GET-PACK-NAME\) \"whoops\" \"mistake\" \(SI:SET-PACK-NAME \"real-name real-name2\"\)") (if (si:parse-host 'lambda-a t) (format t "~% You can even set the pack name to \"lama lamb\" and reboot now with completely default site information, which will work temporarily, but you may want to fix the site files and reload them later. ")) (read-carefully) (abort-install "Local host is AMNESIA")) ;Done with AMNESIA (rel4-p (format t "~2% Your site files appear to point to a proper source hierarchy for release 4; the logical host \"SYS:\" translates to ~A, which appears to be correct." current-srcs)) ;;;Real site info, but not pointing to RELEASE-4 sources (:WRONG-SITE-DIRECTORY? (beep) (format t "~2% The logical pathname definition for \"SYS:\", which should point to the release 4 source hierarchy directory \"RELEASE-4;\", is not correct; your source hierarchy translation works out to ~a." current-srcs) (format t "~% Perhaps you have not loaded your customized site files, and/or you have not modified the file SYS:SITE;SYS.TRANSLATIONS to point to the RELEASE-4 directory as the source hierarchy. \ Since we cannot load the optional software unless we can run MAKE-SYSTEM, we must be ABSOLUTELY CERTAIN that \ 1] The system definition files for the optional systems get restored into SYS:CUSTOMER-SITE; and copied into your own SYS:SITE; directory; and 2] The translations for SYS:*; point to the RELEASE-4 directory. ") (read-carefully) (wait-for-proceed) (format t "~% At this point you have two options: \ a) You can abort this installation, so that you can manually correct your site files to translate 'SYS:*;' to RELEASE-4; b) This procedure can generate and load a new SYS.TRANSLATIONS file into your own SYS:SITE; directory. This should solve the problem under the usual circumstances, but DON'T ELECT TO DO SO if you have customized your own SYS.TRANSLATIONS file to execute site-specific procedures! c) You can continue anyway, if you know the circumstances are correct.") (case (fquery '(:type :tyi :choices (((:abort "Abort") #\A) ((:load "Load SYS.TRANSLATIONS") #\B) ((:continue "Continue") #\C)) :list-choices t :help-function (lambda(stream &rest ignore) (format stream "(Type A to abort, R to restore SYS.TRANSLATIONS, or C to continue")) ) "~%How should we proceed? ~% A = ABORT. B = This procedure will generate a new SYS:SITE;SYS.TRANSLATIONS for you. C = Continue and hope for the best. Choose one: ") (:ABORT (format t "~%OK...") (sleep 3) (clear-screen) (format t "~% Recommendations: you can either 1] edit your own SYS.TRANSLATIONS file, or 2] restore the distribution CUSTOMER-SITE; directory and copy the example SYS.TRANSLATIONS file into your own SYS:SITE; directory. \ To correct this situation, we recommend either of the following procedures:") (format t "~% 1] Working on the SYS HOST, use ZMacs to edit `SYS:SITE;SYS.TRANSLATIONS'. If you plan to also run a previous software release, you may want to first copy the old site file directory to a new directory location. Then edit your new SYS.TRANSLATIONS so that it looks something like: \ ;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL; -*- \ \(fs:set-logical-pathname-host \"SYS\" :physical-host \"LAMA\" \; the actual computer where the sources are stored :translations '\(\(\"CHAOS;\" \"\"\) \(\"SITE;\" \"\"\) \(\"*;*;*;\" \"\"\) \(\"*;*;\" \"\"\) \(\"*;\" \"\"\)\)\) ") (format t "~% 2] Repeat this installation, choosing only to restore CUSTOMER-SITE. Then copy the example file as follows: \(FS:COPY-FILE \"~A:RELEASE-4;SYS.TRANSLATIONS\" \"SYS:SITE;\"\) \ ...and edit it to modify only the :PHYSICAL-HOST keyword value to refer to your current SYS HOST. ") (read-carefully) (abort-install "invalid SYS:*; translation")) ((:continue :trap) (setq skip-sample-systems-copy t) (format t "~%Ok, we're taking your word for it.")) (:load (let*((path (fs:translated-pathname "SYS:SITE;SYS.TRANSLATIONS#>")) (host (pathname-host path)) (fn (namestring path)) (*readtable* (si:find-readtable-named "CL" t)) temp) (unless (fs:get-pathname-host host t) (abort-install "invalid host ~a" host)) (unless (eq (setq temp(send host :system-type)) :lispm) (abort-install "Cannot generate ~a for non-LISPM host ~a [type ~a]" fn host temp)) (with-open-file(out path :direction :output :error :reprompt) (format out "~% ;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL; -*- \ ;;; SYS.TRANSLATIONS written from 4.0 Options Distribution procedure. \ ") (si:write-responsibility-comment out) (format out "~2% ;;; Defines the translations for the SYS logical host.~2%") (pprint `(fs:set-logical-pathname-host "SYS" :physical-host ,(send host :name) :translations '(("CHAOS;" ,(directory-namestring path)) ("SITE;" ,(directory-namestring path)) ("*;*;*;*;*;" "") ("*;*;*;*;" "") ("*;*;*;" "") ("*;*;" "") ("*;" ""))) out)) (format t "~2%Done writing ~a, proceeding to load." path) (load path)) ))) ) ;cond ??all the site file situations (when systems-to-copy (push current-site systems-to-copy)) ;save site file dir ))) ;If systems-to-copy ;;; ;;;Now we're cooking - restoring files ;;; (phasen "Restore files for software options") (if (null directories-to-restore) (phaseskip) (catch catch-last-directory ;;Make sure tape drive is ON-LINE (multiple-value-bind (status error) (catch-error (tape:device-status)) (unless (or error (not (listp status)) (member :on-line status)) (beep) (fquery '(:type :tyi :choices :any :list-choices nil :clear-input t) "The tape drive appears to be unavailable. Check the tape and press any character to try again:")) (unless (or (member :on-line (catch-error (tape:device-status))) (yes-or-no-p "The problem has not been resolved... Try to proceed anyway? ")) (read-carefully) (abort-install "tape drive problem - status reports ~A" (with-output-to-string (error-output) (catch-error(tape:device-status)))))) ;;;Start restore. Remember, normally the tape position ;;;is at the end of the first file on the tape. (In other words, ;;;you don't need to rewind.) (let ((more-p (send terminal-io :more-p)) (more-x (send terminal-io :set-more-p nil))) (unwind-protect (tape:restore-files :transform #'(lambda(flist) ;;The following works destructively, to bash ;;the tape software's file plist; says "already backed up" (setf (get flist :not-backed-up) nil) (send (car flist) :new-pathname :host *host*)) :match #'(lambda(flist &aux (path (car flist)) result) (prog1 (setq result (member (prog(dir) (setq dir (send path :directory)) (if (atom dir) (setq dir (ncons dir))) (return dir)) directories-to-restore :test #'directory-wanted-p)) (unless result (when (null directories-pending) (when catch-last-directory (throw catch-last-directory))) (format t "~%Skipping ~a" path)))) :overwrite :never) (send terminal-io :set-more-p more-p))))) (when directories-pending (format t "~2%>> There could have been an error - director~@P pending: ~S" (length directories-pending) directories-pending)) (phasen "Copying system definition files to SYS:SITE;") (cond ;Systems to copy? site files visible? ((null (cdr systems-to-copy)) (phaseskip)) (skip-sample-systems-copy (phaseskip)) ((not (pathnamep (car systems-to-copy))) (format t "[Aborting]") (format t "~%>> Sorry, this is probably a bug! Can't get your site file directory.") (format t "~%>> I suggest you try: \(TAPE:REWIND\) \(TAPE:RESTORE-FILES\) \ ...and then use \(MAKE-SYSTEM 'name\) to load each optional system. ") (read-carefully) (abort-install "internal bug")) (t ;Ok to copy system files ;;; ;;;Should get here iff site files OK and we're copying .SYSTEM files ;;; (let((from-path (make-pathname :host *host* :directory '("RELEASE-4" "CUSTOMER-SITE"))) (to-path (make-pathname :defaults (pop systems-to-copy) :name :wild :version :wild :type :wild))) (unless (yes-or-no-p "Ok to copy system definition files to ~a [No means abort installation!] ?" to-path) (abort-install "user chose not to copy system definition files")) (loop for file in systems-to-copy as from = (make-pathname :defaults from-path :name (string file) :type "SYSTEM" :version :highest) do (format t "~%Copying ~a to ~a" from to-path) (copy-file from to-path)))) ) ;Done phase - copy system def files ;;; ;;;Run commands to MAKE-SYSTEMs ;;; (phasen "Execute commands to load optional systems") (if (null (setq commands-to-eval (reverse commands-to-eval))) (phaseskip) (loop for cmd in commands-to-eval do (condition-case (err) (when (ask-y-or-n "Execute `~s'" cmd) (eval cmd)) (sys:abort (format t "~%Aborted."))))) (format t "~2%4.0 Options -- Installation completed.") ) ;labels local-fcns ) ;let local-vars ) ;tagbody ) ;return-block ) ;else [we're doing install] ) ;cond top-level ) ;top-level forms