;;;-*-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 "{nb:parc:xerox}<pcl>") #+:gclisp (pathname "/pcl/") #+pyramid (pathname "") #+:coral (pathname "hd:coral:pcl:") ) ;;; ;;; *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 #+:coral coral)) ;;; ;;; 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") #+:coral ("lisp" . "fasl") )))) (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) (coral-low (low) (low) (low) coral) (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)))) ;;; ;;; unido!ztivax!dae@seismo.css.gov ;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet ;;; #+Symbolics (defun mail-pcl (to) (let* ((original-buffer zwei:*interval*) (files (cons 'defsys (mapcar #'car *pcl-files*))) (total-number (length files)) (file nil) (number-of-lines 0) (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)) (setq number-of-lines (zwei:count-lines b)) (zwei:com-mail-internal t to b nil nil nil (format nil "PCL file ~A (~A of ~A) ~D lines" file i total-number number-of-lines)) (setq mail-buffer zwei:*interval*) (zwei:com-exit-com-mail) (format t "~&Just sent ~A (~A of ~A)." b i total-number) (zwei:kill-buffer mail-buffer))) (zwei:make-buffer-current original-buffer))))