"Fossies" - the Fresh Open Source Software Archive

Member "slib-3b6/require.scm" (16 Feb 2020, 10202 Bytes) of package /linux/privat/slib-3b6.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "require.scm": 3b5_vs_3b6.

    1 ;;;; Implementation of VICINITY and MODULES for Scheme
    2 ;Copyright (C) 1991, 1992, 1993, 1994, 1997, 2002, 2003, 2005 Aubrey Jaffer
    3 ;
    4 ;Permission to copy this software, to modify it, to redistribute it,
    5 ;to distribute modified versions, and to use it for any purpose is
    6 ;granted, subject to the following restrictions and 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 warranty 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* "3b6")
   21 
   22 ;;;; MODULES
   23 ;@
   24 (define *catalog* #f)
   25 (define *base-table-implementations* '())
   26 ;@
   27 (define (slib:version path)
   28   (let ((expr (and (file-exists? path)
   29            (call-with-input-file path (lambda (port) (read port))))))
   30     (and (list? expr) (= 3 (length expr))
   31      (eq? (car expr) 'define) (eq? (cadr expr) '*slib-version*)
   32      (string? (caddr expr)) (caddr expr))))
   33 
   34 (define (catalog/require-version-match? slibcat)
   35   (let* ((apair (assq '*slib-version* slibcat))
   36      (req (in-vicinity (library-vicinity)
   37                (string-append "require" (scheme-file-suffix))))
   38      (reqvers (slib:version req)))
   39     (cond ((not (file-exists? req))
   40        (slib:warn "can't find " req) #f)
   41       ((not apair) #f)
   42       ((not (equal? reqvers (cdr apair))) #f)
   43       ((not (equal? reqvers *slib-version*))
   44        (slib:warn "The loaded " req " is stale.")
   45        #t)
   46       (else #t))))
   47 
   48 (define (catalog:try-read vicinity name)
   49   (or (and vicinity name
   50        (let ((path (in-vicinity vicinity name)))
   51          (and (file-exists? path)
   52           (call-with-input-file path
   53             (lambda (port)
   54               (do ((expr (read port) (read port))
   55                (lst '() (cons expr lst)))
   56               ((eof-object? expr)
   57                (apply append lst))))))))
   58       '()))
   59 ;@
   60 (define (catalog:resolve vicinity catlist)
   61   (define (res1 e) (if (string? e) (in-vicinity vicinity e) e))
   62   (define (resolve p)
   63     (cond ((symbol? (cdr p)) p)
   64       ((not (list? p)) (cons (car p) (res1 (cdr p))))
   65       ((null? (cddr p)) (cons (car p) (res1 (cadr p))))
   66       (else (map res1 p))))
   67   (map resolve catlist))
   68 ;@
   69 (define (catalog:read vicinity cat)
   70   (catalog:get #f)          ; make sure *catalog* exists
   71   (set! *catalog*
   72     (append (catalog:resolve vicinity (catalog:try-read vicinity cat))
   73         *catalog*)))
   74 
   75 (define (catalog:get feature)
   76   (if (not *catalog*)
   77       (let ((slibcat (catalog:try-read (implementation-vicinity) "slibcat")))
   78     (cond ((not (catalog/require-version-match? slibcat))
   79            (slib:load-source (in-vicinity (library-vicinity) "mklibcat"))
   80            (set! slibcat
   81              (catalog:try-read (implementation-vicinity) "slibcat"))))
   82     (cond (slibcat
   83            (set! *catalog* ((slib:eval
   84                  (cadr (or (assq 'catalog:filter slibcat)
   85                        '(#f identity))))
   86                 slibcat))))
   87     (and (home-vicinity)
   88          (set! *catalog*
   89            (append (catalog:try-read (home-vicinity) "homecat")
   90                *catalog*)))
   91     (set! *catalog*
   92           (append (catalog:try-read (user-vicinity) "usercat") *catalog*))))
   93   (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f)))))
   94 ;@
   95 (define (slib:in-catalog? feature)
   96   (let ((path (catalog:get feature)))
   97     (if (symbol? path) (slib:in-catalog? path) path)))
   98 
   99 ;@
  100 (define (feature-eval expression provided?)
  101   (define (bail expression)
  102     (slib:error 'invalid 'feature 'expression expression))
  103   (define (feval expression)
  104     (cond ((not expression) expression)
  105       ((symbol? expression) (provided? expression))
  106       ((and (list? expression) (pair? expression))
  107        (case (car expression)
  108          ((not) (case (length expression)
  109               ((2) (not (feval (cadr expression))))
  110               (else (bail expression))))
  111          ((or)  (case (length expression)
  112               ((1) #f)
  113               ;;((2) (feval (cadr expression)))
  114               (else (or (feval (cadr expression))
  115                 (feval (cons 'or (cddr expression)))))))
  116          ((and) (case (length expression)
  117               ((1) #t)
  118               ;;((2) (feval (cadr expression)))
  119               (else (and (feval (cadr expression))
  120                  (feval (cons 'and (cddr expression)))))))
  121          (else (bail expression))))
  122       (else (bail expression))))
  123   (feval expression))
  124 ;@
  125 (define (slib:provided? expression)
  126   (define feature-list (cons (scheme-implementation-type)
  127                  (cons (software-type) slib:features)))
  128   (define (provided? expression)
  129     (if (memq expression feature-list) #t
  130     (and *catalog*
  131          (let ((path (catalog:get expression)))
  132            (cond ((symbol? path) (provided? path))
  133              (else #f))))))
  134   (feature-eval expression provided?))
  135 ;@
  136 (define (slib:provide feature)
  137   (if (not (memq feature slib:features))
  138       (set! slib:features (cons feature slib:features))))
  139 ;@
  140 (define (slib:require feature)
  141   (cond
  142    ((not feature) (set! *catalog* #f))
  143    ((slib:provided? feature))
  144    (else
  145     (let ((path (catalog:get feature)))
  146       (cond ((not path)
  147          (slib:error 'slib:require 'unsupported 'feature feature))
  148         ((symbol? path) (slib:provide feature) (slib:require path))
  149         ((string? path)     ;simple name
  150          (if (not (eq? 'new-catalog feature)) (slib:provide feature))
  151          (slib:load path))
  152         (else           ;dispatched loads
  153          (slib:require (car path))
  154          (if (not (eq? 'new-catalog feature)) (slib:provide feature))
  155          (apply (case (car path)
  156               ((macro) macro:load)
  157               ((syntactic-closures) synclo:load)
  158               ((syntax-case) syncase:load)
  159               ((macros-that-work) macwork:load)
  160               ((macro-by-example) defmacro:load)
  161               ((defmacro) defmacro:load)
  162               ((source) slib:load-source)
  163               ((compiled) slib:load-compiled)
  164               ((aggregate)
  165                (lambda feature (for-each slib:require feature)))
  166               ((spectral-tristimulus-values) load-ciexyz)
  167               ((color-names)
  168                (lambda (filename)
  169              (load-color-dictionary feature filename)))
  170               (else (slib:error "unknown package loader" path)))
  171             (if (list? path) (cdr path) (list (cdr path))))))))))
  172 ;@
  173 (define (slib:require-if feature? feature)
  174   (if (slib:provided? feature?) (slib:require feature)))
  175 
  176 ;@
  177 (define provide slib:provide)
  178 (define provided? slib:provided?)
  179 (define require slib:require)
  180 (define require-if slib:require-if)
  181 
  182 (let ((x (string->number "0.0")))
  183   (if (and x (inexact? x)) (slib:provide 'inexact)))
  184 (if (rational? (string->number "1/19")) (slib:provide 'rational))
  185 (let ((x (string->number "0.01")))
  186   (if (and (real? x) (not (integer? x))) (slib:provide 'real)))
  187 (let ((z (string->number "0.01+i")))
  188   (if (and (complex? z) (not (real? z))) (slib:provide 'complex)))
  189 (let ((n (string->number "9999999999999999999999999999999")))
  190   (if (and n (exact? n)) (slib:provide 'bignum)))
  191 
  192 (cond
  193  ((slib:provided? 'srfi-0)
  194   (slib:provide 'srfi-59)
  195   (slib:provide 'srfi-96)
  196   (do ((idx 0 (+ 1 idx))
  197        (srfis (symbol->string 'srfi-)))
  198       ((> idx 150))
  199     (let ((srfi (string->symbol (string-append srfis (number->string idx)))))
  200       (if (slib:eval `(cond-expand (,srfi #t) (else #f)))
  201       (slib:provide srfi))))))
  202 
  203 (define (slib:pathnameize-load *old-load*)
  204   (lambda (<pathname> . extra)
  205     (with-load-pathname <pathname>
  206       (lambda ()
  207     (apply *old-load* (cons <pathname> extra))))))
  208 
  209 (set! slib:load-source
  210       (slib:pathnameize-load slib:load-source))
  211 (set! slib:load
  212       (slib:pathnameize-load slib:load))
  213 
  214 ;@
  215 (define (slib:eval-load <pathname> evl)
  216   (if (not (file-exists? <pathname>))
  217       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  218   (call-with-input-file <pathname>
  219     (lambda (port)
  220       (with-load-pathname <pathname>
  221     (lambda ()
  222       (do ((o (read port) (read port)))
  223           ((eof-object? o))
  224         (evl o)))))))
  225 
  226 (define (report:print . args)
  227   (for-each (lambda (x) (write x) (display #\space)) args)
  228   (newline))
  229 ;@
  230 (define (slib:report . args)
  231   (define rpt (lambda () (slib:report-version) (slib:report-locations #t)))
  232   (cond ((null? args)
  233      (slib:report-version) (slib:report-locations))
  234     ((not (string? (car args)))
  235      (rpt))
  236     ((slib:provided? 'transcript)
  237      (transcript-on (car args))
  238      (rpt)
  239      (transcript-off))
  240     ((slib:provided? 'with-file)
  241      (with-output-to-file (car args) rpt))
  242     (else (rpt))))
  243 
  244 ;@
  245 (define (slib:report-version)
  246   (report:print
  247    'SLIB *slib-version* 'on (scheme-implementation-type)
  248    (scheme-implementation-version) 'on (software-type)))
  249 
  250 (define slib:report-locations
  251   (let ((lfeatures slib:features))  ; Capture load-time value
  252     (lambda args
  253       (define sit (scheme-implementation-type))
  254       (define siv (string->symbol (scheme-implementation-version)))
  255       (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
  256       (report:print '(LIBRARY-VICINITY) 'is (library-vicinity))
  257       (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix))
  258       (let* ((i (+ -1 5)))
  259     (cond ((eq? (car lfeatures) (car slib:features)))
  260           (else (report:print 'loaded 'SLIB:FEATURES ':) (display slib:tab)))
  261     (for-each
  262      (lambda (x)
  263        (cond ((eq? (car lfeatures) x)
  264           (if (not (eq? (car lfeatures) (car slib:features))) (newline))
  265           (report:print sit siv 'SLIB:FEATURES ':)
  266           (display slib:tab) (set! i (+ -1 5)))
  267          ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5)))
  268          ((not (= (+ -1 5) i)) (display #\space)))
  269        (write x) (set! i (+ -1 i)))
  270      slib:features))
  271       (newline)
  272       (report:print sit siv '*CATALOG* ':)
  273       (catalog:get #f)
  274       (cond ((pair? args)
  275          (for-each (lambda (x) (display slib:tab) (report:print x))
  276                *catalog*))
  277         (else (display slib:tab) (report:print (car *catalog*))
  278           (display slib:tab) (report:print '...)))
  279       (newline))))
  280 
  281 (let ((siv (scheme-implementation-version)))
  282   (cond ((zero? (string-length siv)))
  283     ((or (not (string? siv)) (char=? #\? (string-ref siv 0)))
  284      (newline)
  285      (slib:report-version)
  286      (report:print 'edit (scheme-implementation-type) ".init"
  287                'to 'set '(scheme-implementation-version) 'string)
  288      (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
  289      (report:print 'type '(slib:report) 'for 'configuration)
  290      (newline))))