DataMuseum.dk

top - download

    Length: 8803 (0x2263)
    Types: TextFile
    Names: »pathnm.scm.15«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/pathnm.scm.15« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Pathnames

(declare (usual-integrations))

(define merge-pathnames)
(define make-pathname)
(define pathname-components)
(define pathname-device)
(define pathname-directory)
(define pathname-name)
(define pathname-type)
(define pathname-version)
(define string->pathname)
(define pathname->string)

(let ()
\f


;;;; Merge

;;; This is very simple minded, compared to LispM version.  It
;;; basically replaces wildcards in the target pathname with
;;; components from the source pathname.  Obviously there shouldn't be
;;; any wildcards in the source unless you expect to get them in the
;;; result.

(set! merge-pathnames
      (named-lambda (merge-pathnames target source)
	(make-pathname (merge-pathname-components (pathname-device target)
						  (pathname-device source))
		       (merge-pathname-directories (pathname-directory target)
						   (pathname-directory source))
		       (merge-pathname-components (pathname-name target)
						  (pathname-name source))
		       (merge-pathname-components (pathname-type target)
						  (pathname-type source))
		       (merge-pathname-components (pathname-version target)
						  (pathname-version source)))))

(define (merge-pathname-directories target source)
  (cond ((eq? target 'WILD) source)
	((null? target) '())
	((null? source) target)
	(else
	 (cons (merge-pathname-components (car target) (car source))
	       (merge-pathname-directories (cdr target) (cdr source))))))
			     
(define (merge-pathname-components target source)
  (cond ((eq? target 'WILD) source)
	(else target)))
\f


;;;; Basic Pathnames

(set! make-pathname
      (named-lambda (make-pathname device directory name type version)
	(define self
	  (the-environment))

	(define (:print-self)
	  (unparse-with-brackets
	   (lambda ()
	     (*unparse-string "PATHNAME ")
	     (*unparse-object (pathname->string self)))))

	self))

(set! pathname-components
      (named-lambda (pathname-components pathname receiver)
	(receiver (access device pathname)
		  (access directory pathname)
		  (access name pathname)
		  (access type pathname)
		  (access version pathname))))

(set! pathname-device
      (named-lambda (pathname-device pathname)
	(access device pathname)))

(set! pathname-directory
      (named-lambda (pathname-directory pathname)
	(access directory pathname)))

(set! pathname-name
      (named-lambda (pathname-name pathname)
	(access name pathname)))

(set! pathname-type
      (named-lambda (pathname-type pathname)
	(access type pathname)))

(set! pathname-version
      (named-lambda (pathname-version pathname)
	(access version pathname)))
\f


;;;; Parse

(set! string->pathname
      (named-lambda (string->pathname string)
	(parse-pathname string make-pathname)))

(define (parse-pathname pathname receiver)
  (parse-device pathname
    (lambda (device rest)
      (parse-directory rest
	(lambda (directory rest)
	  (parse-name rest
	    (lambda (name rest)
	      (parse-type rest
		(lambda (type rest)
		  (receiver device
			    directory
			    name
			    type
			    (parse-version rest)))))))))))

;;; It would be nice to recognize the "#n:" syntax and store the
;;; device as an integer.

(define (parse-device string receiver)
  (if (conjunction (> (string-size string) 0)
		   (= (string-ref string 0) #/*))
      (receiver 'SYSTEM (substring string 1 (string-size string)))
      (let ((index (string-index string #/:)))
	(if index
	    (receiver (wildify (substring string 0 index))
		      (substring string (1+ index) (string-size string)))
	    (receiver '() string)))))

;;; It is not possible to parse a 'WILD directory, and it should be.

(define (parse-directory string receiver)
  (let ((index (string-index string #//)))
    (if index
	(parse-directory (substring string (1+ index) (string-size string))
	  (lambda (directory rest)
	    (receiver (cons (wildify (substring string 0 index)) directory)
		      rest)))
	(receiver '() string))))
\f


(define (parse-name string receiver)
  (let ((index (string-index string #/.)))
    (if index
	(receiver (wildify (substring string 0 index))
		  (substring string (1+ index) (string-size string)))
	(receiver (wildify string) '()))))

(define (parse-type string-or-null receiver)
  (if (null? string-or-null)
      (receiver '() '())
      (let ((index (string-index string-or-null #/.)))
	(if index
	    (receiver (wildify (substring string-or-null 0 index))
		      (substring string-or-null
				 (1+ index)
				 (string-size string-or-null)))
	    (receiver (wildify string-or-null) '())))))

(define (parse-version string-or-null)
  (cond ((null? string-or-null) '())
	((string-equal? string-or-null "") "")
	((all-digits? (string->list string-or-null))
	 (with-input-from-string string-or-null read))
	(else 
	 (wildify string-or-null))))

(define (all-digits? digits)
  (disjunction (null? digits)
	       (conjunction (vector-1b-ref *digit-bit* (car digits))
			    (all-digits? (cdr digits)))))

(define (wildify string)
  (if (string-equal? string "=")
      'WILD
      string))
\f


;;;; Unparse

(set! pathname->string
      (named-lambda (pathname->string pathname)
	(pathname-components pathname unparse-pathname)))

(define (unparse-pathname device directory name type version)
  (unparse-device device
		  (unparse-directory directory
				     (unparse-name name type version))))

(define (unparse-name name type version)
  (let ((name-string (unparse-component name))
	(type-string (unparse-component type))
	(version-string (unparse-component version)))
    (if name-string
	(if type-string
	    (if version-string
		(string-append name-string "." type-string "." version-string)
		(string-append name-string "." type-string))
	    (if version-string
		(string-append name-string ".." version-string)
		name-string))
	(if type-string
	    (if version-string
		(string-append "." type-string "." version-string)
		(string-append "." type-string))
	    (if version-string
		(string-append ".." version-string)
		"")))))

(define (unparse-directory directory rest)
  (cond ((null? directory) rest)
	((list? directory)
	 (let loop ((directory directory))
	   (let ((directory-string (unparse-component (car directory)))
		 (rest (if (null? (cdr directory))
			   rest
			   (loop (cdr directory)))))
	     (if directory-string
		 (string-append directory-string "/" rest)
		 rest))))
	(else
	 (error "Unrecognizable directory" directory))))

(define (unparse-device device rest)
  (let ((device-string (unparse-component device)))
    (if device-string
	(string-append device-string ":" rest)
	(if (eq? device 'SYSTEM)
	    (string-append "*" rest)
	    rest))))

(define (unparse-component component)
  (cond ((string? component) component)
	((eq? component 'WILD) "=")
	((integer? component) (prin1-to-string component))
	(else #!FALSE)))
\f


;;;; Strings

(define (string-split-right string index receiver)
  (if index
      (receiver (substring string 0 index)
		(substring string (1+ index) (string-size string)))
      (receiver '() string)))

(define (string-split-left string index receiver)
  (if index
      (receiver (substring string 0 index)
		(substring string (1+ index) (string-size string)))
      (receiver string "")))

(define (string-index string character)
  (string-position string #o177 character))

;;; end LET.
)