;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; ;;;$Header: /ct/ctlisp/ctload.l,v 1.19 84/09/06 15:05:38 bill Exp $ ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CT_LOAD ;;; ;;; ;;; ;;; Machine-Independent, Database-Driven File Loader. ;;; ;;; ;;; ;;; 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 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;; ;;; ;;; NB: This stuff has been hacked a great deal for adopting RCS. ;;; ;;; Due to this, ct_load needs to be re-written. A version which ;;; ;;; keeps pathnames in a more structured form, instead of strings, ;;; ;;; is desired. Also, the following documentation is probably not ;;; ;;; very accurate. This version is temporary and kludgy, but it ;;; ;;; does happen to work. -- Mark ;;; ;;; ;;; ;;; NO External Files Are Required For CT_LOAD. It is expected that ;;; ;;; CT_LOAD (and personal filemaps) will be loaded by each person's ;;; ;;; Lisp/Compiler Init File. Thus, no source code other than init ;;; ;;; files should ever contain constant filename strings!!! ;;; ;;; ;;; ;;; User-callable functions: ct_load_def, ct_load_put, ct_load, ;;; ;;; ct_reload, ct_load_get, status_feature, sstatus_feature, ;;; ;;; ct_includef. Makes excl a machine-indep. escape (slashifier). ;;; ;;; User-settable specvar: *ct_load_dflts*. User-readable specvar: ;;; ;;; *ct_load_defs* (list of CT filename syms ct_load_def'd so far). ;;; ;;; ;;; ;;; Ct_load_def takes two arguments, a symbol (the CT Symbolic Name ;;; ;;; for a file), and a string (a machine dependent path string for ;;; ;;; it). ;;; ;;; ;;; ;;; Ct_load and ct_reload take a single argument, a unique symbolic ;;; ;;; "generic" name for a file. (The actual filename is expected to ;;; ;;; have been previously defined using ct_load_def.) When ct_load ;;; ;;; loads file f, it remembers that, using (sstatus_feature f). ;;; ;;; Ct_load won't load f if called again -- use ct_reload if that is ;;; ;;; what you want (eg., if you just editted f). ;;; ;;; ;;; ;;; Ct_load is meant to be used in conjunction with a separate file ;;; ;;; of data (= calls to ct_load_def, which is analogous to defprop), ;;; ;;; which is the LOADER FILEMAP. Machine-dependent filename ;;; ;;; strings, specific versions of files for demos, etc., are thus ;;; ;;; isolated into a separate file, and code using ct_load instead of ;;; ;;; lisp's load need never refer to constant filename strings. It ;;; ;;; is URGED that ALL occurrences of load be replaced by appropriate ;;; ;;; calls to ct_load instead. (continued) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (continued) ;;; ;;; ;;; ;;; Status_feature and SStatus_feature are versions of the LISP ;;; ;;; special forms that evaluate their one argument (which should be ;;; ;;; a symbol). ;;; ;;; ;;; ;;; *Ct_load_dflts* should be a list of values for the optional args ;;; ;;; to lisp load function. It defaults to something reasonable that ;;; ;;; provides similar behavior on both LM and Franz implementations. ;;; ;;; (NB: if your code supplies these extra args it becomes machine ;;; ;;; dependent.) ;;; ;;; ;;; ;;; ******* Example Usage: Preparing a Frozen Demo. ******* ;;; ;;; For frozen demos, it is recommended that every file needed ;;; ;;; (named in the filemap) be copied to a separate directory, and ;;; ;;; that a COPY of the filemap FILE itself BE EDITTED to USE that ;;; ;;; directory. Use full, explicit paths and versions with NO ;;; ;;; reliance on defaults. Eg., instead of saying (load ;;; ;;; ">bar>foo.lisp"), have the filemap file say (ct_load_def foo ;;; ;;; "local:>bar>foo.lisp.17") and then just load via (ct_load 'foo). ;;; ;;; Note that UNIX or VMS filenames need not bear any obvious or ;;; ;;; direct relation to the LM filenames (nor, indeed, to the CT ;;; ;;; Symbolic Name for the file). However, the USUAL CONVENTION, ;;; ;;; would be, eg., for foo to be the symbolic name with ;;; ;;; >ct>ctlisp>foo.lisp being the interpreted version on the LM, ;;; ;;; >ct>ctlisp>foo.qfasl being the compiled version on the LM, and ;;; ;;; likewise /mnt/ct/ctlisp/foo.l and foo.o being the unix versions. ;;; ;;; Normally it is recommended that ALL files be kept on the UnixVax ;;; ;;; file server, with foo.nnn.l being version nnn, and foo.l a link. ;;; ;;; Foo.nnn.o should be a link to foo.o (the installed Vax version ;;; ;;; of foo) and foo.nnn.qb should be a linke to foo.qb (the LM one). ;;; ;;; See ctvax:/mnt/ct/ctlisp/filemap.l for the standard default map. ;;; ;;; This is (now) always loaded by ct_load. ;;; ;;; Naturally, one must load ct_load using the standard load ;;; ;;; primitive. Then ct_load_def can be called to define a location ;;; ;;; for the filemap. Then, ct_load should be used instead of load. ;;; ;;; After ct_load and a filemap are in, no other files are needed to ;;; ;;; either compile or run ct_load. NB: The demo dir should have an ;;; ;;; init file which loads ct_load and then overwrites the filemap w. ;;; ;;; a pointer to a filemap file on the demo directory. It should ;;; ;;; then ct_load each file required, and then it should call the ;;; ;;; top level function of the demo. Thus, a naive user can run the ;;; ;;; demo simply by cold-booting (if on the LM) and logging in as the ;;; ;;; correct demo. (The analogous facility is also going to be ;;; ;;; supported on CT's Vax system(s).) (continued) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (continued) ;;; ;;; ;;; ;;; Ct_load returns nil if the file is not actually loaded, either ;;; ;;; due to a previous loading or an error (see below). If loading ;;; ;;; is successful, ct_load calls sstatus_feature to record the file, ;;; ;;; and then returns the path string actually used in loading. ;;; ;;; ;;; ;;; Possible errors: wrong_type_argument (must be non-nil SYMBOL ;;; ;;; naming the file, usually the fn1), illegal_or_missing_path (must ;;; ;;; find string [or symbol] naming a legal pathname on the ct_load ;;; ;;; property of sym), file_not_found (path located on plist must ;;; ;;; name an existing file), and error_during_loading (something ;;; ;;; broke while calling lisp load). When an error occurs, a break ;;; ;;; is forced -- if you resume from the break, nil is returned -- ;;; ;;; but if compat is loaded, LOSE is called instead. ;;; ;;; ;;; ;;; Loads initial dflt filemap from ctvax:/mnt/ct/ctlisp/filemap.l ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- ;;; RMSoley 13 Aug 85 to fix TI/LMI brain damage . . . #+(or LMI TI) (eval-when (eval compile load) (setq-globally compiler:qc-file-check-indentation nil)) #+franz (declare (macros t)) (declare (*expr lose)) ; In COMPAT. Since it has optional args, ; it is actually a lexpr ++ on Franz, but ; allegedly Franz lexprs = exprs, so... (declare (special *ct_status_feature_form* ; Internal-use-only. *ct_sstatus_feature_form* ; Internal-use-only. *ct_load_defs* ; User-readable list. *ct_load_dflts* ; User-settable hook. *ct_load_subdir* ; User-settable hook. *ct_load_type* ; User-settable hook. *ct_load_disabled* ; User-settable hook. *ct_load_circular* ; User-settable hook. *ct_load_unremovable_defs* ; ctload defs that don't go away. user-id ; As in LM Manual. )) ;;; Put main user symbols in package global since caller may be in ;;; zwei, tv, or other packages than user. #+lispm (progn (globalize '*ct_load_defs*) (globalize '*ct_load_dflts*) (globalize '*ct_load_subdir*) (globalize '*ct_load_type*) (globalize '*ct_load_disabled*) (globalize '*ct_load_circular*) (globalize '*ct_load_unremovable_defs*) (globalize 'status_feature) (globalize 'sstatus_feature) (globalize 'ct_includef) (globalize 'ct_load) (globalize 'ct_load_get) (globalize 'ct_load_put) (globalize 'ct_load_def) (globalize 'ct_load_subdir_def) (globalize 'ct_reload) (globalize 'with_ct_load_dflts) (globalize 'with_ct_load_subdir) (globalize 'with_ct_load_type) (globalize 'with_ct_load_disabled) (globalize 'with_ct_load_circular) (globalize 'wrong_type_argument) (globalize 'illegal_or_missing_path) (globalize 'file_not_found) (globalize 'ct_filemap_flush) (globalize 'ct_load_permanent) (globalize 'error_during_loading)) (setq *ct_status_feature_form* '(status feature ct_load)) (setq *ct_sstatus_feature_form* '(sstatus feature ct_load)) (cond ((not (boundp '*ct_load_defs*)) (setq *ct_load_defs* nil))) ;;; This defines the ct_load definitions to NOT remove when we ;;; do a ct_filemap_flush. All other ct_load definitions will ;;; be removed. The things in this list are the files that get ;;; loaded at RUN time. (cond ((not (boundp '*ct_load_unremovable_defs*)) (setq *ct_load_unremovable_defs* '(syspwd)))) (cond ((not (boundp '*ct_load_dflts*)) (setq *ct_load_dflts* #+lispm '(nil nil t nil) #+(and franz unix) '(nil t)))) (cond ((not (boundp '*ct_load_subdir*)) (setq *ct_load_subdir* ""))) (cond ((not (boundp '*ct_load_type*)) (setq *ct_load_type* nil))) (cond ((not (boundp '*ct_load_disabled*)) (setq *ct_load_disabled* nil))) (cond ((not (boundp '*ct_load_circular*)) (setq *ct_load_circular* nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ct_load, User-callable Functions, Source Code -- (defun status_feature (x) ;;; Like (status feature foo) but evals foo. Clobbers ;;; specvar to avoid repeatedly consing up the form to eval. (cond ((setq x (ct_load_symbol_check x)) (rplaca (cddr *ct_status_feature_form*) x) (eval *ct_status_feature_form*)))) (defun sstatus_feature (x) ;;; Like (sstatus feature foo) but evals foo. Also, doesn't ;;; put multiple occurrences of foo on (status features) list. ;;; Like status_feature, clobbers a specvar, to avoid ;;; repeatedly consing up the form to eval. (cond ((status_feature x)) (t (rplaca (cddr *ct_sstatus_feature_form*) x) (eval *ct_sstatus_feature_form*)))) (defun ct_load_def macro (form) ;;; Example usage: (ct_load_def foo "/mnt/ct/ctlisp/foo.l") ;;; Does not eval its args. (Analogous to defprop.) (rplaca form 'ct_load_put) (rplacd form (list (list 'quote (cadr form)) (list 'quote (caddr form))))) (defun ct_load_subdir_def macro (form) ;;; Example usage: (ct_load_subdir_def foo "latest") ;;; Does not eval its args. (Analogous to defprop.) (rplaca form 'ct_load_subdir_put) (rplacd form (list (list 'quote (cadr form)) (list 'quote (caddr form))))) (defun ct_load_put (sym strng) ;; Expr version (analogous to putprop). (cond ((or (null (setq sym (ct_load_symbol_check sym))) (null strng) (not (stringp strng))) (ct_load_err 'ct_load_put 'wrong_type_argument sym strng)) (t (or (memq sym *ct_load_defs*) (setq *ct_load_defs* (cons sym *ct_load_defs*))) (putprop sym strng 'ct_load)))) (defun ct_load_subdir_put (sym strng) ;; Expr version (analogous to putprop). (cond ((or (null (setq sym (ct_load_symbol_check sym))) (null strng) (not (stringp strng))) (ct_load_err 'ct_load_subdir_put 'wrong_type_argument sym strng)) (t (or (memq sym *ct_load_defs*) (setq *ct_load_defs* (cons sym *ct_load_defs*))) (putprop sym strng 'ct_load_subdir)))) (defun with_ct_load_dflts macro (forms) `(let ((old_dflts *ct_load_dflts*)) (unwind-protect (progn (setq *ct_load_dflts* ,(cadr forms)) ,@(cddr forms)) (setq *ct_load_dflts* old_dflts)))) (defun with_ct_load_subdir macro (forms) `(let ((old_subdir *ct_load_subdir*)) (unwind-protect (progn (setq *ct_load_subdir* ,(cadr forms)) ,@(cddr forms)) (setq *ct_load_subdir* old_subdir)))) (defun with_ct_load_type macro (forms) `(let ((old_type *ct_load_type*)) (unwind-protect (progn (setq *ct_load_type* ,(cadr forms)) ,@(cddr forms)) (setq *ct_load_type* old_type)))) (defun with_ct_load_disabled macro (forms) `(let ((old_disabled *ct_load_disabled*)) (unwind-protect (progn (setq *ct_load_disabled* ,(cadr forms)) ,@(cddr forms)) (setq *ct_load_disabled* old_disabled)))) (defun with_ct_load_circular macro (forms) `(let ((old_circular *ct_load_circular*)) (unwind-protect (progn (setq *ct_load_circular* ,(cadr forms)) ,@(cddr forms)) (setq *ct_load_circular* old_circular)))) ; Change to allow the case where we don't what any of the subdir crap to occur. ; Also check for a subdir property on the symbol. If one exists then use it. ; Otherwise use the *ct_load_subdir* value. (defun ct_load_get (sym) ;;; User-callable access function to lookup path for sym. ;;; Works, but needs to be cleaned up -- mlm. ++ (cond ((setq sym (ct_load_symbol_check sym)) (let ((path (ct_load_get_with_file_type sym)) (subdir (or (get sym 'ct_load_subdir) *ct_load_subdir*))) (cond ((equal subdir "no_subdir") path) ((or (equal subdir "frozen") (equal subdir "latest")) (cond ((probef_check_for_subdir path subdir) (ct_load_get_with_subdir path subdir)) (t (terpri) (terpri) (princ "Warning: No ") (princ subdir) (princ " subdirectory found for ct_load symbol ") (princ sym) (princ ".") (terpri) (princ "Using ") (princ path) (princ ", directly, instead.") (terpri) path))) ((not (equal subdir "")) (ct_load_get_with_subdir path subdir)) ((ct_load_check_for_ct_dir path) (cond ((probef_check_for_subdir path "frozen")) (t (terpri) (terpri) (princ "Warning: No frozen subdir for ct_load symbol ") (princ sym) (princ ", under !/ct.") (terpri) (princ "Using ") (princ path) (princ ", directly, instead.") (terpri) path))) (t path)))))) (defun ct_load (sym) ;;The normal top level interface. (ct_load_int sym 'ct_load nil)) (defun ct_reload (sym) ;;; Use this to force reloading a previously ct_loaded file. (ct_load_int sym 'ct_reload nil)) ;;; continued ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ct_load, User-callable Functions, Source Code -- continued (defun ct_includef (f) ;;; NB: in order to work correctly when compiling for the LM, f (the ;;; file) should ALWAYS be re-included regardless of (status features). ;;; The unwind-protect code approximates the LM's with-open-file ;;; primitive. It began as a copy of with_open_infile, from compat. ;;; The call to close works ok on both dialects, but should be kept ;;; consistent with ct_closef, in compat, as well. ++ (let ((eof (gensym)) (s (ct_load_get f))) (unwind-protect (progn (setq s #+lispm (open s ':direction ':input ':characters t) #+(and franz unix) (infile s) ) (do ((x (read s eof) (read s eof))) ((eq x eof)) (eval x))) (close s)))) ;;; **************** ;;; Flushing the file map ;;; **************** ;;; Here follows code to flush unused parts of the filemap. You should ;;; call this function just before the final garbage collect and save of ;;; the system. ;;; ;;; ct_filemap_flush runs through all the ct_load definitions, EXCEPT for ;;; those in *ct_load_unremovable_defs*, and cleans up as much as possible. ;;; ;**************; (defun ct_filemap_flush () ;**************; (do ((sym *ct_load_defs* (cdr sym))) ((null sym) t) ;; Loop over all the ct_load defs. ;; Remove the ct_load property if not unremovable. (or (memq (car sym) *ct_load_unremovable_defs*) (remprop (car sym) 'ct_load))) ;; Now, reset the list of known definitions, since most have been ;; clobbered. (setq *ct_load_defs* *ct_load_unremovable_defs*)) ;;; Allow other files to make certain symbols permanent. ;***************; (defun ct_load_permanent (symbol) ;***************; (cond ((memq symbol *ct_load_unremovable_defs*)) (t (setq *ct_load_unremovable_defs* (cons symbol *ct_load_unremovable_defs*))))) ;;; ;;; At one time, we had all the sharp-macro character definitions ;;; in this file. We found out (4-Apr-83) that they were not necessary, ;;; and so removed them. The code is in /mnt/ct/ctlisp/old_sharpmac.l ;;; John Shelton. ;;; **************************************************************** ;;; SETTING ESCAPE CHARACTERS. (leave this in CTLOAD) ;;; **************************************************************** ;;; Here, we make ! be a slash (escape) character in both ;;; dialects of lisp. ;;; On the lisp machine, make EXCL a slash character. (33. is the ;;; ascii code for EXCL) #+lispm (eval-when (compile load eval) (set-syntax-from-description 33. 'si:slash)) ;;; In FRANZ, make EXCL a slash character. 33. is the ascii for ;;; EXCL, and 143. is the Franz read-table type for escape characters. #+(and franz unix) (eval-when (compile load eval) (setsyntax 33. 143.)) ;;; On franz, define string coercion of symbols to be getting their pname. #+franz (putd 'string (getd 'get_pname)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros -- (#+lispm compiler-let #+franz let ((obsolete-function-warning-switch nil)) #+franz (defun ct_load_get_with_file_type (sym) (let* ((path (get sym 'ct_load))) (selectq *ct_load_type* (source (string (uconcat (ct_load_get_base_path path) ".l"))) (object (string (uconcat (ct_load_get_base_path path) ".o"))) path))) #+cadr (defun ct_load_get_with_file_type (sym) (let* ((path (get sym 'ct_load))) (selectq *ct_load_type* (source (string-append (ct_load_get_base_path path) ".l")) (object (string-append (ct_load_get_base_path path) ".qb")) (otherwise path)))) #+(and 3600. (not local_build)) (defun ct_load_get_with_file_type (sym) (let* ((path (get sym 'ct_load))) (selectq *ct_load_type* (source (string-append (ct_load_get_base_path path) ".l")) (object (string-append (ct_load_get_base_path path) ".bn")) (otherwise path)))) #+LMI (defun ct_load_get_with_file_type (sym) (let* ((path (get sym 'ct_load))) (selectq *ct_load_type* (source (string-append (ct_load_get_base_path path) ".lisp")) (object (string-append (ct_load_get_base_path path) ".qfasl")) (otherwise path)))) #+local_build (defun ct_load_get_with_file_type (sym) (let* ((path (get sym 'ct_load))) (selectq *ct_load_type* (source (string-append (ct_load_get_base_path path) ".lisp")) (object (string-append (ct_load_get_base_path path) ".bin")) (otherwise path)))) #+franz (defun ct_load_get_base_path (path) (let ((last_two (substring path -2 2))) (cond ((or (equal last_two ".o") (equal last_two ".l")) (substring path 1 (- (flatc path) 2))) (t path)))) #+cadr (defun ct_load_get_base_path (path) (let* ((length (string-length path)) (last_two (and (>= length 2) (substring path (- length 2) length))) (last_three (and (>= length 3) (substring path (- length 3) length)))) (cond ((equal last_three ".qb") (substring path 0 (- length 3))) ((equal last_two ".l") (substring path 0 (- length 2))) (t path)))) #+(and 3600. (not local_build)) (defun ct_load_get_base_path (path) (let* ((length (string-length path)) (last_two (and (>= length 2) (substring path (- length 2) length))) (last_three (and (>= length 3) (substring path (- length 3) length)))) (cond ((equal last_three ".bn") (substring path 0 (- length 3))) ((equal last_two ".l") (substring path 0 (- length 2))) (t path)))) #+LMI ;;; Don't you think this is little better, friends??? -- Soley 13 Aug 85 (defun ct_load_get_base_path (path) (string (send (fs:parse-pathname path) :new-type :unspecific))) #+local_build (defun ct_load_get_base_path (path) (let* ((length (string-length path)) (last_four (and (>= length 4) (substring path (- length 4) length))) (last_five (and (>= length 5) (substring path (- length 5) length)))) (cond ((equal last_four ".bin") (substring path 0 (- length 4))) ((equal last_five ".lisp") (substring path 0 (- length 5))) (t path)))) ; change to pass subdir as a parmeter 10-22-83 wab (defun ct_load_get_with_subdir (path subdir) ;;; Splices the subdir string into the pathname. ;;; The use of obsolete functions is due to N-way compat. constraints. (let* ((p (nreverse (exploden path))) (q (member #// p)) (fil (ldiff p q))) (string (maknam (nreverse (append fil '(#//) (reverse (exploden subdir)) q)))))) (defun probef_check_for_subdir (path strng) ;;; See if there is a strng (eg "frozen") subdir for path and if so return ;;; that. Otherwise return nil. ;;; Splices in the strng and splices out the filename proper. ;;; The use of obsolete functions is due to N-way compat. constraint. ;;; All this lossage will go away when ct_load is re-written to keep ;;; paths as lists of tokens instead of as strings. (let* ((p (nreverse (exploden path))) (q (member #// p)) (fil (ldiff p q)) (xplod (reverse (exploden strng)))) (cond ((ct_load_probef (string (maknam (reverse (append xplod q))))) (string (maknam (nreverse (append fil '(#//) xplod q)))))))) ) (defun ct_load_symbol_check (sym) (cond ((and sym (symbolp sym)) sym) (t (ct_load_err 'ct_load_symbol_check 'wrong_type_argument sym nil) nil))) ; The following three functions were added to allow files with ct_loads to ; reference each other in a circular fashion without looping forever. To cure ; the problem we mark the ct_load symbol as a load in progress as soon as we ; start loading it. The mark is checked each time we try to load the file again ; to prevent a recursive load. The mark is removed when the file is successfully ; loaded. (defun ct_load_mark_in_progress (sym) (putprop sym t 'ct_load_in_progress) ) (defun ct_load_in_progressp (sym) (get sym 'ct_load_in_progress) ) (defun ct_load_mark_done (sym) (remprop sym 'ct_load_in_progress) ) ;;; We shouldn't HAVE to do this sstatus, but flavors aren't in by dflt: (eval-when (compile load eval) ;; ++ (cond ;; [We have flavors in both dialects -- ((not (status feature flavors)) ;; But ct_load_int CHECKS, as it should.] (sstatus feature flavors)))) (defun ct_load_int (sym fun path) ;;; Internal-only to ct_load and ct_reload. ;;; Second arg is name of caller, for whether to force reloading, ;;; even if already done, and for error messages. ;;; Third arg is an internal aux var for the path (initially nil). (and (ct_load_symbol_check sym) (cond (*ct_load_disabled* nil) ((ct_load_in_progressp sym) (cond ((or (not *ct_load_circular*) (status feature debugging)) (princ "Ct_load circular dependancy, a ct_load on ") (princ sym) (princ " is already in progress.") (terpri))) nil); wab ((and (eq fun 'ct_load) (status_feature sym)) nil) ((or (null (setq path (ct_load_get sym))) (not (or (stringp path) (symbolp path))) (equal path "nil")) (ct_load_err fun 'illegal_or_missing_path sym path)) ((not (ct_load_probef path)) ;;++ See notes on next page re. this CT_LOAD_PROBEF. (ct_load_err fun 'file_not_found sym path)) ;; Maybe someday make the load function more extensible++ ((errset #+(and franz unix flavors) ;; Assumes flavors always there (let ((pretrans (status translink))) ;;; Maybe unsnap links around this load operation. (unwind-protect (progn (ct_load_mark_in_progress sym); wab (cond ((and pretrans (eq fun 'ct_reload)) (sstatus translink nil))) (apply (function load1) (cons (maybe_remove_dot_o path) (maybe_ignore_if_dot_l path *ct_load_dflts*)))) (progn (ct_load_mark_done sym); WAB (and (eq fun 'ct_reload) (cond ((eq pretrans 'on) (sstatus translink on)) (pretrans (sstatus translink t))))))) #+lispm (unwind-protect ; wab (progn ; wab (ct_load_mark_in_progress sym); wab (apply (function load) (cons path *ct_load_dflts*))) (ct_load_mark_done sym)); wab (status feature debugging)) ;; Else suppress msgs (sstatus_feature sym) path) (t (ct_load_err fun 'problem_during_loading sym path))))) (defun ct_load_probef (file) (car (errset (probef file) nil))) (defun ct_load_check_for_ct_dir (path) ;;; Given a pathname string, checks if it begins with "!/ct!/". ;;; Has to ignore a possible hostname at the front. #+lispm (or (string-equal path "ctvax://ct//" 0 0 10. 10.) (string-equal path "vax://ct//" 0 0 8. 8.)) #+franz (and (eq (nthchar path 1) '!/ ) (eq (nthchar path 2) '!c ) (eq (nthchar path 3) '!t ) (eq (nthchar path 4) '!/ ))) ;;; This is designed to remove the ".o" from a filename because ;;; Franz's LOAD1 function loses (badly) if you leave it in. #+(and franz unix) (defun maybe_remove_dot_o (path) (cond ((and (eq (nthchar path -1) '!o) (eq (nthchar path -2) '!.)) (implode (nreverse (cddr (nreverse (exploden path)))))) (t path))) ;;; Maryland loses. Load1 is stupid enough that if you give it ;;; fasl-args in addition to the file name, it fasls the file ;;; regardless of filetype. #+(and franz unix) (defun maybe_ignore_if_dot_l (path frob) (cond ((and (eq (nthchar path -1) '!l) (eq (nthchar path -2) '!.)) nil) (t frob))) (defun ct_load_err (fun errtyp sym path) ;;; Internal-only error message handler for ct_load_xxx. (cond ((status feature debugging) (terpri) (princ "ERROR within ") (princ fun) (princ " -- ") (princ errtyp) (princ ".") (terpri) (princ " CT Symbolic Name (e.g., fn1) for File : ") (prin1 sym) (terpri) (princ " Path String Found on CT_Load Property : ") (prin1 path) (terpri) (break #+Franz ct_load_err #+lispm "ct_load_err" t)) ((status feature compat) ;; Ie, is LOSE defined yet? (lose errtyp 'ct_load_err `("File IO Error involving ~A." ,sym) `("Error within ~A -- ~A.~% CT Symbolic Name for File: ~S~% Path String Found on CT_Load Property: ~S~%" ,fun ,errtyp ,sym ,path))) (t (terpri) (princ "File IO Error involving ") (princ sym) (terpri))) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sstatus_feature 'ctload) ; So won't load SELF twice! ;;; Load an initial default filemap from an initial default place. ;;; Harmless because you can override with your own afterwards. ;;; Helpful, because you get "the standard installed world" for free. ;;; Notice the use of "!" to escape "/". (eval-when (eval compile load) #+LMI-using-Angel (fs:set-logical-pathname-host "CT" :physical-host "ANGEL" :translations '(("CT;" "//usr//ct//") ("*;*;*;*;" "//usr//ct//*//*//*//*//") ("*;*;*;" "//usr//ct//*//*//*//") ("*;*;" "//usr//ct//*//*//") ("*;" "//usr//ct//*//latest//"))) #| ;;; Previous version -- commented out by mlm on 8/19/85 #+LMI ;-using-LAM6 (fs:set-logical-pathname-host "CT" :physical-host "LAMA" :translations '(("CT;" "") ("*;*;*;*;" "*.*.*.*;") ("*;*;*;" "*.*.*;") ("*;*;" "*.*;") ("*;" "*.latest;"))) |# #+lmi ;-GJC's new version, enterred by mlm on 8/19/85 ;;; clever self referential host hack (let ((host (send fs:fdefine-file-pathname :host))) (if (typep host 'fs:logical-host) (setq host (send host :host))) (format t "~&Setting CT physical host to ~A." host) (fs:set-logical-pathname-host "CT" :physical-host host :translations '(("ADA;" "CT-ADA.ADA;") ;Ada programs ("BROWSER;" "CT-ADA.BROWSER;") ;Doc browser system ("BUILD;" "CT-ADA.BUILD;") ;System building tools ("CT;" "CT-ADA.CT;") ;Temporary files ("CTLISP;" "CT-ADA.CTLISP;") ;Lisp compatibility files ("DEBUG;" "CT-ADA.DEBUG;") ;Debugger ("DOC;" "CT-ADA.DOC;") ;Documentation for browser ("DOC; *;" "CT-ADA.DOC.*;") ;Doc subdirectories ("EDITOR;" "CT-ADA.EDITOR;") ;Zwei Ada mode ("GRAPH;" "CT-ADA.GRAPH;") ;Graph editor ("INTERP;" "CT-ADA.INTERP;") ;Ada interpreter ("LMFONTS;" "CT-ADA.LMFONTS;") ;Additional fonts ("TOOLS;" "CT-ADA.TOOLS;") ;Random tools ("WINDOW;" "CT-ADA.WINDOW;") ;Window enhancements ))) ) ; END eval-when (cond ((status nofeature inhibit_default_filemap) (ct_load_def filemap #+cadr "ctvax:!/ct!/ctlisp!/filemaps!/filemap.qb" #+(and 3600 (not local_build)) "ctvax:!/ct!/ctlisp!/filemaps!/filemap.bn" #+LMI-last-august "CT: CTLISP; FILEMAPS; filemap.qfasl" #+LMI "CT: CTLISP; filemap.qfasl" #+local_build "local:>ct>ctlisp>filemaps>filemap.bin" #+(and franz unix) "!/ct!/ctlisp!/filemaps!/filemap.o") (ct_load 'filemap))) ;;; The following is a new hook to allow, eg., MAKE to append a ;;; subdirectory like "frozen" or "current" to the pathname. ;;; MAKE should create a file ct_load.user containing a setq of ;;; *ct_load_subdir*. (The default value is "".) #+(and franz unix) (setq user-id (getenv 'USER)) #-local_build (let ((temp #+lispm (string-append "ctvax:!/ct!/ctlisp!/ct_load." ;;; (login 'penny) -> "PENNY" (sigh) so: (string-downcase user-id)) #+(and franz unix) (string (concat "!/ct!/ctlisp!/ct_load." user-id)))) (ct_load_put 'ct_load_subdir_hook temp) (cond ((ct_load_probef temp) (load temp) (sstatus_feature 'ct_load_subdir_hook)))) ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;