comment %

		HEAP MANAGER

these functions ar based on an algorythm described by Knuth in
	"The Art of Computer Programming"

Original work done by Shel Kaphan (SK@SAIL) ca. 1978

Revamped and augmented by Dave Dyer (DDYER@ISIB) ca. 1979.
Adapted for PASCAL usage by Dave Dyer, ca. 1980.

No Rights Reserved.

%
;assumptions made by the Pascal compiler for Pascal use:
;  args:
;    NEW
;	size of block in 2
;    DISPOSE
;	pointer in 2
;	size of block in 3
;  sideeffects:
;    any memory needed is gotten from the Pascal heap, via GETNEW.
;    currently there is no way to return memory to the heap
;    AC's 0 to 6 are assumed free for use by NEW and DISPOSE.  No others
;	are used.  Note that the compiler will save AC's 2 to 6 if they
;	are active, and will recompute 1 (the display pointer) if it is needed


; parameters, program begins on next page
define params
<.twseg==:1		; set =0 for oneseg version
search pasunv
.sat==:00		; 1= stand alone test version
			; -1 for quiet test
ifn tops10,<opsys==:-1>
ife tops10,<
	ifn tenex,<opsys==:0>
	ife tenex,<opsys==:1>
> ;ife tops10
			; -1= tops10 version
			; 0 = tenex
			; 1 = tops20
bakwd==:1		; 1= allocate from top down, 0=bottom up
			;with bakwd on, uses GETNEW in PASIO, with it off,
			;conventional allocation at .JBFF.
xsize==:1		; 1= insist on allocating EXACT size requested.
			; 0= otherwise, can be a few words bigger.
			; and therefore doesn't check size of returned objects.
nil=377777		; representation of NIL
pagsiz=777		;should use 1777 for tops10&kacpu, since that uses K
			; instead of pages.  However since they also don't do
			; auto-expansion but allocate in a fixed space, I
			; want to minimize the use of their space.
.clear==:0		;if nonzero, clear the area
>
params
	UNIVERSAL USEDEF

comment *

 subtoutines use ac 17 as a stack
   take arguments in ac1 ac2 ..
   return values in  ac1 ac2 ..
do NOT modify any ac that is not a returned value

*
;accumulators
T1=2
T2=T1+1
T3=T2+1
T4=T3+1
T5=T4+1
P=17
if1,<
ifn .sat, <PRINTX STAND ALONE TEST version>
ifl opsys,<printx Tops-10 version>
ife opsys,<printx TENEX version>
ifg opsys,<printx Tops-20 version>
ifn pagsiz-777,<printx Non-standard page size>
ifn bakwd,<printx BACKWARD version>
>
ifn .twseg,<		;macros for oneseg version
if1,<printx TWOSEG version>
define ini(a,b)
<	title A B
params
ife opsys,<	search stenex>
ifg opsys,<	search monsym>
ifn .twseg,<
	twoseg
	reloc 0
	reloc 400000
	..loc==:1
>
ife .twseg,<..loc==:0>
	pure
entry	a
a::>

define pure
<ife ..loc,<	reloc>
>
define impure
<ifn ..loc,<	reloc>
>
>
ife .twseg,<		;macros for twoseg version
if1,< printx ONESEG version>
define ini
<	..loc==:0
>
define pure<>
define impure<>
>

define typ(msg)
<ifge opsys,<
	hrroi	1,msg
	psout
>
ifl opsys,<
	outstr	msg
>
>
define typc(chr)
<ifl opsys,<
	outchr	chr
>
ifge opsys,<
	move	1,chr
	pbout
>
>
define error(msg)
<
ifl opsys,<
	OUTSTR	[ASCIZ/?
? MSG
/]
ifn .sat,<
	EXIT	1,
	POPJ	P,
> ;ifn .sat
ife .sat,<
	HRRZ	0,-1(P)	;get return pc
	PUSHJ	P,RUNER.##
> ;ife .sat
> ;ifl opsys

ifge OPSYS,<
ifn .sat,<	PUSH	P,1>
	HRROI	1,[ASCIZ/?
? MSG
/]
	PSOUT
ifn .sat,<
	HALTF
	POP	P,1
	POPJ	P,
> ;ifn .sat
ife .sat,<
	HRRZ	0,-1(P)	;get return pc
	PUSHJ	P,RUNER.##
> ;ife .sat
> ;ifge opsys
> ;define error
	prgend;
	SEARCH	USEDEF
