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 MOVEI R0,^O620110 ; START UP AGAIN, 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