Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-02 - decus/20-0057/sddprm.vms
There are 2 other files named sddprm.vms in the archive. Click here to see a list.
	TITLE	S$$PRM FASBOL PRIMITIVE FUNCTIONS
	SUBTTL	F$$FRZ FREEZE() FORTRAN PRIMITIVE FUNCTION

	ENTRY	F$$FRZ
	EXTERN	S$$SST,S$$TMS,S$$LFC,S$$GRS,.JBSA,.JBREL,.JBFF,.JBCOR
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	JSA	^O16,F$$FRZ	; SAVE PROGRAM STATE, AND RETURN UPON
RESTART/

F$$FRZ:	BLOCK	1
	MOVEM	^O16,SAVE16	; SAVE R14,R15
	MOVEM	SS,SAVESS
	SETZ	R0,	; GET CURRENT RUNNING TIME
	RUNTIM	R0,
	SUBM	R0,S$$SST	; SAVE CURRENT - START
	SUBM	R0,S$$TMS	; SAVE CURRENT - LAST TIMER SAVE
	MOVEI	R0,.+3	; GET RESTART LOCATION
	HRRM	R0,.JBSA	; SAVE
	EXIT		; RETURN TO MONITOR
	JSR	S$$PFZ##	; START UP AGAIN - INITIALIZE PAGE FAULT HANDLER
	MOVEI	R0,^O620110	;  SET APR TRAPS
	JFCL	17,.+1	; CLEAR ALL FLAGS
	APRENB	R0,
	SETZ	R0,	; GET NEW START TIME (= CURRENT)
	RUNTIM	R0,
	SUBM	R0,S$$SST	; IMAGINARY START = CURRENT - OLD INCR
	SUBM	R0,S$$TMS	; IMAGINARY TIMER SAVE = CUR - OLD INCR
	MOVE	SS,SAVESS	; RESTORE R14,R15
	MOVE	^O16,SAVE16
	SETZ	R0,	; 0 VALUE RETURNED
	MOVE	R1,.JBREL	; GET .JBREL
	CAMN	R1,S$$LFC+1	; SAME AS MAXCOR?
	JRA	^O16,(^O16)	; YES, RETURN
	HRRZ	R0,S$$GRS	; NO, IS IT STILL QUICKMODE?
	SUBI	R0,S$$GRS+2
	JUMPE	R0,.-3	; NO, RETURN
	MOVEM	R1,S$$LFC+1	; YES, NEW MAXCOR
	SUBI	R1,P$GBUF
	MOVEM	R1,S$$LFC+2	; NEW MAXFRE
	MOVEM	R1,.JBFF	; ETC
	HRLM	R1,.JBSA
	HRLM	R1,.JBCOR
	SETZ	R0,	; RETURN 0 VALUE
	JRA	^O16,(^O16)
; STORAGE
SAVE16:	BLOCK	1
SAVESS:	BLOCK	1
	PRGEND
	SUBTTL	P$$DTE DATE() PRIMITIVE FUNCTION

	ENTRY	P$$DTE
	EXTERN	S$$GRS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT"
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 0. RETURNS AN 8-CHAR
STRING OF THE FORM MM/DD/YY,E.G. JULY 8,1972 IS REPRESENTED AS 07/08/72"

P$$DTE:	MOVEI	R0,3	; NEED 3-WORD BLOCK FOR STRING
	JSP	R6,S$$GRS
	HRLI	R1,^O700	; FORM STRING DESCR
	MOVEI	R2,8	; 8 CHARS IN STRING
	HRRM	R2,(R1)	; SAVE CHAR COUNT
	DATE	R2,	; GET DATE: ((YEAR-1964)*12+(MONTH-1))*12+DAY-1
	MOVE	R6,R1	; COPY BYTE POINTER
	IDIVI	R2,31
	MOVEI	R5,1(R3)	; SAVE DAY
	IDIVI	R2,12
	ADDI	R3,1	; GET MONTH
DTELOP:	IDIVI	R3,10	; OUTPUT 2 DIGITS + "/"
	ADDI	R3,"0"
	IDPB	R3,R6
	ADDI	R4,"0"
	IDPB	R4,R6
	MOVEI	R3,"/"
	IDPB	R3,R6
	JUMPE	R5,YEAR	; SKIP TO YEAR IF DAY IS DONE
	MOVEI	R3,(R5)	; GET DAY
	SETZ	R5,	; MARK DAY DONE
	JRST	DTELOP	; REPEAT 2 DIGITS + "/"
YEAR:	ADDI	R2,64	; GET YEAR - 1900
	IDIVI	R2,10	; OUTPUT 2 DIGITS
	ADDI	R2,"0"
	IDPB	R2,R6
	ADDI	R3,"0"
	IDPB	R3,R6
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	P$$TIM TIME() PRIMITIVE FUNCTION

	ENTRY	P$$TIM
	EXTERN	S$$SST
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 0. RETURNS INTEGER
DESCRIPTOR FOR ELAPSED TIME IN MILLISECONDS SINCE START OF EXECUTION/

P$$TIM:	SETZ	R1,	; GET RUNNING TIME FOR THIS JOB
	RUNTIM	R1,
	SUB	R1,S$$SST	; SUBTRACT START TIME OF THIS EXECUTION
	TLO	R1,1B18	; MAKE INTEGER DESCR
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	P$$DTM DAYTIM() PRIMITIVE FUNCTION

	ENTRY	P$$DTM
	EXTERN	S$$GRS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 0. RETURNS AN 11-CHAR
STRING OF THE FORM HH:MM:SS.HH, REPRESENTING HOURS, MINUTES, SECONDS,
AND HUNDREDTHS OF SECONDS SINCE MIDNIGHT/

P$$DTM:	MOVEI	R0,4	; NEED 4-WORD BLOCK FOR STRING
	JSP	R6,S$$GRS
	HRLI	R1,^O700	; FORM STRING DESCR
	MOVEI	R2,11	; 11-CHAR STRING
	HRRM	R2,(R1)	; SAVE CHAR COUNT
	SETZB	R4,R5	; CLEAR TEMP STRING
	MSTIME	R2,	; TIME OF DAY IN MSEC
	IDIVI	R2,10	; TIME OF DAY IN 1/100 OF A SEC
	IDIVI	R2,10	; GET HUNDREDTHS OF A SEC
	ADDI	R3,"0"	; FORM DIGIT
	DPB	R3,[POINT 7,3(R1),6]	; SAVE AS 11TH CHAR
	IDIVI	R2,10	; GET TENTHS OF A SEC
	LSHC	R3,-14	; SAVE
	IDIVI	R2,10	; GET SECS
	LSHC	R3,-7	; SAVE
	IDIVI	R2,6	; GET 10 SEC UNITS
	LSHC	R3,-14	; SAVE
	EXCH	R4,R5	; PREPARE FOR FIRST 5 CHARS
	IDIVI	R2,10	; GET MINUTES
	LSHC	R3,-7	; SAVE
	IDIVI	R2,6	; GET 10 MINUTE UNITS
	LSHC	R3,-14	; SAVE
	IDIVI	R2,10	; GET HOURS
	LSHC	R3,-14	; SAVE
	DPB	R2,[POINT 7,R4,6]	; SAVE 10 HOUR UNITS
	ADD	R4,[ASCII/00:00/]	; FILL IN FIRST WORD
	ADD	R5,[ASCII/:00.0/]	; AND SECOND
	MOVEM	R4,1(R1)	; SAVE CHARS 1-5
	MOVEM	R5,2(R1)	; SAVE CHARS 6-10
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	P$$EJC EJECT() PRIMITIVE FUNCTION

	ENTRY	P$$EJC
	EXTERN	S$$OUC
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 0. OUTPUTS A FORM
FEED CHARACTER VIA 'OUTPUTC' AND RETURNS NULL/

P$$EJC:	MOVE	R1,[POINT 7,[BYTE (2)2(16)2(18)1(7)^O14],35]
	MOVEM	R1,@S$$OUC	; OUTPUT FORM FEED STRING
	SETZ	R1,	; RETURN NULL
	JRST	(R12)
	PRGEND
	SUBTTL	P$$INT,P$$RAL INTEGER(X), REAL(X) PRIMITIVE FUNCTIONS

	ENTRY	P$$INT,P$$RAL
	EXTERN	S$$FLR,S$$STN
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. FAILS IF ARGUMENT
IS NOT INTEGER [REAL] OR INTEGER [REAL] STRING, OR RETURNS NULL VALUE/

P$$INT:	JSP	R8,INTRLC	; INTEGER(), INDEX=2
P$$RAL:	JSP	R8,INTRLC	; REAL(), INDEX=3
INTRLC:	SUBI	R8,P$$INT-1	; FORM INDEX
	POP	ES,R1	; GET ARG
	SETZ	R2,	; GET TYPE
	ROTC	R1,2
	JRST	.+1(R2)	; CONVERT TO VALUE
	JSP	R7,S$$STN-1	; STRING, CONVERT TO INTEGER OR REAL
	JRST	S$$FLR	; OTHER, FAILS
	CAIN	R2,(R8)	; INTEGER, SKIP IF INDEX=3
	CAIE	R2,(R8)	; REAL, OR CONVERTED STRING, SKIP INDEX=TYPE
	JRST	S$$FLR	; OR FAIL
	SETZ	R1,	; RETURN NULL
	JRST	(R12)
	PRGEND
	SUBTTL	P$$SIZ SIZE(STRING) PRIMITIVE FUNCTION

	ENTRY	P$$SIZ
	EXTERN	S$$PGL,S$$MKS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. RETURNS INTEGER
DESCRIPTOR FOR NUMBER OF CHARACTERS IN ARGUMENT, WHICH MUST BE STRING/

P$$SIZ:	POP	ES,R2	; GET ARG
	TLNE	R2,^O770000	; IS IT STRING?
	JRST	MKSTRN	; NO, GO CONVERT
	SETZ	R0,	; GET # OF CHARACTERS
	HRRZ	R1,(R2)
MKSTRR:	TLO	R1,1B18	; FORM INTEGER DESCR
	JRST	(R12)	; RETURN
MKSTRN:	MOVE	R1,R2	; GET DESCRIPTOR
	SETO	R0,	; CONVERT TO STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL	; ERROR, NOT INTEGER OR REAL
	HRRZI	R1,(R3)	; GET CHAR COUNT
	JRST	MKSTRR	; GO FORM INTEGER DESCRIPTOR
	PRGEND
	SUBTTL	P$$TRM TRIM(STRING) PRIMITIVE FUNCTION

	ENTRY	P$$TRM
	EXTERN	S$$MKS,S$$PGL,S$$GRS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. TRIMS TRAILING
BLANKS OFF THE ARGUMENT, WHICH MUST BE CONVERTIBLE TO STRING/

P$$TRM:	MOVE	R1,(ES)	; GET ARG
	TLNN	R1,^O770000	; IS IT STRING?
	JRST	TRYTRM	; YES
	SETO	R0,	; NO, TRY TO CONVERT
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL	; IMPOSSIBLE
FINTRM:	SUB	ES,[XWD 1,1]	; OK, NO TRIM NEEDED, POP ES
	JRST	(R12)	; RETURN
TRYTRM:	SETZ	R0,	; GET CHAR COUNT
	HRRZ	R7,(R1)
	JUMPE	R7,FINTRM	; RETURN IF NULL
	MOVNI	R7,(R7)	; FORM XWD -NCHAR,0
	HRLZI	R7,(R7)
SRCHLP:	ILDB	R0,R1	; SEARCH FOR BLANKS, GET NEXT CHAR
	CAIN	R0," "	; IS IT BLANK?
	JRST	FOUNDB	; YES
SRCHRT:	AOBJN	R7,SRCHLP	; NO, LOOP
	POP	ES,R1	; STRING EXHAUSED, NO TRAILING BLANKS
	JRST	(R12)	; RETURN ORIGINAL STRING
FOUNDB:	MOVEI	R8,(R7)	; SAVE CHAR COUNT UP TO THIS POINT
	AOBJN	R7,BLNKLP	; DECREMENT COUNT AND ENTER LOOP, OR
	JRST	DOTRIM	; ALL OVER, TRIM
BLNKLP:	ILDB	R0,R1	; SEARCH FOR NONBLANKS, GET NEXT CHAR
	CAIE	R0," "	; IS IT BLANK?
	JRST	SRCHRT	; NO, GO BACK TO OLD LOOP
	AOBJN	R7,BLNKLP	; YES, LOOP
