;;;-*-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). ***
;;;
#|
dcode doesn't use gensym function names
flush :dynamic
cpl should be in know slot #
FSC should be smarter about function slot??
don't funcall closures (FIN's) in systems where it is slow??
get-slot--funcallable-standard-class
FSC stuff compiles faster
function-names, method-names
congruent arglists
macrolet in walk by hacking macroexpand-1??
no this won't work in general because there is no guarantee that the Lisp
really call's macroexpand-1!
|#
(in-package 'pcl :use (list (or (find-package 'walker)
(make-package 'walker :use '(lisp)))
'lisp))
(defvar *pcl-system-date* "8/27/87 August 27th, 1987")
;;;
;;; Various hacks to get people's *features* into better shape.
;;;
(eval-when (compile load eval)
#+Symbolics
(si:inhibit-style-warnings
(let ((major (sct:get-release-version)))
(cond ((= major 6) (pushnew ':symbolics-release-6 *features*))
((= major 7) (pushnew ':symbolics-release-7 *features*))
(t (error "don't know this system version")))))
(dolist (feature *features*)
(when (and (symbolp feature) ;3600!!
(equal (symbol-name feature) "CMU"))
(pushnew :CMU *features*)))
#+TI
(if (eq (si:local-binary-file-type) :xld)
(pushnew ':ti-release-3 *features*)
(pushnew ':ti-release-2 *features*))
)
;;;
;;; 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-directory*.
;;; If the value specified for *pcl-directory* is a CONS, then the CAR is
;;; used as the source file directory and the CDR is used as the binary
;;; file directory.
;;;
(defvar *pcl-directory*
#+Symbolics (cons (pathname "BD:>pcl>")
#+Symbolics-release-6 (pathname "BD:>pcl>rel6>")
#+Symbolics-release-7 (pathname "BD:>pcl>"))
#+Lucid (pathname "/usr/guest/gregor/pcl/")
#+ExCL (pathname "/usr/guest/gregor/pcl/")
#+KCL (pathname "/usr/guest/gregor/pcl/")
#+(and DEC common vax VMS) (pathname "")
#+:CMU (pathname "pcl:")
#+HP (pathname "")
#+Xerox (pathname "{phylum}<pcl>")
#+:gclisp (pathname "/pcl/")
#+pyramid (pathname "")
)
;;;
;;; *port* is a list of symbols (in the PCL package) which represent the
;;; Common Lisp in which PCL is now running. Many of the facilities in
;;; defsys use the value of *port* rather than #+ and #- to conditionalize
;;; the way they work.
;;;
(defvar *port*
'(#+Symbolics Symbolics
#+Symbolics-Release-6 Rel-6
#+Symbolics-Release-7 Rel-7
#+Lucid Lucid
#+Xerox Xerox
#+TI TI
#+(and dec vax common) Vaxlisp
#+KCL KCL
#+excl excl
#+:CMU CMU
#+HP HP
#+:gclisp gclisp
#+pyramid pyramid))
;;;
;;; 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")
#+:CMU ("slisp" . "sfasl")
#+HP ("l" . "b")
#+TI ("lisp" . #.(string (si::local-binary-file-type)))
#+:gclisp ("LSP" . "F2S")
#+pyramid ("clisp" . "o")
))))
(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-internal name :source))
(defun make-binary-pathname (name) (make-pathname-internal name :binary))
(defun make-pathname-internal (name type)
(let* ((extension (ecase type
(:source (car *pathname-extensions*))
(:binary (cdr *pathname-extensions*))))
(directory (etypecase *pcl-directory*
(pathname *pcl-directory*)
(cons (ecase type
(:source (car *pcl-directory*))
(:binary (cdr *pcl-directory*))))))
(pathname
(make-pathname
:name #-VMS (string-downcase (string name))
#+VMS (string-downcase (substitute #\← #\- (string name)))
:type extension
:defaults directory)))
#+Symbolics
(setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
pathname))
;;;
;;; *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*
;; file load compile files which port
;; environment environment force the of
;; recompilation
;; of this file
`((rel-6-patches t t () rel-6)
(rel-7-patches t t () rel-7)
(7debug t t () rel-7)
(ti-patches t t () ti)
(pyr-patches t t () pyramid)
(pkg t t ())
(walk (pkg) (pkg) ())
(macros (pkg walk) (pkg walk) ())
(low (pkg walk) (pkg macros) (macros))
(3600-low (low) (low) (low) Symbolics)
(lucid-low (low) (low) (low) Lucid)
(Xerox-low (low) (low) (low) Xerox)
(ti-low (low) (low) (low) TI)
(vaxl-low (low) (low) (low) vaxlisp)
(kcl-low (low) (low) (low) KCL)
(excl-low (low) (low) (low) excl)
(cmu-low (low) (low) (low) CMU)
(hp-low (low) (low) (low) HP)
(gold-low (low) (low) (low) gclisp)
(pyr-low (low) (low) (low) pyramid)
(fin t t (low))
(defs t t (macros))
(boot t t (defs fin))
(slots t t (boot defs fin))
(defclass t t (boot defs fin))
(std-class t t (boot defs fin))
(braid1 t t (boot defs fin))
(fsc t t (boot defs fin))
(methods t t (boot defs fin))
(dcode t t (defs fin))
(dcode-pre1 t t (defs fin dcode))
(dcode-pre2 t t (defs fin dcode))
(fixup t t (boot defs fin))
(high t t (boot defs fin))
(compat t t ())
))
;;
;;;;;; 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))
(port (car (cddddr file)))
(module nil))
(when (or (null port)
(member port *port*))
(setq 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))
#+symbolics-release-6 (make-load-transformation module transforms)
(push `(:compile ,module) (cdr transforms))))
(defun make-load-transformation (module transforms)
(unless (dolist (trans transforms)
(when (eq (cadr trans) module)
(cond ((eq (car trans) ':compile) (return nil))
((eq (car trans) ':load) (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))
(unless print-only
(let ((name (module-name m)))
(compile-file (make-source-pathname name)
:output-file (make-binary-pathname name)))))
(true (&rest ignore) (declare (ignore ignore)) 't))
(setq transformations
(ecase mode
(:compile
(make-transformations modules
#'compile-filter
#'make-compile-transformation))
(:recompile
(make-transformations modules
#'true
#'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))
(:confirm-compile
(make-transformations modules
#'(lambda (m transforms)
(and (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
#'true
#'make-load-transformation))
(:query-load
(make-transformations modules
#'(lambda (m transforms)
(declare (ignore 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)
#+GCLisp (load "defsys.lsp") ;*** Don't ask
(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))
((eq m :confirm) (operate-on-system *pcl-files* :confirm-compile))
((symbolp m) (operate-on-system *pcl-files* :compile-from `(,m)))
((listp m) (operate-on-system *pcl-files* :compile-from m))))
(defun load-pcl (&optional m)
#+GCLisp (load "defsys.lsp") ;*** Don't ask
(cond ((null m) (operate-on-system *pcl-files* :load))
((eq m :query) (operate-on-system *pcl-files* :query-load))))
;;;;
;;;
;;; This stuff is not intended for external use.
;;;
(defun rename-pcl ()
(dolist (f *pcl-files*)
(let ((old nil)
(new nil))
(let ((*pcl-directory* *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 (&optional query-p)
(let ((files (mapcar #'(lambda (f)
(setq f (car f))
(and (or (not query-p)
(y-or-n-p "~A? " f))
f))
*pcl-files*))
(b zwei:*interval*))
(unwind-protect
(dolist (f files)
(when f
(multiple-value-bind (ignore b)
(zwei:find-file (make-source-pathname f))
(zwei:hardcopy-buffer b))))
(zwei:make-buffer-current b))))
#+Symbolics
(defun mail-pcl (to)
(let* ((original-buffer zwei:*interval*)
(files (cons 'defsys (mapcar #'car *pcl-files*)))
(total-number (length files))
(file nil)
(i 0)
(mail-buffer nil))
(unwind-protect
(loop
(when (null files) (return))
(setq file (pop files))
(incf i)
(multiple-value-bind (ignore b)
(zwei:find-file (make-source-pathname file))
(zwei:com-mail-internal t
to
b
nil
nil
nil
(format nil
"PCL file ~A (~A of ~A)"
file i total-number))
(setq mail-buffer zwei:*interval*)
(zwei:com-exit-com-mail)
(format t "~&Just sent ~A (~A of ~A)." file i total-number)
(zwei:kill-buffer mail-buffer)))
(zwei:make-buffer-current original-buffer))))