Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

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