Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

;+.FT.rm 72.TITLE FORMAC - A MACRO library for FORTRAN programs
;.C ;Description of programs in the library FORMAC
;.c ;July 8, 1981
;.c ;Norm Samuelson, 2644
;.b1.nj;All of the routines described in this document are
;available in the relocatable library FORMAC.
;(The source is in MAC:FORMAC.MAC).
;To access any or all of these subroutines, simply add
;",REL:FORMAC.REL/LIB" to your LOAD or EXECUTE command.
;.b1;All of these routines are designed to be called from
;FORTRAN programs.  Some can be called from COBOL also.
;Some are FUNCTIONS, others are SUBROUTINES
;(see comments with each one).

;.b1;The source file contains RUNOFF input to produce this
;documentation.  To get a copy type the command:
;.i8;RUNOFF TTY:=MAC:FORMAC.MAC
;.I5;or RUNOFF LPT:=MAC:FORMAC.MAC
;-

UNIVERSAL	SLAUNV - DEFINE SANDIA DEFAULTS
SUBTTL	NH SAMUELSON, 2641, 4/76

COMMENT	
This file defines common symbols used in many Sandia programs
It is accessable to anyone by simply adding the statement
	SEARCH	SLAUNV
To your MACRO source.

This has been included in FORMAC to put all the required sources
into a single file to make distribution easier.




DEFINE ND (NAME,VALUE),<IFNDEF NAME,<NAME==VALUE>>
ND FTF40,0	;DONT SUPPORT F40 ANY MORE
ND FTKA10,0	;WE GOT RID OF IT IN FEB-79
ND ftjsys,-1
ife ftjsys,<PRINTX BUILDING UNIVERSALS FOR TOPS10>
IFN ftjsys,<PRINTX BUILDING UNIVERSALS FOR TOPS20>
IFN FTKA10,<
	PRINTX %BUILDING KA10 COMPATIBLE CODE
	pagsiz==2000
>
IFE FTKA10,<PAGSIZ==1000>
IFN FTF40,<PRINTX %BUILDING F40 COMPATIBLE CODE>

;IO CHANNELS
ife ftjsys,<
DSK==1
LPT==2
MTA==3
SYS==4
MFD==5
UFD==6
PTY==7
LOG==10
LST==11
CMD==12
TTY==13
>;END ife ftjsys

;ACCUMULATORS
F=0
syn	f,t0		;t0 is a synonym for f
T1=1
T2=t1+1
T3=t2+1
T4=t3+1
t5=t4+1
P1=t5+1
P2=p1+1
P3=p2+1
P4=p3+1
ap=16
P=17
STKSIZ==20

;special ppn's
ife ftjsys,<
SYSPPN==1,,4
OPRPPN==1,,2
QUEPPN==3,,3
NIKPPN==2,,20
>;END ife ftjsys

.TTHP==4			;HP2624
.TTADM==5			;ADM3a
.TTTEK==6			;TEKTRONIX
.TTTK5==7			;TEKTRONIX 4015

subttl	MACRO DEFINITIONS
DEFINE	MAKSTK,<MOVE	P,[IOWD STKSIZ,STAK]>

DEFINE	FXCASE (AC),<
	CAIL	AC,"a"
	SUBI	AC,"a"-"A"
>

DEFINE	HELLO	(EP),<
	SIXBIT/EP/
EP:	ENTRY	EP
IFN FTF40,<
	JRST	EP+3
	CALL	EP+3
	JRST	16,@(16)
>>;END HELLO MACRO

DEFINE	SLAPLG(%ID),<	;STANDARD PROLOGUE
	SALL
	.DIRECT	SFCOND
	.DIRECT	FLBLST
IFN FTJSYS,<SEARCH	MONSYM, MACSYM>
IFE FTJSYS,<
	SEARCH	UUOSYM, MACTEN
	DEFINE	TMSG(%TEXT),<OUTSTR	[ASCIZ/%TEXT/]>
>
	IFNB	<%ID>,<
ND %ID'VER,1	;DEFAULT VERSION NUMBER
ND %ID'MVR,0	;MINOR VERSION
ND %ID'EDT,0	;EDIT NUMBER
ND %ID'WHO,1	;WHO (NON-DEC)
	VERNUM==BYTE(3)%ID'WHO(9)%ID'VER(6)%ID'MVR(18)%ID'EDT
>>;END PROLOGUE

DEFINE	MOV2	(AC,MEM),<
IFN FTKA10,<
	.DIRECTIVE KA10
	MOVE	AC,MEM
	MOVE	AC+1,1+MEM
>
IFE FTKA10,<
	.DIRECTIVE KI10,KL10
	DMOVE	AC,MEM
>>;END MOV2

DEFINE	MOV2M	(AC,MEM),<
IFN FTKA10,<
	.DIRECTIVE KA10
	MOVEM	AC,MEM
	MOVEM	AC+1,1+MEM
>
IFE FTKA10,<
	.DIRECTIVE KI10,KL10
	DMOVEM	AC,MEM
>>;END MOV2M

;the following are special cases for indirect moves on the ka10

define	imov2	(ac,mem),<
ife ftka10,<
	.DIRECTIVE KI10,KL10
	DMOVE	AC,MEM>
IFN FTKA10,<
	.DIRECTIVE KA10
	MOVEI	AC+1,MEM
	MOV2	AC,(AC+1)
>>;END IMOV2 MACRO

DEFINE	IMOV2M	(AC,MEM,AUX<15>),<
IFE FTKA10,<
	.DIRECTIVE KI10,KL10
	DMOVEM	AC,MEM>
IFN FTKA10,<
	.DIRECTIVE KA10
	MOVEI	AUX,MEM
	MOV2M	AC,(AUX)
>>;END IMOV2M MACRO

;USEFUL OPDEFs

OPDEF	CALL	[PUSHJ	P,]
OPDEF	RETURN	[POPJ	P,]

;STATES WORD - SCHED BITS
ife ftjsys,<
	ST%SPO==1B18	;SYSTEM PROGRAMMERS ONLY
	ST%MSG==1B19	;SPECIAL MESSAGE IN "SYS:MESSAG.TXT"
			;(USED BY LOGIN, REPORTED BY OTHERS)

;BITS IN RIBPCA - PRIV CUST ARG IN RIB OF EACH FILE
	RB%PRG==1B18	;THIS FILE IS TO BE PURGED
>;END ife ftjsys

;MISC DEFINITIONS
MAXINT==377777,,777777

;NBS DATE TIME UNITS
	NBSDAY==1B17
	NBSHR==NBSDAY/^D24
	NBSMIN==NBSHR/^D60
	NBSSEC==NBSMIN/^D60

subttl	macros for COMND JSYS calls
ifn ftjsys,<

