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