DOTRIM:	MOVEI	R1,(R8)	; STRING EXHAUSTED, GET COUNT UP TO FIRST BLANK
	JUMPE	R1,FINTRM	; SKIP OUT IF NULL
	MUL	R1,[^F0.2B0]	; COMPUTE # OF WORDS NEEDED
	MOVEI	R0,2(R1)
	JSP	R6,S$$GRS	; GET BLOCK
	HRLI	R1,^O700	; FORM STRING DESCR
	HRRM	R8,(R1)	; SAVE CHAR COUNT
	POP	ES,R2	; GET OLD STRING POINTER
	HRLZI	R2,1(R2)	; POINTER TO FIRST SOURCE WORD
	ADDI	R2,1(R1)	; PTR TO FIRST DESTINATION WORD
	MOVEI	R3,-1(R1)	; PTR TO LAST DESTINATION WORD
	ADD	R3,R0
	BLT	R2,(R3)	; MOVE ALL NONBLANK WORDS
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	P$$CPY COPY(X) PRIMITIVE FUNCTION

	ENTRY	P$$CPY
	EXTERN	S$$CPS,S$$GRS,S$$PGL
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. RETURNS INTEGERS,
REALS, NAMES, AND PATTERNS IMMEDIATELY, MAKES FRESH COPIES OF STRINGS,
ARRAYS, AND PROGRAMMED DEFINED DATATYPES, AND CAUSES AN ERROR ON TABLES/

P$$CPY:	POP	ES,R1	; GET ARG
	JUMPL	R1,(R12)	; RETURN IF INTEGER OR REAL
	TLNE	R1,^O770000	; IS IT STRING?
	JRST	.+3	; NO
	JSP	R7,S$$CPS	; YES, GET COPY
	JRST	(R12)	; RETURN
	TLC	R1,^B01011B22	; TEST FOR TABLE
	TLNN	R1,^B11111B22	; IS IT TABLE?
	CFERR	10,S$$PGL	; YES, ERROR
	TLC	R1,^B01011B22	; RESTORE DESCR
	TLNN	R1,1B21	; IS IT NAME OR PATTERN?
	JRST	(R12)	; YES, RETURN
	HLRZ	R0,(R1)	; GET BLOCK SIZE
	TRZ	R0,3B19
	ADD	ES,[XWD 1,1]	; KEEP OLD DESCR SAFE ON ES
	JSP	R6,S$$GRS	; GET NEW BLOCK
	POP	ES,R2	; GET OLD DESCR
	HLL	R1,R2	; COMPLETE NEW DESCR
	HRRZ	R3,(R2)	; TRANSFER RH OF FIRST WORD FROM OLD TO NEW
	HRRM	R3,(R1)
	HRLZI	R2,1(R2)	; PTR TO SECOND WORD OF OLD BLOCK
	ADDI	R2,1(R1)	; PTR TO SECOND WORD OF NEW BLOCK
	MOVEI	R3,-1(R1)	; PTR TO LAST WORD OF NEW BLOCK
	ADD	R3,R0
	BLT	R2,(R3)	; MOVE ARRAY OR DATATYPE ELEMENTS
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	P$$PRO PROTOTYPE(ARRAY) PRIMITIVE FUNCTION

	ENTRY	P$$PRO
	EXTERN	S$$PGL
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. RETURNS PROTOTYPE
STRING OF ARGUMENT, WHICH MUST BE OF TYPE ARRAY/

P$$PRO:	POP	ES,R1	; GET ARG
	TLC	R1,^B01010B22	; IS IT ARRAY?
	TLNE	R1,^B11111B22
	CFERR	10,S$$PGL	; NO, ERROR
	MOVE	R1,(R1)	; GET FIRST WORD OF ARRAY BLOCK
	MOVE	R1,(R1)	; GET FIRST WORD OF PROTOTYPE BLOCK
	MOVE	R1,(R1)	; GET STRING DESCR FOR PROTOTYPE
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	P$$RVS REVERSE(STRING) PRIMITIVE FUNCTION

	ENTRY	P$$RVS
	EXTERN	S$$PGL,S$$MKS,S$$GRS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. RETURNS A STRING
WHICH IS THE REVERSE OF THE ARGUMENT, WHICH MUST BE CONVERTIBLE TO
STRING. E.G. 'ABCDE' => 'EDCBA'/

P$$RVS:	MOVE	R1,(ES)	; GET ARG
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	MOVEM	R1,(ES)	; SAVE STRING DESCR IF CONVERTED
	JUMPE	R3,FINRVS	; QUIT IF NULL
	MOVEI	R8,(R3)	; SAVE # OF CHARS
	SKIPA	R7,R8	; GET CHAR COUNT, SKIP
RVSLP1:	PUSH	SS,R9	; SAVE CHAR ON STACK
	ILDB	R9,R1	; GET NEXT CHAR
	SOJG	R7,RVSLP1	; LOOP
	MOVEI	R1,(R8)	; COMPUTE # OF WORDS NEEDED FOR REVERSED STRING
	MUL	R1,[^F0.2B0]
	MOVEI	R0,2(R1)
	JSP	R6,S$$GRS	; GET BLOCK
	HRLI	R1,^O700	; FORM STRING DESCR
	HRRM	R8,(R1)	; SAVE CHAR COUNT
	MOVEM	R1,(ES)	; SAVE DESCR
	JRST	.+2	; SKIP INTO LOOP
RVSLP2:	POP	SS,R9	; GET NEXT CHAR FROM STACK
	IDPB	R9,R1	; PUT CHAR IN REVERSED STRING
	SOJG	R8,RVSLP2	; LOOP
FINRVS:	POP	ES,R1	; GET NEW STRING DESCR
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	F$$NOT NOT(I) FORTRAN PRIMITIVE FUNCTION

	ENTRY	F$$NOT
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	JSA	^O16,F$$NOT	; RETURNS COMPLEMENT OF VALUE IN LOC
	ARG	CODE,LOC	; IN R0/

F$$NOT:	BLOCK	1
	SETCM	R0,@(^O16)	; COMPLEMENT OF ARG INTO R0
	JRA	^O16,1(^O16)	; RETURN
	PRGEND
	SUBTTL	P$$LGT LGT(STR1,STR2) PRIMITIVE FUNCTION

	ENTRY	P$$LGT
	EXTERN	S$$FLR,S$$MKS,S$$PGL
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. SUCCEEDS WITH NULL
VALUE IF STR1 IS LEXICALLY GREATER THAN STR2, OR FAILS. ARGS MUST BE
CONVERTIBLE TO STRINGS/

P$$LGT:	POP	ES,R1	; GET SECOND ARG
	SETO	R0,	; ASSURE IT IS STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	EXCH	R1,(ES)	; SAVE, GET FIRST ARG
	MOVEI	R8,(R3)	; SAVE CHAR COUNT OF SECOND ARG
	SETO	R0,	; ASSURE FIRST IS STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	POP	ES,R2	; GET SECOND ARG
	MOVEI	R7,(R3)	; SAVE CHAR COUNT OF FIRST ARG
	CAIGE	R8,(R3)	; WAS SECOND ARG SHORTER?
	MOVEI	R3,(R8)	; YES, USE SMALLEST CHAR COUNT
	JUMPE	R3,LGTFIN	; SKIP IF ONE IS NULL
LGTLOP:	ILDB	R0,R1	; GET CHAR FROM FIRST
	ILDB	R4,R2	; GET CHAR FROM SECOND
	SUBI	R0,(R4)
	JUMPL	R0,S$$FLR	; FAIL IF FIRST < SECOND
	JUMPG	R0,NULRET	; SUCCEED IF FIRST > SECOND
	SOJG	R3,LGTLOP	; LOOP OTHERWISE
LGTFIN:	CAIG	R7,(R8)	; OR IF FINISHED,IS FIRST LONGER?
	JRST	S$$FLR	; NO, FAIL
NULRET:	SETZ	R1,	; YES, RETURN NULL
	JRST	(R12)
	PRGEND
	SUBTTL	P$$CNV CONVERT(X,DATATYPE) PRIMITIVE FUNCTION

	ENTRY	P$$CNV
	EXTERN	P$$DTY,S$$PGL,S$$MKI,S$$MKR,S$$FLR,S$$CVS,S$$EQS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. IF POSSIBLE, CON-
VERTS FIRST ARGUMENT TO TYPE SPECIFIED BY SECOND AND RETURNS IT AS
VALUE, OTHERWISE FAILS. TYPES OTHER THAN STRINGS, INTEGERS, AND REALS
CAN ONLY BE CONVERTED TO 'STRING' OR TO THEIR OWN TYPE/

P$$CNV:	POP	ES,R1	; GET TYPE
	TLNE	R1,^O770000	; IS IT STRING?
	CFERR	10,S$$PGL	; NO, ERROR
	SETZ	R0,	; GET CHAR COUNT
	HRRZ	R2,(R1)
	CAIL	R2,4	; IS IT <4
	CAILE	R2,7	; OR >7?
	JRST	SPECTP	; YES, SPECIAL TYPE
	JRST	.-3(R2)	; NO,
	JRST	TRYREL	; MAYBE 'REAL'
	JRST	SPECTP	; SPECIAL TYPE
	JRST	TRYSTR	; MAYBE 'STRING'
	LDB	R0,[POINT 35,1(R1),34]	; MAYBE 'INTEGER'
	CAME	R0,["INTEG"]
	JRST	SPECTP	; NO
	LDB	R0,[POINT 14,2(R1),13]
	CAIE	R0,"ER"
	JRST	SPECTP	; NO
	POP	ES,R1	; YES
	JSP	R7,S$$MKI	; MAKE INTEGER
	JRST	S$$FLR	; CAN'T DO
	TLO	R1,1B18	; FORM DESCR
	TLZ	R1,1B19
	JRST	(R12)	; RETURN
TRYREL:	LDB	R0,[POINT 28,1(R1),27]	; MAYBE 'REAL'
	CAME	R0,["REAL"]
	JRST	SPECTP	; NO
	POP	ES,R1	; YES
	JSP	R7,S$$MKR	; MAKE REAL
	JRST	S$$FLR	; CAN'T DO
	LSH	R1,-2	; FORM DESCR
	TLO	R1,3B19
	JRST	(R12)	; RETURN
TRYSTR:	LDB	R0,[POINT 35,1(R1),34]	; MAYBE 'STRING'
	CAME	R0,["STRIN"]
	JRST	SPECTP	; NO
	LDB	R0,[POINT 7,2(R1),6]
	CAIE	R0,"G"
	JRST	SPECTP	; NO
	POP	ES,R1	; YES
	JSP	R7,S$$CVS	; CONVERT TO STRING
	JRST	(R12)	; RETURN
SPECTP:	ADD	ES,[XWD 1,1]	; KEEP TYPE ON STACK
	HRRM	R12,SPERET	; SAVE RETURN LINK
	PUSH	ES,-1(ES)	; COPY FIRST ARG ONTO STACK
	JSP	R12,P$$DTY	; GET DATATYPE
	POP	ES,R2	; RESTORE TYPE DESCR
	JSP	R5,S$$EQS	; COMPARE TYPES
	JRST	.+2	; EQUAL
	JRST	S$$FLR	; UNEQUAL, FAIL
	POP	ES,R1	; RETURN FIRST ARG
SPERET:	JRST	.-.
	PRGEND
	SUBTTL	P$$DTY DATATYPE(X) PRIMITIVE FUNCTION

	ENTRY	P$$DTY
	EXTERN	S$$CVS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. RETURNS STRING
REPRESENTATION OF DATATYPE OF ARGUMENT/

P$$DTY:	POP	ES,R1	; GET ARG
	SETZ	R2,	; GET TYPE
	ROTC	R1,2
	CAIN	R2,1	; IS IT SPECIAL?
	JRST	USECVS	; YES
	MOVE	R1,STRING(R2)	; NO, GET DATATYPE STRING DESCR
	JRST	(R12)	; RETURN
USECVS:	ROTC	R1,-2	; RESTORE DESCR
	JSP	R7,S$$CVS	; GET SPECIAL DATATYPE STRING DESCR
	JRST	(R12)	; RETURN
; STORAGE
STRING:	POINT	7,STRBLK,35
	0
	POINT	7,INTBLK,35
	POINT	7,RELBLK,35
STRBLK:	BYTE	(2)2(16)3(18)6
	ASCII/STRING/
INTBLK:	BYTE	(2)2(16)3(18)7
	ASCII/INTEGER/