;Key - define an entry in a keyword table.  It takes one to three arguemnts.
;The first argument is the keyword.
;The second argument is the value to be associated with the keyword.
;If omitted it defaults to a value of "." concatenated with the keyword,
;ie:  key foo####would have a value of ".FOO"
;The third argument is a combination of flag bits.
;[if more than one flag bit is specified they should be separated by
;exclamation points (!).]
;

define	key(nam,val,bits),<
  ifnb <val>,<
	ifb <bits>,<[asciz/nam/],,val>		;;normal case
	ifnb <bits>,<[cm%fw!bits		;;bits are messy but useful
			[asciz/nam/]],,val>
   >
  ifb <val>,<
		ifb <bits>,<[asciz/nam/],,.'nam> ;;normal case
	ifnb <bits>,<[cm%fw!bits		;;bits are messy but useful
			[asciz/nam/]],,.'nam>
   >
>;end key macro

;.b1;IKEY - KEY with invisible bit set

define	IKEY(nam,val,bits<0>),<
	KEY(nam,val,cm%inv!bits)
>;end IKEY macro

;.b1;TV - even easier than KEY, value is just index into keyword table.

define	TV(nam),<
	zzzz==zzzz+1				;;increment value
	key(nam,zzzz)
>;end TV macro

;.b1;ITV - same as TV but invisible.

define	ITV(nam),<
	zzzz==zzzz+1
	ikey(nam,zzzz)
>;end ITV macro
>;end ifn ftjsys
	PRGEND

Title	SHIFT - single word shift and rotate routines
subttl	NH Samuelson, 2641, 8/2/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.HL1 SHIFT routines
;.nj;The following group of FUNCTIONS are special case routines
;to produce results equivalent to the strange SHIFT FUNCTION found
;on CDC 6600 and 7600 computers.

;.b1.nf;Calling sequence:
;	SHIFT(W,N)	   left=circular	right=sign extended
;  or	ASH(W,N)	   left=zero fill	right=sign extended
;  or	LSH(W,N)	   left=zero fill	right=zero fill
;  or	ROT(W,N)	   left=curcular	right=circular
; where	W is a SINGLE WORD quantity to be shifted
;  and	N is the SHIFT COUNT (+=LEFT, -=RIGHT)
;.b1.f.nj;The FUNCTION to be used should be declared LOGICAL in the
;-calling program.

WORD==0
COUNT==1

HELLO	SHIFT
	SKIPL	T1,@COUNT(AP)	;IS COUNT NEGATIVE?
	 JRST	ROT..		;NO - POSITIVE = ROTATE LEFT
	JRST	ASH..		;YES - RIGHT WITH SIGN EXTENSION

HELLO	ASH
	MOVE	T1,@COUNT(AP)
ASH..:	MOVE	T0,@WORD(AP)
	ASH	T0,(T1)
	RETURN

HELLO	ROT
	MOVE	T1,@COUNT(AP)
ROT..:	MOVE	T0,@WORD(AP)
	ROT	T0,(T1)
	RETURN

HELLO	LSH
	MOVE	T1,@COUNT(AP)
	MOVE	T0,@WORD(AP)
	LSH	T0,(T1)
	RETURN

	PRGEND

Title	DSHIFT - DOUBLE PRECISION shift and rotate routines
subttl	NH Samuelson, 2641, 8/2/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.HL1 DSHIFT routines
;.F.nj;The following group of DOUBLE PRECISION FUNCTIONS are
;special case routines to produce results equivalent to the strange
;SHIFT FUNCTION found on CDC 6600 and 7600 computers.

;.b1.nf;Calling sequence:
;	DSHIFT(DD,N)  left=circular	right=sign extended
;	DASH(DD,N)    left=zero fill	right=sign extended
;	DLSH(DD,N)    left=zero fill	right=zero fill
;	DROT(DD,N)    left=curcular	right=circular
; where	DD is a DOUBLE WORD quantity to be shifted
; and	N is the SHIFT COUNT (+=LEFT, -=RIGHT)
;.b1.f.nj;The FUNCTION to be used should be delcared DOUBLE PRECISION
;-in the calling program.

WORDS==0
COUNT==1

HELLO	DSHIFT
	PUSH	P,T2
	SKIPL	T2,@COUNT(AP)
	 JRST	DROT..		;NO - POSITIVE = ROTATE LEFT
	JRST	DASH..		;YES - RIGHT WITH SIGN EXTENSION

HELLO	DASH
	PUSH	P,T2
	MOVE	T2,@COUNT(AP)
DASH..:	IMOV2	T0,@WORDS(AP)
	ASHC	T0,(T2)
	JRST	T2POPJ

HELLO	DROT
	PUSH	P,T2
	MOVE	T2,@COUNT(AP)
DROT..:	IMOV2	T0,@WORDS(AP)
	ROTC	T0,(T2)
	JRST	T2POPJ

HELLO	DLSH
	PUSH	P,T2
	MOVE	T2,@COUNT(AP)
	IMOV2	T0,@WORDS(AP)
	LSHC	T0,(T2)
T2POPJ:	POP	P,T2
	RETURN

	PRGEND

Title	MASK - generate an N-bit mask (single or double precision)
Subttl	NH Samuelson, 2641, 10/79

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.HL1 MASK function
;.f.nj;The MASK function generates a mask of up to 72 bits, similar to
;the MASK function on CDC computers.

;.b1.nf;Calling sequence:
;	BITS = MASK(NBITS)
; where	NBITS is integer number of bits in the mask
;  and	BITS and MASK are of the same type (both LOGICAL, both REAL,
;	or both DOUBLE PRECISION)
;.F.NJ;Note: If NBITS is negative the mask generated is the complement
;-of that generated by MASK(ABS(NBITS))

NBITS==0

	HELLO	MASK
	CLEARB	T0,T1
	PUSH	P,T2
	PUSH	P,T3
	SKIPN	T2,@NBITS(AP)
	 JRST	MASKOK			;IF NBITS IS ZERO
	MOVM	T2,T2
	IDIVI	T2,^D36
	SOJG	T2,ALLSET		;IS COUNT .GE. 72?
	JUMPE	T3,NOSHFT		;EVEN # WORDS?
	MOVX	T0,<1B0>		;SET THE FIRST BIT
	MOVNI	T3,(T3)			;NEGATE SHIFT COUNT FOR RIGHT SHIFT
	ASH	T0,1(T3)		;BUILD THE PARTIAL WORD
NOSHFT:	JUMPL	T2,ONEWRD		;SINGLE WORD?
	CAIA
ALLSET:	SETO	T0,
	MOVE	T1,T0
	SETO	T0,			;AND SET ALL BITS IN THE FIRST
ONEWRD:	SKIPL	@NBITS(AP)		;WAS SHIFT COUNT NEGATIVE?
	 JRST	MASKOK			;NO - DONT COMPLEMENT
	SETCM	T0,T0
	SETCM	T1,T1
