module/slib/require.scm

   1 ;;;; Implementation of VICINITY and MODULES for Scheme
   2 ;Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (define *SLIB-VERSION* "2d1")
  21
  22 ;;; Standardize msdos -> ms-dos.
  23 (define software-type
  24   (cond ((eq? 'msdos (software-type))
  25          (lambda () 'ms-dos))
  26         (else software-type)))
  27
  28 (define (user-vicinity)
  29   (case (software-type)
  30     ((VMS)      "[.]")
  31     (else       "")))
  32
  33 (define *load-pathname* #f)
  34 (define vicinity:suffix?
  35   (let ((suffi
  36          (case (software-type)
  37            ((AMIGA)                             '(#\: #\/))
  38            ((MACOS THINKC)                      '(#\:))
  39            ((MS-DOS WINDOWS ATARIST OS/2)       '(#\\ #\/))
  40            ((NOSVE)                             '(#\: #\.))
  41            ((UNIX COHERENT)                     '(#\/))
  42            ((VMS)                               '(#\: #\])))))
  43     (lambda (chr) (memv chr suffi))))
  44 (define (program-vicinity)
  45   (if *load-pathname*
  46       (let loop ((i (- (string-length *load-pathname*) 1)))
  47         (cond ((negative? i) "")
  48               ((vicinity:suffix? (string-ref *load-pathname* i))
  49                (substring *load-pathname* 0 (+ i 1)))
  50               (else (loop (- i 1)))))
  51       (slib:error "Not loading but called" 'program-vicinity)))
  52
  53 (define sub-vicinity
  54   (case (software-type)
  55     ((VMS) (lambda
  56                (vic name)
  57              (let ((l (string-length vic)))
  58                (if (or (zero? (string-length vic))
  59                        (not (char=? #\] (string-ref vic (- l 1)))))
  60                    (string-append vic "[" name "]")
  61                    (string-append (substring vic 0 (- l 1))
  62                                   "." name "]")))))
  63     (else (let ((*vicinity-suffix*
  64                  (case (software-type)
  65                    ((NOSVE) ".")
  66                    ((MACOS THINKC) ":")
  67                    ((MS-DOS WINDOWS ATARIST OS/2) "\\")
  68                    ((UNIX COHERENT AMIGA) "/"))))
  69             (lambda (vic name)
  70               (string-append vic name *vicinity-suffix*))))))
  71
  72 (define (make-vicinity <pathname>) <pathname>)
  73
  74 (define (slib:pathnameize-load *old-load*)
  75   (lambda (<pathname> . extra)
  76     (let ((old-load-pathname *load-pathname*))
  77       (set! *load-pathname* <pathname>)
  78       (apply *old-load* (cons <pathname> extra))
  79       (require:provide <pathname>)
  80       (set! *load-pathname* old-load-pathname))))
  81
  82 (set! slib:load-source
  83       (slib:pathnameize-load slib:load-source))
  84 (set! slib:load
  85       (slib:pathnameize-load slib:load))
  86
  87 ;;;; MODULES
  88
  89 (define *catalog* #f)
  90 (define *modules* '())
  91
  92 (define (require:version path)
  93   (let ((expr (and (file-exists? path)
  94                    (call-with-input-file path (lambda (port) (read port))))))
  95     (and (list? expr) (= 3 (length expr))
  96          (eq? (car expr) 'define) (eq? (cadr expr) '*SLIB-VERSION*)
  97          (string? (caddr expr)) (caddr expr))))
  98
  99 (define (catalog/require-version-match? slibcat)
 100   (let* ((apair (assq '*SLIB-VERSION* slibcat))
 101          (req (in-vicinity (library-vicinity)
 102                            (string-append "require" (scheme-file-suffix))))
 103          (reqvers (require:version req)))
 104     (cond ((not (file-exists? req))
 105            (slib:warn "can't find " req) #f)
 106           ((not apair) #f)
 107           ((not (equal? reqvers (cdr apair))) #f)
 108           ((not (equal? reqvers *SLIB-VERSION*))
 109            (slib:warn "The loaded " req " is stale.")
 110            #t)
 111           (else #t))))
 112
 113 (define (catalog:try-read vicinity name)
 114   (or (and vicinity name
 115            (let ((path (in-vicinity vicinity name)))
 116              (and (file-exists? path)
 117                   (call-with-input-file path
 118                     (lambda (port)
 119                       (do ((expr (read port) (read port))
 120                            (lst '() (cons expr lst)))
 121                           ((eof-object? expr)
 122                            (apply append lst))))))))
 123       '()))
 124
 125 (define (catalog:get feature)
 126   (if (not *catalog*)
 127       (let ((slibcat (catalog:try-read (implementation-vicinity) "slibcat")))
 128         (cond ((not (catalog/require-version-match? slibcat))
 129                (slib:load (in-vicinity (library-vicinity) "mklibcat"))
 130                (set! slibcat
 131                      (catalog:try-read (implementation-vicinity) "slibcat"))))
 132         (cond (slibcat
 133                (set! *catalog* ((slib:eval
 134                                  (cadr (or (assq 'catalog:filter slibcat)
 135                                            '(#f identity))))
 136                                 slibcat))))
 137         (set! *catalog*
 138               (append (catalog:try-read (home-vicinity) "homecat") *catalog*))
 139         (set! *catalog*
 140               (append (catalog:try-read (user-vicinity) "usercat") *catalog*))))
 141   (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f)))))
 142
 143 (define (require:provided? feature)
 144   (if (symbol? feature)
 145       (if (memq feature *features*) #t
 146           (and *catalog*
 147                (let ((path (catalog:get feature)))
 148                  (cond ((symbol? path) (require:provided? path))
 149                        ((member (if (pair? path) (cdr path) path) *modules*)
 150                         #t)
 151                        (else #f)))))
 152       (and (member feature *modules*) #t)))
 153
 154 (define (require:feature->path feature)
 155   (and (symbol? feature)
 156        (let ((path (catalog:get feature)))
 157          (if (symbol? path) (require:feature->path path) path))))
 158
 159 (define (require:require feature)
 160   (or (require:provided? feature)
 161       (let ((path (catalog:get feature)))
 162         (cond ((and (not path) (string? feature) (file-exists? feature))
 163                (set! path feature)))
 164         (cond ((not feature) (set! *catalog* #f))
 165               ((not path)
 166                (slib:error ";required feature not supported: " feature))
 167               ((symbol? path) (require:require path) (require:provide feature))
 168               ((not (pair? path))       ;simple name
 169                (slib:load path)
 170                (and (not (eq? 'new-catalog feature)) (require:provide feature)))
 171               (else                     ;special loads
 172                (require:require (car path))
 173                (apply (case (car path)
 174                         ((macro) macro:load)
 175                         ((syntactic-closures) synclo:load)
 176                         ((syntax-case) syncase:load)
 177                         ((macros-that-work) macwork:load)
 178                         ((macro-by-example) defmacro:load)
 179                         ((defmacro) defmacro:load)
 180                         ((source) slib:load-source)
 181                         ((compiled) slib:load-compiled)
 182                         (else (slib:error "unknown package loader" path)))
 183                       (if (list? path) (cdr path) (list (cdr path))))
 184                (require:provide feature))))))
 185
 186 (define (require:provide feature)
 187   (if (symbol? feature)
 188       (if (not (memq feature *features*))
 189           (set! *features* (cons feature *features*)))
 190       (if (not (member feature *modules*))
 191           (set! *modules* (cons feature *modules*)))))
 192
 193 (require:provide 'vicinity)
 194
 195 (define provide require:provide)
 196 (define provided? require:provided?)
 197 (define require require:require)
 198
 199 (if (and (string->number "0.0") (inexact? (string->number "0.0")))
 200     (require:provide 'inexact))
 201 (if (rational? (string->number "1/19")) (require:provide 'rational))
 202 (if (real? (string->number "0.0")) (require:provide 'real))
 203 (if (complex? (string->number "1+i")) (require:provide 'complex))
 204 (let ((n (string->number "9999999999999999999999999999999")))
 205   (if (and n (exact? n)) (require:provide 'bignum)))
 206
 207 (define report:print
 208   (lambda args
 209     (for-each (lambda (x) (write x) (display #\ )) args)
 210     (newline)))
 211
 212 (define slib:report
 213   (let ((slib:report (lambda () (slib:report-version) (slib:report-locations))))
 214     (lambda args
 215       (cond ((null? args) (slib:report))
 216             ((not (string? (car args)))
 217              (slib:report-version) (slib:report-locations #t))
 218             ((require:provided? 'transcript)
 219              (transcript-on (car args))
 220              (slib:report)
 221              (transcript-off))
 222             ((require:provided? 'with-file)
 223              (with-output-to-file (car args) slib:report))
 224             (else (slib:report))))))
 225
 226 (define slib:report-version
 227   (lambda ()
 228     (report:print
 229      'SLIB *SLIB-VERSION* 'on (scheme-implementation-type)
 230      (scheme-implementation-version) 'on (software-type))))
 231
 232 (define slib:report-locations
 233   (let ((features *features*))
 234     (lambda args
 235       (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
 236       (report:print '(LIBRARY-VICINITY) 'is (library-vicinity))
 237       (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix))
 238       (cond (*load-pathname*
 239              (report:print '*LOAD-PATHNAME* 'is *load-pathname*)))
 240       (cond ((not (null? *modules*))
 241              (report:print 'Loaded '*MODULES* 'are: *modules*)))
 242       (let* ((i (+ -1 5)))
 243         (cond ((eq? (car features) (car *features*)))
 244               (else (report:print 'loaded '*FEATURES* ':) (display slib:tab)))
 245         (for-each
 246          (lambda (x)
 247            (cond ((eq? (car features) x)
 248                   (if (not (eq? (car features) (car *features*))) (newline))
 249                   (report:print 'Implementation '*FEATURES* ':)
 250                   (display slib:tab) (set! i (+ -1 5)))
 251                  ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5)))
 252                  ((not (= (+ -1 5) i)) (display #\ )))
 253            (write x) (set! i (+ -1 i)))
 254          *features*))
 255       (newline)
 256       (report:print 'Implementation '*CATALOG* ':)
 257       (catalog:get #f)
 258       (cond ((pair? args)
 259              (for-each (lambda (x) (display slib:tab) (report:print x))
 260                        *catalog*))
 261             (else (display slib:tab) (report:print (car *catalog*))
 262                   (display slib:tab) (report:print '...)))
 263       (newline))))
 264
 265 (let ((sit (scheme-implementation-version)))
 266   (cond ((zero? (string-length sit)))
 267         ((or (not (string? sit)) (char=? #\? (string-ref sit 0)))
 268          (newline)
 269          (slib:report-version)
 270          (report:print 'edit (scheme-implementation-type) ".init"
 271                        'to 'set '(scheme-implementation-version) 'string)
 272          (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
 273          (report:print 'type '(slib:report) 'for 'configuration)
 274          (newline))))