;;; -*-MIDAS-*- ;;; ************************************************************** ;;; ***** MACLISP ****** ARRAY PACKAGE *************************** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT ARA SUBTTL ARRAY PACKAGE IFN SFA, QSFA IFN JOBQIO, QJOB ;THESE ENTRIES USED ONLY QFILE ; BY ARRAYDIMS FUNCTION ARYTP1: AS.RDT+AS.FX,,QREADTABLE ;READTABLE AS.OBA+AS.SX+AS.GCP,,QOBARRAY ;OBARRAY NPARTP==.-ARYTP1 ;# OF PECULIAR ARRAY TYPES DX$ AS.DX,,QDUPLEX ;DUPLEX DX% -1 CX$ AS.CX,,QCOMPLEX ;COMPLEX CX% -1 DB$ AS.DB,,QDOUBLE ;DOUBLE DB% -1 AS.SX+AS.GCP,,TRUTH ;S-EXPRESSION AS.FX,,QFIXNUM ;FIXNUM AS.FL,,QFLONUM ;FLONUM AS.SX,,NIL ;NSTORE-TYPE LARYTP==.-ARYTP1 ARYTYP==ARYTP1-.LZ (AS.RDT), .SEE ADIMS ;FOR JFFO'S ON THE BITS ;;; TABLE OF EXTRA INSTRUCTIONS FOR ARRAY HEADER. ;;; ENTRIES ARE ZERO IF NO INSTRUCTION NEEDED. ;;; ENTRIES ARE NEGATIVE FOR AN ILLEGAL ARRAY TYPE. ;;; (NOTE THAT THE OPCODE PUSH IS POSITIVE.) ARYIN1: 0 ;READTABLE 0 ;OBARRAY TBLCHK ARYIN1,NPARTP DX$ PUSH P,CDUPL1 ;DUPLEX DX% -1 CX$ PUSH P,CCMPL1 ;COMPLEX CX% -1 DB$ PUSH P,CDBL1 ;DOUBLE DB% -1 0 ;S-EXPRESSION PUSH P,CFIX1 ;FIXNUM PUSH P,CFLOAT1 ;FLONUM 0 ;NSTORE-TYPE TBLCHK ARYIN1,LARYTP ;;;
,, ;;; THE MULTIPLIER IS USED TO ADJUST FOR THE NUMBER OF WORDS ;;; OCCUPIED BY EACH ELEMENT. ARYIN2: DIMFTB,,1 ;READTABLE DIMSTB,,1 ;OBARRAY TBLCHK ARYIN2,NPARTP DX$ DIMZTB,,4 ;DUPLEX DX% 0 CX$ DIMDTB,,2 ;COMPLEX CX% 0 DB$ DIMDTB,,2 ;DOUBLE DB% 0 DIMSTB,,1 ;S-EXPRESSION DIMFTB,,1 ;FIXNUM DIMFTB,,1 ;FLONUM DIMSTB,,1 ;NSTORE-TYPE TBLCHK ARYIN2,LARYTP ;;; TABLES OF INSTRUCTIONS FOR CALLING ARRAY SUBSCRIPT ;;; CALCULATION ROUTINES. DIMSTB IS FOR S-EXPRESSION ;;; ARRAYS, AND DIMFTB FOR FULL-WORD ARRAYS. DIMSTB: JSP TT,1DIMS ;TABLE OF DIMS'S JSP TT,2DIMS JSP TT,3DIMS JSP TT,4DIMS JSP TT,5DIMS DIMFTB: JSP TT,1DIMF ;TABLE OF DIMF'S JSP TT,2DIMF JSP TT,3DIMF JSP TT,4DIMF JSP TT,5DIMF IFN DBFLAG+CXFLAG,[ DIMDTB: JSP TT,1DIMD JSP TT,2DIMD JSP TT,3DIMD JSP TT,4DIMD JSP TT,5DIMD ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ DIMZTB: JSP TT,1DIMZ JSP TT,2DIMZ JSP TT,3DIMZ JSP TT,4DIMZ JSP TT,5DIMZ ] ;END OF IFN DXFLAG SUBTTL ARRAY AND *ARRAY FUNCTIONS TTDEAD=BPURPG(TT) TTDEDC=TTDEAD+,,> ARRAY: JSP TT,FWNACK ;FSUBR FA234567,,QARRAY JSP TT,KLIST ;LIKE *ARRAY, BUT FIRST TWO SUBI T,2 ; ARGS NOT EVALUATED JRST ARRY0 %%ARRAY: JSP TT,LWNACK ;LSUBR (2 . 7) LA234567,,Q%%ARRAY ARRY0: MOVEI TT,(P) ADDI TT,(T) ;TT POINTS TO BELOW ARGS ON PDL HRRZ A,2(TT) ARRY0B: MOVSI F,-LARYTP ;CHECK OUT ARRAY TYPE ARRY0C: HRRZ B,ARYTP1(F) CAIN B,(A) JRST ARRY0F AOBJN F,ARRY0C WTA [BAD ARRAY TYPE - *ARRAY!] MOVEM A,2(TT) JRST ARRY0B ARRY0F: TLZ F,-1 ;F HAS ARRAY TYPE (INDEX INTO ARYTP1) CAIL F,NPARTP ;SKIP IF PECULIAR ARRAY TYPE JRST ARRY2 CAML T,XC-3 JRST ARRY1 ARRY0G: MOVEI D,Q%%ARRAY ;WRONG NUMBER OF ARGS - LOSEY LOSEY JRST WNALOSE ARRY1: HRRZ AR2A,ARRYQ1(F) ;DEFAULT ARRAY TO COPY FROM CAML T,XC-2 SOJA T,ARRY1F ;T REFLECTS # OF DIMS POP P,A ;GET THIRD ARG ARRY1A: HLRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF NIL JUMPE A,ARRY1F HRRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF T CAIN A,TRUTH JRST ARRY1F MOVEI C,(A) ;THIRD ARG BETTER BE AN ARRAY ITSELF MOVEI D,(T) PUSHJ P,AREGET ; TO COPY NEW ONE FROM MOVEI T,(D) HLLZ TT,ARRYQ1(F) ;SUPPLIED ARRAY BETTER BE TDNE TT,ASAR(A) ; OF CORRECT TYPE JRST ARRY1D MOVEI A,(C) %WTA ARRYQ0(F) ;IF NOT, LOSEY LOSEY JRST ARRY1A ARRYQ0: SIXBIT \NOT READTABLE - *ARRAY!\ SIXBIT \NOT OBARRAY - *ARRAY!\ ARRYQ1: AS.RDT,,VREADTABLE ;REQUIRED BIT,,NO ARG DEFAULT AS.OBA,,VOBARRAY ARRYQ2: VREADTABLE,,[PRDTBL] VNIL,,VOBARRAY ARRYQ3: 0,,2*LRCT ;MAX INDEX+1,,LENGTH OF DATA OBTSIZ+1+200,,OBTSIZ+1+200 ;FOOEY - GLS ARRYQ4: -1,,3 ;STANDARD GC AOBJN POINTER: -/2,,3 ; -,, ARRY1D: SKIPA AR2A,A ARRY1F: HRRZ AR2A,(AR2A) ;AR2A HAS SAR OF ARRAY TO COPY FROM MOVNI AR1,2(T) ;AR1 HAS NUMBER OF DIMENSIONS PUSH FXP,INHIBIT ;HALF A LOCKI HRRZ R,ARRYQ3(F) ;R HAS LENGTH OF ARRAY DATA HLRZ D,ARRYQ3(F) ;D HAS 1+LARGEST LEGAL INDEX PUSH FXP,D JRST ARRY2F ARRY2: CAML T,XC-2 ;REGULAR ARRAY JRST ARRY0G PUSH FXP,INHIBIT ;HALF A LOCKI MOVEI R,1 ;R ACCUMULATES SIZE OF DATA HRREI D,2(T) ;-<# OF DIMENSIONS> MOVNI AR1,2(T) ;AR1 GETS NUMBER OF DIMENSIONS ARRY2A: POP P,A ARRY2B: JSP T,FXNV1 TLNN TT,-1 JUMPG TT,ARRY2C WTA [ILLEGAL DIMENSION - *ARRAY!] JRST ARRY2B ARRY2C: PUSH FXP,TT IMULI R,(TT) ;PRODUCT OF ALL DIMENSIONS AOJL D,ARRY2A MOVEI D,(R) ;R HAS SIZE OF DATA, AR2A HAS NIL, SETZ AR2A, ; D HAS 1+LARGEST LEGAL INDEX HRRZ A,-1(P) ;PICK UP ARRAY NAME ARRYAE: JUMPE A,ARRY2F ;ALWAYS ALLOW NIL MOVEI TT,(A) ;GET POINTER TO ARRAY'S NAME ARG LSH TT,-SEGLOG ;MAKE POINTER TO ST TABLE MOVE TT,ST(TT) ;GET TABLE ENTRY TLNE TT,SA\SY ;OK IF SAR OR SYMBOL JRST ARRY2F ;WIN IF IT IS %WTA NASER ;ELSE WRNG-TYPE-ARG ERROR HRRZM A,-1(P) ;REPLACE RETURNED ARG JRST ARRYAE ;AND TRY AGAIN WITH ATOM TEST ARRY2F: SETOM INHIBIT ;OTHER HALF OF LOCKI HRLM AR1,TOTSPC ;SAVE NUMBER OF DIMENSIONS MOVEI T,(AR1) ;T ACCUMULATES SIZE OF HEADER MOVEM D,LLIP1 ;SAVE 1+LARGEST LEGAL INDEX MOVSI D,AS.SX TDNN D,ARYTP1(F) ;S-EXP OR FULLWORD ARRAY? AOJA T,ARRY2H ;FULLWORD NEEDS EXTRA WORD IN HEADER ADDI R,1 ;S-EXP PACKS TWO ENTRIES PER WORD LSH R,-1 ARRY2H: HRRZ TT,ARYIN2(F) ;ACCOUNT FOR LENGTHS OF ENTRIES IMULI R,(TT) MOVNM R,BPPNR ;- ADDI T,2 ;TWO WDS IN HEADER FOR JSP AND SAR HRLM T,BPPNR ;SAVE SIZE OF HEADER ADDI R,1(T) ;ONE WORD FOR GC AOBJN POINTER HRRM R,TOTSPC ;SAVE TOTAL SIZE OF ARRAY IN WORDS MOVEM AR2A,(P) ;CLOBBER 2ND ARG WITH SAR OF ARRAY TO COPY PUSH FXP,F ;SAVE ARRAY TYPE ;FALLS THROUGH ;FALLS IN SKIPN A,-1(P) ;ARRAY OF NIL GIVES A SAR JRST ARRY3A ;DON'T DO SARGET FOR NIL PUSHJ P,SARGET JUMPN A,ARRY6 ;ALREADY HAS A SAR ARRY3A: JSP T,SACONS MOVEI B,(A) MOVEI C,QARRAY SKIPE A,-1(P) PUSHJ P,PUTPROP ;AND PUTPROP IT UNLESS ATOM IS NIL JUMPN A,ARRY6 MOVEM B,-1(P) ;WE WANT TO RETURN THE SAR, NOT NIL! MOVEI A,(B) ARRY6: MOVEM A,ADDSAR ;ADDRESS OF THE SAR MOVEI B,ADEAD MOVEM B,ASAR(A) ;THIS SAYS THE OLD ARRAY, IF ANY, IS DEAD MOVE B,GCMKL PUSHJ P,MEMQ1 JUMPE A,ARRY6Q MOVEI B,DEDSAR HRLM B,(A) ARRY6Q: HRRZ TT,TOTSPC MOVEM TT,GAMNT MOVEI AR2A,GCMKL ;RUNNING BACKUP POINTER FOR GCMKL MOVEI C,0 ;TAIL OF GAMKL FOR WINNING DEAD BLOCK MOVEI F,-1 ;SIZE OF SMLST DEAD BLOCK NOT SMLR THAN REQUESTED SKIPA D,BPSH ;RUNNING LOCATION OF BLOCK BEGINNINGS ARRY6A: MOVE AR2A,AR1 HRRZ B,(AR2A) JUMPE B,ARRY7 ;ALL DONE WITH GCMKL HRRZ AR1,(B) HLRZ A,(AR1) MOVE TT,(A) SUB D,TT HLRZ A,(B) HLRZ A,ASAR(A) ;ALIVEP JUMPN A,ARRY6A CAMGE TT,F CAMGE TT,GAMNT JRST ARRY6A MOVE F,TT MOVE C,AR2A MOVE R,D JRST ARRY6A ARRY7: JUMPN C,ARRY7A ;FOUND DEAD BLOCK BIG ENOUGH HRRZ TT,TOTSPC ;ELSE MUST GRAB NEW BLOCK OF REQUISITE SIZE PUSHJ P,AGTSPC JUMPE A,ARRY8 SUB TT,TOTSPC HRRZM TT,INSP HRRZ TT,TOTSPC ;WILL MAKE AN ENTRY JSP T,FIX1A ;ON GCMKL. PUSHJ P,NCONS MOVE B,ADDSAR PUSHJ P,XCONS MOVEI B,(A) MOVEI A,GCMKL PUSHJ P,.NCNC1 MOVE TT,INSP JSP T,FIX1A MOVEM A,VBPEND JRST ARRY5 ARRY7A: HRRZ AR1,(C) ;C POINTS TO GCMKL TAIL WITH DEAD BLK TO BE USED SUB F,GAMNT ;F HAD SIZE OF USEABLE DEAD BLK JUMPN F,ARRY7B MOVE B,ADDSAR ;DEAD BLOCK IS EXACTLY SIZE NEEDED HRLM B,(AR1) ; SIMPLY SPLICE SAR INTO GCMKL AND XIT JRST ARRY4 ARRY7B: ADD R,F ;SLICE UP DEAD BLOCK INTO ARRAY IN HIGHER MOVEI A,DBM ; PART AND NEW DEAD BLK IN LOWER HRLM A,(AR1) MOVE TT,F JSP T,FIX1A HRRZ AR1,(AR1) ;INSTALL NEW DEAD BLOCK MARKER, MOVEI AR2A,(A) ; AND NEW DEAD BLOCK SIZE HRRZ TT,TOTSPC JSP T,FIX1A HRRZ B,(C) PUSHJ P,CONS MOVE B,ADDSAR PUSHJ P,XCONS HRLM AR2A,(AR1) XCTPRO HRRM A,(C) ;PROTECTED, JUST TO BE SAFE NOPRO ARRY4: HRRZM R,INSP ;R NOW HOLDS BEGINNING OF BLOCK FOR NEW ARRAY ARRY5: POP FXP,F ;INDEX INTO ARYTP1 HRRZ R,INSP ;R HELPS PUSH OUT ARRAY HEADER CAIGE F,NPARTP ;MAKE UP AOBJN POINTER FOR GC SKIPA C,ARRYQ4(F) MOVS C,BPPNR ADDI C,2(R) ;ALLOW FOR SIZE OF HEADER, ETC. PUSH R,C SKIPGE ARYIN1(F) ;MAKE DOUBLY SURE ARRAY TYPE EXISTS .VALUE SKIPE TT,ARYIN1(F) ;OOPS! DO WE NEED EXTRA INSTRUCTION? PUSH R,TT ;YES, PUSH IT OUT FIRST HLRZ T,ARYIN2(F) ;BASE ADDRESS OF TABLE OF SUBSCRIPT FUNCTION CALLS HLRZ D,TOTSPC ;NUMBER OF DIMENSIONS ADDI T,-1(D) PUSH R,(T) ;PUSH OUT JSP TO CORRECT PLACE PUSH R,ADDSAR ;PUSH OUT ADDRESS OF SAR ARRY5D: POP FXP,T ;PUSH OUT ARRAY DIMENSIONS, IN ORDER PUSH R,T SOJG D,ARRY5D SETZM 1(R) ;ZERO FIRST WORD OF DATA MOVSI A,1(R) ;MAKE UP BLT POINTER HRRI A,2(R) MOVN C,BPPNR ADDI C,(R) ;C HAS LIMIT FOR BLT POP P,AR1 ;DO WE WANT TO COPY ANOTHER ARRAY? JUMPE AR1,ARRY5F ;NO - ZERO OUT ARRAY HRL A,TTSAR(AR1) ;YES - REARRANGE BLT POINTER SOJA A,ARRY5G ARRY5F: TLZ C,-1 ;FOR ONE-WORD ARRAY, DON'T DO BLT! CAIE C,-1(A) ARRY5G: BLT A,(C) MOVE AR2A,ADDSAR ;PUT CORRECT STUFF INTO SAR ITSELF MOVE TT,INSP ADDI TT,2 HLL TT,ARYTP1(F) MOVEM TT,ASAR(AR2A) ADDI R,1 HRRM R,TTSAR(AR2A) HLRZ D,TOTSPC DPB D,[TTSDIM,,TTSAR(AR2A)] CAIGE F,NPARTP PUSHJ P,@ARRYQ5(F) ;PECULIAR ARRAYS NEED FIXING UP MOVE B,ADDSAR ;RETURN SAR IN B POP P,A ;RETURN ARG 1 IN A UNLKPOPJ ARRY8: SUB P,R70+1 HLRZ TT,TOTSPC MOVNI TT,1(TT) HRLI TT,-1(TT) ADD FXP,TT HRRZ TT,TOTSPC JSP T,FXCONS pushj p,%%RLFE ,,Q%%ARRAY UNLOCKI FAC [NO CORE - *ARRAY!] SUBTTL AREGET ROUTINE AREGET: PUSH P,A ;GET AN ARRAY SAR (AND INSIST ON ONE!) MOVEI TT,(A) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,SA JRST AREGT0 ;A SAR ITSELF IS ACCEPTABLE AREGT2: PUSHJ P,ARGET ;SO IS A SYMBOL WITH AN ARRAY PROPERTY JUMPE A,AREGT1 AREGT0: MOVE TT,ASAR(A) ;A KILLED ARRAY IS AS BAD AS NO ARRAY CAIE TT,ADEAD JRST POP1J ;SUCCESS! RETURN THE SAR IN A AREGT1: POP P,A ;FAILURE! CRAP OUT %WTA ARGT3 JRST AREGET ARGT3: SIXBIT \NOT AN ARRAY!\ SUBTTL MKDTAR/MKLSAR ROUTINE, AND ARRAYDIMS FUNCTION MKFLAR: SKIPA T,[QFLONUM] MKFXAR: MOVEI T,QFIXNUM JRST MKAR1 MKDTAR: TDZA T,T ;MAKE UP A DATA ARRAY [NO GC PROTECTION FOR ELTS] MKLSAR: MOVEI T,TRUTH ;MAKE UP A LIST ARRAY [GC PROTECTION] LSH TT,1 ;FINDS NUMBER OF DATA WORDS DESIRED IN TT MKAR1: PUSH P,[PX1J] ;A CONTAINS NAME FOR ARRAY PUSH P,A ;A=NIL => GENSYM A NAME PUSH P,T ;A=<-1,,> => JUST RETURN THE SAR PUSH FXP,TT ;LEAVES GENSYMMED NAME OF ARRAY IN A MOVEI A,(FXP) PUSH P,A ;LEAVES ADDRESS OF SAR IN B MOVEI T,0 SKIPN A,-2(P) PUSHJ P,GENSYM HRRZM A,-2(P) MOVNI T,3 JRST %%ARRAY SPECPRO INTZAX SACONS: SKIPN FFA ;SAR CONSER PUSHJ P,AGC MOVE A,@FFA XCTPRO EXCH A,FFA NOPRO HRLI T,((TT)) HLLM T,TTSAR(A) JRST (T) ;ARRAY-DIMENSION-N ADIMN: JSP T,FXNV1 ;just checks for fixnumness MOVE AR1,A MOVE A,B JSP R,ADIMC ;SUBR 1 - ARG MUST BE ARRAY MOVE F,(AR1) JUMPLE F,FALSE CAMLE F,TT ;TT HAS # OF DIMS JRST FALSE SUBM F,TT SOS TT MOVE TT,@TTSAR(C) JRST FIX1 ;ARRAY-#-DIMS ANDIM: JSP R,ADIMC ;SUBR 1 - ARG MUST BE ARRAY JRST FIX1 ARRTYP: JSP R,ADIMC MOVE A,F POPJ P, ADIMS0: MOVEI A,(C) %WTA ARGT3 ADIMC: MOVEI C,(A) ;COMMON ROUTINE FOR ARRAYDIMS/ARRAY-DIMENSION-N PUSHJ P,SARGET JUMPE A,ADIMS0 HRRZ T,ASAR(A) CAIN T,ADEAD JRST FALSE LOCKTOPOPJ MOVEI C,(A) MOVE T,ASAR(C) JFFO T,.+1 HRRZ F,ARYTYP(TT) ;F HAS SYMBOL FOR ARRAY TYPE CAIE F,TRUTH JRST .+3 TLNN T,AS.GCP MOVEI F,NIL LDB TT,[TTSDIM,,TTSAR(C)] ;# OF DIMENSIONS JRST (R) ;ARRAYDIMS ADIMS: JSP R,ADIMC ;SUBR 1 - ARG MUST BE ARRAY MOVNI D,(TT) ;D HAS -<# OF DIMS> MOVNI R,1 TDZA B,B ADIMS1: MOVEI B,(A) ;CONS UP LIST OF DIMENSIONS MOVEI TT,(R) MOVE TT,@TTSAR(C) JSP T,FXCONS PUSHJ P,CONS CAME R,D SOJA R,ADIMS1 MOVEI B,(F) ;CONS TYPE ON FRONT OF LIST JRST XCONS ;;; JSP T,ARYSIZ ;;; ACCEPTS A SAR IN A; RETURNS THE PRODUCT OF THE DIMENSIONS ;;; IN F, AND THE SIZE OF THE DATA IN WORDS IN TT. ;;; SAVES D AND R. ARYSIZ: HLL T,ASAR(A) ;RETURN ADDRESS IN IN RH OF T TLNE T,AS.RDT+AS.OBA JRST ARYSZ5 ;SPECIAL HANDLING FOR READTABLES AND OBARRAY LDB TT,[TTSDIM,,TTSAR(A)] MOVNS TT MOVE F,@TTSAR(A) ARYSZ3: AOJE TT,ARYSZ4 ;ON EXIT, F HAS PRODUCT OF ALL DIMENSIONS IMUL F,@TTSAR(A) JRST ARYSZ3 ARYSZ4: TLNE T,AS.SX JRST ARYSZ7 ARYSZ6: MOVE TT,F ;NUMERIC ARRAY - SIZES MAY BE 1, 2, 4 IFN DBFLAG+CXFLAG,[ TLNE T,AS.DB+AS.CX LSH TT,1 ] ;END OF IFN DBFLAG+CXFLAG DX$ TLNE T,AS.DX DX$ LSH TT,1 JRST (T) ARYSZ5: MOVEI F,LRCT ;ASSUME A READTABLE TLNE T,AS.RDT JRST ARYSZ6 MOVEI F,OBTSIZ+1+200 ;IF NOT, AN OBARRAY ARYSZ7: move tt,f ;ALLOW FOR S-EXPRESSION ARRAYS addi tt,1 ; HAVING TWO ELEMENTS/WORD LSH TT,-1 ;(Don't use MOVEI TT,1(F) in case array is JRST (T) ; just slightly bigger than 2^18.) OBAFIX: JUMPE AR1,CPOPJ ;FIX UP OBARRAY AFTER A BLTARRAY, ETC. MOVE T,TTSAR(AR2A) ; BY COPYING ALL THE BUCKETS HRLI T,442200 ;USER INTERRUPTS SHOULD BE SHUT OFF MOVEI D,OBTSIZ OBAFX3: ILDB A,T SETZ B, PUSHJ P,.APPEND ;USE *APPEND TO COPY LISTS DPB A,T SOJG D,OBAFX3 POPJ P, RDTFIX: SKIPA R,PROLIS ;FIX UP A READTABLE AFTER A BLTARRAY, ETC. RDTFX2: HRRZ R,(R) ; BY DUPLICATING ALL PROLIS ENTRIES JUMPE R,CPOPJ ; FOR MACRO CHAR FUNCTIONS HLRZ D,(R) HRRZ TT,(D) HLRZ T,(TT) CAIE T,(AR1) JRST RDTFX2 HRRZ B,(TT) MOVEI A,(AR2A) PUSHJ P,CONS HLRZ B,(D) PUSHJ P,XCONS MOVE B,PROLIS PUSHJ P,CONS MOVEM A,PROLIS JRST RDTFX2 SUBTTL *REARRAY FUNCTION .REARRAY: ;THIS CODE COULD STAND MUCH IMPROVEMENT JSP TT,LWNACK LA1234567,,Q.REARRAY AOJE T,.REA1 ;ONE ARG, DELETE THE ARRAY MOVEI D,(P) ADDI D,(T) HRLI D,(T) HRRZ A,(D) SUBI T,1 PUSH FXP,T .REA4B: PUSHJ P,AREGET MOVE T,ASAR(A) ;GET SAR TLNN T,AS.FIL\AS.JOB ;DON'T ALLOW JOB OR FILE ARRAY JRST .REA4A XCT .REA6A ;ISSUE WTA ERROR JRST .REA4B .REA4A: LOCKI PUSH P,A HLRZ T,ASAR(A) HRRZ A,1(D) .REA4: MOVSI F,-LARYTP .REA5: HRRZ B,ARYTP1(F) CAIN B,(A) JRST .REA7 AOBJN F,.REA5 .REA6: UNLOCKI POP FXP,T .REA6A: WTA [BAD ARRAY TYPE - *REARRAY!] MOVEM A,1(D) PUSH FXP,T LOCKI JRST .REA4 .REA7: HLRZ TT,ARYTP1(F) XORI TT,(T) ANDCMI TT,AS JUMPN TT,.REA6 .REA7A: PUSHJ P,.REA8 .REA2: LOCKI HRRZ AR1,(P) ;AR1 HAS THE OLD ARRAY SAR MOVEI AR2A,(A) ;AR2A HAS THE NEW ARRAY SAR PUSHJ P,.REA3 ;COPY OLD ARRAY DATA INTO NEW ARRAY JRST .REALOSE MOVEI B,ADEAD ;NOW INTER-CLOBBER THE TWO SARS EXCH B,ASAR(AR2A) MOVEM B,ASAR(AR1) ;STORE NEW CONTENTS OF ASAR TLNE B,AS ADDI B,1 MOVEM AR1,1(B) ;INSTALL CORRECT SAR IN ARRAY MOVE B,TTSAR(AR2A) HLLOS TTSAR(AR2A) MOVEM B,TTSAR(AR1) ;STORE NEW CONTENTS OF TTSAR MOVEI A,(AR1) MOVE B,GCMKL PUSHJ P,MEMQ1 JUMPE A,.REALOSE MOVEI B,DEDSAR HRLM B,(A) MOVE B,GCMKL MOVEI A,(AR2A) PUSHJ P,MEMQ1 JUMPE A,.REALOSE HRLM AR1,(A) UNLOCKI POP FXP,T HRLI T,-1(T) ADD P,T JRST POPAJ .REA8: PUSH P,R70 ;*ARRAY WILL CREATE A FRESH SAR PUSH P,1(D) AOBJN D,.-1 UNLOCKI MOVE T,(FXP) JRST %%ARRAY .REALOSE: SUB P,R70+1 UNLOCKI POP FXP,T PUSHJ FXP,LISTX PUSHJ P,NCONS MOVEI B,Q.REARRAY PUSHJ P,XCONS FAC [*REARRAY LOST!] ;;; SMASH ARRAY WHOSE SAR IS IN AR1 INTO ARRAY WHOSE SAR IS IN AR2A ;;; SKIPS ON SUCCESS - FAILS WHEN ARRAY TYPES DON'T MATCH .REA3: HLLZ TT,ASAR(AR1) HLLZ D,ASAR(AR2A) XOR TT,D TLZ TT,AS.GCP JUMPE TT,.REA3C ;WIN IF ARRAY TYPES MATCH TLNE TT,# ;ASSUME WIN IF BOTH NUMERIC POPJ P, .REA3C: AOS (P) MOVEI A,(AR1) JSP T,ARYSIZ ;RETURNS SIZE IN WORDS IN TT MOVE R,TT MOVEI A,(AR2A) JSP T,ARYSIZ HRRZS (P) CAMG TT,R ;MOVE NUMBER OF WORDS DICTATED JRST .REA3D ; BY THE SMALLER OF THE ARRAYS MOVE TT,R HRROS (P) ;REMEMBER WHETHER ARRAY GETS BIGGER OR SMALLER .REA3D: ADD TT,TTSAR(AR2A) HRRZ R,TTSAR(AR2A) HRL R,TTSAR(AR1) BLT R,-1(TT) ;TRANSFER THE DATA SKIPGE (P) ;IF DIDN'T SWITCH ARRAY SIZES THEN DO CHECK JRST .REA3E TLNE T,AS.SX ;IF S-EXP ARRAY TRNN F,1 ;AND AN ODD NUMBER OF ENTRIES SKIPA HLLZS -1(TT) ;MAKE SURE LAST HALFWORD IS ZERO .REA3E: TRNN D,AS.RDT+AS.OBA POPJ P, TRNE D,AS.RDT ;MUST PERFORM A SPECIAL FIXUPS" ARRYQ5: JRST RDTFIX ;; OBAFIX FOR OBARRAYS (AFTER BLT'TING) JRST OBAFIX ;; RDTFIX FOR READTABLES GETSP: JSP TT,LWNACK LA12,,QGETSP POP P,A MOVEI D,GETSP1 HRL D,VPURE AOJE T,GETSP0 HRLI D,(A) POP P,A GETSP0: JSP T,FXNV1 ;RETURNS BPEND-BPORG IF SPACE IS AVAILABLE TLCE D,-1 TLZ D,-1 LOCKTOPOPJ PUSH P,D AGTSPC: MOVEM TT,GAMNT ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT) SUB TT,@VBPEND JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE. MOVE A,VBPEND ;ALREADY OK MOVE TT,(A) POPJ P, GETSP1: JUMPE TT,FALSE SUB TT,@VBPORG JRST FIX1 .REA1: MOVE A,(P) ;REMOVES ARRAY BY PUTTING ADDRESS OF PUSHJ P,SARGET ; ERROR ROUTINE IN SAR, ETC. JUMPE A,POP1J MOVE T,ASAR(A) ;GET SAR TLNE T,AS.JOB\AS.FIL ;MUST NOT BE FILE OR JOB ARRAY JRST .REA1A MOVEI B,ADEAD XCTPRO MOVEM B,ASAR(A) MOVE B,[TTDEAD] MOVSI T,TTS TDNE T,TTSAR(A) IOR B,T MOVEM B,TTSAR(A) NOPRO JRST POPAJ .REA1A: POP P,A ;ARRAY IS FILE OR JOB OBJECT XCT .REA6A ;ISSUE WTA ERROR PUSH P,A JRST .REA1 SUBTTL MULTI-DIMENSIONAL ARRAY ACCESS ROUTINES ;;; THESE ARE LIKE THE FXNV ROUTINES; THEY TAKE A FIXNUM ;;; FROM AN ARGUMENT AC, CHECK ITS TYPE, AND PUT ITS VALUE ;;; IN R. THIS VALUE IS CHECKED TO ENSURE IT IS WITHIN THE ;;; NEXT DIMENSION VALUE. TT IS STEPPED ALONG THE VECTOR ;;; OF DIMENSIONS IN THE ARRAY HEADER. AYNV1 ADDITIONALLY ;;; PUTS THE ADDRESS OF THE SAR IN LISAR. SFXPRO AYNV1: HRRZ R,(TT) MOVEM R,LISAR AOJA TT,AYNV0 AYNV5: SKIPA A,AR2A AYNV4: MOVEI A,(AR1) JRST AYNV0 AYNV3: SKIPA A,C AYNV2: MOVEI A,(B) ;LEFT HALF OF B MAY BE NON-ZERO AYNV0: MOVEI R,(A) LSH R,-SEGLOG MOVE R,ST(R) TLNN R,FX JRST AYNVER ;LOSE IF NOT A FIXNUM SKIPL R,(A) ;MUST NOT BE NEGATIVE, CAML R,(TT) ; AND MUST BE BELOW NEXT DIMENSION CAIA AOJA TT,(T) ;RETURN TO CALLER, BUMPING POINTER IN TT SKIPA D,[IXEXBD] AYNVER: MOVEI D,NFXIX PUSH P,D MOVEI R,(TT) AYNVE1: HLRZ D,-1(R) ;WE MUST BACK UP THE POINTER TO THE JSP TT, CAIE D,(JSP TT,) ; WHICH IS WHERE THE ASAR POINTS SOJA R,AYNVE1 HRRZ D,(R) SUB TT,ASAR(D) ;SAVE TT AS AN ABSOLUTE OFFSET FROM THE ASAR EXCH D,(P) ; (SINCE DURING THE ERROR THE ARRAY MAY MOVE) XCT AYNVSFX ;SYNCHRONIZE WITH THE INTERRUPT LOCKOUT MECHANISM POP P,D ADD TT,ASAR(D) ;RESTORE THE TT POINTER USING THE JRST AYNV0 ; (POSSIBLY NEW) ASAR, AND TRY AGAIN .SEE 1DIMS ;THE 1-DIMENSIONAL ACCESS ROUTINES ARE IN LOW CORE 2DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMS1: ADDI R,(F) JRST ARYGET 2DIMF: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMF1: ADDI R,(F) JRST ANYGET IFN DBFLAG+CXFLAG,[ 2DIMD: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMD1: ADDI R,(F) JRST ADYGET ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ 2DIMZ: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMZ1: ADDI R,(F) JRST AZYGET ] ;END OF IFN DXFLAG ;;; THERE ARE FOUR SEPARATE 1DIM- AND 2DIM- ROUTINES FOR SPEED. ;;; FOR THE OTHERS, WHICH ARE LESS COMMON, WE PREFER TO SAVE ;;; SPACE. WE ENCODE THE ARRAY TYPE IN THE LEFT HALF OF B: ;;; 0 S-EXPRESSION ;;; 1 FIXNUM, FLONUM ;;; 2 DOUBLE, COMPLEX ;;; 3 DUPLEX ;;; PLEASANTLY, IF THIS NUMBER IS N, AN ARRAY ELEMENT IS OF SIZE ;;; 2^N HALFWORDS, BUT WE DO NOT USE THIS FACT. IFN DXFLAG, 3DIMZ: TLOA B,2 IFN DBFLAG+CXFLAG, 3DIMD: TLOA B,2 3DIMF: TLO B,1 3DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 ADDI F,(R) IMUL F,(TT) JSP T,AYNV3 3DIMX: HLRZ T,B TLZ B,-1 JRST .+1(T) JRST 2DIMS1 ;S-EXPRESSION JRST 2DIMF1 ;FIXNUM, FLONUM IFN DBFLAG+CXFLAG, JRST 2DIMD1 ;DOUBLE, COMPLEX .ELSE .VALUE IFN DXFLAG, JRST 2DIMZ1 ;DUPLEX .ELSE .VALUE IFN DXFLAG, 4DIMZ: TLOA B,2 IFN DBFLAG+CXFLAG, 4DIMD: TLOA B,2 4DIMF: TLO B,1 4DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 ADDI F,(R) IMUL F,(TT) JSP T,AYNV3 ADDI F,(R) IMUL F,(TT) JSP T,AYNV4 JRST 3DIMX IFN DXFLAG, 5DIMZ: TLOA B,2 IFN DBFLAG+CXFLAG, 5DIMD: TLOA B,2 5DIMF: TLO B,1 5DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 ADDI F,(R) IMUL F,(TT) JSP T,AYNV3 ADDI F,(R) IMUL F,(TT) JSP T,AYNV4 ADDI F,(R) IMUL F,(TT) JSP T,AYNV5 JRST 3DIMX NOPRO SUBTTL FILLARRAY AND LISTARRAY FILLARRAY: ;SUBR 2 SKOTT B,LS JRST FILLAA MOVEI C,(B) FILLA0: PUSH P,A PUSHJ P,AREGET ;GET SAR OF ARRAY HLLZ D,ASAR(A) TLNE D,AS.JOB+AS.FIL+AS.RDT+AS.OBA JRST FILLUZ ;CAN'T FILL JOB OR FILE OR READTABLE OR OBARRAY JSP T,ARYSIZ ;GET SIZE OF ARRAY IN F SETZ TT, ;TT WILL BE USED FOR INCREMENTAL INDEX TLNN D,AS.SX JRST FILLA2 FILLA1: JUMPE C,FILLA4 ;FILL LOOP FOR S-EXP ARRAYS HLRZ B,(C) HRLM B,@TTSAR(A) HRRZ C,(C) SOJE F,POPAJ JUMPE C,FILLA5 HLRZ B,(C) HRRM B,@TTSAR(A) HRRZ C,(C) SOJE F,POPAJ AOJA TT,FILLA1 FILLA4: HRLM B,@TTSAR(A) SOJE F,POPAJ FILLA5: HRRM B,@TTSAR(A) SOJE F,POPAJ ADDI F,1 ROT F,-1 ;ROT, NOT LSH; SEE BELOW MOVEI D,1 ;MULTIPLIER FOR ELEMENT SIZE JRST FILLA7 FILLA2: TLNN D,AS.FX+AS.FL IFN DBFLAG+CXFLAG, JRST FILLD1 .ELSE .VALUE MOVEI B,(A) ;FILL LOOP FOR FULLWORD ARRAYS FILLA3: JUMPE C,FILLA6 HLRZ A,(C) HRRZ C,(C) MOVEI R,(TT) TLNN D,AS JSP T,FLNV1X JSP T,FXNV1 EXCH TT,R MOVEM R,@TTSAR(B) SOJE F,POPAJ AOJA TT,FILLA3 IFN DBFLAG+CXFLAG,[ FILLD1: TLNN D,AS.DB+AS.CX DX$ JRST FILLZ1 DX% .VALUE MOVE F,D FILLD3: JUMPE C,FILLD6 ;FILL LOOP FOR DOUBLE AND COMPLEX ARRAYS HLRZ A,(C) HRRZ C,(C) MOVEI R,(TT) DB$ CX$ TLNN F,AS.DB DB$ CX$ JSP T,CXNV1X DB$ JSP T,DBNV1 DB% JSP T,CXNV1 EXCH TT,R MOVEM R,@TTSAR(B) ADDI TT,1 MOVEM D,@TTSAR(B) SOJE F,POPAJ AOJA TT,FILLD3 FILLD6: ADDI TT,1 MOVEM D,@TTSAR(B) MOVEI D,2 SOJA TT,FILLA9 ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ FILLZ1: TLNN D,AS.DX .VALUE PUSH FXP,TT PUSH FXP,F FILLZ3: JUMPE C,FILLZ6 ;FILL LOOP FOR DUPLEX ARRAYS HLRZ A,(C) HRRZ C,(C) JSP T,DXNV1 MOVE T,TT MOVE TT,-1(FXP) KA MOVEM R,@TTSAR(B) KA ADDI TT,1 KA MOVEM F,@TTSAR(B) KA ADDI TT,1 KIKL DMOVEM R,@TTSAR(B) KIKL ADDI TT,2 MOVEM T,@TTSAR(B) ADDI TT,1 MOVEM D,@TTSAR(B) ADDI TT,1 MOVEM TT,-1(FXP) SOSE (FXP) JRST FILLZ3 POPI FXP,2 JRST POPAJ FILLZ6: KA MOVEM R,@TTSAR(B) KA ADDI TT,1 KA MOVEM F,@TTSAR(B) KA ADDI TT,1 KIKL DMOVEM R,@TTSAR(B) KIKL ADDI TT,2 MOVEM T,@TTSAR(B) ADDI TT,1 MOVEM D,@TTSAR(B) SUBI TT,3 MOVEI D,4 JRST FILLA8 ] ;END OF IFN DXFLAG OPNCLR: MOVEI F,LONBFA ;USED BY $OPEN TO CLEAR ARRAY SETZB TT,R ;SAR OF FILE ARRAY IS IN A MOVEI B,(A) PUSH P,A FILLA6: MOVEI D,1 FILLA9: MOVEM R,@TTSAR(B) FILLA8: SOJE F,POPAJ TLO F,400000 ;AVOID HLLZS BELOW MOVEI A,(B) FILLA7: LOCKI ;IF LIST RUNS OUT, DUPLICATE INTO ADD TT,TTSAR(A) ; REMAINING ELEMENTS WITH A BLT IMULI F,(D) ;ACCOUNT FOR SIZE OF ELEMENTS ADDI F,(TT) ADDI F,-1(D) HRLI TT,(TT) ADDI TT,(D) BLT TT,(F) SKIPL F ;FOR AN ODD LENGTH S-EXP ARRAY, ZERO RH OF HLLZS (F) ; LAST WORD SO GC WON'T MARK IT SPURIOUSLY POP P,A UNLKPOPJ FILLAA: TLNE TT,SA ;A SAR? JRST FILLAB TLNE TT,SY ;A NON-NULL SYMBOL? JUMPN B,FILLAB EXCH A,B WTA [CANT FILLARRAY WITH THIS!] EXCH A,B JRST FILLARRAY FILLAB: JCALLF 2,QBLTARRAY FILLUZ: POP P,A WTA [WRONG TYPE ARRAY!] JRST FILLA0 LISTARRAY: JSP TT,LWNACK LA12,,QLISTARRAY HRLZI D,377777 ;INITIAL SETTING FOR COUNT AOJE T,LISTA3 POP P,B ;COUNT INITIALIZED TO 2ND ARG IF PRESENT JSP T,FXNV2 LISTA3: POP P,A LISTAZ: PUSHJ P,AREGET MOVE T,(A) ;GET SAR BITS TLNN T,AS.JOB ;CAN'T BE JOB ARRAY TLNE T,AS.FIL ; OR FILE ARRAY JRST LISFIL JSP T,ARYSIZ ;GET SIZE OF ARRAY JUMPL D,LISTA7 ;SET COUNT TO SIZE IF 2ND ARG NEGATIVE CAMGE D,F ;OR IF 2ND ARG BIGGER THAN SIZE MOVE F,D LISTA7: MOVEI C,(A) SETZB A,B JUMPE F,CPOPJ TLNN T,AS.SX JRST LISTA5 MOVEI TT,-1(F) LSHC TT,-1 ;FIGURE OUT IF ODD OR EVEN JUMPGE D,LISTA2 ; NUMBER OF ITEMS TO LIST LISTA1: HRRZ B,@TTSAR(C) ;S-EXP ARRAY LISTING LOOP PUSHJ P,XCONS LISTA2: HLRZ B,@TTSAR(C) PUSHJ P,XCONS SOJGE TT,LISTA1 POPJ P, LISTA5: TLNN T,AS.FX+AS.FL IFN DBFLAG+CXFLAG, JRST LISTD5 .ELSE .VALUE SKIPA D,T ;FULLWORD ARRAY LISTING LOOP LISTA6: MOVEI B,(A) MOVEI TT,-1(F) MOVE TT,@TTSAR(C) TLNN D,AS ;CONS UP FLONUM OR FIXNUM? JSP T,FLCONX ;FLONUM CONS WITH SKIP RETURN JSP T,FXCONS ;FIXNUM CONS PUSHJ P,CONS SOJG F,LISTA6 POPJ P, LISFIL: WTA [CANT LIST JOB- OR FILE- ARRAY!] JRST LISTAZ IFN DBFLAG+CXFLAG,[ LISTD5: TLNN T,AS.DB+AS.CX DX$ JRST LISTZ5 DX% .VALUE SKIPA R,T LISTD6: MOVEI B,(A) ;DOUBLE/COMPLEX ARRAY LISTING LOOP KA HRROI TT,-1(F) KA ROT TT,1 ;SNEAKY, HUH? KA MOVE D,@TTSAR(C) KA SUBI TT,1 KA MOVE TT,@TTSAR(C) KIKL MOVEI TT,-1(F) KIKL LSH TT,1 KIKL DMOVE TT,@TTSAR(C) DB$ CX$ TLNN R,AS.DB DB$ CX$ JSP T,CXCONX ;COMPLEX CONS WITH SKIP RETURN DB$ JSP T,DBCONS DB% JSP T,CXCONS PUSHJ P,CONS SOJG F,LISTD5 POPJ P, ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ LISTZ5: TLNN T,AS.DX .VALUE PUSH FXP,F SKIPA TT,F LISTZ6: MOVEI B,(A) LSH TT,2 KA MOVE R,@TTSAR(C) KA ADDI TT,1 KA MOVE F,@TTSAR(C) KA ADDI TT,2 KA MOVE D,@TTSAR(C) KA SUBI TT,1 KA MOVE TT,@TTSAR(C) KIKL DMOVE R,@TTSAR(C) KIKL ADDI TT,2 KIKL DMOVE TT,@TTSAR(C) JSP T,DXCONS PUSHJ P,CONS SOSE TT,(FXP) JRST LISTZ6 POPI FXP,1 POPJ P, ] ;END OF IFN DXFLAG PGTOP ARA,[ARRAY STUFF]