MASKOK:	POP	P,T3			;RESTORE WORK ACs
	POP	P,T2
	RETURN

	PRGEND

title	CSHIFT - character circular shift SUBROUTINE or FUNCTION
subttl	nh samuelson, 2641, 4/14/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 CSHIFT
;.NJ;CSHIFT is either a SUBROUTINE, or a FUNCTION.
;It does character shifting in DOUBLE PRECISION (ie: A10 FORMAT)
;such that the characters come out in normal character positions, in
;spite of the extra bit in each word.
;.B1.nf;Calling sequence:
;	CALL CSHIFT(DPVAR,NUMCH,DPRES)
;or	DPRES = CSHIFT(DPVAR,NUMCH)
; where	DPVAR is a DOUBLE PRECISION variable in A10 format
;	DPRES is the DOUBLE PRECISION result (in A10 format)
;	NUMCH is the number of character positions to shift
;		if NUMCH is positive, the characters are shifted
;		#LEFT, END AROUND (ie: rotated).
;		If NUMCH is negative, the characters are shifted
;		#RIGHT, END OFF with blank fill
; on return the contents of DPVAR and NUMCH are un-changed.
;.F.NJ.b1;NOTE - If called as a FUNCTION, CSHIFT must be declared 
;-DOUBLE PRECISION in the calling program.

;register assignments:
;	t0&t1 = output string
;	t2 = temp
;	t3 = count
;	t4 = current pointer to input
;	p1 = initial pointer to input
;	p2 = negative shift count
;	p3 = byte pointer to string in t0+t1

DPVAR==0
NUMCH==1
DPRES==2

HELLO	CSHIFT
	move	t1,[t2,,savrgs]
	blt	t1,savrgs+p3-t2
	move	p3,[point 7,t0]	;starting byte pointer
	movei	p1,@DPVAR(AP)	;get address of chars
	hrli	p1,(point 7,)	;make a byte pointer
	move	t4,p1		;get copy of byte pointer
	skipge	t2,@NUMCH(AP)	;get number of characters to shift
	 jrst	right		;negative count = shift right
	idivi	t2,^d10		;get remainder ie: n mod 10.
	jumpe	t3,noshft	;zero count?
left:
	movn	p2,t3		;save negative shift count
	clearb	t0,t1		;new words built here
ifn ftka10,<
	ibp	t4		;skip over first n characters
	sojg	t3,.-1
>;end ifn ftka10
ife ftka10,<
	adjbp	t3,t4		;skip over first n characters
	move	t4,t3
>;end ife ftka10
	movei	t3,^d10(p2)	;get # chars remaining
	call	copy
	move	t4,p1		;get byte pointer for first chars
	movm	t3,p2		;and count
	call	copy
	jrst	store

right:
	move	t0,[ascii/     /]	;blanks
	move	t1,t0		;in both words
	movm	t3,t2		;get (+) shift count
	cail	t3,^d10		;loose everything?
	 jrst	store		;yes - all blanks
	move	p2,t2		;save neg shift count
ifn ftka10,<
	ibp	p3		;skip the blanks
	sojg	t3,.-1		;loop till enuf
>;end ifn ftka10
ife ftka10,<
	adjbp	t3,p3		;skip the blanks
	move	p3,t3
>;end ife ftka10
	movei	t3,^d10(p2)	;# chars remaining
	call	copy
	jrst	store

copy:
	ildb	t2,t4		;get a byte
	idpb	t2,p3		;store it
	sojg	t3,copy		;loop till done
	return

noshft:
	mov2	t0,(p1)		;copy the input
store:
	hlrz	t2,-1(AP)	;arg count
	caie	t2,-3		;3 args?
	 jrst	gobak		;we were called as a FUNCTION
	movei	t2,@DPRES(AP)	;result address
	MOV2M	T0,(T2)		;STORE THE RESULT
gobak:
	move	p3,[savrgs,,t2]
	blt	p3,p3
	return

savrgs:	block	p3-t2+1

	PRGEND

TITLE	ECHO - TURN ECHO ON OR OFF
SUBTTL	NHS, 2641, 7/26/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 Terminal control routines
;.f.nj;These FORTRAN SUBROUTINES take no arguments.
;A call to ECHO will turn on echo, a call to NOECHO will turn it off.
;A call to CTRLO will restart typeout in case the user stopped it
;-with _^O.  (This is a good idea before typeing error messages).

HELLO	ECHO
ife ftjsys,<
	SETO	T1,
	GETLCH	T1		;GET CHARACTERISTICS OF MY TTY
	TXZ	T1,GL.LCP	;TURN ON ECHO
	SETLCH	T1
>;end ife ftjsys
ifn ftjsys,<
	movei	t1,.priin
	rfmod
	txo	t2,tt%eco	;set the echo bit
	sfmod
>;end ifn ftjsys
	RETURN

HELLO	NOECHO
ife ftjsys,<
	SETO	T1,
	GETLCH	T1
	TXO	T1,GL.LCP
	SETLCH	T1
>;end ife ftjsys
ifn ftjsys,<
	movei	t1,.priin
	rfmod
	txz	t2,tt%eco	;clear the echo bit
	sfmod
>;end ifn ftjsys
	RETURN

HELLO	CTRLO
ife ftjsys,<
	SKPINL			;CHECK FOR TTY INPUT, WAKE THE TTY
	 RETURN
>;end ife ftjsys
ifn ftjsys,<
	movei	t1,.priou
	rfmod
	txz	t2,tt%osp	;clear the suppress output bit
	sfmod
>;end ifn ftjsys
	RETURN

	PRGEND

TITLE	IBYTE - TO GET AN ARBITRARY BYTE FROM ANY WORD
SUBTTL	NH SAMUELSON - 9/75

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 IBYTE
;.NJ;IBYTE is a FUNCTION which returns an arbitrary sized byte
;from any word.
;.b1.nf;Calling sequence:
;	IBYTE(WORD,SIZE,LOC)
; where	WORD is the word containing the desired byte
;	SIZE is the (INTEGER) length of the byte
;  and	LOC  is the (INTEGER) location of the rightmost bit
;	  (bits are numbered from 0 on the left to 35 on the right)
;-.b1.f.nj;IBYTE should be declared LOGICAL in the calling program.

WORD==0
SIZE==1
LOC==2

HELLO	IBYTE
	MOVEI	T1,^D35		;COMPUTE "P"
	SUB	T1,@LOC(AP)	;..
	LSH	T1,6		;POSITION IT
	ADD	T1,@SIZE(AP)	;GET BYTE SIZE ("S")
	LSH	T1,^D24		;BUILD BYTE POINTER
	HRRI	t1,@WORD(AP)	;GET THE ADDRESS
	LDB	t0,t1		;GET THE BYTE INTO AC0 FOR RETURN
	RETURN

	PRGEND

title	PUTBYT - Put any byte anywhere in any word
subttl	NH Samuelson, 2644, 2/80

	search	slaunv
	slaplg

