home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part03 / defsys.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  11.5 KB  |  324 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26. ;;; Some support stuff for compiling and loading PCL.  It would be nice if
  27. ;;; there was some portable make-system we could all agree to share for a
  28. ;;; while.  At least until people really get databases and stuff.
  29. ;;;
  30. ;;; *** To install PCL at a new site, read the directions above the    ***
  31. ;;; *** second and third defvars in this file (down about 10 lines).  ***
  32. ;;;
  33.  
  34. (in-package 'pcl :use (list (or (find-package 'walker)
  35.                 (make-package 'walker :use '(lisp)))
  36.                 'lisp))
  37.  
  38. (defvar *pcl-system-date* "2/24/87")
  39.  
  40. ;;;
  41. ;;; Some CommonLisps have more symbols in the Lisp package than the ones that
  42. ;;; are explicitly specified in CLtL.  This causes trouble. Any Lisp that has
  43. ;;; extra symbols in the Lisp package should shadow those symbols in the PCL
  44. ;;; package.
  45. ;;;
  46. #+TI
  47. (shadow '(string-append once-only destructuring-bind
  48.       memq assq delq neq ignore true false
  49.       without-interrupts
  50.       defmethod)
  51.     'pcl)
  52. #+Spice
  53. (shadow '(memq assq delq) (find-package 'pcl))
  54. #+Symbolics
  55. (shadow '(ignore) (find-package 'pcl))
  56.  
  57. ;;;
  58. ;;; When installing PCL at your site, edit this defvar to give the directory
  59. ;;; in which the PCL files are stored.  The values given below are EXAMPLES
  60. ;;; of correct values for *pcl-pathname-defaults*.
  61. ;;; 
  62. (defvar *pcl-pathname-defaults*
  63.     #+Symbolics                (pathname "avalon:>Gregor>pcl>")
  64.     #+SUN                      (pathname "/usr/yak/gregor/pcl/")
  65.     #+ExCL                     (pathname "/usr/yak/gregor/pcl/")
  66.     #+KCL                      (pathname "/user/isl/gregor/pcl/")
  67.     #+(and DEC common vax VMS) (pathname "[gregor]")
  68.     #+Spice                   (pathname "pcl:")
  69.     #+HP                  (pathname "/net/hplfs2/users/kempf/public/pcl/")
  70.     #+Xerox                    (pathname "{phylum}<pcl>")
  71.     )
  72.  
  73. ;;;
  74. ;;; When you get a copy of PCL (by tape or by FTP), the sources files will
  75. ;;; have extensions of ".l" specifically, this file will be named defsys.l.
  76. ;;; The preferred way to install pcl is to rename these files to have the
  77. ;;; extension which your lisp likes to use for its files.  Alternately, it
  78. ;;; is possible not to rename the files.  If the files are not renamed to
  79. ;;; the proper convention, the second line of the following defvar should
  80. ;;; be changed to:
  81. ;;;     (let ((files-renamed-p nil)
  82. ;;;
  83. ;;; Note: Something people installing PCL on a machine running Unix
  84. ;;;       might find useful.  If you want to change the extensions
  85. ;;;       of the source files from ".l" to ".lsp", *all* you have to
  86. ;;;       do is the following:
  87. ;;;
  88. ;;;       % foreach i (*.l)
  89. ;;;       ? mv $i $i:r.lsp
  90. ;;;       ? end
  91. ;;;       %
  92. ;;;
  93. ;;;       I am sure that a lot of people already know that, and some
  94. ;;;       Unix hackers may say, "jeez who doesn't know that".  Those
  95. ;;;       same Unix hackers are invited to fix mv so that I can type
  96. ;;;       "mv *.l *.lsp".
  97. ;;;
  98. (defvar *pathname-extensions*
  99.     (let ((files-renamed-p t)
  100.           (proper-extensions
  101.         (car '(#+Symbolics           ("lisp"  . "bin")
  102.                #+(and dec common)    ("LSP"   . "FAS")
  103.                #+KCL                 ("lsp"   . "o")
  104.                #+Xerox               ("lisp"  . "dfasl")
  105.                #+(and Lucid MC68000) ("lisp"  . "lbin")
  106.                #+(and Lucid VAX VMS) ("lisp"  . "vbin")
  107.                #+excl                ("cl"    . "fasl")
  108.                #+Spice               ("slisp" . "sfasl")
  109.                #+HP                  ("l"     . "b")
  110.                #+TI                  ("lisp"  . "xfasl")
  111.                ))))
  112.       (cond ((null proper-extensions) '("l" . "lbin"))
  113.         ((null files-renamed-p) (cons "l" (cdr proper-extensions)))
  114.         (t proper-extensions))))
  115.  
  116.  
  117.  
  118. ;;;
  119. ;;; *PCL-FILES* is a kind of "defsystem" for pcl.  A new port of pcl should
  120. ;;; add an entry for that port's xxx-low file.
  121. ;;; 
  122. (defvar *pcl-files*
  123.   (let ((xxx-low (or #+Symbolics '3600-low
  124.              #+Lucid     'lucid-low
  125.              #+Xerox     'Xerox-low
  126.              #+TI        'ti-low
  127.              #+(and dec common) 'vaxl-low
  128.              #+KCL       'kcl-low
  129.              #+excl      'excl-low
  130.              #+Spice     'spice-low
  131.              #+HP        'hp-low
  132.              nil)))
  133.     ;; file         load           compile         files which force
  134.     ;;              environment    environment     recompilations of
  135.     ;;                                             this file
  136.     `(
  137.       #+Symbolics
  138.       (rel-7-patches nil            nil                    nil)
  139.       #+Symbolics
  140.       (walk         (rel-7-patches) (rel-7-patches)        nil)
  141.       #-Symbolics
  142.       (walk         nil             nil                    ())
  143.       (macros       (walk)          (walk macros)          ())
  144.       (low          (walk)          (macros)               (macros))
  145.       (,xxx-low     (low)           (macros low)           ())
  146.       (braid        t               ((braid :source))      (low ,xxx-low))
  147.       (class-slots  t               (braid)                (low ,xxx-low))
  148.       (defclass     t               (braid defclass)       (low ,xxx-low))
  149.       (class-prot   t               (braid
  150.                      defclass)             (low ,xxx-low))
  151.       (methods      t               (braid
  152.                      class-prot
  153.                      (methods :source)    ;Because Common Lisp
  154.                                 ;makes it unlikely
  155.                                 ;that any particular
  156.                                 ;CommonLisp will do
  157.                                 ;the right thing with
  158.                                 ;a defsetf during
  159.                                 ;a compile-file.
  160.                      )                  (low ,xxx-low))
  161.       (dfun-templ   t               (methods 
  162.                       (dfun-templ :source)) (low ,xxx-low))
  163.       (fixup        t               (braid
  164.                      methods
  165.                      (fixup :source))   (low
  166.                              ,xxx-low
  167.                              braid
  168.                              class-slots
  169.                              defclass
  170.                              class-prot
  171.                              methods
  172.                              dfun-templ))
  173.       (high         (fixup)         ((high :source))    (low ,xxx-low walk))
  174.       (compat       (high)          (high))
  175. ;     (meth-combi   (high)          (high)              )
  176. ;     (meth-combs   (meth-combi)    (meth-combi)        (meth-combi))
  177. ;     (trapd        (meth-combs)    (high)              )
  178.       )))
  179.  
  180. (defun load-pcl (&optional (sources-p nil))
  181.   (load-system
  182.     (if sources-p :sources :load) *pcl-files* *pcl-pathname-defaults*)
  183.   (provide "pcl"))
  184.  
  185. (defun compile-pcl (&optional (force-p nil))
  186.   (load-system (if force-p ':force ':compile) *pcl-files* *pcl-pathname-defaults*))
  187.  
  188.   ;;   
  189. ;;;;;; load-system
  190.   ;;
  191. ;;; Yet Another Sort Of General System Facility and friends.
  192. ;;; 
  193.  
  194. (defstruct (module (:constructor make-module
  195.                  (name load-env comp-env recomp-reasons))
  196.            (:print-function
  197.              (lambda (m s d)
  198.                (declare (ignore d))
  199.                (format s
  200.                    "#<Module ~A L:~@A  C:~@A  R:~@A>"
  201.                    (module-name m)
  202.                    (module-load-env m)
  203.                    (module-comp-env m)
  204.                    (module-recomp-reasons m)))))
  205.   name
  206.   load-env
  207.   comp-env
  208.   recomp-reasons)
  209.  
  210. (defun load-system (mode system *default-pathname-defaults*)
  211.   (#+Symbolics compiler:compiler-warnings-context-bind
  212.    #-Symbolics progn
  213.    (let ((loaded ())    ;A list of the modules loaded so far.
  214.      (compiled ())  ;A list of the modules we have compiled.
  215.      (modules ())   ;All the modules in the system.
  216.      (module-names ())
  217.      (*modules-to-source-load* ()))
  218.      (declare (special *modules-to-source-load*))
  219.      (labels
  220.        (
  221.        ;(load (x) x)
  222.        ;(compile-file (x) x)
  223.     (find-module (name)
  224.       (or (car (member name modules :key #'module-name))
  225.           (error "Can't find module of name ~S???" name)))
  226.     (needs-compiling-p (m)
  227.       (or (null (probe-file (make-binary-pathname (module-name m))))
  228.           (eq (module-recomp-reasons m) 't)
  229.           (dolist (r (module-recomp-reasons m))
  230.         (when (member (find-module r) compiled)
  231.           (return t)))
  232.           (> (file-write-date (make-source-pathname (module-name m)))
  233.          (file-write-date (make-binary-pathname (module-name m))))))
  234.     (compile-module (m)
  235.       (unless (member m compiled)
  236.         (assure-compile-time-env m)
  237.         (format t "~&Compiling ~A..." (module-name m))
  238.         (compile-file (make-source-pathname (module-name m)))
  239.         (push m compiled)))
  240.     (load-module (m &optional source-p)
  241.       (setq source-p (or (if (member m *modules-to-source-load*) t nil)
  242.                  source-p
  243.                  (eq mode :sources)))
  244.       (unless (dolist (l loaded)
  245.             (and (eq (car l) m)
  246.              (eq (cdr l) source-p)
  247.              (return t)))
  248.         (assure-load-time-env m)
  249.         (cond (source-p
  250.            (format t "~&Loading source of ~A..." (module-name m))
  251.            (load (make-source-pathname (module-name m))))
  252.           (t
  253.            (format t "~&Loading ~A..." (module-name m))
  254.            (load (make-binary-pathname (module-name m)))))
  255.         (push (cons m source-p) loaded)))
  256.     (assure-compile-time-env (m)
  257.       (let ((*modules-to-source-load*
  258.           (cons m *modules-to-source-load*)))
  259.         (declare (special *modules-to-source-load*))    ;Should not have to
  260.                         ;but...
  261.         (dolist (c (module-comp-env m))
  262.           (when (eq (cadr c) :source)
  263.         (push (find-module (car c)) *modules-to-source-load*)))
  264.         (dolist (c (module-comp-env m))
  265.           (load-module (find-module (car c))))))
  266.     (assure-load-time-env (m)
  267.       (dolist (l (module-load-env m))
  268.         (load-module (find-module l))))
  269.     )
  270.        
  271.        ;; Start by converting the list representation of we got into
  272.        ;; modules.  At the same time, we convert the abbreviations
  273.        ;; for load-envs and comp envs to the unabbreviated internal
  274.        ;; representation.
  275.        (dolist (file system)
  276.      (let ((name (car file))
  277.            (load-env (cadr file))
  278.            (comp-env (caddr file))
  279.            (recomp-reasons (cadddr file)))
  280.        (push (make-module name
  281.                   (if (eq load-env 't)
  282.                   (reverse module-names)
  283.                   load-env)
  284.                   (mapcar #'(lambda (c)
  285.                       (if (listp c)
  286.                           c
  287.                           (list c :binary)))
  288.                       (if (eq comp-env 't)
  289.                       (reverse (cons name module-names))
  290.                       comp-env))
  291.                   recomp-reasons)
  292.          modules)
  293.        (push name module-names)))
  294.        (setq modules (nreverse modules))
  295.        (ecase mode
  296.      (:compile
  297.        (dolist (module modules)
  298.          (when (needs-compiling-p module)
  299.            (compile-module module))))
  300.      (:force
  301.        (dolist (module modules)
  302.          (compile-module module)))
  303.      (:load
  304.        (dolist (module modules)
  305.          (load-module module)))
  306.      (:sources
  307.        (dolist (module modules)
  308.          (load-module module t))))))))
  309.  
  310. (defun make-source-pathname (name)
  311.   (make-pathname
  312.     :name #-VMS (string-downcase (string name))
  313.           #+VMS (string-downcase (substitute #\_ #\- (string name)))
  314.     :type (car *pathname-extensions*)
  315.     :defaults *default-pathname-defaults*))
  316.  
  317. (defun make-binary-pathname (name)
  318.   (make-pathname
  319.     :name #-VMS (string-downcase (string name))
  320.           #+VMS (string-downcase (substitute #\_ #\- (string name)))
  321.     :type (cdr *pathname-extensions*)
  322.     :defaults *default-pathname-defaults*))
  323.  
  324.