home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / wabbit / load.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  81 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: load.scm,v 1.3 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1994-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; System Packaging
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (cond ((name->package '(gc-wabbits))
  27.        (display "\n; Package already loaded under some other alias")
  28.        'ok)
  29.       (else
  30.        (package/system-loader "wabbit" '() 'QUERY)
  31.        (add-identification! "Wabbit Hunting / Headhunting GC" 1 0)
  32.  
  33.        (let ()
  34.      (define (package-initialize package-name
  35.                      #!optional procedure-name mandatory?)
  36.        (let ((procedure-name
  37.           (if (default-object? procedure-name)
  38.               'INITIALIZE-PACKAGE!
  39.               procedure-name))
  40.          (mandatory?
  41.           (or (default-object? mandatory?) mandatory?)))
  42.          (define (print-name string)
  43.            (display "\n")
  44.            (display string)
  45.            (display " (")
  46.            (let loop ((name package-name))
  47.          (if (not (null? name))
  48.              (begin
  49.                (if (not (eq? name package-name))
  50.                (display " "))
  51.                (display (system-pair-car (car name)))
  52.                (loop (cdr name)))))
  53.            (display ")"))
  54.  
  55.          (define (package-reference name)
  56.            (package/environment (find-package name)))
  57.  
  58.          (let ((env (package-reference package-name)))
  59.            (cond ((not procedure-name))
  60.              ((not (lexical-unreferenceable? env procedure-name))
  61.               (print-name "initialize:")
  62.               (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
  63.               (begin
  64.                 (display " [")
  65.                 (display (system-pair-car procedure-name))
  66.                 (display "]")))
  67.               ((lexical-reference env procedure-name)))
  68.              ((not mandatory?)
  69.               (print-name "* skipping:"))
  70.              (else
  71.               ;; Missing mandatory package! Report it and die.
  72.               (print-name "Package")
  73.               (display " is missing initialization procedure ")
  74.               (display (system-pair-car procedure-name))
  75.               (error "Could not initialize a required package."))))))
  76.  
  77.      (package-initialize '(gc-wabbits)))))
  78.  
  79. ;;; fini
  80.  
  81.