Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0028/c.366
There are 2 other files named c.366 in the archive. Click here to see a list.
TITLE COMMON SUBROUTINES FOR SNOBOL
SUBTTL BY LARRY WADE / THIS ASSEMBLY MADE WITH C.366
IFNDEF REENTR,<REENTR==1>
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