clu-1976-1989/clu/100260/clusys/load.39

;****	A BASIC CLUSYS FILE    ****

cluster	%load,0,0,[],[]
	
; snap  should  be  called  with  the  address  of   a
; procedure call block  (pcb) and the  address of  the
; entry  block   of  the   procedure  executing   when
; snapping. it will give a  nasty error if the  pc.lnk
; field of  the pcb  does not  refer to  a word  which
; refers back to the pcb.  it will give another  nasty
; error if the pcb refers  to a procedure that is  not
; present in the procedure table. snap returns (if all
; is well) with the procedure object.

proc	snap,[plnk,ent]
	$label	retry		; we will try forever if necessary
	move	r0,plnk(er)
	tcheck	r0,tpcb
	$if	skipe	pc.par(r0)		; if no parms to fool with
	$then	mcall	pfind,[pc.str(r0)]	; look in ptab
	$else	call	desc$pfind,1,[r0,ent(er)] ; look and perhaps build one
	$fi
	$if	came	rr,$none
	$then	slink	lnk,Snap can't find: 
		move	g0,lnk(lr)
		$go	bitch
	$fi
	hrrz	r1,en.lpr(rr)	; get the pr for the found procedure
	hrrz	n1,pr.cut(r1)	; get number of args for that procedure
	hrrz	r0,plnk(er)
	$if	skipn	n2,pc.num(r0)	; if #args < 0, then no test
		cain	n2,-2(n1)	; adjust test for frame size
	$then	slink	lnk,Snap found a bad # of args for: 
		move	g0,lnk(lr)
		$go	bitch
	$fi
	push	sp,rr
	move	r0,ent(er)		; try to fixup linkage
	hlro	r0,en.lpr(r0)
	$ift	mcall	ld.sb,[r0,plnk(er),rr]
	$then	$rtn	(sp)
	$fi
	move	rr,(sp)
	move	r0,ent(er)		; try to fixup proc parms
	hlro	r0,en.par(r0)
	$ift	mcall	ld.sb,[r0,plnk(er),rr]
	$then	$rtn	(sp)
	$fi
	move	rr,(sp)
	move	r0,ent(er)		; try to fixup cluster parms
	hrro	r0,en.par(r0)
	$ift	mcall	ld.sb,[r0,plnk(er),rr]
	$then	$rtn	(sp)
	$fi
	move	rr,(sp)
	$rtn	rr		; and return the procedure object

	$label	bitch		; come here to bitch about something
	mcall	dtyo
	push	sp,rr
	mcall	crlf,[rr]	; get new line
	move	rr,(sp)
	mcall	ch.ws,[rr,g0]	; write the bitch
	move	rr,(sp)
	move	r0,plnk(er)
	mcall	ch.ws,[rr,pc.str(r0)]	; write the name of the offender
	mcall	crlf
	croak	$p gets you a listen loop (maybe).
	mcall	dtyi
	args	[rr]
	mcall	dtyo
	call	listen,2,[rr]	; call to listen again
	$go	retry		; try again if we return
corp	snap,[plnk,ent]

; Load$replace(vec,item,repl) tries to replace all occurences
; of item in vec by repl.  If there was a replacement, it returns
; true, otherwise false.
proc	ld.sb,[vec,item,repl],[flag],[tbool+false]

	move	r0,vec(er)
	$if	trne	r0,-pgsize
	$then	$rtnc	$false
	$fi
	$for	all,rr,mcall	loopv,[r0]
		move	r0,item(er)
		$if	came	r0,(rr)
		$then	move	r1,repl(er)
			movem	r1,(rr)
			move	rr,$true
			movem	rr,flag(er)
		$fi
	$rof	all
	$rtn	flag(er)

corp	load$replace,[vec,item,replace],[flag]

;	xload takes a string and tries to open the named channel.
; it then reads lines and treats them as file names to be fload'd
; into the current environment.

