← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/runtime/packag.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2005-09-12 21:36:33 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050912213633-shybia1ie66exjvl
Tags: 7.7.90+20050912-1
http://bugs.debian.org/323739
* Acknowledge NMU (thanks Matej!).  (closes: Bug#323739)
* New upstream snapshot.
* Bump standards version to 3.6.2 (no changes).
* Drop texi2html from build dependencies; no longer used.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/packag.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: packag.scm,v 14.44 2003/03/13 18:13:52 cph Exp $
 
3
$Id: packag.scm,v 14.47 2005/08/05 20:03:05 cph Exp $
4
4
 
5
5
Copyright 1988,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
6
6
Copyright 1995,1996,1998,2001,2002,2003 Massachusetts Institute of Technology
 
7
Copyright 2004,2005 Massachusetts Institute of Technology
7
8
 
8
9
This file is part of MIT/GNU Scheme.
9
10
 
164
165
 
165
166
(define system-loader/enable-query? #f)
166
167
 
167
 
(define (load-package-set filename #!optional options load-interpreted?)
168
 
  (let ((pathname (package-set-pathname filename))
169
 
        (options
170
 
         (cons (cons 'OS-TYPE microcode-id/operating-system)
171
 
               (if (default-object? options) '() options))))
172
 
    (with-working-directory-pathname (directory-pathname pathname)
173
 
      (lambda ()
174
 
        (let ((file (fasload pathname)))
175
 
          (if (not (package-file? file))
176
 
              (error "Malformed package-description file:" pathname))
177
 
          (construct-packages-from-file file)
178
 
          (fluid-let
179
 
              ((load/default-types
180
 
                (if (if (or (default-object? load-interpreted?)
181
 
                            (eq? load-interpreted? 'QUERY))
182
 
                        (and system-loader/enable-query?
183
 
                             (prompt-for-confirmation "Load interpreted"))
184
 
                        load-interpreted?)
185
 
                    (list (assoc "bin" load/default-types)
186
 
                          (assoc "scm" load/default-types))
187
 
                    load/default-types)))
188
 
            (let ((alternate-loader
189
 
                   (lookup-option 'ALTERNATE-PACKAGE-LOADER options))
190
 
                  (load-component
191
 
                   (lambda (component environment)
192
 
                     (let ((value
193
 
                            (filename->compiled-object filename component)))
194
 
                       (if value
195
 
                           (begin
196
 
                             (purify (load/purification-root value))
197
 
                             (scode-eval value environment))
198
 
                           (load component environment 'DEFAULT #t))))))
199
 
              (if alternate-loader
200
 
                  (alternate-loader load-component options)
201
 
                  (begin
202
 
                    (load-packages-from-file file options load-component)
203
 
                    (initialize-packages-from-file file)))))))))
 
168
(define (load-package-set filename #!optional options)
 
169
  (let ((os-type microcode-id/operating-system))
 
170
    (let ((pathname (package-set-pathname filename os-type))
 
171
          (options
 
172
           (cons (cons 'OS-TYPE os-type)
 
173
                 (if (default-object? options) '() options))))
 
174
      (with-working-directory-pathname (directory-pathname pathname)
 
175
        (lambda ()
 
176
          (let ((file (fasload pathname)))
 
177
            (if (not (package-file? file))
 
178
                (error "Malformed package-description file:" pathname))
 
179
            (construct-packages-from-file file)
 
180
            (fluid-let
 
181
                ((load/default-types
 
182
                  (if (and system-loader/enable-query?
 
183
                           (prompt-for-confirmation "Load interpreted"))
 
184
                      (list (assoc "bin" load/default-types)
 
185
                            (assoc "scm" load/default-types))
 
186
                      load/default-types)))
 
187
              (let ((alternate-loader
 
188
                     (lookup-option 'ALTERNATE-PACKAGE-LOADER options))
 
189
                    (load-component
 
190
                     (lambda (component environment)
 
191
                       (load component environment 'DEFAULT #t))))
 
192
                (if alternate-loader
 
193
                    (alternate-loader load-component options)
 
194
                    (begin
 
195
                      (load-packages-from-file file options load-component)
 
196
                      (initialize-packages-from-file file))))))))))
204
197
  ;; Make sure that everything we just loaded is purified.  If the
205
198
  ;; program runs before it gets purified, some of its run-time state
206
199
  ;; can end up being purified also.
211
204
                 (pathname-device pathname)
212
205
                 (pathname-directory pathname)
213
206
                 (string-append (pathname-name pathname)
214
 
                                (case (if (or (default-object? os-type)
215
 
                                              (not os-type))
 
207
                                (case (if (default-object? os-type)
216
208
                                          microcode-id/operating-system
217
209
                                          os-type)
218
210
                                  ((NT) "-w32")
221
213
                                  (else "-unk")))
222
214
                 "pkd"
223
215
                 (pathname-version pathname)))
224
 
 
225
 
(define (filename->compiled-object system component)
226
 
  (let ((prim (ucode-primitive initialize-c-compiled-block 1)))
227
 
    (and (implemented-primitive-procedure? prim)
228
 
         (let* ((name
229
 
                 (let* ((p (->pathname component))
230
 
                        (d (pathname-directory p)))
231
 
                   (string-append (if (pair? d) (car (last-pair d)) system)
232
 
                                  "_"
233
 
                                  (string-replace (pathname-name p) #\- #\_))))
234
 
                (value (prim name)))
235
 
           (if (or (not value) load/suppress-loading-message?)
236
 
               value
237
 
               (let ((port (notification-output-port)))
238
 
                 (fresh-line port)
239
 
                 (write-string ";Initialized " port)
240
 
                 (write name port)
241
 
                 value))))))
242
 
 
243
 
(define package/system-loader load-package-set)
244
216
 
245
217
(define-integrable (make-package-file tag version descriptions loads)
246
218
  (vector tag version descriptions loads))