;+.tp15.hl1 PUTBYT
;.nj;PUTBYT is a SUBROUTINE which puts an arbitrary sized byte
;into any word.
;.b1.nf;Calling sequence:
;	CALL PUTBYT(WORD,SIZE,LOC,VAL)
; where	WORD is the word to be modified
;	SIZE is the (INTEGER) length of the byte
;	LOC  is the (INTEGER) location of the rightmost bit
;  and	VAL  is the value to be stored
;-	  (bits are numbered from 0 on the left to 35 on the right)

WORD==0
SIZE==1
LOC==2
VAL==3

	hello	putbyt
	MOVEI	T1,^D35		;COMPUTE "P"
	SUB	T1,@LOC(AP)	;..
	LSH	T1,6		;POSITION IT
	ADD	T1,@SIZE(AP)	;GET BYTE SIZE ("S")
	LSH	T1,^D24		;BUILD BYTE POINTER
	HRRI	t1,@WORD(AP)	;GET THE ADDRESS
	MOVE	T0,@VAL(AP)	;get the value to store
	DPB	T0,T1		;store the byte
	RETURN

	PRGEND

TITLE	ICHAR - TO GET A ARBITRARY CHARACTER FROM A STRING
SUBTTL	NH SAMUELSON, 2641, 8/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 ICHAR
;.F.NJ;ICHAR is a FUNCTION which returns the Nth character of
;an ASCII character string.
;.b1.nf;Calling sequence:
;	ICHAR(STRING,NPOS)
; where	STRING is a variable (or array) containing an ASCII string
;  and	NPOS is the position of the character desired
;	(starting with position 1 at the left)
;.b1.f.nj;ICHAR should be decalred INTEGER or LOGICAL in 
;-the calling program.

STRING==0
NPOS==1
CHAR==2

HELLO	ICHAR
	CALL	BLDPTR			;BUILD BYTE POINTER
	LDB	T0,T0			;GET THE CHARACTER
	RETURN

;+.TP15.HL1 PUTCHR
;.F.NJ;PUTCHR is a SUBROUTINE which replaces a character in
;an ASCII string.
;.b1.nf;Calling sequence:
;	CALL PUTCHR(STRING,NPOS,CHAR)
; where STRING is a variable (or array) containing an ASCII STRING
;	NPOS is the position of the character to be replaced
;	  (starting with position 1 at the left)
;  and	CHAR is the character to insert into the string right justified
;	  (as is the character returned by ICHAR)
;note: to take a character from one string and put it into another
;you can call PUTCHR and ICHAR as follows:
;-	CALL PUTCHR(STR1,NPOS1,ICHAR(STR2,NPOS2))

HELLO	PUTCHR
	CALL	BLDPTR			;BUILD BYTE POINTER
	MOVE	T1,@CHAR(AP)		;GET THE CHARACTER
	DPB	T1,T0			;STORE IT
	RETURN

BLDPTR:	MOVE	T0,@NPOS(AP)		;GET POSITION
	SOJL	T0,BADCNT		;BAD COUNT
	IDIVI	T0,5			;CONVERT TO WORDS
	ADDI	T0,@STRING(AP)		;GET ADDRESS OF DESIRED WORD
	HLL	T0,[POINT 7,0,6
		    POINT 7,0,13
		    POINT 7,0,20
		    POINT 7,0,27
		    POINT 7,0,34](T1)	;MAKE BYTE POINTER
	RETURN

BADCNT:	tmsg	<
?Character position not positive in call to PUTCHR or ICHAR
>
ife ftjsys,<MONRT.>
ifn ftjsys,<haltf>
	clear	t0,			;IN CASE OF CONTINUE
	jrst	bldptr+2

	PRGEND

title	MEMORY - dynamic memory allocation for FORTRAN
subttl	N Samuelson, 2641, 4/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 DYNAMIC MEMORY MANAGEMENT
;.NJ;Two routines are provided to interface with the memory allocation
;routines in FOROTS (the fortran run-time library).  One to allocate
;core (MORCOR) and the other to return it (RELCOR).
;.hl2 MORCOR
;MORCOR is a FORTRAN FUNCTION which requests core from FOROTS
;and returns the OFFSET to be used to make future references to
;the allocated memory.
;.B1.nf;Calling sequence:
;	OFFSET = MORCOR(ARAY,LENGTH)
;.B1.F.NJ;MORCOR should be declared LOGICAL or INTEGER in the calling
;program.  The newly allocated memory will be zeroed by FOROTS.
;.b1;To access the allocated memory use the following:
;-.I6;ARAY(OFFSET+I)

ARAY==0
LENGTH==1
OFFSET==1

HELLO	MORCOR
	skipg	@LENGTH(AP)	;is request .gt. 0?
	 jrst	badreq		;bad request
	movei	t1,@ARAY(AP)	;get address of array
	movem	t1,reladr	;save address
	move	t1,1(AP)	;get length pointer from arg list
	movei	AP,getarg	;setup new pointer
	movem	t1,0(AP)	;store the length pointer
	CALL	alcor.##	;get some core
	jumpl	t0,nocore	;cant get it?
	sub	t0,reladr	;compute offset
	return

badreq:	tmsg	<
?less than one word of core requested in MORCOR>
	jrst	.exit
nocore:	tmsg	<
?CORE request failed in MORCOR>
.exit:
ife ftjsys,<monrt.>		;die
ifn ftjsys,<haltf>
	clear	t0,		;in case of continue
	return

;+.HL2 RELCOR
;RELCOR is a FORTRAN SUBROUTINE to release core allocated by MORCOR.
;.b1.nf;Calling sequence:
;	CALL RELCOR(ARAY,OFFSET)
;where OFFSET is the value returned by MORCOR
;NOTE: RELCOR returns the memory to FOROTS, but FOROTS does not,
;at present, release the core to the system.
;-It does, however, re-use it if possible on future calls to MORCOR.

HELLO	RELCOR
	movei	t1,@ARAY(AP)	;get array address
	add	t1,@OFFSET(AP)	;ADDRESS OF CORE TO GIVE BACK
	movem	t1,reladr	;save the address
	movei	AP,relarg	;new arg pointer
	jrst	decor.##	;give core back to FOROTS

	-1,,0			;arg list for alcor.
getarg:	block	1

	-1,,0			;arg list for decor.
relarg:	2b12!reladr
reladr:	block	1		;address of block to be returned

	PRGEND

TITLE	ZERO - zero a block of memory quickly
SUBTTL	NH SAMUELSON, 2641, 10/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 ZERO
;.F.NJ;ZERO is a group of FORTRAN SUBROUTINEs which clear memory.
;The entry point names were chosen for an existing application (SPICE2)
;They are related to IBM terminology (ie: REAL*4, REAL*8, etc).
;.B1.nf;Calling sequence:
;	CALL ZERO4(A,N)
;  or	CALL ZERO8(A,N)
;  or	CALL ZERO16(A,N)
; where	A is the start of the block to zero
; and	N is the number of elements to zero.
;	(ie: elements are words(ZERO4), double-words(ZERO8),
;	  or quad-words(ZERO16))
;.b1.f.nj;The memory is cleared with Block Transfer instruction,
;-which is very efficient.