proc	xload,[str],[chan],[0]
	tcheck	str(er),tstr
	slink	lnk,dsk:clusys;
	call	%str$concat,2,[lnk(lr),str(er)]
	assn	str(er),rr
	slink	lnk,read
	call	chan$open,2,[lnk(lr),str(er)]
	assn	chan(er),rr
	$if	hlrz	n0,rr
		cain	n0,(tchan)
	$then	$rtn	rr
	$fi
	$loop
		link	lnk,tchar+12
		call	chan$reads,2,[chan(er),lnk(lr)]
		assn	str(er),rr
		call	%str$size,1,[rr]	
		$if	camg	rr,$two
		$then	call	fload,1,[str(er)]
		$else	call	chan$close,1,[chan(er)]
			$rtnc	$none
		$fi
	$pool

corp	xload,[str],[chan]

; Load$page(chan,addr) attempts to load in a page from
; a load  file by  mapping it  in. If  successful,  it
; makes the  page read-only  to prevent  funny  things
; from happening.
proc	ld.np,[chan,addr]
	movei	n0,0
	hrrz	n1,chan(er)
	hrrz	n2,addr(er)
	idivi	n2,pgsize
	$if	.call	ld.np1(pr)	; did we map it in?
	$then
	$elf	.call	ld.np2(pr)	; try to get new page for reading
	$then	movei	n1,pgsize		; could not map it in, so try to read it
		hrli	n1,(tint)
		call	chan$readvec,3,[chan(er),addr(er),n1]
	$else	croak	Can't get the page to load!
	$fi
	$rtnc	$none
ld.np1==.-proc$
	setz
	sixbit	/corblk/
	5000,,%cbndr+%cbcpy	; copy, read
	n0		; arg1 = 0 (no mod to ctrl bits)
	1000,,%jself	; job = self
	n2		; page number
	setz	n1	; channel #
ld.np2==.-proc$
	setz
	sixbit	/corblk/
	5000,,%cbndr+%cbndw	; read & write the page
	n0		; arg1 = 0 (no mod to ctrl bits)
	1000,,%jself	; job = self
	n2		; page number
	setzi	%jsnew	; try for new page
corp	load$page,[chan,addr]

; Fload takes a string for a file name, then  attempts
; to open a load file  by that name. If successful  it
; calls Load on the resulting channel.

proc	ld.fl,[name],[chan],[0]
	slink	def, bin
	call	%str$concat,2,[name(er),def(lr)]
	slink	lnk,readb
	call	chan$open,2,[lnk(lr),rr]
	movem	rr,chan(er)
	$if	hlrz	n1,rr
		cain	n1,(tchan)
	$then	slink	lnk,Fload could not open a channel for 
		call	%str$concat,2,[lnk(lr),name(er)]
		$rtn	rr
	$fi
	call	load,1,[chan(er)]	; load the file
	movem	rr,name(er)
	call	chan$close,1,[chan(er)]	; close the channel
	$rtn	name(er)
corp	fload,[name],[chan],[0]

; Load takes an open channel,  then reads in what  had
; better be a  load file.  To wit, there  should be  a
; JRST 1 in the  first page of  the file, followed  by
; blocks with the format:
; 	0:  -N,,addr
; 	1-N: data
; 	N: checksum
; This loading process runs out when a block is  found
; with N = 0. The first block to be loaded must be  in
; the "load block" format given here:
 	ld.cod== 0	; tvec+5
	ld.siz== 1	; size of load file
	ld.low== 2	; virtual low bound
	ld.ent== 3	; ref to entry block vector
	ld.ver== 4	; CLU version number
	ld.ref== 5	; ptr to ref area
; Load then calls Load$fix to fix up the loaded stuff,
; then runs around making  the entry blocks happy  and
; entering them into the module table.

proc	ld.ld,[chan],[lolim,size,reloc,source,srclen],[0,0,0,0,0]
	call	load$page,2,[chan(er),$work]
	movei	n1,1
	hrli	n1,(jrst)
	move	r0,$work
	hrli	r0,-pgsize
.here	ld.ld1		; Scan for a JRST 1 to start the file.
		camn	n1,(r0)
		jrst	ld.ld2(pr)
		aobjn	r0,ld.ld1(pr)
		jrst	ld.lde(pr)	; there had better be one!
