File SYSFUN.MA (MACREL macro assembler source file)

Directory of image this file is from
This file as a plain text file

	TITLE	SYSFUN - PPL SYSTEM FUNCTIONS  /EAT/ 17-SEP-72   

	HISEG

	SEARCH	PPL		;ACCESS PARAMETERS AND DEFINITIONS

;STANDARD ACCUMULATOR ASSIGNMENTS FOR FUNCTION CALLING AND EVALUATION.
;THESE AC'S ARE NOT SAVED AND RESTORED **********

	B==	AC14	;HOLDS BASE ADDR OF A DZ BLOCK (FOR GET,SET)
	L==	AC13	;HOLDS CURRENT LEXEME (FOR LGET,LSET)
	T==	AC12	;HOLDS LEXEME OR DATA TYPE; GENERAL TEMP ALSO
	CAR==	AC11	;HOLDS PZ ADDR OF CURRENT ACTIVATION RECORD
	ARGP==	AC10	;HOLDS XWD B,LEXEME POINTER

;IN ADDITION, THE CONVERSION ROUTINES CLOBBER AC1-4, AND THE
;FUNCTION EVALUATION ROUTINES MAY DO LIKEWISE.  FOR REASONS OF SPEED
;NO AC'S ARE SAVED OR RESTORED AT THIS LEVEL.

;NOTES ON SYSTEM FNS:
;THE WORD DISPATCHED TO IN THE IDT MUST CONTAIN, IN ITS RH, THE NUMBER
;OF PARAMETERS THIS FUNCTION EXPECTS.  IF A SYSTEM FUNCTION ACCEPTS
;A VARIABLE NUMBER OF ARGUMENTS, THE RH OF THIS WORD SHOULD BE -1.
;ROUTINES TESTING THIS WORD SHOULD DO SO IN THE FORM HRRE AC,(LOC).
;THE USE OF THE LH IS PRESENTLY UNSPECIFIED.
;SYSTEM FUNCTIONS MAY ASSUME THEY ARE CALLED WITH THE CORRECT NUMBER
;OF ARGUMENTS, BUT MUST CHECK FOR CORRECT TYPES.

WRNGNB:	SFNERR	MSG(WNARG)	;WRONG NUMBER OF ARGUMENTS

