File DATA.MA (MACREL macro assembler source file)

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

	TITLE	DATA - PPL DATA OPERATIONS (CONSTRUCTION, SELECTION)
	SUBTTL	T.STANDISH/EAT/ 19-NOV-72

	HISEG
	SEARCH	PPL

	SUBTTL	CODE FOR CONSTRUCTOR FUNCTIONS

;WE ENTER HERE FROM THE INTERPRETER WITH THE STACK IN
;   THE FOLLOWING FORM:
;	X1 X2 X3 ... XN F
;   WHERE THE FOLLOWING AC'S HAVE BEEN SETUP
;	L =	FNAPP(N)
;	TOP =	B,,PTR(X1)
;	ARGP =	B,,PTR(X1)
;	S =	N,,PZADR(DDEF)

;THIS CODE MAKES A STRUCTURE OR SEQUENCE, AND RETURNS A CONST LEXEME
;   POINTING TO IT AT THE STACK POSITION POINTED TO BY TOP.

;CFNAM IS AN INTERNAL LOW SEGMENT NAME CONTAINING THE IDT RELADR
;   OF THE NAME OF THE FUNCTION YOU JUST STARTED TO EXECUTE.

DODOP:	MOVE	AC1,(S)		;AC1_PZ WORD OF DDEF
	HLRZ	AC2,AC1		;SWITCH ON DDEF TYPE
	ANDCMI	AC2,(GCBIT+SYSBIT+CPYBIT) ;EXTRACT OFF GC,SYS,CPY BITS
	XCT	DTAB-B.STRUCT(AC2)	;DISPATCH ON DDEF BLOCK TYPE
DTAB:	JRST	CSTRUCT		;STRUCT-GO MAKE STRUCTURE
	EXERR	MSG(IUALT)	;IMPROPER USE OF ALTERNATE NAME
	JRST	CSEQ		;SEQ-GO MAKE POLYADIC SEQUENCE
	JRST	CVSEQ		;VSEQ-GO MAKE VARIADIC SEQUENCE

