;;; -*- Mode: COMMON-LISP; cold-load:t; Base: 10.; Package: File-System -*- ; 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 ; AUSTIN, TEXAS 78769 ; ; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;; All "MAP-" streams are internal to the file system and support only simple ;;; serial IO. All "LM-" streams are streams used when opening files. ;;; ;;; 01-21-87 DAB Removed function calls to initialize instance vars MAP and RQB. Created a new method ;;; MAP-STREAM-MIXIN method :BEFORE :INIT to initialize these vars. ;;; 02-16-87 DAB Added :set-pointer fixes. This changed several functions including Allocate-disk-block. It also ;;; redefines bad-disk-block to be put-rsvd-not-used ;;; 04.06.87 DAB Changed lmfs-character-output-file :after :close to special case APPEND and Supersede. Open-count error. ;;; 06.26.87 DAB Changed (map-output-stream-mixin :new-output-buffer) to return a fourth value. Its value will be the ;;; number of bytes currently in this buffer or nil for new allocations. ;;; 07-23-87 DAB Added code to support File IO . ;;; 07-28-87 DAB Changed flavor mixins order for lm-character-io-stream. ;;; 07-31-87 DAB Add method :direction to lm-character-io-stream. (DEFFLAVOR MAP-STREAM-MIXIN ((STATUS ':OPEN) ;:OPEN, :EOF, :BEING-CLOSED, :CLOSED (MAP nil) ;The map this stream is acting upon. (MAP-INDEX 0.) ;Current index within map. (BYTE-SIZE 8.) ;The byte size of the STREAM. (RQB nil) ;The RQB in which the physical buffer lives. (RQB-VALID-PAGES NIL)) ;The number of pages of data in RQB () (:INCLUDED-FLAVORS si:STREAM) (:INITABLE-INSTANCE-VARIABLES MAP BYTE-SIZE) (:GETTABLE-INSTANCE-VARIABLES BYTE-SIZE)) (DEFWRAPPER (MAP-STREAM-MIXIN :CLOSE) ((&OPTIONAL IGNORE) . BODY) `(AND (NEQ STATUS ':CLOSED) (PROG1 (PROGN . ,BODY) (SETQ STATUS ':CLOSED)))) (defmethod (MAP-STREAM-MIXIN :before :init) (&optional ignore) (unless map (setq MAP (MAP-CREATE))) (unless rqb (setq RQB (GET-DISK-RQB STANDARD-BLOCK-SIZE)))) (DEFMETHOD (MAP-STREAM-MIXIN :CLOSE) (&OPTIONAL IGNORE) (AND RQB (RETURN-DISK-RQB RQB)) (SETQ RQB ())) (DEFFLAVOR MAP-INPUT-STREAM-MIXIN () (MAP-STREAM-MIXIN) (:INCLUDED-FLAVORS SI:BUFFERED-INPUT-STREAM)) (DEFFLAVOR MAP-OUTPUT-STREAM-MIXIN () (MAP-STREAM-MIXIN) (:INCLUDED-FLAVORS SI:BUFFERED-OUTPUT-STREAM)) (DEFMETHOD (MAP-INPUT-STREAM-MIXIN :NEXT-INPUT-BUFFER) (&OPTIONAL IGNORE) (COND ((EQ STATUS :CLOSED) (FERROR () "Attempt to get input from ~S, which is closed." SELF))) (LET ((MAP-NBLOCKS (MAP-NBLOCKS MAP)) SIZE) (COND ((< MAP-INDEX MAP-NBLOCKS) (SETQ STATUS :OPEN) ;May have been at :EOF (SETQ SIZE (MAP-BLOCK-SIZE MAP MAP-INDEX) RQB-VALID-PAGES (QUOTIENT-CEILING SIZE PAGE-SIZE-IN-BITS)) (LM-DISK-READ RQB (MAP-BLOCK-LOCATION MAP MAP-INDEX) RQB-VALID-PAGES) (VALUES (GET-RQB-ARRAY RQB BYTE-SIZE) 0. (FLOOR SIZE BYTE-SIZE))) ;; If we're out of range, simply call it an :EOF. (T (SETQ STATUS :EOF) NIL)))) ;; This doesn't really discard the buffer (why bother), but does increment ;; the buffer pointer for the next :NEXT-INPUT-BUFFER message. (DEFMETHOD (MAP-INPUT-STREAM-MIXIN :DISCARD-INPUT-BUFFER) (IGNORE) (INCF MAP-INDEX)) ;; This message would work, but would not do anything near what ;; the user would want -- it would just use up more disk space. (DEFMETHOD (MAP-OUTPUT-STREAM-MIXIN :FORCE-OUTPUT) IGNORE) (DEFMETHOD (MAP-OUTPUT-STREAM-MIXIN :NEW-OUTPUT-BUFFER) (&AUX LOC) (COND ((EQ STATUS :CLOSED) (FERROR () "Attempt to do output on ~S, which is closed." SELF))) (IF (= MAP-INDEX (MAP-NBLOCKS MAP)) ;; At end: add a new block. (PROGN (MULTIPLE-VALUE-SETQ (LOC RQB-VALID-PAGES) (ALLOCATE-DISK-BLOCK)) (MAP-APPEND-BLOCK MAP LOC 0.) (VALUES (GET-RQB-ARRAY RQB BYTE-SIZE) 0. (FLOOR (* RQB-VALID-PAGES PAGE-SIZE-IN-BITS) BYTE-SIZE))) ;; In the middle: read contents of next existing block ;; so that we can change only the bytes actually output. (LET ((SIZE (MAP-BLOCK-SIZE MAP MAP-INDEX)) ;(old-status status) ) (SETQ RQB-VALID-PAGES (QUOTIENT-CEILING SIZE PAGE-SIZE-IN-BITS)) (LM-DISK-READ RQB (MAP-BLOCK-LOCATION MAP MAP-INDEX) RQB-VALID-PAGES) (VALUES (GET-RQB-ARRAY RQB BYTE-SIZE) ;array 0. ;starting index (FLOOR SIZE BYTE-SIZE) ;ending index (FLOOR SIZE BYTE-SIZE))))) ; minimum index 06.26.87 DAB ;; The :NEW-OUTPUT-BUFFER method gets the old data, so this has nothing to do. (DEFMETHOD (MAP-OUTPUT-STREAM-MIXIN :GET-OLD-DATA) (&REST IGNORE) ()) (DEFMETHOD (MAP-OUTPUT-STREAM-MIXIN :DISCARD-OUTPUT-BUFFER) (BUFFER) (SEND SELF :SEND-OUTPUT-BUFFER BUFFER 0.)) ;; The next two flavors are used internally by the file system. (DEFFLAVOR MAP-CHARACTER-INPUT-STREAM () (MAP-INPUT-STREAM-MIXIN SI:BUFFERED-INPUT-CHARACTER-STREAM)) (DEFMETHOD (MAP-OUTPUT-STREAM-MIXIN :SEND-OUTPUT-BUFFER) (BUFFER TO-INDEX) (OR (AND (ARRAY-INDIRECT-P BUFFER) (EQ (%P-CONTENTS-OFFSET BUFFER (1+ (%P-LDB-OFFSET %%ARRAY-LONG-LENGTH-FLAG BUFFER 0))) RQB)) (FERROR NIL "Attempt to :SEND-OUTPUT-BUFFER ~S, which is not indirected into ~S" BUFFER RQB)) (LET* ((LOC (MAP-BLOCK-LOCATION MAP MAP-INDEX)) (SIZE (* TO-INDEX BYTE-SIZE)) (USED-NPAGES (QUOTIENT-CEILING SIZE PAGE-SIZE-IN-BITS))) (COND ((ZEROP SIZE) (setf (map-block-location map map-index) nil) ;clear current entry in map table (setf (map-block-size map map-index) nil) (DECF (MAP-NBLOCKS MAP)) (loop for I from (1- (map-nblocks map)) downto 0 do (if (eql put-rsvd-not-used (aref page-usage-table (map-block-location map i))) (progn (using-put (change-block-disk-space (map-block-location map i) (QUOTIENT-CEILING (map-block-size map i) PAGE-SIZE-IN-BITS) put-rsvd-not-used put-free)) (setf (map-block-location map i) nil) (setf (map-block-size map i) nil) (decf (map-nblocks map)) (decf map-index)) (return nil))) ) (T (LM-DISK-WRITE RQB LOC USED-NPAGES) (WHEN (< (MAP-BLOCK-SIZE MAP MAP-INDEX) SIZE) (SETF (MAP-BLOCK-SIZE MAP MAP-INDEX) SIZE)) (when (eql put-rsvd-not-used (AREF PAGE-USAGE-TABLE loc)) (SETF (MAP-BLOCK-SIZE MAP MAP-INDEX) SIZE) (loop for I from map-index downto 0 do (if (eql put-rsvd-not-used (aref page-usage-table (map-block-location map i))) (using-put (CHANGE-BLOCK-DISK-SPACE (map-block-location map i) (QUOTIENT-CEILING (map-block-size map i) PAGE-SIZE-IN-BITS) PUT-RSVD-NOT-USED PUT-RESERVED)) (return nil)))) (INCF MAP-INDEX))) (when (<= USED-NPAGES RQB-VALID-PAGES) (USING-PUT (CHANGE-BLOCK-DISK-SPACE (+ LOC USED-NPAGES) (- RQB-VALID-PAGES USED-NPAGES) PUT-RESERVED PUT-FREE t t) ;; Try to minimize small holes by backing up the search pointer. (SETQ PUT-SCANNING-INDEX (+ LOC USED-NPAGES))) ))) (DEFMETHOD (MAP-CHARACTER-INPUT-STREAM :SET-BUFFER-POINTER) (NEW-POINTER) (DO ((NBLOCKS (MAP-NBLOCKS MAP)) (I 0. (1+ I)) (P 0. P1) (P1)) (NIL) (COND ((OR (>= I NBLOCKS) (> (SETQ P1 (+ P (FLOOR (MAP-BLOCK-SIZE MAP I) BYTE-SIZE))) NEW-POINTER)) (SETQ MAP-INDEX I) (RETURN P))))) (DEFMETHOD (MAP-CHARACTER-INPUT-STREAM :SKIP-UNTIL) (CHAR &OPTIONAL (SLASHIFICATION NIL)) "Position the stream after the next occurance of CHAR. If SLASHIFICATION is non-nil, it will postion after the next non-slashified CHAR. Returns T if EOF was reached, nil otherwise." (BLOCK SKIP-UNTIL (DO ((CR-INDEX NIL) (LAST-SLASH NIL)) (NIL) (LOOP;get the correct buffer (IF (AND SI::STREAM-INPUT-BUFFER;if we are in the current buffer (< SI::STREAM-INPUT-INDEX SI::STREAM-INPUT-LIMIT)) (RETURN);we can return to main loop (UNLESS (SEND SELF :SETUP-NEXT-INPUT-BUFFER);otherwise, get the next buffer (RETURN-FROM SKIP-UNTIL T)))) (SETQ CR-INDEX (%STRING-SEARCH-CHAR CHAR;try to find CHAR in the buffer SI::STREAM-INPUT-BUFFER SI::STREAM-INPUT-INDEX SI::STREAM-INPUT-LIMIT)) (IF CR-INDEX;found one (PROGN (SETQ SI::STREAM-INPUT-INDEX (1+ CR-INDEX)) (COND ((NOT SLASHIFICATION) (RETURN-FROM SKIP-UNTIL ()));don't care about slashes ((AND (ZEROP CR-INDEX);if first character in buffer and (NOT LAST-SLASH)) (RETURN-FROM SKIP-UNTIL ()));no slash at end of preceeding buffer ((UNLESS (ZEROP CR-INDEX);unless first character in buffer, check for (NOT (OR (EQl #\\ (AREF SI::STREAM-INPUT-BUFFER (1- CR-INDEX)));both types of slashes (EQl #\/ (AREF SI::STREAM-INPUT-BUFFER (1- CR-INDEX)))))) (RETURN-FROM SKIP-UNTIL ()))));no slashes (PROGN (SETQ SI::STREAM-INPUT-INDEX SI::STREAM-INPUT-LIMIT);set index to next buffer (SETQ LAST-SLASH (AND SLASHIFICATION;if we care about slashes, see if the last ;character in the buffer is a slash and remember it (OR (EQl #\\ (AREF SI::STREAM-INPUT-BUFFER (1- SI::STREAM-INPUT-LIMIT))) (EQl #\/ (AREF SI::STREAM-INPUT-BUFFER (1- SI::STREAM-INPUT-LIMIT)))))))));return EOF )) (DEFMETHOD (MAP-CHARACTER-INPUT-STREAM :INCREMENT-POINTER) (DELTA) "Changes the current stream pointer by DELTA." (LET ((NEW-POINTER (+ DELTA SI::INPUT-POINTER-BASE (IF SI::STREAM-INPUT-INDEX (- SI::STREAM-INPUT-INDEX SI::STREAM-INPUT-LOWER-LIMIT) 0.)))) (LOOP AS NEW-RELATIVE-POINTER = (+ (- NEW-POINTER SI::INPUT-POINTER-BASE) SI::STREAM-INPUT-LOWER-LIMIT) WHEN (AND SI::STREAM-INPUT-INDEX (= NEW-RELATIVE-POINTER SI::STREAM-INPUT-INDEX)) RETURN T UNTIL (IF SI::STREAM-INPUT-BUFFER (AND (>= NEW-RELATIVE-POINTER SI::STREAM-INPUT-LOWER-LIMIT) (< NEW-RELATIVE-POINTER SI::STREAM-INPUT-LIMIT)) (= NEW-RELATIVE-POINTER SI::STREAM-INPUT-LOWER-LIMIT)) DO (SEND SELF :DISCARD-CURRENT-INPUT-BUFFER) (SETQ SI::INPUT-POINTER-BASE (SEND SELF :SET-BUFFER-POINTER NEW-POINTER)) (SEND SELF :SETUP-NEXT-INPUT-BUFFER) FINALLY (SETQ SI::STREAM-INPUT-INDEX NEW-RELATIVE-POINTER)))) (DEFFLAVOR MAP-CHARACTER-OUTPUT-STREAM () (MAP-OUTPUT-STREAM-MIXIN SI:OUTPUT-POINTER-REMEMBERING-MIXIN SI:BUFFERED-OUTPUT-CHARACTER-STREAM)) (DEFMETHOD (MAP-CHARACTER-OUTPUT-STREAM :MAP) () MAP) ;;;new code to support file io. (DEFFLAVOR MAP-CHARACTER-IO-STREAM () (Map-CHARACTER-OUTPUT-STREAM SI:BUFFERED-IO-STREAM) ) (DEFMETHOD (MAP-CHARACTER-IO-STREAM :NEXT-INPUT-BUFFER) (&OPTIONAL IGNORE) (COND ((EQ STATUS :CLOSED) (FERROR () "Attempt to get input from ~S, which is closed." SELF))) (LET ((MAP-NBLOCKS (MAP-NBLOCKS MAP)) SIZE) (COND ((< MAP-INDEX MAP-NBLOCKS) (SETQ STATUS :OPEN) ;May have been at :EOF (SETQ SIZE (MAP-BLOCK-SIZE MAP MAP-INDEX) RQB-VALID-PAGES (QUOTIENT-CEILING SIZE PAGE-SIZE-IN-BITS)) (LM-DISK-READ RQB (MAP-BLOCK-LOCATION MAP MAP-INDEX) RQB-VALID-PAGES) (VALUES (GET-RQB-ARRAY RQB BYTE-SIZE) 0. (FLOOR SIZE BYTE-SIZE))) ;; If we're out of range, simply call it an :EOF. (T (SETQ STATUS :EOF) NIL)))) (DEFMETHOD (MAP-CHARACTER-IO-STREAM :SKIP-UNTIL) (CHAR &OPTIONAL (SLASHIFICATION NIL)) "Position the stream after the next occurance of CHAR. If SLASHIFICATION is non-nil, it will postion after the next non-slashified CHAR. Returns T if EOF was reached, nil otherwise." (BLOCK SKIP-UNTIL (DO ((CR-INDEX NIL) (LAST-SLASH NIL) (real-buffer-limit nil)) (NIL) (LOOP;get the correct buffer (IF (AND SI::STREAM-outPUT-BUFFER;if we are in the current buffer (send self :check-buffer-eof)) (RETURN);we can return to main loop (UNLESS (SEND SELF :SETUP-NEXT-INPUT-BUFFER);otherwise, get the next buffer (RETURN-FROM SKIP-UNTIL T)))) (setq real-buffer-limit (if si:Stream-output-byte-limit si:Stream-output-byte-limit (if si:saved-STREAM-outPUT-index (max si:STREAM-outPUT-index si:saved-STREAM-outPUT-index) si:STREAM-outPUT-index))) (SETQ CR-INDEX (%STRING-SEARCH-CHAR CHAR;try to find CHAR in the buffer SI::STREAM-outPUT-BUFFER SI::STREAM-outPUT-INDEX real-buffer-limit)) (IF CR-INDEX;found one (PROGN (SETQ SI::STREAM-outPUT-INDEX (1+ CR-INDEX)) (COND ((NOT SLASHIFICATION) (RETURN-FROM SKIP-UNTIL ()));don't care about slashes ((AND (ZEROP CR-INDEX);if first character in buffer and (NOT LAST-SLASH)) (RETURN-FROM SKIP-UNTIL ()));no slash at end of preceeding buffer ((UNLESS (ZEROP CR-INDEX);unless first character in buffer, check for (NOT (OR (EQl #\\ (AREF SI::STREAM-outPUT-BUFFER (1- CR-INDEX)));both types of slashes (EQl #\/ (AREF SI::STREAM-outPUT-BUFFER (1- CR-INDEX)))))) (RETURN-FROM SKIP-UNTIL ()))));no slashes (PROGN (SETQ SI::STREAM-outPUT-INDEX real-buffer-limit);set index to next buffer (SETQ LAST-SLASH (AND SLASHIFICATION;if we care about slashes, see if the last ;character in the buffer is a slash and remember it (OR (EQl #\\ (AREF SI::STREAM-outPUT-BUFFER (1- real-buffer-limit))) (EQl #\/ (AREF SI::STREAM-outPUT-BUFFER (1- real-buffer-limit)))))))));return EOF )) (DEFMETHOD (MAP-CHARACTER-IO-STREAM :INCREMENT-POINTER) (DELTA) "Changes the current stream pointer by DELTA." (LET ((NEW-POINTER (+ DELTA SI::outPUT-POINTER-BASE (IF SI::STREAM-outPUT-INDEX (- SI::STREAM-outPUT-INDEX SI::STREAM-outPUT-LOWER-LIMIT) 0.)))) (LOOP AS NEW-RELATIVE-POINTER = (+ (- NEW-POINTER SI::outPUT-POINTER-BASE) SI::STREAM-outPUT-LOWER-LIMIT) WHEN (AND SI::STREAM-outPUT-INDEX (= NEW-RELATIVE-POINTER SI::STREAM-outPUT-INDEX)) RETURN T UNTIL (IF SI::STREAM-outPUT-BUFFER (AND (>= NEW-RELATIVE-POINTER SI::STREAM-outPUT-LOWER-LIMIT) (< NEW-RELATIVE-POINTER (if si:Stream-output-byte-limit si:Stream-output-byte-limit (if si:saved-STREAM-outPUT-index (max si:STREAM-outPUT-index si:saved-STREAM-outPUT-index) si:STREAM-outPUT-index)))) (= NEW-RELATIVE-POINTER SI::STREAM-outPUT-LOWER-LIMIT)) DO (SEND SELF :DISCARD-CURRENT-INPUT-BUFFER) (SETQ SI::outPUT-POINTER-BASE (SEND SELF :SET-BUFFER-POINTER NEW-POINTER)) (SEND SELF :SETUP-NEXT-INPUT-BUFFER) FINALLY (SETQ SI::STREAM-outPUT-INDEX NEW-RELATIVE-POINTER)))) (DEFMETHOD (MAP-CHARACTER-IO-STREAM :DISCARD-INPUT-BUFFER) (IGNORE) (unless (= map-index (1- (map-nblocks map))) (INCF MAP-INDEX))) ;; The next flavor is for input streams opened in an odd byte size. (DEFFLAVOR ODD-BYTE-SIZE-MIXIN () () (:REQUIRED-FLAVORS SI::MAP-INPUT-STREAM-MIXIN)) (DEFWRAPPER (ODD-BYTE-SIZE-MIXIN :NEXT-INPUT-BUFFER) ((&OPTIONAL IGNORE) . BODY) (LET ((VAL1 (GENSYM)) (VAL2 (GENSYM)) (VAL3 (GENSYM)) (I (GENSYM))) `(MULTIPLE-VALUE-BIND (,VAL1 ,VAL2 ,VAL3) (PROGN . ,BODY) (COND (,VAL1 (LOOP FOR ,I FROM ,VAL2 BELOW ,VAL3 DO (ASET (LDB BYTE-SIZE (GLOBAL:AREF ,VAL1 ,I)) ,VAL1 ,I)))) (VALUES ,VAL1 ,VAL2 ,VAL3)))) (DEFFLAVOR LM-STREAM-MIXIN (TRUENAME) (SI:PROPERTY-LIST-MIXIN SI:FILE-STREAM-MIXIN) (:GETTABLE-INSTANCE-VARIABLES TRUENAME) (:INIT-KEYWORDS :FILE :APPEND :TRUENAME)) (DEFMETHOD (LM-STREAM-MIXIN :INIT) (PLIST) (LET ((FILE (GET PLIST :FILE))) (IF FILE (SETQ TRUENAME (FILE-TRUENAME FILE) SI:PROPERTY-LIST (LMFS-FILE-PROPERTIES FILE)) (SETQ TRUENAME (GET PLIST :TRUENAME))))) (DEFMETHOD (LM-STREAM-MIXIN :QFASLP) () (GETF SI:PROPERTY-LIST :QFASLP)) ;; For probes, assume you really mean :LENGTH-IN-BYTES (DEFMETHOD (LM-STREAM-MIXIN :LENGTH) () (GETF SI:PROPERTY-LIST :LENGTH-IN-BYTES)) (DEFFLAVOR LM-DATA-STREAM-MIXIN (FILE) (LM-STREAM-MIXIN) (:INCLUDED-FLAVORS MAP-STREAM-MIXIN) (:INITABLE-INSTANCE-VARIABLES FILE)) (DEFMETHOD (LM-DATA-STREAM-MIXIN :STATUS) () STATUS) (DEFMETHOD (LM-DATA-STREAM-MIXIN :DELETE) (&OPTIONAL (ERROR-P T)) (IDENTIFY-FILE-OPERATION :DELETE (HANDLING-ERRORS ERROR-P (LMFS-DELETE-FILE FILE)))) (DEFMETHOD (LM-DATA-STREAM-MIXIN :RENAME) (NEW-NAME &OPTIONAL (ERROR-P T)) (let ((lm-signal-pathname-object self)) (declare (special lm-signal-pathname-object)) (IDENTIFY-FILE-OPERATION :RENAME (HANDLING-ERRORS ERROR-P (UNLESS (EQ (SEND (SEND SELF :TRUENAME) :HOST) (SEND NEW-NAME :HOST)) (LM-SIGNAL-ERROR 'DIFFERENT-HOSTS-SPECIFIED-FOR-RENAME)) (UNLESS (LOOKUP-DIRECTORY (PATHNAME-DIRECTORY NEW-NAME) T) (LM-SIGNAL-ERROR 'DIRECTORY-NOT-FOUND NEW-NAME)) (SETQ TRUENAME (LMFS-RENAME-FILE FILE (PATHNAME-DIRECTORY NEW-NAME) (PATHNAME-NAME NEW-NAME) (PATHNAME-TYPE NEW-NAME) (PATHNAME-VERSION NEW-NAME))))))) (DEFMETHOD (LM-DATA-STREAM-MIXIN :CHANGE-PROPERTIES) (ERROR-P &REST PROPERTIES) (IDENTIFY-FILE-OPERATION :CHANGE-PROPERTIES (HANDLING-ERRORS ERROR-P (LMFS-CHANGE-FILE-PROPERTIES FILE PROPERTIES)))) (DEFMETHOD (LM-DATA-STREAM-MIXIN :INIT) (IGNORE) (SETQ MAP (FILE-MAP FILE) TRUENAME (FILE-TRUENAME FILE) SI:PROPERTY-LIST (LMFS-FILE-PROPERTIES FILE)) (WITHOUT-INTERRUPTS (SETQ LM-FILE-STREAMS-LIST (CONS-IN-AREA SELF LM-FILE-STREAMS-LIST LOCAL-FILE-SYSTEM-AREA)))) (DEFMETHOD (LM-DATA-STREAM-MIXIN :SET-BUFFER-POINTER) (NEW-POINTER) (let ((pointer NIL) (ALLOCATED-NEW-SPACE NIL) (loc NIL) (ALLOCATED-NEW-PAGES NIL) (initial-map-block-length (map-nblocks map))) (loop (if (setq pointer (loop for I from 0 to (1- (map-nblocks map)) for p = 0 then p1 for p1 = (+ P (FLOOR (MAP-BLOCK-SIZE MAP I) BYTE-SIZE)) do (progn (when (> p1 new-pointer) (setf map-index i) (return p)) ) finally (return nil))) (RETURN pointer) (progn (SETF ALLOCATED-NEW-SPACE T) (MULTIPLE-VALUE-setq (LOC ALLOCATED-NEW-PAGES) (ALLOCATE-DISK-BLOCK STANDARD-BLOCK-SIZE put-rsvd-not-used)) ;there should be a block-to-pages form. (MAP-APPEND-BLOCK MAP LOC (* page-size-in-bits allocated-new-pages))))) (values pointer (if (= initial-map-block-length 0) T ALLOCATED-NEW-SPACE)))) (DEFFLAVOR LM-INPUT-STREAM-MIXIN () (LM-DATA-STREAM-MIXIN SI:INPUT-FILE-STREAM-MIXIN) (:INCLUDED-FLAVORS MAP-STREAM-MIXIN)) (DEFFLAVOR LM-OUTPUT-STREAM-MIXIN ((start-map-index nil) ;added instance variable 02-09-88 DAB (start-map-size nil)) (LM-DATA-STREAM-MIXIN SI:OUTPUT-FILE-STREAM-MIXIN) (:GETTABLE-INSTANCE-VARIABLES) (:SETTABLE-INSTANCE-VARIABLES) (:INCLUDED-FLAVORS MAP-STREAM-MIXIN)) (DEFMETHOD (LM-OUTPUT-STREAM-MIXIN :DISCARD-OUTPUT-BUFFER) (BUFFER) (if (and start-map-index (eq start-map-index map-index)) (SEND SELF :SEND-OUTPUT-BUFFER BUFFER start-map-size) (SEND SELF :SEND-OUTPUT-BUFFER BUFFER 0.))) (DEFMETHOD (LM-INPUT-STREAM-MIXIN :AFTER :CLOSE) (&OPTIONAL IGNORE) (LET ((DEFAULT-CONS-AREA LOCAL-FILE-SYSTEM-AREA)) (LMFS-CLOSE-FILE FILE) (WITHOUT-INTERRUPTS (SETQ LM-FILE-STREAMS-LIST (DELETE SELF (THE LIST LM-FILE-STREAMS-LIST) :TEST #'EQ :COUNT 1.))) (SETQ FILE () MAP ()))) ;Remove pointers into temp area. ;; For input streams, :LENGTH may be different from :LENGTH-IN-BYTES (DEFMETHOD (LM-INPUT-STREAM-MIXIN :LENGTH) () (FLOOR (* (GETF SI:PROPERTY-LIST :LENGTH-IN-BYTES) (GETF SI:PROPERTY-LIST :BYTE-SIZE)) BYTE-SIZE)) ;;;New Method to assure :set-buffer-pointer does not set the pointer past EOF. (defmethod (LM-INPUT-STREAM-MIXIN :around :SET-BUFFER-POINTER) (cont mt arg new-pointer &rest ignore) (if (>= new-pointer (send self :LENGTH)) ;Do not allow a pointer to be position pass the EOF for input files. (FERROR () "Attempted to set the pointer beyond the end of the file ~a" SELF) (apply 'funcall-with-mapping-table cont mt arg))) (DEFMETHOD (LM-OUTPUT-STREAM-MIXIN :AFTER :INIT) (INIT-PLIST) (WHEN (GET INIT-PLIST :APPEND) ;;;02-11-88 DAB IF we are appending to an existing file we want the index pointing to the next char position ;;;in the last allocated block. We can do this if the file is not empty and the last allocation is not full. (SETQ MAP-INDEX (MAP-NBLOCKS MAP)) ;This will causes a new allocation in :new-output-buffer (unless (zerop (MAP-length MAP)) ;Is the file empty? (setq MAP-INDEX (1- map-index)) ;This will point to the last map allocation. (send self :setup-new-output-buffer) ; bring in the last buffer. (setf SI:stream-output-index ;Adjust the index pass the last byte. (+ SI:stream-output-index (floor (map-block-size map map-index) byte-size))) (setf SI:stream-output-limit (floor ;adjust the limit to the next full page. (* (ceiling (map-block-size map map-index) page-size-in-bits) page-size-in-bits) byte-size)) (setf SI:stream-output-byte-limit SI:stream-output-index) (setf start-map-index MAP-INDEX) ;These two variables will used used to cleanup after a :close with :abort. (setf start-map-size SI:stream-output-index) ;see discard-output-buffer. )) ) (DEFMETHOD (LM-OUTPUT-STREAM-MIXIN :AFTER :CLOSE) (&OPTIONAL ABORTP) (LET ((DEFAULT-CONS-AREA LOCAL-FILE-SYSTEM-AREA)) (IF (and ABORTP (not (minusp (file-open-count file)))) ;append and supersede 04.06.87 DAB (PROGN (LMFS-EXPUNGE-FILE FILE) (WRITE-DIRECTORY-FILES (FILE-DIRECTORY FILE))) (LMFS-CLOSE-FILE FILE)) (WITHOUT-INTERRUPTS (SETQ LM-FILE-STREAMS-LIST (DELETE SELF (THE LIST LM-FILE-STREAMS-LIST) :TEST #'EQ :COUNT 1.))) (SETQ FILE () MAP ()))) ;Remove pointers into temp area. (DEFFLAVOR LM-IO-STREAM-MIXIN () (LM-OUTPUT-STREAM-MIXIN SI:IO-FILE-STREAM-MIXIN) ) ;07-23-87 DAB (DEFFLAVOR LM-INPUT-STREAM () (LM-INPUT-STREAM-MIXIN MAP-INPUT-STREAM-MIXIN SI:BUFFERED-INPUT-STREAM)) (DEFFLAVOR LM-OUTPUT-STREAM () (LM-OUTPUT-STREAM-MIXIN MAP-OUTPUT-STREAM-MIXIN SI:BUFFERED-OUTPUT-STREAM)) (DEFFLAVOR LM-IO-STREAM () ;07-23-87 DAB (SI:BUFFERED-IO-STREAM LM-IO-STREAM-MIXIN MAP-character-IO-STREAM si:output-pointer-remembering-mixin )) (DEFFLAVOR LM-CHARACTER-INPUT-STREAM () (LM-INPUT-STREAM-MIXIN MAP-INPUT-STREAM-MIXIN SI:BUFFERED-INPUT-CHARACTER-STREAM)) (DEFFLAVOR LM-CHARACTER-OUTPUT-STREAM () (LM-OUTPUT-STREAM-MIXIN MAP-OUTPUT-STREAM-MIXIN SI:BUFFERED-OUTPUT-CHARACTER-STREAM)) (DEFFLAVOR LM-CHARACTER-IO-STREAM () ;07-23-87 DAB (MAP-CHARACTER-IO-STREAM SI:BUFFERED-IO-CHARACTER-STREAM LM-IO-STREAM-MIXIN ;07-28-87 DAB si:output-pointer-remembering-mixin )) (defmethod (LM-CHARACTER-IO-STREAM :direction) ;07-31-87 DAB () :IO) (DEFFLAVOR LM-PROBE-STREAM () (LM-STREAM-MIXIN STREAM) ;; Kludge so that OPEN can pass this a :BYTE-SIZE :DEFAULT (:INIT-KEYWORDS :BYTE-SIZE)) (DEFMETHOD (LM-PROBE-STREAM :STATUS) () :CLOSED) (DEFMETHOD (LM-PROBE-STREAM :DIRECTION) () ()) (DEFMETHOD (LM-PROBE-STREAM :BYTE-SIZE) () (GETF SI:PROPERTY-LIST :BYTE-SIZE)) ;;;update stream supports directory inplace updates (DEFFLAVOR MAP-CHARACTER-UPDATE-STREAM () (MAP-OUTPUT-STREAM-MIXIN SI:OUTPUT-POINTER-REMEMBERING-MIXIN SI:BUFFERED-OUTPUT-CHARACTER-STREAM)) (DEFMETHOD (MAP-CHARACTER-UPDATE-STREAM :SET-BUFFER-POINTER) (NEW-POINTER) (DO ((NBLOCKS (MAP-NBLOCKS MAP)) (I 0 (1+ I)) (P 0 P1) (P1)) (NIL) (COND ((OR (>= I NBLOCKS) (> (SETQ P1 (+ P (FLOOR (MAP-BLOCK-SIZE MAP I) BYTE-SIZE))) NEW-POINTER)) (SETQ MAP-INDEX I) (RETURN P))))) (DEFMETHOD (MAP-CHARACTER-UPDATE-STREAM :SEND-OUTPUT-BUFFER) (BUFFER TO-INDEX) (OR (AND (ARRAY-INDIRECT-P BUFFER) (EQ (%P-CONTENTS-OFFSET BUFFER (1+ (%P-LDB-OFFSET %%ARRAY-LONG-LENGTH-FLAG BUFFER 0))) RQB)) (FERROR NIL "Attempt to :SEND-OUTPUT-BUFFER ~S, which is not indirected into ~S" BUFFER RQB)) (LET* ((LOC (MAP-BLOCK-LOCATION MAP MAP-INDEX)) (SIZE (* TO-INDEX BYTE-SIZE)) (USED-NPAGES (QUOTIENT-CEILING SIZE PAGE-SIZE-IN-BITS))) (UNLESS (ZEROP SIZE) (LM-DISK-WRITE RQB LOC USED-NPAGES)))) (DEFMETHOD (MAP-CHARACTER-UPDATE-STREAM :NEW-OUTPUT-BUFFER) () (WHEN (EQ STATUS ':CLOSED) (FERROR NIL "Attempt to do output on ~S, which is closed." SELF)) (WHEN (>= MAP-INDEX (MAP-NBLOCKS MAP)) (FERROR NIL "Attempt to do update ~S past the end of file." SELF)) (LET ((SIZE (MAP-BLOCK-SIZE MAP MAP-INDEX))) (SETQ RQB-VALID-PAGES (QUOTIENT-CEILING SIZE PAGE-SIZE-IN-BITS)) (LM-DISK-READ RQB (MAP-BLOCK-LOCATION MAP MAP-INDEX) RQB-VALID-PAGES) (VALUES (GET-RQB-ARRAY RQB BYTE-SIZE) 0 (FLOOR SIZE BYTE-SIZE)))) (COMPILE-FLAVOR-METHODS MAP-CHARACTER-INPUT-STREAM MAP-CHARACTER-OUTPUT-STREAM MAP-CHARACTER-update-STREAM LM-INPUT-STREAM LM-OUTPUT-STREAM LM-CHARACTER-INPUT-STREAM LM-CHARACTER-OUTPUT-STREAM LM-PROBE-STREAM map-character-io-stream ;07-23-87 DAB LM-IO-STREAM LM-CHARACTER-IO-STREAM) (DEFUN MAKE-MAP-STREAM (FLAVOR &REST INIT-PLIST) (INSTANTIATE-FLAVOR FLAVOR (LOCF INIT-PLIST) t () LOCAL-FILE-SYSTEM-AREA)) (DEFUN MAKE-MAP-STREAM-IN (MAP) (MAKE-MAP-STREAM 'MAP-CHARACTER-INPUT-STREAM :MAP MAP)) (DEFUN MAKE-MAP-STREAM-OUT () (MAKE-MAP-STREAM 'MAP-CHARACTER-OUTPUT-STREAM :MAP (MAP-CREATE 4.))) ;Internal things tend to be small. (defun MAKE-MAP-STREAM-update (&rest arg) (MAKE-MAP-STREAM 'MAP-CHARACTER-update-STREAM :MAP (car arg))) ;; A simple stream for reading and writing the disk configuration. ;; DISK-CONFIGURATION-BUFFER-POINTER must be bound for this stream to work. (DEFun DISK-CONFIGURATION-STREAM (operation &optional char &rest arg) (case operation (:TYI (CHAR-INT (AREF DISK-CONFIGURATION-BUFFER (PROG1 DISK-CONFIGURATION-BUFFER-POINTER (INCF DISK-CONFIGURATION-BUFFER-POINTER))))) (:UNTYI (DECF DISK-CONFIGURATION-BUFFER-POINTER) CHAR) (:TYO (SETF (AREF DISK-CONFIGURATION-BUFFER (PROG1 DISK-CONFIGURATION-BUFFER-POINTER (INCF DISK-CONFIGURATION-BUFFER-POINTER))) CHAR)) (t (apply #'DISK-CONFIGURATION-STREAM-DEFAULT operation char arg)))) (DEFUN DISK-CONFIGURATION-STREAM-DEFAULT (OP &OPTIONAL ARG1 &REST ARGS) (STREAM-DEFAULT-HANDLER #'DISK-CONFIGURATION-STREAM OP ARG1 ARGS))