;;; -*- Mode: Lisp; Package: User; Base: 10; -*- ;;; $Header: /ct/build/bldsys.l,v 1.50 85/04/03 14:12:52 bill Exp $ (putprop 'bldsys "$Revision: 1.50 $" 'rcs_revision) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; BLDSYS ;;; ;;; ;;; ;;; William Brew 2-25-84 ;;; ;;; ;;; ;;; Loads the interpreter, runs the front end and loads the debugger ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1984 Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Edited 13 August 1985 Richard Mark Soley for Lambda installation. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #-:lispm (eval-when (compile load eval) (break arent-you-supposed-to-be-on-a-lispm???? t)) #+Symbolics (eval-when (compile load eval) (cond ((>= (si:get-system-version) 242.) (sstatus feature release5)) (t (sstatus feature release4)))) (declare (special *ct_load_subdir* *release* *db%release* *temp_directory* *ct_load_defs* *browser-release* *db%system_key* *lrm-release* si:*count-usable-pages* si:page-size zwei:*adamode-release*)) (defvar *band_info* (list nil) "Arbitrary property list of band info.") #-LMI (eval-when (compile eval) (ct_load 'resume)) #+LMI (defmacro si:without-stack-overflows (&body body) `(progn . ,body)) (eval-when (compile eval) (ct_load 'protect)) (eval-when (eval compile load) (defpackage browser)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Callable Functions/Methods -- ;;;This is the function to call to install all the CTAda stuff. (defun install_ctada () (setup_dump_mode ':ask) (cond ((or (real_sitep) (eq (get *band_info* 'dump_mode) 'ct_practice_customer)) (install_ctada_int ':ask ':ask nil)) (t (install_ctada_int ':ask ':ask nil)))) ;;;This is the function to call to load all the CTAda stuff. (defun load_ctada () (setup_dump_mode ':ask) (cond ((or (real_sitep) (eq (get *band_info* 'dump_mode) 'ct_practice_customer)) (load_ctada_int ':ask "no_subdir" ':ask ':ask ':ask nil nil ':ask ':ask ':ask ':ask ':ask ':ask':default)) (t (load_ctada_int ':ask ':ask ':default ':default ':default t t ':default ':default ':default ':default ':default ':default ':ask)))) ;;;Print out some interesting info about CTAda. (defun show_ctada (&optional (stream terminal-io)) (format stream "~%Computer*Thought Interpreter Debugger~%") (and (boundp '*release*) *release* (format stream "Interpreter release ~a~%" *release*)) (and (boundp '*db%release*) *db%release* (format stream "Debugger release ~a~%" *db%release*)) (and (boundp '*browser-release*) *browser-release* (format stream "Browser release ~a~%" *browser-release*)) (and (boundp '*lrm-release*) *lrm-release* (format stream "Lrm release ~a~%" *lrm-release*)) (and (boundp 'zwei:*adamode-release*) zwei:*adamode-release* (format stream "Ada mode editor release ~a~%" zwei:*adamode-release*)) (and (boundp '*band_info*) (listp *band_info*) *band_info* (loop initially (format stream "Band information:~%") for (indicator value . rest) on (cdr *band_info*) by 'cddr do (format stream "~5t~a~40t~a~%" indicator value))) (and (boundp '*ct_load_defs*) *ct_load_defs* (loop initially (format stream "The following C*T controlled files are present:~%") for name in *ct_load_defs* for loadedp = (eval (list #'status 'feature name)) for version = (get name 'rcs_revision) do (cond ((not loadedp)) (version (format stream "~5t~a~22t~a~%" name version)) (t (format stream "~5t~a~%" name)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Methods -- ;;;Set up the dump mode. For now, we allow a mode where we can make C*T look like ;;;a customer's site. Possible extensions: an all default mode. ;;;like a non C*T site even when we are at C*T. (defun setup_dump_mode (&optional (customerp ':ask)) (if (null (get *band_info* 'dump_mode)) (if (memq si:site-name '(CT C*T :CT :C*T)) (if (ct_get_value customerp 't-or-nilp t "Do you wish to practice a customer installation? ") (putprop *band_info* 'ct_practice_customer 'dump_mode) (putprop *band_info* 'ct_internal 'dump_mode)) (putprop *band_info* 'ct_customer 'dump_mode)))) ;;;Internal version install_ctada. (defun install_ctada_int (&optional (band ':ask) (gc_before ':ask) (internalp t) &aux (current_more_p (send terminal-io ':more-p))) (unwind-protect (progn (send terminal-io ':set-more-p nil) (setq band (ct_get_value band 'bandp #+cadr "intd" #+3600. ">ctada.load" "Dump to which world load file? ")) (setq gc_before (ct_get_value gc_before 't-or-nilp t "GC before dumping? ")) (cond (internalp (load_ctada_int)) (t (load_ctada))) (maybe_gc gc_before) (putprop *band_info* (time:print-current-time nil) 'time_stamp) (putprop *band_info* si:site-name 'site_name) (putprop *band_info* user-id 'guilty_party) (putprop *band_info* (current_band_description) 'base_band) (putprop *band_info* band 'new_band_name)) (send terminal-io ':set-more-p current_more_p)) (disk-save band)) ;;;Internal version of load_ctada (defun load_ctada_int (&optional (obj_directory ':ask) (subdir ':ask) (pass_directory ':ask) (temp_directory ':ask) (ada_env_directory ':ask) (timing ':ask) (report ':ask) (interp_key ':ask) (intd_man_directory ':ask) (brow_man_directory ':ask) (lrm_man_directory ':ask) (editor_man_directory ':ask) (brow_key ':ask) (dump_string ':ask) &aux (current_more_p (send terminal-io ':more-p))) (unwind-protect (progn (send terminal-io ':set-more-p nil) (cond ((status nofeature :ctada_loaded) (setq obj_directory (ct_get_value obj_directory 'directoryp "local:>ct>" "Directory containing the C*T object files? ")) (setq subdir (ct_get_value subdir 'subdirp "no_subdir" "Ct_load subdirectory? ")) (load_ct_loader obj_directory subdir) (putprop *band_info* obj_directory 'ct_object_file_directory) (setq pass_directory (ct_get_value pass_directory 'directoryp (add_subdir subdir (add_subdir "build" obj_directory)) "Directory containing the C*T password file? ")) (set_up_password pass_directory) (ct_load 'protect) (when (or (soft-protect 'interpreter) (soft-protect 'debugger)) (setq temp_directory (ct_get_value temp_directory 'directoryp "local:>ct>" "Directory containing the C*T temporary files? "))) (when (soft-protect 'interpreter) (setq ada_env_directory (ct_get_value ada_env_directory 'directoryp (add_subdir subdir (add_subdir "interp" obj_directory)) "Directory containing the C*T Ada environment files? ")) (setq timing (ct_get_value timing 't-or-nilp nil "Show execution timing information? ")) (setq report (ct_get_value report 't-or-nilp nil "Load the report package? ")) (setq interp_key (ct_get_value interp_key 'keyp "A" "To what system key should CTAda be bound? "))) (when (soft-protect 'browser) (setq brow_man_directory (ct_get_value brow_man_directory 'directoryp (add_subdir subdir (add_subdir "browser" (add_subdir "doc" obj_directory))) "Directory containing the Browser User Manual files? ")) (when (and (soft-protect 'interpreter) (soft-protect 'debugger)) (setq intd_man_directory (ct_get_value intd_man_directory 'directoryp (add_subdir subdir (add_subdir "manual" (add_subdir "doc" obj_directory))) "Directory containing the CTAda User Manual files? "))) (when (soft-protect 'lrm) (setq lrm_man_directory (ct_get_value lrm_man_directory 'directoryp (add_subdir subdir (add_subdir "lrm" (add_subdir "doc" obj_directory))) "Directory containing the LRM files? "))) (when (soft-protect 'editor) (setq editor_man_directory (ct_get_value editor_man_directory 'directoryp (add_subdir subdir (add_subdir "editor" (add_subdir "troff" obj_directory))) "Directory containing the Ada Mode Editor manual files? "))) (setq brow_key (ct_get_value brow_key 'keyp "B" "To what system key should the browser be bound? "))) (setq dump_string (ct_get_value dump_string 'stringp "How much is that doggie in the window?" "What dump string would you like? ")) (si:without-stack-overflows (load_ctada_proc obj_directory subdir pass_directory temp_directory ada_env_directory timing report interp_key intd_man_directory brow_man_directory lrm_man_directory editor_man_directory brow_key dump_string terminal-io)) (format t "~%CTAda is now loaded.~%")) (t (format t "~%CTAda appears to be already loaded.")))) (send terminal-io ':set-more-p current_more_p))) ;;;This actually does all the loading. (defun load_ctada_proc (obj_directory subdir pass_directory temp_directory ada_env_directory timing report interp_key intd_man_directory brow_man_directory lrm_man_directory editor_man_directory brow_key dump_string &optional (stream terminal-io)) obj_directory pass_directory (let ((terminal-io stream)) (terpri) ;;Do a little set up (login-forms (setq-globally base 10. ibase 10. *nopoint nil si:gc-report-stream nil)) #-LMI (ct_load 'resume) (setq *temp_directory* temp_directory) (putprop *band_info* temp_directory 'ct_temp_directory) ;;Now that everything is set up, lets start to do the real work ;;First the interpeter (when (soft-protect 'interpreter) (ct_load 'interp) (sstatus nofeature :fe_initialized) (putprop *band_info* timing 'timing_info) (putprop *band_info* report 'report_package) (putprop *band_info* ada_env_directory 'ada_environment_directory) (dumpada subdir timing report ada_env_directory) (putprop *band_info* t 'interpreter_loaded)) ;;And then the debugger (when (soft-protect 'debugger) (setq *db%system_key* interp_key) (putprop *band_info* interp_key 'interpreter_system_key) (ct_load 'debugger) (db%dump_debugger) (putprop *band_info* t 'debugger_loaded)) ;;And the browser (when (soft-protect 'browser) (putprop *band_info* brow_man_directory 'browser_manual_directory) (putprop *band_info* brow_key 'browser_system_key) (ct_load 'browser) (browser:init-browser brow_key brow_man_directory) (when (and (soft-protect 'interpreter) (soft-protect 'debugger)) (browser:install-intd-document intd_man_directory) (putprop *band_info* intd_man_directory 'interpdebug_manual_directory)) (when (soft-protect 'lrm) (browser:install-lrm-document lrm_man_directory) (putprop *band_info* lrm_man_directory 'lrm_manual_directory)) (when (soft-protect 'editor) (browser:install-editor-document editor_man_directory) (putprop *band_info* editor_man_directory 'editor_manual_directory)) (putprop *band_info* t 'browser_loaded)) ;;And the ada mode editor (when (soft-protect 'editor) (ct_load 'adamode) (putprop *band_info* t 'adamode_loaded)) (setq *ct_load_subdir* "") (putprop *band_info* dump_string 'dump_string) (sstatus feature :ctada_loaded))) ;;;This gets all the ct_load cruft loaded. (defun load_ct_loader (obj_directory subdir) (let* ((host (send (fs:parse-pathname obj_directory) ':host)) (host_type (typep host)) (ct_loader nil)) (sstatus feature :inhibit_default_filemap) (cond ((status feature :LMI) (load (setq ct_loader (subdir_substitute subdir (string-append obj_directory "ctlisp.") "ctload.qfasl"))) (eval `(ct_load_def filemap ,(string-append obj_directory "ctlisp.filemaps; filemap.qfasl")))) ((and (status feature :3600) (eq host_type 'fs:lispm-host)) (load (setq ct_loader (subdir_substitute subdir (string-append obj_directory "ctlisp>") "ctload.bin"))) (eval `(ct_load_def filemap ,(string-append obj_directory "ctlisp>filemaps>filemap.bin")))) ((and (status feature :3600) (eq host_type 'fs:unix-host) (status feature release5)) (load (setq ct_loader (subdir_substitute subdir (string-append obj_directory "ctlisp//") "ctload.bn"))) (eval `(ct_load_def filemap ,(string-append obj_directory "ctlisp//filemaps//filemap.bn")))) ((and (status feature :3600) (eq host_type 'fs:unix-host) (status feature release4)) (load (setq ct_loader (subdir_substitute subdir (string-append obj_directory "ctlisp//") "ctload.OB"))) (eval `(ct_load_def filemap ,(string-append obj_directory "ctlisp//filemaps//filemap.OB")))) ((and (status feature :cadr) (eq host_type 'fs:lispm-host)) (load (setq ct_loader (subdir_substitute subdir (string-append obj_directory "ctlisp>") "ctload.qbin"))) (eval `(ct_load_def filemap ,(string-append obj_directory "ctlisp>filemaps>filemap.qbin")))) ((and (status feature :cadr) (eq host_type 'fs:unix-host) (status feature release5)) (load (setq ct_loader (subdir_substitute subdir (string-append obj_directory "ctlisp//") "ctload.qb"))) (eval `(ct_load_def filemap ,(string-append obj_directory "ctlisp//filemaps//filemap.qb")))) ((and (status feature :cadr) (eq host_type 'fs:unix-host) (status feature release4)) (load (setq ct_loader (subdir_substitute subdir (string-append obj_directory "ctlisp//") "ctload.OQ"))) (eval `(ct_load_def filemap ,(string-append obj_directory "ctlisp//filemaps//filemap.OQ")))) (t (break "what kind of machine is this anyway"))) (putprop *band_info* ct_loader 'ct_loader) (sstatus feature :ct_load) (setq *ct_load_subdir* subdir) (putprop *band_info* subdir 'ct_load_subdir) (ct_reload 'filemap) (putprop *band_info* (ct_load_get 'filemap) 'filemap) (switch_filemap_host "local" (send host ':string-for-printing)) (putprop *band_info* (send host ':string-for-printing) 'ct_host))) ;;;Set up the load def for the password file. For now we have wired in the name of the file. (defun set_up_password (pass_directory) (ct_load_put 'syspwd (string-append pass_directory "syspwd.dat")) (putprop *band_info* (with_ct_load_subdir "no_subdir" (ct_load_get 'syspwd)) 'password_file)) ;;;Patch a filemap entry to point to a different host. (defun switch_ct_def_host (ct_name from_host to_host) (let ((current_def (with_ct_load_subdir "no_subdir" (ct_load_get ct_name))) colon_char) (if (and (stringp current_def) (setq colon_char (string-search-char #/: current_def)) (string-equal from_host (substring current_def 0 colon_char))) (ct_load_put ct_name (string-append to_host (substring current_def colon_char)))))) ;;;A kludge to patch the filemap so that it will point to a different host. (defun switch_filemap_host (from_host to_host) (mapc #'switch_ct_def_host *ct_load_defs* (circular-list (string from_host)) (circular-list (string to_host)))) ;;;Do the same subdir substitutions that ctload does. (defun subdir_substitute (subdir path file) (condition-case () (let ((host_type (typep (send (fs:parse-pathname path) ':host)))) (cond ((string-equal subdir "no_subdir") (string-append path file)) ((and (string-equal subdir "") (eq host_type 'fs:unix-host)) (if (directoryp (string-append path "frozen//")) (string-append path "frozen//" file) (string-append path file))) ((and (string-equal subdir "") (eq host_type 'fs:lispm-host)) (if (directoryp (string-append path "frozen>")) (string-append path "frozen>" file) (string-append path file))) ((eq host_type 'fs:unix-host) (string-append path subdir "//" file)) ((eq host_type 'fs:lispm-host) (string-append path subdir ">" file)) (t (break "subdir problem")))) (error ""))) ;;;Just add a subdirectory to the end of path using the correct syntax. (defun add_subdir (subdir path) (subdir_substitute subdir path "")) ;;;Kludges to work around a bug in the garbage collector. (declare (special *gc_complete*)) ;;;Maybe do a garbage collection depending on the value of gc_before. This function ;;;is here to hide some of the ugliness of the current garbage collection scheme. (defun maybe_gc (gc_before) ;;Work around for Slymbolics garbage collector bug. ;;In release 5.2, if you gc in the same process that loaded ctada, ;;then the garbage collector gets fouled up because the pdl stacks have been extended. (when gc_before (format t "~2%WARNING, a separate process will be used for garbage collection.~%") (setq-globally *gc_complete* nil) (process-run-function "GC" 'gc_process gc_before terminal-io) (process-wait "GC Wait" #'(lambda () *gc_complete*)) (format t "~2%The original process has resumed.~%"))) ;;;This is where the gc actually happens. This function runs in a separate process for now. (defun gc_process (gc_before terminal-io) (let ((si:gc-report-stream terminal-io) (physical-memory-size #+3600.(* si:*count-usable-pages* si:page-size 4.) #+(or CADR Lambda) (sys:system-communication-area sys:%sys-com-memory-size))) (cond ((not gc_before) (putprop *band_info* "No gc" 'garbage_collection)) ((< physical-memory-size (expt 2. 20.)) (putprop *band_info* "GC cancelled -- small memory" 'garbage_collection)) ((< physical-memory-size (* 3. (expt 2. 20.))) (gc-immediately #+Symbolics t) (putprop *band_info* "GC immediately in a separate process" 'garbage_collection)) (t (si:full-gc ':system-release t) (putprop *band_info* "Full gc in a separate process" 'garbage_collection))) (setq-globally *gc_complete* t))) ;;;Return a string describing the current band. Just get the band name for now. ;;;Maybe get part of the herald in the future. Note use of string-append. This is ;;;to get a fresh copy of the string. Apparently, on the 3600, they string ;;;pointed to by si:loaded-band-name gets poked with the name of the band ;;;when it is loaded. (defun current_band_description () (string-append #+(or CADR Lambda) (si:current-band) #+:3600 si:loaded-band-name)) ;;;Ask the user for some input. (defun ct_ask_string (&rest format_args) (apply #'format format_args) (readline)) ;;;Get a new value from the user. Special case if we are looking for a yes or ;;;no answer. (this whole input scheme is getting pretty kludgy) ;;;Bug: user cannot enter a null string. (defun ct_ask_new_value (predicate default_value prompt &optional (stream terminal-io)) (let* ((default_string (cond ((neq predicate 't-or-nilp) (string default_value)) ((not default_value) "No") (t "Yes"))) (new_value (ct_ask_string stream "~&~a(default: ~a) " prompt default_string))) (if (string-equal new_value "") (setq new_value default_string)) (cond ((neq predicate 't-or-nilp) new_value) ((memq (character new_value) '(#/n #/N)) nil) ((memq (character new_value) '(#/y #/Y)) t) (t 'bad)))) ;;;Get a value. If the current value looks good, return it. If we want the default ;;;and it looks good return it. Otherwise, query the user. (defun ct_get_value (value predicate default_value prompt &optional (stream terminal-io)) (cond ((and (neq value ':ask) (funcall predicate value)) value) ((and (eq value ':default) (funcall predicate default_value)) default_value) (t (loop for new_value = (ct_ask_new_value predicate default_value prompt stream) if (funcall predicate new_value) return new_value else do (format stream "~%Bad value. Please try again.~2%"))))) ;;;The following functions are a few simple predicates for checking some of the ;;;arguments we recieve. They should be beefed up at some point. ;;;Determine if this is a real site or C*T. (defun real_sitep () (not (memq si:site-name '(CT C*T :CT :C*T)))) (defun t-or-nilp (frob) (memq frob '(t nil))) (defun directoryp (frob) (let ((pathname (fs:parse-pathname frob))) (and (stringp frob) (string-search-char #/: frob) (condition-case () (progn (open frob ':direction ':probe-directory) (open (string-append frob "xyzzy") ':direction ':probe-directory)) (error nil) (:no-error t)) (not (send pathname ':name))))) (defun subdirp (frob) (and (stringp frob) (member frob '("latest" "frozen" "no_subdir" "debugging" "")))) ;;;These band checkers could be a little more robust and try checking for bands ;;;that shouldn't be clobbered. #+:3600 (defun bandp (frob) (stringp frob)) #+(or CADR Lambda) (defun bandp (frob) (and (stringp frob) (<= (string-length frob) 4.))) (defun keyp (frob &aux it) (and (stringp frob) (setq it (character frob)) (or (neq it (char-downcase it)) (neq it (char-upcase it))))) ; Let the world know that we are loaded (sstatus feature :bldsys) ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;