A==0
N==1

HELLO	ZERO16
	MOVEI	T1,2			;QUADRUPLE WORDS
	JRST	ZERO

HELLO	ZERO8
	MOVEI	T1,1			;DOUBLE WORDS
	JRST	ZERO

HELLO	ZERO4
	CLEAR	T1,			;NO SHIFT
ZERO:	SKIPG	T2,@N(AP)		;GET # WORDS TO CLEAR
	 RETURN
	LSH	T2,(T1)			;ADJUST FOR ELEMENT SIZE
	MOVEI	T1,@A(AP)		;GET START ADDRESS
	SETZM	(T1)			;ZERO THE FIRST WORD
	SOJLE	T2,RTN			;# WORDS LEFT TO CLEAR
	ADDI	T2,(T1)			; LAST ADDRESS TO CLEAR
	HRLI	T1,(T1)			; FWA,,FWA
	AOS	T1			; FWA,,FWA+1
	BLT	T1,(T2) 		;CLEAR THE REST
RTN:	RETURN

	PRGEND

TITLE	COPY - COPY A BLOCK OF MEMORY
SUBTTL	NH SAMUELSON, 2641, 10/78

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 COPY
;.F.NJ;COPY is a group of FORTRAN SUBROUTINEs which copy blocks of memory.
;The entry point names were chosen for an existing application (SPICE2).
;They are related to IBM terminology (ie: REAL*4, REAL*8, etc).
;.b1.nf;Calling sequence:
;	CALL COPY4(A,B,N)
;  or	CALL COPY8(A,B,N)
;  or	CALL COPY16(A,B,N)
; where	A is the start of the FROM block
;	B is the start of the TO block
; and	N is the number of elements to copy.
;	(ie: elements are words(ZERO4), double-words(ZERO8),
;	  or quad-words(ZERO16))
;.f.nj.b1;The Block Transfer instruction is used for fast block
;copying when possible.  That is not possible if the block is
;being moved up in memory and the blocks overlap, in that case
;it is necessary to use a loop to transfer one word at a time.
;-The loop used is as fast as possible under the circumstances.

A==0
B==1
N==2

HELLO	COPY16
	MOVEI	T2,2
	JRST	COPY

HELLO	COPY8
	MOVEI	T2,1
	JRST	COPY

HELLO	COPY4
	CLEAR	T2,
COPY:	SKIPG	T3,@N(AP)
	 RETURN				;dont copy anything
	LSH	T3,(T2)			;ADJUST FOR ELEMENT LENGTH
	SOJLE	T3,CPY1WD		;WORD COUNT MINUS ONE
	MOVEI	T1,@A(AP)		;FROM ADDRESS
	MOVEI	T2,@B(AP)		;TO ADDRESS
	CAILE	T1,(T2) 		;MOVING DOWN?
	 JRST	MOVEOK			;YES - ALWAYS SAFE
	MOVEI	T0,(T2)
	SUBI	T0,(T1)
	CAIG	T0,(T3)			;OR UP FAR ENOUGH
	 JRST	MOVEUP			;NO - TOO BAD
MOVEOK:	HRLI	T2,(T1)			;PREPARE FOR BLT
	ADDI	T3,(T2)			;END ADDRESS
	BLT	T2,(T3)
RTN:	RETURN

CPY1WD:	MOVE	T1,@A(AP)		;GET THE ONE WORD
	MOVEM	T1,@B(AP)		;STORE IT
	RETURN

;THE FOLLOWING IS SOME OF THE MOST OBSCURE CODE I EVER HOPE TO WRITE
;IT IS TAKEN FROM THE HARDWARE REFERENCE MANUAL, IN A MARGINAL NOTE
;RELATED TO THE POP INSTRUCTION.

;A TWO INSTRUCTION LOOP, FOLLOWED BY A RETURN, IS LOADED INTO AC'S
;P1 THRU P3, THEN WE JUMP INTO THE AC'S TO PERFORM THIS MAGIC.

MOVEUP:	MOVSI	P1,(POP T1,0(T1))	;BUILD A POP INSTR. IN P1
	ADD	P1,T0			;IE:  POP T1,B-A(T1)
	HRLI	T1,400000(T3)		;SETUP T1 AS THE STACK POINTER
	ADDI	T1,(T3)			;IE: 400000+N-1,,B+N-1
	MOVE	P2,[JUMPL T1,P1]	;PUT JUMPL INSTR. IN P2
	MOVE	P3,RTN			;AND RETURN INSTR. IN P3
	JRST	P1			;GOOD LUCK!

	PRGEND

TITLE	TTSYNC	GET IN SYNC WITH TTY OUTPUT
SUBTTL	NH SAMUELSON, 2641, 5/16/79

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE
ITIM==0		;ONLY ARG - SLEEP TIME AFTER OUTPUT DONE
;+.TP15.HL1 TTSYNC
;TTSYNC is a FORTRAN SUBROUTINE which allows a program to get back
;into sync with terminal output.  It waits for the output buffer to
;become empty, then turns off the effect of any control-O which might
;have been typed by the user.
;It can also wait a specified period after output has stopped,
;to allow the terminal to settle down (eg: for TEKTRONIX graphics
;terminals to clear the screen).
;.b1;Calling sequence:
;.i8;CALL TTSYNC(ITIME)
;-.i2;where ITIME is the number of milliseconds to wait after output stops.

SLPTIM==^D100	;100 MILLISECONDS PER HIBER WAITING FOR OUTPUT DONE

	HELLO	TTSYNC
ife ftjsys,<
	SETO	T3,
	TRMNO.	T3,			;GET OUR TTY #
	 RETURN				;NO TTY - DONT WAIT
	MOVEI	T2,.TOSOP		;FUNCTION=SKIP IF DOING OUTPUT
CHKBFR:	MOVE	T1,[2,,T2]
	TRMOP.	T1,
	 JRST	NOTBSY			;BUFFER EMPTY NOW
	MOVEI	T1,SLPTIM		;SET SLEEP TIME
	HIBER	T1,			;SLEEP
	 SLEEP	T1,			;REALLY SLEEP
	JRST	CHKBFR			;THEN TRY AGAIN

NOTBSY:	SKPINL				;CHECK FOR INPUT TO WAKE TTY
	 JFCL
	SKIPLE	T1,@ITIM(AP)		;EXTRA SLEEP TIME
	HIBER	T1,
	 JFCL
