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 / runtime / packag.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  224 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: packag.scm,v 14.28 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; Simple Package Namespace
  23. ;;; package: (package)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;; Kludge -- package objects want to be records, but this file must
  28. ;;; be loaded first, before the record package.  The way we solve this
  29. ;;; problem is to build the initial packages without an appropriate
  30. ;;; record type, then build the record type and clobber it into the
  31. ;;; packages.  Thereafter, packages are constructed normally.
  32.  
  33. (define package-tag #f)
  34.  
  35. (define-integrable (make-package parent name environment)
  36.   (%record package-tag parent '() name environment))
  37.  
  38. (define (package? object)
  39.   (and (%record? object)
  40.        (eq? (%record-ref object 0) package-tag)))
  41.  
  42. (define-integrable (package/parent package)
  43.   (%record-ref package 1))
  44.  
  45. (define-integrable (package/children package)
  46.   (%record-ref package 2))
  47.  
  48. (define-integrable (set-package/children! package children)
  49.   (%record-set! package 2 children))
  50.  
  51. (define-integrable (package/%name package)
  52.   (%record-ref package 3))
  53.  
  54. (define-integrable (package/environment package)
  55.   (%record-ref package 4))
  56.  
  57. (define-integrable (set-package/environment! package environment)
  58.   (%record-set! package 4 environment))
  59.  
  60. (define (finalize-package-record-type!)
  61.   (let ((rtd
  62.      (make-record-type "package" '(PARENT CHILDREN %NAME ENVIRONMENT))))
  63.     (let ((tag (record-type-dispatch-tag rtd)))
  64.       (set! package-tag tag)
  65.       (let loop ((package system-global-package))
  66.     (%record-set! package 0 tag)
  67.     (for-each loop (package/children package))))
  68.     (set-record-type-unparser-method! rtd
  69.       (standard-unparser-method 'PACKAGE
  70.     (lambda (package port)
  71.       (write-char #\space port)
  72.       (write (package/name package) port))))))
  73.  
  74. (define (package/child package name)
  75.   (let loop ((children (package/children package)))
  76.     (and (not (null? children))
  77.      (if (eq? name (package/%name (car children)))
  78.          (car children)
  79.          (loop (cdr children))))))
  80.  
  81. (define (package/name package)
  82.   (let loop ((package package) (result '()))
  83.     (if (package/parent package)
  84.     (loop (package/parent package) (cons (package/%name package) result))
  85.     result)))
  86.  
  87. (define (name->package name)
  88.   (let loop ((path name) (package system-global-package))
  89.     (if (null? path)
  90.     package
  91.     (let ((child (package/child package (car path))))
  92.       (and child
  93.            (loop (cdr path) child))))))
  94.  
  95. (define (environment->package environment)
  96.   (and (interpreter-environment? environment)
  97.        (interpreter-environment->package environment)))
  98.  
  99. (define (interpreter-environment->package environment)
  100.   (and (not (lexical-unreferenceable? environment package-name-tag))
  101.        (let ((package (lexical-reference environment package-name-tag)))
  102.      (and (package? package)
  103.           (eq? environment (package/environment package))
  104.           package))))
  105.  
  106. (define-integrable package-name-tag
  107.   ((ucode-primitive string->symbol) "#[(package)package-name-tag]"))
  108.  
  109. (define (find-package name)
  110.   (let loop ((path name) (package system-global-package))
  111.     (if (null? path)
  112.     package
  113.     (loop (cdr path)
  114.           (or (package/child package (car path))
  115.           (error "Unable to find package"
  116.              (list-difference name (cdr path))))))))
  117.  
  118. (define (list-difference list tail)
  119.   (let loop ((list list))
  120.     (if (eq? list tail)
  121.     '()
  122.     (cons (car list) (loop (cdr list))))))
  123.  
  124. (define (package/add-child! package name environment #!optional force?)
  125.   (let ((child (package/child package name))
  126.     (finish
  127.      (lambda (child)
  128.        (if (not (interpreter-environment->package environment))
  129.            (local-assignment environment package-name-tag child))
  130.        child)))
  131.     (if child
  132.     (begin
  133.       (if (not (if (default-object? force?)
  134.                *allow-package-redefinition?*
  135.                force?))
  136.           (error "Package already has child of given name:" package name))
  137.       (set-package/environment! child environment)
  138.       (set-package/children! child '())
  139.       (finish child))
  140.     (let ((child (make-package package name environment)))
  141.       (set-package/children! package
  142.                  (cons child (package/children package)))
  143.       (finish child)))))
  144.  
  145. (define system-global-package)
  146. (define *allow-package-redefinition?*)
  147.  
  148. (define system-loader/enable-query?
  149.   false)
  150.  
  151. (define (package/system-loader filename options load-interpreted?)
  152.   (let ((pathname (->pathname filename)))
  153.     (with-working-directory-pathname (directory-pathname pathname)
  154.       (lambda ()
  155.     (fluid-let ((load/default-types
  156.              (if (if (eq? load-interpreted? 'QUERY)
  157.                  (and system-loader/enable-query?
  158.                   (prompt-for-confirmation "Load interpreted"))
  159.                  load-interpreted?)
  160.              (list (assoc "bin" load/default-types)
  161.                    (assoc "scm" load/default-types))
  162.              load/default-types)))
  163.       (let ((syntax-table (nearest-repl/syntax-table)))
  164.         (load (let ((rewrite (assq 'MAKE-CONSTRUCTOR-NAME options))
  165.             (pathname (pathname-new-type pathname "bco")))
  166.             (if rewrite
  167.             ((cdr rewrite) pathname)
  168.             pathname))
  169.           system-global-environment
  170.           syntax-table false)
  171.         ((load (let ((rewrite (assq 'MAKE-LOADER-NAME options))
  172.              (pathname (pathname-new-type pathname "bld")))
  173.              (if rewrite
  174.              ((cdr rewrite) pathname)
  175.              pathname))
  176.            system-global-environment
  177.            syntax-table false)
  178.          (lambda (component environment)
  179.            (cond ((filename->compiled-object filename component)
  180.               => (lambda (value)
  181.                (purify (load/purification-root value))
  182.                (scode-eval value environment)))
  183.              (else
  184.               (load component environment syntax-table true))))
  185.          options))))))
  186.   ;; Make sure that everything we just loaded is purified.  If the
  187.   ;; program runs before it gets purified, some of its run-time state
  188.   ;; can end up being purified also.
  189.   (flush-purification-queue!))
  190.  
  191. (define (filename->compiled-object system component)
  192.   (let ((prim (ucode-primitive initialize-c-compiled-block 1)))
  193.     (and (implemented-primitive-procedure? prim)
  194.      (let* ((name
  195.          (let* ((p (->pathname component))
  196.             (d (pathname-directory p)))
  197.            (string-append
  198.             (if (or (not d) (null? d))
  199.             system
  200.             (car (last-pair d)))
  201.             "_"
  202.             (string-replace (pathname-name p) ; kludge
  203.                     #\-
  204.                     #\_))))
  205.         (value (prim name)))
  206.        (if (or (not value)
  207.            load/suppress-loading-message?)
  208.            value
  209.            (let ((port (notification-output-port)))
  210.          (fresh-line port)
  211.          (write-string ";Initialized " port)
  212.          (write name port)
  213.          value))))))
  214.  
  215. (define-integrable (package/reference package name)
  216.   (lexical-reference (package/environment package) name))
  217.  
  218. (define (initialize-package!)
  219.   (set! system-global-package (make-package #f #f system-global-environment))
  220.   (local-assignment system-global-environment
  221.             package-name-tag
  222.             system-global-package)
  223.   (set! *allow-package-redefinition?* #f)
  224.   unspecific)