root/trunk/lisp/lmio/qfile.lisp @ 239

Revision 239, 77.9 KB (checked in by rjs, 3 years ago)

Update.

Line 
1;;; -*- Mode: LISP; Package: FILE-SYSTEM -*-
2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
3
4;;; Also NOTE: Two people using the same CHANNEL will probably completely screw
5;;;  each other....arg, I guess this should get fixed at some point.
6;;; GC'ing of HOST-UNIT'S
7;;; Filenames with two colons (machine and device)
8
9;;; Guts of the file system
10
11(DEFVAR FILE-DEVICES NIL)           ;Alist  <device-name-string> . handler
12(DEFVAR FILE-CHANNEL NIL)           ;The current channel, bound in the stream closure
13(DEFVAR FILE-CHANNEL-CURRENT NIL)   ;The file channel currently being displayed in the
14                                    ; who-line.
15(DEFVAR FILE-PENDING-TRANSACTIONS NIL) ;Alist of pending transactions and response packets
16(DEFVAR FILE-UNIQUE-NUMBER 259.)    ;Only one of its kind
17
18;;; Each open channel has the following data structure describing it:
19(DEFSTRUCT (CHANNEL (:CONSTRUCTOR MAKE-CHANNEL) :NAMED)
20  CHANNEL-FILE-NAME                 ;Name of the file associated with this channel
21                                    ; as specified by the user.  The UNIQUE-ID property
22                                    ; records the "truename" of the file as returned by
23                                    ; the file computer
24  CHANNEL-FILE-HANDLE               ;Name by which the file is referred to by the
25                                    ;file computer.  This is a string assigned at OPEN
26                                    ;time by code herein.
27
28  CHANNEL-FILE-PROPERTIES           ;File properties as returned by OPEN, also contains
29                                    ; interesting things like async error packet
30
31  CHANNEL-FUNCTION                  ;Function to call to perform actions on this channel
32
33  CHANNEL-CONTROL-CONNECTION        ;The control connection associated with this channel
34                                    ; This is in the HOST-UNIT, but as it is used often
35                                    ; it is made more accessible by storing it here as well.
36
37  CHANNEL-HOST-UNIT-FUNCTION        ;Function to call to do operations on the HOST-UNIT
38
39  CHANNEL-STATE                     ;Current state of channel
40
41;; CHANNEL-STATE is one of:
42; OPEN - a file is currently open on this channel
43; CLOSED - no file is open, but the channel exists
44; EOF - a file is open, but is at its end (no more data available).
45; SYNC-MARKED - a mark that was requested has been received
46; ASYNC-MARKED - an asynchronous (error) mark has been received
47
48  CHANNEL-MODE                      ;Mode in which file is open
49
50;; CHANNEL-MODE can be one of
51; CHARACTER - character oriented, 8 bit bytes
52; BINARY - non-character, can be arbitrary byte size
53
54  CHANNEL-DIRECTION                 ;I/O direction
55
56;; CHANNEL-DIRECTION can be one of
57; INPUT - character input mode
58; OUTPUT - character output mode
59
60  CHANNEL-DATA-CONNECTION           ;Connection on which to transmit/receive data
61  CHANNEL-DATA-PACKET               ;Packet into which CHANNEL-DATA-ARRAY indirects
62  CHANNEL-DATA-ARRAY                ;Indirected to CHANNEL-DATA-PACKET, has correct byte size
63  (CHANNEL-DATA-POINTER 0)          ;Pointer into CHANNEL-DATA-ARRAY
64  (CHANNEL-DATA-COUNT 0)            ;Number of entities remaining in the next
65
66; For optimization of certain common filepos operations, remember the first and
67; current bufferful.  Also need the length of the current bufferful.
68  (CHANNEL-FIRST-FILEPOS 0)
69  (CHANNEL-FIRST-COUNT 0)
70  )
71
72(DEFUN CHANNEL (OP &OPTIONAL CHANNEL &REST ARGS)
73  (SELECTQ OP
74    (:WHICH-OPERATIONS '(:PRINT :PRINT-SELF))
75    ((:PRINT :PRINT-SELF)
76            (FORMAT (CAR ARGS) "#<Channel ~S ~O>"
77                    (FUNCALL (CHANNEL-FILE-NAME CHANNEL) ':STRING-FOR-PRINTING)
78                    (%POINTER CHANNEL)))
79    (OTHERWISE (FERROR NIL "No such operation ~S" OP))))
80
81(DEFMACRO CHANNEL-PROPERTY-GET (CHANNEL PROPERTY)
82  `(GET (LOCF (CHANNEL-FILE-PROPERTIES ,CHANNEL)) ,PROPERTY))
83
84(DEFMACRO CHANNEL-PROPERTY-PUTPROP (CHANNEL NEW PROPERTY)
85  `(PUTPROP (LOCF (CHANNEL-FILE-PROPERTIES ,CHANNEL)) ,NEW ,PROPERTY))
86
87(DEFMACRO CHANNEL-PROPERTY-REMPROP (CHANNEL PROPERTY)
88  `(REMPROP (LOCF (CHANNEL-FILE-PROPERTIES ,CHANNEL)) ,PROPERTY))
89
90;CHAOSnet file functions
91
92;;; Useful constants
93(DEFVAR %FILE-BINARY-OPCODE (LOGIOR CHAOS:DAT-OP 100))
94(DEFVAR %FILE-CHARACTER-OPCODE CHAOS:DAT-OP)
95(DEFVAR %FILE-COMMAND-OPCODE CHAOS:DAT-OP)
96(DEFVAR %FILE-SYNCHRONOUS-MARK-OPCODE (1+ CHAOS:DAT-OP))
97(DEFVAR %FILE-ASYNCHRONOUS-MARK-OPCODE (+ CHAOS:DAT-OP 2))
98(DEFVAR %FILE-EOF-OPCODE CHAOS:EOF-OP)
99
100(DEFMACRO FILE-GET-NEXT-PKT (CONN)
101  `(LET ((CONN ,CONN))
102    (OR (EQ (CHAOS:STATE CONN) 'CHAOS:OPEN-STATE)
103        (FERROR 'FILE-CONNECTION-TROUBLE
104                "~S went into illegal state while doing I/O on ~S"
105                CONN FILE-CHANNEL))
106    (CHAOS:GET-NEXT-PKT CONN)))
107
108(DEFMACRO FILE-GET-PKT-STRING (PKT)
109  `(PROG1 (STRING-APPEND (CHAOS:PKT-STRING ,PKT))
110          (CHAOS:RETURN-PKT ,PKT)))
111
112(DEFMACRO FILE-CONVERSION ()
113  `(COND ((EQ (CHANNEL-MODE FILE-CHANNEL) ':BINARY) 2)
114         (T 1)))
115
116(DEFMACRO FILE-CHAOSNET-NBYTES-DATA (PKT)
117  `(// (CHAOS:PKT-NBYTES ,PKT) (FILE-CONVERSION)))
118
119(DEFMACRO FILE-DATA-ARRAY-SETUP (PKT)
120  `(COND ((EQ (CHANNEL-MODE FILE-CHANNEL) ':BINARY)
121          (SETF (CHANNEL-DATA-ARRAY FILE-CHANNEL) ,PKT)
122          (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL) CHAOS:FIRST-DATA-WORD-IN-PKT))
123         (T (SETF (CHANNEL-DATA-ARRAY FILE-CHANNEL) (CHAOS:PKT-STRING ,PKT))
124            (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL) 0))))
125
126(DEFMACRO FILE-DATA-PKT-OPCODE ()
127  `(COND ((EQ (CHANNEL-MODE FILE-CHANNEL) ':BINARY) %FILE-BINARY-OPCODE)
128         (T %FILE-CHARACTER-OPCODE)))
129
130(DEFSELECT FILE-CHAOSNET-CHANNEL-FUNCTION
131  (:RETURN (PKT) (CHAOS:RETURN-PKT PKT))
132  (:COMMAND (MARK-P FHN-P SIMPLE-P &REST COMMANDS)
133     ;; MARK-P is T if writing or reading (expecting) a synchronous mark
134     ;; FHN-P is NIL if the file handle should be blank, T to use the
135     ;; channel's file-handle, or a string to be used as the file-handle.
136     (PROG ()
137      (LET ((PKT (CHAOS:GET-PKT)) (TRANSACTION-ID (FILE-MAKE-TRANSACTION-ID SIMPLE-P))
138            SUCCESS WHOSTATE STRING)
139        ;; Make up a packet containing the command to be sent over
140        (LEXPR-FUNCALL (FUNCTION CHAOS:SET-PKT-STRING) PKT
141                       TRANSACTION-ID
142                       " "
143                       (COND ((NULL FHN-P) "")
144                             ((EQ FHN-P 'T) (CHANNEL-FILE-HANDLE FILE-CHANNEL))
145                             (T FHN-P))
146                       " "
147                       COMMANDS)
148        (LET ((STRING (CHAOS:PKT-STRING PKT))
149              (FROM 0))
150          (SETQ FROM (STRING-SEARCH-CHAR #\SP STRING (1+ (STRING-SEARCH-CHAR #\SP STRING))))
151          (SETQ WHOSTATE (SUBSTRING STRING (1+ FROM)
152                                    (STRING-SEARCH-SET '(#\SP #\CR) STRING (1+ FROM)))))
153        (CHAOS:SEND-PKT (CHANNEL-CONTROL-CONNECTION FILE-CHANNEL) PKT %FILE-COMMAND-OPCODE)
154        (AND MARK-P (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':OUTPUT)
155             (FILE-WRITE-SYNCHRONOUS-MARK))
156        ;; Get the portion of the response after the transaction ID.
157        (COND (SIMPLE-P
158                (AND MARK-P (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':INPUT)
159                     (FILE-READ-UNTIL-SYNCHRONOUS-MARK))
160                (RETURN NIL T ""))
161              (T (SETQ PKT (FILE-WAIT-FOR-TRANSACTION TRANSACTION-ID
162                                                      (CHANNEL-CONTROL-CONNECTION FILE-CHANNEL)
163                                                      WHOSTATE))
164                 (SETQ STRING (NSUBSTRING (CHAOS:PKT-STRING PKT)
165                                          (1+ (STRING-SEARCH-CHAR #\SP
166                                                                  (CHAOS:PKT-STRING PKT)))))
167                 (SETQ SUCCESS
168                       (LET ((FROM (COND ((EQ FHN-P T)
169                                          (FILE-CHECK-HANDLE FILE-CHANNEL STRING))
170                                         (T (1+ (STRING-SEARCH-SET '(#\SP #\CR) STRING))))))
171                         (NOT (STRING-EQUAL "ERROR" STRING 0 FROM 5
172                                            (STRING-SEARCH-SET '(#\SP #\CR) STRING FROM)))))
173                 (AND MARK-P SUCCESS (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':INPUT)
174                      (FILE-READ-UNTIL-SYNCHRONOUS-MARK))
175                 (RETURN PKT SUCCESS STRING))))))
176  (:READ . FILE-NEXT-READ-PKT)
177  (:WRITE . FILE-NEXT-WRITE-PKT)
178  (:FORCE-OUTPUT . FILE-NEXT-WRITE-PKT)
179  (:FINISH ()
180    (DO () ((CHAOS:FINISHED-P (CHANNEL-DATA-CONNECTION FILE-CHANNEL)))
181      (PROCESS-WAIT "File Finish"
182                    #'(LAMBDA (CONN CHAN)
183                        (OR (CHAOS:FINISHED-P CONN)
184                            (EQ (CHANNEL-STATE CHAN) ':ASYNC-MARKED)))
185                    (CHANNEL-DATA-CONNECTION FILE-CHANNEL) FILE-CHANNEL)
186      (AND (EQ (CHANNEL-STATE FILE-CHANNEL) ':ASYNC-MARKED)
187           (FILE-PROCESS-OUTPUT-ASYNC-MARK))))
188  (:EOF ()
189    (FILE-NEXT-WRITE-PKT)
190    (CHAOS:SEND-PKT (CHANNEL-DATA-CONNECTION FILE-CHANNEL) (CHAOS:GET-PKT) CHAOS:EOF-OP)
191    (SETF (CHANNEL-STATE FILE-CHANNEL) ':EOF)
192    (FILE-CHAOSNET-CHANNEL-FUNCTION ':FINISH)) )
193
194; Insure response over control connection is for correct file-handle.  If not, bomb out
195; right here as the protocol has been violated.  If returning, return the string-index
196; of the first non-file-handle byte.
197(DEFUN FILE-CHECK-HANDLE (CHANNEL STRING)
198  (LET ((HANDLE-END (STRING-SEARCH-SET '(#\SP #\CR) STRING)))
199    (AND (NULL HANDLE-END)
200         (FERROR 'FILE-CONNECTION-TROUBLE
201                 "Response over control connection (channel ~S) was incorrectly formatted"
202                 CHANNEL))
203    (OR (STRING-EQUAL STRING (CHANNEL-FILE-HANDLE CHANNEL) 0 0 HANDLE-END)
204        (FERROR 'FILE-CONNECTION-TROUBLE
205                "Response over control connection (channel ~S) was for wrong file handle"
206                CHANNEL))
207    (1+ HANDLE-END)))
208
209;;; Transaction stuff: first routine allocates a transaction-id and prepares to receive
210;;;  the transaction respose.  Third routine hangs until transaction response received
211;;;  and returns the appropriate packet.
212(DEFUN FILE-MAKE-TRANSACTION-ID (&OPTIONAL (SIMPLE-P NIL) &AUX ID)
213  (WITHOUT-INTERRUPTS
214   (SETQ ID (FILE-GENSYM 'T))
215   (SETQ FILE-PENDING-TRANSACTIONS (CONS (LIST* ID SIMPLE-P NIL) FILE-PENDING-TRANSACTIONS)))
216  ID)
217
218(DEFUN FILE-GENSYM (LEADER)
219  (WITHOUT-INTERRUPTS
220   (FORMAT NIL "~A~4,48D" LEADER (SETQ FILE-UNIQUE-NUMBER
221                                       (\ (1+ FILE-UNIQUE-NUMBER) 10000.)))))
222
223(DEFUN FILE-WAIT-FOR-TRANSACTION (TID &OPTIONAL CONN (WHOSTATE "FileTransaction") &AUX ID)
224  "Wait for a transaction to complete.  SHould not be called if the transaction is simple."
225  (IF (NULL (SETQ ID (ASSOC TID FILE-PENDING-TRANSACTIONS)))
226      (FERROR NIL "Transaction ID ~A not found on pending list" TID)
227      (PROCESS-WAIT WHOSTATE #'(LAMBDA (ID CONN)
228                                 (OR (CDDR ID)
229                                     (NEQ (CHAOS:STATE CONN) 'CHAOS:OPEN-STATE)))
230                    ID CONN)
231      (COND ((NEQ (CHAOS:STATE CONN) 'CHAOS:OPEN-STATE)
232             (FERROR 'FILE-CONNECTION-TROUBLE
233                     "Connection ~S went into illegal state while waiting for a transaction"
234                     CONN))
235            (T
236             (WITHOUT-INTERRUPTS
237               (SETQ FILE-PENDING-TRANSACTIONS (DELQ ID FILE-PENDING-TRANSACTIONS))
238               (CDDR ID))))))
239
240(DEFUN FILE-NEXT-READ-PKT (&OPTIONAL IGNORE FOR-SYNC-MARK-P)
241  (OR (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':INPUT)
242      (FERROR NIL "Attempt to read from ~S, which is not an input channel" FILE-CHANNEL))
243  (SELECTQ (COND (FOR-SYNC-MARK-P ':EOF)
244                 (T (CHANNEL-STATE FILE-CHANNEL)))
245    ((:OPEN :EOF)
246     (SETF (CHANNEL-DATA-ARRAY FILE-CHANNEL) NIL)
247     (COND ((CHANNEL-DATA-PACKET FILE-CHANNEL)
248            (CHAOS:RETURN-PKT (CHANNEL-DATA-PACKET FILE-CHANNEL))
249            (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) NIL)
250            (SETF (CHANNEL-FIRST-FILEPOS FILE-CHANNEL)
251                  (+ (CHANNEL-FIRST-FILEPOS FILE-CHANNEL)
252                     (CHANNEL-FIRST-COUNT FILE-CHANNEL)))
253            (SETF (CHANNEL-FIRST-COUNT FILE-CHANNEL) 0)
254            (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) 0)))
255     (LET ((PKT (CHAOS:GET-NEXT-PKT (CHANNEL-DATA-CONNECTION FILE-CHANNEL))))
256      (COND (PKT  ;If no PKT, it return nil and try again.  Probably
257                  ; the channel state has changed.
258       (SELECT (CHAOS:PKT-OPCODE PKT)
259
260         ;; Received some sort of data
261        ((%FILE-BINARY-OPCODE %FILE-CHARACTER-OPCODE)
262         (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) PKT)
263         (FILE-DATA-ARRAY-SETUP PKT)
264         (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) (FILE-CHAOSNET-NBYTES-DATA PKT))
265         (SETF (CHANNEL-FIRST-COUNT FILE-CHANNEL) (CHANNEL-DATA-COUNT FILE-CHANNEL))
266         (COND ((AND (EQ CURRENT-PROCESS TV:LAST-WHO-LINE-PROCESS) (NOT FOR-SYNC-MARK-P))
267                (SETQ FILE-CHANNEL-CURRENT FILE-CHANNEL)
268                ;Save CPU time by not updating who-line except when going blocked
269                ;(TV:WHO-LINE-UPDATE)
270                ))
271         T)
272
273         ;; No data, but a synchronous mark
274         (%FILE-SYNCHRONOUS-MARK-OPCODE
275          (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) PKT)
276          (SETF (CHANNEL-STATE FILE-CHANNEL) ':SYNC-MARKED)
277          ':SYNC-MARKED)
278
279         ;; Received an asynchronous mark, meaning some sort of error condition
280         (%FILE-ASYNCHRONOUS-MARK-OPCODE
281          (SETF (CHANNEL-STATE FILE-CHANNEL) ':ASYNC-MARKED)
282          (OR FOR-SYNC-MARK-P (FILE-PROCESS-ASYNC-MARK PKT)))
283
284         ;; EOF received, change channel state and return
285         (%FILE-EOF-OPCODE
286          (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) PKT)
287          (SETF (CHANNEL-STATE FILE-CHANNEL) ':EOF)
288          ':EOF)
289
290         ;; Connection closed or broken with message
291         ((CHAOS:CLS-OP CHAOS:LOS-OP)
292          (FERROR 'FILE-CONNECTION-TROUBLE
293                  "Network connection ~:[broken~;closed~], reason given as /"~A/""
294                  (= (CHAOS:PKT-OPCODE PKT) CHAOS:CLS-OP) (CHAOS:PKT-STRING PKT)))
295
296         ;; Not a recognized opcode, huh?
297         (OTHERWISE
298          (FERROR 'FILE-CONNECTION-TROUBLE
299                  "Receieved data packet (~S) with illegal opcode for ~S"
300                  PKT FILE-CHANNEL)))))))
301    (:CLOSED (FERROR ':FILE-ERROR
302                     "Attempt to read from ~S, which is closed"
303                     FILE-CHANNEL))
304    ((:ASYNC-MARKED :SYNC-MARKED) (FERROR ':FILE-CONNECTION-TROUBLE
305                                        "Attempt to read from ~S, which is in a marked state"
306                                        FILE-CHANNEL))
307    (OTHERWISE (FERROR NIL "Attempt to read from ~S, which is in illegal state ~S"
308                           FILE-CHANNEL (CHANNEL-STATE FILE-CHANNEL)))))
309
310(DEFUN FILE-NEXT-WRITE-PKT (&OPTIONAL IGNORE FOR-SYNC-MARK-P)
311  (OR (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':OUTPUT)
312      (FERROR NIL "Attempt to write to ~S, which is not an output channel" FILE-CHANNEL))
313  (PROG ()
314     WRITE-LOOP
315     (SELECTQ (COND (FOR-SYNC-MARK-P ':EOF)
316                    (T (CHANNEL-STATE FILE-CHANNEL)))
317       ((:OPEN :EOF)
318        (LET ((PKT (CHANNEL-DATA-PACKET FILE-CHANNEL))
319              (COUNT (CHANNEL-DATA-COUNT FILE-CHANNEL))
320              (MAX (// CHAOS:MAX-DATA-BYTES-PER-PKT (FILE-CONVERSION))))
321          (COND ((AND PKT ( COUNT MAX))        ;If output buffer non-empty, send it
322                 (SETF (CHAOS:PKT-NBYTES PKT) (- CHAOS:MAX-DATA-BYTES-PER-PKT
323                                                 (* COUNT (FILE-CONVERSION))))
324                 (PROCESS-WAIT "File NETO"
325                               #'(LAMBDA (CHANNEL CONNECTION)
326                                         (OR (EQ (CHANNEL-STATE CHANNEL) ':ASYNC-MARKED)
327                                             (CHAOS:MAY-TRANSMIT CONNECTION)))
328                               FILE-CHANNEL (CHANNEL-DATA-CONNECTION FILE-CHANNEL))
329                 (AND (EQ (CHANNEL-STATE FILE-CHANNEL) ':ASYNC-MARKED)
330                      (GO WRITE-LOOP))
331                 (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) NIL) ;Forget before sending,
332                        ;if we quit out would get error if packet sent twice
333                 (CHAOS:SEND-PKT (CHANNEL-DATA-CONNECTION FILE-CHANNEL)
334                                 PKT
335                                 (FILE-DATA-PKT-OPCODE))
336                 (SETF (CHANNEL-FIRST-COUNT FILE-CHANNEL) 0)    ;FIRST-COUNT - DATA-COUNT = 0
337                 (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) 0)     ; for correct wholine updating
338                 (SETF (CHANNEL-FIRST-FILEPOS FILE-CHANNEL)
339                       (+ (- MAX COUNT) (CHANNEL-FIRST-FILEPOS FILE-CHANNEL)))
340                 (COND ((EQ CURRENT-PROCESS TV:LAST-WHO-LINE-PROCESS)
341                        (COND ((AND FILE-CHANNEL-CURRENT
342                                    (EQ (CHANNEL-DIRECTION FILE-CHANNEL-CURRENT) ':INPUT)))
343                              (T (SETQ FILE-CHANNEL-CURRENT FILE-CHANNEL)
344                                 ;Save CPU time by not updating who-line except
345                                 ;(TV:WHO-LINE-UPDATE)  ; when going blocked
346                                 )))))
347                (PKT (CHAOS:RETURN-PKT PKT)))  ;Return empty output buffer
348          (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) (SETQ PKT (CHAOS:GET-PKT)))
349          (FILE-DATA-ARRAY-SETUP PKT)
350          (SETF (CHANNEL-FIRST-COUNT FILE-CHANNEL) MAX)
351          (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) MAX)))
352       (:ASYNC-MARKED
353        (FILE-PROCESS-OUTPUT-ASYNC-MARK)
354        (GO WRITE-LOOP))
355       (OTHERWISE
356        (FERROR NIL "Attempt to write to ~S, which is in illegal state ~S"
357                FILE-CHANNEL (CHANNEL-STATE FILE-CHANNEL))))))
358
359;If the connection is broken or closed **This sucks completely** 
360(DEFUN FILE-READ-UNTIL-SYNCHRONOUS-MARK ()
361  (DO () ((EQ (CHANNEL-STATE FILE-CHANNEL) ':SYNC-MARKED)
362          (SETF (CHANNEL-STATE FILE-CHANNEL) ':OPEN)
363          (CHAOS:RETURN-PKT (CHANNEL-DATA-PACKET FILE-CHANNEL))
364          (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) NIL))
365    (FILE-NEXT-READ-PKT NIL T)))
366
367(DEFUN FILE-WRITE-SYNCHRONOUS-MARK ()
368  (FILE-NEXT-WRITE-PKT NIL T)    ;Checks for empty packet, ignores async marks
369  (LET ((PKT (CHAOS:GET-PKT)))
370    (SETF (CHAOS:PKT-NBYTES PKT) 0)
371    (CHAOS:SEND-PKT (CHANNEL-DATA-CONNECTION FILE-CHANNEL) PKT
372                    %FILE-SYNCHRONOUS-MARK-OPCODE)))
373
374(DEFUN FILE-PROCESS-OUTPUT-ASYNC-MARK ()
375  (LET ((PKT (CHANNEL-PROPERTY-GET FILE-CHANNEL 'ASYNC-MARK-PKT)))
376    (COND (PKT (CHANNEL-PROPERTY-REMPROP FILE-CHANNEL 'ASYNC-MARK-PKT)
377               (UNWIND-PROTECT
378                (FILE-PROCESS-ASYNC-MARK PKT)
379                (CHAOS:RETURN-PKT PKT)))
380          (T (FERROR NIL
381                     "Output channel ~S in ASYNC-MARKED state, but no async mark pkt"
382                     FILE-CHANNEL)))))
383
384(DEFUN FILE-PROCESS-ASYNC-MARK (PKT)
385    (LET ((STRING (NSUBSTRING (CHAOS:PKT-STRING PKT)
386                              (1+ (STRING-SEARCH-CHAR #\SP (CHAOS:PKT-STRING PKT))))))
387      (FILE-PROCESS-ERROR STRING FILE-CHANNEL T))       ;Process error allowing proceeding
388    ;; If user says to continue, attempt to do so.
389    (FILE-CHANNEL-OPERATIONS ':CONTINUE))
390
391;;; Reading and writing streams
392;;; WHICH-OPERATIONS: :TYI :LINE-IN :UNTYI :CLOSE :NAME :READ-POINTER :SET-POINTER
393;;;                   :REWIND :GET-INPUT-BUFFER :ADVANCE-INPUT-BUFFER
394(DEFSELECT (FILE-CHAOSNET-READ-STREAM FILE-CHANNEL-OPERATIONS)
395  (:TYI (&OPTIONAL EOF-VALUE)
396    (DO ((C-P (CHANNEL-DATA-COUNT FILE-CHANNEL))
397         (STATE))
398        ((EQ (SETQ STATE (CHANNEL-STATE FILE-CHANNEL)) ':EOF)
399         (AND EOF-VALUE (ERROR EOF-VALUE)))
400     (COND (( C-P 0)
401            (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':READ)
402            (SETQ C-P (CHANNEL-DATA-COUNT FILE-CHANNEL)))
403           (T (SELECTQ STATE
404                (:OPEN
405                 (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) (1- C-P))
406                 (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL)
407                       (1+ (SETQ C-P (CHANNEL-DATA-POINTER FILE-CHANNEL))))
408                 (RETURN (AREF (CHANNEL-DATA-ARRAY FILE-CHANNEL) C-P)))
409                ((:SYNC-MARKED :ASYNC-MARKED)
410                 (FERROR 'FILE-CONNECTION-TROUBLE
411                         "(A)synchronous mark seen when none expected on ~S"
412                         FILE-CHANNEL))
413                (:CLOSED (FERROR 'FILE-CONNECTION-TROUBLE
414                                 "~S closed trying to read"
415                                 FILE-CHANNEL))
416                (OTHERWISE (FERROR NIL "Channel ~S in unknown state" FILE-CHANNEL)))))))
417  (:LINE-IN (&OPTIONAL LEADER)
418     (PROG LINE-IN ()
419       ;; Since we always make a copy, treat LEADER specifications of T and NIL the same
420       (AND (EQ LEADER T) (SETQ LEADER NIL))
421       (COND ((EQ (CHANNEL-STATE FILE-CHANNEL) ':EOF)
422              (RETURN-FROM LINE-IN NIL T))
423             (T (DO ((MAX 100)
424                     (STRING (MAKE-ARRAY NIL 'ART-STRING 100 NIL LEADER))
425                     (STRING-IDX 0)
426                     (DATA-ARRAY (CHANNEL-DATA-ARRAY FILE-CHANNEL))
427                     (COUNT (CHANNEL-DATA-COUNT FILE-CHANNEL))
428                     (POINTER (CHANNEL-DATA-POINTER FILE-CHANNEL))
429                     (CR-IDX) (NEW-STRING-IDX) (NEW-POINTER)
430                     )
431                    (NIL)       ;Repeat for each buffer until a CR has been seen
432                  ;; First make sure we really have a buffer
433                  (COND (( COUNT 0)
434                         (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':READ)
435                         (SELECTQ (CHANNEL-STATE FILE-CHANNEL)
436                           (:OPEN
437                            (SETQ DATA-ARRAY (CHANNEL-DATA-ARRAY FILE-CHANNEL)
438                                  COUNT (CHANNEL-DATA-COUNT FILE-CHANNEL)
439                                  POINTER (CHANNEL-DATA-POINTER FILE-CHANNEL)))
440                           (:EOF (ADJUST-ARRAY-SIZE STRING STRING-IDX)
441                                 (AND LEADER (STORE-ARRAY-LEADER STRING-IDX STRING 0))
442                                 (RETURN-FROM LINE-IN STRING T))
443                           ((:SYNC-MARKED :ASYNC-MARKED)
444                            (FERROR 'FILE-CONNECTION-TROUBLE
445                                    "(A)synchronous mark seen when non expected on ~S"
446                                    FILE-CHANNEL))
447                           (:CLOSED (FERROR 'FILE-CONNECTION-TROUBLE
448                                            "~S closed while trying to read"
449                                            FILE-CHANNEL)))))
450                  ;; Now see if this buffer has a CR, and copy out the appropriate amount
451                  (SETQ CR-IDX (%STRING-SEARCH-CHAR #\CR DATA-ARRAY POINTER
452                                                    (+ POINTER COUNT)))
453                  (COND ((NULL CR-IDX)
454                         (SETQ NEW-POINTER (+ POINTER COUNT)
455                               NEW-STRING-IDX (+ STRING-IDX COUNT)
456                               COUNT 0))                         
457                        (T
458                         (SETQ NEW-POINTER (1+ CR-IDX)  ;One includes the CR the other doesn't
459                               NEW-STRING-IDX (+ STRING-IDX (- CR-IDX POINTER))
460                               COUNT (- COUNT (- NEW-POINTER POINTER)))))
461                  (AND (> NEW-STRING-IDX MAX)
462                       (SETQ STRING (ADJUST-ARRAY-SIZE STRING
463                                                       (SETQ MAX (MAX (+ MAX 100)
464                                                                      NEW-STRING-IDX)))))
465                  (COPY-ARRAY-PORTION DATA-ARRAY POINTER NEW-POINTER
466                                      STRING STRING-IDX NEW-STRING-IDX)
467                  (SETQ POINTER NEW-POINTER STRING-IDX NEW-STRING-IDX)
468                  (COND ((NOT (NULL CR-IDX))    ;This buffer is enough to satisfy
469                         (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) COUNT)
470                         (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL) POINTER)
471                         (AND LEADER (STORE-ARRAY-LEADER STRING-IDX STRING 0))
472                         (RETURN-FROM LINE-IN (ADJUST-ARRAY-SIZE STRING STRING-IDX) NIL)))
473                  )))))
474  (:UNTYI (IGNORE &AUX (C-P (CHANNEL-DATA-COUNT FILE-CHANNEL)))
475    (COND (( C-P (CHANNEL-FIRST-COUNT FILE-CHANNEL))
476           (FERROR NIL "Cannot UNTYI, no room in buffer on ~S" FILE-CHANNEL))
477          (T (WITHOUT-INTERRUPTS
478              (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) (1+ C-P))
479              (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL)
480                    (1- (CHANNEL-DATA-POINTER FILE-CHANNEL)))))))
481  (:CLOSE . FILE-CLOSE)
482  (:NAME () (FUNCALL (CHANNEL-FILE-NAME FILE-CHANNEL) ':STRING-FOR-PRINTING))
483  (:FILENAME () (CHANNEL-FILE-NAME FILE-CHANNEL))
484  (:READ-POINTER () (+ (CHANNEL-FIRST-FILEPOS FILE-CHANNEL)
485                       (- (CHANNEL-FIRST-COUNT FILE-CHANNEL)
486                          (CHANNEL-DATA-COUNT FILE-CHANNEL))))
487  (:SET-POINTER (NEW-POINTER &AUX (F-COUNT (CHANNEL-FIRST-COUNT FILE-CHANNEL))
488                                  (COUNT (CHANNEL-DATA-COUNT FILE-CHANNEL))
489                                  (F-FILEPOS (CHANNEL-FIRST-FILEPOS FILE-CHANNEL)))
490    (COND ((OR (< NEW-POINTER F-FILEPOS)
491               ( NEW-POINTER (+ F-COUNT F-FILEPOS)))
492           (SELECTQ (CHANNEL-STATE FILE-CHANNEL)
493             ((:OPEN :EOF)
494              (LET (PKT SUCCESS STRING)
495                (UNWIND-PROTECT
496                 (PROGN
497                  (MULTIPLE-VALUE (PKT SUCCESS STRING)
498                                  (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND T T NIL
499                                           "FILEPOS " (FORMAT NIL "~D" NEW-POINTER)))
500                  (OR SUCCESS
501                      (FILE-PROCESS-ERROR STRING FILE-CHANNEL NIL)) ;Cannot proceed
502                  (SETF (CHANNEL-FIRST-FILEPOS FILE-CHANNEL) NEW-POINTER)
503                  (SETF (CHANNEL-FIRST-COUNT FILE-CHANNEL) 0)
504                  (WITHOUT-INTERRUPTS
505                   (AND (EQ (CHANNEL-STATE FILE-CHANNEL) ':EOF)
506                        (SETF (CHANNEL-STATE FILE-CHANNEL) ':OPEN))))
507                 (AND PKT (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)))))
508             (OTHERWISE
509              (FERROR NIL ":SET-POINTER attempted on ~S which is in state ~S"
510                      (CHANNEL-STATE FILE-CHANNEL)))))
511          (T (LET ((OFFSET (- (- NEW-POINTER F-FILEPOS) (- F-COUNT COUNT))))
512               (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) (- COUNT OFFSET))
513               (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL)
514                     (+ OFFSET (CHANNEL-DATA-POINTER FILE-CHANNEL)))))))
515;  (:SET-POINTER (NEW-POINTER)
516;    (OR (= NEW-POINTER 0)
517;        (FERROR NIL "Attempt to do a :SET-POINTER with a non-zero arg"))
518;    (FILE-CHAOSNET-READ-STREAM ':REWIND))
519  (:REWIND ()
520    (COND ((= (CHANNEL-FIRST-FILEPOS FILE-CHANNEL) 0)
521           (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL)
522                 (+ (CHANNEL-DATA-POINTER FILE-CHANNEL)
523                    (- (CHANNEL-DATA-COUNT FILE-CHANNEL)
524                       (CHANNEL-FIRST-COUNT FILE-CHANNEL))))
525           (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) (CHANNEL-FIRST-COUNT FILE-CHANNEL)))
526          (T (CHAOS:RETURN-PKT
527               (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND T T NIL "FILEPOS 0"))
528             (SETF (CHANNEL-FIRST-FILEPOS FILE-CHANNEL) 0))))
529;The following two are experimental to see how much they speed up FASLOAD.
530;:GET-INPUT-BUFFER is like :TYI except it returns 3 values, an ARRAY, an initial index,
531;  and a count.  Count elements of the array starting with initial index are valid
532;  input items.  This call does not advance the stream at all
533;  (see ADVANCE-INPUT-BUFFER, following)
534  (:GET-INPUT-BUFFER (&OPTIONAL EOF-VALUE)
535    (DO ((C-P (CHANNEL-DATA-COUNT FILE-CHANNEL))
536         (STATE))
537        ((EQ (SETQ STATE (CHANNEL-STATE FILE-CHANNEL)) ':EOF)
538         (AND EOF-VALUE (ERROR EOF-VALUE)))
539     (COND (( C-P 0)
540            (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':READ)
541            (SETQ C-P (CHANNEL-DATA-COUNT FILE-CHANNEL)))
542           (T (SELECTQ STATE
543                (:OPEN
544                 (RETURN (CHANNEL-DATA-ARRAY FILE-CHANNEL)
545                         (CHANNEL-DATA-POINTER FILE-CHANNEL)
546                         (CHANNEL-DATA-COUNT FILE-CHANNEL)))
547                ((:SYNC-MARKED :ASYNC-MARKED)
548                 (FERROR 'FILE-CONNECTION-TROUBLE
549                         "(A)synchronous mark seen when none expected on ~S"
550                         FILE-CHANNEL))
551                (:CLOSED (FERROR 'FILE-CONNECTION-TROUBLE
552                                 "~S closed trying to read"
553                                 FILE-CHANNEL))
554                (OTHERWISE (FERROR NIL "Channel ~S in unknown state" FILE-CHANNEL)))))))
555    ;Advances stream within current buffer array.  Arg is number of entities,
556    ;if no arg, then effectively discard buffer array.
557  (:ADVANCE-INPUT-BUFFER (&OPTIONAL NEW-POINTER &AUX INCR)
558    (SETQ INCR (COND (NEW-POINTER (- NEW-POINTER (CHANNEL-DATA-POINTER FILE-CHANNEL)))
559                     (T (CHANNEL-DATA-COUNT FILE-CHANNEL))))
560    (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL)
561          (- (CHANNEL-DATA-COUNT FILE-CHANNEL) INCR))
562    (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL)
563          (+ (CHANNEL-DATA-POINTER FILE-CHANNEL) INCR))
564    INCR)
565  )
566
567(DEFSELECT (FILE-CHAOSNET-WRITE-STREAM FILE-CHANNEL-OPERATIONS)
568;;; WHICH-OPERATIONS: :TYO :CLOSE :FINISH :FORCE-OUTPUT :READ-POINTER :NAME :LINE-OUT
569;;;                   :STRING-OUT
570  (:TYO (BYTE &AUX (C-P (CHANNEL-DATA-COUNT FILE-CHANNEL)))
571    (COND (( C-P 0)
572           (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':WRITE)
573           (SETQ C-P (CHANNEL-DATA-COUNT FILE-CHANNEL))
574           (SELECTQ (CHANNEL-STATE FILE-CHANNEL)
575             (:OPEN
576              (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) (1- C-P))
577              (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL)
578                    (1+ (SETQ C-P (CHANNEL-DATA-POINTER FILE-CHANNEL))))
579              (ASET BYTE (CHANNEL-DATA-ARRAY FILE-CHANNEL) C-P))
580             ((:SYNC-MARKED :ASYNC-MARKED)
581              (FERROR 'FILE-CONNECTION-TROUBLE
582                      "(A)synchronous mark seen when not expected on ~S"
583                      FILE-CHANNEL))
584             (:CLOSED (FERROR 'FILE-CONNECTION-TROUBLE
585                              "~S closed while trying to write"
586                              FILE-CHANNEL))
587             (:EOF (FERROR 'FILE-CONNECTION-TROUBLE
588                           "~S has hit EOF, but is an output channel"
589                           FILE-CHANNEL))
590             (OTHERWISE
591              (FERROR NIL "Attempt to write to ~S, which is in illegal state ~S"
592                      FILE-CHANNEL (CHANNEL-STATE FILE-CHANNEL)))))
593          (T (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) (1- C-P))
594             (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL)
595                   (1+ (SETQ C-P (CHANNEL-DATA-POINTER FILE-CHANNEL))))
596             (ASET BYTE (CHANNEL-DATA-ARRAY FILE-CHANNEL) C-P))))
597  (:CLOSE . FILE-CLOSE)
598  (:FINISH () (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':FINISH))
599  (:FORCE-OUTPUT () (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':FORCE-OUTPUT))
600  (:NAME () (FUNCALL (CHANNEL-FILE-NAME FILE-CHANNEL) ':STRING-FOR-PRINTING))
601  (:FILENAME () (CHANNEL-FILE-NAME FILE-CHANNEL))
602  (:READ-POINTER () (+ (CHANNEL-FIRST-FILEPOS FILE-CHANNEL)
603                       (- (CHANNEL-FIRST-COUNT FILE-CHANNEL)
604                          (CHANNEL-DATA-COUNT FILE-CHANNEL))))
605  (:LINE-OUT (STRING)
606    (FILE-STRING-OUT STRING)
607    (FILE-CHAOSNET-WRITE-STREAM ':TYO #\CR))
608  (:STRING-OUT (STRING) (FILE-STRING-OUT STRING)))
609
610(DEFUN FILE-STRING-OUT (STRING)
611  (DO ((DATA-ARRAY (CHANNEL-DATA-ARRAY FILE-CHANNEL))
612       (POINTER (CHANNEL-DATA-POINTER FILE-CHANNEL))
613       (COUNT (CHANNEL-DATA-COUNT FILE-CHANNEL))
614       (STRING-IDX 0)
615       (STRING-LEN (ARRAY-ACTIVE-LENGTH STRING))
616       (AMT))
617      (( STRING-IDX STRING-LEN))       ;Repeat for each buffer until whole string out
618     ;; Make sure we have some buffer space
619     (COND (( COUNT 0)
620            (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':WRITE)
621            (SELECTQ (CHANNEL-STATE FILE-CHANNEL)
622              (:OPEN
623               (SETQ DATA-ARRAY (CHANNEL-DATA-ARRAY FILE-CHANNEL)
624                     POINTER (CHANNEL-DATA-POINTER FILE-CHANNEL)
625                     COUNT (CHANNEL-DATA-COUNT FILE-CHANNEL)))
626              ((:SYNC-MARKED :ASYNC-MARKED)
627               (FERROR 'FILE-CONNECTION-TROUBLE
628                       "(A)synchronous mark seen when not expected on ~S"
629                       FILE-CHANNEL))
630              (:CLOSED (FERROR 'FILE-CONNECTION-TROUBLE
631                               "~S closed while trying to write"
632                               FILE-CHANNEL))
633              (:EOF (FERROR 'FILE-CONNECTION-TROUBLE
634                            "~S has hit EOF, but is an output channel"
635                            FILE-CHANNEL))
636              (OTHERWISE
637               (FERROR NIL "Attempt to write to ~S, which is in illegal state ~S"
638                       FILE-CHANNEL (CHANNEL-STATE FILE-CHANNEL))))))
639     ;; Copy as much of the string as will fit
640     (SETQ AMT (MIN (- STRING-LEN STRING-IDX) COUNT))
641     (COPY-ARRAY-PORTION STRING STRING-IDX STRING-LEN
642                         DATA-ARRAY POINTER (SETQ POINTER (+ POINTER AMT)))
643     (SETQ COUNT (- COUNT AMT)
644           STRING-IDX (+ STRING-IDX AMT))
645     (SETF (CHANNEL-DATA-POINTER FILE-CHANNEL) POINTER)
646     (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) COUNT)))
647
648;;; Operations on channels for the user to call
649(DEFSELECT (FILE-CHANNEL-OPERATIONS FILE-STREAM-DEFAULT-HANDLER)
650  (:GET (PROP)
651    (CHANNEL-PROPERTY-GET FILE-CHANNEL PROP))
652  (:PUT (PROP NEW)
653    (CHANNEL-PROPERTY-PUTPROP FILE-CHANNEL NEW PROP))
654  (:SET-BYTE-SIZE (NEW-BYTE-SIZE)
655    (OR (EQ (CHANNEL-MODE FILE-CHANNEL) ':BINARY)
656        (FERROR NIL "Cannot set byte size on a character file, channel ~S" FILE-CHANNEL))
657    (COND ((AND (> NEW-BYTE-SIZE 0) ( NEW-BYTE-SIZE 16.)))
658          (T (FERROR NIL "Cannot set byte size to ~D, channel ~S"
659                     NEW-BYTE-SIZE FILE-CHANNEL)))
660    (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND T T NIL
661             "SET-BYTE-SIZE "
662             (FORMAT NIL "~D ~D"
663                     NEW-BYTE-SIZE
664                     (+ (CHANNEL-DATA-POINTER FILE-CHANNEL)
665                        (- (CHANNEL-DATA-COUNT FILE-CHANNEL)
666                           (CHANNEL-FIRST-COUNT FILE-CHANNEL)))))
667    NEW-BYTE-SIZE)
668  (:DELETE (&OPTIONAL (ERROR-P T) &AUX SUCCESS STRING)
669    (SELECTQ (CHANNEL-STATE FILE-CHANNEL)
670      ((:OPEN :EOF :SYNC-MARKED :ASYNC-MARKED)
671       (MULTIPLE-VALUE (STRING SUCCESS)
672         (FILE-CHANNEL-OPERATIONS ':COMMAND NIL "DELETE"))
673       (OR SUCCESS
674           (AND (NULL ERROR-P) STRING)
675           (FILE-PROCESS-ERROR STRING FILE-CHANNEL NIL)))
676      (OTHERWISE (FERROR NIL "~S in illegal state for delete" FILE-CHANNEL))))
677  (:RENAME (NEW-NAME &OPTIONAL (ERROR-P T) &AUX SUCCESS STRING)
678    (SELECTQ (CHANNEL-STATE FILE-CHANNEL)
679      ((:OPEN :EOF :SYNC-MARKED :ASYNC-MARKED)
680       (SETQ NEW-NAME (FILE-PARSE-NAME NEW-NAME (FUNCALL (CHANNEL-FILE-NAME FILE-CHANNEL)
681                                                         ':HOST)))
682       (MULTIPLE-VALUE (STRING SUCCESS)
683         (FILE-CHANNEL-OPERATIONS ':COMMAND NIL
684                                  (FORMAT NIL "RENAME~%~A~%"
685                                          (FUNCALL NEW-NAME ':STRING-FOR-HOST))))
686       (COND (SUCCESS
687              (SETF (CHANNEL-FILE-NAME FILE-CHANNEL) NEW-NAME)
688              (LET ((ITEM (ASSQ 'WHO-LINE-FILE-STATE TV:WHO-LINE-LIST)))
689                (AND ITEM                       ;Clobber item for full redisplay
690                     (SETF (TV:WHO-LINE-ITEM-STATE ITEM) NIL)))
691              T)
692             ((NOT ERROR-P) STRING)
693             (T (FILE-PROCESS-ERROR STRING FILE-CHANNEL NIL))))
694      (OTHERWISE (FERROR NIL "~S in illegal state for rename" FILE-CHANNEL))))
695  (:COMMAND (MARK-P COM &REST STRINGS &AUX PKT SUCCESS STRING)
696    (MULTIPLE-VALUE (PKT SUCCESS STRING)
697      (LEXPR-FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND MARK-P T NIL COM STRINGS))
698    (SETQ STRING (STRING-APPEND STRING))
699    (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)
700    (PROG () (RETURN STRING SUCCESS)))
701  (:INFO ()
702    (FORMAT NIL "~D ~A ~A"
703            (FILE-CHANNEL-OPERATIONS ':GET ':VERSION)
704            (FILE-CHANNEL-OPERATIONS ':GET ':CREATION-DATE)
705            (FILE-CHANNEL-OPERATIONS ':GET ':CREATION-TIME)))
706  (:CONTINUE . FILE-CONTINUE) )
707
708(DEFUN FILE-STREAM-DEFAULT-HANDLER (OP &OPTIONAL ARG1 &REST ARGS)
709  (STREAM-DEFAULT-HANDLER (SELECTQ (CHANNEL-DIRECTION FILE-CHANNEL)
710                            (:INPUT 'FILE-CHAOSNET-READ-STREAM)
711                            (:OUTPUT 'FILE-CHAOSNET-WRITE-STREAM))
712                          OP ARG1 ARGS))
713
714;;; For Maclisp compatibility, the OPEN function accepts keywords
715;;; from any package and translates them to the keyword package.
716;;; Note that OPEN is not called in the cold-load until after packages
717;;; have been set up (before then MINI is used).
718(DEFUN OPEN (FILENAME &OPTIONAL OPTIONS EXCEPTION-HANDLER)
719  (SETQ FILENAME (FILE-PARSE-NAME FILENAME))
720  (FORCE-USER-TO-LOGIN)
721  (AND (ATOM OPTIONS) (NOT (NULL OPTIONS))
722       (SETQ OPTIONS (LIST OPTIONS)))
723  (SETQ OPTIONS (MAPCAR #'(LAMBDA (X PKG)
724                            (IF (SYMBOLP X) (INTERN X PKG) X))
725                        OPTIONS
726                        (CIRCULAR-LIST (PKG-FIND-PACKAGE ""))))
727  (FUNCALL FILENAME ':OPEN OPTIONS EXCEPTION-HANDLER))
728 
729(DEFUN OPEN-CHAOS (HOST FILENAME OPTIONS EXCEPTION-HANDLER
730                        &AUX (MODE ':READ) (TYPE ':CHARACTER) (NOERROR-P NIL)
731                             (TEMPORARY-P NIL) (DELETED-P NIL) (RAW-P NIL) (SUPER-IMAGE-P NIL)
732                             BYTE-SIZE FILE-CHANNEL PKT SUCCESS STRING FILENAME-ORIGIN)
733  (DO-NAMED OPEN-CHAOS () (NIL) ;DO repeated if retrying from error
734    (*CATCH 'OPEN-CHAOS-RETRY (PROGN
735      (DO ((L OPTIONS (CDR L)))
736          ((NULL L))
737        (SELECTQ (CAR L)
738            ((:IN :READ) (SETQ MODE ':READ))
739            ((:OUT :WRITE :PRINT) (SETQ MODE ':WRITE))
740            (:FIXNUM (SETQ TYPE ':BINARY))
741            (:ASCII (SETQ TYPE ':CHARACTER))
742            (:SINGLE NIL)
743            (:BLOCK NIL)
744            (:BYTE-SIZE (SETQ L (CDR L)
745                              BYTE-SIZE (CAR L)))
746            (:PROBE (SETQ MODE ':PROBE
747                          TYPE ':BINARY
748                          NOERROR-P T))
749            (:NOERROR (SETQ NOERROR-P T))
750            (:ERROR (SETQ NOERROR-P NIL))
751            (:RAW (SETQ RAW-P T))
752            (:SUPER-IMAGE (SETQ SUPER-IMAGE-P T))
753            ;; These two are fot TOPS-20
754            (:DELETED (SETQ DELETED-P T))
755            (:TEMPORARY (SETQ TEMPORARY-P T))
756            (OTHERWISE (FERROR NIL "~S is not a known OPEN option" (CAR L)))))
757      (SETQ FILE-CHANNEL
758            (CHANNEL-ALLOCATE HOST
759                              ;PROBE mode implies no need for data connection
760                              (EQ MODE ':WRITE) (NEQ MODE ':PROBE)))
761      (SETF (CHANNEL-FILE-NAME FILE-CHANNEL) FILENAME)
762      (SETF (CHANNEL-STATE FILE-CHANNEL)
763            (SELECTQ MODE
764              ((:WRITE :READ) ':OPEN)
765              (:PROBE ':CLOSED)
766              (OTHERWISE (FERROR NIL
767                                 "Mode ~S is unknown.  This is an impossible error" MODE))))
768      (SETF (CHANNEL-DIRECTION FILE-CHANNEL)
769            (SELECTQ MODE
770              (:WRITE ':OUTPUT)
771              ((:READ :PROBE) ':INPUT)))
772      (SETF (CHANNEL-MODE FILE-CHANNEL) TYPE)
773      (AND EXCEPTION-HANDLER
774           (CHANNEL-PROPERTY-PUTPROP FILE-CHANNEL EXCEPTION-HANDLER ':EXCEPTION-HANDLER))
775      (MULTIPLE-VALUE (PKT SUCCESS STRING)
776        (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND NIL (NEQ MODE ':PROBE) NIL
777                 "OPEN " MODE " " TYPE
778                 (FORMAT NIL "~:[~;~0G BYTE-SIZE ~D~]~:[~; TEMPORARY~]~:[~; DELETED~]~
779                              ~:[~; RAW~]~:[~; SUPER~]~%~A~%"
780                         BYTE-SIZE TEMPORARY-P DELETED-P RAW-P SUPER-IMAGE-P
781                         (FUNCALL FILENAME ':STRING-FOR-HOST))))
782      (COND ((NOT SUCCESS)
783             (SETQ STRING (STRING-APPEND STRING))
784             (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)
785             (COND (NOERROR-P
786                    (OR (EQ MODE ':PROBE)
787                        (FUNCALL (CHANNEL-HOST-UNIT-FUNCTION FILE-CHANNEL)
788                                 ':DEALLOCATE FILE-CHANNEL))
789                    (RETURN-FROM OPEN-CHAOS STRING))
790                   (T (UNWIND-PROTECT
791                        (PROGN (FILE-PROCESS-ERROR STRING FILE-CHANNEL T)       ;proceedable
792                               (*THROW 'OPEN-CHAOS-RETRY NIL))
793                        (OR (EQ MODE ':PROBE)
794                            (FUNCALL (CHANNEL-HOST-UNIT-FUNCTION FILE-CHANNEL)
795                                     ':DEALLOCATE FILE-CHANNEL))))))
796            (T (OR (SETQ FILENAME-ORIGIN (STRING-SEARCH-CHAR #\CR STRING))
797                   (FERROR 'FILE-CONNECTION-TROUBLE
798                           "Illegally formatted string ~S from control connection for channel ~S"
799                           STRING FILE-CHANNEL))
800               (DO ((I (FILE-CHECK-COMMAND "OPEN" STRING) (STRING-SEARCH-CHAR #\SP STRING (1+ I)))
801                    (PROP '((:VERSION . T) (:CREATION-DATE) (:CREATION-TIME) (:LENGTH . T)
802                            (:QFASLP . T))
803                          (CDR PROP))
804                    (IBASE 10.))
805                   ((OR (NULL I) (> I FILENAME-ORIGIN) (NULL PROP)))
806                 (CHANNEL-PROPERTY-PUTPROP FILE-CHANNEL
807                                    (COND ((CDAR PROP)
808                                           (READ-FROM-STRING STRING NIL I))
809                                          (T (SUBSTRING STRING (1+ I)
810                                                        (OR (STRING-SEARCH-SET '(#\SP #\CR)
811                                                                               STRING (1+ I))
812                                                            (STRING-LENGTH STRING)))))
813                                    (CAAR PROP)))
814               (CHANNEL-PROPERTY-PUTPROP FILE-CHANNEL
815                                         (SUBSTRING STRING (1+ FILENAME-ORIGIN)
816                                                    (OR (STRING-SEARCH-CHAR #\CR STRING
817                                                                            (1+ FILENAME-ORIGIN))
818                                                        (STRING-LENGTH STRING)))
819                                         ':UNIQUE-ID)
820               (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)
821               ;; Put the file name in the who-line if appropriate
822               (COND ((AND (EQ CURRENT-PROCESS TV:LAST-WHO-LINE-PROCESS)
823                           (NEQ MODE ':PROBE)
824                           (OR (NULL FILE-CHANNEL-CURRENT)
825                               (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':INPUT)))
826                      (SETQ FILE-CHANNEL-CURRENT FILE-CHANNEL)
827                      (TV:WHO-LINE-UPDATE)))
828               (RETURN-FROM OPEN-CHAOS (CLOSURE '(FILE-CHANNEL)
829                                         (SELECTQ (CHANNEL-DIRECTION FILE-CHANNEL)
830                                           (:INPUT (FUNCTION FILE-CHAOSNET-READ-STREAM))
831                                           (:OUTPUT (FUNCTION FILE-CHAOSNET-WRITE-STREAM)))))
832               ))))))
833
834(DEFUN CLOSE (STREAM)
835  (FUNCALL STREAM ':CLOSE))
836
837(DEFUN RENAMEF (STRING-OR-STREAM NEW-NAME &OPTIONAL (ERROR-P T))
838  (AND (STRINGP STRING-OR-STREAM)
839       (SETQ STRING-OR-STREAM (FILE-PARSE-NAME STRING-OR-STREAM)))
840  (FUNCALL STRING-OR-STREAM ':RENAME NEW-NAME ERROR-P))
841
842(DEFUN RENAME-CHAOS (FILENAME NEW-NAME ERROR-P)
843  (LET ((PKT) (SUCCESS) (STRING) (FILE-CHANNEL))
844    (SETQ FILE-CHANNEL (CHANNEL-ALLOCATE (FUNCALL FILENAME ':HOST) NIL NIL))
845    (MULTIPLE-VALUE (PKT SUCCESS STRING)
846      (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND NIL NIL NIL
847               (FORMAT NIL "RENAME~%~A~%~A~%"
848                       (FUNCALL FILENAME ':STRING-FOR-HOST)
849                       (FUNCALL NEW-NAME ':STRING-FOR-HOST))))
850    (COND (SUCCESS
851           (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)
852           T)
853          ((NOT ERROR-P)
854           (PROG1 (STRING-APPEND STRING)
855                  (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)))
856          (T (UNWIND-PROTECT (FILE-PROCESS-ERROR STRING FILENAME T)
857                             (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT))
858             ;; Retry if proceeded
859             (RENAME-CHAOS FILENAME NEW-NAME ERROR-P)))))
860
861(DEFUN DELETEF (STRING-OR-STREAM &OPTIONAL (ERROR-P T))
862  (AND (STRINGP STRING-OR-STREAM)
863       (SETQ STRING-OR-STREAM (FILE-PARSE-NAME STRING-OR-STREAM)))
864  (FUNCALL STRING-OR-STREAM ':DELETE ERROR-P))
865
866(DEFUN DELETE-CHAOS (FILENAME ERROR-P)
867  (LET ((PKT) (SUCCESS) (STRING) (FILE-CHANNEL))
868    (SETQ FILE-CHANNEL (CHANNEL-ALLOCATE (FUNCALL FILENAME ':HOST) NIL NIL))
869    (MULTIPLE-VALUE (PKT SUCCESS STRING)
870       (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND NIL NIL NIL
871                (FORMAT NIL "DELETE~%~A~%" (FUNCALL FILENAME ':STRING-FOR-HOST))))
872    (COND (SUCCESS
873           (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)
874           T)
875          ((NOT ERROR-P)
876           (PROG1 (STRING-APPEND STRING)
877                  (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)))
878          (T (UNWIND-PROTECT (FILE-PROCESS-ERROR STRING FILENAME T)
879               (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT))
880             (DELETE-CHAOS FILENAME ERROR-P)))))        ;retry if proceeded
881
882;Returns NIL or the truename
883(DEFUN PROBEF (FILE)
884  (LET ((STREAM-OR-ERROR-MESSAGE (OPEN FILE '(:PROBE))))
885    (COND ((STRINGP STREAM-OR-ERROR-MESSAGE) NIL)
886          (T (PROG1 (FUNCALL STREAM-OR-ERROR-MESSAGE ':GET ':UNIQUE-ID)
887                    (FUNCALL STREAM-OR-ERROR-MESSAGE ':CLOSE)))))) ;In case this did something
888
889(DEFUN FILE-CLOSE (IGNORE &AUX PKT SUCCESS STRING FILENAME-ORIGIN)
890  (COND ((EQ (CHANNEL-STATE FILE-CHANNEL) ':CLOSED) NIL)
891        ((NEQ (CHAOS:STATE (CHANNEL-CONTROL-CONNECTION FILE-CHANNEL)) 'CHAOS:OPEN-STATE)
892         (SETF (CHANNEL-STATE FILE-CHANNEL) ':CLOSED)
893         T)
894        (T (AND (EQ (CHANNEL-STATE FILE-CHANNEL) ':OPEN)
895                (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':OUTPUT)
896                (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':EOF))
897           (COND ((CHANNEL-DATA-PACKET FILE-CHANNEL)
898                  (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN
899                           (CHANNEL-DATA-PACKET FILE-CHANNEL))
900                  (SETF (CHANNEL-DATA-PACKET FILE-CHANNEL) NIL)
901                  (SETF (CHANNEL-DATA-ARRAY FILE-CHANNEL) NIL)
902                  (SETF (CHANNEL-DATA-COUNT FILE-CHANNEL) 0)))
903           (MULTIPLE-VALUE (PKT SUCCESS STRING)
904             (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND T T NIL "CLOSE"))
905           (CHANNEL-DEALLOCATE FILE-CHANNEL)
906           (COND ((EQ FILE-CHANNEL FILE-CHANNEL-CURRENT)
907                  (SETQ FILE-CHANNEL-CURRENT NIL)
908                  (TV:WHO-LINE-UPDATE)))
909           (SETF (CHANNEL-STATE FILE-CHANNEL) ':CLOSED)
910           (COND ((AND SUCCESS (EQ (CHANNEL-DIRECTION FILE-CHANNEL) ':OUTPUT))
911                  (OR (SETQ FILENAME-ORIGIN (STRING-SEARCH-CHAR #\CR STRING))
912                      (FERROR 'FILE-CONNECTION-TROUBLE
913                        "Illegally formatted string ~S from control connection for channel ~S"
914                        STRING FILE-CHANNEL))
915                  (DO ((I (FILE-CHECK-COMMAND "CLOSE" STRING)
916                          (STRING-SEARCH-CHAR #\SP STRING (1+ I)))
917                       (PROP '((:VERSION . T) (:CREATION-DATE) (:CREATION-TIME) (:LENGTH . T)
918                               (:QFASLP . T))
919                             (CDR PROP))
920                       (IBASE 10.))
921                      ((OR (NULL I) (> I FILENAME-ORIGIN) (NULL PROP)))
922                    (CHANNEL-PROPERTY-PUTPROP FILE-CHANNEL
923                                (COND ((CDAR PROP)
924                                       (READ-FROM-STRING STRING NIL I))
925                                      (T (SUBSTRING STRING (1+ I)
926                                                    (OR (STRING-SEARCH-SET '(#\SP #\CR)
927                                                                           STRING (1+ I))
928                                                        (STRING-LENGTH STRING)))))
929                                (CAAR PROP)))
930                  (CHANNEL-PROPERTY-PUTPROP FILE-CHANNEL
931                                (SUBSTRING STRING (1+ FILENAME-ORIGIN)
932                                           (OR (STRING-SEARCH-CHAR #\CR STRING
933                                                                   (1+ FILENAME-ORIGIN))
934                                               (STRING-LENGTH STRING)))
935                                ':UNIQUE-ID)
936                  (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)
937                  T)
938                 (SUCCESS
939                   (AND PKT (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT))
940                   T)
941                 (T (UNWIND-PROTECT (FILE-PROCESS-ERROR STRING FILE-CHANNEL T)
942                                        ;Proceedable, in that case ignore & consider closed
943                       (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)))))))
944
945(DEFUN FILE-CHECK-COMMAND (COMMAND RETURNED-STRING &OPTIONAL (Y-OR-N-P NIL)
946                                                   &AUX START END)
947  (SETQ START (1+ (STRING-SEARCH-CHAR #\SP RETURNED-STRING)))
948  (SETQ END (OR (STRING-SEARCH-SET '(#\SP #\CR) RETURNED-STRING START)
949                (STRING-LENGTH RETURNED-STRING)))
950  (COND ((STRING-EQUAL RETURNED-STRING COMMAND START 0 END)
951         (1+ END)) ;Index of character after the delimiting space
952        (Y-OR-N-P NIL)
953        (T (FERROR 'FILE-CONNECTION-TROUBLE
954                   "Incorrect command name ~S in acknowledge from file computer on channel ~S"
955                   (NSUBSTRING RETURNED-STRING START END) FILE-CHANNEL))))
956
957(DEFUN FILE-CONTINUE (&OPTIONAL IGNORE &AUX PKT SUCCESS STRING)
958  (COND ((EQ (CHANNEL-STATE FILE-CHANNEL) ':ASYNC-MARKED)
959         (MULTIPLE-VALUE (PKT SUCCESS STRING)
960           (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':COMMAND NIL T NIL
961                    "CONTINUE"))
962         (UNWIND-PROTECT
963          (COND (SUCCESS
964                 (SETF (CHANNEL-STATE FILE-CHANNEL) ':OPEN))
965                (T (FILE-PROCESS-ERROR
966                    (NSUBSTRING (CHAOS:PKT-STRING PKT)
967                                (1+ (STRING-SEARCH-CHAR #\SP (CHAOS:PKT-STRING PKT))))
968                    FILE-CHANNEL
969                    NIL)))      ;not proceedable
970          (FUNCALL (CHANNEL-FUNCTION FILE-CHANNEL) ':RETURN PKT)))))
971;;; An error string is as follows:
972;;;  FHN<SP>Error-code<SP>Error-severity<SP>Error-description
973;;; The error code is a three letter code that uniquely determines the error.  In general,
974;;; this code will be ignored, but some codes may be of interest.  FNF is file not found,
975;;; and NER is not enough resources.  The severity is either F (Fatal) or R (Restartable).
976;;; If an error is Fatal, it can not be continued from, even if it is an asynchronous
977;;; error.  If an error is Restartable, sending a CONTINUE command for the appropriate
978;;; file handle will cause the file job to proceed where it left off.  In general, before
979;;; the error is continued from, the error condition should be corrected, or the error
980;;; will happen again immediately.
981;;; The string that is passed in is expected to be "temporary" (contained in a chaos packet,
982;;; for example).  Therefore, if an error handler gets called and it wants to save some
983;;; of the strings, it must copy the ones it wishes to save.
984;;; If the 3rd arg is NIL, this function won't return.  If T it will
985;;; return if the user has said to proceed.  The caller should retry the operation
986;;; or ignore the error as appropriate.
987;;; In all cases the values returned to the caller are the 3-letter abbreviation
988;;; for the error, the severity letter, the message string, and the error-handler function
989;;; of the channel (usually NIL).
990(DEFUN FILE-PROCESS-ERROR (STRING STR-OR-CHAN PROCEEDABLE
991                           &OPTIONAL (JUST-RETURN NIL)
992                           &AUX S-P ERROR-CODE ERROR-SEVERITY ERROR-STRING
993                                WHO-FOR ERROR-HANDLER)
994  (PROG ()
995    (COND ((EQ (TYPEP STR-OR-CHAN) 'CHANNEL)
996           (SETQ ERROR-HANDLER (CHANNEL-PROPERTY-GET STR-OR-CHAN ':EXCEPTION-HANDLER))
997           (SETQ WHO-FOR (FUNCALL (CHANNEL-FILE-NAME STR-OR-CHAN) ':STRING-FOR-PRINTING)))
998          ((TYPEP STR-OR-CHAN 'FILENAME)
999           (SETQ WHO-FOR (FUNCALL STR-OR-CHAN ':STRING-FOR-PRINTING)))
1000          (T (SETQ WHO-FOR STR-OR-CHAN)))
1001    (SETQ S-P (FILE-CHECK-COMMAND "ERROR" STRING))
1002    (SETQ ERROR-CODE (SUBSTRING STRING S-P (SETQ S-P (STRING-SEARCH-CHAR #\SP STRING S-P))))
1003    (SETQ S-P (1+ S-P))
1004    (SETQ ERROR-SEVERITY
1005          (SUBSTRING STRING S-P (SETQ S-P (STRING-SEARCH-CHAR #\SP STRING S-P))))
1006    (SETQ ERROR-STRING (NSUBSTRING STRING (1+ S-P) (STRING-LENGTH STRING)))
1007    (AND WHO-FOR
1008         (SETQ ERROR-STRING (STRING-APPEND ERROR-STRING " for " WHO-FOR)))
1009    (COND (JUST-RETURN (RETURN ERROR-CODE ERROR-SEVERITY ERROR-STRING ERROR-HANDLER))
1010          ((AND ERROR-HANDLER   ;ERROR-HANDLER returns T if it handled it, NIL to do default
1011                (FUNCALL ERROR-HANDLER STR-OR-CHAN ERROR-CODE ERROR-SEVERITY ERROR-STRING))
1012           (RETURN ERROR-CODE ERROR-SEVERITY ERROR-STRING ERROR-HANDLER))
1013          (T (CERROR PROCEEDABLE NIL ':FILE-ERROR "File error ~A (Severity ~A), ~A"
1014                     ERROR-CODE ERROR-SEVERITY ERROR-STRING)
1015             (RETURN ERROR-CODE ERROR-SEVERITY ERROR-STRING ERROR-HANDLER)))))
1016
1017(DEFUN (:FILE-ERROR EH:PROCEED) (IGNORE IGNORE)
1018  (FORMAT T "~&Retrying file operation.~%"))
1019
1020(DEFUN FORCE-USER-TO-LOGIN (&OPTIONAL (HOST USER-LOGIN-MACHINE))
1021  (COND ((OR (NULL USER-ID) (STRING-EQUAL USER-ID ""))
1022         (FORMAT QUERY-IO "~&Host is ~A, login name or host:login name: " HOST)
1023         (LET ((INPUT (READLINE QUERY-IO))
1024               (COLON))
1025           (AND (SETQ COLON (STRING-SEARCH-CHAR #/: INPUT))
1026                (SETQ HOST (SUBSTRING INPUT 0 COLON)
1027                      INPUT (SUBSTRING INPUT (1+ COLON))))
1028           (LOGIN INPUT HOST)))))
1029
1030;;; Connection management
1031(DEFVAR FILE-DEFAULT-HOST "AI")
1032(DEFVAR FILE-DATA-WINDOW-SIZE 15)
1033
1034(DEFSTRUCT (HOST-UNIT (:CONSTRUCTOR MAKE-HOST-UNIT) :NAMED)
1035  (HOST-UNIT-HOST "")
1036  HOST-UNIT-LINK                    ;Link to next unit for this host
1037  HOST-UNIT-TIME                    ;Time last active connection closed
1038  HOST-UNIT-CONTROL-CONNECTION      ;The control connection associated with this host unit
1039
1040;List of all the currently open data connections (2-way).  Each data connection can
1041; support one output channel and one input channel.  Each connection is represented
1042; as a three list.  The first element being the connection, the second and third being
1043; flags saying whether the input side and the output side are currently in use, respectively.
1044  HOST-UNIT-DATA-CONNECTIONS
1045  HOST-UNIT-FUNCTION                ;Function to be called to operate on this HOST-UNIT
1046  HOST-UNIT-CHANNEL-FUNCTION        ;Function to be called to perform channel operations
1047                                    ; on channels associated with this unit
1048  HOST-UNIT-MAX-DATA-CONNECTIONS    ;Maximum number of data connections on this HOST-UNIT
1049  (HOST-UNIT-LOCK-WORD NIL)         ;Lock to insure no timing screws
1050  HOST-UNIT-CLOSURE                 ;Closure to be placed in CHANNEL-HOST-UNIT-FUNCTION
1051  )
1052
1053(DEFMACRO CONNECTION (DATA-CONN) `(CAR ,DATA-CONN))
1054
1055(DEFMACRO HANDLE (DATA-CONN DIRECTION)
1056  `(SELECTQ ,DIRECTION
1057     (:INPUT (CADR ,DATA-CONN))
1058     (:OUTPUT (CADDR ,DATA-CONN))))
1059
1060(DEFMACRO DATA-CHANNEL (DATA-CONN DIRECTION)
1061  `(CADR (MEMQ ,DIRECTION ,DATA-CONN)))
1062
1063(DEFUN HOST-UNIT (OP &OPTIONAL HOST-UNIT &REST ARGS)
1064  (SELECTQ OP
1065    (:WHICH-OPERATIONS '(:PRINT :PRINT-SELF))
1066    ((:PRINT :PRINT-SELF)
1067            (FORMAT (CAR ARGS) "#<HOST-UNIT ~S ~O>"
1068                    (HOST-UNIT-HOST HOST-UNIT) (%POINTER HOST-UNIT)))
1069    (OTHERWISE (FERROR NIL "No such operation ~S" OP))))
1070
1071(DEFMACRO HOST-UNIT-LOCK (HOST-UNIT)
1072  `(PROCESS-LOCK (LOCF (HOST-UNIT-LOCK-WORD ,HOST-UNIT))))
1073
1074(DEFMACRO HOST-UNIT-UNLOCK (HOST-UNIT)
1075  `(PROCESS-UNLOCK (LOCF (HOST-UNIT-LOCK-WORD ,HOST-UNIT))))
1076
1077(DEFMACRO HOST-UNIT-GRAB (HOST-UNIT &REST FORMS)
1078  `(UNWIND-PROTECT
1079    (PROGN
1080     (HOST-UNIT-LOCK ,HOST-UNIT)
1081     . ,FORMS)
1082    (HOST-UNIT-UNLOCK ,HOST-UNIT)))
1083
1084(DEFMACRO UNWIND-PROTECT-IF-ABNORMAL-EXIT (EVALED-FORM &REST UNWIND-FORMS)
1085  `(LET ((*UNWIND-PROTECT-IF-ABNORMAL-EXIT-FLAG* T))
1086     (UNWIND-PROTECT
1087      (PROG1
1088       ,EVALED-FORM
1089       (SETQ *UNWIND-PROTECT-IF-ABNORMAL-EXIT-FLAG* NIL))
1090      (COND (*UNWIND-PROTECT-IF-ABNORMAL-EXIT-FLAG*
1091             . ,UNWIND-FORMS)))))
1092             
1093
1094; Each host is known about as a closure on FILE-HOST-ALIST.
1095; The closure contains all the information necessary to manage connections associated with
1096; the particular host.  The closure-function will in general be a small function which
1097; dispatches to the appropriate routines.  If a particular host needs unusual handling,
1098; it can be done through this mechanism as well.
1099(DEFVAR FILE-HOST-ALIST NIL)
1100(DEFVAR FILE-HOST-FIRST-UNIT)
1101(DEFVAR FILE-HOST-UNIT)
1102
1103;; This function defines a host
1104(DEFUN FILE-HOST (HOST-NAME HOST-FUNCTION &AUX CLOSURE
1105                                               (FILE-HOST-FIRST-UNIT (MAKE-HOST-UNIT))
1106                                               FILE-HOST-UNIT)
1107  (FUNCALL HOST-FUNCTION ':INIT-HOST-UNIT FILE-HOST-FIRST-UNIT HOST-NAME)
1108  (SETF (HOST-UNIT-FUNCTION FILE-HOST-FIRST-UNIT) HOST-FUNCTION)
1109  (SETQ CLOSURE (CLOSURE '(FILE-HOST-FIRST-UNIT) HOST-FUNCTION)
1110        FILE-HOST-UNIT FILE-HOST-FIRST-UNIT)
1111  (SETF (HOST-UNIT-CLOSURE FILE-HOST-UNIT) (CLOSURE '(FILE-HOST-UNIT) CLOSURE))
1112  ;; This is NOT an initialization!  This is a KLUDGE to avoid duplicate entries.
1113  (ADD-INITIALIZATION HOST-NAME CLOSURE NIL 'FILE-HOST-ALIST)
1114  CLOSURE)
1115
1116;; Get a channel that goes to this host, using an additional HOST-UNIT if necessary
1117(DEFUN CHANNEL-ALLOCATE (HOST &OPTIONAL (WRITE-P NIL) (DATA-CONN-P T))
1118  (LET ((HOST-INFO (ASSOC HOST FILE-HOST-ALIST))
1119        (CHANNEL) (HOST-UNIT))
1120    (OR HOST-INFO       ;If host unknown, use the default host instead
1121        (SETQ HOST-INFO (ASSOC (SETQ HOST FILE-DEFAULT-HOST) FILE-HOST-ALIST)))
1122    (SETQ FILE-DEFAULT-HOST HOST)
1123    (MULTIPLE-VALUE (CHANNEL HOST-UNIT)
1124      (FUNCALL (SI:INIT-FORM HOST-INFO) ':ALLOCATE (MAKE-CHANNEL) WRITE-P DATA-CONN-P))
1125    (SETF (CHANNEL-CONTROL-CONNECTION CHANNEL) (HOST-UNIT-CONTROL-CONNECTION HOST-UNIT))
1126    (SETF (CHANNEL-STATE CHANNEL) ':CLOSED)
1127    (SETF (CHANNEL-FUNCTION CHANNEL) (HOST-UNIT-CHANNEL-FUNCTION HOST-UNIT))
1128    (SETF (CHANNEL-HOST-UNIT-FUNCTION CHANNEL) (HOST-UNIT-CLOSURE HOST-UNIT))
1129    CHANNEL))
1130
1131;; Deallocate the portion of the host-unit used by this channel
1132(DEFUN CHANNEL-DEALLOCATE (CHANNEL)
1133  (FUNCALL (CHANNEL-HOST-UNIT-FUNCTION CHANNEL) ':DEALLOCATE CHANNEL))
1134
1135;; Map a function over all host units
1136(DEFUN HOST-UNIT-MAP-FUNCTION (CLOSURE FUNCTION &REST ARGS)
1137  (DO ((UNIT (SYMEVAL-IN-CLOSURE CLOSURE 'FILE-HOST-FIRST-UNIT) (HOST-UNIT-LINK UNIT)))
1138      ((NULL UNIT))
1139    (LEXPR-FUNCALL FUNCTION UNIT ARGS)))
1140
1141;;; Setup a user-id for the specified host.  Knows about ITS specially, as they
1142;;; are one big happy family...
1143(DEFVAR USER-UNAMES NIL)
1144(DEFUN FILE-HOST-USER-ID (UID HOST)
1145  (AND (EQ (CDR (ASSOC HOST HOST-FILENAME-FLAVOR-ALIST)) 'ITS-FILENAME)
1146       ;; All ITS' are the same
1147       (SETQ HOST 'ITS
1148             UID (SUBSTRING UID 0 (MIN (STRING-LENGTH UID) 6))))
1149  (LET ((AE (ASSOC HOST USER-UNAMES)))
1150       (IF AE
1151           (RPLACD AE UID)
1152           (PUSH (CONS HOST UID) USER-UNAMES))))
1153
1154;Send a LOGIN command to all open host units.  Called every time a user logs in or out.
1155(DEFUN FILE-LOGIN (LOGIN-P)
1156  (OR LOGIN-P (SETQ USER-UNAMES NIL))
1157  (DOLIST (ALIST-ENTRY FILE-HOST-ALIST)
1158    (HOST-UNIT-MAP-FUNCTION (SI:INIT-FORM ALIST-ENTRY)
1159                            #'(LAMBDA (U LP)
1160                                      (FUNCALL (HOST-UNIT-FUNCTION U) ':LOGIN-UNIT U LP))
1161                            LOGIN-P)))
1162
1163(DEFVAR USER-HSNAMES NIL)
1164(DEFVAR USER-PERSONAL-NAME "")                  ;Full name, last name first
1165(DEFVAR USER-PERSONAL-NAME-FIRST-NAME-FIRST "") ;Full name, first name first
1166(DEFVAR USER-GROUP-AFFILIATION #/-)
1167(DEFVAR USER-LOGIN-MACHINE "AI")
1168;;; Make sure that our HSNAME and Personal names are correct
1169(DEFUN FILE-USER-ID-HSNAME (&OPTIONAL (HOST USER-LOGIN-MACHINE) RESET-P
1170                            &AUX HOST-ITS UNIT)
1171  (FORCE-USER-TO-LOGIN)
1172  (SETQ HOST-ITS (SI:INIT-FORM (OR (ASSOC HOST FILE-HOST-ALIST)
1173                                   (ASSOC FILE-DEFAULT-HOST FILE-HOST-ALIST)))
1174        UNIT (SYMEVAL-IN-CLOSURE HOST-ITS 'FILE-HOST-FIRST-UNIT))
1175  (AND RESET-P (SETQ USER-LOGIN-MACHINE (HOST-UNIT-HOST UNIT)))
1176  (OR (HOST-UNIT-GRAB UNIT (FUNCALL HOST-ITS ':VALIDATE-CONTROL-CONNECTION UNIT))
1177      (FERROR NIL "Cannot connect to host ~A" HOST))
1178  (CDR (ASSOC HOST USER-HSNAMES)))
1179
1180(DEFVAR FILE-HOST-DEFAULTS-ALIST NIL)           ;Needed here before FNUTIL
1181(DEFUN FILE-HOST-LOGGED-IN (HOST DEFAULT-NAMESTRING)
1182  (FILE-PARSE-NAME DEFAULT-NAMESTRING HOST
1183                   (NOT (NULL (ASSOC HOST FILE-HOST-DEFAULTS-ALIST)))))
1184
1185(DEFSELECT HOST-ITS
1186  (:ALLOCATE . HOST-STANDARD-ALLOCATE)
1187  (:DEALLOCATE . HOST-STANDARD-DEALLOCATE)
1188  (:RESET ()
1189    (DO ((UNIT FILE-HOST-FIRST-UNIT (HOST-UNIT-LINK UNIT)))
1190        ((NULL UNIT)
1191         (SETF (HOST-UNIT-LINK FILE-HOST-FIRST-UNIT) NIL))
1192       ;; Arg of NIL: Unlock all unit
1193      (FUNCALL (HOST-UNIT-FUNCTION UNIT) ':RESET-UNIT UNIT NIL)))
1194  (:RESET-UNIT (UNIT &OPTIONAL DONT-UNLOCK-LOCK-P)
1195    (AND (HOST-UNIT-CONTROL-CONNECTION UNIT)
1196         (CHAOS:REMOVE-CONN (HOST-UNIT-CONTROL-CONNECTION UNIT)))
1197    (SETF (HOST-UNIT-CONTROL-CONNECTION UNIT) NIL)
1198    (DO ((DATA-CONNS (HOST-UNIT-DATA-CONNECTIONS UNIT) (CDR DATA-CONNS))
1199         (CHANNEL))
1200        ((NULL DATA-CONNS)
1201         (SETF (HOST-UNIT-DATA-CONNECTIONS UNIT) NIL))
1202      (AND (SETQ CHANNEL (DATA-CHANNEL (CAR DATA-CONNS) ':INPUT))
1203           (SETF (CHANNEL-STATE CHANNEL) ':CLOSED))
1204      (AND (SETQ CHANNEL (DATA-CHANNEL (CAR DATA-CONNS) ':OUTPUT))
1205           (SETF (CHANNEL-STATE CHANNEL) ':CLOSED))
1206      (CHAOS:REMOVE-CONN (CONNECTION (CAR DATA-CONNS))))
1207    (OR DONT-UNLOCK-LOCK-P
1208        (SETF (HOST-UNIT-LOCK-WORD UNIT) NIL)))
1209  (:LOGIN-UNIT (UNIT LOGIN-P &AUX (CONN (HOST-UNIT-CONTROL-CONNECTION UNIT)) NEW-USER-ID)
1210    (AND CONN (EQ (CHAOS:STATE CONN) 'CHAOS:OPEN-STATE)
1211         (LET ((PKT (CHAOS:GET-PKT))
1212               (ID (FILE-MAKE-TRANSACTION-ID)))
1213           (COND ((AND LOGIN-P
1214                       ;; This is really a login
1215                       (NULL (SETQ NEW-USER-ID (CDR (ASSOC 'ITS USER-UNAMES)))))
1216                  ;; We don't know about USER-ID for this host, so must ask
1217                  (FORMAT QUERY-IO "~&ITS uname (default ~A): " USER-ID)
1218                  (LET ((NID (READLINE)))
1219                    (SETQ NEW-USER-ID (IF (NULL-S NID) USER-ID NID)))
1220                  (FILE-HOST-USER-ID NEW-USER-ID (HOST-UNIT-HOST UNIT))))
1221           (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " (IF NEW-USER-ID
1222                                                       (STRING-UPCASE NEW-USER-ID)
1223                                                       ""))
1224           (CHAOS:SEND-PKT CONN PKT)
1225           (SETQ PKT (FILE-WAIT-FOR-TRANSACTION ID CONN "Login"))
1226           (AND LOGIN-P
1227                (LET ((STR (CHAOS:PKT-STRING PKT))
1228                      IDX)
1229                  (SETQ STR (NSUBSTRING STR (1+ (STRING-SEARCH-CHAR #\SP STR))))
1230                  (SETQ IDX (FILE-CHECK-COMMAND "LOGIN" STR))
1231                  (OR (STRING-EQUAL NEW-USER-ID STR 0 IDX NIL
1232                                    (SETQ IDX (STRING-SEARCH-CHAR #\SP STR IDX)))
1233                      (FERROR NIL "File job claims to have logged in as someone else."))
1234                  (LET ((HSNAME (SUBSTRING STR (SETQ IDX (1+ IDX))
1235                                           (SETQ IDX (STRING-SEARCH-CHAR #\CR STR IDX))))
1236                        HSNAME-STRING ITEM)
1237                    (SETQ HSNAME-STRING (STRING-APPEND (HOST-UNIT-HOST UNIT) ": "
1238                                                       HSNAME "; "))
1239                    (FILE-HOST-LOGGED-IN (HOST-UNIT-HOST UNIT) HSNAME-STRING)
1240                    (IF (SETQ ITEM (ASSOC (HOST-UNIT-HOST UNIT) USER-HSNAMES))
1241                        (RPLACD ITEM HSNAME-STRING)
1242                        (PUSH (CONS (HOST-UNIT-HOST UNIT) HSNAME-STRING) USER-HSNAMES)))
1243                  (SETQ USER-PERSONAL-NAME
1244                        (SUBSTRING STR (SETQ IDX (1+ IDX))
1245                                   (SETQ IDX (STRING-SEARCH-CHAR #\CR STR IDX))))
1246                  (SETQ USER-GROUP-AFFILIATION (AREF STR (1+ IDX)))
1247                  (SETQ IDX (STRING-SEARCH ", " USER-PERSONAL-NAME)
1248                        STR (NSUBSTRING USER-PERSONAL-NAME 0 IDX))
1249                  (AND IDX (SETQ STR (STRING-APPEND (NSUBSTRING USER-PERSONAL-NAME
1250                                                                (+ IDX 2))
1251                                                    #\SP STR)))
1252                  (SETQ USER-PERSONAL-NAME-FIRST-NAME-FIRST STR)))
1253           (CHAOS:RETURN-PKT PKT)))
1254    T)
1255     
1256;; All below here must be called with the HOST-UNIT locked
1257  (:VALIDATE-CONTROL-CONNECTION (UNIT &AUX (CONN (HOST-UNIT-CONTROL-CONNECTION UNIT)))
1258    (COND ((AND CONN
1259                (EQ (CHAOS:STATE CONN) 'CHAOS:OPEN-STATE)
1260                (NOT (DOLIST (DATA-CONN (HOST-UNIT-DATA-CONNECTIONS UNIT))
1261                       (OR (EQ (CHAOS:STATE (CONNECTION DATA-CONN)) 'CHAOS:OPEN-STATE)
1262                           (RETURN T)))))
1263           T)
1264          (T (FUNCALL (HOST-UNIT-FUNCTION UNIT)
1265                      ':RESET-UNIT UNIT T)      ;Arg of T means don't unlock lock
1266             (SETF (HOST-UNIT-CONTROL-CONNECTION UNIT)
1267                   (CHAOS:CONNECT (CHAOS:ADDRESS-PARSE (HOST-UNIT-HOST UNIT)) "FILE" 5))
1268             (COND ((STRINGP (HOST-UNIT-CONTROL-CONNECTION UNIT))
1269                    (SETF (HOST-UNIT-CONTROL-CONNECTION UNIT) NIL)
1270                    NIL)
1271                   (T (SETF (HOST-UNIT-CHANNEL-FUNCTION UNIT) 'FILE-CHAOSNET-CHANNEL-FUNCTION)
1272                      (SETF (CHAOS:INTERRUPT-FUNCTION (HOST-UNIT-CONTROL-CONNECTION UNIT))
1273                            (LET ((FILE-HOST-UNIT UNIT))
1274                              (CLOSURE '(FILE-HOST-UNIT) 'HOST-CHAOS-INTERRUPT-FUNCTION)))
1275                      (FUNCALL (HOST-UNIT-FUNCTION UNIT) ':LOGIN-UNIT UNIT T)
1276                      T)))))
1277  (:NEW-DATA-CONNECTION (UNIT)
1278    (LET ((INPUT-HANDLE (FILE-GENSYM 'I))
1279          (OUTPUT-HANDLE (FILE-GENSYM 'O))
1280          (PKT (CHAOS:GET-PKT))
1281          (ID (FILE-MAKE-TRANSACTION-ID))
1282          (DATA-CONN)
1283          (CONNECTION))
1284      (CHAOS:SET-PKT-STRING PKT
1285                            ID "  DATA-CONNECTION " INPUT-HANDLE " " OUTPUT-HANDLE)
1286      (CHAOS:SEND-PKT (HOST-UNIT-CONTROL-CONNECTION UNIT) PKT)
1287      (SETQ CONNECTION
1288            (CHAOS:LISTEN (STRING OUTPUT-HANDLE) FILE-DATA-WINDOW-SIZE))
1289      (OR (CHAOS:WAIT CONNECTION 'CHAOS:LISTENING-STATE (* 60. 3))
1290          ;; Attempt to establish connection timed out -- give reasonable error
1291          (FERROR NIL "Attempt to establish chaos connection timed out."))
1292      (CHAOS:ACCEPT CONNECTION)
1293      (SETQ PKT (FILE-WAIT-FOR-TRANSACTION ID (HOST-UNIT-CONTROL-CONNECTION UNIT)
1294                                           "New Data Conn"))
1295      (UNWIND-PROTECT
1296       (LET ((STRING
1297              (NSUBSTRING (CHAOS:PKT-STRING PKT)
1298                          (1+ (STRING-SEARCH-CHAR #\SP (CHAOS:PKT-STRING PKT))))))
1299         (COND ((FILE-CHECK-COMMAND "DATA-CONNECTION" STRING T)
1300                (SETF (HOST-UNIT-DATA-CONNECTIONS UNIT)
1301                      (CONS (SETQ DATA-CONN
1302                                  (LIST CONNECTION INPUT-HANDLE OUTPUT-HANDLE
1303                                        ':INPUT NIL ':OUTPUT NIL))
1304                            (HOST-UNIT-DATA-CONNECTIONS UNIT))))
1305               (T (FILE-PROCESS-ERROR STRING NIL NIL))))        ;not proceedable
1306       (CHAOS:RETURN-PKT PKT))
1307      DATA-CONN))
1308  (:INIT-HOST-UNIT (UNIT HOST-NAME)
1309                   (SETF (HOST-UNIT-HOST UNIT) HOST-NAME)
1310                   (SETF (HOST-UNIT-MAX-DATA-CONNECTIONS UNIT) 3)) )
1311
1312(DEFSELECT (HOST-TOPS20 HOST-ITS)
1313  (:LOGIN-UNIT (UNIT LOGIN-P &AUX (CONN (HOST-UNIT-CONTROL-CONNECTION UNIT)))
1314    (AND CONN (EQ (CHAOS:STATE CONN) 'CHAOS:OPEN-STATE)
1315         (IF (NOT LOGIN-P)
1316             (CHAOS:CLOSE CONN "Logging out")
1317             (LET ((PKT (CHAOS:GET-PKT))
1318                   (NEW-USER-ID)
1319                   (PASSWORD)
1320                   (ID (FILE-MAKE-TRANSACTION-ID)))
1321               (MULTIPLE-VALUE (NEW-USER-ID PASSWORD)
1322                               (FILE-GET-TOPS20-PASSWORD USER-ID (HOST-UNIT-HOST UNIT)))
1323               ;; LOGIN <UID> <PASS> <NULL ACCOUNT STRING>
1324               (CHAOS:SET-PKT-STRING PKT ID "  LOGIN " NEW-USER-ID " " PASSWORD "  ")
1325               (CHAOS:SEND-PKT CONN PKT)
1326               (SETQ PKT (FILE-WAIT-FOR-TRANSACTION ID CONN "Login"))
1327               (LET ((STR (CHAOS:PKT-STRING PKT))
1328                     IDX)
1329                 (SETQ STR (NSUBSTRING STR (1+ (STRING-SEARCH-CHAR #\SP STR))))
1330                 (SETQ IDX (FILE-CHECK-COMMAND "Login" STR))
1331                 (LET ((HSNAME NEW-USER-ID)
1332                        HSNAME-STRING ITEM)
1333                   (SETQ HSNAME-STRING (STRING-APPEND "PS:<" (STRING-UPCASE HSNAME) ">"))
1334                   (FILE-HOST-LOGGED-IN (HOST-UNIT-HOST UNIT) HSNAME-STRING)
1335                   (IF (SETQ ITEM (ASSOC (HOST-UNIT-HOST UNIT) USER-HSNAMES))
1336                       (RPLACD ITEM HSNAME-STRING)
1337                       (PUSH (CONS (HOST-UNIT-HOST UNIT) HSNAME-STRING) USER-HSNAMES)))
1338                 ;; Only do the following kludge if the guy's home isn't ITS
1339                 (COND ((NULL USER-PERSONAL-NAME)
1340                        (SETQ USER-PERSONAL-NAME USER-ID)
1341                        (SETQ USER-GROUP-AFFILIATION #/W)
1342                        (SETQ USER-PERSONAL-NAME-FIRST-NAME-FIRST NEW-USER-ID)))))))
1343    T)
1344  (:INIT-HOST-UNIT (UNIT HOST-NAME)
1345                   (SETF (HOST-UNIT-HOST UNIT) HOST-NAME)
1346                   (SETF (HOST-UNIT-MAX-DATA-CONNECTIONS UNIT) 8.)) )
1347
1348(DEFUN FILE-GET-TOPS20-PASSWORD (UID HOST)
1349  (DO-NAMED EXIT
1350            () (())
1351    (SETQ UID (OR (CDR (ASSOC HOST USER-UNAMES)) UID))
1352    (FORMAT QUERY-IO "~&Current login name is ~A for host ~A.
1353Type either password or loginname<space>password: " UID HOST)
1354    (DO ((LINE (MAKE-ARRAY NIL 'ART-STRING 30 NIL '(0)))
1355         (CHAR))
1356        (())
1357      (SETQ CHAR (FUNCALL QUERY-IO ':TYI))
1358      (COND ((= CHAR #\RUBOUT)
1359             (LET ((AL (ARRAY-LEADER LINE 0)))
1360                  (IF (> AL 0)
1361                      (STORE-ARRAY-LEADER (1- AL) LINE 0)
1362                      (FORMAT QUERY-IO "XXX")
1363                      (RETURN))))
1364            ((= CHAR #/ )
1365             (SETQ UID LINE
1366                   LINE (MAKE-ARRAY NIL 'ART-STRING 30 NIL '(0)))
1367             (FORMAT QUERY-IO "~A" UID)
1368             (SETQ CHAR (FUNCALL QUERY-IO ':TYI)))
1369            ((= CHAR #\CR)
1370             (FILE-HOST-USER-ID UID HOST)
1371             (RETURN-FROM EXIT UID LINE)))
1372      (ARRAY-PUSH-EXTEND LINE CHAR))))
1373
1374(DEFUN HOST-CHAOS-INTERRUPT-FUNCTION (REASON CONN &REST IGNORE)
1375  (SELECTQ REASON
1376    (:INPUT
1377     (DO ((PKT (CHAOS:GET-NEXT-PKT CONN T)
1378               (CHAOS:GET-NEXT-PKT CONN T))
1379          (STRING) (TEM))
1380         ((NULL PKT))
1381       (SETQ STRING (CHAOS:PKT-STRING PKT))
1382       (SELECT (CHAOS:PKT-OPCODE PKT)
1383         (%FILE-ASYNCHRONOUS-MARK-OPCODE
1384          (SETQ STRING (NSUBSTRING STRING
1385                                   (1+ (STRING-SEARCH-CHAR #\SP (CHAOS:PKT-STRING PKT)))))
1386          (DO ((DATA-CONNS (HOST-UNIT-DATA-CONNECTIONS FILE-HOST-UNIT) (CDR DATA-CONNS))
1387               (HANDLE-LEN (OR (STRING-SEARCH-CHAR #\SP STRING)
1388                               (STRING-LENGTH STRING)))
1389               (CHANNEL))
1390              ((NULL DATA-CONNS) (CHAOS:RETURN-PKT PKT))
1391            (COND ((STRING-EQUAL STRING (HANDLE (CAR DATA-CONNS) ':OUTPUT) 0 0 HANDLE-LEN)
1392                   (SETQ CHANNEL (DATA-CHANNEL (CAR DATA-CONNS) ':OUTPUT))
1393                   (CHANNEL-PROPERTY-PUTPROP CHANNEL PKT 'ASYNC-MARK-PKT)
1394                   (SETF (CHANNEL-STATE CHANNEL) ':ASYNC-MARKED)
1395                   (RETURN NIL)))))
1396         (%FILE-COMMAND-OPCODE
1397          (SETQ STRING (SUBSTRING STRING 0 (STRING-SEARCH-CHAR #\SP STRING)))
1398          (SETQ TEM (ASSOC STRING FILE-PENDING-TRANSACTIONS))
1399          (RETURN-ARRAY (PROG1 STRING (SETQ STRING NIL))) ;Don't cons
1400          (COND ((CADR TEM)                     ;If simple transaction, make sure no error
1401                 (LET ((STRING (NSUBSTRING (CHAOS:PKT-STRING PKT)
1402                                           (1+ (STRING-SEARCH-CHAR #\SP
1403                                                                   (CHAOS:PKT-STRING PKT)))))
1404                       (FROM))
1405                   (SETQ FROM (1+ (STRING-SEARCH-SET '(#\SP #\CR) STRING)))
1406                   ;; If simple transaction fails, barf in another process
1407                   (OR (NOT (STRING-EQUAL "ERROR" STRING 0 FROM 5
1408                                          (STRING-SEARCH-SET '(#\SP #\CR) STRING FROM)))
1409                       (PROCESS-RUN-FUNCTION "File System Barf"
1410                                             #'FILE-PROCESS-ERROR
1411                                             (PROG1 (STRING-APPEND STRING)
1412                                                    (CHAOS:RETURN-PKT PKT))
1413                                             NIL NIL)))
1414                 (SETQ FILE-PENDING-TRANSACTIONS (DELQ TEM FILE-PENDING-TRANSACTIONS)))
1415                (TEM (RPLACD (CDR TEM) PKT))
1416                (T (PROCESS-RUN-FUNCTION "File system fucked"
1417                     #'(LAMBDA (PKT)
1418                         (UNWIND-PROTECT
1419                          (FERROR NIL "File system fucked, unknown transaction id in ~S"
1420                                  (CHAOS:PKT-STRING PKT))
1421                          (CHAOS:RETURN-PKT PKT)))
1422                     PKT))))
1423         (OTHERWISE (CHAOS:RETURN-PKT PKT)))))))
1424
1425(DEFUN HOST-STANDARD-ALLOCATE (IGNORE NEW-CHANNEL &OPTIONAL (WRITE-P NIL) (DATA-CONN-P T))
1426  (PROG ((DIRECTION (COND (WRITE-P ':OUTPUT)
1427                          (T ':INPUT)))
1428         (SELECTED-UNIT) (SELECTED-DATA-CONN))
1429    (UNWIND-PROTECT
1430      (PROGN
1431        (COND ((NOT DATA-CONN-P)
1432               (OR (HOST-UNIT-GRAB FILE-HOST-FIRST-UNIT
1433                                   (FUNCALL (HOST-UNIT-FUNCTION FILE-HOST-FIRST-UNIT)
1434                                            ':VALIDATE-CONTROL-CONNECTION
1435                                            FILE-HOST-FIRST-UNIT))
1436                   (FERROR NIL "Cannot connect to host ~A"
1437                           (HOST-UNIT-HOST FILE-HOST-FIRST-UNIT)))
1438               (RETURN NEW-CHANNEL FILE-HOST-FIRST-UNIT)))
1439        (DO-NAMED HAVE-DATA-CONN
1440                  ((UNIT FILE-HOST-FIRST-UNIT (HOST-UNIT-LINK UNIT))
1441                   (PREV-UNIT NIL UNIT))
1442                  ((NULL UNIT)
1443                   ;; If we get here, there is no unit that can handle a new channel in the
1444                   ;; specified direction.  Create a new unit if possible, else bomb
1445                   (SETQ SELECTED-UNIT (MAKE-HOST-UNIT))
1446                   (FUNCALL (HOST-UNIT-FUNCTION FILE-HOST-FIRST-UNIT) ':INIT-HOST-UNIT
1447                            SELECTED-UNIT (HOST-UNIT-HOST FILE-HOST-FIRST-UNIT))
1448                   (HOST-UNIT-LOCK SELECTED-UNIT)
1449                   (SETF (HOST-UNIT-FUNCTION SELECTED-UNIT)
1450                         (HOST-UNIT-FUNCTION FILE-HOST-FIRST-UNIT))
1451                   (LET ((FILE-HOST-UNIT SELECTED-UNIT))
1452                     (SETF (HOST-UNIT-CLOSURE SELECTED-UNIT)
1453                           (CLOSURE '(FILE-HOST-UNIT)
1454                                    (HOST-UNIT-FUNCTION FILE-HOST-FIRST-UNIT))))
1455                   (SETF (HOST-UNIT-LINK PREV-UNIT) SELECTED-UNIT))
1456          (HOST-UNIT-LOCK UNIT)
1457          (COND ((FUNCALL (HOST-UNIT-FUNCTION UNIT) ':VALIDATE-CONTROL-CONNECTION UNIT)
1458                 (DO ((DATA-CONN (HOST-UNIT-DATA-CONNECTIONS UNIT) (CDR DATA-CONN)))
1459                     ((NULL DATA-CONN))
1460                   (COND ((NULL (DATA-CHANNEL (CAR DATA-CONN) DIRECTION))
1461                          (SETQ SELECTED-UNIT UNIT)
1462                          (SETQ SELECTED-DATA-CONN (CAR DATA-CONN))
1463                          (OR (EQ (CHAOS:STATE (CAR SELECTED-DATA-CONN)) 'CHAOS:OPEN-STATE)
1464                              (FERROR NIL "~A, a data connection for the file system, went into an illegal state" SELECTED-DATA-CONN))
1465                          (RETURN-FROM HAVE-DATA-CONN SELECTED-DATA-CONN))))
1466                 (COND ((< (LENGTH (HOST-UNIT-DATA-CONNECTIONS UNIT))
1467                           (HOST-UNIT-MAX-DATA-CONNECTIONS UNIT))
1468                        (RETURN (SETQ SELECTED-UNIT UNIT)))))))
1469        (COND ((NULL SELECTED-UNIT) (FERROR NIL "No unit selected"))
1470              (SELECTED-DATA-CONN)
1471              (T (OR (FUNCALL (HOST-UNIT-FUNCTION SELECTED-UNIT)
1472                              ':VALIDATE-CONTROL-CONNECTION SELECTED-UNIT)
1473                     (FERROR NIL "Cannot connect to host ~A"
1474                             (HOST-UNIT-HOST SELECTED-UNIT)))
1475                 (SETQ SELECTED-DATA-CONN
1476                       (FUNCALL (HOST-UNIT-FUNCTION SELECTED-UNIT)
1477                                ':NEW-DATA-CONNECTION SELECTED-UNIT))))
1478        (SETF (DATA-CHANNEL SELECTED-DATA-CONN DIRECTION) NEW-CHANNEL)
1479        ;; At this point we have allocated the data conn, so we can release exclusive use
1480        ;; of the HOST-UNIT.
1481        (SETF (CHANNEL-FILE-HANDLE NEW-CHANNEL) (HANDLE SELECTED-DATA-CONN DIRECTION))
1482        (SETF (CHANNEL-DATA-CONNECTION NEW-CHANNEL) (CONNECTION SELECTED-DATA-CONN))
1483        (SETF (CHANNEL-CONTROL-CONNECTION NEW-CHANNEL)
1484              (HOST-UNIT-CONTROL-CONNECTION SELECTED-UNIT))
1485        (SETF (CHANNEL-HOST-UNIT-FUNCTION NEW-CHANNEL) (HOST-UNIT-CLOSURE SELECTED-UNIT)))
1486      ;; UNWIND-PROTECT undo clause here
1487      (WITHOUT-INTERRUPTS
1488        (DO ((UNIT FILE-HOST-FIRST-UNIT (HOST-UNIT-LINK UNIT)))
1489            ((NULL UNIT))
1490          (AND (EQ (HOST-UNIT-LOCK-WORD UNIT) CURRENT-PROCESS)
1491               (HOST-UNIT-UNLOCK UNIT)))))
1492    (RETURN NEW-CHANNEL SELECTED-UNIT)))
1493
1494;FILE-HOST-UNIT bound in closure
1495(DEFUN HOST-STANDARD-DEALLOCATE (IGNORE CHANNEL)
1496  (DO ((DATA-CONN (HOST-UNIT-DATA-CONNECTIONS FILE-HOST-UNIT) (CDR DATA-CONN)))
1497      ((NULL DATA-CONN)
1498       (FERROR 'FILE-CONNECTION-TROUBLE
1499               "Channel ~S not associated with the closed-over unit" CHANNEL))
1500    (COND ((EQ CHANNEL (DATA-CHANNEL (CAR DATA-CONN) (CHANNEL-DIRECTION CHANNEL)))
1501           (SETF (DATA-CHANNEL (CAR DATA-CONN) (CHANNEL-DIRECTION CHANNEL)) NIL)
1502           ;; For now, close data connection if unused and at least 1 other extant
1503           (HOST-UNIT-GRAB FILE-HOST-UNIT
1504             (COND ((AND (NULL (DATA-CHANNEL (CAR DATA-CONN) ':INPUT))
1505                         (NULL (DATA-CHANNEL (CAR DATA-CONN) ':OUTPUT))
1506                         ( (LENGTH (HOST-UNIT-DATA-CONNECTIONS FILE-HOST-UNIT)) 1))
1507                    (LET ((CONN (CONNECTION (CAR DATA-CONN))))
1508                      (FUNCALL (CHANNEL-FUNCTION CHANNEL) ':COMMAND NIL
1509                               (HANDLE (CAR DATA-CONN) ':INPUT)
1510                               NIL
1511                               "UNDATA-CONNECTION")
1512                      (CHAOS:CLOSE CONN "Done")
1513                      (CHAOS:REMOVE-CONN CONN)
1514                      (SETF (HOST-UNIT-DATA-CONNECTIONS FILE-HOST-UNIT)
1515                            (DELQ (CAR DATA-CONN)
1516                                  (HOST-UNIT-DATA-CONNECTIONS FILE-HOST-UNIT)))))))
1517           (RETURN T)))))
1518
1519;;; Who-line stuff
1520;;; NOTE: This code assumes that the file item is at the end of the line
1521(DEFSTRUCT (WHO-LINE-FILE-ITEM :LIST (:INCLUDE TV:WHO-LINE-ITEM) (:CONSTRUCTOR NIL))
1522  WHO-LINE-FILE-ITEM-PERCENT
1523  WHO-LINE-FILE-ITEM-CURRENT)
1524
1525(DEFUN WHO-LINE-FILE-STATE (ITEM &AUX (MAX-CHARS 36.) IDLE)
1526  (COND (FILE-CHANNEL-CURRENT
1527         (LET ((PERCENT 0)
1528               (LENGTH (CHANNEL-PROPERTY-GET FILE-CHANNEL-CURRENT ':LENGTH))
1529               (OLD-CHANNEL (TV:WHO-LINE-ITEM-STATE ITEM))
1530               (CURRENT) (STRING) (SP-POS) (FILE-NAME) (FNTRUNC))
1531           (SETQ CURRENT (+ (CHANNEL-FIRST-FILEPOS FILE-CHANNEL-CURRENT)
1532                            (- (CHANNEL-FIRST-COUNT FILE-CHANNEL-CURRENT)
1533                               (CHANNEL-DATA-COUNT FILE-CHANNEL-CURRENT))))
1534           (AND LENGTH (NOT (ZEROP LENGTH))
1535                (SETQ PERCENT (// (* 100. CURRENT)
1536                                  LENGTH)))
1537           TV:(SHEET-SET-CURSORPOS WHO-LINE-WINDOW (WHO-LINE-ITEM-LEFT FS:ITEM) 0)
1538           (COND ((AND (EQ OLD-CHANNEL FILE-CHANNEL-CURRENT)
1539                       (= PERCENT (WHO-LINE-FILE-ITEM-PERCENT ITEM))
1540                       (= CURRENT (WHO-LINE-FILE-ITEM-CURRENT ITEM))))
1541                 (T (OR (EQ OLD-CHANNEL FILE-CHANNEL-CURRENT)
1542                        TV:(SHEET-CLEAR-EOL WHO-LINE-WINDOW))
1543                    (SETF (TV:WHO-LINE-ITEM-STATE ITEM) FILE-CHANNEL-CURRENT)
1544                    (SETF (WHO-LINE-FILE-ITEM-PERCENT ITEM) PERCENT)
1545                    (SETF (WHO-LINE-FILE-ITEM-CURRENT ITEM) CURRENT)
1546                    (TV:SHEET-STRING-OUT TV:WHO-LINE-WINDOW
1547                                         (SELECTQ (CHANNEL-DIRECTION FILE-CHANNEL-CURRENT)
1548                                           (:INPUT " ")
1549                                           (:OUTPUT " ")))
1550                    (SETQ FILE-NAME (IF (STRINGP (CHANNEL-FILE-NAME FILE-CHANNEL-CURRENT))
1551                                        (CHANNEL-FILE-NAME FILE-CHANNEL-CURRENT)
1552                                        (FUNCALL (CHANNEL-FILE-NAME FILE-CHANNEL-CURRENT)
1553                                                 ':STRING-FOR-WHOLINE)))
1554                    (AND ( (STRING-LENGTH FILE-NAME) (- MAX-CHARS 4))
1555                         ;; If not enough room for filename, then truncate
1556                         (SETQ FNTRUNC (- MAX-CHARS 7)))
1557                    (TV:SHEET-STRING-OUT TV:WHO-LINE-WINDOW FILE-NAME 0 FNTRUNC)
1558                    (TV:SHEET-STRING-OUT TV:WHO-LINE-WINDOW (IF FNTRUNC " " "  "))
1559                    (SETQ SP-POS (+ 4 (OR FNTRUNC (STRING-LENGTH FILE-NAME))))
1560                    TV:(SHEET-CLEAR-EOL WHO-LINE-WINDOW)
1561                    (COND ((AND (NOT (ZEROP LENGTH))
1562                                ( (+ SP-POS (STRING-LENGTH (SETQ STRING (FORMAT NIL "~D% ~D"
1563                                                                                 PERCENT
1564                                                                                 CURRENT))))
1565                                   MAX-CHARS)))
1566                          ((NOT (ZEROP LENGTH))
1567                           (WITHOUT-INTERRUPTS
1568                             (RETURN-ARRAY STRING)
1569                             (SETQ STRING (FORMAT NIL "~D%" PERCENT))))
1570                          (T (WITHOUT-INTERRUPTS
1571                               (AND STRING (RETURN-ARRAY STRING))
1572                               (SETQ STRING (FORMAT NIL "~D" CURRENT)))))
1573                    (TV:SHEET-STRING-OUT TV:WHO-LINE-WINDOW STRING
1574                                         0 (MIN (- MAX-CHARS SP-POS) (STRING-LENGTH STRING)))
1575                    (WITHOUT-INTERRUPTS
1576                      (RETURN-ARRAY STRING)
1577                      (SETQ STRING NIL))))))
1578        (SI:WHO-LINE-JUST-COLD-BOOTED-P
1579          (COND ((NEQ (TV:WHO-LINE-ITEM-STATE ITEM) 'COLD)
1580                 (TV:WHO-LINE-PREPARE-FIELD ITEM)
1581                 (SETF (TV:WHO-LINE-ITEM-STATE ITEM) 'COLD)
1582                 (TV:SHEET-STRING-OUT TV:WHO-LINE-WINDOW "Cold-booted"))))
1583        ((> (SETQ IDLE (// (TIME-DIFFERENCE (TIME) TV:KBD-LAST-ACTIVITY-TIME) 3600.)) 4)
1584                                                ;Display keyboard idle time
1585         (LET ((OLD-IDLE (TV:WHO-LINE-ITEM-STATE ITEM)))
1586           (AND OLD-IDLE
1587                (NOT (NUMBERP OLD-IDLE))
1588                (TV:WHO-LINE-PREPARE-FIELD ITEM))
1589           (COND ((OR (NOT (NUMBERP OLD-IDLE)) ( OLD-IDLE IDLE))
1590                  (TV:WHO-LINE-PREPARE-FIELD ITEM)
1591                  (WITHOUT-INTERRUPTS
1592                    (LET ((STRING (FORMAT NIL "Keyboard idle ~D minute~P" IDLE IDLE)))
1593                      (TV:SHEET-STRING-OUT TV:WHO-LINE-WINDOW STRING)
1594                      (RETURN-ARRAY STRING)))
1595                  (SETF (TV:WHO-LINE-ITEM-STATE ITEM) IDLE)))))
1596        (T
1597         (AND (TV:WHO-LINE-ITEM-STATE ITEM)
1598              (TV:WHO-LINE-PREPARE-FIELD ITEM))
1599         (SETF (TV:WHO-LINE-ITEM-STATE ITEM) NIL)
1600         (SETF (WHO-LINE-FILE-ITEM-PERCENT ITEM) -1)
1601         (SETF (WHO-LINE-FILE-ITEM-CURRENT ITEM) -1))))
1602
1603;;; Functions for compatibility
1604(DEFUN FILE-QFASL-P (FILENAME)
1605  (LET ((STREAM (OPEN FILENAME '(:PROBE :ERROR))))
1606    (FUNCALL STREAM ':GET ':QFASLP)))
1607
1608(DEFUN FILE-EXISTS-P (FILENAME)
1609  (LET ((STREAM (OPEN FILENAME '(:PROBE))))
1610    (COND ((STRINGP STREAM) NIL)
1611          ((FUNCALL STREAM ':GET ':QFASLP) ':QFASL)
1612          (T T))))
1613
1614(DEFUN FILE-GET-FILE-INFO (FILENAME)
1615  (LET ((STREAM (OPEN FILENAME '(:PROBE :ASCII))))
1616    ;VERSION, DATE, TIME, LENGTH
1617    (COND ((STRINGP STREAM) NIL)
1618          (T (FUNCALL STREAM ':INFO)))))
1619
1620(DEFUN FILE-ININFO (STREAM)
1621  (FUNCALL STREAM ':INFO))
1622
1623(DEFUN FILE-OUTINFO (STREAM)
1624  (FUNCALL STREAM ':INFO))
1625
1626(DEFUN FILE-OUTRFN (STREAM)
1627  (FUNCALL STREAM ':GET ':UNIQUE-ID))
1628
1629(DEFUN FILE-GET-CREATION-DATE (FILENAME ERROR-P)
1630  (LET ((STREAM (OPEN FILENAME '(:PROBE))))
1631    (COND ((STRINGP STREAM)
1632           (AND ERROR-P
1633                (FILE-PROCESS-ERROR STREAM FILENAME NIL)))      ;not proceedable
1634          (T (LET ((DATE (FUNCALL STREAM ':GET ':CREATION-DATE))
1635                   (TIME (FUNCALL STREAM ':GET ':CREATION-TIME)))
1636               (STRING-APPEND (SUBSTRING DATE 6 8)      ;YY
1637                              "//"
1638                              (SUBSTRING DATE 0 5)      ;MM/DD
1639                              " "
1640                              TIME))))))                ;HH:MM:SS
1641
1642(DEFUN FILE-ERROR-STATUS (FILENAME)
1643  (PROG ((STREAM (OPEN FILENAME '(:PROBE)))
1644         SHORT LONG)
1645        (COND ((STRINGP STREAM)
1646               (MULTIPLE-VALUE (SHORT LONG)
1647                 (FILE-PROCESS-ERROR STREAM FILENAME NIL T))
1648               (RETURN SHORT LONG))
1649              (T (RETURN NIL)))))
1650
1651(DEFUN READFILE (FILE-NAME &OPTIONAL PKG)
1652  (LET ((EOF '(()))
1653        FILE-ID FILE-SYMBOL FILE-GROUP-SYMBOL
1654        (STANDARD-INPUT (OPEN FILE-NAME '(READ))))
1655    (UNWIND-PROTECT
1656      (PROGN
1657        (SETQ FILE-ID (FUNCALL STANDARD-INPUT ':INFO))
1658        (MULTIPLE-VALUE (FILE-SYMBOL FILE-GROUP-SYMBOL)
1659          (GET-FILE-SYMBOLS FILE-NAME))
1660        (FILE-READ-PROPERTY-LIST FILE-GROUP-SYMBOL STANDARD-INPUT)
1661        (LET ((PACKAGE PACKAGE)
1662              (SI:FDEFINE-FILE-SYMBOL FILE-GROUP-SYMBOL))
1663          ;; Enter appropriate environment for the file
1664          (MULTIPLE-VALUE-BIND (VARS VALS) (FILE-PROPERTY-BINDINGS FILE-GROUP-SYMBOL)
1665            (PROGV VARS VALS
1666              ;; If package overridden, do so.  PACKAGE is bound in any case.
1667              (IF PKG (SETQ PACKAGE (PKG-FIND-PACKAGE PKG))
1668                  (FORMAT T "~&Loading file ~A into package ~A~%" FILE-SYMBOL PACKAGE))
1669              (DO FORM (READ STANDARD-INPUT EOF) (READ STANDARD-INPUT EOF)
1670                  (EQ FORM EOF)
1671                (EVAL FORM))
1672              (SET-FILE-LOADED-ID FILE-SYMBOL FILE-ID PACKAGE)))))
1673      (CLOSE STANDARD-INPUT)))
1674  T)
1675
1676;; Does not handle multiple-line property lists.
1677(DEFUN FILE-READ-PROPERTY-LIST (FILE-SYMBOL STREAM)
1678   (DO ((LINE) (EOF-P))
1679       (())
1680     (MULTIPLE-VALUE (LINE EOF-P) (FUNCALL STREAM ':LINE-IN))
1681     (COND (EOF-P
1682            (RETURN NIL))
1683           ((STRING-SEARCH-NOT-SET '(#\SP #\TAB) LINE)
1684            ;; This is the first non-blank line.
1685            (LET ((I (STRING-SEARCH "-*-" LINE)))
1686              (COND ((NOT (NULL I))
1687                     ;; The file has a property list.
1688                     (SETQ I (+ I 3)) ;Move over -*-
1689                     (LET ((END (STRING-SEARCH "-*-" LINE I)))
1690                       ;; For now, don't handle the multiple-line case.
1691                       (LET ((COLON (STRING-SEARCH ":" LINE I END)))
1692                         (COND ((NULL COLON)
1693                                (FILE-ADD-PROPERTY FILE-SYMBOL
1694                                                   "MODE"
1695                                                   (NSUBSTRING LINE I END)))
1696                               (T
1697                                ;; File has full hair with colons and semicolons.
1698                                (DO ((START I (+ 1 SEMI))
1699                                     (COLON) (SEMI))
1700                                    (NIL)
1701                                  (SETQ COLON (STRING-SEARCH-CHAR #/: LINE START END))
1702                                  (COND ((NULL COLON) (RETURN NIL)))
1703                                  (SETQ SEMI (OR (STRING-SEARCH-CHAR #/; LINE (1+ COLON) END)
1704                                                 END))
1705                                  (FILE-ADD-PROPERTY FILE-SYMBOL
1706                                             (NSUBSTRING LINE START COLON)
1707                                             (NSUBSTRING LINE (1+ COLON) SEMI))))))))))
1708            (RETURN NIL))))
1709   (FUNCALL STREAM ':SET-POINTER 0))
1710
1711;Note that property values are read with READ, in base 10 and the keyword package.
1712(DEFUN FILE-ADD-PROPERTY (FILE-SYMBOL INDICATOR VALUE &AUX COMMA (IBASE 10.))
1713  (PKG-BIND ""
1714    (COND ((SETQ COMMA (STRING-SEARCH-CHAR #/, VALUE))
1715           (DO ((COMMA COMMA (STRING-SEARCH-CHAR #/, VALUE (1+ COMMA)))
1716                (BEG 0 (1+ COMMA))
1717                (L NIL))
1718               (NIL)
1719             (PUSH (READ-FROM-STRING (NSUBSTRING VALUE BEG COMMA))
1720                   L)
1721             (COND ((NOT COMMA)
1722                    (SETQ VALUE (NREVERSE L))
1723                    (RETURN NIL)))))
1724          (T (SETQ VALUE (READ-FROM-STRING VALUE))))
1725    (PUTPROP FILE-SYMBOL VALUE (READ-FROM-STRING INDICATOR))))
1726
1727;Use this to get "into" the environment specified by the file.
1728(DEFUN FILE-PROPERTY-BINDINGS (FILE-SYMBOL)
1729  "Returns two values, a list of special variables and a list of values to bind them to."
1730  (DO ((PL (PLIST FILE-SYMBOL) (CDDR PL))
1731       (VARS NIL)
1732       (VALS NIL)
1733       (TEM))
1734      ((NULL PL) (RETURN VARS VALS))
1735    (AND (SETQ TEM (GET (CAR PL) 'FILE-PROPERTY-BINDINGS))
1736         (MULTIPLE-VALUE-BIND (VARS1 VALS1) (FUNCALL TEM FILE-SYMBOL (CAR PL) (CADR PL))
1737           (SETQ VARS (NCONC VARS1 VARS)
1738                 VALS (NCONC VALS1 VALS))))))
1739
1740(DEFUN (:PACKAGE FILE-PROPERTY-BINDINGS) (IGNORE IGNORE PKG)
1741  (PROG () (RETURN (NCONS 'PACKAGE) (NCONS (PKG-FIND-PACKAGE PKG ':ASK)))))
1742
1743(DEFUN (:BASE FILE-PROPERTY-BINDINGS) (FILE IGNORE BSE)
1744  (OR (AND (TYPEP BSE 'FIXNUM) (> BSE 1) (< BSE 37.))
1745      (FERROR NIL "File ~A has an illegal -*- BASE:~S -*-" FILE BSE)) 
1746  (PROG () (RETURN (LIST 'BASE 'IBASE) (LIST BSE BSE))))
1747
1748;;; Find and close all files
1749;;; This should be done better
1750(DEFUN CLOSE-ALL-FILES ()
1751  (DOLIST (HOST FILE-HOST-ALIST)
1752    (DO UNIT (SYMEVAL-IN-CLOSURE (CADR HOST) 'FILE-HOST-FIRST-UNIT)
1753             (HOST-UNIT-LINK UNIT) (NULL UNIT)
1754      (DOLIST (CONN (HOST-UNIT-DATA-CONNECTIONS UNIT))
1755        (LET ((FILE-CHANNEL (NTH 4 CONN)))      ;Input
1756          (COND (FILE-CHANNEL
1757                  (FORMAT T "~&Closing ~S" FILE-CHANNEL)
1758                  (FILE-CLOSE NIL))))
1759        (LET ((FILE-CHANNEL (NTH 6 CONN)))      ;Output
1760          (COND (FILE-CHANNEL
1761                  (FORMAT T "~&Closing ~S" FILE-CHANNEL)
1762                  (FILE-CLOSE NIL))))))))
1763
1764;;; Initializations
1765
1766; Each host is known about as a closure on HOST-NAME-ALIST.
1767; The closure contains all the information necessary to manage connections associated with
1768; the particular host.  The closure-function will in general be a small function which
1769; dispatches to the appropriate routines.  If a particular host needs unusual handling,
1770; it can be done through this mechanism as well.
1771(DEFVAR HOST-FILENAME-FLAVOR-ALIST NIL)
1772
1773;;; This is a function since it otherwise calls functions that aren't loaded yet
1774(DEFUN ADD-FILE-COMPUTER (NAME INITIALIZATION-NAME HOST-TYPE FILE-NAME-TYPE)
1775  (ADD-INITIALIZATION INITIALIZATION-NAME
1776                      `(FUNCALL ',(FILE-HOST NAME HOST-TYPE) ':RESET) '(SYSTEM))
1777  (PUSH (CONS NAME FILE-NAME-TYPE) HOST-FILENAME-FLAVOR-ALIST)
1778  (PUSH (CONS NAME 'FILE-CHAOS-OP-DISPATCH) FILE-DEVICES))
1779
1780(ADD-INITIALIZATION "FILE-COMPUTER:AI"
1781                    '(ADD-FILE-COMPUTER "AI" "FILE-COMPUTER:AI" 'HOST-ITS 'ITS-FILENAME)
1782                    '(ONCE))
1783
1784(ADD-INITIALIZATION "FILE-COMPUTER:MC"
1785                    '(ADD-FILE-COMPUTER "MC" "FILE-COMPUTER:MC" 'HOST-ITS 'ITS-FILENAME)
1786                    '(ONCE))
1787
1788(ADD-INITIALIZATION "FILE-COMPUTER:XX"
1789                    '(ADD-FILE-COMPUTER "XX" "FILE-COMPUTER:XX" 'HOST-TOPS20 'TOPS20-FILENAME)
1790                    '(ONCE))
1791
1792(ADD-INITIALIZATION "FILE-COMPUTER:SPEECH"
1793                    '(ADD-FILE-COMPUTER "SPEECH" "FILE-COMPUTER:SPEECH"
1794                                        'HOST-TOPS20 'TOPS20-FILENAME)
1795                    '(ONCE))
1796
1797(ADD-INITIALIZATION "FILE-COMPUTER:EE"
1798                    '(ADD-FILE-COMPUTER "EE" "FILE-COMPUTER:EE" 'HOST-TOPS20 'TOPS20-FILENAME)
1799                    '(ONCE))
1800
1801
1802(DEFUN FILE-SYSTEM-INIT ()
1803  (SETQ FILE-CHANNEL-CURRENT NIL)
1804  (WITHOUT-INTERRUPTS
1805   (DO ((L FILE-PENDING-TRANSACTIONS (CDR L))
1806        (PKT))
1807       ((NULL L)
1808        (SETQ FILE-PENDING-TRANSACTIONS NIL))
1809     (AND (SETQ PKT (CDAR L))
1810          ;; Since we don't know what is in the packet portion (it could be from any one
1811          ;; of the "many" access path functions) we better do the right thing.
1812          (SELECTQ (TYPEP PKT)
1813            (CHAOS:PKT (FILE-CHAOSNET-CHANNEL-FUNCTION ':RETURN PKT)))))))
1814
1815(ADD-INITIALIZATION "FILE-SYSTEM-INIT" '(FILE-SYSTEM-INIT) '(SYSTEM))
Note: See TracBrowser for help on using the browser.