>;end ife ftjsys
ifn ftjsys,<
	movei	t1,.priou
	dobe				;dismiss until output buffer empty
	skiple	t1,@itim(ap)		;time to sleep
	disms
>;end ifn ftjsys
	RETURN

	PRGEND

TITLE	FORKS - SUBROUTINES TO CONTROL FORKS
SUBTTL	NH Samuelson, 2641, 10/79

	SEARCH	SLAUNV
	SLAPLG		;PROLOGUE
ife ftjsys,<
	printx	?You cant have forks on a DEC-10
	END
>
	.request	rel:macrel

;+.HL1 FORK HANDLING ROUTINES
;.F.NJ;FORKS is a collection of FORTRAN (or PASCAL) callable routines
;to manipulate forks.  Facilities are provided to create forks, destroy forks,
;load programs into forks, start forks, freeze forks, resume forks, and
;wait on forks.
;.b1;All fork handling routines require a 'fork handle' to distinguish
;between possible multiple forks.  When a fork is created
;a handle is returned, that same handle must be used in all future
;references to that fork

;.hl2 FRKCRE - Create a fork
;.nf.b1;Calling sequence:
;	CALL FRKCRE(BITS,HANDLE)
; where BITS is a logical mask to control the forks address space and capabilities (Normally ZERO)
;- and	HANDLE (on return) is the new fork handle (INTEGER)

	HELLO	FRKCRE
	SKIPE	T1,@0(AP)		;GET THE BITS
	TXO	T1,CR%CAP	;GIVE HIM OUR CAPABILITIES
	CFORK
	 JSERR
	MOVEM	T1,@1(AP)		;RETURN THE FORK HANDLE
	RETURN

;+.HL2 FRKKIL - Kill a fork
;.b1.nf;Calling sequence:
;-	CALL FRKKIL(HANDLE)

	HELLO	FRKKIL
	MOVE	T1,@0(AP)		;GET HANDLE
	KFORK				;KILL IT
	 ERJMP	JSERR0
	RETURN

;+.HL2 FRKHLT - Halt a fork
;.b1.nf;Calling sequence:
;-	CALL FRKHLT(HANDLE)

	HELLO	FRKHLT
	MOVE	T1,@0(AP)
	HFORK
	 ERJMP	JSERR0
	RETURN

;+.HL2 FRKWAI - Wait for a fork to exit
;.b1.nf;Calling sequence:
;-	CALL FRKWAI(HANDLE)

	HELLO	FRKWAI
	MOVE	T1,@0(AP)
	WFORK%
	 ERJMP	JSERR0
	MOVE	T1,@0(AP)
	RFSTS%
	 ERJMP	JSERR0
	LDB	T1,[POINT 17,T1,17] ;GET RF%STS
	CAIN	T1,.RFHLT	;DID IT HALT VOLUNTARILY?
	 RET			;YES
	TMSG	<?
?Error in fork termination - >
	MOVEI	T1,.PRIOU
	HRLO	T2,@0(AP)	;GET HANDLE AGAIN
	CLEAR	T3,
	ERSTR%
	 ERJMP	JSERR0
	 ERJMP	JSERR0
	RETURN

;+.HL2 FRKFRZ - Freeze (suspend) a fork
;.b1.nf;Calling sequence:
;-	CALL FRKFRZ(HANDLE)

	HELLO	FRKFRZ
	MOVE	T1,@0(AP)
	FFORK
	 ERJMP	JSERR0
	RETURN

;+.HL2 FRKRES - Resume a (suspended) fork
;.b1.nf;Calling sequence:
;-	CALL FRKRES(HANDLE)

	HELLO	FRKRES
	MOVE	T1,@0(AP)
	RFORK
	 ERJMP	JSERR0
	RETURN

;+.HL2 FRKSTA - Start a fork
;.b1.nf;Calling sequence:
;	CALL FRKSTA(HANDLE)
;Optional calling sequence:
;	CALL FRKSTA(HANDLE,OFFSET)
;-where OFFSET is the offset into the entry vector to the desired starting address.

	HELLO	FRKSTA
	MOVE	T1,@0(AP)
	hlre	t2,-1(ap)	;get arg count
	movm	t2,t2		;make it positive
	cail	t2,2		;are there 2 args?
	 skipa	t2,@1(ap)	;yes, get the second arg
	 clear	t2,		;no, normal starting address
	sfrkv
	 ERJMP	JSERR0
	RETURN

;+.HL2 FRKGET - Get (load) an .EXE file into a fork
;.b1.nf;Calling sequence:
;	CALL FRKGET(HANDLE,JFN)
;- where	JFN is a 'Job File Number' for the file to be loaded (obtained from GETJFN)
; THE FOLLOWING OPDEF IS TO AVOID CONFLICT WITH "GET" IN PASLIB
	OPDEF	GET.	[JSYS	200]

	HELLO	FRKGET
	MOVS	T1,@0(AP)
	HRR	T1,@1(AP)
	CLEAR	T2,
	GET.
	 ERJMP	JSERR0
	RETURN

;+.hl2 FRKSAC - Set fork ACs.  This should rarely be used, but
;is necessary when running programs which expect parameters to be
;set in the accumulators (ACs).  (EDIT is such a program).
;.b1.nf;Calling sequence:
;	CALL FRKSAC(HANDLE,ACBLOK)
;- where	ACBLOK is an array of 16 words (INTEGER)

	HELLO	FRKSAC
	MOVE	T1,@0(AP)	; GET FORK HANDLE
	MOVEI	T2,@1(AP)	; AND ADDRESS OF ACBLOK
	SFACS
	RET

;+.HL2 GETJFN
;The GETJFN routine returns a number (called a JFN) which is used by
;the operating system for all calls related to files.  It is included in
;the FORKS package because a JFN is required in the FRKGET routine to
;specify the file to be loaded.
;.nf.b1;Calling sequence:
;	CALL GETJFN(FILNAM,JFN)
; where	FILNAM is an array or literal containing the name of the file desired
;-  and	JFN is (on return) the JFN for the desired file

	HELLO	GETJFN
	MOVX	T1,<GJ%OLD!GJ%SHT>	;SHORT FORM, OLD FILE ONLY
	HRROI	T2,@0(AP)		;POINTER TO STRING
	GTJFN
	 ERCAL	JSERR0
	MOVEM	T1,@1(AP)	;RETURN THE JFN
	RETURN

	PRGEND

TITLE	EXIT0 - SETUP FOR QUIET EXIT FROM FORTRAN

	SEARCH	SLAUNV
	SLAPLG

;+.HL1 EXIT0 routine
;.f.nj;The routine EXIT0 can be called from FORTRAN ONLY!
;Its purpose is to signal FOROTS that, on exit, the CPU time and ELAPSED
;time message are NOT to be typed out.  It does NOT exit, it merely sets
;that flag.

