.title	MEMORY mapping routines, GB September 1981

	.psect	memorywrt, wrt, noexe

fskel:	$fab	fop=<cbt,ufo>, fac=<get,put,trn>, shr=<get,put,upi>, nam=nam
fab:	$fab
nam:	$nam	rsa=res, rss=127
res:	.blkb	127
fablen = fab-fskel

	$fibdef

	$fatdef
fat:	.blkb	20

	$atrdef
acb:	.word	20, atr$c_recattr
	.long	fat
	.long	0

iosb:	.quad	0

vmlist::.long	vmlist, vmlist

	.psect	memorycode, exe, nowrt

	$secdef

; %integerfn connect (%string(127) file, %integername start, length,
;                     %integer flags)
;
; Connects 'file' at the next free memory page, the address being returned
; in 'start'.  This address acts as a unique identifier for the mapped area.
; The length of the file, in bytes, is returned in 'length'.
; 'flags' specifies the access which the users requires to (a) the mapped
; memory, and (b) the file.  If bit 0 is set, write access to the mapped
; memory is required.  If bit 1 is set, write access to the file is required.
; If both bits are set, write access to the file is allowed if possible,
; otherwise write access to the mapped memory is provided.  If more than
; one process writes to a mapped file, the data which other processes read
; from their mapped areas subsequently must be regarded as undefined.
; The value returned by the function is a standard VMS status code.  If the
; least significant bit is zero, something went wrong.  The more carefree
; user might prefer to %spec 'connect' as a routine, and ignore errors.

	.entry	connect, ^m<r2,r3,r4,r5,r6,r7>
file = 4
start = 8
length = 12
flags = 16
	movc3	#fablen, fskel, fab
	movl	file(ap), r2
	movzbl	(r2)+, r3
	$fab_store fab=fab, fna=(r2), fns=r3
	movl	#sec$m_expreg, r2
	movl	#fib$m_write, r5
	clrl	r6
	extzv	#0, #2, flags(ap), r7
	beql	20$
	bisl	#sec$m_wrt, r2
	bitl	#2, r7
	beql	10$
	$open	fab=fab
	blbs	r0, 30$
	blbs	r7, 10$
	ret
10$:	bisl	#sec$m_crf, r2
20$:	bicl	#fib$m_write, r5
	$fab_store fab=fab, fac=<get>
	$open	fab=fab
30$:	brb	common


; %integerfn create (%string(127) file, %integername start, %integer length)
;
; Similar to 'connect', except that it creates the file with 'length' bytes.

	.entry	create, ^m<r2,r3,r4,r5,r6,r7>
file = 4
start = 8
length = 12
	movc3	#fablen, fskel, fab
	movl	file(ap), r2
	movzbl	(r2)+, r3
	addl3	#511, length(ap), r4
	ashl	#-9, r4, r4
	$fab_store fab=fab, alq=r4, fna=(r2), fns=r3
	movl	#sec$m_expreg!sec$m_wrt, r2
	movl	#fib$m_write, r5
	movzbl	#1, r6
	$create	fab=fab

common:
	blbc	r0, 50$
	subl	#8, sp
	movl	sp, r3
	movzwl	fab+fab$l_stv, r4
	$crmpsc_s flags=r2, inadr=(r3), retadr=(r3), chan=r4
	blbs	r0, 60$
	pushl	r0
	$dassgn_s r4
	movl	(sp)+, r0
50$:	ret
60$:	movzbl	nam+nam$b_rsl, r7
	addl3	r7, #69, -(sp)
	pushal	-(sp)
	pushal	8(sp)
	calls	#2, g^lib$get_vm
	movl	(sp), r1
	movq	(r3), 8(r1)
	movw	r4, 16(r1)
	movl	r2, 18(r1)
	movl	#32, 22(r1)
	movab	30(r1), 26(r1)
	movl	r5, 30(r1)
	movl	nam+nam$w_fid, 34(r1)
	movw	nam+nam$w_fid+4, 38(r1)
	clrq	40(r1)
	clrq	48(r1)
	insque	(r1), vmlist
	movl	(r3), @start(ap)
	movab	22(r1), r5
	tstl	r6
	beql	70$
	movl	length(ap), r3
	jsb	setsize
	brb	80$
70$:	jsb	getsize
	movl	r3, @length(ap)
80$:	movl	(sp)+, r1
	clrw	62(r1)
	movl	r3, 64(r1)
	movb	r7, 68(r1)
	movc3	r7, res, 69(r1)
	movzwl	#ss$_normal, r0
	ret


; %integerfn update (%integer start)
; Ensures that the area of mapped memory starting at address 'start'
; has been preserved in its associated file.  Note that all mapped areas are
; updated automatically when the program terminates.
; The value returned by the function is a standard VMS status code.

	.entry	update, ^m<r2>
start = 4
	movl	start(ap), r0
	jsb	locate
	$updsec_s inadr=8(r2), updflg=#1, iosb=iosb
	blbc	r0, 10$
	$waitfr_s #0
	movzwl	iosb, r0
10$:	ret


; %integerfn change size(%integername start, %integer length)
;
; Alters the size of the file and the associated are of mapped memory to
; 'length' bytes.  A new start address may be returned in 'start'.

	.entry	changesize, ^m<r2,r3,r4,r5,r6>
