home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d1xx / d149 / scheme.lha / Scheme / load-patches.scm < prev    next >
Text File  |  1987-06-15  |  2KB  |  63 lines
  1. ;;; load-patches.scm
  2.  
  3. (define path-object
  4.   (let ()
  5.     (define *CURRENT-DIR* ":")
  6.     (define (extend-filename name add-slash?)
  7.       (cond ((zero? (string-length name))
  8.          name)            ; don't add slash
  9.         (else
  10.          (let ((name-chars
  11.             (let ((last-char (string-ref name (- (string-length name) 1))))
  12.               (if (or (not add-slash?)
  13.                   (eq? last-char #\/)
  14.                   (eq? last-char #\:))
  15.               (string->list name)
  16.               (append (string->list name) '(#\/)) ))))
  17.         (cond ((null? name-chars)
  18.                *CURRENT-DIR*)
  19.               ((or (memq #\: name-chars)
  20.                (eq? (car name-chars) #\/))
  21.                (list->string name-chars))
  22.               (else
  23.                (string-append *CURRENT-DIR* (list->string name-chars))))))))
  24.     (define (cd . dirlist)
  25.       (cond ((= (length dirlist) 0)
  26.          *CURRENT-DIR*)
  27.         ((= (length dirlist) 1)
  28.          (let ((fullname (extend-filename (car dirlist) #t)))
  29.            (if (file-exists? fullname)
  30.            (set! *CURRENT-DIR* fullname)
  31.            (error "file not found" fullname))))
  32.         (else
  33.          (error "use zero or one argument" dirlist))))
  34.     (lambda (m)
  35.       (cond ((eq? m 'cd)              cd)
  36.         ((eq? m 'extend-filename) extend-filename))) ))
  37.  
  38.  
  39.  
  40. (define cd        (path-object 'cd))
  41. (define extend-filename (path-object 'extend-filename))
  42.  
  43.  
  44.  
  45. (define load
  46.   (let ()
  47.     (define original-load load)
  48.     (define last-file-list '())
  49.     (define (ld file)
  50.       (original-load (extend-filename file #f)))
  51.     (define (do-load file-list)
  52.       (for-each ld file-list))
  53.     (lambda file-list
  54.       (if (null? file-list)
  55.       (do-load last-file-list)
  56.       (begin (set! last-file-list file-list)
  57.          (do-load file-list)))) ))
  58.  
  59.  
  60.  
  61. ;;; EOF load-patches.scm
  62.  
  63.