INI	HEAP,<nontrivial heap allocator>

COMMENT %

ENTRY POINTS

NEW		call to get a block
		MOVEI	B,SIZE
		PUSHJ	P,NEW
		RETURN HERE
		  B=BLOCK, RPART of -1 and N+1 available
DISPOS		call to release a block
		MOVE	B,ADDR   or MOVE B,[SIZE,,ADDR]
		PUSHJ	P,DISPOS
		RETURN HERE
CAINIT		call to initialize (once only)
		RETURN HERE, AC 1 2 3 4 used
CASIZE		call to verify ca data base,
		return USED,,FREE

ALL with return on success, or trap to pascal if an error is detected.

standard boundary tag heap allocation.
unallocated blocks kept in doubly linked lists.
two words overhead per area

free storage list looks like
word 0:		[tag bit][size of block],,[link to next block]
word 1:					  [link to previous block]
.
.
.
word N-1:	[tag bit][size=N]	,,0

when block adjacent to a free area is released, the free area is
unlinked from the avail list temporarily, merged with the newly
released area, and then the whole block is put onto the free list.
%

;
; call with pointer in T1
;
ENTRY DISPOS		;this is what gets it pulled in

ife .sat,<	;for Pascal only
entry dispf.		;special entry for records with files in them

dispf.:	pushj p,dispc.##
	;jrst dispos	;fall into regular dispose
> ;ife .sat

DISPOS::
ifn .sat,<
	PUSH	P,T2
	PUSH	P,T3
	PUSH	P,T4
>
ifn xsize,<
	MOVE	T3,T2		; get (optional) size
>
	ANDI	T1,-1		; get adress part only
	CAIE	T1,NIL		; trying to release nil?
	SOSG	T2,T1		; jump if zero being disposed.
	 PUSHJ	P,RLSBXR

; some consistancy checking
	HLRE	T4,(T2)		; get size of block
	JUMPL	T4,.+2		;tag bit must be on!
	PUSHJ	P,RLSDED	;already killed!

	ANDI	T4,377777	;get size
	CAIGE	T4,3		;must be at least this big to be real
	 PUSHJ	P,RLSDED	;so spread the bad news

ifn xsize,<
	JUMPE	T3,RLSC1	;jump if he didn't claim to know then size
	CAIE	T3,-2(T4)	;is he as smart as he thought?
	 PUSHJ	P,RLSDED	;no.
>
RLSC1:	ADDI	T4,(T2)		;ptr to next block
	MOVE	T3,-1(T4)	;get end tag
	XOR	T3,(T2)		;compare with begin tag
	TLNE	T3,-1		;must match
	 PUSHJ	P,RLSDED	;BAD NEWS!

	SKIPGE	-1(T2)		;previous block free?
	JRST	RLSB3		;no, don't merge to this block.

RLSB2:	;preserve t4
	MOVE	T1,T2		;get ptr to current block in T1
	HLRZ	T3,-1(T2)	;get size of previous block
	SUBI	T1,(T3)		;get ptr to start of previous block
	PUSHJ	P,UNLINK	;unlink previous area from avail list
	HLRZ	T2,(T2)		;get size of current block
	HLRZ	T3,(T1)		;get size of previous in T4
	ADDI	T2,(T3)		;	(t4 was smashed in UNLINK)
	HRLM	T2,(T1)		;add to size of previous block

	MOVE	T2,T1		;move pointer to previous block
RLSB3:	; t4 preserved
	MOVE	T1,T4
	SKIPGE	(T4)		;free?
	 JRST	RLSB5		;no, don't merge next
	PUSHJ	P,UNLINK	;unlink next area
	HLRZ	T3,(T1)		;get size of next
	ADD	T1,T3		;first element after merged block
	HLRZ	T4,(T2)		;size of current
	ANDI	T4,377777	;throw out tag bit (or else!)
	ADDI	T3,(T4)		;sum = size of merged block
	HRLM	T3,(T2)		;deposit into size of first

RLSB5:	;T1=LAST+1, T2=FIRST-1
	HLRZ	T4,(T2)		;total size of block to be released.
	ANDI	T4,377777	;make sure tag bit off
	HRLZM	T4,(T2)		;put size, tag in first word
	HRLZM	T4,-1(T1)	;put size, tag in last word

