Context Navigation

qfile.lisp @ 239

Revision 239, 77.9 KB (checked in by rjs, 22 months 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.
1353	Type 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.

Download in other formats:

Original Format