;.b1.nf;Calling sequence: fortran:
;-	CALL EXIT0

	HELLO	EXIT0
	MOVEI	T0,12		;ARGUMENT TO FOROP.
	CALLRET	FOROP.##	;IN FOROTS

	PRGEND

TITLE	DOJSYS - PASCAL, FORTRAN, AND COBOL CALLABLE JSYS DOER
SUBTTL	NH SAMUELSON, 2641, 10/3/79

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE
	.request rel:macrel


;+.HL1 DOJSYS routine
;.f.nj;The routine DOJSYS can be called from either FORTRAN or COBOL
;to perform any JSYS monitor call in TOPS-20.

;.b1.nf;Calling sequence: fortran:
;	CALL DOJSYS(NUMBER,ARG1,ARG2,...,ARGN [,$LABEL])
;PASCAL:
;Define DOJSYS as:
;	PROCEDURE DOJSYS(JSYS_NUM: INTEGER; VAR AC1,AC2,AC3,AC4: INTEGER); FORTRAN;
;Call it with:
;	DOJSYS(NUMBER, ARG1, ARG2, ARG3, ARG4)
;COBOL:
;	ENTER MACRO DOJSYS USING NUMBER, ARG1, ARG2,...,ARGN [,PROC-NAME].
; where	NUMBER is the JSYS number to be performed
;	ARG1 thru ARGN are the arguments for the JSYS
;	$LABEL or PROC-NAME is the return address in case of error
;-.f.nj;Note: In PASCAL the error-return address cannot be used.

	hello	DOJSYS
	hll	ap,-1(ap)	;form aobjn word for rest of arglist
	move	15,@0(ap)	;get JSYS number
	hrli	15,(JSYS)	;make a JSYS
	movei	14,0		;point at first AC
	aobjp	ap,doj2		;step to next arg
doj1:	move	13,@0(ap)	;get next arg
	aoj	14,		;point to next AC
	movem	13,(14)		;store in the AC
	aobjn	ap,doj1		;do all the args
doj2:	ldb	13,[point 4,-1(ap),12]	;get type of last arg
	cain	13,7		;label?
	skipa	13,(14)		;yes - save it
	 movei	13,0		;no - clear it
	xct	15		;do the jsys
	 erjmp	doj4		;error return 1
	 erjmp	doj4		;error return 2
doj3:	move	13,(14)		;get an arg back
	movem	13,@-1(ap)	;store for user
	sub	ap,[1,,1]	;point to previous
	sojg	14,doj3		;store all args away
	RETURN

doj4:	jumpe	13,doj5		;did user give error label?
	movem	13,-1(p)	;yes - fixup stack
	jrst	doj3		;and continue

doj5:	jshlt		;type error message and die

	prgend

Title	FLT11 - convert pdp10 real to pdp11 real
subttl	NH Samuelson, 2641, 1/80

	search	slaunv

;+.tp15.hl1 DATA conversion routines
;.f.nj;This is a collection of SUBROUTINEs to convert PDP-10 floating
;point numbers to PDP-11 floating point and vice-versa.
;.hl2 F3632 - convert 36bit floating poing to 32-bit
;.nf.b1;Calling sequence:
;	CALL F3632(FIN,FOUT,NUM)
; where	FIN is the input array of PDP-10 36bit real numbers
;	FOUT is the output array of PDP-11 32 bit numbers
;-  and	NUM is the length of each array

FIN==0
FOUT==1
NUM==2

byte1:	point	8,t1,16
byte2:	point	8,t1,7
byte3:	point	8,t1,32
byte4:	point	8,t1,24
expofs==0	;difference in exponents between -10 and -11

	hello	f3632
	movei	p1,@fin(ap)	;address of input array
	movei	p2,@fout(ap)	;address of output array
	hrli	p2,(point 8,0)	;make a byte pointer
	skipa	p3,@num(ap)	;number of elements
go.1:	 aos	p1		;advance input pointer
	skipl	t1,(p1)		;get next number
	 jrst	pos.1		;jump if positive
	movn	t1,t1		;convert to sign/magnitude
	tlo	t1,(t1)		; ...
pos.1:
	 fsc	t1,expofs	;normalize and correct exp.
	ldb	t2,byte1	;get the first byte
	tlnn	t1,(1b8)	;even exponent?
	 trz	t2,200		;yes - clear the low bit of the exp.
	idpb	t2,p2		;store it
	ldb	t2,byte2
	idpb	t2,p2
	ldb	t2,byte3
	idpb	t2,p2
	ldb	t2,byte4	;get the last byte
	idpb	t2,p2
	sojg	p3,go.1		;loop till done
	return

;+.hl2 F3236 - convert 32bit to 36bit
;.nf.b1;Calling sequence:
;	CALL F3236(FIN,FOUT,NUM)
; where	FIN is the input array of PDP-11 32bit real numbers
;	FOUT is the output array of PDP-10 36 bit numbers
;-  and	NUM is the length of each array

	hello	f3236
	movei	p1,@fin(ap)	;address of input array
	hrli	p1,(point 8,0)	;make a byte pointer
	movei	p2,@fout(ap)	;address of output array
	skipa	p3,@num(ap)	;number of elements
go.2:	 aos	p2		;advance output pointer
	clear	t1,
	ildb	t2,p1		;get first byte
	troe	t2,200		;check for odd exponent
	 tlo	t1,(1b8)	; ...
	dpb	t2,byte1
	ildb	t2,p1		;get next byte
	dpb	t2,byte2
	ildb	t2,p1
	dpb	t2,byte3
	ildb	t2,p1		;get the last byte
	dpb	t2,byte4
	tlze	t1,(1b0)	;convert sign/mag to twos comp.
	 movn	t1,t1
	fsc	t1,-expofs	;correct the exponent
	movem	t1,(p2)		;store the result
	sojg	p3,go.2
	return

	prgend

title	RUNTIM - return PROCESS runtime.
subttl	NH Samuelson, 2644, 2/4/80

search	slaunv
	slaplg

;+.tp15.hl1 RUNTIME - return PROCESS runtime
;.f.nj;The SUBROUTINE RUNTIME returns the runtime used by this process
;(not by the JOB) in milliseconds.
;.nf.b1;Calling sequence:
;	CALL RUNTIM(ITIME)
;- where	ITIME is an INTEGER

ITIM==0

	hello	runtim
	movei	t1,.fhslf
	runtm
	movem	t1,@itim(ap)
	return

	prgend

Title	LOCF - return the address of an argument
Subttl	NH Samuelson, 2644, 2/80

	SEARCH	SLAUNV
	SLAPLG

;+.TP15.HL1 LOCF
;.F.NJ;LOCF is a FUNCTION which returns the address of the argument
;.b1.nf;Calling sequence:
;	LOCF(ARG)
;- where	ARG is ANY argument of ANY type, including a literal

ARG==0

	HELLO	LOCF
	XMOVEI	T0,@ARG(AP)	;GET THE ADDRESS
	RETURN			;RETURN IT TO THE USER

	prgend

