LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030591. :SYSTEM-TYPE :LOGICAL :VERSION 16. :TYPE "LISP" :NAME "LOCAL-FILE-ACCESS" :DIRECTORY ("REL3-SOURCE" "FILE") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758307953. :AUTHOR "REL3" :LENGTH-IN-BYTES 13181. :LENGTH-IN-BLOCKS 13. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     ;;; -*- Mode:Common-Lisp; Package:FS; cold-load:t; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;;;; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;;; ;;; Local-file;;;;;; REVISIONS:;;;02.18.87 MBCMake :COMPLETE-STRING pick up default version & type if needed.;;;01.28.87 MBCTranslate new-pathname before doing a RENAME.;;;12.09.86 MBCAdd :HOMEDIR method.;;;12.18.86 MBCMake methods, (:OPEN, :DELETE-AND-EXPUNGE, :DELETE-MULTIPLE-FILES,;;;:DELETE-AND-EXPUNGE-MULTIPLE-FILES, & :MULTIPLE-FILE-PLISTS) pass on ;;;translated components to lmfs (local file system) routines.(defflavor LOCAL-FILE   ((net:name :local-file)    (net:desirability .75))   (net:service-implementation-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables)(host:define-service-implementation 'local-file)(defmethod (LOCAL-FILE :OPEN) (medium pathname &optional options)  (declare (ignore medium))  ;; Be sure to use the translated pathname here.  (let ((lm-signal-pathname-object (translated-pathname pathname)))    (declare (special lm-signal-pathname-object))    (apply #'fs:lmfs-open-file pathname   (pathname-directory lm-signal-pathname-object)   (pathname-name lm-signal-pathname-object)   (pathname-type lm-signal-pathname-object)   (pathname-version lm-signal-pathname-object) options)))(defmethod (Local-File :HOMEDIR) (Medium Pathname &optional (id user-id))  (declare (ignore medium))  (SEND pathname :new-directory id))(defmethod (LOCAL-FILE :DELETE) (medium pathname &optional error-p)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (identify-file-operation :delete      (handling-errors error-p(opening-input-file (file (pathname-directory pathname) (pathname-name pathname)  (pathname-type pathname) (pathname-version pathname))  (IF (DIRECTORY? FILE)      (progn(if (eq (directory-files file) :disk);to delete empty directories    (read-directory-files file))(IF (NULL (DIRECTORY-FILES FILE))    (LMFS-DELETE-FILE FILE)    (LM-SIGNAL-ERROR 'DIRECTORY-NOT-EMPTY)))      (LMFS-DELETE-FILE FILE))  )))))(defmethod (LOCAL-FILE :DELETE-AND-EXPUNGE) (medium pathname &optional error-p)  (declare (ignore medium))  (let ((lm-signal-pathname-object (translated-pathname pathname)))    (declare (special lm-signal-pathname-object))    (identify-file-operation :delete-and-expunge      (handling-errors error-p(let ((file (lookup-file (pathname-directory lm-signal-pathname-object) (pathname-name lm-signal-pathname-object) (pathname-type lm-signal-pathname-object) (pathname-version lm-signal-pathname-object) :error)))  (IF (DIRECTORY? FILE)      (progn(if (eq (directory-files file) :disk);to delete empty directories    (read-directory-files file))(IF (NULL (DIRECTORY-FILES FILE))    (LMFS-EXPUNGE-FILE FILE)    (LM-SIGNAL-ERROR 'DIRECTORY-NOT-EMPTY)))      (LMFS-EXPUNGE-FILE FILE))  (write-directory-files (file-directory file))  (file-npages file))))))(defmethod (LOCAL-FILE :UNDELETE) (medium pathname &optional error-p)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (identify-file-operation :undelete      (handling-errors error-p(opening-input-file (file (pathname-directory pathname)  (pathname-name pathname)  (pathname-type pathname)  (pathname-version pathname))  (lmfs-undelete-file file))))))(defmethod (LOCAL-FILE :EXPUNGE) (medium pathname &optional error-p)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (identify-file-operation :expunge      (handling-errors error-p(if (null (lookup-directory (pathname-directory pathname)) )    (lm-signal-error 'directory-not-found)    (lmfs-expunge-directory (pathname-directory pathname)     (if (null (pathname-name pathname)) :wild (pathname-name pathname))    (if (null (pathname-type pathname)) :wild (pathname-type pathname))     (if (null (pathname-version pathname)) :wild(pathname-version pathname))))))))(defmethod (LOCAL-FILE :DELETE-MULTIPLE-FILES) (medium pathnames &optional error-p)    (declare (ignore medium))  (let (lm-signal-pathname-object)    (declare (special lm-signal-pathname-object))    (identify-file-operation :delete      (handling-errors error-p(loop for pathname in pathnames      with files-of-directory-to-write = nil      do (setf lm-signal-pathname-object (translated-pathname pathname))      do (opening-input-file (file (pathname-directory lm-signal-pathname-object)   (pathname-name lm-signal-pathname-object)   (pathname-type lm-signal-pathname-object)   (pathname-version lm-signal-pathname-object))   (IF (DIRECTORY? FILE)       (progn (if (eq (directory-files file) :disk)     (read-directory-files file)) (IF (NULL (DIRECTORY-FILES FILE))     (LMFS-DELETE-FILE FILE nil)     (LM-SIGNAL-ERROR 'DIRECTORY-NOT-EMPTY)))       (LMFS-DELETE-FILE FILE nil))      (loop for entry in files-of-directory-to-write when (equal (file-directory file) (file-directory entry)) return nil finally (push file files-of-directory-to-write)))      finally      (dolist (file files-of-directory-to-write)(write-directory-of-file file)))))))(defmethod (LOCAL-FILE :DELETE-AND-EXPUNGE-MULTIPLE-FILES) (medium pathnames &optional error-p)  (declare (ignore medium))   (let ((lm-signal-pathname-object))    (declare (special lm-signal-pathname-object))    (identify-file-operation :delete      (handling-errors error-p(let ((file-list nil)      (total-pages 0))  (loop for pathname in pathnameswith files-of-directory-to-write = nil        do (setf lm-signal-pathname-object (translated-pathname pathname))do (let ((file (lookup-file (pathname-directory lm-signal-pathname-object)    (pathname-name lm-signal-pathname-object)    (pathname-type lm-signal-pathname-object)    (pathname-version lm-signal-pathname-object) :error)))     (IF (DIRECTORY? FILE) (progn   (if (eq (directory-files file) :disk);to delete empty directories       (read-directory-files file))   (IF (NULL (DIRECTORY-FILES FILE))       (LMFS-EXPUNGE-FILE FILE nil)       (LM-SIGNAL-ERROR 'DIRECTORY-NOT-EMPTY))) (LMFS-EXPUNGE-FILE FILE nil))     (push file file-list)     (setq total-pages (+ (file-npages file) total-pages))     (loop for entry in files-of-directory-to-write   when (equal (file-directory file) (file-directory entry))   return nil   finally (push file files-of-directory-to-write)))finally(progn  (dolist (file files-of-directory-to-write)    (write-directory-of-file file))  (using-put    (dolist (file file-list)      (change-map-disk-space (file-map file)     (if (file-deleted? file) put-reserved put-used)     put-free)))))  total-pages)))))(defmethod (LOCAL-FILE :RENAME) (medium pathname new-pathname &optional error-p)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (setf new-pathname (translated-pathname new-pathname));If new one is logical. 1.28.87 MBC    (identify-file-operation :rename      (handling-errors error-p(unless (eq (pathname-host pathname) (send new-pathname :host))  (lm-signal-error 'different-hosts-specified-for-rename))(unless (lookup-directory (pathname-directory new-pathname) t)  (lm-signal-error 'directory-not-found new-pathname))(when (string-equal (send pathname :type) "DIRECTORY")  (when      (do ((dir1 (send pathname :directory) (cdr dir1))         (dir2 (send new-pathname :directory) (cdr dir2)) (i 0 (1+ i)))        ((or (eq dir1 :root)     (eq dir2 :root)     (null dir1)) (if (eq dir2 :root) ()      (if dir2 (string-equal (send pathname :name) (car dir2)))))      (unless (string-equal (car dir1) (car dir2))(return nil)))    (lm-signal-error 'rename-over-itself-error pathname)))(opening-input-file (file (pathname-directory pathname)  (pathname-name pathname)  (pathname-type pathname)  (pathname-version pathname))  (lmfs-rename-file file    (pathname-directory new-pathname)    (or (pathname-name new-pathname) "FOO")    (or (pathname-type new-pathname) :unspecific)    (pathname-version new-pathname)))))))(defmethod (LOCAL-FILE :DIRECTORY-LIST) (medium pathname &optional options)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (lmfs-directory-list pathname (pathname-host pathname) (pathname-directory pathname) (pathname-name pathname) (pathname-type pathname) (pathname-version pathname) options)))(defmethod (LOCAL-FILE :ALL-DIRECTORIES) (medium pathname options)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (lmfs-all-directories (pathname-host pathname) (not (member :noerror options :test #'eq)))))(defmethod (LOCAL-FILE :PROPERTIES) (medium pathname &optional (error-p t))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))        (let ((dir (send self :directory-list medium pathname (if error-p '(:deleted) '(:noerror :deleted)))))    (cond ((consp dir)   (values (cadr dir) (get (car dir) ':settable-properties)))  (t dir)))))(defmethod (LOCAL-FILE :MULTIPLE-FILE-PLISTS) (medium pathnames options)  "This is a hack to speed up DIRED. There are no currently meaningful options."  (declare (ignore medium options))  (let ((lm-signal-pathname-object pathnames))    (declare (special lm-signal-pathname-object))    (identify-file-operation :properties      (loop for pathname in pathnames    do (setf lm-signal-pathname-object (translated-pathname pathname))        collect (cond ((null (probe-file pathname))   (list pathname))  (t   (let ((file (lookup-file (pathname-directory lm-signal-pathname-object)    (pathname-name lm-signal-pathname-object)    (pathname-type lm-signal-pathname-object)    (pathname-version lm-signal-pathname-object))))     (list* pathname    :truename (file-truename file)    (lmfs-file-properties file)))))))))(defmethod (LOCAL-FILE :CHANGE-PROPERTIES) (medium pathname &optional plist error-p)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (identify-file-operation :change-properties      (handling-errors error-p(opening-input-file (file (pathname-directory pathname) (pathname-name pathname)  (pathname-type pathname) (pathname-version pathname))  (lmfs-change-file-properties file plist))))))(defmethod (LOCAL-FILE :COMPLETE-STRING) (medium pathname string options)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))    (multiple-value-bind (dev dir nam typ ver)(send pathname :parse-namestring (pathname-host pathname) string)      ;;; These next two lines try to setup the proper type and version      (unless ver (setf ver (pathname-version pathname)));2.18.87      (unless typ (setf typ (pathname-type pathname)));2.18.87      (multiple-value-bind (new-directory new-name new-type completion)  (lmfs-complete-path (or dir (pathname-directory pathname) "") (or nam "") typ      (pathname-name pathname) (pathname-type pathname) options)(values (lm-namestring (pathname-host pathname) (or dev (pathname-device pathname))       new-directory new-name new-type       (if completion ver NIL));force NIL version if no completion 2.18.87completion)))))(defmethod (LOCAL-FILE :CREATE-DIRECTORY) (medium pathname &optional error-p)  (declare (ignore medium))  (let ((lm-signal-pathname-object pathname))    (declare (special lm-signal-pathname-object))  (identify-file-operation :create-directory    (handling-errors error-p      (lmfs-create-directory (pathname-directory pathname))      t))))(defmethod (LOCAL-FILE :CREATE-LINK) (medium pathname target error-p)  (declare (ignore medium pathname target))  (handling-errors error-p    (lm-signal-error 'links-not-supported nil nil :create-link)))(defmethod (local-file :truename) (medium pathname error-p)  (with-open-stream (stream (send self :open medium pathname `(:error ,error-p :direction nil)))    (if (errorp stream)stream(send stream :truename)))) (compile-flavor-methods local-file)W-SPACE NIL)(loc NIL)(ALLOCATED-NEW-PAGES NIL)(initial-map-block-length (map-nblocks map)))    (loop      (if (setq pointer