;;;-*-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))))