.here	ld.ld2		; Get the descriptor block & check it
	movei	n1,6
	hrli	n1,(tvec)
	came	n1,ld.cod+2(r0)	; the first word must be tvec+6
	jrst	ld.lde(pr)
	hrrz	n1,1(r0)	; get the low addr from load format
	hrrz	n2,2+ld.low(r0)	; and from the load block itself
	came	n1,n2
	jrst	ld.lde(pr)	; they had better match!
	movem	n2,lolim(er)	; save the low limit
	hlrz	n3,2+ld.ver(r0)	; get the version number
	caie	n3,ones&(myvers); compare against format part
	jrst	ld.lde(pr)	; otherwise we goof off
	hrrz	n1,2+ld.siz(r0)
	movem	n1,size(er)	; and the size of the memory
	hrli	n1,(twvec)
	alloc	(n1),n1		; grab enough memory to load into
	gclock			; stop any GC's
	hrroi	r1,0(rr)	; point at the memory
	movem	r1,reloc(er)	; save that address
	movei	n3,0		; clear to force new virtual ptr
.here	ld.ld3
	jumpl	r0,ld.ld4(pr)	; if work ptr is valid, then use it
	hrrm	n3,source(er)	; save the virtual ptr
	hlrm	n3,srclen(er)
	call	load$page,2,[chan(er),$work]	; grab the page
	move	r0,$work
	hrli	r0,-pgsize	; get ptr to the work area
	move	n3,source(er)	; get virtual ptr
	hrl	n3,srclen(er)	; and the length
.here	ld.ld4
	jumpl	n3,ld.ld6(pr)	; if we can load another word, do so
	aobjn	r0,ld.ld5(pr)	; skip checksum & check for new page needed
	call	load$page,2,[chan(er),$work]	; grab the page
	move	r0,$work
	hrli	r0,-pgsize	; get ptr to the work area
.here	ld.ld5
	$if	skipge	n3,(r0)	; get new virtual ptr & check for loading done
	$then	call	load$fix,5,[reloc(er),size(er),lolim(er),size(er),reloc(er)]
		move	r0,reloc(er)	; get the first word address
		$if	skipn	r1,ld.ref(r0)	; if there are strings to fix up
		$then	add	r0,ld.siz(r0)
			hrli	r0,(trel)
			move	g1,r0
			$loop			; then start to fix them
				hrli	r1,(trel)
				$if	camge	r1,g1		; test for end of area
				$then	$go	sfixed
				$fi
				hlrz	n2,(r1)
				$if	caie	n2,(tsrep)	; fix the string
				$then	hrli	r1,(trel)
					push	sp,g1
					call	load$string_fix,1,[r1]
					pop	sp,g1
					move	r1,rr
				$elf	caie	n2,(tarep)	; skip the array block
				$then	addi	r1,3
				$elf	cail	n2,typrep
					cail	n2,typrsb
				$then	hrrz	n1,(r1)
					addi	r1,(n1)		; skip the block
				$else	aos	r1		; skip any other word
				$fi
			$pool
			$label	sfixed
		$fi

		move	r0,reloc(er)	; get the first word address
		$for	all,rr,call	loopv,1,[ld.ent(r0)] ; for all entry blocks, do
			push	sp,(rr)		; save the entry block
			call	pname,1,[(rr)]	; get the name it wants
			push	sp,rr		; save that, too
			$if	camn	rr,$nulls
			$then	call	%table$value,2,[$mtab,rr]	; get old entry
				pop	sp,g0			; restore the name
				pop	sp,g1			; restore the entry
				push	sp,rr			; save the old guy
				hrrz	r0,rr
				$if	cail	r0,stack
				$then	croak	Attempt to redefine an initial module !
				$fi
				call	%table$enter,3,[$mtab,g0,g1]
				pop	sp,rr	; restore the old guy
				$if	camn	rr,$none
				$then	movei	n1,relink ; change setup call
					hrrm	n1,en.set(rr) ; to relink
				$fi
			$fi
		$rof	all
		move	rr,chan(er)
		jrst	ld.ldx(pr)
	$fi
	aobjp	r0,ld.ld3(pr)	; skip over block ptr word & get new page if needed