SUBTTL ARGUMENT PREPARATION ROUTINES ;ARGUMENT PREPARATION ROUTINE. PROCESS AS AN ARGUMENT THE LEXEME ;RELATIVELY ADDRESSED BY ARGP IN THE CAR. COERCE ARGUMENTS AND ;CALL FUNCTIONS WHERE NECESSARY TO YIELD A VALUE. ;RETURNS AS FOLLOWS: ; (NON-SKIP) NON-ATOMIC. R_PZ ADDRESS OF REFERENCED DATA ITEM. ; T_LH OF PZ WORD (MINUS GCBIT,CPYBIT) ; (SKIP) ATOMIC. (R,R2) _ ATOMIC VALUE ; T_U.TYPE OF VALUE / 2 ;ARGP MUST HAVE B IN ITS INDEX FIELD ON CALL. ;B IS RETURNED WITH THE ABSOLUTE BASE ADDRESS OF THE CAR. ARGPRP: SAVE <L> ;PROTECT AN AC HRRZ B,(CAR) ;GET BASE ADDR OF THE CURRENT AR MOVE L,@ARGP ;L_LEXEME UNDER CONSIDERATION BRLTYP: LGET T,LTYPF ;GET LEXEME TYPE FIELD XCT ARGTB1(T) ;BRANCH ON LEXEME TYPE ;DISPATCH TABLE FOR BRANCHING ON LEXEME TYPE ARGTB1: ILLTYPE ;OP - ERROR JRST GETHDW ;PROCID - GO GET LEXEME FROM HEADER OF AR JRST GETHDW ;FORML JRST GETHDW ;LCL JRST BRSTE ;ID - GO BRANCH ON STE TYPE JRST LXCONS ;CONST - RETRIEVE DATA JRST LXRELO ;RELOC - DATA IS IN RH OF LEXEME ILLTYPE ;DEMAND - SYSTEM ERROR JRST LXSELX ;SELX - GO LOOK AT LVAL BLOCK JRST BRSTE ;$ID - HANDLE LIKE NORMAL ID JRST ARGDMR ;DUMREF - REFERENCE TO A LOCAL IN ANOTHER AR ;ARG IS A DUMMY REFERENCE ARGDMR: CALL GETDMR ;FETCH REFERENCED LEXEME JUMPN L,BRLTYP ;BRANCH ON LEXEME TYPE AGAIN JRST UNASGV ;ERROR - UNASSIGNED VARIABLE ;ROUTINE TO FETCH THE VALUE OF A DUMMY REFERENCE ;ENTER WITH L CONTAINING THE DUMREF LEXEME. RESULT LEXEME RETURNED IN L. GETDMR: FETCH (R,L,FCHNF) ;FETCH LOCAL PARAMETER NUMBER FROM DUMREF HRRZ L,(L) ;FETCH DZADR OF REFERENCED AR ADDI L,ARBASE(R) ;COMPUTE ABS ADR OF LOCAL VARIABLE MOVE L,(L) ;FETCH REFERENCED LOCAL LEXEME RETURN
;PROCID, LCL, FORML: GET LEXEME FROM AR HEADER ZONE GETHDW: ADDI L,ARBASE(B) ;CMPUTE ADDR OF CORRECT ENTRY MOVE L,(L) ;GET THE LEXEME JRST BRLTYP ;GO BRANCH ON ITS TYPE ;ID: GO SEE WHAT KIND BRSTE: ADD L,@IDTP ;TURN INTERNAL NAME INTO ABS ADDR OF IDT HLRZ R,(L) ;GET LH OF ENTRY HRRZ L,(L) ;GET RH OF ENTRY XCT ARGTB2(R) ;BRANCH ON STE TYPE ;BRANCH TABLE FOR SYMBOL TABLE TYPES UNASGV: ARGTB2: SFNERR MSG(UNASG) ;UNASSIGNED IDENTIFIER JRST LXCONS ;VAR - GO USE ITS VALUE ILLTYPE ;PARAMETERLESS FN (SYSTEM ERROR) ILLTYP ;DDEF - ERROR ILLTYP ;SEL - ERROR JRST ARGCEV ;CEV - GO EXTRACT NAMED VALUE ILLTYP ;NAME OF ATOM - ERROR (E.G. "3+INT") ILLTYPE ;SYS FN - SYSTEM ERROR ILLTYPE ;RESERVED WORD ;STE IS CEV - GO EXTRACT VALUE FROM CVAL BLOCK ARGCEV: HRRZ L,(L) ;GET ABS ADDR OF CVAL BLOCK HRRZ L,1(L) ;GET PZ ADDR OF REFERENCED DATA ;CONST - L CONTAINS PZ ADDR OF VALUE BLOCK LXCONS: JUMPE L,UNASGV ;ERROR IF ZERO [= UNDEFINED VALUE] MOVE L,(L) ;GET PZ WORD LGET T,BLTF ;T_BLOCK TYPE CAILE T,LSTATM ;IS IT AN ATOM? JRST NOTATM ;NO, RETURN PZ ADDR OF BLOCK MOVE R,1(L) ;YES, GET FIRST WORD OF DATA BLOCK CAIN T,U.DBL ;ALSO SECOND IF DOUBLE MOVE R2,2(L) ARGPX0: LSH T,-1 ;HALVE TYPE TO COMPACT TYPE SPACE ARGPRX: AOSA -1(P) ;SKIP RETURN NOTATM: HRRZ R,(L) ;COME HERE IF BLOCK NOT AN ATOM PRPRET: RESTORE <L> ;RESTORE CLOBBERED AC JRST BPOPJ ;RESTORE B AS CAR DZADR AND RETURN
;RELOC - TAKE RH OF LEXEME AS AN INT LXRELO: HRRZ R,L ;GET RELOC LINE NUMBER MOVEI T,U.INT/2 ;INDICATE IT IS AN INT JRST ARGPRX ;EXIT ;SELX - GO EXTRACT A FIELD FROM THE REFERENCED DATA LXSELX: MOVE B,(L) ;GET LVALUE PZ WORD CALL SELECT ;PERFORM SELECTION SKIPA L,R ;GOT A DATA BLOCK. PRETEND I HAD CONST JRST ARGPX0 ;GOT UNPACKED ATOMIC DATA IN (R,R2). JRST LXCONS
;HERE FOR WARNING MESSAGES (I.E. OVERFLOW) ;PRINT FN NAME AND LINE NUMBER, THEN RESUME XWARN: SAVE <AC1,B,R2,R> MOVE B,JOBUUO ;SAVE ADR OF MESSAGE TTOS [SIXBIT/WARNING - IN SYSTEM FN !/] MOVE AC1,CFNAM ;PRINT NAME OF CURRENT SYSTEM FN CALL IDPR TTOS [SIXBIT/: !/] TTOS (B) ;PRINT MESSAGE HRRZ B,(CAR) ;GET DZ ADR OF CAR GET AC1,LPF ;FETCH LINE PTR FIELD HRRZ B,(AC1) ;FETCH DZADR OF LINE BLOCK GET AC1,NF ;FETCH LINE NO. FIELD OF BLOCK JUMPL AC1,XWARNX ;TYPE NOTHING ELSE IF DIRECT STMT HRRZ B,(CAR) ;RESTORE DZADR OF CAR TTOS [SIXBIT/OCCURRED AT !/] CALL PWHERE ;PRINT USER FUNCTION NAME AND LINE NO. TTOS [SIXBIT/#/] XWARNX: RESTORE <R,R2,B> JRST X1 ;GO RESTORE AC1 AND EXIT UUO LEVEL
;SELECT ;ROUTINE TO PERFORM A SELECTION, USING THE REF OR LVALUE BLOCK ;WHOSE ABSOLUTE ADDRESS IS IN B. THE ELEMENT TYPE IS RETURNED IN T, ;AND THE SELECTED VALUE IN (R,R2). B IS CLOBBERED. ;RETURNS: (1) R CONTAINS PZ POINTER TO DATA BLOCK. ; (2) (R,R2) CONTAINS ATOMIC VALUE OF DATUM SELECT: GET T,ELTF ;GET ELEMENT TYPE GET R,DISPF ;GET DISPLACEMENT FIELD HRLI R,B ;PREPARE TO INDEX BY BASE ADDR LSHC R,-^D24 ;SHIFT I,X,Y INTO LH OF R2 GET R,LENF ;GET LENGTH (BITS) CAIE R,^D18 ;A PZ ADDR? AOS (P) ;NO, SIGNAL ATOMIC DATA BEING RETURNED CAILE R,^D36 ;IF OVER 1 WORD CAN ONLY BE A DBL JRST SELDBL LSHC R,-^D6 ;PACK ON SIZE FIELD GET R,BEGF ;GET POSITION OF FIRST BIT MOVNI R,-^D36(R) ;CONVERT TO BYTE-POINTER POSITION FIELD LSHC R,-^D6 ;FINISH BYTE POINTER GET B,PZAF ;GET PZ ADDR OF REFERENCED BLOCK JUMPE B,ZPERR ;SYS ERROR IF PTR IS ZERO MOVE B,(B) ;GET DZ ADDRESS ILDB R,R2 ;GET THE ADDRESSED BYTE RETURN ZPERR: ERROR MSG(TRCZP) ;TRIED TO TRACE A ZERO POINTER ;A SIZE >36 WAS SPECIFIED. CAN ONLY BE DBL. SELDBL: GET B,PZAF ;GET PZ ADDRESS OF REFERENCED BLOCK JUMPE B,ZPERR ;SYS ERROR IF PTR IS ZERO MOVE B,(B) ;GET DZ ADDRESS LSH R2,-^D12 ;POSITION UNFINISHED BYTE POINTER TLO R2,4400 ;SET SIZE=36 LDB R,R2 ;GET HIGH ORDER ILDB R2,R2 ;GET LOW ORDER RETURN
;BRETRN ;ROUTINE TO SET TYPE=BOOL AND RETURN LEXEME BRETRN: MOVEI T,U.BOOL/2 ;SET TYPE ;SRETRN ;ROUTINE TO MAKE A BLOCK OUT OF (R,R2) AND TYPE T, AND RETURN A LEXEME ;IN R POINTING TO IT. SRETRN: SAVE <AC1,AC2,AC3> MOVE AC3,T ;GET TYPE/2 LSH AC3,1 ;CONVERT TO CONVENTIONAL USERTYPE ADDI AC3,1 MOVE AC1,R ;GET VALUE TO BE STORED MOVE AC2,R2 CALL ATOM ;STORE IT AND RETURN PZ POINTER HRLI R,(LXM(STAK,CONST)) ;RETURN AS A CONST JRST X321 ;RESTORE AC'S 3,2,1 AND RETURN
;ROUTINE TO CHECK FOR AND RETURN TWO ATOMIC ARGUMENTS ;LH VALUE RETURNED IN (AC1,AC2), TYPE IN AC3 ;RH VALUE RETURNED IN (R,R2), TYPE IN T GRAB2: CALL ARGPRP ; COERCE THE LH ARG ILLTYPE ;NOT ATOMIC, ERROR GRAB2A: MOVE AC1,R ;OK. SAVE RESULTS MOVE AC2,R2 MOVE AC3,T CAIN AC3,U.NONE/2 ;NULL? SETZB AC1,AC2 ;YES, SIMPLIFY CONVERSION,SET VALUE TO ZERO ADDI ARGP,1 ;POINT TO RH ARG AND FALL INTO GRAB1 ;ROUTINE TO CHECK FOR AND RETURN A SINGLE ATOMIC ARGUMENT. ;VALUE RETURNED IN (R,R2), TYPE IN T GRAB1: CALL ARGPRP ;COERCE ARG AND SET UP ILLTYPE ;NOT ATOMIC TRZ FF,FOV ;OK, CLEAR FLOATING OVERFLOW FLAG JFCL 17,.+1 ;CLEAR ALL HARDWARE FLAGS CAIN T,U.NONE/2 ;NULL? SETZB R,R2 ;YES, SIMPLIFY CONVERSION,SET VALUE TO ZERO RETURN
;RELPRP - PREPARATION FOR RELATIONAL OPERATIONS RELPRP: CALL GRAB2 ;PICK UP,TEST,COERCE TWO ARGS CAIG AC3,U.DBL/2 ;CHECK THAT BOTH ARE ARITHMETIC CAILE T,U.DBL/2 ILLTYPE ;AT LEAST ONE WAS NOT JRST .+2 ;OK, NOW DO ONLY ARITHMETIC CONVERSION ;BARPRP - PREPARATION FOR BINARY ARITHMETIC ARGUMENTS BARPRP: CALL GRAB2 ;PICK UP AND COERCE TWO ARGS CAIE T,U.NONE/2 ;ERROR IF EITHER ARG IS NULL CAIN AC3,U.NONE/2 NULVOP: SFNERR MSG(NULVO) ;NULL-VALUED OPERAND ARGPR1: MOVE AC4,AC3 ;OK, CONCATENATE TYPE NUMBERS IMULI AC4,U.CHAR/2+1 ;MULTIPLY LH BY NUMBER OF ATOMIC TYPES ADD AC4,T ;ADD ON RH TYPE INDEX MOVE AC4,BATTBL(AC4) ;GET CONVERSION TABLE ENTRY XCT (AC4) ;CONVERT RH; LEAVE RESULT IN R,R2,T EXCH AC1,R ;EXCHANGE RH AND LH OPERANDS EXCH AC2,R2 EXCH AC3,T MOVS AC4,AC4 ;SWAP HALVES OF CONV TABLE ENTRY XCT (AC4) ;CONVERT LH RETURN ;BBLPRP - BINARY BOOLEAN ARGUMENT PREPARATION BBLPRP: CALL GRAB2 ;COERCE AND SET UP TWO ARGS CAIN T,U.BOOL/2 ;SEE IF BOTH ARGS ARE BOOL CAIE AC3,U.BOOL/2 JRST .+2 RETURN ;YES, SETUP IS DONE CAIE T,U.INT/2 ;NO, LH ARG AN INT? JRST BBLPR1 ;NO, TRY RH CAIN AC3,U.BOOL/2 ;YES, RH A BOOL? MOVN AC1,AC1 ;YES, MAKE TRUE BE ALL ONES CAIE AC3,U.REAL/2 ;SET RESULT TYPE TO REAL OR DBL IF NECESSARY CAIN AC3,U.DBL/2 MOVE T,AC3 RETURN BBLPR1: CAIE AC3,U.INT/2 ;LH WAS NOT INT, TRY RH ILLTYPE ;BAD COMBINATION CAIN T,U.BOOL/2 ;OK, LH A BOOL? MOVN R,R ;YES, MAKE TRUE BE ALL 1S CAIE T,U.CHAR/2 ;SET RESULT TYPE TO INT FOR CHAR OR BOOL CAIN T,U.BOOL/2 MOVEI T,U.INT/2 RETURN
SUBTTL ARGUMENT CONVERSION ;BINARY ARITHMETIC CONVERSION TABLE ;THE H(A,B) MACRO SPECIFIES TYPE CONVERSION TO BE PERFORMED. ;A IS THE INSTRUCTION FOR CONVERTING THE LEFT OPERAND; B FOR RIGHT. DEFINE H(A,B) < XWD [A],[B] > BATTBL: H JFCL ,JFCL ;INT,INT H CALL INTRL1 ,JFCL ;INT,REAL --> REAL,REAL H CALL INTDB1 ,JFCL ;INT,DBL --> DBL,DBL H JFCL ,<MOVEI T,U.INT/2>;INT,BOOL --> INT,INT H JFCL ,<MOVEI T,U.INT/2>;INT,CHAR --> INT,INT H JFCL ,CALL INTRL1 ;REAL,INT --> REAL,REAL H JFCL ,JFCL ;REAL,REAL H CALL RLDB1 ,JFCL ;REAL,DBL --> DBL,DBL H ILLTYP ,ILLTYP ;REAL,BOOL --> ERROR H ILLTYP ,ILLTYP ;REAL,CHAR --> ERROR H JFCL ,CALL INTDB1 ;DBL,INT --> DBL,DBL H JFCL ,CALL RLDB1 ;DBL,REAL --> DBL,DBL H JFCL ,JFCL ;DBL,DBL H ILLTYP ,ILLTYP ;DBL,BOOL --> ERROR H ILLTYP ,ILLTYP ;DBL,CHAR --> ERROR H <MOVEI T,U.INT/2>,JFCL ;BOOL,INT --> INT,INT H ILLTYP ,ILLTYP ;BOOL,REAL --> ERROR H ILLTYP ,ILLTYP ;BOOL,DBL --> ERROR H <MOVEI T,U.INT/2>,<MOVEI T,U.INT/2>;BOOL,BOOL --> INT,INT H ILLTYP ,ILLTYP ;BOOL,CHAR --> ERROR H <MOVEI T,U.INT/2>,JFCL ;CHAR,INT --> INT,INT H ILLTYP ,ILLTYP ;CHAR,REAL --> ERROR H ILLTYP ,ILLTYP ;CHAR,DBL --> ERROR H ILLTYP ,ILLTYP ;CHAR,BOOL --> ERROR H <MOVEI T,U.INT/2>,<MOVEI T,U.INT/2>;CHAR,CHAR --> INT,INT
;CENTRAL ARITHMETIC CONVERSION ROUTINES ;INTRL1 - INT TO REAL INTRL1: IDIVI R,400000 ;SPLIT INT INTO TWO PARTS TLC R,254000 ;FLOAT HIGH ORDER UNNORMALIZED TLC R2,233000 ;FLOAT LOW ORDER UNNORMALIZED FADR R,R2 ;COMBINE TWO PARTS AND ROUND MOVEI T,U.REAL/2 ;RETURN REAL TYPE TAG RETURN ;INTDB1 - INT TO DOUBLE INTDB1: IDIVI R,400000 ;SPLIT INT INTO TWO PARTS TLC R,254000 ;FLOAT HIGH ORDER UNNORMALIZED TLC R2,233000 ;FLOAT LOW ORDER UNNORMALIZED FADL R,R2 ;COMBINE TWO PARTS INTO DOUBLE PRECISION JRST .+2 ;RLDB1 - REAL TO DOUBLE RLDB1: MOVEI R2,0 ;CLEAR LOW ORDER MOVEI T,U.DBL/2 ;RETURN TYPE TAG RETURN ;DBLRL1 - DOUBLE TO REAL DBLRL1: FADR R,R2 ;ROUND TO SINGLE PRECISION MOVEI T,U.REAL/2 ;RETURN REAL TYPE TAG RETURN ;ARIBL1 - INT,REAL,OR DBL TO BOOL ;NOTE: ZERO-->FALSE, NONZERO-->TRUE ARIBL1: JUMPE R,ARIBLR ;ARITHMETIC ZERO = BOOL FALSE ARIBLT: MOVEI R,1 ;NONZERO-->1 = BOOL TRUE ARIBLR: MOVEI T,U.BOOL/2 ;RETURN BOOL TYPE RETURN ;CHRBL1 - CHAR TO BOOL ; "T"-->TRUE, ALL ELSE --> FALSE CHRBL1: CAIE R,"T" ;CHECK FOR UPPER OR LOWER CASE T CAIN R,"T"+40 JRST ARIBLT ;YES, RETURN TRUE MOVEI R,0 ;ELSE RETURN FALSE JRST ARIBLR
;INTCH1 - INT TO CHAR ;IF 0<=INT<=127, USE INT CHARACTER CODE INTCH1: JUMPL R,.+2 ;CHECK FOR ILLEGAL CHARACTER CODES CAILE R,177 SFNERR MSG(ARGOR) ;ARGUMENT OUT OF RANGE MOVEI T,U.CHAR/2 ;OK, SET PROPER TYPE RETURN ;BLCH1 - BOOL TO CHAR ;TRUE-->"T", FALSE-->"F" BLCH1: JUMPN R,.+2 TROA R,"F" ;BOOL FALSE=0 -->"F" MOVEI R,"T" ;NONZERO -->"T" MOVEI T,U.CHAR/2 RETURN ;FIX - REAL TO INT FIX: MOVEI R2,0 ;CLEAR LOW WORD, FALL INTO DFIX ;DFIX - DBL TO INT DFIX: SAVE <AC1,AC2> SKIPGE AC1,R ;SAVE SIGN. POSITIVE? DFN R,R2 ;NO, MAKE IT SO LDB AC2,[POINT 8,R,8] ;EXTRACT EXPONENT FROM HIGH WORD SUBI AC2,200 ;MAKE 2'S COMPLEMENT EXPONENT JUMPLE AC2,FIXRTZ ;IF EXPONENT <=0, RETURN ZERO CAILE AC2,^D35 ;NUMBER WITHIN RANGE? SFNERR MSG(ARGOR) ;ARGUMENT OUT OF RANGE LSH R2,^D9 ;OK, LEFT-JUSTIFY LOW PART LSHC R,^D9 ;CLEAR EXP IN HIGH PART. BINARY POINT BEFORE BIT 0 LSH R,-^D36(AC2) ;SCALE TO PROPER INTEGER JUMPGE AC1,.+2 ;CHECK SIGN AND NEGATE IF NECESSARY MOVN R,R FIXRT: MOVEI T,U.INT/2 ;SET RESULT TYPE JRST X21 ;RESTORE AC'S 2,1, AND RETURN FIXRTZ: MOVEI R,0 ;COME HERE TO RETURN INTEGER ZERO JRST FIXRT
SUBTTL ARITHMETIC FUNCTIONS SADD: XWD 0,2 ;ADD(A,B) - TAKES 2 ARGS JSP AC7,ARITHX ;CALL ARITHMETIC FUNCTION HANDLER ADD R,AC1 ;INTEGER ADD FADR R,AC1 ;REAL ADD DFAD AC1 ;DBL ADD SSUB: XWD 0,2 ;SUB(A,B) - TAKES 2 ARGS JSP AC7,ARITHX ;CALL ARITHMETIC FUNCTION HANDLER SUB R,AC1 ;INTEGER SUBTRACT FSBR R,AC1 ;REAL SUBTRACT DFSB AC1 ;DBL SUBTRACT SMUL: XWD 0,2 ;MUL(A,B) - TAKES 2 ARGS JSP AC7,ARITHX ;CALL ARITHMETIC FUNCTION HANDLER IMUL R,AC1 ;INTEGER MULTIPLY FMPR R,AC1 ;REAL MULTIPLY DFMP AC1 ;DBL MULTIPLY SIDIV: XWD 0,2 ;IDIV(A,B) - TAKES 2 ARGS JSP AC7,ARITHX ;CALL ARITHMETIC FUNCTION HANDLER IDIV R,AC1 ;INTEGER DIVIDE FDVR R,AC1 ;REAL DIVIDE DFDV AC1 ;DBL DIVIDE SDIV: XWD 0,2 ;DIV(A,B) - TAKES 2 ARGS JSP AC7,ARITHX ;CALL ARITHMETIC FUNCTION HANDLER JRST IDIV1 ;DO INTEGER DIVIDE FDVR R,AC1 ;REAL DIVIDE DFDV AC1 ;DBL DIVIDE IDIV1: MOVE AC2,R ;SAVE ARGUMENT IDIV R,AC1 ;DO INTEGER DIVISION JUMPE R2,OVCK ;IF NO REM, ALL IS WELL MOVE R,AC2 ;GET ORIGINAL ARG BACK CALL INTRL1 ;CONVERT ONE ARGUMENT TO REAL IDIVI AC1,400000 ;CONVERT THE OTHER IN LINE TLC AC1,254000 ;FLOAT HIGH ORDER UNNORMALIZED TLC AC2,233000 ;FLOAT LOW ORDER UNNORMALIZED FADR AC1,AC2 ;COMBINE TWO PARTS AND ROUND FDVR R,AC1 ;DO REAL DIVISION JRST OVCK ;CENTRAL ARITHMETIC FUNCTION HANDLER ARITHX: CALL BARPRP ;PREPARE TWO ARITHMETIC ARGS, CONVERT, ETC. HRLI AC7,T ;INDEX BY RESULT TYPE XCT @AC7 ;PERFORM ARITHMETIC OPERATION ;HERE TO CHECK FOR INTEGER OR FLOATING OVERFLOW AND GIVE WARNINGS IF SO OVCK: TRZE FF,FOV ;WAS FLOATING OVERFLOW DETECTED? WARNING MSG(FLTOV) ;FLOATING OVERFLOW JOV AROV ;JUMP IF INTEGER OVERFLOW JRST SRETRN ;RETURN FIXED-UP RESULT IF SO AROV: WARNING MSG(INTOV) ;INTEGER OVERFLOW JRST SRETRN
; A^B, POWER(A,B) - RAISE A NUMBER TO A POWER SPOWER: EXP 2 ;TAKES TWO ARGS CALL GRAB2 ;PICK UP TWO ARGUMENTS CAIG AC3,U.DBL/2 ;CHECK THAT LH ARG IS INT,REAL,OR DBL CAILE T,U.DBL/2 ;AND THAT RH IS TOO ILLTYPE ;UGH CAIE T,U.INT/2 ;IS RH AN INT? JRST RPOWER ;DO REAL POWER CALCULATION MOVE T,AC3 ;OK, GET TYPE OF RESULT MOVE AC3,R ;GET INTEGER POWER TO RAISE TO JOV .+1 ;CLEAR OVERFLOW FLAG SPOW1: XCT MOVONE(T) ;LOAD PROPER REPRESENTATION OF 1 INTO (R,R2) MOVEI R2,0 JUMPE AC3,SRETRN ;ANYTHING^0 IS ONE. EXIT JUMPG AC3,POSPOW ;JUMP IF POWER IS POSITIVE MOVM AC3,AC3 ;NEGATIVE, MAKE IT POSITIVE JOV .+1 ;IGNORE OVERFLOW CAUSED BY 400000000000 XCT INVTAB(T) ;TAKE 1/LH ARG MOVE AC1,R ;GET RESULTS MOVE AC2,R2 JRST SPOW1 ;GO RESET (R,R2) TO ONE NXTPOW: XCT DBLPOW(T) ;RAISE MULTIPLIER TO NEXT POWER OF 2 EXPONENT POSPOW: TRNE AC3,1 ;WANT TO MULTIPLY THIS POWER? XCT MULPOW(T) ;YES, DO IT LSH AC3,-1 ;SHIFT OUT THAT BIT AND GET NEXT JUMPN AC3,NXTPOW ;LOOP AROUND IF ANY BITS LEFT JRST OVCK ;DONE. CHECK FOR OVERFLOW AND EXIT MOVONE: MOVEI R,1 ;MOVE INTEGER 1 MOVSI R,(1.0) ;MOVE REAL 1 MOVSI R,(1.0) ;MOVE DBL ONE INVTAB: IDIV R,AC1 ;TAKE INTEGER 1/LH ARG FDVR R,AC1 ;TAKE REAL 1/LH ARG DFDV AC1 ;TAKE DBL 1/LH ARG MULPOW: IMUL R,AC1 ;ACCUMULATE INTEGER POWER FMPR R,AC1 ;ACCUMULATE REAL POWER DFMP AC1 ;ACCUMULATE DOUBLE POWER DBLPOW: IMUL AC1,AC1 ;DOUBLE POWER OF INTEGER MULTIPLIER FMPR AC1,AC1 ;DOUBLE POWER OF REAL MULTIPLIER JRST .+1 ;DO KLUDGE FOR DBL SAVE <R,R2> ;DON'T CLOBBER PARTIAL RESULTS MOVE R,AC1 ;DUPLICATE MULTIPLIER MOVE R2,AC2 DFMP AC1 ;DOUBLE POWER OF DBL MULTIPLIER MOVE AC1,R ;RETRIEVE RESULTS MOVE AC2,R2 RESTORE <R2,R> JRST POSPOW ;CONTINUE
;COME HERE FOR NON-INTEGER POWERS RPOWER: EXCH R,AC1 ;EXCHANGE ARGS MOVE R2,AC2 ;AND SECOND HALF OF BASE IF DBL MOVEI R2,0 ;SET LOW ORDER BITS OF EXP TO 0 CAIN AC3,U.INT/2 ;WAS BASE AN INTEGER CALL INTRL1 ;MAKE IT A REAL MOVEI R2,0 ;CLEAR LOW ORDER BITS IF DBL MOVEI T,U.REAL/2 ;WORKING WITH TWO REALS JUMPE AC1,RPOW1 ;ANYTHING TO ZERO POWER IS 1 JUMPE R,RPOW0 ;ZERO TO ANYTHING IS 0. CAIG R,0 ;MUST ALSO BE POSITIVE SFNERR MSG(BSMNN) ;BASE MUST BE NON-NEGATIVE SAVE AC1 ;PROTECT THE BASE CALL LNSUB ;CALL LN SUBROUTINE RESTORE AC1 ;GET THE BASE BACK FMPR R,AC1 ;COMPUTE B*LN(A) JRST EXP1 ;FALL INTO EXP ROUTINE RPOW1: MOVSI R,(1.0) ;MOVE IN REAL 1. JRST SRETRN ;RETURN VALUE RPOW0: MOVEI R,0 ;SET TO 0. JRST SRETRN ;RETURN VALUE
;SYSTEM ARITHMETIC ROUTINES FOR UNARY +- SPLUS: EXP 1 ;TAKES 1 ARG CALL GRAB1 ;PREPARE A UNARY OPERAND CAIG T,U.DBL/2 ;CHECK TYPE JRST SRETRN ;NUMERIC. + IS A NO-OP ILLTYPE ;NON-NUMERIC. ERROR SMINUS: EXP 1 ;TAKES 1 ARG CALL GRAB1 ;PREPARE A UNARY OPERAND JOV .+1 ;PREPARE TO DETECT OVERFLOW ON -2^35 XCT SMINTB(T) ;NEGATE OPERAND JOV AROV ;JUMP IF OVERFLOW (ONLY INTEGER POSSIBLE) JRST SRETRN ;OK, RETURN VALUE SMINTB: MOVN R,R ;INTEGER (CAN CAUSE OVERFLOW) MOVN R,R ;REAL DFN R,R2 ;DBL XORI R,1 ;BOOL. PERFORM 'NOT' OPERATION ILLTYPE ;CHAR, AN ERROR JRST NULVOP ;NONE, AN ERROR ;SYSTEM BINARY BOOLEAN ROUTINES SAND: EXP 2 ;TAKES 2 ARGS CALL BBLPRP ;PREPARE TWO ARGS AND RESULT TYPE AND R,AC1 ;PERFORM LOGICAL AND JRST SRETRN SOR: EXP 2 ;TAKES 2 ARGS CALL BBLPRP ;PREPARE TWO ARGS AND RESULT TYPE OR R,AC1 ;PERFORM LOGICAL OR JRST SRETRN
SUBTTL ASSIGNMENT ;NONCOPYING ASSIGNMENT SNONCO: EXP 2 ;TAKES 2 ARGS TRO FF,ASGFLG ;INDICATE TYPE OF ASSIGNMENT JRST SASSG1 ;GO DO IT ;ASSIGNMENT ;***** NOTE ******* THIS ROUTINE WILL EVENTUALLY CONSIDER THE PROBLEM ;OF CONTINUOUS EVALUATION. SASSIG: EXP 2 ;TAKES 2 ARGS TRZ FF,ASGFLG ;INDICATE COPYING ASSIGNMENT TO BE DONE SASSG1: ADDI ARGP,1 ;POINT TO RH ARG FIRST MOVE L,@ARGP ;GET THE LEXEME ASGLTP: LGET T,LTYPF ;LOAD LEXEME TYPE FIELD XCT ASGTB1(T) ;BRANCH ON RH LEXEME TYPE ;TABLE FOR DISCRIMINATING ON RIGHT-HAND VALUE ASGTB1: ILLTYPE ;OP - ERROR JRST ASGHDW ;PROCID - GO GET LEXEME FROM AR HEADER JRST ASGHDW ;FORML JRST ASGHDW ;LCL JRST ASGID ;ID-GO BRANCH ON ITS TYPE JRST ASGN1 ;CONST - ASSIGNABLE JRST ASGRLC ;RELOC - ASSIGNABLE IF CONVERTED TO INT ILLTYPE ;DEMAND - SYSTEM ERROR JRST ASGSLX ;SELX - RESULT OF SELECTION ASSIGNABLE JRST ASGID ;$ID - TREAT LIKE ID JRST ASGDMR ;DUMREF - FETCH REFERENCED LEXEME ;PROCID,FORML,LCL - GET LEXEME FROM APPROPRIATE CELL OF THE CURRENT AR ASGHDW: ADDI L,ARBASE(B) ;COMPUTE ABS ADDR OF THIS HEADER WORD MOVE L,(L) ;GET THE LEXEME JRST ASGLTP ;GO BRANCH ON ITS TYPE ;ID - GO SEE WHAT KIND ASGID: ADD L,@IDTP ;CONVERT INTERNAL NAME TO ABS ADDR IN IDT HLRZ R,(L) ;GET LH OF ENTRY HRRZ L,(L) ;GET RH OF ENTRY XCT ASGTB2(R) ;BRANCH ON ID TYPE ;TABLE FOR DISCRIMINATING ON ID'S IN AN RVALUE CONTEXT ASGTB2: JRST UNASGV ;UNASSIGNED IDENTIFIER JRST ASGN1 ;VAR - ASSIGNABLE ILLTYPE ;FN ILLTYPE ;DDEF ILLTYPE ;SEL JRST ASGCEV ;CEV - EXTRACTED VALUE ASSIGNABLE ILLTYPE ;ATOM ILLTYPE ;SFN ILLTYPE ;RESW
;STE IS CEV - GO EXTRACT VALUE FROM CVAL BLOCK ASGCEV: HRRZ L,(L) ;GET DZ ADDR OF CVAL BLOCK HRRZ L,1(L) ;GET PZ POINTER JRST ASGN1 ;GO ASSIGN IT ;LEXEME IS A RELOC, CONVERT IT TO AN INT ASGRLC: HRRZ R,L ;GET VALUE MOVEI T,U.INT ;MARK IT AS AN INT JRST ASGSTO ;GO TO MAKE A BLOCK OF IT ;LEXEME IS A DUMMY REFERENCE TO A LOCAL IN ANOTHER AR ASGDMR: CALL GETDMR ;GET LEXEME FROM REFERENCED AR JRST ASGLTP ;GO DISPATCH ON ITS LEXEME TYPE ;LEXEME IS AN LVALUE, GO GET REFERENCED VALUE ASGSLX: MOVE B,(L) ;GET DZ ADDR OF LVALUE CALL SELECT ;PERFORM SELECTION JRST ASGN2 ;RETURNED A PZ ADDR TO DATUM ASGSTO: MOVE AC1,R ;FETCH DATUM TO BE RETURNED MOVE AC2,R2 MOVE AC3,T ;AND TYPE INFORMATION CALL ATOM ;CONSTRUCT ATOM, PZADR IN R ASGN2: HRRZ B,(CAR) ;RESTORE AR DZ POINTER MOVE L,R ;PUT PZ ADDR OF RVALUE BLOCK IN L ;WE NOW HAVE A VALID LEXEME FOR ASSIGNMENT, AND WE MUST NOW DETERMINE ;THE CHARACTERISTICS OF THE LH EXPRESSION ASGN1: MOVE AC1,L ;SET UP COMPUTED LEXEME TRNE FF,ASGFLG ;NONCOPY ASSIGNMENT? SKIPA R,AC1 ;YES. USE RVALUE DIRECTLY CALL COPY ;NO. MAKE A COPY OF THE RVALUE MOVE AC4,R ;PICK UP RESULT HRLI AC4,(LXM(STAK,CONST)) ;CONSTRUCT CONST LEXEME HRRZ B,(CAR) ;RESTORE AR BASE POINTER SUBI ARGP,1 ;POINT TO LEFT ARGUMENT MOVE L,@ARGP ;GET THE LEFT ARG LEXEME LGET T,LTYPF ;GET LEXEME TYPE FIELD MOVE T,ASGTB3(T) ;FETCH RH ENTRY FOR LEXEME TYPE JRST (T) ;DISPATCH
;TABLE FOR DISCRIMINATING ON LH VALUES ASGTB3: ASGBAD ,, ASGBAD ;OP ASGBAD ,, HDASG ;PROCID ASGBAD ,, FMLASG ;FORML ASGBAD ,, HDASG ;LCL GLBASG ,, GLBASG ;ID HDASG0 ,, CASGER ;CONST HDASG0 ,, CASGER ;RELOC ASGBAD ,, ASGBAD ;DEMAND ASGEL ,, ASGEL ;SELX GLBASG ,, GLBASG ;$ID ASGDM1 ,, ASGDM1 ;DUMREF ;SYSTEM ERROR FOR BAD LH OPERAND LEXEME ASGBAD: ERROR MSG(BDLHS) ;BAD LHS IN ASSIGN ;LH IS A FORMAL PARAMETER. SWITCH ON THE PRESENT VALUE OF THE ; FORMAL (IF ANY). IF IT IS ONE OF ID,$ID,SELX, OR DUMREF, THEN ; IT IS IN TURN USED AS THE LVALUE. OTHERWISE, ASSIGNMENT IS ; MADE TO THE FORMAL SLOT IN THE AR AS IF THE FORMAL WERE A LOCAL. FMLASG: ADDI L,ARBASE(B) ;COMPUTE ABS ADR OF FORMAL SKIPN L,(L) ;FETCH PRESENT CONTENTS JRST HDASG0 ;NOT ASSIGNED, PERFORM LOCAL ASSIGNMENT LGET T,LTYPF ;DEFINED, FETCH LEXEME TYPE FIELD MOVS T,ASGTB3(T) ;FETCH LH OF DISPATCH TABLE ENTRY JRST (T) ;DISPATCH AGAIN ;HERE WHEN A FORMAL IS TO BE TREATED AS A LOCAL. HDASG0: MOVE L,@ARGP ;RESTORE FORML LEXEME AND FALL INTO LCL CODE ;LH IS PROCID OR LCL. STORE RVALUE IN PROPER SLOT AS A CONST HDASG: ADDI L,ARBASE(B) ;COMPUTE ADDR OF SLOT IN AR MOVEM AC4,(L) ;STORE LEXEME ASGXIT: MOVE R,AC4 ;RETURN RH VALUE AS HRLI R,(LXM(STAK,CONST)) ; VALUE OF CALL TO ASSIGN TRZ FF,PIR ;TURN OFF PRINT BIT RETURN ;EXIT TO CALLER OF ASSIGN
;LH IS AN ID. MAKE SURE IT IS A GLOBAL IDENTIFIER GLBASG: ADD L,@IDTP ;COMPUTE ABS STE ADDR HLRZ R,(L) ;GET ID TYPE JUMPE R,GLBAS1 ;OK IF NOT PREVIOUSLY DEFINED CAIN R,I.CEV ;A CEV? JRST GLBCEV ;YES, GO GRAB PZ ADDR OF DATA FROM CVAL CAIE R,I.VAR ;NO, MUST BE NORMAL VAR CASGER: ASGERR GLBAS1: HRLI AC4,I.VAR ;IDENTIFY THIS ID AS A VAR MOVEM AC4,(L) ;STORE STE JRST ASGXIT ;RETURN CONST ON STACK GLBCEV: HRRZ L,(L) ;GET PZ ADDR OF CVAL BLOCK HRRZ L,(L) ;GET DZ ADDR OF CVAL BLOCK AOJA L,GLBAS1 ;GO PERFORM ASSIGNMENT
;LH IS A SELECTION EXPRESSION. CHECK FOR TYPE MATCH AND STORE RVALUE ASGEL: SAVE AC4 ;SAVE POINTER TO RVALUE HLRZ AC1,(AC4) ;GET LH OF PZ WORD FOR RVALUE ANDCMI AC1,(GCBIT+CPYBIT) HRRZ B,(L) ;GET DZ ADDR OF LVALUE GET AC2,PZAF ;AC2_PZ ADDRESS FIELD IN LVALUE CAMN AC2,IDTP ;DOES IT ADDRESS THE IDT? JRST STFADR ;YES, WE CAN STUFF IN ANY TYPE GET AC2,ELTF ;NO, GET LVALUE ELEMENT TYPE FIELD CALL CHKPRD ;SKIP IF RVALUE IS AN INSTANCE OF LVALUE ELEMENT TYPE SFNERR MSG(DTMIS) ;DATA TYPE MISMATCH STFADR: GET R,DISPF ;OK, GET LVALUE DISPLACEMENT FIELD HRLI R,B ;PREPARE TO INDEX BY BASE ADDR LSHC R,-^D24 ;SHIFT I,X,Y INTO LH OF R2 GET R,LENF ;GET LENGTH FIELD CAIN R,^D18 ;CHECK SIZE JRST ASGPZA ;18=STORE PZ ADDR JUMPE R,ASGPZA ;BYTE SIZE=0 => NULL HRRZ AC1,(AC4) ;ATOMIC FIELD, GO ACCESS DATA MOVE AC4,1(AC1) ;GET HIGH ORDER CAILE R,^D36 JRST ASGDBL ;>36 = STORE DOUBLE ASGPZA: LSHC R,-6 ;PACK ON SIZE FIELD GET R,BEGF ;GET POSITION OF FIRST BIT MOVNI R,-^D36(R) ;CONVERT TO HARDWARE POSITION FIELD LSHC R,-6 ;COMPLETE BYTE POINTER GET B,PZAF ;GET PZ ADDR OF SELECTED STRUCTURE HRRZ B,(B) ;GET DZ ADDR ASGELX: IDPB AC4,R2 ;STORE DATA RESTORE AC4 ;RESTORE RVALUE TO LEAVE ON STACK HRRZ B,(CAR) ;RESTORE CLOBBERED AR POINTER JRST ASGXIT ;SIZE>36, STORE DOUBLE ASGDBL: GET B,PZAF ;GET PZ ADDR OF TARGET STRUCTURE HRRZ B,(B) ;GET ITS DZ ADDR LSH R2,-^D12 ;FINISH BYTE POINTER TLO R2,4400 ;SET SIZE=36, POSITION=0 DPB AC4,R2 ;STORE HIGH WORD MOVE AC4,2(AC1) ;GET LOW WORD JRST ASGELX ;GO TO STORE IT ;DUMMY REFERENCE ON LH - PERFORM ASSIGNMENT INTO ANOTHER AR ASGDM1: FETCH (R,L,FCHNF) ;FETCH LOCAL PARAMETER NUMBER HRRZ L,(L) ;FETCH DZADR OF REFERENCED AR ADDI L,ARBASE(R) ;COMPUTE ABS ADR OF DESIRED LOCAL MOVEM AC4,(L) ;PERFORM ASSIGNMENT JRST ASGXIT
SUBTTL COPYING OF A SYSTEM FUNCTION INTO A USER ID SCOPYS: EXP 2 ;TAKES TWO ARGS CALL EVALID ;FIRST SHOULD BE ID ILLTYPE MOVE L,@ARGP ;FETCH RESULTANT LEXEME ADD L,@IDTP ;COMPUTE ABS ADR OF STE IN IDT HRRZ AC4,L ;SAVE THIS ADDRESS FOR LATER HLRZ R,(L) ;GET LH OF STE CAIE R,0 ;MAKE SURE IS UNASSIGNED ID SFNERR MSG(FNAIU) ;NAME ALREADY IN USE ADDI ARGP,1 ;NEXT ARGUMENT CALL EVALID ;MAKE AN ID ILLTYPE MOVE L,@ARGP ;FETCH RESULTANT LEXEME ADD L,@IDTP ;COMPUTE ABS ADR OF STE IN IDT HLRZ R,(L) ;GET TYPE FIELD CAIE R,I.SFN ;BETTER BE A SYSTEM FUNCTION ILLTYPE MOVE R,(L) ;GET THE WHOLE VALUE WORD MOVEM R,(AC4) ;ASSIGN IT TO LH ID JRST RETNUL ;ALL DONE, RETURN NULL
SUBTTL PREDICATE HANDLING AND TYPE TESTING ; X==T, INSTANCE(X,T) - IS EXPRESSION X OF TYPE T? SINSTA: EXP 2 ;TAKES 2 ARGS CALL MKCNST ;COERCE LH ARG TO A CONSTANT JRST RETF ;CANT MAKE A CONSTANT, SO MUST BE FALSE MOVE AC1,@ARGP ;GET RESULTANT LEXEME HLRZ AC1,(AC1) ;GET THE TYPE FIELD FROM ADDRESSED PZ WORD ADDI ARGP,1 ;MOVE TO RH ARG CALL EVALID ;EVAL TO AN ID ILLTYPE ;COULDN'T DO IT - IMPROPER PREDICATE HRRZ AC2,@ARGP ;GET ID INTERNAL NAME CALL CHKPRD ;PERFORM PREDICATE TEST BETWEEN DATA ; TYPE IN AC1 AND PREDICATE IN AC2 TDZA R,R ;NON-MATCH, RETURN BOOLEAN FALSE MOVEI R,1 ;MATCH, RETURN BOOLEAN TRUE JRST BRETRN ;RETURN RESULT AS A BOOL ;ROUTINE TO COERCE THE LEXEME AT ARGP TO AN ID. THE RESULT IS LEFT AT ;THE CELL POINTED TO BY ARGP AND A SKIP RETURN IS TAKEN. A NON-SKIP ;RETURN IS TAKEN IF IT IS NOT POSSIBLE TO COERCE TO AN ID ;THE STANDARD ENTRY POINT (EVALID) ATTEMPTS TO CONVERT ;STRING ARGUMENTS TO EQUIVALENT ID'S. THE ALTERNATE ENTRY ;(EVLIDN) DOES NOT CONVERT AND IS USED IN CASES THAT ;WOULD OTHERWISE BE AMBIGUOUS. EVLIDN: SAVE <L> ;PROTECT A REGISTER JRST TRYID2 ;ONLY TRY DIRECT CONVERSION EVALID: SAVE <L> ;PROTECT A REGISTER PUSH P,@ARGP ;SAVE THE OLD ARGUMENT VALUE CALL MKCNST ;TRY TO COERCE TO A CONSTANT FIRST JRST TRYID ;NOT POSSIBLE, TRY ID MOVE L,@ARGP ;GET THE CONSTANT LEXEME JUMPE L,TRYID ;UNASSIGNED ID, TRY THAT APPROACH MOVE L,(L) ;GET ADDRESS OF DATA BLOCK LGET L,BLTF ;AND ITS BLOCK TYPE CAIE L,U.STRING ;CHECK FOR STRING JRST TRYID ;TRY ID IF NOT SAVE <AC1,T> ;SAVE SEVERAL WORK REGISTERS MOVE L,@ARGP ;GET DATA BLOCK AGAIN MOVE L,(L) HRRZ L,(L) ;COMPUTE STARTING ADDRESS OF STRING BLK HRRZ L,(L) SKIPN 1(L) ;CHECK FOR NULL STRING JRST IDNULL ;GO RETURN ID NULL MOVE AC1,[POINT 6,LXBUF,5] ;PREPARE BYTE POINTER TO STORE HRRZI R2,2(L) ;ALSO PREPARE ASCII LOAD HRLI R2,(POINT 7) ; BYTE POINTER HRRZ T,1(L) ;GET LENGTH ; HAVE TO DO OWN LEX CHECKING OF STRINGS HERE TO SEE THAT THEY ; ARE VALID IDS ILDB R,R2 ;GET FIRST ASCII CHAR CAIL R,"A"+40 ;CHECK FOR LOWER CASE SUBI R,40 ;CONVERT TO UPPER CASE CAIL R,"A" ;CHECK ALPHABETIC RANGE CAILE R,"Z" SFNERR MSG(ILIDS) ;ILLEGAL ID STRING JRST IDPUTC ;ENTER CHARACTER IDCLP: ILDB R,R2 ;GET NEXT CHARACTER CAIN R,"." ;CHECK FOR PERIOD JRST IDPERD ;HANDLE PERIOD SPECIALLY TLZ L,1 ;FLAG NO PERIOD CAIL R,"A"+40 ;CHECK FOR LOWER CASE SUBI R,40 ;AND CONVERT CAIL R,"0" ;CHK DIGIT OR ALPHA CAILE R,"Z" SFNERR MSG(ILIDS) ;ILLEGAL ID STRING CAILE R,"9" ;KEEP CHECKING CAIL R,"A" JRST IDPUTC ;OK SFNERR MSG(ILIDS) ;ILLEGAL ID STRING IDPERD: TLOE L,1 ;JUST SAW A PERIOD SFNERR MSG(ILIDS) ;SECOND CONSECUTIVE PERIOD IDPUTC: ADDI R,40 ;CONVERT TO SIXBIT IDPB R,AC1 ;AND STORE SOJG T,IDCLP ;GO BACK IF ANY LEFT TLZE L,1 ;MAKE SURE DID NOT END WITH A PERIOD SFNERR MSG(ILIDS) ;ILLEGAL ID STRING CALL CLRBYT ;FINISH THAT WORD HRRZ R,1(L) ;GET LENGTH AGAIN IDIVI R,6 ;COMPUTE NUMBER OF WORDS USED ADDI R,2 ;CORRECT TO PUT IN STANDARD FORM DPB R,[POINT 6,LXBUF,5] ;DEPOSIT IN INITIAL POSITION CALL FINDID ;LOOK IT UP JFCL ;DON'T CARE IF IT IS NEW MOVE R2,@IDTP ;GET BASE ADDRESS ADDI R2,(R) ;COMPUTE ABSOLUTE ADDRESS OF ENTRY CAIN N,I.SYNTOK ;IS IT A SPECIAL SYNTAX TOKEN SFNERR MSG(ILIDS) ;ILLEGAL ID STRING CAIA ;SKIP NEXT INSTRUCTION IDNULL: MOVEI R,%NULL ;MAKE NULL ID HRLI R,(LXM(STAK,ID)) ;MAKE STACK LEXEME MOVEM R,@ARGP ;PUT IT BACK AT ARGP RESTORE <T,AC1> POP P,L ;FLUSH THE SAVED ARGUMENT JRST EVLIOK ;GO BACK WITH CONVERTED ID ;OLD EVALID CODE - STANDARD IDENTIFIER TRYID: POP P,@ARGP ;RESTORE CLOBBERED ARGP TRYID2: MOVE L,@ARGP ;GET THE LEXEME EVALI1: LGET R,LTYPF ;EXTRACT LEXEME TYPE FIELD CAIE R,ID ;IF AN ID CAIN R,$ID ; OR A $ID JRST EVLIOK ; THEN IT'S OK CAIE R,FORML ;OTHERWISE, SEE IF DUMMY ARG JRST EVALI2 ;NO, TRY PROCID ADDI L,ARBASE(B) ;YES. COMPUTE ADDR OF HEADER SLOT IN AR MOVE L,(L) ;GET ITS CONTENTS MOVEM L,@ARGP ;SUBSTITUTE ACTUAL FOR FORMAL JRST EVALI1 ;GO BACK AND SWITCH AGAIN EVALI2: CAIE R,PROCID ;PROCEDURE IDENTIFIER? JRST EVLIDX ;NO. IMPROPER ARG. TAKE ERROR RETURN GET R,FNF ;YES. GET FUNCTION FIELD HRRZ R,(R) ;GET DZADR OF FN BLOCK HLRZ R,3(R) ;GET PZADR OF LINE0 BLOCK HRRZ R,(R) ;GET DZADR OF LINE0 BLOCK HLRZ L,4(R) ;GET INTERNAL NAME OF PROCID HRLI L,(LXM(STAK,ID)) ;MAKE AN ID LEXEME MOVEM L,@ARGP ;STORE IT ON STACK EVLIOK: AOS -1(P) ;SKIP RETURN EVLIDX: RESTOR <L> ;RESTORE CLOBBERED AC RETURN
;CHKPRD(TYPE,CLASS) ;CHECK TO SEE WHETHER THE USER-DEFINED BLOCK TYPE "TYPE" IS AN INSTANCE ;OF THE PREDICATE "CLASS". BOTH ARGS ARE INTERNAL ID NAMES. TYPE MAY ;BE A PHYSICAL BLOCK TYPE, I.E. IT MUST BE THE NAME OF AN ATOM,SEQ, ;VSEQ, OR STRUCT. CLASS MAY BE ANY OF THE ABOVE, OR THE NAME OF AN ALT OR ;USER-DEFINED BOOLEAN PROCEDURE OPERATING ON PREDICATES AND RETURNING ;A BOOLEAN VALUE BASED ON THE RESULTS. ;RETURNS: (1) TYPE IS NOT AN INSTANCE OF CLASS ; (2) TYPE IS AN INSTANCE OF CLASS ;****** IMPORTANT IMPLEMENTATION NOTES ********* ;(1) THE INITIAL VERSION OF PPL DOES NOT RECOGNIZE USER-DEFINED ; FUNCTIONS AS PREDICATES. ;(2) THE INITIAL VERSION DOES NOT GUARD AGAINST PREDICATES POINTING ; IN A LOOP. THIS WILL CAUSE OVERFLOW ON THE SYSTEM STACK. TYPE== AC1 ;ARGS CLASS== AC2 ;NOTE: TYPE MUST HAVE ITS LH CLEAR ON ENTRY. R,R2 ARE CLOBBERED. CHKPRD: SAVE B ;PRESERVE A REGISTER HRRZ B,@IDTP ;GET DZ ADDR OF IDT INTO B FOR INDEXINT HRRZ R,CLASS ;PREPARE ARG TO CENTRAL LOOP HRLI R,B ;SET INDEX FIELD CALL CHKTP1 ;SKIP IF TYPE DID NOT MATCH PREDICATE AOS -1(P) ;THEY MATCHED, TAKE SKIP RETURN RESTORE B RETURN
;CENTRAL TYPE-CHECK ROUTINE. R MUST CONTAIN XWD B,PREDICATE. ;SKIPS IF R DOES ***NOT*** MATCH PREDICATE. ;CLASS IS PRESERVED OVER RECURSIVE CALLS CHKTP1: SAVE CLASS ;PROTECT IN CASE OF RECURSIVE CALL TRNN R,-1 ;NULL PREDICATE IS MISMATCH JRST CHKTX1 HLRZ CLASS,@R ;OK, GET STE FOR NAMED PREDICATE CAIN CLASS,I.ATOM ;CHECK ID TYPE JRST CHKTPD ;ATOM, WE CAN CHECK TYPE DIRECTLY CAIN CLASS,I.RESW ;NOT ATOM; SEE IF RESERVED WORD JRST CHKRSW ;RESW. PERFORM SPECIAL ACTION CAIE CLASS,I.DDEF ;NOT ATOM EXERR MSG(ILGID) ;ILLEGAL ID IN PREDICATE EXPRESSION HRRZ CLASS,@R ;DDEF, GET ITS PZ ADDR HLRZ R2,(CLASS) ;GET BLOCK TYPE ANDCMI R2,(SYSBIT+GCBIT+CPYBIT) CAIE R2,B.ALT ;AN ALT? JRST CHKTPD ;NO, ANOTHER KIND OF DDEF. MAKE DIRECT TEST HRRZ R2,(CLASS) ;ALT, GET DZ ADDR OF ALT BLOCK SETCM CLASS,(R2) ;PUT -WLENGTH-1 IN LH HRRI CLASS,-1(R2) ;PUT ALT BASE -1 IN RH AOBJN CLASS,CHKAL1 ; -WLENGTH,,BASE CHKALT: HLR R,(CLASS) ;CHECK PREDICATE WHICH IS LH ALT ENTRY CALL CHKTP1 JRST CHKTX2 ;IT MATCHED. GO RETURN HRR R,(CLASS) ;NOT A MATCH, TRY RH CALL CHKTP1 JRST CHKTX2 ;MATCHED, GO RETURN CHKAL1: AOBJN CLASS,CHKALT ;NOT A MATCH, TRY NEXT ALT WORD IF ANY CHKTX1: AOS -1(P) ;COME HERE ON A FAILURE TO MATCH CHKTX2: RESTORE CLASS ;COME HERE IF SUCCESS RETURN CHKTPD: CAIE TYPE,(R) ;DIRECT TEST : TYPE MATCH PREDICATE? AOS -1(P) ;NO RESTORE CLASS RETURN CHKRSW: HRRZ CLASS,@R ;COME HERE ON A RESERVED WORD HRR R,TYPE ;PREPARE TO EXAMINE DATA TYPE HRRZ R2,@R ;GET RH OF IDT ENTRY FOR DATUM CAILE TYPE,LSTATM ;SKIP IF ATOMIC DATUM HLRZ R2,(R2) ;OTHERWISE, GET DDEF TYPE XCT CHKRTB-1(CLASS) ;BRANCH ON RESW INDEX JRST CHKTX1 ;HERE IF NOT A MATCH CHKRTB: JRST CHKTX2 ;GENERAL - UNCONDITIONAL MATCH CAIE R2,SB+B.STRUCT ;STRUCTURE - UNION OF ALL STRUCTURES CAIE R2,SB+B.SEQ ;SEQUENCE - UNION OF ALL SEQUENCES CAIE R2,SB+B.VSEQ ;V.SEQUENCE - UNION OF ALL VARIADIC SEQUENCES CAILE TYPE,U.NONE ;ATOMIC - UNION OF INT!REAL!DBL!BOOL!CHAR!NONE
SUBTTL SYSTEM RELATIONAL ROUTINES SLESS: XWD 0,2 ;LESS(A,B) - TAKES 2 ARGS JSP AC7,RELATX ;CALL RELATIONAL FUNCTION HANDLER CAML R,AC1 ;INTEGER OR REAL COMPARE CALL DCMPL ;DOUBLE COMPARE SLESSE: XWD 0,2 ;LESSEQ(A,B) - TAKES 2 ARGS JSP AC7,RELATX ;CALL RELATIONAL FUNCTION HANDLER CAMLE R,AC1 ;INTEGER OR REAL COMPARE CALL DCMPLE ;DOUBLE COMPARE SGR: XWD 0,2 ;GR(A,B) - TAKES 2 ARGS JSP AC7,RELATX ;CALL RELATIONAL FUNCTION HANDLER CAMG R,AC1 ;INTEGER OR REAL COMPARE CALL DCMPG ;DOUBLE COMPARE SGREQ: XWD 0,2 ;GREQ(A,B) - TAKES 2 ARGS JSP AC7,RELATX ;CALL RELATIONAL FUNCTION HANDLER CAMGE R,AC1 ;INTEGER OR REAL COMPARE CALL DCMPGE ;DOUBLE COMPARE ;CENTRAL RELATIONAL FUNCTION HANDLER RELATX: CALL RELPRP ;PREPARE TWO ARITHMETIC ARGS FOR COMPARE CAIN T,U.DBL/2 ;RESULT TYPE DBL? ADDI AC7,1 ;YES, POINT TO DBL OPERATION XCT (AC7) ;PERFORM COMPARISON OPERATION TDZA R,R ;SET BOOLEAN FALSE MOVEI R,1 ;SET BOOLEAN TRUE JRST BRETRN ;RETURN RESULT OF COMPARE AS A BOOL
;POLYMORPHIC EQUALITY AND INEQUALITY SEQ: EXP 2 ;TAKES 2 ARGS CALL EQTST ;PERFORM EQUALITY TEST JRST BRETRN ;RETURN RESULT AS DATUM OF TYPE BOOL SNOTEQ: EXP 2 ;TAKES 2 ARGS CALL EQTST ;PERFORM EQUALITY TEST TRC R,1 ;TAKE COMPLEMENT OF RESULT JRST BRETRN ;RETURN RESULT AS DATUM OF TYPE BOOL ;ROUTINE TO COMPARE TWO ARGS AND RETURN 1 OR 0 ACCORDING TO WHETHER OR ;NOT THEY ARE EQUAL. ARITHMETIC TYPES (INT,REAL,DBL) MAY HAVE TYPE ;CONVERSION PERFORMED ON THEM. EQTST: CALL ARGPRP ;LOOK AT FIRST ARG JRST EQNAT ;NOT ATOMIC, TRY STRING CALL GRAB2A ;PICK UP TWO ARGS CAIG T,U.DBL/2 ;ARE BOTH ARITHMETIC? CAILE AC3,U.DBL/2 JRST EQTST1 ;NO, DO SPECIAL THINGS FOR CHAR AND BOOL CALL ARGPR1 ;YES. PERFORM ANY REQUIRED TYPE CONVERSION EQTST0: XCT EQTB(T) ;SKIP IF ARGUMENTS ARE EQUAL EQTST2: TDZA R,R ;RETURN FALSE EQTST3: MOVEI R,1 ;RETURN TRUE RETURN EQTST1: CAME T,AC3 ;COME HERE IF EITHER ARG IS NOT ARITHMETIC JRST EQTST2 ;NOT SAME TYPE. ALWAYS RETURN FALSE JRST EQTST0 ;SAME TYPE. MAKE DIRECT COMPARISON EQTB: CAME R,AC1 ;INTEGER COMPARE CAME R,AC1 ;REAL COMPARE CALL DCMPE ;DBL COMPARE CAME R,AC1 ;BOOL COMPARE CAME R,AC1 ;CHAR COMPARE CAIA ;NONE COMPARE
;HERE WHEN FIRST ARG WASN'T ATOMIC. WE CAN ALSO COMPARE STRINGS. EQNAT: CAIE T,U.STRING ;WAS IT A STRING? ILLTYP ;NO, ERROR MOVE AC1,R ;YES, SAVE PZADR OF DATUM ADDI ARGP,1 ;ADVANCE TO SECOND ARG CALL ARGPRP ;COERCE TO A CONSTANT CAIE T,U.STRING ;ERROR IF NOT A STRING ILLTYP ;ERROR IF ATOMIC HRRZ AC1,(AC1) ;BOTH STRINGS. GET DZADR OF 1ST ARG HLRZ R2,(AC1) ;GET WLENGTH MOVNI R2,-1(R2) ;COMPUTE -# WDS, INCL UPPER BOUND MOVSI R2,(R2) ;PUT IN LH HRRI R2,1 ;INDEX PAST WLENGTH/BACK PTR HRLI AC1,R2 ;INDEX FIRST ARG BY R2 HRRZ R,(R) ;FETCH DZADR OF 2ND ARG HRLI R,R2 ;INDEX BY R2 ;LOOP TO COMPARE EACH WORD OF STRING BLOCKS EQSTR: MOVE AC2,@AC1 ;FETCH WORD FROM FIRST ARG CAMN AC2,@R ;COMPARE WITH WORD FROM SECOND ARG AOBJN R2,EQSTR ;EQUAL. TRY NEXT JUMPGE R2,EQTST3 ;IF ALL EQUAL, RETURN TRUE JRST EQTST2 ; ELSE FALSE ;NOT(A) - FOR A BOOL, RETURNS COMPLEMENT ;FOR AN INT, RETURNS BITWISE COMPLEMENT SNOT: EXP 1 ;TAKES ONE ARG CALL GRAB1 ;PICK IT UP CAIN T,U.INT/2 ;IS IT AN INT? JRST .+4 ;YES CAIE T,U.BOOL/2 ;NO, A BOOL? ILLTYPE ;NO, ERROR TRCA R,1 ;YES. COMPLEMENT BOOLEAN VALUE SETCM R,R ;COMPLEMENT INTEGER VALUE JRST SRETRN
SUBTTL USER-CALLABLE CONVERSION FUNCTIONS ;INT(X) - CONVERT ANYTHING TO AN INT. SINT: EXP 1 ;TAKES A SINGLE ARG CALL GRAB1 ;SET UP ATOMIC ARG XCT SINTTB(T) ;PERFORM REQUIRED CONVERSION SINTTB: JRST SRETRN ;INT - DO NOTHING CALL FIX ;REAL - CONVERT TO INT IF POSSIBLE CALL DFIX ;DBL - CONVERT TO INT MOVEI T,U.INT/2 ;BOOL, MAKE IT INT 0 OR 1 (FALSE,TRUE) MOVEI T,U.INT/2 ;CHAR - RETURN CHAR CODE AS INT MOVEI T,U.INT/2 ;NONE, DEFAULT TO ZERO ;REAL(X) - CONVERT ANYTHING TO A REAL. SREAL: EXP 1 CALL GRAB1 ;SET UP ATOMIC ARG XCT SREALT(T) ;PERFORM REQUIRED CONVERSION TO REAL JRST SRETRN SREALT: CALL INTRL1 ;INT - FLOAT IT JRST SRETRN ;REAL, DO NOTHING CALL DBLRL1 ;DBL, CONVERT TO REAL CALL INTRL1 ;BOOL, CONVERT FALSE TO 0.0 AND TRUE TO 1.0 CALL INTRL1 ;CHAR, MAKE A REAL CHARACTER CODE MOVEI T,U.REAL/2 ;NONE, DEFAULT TO ZERO ;DBL(X) - CONVERT ANYTHING TO A DBL SDBL: EXP 1 CALL GRAB1 ;PICK UP SINGLE ATOMIC ARG XCT SDBLTB(T) ;PERFORM CONVERSION TO DBL JRST SRETRN SDBLTB: CALL INTDB1 ;INT, CONV. TO DBL CALL RLDB1 ;REAL, CONV TO DBL JRST SRETRN ;DBL, DO NOTHING CALL INTDB1 ;BOOL, MAKE A DBL 0.0 OR 1.0 CALL INTDB1 ;CHAR, MAKE A DOUBLE CHARACTER CODE MOVEI T,U.DBL/2 ;NONE, DEFAULT TO ZERO
;BOOL(X) - CONVERT ANYTHING TO A BOOL SBOOL: EXP 1 CALL GRAB1 ;PICK UP SINGLE ARG XCT SBLTB(T) ;PERFORM CONVERSION JRST SRETRN SBLTB: CALL ARIBL1 ;INT - ZERO-->FALSE, NONZERO-->TRUE CALL ARIBL1 ;REAL CALL ARIBL1 ;DBL JRST SRETRN ;BOOL, DO NOTHING CALL CHRBL1 ;CHAR: "T"-->TRUE, ALL ELSE-->FALSE MOVEI T,U.BOOL/2 ;NONE, DEFAULT TO FALSE ;CHAR(X) - CONVERT ANYTHING TO A CHAR SCHAR: EXP 1 ;ONE ARG CALL GRAB1 ;PREPARE THE ARG XCT SCHRTB(T) ;PERFORM PROPER CONVERSION JRST SRETRN ;RETURN TO CALLER SCHRTB: CALL INTCH1 ;INT-->CHARACTER CODE JRST SCHARR ;REAL-->CHARACTER CODE JRST SCHARD ;DBL-->CHARACTER CODE CALL BLCH1 ;BOOL: TRUE-->"T", FALSE-->"F" JRST SRETRN ;CHAR, NO MODIFICATION MOVEI T,U.CHAR/2 ;NONE, CONVERT TO NULL CHARACTER SCHARR: CALL FIX ;REAL-->INT FIRST JRST .+2 SCHARD: CALL DFIX ;DBL-->INT FIRST CALL INTCH1 ;NOW INT-->CHARACTER CODE JRST SRETRN
SUBTTL UTILITY SYSTEM FUNCTIONS ;RESET - SYSTEM FN TO CLEAR RAF,RSF AND RE-ENTER SUPVSR. ;THIS IS REQUIRED TO EDIT A FUNCTION AFTER BECOMING SUSPENDED WITHIN ;A FUNCTION SRESET: EXP 0 ;TAKES ZERO ARGS JRST RESETN ;GO RESET TO TOP LEVEL AND RESTART SUPERVISOR ; UNARY("X",Y) - DEFINE THE CHAR OR STRING X TO BE A UNARY OPERATOR ;WHICH INVOKES THE FUNCTION Y. SUNARY: EXP -1 ;TAKES 2 OR 3 ARGS SETZ AC3, ;FLAG UNARY CASE CALL PREPOP ;SET UP AND CHECK ARGS; RETURN OP IN AC1 ;AND INTERNAL NAME IN AC2 ;AND PRECEDENCE IN AC3 ;ASSOC IN AC4. AC3&AC4 HAVE BIT 0 SET ;IF DEFAULT VALUES ARE BEING USED CALL FINDOP ;LOOK UP OP IN OPT CALL ENTROP ;ENTER NEW OPERATOR ADD R,@OPTP ;CONV INTERNAL NAME TO ABS ADDR OF OP ENTRY HLRZ AC1,1(R) ;GET OLD ASSIGNMENT (IF ANY) JUMPN AC1,.+2 ;WAS THERE ONE? HRLI AC3,0 ;DEFAULT USING DEFAULT VALUES HRLM AC2,1(R) ;STORE IN UNARY POSITION TLZN AC3,400000 ;DON'T OVERRIDE OLD VALUE HRLM AC3,2(R) ;STORE PRECEDENCE JRST RETNUL ;RETURN NULL LEXEME ; BINARY("X",Y) - DEFINE BINARY OPERATOR THE SAME WAY SBINAR: EXP -1 HRRZI AC3,1 ;FLAG BINARY CASE CALL PREPOP CALL FINDOP CALL ENTROP ADD R,@OPTP HRRZ AC1,1(R) JUMPN AC1,.+3 HRLI AC3,0 HRLI AC4,0 HRRM AC2,1(R) TLZN AC3,400000 ;DON'T CLOBBER PRECEDENCE HRRM AC3,2(R) TLZE AC4,400000 ;OR ASSOCIATIVITY JRST RETNUL TRNE AC4,RASSOC ;RIGHT ASSOCIATIVE? IORM AC4,2(R) ;SET ACCOCIATIVITY BIT ;HERE TO RETURN A NULL LEXEME TO THE CALLER RETNUL: MOVE R,NULLL ;FETCH NULL LEXEME TRZ FF,PIR ;INDICATE NOT TO PRINT RESULT RETURN
;ROUTINE TO PREPARE OPERANDS FOR UNARY AND BINARY ;RETURN OP PACKED IN AC1, AND INTERNAL NAME OF FN OR SFN IN AC2 PREPOP: HLRZ AC4,S ;GET NUMBER OF ARGS CAIL AC4,2 ;MUST BE TWO ARGS CAILE AC4,3(AC3) ;BUT NOT MORE THAN MAX JRST WRNGNB ;WRONG NUMBER OF ARGS CALL OPSTR ;PROCESS FIRST ARGUMENT ADDI ARGP,1 ;POINT TO RH ARG HRRZ B,(CAR) ;RESTORE CURRENT AR BASE CALL EVALID ;EVAL TO AN ID ILLTYPE ;NOT POSSIBLE, ERROR HRRZ AC2,@ARGP ;OK. AC2_INTERNAL NAME OF IDT ENTRY CAIN AC2,%NULL ;IS THE ID NULL (FOR ERASING) JRST ERASOP ;YES GO ERASE OP CAIG AC4,2 ;IS THERE THIRD ARG CALL DEFPRC ;NO, DEFAULT IT ADDI ARGP,1 ;ADVANCE TO NEXT ARG CALL ARGPRP ;GET PRECEDENCE ILLTYPE ;MUST BE ATOMIC CAIE T,U.INT/2 ;MUST ALSO BE INT ILLTYPE CAIL R,1 ;TEST ARGUMENT RANGE CAIL R,100000 SFNERR MSG(ARGOR) ;ARGUMENT OUT OF RANGE HRR AC3,R ;SET PRECEDENCE CAIG AC4,3 ;IS THERE A FOURTH ARG CALL DEFASS ;DEFAULT THE ASSOCIATIVITY ADDI ARGP,1 ;ADVANCE TO NEXT ARG HRRI AC4,0 ;CLEAR COUNT CALL ARGPRP ;REDUCE IT JRST CKPRST ;SHOULD BE A STRING CAIE T,U.CHAR/2 ;BUT MIGHT ALSO BE CHAR ILLTYPE GOTPRC: CAIE R,"R" ;IS IT R CAIN R,"R"+40 ;OR LITTLE R TROA AC4,RASSOC ;RIGHT ASSOCIATIVE CAIA RETURN CAIE R,"L" ;HOW ABOUT AN L CAIN R,"L"+40 ;OR LITTLE L RETURN SFNERR MSG(ASNLR) ;ASSOCIATIVITY NOT L OR R CKPRST: CAIE T,U.STRING ;IS IT A STRING? ILLTYPE HRRZ R,(R) ;GET DZADR OF STRING BLOCK SKIPN 1(R) ;IS LENGTH = 0? SFNERR MSG(ASNLR) ;ASSOCIATIVITY NOT L OR R LDB R,[POINT 7,2(R),6] ;GET CHARACTER JRST GOTPRC ;GO BACK TO CHARACTER CODE ERASOP: SETZB AC2,AC3 ;PUT ZEROES IN EVERYTHING SETZ AC4, ;TO INDICATE NO DEFINITION RETURN ;AND DO THINGS NORMALLY DEFPRC: TRNE AC3,1 ;UNARY CALL? SKIPA AC3,[LXM(STAK,ID,%DEF.B)] ;NO, MAKE BINARY LEXEME MOVE AC3,[LXM(STAK,ID,%DEF.U)] ;MAKE UNARY LEXEME MOVEM AC3,@ARGP ;CLOBBER STACK WITH DEFAULT VALUE HRLZI AC3,400000 ;CLEAR AC3 AND FLAG DEFAULT CASE JRST CPOPJ1 ;GO EVAL IT DEFASS: HRLZI AC4,400000 ;FLAG ASSOC DEFAULTED HRRZI R,%DEF.A ;GET INTERNAL NAME OF DEF.ASSOC HRLI R,(LXM(STAK,ID)) ;MAKE AN ID LEXEME MOVEM R,@ARGP ;CLOBBER OLD ARG JRST CPOPJ1
;CONVERT STRING ARGUMENT TO OPERATOR ;RETURN WITH STRING IN AC1 OPSTR: CALL ARGPRP ;COERCE AND SET UP ARG CAIE T,U.STRING ;COME HERE FOR NON-ATOMIC. STRING? ILLTYPE ;NO, ATOMIC OR NOT STRING HRRZ B,(R) ;OK, GET DZ ADDR OF STRING BLOCK GET R2,UDUBF ;GET # OF CHARACTERS IN STRING CAIL R2,1 ;MUST BE 1 TO 4 CAILE R2,4 SFNERR MSG(ILGOP) ;ILLEGAL OP DEFINITION MOVE R2,[POINT 7,2(B)] ;OK, PREPARE TO UNPACK AND PACK MOVEI AC1,0 NXTOPC: ILDB R,R2 ;GET NEXT OP CHARACTER JUMPE R,PRPOPX ;EXIT IF OUT OF CHARACTERS LSH AC1,6 ;OK, PUT IT ON TO OP STRING IORI AC1,-40(R) ROT R,-1 ;DIVIDE CHAR CODE BY 2 JUMPGE R,.+2 ;REMAINDER 1? SKIPA R,CTTBL(R) ;YES, USE RH ENTRY MOVS R,CTTBL(R) ;NO, USE LH ENTRY TRNE R,PUNCT ;LEGAL OP CHARACTER? JRST NXTOPC ;YES, CONTINUE SFNERR MSG(ILGOP) ;ILLEGAL OP DEFINITION PRPOPX: CALL TOKSRC ;SEE IF OP IS A SPECIAL TOKEN RETURN ;NO, DEFINITION IS OK SFNERR MSG(ILGOP) ;ILLEGAL OP DEFINITION
;OPERATOR UTILITY ROUTINES ; UNARY.PREC(S) - RETURN UNARY PRECEDENCE OF OP SUPREC: EXP 1 ;TAKES ONE ARG CALL OPSTR ;CONVERT IT TO AN OPERATOR STRING CALL FINDOP ;LOOK UP OPERATOR JRST RETZER ;RETURN ZERO IF NOT FOUND ADD R,@OPTP ;GET ABS ADDRESS OF OP ENTRY HLRZ R,2(R) ;GET UNARY PRECEDENCE JRST RETINT ;RETURN AS AN INT ; BINARY.PREC(S) - RETURN BINARY PRECEDENCE OF OP SBPREC: EXP 1 ;TAKES ONE ARG CALL OPSTR ;CONVERT IT TO AN OPERATOR STRING CALL FINDOP ;LOOK UP OPERATOR JRST RETZER ;RETURN ZERO IF NOT FOUND ADD R,@OPTP ;GET ABS ADDRESS OF OP ENTRY HRRZ R,2(R) ;GET BINARY PRECEDENCE TRZA R,RASSOC ;CLEAR ASSOCIATIVITY IF SET RETZER: SETZ R, ;SET R TO ZERO RETINT: MOVEI T,U.INT/2 ;RETURN AS AN INT JRST SRETRN ;MAKE DATA BLOCK AND RETURN ; ASSOCIATIVITY(S) - RETURNS 'L OR 'R (OR BLANK IF NOT BOUND) SASSOC: EXP 1 ;TAKES ONE ARG CALL OPSTR ;CONVERT IT TO AN OPERATOR STRING CALL FINDOP ;LOOK IT UP JRST RETNST ;RETURN THE NULL STRING ADD R,@OPTP ;GET ABS ADDRESS OF OP ENTRY HRRZ AC1,2(R) ;GET BINARY PREC VALUE MOVE AC2,[ASCII /LEFT/] ;ASSUME LEFT ASSOC TRNE AC1,RASSOC ;SKIP IF REALLY IS LEFT MOVE AC2,[ASCII /RIGHT/] ;NO REALLY RIGHT CAIN AC1,0 ;BUT MAKE SURE WHOLE WORD NOT ZERO JRST RETNST ;RETURN A NULL STRING MOVEI AC1,4 ;ASSUME 4 FOR LEFT CAMN AC2,[ASCII /RIGHT/] ;CHECK IF RIGHT MOVEI AC1,5 ;THEN LENGTH IS 5 RETSST: CALL MKBLK ;MAKE A STRING BLOCK BLKARG U.STRING,3 HRRZM AC1,1(R2) ;SET STRING LENGTH MOVEM AC2,2(R2) ;PUT IN STRING HRLI R,(LXM(STAK,CONST)) ;RETURN A LEXEME RETURN ; UNARY.DEF(S) - RETURNS THE DEFINITION OF OPERTOR SUDEF: EXP 1 ;TAKES ONE ARG CALL OPSTR ;CONVERT ARG TO OP STRING CALL FINDOP ;LOOK IT UP JRST RETNST ;RETURN THE NULL STRING ADD R,@OPTP ;GET ABS ADDRESS HLRZ AC2,1(R) ;GET UNARY DEF JUMPE AC2,RETNST ;UNDEFINED ADD AC2,@IDTP ;GET ADDRESS IN IDT JRST IDSTRG ;FALL INTO CODE FOR TYPE ; BINARY.DEF(S) - RETURNS THE DEFINITION OF OPERTOR SBDEF: EXP 1 ;TAKES ONE ARG CALL OPSTR ;CONVERT ARG TO OP STRING CALL FINDOP ;LOOK IT UP JRST RETNST ;RETURN THE NULL STRING ADD R,@OPTP ;GET ABS ADDRESS HRRZ AC2,1(R) ;GET BINARY DEF JUMPE AC2,RETNST ;UNDEFINED ADD AC2,@IDTP ;GET ADDRESS IN IDT JRST IDSTRG ;FALL INTO CODE FOR TYPE RETNST: CALL MKBLK ;MAKE A STRING BLOCK BLKARG U.STRING,2 SETZM 2(R2) ;MAKE NULL STRING HRLI R,(LXM(STAK,CONST)) ;RETURN A LEXEME POINTING TO IT RETURN
;OPERATOR ENUMERATION ROUTINE ; OPERATORS - RETURNS TUPLE OF STRINGS OF DEFINED OPERATORS SOPERA: EXP 0 ;TAKES NO ARGS SOS ARGP,TOP ;MAKE STACK OK FOR LATER TUPLE STUFF HRRZ R,@OPTP ;GET ABS ADDR OF OPT SETCM AC3,(R) ;PUT -WLENGTH-1 IN LH(AC3) HRRI AC3,1 ;GET INTERNAL NAME OF FIRST OP SUBI AC3,3 ;SET UP CORRECTLY FOR FIRST TIME THRU ENOPLP: ADD AC3,[3,,3] ;INCREMENT POINTER JUMPGE AC3,MKIDL2 ;GO MAKE TUPLE OF THE OPS HRRZI AC1,(AC3) ;GET INTERNAL NAME OF NEXT OP ADD AC1,@OPTP ;GET ABS ADDRESS MOVE AC1,(AC1) ;GET SIXBIT NAME SETZB AC2,AC4 ;SET OP WORD AND CHAR COUNT TO ZERO OPCHLP: LSHC AC1,-6 ;SHIFT OUT A SIXBIT CHAR LSH AC2,-1 ;MOVE IT OVER ONE BIT TLCE AC2,200000 ;EFFECTIVELY ADD 40 TO THE CHAR TLO AC2,400000 ; TO MAKE IT ASCII ADDI AC4,1 ;INCREMENT CHAR COUNT JUMPN AC1,OPCHLP ;GO BACK IF MORE CHARACTERS CALL MKBLK ;GET A STRING BLOCK BLKARG U.STRING,3 MOVEM AC4,1(R2) ;LOAD CHAR COUNT MOVEM AC2,2(R2) ;PUT OPERATOR STRING THERE MOVE AC1,R ;GET ADDRESS HRLI AC1,(LXM(STAK,CONST)) ;MAKE A LEXEME POINTING TO IT CALL STACK ;PUT IT ON THE STACK JRST ENOPLP ;GO BACK FOR MORE
;DOUBLE PRECISION COMPARISON ROUTINES ;COMPARE (R,R2) TO (AC1,AC2). SKIP IF THE CONDITION HOLDS DCMPL: CAMN R,AC1 ;...SKIP IF < CAML R2,AC2 CAMGE R,AC1 AOS (P) RETURN DCMPLE: CAMN R,AC1 ;...SKIP IF <= CAMLE R2,AC2 CAMGE R,AC1 AOS (P) RETURN DCMPG: CAMN R,AC1 ;...SKIP IF > CAMG R2,AC2 CAMLE R,AC1 AOS (P) RETURN DCMPGE: CAMN R,AC1 ;...SKIP IF >= CAMGE R2,AC2 CAMLE R,AC1 AOS (P) RETURN DCMPE: CAMN R,AC1 ;...SKIP IF = CAME R2,AC2 RETURN AOS (P) RETURN REPEAT 0,< ;------NEVER CALLED DCMPN: CAMN R,AC1 ;...SKIP IF # CAME R2,AC2 AOS (P) RETURN > ;------ ;***** NOTE ****** THESE WORK ONLY FOR PROPERLY NORMALIZED DOUBLE ;PRECISION ARGUMENTS.
; ERASE(A, B, ...): IF NULL ARG, RESTARTS PPL. IF ONE OR MORE ;ARGS, ZEROES THEIR SYMBOL TABLE ENTRIES. THE USER IS NOT PROTECTED ;AGAINST ERRORS CAUSED BY ATTEMPTS TO ACCESS DATA WHOSE DEFINITIONS ;HAVE BEEN DELETED. SERASE: XWD 0,-1 ;TAKES ANY NUMBER OF ARGS JUMPE ARGP,PPLRST ;IF NO ARGS, START PPL OVER MOVEI AC1,SERS1 ;SET UP ADR OF ROUTINE TO CALL JRST RPTARG ;SEQUENCE DOWN ARGLIST, THEN RETURN NULL SERS1: CALL EVLIDN ;EVAL TO AN ID, SKIP IF OK. ERSERR: SFNERR MSG(ERSER) ;IMPROPER ARGUMENT TO ERASE HRRZ L,@ARGP ;GET INTERNAL NAME OF ID CAIGE L,FSTRDF ;DON'T ERASE BUILT-IN DEFS OR TOKENS JRST ERSERR ADD L,@IDTP ;OK, POINT TO STE IN IDT SETZM (L) ;CLEAR SYMBOL TABLE ENTRY RETURN ; SYS -- SOFTLY EXIT TO THE MONITOR (LIKE ^C) SMONIT: EXP 0 ;TAKES NO ARGS EXIT 1, ;EXIT QUIETLY JRST RETNUL ;RETURN NULL IF .CONT OR .REE TYPED ; LOGOUT -- CLOSE ALL OPEN FILES AND CALL LOGOUT. SLOGOU: EXP 0 ;TAKES NO ARGS MOVEI AC1,CLSOPN ;ROUTINE TO CALL TO CLOSE FILE IF OPEN PUSHJ P,ALLFCB ;ITERATE OVER ALL FILE BLOCKS MOVEM P,CRSHSV+P ;SAVE P (ALL AC'S CLOBBERED BY RUN UUO) SETZ FF, ;CLEAR SOME AC'S MOVEI AC6,AC1 BLT AC6,AC6 MOVSI FF,'SYS' ;SETUP ARGLIST FOR SYS:LOGOUT MOVE AC1,[SIXBIT\LOGOUT\] RUN AC6, ;RUN IT (SHOULDN'T RETURN) MOVE P,CRSHSV+P ;ERROR RETURN, RESTORE P SETZ FF, ;CLEAR FLAGS PUSHJ P,IOINI ;CLEAR THE WORLD I/O-WISE SFNERR MSG(LGOER) ;LOGOUT RUN FAILURE
; ADDITIONAL FUNCTIONS FOR PREDICATE HANDLING ;CENTRAL ROUTINE IDPRD: CALL EVLIDN ;MAKE AN ID JRST RETF ;RETURN FALSE HRRZ R,@ARGP ;GET INTERNAL NAME ADD R,@IDTP ;GET ABSOLUTE ADDRESS HRRZ R2,(R) ;GET ID PTR IF NEEDED HLRZ R,(R) ;GET ID TYPE XCT (AC1) ;EXECUTE CALLING INSTRUCTION JRST RETF ;NOT THE SAME RETT: MOVEI R,1 ;GET BOOL TRUE JRST BRETRN ;RETURN THE BOOL RETF: MOVEI R,0 ;RETURN FALSE JRST BRETRN SUNASS: EXP 1 JSP AC1,IDPRD CAIE R,0 ;UNASSIGNED VARS HAVE VALUE 0 SSYSTE: EXP 1 JSP AC1,IDPRD CAIE R,7 ;SYSTEM FUNCTIONS ARE 7 SUSER.: EXP 1 JSP AC1,IDPRD CAIE R,2 ;USER FNS ARE 2 SCOMPO: EXP 1 JSP AC1,IDPRD JRST .+1 ;CHECK FOR COMPOSITE TYPES SPECIALLY CAIE R,3 ;IS IT A NON-ATOMIC DEF JRST RETF ;NO HLRZ R,(R2) ;GET FIRST WORD OF PZ BLOCK TRZ R,700000 ;ISOLATE TYPE FIELD CAIN R,B.ALT ;COULD ALSO BE AN ALTERNATIVE DEF JRST RETF JRST RETT SATOMI: EXP 1 JSP AC1,IDPRD CAIE R,6 ;ATOMIC TYPES ARE 6 SSELEC: EXP 1 JSP AC1,IDPRD CAIE R,4 ;SELECTOR NAMES ARE 4 SALTER: EXP 1 JSP AC1,IDPRD JRST .+1 ;CHECK FOR ALTERNATES IN TWO PLACES CAIN R,10 ;RESERVED WORDS ARE OK JRST RETT CAIE R,3 ;OTHERWISE MUST BE NON-ATOMIC DEF JRST RETF HLRZ R,(R2) ;GET FIRST WORD OF PZ BLOCK TRZ R,700000 ;ISOLATE TYPE CAIN R,B.ALT ;MUST BE ALT JRST RETT JRST RETF SVARCK: EXP 1 ;TEST FOR VARIABLE JSP AC1,IDPRD CAIE R,1 ;VARIABLES ARE ONE SCLASS: EXP 1 CALL EVALID ;MAKE SURE THE ARG IS AN ID JRST RETNST ;RETURN NULL STRING IF NOT ID HRRZ R,@ARGP ;GET INTERNAL NAME ADD R,@IDTP ;GET ABS ADDRESS HRRZ R2,(R) ;GET VALUE PTR IF NEEDED HLRZ R,(R) ;GET ID TYPE XCT CLCKTB(R) ;DISPATCH ON TYPE ;RETURNING PTR(STRING BLOCK) IN AC1 MOVE AC2,(AC1) ;GET LENGTH ADDI AC2,4 ;COMPUTE NUMBER OF WORDS IDIVI AC2,5 CALL MKBLK ;MAKE A STRING BLOCK BLKARG U.STRING,2(AC2) ADDI AC2,1(R2) ;COMPUTE FINAL ADDRESS FOR BLT HRRZI AC3,1(R2) ;MAKE THE BLT REG HRLI AC3,(AC1) BLT AC3,(AC2) ;DO THE TRANSFER HRLI R,(LXM(STAK,CONST)) ;RETURN A CONSTANT RETURN CLCKTB: MOVEI AC1,CUNASS ;UNASSIGNED VARIABLE MOVEI AC1,CVARIA ;NORMAL VARIABLE MOVEI AC1,CUSRFN ;USER FUNCTION CALL CCKDDF ;FURTHER CHECKING REQUIRED FOR DDEFS MOVEI AC1,CSELEC ;SELECTOR NAME ILLTYPE ;CEV? MOVEI AC1,CATOMI ;ATOMIC TYPE MOVEI AC1,CSYSFN ;SYSTEM FN MOVEI AC1,CALTER ;RESERVED WORD (ALTERNATE) CCKDDF: MOVEI AC1,CCOMPO ;ASSUME COMPOSTITE TYPE FOR NOW HLRZ R2,(R2) ;GET FIRST WORD OF PZ BLOCK TRZ R2,700000 ;ISOLATE TYPE CAIN R2,B.ALT ;SEE IF AN ALT MOVEI AC1,CALTER ;YES RETURN DEFINE STRBLK (S) < NCHRS==0 IRPC S,<NCHRS==NCHRS+1> EXP NCHRS ASCII /S/ > CUNASS: STRBLK <UNASSIGNED> CVARIA: STRBLK <VARIABLE> CUSRFN: STRBLK <USER.FN> CCOMPO: STRBLK <COMPOSITE.TYPE> CSELEC: STRBLK <SELECTOR.NAME> CATOMI: STRBLK <ATOMIC.TYPE> CSYSFN: STRBLK <SYSTEM.FN> CALTER: STRBLK <ALTERNATE.TYPE>
; ROUTINES TO RETURN SUBSETS OF THE ENVIRONMENT AS TUPLES OF STRINGS ; EACH CALL THE FOLLOWING SYSTEM ROUTINE AFTER LOADING TSTTYP WITH THE ; ADDRESS OF THE CORRECT SELECTION ROUTINE. MKIDL: SOS ARGP,TOP ;DECREMENT THE CAR STACK TOP MOVEI AC1,PSHIDS ;LOAD ADDRESS OF PUSH ID ROUTINE CALL ENUIDT MKIDL2: MOVE L,TOP ;GET THE NUMBER OF ARGS SUB L,ARGP JRST IMAKTUP ;GO MAKE A TUPLE OUT OF THE STRINGS PSHIDS: SAVE <AC1,AC2> ;SAVE SOME REGS CALL @TSTTYP ;GO CHECK TYPE JRST X21 ;HERE IF IT IS NOT THE PROPER TYPE CALL IDSTRG ;CONVERT ID TO STRING LEXEME IN R MOVE AC1,R ;GET LEXEME PUSHJ P,STACK ;PUT IT ON CAR STACK JRST X21 ;RESTORE REGS AND RETURN SFUNCT: EXP 0 ;ENUMERATE USER FNS HRRI AC4,CHKUFN ;SETUP TEST ROUTINE HRRM AC4,TSTTYP JRST MKIDL CHKUFN: HLRZ R,(AC2) ;CHECK TYPE FOR FN CAIE R,I.FN RETURN JRST CPOPJ1 ;SKIP RETURN SDATA.: EXP 0 ;ENUMERATE USER DATA DEFS HRRI AC4,CHKDDF ;SETUP TEST HRRM AC4,TSTTYP JRST MKIDL CHKDDF: HLRZ R,(AC2) ;GET TYPE CAIE AC1,U.STRING ;DON'T LIST STRING CAIE R,I.DDEF ;OR NON DDEFS RETURN CAIN AC1,U.TUPLE ;OR TUPLE RETURN JRST CPOPJ1 SVARIA: EXP 0 ;ENUMERATE ASSIGNED VARS HRRI AC4,CHKVAR ;SETUP TEST HRRM AC4,TSTTYP JRST MKIDL CHKVAR: HLRZ R,(AC2) ;GET TYPE CAIE R,I.VAR ; IS IT A VARIABLE RETURN MOVEI R2,BIVTAB ;SETUP LOOP TO TEST INTIAL VALUES BIVL: SKIPN (R2) ;ALL DONE JRST CPOPJ1 ;SKIP RETURN CAMN AC1,(R2) ;IS THIS VAR BUILT IN RETURN ;YES AOJA R2,BIVL ;TRY THE NEXT ONE DEFINE BIV(A,B) < EXP %'A > BIVTAB: BIVS EXP 0
;NTYPE(X) - RETURN AN INTERNAL NUMBER REPRESENTING A DATA TYPE. SNTYPE: EXP 1 ;TAKES ONE ARG CALL MKCNST ;COERCE TO A VALUE ILLTYP ;ERROR MOVE L,@ARGP ;GET LEXEME MOVE L,(L) ;GET PZ WORD FOR ADDRESSED DATUM LGET BLTF ;R_BLOCK TYPE FIELD MOVEI T,U.INT/2 ;RETURN AS AN INT JRST SRETRN ;CONSTRUCT DATA BLOCK AND LEXEME ; TYPE(X) -RETURN THE DATA TYPE OF X AS A STRING STYPE: EXP 1 ;TAKES ONE ARG CALL MKCNST ;COERCE TO A VALUE ILLTYP ;ERROR MOVE L,@ARGP ;GET THE LEXEME MOVE L,(L) ;GET ADDRESSED PZ WORD LGET AC2,BLTF ;EXTRACT BLOCK TYPE FIELD ADD AC2,@IDTP ;USE AS INDEX INTO IDT CALL IDSTRG RETURN IDSTRG: HRLI AC2,(POINT 6,0,35) ;PREPARE TO LOAD WORD COUNT BYTE ILDB R,AC2 ;GET WORD COUNT BYTE IMULI R,6 ;COMPUT MAX POSSIBLE NUMBER OF CHARACTERS SUBI R,7 MOVE AC1,[POINT 7,LXBUF+1] ;SET UP STORAGE BYTE POINTER SETZM LXBUF ;CLEAR UPPER BOUND FIELD STYPE1: ILDB R2,AC2 ;GET A SIXBIT CHARACTER JUMPE R2,STYPE2 ;TERMINATE CONSTRUCTION IF BLANK ADDI R2,40 ;CONVERT TO ASCII IDPB R2,AC1 ;STORE IT IN LXBUF AOS LXBUF ;ADD ONE TO UPPER BOUND FIELD SOJG R,STYPE1 ;GO BACK IF COUNT HAS NOT RUN OUT STYPE2: CALL CLRBYT ;ZERO REST OF LAST WORD SUBI AC1,LXBUF ;COMPUTE SPACE USED CALL MKBLK ;CONSTRUCT A STRING BLOCK BLKARG U.STRING,2(AC1) ADDI AC1,1(R2) ;AC1 POINTS TO LAST WORD OF BLOCK ADD R2,[XWD LXBUF,1];CONSTRUCT BLT POINTER BLT R2,(AC1) ;TRANSFER STRING TO NEW BLOCK HRLI R,(LXM(STAK,CONST)) ;RETURN A LEXEME POINTING TO IT RETURN
;*** STOP AND TRACE *** ;THE FUNCTION CALL STOP(F,S1,S2, ... ,SK) SETS STOP CODES ON ;STATEMENTS S1,S2, ... ,SK OF FUNCTION F. S1,S2, ... ,SK MUST BE ;INTEGERS. ;THE CALL STOP(F) SETS STOP CODES ON EVERY STATEMENT OF F. ;SIMILARLY FOR UNSTOP, TRACE, UNTRACE. SSTOP: XWD 0,-1 ;SET STOP BITS MOVEI AC1,STP1 ;SET UP ADDR OF STOP BIT SET ROUTINE JRST CMSQR ;GO TO COMMON ARG SEQUENCING ROUTINE STRACE: XWD 0,-1 ;SET TRACE BITS MOVEI AC1,TRC1 JRST CMSQR SUNSTO: XWD 0,-1 ;REMOVE STOP BITS MOVEI AC1,UNSTP1 JRST CMSQR SUNTRA: XWD 0,-1 ;REMOVE TRACE BITS MOVEI AC1,UNTRC1 ;FALL INTO CMSQR... ;COMMON SEQUENCING ROUTINE FOR STOP/TRACE. ON ENTRY, AC1 SHOULD CONTAIN ;THE ADDRESS OF A ROUTINE TO BE CALLED FOR EVERY LINE TO BE TRACED. ;CMSQR PROCESSES THE ARGUMENT LIST AND CALLS THE GIVEN ROUTINE, ;SUPPLYING, IN AC2, THE DZ ADDRESS OF THE LINE TO BE MARKED. CMSQR: JUMPE ARGP,WRNGNB ;ERROR IF NO ARGS HLRZ AC4,S ;FETCH NUMBER OF ARGS MOVE L,@ARGP ;GET FIRST "REAL" ARG LGET R,LTYPF ;GET LEXEME TYPE FIELD GET R2,FNF ;R2_PZ ADR OF FUNCTION CURRENTLY BEING EXECUTED CAIN R,PROCID ;IS FIRST ARG THE PROCEDURE ID? JRST CMSQR1 ;YES. R2 CONTAINS PZ ADR OF FN WE WANT TO MARK CAIE R,ID ;NO, A REGULAR ID? CAIN R,$ID ;OR A DOLLAR ID JRST .+2 ;YES JRST STERR ;NO. IMPROPER FIRST ARG ADD L,@IDTP ;YES. GET ABS ADR OF STE FOR THIS ID HLRZ R2,(L) ;GET IDENTIFIER TYPE FIELD CAIE R2,I.FN ;IDENTIFIER A USER-DEFINED FN? STERR: SFNERR MSG(ILLST) ;.IMPROPER ARG TO STOP/TRACE HRRZ R2,(L) ;GET PZ ADR OF FN BLOCK HLRZ R,(R2) ;IS IT REALLY A FN? (COULD BE LSB IF CAIE R,B.FN(SYSBIT) ; TRANSLATION ERROR OCCURRED) SFNERR MSG(STUNX) ;.CAN'T STOP/TRACE UNEXECUTABLE FN
;COME HERE WITH R2 CONTAINING PZ ADR OF SELECTED FN BLOCK CMSQR1: HRRZ B,(R2) ;GET DZ ADR OF FN BLOCK GET AC3,LINESF ;GET NUMBER OF LINES, INCLUDING LINE 0 SOJG AC4,.+3 ;MORE THAN ONE ARG IN STOP/TRACE CALL? MOVEI AC4,-1(AC3) ;NO. MARK ALL (NONZERO) LINES. TROA FF,STRFLG ;SET FLAG TO SIGNAL MARKING ALL LINES TRZ FF,STRFLG ;YES. MARK ONLY SELECTED LINES. MOVE AC6,B ;SAVE DZ ADR OF FN BLOCK ;COME HERE TO STOP/TRACE ONE LINE CMSQR2: TRNE FF,STRFLG ;CHECK SELECTED/ALL FLAG SKIPA R,AC4 ;ALL. USE LINE COUNT AS STATEMENT NO. AOSA ARGP ;SELECTED. SEQUENCE DOWN ARGLIST JRST CMSQR3 ;ALL. GO DIRECTLY TO MARKING CALL CALL ARGPRP ;SELECTED. COERCE THE ARG AT ARGP JRST STERR ;NON-ATOMIC ARG, ERROR. CAMGE R,AC3 ;ERROR IF LINE NUMBER OUT OF RANGE CAIE T,U.INT/2 ;OR IF NOT AN INT JRST STERR JUMPLE R,STERR CMSQR3: ROT R,-1 ;DIVIDE SELECTED LINE NO. BY 2 ADDI R,3(AC6) ;COMPUTE ABS ADDR OF LINE ENTRY IN FN BLOCK SKIPGE R ;CHECK REMAINDER ON DIVISION SKIPA R,(R) ;1. TAKE RH ENTRY MOVS R,(R) ;0. TAKE LH ENTRY HRRZ AC2,(R) ;AC2_DZ ADR OF LINE BLOCK PUSHJ P,(AC1) ;CALL APPROPRIATE MARKING ROUTINE SOJG AC4,CMSQR2 ;GO BACK TO MARK MORE LINES JRST RETNUL ;WHEN DONE, RETURN NULL LEXEME ;STOP/TRACE MARKING ROUTINES ;ENTER WITH AC2= ADDR-1 OF WORD WHERE BIT IS TO BE SET OR CLEARED STP1: MOVSI AC5,(STPBIT) ;SET STOP BIT IORM AC5,1(AC2) POPJ P, UNSTP1: MOVSI AC5,(STPBIT) ;CLEAR STOP BIT ANDCAM AC5,1(AC2) POPJ P, TRC1: MOVSI AC5,(TRCBIT) ;SET TRACE BIT IORM AC5,1(AC2) POPJ P, UNTRC1: MOVSI AC5,(TRCBIT) ;CLEAR TRACE BIT ANDCAM AC5,1(AC2) POPJ P, ;BACKTRACE - PRINTS A SIMPLE LISTING OF THE FUNCTIONS ENTERED ON ; THE TELETYPE. SBACKT: EXP 0 ;TAKES NO ARGS SAVE <B> ;SAVE CURRENT AR BASE BTLOOP: SKIPN 1(B) ;CHECK FOR TOP-LEVEL JRST BTDONE ;TOP LEVEL FOUND CALL PWHERE ;USE ROUTINE FROM STOP/TRACE TTOS [SIXBIT/#/] ;CRLF GET AC1,CRF ;GET CALLER FIELD HRRZ B,(AC1) ;GET DZADR OF CAR JRST BTLOOP BTDONE: RESTORE <B> ;RESTORE CURRENT AR BASE JRST RETNUL ;RETURN NULL
;GETBYTE(FIRST,LAST,WORD) ;EXTRACT THE "FIRST" THRU THE "LAST" BITS FROM "WORD", AND RETURN THE ; BYTE AS AN INT. ALL ARGS MUST BE INTS, "FIRST" AND "LAST" FROM ; 0 TO 35, AND "FIRST" .LE. "LAST" SGETBY: EXP 3 ;TAKES 3 ARGS PUSHJ P,SETBPT ;SETUP BYTE PTR AND WORD ARG LDB R,R2 ;EXTRACT THE BYTE JRST SRETRN ;RETURN RESULT AS AN INT ;SETBYTE(BYTE,FIRST,LAST,WORD) ;STORE "BYTE" IN THE "FIRST" THRU "LAST" BIT POSITIONS OF "WORD", AND ; RETURN THE RESULTING WORD AS AN INT. SPUTBY: EXP 4 ;TAKES 4 ARGS PUSHJ P,GETINT ;GET BYTE TO BE PACKED MOVE AC1,R ;SAVE THE RESULT PUSHJ P,SETBPT ;SETUP BYTE PTR AND WORD ARG DPB AC1,R2 ;STORE THE BYTE JRST SRETRN ;RETURN THE RESULT AS AN INT ;ROUTINE TO PROCESS THE "FIRST", "LAST", AND "WORD" ARGUMENTS FOR GETBYTE ; AND SETBYTE. RETURNS "WORD" IN R AND A BYTE POINTER IN R2. SETBPT: CALL INT035 ;FETCH "FIRST" ARG PUSH P,R ;SAVE IT ON STACK CALL INT035 ;FETCH "LAST" ARG SUBM R,(P) ;COMPUTE DIFFERENCE, PLACE ON STACK AOSG R2,(P) ;R2_BYTE SIZE SFNERR MSG(ARGOR) ;ARG OUT OF RANGE SUBI R,^D35 ;R_ - # OF BITS TO RIGHT OF BYTE MOVNI R,-<R_6>(R) ;MAKE POSITIVE, SETUP DESTINATION ASH R2,^D12 ;LEFT-JUSTIFY SIZE IN RIGHT HALF WORD HRLI R,(R2) ;PUT IN LH ROT R,-6 ;ROTATE TO FINISH OFF CONSTRUCTION OF BYTE PTR MOVEM R,(P) ;SAVE RESULT ON STACK CALL GETINT ;GET THE "WORD" ARGUMENT POP P,R2 ;POP BYTE PTR INTO R2 POPJ P, ;RETURN
;ROUTINE TO FETCH AN INTEGER ARGUMENT AND ENSURE THAT IT IS IN THE RANGE ; 0 TO 35 INT035: PUSHJ P,GETINT ;GET AN INTEGER CAIG R,^D35 ;CHECK RANGE JUMPGE R,CPOPJ SFNERR MSG(ARGOR) ;ARG OUT OF RANGE ;ROUTINE TO FETCH AN INTEGER ARGUMENT GETINT: CALL GRAB1 ;RETURN ATOMIC ARG CAIN T,U.INT/2 ;INTEGER? AOJA ARGP,CPOPJ ;YES, ADVANCE ARGP AND RETURN ILLTYP ;NO, IMPROPER ARGUMENT TYPE IFN FTBAKG,< ;BACKGROUND() - ENTER BACKGROUND MODE (I.E. DON'T RUN UNLESS NOBODY ; ELSE WANTS TO RUN) SBACKG: EXP 0 ;PARAMETERLESS PROCEDURE MOVEI R,AP.CLK ;SET CLOCK-ENABLE BIT IN WORD IORB R,ENBWRD JRST SETCLK ;GO SET NEW ENABLE BITS AND RETURN ;FOREGROUND() - CANCEL BACKGROUND MODE SFOREG: EXP 0 ;PARAMETERLESS PROCEDURE MOVEI R,AP.CLK ;CLEAR CLOCK-ENABLE BIT IN WORD ANDCAB R,ENBWRD SETCLK: MOVEI R2,INITIC ;RESET CLOCK INTERVAL COUNTER MOVEM R2,JIFCNT ; TO 10 SECONDS, TO ALLOW INTERACTION APRENB R, ;SET NEW ENABLE BITS JRST RETNUL ;RETURN NULL AS VALUE OF CALL >
IFN CHARIO,< ;GETCHAR - TAKES IN A SINGLE CHARACTER SGETCH: EXP 0 INCHRW R ;GET CHARACTER MOVEI T,U.CHAR/2 ;IT IS A CHARACTER JRST SRETRN ;RETURN ;SENDCHAR(C) - SENDS INT OR CHAR C TO THE TTY AS AN IMAGE CHARACTER SSENDC: EXP 1 ;TAKES ONE ARG CALL GRAB1 ;GET ONE ATOMIC ARG CAIN T,U.INT/2 ;IS IT AN INT JRST .+3 ;YES, OK CAIE T,U.CHAR/2 ;OR MAYBE A CHARACTER ILLTYPE ;NONE OF THE ABOVE IONEOU R ;OUTPUT R AS AN IMAGE CHARACTER JRST RETNUL ;RETURN NULL > IFE MITS,< ;SOME SPECIAL FUNCTIONS NEEDED FOR ATC DEMO ;SLEEP(N) - PUT JOB TO SLEEP FOR N SECONDS SSLEEP: EXP 1 CALL GRAB1 ;GET SINGLE ATOMIC ARG CAIE T,U.INT/2 ;MUST BE INT ILLTYPE SKIPLE AC1,R ;FETCH RESULT, CHECK FOR WITHIN RANGE CAILE AC1,^D63 SFNERR MSG(ARGOR) ;ARGUMENT OUT OF RANGE SLEEP AC1, ;ZZZZZZ JRST RETNUL ;DAYTIME() - RETURN TIME OF DAY IN MILLISECONDS SDAYTI: EXP 0 MSTIME R, ;RETURN TIME OF DAY IN MS MOVEI T,U.INT/2 ;MARK IT AS AN INT JRST SRETRN ;RETURN VALUE TO CALLER ;DATE - RETURN DATE AS A STRING DD-MMM-YY HH:MM:SS SDATE: EXP 0 ;TAKES NO ARGS CALL MKBLK ;MAKE A STRING BLOCK BLKARG U.STRING,6 ;2 WDS HEADER ; 4 WDS DATA HRLI R,(LXM(STAK,CONST)) ;RETURN A CONSTANT MOVEI AC1,^D18 ;EXACTLY 18 CHARS MOVEM AC1,1(R2) ;STORE LENGTH ADD R2,[POINT 7,2] ;SETUP OUTPUT BYTE PTR DATE AC1, ;GET THE DATE IDIVI AC1,^D31 ;EXTRACT THE DAY ADDI AC2,1 CALL PUT2D ;STORE TWO DIGITS IN DATE IDIVI AC1,^D12 ;SEPARATE MONTH AND YEAR MOVEI AC2,MONTAB(AC2) ;GET ADDRESS OF MONTH STRING HRLI AC2,(POINT 7) ;MAKE BYTE PTR ILDB AC3,AC2 ;LOOP TO GET CHARACTERS FROM MONTH NAME JUMPE AC3,.+3 ;FINISH ON ZERO CHAR IDPB AC3,R2 ;STORE CHARACTER IN STRING JRST .-3 ;GO BACK FOR MORE MOVEI AC2,"-" ;FILL WITH SECOND DASH IDPB AC2,R2 MOVEI AC2,^D64(AC1) ;OUTPUT YEAR CALL PUT2D MOVEI AC2,^D9 ;INSERT A TAB TO SEPARATE DATE AND TIME IDPB AC2,R2 MSTIME AC2, IDIVI AC2,^D1000 ;GET MILLISECS TO SECS IDIVI AC2,^D3600 ;GET HOURS MOVEI AC1,(AC3) ;SAVE MIN/SEC IN AC1 CALL PUT2D MOVEI AC2,":" ;USE COLON TO SEPARATE IDPB AC2,R2 IDIVI AC1,^D60 ;SEPARATE MINS AND SECS EXCH AC1,AC2 ;MUST DO IN OTHER ORDER CALL PUT2D MOVEI AC2,":" ;USE ANOTHER COLON TO SEPARATE IDPB AC2,R2 MOVEI AC2,(AC1) CALL PUT2D SETZ AC2, ;FILL OUT WORD WITH ZERO BYTES IDPB AC2,R2 IDPB AC2,R2 RETURN PUT2D: IDIVI AC2,^D10 ;SEPARATE TWO DIGITS ADDI AC2,"0" ;CONVERT TO A DIGIT ADDI AC3,"0" IDPB AC2,R2 ;STORE IN STRING IDPB AC3,R2 RETURN DEFINE MONMAC(A) < IRP A < ASCII /-A/ >> MONTAB: MONMAC <JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC> > ; END IFE MITS CONDITIONAL LIT END



Feel free to contact me, David Gesswein djg@pdp8online.com with any questions, comments on the web site, or if you have related equipment, documentation, software etc. you are willing to part with.  I am interested in anything PDP-8 related, computers, peripherals used with them, DEC or third party, or documentation. 

PDP-8 Home Page   PDP-8 Site Map   PDP-8 Site Search