;this code (hopefully) links the new block to the end of the list

	HRRZ	T4,AVAIL+1	;get back link of avail list
	HRRM	T4,1(T2)	;back link new block to previous end
	HRRM	T2,(T4)		;forward link old end of list to block

	MOVEI	T4,AVAIL
	HRRM	T4,(T2)		;forward link block to avail list head
	HRRM	T2,1(T4)	;back link list head to current block

	SETZ	T1,
POPJX:
ifn .sat,<
	POP	P,T4
	POP	P,T3
	POP	P,T2
>
	POPJ	P,

RLSDED:
ERROR<DISPOSE called with clobbered or already-disposed object>
	POPJ	P,	;if he continues, ignore error

RLSBXR:
ERROR<DISPOSE called with zero or NIL poiniter>
	POP	P,(P)	;if he continues, exit dispose
	JRST	POPJX
	



;
; allocate a block of heap.
;
;ENTRY NEW		;no entry, so old memory manager can be used
NEW::
ifn .sat,<
	PUSH	P,T2
	PUSH	P,T3
	PUSH	P,T4
>
	SKIPE	BEGMEM		;init memory if not done yet
	 JRST	GET001
	PUSH	P,T1		;preserve size over call to cainit
	PUSHJ	P,CAINIT
	POP	P,T1
GET001:	SKIPG	T2,T1
	PUSHJ	P,GETBXR
	ADDI	T2,2
GETRTY:	MOVEI	T1,AVAIL		;get available list header
	
GETBF0:	HRRZ	T3,(T1)		;get link to next element of list
	HLRZ	T4,(T1)		;get size of this element
	CAIG	T2,(T4)		;area big enough?
	JRST	GETBF1		;yes, allocate out of it
GETB00:	HRRZ	T1,T3		;save pointer
	CAIE	T3,AVAIL	;back to avail list?
	JRST	GETBF0		;if not, keep trying.


GETBXX:	MOVE	T1,T2		;try memory expansion
	PUSH	P,T2		;preserve size over call to .alcor
IFE BAKWD,<
	MOVE	T2,ENDMEM
>
IFN BAKWD,<
	MOVE	T2,BEGMEM
>
	MOVEM	T2,SYSFF##
	PUSHJ	P,RECALC	;re init for expanded memory
	POP	P,T2
	JRST	GETRTY

GETBF1:	;T1 points to block we are allocating out of
	;T2 is size of words+2 to allocate
	;T3 is link to next free block, if any
	;T4 is size of current block	

	CAILE	T2,-3(T4)	;at least 3 words extra?
				; Actually, this could be -2(t4)
				; but the result would be to leave
				; a 2 word block that could never be allocated,
				; and would clutter up the free list until
				; one of the adjacent blocks was freed.

	 JRST	GETBF2		;no

ifn .sat,<	PUSH	P,T5>
	MOVEI	T5,(T4)		;get size of old free block
	ADDI	T5,-1(T1)	;get last word of free block	

	MOVEI	T3,(T2)		;get size
	ADDI	T3,(T1)		;ptr to new free block
	SUBI	T4,(T2)		;find size of new free block
	HRLM	T4,(T3)		;store size of new free block
	HRLM	T4,(T5)		;update size in last word of free block
ifn .sat,<	POP	P,T5>

	HRRZ	T4,1(T1)	;find old backlink
	HRRM	T4,1(T3)	;backlink new area to previous
	HRRM	T3,(T4)		;also store forward link in previous

	HRRZ	T4,(T1)		;find old forward link
	HRRM	T4,(T3)		;deposit it in new area
	HRRM	T3,1(T4)	;update backlink in next

	MOVEI	T4,(T1)		;get size of current block
	ADDI	T4,-1(T2)	;find last location
	IORI	T2,400000
	HRLZM	T2,(T1)
	HRLZM	T2,(T4)		;store tag,size in 1st, last words.
	JRST	GETBF3

;gets here if whole free block was allocated.
;t4 = size of total free block when coming in here.

GETBF2:
ifn XSIZE,<
	CAIE	T4,(T2)		;was it an exact match?
	 JRST	GETB00		;no.  Because we allow the size returned to
				;be specified, we have to try something
				;different.  Otherwise, someone will eventually
				;complain because the object is a different
				;size than was asked for.
>
	ADDI	T4,-1(T1)	;location of last word
	HRLZI	T2,400000	;set up tag bit
	IORM	T2,(T1)		;turn tag on in first word
	IORM	T2,(T4)		;also in last
	PUSHJ	P,UNLINK
	HLLZS	(T1)		;zero free list link