RELBLK:	BYTE	(2)2(16)2(18)4
	ASCII/REAL/
	PRGEND
	SUBTTL	P$$DUP DUPL(STRING,N) PRIMITIVE FUNCTION

	ENTRY	P$$DUP
	EXTERN	S$$PGL,S$$MKI,S$$MKS,S$$KWD,S$$GRS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. RETURNS STRING
DUPLICATED N TIMES/

P$$DUP:	POP	ES,R1	; GET DUPLICATION COUNT
	JSP	R7,S$$MKI	; MUST BE INTEGER
	CFERR	10,S$$PGL	; OR ERROR
	JUMPL	R1,.-1	; ERROR IF NEG
	JUMPE	R1,DUPFIN	; NULL VALUE IF 0
	MOVEI	R8,(R1)	; SAVE DUP COUNT
	MOVE	R1,(ES)	; GET FIRST ARG
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	JUMPE	R3,DUPFIN	; NULL VALUE IF NULL
	CAIN	R8,1	; OR IF DUP COUNT IS 1
	JRST	DUPFIN	; DON'T BOTHER TO DUP
	MOVEM	R1,(ES)	; SAVE STRING DESCR
	MOVEI	R7,(R3)	; SAVE CHAR COUNT
	IMULI	R3,(R8)	; COMPUTE TOTAL CHARS
	CAMLE	R3,S$$KWD+12	; >&MAXLNGTH?
	CFERR	15,S$$PGL	; YES, ERROR
	MOVEI	R9,(R3)	; SAVE TOTAL COUNT
	MUL	R3,[^F0.2B0]	; COMPUTE # OF WORDS NEEDED
	MOVEI	R0,2(R3)
	JSP	R6,S$$GRS	; GET BLOCK
	HRLI	R1,^O700	; FORM STRING DESCR
	HRRM	R9,(R1)	; SAVE CHAR COUNT
	MOVE	R2,R1	; COPY RESULT STRING POINTER
	MOVE	R3,(ES)	; COPY ARG STRING POINTER
	CAIE	R7,1	; 1-CHAR ARG STRING?
	JRST	MULDUP	; NO
	ILDB	R4,R3	; YES, GET IT
SCHRLP:	IDPB	R4,R2	; PUT IN RESULT STRING
	SOJG	R8,.-1	; AND LOOP
DUPFIN:	SUB	ES,[XWD 1,1]	; POP ES
	JRST	(R12)	; RETURN
MULDUP:	MOVEI	R6,(R7)	; COPY CHAR COUNT
	MOVE	R5,R3	; COPY DESCR
MCHRLP:	ILDB	R4,R5	; GET CHAR FROM ARG
	IDPB	R4,R2	; PUT CHAR IN RESULT
	SOJG	R6,MCHRLP	; LOOP FOR EACH CHAR IN ARG
	SOJG	R8,MULDUP	; LOOP FOR # OF DUPS
	JRST	DUPFIN	; FINISHED
	PRGEND
	SUBTTL	P$$OPS OPSYN(NEWFUN,OLDFUN) PRIMITIVE FUNCTION

	ENTRY	P$$OPS
	EXTERN	S$$LKF
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. BOTH ARGS MUST
BE CONVERTIBLE TO STRINGS, AND THE NEW FUNCTION IS REDEFINED TO BE THE
SAME AS THE OLD FUNCTION, WITH A NULL VALUE RETURNED/

P$$OPS:	POP	ES,R1	; GET OLD FUNC NAME
	JSP	R10,S$$LKF	; LOOKUP FUNCTION WORD
	MOVE	R11,(R2)	; SAVE FUNCTION WORD
	POP	ES,R1	; GET NEW FUNC NAME
	JSP	R10,S$$LKF	; LOOKUP FUNCTION WORD
	MOVEM	R11,(R2)	; STORE DEFINITION OF OLD FUNC
	SETZ	R1,	; RETURN NULL
	JRST	(R12)
	PRGEND
	SUBTTL	P$$DIF,P$$IDT DIFFER(X,Y),IDENT(X,Y) PRIMITIVE FUNCTIONS

	ENTRY	P$$DIF,P$$IDT
	EXTERN	S$$FLR,S$$EQS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. DIFFER(X,Y) FAILS
IF X AND Y ARE IDENTICAL, AND IDENT(X,Y) FAILS IF X AND Y ARE NOT IDEN-
TICAL; OTHERWISE A NULL VALUE IS RETURNED. SIMILAR STRINGS ARE CONSIDER-
ED IDENTICAL, BUT OTHER TYPES OF DESCRIPTORS MUST MATCH EXACTLY/

P$$DIF:	JSP	R11,COMCOM	; DIFFER(), INDEX=0
P$$IDT:	JSP	R11,COMCOM	; IDENT(), INDEX=1
COMCOM:	SUBI	R11,P$$DIF+1	; COMPUTE INDEX
	POP	ES,R1	; GET SECOND ARG
	POP	ES,R2	; GET FIRST ARG
	SETZB	R0,R3	; GET THEIR TYPES
	ROTC	R0,2
	ROTC	R2,2
	CAIE	R0,(R3)	; ARE TYPES EQUAL?
	JRST	DIFTYP(R11)	; NO, DIFFERENT
	JUMPN	R0,IDTTYP(R11)	; YES, IDENTICAL UNLESS STRING TYPE
	ROTC	R0,-2	; STRINGS, RESTORE DESCRIPTORS
	ROTC	R2,-2
	JSP	R5,S$$EQS	; COMPARE STRINGS
	JRST	IDTTYP(R11)	; IDENTICAL
	JRST	DIFTYP(R11)	; DIFFERENT
DIFTYP:	JRST	NULRET	; DIFFER, DIFFERENT
IDTTYP:	JRST	S$$FLR	; DIFFER, IDENTICAL OR IDENT, DIFFERENT
NULRET:	SETZ	R1,	; IDENT, IDENTICAL   RETURN NULL
	JRST	(R12)
	PRGEND
	SUBTTL	P$$LTP[LEP,EQP,NEP,GEP,GTP] LT(I,J),...,GT(I,J) PRIMITIV

	ENTRY	P$$LTP,P$$LEP,P$$EQP,P$$NEP,P$$GEP,P$$GTP
	EXTERN	S$$PGL,S$$STN,S$$ITR,S$$FLR
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. ARGUMENTS MUST BE
CONVERTIBLE TO INTEGERS OR REALS, WITH A NULL VALUE RETURNED ON SUCCESS
OF THE COMPARISON, OR FAILURE. AN INTEGER BEING COMPARED TO A REAL IS
FIRST CONVERTED TO REAL/

P$$LTP:	JSP	R11,PRDCOM	; LT, INDEX=0
P$$LEP:	JSP	R11,PRDCOM	; LE, INDEX=1
P$$EQP:	JSP	R11,PRDCOM	; EQ, INDEX=2
P$$NEP:	JSP	R11,PRDCOM	; NE, INDEX=3
P$$GEP:	JSP	R11,PRDCOM	; GE, INDEX=4
P$$GTP:	JSP	R11,PRDCOM	; GT, INDEX=5
PRDCOM:	SUBI	R11,P$$LTP+1	; FORM INDEX
	POP	ES,R1	; GET SECOND ARG
	SETZ	R2,	; GET TYPE
	ROTC	R1,2
	JRST	.+1(R2)	; GET INTEGER OR REAL VALUE
	JSP	R7,S$$STN-1	; STRING
	CFERR	10,S$$PGL	; OTHER, OR NONCONVERTIBLE STRING
	ASH	R1,-2	; INTEGER, FORM TRUE VALUE
	MOVEI	R10,(R2)	; REAL, OR CONVERTED STRING, SAVE TYPE
	MOVE	R9,R1	; SAVE VALUE
	POP	ES,R1	; REPEAT FOR FIRST ARG
	SETZ	R2,
	ROTC	R1,2
	JRST	.+1(R2)
	JSP	R7,S$$STN-1
	CFERR	10,S$$PGL
	ASH	R1,-2
	CAIN	R2,(R10)	; ARE TYPES EQUAL?
	JRST	SAMMOD	; YES
	CAIE	R10,3	; NO, WAS SECOND REAL?
	EXCH	R1,R9	; NO, EXCHANGE FIRST AND SECOND
	JSP	R3,S$$ITR	; YES, NOW CONVERT INTEGER TO REAL
	CAIE	R10,3	; SWITCH BACK?
	EXCH	R1,R9	; YES
SAMMOD:	XCT	TESTBL(R11)	; EXECUTE TEST
	JRST	S$$FLR	; TEST FAILED, FAIL
	SETZ	R1,	; TEST SUCCEEDED, RETURN NULL
	JRST	(R12)
TESTBL:	CAML	R1,R9
	CAMLE	R1,R9
	CAME	R1,R9
	CAMN	R1,R9
	CAMGE	R1,R9
	CAMG	R1,R9
	PRGEND
	SUBTTL	F$$LTP[LEP,EQP,NEP,GEP,GTP] ILT(I,J),...,IGT(I,J) FORT

	ENTRY	F$$LTP,F$$LEP,F$$EQP,F$$NEP,F$$GEP,F$$GTP
	EXTERN	S$$FLR
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	JSA	^O16,F$$LTP[ETC]	; PERFORMS SPECIFIED COMPARISON
	ARG	CODE,LOC1	; BETWEEN VALUES IN LOC1 AND LOC2, AND
	ARG	CODE,LOC2	; FAILS OR RETURNS 0 IN R0/

F$$LTP:	BLOCK	1	; ILT, INDEX=0
	JSP	R1,PRDCOM
F$$LEP:	BLOCK	1	; ILE, INDEX=1
	JSP	R1,PRDCOM
F$$EQP:	BLOCK	1	; IEQ, INDEX=2
	JSP	R1,PRDCOM
F$$NEP:	BLOCK	1	; INE, INDEX=3
	JSP	R1,PRDCOM
F$$GEP:	BLOCK	1	; IGE, INDEX=4
	JSP	R1,PRDCOM
F$$GTP:	BLOCK	1	; IGT, INDEX=5
	JSP	R1,PRDCOM
PRDCOM:	SUBI	R1,F$$LTP+2	; FORM INDEX
	LSH	R1,-1
	MOVE	R0,@(^O16)	; GET FIRST VAL
	XCT	TESTBL(R1)	; COMPARE TO SECOND
	JRST	S$$FLR	; FAIL
	SETZ	R0,	; OR RETURN 0
	JRA	^O16,2(^O16)
TESTBL:	CAML	R0,@1(^O16)
	CAMLE	R0,@1(^O16)
	CAME	R0,@1(^O16)
	CAMN	R0,@1(^O16)
	CAMGE	R0,@1(^O16)
	CAMG	R0,@1(^O16)
	PRGEND
	SUBTTL	F$$AND,F$$IOR,F$$XOR AND(I,J),OR(I,J),XOR(I,J) FORT

	ENTRY	F$$AND,F$$IOR,F$$XOR
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	JSA	^O16,F$$AND[ETC]	; PERFORMS SPECIFIED LOGICAL
	ARG	CODE,LOC1	; OPERATION BETWEEN LOC1 AND LOC2 AND
	ARG	CODE,LOC2	; RETURNS RESULT IN R0/

F$$AND:	BLOCK	1	; AND, INDEX=0
	JSP	R1,LOGCOM
F$$IOR:	BLOCK	1	; OR, INDEX=1
	JSP	R1,LOGCOM
F$$XOR:	BLOCK	1	; XOR, INDEX=2
	JSP	R1,LOGCOM
LOGCOM:	SUBI	R1,F$$AND+2	; FORM INDEX
	LSH	R1,-1
	MOVE	R0,@(^O16)	; GET FIRST VAR
	XCT	LOGTBL(R1)	; PERFORM OPERATION WITH SECOND VAR
	JRA	^O16,2(^O16)	; RETURN WITH RESULT IN R0
LOGTBL:	AND	R0,@1(^O16)
	OR	R0,@1(^O16)
	XOR	R0,@1(^O16)
	PRGEND
	SUBTTL	F$$RSH,F$$LSH RSHIFT(I,J),LSHIFT(I,J) FORTRAN PRIMITIVES

	ENTRY	F$$RSH,F$$LSH
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	JSA	^O16,F$$RSH[LSH]	; PERFORMS SPECIFIED SHIFT OF
	ARG	CODE,LOC1	; VALUE IN LOC1 BY AMOUNT IN LOC2 AND
	ARG	CODE,LOC2	; RETURNS RESULT IN R0/