SUBTTL CONSTRUCT A STRUCTURE REPEAT 0, <THIS ROUTINE FIRST PROCESSES THE ARGUMENT LIST POINTED TO BY ARGP TO SUBSTITUTE VALUES FOR ALL LOCAL VARIABLES,NAMES,RELOCS AND SELECTION EXPRESSIONS. THIS REDUCES THE ARGLIST TO A LIST OF CONSTANTS. IT THEN CHECKS THE TYPES OF THE ELEMENTS IN THE ARGLIST TO SEE IF THEY ARE APPROPRIATE FOR USE IN THE GIVEN CONSTRUCTION, USING INFORMATION ABOUT COMPONENT TYPES EXTRACTED FROM THE DDEF BLOCK. ADDITIONALLY, IN THE CASE OF POLYADIC SEQUENCES AND STRUCTURES IT CHECKS TO SEE THAT THE LENGTH OF THE ARGLIST IS PROPER. IF THESE CHECKS SUCCEED, IT COPIES THE CONSTANTS IN THE ARGUMENT LIST AND CONSTRUCTS AN OBJECT OF THE APPROPRIATE SIZE AND COMPOSITION.> ;CODE TO MAKE A STRUCTURE. S=STE FOR DDEF CSTRUCT:SAVE <AC3,L> SAVE <S> ;SAVE S ACROSS ARGLSB PUSHJ P,ARGLSB ;COERCE ARGLIST TO CONSTANTS EXERR MSG(IPCON) ;IMPROPER PARAMETER TO CONSTRUCTOR MOVE S,(P) ;REFRESH S PUSHJ P,TYPCHK ;CHECK TYPES OF ARGUMENTS RESTOR <S> ;RESTORE S HRRZ AC1,(S) ;CHECK NUMBER OF ARGS AGAINST HLRZ AC1,(AC1) ;LENGTH OF STRUCTURE SUBI AC1,1 ;AC1=#COMPONENTS OF STRUCTURE HLRZ R,S ;GET NUMBER OF ARGS CAIE R,(AC1) ;CORRECT NUMBER TO MAKE STRUCTURE? WNARGC: EXERR MSG(WNARC) ;WRONG NUMBER OF ARGS TO CONSTRUCTOR CS2: PUSHJ P,LCOPY ;COPY ARGLIST MOVEI AC2,^D18 ;STORE SIZE OF ELEMENT IN AC2 PUSHJ P,BLOCK ;COMPUTE SIZE OF PACKING AREA MOVEI R2,1(R) ;RESULT IN R, R2_R+1 PUSHJ P,MKBLK ;GO MAKE BLOCK OF SIZE R BLKARG 0,0(R2) ;PZADR IN R,DZADR IN R2 HRRZ L,CFNAM ;L_RELADR OF DDEF HRLM L,(R) ;STORE DATA TYPE IN BLOCK PZWORD HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR HRLI R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME SAVE R ;SAVE IT ON STACK GET AC3,TOPF ;FOR RESULT OF CONSTRUCTION HRLI AC3,B ;AT TOP IN CAR STACK MOVEI R,LSTATM/2+2 ;STORE CODE FOR PACKING PZADRESSES ADDI R2,1 ;R2=BASE OF PACKING ZONE PUSHJ P,PACK ;GO PACK ARGLIST ELEMENTS POP P,@AC3 ;PLACE RESULT OF CONSTRUCTION ON AR STACK RESTOR <L,AC3> JRST RESUM1 ;RESUME INTERPRETATION
SUBTTL CONSTRUCT A SEQUENCE CSEQ: SAVE <AC3,AC4,L> SAVE <S> ;SAVE S ACROSS ARGLSB PUSHJ P,ARGLSB ;COERCE ARGLIST TO LIST OF CONSTANTS EXERR MSG(IPCON) ;IMPROPER PARAMETER TO CONSTRUCTOR MOVE S,(P) ;REFRESH S PUSHJ P,TYPCHK ;CHECK TYPES OF ARGUMENTS RESTOR <S> ;RESTORE S HRRZ B,(S) ;CHECK NUMBER OF ARGUMENTS GET AC1,UBF ;AGAINST LENGTH OF STRUCTURE GET AC2,LBF ;TO SEE IF NUMBER OF ARGS IS CORRECT SUB AC1,AC2 ADDI AC1,1 ;LENGTH=UB-LB+1 GET AC4,TYPF ;SAVE TYPE FIELD IN AC4 HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR JUMPN ARGP,.+2 ;USER SUPPLY ANY ARGS? JUMPN AC1,WNARGC ;NO, ERROR IF SEQUENCE IS OF NONZERO LENGTH HLRZ R,S ;FETCH NUMBER OF ARGS CAME R,AC1 ;IF NUMBER OF ARGS IN LIST =# REQD,OK. JRST WNARGC ;ERROR-WRONG # OF ARGS TO CONSTRUCTOR CSQ2: PUSHJ P,LCOPY ;COPY ARGS IN ARGLIST LSH AC4,-1 ;SHIFT ELEMENT TYPE RIGHT ONE CAIG AC4,LSTATM/2 ;SEE IF ATOMIC SKIPA AC2,LTABL(AC4) ;IF SO AC2_APPROPRIATE SIZE MOVEI AC2,^D18 ;ELSE AC2_LENGTH=18 PUSHJ P,BLOCK ;COMPUTE SIZE OF PACKING AREA MOVE R2,R ;SET UP PARAMETERS TO MAKE BLOCK ADDI R2,1 ;PACKING AREA SIZE +1 IN R2 PUSHJ P,MKBLK ;GO MAKE BLOCK OF PROPER SIZE BLKARG 0,0(R2) ;BLANK DATA TYPE FIELD HRRZ L,CFNAM ;GET DATA TYPE IN L HRLM L,(R) ;STORE IN PZWORD FOR BLOCK HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR HRLI R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME SAVE R GET AC3,TOPF ;STORE IN TOP OF CAR HRLI AC3,B ;INDEX TOP RELADR BY B MOVEI R,1(AC4) ;SET CODE FOR ELEMENT TYPE IN R CAILE R,LSTATM/2+1 ;IF <=5 SKIP CODE OK, ELSE MOVEI R,LSTATM/2+2 ;SET CODE TO 6 FOR PZADR'S ADDI R2,1 ;R2=ABSADR OF PACKING ZONE PUSHJ P,PACK ;GO DO PACKING POP P,@AC3 ;STORE LEXEME ON AR STACK
CSQ4: RESTOR <L,AC4,AC3> TRNE FF,TUPARG ;IS THIS A SPECIAL TUPARG CALL JRST TUPRET ;YES, GO BACK TO TUPRET IN INTERP JRST RESUM1 ;RESUME INTERPRETATION ;CODE TO MAKE AND STACK A NULL SEQUENCE CSQ3: MOVEI R2,1 ;SET BLOCK SIZE TO 1 PUSHJ P,MKBLK ;GO MAKE A BLOCK BLKARG 0,0(R2) ;BLOCK TYPE NOT GIVEN HRRZ L,CFNAM ;L_DATA TYPE HRLM L,(R) ;SET DATA TYPE IN BLOCK HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR HRLI R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME GET AC3,TOPF ;GO GET TOPF OF CAR HRLI AC3,B ;INDEX IT BY B MOVEM R,@AC3 JRST CSQ4 ;RESTORE AC'S AND RETURN TO FINDPH
SUBTTL CONSTRUCT A VARIADIC SEQUENCE CVSEQ: SAVE <AC3,AC4,L> SAVE <S> ;SAVE S ACROSS ARGLSB PUSHJ P,ARGLSB ;COERCE ARGLIST TO CONSTANTS EXERR MSG(IPCON) ;IMPROPER ARGUMENT TO CONSTRUCTOR MOVE S,(P) ;REFRESH S PUSHJ P,TYPCHK ;CHECK TYPES OF ARGUMENTS RESTOR <S> ;RESTORE S JUMPE ARGP,CVSQ1 ;DO SPECIAL CODE TO MAKE VSEQ OF LENGTH ZERO HLRZ R,S ;GET NUMBER OF ARGS TO CONSTRUCTOR CVSQ3: SAVE <S> ;SAVE S ACROSS LCOPY PUSHJ P,LCOPY ;COPY ARGS IN ARGLIST RESTOR <S> ;RESTORE S HRRZ B,(S) ;B_DZADR OF VSEQ DEF GET AC4,TYPF ;AC4_ELEMENT TYPE GET AC3,LBF ;AC3_LOWER BOUND EXTENDED LSH AC4,-1 ;SHIFT ELEMENT TYPE RIGHT ONE CAIG AC4,LSTATM/2 ;SKIP IF TYPE IS NON-ATOMIC SKIPA AC2,LTABL(AC4) ;AC2_APPROPRIATE SIZE MOVEI AC2,^D18 ;AC2_SIZE 18 FOR NON-ATOMIC ELEMENTS HLRZ AC1,S ;FETCH NUMBER OF ARGS TO CONSTRUCTOR PUSHJ P,BLOCK ;COMPUTE SIZE OF PACKING AREA MOVE R2,R ;SET UP SIZE FOR MAKE BLOCK ADDI R2,2 PUSHJ P,MKBLK ;GO MAKE BLOCK OF PROPER SIZE BLKARG 0,0(R2) HRRZ L,CFNAM ;GET PROPER DATA TYPE HRLM L,(R) ;STORE VSEQ TYPE IN PZWORD HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR
HRLI R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME ADD AC3,AC1 ;COMPUTE UPPER BOUND=LB+LENGTH-1 SUBI AC3,1 MOVE L,AC3 ;L=UPPER BOUND GET AC3,TOPF ;STORE CONSTANT LEXEME ON TOP OF CAR HRLI AC3,B ;STACK SAVE R ;REMEMBER LEXEME MOVEI R,1(AC4) ;SET CODE FOR ELEMENT TYPE IN R CAILE R,LSTATM/2+1 ;IF <=5 OK ELSE USE 6 MOVEI R,LSTATM/2+2 HRRM L,1(R2) ;STORE UB IN VSEQ ADDI R2,2 ;R2=BASE ADDRESS OF PACKING ZONE PUSHJ P,PACK ;GO PACK ARGUMENTS IN VSEQ POP P,@AC3 ;PLACE RESULT OF CONSTRUCTION ON STACK JRST CSQ4 ;RESTORE AC'S AND RETURN TO FINDPH CVSQ1: PUSHJ P,MKBLK ;MAKE BLOCK OF LENGTH 2 BLKARG 0,2 ;DATA TYPE BLANK HRRZ L,CFNAM ;GET DATA TYPE OF VSEQ HRLM L,(R) ;AND STORE IN PZWORD HRRZ B,(S) ;SET UPPER BOUND FIELD GET AC1,LBF ;AC1_LOWER BOUND SUBI AC1,1 ;UB=LB-1 HRRM AC1,1(R2) ;STORE IN BLOCK HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR HRLI R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME GET AC3,TOPF ;STORE CONSTANT LEXEME HRLI AC3,B ;ON TOP OF CAR STACK MOVEM R,@AC3 JRST CSQ4 ;RESTORE AC'S AND RESUME SYNTAX ANALYSIS
SUBTTL SUBROUTINES FOR CONSTRUCTOR FUNCTIONS ;SUBROUTINE TO PROCESS AN ARGLIST & REDUCE IT TO CONSTANTS. ; ASSUMES ARGP POINTS TO FIRST ARGUMENT AND S[LH] HAS NUMBER OF ARGS. ; THIS ROUTINE SKIPS UNLESS ONE OR MORE OF THE ARGUMENTS IS IN ERROR. ARGLSB: MOVEI AC1,MKCNST ;SETUP FOR REPEATED CALL ON MKCNST JRST ARGSEQ ;DISTRIBUTE CALLS TO MKCNST OVER ARGLIST ;ROUTINE TO COERCE A LEXEME TO A CONSTANT AT ARGP. ; CLOBBERS R,R2. RECOMPUTES B IF NECESSARY. ; SKIP RETURN IF OK, NON-SKIP IF ERROR. MKCNST: SAVE <AC1,AC2,L,T> MOVE L,@ARGP ;L_ARGUMENT TO BE COERCED MKC1: LGET AC1,LTYPF ;AC1_LEXEME TYPE XCT MKTAB(AC1) ;DISPATCH ON LEXEME TYPE MKTAB: JRST ERROR8 ;OP-ERROR JRST CLCL ;PROCID-GET VALUE JRST CLCL ;FORML-GET VALUE JRST CLCL ;LCL-GET VALUE JRST CID ;ID-GET VALUE JRST CTBOUT ;CONST-ALREADY A CONSTANT-GO OUT JRST CRELOC ;RELOC-CODERCE TO INTEGER CONSTANT JRST ERROR8 ;DEMAND-SYSTEM ERROR JRST CSELX ;SELX-COERCE TO CONSTANT JRST ERROR8 ;$ID-IMPROPER ARGUMENT JRST CDMR ;DUMREF-FETCH VALUE OF REFERENCED LCL CRELOC: CALL RLCINT ;CONVERT RELOC TO INT CTBOUT: AOS -4(P) ;SUCCESSFUL (SKIP) RETURN ERROR8: RESTOR <T,L> ;RESTORE ACCUMULATORES JRST X21 ;RESTORE AC2,1 AND RETURN
;CODE TO GET A VALUE OF A LOCAL IN THE CAR CLCL: MOVEI L,ARBASE(L) ;L_RELADR OF LOCAL IN CAR HRLI L,B ;INDEX L BY B SKIPA L,@L ;GET LOCAL QUANTITY ;CODE TO FETCH A LEXEME REFERENCED BY A DUMREF CDMR: CALL GETDMR ;FETCH REFERENCED LEXEME JUMPE L,ERROR8 ;ERROR IF LOCAL UNASSIGNED MOVEM L,@ARGP ;STORE IN CAR IN PLACE OF LOCAL JRST MKC1 ;AND RESUME ANALYSIS WITH ;SUBSTITUTED LEXEME ;CODE TO GET THE VALUE OF A GLOBAL IDENTIFIER CID: MOVE AC2,IDTP ;AC2_DZADR OF IDT HRRZ AC2,(AC2) ADDI AC2,(L) ;AC2_ABSADR OF STE MOVE L,(AC2) ;L_STE OF IDENTIFIER HLRZ AC1,L ;AC1_CLASS OF IDENTIFIER XCT CIDTBL(AC1) ;DISPATCH ON ID TYPE CIDTBL: JRST ERROR8 ;UNDEFINED IDENTIFIER JRST CIDVAR ;VAR-GET VALUE JRST ERROR8 ;FN-IMPROPER PARAMETER JRST ERROR8 ;DDEF-IMPROPER PARAMETER JRST ERROR8 ;SEL-IMPROPER PARAMETER JRST CIDCEV ;CEV-GO GET VALUE JRST ERROR8 ;ATOM-IMPROPER PARAMETER JRST ERROR8 ;I.SFN-IMPROPER PARAMETER JRST ERROR8 ;RESW - IMPROPER PARAMETER CIDVAR: HRRZ AC1,L ;CHECK TO SEE IF RIGHT HALF JUMPE AC1,ERROR8 ;OF STE IS NON-ZERO HRLI AC1,(LXM(STAK,CONST)) ;MAKE CONST LEXEME MOVEM AC1,@ARGP ;AND STACK IT ON STACK AT ARGP JRST CTBOUT ;AND EXIT
CIDCEV: HRRZ AC1,L ;GET CONTINUOUS VALUE AND JUMPE AC1,ERROR8 ;IF IT IS NON-ZERO MAKE HRRZ AC2,(AC1) ;CONSTANT OUT OF IT HRRZ AC1,1(AC2) ;AC2_DZADR OF CEV BLOCK, JUMPE AC1,ERROR8 ;AC1=CONTINUOUS VALUE,ERROR IF ZERO HRLI AC1,(LXM(STAK,CONST)) ;MAKE CONST LEXEME MOVEM AC1,@ARGP ;AND STACK ON STACK,THEN JRST CTBOUT ;EXIT ;CODE TO COERCE A SELECTION EXPRESSION INTO A CONSTANT CSELX: HRRZ B,(L) ;B_DZADR OF LVALUE BLOCK PUSHJ P,SELECT ;RETURNS WITH VALUE IN (R,R2),ELTYPE IN T JRST CSELX1 ;R WAS PZADR IF HAD NORMAL RETURN LSH T,-1 ;HALVE TYPE FIELD TO MAKE SRETRN HAPPY PUSHJ P,SRETRN ;MAKES BLOCK OUT OF (R,R2) OF TYPE T CSELX2: HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR MOVEM R,@ARGP ;STORE ON CAR AT ARGP JRST CTBOUT ;AND EXIT CSELX1: HRLI R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME JRST CSELX2 ;AND GO STACK IT ON CAR AT ARGP
;ROUTINE TO CHECK TYPES OF ARGUMENTS IN ARGLIST. ; ASSUMES ARGP --> FIRST ARG AND S[LH] CONTAINS # OF ARGS TYPCHK: MOVEI AC1,TYPEOK ;SETUP ADR OF ROUTINE TO BE CALLED MOVEI AC2,1 ;INIT ARG COUNTER CALL ARGSEQ ;ENUMERATE ARGLIST, CALLING TYPEOK JFCL ;ARGENU SKIPS IF NO ARGS RETURN ;ROUTINE TO CHECK THE TYPE OF THE ITH ARGUMENT IN THE ARGLIST ;AGAINST THE TYPE REQUIRED FOR THE ITH ELEMENT ;AS SPECIFIED BY THE DATA TYPE BEING CONSTRUCTED. ;AC2=ORDINAL NUMBER OF THE ARGUMENT,S=STE FOR DDEF (CAUTION:MAYBE ;CLOBBERED BY ARGLSB WHICH CLOBBERS T=S=AC12). IF NO ERROR, ;TYPEOK EXITS NORMALLY. OTHERWISE IT DOES EXERR. TYPEOK: SAVE <AC2> ;PROTECT ARG COUNTER HRRZ AC1,S ;AC1_PZADR OF DDEF BLOCK PUSHJ P,ITHTYP ;R_TYPE OF ITH ELEMENT (AC2=I) HLRZ AC1,(L) ;FETCH DATA TYPE OF ITH ARGUMENT ANDCMI AC1,(SYSBIT+GCBIT+CPYBIT) ;MASK OTHER BITS MOVE AC2,R ;AC2_TYPE OF ITH ELEMENT PUSHJ P,CHKPRD ;CALL INSTANCE EXERR MSG(IPCON) ;WRONG TYPE ARGUMENT TO CONSTRUCTOR RESTOR <AC2> ;RESTORE ARG COUNT AOJA AC2,CPOPJ ;INCREMENT ARG COUNT AND RETURN
;ROUTINE TO COMPUTE REQUIRED TYPE OF ITH ARGUMENT IN ;A CONSTRUCTION. AC1=PZADR OF DDEF BLOCK ;FOR CONSTRUCTOR,AC2=I. RESULT IN R( AS RELADR OF TYPE ;ID IN IDT.) ITHTYP: SAVE <AC1> HLRZ R,(AC1) ;R_DDEF TYPE ANDCMI R,(GCBIT+CPYBIT+SYSBIT) ;EXTRACT OFF GC,CPY,SYS BITS XCT ITHT-B.STRUCT(R) ;DISPATCH ON DDEF TYPE ITHT: JRST STRITH ;STRUCT-GET TYPE OF ITH ELEMENT ERROR MSG(CNARG) ;ARG WAS ALT IN ITHTYP JRST SEQITH ;SEQ-GET ELEMENT TYPE JRST SEQITH ;VSEQ-GET ELEMENT TYPE STRITH: EXCH B,AC1 ;B_PZADR OF DDEF BLOCK HRRZ B,(B) ;B_DZADR OF DDEF BLOCK GET R,WLF ;R_WORD LENGTH CAML AC2,R ;IF I<WLF, OK EXERR MSG(TMARG) ;TOO MANY ARGUMENTS TO MAKE STRUCTURE ADDI B,(AC2) ;B_ABSADR OF ITH SEL:TYPE PAIR HRRZ R,(B) ;R_ELEMENT TYPE OF ITH ELEMENT MOVE B,AC1 ;RESTORE B,AC1 JRST X1 ;RESTORE AC1 AND RETURN SEQITH: EXCH AC1,B ;B_PZADR OF DDEF BLOCK HRRZ B,(B) ;B_DZADR OF DDEF BLOCK GET R,TYPF ;R_ELEMENT TYPE JRST X1 ;RESTORE AC1 AND RETURN POPJ P, ;AND EXIT
;CODE TO COPY AN ARGLIST OF CONSTANTS IN CAR POINTED LCOPY: SAVE <AC1> ;PROTECT AN AC MOVEI AC1,SGCOPY ;SETUP ADR OF SINGLE COPY ROUTINE CALL ARGSEQ ;DISTRIBUTE CALLS TO SGCOPY OVER ARGLIST JFCL ;ARGSEQ SKIPS IF NO ARGS JRST X1 ;RESTORE AC1 AND RETURN SGCOPY: HRRZ AC1,@ARGP ;FETCH PZADR OF DATUM TO BE COPIED CALL COPY ;MAKE A COPY (IF NECESSARY) HRRZ B,(CAR) ;RESTORE BASE ADR OF CAR HRRM R,@ARGP ;STORE PZADR OF COPY RETURN
;ALGORITHM TO COMPUTE REQUIRED LENGTH OF PACKING ZONE ;FOR N OBJECTS OF SIZE S=1,7,18,36 OR 72, WHERE AC1=N, ;AC2=S. RESULT IN R IN UNITS OF WORDS. BLOCK: SAVE <AC1,AC2> ;SAVE ACCUMULATORS MOVE R,AC1 ;R_N IMUL R,AC2 ;R_N*S CAIE AC2,7 ;IF S=7 SKIP JRST .+4 ;ELSE GO TO .+4 SUBI AC1,1 ;AC1_N-1 IDIVI AC1,5 ;AC1_ENTIER((N-1)/5) ADD R,AC1 ;R_N*S+ENTIER((N-1)/5) IDIVI R,^D36 ;R_ENTIER(R/36) SKIPE R2 ;IF HAD NON-ZERO REMAINDER IN R2 ADDI R,1 ;THEN ADD 1 TO R,NEED ONE MORE WORD RESTORE <AC2,AC1> ;RESTORE ACCUMULATORS POPJ P, ;EXIT
;ROUTINE TO PACK AN ARGLIST INTO A ZONE. ;CALLING PARAMETERS: ; AC1 = NUMBER OF ELEMENTS IN ARGLIST ; AC2 = PACKING SIZE OF EACH ELEMENT ; R = ELEMENT TYPE CODE, WHERE ; INT = 1 ; REAL = 2 ; DBL = 3 ; BOOL = 4 ; CHAR = 5 ; NONE = 6 ; ADDRESS=7 ; R2 = ABSOLUTE ADDRESS OF THE FIRST WORD OF THE PACKING ZONE. PACK: XCT PCKTAB-1(R) ;DISPATCH ON ELEMENT TYPE CODE PCKTAB: JRST PKINT ;INT-GO PACK INTGERS JRST PKREAL ;REAL-GO PACK REALS JRST PKDBL ;DBL-GO PACK DOUBLES JRST PKBOOL ;BOOL-GO PACK BOOLS JRST PKCHAR ;CHAR-GO PACK CHARACTERS POPJ P, ;NONE-PACKING NULLS IS A NO-OP JRST PKADR ;ADR-GO PACK PZADR'S PKREAL: PKINT: SAVE <ARGP> ;SAVE ARGP FOR LATER RESTORATION PKI1: MOVE L,@ARGP ;GET LEXEME IN L HRRZ L,(L) ;L_DZADR MOVE L,1(L) ;L_INT OR REAL MOVEM L,(R2) ;STORE IN PACKING ZONE ADDI ARGP,1 ;MOVE TO NEXT ARGUMENT ADDI R2,1 ;INCREMENT TARGET PACKING ADDRESS SOJG AC1,PKI1 ;IF MORE LEFT GO AROUND,ELSE RESTOR <ARGP> ;RESTORE ARGP POPJ P, ;AND EXIT
;ROUTINE TO PACK DOUBLES PKDBL: SAVE <ARGP> PKD1: MOVE L,@ARGP ;L_LEXEME FOR ITH DOUBLE HRRZ L,(L) ;L_DZADR OF DOUBLE DATA BLOCK MOVE R,1(L) ;GET FIRST HALF OF DOUBLE IN R MOVEM R,(R2) ;AND STORE IN (R2) MOVE R,2(L) ;GET SECOND HALF OF DOUBLE IN R MOVEM R,1(R2) ;STORE ADJACENT TO FIRST HALF ADDI R2,2 ;INCREMENT R2 BY TWO ADDI ARGP,1 ;MOVE TO NEXT ARGUMENT SOJG AC1,PKD1 ;IF MORE LEFT,GO AROUND RESTOR <ARGP> ;ELSE RESTORE ARGP POPJ P, ;AND EXIT ;ROUTINE TO PACK BOOLEAN VALUES PKBOOL: SAVE <ARGP> MOVSI R,(POINT 1,(R2)) ;SETUP BYTE PTR FOR BOOLS JRST PKBC1 ;GO TO COMMON CODE FOR BOOLS AND CHARS ;ROUTINE TO PACK CHARACTERS PKCHAR: SAVE <ARGP> MOVSI R,(POINT 7,(R2)) ;SETUP BYTE PTR FOR CHARS ;COMMON CODE FOR BOOLS AND CHARS PKBC1: MOVE L,@ARGP ;L_LEXEME WITH VALUE TO BE PACKED HRRZ L,(L) ;L_DZADR OF DATA BLOCK MOVE L,1(L) ;L_BOOL OR CHAR TO BE PACKED IDPB L,R ;MOVE BYTE TO LOC. SPECFIED BY R ADDI ARGP,1 ;MOVE TO NEXT ARGUMENT SOJG AC1,PKBC1 ;IF MORE GO AROUND RESTOR <ARGP> ;RESTORE ARGP POPJ P, ;AND EXIT ;ROUTINE TO PACK ADDRESSES PKADR: SAVE <ARGP> MOVSI R,(POINT 18,(R2)) ;SETUP BYTE PTR FOR ADDRESSES PKA1: HRRZ L,@ARGP ;L_PZADR OF DATUM IDPB L,R ;DEPOSIT IT IN LOC. SPECIFIED BY R ADDI ARGP,1 ;MOVE TO NEXT ARGUMENT SOJG AC1,PKA1 ;IF MORE LEFT GO AROUND RESTOR <ARGP> ;ELSE RESTORE ARGP POPJ P, ;AND EXIT
SUBTTL SELECTION ;COMPOUND SELECTION. ;ENTER WITH STACK IN THE FORM ; S1 S2 ... SN X ;WHERE THE FOLLOWING AC'S ARE SET UP: ; L = SELAPP(N) ; ARGP = B,,PTR(S1) ; TOP = B,,PTR(X) ;NOTE UNUSUAL CONVENTION ;SELECTORS S1 THRU SN ARE APPLIED TO X IN LEFT TO RIGHT (NUMERICAL) ; ORDER. THE RESULT OF EACH SIMPLE SELECTION REPLACES THE SELECTAND ; (ORIGINALLY X). AT THE COMPLETION OF COMPOUND SELECTION, ; THE RESULT MUST BE PLACED IN THE S1 POSITION AND THE STACK POPPED. CSELCT: MOVEI AC1,SSELCT ;SETUP REPEATED CALL FOR SIMPLE SELECTION HRRZ AC2,L ;SUPPLY NUMBER OF SELECTORS CALL ARGENU ;ENUMERATE SELECTOR LIST MOVE AC1,@TOP ;FETCH RESULT OF COMPOUND SELECTION MOVEM AC1,@ARGP ;STORE IN FIRST SELECTOR POSITION MOVE TOP,ARGP ;POP STACK SET TOP,TOPF ;STORE STACK PTR IN CAR JRST RESUM1 ;RESUME INTERPRETATION AFTER INCREMENTING CPM
;ROUTINE TO PERFORM SIMPLE SELECTION X[S], WHERE ; ARGP = B,,PTR(S) ; TOP = B,,PTR(X) ;THE RESULT IS LEFT AT THE X POSITION ON THE STACK SSELCT: EXCH ARGP,TOP ;MAKE ARGP-->X CALL MKCNST ;COERCE X TO A CONSTANT EXERR MSG(IPSEL) ;IMPROPER PARAMETER FOR SELECTION EXCH ARGP,TOP ;RESTORE POINTERS MOVE L,@TOP ;GET LEXEME FOR CONSTANT HLRZ AC1,(L) ;AC1_DATA TYPE TRNE AC1,(SYSBIT) ;IF SYSBIT ON THEN ERROR ERROR MSG(SYSEL) ;ATTEMPT TO SELECT FROM SYSTEM OBJECT CAIG AC1,LSTATM ;SEE IF SELECTAND IS ATOMIC,IF SO ERROR EXERR MSG(ATSEL) ;ATTEMPT TO SELECT COMPONENT OF ATOMIC DATUM HRRZ AC2,@IDTP ;AC2_DZADR OF IDT ADD AC2,AC1 ;AC2=ABSADR OF STE FOR DATA TYPE HRRZ AC2,(AC2) ;AC2=PZADR OF DDEF BLOCK SKIPN AC2 ;IF DDEF BLOCK IS ZERO THEN DDEF UNDEFINED ERROR MSG(DDMSE) ;DATA DEF MISSING DURING SELECTION HLRZ R,(AC2) ;R_TYPE OF DDEF BLOCK ANDCMI R,(SYSBIT+GCBIT+CPYBIT) ;MASK OUT OTHER BITS XCT SSTBL-B.STRUCT(R) ;DISPATCH ON DDEF TYPE SSTBL: JRST SSTRCT ;GO DO SELECTION ON STRUCTURE ERROR MSG(DDALT) ;DDEF WAS ALT IN SELECTION JRST SSEQ ;GO DO SELECTION ON SEQUENCE JRST SVSEQ ;GO DO SELECTION ON VARIADIC SEQUENCE
;CODE TO SELECT FROM A STRUCTURE. ;ENTER AC1=PZADR OF DDEF BLOCK ; AC2=DATA TYPE OF SELECTAND ; ARGP = B,,PTR(S) ;S IS SELECTOR ON STACK ; TOP = B,,PTR(X) ;X IS OBJECT BEING SELECTED FROM SSTRCT: MOVE L,@ARGP ;FETCH SELECTOR LGET R,LTYPF ;SEE IF SELECTOR IS PROCID CAIN R,PROCID JRST SSTR4 ;YES, TREAT INTEGER SELECTORS CALL EVALID ;NO, SEE IF IT CAN BE COERCED TO ID JRST SSTR4 ;NO, TREAT INTEGER SELECTORS HRRZ L,@ARGP ;FETCH ID INTERNAL NAME ADD L,@IDTP ;AN ID, SEE WHAT KIND HLRZ L,(L) ;GET LH OF SYMBOL TABLE ENTRY CAIE L,I.SEL ;A SELECTOR? JRST SSTR4 ;NO, ASSUME INDEXED SELECTION HRLZ L,@ARGP ;YES. L[LH]_SELECTOR NAME HRRZ B,(AC2) ;FIND ORDINAL POSITION OF SELECTOR HRLI B,R ;INDEX B BY R GET R,WLF ;B_DZADR OF STRUCT DDEF BLOCK,INDXD BY R SSTR1: SOJG R,.+2 ;R_WLENGTH OF DDEF BLOCK EXERR MSG(ISELS) ;IMPROPER SELECTOR FOR STRUCTURE SSTR2: HRR L,@B ;GET NTH SEL:TYPE PAIR IN DDEF BLOCK CAMN L,@B ;COMPARE L WITH SEL:TYPE PAIR JRST SSTR3 ;FOUND SELECTOR,GO TO SSTR3,RHS(L)=ELTYPE SOJG R,SSTR2 ;GO AROUND IF R>0 EXERR MSG(ISELS) ;IMPROPER SELECTOR FOR STRUCTURE SSTR3: MOVEI AC1,(R) ;AC1_ORDINAL NUMBER OF SELECTOR SSTR6: MOVEI T,LSTATM+2 ;T_ELEMENT TYPE FOR HALF WORD CALCULATION PUSHJ P,FIELDP ;CALCULATE R=DISP,R2=BEG, AND AC2=18 ADDI R,1 ;INCREMENT DISPLACEMENT BY ONE HRRZ T,L ;T=ELTYPE OF STR FIELD SLCOUT: HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR HRRZ AC1,@TOP ;AC1_PZADR OF DATUM PUSHJ P,MKLVL ;MAKE AN LVALUE MOVEM R,@TOP ;STORE SELX LEXEME AT ARGP-3 RETURN
SSTR4: PUSHJ P,MKCNST ;COERCE SELECTOR TO A CONSTANT EXERR MSG(ISELS) ;IMPROPER SELECTOR FOR STRUCTURE MOVE L,@ARGP ;GET LEXEME FOR SELECTOR IN L HLRZ R2,(L) ;R_DATA TYPE OF CONSTANT ANDI R2,077777 ;IF WASNT INT THEN CAIE R2,U.INT ;THEN HAD ILLEGAL SELECTOR SSTR5: EXERR MSG(ILSEL) ;ILLEGAL SELECTOR HRRZ B,(L) ;B_DZADR OF INTEGER GET AC1,INTF ;AC1_ORDINAL # OF COMPONENT JUMPLE AC1,SSTR5 ;ILLEGAL IF NEGATIVE OR ZERO HRRZ B,(AC2) ;B_DZADR OF DDEF BLOCK GET R,WLF ;R_WLF OF DDEF BLOCK CAML AC1,R ;IF ORDINAL SEL<WLF,OK,ELSE JRST SSTR5 ;ORDINAL SELECTOR TOO LARGE ADD B,AC1 ;B_ABS ADR OF SEL:TYPE PAIR MOVE L,(B) ;L_SEL:TYPE PAIR JRST SSTR6 ;GO TO SSTR6 TO FINISH
;CODE FOR SELECTION ON SEQUENCES ;AC2=PZADR OF DDEF BLOCK ; ARGP = B,,PTR(S) ;S IS SELECTOR ; TOP = B,,PTR(X) ;X IS SELECTAND SSEQ: SAVE <AC3,AC4,AC5> HRRZ B,(AC2) ;B_DZADR OF DATA BLOCK GET AC3,LBF ;AC3_LOWER BOUND FIELD,EXTENDED GET AC4,UBF ;AC4_UPPER BOUND FIELD EXTENDED MOVEI AC5,0 ;AC5_0 =CODE FOR SEQ HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR JRST CSSEQ ;GO TO COMMON CODE FOR SEQ AND VSEQ SVSEQ: SAVE <AC3,AC4,AC5> MOVE L,@TOP ;GET UPPER BOUND FROM DATUM HRRZ B,(L) ;B_DZADR OF SELECTAND GET AC4,UDUBF ;GET UPPER BOUND FROM DATUM HRRZ B,(AC2) ;B_DZADR OF DDEF BLOCK GET AC3,LBF ;AC3_LOWER BOUND FIELD EXTENDED MOVEI AC5,1 ;AC5_1=CODE FOR VSEQ HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR JRST CSSEQ ;GO TO COMMON CODE FOR SEQ AND VSEQ
;CODE COMMON TO DO SELECTION ON SEQ'S AND VSEQ'S. ;ENTER WITH AC2=PZADR OF DDEF BLOCK,AC1=DATA TYPE OF SELECTAND ;AC3=LB,AC4=UB,AC5=0 OR 1 IF SEQ OR VSEQ RESPECTIVELY. CSSEQ: PUSHJ P,MKCNST ;COERCE SELECTOR TO A CONSTANT EXERR MSG(ISELQ) ;IMPROPER SELECTOR FOR SEQUENCE MOVE L,@ARGP ;GET LEXEME FOR CONSTANT IN L HLRZ R2,(L) ;R2_DATA TYPE OF CONSTANT ANDI R2,077777 ; CAIE R2,U.INT ;IF NOT INT THEN ERROR JRST SSTR5 ;GO PRINT ERROR MESSAGE HRRZ B,(L) ;B_DZADR OF CONSTANT GET AC1,INTF ;GET SELECTOR SUBSCRIPT CAML AC1,AC3 ;ERROR IF SELECTOR NOT >= LB CAMLE AC1,AC4 ;ERROR IF SELECTOR OUT OF BOUNDS CCSEQ1: EXERR MSG(SSOUT) ;SELECTOR SUBSCRIPT OUT OF BOUNDS SUB AC1,AC3 ;AC1_AC1-AC3+1 ADDI AC1,1 ;AC1=ORDINAL NUMBER OF SELECTOR HRRZ B,(AC2) ;B_DZADR OF DATA BLOCK GET T,TYPF ;T_ELEMENT TYPE PUSHJ P,FIELDP ;AC2=LENGTH,R=DISP,R2=BEG ADDI R,1(AC5) ;INCREMENT DISP FOR SEQ OR VSEQ RESTOR <AC5,AC4,AC3> ;RESTORE ACCUMULATORS JRST SLCOUT ;GO PERFORM COMMON LVALUE CODE
SUBTTL SELECTOR ROUTINES ;ROUTINE TO CREATE AN L-VALUE FROM FIELD PARAMETERS. ;AC1=PZADR OF DATUM,AC2=LENGTH,T=ELTYPE(RELADR IN IDT),, ;R=DISP,R2=BEG. RESULTS:R2=PZADR OF LVAL,R=SELX LEXEME, MKLVL: SAVE <AC3,R,R2> PUSHJ P,MKBLK ;MAKE A BLOCK BLKARG SYSBIT+B.LVAL,3 ;3 WORDS LONG OF TYPE LVAL MOVE AC3,R ;AC3_PZADR OF LVAL MOVE B,R2 ;B_DZADR OF LVAL BLOCK RESTOR <R2,R> SET T,ELTF ;ELEMENT TYPE _T SET AC1,PZAF ;PZADR _ AC1 SET R,DISPF ;DISPLACEMENT FIELD_R SET R2,BEGF ;BEGINNING FIELD_R2 SET AC2,LENF ;LENGTH FIELD _ AC2 MOVE R,AC3 ;R,R2_PZADR OF LVAL MOVE R2,AC3 ;R_SELX LEXEME HRLI R,(LXM(STAK,SELX)) ;MAKE SELX LEXEME RESTOR <AC3> ;RESTORE ACCUMULATOR JRST BPOPJ ;RECOMPUTE B=DZADR OF CAR AND EXIT
;ROUTINE TO CALCULATE FIELD PARAMETERS OF ITH COMPONENT OF ;A HOMOGENEOUS ARRAY OF ELEMENTS OF ELTYPE T (=RELADR IN IDT ;OF ELEMENT TYPE), WHERE AC1=ORDINAL NUMBER OF ELEMENT. ALL ACCUMULATORS ;SAVED. RESULTS:AC2=LENGTH,R=DISP (RELATIVE TO ZERO, R2=BEG. FIELDP: SAVE <T> ;SAVE ELEMENT TYPE LSH T,-1 ;SHIFT ELEMENT TYPE ONE RIGHT CAIG T,LSTATM/2 ;SEE IF ELEMENT IS ATOMIC SKIPA AC2,LTABL(T) ;IF SO AC2_APPROPRIATE LENGTH MOVEI AC2,^D18 ;ELSE ,IF NON-ATOMIC,LENGTH_18 PUSHJ P,DBFIND ;GO CALCULATE DISP & BEG IN (R,R2) RESTOR <T> ;RESTORE ELEMENT TYPE POPJ P, ;AND EXIT LTABL: EXP ^D36 ;INT-LENGTH=36 EXP ^D36 ;REAL-LENGTH=36 EXP ^D72 ;DBL-LENGTH=72 EXP ^D1 ;BOOL-LENGTH=1 EXP ^D7 ;CHAR-LENGTH=7 EXP ^D0 ;NONE-LENGTH=0 EXP ^D18 ;PZADR-LENGTH=18 ;DBFIND CALCULATES A DISPLACEMENT (IN R) AND A BEGINNING ;BIT POSITION (IN R2), OF THE ITH FIELD (I>=1) OF LENGTH ;(AC2),WHERE I=(AC1), IN A PACKED ARRAY OF HOMOGENEOUS ELEMENTS ;EACH OF LENGTH =(AC2) STARTING AT ADDRESS 0 WITH BITS OF ;SUCCESSIVE WORDS NUMBERED FROM 0-35. NO ACCUMULATORS ;OTHER THAN (R,R2) ARE CLOBBERED. NOTE:THE ACCUMULATOR ;PAIRS (AC1,AC2) AND (R,R2) MUST EACH BE ADJACENT PAIRS ;OF ACCUMULATORS. DBFIND: SAVE <AC1,AC2> ;SAVE AC1 AND AC2 SUBI AC1,1 ;AC1_I-1 MOVE R,AC1 ;R_I-1 IMUL R,AC2 ;R_(I-1)*LENGTH CAIE AC2,7 ;IF LENGTH#7 (NOT CHARACTER) JRST .+3 ;DONT ADD FUDGE FACTOR FOR CHARS IDIVI AC1,5 ;ELSE ADD FUDGE FACTOR FOR CHARS ADD R,AC1 ;R_R+ENTIER((I-1)/5) IDIVI R,^D36 ;R_ENTIER(R/36)=DISP JRST X21 ;RESTORE AC2,AC1 AND RETURN
SUBTTL SYSTEM FUNCTIONS FOR USER-DEFINED DATA ;LENGTH FUNCTIONS FOR ALL USER DATA, WHERE LENGTH = NUMBER ;OF COMPONENTS OF A COMPOUND STRUCTURE, AND, BY CONVENTION, ;THE LENGTH OF ALL ATOMS IS 1. REPEAT 0, <AC1=PZADR OF DATUM WHOSE LENGTH WILL BE TAKEN. R=RESULT , R2 IS CLOBBERED.> LENGT: HLRZ R,(AC1) ;R_DATA TYPE TRNE R,(SYSBIT) ;SKIP IF WAS USER TYPE ERROR MSG(SYLEN) ;ATTEMPT TO GET LENGTH OF SYSTEM OBJECT ANDI R,077777 ;EXTRACT OFF GC,SYS AND CPY BITS CAILE R,LSTATM ;SKIP IF ATOMIC TYPE JRST LENGT1 ;ELSE GO COMPUTE LENGTH MOVEI R,1 ;LENGTH OF ATOMS IS 1 POPJ P, ;EXIT LENGT1: ADD R,@IDTP ;R_DZADR OF STE FOR DATA TYPE HRRZ R2,(R) ;R2_PZADR OF DDEF HLRZ R,(R2) ;R_DDEF TYPE ANDCMI R,(GCBIT+SYSBIT+CPYBIT) ;MASK OUT OTHER BITS XCT LNGTBL-B.STRUCT(R) ;DISPATCH ON DDEF TYPE LNGTBL: JRST LNGSTR ;STRUCT-LENGTH IS WLENTGH-1 ERROR MSG(ALLEN) ;LENGTH OF ALT CAN'T EXIST JRST LNGSEQ ;SEQ-LENGTH IS UB-LB+1 JRST LNGVSQ ;VSEQ-LENGTH IS UB-LB+1 LNGSTR: HRRZ R,(R2) ;TO CALCULATE LENGTH OF HLRZ R,(R) ;STRUCT, WE USE WLENGTH-1 SUBI R,1 POPJ P, ;EXIT WITH LENGTH IN R LNGSEQ: HRRZ R,(R2) ;R_DZADR OF SEQ DATA DEF HLRE R2,1(R) ;R2_LOWER BOUND HRRE R,2(R) ;R_UPPER BOUND SUB R,R2 ;COMPUTE LENGTH=UB-LB+1 AOJA R,CPOPJ ;RETURN WITH LENGTH IN R
LNGVSQ: SAVE <AC1> ;SAVE AC1 HRRZ R,(R2) ;R_DZADR OF SEQ DATA DEF HLRE R2,1(R) ;R2_LOWER BOUND HRRZ AC1,(AC1) ;AC1_DZADR OF DATUM HRRE R,1(AC1) ;R_UPPER BOUND SUB R,R2 ;COMPUTE LENGTH =UB-LB+1 AOJA R,X1 ;RETURN, RESTORING AC1. LENGTH IN R ;SYSTEM FUNCTION FOR LENGTH. RESULT LEXEME IN R,MAY CLOBBER B. SLENGTH:EXP 1 ;TAKES ONE ARGUMENT PUSHJ P,MKCNST ;COERCE ARGUMENT TO A CONSTANT ILLTYPE ;ERROR HRRZ AC1,@ARGP ;AC1_PZADR OF DATUM PUSHJ P,LENGT ;GET LENGTH,RESULT IN R MOVEI T,U.INT/2 ;SET DATA TYPE IN T JRST SRETRN ;MAKE BLOCK OF TYPE T FROM (R,R2) ;AND EXIT ;ROUTINE TO MAKE VSEQ OF SPECIFIED TYPE,LENGTH AND INITIAL ELEMENT ;OF FORM MAKE(TYPE,LENGTH,INITIAL.ELEMENT) SMAKE: EXP 3 CALL EVALID ;EVAL FIRST ARG TO AN ID MERR2: ILLTYPE ;IMPROPER ARGUMENT TYPE MOVE L,@ARGP ;FETCH RESULTANT ID LEXEME HRRZ AC4,L ;SAVE ID INTERNAL NAME FOR LATER ADD L,@IDTP ;COMPUTE ABS ADR OF STE IN IDT HLRZ R,(L) ;GET LH OF STE CAIE R,I.DDEF ;IF FIRST ARG NOT DDEF NAME, ILLTYPE ; THEN IS AN ERROR HRRZ R,(L) ;OK. GET PZADR OF DDEF BLOCK HLRZ R2,(R) ;GET LH OF PZ WORD CAIE R2,B.VSEQ(SYSBIT) ILLTYPE ;ERROR IF NOT VARIADIC SEQUENCE DEF HRRZ B,(R) ;OK, GET DZADR OF VSEQ BLOCK
GET AC2,TYPF ;AC2_REQD ELEMENT TYPE GET AC3,LBF ;AC3_LOWER BOUND FIELD ADDI ARGP,1 HRRZ B,(CAR) ;B_DZADR OF CAR FOR USE IN MKCONST PUSHJ P,MKCNST ;COERCE 2ND ARG. TO CONSTANT ILLTYPE ;ERROR MOVE L,@ARGP MOVE B,(L) ;B_PZWORD OF VALUE HLRZ R2,B ;R2_TYPE OF CONSTANT ANDI R2,077777 ;EXTRACT OFF GC,CPY AND SYS BITS CAIE R2,U.INT ;SECOND ARG. MUST BE INT,ERROR IF NOT MERR3: SFNERR MSG(MAKE2) ;SECOND ARG. MUST BE NON-NEG INTEGER GET AC5,INTF ;AC5_INTEGER FOR LENGTH JUMPL AC5,MERR3 ;ERROR IF INT < 0 ADDI ARGP,1 ;SEQUENCE TO THIRD ARG HRRZ B,(CAR) ;B_DZADR OF CAR PUSHJ P,MKCNST ;COERCE 3RD ARGUMENT TO CONSTANT ILLTYPE ;ERROR MOVE L,@ARGP ;GET LEXEME FOR THIRD ARGUMENT IN L HLRZ AC1,(L) ;AC1_DATA TYPE OF CONSTANT ANDI AC1,077777 PUSHJ P,CHKPRD ;CHECK TO SEE THAT INITIAL.ELEMNT IS OK TYPE
MERR4: SFNERR MSG(MAKE3) ;3RD ARG. IS NOT OF PROPER TYPE EXCH AC1,AC2 ;EXCHANGE TYPE CODES OF CLASS AND TYPE LSH AC1,-1 ;SHIFT TYPE OF INIT. ELEMENT RIGHT ONE CAILE AC1,LSTATM/2 ;ELEMENT TYPE ATOMIC? MOVEI AC1,LSTATM/2+1 ;NO, SET CODE FOR NON-ATOMIC MOVE AC2,LTABL(AC1) ;AC2_SIZE IN BITS OF ELEMENT TO BE PACKED EXCH AC1,AC5 ;AC1_NUMBER OF ELEMENTS PUSHJ P,BLOCK ;COMPUTE IN R SIZE OF PACKING ZONE MOVEI R2,2(R) ;R2_R+2 PUSHJ P,MKBLK ;MAKE A BLOCK OF REQUIRED SIZE BLKARG 0,0(R2) ;PZADR IN R,DZADR IN R2 HRLI R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME HRLM AC4,(R) ;SET TYPE OF NEW DATUM HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR IDPB R,PZSAV ;SAVE PZADR OF DATUM BEING CONSTRUCTED ; TO PROTECT IT FROM GC ADD AC3,AC1 ;COMPUTE UB FOR VSEQ SUBI AC3,1 ;UB=LENGTH+LB-1 MOVE AC4,R2 ;AC4_DZADR OF NEW DATUM MOVE B,R2 ;B_DZADR OF NEW DATUM SET AC3,UDUBF ;FILL IN USER DEFINED UPPER BOUND FIELD JUMPE AC1,MAKENX ;EXIT NOW IF ZERO LENGTH VSEQ MOVEI AC3,(R) ;AC3_PZADR OF NEW DATUM HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR CAILE AC5,LSTATM/2 ;SKIP IF DATA TYPE WAS ATOMIC JRST MAKENA ;ELSE GO TREAT NON-ATOMIC CASE MOVE L,@ARGP ;LOAD (R,R2) WITH ATOMIC DATUM HRRZ L,(L) ;L_DZADR OF INITIAL ELEMENT MOVE R,1(L) ;GET TOP HALF MOVE R2,2(L) ;GET BOTTOM HALF CAIN AC5,U.DBL/2 ;IF ELEMENT TYPE WAS 2 HAD DOUBLE JRST MAKED ;GO PACK DOUBLES MOVE L,AC2 ;ELSE MAKE BYTE POINTER
LSH L,6 ;SHIFT LEFT SIX ADDI L,AC4 ;INDEX L BY AC4 LSH L,^D18 ;POINTER POINTS TO (AC4)+1 ADDI L,1 ;0BITS TO RIGHT OF BYTE IDPB R,L ;DEPOSIT BYTE SOJG AC1,.-1 ;GO AROUND IF MORE JRST MAKENX ;GO EXIT WITH LEXEME IN R MAKED: ADDI AC4,2 ;AC4_BASE ADDR OF PACKING ZONE MOVEM R,(AC4) ;PACK FIRST HALF OF DOUBLE MOVEM R2,1(AC4) ;PACK SECOND HALF OF DOUBLE SOJG AC1,MAKED ;GO AROUND IF MORE LEFT JRST MAKENX ;GO EXIT WITH LEXEME IN R MAKENA: MOVE AC5,AC1 ;AC5=NUMBER OF ELEMENTS MOVE L,[POINT 18,2(AC4)] ;L_BYTE POINTER HRRZ AC1,@ARGP ;AC1_PZADR OF INITIAL ELEMENT MAKEN1: PUSHJ P,COPY ;GO COPY ELEMENT HRRZ AC4,(AC3) ;RECOMPUTE DZADR OF PACKING SONE IDPB R,L ;LOAD BYTE INTO ZONE SOJG AC5,MAKEN1 ;GO AROUND IF MORE MAKENX: MOVE R,@PZSAV ;PICK UP SAVED LEXEME SOS PZSAV ;REMOVE FROM SAVED STATUS RETURN
;ROUTINE TO GET THE LOWER BOUND OF A DATUM SL.BOU: EXP 1 CALL MKCNST ;COERCE TO A CONSTANT ILLTYPE ;ERROR MOVE L,@ARGP ;GET THE COERCED LEXEME MOVE L,(L) ;GET ADDRESSED PZ WORD LGET BLTF ;EXTRACT BLOCK TYPE FIELD ADD R,@IDTP ;GET STE ADDR. HRRZ B,(R) ;GET THE RH OF THE STE HLRZ R2,(R) ;GET ID TYPE FIELD CAIE R2,I.DDEF ;MAKE SURE IT'S A DDEF ILLTYPE ;NO, MUST HAVE BEEN ATOM OR OTHER NONSENSE JUMPE B,DDGONE ;BOMB IF DDEF HAS BEEN ERASED HLRZ R2,(B) ;GET DDEF TYPE FIELD HRRZ B,(B) ;GET DZ ADDR OF DDEF BLOCK CAIN R2,B.STRUCT(SYSBIT) ;RETURN 1 FOR A STRUCT MOVEI R,1 CAIE R2,B.SEQ(SYSBIT) ;RETURN LBF FOR SEQ OR VSEQ CAIN R2,B.VSEQ(SYSBIT) GET LBF MOVEI T,U.INT/2 ;MAKE IT AN INT JRST SRETRN DDGONE: ERROR MSG(DDMIS) ;MISSING DATA DEFINITION
;SYSTEM FUNCTION FOR CONCATENATION. ;CONCATENATES TWO VARIADIC SEQUENCES OF IDENTICAL TYPE. SCONCA: EXP 2 ;TAKES TWO ARGUMENTS, ARG1 AND ARG2 CALL MKCNST ;COERCE FIRST ARG TO A CONSTANT ILLTYPE ;ERROR MOVE L,@ARGP HRRZ R,L ;R_PZADR OF ARG1 HLRZ R2,(R) ;R2_DATA TYPE OF ARG1 ANDI R2,077777 ;REMOVE GC,SYS AND CPY BITS MOVE AC3,R2 ;SAVE PZADR OF ARG1 IN AC3 FOR LATER ADD R2,@IDTP ;R2_ABS ADR OF TYPE(ARG1) MOVE R,(R2) ;R_IDT ENTRY FOR TYPE(ARG1) HLRZ R2,R ;GET ID TYPE CAIE R2,I.DDEF ;MUST BE DATA DEFINITION ILLTYPE HLRZ AC2,(R) ;AC2_DATA TYPE OF DDEF ANDI AC2,077777 ;REMOVE GC,CPY AND SYS BITS CAIE AC2,B.VSEQ ;SKIP IF WAS VARIADIC SEQUENCE CONC2: ILLTYPE HRRZ B,(R) ;B_DZADR OF DDEF BLOCK GET AC2,TYPF ;AC2_REQUIRED ELEMENT TYPE ADDI ARGP,1 ;CONSIDER SECOND ARGUMENT HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR CALL MKCNST ;COERCE ARG2 TO A CONSTANT ILLTYPE ;ERROR MOVE L,@ARGP HLRZ R,(L) ;R_DATA TYPE OF ARG2 ANDI R,077777 ;EXTRACT OFF GC,SYS AND CPY BITS
CAME R,AC3 ;SEE IF ARG2 IS SAME TYPE AS ARG1 JRST CONC2 ;IF NOT PRINT ERROR SUBI ARGP,1 ;POINT TO FIRST ARG AGAIN CAILE AC3,LSTATM ;IF ELEMENTS NON-ATOMIC PUSHJ P,LCOPY ;THEN COPY ARGUMENTS HRRZ AC1,@ARGP ;AC1_PZADR OF ARG1 HRRZ AC7,(AC1) HRRE AC7,1(AC7) ;AC7_UPPER BOUND OF ARG1 PUSHJ P,LENGT ;R=LENGTH(ARG1) MOVE AC4,R ;STORE LENGTH OF ARG1 IN AC4 ADDI ARGP,1 ;POINT TO 2ND ARG HRRZ AC1,@ARGP ;AC1_PZADR OF ARG2 PUSHJ P,LENGT ;R=LENGTH(ARG2) MOVE AC5,R ;STORE LENGTH OF ARG2 IN AC5 MOVE T,AC2 ;SAVE ELEMENT TYPE IN T LSH AC2,-1 ;CONVERT ELEMENT TYPE INTO INDEX CAILE AC2,LSTATM/2 ;INTO LENGTH TABLE MOVEI AC2,LSTATM/2+1 ;AND USE IT TO GET SIZE OF ELEMENT MOVE AC2,LTABL(AC2) ;IN BITS MOVE AC1,AC4 ;AC1_LENGTH(ARG1)+LENGTH(ARG2) ADD AC1,AC5 PUSHJ P,BLOCK ;CALCULATE LENGTH OF BLOCK REQUIRED MOVEI R2,2(R) ;R2_LENGTH OF BLOCK TO MAKE PUSHJ P,MKBLK ;GO MAKE IT BLKARG 0,0(R2) ;PZADR IN R, DZADR IN R2 HRRZ B,(CAR) ;RECOMPUTE DZADR OF CAR HRLM AC3,(R) ;STORE DATA TYPE IN LHS OF PZWORD ADD AC7,AC5 ;AC7_NEW UPPER BOUND HRRM AC7,1(R2) ;STORE IN RESULT DATA BLOCK MOVEI AC7,1(AC4) ;AC7_1+LENGTH(ARG1) JUMPE AC4,CONC3 ;GO TO CONC3 IF LENGTH(ARG1)=0
SUBI ARGP,1 ;MAKE ARGP POINT TO ARG1 MOVE L,@ARGP ;GET ARG1 HRRZ L,(L) ;L_DZADR OF ARG1 HLRZ AC1,(L) ;AC1_WLENGTH(ARG1) SUBI AC1,2 ;AC1_WLENGTH(ARG1)-2 ADDI ARGP,1 ;MAKE ARGP POINT TO ARG2 JUMPE AC1,CONC3 ;GO TO CONC3 IF LENGTH IS 0 MOVEI AC2,1(R2) ;AC2_DZADR OF RESULT+1 MOVEI AC3,1(L) ;AC3_DZADR OF ARG1+1 HRLI AC2,AC1 ;INDEX AC2 BY AC1 HRLI AC3,AC1 ;INDEX AC3 BY AC1 CONC4: MOVE L,@AC3 ;TRANSFER WORD FROM ARG1 MOVEM L,@AC2 ;TO RESULT SOJG AC1,CONC4 ;GO AROUND IF MORE LEFT ;DATA TRANSFER OF ELEMENTS OF ARG1 COMPLETE CONC3: MOVE AC3,R ;AC3_PZADR OF RESULT MOVE AC4,R2 ;AC4_DZADR OF RESULT JUMPE AC5,CONC5 ;GO OUT IF LENGTH(ARG2)=0 ;HERE WE HAVE TO COMPUTE THE FIELD PARAMETERS OF ;THE LENGTH(ARG1)+1ST ELEMENT. MOVE AC1,AC7 ;AC1_ORDINAL NO. OF ELEMENT, NOTE: ;T=SAVED ELEMENT TYPE PUSHJ P,FIELDP ;CALCULATE FIELD PARAMETERS HRRZ L,@ARGP ;AC2=LENGTH,R=DISP,R2=BEG HRRZ L,(L) ;L_DZADR OF ARG2 MOVEI AC7,2(L) ;AC7_BASE OF ARG2 PACKING ZONE MOVEI AC6,2(AC4) ;AC6_BASE OF RESULT PACKING ZONE CAIN AC2,^D72 ;SKIP IF ELEMENT TYPE NOT =DBL JRST CONC6 ;GO TRANSFER DOUBLES
;CALCULATE DESTINATION BYTE POINTER MOVEI AC1,^D36 ;AC1_36 SUB AC1,R2 ;P=36-(BEG+LENGTH) SUB AC1,AC2 LSH AC1,6 ;SHIFT AC1 LEFT SIX ADD AC1,AC2 ;ADD SIZE LSH AC1,6 ;SHIFT LEFT SIX MORE ADDI AC1,AC6 ;INDEX POINTER BY AC6 HRL R,AC1 ;R_BYTE POINTER TO DESTINATION ;CONSTRUCT BYTE POINTER FOR SOURCE MOVEI AC1,^D36 ;(AC2)=LENGTH,BEG=0 SUB AC1,AC2 ;P=36-(BEG+LENGTH) LSH AC1,6 ;SHIFT AC1 LEFT SIX ADD AC1,AC2 ;ADD IN SIZE LSH AC1,6 ;SHIFT LEFT SIX MORE ADDI AC1,AC7 ;INDEX BYTE PTR BY AC7 HRLZ R2,AC1 ;R2=BYTE POINTER FOR SOURCE ;NOTE: (AC5)= NO. OF ELEMENTS TO BE TRANSFERRED LDB AC1,R2 ;FETCH BYTE FROM SOURCE DPB AC1,R ;DEPOSIT BYTE IN DESTINATION SOJE AC5,CONC5 ;GO CONC5 , IF NO MORE LEFT CONC8: ILDB AC1,R2 ;TRANSFER BYTE FROM IDPB AC1,R ;ARG2 TO RESULT SOJG AC5,CONC8 ;IF MORE GO AROUND ;TRANSFER IS COMPLETE, SO EXIT CONC5: HRLI AC3,(LXM(STAK,CONST)) ;MAKE CONST LEXEME MOVE R,AC3 ;STORE CONSTANT LEXEME IN R POPJ P, ;AND EXIT ;CODE TO TRANSFER DOUBLES CONC6: ADD AC6,R ;AC6=DISP+BASE ADR OF RESULT PCKNG ZONE CONC9: MOVE AC1,(AC7) ;MOVE FIRST HALF OF MOVEM AC1,(AC6) ;DOUBLE FROM ARG2 TO RESULT MOVE AC1,1(AC7) ;MOVE SECOND HALF OF DOUBLE MOVEM AC1,1(AC6) ;FROM ARG2 TO RESULT ADDI AC7,2 ;INCREMENT AC7 AND AC6 BY TWO EACH ADDI AC6,2 SOJG AC5,CONC9 ;GO AROUND IF MORE LEFT, JRST CONC5 ;ELSE GO OUT. 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