GETBF3:	; T1 = adress of allocated area's header word
	HLLZS	(T1)		;clear forward pointer
	HLRZ	T3,(T1)		;actual size of area
	ANDI	T3,377777	;clear allocated bit
	ADDI	T3,-2(T1)	;last word to clear
	HLLZS	(T3)		;clear tail pointer
	MOVEI	T1,1(T1)	;return first available word
ifn .clear,<
	SETZM	(T1)		;clear allocated area
	CAIL	T1,(T3)		;was it exaactly 1 word?
	 JRST	POPJX
	MOVEI	T2,1(T1)
	HRLI	T2,(T1)
	BLT	T2,(T3)
>
	JRST	POPJX	

GETBXR:	ERROR<NEW called for Zero size!>
	MOVEI	T1,NIL		;if continued, return NIL
	JRST	POPJX
	

; subroutine to unlink block addressed by T1 from free list
; called with PUSHJ P,UNLINK

UNLINK:	PUSH	P,T4
	PUSH	P,T3
	HRRZ	T4,(T1)		;get ptr to next
	HRRZ	T3,1(T1)	;get ptr to previous
	HRRM	T3,1(T4)	;unlink from next
	HRRM	T4,(T3)		;unlink from previous
	POP	P,T3
	POP	P,T4
	POPJ	P,

ENTRY CAINIT
CAINIT::MOVEI	T1,3
	MOVEI	T1,AVAIL
	MOVEM	T1,(T1)
	MOVEM	T1,1(T1)	;init free list

	MOVEI	T1,3
	PUSHJ	P,.ALCOR##
	MOVSI	T2,400003
	MOVEM	T2,(T1)
	MOVEM	T2,2(T1)
IFN BAKWD,<
	; create an endmem and a BEGMEM block
	MOVEM	T1,ENDMEM
	MOVEI	T1,3
	PUSHJ	P,.ALCOR##
	MOVSI	T2,400003
	MOVEM	T2,(T1)
	MOVEM	T2,2(T1)
	MOVEM	T1,SYSFF
>
	MOVEM	T1,BEGMEM	;beginning of memory block
	SETZ	T1,
; enter here when heap expands
RECALC:
IFN BAKWD,<
	; allocate as much as required plus the rest of the page
	MOVE	T2,SYSFF##
	SUBM	T2,T1
	TRZ	T1,PAGSIZ	;back up to top of page
	SUB	T1,SYSFF	;ask for this much..
	MOVN	T1,T1
	CAIGE	T1,6		;but at least enough for two blocks
	ADDI	T1,PAGSIZ+1	;so add a page if we wanted too little

	PUSH	P,T1
	PUSHJ	P,.ALCOR##	;go getum
	HRLZI	T2,400003	;mark as used
	MOVEM	T2,(T1)
	MOVEM	T2,2(T1)	;at both ends
	POP	P,T2
	; mark the rest of the block and the old BEGMEM block
	IORI	T2,400000
	MOVSM	T2,3(T1)
	MOVEM	T1,BEGMEM
	ADDI	T1,-400000(T2)
	MOVSM	T2,2(T1)
	MOVE	T1,BEGMEM
	ADDI	T1,4
ifn XSIZE,<
	SETZ	T2,
>
	JRST	DISPOS
>
IFE BAKWD,<
	HRRZ	T2,SYSFF
	ADD	T1,T2		;proposed new size
	TRO	T1,PAGSIZ	;round up to next page top
	SUBI	T1,-1(T2)	;T1= size available without expansion
	CAIGE	T1,6		;must be room for 2 blocks
	ADDI	T1,PAGSIZ+1
	PUSHJ	P,.ALCOR##	;make sure enough heap

	MOVE	T2,SYSREL##
	MOVE	T3,T2
	SUBI	T2,2(T1)	;size of block to free
	IORI	T2,400000	;mark as used
	HRLZM	T2,(T1)
	HRLZM	T2,-3(T3)	;at both ends
	MOVEI	T2,400003
	HRLZM	T2,(T3)
	HRLZM	T2,-2(T3)	;make an end of memory block
	SUBI	T3,2
	MOVEM	T3,ENDMEM
	MOVEI	T1,1(T1)
ifn XSIZE,<
	SETZ	T2,
>
	JRST	DISPOS	;release the free space
>

