TITLE COMMON SUBROUTINES FOR SNOBOL SUBTTL BY LARRY WADE / THIS ASSEMBLY MADE WITH C.366 IFNDEF REENTR, IFN REENTR,< TWOSEG RELOC ^O400000 > EXTERN FLOUT. EXTERN I ;INTEGER DATA TYPE EXTERN STYPE EXTERN JOBFF,JOBREL INTERN SPCINX,LOCSPR,APPEND,INTSPX,REALSX INTERN CPYPAX,INTDEV,INFMT EXTERN SYNTAB,SYNSIZ,PUTTAB,PUTSIZ EXTERN DATBUF INTERN INTCOR INTERN PDL EXTERN PDSTCK PDSIZ=30 PDL: IOWD PDSIZ,PDSTCK INTERN DATX DATX: CALLI 1,14 ;GET THE DATE FROM THE MONITOR. IDIVI 1,^D31 ;DIV. BY 31 TO OBTAIN THE DAY-1. AOS 2 ;TO OBTAIN THE DAY. IDIVI 2,^D10 ;CONVERT INTO TWO DEC. DIGITS. SKIPN 2 ;IS THE DAY < 10? MOVNI 2,20 ;YES, OUTPUT BLANK. MOVEI 0,DATBUF ;CREATE POINTER HRLI 0,440700 ;TO DEPOSIT DATE JSP 4,SUB1 ;DEPOSIT DAY IDIVI 1,^D12 ;TO OBTAIN THE MONTH MOVE 3,[POINT 7,TABLE(2)] ;BYTE POINTER FOR MONTH GETMON: ILDB 4,3 ;GET MONTH FROM THE TABLE IDPB 4,0 ;DEPOSIT MONTH TLNE 3,760000 ;ALL OF THE MONTH? JRST GETMON ;NO, GET NEXT CHAR. MOVEI 2,^D64(1) ;YES, GET THE YEAR IDIVI 2,^D10 ;CONVERT INTO TWO DEC. DIGITS JSP 4,SUB1 ;DEPOSIT YEAR POPJ P, ;SUB1 CONVERTS THE DAY AND THE YEAR INTO ASCII CHARS, AND ;DEPOSITS THEM IN THE TWO WORD ARRAY. SUB1: ADDI 2,60 ;CONVERT FIRST DIGIT TO ASCII IDPB 2,0 ;DEPOSIT FIRST DIGIT ADDI 3,60 ;CONVERT SECOND DIGIT TO ASCII IDPB 3,0 ;DEPOSIT SECOND DIGIT JRST (4) ;RETURN TO MAIN SEQ. PAGE TABLE: ASCII /-JAN-/ ASCII /-FEB-/ ASCII /-MAR-/ ASCII /-APR-/ ASCII /-MAY-/ ASCII /-JUN-/ ASCII /-JUL-/ ASCII /-AUG-/ ASCII /-SEP-/ ASCII /-OCT-/ ASCII /-NOV-/ ASCII /-DEC-/ INTERN INFMT INFMT: ASCII \(16A5)\ ;GENERALIZED FORMAT FOR ALL INPUT INTERN SOURCF,TITLEF SOURCF: ASCII \(1H0,'DIGITAL EQUIPMENT CORP., PDP-10'/)\ TITLEF: ASCII \(1H1,'SNOBOL4 (VERSION 3.4.3, JAN. 16, 1971)'/)\ ;AT COMPILER LEVEL. INTERN BUFPNT EXTERN BUFIN BUFPNT: POINT 7,BUFIN, EXTERN ALPHI.,ALPHO. INTERN TXPNT EXTERN TXBUF TXPNT: POINT 7,TXBUF, ;ORDER TO INITIALIZE ARRAY0S AND BUFFERS CPOPJ2: AOS (P) CPOPJ1: AOS (P) CPOPJ: POPJ P, PAGE INTERN RENCOM EXTERN SYSCUT,DMPCL,LISTCL RENCOM: SETOM DMPCL EXTERN NCTRLC,CUTFLG,JOBOPC SKIPN NCTRLC ;CAN WE INTERRUPT AT THIS POINT? JRST SYSCUT ;YES, SO DO IT EXTERN EOL.,FIN ; SINCE WE ARE SOMEWHERE IN FORSE DOING SOME I/O LET'S FORCE A ; FIN. UUO AND CAUSE AN EXIT MOVEM 0,CUTFLG MOVEI 0,RNCOM1 EXCH 0,CUTFLG SETOM EOL. JRST FIN ;DO THE FIN. AND RETURN AT RNCOM1 RNCOM1: SETZM CUTFLG JRST SYSCUT ; CPYPAX IS CALLED BY "CPYPAT" MACRO ; A1,A2...A6 CONTAIN THE ADDRESS OF DESCRIPTORES ; D1,D2...D6 RESPECTIVELY CPYPAX: MOVE R1,(A1) MOVE R2,(A2) MOVE R3,(A6) CPY3: MOVE A0,2(R2) MOVEM A0,2(R1) MOVE A0,3(R2) MOVEM A0,3(R1) MOVE A0,2*D(R2) SKIPE A0 ADD A0,(A4) ;F1(X)=X+4 IF X NOT EQUAL TO 0 MOVEM A0,2*D(R1) HRRZ A0,2*D+1(R2) JUMPE A0,CPY1 ADD A0,(A4) ;F2(X)=X+A4 IF X NE TO 0 SKIPA CPY1: MOVE A0,(A5) ;F2(X)=A5 IF X=0 MOVEM A0,2*D+1(R1) MOVE A0,3*D(R2) ;GET A9+A3 ADD A0,(A3) MOVEM A0,3*D(R1) HRRZ A0,3*D+1(R2) ;GET V9+A3 ADD A0,(A3) MOVEM A0,3*D+1(R1) HRRZ A0,D+1(R2) ;LOOK AT V7 CAIE A0,3 JRST CPY2 ;THIS CHECK DIFFERENT FOR VER 3 MOVE A0,4*D(R2) MOVEM A0,4*D(R1) MOVE A0,4*D+1(R2) MOVEM A0,4*D+1(R1) CPY2: HRRZ A0,D+1(R2) ;GET V7 ADDI A0,1 IMULI A0,D SUBI R3,(A0) ;GET NEW R3 ADDI R1,(A0) ADDI R2,(A0) SKIPLE R3 JRST CPY3 CPY4: MOVEM R1,(A1) POPJ P, ; INTEGER TO STRING CONVERSION ROUTINE ; CALLED BY "INTSPC" MACRO ; A0=ADDRESS OF OUTPUT SPECIFIER ; A1=INTEGER TO BE CONVERTED INTSPX: SETZM SPECL(A0) ;SET LENGTH=0 INITIALLY ; CLEAR FLAG FIELD AND SET 'SPCFLG' TO UNIQUELY IDENTIFY ; THIS AS A SPECIFIER MOVSI A3,SPCFLG HLLM A3,SPECF(A0) MOVE A3,[POINT 7,BUFSPX,] HRRM A3,(A0) ;SET ADDRESS FIELD MOVEM A3,SPECO(A0) ;SET OFFSET FIELD JUMPGE A1,INTS1 MOVN A1,A1 ;NEGATIVE, SO FORCE POSITIVE MOVEI CH,"-" IDPB CH,A3 AOS SPECL(A0) ;BUMP LENGTH INTS1: MOVEI A4,^O12 ;RADIX 10 RDXPRT: IDIVI A1,(A4) HRLM A2,0(P) ;STORE ON LEFT HALF OF LIST SKIPE A1 ;DONE IF NUMERATOR GOES TO ZERO PUSHJ P,RDXPRT ;RECURISIVE CALL HLRZ CH,0(P) ADDI CH,"0" ;CONVERT TO ASCII IDPB CH,A3 AOS SPECL(A0) POPJ P, ;EVENTUALLY RETURN TO CALLER PAGE EXTERN BUFSPX PAGE EXTERN FRSGPT,HDSGPT,TLSGP1,OCALIM ;FREE SEGMENT POINTER,HEADER SEGMENT POINTER AND TAIL INTERN INTCOR ; BECAUSE OF DESIGN DECISIONS IN SNOBOL, IT IS NECESSARY ; TO REINITIALIZE MANY-MANY VARAIBLES AND CONSTANTS ON ; EACH RESTART OF SNOBOL (EXCEPT THE FIRST, BUT WE DO IT ; ANYWAY). THIS IS DUE TO THE FACT THAT SOME NECESSARY ; CONSTANTS ARE IRREPARABLY CHANGED DURING EXECUTION. ; SINCE THERE ARE SO MANY, WE KEEP THESE ON A DISK FILE ; CALLED SNOBOL.INI AND READ THIS FILE INTO THE PROPER ; CORE AREA (BOUNDED BY DTLIST AND ARTHNO). ; SNOBOL.INI IS CREATED DURING SNOBOL GENERATION TIME ; BY USING THE /C SWITCH (FOR CREATE). EXTERNAL DTLIST,ARTHNO INTERN CORCHN CORCHN==^O16 ;CHANNEL TO DO INPUT FROM SNOBOL.INI EXTERN INIST%,ILIST% EXTERN TOTAVL,STCORE,ICORE,NUMIOB EXTERN ERRSET INTCOR: JSA ^O16,ERRSET ARG ZERO ;TELL HIM WE DON'T WANT ANY ERROR PRINTOUT INIT CORCHN,17 ;DUMP MODE,RANDOM CHANNEL SIXBIT/SYS/ ;ASSIGN DSK SYS IF ON OWN AREA Z ;DUMP MODE,SO NO BUFFERS HALT . ;FBTSES INTCR1: SETZM INIST%+3 LOOKUP CORCHN,INIST% JRST INTCR2 INTCR4: SKIPN FRSTIM JRST ICOR11 MOVEI A0,ARTHNO ;CALCULATE WC SUBI A0,DTLIST MOVNS A0 HRLM A0,ILIST% MOVEI A0,DTLIST-1 HRRM A0,ILIST% ;FIX UP IOWD SETZM ILIST%+1 INPUT CORCHN,ILIST% ;INPUT IT ICOR11: RELEASE CORCHN, ;GIVE IT UP ICOR1: SETOM FRSTIM RELOC FRSTIM: Z RELOC MOVE A0,JOBREL ;NOW MAKE UP DYNAMIC STORAGE MOVEM A0,ICORE ;SAVE FOR LATER SHRINKAGE SUB A0,JOBFF ;GET AMOUNT OF FREE STORAGE IDIVI A0,^O1777 ;CONVERT TO NUMBER OF 1K BLOCKS MOVEM A0,STCORE ;AMOUNT OF STARTING FREE CORE MOVEI A1,0 ;FIND OUT HOW MUCH CORE WE HAVE CALLI A1,11 ;CORE UUO JFCL IMULI A1,2000 ;CONVERT TO RELATIVE ADDR IFN REENTR,< EXTERN JOBHRL HLRZ A0,JOBHRL SUBI A1,(A0) ;ACCOUNT FOR HIGH SEG SIZE > MOVEM A1,TOTAVL ;TOTAL AVAILABLE TO US MOVE A0,JOBREL SUBI A0,2*D ;SAFTEY FACTOR MOVEM A0,TLSGP1 ; /I SWITCH CODE FOR IO BUFFERING MOVE A0,NUMIOB ;NUMBER OF IO BUFFERS TO INCREASE TO IMULI A0,^O204*2 ADDI A0,^O204*4 ADD A0,JOBFF ;RELOCATE ADDI A0,10 ;SAFTEY FACTOR ICOR2: MOVEM A0,FRSGPT ;FREE SEGMENT POINTER MOVEM A0,HDSGPT ;PERMANENT HEADER WORD EXTERN STRREF SETZM STRREF ;CLEAR THE PEG COUNTER ; GUARD AGAINST CORE BOUNDARIES BEING EXCEEDED AT THIS POINT EXTRACARE: ADDI A0,5*^O1777 ;5K IS MAGIC EXCESS AMT CAMG A0,JOBREL ;HAVE WE EXCEED JOBREL? POPJ P, ;NO,SO RETURN CALLI A0,11 ;GET THE NEEDED CORE EXTERN CORERR JRST CORERR ;NOT AVAILABLE, SO GIVE ERROR MSG MOVE A0,JOBREL SUBI A0,2*D ;FIX UP TLSGP1 MOVEM A0,TLSGP1 POPJ P, ;RETURN CAREFREE AND HAPPY! PAGE INTERN NUMINP,NUMOUT EXTERN UNITI,UNITO NUMINP: EXP UNITI ;INPUT DEVICE NUMBER NUMOUT: EXP UNITO ;OUTPUT DEVICE NUMBER NUMONE: EXP 1 ;ONE? NUMTWO: EXP 2 ;TWO? NUMSNS==^D29 ;DEVICE NO. FOR SNOOL SAVE FILE OPERATIONS NUM29: EXP NUMSNS ;"SNS" DEVICE NUMBER EXTERN CSWSET INTCR2: SETZM INIST%+2 SETZM INIST%+3 RELEASE CORCHN,0 INIT CORCHN,17 SIXBIT /DSK/ Z HALT . LOOKUP CORCHN,INIST% SKIPA JRST INTCR4 INTCR3: RELEASE CORCHN,0 PUSHJ P,CSWSET ;WRITE THE FILE ON DISK JFCL INIT CORCHN,17 SIXBIT /DSK/ Z HALT . JRST INTCR1 ;AND CONTINUE PAGE INTDEV: PUSHJ P,FIXLST PUSHJ P,FIXSRC POPJ P, INTERN FIXSRC EXTERN OFILE,IFILE,LSTFIL,SRCFIL INTERN INTDEV EXTERN OFILBF,IFFAIL,IFILBF FIXLST: SETZM OFILBF+3 ;CLEAR OLD PPN MOVEI A0,6 MOVE A1,[POINT 6,LSTFIL,] ;SOURCE MOVE A2,[POINT 7,OFILBF,] ;DESTINATION PUSHJ P,FIXNAM MOVEI A0,3 MOVE A1,[POINT 6,LSTFIL+1,] PUSHJ P,FIXEXT MOVE A1,LSTFIL+2 MOVEM A1,OFILBF+3 ;TRANSFER PPN JSA Q,OFILE JUMP 0,NUMOUT JUMP 5,OFILBF JUMP 0,OFILBF+3 POPJ P, FIXSRC: SETZM IFILBF+3 MOVEI A0,6 MOVE A1,[POINT 6,SRCFIL,] ;SOURCE MOVE A2,[POINT 7,IFILBF,] ;DESTINATION PUSHJ P,FIXNAM MOVEI A0,3 MOVE A1,[POINT 6,SRCFIL+1,] PUSHJ P,FIXEXT MOVE A1,SRCFIL+2 MOVEM A1,IFILBF+3 ;TRANSFER PPN ; CHECK FOR A SNOBOL SAVE FILE HLRZ A0,SRCFIL+1 ;GET EXTENSION CAIE A0,(SIXBIT .SNS.) JRST FIX1 JSA Q,IFILE JUMP 0,NUM29 JUMP 5,IFILBF ;READ THE FILE MOVEI A0,0 ;CHECK FOR FILE NOT THERE EXCH A0,IFFAIL JUMPN A0,NOFILE PUSHJ PDP,BUFCLR ;CLEAR OUT OLD GARBAGE FIXS1: RTB. 0,NUMSNS ;READ THE CONTROL BLOCK FIRST SLIST. 0,BUFIN ARG 0,^D30 FIN. MOVE A0,BUFIN ;FIND OLD JOBREL JUMPE A0,BADSNS ;BAD FORMAT ON INPUT FILE CALLI A0,^O11 ;CORE UUO JRST FIX2 MOVE A0,BUFIN+1 ;FIND NO. OF WORDS TO READ HRRM A0,SIZEIN MOVE A0,BUFIN+2 HRRM A0,FIX6 ;STORE SIZE MOVE A0,BUFIN+3 HRRM A0,FIX5 ;STORE ADDRESS JRST FIX3 RELOC ;SWITCH TO LOW SEGMENT FIX3: RTB. 0,NUMSNS SLIST. 0,DTLIST SIZEIN: ARG 0,7777 ;FIXED UP AT RUN TIME FIN. FIX5: RTB. 0,NUMSNS FIX6: SLIST. 0,. ;FIXED UP AT RUN TIME FIX7: ARG 0,0 FIN. JRST FIX4 RELOC ;SWITCH BACK TO HIGH SEGMENT FIX4: MOVSI 17,BUFIN+3 ;RESTORE ACS BLT 17,17 EXTERN RETNUL EXTERN SAVECL MOVEI A0,1 MOVEM A0,SAVECL POPJ PDP, ;RETURN TO THE POINT AFTER ;WHERE 'SAVE' WAS ORIGINALLY CALLED MLON FIX2: TTCALL 3,[ASCIZ /CAN'T EXPAND CORE FOR SNOBOL SAVE FILE /] JRST F4EXEC EXTERN F4EXEC FIX1: JSA Q,IFILE ;SPECIFY INPUT FILE NAME JUMP 00,NUMINP ;FORTRAN INPUT NUMBER JUMP 05,IFILBF ;INPUT BUFFER FOR FILENAME JUMP 0,IFILBF+3 SKIPE ETMCL ;DON'T CHECK IF IN INTERPRETER JRST CPOPJ MOVEI A0,0 ;CHECK FOR FILE NOT THERE EXCH A0,IFFAIL JUMPN A0,NOFILE POPJ P, FIXEXT: MOVEI A3,"." IDPB A3,A2 FIXNAM: ILDB A3,A1 ;GET A SOURCE CHARACTER JUMPE A3,CPOPJ ADDI A3,40 ;CONVERT TO ASCII IDPB A3,A2 SOJG A0,FIXNAM POPJ P, NOFILE: TTCALL 3,[ASCIZ /?INPUT FILE NOT FOUND /] JRST F4EXEC BADSNS: TTCALL 3,[ASCIZ /?BAD INPUT FORMAT ON SAVE FILE /] JRST F4EXEC PAGE EXTERN BINWR.,ERR.,FAIL,DTLIST INTERNAL SAVCOR ; THIS ROUTINE IMPLEMENTS THE SAVE(FILE) FUNCTION ; IT ASSUMES A FILE NAME OF THE FORM FOO.SNS, WHERE ; 'SNS' SIGNIFIES THE SNOBOL SAVE FORMAT FILE DEFAULT ; ; CALLS OF THIS FUNCTION ARE OF THE FORM ; ; SAVE('SNIP.SNS') :F(HELP) ; ; CALL: MOVEI A2,SPECIFIER ADDRESS ; PUSHJ PDP,SAVCOR ; SUCCESS RETURN ; THE LAYOUT OF THE CONTROL BLOCK IS ; ; BUFIN+0 OLD JOBHRL,,OLD JOBREL ; BUFIN+1 SIZE OF BLOCK STARTING AT CUTFLG EXTERN JOBSA ; BUFIN+2 SIZE OF BLOCK STARTING AT C(LH(JOBSA)) ; BUFIN+3 -BUFIN + 7 NOT USED ; BUFIN+10 AC SAV AREA SAVCOR: PUSHJ P,BUFCLR ;CLEAR THE OUTPUT BUFFER MOVE A0,JOBREL ;REMEMBER HOW MUCH CORE WE HAVE MOVEM A0,BUFIN IFN REENTR,< MOVE A0,JOBHRL HRLM A0,BUFIN > MOVEI A0,ARTHNO SUBI A0,CUTFLG MOVEM A0,BUFIN+1 HRRM A0,LSTSIZ MOVE A0,JOBREL HLRZ A1,JOBSA HRRM A1,SAVC4 SUB A0,A1 MOVEM A0,BUFIN+2 HRRM A0,SAVC5 MOVEM A1,BUFIN+3 MOVEI A1,BUFIN+10 ;SAVE ACS ALSO BLT A1,BUFIN+10+17 ; NOW WRITE OUT THE TWO AREAS, ONE A CONTROL BLOCK AND THE OTHER ; ALL OF THE ACTUAL VARIABLE DATA WTB. 0,NUMSNS ;SELECT UNIT 29 SLIST. 0,BUFIN ARG 0,^D30 FIN. JRST SAVC1 RELOC ;SWITCH TO LOW SEGMENT SAVC1: WTB. 0,NUMSNS SLIST. 0,CUTFLG LSTSIZ: ARG 0,7777 ;FIXED AT RUN TIME FIN. SAVC3: WTB. 0,NUMSNS SAVC4: SLIST. 0,. SAVC5: ARG 0,0 FIN. JRST SAVC2 RELOC ;SWITCH TO HIGH SEGMENT SAVC2: POPJ P, PAGE ; CALLED FROM APDSP MACRO ; A0=ADDRESS OF STRING 1-STRING 2 IS APPENDED TO THIS STRING ; A1=ADDRESS OF STRING 2 SPECIFIER APPEND: MOVE A3,SPECO(A0) ;GET BYTE POINTER OF STRING1 MOVE A4,SPECL(A0) ;CHECK FOR NULL STRING APPEN3: JUMPE A4,APPEN1 CAIGE A4,5 JRST APPEN2 IDIVI A4,5 ADD A3,A4 MOVE A4,A5 APPEN2: SKIPE A4 IBP A3 SOJG A4,.-1 ; THE ABOVE CODE TO GET TO THE END OF A STRING WAS ADOPTED ; BECAUSE THE CODE 'DUPL('A',50000)' TOOK FOREVER TO EXECUTE APPEN1: MOVE A4,SPECO(A1) ;GET POINTER TO STRING2 MOVE A5,SPECL(A1) ;GET NUMBER OF CHARACTERS TO MOVE JUMPE A5,CPOPJ ;CHECK FOR NULL STRING ILDB CH,A4 IDPB CH,A3 ;MOVE IT SOJG A5,.-2 ;MOVE ALL OF IT- MOVE A5,SPECL(A1) ADDM A5,SPECL(A0) ;INDICATE NEW LENGTH POPJ P, ;AND CALL IT QUITS PAGE ; CALLED BY "LOCSP" MACRO ; A0=ADDRESS OF INPUT DESCRIPTOR ; A1=ADDRESS OF SPECIFIER LOCSPR: MOVE A2,(A0) ;GET "A" MOVSI A3,SPCFLG IORM A3,1(A1) ;UNIQUELY IDENTIFY AS A SPECIFIER JUMPE A2,LOCS1 ;A=0 TEST MOVE A3,(A0) ;COPY DESCRIPTOR INTO SPECIFIER MOVEM A3,(A1) MOVE A3,1(A0) MOVEM A3,1(A1) MOVSI A3,SPCFLG ;UNIQUELY IDENTIFY AS A SPECIFIER IORM A3,1(A1) MOVEI A3,4*CPD/5 ;CPD=NO. OF CHARACTERS/DESCRIPTOR HRLI A3,^O440700 ;MAKE A BYTE POINTER OUT OF IT ADD A3,(A0) ;PUT IN ADDRESS PART MOVEM A3,SPECO(A1) ;STORE THE POINTER IN OFFSET FIELD HRRZ A3,1(A2) ;GET VALUE FIELD-"I" SKIPA LOCS1: MOVEI A3,0 MOVEM A3,SPECL(A1) ;STORE LENGTH FIELD POPJ P, PAGE ; CALL: PUSHJ P,STREAM ; A0=BYTE POINTER TO INPUT STRING ; A1= NUMBER OF CHARACTERS IN THE STRING ; A3=TABLE ADDRESS ; A4-ADDRESS OF SPECIFIER 1 ; A5=ADDRESS OF SPECIFIER 2 ; Z ;ERROR RETURN ; Z ;RUNOUT RETURN ; Z ;SUCCESS RETURN PXPTR: POINT 6,A2,35 ;"PUT" FIELD CROSS INDEX TXPTR: POINT 6,A2,29 ;"GOTO" CROSS INDEX INTERN STREEM STREEM: SETZM STYPE ;DESTROY THE HISTORY MOVE A0,SPECO(A5) MOVE A1,SPECL(A5) ;GET CHARACTER COUNT JUMPE A1,RUNOUT ;IF NO CHARACTERS, RUNOUT STRM1: MOVE A12,A0 ;COPY THE BYTE PTR IBP A0 SETZM A7 ;FOR CARRY LDB A6,A0 ;GET A CHARACTER LSHC A6,-1 ;DIVIDE BY 2, SAVE REMAINDER ADDI A6,(A3) ;GET ADDRESS IN SYNTAX TABLE HRRZ A2,(A6) ;GUESS WHICH HALFWORD WE WANT TLNE A7,400000 ;WAS THE CHAR. EVEN HLRZ A2,(A6) ;NO, GET THE LEFT HALF INSTEAD TRNE A2,STOP+STOPSH ;STOP OR STOP SHORT? JRST STPSH ;YES TRNE A2,CONTIN ;CONTINUE CODE? JRST CNTIN ;YES TRNE A2,ERROR JRST STRERR LDB A6,TXPTR ;GOTO A DIFF. SYNTAX TABLE? CAILE A6,SYNSIZ ;IN RANGE? POPJ P, ;NO,ERROR RETURN SKIPN A6 JRST STRM2 ;USE THE SAME TABLE SETZM STYPE ;START WITH A FRESH VALUE HRRZ A3,SYNTAB(A6) ;GET THE NEW TABLE ADDRESS STRM2: LDB A6,PXPTR ;ANYTHING IN "PUT" FIELD? CAILE A6,PUTSIZ ;IN RANGE? POPJ P, ;NO,ERROR RETRUN HRRZ A6,PUTTAB(A6) SKIPE A6 MOVEM A6,STYPE CNTIN: SOJG A1,STRM1 ;CONTINUE IF MORE CHARS. RUNOUT: MOVSI A0,(A5) HRRI A0,(A4) BLT A0,SPECL(A4) SETZM SPECL(A5) JRST CPOPJ1 ;NO,RUNNOUT RETURN STRERR: SETZM STYPE ;INDICATE ERROR MOVSI A0,(A5) ;"FROM" HRRI A0,(A4) ;"TO" BLT A0,SPECL(A4) POPJ P, ;ERROR RETURN STPSH: SUBI A1,1 ;BRING J INTO SYNC LDB A6,PXPTR ;SEE IF "PUT" FIELD EMPTY CAILE A6,PUTSIZ ;IN RANGE? POPJ P, ;NO,ERROR RETURN HRRZ A6,PUTTAB(A6) ;GET VALUE SKIPE A6 ;DON'T UPDATE UNLESS THE VALUE IS NEW MOVEM A6,STYPE ;ADD IN,IF ANY MOVSI A3,(A5) ;"FROM" HRRI A3,(A4) ;"TO" BLT A3,SPECL(A4) HRRZ A3,SPECL(A5) ;GET ORIG. NO. OF CHARACTERS SUBI A3,(A1) ;FORM "J" MOVN A3,A3 TRNN A2,STOP JRST STRSH ;SO STOPSH CODE ADDM A3,SPECL(A5) ;FORM L-J MOVN A3,A3 ;MAKE POSITIVE AGAIN HRRM A3,SPECL(A4) ;FORM J MOVEM A0,SPECO(A5) ;OFFSET+J+1 JRST CPOPJ2 ;SUCCESS RETURN STRSH: ADDM A3,SPECL(A5) AOS SPECL(A5) ;L-J+1 MOVN A3,A3 SUBI A3,1 HRRM A3,SPECL(A4) ;J-1 MOVEM A12,SPECO(A5) ;OFFSET+J JRST CPOPJ2 ;SUCCESS RETURN PAGE INTERN SPREAX EXTERN R,TBLP. ;REAL DATA TYPE ; CONVERT STRING TO A REAL NUMBER ; A0=ADDRESS OF WHERE TO STORE RESULT ; A1=ADDRESS OF STRING SPECIFIER ;TITLE FLIRT. V.005 FLOATING POINT INPUT FORTRAN IV ;SUBTTL 29-MAY-67 ;"FLIRT." IS A ROUTINE WHICH INPUTS A STRING OF ASCII CHARACTERS. ;THE CHARS. ARE RECEIVED IN ACO FROM "CHINN."; THE INPUT ITEM IS ;RETURNED IN THE SAME AC. "IIB." IS AN EXTERNAL ROUTINE WHICH ;ADVANCES THE POINTER; "TBLP." IS AN EXTERNAL TABLE ;OF FLOATING POINT POWERS OF TEN. ;IF THE FLAG ILLEG. HAS BEEN SET (BY A CALL TO ILL), THE ;INPUT WORD WILL BE SET TO 0 IF ANY ILLEGAL CHARACTERS ;ARE SCANNED FOR THAT WORD. ; CALLING SEQUENCE: ; PUSHJ P,FLIRT. ; 2 RETURNS: ; ILLEGAL CHARACTER ; NORMAL ; PUSHDOWN LIST CONTAINS: ; 1. FORMAT WORD CONSTRUCTED AS FOLLOWS: ; BIT 0: 0=F TYPE CONVERSION ; 1=E TYPE CONVERSION ; BIT 1: 1=G TYPE CONVERSION ; BITS 4-10: D -- NO. OF DIGITS FOLLOWING THE DECIMAL POINT ; BITS 11-17: W -- FIELD WIDTH; W=0, VARIABLE FIELD ; BITS 18-35: N -- SCALE FACTOR ; 2. PROGRAM COUNTER (RETURN ADDRESS) ;PARAMETER ASSIGNMENTS H=6 ;INPUT WORD ACO=A11 ; ;RETURNS THE INPUT ITEM ACT=2 ;CNTR FOR MULTIPLICATION FACTOR FL=0 ;FLAG FMT=4 ;FORMAT WORD ACNO=3 ;FRACTION,EXPONENT W=5 ;FIELD WIDTH PDP=17 ;PUSHDOWN POINTER ;FLAGS EXP=1 ;EXPONENT FRAC=2 ;FRACTION FIRDIG=4 ;FIRST DIGIT NEGFRA=10 ;NEGATIVE FRACTION NEGEXP=20 ;NEGATIVE EXPONENT ESIGN=40 ;EXPONENT SIGN OFLO=100 ;OVERFLOW INTO CHARACTERISTIC DECF=1000 ;DECIMAL POINT FLAG PDSV=PPPDP+1 FLIRT: MOVEM 16,PDSV+16 MOVEI 16,PDSV BLT 16,PDSV+15 CLEARB ACNO,FL CLEARB H,ACT IB: CL: JUMPE W,ENDF1 ;END OF FIELD ILDB ACO,A12 SOS W ;DECREMENT FILED WIDTH CAIG ACO,71 ;TEST FOR DIGIT CAIGE ACO,60 JRST NODIG ;NOT A DIGIT TLO FL,FIRDIG ;SET FIRST-DIGIT FLAG SUBI ACO,60 ;REMOVE ASCII CODE IM: TLNN FL,OFLO ;OVERFLOW FLAG SET? JRST IM1 ;NO, FORM AN INTEGER TLNN FL,FRAC ;IS THIS THE FRACTION? ADD ACT,L1 ;NO, INCREMENT OVERFLOW COUNTER JRST IB ;GET NEXT CHARACTER IM1: IMULI ACNO,12 ;FORM AND SAVE INTEGER ADD ACNO,ACO TLNE FL,FRAC ;FRACTION? AOS ACT ;YES TLNN ACNO,377000 ;OVERFLOW IN CHARACTERISTIC? JRST IB ;NO, GET NEXT CHAR. PUSH PDP,ACNO+1 ;SAVE ACNO+1 IDIVI ACNO,12 ;OTHERWISE, COMPENSATE: CAIL ACNO+1,5 ;IF DROPPED DIGIT >,= 5, AOS ACNO ;ADD ONE TO LAST CHAR ADD ACT,L1 ;INCREMENT OVERFLOW CNTR TLO FL,OFLO ;SET OVERFLOW FLAG POP PDP,ACNO+1 ;RESTORE ACNO+1 JRST IB ;GET NEXT CHARACTER ENDF1: EXCH H,ACNO JUMPE H,RETURN TLNE FL,NEGEXP ;IS EXP NEGATIVE? MOVNS ACNO ;YES, COMPLEMENT IT HLRZ ACO,ACT ;SET UP REDUCTION CNTR TLNN FL,DECF ;DECIMAL POINT FLAG SET? JRST ERRORS ADD ACNO,ACO SUBI ACNO,(ACT) ;SET MULTIPLICATION FACTOR JOV .+1 ;CLEAR OV CAIG ACNO,46 ;IS EXPONENT WITHIN RANGE? CAMGE ACNO,M46 JRST BADEXP ;NO, OUT OF RANGE TLC H,233000 FAD H,ZE ;RANGE OK, NORMALIZE FRACTION JUMPGE ACNO,FMR ;IS EXPONENT .GE. 0? MOVMS ACNO ;NO, THEN COMPLEMENT IT MOVEI ACT,-6 ;AND SET CNTR = -6 JRST .+2 FMR: MOVEI ACT,1 ;OTHERWISE, SET CNTR = 1 TR: TRNE ACNO,1 ;IF LOW ORDER BIT OF EXPONENT FMPR H,TBLP.(ACT) ;IS ONE,MULTIPLY BY POWER OF TEN ASH ACNO,-1 AOS ACT JUMPN ACNO,TR ;ANY MORE CHARS? JOV BADEXP ;NO, CHECK OV TLF: TRNE FL,NEGFRA ;IF NEGATIVE FRACTION, MOVNS H ;COMPLEMENT IT JRST RETURN ;NORMAL RETURN NODIG:NOTE: CAIN ACO,40 ;BLANK? JRST BLK ;YES NBL: CAIN ACO,56 ;NOT BLANK, . JRST DECPT CAIN ACO,55 ;- JRST MINUS CAIN ACO,53 ;+ JRST PLUS BADEXP: ERRORS: POPJ P, RETURN: MOVEM H,(A0) ;STORE RESULT MOVEI H,R ;REAL DATA TYPE MOVEM H,1(A0) MOVSI 16,PDSV BLT 16,16 JRST CPOPJ1 BLK: TLNN FL,4 ;BLANK,FIRST DIGIT IN? JRST IB ;NO,GET NEXT CHAR. JRST ERRORS ;BLANKS NOT ALLOWED IN MIDDLE ADDCNT: AOS 2(7) ;ADD ONE TO THE ITEM COUNT JRST ENDF1 ;PROCESS NUMBER DECPT: TLON FL,FRAC+DECF ;SET FRACTION AND DEC. PT. FLAGS JRST IB ;NO, GET NEXT CHAR JRST ERRORS ;NO, ILLEGAL MINUS: TROA FL,NEGFRA ;-, SET RT. HALF TO 10 PLUS: HRRI FL,0 ;+, SET RT. HALF TO 0 TLNE FL,FIRDIG ;FIRST DIGIT IN? JRST ERRORS TLO FL,(FL) ;NO - SET RESULT SIGN JRST IB ;GET NEXT CHAR L1: XWD 1,0 PTR1: POINT 7,FMT,17 PTR2: POINT 7,FMT,10 ZE: Z M46: DEC -38 SPREAX: MOVE W,SPECL(A1) MOVE A12,SPECO(A1) JRST FLIRT PAGE REPEAT 0,< ; THIS CODE REPLACED BY SOMETHING MORE CLEAVER AND SHORTER REALSX: MOVE A2,(A1) MOVEM A2,SVFN MOVEI A4,BUFSPX MOVEM A4,(A0) SETZM 1(A0) ;CLEAR FLAG AND VALUE FIELDS SETZM SPECL(A0) ;INITIALIZE LENGTH HRLI A4,440700 MOVEM A4,SPECO(A0) MOVEM A4,ARRAY0 MOVEI A2,6 ;NUMBER OF DIGITS PAST DECIMAL PT. MOVEM A2,SVNN REALS1: MOVEM 17,SV17N MOVEI 17,SVON BLT 17,SVON+2 ;SAVE ACS 0,1,2 MOVE P,PNPDP MOVEI 1,"-" SKIPGE SVFN IDPB 1,ARRAY0 MOVMS SVFN ;GET MAGNITUDE SKIPGE 1,SVNN ;FRACTIONAL PRINT? MOVEI 1,0 ;NO, INDICATE NO ZEROES MOVNS 1 MOVSI 0,(10.0) PUSHJ P,EXP2.0 MOVEM 0,T2 FSC 0,-1 FADRB 0,SVFN ;ROUND IN FIRST INSIGN. DIGIT FDVR 0,T2 ;SCALE TO AN INTEGER MOVEM 0,TEMP JSA Q,IFIX JUMP 0,TEMP ;AN INTEGER INTEGER MOVEM 0,UNITS PUSHJ P,DECPLT MOVEI 1,"." SKIPN SVNN ;NEED A DEC. PT.? IDPB 1,ARRAY0 ENDNUM: MOVSI 17,SVON BLT 17,2 ;RESTORE ACS MOVE 17,SV17N MOVE A1,[POINT 7,BUFSPX,] END12: CAMN A1,ARRAY0 ;CALCULATE LENGTH OF STRING POPJ P, AOS SPECL(A0) IBP A1 JRST END12 DECPLT: MOVM 1,UNITS SETZM DIGITS ;NO OF DIGITS BEING PRINTED DECP3: IDIVI 1,12 HRLM 2,(P) ;SAVE REMAINDER AOS DIGITS SKIPE 1;DECOMPOSE UNTIL GONE TO ZERO PUSHJ P,DECP3 MOVE 0,DIGITS CAMLE 0,SVNN JRST DECP4 MOVEI 1,"." IDPB 1,ARRAY0 CAML 0,SVNN JRST DECP4A DECP5: MOVEI 1,"0" IDPB 1,ARRAY0 AOS 1,DIGITS CAMGE 1,SVNN JRST DECP5 DECP4A: SETOM SVNN ;FAKE OUT NEXT TIME AROUND DECP4: SOS DIGITS HLRZ 1,(P) TRO 1,60 ;CONVERT TO ASCII IDPB 1,ARRAY0 POPJ P, > PAGE EXTERN STROUT,SAVDP.,LNGTH EXTERN DEPOT.,FLOUT. EXTERN NCTRLC,CUTFLG ; CALLING SEQUENCE ; A0=ADDRESS OF OUTPUT SPECIFIER ; A1=ADDRESS OF INPUT DESCRIPTOR REALSX: SETOM NCTRLC ;INDICATE ^C NOT POSSIBLE HERE MOVE A2,[JRST TRAPCH] EXCH A2,DEPOT. ;INTERCEPT THE CONVERTED CHARACTERS MOVEM A2,SAVDP. MOVEI 11,0 ;FLAG WORD FOR FLOUT.-FREE FORMAT PUSH PDP,11 ;THIS IS WHERE FLOUT. EXPECTS IT MOVE 0,(A1) ;GET THE REAL NUMBER MOVEI A2,BUFSPX MOVEM A2,(A0) HRLI A2,440700 MOVEM A2,STROUT MOVEM A2,SPECO(A0) SETZM 1(A0) MOVEI A2,SPECL(A0) MOVEM A2,LNGTH ;REMEMBER THE LENGTH SETZM SPECL(A0) PUSHJ PDP,FLOUT. MOVE A0,SAVDP. MOVEM A0,DEPOT. POP PDP,(PDP) ;GET RID OF 'F' ENTRY SETZM NCTRLC SKIPE CUTFLG ;HAS 'REENTER' BEEN TYPED IN A SENSITIVE SPOT? JRST @CUTFLG POPJ PDP, ;RETURN NORMALLY TRAPCH: CAIN 0," " ;IGNORE BLANKS POPJ PDP, AOS @LNGTH IDPB 0,STROUT POPJ PDP, PAGE EXTERN IFIX,FLOAT,EXP2.0 EXTERN PPPDP PNPDP: XWD -25,PPPDP EXTERN UNITS,DIGITS,NARGS,SVFN,SVNN,ARRAY0,TEMP,T2 EXTERN SVON,SV17N INTERN SPCINX ; STRING TO INTEGER CONVERSION ROUTINE ; A0=SPECIFIER ADDRESS ; A1=DESCRIPTOR ADDRESS SPCINX: MOVE A2,SPECO(A0) ;GET BYTE POINTER MOVE A3,SPECL(A0) ;GET NO. OF CHARACTERS MOVEI A5,0 JUMPE A3,SPC2 ;NULL STRING TEST SPC1: ILDB A4,A2 CAIN A4,"-" ;STRING NEGATIVE? JRST SPC4 SPC3: CAIL A4,"0" CAILE A4,"9" POPJ P, ;ERROR RETURN SUBI A4,"0" IMULI A5,^D10 ADDI A5,(A4) SOJG A3,SPC1 MOVE A2,SPECO(A0) ILDB A4,A2 CAIN A4,"-" ;NEGATIVE CHECK AGAIN MOVN A5,A5 SPC2: MOVEM A5,(A1) ;SAVE RESULT MOVEI A4,I ;MAKE IT INTEGER DATA TYPE MOVEM A4,1(A1) JRST CPOPJ1 ;SUCCESS RETURN SPC4: ILDB A4,A2 ;BYPASS THE MINUS SIGN SUBI A3,1 JRST SPC3 PAGE INTERN OUTPTS EXTERN INTO.,INTI. ; A1=FORMAT STATEMENT REFERENCE ; A0=UNIT FOR OUTPUT ; A2=ADDRESS OF OUTPUT STRING EXTERN ETMCL ;FLAG TO INDICATE WHETHER WE ARE ;IN THE SNOBOL COMPILER OR INTERPRETER OUTPTS: ; SINCE THE OUTPUT STRING MAY NOT BE LEFT ; JUSTIFIED, WE ALWAYS MOVE IT INTO ANOTHER BUFFER ; SO IT WILL BE JUSTIFIED. THIS BUFFER IS ZERO FILLED ; SO TRAILING BLANKS ARE NOT PRESENT ; UNLESS GIVEN BY SNOBOL SETZM TXBUF MOVE A0,[XWD TXBUF,TXBUF+1] BLT A0,TXBUF+^D26 ;ZERO IT FIRST MOVE A0,SPECO(A2) MOVE A4,TXPNT MOVE A2,SPECL(A2) JUMPE A2,PTS1 ;NULL STRING CASE MOVEM A2,PTINSZ MOVEM A0,PTINBY HRRZM A0,PTIN MOVEI A5,PTIN MOVEI A6,PTSOUT SKIPN ETMCL ;FORCE A TRIM IF WE ARE OUTPUTTING SOURCE PUSHJ PDP,TRIMIT MOVE A10,PTSIZE MOVE A0,PTSOUT+SPECO MOVE A2,PTSIZE CAILE A2,^D132 PUSHJ P,PTS3 ;GET STRING TO LESS THAN 132 CHARACTERS ILDB A3,A0 IDPB A3,A4 SOJG A2,.-2 EXTERN OUTIT,PTS2 PTS1: PUSHJ PDP,OUTPT. FIN. POPJ PDP, OUTPT.: MOVE A10,PTSIZE IDIVI A10,5 SKIPE A11 ADDI A10,1 OUTALL: MOVNS A10 HRLZ A10,A10 DATA. TXBUF(A10) AOBJN A10,.-1 POPJ PDP, EXTERN PTSOUT,PTSIZE,PTIN,PTINBY,PTINSZ PTS3: ;THE STRING IS LONGER THAN 132 CHARACTERS ; SO SPLIT IT AMONG SEVERAL BUFFERS SETZM TXBUF MOVE A1,[XWD TXBUF,TXBUF+1] BLT A1,TXBUF+^D26 CAIG A2,^D132 POPJ P, ;FINISHED MOVEI A16,^D132 ILDB A3,A0 IDPB A3,A4 SOJG A16,.-2 MOVEI A10,^D27 ;OUTPUT THE ENTIRE BUFFER PUSHJ PDP,OUTALL SUBI A2,^D132 MOVE A4,TXPNT ;RESTORE POINTER TO BUFFER AREA MOVEM A2,PTSIZE ;UPDATE LENGTH LEFT JRST PTS3 DEFINE LDBD (AC,PTR,%A,%B)< ;IT ALWAYS ASSUMES 0 IS FREE LDB AC,PTR LDB A0,[POINT 6,PTR,5] CAIN A0,^O35 ;IS THIS THE LAST BYTE IN THE WORD? JRST %A ADDI A0,7 JRST %B %A: MOVEI A0,1 SOS PTR %B: DPB A0,[POINT 6,PTR,5] > INTERN TRIMIT ; CALL A5=ADDRESS OF INPUT SPECIFIER ; A6=ADDRESS OF OUTPUT SPECIFIER TRIMIT: HRRZ A1,SPECL(A5) ;NO. OF CHARACTERS MOVE A2,SPECO(A5) JUMPE A1,TRIM2 IBP A2 SOJG A1,.-1 ; MOVE TO END OF STRING SINCE LDBD WILL DO A LDB MOVE A1,SPECL(A5) TRIM1: LDBD A3,A2 JUMPE A3,TRIM3 CAIE A3," " CAIN A3," " TRIM3: SOJG A1,TRIM1 ;DELETE TABS AND BLANKS TRIM2: MOVEM A1,SPECL(A6) MOVE A1,A6 HRL A1,A5 BLT A1,SPECO(A6) POPJ PDP, PAGE EXTERNAL OBSIZ,OBSTRT INTERNAL ORDVSX ORDVSX: POPJ P, ;DO NOT ORDER VARIABLE STORAGE NOW INTERN LOAFNC,UNLFNC,LINKFC EXTERN UNDF,INTR10 LOAFNC: POP PDP,(PDP) ;LOAD FUNCTION ENTRY POINT JRST UNDF UNLFNC: POPJ PDP, ;UNLOAD FUNCTION LINKFC: POP PDP,(PDP) JRST INTR10 ;LINK MACRO ENTRY POINT INTERN INCIOB INCIOB: JFCL ;THIS TAGE PUT HERE SO MORE INTELLIGENT ERROR RECOVERY ;CAN BE DONE LATER POPJ PDP, PAGE EXTERN ERR.,END. INTERN STREAX INCHLN=^D80 INBFLN=^D16 ;NO. OF CHARACTERS READ EACH TIME ON INPUT = INCHLN ;NO. OF WORDS ALLOCATED FOR READING THESE = INBFLN STREAX: MOVEM A1,ERR.. ;FIX UP ERROR RETURN MOVEM A2,END.. ;FIX UP END OF FILE RETURN RELOC ;DEFINE DUMMY CELLS ERR..: EXP 0 END..: EXP 0 RELOC MOVEI A1,STRER MOVEM A1,ERR. MOVEI A1,STREND MOVEM A1,END. ; WE HAVE TO PUT IN A DUMMY ROUTINE ON ERR= AND END= TYPE TRAPS ; OTHERWISE THE STACK WILL NOT BE CLEANED UP PROPERLY REPEAT 0,< MOVE A1,SPECL(A4) ;GET STRING LENGTH IDIVI A1,5 SKIPE A2 ADDI A1,1 ;MAX. NO. OF WORDS TO READ HRRM A1,STRLTH ;FIX UP SLIST. LENGTH MOVE A5,[POINT 7,STRFMT,6] ;BY-PASS "(" JUMPE A1,CPOPJ PUSHJ PDP,FIXFMT MOVE A1,[ASCIZ /A5)/] MOVE A6,[POINT 7,A1,] STRX2: ILDB A7,A6 JUMPE A7,STRX1 ;DYNAMICALLY CREATE A FORMAT STATEMENT IDPB A7,A5 JRST STRX2 STRX1: IN. 01,(A3) HRRZ A1,SPECO(A4) HRRM A1,STRSLI ;FIX UP THE SLIST ADDRESS ; ZERO OUT THE RECEVING BUFFER SETZM (A1) HRLS A1 ADDI A1,1 HLRZ A2,A1 ADD A2,STRLTH SUBI A2,1 BLT A1,(A2) PUSHJ PDP,STRSLI ;DO TH INPUT NOW MOVE A2,SPECL(A4) ;GET ORIGINAL LENGTH SETZM SPECL(A4) ; BY-PASS LINE SEQUENCE NUMBERS STRX4: MOVE A5,@A0 TRNN A5,1 ;SEE IF 1B35 IS ON JRST STRX3 ;NOT ON, SO DONE AOS SPECO(A4) ;SKIP OVER THE WORD SUBI A2,5 ;AND DECREMENT STRING LENGTH JRST STRX4 STRX3: MOVE A0,SPECO(A4) MOVE A1,A0 ;GET BYTE POINTERS ; COMPRESS OUT NULL CHARACTERS STRX5: ILDB A3,A0 SKIPN A3 JRST STRX6 IDPB A3,A1 AOS SPECL(A4) STRX6: SOJG A2,STRX5 POPJ PDP, > ; THE ABOVE CODE LEFT AROUND SINCE IT ALMOST WORKED AND WOULD HAVE ; ALLOWED INPUT OF ARBITRARILY LONG STRINGS. THE ONE BIG PROBELM ; WAS CAUSED BY THE FACT THAT THE STRING TO BE INPUT IS ; SOMETIMES NOT LEFT JUSTIFIED IN A WORD AND FORSE IS INCAPABLE OF ; DOING ANYTHING ABOUT. CONSEQUENTLY WE MUST READ THE STRING INTO ; AN INTERMEDITATE BUFFER AND TRANSFER IT MOVEI A1,INFMT IN. 01,(A3) PUSHJ PDP,BUFCLR MOVEI A0,INBFLN ;READ ONLY INBFLN WORDS HRRM A0,STRLTH MOVEI A0,BUFIN HRRM A0,STRSLI PUSHJ PDP,STRSLI RELOC ;SWITCH TO LOW SEGMENT STRSLI: SLIST. 0,. ;FIXED UP AT RUN TIME STRLTH: JUMP 0,. ;FIXED UP AT RUN TIME FIN. POPJ PDP, RELOC ;SWITCH BACK TO HIGH SEGMENT STRX3: MOVE A2,SPECL(A4) CAIL A2,INCHLN ;TAKE THE LEAST VALUE MOVEI A2,INCHLN ;ALLOW ONLY INCHLN CHARACTERS MOVE A0,BUFPNT MOVE A1,SPECO(A4) MOVEI A5,0 STRX5: ILDB A3,A0 JUMPE A3,STRX6 AOS A5 ;KEEP TRACK OF THE LENGTH WE SEE IDPB A3,A1 STRX6: SOJG A2,STRX5 ; NOW MAKE SURE WE BLANK FILL TO RETURN TNE EXACT NO. OF CHARACTERS ; THE MACRO CALLED FOR CAML A5,SPECL(A4) POPJ PDP, MOVE A2,SPECL(A4) SUB A2,A5 MOVEI A3,40 ;ASCII BLANK IDPB A3,A1 SOJG A2,.-1 POPJ PDP, POPJ PDP, REPEAT 0,< FIXFMT: IDIVI A1,12 HRLM A2,(PDP) ;SAVE REMAINDER SKIPE A1 ;ANY REMAINDER IN ORIGINAL VALUE? PUSHJ PDP,FIXFMT ;RECURSIVE CALL HLRZ A1,(PDP) TRO 1,60 ;CONVERT TO ASCII IDPB A1,A5 POPJ PDP, ;BACK TO ORIGINAL WHEN DONE > STREND: POP PDP,(PDP) ;CLEAN UP THE STACK POP PDP,(PDP) JRST @END.. STRER: POP PDP,(PDP) POP PDP,(PDP) JRST @ERR.. PAGE INTERN IFILEX,OFILEX,BUFCLR ; CALL ; A1 = ADDRESS OF DESCRIPTOR CONTAINING UNIT NO. ; A2 = ADDRESS OF SPECIFIER CONTAINING THE FILENAME ; PUSHJ PDP,IFILEX/OFILEX ; ALWAYS RETURN HERE ; FOLLOWING TRANSFER OF STRINGS IS NECESSARY BECAUSE SNOBOL ; DOESN'T ALWAYS CLEAR OUT STRING STORAGE BEFORE ; APPENDING CHARACTER STRINGS BUFCLR: SETZM BUFIN MOVE A7,[XWD BUFIN,BUFIN+1] BLT A7,BUFIN+^D26 POPJ PDP, BUFTRN: PUSHJ PDP,BUFCLR MOVE A7,SPECL(A2) ;GET STRING LENGTH JUMPE A7,CPOPJ MOVE A10,SPECO(A2) ;GET BYTE POINTER MOVE A11,BUFPNT ILDB A0,A10 IDPB A0,A11 SOJG A7,.-2 POPJ P, IFILEX: PUSHJ P,BUFTRN JSA ^O16,IFILE ARG (A1) ARG 5,BUFIN POPJ P, OFILEX: PUSHJ P,BUFTRN JSA ^O16,OFILE ARG (A1) ARG 5,BUFIN POPJ P, PAGE INTERN LOCATX,LOCAVX LOCATX: MOVE A0,(A11) JUMPE A0,CPOPJ ;ERROR RETURN HRRZ A1,1(A0) ;GET MAX. NUMBER TO TEST FOR ADD A1,A0 MOVEI A2,(A0) ;SETUP FOR I=0 LOC1: MOVE A3,D(A2) CAMN A3,(A10) ;CHECK ADDRESS FIELD JRST LOC2 LOC3: ADDI A2,2*D CAIGE A2,(A1) ;CHECK FOR DONE JRST LOC1 ;CONTINUE POPJ P, ;NOT FOUND,ERROR RETURN LOC2: MOVE A7,D+1(A2) ;CHECK FLAG + VALUE FIELD CAME A7,1(A10) JRST LOC3 ;CONTINUE MOVE A5,1(A11) ;TRANSFER GOOD STUFF MOVEM A5,1(A6) MOVEM A2,(A6) JRST CPOPJ1 ;SUCCESS RETURN LOCAVX: MOVE A0,(A11) JUMPE A0,CPOPJ ;ERROR RETURN HRRZ A1,1(A0) ;GET MAX. NUMBER TO TEST FOR ADD A1,A0 MOVEI A2,(A0) ;SET FOR I=0 LOCV1: MOVE A3,2*D(A2) CAMN A3,(A10) ;CHECK ADDRESS FIELD JRST LOCV2 ;FOUND TO BE EQUAL SO FAR LOCV3: ADDI A2,2*D CAIGE A2,(A1) ;CHECK FOR DONE JRST LOCV1 ;CONTINUE POPJ P, ;ERROR RETURN-NONE FOUND LOCV2: MOVE A7,2*D+1(A2) CAME A7,1(A10) ;CHECK FLAG + VALUE FIELD JRST LOCV3 ;NOT EQUAL,SO CONTINUE MOVE A5,1(A11) MOVEM A5,1(A6) MOVEM A2,(A6) JRST CPOPJ1 ;SUCCESS RETURN PAGE ; THIS CODE WAS PLACED HER IN ORDER TO MINIMIZE THE AMOUNT OF ; CODE USED BY THE RCALL RRTURN PAIR. BY NOT EXPANDING ; THOSE MACROS ALL IN-LINE, I WAS ABLE TO SAVE ABOUT 2600 ; (DECIMAL) WORDS WHICH IS VERY SIGNIFICANT. I FIGURE THAT ; THIS TECHNIQUE ADDS A FEW EXTRA CYCLES, PROBABLY 4, ; FOR EACH OCCURRENCE AND MAKES THE EXECUTION LONGER BY A FEW ; PERCENT. INTERN RCALX0,RCALX1,RCALX2,RCALX3,RCALX4,RCALX5 INTERN RCALX6,RCALX7 INTERN RCALD0,RCALD1,RCALD2,RCALD3,RCALD4,RCALD5 INTERN RCALD6,RCALD7 ZERO: Z ;A WORD OF ALL ZEROES RCALX0: MOVE A0,CSTACK ;SAVE CURRENT STACK POSITION MOVEI A3,0 ;INDICATE NO ARGUMENT ON RETURN JRST RX1 RCALD0: MOVE A0,CSTACK HLRZ A3,(A2) ;SAVE ADDRESS OF RESULT DESCRIPTOR RX1: PUSH CSTACK,OSTACK PUSH CSTACK,A3 PUSH CSTACK,A2 ;SAVE RETURN ADDRESS PUSH CSTACK,ZERO MOVE OSTACK,A0 ;FIX UP OLD STACK POINTER HRRZ A2,(A2) ;GET PROCEDURE ADDRESS JRST (A2) RCALX1: MOVE A0,CSTACK MOVEI A3,0 JRST RX2 RCALD1: MOVE A0,CSTACK HLRZ A3,(A2) RX2: PUSH CSTACK,OSTACK PUSH CSTACK,A3 PUSH CSTACK,A2 ;SAVE RETURN ADDRESS PUSH CSTACK,ZERO MOVE OSTACK,A0 PUSH CSTACK,(A4) PUSH CSTACK,1(A4) HRRZ A2,(A2) JRST (A2) RCALX: MOVE A0,CSTACK MOVEI A3,0 JRST RX3 RCALD: MOVE A0,CSTACK HLRZ A3,(A2) RX3: PUSH CSTACK,OSTACK PUSH CSTACK,A3 PUSH CSTACK,A2 ;SAVE RETURN ADDRESS PUSH CSTACK,ZERO HRRZ A2,(A2) ;GET PROCEDURE ADDRESS MOVE OSTACK,A0 PUSH CSTACK,(A4) PUSH CSTACK,1(A4) ;SAVE ARGUMENTS PUSH CSTACK,(A5) PUSH CSTACK,1(A5) SOJE A16,(A2) PUSH CSTACK,(A6) PUSH CSTACK,1(A6) SOJE A16,(A2) PUSH CSTACK,(A7) PUSH CSTACK,1(A7) SOJE A16,(A2) PUSH CSTACK,(A10) PUSH CSTACK,1(A10) SOJE A16,(A2) PUSH CSTACK,(A11) PUSH CSTACK,1(A11) SOJE A16,(A2) PUSH CSTACK,(A12) PUSH CSTACK,1(A12) SOJE A16,(A2) HALT . ;ASSUME NO MORE ARGUMENNTS THAN THIS RCALX2: MOVEI A16,1 JRST RCALX RCALX3: MOVEI A16,2 JRST RCALX RCALX4: MOVEI A16,3 JRST RCALX RCALX5: MOVEI A16,4 JRST RCALX RCALX6: MOVEI A16,5 JRST RCALX RCALX7: MOVEI A16,6 JRST RCALX RCALD2: MOVEI A16,1 JRST RCALD RCALD3: MOVEI A16,2 JRST RCALD RCALD4: MOVEI A16,3 JRST RCALD RCALD5: MOVEI A16,4 JRST RCALD RCALD6: MOVEI A16,5 JRST RCALD RCALD7: MOVEI A16,6 JRST RCALD PAGE INTERN RRTND,RRTNX ; THIS CODE PLACED HERE TO REDUCE THE AMOUNT OF CODE ; EXPANDED IN-LINE. ; ; THE FORMAT IS SLIGHTLY CHANGED FROM THE STANDARD IN THAT ; THE POSSIBLE ADDRESS OF THE DESCRIPTOR RECEIVING THE VALUE ; IS STORED ON THE STACK AND NOT IN-LINE ; RRTND RETURNS A VALUE, RRTNX DOES NOT ; A1 CONTAINS THE EXIT RETURN NUMBER , TO N RRTND: SKIPN A3,2(OSTACK) JRST RRFIN ;NO ADDRESS MOVE A0,(A2) ;GE T THE DESCRIPTOR MOVEM A0,(A3) MOVE A0,1(A2) MOVEM A0,1(A3) RRTNX: RRFIN: MOVE CSTACK,OSTACK ADD A1,D+1(OSTACK) ;FORM RETURN ADDRESS MOVE OSTACK,1(OSTACK) JRST 1(A1) ;RETURN END