home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / module.lisp < prev    next >
Encoding:
Text File  |  1992-12-16  |  3.4 KB  |  100 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: module.lisp,v 1.2 92/12/16 12:32:10 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13.  
  14. ;;; Code written by Jim Muller.
  15. ;;; Rewritten by Bill Chiles.
  16. ;;;
  17. ;;; Note that this module file is based on the old system, and is being
  18. ;;; spliced into the current sources to reflect the last minute deprecated
  19. ;;; addition of modules to the X3J13 ANSI standard.
  20. ;;;
  21. (in-package 'lisp)
  22.  
  23. (export '(*modules* provide require))
  24.  
  25.  
  26. (in-package "EXTENSIONS")
  27. (export '(*require-verbose* defmodule))
  28. (in-package 'lisp)
  29.  
  30.  
  31.  
  32. ;;;; Exported specials.
  33.  
  34. (defvar *modules* ()
  35.   "This is a list of module names that have been loaded into Lisp so far.
  36.    It is used by PROVIDE and REQUIRE.")
  37.  
  38. (defvar *require-verbose* t
  39.   "*load-verbose* is bound to this before loading files.")
  40.  
  41. ;;;; Defmodule.
  42.  
  43. (defvar *module-file-translations* (make-hash-table :test #'equal))
  44. (defmacro defmodule (name &rest files)
  45.   "Defines a module by registering the files that need to be loaded when
  46.    the module is required.  If name is a symbol, its print name is used
  47.    after downcasing it."
  48.   `(%define-module ,name ',files))
  49.  
  50. (defun %define-module (name files)
  51.   (setf (gethash (module-name-string name) *module-file-translations*)
  52.         files))
  53.  
  54. (defun module-files (name)
  55.   (gethash name *module-file-translations*))
  56.  
  57.  
  58.  
  59. ;;;; Provide and Require.
  60.  
  61. (defun provide (module-name)
  62.   "Adds a new module name to *modules* indicating that it has been loaded.
  63.    Module-name may be either a case-sensitive string or a symbol; if it is
  64.    a symbol, its print name is downcased and used."
  65.   (pushnew (module-name-string module-name) *modules* :test #'string=)
  66.   t)
  67.  
  68. (defun require (module-name &optional pathname)
  69.   "Loads a module when it has not been already.  Pathname, if supplied,
  70.    is a single pathname or list of pathnames to be loaded if the module
  71.    needs to be.  If pathname is not supplied, then a list of files are
  72.    looked for that were registered by a EXT:DEFMODULE form.  If the module
  73.    has not been defined, then a file will be loaded whose name is formed
  74.    by merging \"modules:\" and module-name (downcased if it is a symbol).
  75.    This merged name will be probed with both a .lisp and .fasl extensions,
  76.    calling LOAD
  77.    if it exists.  While loading any files, *load-verbose* is bound to
  78.    *require-verbose* which defaults to nil."
  79.  (setf module-name (module-name-string module-name))
  80.   (unless (member module-name *modules* :test #'string=)
  81.     (if pathname
  82.         (unless (listp pathname) (setf pathname (list pathname)))
  83.         (let ((files (module-files module-name)))
  84.           (if files
  85.               (setf pathname files)
  86.               (setf pathname (list (merge-pathnames "modules:" module-name))))))    (let ((*load-verbose* *require-verbose*))
  87.       (dolist (ele pathname t)
  88.         (load ele)))))
  89.  
  90.  
  91.  
  92. ;;;; Misc.
  93.  
  94. (defun module-name-string (name)
  95.   (typecase name
  96.     (string name)
  97.     (symbol (string-downcase (symbol-name name)))
  98.     (t (error "Module name must be a string or symbol -- ~S."
  99.               name))))
  100.