.here	ld.ld6			; come here to move a bunch of words
				; n3 is aobjn to virtual area
				; r0 is aobjn to work area
	hlre	n2,n3
	movn	n2,n2		; get length of virtual ptr
	hlre	n1,r0
	movn	n1,n1		; and length of work ptr
	camle	n1,n2
	exch	n1,n2		; n1 now has min length to blt
	hrrz	n0,n3
	sub	n0,lolim(er)
	jumpl	n0,ld.lde(pr)	; if low limit too low, error
	hrrz	br,reloc(er)
	add	br,n0		; save for destination address
	add	n0,n1		; add in blt length
	camle	n0,size(er)
	jrst	ld.lde(pr)	; if too long to blt, then error
	hrrz	r1,br		; get dest address
	addi	r1,-1(n1)	; find last word address
	hrl	br,r0		; get work area address as source
	blt	br,(r1)		; move all possible words
	hrl	n1,n1		; duplicate the size moved
	add	n3,n1		; update the aobjn ptrs
	add	r0,n1
	jrst	ld.ld3(pr)	; and go test for source acceptability
.here	ld.lde
	croak	Bad load file!!!!
	slink	lnk,Load failed.
	move	rr,lnk(lr)
.here	ld.ldx
	gcsafe
	$rtn	rr
corp	load,[chan],[lolim,size,reloc,source,srclen]


; Load$fix(src,srclen,reflow,reflen,reloc)  scans  the
; area from src for srclen, looking for references  to
; the area from reflow  to reflen, and relocates  such
; references to point at the area starting at reloc.

;	macro to perform one case
define	.case	x
jrst	lf.nxt(pr)
$elf	caie	n2,(t!x)
$then	.case.==0
termin

;	macro to skip a word of rsb's
define	.skip	pos
ifsn	pos,,[
	kvetch	pos-.case.,n,Bad position in .skip pos !
	.case.==.case.+1
	]
aobjp	r0,lf.ex(pr)
move	n1,(r0)
termin

;	macro to relocate the right half of current word
define	.rel	pos
ifsn	pos,,[
	kvetch	pos-.case.,n,Bad position in .rel pos !
	.case.==.case.+1
	]
jsp	r1,lf.rel(pr)
termin

;	macro to relocate both halves of current word
define	.pair	pos
ifsn	pos,,[
	kvetch	pos-.case.,n,Bad position in .pair pos !
	.case.==.case.+1
	]
jsp	r1,lf.par(pr)
termin

;	macro to snap setup words
define	.set	pos
ifsn	pos,,[
	kvetch	pos-.case.,n,Bad position in .set pos !
	.case.==.case.+1
	]
jsp	r1,lf.set(pr)
termin

proc	ld.fx,[src,srclen,reflow,reflen,reloc]
	move	r0,src(er)
	movn	n1,srclen(er)
	hrl	r0,n1		; r1 is aobjn to source for fix
	hrrz	g0,reflow(er)	; g0 points to ref bottom
	hrrz	n3,reflen(er)	; n3 is size of ref area
	move	g1,reloc(er)	; g1 points to start of reloc area
.here	lf.get
	$crtnc	r0,ge,$none
	move	n1,(r0)
