;;; -*- Mode: Common-Lisp; Package: fs; Base: 10.; Patch-File: T -*- ;;; Reason: Fixed parse-pathname to handle with-respect-to. ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 03/02/90 13:40:23 by BERGER, ;;; while running on Pasteur from band LOD2 ;;; With SYSTEM 6.30, VIRTUAL-MEMORY 6.3, EH 6.6, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.3, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.1, ;;; DISK-IO 6.2, DISK-LABEL 6.0, BASIC-FILE 6.8, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.1, ;;; COMPILER 6.14, TV 6.24, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.12, ;;; DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.5, MAIL-READER 6.7, TELNET 6.1, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.7, TI-CLOS 6.39, CLEH 6.5, IP 3.57, ;;; Experimental CLX 6.8, CLUE 6.60, X11M 6.20, Experimental BUG 11.18, RPC 6.2, ;;; microcode 648, Band Name: rel6.0 1/23 #!C ; From file PARSE.LISP#> PATHNAME; sys: #10R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "FILE-SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: PATHNAME; PARSE.#" (DEFUN PARSE-PATHNAME (THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (START 0.) END JUNK-ALLOWED) "Parse THING into a pathname and return it. THING can be a pathname already (it is just passed back), a string or symbol, or a Maclisp-style namelist. WITH-RESPECT-TO can be NIL or a host or host-name; if it is not NIL, the pathname is parsed for that host and it is an error if the pathname specifies a different host. If WITH-RESPECT-TO is NIL, then DEFAULTS is used to get the host if none is specified. DEFAULTS may be a host object in this case. START and END are indices specifying a substring of THING to be parsed. They default to 0 for START and NIL (meaning end of THING) for END. If JUNK-ALLOWED is non-NIL, parsing stops without error if the syntax is invalid, and this function returns NIL. The second value is the index in THING at which parsing stopped. If JUNK-ALLOWED is T and there was invalid syntax, this is the index of the invalid character." (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*)) (DECLARE (VALUES PARSED-PATHNAME PARSE-END-INDEX)) (WHEN (STREAMP THING) (SETQ THING (SEND THING :PATHNAME))) (WHEN (STREAMP DEFAULTS) (SETQ DEFAULTS (SEND DEFAULTS :PATHNAME))) (AND WITH-RESPECT-TO (SETQ WITH-RESPECT-TO (GET-PATHNAME-HOST WITH-RESPECT-TO))) ;(and with-respect-to (stringp with-respect-to ) (setf with-respect-to (si:parse-host with-respect-to ))) ; DAB 10-04-89 (CONDITION-RESUME '((PATHNAME-ERROR) :NEW-PATHNAME T ("Proceed, supplying a new pathname.") PARSE-PATHNAME-THROW-NEW-PATHNAME) (LET (host-specified (PARSE-PATHNAME-FLAG JUNK-ALLOWED)) (CATCH-CONTINUATION 'PARSE-PATHNAME #'(LAMBDA (INDEX-OR-PATHNAME) (IF (NUMBERP INDEX-OR-PATHNAME) (VALUES () (MIN (OR END (LENGTH THING)) INDEX-OR-PATHNAME)) (VALUES INDEX-OR-PATHNAME START))) () (COND ((TYPEP THING 'PATHNAME) (AND WITH-RESPECT-TO (NEQ WITH-RESPECT-TO (PATHNAME-HOST THING)) (IF PARSE-PATHNAME-FLAG (VALUES () 0.) (FERROR 'PATHNAME-PARSE-ERROR "Host ~A in ~A does not match ~A" (PATHNAME-HOST THING) THING WITH-RESPECT-TO))) (VALUES THING START)) ((CONSP THING) (SETQ THING (CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST THING)) (LET (DEVICE DIRECTORY NAME TYPE VERSION HOST) (COND ((CONSP (CAR THING)) (SETF `((,DEVICE ,DIRECTORY) ,NAME ,TYPE ,VERSION) THING)) ((NUMBERP (THIRD THING)) (SETF `(,NAME ,TYPE ,VERSION ,DEVICE ,DIRECTORY) THING)) (T (SETF `(,NAME ,TYPE ,DEVICE ,DIRECTORY ,VERSION) THING))) (SETQ HOST (COND ((GET-PATHNAME-HOST DEVICE T)) (WITH-RESPECT-TO) ((TYPEP DEFAULTS 'SI:BASIC-HOST) DEFAULTS) (T (DEFAULT-HOST DEFAULTS)))) (AND WITH-RESPECT-TO (NEQ WITH-RESPECT-TO HOST) (IF PARSE-PATHNAME-FLAG (VALUES () 0.) (FERROR 'PATHNAME-PARSE-ERROR "Host ~A in ~A does not match ~A" HOST THING WITH-RESPECT-TO))) (VALUES (MAKE-PATHNAME :HOST HOST :DEVICE DEVICE :DIRECTORY DIRECTORY :NAME NAME :TYPE TYPE :VERSION VERSION) START))) ((AND (FBOUNDP 'MAGTAPE-FILEHANDLE) ; We've got to make sure the mt: package exists (MAGTAPE-FILEHANDLE THING)) THING) ; else we die during builds. (T (SETQ THING (STRING THING)) (if with-respect-to (let ((start1 start)) ;save start in case with-respect-to is a mac and first node ;happens to be a host name we know. 1.11.88 (MULTIPLE-VALUE-setq (HOST-SPECIFIED START END) ;bump past any host we know. (PARSE-PATHNAME-FIND-COLON THING START END T)) (if (and host-specified (eq (send with-respect-to :pathname-flavor) 'FS:MAC-PATHNAME)) ;10.23.87 MBC (progn (when (neq host-specified with-respect-to) ;;;;don't skip nodes that look like host we know ;;; But do skip a node if it is our MAC host name. 1.11.88 (setf start start1)) (setf host-specified with-respect-to)) ;force mac-host parse 1.11.88 (if (AND HOST-SPECIFIED (NEQ WITH-RESPECT-TO HOST-SPECIFIED)) (FERROR 'PATHNAME-PARSE-ERROR "Host ~A in ~A does not match ~A" (PATHNAME-HOST THING) THING WITH-RESPECT-TO)))) (MULTIPLE-VALUE-setq (HOST-SPECIFIED START END) (PARSE-PATHNAME-FIND-COLON THING START END NIL))) ;MBC 1.28.87 ;; If the thing before the colon is really a host, ;; and WITH-RESPECT-TO was specified, then they had better match (LET* ((HOST (COND ((GET-PATHNAME-HOST HOST-SPECIFIED T)) (WITH-RESPECT-TO (GET-PATHNAME-HOST WITH-RESPECT-TO)) ;02-02-88 DAB ((TYPEP DEFAULTS 'SI:BASIC-HOST) DEFAULTS) (T (DEFAULT-HOST DEFAULTS))))) (CONDITION-CASE-if ;New handler - MBC 1.28.87 parse-pathname-flag ;cond form (ERROR-OBJECT) ;variables ;body (MULTIPLE-VALUE-BIND (DEVICE DIRECTORY NAME TYPE VERSION PARSE-END QUOTED-STRING) (FUNCALL (SAMPLE-PATHNAME HOST) :PARSE-NAMESTRING (NOT (NULL HOST-SPECIFIED)) THING START END) (VALUES ;; If device is :NO-INTERN then immeditely return 2nd value, DIRECTORY. ;; this provides a way to bypass as much of this lossage as possible ;; in cases where it doesnt make sense. (COND ((EQ DEVICE :NO-INTERN) DIRECTORY) (T ;; Otherwise we assume we got the raw forms of everything. (MAKE-PATHNAME-INTERNAL QUOTED-STRING HOST DEVICE DIRECTORY NAME TYPE VERSION))) PARSE-END)) (PATHNAME-PARSE-ERROR ;clause (IF (and (numberp (SEND ERROR-OBJECT :PARSE-END-INDEX)) ;07-11-88 DAB (ZEROP (SEND ERROR-OBJECT :PARSE-END-INDEX))) (VALUES () 0.) (IF (NULL (SEND ERROR-OBJECT :PARSE-END-INDEX)) (signal ERROR-OBJECT) (MULTIPLE-VALUE-BIND (DEVICE DIRECTORY NAME TYPE VERSION PARSE-END QUOTED-STRING) (FUNCALL (SAMPLE-PATHNAME HOST) :PARSE-NAMESTRING (NOT (NULL HOST-SPECIFIED)) THING START (SEND ERROR-OBJECT :PARSE-END-INDEX)) (VALUES ;; If device is :NO-INTERN then immeditely return 2nd value, DIRECTORY. ;; this provides a way to bypass as much of this lossage as possible ;; in cases where it doesnt make sense. (COND ((EQ DEVICE :NO-INTERN) DIRECTORY) (T ;; Otherwise we assume we got the raw forms of everything. (MAKE-PATHNAME-INTERNAL QUOTED-STRING HOST DEVICE DIRECTORY NAME TYPE VERSION))) PARSE-END))))))))))))) ))