F$$RSH:	BLOCK	1
	MOVE	R0,@(^O16)	; GET VAL
	MOVN	R1,@1(^O16)	; -SHIFT (TO RIGHT)
	LSH	R0,(R1)	; SHIFT
	JRA	^O16,2(^O16)	; RETURN
F$$LSH:	BLOCK	1
	MOVE	R0,@(^O16)	; GET VAL
	MOVE	R1,@1(^O16)	; +SHIFT (TO LEFT)
	LSH	R0,(R1)	; SHIFT
	JRA	^O16,2(^O16)	; RETURN
	PRGEND
	SUBTTL	F$$RMD REMDR(I,J) FORTRAN PRIMITIVE FUNCTION

	ENTRY	F$$RMD
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	JSA	^O16,F$$RMD	; PERFORMS INTEGER DIVISION OF VALUE IN
	ARG	CODE,LOC1	; LOC1 BY VALUE IN LOC2 AND RETURNS RE-
	ARG	CODE,LOC2	; MAINDER IN R0/

F$$RMD:	BLOCK	1
	MOVE	R0,@(^O16)	; GET DIVIDEND
	IDIV	R0,@1(^O16)	; DIVIDE
	MOVE	R0,R1	; GET REMAINDER
	JRA	^O16,2(^O16)	; RETURN
	PRGEND
	SUBTTL	P$$LPD,P$$RPD LPAD[RPAD](STRING,N,CHR) PRIMITIVE FUNC

	ENTRY	P$$LPD,P$$RPD
	EXTERN	S$$MKS,S$$MKI,S$$PGL,S$$GRS,S$$MVS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 3. RETURNS STRING
PADDED ON THE LEFT[RIGHT] TO N CHARACTERS TOTAL WITH THE CHARACTER CHR.
IF THIRD ARG IS NULL, BLANK IS USED. IF THIRD ARG IS MORE THAN 1 CHAR,
ONLY FIRST CHAR IS USED. IF SIZE(STRING) IS > OR = TO N, STRING IS
RETURNED UNCHANGED/

P$$LPD:	JSP	R11,PADCOM	; LPAD(), INDEX=0
P$$RPD:	JSP	R11,PADCOM	; RPAD(), INDEX=1
PADCOM:	SUBI	R11,P$$LPD+1	; FORM INDEX
	POP	ES,R1	; GET PAD CHAR
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	JUMPE	R3,[MOVEI	R8," "
		    JRST	BLNRET]	; IF NULL, USE BLANK
	ILDB	R8,R1	; SAVE FIRST CHAR
BLNRET:	POP	ES,R1	; GET PAD LENGTH
	JSP	R7,S$$MKI	; ASSURE INTEGER
	CFERR	10,S$$PGL
	JUMPL	R1,.-1	; ERROR IF <0
	MOVEI	R9,(R1)	; SAVE
	MOVE	R1,(ES)	; GET STRING
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	CAIL	R3,(R9)	; IS SIZE(STRING) < N?
	JRST	PADFIN	; NO, QUIT NOW
	MOVEM	R1,(ES)	; SAVE DESCR
	MOVEI	R10,(R3)	; SAVE SIZE OF STRING
	MOVEI	R0,(R9)	; COMPUTE # OF WORDS NEEDED FOR PADDED STRING
	MUL	R0,[^F0.2B0]
	ADDI	R0,2
	JSP	R6,S$$GRS	; GET BLOCK
	HRLI	R1,^O700	; FORM DESCR
	HRRM	R9,(R1)	; SAVE CHAR COUNT
	SUBI	R9,(R10)	; COMPUTE # OF PADDING CHARS
	MOVE	R2,(ES)	; GET OLD STRING DESCR
	MOVEM	R1,(ES)	; SAVE NEW STRING DESCR
	JRST	.+1(R11)	; DO PADDING
	JRST	LPAD	; LEFT
	MOVEI	R3,(R10)	; RIGHT, GET SIZE OF OLD STRING
	JUMPE	R3,RPDLOP	; SKIP IF NULL
	JSP	R7,S$$MVS	; COPY INTO NEW STRING
RPDLOP:	IDPB	R8,R1	; COPY PADDING CHARS
	SOJG	R9,RPDLOP	; LOOP
PADFIN:	POP	ES,R1	; GET NEW STRING DESCR
	JRST	(R12)	; RETURN
LPAD:	IDPB	R8,R1	; COPY PADDING CHARS
	SOJG	R9,LPAD	; LOOP
	MOVEI	R3,(R10)	; GET SIZE OF OLD STRING
	JUMPE	R3,PADFIN	; QUIT IF NULL
	JSP	R7,S$$MVS	; COPY OLD STRING
	JRST	PADFIN	; FINISH
	PRGEND
	SUBTTL	P$$INS INSERT(SUBSTR,STRING,N,POS) PRIMITIVE FUNCTION

	ENTRY	P$$INS
	EXTERN	S$$PGL,S$$MKI,S$$MKS,S$$GRS,S$$MVS,S$$FLR,S$$SPC,S$$KWD
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 4. THE STATEMENT
	VAL	= INSERT(SUBSTR,STRING,N,POS)
IS EQUIVALENT TO THE STATEMENTS
	STRING	TAB(POS) . PART1  LEN(N)  REM . PART2
	VAL	= PART1 SUBSTR PART2
AND FAILS UNDER THE SAME CONDITIONS THAT WOULD CAUSE THE MATCH TO FAIL/

P$$INS:	POP	ES,R1	; GET POS
	JSP	R7,S$$MKI	; ASSURE INTEGER
	CFERR	10,S$$PGL
	JUMPL	R1,S$$FLR	; FAIL IF <0
	MOVEI	R8,(R1)	; SAVE POS
	POP	ES,R1	; GET N
	JSP	R7,S$$MKI	; ASSURE INTEGER
	CFERR	10,S$$PGL
	JUMPL	R1,S$$FLR	; FAIL IF <0
	MOVEI	R9,(R1)	; SAVE N
	MOVE	R1,(ES)	; GET STRING
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	EXCH	R1,-1(ES)	; SAVE ON STACK, GET SUBSTR
	SUBI	R3,(R9)	; SIZE(STRING)-N
	MOVEI	R10,(R3)	; SAVE
	SUBI	R3,(R8)	; SIZE(STRING)-N-POS (REM)
	JUMPL	R3,S$$FLR	; FAIL IF REM<0
	MOVEI	R11,(R3)	; SAVE REM CHARS
	SETO	R0,	; ASSURE SUBSTR IS STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	MOVEM	R1,(ES)	; SAVE ON STACK
	EXCH	R3,R10	; SAVE SIZE(SUBSTR), GET SIZE(STRING)-N
	ADDI	R3,(R10)	; SIZE(STRING)-N+SIZE(SUBSTR)
	CAMLE	R3,S$$KWD+12	; IS IT > &MAXLNGTH?
	CFERR	15,S$$PGL	; YES, STRING OVERFLOW ERROR
	MOVEI	R7,(R3)	; SAVE AS SIZE OF NEW STRING
	MUL	R3,[^F0.2B0]	; COMPUTE # WORDS NEEDED FOR NEW STRING
	MOVEI	R0,2(R3)
	JSP	R6,S$$GRS	; GET BLOCK FOR NEW STRING
	HRLI	R1,^O700	; FORM DESCR
	HRRM	R7,(R1)	; SAVE CHAR COUNT
	MOVE	R2,-1(ES)	; GET OLD STRING DESCR
	MOVEM	R1,-1(ES)	; SAVE NEW STRING DESCR
	SKIPE	R3,R8	; LOAD POS, SKIP IF 0
	JSP	R7,S$$MVS	; COPY FRONT OF STRING
	MOVEI	R3,(R9)	; GET N
	JSP	R5,S$$SPC	; SPACE OVER MIDDLE OF STRING
	EXCH	R2,(ES)	; SAVE POINTER, GET SUBSTR DESCR
	SKIPE	R3,R10	; LOAD SIZE(SUBSTR), SKIP IF 0
	JSP	R7,S$$MVS	; COPY SUBSTR
	POP	ES,R2	; GET REM STRING POINTER
	SKIPE	R3,R11	; LOAD REM CHARS, SKIP IF 0
	JSP	R7,S$$MVS	; COPY REM CHARS
	POP	ES,R1	; GET NEW STRING DESCR
	JRST	(R12)	; RETURN
	PRGEND
	SUBTTL	P$$SBS SUBSTR(STRING,N,POS) PRIMITIVE FUNCTION

	ENTRY	P$$SBS,S$$SPC
	EXTERN	S$$PGL,S$$MKI,S$$MKS,S$$GRS,S$$MVS,S$$FLR
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 3. THE STATEMENT
	VAL	= SUBSTR(STRING,N,POS)
IS EQUIVALENT TO THE STATEMENT
	STRING	TAB(POS)  LEN(N) . VAL
AND FAILS UNDER THE SAME CONDITIONS THAT WOULD CAUSE THE MATCH TO FAIL/

P$$SBS:	POP	ES,R1	; GET POS
	JSP	R7,S$$MKI	; ASSURE INTEGER
	CFERR	10,S$$PGL
	JUMPL	R1,S$$FLR	; FAIL IF <0
	MOVEI	R8,(R1)	; SAVE POS
	POP	ES,R1	; GET N
	JSP	R7,S$$MKI	; ASSURE INTEGER
	CFERR	10,S$$PGL
	JUMPL	R1,S$$FLR	; FAIL IF <0
	JUMPE	R1,NULRET	; NULL RETURNED IF = 0
	MOVEI	R9,(R1)	; SAVE N
	MOVE	R1,(ES)	; GET STRING
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	MOVEM	R1,(ES)	; SAVE DESCR
	SUBI	R3,(R8)	; SIZE(STRING)-POS
	SUBI	R3,(R9)	; SIZE(STRING)-POS-N
	JUMPL	R3,S$$FLR	; FAIL IF <0
	MOVEI	R0,(R9)	; COMPUTE # WORDS NEEDED FOR SUBSTRING
	MUL	R0,ZPOIN2
	ADDI	R0,2
	JSP	R6,S$$GRS	; GET BLOCK
	HRLI	R1,^O700	; FORM DESCR
	HRRM	R9,(R1)	; SAVE CHAR COUNT
	MOVE	R2,(ES)	; GET OLD STRING DESCR
	MOVEM	R1,(ES)	; SAVE SUBSTRING DESCR
	MOVEI	R3,(R8)	; GET POS
	JSP	R5,S$$SPC	; SPACE POINTER TO BEGINNING OF SUBSTR
	MOVEI	R3,(R9)	; GET N
	JSP	R7,S$$MVS	; COPY SUBSTRING
	POP	ES,R1	; GET SUBSTRING DESCR
	JRST	(R12)	; RETURN
NULRET:	SUB	ES,[XWD 1,1]	; POP ES
	SETZ	R1,	; RETURN NULL
	JRST	(R12)
	COMMENT/SPACE CHARACTERS ROUTINE
CALL:	JSP	R5,S$$SPC	; WITH BYTE POINTER IN R2, MOVE COUNT
	IN R3, AND RETURNS UPDATED BYTE COUNTER IN R2, WITH R0 AND R1
	UNCHANGED/

S$$SPC:	JUMPE	R3,(R5)	; RETURN IF NO MOVEMENT
	MUL	R3,POINT2	; COMPUTE # OF WHOLE WORDS
	ROT	R4,4	; COMPUTE REMAINING CHAR INDEX
	XCT	CHNGCR-1(R4)	; PERFORM PTR INCREMENTATION
	JRST	(R5)	; AND RETURN
CHNGCR:	JRST	ONECHR	; REM=1, 1 CHR
ZPOIN2:	^F0.2B0		; REM=2, IMPOSSIBLE, USE SPACE
	JRST	TWOCHR	; REM=3, 2 CHR
	JRST	THRCHR	; REM=4, 3 CHR
POINT2:	^O63146300000	; REM=5, IMPOSSIBLE, USE SPACE
	JRST	FOUCHR	; REM=6, 4 CHR
	ADDI	R2,1(R3)	; REM=7, 5 CHR
FOUCHR:	IBP	R2	; 4
THRCHR:	IBP	R2	; 3
TWOCHR:	IBP	R2	; 2
ONECHR:	IBP	R2	; 1
	ADDI	R2,(R3)	; ADD WHOLE WORDS
	JRST	(R5)	; RETURN
	PRGEND
	SUBTTL	P$$RPL REPLACE(STRING,CLASS1,CLASS2) PRIMITIVE FUNCTION

	ENTRY	P$$RPL
	EXTERN	S$$PGL,S$$MKS,S$$GRS,S$$FLR
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 3. RESULT IS STRING
WITH EACH CHARACTER APPEARING IN CLASS1 STRING REPLACED BY THE CORRES-
PONDING CHARACTER IN CLASS2 STRING. FAILS IF EITHER OF THE CLASS STRINGS
ARE NULL OR IF THEY ARE OF DIFFERENT LENGTHS/