ENTRY CASIZE
CASIZE::; verify correctness of data base
	; calculate size of free space
	SKIPN	BEGMEM
	PUSHJ	P,CAINIT
	MOVSI	T1,3
ifn .sat,<
	PUSH	P,T2
	PUSH	P,T3
	PUSH	P,T4
>
	MOVE	T3,BEGMEM
MEMLP:	HLRZ	T4,(T3)		;get area size
	MOVE	T2,T4
	TRZ	T4,400000	;clear tag
	ADDI	T4,(T3)		;beginning of next area
		; T3= begin this area, T4=begin next area
	CAMLE	T4,ENDMEM
	 PUSHJ	P,BADCOR		;oops!
	TSC	T2,-1(T4)	;prev tag should match
	TRNE	T2,-1
	 PUSHJ	P,BADCOR
	HLRE	T2,(T3)
	JUMPG	T2,FREBL
	HRLZ	T2,T2		;left half for allocated
	TLZ	T2,400000
	JRST	ACCUM
FREBL:	SKIPL	(T4)		;next better be allocated
	 PUSHJ	P,BADCMP
ACCUM:	ADD	T1,T2		;accumulate size
	MOVE	T3,T4		;step to the next area
	CAMGE	T3,ENDMEM
	 JRST	MEMLP
RETX:
ifn .sat,<
	POP	P,T4
	POP	P,T3
	POP	P,T2
>
	MOVEM	T1,1(P)		;return value
	POPJ	P,

BADCMP:	ERROR<free list not compact>
	MOVEI	T1,0		;if continued, return 0
	JRST	RETX

BADCOR:	ERROR<heap is messed up>
	MOVEI	T1,0		;if continued, return 0
	JRST	RETX
	
IMPURE
AVAIL::	BLOCK	2	;pointer to free heap, inited by cainit
BEGMEM::BLOCK	1	;begin of memory area, always marked allocated
ENDMEM::BLOCK	1	;start of memory area, always marked allocated
PURE

	PRGEND


;
;TEST PROGRAM FOR HEAP PACKAGE
;
	search	usedef
ifn .sat,<
ini cortst,<test program for the heap manager>
	.request useful
start:	move	p,[iowd 100,stack]
	setzm	allocs
	pushj	p,cainit##

tlp:
ifg .sat,<
	typ	<[ASCIZ/	/]>
>
	pushj	p,casize##
ifg .sat,<
	pushj	p,typoct
	typ	<[Asciz/
/]>
>
tlpd:	pushj	p,random
	idivi	T1,^D100
	jumpl	T1,FREEIT
ifg .sat,<
	typ	<[asciz/alloc	/]>
>
	movm	t1,t2
	addi	t1,1
ifg .sat,<
	pushj	p,typoct
>
	PUSH	P,T1
	PUSHJ	P,NEW##
	POP	P,T3		;size
	move	t2,allocs
	movem	t2,(t1)
	HRLM	T3,(T1)
	movem	T1,allocs	
ifg .sat,<
	typ	<[asciz/	/]>
	pushj	p,typoct
>
	jrst	tlp
freeit:	move	t1,allocs
	jumpe	t1,tlpd
frel:	  hrrz	t1,(T1)
	  skipn t1
	  move	t1,allocs
	  sojg	t2,frel

	hrrz	t2,(T1)
	jumpe	t2,lasfre
	hrrz	t3,(T2)
	hrrm	t3,(T1)
frep:
ifg .sat,<
	typ	<[asciz/rels	/]>
>
	hlrz	t1,-1(t2)
	trz	t1,400000
ifg .sat,<
	pushj	p,typoct
	typ	<[ASCIZ/	/]>
>
	move	t1,t2
ifg .sat,<
	pushj	p,typoct
>
REPEAT 0,<
	hlrz	t2,-1(t1)
	trz	t2,400000
	hrli	t1,-2(t2)
>
	HLRZ	T2,(T1)
	pushj	p,DISPOS##
	jrst	tlp
lasfre:	move	t2,allocs
	hrrz	t1,(T2)
	movem	t1,allocs
	jrst	frep
	entry	typoct
	entry	typdec

typdec::push	p,[^D10]
	jrst	typer
typoct::push	p,[^D8]
typer:	exch	t3,(P)		;save P3, get radix
	push	p,t1
	push	p,t2
	pushj	p,typsub
	pop	p,t2
	pop	p,t1
	pop	p,t3
	popj	p,

