home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / sf / pthmap.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  125 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pthmap.scm,v 4.5 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Pathname Maps
  23.  
  24. (declare (usual-integrations)
  25.      (automagic-integrations)
  26.      (open-block-optimizations)
  27.      (eta-substitution))
  28.  
  29. (define pathname-map/make)
  30. (define pathname-map?)
  31. (define pathname-map/lookup)
  32. (define pathname-map/insert!)
  33.  
  34. (let ()
  35.  
  36. (define pathname-map/tag "pathname-map")
  37. (define pathname-map/root-node cdr)
  38.  
  39. (unparser/set-tagged-pair-method!
  40.  pathname-map/tag
  41.  (unparser/standard-method "PATHNAME-MAP"))
  42.  
  43. (declare (integrate-operator node/make))
  44.  
  45. (define (node/make)
  46.   (cons unbound-value '()))
  47.  
  48. (define unbound-value "unbound-value")
  49. (define node/value car)
  50. (define set-node/value! set-car!)
  51. (define node/alist cdr)
  52. (define set-node/alist! set-cdr!)
  53.  
  54. (define (node/associate node key)
  55.   (let ((entry (assoc key (node/alist node))))
  56.     (and entry
  57.      (cdr entry))))
  58.  
  59. (define (make-node-list pathname)
  60.   (cons-if (pathname-device pathname)
  61.        (append (pathname-directory pathname)
  62.            (cons-if (pathname-name pathname)
  63.                 (cons-if (pathname-type pathname)
  64.                      (cons-if (pathname-version pathname)
  65.                           '()))))))
  66.  
  67. (declare (integrate-operator cons-if))
  68.  
  69. (define (cons-if item rest)
  70.   (if item
  71.       (cons item rest)
  72.       rest))
  73.  
  74. (define (find-node node node-list)
  75.   (if (null? node-list)
  76.       node
  77.       (let ((node (node/associate node (car node-list))))
  78.     (and node
  79.          (find-node node (cdr node-list))))))
  80.  
  81. (define (find-or-create-node node node-list)
  82.   (if (null? node-list)
  83.       node
  84.       (let ((next (node/associate node (car node-list))))
  85.     (if next
  86.         (find-or-create-node next (cdr node-list))
  87.         (create-node node node-list)))))
  88.  
  89. (define (create-node node node-list)
  90.   (let ((next (node/make)))
  91.     (set-node/alist! node
  92.              (cons (cons (car node-list) next)
  93.                (node/alist node)))
  94.     (if (null? (cdr node-list))
  95.     next
  96.     (create-node next (cdr node-list)))))
  97.  
  98. (set! pathname-map/make
  99.   (named-lambda (pathname-map/make)
  100.     (cons pathname-map/tag (node/make))))
  101.  
  102. (set! pathname-map?
  103.   (named-lambda (pathname-map? object)
  104.     (and (pair? object)
  105.      (eq? (car object) pathname-map/tag))))
  106.  
  107. (set! pathname-map/lookup
  108.   (named-lambda (pathname-map/lookup map pathname if-found if-not)
  109.     (let ((node
  110.        (find-node (pathname-map/root-node map)
  111.               (make-node-list pathname))))
  112.       (if node
  113.       (let ((value (node/value node)))
  114.         (if (eq? value unbound-value)
  115.         (if-not)
  116.         (if-found value)))
  117.       (if-not)))))
  118.  
  119. (set! pathname-map/insert!
  120.   (named-lambda (pathname-map/insert! map pathname value)
  121.     (set-node/value! (find-or-create-node (pathname-map/root-node map)
  122.                       (make-node-list pathname))
  123.              value)))
  124.  
  125. unspecific)