P$$RPL:	POP	ES,R1	; GET CLASS2 STRING
	CAME	R1,LASTC2	; IS IT SAME AS LAST TIME?
	JRST	NEWTAB+1	; NO, BUILD NEW TABLE
	POP	ES,R1	; GET CLASS1 STRING
	CAME	R1,LASTC1	; IS IT SAME AS LAST TIME?
	AOBJN	ES,NEWTAB	; NO, FIX STACK, BUILD NEW TABLE
RPLCOM:	MOVE	R1,(ES)	; GET STRING
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	MOVEM	R1,(ES)	; SAVE DESCR
	JUMPE	R3,RPLFIN	; SKIP IF NULL
	MOVEI	R7,(R3)	; SAVE CHAR COUNT
	MUL	R3,[^F0.2B0]	; COMPUTE # OF WORDS NEEDED
	MOVEI	R0,2(R3)	; FOR REPLACEMENT STRING
	JSP	R6,S$$GRS	; GET BLOCK
	HRLI	R1,^O700	; DORM DESCR
	HRRM	R7,(R1)	; SAVE CHAR COUNT
	MOVE	R2,(ES)	; GET OLD STRING DESCR
	MOVEM	R1,(ES)	; SAVE NEW STRING DESCR
RPLOOP:	ILDB	R3,R2	; GET CHAR FROM OLD STRING
	MOVE	R3,RPLTAB(R3)	; GET REPLACEMENT CHAR
	IDPB	R3,R1	; PUT IN NEW STRING
	SOJG	R7,RPLOOP	; LOOP
RPLFIN:	POP	ES,R1	; GET NEW STRING DESCR
	JRST	(R12)	; RETURN
NEWTAB:	MOVE	R1,1(ES)	; GET CLASS2 STRING
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	JUMPE	R3,S$$FLR	; FAIL IF NULL
	MOVEI	R8,(R3)	; SAVE CHAR COUNT
	EXCH	R1,(ES)	; EXCHANGE CLASS2 WITH CLASS1 STRING
	SETO	R0,	; ASSURE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL
	CAIE	R3,(R8)	; SIZES EQUAL?
	JRST	S$$FLR	; NO, FAIL
	POP	ES,R2	; GET CLASS2
	MOVEM	R2,LASTC2	; SAVE CLASS1 AND CLASS2 FOR NEXT TIME
	MOVEM	R1,LASTC1
	MOVEI	R3,^O177	; SET UP NORMAL TABLE WITH &ALPHABET
TBFLOP:	MOVEM	R3,RPLTAB(R3)	; I.E. EACH CHAR REPLACES ITSELF
	SOJGE	R3,TBFLOP	; LOOP
TBLLOP:	ILDB	R3,R1	; GET CHAR FROM CLASS1
	ILDB	R4,R2	; GET CHAR FROM CLASS2
	MOVEM	R4,RPLTAB(R3)	; SAVE CLASS2 CHAR IN CLASS1 ENTRY
	SOJG	R8,TBLLOP	; LOOP
	JRST	RPLCOM	; GO REPLACE
; STORAGE
LASTC1:	-1
LASTC2:	-1
RPLTAB:	BLOCK	^O200
	PRGEND
	SUBTTL	P$$TBL TABLE(SIZE,EXT) PRIMITIVE FUNCTION

	ENTRY	P$$TBL,S$$TRF
	EXTERN	S$$PGL,S$$GRS,S$$MKI,S$$GLP,S$$GNS,S$$SY1,S$$TBM
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
	TABLE() PRIMITIVE
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. IF FIRST ARGUMENT
IS A TABLE DATATYPE, IT MARKS IT AS DELETED AND DISCONNECTS ALL THE EN-
TRIES, RETURNING NULL. IF FIRST ARG IS AN ARRAY DATATYPE, IT MUST HAVE
2 DIMENSIONS, WITH A RANGE OF 2 FOR THE SECOND, AND IT IS CONVERTED TO
A TABLE AND RETURNED. OTHERWISE, A TABLE WITH THE GIVEN INITIAL AND EX-
TENSION SIZE IS CREATED AND RETURNED.
	TABLE REFERENCE
CALL:	JRST	S$$TRF	; WITH RETURN LINK IN R12, TABLE DESCR IN R8, KEY
DESCR ON ES. RETURNS POINTER TO VALUE WORD OF TABLE ENTRY IN R2, WITH KEY
POPED OFF ES/

; TABLE() PRIMITIVE
P$$TBL:	MOVE	R1,-1(ES)	; GET FIRST ARG
	TLC	R1,^B0101B21	; IS IT ARRAY OR TABLE?
	TLNN	R1,^B1111B21
	JRST	NOTNTB	; YES
	TLC	R1,^B0101B21	; NO, MUST BE INTEGER
	JSP	R7,S$$MKI
BADARG:	CFERR	10,S$$PGL	; OR IS BAD ARG
	JUMPL	R1,BADARG	; ERROR IF SIZE < 0
	JUMPN	R1,.+2	; USE 10 IF 0
	MOVEI	R1,10
	LSH	R1,2	; *4 WORDS PER ENTRY
	HRLZI	R7,(R1)	; SAVE FOR ESIZE,XPTR WORD
	MOVEI	R0,3(R1)	; +3 WORDS FOR INITIAL BLOCK
	JSP	R6,S$$GRS	; GET BLOCK
	MOVEI	R2,3(R1)	; PTR TO FIRST ENTRY
	MOVEM	R2,1(R1)	; SAVE
	MOVEM	R7,2(R1)	; SAVE ESIZE,XPTR WORD
	AOS	R2,S$$GLP+3	; GET NEW TABLE #
	TRO	R2,^B01011B22	; MAKE TABLE DESCR
	HRLI	R1,(R2)
	MOVEM	R1,-1(ES)	; SAVE ON ES
	POP	ES,R1	; GET EXT SIZE OFF ES
	JSP	R7,S$$MKI	; MUST BE POSITIVE INTEGER
	JRST	BADARG
	JUMPL	R1,BADARG
	JUMPN	R1,.+2	; USE 10 IF 0
	MOVEI	R1,10
	LSH	R1,2	; EXT BLOCK SIZE = # ENTRIES*4 + 2
	ADDI	R1,2
	MOVE	R2,(ES)	; GET PTR TO TABLE
	HRRM	R1,(R2)	; SAVE EXTENSION SIZE
; ADD TABLE TO ACTIVE TABLE CHAIN
	SKIPE	R7,TBLCHN	; HAS TABLE CHAIN BEEN STARTED?
	JRST	ADDCHN	; YES, SKIP
	MOVEI	R0,2	; NO, GET BLOCK TO START CHAIN
	JSP	R6,S$$GNS	; MAKE IT NONRETURNABLE
	MOVEI	R7,(R1)	; GET PTR
	MOVEM	R7,TBLCHN	; SAVE IN TABLE CHAIN WORD
	HLRZ	R0,S$$GLP+1	; GET PTR TO START OF VAR BLOCK LIST
	HRRM	R0,(R1)	; SAVE IN NEW BLOCK
	HRLM	R1,S$$GLP+1	; START OF VAR BLOCK LIST IS NEW BLOCK
	HRLZI	R0,1B18	; INTEGER DESCR FOR 0
	MOVEM	R0,1(R1)	; SAVE IN BLOCK
ADDCHN:	AOS	1(R7)	; INCREMENT TABLE CHAIN COUNT
	MOVEI	R0,2	; GET NEW BLOCK
	JSP	R6,S$$GNS
	MOVE	R2,(R7)	; SPLICE INTO CHAIN AT FRONT
	HRRM	R2,(R1)
	HRRM	R1,(R7)
	POP	ES,1(R1)	; SAVE TABLE DESCR IN BLOCK
	MOVE	R1,1(R1)	; RETURN TABLE DESCR
	JRST	(R12)
; ARRAY OR TABLE
NOTNTB:	TLNE	R1,1B22	; IS IT ARRAY?
	JRST	DELTBL	; NO, GO DELETE TABLE
	MOVE	R2,(R1)	; GET PROTOTYPE BLOCK POINTER
	LSH	R1,-23	; GET NDIM
	HLRZ	R3,1(R2)	; GET RANGE OF LAST DIM
	CAIN	R1,2	; IS IT 2 DIMENSIONS
	CAIE	R3,2	; AND A RANGE OF 2 FOR THE SECOND?
	JRST	BADARG	; NO, BAD ARG
	HLRZ	R1,2(R2)	; GET RANGE OF FIRST DIM
	TLO	R1,1B18	; FORM INTEGER DESCR
	MOVEM	R1,(ES)	; PUT ON ES AS FIRST ARG TO TABLE()
	SETZ	R1,	; PUSH NULL SECOND ARG
	PUSH	ES,R1
	HRRM	R12,ATTRET	; SAVE LINK
	JSP	R12,P$$TBL	; AND SIMULATE TABLE() CALL
	HRLZI	R0,^O17777	; GET 0/TABLE NO. INTO R0
	AND	R0,R1
	MOVEI	R8,3(R1)	; GET FIRST TABLE ENTRY PTR
	HLRZ	R9,2(R1)	; GET  RANGE
	LSH	R9,-2
	HRRM	R9,SAVVAL	; SAVE FOR ACCESS OF UPPER 1/2 OF ARRAY
	MOVNI	R9,(R9)	; GET -RANGE
	HRLZI	R9,(R9)	; INTO LH FOR AOBJ
	EXCH	R1,(ES)	; SAVE TABLE DESCR AND GET ARRAY DESCR
	ADDI	R9,1(R1)	; POINT TO FIRST ELEMENT OF ARRAY
ATBLOP:	MOVE	R1,(R9)	; GET KEY DESCR
	JSP	R7,S$$SY1	; DO LOOKUP
LKPRET:	JRST	SAVVAL	; FOUND, ALREADY IN TABLE
	MOVEM	R0,1(R8)	; NOT FOUND, SAVE TBLNO.,MAJOR KEY
	MOVEM	R1,2(R8)	; SAVE KEY
	HLL	R2,(R2)	; FORM CHAIN WORD FOR NEW ENTRY
	MOVEM	R2,(R8)	; AND SAVE
	HRLM	R8,(R2)	; SPLICE ENTRY INTO CHIN
	MOVS	R2,R2
	HRRM	R8,(R2)
	MOVEI	R2,3(R8)	; PTR TO VALUE LOC
	ADD	R8,[XWD 4,4]	; NEXT ENTRY POINTER
SAVVAL:	MOVE	R1,.-.(R9)	; GET VALUE DESCR FROM UPPER 1/2
	MOVEM	R1,(R2)	; SAVE IN ENTRY
	AOBJN	R9,ATBLOP	; LOOP FOR ENTIRE FIRST ARRAY DIMENSION
	POP	ES,R1	; GET TABLE DESCR
	HLLM	R8,1(R1)	; SAVE CURRENT ENTRY INDEX
ATTRET:	JRST	.-.	; RETURN
; DELETE TABLE
DELTBL:	TLC	R1,^B0101B21	; RESTORE TABLE DESCR
	MOVE	R2,(R1)	; GET FIRST WORD
	TROE	R2,1B19	; IS DELETE BIT SET?
	JRST	BADARG	; YES, ERROR
	MOVEM	R2,(R1)	; NO, SET IT
	MOVE	R7,TBLCHN	; GET CHAIN POINTER
	SOS	R5,1(R7)	; DECREMENT COUNT
	HRRZI	R5,(R5)	; BUT IGNORE INTEGER DESCRIPTOR BIT
DSRCHL:	MOVE	R6,(R7)	; GET PTR TO NEXT ON CHAIN
	CAMN	R1,1(R6)	; IS THIS THE TABLE?
	JRST	DSRCHF	; YES, FOUND
	MOVEI	R7,(R6)	; NO, SAVE POINTER
	SOJGE	R5,DSRCHL	; AND LOOP
	UFERR	1,S$$PGL	; OR ERROR
