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 / pcsample / load.scm next >
Text File  |  1999-01-02  |  3KB  |  89 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: load.scm,v 1.5 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1995-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. ;; This kludge keeps the 7.4 and 8.0 sources the same:
  27.  
  28. (let ((compiler-info (->environment '(runtime compiler-info))))
  29.   (if (environment-bound? compiler-info 'COMPILED-ENTRY/FILENAME)
  30.       (in-package compiler-info
  31.     (define compiled-entry/filename-and-index compiled-entry/filename)
  32.     (define compiled-code-block/filename-and-index
  33.       compiled-code-block/filename))))
  34.  
  35. (package/system-loader "pcs" '() 'QUERY)
  36. (add-identification! "PC Sampler" 1 0)
  37.  
  38. (let ()
  39.   (define (package-initialize package-name
  40.                   #!optional procedure-name mandatory?)
  41.     (let ((procedure-name
  42.        (if (default-object? procedure-name)
  43.            'INITIALIZE-PACKAGE!
  44.            procedure-name))
  45.       (mandatory?
  46.        (or (default-object? mandatory?) mandatory?)))
  47.       (define (print-name string)
  48.     (display "\n")
  49.     (display string)
  50.     (display " (")
  51.     (let loop ((name package-name))
  52.       (if (not (null? name))
  53.           (begin
  54.         (if (not (eq? name package-name))
  55.             (display " "))
  56.         (display (system-pair-car (car name)))
  57.         (loop (cdr name)))))
  58.     (display ")"))
  59.  
  60.       (define (package-reference name)
  61.     (package/environment (find-package name)))
  62.  
  63.       (let ((env (package-reference package-name)))
  64.     (cond ((not procedure-name))
  65.           ((not (lexical-unreferenceable? env procedure-name))
  66.            (print-name "initialize:")
  67.            (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
  68.            (begin
  69.              (display " [")
  70.              (display (system-pair-car procedure-name))
  71.              (display "]")))
  72.            ((lexical-reference env procedure-name)))
  73.           ((not mandatory?)
  74.            (print-name "* skipping:"))
  75.           (else
  76.            ;; Missing mandatory package! Report it and die.
  77.            (print-name "Package")
  78.            (display " is missing initialization procedure ")
  79.            (display (system-pair-car procedure-name))
  80.            (error "Could not initialize a required package."))))))
  81.  
  82.   (for-each package-initialize
  83.         '((pribinut)
  84.           (pc-sample interrupt-handler)
  85.           (pc-sample)
  86.           (pc-sample interp-procs)
  87.           (pc-sample code-blocks)
  88.           (pc-sample display)
  89.           (pc-sample zones))))