rs@uunet.UU.NET (Rich Salz) (07/31/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 77
Archive-name: comobj.lisp/Part03
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 3 (of 13)."
# Contents: co-meta.l defsys.l fixup.l high.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'co-meta.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-meta.l'\"
else
echo shar: Extracting \"'co-meta.l'\" \(12006 characters\)
sed "s/^X//" >'co-meta.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-meta.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Metaclass for CommonObjects
X; Author: James Kempf
X; Created: March 10, 1987
X; Modified: March 10, 1987 13:30:58 (Roy D'Souza)
X; Language: Lisp
X; Package: COMMON-OBJECTS
X; Status: Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; CommonObjects Class Ndefstruct
X;
X; Instances are represented as trees of their parent instances just like
X; in the original CommonObjects implementation except that we do not make
X; make the single inheritance optimization of in-lining the first parent.
X; The first slot of every instance is the class object.
X; The second slot of every instance is named .SELF. and is a pointer to
X; the acutal object. Then come slots for each of the parent class instances,
X; then the slots for this class.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(ndefstruct (common-objects-class
X (:class class)
X (:include (essential-class))
X (:conc-name class-)
X )
X
X (instance-size 1) ;The total number of slots every instance
X ;of this class must have. This includes
X ;one slot for the pointer to outer self and
X ;one slot for each of the parent instances.
X
X (local-super-slot-names ()) ;A list of the names of the slots used to
X ;store the parent instances. This list
X ;exactly parallels the local-supers as
X ;stored in class-local-supers.
X
X (slots ()) ;The slots required by CommonLoops.
X
X (user-visible-slots ()) ;Instance variable names.
X
X (children ()) ;Children of this guy. Not currently used.
X
X (init-keywords ;Initialization keywords
X ()
X )
X (init-keywords-check T) ;Whether to check the initialization
X ;keywords
X) ;end ndefstruct for common-objects-class
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Establishment of the CommonObjects MetaClass
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X(eval-when (load)
X (define-meta-class common-objects-class
X (lambda (x) (%instance-ref x $CLASS-OBJECT-INDEX))
X))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; CommonObjects MetaClass Protocol
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;add-class-Add a CommonObjects class. Part of the metaclass protocol.
X
X(defmeth add-class ((class common-objects-class)
X new-local-supers
X new-local-slots
X extra
X )
X
X (let
X (
X (local-super-slot-names
X (mapcar #'(lambda (nls) (local-super-slot-name (class-name nls)))
X new-local-supers
X )
X )
X )
X
X (setf (class-local-super-slot-names class) local-super-slot-names)
X
X (setf (class-user-visible-slots class) new-local-slots)
X
X (setq new-local-slots
X (mapcar #'(lambda (x) (make-slotd class :name x))
X (append local-super-slot-names
X new-local-slots)
X )
X )
X
X (setf (class-instance-size class) (length new-local-slots))
X
X (run-super)
X
X ) ;let
X
X) ;end add-class
X
X;;class-slots-Return the slot names for the parents
X
X(defmeth class-slots ((class common-objects-class))
X
X (class-local-slots class)
X
X) ;end class-slots
X
X;;has-slot-p-Return T if class has user visible slot symbol
X
X(defmeth has-slot-p ((class common-objects-class) symbol)
X
X (let
X (
X (bool NIL)
X )
X
X (dolist (slotd (class-user-visible-slots class))
X (when (equal symbol (slot-name-from-slotd slotd))
X (setf bool T)
X (return)
X )
X )
X bool
X
X ) ;end let
X
X) ;end has-slot-p
X
X;;init-keywords-Return the initialization keywords
X
X(defmeth init-keywords ((class common-objects-class))
X
X (class-init-keywords class)
X
X) ;init-keywords
X
X;;class-local-super-names-Return the names of the local supers for
X;; this class.
X
X(defmeth class-local-super-names ((class common-objects-class))
X
X (mapcar #'(lambda (x) (class-name x)) (class-local-supers class))
X
X) ;end class-local-super-names
X
X;;compute-class-precedence-list-Calculate class precedence.
X;; CommonObjects classes don't inherit in the CommonLoops sense.
X;; Tell CommonLoops that they only inherit from themselves,
X;; the class COMMON-OBJECTS-CLASS itself which they need for
X;; GET-SLOT-USING-CLASS and PUT-SLOT-USING-CLASS and default printing
X;; to work right.
X
X(defmeth compute-class-precedence-list ((class common-objects-class))
X
X (list class (class-named 'common-objects-class) (class-named 'object))
X
X) ;end compute-class-precedence-list
X
X;;method-alist-Return the a-list of names v.s. method objects. Only
X;; methods which are CommonObjects methods are returned. This
X;; is to accomodate system generated methods, like TYPE-OF, which
X;; should not be identified as methods on CommonObjects instances.
X;; This routine is primarily used in parsing.
X
X(defmeth method-alist ((class common-objects-class))
X (declare (special *universal-methods*))
X
X (let
X (
X (alist NIL)
X )
X
X ;;First get the direct methods
X
X (dolist (methobj (class-direct-methods class))
X
X (if (eq (class-name (class-of methobj)) 'common-objects-method)
X
X (push
X (list (unkeyword-standin (method-name methobj)) methobj)
X alist
X )
X ) ;if
X )
X
X ;;Now check if any of the universal methods need to be added
X
X (dolist (univmeth *universal-methods*)
X
X (if (not (assoc univmeth alist))
X (push
X (list
X univmeth
X (find-method
X (discriminator-named (keyword-standin univmeth))
X '(common-objects-class)
X NIL
X T
X )
X )
X alist
X )
X
X ) ;if
X
X ) ;dolist
X
X alist
X
X ) ;end let
X
X) ;end method-alist
X
X;;check-init-keywords-Check if the initialization keywords are
X;; correct
X
X(defmeth check-init-keywords ((class common-objects-class) keylist)
X
X (let
X (
X (legalkeys (class-init-keywords class))
X )
X
X (do
X (
X (key (car keylist) (cddr key) )
X )
X ( (null key) )
X
X (if (not (and (keywordp (car key)) (>= (length key) 2)))
X (error "MAKE-INSTANCE: For type ~S, keylist must have alternating keys and values. List:~S~%"
X (class-name class) (car keylist)
X )
X )
X
X (when (not (member (car key) legalkeys))
X (error "MAKE-INSTANCE: For type ~S, ~S is not a legal initialization keyword.~%"
X (class-name class) (car key)
X )
X )
X ) ;dolist
X
X ) ;let
X
X) ;end check-init-keywords
X
X;;optimize-get-slot-Optimize a get slot by returning
X;; the right code. CommonObjects instances are statically
X;; allocated, so "hard" indicies can be used for them.
X;; Stolen from the protocol for BASIC-CLASS.
X
X;(defmeth optimize-get-slot ((method common-objects-method)
X; (class common-objects-class)
X; form)
X; (declare (ignore method)) ; rds 3/9
X(defmeth optimize-get-slot ((class common-objects-class) form)
X `(%instance-ref ,(second form) ,(slot-index class (second (third form))))
X
X
X
X) ;end optimize-get-slot
X
X;;pcl::optimize-setf-of-get-slot-Optimize a setf of a slot
X;; by returning the right code. Again, "hard" indicies
X;; can be used since in-line allocation is the rule.
X;; Stolen from the protocol for BASIC-CLASS.
X
X;(defmeth pcl::optimize-setf-of-get-slot ((method common-objects-method)
X; (class common-objects-class)
X; form)
X; (declare (ignore method))
X(defmeth pcl::optimize-setf-of-get-slot ((class common-objects-class)
X form)
X `(setf
X (%instance-ref , (nth 1 form) ,(slot-index class (second (nth 2 form))))
X ,(nth 3 form)
X )
X
X) ;end optimize-setf-of-get-slot
X
X;;slot-index-Calculate the slot index for the indicated slot
X
X(defmeth slot-index ((class common-objects-class) slotname)
X
X ;;Treat .SELF. as a special case
X
X (if (eq slotname '.self.)
X $SELF-INDEX
X
X (calculate-slot-index
X slotname
X (class-local-super-slot-names class)
X (class-user-visible-slots class)
X )
X
X ) ;if
X
X) ;end slot-index
X
X;;get-slot-using-class-Generic version for all CommonObjects classes.
X;; Normally, this will be optimized out by the optimization method
X;; but just in case.
X
X(defmeth get-slot-using-class ((class common-objects-class) object slot-name)
X
X (%instance-ref object (slot-index class slot-name))
X
X) ;get-slot-using-class
X
X;;put-slot-using-class-Generic version for all CommonObjects classes.
X;; A bug in the default code-walker makes this necessary, although
X;; ultimately a custom walking function for CommonObjects methods
X;; might make the optimization work. Note that the code walker
X;; bug is fixed in the specialized walker method WALK-METHOD-BODY-INTERNAL
X;; for CommonObjects methods.
X
X(defmeth pcl::put-slot-using-class
X ((class common-objects-class) object slot-name new-value)
X
X (setf
X (%instance-ref object (slot-index class slot-name) )
X new-value
X )
X
X) ;put-slot-using-class
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; CommonObjects MetaClass Utility Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;defined-classes-List the defined CommonObjects classes
X
X(defun defined-classes ()
X
X (let
X (
X (defined-types NIL)
X (class (class-named 'common-objects-class))
X )
X
X (maphash
X #'(lambda (key val)
X (when (and val (eq (class-of val) class))
X (setf defined-types (cons key defined-types))
X )
X )
X pcl::*class-name-hash-table*
X )
X defined-types
X )
X) ;end defined-classes
X
X;;slot-name-from-slotd-Return the name of the slot, given the SLOTD.
X
X(defun slot-name-from-slotd (slotd)
X slotd
X
X) ;slot-name-from-slotd
X
X;;method-name-Return the method name, given the method object
X
X(defun method-name (methobj)
X
X (discriminator-name (method-discriminator methobj))
X)
X
END_OF_FILE
if test 12006 -ne `wc -c <'co-meta.l'`; then
echo shar: \"'co-meta.l'\" unpacked with wrong size!
fi
# end of 'co-meta.l'
fi
if test -f 'defsys.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'defsys.l'\"
else
echo shar: Extracting \"'defsys.l'\" \(11775 characters\)
sed "s/^X//" >'defsys.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Some support stuff for compiling and loading PCL. It would be nice if
X;;; there was some portable make-system we could all agree to share for a
X;;; while. At least until people really get databases and stuff.
X;;;
X;;; *** To install PCL at a new site, read the directions above the ***
X;;; *** second and third defvars in this file (down about 10 lines). ***
X;;;
X
X(in-package 'pcl :use (list (or (find-package 'walker)
X (make-package 'walker :use '(lisp)))
X 'lisp))
X
X(defvar *pcl-system-date* "2/24/87")
X
X;;;
X;;; Some CommonLisps have more symbols in the Lisp package than the ones that
X;;; are explicitly specified in CLtL. This causes trouble. Any Lisp that has
X;;; extra symbols in the Lisp package should shadow those symbols in the PCL
X;;; package.
X;;;
X#+TI
X(shadow '(string-append once-only destructuring-bind
X memq assq delq neq ignore true false
X without-interrupts
X defmethod)
X 'pcl)
X#+Spice
X(shadow '(memq assq delq) (find-package 'pcl))
X#+Symbolics
X(shadow '(ignore) (find-package 'pcl))
X
X;;;
X;;; When installing PCL at your site, edit this defvar to give the directory
X;;; in which the PCL files are stored. The values given below are EXAMPLES
X;;; of correct values for *pcl-pathname-defaults*.
X;;;
X(defvar *pcl-pathname-defaults*
X #+Symbolics (pathname "avalon:>Gregor>pcl>")
X #+SUN (pathname "/usr/yak/gregor/pcl/")
X #+ExCL (pathname "/usr/yak/gregor/pcl/")
X #+KCL (pathname "/user/isl/gregor/pcl/")
X #+(and DEC common vax VMS) (pathname "[gregor]")
X #+Spice (pathname "pcl:")
X #+HP (pathname "/net/hplfs2/users/kempf/public/pcl/")
X #+Xerox (pathname "{phylum}<pcl>")
X )
X
X;;;
X;;; When you get a copy of PCL (by tape or by FTP), the sources files will
X;;; have extensions of ".l" specifically, this file will be named defsys.l.
X;;; The preferred way to install pcl is to rename these files to have the
X;;; extension which your lisp likes to use for its files. Alternately, it
X;;; is possible not to rename the files. If the files are not renamed to
X;;; the proper convention, the second line of the following defvar should
X;;; be changed to:
X;;; (let ((files-renamed-p nil)
X;;;
X;;; Note: Something people installing PCL on a machine running Unix
X;;; might find useful. If you want to change the extensions
X;;; of the source files from ".l" to ".lsp", *all* you have to
X;;; do is the following:
X;;;
X;;; % foreach i (*.l)
X;;; ? mv $i $i:r.lsp
X;;; ? end
X;;; %
X;;;
X;;; I am sure that a lot of people already know that, and some
X;;; Unix hackers may say, "jeez who doesn't know that". Those
X;;; same Unix hackers are invited to fix mv so that I can type
X;;; "mv *.l *.lsp".
X;;;
X(defvar *pathname-extensions*
X (let ((files-renamed-p t)
X (proper-extensions
X (car '(#+Symbolics ("lisp" . "bin")
X #+(and dec common) ("LSP" . "FAS")
X #+KCL ("lsp" . "o")
X #+Xerox ("lisp" . "dfasl")
X #+(and Lucid MC68000) ("lisp" . "lbin")
X #+(and Lucid VAX VMS) ("lisp" . "vbin")
X #+excl ("cl" . "fasl")
X #+Spice ("slisp" . "sfasl")
X #+HP ("l" . "b")
X #+TI ("lisp" . "xfasl")
X ))))
X (cond ((null proper-extensions) '("l" . "lbin"))
X ((null files-renamed-p) (cons "l" (cdr proper-extensions)))
X (t proper-extensions))))
X
X
X
X;;;
X;;; *PCL-FILES* is a kind of "defsystem" for pcl. A new port of pcl should
X;;; add an entry for that port's xxx-low file.
X;;;
X(defvar *pcl-files*
X (let ((xxx-low (or #+Symbolics '3600-low
X #+Lucid 'lucid-low
X #+Xerox 'Xerox-low
X #+TI 'ti-low
X #+(and dec common) 'vaxl-low
X #+KCL 'kcl-low
X #+excl 'excl-low
X #+Spice 'spice-low
X #+HP 'hp-low
X nil)))
X ;; file load compile files which force
X ;; environment environment recompilations of
X ;; this file
X `(
X #+Symbolics
X (rel-7-patches nil nil nil)
X #+Symbolics
X (walk (rel-7-patches) (rel-7-patches) nil)
X #-Symbolics
X (walk nil nil ())
X (macros (walk) (walk macros) ())
X (low (walk) (macros) (macros))
X (,xxx-low (low) (macros low) ())
X (braid t ((braid :source)) (low ,xxx-low))
X (class-slots t (braid) (low ,xxx-low))
X (defclass t (braid defclass) (low ,xxx-low))
X (class-prot t (braid
X defclass) (low ,xxx-low))
X (methods t (braid
X class-prot
X (methods :source) ;Because Common Lisp
X ;makes it unlikely
X ;that any particular
X ;CommonLisp will do
X ;the right thing with
X ;a defsetf during
X ;a compile-file.
X ) (low ,xxx-low))
X (dfun-templ t (methods
X (dfun-templ :source)) (low ,xxx-low))
X (fixup t (braid
X methods
X (fixup :source)) (low
X ,xxx-low
X braid
X class-slots
X defclass
X class-prot
X methods
X dfun-templ))
X (high (fixup) ((high :source)) (low ,xxx-low walk))
X (compat (high) (high))
X; (meth-combi (high) (high) )
X; (meth-combs (meth-combi) (meth-combi) (meth-combi))
X; (trapd (meth-combs) (high) )
X )))
X
X(defun load-pcl (&optional (sources-p nil))
X (load-system
X (if sources-p :sources :load) *pcl-files* *pcl-pathname-defaults*)
X (provide "pcl"))
X
X(defun compile-pcl (&optional (force-p nil))
X (load-system (if force-p ':force ':compile) *pcl-files* *pcl-pathname-defaults*))
X
X ;;
X;;;;;; load-system
X ;;
X;;; Yet Another Sort Of General System Facility and friends.
X;;;
X
X(defstruct (module (:constructor make-module
X (name load-env comp-env recomp-reasons))
X (:print-function
X (lambda (m s d)
X (declare (ignore d))
X (format s
X "#<Module ~A L:~@A C:~@A R:~@A>"
X (module-name m)
X (module-load-env m)
X (module-comp-env m)
X (module-recomp-reasons m)))))
X name
X load-env
X comp-env
X recomp-reasons)
X
X(defun load-system (mode system *default-pathname-defaults*)
X (#+Symbolics compiler:compiler-warnings-context-bind
X #-Symbolics progn
X (let ((loaded ()) ;A list of the modules loaded so far.
X (compiled ()) ;A list of the modules we have compiled.
X (modules ()) ;All the modules in the system.
X (module-names ())
X (*modules-to-source-load* ()))
X (declare (special *modules-to-source-load*))
X (labels
X (
X ;(load (x) x)
X ;(compile-file (x) x)
X (find-module (name)
X (or (car (member name modules :key #'module-name))
X (error "Can't find module of name ~S???" name)))
X (needs-compiling-p (m)
X (or (null (probe-file (make-binary-pathname (module-name m))))
X (eq (module-recomp-reasons m) 't)
X (dolist (r (module-recomp-reasons m))
X (when (member (find-module r) compiled)
X (return t)))
X (> (file-write-date (make-source-pathname (module-name m)))
X (file-write-date (make-binary-pathname (module-name m))))))
X (compile-module (m)
X (unless (member m compiled)
X (assure-compile-time-env m)
X (format t "~&Compiling ~A..." (module-name m))
X (compile-file (make-source-pathname (module-name m)))
X (push m compiled)))
X (load-module (m &optional source-p)
X (setq source-p (or (if (member m *modules-to-source-load*) t nil)
X source-p
X (eq mode :sources)))
X (unless (dolist (l loaded)
X (and (eq (car l) m)
X (eq (cdr l) source-p)
X (return t)))
X (assure-load-time-env m)
X (cond (source-p
X (format t "~&Loading source of ~A..." (module-name m))
X (load (make-source-pathname (module-name m))))
X (t
X (format t "~&Loading ~A..." (module-name m))
X (load (make-binary-pathname (module-name m)))))
X (push (cons m source-p) loaded)))
X (assure-compile-time-env (m)
X (let ((*modules-to-source-load*
X (cons m *modules-to-source-load*)))
X (declare (special *modules-to-source-load*)) ;Should not have to
X ;but...
X (dolist (c (module-comp-env m))
X (when (eq (cadr c) :source)
X (push (find-module (car c)) *modules-to-source-load*)))
X (dolist (c (module-comp-env m))
X (load-module (find-module (car c))))))
X (assure-load-time-env (m)
X (dolist (l (module-load-env m))
X (load-module (find-module l))))
X )
X
X ;; Start by converting the list representation of we got into
X ;; modules. At the same time, we convert the abbreviations
X ;; for load-envs and comp envs to the unabbreviated internal
X ;; representation.
X (dolist (file system)
X (let ((name (car file))
X (load-env (cadr file))
X (comp-env (caddr file))
X (recomp-reasons (cadddr file)))
X (push (make-module name
X (if (eq load-env 't)
X (reverse module-names)
X load-env)
X (mapcar #'(lambda (c)
X (if (listp c)
X c
X (list c :binary)))
X (if (eq comp-env 't)
X (reverse (cons name module-names))
X comp-env))
X recomp-reasons)
X modules)
X (push name module-names)))
X (setq modules (nreverse modules))
X (ecase mode
X (:compile
X (dolist (module modules)
X (when (needs-compiling-p module)
X (compile-module module))))
X (:force
X (dolist (module modules)
X (compile-module module)))
X (:load
X (dolist (module modules)
X (load-module module)))
X (:sources
X (dolist (module modules)
X (load-module module t))))))))
X
X(defun make-source-pathname (name)
X (make-pathname
X :name #-VMS (string-downcase (string name))
X #+VMS (string-downcase (substitute #\_ #\- (string name)))
X :type (car *pathname-extensions*)
X :defaults *default-pathname-defaults*))
X
X(defun make-binary-pathname (name)
X (make-pathname
X :name #-VMS (string-downcase (string name))
X #+VMS (string-downcase (substitute #\_ #\- (string name)))
X :type (cdr *pathname-extensions*)
X :defaults *default-pathname-defaults*))
X
END_OF_FILE
if test 11775 -ne `wc -c <'defsys.l'`; then
echo shar: \"'defsys.l'\" unpacked with wrong size!
fi
# end of 'defsys.l'
fi
if test -f 'fixup.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'fixup.l'\"
else
echo shar: Extracting \"'fixup.l'\" \(12761 characters\)
sed "s/^X//" >'fixup.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X(eval-when (compile load eval)
X (setq *real-methods-exist-p* nil)
X (setf (symbol-function 'expand-defmeth)
X (symbol-function 'real-expand-defmeth)))
X
X(eval-when (load)
X (clrhash *discriminator-name-hash-table*)
X (fix-early-defmeths)
X ;; This now happens at the end of loading HIGH to make it
X ;; possible to compile and load pcl in the same environment.
X ;(setq *error-when-defining-method-on-existing-function* t)
X )
X
X(eval-when (compile load eval)
X (setq *real-methods-exist-p* t))
X
X ;;
X;;;;;; Pending defmeths which I couldn't do before.
X ;;
X
X
X(eval-when (load eval)
X (setf (discriminator-named 'print-instance) ())
X (make-specializable 'print-instance :arglist '(instance stream depth)))
X
X(defmeth print-instance ((instance object) stream depth)
X (let ((length (if (numberp *print-length*) (* *print-length* 2) nil)))
X (format stream "#S(~S" (class-name (class-of instance)))
X (iterate ((slot-or-value in (all-slots instance))
X (slotp = t (not slotp)))
X (when (numberp length)
X (cond ((<= length 0) (format stream " ...") (return ()))
X (t (decf length))))
X (princ " " stream)
X (let ((*print-level* (cond ((null *print-level*) ())
X (slotp 1)
X (t (- *print-level* depth)))))
X (if (and *print-level* (<= *print-level* 0))
X (princ "#" stream)
X (prin1 slot-or-value stream))))
X (princ ")" stream)))
X
X(defmeth print-instance ((class essential-class) stream depth)
X (named-object-print-function class stream depth))
X
X
X(defmethod print-instance ((method essential-method) stream depth)
X (ignore depth)
X (printing-random-thing (method stream)
X (let ((discriminator (method-discriminator method))
X (class-name (capitalize-words (class-name (class-of method)))))
X (format stream "~A ~S ~:S"
X class-name
X (and discriminator (discriminator-name discriminator))
X (method-type-specifiers method)))))
X
X(defmethod print-instance ((method basic-method) stream depth)
X (ignore depth)
X (printing-random-thing (method stream)
X (let ((discriminator (method-discriminator method))
X (class-name (capitalize-words (class-name (class-of method)))))
X (format stream "~A ~S ~:S"
X class-name
X (and discriminator (discriminator-name discriminator))
X (unparse-type-specifiers method)))))
X
X(defmethod print-instance ((discriminator essential-discriminator) stream depth)
X (named-object-print-function discriminator stream depth))
X
X(defmethod print-instance ((discriminator basic-discriminator) stream depth)
X (named-object-print-function
X discriminator stream depth (list (method-combination-type discriminator))))
X
X(eval-when (load)
X
X(define-meta-class essential-class (lambda (x) (%instance-ref x 0)))
X
X(defmeth class-slots ((class essential-class))
X (ignore class)
X ())
X
X(defmeth make-instance ((class essential-class))
X (let ((primitive-instance
X (%make-instance (class-named 'esfiers method)))))
X
X(defmethod print-instance ((mss))))))
X (setf (%instance-ref primitive-instance 0) class)
X primitive-instance))
X
X(defmeth get-slot-using-class ((class essential-class) object slot-name)
X (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
X (if pos
X (%instance-ref object (1+ pos))
X (slot-missing ;class
X object slot-name))))
X
X(defmeth put-slot-using-class ((class essential-class)
X object
X slot-name
X new-value)
X (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
X (if pos
X (setf (%instance-ref object (1+ pos)) new-value)
X (slot-missing ;class
X object slot-name))))
X
X(defmeth optimize-get-slot (class form)
X (declare (ignore class))
X form)
X
X(defmeth optimize-setf-of-get-slot (class form)
X (declare (ignore class))
X form)
X
X(defmeth make-slotd ((class essential-class) &rest keywords-and-options)
X (ignore class)
X (apply #'make-slotd--essential-class keywords-and-options))
X
X(defmeth add-named-class ((proto-class essential-class) name
X local-supers
X local-slot-slotds
X extra)
X ;; First find out if there is already a class with this name.
X ;; If there is, call class-for-redefinition to get the class
X ;; object to use for the new definition. If there is no exisiting
X ;; class we just make a new instance.
X (let* ((existing (class-named name t))
X (class (if existing
X (class-for-redefinition existing proto-class name
X local-supers local-slot-slotds
X extra)
X (make (class-of proto-class)))))
X
X (setq local-supers
X (mapcar
X #'(lambda (ls)
X (or (class-named ls t)
X (error "~S was specified as the name of a local-super~%~
X for the class named ~S. But there is no class~%~
X class named ~S." ls name ls)))
X local-supers))
X
X (setf (class-name class) name)
X; (setf (class-ds-options class) extra) ;This is NOT part of the
X; ;standard protocol.
X
X (add-class class local-supers local-slot-slotds extra)
X
X (setf (class-named name) class)
X name))
X
X(defmeth supers-changed ((class essential-class)
X old-local-supers
X old-local-slots
X extra
X top-p)
X (ignore old-local-supers old-local-slots top-p)
X (let ((cpl (compute-class-precedence-list class)))
X (setf (class-class-precedence-list class) cpl)
X; (update-slots--class class cpl) ;This is NOT part of
X; ;the essential-class
X; ;protocol.
X (dolist (sub-class (class-direct-subclasses class))
X (supers-changed sub-class
X (class-local-supers sub-class)
X (class-local-slots sub-class)
X extra
X nil))
X; (when top-p ;This is NOT part of
X; (update-method-inheritance class old-local-supers));the essential-class
X; ;protocol.
X ))
X
X(defmeth slots-changed ((class essential-class)
X old-local-slots
X extra
X top-p)
X (ignore top-p old-local-slots)
X ;; When this is called, class should have its local-supers and
X ;; local-slots slots filled in properly.
X; (update-slots--class class (class-class-precedence-list class))
X (dolist (sub-class (class-direct-subclasses class))
X (slots-changed sub-class (class-local-slots sub-class) extra nil)))
X
X(defmeth method-equal (method argument-specifiers options)
X (ignore options)
X (equal argument-specifiers (method-type-specifiers method)))
X
X(defmeth methods-combine-p ((d essential-discriminator))
X (ignore d)
X nil)
X
X)
X
X ;;
X;;;;;;
X ;;
X
X(define-method-body-macro call-next-method ()
X :global :error
X :method (expand-call-next-method
X (macroexpand-time-method macroexpand-time-environment)
X nil
X macroexpand-time-environment))
X
X(defmethod expand-call-next-method ((mex-method method) args mti)
X (ignore args)
X (let* ((arglist (and mex-method (method-arglist mex-method)))
X (uid (macroexpand-time-method-uid mti))
X (load-method-1-args (macroexpand-time-load-method-1-args mti))
X (load-time-eval-form `(load-time-eval
X (if (boundp ',uid)
X ,uid
X (setq ,uid
X (apply #'load-method-1
X ',load-method-1-args)))))
X (applyp nil))
X (multiple-value-setq (arglist applyp) (make-call-arguments arglist))
X (cond ((null (method-type-specifiers mex-method))
X (warn "Using call-next-method in a default method.~%~
X At run time this will generate an error.")
X '(error "Using call-next-method in a default method."))
X (applyp
X `(apply
X #'call-next-method-internal ,load-time-eval-form . ,arglist))
X (t
X `(call-next-method-internal ,load-time-eval-form . ,arglist)))))
X
X(defun call-next-method-internal (current-method &rest args)
X (let* ((discriminator (method-discriminator current-method))
X (type-specifiers (method-type-specifiers current-method))
X (most-specific nil)
X (most-specific-type-specifiers ())
X (dispatch-order (get-slot--class discriminator 'dispatch-order)))
X (iterate ((method in (discriminator-methods discriminator)))
X (let ((method-type-specifiers (method-type-specifiers method))
X (temp ()))
X (and (every #'(lambda (arg type-spec)
X (or (eq type-spec 't)
X (memq type-spec
X (get-slot--class
X (class-of arg) 'class-precedence-list))))
X args method-type-specifiers)
X (eql 1 (setq temp (compare-type-specifier-lists
X type-specifiers
X method-type-specifiers
X ()
X args
X ()
X dispatch-order)))
X (or (null most-specific)
X (eql 1 (setq temp (compare-type-specifier-lists
X method-type-specifiers
X most-specific-type-specifiers
X ()
X args
X ()
X dispatch-order))))
X (setq most-specific method
X most-specific-type-specifiers method-type-specifiers))))
X (if (or most-specific
X (setq most-specific (discriminator-default-method
X discriminator)))
X (apply (method-function most-specific) args)
X (error "no super method found"))))
X
X;;;
X;;; This is kind of bozoid because it always copies the lambda-list even
X;;; when it doesn't need to. It also doesn't remember things it could
X;;; remember, causing it to call memq more than it should. Fix this one
X;;; day when there is nothing else to do.
X;;;
X(defun make-call-arguments (lambda-list &aux applyp)
X (setq lambda-list (reverse lambda-list))
X (when (memq '&aux lambda-list)
X (setq lambda-list (cdr (memq '&aux lambda-list))))
X (setq lambda-list (nreverse lambda-list))
X (let ((optional (memq '&optional lambda-list)))
X (when optional
X ;; The &optional keyword appears in the lambda list.
X ;; Get rid of it, by moving the rest of the lambda list
X ;; up, then go through the optional arguments, replacing
X ;; them with the real symbol.
X (setf (car optional) (cadr optional)
X (cdr optional) (cddr optional))
X (iterate ((loc on optional))
X (when (memq (car loc) lambda-list-keywords)
X (unless (memq (car loc) '(&rest &key &allow-other-keys))
X (error
X "The non-standard lambda list keyword ~S appeared in the~%~
X lambda list of a method in which CALL-NEXT-METHOD is used.~%~
X PCL can only deal with standard lambda list keywords."))
X (when (listp (car loc)) (setf (car loc) (caar loc)))))))
X (let ((rest (memq '&rest lambda-list)))
X (cond ((not (null rest))
X ;; &rest appears in the lambda list. This means we
X ;; have to do an apply. We ignore the rest of the
X ;; lambda list, just grab the &rest var and set applyp.
X (setf (car rest) (if (listp (cadr rest))
X (caadr rest)
X (cadr rest))
X (cdr rest) ())
X (setq applyp t))
X (t
X (let ((key (memq '&key lambda-list)))
X (when key
X ;; &key appears in the lambda list. Remove &key from the
X ;; lambda list then replace all the keywords with pairs of
X ;; the actual keyword followed by the value variable.
X ;; Have to parse the hairy triple case of &key.
X (let ((key-args
X (iterate ((arg in (cdr key)))
X (until (eq arg '&allow-other-keys))
X (cond ((symbolp arg)
X (collect (make-keyword arg))
X (collect arg))
X ((cddr arg)
X (collect (caddr arg))
X (collect (car arg)))
X (t
X (collect (make-keyword (car arg)))
X (collect (car arg)))))))
X (if key-args
X (setf (car key) (car key-args)
X (cdr key) (cdr key-args))
X (setf (cdr key) nil
X lambda-list (remove '&key lambda-list)))))))))
X (values lambda-list applyp))
X
END_OF_FILE
if test 12761 -ne `wc -c <'fixup.l'`; then
echo shar: \"'fixup.l'\" unpacked with wrong size!
fi
# end of 'fixup.l'
fi
if test -f 'high.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'high.l'\"
else
echo shar: Extracting \"'high.l'\" \(9615 characters\)
sed "s/^X//" >'high.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Non-Bootstrap stuff
X;;;
X
X(in-package 'pcl :nicknames '(portable-commonloops))
X
X
X(ndefstruct (obsolete-class (:class class)
X (:include (class))))
X
X
X(defmeth get-slot-using-class ((class obsolete-class)
X object slot-name
X dont-call-slot-missing-p
X default)
X (change-class object
X (cadr (get-slot class 'class-precedence-list)))
X (get-slot-using-class
X (class-of object) object slot-name dont-call-slot-missing-p default))
X
X
X ;;
X;;;;;;
X ;;
X
X
X(defmeth describe-class (class-or-class-name
X &optional (stream *standard-output*))
X (flet ((pretty-class (class) (or (class-name class) class)))
X (if (symbolp class-or-class-name)
X (describe-class (class-named class-or-class-name) stream)
X (let ((class class-or-class-name))
X (format stream
X "~&The class ~S is an instance of class ~S."
X class
X (class-of class))
X (format stream "~&Name:~23T~S~%~
X Class-Precedence-List:~23T~S~%~
X Local-Supers:~23T~S~%~
X Direct-Subclasses:~23T~S"
X (class-name class)
X (mapcar #'pretty-class (class-class-precedence-list class))
X (mapcar #'pretty-class (class-local-supers class))
X (mapcar #'pretty-class (class-direct-subclasses class)))
X class))))
X
X(defun describe-instance (object &optional (stream t))
X (let* ((class (class-of object))
X (instance-slots (class-instance-slots class))
X (non-instance-slots (class-non-instance-slots class))
X (dynamic-slots (iwmc-class-dynamic-slots object))
X (max-slot-name-length 0))
X (macrolet ((adjust-slot-name-length (name)
X `(setq max-slot-name-length
X (max max-slot-name-length
X (length (the string (symbol-name ,name))))))
X (describe-slot (name value &optional (allocation () alloc-p))
X (if alloc-p
X `(format stream
X "~% ~A ~S ~VT ~S"
X ,name ,allocation (+ max-slot-name-length 7)
X ,value)
X `(format stream
X "~% ~A~VT ~S"
X ,name max-slot-name-length ,value))))
X ;; Figure out a good width for the slot-name column.
X (iterate ((slotd in instance-slots))
X (adjust-slot-name-length (slotd-name slotd)))
X (iterate ((slotd in non-instance-slots))
X (adjust-slot-name-length (slotd-name slotd)))
X (iterate ((name in dynamic-slots by cddr))
X (adjust-slot-name-length name))
X (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
X (format stream "~%~S is an instance of class ~S:" object class)
X (format stream "~% The following slots are allocated in the instance ~
X (:INSTANCE allocation):")
X (iterate ((slotd in instance-slots))
X (let ((name (slotd-name slotd)))
X (describe-slot name (get-slot object name))))
X (when (or dynamic-slots
X (iterate ((slotd in non-instance-slots))
X (when (neq (slotd-allocation slotd) :dynamic) (return t))))
X (format stream
X "~%The following slots have special allocations as shown:")
X (iterate ((slotd in non-instance-slots))
X (unless (eq (slotd-allocation slotd) :dynamic)
X (describe-slot (slotd-name slotd)
X (get-slot object (slotd-name slotd))
X (slotd-allocation slotd))))
X (iterate ((name in dynamic-slots by cddr)
X (val in (cdr dynamic-slots) by cddr))
X (describe-slot name val :dynamic)))))
X object)
X
X
X ;;
X;;;;;;
X ;;
X
X(ndefstruct (structure-metaclass (:class class)
X (:include class)
X (:constructor nil)))
X
X(defmeth expand-defstruct ((class structure-metaclass)
X name-and-options doc slot-descriptions)
X (ignore class doc)
X (let ((class-argument (iterate ((option in (cdr name-and-options)))
X (when (and (listp option)
X (eq (car option) ':class))
X (return option)))))
X `(defstruct ,(remove class-argument name-and-options)
X . ,slot-descriptions)))
X
X
X ;;
X;;;;;;
X ;;
X
X(eval-when (compile load eval)
X(ndefstruct (built-in (:class class)
X (:include (class))))
X
X(ndefstruct (built-in-with-fast-type-predicate (:class class)
X (:include (built-in))))
X
X(defmacro define-built-in-class (name includes &optional fast-type-predicate)
X `(ndefstruct (,name (:class ,(if fast-type-predicate
X 'built-in-with-fast-type-predicate
X 'built-in))
X (:include ,includes))
X (fast-type-predicate ',fast-type-predicate) ;;;
X
X ))
X
X(defmeth parse-defstruct-options ((class built-in) name options)
X (let ((ds-options (call-next-method)))
X (or (ds-options-includes ds-options)
X (setf (ds-options-includes ds-options) (list 'object)))
X ds-options))
X
X(defmeth expand-defstruct-make-definitions ((class built-in)
X name ds-options slotds)
X (ignore class name ds-options slotds)
X ())
X
X(defmeth make-instance ((class built-in))
X (ignore class)
X (error
X "Attempt to make an instance of the built-in class ~S.~%~
X Currently it is not possible to make instance of built-in classes with~
X make.~%~
X A design for this exists, because of metaclasses it is easy to do,~%~
X it just has to be done."
X class))
X
X(defmeth compatible-meta-class-change-p
X ((from built-in)
X (to built-in-with-fast-type-predicate))
X (ignore from to)
X t)
X
X(defmeth check-super-metaclass-compatibility ((built-in built-in)
X (new-super class))
X (or (eq new-super (class-named 't))
X (error "~S cannot have ~S as a super.~%~
X The only meta-class CLASS class that a built-in class can~%~
X have as a super is the class T."
X built-in new-super)))
X
X
X
X(defmeth check-super-metaclass-compatibility
X ((class built-in)
X (new-local-super built-in))
X (ignore class new-local-super)
X t)
X
X;(defmeth check-super-metaclass-compatibility
X; ((class built-in-with-fast-type-predicate)
X; (new-local-super built-in))
X; (ignore class new-local-super)
X; t)
X
X(defmeth compute-class-precedence-list ((class built-in))
X ;; Compute the class-precedence list just like we do for CLASS except that
X ;; a built-in class cannot inherit COMMON from another built-in class. But
X ;; it does inherit the things that it would have inherited had it inherited
X ;; common.
X (let ((val (call-next-method))
X (common-class nil))
X (if (not (memq (setq common-class (class-named 'common t))
X (class-local-supers class)))
X (remove common-class val)
X val)))
X
X
X)
X
X ;;
X;;;;;; The built in types
X ;;
X
X(define-built-in-class common (t))
X
X(define-built-in-class pathname (common) pathnamep)
X
X(define-built-in-class stream (common) streamp)
X
X(define-built-in-class sequence (t))
X(define-built-in-class list (sequence) listp)
X(define-built-in-class cons (list common) consp)
X(define-built-in-class symbol (common) symbolp)
X(define-built-in-class null (list symbol) null)
X
X(define-built-in-class keyword (symbol common) keywordp)
X
X(define-built-in-class array (common) arrayp)
X(define-built-in-class vector (sequence array) vectorp)
X(define-built-in-class simple-array (array))
X
X(define-built-in-class string (vector common) stringp)
X(define-built-in-class bit-vector (vector) bit-vector-p)
X;(vector t) should go here
X
X(define-built-in-class simple-string (string simple-array) simple-string-p)
X(define-built-in-class simple-bit-vector (bit-vector simple-array)
X simple-bit-vector-p)
X(define-built-in-class simple-vector (vector simple-array) simple-vector-p)
X
X(define-built-in-class function (t))
X
X(define-built-in-class character (t) characterp)
X(define-built-in-class string-char (character) string-char-p)
X(define-built-in-class standard-char (string-char common) standard-char-p)
X
X(define-built-in-class structure (common))
X
X(define-built-in-class number (t) numberp)
X
X(define-built-in-class rational (number) rationalp)
X(define-built-in-class float (number) floatp)
X(define-built-in-class complex (number common) complexp)
X
X(define-built-in-class integer (rational))
X(define-built-in-class ratio (rational common))
X
X(define-built-in-class fixnum (integer common))
X(define-built-in-class bignum (integer common))
X
X(define-built-in-class short-float (float common))
X(define-built-in-class single-float (float common))
X(define-built-in-class double-float (float common))
X(define-built-in-class long-float (float common))
X
X(define-built-in-class hash-table (common) hash-table-p)
X(define-built-in-class readtable (common) readtablep)
X(define-built-in-class package (common) packagep)
X(define-built-in-class random-state (common) random-state-p)
X
X
X(eval-when (load)
X (setq *error-when-defining-method-on-existing-function* t))
X
END_OF_FILE
if test 9615 -ne `wc -c <'high.l'`; then
echo shar: \"'high.l'\" unpacked with wrong size!
fi
# end of 'high.l'
fi
echo shar: End of archive 3 \(of 13\).
cp /dev/null ark3isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 13 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Rich $alz "Anger is an energy"
Cronus Project, BBN Labs rsalz@bbn.com
Moderator, comp.sources.unix sources@uunet.uu.
X;;