DSRCHF:	MOVE	R2,(R6)	; REMOVE BLOCK FROM CHAIN
	TLC	R2,3B19	; AND MAKE NONRETURNABLE
	MOVEM	R2,(R6)
	HRRM	R2,(R7)
	MOVE	R4,1(R1)	; COMPUTE NEXT AVAIL ENTRY POINTER
	HLRZ	R3,R4
	ADDI	R3,(R4)
	MOVEI	R4,3(R1)	; RESET NEXT AVAIL TO FIRST
	MOVEM	R4,1(R1)
	AOSA	R2,R1	; FAKE EXT BLOCK POINTER AND SKIP
DELLOP:	MOVE	R2,1(R2)	; GET PTR TO NEW EXT BLOCK
	MOVE	R5,1(R2)	; COMPUTE END OF EXT BLOCK PTR
	HLRZ	R4,R5
	ADDI	R4,2(R2)
	MOVEI	R1,2(R2)	; PTR TO FIRST ENTRY IN BLOCK
DISCLP:	CAIN	R1,(R3)	; IS IT LAST?
	JRST	DELFIN	; YES, FINISH
	CAIN	R1,(R4)	; IS IT END OF BLOCK?
	JRST	DELLOP	; YES, GO ON TO NEXT
	MOVE	R5,(R1)	; GET CHAIN WORD
	HLLM	R5,(R5)	; SET BACK LINK INTO NEXT
	MOVS	R5,R5
	HLRM	R5,(R5)	; SET FORWARD LINK INTO PREVIOUS
	ADDI	R1,4	; PTR TO NEXT ENTRY
	JRST	DISCLP	; LOOP
DELFIN:	SUB	ES,[XWD 2,2]	; POP ES 2 PLACES
	SETZ	R1,	; RETURN NULL
	JRST	(R12)

; TABLE REFERENCE
S$$TRF:	HRLZI	R0,^O17777	; GET 0/TBL NO. INTO LH OF R0
	AND	R0,R8
	POP	ES,R1	; GET KEY DESCR INTO R1
	JSP	R7,S$$SY1	; DO LOOKUP
	JRST	(R12)	; FOUND, RETURN VAL POINTER IN R2
	MOVE	R4,R8	; GET TABLE DESCR
	JSP	R7,S$$TBM	; MAKE NEW TABLE ENTRY
	SETZM	(R2)	; SET INITIAL VALUE TO NULL
	JRST	(R12)	; RETURN VALUE PTR IN R2
; STORAGE
TBLCHN:	0	; START OF TABLE CHAIN
	PRGEND
	SUBTTL	P$$ARR ARRAY(PROT,IVAL) PRIMITIVE FUNCTION

	ENTRY	P$$ARR,S$$ARF
	EXTERN	S$$PGL,S$$GRS,S$$MKS,S$$GNP,S$$STB,S$$TAC,S$$ITS,S$$FLR
	EXTERN	S$$MKI
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
	ARRAY() PRIMITIVE
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. IF FIRST ARG IS A
TABLE DATATYPE, IT PRODUCES AND RETURNS A 2-DIMENSIONAL ARRAY('N,2')
WHERE N IS THE NUMBER OF ENTRIES IN THE TABLE, WITH THE REFERENCING
ARGUMENT IN A<I,1> AND VALUE IN A<I,2>. OTHERWISE, THE FIRST ARGUMENT
IS USED AS A PROTOTYPE TO BUILD AND RETURN AN N-DIMENSIONAL ARRAY WHICH
IS INITIALIZED TO CONTAIN ALL VALUES EQUAL TO THE SECOND ARGUMENT.
	ARRAY REFERENCE
CALL:	JRST	S$$ARF	; WITH RETURN LINK IN R12, ARRAY DESCRIPTOR IN
R8, NUMBER OF DIMENSIONS IN R3, AND INDICES ON ES. RETURNS PTR TO ARRAY
ELEMENT IN R2, WITH INDICES POPPED OFF ES. FAILS IF INDICES ARE OUT
OF BOUNDS/

; ARRAY() PRIMITIVE
P$$ARR:	MOVE	R1,-1(ES)	; GET PROTOTYPE DESCR
	TLC	R1,^B01011B22	; IS IT TABLE?
	TLNN	R1,^B11111B22
	JRST	CVRTBL	; YES, GO CONVERT TABLE
	TLC	R1,^B01011B22	; NO
	TLNN	R1,^O770000	; IS IT STRING?
	JRST	.+5	; YES
	SETO	R0,	; NO, CONVERT TO STRING
	JSP	R7,S$$MKS
BADARG:	CFERR	10,S$$PGL	; NOT CONVERTIBLE, BAD ARG
	MOVEM	R1,-1(ES)	; SAVE BACK ON ES
	SETZ	R0,	; GET CHAR COUNT
	HRRZ	R3,(R1)
	JUMPE	R3,BADARG	; ERROR IF NULL
	MOVN	R0,S$$STB-1	; COMPUTE CURRENT SS-BASE
	ADD	R0,SS
	MOVEM	R0,SAVESS	; SAVE
	MOVEI	R7,1	; INITIAL VALUE OF ARRAY SIZE
DIMLOP:	MOVEI	R5,1	; INITIAL LOWER BOUND VAL
	JSP	R4,S$$GNP	; GET NEXT NUMERICAL PARAMETER
	JRST	NXTDIM+1	; NO MORE CHARS
	CAIE	R0,":"	; IS IT A LOWER BOUND?
	JRST	NXTDIM	; NO
	MOVE	R5,R2	; YES, SAVE LOWER BOUND
	JSP	R4,S$$GNP	; GET NEXT NUMERICAL PARAMETER
	JRST	NXTDIM+1	; NO MORE CHARS
NXTDIM:	CAIN	R0,","	; IS DIMENSION TERMINATOR ","?
	CAMLE	R5,R2	; YES, IS UPPER BOUND > OR = LOWER BOUND
	CFERR	6,S$$PGL	; NEITHER, BAD PROROTYPE
	SUB	R2,R5	; COMPUTE RANGE-1
	IMULI	R7,1(R2)	; SIZE=SIZE*RANGE
	HRLI	R5,1(R2)	; FORM XWD RANGE,LDIM
	PUSH	SS,R5	; SAVE ON SS
	JUMPGE	R3,DIMLOP	; LOOP IF MORE CHARS
	MOVEI	R0,1(R7)	; SIZE + 1
	JSP	R6,S$$GRS	; GET BLOCK FOR ARRAY
	HRLI	R1,^O700	; FAKE STRING DESCR
	MOVEM	R1,S$$TAC	; SAVE PTR
	MOVE	R2,(ES)	; GET INITIAL VALUE FOR ARRAY
	MOVEM	R2,1(R1)	; SAVE IN FIRST ELEMENT
	ADDI	R7,(R1)	; PTR TO LAST ELEMENT
	HRLI	R1,1(R1)	; PTR TO FIRST
	ADDI	R1,2	; PTR TO SECOND
	CAIE	R7,-1(R1)	; BUT SKIP IF ONLY 1 ELEMENT
	BLT	R1,(R7)	; FILL ARRAY WITH VALUE
	MOVN	R7,SAVESS	; COMPUTE XWD NDIM,NDIM
	SUB	R7,S$$STB-1
	ADD	R7,SS
	MOVEI	R0,2(R7)	; NDIM+2 WORDS
	JSP	R6,S$$GRS	; FOR PROTOTYPE BLOCK
	HRRM	R1,@S$$TAC	; SAVE POINTER IN ARRAY BLOCK
	MOVEI	R2,^B01010B27(R7)	; FORM LH OF ARRAY DESCR
	LSH	R2,5
	MOVNI	R7,(R7)	; GET -NDIM
	HRLI	R1,(R7)	; FORM XWD -NDIM,PROT BLOCK PTR
	POP	SS,1(R1)	; POP XWD RANGE, LDIM INTO PROT BLOCK
	AOBJN	R1,.-1	; LOOP FOR EACH DIMENSION
	SUB	ES,[XWD 1,1]	; POP INITIAL VALUE OFF ES
	POP	ES,1(R1)	; POP PROTOTYPE STRING DESCR INTO PROT BLOCK
	MOVEI	R3,1(R1)	; SAVE PTR TO BOTTOM OF PROT BLOCK
	SETZ	R1,	; GET PTR TO ARRAY BLOCK
	EXCH	R1,S$$TAC
	HRLI	R1,(R2)	; FORM ARRAY DESCR
	MOVE	R2,(R1)	; GET PTR TO PROT BLOCK
	HRRM	R3,(R2)	; SAVE PTR TO PROT STRING DESCR
	JRST	(R12)	; RETURN
; CONVERT TABLE TO ARRAY
CVRTBL:	HLRZ	R7,1(R1)	; GET # OF ENTRIES IN LAST BLOCK
	LSH	R7,-2
	HRRZ	R3,1(R1)	; FORM PTR TO LAST BLOCK
	SUBI	R3,2
	MOVEI	R1,1(R1)	; DUMMY DIRST BLOCK POINTER
	CAIN	R1,(R3)	; ONLY ONE BLOCK?
	JRST	FRSDIM	; YES, FIRST DIMENSION COMPUTED
SIZLOP:	HLRZ	R4,1(R1)	; GET MAX SIZE OF THIS BLOCK
	LSH	R4,-2	; # ENTRIES IN IT
	ADDI	R7,(R4)	; ADD TO TOTAL
	HRRZ	R1,1(R1)	; PTR TO NEXT BLOCK
	CAIE	R1,(R3)	; IS IT LAST ONE?
	JRST	SIZLOP	; NO, LOOP
FRSDIM:	MOVEI	R0,(R7)	; GET # ENTRIES * 2 + 1
	JUMPE	R0,S$$FLR	; FAIL IF NO ENTRIES
	LSH	R0,1
	ADDI	R0,1
	JSP	R6,S$$GRS	; GET BLOCK FOR ARRAY
	HRLI	R1,^O700	; MAKE DUMMY STRING DESCR
	MOVEM	R1,S$$TAC	; AND SAVE
	HRLI	R1,^O400001	; SET UP INFINITE STACKS
	MOVEI	R6,(R7)	; TO STORE ARRAY ELEMENTS, KEYS IN FIRST
	ADD	R6,R1	; HALF AND VALUES IN SECOND HALF
	MOVE	R2,-1(ES)	; GET TABLE POINTER
	MOVE	R4,1(R2)	; COMPUTE NEXT AVAILABLE ENTRY PTR
	HLRZ	R3,R4
	ADDI	R3,(R4)
	AOJA	R2,.+2	; DUMMY FIRST BLOCK POINTER
TBTARL:	MOVE	R2,1(R2)	; GET NEXT BLOCK POINTER
	HLRZ	R4,1(R2)	; COMPUTE END OF CURRENT BLOCK PTR
	ADDI	R4,2(R2)
	MOVEI	R5,2(R2)	; FIRST ENTRY IN THIS BLOCK
TBTARE:	CAIN	R5,(R3)	; NO MORE ENTRIES?
	JRST	TBTARF	; YES, FINISHED
	CAIN	R5,(R4)	; NO MORE ENTRIES IN THIS BLOCK?
	JRST	TBTARL	; YES, GO ON TO NEXT BLOCK
	PUSH	R1,2(R5)	; A<I,1>=KEY DESCR
	PUSH	R6,3(R5)	; A<I,2>=VALUE DESCR
	ADDI	R5,4	; PTR TO NEXT ENTRY
	JRST	TBTARE	; LOOP
TBTARF:	MOVEI	R0,3	; GET 3-WORD BLOCK FOR PROTOTYPE STRING
	JSP	R6,S$$GRS
	HRLI	R1,^O700	; FORM STRING DESCR
	MOVEM	R1,(ES)	; SAVE ON ES
	MOVEI	R2,(R7)	; CONVERT FIRST DIMENSION TO STRING
	MOVEI	R0,4
	JSP	R4,S$$ITS+1
	ADDI	R3,2	; + 2 CHARS (",2")
	HRRM	R3,@(ES)	; SAVE IN STRING BLOCK
	MOVEI	R2,","	; FORM "N,2"
	IDPB	R2,R1
	MOVEI	R2,"2"
	IDPB	R2,R1
	MOVEI	R0,4	; GET BLOCK FOR PROTOTYPE
	JSP	R6,S$$GRS
	HRRM	R1,@S$$TAC	; SAVE PTR IN ARRAY BLOCK
	ADDI	R1,3	; PTR TO LAST WORD OF PROT BLOCK
	HRRM	R1,-3(R1)	; SAVE IN FIRST WORD (PTR TO STR DESCR)
	MOVE	R2,[XWD 2,1]	; SECOND DIMENSION RANGE,LDIM
	MOVEM	R2,-2(R1)	; SAVE
	HRLI	R7,1	; FORM	XWD #OF ENTRIES,1
	MOVSM	R7,-1(R1)	; AS FIRST DIMENSION PARAMS
	MOVE	R2,(ES)	; GET PROTOTYPE STRING DESCR
	MOVEM	R2,(R1)	; SAVE IN PROTOTYPE BLOCK
	SUB	ES,[XWD 2,2]	; POP ES 2 LEVELS
	SETZ	R1,	; GET PTR TO ARRAY BLOCK
	EXCH	R1,S$$TAC
	HRLI	R1,^B010100000001000000	; FORM DESCR FOR 2-DIM ARRAY
	JRST	(R12)	; RETURN
