diff --git a/contrib/logical-pathnames.ecl b/contrib/logical-pathnames.ecl deleted file mode 100644 index dbc028eb3..000000000 --- a/contrib/logical-pathnames.ecl +++ /dev/null @@ -1,1951 +0,0 @@ -;;; -*- Mode: LISP; Package: LOGICAL-PATHNAME; Syntax: Common-lisp; -*- -;;; Tue Apr 9 19:17:01 1991 by Mark Kantrowitz -;;; logical-pathnames.lisp - -;;; **************************************************************** -;;; Logical Pathnames System *************************************** -;;; **************************************************************** -;;; -;;; Logical Pathnames provide a facility for referring to pathnames -;;; in a portable manner. Logical pathnames are mapped to physical -;;; pathnames by a set of implementation dependent and site-dependent -;;; rules. -;;; -;;; This system is a Common Lisp portable implementation of logical -;;; pathnames. It fulfills most of the X3J13 June 1989 specification -;;; for logical pathnames, as documented in Guy Steele's "Common Lisp: -;;; The Language" (2nd Edition), section 23.1.5 "Logical Pathnames". -;;; -;;; Written by Mark Kantrowitz, July 1990. -;;; -;;; Address: Carnegie Mellon University -;;; School of Computer Science -;;; Pittsburgh, PA 15213 -;;; -;;; This code is in the public domain and is distributed without warranty -;;; of any kind. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted, so long as the following -;;; conditions are met: -;;; o no fees or compensation are charged for use, copies, or -;;; access to this software -;;; o this copyright notice is included intact. -;;; This software is made available AS IS, and no warranty is made about -;;; the software or its performance. -;;; -;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. -;;; -;;; -;;; Logical Pathnames are especially useful when coupled with a portable -;;; system construction tool, such as the Defsystem facility written -;;; by Mark Kantrowitz. -;;; - -;;; ******************************** -;;; Change Log ********************* -;;; ******************************** -;;; -;;; djc = Daniel J. Clancy -;;; -;;; 30-JUL-90 mk Fixed logical pathnames for VAX-LISP (thanks to -;;; Paul Werkowski). In VAX-LISP simple strings are not -;;; sub-types of simple-vectors, so svref doesn't work -;;; on strings. These calls have been fixed to read -;;; #+:cmu svref #-:cmu aref. -;;; 15-NOV-90 mk Changed convert-file-function to better handle optional -;;; args. This should fix the problem of (ed) and (dribble) -;;; returning errors like "argument NIL must be a number" -;;; in parse-namestring. Note that some lisps seem to make -;;; a distinction between (funcall #'foo) and (foo) with -;;; respect to this error. -;;; 29-JAN-91 mk Defined LISP:NTH-VALUE if not already present (it is -;;; a CLtL2 addition) and used it in LOAD-PHYSICAL-HOSTAB -;;; to avoid needing a GARBAGE variable in -;;; (multiple-value-setq (garbage pos) ...) which we can -;;; not declare ignore and yet causes a compiler warning -;;; since we don't use it. -;;; 29-JAN-91 mk lisp::file-name is particular to CMU Common Lisp -;;; and the #+:cmu's were accidentally left off. -;;; 29-JAN-91 mk Added :explorer physical namestring output to -;;; PHYSICAL-NAMESTRING. -;;; 29-JAN-91 mk Warns about name collisions between physical and logical -;;; host names. -;;; 30-JAN-91 mk Added :logical-pathnames-mk to the *features* list. -;;; 25-FEB-91 mk Added definition of LOAD-LOGICAL-PATHNAME-TRANSLATIONS. -;;; 09-APR-91 mk Export pathname-host-type, append-logical-directories. -;;; 09-APR-91 mk Translation rules now support :case :unchanged. -;;; 09-APR-91 djc Fixed so that (logical-pathname "") returns a -;;; logical-pathname structure. -;;; 21-FEB-96 attardi -;;; Added support for ECL - -;;; ******************************** -;;; To Do ************************** -;;; ******************************** -;;; -;;; Support for Macintosh pathnames. Little tricky, since MACL uses a -;;; colon (:) as the delimiter. -;;; -;;; support for tops-20/tenex, multics, its, ms-dos -;;; add host-type to pathnames -;;; merge-pathnames, with-open-file -;;; -;;; Define generic pathname parsing/printing definition interface. -;;; -;;; Redefine with-open-file? -;;; -;;; Port to emacs-lisp for gnu-emacs? -;;; -;;; Logical pathnames needs to case both on the physical host type and on -;;; lisp type (e.g., for canonicalization). Fix this, and define lots of -;;; canonical types. Dependency on lisp type can probably be handled using -;;; #+ and #-. What about conflicts between canonicalization and the -;;; translations (e.g., "L" vs :lisp)? -;;; - -;;; ******************************** -;;; Notes ************************** -;;; ******************************** -;;; -;;; LOGICAL-PATHNAMES has been tested (successfully) in the following lisps: -;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) -;;; Macintosh Allegro Common Lisp (1.3.2) -;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) -;;; Lucid CL (Version 2.1 6-DEC-87) -;;; Symbolics Common Lisp (8.0) -;;; Lucid Common Lisp (3.0, 4.0) -;;; VAXLisp (2.0, 3.1) -;;; ECL (ECoLisp) Version(0.23) -;;; -;;; LOGICAL-PATHNAMES needs to be tested in the following lisps: -;;; KCL (June 3, 1987 or later) -;;; AKCL (1.86, June 30, 1987 or later) -;;; TI (Release 4.1 or later) -;;; Ibuki Common Lisp (01/01, October 15, 1987) -;;; Golden Common Lisp (3.1 IBM-PC) -;;; HP Common Lisp (same as Lucid?) -;;; Procyon Common Lisp - - -;;; ******************************** -;;; Documentation ****************** -;;; ******************************** -;;; -;;; Logical pathnames allow large programs to be moved between sites -;;; by separating pathname reference from actual file location. The -;;; program will refer to files using logical pathnames. At each site, -;;; a user will specify a set of "translations" which map from the logical -;;; pathnames to the physical pathnames used on the device. -;;; -;;; Logical pathnames provide a uniform convention for filesystem access, -;;; with the following properties: -;;; 1. Pathname Portability: The program specifies a pathname in -;;; a conventional format (logical pathnames), which may be -;;; mapped reasonably literally (via the translations) to -;;; a variety of filesystems. -;;; 2. Pathname Aliasing: The files may exist in different locations -;;; in the various filesystems. For example, the root directory -;;; might change. The translations allow such a change easily. -;;; 3. Cross-host Access: The files need not all exist on the same -;;; physical host. -;;; -;;; This definition of logical pathnames provides support for physical -;;; pathnames for Unix, VMS/VAX, Symbolics, and TI Explorers, and is -;;; easily extended to handle additional platforms. Code which may need -;;; customization for particular Lisps and platforms has been commented -;;; with three ampersands (&&&). In addition, the user probably should -;;; define their own canonical types, translation rules, and -;;; logical-pathname-translations. Examples are provided. -;;; -;;; Logical pathnames employ the following syntax: -;;; [host:] [;] {directory ;}* [name] [. type [. version]] -;;; host ::= word -;;; directory ::= word | wildcard-word | wildcard-inferiors -;;; name ::= word | wildcard-word -;;; type ::= word | wildcard-word -;;; version ::= word | wildcard-word -;;; word ::= {letter | digit | -}* -;;; wildcard-word ::= [word] * {word *}* [word] -;;; wildcard-inferiors ::= ** -;;; -;;; A wildcard-word of * parses as :wild; all others as strings. These -;;; definitions may be extended (e.g., "newest" parsing as :newest) by -;;; defining new canonical types. -;;; -;;; Incompatibilities with the X3J13 specification: -;;; - LOGICAL-PATHNAME is not defined as a subclass of PATHNAME -;;; since we have no guarrantee about the format of PATHNAME -;;; (i.e., is it a defstruct or a class definition, what are -;;; its slots, etc.). Many Lisps will be able to replace the -;;; definition of PHYSICAL-PATHNAME with their definition of -;;; PATHNAME by doing a string-replace of "physical-pathname" -;;; with "pathname" and deleting some definitions from this file. -;;; - CLtL does not specify the manner in which wildcards are -;;; translated. We use reversible wildcard pathname translation, -;;; similar to that used in the Symbolics logical pathnames. -;;; - COMPILE-FILE-PATHNAME has not been defined, since it is -;;; highly implementation dependent. - -;;; ******************************** -;;; Examples *********************** -;;; ******************************** -;;; -;;; The following examples of the use of logical pathnames are taken -;;; from Section 23.1.5.4 of Guy Steele CLtL 2nd Ed. - -#| -(setf (lp:physical-host-type "MY-LISPM") :symbolics) -(setf (lp:logical-pathname-translations "foo") - '(("**;*.*.*" "MY-LISPM:>library>foo>**>"))) - - (lp:translate-logical-pathname "foo:bar;baz;mum.quux.3" :namestring) -"MY-LISPM:>library>foo>bar>baz>mum.quux.3" - -(setf (lp:physical-host-type "U") :unix) -(setf (lp:physical-host-type "V") :vms) -(setf (lp:logical-pathname-translations "prog") - '(("RELEASED;*.*.*" "U:/sys/bin/my-prog/") - ("RELEASED;*;*.*.*" "U:/sys/bin/my-prog/*/") - ("EXPERIMENTAL;*.*.*" "U:/usr/Joe/development/prog/") - ("EXPERIMENTAL;DOCUMENTATION;*.*.*" "V:SYS$DISK:[JOE.DOC]") - ("EXPERIMENTAL;*;*.*.*" "U:/usr/Joe/development/prog/*/") - ("MAIL;**;*.MAIL" "V:SYS$DISK:[JOE.MAIL.PROG...]*.MBX"))) - - (lp:translate-logical-pathname "prog:mail;save;ideas.mail.3" :namestring) -"V:SYS$DISK:[JOE.MAIL.PROG.SAVE]IDEAS.MBX.3" - (lp:translate-logical-pathname "prog:experimental;spreadsheet.c" :namestring) -"U:/usr/Joe/development/prog/spreadsheet.c" - -(setf (lp:logical-pathname-translations "prog") - '(("CODE;*.*.*" "/lib/prog/"))) - (lp:translate-logical-pathname "prog:code;documentation.lisp" :namestring) -"/lib/prog/documentation.lisp" - -(setf (lp:logical-pathname-translations "prog") - '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*") - ("CODE;*.*.*" "/lib/prog/"))) - (lp:translate-logical-pathname "prog:code;documentation.lisp" :namestring) -"/lib/prog/docum.lisp" - - -(setf (lp:logical-pathname-translations "prog") - `(("**;*.LISP.*" ,(lp:logical-pathname "PROG:**;*.L.*")) - ("**;*.FASL.*" ,(lp:logical-pathname "PROG:**;*.B.*")) - ("CODE;DOCUMENTATION.*.*" "/lib/prog/documentatio.*") - ("CODE;*.*.*" "/lib/prog/"))) - (lp:translate-logical-pathname "prog:code;documentation.lisp" :namestring) -"/lib/prog/documentatio.l" - -|# - -;;; **************************************************************** -;;; Logical Pathnames ********************************************** -;;; **************************************************************** -;;; Putting this in a separate package doesn't prevent collisions -;;; with the LISP package, since this package :uses the LISP -;;; package. -(in-package "LOGICAL-PATHNAME" :nicknames '("LP")) - -(export '(logical-pathname - translate-logical-pathname - logical-pathname-translations - pathname-host-type - append-logical-directories - make-logical-pathname - physical-host-type - load-logical-pathname-translations - load-physical-hostab - define-translation-rule - define-canonical)) - -(pushnew :logical-pathnames-mk *features*) - -;;; ******************************** -;;; Global Variables *************** -;;; ******************************** -(defvar *null-vector* (coerce nil 'simple-vector)) - -(defvar *warn-about-host-type-collisions* t - "Warn user when a logical host type definition collides with a physical - host type definition.") - -;;; ******************************** -;;; Primitives ********************* -;;; ******************************** -(defun parse-with-string-delimiter (delim string &key (start 0) end) - "Returns up to three values: the string up to the delimiter DELIM - in STRING (or NIL if the field is empty), the position of the beginning - of the rest of the string after the delimiter, and a value which, if - non-NIL (:delim-not-found), specifies that the delimiter was not found." - (declare (simple-string string)) - ;; Conceivably, if DELIM is a string consisting of a single character, - ;; we could do this more efficiently using POSITION instead of SEARCH. - ;; However, any good implementation of SEARCH should optimize for that - ;; case, so nothing to worry about. - (setq end (or end (length string))) - (let ((delim-pos (search delim string :start2 start :end2 end)) - (dlength (length delim))) - (cond ((null delim-pos) - ;; No delimiter was found. Return the rest of the string, - ;; the end of the string, and :delim-not-found. - (values (subseq string start end) end :delim-not-found)) - ((= delim-pos start) - ;; The field was empty, so return nil and skip over the delimiter. - (values nil (+ start dlength))) - ;; The following clause is subsumed by the last cond clause, - ;; and hence should probably be eliminated. -; ((= delim-pos (- end dlength)) -; ;; The delimiter is at the end of the string, so return the -; ;; field and skip to the end. -; (values (subseq string start delim-pos) -; end)) - (t - ;; The delimiter is in the middle of the string. Return the - ;; field and skip over the delimiter. - (values (subseq string start delim-pos) - (+ delim-pos dlength)))))) - -(defun parse-with-string-delimiter* (delim string &key (start 0) end - include-last) - "Breaks STRING into a list of strings, each of which was separated - from the previous by DELIM. If INCLUDE-LAST is nil (the default), - will not include the last string if it wasn't followed by DELIM - (i.e., \"foo,bar,\" vs \"foo,bar\"). Otherwise includes it even if - not terminated by DELIM. Also returns the final position in the string." - (declare (simple-string string)) - (setq end (or end (length string))) - (let (result) - (loop - (if (< start end) - (multiple-value-bind (component new-start delim-not-found) - (parse-with-string-delimiter delim string :start start :end end) - (when delim-not-found - (when include-last - (setq start new-start) - (push component result)) - (return)) - (setq start new-start) - (push component result)) - (return))) - (values (nreverse result) - start))) - -(defun get-host-string (string &optional (host-delimiter ":") (start 0) end) - "Strips the host name off the front of the string." - (setq end (or end (length string))) - (multiple-value-bind (host pos delim-not-found) - (parse-with-string-delimiter host-delimiter string :start start :end end) - (if delim-not-found - (values nil start) - (values host pos)))) - -(defun parallel-substitute (alist string) - "Makes substitutions for characters in STRING according to the ALIST. - In effect, PARALLEL-SUBSTITUTE can perform several SUBSTITUTE - operations simultaneously." - (declare (simple-string string)) - ;; This function should be generalized to arbitrary sequences and - ;; have an arglist (alist sequence &key from-end (test #'eql) test-not - ;; (start 0) (count most-positive-fixnum) end key). - (if alist - (let* ((length (length string)) - (result (make-string length))) - (declare (simple-string result)) - (dotimes (i length) - (let ((old-char (schar string i))) - (setf (schar result i) - (or (second (assoc old-char alist :test #'char=)) - old-char)))) - result) - string)) - -(defun name-substitution (alist string) - "Replaces STRING by it's replacement in ALIST, if present." - (let ((new-string (second (assoc string alist :test #'string-equal)))) - (or new-string string))) - -(unless (fboundp 'lisp::nth-value) - ;; NTH-VALUE is a CLtL2 addition, so not every lisp has it yet. - ;; This definition conses a lot, so we shouldn't use it in time-critical - ;; situations. It is fine for load-physical-hostab which is the only - ;; place we use it. - (defmacro lisp::nth-value (n form) - "Returns the nth value of the values returned by form." - `(nth ,n (multiple-value-list ,form))) - (export 'lisp::nth-value "LISP")) - -;;; ******************************** -;;; Logical Host Tables ************ -;;; ******************************** -(defvar *logical-pathname-translations-table* (make-hash-table :test #'equal)) -(defun canonicalize-logical-hostname (host) - (string-upcase host)) -(defun LOGICAL-PATHNAME-TRANSLATIONS (host) - "If HOST is the host component of a logical pathname and has been defined - as a logical pathname host name by SETF of LOGICAL-PATHNAME-TRANSLATIONS, - this function returns the list of translations for the specified HOST. - Each translation is a list of at least two elements, a from-wildname - and a to-wildname. The former is a logical pathname whose host is the - specified HOST. (I.e., the host of the from-pathname need not be - explicitly specified.) The latter is any pathname. If to-wildname coerces to - a logical pathname, TRANSLATE-LOGICAL-PATHNAME will retranslate the - result, repeatedly if necessary. Translations are listed in - the order listed, so more specific from-wildnames must precede more - general ones." - ;; would be nice to have host:: specify logical host if physical host - ;; already exists, to distinguish from host: - (gethash (canonicalize-logical-hostname host) - *logical-pathname-translations-table*)) -(defsetf logical-pathname-translations (host) (translations) - "(setf (logical-pathname-translations host) translations) sets the list - of translations for the logical pathname host to translations. If host - is a string that has not previously been used as a logical pathname - host, a new logical pathname host is defined; otherwise an existing - host's translations are replaced. Logical pathname host names are - compared with string-equal." - `(progn - (when (and *warn-about-host-type-collisions* - (physical-host-type ,host)) - (format t "~&Warning in (SETF LOGICAL-PATHNAME-TRANSLATIONS):~ - ~& ~S is defined as both a physical host and a logical host." - ,host)) - (setf (gethash (canonicalize-logical-hostname ,host) - *logical-pathname-translations-table*) - (eval-translations ,translations)))) - -;;; EVAL-TRANSLATIONS -;; -;;; Will receive a list of translations and it will evaluate the physical -;;; translation if it is not a string. This allows the user to put a format -;;; statement as the physical-translation. - -(defun eval-translations (translations) - (let (new_trans) - (nreverse - (dolist (translation translations new_trans) - (if (stringp (cadr translation)) - (setf new_trans (cons translation new_trans)) - (setf new_trans (cons (list (car translation) (eval (cadr translation))) new_trans))))))) - -;;; ******************************** -;;; Load Logical Translations ****** -;;; ******************************** -(defvar *logical-translations-directory* nil ; &&& - "Directory where logical pathname translations are stored.") -;;; (setq *logical-translations-directory* "/usr/local/lisp/Registry/") - -(defun LOAD-LOGICAL-PATHNAME-TRANSLATIONS (host) - "Loads the logical pathname translations for host named HOST if the logical - pathname translations are not already defined. First checks for a file - with the same name as the host (lowercase) and type \"translations\" in - the current directory, then the translations directory. If it finds such - a file it loads it and returns T, otherwise it signals an error." - (unless (logical-pathname-translations host) - (let* ((trans-fname (concatenate 'string (string-downcase host) - ".translations")) - (pathname (when *logical-translations-directory* - (merge-pathnames *logical-translations-directory* - trans-fname)))) - (cond ((probe-file trans-fname) - (load trans-fname) - t) - ((and *logical-translations-directory* - (probe-file pathname)) - (load pathname) - t) - (t - (error "Logical pathname translations for host ~A not found." - host)))))) - -;;; ******************************** -;;; Physical Host Tables *********** -;;; ******************************** -(defvar *physical-host-table* (make-hash-table :test #'equal) - "Table of physical hosts and system types for those hosts. - Valid (implemented) types include :vms, :explorer, :symbolics, :unix.") -(defun physical-host-type (host) - (gethash host *physical-host-table*)) -(defsetf physical-host-type (host) (type) - `(progn - (when (and *warn-about-host-type-collisions* - (logical-pathname-translations ,host)) - (format t "~&Warning in (SETF PHYSICAL-HOST-TYPE):~ - ~& ~S is defined as both a physical host and a logical host." - ,host)) - (setf (gethash ,host *physical-host-table*) - ,type))) - -(defconstant local-host-table ; &&& - #+:vms "chaos$root:[host.tables]nethosts.txt" - #-:vms "nethosts.txt") - -(defun load-physical-hostab (&optional (local-hostab local-host-table)) - "Loads the physical host namespace table. This is compatible with - vms and symbolics host tables. Hostab line format should look - something like: - HOST NAME,CHAOS-#,STATUS,SYSTEM-TYPE,MACHINE-TYPE,NICKNAMES - NAME and SYSTEM-TYPE are required; all others are optional (but delimiting - commas are still required). SYSTEM-TYPE specifies the operating system - run on the host. This information is used to figure out how to parse - pathnames for the host. Common values are: LISP, LISPM, UNIX, MACH, - VMS, and EXPLORER." - ;; What about SITE, SHORT-NAME, USER-PROPERTY, ADDRESS, PRETTY-NAME, - ;; and other Symbolics host attributes? - (when local-hostab - (with-open-file (hostab local-hostab :direction :input) - (do* ((host (read hostab nil :eof)(read hostab nil :eof)) - ;; host should be NET or HOST. - (line (read-line hostab nil :eof)(read-line hostab nil :eof))) - ;; Exit on end of file. - ((or (eq host :eof)(eq line :eof))) - ;; For each line in the host table, do - (cond ((null line) - (warn "Unexpected EOF in hostab ~S, exiting." local-hostab) - (return)) - ((string-equal (symbol-name host) "HOST") - ;; Delete spaces and tabs. - (setq line (delete #\tab (delete #\space line))) - (let ((pos 0) name system machine nicknames delim-not-found) - ;; Snarf the machine NAME. - (multiple-value-setq (name pos) - (parse-with-string-delimiter "," line :start pos)) - ;; Throw away chaos host numbers. - (setq pos - (nth-value 1 (parse-with-string-delimiter - (if (char-equal #\( (char line pos)) - ")," ",") - line :start pos))) - ;; Throw away status. - (setq pos - (nth-value 1 (parse-with-string-delimiter "," line - :start pos))) - ;; Snarf the system and machine types. - (multiple-value-setq (system pos) - (parse-with-string-delimiter "," line :start pos)) - (multiple-value-setq (machine pos delim-not-found) - (parse-with-string-delimiter "," line :start pos)) - (when (and (not delim-not-found) - (> (length line) pos)) - ;; Snarf the nicknames. - (setq nicknames - (parse-with-string-delimiter* - "," - (parse-with-string-delimiter "]" line - :start (1+ pos))))) - (unless (or (equal "" system) (null system)) - (when (equal "LISP" system) (setq system machine)) - (setq system (intern system 'keyword)) - (case system - ;; :vms, :ms-dos, etc are left alone. - ((:mach :unix :unix42) (setq system :unix)) - ((:lisp :lispm) (setq system :symbolics)) - ((:appaloosa :explorer) (setq system :explorer))) - (setf (physical-host-type name) system) - (dolist (name nicknames) - (setf (physical-host-type name) system)))))))))) - -(defun host-type (host) - "Returns the type of the host. If HOST is a defined logical pathname - host (i.e., it has translations), returns :logical. Otherwise checks - the physical type of the host. If HOST is NIL, uses the type of the - default physical host (the one lisp is running in)." - ;; Note that logical hosts have priority over physical hosts... - ;; This is a bad situation, since we don't have any way of - ;; distinguishing between host names that are both logical and physical. - ;; CLtL2 relies on the convention of naming them differently, but - ;; collisions are going to occur. It would be better to have some - ;; way of distinguishing the two in a pathname's printed representation. - (cond ((multiple-value-bind (ignore present) - (logical-pathname-translations host) - ;; Yet another use for nth-value. - (declare (ignore ignore)) - present) - :logical) - ((physical-host-type host)))) - -(defun pathname-host-type (pathname) - (cond ((typep pathname 'logical-pathname) :logical) - ((typep pathname 'pathname) - (host-type (pathname-host pathname))) - ((stringp pathname) (host-type (get-host-string pathname ":"))))) - -;;; Setup Default Physical Host -(eval-when (load eval) ; &&& -(setf (physical-host-type nil) ; nil is default host - (or #+:vms :vms - #+:explorer :explorer - #+:symbolics :symbolics - #+:unix :unix - #+:hp :unix - #+:cmu :unix - :unix ; default. change if necessary - )) -(setf (physical-host-type "Default") - (physical-host-type nil)) -) - -;;; ******************************** -;;; Translation Rules ************** -;;; ******************************** -(defstruct translation-rule - host-type - case ; Default case of pathname - char-mappings ; Character substitutions - component-mappings ; String substitutions - version-case ; Case for version component - type-case ; Case for type component - name-case ; Case for name - component-case ; Case for directory names - ) - -(defvar *permanent-translation-rules* (make-hash-table :test #'equal) - "Hash table of default translation rules for each type of host.") - -(defvar *default-translation-rule* (make-translation-rule)) - -(defmacro define-translation-rule (host-type - &key case char-mappings component-mappings - version-case - type-case - name-case - component-case) - "Defines translation rules for hosts of type host-type. - Case may be :unchanged, :upper, :lower, or :capitalize. This provides a - default case translation; version-case, type-case, name-case, and - component-case will shadow this value if non-nil. - Char-mappings is a list of character substitutions which occur in parallel. - Component-mappings is a list of string substitutions." - ;; Note: Currently there is only one rule per host-type. - `(setf (gethash ,host-type *permanent-translation-rules*) - (make-translation-rule :host-type ',host-type - :case ',case - :char-mappings ',char-mappings - :component-mappings ',component-mappings - :version-case ',version-case - :type-case ',type-case - :name-case ',name-case - :component-case ',component-case))) - -(defun find-translation-rule (host-type) - (or (gethash host-type *permanent-translation-rules*) - *default-translation-rule*)) - -(defun choose-case (rule level) - (or (case level - (version (translation-rule-version-case rule)) - (type (translation-rule-type-case rule)) - (name (translation-rule-name-case rule)) - (component (translation-rule-component-case rule))) - (translation-rule-case rule))) - -(defun casify (thing case) - (if (stringp thing) - (case case - (:upper (string-upcase thing)) - (:lower (string-downcase thing)) - (:capitalize (string-capitalize thing)) - (:unchanged thing) - (otherwise thing)) - thing)) - -(define-translation-rule :vms - :case :upper :char-mappings ((#\- #\_))) - -(define-translation-rule :unix - :case :unchanged ; :lower - :type-case :lower - ) - -(define-translation-rule :logical - :case :upper - :name-case :unchanged) - -;;; ******************************** -;;; Canonical Types **************** -;;; ******************************** -(defvar *default-canonical-types* (make-hash-table :test #'equal) - "Alists of canonical types and default surface types.") -(defvar *canonical-types-alist* (make-hash-table :test #'equal) - "Alists of canonical types and surface types for various hosts.") - -(defmacro define-canonical (level canonical default &body specs) - "Defines a new canonical type. Level specifies whether it is a - canonical type, version, name, or component. Default is a string - containing the default surface type for any kind of host not - mentioned explicitly. The body contains a list of specs that define - the surface types that indicate the new canonical type for each host. - For systems with more than one possible default surface form, - the form that appears first becomes the preferred form for the type." - `(progn - (setf (gethash ',level *default-canonical-types*) - (cons (list ',canonical ',default) - (remove ',canonical - (gethash ',level *default-canonical-types*) - :key #'car))) -; (push (list ',canonical ',default) -; (gethash ',level *default-canonical-types*)) - (setf (gethash ',level *canonical-types-alist*) - (cons (list* ',canonical ',specs) - (remove ',canonical - (gethash ',level *canonical-types-alist*) - :key #'car))) -; (push (list* ',canonical ',specs) -; (gethash ',level *canonical-types-alist*)) - )) - -(defun member-or-eq (x list-or-atom) - (cond ((listp list-or-atom) (member x list-or-atom)) - (t (eq x list-or-atom)))) - -(defun surface-form (canonical host-type &optional (level 'type)) - "Given the canonical form of some canonical type, replaces it with - the appropriate surface form." - (let ((case (choose-case (find-translation-rule host-type) level))) - (casify (or (second (assoc host-type - (cdr (assoc canonical - (gethash level - *canonical-types-alist*) - :test #'equal)) - :test #'member-or-eq)) - (second (assoc canonical - (gethash level *default-canonical-types*) - :test #'equal)) - canonical) - case))) - -(defun canonicalize (surface-form host-type &optional (level 'type)) - "Given the surface form of some canonical type, replaces it with - the appropriate canonical type." - (cond ((stringp surface-form) - (or (first (find surface-form (gethash level *canonical-types-alist*) - :key #'cdr - :test #'(lambda (surf alist) - (member surf - (cdr (assoc host-type alist - :test #'member-or-eq)) - :test #'string-equal)))) - (first (find surface-form - (gethash level *default-canonical-types*) - :key #'second :test #'string-equal)) - (coerce surface-form 'simple-string))) - (t surface-form))) - - -;;; *** Some Sample Types *** - -(define-canonical host :default "" - (:unix #+:CMU "Mach" "" "Default")) - -(define-canonical host "Default" "" - (:unix nil "" "Default")) - -(define-canonical device :unspecific "") - -(define-canonical component :absolute "" - (:unix "/") - (:symbolics ">") - (:logical "") - (:vms "")) -(define-canonical component :relative "" - (:unix "") - (:symbolics "") - (:logical ";") - (:vms ".")) -(define-canonical component :wild "*") -(define-canonical component :wild-inferiors "**" - (:vms "..")) - -(define-canonical name :wild "*") - -(define-canonical type :unspecific "") ;; null type -(define-canonical type :wild "*") ;; wild type - -;; uncommented the "L" causes the last Steele example to break, of course. -(define-canonical type :lisp "LISP" - (:unix-ucb "LISP") - (:unix #+(and :sun :kcl :unix) "lsp" - #+ecl "lsp" - "lisp" ; "L" #+:excl "cl" -) - (:vms "LSP" "LISP") - ;; (:vms4 "LSP" "LISP") - ((:tops-20 :tenex) "LISP" "LSP")) - -(define-canonical type :text "TEXT" - (:unix "text" "txt" "tx") - (:vms "TXT") - ((:tops-20 :tenex) "TXT")) - -(define-canonical type :fasl "FASL" - (:unix #+:hp "b" - #+(and :sun :kcl :unix) "o" - #+ecl "o" - #+:cmu "fasl" - "fasl" "bin" "BN") - (:vms "FAS" "BIN") - (:explorer "XLD") - (:symbolics "BIN") - ((:tops-20 :tenex) "BIN")) - -(define-canonical version :wild "*") -(define-canonical version :newest "newest") - -#| -;;; Examples: - (lp::canonicalize "*" :unix) -:WILD - (lp::surface-form :fasl :unix) -"fasl" - (lp::surface-form :fasl :vms) -"FAS" -|# - - -;;; ******************************** -;;; Pathname Defstruct ************* -;;; ******************************** -;;; -;;; We define a generic physical pathname (physical-pathname defstruct) because -;;; we have absolutely NO guarrantees about the structure of pathnames. -;;; Pathnames may be defstructs or classes, and the slots may have arbitrary -;;; types, especially with respect to the directory slot. Depending on the -;;; lisp, the directory slot may be a list, vector, simple-vector, -;;; string, keyword, or nil. If a list or vector, the items in the list -;;; may be strings, keywords (for canonical types), or nil. The first item -;;; in the list may or may not be a special keyword (e.g., :relative and -;;; :absolute). -;;; -;;; The lack of a common interface to pathnames means that any implementation -;;; of logical pathnames must parse and generate the pathname (namestring) -;;; formats for a variety of file-servers. We can't simply rely on the -;;; lisp's implementation of the PATHNAME defstruct, because that does not -;;; necessarily handle the formats of file-servers of a different type -;;; (translations may be in the format of the target file server). Also, -;;; inconsistency in the implementation of the PATHNAME type means that we -;;; would have to special case most of the code for each and every lisp. -;;; -;;; Instead, we parse the pathnames into a common format (the physical-pathname -;;; defstruct), from which we generate a namestring in a format acceptable -;;; to the underlying lisp. The namestring (which is a string in *all* the -;;; lisps) serves as the interface to the lisp's implementation of pathnames. -;;; -;;; As it currently stands, X3J13's spec for logical pathnames tries to -;;; accomplish two distinct goals: -;;; (1) isolate pathname reference from actual file location (logical -;;; as opposed to physical pathnames) -;;; (2) provide a common format for namestring syntax and -;;; pathname structure -;;; This is trying to accomplish too much within a single framework. Instead, -;;; the second goal should be decoupled from logical pathnames and made a -;;; requirement for pathnames in general. -;;; -;;; In other words, let there be a standard namestring syntax and a fully -;;; specified structure for physical pathnames (not just logical pathnames). -;;; This standard should subsume the requirements of all current lisps, and -;;; the individual lisp implementation should worry about interfacing with -;;; the file system. There is no good reason why a programmer should have -;;; to know the peculiarities of a filesystem when writing software. The X3J13 -;;; spec just shoves it under the rug, forcing the programmer to deal with -;;; it when writing the translations file. -;;; -;;; Because there is no standard for pathnames, we're forced into a situation -;;; where different lisps running on the same physical host may have -;;; different namestring syntaxes, so knowing the physical host type is not -;;; a guarrantee of the pathname syntax. -;;; -(defstruct (physical-pathname - (:conc-name %physical-pathname-) - (:predicate physical-pathnamep)) - "Physical-Pathname is the underlying structure for a pathname." - (host nil :type (or null keyword simple-string)) - (device nil :type (or null keyword simple-string)) - (directory nil :type (or null simple-vector)) - (name nil :type (or null keyword simple-string)) - (type nil :type (or null keyword simple-string)) - version) - -(defun ensure-pathname (thing) - (if (pathnamep thing) thing (pathname thing))) - -;;; ******************************** -;;; Logical Pathname Defstruct ***** -;;; ******************************** -(defstruct (logical-pathname - (:include physical-pathname) - (:conc-name %logical-pathname-) - (:print-function %print-logical-pathname) - (:constructor %make-logical-pathname - (host device directory name type version)) - (:predicate logical-pathnamep)) - "Logical-pathname is the underlying structure for a logical pathname.") - -(defun %print-logical-pathname (pname stream depth) - (declare (ignore depth)) - (format stream "#.(logical-pathname ~S)" (logical-namestring pname))) - -(defun make-logical-pathname (&key host directory name type version) - (let ((host-type (host-type host))) - (when (stringp directory) - (setq directory - (%logical-pathname-directory (parse-generic-namestring directory - host)))) - (%make-logical-pathname - (canonicalize host host-type 'host) - :unspecific - directory - (canonicalize name host-type 'name) - (canonicalize type host-type 'type) - (canonicalize version host-type 'version) - ))) - -(defun ensure-logical-pathname (thing) - (if (logical-pathnamep thing) thing (logical-pathname thing))) - -;;; The following cannot be done by the accessors because the pathname -;;; arg may be a string. - -(defun logical-pathname-host (logical-pathname) - "Returns the logical-pathname-host of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-host (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-directory (logical-pathname) - "Returns the logical-pathname-directory of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-directory (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-name (logical-pathname) - "Returns the logical-pathname-name of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-name (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-type (logical-pathname) - "Returns the logical-pathname-type of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-type (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-version (logical-pathname) - "Returns the logical-pathname-type of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-version (ensure-logical-pathname logical-pathname))) - - -;;; ******************************** -;;; Pathname Namestring Functions ** -;;; ******************************** -(defun logical-namestring (logical-pathname) - "Returns the full form of LOGICAL-PATHNAME as a string." - (setq logical-pathname (logical-pathname logical-pathname)) - (let ((host (%logical-pathname-host logical-pathname)) - (directory (%logical-pathname-directory logical-pathname)) - (name (%logical-pathname-name logical-pathname)) - (type (%logical-pathname-type logical-pathname)) - (version (%logical-pathname-version logical-pathname)) - result) - (declare (simple-string result)) - ;; FORMAT would have been easier, but this is faster. - (when host - (setq result - (concatenate 'simple-string - (surface-form host :logical 'host) ":"))) - (when directory - (setq result - (concatenate 'simple-string - result - (the simple-string (%directory-string directory))))) - (when name - (setq result - (concatenate 'simple-string - result - (the simple-string (surface-form name :logical 'name))))) - (when type - (setq result - (concatenate 'simple-string - result "." - (the simple-string (surface-form type :logical 'type))))) - (when version - (setq result - (concatenate 'simple-string - result "." - (the simple-string - (%version-to-string version))))) - result)) - -(defun %directory-string (dirlist &optional (host-type :logical) - (dir-delim #\;)) - "Converts a vector of the form #(\"foo\" \"bar\" ... \"baz\") into - a string of the form \"foo;bar;...;baz;\"" - (declare (simple-vector dirlist)) - (let* ((numdirs (length dirlist)) - (length numdirs)) - (declare (fixnum numdirs length)) - (dotimes (i numdirs) - (let ((component (#+:cmu svref #-:cmu aref dirlist i))) - (case component - ;; Do we have to worry about Lucid's :root here??? - ((:relative :absolute) - (incf length - (the fixnum - (1- (length (surface-form component - host-type 'component)))))) - (otherwise (incf length - (the fixnum - (length (surface-form component host-type - 'component)))))))) - (do ((result (make-string length)) - (index 0 (1+ index)) - (position 0)) - ((= index numdirs) result) - (declare (simple-string result)) - (let* ((component (#+:cmu svref #-:cmu aref dirlist index)) - (string (surface-form component host-type 'component)) - (len (length string)) - (end (+ position len))) - (declare (simple-string string) - (fixnum len end)) - (replace result string :start1 position :end1 end :end2 len) - (unless (or (eq component :absolute)(eq component :relative)) - (setf (schar result end) dir-delim) - (setq position (+ end 1))))))) - -(defun %version-to-string (version &optional (host-type :logical)) - (cond ((surface-form version host-type 'version)) - ((zerop version) "0") - ((eql version 1) "1") - (t - ;; Using FORMAT would have been easier, but this is faster. - (do* ((len (1+ (truncate (log version 10)))) ; base 10 num digits - (res (make-string len)) - (i (1- len) (1- i)) - (q version) ; quotient - (r)) ; residue - ((zerop q) ; nothing left - res) - (declare (simple-string res) - (fixnum len i r)) - (multiple-value-setq (q r) (truncate q 10)) - (setf (schar res i) (schar "0123456789" r)))))) - -(defun physical-namestring (pathname) - ;; needs to get appropriate surface forms - (setq pathname (pathname pathname)) - (let* ((host (%physical-pathname-host pathname)) - (host-type (host-type host)) - (device (%physical-pathname-device pathname)) - (directory (coerce (%pathname-directory pathname) 'list)) - (name (%physical-pathname-name pathname)) - (type (%physical-pathname-type pathname)) - (version (%physical-pathname-version pathname)) - (ptype (pathname-host-type pathname))) - (setq host (surface-form host host-type 'host) - name (surface-form name host-type 'name) - type (surface-form type host-type 'type) - version (surface-form version host-type 'version)) - ;; Does directory need to be mapcar'ed into surface-form? - ;; Yes, but we can probably ignore it for now, since the only - ;; canonical types defined so far are :wild and :wild-inferiors, - ;; which we don't have to support. Probably wouldn't hurt to - ;; uncomment this code. - ;;(setq directory - ;; (cons (car directory) - ;; (mapcar #'(lambda (comp) - ;; (surface-form comp host-type 'component)) - ;; (cdr directory)))) - (case ptype - (:logical - (logical-namestring pathname)) - (:unix - (format nil "~@[~A:~]~A~{~A/~}~@[~A~@[.~A~@[.~A~]~]~]" - host (case (car directory) - (:absolute "/") - (otherwise "")) - (cdr directory) - name type version)) - (:vms - ;; was "~@[~A:~]~@[~A:~][~A~{~A.~}]~@[~A~@[.~A~@[.~A~]~]~]" - ;; which was adding an extra "." to path - ;; such as [a.b] => [a.b.] - (format nil - "~@[~A:~]~@[~A:~][~A~{~A~^.~}]~@[~A~@[.~A~@[.~A~]~]~]" - host device (case (car directory) - (:relative ".") - (otherwise "")) - (cdr directory) - name type version)) - (:explorer - (format nil "~@[~A:~]~A~{~A~^.~};~@[~A~@[.~A~@[#~A~]~]~]" - host (case (car directory) - (:relative ".") - (otherwise "")) - (cdr directory) - name type version)) - (:symbolics - (format nil "~@[~A:~]~A~{~A>~}~@[~A~@[.~A~@[.~A~]~]~]" - host (case (car directory) - (:absolute ">") - (otherwise "")) - (cdr directory) - name type version)) - (otherwise - ;; Use UNIX as default. - (format nil "~@[~A:~]~A~{~A/~}~@[~A~@[.~A~@[.~A~]~]~]" - host (case (car directory) - (:absolute "/") - (otherwise "")) - (cdr directory) - name type version)) - ))) - -;;; ******************************** -;;; Pathname Parsing Functions ***** -;;; ******************************** -(defun logical-pathname (thing &optional host) - "Converts THING to a logical pathname and returns it. THING may be - a logical pathname, a logical pathname namestring containing a - host component, or a stream for which the pathname function returns - a logical pathname." - (etypecase thing - (string - (values (parse-generic-namestring thing host - *default-pathname-defaults* - :force-logical t))) - (pathname thing) - (logical-pathname thing) - #+:CMU(stream (logical-pathname (lisp::file-name thing) host)))) - -(defun physical-pathname (thing &optional host) - "Converts THING to a physical-pathname and returns it. THING may be - a pathname, a pathname namestring containing a - host component, or a stream for which the file-name function returns - a pathname." - (typecase thing - (string (values (parse-generic-namestring thing host))) - (logical-pathname thing) - (physical-pathname thing) - #+:CMU(stream (physical-pathname (lisp::file-name thing) host)))) - -(defun parse-generic-namestring (thing &optional host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed - force-logical) - "Convert namestring into a pathname." - (declare (ignore junk-allowed)) - (unless end (setf end (length thing))) - (let ((host-string (get-host-string thing ":")) - host-type) - (unless host-string (setq host-string host)) - (when (and host host-string (not (string-equal host host-string))) - (cerror "Ignore it." - "Host mismatch in ~S: ~S isn't ~S" - 'parse-generic-namestring - host-string - host)) - (if force-logical - (setq host-type :logical) - (setq host-type (host-type host-string))) - (if host-type - (multiple-value-bind (parsed-host device directory name type version) - (do-generic-pathname-parse thing host-type start end) - (let ((defaults-p (and (typep defaults 'pathname) - (equal host-type - (pathname-host-type defaults))))) - (values - (case host-type - (:logical - (make-logical-pathname - :host (or parsed-host host - (and defaults-p (logical-pathname-host defaults)) -; (when directory "Default") - ) - :directory (or directory - (and defaults-p - (logical-pathname-directory defaults))) - :name (or name - (and defaults-p - (logical-pathname-name defaults))) - :type (or type - (and defaults-p - (logical-pathname-type defaults))) - :version (or version - (and defaults-p - (logical-pathname-version defaults))))) - (otherwise - (make-pathname - :host (or parsed-host host - (and defaults-p (pathname-host defaults)) -; (when directory "Default") - ) - :device (or device - (and defaults-p - (pathname-device defaults))) - :directory (or directory - (and defaults-p - (pathname-directory defaults))) - :name (or name - (and defaults-p - (pathname-name defaults))) - :type (or type - (and defaults-p - (pathname-type defaults))) - :version (or version - (and defaults-p - (pathname-version defaults)))))) - end))) - ;; Unknown host type, wing it with parse-namestring. - (when thing - (lisp:parse-namestring thing host defaults - :start start :end end))))) - -;;; ******************************** -;;; Parse Physical Pathnames ******* -;;; ******************************** -(defun do-generic-pathname-parse (string host-type &optional (start 0) end) - "Splits string into a logical host, a vector of directories, a file name, - a file type, and a file version." - (declare (simple-string string)) - (case host-type - (:logical - ;; Parses Logical Pathnames of the following format: - ;; host:dir1;dir2;name.type.version - (parse-generic-pathname string start end ":" nil ";" "." "." ".")) - (:unix - ;; Parses Unix pathnames of the following format: - ;; host:/dir1/dir2/*/name.type.version - (parse-generic-pathname string start end ":" t "/" "." "." ".")) - (:symbolics - ;; Parses Symbolics Pathnames of the following format: - ;; host:>dir1>dir2>**>name.type.version - (parse-generic-pathname string start end ":" t ">" "." "." ".")) - (:vms (parse-vms-pathname string start end)) - (:explorer (parse-explorer-pathname string start end)) - (otherwise (warn "~&PARSE-~A-PATHNAME not yet implemented.~%" host-type) - nil))) - -(defun parse-generic-pathname (string &optional (start 0) end - (host-delim ":")(lead-is-abs t) - (dir-delim "/") - (name-delim ".")(type-delim ".") - (version-delim ".")) - "Splits string into a host, vector of directories, a file name, type, - and version. Parses generic pathnames." - (declare (simple-string string)) - (setq end (or end (length string))) - (let (host a-vs-r directories name type version host-type) - (multiple-value-setq (host start) - (get-host-string string host-delim start end)) - (setq host-type (host-type host)) - ;; Absolute vs. Relative - (cond ((and (not (string-equal string "" :start1 start)) - (char= (char dir-delim 0) (char string start))) - (setq a-vs-r (if lead-is-abs :absolute :relative)) - (incf start)) - (t (setq a-vs-r (if lead-is-abs :relative :absolute)))) - ;; Split off the components - (multiple-value-bind (dirs new-start) - (parse-with-string-delimiter* dir-delim string :start start :end end) - (setq directories - (cons a-vs-r - (mapcar #'(lambda (dir) - (canonicalize dir host-type 'component)) - dirs)) - start new-start)) - ;; Split off the name, type, and version - (when (< start end) - (multiple-value-setq (name start) - (parse-with-string-delimiter name-delim string - :start start :end end)) - (when (< start end) - (multiple-value-setq (type start) - (parse-with-string-delimiter type-delim string - :start start :end end)) - (when (< start end) - (multiple-value-setq (version start) - (parse-with-string-delimiter version-delim string - :start start :end end))))) - ;; Return the values - (values host - :unspecific - (when (or host directories) - (coerce directories 'vector)) - name - type - version - ;; This last is the remaining cruft. Should be nil. - (when (< start end) (subseq string start end))))) - -(defun parse-vms-pathname (string &optional (start 0) end) - "Splits string into a host, vector of directories, a file name, type, - and version. Parses VMS pathnames of the following formats: - host::device:[dir1.dir2...]name.type;version - host::device:name.type.version - host:device:name.type.version &c - .. = :wild-inferiors" - (declare (simple-string string)) - (setq end (or end (length string))) - (let (host device a-vs-r (directories "") name type version) - (multiple-value-bind (new-host new-start) - (get-host-string string "::" start end) - (if new-host - (setq host new-host start new-start) - (multiple-value-setq (host start) (get-host-string string ":" start end)))) - (multiple-value-setq (device start) (get-host-string string ":" start end)) - (when (plusp (length string)) - (case (char string start) - (#\[ (multiple-value-setq (directories start) - (parse-with-string-delimiter "]" string - :start (1+ start) :end end))) - (#\< (multiple-value-setq (directories start) - (parse-with-string-delimiter ">" string - :start (1+ start) :end end))))) - ;; Absolute vs. Relative - (cond ((and (not (zerop (length directories))) - (char= #\. (char directories 0))) - (setq a-vs-r :relative)) - (t (setq a-vs-r :absolute))) - ;; Split off the components - (multiple-value-bind (dirs) - (parse-with-string-delimiter* "." directories - :start (if (eq a-vs-r :relative) 1 0) - :include-last t) ; <<< fix - (let ((last2 (when (> (length dirs) 1) - (nthcdr (- (length dirs) 2) dirs)))) - (when (equal last2 '(nil nil)) - (rplaca last2 "..") - (rplacd last2 nil))) - (setq directories - (cons a-vs-r - (mapcar #'(lambda (dir) (canonicalize dir :vms 'component)) - dirs)))) - ;; Split off the name, type, and version - (when (< start end) - (multiple-value-setq (name start) - (parse-with-string-delimiter "." string :start start :end end)) - (when (< start end) - (multiple-value-bind (new-type new-start delim-not-found) - (parse-with-string-delimiter ";" string :start start :end end) - (cond (delim-not-found - (multiple-value-setq (type start) - (parse-with-string-delimiter "." string - :start start :end end))) - (t - (setq type new-type start new-start)))) - (when (< start end) - (multiple-value-setq (version start) - (parse-with-string-delimiter "." string :start start :end end))))) - ;; Return the values - (values host - device - (when (or host directories) - (coerce directories 'vector)) - name - type - version - ;; This last is the remaining cruft. Should be nil. - (when (< start end) (subseq string start end))))) - -(defun parse-explorer-pathname (string &optional (start 0) end) - "Splits string into a host, vector of directories, a file name, type, - and version. Parses TI Explorer pathnames of the following format: - host:dir1.dir2...;name.type#version" - (declare (simple-string string)) - (setq end (or end (length string))) - (let (host a-vs-r (directories "") name type version) - (multiple-value-setq (host start) - (get-host-string string ":" start end)) - (multiple-value-setq (directories start) - (parse-with-string-delimiter ";" string - :start start :end end)) - ;; Absolute vs. Relative - (cond ((and (not (zerop (length directories))) - (char= #\. (char directories 0))) - (setq a-vs-r :relative)) - (t (setq a-vs-r :absolute))) - ;; Split off the components - (multiple-value-bind (dirs) - (parse-with-string-delimiter* "." directories - :start (if (eq a-vs-r :relative) 1 0) - :end nil :include-last t) - - (setq directories - (cons a-vs-r - (mapcar #'(lambda (dir) - (canonicalize dir :explorer 'component)) - dirs)))) - ;; Split off the name, type, and version - (when (< start end) - (multiple-value-bind (new-name new-start delim-not-found) - (parse-with-string-delimiter "." string :start start :end end) - (when (not delim-not-found) - (setq name new-name start new-start))) - (when (< start end) - (multiple-value-setq (type start) - (parse-with-string-delimiter "#" string :start start :end end)) - (when (< start end) - (multiple-value-setq (version start) - (parse-with-string-delimiter "." string :start start :end end))))) - ;; Return the values - (values host - :unspecific - (when (or host directories) - (coerce directories 'vector)) - name - type - version - ;; This last is the remaining cruft. Should be nil. - (when (< start end) (subseq string start end))))) - - -;;; ******************************** -;;; Convert Generic Pathnames ****** -;;; ******************************** -;;; Converts a generic pathname to a format for standard lisp functions. - -(defvar *translation-output* :namestring - "Specifies whether the output of translate-logical-pathname - should be a :namestring or a :pathname made with lisp:make-pathname, - or :as-is.") - -(defconstant directory-structure-type ; &&& - #+:CMU 'simple-vector - #+:lispm 'list - #+:kcl 'list - #+:ecl 'list - #+:hp 'list - #-(or :cmu :lispm :kcl :ecl :hp) - (cond ((string-equal (lisp-implementation-type) "VAX LISP") 'list) - (t 'list))) - -(defun convert-generic-pathname (pathname - &optional (output-type *translation-output*)) - (when pathname - (case output-type - (:namestring (physical-namestring pathname)) - (:pathname - (let ((host (%physical-pathname-host pathname)) - (device (%physical-pathname-device pathname)) - (directory (coerce (%physical-pathname-directory pathname) - 'list)) - (name (%physical-pathname-name pathname)) - (type (%physical-pathname-type pathname)) - (version (%physical-pathname-version pathname)) - (target-host-type (host-type nil)) - a-vs-r) - ;; Handle :absolute/:relative crap. - (setq a-vs-r (pop directory)) - (case a-vs-r - (:absolute - #+:cmu (setf device :absolute) - #+(and :sun :kcl :unix) (setq a-vs-r :root) - #+ecl (setq a-vs-r :root)) - (:relative - #+:cmu (setf device "Default"))) - ;; Reverse canonicalizations - (setq host (surface-form host target-host-type 'host) - directory (mapcar #'(lambda (dir) - (surface-form dir target-host-type - 'component)) - directory) - name (surface-form name target-host-type 'name) - type (surface-form type target-host-type 'type) - version (surface-form version target-host-type 'version)) - ;; Fixup Host - #+:cmu (setf host "Mach") - ;; Fixup Directory - #-:cmu (push a-vs-r directory) - (setq directory (coerce directory directory-structure-type)) - - (when (string-equal (lisp-implementation-type) "VAX LISP") - (setq directory - (cond ((stringp directory) directory) - ((eq (car directory) :absolute) - (format nil "[~{~A~^.~}]" (cdr directory))) - ((eq (car directory) :relative) - (format nil "[.~{~A~^.~}]" (cdr directory))) - (t (format nil "[~{~A~^.~}]" directory))))) - - ;; Return the new pathname - (make-pathname :host host :device device :directory directory - :name name :type type :version version) - )) - (otherwise pathname)))) - - -;;; ******************************** -;;; Translate Logical Pathnames **** -;;; ******************************** -(defvar *circularity-check-table* (make-hash-table :test #'equal) - "This table is used to prevent infinite circular loops in the logical - pathname resolution. If a pathname's entry in this table is set - to T, it has already been \"seen\". Seeing such a pathname twice - is an error.") - -(defun translate-logical-pathname (logical-pathname - &optional - (output-format *translation-output*)) - "Translates a logical pathname to the corresponding physical pathname. - The pathname argument is first coerced to a logical pathname [this - should really be pathname, but for that we'd have to redefine - make-pathname and friends to check whether the host is a logical host]. - If the coerced argument is a logical pathname, the first matching - translation (according to LOGICAL-PATHNAME-MATCH-P) of the logical pathname - host is applied, as if by calling TRANSLATE-LOGICAL-PATHNAME-AUX. - If the result is a logical pathname, this process is repeated. - When the result is finally a physical pathname, it is returned. If no - translation matches a logical pathname, or the resolution process loops, - an error is signaled. - - TRANSLATE-LOGICAL-PATHNAME may perform additional translations, - to provide translation of file types to local naming conventions, to - accommodate physical file systems with names of limited length, or to - deal with special character requirements such as translating hyphens - to underscores or uppercase letters to lowercase." - - ;; Ensure that it is a logical pathname - (setq logical-pathname (logical-pathname logical-pathname)) - (when (typep logical-pathname 'logical-pathname) - ;; To prevent circular loops... - (let ((namestring (logical-namestring logical-pathname))) - (setf (gethash namestring *circularity-check-table*) T)) - (unwind-protect - (resolve-logical-pathname logical-pathname output-format) - (clrhash *circularity-check-table*)))) - -(defun resolve-logical-pathname (logical-pathname - &optional - (output-format *translation-output*)) - "Resolve the logical pathname into a physical pathname using the - translations table." - (let ((logical-host (logical-pathname-host logical-pathname))) - (if logical-host - (let ((translated-pathname - (map-logical-pathname logical-pathname logical-host - output-format))) - (if translated-pathname - (or (when (eq (pathname-host-type translated-pathname) :logical) - ;; If the translation is itself a logical pathname, - ;; repeat the process until a physical pathname is reached. - (check-logical-pathname translated-pathname) - (resolve-logical-pathname translated-pathname - output-format)) - translated-pathname) - (error "No translation mapping for ~S." logical-pathname))) - (error "No such logical host in ~S:." logical-pathname)))) - -(defun check-logical-pathname (pathname) - "Ensure that there are no cycles in the translations." - (let ((namestring (logical-namestring pathname))) - (if (gethash namestring *circularity-check-table*) - (error "Circularity in translations for ~S." namestring) - (setf (gethash namestring *circularity-check-table*) T)))) - -(defun map-logical-pathname (logical-pathname - host - &optional (output-format *translation-output*)) - "Find and execute the first matching translation." - (dolist (translation (logical-pathname-translations host)) - (let ((from-pathname (logical-pathname (car translation) host)) - (to-pathname (cadr translation))) - (when (logical-pathname-match-p logical-pathname from-pathname) - (return (translate-logical-pathname-aux logical-pathname - from-pathname - to-pathname - output-format)))))) - -(defun logical-pathname-match-p (logical-pathname from-pathname) - "Return T if the logical pathname matches the test pathname." - (setq logical-pathname (logical-pathname logical-pathname) - from-pathname (logical-pathname from-pathname)) - ;; ignore host. Match directories. Match name. Match type. Match version. - (and (match-directories (logical-pathname-directory from-pathname) - (logical-pathname-directory logical-pathname)) - (match-wildcard-word (logical-pathname-name from-pathname) - (logical-pathname-name logical-pathname)) - (match-wildcard-word (logical-pathname-type from-pathname) - (logical-pathname-type logical-pathname)) - (match-wildcard-word (logical-pathname-version from-pathname) - (logical-pathname-version logical-pathname)))) - -(defun translate-logical-pathname-aux (logical-pathname - from-pathname to-pathname - &optional - (output-format *translation-output*)) - "Translates the logical pathname using the substitution specified by - a particular translation." - (let* ((host (pathname-host to-pathname)) - (host-type (host-type host)) - (translation-rule (find-translation-rule host-type)) - (char-map (translation-rule-char-mappings translation-rule)) - (string-map (translation-rule-component-mappings translation-rule))) - (let ((device (pathname-device to-pathname)) - (directories (map-directories - (pathname-directory logical-pathname) - (pathname-directory from-pathname) - (pathname-directory to-pathname) - *null-vector* 0 0 0 - (choose-case translation-rule 'component) - char-map string-map)) - (name (map-wildcard-word (pathname-name logical-pathname) - (pathname-name from-pathname) - (pathname-name to-pathname) - (choose-case translation-rule 'name) - char-map string-map)) - (type (map-wildcard-word (pathname-type logical-pathname) - (pathname-type from-pathname) - (pathname-type to-pathname) - (choose-case translation-rule 'type) - char-map string-map)) - (version (map-wildcard-word (pathname-version logical-pathname) - (pathname-version from-pathname) - (pathname-version to-pathname) - (choose-case translation-rule 'version) - char-map string-map))) - (cond ((eq (pathname-host-type to-pathname) :logical) - (make-logical-pathname :host host - :directory directories - :name name - :type type - :version version)) - (t - (convert-generic-pathname - (make-pathname :host host - :device device - :directory directories - :name name - :type type - :version version) - output-format)))))) - -;;; ******************************** -;;; Match and Map Wildcards ******** -;;; ******************************** -(defun wildcard-wordp (string) - (find #\* string)) - -(defun must-match (thing) - (or (eq thing :wild) - (and (stringp thing) - (wildcard-wordp thing)))) - -(defun match-wildcard-word (template string) - ;; "*" standalone (:wild) is treated differently from "*" within - ;; a word. - (or (eq template :wild) - (null template) - (and (stringp string) (stringp template) - (match-strings template string)) - ;; e.g., :absolute :absolute - (eq template string))) - -(defun match-strings (template string &optional (t-start 0) (s-start 0)) - (let* ((t-length (length template)) - (s-length (length string)) - (t-at-end (= t-length t-start)) - (s-at-end (= s-length s-start))) - (cond ((or t-at-end s-at-end) ; if at end of template or string - (and t-at-end s-at-end)) ; both must be at the end. - ((char= #\* (char template t-start)) - (or (match-strings template string (1+ t-start) s-start) - (match-strings template string t-start (1+ s-start)) - (match-strings template string (1+ t-start) (1+ s-start)))) - ((char-equal (char template t-start) - (char string s-start)) ; includes * against * - (match-strings template string (1+ t-start) (1+ s-start)))))) - -(defun match-directories (template dirs &optional (t-start 0) (d-start 0)) - (let* ((t-length (length template)) - (d-length (length dirs)) - (t-at-end (= t-length t-start)) - (d-at-end (= d-length d-start))) - (cond ((or t-at-end d-at-end) - (and t-at-end d-at-end)) - ((eq (#+:cmu svref #-:cmu aref template t-start) :wild-inferiors) - ;; :wild-inferiors matches any number of components, including - ;; zero. First try skipping over the :wild-inferiors. If that fails, - ;; try matching against one component without skipping over the - ;; :wild-inferiors. Finally, try matching against one component - ;; while skipping over the :wild-inferiors (the latter really - ;; isn't necessary, since the first 2 cases include it). - (or (match-directories template dirs (1+ t-start) d-start) - (match-directories template dirs t-start (1+ d-start)) - (match-directories template dirs (1+ t-start) (1+ d-start)))) - ((match-wildcard-word (#+:cmu svref #-:cmu aref template t-start) - (#+:cmu svref #-:cmu aref dirs d-start)) - (match-directories template dirs (1+ t-start) (1+ d-start)))))) - -(defun map-wildcard-word (string source target - &optional case char-mappings string-mappings) - (let ((result - (cond ((and (stringp target) - (not (wildcard-wordp target))) - ;; If the target pattern does not contain *, copy the target - ;; pattern component literally to the target instance. - target) - ((or (eq target :wild) (null target)) - ;; If the target pattern is :wild, copy the source string - ;; component to the target string literally with no further - ;; analysis. This holds even for the type, which is - ;; represented internally in terms of canonical types, - ;; and is "translated" when realized for the new host. - string) - ((not (stringp target)) - target) - ((eq source :wild) - (map-strings string string target)) - (t (map-strings string source target))))) - (when (stringp result) - (setq result - (casify (parallel-substitute char-mappings - (name-substitution string-mappings - result)) - case))) - result)) - -(defun map-strings (string source target - &optional (result "") - (s-start 0) (st-start 0) (tt-start 0)) - (let* ((s-length (length string)) - (st-length (length source)) - (tt-length (length target)) - (s-at-end (= s-length s-start)) - (st-at-end (= st-length st-start)) - (tt-at-end (= tt-length tt-start))) - (cond ((or s-at-end st-at-end) - ;; When not enough matching values are available due to too few - ;; * in the source pattern, use the null string as the matching - ;; value for any * remaining in the target. - (when (and s-at-end st-at-end) - (concatenate 'simple-string - result - (delete #\* (subseq target tt-start))))) - (tt-at-end - ;; When the source pattern has too many *, ignore the first - ;; extra * and everything following it. - result) - ((char= #\* (char target tt-start)) - ;; Replace * in target pattern with the contents of the source - ;; string specified by the next * in the source pattern. - (cond ((char= #\* (char source st-start)) - (or (map-strings string source target result - s-start (1+ st-start) (1+ tt-start)) - (map-strings string source target - (concatenate 'simple-string result - (subseq string s-start - (1+ s-start))) - (1+ s-start) st-start tt-start))) - ((char-equal (char source st-start) ; was char= - (char string s-start)) - (map-strings string source target result - (1+ s-start) (1+ st-start) tt-start)))) - (t;; copy literal strings as is from the target - (let ((next-* (position #\* target :start tt-start))) - (if next-* - (map-strings string source target - (concatenate 'simple-string result - (subseq target tt-start next-*)) - s-start st-start next-*) - (when (match-strings source string st-start s-start) - (concatenate 'simple-string - result (subseq target tt-start))))))))) - -(defun map-directories (dirs source target - &optional (result *null-vector*) - (d-start 0) (s-start 0) (t-start 0) - case char-map string-map) - (let* ((d-length (length dirs)) - (s-length (length source)) - (t-length (length target)) - (d-at-end (= d-length d-start)) - (s-at-end (= s-length s-start)) - (t-at-end (= t-length t-start))) - (cond ((or d-at-end s-at-end) - (when (and d-at-end s-at-end) - (concatenate 'simple-vector result - (map 'simple-vector - #'(lambda (x) - (map-wildcard-word - "" "" x - case char-map string-map)) - (delete :wild-inferiors - (subseq target t-start)))))) - (t-at-end - (when (match-directories source dirs s-start d-start) - result)) - ((eq :wild-inferiors (#+:cmu svref #-:cmu aref target t-start)) - (cond ((eq :wild-inferiors (#+:cmu svref - #-:cmu aref source s-start)) - (or (map-directories dirs source target result - d-start (1+ s-start) (1+ t-start) - case char-map string-map) - (map-directories dirs source target - (concatenate 'simple-vector result - (list (map-wildcard-word - (#+:cmu svref - #-:cmu aref - dirs d-start) - :wild :wild - case char-map - string-map))) - (1+ d-start) s-start t-start - case char-map string-map) - (map-directories dirs source target - (concatenate 'simple-vector result - (list (map-wildcard-word - (#+:cmu svref - #-:cmu aref - dirs d-start) - :wild :wild - case char-map - string-map))) - (1+ d-start) (1+ s-start) (1+ t-start) - case char-map string-map))) - ((string-equal (#+:cmu svref #-:cmu aref dirs d-start) - (#+:cmu svref #-:cmu aref source s-start)) - (map-directories dirs source target result - (1+ d-start) (1+ s-start) t-start - case char-map string-map)))) - ((must-match (#+:cmu svref #-:cmu aref target t-start)) - (cond ((must-match (#+:cmu svref #-:cmu aref source s-start)) - (map-directories dirs source target - (concatenate 'simple-vector result - (list (map-wildcard-word - (#+:cmu svref - #-:cmu aref dirs d-start) - (#+:cmu svref - #-:cmu aref source s-start) - (#+:cmu svref - #-:cmu aref target t-start) - case char-map string-map))) - (1+ d-start) (1+ s-start) (1+ t-start) - case char-map string-map)) - ((string-equal (#+:cmu svref #-:cmu aref dirs d-start) - (#+:cmu svref #-:cmu aref source s-start)) - (map-directories dirs source target result - (1+ d-start) (1+ s-start) t-start - case char-map string-map)))) - (t - (map-directories dirs source target - (concatenate 'simple-vector result - (list - (map-wildcard-word - (#+:cmu svref - #-:cmu aref target t-start) - :wild :wild - case char-map - string-map))) - d-start s-start (1+ t-start) - case char-map string-map))))) - - -;;; ******************************** -;;; Common Lisp Redefinitions ****** -;;; ******************************** -;;; Not doing merge-pathnames or with-open-file. Parse-namestring not -;;; really done well. - -;;; append-directories -(defun append-logical-directories (absolute-dir relative-dir) - (when (or absolute-dir relative-dir) - (setq absolute-dir (logical-pathname (or absolute-dir "")) - relative-dir (logical-pathname (or relative-dir ""))) - (logical-namestring - (make-logical-pathname - :host (or (logical-pathname-host absolute-dir) - (logical-pathname-host relative-dir)) - :directory (concatenate 'simple-vector - (logical-pathname-directory absolute-dir) - (cdr (coerce (logical-pathname-directory - relative-dir) - 'list))) - :name (or (logical-pathname-name absolute-dir) - (logical-pathname-name relative-dir)) - :type (or (logical-pathname-type absolute-dir) - (logical-pathname-type relative-dir)) - :version (or (logical-pathname-version absolute-dir) - (logical-pathname-version relative-dir)))))) - -(eval-when (compile load eval) -(defun real-filename (filename) - (if (and filename - (eq (pathname-host-type filename) :logical)) - (translate-logical-pathname filename :namestring) - filename)) - -#| -(defmacro convert-file-function (name &optional optionalp) - (let ((old-name (intern (concatenate 'string "OLD-" (string name))))) - `(unless (fboundp ',old-name) - (setf (symbol-function ',old-name)(symbol-function ',name)) - (setf (symbol-function ',name) - #'(lambda ,(if optionalp - '(&optional filename &rest args) - '(filename &rest args)) - (apply #',old-name (real-filename filename) args)))))) -|# - -(defmacro convert-file-function (name &optional optionalp) - (let ((old-name (intern (concatenate 'string "OLD-" (string name))))) - `(unless (fboundp ',old-name) - ;; Yes, some lisps will give compiler warnings about OLD-name - ;; not being declared or defined as a function. But what can - ;; we do, with most lisps not yet recognizing CLtL2's ftype - ;; declaration? - (setf (symbol-function ',old-name)(symbol-function ',name)) - (setf (symbol-function ',name) - #'(lambda ,(if optionalp - '(&optional filename &rest args) - '(filename &rest args)) - ,(if optionalp - `(if filename - (apply #',old-name (real-filename filename) args) - (,old-name)) ; instead of (funcall #',old-name) - `(apply #',old-name (real-filename filename) args))))))) - -(defmacro convert-file-function-2-args (name) - (let ((old-name (intern (concatenate 'string "OLD-" (string name))))) - `(unless (fboundp ',old-name) - (setf (symbol-function ',old-name)(symbol-function ',name)) - (setf (symbol-function ',name) - #'(lambda (filename1 filename2 &rest args) - (apply #',old-name - (real-filename filename1)(real-filename filename2) - args)))))) -) - -(convert-file-function lisp::load) -(convert-file-function lisp::open) -(convert-file-function lisp::probe-file) -(convert-file-function lisp::delete-file) -(convert-file-function lisp::truename) -(convert-file-function lisp::directory) -(convert-file-function lisp::dribble t) -(convert-file-function lisp::ed t) -(convert-file-function lisp::file-author) -(convert-file-function lisp::file-write-date) - -(convert-file-function-2-args lisp::rename-file) -;; should take care of :output-file as well -(convert-file-function lisp::compile-file) - -(unless (fboundp 'old-parse-namestring) - (setf (symbol-function 'old-parse-namestring) - (symbol-function 'lisp::parse-namestring)) - (defun lisp::parse-namestring (thing &optional host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) - "Convert THING (string, symbol, pathname, or stream) into a pathname." - (declare (ignore junk-allowed)) - (cond ((null thing) nil) ; try to fix bug with (ed). probably not here. - ((or (eq (pathname-host-type thing) :logical) - (eq (pathname-host-type defaults) :logical) - (eq (host-type host) :logical)) - ;; Tis a logical pathname - (parse-generic-namestring thing host defaults - :start start :end end)) - (t (if end - (funcall 'old-parse-namestring thing host defaults - :start start :end end) - (funcall 'old-parse-namestring thing host defaults - :start start)))))) - -;;; *EOF* diff --git a/contrib/logical-pathnames.lsp b/contrib/logical-pathnames.lsp deleted file mode 100644 index b8f94624b..000000000 --- a/contrib/logical-pathnames.lsp +++ /dev/null @@ -1,2000 +0,0 @@ -;;; -*- Mode: LISP; Package: LOGICAL-PATHNAME; Syntax: Common-lisp; -*- -;;; Tue Apr 9 19:17:01 1991 by Mark Kantrowitz -;;; logical-pathnames.lisp - -;;; **************************************************************** -;;; Logical Pathnames System *************************************** -;;; **************************************************************** -;;; -;;; Logical Pathnames provide a facility for referring to pathnames -;;; in a portable manner. Logical pathnames are mapped to physical -;;; pathnames by a set of implementation dependent and site-dependent -;;; rules. -;;; -;;; This system is a Common Lisp portable implementation of logical -;;; pathnames. It fulfills most of the X3J13 June 1989 specification -;;; for logical pathnames, as documented in Guy Steele's "Common Lisp: -;;; The Language" (2nd Edition), section 23.1.5 "Logical Pathnames". -;;; -;;; Written by Mark Kantrowitz, July 1990. -;;; -;;; Address: Carnegie Mellon University -;;; School of Computer Science -;;; Pittsburgh, PA 15213 -;;; -;;; This code is in the public domain and is distributed without warranty -;;; of any kind. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted, so long as the following -;;; conditions are met: -;;; o no fees or compensation are charged for use, copies, or -;;; access to this software -;;; o this copyright notice is included intact. -;;; This software is made available AS IS, and no warranty is made about -;;; the software or its performance. -;;; -;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. -;;; -;;; -;;; Logical Pathnames are especially useful when coupled with a portable -;;; system construction tool, such as the Defsystem facility written -;;; by Mark Kantrowitz. -;;; - -;;; ******************************** -;;; Change Log ********************* -;;; ******************************** -;;; -;;; djc = Daniel J. Clancy -;;; -;;; 30-JUL-90 mk Fixed logical pathnames for VAX-LISP (thanks to -;;; Paul Werkowski). In VAX-LISP simple strings are not -;;; sub-types of simple-vectors, so svref doesn't work -;;; on strings. These calls have been fixed to read -;;; #+:cmu svref #-:cmu aref. -;;; 15-NOV-90 mk Changed convert-file-function to better handle optional -;;; args. This should fix the problem of (ed) and (dribble) -;;; returning errors like "argument NIL must be a number" -;;; in parse-namestring. Note that some lisps seem to make -;;; a distinction between (funcall #'foo) and (foo) with -;;; respect to this error. -;;; 29-JAN-91 mk Defined LISP:NTH-VALUE if not already present (it is -;;; a CLtL2 addition) and used it in LOAD-PHYSICAL-HOSTAB -;;; to avoid needing a GARBAGE variable in -;;; (multiple-value-setq (garbage pos) ...) which we can -;;; not declare ignore and yet causes a compiler warning -;;; since we don't use it. -;;; 29-JAN-91 mk lisp::file-name is particular to CMU Common Lisp -;;; and the #+:cmu's were accidentally left off. -;;; 29-JAN-91 mk Added :explorer physical namestring output to -;;; PHYSICAL-NAMESTRING. -;;; 29-JAN-91 mk Warns about name collisions between physical and logical -;;; host names. -;;; 30-JAN-91 mk Added :logical-pathnames-mk to the *features* list. -;;; 25-FEB-91 mk Added definition of LOAD-LOGICAL-PATHNAME-TRANSLATIONS. -;;; 09-APR-91 mk Export pathname-host-type, append-logical-directories. -;;; 09-APR-91 mk Translation rules now support :case :unchanged. -;;; 09-APR-91 djc Fixed so that (logical-pathname "") returns a -;;; logical-pathname structure. -;;; 21-FEB-96 attardi -;;; Added support for ECL - -;;; ******************************** -;;; To Do ************************** -;;; ******************************** -;;; -;;; Support for Macintosh pathnames. Little tricky, since MACL uses a -;;; colon (:) as the delimiter. -;;; -;;; support for tops-20/tenex, multics, its, ms-dos -;;; add host-type to pathnames -;;; merge-pathnames, with-open-file -;;; -;;; Define generic pathname parsing/printing definition interface. -;;; -;;; Redefine with-open-file? -;;; -;;; Port to emacs-lisp for gnu-emacs? -;;; -;;; Logical pathnames needs to case both on the physical host type and on -;;; lisp type (e.g., for canonicalization). Fix this, and define lots of -;;; canonical types. Dependency on lisp type can probably be handled using -;;; #+ and #-. What about conflicts between canonicalization and the -;;; translations (e.g., "L" vs :lisp)? -;;; - -;;; ******************************** -;;; Notes ************************** -;;; ******************************** -;;; -;;; LOGICAL-PATHNAMES has been tested (successfully) in the following lisps: -;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) -;;; Macintosh Allegro Common Lisp (1.3.2) -;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) -;;; Lucid CL (Version 2.1 6-DEC-87) -;;; Symbolics Common Lisp (8.0) -;;; Lucid Common Lisp (3.0, 4.0) -;;; VAXLisp (2.0, 3.1) -;;; ECL (ECoLisp) Version(0.23) -;;; -;;; LOGICAL-PATHNAMES needs to be tested in the following lisps: -;;; KCL (June 3, 1987 or later) -;;; AKCL (1.86, June 30, 1987 or later) -;;; TI (Release 4.1 or later) -;;; Ibuki Common Lisp (01/01, October 15, 1987) -;;; Golden Common Lisp (3.1 IBM-PC) -;;; HP Common Lisp (same as Lucid?) -;;; Procyon Common Lisp - - -;;; ******************************** -;;; Documentation ****************** -;;; ******************************** -;;; -;;; Logical pathnames allow large programs to be moved between sites -;;; by separating pathname reference from actual file location. The -;;; program will refer to files using logical pathnames. At each site, -;;; a user will specify a set of "translations" which map from the logical -;;; pathnames to the physical pathnames used on the device. -;;; -;;; Logical pathnames provide a uniform convention for filesystem access, -;;; with the following properties: -;;; 1. Pathname Portability: The program specifies a pathname in -;;; a conventional format (logical pathnames), which may be -;;; mapped reasonably literally (via the translations) to -;;; a variety of filesystems. -;;; 2. Pathname Aliasing: The files may exist in different locations -;;; in the various filesystems. For example, the root directory -;;; might change. The translations allow such a change easily. -;;; 3. Cross-host Access: The files need not all exist on the same -;;; physical host. -;;; -;;; This definition of logical pathnames provides support for physical -;;; pathnames for Unix, VMS/VAX, Symbolics, and TI Explorers, and is -;;; easily extended to handle additional platforms. Code which may need -;;; customization for particular Lisps and platforms has been commented -;;; with three ampersands (&&&). In addition, the user probably should -;;; define their own canonical types, translation rules, and -;;; logical-pathname-translations. Examples are provided. -;;; -;;; Logical pathnames employ the following syntax: -;;; [host:] [;] {directory ;}* [name] [. type [. version]] -;;; host ::= word -;;; directory ::= word | wildcard-word | wildcard-inferiors -;;; name ::= word | wildcard-word -;;; type ::= word | wildcard-word -;;; version ::= word | wildcard-word -;;; word ::= {letter | digit | -}* -;;; wildcard-word ::= [word] * {word *}* [word] -;;; wildcard-inferiors ::= ** -;;; -;;; A wildcard-word of * parses as :wild; all others as strings. These -;;; definitions may be extended (e.g., "newest" parsing as :newest) by -;;; defining new canonical types. -;;; -;;; Incompatibilities with the X3J13 specification: -;;; - LOGICAL-PATHNAME is not defined as a subclass of PATHNAME -;;; since we have no guarrantee about the format of PATHNAME -;;; (i.e., is it a defstruct or a class definition, what are -;;; its slots, etc.). Many Lisps will be able to replace the -;;; definition of PHYSICAL-PATHNAME with their definition of -;;; PATHNAME by doing a string-replace of "physical-pathname" -;;; with "pathname" and deleting some definitions from this file. -;;; - CLtL does not specify the manner in which wildcards are -;;; translated. We use reversible wildcard pathname translation, -;;; similar to that used in the Symbolics logical pathnames. -;;; - COMPILE-FILE-PATHNAME has not been defined, since it is -;;; highly implementation dependent. - -;;; ******************************** -;;; Examples *********************** -;;; ******************************** -;;; -;;; The following examples of the use of logical pathnames are taken -;;; from Section 23.1.5.4 of Guy Steele CLtL 2nd Ed. - -#| -(setf (lp:physical-host-type "MY-LISPM") :symbolics) -(setf (lp:logical-pathname-translations "foo") - '(("**;*.*.*" "MY-LISPM:>library>foo>**>"))) - - (lp:translate-logical-pathname "foo:bar;baz;mum.quux.3" :namestring) -"MY-LISPM:>library>foo>bar>baz>mum.quux.3" - -(setf (lp:physical-host-type "U") :unix) -(setf (lp:physical-host-type "V") :vms) -(setf (lp:logical-pathname-translations "prog") - '(("RELEASED;*.*.*" "U:/sys/bin/my-prog/") - ("RELEASED;*;*.*.*" "U:/sys/bin/my-prog/*/") - ("EXPERIMENTAL;*.*.*" "U:/usr/Joe/development/prog/") - ("EXPERIMENTAL;DOCUMENTATION;*.*.*" "V:SYS$DISK:[JOE.DOC]") - ("EXPERIMENTAL;*;*.*.*" "U:/usr/Joe/development/prog/*/") - ("MAIL;**;*.MAIL" "V:SYS$DISK:[JOE.MAIL.PROG...]*.MBX"))) - - (lp:translate-logical-pathname "prog:mail;save;ideas.mail.3" :namestring) -"V:SYS$DISK:[JOE.MAIL.PROG.SAVE]IDEAS.MBX.3" - (lp:translate-logical-pathname "prog:experimental;spreadsheet.c" :namestring) -"U:/usr/Joe/development/prog/spreadsheet.c" - -(setf (lp:logical-pathname-translations "prog") - '(("CODE;*.*.*" "/lib/prog/"))) - (lp:translate-logical-pathname "prog:code;documentation.lisp" :namestring) -"/lib/prog/documentation.lisp" - -(setf (lp:logical-pathname-translations "prog") - '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*") - ("CODE;*.*.*" "/lib/prog/"))) - (lp:translate-logical-pathname "prog:code;documentation.lisp" :namestring) -"/lib/prog/docum.lisp" - - -(setf (lp:logical-pathname-translations "prog") - `(("**;*.LISP.*" ,(lp:logical-pathname "PROG:**;*.L.*")) - ("**;*.FASL.*" ,(lp:logical-pathname "PROG:**;*.B.*")) - ("CODE;DOCUMENTATION.*.*" "/lib/prog/documentatio.*") - ("CODE;*.*.*" "/lib/prog/"))) - (lp:translate-logical-pathname "prog:code;documentation.lisp" :namestring) -"/lib/prog/documentatio.l" - -|# - -;;; **************************************************************** -;;; Logical Pathnames ********************************************** -;;; **************************************************************** -;;; Putting this in a separate package doesn't prevent collisions -;;; with the LISP package, since this package :uses the LISP -;;; package. -(in-package "LOGICAL-PATHNAME" :nicknames '("LP")) - -(export '(logical-pathname - translate-logical-pathname - logical-pathname-translations - pathname-host-type - append-logical-directories - make-logical-pathname - physical-host-type - load-logical-pathname-translations - load-physical-hostab - define-translation-rule - define-canonical)) - -(pushnew :logical-pathnames-mk *features*) - -;;; ******************************** -;;; Global Variables *************** -;;; ******************************** -(defvar *null-vector* (coerce nil 'simple-vector)) - -(defvar *warn-about-host-type-collisions* t - "Warn user when a logical host type definition collides with a physical - host type definition.") - -;;; ******************************** -;;; Primitives ********************* -;;; ******************************** -(defun parse-with-string-delimiter (delim string &key (start 0) end) - "Returns up to three values: the string up to the delimiter DELIM - in STRING (or NIL if the field is empty), the position of the beginning - of the rest of the string after the delimiter, and a value which, if - non-NIL (:delim-not-found), specifies that the delimiter was not found." - (declare (simple-string string)) - ;; Conceivably, if DELIM is a string consisting of a single character, - ;; we could do this more efficiently using POSITION instead of SEARCH. - ;; However, any good implementation of SEARCH should optimize for that - ;; case, so nothing to worry about. - (setq end (or end (length string))) - (let ((delim-pos (search delim string :start2 start :end2 end)) - (dlength (length delim))) - (cond ((null delim-pos) - ;; No delimiter was found. Return the rest of the string, - ;; the end of the string, and :delim-not-found. - (values (subseq string start end) end :delim-not-found)) - ((= delim-pos start) - ;; The field was empty, so return nil and skip over the delimiter. - (values nil (+ start dlength))) - ;; The following clause is subsumed by the last cond clause, - ;; and hence should probably be eliminated. -; ((= delim-pos (- end dlength)) -; ;; The delimiter is at the end of the string, so return the -; ;; field and skip to the end. -; (values (subseq string start delim-pos) -; end)) - (t - ;; The delimiter is in the middle of the string. Return the - ;; field and skip over the delimiter. - (values (subseq string start delim-pos) - (+ delim-pos dlength)))))) - -(defun parse-with-string-delimiter* (delim string &key (start 0) end - include-last) - "Breaks STRING into a list of strings, each of which was separated - from the previous by DELIM. If INCLUDE-LAST is nil (the default), - will not include the last string if it wasn't followed by DELIM - (i.e., \"foo,bar,\" vs \"foo,bar\"). Otherwise includes it even if - not terminated by DELIM. Also returns the final position in the string." - (declare (simple-string string)) - (setq end (or end (length string))) - (let (result) - (loop - (if (< start end) - (multiple-value-bind (component new-start delim-not-found) - (parse-with-string-delimiter delim string :start start :end end) - (when delim-not-found - (when include-last - (setq start new-start) - (push component result)) - (return)) - (setq start new-start) - (push component result)) - (return))) - (values (nreverse result) - start))) - -(defun get-host-string (string &optional (host-delimiter ":") (start 0) end) - "Strips the host name off the front of the string." - (setq end (or end (length string))) - (multiple-value-bind (host pos delim-not-found) - (parse-with-string-delimiter host-delimiter string :start start :end end) - (if delim-not-found - (values nil start) - (values host pos)))) - -(defun parallel-substitute (alist string) - "Makes substitutions for characters in STRING according to the ALIST. - In effect, PARALLEL-SUBSTITUTE can perform several SUBSTITUTE - operations simultaneously." - (declare (simple-string string)) - ;; This function should be generalized to arbitrary sequences and - ;; have an arglist (alist sequence &key from-end (test #'eql) test-not - ;; (start 0) (count most-positive-fixnum) end key). - (if alist - (let* ((length (length string)) - (result (make-string length))) - (declare (simple-string result)) - (dotimes (i length) - (let ((old-char (schar string i))) - (setf (schar result i) - (or (second (assoc old-char alist :test #'char=)) - old-char)))) - result) - string)) - -(defun name-substitution (alist string) - "Replaces STRING by it's replacement in ALIST, if present." - (let ((new-string (second (assoc string alist :test #'string-equal)))) - (or new-string string))) - -(unless (fboundp 'lisp::nth-value) - ;; NTH-VALUE is a CLtL2 addition, so not every lisp has it yet. - ;; This definition conses a lot, so we shouldn't use it in time-critical - ;; situations. It is fine for load-physical-hostab which is the only - ;; place we use it. - (defmacro lisp::nth-value (n form) - "Returns the nth value of the values returned by form." - `(nth ,n (multiple-value-list ,form))) - (export 'lisp::nth-value "LISP")) - -;;; ******************************** -;;; Logical Host Tables ************ -;;; ******************************** -(defvar *logical-pathname-translations-table* (make-hash-table :test #'equal)) -(defun canonicalize-logical-hostname (host) - (string-upcase host)) -(defun LOGICAL-PATHNAME-TRANSLATIONS (host) - "If HOST is the host component of a logical pathname and has been defined - as a logical pathname host name by SETF of LOGICAL-PATHNAME-TRANSLATIONS, - this function returns the list of translations for the specified HOST. - Each translation is a list of at least two elements, a from-wildname - and a to-wildname. The former is a logical pathname whose host is the - specified HOST. (I.e., the host of the from-pathname need not be - explicitly specified.) The latter is any pathname. If to-wildname coerces to - a logical pathname, TRANSLATE-LOGICAL-PATHNAME will retranslate the - result, repeatedly if necessary. Translations are listed in - the order listed, so more specific from-wildnames must precede more - general ones." - ;; would be nice to have host:: specify logical host if physical host - ;; already exists, to distinguish from host: - (gethash (canonicalize-logical-hostname host) - *logical-pathname-translations-table*)) -(defsetf logical-pathname-translations (host) (translations) - "(setf (logical-pathname-translations host) translations) sets the list - of translations for the logical pathname host to translations. If host - is a string that has not previously been used as a logical pathname - host, a new logical pathname host is defined; otherwise an existing - host's translations are replaced. Logical pathname host names are - compared with string-equal." - `(progn - (when (and *warn-about-host-type-collisions* - (physical-host-type ,host)) - (format t "~&Warning in (SETF LOGICAL-PATHNAME-TRANSLATIONS):~ - ~& ~S is defined as both a physical host and a logical host." - ,host)) - (setf (gethash (canonicalize-logical-hostname ,host) - *logical-pathname-translations-table*) - (eval-translations ,translations)))) - -;;; EVAL-TRANSLATIONS -;; -;;; Will receive a list of translations and it will evaluate the physical -;;; translation if it is not a string. This allows the user to put a format -;;; statement as the physical-translation. - -(defun eval-translations (translations) - (let (new_trans) - (nreverse - (dolist (translation translations new_trans) - (if (stringp (cadr translation)) - (setf new_trans (cons translation new_trans)) - (setf new_trans (cons (list (car translation) (eval (cadr translation))) new_trans))))))) - -;;; ******************************** -;;; Load Logical Translations ****** -;;; ******************************** -(defvar *logical-translations-directory* nil ; &&& - "Directory where logical pathname translations are stored.") -;;; (setq *logical-translations-directory* "/usr/local/lisp/Registry/") - -(defun LOAD-LOGICAL-PATHNAME-TRANSLATIONS (host) - "Loads the logical pathname translations for host named HOST if the logical - pathname translations are not already defined. First checks for a file - with the same name as the host (lowercase) and type \"translations\" in - the current directory, then the translations directory. If it finds such - a file it loads it and returns T, otherwise it signals an error." - (unless (logical-pathname-translations host) - (let* ((trans-fname (concatenate 'string (string-downcase host) - ".translations")) - (pathname (when *logical-translations-directory* - (merge-pathnames *logical-translations-directory* - trans-fname)))) - (cond ((probe-file trans-fname) - (load trans-fname) - t) - ((and *logical-translations-directory* - (probe-file pathname)) - (load pathname) - t) - (t - (error "Logical pathname translations for host ~A not found." - host)))))) - -;;; ******************************** -;;; Physical Host Tables *********** -;;; ******************************** -(defvar *physical-host-table* (make-hash-table :test #'equal) - "Table of physical hosts and system types for those hosts. - Valid (implemented) types include :vms, :explorer, :symbolics, :unix.") -(defun physical-host-type (host) - (gethash host *physical-host-table*)) -(defsetf physical-host-type (host) (type) - `(progn - (when (and *warn-about-host-type-collisions* - (logical-pathname-translations ,host)) - (format t "~&Warning in (SETF PHYSICAL-HOST-TYPE):~ - ~& ~S is defined as both a physical host and a logical host." - ,host)) - (setf (gethash ,host *physical-host-table*) - ,type))) - -(defconstant local-host-table ; &&& - #+:vms "chaos$root:[host.tables]nethosts.txt" - #-:vms "nethosts.txt") - -(defun load-physical-hostab (&optional (local-hostab local-host-table)) - "Loads the physical host namespace table. This is compatible with - vms and symbolics host tables. Hostab line format should look - something like: - HOST NAME,CHAOS-#,STATUS,SYSTEM-TYPE,MACHINE-TYPE,NICKNAMES - NAME and SYSTEM-TYPE are required; all others are optional (but delimiting - commas are still required). SYSTEM-TYPE specifies the operating system - run on the host. This information is used to figure out how to parse - pathnames for the host. Common values are: LISP, LISPM, UNIX, MACH, - VMS, and EXPLORER." - ;; What about SITE, SHORT-NAME, USER-PROPERTY, ADDRESS, PRETTY-NAME, - ;; and other Symbolics host attributes? - (when local-hostab - (with-open-file (hostab local-hostab :direction :input) - (do* ((host (read hostab nil :eof)(read hostab nil :eof)) - ;; host should be NET or HOST. - (line (read-line hostab nil :eof)(read-line hostab nil :eof))) - ;; Exit on end of file. - ((or (eq host :eof)(eq line :eof))) - ;; For each line in the host table, do - (cond ((null line) - (warn "Unexpected EOF in hostab ~S, exiting." local-hostab) - (return)) - ((string-equal (symbol-name host) "HOST") - ;; Delete spaces and tabs. - (setq line (delete #\tab (delete #\space line))) - (let ((pos 0) name system machine nicknames delim-not-found) - ;; Snarf the machine NAME. - (multiple-value-setq (name pos) - (parse-with-string-delimiter "," line :start pos)) - ;; Throw away chaos host numbers. - (setq pos - (nth-value 1 (parse-with-string-delimiter - (if (char-equal #\( (char line pos)) - ")," ",") - line :start pos))) - ;; Throw away status. - (setq pos - (nth-value 1 (parse-with-string-delimiter "," line - :start pos))) - ;; Snarf the system and machine types. - (multiple-value-setq (system pos) - (parse-with-string-delimiter "," line :start pos)) - (multiple-value-setq (machine pos delim-not-found) - (parse-with-string-delimiter "," line :start pos)) - (when (and (not delim-not-found) - (> (length line) pos)) - ;; Snarf the nicknames. - (setq nicknames - (parse-with-string-delimiter* - "," - (parse-with-string-delimiter "]" line - :start (1+ pos))))) - (unless (or (equal "" system) (null system)) - (when (equal "LISP" system) (setq system machine)) - (setq system (intern system 'keyword)) - (case system - ;; :vms, :ms-dos, etc are left alone. - ((:mach :unix :unix42) (setq system :unix)) - ((:lisp :lispm) (setq system :symbolics)) - ((:appaloosa :explorer) (setq system :explorer))) - (setf (physical-host-type name) system) - (dolist (name nicknames) - (setf (physical-host-type name) system)))))))))) - -(defun host-type (host) - "Returns the type of the host. If HOST is a defined logical pathname - host (i.e., it has translations), returns :logical. Otherwise checks - the physical type of the host. If HOST is NIL, uses the type of the - default physical host (the one lisp is running in)." - ;; Note that logical hosts have priority over physical hosts... - ;; This is a bad situation, since we don't have any way of - ;; distinguishing between host names that are both logical and physical. - ;; CLtL2 relies on the convention of naming them differently, but - ;; collisions are going to occur. It would be better to have some - ;; way of distinguishing the two in a pathname's printed representation. - (cond ((multiple-value-bind (ignore present) - (logical-pathname-translations host) - ;; Yet another use for nth-value. - (declare (ignore ignore)) - present) - :logical) - ((physical-host-type host)))) - -(defun pathname-host-type (pathname) - (cond ((typep pathname 'logical-pathname) :logical) - ((typep pathname 'physical-pathname) - (host-type (physical-pathname-host pathname))) - ((stringp pathname) (host-type (get-host-string pathname ":"))))) - -;;; Setup Default Physical Host -(eval-when (load eval) ; &&& -(setf (physical-host-type nil) ; nil is default host - (or #+:vms :vms - #+:explorer :explorer - #+:symbolics :symbolics - #+:unix :unix - #+:hp :unix - #+:cmu :unix - :unix ; default. change if necessary - )) -(setf (physical-host-type "Default") - (physical-host-type nil)) -) - -;;; ******************************** -;;; Translation Rules ************** -;;; ******************************** -(defstruct translation-rule - host-type - case ; Default case of pathname - char-mappings ; Character substitutions - component-mappings ; String substitutions - version-case ; Case for version component - type-case ; Case for type component - name-case ; Case for name - component-case ; Case for directory names - ) - -(defvar *permanent-translation-rules* (make-hash-table :test #'equal) - "Hash table of default translation rules for each type of host.") - -(defvar *default-translation-rule* (make-translation-rule)) - -(defmacro define-translation-rule (host-type - &key case char-mappings component-mappings - version-case - type-case - name-case - component-case) - "Defines translation rules for hosts of type host-type. - Case may be :unchanged, :upper, :lower, or :capitalize. This provides a - default case translation; version-case, type-case, name-case, and - component-case will shadow this value if non-nil. - Char-mappings is a list of character substitutions which occur in parallel. - Component-mappings is a list of string substitutions." - ;; Note: Currently there is only one rule per host-type. - `(setf (gethash ,host-type *permanent-translation-rules*) - (make-translation-rule :host-type ',host-type - :case ',case - :char-mappings ',char-mappings - :component-mappings ',component-mappings - :version-case ',version-case - :type-case ',type-case - :name-case ',name-case - :component-case ',component-case))) - -(defun find-translation-rule (host-type) - (or (gethash host-type *permanent-translation-rules*) - *default-translation-rule*)) - -(defun choose-case (rule level) - (or (case level - (version (translation-rule-version-case rule)) - (type (translation-rule-type-case rule)) - (name (translation-rule-name-case rule)) - (component (translation-rule-component-case rule))) - (translation-rule-case rule))) - -(defun casify (thing case) - (if (stringp thing) - (case case - (:upper (string-upcase thing)) - (:lower (string-downcase thing)) - (:capitalize (string-capitalize thing)) - (:unchanged thing) - (otherwise thing)) - thing)) - -(define-translation-rule :vms - :case :upper :char-mappings ((#\- #\_))) - -(define-translation-rule :unix - :case :unchanged ; :lower - :type-case :lower - ) - -(define-translation-rule :logical - :case :upper - :name-case :unchanged) - -;;; ******************************** -;;; Canonical Types **************** -;;; ******************************** -(defvar *default-canonical-types* (make-hash-table :test #'equal) - "Alists of canonical types and default surface types.") -(defvar *canonical-types-alist* (make-hash-table :test #'equal) - "Alists of canonical types and surface types for various hosts.") - -(defmacro define-canonical (level canonical default &body specs) - "Defines a new canonical type. Level specifies whether it is a - canonical type, version, name, or component. Default is a string - containing the default surface type for any kind of host not - mentioned explicitly. The body contains a list of specs that define - the surface types that indicate the new canonical type for each host. - For systems with more than one possible default surface form, - the form that appears first becomes the preferred form for the type." - `(progn - (setf (gethash ',level *default-canonical-types*) - (cons (list ',canonical ',default) - (remove ',canonical - (gethash ',level *default-canonical-types*) - :key #'car))) -; (push (list ',canonical ',default) -; (gethash ',level *default-canonical-types*)) - (setf (gethash ',level *canonical-types-alist*) - (cons (list* ',canonical ',specs) - (remove ',canonical - (gethash ',level *canonical-types-alist*) - :key #'car))) -; (push (list* ',canonical ',specs) -; (gethash ',level *canonical-types-alist*)) - )) - -(defun member-or-eq (x list-or-atom) - (cond ((listp list-or-atom) (member x list-or-atom)) - (t (eq x list-or-atom)))) - -(defun surface-form (canonical host-type &optional (level 'type)) - "Given the canonical form of some canonical type, replaces it with - the appropriate surface form." - (let ((case (choose-case (find-translation-rule host-type) level))) - (casify (or (second (assoc host-type - (cdr (assoc canonical - (gethash level - *canonical-types-alist*) - :test #'equal)) - :test #'member-or-eq)) - (second (assoc canonical - (gethash level *default-canonical-types*) - :test #'equal)) - canonical) - case))) - -(defun canonicalize (surface-form host-type &optional (level 'type)) - "Given the surface form of some canonical type, replaces it with - the appropriate canonical type." - (cond ((stringp surface-form) - (or (first (find surface-form (gethash level *canonical-types-alist*) - :key #'cdr - :test #'(lambda (surf alist) - (member surf - (cdr (assoc host-type alist - :test #'member-or-eq)) - :test #'string-equal)))) - (first (find surface-form - (gethash level *default-canonical-types*) - :key #'second :test #'string-equal)) - (coerce surface-form 'simple-string))) - (t surface-form))) - - -;;; *** Some Sample Types *** - -(define-canonical host :default "" - (:unix #+:CMU "Mach" "" "Default")) - -(define-canonical host "Default" "" - (:unix nil "" "Default")) - -(define-canonical device :unspecific "") - -(define-canonical component :absolute "" - (:unix "/") - (:symbolics ">") - (:logical "") - (:vms "")) -(define-canonical component :relative "" - (:unix "") - (:symbolics "") - (:logical ";") - (:vms ".")) -(define-canonical component :wild "*") -(define-canonical component :wild-inferiors "**" - (:vms "..")) - -(define-canonical name :wild "*") - -(define-canonical type :unspecific "") ;; null type -(define-canonical type :wild "*") ;; wild type - -;; uncommented the "L" causes the last Steele example to break, of course. -(define-canonical type :lisp "LISP" - (:unix-ucb "LISP") - (:unix #+(and :sun :kcl :unix) "lsp" - #+ecl "lsp" - "lisp" ; "L" #+:excl "cl" -) - (:vms "LSP" "LISP") - ;; (:vms4 "LSP" "LISP") - ((:tops-20 :tenex) "LISP" "LSP")) - -(define-canonical type :text "TEXT" - (:unix "text" "txt" "tx") - (:vms "TXT") - ((:tops-20 :tenex) "TXT")) - -(define-canonical type :fasl "FASL" - (:unix #+:hp "b" - #+(and :sun :kcl :unix) "o" - #+ecl "o" - #+:cmu "fasl" - "fasl" "bin" "BN") - (:vms "FAS" "BIN") - (:explorer "XLD") - (:symbolics "BIN") - ((:tops-20 :tenex) "BIN")) - -(define-canonical version :wild "*") -(define-canonical version :newest "newest") - -#| -;;; Examples: - (lp::canonicalize "*" :unix) -:WILD - (lp::surface-form :fasl :unix) -"fasl" - (lp::surface-form :fasl :vms) -"FAS" -|# - - -;;; ******************************** -;;; Pathname Defstruct ************* -;;; ******************************** -;;; -;;; We define a generic physical pathname (physical-pathname defstruct) because -;;; we have absolutely NO guarrantees about the structure of pathnames. -;;; Pathnames may be defstructs or classes, and the slots may have arbitrary -;;; types, especially with respect to the directory slot. Depending on the -;;; lisp, the directory slot may be a list, vector, simple-vector, -;;; string, keyword, or nil. If a list or vector, the items in the list -;;; may be strings, keywords (for canonical types), or nil. The first item -;;; in the list may or may not be a special keyword (e.g., :relative and -;;; :absolute). -;;; -;;; The lack of a common interface to pathnames means that any implementation -;;; of logical pathnames must parse and generate the pathname (namestring) -;;; formats for a variety of file-servers. We can't simply rely on the -;;; lisp's implementation of the PATHNAME defstruct, because that does not -;;; necessarily handle the formats of file-servers of a different type -;;; (translations may be in the format of the target file server). Also, -;;; inconsistency in the implementation of the PATHNAME type means that we -;;; would have to special case most of the code for each and every lisp. -;;; -;;; Instead, we parse the pathnames into a common format (the physical-pathname -;;; defstruct), from which we generate a namestring in a format acceptable -;;; to the underlying lisp. The namestring (which is a string in *all* the -;;; lisps) serves as the interface to the lisp's implementation of pathnames. -;;; -;;; As it currently stands, X3J13's spec for logical pathnames tries to -;;; accomplish two distinct goals: -;;; (1) isolate pathname reference from actual file location (logical -;;; as opposed to physical pathnames) -;;; (2) provide a common format for namestring syntax and -;;; pathname structure -;;; This is trying to accomplish too much within a single framework. Instead, -;;; the second goal should be decoupled from logical pathnames and made a -;;; requirement for pathnames in general. -;;; -;;; In other words, let there be a standard namestring syntax and a fully -;;; specified structure for physical pathnames (not just logical pathnames). -;;; This standard should subsume the requirements of all current lisps, and -;;; the individual lisp implementation should worry about interfacing with -;;; the file system. There is no good reason why a programmer should have -;;; to know the peculiarities of a filesystem when writing software. The X3J13 -;;; spec just shoves it under the rug, forcing the programmer to deal with -;;; it when writing the translations file. -;;; -;;; Because there is no standard for pathnames, we're forced into a situation -;;; where different lisps running on the same physical host may have -;;; different namestring syntaxes, so knowing the physical host type is not -;;; a guarrantee of the pathname syntax. -;;; -(defstruct (physical-pathname - (:conc-name %physical-pathname-) - (:print-function %print-physical-pathname) - (:constructor %make-physical-pathname - (host device directory name type version)) - (:predicate physical-pathnamep)) - "Physical-Pathname is the underlying structure for a pathname." - (host nil :type (or null keyword simple-string)) - (device nil :type (or null keyword simple-string)) - (directory nil :type (or null simple-vector)) - (name nil :type (or null keyword simple-string)) - (type nil :type (or null keyword simple-string)) - version) - -(defun %print-physical-pathname (pname stream depth) - (declare (ignore depth)) - (format stream "#.(physical-pathname ~S)" (physical-namestring pname))) - -(defun make-physical-pathname (&key host device directory name type version) - (let ((host-type (host-type host))) - (when (stringp directory) - (setq directory - (%physical-pathname-directory (parse-generic-namestring directory - host)))) - (%make-physical-pathname - (canonicalize host host-type 'host) - (canonicalize device host-type 'device) - directory - (canonicalize name host-type 'name) - (canonicalize type host-type 'type) - (canonicalize version host-type 'version) - ))) - -(defun ensure-physical-pathname (thing) - (if (physical-pathnamep thing) thing (physical-pathname thing))) - -;;; The following cannot be done by the accessors because the pathname -;;; arg may be a string. - -(defun physical-pathname-host (pathname) - "Returns the host of PATHNAME, which may be a string or pathname." - (%physical-pathname-host (ensure-physical-pathname pathname))) - -(defun physical-pathname-device (pathname) - "Returns the device of PATHNAME, which may be a string or pathname." - (%physical-pathname-device (ensure-physical-pathname pathname))) - -(defun physical-pathname-directory (pathname) - "Returns the directory of PATHNAME, which may be a string or pathname." - (%physical-pathname-directory (ensure-physical-pathname pathname))) - -(defun physical-pathname-name (pathname) - "Returns the name of PATHNAME, which may be a string or pathname." - (%physical-pathname-name (ensure-physical-pathname pathname))) - -(defun physical-pathname-type (pathname) - "Returns the type of PATHNAME, which may be a string or pathname." - (%physical-pathname-type (ensure-physical-pathname pathname))) - -(defun physical-pathname-version (pathname) - "Returns the version of PATHNAME, which may be a string or pathname." - (%physical-pathname-version (ensure-physical-pathname pathname))) - -;;; ******************************** -;;; Logical Pathname Defstruct ***** -;;; ******************************** -(defstruct (logical-pathname - (:include physical-pathname) - (:conc-name %logical-pathname-) - (:print-function %print-logical-pathname) - (:constructor %make-logical-pathname - (host device directory name type version)) - (:predicate logical-pathnamep)) - "Logical-pathname is the underlying structure for a logical pathname.") - -(defun %print-logical-pathname (pname stream depth) - (declare (ignore depth)) - (format stream "#.(logical-pathname ~S)" (logical-namestring pname))) - -(defun make-logical-pathname (&key host directory name type version) - (let ((host-type (host-type host))) - (when (stringp directory) - (setq directory - (%logical-pathname-directory (parse-generic-namestring directory - host)))) - (%make-logical-pathname - (canonicalize host host-type 'host) - :unspecific - directory - (canonicalize name host-type 'name) - (canonicalize type host-type 'type) - (canonicalize version host-type 'version) - ))) - -(defun ensure-logical-pathname (thing) - (if (logical-pathnamep thing) thing (logical-pathname thing))) - -;;; The following cannot be done by the accessors because the pathname -;;; arg may be a string. - -(defun logical-pathname-host (logical-pathname) - "Returns the logical-pathname-host of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-host (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-directory (logical-pathname) - "Returns the logical-pathname-directory of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-directory (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-name (logical-pathname) - "Returns the logical-pathname-name of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-name (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-type (logical-pathname) - "Returns the logical-pathname-type of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-type (ensure-logical-pathname logical-pathname))) - -(defun logical-pathname-version (logical-pathname) - "Returns the logical-pathname-type of LOGICAL-PATHNAME. - LOGICAL-PATHNAME may be a string or logical pathname." - (%logical-pathname-version (ensure-logical-pathname logical-pathname))) - - -;;; ******************************** -;;; Pathname Namestring Functions ** -;;; ******************************** -(defun logical-namestring (logical-pathname) - "Returns the full form of LOGICAL-PATHNAME as a string." - (setq logical-pathname (logical-pathname logical-pathname)) - (let ((host (%logical-pathname-host logical-pathname)) - (directory (%logical-pathname-directory logical-pathname)) - (name (%logical-pathname-name logical-pathname)) - (type (%logical-pathname-type logical-pathname)) - (version (%logical-pathname-version logical-pathname)) - result) - (declare (simple-string result)) - ;; FORMAT would have been easier, but this is faster. - (when host - (setq result - (concatenate 'simple-string - (surface-form host :logical 'host) ":"))) - (when directory - (setq result - (concatenate 'simple-string - result - (the simple-string (%directory-string directory))))) - (when name - (setq result - (concatenate 'simple-string - result - (the simple-string (surface-form name :logical 'name))))) - (when type - (setq result - (concatenate 'simple-string - result "." - (the simple-string (surface-form type :logical 'type))))) - (when version - (setq result - (concatenate 'simple-string - result "." - (the simple-string - (%version-to-string version))))) - result)) - -(defun %directory-string (dirlist &optional (host-type :logical) - (dir-delim #\;)) - "Converts a vector of the form #(\"foo\" \"bar\" ... \"baz\") into - a string of the form \"foo;bar;...;baz;\"" - (declare (simple-vector dirlist)) - (let* ((numdirs (length dirlist)) - (length numdirs)) - (declare (fixnum numdirs length)) - (dotimes (i numdirs) - (let ((component (#+:cmu svref #-:cmu aref dirlist i))) - (case component - ;; Do we have to worry about Lucid's :root here??? - ((:relative :absolute) - (incf length - (the fixnum - (1- (length (surface-form component - host-type 'component)))))) - (otherwise (incf length - (the fixnum - (length (surface-form component host-type - 'component)))))))) - (do ((result (make-string length)) - (index 0 (1+ index)) - (position 0)) - ((= index numdirs) result) - (declare (simple-string result)) - (let* ((component (#+:cmu svref #-:cmu aref dirlist index)) - (string (surface-form component host-type 'component)) - (len (length string)) - (end (+ position len))) - (declare (simple-string string) - (fixnum len end)) - (replace result string :start1 position :end1 end :end2 len) - (unless (or (eq component :absolute)(eq component :relative)) - (setf (schar result end) dir-delim) - (setq position (+ end 1))))))) - -(defun %version-to-string (version &optional (host-type :logical)) - (cond ((surface-form version host-type 'version)) - ((zerop version) "0") - ((eql version 1) "1") - (t - ;; Using FORMAT would have been easier, but this is faster. - (do* ((len (1+ (truncate (log version 10)))) ; base 10 num digits - (res (make-string len)) - (i (1- len) (1- i)) - (q version) ; quotient - (r)) ; residue - ((zerop q) ; nothing left - res) - (declare (simple-string res) - (fixnum len i r)) - (multiple-value-setq (q r) (truncate q 10)) - (setf (schar res i) (schar "0123456789" r)))))) - -(defun physical-namestring (pathname) - ;; needs to get appropriate surface forms - (setq pathname (physical-pathname pathname)) - (let* ((host (%physical-pathname-host pathname)) - (host-type (host-type host)) - (device (%physical-pathname-device pathname)) - (directory (coerce (%physical-pathname-directory pathname) 'list)) - (name (%physical-pathname-name pathname)) - (type (%physical-pathname-type pathname)) - (version (%physical-pathname-version pathname)) - (ptype (pathname-host-type pathname))) - (setq host (surface-form host host-type 'host) - name (surface-form name host-type 'name) - type (surface-form type host-type 'type) - version (surface-form version host-type 'version)) - ;; Does directory need to be mapcar'ed into surface-form? - ;; Yes, but we can probably ignore it for now, since the only - ;; canonical types defined so far are :wild and :wild-inferiors, - ;; which we don't have to support. Probably wouldn't hurt to - ;; uncomment this code. - ;;(setq directory - ;; (cons (car directory) - ;; (mapcar #'(lambda (comp) - ;; (surface-form comp host-type 'component)) - ;; (cdr directory)))) - (case ptype - (:logical - (logical-namestring pathname)) - (:unix - (format nil "~@[~A:~]~A~{~A/~}~@[~A~@[.~A~@[.~A~]~]~]" - host (case (car directory) - (:absolute "/") - (otherwise "")) - (cdr directory) - name type version)) - (:vms - ;; was "~@[~A:~]~@[~A:~][~A~{~A.~}]~@[~A~@[.~A~@[.~A~]~]~]" - ;; which was adding an extra "." to path - ;; such as [a.b] => [a.b.] - (format nil - "~@[~A:~]~@[~A:~][~A~{~A~^.~}]~@[~A~@[.~A~@[.~A~]~]~]" - host device (case (car directory) - (:relative ".") - (otherwise "")) - (cdr directory) - name type version)) - (:explorer - (format nil "~@[~A:~]~A~{~A~^.~};~@[~A~@[.~A~@[#~A~]~]~]" - host (case (car directory) - (:relative ".") - (otherwise "")) - (cdr directory) - name type version)) - (:symbolics - (format nil "~@[~A:~]~A~{~A>~}~@[~A~@[.~A~@[.~A~]~]~]" - host (case (car directory) - (:absolute ">") - (otherwise "")) - (cdr directory) - name type version)) - (otherwise - ;; Use UNIX as default. - (format nil "~@[~A:~]~A~{~A/~}~@[~A~@[.~A~@[.~A~]~]~]" - host (case (car directory) - (:absolute "/") - (otherwise "")) - (cdr directory) - name type version)) - ))) - -;;; ******************************** -;;; Pathname Parsing Functions ***** -;;; ******************************** -(defun logical-pathname (thing &optional host) - "Converts THING to a logical pathname and returns it. THING may be - a logical pathname, a logical pathname namestring containing a - host component, or a stream for which the pathname function returns - a logical pathname." - (etypecase thing - (string - (values (parse-generic-namestring thing host - *default-pathname-defaults* - :force-logical t))) - (physical-pathname thing) - (logical-pathname thing) - #+:CMU(stream (logical-pathname (lisp::file-name thing) host)))) - -(defun physical-pathname (thing &optional host) - "Converts THING to a physical-pathname and returns it. THING may be - a pathname, a pathname namestring containing a - host component, or a stream for which the file-name function returns - a pathname." - (typecase thing - (string (values (parse-generic-namestring thing host))) - (logical-pathname thing) - (physical-pathname thing) - #+:CMU(stream (physical-pathname (lisp::file-name thing) host)))) - -(defun parse-generic-namestring (thing &optional host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed - force-logical) - "Convert namestring into a pathname." - (declare (ignore junk-allowed)) - (unless end (setf end (length thing))) - (let ((host-string (get-host-string thing ":")) - host-type) - (unless host-string (setq host-string host)) - (when (and host host-string (not (string-equal host host-string))) - (cerror "Ignore it." - "Host mismatch in ~S: ~S isn't ~S" - 'parse-generic-namestring - host-string - host)) - (if force-logical - (setq host-type :logical) - (setq host-type (host-type host-string))) - (if host-type - (multiple-value-bind (parsed-host device directory name type version) - (do-generic-pathname-parse thing host-type start end) - (let ((defaults-p (and (typep defaults 'physical-pathname) - (equal host-type - (pathname-host-type defaults))))) - (values - (case host-type - (:logical - (make-logical-pathname - :host (or parsed-host host - (and defaults-p (logical-pathname-host defaults)) -; (when directory "Default") - ) - :directory (or directory - (and defaults-p - (logical-pathname-directory defaults))) - :name (or name - (and defaults-p - (logical-pathname-name defaults))) - :type (or type - (and defaults-p - (logical-pathname-type defaults))) - :version (or version - (and defaults-p - (logical-pathname-version defaults))))) - (otherwise - (make-physical-pathname - :host (or parsed-host host - (and defaults-p (physical-pathname-host defaults)) -; (when directory "Default") - ) - :device (or device - (and defaults-p - (physical-pathname-device defaults))) - :directory (or directory - (and defaults-p - (physical-pathname-directory defaults))) - :name (or name - (and defaults-p - (physical-pathname-name defaults))) - :type (or type - (and defaults-p - (physical-pathname-type defaults))) - :version (or version - (and defaults-p - (physical-pathname-version defaults)))))) - end))) - ;; Unknown host type, wing it with parse-namestring. - (when thing - (lisp:parse-namestring thing host defaults - :start start :end end))))) - -;;; ******************************** -;;; Parse Physical Pathnames ******* -;;; ******************************** -(defun do-generic-pathname-parse (string host-type &optional (start 0) end) - "Splits string into a logical host, a vector of directories, a file name, - a file type, and a file version." - (declare (simple-string string)) - (case host-type - (:logical - ;; Parses Logical Pathnames of the following format: - ;; host:dir1;dir2;name.type.version - (parse-generic-pathname string start end ":" nil ";" "." "." ".")) - (:unix - ;; Parses Unix pathnames of the following format: - ;; host:/dir1/dir2/*/name.type.version - (parse-generic-pathname string start end ":" t "/" "." "." ".")) - (:symbolics - ;; Parses Symbolics Pathnames of the following format: - ;; host:>dir1>dir2>**>name.type.version - (parse-generic-pathname string start end ":" t ">" "." "." ".")) - (:vms (parse-vms-pathname string start end)) - (:explorer (parse-explorer-pathname string start end)) - (otherwise (warn "~&PARSE-~A-PATHNAME not yet implemented.~%" host-type) - nil))) - -(defun parse-generic-pathname (string &optional (start 0) end - (host-delim ":")(lead-is-abs t) - (dir-delim "/") - (name-delim ".")(type-delim ".") - (version-delim ".")) - "Splits string into a host, vector of directories, a file name, type, - and version. Parses generic pathnames." - (declare (simple-string string)) - (setq end (or end (length string))) - (let (host a-vs-r directories name type version host-type) - (multiple-value-setq (host start) - (get-host-string string host-delim start end)) - (setq host-type (host-type host)) - ;; Absolute vs. Relative - (cond ((and (not (string-equal string "" :start1 start)) - (char= (char dir-delim 0) (char string start))) - (setq a-vs-r (if lead-is-abs :absolute :relative)) - (incf start)) - (t (setq a-vs-r (if lead-is-abs :relative :absolute)))) - ;; Split off the components - (multiple-value-bind (dirs new-start) - (parse-with-string-delimiter* dir-delim string :start start :end end) - (setq directories - (cons a-vs-r - (mapcar #'(lambda (dir) - (canonicalize dir host-type 'component)) - dirs)) - start new-start)) - ;; Split off the name, type, and version - (when (< start end) - (multiple-value-setq (name start) - (parse-with-string-delimiter name-delim string - :start start :end end)) - (when (< start end) - (multiple-value-setq (type start) - (parse-with-string-delimiter type-delim string - :start start :end end)) - (when (< start end) - (multiple-value-setq (version start) - (parse-with-string-delimiter version-delim string - :start start :end end))))) - ;; Return the values - (values host - :unspecific - (when (or host directories) - (coerce directories 'vector)) - name - type - version - ;; This last is the remaining cruft. Should be nil. - (when (< start end) (subseq string start end))))) - -(defun parse-vms-pathname (string &optional (start 0) end) - "Splits string into a host, vector of directories, a file name, type, - and version. Parses VMS pathnames of the following formats: - host::device:[dir1.dir2...]name.type;version - host::device:name.type.version - host:device:name.type.version &c - .. = :wild-inferiors" - (declare (simple-string string)) - (setq end (or end (length string))) - (let (host device a-vs-r (directories "") name type version) - (multiple-value-bind (new-host new-start) - (get-host-string string "::" start end) - (if new-host - (setq host new-host start new-start) - (multiple-value-setq (host start) (get-host-string string ":" start end)))) - (multiple-value-setq (device start) (get-host-string string ":" start end)) - (when (plusp (length string)) - (case (char string start) - (#\[ (multiple-value-setq (directories start) - (parse-with-string-delimiter "]" string - :start (1+ start) :end end))) - (#\< (multiple-value-setq (directories start) - (parse-with-string-delimiter ">" string - :start (1+ start) :end end))))) - ;; Absolute vs. Relative - (cond ((and (not (zerop (length directories))) - (char= #\. (char directories 0))) - (setq a-vs-r :relative)) - (t (setq a-vs-r :absolute))) - ;; Split off the components - (multiple-value-bind (dirs) - (parse-with-string-delimiter* "." directories - :start (if (eq a-vs-r :relative) 1 0) - :include-last t) ; <<< fix - (let ((last2 (when (> (length dirs) 1) - (nthcdr (- (length dirs) 2) dirs)))) - (when (equal last2 '(nil nil)) - (rplaca last2 "..") - (rplacd last2 nil))) - (setq directories - (cons a-vs-r - (mapcar #'(lambda (dir) (canonicalize dir :vms 'component)) - dirs)))) - ;; Split off the name, type, and version - (when (< start end) - (multiple-value-setq (name start) - (parse-with-string-delimiter "." string :start start :end end)) - (when (< start end) - (multiple-value-bind (new-type new-start delim-not-found) - (parse-with-string-delimiter ";" string :start start :end end) - (cond (delim-not-found - (multiple-value-setq (type start) - (parse-with-string-delimiter "." string - :start start :end end))) - (t - (setq type new-type start new-start)))) - (when (< start end) - (multiple-value-setq (version start) - (parse-with-string-delimiter "." string :start start :end end))))) - ;; Return the values - (values host - device - (when (or host directories) - (coerce directories 'vector)) - name - type - version - ;; This last is the remaining cruft. Should be nil. - (when (< start end) (subseq string start end))))) - -(defun parse-explorer-pathname (string &optional (start 0) end) - "Splits string into a host, vector of directories, a file name, type, - and version. Parses TI Explorer pathnames of the following format: - host:dir1.dir2...;name.type#version" - (declare (simple-string string)) - (setq end (or end (length string))) - (let (host a-vs-r (directories "") name type version) - (multiple-value-setq (host start) - (get-host-string string ":" start end)) - (multiple-value-setq (directories start) - (parse-with-string-delimiter ";" string - :start start :end end)) - ;; Absolute vs. Relative - (cond ((and (not (zerop (length directories))) - (char= #\. (char directories 0))) - (setq a-vs-r :relative)) - (t (setq a-vs-r :absolute))) - ;; Split off the components - (multiple-value-bind (dirs) - (parse-with-string-delimiter* "." directories - :start (if (eq a-vs-r :relative) 1 0) - :end nil :include-last t) - - (setq directories - (cons a-vs-r - (mapcar #'(lambda (dir) - (canonicalize dir :explorer 'component)) - dirs)))) - ;; Split off the name, type, and version - (when (< start end) - (multiple-value-bind (new-name new-start delim-not-found) - (parse-with-string-delimiter "." string :start start :end end) - (when (not delim-not-found) - (setq name new-name start new-start))) - (when (< start end) - (multiple-value-setq (type start) - (parse-with-string-delimiter "#" string :start start :end end)) - (when (< start end) - (multiple-value-setq (version start) - (parse-with-string-delimiter "." string :start start :end end))))) - ;; Return the values - (values host - :unspecific - (when (or host directories) - (coerce directories 'vector)) - name - type - version - ;; This last is the remaining cruft. Should be nil. - (when (< start end) (subseq string start end))))) - - -;;; ******************************** -;;; Convert Generic Pathnames ****** -;;; ******************************** -;;; Converts a generic pathname to a format for standard lisp functions. - -(defvar *translation-output* :namestring - "Specifies whether the output of translate-logical-pathname - should be a :namestring or a :pathname made with lisp:make-pathname, - or :as-is.") - -(defconstant directory-structure-type ; &&& - #+:CMU 'simple-vector - #+:lispm 'list - #+:kcl 'list - #+:ecl 'list - #+:hp 'list - #-(or :cmu :lispm :kcl :ecl :hp) - (cond ((string-equal (lisp-implementation-type) "VAX LISP") 'list) - (t 'list))) - -(defun convert-generic-pathname (pathname - &optional (output-type *translation-output*)) - (when pathname - (case output-type - (:namestring (physical-namestring pathname)) - (:pathname - (let ((host (%physical-pathname-host pathname)) - (device (%physical-pathname-device pathname)) - (directory (coerce (%physical-pathname-directory pathname) - 'list)) - (name (%physical-pathname-name pathname)) - (type (%physical-pathname-type pathname)) - (version (%physical-pathname-version pathname)) - (target-host-type (host-type nil)) - a-vs-r) - ;; Handle :absolute/:relative crap. - (setq a-vs-r (pop directory)) - (case a-vs-r - (:absolute - #+:cmu (setf device :absolute) - #+(and :sun :kcl :unix) (setq a-vs-r :root) - #+ecl (setq a-vs-r :root)) - (:relative - #+:cmu (setf device "Default"))) - ;; Reverse canonicalizations - (setq host (surface-form host target-host-type 'host) - directory (mapcar #'(lambda (dir) - (surface-form dir target-host-type - 'component)) - directory) - name (surface-form name target-host-type 'name) - type (surface-form type target-host-type 'type) - version (surface-form version target-host-type 'version)) - ;; Fixup Host - #+:cmu (setf host "Mach") - ;; Fixup Directory - #-:cmu (push a-vs-r directory) - (setq directory (coerce directory directory-structure-type)) - - (when (string-equal (lisp-implementation-type) "VAX LISP") - (setq directory - (cond ((stringp directory) directory) - ((eq (car directory) :absolute) - (format nil "[~{~A~^.~}]" (cdr directory))) - ((eq (car directory) :relative) - (format nil "[.~{~A~^.~}]" (cdr directory))) - (t (format nil "[~{~A~^.~}]" directory))))) - - ;; Return the new pathname - (make-pathname :host host :device device :directory directory - :name name :type type :version version) - )) - (otherwise pathname)))) - - -;;; ******************************** -;;; Translate Logical Pathnames **** -;;; ******************************** -(defvar *circularity-check-table* (make-hash-table :test #'equal) - "This table is used to prevent infinite circular loops in the logical - pathname resolution. If a pathname's entry in this table is set - to T, it has already been \"seen\". Seeing such a pathname twice - is an error.") - -(defun translate-logical-pathname (logical-pathname - &optional - (output-format *translation-output*)) - "Translates a logical pathname to the corresponding physical pathname. - The pathname argument is first coerced to a logical pathname [this - should really be pathname, but for that we'd have to redefine - make-pathname and friends to check whether the host is a logical host]. - If the coerced argument is a logical pathname, the first matching - translation (according to LOGICAL-PATHNAME-MATCH-P) of the logical pathname - host is applied, as if by calling TRANSLATE-LOGICAL-PATHNAME-AUX. - If the result is a logical pathname, this process is repeated. - When the result is finally a physical pathname, it is returned. If no - translation matches a logical pathname, or the resolution process loops, - an error is signaled. - - TRANSLATE-LOGICAL-PATHNAME may perform additional translations, - to provide translation of file types to local naming conventions, to - accommodate physical file systems with names of limited length, or to - deal with special character requirements such as translating hyphens - to underscores or uppercase letters to lowercase." - - ;; Ensure that it is a logical pathname - (setq logical-pathname (logical-pathname logical-pathname)) - (when (typep logical-pathname 'logical-pathname) - ;; To prevent circular loops... - (let ((namestring (logical-namestring logical-pathname))) - (setf (gethash namestring *circularity-check-table*) T)) - (unwind-protect - (resolve-logical-pathname logical-pathname output-format) - (clrhash *circularity-check-table*)))) - -(defun resolve-logical-pathname (logical-pathname - &optional - (output-format *translation-output*)) - "Resolve the logical pathname into a physical pathname using the - translations table." - (let ((logical-host (logical-pathname-host logical-pathname))) - (if logical-host - (let ((translated-pathname - (map-logical-pathname logical-pathname logical-host - output-format))) - (if translated-pathname - (or (when (eq (pathname-host-type translated-pathname) :logical) - ;; If the translation is itself a logical pathname, - ;; repeat the process until a physical pathname is reached. - (check-logical-pathname translated-pathname) - (resolve-logical-pathname translated-pathname - output-format)) - translated-pathname) - (error "No translation mapping for ~S." logical-pathname))) - (error "No such logical host in ~S:." logical-pathname)))) - -(defun check-logical-pathname (pathname) - "Ensure that there are no cycles in the translations." - (let ((namestring (logical-namestring pathname))) - (if (gethash namestring *circularity-check-table*) - (error "Circularity in translations for ~S." namestring) - (setf (gethash namestring *circularity-check-table*) T)))) - -(defun map-logical-pathname (logical-pathname - host - &optional (output-format *translation-output*)) - "Find and execute the first matching translation." - (dolist (translation (logical-pathname-translations host)) - (let ((from-pathname (logical-pathname (car translation) host)) - (to-pathname (cadr translation))) - (when (logical-pathname-match-p logical-pathname from-pathname) - (return (translate-logical-pathname-aux logical-pathname - from-pathname - to-pathname - output-format)))))) - -(defun logical-pathname-match-p (logical-pathname from-pathname) - "Return T if the logical pathname matches the test pathname." - (setq logical-pathname (logical-pathname logical-pathname) - from-pathname (logical-pathname from-pathname)) - ;; ignore host. Match directories. Match name. Match type. Match version. - (and (match-directories (logical-pathname-directory from-pathname) - (logical-pathname-directory logical-pathname)) - (match-wildcard-word (logical-pathname-name from-pathname) - (logical-pathname-name logical-pathname)) - (match-wildcard-word (logical-pathname-type from-pathname) - (logical-pathname-type logical-pathname)) - (match-wildcard-word (logical-pathname-version from-pathname) - (logical-pathname-version logical-pathname)))) - -(defun translate-logical-pathname-aux (logical-pathname - from-pathname to-pathname - &optional - (output-format *translation-output*)) - "Translates the logical pathname using the substitution specified by - a particular translation." - (let* ((host (physical-pathname-host to-pathname)) - (host-type (host-type host)) - (translation-rule (find-translation-rule host-type)) - (char-map (translation-rule-char-mappings translation-rule)) - (string-map (translation-rule-component-mappings translation-rule))) - (let ((device (physical-pathname-device to-pathname)) - (directories (map-directories - (physical-pathname-directory logical-pathname) - (physical-pathname-directory from-pathname) - (physical-pathname-directory to-pathname) - *null-vector* 0 0 0 - (choose-case translation-rule 'component) - char-map string-map)) - (name (map-wildcard-word (physical-pathname-name logical-pathname) - (physical-pathname-name from-pathname) - (physical-pathname-name to-pathname) - (choose-case translation-rule 'name) - char-map string-map)) - (type (map-wildcard-word (physical-pathname-type logical-pathname) - (physical-pathname-type from-pathname) - (physical-pathname-type to-pathname) - (choose-case translation-rule 'type) - char-map string-map)) - (version (map-wildcard-word (physical-pathname-version logical-pathname) - (physical-pathname-version from-pathname) - (physical-pathname-version to-pathname) - (choose-case translation-rule 'version) - char-map string-map))) - (cond ((eq (pathname-host-type to-pathname) :logical) - (make-logical-pathname :host host - :directory directories - :name name - :type type - :version version)) - (t - (convert-generic-pathname - (make-physical-pathname :host host - :device device - :directory directories - :name name - :type type - :version version) - output-format)))))) - -;;; ******************************** -;;; Match and Map Wildcards ******** -;;; ******************************** -(defun wildcard-wordp (string) - (find #\* string)) - -(defun must-match (thing) - (or (eq thing :wild) - (and (stringp thing) - (wildcard-wordp thing)))) - -(defun match-wildcard-word (template string) - ;; "*" standalone (:wild) is treated differently from "*" within - ;; a word. - (or (eq template :wild) - (null template) - (and (stringp string) (stringp template) - (match-strings template string)) - ;; e.g., :absolute :absolute - (eq template string))) - -(defun match-strings (template string &optional (t-start 0) (s-start 0)) - (let* ((t-length (length template)) - (s-length (length string)) - (t-at-end (= t-length t-start)) - (s-at-end (= s-length s-start))) - (cond ((or t-at-end s-at-end) ; if at end of template or string - (and t-at-end s-at-end)) ; both must be at the end. - ((char= #\* (char template t-start)) - (or (match-strings template string (1+ t-start) s-start) - (match-strings template string t-start (1+ s-start)) - (match-strings template string (1+ t-start) (1+ s-start)))) - ((char-equal (char template t-start) - (char string s-start)) ; includes * against * - (match-strings template string (1+ t-start) (1+ s-start)))))) - -(defun match-directories (template dirs &optional (t-start 0) (d-start 0)) - (let* ((t-length (length template)) - (d-length (length dirs)) - (t-at-end (= t-length t-start)) - (d-at-end (= d-length d-start))) - (cond ((or t-at-end d-at-end) - (and t-at-end d-at-end)) - ((eq (#+:cmu svref #-:cmu aref template t-start) :wild-inferiors) - ;; :wild-inferiors matches any number of components, including - ;; zero. First try skipping over the :wild-inferiors. If that fails, - ;; try matching against one component without skipping over the - ;; :wild-inferiors. Finally, try matching against one component - ;; while skipping over the :wild-inferiors (the latter really - ;; isn't necessary, since the first 2 cases include it). - (or (match-directories template dirs (1+ t-start) d-start) - (match-directories template dirs t-start (1+ d-start)) - (match-directories template dirs (1+ t-start) (1+ d-start)))) - ((match-wildcard-word (#+:cmu svref #-:cmu aref template t-start) - (#+:cmu svref #-:cmu aref dirs d-start)) - (match-directories template dirs (1+ t-start) (1+ d-start)))))) - -(defun map-wildcard-word (string source target - &optional case char-mappings string-mappings) - (let ((result - (cond ((and (stringp target) - (not (wildcard-wordp target))) - ;; If the target pattern does not contain *, copy the target - ;; pattern component literally to the target instance. - target) - ((or (eq target :wild) (null target)) - ;; If the target pattern is :wild, copy the source string - ;; component to the target string literally with no further - ;; analysis. This holds even for the type, which is - ;; represented internally in terms of canonical types, - ;; and is "translated" when realized for the new host. - string) - ((not (stringp target)) - target) - ((eq source :wild) - (map-strings string string target)) - (t (map-strings string source target))))) - (when (stringp result) - (setq result - (casify (parallel-substitute char-mappings - (name-substitution string-mappings - result)) - case))) - result)) - -(defun map-strings (string source target - &optional (result "") - (s-start 0) (st-start 0) (tt-start 0)) - (let* ((s-length (length string)) - (st-length (length source)) - (tt-length (length target)) - (s-at-end (= s-length s-start)) - (st-at-end (= st-length st-start)) - (tt-at-end (= tt-length tt-start))) - (cond ((or s-at-end st-at-end) - ;; When not enough matching values are available due to too few - ;; * in the source pattern, use the null string as the matching - ;; value for any * remaining in the target. - (when (and s-at-end st-at-end) - (concatenate 'simple-string - result - (delete #\* (subseq target tt-start))))) - (tt-at-end - ;; When the source pattern has too many *, ignore the first - ;; extra * and everything following it. - result) - ((char= #\* (char target tt-start)) - ;; Replace * in target pattern with the contents of the source - ;; string specified by the next * in the source pattern. - (cond ((char= #\* (char source st-start)) - (or (map-strings string source target result - s-start (1+ st-start) (1+ tt-start)) - (map-strings string source target - (concatenate 'simple-string result - (subseq string s-start - (1+ s-start))) - (1+ s-start) st-start tt-start))) - ((char-equal (char source st-start) ; was char= - (char string s-start)) - (map-strings string source target result - (1+ s-start) (1+ st-start) tt-start)))) - (t;; copy literal strings as is from the target - (let ((next-* (position #\* target :start tt-start))) - (if next-* - (map-strings string source target - (concatenate 'simple-string result - (subseq target tt-start next-*)) - s-start st-start next-*) - (when (match-strings source string st-start s-start) - (concatenate 'simple-string - result (subseq target tt-start))))))))) - -(defun map-directories (dirs source target - &optional (result *null-vector*) - (d-start 0) (s-start 0) (t-start 0) - case char-map string-map) - (let* ((d-length (length dirs)) - (s-length (length source)) - (t-length (length target)) - (d-at-end (= d-length d-start)) - (s-at-end (= s-length s-start)) - (t-at-end (= t-length t-start))) - (cond ((or d-at-end s-at-end) - (when (and d-at-end s-at-end) - (concatenate 'simple-vector result - (map 'simple-vector - #'(lambda (x) - (map-wildcard-word - "" "" x - case char-map string-map)) - (delete :wild-inferiors - (subseq target t-start)))))) - (t-at-end - (when (match-directories source dirs s-start d-start) - result)) - ((eq :wild-inferiors (#+:cmu svref #-:cmu aref target t-start)) - (cond ((eq :wild-inferiors (#+:cmu svref - #-:cmu aref source s-start)) - (or (map-directories dirs source target result - d-start (1+ s-start) (1+ t-start) - case char-map string-map) - (map-directories dirs source target - (concatenate 'simple-vector result - (list (map-wildcard-word - (#+:cmu svref - #-:cmu aref - dirs d-start) - :wild :wild - case char-map - string-map))) - (1+ d-start) s-start t-start - case char-map string-map) - (map-directories dirs source target - (concatenate 'simple-vector result - (list (map-wildcard-word - (#+:cmu svref - #-:cmu aref - dirs d-start) - :wild :wild - case char-map - string-map))) - (1+ d-start) (1+ s-start) (1+ t-start) - case char-map string-map))) - ((string-equal (#+:cmu svref #-:cmu aref dirs d-start) - (#+:cmu svref #-:cmu aref source s-start)) - (map-directories dirs source target result - (1+ d-start) (1+ s-start) t-start - case char-map string-map)))) - ((must-match (#+:cmu svref #-:cmu aref target t-start)) - (cond ((must-match (#+:cmu svref #-:cmu aref source s-start)) - (map-directories dirs source target - (concatenate 'simple-vector result - (list (map-wildcard-word - (#+:cmu svref - #-:cmu aref dirs d-start) - (#+:cmu svref - #-:cmu aref source s-start) - (#+:cmu svref - #-:cmu aref target t-start) - case char-map string-map))) - (1+ d-start) (1+ s-start) (1+ t-start) - case char-map string-map)) - ((string-equal (#+:cmu svref #-:cmu aref dirs d-start) - (#+:cmu svref #-:cmu aref source s-start)) - (map-directories dirs source target result - (1+ d-start) (1+ s-start) t-start - case char-map string-map)))) - (t - (map-directories dirs source target - (concatenate 'simple-vector result - (list - (map-wildcard-word - (#+:cmu svref - #-:cmu aref target t-start) - :wild :wild - case char-map - string-map))) - d-start s-start (1+ t-start) - case char-map string-map))))) - - -;;; ******************************** -;;; Common Lisp Redefinitions ****** -;;; ******************************** -;;; Not doing merge-pathnames or with-open-file. Parse-namestring not -;;; really done well. - -;;; append-directories -(defun append-logical-directories (absolute-dir relative-dir) - (when (or absolute-dir relative-dir) - (setq absolute-dir (logical-pathname (or absolute-dir "")) - relative-dir (logical-pathname (or relative-dir ""))) - (logical-namestring - (make-logical-pathname - :host (or (logical-pathname-host absolute-dir) - (logical-pathname-host relative-dir)) - :directory (concatenate 'simple-vector - (logical-pathname-directory absolute-dir) - (cdr (coerce (logical-pathname-directory - relative-dir) - 'list))) - :name (or (logical-pathname-name absolute-dir) - (logical-pathname-name relative-dir)) - :type (or (logical-pathname-type absolute-dir) - (logical-pathname-type relative-dir)) - :version (or (logical-pathname-version absolute-dir) - (logical-pathname-version relative-dir)))))) - -(eval-when (compile load eval) -(defun real-filename (filename) - (if (and filename - (eq (pathname-host-type filename) :logical)) - (translate-logical-pathname filename :namestring) - filename)) - -#| -(defmacro convert-file-function (name &optional optionalp) - (let ((old-name (intern (concatenate 'string "OLD-" (string name))))) - `(unless (fboundp ',old-name) - (setf (symbol-function ',old-name)(symbol-function ',name)) - (setf (symbol-function ',name) - #'(lambda ,(if optionalp - '(&optional filename &rest args) - '(filename &rest args)) - (apply #',old-name (real-filename filename) args)))))) -|# - -(defmacro convert-file-function (name &optional optionalp) - (let ((old-name (intern (concatenate 'string "OLD-" (string name))))) - `(unless (fboundp ',old-name) - ;; Yes, some lisps will give compiler warnings about OLD-name - ;; not being declared or defined as a function. But what can - ;; we do, with most lisps not yet recognizing CLtL2's ftype - ;; declaration? - (setf (symbol-function ',old-name)(symbol-function ',name)) - (setf (symbol-function ',name) - #'(lambda ,(if optionalp - '(&optional filename &rest args) - '(filename &rest args)) - ,(if optionalp - `(if filename - (apply #',old-name (real-filename filename) args) - (,old-name)) ; instead of (funcall #',old-name) - `(apply #',old-name (real-filename filename) args))))))) - -(defmacro convert-file-function-2-args (name) - (let ((old-name (intern (concatenate 'string "OLD-" (string name))))) - `(unless (fboundp ',old-name) - (setf (symbol-function ',old-name)(symbol-function ',name)) - (setf (symbol-function ',name) - #'(lambda (filename1 filename2 &rest args) - (apply #',old-name - (real-filename filename1)(real-filename filename2) - args)))))) -) - -(convert-file-function lisp::load) -(convert-file-function lisp::open) -(convert-file-function lisp::probe-file) -(convert-file-function lisp::delete-file) -(convert-file-function lisp::truename) -(convert-file-function lisp::directory) -(convert-file-function lisp::dribble t) -(convert-file-function lisp::ed t) -(convert-file-function lisp::file-author) -(convert-file-function lisp::file-write-date) - -(convert-file-function-2-args lisp::rename-file) -;; should take care of :output-file as well -(convert-file-function lisp::compile-file) - -(unless (fboundp 'old-parse-namestring) - (setf (symbol-function 'old-parse-namestring) - (symbol-function 'lisp::parse-namestring)) - (defun lisp::parse-namestring (thing &optional host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) - "Convert THING (string, symbol, pathname, or stream) into a pathname." - (declare (ignore junk-allowed)) - (cond ((null thing) nil) ; try to fix bug with (ed). probably not here. - ((or (eq (pathname-host-type thing) :logical) - (eq (pathname-host-type defaults) :logical) - (eq (host-type host) :logical)) - ;; Tis a logical pathname - (parse-generic-namestring thing host defaults - :start start :end end)) - (t (if end - (funcall 'old-parse-namestring thing host defaults - :start start :end end) - (funcall 'old-parse-namestring thing host defaults - :start start)))))) - -;;; *EOF* diff --git a/contrib/make.lsp b/contrib/make.lsp deleted file mode 100644 index 5843149be..000000000 --- a/contrib/make.lsp +++ /dev/null @@ -1,2730 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-Lisp -*- -;;; Wed May 22 19:33:59 1991 by Mark Kantrowitz -;;; defsystem.lisp - -;;; ******************************************************************** -;;; Portable Mini-DefSystem ******************************************** -;;; ******************************************************************** - -;;; This is a portable system definition facility for Common Lisp. -;;; Though home-grown, the syntax was inspired by fond memories of the -;;; defsystem facility on Symbolics 3600's. The exhaustive lists of -;;; filename extensions for various lisps and the idea to have one -;;; "operate-on-system" function instead of separate "compile-system" -;;; and "load-system" functions were taken from Xerox Corp.'s PCL -;;; system. - -;;; This system improves on both PCL and Symbolics defsystem utilities -;;; by performing a topological sort of the graph of file-dependency -;;; constraints. Thus, the components of the system need not be listed -;;; in any special order, because the defsystem command reorganizes them -;;; based on their constraints. It includes all the standard bells and -;;; whistles, such as not recompiling a binary file that is up to date -;;; (unless the user specifies that all files should be recompiled). - -;;; Written by Mark Kantrowitz, School of Computer Science, -;;; Carnegie Mellon University, October 1989. - -;;; Copyright (c) 1989, 1990 by Mark Kantrowitz. All rights reserved. - -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted, so long as the following -;;; conditions are met: -;;; o no fees or compensation are charged for use, copies, or -;;; access to this software -;;; o this copyright notice is included intact. -;;; This software is made available AS IS, and no warranty is made about -;;; the software or its performance. - -;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. - -;;; ******************************** -;;; Change Log ********************* -;;; ******************************** -;;; -;;; Note: Several of the fixes from 30-JAN-91 and 31-JAN-91 were done in -;;; September and October 1990, but not documented until January 1991. -;;; -;;; sb = Sean Boisen -;;; hkt = Rick Taube -;;; brad = Brad Miller -;;; toni = Anton Beschta -;;; bw = Robert Wilhelm -;;; rs = Ralph P. Sobek -;;; gi = Gabriel Inaebnit -;;; djc = Daniel J. Clancy -;;; mc = Matthew Cornell -;;; ik = Ik Su Yoo -;;; gc = Guillaume Cartier -;;; Thanks to Steve Strassmann and -;;; Sean Boisen for detailed bug reports and -;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit -;;; for help with VAXLisp bugs. -;;; -;;; 05-NOV-90 hkt Changed canonicalize-system-name to make system -;;; names package independent. Interns them in the -;;; keyword package. Thus either strings or symbols may -;;; be used to name systems from the user's point of view. -;;; 05-NOV-90 hkt Added definition FIND-SYSTEM to allow OOS to -;;; work on systems whose definition hasn't been loaded yet. -;;; 05-NOV-90 hkt Added definitions COMPILE-SYSTEM and LOAD-SYSTEM -;;; as alternates to OOS for naive users. -;;; 05-NOV-90 hkt Shadowing-import of 'defsystem in Allegro CL 3.1 [NeXT] -;;; into USER package instead of import. -;;; 15-NOV-90 mk Changed package name to "MAKE", eliminating "DEFSYSTEM" -;;; to avoid conflicts with allegro, symbolics packages -;;; named "DEFSYSTEM". -;;; 30-JAN-91 mk Modified append-directories to work with the -;;; logical-pathnames system. -;;; 30-JAN-91 mk Append-directories now works with Sun CL4.0. Also, fixed -;;; bug wrt Lucid 4.0's pathnames (which changed from lcl3.0 -;;; -- 4.0 uses a list for the directory slot, whereas -;;; 3.0 required a string). Possible fix to symbolics bug. -;;; 30-JAN-91 mk Defined NEW-REQUIRE to make redefinition of REQUIRE -;;; cleaner. Replaced all calls to REQUIRE in this file with -;;; calls to NEW-REQUIRE, which should avoid compiler warnings. -;;; 30-JAN-91 mk In VAXLisp, when we redefine lisp:require, the compiler -;;; no longer automatically executes require forms when it -;;; encounters them in a file. The user can always wrap an -;;; (eval-when (compile load eval) ...) around the require -;;; form. Alternately, see commented out code near the -;;; redefinition of lisp:require which redefines it as a -;;; macro instead. -;;; 30-JAN-91 mk Added parameter :version to operate-on-system. If it is -;;; a number, that number is used as part of the binary -;;; directory name as the place to store and load files. -;;; If NIL (the default), uses regular binary directory. -;;; If T, tries to find the most recent version of the -;;; binary directory. -;;; 30-JAN-91 mk Added global variable *use-timeouts* (default: t), which -;;; specifies whether timeouts should be used in -;;; Y-OR-N-P-WAIT. This is provided for users whose lisps -;;; don't handle read-char-no-hang properly, so that they -;;; can set it to NIL to disable the timeouts. Usually the -;;; reason for this is the lisp is run on top of UNIX, -;;; which buffers input LINES (and provides input editing). -;;; To get around this we could always turn CBREAK mode -;;; on and off, but there's no way to do this in a portable -;;; manner. -;;; 30-JAN-91 mk Fixed bug where in :test t mode it was actually providing -;;; the system, instead of faking it. -;;; 30-JAN-91 mk Changed storage of system definitions to a hash table. -;;; Changed canonicalize-system-name to coerce the system -;;; names to uppercase strings. Since we're no longer using -;;; get, there's no need to intern the names as symbols, -;;; and strings don't have packages to cause problems. -;;; Added UNDEFSYSTEM, DEFINED-SYSTEMS, and DESCRIBE-SYSTEM. -;;; Added :delete-binaries command. -;;; 31-JAN-91 mk Franz Allegro CL has a defsystem in the USER package, -;;; so we need to do a shadowing import to avoid name -;;; conflicts. -;;; 31-JAN-91 mk Fixed bug in compile-and-load-operation where it was -;;; only loading newly compiled files. -;;; 31-JAN-91 mk Added :load-time slot to components to record the -;;; file-write-date of the binary/source file that was loaded. -;;; Now knows "when" (which date version) the file was loaded. -;;; Added keyword :minimal-load and global *minimal-load* -;;; to enable defsystem to avoid reloading unmodified files. -;;; Note that if B depends on A, but A is up to date and -;;; loaded and the user specified :minimal-load T, then A -;;; will not be loaded even if B needs to be compiled. So -;;; if A is an initializations file, say, then the user should -;;; not specify :minimal-load T. -;;; 31-JAN-91 mk Added :load-only slot to components. If this slot is -;;; specified as non-NIL, skips over any attempts to compile -;;; the files in the component. (Loading the file satisfies -;;; the need to recompile.) -;;; 31-JAN-91 mk Eliminated use of set-alist-lookup and alist-lookup, -;;; replacing it with hash tables. It was too much bother, -;;; and rather brittle too. -;;; 31-JAN-91 mk Defined #@ macro character for use with AFS @sys -;;; feature simulator. #@"directory" is then synonymous -;;; with (afs-binary-directory "directory"). -;;; 31-JAN-91 mk Added :private-file type of module. It is similar to -;;; :file, but has an absolute pathname. This allows you -;;; to specify a different version of a file in a system -;;; (e.g., if you're working on the file in your home -;;; directory) without completely rewriting the system -;;; definition. -;;; 31-JAN-91 mk Operations on systems, such as :compile and :load, -;;; now propagate to subsystems the system depends on -;;; if *operations-propagate-to-subsystems* is T (the default) -;;; and the systems were defined using either defsystem -;;; or as a :system component of another system. Thus if -;;; a system depends on another, it can now recompile the -;;; other. -;;; 01-FEB-91 mk Added default definitions of PROVIDE/REQUIRE/*MODULES* -;;; for lisps that have thrown away these definitions in -;;; accordance with CLtL2. -;;; 01-FEB-91 mk Added :compile-only slot to components. Analogous to -;;; :load-only. If :compile-only is T, will not load the -;;; file on operation :compile. Either compiles or loads -;;; the file, but not both. In other words, compiling the -;;; file satisfies the demand to load it. This is useful -;;; for PCL defmethod and defclass definitions, which wrap -;;; an (eval-when (compile load eval) ...) around the body -;;; of the definition -- we save time by not loading the -;;; compiled code, since the eval-when forces it to be -;;; loaded. Note that this may not be entirely safe, since -;;; CLtL2 has added a :load keyword to compile-file, and -;;; some lisps may maintain a separate environment for -;;; the compiler. This feature is for the person who asked -;;; that a :COMPILE-SATISFIES-LOAD keyword be added to -;;; modules. It's named :COMPILE-ONLY instead to match -;;; :LOAD-ONLY. -;;; 11-FEB-91 mk Now adds :mk-defsystem to features list, to allow -;;; special cased loading of defsystem if not already -;;; present. -;;; 19-FEB-91 duff Added filename extension for hp9000/300's running Lucid. -;;; 26-FEB-91 mk Distinguish between toplevel systems (defined with -;;; defsystem) and systems defined as a :system module -;;; of a defsystem. The former can depend only on systems, -;;; while the latter can depend on anything at the same -;;; level. -;;; 12-MAR-91 mk Added :subsystem component type to be a system with -;;; pathnames relative to its parent component. -;;; 12-MAR-91 mk Uncommented :device :absolute for CMU pathnames, so -;;; that the leading slash is included. -;;; 12-MAR-91 brad Patches for Allegro 4.0.1 on Sparc. -;;; 12-MAR-91 mk Changed definition of format-justified-string so that -;;; it no longer depends on the ~<~> format directives, -;;; because Allegro 4.0.1 has a bug which doesn't support -;;; them. Anyway, the new definition is twice as fast -;;; and conses half as much as FORMAT. -;;; 12-MAR-91 toni Remove nils from list in expand-component-components. -;;; 12-MAR-91 bw If the default-package and system have the same name, -;;; and the package is not loaded, this could lead to -;;; infinite loops, so we bomb out with an error. -;;; Fixed bug in default packages. -;;; 13-MAR-91 mk Added global *providing-blocks-load-propagation* to -;;; control whether system dependencies are loaded if they -;;; have already been provided. -;;; 13-MAR-91 brad In-package is a macro in CLtL2 lisps, so we change -;;; the package manually in operate-on-component. -;;; 15-MAR-91 mk Modified *central-registry* to be either a single -;;; directory pathname, or a list of directory pathnames -;;; to be checked in order. -;;; 15-MAR-91 rs Added afs-source-directory to handle versions when -;;; compiling C code under lisp. Other minor changes to -;;; translate-version and operate-on-system. -;;; 21-MAR-91 gi Fixed bug in defined-systems. -;;; 22-MAR-91 mk Replaced append-directories with new version that works -;;; by actually appending the directories, after massaging -;;; them into the proper format. This should work for all -;;; CLtL2-compliant lisps. -;;; 09-APR-91 djc Missing package prefix for lp:pathname-host-type. -;;; Modified component-full-pathname to work for logical -;;; pathnames. -;;; 09-APR-91 mk Added *dont-redefine-require* to control whether -;;; REQUIRE is redefined. Fixed minor bugs in redefinition -;;; of require. -;;; 12-APR-91 mk (pathname-host nil) causes an error in MCL 2.0b1 -;;; 12-APR-91 mc Ported to MCL2.0b1. -;;; 16-APR-91 mk Fixed bug in needs-loading where load-time and -;;; file-write-date got swapped. -;;; 16-APR-91 mk If the component is load-only, defsystem shouldn't -;;; tell you that there is no binary and ask you if you -;;; want to load the source. -;;; 17-APR-91 mc Two additional operations for MCL. -;;; 21-APR-91 mk Added feature requested by ik. *files-missing-is-an-error* -;;; new global variable which controls whether files (source -;;; and binary) missing cause a continuable error or just a -;;; warning. -;;; 21-APR-91 mk Modified load-file-operation to allow compilation of source -;;; files during load if the binary files are old or -;;; non-existent. This adds a :compile-during-load keyword to -;;; oos, and load-system. Global *compile-during-load* sets -;;; the default (currently :query). -;;; 21-APR-91 mk Modified find-system so that there is a preference for -;;; loading system files from disk, even if the system is -;;; already defined in the environment. -;;; 25-APR-91 mk Removed load-time slot from component defstruct and added -;;; function COMPONENT-LOAD-TIME to store the load times in a -;;; hash table. This is safer than the old definition because -;;; it doesn't wipe out load times every time the system is -;;; redefined. -;;; 25-APR-91 mk Completely rewrote load-file-operation. Fixed some bugs -;;; in :compile-during-load and in the behavior of defsystem -;;; when multiple users are compiling and loading a system -;;; instead of just a single user. -;;; 16-MAY-91 mk Modified FIND-SYSTEM to do the right thing if the system -;;; definition file cannot be found. -;;; 16-MAY-91 mk Added globals *source-pathname-default* and -;;; *binary-pathname-default* to contain default values for -;;; :source-pathname and :binary-pathname. For example, set -;;; *source-pathname-default* to "" to avoid having to type -;;; :source-pathname "" all the time. -;;; 27-MAY-91 mk Fixed bug in new-append-directories where directory -;;; components of the form "foo4.0" would appear as "foo4", -;;; since pathname-name truncates the type. Changed -;;; pathname-name to file-namestring. -;;; 3-JUN-91 gc Small bug in new-append-directories; replace (when -;;; abs-name) with (when (not (null-string abs-name))) -;;; 4-JUN-91 mk Additional small change to new-append-directories for -;;; getting the device from the relative pname if the abs -;;; pname is "". This is to fix a small behavior in CMU CL old -;;; compiler. Also changed (when (not (null-string abs-name))) -;;; to have an (and abs-name) in there. -;;; 8-JAN-92 sb Added filename extension for defsystem under Lucid Common -;;; Lisp/SGO 3.0.1+. -;;; 8-JAN-92 mk Changed the definition of prompt-string to work around an -;;; AKCL bug. Essentially, AKCL doesn't default the colinc to -;;; 1 if the colnum is provided, so we hard code it. -;;; 8-JAN-92 rs (pathname-directory (pathname "")) returns '(:relative) in -;;; Lucid, instead of NIL. Changed new-append-directories and -;;; test-new-append-directories to reflect this. -;;; 8-JAN-92 mk Fixed problem related to *load-source-if-no-binary*. -;;; compile-and-load-source-if-no-binary wasn't checking for -;;; the existence of the binary if this variable was true, -;;; causing the file to not be compiled. -;;; 8-JAN-92 mk Fixed problem with null-string being called on a pathname. - - - -;;; ******************************** -;;; To Do ************************** -;;; ******************************** -;;; -;;; Need way to load old binaries even if source is newer. -;;; -;;; Load a system (while not loading anything already loaded) -;;; and inform the user of out of date fasls with the choice -;;; to load the old fasl or recompile and then load the new -;;; fasl? -;;; -;;; modify compile-file-operation to handle a query keyword.... -;;; -;;; Perhaps systems should keep around the file-write-date of the system -;;; definition file, to prevent excessive reloading of the system definition? -;;; -;;; load-file-operation needs to be completely reworked to simplify the -;;; logic of when files get loaded or not. -;;; -;;; Need to revamp output: Nesting and indenting verbose output doesn't -;;; seem cool, especially when output overflows the 80-column margins. -;;; -;;; Document various ways of writing a system. simple (short) form -;;; (where :components is just a list of filenames) in addition to verbose. -;;; Put documentation strings in code. -;;; -;;; :load-time for modules and systems -- maybe record the time the system -;;; was loaded/compiled here and print it in describe-system? -;;; -;;; Make it easy to define new functions that operate on a system. For -;;; example, a function that prints out a list of files that have changed, -;;; hardcopy-system, edit-system, etc. -;;; -;;; If a user wants to have identical systems for different lisps, do we -;;; force the user to use logical pathnames? Or maybe we should write a -;;; generic-pathnames package that parses any pathname format into a -;;; uniform underlying format (i.e., pull the relevant code out of -;;; logical-pathnames.lisp and clean it up a bit). -;;; -;;; Verify that Mac pathnames now work with append-directories. -;;; -;;; A common human error is to violate the modularization by making a file -;;; in one module depend on a file in another module, instead of making -;;; one module depend on the other. This is caught because the dependency -;;; isn't found. However, is there any way to provide a more informative -;;; error message? Probably not, especially if the system has multiple -;;; files of the same name. -;;; -;;; For a module none of whose files needed to be compiled, have it print out -;;; "no files need recompilation". -;;; -;;; Write a system date/time to a file? (version information) I.e., if the -;;; filesystem supports file version numbers, write an auxiliary file to -;;; the system definition file that specifies versions of the system and -;;; the version numbers of the associated files. -;;; -;;; Add idea of a patch directory. -;;; -;;; In verbose printout, have it log a date/time at start and end of -;;; compilation: -;;; Compiling system "test" on 31-Jan-91 21:46:47 -;;; by Defsystem version v2.0 01-FEB-91. -;;; -;;; Define other :force options: -;;; :query allows user to specify that a file not normally compiled -;;; should be. OR -;;; :confirm allows user to specify that a file normally compiled -;;; shouldn't be. AND -;;; -;;; We currently assume that compilation-load dependencies and if-changed -;;; dependencies are identical. However, in some cases this might not be -;;; true. For example, if we change a macro we have to recompile functions -;;; that depend on it (except in lisps that automatically do this, such -;;; as the new CMU Common Lisp), but not if we change a function. Splitting -;;; these apart (with appropriate defaulting) would be nice, but not worth -;;; doing immediately since it may save only a couple of file recompilations, -;;; while making defsystem much more complex than it already is. -;;; - -;;; ******************************** -;;; Notes ************************** -;;; ******************************** -;;; -;;; DEFSYSTEM has been tested (successfully) in the following lisps: -;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) -;;; CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach) -;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) -;;; ExCL (Franz Allegro CL 4.0.1 [SPARC]) -;;; Lucid CL (Version 2.1 6-DEC-87) -;;; Lucid Common Lisp (3.0 [SPARC,SUN3]) -;;; Lucid Common Lisp (4.0 [SPARC,SUN3]) -;;; VAXLisp (v2.2) [VAX/VMS] -;;; VAXLisp (v3.1) -;;; -;;; DEFSYSTEM needs to be tested in the following lisps: -;;; Symbolics Common Lisp (8.0) -;;; Macintosh Allegro Common Lisp (1.3.2) -;;; KCL (June 3, 1987 or later) -;;; AKCL (1.86, June 30, 1987 or later) -;;; TI (Release 4.1 or later) -;;; Ibuki Common Lisp (01/01, October 15, 1987) -;;; Golden Common Lisp (3.1 IBM-PC) -;;; HP Common Lisp (same as Lucid?) -;;; Procyon Common Lisp - - -;;; ******************************************************************** -;;; How to Use this System ********************************************* -;;; ******************************************************************** - -;;; To use this system, -;;; 1. If you want to have a central registry of system definitions, -;;; modify the value of the variable *central-registry* below. -;;; 2. Load this file (defsystem.lisp) in either source or compiled form, -;;; 3. Load the file containing the "defsystem" definition of your system, -;;; 4. Use the function "operate-on-system" to do things to your system. - -;;; For more information, see the documentation and examples in -;;; lisp-utilities.ps. - -;;; **************************************************************** -;;; Lisp Code ****************************************************** -;;; **************************************************************** - -;;; ******************************** -;;; Massage CLtL2 onto *features* ** -;;; ******************************** -;;; Let's be smart about CLtL2 compatible Lisps: -(eval-when (compile load eval) - #+(or (and :excl :allegro-v4.0) :mcl) - (pushnew :cltl2 *features*)) - -;;; ******************************** -;;; Provide/Require/*modules* ****** -;;; ******************************** - -;;; Since CLtL2 has dropped require and provide from the language, some -;;; lisps may not have the functions PROVIDE and REQUIRE and the -;;; global *MODULES*. So if lisp::provide and user::provide are not -;;; defined, we define our own. - -;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions -;;; and variables not being declared or bound, apparently because it -;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns -;;; T, so it doesn't really bother when compiling the body of the unless. -;;; The new compiler does this properly, so I'm not going to bother -;;; working around this. - -;;; KCL (and derivatives) complain about the following in-package, proved, -;;; export and import forms being "in a bad place" if any non-package related -;;; form preceeds it. So I moved them before all the other stuff and skip -;;; the following conditional which is unnecessary in KCL anyway. -;;; -- stolcke 10/22/93 - -#-(or (and :CMU (not :new-compiler)) :vms :mcl :kcl :ECL) -(eval-when (compile load eval) - (unless (or (fboundp 'lisp::require) (fboundp 'user::require) - #+(and :excl :allegro-v4.0) (fboundp 'cltl1::require)) - (in-package "LISP") - (export '(*modules* provide require)) - - ;; Documentation strings taken almost literally from CLtL1. - - (defvar *MODULES* () - "List of names of the modules that have been loaded into Lisp so far. - It is used by PROVIDE and REQUIRE.") - - ;; We provide two different ways to define modules. The default way - ;; is to put either a source or binary file with the same name - ;; as the module in the library directory. The other way is to define - ;; the list of files in the module with defmodule. - - ;; The directory listed in *library* is implementation dependent, - ;; and is intended to be used by Lisp manufacturers as a place to - ;; store their implementation dependent packages. - ;; Lisp users should use systems and *central-registry* to store - ;; their packages -- it is intended that *central-registry* is - ;; set by the user, while *library* is set by the lisp. - - (defvar *library* nil ; "/usr/local/lisp/Modules/" - "Directory within the file system containing files, where the name - of a file is the same as the name of the module it contains.") - - (defun canonicalize-module-name (name) - ;; if symbol, string-downcase the printrep to make nicer filenames. - (if (stringp name) name (string-downcase (string name)))) - - (defvar *module-files* (make-hash-table :test #'equal) - "Hash table mapping from module names to list of files for the - module. REQUIRE loads these files in order.") - (defmacro defmodule (name &rest files) - "Defines a module NAME to load the specified FILES in order." - `(setf (gethash (canonicalize-module-name ,name) *module-files*) - ',files)) - (defun module-files (name) - (gethash name *module-files*)) - - (defun PROVIDE (name) - "Adds a new module name to the list of modules maintained in the - variable *modules*, thereby indicating that the module has been - loaded. Name may be a string or symbol -- strings are case-senstive, - while symbols are treated like lowercase strings. Returns T if - NAME was not already present, NIL otherwise." - (let ((module (canonicalize-module-name name))) - (unless (find module *modules* :test #'string=) - ;; Module not present. Add it and return T to signify that it - ;; was added. - (push module *modules*) - t))) - - (defun REQUIRE (name &optional pathname) - "Tests whether a module is already present. If the module is not - present, loads the appropriate file or set of files. The pathname - argument, if present, is a single pathname or list of pathnames - whose files are to be loaded in order, left to right. If the - pathname is nil, the system first checks if a module was defined - using defmodule and uses the pathnames so defined. If that fails, - it looks in the library directory for a file with name the same - as that of the module. Returns T if it loads the module." - (let ((module (canonicalize-module-name name))) - (unless (find module *modules* :test #'string=) - ;; Module is not already present. - (when (and pathname (not (listp pathname))) - ;; If there's a pathname or pathnames, ensure that it's a list. - (setf pathname (list pathname))) - (unless pathname - ;; If there's no pathname, try for a defmodule definition. - (setf pathname (module-files module))) - (unless pathname - ;; If there's still no pathname, try the library directory. - (when *library* - (setf pathname (concatenate 'string *library* module)) - ;; Test if the file exists. - ;; We assume that the lisp will default the file type - ;; appropriately. If it doesn't, use #+".fasl" or some - ;; such in the concatenate form above. - (if (probe-file pathname) - ;; If it exists, ensure we've got a list - (setf pathname (list pathname)) - ;; If the library file doesn't exist, we don't want - ;; a load error. - (setf pathname nil)))) - ;; Now that we've got the list of pathnames, let's load them. - (dolist (pname pathname T) - (load pname :verbose nil))))))) - -;;; ******************************** -;;; Set up Package ***************** -;;; ******************************** - - -;;; Unfortunately, lots of lisps have their own defsystems, some more -;;; primitive than others, all uncompatible, and all in the DEFSYSTEM -;;; package. To avoid name conflicts, we've decided to name this the -;;; MAKE package. A nice side-effect is that the short nickname -;;; MK is my initials. - -#-:cltl2 -(in-package "MAKE" :nicknames '("MK")) - -;;; For CLtL2 compatible lisps... -#+(and :excl :allegro-v4.0 :cltl2) -(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") - (:import-from cltl1 *modules* provide require)) -#+:mcl -(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") - (:import-from ccl *modules* provide require)) -#+(and :cltl2 (not (or (and :excl :allegro-v4.0) :mcl))) -(unless (find-package "MAKE") - (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))) - -#+:cltl2 -(in-package "MAKE") - -#+(and :excl :allegro-v4.0 :cltl2) -(cltl1:provide 'make) -#+:mcl -(ccl:provide 'make) -#+(and :cltl2 (not (or (and :excl :allegro-v4.0) :mcl))) -(provide 'make) -#-:cltl2 -(provide 'make) - -(pushnew :mk-defsystem *features*) - -(eval-when (compile load eval) - (defvar *special-exports* - '(defsystem compile-system load-system)) - (defvar *exports* - '(operate-on-system oos afs-binary-directory afs-source-directory - files-in-system)) - - (defvar *other-exports* - '(*central-registry* *bin-subdir* - machine-type-translation software-type-translation - ;require - allegro-make-system-fasl - files-which-need-compilation - undefsystem - defined-systems - describe-system - *defsystem-version* - *compile-during-load* - *minimal-load* - *dont-redefine-require* - *files-missing-is-an-error* - *reload-systems-from-disk* - *source-pathname-default* - *binary-pathname-default* - ))) - -;;; The external interface consists of *exports* and *other-exports*. -(eval-when (compile load eval) - (export *exports*) - (export *special-exports*) - (export *other-exports*)) - -;;; We import these symbols into the USER package to make them -;;; easier to use. Since some lisps have already defined defsystem -;;; in the user package, we may have to shadowing-import it. -#-(OR :CMU :CCL :ALLEGRO :EXCL) -(eval-when (compile load eval) - (import *exports* #-:cltl2 "USER" #+:cltl2 "COMMON-LISP-USER") - (import *special-exports* #-:cltl2 "USER" #+:cltl2 "COMMON-LISP-USER")) -#+(OR :CMU :CCL :ALLEGRO :EXCL) -(eval-when (compile load eval) - (import *exports* #-:cltl2 "USER" #+:cltl2 "COMMON-LISP-USER") - (shadowing-import *special-exports* - #-:cltl2 "USER" - #+:cltl2 "COMMON-LISP-USER")) - -#-PCL(when (find-package "PCL") - (pushnew :pcl *modules*) - (pushnew :pcl *features*)) - -;;; ******************************** -;;; Defsystem Version ************** -;;; ******************************** -(defparameter *defsystem-version* "v2.5 08-JAN-92" - "Current version number/date for Defsystem.") - -;;; ******************************** -;;; Customizable System Parameters * -;;; ******************************** - -(defvar *dont-redefine-require* t ;nil - "If T, prevents the redefinition of REQUIRE. This is useful for - lisps that treat REQUIRE specially in the compiler.") - -;;; Change this variable to set up the location of a central -;;; repository for system definitions if you want one. -(defvar *central-registry* '() - "Central directory of system definitions. May be either a single - directory pathname, or a list of directory pathnames to be checked - after the local directory.") -(setq *central-registry* "../lisp/") - -(defvar *bin-subdir* ".bin/" - "The subdirectory of an AFS directory where the binaries are really kept.") - -;;; These variables set up defaults for operate-on-system, and are used -;;; for communication in lieu of parameter passing. Yes, this is bad, -;;; but it keeps the interface small. Also, in the case of the -if-no-binary -;;; variables, parameter passing would require multiple value returns -;;; from some functions. Why make life complicated? -(defvar *tell-user-when-done* nil - "If T, system will print ...DONE at the end of an operation") -(defvar *oos-verbose* nil - "Operate on System Verbose Mode") -(defvar *oos-test* nil - "Operate on System Test Mode") -(defvar *load-source-if-no-binary* nil - "If T, system will try loading the source if the binary is missing") -(defvar *bother-user-if-no-binary* t - "If T, the system will ask the user whether to load the source if - the binary is missing") -(defvar *load-source-instead-of-binary* nil - "If T, the system will load the source file instead of the binary.") -(defvar *compile-during-load* :query - "If T, the system will compile source files during load if the - binary file is missing. If :query, it will ask the user for - permission first.") -(defvar *minimal-load* nil - "If T, the system tries to avoid reloading files that were already loaded - and up to date.") - -(defvar *files-missing-is-an-error* t - "If both the source and binary files are missing, signal a continuable - error instead of just a warning.") - -(defvar *operations-propagate-to-subsystems* t - "If T, operations like :COMPILE and :LOAD propagate to subsystems - of a system that are defined either using a component-type of :system - or by another defsystem form.") - -;;; Particular to CMULisp -(defvar *compile-error-file-type* "err" - "File type of compilation error file in cmulisp") -(defvar *cmu-errors-to-terminal* t - "Argument to :errors-to-terminal in compile-file in cmulisp") -(defvar *cmu-errors-to-file* t - "If T, cmulisp will write an error file during compilation") - -;;; ******************************** -;;; Global Variables *************** -;;; ******************************** - -;;; Massage people's *features* into better shape. -(eval-when (compile load eval) - (dolist (feature *features*) - (when (and (symbolp feature) ; 3600 - (equal (symbol-name feature) "CMU")) - (pushnew :CMU *features*))) - - #+Lucid - (when (search "IBM RT PC" (machine-type)) - (pushnew :ibm-rt-pc *features*)) - ) - -;;; *filename-extensions* is a cons of the source and binary extensions. -(defvar *filename-extensions* - (car '(#+(and Symbolics Lispm) ("lisp" . "bin") - #+(and dec common vax (not ultrix)) ("LSP" . "FAS") - #+(and dec common vax ultrix) ("lsp" . "fas") - #+(or :kcl :ECL) ("lsp" . "o") - #+IBCL ("lsp" . "o") - #+Xerox ("lisp" . "dfasl") - ;; Lucid on Silicon Graphics - #+(and Lucid MIPS) ("lisp" . "mbin") - ;; the entry for (and lucid hp300) must precede - ;; that of (and lucid mc68000) for hp9000/300's running lucid, - ;; since *features* on hp9000/300's also include the :mc68000 - ;; feature. - #+(and lucid hp300) ("lisp" . "6bin") - #+(and Lucid MC68000) ("lisp" . "lbin") - #+(and Lucid Vax) ("lisp" . "vbin") - #+(and Lucid Prime) ("lisp" . "pbin") - #+(and Lucid SUNRise) ("lisp" . "sbin") - #+(and Lucid SPARC) ("lisp" . "sbin") - #+(and Lucid :IBM-RT-PC) ("lisp" . "bbin") - ;; PA is Precision Architecture, HP's 9000/800 RISC cpu - #+(and Lucid PA) ("lisp" . "hbin") - #+excl ("cl" . "fasl") - #+(and :CMU :SPARC) ("lisp" . "sparcf") - #+:CMU ("lisp" . "fasl") - #+PRIME ("lisp" . "pbin") - #+HP ("l" . "b") - #+TI ("lisp" . #.(string (si::local-binary-file-type))) - #+:gclisp ("LSP" . "F2S") - #+pyramid ("clisp" . "o") - #+:coral ("lisp" . "fasl") - ;; Harlequin LispWorks on Mips M2000 - #+(and :mips :lispworks) ("lisp" . "mfasl") - - ;; Otherwise, - ("lisp" . "lbin"))) - "Filename extensions for Common Lisp. A cons of the form - (Source-Extension . Binary-Extension). If the system is - unknown (as in *features* not known), defaults to lisp and lbin.") - -;;; There is no real support for this variable being nil, so don't change it. -;;; Note that in any event, the toplevel system (defined with defsystem) -;;; will have its dependencies delayed. Not having dependencies delayed -;;; might be useful if we define several systems within one defsystem. -(defvar *system-dependencies-delayed* t - "If T, system dependencies are expanded at run time") - -;;; Replace this with consp, dammit! -(defun non-empty-listp (list) - (and list (listp list))) - -;;; ******************************** -;;; Component Operation Definition * -;;; ******************************** -(defvar *component-operations* (make-hash-table :test #'equal) - "Hash table of (operation-name function) pairs.") -(defun component-operation (name &optional operation) - (if operation - (setf (gethash name *component-operations*) operation) - (gethash name *component-operations*))) - -;;; ******************************** -;;; AFS @sys immitator ************* -;;; ******************************** - -;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out. -#-:mcl -(eval-when (compile load eval) - ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo"). - ;; For example, - ;; #@"foo" - ;; "foo/.bin/rt_mach/" - (set-dispatch-macro-character - #\# #\@ - #'(lambda (stream char arg) - (declare (ignore char arg)) - `(afs-binary-directory ',(read stream t nil t))))) - -(defun afs-binary-directory (root-directory) - ;; Function for obtaining the directory AFS's @sys feature would have - ;; chosen when we're not in AFS. This function is useful as the argument - ;; to :binary-pathname in defsystem. For example, - ;; :binary-pathname (afs-binary-directory "scanner/") - (let ((machine (machine-type-translation (machine-type))) - (software (software-type-translation (software-type)))) - ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach - (setq root-directory (namestring root-directory)) - (setq root-directory (ensure-trailing-slash root-directory)) - (format nil "~A~@[~A~]~@[~A/~]" - root-directory - *bin-subdir* - (afs-component machine software)))) - -(defun afs-source-directory (root-directory &optional version-flag) - ;; Function for obtaining the directory AFS's @sys feature would have - ;; chosen when we're not in AFS. This function is useful as the argument - ;; to :source-pathname in defsystem. - (setq root-directory (namestring root-directory)) - (setq root-directory (ensure-trailing-slash root-directory)) - (format nil "~A~@[~A/~]" - root-directory - (and version-flag (translate-version *version*)))) - -(defun null-string (s) - (when (stringp s) - (string-equal s ""))) - -(defun ensure-trailing-slash (dir) - (if (and dir - (not (null-string dir)) - (not (char= (char dir - (1- (length dir))) - #\/))) - (concatenate 'string dir "/") - dir)) - -(defun afs-component (machine software) - (format nil "~@[~A~]~@[_~A~]" - machine - (or software "mach"))) - -(defvar *machine-type-alist* (make-hash-table :test #'equal) - "Hash table for retrieving the machine-type") -(defun machine-type-translation (name &optional operation) - (if operation - (setf (gethash (string-upcase name) *machine-type-alist*) operation) - (gethash (string-upcase name) *machine-type-alist*))) - -(machine-type-translation "IBM RT PC" "rt") -(machine-type-translation "DEC 3100" "pmax") -(machine-type-translation "DEC VAX-11" "vax") -(machine-type-translation "Sun3" "sun3") -(machine-type-translation "Sun-4" "sun4") -#+(and :lucid :sun :mc68000) -(machine-type-translation "unknown" "sun3") - - -(defvar *software-type-alist* (make-hash-table :test #'equal) - "Hash table for retrieving the software-type") -(defun software-type-translation (name &optional operation) - (if operation - (setf (gethash (string-upcase name) *software-type-alist*) operation) - (gethash (string-upcase name) *software-type-alist*))) - -(software-type-translation "BSD UNIX" "mach") ; "unix" -(software-type-translation "Ultrix" "mach") ; "ultrix" -(software-type-translation "SunOS" "SunOS") -(software-type-translation "MACH/4.3BSD" "mach") -#+:lucid -(software-type-translation "Unix" - #+:lcl4.0 "4.0" - #+(and :lcl3.0 (not :lcl4.0)) "3.0") - -;;; ******************************** -;;; System Names ******************* -;;; ******************************** -(defun canonicalize-system-name (name) - ;; Originally we were storing systems using GET. This meant that the - ;; name of a system had to be a symbol, so we interned the symbols - ;; in the keyword package to avoid package dependencies. Now that we're - ;; storing the systems in a hash table, we've switched to using strings. - ;; Since the hash table is case sensitive, we use uppercase strings. - ;; (Names of modules and files may be symbols or strings.) - #|(if (keywordp name) - name - (intern (string-upcase (string name)) "KEYWORD"))|# - (if (stringp name) name (string-upcase (string name)))) - -(defvar *defined-systems* (make-hash-table :test #'equal) - "Hash table containing the definitions of all known systems.") - -(defun get-system (name) - "Returns the definition of the system named NAME." - (gethash (canonicalize-system-name name) *defined-systems*)) - -(defsetf get-system (name) (value) - `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value)) - -(defun undefsystem (name) - "Removes the definition of the system named NAME." - (setf (get-system name) nil)) - -(defun defined-systems () - "Returns a list of defined systems." - (let ((result nil)) - (maphash #'(lambda (key value) - (declare (ignore key)) - (push value result)) - *defined-systems*) - result)) - -;;; ******************************** -;;; Directory Pathname Hacking ***** -;;; ******************************** - -;;; Unix example: An absolute directory starts with / while a -;;; relative directory doesn't. A directory ends with /, while -;;; a file's pathname doesn't. This is important 'cause -;;; (pathname-directory "foo/bar") will return "foo" and not "foo/". - -;;; I haven't been able to test the fix to the problem with symbolics -;;; hosts. Essentially, append-directories seems to have been tacking -;;; the default host onto the front of the pathname (e.g., mk::source-pathname -;;; gets a "B:" on front) and this overrides the :host specified in the -;;; component. The value of :host should override that specified in -;;; the :source-pathname and the default file server. If this doesn't -;;; fix things, specifying the host in the root pathname "F:>root-dir>" -;;; may be a good workaround. - -;;; Need to verify that merging of pathnames where modules are located -;;; on different devices (in VMS-based VAXLisp) now works. - -;;; Merge-pathnames works for VMS systems. In VMS systems, the directory -;;; part is enclosed in square brackets, e.g., -;;; "[root.child.child_child]" or "[root.][child.][child_child]" -;;; To concatenate directories merge-pathnames works as follows: -;;; (merge-pathnames "" "[root]") ==> "[root]" -;;; (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext" -;;; (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext" -;;; (merge-pathnames "[root]file.ext" "[son]") ==> "[root]file.ext" -;;; Thus the problem with the #-VMS code was that it was merging x y into -;;; [[x]][y] instead of [x][y] or [x]y. - -;;; Miscellaneous notes: -;;; On GCLisp, the following are equivalent: -;;; "\\root\\subdir\\BAZ" -;;; "/root/subdir/BAZ" -;;; On VAXLisp, the following are equivalent: -;;; "[root.subdir]BAZ" -;;; "[root.][subdir]BAZ" -;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2 - -(defun new-append-directories (absolute-dir relative-dir) - ;; Version of append-directories for CLtL2-compliant lisps. In particular, - ;; they must conform to section 23.1.3 "Structured Directories". We are - ;; willing to fix minor aberations in this function, but not major ones. - ;; Tested in Allegro CL 4.0 [SPARC], Allegro CL 3.1.12 [DEC 3100], - ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0. - (setf absolute-dir (or absolute-dir "") - relative-dir (or relative-dir "")) - (let* ((abs-dir (pathname absolute-dir)) - (rel-dir (pathname relative-dir)) - (host (pathname-host abs-dir)) - (device (if (null-string absolute-dir) ; fix for CMU CL old compiler - (pathname-device rel-dir) - (pathname-device abs-dir))) - (abs-directory (coerce (pathname-directory abs-dir) 'list)) - (abs-keyword (when (keywordp (car abs-directory)) - (pop abs-directory))) - (abs-name (file-namestring abs-dir)) ; was pathname-name - (rel-directory (coerce (pathname-directory rel-dir) 'list)) - (rel-keyword (when (keywordp (car rel-directory)) - (pop rel-directory))) - (rel-file (file-namestring rel-dir)) - (directory nil)) - ;; Allegro v4.0 parses "/foo" into :directory '(:absolute :root) - ;; and filename "foo". The namestring of a pathname with - ;; directory '(:absolute :root "foo") ignores everything after the - ;; :root. - #+:allegro-v4.0(when (eq (car abs-directory) :root) (pop abs-directory)) - #+:allegro-v4.0(when (eq (car rel-directory) :root) (pop rel-directory)) - (when (and abs-name (not (null-string abs-name))) ; was abs-name - (cond ((and (null abs-directory) (null abs-keyword)) - #-(or :lucid :kcl :ECL) (setf abs-keyword :relative) - (setf abs-directory (list abs-name))) - (t - (setf abs-directory (append abs-directory (list abs-name)))))) - (when (and (null abs-directory) - (or (null abs-keyword) - ;; In Lucid, an abs-dir of nil gets a keyword of - ;; :relative since (pathname-directory (pathname "")) - ;; returns (:relative) instead of nil. - #+:lucid (eq abs-keyword :relative)) - rel-keyword) - (setf abs-keyword rel-keyword)) - (setf directory (append abs-directory rel-directory)) - (when abs-keyword (setf directory (cons abs-keyword directory))) - (namestring - (make-pathname :host host - :device device - :directory #-:cmu directory - #+:cmu (if (find-package :common-lisp) -;; no longer required in CMUcl 16e -- stolcke 9/17/92 - directory - (coerce directory 'simple-vector)) - :directory directory - :name rel-file)))) - -(defparameter *append-dirs-tests* - '("~/foo/" "baz/bar.lisp" - "~/foo" "baz/bar.lisp" - "/foo/bar/" "baz/barf.lisp" - "/foo/bar/" "/baz/barf.lisp" - "foo/bar/" "baz/barf.lisp" - "foo/bar" "baz/barf.lisp" - "foo/bar" "/baz/barf.lisp" - "foo/bar/" "/baz/barf.lisp" - "/foo/bar/" nil - "foo/bar/" nil - "foo/bar" nil - "foo" "bar" - nil "baz/barf.lisp" - nil "/baz/barf.lisp" - nil nil)) - -(defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*)) - (do* ((dir-list test-dirs (cddr dir-list)) - (abs-dir (car dir-list) (car dir-list)) - (rel-dir (cadr dir-list) (cadr dir-list))) - ((null dir-list) (values)) - (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S" - abs-dir rel-dir (new-append-directories abs-dir rel-dir)))) - -#| - (test-new-append-directories) - -ABS: "~/foo/" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp" -ABS: "~/foo" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp" -ABS: "/foo/bar/" REL: "baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp" -ABS: "/foo/bar/" REL: "/baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp" -ABS: "foo/bar/" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" -ABS: "foo/bar" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" -ABS: "foo/bar" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" -ABS: "foo/bar/" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp" -ABS: "/foo/bar/" REL: NIL Result: "/foo/bar/" -ABS: "foo/bar/" REL: NIL Result: "foo/bar/" -ABS: "foo/bar" REL: NIL Result: "foo/bar/" -ABS: NIL REL: "baz/barf.lisp" Result: "baz/barf.lisp" -ABS: NIL REL: "/baz/barf.lisp" Result: "/baz/barf.lisp" -ABS: NIL REL: NIL Result: "" - -|# - -(defun append-directories (absolute-directory relative-directory) - "There is no CL primitive for tacking a subdirectory onto a directory. - We need such a function because defsystem has both absolute and - relative pathnames in the modules. This is a somewhat ugly hack which - seems to work most of the time. We assume that ABSOLUTE-DIRECTORY - is a directory, with no filename stuck on the end. Relative-directory, - however, may have a filename stuck on the end." - (when (or absolute-directory relative-directory) - (cond - #+:logical-pathnames-mk - ((eq (lp:pathname-host-type absolute-directory) :logical) - ;; For use with logical pathnames package. - (lp:append-logical-directories absolute-directory relative-directory)) - (t - ;; In VMS, merge-pathnames actually does what we want!!! - #+:VMS(namestring (merge-pathnames (or absolute-directory "") - (or relative-directory ""))) - #+:macl1.3.2(namestring (make-pathname :directory absolute-directory - :name relative-directory)) - ;; Cross your fingers and pray. - #-(or :VMS :macl1.3.2) - (new-append-directories absolute-directory relative-directory))))) - -#| -(defun append-directories (absolute-directory relative-directory) - "There is no CL primitive for tacking a subdirectory onto a directory. - We need such a function because defsystem has both absolute and - relative pathnames in the modules. This is a very gross hack which - seems to work most of the time. We assume that ABSOLUTE-DIRECTORY - is a directory, with no filename stuck on the end. Relative-directory, - however, may have a filename stuck on the end. We assume that - if we do a (make-pathname :directory abs-directory :name rel-directory) - it will do what we want. The #+ and #-'s that appear before this - form are used to massage abs-directory and rel-directory into a - format acceptable to make-pathname in the particular lisp." - (when (or absolute-directory relative-directory) - (cond - #+:logical-pathnames-mk - ((eq (pathname-host-type absolute-directory) :logical) - ;; For use with logical pathnames package. - (lp::append-logical-directories absolute-directory relative-directory)) - (t - ;; Allegro CL barfs if abs-dir is "", so we replace it with NIL. - #+:ExCL(when (and (stringp absolute-directory) - (null-string absolute-directory)) - (setq absolute-directory nil)) - ;; CMU CL needs a / at the end of absolute directory, so we - ;; coerce abs-dir to a namestring and then check the last character - ;; of the namestring. An alternate method of doing this might - ;; be to break the directory into components, cons :absolute or - ;; :relative on the front, and hand that off to make-pathname. - #+:CMU(when (pathnamep absolute-directory) - (setq absolute-directory (namestring absolute-directory))) - #+:CMU(when (and absolute-directory - (not (null-string absolute-directory)) - (not (char= (char absolute-directory - (1- (length absolute-directory))) - #\/))) - (setq absolute-directory - (concatenate 'string absolute-directory "/"))) - #+:CMU(when (pathnamep relative-directory) - (setq relative-directory (namestring relative-directory))) - ;; In VMS, merge-pathnames actually does what we want!!! - #+:VMS(namestring (merge-pathnames (or absolute-directory "") - (or relative-directory ""))) - ;; For Sun Common Lisp 4.0, which is the same as Lucid 4.0. - ;; For this one, we need to break the string up into components, - ;; and tack a :ROOT on the front. - ;; The :lucid probably should be removed below for it to work properly - ;; in Lucid 3.0. - #+(or (and (not :excl) :SUN) :lcl4.0 :lucid) - (namestring (make-pathname - :directory (cons :ROOT - (parse-slashed-pathname - (merge-pathnames absolute-directory))) - :name relative-directory)) - #|(namestring (make-pathname - :directory (list :ROOT (or absolute-directory "")) - :name relative-directory))|# - ;; Cross your fingers and pray. - #-(or :VMS (and (not :excl) :SUN) :lcl4.0 :lucid) - (namestring (make-pathname :directory absolute-directory - #+:cmu :device #+:cmu :absolute - #+:symbolics :host #+:symbolics nil - :name relative-directory)))))) - -(defun parse-with-delimiter (line &optional (delim #\/)) - (let ((pos (position delim line))) - (cond (pos - (cons (subseq line 0 pos) - (parse-with-delimiter (subseq line (1+ pos)) delim))) - (t - (list line))))) - -(defun parse-slashed-pathname (directory) - "Parses strings like \"/usr/mkant/Public/\" into a list of - the directory components: '(\"usr\" \"mkant\" \"Public\"), - with null components (\"\") removed." - (if directory - (remove-if #'(lambda (string) (string-equal string "")) - (parse-with-delimiter directory #\/)) - (list ""))) -|# - -#| -;;; This was a try at appending a subdirectory onto a directory. -;;; It failed. We're keeping this around to prevent future mistakes -;;; of a similar sort. -(defun merge-directories (absolute-directory relative-directory) - ;; replace concatenate with something more intelligent - ;; i.e., concatenation won't work with some directories. - ;; it should also behave well if the parent directory - ;; has a filename at the end, or if the relative-directory ain't relative - (when absolute-directory - (setq absolute-directory (pathname-directory absolute-directory))) - (concatenate 'string - (or absolute-directory "") - (or relative-directory ""))) -|# - - - -#| - (defun d (d n) (namestring (make-pathname :directory d :name n))) - -D - (d "~/foo/" "baz/bar.lisp") -"/usr0/mkant/foo/baz/bar.lisp" - - (d "~/foo" "baz/bar.lisp") -"/usr0/mkant/foo/baz/bar.lisp" - - (d "/foo/bar/" "baz/barf.lisp") -"/foo/bar/baz/barf.lisp" - - (d "foo/bar/" "baz/barf.lisp") -"foo/bar/baz/barf.lisp" - - (d "foo/bar" "baz/barf.lisp") -"foo/bar/baz/barf.lisp" - - (d "foo/bar" "/baz/barf.lisp") -"foo/bar//baz/barf.lisp" - - (d "foo/bar" nil) -"foo/bar/" - - (d nil "baz/barf.lisp") -"baz/barf.lisp" - - (d nil nil) -"" - -|# - - -(defun namestring-or-nil (pathname) - (when pathname - (namestring pathname))) - -(defun new-file-type (pathname type) - (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (pathname-directory pathname) - :name (pathname-name pathname) - :type type - :version (pathname-version pathname))) - - - -;;; ******************************** -;;; Component Defstruct ************ -;;; ******************************** -(defvar *source-pathname-default* nil - "Default value of :source-pathname keyword in DEFSYSTEM. Set this to - \"\" to avoid having to type :source-pathname \"\" all the time.") -(defvar *binary-pathname-default* nil - "Default value of :binary-pathname keyword in DEFSYSTEM.") - -(defstruct (topological-sort-node (:conc-name topsort-)) - color - time) - -(defstruct (component (:include topological-sort-node) - (:print-function print-component)) - type ; :defsystem, :system, :subsystem, :module, :file, or :private-file - name ; a symbol or string - indent ; number of characters of indent in verbose output to the user. - host ; the pathname host (i.e., "/../a") - device ; the pathname device - source-root-dir - ;; relative or absolute (starts with "/"), directory or file (ends with "/") - (source-pathname *source-pathname-default*) - source-extension ; a string, e.g., "lisp". If nil, uses default for machine-type - (binary-pathname *binary-pathname-default*) - binary-root-dir - binary-extension ; a string, e.g., "fasl". If nil, uses default for machine-type - package ; package for use-package - components ; a list of components comprising this component's definition - depends-on ; a list of the components this one depends on. may refer only - ; to the components at the same level as this one. - initially-do ; form to evaluate before the operation - finally-do ; form to evaluate after the operation - compile-form ; for foreign libraries - load-form ; for foreign libraries -; load-time ; The file-write-date of the binary/source file loaded. - ;; If load-only is T, will not compile the file on operation :compile. - ;; In other words, for files which are :load-only T, loading the file - ;; satisfies any demand to recompile. - load-only ; If T, will not compile this file on operation :compile. - ;; If compile-only is T, will not load the file on operation :compile. - ;; Either compiles or loads the file, but not both. In other words, - ;; compiling the file satisfies the demand to load it. This is useful - ;; for PCL defmethod and defclass definitions, which wrap a - ;; (eval-when (compile load eval) ...) around the body of the definition. - ;; This saves time in some lisps. - compile-only ; If T, will not load this file on operation :compile. -) - -(defvar *file-load-time-table* (make-hash-table :test #'equal) - "Hash table of file-write-dates for the system definitions and - files in the system definitions.") -(defun component-load-time (component) - (when component - (etypecase component - (string (gethash component *file-load-time-table*)) - (pathname (gethash (namestring component) *file-load-time-table*)) - (component - (ecase (component-type component) - (:defsystem - (let ((name (component-name component)) - (path nil)) - (when (and name - (setf path (compute-system-path name nil))) - (gethash (namestring path) *file-load-time-table*)))) - ((:file :private-file) - ;; Use only :source pathname to identify component's - ;; load time. - (let ((path (component-full-pathname component :source))) - (when path - (gethash (namestring path) *file-load-time-table*))))))))) -(defsetf component-load-time (component) (value) - `(when ,component - (etypecase ,component - (string (setf (gethash ,component *file-load-time-table*) ,value)) - (pathname (setf (gethash (namestring ,component) *file-load-time-table*) - ,value)) - (component - (ecase (component-type ,component) - (:defsystem - (let ((name (component-name ,component)) - (path nil)) - (when (and name - (setf path (compute-system-path name nil))) - (setf (gethash (namestring path) *file-load-time-table*) - ,value)))) - ((:file :private-file) - ;; Use only :source pathname to identify file. - (let ((path (component-full-pathname ,component :source))) - (when path - (setf (gethash (namestring path) *file-load-time-table*) - ,value))))))))) - -(defun compute-system-path (module-name definition-pname) - (let* ((filename (format nil "~A.system" - (if (symbolp module-name) - (string-downcase (string module-name)) - module-name)))) - (or (when definition-pname ; given pathname for system def - (probe-file definition-pname)) - (probe-file filename) ; try current dir - (when *central-registry* ; central registry - (if (listp *central-registry*) - (dolist (registry *central-registry*) - (let ((file (probe-file (append-directories registry - filename)))) - (when file (return file)))) - (probe-file (append-directories *central-registry* filename)))) - ))) - -(defvar *reload-systems-from-disk* t - "If T, always tries to reload newer system definitions from disk. - Otherwise first tries to find the system definition in the current - environment.") - -(defun FIND-SYSTEM (system-name &optional (mode :ask) definition-pname) - "Returns the system named SYSTEM-NAME. If not already loaded, loads it. - This allows operate-on-system to work on non-loaded as well as - loaded system definitions. DEFINITION-PNAME is the pathname for - the system definition, if provided." - (ecase mode - (:ASK - (or (get-system system-name) - (when (y-or-n-p-wait - #\y 20 - "System ~A not loaded. Shall I try loading it? " - system-name) - (find-system system-name :load definition-pname)))) - (:ERROR - (or (get-system system-name) - (error "Can't find system named ~s." system-name))) - (:LOAD-OR-NIL - (let ((system (get-system system-name))) - (or (unless *reload-systems-from-disk* system) - (let ((path (compute-system-path system-name definition-pname))) - (when (and path - (or (null system) - (null (component-load-time path)) - (< (component-load-time path) - (file-write-date path)))) - (load path) - (setf system (get-system system-name)) - (when system - (setf (component-load-time path) - (file-write-date path)))) - system) - system))) - (:LOAD - (or (unless *reload-systems-from-disk* (get-system system-name)) - (or (find-system system-name :load-or-nil definition-pname) - (error "Can't find system named ~s." system-name)))))) - -(defun print-component (component stream depth) - (declare (ignore depth)) - (format stream "#<~:@(~A~): ~A>" - (component-type component) - (component-name component))) - -(defun describe-system (name &optional (stream *standard-output*)) - "Prints a description of the system to the stream. If NAME is the - name of a system, gets it and prints a description of the system. - If NAME is a component, prints a description of the component." - (let ((system (if (typep name 'component) name (find-system name :load)))) - (format stream "~&~A ~A: ~ - ~@[~& Host: ~A~]~ - ~@[~& Device: ~A~]~ - ~@[~& Package: ~A~]~ - ~& Source: ~@[~A~] ~@[~A~] ~@[~A~]~ - ~& Binary: ~@[~A~] ~@[~A~] ~@[~A~]~ - ~@[~& Depends On: ~A ~]~& Components: ~{~15T~A~&~}" - (component-type system) - (component-name system) - (component-host system) - (component-device system) - (component-package system) - (component-root-dir system :source) - (component-pathname system :source) - (component-extension system :source) - (component-root-dir system :binary) - (component-pathname system :binary) - (component-extension system :binary) - (component-depends-on system) - (component-components system)) - #|(when recursive - (dolist (component (component-components system)) - (describe-system component stream recursive)))|# - system)) - -(defun canonicalize-component-name (component) - ;; Within the component, the name is a string. - (if (typep (component-name component) 'string) - ;; Unnecessary to change it, so just return it, same case - (component-name component) - ;; Otherwise, make it a downcase string - (setf (component-name component) - (string-downcase (string (component-name component)))))) - -(defun component-pathname (component type) - (when component - (case type - (:source (component-source-pathname component)) - (:binary (component-binary-pathname component)) - (:error (component-error-pathname component))))) -(defun component-error-pathname (component) - (let ((binary (component-pathname component :binary))) - (new-file-type binary *compile-error-file-type*))) -(defsetf component-pathname (component type) (value) - `(when ,component - (case ,type - (:source (setf (component-source-pathname ,component) ,value)) - (:binary (setf (component-binary-pathname ,component) ,value))))) - -(defun component-root-dir (component type) - (when component - (case type - (:source (component-source-root-dir component)) - ((:binary :error) (component-binary-root-dir component)) - ))) -(defsetf component-root-dir (component type) (value) - `(when ,component - (case ,type - (:source (setf (component-source-root-dir ,component) ,value)) - (:binary (setf (component-binary-root-dir ,component) ,value))))) - -(defvar *version-dir* nil - "The version subdir. bound in oos.") -(defvar *version-replace* nil - "The version replace. bound in oos.") -(defvar *version* nil - "Default version") -(defun component-full-pathname (component type &optional (version *version*) - &aux version-dir replace) - (when component - ;; If the pathname-type is :binary and the root pathname is null, - ;; distribute the binaries among the sources (= use :source pathname). - ;; This assumes that the component's :source pathname has been set - ;; before the :binary one. - (if version - (multiple-value-setq (version-dir replace) (translate-version version)) - (setq version-dir *version-dir* replace *version-replace*)) - (let ((pathname - (append-directories - (if replace - version-dir - (append-directories (component-root-dir component type) - version-dir)) - (component-pathname component type)))) - ;; When a logical pathname is used, it must first be translated to - ;; a physical pathname. This isn't strictly correct. What should happen - ;; is we fill in the appropriate slots of the logical pathname, and - ;; then return the logical pathname for use by compile-file & friends. - ;; But calling translate-logical-pathname to return the actual pathname - ;; should do for now. - #+:logical-pathnames-mk - (when (eq (lp:pathname-host-type pathname) :logical) - ;;(setf (lp::%logical-pathname-type pathname) - ;; (component-extension component type)) - (setf pathname (lp:translate-logical-pathname pathname))) - - (make-pathname :name (pathname-name pathname) - :type (component-extension component type) -;; couldn't get this to work under CMUcl 16e -- stolcke 9/17/92 - #-:cmu :host #-:cmu (when (component-host component) - ;; MCL2.0b1 causes an error on - ;; (pathname-host nil) - (pathname-host (component-host component))) -;; in CMUcl 15d not needed -- stolcke 9/17/92 - ;; :device #+CMU :absolute - ;; #-CMU (pathname-device (component-device component)) -;; but CMUcl 16e doesn't tolerate (pathname-device nil) - :device (when (component-device component) - (pathname-device (component-device component))) - ;; :version :newest - ;; Use :directory instead of :defaults - :directory (pathname-directory pathname))))) - -(defun translate-version (version) - ;; Value returns the version directory and whether it replaces - ;; the entire root (t) or is a subdirectory. - ;; Version may be nil to signify no subdirectory, - ;; a symbol, such as alpha, beta, omega, :alpha, mark, which - ;; specifies a subdirectory of the root, or - ;; a string, which replaces the root. - (cond ((null version) - (values "" nil)) - ((symbolp version) - (values (let ((sversion (string version))) - (if (find-if #'lower-case-p sversion) - sversion - (string-downcase sversion))) - nil)) - ((stringp version) - (values version t)) - (t (error "~&; Illegal version ~S" version)))) - -(defun component-extension (component type) - (case type - (:source (component-source-extension component)) - (:binary (component-binary-extension component)) - (:error *compile-error-file-type*))) -(defsetf component-extension (component type) (value) - `(case ,type - (:source (setf (component-source-extension ,component) ,value)) - (:binary (setf (component-binary-extension ,component) ,value)) - (:error (setf *compile-error-file-type* ,value)))) - -;;; ******************************** -;;; System Definition ************** -;;; ******************************** -(defmacro defsystem (name &rest definition-body) - `(create-component :defsystem ',name ',definition-body nil 0)) - -(defun create-component (type name definition-body &optional parent (indent 0)) - (let ((component (apply #'make-component :type type :name name :indent indent definition-body))) - ;; Set up :load-only attribute - (unless (find :load-only definition-body) - ;; If the :load-only attribute wasn't specified, - ;; inherit it from the parent. If no parent, default it to nil. - (setf (component-load-only component) - (when parent - (component-load-only parent)))) - ;; Set up :compile-only attribute - (unless (find :compile-only definition-body) - ;; If the :compile-only attribute wasn't specified, - ;; inherit it from the parent. If no parent, default it to nil. - (setf (component-compile-only component) - (when parent - (component-compile-only parent)))) - - ;; Initializations/after makes - (canonicalize-component-name component) - - ;; Inherit package from parent if not specified. - (setf (component-package component) - (or (component-package component) - (when parent (component-package parent)))) - - ;; Type specific setup: - (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) - (setf (get-system name) component)) - - ;; Set up the component's pathname - (create-component-pathnames component parent) - - ;; If there are any components of the component, expand them too. - (expand-component-components component (+ indent 2)) - - ;; Make depends-on refer to structs instead of names. - (link-component-depends-on (component-components component)) - - ;; Design Decision: Topologically sort the dependency graph at - ;; time of definition instead of at time of use. Probably saves a - ;; little bit of time for the user. - - ;; Topological Sort the components at this level. - (setf (component-components component) - (topological-sort (component-components component))) - - ;; Return the component. - component)) - -(defun create-component-pathnames (component parent) - ;; Evaluate the root dir arg - (setf (component-root-dir component :source) - (eval (component-root-dir component :source))) - (setf (component-root-dir component :binary) - (eval (component-root-dir component :binary))) - ;; Evaluate the pathname arg - (setf (component-pathname component :source) - (eval (component-pathname component :source))) - (setf (component-pathname component :binary) - (eval (component-pathname component :binary))) - ;; Pass along the host and devices - (setf (component-host component) - (or (component-host component) - (when parent (component-host parent)))) - (setf (component-device component) - (or (component-device component) - (when parent (component-device parent)))) - ;; Set up extension defaults - (setf (component-extension component :source) - (or (component-extension component :source) ; for local defaulting - (when parent ; parent's default - (component-extension parent :source)) - (car *filename-extensions*))) ; system default - (setf (component-extension component :binary) - (or (component-extension component :binary) ; for local defaulting - (when parent ; parent's default - (component-extension parent :binary)) - (cdr *filename-extensions*))) ; system default - ;; Set up pathname defaults -- expand with parent - ;; We must set up the source pathname before the binary pathname - ;; to allow distribution of binaries among the sources to work. - (generate-component-pathname component parent :source) - (generate-component-pathname component parent :binary)) - -;; maybe file's inheriting of pathnames should be moved elsewhere? -(defun generate-component-pathname (component parent pathname-type) - ;; Pieces together a pathname for the component based on its component-type. - ;; Assumes source defined first. - ;; Null binary pathnames inherit from source instead of the component's - ;; name. This allows binaries to be distributed among the source if - ;; binary pathnames are not specified. Or if the root directory is - ;; specified for binaries, but no module directories, it inherits - ;; parallel directory structure. - (case (component-type component) - ((:defsystem :system) ; Absolute Pathname - ;; Set the root-dir to be the absolute pathname - (setf (component-root-dir component pathname-type) - (or (component-pathname component pathname-type) - (when (eq pathname-type :binary) - ;; When the binary root is nil, use source. - (component-root-dir component :source))) ) - ;; Set the relative pathname to be nil - (setf (component-pathname component pathname-type) - nil));; should this be "" instead? - ;; If the name of the component-pathname is nil, it - ;; defaults to the name of the component. Use "" to - ;; avoid this defaulting. - (:private-file ; Absolute Pathname - ;; Root-dir is the directory part of the pathname - (setf (component-root-dir component pathname-type) - "" - #+ignore(or (when (component-pathname component pathname-type) - (pathname-directory - (component-pathname component pathname-type))) - (when (eq pathname-type :binary) - ;; When the binary root is nil, use source. - (component-root-dir component :source))) - ) - ;; The relative pathname is the name part - (setf (component-pathname component pathname-type) - (or (when (and (eq pathname-type :binary) - (null (component-pathname component :binary))) - ;; When the binary-pathname is nil use source. - (component-pathname component :source)) - (or (when (component-pathname component pathname-type) -; (pathname-name ) - (component-pathname component pathname-type)) - (component-name component))))) - ((:module :subsystem) ; Pathname relative to parent. - ;; Inherit root-dir from parent - (setf (component-root-dir component pathname-type) - (component-root-dir parent pathname-type)) - ;; Tack the relative-dir onto the pathname - (setf (component-pathname component pathname-type) - (or (when (and (eq pathname-type :binary) - (null (component-pathname component :binary))) - ;; When the binary-pathname is nil use source. - (component-pathname component :source)) - (append-directories - (component-pathname parent pathname-type) - (or (component-pathname component pathname-type) - (component-name component)))))) - (:file ; Pathname relative to parent. - ;; Inherit root-dir from parent - (setf (component-root-dir component pathname-type) - (component-root-dir parent pathname-type)) - ;; Tack the relative-dir onto the pathname - (setf (component-pathname component pathname-type) - (or (append-directories - (component-pathname parent pathname-type) - (or (component-pathname component pathname-type) - (component-name component) - (when (eq pathname-type :binary) - ;; When the binary-pathname is nil use source. - (component-pathname component :source))))))) - )) - -(defun expand-component-components (component &optional (indent 0)) - (setf (component-components component) - (remove-if #'null - (mapcar #'(lambda (definition) - (expand-component-definition definition - component indent)) - (component-components component))))) - -(defun expand-component-definition (definition parent &optional (indent 0)) - ;; Should do some checking for malformed definitions here. - (cond ((null definition) nil) - ((stringp definition) - ;; Strings are assumed to be of type :file - (create-component :file definition nil parent indent)) - ((and (listp definition) - (not (member (car definition) - '(:defsystem :system :subsystem - :module :file :private-file)))) - ;; Lists whose first element is not a component type - ;; are assumed to be of type :file - (create-component :file (car definition) (cdr definition) parent indent)) - ((listp definition) - ;; Otherwise, it is (we hope) a normal form definition - (create-component (car definition) ; type - (cadr definition) ; name - (cddr definition) ; definition body - parent ; parent - indent) ; indent - ))) - -(defun link-component-depends-on (components) - (dolist (component components) - (unless (and *system-dependencies-delayed* - (eq (component-type component) :defsystem)) - (setf (component-depends-on component) - (mapcar #'(lambda (dependency) - (let ((parent (find (string dependency) components - :key #'component-name - :test #'string-equal))) - (cond (parent parent) - ;; make it more intelligent about the following - (t (warn "Dependency ~S of component ~S not found." - dependency component))))) - - (component-depends-on component)))))) - -;;; ******************************** -;;; Topological Sort the Graph ***** -;;; ******************************** -(defun topological-sort (list &aux (time 0)) - ;; The algorithm works by calling depth-first-search to compute the - ;; blackening times for each vertex, and then sorts the vertices into - ;; reverse order by blackening time. - (labels ((dfs-visit (node) - (setf (topsort-color node) 'gray) - (unless (and *system-dependencies-delayed* - (eq (component-type node) :defsystem)) - (dolist (child (component-depends-on node)) - (cond ((eq (topsort-color child) 'white) - (dfs-visit child)) - ((eq (topsort-color child) 'gray) - (format t "~&Detected cycle containing ~A" child))))) - (setf (topsort-color node) 'black) - (setf (topsort-time node) time) - (incf time))) - (dolist (node list) - (setf (topsort-color node) 'white)) - (dolist (node list) - (when (eq (topsort-color node) 'white) - (dfs-visit node))) - (sort list #'< :key #'topsort-time))) - -;;; ******************************** -;;; Output to User ***************** -;;; ******************************** -;;; All output to the user is via the tell-user functions. - -(defun split-string (string &key (item #\space) (test #'char=)) - ;; Splits the string into substrings at spaces. - (let ((len (length string)) - (index 0) result) - (dotimes (i len - (progn (unless (= index len) - (push (subseq string index) result)) - (reverse result))) - (when (funcall test (char string i) item) - (unless (= index i);; two spaces in a row - (push (subseq string index i) result)) - (setf index (1+ i)))))) - -;; probably should remove the ",1" entirely. -(defun prompt-string (component) - (format nil "; ~:[~;TEST:~]~V,1@T " - *oos-test* - (component-indent component))) - -#| -(defun format-justified-string (prompt contents) - (format t (concatenate 'string "~%" prompt "-~{~<~%" prompt " ~1,80:; ~A~>~^~}") - (split-string contents)) - (finish-output *standard-output*)) -|# - -(defun format-justified-string (prompt contents &optional (width 80) - (stream *standard-output*)) - (let ((prompt-length (+ 2 (length prompt)))) - (cond ((< (+ prompt-length (length contents)) width) - (format stream "~%~A- ~A" prompt contents)) - (t - (format stream "~%~A-" prompt) - (do* ((cursor prompt-length) - (contents (split-string contents) (cdr contents)) - (content (car contents) (car contents)) - (content-length (1+ (length content)) (1+ (length content)))) - ((null contents)) - (cond ((< (+ cursor content-length) width) - (incf cursor content-length) - (format stream " ~A" content)) - (t - (setf cursor (+ prompt-length content-length)) - (format stream "~%~A ~A" prompt content))))))) - (finish-output stream)) - -(defun tell-user (what component &optional type no-dots force) - (when (or *oos-verbose* force) - (format-justified-string (prompt-string component) - (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]" - ;; To have better messages, wrap the following around the - ;; case statement: - ;;(if (find (component-type component) - ;; '(:defsystem :system :subsystem :module)) - ;; "Checking" - ;; (case ...)) - ;; This gets around the problem of DEFSYSTEM reporting - ;; that it's loading a module, when it eventually never - ;; loads any of the files of the module. - (case what - ((compile :compile) - (if (component-load-only component) - ;; If it is :load-only t, we're loading. - "Loading" - ;; Otherwise we're compiling. - "Compiling")) - ((load :load) "Loading") - (otherwise what)) - (component-type component) - (or (when type - (namestring-or-nil (component-full-pathname - component type))) - (component-name component)) - (and *tell-user-when-done* - (not no-dots)))))) - -(defun tell-user-done (component &optional force no-dots) - ;; test is no longer really used, but we're leaving it in. - (when (and *tell-user-when-done* - (or *oos-verbose* force)) - (format t "~&~A~:[~;...~] Done." - (prompt-string component) (not no-dots)) - (finish-output *standard-output*))) - -(defmacro with-tell-user ((what component &optional type no-dots force) &body body) - `(progn - (tell-user ,what ,component ,type ,no-dots ,force) - ,@body - (tell-user-done ,component ,force ,no-dots))) - -(defun tell-user-no-files (component &optional force) - (when (or *oos-verbose* force) - (format-justified-string (prompt-string component) - (format nil "Source file ~A ~ - ~:[and binary file ~A ~;~]not found, not loading." - (namestring (component-full-pathname component :source)) - (or *load-source-if-no-binary* *load-source-instead-of-binary*) - (namestring (component-full-pathname component :binary)))))) - -(defun tell-user-require-system (name parent) - (when *oos-verbose* - (format t "~&; ~:[~;TEST:~] - System ~A requires ~S" - *oos-test* (component-name parent) name) - (finish-output *standard-output*))) - -(defun tell-user-generic (string) - (when *oos-verbose* - (format t "~&; ~:[~;TEST:~] - ~A" - *oos-test* string) - (finish-output *standard-output*))) - -;;; ******************************** -;;; Y-OR-N-P-WAIT ****************** -;;; ******************************** -;;; y-or-n-p-wait is like y-or-n-p, but will timeout -;;; after a specified number of seconds -(defun internal-real-time-in-seconds () - (float (/ (get-internal-real-time) - internal-time-units-per-second))) - -(defun read-char-wait (&optional (timeout 20) input-stream &aux char) - (do ((start (internal-real-time-in-seconds))) - ((or (setq char (read-char-no-hang input-stream)) ;(listen *query-io*) - (< (+ start timeout) (internal-real-time-in-seconds))) - char))) - -;;; Lots of lisps, especially those that run on top of UNIX, do not get -;;; their input one character at a time, but a whole line at a time because -;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait -;;; to not always work as expected. -;;; -;;; I wish lisp did all its own buffering (turning off UNIX input line -;;; buffering by putting the UNIX into CBREAK mode). Of course, this means -;;; that we lose input editing, but why can't the lisp implement this? - -(defvar *use-timeouts* t - "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves - like Y-OR-N-P. This is provided for users whose lisps don't handle - read-char-no-hang properly.") - -(defvar *clear-input-before-query* t - "If T, y-or-n-p-wait will clear the input before printing the prompt - and asking the user for input.") - -(defun y-or-n-p-wait (&optional (default #\y) (timeout 20) - format-string &rest args) - "Y-OR-N-P-WAIT prints the message, if any, and reads characters from - *QUERY-IO* until the user enters y, Y or space as an affirmative, or either - n or N as a negative answer, or the timeout occurs. It asks again if - you enter any other characters." - (when *clear-input-before-query* (clear-input *query-io*)) - (when format-string - (fresh-line *query-io*) - (apply #'format *query-io* format-string args) - ;; FINISH-OUTPUT needed for CMU and other places which don't handle - ;; output streams nicely. This prevents it from continuing and - ;; reading the query until the prompt has been printed. - (finish-output *query-io*)) - (loop - (let* ((read-char (if *use-timeouts* - (read-char-wait timeout *query-io*) - (read-char *query-io*))) - (char (or read-char default))) - ;; We need to ignore #\newline because otherwise the bugs in - ;; clear-input will cause y-or-n-p-wait to print the "Type ..." - ;; message every time... *sigh* - ;; Anyway, we might want to use this to ignore whitespace once - ;; clear-input is fixed. - (unless (find char '(#\tab #\newline #\return)) - (when (null read-char) - (format *query-io* "~@[~A~]" default) - (finish-output *query-io*)) - (cond ((null char) (return t)) - ((find char '(#\y #\Y #\space) :test #'char=) (return t)) - ((find char '(#\n #\N) :test #'char=) (return nil)) - (t - (when *clear-input-before-query* (clear-input *query-io*)) - (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ") - (when format-string - (fresh-line *query-io*) - (apply #'format *query-io* format-string args)) - (finish-output *query-io*))))))) - -#| -(y-or-n-p-wait #\y 20 "What? ") -(progn (format t "~&hi") (finish-output) - (y-or-n-p-wait #\y 10 "1? ") - (y-or-n-p-wait #\n 10 "2? ")) -|# -;;; ******************************** -;;; Operate on System ************** -;;; ******************************** -;;; Operate-on-system -;; Operation is :compile, 'compile, :load or 'load -;; Force is :all or :new-source or :new-source-and-dependents or a list of -;; specific modules. -;; :all (or T) forces a recompilation of every file in the system -;; :new-source-and-dependents compiles only those files whose -;; sources have changed or who depend on recompiled files. -;; :new-source compiles only those files whose sources have changed -;; A list of modules means that only those modules and their dependents are recompiled. -;; Test is T to print out what it would do without actually doing it. -;; Note: it automatically sets verbose to T if test is T. -;; Verbose is T to print out what it is doing (compiling, loading of -;; modules and files) as it does it. -;; Dribble should be the pathname of the dribble file if you want to -;; dribble the compilation. -;; Load-source-instead-of-binary is T to load .lisp instead of binary files. -;; Version may be nil to signify no subdirectory, -;; a symbol, such as alpha, beta, omega, :alpha, mark, which -;; specifies a subdirectory of the root, or -;; a string, which replaces the root. -;; -(defun operate-on-system (name operation &key force - (version *version*) - (test *oos-test*) (verbose *oos-verbose*) - (load-source-instead-of-binary *load-source-instead-of-binary*) - (load-source-if-no-binary *load-source-if-no-binary*) - (bother-user-if-no-binary *bother-user-if-no-binary*) - (compile-during-load *compile-during-load*) - dribble - (minimal-load *minimal-load*)) - (unwind-protect - ;; Protect the undribble. - (progn - (when dribble (dribble dribble)) - (when test (setq verbose t)) - (when (null force);; defaults - (case operation - ((load :load) (setq force :all)) - ((compile :compile) (setq force :new-source-and-dependents)) - (t (setq force :all)))) - ;; Some CL implementations have a variable called *compile-verbose* - ;; or *compile-file-verbose*. - (multiple-value-bind (*version-dir* *version-replace*) - (translate-version version) - ;; CL implementations may uniformly default this to nil - (let ((*load-verbose* t) ; nil - ;; avoid warning from CMUcl compiler -- stolcke 9/18/92 - ;; KCL also doesn't about these -- stolcke 10/22/93 - #-(or :cmu :kcl :ECL) (*compile-file-verbose* t) ; nil - #-(or :kcl :ECL) (*compile-verbose* t) ; nil - (*version* version) - (*oos-verbose* verbose) - (*oos-test* test) - (*load-source-if-no-binary* load-source-if-no-binary) - (*compile-during-load* compile-during-load) - (*bother-user-if-no-binary* bother-user-if-no-binary) - (*load-source-instead-of-binary* load-source-instead-of-binary) - (*minimal-load* minimal-load) - (system (find-system name :load))) - (unless (component-operation operation) - (error "Operation ~A undefined." operation)) - (operate-on-component system operation force)))) - (when dribble (dribble)))) - -(defun COMPILE-SYSTEM (name &key force - (version *version*) - (test *oos-test*) (verbose *oos-verbose*) - (load-source-instead-of-binary *load-source-instead-of-binary*) - (load-source-if-no-binary *load-source-if-no-binary*) - (bother-user-if-no-binary *bother-user-if-no-binary*) - (compile-during-load *compile-during-load*) - dribble - (minimal-load *minimal-load*)) - ;; For users who are confused by OOS. - (operate-on-system - name :compile - :force force - :version version - :test test - :verbose verbose - :load-source-instead-of-binary load-source-instead-of-binary - :load-source-if-no-binary load-source-if-no-binary - :bother-user-if-no-binary bother-user-if-no-binary - :compile-during-load compile-during-load - :dribble dribble - :minimal-load minimal-load)) - -(defun LOAD-SYSTEM (name &key force - (version *version*) - (test *oos-test*) (verbose *oos-verbose*) - (load-source-instead-of-binary *load-source-instead-of-binary*) - (load-source-if-no-binary *load-source-if-no-binary*) - (bother-user-if-no-binary *bother-user-if-no-binary*) - (compile-during-load *compile-during-load*) - dribble - (minimal-load *minimal-load*)) - ;; For users who are confused by OOS. - (operate-on-system - name :load - :force force - :version version - :test test - :verbose verbose - :load-source-instead-of-binary load-source-instead-of-binary - :load-source-if-no-binary load-source-if-no-binary - :bother-user-if-no-binary bother-user-if-no-binary - :compile-during-load compile-during-load - :dribble dribble - :minimal-load minimal-load)) - -(defun operate-on-component (component operation force &aux changed) - ;; Returns T if something changed and had to be compiled. - (let ((type (component-type component)) - (old-package (package-name *package*))) - - (unwind-protect - ;; Protect old-package. - (progn - ;; Use the correct package. - (when (component-package component) - (tell-user-generic (format nil "Using package ~A" - (component-package component))) - (unless *oos-test* - (unless (find-package (component-package component)) - ;; If the package name is the same as the name of the system, - ;; and the package is not defined, this would lead to an - ;; infinite loop, so bomb out with an error. - (when (string-equal (string (component-package component)) - (component-name component)) - (format t "~%Component ~A not loaded:~%" - (component-name component)) - (error " Package ~A is not defined" - (component-package component))) - ;; If package not found, try using REQUIRE to load it. - (new-require (component-package component))) - ;; This was USE-PACKAGE, but should be IN-PACKAGE. - ;; Actually, CLtL2 lisps define in-package as a macro, - ;; so we'll set the package manually. - ;; (in-package (component-package component)) - (let ((package (find-package (component-package component)))) - (when package - (setf *package* package))))) - - ;; Load any required systems - (when (eq type :defsystem) ; maybe :system too? - (operate-on-system-dependencies component operation force)) - - ;; Do any initial actions - (when (component-initially-do component) - (tell-user-generic (format nil "Doing initializations for ~A" - (component-name component))) - (or *oos-test* - (eval (component-initially-do component)))) - - ;; If operation is :compile and load-only is T, this would change - ;; the operation to load. Only, this would mean that a module would - ;; be considered to have changed if it was :load-only and had to be - ;; loaded, and then dependents would be recompiled -- this doesn't - ;; seem right. So instead, we propagate the :load-only attribute - ;; to the components, and modify compile-file-operation so that - ;; it won't compile the files (and modify tell-user to say "Loading" - ;; instead of "Compiling" for load-only modules). - #|(when (and (find operation '(:compile compile)) - (component-load-only component)) - (setf operation :load))|# - - ;; Do operation and set changed flag if necessary. - (setq changed - (case type - ((:file :private-file) - (funcall (component-operation operation) component force)) - ((:module :system :subsystem :defsystem) - (operate-on-components component operation force changed)))) - - ;; Do any final actions - (when (component-finally-do component) - (tell-user-generic (format nil "Doing finalizations for ~A" - (component-name component))) - (or *oos-test* - (eval (component-finally-do component))))) - - ;; Reset the package. (Cleanup form of unwind-protect.) - ;;(in-package old-package) - (setf *package* (find-package old-package))) - - ;; Provide the loaded system - (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) - (tell-user-generic (format nil "Providing system ~A" - (component-name component))) - (or *oos-test* - (provide (canonicalize-system-name (component-name component)))))) - - ;; Return t if something changed in this component and hence had to be recompiled. - changed) - -(defvar *force* nil) -(defvar *providing-blocks-load-propagation* t - "If T, if a system dependency exists on *modules*, it is not loaded.") -(defun operate-on-system-dependencies (component operation &optional force) - (when *system-dependencies-delayed* - (let ((*force* force)) - (dolist (system (component-depends-on component)) - ;; For each system that this system depends on, if it is a - ;; defined system (either via defsystem or component type :system), - ;; and propagation is turned on, propagates the operation to the - ;; subsystem. Otherwise runs require (my version) on that system - ;; to load it (needed since we may be depending on a lisp - ;; dependent package). - ;; Explores the system tree in a DFS manner. - (cond ((and *operations-propagate-to-subsystems* - (not (listp system)) - ;; The subsystem is a defined system. - (find-system system :load-or-nil)) - ;; Call OOS on it. Since *system-dependencies-delayed* is - ;; T, the :depends-on slot is filled with the names of - ;; systems, not defstructs. - ;; Aside from system, operation, force, for everything else - ;; we rely on the globals. - (unless (and *providing-blocks-load-propagation* - ;; If *providing-blocks-load-propagation* is T, - ;; the system dependency must not exist in the - ;; *modules* for it to be loaded. Note that - ;; the dependencies are implicitly systems. - (find operation '(load :load)) - ;; (or (eq force :all) (eq force t)) - (find (canonicalize-system-name system) - *modules* :test #'string=)) - (operate-on-system system operation :force force))) - ((listp system) - (tell-user-require-system - (cond ((and (null (car system)) (null (cadr system))) - (caddr system)) - (t system)) - component) - (or *oos-test* (new-require (car system) nil - (eval (cadr system)) - (caddr system) - (or (car (cdddr system)) - *version*)))) - (t - (tell-user-require-system system component) - (or *oos-test* (new-require system)))))))) - -(defun operate-on-components (component operation force changed) - (with-tell-user (operation component) - (if (component-components component) - (dolist (module (component-components component)) - (when (operate-on-component module operation - (cond ((and (dolist (dependent (component-depends-on module)) - (when (member dependent changed) - (return t))) - #|(some #'(lambda (dependent) - (member dependent changed)) - (component-depends-on module))|# - (or (non-empty-listp force) - (eq force :new-source-and-dependents))) - ;; The component depends on a changed file - ;; and force agrees. - (if (eq force :new-source-and-dependents) - :new-source-all - :all)) - ((and (non-empty-listp force) - (member (component-name module) force - :test #'string-equal :key #'string)) - ;; Force is a list of modules - ;; and the component is one of them. - :all) - (t force))) - (push module changed))) - (case operation - ((compile :compile) - (eval (component-compile-form component))) - ((load :load) - (eval (component-load-form component)))))) - changed) - -;;; ******************************** -;;; New Require ******************** -;;; ******************************** -(defvar *old-require* nil) - -;;; All calls to require in this file have been replaced with calls -;;; to new-require to avoid compiler warnings and make this less of -;;; a tangled mess. -(defun new-require (module-name &optional pathname definition-pname - default-action (version *version*)) - ;; If the pathname is present, this behaves like the old require. - (unless (and module-name - (find #-CMU (string module-name) - #+CMU (string-downcase (string module-name)) - *modules* :test #'string=)) - (cond (pathname - (funcall *old-require* module-name pathname)) - ;; If the system is defined, load it. - ((find-system module-name :load-or-nil definition-pname) - (operate-on-system module-name :load - :force *force* - :version version - :test *oos-test* - :verbose *oos-verbose* - :load-source-if-no-binary *load-source-if-no-binary* - :bother-user-if-no-binary *bother-user-if-no-binary* - :compile-during-load *compile-during-load* - :load-source-instead-of-binary *load-source-instead-of-binary* - :minimal-load *minimal-load*)) - ;; If there's a default action, do it. This could be a progn which - ;; loads a file that does everything. - ((and default-action - (eval default-action))) - ;; If no system definition file, try regular require. - ;; had last arg PATHNAME, but this wasn't really necessary. - ((funcall *old-require* module-name)) - ;; If no default action, print a warning or error message. - (t - (format t "~&Warning: System ~A doesn't seem to be defined..." - module-name))))) - -;;; Note that in some lisps, when the compiler sees a REQUIRE form at -;;; top level it immediately executes it. This is as if an -;;; (eval-when (compile load eval) ...) were wrapped around the REQUIRE -;;; form. I don't see any easy way to do this without making REQUIRE -;;; a macro. -;;; -;;; For example, in VAXLisp, if a (require 'streams) form is at the top of -;;; a file in the system, compiling the system doesn't wind up loading the -;;; streams module. If the (require 'streams) form is included within an -;;; (eval-when (compile load eval) ...) then everything is OK. -;;; -;;; So perhaps we should replace the redefinition of lisp:require -;;; with the following macro definition: -#| -(unless *old-require* - (setf *old-require* - (symbol-function #-(and :excl :allegro-v4.0) 'lisp:require - #+(and :excl :allegro-v4.0) 'cltl1:require)) - - (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil)) - ;; Note that lots of lisps barf if we redefine a function from - ;; the LISP package. So what we do is define a macro with an - ;; unused name, and use (setf macro-function) to redefine - ;; lisp:require without compiler warnings. If the lisp doesn't - ;; do the right thing, try just replacing require-as-macro - ;; with lisp:require. - (defmacro require-as-macro (module-name - &optional pathname definition-pname - default-action (version '*version*)) - `(eval-when (compile load eval) - (new-require ,module-name ,pathname ,definition-pname - ,default-action ,version))) - (setf (macro-function #-(and :excl :allegro-v4.0) 'lisp:require - #+(and :excl :allegro-v4.0) 'cltl1:require) - (macro-function 'require-as-macro)))) -|# -;;; This will almost certainly fix the problem, but will cause problems -;;; if anybody does a funcall on #'require. - -;;; Redefine old require to call the new require. -(unless *old-require* - (setf *old-require* - (symbol-function #-(or (and :excl :allegro-v4.0) :mcl) 'lisp:require - #+(and :excl :allegro-v4.0) 'cltl1:require - #+:mcl 'ccl:require)) - - (unless *dont-redefine-require* - (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil)) - (setf (symbol-function - #-(or (and :excl :allegro-v4.0) :mcl) 'lisp:require - #+(and :excl :allegro-v4.0) 'cltl1:require - #+:mcl 'ccl:require) - (symbol-function 'new-require))))) - - -;;; ******************************** -;;; Component Operations *********** -;;; ******************************** -;;; Define :compile/compile and :load/load operations -(component-operation :compile 'compile-and-load-operation) -(component-operation 'compile 'compile-and-load-operation) -(component-operation :load 'load-file-operation) -(component-operation 'load 'load-file-operation) - -(defun compile-and-load-operation (component force) - ;; FORCE was CHANGED. this caused defsystem during compilation to only - ;; load files that it immediately compiled. - (let ((changed (compile-file-operation component force))) - ;; Return T if the file had to be recompiled and reloaded. - (if (and changed (component-compile-only component)) - ;; For files which are :compile-only T, compiling the file - ;; satisfies the need to load. - changed - ;; If the file wasn't compiled, or :compile-only is nil, - ;; check to see if it needs to be loaded. - (and (load-file-operation component force) ; FORCE was CHANGED ??? - changed)))) - -(defun compile-file-operation (component force) - ;; Returns T if the file had to be compiled. - (let ((must-compile - ;; For files which are :load-only T, loading the file - ;; satisfies the demand to recompile. - (and (null (component-load-only component)) ; not load-only - (or (find force '(:all :new-source-all t) :test #'eq) - (and (find force '(:new-source :new-source-and-dependents) - :test #'eq) - (needs-compilation component)))))) - - (cond ((and must-compile - (probe-file (component-full-pathname component :source))) - (with-tell-user ("Compiling source" component :source) - (or *oos-test* - (compile-file (component-full-pathname component :source) - :output-file (component-full-pathname component :binary) - #+CMU :error-file #+CMU (and *cmu-errors-to-file* - (component-full-pathname component :error)) - #+(and CMU (not :new-compiler)) - :errors-to-terminal - #+(and CMU (not :new-compiler)) - *cmu-errors-to-terminal* - ))) - must-compile) - (must-compile - (tell-user "Source file not found. Not compiling" - component :source :no-dots :force) - nil) - (t nil)))) - -(defun needs-compilation (component) - ;; If there is no binary, or it is older than the source - ;; file, then the component needs to be compiled. - ;; Otherwise we only need to recompile if it depends on a file that changed. - (and - ;; source must exist - (probe-file (component-full-pathname component :source)) - (or - ;; no binary - (null (probe-file (component-full-pathname component :binary))) - ;; old binary - (< (file-write-date (component-full-pathname component :binary)) - (file-write-date (component-full-pathname component :source)))))) - -(defun needs-loading (component &optional (check-source t) (check-binary t)) - ;; Compares the component's load-time against the file-write-date of - ;; the files on disk. - (let ((load-time (component-load-time component))) - (or - ;; File never loaded. - (null load-time) - ;; Binary is newer. - (when (and check-binary - (probe-file (component-full-pathname component :binary))) - (< load-time - (file-write-date (component-full-pathname component :binary)))) - ;; Source is newer. - (when (and check-source - (probe-file (component-full-pathname component :source))) - (< load-time - (file-write-date (component-full-pathname component :source))))))) - -;;; Need to completely rework this function... -(defun load-file-operation (component force) - ;; Returns T if the file had to be loaded - (let* ((binary-pname (component-full-pathname component :binary)) - (source-pname (component-full-pathname component :source)) - (binary-exists (probe-file binary-pname)) - (source-exists (probe-file source-pname)) - (source-needs-loading (needs-loading component t nil)) - (binary-needs-loading (needs-loading component nil t)) - ;; needs-compilation has an implicit source-exists in it. - (needs-compilation (if (component-load-only component) - source-needs-loading - (needs-compilation component))) - (check-for-new-source - ;; If force is :new-source*, we're checking for files - ;; whose source is newer than the compiled versions. - (find force '(:new-source :new-source-and-dependents :new-source-all) - :test #'eq)) - (load-binary (or (find force '(:all :new-source-all t) :test #'eq) - binary-needs-loading)) - (load-source - (or *load-source-instead-of-binary* - (and load-binary (component-load-only component)) - (and check-for-new-source needs-compilation))) - (compile-and-load - (and needs-compilation (or load-binary check-for-new-source) - (compile-and-load-source-if-no-binary component)))) - ;; When we're trying to minimize the files loaded to only those - ;; that need be, restrict the values of load-source and load-binary - ;; so that we only load the component if the files are newer than - ;; the load-time. - (when *minimal-load* - (when load-source (setf load-source source-needs-loading)) - (when load-binary (setf load-binary binary-needs-loading))) - - (when (or load-source load-binary compile-and-load) - (cond (compile-and-load - ;; If we're loading the binary and it is old or nonexistent, - ;; and the user says yes, compile and load the source. - (compile-file-operation component t) - (with-tell-user ("Loading binary" component :binary) - (or *oos-test* - (progn - (load binary-pname) - (setf (component-load-time component) - (file-write-date binary-pname))))) - T) - ((and source-exists - (or (and load-source ; implicit needs-comp... - (or *load-source-instead-of-binary* - (component-load-only component) - (not *compile-during-load*))) - (and load-binary (not binary-exists) - (load-source-if-no-binary component)))) - ;; Load the source if the source exists and: - ;; o we're loading binary and it doesn't exist - ;; o we're forcing it - ;; o we're loading new source and user wasn't asked to compile - (with-tell-user ("Loading source" component :source) - (or *oos-test* - (progn - (load source-pname) - (setf (component-load-time component) - (file-write-date source-pname))))) - T) - ((and binary-exists load-binary) - (with-tell-user ("Loading binary" component :binary) - (or *oos-test* - (progn - (load binary-pname) - (setf (component-load-time component) - (file-write-date binary-pname))))) - T) - ((and (not binary-exists) (not source-exists)) - (tell-user-no-files component :force) - (when *files-missing-is-an-error* - (cerror "Continue, ignoring missing files." - "~&Source file ~S ~:[and binary file ~S ~;~]do not exist." - (namestring source-pname) - (or *load-source-if-no-binary* - *load-source-instead-of-binary*) - (namestring binary-pname))) - nil) - (t - nil))))) - -(component-operation :delete-binaries 'delete-binaries-operation) -(defun delete-binaries-operation (component force) - (when (or (eq force :all) - (eq force t) - (and (find force '(:new-source :new-source-and-dependents - :new-source-all) - :test #'eq) - (needs-compilation component))) - (when (probe-file (component-full-pathname component :binary)) - (with-tell-user ("Deleting binary" component :binary) - (or *oos-test* - (delete-file (component-full-pathname component :binary))))))) - - -;; when the operation = :compile, we can assume the binary exists in test mode. -;; ((and *oos-test* -;; (eq operation :compile) -;; (probe-file (component-full-pathname component :source))) -;; (with-tell-user ("Loading binary" component :binary))) - -(defun binary-exists (component) - (probe-file (component-full-pathname component :binary))) - -;;; or old-binary -(defun compile-and-load-source-if-no-binary (component) - (when (not (or *load-source-instead-of-binary* - (and *load-source-if-no-binary* - (not (binary-exists component))))) - (cond ((component-load-only component) - #|(let ((prompt (prompt-string component))) - (format t "~A- File ~A is load-only, ~ - ~&~A not compiling." - prompt - (namestring (component-full-pathname component :source)) - prompt))|# - nil) - ((eq *compile-during-load* :query) - (let* ((prompt (prompt-string component)) - (compile-source - (y-or-n-p-wait - #\y 30 - "~A- Binary file ~A is old or does not exist. ~ - ~&~A Compile (and load) source file ~A instead? " - prompt - (namestring (component-full-pathname component :binary)) - prompt - (namestring (component-full-pathname component :source))))) - (unless (y-or-n-p-wait - #\y 30 - "~A- Should I bother you if this happens again? " - prompt) - (setq *compile-during-load* - (y-or-n-p-wait - #\y 30 - "~A- Should I compile and load or not? " - prompt))) ; was compile-source, then t - compile-source)) - (*compile-during-load*) - (t nil)))) - -(defun load-source-if-no-binary (component) - (and (not *load-source-instead-of-binary*) - (or (and *load-source-if-no-binary* - (not (binary-exists component))) - (component-load-only component) - (when *bother-user-if-no-binary* - (let* ((prompt (prompt-string component)) - (load-source - (y-or-n-p-wait #\y 30 - "~A- Binary file ~A does not exist. ~ - ~&~A Load source file ~A instead? " - prompt - (namestring (component-full-pathname component :binary)) - prompt - (namestring (component-full-pathname component :source))))) - (setq *bother-user-if-no-binary* - (y-or-n-p-wait #\n 30 - "~A- Should I bother you if this happens again? " - prompt )) - (unless *bother-user-if-no-binary* - (setq *load-source-if-no-binary* load-source)) - load-source))))) - -;;; ******************************** -;;; Allegro Make System Fasl ******* -;;; ******************************** -#+:excl -(defun allegro-make-system-fasl (system destination) - (excl:shell - (format nil "rm -f ~A; cat~{ ~A~} > ~A" - destination - (mapcar #'namestring - (files-in-system system :all :binary))))) - -(defun files-which-need-compilation (system) - (mapcar #'(lambda (comp) (namestring (component-full-pathname comp :source))) - (remove nil - (file-components-in-component - (find-system system :load) :new-source)))) - -(defun files-in-system (name &optional (force :all) (type :source) version) - ;; Returns a list of the pathnames in system in load order. - (let ((system (find-system name :load))) - (multiple-value-bind (*version-dir* *version-replace*) - (translate-version version) - (let ((*version* version)) - (file-pathnames-in-component system type force))))) - -(defun file-pathnames-in-component (component type &optional (force :all)) - (mapcar #'(lambda (comp) (component-full-pathname comp type)) - (file-components-in-component component force))) - -(defun file-components-in-component (component &optional (force :all) - &aux result changed) - (case (component-type component) - ((:file :private-file) - (when (setq changed - (or (find force '(:all t) :test #'eq) - (and (not (non-empty-listp force)) - (needs-compilation component)))) - (setq result - (list component)))) - ((:module :system :subsystem :defsystem) - (dolist (module (component-components component)) - (multiple-value-bind (r c) - (file-components-in-component - module - (cond ((and (some #'(lambda (dependent) - (member dependent changed)) - (component-depends-on module)) - (or (non-empty-listp force) - (eq force :new-source-and-dependents))) - ;; The component depends on a changed file and force agrees. - :all) - ((and (non-empty-listp force) - (member (component-name module) force - :test #'string-equal :key #'string)) - ;; Force is a list of modules and the component is one of them. - :all) - (t force))) - (when c - (push module changed) - (setq result (append result r))))))) - (values result changed)) - -(setf (symbol-function 'oos) (symbol-function 'operate-on-system)) - -;;; ******************************** -;;; Additional Component Operations -;;; ******************************** - -;;; *** Edit Operation *** - -#+:ccl -(defun edit-operation (component force) - "Always returns nil, i.e. component not changed." - (declare (ignore force)) - ;; - (let* ((full-pathname (make::component-full-pathname component :source)) - (already-editing\? #+:mcl (dolist (w (windows :class 'fred-window)) - (when (equal (window-filename w) - full-pathname) - (return w))) - #-:mcl nil)) - (if already-editing\? - #+:mcl (window-select already-editing\?) #-:mcl nil - (ed full-pathname))) - nil) - -#+:ccl -(make::component-operation :edit 'edit-operation) -#+:ccl -(make::component-operation 'edit 'edit-operation) - -;;; *** System Source Size *** - -(defun system-source-size (system-name) - "Prints a short report and returns the size in bytes of the source files in - ." - (let* ((file-list (files-in-system system-name :all :source)) - (total-size (file-list-size file-list))) - (format t "~&~S (~A files) totals ~A bytes (~A K)" - system-name (length file-list) total-size (round total-size 1024)) - total-size)) - -(defun file-list-size (file-list) - "Returns the size in bytes of the files in ." - ;; - (let ((total-size 0)) - (dolist (file file-list) - (with-open-file (stream file) - (incf total-size (file-length stream)))) - total-size)) - - - -;;; **************************************************************** -;;; Dead Code ****************************************************** -;;; **************************************************************** - -#| -;;; ******************************** -;;; Alist Manipulation ************* -;;; ******************************** -;;; This is really gross. I've replaced it with hash tables. - -(defun alist-lookup (name alist &key (test #'eql) (key #'identity)) - (cdr (assoc name alist :test test :key key))) - -(defmacro set-alist-lookup ((name alist &key (test '#'eql) (key '#'identity)) - value) - (let ((pair (gensym))) - `(let ((,pair (assoc ,name ,alist :test ,test :key ,key))) - (if ,pair - (rplacd ,pair ,value) - (push (cons ,name ,value) ,alist))))) - -(defun component-operation (name &optional operation) - (if operation - (set-alist-lookup (name *component-operations*) operation) - (alist-lookup name *component-operations*))) - -(defun machine-type-translation (name &optional operation) - (if operation - (set-alist-lookup (name *machine-type-alist* :test #'string-equal) - operation) - (alist-lookup name *machine-type-alist* :test #'string-equal))) - -(defun software-type-translation (name &optional operation) - (if operation - (set-alist-lookup (name *software-type-alist* :test #'string-equal) - operation) - (alist-lookup name *software-type-alist* :test #'string-equal))) - -|# - -;;; *END OF FILE* - - - - diff --git a/contrib/metering.lsp b/contrib/metering.lsp deleted file mode 100644 index 136fb6212..000000000 --- a/contrib/metering.lsp +++ /dev/null @@ -1,347 +0,0 @@ -From daemon Fri Jul 8 22:43:26 1994 ->From clisp-list@ma2s2.mathematik.uni-karlsruhe.de Fri Jul 8 22:43:16 1994 -Return-Path: -Date: Fri, 8 Jul 94 22:45:40 +0200 -Errors-To: haible@ma2s2.mathematik.uni-karlsruhe.de -Originator: clisp-list@ma2s2.mathematik.uni-karlsruhe.de -Errors-To: haible@ma2s2.mathematik.uni-karlsruhe.de -Reply-To: clisp-list -Sender: clisp-list@ma2s2.mathematik.uni-karlsruhe.de -Version: 5.5 -- Copyright (c) 1991/92, Anastasios Kotsikonas -From: donc@ISI.EDU (Don Cohen) -To: Multiple recipients of list -Subject: recording function calls - - From: "Edward G. Kovach" - Is there a way to ... get a listing of.. - A. How many times a particular function is called? - B. How much time it takes to run each function? - -I've seen several such facilities. The one I like, though, is -my own, included below. At the cost of some extra space, it -records not only the number of calls and total time, but each -individual call, its inputs and outputs, its start/finish time. -This is much more useful for debugging and tuning, since you get -to see WHICH calls took a lot of time, which ones got the wrong -inputs or computed the wrong results, etc. - -;;; -*- Mode: LISP; Package: USER; Syntax: Common-lisp -*- -(lisp::in-package "USER") -; ---- Record the calls to given functions ---- -#| 2/17/89 - try to avoid advice, not so much because it's not commonlisp - as because it's not compiled! In fact, I want to be able to turn on and - off recording at high frequency and encapsulations seem to get in the way - of this. For now I'll assume that one does not encapsulate and record the - same functions. - - In order to monitor a function one first prepares it for monitoring, then - one can turn monitoring on and off at high frequency. One can also reset - or read the monitoring data for a function. Finally one can forget about - monitoring a function. - - *monitored-fns* is a list of functions currently prepared for monitoring. - (prepare-record-calls '(f1 f2 f3)) prepares the functions named. - additional keyword arguments: entryforms, exitforms, test - The entryforms are evaluated at function entry, the exitforms at function - exit. The results are recorded along with inputs, outputs, entry time - and exit time. Test is a form (default is T) that determines whether - this particular call will be recorded. It runs in an environment where - ARGS is bound to the argument list of the function. - (record-on '(f1 f2 f3)) turns on recording for these functions. - (record-off '(f1 f2 f3)) turns it off. - (initialize-records '(f1 f2 f3)) discards all monitoring data for the - functions (but does not turn recording off or on and does not forget - preparation). - (recorded-calls 'f1) returns a list of the call records for f1. - This is a list of records of the form - (inputs outputs start-time1 start-time2 end-time1 end-time2 - ) - Times are represented as 2 numbers since some clocks wrap around. - The second is a wrap around count that is incremented whenever the - finish time comes out lower than the start time. - (summarize-calls '(f1 f2 f3)) prints a summary of the calls. - The argument defaults to *monitored-fns*. - Additional optional argument: name-alist - Name-alist is something like ((f1 . "updating database") (f2 . "waiting")) - and is used to translate function names into something more meaningful. - (forget-record-calls '(f1 f2 f3)) discards all monitoring data and preparation - - (longest-n-calls 'f2 3) lists the 3 longest recorded calls of f2 - additional keyword arguments: start end filterfn - filterfn - a function of 1 arg (inputs outputs start finish) - should return T if the call is "interesting" - start/end are special cases - filter out anything that starts before start - or ends after end - - (time-line '(f1 f2 f3) produces a time line of activity - additional keyword arguments: (width 80) filterfn start end name-alist - - Both symbolics and TI have a fast short clock and a slow long one. - We use the fast one on symbolics, slow one on TI. - time before wrap around / #usec to read clock - -------------------------------------------- - symbolics 3600 TI explorer II - fast >.5 hour / 67 * 16 sec. / 260 - slow >100 yrs / 218 >1 hour / 260 * - - Actually we notice wrap around and record it - whenever a clock access - returns a smaller value than the previous one we increment a counter. - Therefore all events are ordered correctly, but if you fail to read the - clock for an hour or so, it's as if that time never passed. This is bad - if you time things on such a coarse scale, but good if you time one thing - for a minute today and something else for a minute tomorrow - the time - line between such events never separates them by much more than an hour. - In practice I don't think this will matter much. - - Since calls are recorded by pushing onto a list at exit, they are ordered - by decreasing exit time. This is handy for finding the outermost calls - in the case where the calls all come from the same process (and must thus - be properly nested). - (outermost (recorded-calls 'foo)) - returns the subset of the calls to foo that are outermost. - -|# - -(defvar *monitored-fns* nil) -(defvar *clock-cycle* 0) -(defvar *last-time* 0) -(defun prepare-record-calls (fns &key entryforms exitforms (test t)) - (loop for fn in fns do (prepare-record-call fn entryforms exitforms test))) - -; record-calls-fn prop is cons substitute and original fns -(defun prepare-record-call (fn entryforms exitforms test &aux prop) - (cond ((not (fboundp fn)) (error "no such function as ~A" fn)) - #+zetalisp - ((and (si:function-encapsulated-p fn) - (warn "~A is an encapsulation") nil)) - #+ignore ; might be called with different entryforms/exitforms - ((and (setf prop (get fn 'record-calls-fn)) - (eq (cdr prop) (symbol-function fn))) - #+ignore (warn "~A already recorded" fn)) - ((eq (symbol-function fn) (car prop)) - #+ignore (warn "~A already prepared" fn)) - (t ; not cached ... - (setf (get fn 'record-calls-fn) - (cons (make-record-fn fn entryforms exitforms test) - (symbol-function fn))) - (pushnew fn *monitored-fns*)))) - -(defun make-record-fn (fn entryforms exitforms test) - (compile nil - `(lambda (&rest args &aux start start1 values finish finish1 entryvals) - (if ,test - (unwind-protect - (progn (setq entryvals (list ,@entryforms) - start (microsec-time) - start1 *clock-cycle* - values (multiple-value-list - (apply ',(symbol-function fn) args)) - finish (microsec-time) finish1 *clock-cycle*) - (values-list values)) - (record-1-call ',fn (copy-list args) - (if finish values :abnormal-exit) - start start1 - (or finish (microsec-time)) - (or finish1 *clock-cycle*) - entryvals - (list ,@exitforms))) - (apply ',(symbol-function fn) args))))) -; perhaps we should try to correct for the time spent in the new function? - -(defun forget-record-calls (fns) - (record-off fns) - (loop for fn in fns do - (setq *monitored-fns* (delete fn *monitored-fns*)) - (setf (get fn 'record-calls-fn) nil) - (setf (get fn 'recorded-calls) nil))) - -(defun record-on (fns) - (loop for fn in fns do - (let ((prop (get fn 'record-calls-fn))) - (cond ((not prop) (cerror "skip turning on recording" - "~A not prepared for recording" fn)) - ((eq (cdr prop) (symbol-function fn)) - (setf (symbol-function fn) (car prop))) - ((eq (car prop) (symbol-function fn))) - (t (cerror "skip turning on recording" - "~A has changed since last prepared for recording" - fn)))))) - -(defun record-off (fns) - (loop for fn in fns do - (let ((prop (get fn 'record-calls-fn))) - (cond ((not prop) - (cerror "continue" "~A not prepared for recording" fn)) - ((eq (car prop) (symbol-function fn)) - (setf (symbol-function fn) (cdr prop))) - ((eq (cdr prop) (symbol-function fn))) - (t (cerror "continue" - "~A has changed since recording last turned on" - fn)))))) - -(defun microsec-time (&aux time) - (setq time - #-(or symbolics ti) (get-internal-run-time) - #+symbolics (time:fixnum-microsecond-time) - #+TI (time:microsecond-time)) - (when (< time *last-time*) (incf *clock-cycle*)) - (setf *last-time* time)) - -(defun record-1-call (fn inputs results t1 t11 t2 t21 entryvals exitvals) - (push (list inputs results t1 t11 t2 t21 entryvals exitvals) - (get fn 'recorded-calls))) - -(defun initialize-records (fns) - (loop for fn in fns do (setf (get fn 'recorded-calls) nil))) - -(defun recorded-calls (fn) (get fn 'recorded-calls)) - -(defun summarize-calls (&optional (fns *monitored-fns*) name-alist) - (loop for fn in fns do - (summarize-record fn (get fn 'recorded-calls) name-alist))) - -(defun summarize-record (fn calls name-alist) - (when calls (loop for x in calls sum 1 into ncalls - sum (elapsed (third x) (fourth x) (fifth x) (sixth x)) - into time finally - (print-summarize-record fn ncalls time name-alist)))) - -(defun print-summarize-record (fn ncalls time name-alist) - (multiple-value-bind (total tunits) - (standardized-time-units time) - (multiple-value-bind (avg aunits) - (standardized-time-units (float (/ time ncalls))) - (format *standard-output* "~%~A: ~A calls, ~A ~A (avg. ~A~:[ ~a~; ~])" - (or (cdr (assoc fn name-alist)) fn) - ncalls total tunits avg (eq aunits tunits) aunits)))) - -(defun standardized-time-units (usec) - (cond ((> usec 999999) (values (float (/ usec 1000000)) "sec.")) - ((> usec 999) (values (float (/ usec 1000)) "msec.")) - (t (values usec "usec.")))) - -(defun elapsed (t1 t11 t2 t21) - (+ (- t2 t1) (* (- t21 t11) (* 1024 1024 2048 #+TI 2)))) - -(defun longest-n-calls (fn n &key start end filterfn - &aux next time current - (candidates (recorded-calls fn)) (i 0)) - ; filterfn decides whether a record is "interesting" - ; special cases: start/end filters out anything that starts before start - ; or ends after end - (flet ((filter (e) (and (or (null start) - (plusp (elapsed start 0 (third e) (fourth e)))) - (or (null end) - (plusp (elapsed (fifth e) (sixth e) end 0))) - (or (null filterfn) (funcall filterfn e))))) - (loop while (and (< i n) (setq next (pop candidates))) - when (filter next) - do (incf i) (push (cons (elapsed (third next) (fourth next) - (fifth next) (sixth next)) - next) current)) - (setq current (sort current #'<= :key #'car)) - (loop while (setq next (pop candidates)) - when (filter next) - when (< (caar current) - (setq time (elapsed (third next) (fourth next) - (fifth next) (sixth next)))) - do (setq current (merge 'list (cdr current) - (list (cons time next)) - #'<= :key #'car))) - (nreverse current))) - -(defvar *time-line-key* - "Start time = ~A, End time = ~A, Width = ~A, ~ - ~& each column represents ~A ~A~ - ~& Key: ( = 1 entry, ) = 1 exit, * = more than one entry/exit~ - ~& if no entry/exit, a digit indicates number of active calls,~ - ~& blank indicates no change, + indicates >9 ~% ") - -(defun time-line (fns &key (width 80) filterfn start end len name-alist - &aux events) - (flet ((filter (e) (and (or (null start) - (plusp (elapsed start 0 (third e) (fourth e)))) - (or (null end) - (plusp (elapsed (fifth e) (sixth e) end 0))) - (or (null filterfn) (funcall filterfn e))))) - (setq events (loop for f in fns collect - (cons f (loop for e in (recorded-calls f) - when (filter e) collect e)))) - (unless (and start end) - (loop for e in events do - (loop for r in (cdr e) do - (when (or (null start) - (minusp (elapsed start 0 (third r) (fourth r)))) - (setq start (totalt (third r) (fourth r)))) - (when (or (null end) - (minusp (elapsed (fifth r) (sixth r) end 0))) - (setq end (totalt (fifth r) (sixth r))))))) - (when (and start end) (setq len (- end start))) - (unless (and len (> len 0)) (return-from time-line "empty interval")) - (multiple-value-bind (number unit) - (when (and start end width) - (standardized-time-units (/ (- end start 0.0) width))) - (apply #'concatenate 'string - (format nil *time-line-key* start end width number unit) - (loop for f in events collect - (concatenate 'string - (let ((string (make-string width - :initial-element #\space)) - index - (countstart - (make-array (list width) - :initial-element 0 - :element-type 'integer)) - (countend - (make-array (list width) :initial-element 0 - :element-type 'integer))) - (loop for e in (cdr f) do - (setq index - (min (1- width) - (floor (* width (/ (- (totalt (third e) - (fourth e)) - start) - len))))) - (incf (aref countstart index)) - (setf (aref string index) - (if (char= #\space (aref string index)) - #\( #\*)) - (setq index - (min (1- width) - (floor (* width (/ (- (totalt (fifth e) - (sixth e)) - start) - len))))) - (decf (aref countend index)) - (setf (aref string index) - (if (char= #\space (aref string index)) - #\) #\*))) - (loop for i below width with sum = 0 do - (setf sum (+ sum (aref countstart i) - (aref countend i))) - (when (and (/= i 0) - (/= (aref countstart (1- i)) 0) - (/= (aref countend (1- i)) 0) - (char= #\space (aref string i)) - (> sum 0)) - (setf (aref string i) - (if (> sum 9) #\+ (aref "0123456789" sum))))) - string) - (format nil " ~A~& " - (symbol-name (or (cdr (assoc (car f) name-alist)) - (car f)))))))))) - - -(defun outermost (calls &aux outer) - (loop for c in calls - unless (and outer (<= (totalt (third outer) (fourth outer)) - (totalt (third c) (fourth c)) - (totalt (fifth c) (sixth c)) - (totalt (fifth outer) (sixth outer)))) - collect (setf outer c))) - -; get the time represented by the two numbers x (low order) and y (high order) -(defun totalt (x y) (elapsed 0 0 x y)) - - - diff --git a/contrib/pvm/eclreader.lsp b/contrib/pvm/eclreader.lsp deleted file mode 100644 index 8ea7c9ecf..000000000 --- a/contrib/pvm/eclreader.lsp +++ /dev/null @@ -1,129 +0,0 @@ -;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*- -;;; -;;; File = eclreader.lsp -;;; Definition of reader for ECoLISP. -;;; -;;; (c) 1994, I.D. Alexander-Craig, all rights reserved. -;;; -;;; - - - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; Definition of the basic reader that is needed by KCL. ;;;; -;;;; The following function should be called when loading the ;;;; -;;;; object reader for KCL. This is called the default reader ;;;; -;;;; for KCL. ;;;; -;;;; ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -(defparameter *default-reader* ()) - -(defparameter *default-reader-specs* - (list - (list 'NULL - LISP_NIL_TYPE - * - #'(lambda (rdr) - (declare (ignore rdr)) - ())) - (list T - LISP_T_TYPE - '* - #'(lambda (rdr) - (declare (ignore rdr)) - t)) - (list 'STANDARD-CHAR ;; CHARACTER - LISP_CHAR_TYPE - #'(lambda (obj rdr) - (declare (ignore rdr)) - (C-obuffer-char obj)) - #'(lambda (rdr) - (declare (ignore rdr)) - (C-ibuffer-char))) - (list 'FIXNUM - LISP_INT_TYPE - #'(lambda (obj rdr) - (declare (ignore rdr)) - (C-obuffer-int obj)) - #'(lambda (rdr) - (declare (ignore rdr)) - (C-ibuffer-int))) - (list 'BIGNUM - LISP_LONGINT_TYPE - #'(lambda (obj rdr) - (declare (ignore rdr)) - (C-obuffer-longint obj)) - #'(lambda (rdr) - (declare (ignore rdr)) - (C-ibuffer-longint))) - (list 'LONG-FLOAT ;;FLOAT - LISP_DOUBLE_TYPE - #'(lambda (obj rdr) - (declare (ignore rdr)) - (C-obuffer-double obj)) - #'(lambda (rdr) - (declare (ignore rdr)) - (C-ibuffer-double))) - (list 'SYMBOL - LISP_SYMBOL_TYPE - #'(lambda (obj rdr) - (declare (ignore rdr)) - (cond ((eq obj t) - (C-obuffer-t)) - ((null obj) - (C-obuffer-nil)) - (t - (let ((pname (symbol-name obj))) - (C-obuffer-symbol pname (length pname)))))) - #'(lambda (rdr) - (declare (ignore rdr)) - (C-ibuffer-symbol))) - (list 'STRING ;; SIMPLE-STRING - LISP_STRING_TYPE - #'(lambda (obj rdr) - (declare (ignore rdr)) - (C-obuffer-string obj (length obj))) - #'(lambda (rdr) - (declare (ignore rdr)) - (C-ibuffer-string))) - (list 'VECTOR - LISP_VECTOR_TYPE - #'(lambda (obj rdr) - (encode-vector obj rdr)) - #'(lambda (rdr) - (decode-vector rdr))) - (list 'CONS - LISP_LIST_TYPE - #'(lambda (obj rdr) - (encode-list obj rdr)) - #'(lambda (rdr) - (decode-list rdr))))) - -;; For testing only: - -(defparameter *rdr* ()) - -(defun init-default-reader () - (setq *default-reader* (make-object-reader)) - (initialise-reader-object - *default-reader* - *default-reader-specs*) - (values)) - -(format t "Creating reader:~%") -(init-default-reader) -(format t "Done.~%~%") - -;;; For testing only: - -(setq *rdr* *default-reader*) - -(defun restart-reader () - (setq *default-reader* () - rdr ()) - (init-default-reader) - (setq *rdr* *default-reader*) - (values)) diff --git a/contrib/pvm/hostfile b/contrib/pvm/hostfile deleted file mode 100644 index dd06e6a42..000000000 --- a/contrib/pvm/hostfile +++ /dev/null @@ -1,2 +0,0 @@ -database -igor diff --git a/contrib/pvm/load.lsp b/contrib/pvm/load.lsp deleted file mode 100644 index 2dd46e305..000000000 --- a/contrib/pvm/load.lsp +++ /dev/null @@ -1,11 +0,0 @@ -;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*- -;;; -;;; File = load.lsp -;;; Load file for ECL<->PVM interface modules. -;;; - -(load "pvmconsts") -(load "pvmlisp") -(si:faslink "pvmecl" "-L/project/pvm/pvm3/lib/SUN4 -lgpvm3 -lpvm3 -lc") -;(load "pvmecl") -(load "eclreader") diff --git a/contrib/pvm/pvm-test.lsp b/contrib/pvm/pvm-test.lsp deleted file mode 100644 index 2c2f7354e..000000000 --- a/contrib/pvm/pvm-test.lsp +++ /dev/null @@ -1,14 +0,0 @@ -(defparameter *my-tid* ()) - -(defun enroll () - (setq *my-tid* (lpvm-my-tid))) - -(defun leave () - (lpvm-exit) - (quit)) - -(defun send-rec (msg msgtype) - (format t "about to send~%") - (lpvm-send-message msg *rdr* msgtype *my-tid*) - (format t "about to receive~%") - (lpvm-nonblocking-recv *rdr* *my-tid* msgtype)) diff --git a/contrib/pvm/pvmconsts.lsp b/contrib/pvm/pvmconsts.lsp deleted file mode 100644 index 98ed6676f..000000000 --- a/contrib/pvm/pvmconsts.lsp +++ /dev/null @@ -1,109 +0,0 @@ -;;;-*- Mode: LISP; Syntax: Common LISP; Base: 10 -*- -;;; -;;; File = pvmconsts.lisp -;;; -;;; PVM constant definitions. -;;; - -;; -;; Change log. -;; 25 March 1994. LISP_X_TYPE constants have contiguous values. -;; This is to support the new representation for the read structure. -;; - -;;; -;;; Constant definitions for type tags used to define -;;; message boundaries. -;;; The tags are all ad hoc and tailored to the needs of LISP. -;;; Each is represented by an integer. -;;; -;;; - -(defconstant MESSAGE_START 1) - ;; This says that there is going to be - ;; a new structure type that follows. -(defconstant LISP_NIL_TYPE 2) ; encode nil -(defconstant LISP_T_TYPE 3) ; encode t -(defconstant LISP_CHAR_TYPE 4) -(defconstant LISP_SHORTINT_TYPE 5) -(defconstant LISP_INT_TYPE 6) -(defconstant LISP_LONGINT_TYPE 7) -;(defconstant LISP_FLOAT_TYPE 8) not used in ECo or KCL -(defconstant LISP_DOUBLE_TYPE 9) -(defconstant LISP_SYMBOL_TYPE 10) -(defconstant LISP_STRING_TYPE 11) -(defconstant LISP_VECTOR_TYPE 12) -(defconstant LISP_LIST_TYPE 13) - ;; If complex and rational are required, we can fit them in. -(defconstant LISP_OPAQUE_TYPE 14) -(defconstant LISP_MIN_USER_TYPE 15) - - -;;; -;;; PVM constant definitions for error messages, together -;;; with the error function for PVM routines. -;;; - -(defconstant %PvmOk 0) -(defconstant %PvmBadParam -2) -(defconstant %PvmMismatch -3) -(defconstant %PvmNoData -5) -(defconstant %PvmNoHost -6) -(defconstant %PvmNoFile -7) -(defconstant %PvmNoMem -10) -(defconstant %PvmBadMsg -12) -(defconstant %PvmSysErr -14) -(defconstant %PvmNoBuf -15) -(defconstant %PvmNoSuchBuf -16) -(defconstant %PvmNullGroup -17) -(defconstant %PvmDupGroup -18) -(defconstant %PvmNoGroup -19) -(defconstant %PvmNotInGroup -20) -(defconstant %PvmNoInst -21) -(defconstant %PvmHostFail -22) -(defconstant %PvmNoParent -23) -(defconstant %PvmNotImpl -24) -(defconstant %PvmDSysErr -25) -(defconstant %PvmBadVersion -26) -(defconstant %PvmOutOfRes -27) -(defconstant %PvmDupHost -28) -(defconstant %PvmCantStart -29) -(defconstant %PvmAlready -30) -(defconstant %PvmNoTask -31) -(defconstant %PvmNoEntry -32) -(defconstant %PvmDupEntry -33) - - -(defun pvm-error (errno where) - ;; quick hack for testing - (unless (= errno %PvmOk) - (error "PVM error in ~s no. ~d~%" where errno))) - - -;;; -;;; Constants for pvm_advise -;;; - -(defconstant %PvmDontRoute 1) -(defconstant %PvmAllowDirect 2) -(defconstant %PvmRouteDirect 3) - -;;; -;;; Constants for pvm_initsend's encoding -;;; - -(defconstant %PvmDataDefault 0) ; use XDR if heterogeneous -(defconstant %PvmDataRaw 1) ; no encoding -(defconstant %PvmDataInPlace 2) ; leave data in place. - -;;; -;;; Constants for pvm_spawn. -;;; See the PVM manual p. 13 for details. -;;; - -(defconstant %PvmTaskDefault 0) -(defconstant %PvmTaskHost 1) -(defconstant %PvmTaskArch 2) -(defconstant %PvmTaskDebug 4) -(defconstant %PvmTaskTrace 8) - diff --git a/contrib/pvm/pvmecl.c b/contrib/pvm/pvmecl.c deleted file mode 100644 index 2ba3ba0d6..000000000 --- a/contrib/pvm/pvmecl.c +++ /dev/null @@ -1,1058 +0,0 @@ - -#include "pvmecl.h" -init_code(int size, object data_stream) -{VT2 CLSR2 - volatile object VVprotect; - Cblock.cd_start=(char *)init_code; Cblock.cd_size=size; - VVprotect=Cblock.cd_data=read_VV(VV,VM1,data_stream); - MF0(VV[95],L1); - (void)putprop(VV[95],VV[Vdeb95],VV[96]); - MF0(VV[2],L2); - funcall(2,VV[97]->s.s_gfdef,VV[1]) /* PROCLAIM */; - putprop(VV[2],VV[4],VV[3]); - MF0(VV[98],L3); - (void)putprop(VV[98],VV[Vdeb98],VV[96]); - MF0(VV[99],L4); - (void)putprop(VV[99],VV[Vdeb99],VV[96]); - MF0(VV[100],L5); - (void)putprop(VV[100],VV[Vdeb100],VV[96]); - MF0(VV[101],L6); - (void)putprop(VV[101],VV[Vdeb101],VV[96]); - MF0(VV[8],L7); - funcall(2,VV[97]->s.s_gfdef,VV[7]) /* PROCLAIM */; - putprop(VV[8],VV[9],VV[3]); - MF0(VV[102],L8); - (void)putprop(VV[102],VV[Vdeb102],VV[96]); - MF0(VV[103],L9); - (void)putprop(VV[103],VV[Vdeb103],VV[96]); - MF0(VV[13],L10); - funcall(2,VV[97]->s.s_gfdef,VV[12]) /* PROCLAIM */; - putprop(VV[13],VV[14],VV[3]); - MF0(VV[104],L11); - (void)putprop(VV[104],VV[Vdeb104],VV[96]); - MF0(VV[17],L12); - funcall(2,VV[97]->s.s_gfdef,VV[16]) /* PROCLAIM */; - putprop(VV[17],VV[18],VV[3]); - MF0(VV[105],L13); - (void)putprop(VV[105],VV[Vdeb105],VV[96]); - MF0(VV[21],L14); - funcall(2,VV[97]->s.s_gfdef,VV[20]) /* PROCLAIM */; - putprop(VV[21],VV[22],VV[3]); - MF0(VV[106],L15); - (void)putprop(VV[106],VV[Vdeb106],VV[96]); - MF0(VV[107],L16); - (void)putprop(VV[107],VV[Vdeb107],VV[96]); - MF0(VV[108],L17); - (void)putprop(VV[108],VV[Vdeb108],VV[96]); - MF0(VV[109],L18); - (void)putprop(VV[109],VV[Vdeb109],VV[96]); - MF0(VV[110],L19); - MF0(VV[111],L20); - (void)putprop(VV[111],VV[Vdeb111],VV[96]); - MF0(VV[112],L21); - (void)putprop(VV[112],VV[Vdeb112],VV[96]); - MF0(VV[113],L21); - (void)putprop(VV[113],VV[Vdeb113],VV[96]); - MF0(VV[114],L23); - MF0(VV[115],L24); - (void)putprop(VV[115],VV[Vdeb115],VV[96]); - MF0(VV[116],L25); - MF0(VV[117],L26); - (void)putprop(VV[117],VV[Vdeb117],VV[96]); - MF0(VV[118],L27); - MF0(VV[119],L28); - (void)putprop(VV[119],VV[Vdeb119],VV[96]); - MF0(VV[120],L29); - MF0(VV[121],L30); - (void)putprop(VV[121],VV[Vdeb121],VV[96]); - MF0(VV[122],L31); - (void)putprop(VV[122],VV[Vdeb122],VV[96]); - MF0(VV[123],L32); - MF0(VV[124],L33); - (void)putprop(VV[124],VV[Vdeb124],VV[96]); - MF0(VV[125],L34); - (void)putprop(VV[125],VV[Vdeb125],VV[96]); - MF0(VV[126],L35); - (void)putprop(VV[126],VV[Vdeb126],VV[96]); - MF0(VV[127],L36); - (void)putprop(VV[127],VV[Vdeb127],VV[96]); - MF0(VV[34],L37); - funcall(2,VV[97]->s.s_gfdef,VV[33]) /* PROCLAIM */; - putprop(VV[34],VV[35],VV[3]); - MF0(VV[128],L38); - (void)putprop(VV[128],VV[Vdeb128],VV[96]); - MF0(VV[40],L39); - funcall(2,VV[97]->s.s_gfdef,VV[39]) /* PROCLAIM */; - putprop(VV[40],VV[41],VV[3]); - MF0(VV[129],L40); - (void)putprop(VV[129],VV[Vdeb129],VV[96]); - MF0(VV[130],L41); - (void)putprop(VV[130],VV[Vdeb130],VV[96]); - MF0(VV[45],L42); - funcall(2,VV[97]->s.s_gfdef,VV[44]) /* PROCLAIM */; - putprop(VV[45],VV[46],VV[3]); - MF0(VV[131],L43); - (void)putprop(VV[131],VV[Vdeb131],VV[96]); - MF0(VV[50],L44); - funcall(2,VV[97]->s.s_gfdef,VV[49]) /* PROCLAIM */; - putprop(VV[50],VV[51],VV[3]); - MF0(VV[132],L45); - (void)putprop(VV[132],VV[Vdeb132],VV[96]); - MF0(VV[54],L46); - funcall(2,VV[97]->s.s_gfdef,VV[53]) /* PROCLAIM */; - putprop(VV[54],VV[55],VV[3]); - MF0(VV[133],L47); - (void)putprop(VV[133],VV[Vdeb133],VV[96]); - MF0(VV[58],L48); - funcall(2,VV[97]->s.s_gfdef,VV[57]) /* PROCLAIM */; - putprop(VV[58],VV[59],VV[3]); - MF0(VV[134],L49); - (void)putprop(VV[134],VV[Vdeb134],VV[96]); - MF0(VV[62],L50); - funcall(2,VV[97]->s.s_gfdef,VV[61]) /* PROCLAIM */; - putprop(VV[62],VV[63],VV[3]); - MF0(VV[135],L51); - (void)putprop(VV[135],VV[Vdeb135],VV[96]); - MF0(VV[66],L52); - funcall(2,VV[97]->s.s_gfdef,VV[65]) /* PROCLAIM */; - putprop(VV[66],VV[67],VV[3]); - MF0(VV[136],L53); - (void)putprop(VV[136],VV[Vdeb136],VV[96]); - MF0(VV[70],L54); - funcall(2,VV[97]->s.s_gfdef,VV[69]) /* PROCLAIM */; - putprop(VV[70],VV[71],VV[3]); - MF0(VV[137],L55); - (void)putprop(VV[137],VV[Vdeb137],VV[96]); - MF0(VV[74],L56); - funcall(2,VV[97]->s.s_gfdef,VV[73]) /* PROCLAIM */; - putprop(VV[74],VV[75],VV[3]); - MF0(VV[138],L57); - (void)putprop(VV[138],VV[Vdeb138],VV[96]); - MF0(VV[139],L58); - MF0(VV[140],L59); - (void)putprop(VV[140],VV[Vdeb140],VV[96]); - MF0(VV[88],L60); - funcall(2,VV[97]->s.s_gfdef,VV[87]) /* PROCLAIM */; - putprop(VV[88],VV[89],VV[3]); - MF0(VV[141],L61); - (void)putprop(VV[141],VV[Vdeb141],VV[96]); - MF0(VV[92],L62); - funcall(2,VV[97]->s.s_gfdef,VV[91]) /* PROCLAIM */; - putprop(VV[92],VV[93],VV[3]); - MF0(VV[142],L63); - (void)putprop(VV[142],VV[Vdeb142],VV[96]); - Cblock.cd_start=(char *)end_init; - Cblock.cd_size-=(char *)end_init - (char *)init_code; - insert_contblock((char *)init_code,(char *)end_init - (char *)init_code); -} -static end_init() {} -/* function definition for PVM-ERROR */ -static L1(int narg, object V1, object V2) -{ VT3 VLEX3 CLSR3 -TTL: - RETURN(Lerror(3,VV[0],(V1),(V2)) /* ERROR */); -} - -#include "/project/pvm/pvm3/include/pvm3.h" - -/* function definition for C_PVM_PKINT */ -static L2(int narg, object V1) -{ - int x; - x=pvm_pkint(&object_to_int(V1),1,1); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for OBUFFER-INT */ -static L3(int narg, object V1) -{ VT4 VLEX4 CLSR4 -TTL: - {int V2; /* INFO */ - V2= pvm_pkint(&fix((V1)),1,1); - if((0)==(V2)){ - goto L35;} - L1(2,MAKE_FIXNUM(V2),VV[5]) /* PVM-ERROR */; - } -L35: - RETURN(0); -} -/* function definition for PACK-TYPE-TAG */ -static L4(int narg, object V1) -{ VT5 VLEX5 CLSR5 -TTL: - {int V2; /* RETURN-CODE */ - V2= pvm_pkint(&fix((V1)),1,1); - if((0)==(V2)){ - goto L39;} - L1(2,MAKE_FIXNUM(V2),VV[6]) /* PVM-ERROR */; - } -L39: - RETURN(0); -} -/* function definition for C-OBUFFER-NIL */ -static L5(int narg) -{ VT6 VLEX6 CLSR6 -TTL: - RETURN(L4(1,MAKE_FIXNUM(2)) /* PACK-TYPE-TAG */); -} -/* function definition for C-OBUFFER-T */ -static L6(int narg) -{ VT7 VLEX7 CLSR7 -TTL: - RETURN(L4(1,MAKE_FIXNUM(3)) /* PACK-TYPE-TAG */); -} -/* function definition for C_PVM_PKCHAR */ -static L7(int narg, object V1) -{ - int x; - x=pvm_pkbyte(&object_to_char(V1),1,1); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for C-OBUFFER-CHAR */ -static L8(int narg, object V1) -{ VT8 VLEX8 CLSR8 -TTL: - L4(1,MAKE_FIXNUM(4)) /* PACK-TYPE-TAG */; - {int V2; /* INFO */ - V2= pvm_pkbyte(&char_code((V1)),1,1); - if((0)==(V2)){ - goto L44;} - L1(2,MAKE_FIXNUM(V2),VV[10]) /* PVM-ERROR */; - } -L44: - RETURN(0); -} -/* function definition for C-OBUFFER-INT */ -static L9(int narg, object V1) -{ VT9 VLEX9 CLSR9 -TTL: - L4(1,MAKE_FIXNUM(6)) /* PACK-TYPE-TAG */; - {int V2; /* INFO */ - V2= pvm_pkint(&fix((V1)),1,1); - if((0)==(V2)){ - goto L49;} - L1(2,MAKE_FIXNUM(V2),VV[11]) /* PVM-ERROR */; - } -L49: - RETURN(0); -} -/* function definition for C_PVM_PKFLOAT */ -static L10(int narg, object V1) -{ - int x; - x=pvm_pkfloat(&object_to_float(V1),1,1); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for OBUFFER-FLOAT */ -static L11(int narg, object V1) -{ VT10 VLEX10 CLSR10 -TTL: - {int V2; /* INFO */ - V2= pvm_pkfloat(&sf((V1)),1,1); - if((0)==(V2)){ - goto L53;} - L1(2,MAKE_FIXNUM(V2),VV[15]) /* PVM-ERROR */; - } -L53: - RETURN(0); -} -/* function definition for C_PVM_PKDOUBLE */ -static L12(int narg, object V1) -{ - int x; - x=pvm_pkdouble(&object_to_double(V1),1,1); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for C-OBUFFER-DOUBLE */ -static L13(int narg, object V1) -{ VT11 VLEX11 CLSR11 -TTL: - {int V2; /* INFO */ - V2= pvm_pkdouble(&lf((V1)),1,1); - if((0)==(V2)){ - goto L57;} - L1(2,MAKE_FIXNUM(V2),VV[19]) /* PVM-ERROR */; - } -L57: - RETURN(0); -} -/* function definition for C_PVM_PKSTR */ -static L14(int narg, object V1, object V2) -{ - int x; - x=(((object_to_int(V2) = pvm_pkint(&type,1,1)) == PvmOk) ? - pvm_pkstr((V1)->st.st_self) : object_to_int(V2)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for C-OBUFFER-SYMBOL */ -static L15(int narg, object V1) -{ VT12 VLEX12 CLSR12 -TTL: - {object V2; /* PNAME */ - V2= symbol_name((V1)); - {int V3; /* LEN */ - V3= ((V2))->v.v_fillp; - L4(1,MAKE_FIXNUM(10)) /* PACK-TYPE-TAG */; - {int V4; /* INFO */ - V4= (((V3 = pvm_pkint(&type,1,1)) == PvmOk) ? - pvm_pkstr(((V2))->st.st_self) : V3); - if((0)==(V4)){ - goto L61;} - L1(2,MAKE_FIXNUM(V4),VV[23]) /* PVM-ERROR */; - } - } - } -L61: - RETURN(0); -} -/* function definition for C-OBUFFER-STRING */ -static L16(int narg, object V1) -{ VT13 VLEX13 CLSR13 -TTL: - {int V2; /* LEN */ - V2= length((V1)); - L4(1,MAKE_FIXNUM(11)) /* PACK-TYPE-TAG */; - {int V3; /* INFO */ - V3= (((V2 = pvm_pkint(&type,1,1)) == PvmOk) ? - pvm_pkstr(((V1))->st.st_self) : V2); - if((0)==(V3)){ - goto L68;} - L1(2,MAKE_FIXNUM(V3),VV[24]) /* PVM-ERROR */; - } - } -L68: - RETURN(0); -} -/* function definition for C-OBUFFER-VECTOR-HEADER */ -static L17(int narg, object V1) -{ VT14 VLEX14 CLSR14 -TTL: - L4(1,MAKE_FIXNUM(12)) /* PACK-TYPE-TAG */; - {int V2; /* INFO */ - V2= pvm_pkint(&fix((V1)),1,1); - if((0)==(V2)){ - goto L75;} - L1(2,MAKE_FIXNUM(V2),VV[25]) /* PVM-ERROR */; - } -L75: - RETURN(0); -} -/* function definition for C-OBUFFER-LIST-HEADER */ -static L18(int narg) -{ VT15 VLEX15 CLSR15 -TTL: - L4(1,MAKE_FIXNUM(13)) /* PACK-TYPE-TAG */; - RETURN(0); -} -/* function definition for C_PVM_UNPACK_TAG */ -static L19(int narg) -{ - object x; - x= Cnil; - { int tagval, info; - info = pvm_upkint(&tagval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = MAKE_FIXNUM(tagval); - RETURN(2); - }; - VALUES(0)=x; - RETURN(1); -} -/* function definition for IBUFFER-TAG */ -static L20(int narg) -{ VT16 VLEX16 CLSR16 -TTL: - { int V1; - object V2; /* INFO */ - object V3; /* VALUE */ - V1=L23(0) /* C_PVM_UNPACK_INT*/; - if (V1--==0) goto L81; - V2= VALUES(0); - if (V1--==0) goto L82; - V3= VALUES(1); - goto L83; -L81: - V2= Cnil; -L82: - V3= Cnil; -L83: - if(((V2))==Cnil){ - goto L85;} - VALUES(0) = (V3); - RETURN(1); -L85: - RETURN(L1(2,(V2),VV[26]) /* PVM-ERROR */);} -} -/* function definition for C-NEXT-MSG-TYPE */ -static L21(int narg) -{ VT17 VLEX17 CLSR17 -TTL: - RETURN(L20(0) /* IBUFFER-TAG */); -} -/* function definition for C_PVM_UNPACK_INT */ -static L23(int narg) -{ - object x; - x= Cnil; - { int ival, info; - info = pvm_upkint(&ival,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = MAKE_FIXNUM(ival); - RETURN(2); - }; - VALUES(0)=x; - RETURN(1); -} -/* function definition for C-IBUFFER-INT */ -static L24(int narg) -{ VT18 VLEX18 CLSR18 -TTL: - { int V1; - object V2; /* INFO */ - object V3; /* VALUE */ - V1=L23(0) /* C_PVM_UNPACK_INT*/; - if (V1--==0) goto L88; - V2= VALUES(0); - if (V1--==0) goto L89; - V3= VALUES(1); - goto L90; -L88: - V2= Cnil; -L89: - V3= Cnil; -L90: - if(((V2))==Cnil){ - goto L92;} - VALUES(0) = (V3); - RETURN(1); -L92: - RETURN(L1(2,(V2),VV[27]) /* PVM-ERROR */);} -} -/* function definition for C_PVM_UNPACK_CHAR */ -static L25(int narg) -{ - object x; - x= Cnil; - { int info; - char chval; - info = pvm_upkbyte(&chval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = code_char(chval); - RETURN(2); - }; - VALUES(0)=x; - RETURN(1); -} -/* function definition for C-IBUFFER-CHAR */ -static L26(int narg) -{ VT19 VLEX19 CLSR19 -TTL: - { int V1; - object V2; /* INFO */ - object V3; /* VALUE */ - V1=L25(0) /* C_PVM_UNPACK_CHAR*/; - if (V1--==0) goto L95; - V2= VALUES(0); - if (V1--==0) goto L96; - V3= VALUES(1); - goto L97; -L95: - V2= Cnil; -L96: - V3= Cnil; -L97: - if(((V2))==Cnil){ - goto L99;} - VALUES(0) = (V3); - RETURN(1); -L99: - RETURN(L1(2,(V2),VV[28]) /* PVM-ERROR */);} -} -/* function definition for C_PVM_UNPACK_FLOAT */ -static L27(int narg) -{ - object x; - x= Cnil; - { int info; - float fval; - info = pvm_upkfloat(&fval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = make_shortfloat(fval); - RETURN(2); - }; - VALUES(0)=x; - RETURN(1); -} -/* function definition for IBUFFER-FLOAT */ -static L28(int narg) -{ VT20 VLEX20 CLSR20 -TTL: - { int V1; - object V2; /* INFO */ - object V3; /* VALUE */ - V1=L27(0) /* C_PVM_UNPACK_FLOAT*/; - if (V1--==0) goto L102; - V2= VALUES(0); - if (V1--==0) goto L103; - V3= VALUES(1); - goto L104; -L102: - V2= Cnil; -L103: - V3= Cnil; -L104: - if(((V2))==Cnil){ - goto L106;} - VALUES(0) = (V3); - RETURN(1); -L106: - RETURN(L1(2,(V2),VV[29]) /* PVM-ERROR */);} -} -/* function definition for C_PVM_UNPACK_DOUBLE */ -static L29(int narg) -{ - object x; - x= Cnil; - { - int info; - double dval; - info = pvm_upkdouble(&dval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = make_longfloat(dval); - RETURN(2); - }; - VALUES(0)=x; - RETURN(1); -} -/* function definition for C-IBUFFER-DOUBLE */ -static L30(int narg) -{ VT21 VLEX21 CLSR21 -TTL: - { int V1; - object V2; /* INFO */ - object V3; /* VALUE */ - V1=L29(0) /* C_PVM_UNPACK_DOUBLE*/; - if (V1--==0) goto L109; - V2= VALUES(0); - if (V1--==0) goto L110; - V3= VALUES(1); - goto L111; -L109: - V2= Cnil; -L110: - V3= Cnil; -L111: - if(((V2))==Cnil){ - goto L113;} - VALUES(0) = (V3); - RETURN(1); -L113: - RETURN(L1(2,(V2),VV[30]) /* PVM-ERROR */);} -} -/* function definition for SETSTRING */ -static L31(int narg, object V1, object V2, object V3) -{ VT22 VLEX22 CLSR22 -TTL: - aset1((V3),fix((V2)),(V1)); - RETURN(0); -} -/* function definition for C_PVM_UNPACK_CHARS */ -static L32(int narg, object V1) -{ - object x; - x= - Cnil; - { char *strchrs; - int info; - info = pvm_upkstr(strchrs); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = make_simple_string(strchrs); - RETURN(2); - }; - VALUES(0)=x; - RETURN(1); -} -/* function definition for GET-LENGTH-AND-STRING */ -static L33(int narg) -{ VT23 VLEX23 CLSR23 -TTL: - {object V1; /* LEN */ - (*LK0)(0) /* IBUFFER-INT */; - V1= VALUES(0); - { int V2; - object V3; /* INFO */ - object V4; /* STR */ - V2=L32(1,(V1)) /* C_PVM_UNPACK_CHARS*/; - if (V2--==0) goto L118; - V3= VALUES(0); - if (V2--==0) goto L119; - V4= VALUES(1); - goto L120; -L118: - V3= Cnil; -L119: - V4= Cnil; -L120: - if(((V3))==Cnil){ - goto L122;} - if(!(number_compare(MAKE_FIXNUM(length((V4))),(V1))==0)){ - goto L125;} - VALUES(0) = (V4); - RETURN(1); -L125: - RETURN(Lformat(4,Ct,VV[31],MAKE_FIXNUM(length((V4))),(V1))/* FORMAT*/); -L122: - RETURN(L1(2,(V3),VV[32]) /* PVM-ERROR */);} - } -} -/* function definition for C-IBUFFER-SYMBOL */ -static L34(int narg) -{ VT24 VLEX24 CLSR24 -TTL: - {object V1; /* PNAME */ - L33(0) /* GET-LENGTH-AND-STRING*/; - V1= VALUES(0); - RETURN(Lmake_symbol(1,(V1)) /* MAKE-SYMBOL */); - } -} -/* function definition for C-IBUFFER-STRING */ -static L35(int narg) -{ VT25 VLEX25 CLSR25 -TTL: - RETURN(L33(0) /* GET-LENGTH-AND-STRING*/); -} -/* function definition for C-IBUFER-VECTOR-LENGTH */ -static L36(int narg) -{ VT26 VLEX26 CLSR26 -TTL: - RETURN(L24(0) /* C-IBUFFER-INT */); -} -/* function definition for C_PVM_INITSEND */ -static L37(int narg, object V1) -{ - int x; - x=pvm_initsend(object_to_int(V1)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-INIT-SEND */ -static L38(int narg, object V1) -{ VT27 VLEX27 CLSR27 -TTL: - if(type_of((V1))==t_fixnum||type_of((V1))==t_bignum){ - goto L129;} - RETURN(Lerror(2,VV[36],TYPE_OF((V1))) /* ERROR */); -L129: - if(!(number_compare(MAKE_FIXNUM(0),(V1))>0)){ - goto L132;} - RETURN(Lerror(2,VV[37],(V1)) /* ERROR */); -L132: - {register int V2; /* BUFID */ - V2= pvm_initsend(fix((V1))); - if(!((V2)<0)){ - goto L135;} - L1(2,MAKE_FIXNUM(V2),VV[38]) /* PVM-ERROR */; -L135: - VALUES(0) = MAKE_FIXNUM(V2); - RETURN(1); - } -} -/* function definition for C_PVM_SEND */ -static L39(int narg, object V1, object V2) -{ - int x; - x=pvm_send(object_to_int(V1), object_to_int(V2)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-SEND-MESSAGE */ -static L40(int narg, object V1, object V2, object V3, object V4, ...) -{ VT28 VLEX28 CLSR28 - {int i=4; - object V5; - va_list args; va_start(args, V4); - if (i==narg) goto L138; - V5= va_arg(args, object); - i++; - goto L139; -L138: - V5= MAKE_FIXNUM(0); -L139: - L38(1,(V5)) /* LPVM-INIT-SEND */; - (*LK1)(2,(V1),(V2)) /* WRITE-OBJECT */; - {int V6; /* INFO */ - V6= pvm_send(fix((V4)), fix((V3))); - if(!((V6)<0)){ - goto L143;} - L1(2,MAKE_FIXNUM(V6),VV[42]) /* PVM-ERROR */; - } -L143: - RETURN(0); - } -} -/* function definition for LPVM-MULTICAST */ -static L41(int narg, object V1, object V2, object V3, object V4, ...) -{ VT29 VLEX29 CLSR29 - {int i=4; - volatile object V5; - va_list args; va_start(args, V4); - if (i==narg) goto L147; - V5= va_arg(args, object); - i++; - goto L148; -L147: - V5= MAKE_FIXNUM(0); -L148: - L38(1,(V5)) /* LPVM-INIT-SEND */; - (*LK1)(2,(V1),(V2)) /* WRITE-OBJECT */; - {volatile object V6; - volatile object V7; /* TID */ - V6= (V4); - V7= Cnil; -L156: - if(!((V6)==Cnil)){ - goto L157;} - goto L152; -L157: - V7= CAR((V6)); - {register int V9; /* INFO */ - V9= pvm_send(fix((V7)), fix((V3))); - if(!((V9)<0)){ - goto L162;} - L1(2,MAKE_FIXNUM(V9),VV[43]) /* PVM-ERROR */; - } -L162: - V6= CDR((V6)); - goto L156; - } -L152: - RETURN(0); - } -} -/* function definition for C_PVM_NRECV */ -static L42(int narg, object V1, object V2) -{ - int x; - x=pvm_nrecv(object_to_int(V1),object_to_int(V2)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-NONBLOCKING-RECV */ -static L43(int narg, object V1, object V2, object V3) -{ VT30 VLEX30 CLSR30 -TTL: - {register int V4; /* BUFID */ - V4= pvm_nrecv(fix((V2)),fix((V3))); - if(!((V4)<0)){ - goto L171;} - RETURN(L1(2,MAKE_FIXNUM(V4),VV[47]) /* PVM-ERROR */); -L171: - if(!((0)==(V4))){ - goto L174;} - VALUES(0) = Cnil; - RETURN(1); -L174: - if(!((V4)>0)){ - goto L177;} - RETURN((*LK2)(1,(V1)) /* READ-OBJECT */); -L177: - RETURN(Lerror(1,VV[48]) /* ERROR */); - } -} -/* function definition for C_PVM_RECV */ -static L44(int narg, object V1, object V2) -{ - int x; - x=pvm_recv(object_to_int(V1), object_to_int(V2)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-BLOCKING-READ */ -static L45(int narg, object V1, object V2, object V3) -{ VT31 VLEX31 CLSR31 -TTL: - {int V4; /* BUFID */ - V4= pvm_recv(fix((V2)), fix((V3))); - if(!((V4)<0)){ - goto L180;} - L1(2,MAKE_FIXNUM(V4),VV[52]) /* PVM-ERROR */; -L180: - RETURN((*LK2)(1,(V1)) /* READ-OBJECT */); - } -} -/* function definition for C_PVM_MYTID */ -static L46(int narg) -{ - int x; - x=pvm_mytid(); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-MY-TID */ -static L47(int narg) -{ VT32 VLEX32 CLSR32 -TTL: - {register int V1; /* INFO */ - V1= pvm_mytid(); - if(!((V1)<0)){ - goto L184;} - L1(2,MAKE_FIXNUM(V1),VV[56]) /* PVM-ERROR */; -L184: - VALUES(0) = MAKE_FIXNUM(V1); - RETURN(1); - } -} -/* function definition for C_PVM_EXIT */ -static L48(int narg) -{ - int x; - x=pvm_exit(); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-EXIT */ -static L49(int narg) -{ VT33 VLEX33 CLSR33 -TTL: - {int V1; /* INFO */ - V1= pvm_exit(); - if((0)==(V1)){ - goto L187;} - L1(2,MAKE_FIXNUM(V1),VV[60]) /* PVM-ERROR */; - } -L187: - RETURN(0); -} -/* function definition for C_PVM_KILL */ -static L50(int narg, object V1) -{ - int x; - x=pvm_kill(object_to_int(V1)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-KILL */ -static L51(int narg, object V1) -{ VT34 VLEX34 CLSR34 -TTL: - {int V2; /* INFO */ - V2= pvm_kill(fix((V1))); - if(!((V2)<0)){ - goto L191;} - L1(2,MAKE_FIXNUM(V2),VV[64]) /* PVM-ERROR */; - } -L191: - RETURN(0); -} -/* function definition for C_PVM_PARENT */ -static L52(int narg) -{ - int x; - x=pvm_parent(); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-PARENT */ -static L53(int narg) -{ VT35 VLEX35 CLSR35 -TTL: - {int V1; /* INFO */ - V1= pvm_parent(); - if(!((V1)==(-23))){ - goto L195;} - L1(2,MAKE_FIXNUM(V1),VV[68]) /* PVM-ERROR */; - } -L195: - RETURN(0); -} -/* function definition for C_PVM_PSTAT */ -static L54(int narg, object V1) -{ - int x; - x=pvm_pstat(object_to_int(V1)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-PSTAT */ -static L55(int narg, object V1) -{ VT36 VLEX36 CLSR36 -TTL: - {register int V2; /* INFO */ - V2= pvm_pstat(fix((V1))); - if(!((V2)==(0))){ - goto L201;} - VALUES(0) = MAKE_FIXNUM(V2); - RETURN(1); -L201: - if(!((V2)==(-31))){ - goto L204;} - VALUES(0) = MAKE_FIXNUM(V2); - RETURN(1); -L204: - RETURN(L1(2,MAKE_FIXNUM(V2),VV[72]) /* PVM-ERROR */); - } -} -/* function definition for C_PVM_MSTAT */ -static L56(int narg, object V1) -{ - int x; - x=pvm_mstat(V1->st.st_self); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-MSTAT */ -static L57(int narg, object V1) -{ VT37 VLEX37 CLSR37 -TTL: - if(type_of((V1))==t_string){ - goto L206;} - Lerror(2,VV[76],TYPE_OF((V1))) /* ERROR */; -L206: - {register int V2; /* INFO */ - V2= pvm_mstat((V1)->st.st_self); - if(!((V2)==(0))){ - goto L211;} - VALUES(0) = VV[77]; - RETURN(1); -L211: - if(!((V2)==(-6))){ - goto L214;} - VALUES(0) = VV[78]; - RETURN(1); -L214: - if(!((V2)==(-22))){ - goto L217;} - VALUES(0) = VV[79]; - RETURN(1); -L217: - RETURN(L1(2,MAKE_FIXNUM(V2),VV[80]) /* PVM-ERROR */); - } -} -/* function definition for C_PVM_SPAWN */ -static L58(int narg, object V1, object V2, object V3, object V4) -{ - object x; - x= - Cnil; - { - int numt, tid, i; - int sz = object_to_int(V2); - object v; - extern object lisp_package; - - siLmake_vector(7, intern("FIXNUM", lisp_package), - MAKE_FIXNUM(sz), Cnil, Cnil, Cnil, Cnil, Cnil); - v = VALUES(0); - numt = pvm_spawn(V1->st.st_self, 0, object_to_int(V2), V3->st.st_self, object_to_int(V4), v->v_self); - if (numt < PvmOk) RETURN(1); - VALUES(0) = MAKE_FIXNUM(numt); - VALUES(1) = v; - RETURN(2); - }; - VALUES(0)=x; - RETURN(1); -} -/* function definition for LPVM-SPAWN */ -static L59(int narg, object V1, object V2, object V3, object V4) -{ VT38 VLEX38 CLSR38 -TTL: - if(type_of((V1))==t_string){ - goto L220;} - RETURN(Lerror(2,VV[81],TYPE_OF((V1))) /* ERROR */); -L220: - if(type_of((V2))==t_fixnum||type_of((V2))==t_bignum){ - goto L223;} - RETURN(Lerror(2,VV[82],TYPE_OF((V2))) /* ERROR */); -L223: - if(type_of((V3))==t_string){ - goto L226;} - RETURN(Lerror(2,VV[83],TYPE_OF((V3))) /* ERROR */); -L226: - if(type_of((V4))==t_fixnum||type_of((V4))==t_bignum){ - goto L229;} - RETURN(Lerror(2,VV[84],TYPE_OF((V4))) /* ERROR */); -L229: - if(!(number_compare(MAKE_FIXNUM(1),(V4))<=0)){ - goto L231;} - if(number_compare((V4),MAKE_FIXNUM(32))<=0){ - goto L232;} -L231: - RETURN(Lerror(2,VV[85],(V4)) /* ERROR */); -L232: - { int V5; - object V6; /* NUM-SPAWNED */ - object V7; /* TIDS */ - V5=L58(4,(V1),(V2),(V3),(V4)) /* C_PVM_SPAWN */; - if (V5--==0) goto L237; - V6= VALUES(0); - if (V5--==0) goto L238; - V7= VALUES(1); - goto L239; -L237: - V6= Cnil; -L238: - V7= Cnil; -L239: - if(!(number_compare(MAKE_FIXNUM(0),(V6))>0)){ - goto L241;} - RETURN(L1(2,(V6),VV[86]) /* PVM-ERROR */); -L241: - VALUES(1) = (V7); - VALUES(0) = (V6); - RETURN(2);} -} -/* function definition for C_PVM_SENDSIG */ -static L60(int narg, object V1, object V2) -{ - int x; - x=pvm_sendsig(object_to_int(V1),object_to_int(V2)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-SENDSIG */ -static L61(int narg, object V1, object V2) -{ VT39 VLEX39 CLSR39 -TTL: - {int V3; /* INFO */ - V3= pvm_sendsig(fix((V1)),fix((V2))); - if(!((V3)<0)){ - goto L243;} - L1(2,MAKE_FIXNUM(V3),VV[90]) /* PVM-ERROR */; - } -L243: - RETURN(0); -} -/* function definition for C_PVM_ADVISE */ -static L62(int narg, object V1) -{ - int x; - x=pvm_advise(object_to_int(V1)); - VALUES(0)=MAKE_FIXNUM(x); - RETURN(1); -} -/* function definition for LPVM-ADVISE */ -static L63(int narg, object V1) -{ VT40 VLEX40 CLSR40 -TTL: - {int V2; /* INFO */ - V2= pvm_advise(fix((V1))); - if((V2)==(0)){ - goto L247;} - L1(2,MAKE_FIXNUM(V2),VV[94]) /* PVM-ERROR */; - } -L247: - RETURN(0); -} -static LKF2(int narg, ...) {TRAMPOLINK(VV[160],&LK2);} -static LKF1(int narg, ...) {TRAMPOLINK(VV[157],&LK1);} -static LKF0(int narg, ...) {TRAMPOLINK(VV[155],&LK0);} diff --git a/contrib/pvm/pvmecl.lsp b/contrib/pvm/pvmecl.lsp deleted file mode 100644 index 372739fcd..000000000 --- a/contrib/pvm/pvmecl.lsp +++ /dev/null @@ -1,756 +0,0 @@ -;;;-*-Mode:LISP; Syntax: Common LISP; Base: 10-*- -;;; -;;; File = pvmecl.lsp -;;; Interface between ECoLISP and PVM. -;;; This file contains the C function interface between ECoLisp and PVM. -;;; It is not portable. -;;; -;;; -;;; (c) 1994, I.D. Alexander-Craig, all rights reserved. -;;; -;;; - -;;; -;;; pvmconsts.lsp must be loaded before this file. -;;; - -;;; -;;; Error function for PVM interface. -;;; - -(defun pvm-error (errno routine) - (error "PVM interface error ~d in ~a~%" errno routine)) - - -(clines " -#include \"/project/pvm/pvm3/include/pvm3.h\" -") - - -;;; -;;; Begin with buffering routines. -;;; - -;; -;; Start with output buffering routines for simple types. -;; Each C function is followed by the corresponding entry -;; definition. Then comes the LISP function. -;; - - -(definline c_pvm_pkint (fixnum) fixnum - "({int x = #0; pvm_pkint(&x,1,1);})" -) - -(defun obuffer-int (i) - (let ((info (c_pvm_pkint i))) - (unless (= %PvmOk info) - (pvm-error info "obuffer-int"))) - (values)) - -;; -;; Packing routine for message types. This is a LISP function -;; that calls c_pvm_pkint to pack the type. -;; - -(defun pack-type-tag (typetag) - (let ((return-code (c_pvm_pkint typetag))) - (unless (= %PvmOk return-code) - (pvm-error return-code "pack-type-tag"))) - (values)) - -(defun C-obuffer-nil () - (pack-type-tag LISP_NIL_TYPE)) - -(defun C-obuffer-t () - (pack-type-tag LISP_T_TYPE)) - -(definline c_pvm_pkchar (character) fixnum - "({char x = #0; pvm_pkbyte(&x,1,1);})" -) - -(defun C-obuffer-char (ch) - (pack-type-tag LISP_CHAR_TYPE) - (let ((info (c_pvm_pkchar ch))) - (unless (= %PvmOk info) - (pvm-error info "pvm_pkchar call"))) - (values)) - -(defun C-obuffer-int (i) - (pack-type-tag LISP_INT_TYPE) - (let ((info (c_pvm_pkint i))) - (unless (= %PvmOk info) - (pvm-error info "pvm_pkint call"))) - (values)) - -(definline c_pvm_pkfloat (short-float) fixnum - "({float x = #0; pvm_pkfloat(&x,1,1);})" -) - -(defun obuffer-float (fl) - (let ((info (c_pvm_pkfloat fl))) - (unless (= %PvmOk info) - (pvm-error info "obuffer-float"))) - (values)) - -(definline c_pvm_pkdouble (long-float) fixnum - "({double x = #0; pvm_pkdouble(&x,1,1);})" -) - -(defun C-obuffer-double (db) - (let ((info (c_pvm_pkdouble db))) - (unless (= %PvmOk info) - (pvm-error info "obuffer-double"))) - (values)) - -;; -;; Packing routines for symbol and string. -;; Both routines expect a string and a number (in that order) -;; to be supplied to them. -;; The number is the length of the string. -;; -;; -;; The first function packs the length and the string into -;; the output buffer. -;; -(definline c_pvm_pkstr (string fixnum) fixnum - "({int type = #1; - type = pvm_pkint(&type,1,1); - ((type == PvmOk) ? pvm_pkstr((#0)->st.st_self) : type);})" -) -;; -;; Now define the routines that manipulate symbols and strings. -;; - -(defun C-obuffer-symbol (s) - (let ((pname (symbol-name s))) - (let ((len (length pname))) - (pack-type-tag LISP_SYMBOL_TYPE) - (let ((info (c_pvm_pkstr pname len))) - (unless (= %PvmOk info) - (pvm-error info "obuffer-symbol"))))) - (values)) - -(defun C-obuffer-string (str) - (let ((len (length str))) - (pack-type-tag LISP_STRING_TYPE) - (let ((info (c_pvm_pkstr str len))) - (unless (= %PvmOk info) - (pvm-error info "obuffer-string")))) - (values)) - -;; -;; Packing routines for vector and list headers. -;; - -(defun C-obuffer-vector-header (vector-length) - (pack-type-tag LISP_VECTOR_TYPE) - (let ((info (c_pvm_pkint vector-length))) - (unless (= %PvmOk info) - (pvm-error info "obuffer-vector-header"))) - (values)) - -(defun C-obuffer-list-header () - (pack-type-tag LISP_LIST_TYPE) - (values)) - -;; -;; Unpacking routines for scalar types. -;; - -(defcbody c_pvm_unpack_tag () object -" Cnil; - { int tagval, info; - info = pvm_upkint(&tagval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = MAKE_FIXNUM(tagval); - RETURN(2); - }" -) - -;(proclaim '(inline ibuffer-tag)) -(defun ibuffer-tag () - (multiple-value-bind (info value) - (c_pvm_unpack_int) - (if info - value - (pvm-error info "ibuffer-tag")))) - -(defun C-next-msg-type () - (ibuffer-tag)) - -(defun C-next-type-name () - (ibuffer-tag)) - -(defcbody c_pvm_unpack_int () object -" Cnil; - { int ival, info; - info = pvm_upkint(&ival,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = MAKE_FIXNUM(ival); - RETURN(2); - }" -) - -(defun C-ibuffer-int () - (multiple-value-bind (info value) - (c_pvm_unpack_int) - (if info - value - (pvm-error info "ibuffer-int")))) - -(defcbody c_pvm_unpack_char () object -" Cnil; - { int info; - char chval; - info = pvm_upkbyte(&chval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = code_char(chval); - RETURN(2); - }" -) - -(defun C-ibuffer-char () - (multiple-value-bind (info value) - (c_pvm_unpack_char) - (if info - value - (pvm-error info "ibuffer-char")))) - -(defcbody c_pvm_unpack_float () object -" Cnil; - { int info; - float fval; - info = pvm_upkfloat(&fval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = make_shortfloat(fval); - RETURN(2); - }" -) - -(defun ibuffer-float () - (multiple-value-bind (info value) - (c_pvm_unpack_float) - (if info - value - (pvm-error info "ibuffer-float")))) - -(defcbody c_pvm_unpack_double () object -" Cnil; - { - int info; - double dval; - info = pvm_upkdouble(&dval,1,1); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = make_longfloat(dval); - RETURN(2); - }" -) - -(defun C-ibuffer-double () - (multiple-value-bind (info value) - (c_pvm_unpack_double) - (if info - value - (pvm-error info "ibuffer-double")))) - - -;; -;; Routines to get symbols and strings from the PVM -;; buffer. -;; This is a little tricky! -;; - -;; -;; First, a general unpacking routine for strings. -;; - -(defun setstring (chr indx str) - (setf (aref str indx) chr) - (values)) - -(defcbody c_pvm_unpack_chars (fixnum) object -" - Cnil; - { char *strchrs; - int info; - info = pvm_upkstr(strchrs); - if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);} - VALUES(0) = MAKE_FIXNUM(info); - VALUES(1) = make_simple_string(strchrs); - RETURN(2); - }" -) - - -;; -;; Now the routine which gets the length and the string -;; from the buffer. -;; - -(defun get-length-and-string () - (let ((len (ibuffer-int))) - (multiple-value-bind (info str) - (c_pvm_unpack_chars len) - (if info - (if (= (length str) len) - str - (format - t - "received string has length ~a, not ~a as promised.~%" - (length str) - len)) - (pvm-error info "get-length-and-string"))))) - -(defun C-ibuffer-symbol () - ; It might be useful sometimes just to return the string. - (let ((pname (get-length-and-string))) - (make-symbol pname))) - -(defun C-ibuffer-string () - (get-length-and-string)) - - -(defun C-ibufer-vector-length () - (C-ibuffer-int)) - - -;;; -;;; Send and received routines (together with registration and exit). -;;; - -(definline c_pvm_initsend (fixnum) fixnum - "pvm_initsend(#0)") - -(defun lpvm-init-send (encoding) - (cond ((not (integerp encoding)) - (error "lpvm-init-send expects an int, not a ~a~%" - (type-of encoding))) - ((minusp encoding) - (error - "lpvm-init-send: encoding must be non-negative (~d)~%" - encoding)) - (t - (let ((bufid (c_pvm_initsend encoding))) - (when (minusp bufid) - (pvm-error bufid "pvm_initsend call")) - bufid)))) - -(definline c_pvm_send (fixnum fixnum) fixnum - "pvm_send(#0, #1)") - -;;; -;;; The send routine. -;;; - -(defun lpvm-send-message (lisp-object - reader-object - message-type - destination-task - &optional (encoding %PvmDataDefault)) - (lpvm-init-send encoding) - (write-object lisp-object reader-object) - (let ((info (c_pvm_send destination-task message-type))) - (when (minusp info) - (pvm-error info "pvm_send call"))) - (values)) - -;;; -;;; The multi-cast routine is similar, but we set up the buffer -;;; once and then repeatedly send the message. -;;; - -(defun lpvm-multicast (lisp-object - reader-object - message-type - destination-tasks - &optional (encoding %PvmDataDefault)) - (lpvm-init-send encoding) - (write-object lisp-object reader-object) - (dolist (tid destination-tasks) - (let ((info (c_pvm_send tid message-type))) - (when (minusp info) - (pvm-error info "pvm_multicast")))) - (values)) - -;;; -;;; Receive routines. -;;; - -(definline c_pvm_nrecv (fixnum fixnum) fixnum - "pvm_nrecv(#0,#1)" -) - -(defun lpvm-nonblocking-recv (object-reader tid msgtag) - (let ((bufid (c_pvm_nrecv tid msgtag))) - (cond ((minusp bufid) - (pvm-error bufid "pvm_nrecv")) - ((= %PvmOk bufid) - ()) ; nothing there - ((plusp bufid) - (read-object object-reader)) - (t - (error - "something weird has happened---nonblocking-recv"))))) - -(definline c_pvm_recv (fixnum fixnum) fixnum - "pvm_recv(#0, #1)" -) - -(defun lpvm-blocking-read (object-reader tid msgtag) - (let ((bufid (c_pvm_recv tid msgtag))) - (when (minusp bufid) - (pvm-error bufid "pvm_recv")) - (read-object object-reader))) - - -;;; -;;; Join PVM primitive. -;;; - -(definline c_pvm_mytid () fixnum - "pvm_mytid()" -) - -(defun lpvm-my-tid () - (let ((info (c_pvm_mytid))) - (when (minusp info) - (pvm-error info "pvm_mytid call")) - info)) - - -;;; -;;; Leave PVM primitive. -;;; - -(definline c_pvm_exit () fixnum - "pvm_exit()") - -(defun lpvm-exit () - (let ((info (c_pvm_exit))) - (unless (= %PvmOk info) - (pvm-error info "pvm_exit call"))) - (values)) - - -(definline c_pvm_kill (fixnum) fixnum - "pvm_kill(#0)" -) - -(defun lpvm-kill (tid) - (let ((info (c_pvm_kill tid))) - (when (minusp info) - (pvm-error info "pvm_kill call"))) - (values)) - -(definline c_pvm_parent () fixnum - "pvm_parent()" -) - -(defun lpvm-parent () - (let ((info (c_pvm_parent))) - (when (= info %PvmNoParent) - (pvm-error info "pvm_parent"))) - (values)) - -(definline c_pvm_pstat (fixnum) fixnum - "pvm_pstat(#0)" -) - -(defun lpvm-pstat (tid) - (let ((info (c_pvm_pstat tid))) - (cond ((= info %PvmOk) - info) - ((= info %PvmNoTask) - info) - (t - (pvm-error info "pvm_stat call"))))) - -(definline c_pvm_mstat (string) fixnum - "pvm_mstat(#0->st.st_self)" -) - -(defun lpvm-mstat (hostname) - (unless (stringp hostname) - (error "lpvm-mstat: hostnames must be strings, not ~a~%" - (type-of hostname))) - (let ((info (c_pvm_mstat hostname))) - (cond ((= info %PvmOk) - 'running) - ((= info %PvmNoHost) - 'no-such-host) - ((= info %PvmHostFail) - 'host-unreachable) - (t - (pvm-error info "pvm_mstat call"))))) - -(defcbody c_pvm_spawn (string fixnum string fixnum) object -" - Cnil; - { - int numt, tid, i; - int sz = #1; - object v; - extern object lisp_package; - - siLmake_vector(7, intern(\"FIXNUM\", lisp_package), - MAKE_FIXNUM(sz), Cnil, Cnil, Cnil, Cnil, Cnil); - v = VALUES(0); - numt = pvm_spawn(#0->st.st_self, 0, #1, #2->st.st_self, #3, v->v.v_self); - if (numt < PvmOk) RETURN(1); - VALUES(0) = MAKE_FIXNUM(numt); - VALUES(1) = v; - RETURN(2); - }" -) - -(defun lpvm-spawn (taskname flag where numtasks) - (cond ((not (stringp taskname)) - (error "spawn -- wrong type: ~A" (type-of taskname))) - ((not (integerp flag)) - (error "spawn -- wrong type: ~A" (type-of flag))) - ((not (stringp where)) - (error "spawn -- wrong type: ~A" (type-of where))) - ((not (integerp numtasks)) - (error "spawn -- wrong type: ~A" (type-of numtasks))) - ((not (and (<= 1 numtasks) - (<= numtasks 32))) - (error "spawn -- wrong number of tasks: ~D" numtasks)) - (t - (multiple-value-bind (num-spawned tids) - (c_pvm_spawn taskname flag where numtasks) - (if (minusp num-spawned) - (pvm-error num-spawned "pvm_spawn call") - (values num-spawned tids)))))) - - -(definline c_pvm_sendsig (fixnum fixnum) fixnum - "pvm_sendsig(#0,#1)" -) - -(defun lpvm-sendsig (tid signum) - (let ((info (c_pvm_sendsig tid signum))) - (when (minusp info) - (pvm-error info "pvm_sendsig call"))) - (values)) - -(definline c_pvm_advise (fixnum) fixnum - "pvm_advise(#0)" -) - -(defun lpvm-advise (route) - (let ((info (c_pvm_advise route))) - (unless (= info %PvmOk) - (pvm-error info "pvm_advise call"))) - (values)) - -;;;; -;;;; Group operations. -;;;; - - -(definline c_pvm_join_group (object) fixnum - "pvm_joingroup(#0->st.st_self)" -) - -(defun lpvm-join-group (group) - (unless (stringp group) - (error "lpvm-join-grou expects a string, not a ~a~%" - (type-of group))) - (let ((inum (c_pvm_joingroup group))) - (when (minusp inum) - (pvm-error inum "pvm_joingroup call")) - inum)) - -(definline c_pvm_leave_group (object) fixnum - "pvm_lvgroup(#0->st.st_self)" -) - -(defun lpvm-leave-group (group) - (unless (stringp group) - (error - "lpvm-leave-group expects a string, not a ~a~%" - (type-of group))) - (let ((info (c_pvm_leave_group group))) - (when (minusp info) - (pvm-error info "pvm_lvgroup call"))) - (values)) - -(definline c_pvm_get_tid (object fixnum) fixnum - "pvm_gettid(#0->st.st_self, #1)" -) - -(defun lpvm-get-tid (group inum) - (unless (stringp group) - (error - "lpvm-get-tid expects arg 1 to be a string, not a ~a~%" - (type-of group))) - (unless (integerp inum) - (error - "lpvm-get-tid expects arg 2 to be an int, not a ~a~%" - (type-of inum))) - (let ((info (c_pvm_get_tid group inum))) - (cond ((plusp info) - info) - ((minusp info) - (pvm-error info "pvm_gettid call")) - (t - (pvm-error 0 "pvm_gettid: should not happen"))))) - -(definline c_pvm_get_inst (object fixnum) fixnum - "pvm_getinst(#0->st.st_self, #1)" -) - -(defun lpvm-get-inst-no (group tid) - (cond ((not (stringp group)) - (error - "lpvm-get-inst-no expects arg1 to be a string, not a ~a~%" - (type-of group))) - ((not (integerp tid)) - (error - "lpvm-get-inst-no expects arg2 to be an int, not a ~a~%" - (type-of tid))) - (t - (let ((inum (c_pvm_get_inst group tid))) - (when (minusp inum) - (pvm-error inum "pvm_getinst call")) - inum)))) - -(definline c_pvm_grpsize (object) fixnum - "pvm_gsize(#0->st.st_self)" -) - -(defun lpvm-group-size (group) - (unless (stringp group) - (error - "lpvm-group-size expects a string not a ~a~%" - (type-of group))) - (let ((size (c_pvm_grpsize group))) - (when (minusp size) - (pvm-error size "pvm_gsize call")) - size)) - -(definline c_pvm_barrier (object fixnum) fixnum - "pvm_barrier(#0->st.st_self,#1)" -) - -(defun lpvm-barrier (group count) - (cond ((not (stringp group)) - (error - "lpvm-barrier expects arg 1 to be a string, not a ~a~%" - (type-of group))) - ((not (integerp count)) - (error - "lpvm-barriet expects arg 2 to be an int, not a ~a~%" - (type-of count))) - (t - (let ((info (c_pvm_barrier group count))) - (unless (= %PvmOk info) - (pvm-error info "pvm_barrier call"))))) - (values)) - -(definline c_pvm_broadcast (object fixnum) fixnum - "pvm_bcast(#0->st.st_self,#1)" -) - -(defun lpvm-broadcast (lisp-object - reader-object - message-type - group-name - &optional (encoding %PvmDataDefault)) - (lpvm-init-send encoding) - (write-object lisp-object reader-object) - (let ((info (c_pvm_broadcast group-name message-type))) - (when (minusp info) - (pvm-error info "pvm_bcast call"))) - (values)) - - -(defCbody c_pvm_probe (fixnum fixnum) fixnum - "0; - { int bufid, info; - int *bytes; - int out_tid, out_tag; - VALUES(0) = Cnil; - bufid = pvm_probe(#0,#1); - if (bufid == 0) RETURN(1); - if (bufid < 0) { - VALUES(0) = CONS(MAKE_FIXNUM(bufid), Cnil); - RETURN(1); - } - info = pvm_bufinfo(bufid,bytes,&out_tag,&out_tid); - VALUES(0) = list(3, MAKE_FIXNUM(info), MAKE_FIXNUM(out_tag), - MAKE_FIXNUM(out_tid)); - RETURN(1); - }" -) - -(defun lpvm-probe (tid msgno) - (let ((return-val (c_pvm_probe tid msgno))) - (let ((num-returned (length return-val)) - (out-tid 0) - (out-tag 0) - (info 0)) - (cond ((= num-returned 1) - (pvm-error (car return-val) "pvm_probe call")) - (t - (setf info (first return-val)) - (setf out-tag (second return-val)) - (setf out-tid (third return-val)) - (if (= info %PvmOk) - (values out-tid out-tag) - (pvm-error info "pvm_probe call"))))))) - - -;;;; -;;;; Add and delete hosts. -;;;; - -;; -;; add_host adds a single host to the machine. hostname is the -;; string name of the host. The function returns a pair. - -(defCbody c_pvm_add_host (object) object - "Cnil; - { int host_info[1]; - int info, hival; - info = pvm_addhosts(&(#0)->st.st_self,1,host_info); - hival = host_info[0]; - VALUES(0) = list(2, MAKE_FIXNUM(info), MAKE_FIXNUM(hival)); - RETURN(1); - }" -) - -(defun add-hosts (hostnames) - (let ((results (make-array (length hostnames)))) - (dotimes (host (length hostnames)) - (let ((host (aref hostnames))) - (c_pvm_add_host host) - (setf (aref results host)(cadr host)))) - results)) - - -(defCbody c_pvm_del_host (object) object - "Cnil; - { int host_info[1]; - int info, hival; - info = pvm_delhosts(&(#0)->st.st_self,1,host_info); - hival = host_info[0]; - VALUES(0) = list(2, MAKE_FIXNUM(info), MAKE_FIXNUM(hival)); - RETURN(1); - }" -) - -(defun del-hosts (hostnames) - (let ((results (make-array (length hostnames)))) - (dotimes (host (length hostnames)) - (let ((host (aref hostnames))) - (c_pvm_add_host host) - (setf (aref results host) (cadr host)))) - results)) - diff --git a/contrib/pvm/pvmlisp.lsp b/contrib/pvm/pvmlisp.lsp deleted file mode 100644 index 67fb2e0b7..000000000 --- a/contrib/pvm/pvmlisp.lsp +++ /dev/null @@ -1,620 +0,0 @@ -;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*- -;;; -;;; File = pvmlisp.lsp -;;; -;;; New version of reader structure using vectors. -;;; -;;; -;;; This code only works with Common LISP. It should not be included -;;; in a CLOS program (yet). It will also not work with CLiCC. -;;; -;;; -;;; Message-start-p is used to detect the start of a complex message. -;;; It is true if it is applied to a message tag. -;;; - -(defun message-start-p (mty) - (and (integerp mty) - (= MESSAGE_START mty))) - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; We define the reader object. This is a structure containing ;;;; -;;;; the function closures which perform the encoding and decoding. ;;;; -;;;; We begin by defining the encoder and decoder structures and ;;;; -;;;; manipulation functions (this will be a dream in CLOS or ;;;; -;;;; TELOS!) ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -;;; -;;; The encoder structure. -;;; The design of the encoder is such that it allows users to configure -;;; their own encoders. For example, CMU CL calls a SIMPLE-STRING a -;;; SIMPLE-BASE-STRING. This can be accomodated within this organisation -;;; at the cost of a little effort. -;;; -(defstruct encoder-rec - typename ;; value returned by type-of and used to index the - ;; encoder function - msgtypeno ;; the numeric message type - encoder-fn) - -;;; -;;; Encoders are held in hash tables. The following function (which -;;; should be inline) creates such a table. -;;; -;(declaim (inline make-encoder-structure)) -(proclaim '(inline make-encoder-structure)) - -(defun make-encoder-structure () - (make-hash-table :test #'eq)) - -;;; -;;; encoder-present-p is true if there is an encoder for the -;;; named type in the encoder table. -;;; - -(defun encoder-present-p (enc-struc typename) - (multiple-value-bind (encrec there) - (gethash typename enc-struc) - (declare (ignore encrec)) - there)) - -;;; -;;; Retrieval function for encoders. Given a type name, it returns the -;;; encoder function associated with the type. -;;; - -(defun get-encoder (enc-struc typename) - (multiple-value-bind (encoder-rec known-type) - (gethash typename enc-struc) - (if known-type - (encoder-rec-encoder-fn encoder-rec) - ()))) - -;;; -;;; Routine to store an encoder function. -;;; Assumes that typename and typeno have been checked. -;;; - -(defun put-encoder (enc-struc typename typeno encoder-fn) - (setf (gethash typename enc-struc) - (make-encoder-rec :encoder-fn encoder-fn - :typename typename - :msgtypeno typeno)) - (values)) - -;;;****************************************************************;;; -;;; ;;; -;;; ;;; -;;; A routine to replace the encoder function and a routine to ;;; -;;; remove an encode could be added here. ;;; -;;; ;;; -;;; ;;; -;;;****************************************************************;;; - -;;; -;;; message-type-number returns the type number associated with a -;;; symbolic type name. Its input is an encoder structure. -;;; - -(defun message-type-number (enc-struc typename) - (multiple-value-bind (enc-rec known-type) - (gethash typename enc-struc) - (if known-type - (encoder-rec-msgtypeno enc-rec) - (error "cannot return type number for type ~a: unknown type.~%" - typename)))) - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; The decoder structure and containing object. ;;;; -;;;; ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -;;; -;;; The decoder is indexed by its message type number. -;;; Decoders have a symbolic identifier associated with them. -;;; - -(defstruct decoder-rec - typename - decoder-fn) - -;;; -;;; Decoders are held in a hash table. The table is indexed by the -;;; message number. The hash table representation is used so that -;;; users can have gaps in their message number sequences. -;;; - -;(declaim (inline make-decoder-structure)) -(proclaim '(inline make-decoder-structure)) - -(defun make-decoder-structure () - (make-hash-table :test #'eql)) - -;;; -;;; decoder-present-p is true if there is a decoder structure -;;; in the decoder table at the point indexed by the numeric -;;; message type. -;;; - -(defun decoder-present-p (dec-struc msg-type-no) - (multiple-value-bind (decrec there) - (gethash msg-type-no dec-struc) - (declare (ignore decrec)) - there)) - -;;; -;;; get-decoder returns the decoder function associated with a -;;; message type number. If there is no such message, an error is raised. -;;; - -(defun get-decoder (decoder-struc msg-no) - (multiple-value-bind (decrec there) - (gethash msg-no decoder-struc) - (if there - (decoder-rec-decoder-fn decrec) - ()))) - -;;; -;;; put-decoder inserts a decoder record into the decoder vector. -;;; If a decoder structure is already in the vector at the place -;;; indexed by the message number, an error is raised. -;;; -;;; Note that this function will expand the vector if there is -;;; insufficient room. -;;; - -(defun put-decoder (decoder-struc msg-no msg-typename decoder-fn) - (setf (gethash msg-no decoder-struc) - (make-decoder-rec :typename msg-typename - :decoder-fn decoder-fn)) - (values)) - - -;;;****************************************************************;;; -;;; ;;; -;;; ;;; -;;; A routine to replace the decoder function and a routine to ;;; -;;; remove an encode could be added here. ;;; -;;; ;;; -;;; ;;; -;;;****************************************************************;;; - -;;; -;;; message-number-type returns the symbolic name associated with -;;; a numeric message type. -;;; - -(defun message-number-type (decoder-struc msg-type-no) - (decoder-rec-typename - (aref decoder-struc msg-type-no))) - - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; The reader object and its associated functions. ;;;; -;;;; Note that encoder and decoders can be added or removed at ;;;; -;;;; runtime. ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -(defstruct reader-object - (encoders (make-encoder-structure)) - (decoders (make-decoder-structure)) - (known-type-names ())) - -;;; -;;; A creation function for readers. -;;; - -(defun make-object-reader () - (make-reader-object)) - -;;; -;;; add-type-name adds a symbolic type name to the reader object. -;;; - -;(declaim (inline add-type-name)) -(proclaim '(inline add-type-name)) - -(defun add-type-name (reader-obj typename) - (pushnew typename - (reader-object-known-type-names reader-obj) - :test #'eq) - (values)) - -;;;; A deletion function can easily be defined. - -;;; -;;; valid-type-name-p is true iff the type name supplied as -;;; the second argument is known to the reader supplied as the -;;; first argument. -;;; - -;(declaim (inline valid-type-name-p)) -(proclaim '(inline valid-type-name-p)) - -(defun valid-type-namex-p (reader-obj typename) - (member typename - (reader-object-known-type-names reader-obj) - :test #'eq)) - -;(declaim (inline known-type-name-p)) -(proclaim '(inline known-type-name-p)) - -(defun known-type-name-p (reader-obj typename) - (member typename - (reader-object-known-type-names reader-obj) - :test #'eq)) - -;;; -;;; valid-message-type-no-p is true if the message type number -;;; supplied as the second argument is (i) positive and (ii) in the -;;; range 0 .. (length decoders) -;;; - -;(declaim (inline valid-message-type-no-p)) -(proclaim '(inline valid-message-type-no-p)) - -(defun valid-message-type-no-p (reader-obj msg-typeno) - (multiple-value-bind (decrec present) - (gethash msg-typeno - (reader-object-decoders reader-obj)) - (declare (ignore decrec)) - present)) - -;(declaim (inline known-type-number-p)) -(proclaim '(inline known-type-number-p)) - -(defun known-type-number-p (reader-obj msg-typeno) - (multiple-value-bind (decrec present) - (gethash msg-typeno - (reader-object-decoders reader-obj)) - (declare (ignore decrec)) - present)) - -;;; -;;; Routines to add encoder and decoder functions to a reader object. -;;; They can be called at runtime as well as at configuration time. -;;; Procedures to replace readers and writers could be defined if -;;; necessary---they won't be too difficult. -;;; - -(defun add-encoder (reader-obj ;; the reader object - message-type-no ;; the numeric type of the - ;; message type - message-type-name ;; the symbolic name of the - ;; message type - encoder-function) ;; the encoder function proper - ; start by checking that the type is not already known. - (when (and (known-type-name-p reader-obj message-type-name) - (encoder-present-p (reader-object-encoders reader-obj) - message-type-name)) - (error - "add-encoder: cannot add encoder for ~a -- one already present~%" - message-type-name)) - ; try to add the type name (a decoder might have put it there already) - (add-type-name reader-obj message-type-name) - ; add the encoder function - (put-encoder (reader-object-encoders reader-obj) - message-type-name - message-type-no - encoder-function) - (values)) - - -(defun add-decoder (reader-obj ;; the reader object - message-type-no ;; the numeric type of the - ;; message type - message-type-name ;; the symbolic name of the - ;; message type - decoder-function) ;; the encoder function proper - ; start by checking that the type is not already known - (when (and (known-type-name-p reader-obj message-type-name) - (decoder-present-p (reader-object-decoders reader-obj) - message-type-no)) - (error - "add-decoder: cannot add decoder for ~a -- one already present~%" - message-type-name)) - ; try to add the type name (an encoder might have already added it) - (add-type-name reader-obj message-type-name) - ; add the decoder function - (put-decoder (reader-object-decoders reader-obj) - message-type-no - message-type-name - decoder-function) - (values)) - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; Some utility functions. ;;;; -;;;; ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -;;; -;;; Only proper lists can be transmitted and received -- sorry. -;;; - -(defun proper-listp (l) - (and (not (null l)) - (list l) - (null (cdr (last l))))) - -;;; -;;; type-name is used in indexing the encoders. -;;; - -(defun type-name (typ) - (if (symbolp typ) - typ - (car typ))) - -;;; -;;; initialise-reader-object takes a reader object as its first -;;; argument and a list of lists of the following form: -;;; (typename -- a symbol -;;; typeno -- a natural number (one of the LISP_X_TYPEs) -;;; encoder -- a closure or the symbol '* -;;; decoder -- a closure or the symbol '* -;;; ) -;;; - -(defun initialise-reader-object (reader-obj ;; the reader to be started. - specs) ;; a list of reader and writer - ;; specifications - (dolist (spec specs) - (let ((typename (first spec)) - (typeno (second spec)) - (encfn (third spec)) - (decfn (fourth spec))) - (when (and (symbolp encfn) - (eq encfn '*) - (symbolp decfn) - (eq decfn '*)) - (error - "initialise reader: reader and writer for ~a both unspecified.~%" - typename)) - (unless (and (symbolp encfn) - (eq '* encfn)) - ; add an encoder. - (add-encoder reader-obj typeno typename encfn)) - (unless (and (symbolp decfn) - (eq '* decfn)) - (add-decoder reader-obj typeno typename decfn)))) - (values)) - - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; Routines to apply encoders and decoders. These are the core ;;;; -;;;; of the module. ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -(defun apply-encoder (objectreader ;; reader in which to look for encoder - lisp-object) ;; object to encode - (let ((tname (type-name (type-of lisp-object)))) - (cond ((not (known-type-name-p objectreader tname)) - (error - "apply-encoder: cannot encode -- unknown type ~a for object ~a~%" - tname - lisp-object)) - (t - (let ((encode-fn (get-encoder - (reader-object-encoders objectreader) - tname))) - (cond ((null encode-fn) - (error - "apply-encoder: no writer function for type ~a~%" - tname)) - (t - (funcall encode-fn lisp-object objectreader))))))) - (values)) - -(defun apply-decoder (objectreader ;; the reader in which to look - message-type-no) ;; the number of the message - (cond ((not (known-type-number-p objectreader message-type-no)) - (error - "apply-decoder: cannot decode -- unknown message type number ~d~%" - message-type-no)) - (t - (let ((decoder-struc (reader-object-decoders objectreader))) - (let ((decoder-fn (get-decoder decoder-struc message-type-no))) - (if (null decoder-fn) - (error - "apply-decoder: no reader function for type ~a~%" - (message-number-type decoder-struc message-type-no)) - (funcall decoder-fn objectreader))))))) - - - -;;;****************************************************************;;; -;;; ;;; -;;; User interface functions. ;;; -;;; ;;; -;;;****************************************************************;;; - -(defun write-object (object reader) - (apply-encoder reader object)) - -(defun write-user-object-type (object reader) - (let ((encoders (reader-object-encoders reader))) - (multiple-value-bind (encrec there) - (gethash (type-name (type-of object)) - encoders) - (if there - (let ((msgno (encoder-rec-msgtypeno encrec))) - (when (>= msgno LISP_MIN_USER_TYPE) - (C-set-message-type msgno))) - (error - "write-object: no encoder information for type ~a~%" - (type-name (type-of object))))))) - -(defun read-object (reader) - (let ((next-object-type (C-next-msg-type))) -(format t "got next type: ~A~%" (type-of next-object-type)) - (when (message-start-p next-object-type) - (setf next-object-type (C-next-type-name))) - (apply-decoder reader next-object-type))) - -(defun add-writer (reader type-no type-name writer-fn) - (add-encoder reader type-no type-name writer-fn)) - -(defun add-reader (reader type-no type-name writer-fn) - (add-decoder reader type-no type-name writer-fn)) - - - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; Readers and writers for vectors and lists. ;;;; -;;;; These should be used as default (they are, in any case, ;;;; -;;;; portable). ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; - -;(declaim (inline ok-message-type)) -(proclaim '(inline ok-message-type)) - -(defun ok-message-type (rdr type-no) - (known-type-number-p rdr type-no)) - -;;; -;;; Writer (encoder) for vectors. -;;; Vectors must be of type SIMPLE-VECTOR. -;;; - -(defun encode-vector (vec objreader) - (let ((len (length vec))) ;; get the length for the header. - ;; call the C primitive for stuffing the length - ;; into the PVM buffer - (C-obuffer-vector-header len) - ;; iterate over the vector, encoding each item and - ;; stuffing it into the buffer. - (dotimes (i len) - (apply-encoder objreader (aref vec i))) - ;; when control drops out of the bottom of this loop, - ;; the vector has been encoded. - )) - -;;; -;;; Reader (decoder) for vectors. -;;; - -(defun decode-vector (objreader) - ;; we know we have a vector, so get the length by - ;; calling the C primitive. - (let ((vector-len (C-ibuffer-vector-length))) - (cond ((minusp vector-len) - (error "Cannot read vector: negative length ~d~%" - vector-len)) - ((zerop vector-len) - (make-array '(0))) - (t - (let ((vec (make-array (list vector-len)))) - ;; create a new vector and try to fill its elements - (dotimes (i vector-len) - (let ((next-obj-type ;; get the type of the next - ;; object to be decoded from a C - ;; routine - (C-next-msg-type))) - (when (not (ok-message-type objreader next-obj-type)) - ;; call a routine to check that there is an object - ;; that comes next. - (error "Cannot read vector: invalid type ~s~%" - next-obj-type)) - (when (message-start-p next-obj-type) - (setq next-obj-type (C-next-type-name))) - (let ((next-elem (apply-decoder objreader next-obj-type))) - (setf (aref vec i) next-elem)))) - vec))))) - -;;; -;;; Writer (encoder) for lists. -;;; Lists must be PROPER lists. -;;; - -(defun encode-list (list-to-go objreader) - ;; First ensure that we have a proper list. - (unless (proper-listp list-to-go) - (error - "encode-list: input list is not proper~% ~s ~%-- cannot encode, sorry.~%" - list-to-go)) - ;; The list header should have been put into the output buffer. - ;; Remember that the end of the list has to be a nil message object. - ;; So: mark the object to go as a list by calling the C routine. - ;; (Perhaps the length could also be encoded for extra checking--- - ;; perhaps not.) - ;; OK. Run over the list and encode the elements. - (C-obuffer-list-header) - (mapc ; or dolist or explicit manipulation---it doesn't matter - #'(lambda (element) - (apply-encoder objreader element)) - list-to-go) - ;; finally, put a NIL into the output buffer to say that it's the - ;; end: do this by calling the C routine. - (C-obuffer-nil) - (values)) - -;;; -;;; Reader (decoder) for lists. -;;; - -(defun decode-list (objreader) - ;; When we're called, we know we have a list. - ;; We need to iterate until we get a nil object. - ;; (Problem: what happens if there is no nil at the end??) - (let ((newlist ()) ;; the list we're going to build. - (next-item-type ())) ;; the type of the next object in the - ;; input buffer - (loop - (setq next-item-type (C-next-msg-type)) - (when (not (ok-message-type objreader next-item-type)) - (error "cannot decode list: invalid type ~s~%" - next-item-type)) - (cond ((= next-item-type LISP_NIL_TYPE) - (return)) ; got the end of the list. - ((message-start-p next-item-type) - (setq next-item-type (C-next-type-name)) - (push (apply-decoder objreader next-item-type) newlist)) - (t - (push (apply-decoder objreader next-item-type) newlist)))) - (reverse newlist))) - - -;;;;****************************************************************;;;; -;;;; ;;;; -;;;; An example of how to define a reader and a writer for a ;;;; -;;;; structure (the same outline applies to classes). ;;;; -;;;; ;;;; -;;;;****************************************************************;;;; -#| - -(defparameter *rdr* (make-object-reader)) - -(defstruct foo slot1 slot2) - -(defconstant foo-type 32) - -(defun write-foo (obj rdr) - (write-object (foo-slot1 obj) rdr) - (write-object (foo-slot2 obj) rdr)) - -(defun read-foo (rdr) - (let ((s1 (read-object rdr)) - (s2 (read-object rdr))) - (make-foo :slot1 s1 :slot2 s2))) - -(add-writer *rdr* foo-type 'foo #'write-foo) -(add-reader *rdr* foo-type 'foo #'read-foo) -|# diff --git a/contrib/thread.patch b/contrib/thread.patch deleted file mode 100644 index 8bb1c1361..000000000 --- a/contrib/thread.patch +++ /dev/null @@ -1,2062 +0,0 @@ ---- src/c/error.c Mon Jun 24 04:19:09 1996 -+++ zsrc/c/error.c Mon Jul 22 18:13:48 1996 -@@ -103,10 +103,44 @@ - - object siSterminal_interrupt; - -+/* This gets _hard_ in threaded systems... */ -+/* remembering that we may be in any thread when we get this call... */ -+/* we may also _not_ be in a thread. Fortunately we can tell which */ -+/* thread we are in by examining 'active'. */ -+/* First determine where we are, if we are scheduled, or descheduled */ -+/* if descheduled, then we need to be rescheduled... */ -+/* then we can */ -+ -+#ifdef THREADS -+static bool ti_corr = 0; -+extern void *override_redirect_fun; -+extern pd *override_redirect_process; -+extern pd main_pd; -+ -+terminal_interrupt2() -+{ -+ funcall(2, siSterminal_interrupt, ti_corr? Ct : Cnil); -+} -+ -+terminal_interrupt(bool correctable) -+{ -+ ti_corr = correctable; -+ -+ start_critical_section(); -+ -+ override_redirect_process = &main_pd; -+ override_redirect_fun = terminal_interrupt2; -+ -+ force_resumption(&main_pd); -+ end_critical_section(); -+} -+ -+#else - terminal_interrupt(bool correctable) - { - funcall(2, siSterminal_interrupt, correctable? Ct : Cnil); - } -+#endif /* THREADS */ - - object - ihs_function_name(object x) -diff --recursive --unified=3 src/c/file.d zsrc/c/file.d ---- src/c/file.d Tue Mar 12 20:38:01 1996 -+++ zsrc/c/file.d Wed Jul 17 22:16:17 1996 -@@ -22,6 +22,11 @@ - - #include "config.h" - -+#ifdef THREADS -+# include -+#endif -+ -+ - #if defined(BSD) && !defined(MSDOS) - #include - #endif -@@ -347,6 +352,9 @@ - x->sm.sm_object0 = Sstring_char; - x->sm.sm_object1 = fn; - x->sm.sm_int0 = x->sm.sm_int1 = 0; -+#ifdef THREADS -+ fcntl(fileno(fp), F_SETFL, O_NONBLOCK); -+#endif - setbuf(fp, alloc_contblock(BUFSIZ)); - return(x); - } -@@ -509,6 +517,11 @@ - - #ifdef TK - bool no_input = FALSE; -+#ifdef THREADS -+# define PUTC(c, fp) lwpputc(c, fp) -+#else -+# define PUTC(c, fp) putc(c, fp) -+#endif - - StdinEnableEvents() - { -@@ -521,11 +534,24 @@ - } - # define GETC(c, fp) { if (fp == stdin) \ - while (no_input) Tk_DoOneEvent(0); \ -+#ifdef THREADS -+ c = lwpgetc(fp); \ -+#else - c = getc(fp); \ -+#endif /* THREADS */ - no_input = !FILE_CNT(fp); } - # define UNGETC(c, fp) { if (fp == stdin) no_input = FALSE; ungetc(c, fp); } - #else -+#ifdef THREADS -+# define PUTC(c, fp) lwpputc(c, fp) -+#else -+# define PUTC(c, fp) putc(c, fp) -+#endif -+#ifdef THREADS -+# define GETC(c, fp) c = lwpgetc(fp) -+#else - # define GETC(c, fp) c = getc(fp) -+#endif /* THREADS */ - # define UNGETC(c, fp) ungetc(c, fp) - #endif - -@@ -544,8 +570,11 @@ - if (fp == NULL) - closed_stream(strm); - GETC(c, fp); --/* c &= 0377; */ -- if (feof(fp)) -+/* c &= 0377; */ -+/* if (feof(fp)) */ -+ /*c &= 0x7f; -+ printf("<%d:%c>", c, c); fflush(stdout);*/ -+ if (c == EOF) - end_of_stream(strm); - /* strm->sm.sm_int0++; useless in smm_io, Beppe */ - return(c); -@@ -612,6 +641,7 @@ - if (fp == NULL) - closed_stream(strm); - UNGETC(c, fp); -+ /* c &= 0x7f; /* hmm? */ - /* --strm->sm.sm_int0; useless in smm_io, Beppe */ - break; - -@@ -678,7 +708,7 @@ - strm->sm.sm_int1++; - if (fp == NULL) - closed_stream(strm); -- putc(c, fp); -+ PUTC(c, fp); - break; - - case smm_synonym: -@@ -921,7 +951,8 @@ - if (fp == NULL) - closed_stream(strm); - GETC(c, fp); -- if (feof(fp)) -+/* if (feof(fp)) */ -+ if (c == EOF) - return(TRUE); - else { - UNGETC(c, fp); -diff --recursive --unified=3 src/c/gbc.c zsrc/c/gbc.c ---- src/c/gbc.c Wed Jul 3 02:15:49 1996 -+++ zsrc/c/gbc.c Mon Jul 22 18:04:37 1996 -@@ -530,7 +530,7 @@ - break; - #endif CLOS - default: -- if (debug) -+ if (1 || debug) - printf("\ttype = %d\n", type_of(x)); - error("mark botch"); - } -@@ -588,10 +588,14 @@ - - #ifdef THREADS - { -- pd *pdp; -+ pd *pdp, *queue; - lpd *old_clwp = clwp; - -- for (pdp = running_head; pdp != (pd *)NULL; pdp = pdp->pd_next) { -+ queue = running_queue; -+ do { -+ pdp = queue; -+ do { -+ /*for (pdp = running_head; pdp != (pd *)NULL; pdp = pdp->pd_next) <*/ - - clwp = pdp->pd_lpd; - #endif THREADS -@@ -620,7 +624,7 @@ - mark_object(clwp->lwp_gensym_prefix); - mark_object(clwp->lwp_gentemp_prefix); - mark_object(clwp->lwp_token); -- -+ - /* (current-thread) can return it at any time - */ - mark_object(clwp->lwp_thread); -@@ -654,7 +658,48 @@ - mark_stack_conservative(cs_org, where); - } - #ifdef THREADS -- } -+ pdp = pdp->pd_next; -+ } while(pdp != queue); -+ -+ -+ /* Now I have to wonder why I didn't use an array of queues... :] */ -+ -+ if (queue == running_queue) { -+ if (blocking_queue) queue = blocking_queue; -+ else if (delayed_queue) queue = delayed_queue; -+ else if (dead_queue) queue = dead_queue; -+ else if (stopped_queue) queue = stopped_queue; -+ else if (suspended_queue) queue = suspended_queue; -+ else if (waiting_queue) queue = waiting_queue; -+ else queue = NULL; -+ } else if (queue == blocking_queue) { -+ if (delayed_queue) queue = delayed_queue; -+ else if (dead_queue) queue = dead_queue; -+ else if (stopped_queue) queue = stopped_queue; -+ else if (suspended_queue) queue = suspended_queue; -+ else if (waiting_queue) queue = waiting_queue; -+ else queue = NULL; -+ } else if (queue == delayed_queue) { -+ if (dead_queue) queue = dead_queue; -+ else if (stopped_queue) queue = stopped_queue; -+ else if (suspended_queue) queue = suspended_queue; -+ else if (waiting_queue) queue = waiting_queue; -+ else queue = NULL; -+ } else if (queue == dead_queue) { -+ if (stopped_queue) queue = stopped_queue; -+ else if (suspended_queue) queue = suspended_queue; -+ else if (waiting_queue) queue = waiting_queue; -+ else queue = NULL; -+ } else if (queue == stopped_queue) { -+ if (suspended_queue) queue = suspended_queue; -+ else if (waiting_queue) queue = waiting_queue; -+ else queue = NULL; -+ } else if (queue == suspended_queue) { -+ if (waiting_queue) queue = waiting_queue; -+ else queue = NULL; -+ } else if (queue == waiting_queue) -+ queue = NULL; -+ } while(queue != NULL); - clwp = old_clwp; - } - #endif THREADS -@@ -853,9 +898,9 @@ - if (val == 0) { - /* informations used by the garbage collector need to be updated */ - # ifdef __linux -- running_head->pd_env[0].__jmpbuf[0].__sp = old_env[0].__jmpbuf[0].__sp; -+ running_queue->pd_env[0].__jmpbuf[0].__sp = old_env[0].__jmpbuf[0].__sp; - # else -- running_head->pd_env[JB_SP] = old_env[JB_SP]; -+ running_queue->pd_env[JB_SP] = old_env[JB_SP]; - # endif - old_clwp = clwp; - Values = main_lpd.lwp_Values; -Only in zsrc/c: gbc.my -diff --recursive --unified=3 src/c/load.d zsrc/c/load.d ---- src/c/load.d Tue Mar 12 20:40:01 1996 -+++ zsrc/c/load.d Wed Jul 17 17:55:13 1996 -@@ -31,7 +31,9 @@ - extern object Kwild; - extern object Vdefault_pathname_defaults; - extern object Vpackage; -+#ifndef THREADS - extern object Vstandard_output; -+#endif - extern object readc(); - - /******************************* ------- ******************************/ -diff --recursive --unified=3 src/c/lwp.d zsrc/c/lwp.d ---- src/c/lwp.d Thu Jun 27 17:43:28 1996 -+++ zsrc/c/lwp.d Mon Jul 22 18:14:34 1996 -@@ -3,6 +3,7 @@ - */ - /* - Copyright (c) 1990, Giuseppe Attardi. -+ Copyright (c) 1996, Brian Spilsbury. - - ECoLisp is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public -@@ -12,18 +13,43 @@ - See file '../Copyright' for full details. - */ - -+/* -+ Rewritten to use a multiple queue scheme to reduce time, and -+ facilitate simulated blocking io, and sleeping without -+ busy-looping. -+ Changed timing to be millisecond standard. -+ Made (sleep) equivelent to (%delay). -+ added lwpgetc(), lwpputc(), lwpread(), lwpwrite() to provide -+ for transparent blocking character and sequence io. lwpread, and -+ lwpwrite aren't used yet. -+ Made all streams non-blocking. -+ -+ Brian Spilsbury, 1996. -+*/ - - #include "config.h" - -+#include -+ - /******************************* EXPORTS ******************************/ - - lpd main_lpd; - lpd *clwp = &main_lpd; - int critical_level = 0; --pd *running_head; /* front of running pd's */ --pd *running_tail; /* back of running pd's */ -+ - pd main_pd; - -+pd *active = &main_pd; /* the pd that is attached to clwp */ -+ -+ /* circular queues, no tails */ -+pd *running_queue; /* running pd's */ -+pd *blocking_queue; /* blocking pd's */ -+pd *delayed_queue; /* delaying pd's */ -+pd *dead_queue; /* dead pd's */ -+pd *stopped_queue; /* stopped pd's */ -+pd *suspended_queue; /* suspended pd's */ -+pd *waiting_queue; /* waiting pd's */ -+ - /******************************* IMPORTS ******************************/ - - extern scheduler_interruption; /* in unixint.c */ -@@ -37,27 +63,41 @@ - #define thread_switch() { setTimer(0); enable_scheduler(); \ - scheduler(0, 0, NULL); } - --static bool timer_active = FALSE; --static bool scheduler_disabled = FALSE; -+static int timer_active = FALSE; -+static int scheduler_disabled = FALSE; - static int scheduler_level = 0; /* tito */ --static bool reset_timer = FALSE; -+static int reset_timer = FALSE; - static int running_processes = 1; -+static int awake_processes = 1; - static int absolute_time = 0; -+static int housekeeping_time = 0; -+static int fd_hightide = 3; /* highest fd ever to block + 1 */ -+static int wake_lowtide = -1; /* time to closest sleep-wake */ -+ -+/* hopefully this will work with DJGPP, but I really have no idea... */ -+/* Sets for blocking threads, see housekeeping */ -+static fd_set fd_rd, fd_wr, fd_ex; - - object Srunning; - object Ssuspended; - object Swaiting; - object Sstopped; - object Sdead; -+object Sblocking; -+object Sdelayed; - object siSthread_top_level; - -+void (*override_redirect_fun)() = NULL; -+pd *override_redirect_process = NULL; -+ - static object main_thread; - - static - setTimer(long time) - { -- struct itimerval oldtimer; -- struct itimerval itimer; -+ static struct itimerval oldtimer; -+ static struct itimerval itimer; -+ - itimer.it_value.tv_sec = 0; - itimer.it_value.tv_usec = time; - itimer.it_interval.tv_sec = 0; -@@ -66,32 +106,25 @@ - } - - pd * --dequeue() --{ -- pd *tmp; -- tmp = running_head; -- if (running_head != NULL) -- running_head = running_head->pd_next; -- return tmp; --} -- --pd * --make_pd() -+make_pd(pd *o) - { - pd *new_pd; lpd *npd; - - /* Allocate a new descriptor for the new lwp */ -- new_pd = (pd *)malloc(sizeof(pd)); -+ /* if we already have one, then we have passed it in o... */ -+ -+ if (o) new_pd = o; -+ else new_pd = (pd *)malloc(sizeof(pd)); - - /* create a new stack ... */ -- new_pd->pd_base = (int *)malloc(STACK_SIZE * sizeof(int)); -- new_pd->pd_status = SUSPENDED; -+ if (!o) new_pd->pd_base = (int *)malloc(STACK_SIZE * sizeof(int)); - - /* allocate a lisp descriptor: - * using the calloc here it's possible to avoid the - * critical section in the various push operations - */ -- npd = new_pd->pd_lpd = (lpd *)calloc(sizeof(lpd), 1); -+ if (o) { npd = new_pd->pd_lpd; } -+ else npd = new_pd->pd_lpd = (lpd *)calloc(1, sizeof(lpd)); - - /* initialize it */ - -@@ -117,11 +150,13 @@ - npd->lwp_frs_top = npd->lwp_frame_stack - 1; - npd->lwp_frs_limit = npd->lwp_frame_stack + FRSSIZE; - -+ /* constants are fine for a reincarnatee */ - npd->lwp_alloc_temporary = OBJNULL; - npd->lwp_backq_level = 0; - npd->lwp_eval1 = 0; - /* for gc */ -- npd->lwp_fmt_temporary_stream = OBJNULL; -+ /* we need to rebuild temporary_stream for some reason */ -+ if (!o) npd->lwp_fmt_temporary_stream = OBJNULL; - npd->lwp_fmt_temporary_string = OBJNULL; - - npd->lwp_PRINTstream = Cnil; -@@ -153,7 +188,7 @@ - npd->lwp_string_register = OBJNULL; - npd->lwp_gensym_prefix = OBJNULL; - npd->lwp_gentemp_prefix = OBJNULL; -- npd->lwp_token = OBJNULL; -+ if (!o) npd->lwp_token = OBJNULL; - - /* lex_env copy */ - npd->lwp_lex[0] = lex_env[0]; -@@ -168,70 +203,30 @@ - /* Now the allocation. If the gc is invoked we are able to mark - * the objects already allocated - */ -- npd->lwp_fmt_temporary_stream = make_string_output_stream(64); -- npd->lwp_fmt_temporary_string = -- npd->lwp_fmt_temporary_stream->sm.sm_object0; -- -- npd->lwp_string_register = alloc_simple_string(0); -- npd->lwp_gensym_prefix = make_simple_string("G"); -- npd->lwp_gentemp_prefix = make_simple_string("T"); -- npd->lwp_token = alloc_simple_string(LISP_PAGESIZE); -- npd->lwp_token->st.st_self = alloc_contblock(LISP_PAGESIZE); -+ -+ /* Hmm, this gets more complex with a reincarnatee */ -+ /* ideally we just want to initialize these destructively */ -+ /* and hope that this is good enough. */ -+ /* The main problem is that if other things have been passed these */ -+ /* and don't expect them to suddenly change, but I'm not sure that this */ -+ /* can be the case, since these should be local to a thread... */ -+ -+ if (!o) npd->lwp_fmt_temporary_stream = make_string_output_stream(64); -+ /* might need some resetting here? */ -+ npd->lwp_fmt_temporary_string = npd->lwp_fmt_temporary_stream->sm.sm_object0; -+ -+ if (!o) npd->lwp_string_register = alloc_simple_string(0); -+ if (!o) npd->lwp_gensym_prefix = make_simple_string("G"); -+ if (!o) npd->lwp_gentemp_prefix = make_simple_string("T"); -+ if (!o) npd->lwp_token = alloc_simple_string(LISP_PAGESIZE); -+ if (!o) npd->lwp_token->st.st_self = alloc_contblock(LISP_PAGESIZE); - npd->lwp_token->st.st_fillp = 0; - npd->lwp_token->st.st_hasfillp = TRUE; - npd->lwp_token->st.st_adjustable = TRUE; -- -- return new_pd; --} -- --update_queue() --{ -- register pd *dead_pd; -- pd *last = running_tail; -- -- do -- switch (running_head->pd_status) { -- -- case DEAD: -- -- /* remove the dead process */ -- dead_pd = dequeue(); -- /* free the lisp descriptor */ -- free(dead_pd->pd_lpd); -- /* free the memory allocated for the stack and the descriptor */ -- free(dead_pd->pd_base); -- free(dead_pd); -- break; -- --/* case SUSPENDED: */ -- case DELAYED: -- -- if (running_head->pd_slice != 0) -- if (absolute_time > running_head->pd_slice) { -- -- /* the time slice has expired */ -- running_head->pd_slice = 0; - -- if ((running_head->pd_thread->th.th_cont) != OBJNULL) { -- /* in this case a continuation was created before %delay */ -- running_head->pd_thread->th.th_cont->cn.cn_timed_out = TRUE; -- running_head->pd_thread->th.th_cont = OBJNULL; -- } -- running_head->pd_status = RUNNING; -- return; /* now you are a running process */ -- } -- ROTQUEUE(); -- break; -- -- case WAITING: /* waiting processes need to be scheduled */ -- case RUNNING: -- return; /* found schedulable process */ -- -- default: /* currently is only STOPPED */ -- ROTQUEUE(); -- break; -- } -- while (running_head != last); -+ new_pd->pd_status = SUSPENDED; -+ ENQUEUE(new_pd, suspended_queue); /* needs to be on a queue */ -+ return new_pd; - } - - activate_thread(object thread) -@@ -275,33 +270,111 @@ - sigsetmask(sigblock(0) & ~(sigmask(SIGALRM))); - #endif - -+/* to get here we've been scheduled */ -+/* so we aren't in someone else's bind stack */ -+/* so we should get the defaults for the stdio */ -+ -+start_critical_section(); -+ -+for(;;) { /* mortal coil */ -+ /* set up local stdio bindings below everything else on the bind stack */ -+ /* so that they shouldn't be take out of scope ever... */ -+ -+ bind_var(Vstandard_input, SYM_VAL(Vstandard_input), Cnil); -+ bind_var(Vstandard_output, SYM_VAL(Vstandard_output), Cnil); -+ bind_var(Verror_output, SYM_VAL(Verror_output), Cnil); -+ bind_var(Vquery_io, SYM_VAL(Vquery_io), Cnil); -+ bind_var(Vdebug_io, SYM_VAL(Vdebug_io), Cnil); -+ bind_var(Vterminal_io, SYM_VAL(Vterminal_io), Cnil); -+ bind_var(Vtrace_output, SYM_VAL(Vtrace_output), Cnil); -+ - { int i; -- for (i = clwp->lwp_nValues; i > 0;) -+ for (i = clwp->lwp_nValues; i > 0;) - VALUES(i) = VALUES(--i); - VALUES(0) = clwp->lwp_thread->th.th_fun; -+ end_critical_section(); - apply(clwp->lwp_nValues+1, siSthread_top_level, &VALUES(0)); -+ start_critical_section(); - } - /* Termination */ -- -- terpri(Cnil); -- running_head->pd_status = DEAD; -- running_head->pd_thread->th.th_self = NULL; -+ -+ { -+ pd *tmp = active; -+ -+ tmp->pd_status = DEAD; - running_processes--; -+ awake_processes--; -+ DEQUEUE(tmp, running_queue); -+ ENQUEUE(tmp, dead_queue); -+ } - -- update_queue(); -- thread_next(); /* update_queue has freed our stack!!! */ -+ end_critical_section(); -+ thread_switch(); /* stack won't have been free'd yet... that's a */ -+ /* job for housekeeping to think about. */ -+ /* otherwise dead threads live in limbo waiting */ -+ /* for reincarnation */ -+ /* incase we are raised from the dead, we want to do it again */ -+ start_critical_section(); -+ } - } - - /* -- * switch to the first thread on queue -+ * switch to the next thread on queue - */ - thread_next() - { -+ /* rotate the running-queue */ -+ -+ /* should devolve into an if, but *shrug* better to guarantee */ -+ start_critical_section(); -+ -+ if (override_redirect_process == active) { -+ void (*fun)(); -+ -+ force_resumption(active); -+ -+ if (running_processes > 1) { -+ timer_active = TRUE; -+ setTimer(REALQUANTUM); -+ } else { -+ timer_active = FALSE; -+ absolute_time = 0; -+ } -+ fun = override_redirect_fun; -+ -+ override_redirect_fun = NULL; -+ override_redirect_process = NULL; -+ -+ end_critical_section(); -+ (*fun)(); -+ start_critical_section(); -+ } -+ - /* unwind the bind stack */ - lwp_bds_unwind(clwp->lwp_bind_stack, clwp->lwp_bds_top); - -+ ROTQUEUE(running_queue); -+ -+ end_critical_section(); -+ /* housekeeping isn't actually critical */ -+ /* and turns off the timer while its in there */ -+ if (absolute_time > housekeeping_time) -+ housekeeping(); -+ -+ /* we need this incase a signal blew us out of the previous housekeeping */ -+ /* and running_queue is void */ -+ -+ while(running_queue == NULL) { -+ static struct timeb tb; -+ ftime(&tb); /* not sure how portable */ -+ absolute_time = tb.millitm + tb.time*1000; -+ housekeeping(); -+ } -+ start_critical_section(); -+ - /* switch clwp */ -- clwp = running_head->pd_lpd; -+ clwp = running_queue->pd_lpd; -+ active = running_queue; - - /* restore Values pointer */ - Values = clwp->lwp_Values; -@@ -313,19 +386,253 @@ - if (running_processes > 1) { - timer_active = TRUE; - setTimer(REALQUANTUM); -- } else { -+ } else { - timer_active = FALSE; - absolute_time = 0; - } -- siglongjmp(running_head->pd_env, 1); -+ -+ end_critical_section(); -+ siglongjmp(active->pd_env, 1); - } - - /* - * Called when time slice expires or explicitily to switch thread -+ * New version... - */ - scheduler(int sig, int code, struct sigcontext *scp) - { - int val; -+ static struct timeb tb; -+ -+#if defined(SYSV) || defined(__svr4__) || defined(__linux) -+ signal(SIGALRM, scheduler); -+#endif SYSV -+ -+ ftime(&tb); /* not sure how portable */ -+ absolute_time = tb.millitm + tb.time*1000; -+ -+ if (critical_level > 0) { /* within critical section */ -+ scheduler_interrupted = TRUE; -+ scheduler_interruption = SCHEDULER_INT; -+ return; -+ } -+ if (scheduler_level > 0) { /* abilitation check */ -+ scheduler_interrupted = TRUE; -+ return; -+ } -+ -+ val = sigsetjmp(active->pd_env, 1); -+ -+ if (val == 1) /* resume interrupted thread execution */ -+ return; /* coming back from longjmp in thread_next */ -+ -+ if (val == 2) /* coming back from longjmp in GC */ -+ gc(garbage_parameter); /* GC will return to the previous thread */ -+ -+ thread_next(); -+} -+ -+/* TODO: Add in waiting thread condition resolution */ -+housekeeping() -+{ -+ static struct timeval timeout; -+ static pd *p, *q; -+ static int tide; -+ static fd_set rd, wr, ex; -+ /* see if we are polling or lurking */ -+ -+ /* turn off that bloody timer... */ -+ setTimer(0); -+ -+ if ((running_processes > 1) && (awake_processes > 0)) { -+ /* poll */ -+ /* set timeout to instant */ -+ timeout.tv_sec = timeout.tv_usec = 0; -+ tide = 1; -+ } else { -+ /* is recovery possible? */ -+ -+ if ( (running_queue == NULL) && -+ (blocking_queue == NULL) && -+ (delayed_queue == NULL)) { -+ /* in a coma... can't awaken itself... */ -+ /* there is a possibility that a signal */ -+ /* will, but um, for now assume dead and buried */ -+ exit(0); /* bail w/out error */ -+ } -+ -+ /* ok, in theory we can wake up.... so lurk */ -+ /* set timeout to the shortest sleep resumption time */ -+ /* if there isn't a sleep resumption time */ -+ /* block forever... */ -+ -+ if (wake_lowtide != -1) { -+ if (absolute_time >= wake_lowtide) { -+ timeout.tv_sec = timeout.tv_usec = 0; -+ tide = 1; -+ } else { -+ timeout.tv_sec = (wake_lowtide-absolute_time)/1000; -+ timeout.tv_usec = ((wake_lowtide-absolute_time)%1000)*1000; -+ tide = 1; -+ } -+ } else tide = 0; -+ } -+ -+ memcpy(&rd, &fd_rd, sizeof(fd_set)); -+ memcpy(&wr, &fd_wr, sizeof(fd_set)); -+ memcpy(&ex, &fd_ex, sizeof(fd_set)); -+ -+ /* If there is an error, the sets are undefined, just bail out... */ -+ /* we'll catch it next time, it was probably a signal interrupting */ -+ /* us. */ -+ if (select(fd_hightide, &rd, &wr, &ex, (tide ? &timeout : NULL)) == -1) { -+ /* we broke for some reason */ -+ /* a signal handler may have been invoked... */ -+ /* someone may have been woken up */ -+ /* so schedule another housekeeping apointment */ -+ /* and bail */ -+ goto out; -+ } -+ -+ /* check for awakened threads */ -+ -+ if (p = blocking_queue) -+ do { -+ q = p->pd_next; -+ switch(p->pd_fp_mode) { -+ case PD_INPUT: -+ if (FD_ISSET(fileno(p->pd_fp), &rd)) { -+ FD_CLR(fileno(p->pd_fp), &fd_rd); -+ DEQUEUE(p, blocking_queue); -+ ENQUEUE(p, running_queue); -+ p->pd_status = RUNNING; -+ awake_processes++; -+ if (blocking_queue == NULL) goto endblk; -+ } -+ break; -+ case PD_OUTPUT: -+ if (FD_ISSET(fileno(p->pd_fp), &wr)) { -+ FD_CLR(fileno(p->pd_fp), &fd_wr); -+ DEQUEUE(p, blocking_queue); -+ ENQUEUE(p, running_queue); -+ p->pd_status = RUNNING; -+ awake_processes++; -+ if (blocking_queue == NULL) goto endblk; -+ } -+ break; -+ case PD_EXCEPTION: -+ if (FD_ISSET(fileno(p->pd_fp), &ex)) { -+ FD_CLR(fileno(p->pd_fp), &fd_ex); -+ DEQUEUE(p, blocking_queue); -+ ENQUEUE(p, running_queue); -+ p->pd_status = RUNNING; -+ awake_processes++; -+ if (blocking_queue == NULL) goto endblk; -+ } -+ break; -+ } -+ p = q; -+ } while(p != blocking_queue); -+ -+ /* if sleeping, check for wakeup.... */ -+ -+endblk: tide = -1; -+ -+ /*putchar('.'); fflush(stdout);*/ -+ -+ if ((wake_lowtide != -1) && ((p = delayed_queue) != NULL)) -+ do { -+ q = p->pd_next; -+ if (absolute_time >= p->pd_slice) { -+ DEQUEUE(p, delayed_queue); -+ ENQUEUE(p, running_queue); -+ p->pd_status = RUNNING; -+ awake_processes++; -+ if (delayed_queue == NULL) break; -+ } else { -+ /* get new low-tide */ -+ if ((tide == -1) || (p->pd_slice < tide)) -+ tide = p->pd_slice; -+ } -+ -+ p = q; -+ } while(p != delayed_queue); -+ -+ wake_lowtide = tide; -+ -+ /* requeue waiting threads for resolution checking */ -+ /* not a good solution, but the only one that I can see */ -+ /* at least now we will only check them on housekeeping intervals */ -+ /* just get the timeout cases to set the wake_lowtide on entry */ -+ /* to prevent oversleeping. */ -+ -+ while(p = waiting_queue) { -+ DEQUEUE(p, waiting_queue); -+ ENQUEUE(p, running_queue); -+ p->pd_status = RUNNING; -+ awake_processes++; -+ } -+ -+out: housekeeping_time = absolute_time + 1000; /* one second */ -+} -+ -+/* this will mostly be used in conjunction with override_redirect */ -+/* which should be set before entry here. */ -+ -+force_resumption(pd *p) -+{ -+ start_critical_section(); -+ -+ switch(p->pd_status) { -+ case RUNNING: DEQUEUE(p, running_queue); -+ break; -+ case STOPPED: DEQUEUE(p, stopped_queue); -+ running_processes++; -+ awake_processes++; -+ break; -+ case SUSPENDED: DEQUEUE(p, stopped_queue); -+ running_processes++; -+ awake_processes++; -+ break; -+ case DEAD: /* hmmm... raising the dead might be dangerous */ -+ running_processes++; -+ awake_processes++; -+ DEQUEUE(p, dead_queue); -+ break; -+ case WAITING: DEQUEUE(p, waiting_queue); -+ awake_processes++; -+ break; -+ case DELAYED: DEQUEUE(p, delayed_queue); -+ awake_processes++; -+ break; -+ /* don't worry about the magic, at worst this can */ -+ running_processes++; -+ /* cause housekeeping to make a false check */ -+ case BLOCKED: DEQUEUE(p, blocking_queue); -+ /* this needs some fixing */ -+ switch(p->pd_fp_mode) { -+ case PD_INPUT: -+ FD_CLR(fileno(p->pd_fp), &fd_rd); -+ break; -+ case PD_OUTPUT: -+ FD_CLR(fileno(p->pd_fp), &fd_wr); -+ break; -+ case PD_EXCEPTION: -+ FD_CLR(fileno(p->pd_fp), &fd_ex); -+ break; -+ } -+ awake_processes++; -+ break; -+ } -+ -+ ENQUEUE(p, running_queue); -+ end_critical_section(); -+} -+ -+#ifdef 0 -+scheduler(int sig, int code, struct sigcontext *scp) -+{ -+ int val; - - #if defined(SYSV) || defined(__svr4__) || defined(__linux) - signal(SIGALRM, scheduler); -@@ -342,7 +649,7 @@ - return; - } - -- val = sigsetjmp(running_head->pd_env, 1); -+ val = sigsetjmp(running_dead->pd_env, 1); - - if (val == 1) /* resume interrupted thread execution */ - return; /* coming back from longjmp in thread_next */ -@@ -353,6 +660,7 @@ - ROTQUEUE(); - thread_next(); - } -+#endif /* old version */ - - /* - * Handle signal received within critical section -@@ -400,18 +708,34 @@ - register pd *p; - - start_critical_section(); -- running_processes++; -+ -+ if (rpd->pd_status == STOPPED) { -+ DEQUEUE(rpd, stopped_queue); -+ running_processes++; -+ awake_processes++; -+ } else if (rpd->pd_status == DELAYED) { -+ DEQUEUE(rpd, delayed_queue); -+ /* TODO: look for interaction with housekeeping problem for this case... */ -+ awake_processes++; -+ } else if (rpd->pd_status == SUSPENDED) { -+ DEQUEUE(rpd, suspended_queue); -+ running_processes++; -+ awake_processes++; -+ } -+ -+ /* else, should we be here? no. hmmm. */ -+ /* where are the fucking arguments? */ - - rpd->pd_status = RUNNING; -- for (p = running_head; (p != rpd) && (p != NULL); p = p->pd_next) ; -- if (p == NULL) -- ENQUEUE(rpd); -+ -+ ENQUEUE(rpd, running_queue); -+ - end_critical_section(); - - if (!timer_active) { - timer_active = TRUE; - setTimer(REALQUANTUM); -- } -+ } - } - - /*********** -@@ -428,6 +752,11 @@ - RETURN(1); - } - -+/* Hmmmmm, what the hell is this supposed to do? */ -+/* and why bother? */ -+/* Put this in the TODO basket, as something of dubiousness */ -+ -+#ifdef 0 - siLthread_break_quit(int narg) - { - /* reset everything in MT */ -@@ -443,17 +772,21 @@ - critical_level = 0; - scheduler_interrupted = 0; - -- for (p = running_head; (p != NULL); p = p->pd_next) -- if (p != &main_pd) -+ /*for (p = running_dead; (p != NULL); p = p->pd_next)*/ -+ p = running_queue; -+ do { -+ if (p != &main_pd) { - p->pd_status = DEAD; -- else { -+ } else { - p->pd_status = RUNNING; - p->pd_thread->th.th_cont = OBJNULL; -- } -+ } -+ p = p->pd_next; -+ } while(running_queue->pd_next != running_queue); - -- if (running_head != &main_pd) { -+ if (running_queue != &main_pd) { - update_queue(); -- thread_next(); -+ thread_dext(); - /* here one should deallocate the main-thread function */ - } - else -@@ -462,6 +795,7 @@ - VALUES(0) = Cnil; - RETURN(1); - } -+#endif - - siLthread_break_resume(int narg) - { -@@ -478,16 +812,70 @@ - Lthread_list(int narg) - { - pd *p; -- object tmp, x = CONS(running_head->pd_thread, Cnil); -+ object tmp; -+ object tmp2 = CONS(running_queue->pd_thread, Srunning); -+ object x = CONS(tmp2, Cnil); - - tmp = x; - - start_critical_section(); - -- for (p = running_head->pd_next; (p != NULL); p = p->pd_next) { -- CDR(tmp) = CONS(p->pd_thread, Cnil); -- tmp = CDR(tmp); -- } -+ p = running_queue->pd_next; -+ while(p != running_queue) { -+ tmp2 = CONS(p->pd_thread, Srunning); -+ CDR(tmp) = CONS(tmp2, Cnil); -+ tmp = CDR(tmp); -+ p = p->pd_next; -+ } -+ -+ if (p = blocking_queue) -+ do { -+ tmp2 = CONS(p->pd_thread, Sblocking); -+ CDR(tmp) = CONS(tmp2, Cnil); -+ p = p->pd_next; -+ tmp = CDR(tmp); -+ } while(p != blocking_queue); -+ -+ if (p = delayed_queue) -+ do { -+ tmp2 = CONS(p->pd_thread, Sdelayed); -+ CDR(tmp) = CONS(tmp2, Cnil); -+ p = p->pd_next; -+ tmp = CDR(tmp); -+ } while(p != delayed_queue); -+ -+ /* TODO: Should this queue be listed? */ -+ if (p = dead_queue) -+ do { -+ tmp2 = CONS(p->pd_thread, Sdead); -+ CDR(tmp) = CONS(tmp2, Cnil); -+ p = p->pd_next; -+ tmp = CDR(tmp); -+ } while(p != dead_queue); -+ -+ if (p = stopped_queue) -+ do { -+ tmp2 = CONS(p->pd_thread, Sstopped); -+ CDR(tmp) = CONS(tmp2, Cnil); -+ p = p->pd_next; -+ tmp = CDR(tmp); -+ } while(p != stopped_queue); -+ -+ if (p = suspended_queue) -+ do { -+ tmp2 = CONS(p->pd_thread, Ssuspended); -+ CDR(tmp) = CONS(tmp2, Cnil); -+ p = p->pd_next; -+ tmp = CDR(tmp); -+ } while(p != suspended_queue); -+ -+ if (p = waiting_queue) -+ do { -+ tmp2 = CONS(p->pd_thread, Swaiting); -+ CDR(tmp) = CONS(tmp2, Cnil); -+ p = p->pd_next; -+ tmp = CDR(tmp); -+ } while(p != waiting_queue); - - end_critical_section(); - -@@ -511,20 +899,41 @@ - /* fun = SYM_FUN(fun); confusing */ - } - -- x = alloc_object(t_thread); -- x->th.th_fun = fun; -- x->th.th_size = sizeof(pd); -- x->th.th_self = npd = make_pd(); -- x->th.th_cont = OBJNULL; -+start_critical_section(); -+ /* see if there is a lost soul waiting for reincarnation */ -+ if (dead_queue) { -+ /* ok, lets juice it up */ -+ -+ npd = dead_queue; -+ DEQUEUE(npd, dead_queue); -+ -+ x = npd->pd_lpd->lwp_thread; -+ /* enqueued in make_pd */ -+ -+ x->th.th_fun = fun; -+ x->th.th_size = sizeof(pd); -+ x->th.th_self = make_pd(npd); /* reinitialize it */ -+ x->th.th_cont = OBJNULL; -+ } else { -+ /* ok, no lost souls, better build a new one */ -+ x = alloc_object(t_thread); -+ x->th.th_fun = fun; -+ x->th.th_size = sizeof(pd); -+ x->th.th_self = npd = make_pd(0); -+ x->th.th_cont = OBJNULL; - -- npd->pd_thread = x; -- npd->pd_slice = 0; -+ npd->pd_thread = x; -+ npd->pd_slice = 0; - -- /* Backpointer to thread */ -- npd->pd_lpd->lwp_thread = x; -+ /* Backpointer to thread */ -+ npd->pd_lpd->lwp_thread = x; - - activate_thread(x); -+ } -+ -+ /* note: this is created as a suspended thread, and in that queue */ - -+end_critical_section(); - VALUES(0) = x; - RETURN(1); - } -@@ -542,12 +951,17 @@ - start_critical_section(); /* tito */ - thread->th.th_self->pd_status = STOPPED; - running_processes--; -- if (thread->th.th_self == running_head) { -- critical_level--; /* end_critical_section() */ -- update_queue(); -- thread_next(); -- } else -- end_critical_section(); -+ awake_processes--; -+ if (thread->th.th_self == active) { -+ DEQUEUE(thread->th.th_self, running_queue); -+ ENQUEUE(thread->th.th_self, stopped_queue); -+ critical_level--; /* end_critical_section() */ -+ thread_switch(); -+ } else { -+ DEQUEUE(thread->th.th_self, running_queue); -+ ENQUEUE(thread->th.th_self, stopped_queue); -+ end_critical_section(); -+ } - VALUES(0) = Cnil; - RETURN(1); - } -@@ -568,6 +982,7 @@ - start_critical_section(); /* tito */ - thread->th.th_self->pd_status = RUNNING; - running_processes++; -+ awake_processes++; - - if (!timer_active) { - timer_active = TRUE; -@@ -582,11 +997,8 @@ - - Lkill_thread(int narg, object thread) - { -+ pd *tmp; - -- /* The following code is not enough. -- Consider: The scheduler can be disabled -- What about killing the current thread? -- */ - check_arg(1); - - if (type_of(thread) != t_thread) -@@ -597,13 +1009,17 @@ - thread->th.th_self->pd_status = DEAD; - if (thread->th.th_self->pd_lpd == clwp) { - /* if a thread kills itself the scheduler is to be called */ -- thread->th.th_self = NULL; -+ tmp = thread->th.th_self; -+ DEQUEUE(tmp, running_queue); -+ ENQUEUE(tmp, dead_queue); - critical_level--; /* end_critical_section() */ -- update_queue(); -- thread_next(); -+ thread_switch(); - } - else { -- thread->th.th_self = NULL; -+ /*thread->th.th_self = NULL;*/ -+ tmp = thread->th.th_self; -+ DEQUEUE(tmp, running_queue); -+ ENQUEUE(tmp, dead_queue); - end_critical_section(); - } - } -@@ -642,6 +1058,11 @@ - case DEAD: - VALUES(0) = Sdead; - break; -+ case BLOCKED: -+ VALUES(0) = Sblocking; -+ break; -+ case DELAYED: -+ VALUES(0) = Sdelayed; - default: - FEerror("Unexpected type for thread ~A", 1, thread); - } -@@ -663,6 +1084,7 @@ - object x; - check_arg(1); - -+ - if (type_of(thread) != t_thread) - FEwrong_type_argument(Sthread, thread); - -@@ -797,91 +1219,206 @@ - check_arg(0); - - if (timer_active) { -- running_head->pd_status = SUSPENDED; -+ pd *tmp = active; -+ tmp->pd_status = SUSPENDED; -+ DEQUEUE(tmp, running_queue); -+ ENQUEUE(tmp, suspended_queue); - running_processes--; -+ awake_processes--; - thread_switch(); - /* When resumed it will be provided with the Values to return */ -- RETURN(running_head->pd_lpd->lwp_nValues); -+ RETURN(tmp->pd_lpd->lwp_nValues); - } - else - FEerror("No other active thread.", 0); - } - -+void lwpblockon(pd *who, FILE *fp, int mode) -+{ -+ who->pd_fp = fp; -+ who->pd_fp_mode = mode; /* in, out, execept */ -+ who->pd_status = BLOCKED; -+ -+ start_critical_section(); -+ -+ DEQUEUE(who, running_queue); -+ ENQUEUE(who, blocking_queue); -+ awake_processes--; -+ -+ if (fd_hightide <= fileno(fp)) -+ fd_hightide = fileno(fp)+1; -+ -+ switch(mode) { -+ case PD_INPUT: -+ FD_SET(fileno(fp), &fd_rd); -+ break; -+ case PD_OUTPUT: -+ FD_SET(fileno(fp), &fd_wr); -+ break; -+ case PD_EXCEPTION: -+ FD_SET(fileno(fp), &fd_ex); -+ break; -+ } -+ -+ end_critical_section(); -+ -+ thread_switch(); -+} -+ -+int inline lwpgetc(FILE *fp) -+{ -+ int c; -+ -+loop: errno = 0; -+ c = getc(fp); -+ if (errno) { -+ lwpblockon(active, fp, PD_INPUT); -+ clearerr(fp); -+ goto loop; -+ } -+ return(c); -+} -+ -+void inline lwpputc(char c, FILE *fp) -+{ -+loop: errno = 0; -+ putc(c, fp); -+ if (errno) { -+ lwpblockon(active, fp, PD_OUTPUT); -+ clearerr(fp); -+ goto loop; -+ } -+ return; -+} -+ -+int inline lwpread(char *buf, int len, FILE *fp) -+{ -+ int ind = 0, left = len, n; -+ -+loop: errno = 0; -+ n = read(&buf[ind], left, fileno(fp)); -+ if (errno) { -+ ind += n; -+ left -= n; -+ lwpblockon(active, fp, PD_INPUT); -+ clearerr(fp); -+ goto loop; -+ } -+ return(ind+n); -+} -+ -+int inline lwpwrite(char *buf, int len, FILE *fp) -+{ -+ int ind = 0, left = len, n; -+ -+loop: errno = 0; -+ n = write(&buf[ind], left, fileno(fp)); -+ if (errno) { -+ ind += n; -+ left -= n; -+ lwpblockon(active, fp, PD_OUTPUT); -+ clearerr(fp); -+ goto loop; -+ } -+ return(ind+n); -+} -+ - Ldelay(int narg, object interval) - { int z; - - check_arg(1); - check_type_non_negative_integer(&interval); - z = fix(interval); -+ -+ if (timer_active) { -+ pd *tmp = active; /* remember who we are */ -+ lwpsleep(z*1000); /* lwpsleep is in milliseconds */ -+ /* When resumed it will be provided with the Values to return */ -+ RETURN(tmp->pd_lpd->lwp_nValues); -+ } -+ else -+ { -+ sleep(z); -+ } -+} -+ -+/* Sleep for at least ms milliseconds */ -+lwpsleep(int ms) -+{ - - if (timer_active) { -- running_head->pd_status = DELAYED; -- running_processes--; -+ pd *tmp = active; -+ -+ start_critical_section(); -+ tmp->pd_status = DELAYED; -+ DEQUEUE(tmp, running_queue); -+ ENQUEUE(tmp, delayed_queue); -+ awake_processes--; - -- /* Translate seconds in number of scheduler slices */ -- running_head->pd_slice = z * 10 + absolute_time; -+ tmp->pd_slice = ms + absolute_time; -+ -+ if ((wake_lowtide == -1) || (wake_lowtide > tmp->pd_slice)) -+ wake_lowtide = tmp->pd_slice; -+ -+ end_critical_section(); - - thread_switch(); -- -- /* When resumed it will be provided with the Values to return */ -- RETURN(running_head->pd_lpd->lwp_nValues); - } -- else -- sleep(z); -+ else usleep(ms*1000); /* milli->micro */ - } - -+/* TODO: Find a way to move this functionality into housekeeping() -+ sigh */ -+ - Lthread_wait(int narg, object fun, ...) - { int nr; -+ pd *tmp = active; - va_list args; - va_start(args, fun); -- -+ - if (narg < 1) FEtoo_few_arguments(&narg); - -- start_critical_section(); -- running_head->pd_status = WAITING; -- running_processes--; -- end_critical_section(); -- - for (;;) { - - nr = apply(narg-1, fun, args); - - if (VALUES(0) != Cnil) - break; -- else if (timer_active) { -- /* the time slice has not been used */ -- absolute_time--; -- thread_switch(); -- } else -- FEerror("The condition will never be satisfied for lack of active processes", 0); -+ -+ start_critical_section(); -+ tmp->pd_status = WAITING; -+ -+ DEQUEUE(tmp, running_queue); -+ ENQUEUE(tmp, waiting_queue); -+ -+ awake_processes--; -+ -+ end_critical_section(); -+ thread_switch(); - } -- running_head->pd_status = RUNNING; -- running_processes++; -- end_critical_section(); -+ - RETURN(nr); - } - -- -+/* TODO: whack this into housekeeping() */ -+ - Lthread_wait_with_timeout(int narg, object timeout, object fun, ...) - { - int nr; -+ pd *tmp = active; - va_list args; - va_start(args, fun); - - if (narg < 2) FEtoo_few_arguments(&narg); - check_type_non_negative_integer(&timeout); - -- /* We have to translate seconds in scheduler call number */ -- start_critical_section(); -- running_head->pd_slice = fix(timeout) * 10 + absolute_time; -+ /* We have to translate seconds into milliseconds into the future */ -+ tmp->pd_slice = fix(timeout) * 1000 + absolute_time; - -- running_head->pd_status = WAITING; -- running_processes--; -- end_critical_section(); - - for (;;) { - -- if (absolute_time > running_head->pd_slice) { -+ if (absolute_time > tmp->pd_slice) { - /* the time slice has expired */ - VALUES(0) = Cnil; - nr = 1; -@@ -897,13 +1434,19 @@ - absolute_time--; - thread_switch(); - } -- } -+ -+ tmp->pd_status = WAITING; -+ DEQUEUE(tmp, running_queue); -+ ENQUEUE(tmp, waiting_queue); -+ awake_processes--; -+ -+ if ((wake_lowtide == -1) || (wake_lowtide > tmp->pd_slice)) -+ wake_lowtide = tmp->pd_slice; -+ -+ thread_switch(); -+ } - -- start_critical_section(); -- running_head->pd_slice = 0; -- running_head->pd_status = RUNNING; -- running_processes++; -- end_critical_section(); -+ tmp->pd_slice = 0; - RETURN(nr); - } - -@@ -912,11 +1455,25 @@ - signal(SIGALRM, scheduler); - } - -+/* called when we start after a dump */ -+linit_lwp() -+{ -+ FD_ZERO(&fd_rd); -+ FD_ZERO(&fd_wr); -+ FD_ZERO(&fd_ex); -+} -+ - init_lwp() - { pd *temp_pd; - - temp_pd = &main_pd; -- PUSH(temp_pd); -+ /*PUSH(temp_pd);*/ -+ -+ FD_ZERO(&fd_rd); -+ FD_ZERO(&fd_wr); -+ FD_ZERO(&fd_ex); -+ -+ ENQUEUE(temp_pd, running_queue); - - main_thread = alloc_object(t_thread); - main_pd.pd_thread = main_thread; -@@ -935,10 +1492,12 @@ - Swaiting = make_ordinary("WAITING"); - Sstopped = make_ordinary("STOPPED"); - Sdead = make_ordinary("DEAD"); -+ Sblocking = make_ordinary("BLOCKING"); -+ Sdelayed = make_ordinary("DELAYED"); - siSthread_top_level = make_si_ordinary("THREAD-TOP-LEVEL"); - - make_si_function("THREAD-BREAK-IN", siLthread_break_in); -- make_si_function("THREAD-BREAK-QUIT", siLthread_break_quit); -+/* make_si_function("THREAD-BREAK-QUIT", siLthread_break_quit); */ - make_si_function("THREAD-BREAK-RESUME", siLthread_break_resume); - - make_function("MAKE-THREAD", Lmake_thread); -Only in zsrc/c: lwp.my -Only in zsrc/c: lwp.orig -diff --recursive --unified=3 src/c/main.c zsrc/c/main.c ---- src/c/main.c Mon Apr 15 20:54:12 1996 -+++ zsrc/c/main.c Mon Jul 22 18:14:02 1996 -@@ -170,6 +170,11 @@ - setbuf(stdin, stdin_buf); - setbuf(stdout, stdout_buf); - -+#ifdef THREADS -+ fcntl(fileno(stdin), F_SETFL, O_NONBLOCK); -+ fcntl(fileno(stdout), F_SETFL, O_NONBLOCK); -+#endif -+ - ARGC = argc; - ARGV = argv; - ecl_self = argv[0]; -@@ -185,6 +190,7 @@ - gc_time = 0; - - #ifdef THREADS -+ clwp = &main_lpd; - Values = main_lpd.lwp_Values; - #endif - frs_top = frs_org-1; -@@ -226,6 +232,7 @@ - enable_interrupt(); - siLcatch_bad_signals(0); - #ifdef THREADS -+ linit_lwp(); - enable_lwp(); - #endif THREADS - SYM_VAL(siVlisp_maxpages) = MAKE_FIXNUM(real_maxpage); -Only in zsrc/c: main.my -diff --recursive --unified=3 src/c/print.d zsrc/c/print.d ---- src/c/print.d Fri Jul 5 02:41:09 1996 -+++ zsrc/c/print.d Wed Jul 17 16:38:16 1996 -@@ -2258,7 +2258,10 @@ - write_ch_fun = interactive_writec_stream; - else - #endif CLOS -+ { -+ printf("type_of(strm) == %d, t_stream == %d\n", type_of(strm), t_stream); fflush(stdout); - FEerror("~S is not a stream.", 1, strm); -+ } - write_ch('\n', strm); - FLUSH_STREAM(strm); - return(Cnil); -diff --recursive --unified=3 src/c/read.d zsrc/c/read.d ---- src/c/read.d Thu Jun 6 03:50:15 1996 -+++ zsrc/c/read.d Wed Jul 17 02:20:29 1996 -@@ -253,12 +253,30 @@ - - #if TK - extern bool no_input; -+#ifdef THREADS -+# define PUTC(c, fp) lwpputc(c, fp) -+#else -+# define PUTC(c, fp) putc(c, fp) -+#endif - #define GETC(c, fp) { if (fp == stdin) \ - while (no_input) Tk_DoOneEvent(0); \ -+#ifdef THREADS -+ c = lwpgetc(fp); \ -+#else - c = getc(fp); \ -+#endif /* THREADS */ - no_input = !FILE_CNT(fp); } - #else -+#ifdef THREADS -+# define PUTC(c, fp) lwpputc(c, fp) -+#else -+# define PUTC(c, fp) putc(c, fp) -+#endif -+#ifdef THREADS -+#define GETC(c, fp) c = lwpgetc(fp) -+#else - #define GETC(c, fp) c = getc(fp) -+#endif /* THREADS */ - #endif /* TK */ - - /* Beppe: faster code for inner loop from file stream */ -diff --recursive --unified=3 src/c/tcp.c zsrc/c/tcp.c ---- src/c/tcp.c Wed May 31 18:36:36 1995 -+++ zsrc/c/tcp.c Wed Jul 17 21:22:12 1996 -@@ -12,6 +12,7 @@ - */ - - #include "config.h" -+#include - - object - make_stream(object host, int fd, enum smmode smm) -@@ -35,6 +36,9 @@ - stream = alloc_object(t_stream); - stream->sm.sm_mode = (short)smm; - stream->sm.sm_fp = fp; -+#ifdef THREADS -+ fcntl(fd, F_SETFL, O_NONBLOCK); -+#endif - fp->_IO_buf_base = NULL; /* BASEFF */; - stream->sm.sm_object0 = Sstring_char; - stream->sm.sm_object1 = host; /* not really used */ -@@ -67,11 +71,11 @@ - FEerror("~S is a too long file name.", 1, host); - - #ifdef THREADS -- start_critical_section(); -+/* start_critical_section(); */ - #endif THREADS - fd = connect_to_server(host->st.st_self, fix(port)); - #ifdef THREADS -- end_critical_section(); -+/* end_critical_section(); */ - #endif THREADS - - if (fd == 0) { -@@ -94,13 +98,7 @@ - if (!FIXNUMP(port)) - FEwrong_type_argument(TSpositive_number, port); - --#ifdef THREADS -- start_critical_section(); --#endif THREADS - fd = create_server_port(fix(port)); --#ifdef THREADS -- end_critical_section(); --#endif THREADS - - if (fd == 0) - VALUES(0) = Cnil; -@@ -116,4 +114,190 @@ - { - make_si_function("OPEN-CLIENT-STREAM", Lopen_client_stream); - make_si_function("OPEN-SERVER-STREAM", Lopen_server_stream); -+} -+ -+/* -+ -+ Ok, maybe this shouldn't be here, but it really doesn't belong in -+ crs does it? Also moving it here makes life much easier. -+*/ -+ -+/* socket.c -- socket interface */ -+/* Maybe this shouldn't be here, but what the hell. */ -+/* -+ Copyright (c) 1990, Giuseppe Attardi. -+ -+ ECoLisp is free software; you can redistribute it and/or modify it -+ under the terms of the GNU General Library Public License as published -+ by the Free Software Foundation; either version 2 of the License, or -+ (at your option) any later version. -+ -+ See file '../Copyright' for full details. -+*/ -+ -+#include -+#include -+#include -+ -+#include -+#include -+#include -+#include -+ -+#include -+ -+extern int errno; -+ -+/*********************************************************************** -+ * Client side -+ **********************************************************************/ -+ -+/* -+ * Attempts to connect to server, given host and port. Returns file -+ * descriptor (network socket) or 0 if connection fails. -+ */ -+int connect_to_server(char *host, int port) -+{ -+ struct sockaddr_in inaddr; /* INET socket address. */ -+ struct sockaddr *addr; /* address to connect to */ -+ struct hostent *host_ptr; -+ int addrlen; /* length of address */ -+ extern char *getenv(); -+ extern struct hostent *gethostbyname(); -+ int fd; /* Network socket */ -+ -+ /* Get the statistics on the specified host. */ -+ if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { -+ if ((host_ptr = gethostbyname(host)) == NULL) { -+ /* No such host! */ -+ errno = EINVAL; -+ return(0); -+ } -+ /* Check the address type for an internet host. */ -+ if (host_ptr->h_addrtype != AF_INET) { -+ /* Not an Internet host! */ -+ errno = EPROTOTYPE; -+ return(0); -+ } -+ /* Set up the socket data. */ -+ inaddr.sin_family = host_ptr->h_addrtype; -+ memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, -+ sizeof(inaddr.sin_addr)); -+ } -+ else -+ inaddr.sin_family = AF_INET; -+ -+ addr = (struct sockaddr *) &inaddr; -+ addrlen = sizeof (struct sockaddr_in); -+ inaddr.sin_port = port; -+ inaddr.sin_port = htons(inaddr.sin_port); -+ /* -+ * Open the network connection. -+ */ -+ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) -+ return(0); /* errno set by system call. */ -+ -+#ifdef TCP_NODELAY -+ /* make sure to turn off TCP coalescence */ -+ { int mi; -+ setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); -+ } -+#endif -+ -+#ifdef THREADS -+start_critical_section(); -+#endif -+ if (connect(fd, addr, addrlen) == -1) { -+ (void) close (fd); -+#ifdef THREADS -+end_critical_section(); -+#endif -+ return(0); /* errno set by system call. */ -+ } -+ /* -+ * Return the id if the connection succeeded. -+ */ -+ return(fd); -+} -+ -+ -+/*********************************************************************** -+ * Server side -+ **********************************************************************/ -+/* -+ * Creates a server port. Returns file -+ * descriptor (network socket) or 0 if connection fails. -+ */ -+ -+int create_server_port(int port) -+{ -+ struct sockaddr_in inaddr; /* INET socket address. */ -+ struct sockaddr *addr; /* address to connect to */ -+ int addrlen; /* length of address */ -+ int request, conn; /* Network socket */ -+ -+ /* -+ * Open the network connection. -+ */ -+ if ((request = socket(AF_INET, SOCK_STREAM, 0)) < 0) { -+ return(0); /* errno set by system call. */ -+ } -+ -+#ifdef SO_REUSEADDR -+ /* Necesary to restart the server without a reboot */ -+ { -+ int one = 1; -+ setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(int)); -+ } -+#endif /* SO_REUSEADDR */ -+#ifdef TCP_NODELAY -+ /* make sure to turn off TCP coalescence */ -+ { int mi; -+ setsockopt(request, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); -+ } -+#endif -+ -+ /* Set up the socket data. */ -+ memset((char *)&inaddr, 0, sizeof(inaddr)); -+ inaddr.sin_family = AF_INET; -+ inaddr.sin_port = htons(port); -+ inaddr.sin_addr.s_addr = htonl(INADDR_ANY); -+ -+ if (bind(request, (struct sockaddr *)&inaddr, sizeof (inaddr))) -+ FEerror("Binding TCP socket", 0); -+ if (listen(request, 1)) -+ FEerror("TCP listening", 0); -+ -+#ifdef THREADS -+ /* Don't make this file-descriptor non-blocking */ -+ /* just block on it before we attempt to accept from it */ -+ /* Think _hard_ about moving this out of here, into somewhere sane */ -+ /* and creating an 'accepting' stream type, which is bound to a port */ -+ /* on reading returns streams */ -+ { -+ FILE *fp; /* need to use FILE *'s rather than fd... *sigh* */ -+ if ((fp = fdopen(request, "r")) == (FILE *)0) { -+ printf("fdopen didn't work on accept fd!\n"); fflush(stdout); -+ } -+ fcntl(request, F_SETFL, O_NONBLOCK); -+ clearerr(fp); -+ -+loop: errno = 0; -+#endif -+ if ((conn = accept(request, (struct sockaddr *)NULL, (int *)NULL)) < 0) -+#ifndef THREADS -+ FEerror("Accepting requests", 0); -+#else /* THREADS */ -+ if (errno) { -+ lwpblockon(active, fp, PD_INPUT); -+ clearerr(fp); -+ goto loop; -+ } else { -+ fclose(fp); -+ FEerror("Accepting requests", 0); -+ } -+ fclose(fp); -+ } -+#endif /* THREADS */ -+ return(conn); - } -diff --recursive --unified=3 src/c/unixint.c zsrc/c/unixint.c ---- src/c/unixint.c Sun Sep 24 01:05:26 1995 -+++ zsrc/c/unixint.c Sun Jul 21 13:26:47 1996 -@@ -38,12 +38,15 @@ - void - sigint() - { -+ /* always reinit on entry, since there is a wee race condition that */ -+ /* might bite unless you have BSD flavour signals... *sigh* */ -+ -+ signal(SIGINT, sigint); - if (!interrupt_enable || interrupt_flag) { - if (!interrupt_enable) { - fprintf(stdout, "\n;;;Interrupt delayed.\n"); fflush(stdout); - interrupt_flag = TRUE; - } -- signal(SIGINT, sigint); - return; - } - if (symbol_value(SVinterrupt_enable) == Cnil) { -@@ -70,9 +73,11 @@ - void - sigint() - { --#ifdef SYSV -+/*#ifdef SYSV*/ -+ /* shouldn't hurt to reset it on entry... */ - signal(SIGINT, sigint); --#endif -+/*#endif*/ -+ - if (critical_level > 0) { - scheduler_interrupted = TRUE; - scheduler_interruption = ERROR_INT; -@@ -101,15 +106,17 @@ - signal_catcher(int sig, int code, int scp) - { - char str[64]; -+/* if not bsd... */ -+ signal(sig, signal_catcher); - - if (!interrupt_enable) { - sprintf(str, "signal %d caught (during GC)", sig); - error(str); - } -- else if (sig == SIGSEGV) -+ else if (sig == SIGSEGV) { - FEerror("Segmentation violation.~%\ - Wrong type argument to a compiled function.", 0); -- else { -+ } else { - printf("System error. Trying to recover ...\n"); - fflush(stdout); - FEerror("Signal ~D caught.~%\ -diff --recursive --unified=3 src/c/unixtime.c zsrc/c/unixtime.c ---- src/c/unixtime.c Wed Jul 5 04:12:07 1995 -+++ zsrc/c/unixtime.c Tue Jul 16 19:53:05 1996 -@@ -74,10 +74,18 @@ - Lround(1, z); - z = VALUES(0); - if (FIXNUMP(z)) -+#ifdef THREADS -+ lwpsleep(fix(z)*1000); -+#else - sleep(fix(z)); -+#endif - else - for(;;) -+#ifdef THREADS -+ lwpsleep(1000000); -+#else - sleep(1000); -+#endif - VALUES(0) = Cnil; - RETURN(1); - } -diff --recursive --unified=3 src/crs/Makefile.in zsrc/crs/Makefile.in ---- src/crs/Makefile.in Wed May 31 02:27:00 1995 -+++ zsrc/crs/Makefile.in Wed Jul 17 12:04:30 1996 -@@ -26,7 +26,7 @@ - - # Files - --OBJS = unexec.o dld.o @SETJMPO@ socket.o -+OBJS = unexec.o dld.o @SETJMPO@ - HFILES = ../h/config.h $(srcdir)/objff.h - - SYSDIR = .. -@@ -39,9 +39,6 @@ - - dld.o: $(srcdir)/@DLD@.c $(HFILES) - $(CC) -c $(CFLAGS) $(srcdir)/@DLD@.c -o $@ -- --socket.o: $(srcdir)/socket.c -- $(CC) -c $(CFLAGS) $(srcdir)/socket.c -o $@ - - unexec.o: $(srcdir)/@UNEXEC@.c $(HFILES) - $(CC) -c $(CFLAGS) $(srcdir)/@UNEXEC@.c -o $@ -Only in src/crs: socket.c -diff --recursive --unified=3 src/h/external.h zsrc/h/external.h ---- src/h/external.h Tue Mar 12 20:17:12 1996 -+++ zsrc/h/external.h Wed Jul 17 19:25:23 1996 -@@ -279,9 +279,15 @@ - #ifdef THREADS - extern lpd main_lpd; - extern lpd *clwp; --extern pd *running_head; --extern pd *running_tail; - extern pd main_pd; -+extern pd *active; /* active pd */ -+extern pd *running_queue; /* running pd's */ -+extern pd *blocking_queue; /* blocking pd's */ -+extern pd *delayed_queue; /* delaying pd's */ -+extern pd *dead_queue; /* dead pd's */ -+extern pd *stopped_queue; /* stopped pd's */ -+extern pd *suspended_queue; /* suspended pd's */ -+extern pd *waiting_queue; /* waiting pd's */ - #endif THREADS - - /* macros.c */ -diff --recursive --unified=3 src/h/lwp.h zsrc/h/lwp.h ---- src/h/lwp.h Tue Feb 6 04:00:30 1996 -+++ zsrc/h/lwp.h Sat Jul 20 16:44:15 1996 -@@ -146,8 +146,8 @@ - object lwp_gentemp_prefix; - object lwp_token; /* They have to be initialized with - * alloc_simple_string and */ --} lpd; - -+} lpd; - - #define RUNNING 0 - #define SUSPENDED 1 -@@ -155,6 +155,7 @@ - #define DEAD 3 - #define WAITING 4 - #define DELAYED 5 -+#define BLOCKED 6 - - typedef struct pd { - object pd_thread; /* point back to its thread */ -@@ -166,14 +167,46 @@ - sigjmp_buf pd_env; /* Stack Environment */ - #endif VAX - int pd_slice; /* time out */ -+ int pd_fp_mode; /* in, out, execpt */ - FILE *pd_fp; /* File pointer waiting input on */ - lpd *pd_lpd; /* lisp process descriptor */ - struct pd *pd_next; - - } pd; - -+#define PD_INPUT 0 -+#define PD_OUTPUT 1 -+#define PD_EXCEPTION 2 -+ -+#define ENQUEUE(lpd, queue) \ -+ { if (queue == NULL) { \ -+ lpd->pd_next = lpd; \ -+ queue = lpd; \ -+ } else { \ -+ lpd->pd_next = queue->pd_next; \ -+ queue->pd_next = lpd; \ -+ } } -+ -+#define DEQUEUE(lpd, queue) \ -+ { pd *TMP; \ -+ TMP = queue; \ -+ do { \ -+ if (TMP->pd_next == lpd) { \ -+ TMP->pd_next = lpd->pd_next; \ -+ lpd->pd_next = lpd; \ -+ if (lpd == queue) \ -+ queue = TMP; \ -+ break; \ -+ } \ -+ TMP = TMP->pd_next; \ -+ } while(TMP != queue); \ -+ if (lpd == queue) queue = NULL; \ -+ } - -+#define ROTQUEUE(queue) \ -+ if (queue != NULL) queue = queue->pd_next - -+/* - #define PUSH(lpd) { if ( running_head == NULL) \ - { running_head = lpd; \ - running_tail = lpd; \ -@@ -194,7 +227,7 @@ - running_head = running_head->pd_next; \ - running_tail = running_tail->pd_next; \ - running_tail->pd_next = NULL; } -- -+*/ - - /* - #define PUSH(lpd) ( running_head == NULL \ -Only in zsrc/h: lwp.orig -diff --recursive --unified=3 src/h/machines.h zsrc/h/machines.h ---- src/h/machines.h Thu Jul 4 21:14:03 1996 -+++ zsrc/h/machines.h Mon Jul 15 22:01:57 1996 -@@ -209,7 +209,7 @@ - #define IEEEFLOAT - #define DOWN_STACK - #define BSD --# if __GNUC__ > 2 || __GNUC_MINOR__ > 6 -+# if 0 /*__GNUC__ > 2 || __GNUC_MINOR__ > 6*/ - # define ELF - # define UNEXEC unexelf - #define DATA_START ELF_TEXT_BASE -Only in zsrc: newthread.tgz -Only in zsrc: socket.c