From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 11 Sep 1995 19:07:16 +0000 (+0000)
Subject: Add new condition type ILLEGAL-PATHNAME-COMPONENT so that pathname
X-Git-Tag: 20090517-FFI~5962
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f4ca838155df32109c32d588ec8c66df64063e14;p=mit-scheme.git

Add new condition type ILLEGAL-PATHNAME-COMPONENT so that pathname
parsing errors can be caught.
---

diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm
index c0572ad61..3f2163485 100644
--- a/v7/src/runtime/dospth.scm
+++ b/v7/src/runtime/dospth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dospth.scm,v 1.27 1995/07/11 22:31:03 cph Exp $
+$Id: dospth.scm,v 1.28 1995/09/11 19:07:10 cph Exp $
 
 Copyright (c) 1992-95 Massachusetts Institute of Technology
 
@@ -200,12 +200,13 @@ MIT in each case. |#
 			       sub-directory-delimiter-string
 			       (loop (cdr directory)))))))
 	(else
-	 (error "Illegal pathname directory:" directory))))
+	 (error:illegal-pathname-component directory "directory"))))
 
 (define (unparse-directory-component component)
   (cond ((eq? component 'UP) "..")
 	((string? component) component)
-	(else (error "Illegal pathname directory component:" component))))
+	(else
+	 (error:illegal-pathname-component component "directory component"))))
 
 (define (unparse-name name type)
   (let ((name (or (unparse-component name) ""))
@@ -217,7 +218,7 @@ MIT in each case. |#
 (define (unparse-component component)
   (cond ((or (not component) (string? component)) component)
 	((eq? component 'WILD) "*")
-	(else (error "Illegal pathname component:" component))))
+	(else (error:illegal-pathname-component component "component"))))
 
 ;;;; Pathname Constructors
 
@@ -226,8 +227,7 @@ MIT in each case. |#
    host
    (cond ((string? device) device)
 	 ((memq device '(#F UNSPECIFIC)) device)
-	 (else
-	  (error:wrong-type-argument device "pathname device" 'MAKE-PATHNAME)))
+	 (else (error:illegal-pathname-component device "device")))
    (cond ((or (not directory) (eq? directory 'UNSPECIFIC))
 	  directory)
 	 ((and (list? directory)
@@ -242,19 +242,18 @@ MIT in each case. |#
 		       (eq? element 'UP)))))
 	  (simplify-directory directory))
 	 (else
-	  (error:wrong-type-argument directory "pathname directory"
-				     'MAKE-PATHNAME)))
+	  (error:illegal-pathname-component directory "directory")))
    (if (or (memq name '(#F WILD))
 	   (and (string? name) (not (string-null? name))))
        name
-       (error:wrong-type-argument name "pathname name" 'MAKE-PATHNAME))
+       (error:illegal-pathname-component name "name"))
    (if (or (memq type '(#F WILD))
 	   (and (string? type) (not (string-null? type))))
        type
-       (error:wrong-type-argument type "pathname type" 'MAKE-PATHNAME))
+       (error:illegal-pathname-component type "type"))
    (if (memq version '(#F UNSPECIFIC WILD NEWEST))
        'UNSPECIFIC
-       (error:wrong-type-argument version "pathname version" 'MAKE-PATHNAME))))
+       (error:illegal-pathname-component version "version"))))
 
 (define (%%make-pathname host device directory name type version)
   ;; This is a kludge to make the \\foo\bar notation work correctly.
diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index deb2200ba..700fe4fb6 100644
--- a/v7/src/runtime/error.scm
+++ b/v7/src/runtime/error.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: error.scm,v 14.45 1993/12/23 08:03:22 cph Exp $
+$Id: error.scm,v 14.46 1995/09/11 19:05:26 cph Exp $
 
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -684,6 +684,7 @@ MIT in each case. |#
 (define condition-type:floating-point-overflow)
 (define condition-type:floating-point-underflow)
 (define condition-type:illegal-datum)
+(define condition-type:illegal-pathname-component)
 (define condition-type:no-such-restart)
 (define condition-type:port-error)
 (define condition-type:serious-condition)
@@ -710,6 +711,7 @@ MIT in each case. |#
 (define error:derived-file)
 (define error:derived-port)
 (define error:derived-thread)
+(define error:illegal-pathname-component)
 (define error:wrong-number-of-arguments)
 (define error:wrong-type-argument)
 (define error:wrong-type-datum)
@@ -885,6 +887,16 @@ MIT in each case. |#
 		       (write-string " arguments" port))))
 	      (write-char #\. port)))))
 
+  (set! condition-type:illegal-pathname-component
+	(make-condition-type 'ILLEGAL-PATHNAME-COMPONENT
+	    condition-type:wrong-type-datum
+	  (lambda (condition port)
+	    (write-string "The object " port)
+	    (write (access-condition condition 'DATUM) port)
+	    (write-string " is not a valid pathname " port)
+	    (write (access-condition condition 'TYPE) port)
+	    (write-string "." port))))
+
   (set! condition-type:control-error
 	(make-condition-type 'CONTROL-ERROR condition-type:error '()
 	  "Control error."))
@@ -1112,6 +1124,10 @@ MIT in each case. |#
 	(condition-signaller condition-type:wrong-number-of-arguments
 			     '(DATUM TYPE OPERANDS)
 			     standard-error-handler))
+  (set! error:illegal-pathname-component
+	(condition-signaller condition-type:illegal-pathname-component
+			     '(DATUM TYPE)
+			     standard-error-handler))
   (set! error:divide-by-zero
 	(condition-signaller condition-type:divide-by-zero
 			     '(OPERATOR OPERANDS)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7c53ff4a5..ad1dadf8e 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.261 1995/08/08 15:30:04 adams Exp $
+$Id: runtime.pkg,v 14.262 1995/09/11 19:06:33 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -585,6 +585,7 @@ MIT in each case. |#
 	  condition-type:floating-point-overflow
 	  condition-type:floating-point-underflow
 	  condition-type:illegal-datum
+	  condition-type:illegal-pathname-component
 	  condition-type:no-such-restart
 	  condition-type:port-error
 	  condition-type:serious-condition
@@ -622,6 +623,7 @@ MIT in each case. |#
 	  error:derived-thread
 	  error:divide-by-zero
 	  error:file-operation
+	  error:illegal-pathname-component
 	  error:no-such-restart
 	  error:wrong-number-of-arguments
 	  error:wrong-type-argument
diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm
index 63a85340e..cb4ae439f 100644
--- a/v7/src/runtime/unxpth.scm
+++ b/v7/src/runtime/unxpth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxpth.scm,v 14.18 1995/04/09 22:32:33 cph Exp $
+$Id: unxpth.scm,v 14.19 1995/09/11 19:07:16 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -160,12 +160,13 @@ MIT in each case. |#
 			       "/"
 			       (loop (cdr directory)))))))
 	(else
-	 (error "Illegal pathname directory:" directory))))
+	 (error:illegal-pathname-component directory "directory"))))
 
 (define (unparse-directory-component component)
   (cond ((eq? component 'UP) "..")
 	((string? component) component)
-	(else (error "Illegal pathname directory component:" component))))
+	(else
+	 (error:illegal-pathname-component component "directory component"))))
 
 (define (unparse-name name type)
   (let ((name (or (unparse-component name) ""))
@@ -177,7 +178,7 @@ MIT in each case. |#
 (define (unparse-component component)
   (cond ((or (not component) (string? component)) component)
 	((eq? component 'WILD) "*")
-	(else (error "Illegal pathname component:" component))))
+	(else (error:illegal-pathname-component component "component"))))
 
 ;;;; Pathname Constructors
 
@@ -186,7 +187,7 @@ MIT in each case. |#
    host
    (if (memq device '(#F UNSPECIFIC))
        'UNSPECIFIC
-       (error:wrong-type-argument device "pathname device" 'MAKE-PATHNAME))
+       (error:illegal-pathname-component device "device"))
    (cond ((not directory)
 	  directory)
 	 ((and (list? directory)
@@ -199,19 +200,18 @@ MIT in each case. |#
 		       (eq? element 'UP)))))
 	  (simplify-directory directory))
 	 (else
-	  (error:wrong-type-argument directory "pathname directory"
-				     'MAKE-PATHNAME)))
+	  (error:illegal-pathname-component directory "directory")))
    (if (or (memq name '(#F WILD))
 	   (and (string? name) (not (string-null? name))))
        name
-       (error:wrong-type-argument name "pathname name" 'MAKE-PATHNAME))
+       (error:illegal-pathname-component name "name"))
    (if (or (memq type '(#F WILD))
 	   (and (string? type) (not (string-null? type))))
        type
-       (error:wrong-type-argument type "pathname type" 'MAKE-PATHNAME))
+       (error:illegal-pathname-component type "type"))
    (if (memq version '(#F UNSPECIFIC WILD NEWEST))
        'UNSPECIFIC
-       (error:wrong-type-argument version "pathname version" 'MAKE-PATHNAME))))
+       (error:illegal-pathname-component version "version"))))
 
 (define (unix/pathname-as-directory pathname)
   (let ((name (%pathname-name pathname))
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 52494dd8f..b7c177f24 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.263 1995/08/08 15:30:29 adams Exp $
+$Id: runtime.pkg,v 14.264 1995/09/11 19:05:39 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -584,6 +584,7 @@ MIT in each case. |#
 	  condition-type:floating-point-overflow
 	  condition-type:floating-point-underflow
 	  condition-type:illegal-datum
+	  condition-type:illegal-pathname-component
 	  condition-type:no-such-restart
 	  condition-type:port-error
 	  condition-type:serious-condition
@@ -621,6 +622,7 @@ MIT in each case. |#
 	  error:derived-thread
 	  error:divide-by-zero
 	  error:file-operation
+	  error:illegal-pathname-component
 	  error:no-such-restart
 	  error:wrong-number-of-arguments
 	  error:wrong-type-argument