LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032823. :SYSTEM-TYPE :LOGICAL :VERSION 5. :TYPE "LISP" :NAME "DEFSYS" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388351. :AUTHOR "REL3" :LENGTH-IN-BYTES 13951. :LENGTH-IN-BLOCKS 14. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-;;;;;; *************************************************************************;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.;;;;;; Use and copying of this software and preparation of derivative works;;; based upon this software are permitted.  Any distribution of this;;; software or derivative works must comply with all applicable United;;; States export control laws.;;; ;;; This software is made available AS IS, and Xerox Corporation makes no;;; warranty about the software, its performance or its conformity to any;;; specification.;;; ;;; Any person obtaining a copy of this software is requested to send their;;; name and post office or electronic mail address to:;;;   CommonLoops Coordinator;;;   Xerox Artifical Intelligence Systems;;;   2400 Hanover St.;;;   Palo Alto, CA 94303;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa);;;;;; Suggestions, comments and requests for improvements are also welcome.;;; *************************************************************************;;;;;; Some support stuff for compiling and loading PCL.  It would be nice if;;; there was some portable make-system we could all agree to share for a;;; while.  At least until people really get databases and stuff.;;;;;; *** To install PCL at a new site, read the directions above the    ***;;; *** second and third defvars in this file (down about 10 lines).  ***;;;(in-package 'pcl :use (list (or (find-package 'walker)(make-package 'walker :use '(lisp)))    'lisp))(defvar *pcl-system-date* "4/21/87 beta   April 21rst 1987");;;;;; Some CommonLisps have more symbols in the Lisp package than the ones that;;; are explicitly specified in CLtL.  This causes trouble. Any Lisp that has;;; extra symbols in the Lisp package should shadow those symbols in the PCL;;; package.;;;#+TI(shadow '(string-append once-only destructuring-bind  memq assq delq neq true false  without-interrupts rassq make-instance  defmethod defclass)'pcl)#+Spice(shadow '(memq assq delq) (find-package 'pcl))#+Symbolics(shadow '(ignore) (find-package 'pcl));;;;;; When installing PCL at your site, edit this defvar to give the directory;;; in which the PCL files are stored.  The values given below are EXAMPLES;;; of correct values for *pcl-pathname-defaults*.;;; (defvar *pcl-pathname-defaults*#+Symbolics                (pathname "avalon:>Gregor>pcl>")#+SUN                      (pathname "/usr/gregor/pcl/")#+ExCL                     (pathname "/usr/gregor/pcl/")#+KCL                      (pathname "/usr/gregor/pcl/")#+(and DEC common vax VMS) (pathname "");#+system::cmu              (pathname "pcl:")#+HP                       (pathname "")#+Xerox                    (pathname "{phylum}<pcl>")#+:gclisp                  (pathname "/pcl/")#+ti                       (pathname "sys:public.pcl;"));;;;;; When you get a copy of PCL (by tape or by FTP), the sources files will;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.;;; The preferred way to install pcl is to rename these files to have the;;; extension which your lisp likes to use for its files.  Alternately, it;;; is possible not to rename the files.  If the files are not renamed to;;; the proper convention, the second line of the following defvar should;;; be changed to:;;; (let ((files-renamed-p nil);;;;;; Note: Something people installing PCL on a machine running Unix;;;       might find useful.  If you want to change the extensions;;;       of the source files from ".lisp" to ".lsp", *all* you have;;;       to do is the following:;;;;;;       % foreach i (*.lisp);;;       ? mv $i $i:r.lsp;;;       ? end;;;       %;;;;;;       I am sure that a lot of people already know that, and some;;;       Unix hackers may say, "jeez who doesn't know that".  Those;;;       same Unix hackers are invited to fix mv so that I can type;;;       "mv *.lisp *.lsp".;;;(defvar *pathname-extensions*(let ((files-renamed-p t)      (proper-extensions(car '(#+Symbolics                         ("lisp"  . "bin")       #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")       #+(and dec common vax ultrix)       ("lsp"   . "fas")       #+KCL                               ("lsp"   . "o")       #+Xerox                             ("lisp"  . "dfasl")       #+(and Lucid MC68000)               ("lisp"  . "lbin")       #+(and Lucid VAX VMS)               ("lisp"  . "vbin")       #+(and Lucid Prime)                 ("lisp"  . "pbin")       #+excl                              ("cl"    . "fasl");       #+system::cmu                       ("slisp" . "sfasl")       #+HP                                ("l"     . "b")       #+ti      ("lisp"  . #.(string (Si:LOCAL-BINARY-FILE-TYPE )))       #+:gclisp                           ("LSP"   . "FAS")       ))))  (cond ((null proper-extensions) '("l" . "lbin"))((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))(t proper-extensions))))(defun make-source-pathname (name)  (make-pathname    :name #-VMS (string-downcase (string name))          #+VMS (string-downcase (substitute #\_ #\- (string name)))    :type (car *pathname-extensions*)    :defaults *pcl-pathname-defaults*))(defun make-binary-pathname (name)  (make-pathname    :name #-VMS (string-downcase (string name))          #+VMS (string-downcase (substitute #\_ #\- (string name)))    :type (cdr *pathname-extensions*)    :defaults *pcl-pathname-defaults*));;;;;; *PCL-FILES* is a kind of "defsystem" for pcl.  A new port of pcl should;;; add an entry for that port's xxx-low file.;;; (defparameter *pcl-files*  (let ((xxx-low (or #+Symbolics            '3600-low     #+Lucid                'lucid-low     #+Xerox                'Xerox-low     #+TI                   'ti-low     #+(and dec vax common) 'vaxl-low     #+KCL                  'kcl-low     #+excl                 'excl-low;     #+system::cmu          'cmu-low     #+HP                   'hp-low     #+:gclisp              'gold-low     nil)))    ;; file         load           compile         files which force    ;;              environment    environment     recompilations of    ;;                                             this file    `(      #+Symbolics      (rel-7-patches nil            nil                    nil);     (defsys        nil            nil                    nil)      #+Symbolics      (walk         (rel-7-patches) (rel-7-patches)        nil)      #+ti      (ti-patches   nil             nil                    nil)      #+ti      (walk         (ti-patches)    (ti-patches)           nil)      #-(or Symbolics ti)      (walk         nil             nil                    ())      (macros       (walk)          (walk macros)          ())      (low          (walk)          (macros)               (macros))      (,xxx-low     (low)           (macros low)           ())      (fsc-low      (,xxx-low)      (macros low ,xxx-low)  (low ,xxx-low))      (boot         t               t                      (fsc-low))      (braid0       t               t                      (fsc-low))      (slots        t               t                      (fsc-low))      (defclass     t               t                      (fsc-low))      (std-class    t               t                      (fsc-low))      (braid1       t               t                      (fsc-low))      (fsc          t               t                      (fsc-low))      (methods      t               t                      (fsc-low))      (dfun-templ   t               t                      (fsc-low))      (fixup        t               t                      (fsc-low))      (high         (fixup)         (high)                 (fsc-low))      (compat       (high)          t                      ());     (meth-combi   (high)          (high)              );     (meth-combs   (meth-combi)    (meth-combi)        (meth-combi));     (trapd        (meth-combs)    (high)              )      )))  ;;   ;;;;;; operate-on-system  ;;;;; Yet Another Sort Of General System Facility and friends.;;; (defstruct (module (:constructor make-module (name))   (:print-function     (lambda (m s d)       (declare (ignore d))       (format s "#<Module ~A>" (module-name m)))))  name  load-env  comp-env  recomp-reasons)(defun make-modules (system-description)  (let ((modules ()))    (labels ((get-module (name)       (or (find name modules :key #'module-name)   (progn (setq modules (cons (make-module name) modules))  (car modules))))     (parse-spec (spec)       (if (eq spec 't)   (reverse (cdr modules))   (mapcar #'get-module spec))))      (dolist (file system-description)(let* ((name (car file))       (module (get-module name)))  (setf (module-load-env module) (parse-spec (cadr file))(module-comp-env module) (parse-spec (caddr file))(module-recomp-reasons module) (parse-spec (cadddr file))))))    (reverse modules)))(defun make-transformations (modules filter make-transform)  (let ((transforms (list nil)))    (dolist (m modules)      (when (funcall filter m transforms)(funcall make-transform m transforms)))    (reverse (cdr transforms))))(defun make-compile-transformation (module transforms)  (unless (dolist (trans transforms)    (and (eq (car trans) ':compile) (eq (cadr trans) module) (return trans)))     (dolist (c (module-comp-env module))      (make-load-transformation c transforms))    (push `(:compile ,module) (cdr transforms))))(defun make-load-transformation (module transforms)  (unless (dolist (trans transforms)    (and (eq (car trans) ':load) (eq (cadr trans) module) (return trans)))    (dolist (l (module-load-env module))      (make-load-transformation l transforms))    (push `(:load ,module) (cdr transforms))))(defun make-load-without-dependencies-transformation (module transforms)  (unless (dolist (trans transforms)    (and (eq (car trans) ':load) (eq (cadr trans) module) (return trans)))    (push `(:load ,module) (cdr transforms))))(defun compile-filter (module transforms)  (or (dolist (r (module-recomp-reasons module))(when (dolist (transform transforms)(when (and (eq (car transform) ':compile)   (eq (cadr transform) r))  (return t)))  (return t)))      (null (probe-file (make-binary-pathname (module-name module))))      (> (file-write-date (make-source-pathname (module-name module))) (file-write-date (make-binary-pathname (module-name module))))))(defun operate-on-system (system mode &optional arg print-only)  (let ((modules (make-modules system))(transformations ()))    (flet ((load-module (m)     (let ((name (module-name m))   (*load-verbose* nil))       (if (dolist (trans transformations)     (and (eq (car trans) :compile)  (eq (cadr trans) m)  (return trans)))   (progn (format t "~&Loading source of ~A..." name)  (or print-only      (load (make-source-pathname name))))   (progn (format t "~&Loading binary of ~A..." name)  (or print-only      (load (make-binary-pathname name)))))))   (compile-module (m)     (format t "~&Compiling ~A..." (module-name m))     (or print-only  (compile-file (make-source-pathname (module-name m))))))      (setq transformations(ecase mode  (:compile    (make-transformations modules  #'compile-filter  #'make-compile-transformation))  (:recompile    (make-transformations modules  #'(lambda (&rest ignore) t)  #'make-compile-transformation))  (:query-compile    (make-transformations modules  #'(lambda (m transforms)      (or (compile-filter m transforms)  (y-or-n-p "Compile ~A?"    (module-name m))))  #'make-compile-transformation))  (:compile-from    (make-transformations modules  #'(lambda (m transforms)      (or (member (module-name m) arg)  (compile-filter m transforms)))  #'make-compile-transformation))  (:load    (make-transformations modules  #'(lambda (&rest ignore) t)  #'make-load-transformation))  (:query-load    (make-transformations modules      #'(lambda (m transforms)  (y-or-n-p "Load ~A?" (module-name m)))      #'make-load-without-dependencies-transformation))))            (#+Symbolics compiler:compiler-warnings-context-bind       #-Symbolics progn             (loop (when (null transformations) (return t))     (let ((transform (pop transformations)))       (ecase (car transform) (:compile (compile-module (cadr transform))) (:load (load-module (cadr transform))))))))))(defun compile-pcl (&optional m)  (cond ((null m)      (operate-on-system *pcl-files* :compile))((eq m 't)     (operate-on-system *pcl-files* :recompile))((eq m :print) (operate-on-system *pcl-files* :compile () t))((eq m :query) (operate-on-system *pcl-files* :query-compile))((symbolp m)   (operate-on-system *pcl-files* :compile-from (list m)))((listp m)     (operate-on-system *pcl-files* :compile-from m))))(defun load-pcl (&optional m)  (cond ((null m)      (operate-on-system *pcl-files* :load))((eq m :query) (operate-on-system *pcl-files* :query-load))))(defun rename-pcl ()  (dolist (f *pcl-files*)    (let ((old nil)  (new nil))      (let ((*pcl-pathname-defaults* *default-pathname-defaults*))(setq old (make-source-pathname (car f))))      (setq new  (make-source-pathname (car f)))      (rename-file old new))))#+Symbolics(defun edit-pcl ()  (dolist (f *pcl-files*)    (zwei:find-file (make-source-pathname (car f)))))#+Symbolics(defun hardcopy-pcl ()  (dolist (f *pcl-files*)    (multiple-value-bind (ignore b)(zwei:find-file (make-source-pathname (car f)))      (zwei:hardcopy-buffer b))))pixmap) border)   (type (or null bit-gravity) bit-gravity)   (type (or null win-gravity) win-gravity)   (type (or null (member :not-useful :when-mapped :always) backing-store))   (type (or null integer) backing-bit-planes backing-pixel   event-mask do-not-propagate-mask)   (type (or null (member :on :off)) save-under override-redirect)   (type (or null (member :copy