Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-01 - 43,50150/macros.399
There are 2 other files named macros.399 in the archive. Click here to see a list.
	SUBTTL THIS ASSEMBLY MADE WITH MACROS.399

IFNDEF REENTR,<REENTR==1>


;	FOLLOWING ARE THE MACROS DEFINITIONS USED WITH THE
;	BELL TELEPHONE LABORATORIES SOURCE TAPE(CONVERTED
;	TO MACRO-10 FORMAT) WHICH PRODUCES SNOBOL4 FOR
;	THE PDP-10. THIS SOURCE WORKS FOR VERSION 3.4 AS
;	RELEASED BY BELL LABORATORIES.


	MLON
	RADIX 8
	OPDEF STAK [261B8]
	OPDEF UNSTAK [262B8]
	OPDEF MSTIM [CALLI ^O23]
	OPDEF RUNTIM [CALLI ^O27]

	DEFINE WEIGHT (A,B,C,D)<
	.%%K=0
	IFNB <A>,<.%%K=.%%K+1>
	IFNB <B>,<.%%K=.%%K+2>
	IFNB <C>,<.%%K=.%%K+4>
	IFNB <D>,<.%%K=.%%K+8>>

; "WEIGHT" WILL DETERMINE WHETHER A GIVEN ARGUMENT EXISTS AND IF
; SO IT WILL INCREMENT A VARIABLE WITH ITS CORRESPONDING WEIGHT VALUE.
; THIS WEIGHT IS THEN CONVERTED TO AN ASCII CHARACTER VIA THE "\"
; FEATURE IN MACRO-10 AND USED WITH THE "XFER" MACRO
; TO CHOSE A FORM OF THE ORIGINAL MACRO IN ORDER TO PICK ONE
; WHICH GENERATES OPTIMUM CODE.
;THE CALL IS IN REVERSE ORDER OF ARGUMENTS IN ORDER
;TO ALLOW CALLING THE MACRO WITH A VARIABLE NUMBER OF
;ARGUMENTS


	DEFINE XFER (A,B,C,D,E,F,G)<
	B'A C,D,E,F,G>