; ARRAY REFERENCE
S$$ARF:	MOVNI	R3,(R3)	; GET -NDIM
	SETZ	R9,	; INITIAL DISPLACEMENT
	HRRZ	R10,(R8)	; POINTER TO PROTOTYPE BLOCK
	HRLI	R10,(R3)	; -NDIM IN LH FOR AOBJ
ARFLOP:	POP	ES,R1	; GET NEXT PREVIOUS INDEX
	JSP	R7,S$$MKI	; MUST BE INTEGER
	CFERR	3,S$$PGL	; OR BAD ARRAY REF
	MOVE	R2,1(R10)	; GET RANGE,LDIM(I)
	HLRZ	R3,R2	; RANGE(I)
	HRREI	R2,(R2)	; LDIM(I)
	SUB	R1,R2	; INDEX-LDIM
	JUMPL	R1,S$$FLR	; FAIL IF BELOW LOWER BOUND
	CAIL	R1,(R3)	; IS IT ABOVE UPPER BOUND?
	JRST	S$$FLR	; YES, FAIL
	IMULI	R9,(R3)	; DISP=DISP*RANGE
	ADDI	R9,(R1)	; DISP=DISP+INEX-LDIM
	AOBJN	R10,ARFLOP	; LOOP FOR EACH DIMENSION
	MOVEI	R2,(R9)	; GET DISPLACEMENT
	ADDI	R2,1(R8)	; ADD BASE
	JRST	(R12)	; RETURN
; STORAGE
SAVESS:	BLOCK	1
	PRGEND
	SUBTTL	P$$ITM ITEM(ARRAY/TABLE,INDICES) PRIMITIVE FUNCTION

	ENTRY	P$$ITM
	EXTERN	S$$PGL,S$$EQA,S$$ARF,S$$TRF
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS NOT EQUALIZED.
	ITEM(ARRAY!TABLE,ARGS) IS EQUIVALENT TO ARRAY!TABLE<ARGS>. EX-
PECTS ACTUAL NUMBER OF ARGS IN R2, AND NRETURNS WITH NAME IN R1/

P$$ITM:	SOSGE	R0,R2	; GET ACTUAL # OF ARGS -1
	CFERR	3,S$$PGL	; ERROR IF < 0
	MOVEI	R4,(ES)	; PTR TO LAST ARG
	SUBI	R4,(R2)	; PTR TO FIRST ARG
	MOVE	R8,(R4)	; GET FIRST ARG
	HLLZ	R3,R8	; GET DESCR TYPE
	ROT	R3,4
	MOVEI	R5,-5(R3)	; IS IT ARRAY OR TABLE?
	JUMPE	R5,.+2	; YES, SKIP
	CFERR	3,S$$PGL	; NO, ERROR
	JUMPGE	R3,.+3	; SKIP IF ARRAY
	AOS	R3,R5	; OR IF TABLE, SET EXPECTED ARGS=1,
	JRST	.+3	; TYPE INDEX=1, AND SKIP
	ROT	R3,9	; GET # OF ARRAY DIMENSIONS
	ANDI	R3,^O377	; AS EXPECTED # OF ARGS
	CAILE	R2,(R3)	; ARE THERE MORE THAN EXPECTED?
	CFERR	3,S$$PGL	; YES, ERROR
	JSP	R4,S$$EQA	; NO, EQUALIZE IF LESS
	HRLI	R12,ATBRET	; SAVE RETURN LINK FOR ITEM
	MOVS	R12,R12	; AND SIMULATE JSP
	JUMPE	R5,S$$ARF	; ARRAY REFERENCE IF INDEX=0
	JRST	S$$TRF	; TABLE REFERENCE OTHERWISE
ATBRET:	HRLZI	R1,1B19	; FORM NAME DESCR
	ADDI	R1,(R2)	; USING RETURNED POINTER
	SUB	ES,[XWD 1,1]	; POP ARRAY/TABLE DESCR OFF ES
	MOVS	R12,R12	; RESTORE RETURN LINK
	JRST	1(R12)	; NRETURN
	PRGEND
	SUBTTL	P$$DAT DATA(PROT) PRIMITIVE FUNCTION

	ENTRY	P$$DAT
	EXTERN	S$$PGL,S$$GFP,S$$GNS,S$$LKS,S$$EQS,S$$OUC,S$$OUT,S$$GRS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
	DATA() PRIMITIVE
CALL:	FUNCTION CALL, WITH ARGUMENTS INITIALIZED TO 1. DEFINES DATA-
TYPES AND FIELDS, AND DEFINES FUNCTIONS CORRESPONDING TO THEM
	DATATYPE CREATION [VIA FUNCTION CALL]
CALL:	JSP	R11,CREDAT	; WHERE DATNO IS THE DATATYPE #, AND
	BYTE	(2)1(2)3(14)DATNO(18)TYPSTR	; TYPSTR IS THE LOCATION
OF THE STRING DESCRIPTOR FOR THE DATATYPE. EXPECTS THE ACTUAL FIELD VAL-
UES ON ES, THEIR NUMBER IN R3, AND RETURNS A DESCRIPTOR FOR THE DATATYPE,
FILLED BY POPPING THE ACTUAL FIELD VALUES OFF ES
	FIELD REFERENCE [VIA FUNCTION CALL]
CALL:	JSP	R11,FLDREF	; WHERE NDAT IS THE # OF DATATYPES WITH
	XWD	-NDAT,DATBLK+1	; THIS FIELD, AND DATBLK IS THE DATATYPE
LIST BLOCK. EXPECTS THE DATATYPE DESCR ON ES, AND NRETURNS THE NAME DESCR
OF THE FIELD OF THE GIVEN DATATYPE/

; CREATE DATATYPE
CREDAT:	MOVEI	R0,1(R3)	; GET # OF FIELDS + 1
	MOVEI	R7,(R3)	; SAVE # OF FIELDS
	JSP	R6,S$$GRS	; GET BLOCK FOR NEW DATATYPE
	MOVE	R2,(R11)	; GET DATNO, STRING POINTER
	HLL	R1,R2	; MAKE LH OF DESCR DATNO
	HRRM	R2,(R1)	; SAVE PTR TO DATATYPE STRING
	ADDI	R7,(R1)	; PTR TO LAST FIELD
	SOJA	R0,.+1	; NUMBER OF FIELDS
	POP	ES,(R7)	; POP VALUE INTO FIELD LOC
	SUBI	R7,1	; DECREMENT FIELD PTR
	SOJG	R0,.-2	; LOOP FOR EACH FIELD
	JRST	(R12)	; RETURN

; FIELD REFERENCE
FLDREF:	MOVE	R11,(R11)	; GET -NDAT,DATPTR
	POP	ES,R1	; GET DATATYPE DESCR
	HLLZ	R2,R1	; GET DATNO, 0
	HRLI	R1,1B19	; FORM NAME DESCR
	HRR	R2,(R11)	; GET CURRENT FIELD POS
	CAMN	R2,(R11)	; ARE DATNOS EQUAL?
	JRST	FOUND	; YES
	AOBJN	R11,.-3	; NO, LOOP
	CFERR	1,S$$PGL	; OR ERROR, ILLEGAL DATATYPE
FOUND:	ADDI	R1,(R2)	; ADD FIELD POS TO DATATYPE PTR
	JRST	1(R12)	; NRETURN
; DATA() PRIMITIVE
P$$DAT:	SETO	R0,	; NO LOCAL VARS EXPECTED
	JSP	R11,S$$GFP	; PARSE PROTOTYPE
	CFERR	6,S$$PGL	; BAD PROTOTYPE
	CAIG	R10,1	; > 0 FIELDS?
	CFERR	6,S$$PGL	; NO, BAD PROTOTYPE
	HRLI	R10,(R10)	; FORM NFLD+1,NFLD+1
	MOVN	R11,R10	; -(NFLD+1,NFLD+1)
	SUB	R11,[XWD 1,1]	; -(NFLD+2,NFLD+2)
	ADD	R11,ES	; ES BEFORE PROTOTYPE
	MOVEM	R11,SAVEES	; SAVE IT
	HRLZI	R0,7B22	; DATATYPE SYMBOL
	MOVE	R1,2(R11)	; LOOKUP
	JSP	R8,S$$LKS
	SOJA	R2,OLDDAT	; ALREADY DEFINED
	SOS	R9,R2	; NEW, POINT TO STRING DESCR
	MOVEI	R0,3	; GET 3-WORD DATA DEF BLOCK
	JSP	R6,S$$GNS
	HRRZM	R1,1(R9)	; SAVE POINTER TO DDFBLK IN ENTRY
	MOVEI	R2,-1(R10)	; GET NFLD
	LSH	R2,5	; GORM LH OF FUNCTION WORD
	IORI	R2,^B10011B23	; REQUIRING NFLD ARGS
	HRRM	R2,(R1)	; SAVE IN DEF BLOCK
	MOVE	R2,[JSP R11,CREDAT]	; CREATE DATATYPE CALL
	MOVEM	R2,1(R1)	; SAVE IN DEF BLOCK
	AOS	R2,TYPNUM	; GET NEW TYPE NUMBER
	HRLI	R2,(R9)	; AND POINTER TO DATATYPE STRING DESCR
	MOVSM	R2,2(R1)	; SAVE IN DEF BLOCK
	HRRM	R9,GETTPS	; SAVE ENTRY POINTER
	MOVEI	R0,(R10)	;  GET BLOCK FOR FIELD LIST
	JSP	R6,S$$GNS
	SUBI	R0,1	; SAVE NFLD IN FLDBLK
	HRRM	R0,(R1)
	HRLM	R1,1(R9)	; SAVE FLDBLK POINTER IN ENTRY
	MOVNI	R10,-1(R10)	; GET -NFLD,1 , INITIAL FILED POS
	HRLZI	R10,(R10)
	ADDI	R10,1
	ADDI	R11,3	; PTR TO FIRST FIELD STRING ON ES
	HRLI	R11,1(R1)	; POINTER TO FIRST FIELD LOC IN FLDBLK
	HRLZ	R9,TYPNUM	; GET DATATYPE NUMBER IN LH
; LOOKUP FIELDS
FDFLOP:	HRLZI	R0,8B22	; FIELD SYMBOL LOOKUP
	MOVE	R1,(R11)
	JSP	R8,S$$LKS
	JRST	OLDFLD	; FIELD ALREADY DEFINED
	SOS	R7,R2	; NEW ENTRY, PTR TO STRING DESCR LOC
	MOVEI	R0,3	; GET BLOCK FOR FIELD DEF
	JSP	R6,S$$GNS
	HRLI	R1,1	; ONLY 1 DATATYPE WITH THIS FIELD SO FAR
	MOVEM	R1,1(R7)	; SAVE IN ENTRY
	MOVEI	R2,^B010010000000100000	; LH OF FUNCTION WORD
	HRRM	R2,(R1)	; FOR FIELD REF CALL, SAVE IN DEF BLOCK
	MOVE	R2,[JSP R11,FLDREF]	; FIELD REFERENCE CALL
	MOVEM	R2,1(R1)	; SAVE IN DEF BLOCK
	HRLI	R7,1(R1)	; PTR TO FLD REF CALL
	MOVEI	R0,2	; GET BLOCK FOR DATATYPE LIST (ONLY 1 DATATYPE)
	JSP	R6,S$$GNS
	HRROI	R2,1(R1)	; FORM XWD -1,FIRST DATATYPE ENTRY
	HLRZ	R6,R7	; GET PTR TO FIELD REF CALL
	MOVEM	R2,1(R6)	; SAVE DATATYPE LIST WORD IN CALLING SEQ