typsub:	lshc	t1,-^D35
	lsh	t2,-1		;vacate sign bit
	divi	t1,(t3)		;dividend in T1, remainder in T2
	hrlm	t2,(p)		;save digit
	caie	t1,0		;done?
	pushj	p,typsub	;no, recurse
	hlrz	t1,(p)		;get digit
	addi	t1,"0"		;convert to ascii
	typc	t1		;type it
	popj	p,		;return

random:	move	t1,rab
	mul	t1,rab2
	addi	t2,134
	addi	t1,1231
	movem	t2,rab2
	movem	t1,rab
	rotc	t1,17
	xor	t1,t2
	popj	p,

rab:	123457
rab2:	5421312
allocs:	block 1
stack:	block 	100
	prgend	start>

	SEARCH USEDEF
INI	.ALCOR,<trivial memory allocator>

;  trivial core allocation
;  T1	=NUMBER OF WORDS
;	T1 returned is pointer, memorty has been cleared

	AC1=T1
	AC2=T2
ife .sat,<
; get the memory from pascal, then set SYSREL and SYSFF appropriately
.ALCOR:
IFE BAKWD,<	PUSH	P,T1>
	PUSHJ	P,GETNEW##		;get it!
	PUSH	P,T1
IFE BAKWD,<
	IORI	T1,PAGSIZ
>
IFN BAKWD,<
	ANDCMI	T1,PAGSIZ
>
	MOVEM	T1,SYSREL		;current page boundary
IFE BAKWD,<
	MOVE	T1,(P)
	ADD	T1,-1(P)
>
	MOVEM	T1,SYSFF		;next location to use
	POP	P,T1
	POPJ	P,
>

ifn .sat,<
.ALCOR:
	PUSH	P,AC1
	PUSH	P,AC2
IFE BAKWD,<
	ADD	AC1,SYSFF
	MOVE	AC2,SYSREL
	CAIG	AC1,1(AC2)
>
IFN BAKWD,<
	SKIPN	AC2,SYSFF
	  JRST	[MOVEI	AC2,400000
		 MOVEM	AC2,SYSREL
		 MOVEM  AC2,SYSFF
		 JRST	.+1]
	MOVN	AC1,AC1
	ADD	AC1,SYSFF		;add to used location
	CAML	AC1,SYSREL		;going below the boundary?
>
	 JRST	RETJBF
ifl opsys,<	CORE	AC1,>
ifge opsys,<
ife bakwd,<
	CAILE	AC1,777777
>
ifn bakwd,<
	CAIGE	AC1,PAGSIZ
>
>
	 JRST	CORERR
ifge opsys,<
IFE BAKWD,<
	IORI	AC1,PAGSIZ
>
IFN BAKWD,<
	ANDCMI	AC1,PAGSIZ
>
	MOVEM	AC1,SYSREL
>
	MOVE	AC1,SYSFF
IFE BAKWD,<	ADD	AC1,-1(P)>
IFN BAKWD,<	SUB	AC1,-1(P)>
RETJBF:	HRRZ	AC2,SYSFF
IFN BAKWD,<
	SETZM	1,(AC1)
	SOSG	-1(P)		;one word?
	MOVEM	AC1,-1(P)	;save
	JRST	BLTDON
	HRLI	AC1,1(AC1)
	MOVSS	AC1
	BLT	AC1,-1(AC2)	
	MOVE	AC1,-1(P)
>
IFE BAKWD,<
	SETZM	(AC2)
	SOSG	-1(P);one word?
	JRST	BLTDON
	HRLI	AC2,1(AC2)
	MOVSS	AC2
	BLT	AC2,-1(AC1)
>
BLTDON:	; ac1 = adress to return
	POP	P,AC2
	POP	P,(P)
IFE BAKWD,<
	EXCH	AC1,SYSFF
>
IFN BAKWD,<
	MOVEM	AC1,SYSFF
>
	POPJ	P,
CORERR:	ERROR<core expansion failed>
	HALT	.
>

IFE BAKWD,<
ENTRY SYSFF,SYSREL
	SYSFF==.JBFF##
	SYSREL==.JBREL##
>
IFN BAKWD,<
	IMPURE
ENTRY SYSFF,SYSREL
SYSFF::	BLOCK	1
SYSREL::BLOCK	1
	PURE
>
	LIT
	IMPURE
	VAR
	PURE
	end;