;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; Patch file for System version 78.10 ;;; Reason: Improvements to pathname merging. ;;; Written 12/11/81 07:17:45 by DLA, ;;; while running on Lisp Machine Eighteen from band 3 ;;; with System 78.9, ZMail 38.1, Local-File 30.3, microcode 836. ; From file PATHNM > LMIO; AI: #8R FILE-SYSTEM:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (DEFUN MAKE-PATHNAME-1 (&REST OPTIONS &AUX NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION DEFAULTS NEW-HOST ACTOR STRUCTURED-DEVICE STRUCTURED-DIRECTORY STRUCTURED-NAME) (SETQ DEFAULTS (OR (GET (LOCF OPTIONS) ':DEFAULTS) *DEFAULT-PATHNAME-DEFAULTS*) NEW-HOST (OR (GET (LOCF OPTIONS) ':HOST) (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T)))) (SETQ ACTOR (DEFAULT-PATHNAME DEFAULTS NEW-HOST NIL NIL T)) (TV:DOPLIST (OPTIONS VAL KEY) (SELECTQ KEY (:DEFAULTS) (:HOST) (:DEVICE (SETQ NEW-DEVICE VAL STRUCTURED-DEVICE NIL)) (:STRUCTURED-DEVICE (SETQ NEW-DEVICE VAL STRUCTURED-DEVICE T)) (:DIRECTORY (SETQ NEW-DIRECTORY VAL STRUCTURED-DIRECTORY NIL)) (:STRUCTURED-DIRECTORY (SETQ NEW-DIRECTORY VAL STRUCTURED-DIRECTORY T)) (:NAME (SETQ NEW-NAME VAL STRUCTURED-NAME NIL)) (:STRUCTURED-NAME (SETQ NEW-NAME VAL STRUCTURED-NAME T)) (:TYPE (SETQ NEW-TYPE VAL)) (:VERSION (SETQ NEW-VERSION VAL)) (OTHERWISE (FERROR NIL "~S is not a recognized option" KEY)))) ;; The new fields are parsed only once to save time, consing, and possible errors ;; due to incompatible fields in different types of pathnames. (AND NEW-DEVICE (SETQ NEW-DEVICE (FUNCALL ACTOR (IF STRUCTURED-DEVICE ':PARSE-STRUCTURED-DEVICE-SPEC ':PARSE-DEVICE-SPEC) NEW-DEVICE))) (AND NEW-DIRECTORY (SETQ NEW-DIRECTORY (FUNCALL ACTOR (IF STRUCTURED-DIRECTORY ':PARSE-STRUCTURED-DIRECTORY-SPEC ':PARSE-DIRECTORY-SPEC) NEW-DIRECTORY))) (AND NEW-NAME (SETQ NEW-NAME (FUNCALL ACTOR (IF STRUCTURED-NAME ':PARSE-STRUCTURED-NAME-SPEC ':PARSE-NAME-SPEC) NEW-NAME))) (AND NEW-TYPE (SETQ NEW-TYPE (FUNCALL ACTOR ':PARSE-COMPONENT-SPEC NEW-TYPE))) (MAKE-PATHNAME-INTERNAL (GET-PATHNAME-HOST NEW-HOST) NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION)) ;;; Fill in slots in PATHNAME from program defaults. This is what most ;;; programs interface to. (DEFUN MERGE-PATHNAME-DEFAULTS (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (DEFAULT-TYPE ':UNSPECIFIC) (DEFAULT-VERSION ':NEWEST) &AUX HOST DEFAULT NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION) (SETQ PATHNAME (PARSE-PATHNAME PATHNAME NIL DEFAULTS)) ;; Host always comes from pathname (SETQ HOST (PATHNAME-HOST PATHNAME)) ;; Get default for this host (SETQ DEFAULT (DEFAULT-PATHNAME DEFAULTS HOST)) ;; Merge the device, directory, and name (LET ((PDIR (PATHNAME-DIRECTORY PATHNAME)) (DDIR (PATHNAME-DIRECTORY DEFAULT))) (SETQ NEW-DIRECTORY (COND ((NULL PDIR) DDIR) ((AND (LISTP PDIR) (EQ (CAR PDIR) ':RELATIVE)) (MERGE-RELATIVE-DIRECTORY PDIR DDIR))))) (OR (PATHNAME-DEVICE PATHNAME) (SETQ NEW-DEVICE (PATHNAME-DEVICE DEFAULT))) (OR (PATHNAME-NAME PATHNAME) (SETQ NEW-NAME (PATHNAME-NAME DEFAULT))) ;; Merge the type and version if the name was NIL before the above merge (COND ((NULL (PATHNAME-NAME PATHNAME)) (OR (PATHNAME-TYPE PATHNAME) (SETQ NEW-TYPE (PATHNAME-TYPE DEFAULT))) (OR (PATHNAME-VERSION PATHNAME) (SETQ NEW-VERSION (PATHNAME-VERSION DEFAULT))))) (OR (PATHNAME-TYPE PATHNAME) NEW-TYPE (SETQ NEW-TYPE DEFAULT-TYPE)) (OR (PATHNAME-VERSION PATHNAME) NEW-VERSION (SETQ NEW-VERSION DEFAULT-VERSION)) ;; Whatever the new fields are, give them to the pathname. ;; I think this is the only way to do this without consing. (%ASSURE-PDL-ROOM 12.) ;Worst case (%OPEN-CALL-BLOCK PATHNAME 0 4) ;D-RETURN (%PUSH ':NEW-PATHNAME) (COND (NEW-DEVICE (%PUSH (IF (LISTP NEW-DEVICE) ':STRUCTURED-DEVICE ':DEVICE)) (%PUSH NEW-DEVICE))) (COND (NEW-DIRECTORY (%PUSH (IF (LISTP NEW-DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY)) (%PUSH NEW-DIRECTORY))) (COND (NEW-NAME (%PUSH (IF (LISTP NEW-NAME) ':STRUCTURED-NAME ':NAME)) (%PUSH NEW-NAME))) (COND (NEW-TYPE (%PUSH ':TYPE) (%PUSH NEW-TYPE))) (COND (NEW-VERSION (%PUSH ':VERSION) (%PUSH NEW-VERSION))) (%ACTIVATE-OPEN-CALL-BLOCK)) (DEFUN OPEN (FILENAME &REST KEYWORD-ARGS) (FORCE-USER-TO-LOGIN) (SETQ FILENAME (MERGE-PATHNAME-DEFAULTS FILENAME)) (SETQ LAST-FILE-OPENED FILENAME) (IF (OR (NULL KEYWORD-ARGS) ;No args is good args (NOT (NULL (CDR KEYWORD-ARGS)))) (LEXPR-FUNCALL FILENAME ':OPEN FILENAME KEYWORD-ARGS) ;; Old Syntax. (DO ((KEYL (IF (AND (CAR KEYWORD-ARGS) (SYMBOLP (CAR KEYWORD-ARGS))) (LIST (CAR KEYWORD-ARGS)) (CAR KEYWORD-ARGS)) (CDR KEYL)) (KEY) (CHARACTERS T) (DIRECTION ':INPUT) (BYTE-SIZE NIL) (ERROR-P T) (ERROR-P-SPECD NIL) (DELETED-P NIL) (TEMPORARY-P NIL) ;; These two are really only useful for machines that do not natively store ;; 8-bit characters. (RAW-P NIL) (SUPER-IMAGE-P NIL) ) ((NULL KEYL) ;; Because we don't want to send meaningless keywords to file systems ;; which don't support them, and we don't want to cons... (%ASSURE-PDL-ROOM 19.) ;Worst case (%OPEN-CALL-BLOCK FILENAME 0 4) ;D-RETURN (%PUSH ':OPEN) (%PUSH FILENAME) (%PUSH ':CHARACTERS) (%PUSH CHARACTERS) (%PUSH ':DIRECTION) (%PUSH DIRECTION) (COND (BYTE-SIZE (%PUSH ':BYTE-SIZE) (%PUSH BYTE-SIZE))) (COND (ERROR-P-SPECD (%PUSH ':ERROR) (%PUSH ERROR-P))) (COND (DELETED-P (%PUSH ':DELETED) (%PUSH DELETED-P))) (COND (TEMPORARY-P (%PUSH ':TEMPORARY) (%PUSH TEMPORARY-P))) (COND (SUPER-IMAGE-P (%PUSH ':SUPER-IMAGE) (%PUSH SUPER-IMAGE-P))) (COND (RAW-P (%PUSH ':RAW) (%PUSH RAW-P))) (%ACTIVATE-OPEN-CALL-BLOCK)) (SETQ KEY (CAR KEYL)) (SELECTOR KEY STRING-EQUAL ((':IN ':READ) (SETQ DIRECTION ':INPUT)) ((':OUT ':WRITE ':PRINT) (SETQ DIRECTION ':OUTPUT)) ((':BINARY ':FIXNUM) (SETQ CHARACTERS NIL)) ((':CHARACTER ':ASCII) (SETQ CHARACTERS T)) ((':BYTE-SIZE) (SETQ KEYL (CDR KEYL) BYTE-SIZE (CAR KEYL))) ((':PROBE) (SETQ DIRECTION NIL CHARACTERS NIL ERROR-P-SPECD T ERROR-P NIL)) ((':NOERROR) (SETQ ERROR-P NIL ERROR-P-SPECD T)) ((':ERROR) (SETQ ERROR-P T ERROR-P-SPECD T)) ((':RAW) (SETQ RAW-P T)) ((':SUPER-IMAGE) (SETQ SUPER-IMAGE-P T)) ((':DELETED) (SETQ DELETED-P T)) ((':TEMPORARY) (SETQ TEMPORARY-P T)) ((':BLOCK ':SINGLE) ) ;Ignored for compatility with Maclisp (OTHERWISE (FERROR NIL "~S is not a known OPEN option" KEY)))))) )