← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/runtime/load.scm

  • Committer: Bazaar Package Importer
  • Author(s): Soren Hansen
  • Date: 2007-05-09 10:57:57 UTC
  • mfrom: (1.1.5 upstream)
  • Revision ID: james.westby@ubuntu.com-20070509105757-p8focimovgqxaaed
Tags: 7.7.90+20070205-1ubuntu1
* Merge from debian unstable, remaining changes:
  * Bootstrapping done via supplied binary package. See log entry for
    7.7.90+20060906-3ubuntu1 for details.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/load.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: load.scm,v 14.76 2006/07/26 19:10:33 cph Exp $
 
3
$Id: load.scm,v 14.84 2007/01/12 10:23:04 riastradh Exp $
4
4
 
5
 
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
6
 
Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
7
 
Copyright 2004,2005,2006 Massachusetts Institute of Technology
 
5
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 
6
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
 
7
    2006, 2007 Massachusetts Institute of Technology
8
8
 
9
9
This file is part of MIT/GNU Scheme.
10
10
 
20
20
 
21
21
You should have received a copy of the GNU General Public License
22
22
along with MIT/GNU Scheme; if not, write to the Free Software
23
 
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
 
23
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
24
24
USA.
25
25
 
26
26
|#
36
36
  (set! load/loading? #f)
37
37
  (set! load/suppress-loading-message? #f)
38
38
  (set! load/default-types
39
 
        `(("com" ,load/internal)
 
39
        `((#f ,wrapper/load/built-in)
 
40
          ("com" ,load/internal)
40
41
          ("so" ,load-object-file)
41
42
          ("sl" ,load-object-file)
 
43
          ("dylib" ,load-object-file)
42
44
          ("bin" ,load/internal)
43
45
          ("scm" ,load/internal)))
44
46
  (set! fasload/default-types
45
 
        `(("com" ,fasload/internal)
 
47
        `((#f ,wrapper/fasload/built-in)
 
48
          ("so" ,fasload-object-file)
 
49
          ("sl" ,fasload-object-file)
 
50
          ("dylib" ,fasload-object-file)
 
51
          ("com" ,fasload/internal)
46
52
          ("bin" ,fasload/internal)))
47
53
  (set! load/default-find-pathname-with-type search-types-in-order)
48
54
  (set! *eval-unit* #f)
169
175
                                                find-pathname
170
176
                                                (list filename default-types))
171
177
                          default-types))))
