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
/
ascendMar8.tar
/
UMass
/
Epipolar
/
lucid-defsystem.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1995-07-20
|
44KB
|
1,205 lines
;;;; -*-lisp-mode-*-
;;;; -*- Mode:Common-Lisp; Package:defsys; Base:10; Fonts:(hl12fb) -*-
;;;; *-* File: VAX6:DIS$DISK:[CERLISP]DEFSYSTEM.LISP *-*
;;;; *-* Last-Edit: Tuesday, July 8, 1986 16:49:22; Edited-By: CORK *-*
;;;; *-* Machine: Caliban Explorer, Microcode 253 D0; Software: Zetalisp System 2.11 *-*
;;;; *-* Lisp: Zetalisp System 2.11 (0.0) *-*
;;;; **************************************************************************
;;;; **************************************************************************
;;;; *
;;;; * SIMPLE DEFSYSTEM
;;;; *
;;;; **************************************************************************
;;;; **************************************************************************
;;;
;;; Written by: Kelly Murray
;;; Department of Computer and Information Science
;;; University of Massachusetts
;;; Amherst, Massachusetts 01003.
;;;
;;; This code was written as part of general Extended Common Lisp support at
;;; the Department of Computer and Information Science (COINS), University of
;;; Massachusetts, Amherst, Massachusetts, 01003.
;;;
;;; Copyright (c) 1985, COINS. All rights are reserved.
;;;
;;; Development of this code was partially supported by:
;;; NSF CER grant DCR-8500332;
;;; NSF maintenance grant DCR-8318776;
;;; NSF CDPS grant MCS-8318776;
;;; ONR CDPS contract NR049-041.
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;; 10/23/85 File Created. (MURRAY)
;;; Tue Apr 28 1987 modified to handle file of type .lsp (RPH)
;;; Tue Apr 30 1987 modified to handle additional options and keywords:
;;; :warning-pathname-default (defsystem option - define pathname
;;; for compiler warnings)
;;; :defaulted-batch & :batch (uses warnings output file and does
;;; :noconfirm)
;;; :noconfirm (answer yes to all questions)
;;; :print-only - only print transformations, don't do them
;;; :noload - don't load system (used with :compile or :recomple)
;;;
;;; Mon Feb 27 1995 added *compiled-file-extension* parameter --Bob Collins
;;; Wed Mar 1 1995 allow pathname default specification to be a symbol
;;; which evaluates to a string --Bob Collins
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
(eval-when (load eval compile)
(unless (find-package "DEFSYS")
(make-package "DEFSYS")))
(in-package "DEFSYS")
#-:ALLEGRO
(provide 'user::defsys)
#+(or TI :ALLEGRO)
(shadow '(defsystem compile-system load-system make-system))
#-TI
(export '(defsystem make-system compile-system load-system prompt-choose))
;;; ***************************************************************************
(defparameter *compiled-file-extension*
#+DEC "FAS"
#+(and :LUCID :MIPS :DBCS) "mbin5"
#+(and :LUCID :MIPS) "mbin"
#+(and :LUCID :SPARC :DBCS) "dsbin"
#+(and :LUCID :SPARC) "sbin"
#+:ALLEGRO "fasl")
(defvar *print-transforms-only* nil
"Set if transforms are only to be printed, not done (used for debugging defsystems).")
(defun make-system (sys &rest options)
(let* ((verbose (not (intersection '(:silent :batch :defaulted-batch)
options)))
(batch-file (when (intersection '(:batch :defaulted-batch) options)
(let* ((def-warn-path (get-warnings-pathname sys))
(bf (if (member :defaulted-batch options)
def-warn-path
(ask-for-string-or-default
"Warnings file"
def-warn-path))))
(unless (eq bf 'T) bf))
))
(*standard-output* (if batch-file
(open batch-file :direction :output
:if-exists :new-version)
*standard-output*))
(*error-output* *standard-output*)
(noconfirm (intersection '(:batch :defaulted-batch :noconfirm)
options))
(*print-transforms-only* (member :print-only options))
)
(unwind-protect
(progn
;; Do we compile first?
(cond
((member :compile options)
(compile-system sys :verbose verbose :noconfirm noconfirm))
((member :recompile options)
(compile-system sys :recompile t :verbose verbose
:noconfirm noconfirm)))
;; Load it unless :noload specified
(unless (member :noload options)
(load-system sys :verbose verbose :noconfirm noconfirm)))
(when batch-file (close *standard-output*))
)
)
sys)
#+DEC
(defun PROMPT-CHOOSE (prompt keys &optional help)
"PROMPT-CHOOSE prompt keys &optional help
This will use prompt to prompt for one of keys. If one of
keys is entered, the upper case character is returned. If
a ? is entered, help is printed if given, otherwise the
list of keys is displayed, and the user is re-prompted."
(let ((mode (get-terminal-modes))
(key))
(set-terminal-modes :pass-through t)
(unwind-protect
(do () (())
(format t prompt)
(setq key (read-char))
(cond ((char= key #\^C)
(throw sys::*top-level-catcher* t))
((member key keys :TEST #'char-equal)
(return (char-upcase key)))
((char= key #\?)
(if help (format t help)
(format t "~%Sorry No Help Available.~
~%Please Enter one of: ~{~C ~}" keys)))
(t (format t "~%Please Enter one of: ~{~C ~}" keys))))
(apply #'set-terminal-modes mode))))
#+(or :LUCID :ALLEGRO)
(defun PROMPT-CHOOSE (prompt keys &optional help)
"PROMPT-CHOOSE prompt keys &optional help
This will use prompt to prompt for one of keys. If one of
keys is entered, the upper case character is returned. If
a ? is entered, help is printed if given, otherwise the
list of keys is displayed, and the user is re-prompted."
(let ((key nil))
(do () (())
(format t prompt)
(setq key (aref (read-line) 0))
(cond ((member key keys :TEST #'char-equal)
(return (char-upcase key)))
((char= key #\?)
(if help (format t help)
(format t "~%Sorry No Help Available.~
~%Please Enter one of: ~{~C ~}" keys)))
(t (format t "~%Please Enter one of: ~{~C ~}" keys))))
)
)
(defun ask-for-string-or-default (prompt default)
(let (ans)
(format *query-io* "~%~A (~A)? " prompt default)
(setf ans (read-line *query-io*))
(if (string= ans "") default ans)))
(defparameter *source-files* nil
"Bound to a list of the source files that make up the current system.")
(defstruct (defsystem #-:LUCID :NAMED (:CONC-NAME defsystem-))
(name "")
(pathname "")
(package)
(short-name)
(included-systems)
(warnings-pathname)
(modules-alist))
(defstruct (system-module #-:LUCID :NAMED (:CONC-NAME system-module-))
(name nil)
(files nil)
(loaded-files nil)
(compile nil)
(load nil)
(dependants nil)
(self-dependant-p nil)
(flags nil)
)
(defun get-warnings-pathname (sysname)
(let ((defsys (get sysname 'defsystem)))
(if defsys
(defsystem-warnings-pathname defsys)
(Error "~S is not a defined system!" sysname)))
)
(defmacro DEFSYSTEM (name &REST options)
(let ((defsys (create-defsystem name options)))
`(let* ((sys ',defsys))
;; create the package if not already.
(let ((*package* *package*))
(when (defsystem-package sys)
(unless (find-package (car (defsystem-package sys)))
(apply #'make-package (defsystem-package sys)))))
;; put the system on it's property list.
(setf (get ',name 'defsystem) sys)
sys)))
(defun CREATE-DEFSYSTEM (name options)
(let ((defsys (make-defsystem :warnings-pathname
#+DEC
(concatenate 'string
"SYS$LOGIN:"
(make-file-name
(string name))
".LOG")
#+:LUCID
(concatenate 'string
(environment-variable "HOME")
"/"
(make-file-name (string name))
".log")
#+:ALLEGRO
(concatenate 'string
(system::getenv "HOME")
"/"
(make-file-name (string name))
".log")
))
(modalist nil)
(pkg '(user))
mod dep modname deps)
(dolist (opt options)
(case (first opt)
(:NAME (setf (defsystem-name defsys) (second opt)))
(:PATHNAME-DEFAULT (setf (defsystem-pathname defsys)
(eval (second opt)))) ;;Bob Collins, 3/1/95
(:warnings-pathname-default
(setf (defsystem-warnings-pathname defsys) (second opt)))
(:PACKAGE (if (atom (second opt))
(setq pkg (list (second opt)))
(setq pkg (second opt))))
(:SHORT-NAME (setf (defsystem-short-name defsys) (second opt)))
(:COMPONENT-SYSTEMS (setf (defsystem-included-systems defsys)
(second opt)))
(:MODULE
;; create the module.
(push (cons (setq modname (second opt))
(setq mod (make-system-module))) modalist)
(setf (system-module-name mod) modname)
(let ((files (if (consp (third opt))
(third opt)
(list (third opt))
)))
;; set the files.
(setf (system-module-files mod)
(mapcan #'(lambda(spec)
(get-module-files
spec modalist
(if (defsystem-pathname defsys)
(defsystem-pathname
defsys)
"")
))
files)))
)
#+DEC
(:C-MODULE
;; create the C module.
(push (cons (setq modname (second opt))
(setq mod (make-system-module :flags :c))) modalist)
(setf (system-module-name mod) modname)
(let ((files (if (consp (third opt))
(third opt)
(list (third opt))
)))
;; set the files.
(setf (system-module-files mod)
(mapcan #'(lambda(spec)
(get-c-module-files
spec modalist
(if (defsystem-pathname defsys)
(defsystem-pathname
defsys)
"")
))
files))
)
(setf (system-module-load mod)
(get-link-com-file-name (string
(or
(fourth opt)
modname))
(if (defsystem-pathname defsys)
(defsystem-pathname
defsys)
"")))
)
((:FASLOAD :READFILE)
(cond
((Null (setq mod (cdr (assoc (second opt) modalist))))
(error "Module ~a Isn't Defined." (second opt)))
(t (setf (system-module-load mod) (first opt))
(when (setq dep (third opt))
(ecase (first dep)
((:FASLOAD :READFILE :COMPILE)
(setf (system-module-load mod) (cdr dep)))))
)))
(:COMPILE
(cond
((Null (setq mod (cdr (assoc (second opt) modalist))))
(error "Module ~a Isn't Defined." (second opt)))
((eq (system-module-flags mod) :c)
(setf (system-module-compile mod) t)
(when (setq dep (third opt))
(setf (system-module-compile mod) dep))
)
(t (setf (system-module-compile mod) t)
(when (setq dep (third opt))
(ecase (first dep)
((:FASLOAD :READFILE :COMPILE)
(setf (system-module-compile mod) (cdr dep))))))))
(:COMPILE-LOAD
(cond
((Null (setq mod (cdr (assoc (second opt) modalist))))
(error "Module ~a Isn't Defined." (second opt)))
((eq (system-module-flags mod) :c)
(setf (system-module-compile mod) t)
(when (setq dep (third opt))
(setf (system-module-compile mod) dep))
)
(t (setf (system-module-compile mod) t)
(setf (system-module-load mod) t)
(when (setq dep (third opt))
(ecase (first dep)
((:FASLOAD :READFILE)
(setf (system-module-compile mod) (cdr dep))
(setf (system-module-load mod)
(or (remove (second opt) (cdr dep)) t))
(setf (system-module-self-dependant-p mod)
(member name (cdr dep))))
)))))
(otherwise (format t "~%Unsupported Defsystem Option - ~a"
(first opt)))))
(setf (defsystem-package defsys) pkg)
(unless (defsystem-short-name defsys)
(setf (defsystem-short-name defsys)
(defsystem-name defsys)))
(setf (defsystem-modules-alist defsys)
(setq modalist (nreverse modalist)))
;; Record reverse compile dependancies
(dolist (mcons modalist)
;; when we have some.
(when (and (setq deps (system-module-compile (cdr mcons)))
(listp deps))
;; record the backward link.
(dolist (m deps)
;; unless the same as itself.
(unless (eq m (system-module-name (cdr mcons)))
;; add this one.
(push (car mcons)
(system-module-dependants (cdr (assoc m modalist))))
))))
defsys
))
(defun has-file-type-p (filename)
(let ((eod (position #+DEC #\] #+(or :LUCID :ALLEGRO) #\/ filename :from-end t))
(type-dot (position #\. filename :from-end t)))
(cond
((and eod type-dot) (> type-dot eod))
(t type-dot))))
(defun GET-MODULE-FILES (spec modalist defsys-pathname &aux mod sys)
(cond
((stringp spec)
(cond ((has-file-type-p spec)
(let ((ftype (pathname-type (pathname spec))))
(cond ((string-equal ftype #+DEC "LISP" #+(or :LUCID :ALLEGRO) "lisp")
(list spec))
((string-equal ftype "LSP") (list spec))
(t (Error "File Type must be LISP or LSP - ~a." spec)))))
(t (let ((temp-path (pathname spec))
(spec1 (concatenate 'string defsys-pathname spec)))
(when (or (pathname-device temp-path)
(pathname-directory temp-path))
(setq spec1 spec))
(let ((lisp-path (probe-file (concatenate 'string
spec1
".lisp")))
#|(lsp-path (probe-file (concatenate 'string
spec1
".lsp")))|#
)
(if lisp-path
(list (concatenate 'simple-string spec ".lisp"))
(list (concatenate 'simple-string spec ".lsp")))
))
)
)
)
((symbolp spec)
(if (setq mod (cdr (assoc spec modalist)))
(system-module-files mod)
(error "Referenced to UnDefined Module ~a" spec)))
((consp spec)
(cond ((setq sys (get (first spec) 'defsystem))
(cond
((setq mod (cdr (assoc (second spec)
(defsystem-modules-alist sys))))
(system-module-files mod))
(t (error "No ~a Module in system ~a" (second spec) (first spec)))))
(t (error "Reference to UnDefined System ~a" (first spec)))))))
#+DEC
(defun GET-C-MODULE-FILES (spec modalist defsys-pathname &aux mod sys)
(cond
((stringp spec)
(cond ((has-file-type-p spec)
(let ((ftype (pathname-type (pathname spec))))
(cond ((string-equal ftype "C") (list spec))
((string-equal ftype "H") (list spec))
(t (Error "File Type must be C or H - ~a." spec)))))
(t (let ((temp-path (pathname spec))
(spec1 (concatenate 'string defsys-pathname spec)))
(when (or (pathname-device temp-path)
(pathname-directory temp-path))
(setq spec1 spec))
(let ((c-path (probe-file (concatenate 'string
spec1
".c")))
(h-path (probe-file (concatenate 'string
spec1
".h")))
)
(if c-path
(list (concatenate 'simple-string spec ".c"))
(list (concatenate 'simple-string spec ".h")))
))
)
)
)
((symbolp spec)
(if (setq mod (cdr (assoc spec modalist)))
(system-module-files mod)
(error "Referenced to UnDefined Module ~a" spec)))
((consp spec)
(cond ((setq sys (get (first spec) 'defsystem))
(cond
((setq mod (cdr (assoc (second spec)
(defsystem-modules-alist sys))))
(system-module-files mod))
(t (error "No ~a Module in system ~a" (second spec) (first spec)))))
(t (error "Reference to UnDefined System ~a" (first spec)))))))
(defvar *Loaded-Modules* nil)
(defun LOAD-SYSTEM (name &KEY (verbose t) (noconfirm nil))
(let ((defsys (get name 'defsystem))
(modalist nil)
(*loaded-modules* nil)
(pathname nil))
(when (null defsys)
(Error "~&~a is not the name of a defined system." name))
(setq modalist (defsystem-modules-alist defsys))
;; do the included system
(dolist (sys (defsystem-included-systems defsys))
(load-system sys :VERBOSE verbose :noconfirm noconfirm))
(setq pathname (pathname (defsystem-pathname defsys)))
;; load the modules.
(dolist (mod modalist)
(load-module (car mod) modalist pathname verbose noconfirm))))
(defun COMPILE-FILE-TRANSFORM (file &rest options)
(if *print-transforms-only*
(format t "~&; (Compile-File ~S~{ ~S~})" (namestring (pathname file))
options)
(apply #'compile-file file options))
)
(defmacro LOAD-FILE (path type)
`(progn
(let ((true (probe-file (make-pathname :type ,type :defaults ,path))))
(if *print-transforms-only*
(format t "~&; (Load ~S :verbose ~S)" (namestring true) verbose)
(load true :VERBOSE verbose))
(push (list file true (file-write-date true)) loaded))))
(defun LOAD-MODULE (name modalist path verbose noconfirm)
(let* ((module (cdr (assoc name modalist)))
(files (system-module-files module))
(loaded (system-module-loaded-files module))
(load (system-module-load module))
(compile (or (system-module-compile module) (eq load :FASLOAD)))
loaddate fpath fas lisp
)
(unless (or (member name *loaded-modules*) (null load))
(push name *loaded-modules*)
(when verbose (format t "~%; Loading Module ~a." name))
;; make sure dependant modules are loaded.
(when (listp load)
(dolist (mod load)
(load-module mod modalist path verbose noconfirm)))
(when (eq (system-module-flags module) :c) (return-from load-module name))
;; load in the files.
(let (source-type)
(dolist (file files)
(setq fpath (merge-pathnames file path))
(setf source-type (pathname-type
(or (probe-file
(merge-pathnames (make-pathname :type "lisp") fpath))
(probe-file
(merge-pathnames (make-pathname :type "lsp") fpath)))))
;; get the dates for what's on disk.
(setq fas (file-write-date (merge-pathnames (make-pathname
:type *compiled-file-extension*)
fpath)))
(setq lisp (file-write-date (merge-pathnames (make-pathname :type source-type)
fpath)))
;; get if the files already loaded.
(setq load (assoc file loaded :TEST #'equal))
(if (cdr load) (setq loaddate (third load))
(setq loaddate nil))
;; find which file to load in.
(cond
;; Already loaded is newest.
((and loaddate
(>= loaddate (or fas 0))
(>= loaddate (or lisp 0))) nil)
;; LISP is newest for uncompiled.
((and loaddate (not compile) (> lisp loaddate))
(load-file fpath source-type))
;; FAS is newest for compiled.
((and loaddate compile fas (> fas loaddate) (> fas (or lisp 0)))
(load-file fpath *compiled-file-extension*))
((and compile (not fas) lisp)
(if noconfirm
(load-file fpath source-type)
(progn
(format t "~%>> For file ~:@(~a~) In Module ~:@(~a~):~
~% No Compiled file exists."
(pathname-name fpath)
name)
(case (prompt-choose
"~%Load the Uncompiled File? (?/Y/C/S) : "
'(#\y #\n #\c #\s)
"~% Y : Load the Uncompiled File.~
~% C : Compile this File, and load it.~
~% S : Skip loading this file.")
(#\Y (load-file fpath source-type))
(#\C (setf fpath (make-pathname :type source-type
:defaults fpath))
(compile-file-transform fpath)
(load-file fpath *compiled-file-extension*))
(#\S nil)))))
;; FAS file is newest.
((and compile fas (> fas (or lisp 0)))
(load-file fpath *compiled-file-extension*))
;; a newer LISP file, but should be compiled.
((and compile fas lisp (> lisp fas))
(if noconfirm
(load-file fpath source-type)
(progn
(format t "~%>> For file ~:@(~a~) In Module ~:@(~a~):~
~% A newer uncompiled file exists."
(pathname-name fpath) name)
(case (prompt-choose
"~%Load the Uncompiled File? (?/Y/N/C/S) : "
'(#\y #\n #\c #\s)
"~% Y : Load the Uncompiled File.~
~% N : Load the Compiled File.~
~% C : Compile this File, then Load it.~
~% S : Skip loading this File.")
(#\Y (load-file fpath source-type))
(#\N (load-file fpath *compiled-file-extension*))
(#\C (setf fpath (make-pathname :type source-type
:defaults fpath))
(compile-file-transform fpath)
(load-file fpath *compiled-file-extension*))
(#\S nil)))))
;; A lisp file exists.
(lisp (load-file fpath source-type))
(t (if noconfirm
(format t
"~%>> For File ~:@(~a~) In Module ~:@(~a~):~
~% File Doesn't Exist.~
~%The file will be skiped."
(pathname-name fpath)
(system-module-name module))
(CError
"Skip Loading the File."
"~%>> For File ~:@(~a~) In Module ~:@(~a~):~
~% File Doesn't Exist."
(pathname-name fpath)
(system-module-name module)))))))
(setf (system-module-loaded-files module) loaded))))
(defun LOAD-DEPEND-MODULE (name modalist path verbose noconfirm)
"LOAD-DEPEND-MODULE name modalist path verbose
Loads in a module as a compile dependancy."
(let* ((module (cdr (assoc name modalist)))
(files (system-module-files module))
(loaded (system-module-loaded-files module))
(load (system-module-load module))
(compile (or (system-module-compile module) (eq load :FASLOAD)))
fpath fas lisp)
;; check if already loaded, or not supposed to be.
(unless (or (null load)
(every #'(lambda(file)
(cdr (assoc file loaded :TEST #'equal)))
files))
(when verbose (format t "~%; Loading Module ~a." name))
;; make sure dependant modules are loaded.
(when (listp load)
(dolist (mod load)
(load-depend-module mod modalist path verbose noconfirm)))
;; load in the files.
(when (eq (system-module-flags module) :c)
(return-from load-depend-module name))
(let (source-type)
(dolist (file files)
(unless (cdr (assoc file loaded :TEST #'equal)) ;; loaded already.
(setq fpath (merge-pathnames file path))
(setf source-type (pathname-type
(or (probe-file
(merge-pathnames (make-pathname :type "lisp") fpath))
(probe-file
(merge-pathnames (make-pathname :type "lsp") fpath)))))
;; get the dates for what's there.
(setq fas (file-write-date (merge-pathnames (make-pathname
:type *compiled-file-extension*)
fpath)))
(setq lisp (file-write-date (merge-pathnames (make-pathname :type source-type)
fpath)))
;; find which file to load in.
(cond ((and fas compile) (load-file fpath *compiled-file-extension*))
(lisp (load-file fpath source-type))
(t (if noconfirm
(format t
"~%>> For File ~:@(~a~) In Module ~:@(~a~):~
~% File Doesn't Exist.~
~%The file will be skiped."
(pathname-name fpath)
(system-module-name module))
(CError
"Skip Loading the File."
"~%>> For File ~:@(~a~) In Module ~:@(~a~):~
~% File Doesn't Exist."
(pathname-name fpath)
name)))))))
(setf (system-module-loaded-files module) loaded))))
(defvar *compile-time* nil
"Indicates the time when the system began to be compiled.")
(defvar *compiling-modules* nil
"Used to Stop Recursive calls to compile the same module again.")
(defun COMPILE-SYSTEM (name &KEY (recompile nil)
(verbose t)
noconfirm)
"COMPILE-SYSTEM name &KEY (recompile nil)
(verbose t)
noconfirm
If recompile is T, all the source files are recompiled if
regardless of the date of the source files.
Otherwise this compiles any modules source files that have
have a newer .lisp version. This will recompile any
modules that depend on the module being compiled."
(let ((defsys (get name 'defsystem))
(modalist nil) syspath
(pathname nil)
(sysfilename (make-file-name (symbol-name name)))
(*source-files* nil)
(*compile-time* (get-universal-time))
)
(cond
((null defsys) (error "~&~a is not the name of a defined system." name))
(t
;; compile and load any included systems
(dolist (sys (defsystem-included-systems defsys))
(compile-system sys
:RECOMPILE recompile
:VERBOSE verbose
:noconfirm noconfirm)
(load-system sys :VERBOSE verbose :noconfirm noconfirm))
;; create the file directory file.
(setq pathname (pathname (defsystem-pathname defsys)))
(setq syspath (make-pathname
:HOST nil
:NAME sysfilename
:TYPE "defsystem"
:VERSION :NEWEST
:DEFAULTS pathname))
;; if a system file exists, get the current system source files.
(when (probe-file syspath)
(load syspath) ;; load it to get the source files.
(delete-file (truename syspath))) ;; delete the old one.
;; Start out with doing none.
(setq *compiling-modules* nil)
;; compile each of the modules.
(dolist (mcons (setq modalist (defsystem-modules-alist defsys)))
(compile-module (car mcons) modalist pathname verbose recompile
noconfirm))
;; create the new file.
(with-open-file (str syspath :DIRECTION :OUTPUT)
;; this is so all the symbols will have their package prefixes.
(let ((*package* (find-package 'keyword)))
(format str "~&(setq defsys::*source-files* '(")
(dolist (x (clean-source-files *source-files*))
(format str "~%~s" x))
(format str "))"))))
))
)
(defmacro REMOVE-LOADED-FILE (file)
`(let ((there (assoc ,file loaded :TEST #'equal)))
(when (cdr there) (setf (cdr there) nil))))
(defun compile-module (name modalist path verbose &OPTIONAL
(recompile-p nil)
(noconfirm nil))
(let* ((module (cdr (assoc name modalist)))
(flags (system-module-flags module)))
(if (eq flags :c)
(compile-c-module name modalist path verbose recompile-p noconfirm)
(compile-lisp-module name modalist path verbose recompile-p
noconfirm)
))
)
(defun COMPILE-LISP-MODULE (name modalist path verbose &OPTIONAL
(recompile-p nil)
(noconfirm nil))
(let* ((module (cdr (assoc name modalist)))
(files (system-module-files module))
(files-to-compile nil)
(file-path nil)
(loaded (system-module-loaded-files module))
(compile (system-module-compile module)))
;; have we already started this one?
(unless (member name *compiling-modules*)
;; do we compile the files?
(when compile
(push name *compiling-modules*)
(when verbose (format t "~%; Compiling Module ~a." name))
;; make sure depend-on modules are up to date.
(when (listp compile)
;; remove self if there.
(dolist (m (remove name compile))
(compile-module m modalist path verbose recompile-p noconfirm)))
;; Determine if we need to compile any of the files.
(cond
(recompile-p ;; forcing them all, see if they still need it.
(let (source-type fpath)
(dolist (file files)
(setf fpath (merge-pathnames file path))
(setf source-type (pathname-type
(or (probe-file
(merge-pathnames (make-pathname :type "lisp") fpath))
(probe-file
(merge-pathnames (make-pathname :type "lsp") fpath)))))
(setq file-path (make-pathname
:TYPE source-type
:DEFAULTS fpath))
(cond((recompile-file-p file-path) ;; hasnt been recompiled?
(remove-loaded-file file)
(push (cons file file-path) files-to-compile))
(t (push (cons file (truename file-path))
*source-files*))))))
(t ;; otherwise check them each for needing to be compiled.
(let (source-type fpath)
(dolist (file files)
(setf fpath (merge-pathnames file path))
(setf source-type (pathname-type
(or (probe-file
(merge-pathnames (make-pathname :type "lisp") fpath))
(probe-file
(merge-pathnames (make-pathname :type "lsp") fpath)))))
(setq file-path (make-pathname
:TYPE source-type
:DEFAULTS fpath))
(cond
((file-not-compiled-p file-path)
(remove-loaded-file file)
(push (cons file file-path) files-to-compile))
(t (push (cons file (truename file-path)) *source-files*)))))))
;; If we have files to compile, then do it.
(when files-to-compile
;; Load any depend-on Modules first.
(when (listp compile)
(dolist (m compile)
(load-depend-module m modalist path verbose noconfirm)))
;; Get this to destructively modify.
(setq loaded (system-module-loaded-files module))
;; Compile the files.
;; Fpair is a cons. Car is module-file-name and the Cdr the pathname.
(dolist (fpair files-to-compile)
;; compile the file
(cond ((probe-file (CDR fpair))
(compile-file-transform (CDR fpair)
#-(or :LUCID :ALLEGRO) :VERBOSE #-(or :LUCID :ALLEGRO) verbose))
(t (Error "File doesn't exist ~a" (CDR fpair))))
;; Kill any previously loaded file
(remove-loaded-file (CAR fpair))
;; update the source file table.
(push (cons (CAR fpair) (truename (CDR fpair))) *source-files*)))
)
;; Force Recompilation for any dependant modules if we have newer files
(when (or files-to-compile (newer-module-files-p module))
(dolist (m (system-module-dependants module))
(compile-module m modalist path verbose t noconfirm)))
))
)
#+DEC
(defun COMPILE-C-MODULE (name modalist path verbose &OPTIONAL
(recompile-p nil)
(noconfirm nil))
(let* ((module (cdr (assoc name modalist)))
(files (system-module-files module))
(h-files nil)
(files-to-compile nil)
(file-path nil)
(compile (system-module-compile module)))
;; have we already started this one?
(unless (member name *compiling-modules*)
;; do we compile the files?
(when compile
(push name *compiling-modules*)
(when verbose (format t "~%; Compiling Module ~a." name))
;; make sure depend-on modules are up to date.
(when (listp compile)
;; remove self if there.
(dolist (m (remove name compile))
(compile-module m modalist path verbose recompile-p noconfirm))
)
;; Determine if we need to compile any of the files.
(cond
(recompile-p ;; forcing them all, see if they still need it.
(let (source-type fpath)
(dolist (file files)
(setf fpath (merge-pathnames file path))
(setf source-type (pathname-type
(or (probe-file
(merge-pathnames (make-pathname :type "c") fpath))
(probe-file
(merge-pathnames (make-pathname :type "h") fpath)))))
(setq file-path (make-pathname
:TYPE source-type
:DEFAULTS fpath))
(cond((string= source-type "H")
(let* ((true-h-name (truename file-path))
(mod-h-name (file-write-date true-h-name)))
(push (list file true-h-name mod-h-name)
h-files)
(push (cons file true-h-name) *source-files*))
)
((recompile-c-file-p file-path) ;; hasnt been recompiled?
(push (cons file file-path) files-to-compile))
(t (push (cons file (truename file-path))
*source-files*))))))
(t ;; otherwise check them each for needing to be compiled.
(let (source-type fpath)
(dolist (file files)
(setf fpath (merge-pathnames file path))
(setf source-type (pathname-type
(or (probe-file
(merge-pathnames (make-pathname :type "c") fpath))
(probe-file
(merge-pathnames (make-pathname :type "h") fpath)))))
(setq file-path (make-pathname
:TYPE source-type
:DEFAULTS fpath))
(cond
((string= source-type "H")
(let* ((true-h-name (truename file-path))
(mod-h-name (file-write-date true-h-name)))
(push (list file true-h-name mod-h-name)
h-files)
(push (cons file true-h-name) *source-files*))
)
((c-file-not-compiled-p file-path h-files)
(push (cons file file-path) files-to-compile))
(t (push (cons file (truename file-path)) *source-files*)))))))
;; If we have files to compile, then do it.
(when files-to-compile
;; Load any depend-on Modules first.
(when (listp compile)
(dolist (m compile)
(load-depend-module m modalist path verbose noconfirm)))
;; Compile the files.
;; Fpair is a cons. Car is module-file-name and the Cdr the pathname.
(dolist (fpair files-to-compile)
;; compile the file
(cond ((probe-file (CDR fpair))
(c-compile-file-transform (CDR fpair) :VERBOSE verbose))
(t (Error "File doesn't exist ~a" (CDR fpair))))
;; update the source file table.
(push (cons (CAR fpair) (truename (CDR fpair))) *source-files*)))
(when files-to-compile
(link-c-module-transform (system-module-load module)
verbose
noconfirm)))
;; Force Recompilation for any dependant modules if we have newer files
(when (or files-to-compile (newer-module-files-p module))
(dolist (m (system-module-dependants module))
(compile-module m modalist path verbose t noconfirm)))
))
)
#+DEC
(defun c-COMPILE-FILE-TRANSFORM (file &rest options)
(if *print-transforms-only*
(format t "~&; (C-Compile-File ~S~{ ~S~})" (namestring (pathname file))
options)
(apply #'c-compile-file file options))
)
#+DEC
(defun link-c-module-TRANSFORM (file &rest options)
(if *print-transforms-only*
(format t "~&; (link-c-module ~S~{ ~S~})" (namestring (pathname file))
options)
(apply #'link-c-module file options))
)
(defun NEWER-MODULE-FILES-P (module &AUX thisone)
;; check each file.
(dolist (file (system-module-files module))
;; Get the latest file known about.
(setq thisone (cdr (assoc file *source-files* :TEST #'equal)))
(cond ((null thisone) ;; not there, assume newer
(return-from newer-module-files-p t))
;; See if this isn't the newest
((null (equal (truename thisone)
(truename (make-pathname
:VERSION :NEWEST
:DEFAULTS thisone))))
(return-from newer-module-files-p t))))
nil)
#+DEC
(defun RECOMPILE-C-FILE-P (file-path &aux source-type)
;; Returns a pair of file and pathname if it hasn't already
;; been recompiled in this invocation of compile-system.
(setf source-type (pathname-type file-path))
(setf (pathname-type file-path) "OBJ") ;; change it to a OBJ.
(let* ((date (file-write-date file-path)))
;; check if it has already been recompiled.
(cond ((and date (> date *compile-time*))
(setf (pathname-type file-path) source-type) ;; change it back
nil)
(t (setf (pathname-type file-path) source-type) ;; change it back.
t))))
(defun RECOMPILE-FILE-P (file-path &aux source-type)
;; Returns a pair of file and pathname if it hasn't already
;; been recompiled in this invocation of compile-system.
(setf source-type (pathname-type file-path))
(setf file-path (make-pathname :type *compiled-file-extension*
:defaults file-path))
(let* ((date (file-write-date file-path)))
;; check if it has already been recompiled.
(cond ((and date (> date *compile-time*))
nil)
(t
t))))
(defun FILE-NOT-COMPILED-P (pathname)
;; This takes a .lisp pathname and returns t if it needs to be compiled.
;; get the write dates for the files. (if they exists).
(let ((fasdate (file-write-date
(make-pathname :TYPE *compiled-file-extension*
:DEFAULTS pathname)))
(lispdate (file-write-date pathname)))
(cond
((and fasdate lispdate) ;; they both exists, check dates
(> lispdate fasdate))
((and fasdate (null lispdate)) ;; No lisp, but a FAS.
nil)
(lispdate t)
(t (error "File Doesn't exist - ~a." pathname)))))
#+DEC
(defun C-FILE-NOT-COMPILED-P (pathname h-files)
;; This takes a .c pathname and returns t if it needs to be compiled.
;; get the write dates for the files. (if they exists).
(let ((objdate (file-write-date
(make-pathname :TYPE "OBJ" :DEFAULTS pathname)))
(cdate (when (probe-file pathname)
(max (file-write-date pathname)
(max-h-file-write-date h-files)))))
(cond
((and objdate cdate) ;; they both exists, check dates
(> cdate objdate))
((and objdate (null cdate)) ;; No c, but a OBJ.
nil)
(cdate t)
(t (error "File Doesn't exist - ~a." pathname)))))
#+DEC
(defun max-h-file-write-date (h-files)
(do ((h-ptr h-files (rest h-ptr))
(max-date 0))
((endp h-ptr) max-date)
(setf max-date (max max-date (or (third (first h-ptr)) 0)))
)
)
(defun CLEAN-SOURCE-FILES (alist)
(when (consp alist)
(do ((al alist (cdr al))
(pair (car alist) (car al))
(newlist nil) (old nil))
((null pair) newlist)
(unless (member (car pair) old)
(push pair newlist)
(push (car pair) old)))))
(defun MAKE-FILE-NAME (str)
(declare (simple-string str name))
(let* ((len (length str))
(name (make-string (min 20 len)
:INITIAL-ELEMENT #\space))
(pos 0))
(dotimes (x len)
(when (alphanumericp (schar str x))
(setf (schar name pos) (schar str x))
(incf pos)))
(string-right-trim '(#\space) name)))
;;;;;
;;; This function is *slightly* VMS dependent - the use of the extension
;;; ".COM" for command procedures is a VMSism.
;;;;;
#+DEC
(defun get-link-com-file-name (filename def-pathname)
(cond ((has-file-type-p filename)
(if (string-equal (pathname-type (pathname filename))
"COM")
(let ((temp-path (pathname filename)))
(cond ((and (or (pathname-device temp-path)
(pathname-directory temp-path))
(probe-file filename)) filename)
((and (not (or (pathname-device temp-path)
(pathname-directory temp-path)))
(probe-file (setf filename
(concatenate
'string def-pathname
filename))))
filename)
(t (Error "File not found - ~A." filename))))
(Error "File Type must be COM - ~A." filename)))
(t (let ((temp-path (pathname filename))
(file1 (concatenate 'string def-pathname filename)))
(when (or (pathname-device temp-path)
(pathname-directory temp-path))
(setf file1 filename))
(setf file1 (concatenate 'string file1 ".COM"))
(if (probe-file file1)
file1
(Error "File not found - ~A." file1))
)
)
)
)
;;;;===========================================================================
;;;
;;; All of the following code is VMS dependent - use of VMS system services
;;; and RTL routines.
;;;
;;;;===========================================================================
;;;; first two system services: SYS$CREMBX (Create Mailbox) and SYS$DASSGN
;;;; (Deassign channel).
#+DEC
(eval-when (load eval compile)
(define-external-routine (SYS$CREMBX :check-status-return t)
(prmflg :access :in :mechanism :immediate :vax-type :longword
:lisp-type integer)
(chan :access :in-out :mechanism :reference :vax-type :word
:lisp-type (unsigned-byte 16))
(maxmsg :access :in :mechanism :immediate :vax-type :longword
:lisp-type integer)
(bufquo :access :in :mechanism :immediate :vax-type :longword
:lisp-type integer)
(promsk :access :in :mechanism :immediate :vax-type :longword
:lisp-type integer)
(acmode :access :in :mechanism :immediate :vax-type :longword
:lisp-type integer)
(lognam :access :in :mechanism :descriptor :vax-type :text
:lisp-type string)
)
(define-external-routine (SYS$DASSGN :check-status-return t)
(chan :access :in :mechanism :immediate :vax-type :longword
:lisp-type integer)
)
)
#+DEC
(defun $CREMBX (&key (prmflg 0) (maxmsg 0) (bufquo 0) (promsk 0) (acmode 0)
(lognam "") &aux (chan 0))
(call-out sys$crembx prmflg chan maxmsg bufquo promsk acmode lognam)
chan)
#+DEC
(defun $DASSGN (chan)
(call-out sys$dassgn chan)
t)
#+DEC
(defconstant MBX-MAXMSG 256)
#+DEC
(defconstant MBX-BUFQUO 1024)
#+DEC
(defun c-compile-file (file-pathname &rest ignore)
(declare (ignore ignore))
(let* ((file-path (pathname file-pathname))
(file-name (string (pathname-name file-path)))
(obj-path (make-pathname :TYPE "OBJ" :defaults file-path))
(mailbox-name (string (gensym (concatenate 'string
"C_COMPILE_"
file-name))))
(mailbox-channel ($CREMBX :LOGNAM mailbox-name :MAXMSG MBX-MAXMSG
:BUFQUO MBX-BUFQUO))
)
(with-open-file (sub-process-output mailbox-name :direction :input)
($DASSGN mailbox-channel)
(SPAWN :COMMAND-STRING (concatenate
'string
"CC "
(namestring file-path)
" /NOLIST /OBJECT="
(namestring obj-path))
:DCL-SYMBOLS nil
:INPUT-FILE "NLA0:"
:OUTPUT-FILE mailbox-name
:PARALLEL t
)
(do ((line (read-line sub-process-output nil :EOF)
(read-line sub-process-output nil :EOF)))
((eq line :EOF) t)
(write-line line))
)
(when (probe-file obj-path)
(namestring (truename obj-path)))
)
)
#+DEC
(defun link-c-module (file-pathname &rest ignore)
(declare (ignore ignore))
(let* ((file-path (pathname file-pathname))
(file-name (string (pathname-name file-path)))
(mailbox-name (string (gensym (concatenate 'string
"C_LINK_"
file-name))))
(mailbox-channel ($CREMBX :LOGNAM mailbox-name :MAXMSG MBX-MAXMSG
:BUFQUO MBX-BUFQUO))
)
(with-open-file (sub-process-output mailbox-name :direction :input)
($DASSGN mailbox-channel)
(SPAWN :COMMAND-STRING (concatenate 'string
"@"
(namestring file-name))
:DCL-SYMBOLS nil
:INPUT-FILE "NLA0:"
:OUTPUT-FILE mailbox-name
:PARALLEL t
)
(do ((line (read-line sub-process-output nil :EOF)
(read-line sub-process-output nil :EOF)))
((eq line :EOF) t)
(write-line line))
)
)
t)
;;; ***************************************************************************
;;; EOF