; "XFER" WILL PICK A VERSION OF A PARTICULAR MACRO WHICH WILL
; GENERATE OPTIMUM CODE DEPENDING ON THE EXISTENCE OF ARGUMENTS.
; ARGUMENT "B" PICKS THE BASE MACRO (I.E. ACOMP) AND ARGUMENT A
; (CALLED VIA "\") PICKS THE VERSION (I.E. 4).
;ARGUMENTS "A" SHOULD BE THOUGHT OF AS ITS BINARY EQUIVALENT
;WHERE 1'S IDENTIFY WHICH ARGUMENTS EXIST


	DEFINE ACOMP (A,B,C,D,E)<
	MOVE A0,A
	WEIGHT E,D,C
	XFER \.%%K,ACOMP,B,C,D,E
>

	DEFINE ACOMP0 (B,C,D,E)<
	JFCL ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++
>


	DEFINE ACOMP1 (B,C,D,E)<
	CAMGE A0,B
	JRST E
>

	DEFINE ACOMP2 (B,C,D,E)<
	CAMN A0,B
	JRST D
	JRST D
>

	DEFINE ACOMP3 (B,C,D,E)<
IFDIF <D><E>,<
	CAMGE A0,B
	JRST E
	CAMG A0,B
	JRST D
>
IFIDN <D><E>,<
	CAMG A0,B
	JRST E
>>

	DEFINE ACOMP4 (B,C,D,E)<
	CAMLE A0,B
	JRST C
>

	DEFINE ACOMP5 (B,C,D,E)<
IFDIF<C><E>,<
	CAMLE A0,B
	JRST C
	CAME A0,B
	JRST E
>
IFIDN <C><E>,<
	CAME A0,B
	JRST C
>>

	DEFINE ACOMP6 (B,C,D,E)<
IFDIF <C><D>,<
	CAMLE A0,B
	JRST C
	CAML A0,B
	JRST D
>
IFIDN <C><D>,<
	CAML A0,B
	JRST C
>>

	DEFINE ACOMP7 (B,C,D,E)<
%ACMP=0	;;;KLUDGE TO EXPAND ONLY 1 OF THE FOLLOWING
		;;;CONDITIONAL TESTS
IFIDN <C><D>,<
	CAMGE A0,B
	JRST E
	JRST C
	%ACMP=1
>
IFE %ACMP,<
IFIDN <C><E>,<
	CAME A0,B
	JRST C
	JRST D
	%ACMP=1
>>
IFE %ACMP,<
IFIDN <D><E>,<
	CAMG A0,B
	JRST D
	JRST C
	%ACMP=1
>>
IFE %ACMP,<
IFDIF <C><D>,<
	ACOMP6 B,C,D,E
	JRST E
	%ACMP=1
>>
IFE %ACMP,<
IFDIF <C><E>,<
	ACOMP6 B,C,D,E
	JRST E
	%ACMP=1
>>
IFE %ACMP,<
IFDIF <D><E>,<
	ACOMP6 B,C,D,E
	JRST E
>>
>

; "ACOMP" COMPARES THE CONTENTS OF ARGUMENT1 WITH THE CONTENTS OF
; ARGUMENT2 AND
;	1. IF GT, TRANSFERS TO ARG3
;	2. IF EQ, TRANSFERS TO ARG4
;	3. IF LT, TRANSFERS TO ARG5

	DEFINE ACOMPC (DES,N,GT,EQ,LT)<
	WEIGHT LT,EQ,GT
IFDIF <N><0>,<
	MOVE A0,DES
>
	XFER \.%%K,ACOMC,DES,N,GT,EQ,LT
>

	DEFINE ACOMC0(A,B,C,D,E)<
	JFCL ;;++++++++++++++++++++++++++++
>

	DEFINE ACOMC1 (DES,N,GT,EQ,LT)<
IFDIF <N><0>,<
	CAIGE A0,N
	JRST LT
>
IFIDN <N><0>,<
	SKIPGE DES
	JRST LT
>
>

	DEFINE ACOMC2(DES,N,GT,EQ,LT)<
IFDIF <N><0>,<
	CAIN A0,N
	JRST EQ
>
IFIDN <N><0>,<
	SKIPN DES
	JRST EQ
>
>

	DEFINE ACOMC3(DES,N,GT,EQ,LT)<
IFDIF <N><0>,<
	CAIGE A0,N
	JRST LT
	CAIG A0,N
	JRST EQ
>
IFIDN <N><0>,<
	SKIPGE DES
	JRST LT
	SKIPG DES
	JRST EQ
>
>

	DEFINE ACOMC4 (DES,N,GT,EQ,LT)<
IFDIF <N><0>,<
	CAILE A0,N
	JRST GT
>
IFIDN <N><0>,<
	SKIPLE DES
	JRST GT
>
>
	DEFINE ACOMC5(DES,N,GT,EQ,LT)<
IFDIF <N><0>,<
	CAILE A0,N
	JRST GT
	CAIE A0,N
	JRST LT
>
IFIDN <N><0>,<
	SKIPLE DES
	JRST GT
	SKIPE DES
	JRST LT
>
>

	DEFINE ACOMC6(DES,N,GT,EQ,LT)<
IFDIF <N><0>,<
	CAILE A0,N
	JRST GT
	CAIL A0,N
	JRST EQ
>
IFIDN <N><0>,<
	SKIPLE DES
	JRST GT
	SKIPL DES
	JRST EQ
>
>

	DEFINE ACOMC7(DES,N,GT,EQ,LT)<
%ACMC=0	;;A KLUDGE TO ALLOW ONLY ONE OF THE FOLLOWING
		;;CONDITIONALS TO EXPAND
IFIDN <N><0>,<
	MOVE A0,DES
>
IFE %ACMC,<
	IFIDN <GT><EQ>,<
		CAIGE A0,N
		JRST LT
		JRST GT
	%ACMC=1
>>
IFE %ACMC,<
	IFIDN <GT><LT>,<
		CAIE A0,N
		JRST GT
		JRST EQ
	%ACMC=1
>>
IFE %ACMC,<
	IFIDN <EQ><LT>,<
		CAIG A0,N
		JRST EQ
		JRST GT
	%ACMC=1
>>
IFE %ACMC,<
	IFDIF <GT><EQ>,<
		ACOMC6 DES,N,GT,EQ,LT
		JRST LT
	%ACMC=1
>>
IFE %ACMC,<
	IFDIF <GT><LT>,<
		ACOMC6 DES,N,GT,EQ,LT
		JRST LT
	%ACMC=1
>>
IFE %ACMC,<
	IFDIF <EQ><LT>,<
		ACOMC6 DES,N,GT,EQ,LT
		JRST LT
	%ACMC=1
>>
>


	DEFINE ADDLG (A,B)<
	MOVE A0,B
	ADDM A0,A+SPECL
>

	DEFINE ADDSIB (D1,D2)<
	MOVE A2,D2
	MOVE A1,D1
	;;SET UP A2+RSIB WITH (A4)
	MOVE A0,RSIB(A1)
	MOVEM A0,RSIB(A2)
	MOVE A0,RSIB+1(A1)
	MOVEM A0,RSIB+1(A2)
	MOVE A0,FATHER(A1)
	AOS CODE+1(A0)	;;INCRMENT A3+CODE
	MOVEM A0,FATHER(A2)
	MOVE A0,FATHER+1(A1)
	MOVEM A0,FATHER+1(A2)
	MOVEM A2,RSIB(A1)
	MOVE A0,D2+1
	MOVEM A0,RSIB+1(A1)
>

	DEFINE ADDSON (D1,D2)<
	MOVE A1,D1
	MOVE A2,D2
	MOVEM A1,FATHER(A2)
	MOVE A0,D1+1
	MOVEM A0,FATHER+1(A2)
	MOVE A0,LSON(A1)
	MOVEM A0,RSIB(A2)
	MOVE A0,LSON+1(A1)
	MOVEM A0,RSIB+1(A2)
	MOVEM A2,LSON(A1)
	MOVE A0,D2+1
	MOVEM A0,LSON+1(A1)
	AOS CODE+1(A1)
>

	DEFINE ADJUST (A,B,C)<
	MOVE A0,@B
	ADD A0,C
	MOVEM A0,A
>

	DEFINE ADREAL (D1,D2,D3,F,S)<
IFNB <F>,<
	JFCL ^O17,.+1	;;CLEAR ARITH OVFLOW FLAGS
>
	MOVE A0,D2
	FADR A0,D3
IFNB <F>,<
	JFCL F ;FLOATING OVERFLOW
>
	MOVEM A0,D1
	MOVE A1,D2+1	;;TRANSFER REST OF DESCR
	MOVEM A1,D1+1
IFNB <S>,<
	JRST S
>
>


	DEFINE AEQL (A,B,C,D)<
IFDIF <B><0>,<
	MOVE A0,B
>
	WEIGHT D,C
	XFER \.%%K,AEQL,A,B,C,D
>

	DEFINE AEQL0 (A,B,C,D)<
	JFCL ;+++++++++++++++++++++++++++++++++++++++++++++++++++++
>

	DEFINE AEQL1 (A,B,C,D)<
IFIDN <B><0>,<
	SKIPN A
	JRST D
>
IFDIF <B><0>,<
	CAMN A0,A
	JRST D
>
>

	DEFINE AEQL2 (A,B,C,D)<
IFIDN <B><0>,<
	SKIPE A
	JRST C
>
IFDIF <B><0>,<
	CAME A0,A
	JRST C
>
>

	DEFINE AEQL3 (A,B,C,D)<
IFIDN <B><0>,<
	SKIPE A
	JRST C
	JRST D
>
IFDIF <B><0>,<
	CAME A0,A
	JRST C
	JRST D
>
>

	DEFINE AEQLC (A,B,C,D)<
IFDIF <B><0>,<
	MOVEI A0,B
>
	WEIGHT D,C
	XFER \.%%K,AEQL,A,B,C,D
>

	DEFINE AEQLIC(D1,N1,N2,NE,EQ)<
	MOVE A0,D1
	MOVE A0,N1(A0)
	WEIGHT EQ,NE
	XFER \.%%K,AEQLI,N2,NE,EQ
>

	DEFINE AEQLI0(N2,NE,EQ)<
	JFCL	;;++++++++++++++++++++++++++++++++++++++++++++++++++
>

	DEFINE AEQLI1(N2,NE,EQ)<
	CAIN A0,N2
	JRST EQ
>

	DEFINE AEQLI2(N2,NE,EQ)<
	CAIE A0,N2
	JRST NE
>

	DEFINE AEQLI3(N2,NE,EQ)<
	CAIE A0,N2
	JRST NE
	JRST EQ
>

	DEFINE APDSP (ST1,ST2)<
	MOVEI A0,ST1
	MOVEI A1,ST2	;;GET ADDRESS OF STRING TO APPEND
	EXTERN APPEND
	PUSHJ PDP,APPEND
>


	DEFINE ARRAX (N,%A)<
..%%K=<N>*DESCR
%A:
	XLIST
REPEAT ..%%K,<
	Z
>
	LIST
>

	DEFINE BKSIZE (A,B,%C,%D)<
	MOVE A0,B	;;GET FLAGS PLUS VALUE
	MOVE A0,1(A0)
	TLNN A0,STTL	;;STRING STRUCTURE?
	JRST [ ADDI A0,DESCR
		 HRRZM A0,A
		 JRST %C]

	TLZ A0,-1	;;GET VALUE ONLY
	SUBI A0,1
	IDIVI A0,CPD
	ADDI A0,5
	LSH A0,1	;;MULTIPLY BY TWO
%D:	MOVEM A0,A
%C:	SETZM A+1
>

	DEFINE BKSPCE(D)<
	EXTERN MBSR.
	MTOP. 02,@D
>


	DEFINE BRANCH (A,B)<
	JRST A
>

	DEFINE BRANIC (A,B)<
	MOVE A0,A
	JRST @B(A0)
>

	DEFINE BUFFER(N,%A)<
	.%%K=<N>/5+1
%A:
	XLIST
REPEAT .%%K,<
	ASCII &     &
>
	LIST
>


	DEFINE CHKVAL (A,B,C,D,E,F)<
	MOVE A0,C+SPECL
	ADD A0,B
	WEIGHT F,E,D
	XFER \.%%K,ACOMP,A,D,E,F
>

	DEFINE CLERTB (T,K)<
	MOVE A0,[XWD K,K]
	MOVEI A2,^D128/2
	MOVEM A0,T-1(A2)
	SOJG A2,.-1
>

	DEFINE COPY (A)<
MDATA=1
PARMS=2
MLINK=3
	RADIX 8
	IFE <A-1>,<
.%%K=0
ALPHA:
REPEAT <^D128/5+1>,<
Z0=.%%K
Z1=.%%K+1
Z2=.%%K+2
Z3=.%%K+3
Z4=.%%K+4
.%%K=.%%K+5
	EXPAND \Z0,\Z1,\Z2,\Z3,\Z4
>
	LALL
AMPST:	ASCII .&.
COLSTR:	ASCII .: .
QTSTR:	ASCII /'/
SEMSTR:	ASCII .;.
	RADIX 10
	XALL
>

	IFE <A-2>,<
	LALL
CPA=5	;;NO. OF CHARACTERS/MACHINE ADDRESSING UNIT
CHARNO=^D128
ALPHSZ=CHARNO
DESCR=2
D=DESCR
FNC=1
MARK=2
PTR=4
STTL=^O10
TTL=^O20
SPCFLG=^O40	;;NEW FLAG DEFINED TO UNIQUELY DEFINE A SPECIFIER
SIZLIM=^O777777
SPEC=4
	INTERN UNITC,UNITI,UNITO,UNITP
UNITC=^D99	;;UNIT FOR CHARACTER I/O
UNITI=5	;;INPUT UNIT NUMBER
UNITO=6	;;OUTPUT UNIT NUMBER
UNITP=7	;;PUNCH UNIT NUMBER

	RADIX 10
	XALL
>


	IFE <A-3>,<
	JFCL	;;NO EXTERNAL LINKAGES PROVIDED NOW
	RADIX 10
>

>

	DEFINE EXPAND (Z0,Z1,Z2,Z3,Z4)<
	LALL
	BYTE (7) Z0,Z1,Z2,Z3,Z4
	XALL
>

	DEFINE CPYPAT(D1,D2,D3,D4,D5,D6)<
	EXTERN CPYPAX
	MOVEI A1,D1
	MOVEI A2,D2
	MOVEI A3,D3
	MOVEI A4,D4
	MOVEI A5,D5
	MOVEI A6,D6
	PUSHJ PDP,CPYPAX
>

	DEFINE DATE (SP)<
	EXTERN DATX	;;TO AVIOD CONFLICT WITH MACRO NAME
			;;AND EXTERN THE SAME
	EXTERN DATBUF
	PUSHJ PDP,DATX	;;GO TO THE DATE SUBROUTINE
	MOVE A0,[POINT 7,DATBUF,]
	MOVEM A0,SP+SPECO
	MOVEI A0,^D9
	HRRM A0,SP+SPECL
>

	DEFINE DECRA (D,N)<
IFE <N-1>,<
	SOS D
>
IFN <N-1>,<
	MOVNI A0,N
	ADDM A0,D	;;SUBTRACT
>
>

	DEFINE DEQL (D1,D2,NE,EQ)<
	MOVE A0,D1
	MOVE A1,D1+1
	WEIGHT EQ,NE
	XFER \.%%K,DEQL,D2,NE,EQ
>

	DEFINE DEQ0 (D2,NE,EQ)<
	JFCL ;+++++++++++++++++++++++++++++++++++++++++
>

	DEFINE DEQL1 (D2,NE,EQ)<
	CAME A0,D2
	JRST .+3
	CAMN A1,D2+1
	JRST EQ
>

	DEFINE DEQL2 (D2,NE,EQ)<
	CAME A0,D2
	JRST NE
	CAME A1,D2+1
	JRST NE
>

	DEFINE DEQL3 (D2,NE,EQ)<
	CAME A0,D2
	JRST NE
	CAMN A1,D2+1
	JRST EQ
	JRST NE
>

	DEFINE DESCX (A,F,V)<
	EXP A
	XWD F,V
>

	DEFINE DIVIDE(D1,D2,D3,F,S)<
	SKIPN D3
IFB <F>,<
	HALT .
>
IFNB <F>,<
	JRST F
>
	MOVE A0,D2
	IDIV A0,D3
	MOVEM A0,D1
	MOVE A0,D2+1
	MOVEM A0,D1+1
IFNB <S>,<
	JRST S
>>

	DEFINE DUMP<>

	DEFINE DVREAL (D1,D2,D3,F,S,%A) <
IFNB <F>,<
	JFCL ^O17,.+1	;;CLEAR ARITH FLAGS
>
	SKIPN D3
IFB <F>,<
	HALT .
>
IFNB <F>,<
	JRST F
>
	MOVE A0,D2
	FDVR A0,D3	;;DIVIDE
IFNB <F>,<
	JFCL F	;;FLOATING OVERFLOW
>
	MOVEM A0,D1
	MOVE A1,D2+1	;;TRANSFER REST OF DESCR
	MOVEM A1,D1+1
IFNB <S>,<
	JRST S
>
>

	DEFINE ENDEX(A,%A)<
	EXTERN RESTRT

	JRST RESTRT
>

	DEFINE ENFILE (A)<
	EXTERNAL TPFCN.,EXIT.
	MTOP. 04,@A
>

	DEFINE EQU (A)<>

	DEFINE EXPINT(D1,D2,D3,F,S)<
	EXTERN EXP1.0
	MOVE 0,D2
	SKIPN 1,D3
IFNB<F>,<
	JRST F
>
IFB<F>,<
	JFCL	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
	PUSHJ PDP,EXP1.0
	MOVEM 0,D1	;;SAVE THE RESULT
	MOVE A1,D2+1	;;GET FLAGS
	MOVEM A1,D1+1
IFNB<S>,<
	JRST S
>>

	DEFINE EXREAL(D1,D2,D3,F,S)<
;RAISE A REAL NUMBER TO A REAL POWER

	EXTERN EXP3.2
	MOVE 2,D2
	MOVE 3,D3
	PUSHJ PDP,EXP3.2
	MOVEM 2,D1
	MOVE A0,D2+1
	MOVEM A0,D1+1
IFNB <S>,<
	JRST S
>
>
	DEFINE FIRSTH<
IFN REENTR,<
	TWOSEG	;;INDICATE THERE ARE TWO SEGMENTS FOLLOWING
	RELOC ^O400000	;;PUT FOLLOWING CODE IN HIGH SEGMENT
>
>

	DEFINE FIRSTL<
IFN REENTR,<
	RELOC 0	;;PUT FOLLOWING CODE IN LOW SEGMENT
>
>

	DEFINE FORMAT (A)<
	ASCII \A\
>

	DEFINE FSHRTN (S,N)<
IFE <N-1>,<
	SOS S+SPECL
	IBP S+SPECO
>
IFN <N-1>,<
	MOVNI A0,N
	ADDM A0,S+SPECL
	IBP S+SPECO
	AOJL A0,.-1
>
	SKIPGE S+SPECL	;;GUARD AGAINST NEGATIVE LENGTH STRINGS
	SETZM S+SPECL
>

	DEFINE GETAC (D1,D2,N)<
IFIDN <N><0>,<
	MOVE A0,@D2
>
IFDIF <N><0>,<
	MOVE A0,D2
	MOVE A0,N(A0)
>
	MOVEM A0,D1
>

	DEFINE GETBAL (S,D,F,O,%A,%B,%C,%D,%E)<
	MOVEI J,1
	MOVE SPEC1,S+SPECO
	MOVE LOOP,S+SPECL
	JUMPE LOOP,.+3
	IBP SPEC1
	SOJG LOOP,.-1
	MOVE LOOP,D
	ILDB CH,SPEC1
	CAIN CH,")"
	JRST F
	CAIE CH,"("
	JRST %E
	SUBI LOOP,1	;;ACCOUNT FOR "("
	MOVEI COUNT,1
%D:	ILDB CH,SPEC1
	ADDI J,1
	CAIN CH,")"
	JRST %B
	CAIN CH,"("
	AOS COUNT
%C:	SOJG LOOP,%D
	JRST F
%B:	SOJE COUNT,%E
	JRST %C
%E:	ADDM J,S+SPECL
IFNB <O>,<
	JRST O
>>

	DEFINE GETD (D1,D2,D3)<
	MOVE A0,D2
	ADD A0,D3
	MOVSI A0,(A0)
	HRRI A0,D1
	BLT A0,D1+1
>

	DEFINE GETDC (D1,D2,N)<
IFDIF <N><0>,<
	MOVE A2,D2
	MOVSI A2,N(A2)
>
IFIDN <N><0>,<
	HRL A2,D2
>
	HRRI A2,D1
	BLT A2,D1+1
>

	DEFINE GETLG (D,S)<
	MOVE A0,S+SPECL
	MOVEM A0,D
	SETZM D+1
>

	DEFINE GETLTH (D1,D2)<
	MOVE A0,D2
	SUBI A0,1
	IDIVI A0,CPD
	ADDI A0,4
	IMULI A0,DESCR
	MOVEM A0,D1
	SETZM D1+1
>

	DEFINE GETSIZ (D1,D2)<
	MOVE A0,D2
	HRRZ A0,1(A0)
	MOVEM A0,D1
	SETZM D1+1
>

	DEFINE GETSPC (S,D,N)<
	MOVE A0,D
IFDIF <N><0>,<
	ADDI A0,N
>
	HRLI A0,(A0)
	HRRI A0,S
	BLT A0,S+SPECL
>

	DEFINE HIGH<
	RELOC
>

	DEFINE IFILEW<>

	DEFINE OFILEW<>

	DEFINE FILEM(UNIT,NAME)<>

	DEFINE IFILEM(UNIT,NAME)<
	EXTERN IFFAIL,IFILEX
	SETZM IFFAIL
	MOVEI A1,UNIT
	MOVEI A2,NAME
	PUSHJ PDP,IFILEX	;;TRANSFER THE STRING AND DO THE IFILE
	MOVEI A0,0
	EXCH A0,IFFAIL
	JUMPN A0,FAIL		;;SIGNAL FUNCTION FAILURE
>

	DEFINE OFILEM(UNIT,NAME)<
	EXTERN OFILEX,IFFAIL
	SETZM IFFAIL
	MOVEI A1,UNIT
	MOVEI A2,NAME
	PUSHJ PDP,OFILEX
	MOVEI A0,0
	EXCH A0,IFFAIL
	JUMPN A0,FAIL		;;SIGNAL FUNCTION FAILURE
>

	DEFINE INCRA (D,N)<
IFE <N-1>,<
	AOS D
>
IFN <N-1>,<
	MOVEI A0,N
	ADDM A0,D
>
>

	DEFINE INCRV (D,N)<
IFE <N-1>,<
	AOS D+1
>
IFN <N-1>,<
	MOVEI A0,N
	ADDM A0,D+1
>
>

	DEFINE INIT <
	INTERN DMPCL,LISTCL
	INTERN DTLIST,ARTHNO,R
	INTERN FRSGPT,HDSGPT,TLSGP1,OCALIM
	EXTERN PDL,TOTAVL,STCORE,ICORE
	EXTERN INTCOR,INTDEV,JOBAPR
	EXTERN OFILE,IFILE,LSTFIL,SRCFIL
	EXTERNAL FORSE.,EOFC,JOBREN
	INTERN SNOBOL
	INTERN OVER
	INTERN R
	INTERN I
	EXTERN RENCOM,DMPFLG,UNFLAG
	INTERN SYSCUT

SNOBOL:	RESET.
	MOVE PDP,PDL	;;PUSH DOWN LIST POINTER
	PUSHJ PDP,INTDEV	;;INITIALIZE I/O DEVICES
	PUSHJ PDP,INTCOR	;;CORE INITIALIZATION
	MOVEI A0,RENCOM	;;GIVE CUT BY SYSTEM MSG FOR REENTRY
	MOVEM A0,JOBREN
	MOVEI A0,1	;;MAKE LIST LEFT DEFAULT
	MOVEM A0,LLIST
	SKIPE DMPFLG
	MOVEM A0,DMPCL	;;SET &DUMP KEYWORD FOR /D
	SKIPE UNFLAG
	SETZM LISTCL	;;SET -UNLIST FOR /U
>

	DEFINE INSERT (D1,D2)<
	MOVE A1,D1
	MOVE A2,D2
	MOVE A3,FATHER(A1)
	MOVE A4,LSON(A3)
	MOVEM A3,FATHER(A2)
	MOVE A0,FATHER+1(A1)
	MOVEM A0,FATHER+1(A2)
	MOVEM A2,FATHER(A1)
	MOVEM A2,RSIB(A4)
	MOVE A0,D2+1
	MOVEM A0,FATHER+1(A1)
	MOVEM A0,RSIB+1(A4)
	MOVEM A1,LSON(A2)
	MOVE A0,D1+1
	MOVEM A0,LSON+1(A2)
	AOS CODE+1(A2)
>

	DEFINE INTRL (A,B)<
	EXTERNAL FLOAT
	JSA Q,FLOAT
	ARG B
	MOVEM 0,A
	MOVEI A0,R
	MOVEM A0,A+1
>

	DEFINE INTSPC (S,DES)<
	MOVEI A0,S
	MOVE A1,DES
	EXTERN INTSPX
	PUSHJ PDP,INTSPX
>

	DEFINE ISTACK(A) <
	MOVE CSTACK,[XWD -STSIZE,STACK+DESCR-1]
	MOVE OSTACK,CSTACK	;;OLD STACK POSITION=CURRENT STACK POS.
>

	DEFINE LCOMP (S1,S2,GT,EQ,LT)<
	MOVE A0,S1+SPECL
	WEIGHT LT,EQ,GT
	XFER \.%%K,ACOMP,S2+SPECL,GT,EQ,LT
>

	DEFINE LEQLC (S,N,NE,EQ)<
IFDIF <N><0>,<
	MOVEI A0,N
>
	WEIGHT EQ,NE
	XFER \.%%K,AEQL,S+SPECL,N,NE,EQ
>

	DEFINE LEXCMP (S1,S2,GT,EQ,LT)<
	MOVE A0,S1+SPECO
	MOVE A1,S2+SPECO
	MOVE A3,S1+SPECL
	MOVE A4,S2+SPECL
	WEIGHT LT,EQ,GT
	XFER1 \.%%K,LEX,GT,EQ,LT
>

	DEFINE XFER1 (A,B,C,D,E)<
	B'A C,D,E>

	DEFINE LEX0 (GT,EQ,LT)<
	JFCL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>

	DEFINE LEX1 (GT,EQ,LT,%A)<
	AOS LEX1CT
	LEX7 %A,%A,LT
	EXTERN LEX1CT
%A:
>

	DEFINE LEX2 (GT,EQ,LT,%A)<
	AOS LEX2CT
	LEX7 %A,EQ,%A
	EXTERN LEX2CT
%A:>

	DEFINE LEX3 (GT,EQ,LT,%A)<
	AOS LEX3CT
	LEX7 %A,EQ,LT
	EXTERN LEX3CT
%A:
>

	DEFINE LEX4 (GT,EQ,LT,%A)<
	AOS LEX4CT
	LEX7 GT,%A,%A
	EXTERN LEX4CT
%A:
>

	DEFINE LEX5 (AGT,AEQ,ALT,%A)<
.%%K=%A
	AOS LEX5CT
	LEX7 AGT,%A,ALT
	EXTERN LEX5CT
%A:
>

	DEFINE LEX6 (GT,EQ,LT,%A)<
	AOS LEX6CT
	LEX7 GT,EQ,%A
	EXTERN LEX6CT
%A:
>

	DEFINE LEX7 (GT,EQ,LT,%A,%B,%C,%D,%E,%F)<
	AOS LEX7CT
IFE <GT-LT>,<
	CAIE A3,(A4)
	JRST GT
>
IFN <GT-LT>,<
	CAIE A3,(A4)
	JRST %D
>
	CAIE A3,(A4)
	JRST %D	;;LENGTHS NOT EQUAL
	JUMPE A3,EQ
%C:	ILDB CH,A0
	ILDB CH1,A1
	CAILE CH,(CH1)
	JRST GT
	CAIE CH,(CH1)
	JRST LT
	SOJG A3,%C
	JRST EQ
%D:	JUMPE A3,LT
	JUMPE A4,GT
%E:	ILDB CH,A0
	ILDB CH1,A1
	CAIE CH,(CH1)
	JRST %F
	SOJE A3,LT
	SOJE A4,GT
	JRST %E
%F:	CAILE CH,(CH1)
	JRST GT
	JRST LT
	EXTERN LEX7CT
%A:	
>



	DEFINE LHERE <>

	DEFINE LINK(D1,D2,D3,D4,F,S) <
	INTERN INTR10
	EXTERN LINKFC
	MOVEI A1,D1
	MOVEI A2,D2
	MOVEI A3,D3
	MOVEI A4,D4
	PUSHJ PDP,LINKFC
	JRST F
IFNB <S>,<
	JRST S
>
>

	DEFINE LINKOR (D1,D2,%A,%B)<
	MOVE A0,D2
	MOVE A1,D1	;;GET START ADDRESS
%B:	SKIPN A2,2*D(A1)
	JRST %A
	MOVE A1,D1
	ADD A1,A2
	JRST %B
%A:	MOVEM A0,2*D(A1)	;;STORE THE RESULT
>

	DEFINE LOAD (D,S1,S2)<
	EXTERN LOAFNC
	INTERN UNDF
	MOVEI A1,D
	MOVEI A2,S1
	MOVEI A3,S2
	PUSHJ PDP,LOAFNC
>

	DEFINE LOCAPT (D1,D2,D3,F,S,%A)<
	EXTERN LOCATX
	MOVEI A11,D2
	MOVEI A6,D1
	MOVEI A10,D3
	PUSHJ PDP,LOCATX	;;LOCATED IN COMMON
IFNB <F>,<
	JRST F
>
IFB <F>,<
	JRST %A
>
IFNB <S>,<
	JRST S
>
%A:
>

	DEFINE LOCAPV (D1,D2,D3,F,S,%A)<
	EXTERN LOCAVX
	MOVEI A11,D2
	MOVEI A6,D1
	MOVEI A10,D3
	PUSHJ PDP,LOCAVX	;;LOCATED IN COMMON
IFNB <F>,<
	JRST F
>
IFB <F>,<
	JRST %A
>
IFNB <S>,<
	JRST S
>
%A:
>

	DEFINE LOCSPX (SP,DES)<
	EXTERN LOCSPR
	MOVEI A0,DES
	MOVEI A1,SP
	PUSHJ PDP,LOCSPR	;;LOCATE SPECIFIER ROUTINE
>


	DEFINE LOW<
	RELOC
>

	DEFINE LVALUE (D1,D2,%A,%B)<
	MOVE A7,D2	;;SET A7=A
	ADDI A7,2*D	;;SET A7=A+2D
	MOVEI A10,D(A7)	;;SET A10=A+3D
	MOVEI A1,(A7)	;;SAVE FOR LATER USE
	MOVEI A2,(A10)
	MOVE A3,(A2)	;;SET INITIAL AS MINIMUM
%B:	MOVE A4,(A1)	;;GET N(I)
	MOVE A5,(A2)	;;GET I(J)
	JUMPE A4,%A	;;END OF LIST,CHECK FOR ONE MORE
	CAILE A3,(A5)	;;NEW VALUE LT OLD VALUE?
	MOVEI A3,(A5)	;;YES
	MOVEI A1,(A7)	;;REINITIALIZE
	MOVEI A2,(A10)
	ADDI A1,(A4)	;;FORM A+N(K)+2D
	ADDI A2,(A4)	;;FORM A+N(K)+3D
	JRST %B
%A:	CAILE A3,(A5)	;;LAST VALUE LT OLD?
	MOVEI A3,(A5)	;;YES, RENEW I
	MOVEM A3,D1	;;STORE VALUE
	SETZM	D1+1
>

	DEFINE MAKNOD (D1,D2,D3,D4,D5,D6)<
	MOVE A0,D2	;;GET A2
	MOVE A1,D5
	MOVEM A1,D(A0)
	MOVE A1,D5+1
	MOVEM A1,D+1(A0)
	MOVE A1,D4
	MOVEM A1,2*D(A0)
	MOVE A1,D3
	MOVEM A1,3*D(A0)
IFNB <D6>,<
	MOVE A1,D6
	MOVEM A1,4*D(A0)
	MOVE A1,D6+1
	MOVEM A1,4*D+1(A0)
>
	MOVE A1,D2
	MOVEM A1,D1
	MOVE A1,D2+1
	MOVEM A1,D1+1
>

	DEFINE MNREAL (D1,D2)<
	MOVN A0,D2
	MOVEM A0,D1
>

	DEFINE MNSINT (D1,D2,F,S)<
	MOVE A0,D2+1	;;TRANSFER THE DESCRS
	MOVEM A0,D1+1
	MOVN A0,D2
	MOVEM A0,D1
IFNB <F>,<
	CAMG A0,[EXP ^O777777000000]
	JRST F
>
IFNB <S>,<
	JRST S
>
>

	DEFINE MOVA (D1,D2)<
	MOVE A0,D2
	MOVEM A0,D1
>

	DEFINE MOVBLK (D1,D2,D3)<
	HRL A0,D2	;;"FROM"
	HRR A0,D1	;;"TO"
	HRRZ A1,A0
	ADD A0,[XWD DESCR,DESCR]
	ADD A1,D3
	BLT A0,1(A1)
>

	DEFINE MOVD (D1,D2)<
	MOVSI A0,D2	;;FROM
	HRRI A0,D1	;;TO
	BLT A0,D1+1
>

	DEFINE MOVDIC (D1,N1,D2,N2)<
	MOVE A1,D1
	MOVE A2,D2
	MOVE A0,N2(A2)
	MOVEM A0,N1(A1)
	MOVE A0,N2+1(A2)
	MOVEM A0,N1+1(A1)
>

	DEFINE MOVV (D1,D2)<
	HRR A0,D2+1
	HRRM A0,D1+1
>

	DEFINE MPREAL (D1,D2,D3,F,S,%A)<
IFNB <F>,<
	JFCL ^O17,.+1	;;CLEAR FLAGS
>
	MOVE A0,D2
	FMPR A0,D3	;;FLOATING MULTIPLY
IFNB <F>,<
	JFCL F	;;OVERFLOW
>
	MOVEM A0,D1	;;STORE THE RESULT
	MOVE A1,D2+1	;;TRANSFER THE REST
	MOVEM A1,D1+1
IFNB <S>,<
	JRST S
>
>

	DEFINE MSTIME (D)<
	MOVEI A0,0	;;FORCE TO USE THIS JOBS TIME
	RUNTIM A0,	;;THIS CALL MEASURES RUN TIME AND NOT
			;;ELAPSED TIME AS ON OTHER SYSTEMS
	MOVEM A0,D
	SETZM D+1
>

	DEFINE MULT (D1,D2,D3,F,S)<
IFNB <F>,<
	JFCL ^O17,.+1
>
IFDIF <D1><D2>,<
	MOVE A0,D2
	IMUL A0,D3
	MOVEM A0,D1
	MOVE A0,D2+1
	MOVEM A0,D1+1
>
IFIDN <D1><D2>,<
	MOVE A0,D3
	IMULM A0,D1
>
IFNB <F>,<
	JFCL F
>
IFNB <S>,<
	JRST S
>
>

	DEFINE MULTC (D1,D2,N)<
IFDIF <D1><D2>,<
	MOVE A0,D2
	IMULI A0,N
	MOVEM A0,D1
	SETZM D1+1
>
IFIDN <D1><D2>,<
	MOVEI A0,N
	IMULM A0,D1
	SETZM D1+1
>
>

	DEFINE ORDVST <
	INTERNAL OBSIZ,OBSTRT
	EXTERNAL ORDVSX
	PUSHJ PDP,ORDVSX
>

	DEFINE OUTPUX (DES,FOR,LIST)<
	MOVEI A1,FOR
	OUT. 01,@DES
IFNB <LIST>,<
IRP LIST,<
	DATA. 02,LIST
>>
	FIN.
>

	DEFINE PLUGTB (TAB,KEY,SP,%A,%B)<
	MOVE A0,SP+SPECL	;;GET NO. OF ENTRIES TO PLUG
	MOVEI A1,KEY
	MOVE A4,SP+SPECO
	JUMPE A0,%A
%B:	SETZM CH1
	ILDB CH,A4
	IDIVI CH,2	;;REMAINDER IN CH1
	SKIPN CH1	;;LEFT OR RIGHT HALF OF TABLE
	JRST .+3	;;RIGHT HALF
	HRLM A1,TAB(CH)	;;LEFT HALF
	SKIPA
	HRRM A1,TAB(CH)
	SOJG A0,%B
%A:
>


	DEFINE POP (A)<
IRP A,<
	UNSTAK CSTACK,A+1
	UNSTAK CSTACK,A
>
>

	DEFINE PROC (D1,N,D2)<>

	DEFINE PSTACK (A)<
	MOVEI A0,-DESCR-1(CSTACK)
	MOVEM A0,A
	SETZM A+1
>

	DEFINE PUSH (A)<
IRP A,<
	STAK CSTACK,A
	STAK CSTACK,A+1
>>

	DEFINE PUTAC (D1,N,D2)<
	MOVE A0,D2
	MOVE A1,D1
	MOVEM A0,N(A1)
>

	DEFINE PUTD (D1,D2,D3)<
	MOVSI A0,D3	;;FROM
	HRR A0,D1
	ADD A0,D2	;;TO
	HRRI A1,(A0)	;;END TEST
	BLT A0,1(A1)
>

	DEFINE PUTDC (D1,N,D2)<
	HRLI A0,D2	;;"FROM"
	HRR A0,D1	;;"TO"
IFDIF <N><0>,<
	ADDI A0,N
>
	MOVEI A1,(A0)
	BLT A0,1(A1)
>

	DEFINE PUTLG (SP,DES)<
	MOVE A0,DES
	MOVEM A0,SP+SPECL
>

	DEFINE PUTSPC (DES,N,SP)<
	MOVSI A0,SP
	HRR A0,DES
	ADDI A0,N
	HRRI A1,(A0)
	BLT A0,SPECL(A1)
>

	DEFINE PUTVC (D1,N,D2)<
	MOVE A0,D1
	HRR A1,D2+1
	HRRM A1,N+1(A0)
>

	DEFINE RXFER(A,B)<
	JSP A2,B'A
>

	EXTERN RCALX0,RCALX1,RCALX2,RCALX3,RCALX4,RCALX5
	EXTERN RCALX6,RCALX7
	EXTERN RCALD0,RCALD1,RCALD2,RCALD3,RCALD4,RCALD5
	EXTERN RCALD6,RCALD7

	DEFINE RCALL(D,PR,DS,LS,%A,%B)<

; THE BULK OF THE TIME DS HAS EITHER ZERO OR ONE MEMBERS
; SO IT IS BENEFICIAL TO OPTIMIZE AROUND THIS CASE.

.%%R=A4
.%%K=0
IRP DS,<
.%%K=.%%K+1>
..K=.%%K
REPEAT .%%K,<
..Z=1
IRP DS,<
IFE <..Z-.%%K>,<
	MOVEI .%%R,DS
.%%R=.%%R+1
>
..Z=..Z+1
>
.%%K=.%%K-1
>

IFNB <D>,<
	RXFER \..K,RCALD
	XWD D,PR
>

IFB <D>,<
	RXFER \..K,RCALX
	XWD 0,PR
>


IRP LS,<
IFNB <LS>,<
	JRST LS
>
IFB <LS>,<
	JRST %A
>
>
%A:
IF2,<
	PURGE %A
>
>



	DEFINE RCOMP (D1,D2,GT,EQ,LT)<
	ACOMP D1,D2,GT,EQ,LT
>

	DEFINE REALST (SP,DES,%A)<
	MOVEI A0,SP	;;LOCATION OF STRING
	MOVEI A1,DES	;;LOCATION OF REAL NUMBER
	EXTERN REALSX
	PUSHJ PDP,REALSX	;;CONVERT IT
>



	DEFINE REMSX (S1,S2,S3)<
	MOVN A3,S3+SPECL	;;SAVE FOR LATER USE
	SETSP S1,S2
	ADDM A3,S1+SPECL	;;FORM L2-L3
	SKIPE A3		;;DON'T INCREMENT IF ZERO
	IBP S1+SPECO
	AOJL A3,.-1
>

	DEFINE RESETF (DES,FLAG)<
	HRLI A0,FLAG
	ANDCAM A0,DES+1
>

	DEFINE REWIND (DES)<
	MTOP. 00,@DES
>

	DEFINE RLINT (D1,D2,F,S)<
	EXTERN IFIX
	JSA ^O16,IFIX
	JUMP D1
IFNB <F>,<
	CAILE 0,^O777777
	JRST F
>
	MOVEM 0,D2
	MOVEI A0,I
	MOVEM A0,D2+1
IFNB <S>,<
	JRST S
>
>

	DEFINE RPLACE (S1,S2,S3,%A,%B,%C,%D,%E)<
	MOVE A1,S1+SPECL	;;ITERATE OVER THIS AMOUNT
	JUMPE A1,%A
	MOVE A2,S1+SPECL
	MOVE A4,S1+SPECO
%D:	MOVE A5,S3+SPECO
	MOVE A3,S2+SPECO
	MOVE A0,S2+SPECL
	ILDB CH1,A4
	MOVEI A10,0
%C:	ILDB CH,A3
	IBP A5
	CAMN CH,CH1
	JRST %B		;;CHARACTER MATCHES, SUBSTITUTE
%E:	SOJG A0,%C	;;LOOK AT MORE OF SOURCE STRING
	SKIPE A10
	DPB A10,A4
	SOJG A2,%D	;;LOOK FOR OCCURRENCES OF NEXT 
			;;REPLACEMENT CHARACTER
	JRST %A		;;DONE LOOKING SO QUIT
%B:	LDB A10,A5	;;REPLACE IT WITH THIS CHARACTER
	JRST %E		;;CHECK FOR ENDING CONDITIONS NOW
%A:
>

	DEFINE RRTURN (DES,N)<
	EXTERN RRTND,RRTNX
	MOVEI A1,N-1
IFNB <DES>,<
	MOVEI A2,DES
	JRST RRTND
>
IFB <DES>,<
	JRST RRTNX
>
>

	DEFINE RSETFI (D,F)<
	MOVE A0,D
	MOVSI A1,F
	ANDCAM A1,1(A0)
>

	DEFINE SAVEM(SP,%A)<
	INTERN RETNUL,SAVECL
	INTERN INTERP,INIT
	EXTERN SAVCOR
	INTERN FAIL

%A:	JUMP ^D29	;;DEFINE THE DEFAULT DEVICE NUMBER
	OFILEM(%A,SP)	;;OPEN THE FILE
	MOVEI A2,SP
	PUSHJ PDP,SAVCOR	;;WRITE THE DATA OUT
	ENFILE(%A)	;;CLOSE THE FILE
>

	DEFINE SBREAL (D1,D2,D3,F,S,%A)<
IFNB <F>,<
	JFCL ^O17,.+1
>
	MOVE A0,D2
	FSBR A0,D3
IFNB <F>,<
	JFCL F
>
	MOVEM A0,D1
	MOVE A1,D2+1
	MOVEM A1,D1+1
IFNB <S>,<
	JRST S
>
>

	DEFINE SELBRA (D1,LIST,%A)<
	MOVE A0,D1
	JRST .+1(A0)
	HALT .	;;GUARD AGAINST A CASE OF ZERO
IRP LIST,<
IFB <LIST>,<
	JRST %A
>
IFNB <LIST>,<
	JRST LIST
>>
%A:
>

	DEFINE SETAC (D1,N)<
IFIDN <N><0>,<
	SETZM D1
>
IFDIF <N><0>,<
	MOVEI A0,N
	MOVEM A0,D1
>
>

	DEFINE SETAV (D1,D2)<
	HRRZ A0,D2+1
	MOVEM A0,D1
	SETZM D1+1
>

	DEFINE SETF (D1,F)<
	MOVSI A0,F
	IORM A0,D1+1
>

	DEFINE SETFI (D1,F)<
	MOVSI A0,F
	MOVE A1,D1
	IORM A0,1(A1)
>

	DEFINE SETLC (S1,N)<
IFIDN <N><0>,<
	SETZM S1+SPECL
>
IFDIF <N><0>,<
	MOVEI A0,N
	MOVEM A0,S1+SPECL
>
>

	DEFINE SETSIZ (D1,D2)<
	MOVE A0,D2
	MOVE A1,D1
	HRRM A0,1(A1)
>

	DEFINE SETSP (S1,S2)<
	MOVSI A0,S2	;;"FROM"
	HRRI A0,S1	;;"TO"
	BLT A0,S1+SPECL
>

	DEFINE SETVA (D1,D2)<
	MOVE A0,D2
	HRRM A0,D1+1
>

	DEFINE SETVC (D1,N)<
	MOVEI A0,N
	HRRM A0,D1+1
>

	DEFINE SHORTN (S1,N)<
IFE <N-1>,<
	SOS S1+SPECL
>
IFN <N-1>,<
	MOVNI A0,N
	ADDM A0,S1+SPECL
>
>

	DEFINE SPCINT (D1,SPE,F,S,%B)<
	MOVEI A0,SPE	;;INPUT STRING
	MOVEI A1,D1	;;WHERE TO STORE RESULT
	EXTERN SPCINX
	PUSHJ PDP,SPCINX
IFNB <F>,<
	JRST F
>
IFB <F>,<
	JRST %B
>
IFNB <S>,<
	JRST S
>
IFB <F>,<
%B:
>
>

	DEFINE SPEX (A,F,V,O,L)<
	EXP A
	XWD F+SPCFLG,V
IFDIF <O><0>,<
.%%K=<O>-<O>/5*5
	POINT 7,A+<O>/5,.%%K*7-1
>
IFIDN <O><0>,<
	POINT 7,A,
>
	XWD 0,L
>


	DEFINE SPOP (A)<
IRP A,<
	UNSTAK CSTACK,A+3
	UNSTAK CSTACK,A+2
	UNSTAK CSTACK,A+1
	UNSTAK CSTACK,A
>
>

	DEFINE SPUSH (A)<
IRP A,<
	STAK CSTACK,A
	STAK CSTACK,A+1
	STAK CSTACK,A+2
	STAK CSTACK,A+3
>>

	DEFINE SPREAL(DES,SP,F,S,%B)<
	EXTERNAL SPREAX
	MOVEI A0,DES	;;WHERE TO STORE RESULT
	MOVEI A1,SP	;;INPUT STRING
	PUSHJ PDP,SPREAX
IFNB <F>,<
	JRST F
>
IFB <F>,<
	JRST %B
>
IFNB <S>,<
	JRST S
>
%B:
>

	DEFINE STPRNT (D1,D2,SP)<
	EXTERN OUTPTS
	MOVE A0,D2
	MOVE A1,2*DESCR(A0)
	MOVEI A1,4*DESCR(A1)	;;GET FORMAT NUMBER
	HRRZ A10,DESCR(A0)
	OUT. 01,0(A10)
	MOVEI A2,SP	;;ADDRESS OF STRING TO PRINT
	PUSHJ PDP,OUTPTS	;;LOCATED IN COMMON
>

	DEFINE STREAD (SP,DES,EOF,ERR,SUCC)<
	EXTERN BUFPNT,BUFIN
	EXTERN STREAX
	MOVEI A1,ERR
	MOVEI A2,EOF
	MOVE A3,DES
	MOVEI A4,SP
	PUSHJ PDP,STREAX
IFNB <SUCC>,<
	JRST SUCC
>>

	DEFINE STREAM (S1,S2,TAB,ERR,RO,SUC,%A)<
	INTERN STYPE
	MOVEI A4,S1	;;INPUT STRING
	MOVEI A5,S2
	MOVEI A3,TAB	;;TABLE TO START STREAMING WITH
	EXTERN STREEM
	PUSHJ PDP,STREEM
	JRST ERR
IFNB <RO>,<
	JRST RO
>
IFB <RO>,<
	JRST %A
>
IFNB <SUC>,<
	JRST SUC
>
%A:
>

	DEFINE STRING (A)<
.%%K=0
IRPC A,<.%%K=.%%K+1>
;DONT'T COUNT SINGLE QUOTES
	EXP .+4
	Z
	POINT 7,.+2,
	EXP .%%K
	ASCII \A\
>

	DEFINE SUBSP (S1,S2,S3,F,S)<
	HRRZ A0,S2+SPECL
IFNB <F>,<
	CAMLE A0,S3+SPECL
	JRST F
>
IFDIF <S1><S3>,<
	MOVE A1,[XWD S3,S1]
	BLT A1,S1+SPECO
>
	MOVEM A0,S1+SPECL
IFNB <S>,<
	JRST S
>
>

	DEFINE SUBTRT (D1,D2,D3,F,S,%A)<
IFNB <F>,<
	JFCL ^O17,.+1
>
IFDIF <D1><D2>,<
	MOVE A0,D2
	MOVE A1,D2+1
	MOVEM A1,D1+1
	SUB A0,D3
IFNB <F>,<
	JFCL F
>
	MOVEM A0,D1
>
IFIDN <D1><D2>,<
	MOVN A0,D3
	ADDM A0,D1
IFNB <F>,<
	JFCL F
>
>
IFNB <S>,<
	JRST S
>
>

	DEFINE SUM (D1,D2,D3,F,S,%A)<
IFNB <F>,<
	JFCL ^O17,.+1
>
IFDIF <D1><D2>,<
	MOVE A0,D3
	ADD A0,D2
IFNB <F>,<
	JFCL F
>
	MOVEM A0,D1
	MOVE A1,D2+1
	MOVEM A1,D1+1
>
IFIDN <D1><D2>,<
	MOVE A0,D3
	ADDM A0,D1
IFNB <F>,<
	JFCL F
>
>
IFNB <S>,<
	JRST S
>
>

	DEFINE TESTF (D,FLAG,F,S,%A)<
	MOVE A0,D+1
	WEIGHT S,F
	XFER \.%%K,TESTF,FLAG,F,S
>

	DEFINE TESTFI (D,FLAG,F,S,%A)<
	MOVE A0,D
	MOVE A0,1(A0)
	WEIGHT S,F
	XFER \.%%K,TESTF,FLAG,F,S
>

	DEFINE TESTF0 (FLAG,F,S)<
	JFCL ;+++++++++++++++++++++++++++++++++++++++++
>

	DEFINE TESTF1 (FLAG,F,S)<
	TLNE A0,FLAG
	JRST S
>

	DEFINE TESTF2 (FLAG,F,S)<
	TLNN A0,FLAG
	JRST F
>

	DEFINE TESTF3 (FLAG,F,S)<
	TLNN A0,FLAG
	JRST F
	JRST S
>


	DEFINE TIMER(D)<
	MOVEI A0,0
	MSTIM A0,
	MOVEM A0,D
	SETZM D+1
>

TITWRD=1

	DEFINE TITLE (A)<
IFN TITWRD,<
	PURGE TITLE
	TITLE A
TITWRD=0
	DEFINE TITLE (B,C,D,E,F,G)<
	SUBTTL B,C,D,E,F,G
	PAGE
>
>
>

	DEFINE TOP (D1,D2,D3,%A,%B)<
	SETZM D2
	SETZM D2+1
	MOVEI A1,DESCR
	MOVE A0,D3	;;GET A
%B:	MOVE A2,1(A0)	;;GET FLAG FIELD
	TLNE A2,TTL
	JRST %A	;;FLAG FOUND
	ADDM A1,D2
	SUBI A0,DESCR	;;A-I*D
	JRST %B
%A:	MOVEM A0,D1
	MOVE A1,D3+1
	MOVEM A1,D1+1
>

	DEFINE TRIMSP(S1,S2)<
	INTERNAL ETMCL
	EXTERN TRIMIT
	MOVEI A5,S2
	MOVEI A6,S1
	PUSHJ PDP,TRIMIT
>

	DEFINE UNLOAD(S)<
	EXTERN UNLFNC
	MOVEI A1,S
	PUSHJ PDP,UNLFNC
>

; THE FOLLOWING ALGORITH WAS MODIFIED AD HOC WITH .394
; WITH A RESULTING IMPROVEMENT OF ABOUT 2 1/2 TIMES SPEEDUP
; IN ELAPSED TIME. THE BIG KILLER WAS CAUSED BY USING THE 'IMULI'
; IN THE MAIN LOOP. ABOUT EVERY TIME THRU VARID THIS WOULD 
;CAUSE AN OVERFLOW AT LEAST ONCE. WITH THE ADDITION OF TRPINI
; THIS WOULD INVOKE LOTS MORE CODE I.E. AT OVTRAP.
;
; SO WITH EXPERIMENTING AROUND I FOUND THAT THE XOR INDEXED
; INTO A TABLE OF PSUEDO RANDOM CONSTANTS FOR EACH CHARACTER
; RESULTED IN A FAIRLY UNIFORM DISTIBUTION OF HASH CODES. THE
; TABLE HAPPENS TO BE THE CODE FOLLOWING VARID ITSELF WHICH IS
; NOW AND FOREVER SHOULD BE PURE CODE, ELSE THE SAME STRING
; WILL GENERATE DIFFERENT HASH CODES (HEAVEN FORBID).

	DEFINE VARID (D,S,%A,%B,%C)<
	HRRZ A0,S+SPECL	;;GET NO. OF CHARACTERS
	MOVE A1,S+SPECO
	SETZB A5,A6
	MOVEI A5,5	;;START WITH SOME NON-ZERO NUMBER
	JUMPE A0,%A
%B:	ILDB A2,A1
	XOR A5,.(A2)	;;MAGIC ALGORITHM
	SOJG A0,%B
%A:
%C:	JFFO A5,.+1	;;FIND NO. OF LEADING ZEROS
	MOVEI A0,^D36	;;36 BITS IN A WORD
	SUBI A0,(A6)	;;THIS MANY ONES IN M1*M2
	MOVEI A2,(A0)	;;SAVE NUMBER OF ONES
	LSH A0,-2	;;DIVIDE FIELD SIZE BY FOURTH
	MOVEI A6,0	;;CLEAR THE RESULT REGISTER
	MOVN A7,A0
; THE FIRST AND LAST QUARTERS ARE USED SINCE THE MIDDLE
; HALVES TEND TO BE CONSTANT (I.E. 400000 BIT IS ON) AND
; CAUSES CLUSTERING AROUND ZERO
	LSHC A5,(A7)	;;SHIFT RIGHT-GET FOURTH OF THE ONES
	ROT A6,(A0)	;;POSITION IN PROPER PLACE
	LSH A6,1	;;MULTIPLY BY DESCR
	CAIGE A6,<OBSIZ-1>*DESCR
	JRST .+3
	LSH A6,-2	;;DIVIDE BY 4
	JRST .-4
	MOVEM A6,D
	MOVEI A6,0
	LSH A5,(A7)	;;DROP OFF THIRD QUARTER
	LSHC A5,(A7)	;;GET REST OF ONES
	ROT A6,(A0)
	HRRM A6,D+1
	EXTERN STRREF
	AOS STRREF	;;COUNT THE NUMBER OF TIMES THROUGH HERE
			;;THIS GIVES US THE NUMBER OF TIMES A STRING
			;;LOOKUP IS MADE IN VARIABLE STORAGE
>

	DEFINE VCMPIC (D1,N,D2,GT,EQ,LT)<
	MOVE A0,D1
	HRRZ A0,N+1(A0)
	WEIGHT LT,EQ,GT
	HRRZ A1,D2+1
	XFER \.%%K,ACOMP,A1,GT,EQ,LT
>


	DEFINE VEQL (D1,D2,NE,EQ)<
	WEIGHT EQ,NE
	HRRZ A2,D1+1
	HRRZ A0,D2+1
	XFER \.%%K,AEQL,A2,A0,NE,EQ
>

	DEFINE VEQLC (D,N,NE,EQ)<
	WEIGHT EQ,NE
	HRRZ A2,D+1
IFDIF <N><0>,<
	MOVEI A0,N
	XFER \.%%K,AEQL,A2,A0,NE,EQ
>
IFIDN <N><0>,<
	XFER \.%%K,AEQL,A2,0,NE,EQ
>
>

	DEFINE ZERBLK (D1,D2)<
	HRRZ A0,D1
	SETZM (A0)
	HRL A0,D1
	ADDI A0,1
	HRRZ A1,D1
	ADD A1,D2
	BLT A0,1(A1)
>

TITLE SNOBOL4 (VERSION 3.4) FOR THE PDP-10/ LARRY WADE