start = 4
length = 8
	movl	@start(ap), r0
	jsb	locate
	$deltva_s 8(r2)
	jsb	check
	movzwl	16(r2), r4
	movab	22(r2), r5
	$qiow_s	#0, r4, #io$_deaccess, iosb, p1=(r5)
	jsb	check
	jsb	getsize
	movzwl	fat+fat$l_hiblk+2, r3
	addl3	#511, length(ap), r6
	ashl	#-9, r6, r6
	movab	30(r2), r0
	subl	r6, r3
	beql	30$
	blss	10$
	movw	#fib$m_trunc, fib$w_exctl(r0)
	addl3	#1, r6, fib$l_exvbn(r0)
	clrl	fib$l_exsz(r0)
	brb	20$
10$:	movw	#fib$m_extend!fib$m_alconb, fib$w_exctl(r0)
	clrl	fib$l_exvbn(r0)
	mnegl	r3, fib$l_exsz(r0)
20$:	$qiow_s #0, r4, #io$_modify, iosb, p1=(r5)
	jsb	check
30$:	movl	length(ap), r3
	jsb	setsize
	$qiow_s	#0, r4, #io$_access!io$m_access, iosb, p1=(r5)
	jsb	check
	$crmpsc_s flags=18(r2), inadr=8(r2), retadr=8(r2), chan=r4
	blbc	r0, 40$
	movl	8(r2), @start(ap)
	movl	r3, 64(r2)
	movzwl	#ss$_normal, r0
40$:	ret


; %integerfn disconnect(%integer start)
; Updates the file associated with the mapped area starting at 'start',
; and then disconnects it.  Note that all connected files are disconnected
; automatically when the program terminates.
; The value returned by the function is a standard VMS status code.  However,
; the possible values are so uninteresting that 'disconnect' is best
; %spec-ed as a routine.

	.entry	disconnect, ^m<r2>
start = 4
	movl	start(ap), r0
	jsb	locate
	$deltva_s 8(r2)
	$dassgn_s 16(r2)
	pushl	#64
	remque	(r2), -(sp)
	pushal	(sp)
	pushal	8(sp)
	calls	#2, g^lib$free_vm
	movzwl	#ss$_normal, r0
	ret


; Subroutine 'locate' searches for the mapped area starting at the address
; in r0.  If it is found, a pointer to its information block is returned in
; r2.  Otherwise, a failure status is returned to the user.

locate:
	moval	vmlist, r2
	movl	r2, r1
loop:	movl	(r2), r2
	cmpl	r2, r1
	beql	absent
	cmpl	8(r2), r0
	bneq	loop
	rsb
absent:	movzwl	#ss$_nosuchsec, r0
	ret


getsize:
	movl	4(r5), r0
	clrw	fib$w_exctl(r0)
	$qiow_s #0, r4, #io$_access, iosb, p1=(r5), p5=#acb
	jsb	check
	movzwl	fat+fat$l_efblk+2, r0
	decl	r0
	ashl	#9, r0, r0
	movzwl	fat+fat$w_ffbyte, r3
	addl	r0, r3
	rsb


setsize:
	movl	4(r5), r0
	clrw	fib$w_exctl(r0)
	$qiow_s #0, r4, #io$_access, iosb, p1=(r5), p5=#acb
	jsb	check
	bicl3	#^xFE00, r3, fat+fat$w_ffbyte
	ashl	#-9, r3, r0
	incl	r0
	movw	r0, fat+fat$l_efblk+2
	$qiow_s #0, r4, #io$_modify, iosb, p1=(r5), p5=#acb
	jsb	check
	rsb


check:
	blbc	r0, error
	movl	iosb, r0
	blbc	r0, error
	rsb
error:	ret



; %routine array (%name name, %integer addr, lb1, ub1, ..., lbn, ubn)
; Creates an n-dimensional array ('lb1' : 'ub1', ... ,'lbn' : 'ubn'), n > 0,
; starting at address 'addr'.  'name', which must have an actual parameter of
; type %array(n)%name, is pointed at the new array.  The dimensionality of the
; array, n, is determined by the number of parameters which the user includes
; in the %spec of 'array' (all good clean stuff !).

	.entry	array, ^m<r2,r3>
name = 4
width = 8
start = 12
bounds = 16
	subl3	#3, (ap), r2
	ashl	#-1, r2, r2
	mull3	#12, r2, r3
	addl3	r3, #4, -(sp)
	pushal	-(sp)
	pushal	8(sp)
	calls	#2, g^lib$get_vm
	movl	(sp)+, r0
	movl	name(ap), r1
	movl	start(ap), (r1)
	movl	r0, 4(r1)
	movl	r2, (r0)+
	moval	bounds(ap), r3
10$:	movq	(r3), (r0)+
	subl3	(r3)+, (r3)+, r1
	addl3	#1, r1, (r0)+
	sobgtr	r2, 10$
	movzwl	width(ap), -(r0)
	ret


; %integerfn array addr (%name name)
; Returns the start address of the array pointed to by 'name'.

	.entry	arrayaddr, ^m<>
name = 4
	movl	@name(ap), r0
	ret


; %integerfn array size (%name name)
; Returns the size, in bytes, of the array pointed to by 'name'.

	.entry	arraysize, ^m<r2,r3>
name = 4
width = 8
	movzbl	#1, r0
	movl	name(ap), r1
	movl	4(r1), r1
	movl	(r1)+, r2
10$:	subl3	(r1)+, (r1), r3
	incl	r3
	mull	r3, r0
	addl	#8, r1
	sobgtr	r2, 10$
	movzwl	width(ap), r3
	mull	r3, r0
	ret


; %integerfn size (%name name)
; Returns the size, in bytes, of the scalar pointed to by 'name'.

	.entry	size, ^m<>
name = 4
width = 8
	movzwl	width(ap), r0
	ret


	.end