home *** CD-ROM | disk | FTP | other *** search
/ vis-ftp.cs.umass.edu / vis-ftp.cs.umass.edu.tar / vis-ftp.cs.umass.edu / pub / Software / ASCENDER / ascender.tar.Z / ascender.tar / Epipolar / lucid-defsystem.lisp < prev    next >
Lisp/Scheme  |  1995-07-20  |  44KB  |  1,205 lines
  1. ;;;; -*-lisp-mode-*-
  2. ;;;; -*- Mode:Common-Lisp; Package:defsys; Base:10; Fonts:(hl12fb) -*-
  3. ;;;; *-* File: VAX6:DIS$DISK:[CERLISP]DEFSYSTEM.LISP *-*
  4. ;;;; *-* Last-Edit: Tuesday, July 8, 1986  16:49:22; Edited-By: CORK *-*
  5. ;;;; *-* Machine: Caliban Explorer, Microcode 253 D0; Software: Zetalisp System 2.11 *-*
  6. ;;;; *-* Lisp: Zetalisp System 2.11 (0.0) *-*
  7.  
  8. ;;;; **************************************************************************
  9. ;;;; **************************************************************************
  10. ;;;; *
  11. ;;;; *                            SIMPLE DEFSYSTEM
  12. ;;;; *
  13. ;;;; **************************************************************************
  14. ;;;; **************************************************************************
  15. ;;;
  16. ;;; Written by: Kelly Murray
  17. ;;;             Department of Computer and Information Science
  18. ;;;             University of Massachusetts
  19. ;;;             Amherst, Massachusetts 01003.
  20. ;;;
  21. ;;; This code was written as part of general Extended Common Lisp support at
  22. ;;; the Department of Computer and Information Science (COINS), University of 
  23. ;;; Massachusetts, Amherst, Massachusetts, 01003.
  24. ;;;
  25. ;;; Copyright (c) 1985, COINS.  All rights are reserved.
  26. ;;;
  27. ;;; Development of this code was partially supported by:
  28. ;;;    NSF CER grant DCR-8500332;
  29. ;;;    NSF maintenance grant DCR-8318776;
  30. ;;;    NSF CDPS grant MCS-8318776;
  31. ;;;    ONR CDPS contract NR049-041.
  32. ;;;
  33. ;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  34. ;;;
  35. ;;;  10/23/85 File Created.  (MURRAY)
  36. ;;;  Tue Apr 28 1987 modified to handle file of type .lsp (RPH)
  37. ;;;  Tue Apr 30 1987 modified to handle additional options and keywords:
  38. ;;;        :warning-pathname-default (defsystem option - define pathname 
  39. ;;;             for compiler warnings)
  40. ;;;        :defaulted-batch & :batch (uses warnings output file and does 
  41. ;;;             :noconfirm)
  42. ;;;        :noconfirm (answer yes to all questions)
  43. ;;;        :print-only - only print transformations, don't do them
  44. ;;;        :noload - don't load system (used with :compile or :recomple)
  45. ;;;
  46. ;;;  Mon Feb 27 1995 added *compiled-file-extension* parameter  --Bob Collins
  47. ;;;  Wed Mar 1  1995 allow pathname default specification to be a symbol
  48. ;;;                  which evaluates to a string --Bob Collins
  49. ;;;
  50. ;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  51.  
  52. (eval-when (load eval compile)
  53.    (unless (find-package "DEFSYS")
  54.        (make-package "DEFSYS")))
  55.  
  56. (in-package "DEFSYS")
  57.  
  58. #-:ALLEGRO
  59. (provide 'user::defsys)
  60.  
  61.  
  62. #+(or TI :ALLEGRO)
  63. (shadow '(defsystem compile-system load-system make-system))
  64. #-TI
  65. (export '(defsystem make-system compile-system load-system prompt-choose))
  66.  
  67. ;;; ***************************************************************************
  68.  
  69. (defparameter *compiled-file-extension*
  70.   #+DEC "FAS"
  71.   #+(and :LUCID :MIPS :DBCS) "mbin5"
  72.   #+(and :LUCID :MIPS) "mbin"
  73.   #+(and :LUCID :SPARC :DBCS) "dsbin"
  74.   #+(and :LUCID :SPARC) "sbin"
  75.   #+:ALLEGRO "fasl")
  76.  
  77. (defvar *print-transforms-only* nil
  78.    "Set if transforms are only to be printed, not done (used for debugging defsystems).")
  79.  
  80. (defun make-system (sys &rest options)
  81.   (let* ((verbose (not (intersection '(:silent :batch :defaulted-batch)
  82.                      options)))
  83.      (batch-file (when (intersection '(:batch :defaulted-batch) options)
  84.               (let* ((def-warn-path (get-warnings-pathname sys))
  85.                  (bf (if (member :defaulted-batch options)
  86.                      def-warn-path
  87.                      (ask-for-string-or-default
  88.                        "Warnings file"
  89.                        def-warn-path))))
  90.                 (unless (eq bf 'T) bf))
  91.               ))
  92.      (*standard-output* (if batch-file
  93.                 (open batch-file :direction :output
  94.                       :if-exists :new-version)
  95.                 *standard-output*))
  96.      (*error-output* *standard-output*)
  97.      (noconfirm (intersection '(:batch :defaulted-batch :noconfirm)
  98.                   options))
  99.      (*print-transforms-only* (member :print-only options))
  100.      )
  101.                 
  102.     (unwind-protect
  103.       (progn
  104.  
  105.     ;; Do we compile first?
  106.     (cond
  107.       ((member :compile options)
  108.        (compile-system sys :verbose verbose :noconfirm noconfirm))
  109.       ((member :recompile options)
  110.        (compile-system sys :recompile t :verbose verbose 
  111.                :noconfirm noconfirm)))
  112.     ;; Load it unless :noload specified
  113.     (unless (member :noload options)
  114.         (load-system sys :verbose verbose :noconfirm noconfirm)))
  115.       (when batch-file (close *standard-output*))
  116.       )
  117.     )
  118.   sys)
  119.  
  120. #+DEC
  121. (defun PROMPT-CHOOSE (prompt keys &optional help)
  122.   "PROMPT-CHOOSE prompt keys &optional help
  123. This will use prompt to prompt for one of keys. If one of
  124. keys is entered, the upper case character is returned. If
  125. a ? is entered, help is printed if given, otherwise the
  126. list of keys is displayed, and the user is re-prompted."
  127.   (let ((mode (get-terminal-modes))
  128.         (key))
  129.     (set-terminal-modes :pass-through t)
  130.     (unwind-protect
  131.         (do () (())
  132.           (format t prompt)
  133.           (setq key (read-char))
  134.           (cond ((char= key #\^C)
  135.                  (throw sys::*top-level-catcher* t))
  136.                 ((member key keys :TEST #'char-equal)
  137.                  (return (char-upcase key)))
  138.                 ((char= key #\?)
  139.                  (if help (format t help)
  140.                      (format t "~%Sorry No Help Available.~
  141.                                 ~%Please Enter one of: ~{~C ~}" keys)))
  142.                 (t (format t "~%Please Enter one of: ~{~C ~}" keys))))
  143.       (apply #'set-terminal-modes mode))))
  144. #+(or :LUCID :ALLEGRO)
  145. (defun PROMPT-CHOOSE (prompt keys &optional help)
  146.   "PROMPT-CHOOSE prompt keys &optional help
  147. This will use prompt to prompt for one of keys. If one of
  148. keys is entered, the upper case character is returned. If
  149. a ? is entered, help is printed if given, otherwise the
  150. list of keys is displayed, and the user is re-prompted."
  151.  
  152.   (let ((key nil))
  153.        (do () (())
  154.          (format t prompt)
  155.          (setq key (aref (read-line) 0))
  156.          (cond ((member key keys :TEST #'char-equal)
  157.                 (return (char-upcase key)))
  158.                ((char= key #\?)
  159.                 (if help (format t help)
  160.                     (format t "~%Sorry No Help Available.~
  161.                                ~%Please Enter one of: ~{~C ~}" keys)))
  162.                (t (format t "~%Please Enter one of: ~{~C ~}" keys))))
  163.    )
  164. )
  165.  
  166. (defun ask-for-string-or-default (prompt default)
  167.   (let (ans)
  168.        (format *query-io* "~%~A (~A)? " prompt default)
  169.        (setf ans (read-line *query-io*))
  170.        (if (string= ans "") default ans)))
  171.  
  172. (defparameter *source-files* nil
  173.   "Bound to a list of the source files that make up the current system.")
  174.  
  175. (defstruct (defsystem #-:LUCID :NAMED (:CONC-NAME defsystem-))
  176.   (name "")
  177.   (pathname "")
  178.   (package)
  179.   (short-name)
  180.   (included-systems)
  181.   (warnings-pathname)
  182.   (modules-alist))
  183.  
  184. (defstruct (system-module #-:LUCID :NAMED (:CONC-NAME system-module-))
  185.   (name nil)
  186.   (files nil)
  187.   (loaded-files nil)
  188.   (compile nil)
  189.   (load nil)
  190.   (dependants nil)
  191.   (self-dependant-p nil)
  192.   (flags nil)
  193.   )
  194.  
  195. (defun get-warnings-pathname (sysname)
  196.   (let ((defsys (get sysname 'defsystem)))
  197.        (if defsys
  198.        (defsystem-warnings-pathname defsys)
  199.        (Error "~S is not a defined system!" sysname)))
  200.   )
  201.  
  202. (defmacro DEFSYSTEM (name &REST options)
  203.   (let ((defsys (create-defsystem name options)))
  204.     `(let* ((sys ',defsys))
  205.        ;; create the package if not already.
  206.        (let ((*package* *package*))
  207.         (when (defsystem-package sys)
  208.           (unless (find-package (car (defsystem-package sys)))
  209.         (apply #'make-package (defsystem-package sys)))))
  210.        ;; put the system on it's property list.
  211.        (setf (get ',name 'defsystem) sys)
  212.        sys)))
  213.  
  214. (defun CREATE-DEFSYSTEM (name options)
  215.   (let ((defsys (make-defsystem :warnings-pathname
  216. #+DEC
  217.                 (concatenate 'string
  218.                          "SYS$LOGIN:"
  219.                          (make-file-name
  220.                            (string name))
  221.                          ".LOG")
  222. #+:LUCID
  223.                 (concatenate 'string
  224.                          (environment-variable "HOME")
  225.                          "/"
  226.                          (make-file-name (string name))
  227.                          ".log")
  228. #+:ALLEGRO
  229.                 (concatenate 'string
  230.                          (system::getenv "HOME")
  231.                          "/"
  232.                          (make-file-name (string name))
  233.                          ".log")
  234.  
  235.              ))
  236.         (modalist nil)
  237.         (pkg '(user))
  238.         mod dep modname deps)
  239.     (dolist (opt options)
  240.       (case (first opt)
  241.         (:NAME (setf (defsystem-name defsys) (second opt)))
  242.         (:PATHNAME-DEFAULT (setf (defsystem-pathname defsys) 
  243.                  (eval (second opt))))   ;;Bob Collins, 3/1/95
  244.     (:warnings-pathname-default
  245.       (setf (defsystem-warnings-pathname defsys) (second opt)))
  246.         (:PACKAGE  (if (atom (second opt))
  247.                        (setq pkg (list (second opt)))
  248.                        (setq pkg (second opt))))
  249.         (:SHORT-NAME (setf (defsystem-short-name defsys) (second opt)))
  250.         (:COMPONENT-SYSTEMS (setf (defsystem-included-systems defsys)
  251.                                   (second opt)))
  252.         (:MODULE
  253.             ;; create the module.
  254.             (push (cons (setq modname (second opt))
  255.                         (setq mod (make-system-module))) modalist)
  256.             (setf (system-module-name mod) modname)
  257.         (let ((files (if (consp (third opt))
  258.                  (third opt)
  259.                  (list (third opt))
  260.                  )))
  261.          ;; set the files.
  262.          (setf (system-module-files mod)
  263.                (mapcan #'(lambda(spec)
  264.                     (get-module-files 
  265.                       spec modalist
  266.                       (if (defsystem-pathname defsys)
  267.                           (defsystem-pathname
  268.                         defsys)
  269.                           "")
  270.                       ))
  271.                    files)))
  272.         )
  273. #+DEC
  274.         (:C-MODULE
  275.             ;; create the C module.
  276.             (push (cons (setq modname (second opt))
  277.                         (setq mod (make-system-module :flags :c))) modalist)
  278.             (setf (system-module-name mod) modname)
  279.         (let ((files (if (consp (third opt))
  280.                  (third opt)
  281.                  (list (third opt))
  282.                  )))
  283.          ;; set the files.
  284.          (setf (system-module-files mod)
  285.                (mapcan #'(lambda(spec)
  286.                     (get-c-module-files 
  287.                       spec modalist
  288.                       (if (defsystem-pathname defsys)
  289.                           (defsystem-pathname
  290.                         defsys)
  291.                           "")
  292.                       ))
  293.                    files))
  294.          )
  295.         (setf (system-module-load mod)
  296.           (get-link-com-file-name (string
  297.                         (or
  298.                           (fourth opt)
  299.                           modname))
  300.                       (if (defsystem-pathname defsys)
  301.                           (defsystem-pathname
  302.                         defsys)
  303.                           "")))
  304.         
  305.         )
  306.  
  307.         ((:FASLOAD :READFILE)
  308.             (cond
  309.               ((Null (setq mod (cdr (assoc (second opt) modalist))))
  310.                (error "Module ~a Isn't Defined." (second opt)))
  311.               (t (setf (system-module-load mod) (first opt))
  312.                  (when (setq dep (third opt))
  313.                    (ecase (first dep)
  314.                      ((:FASLOAD :READFILE :COMPILE)
  315.                       (setf (system-module-load mod) (cdr dep)))))
  316.                  )))
  317.  
  318.         (:COMPILE
  319.             (cond
  320.               ((Null (setq mod (cdr (assoc (second opt) modalist))))
  321.                (error "Module ~a Isn't Defined." (second opt)))
  322.           ((eq (system-module-flags mod) :c)
  323.            (setf (system-module-compile mod) t)
  324.            (when (setq dep (third opt))
  325.              (setf (system-module-compile mod) dep))
  326.            )
  327.               (t (setf (system-module-compile mod) t)
  328.                  (when (setq dep (third opt))
  329.                    (ecase (first dep)
  330.                      ((:FASLOAD :READFILE :COMPILE)
  331.                       (setf (system-module-compile mod) (cdr dep))))))))
  332.         (:COMPILE-LOAD
  333.             (cond
  334.               ((Null (setq mod (cdr (assoc (second opt) modalist))))
  335.                    (error "Module ~a Isn't Defined." (second opt)))
  336.               ((eq (system-module-flags mod) :c)
  337.            (setf (system-module-compile mod) t)
  338.            (when (setq dep (third opt))
  339.              (setf (system-module-compile mod) dep))
  340.            )
  341.               (t (setf (system-module-compile mod) t)
  342.                  (setf (system-module-load mod) t)
  343.                  (when (setq dep (third opt))
  344.                    (ecase (first dep)
  345.                      ((:FASLOAD :READFILE)
  346.                          (setf (system-module-compile mod) (cdr dep))
  347.                          (setf (system-module-load mod)
  348.                                (or (remove (second opt) (cdr dep)) t))
  349.                          (setf (system-module-self-dependant-p mod)
  350.                                (member name (cdr dep))))
  351.                          )))))
  352.         (otherwise (format t "~%Unsupported Defsystem Option - ~a"
  353.                            (first opt)))))
  354.     (setf (defsystem-package defsys) pkg)
  355.     (unless (defsystem-short-name defsys)
  356.       (setf (defsystem-short-name defsys)
  357.             (defsystem-name defsys)))
  358.     (setf (defsystem-modules-alist defsys)
  359.           (setq modalist (nreverse modalist)))
  360.     ;; Record reverse compile dependancies
  361.     (dolist (mcons modalist)
  362.       ;; when we have some.
  363.       (when (and (setq deps (system-module-compile (cdr mcons)))
  364.                  (listp deps))
  365.         ;; record the backward link.
  366.         (dolist (m deps)
  367.           ;; unless the same as itself.
  368.           (unless (eq m (system-module-name (cdr mcons)))
  369.             ;; add this one.
  370.             (push (car mcons)
  371.                   (system-module-dependants (cdr (assoc m modalist))))
  372.             ))))
  373.     defsys
  374.     ))
  375.  
  376. (defun has-file-type-p (filename)
  377.   (let ((eod (position #+DEC #\] #+(or :LUCID :ALLEGRO) #\/ filename :from-end t))
  378.     (type-dot (position #\. filename :from-end t)))
  379.        (cond
  380.      ((and eod type-dot) (> type-dot eod))
  381.      (t type-dot))))
  382.  
  383. (defun GET-MODULE-FILES (spec modalist defsys-pathname &aux mod sys)
  384.   (cond
  385.     ((stringp spec)
  386.      (cond ((has-file-type-p spec)
  387.         (let ((ftype (pathname-type (pathname spec))))
  388.          (cond ((string-equal ftype #+DEC "LISP" #+(or :LUCID :ALLEGRO) "lisp")
  389.              (list spec))
  390.                ((string-equal ftype "LSP") (list spec))
  391.                (t (Error "File Type must be LISP or LSP - ~a." spec)))))
  392.            (t (let ((temp-path (pathname spec))
  393.             (spec1 (concatenate 'string defsys-pathname spec)))
  394.            (when (or (pathname-device temp-path)
  395.                  (pathname-directory temp-path))
  396.              (setq spec1 spec))
  397.            (let ((lisp-path (probe-file (concatenate 'string
  398.                                  spec1
  399.                                  ".lisp")))
  400.              #|(lsp-path (probe-file (concatenate 'string
  401.                                 spec1
  402.                                 ".lsp")))|#
  403.              )
  404.             (if lisp-path
  405.                 (list (concatenate 'simple-string spec ".lisp"))
  406.                 (list (concatenate 'simple-string spec ".lsp")))
  407.             ))
  408.           )
  409.        )
  410.      )
  411.     ((symbolp spec)
  412.      (if (setq mod (cdr (assoc spec modalist)))
  413.          (system-module-files mod)
  414.          (error "Referenced to UnDefined Module ~a" spec)))
  415.     ((consp spec)
  416.      (cond ((setq sys (get (first spec) 'defsystem))
  417.             (cond
  418.               ((setq mod (cdr (assoc (second spec)
  419.                                      (defsystem-modules-alist sys))))
  420.                (system-module-files mod))
  421.               (t (error "No ~a Module in system ~a" (second spec) (first spec)))))
  422.            (t  (error "Reference to UnDefined System ~a" (first spec)))))))
  423.  
  424. #+DEC
  425. (defun GET-C-MODULE-FILES (spec modalist defsys-pathname &aux mod sys)
  426.   (cond
  427.     ((stringp spec)
  428.      (cond ((has-file-type-p spec)
  429.         (let ((ftype (pathname-type (pathname spec))))
  430.          (cond ((string-equal ftype "C") (list spec))
  431.                ((string-equal ftype "H") (list spec))
  432.                (t (Error "File Type must be C or H - ~a." spec)))))
  433.            (t (let ((temp-path (pathname spec))
  434.             (spec1 (concatenate 'string defsys-pathname spec)))
  435.            (when (or (pathname-device temp-path)
  436.                  (pathname-directory temp-path))
  437.              (setq spec1 spec))
  438.            (let ((c-path (probe-file (concatenate 'string
  439.                                  spec1
  440.                                  ".c")))
  441.              (h-path (probe-file (concatenate 'string
  442.                                 spec1
  443.                                 ".h")))
  444.              )
  445.             (if c-path
  446.                 (list (concatenate 'simple-string spec ".c"))
  447.                 (list (concatenate 'simple-string spec ".h")))
  448.             ))
  449.           )
  450.        )
  451.      )
  452.     ((symbolp spec)
  453.      (if (setq mod (cdr (assoc spec modalist)))
  454.          (system-module-files mod)
  455.          (error "Referenced to UnDefined Module ~a" spec)))
  456.     ((consp spec)
  457.      (cond ((setq sys (get (first spec) 'defsystem))
  458.             (cond
  459.               ((setq mod (cdr (assoc (second spec)
  460.                                      (defsystem-modules-alist sys))))
  461.                (system-module-files mod))
  462.               (t (error "No ~a Module in system ~a" (second spec) (first spec)))))
  463.            (t  (error "Reference to UnDefined System ~a" (first spec)))))))
  464.  
  465. (defvar *Loaded-Modules* nil)
  466.  
  467. (defun LOAD-SYSTEM  (name &KEY (verbose t) (noconfirm nil))
  468.  (let ((defsys (get name 'defsystem))
  469.        (modalist nil)
  470.        (*loaded-modules* nil)
  471.        (pathname nil))
  472.    (when (null defsys)
  473.      (Error "~&~a is not the name of a defined system." name))
  474.    (setq modalist (defsystem-modules-alist defsys))
  475.    ;; do the included system
  476.    (dolist (sys (defsystem-included-systems defsys))
  477.      (load-system sys :VERBOSE verbose :noconfirm noconfirm))
  478.    (setq pathname (pathname (defsystem-pathname defsys)))
  479.    ;; load the modules.
  480.    (dolist (mod modalist)
  481.      (load-module (car mod) modalist pathname verbose noconfirm))))
  482.  
  483. (defun COMPILE-FILE-TRANSFORM (file &rest options)
  484.   (if *print-transforms-only*
  485.        (format t "~&;  (Compile-File ~S~{ ~S~})" (namestring (pathname file))
  486.            options)
  487.        (apply #'compile-file file options))
  488.   )
  489.  
  490. (defmacro LOAD-FILE (path type)
  491.   `(progn
  492.      (let ((true (probe-file (make-pathname :type ,type :defaults ,path))))
  493.        (if *print-transforms-only*
  494.        (format t "~&;  (Load ~S :verbose ~S)" (namestring true) verbose)
  495.        (load true :VERBOSE verbose))
  496.        (push (list file true (file-write-date true)) loaded))))
  497.  
  498. (defun LOAD-MODULE (name modalist path verbose noconfirm)
  499.   (let* ((module (cdr (assoc name modalist)))
  500.          (files (system-module-files module))
  501.          (loaded (system-module-loaded-files module))
  502.          (load  (system-module-load module))
  503.          (compile (or (system-module-compile module) (eq load :FASLOAD)))
  504.          loaddate fpath fas lisp 
  505.      )
  506.     (unless (or (member name *loaded-modules*) (null load))
  507.       (push name *loaded-modules*)
  508.       (when verbose (format t "~%; Loading Module ~a." name))
  509.       ;; make sure dependant modules are loaded.
  510.       (when (listp load)
  511.         (dolist (mod load)
  512.           (load-module mod modalist path verbose noconfirm)))
  513.       (when (eq (system-module-flags module) :c) (return-from load-module name))
  514.       ;; load in the files.
  515.       (let (source-type)
  516.     (dolist (file files)
  517.      (setq fpath (merge-pathnames file path))
  518.      (setf source-type (pathname-type
  519.                  (or (probe-file
  520.                    (merge-pathnames (make-pathname :type "lisp") fpath))
  521.                  (probe-file
  522.                    (merge-pathnames (make-pathname :type "lsp") fpath)))))
  523.      ;; get the dates for what's on disk.
  524.      (setq fas (file-write-date (merge-pathnames (make-pathname
  525.                                :type *compiled-file-extension*)
  526.                              fpath)))
  527.      (setq lisp (file-write-date (merge-pathnames (make-pathname :type source-type)
  528.                               fpath)))
  529.         ;; get if the files already loaded.
  530.         (setq load (assoc file loaded :TEST #'equal))
  531.         (if (cdr load) (setq loaddate (third load))
  532.             (setq loaddate nil))
  533.         ;; find which file to load in.
  534.         (cond
  535.           ;; Already loaded is newest.
  536.           ((and loaddate
  537.                 (>= loaddate (or fas 0))
  538.                 (>= loaddate (or lisp 0))) nil)
  539.           ;; LISP is newest for uncompiled.
  540.           ((and loaddate (not compile) (> lisp loaddate))
  541.            (load-file fpath source-type))
  542.           ;; FAS is newest for compiled.
  543.           ((and loaddate compile fas (> fas loaddate) (> fas (or lisp 0)))
  544.            (load-file fpath *compiled-file-extension*))
  545.           ((and compile (not fas) lisp)
  546.        (if noconfirm
  547.            (load-file fpath source-type)
  548.            (progn
  549.          (format t "~%>> For file ~:@(~a~) In Module ~:@(~a~):~
  550.                 ~%   No Compiled file exists."
  551.                 (pathname-name fpath)
  552.                 name)
  553.          (case (prompt-choose
  554.              "~%Load the Uncompiled File? (?/Y/C/S) : "
  555.              '(#\y #\n #\c #\s)
  556.              "~% Y : Load the Uncompiled File.~
  557.              ~% C : Compile this File, and load it.~
  558.              ~% S : Skip loading this file.")
  559.                (#\Y (load-file fpath source-type))
  560.                (#\C (setf fpath (make-pathname :type source-type
  561.                                :defaults fpath))
  562.                 (compile-file-transform fpath)
  563.                 (load-file fpath *compiled-file-extension*))
  564.                (#\S nil)))))
  565.           ;; FAS file is newest.
  566.           ((and compile fas (> fas (or lisp 0)))
  567.            (load-file fpath *compiled-file-extension*))
  568.           ;; a newer LISP file, but should be compiled.
  569.           ((and compile fas lisp (> lisp fas))
  570.        (if noconfirm
  571.            (load-file fpath source-type)
  572.            (progn
  573.          (format t "~%>> For file ~:@(~a~) In Module ~:@(~a~):~
  574.                 ~%   A newer uncompiled file exists."
  575.                 (pathname-name fpath) name)
  576.          (case (prompt-choose
  577.              "~%Load the Uncompiled File? (?/Y/N/C/S) : "
  578.              '(#\y #\n #\c #\s)
  579.              "~% Y : Load the Uncompiled File.~
  580.              ~% N : Load the Compiled File.~
  581.              ~% C : Compile this File, then Load it.~
  582.              ~% S : Skip loading this File.")
  583.                (#\Y (load-file fpath source-type))
  584.                (#\N (load-file fpath *compiled-file-extension*))
  585.                (#\C (setf fpath (make-pathname :type source-type
  586.                                :defaults fpath))
  587.                 (compile-file-transform fpath)
  588.                 (load-file fpath *compiled-file-extension*))
  589.                (#\S nil)))))
  590.           ;; A lisp file exists.
  591.           (lisp (load-file fpath source-type))
  592.           (t (if noconfirm
  593.          (format t
  594.              "~%>> For File ~:@(~a~) In Module ~:@(~a~):~
  595.              ~%   File Doesn't Exist.~
  596.              ~%The file will be skiped."
  597.              (pathname-name fpath)
  598.              (system-module-name module))
  599.          (CError
  600.            "Skip Loading the File."
  601.            "~%>> For File ~:@(~a~) In Module ~:@(~a~):~
  602.            ~%   File Doesn't Exist."
  603.            (pathname-name fpath)
  604.            (system-module-name module)))))))
  605.       (setf (system-module-loaded-files module) loaded))))
  606.  
  607. (defun LOAD-DEPEND-MODULE (name modalist path verbose noconfirm)
  608.   "LOAD-DEPEND-MODULE name modalist path verbose
  609. Loads in a module as a compile dependancy."
  610.   (let* ((module (cdr (assoc name modalist)))
  611.          (files (system-module-files module))
  612.          (loaded (system-module-loaded-files module))
  613.          (load  (system-module-load module))
  614.          (compile (or (system-module-compile module) (eq load :FASLOAD)))
  615.          fpath fas lisp)
  616.     ;; check if already loaded, or not supposed to be.
  617.     (unless (or (null load)
  618.                 (every #'(lambda(file)
  619.                            (cdr (assoc file loaded :TEST #'equal)))
  620.                        files))
  621.       (when verbose (format t "~%; Loading Module ~a." name))
  622.       ;; make sure dependant modules are loaded.
  623.       (when (listp load)
  624.         (dolist (mod load)
  625.           (load-depend-module mod modalist path verbose noconfirm)))
  626.       ;; load in the files.
  627.       (when (eq (system-module-flags module) :c) 
  628.         (return-from load-depend-module name))
  629.       (let (source-type)
  630.       (dolist (file files)
  631.         (unless (cdr (assoc file loaded :TEST #'equal)) ;; loaded already.
  632.           (setq fpath (merge-pathnames file path))
  633.       (setf source-type (pathname-type
  634.                  (or (probe-file
  635.                    (merge-pathnames (make-pathname :type "lisp") fpath))
  636.                  (probe-file
  637.                    (merge-pathnames (make-pathname :type "lsp") fpath)))))
  638.           ;; get the dates for what's there.
  639.           (setq fas (file-write-date (merge-pathnames (make-pathname 
  640.                             :type *compiled-file-extension*)
  641.                               fpath)))
  642.           (setq lisp (file-write-date (merge-pathnames (make-pathname :type source-type)
  643.                               fpath)))
  644.           ;; find which file to load in.
  645.           (cond ((and fas compile) (load-file fpath *compiled-file-extension*))
  646.                 (lisp (load-file fpath source-type))
  647.                 (t (if noconfirm
  648.                (format t
  649.                    "~%>> For File ~:@(~a~) In Module ~:@(~a~):~
  650.                    ~%   File Doesn't Exist.~
  651.                    ~%The file will be skiped."
  652.                    (pathname-name fpath)
  653.                    (system-module-name module))
  654.                (CError
  655.              "Skip Loading the File."
  656.              "~%>> For File ~:@(~a~) In Module ~:@(~a~):~
  657.              ~%   File Doesn't Exist."
  658.              (pathname-name fpath)
  659.              name)))))))
  660.       (setf (system-module-loaded-files module) loaded))))
  661.  
  662. (defvar *compile-time* nil
  663.         "Indicates the time when the system began to be compiled.")
  664. (defvar *compiling-modules* nil
  665.         "Used to Stop Recursive calls to compile the same module again.")
  666.  
  667.  
  668. (defun COMPILE-SYSTEM (name &KEY (recompile nil)
  669.                                  (verbose t)
  670.                  noconfirm)
  671.   "COMPILE-SYSTEM name &KEY (recompile nil)
  672.                             (verbose t)
  673.                 noconfirm
  674. If recompile is T, all the source files are recompiled if
  675. regardless of the date of the source files.
  676. Otherwise this compiles any modules source files that have
  677. have a newer .lisp version. This will recompile any
  678. modules that depend on the module being compiled."
  679.   
  680.   (let ((defsys (get name 'defsystem))
  681.         (modalist nil) syspath
  682.         (pathname nil) 
  683.         (sysfilename (make-file-name (symbol-name name)))
  684.         (*source-files* nil)
  685.         (*compile-time* (get-universal-time))
  686.     )
  687.      (cond
  688.       ((null defsys) (error  "~&~a is not the name of a defined system." name))
  689.       (t
  690.           ;; compile and load any included systems
  691.           (dolist (sys (defsystem-included-systems defsys))
  692.             (compile-system sys
  693.                             :RECOMPILE recompile
  694.                             :VERBOSE verbose
  695.                 :noconfirm noconfirm)
  696.             (load-system sys :VERBOSE verbose :noconfirm noconfirm))
  697.           ;; create the file directory file.
  698.           (setq pathname (pathname (defsystem-pathname defsys)))
  699.           (setq syspath (make-pathname
  700.                             :HOST nil
  701.                             :NAME sysfilename
  702.                             :TYPE "defsystem"
  703.                 :VERSION :NEWEST
  704.                             :DEFAULTS pathname))
  705.           ;; if a system file exists, get the current system source files.
  706.           (when (probe-file syspath)
  707.             (load syspath)       ;; load it to get the source files.
  708.             (delete-file (truename syspath))) ;; delete the old one.
  709.           ;; Start out with doing none.
  710.           (setq *compiling-modules* nil)
  711.           ;; compile each of the modules.
  712.           (dolist (mcons (setq modalist (defsystem-modules-alist defsys)))
  713.             (compile-module (car mcons) modalist pathname verbose recompile
  714.                 noconfirm))
  715.           ;; create the new file.
  716.           (with-open-file (str syspath :DIRECTION :OUTPUT)
  717.             ;; this is so all the symbols will have their package prefixes.
  718.             (let ((*package* (find-package 'keyword)))
  719.               (format str "~&(setq defsys::*source-files* '(")
  720.               (dolist (x (clean-source-files *source-files*))
  721.                 (format str "~%~s" x))
  722.               (format str "))"))))
  723.       ))
  724.   )
  725.  
  726. (defmacro REMOVE-LOADED-FILE (file)
  727.   `(let ((there (assoc ,file loaded :TEST #'equal)))
  728.      (when (cdr there) (setf (cdr there) nil))))
  729.  
  730. (defun compile-module (name modalist path verbose &OPTIONAL 
  731.                  (recompile-p nil)
  732.                  (noconfirm nil))
  733.   (let* ((module (cdr (assoc name modalist)))
  734.          (flags (system-module-flags module)))
  735.     (if (eq flags :c)
  736.         (compile-c-module name modalist path verbose recompile-p noconfirm)
  737.         (compile-lisp-module name modalist path verbose recompile-p 
  738.                  noconfirm)
  739.         ))
  740.   )
  741.   
  742.  
  743.  
  744. (defun COMPILE-LISP-MODULE (name modalist path verbose &OPTIONAL 
  745.                  (recompile-p nil)
  746.                  (noconfirm nil))
  747.   (let* ((module (cdr (assoc name modalist)))
  748.          (files (system-module-files module))
  749.          (files-to-compile nil)
  750.          (file-path nil)
  751.          (loaded  (system-module-loaded-files module))
  752.          (compile (system-module-compile module)))
  753.     ;; have we already started this one?
  754.     (unless (member name *compiling-modules*)
  755.     ;; do we compile the files?
  756.     (when compile
  757.       (push name *compiling-modules*)
  758.       (when verbose (format t "~%; Compiling Module ~a." name))
  759.       ;; make sure depend-on modules are up to date.
  760.       (when (listp compile)
  761.         ;; remove self if there.
  762.         (dolist (m (remove name compile))
  763.           (compile-module m modalist path verbose recompile-p noconfirm)))
  764.       ;; Determine if we need to compile any of the files.
  765.       (cond
  766.         (recompile-p  ;; forcing them all, see if they still need it.
  767.       (let (source-type fpath)
  768.             (dolist (file files)
  769.           (setf fpath (merge-pathnames file path))
  770.           (setf source-type (pathname-type
  771.                  (or (probe-file
  772.                    (merge-pathnames (make-pathname :type "lisp") fpath))
  773.                  (probe-file
  774.                    (merge-pathnames (make-pathname :type "lsp") fpath)))))
  775.               (setq file-path (make-pathname
  776.                                   :TYPE source-type
  777.                                   :DEFAULTS fpath))
  778.               (cond((recompile-file-p file-path) ;; hasnt been recompiled?
  779.                     (remove-loaded-file file)
  780.                     (push (cons file file-path) files-to-compile))
  781.                    (t (push (cons file (truename file-path))
  782.                             *source-files*))))))
  783.         (t ;; otherwise check them each for needing to be compiled.
  784.       (let (source-type fpath)
  785.             (dolist (file files)
  786.           (setf fpath (merge-pathnames file path))
  787.           (setf source-type (pathname-type
  788.                  (or (probe-file
  789.                    (merge-pathnames (make-pathname :type "lisp") fpath))
  790.                  (probe-file
  791.                    (merge-pathnames (make-pathname :type "lsp") fpath)))))
  792.               (setq file-path (make-pathname
  793.                                   :TYPE source-type
  794.                                   :DEFAULTS fpath))
  795.               (cond
  796.                 ((file-not-compiled-p file-path)
  797.                  (remove-loaded-file file)
  798.                  (push (cons file file-path) files-to-compile))
  799.                 (t (push (cons file (truename file-path)) *source-files*)))))))
  800.       ;; If we have files to compile, then do it.
  801.       (when files-to-compile
  802.         ;; Load any depend-on Modules first.
  803.         (when (listp compile)
  804.           (dolist (m compile)
  805.             (load-depend-module m modalist path verbose noconfirm)))
  806.         ;; Get this to destructively modify.
  807.         (setq loaded (system-module-loaded-files module))
  808.         ;; Compile the files.
  809.         ;; Fpair is a cons. Car is module-file-name and the Cdr the pathname.
  810.         (dolist (fpair files-to-compile)
  811.           ;; compile the file
  812.           (cond ((probe-file (CDR fpair))
  813.                  (compile-file-transform (CDR fpair) 
  814.           #-(or :LUCID :ALLEGRO) :VERBOSE #-(or :LUCID :ALLEGRO) verbose))
  815.                 (t (Error "File doesn't exist ~a" (CDR fpair))))
  816.           ;; Kill any previously loaded file
  817.           (remove-loaded-file (CAR fpair))
  818.           ;; update the source file table.
  819.           (push (cons (CAR fpair) (truename (CDR fpair))) *source-files*)))
  820.       )
  821.     ;; Force Recompilation for any dependant modules if we have newer files
  822.     (when (or files-to-compile (newer-module-files-p module))
  823.       (dolist (m (system-module-dependants module))
  824.         (compile-module m modalist path verbose t noconfirm)))
  825.     ))
  826.  )
  827.  
  828. #+DEC
  829. (defun COMPILE-C-MODULE (name modalist path verbose &OPTIONAL 
  830.                  (recompile-p nil)
  831.                  (noconfirm nil))
  832.   (let* ((module (cdr (assoc name modalist)))
  833.          (files (system-module-files module))
  834.      (h-files nil)
  835.          (files-to-compile nil)
  836.          (file-path nil)
  837.          (compile (system-module-compile module)))
  838.     ;; have we already started this one?
  839.     (unless (member name *compiling-modules*)
  840.     ;; do we compile the files?
  841.     (when compile
  842.       (push name *compiling-modules*)
  843.       (when verbose (format t "~%; Compiling Module ~a." name))
  844.       ;; make sure depend-on modules are up to date.
  845.       (when (listp compile)
  846.         ;; remove self if there.
  847.         (dolist (m (remove name compile))
  848.           (compile-module m modalist path verbose recompile-p noconfirm))
  849.     )
  850.       ;; Determine if we need to compile any of the files.
  851.       (cond
  852.         (recompile-p  ;; forcing them all, see if they still need it.
  853.       (let (source-type fpath)
  854.             (dolist (file files)
  855.           (setf fpath (merge-pathnames file path))
  856.           (setf source-type (pathname-type
  857.                  (or (probe-file
  858.                    (merge-pathnames (make-pathname :type "c") fpath))
  859.                  (probe-file
  860.                    (merge-pathnames (make-pathname :type "h") fpath)))))
  861.               (setq file-path (make-pathname
  862.                                   :TYPE source-type
  863.                                   :DEFAULTS fpath))
  864.               (cond((string= source-type "H")
  865.             (let* ((true-h-name (truename file-path))
  866.                (mod-h-name (file-write-date true-h-name)))
  867.               (push (list file true-h-name mod-h-name)
  868.                 h-files)
  869.               (push (cons file true-h-name) *source-files*))
  870.             )           
  871.            ((recompile-c-file-p file-path) ;; hasnt been recompiled?
  872.                     (push (cons file file-path) files-to-compile))
  873.                    (t (push (cons file (truename file-path))
  874.                             *source-files*))))))
  875.         (t ;; otherwise check them each for needing to be compiled.
  876.       (let (source-type fpath)
  877.             (dolist (file files)
  878.           (setf fpath (merge-pathnames file path))
  879.           (setf source-type (pathname-type
  880.                  (or (probe-file
  881.                    (merge-pathnames (make-pathname :type "c") fpath))
  882.                  (probe-file
  883.                    (merge-pathnames (make-pathname :type "h") fpath)))))
  884.               (setq file-path (make-pathname
  885.                                   :TYPE source-type
  886.                                   :DEFAULTS fpath))
  887.               (cond
  888.         ((string= source-type "H")
  889.          (let* ((true-h-name (truename file-path))
  890.             (mod-h-name (file-write-date true-h-name)))
  891.                (push (list file true-h-name mod-h-name)
  892.                  h-files)
  893.                (push (cons file true-h-name) *source-files*))
  894.          )
  895.         ((c-file-not-compiled-p file-path h-files)
  896.                  (push (cons file file-path) files-to-compile))
  897.                 (t (push (cons file (truename file-path)) *source-files*)))))))
  898.       ;; If we have files to compile, then do it.
  899.       (when files-to-compile
  900.         ;; Load any depend-on Modules first.
  901.         (when (listp compile)
  902.           (dolist (m compile)
  903.             (load-depend-module m modalist path verbose noconfirm)))
  904.         ;; Compile the files.
  905.         ;; Fpair is a cons. Car is module-file-name and the Cdr the pathname.
  906.         (dolist (fpair files-to-compile)
  907.           ;; compile the file
  908.           (cond ((probe-file (CDR fpair))
  909.                  (c-compile-file-transform (CDR fpair) :VERBOSE verbose))
  910.                 (t (Error "File doesn't exist ~a" (CDR fpair))))
  911.           ;; update the source file table.
  912.           (push (cons (CAR fpair) (truename (CDR fpair))) *source-files*)))
  913.       (when files-to-compile
  914.         (link-c-module-transform (system-module-load module)
  915.                      verbose
  916.                      noconfirm)))
  917.     ;; Force Recompilation for any dependant modules if we have newer files
  918.     (when (or files-to-compile (newer-module-files-p module))
  919.       (dolist (m (system-module-dependants module))
  920.         (compile-module m modalist path verbose t noconfirm)))
  921.     ))
  922.  )
  923.  
  924. #+DEC
  925. (defun c-COMPILE-FILE-TRANSFORM (file &rest options)
  926.   (if *print-transforms-only*
  927.        (format t "~&;  (C-Compile-File ~S~{ ~S~})" (namestring (pathname file))
  928.            options)
  929.        (apply #'c-compile-file file options))
  930.   )
  931.  
  932. #+DEC
  933. (defun link-c-module-TRANSFORM (file &rest options)
  934.   (if *print-transforms-only*
  935.        (format t "~&;  (link-c-module ~S~{ ~S~})" (namestring (pathname file))
  936.            options)
  937.        (apply #'link-c-module file options))
  938.   )
  939.  
  940.  
  941. (defun NEWER-MODULE-FILES-P (module &AUX thisone)
  942.   ;; check each file.
  943.   (dolist (file (system-module-files module))
  944.     ;; Get the latest file known about.
  945.     (setq thisone (cdr (assoc file *source-files* :TEST #'equal)))
  946.     (cond ((null thisone) ;; not there, assume newer
  947.            (return-from newer-module-files-p t))
  948.           ;; See if this isn't the newest
  949.           ((null (equal (truename thisone)
  950.                         (truename (make-pathname
  951.                                       :VERSION :NEWEST
  952.                                       :DEFAULTS thisone))))
  953.            (return-from newer-module-files-p t))))
  954.   nil)         
  955.  
  956. #+DEC
  957. (defun RECOMPILE-C-FILE-P (file-path &aux source-type)
  958.   ;; Returns a pair of file and pathname if it hasn't already
  959.   ;; been recompiled in this invocation of compile-system.
  960.   (setf source-type (pathname-type file-path))
  961.   (setf (pathname-type file-path) "OBJ") ;; change it to a OBJ.
  962.   (let* ((date (file-write-date file-path)))
  963.     ;; check if it has already been recompiled.
  964.     (cond ((and date (> date *compile-time*))
  965.            (setf (pathname-type file-path) source-type) ;; change it back
  966.            nil)
  967.           (t  (setf (pathname-type file-path) source-type) ;; change it back.
  968.               t))))
  969.  
  970. (defun RECOMPILE-FILE-P (file-path &aux source-type)
  971.   ;; Returns a pair of file and pathname if it hasn't already
  972.   ;; been recompiled in this invocation of compile-system.
  973.   (setf source-type (pathname-type file-path))
  974.   (setf file-path (make-pathname :type *compiled-file-extension*
  975.                  :defaults file-path))
  976.   (let* ((date (file-write-date file-path)))
  977.     ;; check if it has already been recompiled.
  978.     (cond ((and date (> date *compile-time*))
  979.            nil)
  980.           (t  
  981.               t))))
  982.  
  983. (defun FILE-NOT-COMPILED-P (pathname)
  984.   ;; This takes a .lisp pathname and returns t if it needs to be compiled.
  985.   ;; get the write dates for the files. (if they exists).
  986.   (let ((fasdate (file-write-date
  987.                      (make-pathname :TYPE *compiled-file-extension*
  988.                     :DEFAULTS pathname)))
  989.         (lispdate (file-write-date pathname)))
  990.     (cond
  991.       ((and fasdate lispdate) ;;  they both exists, check dates
  992.        (> lispdate fasdate))
  993.       ((and fasdate (null lispdate)) ;; No lisp, but a FAS.
  994.        nil)
  995.       (lispdate t)
  996.       (t (error "File Doesn't exist - ~a." pathname)))))
  997.  
  998. #+DEC
  999. (defun C-FILE-NOT-COMPILED-P (pathname h-files)
  1000.   ;; This takes a .c pathname and returns t if it needs to be compiled.
  1001.   ;; get the write dates for the files. (if they exists).
  1002.   (let ((objdate (file-write-date
  1003.                      (make-pathname :TYPE "OBJ" :DEFAULTS pathname)))
  1004.         (cdate (when (probe-file pathname)
  1005.              (max (file-write-date pathname)
  1006.               (max-h-file-write-date h-files)))))
  1007.     (cond
  1008.       ((and objdate cdate) ;;  they both exists, check dates
  1009.        (> cdate objdate))
  1010.       ((and objdate (null cdate)) ;; No c, but a OBJ.
  1011.        nil)
  1012.       (cdate t)
  1013.       (t (error "File Doesn't exist - ~a." pathname)))))
  1014.  
  1015. #+DEC
  1016. (defun max-h-file-write-date (h-files)
  1017.   (do ((h-ptr h-files (rest h-ptr))
  1018.        (max-date 0))
  1019.       ((endp h-ptr) max-date)
  1020.       (setf max-date (max max-date (or (third (first h-ptr)) 0)))
  1021.       )
  1022.   )
  1023.  
  1024. (defun CLEAN-SOURCE-FILES (alist)
  1025.   (when (consp alist)
  1026.     (do ((al alist (cdr al))
  1027.          (pair (car alist) (car al))
  1028.          (newlist nil) (old nil))
  1029.         ((null pair) newlist)
  1030.       (unless (member (car pair) old)
  1031.         (push pair newlist)
  1032.         (push (car pair) old)))))
  1033.  
  1034.  
  1035. (defun MAKE-FILE-NAME (str)
  1036.   (declare (simple-string str name))
  1037.   (let* ((len (length str))
  1038.          (name (make-string (min 20 len)
  1039.                             :INITIAL-ELEMENT #\space))
  1040.          (pos 0))
  1041.     (dotimes (x len)
  1042.       (when (alphanumericp (schar str x))
  1043.         (setf (schar name pos) (schar str x))
  1044.         (incf pos)))
  1045.     (string-right-trim '(#\space) name)))
  1046.  
  1047. ;;;;;
  1048. ;;; This function is *slightly* VMS dependent - the use of the extension
  1049. ;;; ".COM" for command procedures is a VMSism.
  1050. ;;;;;
  1051.  
  1052.  
  1053. #+DEC
  1054. (defun get-link-com-file-name (filename def-pathname)
  1055.   (cond ((has-file-type-p filename)
  1056.      (if (string-equal (pathname-type (pathname filename))
  1057.                "COM")
  1058.          (let ((temp-path (pathname filename)))
  1059.           (cond ((and (or (pathname-device temp-path)
  1060.                        (pathname-directory temp-path))
  1061.                   (probe-file filename)) filename)
  1062.             ((and (not (or (pathname-device temp-path)
  1063.                        (pathname-directory temp-path)))
  1064.                   (probe-file (setf filename
  1065.                         (concatenate
  1066.                           'string def-pathname
  1067.                           filename))))
  1068.              filename)
  1069.             (t (Error "File not found - ~A." filename))))
  1070.          (Error "File Type must be COM - ~A." filename)))
  1071.     (t (let ((temp-path (pathname filename))
  1072.          (file1 (concatenate 'string def-pathname filename)))
  1073.         (when (or (pathname-device temp-path)
  1074.               (pathname-directory temp-path))
  1075.               (setf file1 filename))
  1076.         (setf file1 (concatenate 'string file1 ".COM"))
  1077.         (if (probe-file file1)
  1078.             file1
  1079.             (Error "File not found - ~A." file1))
  1080.         )
  1081.        )
  1082.     )
  1083.   )
  1084.  
  1085. ;;;;===========================================================================
  1086. ;;;
  1087. ;;; All of the following code is VMS dependent - use of VMS system services
  1088. ;;; and RTL routines.
  1089. ;;;
  1090. ;;;;===========================================================================
  1091.  
  1092. ;;;; first two system services: SYS$CREMBX (Create Mailbox) and SYS$DASSGN 
  1093. ;;;; (Deassign channel).
  1094.  
  1095. #+DEC
  1096. (eval-when (load eval compile)
  1097.    (define-external-routine (SYS$CREMBX :check-status-return t)
  1098.     (prmflg :access :in :mechanism :immediate :vax-type :longword 
  1099.         :lisp-type integer)
  1100.     (chan   :access :in-out :mechanism :reference :vax-type :word
  1101.         :lisp-type (unsigned-byte 16))
  1102.     (maxmsg :access :in :mechanism :immediate :vax-type :longword 
  1103.         :lisp-type integer)
  1104.     (bufquo :access :in :mechanism :immediate :vax-type :longword 
  1105.         :lisp-type integer)
  1106.     (promsk :access :in :mechanism :immediate :vax-type :longword 
  1107.         :lisp-type integer)
  1108.     (acmode :access :in :mechanism :immediate :vax-type :longword 
  1109.         :lisp-type integer)
  1110.     (lognam :access :in :mechanism :descriptor :vax-type :text 
  1111.         :lisp-type string)
  1112.     )
  1113.    (define-external-routine (SYS$DASSGN :check-status-return t)
  1114.     (chan   :access :in :mechanism :immediate :vax-type :longword 
  1115.         :lisp-type integer)
  1116.     )
  1117.    )
  1118.  
  1119. #+DEC
  1120. (defun $CREMBX (&key (prmflg 0) (maxmsg 0) (bufquo 0) (promsk 0) (acmode 0)
  1121.              (lognam "") &aux (chan 0))
  1122.   (call-out sys$crembx prmflg chan maxmsg bufquo promsk acmode lognam)
  1123.   chan)
  1124.  
  1125. #+DEC
  1126. (defun $DASSGN (chan)
  1127.   (call-out sys$dassgn chan)
  1128.   t)
  1129.  
  1130. #+DEC
  1131. (defconstant MBX-MAXMSG 256)
  1132. #+DEC
  1133. (defconstant MBX-BUFQUO 1024)
  1134.  
  1135.  
  1136. #+DEC
  1137. (defun c-compile-file (file-pathname &rest ignore)
  1138.   (declare (ignore ignore))
  1139.   (let* ((file-path (pathname file-pathname))
  1140.      (file-name (string (pathname-name file-path)))
  1141.      (obj-path (make-pathname :TYPE "OBJ" :defaults file-path))
  1142.      (mailbox-name (string (gensym (concatenate 'string
  1143.                             "C_COMPILE_"
  1144.                             file-name))))
  1145.      (mailbox-channel ($CREMBX :LOGNAM mailbox-name :MAXMSG MBX-MAXMSG
  1146.                    :BUFQUO MBX-BUFQUO))
  1147.      )
  1148.     (with-open-file (sub-process-output mailbox-name :direction :input)
  1149.           ($DASSGN mailbox-channel)
  1150.           (SPAWN :COMMAND-STRING (concatenate
  1151.                        'string
  1152.                        "CC "
  1153.                        (namestring file-path)
  1154.                        " /NOLIST /OBJECT="
  1155.                        (namestring obj-path))
  1156.              :DCL-SYMBOLS nil
  1157.              :INPUT-FILE "NLA0:"
  1158.              :OUTPUT-FILE mailbox-name
  1159.              :PARALLEL t
  1160.              )
  1161.           (do ((line (read-line sub-process-output nil :EOF)
  1162.              (read-line sub-process-output nil :EOF)))
  1163.           ((eq line :EOF) t)
  1164.           (write-line line))
  1165.           )
  1166.     (when (probe-file obj-path)
  1167.           (namestring (truename obj-path)))
  1168.     )
  1169.   )
  1170.  
  1171. #+DEC
  1172. (defun link-c-module (file-pathname &rest ignore)
  1173.   (declare (ignore ignore))
  1174.   (let* ((file-path (pathname file-pathname))
  1175.      (file-name (string (pathname-name file-path)))
  1176.      (mailbox-name (string (gensym (concatenate 'string
  1177.                             "C_LINK_"
  1178.                             file-name))))
  1179.      (mailbox-channel ($CREMBX :LOGNAM mailbox-name :MAXMSG MBX-MAXMSG
  1180.                    :BUFQUO MBX-BUFQUO))
  1181.      )
  1182.     (with-open-file (sub-process-output mailbox-name :direction :input)
  1183.           ($DASSGN mailbox-channel)
  1184.           (SPAWN :COMMAND-STRING (concatenate 'string
  1185.                           "@"
  1186.                           (namestring file-name))
  1187.              :DCL-SYMBOLS nil
  1188.              :INPUT-FILE "NLA0:"
  1189.              :OUTPUT-FILE mailbox-name
  1190.              :PARALLEL t
  1191.              )
  1192.           (do ((line (read-line sub-process-output nil :EOF)
  1193.              (read-line sub-process-output nil :EOF)))
  1194.           ((eq line :EOF) t)
  1195.           (write-line line))
  1196.           )
  1197.     )
  1198.   t)
  1199.                        
  1200.  
  1201.  
  1202.  
  1203. ;;; ***************************************************************************
  1204. ;;; EOF
  1205.