home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / scm / !Scm / slib / require < prev    next >
Encoding:
Text File  |  1994-06-19  |  7.0 KB  |  240 lines
  1. ;;;; Implementation of VICINITY and MODULES for Scheme
  2. ;;; Copyright (C) 1991, 1992, 1993 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 (user-vicinity)
  21.   (case (software-type)
  22.     ((VMS)    "[.]")
  23.     (else    "")))
  24.  
  25. (define program-vicinity
  26.   (let ((*vicinity-suffix*
  27.      (case (software-type)
  28.        ((NOSVE)    '(#\: #\.))
  29.        ((AMIGA)    '(#\: #\/))
  30.        ((UNIX)    '(#\/))
  31.            ((archimedes) '())
  32.        ((VMS)    '(#\: #\]))
  33.        ((MSDOS ATARIST OS/2)    '(#\\))
  34.        ((MACOS THINKC)    '(#\:)))))
  35.     (lambda ()
  36.       (let loop ((i (- (string-length *load-pathname*) 1)))
  37.     (cond ((negative? i) "")
  38.           ((memv (string-ref *load-pathname* i)
  39.              *vicinity-suffix*)
  40.            (substring *load-pathname* 0 (+ i 1)))
  41.           (else (loop (- i 1))))))))
  42.  
  43. (define sub-vicinity
  44.   (case (software-type)
  45.     ((VMS)
  46.      (lambda
  47.       (vic name)
  48.       (let ((l (string-length vic)))
  49.     (if (or (zero? (string-length vic))
  50.         (not (char=? #\] (string-ref vic (- l 1)))))
  51.         (string-append vic "[" name "]")
  52.         (string-append (substring vic 0 (- l 1))
  53.                "." name "]")))))
  54.     (else
  55.      (let ((*vicinity-suffix*
  56.         (case (software-type)
  57.           ((NOSVE) ".")
  58.           ((UNIX AMIGA) "/")
  59.           ((MACOS THINKC) ":")
  60.           ((MSDOS ATARIST OS/2) "\\"))))
  61.        (lambda (vic name)
  62.      (string-append vic name *vicinity-suffix*))))))
  63.  
  64. (define in-vicinity string-append)
  65.  
  66. (define (make-vicinity <pathname>) <pathname>)
  67.  
  68. (define *catalog*
  69.   (map
  70.    (lambda (p)
  71.      (if (symbol? (cdr p)) p
  72.      (cons
  73.       (car p)
  74.       (if (pair? (cdr p))
  75.           (cons 
  76.            (cadr p)
  77.            (in-vicinity (library-vicinity) (cddr p)))
  78.           (in-vicinity (library-vicinity) (cdr p))))))
  79.    '(
  80.      (rev4-optional-procedures    .    "sc4opt")
  81.      (rev3-procedures        .    "sc3")
  82.      (rev2-procedures        .    "sc2")
  83.      (multiarg/and-        .    "mularg")
  84.      (multiarg-apply        .    "mulapply")
  85.      (rationalize        .    "ratize")
  86.      (transcript        .    "trnscrpt")
  87.      (with-file            .    "withfile")
  88.      (dynamic-wind        .    "dynwind")
  89.      (dynamic            .    "dynamic")
  90.      (fluid-let        macro    .    "fluidlet")
  91.      (alist            .    "alist")
  92.      (hash            .    "hash")
  93.      (hash-table        .    "hashtab")
  94.      (logical            .    "logical")
  95.      (random            .    "random")
  96.      (random-inexact        .    "randinex")
  97.      (modular            .    "modular")
  98.      (prime            .    "prime")
  99.      (charplot            .    "charplot")
  100.      (sort            .    "sort")
  101.      (common-list-functions    .    "comlist")
  102.      (tree            .    "tree")
  103.      (format            .    "format")
  104.      (format-inexact        .    "formatfl")
  105.      (generic-write        .    "genwrite")
  106.      (pretty-print        .    "pp")
  107.      (pprint-file        .    "ppfile")
  108.      (object->string        .    "obj2str")
  109.      (string-case        .    "strcase")
  110.      (stdio            .    "stdio")
  111.      (line-i/o            .    "lineio")
  112.      (string-port        .    "strport")
  113.      (getopt            .    "getopt")
  114.      (debug            .    "debug")
  115. ;     (eval            .    "eval")
  116.      (record            .    "record")
  117.      (promise            .    "promise")
  118.      (synchk            .    "synchk")
  119.      (defmacroexpand        .    "defmacex")
  120.      (hygiene            .    "hygiene")
  121.      (macro-by-example    defmacro    .    "mbe")
  122.      (syntax-case        .    "scainit")
  123.      (syntactic-closures    .    "scmacro")
  124.      (macros-that-work        .    "macwork")
  125.      (macro            .    macros-that-work)
  126.      (object            .    "object")
  127.      (yasos        macro    .    "yasos")
  128.      (oop            .    yasos)
  129.      (collect        macro    .    "collect")
  130.      (struct    defmacro    .    "struct")
  131.      (structure    syntax-case    .    "structure")
  132.      (values            .    "values")
  133.      (queue            .    "queue")
  134.      (priority-queue        .    "priorque")
  135.      (array            .    "array")
  136.      (array-for-each        .    "arraymap")
  137.      (repl            .    "repl")
  138.      (process            .    "process")
  139.      (test            .    "test")
  140.      (red-black-tree        .    "rbtree")
  141.      )))                            
  142.      
  143. ;;; --- ams removed for arch version
  144. ; (set! *catalog*
  145. ;      (cons (cons 'portable-scheme-debugger
  146. ;           (in-vicinity (sub-vicinity (library-vicinity) "psd")
  147. ;                     "psd-slib"))
  148. ;         *catalog*))
  149.  
  150. (define *load-pathname* #f)
  151.  
  152. (define (slib:pathnameize-load *old-load*)
  153.   (lambda (<pathname> . extra)
  154.     (let ((old-load-pathname *load-pathname*))
  155.       (set! *load-pathname* <pathname>)
  156.       (apply *old-load* (cons <pathname> extra))
  157.       (require:provide <pathname>)
  158.       (set! *load-pathname* old-load-pathname))))
  159.  
  160. (set! slib:load-source
  161.       (slib:pathnameize-load slib:load-source))
  162. (set! slib:load
  163.       (slib:pathnameize-load slib:load))
  164.  
  165. ;;;; MODULES
  166.  
  167. (define *modules* '())
  168.  
  169. (define (require:provided? feature)
  170.   (if (symbol? feature)
  171.       (if (memq feature *features*) #t
  172.       (let ((path (cdr (or (assq feature *catalog*) '(#f . #f)))))
  173.         (and path (member path *modules*) #t)))
  174.       (and (member feature *modules*) #t)))
  175.  
  176. (define (require:feature->path feature)
  177.   (if (symbol? feature)
  178.       (if (memq feature *features*) #t
  179.       (let ((path (cdr (or (assq feature *catalog*) '(#f . #f)))))
  180.         (cond ((not path)
  181.            (set! feature (symbol->string feature))
  182.            (if (member feature *modules*) #t
  183.                feature))
  184.           ((symbol? path) (require:feature->path path))
  185.           ((member (if (pair? path) (cdr path) path) *modules*)
  186.            #t)
  187.           (else path))))
  188.       (if (member feature *modules*) #t
  189.       feature)))
  190.  
  191. (define (require:require feature)
  192.   (let ((path (require:feature->path feature)))
  193.     (cond ((eq? path #t) #t)
  194.       ((not path)
  195.        (newline)
  196.        (display ";required feature not supported: ")
  197.        (display feature)
  198.        (newline)
  199.        (slib:error ";required feature not supported: " feature))
  200.       ((not (pair? path))        ;simple name
  201.        (slib:load path)
  202.        (require:provide feature))
  203.       (else                ;special loads
  204.        (require (car path))
  205.        (apply (case (car path)
  206.             ((macro) macro:load)
  207.             ((syntactic-closures) synclo:load)
  208.             ((syntax-case) syncase:load)
  209.             ((macros-that-work) macwork:load)
  210.             ((macro-by-example) defmacro:load)
  211.             ((defmacro) defmacro:load)
  212.             ((source) slib:load-source)
  213.             ((compiled) slib:load-compiled))
  214.           (if (list? path) (cdr path) (list (cdr path))))
  215.        (require:provide feature)))))
  216.  
  217. (define (require:provide feature)
  218.   (if (symbol? feature)
  219.       (if (not (memq feature *features*))
  220.       (set! *features* (cons feature *features*)))
  221.       (if (not (member feature *modules*))
  222.       (set! *modules* (cons feature *modules*)))))
  223.  
  224. (require:provide 'vicinity)
  225.  
  226. (define provide require:provide)
  227. (define provided? require:provided?)
  228. (define require require:require)
  229.  
  230. ;;; Supported by all implementations
  231. (provide 'eval)
  232. (provide 'defmacro)
  233.  
  234. (if (inexact? (string->number "0.0")) (provide 'inexact))
  235. (if (rational? (string->number "1/19")) (provide 'rational))
  236. (if (real? (string->number "0.0")) (provide 'real))
  237. (if (complex? (string->number "1+i")) (provide 'complex))
  238. (if (exact? (string->number "9999999999999999999999999999999"))
  239.     (provide 'bignum))
  240.