172
 
    (cond ((file-exists? pathname)
 
178
    (cond ((file-regular? pathname)
173
179
           (values pathname
174
180
                   (let ((find-loader
175
181
                          (lambda (extension)
188
194
             (if (not pathname)
189
195
                 (fail)
190
196
                 (values pathname loader)))))))
191
 
 
 
197
 
192
198
(define (search-types-in-order pathname default-types)
193
199
  (let loop ((types default-types))
194
 
    (if (pair? types)
195
 
        (let ((pathname (pathname-new-type pathname (caar types))))
196
 
          (if (file-exists? pathname)
197
 
              (values pathname (cadar types))
198
 
              (loop (cdr types))))
199
 
        (values #f #f))))
 
200
    (cond ((not (pair? types))
 
201
           (values #f #f))
 
202
          ((not (caar types))
 
203
           (let ((value (try-built-in pathname)))
 
204
             (if value
 
205
                 (values pathname ((cadar types) value))
 
206
                 (loop (cdr types)))))
 
207
          (else
 
208
           (let ((pathname (pathname-new-type pathname (caar types))))
 
209
             (if (file-regular? pathname)
 
210
                 (values pathname (cadar types))
 
211
                 (loop (cdr types))))))))
 
212
 
 
213
;; This always considers a built-in to be the newest.
200
214
 
201
215
(define (find-latest-file pathname default-types)
202
216
  (let loop ((types default-types)
203
217
             (latest-pathname #f)
204
218
             (latest-loader #f)
205
219
             (latest-time 0))
206
 
    (if (not (pair? types))
207
 
        (values latest-pathname latest-loader)
208
 
        (let ((pathname (pathname-new-type pathname (caar types)))
209
 
              (skip
210
 
               (lambda ()
 
220
    (cond ((not (pair? types))
 
221
           (values latest-pathname latest-loader))
 
222
          ((not (caar types))
 
223
           (let ((value (try-built-in pathname)))
 
224
             (if value
 
225
                 (values pathname ((cadar types) value))
211
226
                 (loop (cdr types)
212
227
                       latest-pathname
213
228
                       latest-loader
214
229
                       latest-time))))
215
 
          (let ((time (file-modification-time-indirect pathname)))
216
 
            (if (and time (> time latest-time))
217
 
                (loop (cdr types) pathname (cadar types) time)
218
 
                (skip)))))))
 
230
          (else
 
231
           (let ((pathname (pathname-new-type pathname (caar types))))
 
232
             (let ((time (file-modification-time-indirect pathname)))
 
233
               (if (and time (> time latest-time))
 
234
                   (loop (cdr types) pathname (cadar types) time)
 
235
                   (loop (cdr types)
 
236
                         latest-pathname
 
237
                         latest-loader
 
238
                         latest-time))))))))
 
239
 
 
240
(define (try-built-in pathname)
 
241
  (let ((d (pathname-directory pathname)))
 
242
    (and (pair? d)
 
243
         (let ((tail (last d)))
 
244
           (and (string? tail)          ;Doesn't handle UP ("..").
 
245
                ((ucode-primitive initialize-c-compiled-block 1)
 
246
                 (string-append tail
 
247
                                "_"
 
248
                                (pathname-name pathname))))))))
219
249
 
220
250
(define (load/internal pathname environment purify? load-noisily?)
221
251
  (let* ((port (open-input-file pathname))
235
265
              (write-stream (value-stream)
236
266
                            (lambda (exp&value)
237
267
                              (repl-write (cdr exp&value) (car exp&value))))
238
 
              (loading-message load/suppress-loading-message? pathname
 
268
              (with-loading-message pathname
239
269
                (lambda ()
240
270
                  (write-stream (value-stream)
241
271
                                (lambda (exp&value) exp&value #f)))))))))
247
277
                                       (pathname-new-type pathname "scm")))
248
278
        (warn "Source file newer than binary:" namestring))
249
279
    (let ((value
250
 
           (loading-message suppress-loading-message? pathname
 
280
           (with-loading-message pathname
251
281
             (lambda ()
252
 
               ((ucode-primitive binary-fasload) namestring)))))
 
282
               ((ucode-primitive binary-fasload) namestring))
 
283
             suppress-loading-message?)))
253
284
      (fasload/update-debugging-info! value pathname)
254
285
      value)))
255
286
 
 
287
(define (fasload-object-file pathname suppress-loading-message?)
 
288
  (with-loading-message pathname
 
289
    (lambda ()
 
290
      (let* ((handle ((ucode-primitive load-object-file 1)
 
291
                      (->namestring pathname)))
 
292
             (cth ((ucode-primitive object-lookup-symbol 3)
 
293
                   handle "dload_initialize_file" 0)))
 
294
        (if (not cth)
 
295
            (error "load-object-file: Cannot find init procedure" pathname))
 
296
        (let ((scode ((ucode-primitive initialize-c-compiled-block 1)
 
297
                      ((ucode-primitive address-to-string 1)
 
298
                       ((ucode-primitive invoke-c-thunk 1)
 
299
                        cth)))))
 
300
          (fasload/update-debugging-info! scode pathname)
 
301
          scode)))
 
302
    suppress-loading-message?))
 
303
 
 
304
(define (wrapper/fasload/built-in value)
 
305
  (lambda (pathname suppress-loading-message?)
 
306
    (with-loading-message pathname
 
307
      (lambda ()
 
308
        (fasload/update-debugging-info! value pathname)
 
309
        value)
 
310
      suppress-loading-message?)))
 
311
 
256
312
(define (load-object-file pathname environment purify? load-noisily?)
257
313
  load-noisily?         ; ignored
258
 
  (loading-message
259
 
   load/suppress-loading-message? pathname
260
 
   (lambda ()
261
 
     (let* ((handle
262
 
             ((ucode-primitive load-object-file 1) (->namestring pathname)))
263
 
            (cth
264
 
             ((ucode-primitive object-lookup-symbol 3)
265
 
              handle "dload_initialize_file" 0)))
266
 
       (if (not cth)
267
 
           (error "load-object-file: Cannot find init procedure" pathname))
268
 
       (let ((scode ((ucode-primitive initialize-c-compiled-block 1)
269
 
                     ((ucode-primitive address-to-string 1)
270
 
                      ((ucode-primitive invoke-c-thunk 1)
271
 
                       cth)))))
272
 
         (fasload/update-debugging-info! scode pathname)
273
 
         (load-scode-end scode environment purify?))))))
 
314
  (load-scode-end
 
315
   (fasload-object-file pathname load/suppress-loading-message?)
 
316
   environment
 
317
   purify?))
 
318
 
 
319
(define (wrapper/load/built-in scode)
 
320
  (lambda (pathname environment purify? load-noisily?)
 
321
    load-noisily?                       ; ignored
 
322
    (with-loading-message pathname
 
323
      (lambda ()
 
324
        (fasload/update-debugging-info! scode pathname)
 
325
        (load-scode-end scode environment purify?)))))
274
326
 
275
327
(define (load-scode-end scode environment purify?)
276
328
  (if purify? (purify (load/purification-root scode)))
296
348
                 (let ((find
297
349
                        (lambda (type)
298
350
                          (let ((pathname (pathname-new-type pathname type)))
299
 
                            (and (file-exists? pathname)
 
351
                            (and (file-regular? pathname)
300
352
                                 pathname)))))
301
353
                   (or (find "so")
302
354
                       (find "sl")))))
320
372
  (set! loaded-object-files '())
321
373
  unspecific)
322
374
 
323
 
(define (loading-message suppress-loading-message? pathname do-it)
324
 
  (if suppress-loading-message?
325
 
      (do-it)
326
 
      (let ((port (notification-output-port)))
327
 
        (fresh-line port)
328
 
        (write-string ";Loading " port)
329
 
        (write (enough-namestring pathname) port)
330
 
        (let ((value (do-it)))
331
 
          (write-string " -- done" port)
332
 
          (newline port)
333
 
          value))))
 
375
(define (with-loading-message pathname thunk #!optional suppress-message?)
 
376
  (if (if (default-object? suppress-message?)
 
377
          load/suppress-loading-message?
 
378
          suppress-message?)
 
379
      (thunk)
 
380
      (with-notification (lambda (port)
 
381
                           (write-string "Loading " port)
 
382
                           (write (enough-namestring pathname) port))
 
383
        thunk)))
334
384
 
335
385
(define *purification-root-marker*)
336
386