TITLE NXTJOB FORTRAN CALLABLE ROUTINE TO START ANOTHER JOB
SUBTTL	NH Samuelson, 2644, 2/13/80

	SEARCH	SLAUNV
	SLAPLG	;STANDARD PROLOGUE

;+.TP15.HL1 NXTJOB
;.f.nj;NXTJOB is a FORTRAN SUBROUTINE which will never return.
;It is equivalent to giving a RUN command at monitor level.
;It will cause the monitor to replace the current program with
;a program which is in an executable core image file (.EXE).
;.b1.nf;Calling sequence:
;	CALL NXTJOB(JFN)
; where	JFN is a TOPS-20 JFN for the file (see GETJFN routine)
;Alternate calling sequence (macro)
;	MOVE	T1,JFN
;	JRST	NXTJB1
;.NOTE WARNING
;Any files which are open for output should be closed before NXTJOB
;is called, or they will never be closed.
;-.end note

JFN==0
	entry	nxtjb1

	HELLO	NXTJOB
	MOVE	T1,@JFN(AP)	; GET THE JFN
NXTJB1:	HRRM	T1,ACCODE
	MOVSI	17,ACCODE
	BLT	17,ACEND
	JRST	ACGO

ACCODE:
	PHASE	0		; BUILD CODE FOR THE AC'S
	.FHSLF,,0		; JFN WILL GO IN RIGHT HALF
	-1
	.FHSLF,,0
	1B0!1000
ACGO:	PMAP			; DELETE ALL CORE
	MOVE	1,0		; GET .FHSLF,,JFN
	CLEAR	2,
	GET			; GET THE .EXE FILE
	RESET			; reset I/O
	MOVEI	1,.FHSLF
ACEND:	SFRKV
	prgend

title	DDT - enter DDT - load DDT if necessary...
subttl	NH Samuelson, 2644, 7/8/81

	search	slaunv
	slaplg

;+.hl1 DDT
;Load DDT if it is not already loaded, then transfer control to it.
;-This routine takes no arguments and is callable from any language.

;Note - this was stolen from LIBMAC, which stole it from FOROTS...

	hello	ddt
	MOVE	1,[.FHSLF,,770]	;[114] LOOK AT PAGE 770
	RPACS%			;[114] GET PAGE ACCESS BITS
	TXNN	2,PA%PEX	;[114] DOES PAGE 770 EXIST?
	  JRST	MAPDDT		;[114] NO, GO MAP IN UDDT.EXE
	MOVE	1,770000	;[114] GET DDT ENTRY VECTOR
	CAMN	1,[JRST 770002]	;[114] IS IT REALLY DDT?
	  JRST	GODDT		;[114] YES, JUMP TO IT

MAPDDT:	MOVEI	1,.FHSLF	;[114] GET ENTRY VECTOR LOC
	GEVEC%
	PUSH	P,2		;[114] SAVE SINCE GET WRECKS IT
	MOVX	1,GJ%SHT+GJ%OLD	;[114] SHORT FORM, FILE MUST EXIST
	HRROI	2,[ASCIZ /SYS:UDDT.EXE/] ;[114] DDT
	GTJFN%			;[114] FIND IT
	  ERJMP ERR11		;[114] NOT THERE, CAN'T HELP
	HRLI	1,.FHSLF	;[114] MAP INTO THIS FORK
	GET			;[114] READ IN DDT
	  ERJMP	ERR11		;[114] CAN'T
	DMOVE	1,116		;[114] GET SYMBOL TABLE POINTERS
	MOVEM	1,@770001	;[114] STORE FOR DDT
	MOVEM	2,@770002
	POP	P,2		;[114] GET ENTRY VECTOR BACK
	MOVEI	1,.FHSLF	;[114] THIS FORK
	SEVEC%			;[114] RESTORE ENTRY VECTOR

GODDT:	TMSG	<Type PDDT$G to continue
>
	JRST	770000		;jump into DDT
err11:	TMSG	<
%Sorry, I cant seem to get DDT for you
>
PDDT::	RET
	prgend

title	clear - screen clear routine for all supported terminals
subttl	NH Samuelson, 2644, 8/8/80

	search	slaunv
	slaplg

;+.hl1 CLEAR
;Clear the screen of any supported terminal capable of it.
;-This routine takes no arguments and is callable from any language.

	hello	clear
	push	p,p1		;save some acs
	push	p,t3
	push	p,t2
	movx	t1,.cttrm	;jobs controlling terminal
	gttyp%			;get its terminal type
	move	p1,t2		;save it
	rfmod%			;get the mode word
	push	p,t2		;save it
	txz	t2,tt%dam	;no translation
	sfmod%			;change output mode temporarily
	movx	t2,.morxo	;get current "pause on end-of-page" setting
	mtopr%
	push	p,t3		;save it
	movx	t2,.moxof	;set no pause on end-of-page
	movx	t3,.mooff
	mtopr%
	caig	p1,max.ty	;known legal type number?
	skipn	t1,blnktb(p1)	;get the clear sequence, if any
	 jrst blank2		; none - do nothing
	tlnn	t1,-1		; string or pntr?
	 tloa	t1,-1		; pntr to text
	  hrroi	t1,blnktb(p1)	; string - point to it instead
	psout%			; dump it

	movei	t1,^d1500	;for tektronix terminals sleep 1.5 seconds
	cain	p1,6		;is this tektronix?
	 disms%			;yes

blank2:	movx	t1,.cttrm	;jobs controlling terminal
	pop	p,t3		;get original "pause on end-of-page" bit
	movx	t2,.moxof
	mtopr%
	pop	p,t2		;get original mode word
	sfmod%			;restore it
	pop	p,t2		;restore the acs
	pop	p,t3
	pop	p,p1
	ret

BLNKTB:	0			; (0) TTY 33
	0			; (1) TTY 35
	0			; (2) TTY 37
	0			; (3) TI / EXECUPORT
	BYTE (7)33,"H",33,"J",0	;4 - HP2624
	byte(7).chcnz		;5 - ADM3A.
	byte(7).chesc,.chffd	;6 - Tektronix
	byte(7).chesc,.chffd	;7 - TK4015
	0			; (8) SYSTEM DEFAULT
	0			; (9) IDEAL (NO FILL)
	[BYTE (7)35,177,177,177,177,177,177,37,0] ; (10) VT05
	BYTE (7)33,"H",33,"J",0	; (11) VT50
	0			; (12) LA30
	BYTE (7)35,37		; (13) GT40 - NO FILL REQUIRED
	0			; (14) LA36
	BYTE (7)33,"H",33,"J",0	; (15) VT52
	[BYTE (7)33,"[","H",33,"[","J",0] ; (16) VT100
	0			; (17) LA38
	0			; (18) LA120
max.ty==.-blnktb

	END