;;; -*-MIDAS-*- 
TITLE ARYADR
 .insrt sys:.fasl defs
.fasl

VERPRT ARYADR


;Following DECLARE should be in any file which uses this function
;(declare (fixnum (ARRAY-ADDR () fixnum)))

;FILE-ARRAY-GET takes an "array" as first arg, and a symbolic name of a
;  numeric file-array constituent as second arg.  (FILE-ARRAY-GET foo 'CHAN)
;  will get the internal channel number of the file, and on TWENEX type
;  systems, (FILE-ARRAY-GET foo 'JFN) will get the JFN.  Permissible
;  "properties" are MODE, CHAN, JFN, and LENGTH.
;ARRAY-ADDR takes an "array" as first arg, and a fixnum (say, 'i') as second,
;  and returns a fixnum, which is the address of the i'th word of the array
;WARNING! be aware that if an array-relocation occurs between the time you
;  get the array address, and the time at which you use it, you will lose.
;  Of course, you wouldn't want to do anything in that time interval which
;  would likely force an array-space relocation (such as creating new arrays,
;  or loading in files, or calling GETSP etc), but what about asynchronous
;  interrupts?  Well, try using the NOINTERRUPT function; e.g.
;  (PROGN (SETQ OLD-NOI (NOINTERRUPT 'T))
; 	  (SETQ ADDR (ARRAY-ADDR ARY 15.))
; 	  (FROBULATE-A-LITTLE ON ARGS)
; 	  (USE ADDR)
; 	  (NOINTERRUPT OLD-NOI)



.entry ARRAY-ADDR SUBR 003
	push p,cfix1
	jsp t,fxnv2		;This depends upon GET not
	caml d,[-10]
	 caile d,1_16.		; disturbing register D
	  jrst IOOR
	move tt,A
	lsh tt,-11
	hrrz tt,st(tt)
	cain tt,.atom ARRAY
	 jrst PT1
	caie tt,.atom SYMBOL
	 jrst BADA
	movei B,.atom ARRAY
	call 2,.function GET
	jumpe A,BADA
PT1:	hrrz tt,ttsar(A)
	add tt,D
	popj p,
BADA:	lerr [SIXBIT |BAD ARG TO ARRAY-ADDR!|]
IOOR:	lerr [SIXBIT |INDEX OUT OF RANGE  -  ARRAY-ADDR!|]

.entry FILE-ARRAY-GET subr 003
TG0:	move ar2a,a
	call 1,.function FILEP
	jumpe a,NAF
	skipa a,b
UFP:	wta |UNRECOGNIZED FILE PROPERTY - FILE-ARRAY-GET!|
	seto tt,
	caie a,.atom MODE
	 movei tt,F.MODE
	caie a,.atom CHAN
	 movei tt,F.CHAN
	caie a,.atom JFN
	 movei tt,F.JFN
	caie a,.atom LENGTH
	 movei tt,F.FLEN
	jumpl tt,UFP
	move tt,@ttsar(ar2a)
	jrst fix1

NAF:	wta |NOT A FILE - FILE-ARRAY-GET!|
	jrst tg0

fasend