FDFBOT:	HLRZ	R6,R11	; GET PTR TO ENTRY IN FIELD LIST BLOCK
	MOVEM	R7,(R6)	; SAVE DEFPTR,STRING PTR
	HRRI	R9,(R10)	; FORM XWD DATNO,FIELD POS
	MOVEM	R9,1(R1)	; SAVE IN DATATYPE LIST BLOCK
	AOBJP	R11,.+1	; BUMP POINTERS TO FIELD LIST BLOCK AND ES
	AOBJN	R10,FDFLOP	; LOOP FOR EACH FIELD POSITION
; DEFINE FUNCTIONS CORRESPONDING TO DATATYPE AND FIELD NAMES
DEFFUN:	MOVE	ES,SAVEES	; RESTORE ES TO STATE BEFORE 'DATA' CALL
GETTPS:	MOVEI	R11,.-.	; RESTORE PTR TO DATATYPE ENTRY
	HRLZI	R0,5B22	; DO LOCAL/GLOBAL FUNCTION LOOKUP
	MOVE	R1,(R11)	; OF DATATYPE SYMBOL
	JSP	R8,S$$LKS
	JFCL		; NOOP IF OLD ENTRY
	MOVE	R11,1(R11)	; GET FLDBLK,DDFBLK
	MOVEI	R10,1(R11)	; GET PTR TO CREATE DATATYPE CALL
	HRL	R10,(R11)	; LH OF FUNCTION DEFINITION
	MOVEM	R10,(R2)	; SAVE IN FUNCTION WORD OF ENTRY
	HLRZ	R11,R11	; PTR TO FIELD LIST BLOCK
	MOVN	R10,(R11)	; GET -NFLD
	HRLI	R10,1(R11)	; GET PTR TO FIRST FIELD ENTRY
	MOVS	R11,R10	; SET UP FOR AOBJ
DEFLOP:	MOVE	R10,(R11)	; GET FDFPTR,FIELD STRING PTR
	MOVE	R1,(R10)	; GET FIELD SYMBOL STRING DESCR
	HRLZI	R0,5B22	; DO LOCAL/GLOBAL FUNCTION LOOKUP
	JSP	R8,S$$LKS
	JFCL		; NOOP IF OLD ENTRY
	HLRZ	R10,R10	; PTR TO FIELD REF CALL
	HRL	R10,-1(R10)	; LH OF FUNCTION DEF
	MOVEM	R10,(R2)	; SAVE IN FUNCTION WORD OF ENTRY
	AOBJN	R11,DEFLOP	; LOOP FOR EACH FIELD
	SETZ	R1,	; RETURN NULL
	JRST	(R12)
; DATATYPE ALREADY DEFINED
OLDDAT:	HRRM	R2,GETTPS	; SAVE DATATYPE ENTRY POINTER
	HLRZ	R9,1(R2)	; GET FIELD LIST BLOCK POINTER
	HRRZ	R8,(R9)	; GET NFLD OF DEFINITION
	CAIE	R8,-1(R10)	; SAME AS CURRENT # OF FIELDS?
	JRST	MULDEF	; NO, ERROR, MULTIPLY-DEFINED DATATYPE
	MOVNI	R10,(R10)	; GET -NFLD-1
	HRLI	R9,(R10)	; FORM XWD -NFLD,PTR TO FIRST ENT IN FLDBLK
	ADD	R9,[XWD 1,1]
CHKLOP:	MOVE	R8,(R9)	; GET FIELD SYMBOL STRING DESCR
	MOVE	R1,(R8)
	MOVE	R2,3(R11)	; GET FIELD SYMBOL OFF ES
	JSP	R5,S$$EQS	; ARE THEY THE SAME?
	AOJA	R11,.+2	; YES, GO ON TO NEXT SYMBOL
	JRST	MULDEF	; NO, MULTIPLY-DEFINED DATATYPE
	AOBJN	R9,CHKLOP	; LOOP
	JRST	DEFFUN	; OR RETURN TO DEFINE FUNCTIONS
MULDEF:	MOVE	R1,MLDERM	; GET ERROR MESSAGE DESCR
	MOVEM	R1,@S$$OUC	; OUTPUT
	MOVE	R1,SAVEES	; GET DATATYPE SYMBOL DESCR
	MOVE	R1,2(R1)
	MOVEM	R1,@S$$OUT	; OUPUT
	UFERR	1,S$$PGL	; ERROR

; FIELD ALREADY DEFINED
OLDFLD:	SOS	R7,R2	; PTR TO STRING DESCR
	MOVE	R8,1(R2)	; XWD NDAT,PTR TO FDFBLK
	HRLI	R7,1(R8)	; PTR TO FIELD REF CALL
	HLRZ	R0,R8	; NUMBER OF DATATYPES WITH THIS FIELD
	ADDI	R0,2	; ADD 1 MORE (+1 EXTRA WORD FOR BLOCK HEADER)
	JSP	R6,S$$GNS	; GET NEW DATATYPE LIST BLOCK
	MOVN	R2,R0	; -NDAT-2
	HRLI	R1,(R2)
	AOBJP	R1,.+1	; FORM XWD -NDAT(NEW),PTR TO FIRST DAT ENTRY
	MOVE	R4,2(R8)	; GET OLD DAT LIST PTR
	MOVEM	R1,2(R8)	; SAVE NEW DAT LIST PTR
	MOVE	R3,-1(R4)	; CHANGE OLD BLOCK TO RETURNABLE
	TLC	R3,3B19
	MOVEM	R3,-1(R4)
	MOVEI	R2,(R1)	; PTR TO NEW BLOCK
	HRLI	R2,(R4)	; PTR TO OLD BLOCK
	MOVEI	R1,-3(R1)	; PTR TO NEXT TO LAST ENTRY
	ADD	R1,R0	; OF NEW BLOCK
	BLT	R2,(R1)	; MOVE OLD ENTRIES INTO NEW
	JRST	FDFBOT	; GO PUT NEW ENTRY IN
; STORAGE
SAVEES:	BLOCK	1
TYPNUM:	7B21
MLDERM:	POINT	7,.+1,35
	BYTE	(2)2(16)8(18)32
	ASCII/>>>> MULTIPLY-DEFINED DATATYPE: /
	PRGEND
	SUBTTL	P$$APL APPLY(FNAME,ARGS) PRIMITIVE FUNCTION

	ENTRY	P$$APL
	EXTERN	S$$PGL,S$$LKF,S$$EQA
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS NOT EQUALIZED.
	APPLY(FNAME,ARGS) IS EQUIVALENT TO FNAME(ARGS). EXPECTS ACTUAL
NUMBER OF ARGS IN R2/

P$$APL:	SOSGE	R11,R2	; GET ACTUAL #-1, SAVE
	CFERR	5,S$$PGL	; ERROR IF ACTUAL #<1
	MOVEI	R4,(ES)	; PTR TO LAST ARG
	SUBI	R4,(R2)	; PTR TO FIRST ARG
	MOVE	R1,(R4)	; GET FIRST ARG
	JUMPE	R2,SKPARG	; SKIP IF ONLY ONE ARG
	HRLI	R4,1(R4)	; PTR TO SECOND ARG
	BLT	R4,-1(ES)	; MOVE ARGS DOWN 1 PLACE ON ES
SKPARG:	SUB	ES,[XWD 1,1]	; POP ES
	JSP	R10,S$$LKF	; DO FUNCTION LOOKUP
	EXCH	R2,R11	; EXCHANGE NEW ACTUAL # OF ARGS,
	MOVE	R11,(R11)	; FUNCTION WORD
	LDB	R3,[POINT 5,R11,12]	; GET 'A' FLAG, REQUIRED ARGS
	TRNN	R3,^O20	; SHOULD ARGS BE EQUALIZED?
	JSP	R4,S$$EQA	; YES
	JRST	(R11)	; GO TO NEW FUNCTION
	PRGEND
	SUBTTL	P$$DEF DEFINE(PROT,LABL) PRIMITIVE FUNCTION

	ENTRY	P$$DEF
	EXTERN	S$$MFB,S$$GNS,S$$PBP,S$$CPF
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 2. DEFINES A PRO-
GRAMMER FUNCTION, DELETING ANY PREVIOUS DEFINITION THAT FUNCTION NAME
MAY HAVE HAD, AND RETURNS NULL/

P$$DEF:	MOVE	R1,(ES)	; SWITCH PROTOTYPE AND LABEL DESCR
	EXCH	R1,-1(ES)
	MOVEM	R1,(ES)
	MOVEI	R0,1	; MAKE FUNCTION BLOCK, LOCAL VARS POSSIBLE
	JSP	R11,S$$MFB	; AND FUNCTION WORD REQUIRED
	MOVEI	R0,4	; GET FUNCTION DEFINITION BLOCK
	JSP	R6,S$$GNS
	MOVE	R2,S$$PBP	; SAVE PARBLK+1 IN BLOCK
	HRRM	R2,(R1)
	MOVE	R2,[JSP R11,S$$CPF]	; SAVE 'CALL FUNCTION' IN BLOCK
	MOVEM	R2,1(R1)
	MOVEM	R9,2(R1)	; SAVE PARAMETERS IN BLOCK
	MOVEM	R10,3(R1)
	HLRE	R10,R10	; COMPUTE # OF ARGS
	MOVN	R10,R10
	SUBI	R10,(R9)
	LSH	R10,5	; FORM FUNCTION WORD
	ADDI	R10,^B10001B23
	HRLI	R1,(R10)
	ADDI	R1,1
	MOVEM	R1,(R8)	; SAVE IN FUNCTION WORD OF ENTRY
	SETZ	R1,	; RETURN NULL
	JRST	(R12)
	PRGEND
	SUBTTL	P$$COL COLLECT(N) PRIMITIVE FUNCTION

	ENTRY	P$$COL
	EXTERN	S$$MKI,S$$PGL,S$$GCL,S$$FLR
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. FORCES A GARBAGE
COLLECTION, AND RETURNS THE TOTAL AMOUNT OF WORDS AVAILABLE, OR FAILS
IF LARGEST BLOCK AVAILABLE IS LESS THAN THE ARGUMENT/

P$$COL:	POP	ES,R1	; GET ARG
	JSP	R7,S$$MKI	; MUST BE INTEGER
	CFERR	10,S$$PGL	; OR ERROR
	MOVE	R7,R1	; SAVE ARG
	SETZ	R0,	; SET SIZE=0
	JSP	R6,S$$GCL	; GO FORCE COLLECTION
	CAMGE	R2,R7	; BIG ENOUGH BLOCK FOUND?
	JRST	S$$FLR	; NO, FAIL
	TLO	R1,1B18	; YES, FORM ITEGER DESCR
	JRST	(R12)	; AND RETURN
	PRGEND
	SUBTTL	P$$XTM EXTIME(PROGNAM) PRIMITIVE FUNCTION

	ENTRY	P$$XTM
	EXTERN	S$$TMO,S$$MKS,S$$PRL,S$$FLR,S$$PGL,S$$EQS
	RADIX	10
	SEARCH	S$$NDF

	COMMENT/
CALL:	FUNCTION CALL, WITH ARGUMENTS EQUALIZED TO 1. PRINTS OUT TIMING
STATISTICS FOR THE PROGRAM WHOSE NAME IS GIVEN AS THE ARGUMENT, AND RE-
TURNS NULL. IT FAILS IF PROGRAM IS NOT BEING TIMED/

P$$XTM:	POP	ES,R1	; GET PROGRAM NAME
	SETO	R0,	; MUST BE STRING
	JSP	R7,S$$MKS
	CFERR	10,S$$PGL	; ERROR IF NOT
	HLRZ	R6,S$$PRL	; GET FIRST PROGRAM PARBLK POINTER
	MOVE	R8,R1	; SAVE STRING DESCR
XTMLOP:	HRRZ	R5,1(R6)	; GET TIMING BLOCK POINTER
	JUMPE	R5,XTMLP1	; SKIP OVER IF NO TIMING
	MOVE	R2,-1(R6)	; GET PROGRAM NAME
	JSP	R5,S$$EQS	; COMPARE TO NAME BEING SOUGHT
	JRST	XTMTIM	; EQUAL, FOUND
	MOVE	R1,R8	; UNEQUAL, RESTORE DESCR
XTMLP1:	HRRZ	R6,(R6)	; GET NEXT PARBLK POINTER
	JUMPN	R6,XTMLOP	; LOOP IF NONZERO
	JRST	S$$FLR	; OR FAIL
XTMTIM:	HRRZ	R5,1(R6)	; GET TIMING BLOCK POINTER
	JSP	R7,S$$TMO	; OUTPUT TIMING STATISTICS
	SETZ	R1,	; RETURN NULL
	JRST	(R12)
	END