.here	lf.nxt
.case.==0
	hlrz	n2,n1
	$if	skipl	n1
	$then	.rel
	$elf	cail	n2,typlo
	$then	.skip
	$elf	cail	n2,typrep
	$then	.rel
	$elf	caige	n2,(tbad)
	$then	.skip
	$elf	caige	n2,typrsb
	$then	$if	cail	n2,typref
		$then	.skip
		$elf	cail	n2,typusr
		$then	.rel
		$else	croak	User relocation not yet implemented!
			.skip
		$fi
	.case	arep		; arrays
		.skip	ar.cod
		.rel	ar.vec
		.rel	ar.rel
	.case	crep		; call blocks
		.skip	pc.cod
		.set	pc.set
		.skip	pc.num
	.case	drep		; descriptors
		.skip	td.cod
		.rel	td.fix
		.skip	td.opt
	.case	erep		; entry blocks
		.skip	en.cod
		.set	en.set
		.pair	en.lpr
		movs	n1,n1	; en.vi is (ref+1,,rsb)
		sos	n1
		movem	n1,(r0)
		.rel	en.vi
		move	n1,-1(r0)
		aos	n1
		movsm	n1,-1(r0)
		.pair	en.par
		.rel	en.tr
	.case	orep		; oneofs
		.skip	on.cod
	.case	prep		; pure parts
		.skip	pr.cod
		sos	n1	; adjust because r0 is one farther
		hrl	n1,n1
		add	r0,n1
		jrst	lf.get(pr)
	.case	srep		; strings
		movei	n1,bpword+bpword-1(n1)
		idivi	n1,bpword	; get # of words to skip
		hrl	n1,n1		; duplicate the number
		add	r0,n1		; point at next stuff to fix
		jrst	lf.get(pr)
	.case	vec		; vectors
		.skip
	.case	wvec		; word vectors
		hrl	n1,n1
		add	r0,n1
		jrst	lf.get(pr)
	.case	xrep		; ref vector
		hrrz	n1,n1
		push	sp,n1
		.skip
		$loop
			$if	sosg	(sp)
			$then	.rel
			$else	jrst	lf.nxt(pr)
			$fi
		$pool
	$fi
	jrst	lf.nxt(pr)

.here	lf.par			; reloc a pair of refs (ref,,ref)
	hlrz	n2,n1
	sub	n2,g0
	jumpl	n2,lf.skp(pr)
	caml	n2,n3
	jrst	lf.rel(pr)
	add	n2,g1		; add in relocation
	hrlm	n2,(r0)		; insert the left half back into mem
.here	lf.rel
	hrrz	n1,n1
	sub	n1,g0		; check for validity of ref at bottom
	jumpl	n1,lf.skp(pr)
	caml	n1,n3		; must be under (or at) the top, too
	jrst	lf.skp(pr)
	add	n1,g1		; add in relocation
	hrrm	n1,(r0)		; relocate the right half
.here	lf.skp
	.skip
	jrst	(r1)		; and return to caller
.here	lf.set
	trne	n1,-typlo	; check for n1 being in the common area
	jrst	lf.skp(pr)
	trnn	n1,-comadr
	jrst	lf.skp(pr)	; skip if it is not
	hlrz	n2,(n1)
	caie	n2,(jrst)	; is it a link to a jrst ?
	jrst	lf.skp(pr)
	hrr	n1,(n1)		; yes, so change it
	movem	n1,(r0)
	jrst	lf.skp(pr)	; and go skip the word

.here	lf.ex			; to exit, come here
	$rtnc	$none
corp	load$fix,[src,srclen,reflow,reflen,reloc]

proc	ld.sf,[rel]
	move	r0,rel(er)
	tcheck	r0,trel
	move	rr,r0		; save the start in rr
	hrli	r0,(bsize)
	move	r1,r0
	hrro	g1,r1		; save the start
	hrre	n3,(r0)		; grab the size in bytes
	$loop
		$if	sosl	n3
		$then	$go	done
		$fi
		ildb	n1,r1	; grab byte from source
		$label	again
		$if	caie	n1,"\
		$then	movei	n2,3
			movei	n1,0
			$loop
				$if	sosl	n2
				$then	$go	next
				$fi
				$if	sosl	n3
				$then	idpb	n1,r0
					$go	done
				$fi
				ildb	n0,r1
				$if	cail	n0,"0
					caile	n0,"7
				$then	rot	n1,3
					andi	n0,7
					add	n1,n0
					sos	(rr)	; keep track of chars missed
				$else	idpb	n1,r0
					move	n1,n0
					$go	again
				$fi
			$pool
		$fi
		$label	next
		idpb	n1,r0		; deposit byte to dest
	$pool

	$label	done
	movei	n1,0
	$loop
		$if	came	r0,r1
		$then	hrrz	n1,(rr)			; and the number of bytes
			addi	n1,bpword+bpword-1	; adjust to get # of words
			idivi	n1,bpword
			add	rr,n1			; skip them
			$rtn	rr			; and return the ptr
		$fi
		idpb	n1,r0		; clear out remainder of string
	$pool

corp	load$string_fix,[rel]


retsulc	%load