TITLE	'TABLE OF CONTENTS'

;

;

;              E32 (DECEMEBR 18, 1969) -- VERSION 3.0
;		UPDATED TO VERSION 3.3 (MARCH 26, 1970)
;		 UPDATED TO VERSION 3.4.3 (JAN. 16,1971)

;

;

;      1.   LINKAGE AND EQUIVALENCES . . . . . . . . . . . . . .252

;              LINKAGE . . . . . . . . . . . . . . . . . . . . .253

;              MACHINE DEPENDENT PARAMETERS. . . . . . . . . . .254

;              CONSTANTS . . . . . . . . . . . . . . . . . . . .258

;              EQUIVALENCES. . . . . . . . . . . . . . . . . . .288

;              DATA TYPE CODES . . . . . . . . . . . . . . . . .317

;      2.   PROGRAM INITIALIZATION . . . . . . . . . . . . . . .330

;      3.   COMPILATION AND INTERPRETER INVOCATION . . . . . . .376

;      4.   SUPPORT PROCEDURES . . . . . . . . . . . . . . . . .426

;              AUGATL. . . . . . . . . . . . . . . . . . . . . .430

;              CODSKP. . . . . . . . . . . . . . . . . . . . . .454

;              DTREP . . . . . . . . . . . . . . . . . . . . . .473

;              FINDEX. . . . . . . . . . . . . . . . . . . . . .524

;      5.   STORAGE ALLOCATION AND REGENERATION PROCEDURES . . .548

;              BLOCK . . . . . . . . . . . . . . . . . . . . . .552

;              GENVAR. . . . . . . . . . . . . . . . . . . . . .577

;              GNVARI. . . . . . . . . . . . . . . . . . . . . .631

;              CONVAR. . . . . . . . . . . . . . . . . . . . . .641

;              GNVARS. . . . . . . . . . . . . . . . . . . . . .669

;              GC. . . . . . . . . . . . . . . . . . . . . . . .681

;              GCM . . . . . . . . . . . . . . . . . . . . . . .811

;              SPLIT . . . . . . . . . . . . . . . . . . . . . .841

;      6.   COMPILATION PROCEDURES . . . . . . . . . . . . . . .857

;              BINOP . . . . . . . . . . . . . . . . . . . . . .861

;              CMPILE. . . . . . . . . . . . . . . . . . . . . .883

;              ELEMNT. . . . . . . . . . . . . . . . . . . . . 1136

;              EXPR. . . . . . . . . . . . . . . . . . . . . . 1265

;              FORWRD. . . . . . . . . . . . . . . . . . . . . 1342

;              NEWCRD. . . . . . . . . . . . . . . . . . . . . 1369

;              TREPUB. . . . . . . . . . . . . . . . . . . . . 1441

;              UNOP. . . . . . . . . . . . . . . . . . . . . . 1481

;      7.   INTERPRETER EXECUTIVE AND CONTROL PROCEDURES . . . 1495

;              BASE. . . . . . . . . . . . . . . . . . . . . . 1499

;              GOTG. . . . . . . . . . . . . . . . . . . . . . 1508

;              GOTL. . . . . . . . . . . . . . . . . . . . . . 1519

;              GOTO. . . . . . . . . . . . . . . . . . . . . . 1553

;              INIT. . . . . . . . . . . . . . . . . . . . . . 1562

;              INTERP. . . . . . . . . . . . . . . . . . . . . 1582

;              INVOKE. . . . . . . . . . . . . . . . . . . . . 1600

;      8.   ARGUMENT EVALUATION PROCEDURES . . . . . . . . . . 1610

;              ARGVAL. . . . . . . . . . . . . . . . . . . . . 1614

;              EXPVAL. . . . . . . . . . . . . . . . . . . . . 1633

;              EXPEVL. . . . . . . . . . . . . . . . . . . . . 1681

;              EVAL. . . . . . . . . . . . . . . . . . . . . . 1685

;              INTVAL. . . . . . . . . . . . . . . . . . . . . 1704

;              PATVAL. . . . . . . . . . . . . . . . . . . . . 1728

;              VARVAL. . . . . . . . . . . . . . . . . . . . . 1762

;              XYARGS. . . . . . . . . . . . . . . . . . . . . 1784

;      9.   ARITHMETIC OPERATIONS, PREDICATES AND FUNCTIONS. . 1812

;              ADD . . . . . . . . . . . . . . . . . . . . . . 1813

;              DIV . . . . . . . . . . . . . . . . . . . . . . 1817

;              EXP . . . . . . . . . . . . . . . . . . . . . . 1821

;              MPY . . . . . . . . . . . . . . . . . . . . . . 1825

;              SUB . . . . . . . . . . . . . . . . . . . . . . 1829

;              EQ. . . . . . . . . . . . . . . . . . . . . . . 1833

;              GE. . . . . . . . . . . . . . . . . . . . . . . 1837

;              GT. . . . . . . . . . . . . . . . . . . . . . . 1841

;              LE. . . . . . . . . . . . . . . . . . . . . . . 1845

;              LT. . . . . . . . . . . . . . . . . . . . . . . 1849

;              NE. . . . . . . . . . . . . . . . . . . . . . . 1853

;              REMDR . . . . . . . . . . . . . . . . . . . . . 1857

;              INTGER. . . . . . . . . . . . . . . . . . . . . 1966

;              MNS . . . . . . . . . . . . . . . . . . . . . . 1978

;              PLS . . . . . . . . . . . . . . . . . . . . . . 1997

;      10.   PATTERN-VALUED FUNCTIONS AND OPERATIONS . . . . . 2008

;              ANY . . . . . . . . . . . . . . . . . . . . . . 2009

;              BREAK . . . . . . . . . . . . . . . . . . . . . 2013

;              NOTANY. . . . . . . . . . . . . . . . . . . . . 2018

;              SPAN. . . . . . . . . . . . . . . . . . . . . . 2022

;              LEN . . . . . . . . . . . . . . . . . . . . . . 2036

;              POS . . . . . . . . . . . . . . . . . . . . . . 2040

;              RPOS. . . . . . . . . . . . . . . . . . . . . . 2044

;              RTAB. . . . . . . . . . . . . . . . . . . . . . 2048

;              TAB . . . . . . . . . . . . . . . . . . . . . . 2052

;              ARBNO . . . . . . . . . . . . . . . . . . . . . 2070

;              ATOP (CURSOR POSITION). . . . . . . . . . . . . 2097

;              NAM (VALUE ASSIGNMENT). . . . . . . . . . . . . 2111

;              OR. . . . . . . . . . . . . . . . . . . . . . . 2161

;      11.  PATTERN MATCHING PROCEDURES. . . . . . . . . . . . 2205

;              SCAN. . . . . . . . . . . . . . . . . . . . . . 2209

;              SJSR (SCAN AND REPLACE) . . . . . . . . . . . . 2255

;              SCNR (BASIC SCANNER). . . . . . . . . . . . . . 2404

;              ANYC. . . . . . . . . . . . . . . . . . . . . . 2509

;              BRKC. . . . . . . . . . . . . . . . . . . . . . 2543

;              NNYC. . . . . . . . . . . . . . . . . . . . . . 2557

;              SPNC. . . . . . . . . . . . . . . . . . . . . . 2571

;              LNTH. . . . . . . . . . . . . . . . . . . . . . 2598

;              POSI. . . . . . . . . . . . . . . . . . . . . . 2654

;              RPSI. . . . . . . . . . . . . . . . . . . . . . 2658

;              RTB . . . . . . . . . . . . . . . . . . . . . . 2662

;              TB. . . . . . . . . . . . . . . . . . . . . . . 2666

;              ARBN (ARBNO). . . . . . . . . . . . . . . . . . 2674

;              FARB (ARB BACKUP) . . . . . . . . . . . . . . . 2710

;              ATP (CURSOR POSITION) . . . . . . . . . . . . . 2733

;              BAL . . . . . . . . . . . . . . . . . . . . . . 2766

;              STAR (UNEVALUATED EXPRESSION) . . . . . . . . . 2812

;              FNCE. . . . . . . . . . . . . . . . . . . . . . 2883

;              NME (VALUE ASSIGNMENT). . . . . . . . . . . . . 2900

;              ENMI (IMMEDIATE VALUE ASSIGNMENT) . . . . . . . 2962

;              SUCE (SUCCEED). . . . . . . . . . . . . . . . . 3016

;      12.  DEFINED FUNCTIONS. . . . . . . . . . . . . . . . . 3035

;              DEFINE. . . . . . . . . . . . . . . . . . . . . 3039

;              DEFFNC (INVOKE DEFINED FUNCTION). . . . . . . . 3106

;      13.  EXTERNAL FUNCTIONS . . . . . . . . . . . . . . . . 3266

;              LOAD. . . . . . . . . . . . . . . . . . . . . . 3270

;              UNLOAD. . . . . . . . . . . . . . . . . . . . . 3345

;              LNKFNC (LINK TO EXTERNAL FUNCTION). . . . . . . 3357

;      14.  ARRAYS, TABLES, AND DEFINED DATA OBJECTS . . . . . 3430

;              ARRAY . . . . . . . . . . . . . . . . . . . . . 3434

;              ASSOC (TABLE) . . . . . . . . . . . . . . . . . 3504

;              DATDEF (DATA) . . . . . . . . . . . . . . . . . 3534

;              PROTO . . . . . . . . . . . . . . . . . . . . . 3594

;              ITEM (ARRAY AND TABLE REFERENCES) . . . . . . . 3604

;              DEFDAT (CREATE DATA OBJECT) . . . . . . . . . . 3686

;              FIELD . . . . . . . . . . . . . . . . . . . . . 3735

;      15.  INPUT AND OUTPUT . . . . . . . . . . . . . . . . . 3752

;              READ (INPUT). . . . . . . . . . . . . . . . . . 3756

;              PRINT (OUTPUT). . . . . . . . . . . . . . . . . 3789

;              BKSPCE. . . . . . . . . . . . . . . . . . . . . 3821

;              ENFILE. . . . . . . . . . . . . . . . . . . . . 3825

;              REWIND. . . . . . . . . . . . . . . . . . . . . 3829

;              DETACH. . . . . . . . . . . . . . . . . . . . . 3850

;              PUTIN . . . . . . . . . . . . . . . . . . . . . 3866

;              PUTOUT. . . . . . . . . . . . . . . . . . . . . 3890

;      16.  TRACING PROCEDURES AND FUNCTIONS . . . . . . . . . 3907

;              TRACE . . . . . . . . . . . . . . . . . . . . . 3911

;              STOPTR. . . . . . . . . . . . . . . . . . . . . 3965

;              FENTR (CALL TRACING). . . . . . . . . . . . . . 3993

;              KEYTR . . . . . . . . . . . . . . . . . . . . . 4062

;              TRPHND (TRACE HANDLER). . . . . . . . . . . . . 4100

;              VALTR . . . . . . . . . . . . . . . . . . . . . 4125

;      17.  OTHER OPERATIONS . . . . . . . . . . . . . . . . . 4205

;              ASGN (=). . . . . . . . . . . . . . . . . . . . 4209

;              CON (CONCATENATION) . . . . . . . . . . . . . . 4254

;              IND (INDIRECT REFERENCE). . . . . . . . . . . . 4346

;              KEYWRD. . . . . . . . . . . . . . . . . . . . . 4360

;              LIT . . . . . . . . . . . . . . . . . . . . . . 4385

;              NAME. . . . . . . . . . . . . . . . . . . . . . 4394

;              NMD (VALUE ASSIGNMENT). . . . . . . . . . . . . 4406

;              STR (UNEVALUATED EXPRESSION). . . . . . . . . . 4446

;      18.  OTHER PREDICATES . . . . . . . . . . . . . . . . . 4453

;              DIFFER. . . . . . . . . . . . . . . . . . . . . 4457

;              IDENT . . . . . . . . . . . . . . . . . . . . . 4466

;              LGT . . . . . . . . . . . . . . . . . . . . . . 4475

;              NEG (>) . . . . . . . . . . . . . . . . . . . . 4491

;              QUES (?). . . . . . . . . . . . . . . . . . . . 4502

;      19.  OTHER PRIMITIVE FUNCTIONS. . . . . . . . . . . . . 4507

;              APPLY . . . . . . . . . . . . . . . . . . . . . 4511

;              ARG . . . . . . . . . . . . . . . . . . . . . . 4530

;              LOCAL . . . . . . . . . . . . . . . . . . . . . 4539

;              FIELDS. . . . . . . . . . . . . . . . . . . . . 4544

;              CLEAR . . . . . . . . . . . . . . . . . . . . . 4581

;              COLLECT . . . . . . . . . . . . . . . . . . . . 4597

;              COPY. . . . . . . . . . . . . . . . . . . . . . 4607

;              CONVERT . . . . . . . . . . . . . . . . . . . . 4626

;              DATE. . . . . . . . . . . . . . . . . . . . . . 4795

;              DATATYPE. . . . . . . . . . . . . . . . . . . . 4804

;              DUMP. . . . . . . . . . . . . . . . . . . . . . 4820

;              DUPL. . . . . . . . . . . . . . . . . . . . . . 4885

;              OPSYN . . . . . . . . . . . . . . . . . . . . . 4907

;              REPLACE . . . . . . . . . . . . . . . . . . . . 4977

;              SIZE. . . . . . . . . . . . . . . . . . . . . . 5002

;              TIME. . . . . . . . . . . . . . . . . . . . . . 5013

;              TRIM. . . . . . . . . . . . . . . . . . . . . . 5024

;      20.  COMMON CODE. . . . . . . . . . . . . . . . . . . . 5031

;      21.  TERMINATION. . . . . . . . . . . . . . . . . . . . 5071

;              END . . . . . . . . . . . . . . . . . . . . . . 5072

;              FTLEND. . . . . . . . . . . . . . . . . . . . . 5078

;              SYSCUT. . . . . . . . . . . . . . . . . . . . . 5134

;      22.  ERROR HANDLING . . . . . . . . . . . . . . . . . . 5139

;      23.  DATA . . . . . . . . . . . . . . . . . . . . . . . 5258

;              PAIR LISTS. . . . . . . . . . . . . . . . . . . 5259

;              DATA TYPE PAIRS . . . . . . . . . . . . . . . . 5381

;              SWITCHES. . . . . . . . . . . . . . . . . . . . 5410

;              CONSTANTS . . . . . . . . . . . . . . . . . . . 5423

;              POINTERS TO PATTERNS. . . . . . . . . . . . . . 5454

;              FUNCTION DESCRIPTORS. . . . . . . . . . . . . . 5461

;              MISCELLANEOUS DATA. . . . . . . . . . . . . . . 5502

;              PROGRAM POINTERS. . . . . . . . . . . . . . . . 5543

;              POINTERS TO SPECIFIERS. . . . . . . . . . . . . 5552

;              PERMANENT PAIR LIST POINTERS. . . . . . . . . . 5560

;              SPECIFIERS FOR COMPILATION. . . . . . . . . . . 5566

;              STRINGS AND SPECIFIERS. . . . . . . . . . . . . 5576

;              CHARACTER BUFFERS . . . . . . . . . . . . . . . 5611

;              POINTERS TO PAIR LISTS. . . . . . . . . . . . . 5620

;              SCRATCH DESCRIPTORS . . . . . . . . . . . . . . 5635

;              SYSTEM DESCRIPTORS. . . . . . . . . . . . . . . 5670

;              COMPILER DESCRIPTORS. . . . . . . . . . . . . . 5683

;              DATA POINTERS . . . . . . . . . . . . . . . . . 5701

;              SPECIFIERS. . . . . . . . . . . . . . . . . . . 5711

;              ALLOCATOR DATA. . . . . . . . . . . . . . . . . 5725

;              MACHINE DEPENDENT DATA. . . . . . . . . . . . . 5773

;              FUNCTION TABLE. . . . . . . . . . . . . . . . . 5779

;              FUNCTION PAIR LIST. . . . . . . . . . . . . . . 5911

;              FUNCTION INITIALIZATION DATA. . . . . . . . . . 6161

;              POINTERS TO INITIALIZATION DATA . . . . . . . . 6258

;              SYSTEM ARRAYS . . . . . . . . . . . . . . . . . 6280

;              STRING STORAGE BIN LIST . . . . . . . . . . . . 6304

;              PATTERN-MATCHING HISTORY LIST . . . . . . . . . 6311

;              SYSTEM STACK. . . . . . . . . . . . . . . . . . 6316

;              PRIMITIVE PATTERNS. . . . . . . . . . . . . . . 6321

;              CODE SKELETON FOR TRACE . . . . . . . . . . . . 6414

;              FATAL ERROR MESSAGE POINTERS. . . . . . . . . . 6448

;              FATAL ERROR MESSAGES. . . . . . . . . . . . . . 6480

;              COMPILER ERROR MESSAGES . . . . . . . . . . . . 6511

;              FORMATS . . . . . . . . . . . . . . . . . . . . 6524

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

;

	TITLE	'LINKAGE AND EQUIVALENCES'

	COPY	MLINK	;LINKAGE SEGMENT

	COPY	PARMS	;MACHINE-DEPENDENT PARAMETERS

;

;      CONSTANTS

;

ATTRIB=2*DESCR			;OFFSET OF LABEL IN STRING STRUCTURE

LNKFLD=3*DESCR			;OFFSET OF LINK IN STRING STRUCTURE

BCDFLD=4*DESCR			;OFFSET OF STRING IN STRING STRUCTURE

FATHER=DESCR			;OFFSET OF FATHER IN CODE NODE

LSON=2*DESCR			;OFFSET OF LEFT SON IN CODE NODE

RSIB=3*DESCR			;OFFSET OF RIGHT SIBLING IN CODE NODE

CODE=4*DESCR			;OFFSET OF CODE IN CODE NODE

ESASIZ=50			;LIMIT ON NUMBER OF SYNTACTIC ERRORS

FBLKSZ=10*DESCR			;SIZE OF FUNCTION DESCRIPTOR BLOCK

ARRLEN=20			;LIMIT ON LENGTH OF ARRAY PRINT IMAGE

CARDSZ=80			;WIDTH OF COMPILER INPUT

SEQSIZ=8			;WIDTH OF SEQUENCE FIELD

STNOSZ=8			;LENGTH OF STATEMENT NUMBER FIELD

DSTSZ=2*STNOSZ			;SPACE FOR LEFT AND RIGHT NUMBERING

CNODSZ=4*DESCR			;SIZE OF CODE NODE

DATSIZ=1000			;LIMIT ON NUMBER OF DEFINED DATA TYPE

EXTSIZ=10			;DEFAULT ALLOCATION FOR TABLES

NAMLSZ=20			;GROWTH QUANTUM FOR NAME LIST

NODESZ=3*DESCR			;SIZE OF PATTERN NODE

OBSIZ=256			;NUMBER OF BIN HEADERS

OBARY=OBSIZ+3			;TOTAL NUMBER FOR BINS

OCASIZ=1500			;DESCRIPTORS OF INITIAL OBJECT CODE

SPDLSZ=1000			;DESCRIPTORS OF PATTERN STACK

STSIZE=1000			;DESCRIPTORS OF INTERPRETER STACK

SPDR=SPEC+DESCR			;DESCRIPTOR PLUS SPECIFIER

OBOFF=OBSIZ-2			;OFFSET LENGTH IN BINS

SPDLDR=SPDLSZ*DESCR			;SIZE OF PATTERN STACK

MAXFRE=^D15000	;15K MAX PRE EXPANSION

;

;      EQUIVALENCES

;

ARYTYP=7			;ARRAY REFERENCE

CLNTYP=5			;GOTO FIELD

CMATYP=2			;COMMA

CMTTYP=2			;COMMENT CARD

CNTTYP=4			;CONTINUE CARD

CTLTYP=3			;CONTROL CARD

DIMTYP=1			;DIMENSION SEPARATOR

EOSTYP=6			;END OF STATEMENT

EQTYP=4			;EQUAL SIGN

FGOTYP=3			;FAILURE GOTO

FTOTYP=6			;FAILURE DIRECT GOTO

FLITYP=6			;LITERAL REAL

FNCTYP=5			;FUNCTION CALL

ILITYP=2			;LITERAL INTEGER

LPTYP=1			;LEFT PARENTHESIS

NBTYP=1			;NONBREAK CHARACTER

NEWTYP=1			;NEW STATEMENT

NSTTYP=4			;PARENTHESIZED EXPRESSION

QLITYP=1			;QUOTED LITERAL

RBTYP=7			;RIGHT BRACKET

RPTYP=3			;RIGHT PARENTHESIS

SGOTYP=2			;SUCCESS GOTO

STOTYP=5			;SUCCESS DIRECT GOTO

UGOTYP=1			;UNCONDITIONAL GOTO

UTOTYP=4			;UNCONDITIONAL DIRECT GOTO

VARTYP=3			;VARIABLE

;

;      DATA TYPE CODES

;

A=4			;ARRAY

B=2			;BLOCK (INTERNAL)

C=8			;CODE

E=11			;EXPRESSION

I=6			;INTEGER

K=10			;KEYWORD (NAME)

L=12			;LINKED STRING (INTERNAL)

N=9			;NAME

P=3			;PATTERN

R=7			;REAL

S=1			;STRING

T=5			;TABLE

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'PROGRAM INITIALIZATION'

BEGIN:	INIT	,	;INITIALIZE SYSTEM

	ISTACK	,	;INITIALIZE STACK

;""""""""""""""""""""""""""""""""""""""""""""""""""""""2

	SKIPE UNFLAG
	JRST BEGIN1	;SKIP TITLEF IF /U

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

	OUTPUX	OUTPUT,TITLEF	;TITLE LISTING

	OUTPUX	OUTPUT,SOURCF	;PRINT ATTRIBUTION

BEGIN1:

	MSTIME	TIMECL	;TIME IN COMPILER

	RCALL	SCBSCL,BLOCK,OCALIM	;ALLOCATE BLOCK FOR OBJECT CODE

	MOVD	OCSVCL,SCBSCL	;SAVE OBJECT CODE POINTER

	RESETF	SCBSCL,PTR	;CLEAR POINTER FLAG

	GETSIZ	YCL,INITLS	;GET SIZE OF INITIALIZATION LIST

SPCNVT:	GETD	XPTR,INITLS,YCL	;GET POINTER TO LIST

	GETSIZ	XCL,XPTR	;GET SIZE OF LIST

SPCNV1:	GETD	ZPTR,XPTR,XCL	;GET POINTER TO SPECIFIER

	AEQLC	ZPTR,0,,SPCNV2	;SKIP DUMMY ZERO ENTRIES

	RCALL	ZPTR,GENVAR,ZPTR	;CONVERT SPECIFIER TO STRUCTURE

	PUTD	XPTR,XCL,ZPTR	;REPLACE POINTER TO SPECIFIER

SPCNV2:	DECRA	XCL,2*DESCR	;DECREMENT TO NEXT PAIR

	ACOMPC	XCL,0,SPCNV1	;CONTINUE IF ONE REMAINS

	DECRA	YCL,DESCR	;DECREMENT TO NEXT LIST

	ACOMPC	YCL,0,SPCNVT	;CONTINUE IF ONE REMAINS

INITD1:	GETDC	XPTR,INITB,0	;GET SPECIFIER TO CONVERT

	RCALL	YPTR,GENVAR,<XPTR>	;CONVERT IT TO STRING STRUCTURE

	GETDC	ZPTR,INITB,DESCR	;GET LOCATION TO PUT IT

	PUTDC	ZPTR,0,YPTR	;PLACE POINTER TO STRING STRUCTURE

	INCRA	INITB,2*DESCR	;DECREMENT TO NEXT PAIR

	ACOMP	INITB,INITE,,,INITD1

;                                  COMPARE WITH END

;

	PUTDC	ABRTKY,DESCR,ABOPAT	;INITIAL VALUE OF ABORT

	PUTDC	ARBKY,DESCR,ARBPAT	;INITIAL VALUE OF ARB

	PUTDC	BALKY,DESCR,BALPAT	;INITIAL VALUE OF BAL

	PUTDC	FAILKY,DESCR,FALPAT	;INITIAL VALUE OF FAIL

	PUTDC	FNCEKY,DESCR,FNCPAT	;INITIAL VALUE OF FENCE

	PUTDC	REMKY,DESCR,REMPAT	;INITIAL VALUE OF REM

	PUTDC	SUCCKY,DESCR,SUCPAT	;INITIAL VALUE OF SUCCEED

;

	SETAC	VARSYM,0	;SET COUNT OF VARIABLES TO ZERO

	RCALL	NBSPTR,BLOCK,NMOVER	;ALLOCATE BLOCK FOR VALUE ASSIGNMENT

	MOVD	CMBSCL,SCBSCL	;SET UP POINTER FOR COMPILER

	MOVD	UNIT,INPUT	;SET UP INPUT UNIT

	MOVD	OCBSCL,CMBSCL	;PROJECT BASE FOR INTERPRETER

	SUM	OCLIM,CMBSCL,OCALIM	;COMPUTE END OF CODE BLOCK

	DECRA	OCLIM,5*DESCR	;LEAVE ROOM FOR OVERFLOW

	BRANCH	XLATRN

;_

;""""""""""""""""""""""""""""""""""""""""""""""""""""""

XWADE1:	PUSHJ PDP,EOF	;SPECIAL EOF HANDLING ON SOURCE INPUT
	JRST XLATRN

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'COMPILATION AND INTERPRETER INVOCATION'

XLATRD:	AEQLC	LISTCL,0,,XLATRN	;SKIP PRINT IF LIST IS OFF

	STPRNT	IOKEY,OUTBLK,LNBFSP	;PRINT LINE IMAGE

XLATRN:	STREAD	INBFSP,UNIT,XWADE1,COMP5

	SETSP	TEXTSP,NEXTSP	;READ CARD AND SET UP LINE

	STREAM	XSP,TEXTSP,CARDTB,COMP3,COMP3

;                                  DETERMINE TYPE OF CARD

	RCALL	,NEWCRD,,<XLATRD,XCROCK,XCROCK>	;PROCESS CARD TYPE
; XCROCK LABELS WERE ADDED IN THE ABOVE CALL BECAUSE 
; MACRO.41 GENERATED A JRST 0 FOR THE LAST NULL ARGUMENT
; INSTEAD OF AN EFFECTIVE JRST .+1

XCROCK:


XLATNX:	RCALL	,CMPILE,,<COMP3,,XLATNX>

;                                  COMPILE STATEMENT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,ENDCL	;INSERT END FUNCTION

	AEQLC	LISTCL,0,,XLATP	;SKIP PRINT IF LIST IS OFF

	STPRNT	IOKEY,OUTBLK,LNBFSP	;PRINT LAST LINE IMAGE

XLATP:	AEQLC	STYPE,EOSTYP,,XLAEND

;                                  FINISH ON END OF STATEMENT

	STREAM	XSP,TEXTSP,IBLKTB,COMP3,XLAEND

;                                  ANALYZE END CARD

	AEQLC	STYPE,EOSTYP,,XLAEND

;                                  FINISH ON END OF STATEMENT

	AEQLC	STYPE,NBTYP,COMP7	;ERROR IF BREAK CHARACTER

	STREAM	XSP,TEXTSP,LBLTB,COMP7,COMP7

;                                  ANALYZE END LABEL

	RCALL	XPTR,GENVAR,<XSPPTR>

;                                  GENERATE VARIABLE FOR LABEL

	GETDC	OCBSCL,XPTR,ATTRIB	;GET START FOR INTERPRETER

	AEQLC	OCBSCL,0,,COMP7	;ERROR IF NOT ATTRIBUTE

	AEQLC	STYPE,EOSTYP,,XLAEND

;                                  FINISH ON END OF STATEMENT

	STREAM	XSP,TEXTSP,IBLKTB,COMP7,,COMP7

;                                  ANALYZE REMAINDER OF CARD

XLAEND:	AEQLC	ESAICL,0,,XLATSC	;WERE THERE ANY COMPILATION ERRORS?

	OUTPUX	OUTPUT,ERRCF	;PRINT MESSAGE OF ERRORS

	BRANCH	XLATND

;_

XLATSC:	OUTPUX	OUTPUT,SUCCF	;PRINT MESSAGE OF NO ERRORS

XLATND:	SETAC	UNIT,0	;RESET INPUT UNIT

	SETAC	LPTR,0	;RESET LAST LABEL POINTER

	SETAC	OCLIM,0	;RESET LIMIT ON OBJECT CODE

	ZERBLK	COMREG,COMDCT	;CLEAR COMPILER DESCRIPTORS

	SUM	XCL,CMBSCL,CMOFCL	;COMPUTE END OF OBJECT CODE

	RCALL	,SPLIT,<XCL>	;SPLIT OF UNUSED PART OF BLOCK

	SETAC	LISTCL,0	;TURN OFF LISTING SWITCH

	MSTIME	ETMCL	;TIME OUT COMPILER

	SUBTRT	TIMECL,ETMCL,TIMECL	;COMPUTE ELAPSED TIME

	SETAC	CNSLCL,1	;PERMIT LABEL REDEFINITION

	RCALL	,INTERP,,<MAIN1,MAIN1,MAIN1>

;                                  CALL INTERPRETER

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'SUPPORT PROCEDURES'

;

;      AUGMENTATION OF PAIR LISTS

;

AUGATL:	PROC	,	;PROCEDURE TO AUGMENT PAIR LISTS

	POP	<A1PTR,A2PTR,A3PTR>	;LIST, TYPE AND VALUE

	LOCAPT	A4PTR,A1PTR,ZEROCL,AUG1

;                                  LOOK FOR HOLE IN LIST

	PUTDC	A4PTR,DESCR,A2PTR	;INSERT TYPE DESCRIPTOR

	PUTDC	A4PTR,2*DESCR,A3PTR	;INSERT VALUE DESCRIPTOR

	MOVD	A5PTR,A1PTR	;SET UP RETURN POINTER

	BRANCH	A5RTN	;RETURN PAIR LIST

;_

AUG1:	GETSIZ	A4PTR,A1PTR	;GET SIZE OF PRESENT LIST

	INCRA	A4PTR,2*DESCR	;ADD TWO MORE DESCRIPTORS

	SETVC	A4PTR,B	;INSERT BLOCK DATA TYPE

	RCALL	A5PTR,BLOCK,A4PTR	;ALLOCATE NEW BLOCK

	PUTD	A5PTR,A4PTR,A3PTR	;INSERT VALUE DESCRIPTOR AT END

	DECRA	A4PTR,DESCR	;DECREMENT

	PUTD	A5PTR,A4PTR,A2PTR	;INSERT TYPE DESCRIPTOR ABOVE

AUGMOV:	DECRA	A4PTR,DESCR	;ADJUST SIZE

	MOVBLK	A5PTR,A1PTR,A4PTR	;COPY OLD LIST AT TOP

	BRANCH	A5RTN	;RETURN NEW LIST

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      CODE SKIPPING PROCEDURE

;

CODSKP:	PROC	,	;PROCEDURE TO SKIP OBJECT CODE

	POP	YCL	;RESTORE NUMBER OF ITEMS TO SKIP

CODCNT:	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XCL,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XCL,FNC,,CODFNC	;CHECK FOR FUNCTION

CODECR:	DECRA	YCL,1	;COUNT DOWN

	ACOMPC	YCL,0,CODCNT,RTN1,INTR10

;                                  CHECK FOR END

;_

CODFNC:	PUSH	YCL	;SAVE NUMBER TO SKIP

	SETAV	YCL,XCL	;GET ARGUMENTS TO SKIP

	RCALL	,CODSKP,<YCL>	;CALL SELF RECURSIVELY

	POP	YCL	;RESTORE NUMBER TO SKIP

	BRANCH	CODECR	;GO AROUND AGAIN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DATA TYPE REPRESENTATION

;

DTREP:	PROC	,	;PROCEDURE TO REPRESENT DATA TYPE

	POP	A2PTR	;RESTORE OBJECT

	VEQLC	A2PTR,A,,DTARRY	;IS IS ARRAY?

	VEQLC	A2PTR,T,,DTABLE	;IS IT TABLE?

	VEQLC	A2PTR,R,DTREP1	;IS IT REAL?

	REALST	DPSP,A2PTR	;CONVERT REAL TO STRING

	BRANCH	DTREPR	;JOIN END PROCESSING

;_

DTARRY:	GETDC	A3PTR,A2PTR,DESCR	;GET PROTOTYPE

	LOCSPX	ZSP,A3PTR	;GET SPECIFIER

	GETLG	A3PTR,ZSP	;GET LENGTH

	ACOMPC	A3PTR,ARRLEN,DTREP1	;CHECK FOR EXCESSIVE LENGTH

	SETLC	DTARSP,0	;CLEAR SPECIFIER

	APDSP	DTARSP,ARRSP	;APPEND ARRAY

	APDSP	DTARSP,LPRNSP	;APPEND '('

	APDSP	DTARSP,QTSP	;APPEND QUOTE

	APDSP	DTARSP,ZSP	;APPEND PROTOTYPE

	APDSP	DTARSP,QTSP	;APPEND QUOTE

DTARTB:	APDSP	DTARSP,RPRNSP	;APPEND ')'

	SETSP	DPSP,DTARSP	;MOVE SPECIFIER

	BRANCH	DTREPR	;RETURN

;_

;VERSION 3.3 CHANGE
DTABLE:	GETSIZ A3PTR,A2PTR
	GETD A1PTR,A2PTR,A3PTR
	DECRA A3PTR,DESCR
	GETD A2PTR,A2PTR,A3PTR
DTABL1:	AEQLC A1PTR,1,,DTABL2
	SUM A3PTR,A3PTR,A2PTR
	DECRA A3PTR,2*DESCR
	GETD A1PTR,A1PTR,A2PTR
	BRANCH DTABL1
;_
DTABL2:	DECRA A3PTR,DESCR
	DECRA A2PTR,2*DESCR
;VERSION 3.3 CHANGE END
	DIVIDE	A3PTR,A3PTR,DSCRTW	;DIVIDE TO GET ITEM COUNT

	INTSPC	ZSP,A3PTR	;CONVERT TO STRING

	SETLC	DTARSP,0	;CLEAR SPECIFIER

	APDSP	DTARSP,ASSCSP	;APPEND TABLE

	APDSP	DTARSP,LPRNSP	;APPEND '('

	APDSP	DTARSP,ZSP	;APPEND SIZE

	APDSP	DTARSP,CMASP	;APPEND COMMA

;VERSION 3.3 CHANGE
	DIVIDE A2PTR,A2PTR,DSCRTW
	INTSPC ZSP,A2PTR
;VERSION 3.3 CHANGE END
	APDSP	DTARSP,ZSP	;APPEND EXTENT

	BRANCH	DTARTB	;JOIN COMMON PROCESSING

;_

DTREP1:	MOVV	DT1CL,A2PTR	;INSERT DATA TYPE

	LOCAPT	A3PTR,DTATL,DT1CL,DTREPE

;                                  LOOK FOR DATA TYPE NAME

	GETDC	A3PTR,A3PTR,2*DESCR	;GET DATA TYPE NAME

	LOCSPX	DPSP,A3PTR	;GET SPECIFIER

DTREPR:	RRTURN	DPSPTR,1	;RETURN POINTER TO SPECIFIER

;_

DTREPE:	SETSP	DPSP,EXDTSP	;SET UP EXTERNAL SPECIFIER

	BRANCH	DTREPR	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      LOCATION OF FUNCTION DESCRIPTOR

;

FINDEX:	PROC	,	;PROCEDURE TO GET FUNCTION DESCRIPTOR

	POP	F1PTR	;RESTORE NAME

	LOCAPV	F2PTR,FNCPL,F1PTR,FATNF

;                                  LOOK FOR FUNCTION PAIR

	GETDC	F2PTR,F2PTR,DESCR	;GET FUNCTION DESCRIPTOR

FATBAK:	RRTURN	F2PTR,1	;RETURN

;_

FATNF:	INCRA	NEXFCL,2*DESCR	;INCREMENT FUNCTION BLOCK OFFSET

	ACOMPC	NEXFCL,FBLKSZ,FATBLK

;                                  CHECK FOR END

FATNXT:	SUM	F2PTR,FBLOCK,NEXFCL	;COMPUTE POSITION

	RCALL	FNCPL,AUGATL,<FNCPL,F2PTR,F1PTR>

;                                  AUGMENT FUNCTION PAIR LIST

	PUTDC	F2PTR,0,UNDFCL	;INSERT UNDEFINED FUNCTION

	PUTDC	F2PTR,DESCR,F1PTR	;INSERT NAME

	BRANCH	FATBAK	;JOIN RETURN

;_

FATBLK:	RCALL	FBLOCK,BLOCK,FBLKRQ	;ALLOCATE NEW FUNCTION BLOCK

	SETF	FBLOCK,FNC	;INSERT FUNCTION FLAG

	SETVC	FBLOCK,0	;CLEAR DATA TYPE

	SETAC	NEXFCL,DESCR	;INITIALIZE OFFSET

	BRANCH	FATNXT	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'STORAGE ALLOCATION AND REFENERATION PROCEDURES'

;

;      ALLOCATION OF BLOCK

;

BLOCK:	PROC	,	;PROCEDURE TO ALLOCATE BLOCKS

	POP	ARG1CL	;RESTORE SIZE TO ALLOCATE

	ACOMP	ARG1CL,SIZLMT,SIZERR,SIZERR

;                                  CHECK AGAINST SIZE LIMIT

BLOCK1:	MOVD	BLOCL,FRSGPT	;POSITION POINTER TO TITLE

	MOVV	BLOCL,ARG1CL	;MOVE DATA TYPE

	INCRA	FRSGPT,DESCR	;LEAVE ROOM FOR TITLE

	SUM	FRSGPT,FRSGPT,ARG1CL

;                                  MOVE POSITION POINTER PAST END

	ACOMP	TLSGP1,FRSGPT,,,BLOGC

;                                  CHECK FOR END OF REGION

	ZERBLK	BLOCL,ARG1CL	;CLEAR BLOCK

	PUTAC	BLOCL,0,BLOCL	;SET UP SELF-POINTER IN TITLE

	SETFI	BLOCL,TTL	;INSERT TITLE FLAG

	SETSIZ	BLOCL,ARG1CL	;INSERT BLOCK SIZE

	RRTURN	BLOCL,1	;RETURN POINTER TO BLOCK

;_

BLOGC:	MOVA	FRSGPT,BLOCL	;RESTORE POSITION POINTER

	RCALL	,GC,<ARG1CL>,<ALOC2,BLOCK1>

;                                  REGENERATE STORAGE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      GENERATION OF NATURAL VARIABLES

;

GENVAR:	PROC	,	;PROCEDURE TO GENERATE VARIABLE

	SETAC	CONVSW,0	;NOTE GENVAR ENTRY

	POP	AXPTR	;RESOTRE POINTER TO SPECIFIER

	GETSPC	SPECR1,AXPTR,0	;GET SPECIFIER

	LEQLC	SPECR1,0,,RT1NUL	;AVOID NULL STRING

LOCA1:	VARID	EQUVCL,SPECR1	;COMPUTE BIN AND ASCENSION NUMBERS

	SUM	BUKPTR,OBPTR,EQUVCL	;FIND BIN

LOCA2:	MOVD	LSTPTR,BUKPTR	;SAVE WORKING COPY

	GETAC	BUKPTR,BUKPTR,LNKFLD

;                                  GET LINK DESCRIPTOR

	AEQLC	BUKPTR,0,,LOCA5	;CHECK FOR END OF CHAIN

	VCMPIC	BUKPTR,LNKFLD,EQUVCL,LOCA5,,LOCA2

;                                  COMPARE ASCENSION NUMBERS

	LOCSPX	SPECR2,BUKPTR	;GET SPECIFIER TO STRING IN STORAGE

	LEXCMP	SPECR1,SPECR2,LOCA2,,LOCA2

;                                  COMPARE STRINGS

	MOVD	LCPTR,BUKPTR	;RETURN STRING IN STORAGE

	BRANCH	LOCRET

;_

LOCA5:	GETLG	AXPTR,SPECR1	;GET LENGTH OF STRING

	GETLTH	BKLTCL,AXPTR	;COMPUTE SPACE REQUIRED

	ACOMP	BKLTCL,SIZLMT,SIZERR

;                                  CHECK AGAINST SIZE LIMIT

LOCA7:	MOVD	LCPTR,FRSGPT	;POINT TO POSITION IN STORAGE

	SETVC	LCPTR,S	;SET DATA TYPE TO STRING

	INCRA	FRSGPT,DESCR	;LEAVE SPACE FOR TITLE

	SUM	FRSGPT,FRSGPT,BKLTCL

;                                  SKIP REQUIRED SPACE

	ACOMP	TLSGP1,FRSGPT,,,LOCA4

;                                  CHECK FOR END OF REGION

	PUTDC	LCPTR,0,ZEROCL	;CLEAR TITLE

	PUTAC	LCPTR,0,LCPTR	;POINT TITLE TO SELF

	SETFI	LCPTR,TTL+STTL	;SET STRING AND TITLE FLAGS

	SETSIZ	LCPTR,AXPTR	;INSERT SIZE OF STRING

	AEQLC	CONVSW,0,LOCA6	;CHECK FOR GENVAR ENTRY

	PUTDC	LCPTR,DESCR,NULVCL	;SET VALUE TO NULL STRING

	PUTDC	LCPTR,ATTRIB,ZEROCL	;SET LABEL ATTRIBUTE TO ZERO

	LOCSPX	SPECR2,LCPTR	;GET SPECIFIER TO STRING STRUCTURE

	SETLC	SPECR2,0	;CLEAR LENGTH

	APDSP	SPECR2,SPECR1	;MOVE NEW STRING IN

LOCA6:	PUTVC	LCPTR,LNKFLD,EQUVCL	;INSERT ASCENSION NUMBER

	PUTAC	LCPTR,LNKFLD,BUKPTR	;INSERT LINK POINTER

	PUTAC	LSTPTR,LNKFLD,LCPTR	;LINK TO LAST STRUCTURE

	INCRA	VARSYM,1	;INCREMENT COUNT OF NEW VARIABLES

LOCRET:	RRTURN	LCPTR,1	;RETURN POINTER TO STRUCTURE

;_

LOCA4:	MOVA	FRSGPT,LCPTR	;RESTORE POSITION POINTER

	RCALL	,GC,<BKLTCL>,<ALOC2,LOCA7>

;                                  REGENERATE STORAGE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      GENERATION OF VARIABLE FROM INTEGER

;

GNVARI:	PROC	GENVAR	;PROCEDURE TO GENERATE STRING

	SETAC	CONVSW,0	;NOTE GENVAR ENTRY

	POP	AXPTR	;RESTORE INTEGER

	INTSPC	SPECR1,AXPTR	;CONVERT TO STRING

	BRANCH	LOCA1	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ALLOCATION OF SPACE FOR VARIABLE

;

CONVAR:	PROC	GENVAR	;PROCEDURE TO GET SPACE FOR VARIABLE

	POP	AXPTR	;RESTORE LENGTH

	AEQLC	AXPTR,0,,RT1NUL	;AVOID NULL STRING

	SETAC	CONVSW,1	;NOTE CONVAR ENTRY

	GETLTH	BKLTCL,AXPTR	;GET SPACE REQUIRED

	ACOMP	BKLTCL,SIZLMT,SIZERR

;                                  CHECK AGAINST SIZE LIMIT

	SUM	TEMPCL,FRSGPT,BKLTCL

;                                  SKIP REQUIRED SPACE

	INCRA	TEMPCL,DESCR	;SAVE SPACE FOR TITLE

	ACOMP	TLSGP1,TEMPCL,,,CONVR4

;                                  CHECK FOR END OF REGION

CONVR5:	PUTDC	FRSGPT,0,ZEROCL	;CLEAR TITLE

	PUTAC	FRSGPT,0,FRSGPT	;SET UP SELF POINTER

	SETFI	FRSGPT,TTL+STTL	;SET STRING AND TITLE FLAGS

	SETSIZ	FRSGPT,AXPTR	;INSERT TENTATIVE SIZE OF STRING

	PUTDC	FRSGPT,DESCR,NULVCL	;INSERT NULL STRING AS VALUE

	PUTDC	FRSGPT,ATTRIB,ZEROCL

;                                  SET LABEL TO ZERO

;VERSION 3.4 CHANGE
	MOVA BKLTCL,FRSGPT

	RRTURN BKLTCL,1

;VERSION 3.4 CHANGE END

;_

CONVR4:	RCALL	,GC,BKLTCL,<ALOC2,CONVR5>

;                                  REGENERATE STORAGE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      GENERATION OF VARIABLE IN PLACE

;

GNVARS:	PROC	GENVAR	;PROCEDURE TO ENTRY STRING

	POP	AXPTR	;RESTORE LENGTH

	AEQLC	AXPTR,0,,RT1NUL	;AVOID NULL STRING

	LOCSPX	SPECR1,FRSGPT	;GET SPECIFIER TO POSITION

	PUTLG	SPECR1,AXPTR	;INSERT FINAL LENGTH

	SETSIZ	FRSGPT,AXPTR	;INSERT SIZE IN TITLE

	BRANCH	LOCA1	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      STORAGE REGENERATION

;

GC:	PROC	,	;STORAGE REGENERATION PROCEDURE

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;	CORE EXPANSION WILL TAKE PLACE IF THE GARBAGE COLLECTION
;	DOES NOT RESTORE ENOUGH FREE CORE. IF THIS WERE THE ONLY
;	CHANGE MADE, A POINT WOULD EVENTUALLY BE REACHED WHERE
;	JUST ENOUGH CORE WAS MADE AVAILABLE SO THE PROGRAM WOULD
;	RUN, BUT IT WOULD BE DOING A GREAT NUMBER OF REGENERATIONS
;	WHICH IT WOULD REALLY NOT HAVE TO DO.

;	THIS CODING MAKES AN ATTEMPT TO MONITOR THE NUMBER OF
;	REGENERATIONS DONE THUS FAR AND DOES A PREEXPANSION
;	BEFORE DOING THE COLLECTION IN ORDER TO REDUCE THE
;	CHANCES OF IT BEING CALLED AGAIN.

;	IT DOES A PREEXPANSION EVERY FIFTH TIME, IF
;	1. IT HAS NOT ALREADY REACHED A LIMIT OF MAXFRE
;	   FREE CORE
;	2. AND IT EXPANDS IN 2K CHUNKS

	EXTERN JOBREL,MSWIT

GCWAD1:	MOVE A1,GCNO	;GET NUMBER OF COLLECTIONS SO FAR
	IDIVI A1,5	;LOOK ONLY EVERY FIFTH TIME
	SKIPE A2
	JRST WADE2
	MOVE A0,TLSGP1	;GET TAIL POINTER TO FREE STORAGE
	SUB A0,HDSGPT	;HEADER POINTER
EXPMAX:	CAIL A0,MAXFRE
	JRST WADE2	;YES, SO NO MORE PREEXPANSIONS
	MOVE A0,JOBREL
	ADDI A0,2*^O1777	;ASK FOR 2K MORE
GCWAD6:	CALLI A0,^O11	;CORE UUO
	JFCL		;IGNORE ERROR RETURN AT THIS POINT
	MOVE A0,JOBREL
	SUBI A0,2*DESCR	;SAFTEY PRECAUTION
	MOVEM A0,TLSGP1
WADE2:

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*
	POP	GCREQ	;RESTORE SPACE REQUIRED

	PSTACK	BLOCL	;POST STACK POSITION

	SUBTRT	BLOCL,BLOCL,STKPTR	;COMPUTE STACK LENGTH USED

	SETSIZ	STKPTR,BLOCL	;SET STACK SIZE

	MOVD	BKDXU,PRMDX	;NUMBER OF RESIDENT BLOCKS

GCT:	GETD	GCMPTR,PRMPTR,BKDXU	;GET NEXT RESIDENT BLOCK

	AEQLC	GCMPTR,0,,GCTDWN	;SKIP NONPOINTERS

	RCALL	,GCM,<GCMPTR>	;SCAN RESIDENT BLOCK

GCTDWN:	DECRA	BKDXU,DESCR	;DECREMENT BLOCK COUNT

	AEQLC	BKDXU,0,GCT	;TEST FOR END OF LOOP

	SETAC	BKPTR,OBLIST-DESCR	;SET UP POINTER TO BINS

GCBA1:	ACOMP	BKPTR,OBEND,GCLAD	;CHECK FOR END OF BINS

	INCRA	BKPTR,DESCR	;INCREMENT BIN POINTER

	MOVD	ST1PTR,BKPTR	;GET WORKING COPY

GCBA2:	GETAC	ST1PTR,ST1PTR,LNKFLD

;                                  GET LINK POINTER

	AEQLC	ST1PTR,0,,GCBA1	;TEST FOR END OF CHAIN

	TESTFI	ST1PTR,MARK,,GCBA2	;TEST FOR MARKED STRUCTURE

	GETDC	ST2PTR,ST1PTR,DESCR	;GET VALUE DESCRIPTOR

	DEQL	ST2PTR,NULVCL,GCBA4	;MARK IF NONNULL

	AEQLIC	ST1PTR,ATTRIB,0,,GCBA2

;                                  TEST ATTRIBUTE ALSO

GCBA4:	PUTDC	GCBLK,DESCR,ST1PTR	;SET UP PSEUDOBLOCK

	RCALL	,GCM,<GCBLK>,GCBA2	;MARK STRING STRUCTURE

;_

GCLAD:	MOVD	CPYCL,HDSGPT	;INITIALIZE TARGET POINTER

	MOVD	TTLCL,HDSGPT	;INITIALIZE BLOCK POINTER

GCLAD0:	BKSIZE	BKDX,TTLCL	;GET SIZE OF BLOCK

	TESTFI	TTLCL,MARK,GCLAD7	;IS THE BLOCK MARKED?

	SUM	CPYCL,CPYCL,BKDX	;IS BLOCK MARKED?

	SUM	TTLCL,TTLCL,BKDX	;UPDATE BLOCK POINTER

	AEQL	TTLCL,FRSGPT,GCLAD0,GCBB1

;                                  CHECK FOR END OF REGION

;_

GCLAD7:	MOVD	MVSGPT,TTLCL	;UPDATE COMPRESSION BARRIER

GCLAD4:	SUM	TTLCL,TTLCL,BKDX	;UPDATE BLOCK POINTER

	AEQL	TTLCL,FRSGPT,,GCBB1	;CHECK FOR END OF REGION

	BKSIZE	BKDX,TTLCL	;GET SIZE OF BLOCK

	TESTFI	TTLCL,MARK,GCLAD4	;IS BLOCK MARKED?

	PUTAC	TTLCL,0,CPYCL	;POINT TITLE TO TARGET

	SUM	CPYCL,CPYCL,BKDX	;UPDATE TARGET POINTER

	BRANCH	GCLAD4	;CONTINUE

;_

GCBB1:	SETAC	BKPTR,OBLIST-DESCR	;SET UP POINTER TO BINS

	SETAC	NODPCL,1	;NO DUMP WHILE REORGANIZING

GCBB2:	ACOMP	BKPTR,OBEND,GCLAP	;CHECK FOR END OF BINS

	INCRA	BKPTR,DESCR	;INCREMENT BIN POINTER

	MOVD	ST1PTR,BKPTR	;GET WORK COPY

GCBB3:	MOVD	ST2PTR,ST1PTR	;SAVE POINTER TO BE LINKED

GCBB4:	GETAC	ST1PTR,ST1PTR,LNKFLD

;                                  GET LINK POINTER

	AEQLC	ST1PTR,0,,GCBB5	;CHECK FOR END OF CHAIN

	TESTFI	ST1PTR,MARK,GCBB4	;IS STRING MARKED?

	GETAC	BLOCL,ST1PTR,0	;GET TARGET ADDRESS

	PUTAC	ST2PTR,LNKFLD,BLOCL	;SET LINK TO TARGET

	BRANCH	GCBB3	;CONTINUE

;_

GCBB5:	PUTAC	ST2PTR,LNKFLD,ZEROCL

;                                  SET LAST LINK TO ZERO

	BRANCH	GCBB2	;CONTINUE

;_

GCLAP:	MOVD	TTLCL,HDSGPT	;INITIALIZE TARGET POINTER

GCLAP0:	BKSIZE	BKDXU,TTLCL	;GET SIZE OF BLOCK

	TESTFI	TTLCL,STTL,,GCLAP1	;CHECK FOR STRING

	MOVD	BKDX,BKDXU	;WORKING COPY OF BLOCK SIZE

	BRANCH	GCLAP2

;_

GCLAP1:	SETAC	BKDX,3*DESCR	;THREE DESCRIPTORS FOR STRING

GCLAP2:	TESTFI	TTLCL,MARK,GCLAP5	;IS BLOCK MARKED?

	DECRA	BKDX,DESCR	;DECREMENT OFFSET

GCLAP3:	GETD	DESCL,TTLCL,BKDX	;GET NEXT DESCRIPTOR IN BLOCK

	TESTF	DESCL,PTR,GCLAP4	;IS IT A POINTER?

	ACOMP	DESCL,MVSGPT,,,GCLAP4

;                                  IS IT ABOVE COMPRESSION BARRIER?


; FOLLOWING CODE ADDED TO HANDLE A UNIQUE PROBLEM WITH RELOCATING
; SPECIFIERS ON THE PDP-10. THIS IS NECESSARY BECAUSE THE
; OFFSET FIELD CONTAINS AN ADDRESS AS DOES THE ADDRESS FIELD
; A NEW FLAG CALLED SPCFLG HAS BEEN DEFINED IN COPY TO ALLOW
; US TO IDENTIFY WHEN WE ARE WORKING WITH A SPECIFIER. THE LOCSPX
; AND INTSPX MACROS MAKE PARTICULAR ATTENTION AND SET THIS FLAG

	TESTF DESCL,SPCFLG,SPFIX1	;ARE WE WORKING WITH A SPECIFIER

	INCRA	BKDX,DESCR		;YES, SO GET OTHER HALF

	GETD	DESCL1,TTLCL,BKDX	;DESCL EXPANDED FOR THIS CODE

	HRRZ A1,DESCL1
	SKIPN DESCL1+1	;IGNORE ZERO LENGTH STRINGS
	JRST SPFIX3

;NOW MAKE SOME SUPER PRECAUTIONARY MEASURES FOUND TO BE NECESSARY
	CAMG A1,DESCL	;BYTE POINTER ALWAYS AFTER START
	JRST SPFIX3
	LDB A2,[POINT 12,DESCL1,17] ;MAKE SURE WE HAVE A BYTE POINTER
	CAIE A2,^O0700
	JRST SPFIX3

	SUB A1,DESCL	;CALCULATE RELATIVE DIFFERENCE IN THIS
			;BLOCK BEFORE RELOCATION

	MOVEM A1,DESCL2	;SAVE TEMPORARILY

	TOP TOPCL,OFSET,DESCL

	ADJUST DESCL,TOPCL,OFSET	;RELOCATE FIRST HALF

	HRRZ A0,DESCL	;GET NEW ADDRESS
	ADD A0,DESCL2	;ADD RELATIVE DIFFERENCE FROM OLD LOCATION
	HRRM A0,DESCL+2	;FIX UP THE BYTE POINTER FIELD

	PUTD TTLCL,BKDX,DESCL+2	;PUT BACK LAST HALF

	DECRA BKDX,DESCR	;GO BACK TO ORIGINAL

	PUTD TTLCL,BKDX,DESCL	;PUT BACK FIRST HALF

	BRANCH GCLAP4	;DONE WITH THIS ENTRY, CONTINUE

SPFIX3:	DECRA BKDX,DESCR

SPFIX1:

; END OF SPECIAL FIX UP FOR THE PDP-10
	TOP TOPCL,OFSET,DESCL

	ADJUST	DESCL,TOPCL,OFSET	;ADJUST POINTER TO TARGET

	PUTD	TTLCL,BKDX,DESCL	;PUT DESCRIPTOR BACK IN BLOCK

GCLAP4:	DECRA	BKDX,DESCR	;DECREMENT OFFSET

	AEQLC	BKDX,0,GCLAP3	;CHECK FOR END OF BLOCK

GCLAP5:	SUM	TTLCL,TTLCL,BKDXU	;MOVE TO NEXT BLOCK

	AEQL	TTLCL,FRSGPT,GCLAP0	;CHECK FOR END OF REGION

	MOVD	BKDXU,PRMDX	;NUMBER OF RESIDENT BLOCKS

GCLAT1:	GETD	TTLCL,PRMPTR,BKDXU	;GET NEXT RESIDENT BLOCK

	AEQLC	TTLCL,0,,GCLAT4	;SKIP NONPOINTER

	GETSIZ	BKDX,TTLCL	;GET SIZE OF BLOCK

GCLAT2:	GETD	DESCL,TTLCL,BKDX	;GET DESCRIPTOR FROM BLOCK

	TESTF	DESCL,PTR,GCLAT3	;IS IT A POINTER?

	ACOMP	DESCL,MVSGPT,,,GCLAT3

;                                  IS IT ABOVE COMPRESSION BARRIER?


; THIS CODE IS IDENTICAL TO THE PREVIOUS CODE TO HANDLE
; THE UNIQUE PDP-10 PROBELM OF RELOCATING SPECIFIERS

	TESTF DESCL,SPCFLG,SPFIX2

	INCRA BKDX,DESCR

	GETD DESCL1,TTLCL,BKDX

	HRRZ A1,DESCL1	;CALCULATE OFFSET IN ORIGINAL BLOCK
	SKIPN DESCL1+1
	JRST SPFIX4

	CAMG A1,DESCL
	JRST SPFIX4
	LDB A2,[POINT 12,DESCL1,17]
	CAIE A2,^O0700
	JRST SPFIX4

	SUB A1,DESCL
	MOVEM A1,DESCL2

	TOP TOPCL,OFSET,DESCL


	ADJUST DESCL,TOPCL,OFSET

	HRRZ A0,DESCL
	ADD A0,DESCL2
	HRRM A0,DESCL+2

	PUTD TTLCL,BKDX,DESCL+2

	DECRA BKDX,DESCR

	PUTD TTLCL,BKDX,DESCL

	BRANCH GCLAT3

SPFIX4:	DECRA BKDX,DESCR

SPFIX2:

; END OF CHANGE FOR THE PDP-10

	TOP TOPCL,OFSET,DESCL

	ADJUST	DESCL,TOPCL,OFSET	;ADJUST POINTER TO TARGET

	PUTD	TTLCL,BKDX,DESCL	;PUT DESCRIPTOR BACK IN BLOCK

GCLAT3:	DECRA	BKDX,DESCR	;DECREMENT OFFSET

	AEQLC	BKDX,0,GCLAT2	;CHECK FOR END OF BLOCK

GCLAT4:	DECRA	BKDXU,DESCR	;DECREMENT COUNT OF RESIDENT BLOCKS

	AEQLC	BKDXU,0,GCLAT1	;CHECK FOR END OF RESIDENT BLOCKS

	MOVD	TTLCL,HDSGPT	;SET UP TARGET POINTER

GCLAM0:	BKSIZE	BKDXU,TTLCL	;GET SIZE OF BLOCK

	ACOMP	TTLCL,MVSGPT,GCLAM5,GCLAM5

;                                  HAS COMPRESSION BARRIER BEEN REACHED

	GETAC	TOPCL,TTLCL,0	;GET TARGET POSITION

	MOVDIC	TOPCL,0,TTLCL,0	;MOVE TITLE TO TARGET POSITION

	RSETFI	TOPCL,MARK	;CLEAR MARK FLAG

	BRANCH	GCLAM4	;CONTINUE

;_

GCLAM5:	MOVA	BKDX,BKDXU	;WORKING COPY OF BLOCK SIZE

	DECRA	BKDX,DESCR	;SIZE TO BE MOVED

	TESTFI	TTLCL,MARK,GCLAM4	;IS BLOCK MARKED?

	GETAC	TOPCL,TTLCL,0	;GET TARGET POSITION

	MOVDIC	TOPCL,0,TTLCL,0	;MOVE TITLE

	RSETFI	TOPCL,MARK	;CLEAR MARK FLAG

	MOVBLK	TOPCL,TTLCL,BKDX	;MOVE BLOCK ITSELF

GCLAM4:	SUM	TTLCL,TTLCL,BKDXU	;GET TO NEXT BLOCK

	AEQL	TTLCL,FRSGPT,GCLAM0	;CHECK FOR END OF REGION

	INCRA	GCNO,1	;INCREMENT COUNT OF REGENERATIONS

	SETAC	NODPCL,0	;PERMIT DUMP

	BKSIZE	BKDX,TOPCL	;GET SIZE OF LAST BLOCK

	SUM	FRSGPT,TOPCL,BKDX	;COMPUTE NEW ALLOCATION POINTER

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;	THIS CODING IMPLEMENTS ONE OF TWO BASIC CORE STORAGE
;	EXPANSION MECHANISMS. AT THIS POINT THERE IS NOT ENOUGH
;	CORE LEFT TO FULFILL THE REQUEST, AND A CORE EXPANSION
;	IS MADE TO ATTEMPT TO RESOLVE THE CRISIS. IF NO MORE CORE
;	CORE IS TO BE HAD, THEN WE GIVE UP.

	EXTERN TOTAVL,STCORE,ICORE

	RESETF FRSGPT,FNC
GCWAD4:	SUBTRT GCGOT,TLSGP1,FRSGPT
	DECRA GCGOT,DESCR
	RESETF GCGOT,PTR

GCWADE:	ACOMP GCREQ,GCGOT,,GCWAD3,GCWAD3
	MOVE A0,JOBREL
	ADDI A0,2*^O1777	;ASK FOR 2K MORE
GCWAD5:	CALLI A0,^O11	;CORE UUO
	JRST [	MOVE A0,JOBREL
		ADDI A0,^O1777
		CALLI A0,^O11
		JRST FAIL
		JRST GCWAD8]
GCWAD8:	MOVE A0,JOBREL
	SUBI A0,2*DESCR	;SAFTEY FACTOR
	MOVEM A0,TLSGP1
	JRST GCWAD4	;CONTINUE THE LOOP

GCWAD3:

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*
	RRTURN GCGOT,2

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      BLOCK MARKING

;

GCM:	PROC	,	;PROCEDURE TO MARK BLOCKS

	POP	BK1CL	;RESTORE BLOCK TO MARK FROM

	PUSH	ZEROCL	;SAVE END MARKER

GCMA1:	GETSIZ	BKDX,BK1CL	;GET SIZE OF BLOCK

GCMA2:	GETD	DESCL,BK1CL,BKDX	;GET DESCRIPTOR

	TESTF	DESCL,PTR,GCMA3	;IS IT A POINTER?

	AEQLC	DESCL,0,,GCMA3	;IS ADDRESS ZERO?

	TOP	TOPCL,OFSET,DESCL	;GET TO TITLE OF BLOCK POINTED TO

	TESTFI	TOPCL,MARK,GCMA4	;IS BLOCK MARKED?

GCMA3:	DECRA	BKDX,DESCR	;DECREMENT OFFSET

	AEQLC	BKDX,0,GCMA2	;CHECK FOR END OF BLOCK

	POP	BK1CL	;RESTORE BLOCK PUSHED

	AEQLC	BK1CL,0,,RTN1	;CHECK FOR END

	SETAV	BKDX,BK1CL	;GET SIZE REMAINING

	BRANCH	GCMA2	;CONTINUE PROCESSING

;_

GCMA4:	DECRA	BKDX,DESCR	;DECREMENT OFFSET

	AEQLC	BKDX,0,,GCMA9	;CHECK FOR END

	SETVA	BK1CL,BKDX	;INSERT OFFSET

	PUSH	BK1CL	;SAVE CURRENT BLOCK

GCMA9:	MOVD	BK1CL,TOPCL	;SET POINER TO NEW BLOCK

	SETFI	BK1CL,MARK	;MARK BLOCK

	TESTFI	BK1CL,STTL,GCMA1	;IS IT A STRING?

	MOVD	BKDX,TWOCL	;SET SIZE OF STRING TO 2

	BRANCH	GCMA2	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      PROCEDURE TO SPLIT BLOCKS

SPLIT:	PROC	,	;PROCEDURE TO SPLIT BLOCKS

	POP	A4PTR	;RESTORE POINTER TO MIDDLE OF BLOCK

	TOP	A5PTR,A6PTR,A4PTR	;GET TITLE AND OFFSET

	AEQLC	A6PTR,0,,RTN1	;AVOID BLOCK OF ZERO LENGTH

	GETSIZ	A7PTR,A5PTR	;GET PRESENT BLOCK SIZE

	SUBTRT	A7PTR,A7PTR,A6PTR	;SUBTRACT OFFSET

	DECRA	A7PTR,DESCR	;DECREMENT FOR TITLE

	ACOMPC	A7PTR,0,,RTN1,RTN1	;AVOID BLOCK OF ZERO LENGTH

	SETSIZ	A5PTR,A6PTR	;RESET SIZE OF OLD BLOCK

	INCRA	A4PTR,DESCR	;ADJUST POINTER TO MIDDLE

	PUTDC	A4PTR,0,ZEROCL

	PUTAC	A4PTR,0,A4PTR

	SETFI	A4PTR,TTL	;INSERT TITLE FLAG

	SETSIZ	A4PTR,A7PTR	;INSERT SIZE FO NEW BLOCK

	BRANCH	RTN1	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'COMPILATION PROCEDURES'

;

;      BINARY OPERATOR ANALYSIS

;

BINOP:	PROC	,	;COMPILER BINARY OPERATOR ANALYSIS

	RCALL	,FORBLK,,BINOP1	;TEST FOR INITIAL BLANK

	AEQLC	BRTYPE,NBTYP,RTN2	;IF SO, FAIL ON BREAK

	STREAM	XSP,TEXTSP,BIOPTB,BINCON

	MOVD	ZPTR,STYPE	;MOVE FUNCTION DESCRIPTOR

	BRANCH	RTZPTR	;RETURN FUNCTION DESCRIPTOR

;_

BINOP1:	RCALL	,FORWRD,,COMP3	;IF NO BLANK, FIND CHARACTER

	SELBRA	BRTYPE,<,RTN2,RTN2,,,RTN2,RTN2>

BINERR:	SETAC	EMSGCL,ILLBIN	;SET UP ERROR MESSAGE

	BRANCH	RTN1	;TAKE ERROR RETURN

;_

BINCON:	MOVD	ZPTR,CONCL	;NO OPERATOR, CONCATENATION

	BRANCH	RTZPTR	;RETURN FUNCTION DESCRIPTOR

;_

BINEOS:	SETAC	EMSGCL,ILLEOS	;SET UP ERROR MESSAGE

	BRANCH	RTN1	;ERROR RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      STATEMENT COMPILATION

;

CMPILE:	PROC	,	;PROCEDURE TO COMPILE STATEMENT

	SETAC	BRTYPE,0	;CLEAR BREAK INDICATOR

	MOVD	BOSCL,CMOFCL	;SET STATEMENT BEGINNING OFFSET

	INCRA	CSTNCL,1	;INCREMENT STATEMENT NUMBER

	STREAM	XSP,TEXTSP,LBLTB,CERR1

;                                  BREAK OUT LABEL

	LEQLC	XSP,0,,CMPILA	;CHECK FOR NO LABEL

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,BASECL

;                                  INSERT BASE FUNCTION

	SUM	CMBSCL,CMBSCL,CMOFCL

;                                  ADD OFFSET TO BASE

	ACOMP	CMBSCL,OCLIM,,,CMPILO

;                                  CHECK FOR END OF OBJECT CODE

	RCALL	XCL,BLOCK,CODELT	;GET BLOCK FOR MORE

	PUTDC	CMBSCL,0,GOTGCL	;REPLACE BASE WITH DIRECT GOTO

	PUTDC	CMBSCL,DESCR,DOTCL	;USE NAME LITERAL

	PUTDC	CMBSCL,2*DESCR,XCL	;AIM AT NEW BLOCK

	MOVD	CMBSCL,XCL	;SET UP BASE OF NEW REGION

	SUM	OCLIM,CMBSCL,CODELT	;COMPUTE END OF NEW BLOCK

	DECRA	OCLIM,5*DESCR	;LEAVE SAFETY FACTOR

	PUTDC	CMBSCL,DESCR,BASECL	;SET BASE FUNCTION IN NEW REGION

	INCRA	CMBSCL,DESCR	;INCREMENT BASE

CMPILO:	SETAC	CMOFCL,0	;ZERO OFFSET

	SETAC	BOSCL,0	;ZERO BASE OFFSET

	RCALL	LPTR,GENVAR,XSPPTR	;GET VARIABLE FOR LABEL

	AEQLIC	LPTR,ATTRIB,0,,CMPILC

;                                  CHECK FOR PREVIOUS DEFINITION

	AEQLC	CNSLCL,0,,CERR2	;CHECK FOR LABEL REDEFINITION

CMPILC:	PUTDC	LPTR,ATTRIB,CMBSCL	;INSERT LABEL ATTRIBUTE

	DEQL	LPTR,ENDPTR,,RTN2	;CHECK FOR END

CMPILA:	RCALL	,FORBLK,,CERR12	;GET TO NEXT CHARACTER

	AEQLC	BRTYPE,EOSTYP,,RTN3	;WAS END OF STATEMENT FOUNC?

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,INITCL

;                                  INSERT INIT FUNCTION

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	MOVD	FRNCL,CMOFCL	;SAVE OFFSET FOR FAILURE POSITION

	AEQLC	BRTYPE,NBTYP,,CMPSUB

;                                  CHECK FOR NONBREAK

	AEQLC	BRTYPE,CLNTYP,CERR3,CMPGO

;                                  CHECK FOR GOTO FIELD

;_

CMPSUB:	RCALL	SUBJND,ELEMNT,,<CDIAG,COMP3>

;                                  COMPILER SUBJECT

	RCALL	,FORBLK,,CERR5	;GET TO NEXT CHARACTER

	AEQLC	BRTYPE,NBTYP,,CMPATN

;                                  CHECK FOR NONBREAK

	AEQLC	BRTYPE,EQTYP,,CMPFRM

;                                  CHECK FOR ASSIGNMENT

	RCALL	,TREPUB,<SUBJND>	;COPY SUBJECT INTO OBJECT CODE

	AEQLC	BRTYPE,CLNTYP,,CMPGO

;                                  CHECK FOR GOTO

	AEQLC	BRTYPE,EOSTYP,CERR5,CMPNGO

;                                  CHECK FOR END OF STATEMENT

;_

CMPATN:	RCALL	PATND,EXPR,,CDIAG	;COMPILE PATTERN

	AEQLC	BRTYPE,EQTYP,,CMPASP

;                                  CHECK FOR REPLACEMENT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,SCANCL

;                                  INSERT SCAN FUNCTION

	RCALL	,TREPUB,<SUBJND>	;COPY SUBJECT INTO OBJECT CODE

	RCALL	,TREPUB,<PATND>	;COPY PATTERN INTO OBJECT CODE

CMPTGO:	AEQLC	BRTYPE,EOSTYP,,CMPNGO

;                                  CHECK FOR END OF STATEMENT

	AEQLC	BRTYPE,CLNTYP,CERR5,CMPGO

;                                  CHECK FOR END OF STATEMENT

;_

CMPFRM:	RCALL	FORMND,EXPR,,CDIAG	;COMPILE OBJECT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,ASGNCL

;                                  INSERT ASGN FUNCTION

	RCALL	,TREPUB,<SUBJND>	;COPY SUBJECT INTO OBJECT CODE

	BRANCH	CMPFT	;JOIN OBJECT PUBLICATION

;_

CMPASP:	RCALL	FORMND,EXPR,,CDIAG	;COMPILE OBJECT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,SJSRCL

;                                  INSERT SJSR FUNCTION

	RCALL	,TREPUB,<SUBJND>	;COPY SUBJECT INTO OBJECT CODE

	RCALL	,TREPUB,<PATND>	;COPY PATTERN INTO OBJECT CODE

CMPFT:	RCALL	,TREPUB,FORMND,CMPTGO

;                                  COPY OBJECT INTO OBJECT CODE

;_

CMPNGO:	SETVA	CSTNCL,CMOFCL	;SET UP OFFSET FOR FAILURE

	PUTD	CMBSCL,FRNCL,CSTNCL	;INSERT ARGUMENT OF INIT

	BRANCH	RTN3	;STATEMENT COMPILATION IS DONE

;_                                 GET TO NEXT CHARACTER

CMPGO:	RCALL	,FORWRD,,COMP3	;CHECK FOR END OF STATEMENT

	AEQLC	BRTYPE,EOSTYP,,CMPNGO

;                                  CHECK FOR NONBREAK

	AEQLC	BRTYPE,NBTYP,CERR11

	STREAM	XSP,TEXTSP,GOTOTB,CERR11,CERR12

;                                  ANALYZE GOTO FIELD

	MOVD	GOGOCL,GOTLCL	;PREDICT GOTL

	SETAC	GOBRCL,RPTYP	;SET UP PREDICTED CLOSING BREAK

	ACOMP	STYPE,GTOCL,,CMPGG,CMPGG

;                                  CHECK FOR DIRECT GOTO

	MOVD	GOGOCL,GOTGCL	;SET UP DIRECT GOTO

	SETAC	GOBRCL,RBTYP	;SET UP CLOSING BREAK

CMPGG:	SELBRA	STYPE,<,CMPSGO,CMPFGO,,CMPSGO,CMPFGO>

;                                  BRANCH ON TYPE

CMPUGO:	SETVA	CSTNCL,CMOFCL	;SET UP OFFSET FOR FAILURE

	PUTD	CMBSCL,FRNCL,CSTNCL	;INSERT ARGUMENT OF INIT

	RCALL	GOTOND,EXPR,,CDIAG	;COMPILE GOTO

	AEQL	BRTYPE,GOBRCL,CERR11

;                                  VERIFY CLOSING BREAK

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,GOGOCL

;                                  INSERT GOTO FUNCTION

	RCALL	,TREPUB,<GOTOND>	;COPY GOTO INTO OBJECT CODE

	RCALL	,FORWRD,,COMP3	;GET TO NEXT CHARACTER

	AEQLC	BRTYPE,EOSTYP,CERR11,RTN3

;                                  CHECK FOR END OF STATEMENT

;_

CMPSGO:	RCALL	SGOND,EXPR,,CDIAG	;COMPILE SUCCESS GOTO

	AEQL	BRTYPE,GOBRCL,CERR11

;                                  VERIFY BREAK CHARACTER

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,GOGOCL

;                                  INSERT GOTO FUNCTION

	RCALL	,TREPUB,<SGOND>	;COPY GOTO INTO OBJECT CODE

	RCALL	,FORWRD,,COMP3	;GET TO NEXT CHARACTER

	AEQLC	BRTYPE,EOSTYP,CMPILL

;                                  CHECK FOR END OF STATEMENT

	SETVA	CSTNCL,CMOFCL	;SET UP OFFSET FOR FAILURE

	PUTD	CMBSCL,FRNCL,CSTNCL	;INSERT ARGUMENT OF INIT

	BRANCH	RTN3	;COMPILATION IS COMPLETE, RETURN

;_

CMPILL:	AEQLC	BRTYPE,NBTYP,CERR11	;CHECK FOR NONBREAK

	STREAM	XSP,TEXTSP,GOTOTB,CERR11,CERR12

;                                  ANALYZE GOTO FIELD

	AEQLC	STYPE,FGOTYP,CMPFTC	;CHECK FOR FAILURE GOTO

	MOVD	GOGOCL,GOTLCL	;SET UP GOTO

	SETAC	GOBRCL,RPTYP	;SET UP CLOSING BREAK

	BRANCH	CMPUGO	;JOIN PROCESSING

;_

CMPFTC:	AEQLC	STYPE,FTOTYP,CERR11	;VERIFY FAILURE GOTO

	MOVD	GOGOCL,GOTGCL	;SET UP GOTO

	SETAC	GOBRCL,RBTYP	;SET UP CLOSING BREAK

	BRANCH	CMPUGO	;JOIN PROCESSING

;_

CMPFGO:	RCALL	FGOND,EXPR,,CDIAG	;COMPILE FAILURE GOTO

	AEQL	BRTYPE,GOBRCL,CERR11

;                                  VERIFY FAILURE GOTO

	RCALL	,FORWRD,,COMP3	;GET TO NEXT CHARACTER

	AEQLC	BRTYPE,EOSTYP,CMPILM

;                                  CHECK FOR END OF STATEMENT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,GOTOCL

;                                  INSERT GOTO FUNCTION

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	MOVD	SRNCL,CMOFCL	;SAVE LOCATION FOR SUCCESS

	SETVA	CSTNCL,CMOFCL	;SET UP FAILURE OFFSET

	PUTD	CMBSCL,FRNCL,CSTNCL	;INSERT ARGUMENT OF INIT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,GOGOCL

;                                  INSERT GOTO FUNCTION

	RCALL	,TREPUB,<FGOND>	;COPY GOTO INTO OBJECT CODE

	PUTD	CMBSCL,SRNCL,CMOFCL	;INSERT SUCCESS OFFSET INTO CODE

	BRANCH	RTN3	;COMPILATION IS COMPLETE, RETURN

;_

CMPILM:	AEQLC	BRTYPE,NBTYP,CERR11	;VERIFY NONBREAK

	STREAM	XSP,TEXTSP,GOTOTB,CERR11,CERR12

;                                  ANALYZE GOTO FIELD

	AEQLC	STYPE,SGOTYP,CMPSTC	;CHECK FOR SUCCESS GOTO

	PUSH	GOTLCL	;SAVE GOTO TYPE

	SETAC	GOBRCL,RPTYP	;SET UP CLOSING BREAK

	BRANCH	CMPILN	;JOIN PROCESSING

;_

CMPSTC:	AEQLC	STYPE,STOTYP,CERR11	;VERIFY SUCCESS GOTO

	PUSH	GOTGCL	;SAVE GOTO TYPE

	SETAC	GOBRCL,RBTYP	;SET UP CLOSING BREAK

CMPILN:	RCALL	SGOND,EXPR,,CDIAG	;COMPILE SUCCESS GOTO

	AEQL	BRTYPE,GOBRCL,CERR11

;                                  VERIFY CLOSING BREAK

	RCALL	,FORWRD,,COMP3	;GET TO NEXT CHARACTER

	AEQLC	BRTYPE,EOSTYP,CERR11

;                                  VERIFY END OF STATEMENT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	POP	WCL	;RESTORE GOTO TYPE

	PUTD	CMBSCL,CMOFCL,WCL	;INSERT GOTO FUNCTION

	RCALL	,TREPUB,<SGOND>	;COPY GOTO INTO OBJECT CODE

	SETVA	CSTNCL,CMOFCL	;SET UP FAILURE OFFSET

	PUTD	CMBSCL,FRNCL,CSTNCL	;INSERT ARGUMENT OF INIT

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,GOGOCL

;                                  INSERT GOTO FUNCTION

	RCALL	,TREPUB,<FGOND>,RTN3

;                                  COPY GOTO INTO OBJECT CODE

;_

CERR1:	SETAC	EMSGCL,EMSG1	;ERRONEOUS LABEL

	BRANCH	CDIAG

;_

CERR2:	SETAC	EMSGCL,EMSG2	;MULTIDEFINED LABEL

	BRANCH	CDIAG

;_

CERR3:	SETAC	EMSGCL,EMSG3	;BREAK CHARACTER BEFORE SUBJECT

	BRANCH	CDIAG

;_

CERR5:	SETAC	EMSGCL,ILLBRK	;ILLEGAL CHARACTER AFTER PATTERN

	BRANCH	CDIAG

;_

CERR12:	SETAC	EMSGCL,ILLEOS	;ILLEGAL STATEMENT TERMINATION

	BRANCH	CDIAG

;_

CERR11:	SETAC	EMSGCL,EMSG14	;CHARACTERS AFTER GOTO

CDIAG:	INCRA	BOSCL,DESCR	;INCREMENT OFFSET OF BEGINNING

	PUTD	CMBSCL,BOSCL,ERORCL	;INSERT ERROR FUNCTION

	INCRA	BOSCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,BOSCL,CSTNCL	;INSERT ARGUMENT OF ERROR

	MOVD	CMOFCL,BOSCL	;REPOSITION OFFSET

	INCRA	ESAICL,DESCR	;INCREMENT COUNT OF ERRORS

	ACOMP	ESAICL,ESALIM,COMP9	;TEST FOR EXCESSIVE ERRORS

	AEQLC	LISTCL,0,,CDIAG1	;CHECK FOR LISTING MODE

	MOVD	YCL,ERRBAS	;SET UP LENGTH OF ERROR VECTOR

	AEQLC	BRTYPE,EOSTYP,,CDIAG3

;                                  CHECK FOR END OF STATEMENT

	GETLG	XCL,TEXTSP	;GET LENGTH REMAINING

	SUBTRT	YCL,YCL,XCL	;COMPUTE POSITION FOR MARKER

CDIAG3:	PUTLG	ERRSP,YCL	;INSERT LENGTH

	APDSP	ERRSP,QTSP	;SET IN MARKER

	AEQLC	BRTYPE,EOSTYP,,CDIAG2

;                                  CHECK FOR END OF STATEMENT

	STPRNT	IOKEY,OUTBLK,LNBFSP	;PRINT STATEMENT

CDIAG2:	STPRNT	IOKEY,OUTBLK,ERRSP	;PRINT ERROR MARKER

	PUTLG	ERRSP,YCL	;INSERT LENGTH IN MARKER

	APDSP	ERRSP,BLSP	;BLANK OUT MARKER

	GETSPC	TSP,EMSGCL,0	;GET ERROR MESSAGE

	SETLC	CERRSP,0	;CLEAR SPECIFIER

	APDSP	CERRSP,STARSP	;APPEND ATTENTION GETTER

	APDSP	CERRSP,TSP	;APPEND ERROR MESSAGE

	STPRNT	IOKEY,OUTBLK,CERRSP	;PRINT ERROR MESSAGE

	STPRNT	IOKEY,OUTBLK,BLSP	;PRINT BLANK LINE

;VERSION 3.3 CHANGE
CDIAG1:	AEQLC UNIT,0,,RTN1
	AEQLC BRTYPE,EOSTYP,,RTN3
;VERSION 3.3 CHANGE END
	STREAM	XSP,TEXTSP,EOSTB,COMP3,,RTN3

;                                  GET TO END OF STATEMENT

DIAGRN:	STREAD	INBFSP,UNIT,DWADE2,COMP5

;                                  READ CARD IMAGE

	SETSP	TEXTSP,NEXTSP	;SET UP NEW LINE

	STREAM	XSP,TEXTSP,CARDTB,COMP3,COMP3

;                                  ANALYZE CARD TYPE

	RCALL	,NEWCRD,,<,,RTN3>	;PROCESS CARD IMAGE

	AEQLC	LISTCL,0,,DIAGRN

	STPRNT	IOKEY,OUTBLK,LNBFSP	;PRINT OUT BYPASSED CARD

	BRANCH	DIAGRN

;_
;"""""""""""""""""""""""""""""""""""""""""""""""""""""""

DWADE2:	PUSHJ PDP,EOF
	JRST DIAGRN	;RETURN AFTER GETTING ANOTHER DEVICE

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ELEMENT ANALYSIS

;

ELEMNT:	PROC	,	;ELEMENT ANALYSIS PROCEDURE

	RCALL	ELEMND,UNOP,,RTN2	;GET TREE OF UNARY OPERATORS

	STREAM	XSP,TEXTSP,ELEMTB,ELEICH,ELEILI

;                                  BREAK OUT ELEMENT

ELEMN9:	SELBRA	STYPE,<,ELEILT,ELEVBL,ELENST,ELEFNC,ELEFLT,ELEARY>

;                                  BRANCH ON ELEMENT TYPE

	FSHRTN	XSP,1	;DELETE INITIAL QUOTE

	SHORTN	XSP,1	;REMOVE TERMINAL QUOTE

	RCALL	XPTR,GENVAR,<XSPPTR>

;                                  GENERATE VARIABLE FOR LITERAL

ELEMN5:	RCALL	ELEXND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEXND,CODE,LITCL	;INSERT LITERAL FUNCTION

	RCALL	ELEYND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEYND,CODE,XPTR	;INSERT LITERAL VALUE

	ADDSON	ELEXND,ELEYND	;ADD NODE AS SON

ELEMN1:	AEQLC	ELEMND,0,ELEMN6	;CHECK FOR EMPTY TREE

	MOVD	ZPTR,ELEXND	;SET UP RETURN

	BRANCH	ELEMRR	;JOIN RETURN PROCESSING

;_

ELEMN6:	ADDSON	ELEMND,ELEXND	;ADD AS SON OF PRESENT TREE

ELEMNR:	MOVD	ZPTR,ELEMND	;MOVE TREE TO RETURN

ELEMRR:	AEQLIC	ZPTR,FATHER,0,,RTZPTR

;                                  IS POINTER AT TOP OF TREE?

	GETDC	ZPTR,ZPTR,FATHER	;MOVE BACK TO FATHER

	BRANCH	ELEMRR	;CONTINUE UP TREE

;_

ELEILT:	SPCINT	XPTR,XSP,ELEINT,ELEMN5

;                                  CONVERT STRING TO INTEGER

;_

ELEFLT:	SPREAL	XPTR,XSP,ELEDEC,ELEMN5

;                                  CONVERT STRING TO REAL

;_

ELEVBL:	RCALL	XPTR,GENVAR,<XSPPTR>

;                                  GENERATE VARIABLE

	RCALL	ELEXND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEXND,CODE,XPTR	;INSERT NAME

	BRANCH	ELEMN1	;JOIN EXIT PROCESSING

;_

ELENST:	PUSH	ELEMND	;SAVE CURRENT TREE

	RCALL	ELEXND,EXPR,,RTN1	;EVALUATE NESTED EXPRESSION

	POP	ELEMND	;RESTORE TREE

	AEQLC	BRTYPE,RPTYP,ELECMA,ELEMN1

;                                  VERIFY RIGHT PARENTHESIS

;_

ELEFNC:	SHORTN	XSP,1	;DELETE OPEN PARENTHESIS

	RCALL	XPTR,GENVAR,<XSPPTR>

;                                  GENERATE VARIABLE FOR FUNCTION NAME

	RCALL	XCL,FINDEX,<XPTR>	;FIND FUNCTION DESCRIPTOR

	RCALL	ELEXND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEXND,CODE,XCL	;INSERT FUNCTION DESCRIPTOR IN NODE

	AEQLC	ELEMND,0,,ELEMN7	;IS TREE EMPTY?

	ADDSON	ELEMND,ELEXND	;ADD NODE AS SON TO TREE

ELEMN7:	PUSH	ELEXND	;SAVE CURRENT NODE

	RCALL	ELEXND,EXPR,,RTN1	;EVALUATE ARGUMENT OF FUNCTION

	POP	ELEMND	;RESOTRE CURRENT NODE

	ADDSON	ELEMND,ELEXND	;ADD ARGUMENT AS SON

	MOVD	ELEMND,ELEXND	;MOVE TO NEW NODE

ELEMN2:	AEQLC	BRTYPE,RPTYP,,ELEMN3

;                                  CHECK FOR LEFT PARENTHESIS

	AEQLC	BRTYPE,CMATYP,ELECMA

;                                  VERIFY COMMA

	PUSH	ELEMND	;SAVE CURRENT NODE

	RCALL	ELEXND,EXPR,,RTN1	;EVALUATE NEXT ARGUMENT

	POP	ELEMND	;RESTORE CURRENT NODE

	ADDSIB	ELEMND,ELEXND	;ADD ARGUMENT AS SIBLING

	MOVD	ELEMND,ELEXND	;MOVE TO NEW NODE

	BRANCH	ELEMN2	;CONTINUE

;_

ELEMN3:	GETDC	ELEXND,ELEMND,FATHER

;                                  GET FATHER OF CURRENT NODE

	GETDC	XCL,ELEXND,CODE	;GET FUNCTION DESCRIPTOR

	GETDC	YCL,XCL,0	;GET PROCEDURE DESCRIPTOR

	TESTF	YCL,FNC,,ELEMNR	;CHECK FOR FIXED NUMBER REQUIREMENT

	SETAV	XCL,XCL	;GET NUMBER OF ARGUMENTS GIVEN

	SETAV	YCL,YCL	;GET NUMBER OF ARGUMENTS EXPECTED

ELEMN4:	ACOMP	XCL,YCL,ELEMNR,ELEMNR

;                                  COMPARE GIVEN AND EXPECTED

	RCALL	ELEYND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEYND,CODE,LITCL	;INSERT LITERAL FUNCTION

	RCALL	ELEXND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEXND,CODE,NULVCL	;INSERT NULL STRING VALUE

	ADDSON	ELEYND,ELEXND	;ADD NULL AS SON OF LITERAL

	ADDSIB	ELEMND,ELEYND	;ADD LITERAL AS EXTRA ARGUMENT

	MOVD	ELEMND,ELEYND	;MOVE TO NEW NODE

	INCRA	XCL,1	;INCREMENT ARGUMENT COUNT

	BRANCH	ELEMN4	;CONTINUE

;_

ELEARY:	SHORTN	XSP,1	;REMOVE LEFT BRACKET

	RCALL	XPTR,GENVAR,<XSPPTR>

;                                  GENERATE VARIABLE FOR ARRAY OR TABLE

	RCALL	ELEXND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEXND,CODE,ITEMCL	;INSERT ITEM FUNCTION

	AEQLC	ELEMND,0,,ELEMN8	;IS TREE EMPTY?

	ADDSON	ELEMND,ELEXND	;ADD AS SON TO TREE

ELEMN8:	MOVD	ELEMND,ELEXND	;MOVE TO NEW NODE

	RCALL	ELEXND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	ELEXND,CODE,XPTR	;INSERT ARRAY OR TABLE NAME

	ADDSON	ELEMND,ELEXND	;ADD AS SON TO TREE

	MOVD	ELEMND,ELEXND	;MOVE TO NEW NODE

ELEAR1:	PUSH	ELEMND	;SAVE CURRENT NODE

	RCALL	ELEXND,EXPR,,RTN1	;EVALUATE ARGUMENT

	POP	ELEMND	;RESTORE CURRENT NODE

	ADDSIB	ELEMND,ELEXND	;ADD AS SIBLING TO TREE

	MOVD	ELEMND,ELEXND	;MOVE TO NEW NODE

	AEQLC	BRTYPE,RBTYP,,ELEMNR

;                                  CHECK FOR RIGHT BRACKET

	AEQLC	BRTYPE,CMATYP,ELECMA,ELEAR1

;                                  VERIFY COMMA

;_

ELEICH:	SETAC	EMSGCL,ILCHAR	;'ILLEGAL CHARACTER IN ELEMENT'

	BRANCH	RTN1	;ERROR RETURN

;_

ELEILI:	AEQLC	STYPE,QLITYP,ELEMN9	;CHECK CAUSE OF RUN OUT

	SETAC	EMSGCL,OPNLIT	;'UNCLOSED LITERAL'

	BRANCH	RTN1	;ERROR RETURN

;_

ELEINT:	SETAC	EMSGCL,ILLINT	;'ILLEGAL INTEGER'

	BRANCH	RTN1	;ERROR RETURN

;_

ELEDEC:	SETAC	EMSGCL,ILLDEC	;'ILLEGAL REAL'

	BRANCH	RTN1	;ERROR RETURN

;_

ELECMA:	SETAC	EMSGCL,ILLBRK	;'ILLEGAL BREAK CHARACTER'

	BRANCH	RTN1	;ERROR RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      EXPRESSION ANALYSIS

;

EXPR:	PROC	,	;PROCEDURE TO COMPILE EXPRESSION

	RCALL	EXELND,ELEMNT,,<RTN1,EXPNUL>

;                                  COMPILE ELEMENT

	SETAC	EXPRND,0	;ZERO EXPRESSION TREE

	BRANCH	EXPR2	;JOIN MAIN PROCESSING

;_

EXPR1:	PUSH	EXPRND	;SAVE EXPRESSION TREE

	RCALL	EXELND,ELEMNT,,<RTN1,EXPERR>

;                                  COMPILE ELEMENT

	POP	EXPRND	;RESTORE EXPRESSION TREE

EXPR2:	RCALL	EXOPCL,BINOP,,<RTN1,EXPR7>

;                                  GET BINARY OPERATOR

	RCALL	EXOPND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	EXOPND,CODE,EXOPCL	;INSERT BINARY OPERATOR

	AEQLC	EXPRND,0,EXPR3	;CHECK FOR EMPTY TREE

	ADDSON	EXOPND,EXELND	;ADD NODE AS SON

	MOVD	EXPRND,EXELND	;MOVE TO NEW NODE

	BRANCH	EXPR1	;CONTINUE PROCESSING

;_

EXPR3:	GETDC	EXOPCL,EXOPCL,2*DESCR

;                                  GET PRECEDENCE DESCRIPTOR

	SETAV	EXOPCL,EXOPCL	;GET LEFT PRECEDENCE

	GETDC	EXEXND,EXPRND,FATHER

;                                  GET FATHER OF NODE

	GETDC	XPTR,EXEXND,CODE	;GET FUNCTION DESCRIPTOR

	GETDC	XPTR,XPTR,2*DESCR	;GET PRECEDENCE DESCRIPTOR

	ACOMP	XPTR,EXOPCL,EXPR4	;COMPARE PRECEDENCES

	ADDSIB	EXPRND,EXOPND	;ADD NODE AS SIBLING

	MOVD	EXPRND,EXOPND	;MOVE TO NEW NODE

	ADDSON	EXPRND,EXELND	;PUT CURRENT NODE AS SON

	MOVD	EXPRND,EXELND	;MOVE TO NEW NODE

	BRANCH	EXPR1	;CONTINUE PROCESSING

;_

EXPR4:	ADDSIB	EXPRND,EXELND	;ADD CURRENT NODE AS SIBLING

EXPR5:	AEQLIC	EXPRND,FATHER,0,,EXPR11

;                                  CHECK FOR ROOT NODE

	GETDC	EXPRND,EXPRND,FATHER

;                                  GET FATHER NODE

	AEQLIC	EXPRND,FATHER,0,,EXPR11

;                                  CHECK FOR ROOT NODE

	GETDC	EXEXND,EXPRND,FATHER

;                                  GET FATHER NODE

	GETDC	XPTR,EXEXND,CODE	;GET FUNCTION DESCRIPTOR

	GETDC	XPTR,XPTR,2*DESCR	;GET PRECEDENCE DESCRIPTOR

	ACOMP	XPTR,EXOPCL,EXPR5	;COMPARE PRECEDENCES

	INSERT	EXPRND,EXOPND	;INSERT NODE ABOVE

	BRANCH	EXPR1	;CONTINUE PROCESSING

;_

EXPR7:	AEQLC	EXPRND,0,EXPR10	;CHECK FOR EMPTY TREE

	MOVD	XPTR,EXELND	;SET UP FOR RETURN

	BRANCH	EXPR9	;JOIN END PROCESSING

;_

EXPR10:	ADDSIB	EXPRND,EXELND	;ADD NODE AS SIBLING

	MOVD	XPTR,EXPRND	;SET UP FOR RETURN

EXPR9:	AEQLIC	XPTR,FATHER,0,,RTXNAM

;                                  CHECK FOR ROOT NODE

	GETDC	XPTR,XPTR,FATHER	;GO BACK TO FATHER

	BRANCH	EXPR9	;CONTINUE UP TREE

;_

EXPR11:	ADDSON	EXOPND,EXPRND	;ADD NODE AS SON

	BRANCH	EXPR1	;CONTINUE PROCESSING

;_

EXPNUL:	RCALL	EXPRND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	EXPRND,CODE,LITCL	;INSERT LITERAL FUNCTION

	RCALL	EXEXND,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	EXEXND,CODE,NULVCL	;INSERT NULL STRING AS VALUE

	ADDSON	EXPRND,EXEXND	;ADD NODE AS SON

	MOVD	XPTR,EXPRND	;SET UP FOR RETURN

	BRANCH	RTXNAM

;_

EXPERR:	SETAC	EMSGCL,ILLEOS	;'ILLEGAL END OF STATEMENT'

	BRANCH	RTN1	;TAKE ERROR RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      LOCATION OF NEXT NONBLANK CHARACTER

;

FORWRD:	PROC	,	;PROCEDURE TO GET TO NEXT CHARACTER

	STREAM	XSP,TEXTSP,FRWDTB,COMP3,FORRUN

;                                  BREAK FOR NEXT NONBLANK

FORJRN:	MOVD	BRTYPE,STYPE	;SET UP BREAK TYPE

	BRANCH	RTN2	;RETURN

;_

FORRUN:	AEQLC	UNIT,0,,FOREOS	;CHECK FOR INPUT STREAM

	AEQLC	LISTCL,0,,FORRUR	;CHECK LISTING SWITCH

	STPRNT	IOKEY,OUTBLK,LNBFSP	;PRINT CARD IMAGE

FORRUR:	STREAD	INBFSP,UNIT,FWADE3,COMP5

;                                  READ NEW CARD IAMGE

	SETSP	TEXTSP,NEXTSP	;SET UP NEW LINE

	STREAM	XSP,TEXTSP,CARDTB,COMP3,COMP3

;                                  DETERMINE CARD TYPE

	RCALL	,NEWCRD,,<FORRUN,FORWRD>

;                                  PROCESS NEW CARD

FOREOS:	MOVD	BRTYPE,EOSCL	;SET UP END-OF-CARD

	BRANCH	RTN2	;RETURN

;_

FORBLK:	PROC	FORWRD	;PROCEDURE TO GET TO NONBLANK

	STREAM	XSP,TEXTSP,IBLKTB,RTN1,FORRUN,FORJRN

;                                  BREAK OUT NONBLANK FROM BLANK

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*


;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

FWADE3:	PUSHJ PDP,EOF
	JRST FORRUR	;RETURN AFTER GETTING ANOTHER FILE NAME

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""


;

;      CARD IMAGE PROCESSING

;

NEWCRD:	PROC	,	;PROCESS NEW CARD IMAGE

	SELBRA	STYPE,<,CMTCRD,CTLCRD,CNTCRD>

;                                  BRANCH ON CARD TYPE

	AEQLC	LISTCL,0,,RTN3	;RETURN IF LISTING IS OFF

	MOVD	XCL,CSTNCL	;COPY OF STATEMENT NUMBER

	INCRA	XCL,1	;INCREMENT NUMBER

	INTSPC	TSP,XCL	;CONVERT IT TO STRING

	AEQLC	LLIST,0,CARDL	;CHECK FOR LEFT LISTING

	SETLC	RNOSP,0	;CLEAR RIGHT SPECIFIER

	APDSP	RNOSP,TSP	;SET TO STATEMENT NUMBER

	BRANCH	RTN3

;_

CARDL:	SETLC	LNOSP,0	;CLEAR LEFT SPECIFIER

	APDSP	LNOSP,TSP	;SET TO STATEMENT NUMBER

	BRANCH	RTN3

;_

CMTCRD:	AEQLC	LISTCL,0,,RTN1	;RETURN IF LISTING IS OFF

CMTCLR:	SETLC	LNOSP,0	;CLEAR LEFT SPECIFIER

	SETLC	RNOSP,0	;CLEAR RIGHT SPECIFIER

	APDSP	LNOSP,BLNSP	;BLANK LEFT SPECIFIER

	APDSP	RNOSP,BLNSP	;BLANK RIGHT SPECIFIER

	BRANCH	RTN1

;_

CNTCRD:	FSHRTN	TEXTSP,1	;REMOVE CONTINUE CHARACTER

	AEQLC	LISTCL,0,,RTN2	;RETURN IF LISTING IS OFF

	INTSPC	TSP,CSTNCL	;GET SPECIFIER FOR NUMBER

	AEQLC	LLIST,0,CARDLL	;CHECK FOR LEFT LISTING

	SETLC	RNOSP,0	;CLEAR RIGHT SPECIFIER

	APDSP	RNOSP,TSP	;SET TO STATEMENT NUMBER

	BRANCH	RTN2

;_

CARDLL:	SETLC	LNOSP,0	;CLEAR LEFT SPECIFIER

	APDSP	LNOSP,TSP	;SET TO STATEMENT NUMBER

	BRANCH	RTN2

;_

CTLCRD:	FSHRTN	TEXTSP,1	;DELETE CONTROL CHARACTER

	STREAM	XSP,TEXTSP,FRWDTB,COMP3,CMTCRD

;                                  GET TO NEXT NONBLANK CHARACTER

	AEQLC	STYPE,NBTYP,CMTCRD	;VERIFY NONBREAK

	STREAM	XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR

;                                  BREAK OUT COMMAND

	LEXCMP	XSP,UNLSP,CTLCR1,,CTLCR1

;                                  IS IT UNLIST?

	SETAC	LISTCL,0	;ZERO LISTING SWITCH

	BRANCH	RTN1	;RETURN

;_

CTLCR1:	LEXCMP	XSP,LISTSP,CTLCR3,,CTLCR3

;                                  IS IT LIST?

	SETAC	LISTCL,1	;TURN ON LISTING

	STREAM	XSP,TEXTSP,FRWDTB,COMP3,CMTCLR

;                                  GET TO NEXT NONBLANK CHARACTER

	AEQLC	STYPE,NBTYP,CMTCLR	;VERIFY NONBREAK

	STREAM	XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR

;                                  GET TYPE OF LISTING

	LEXCMP	XSP,LEFTSP,CTLCR2,,CTLCR2

;                                  IS IT LEFT?

	SETAC	LLIST,1	;SET LEFT LISTING SWITCH

	BRANCH	CMTCLR	;JOIN TERMINAL PROCESSING

;_

CTLCR2:	SETAC	LLIST,0	;ZERO LEFT LISTING AS DEFAULT

	BRANCH	CMTCLR	;JOIN TERMINAL PROCESSING

;_

CTLCR3:	LEXCMP	XSP,EJCTSP,CMTCLR,,CMTCLR

;                                  IS IT EJECT?

	AEQLC	LISTCL,0,,CMTCLR	;SKIP EJECT IF NOT LISTING

	OUTPUX	OUTPUT,EJECTF	;EJECT PAGE

	BRANCH	CMTCLR	;JOIN TERMINAL PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      PUBLICATION OF CODE TREES

;

TREPUB:	PROC	,	;PUBLISH CODE TREE

	POP	YPTR	;RESTORE ROOT NODE

TREPU1:	GETDC	XPTR,YPTR,CODE	;GET CODE DESCRIPTOR

	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,XPTR	;INSERT CODE DESCRIPTOR

	SUM	ZPTR,CMBSCL,CMOFCL	;COMPUTE TOTAL POSITION

	ACOMP	ZPTR,OCLIM,TREPU5	;CHECK AGAINST LIMIT

TREPU4:	AEQLIC	YPTR,LSON,0,,TREPU2	;IS THERE A LEFT SON?

	GETDC	YPTR,YPTR,LSON	;GET LEFT SON

	BRANCH	TREPU1	;CONTINUE

;_

TREPU2:	AEQLIC	YPTR,RSIB,0,,TREPU3	;IS THERE A RIGHT SIBLING?

	GETDC	YPTR,YPTR,RSIB	;GET RIGHT SIBLING

	BRANCH	TREPU1	;CONTINUE

;_

TREPU3:	AEQLIC	YPTR,FATHER,0,,RTN1	;IS THERE A FATHER?

	GETDC	YPTR,YPTR,FATHER	;GET FATHER

	BRANCH	TREPU2	;CONTINUE

;_

TREPU5:	SUM	ZPTR,CMOFCL,CODELT	;COMPUTE ADDITIONAL TO GET

	SETVC	ZPTR,C	;INSERT CODE DATA TYPE

	RCALL	XCL,BLOCK,ZPTR	;ALLOCATE NEW CODE BLOCK

	AEQLC	LPTR,0,,TREPU6	;IS THERE A LAST LABEL?

	PUTDC	LPTR,ATTRIB,XCL	;INSERT NEW CODE POSITION

TREPU6:	MOVBLK	XCL,CMBSCL,CMOFCL	;MOVE OLD CODE

	PUTDC	CMBSCL,DESCR,GOTGCL	;INSERT DIRECT GOTO

	PUTDC	CMBSCL,2*DESCR,DOTCL

;                                  INSERT LITERAL FUNCTION

	PUTDC	CMBSCL,3*DESCR,XCL	;INSERT POINTER TO NEW CODE

	INCRA	CMBSCL,3*DESCR	;UPDATE END POINTER

	RCALL	,SPLIT,<CMBSCL>	;SPLIT OFF OLD PORTION

	MOVD	CMBSCL,XCL	;SET UP NEW COMPILER BASE POINTER

	SUM	OCLIM,CMBSCL,ZPTR	;COMPUTE NEW LIMIT

	DECRA	OCLIM,5*DESCR	;LEAVE SAFETY FACTOR

	BRANCH	TREPU4	;REJOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      UNARY OPERATOR ANALYSIS

;

UNOP:	PROC	,	;UNARY OPERATOR ANALYSIS

	RCALL	,FORWRD,,COMP3	;GET TO NEXT NONBLANK CHARACTER

	SETAC	XPTR,0	;ZERO CODE TREE

	AEQLC	BRTYPE,NBTYP,RTN1	;VERIFY NONBREAK

UNOPA:	STREAM	XSP,TEXTSP,UNOPTB,RTXNAM,COMP3

;                                  BREAK OUT UNARY OPERATOR

	RCALL	YPTR,BLOCK,CNDSIZ	;ALLOCATE BLOCK FOR TREE NODE

	PUTDC	YPTR,CODE,STYPE	;INSERT FUNCTION DESCRIPTOR

	AEQLC	XPTR,0,,UNOPB	;IS TREE EMPTY

	ADDSON	XPTR,YPTR	;ADD NEW NODE AS SON

UNOPB:	MOVD	XPTR,YPTR	;MOVE TO NEW NODE

	BRANCH	UNOPA	;CONTINUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'INTERPRETER EXECUTIVE AND CONTROL PROCEDURES'

;

;      CODE BASING

;

BASE:	PROC	,	;INTERPRETER CODE BASING PROCEDURE

	SUM	OCBSCL,OCBSCL,OCICL	;ADD OFFSET TO BASE

	SETAC	OCICL,0	;ZERO OFFSET

	BRANCH	RTNUL3

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DIRECT GOTO

;

GOTG:	PROC	,	;<X>

	RCALL	OCBSCL,ARGVAL,,INTR5

;                                  GET CODE POINTER

	VEQLC	OCBSCL,C,INTR4	;MUST HAVE CODE DATA TYPE

	SETAC	OCICL,0	;ZERO OFFSET

	BRANCH	RTNUL3

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      LABEL GOTO

;

GOTL:	PROC	,	;(X)

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,GOTLC	;TEST FOR FUNCTION

GOTLV:	ACOMPC	TRAPCL,0,,GOTLV1,GOTLV1

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TLABL,XPTR,GOTLV1

;                                  LOOK FOR LABEL TRACE

	PUSH	XPTR	;SAVE VARIABLE

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	POP	XPTR	;RESTORE VARIABLE

GOTLV1:	DEQL	XPTR,RETCL,GOTL1	;COMPARE WITH RETURN

	RRTURN	,6	;RETURN BY VALUE

;_

GOTL1:	DEQL	XPTR,FRETCL,GOTL2	;COMPARE WITH FRETURN

	RRTURN	,4	;FAIL

;_

GOTL2:	DEQL	XPTR,NRETCL,GOTL3	;COMPARE WITH NRETURN

	RRTURN	,5	;RETURN BY NAME

;_

GOTL3:	GETDC	OCBSCL,XPTR,ATTRIB	;GET OBJECT CODE BASE

	AEQLC	OCBSCL,0,,INTR4	;MUST NOT BE ZERO

	SETAC	OCICL,0	;ZERO OFFSET

	BRANCH	RTNUL3	;RETURN

;_

GOTLC:	RCALL	XPTR,INVOKE,XPTR,<INTR5,,NEMO>

;                                  EVALUATE GOTO

	VEQLC	XPTR,S,INTR4,GOTLV	;VARIABLE MUST BE STRING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      INTERNAL GOTO

;

GOTO:	PROC	,	;INTERPRETER GOTO PROCEDURE

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	OCICL,OCBSCL,OCICL	;GET OFFSET

	BRANCH	RTNUL3	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      STATEMENT INITIALIZATION

;

INIT:	PROC	,	;STATEMENT INITIALIZATION PROCEDURE

	MOVD	LSTNCL,STNOCL	;UPDATE &LASTNO

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XCL,OCBSCL,OCICL	;GET STATEMENT DATA

	MOVA	STNOCL,XCL	;UPDATE &STNO

	SETAV	FRTNCL,XCL	;SET UP FAILURE OFFSET

	ACOMP	EXNOCL,EXLMCL,EXEX,EXEX

;                                  CHECK &STLIMIT

	INCRA	EXNOCL,1	;INCREMENT &STCOUNT

	ACOMPC	TRAPCL,0,,RTNUL3,RTNUL3

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TKEYL,STCTKY,RTNUL3

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	BRANCH	RTNUL3

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      BASIC INTERPRETER PROCEDURE

;

INTERP:	PROC	,	;INTERPRETER CORE PROCEDURE

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,INTERP	;TEST FOR FUNCTION

	RCALL	XPTR,INVOKE,<XPTR>,<,INTERP,INTERP,RTN1,RTN2,RTN3>

	MOVD	OCICL,FRTNCL	;SET OFFSET FOR FAILURE

	INCRA	FALCL,1	;INCREMENT &STFCOUNT

	ACOMPC	TRAPCL,0,,INTERP,INTERP

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TKEYL,FALKY,INTERP

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	BRANCH	INTERP

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      PROCEDURE INVOCATION

;

INVOKE:	PROC	,	;INVOKATION PROCEDURE

	POP	INCL	;GET FUNCTION INDEX

	GETDC	XPTR,INCL,0	;GET PROCEDURE DESCRIPTOR

	VEQL	INCL,XPTR,INVK2	;CHECK ARGUMENT COUNTS

INVK1:	BRANIC	INCL,0	;IF EQUAL, BRANCH INDIRECT

;_

INVK2:	TESTF	XPTR,FNC,ARGNER,INVK1

;                                  CHECK FOR VARIABLE ARGUMENT NUMBER

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'ARGUMENT EVALUATION PROCEDURES'

;

;      ARGUMENT EVALUATION

;

ARGVAL:	PROC	,	;PROCEDURE TO EVALUATE ARGUMENT

	INCRA	OCICL,DESCR	;INCREMENT INTERPRETER OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET ARGUMENT

	TESTF	XPTR,FNC,,ARGVC	;TEST FOR FUNCTION DESCRIPTOR

ARGV1:	AEQLC	INSW,0,,ARGV2	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,XPTR,ARGV2

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET INPUT DESCRIPTOR

	RCALL	XPTR,PUTIN,<ZPTR,XPTR>,<FAIL,RTXNAM>

;_

ARGVC:	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,ARGV1,RTXNAM>

;_

ARGV2:	GETDC	XPTR,XPTR,DESCR	;GET VALUE FROM NAME

	BRANCH	RTXNAM

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      EVALUATION OF UNEVALUATED EXPRESSIONS

;

EXPVAL:	PROC	,	;PROCEDURE TO EVALUATE EXPRESSION

	SETAC	SCL,1	;NOTE PROCEDURE ENTRANCE

EXPVJN:	POP	XPTR	;RESTORE POINTER TO OBJECT CODE

EXPVJ2:	PUSH	<OCBSCL,OCICL,PATBCL,PATICL,WPTR,XCL,YCL,TCL>

	PUSH	<MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL>

;                                  SAVE SYSTEM STATE DESCRIPTORS

	SPUSH	<HEADSP,TSP,TXSP,XSP>

;                                  SAVE SYSTEM STATE SPECIFIERS

	MOVD	OCBSCL,XPTR	;SET UP NEW CODE BASE

	SETAC	OCICL,DESCR	;INITIALIZE OFFSET

	MOVD	PDLHED,PDLPTR	;SET UP NEW HISTORY LIST HEADER

	MOVD	NHEDCL,NAMICL	;SET UP NEW NAME LIST HEADER

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,EXPVC	;CHECK FOR FUNCTION

EXPV11:	AEQLC	SCL,0,,EXPV6	;CHECK PROCEDURE ENTRY

	AEQLC	INSW,0,,EXPV4	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,XPTR,EXPV4

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET INPUT ASSOCIATION

	RCALL	XPTR,PUTIN,<ZPTR,XPTR>,<EXPV1,EXPV6>

;                                  PERFORM INPUT

;_

EXPV4:	GETDC	XPTR,XPTR,DESCR	;GET VALUE

EXPV6:	SETAC	SCL,2	;SET UP EXIT

	BRANCH	EXPV7	;JOIN PROCESSING

;_

EXPV9:	POP	SCL	;POPOFF SWITCH

EXPV1:	SETAC	SCL,1	;SET NEW EXIT SWITCH

EXPV7:	SPOP	<XSP,TXSP,TSP,HEADSP>

;                                  RESTORE SYSTEM SPECIFIERS

	POP	<NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN>

	POP	<TCL,YCL,XCL,WPTR,PATICL,PATBCL,OCICL,OCBSCL>

;                                  RESTORE SYSTEM DESCRIPTORS

	SELBRA	SCL,<FAIL,RTXNAM,RTZPTR>

;                                  SELECT EXIT

;_

EXPVC:	PUSH	SCL	;SAVE ENTRANCE INDICATOR

	RCALL	XPTR,INVOKE,XPTR,<EXPV9,EXPV5,>

;                                  EVALUATE FUNCTION

	POP	SCL	;RESTORE ENTRANCE INDICATOR

	AEQLC	SCL,0,EXPV6	;CHECK ENTRY INDICATOR

	SETAC	SCL,3	;SET EXIT SWITCH

	MOVD	ZPTR,XPTR	;SET UP VALUE

	BRANCH	EXPV7	;JOIN END PROCESSING

;_

EXPV5:	POP	SCL	;RESTORE ENTRY INDICATOR

	BRANCH	EXPV11	;JOIN PROCESSING WITH NAME

;_

EXPEVL:	PROC	EXPVAL	;PROCEDURE TO GET EXPRESSION VALUE

	SETAC	SCL,0	;SET ENTRY INDICATOR

	BRANCH	EXPVJN	;JOIN PROCESSING

;_

EVAL:	PROC	EXPVAL	;EVAL(X)

	RCALL	XPTR,ARGVAL,,FAIL	;GET ARGUMENT

	VEQLC	XPTR,E,,EVAL1	;IS IT EXPRESSION?

	VEQLC	XPTR,I,,RTXPTR	;INTEGER IS IDEMPOTENT

	VEQLC	XPTR,R,,RTXPTR	;REAL IS IDEMPOTENT

	VEQLC	XPTR,S,INTR1	;IS IT STRING?

	LOCSPX	XSP,XPTR	;GET SPECIFIER
;VERSION 3.3 ADDITION
	LEQLC XSP,0,,RTXPTR
;VERSION 3.3 ADDITION END

	SPCINT	XPTR,XSP,,RTXPTR	;CONVERT TO INTEGER

	SPREAL	XPTR,XSP,,RTXPTR	;CONVERT TO REAL

	MOVD	ZPTR,XPTR	;SET UP TO CONVERT TO EXPRESSION

	RCALL	XPTR,CONVE,,<FAIL,INTR10>

;                                  CONVERT TO EXPRESSION

EVAL1:	SETAC	SCL,0	;SET UP ENTRY INDICATOR

	BRANCH	EXPVJ2	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      EVALUATION OF INTEGER ARGUMENT

;

INTVAL:	PROC	,	;INTEGER ARGUMENT PROCEDURE

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,INTVC	;CHECK FOR FUNCTION

INTV1:	AEQLC	INSW,0,,INTV3	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,XPTR,INTV3

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET ASSOCIATION

	RCALL	XPTR,PUTIN,<ZPTR,XPTR>,FAIL

;                                  PERFORM INPUT

INTV:	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR STRING

	SPCINT	XPTR,XSP,INTR1,RTXNAM

;                                  CONVERT TO INTEGER

;_

INTV3:	GETDC	XPTR,XPTR,DESCR	;GET VALUE

INTV2:	VEQLC	XPTR,I,,RTXNAM	;INTEGER DESIRED

	VEQLC	XPTR,S,INTR1,INTV	;STRING MUST BE CONVERTED

;_

INTVC:	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,INTV1,INTV2>

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      EVALUATION OF ARGUMENT AS PATTERN

;

PATVAL:	PROC	,	;EVALUATE ARGUMENT AS PATTERN

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,PATVC	;CHECK FOR FUNCTION DESCRIPTOR

PATV1:	AEQLC	INSW,0,,PATV2	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,XPTR,PATV2

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET ASSOCIATION

	RCALL	XPTR,PUTIN,<ZPTR,XPTR>,<FAIL,RTXNAM>

;                                  PERFORM INPUT

;_

PATVC:	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,PATV1,PATV3>

;                                  EVALUATE ARGUMENT

;_

PATV2:	GETDC	XPTR,XPTR,DESCR	;GET VALUE

PATV3:	VEQLC	XPTR,P,,RTXNAM	;IS IT PATTERN?

	VEQLC	XPTR,S,,RTXNAM	;IS IT STRING?

	VEQLC	XPTR,I,,GENVIX	;IS IT INTEGER?

	VEQLC	XPTR,R,,PATVR	;IS IT REAL?

	VEQLC	XPTR,E,INTR1	;IS IT EXPRESSION?

	RCALL	TPTR,BLOCK,STARSZ	;ALLOCATE BLOCK FOR PATTERN

	MOVBLK	TPTR,STRPAT,STARSZ	;COPY PATTERN FOR EXPRESSION

	PUTDC	TPTR,4*DESCR,XPTR	;INSERT EXPRESSION

	MOVD	XPTR,TPTR	;SET UP VALUE

	BRANCH	RTXNAM	;RETURN

;_

PATVR:	REALST	XSP,XPTR	;CONVERT REAL TO STRING

	RCALL	XPTR,GENVAR,XSPPTR,RTXNAM

;                                  GENERATE VARIABLE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      EVALUATION OF ARGUMENT AS STRING

;

VARVAL:	PROC	,	;EVALUATE ARGUMENT AS STRING

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,VARVC	;CHECK FOR FUNCTION

VARV1:	AEQLC	INSW,0,,VARV4	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,XPTR,VARV4

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET INPUT ASSOCIATION

	RCALL	XPTR,PUTIN,<ZPTR,XPTR>,<FAIL,RTXNAM>

;                                  PERFORM INPUT

;_

VARV4:	GETDC	XPTR,XPTR,DESCR	;GET VALUE

VARV2:	VEQLC	XPTR,S,,RTXNAM	;IS IT STRING?

	VEQLC	XPTR,I,INTR1,GENVIX	;CONVERT INTEGER TO STRING

;_

VARVC:	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,VARV1,VARV2>

;                                  EVALUATE FUNCTION

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      EVALUATION OF ARGUMENT PAIR

;

XYARGS:	PROC	,	;PROCEDURE TO EVALUATE ARGUMENT PAIR

	SETAC	SCL,0	;NOTE FIRST ARGUMENT

XYN:	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	YPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	YPTR,FNC,,XYC	;CHECK FOR FUNCTION

XY1:	AEQLC	INSW,0,,XY2	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,YPTR,XY2	;LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET INPUT ASSOCIATION

	RCALL	YPTR,PUTIN,<ZPTR,YPTR>,FAIL

;                                  PERFORM INPUT

XY3:	AEQLC	SCL,0,RTN2	;CHECK FOR COMPLETION

	SETAC	SCL,1	;NOTE SECONF ARGUMENT

	MOVD	XPTR,YPTR	;SET UP FIRST ARGUMENT

	BRANCH	XYN	;GO AROUND AGAIN

;_

XY2:	GETDC	YPTR,YPTR,DESCR	;GET VALUE

	BRANCH	XY3	;CONTINUE

;_

XYC:	PUSH	<SCL,XPTR>	;SAVE INDICATOR AND ARGUMENT

	RCALL	YPTR,INVOKE,<YPTR>,<FAIL,XY4>

;                                  EVALUATE FUNCTION

	POP	<XPTR,SCL>	;RESTORE INDICATOR AND ARGUMENT

	BRANCH	XY3	;JOIN PROCESSING

;_

XY4:	POP	<XPTR,SCL>	;RESTORE INDICATOR AND ARGUMENT

	BRANCH	XY1	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'ARITHMETIC OPERATIONS, PREDICATES, AND FUNCTIONS'

ADD:	PROC	,	;X + Y

	SETAC	SCL,1

	BRANCH	ARITH

;_

DIV:	PROC	ADD	;X / Y

	SETAC	SCL,2

	BRANCH	ARITH

;_

EXP:	PROC	ADD	;X ** Y AND X > Y

	SETAC	SCL,3

	BRANCH	ARITH

;_

MPY:	PROC	ADD	;X * Y

	SETAC	SCL,4

	BRANCH	ARITH

;_

SUB:	PROC	ADD	;X - Y

	SETAC	SCL,5

	BRANCH	ARITH

;_

EQ:	PROC	ADD	;EQ(X,Y)

	SETAC	SCL,6

	BRANCH	ARITH

;_

GE:	PROC	ADD	;GE(X,Y)

	SETAC	SCL,7

	BRANCH	ARITH

;_

GT:	PROC	ADD	;GT(X,Y)

	SETAC	SCL,8

	BRANCH	ARITH

;_

LE:	PROC	ADD	;LE(X,Y)

	SETAC	SCL,9

	BRANCH	ARITH

;_

LT:	PROC	ADD	;LT(X,Y)

	SETAC	SCL,10

	BRANCH	ARITH

;_

NE:	PROC	ADD	;NE(X,Y)

	SETAC	SCL,11

	BRANCH	ARITH

;_

REMDR:	PROC	ADD	;REMDR(X,Y)

	SETAC	SCL,12

	BRANCH	ARITH

;_

ARITH:	PUSH	SCL	;SAVE PROCEDURE SWITCH

	RCALL	,XYARGS,,FAIL	;EVALUATE ARGUMENTS

	POP	SCL	;RESTORE PROCEDURE SWITCH

	SETAV	DTCL,XPTR	;SET UP DATA TYPE PAIR

	MOVV	DTCL,YPTR

	DEQL	DTCL,IIDTP,,ARTHII	;INTEGER-INTEGER

	DEQL	DTCL,IVDTP,,ARTHIV	;INTEGER-STRING

	DEQL	DTCL,VIDTP,,ARTHVI	;STRING-INTEGER

	DEQL	DTCL,VVDTP,,ARTHVV	;STRING-STRING

	DEQL	DTCL,RRDTP,,ARTHRR	;REAL-REAL

	DEQL	DTCL,IRDTP,,ARTHIR	;INTEGER-REAL

	DEQL	DTCL,RIDTP,,ARTHRI	;REAL-INTEGER

	DEQL	DTCL,VRDTP,,ARTHVR	;STRING-REAL

	DEQL	DTCL,RVDTP,INTR1,ARTHRV

;                                  REAL-STRING

;_

ARTHII:	SELBRA	SCL,<AD,DV,EX,MP,SB,CEQ,CGE,CGT,CLE,CLT,CNE,RM>

;_

ARTHVI:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	SPCINT	XPTR,XSP,,ARTHII	;CONVERT STRING TO INTEGER

	SPREAL	XPTR,XSP,INTR1,ARTHRI

;                                  CONVERT TO REAL IF POSSIBLE

;_

ARTHIV:	LOCSPX	YSP,YPTR	;GET SPECIFIER

	SPCINT	YPTR,YSP,,ARTHII	;CONVERT STRING TO INTEGER

	SPREAL	YPTR,YSP,INTR1,ARTHIR

;                                  CONVERT TO REAL IF POSSIBLE

;_

ARTHVV:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	SPCINT	XPTR,XSP,,ARTHIV	;CONVERT STRING TO INTEGER

	SPREAL	XPTR,XSP,INTR1,ARTHRV

;                                  CONVERT TO REAL IF POSSIBLE

;_

ARTHRR:	SELBRA	SCL,<AR,DR,EXR,MR,SR,REQ,RGE,RGT,RLE,RLT,RNE,INTR1>

;_

ARTHIR:	INTRL	XPTR,XPTR	;CONVERT INTEGER TO REAL

	BRANCH	ARTHRR

;_

ARTHRI:	INTRL	YPTR,YPTR	;CONVERT INTEGER TO REAL

	BRANCH	ARTHRR

;_

ARTHVR:	LOCSPX	XSP,XPTR	;GET SPEDIFIER

	SPCINT	XPTR,XSP,,ARTHIR	;CONVERT STRING TO INTEGER

	SPREAL	XPTR,XSP,INTR1,ARTHRR

;                                  CONVERT TO REAL IF POSSIBLE

;_

ARTHRV:	LOCSPX	YSP,YPTR

	SPCINT	YPTR,YSP,,ARTHRI	;CONVERT STRING TO INTEGER

	SPREAL	YPTR,YSP,INTR1,ARTHRR

;                                  CONVERT TO REAL IF POSSIBLE

;_

AD:	SUM	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

DV:	DIVIDE	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

EX:	EXPINT	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

MP:	MULT	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

SB:	SUBTRT	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

CEQ:	AEQL	XPTR,YPTR,FAIL,RETNUL

;_

CGE:	ACOMP	XPTR,YPTR,RETNUL,RETNUL,FAIL

;_

CGT:	ACOMP	XPTR,YPTR,RETNUL,FAIL,FAIL

;_

CLE:	ACOMP	XPTR,YPTR,FAIL,RETNUL,RETNUL

;_

CLT:	ACOMP	XPTR,YPTR,FAIL,FAIL,RETNUL

;_

CNE:	AEQL	XPTR,YPTR,RETNUL,FAIL

;_

AR:	ADREAL	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

DR:	DVREAL	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

EXR:	EXREAL	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

MR:	MPREAL	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

SR:	SBREAL	ZPTR,XPTR,YPTR,AERROR,ARTN

;_

REQ:	RCOMP	XPTR,YPTR,FAIL,RETNUL,FAIL

;_

RGE:	RCOMP	XPTR,YPTR,RETNUL,RETNUL,FAIL

;_

RGT:	RCOMP	XPTR,YPTR,RETNUL,FAIL,FAIL

;_

RLE:	RCOMP	XPTR,YPTR,FAIL,RETNUL,RETNUL

;_

RLT:	RCOMP	XPTR,YPTR,FAIL,FAIL,RETNUL

;_

RNE:	RCOMP	XPTR,YPTR,RETNUL,FAIL,RETNUL

;_

RM:	DIVIDE	ZPTR,XPTR,YPTR,AERROR

;                                  FIRST DIVIDE

	MULT	WPTR,ZPTR,YPTR	;MULTIPLY TRUNCATED PART

	SUBTRT	ZPTR,XPTR,WPTR	;GET DIFFERENCE

	BRANCH	ARTN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      INTEGER(X)

;

INTGER:	PROC	,	;INTEGER(X)

	RCALL	XPTR,ARGVAL,,FAIL	;GET ARGUMENT

	VEQLC	XPTR,I,,RETNUL	;INTEGER SUCCEEDS

	VEQLC	XPTR,S,FAIL	;STRING MUST BE CHECKED

	LOCSPX	XSP,XPTR	;GET SPECIFIER

	SPCINT	XPTR,XSP,FAIL,RETNUL

;                                  TRY CONVERSION TO INTEGER

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ARITHMETIC NEGATIVE

;

MNS:	PROC	,	;-X

	RCALL	XPTR,ARGVAL,,FAIL	;GET ARGUMENT

	VEQLC	XPTR,I,,MNSM	;INTEGER ACCEPTABLE

	VEQLC	XPTR,S,,MNSV	;STRING MUST BE CONVERTED

	VEQLC	XPTR,R,INTR1,MNSR	;REAL IS ACCEPTABLE

;_

MNSM:	MNSINT	ZPTR,XPTR,AERROR,ARTN

;                                  FORM NEGATIVE OF INTEGER

;_

MNSV:	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR STRING

	SPCINT	XPTR,XSP,,MNSM	;CONVERT TO INTEGER

	SPREAL	XPTR,XSP,INTR1	;CONVERT TO REAL

MNSR:	MNREAL	ZPTR,XPTR	;FORM NEGATIVE OF REAL

	BRANCH	ARTN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      UNARY PLUS OPERATOR

;

PLS:	PROC	,	;+X

	RCALL	ZPTR,ARGVAL,,FAIL	;GET ARGUMENT

	VEQLC	ZPTR,I,,ARTN	;IS IT INTEGER?

	VEQLC	ZPTR,S,,PLSV	;IS IT STRING?

	VEQLC	ZPTR,R,INTR1,ARTN	;IS IT REAL?

;_

PLSV:	LOCSPX	XSP,ZPTR	;GET SPECIFIER

	SPCINT	ZPTR,XSP,,ARTN	;CONVERT STRING TO INTEGER

	SPREAL	ZPTR,XSP,INTR1,ARTN	;CONVERT STRING TO REAL

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'PATTERN-VALUED FUNCTIONS AND OPERATIONS'

ANY:	PROC	,	;ANY(S)

	PUSH	ANYCCL	;SAVE FUNCTION DESCRIPTOR

	BRANCH	CHARZ	;JOIN COMMON PROCESSING

;_

BREAK:	PROC	ANY	;BREAK(S)

	PUSH	BRKCCL	;SAVE FUNCTION DESCRIPTOR

	PUSH	ZEROCL	;SAVE MINIMUM LENGTH OF ZERO

	BRANCH	ABNSND	;JOIN COMMON PROCESSING

;_

NOTANY:	PROC	ANY	;NOTANY(S)

	PUSH	NNYCCL	;SAVE FUNCTION DESCRIPTOR

	BRANCH	CHARZ

;_

SPAN:	PROC	ANY	;SPAN(S)

	PUSH	SPNCCL	;SAVE FUNCTION DESCRIPTOR

CHARZ:	PUSH	CHARCL	;SAVE MINIMUM LENGTH OF ONE

ABNSND:	RCALL	XPTR,ARGVAL,,FAIL	;EVALUATE ARGUMENT

	POP	<ZCL,YCL>	;RESTORE DESCRIPTOR AND LENGTH

	VEQLC	XPTR,S,,PATNOD	;STRING IS ACCEPTABLE ARGUMENT

	VEQLC	XPTR,E,,PATNOD	;SO IS EXPRESSION

	VEQLC	XPTR,I,INTR1	;INTEGER MUST BE CONVERTED

	RCALL	XPTR,GNVARI,XPTR

PATNOD:	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR PATTERN

	MAKNOD	ZPTR,TPTR,ZCL,ZEROCL,YCL,XPTR

;                                  CONSTRUCT THE PATTERN

	BRANCH	RTZPTR

;_

LEN:	PROC	ANY	;LEN(N)

	PUSH	LNTHCL	;SAVE FUNCTION DESCRIPTOR

	BRANCH	LPRTND

;_

POS:	PROC	ANY	;POS(N)

	PUSH	POSICL	;SAVE FUNCTION DESCRIPTOR

	BRANCH	LPRTND

;_

RPOS:	PROC	ANY	;RPOS(N)

	PUSH	RPSICL	;SAVE FUNCTION DESCRIPTOR

	BRANCH	LPRTND

;_

RTAB:	PROC	ANY	;RTAB(N)

	PUSH	RTBCL	;SAVE FUNCTION DESCRIPTOR

	BRANCH	LPRTND

;_

TAB:	PROC	ANY	;TAB(N)

	PUSH	TBCL	;SAVE FUNCTION DESCRIPTOR

LPRTND:	RCALL	XPTR,ARGVAL,,FAIL	;EVALUATE ARGUMENT

	POP	YCL	;RESTORE FUNCTION DESCRIPTOR

	MOVD	ZCL,ZEROCL	;PREDICT MINIMUM LENGTH OF ZERO

	VEQLC	XPTR,I,,LPRTNI	;IF INTEGER CHECK FOR LEN

	VEQLC	XPTR,E,,PATNOD	;EXPRESSION IS ACCEPTABLE

	VEQLC	XPTR,S,INTR1	;STRING MUST BE CONVERTED TO INTEGER

	LOCSPX	ZSP,XPTR	;GET SPECIFIER

	SPCINT	XPTR,ZSP,INTR1	;CONVERT TO INTEGER

LPRTNI:	DEQL	YCL,LNTHCL,PATNOD	;CHECK FOR LEN

	MOVA	ZCL,XPTR	;IF SO, USE VALUE OF INTEGER

	BRANCH	PATNOD	;GO FORM PATTERN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ARBNO(P)

;

ARBNO:	PROC	,	;ARBNO(P)

	RCALL	XPTR,PATVAL,,FAIL	;EVALUATE ARGUMENT AS PATTERN

	VEQLC	XPTR,P,,ARBP	;PATTERN IS DESIRED FORM

	VEQLC	XPTR,S,INTR1	;STRING MUST BE MADE INTO PATTERN

	LOCSPX	TSP,XPTR	;GET SPECIFIER

	GETLG	TMVAL,TSP	;GET LENGTH OF STRING

	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR ARGUMENT

	MAKNOD	XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR

ARBP:	GETSIZ	XSIZ,XPTR	;GET SIZE OF PATTERN

	SUM	TSIZ,XSIZ,ARBSIZ	;ADD ADDITIONAL SPACE FOR ARBNO NODE

	SETVC	TSIZ,P	;INSERT PATTERN DATA TYPE

	RCALL	TPTR,BLOCK,TSIZ	;ALLOCATE BLOCK FOR PATTERN

	MOVD	ZPTR,TPTR	;SAVE POINTER TO RETURN

	GETSIZ	TSIZ,ARHEAD	;SET UP COPY FOR HEADING NODE

	CPYPAT	TPTR,ARHEAD,ZEROCL,ZEROCL,ZEROCL,TSIZ

	SUM	ZSIZ,XSIZ,TSIZ

	CPYPAT	TPTR,XPTR,ZEROCL,TSIZ,ZSIZ,XSIZ

	SUM	TSIZ,NODSIZ,NODSIZ	;SET UP SIZE FOR TRAILING NODE

	CPYPAT	TPTR,ARTAIL,ZEROCL,ZSIZ,ZEROCL,TSIZ

	SUM	ZSIZ,TSIZ,ZSIZ	;SET UP SIZE FOR BACKUP NODE

	CPYPAT	TPTR,ARBACK,ZEROCL,ZSIZ,TSIZ,TSIZ

	BRANCH	RTZPTR

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      `X

;

ATOP:	PROC	,	;`X

	INCRA	OCICL,DESCR	;INCREMENT INTERPRETER OFFSET

	GETD	YPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	YPTR,FNC,ATOP1	;TEST FOR FUNCTION DESCRIPTOR

	RCALL	YPTR,INVOKE,YPTR,<FAIL,ATOP1,>

	VEQLC	YPTR,E,NEMO	;ONLY EXPRESSION CAN BE VALUE

ATOP1:	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE PATTERN NODE

	MAKNOD	ZPTR,TPTR,ZEROCL,ZEROCL,ATOPCL,YPTR

	BRANCH	RTZPTR

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      VALUE ASSIGNMENT OPERATORS

;

NAM:	PROC	,	;X . Y

	PUSH	ENMECL	;SAVE FUNCTION DESCRIPTOR

	BRANCH	NAM5	;JOIN PROCESSING

;_

DOL:	PROC	NAM	;X $ Y

	PUSH	ENMICL	;SAVE FUNCTION DESCRITPOR

NAM5:	RCALL	XPTR,PATVAL,,FAIL	;GET PATTERN FOR FIRST ARGUMENT

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	YPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	YPTR,FNC,,NAMC2	;CHECK FOR FUNCTION

NAM3:	VEQLC	XPTR,S,,NAMV	;IS FIRST ARGUMENT STRING?

	VEQLC	XPTR,P,INTR1,NAMP	;IS IT PATTERN?

;_

NAMC2:	PUSH	XPTR	;SAVE FIRST ARGUMENT

	RCALL	YPTR,INVOKE,YPTR,<FAIL,NAM4,>

;                                  EVALUATE SECOND ARGUMENT

	VEQLC	YPTR,E,NEMO	;VERIFY EXPRESSION

NAM4:	POP	XPTR	;RESTORE FIRST ARGUMENT

	BRANCH	NAM3	;JOIN PROCESSING

;_

NAMV:	LOCSPX	TSP,XPTR	;GET SPECIFIER

	GETLG	TMVAL,TSP	;GET LENGTH

	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR PATTERN

	MAKNOD	XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR

;                                  MAKE PATTERN NODE

NAMP:	RCALL	TPTR,BLOCK,SNODSZ	;ALLOCATE BLOCK FOR PATTERN

	MAKNOD	WPTR,TPTR,ZEROCL,ZEROCL,NMECL

;                                  MAKE NODE FOR NAMING

	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR  PATTERN

	POP	TVAL	;RESTORE FUNCTION DESCRIPTOR

	MAKNOD	YPTR,TPTR,ZEROCL,ZEROCL,TVAL,YPTR

;                                  MAKE PATTERN FOR BACKUP

	GETSIZ	XSIZ,XPTR	;GET SIZE OF FIRST PATTERN

	SUM	YSIZ,XSIZ,NODSIZ	;COMPUTE TOTAL SIZE

	GETSIZ	TSIZ,YPTR	;GET SIZE OF NAMING NODE

	SUM	ZSIZ,YSIZ,TSIZ	;COMPUTE TOTAL

	SETVC	ZSIZ,P	;INSERT PATTERN DATA TYPE

	RCALL	TPTR,BLOCK,ZSIZ	;ALLOCATE BLOCK FOR TOTAL PATTERN

	MOVD	ZPTR,TPTR	;SAVE COPY

	LVALUE	TVAL,XPTR	;GET LEAST VALUE

	CPYPAT	TPTR,WPTR,TVAL,ZEROCL,NODSIZ,NODSIZ

;                                  COPY THREE PATTERNS

	CPYPAT	TPTR,XPTR,ZEROCL,NODSIZ,YSIZ,XSIZ

	CPYPAT	TPTR,YPTR,ZEROCL,YSIZ,ZEROCL,TSIZ

	BRANCH	RTZPTR	;RETURN PATTERN AS VALUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      BINARY ALTERNATION OPERATOR

;

OR:	PROC	,	;X ! Y

	RCALL	XPTR,PATVAL,,FAIL	;GET FIRST ARGUMENT

	PUSH	XPTR	;SAVE FIRST ARGUMENT

	RCALL	YPTR,PATVAL,,FAIL	;GET SECOND ARGUMENT

	POP	XPTR	;RESTORE FIRST ARGUMENT

	SETAV	DTCL,XPTR	;GET FIRST DATA TYPE

	MOVV	DTCL,YPTR	;INSERT SECOND DATA TYPE

	DEQL	DTCL,VVDTP,,ORVV	;IS IT STRING-STRING?

	DEQL	DTCL,VPDTP,,ORVP	;IS IT STRING-PATTERN?

	DEQL	DTCL,PVDTP,,ORPV	;IS IT PATTERN-STRING?

	DEQL	DTCL,PPDTP,INTR1,ORPP

;                                  IS IT PATTERN_PATTERN?

;_

ORVV:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	GETLG	TMVAL,XSP	;GET LENGTH

	RCALL	TPTR,BLOCK,LNODSZ	;GET BLOCK FOR PATTERN

	MAKNOD	XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR

;                                  CONSTRUCT PATTERN

ORPV:	LOCSPX	YSP,YPTR	;GET SPECIFIER

	GETLG	TMVAL,YSP	;GET LENGTH

	RCALL	TPTR,BLOCK,LNODSZ	;GET BLOCK FOR PATTERN

	MAKNOD	YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR

;                                  CONSTRUCT PATTERN

ORPP:	GETSIZ	XSIZ,XPTR	;GET SIZE OF FIRST PATTERN

	GETSIZ	YSIZ,YPTR	;GET SIZE OF SECOND PATTERN

	SUM	TSIZ,XSIZ,YSIZ	;COMPUTE TOTAL SIZE

	SETVC	TSIZ,P	;INSERT PATTERN DATA TYPE

	RCALL	TPTR,BLOCK,TSIZ	;ALLOCATE BLOCK FOR PATTERN

	MOVD	ZPTR,TPTR	;SAVE COPY

	CPYPAT	TPTR,XPTR,ZEROCL,ZEROCL,ZEROCL,XSIZ

;                                  COPY FIRST PATTERN

	CPYPAT	TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ

;                                  COPY SECOND PATTERN

	LINKOR	ZPTR,XSIZ	;LINK ALTERNATIVES

	BRANCH	RTZPTR	;RETURN PATTERN AS VALUE

;_

ORVP:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	GETLG	TMVAL,XSP	;GET LENGTH

	RCALL	TPTR,BLOCK,LNODSZ	;GET BLOCK FOR PATTERN

	MAKNOD	XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR

;                                  CONSTRUCT PATTERN

	BRANCH	ORPP	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'PATTERN MATCHING PROCEDURES'

;

;      SIMPLE PATTERN MATCHING

;

SCAN:	PROC	,	;PATTERN MATCHING

	RCALL	XPTR,ARGVAL,,FAIL	;GET SUBJECT

	PUSH	XPTR	;SAVE SUBJECT

	RCALL	YPTR,PATVAL,,FAIL	;GET PATTERN

	POP	XPTR	;RESTORE SUBJECT

	SETAV	DTCL,XPTR	;SET UP DATA TYPE PAIR

	MOVV	DTCL,YPTR

	INCRA	SCNCL,1	;INCREMENT COUNT OF SCANNER ENTRIES

	DEQL	DTCL,VVDTP,,SCANVV	;IS IT STRING-STRING?

	DEQL	DTCL,VPDTP,,SCANVP	;IS IT STRING-PATTERN?

	DEQL	DTCL,IVDTP,,SCANIV	;IS IT INTEGER-STRING?

	DEQL	DTCL,RVDTP,,SCANRV	;IS IT REAL-STRING?

	DEQL	DTCL,RPDTP,,SCANRP	;IS IT REAL-PATTERN?

	DEQL	DTCL,IPDTP,INTR1,SCANIP

;                                  IS IT INTEGER-PATTERN?

;_

SCANVV:	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR SUBJECT

	LOCSPX	YSP,YPTR	;GET SPECIFIER FOR PATTERN

SCANVB:	SUBSP	TSP,YSP,XSP,FAIL	;GET PART TO COMPARE

	LEXCMP	TSP,YSP,,RETNUL	;COMPARE STRINGS

	AEQLC	ANCCL,0,FAIL	;CHECK &ANCHOR

	FSHRTN	XSP,1	;DELETE LEAD CHARACTER

	BRANCH	SCANVB	;TRY AGAIN

;_

SCANIV:	RCALL	XPTR,GNVARI,XPTR	;GENERATE VARIABLE FOR INTEGER

	BRANCH	SCANVV	;JOIN PROCESSING

;_

SCANVP:	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR SUBJECT

	RCALL	,SCNR,,<FAIL,,FAIL>	;CALL SCANNER

	RCALL	,NMD,,<FAIL,RTN2>	;PERFORM NAMING

;_

SCANIP:	RCALL	XPTR,GNVARI,XPTR	;GENERATE VARIABLE FOR INTEGER

	BRANCH	SCANVP	;JOIN PROCESSING

;_

SCANRV:	REALST	XSP,XPTR	;CONVERT REAL TO STRING

	RCALL	XPTR,GENVAR,XSPPTR,SCANVV

;_

SCANRP:	REALST	XSP,XPTR	;CONVERT REAL TO STRING

	RCALL	XPTR,GENVAR,XSPPTR,SCANVP

;                                  GENERATE VARIABLE

;_

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      PATTERN MATCHING WITH REPLACEMENT

;

SJSR:	PROC	,	;PATTERN MATCHING WITH REPLACEMENT

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	WPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	WPTR,FNC,,SJSRC1	;CHECK FOR FUNCTION

SJSR1:	AEQLC	INSW,0,,SJSR1A	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,WPTR,SJSR1A

;                                  LOOK OF INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET ASSOCIATION

	RCALL	XPTR,PUTIN,<ZPTR,WPTR>,<FAIL,SJSR1B>

;                                  PERFORM INPUT

;_

SJSR1A:	GETDC	XPTR,WPTR,DESCR	;GET VALUE

SJSR1B:	PUSH	<WPTR,XPTR>	;SAVE NAME AND VALUE

	RCALL	YPTR,PATVAL,,FAIL	;GET PATTERN

	POP	XPTR	;RESTORE VALUE

	SETAV	DTCL,XPTR	;SET UP DATA TYPE PAIR

	MOVV	DTCL,YPTR

	INCRA	SCNCL,1	;INCREMENT COUNT OF SCANNER CALLS

	DEQL	DTCL,VVDTP,,SJSSVV	;IS IT STRING-PATTERN?

	DEQL	DTCL,VPDTP,,SJSSVP	;IS IT INTEGER-STRING?

	DEQL	DTCL,IVDTP,,SJSSIV	;IS IT INTEGER-PATTERN?

	DEQL	DTCL,RVDTP,,SJSSRV	;IS IT REAL-STRING?

	DEQL	DTCL,RPDTP,,SJSSRP	;IS IT REAL-PATTERN?

	DEQL	DTCL,IPDTP,INTR1,SJSSIP

;_

SJSRC1:	RCALL	WPTR,INVOKE,<WPTR>,<FAIL,SJSR1,NEMO>

;                                  EVALUATE SUBJECT

;_

SJSSVP:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	RCALL	,SCNR,,<FAIL,,FAIL>	;CALL SCANNER

	SETAC	NAMGCL,1	;SET NAMING SWITCH

	REMSX	TAILSP,XSP,TXSP	;GET TAIL OF SUBJECT

	BRANCH	SJSS1	;JOIN COMMON PROCESSING

;_

SJSSIP:	RCALL	XPTR,GNVARI,XPTR	;GENERATE STRING FROM INTEGER

	BRANCH	SJSSVP	;JOIN COMMON PROCESSING

;_

SJSSIV:	RCALL	XPTR,GNVARI,XPTR	;GENERATE STRING FROM INTEGER

	BRANCH	SJSSVV	;JOIN COMMON PROCESSING

;_

SJSSRV:	REALST	XSP,XPTR	;CONVERT REAL TO STRING

	RCALL	XPTR,GENVAR,XSPPTR,SJSSVV

;                                  GENERATE VARIABLE

;_

SJSSRP:	REALST	XSP,XPTR	;CONVERT REAL TO STRING

	RCALL	XPTR,GENVAR,XSPPTR,SJSSVP

;                                  GENERATE VARIABLE

;_

SJVVON:	AEQLC	ANCCL,0,FAIL	;CHECK &ANCHOR

	ADDLG	HEADSP,ONECL	;INCREMENT LENGTH OF HEAD

	FSHRTN	XSP,1	;DELETE HEAD CHARACTER

	BRANCH	SJSSV2	;JOIN COMMON PROCESSING

;_

SJSSVV:	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR SUBJECT

	LOCSPX	YSP,YPTR	;GET SPECIFIER FOR PATTERN

	SETSP	HEADSP,XSP	;SET UP HEAD SPECIFIER

	SETLC	HEADSP,0	;INITIALIZE ZERO LENGTH

SJSSV2:	SUBSP	TSP,YSP,XSP,FAIL	;GET COMMON LENGTH

	LEXCMP	TSP,YSP,SJVVON,,SJVVON

;                                  COMPARE STRINGS

	SETAC	NAMGCL,0	;CLEAR NAMING SWITCH

	REMSX	TAILSP,XSP,TSP	;GET TAIL OF SUBJECT

SJSS1:	SPUSH	<TAILSP,HEADSP>	;SAVE HEAD AND TAIL

	AEQLC	NAMGCL,0,,SJSS1A	;CHECK NAMING SWITCH

	RCALL	,NMD,,FAIL	;PERFORM NAMING

SJSS1A:	RCALL	ZPTR,ARGVAL,,FAIL	;GET OBJECT

	SPOP	<HEADSP,TAILSP>	;RESTORE HEAD AND TAIL

	POP	WPTR	;RESTORE NAME OF SUBJECT

	LEQLC	HEADSP,0,SJSSDT	;CHECK FOR NULL HEAD

	LEQLC	TAILSP,0,,SJSRV1	;CHECK FOR NULL TAIL

SJSSDT:	VEQLC	ZPTR,S,,SJSRV	;IS OBJECT STRING?

	VEQLC	ZPTR,P,,SJSRP	;IS OBJECT PATTERN?

	VEQLC	ZPTR,I,,SJSRI	;IS OBJECT INTEGER?

	VEQLC	ZPTR,R,,SJSRR	;IS OBJECT REAL?

	VEQLC	ZPTR,E,INTR1	;IS OBJECT EXPRESSION?

	RCALL	TPTR,BLOCK,STARSZ	;ALLOCATE BLOCK FOR PATTERN

	MOVBLK	TPTR,STRPAT,STARSZ	;SET UP PATTERN FOR EXPRESSION

	PUTDC	TPTR,4*DESCR,ZPTR	;INSERT OBJECT

	MOVD	ZPTR,TPTR	;SET UP CONVERTED VALUE

SJSRP:	SETSP	XSP,HEADSP	;COPY SPECIFIER

	RCALL	XPTR,GENVAR,<XSPPTR>

;                                  GENERATE VARIABLE FOR HEAD

	GETLG	TMVAL,HEADSP	;GET LENGTH OF HEAD

	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR PATTERN

	MAKNOD	XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR

;                                  MAKE PATTERN NODE

	SETSP	YSP,TAILSP	;SET UP TAIL SPECIFIER

	RCALL	YPTR,GENVAR,<YSPPTR>

;                                  GENERATE VARIABLE FOR TAIL

	GETLG	TMVAL,TAILSP	;GET LENGTH OF TAIL

	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR PATTERN

	MAKNOD	YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR

;                                  MAKE PATTERN NODE

	GETSIZ	XSIZ,XPTR	;GET SIZE OF HEAD NODE

	GETSIZ	YSIZ,YPTR	;GET SIZE OF TAIL NODE

	GETSIZ	ZSIZ,ZPTR	;GET SIZE OF OBJECT

	SUM	TSIZ,XSIZ,ZSIZ	;COMPUTE TOTAL SIZE

	SUM	TSIZ,TSIZ,YSIZ	;GET SIZE OF NEW PATTERN

	SETVC	TSIZ,P	;INSERT PATTERN DATA TYPE

	RCALL	TPTR,BLOCK,TSIZ	;ALLOCATE BLOCK FOR TOTAL PATTERN

	MOVD	VVAL,TPTR	;GET WORKING COPY

	LVALUE	TVAL,ZPTR	;GET LEAST VALUE OF REPLACEMENT

	CPYPAT	TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ

;                                  COPY IN HEAD

	LVALUE	TVAL,YPTR	;GET LEAST VALUE OF TAIL

	SUM	TSIZ,XSIZ,ZSIZ	;GET SIZE OF FIRST TWO

	CPYPAT	TPTR,ZPTR,TVAL,XSIZ,TSIZ,ZSIZ

;                                  COPY IN OBJECT

	CPYPAT	TPTR,YPTR,ZEROCL,TSIZ,ZEROCL,YSIZ

;                                  COPY IN TAIL

	MOVD	ZPTR,VVAL	;SET UP RETURN VALUE

	BRANCH	SJSRV1	;JOIN COMMON PROCESSING

;_

SJSRV:	LOCSPX	ZSP,ZPTR

SJSRS:	GETLG	XPTR,TAILSP	;GET LENGTH OF TAIL

	GETLG	YPTR,HEADSP	;GET LENGTH OF TAIL

	GETLG	ZPTR,ZSP	;GET LENGTH OF OBJECT

	SUM	XPTR,XPTR,YPTR	;COMPUTE TOTAL LENGTH

	SUM	XPTR,XPTR,ZPTR

	ACOMP	XPTR,MLENCL,INTR8	;CHECK &MAXLNGTH

	RCALL	ZPTR,CONVAR,<XPTR>	;ALLOCATE STORAGE FOR STRING

	LOCSPX	TSP,ZPTR	;GET SPECIFIER

	SETLC	TSP,0	;CLEAR LENGTH

	APDSP	TSP,HEADSP	;APPEND HEAD

	APDSP	TSP,ZSP	;APPEND OBJECT

	APDSP	TSP,TAILSP	;APPEND TAIL

	RCALL	ZPTR,GNVARS,XPTR	;ENTER STRING INTO STORAGE

SJSRV1:	PUTDC	WPTR,DESCR,ZPTR	;ASSIGN VALUE TO SUBJECT NAME

	AEQLC	OUTSW,0,,SJSRV2	;CHECK &OUTPUT

	LOCAPV	YPTR,OUTATL,WPTR,SJSRV2

;                                  LOOK FOR OUTPUT ASSOCIATION

	GETDC	YPTR,YPTR,DESCR	;GET OUTPUT ASSOCIATION

	RCALL	,PUTOUT,<YPTR,ZPTR>	;PERFORM OUTPUT

SJSRV2:	ACOMPC	TRAPCL,0,,RTN3,RTN3	;CHECK &TRACE

	LOCAPT	ATPTR,TVALL,WPTR,RTN3

;                                  LOOK FOR VALUE TRACE

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR,RTN3

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

;_

SJSRI:	INTSPC	ZSP,ZPTR	;CONVERT INTEGER

	BRANCH	SJSRS

;_

SJSRR:	REALST	ZSP,ZPTR	;CONVERT REAL

	BRANCH	SJSRS

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      BASIC SCANNING PROCEDURE

;

SCNR:	PROC	,	;SCANNING PROCEDURE

	GETLG	MAXLEN,XSP	;GET MAXIMUM LENGTH

	LVALUE	YSIZ,YPTR	;GET LEAST VALUE

	AEQLC	FULLCL,0,SCNR1	;CHECK &FULLSCAN

	ACOMP	YSIZ,MAXLEN,FAIL	;CHECK MAXIMUM AGAINST MINIMUM

SCNR1:	SETSP	TXSP,XSP	;SET UP WORKING SPECIFIER FOR HEAD

	SETLC	TXSP,0	;ZERO LENGTH

	MOVD	PDLPTR,PDLHED	;INITIALIZE HISTORY LIST

	MOVD	NAMICL,NHEDCL	;INITIALIZE NAME LIST

	AEQLC	ANCCL,0,SCNR3	;CHECK &ANCHOR

	AEQLC	FULLCL,0,,SCNR4	;CHECK &FULLSCAN

	MOVD	YSIZ,MAXLEN	;SET UP LENGTH

	BRANCH	SCNR5	;JOIN PROCESSING

;_

SCNR4:	SUBTRT	YSIZ,MAXLEN,YSIZ	;GET DIFFERENCE OF LENGTHS

SCNR5:	SUM	YSIZ,YSIZ,CHARCL	;ADD ONE

SCNR2:	PUSH	<YPTR,YSIZ>	;SAVE PATTERN AND LENGTH

	SETSP	HEADSP,TXSP	;SET UP HEAD SPECIFIER

	INCRA	PDLPTR,3*DESCR	;MAKE ROOM FOR HISTORY ENTRY

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	SETAC	LENFCL,1	;SET LENGTH FAILURE

	PUTDC	PDLPTR,DESCR,SCONCL	;INSERT SCAN FUNCTION

	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  INSERT ON HISTORY LIST

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  INSERT LENGTH FAILURE

	BRANCH	SCIN1	;JOIN COMMON SCANNING

;_

SCNR3:	INCRA	PDLPTR,3*DESCR	;MAKE ROOM FOR HISTORY ENTRY

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	SETLC	HEADSP,0	;ZERO LENGTH OF HEAD

	PUTDC	PDLPTR,DESCR,SCFLCL	;INSERT SCAN FAILURE FUNCTION

	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  INSERT ON HISTORY LIST

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  INSERT LENGTH FAILURE

	BRANCH	SCIN1	;JOIN COMMON SCANNING

;_

SCIN:	PROC	SCNR

SCIN1:	MOVD	PATBCL,YPTR	;SET UP PATTERN BASE POINTER

	SETAC	PATICL,0	;ZERO OFFSET

SCIN2:	SETAC	LENFCL,1	;SET LENGTH FAILURE

SCIN3:	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	ZCL,PATBCL,PATICL	;GET FUNCTION DESCRIPTOR

	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	XCL,PATBCL,PATICL	;GET THEN-OR DESCRIPTOR

	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	YCL,PATBCL,PATICL	;GET VALUE-RESIDUAL DESCRIPTOR

	INCRA	PDLPTR,3*DESCR	;MAKE ROOM FOR HISTORY ENTRY

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	PUTDC	PDLPTR,DESCR,XCL	;INSERT THEN-OR DESCRIPTOR

	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	MOVV	TMVAL,YCL	;INSERT RESIDUAL

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  INSERT ON HISTORY LIST

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  INSERT LENGTH FAILURE

	AEQLC	FULLCL,0,SCIN4	;CHECK &FULLSCAN

	CHKVAL	MAXLEN,YCL,TXSP,SALT1

;                                  CHECK VALUES

SCIN4:	BRANIC	ZCL,0	;BRANCH TO PROCEDURE

;_

SALF:	PROC	SCNR	;NONLENGTH FAILURE PROCEDURE

SALF1:	SETAC	LENFCL,0	;CLEAR LENGTH FAILURE

	BRANCH	SALT2	;JOIN COMMON PROCESSING

;_

SALT:	PROC	SCNR	;LENGTH FAILURE PROCEDURE

SALT1:	GETDC	LENFCL,PDLPTR,3*DESCR

;                                  GET LENGTH FAILURE FROM HISTORY

SALT2:	GETDC	XCL,PDLPTR,DESCR	;GET THEN-OR DESCRIPTOR

	GETDC	YCL,PDLPTR,2*DESCR	;GET VALUE-RESIDUAL

	DECRA	PDLPTR,3*DESCR	;BACK OVER HISTORY ENTRY

	MOVD	PATICL,XCL	;SET OFFSET TO OR LINK

	AEQLC	PATICL,0,,SALT3	;CHECK FOR NONE

	PUTLG	TXSP,YCL	;INSERT OLD LENGTH OF HEAD

	TESTF	PATICL,FNC,SCIN3	;CHECK FOR FUNCTION

	BRANIC	PATICL,0	;BRANCH TO PROCEDURE

;_

SALT3:	AEQLC	LENFCL,0,SALT1	;CHECK LENGTH FAILURE

	BRANCH	SALF1	;GO TO NONLENGTH FAILURE

;_

SCOK:	PROC	SCNR	;SUCCESSFUL SCANNING PROCEDURE

	SETAV	PATICL,XCL	;SET OFFSET FROM THEN LINK

	AEQLC	PATICL,0,SCIN2,RTN2	;CHECK FOR NONE

;_

SCON:	PROC	SCNR

	AEQLC	FULLCL,0,SCON1	;CHECK &FULLSCAN

	AEQLC	LENFCL,0,FAIL	;CHECK LENGTH FAILURE

SCON1:	POP	<YSIZ,YPTR>	;RESTORE SAVE DESCRIPTORS

	DECRA	YSIZ,1	;DECREMENT POSSIBLE COUNT

	ACOMPC	YSIZ,0,,FAIL,INTR13	;CHECK FOR END

	ADDLG	TXSP,ONECL	;INCREMENT LENGTH OF HEAD

	BRANCH	SCNR2	;CONTINUE

;_

UNSC:	PROC	SCNR	;BACKOUT PROCEDURE

	MOVD	PATBCL,YPTR	;RESET PATTERN BASE

	BRANCH	SALT3	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ANY, BREAK, NOTANY, SPAN

;

ANYC:	PROC	,	;MATCHING PROCEDURE FOR ANY(S)

	SETAC	SCL,1	;POST ENTRY

ABNS:	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,PATBCL,PATICL	;GET ARGUMENT

	PUSH	SCL	;SAVE PROCESSOR SWITCH

ABNS1:	DEQL	XPTR,NULVCL,,SCNAME	;ERROR IF ARGUMENT IS THE NULL STRING

	VEQLC	XPTR,S,,ABNSV	;STRING IS ACCEPTABLE ARGUMENT

	VEQLC	XPTR,E,,ABNSE	;EXPRESSION MUST BE EVALUATED

	VEQLC	XPTR,I,SCDTER,ABNSI	;INTEGER MUST BE CONVERTED

ABNSE:	RCALL	XPTR,EXPVAL,XPTR,<TSALF,ABNS1>

ABNSI:	RCALL	XPTR,GNVARI,XPTR

ABNSV:	POP	SCL	;RESTORE PROCEDURE SWITCH

	SELBRA	SCL,<,BRKV,NNYV,SPNV>

;                                  SELECT PROCESSOR

ANYV:	DEQL	XPTR,TBLCS,ANYC2	;WAS LAST ARGUMENT THE SAME?

	AEQL	TBLFNC,ANYCCL,,ANYC3

;                                  IF SO, WAS LAST PROCEDURE FOR ANY(S)

ANYC2:	CLERTB	SNABTB,ERROR	;IF NOT, CLEAR STREAM TABLE

	LOCSPX	YSP,XPTR

	PLUGTB	SNABTB,STOP,YSP	;PLUG ENTRIES FOR CHARACTERS

	MOVD	TBLCS,XPTR	;SAVE ARGUMENT TO CHECK NEXT TIME

	MOVD	TBLFNC,ANYCCL	;SAVE PROCEDURE TO CHECK NEXT TIME

ANYC3:	SETSP	VSP,XSP	;SET UP WORKING SPECIFIER

	AEQLC	FULLCL,0,ANYC4	;LEAVE LENGTH ALONE IN FULLSCAN MODE

	PUTLG	VSP,MAXLEN	;ELSE INSERT MAXIMUM LENGTH

	LCOMP	VSP,TXSP,,,TSALT	;LENGTH FAILURE IF TOO SHORT

ANYC4:	REMSX	YSP,VSP,TXSP	;GET SPECIFIER TO UNSCANNED PORTION

	STREAM	ZSP,YSP,SNABTB,TSALF,TSALT

	GETLG	XPTR,ZSP	;GET LENGTH ACCEPTED

	ADDLG	TXSP,XPTR	;ADD TO LENGTH MATCHED

	BRANCH	SCOK,SCNR	;RETURN TO SUCCESS POINT

;_

BRKC:	PROC	ANYC	;MATCHING PROCEDURE FOR BREAK(S)

	SETAC	SCL,2	;POST ENTRY

	BRANCH	ABNS

;_

BRKV:	DEQL	XPTR,TBLCS,BRKC2	;WAS LAST ARGUMENT THE SAME?

	AEQL	TBLFNC,BRKCCL,,ANYC3

;                                  WAS THE LAST PROCEDURE FOR BREAK

BRKC2:	CLERTB	SNABTB,CONTIN	;IF NOT, CLEAR STREAM TABLE

	LOCSPX	YSP,XPTR

	PLUGTB	SNABTB,STOPSH,YSP	;PLUG ENTRIES FOR CHARACTERS

	MOVD	TBLCS,XPTR	;SAVE ARGUMENT TO CHECK NEXT TIME

	MOVD	TBLFNC,BRKCCL	;SAVE PROCEDURE TO CHECK NEXT TIME

	BRANCH	ANYC3	;PROCEED

;_

NNYC:	PROC	ANYC	;MATCHING PROCEDURE FOR NOTANY(S)

	SETAC	SCL,3	;POST ENTRY

	BRANCH	ABNS

;_

NNYV:	DEQL	XPTR,TBLCS,NNYC2	;WAS LAST ARGUMENT THE SAME?

	AEQL	TBLFNC,NNYCCL,,ANYC3

;                                  WAS THE LAST PROCEDURE FOR NOTANY?

NNYC2:	CLERTB	SNABTB,STOP	;IF NOT, CLEAR STREAM TABLE

	LOCSPX	YSP,XPTR

	PLUGTB	SNABTB,ERROR,YSP	;PLUG ENTRIES FOR CHARACTERS

	MOVD	TBLCS,XPTR	;SAVE ARGUMENT TO CHECK NEXT TIME

	MOVD	TBLFNC,NNYCCL	;SAVE PROCEDURE TO CHECK NEXT TIME

	BRANCH	ANYC3	;PROCEED

;_

SPNC:	PROC	ANYC	;MATCHING PROCEDURE FOR SPAN(S)

	SETAC	SCL,4	;POST ENTRY

	BRANCH	ABNS

;_

SPNV:	DEQL	XPTR,TBLCS,SPNC2	;WAS LAST ARGUMENT THE SAME?

	AEQL	TBLFNC,SPNCCL,,SPNC3

;                                  WAS THE LAST PROCEDURE FOR SPAN?

SPNC2:	CLERTB	SNABTB,STOPSH	;IF NOT, CLEAR STREAM TABLE

	LOCSPX	YSP,XPTR

	PLUGTB	SNABTB,CONTIN,YSP	;PLUG ENTRIES FOR CHARACTERS

	MOVD	TBLCS,XPTR	;SAVE ARGUMENT TO CHECK NEXT TIME

	MOVD	TBLFNC,SPNCCL	;SAVE PROCEDURE TO CHECK NEXT TIME

SPNC3:	LCOMP	XSP,TXSP,,TSALT,TSALT

;                                  LENGTH FAILURE IF TOO SHORT

	REMSX	YSP,XSP,TXSP	;GET SPECIFIER TO UNSCANNED PORTION

	STREAM	ZSP,YSP,SNABTB,TSALF

	LEQLC	ZSP,0,,TSALF	;FAILURE IF LENGTH ACCEPTED IS ZERO

	GETLG	XPTR,ZSP	;GET LENGTH OF ACCEPTED PORTION

	AEQLC	FULLCL,0,SPNC5	;SKIP LENGTH CHECK IN FULLSCAN MODE

	CHKVAL	MAXLEN,XPTR,TXSP,TSALT

SPNC5:	ADDLG	TXSP,XPTR	;ADD LENGTH ACCEPTED

	BRANCH	SCOK,SCNR

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      LEN, POS, RPOS, RTAB, TAB

;

LNTH:	PROC	,	;MATCHING PROCEDURE FOR LEN(N)

	SETAC	SCL,1	;NOTE ENTRY

LPRRT:	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,PATBCL,PATICL	;GET ARGUMENT

	PUSH	SCL	;SAVE ENTRY INDICATOR

;

LPRRT1:	VEQLC	XPTR,I,,LPRRTI	;IS IT INTEGER?

	VEQLC	XPTR,E,,LPRRTE	;IS IT EXPRESSION?

	VEQLC	XPTR,S,SCDTER,LPRRTV

;                                  IS IT STRING?

;VERSION 3.3 CHANGE
LPRRTE:	RCALL XPTR,EXPVAL,XPTR,<,LPRRT1>
	POP SCL
	BRANCH TSALF
;_
;VERSION 3.3 CHANGE END
;                                  EVALUATE EXPRESSION

LPRRTV:	LOCSPX	ZSP,XPTR	;GET SPECIFIER

	SPCINT	XPTR,ZSP,SCDTER	;CONVERT TO INTEGER

LPRRTI:	POP	SCL	;RESTORE ENTRY INDICATOR

	SELBRA	SCL,<,POSII,RPSII,RTBI,TBI>

;                                  SELECT MATCHING PROCEDURE

	ACOMPC	XPTR,0,,,SCLENR	;CHECK FOR NEGATIVE LENGTH

	CHKVAL	MAXLEN,XPTR,TXSP,TSALT

;                                  COMPARE WITH MAXIMUM LENGTH

	ADDLG	TXSP,XPTR	;ADD TO LENGTH MATCHED

	BRANCH	SCOK,SCNR	;RETURN SUCCESSFUL MATCH

;_

POSII:	ACOMPC	XPTR,0,,,SCLENR	;CHECK FOR NEGATIVE POSITION

	GETLG	NVAL,TXSP	;GET CURSOR POSITION

	ACOMP	XPTR,MAXLEN,TSALT	;CHECK DESIRED AGAINST MAXIMUM

	ACOMP	XPTR,NVAL,TSALF,TSCOK

;                                  CECK AGAINST CURSOR POSITION

	BRANCH	SALT,SCNR

;_

RPSII:	ACOMPC	XPTR,0,,,SCLENR	;CHECK FOR NEGATIVE POSITION

	GETLG	NVAL,XSP	;GET TOTAL LENGTH

	SUBTRT	TVAL,NVAL,XPTR	;FIND DESIRED POSITION

	GETLG	NVAL,TXSP	;GET CURSOR POSITION

;LINE NOT MATCHED ;;;;;;;;;;;;;;;;;;;;;;;;;

;

	ACOMP	NVAL,TVAL,TSALT,TSCOK,TSALF

;                                  COMPARE TWO POSITIONS

;_

RTBI:	ACOMPC	XPTR,0,,,SCLENR	;CHECK FOR NEGATIVE LENGTH

	GETLG	NVAL,XSP	;GET TOTAL LENGTH

	SUBTRT	TVAL,NVAL,XPTR	;FIND DESIRED POSITION

	GETLG	NVAL,TXSP	;GET CURRENT POSITION

	ACOMP	NVAL,TVAL,TSALT	;COMPARE TWO POSITIONS

	AEQLC	FULLCL,0,RTBII	;CHECK &FULLSCAN

	SETAV	NVAL,YCL	;GET RESIDUAL

	SUBTRT	NVAL,MAXLEN,NVAL	;FIND MAXIMUM ALLOWED POSITION

	ACOMP	NVAL,TVAL,,,TSALT	;COMPARE WITH DESIRED POSITION

RTBII:	PUTLG	TXSP,TVAL	;UPDATE LENGTH OF STRING MATCHED

	BRANCH	SCOK,SCNR

;_

TBI:	ACOMPC	XPTR,0,,,SCLENR	;CHECK FOR NEGATIVE LENGTH

	GETLG	NVAL,TXSP	;GET CURSOR POSITION

	ACOMP	NVAL,XPTR,TSALT	;CHECK AGAINST DESIRED POSITION

	ACOMP	XPTR,MAXLEN,TSALT	;CHECK FOR TAB BEYOND END

	PUTLG	TXSP,XPTR	;UPDATE LENGTH OF STRING MATCHED

	BRANCH	SCOK,SCNR

;_

POSI:	PROC	LNTH	;MATCHING PROCEDURE FOR POS(N)

	SETAC	SCL,2	;NOTE ENTRY

	BRANCH	LPRRT	;JOIN COMMON PROCESSING

;_

RPSI:	PROC	LNTH	;MATCHING PROCEDURE FOR RPOS(N)

	SETAC	SCL,3	;NOTE ENTRY

	BRANCH	LPRRT	;JOIN COMMON PROCESSING

;_

RTB:	PROC	LNTH	;MATCHING PROCEDURE FOR RTAB(N)

	SETAC	SCL,4	;NOTE ENTRY

	BRANCH	LPRRT	;JOIN COMMON PROCESSING

;_

TB:	PROC	LNTH	;MATCHING PROCEDURE FOR TAB(N)

	SETAC	SCL,5	;NOTE ENTRY

	BRANCH	LPRRT	;JOIN COMMON PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ARBNO

;

ARBN:	PROC	,	;MATCHING FOR ARBNO(P)

	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	PUSH	TMVAL	;SAVE CURSOR POSITION

	BRANCH	SCOK,SCNR	;RETURN MATCHING SUCCESSFULLY

;_

ARBF:	PROC	ARBN	;BACKUP MATCHING FOR ARBNO(P)

	POP	<TMVAL>	;RESTORE CURSOR POSITION

	BRANCH	ONAR2	;JOIN COMMON PROCESSING

;_

EARB:	PROC	ARBN

	POP	<TMVAL>	;RESTORE CURSOR POSITION

	PUTDC	PDLPTR,DESCR,TMVAL	;INSERT ON HISTORY LIST

	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	PUTDC	PDLPTR,2*DESCR,TMVAL

	PUTDC	PDLPTR,3*DESCR,ZEROCL

	BRANCH	SCOK,SCNR	;RETURN MATCHING SUCCESSFULLY

;_

ONAR:	PROC	ARBN

	AEQLC	FULLCL,0,TSCOK	;CHECK &FULLSCAN

	MOVD	TVAL,ZEROCL

	GETAC	TVAL,PDLPTR,-2*DESCR

;                                  GET OLD CURSOR POSITION

	GETLG	TMVAL,TXSP	;GET CURRENT CURSOR POSITION

	ACOMP	TVAL,TMVAL,TSCOK,,TSCOK

;                                  COMPARE POSITIONS

ONAR1:	PUSH	TVAL	;SAVE CURSOR POSITION

	DECRA	PDLPTR,6*DESCR	;DELETE HISTORY ENTRIES

ONAR2:	AEQLC	LENFCL,0,TSALT	;CHECK LENGTH FAILURE

	BRANCH	SALF,SCNR	;RETURN MATCHING FAILURE

;_

ONRF:	PROC	ARBN

	MOVD	TVAL,ZEROCL

	GETAC	TVAL,PDLPTR,-2*DESCR

;                                  GET OLD CURSOR POSITION

	BRANCH	ONAR1	;JOIN PROCESSING

;_

FARB:	PROC	,

	AEQLC	FULLCL,0,,FARB2	;CHECK &FULLSCAN

	SETAC	NVAL,0	;SET RESIDUAL LENGTH TO 0

	BRANCH	FARB3	;JOIN PROCESSING

;_

FARB2:	AEQLC	LENFCL,0,FARB1	;CHECK FOR LENGTH FAILURE

	SETAV	NVAL,YCL	;GET RESIDUAL LENGTH

FARB3:	GETLG	TVAL,TXSP	;GET CURSOR POSITION

	SUM	TVAL,TVAL,NVAL	;ADD THEM

	ACOMP	TVAL,MAXLEN,FARB1,FARB1

;                                  CHECK AGAINST MAXIMUM

	ADDLG	TXSP,ONECL	;ADD ONE FOR ARB

	GETLG	TVAL,TXSP	;GET LENGTH MATCHED

	PUTAC	PDLPTR,2*DESCR,TVAL	;INSERT ON HISTORY LIST

	BRANCH	SCOK,SCNR	;RETURN SUCCESSFUL MATCH

;_

FARB1:	DECRA	PDLPTR,3*DESCR	;BACK OVER HISTORY ENTRY

	BRANCH	SALT,SCNR

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      `X

;

ATP:	PROC	,	;MATCHING PROCEDURE FOR `X

	INCRA	PATICL,DESCR	;INCREMENT PATTERN OFFSET

	GETD	XPTR,PATBCL,PATICL	;GET ARGUMENT

ATP1:	VEQLC	XPTR,E,,ATPEXN	;EXPRESSION MUST BE EVALUATED

	GETLG	NVAL,TXSP	;GET LENGTH OF TEXT MATCHED

	SETVC	NVAL,I	;SET INTEGER DATA TYPE

	PUTDC	XPTR,DESCR,NVAL	;ASSIGN AS VALUE OF VARIABLE X

	AEQLC	OUTSW,0,,ATP2	;CHECK &OUTPUT

	LOCAPV	ZPTR,OUTATL,XPTR,ATP2

;                                  LOOK FOR OUTPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET OUTPUT ASSOCIATION DESCRIPTOR

	RCALL	,PUTOUT,<ZPTR,NVAL>	;PERFORM OUTPUT

ATP2:	AEQLC	TRAPCL,0,,TSCOK	;CHECK &TRACE

	LOCAPT	ATPTR,TVALL,XPTR,TSCOK

;                                  LOOK FOR TRACE ASSOCIATION

	PUSH	<PATBCL,PATICL,WPTR,XCL,YCL>

	PUSH	<MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL>

	SPUSH	<HEADSP,TSP,TXSP,XSP>

	MOVD	PDLHED,PDLPTR	;SET NEW STACK HEADING

	MOVD	NHEDCL,NAMICL	;SET NEW NAME LIST HEADING

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACING

	SPOP	<XSP,TXSP,TSP,HEADSP>

	POP	<NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN>

	POP	<YCL,XCL,WPTR,PATICL,PATBCL>

	BRANCH	SCOK,SCNR

;_

ATPEXN:	RCALL	XPTR,EXPEVL,XPTR,<TSALF,ATP1,NEMO>

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      BAL

;

BAL:	PROC	,	;MATCHING PROCEDURE FOR BAL

BALF1:	AEQLC	FULLCL,0,,BALF4	;CHECK &FULLSCAN

	SETAC	NVAL,0	;SET LENGTH TO ZERO

	BRANCH	BALF2

;_

BALF4:	SETAV	NVAL,YCL

BALF2:	GETLG	TVAL,TXSP	;GET LENGTH OF TEXT MATCHED SO FAR

	SUM	TVAL,TVAL,NVAL	;ADD REMAINDER POSSIBLE

	ACOMP	TVAL,MAXLEN,BAL1,BAL1

;                                  COMPARE TO MAXIMUM

	SUBTRT	TVAL,MAXLEN,TVAL	;GET MAXIMUM LENGTH FOR BAL

	GETBAL	TXSP,TVAL,BAL1	;GET BALANCED STRING

	GETLG	TVAL,TXSP	;GET LENGTH MATCHED

	PUTAC	PDLPTR,2*DESCR,TVAL	;INSERT HISTORY ENTRY

	BRANCH	SCOK,SCNR	;SUCCESSFUL MATCH

;_

BAL1:	DECRA	PDLPTR,3*DESCR	;BACK OVER HISTORY ENTRY

	ACOMP	PDLPTR,PDLHED,TSALF,TSALF,INTR13

;_

BALF:	PROC	BAL	;MATCHING PROCEDURE FOR BAL RETRY

	AEQLC	FULLCL,0,,BALF3	;CHECK &FULLSCAN

	SETAC	NVAL,0	;IF OFF, SET LENGTH TO ZERO

	BRANCH	BALF2	;REENTER BALANCED MATCHING

;_

BALF3:	AEQLC	LENFCL,0,BAL1,BALF1	;IF ON, TEST FOR LENGTH FAILURE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      MATCHING FOR STRING

;

CHR:	PROC	,	;MATCHING CHARACTER STRING

	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	YPTR,PATBCL,PATICL	;GET ARGUMENT

CHR1:	LOCSPX	TSP,YPTR	;GET SPECIFIER

CHR2:	REMSX	VSP,XSP,TXSP	;REMOVE PART MATCHED

	SUBSP	VSP,TSP,VSP,TSALT	;GET PART TO MATCH

	LEXCMP	VSP,TSP,TSALF,,TSALF

;                                  COMPARE STRINGS

	GETLG	YPTR,TSP	;GET LENGTH

	ADDLG	TXSP,YPTR	;UPDATE STRING MATCHED

	BRANCH	SCOK,SCNR	;RETURN SUCCESSFUL MATCH

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      *X

;

STAR:	PROC	CHR	;MATCHING PROCEDURE FOR EXPRESSIONS

	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	YPTR,PATBCL,PATICL	;GET ARGUMENT EXPRESSION

STAR2:	RCALL	YPTR,EXPVAL,YPTR,TSALF

;                                  EVALUATE ARGUMENT

	VEQLC	YPTR,E,,STAR2	;IS IS EXPRESSION?

	SUM	XPTR,PATBCL,PATICL	;COMPUTE POINTER TO ARGUMENT

	PUTDC	XPTR,7*DESCR,YPTR	;INSERT POINTER IN BACKUP NODE

	VEQLC	YPTR,S,,CHR1	;IS IT STRING?

	VEQLC	YPTR,P,,STARP	;IS IT  PATTERN?

	VEQLC	YPTR,I,SCDTER	;IS IT INTEGER?

	INTSPC	TSP,YPTR	;GET SPECIFIER FOR INTEGER

	BRANCH	CHR2	;JOIN PROCESSING

;_

STARP:	AEQLC	FULLCL,0,,STARP1	;CHECK &FULLSCAN

	SETAC	NVAL,0	;ZERO LENGTH

	BRANCH	STARP4	;JOIN PROCESSING

;_

STARP1:	SETAV	NVAL,YCL	;GET LENGTH

STARP4:	SUBTRT	NVAL,MAXLEN,NVAL	;COMPUTE RESIDUAL

	ACOMPC	NVAL,0,,,TSALT

	LVALUE	TSIZ,YPTR	;CHECK &FULLSCAN

	AEQLC	FULLCL,0,STARP6

	ACOMP	TSIZ,NVAL,TSALT	;CHECK AGAINST LENGTH

STARP6:	INCRA	PDLPTR,3*DESCR	;MAKE ROOM FOR HISTORY

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	PUTDC	PDLPTR,DESCR,SCFLCL	;INSERT FAILURE FUNCTION

	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  INSERT ON HISTORY LIST

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  INSERT LENGTH FAILURE

	PUSH	<MAXLEN,PATBCL,PATICL,XCL,YCL>

;                                  SAVE SCANNER STATE

	MOVD	MAXLEN,NVAL	;SET UP NEW MAXIMUM

	RCALL	,SCIN,,<STARP5,,RTNUL3>

;                                  CALL THE SCANNER

STARP2:	POP	<YCL,XCL,PATICL,PATBCL,MAXLEN>

;                                  RESTORE SCANNER STATE

	BRANCH	SCOK,SCNR	;RETURN MATCHING SUCCESSFULLY

;_

STARP5:	POP	<YCL,XCL,PATICL,PATBCL,MAXLEN>

;                                  RESTORE SCANNER STATE

STARP3:	AEQLC	LENFCL,0,TSALT	;CHECK LENGTH FAILURE

	BRANCH	SALF,SCNR	;RETURN MATCHING FAILURE

;_

DSAR:	PROC	CHR	;BACKUP MATCHING FOR EXPRESSION

	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	YPTR,PATBCL,PATICL	;GET ARGUMENT

	VEQLC	YPTR,S,,STARP3	;IS IT STRING?

	VEQLC	YPTR,P,,DSARP	;IS IT PATTERN?

	VEQLC	YPTR,I,SCDTER,STARP3

;                                  IS IT INTEGER?

;_

DSARP:	AEQLC	FULLCL,0,,DSARP1	;CHECK &FULLSCAN

	SETAC	NVAL,0	;ZERO LENGTH

	BRANCH	DSARP2	;JOIN PROCESSING

;_

DSARP1:	SETAV	NVAL,YCL	;GET LENGTH

DSARP2:	SUBTRT	NVAL,MAXLEN,NVAL	;COMPUTE RESIDUAL

	PUSH	<MAXLEN,PATBCL,PATICL,XCL,YCL>

;                                  SAVE SCANNER STATE

	MOVD	MAXLEN,NVAL	;SET UP NEW MAXIMUM

	RCALL	,UNSC,,<STARP5,STARP2,RTNUL3>

;                                  CALL UNSCANNING PROCEDURE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      FENCE

;

FNCE:	PROC	,	;PROCEDURE FOR MATCHING FENCE

	INCRA	PDLPTR,3*DESCR	;CREATE NEW HISTORY ENTRY

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	PUTDC	PDLPTR,DESCR,FNCFCL	;INSERT FENCE FAILURE FUNCTION

	GETLG	TMVAL,TXSP	;GET LENGTH

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  SAVE LENGTH

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  SAVE LENGTH FAILURE SWITCH

	SETAC	LENFCL,1	;SET LENGTH FAILURE SWITCH

	BRANIC	SCOKCL,0	;RETURN MATCHING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      X . Y AND X $ Y

;

NME:	PROC	,	;MATCHING PROCEDURE FOR NAMING

	INCRA	PDLPTR,3*DESCR	;MAKE ROOM FOR HISTORY ENTRY

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR END OF LIST

	PUTDC	PDLPTR,DESCR,FNMECL	;INSERT BACKUP FUNCTION

	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  PUT ON HISTORY LIST

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  PUT LENGTH FAILURE INDICATOR

	PUSH	<TMVAL>	;SAVE CURSOR

	SETAC	LENFCL,1	;SET LENGTH FAILURE INDICATOR

	BRANCH	SCOK,SCNR	;RETURN MATCHING SUCCESSFULLY

;_

FNME:	PROC	NME	;BACKUP PROCEDURE FOR NAMING

	POP	<TVAL>	;RESTORE CURSOR

FNME1:	AEQLC	LENFCL,0,TSALT,TSALF

;                                  CHECK LENGTH FAILURE INDICATOR

;_

ENME:	PROC	NME	;NAMING PROCESS FOR X . Y

	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	YPTR,PATBCL,PATICL	;GET ARGUMENT

	POP	<NVAL>	;RESTORE PREVIOUS CURSOR POSITION

	SETVA	YCL,NVAL	;SET UP LENGTH

	SETSP	TSP,TXSP	;COPY SPECIFIER

	PUTLG	TSP,NVAL	;INSERT LENGTH

	REMSX	TSP,TXSP,TSP	;COMPUTE RAMAINDER

	SUM	TPTR,NBSPTR,NAMICL	;COMPUTE POSITION ON NAME LIST

	PUTSPC	TPTR,DESCR,TSP	;INSERT SPECIFIER

	PUTDC	TPTR,DESCR+SPEC,YPTR

;                                  INSERT ARGUMENT

	INCRA	NAMICL,DESCR+SPEC	;INCREMENT LIST OFFSET

	ACOMP	NAMICL,NMOVER,INTR13,ENME1

;                                  CHECK FOR OVERFLOW

ENME2:	INCRA	PDLPTR,DESCR+SPEC	;MAKE ROOM ON HISTORY LIST

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	PUTDC	PDLPTR,DESCR,DNMECL	;INSERT UNRAVELLING FUNCTION

ENME3:	GETLG	TMVAL,TXSP	;GET CURSOR POSITION

	MOVV	TMVAL,YCL

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  INSERT ON LIST

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  INSERT LENGTH FAILURE

	SETAC	LENFCL,1	;SET LENGTH FAILURE

	BRANCH	SCOK,SCNR	;RETURN MATCHING SUCCESSFULLY

;_

ENME1:	MOVD	WCL,NMOVER	;SAVE COPY OF CUURENT NAME LIST END

	INCRA	NMOVER,NAMLSZ*SPDR	;INCREMENT FOR LARGER BLOCK

	RCALL	TPTR,BLOCK,NMOVER	;ALLOCATE LARGER BLOCK

	MOVBLK	TPTR,NBSPTR,WCL	;MOVE IN OLD BLOCK

	MOVD	NBSPTR,TPTR	;SET UP NEW BASE POINTER

	BRANCH	ENME2	;REJOIN PROCESSING

;_

DNME:	PROC	NME	;UNRAVELLING PROCEDURE FOR NAMING

	DECRA	NAMICL,DESCR+SPEC	;BACK OFF NAMED STRING

	SUM	TPTR,NBSPTR,NAMICL	;COMPUTE CURRENT POSITION

DNME1:	PROC	NME

	SETAV	VVAL,YCL

	PUSH	<VVAL>	;PRESERVE LENGTH

	BRANCH	FNME1

;_

ENMI:	PROC	NME	;MATCHING FOR X $ Y

	INCRA	PATICL,DESCR	;INCREMENT OFFSET

	GETD	YPTR,PATBCL,PATICL	;GET ARGUMENT

	POP	<NVAL>	;RESTORE INITIAL LENGTH

	SETVA	YCL,NVAL	;MOVE INITIAL LENGTH INTO VALUE FIELD

	SETSP	TSP,TXSP	;GET WORKING SPECIFIER

	PUTLG	TSP,NVAL	;INSERT LENGTH

	REMSX	TSP,TXSP,TSP	;GET SPECIFIER FOR PART MATCHED

	GETLG	ZCL,TSP	;GET LENGTH OF PART

	ACOMP	ZCL,MLENCL,SCLNOR	;CHECK &MAXLNGTH

	VEQLC	YPTR,E,,ENMEXN	;IS IT EXPRESSION?

ENMI5:	VEQLC	YPTR,K,,ENMIC	;CHECK FOR KEYWORD DATA TYPE

	RCALL	VVAL,GENVAR,<TSPPTR>

;                                  GENERATE VARIABLE

ENMI3:	PUTDC	YPTR,DESCR,VVAL	;PERFORM ASSIGNMENT

	AEQLC	OUTSW,0,,ENMI4	;CHECK &OUTPUT

	LOCAPV	ZPTR,OUTATL,YPTR,ENMI4

;                                  LOOK FOR OUTPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET ASSOCIATION

	RCALL	,PUTOUT,<ZPTR,VVAL>	;PERFORM OUTPUT

ENMI4:	ACOMPC	TRAPCL,0,,ENMI2,ENMI2

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TVALL,YPTR,ENMI2

;                                  LOOK FOR VALUE TRACE

	PUSH	<PATBCL,PATICL,WPTR,XCL,YCL>

;                                  SAVE RELEVANT DESCRIPTORS

	PUSH	<MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL>

	SPUSH	<HEADSP,TSP,TXSP,XSP>

;                                  SAVE RELEVANT SPECIFIERS

	MOVD	PDLHED,PDLPTR	;SET UP NEW HISTORY LIST HEAD

	MOVD	NHEDCL,NAMICL	;SET UP NEW NAME LIST HEAD

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	SPOP	<XSP,TXSP,TSP,HEADSP>

;                                  RESTORE SPECIFIERS

	POP	<NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN>

;                                  RESTORE DESCRIPTORS

	POP	<YCL,XCL,WPTR,PATICL,PATBCL>

ENMI2:	INCRA	PDLPTR,3*DESCR	;MAKE ROOM ON HISTORY LIST

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	PUTDC	PDLPTR,DESCR,DNMICL	;INSERT UNRAVELLING FUNCTION

	BRANCH	ENME3	;JOIN COMMON PROCESSING

;_

ENMIC:	SPCINT	VVAL,TSP,SCDTER,ENMI3

;                                  CONVERT STRING TO INTEGER

;_

ENMEXN:	RCALL	YPTR,EXPEVL,YPTR,<TSALF,ENMI5,NEMO>

;                                  EVALUATE EXPRESSION TO GET VARIABLE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      SUCCEED

;

SUCE:	PROC	,	;MATCHING PROCEDURE FOR SUCCEED

SUCE1:	INCRA	PDLPTR,3*DESCR	;MAKE ROOM FOR HISTORY ENTRY

	ACOMP	PDLPTR,PDLEND,INTR31

;                                  CHECK FOR OVERFLOW

	PUTDC	PDLPTR,DESCR,SUCFCL	;INSERT SUCCESS BACKUP FUNCTION

	GETLG	TMVAL,TXSP	;GET LENGTH MATCHED

	PUTDC	PDLPTR,2*DESCR,TMVAL

;                                  SAVE ON HISTORY LIST

	PUTDC	PDLPTR,3*DESCR,LENFCL

;                                  SAVE CURRENT LENGTH FAILURE

	SETAC	LENFCL,1	;SET LENGTH FAILURE

	BRANIC	SCOKCL,0	;RETURN SUCCESSFUL MATCH

;_

SUCF:	PROC	SUCE	;SUCCEED FAILURE

	GETDC	XCL,PDLPTR,DESCR	;GET HISTORY ENTRIES

	GETDC	YCL,PDLPTR,2*DESCR

	BRANCH	SUCE1	;GO IN FRONT DOOR

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'DEFINED FUNCTIONS'

;

;      DEFINE(P,E)

;

DEFINE:	PROC	,	;DEFINE(P,E)

	RCALL	XPTR,VARVAL,,FAIL	;GET PROTOTYPE

	PUSH	XPTR	;SAVE PROTOTYPE

	RCALL	YPTR,VARVAL,,FAIL	;GET ENTRY POINT

	POP	XPTR	;RESTORE PROTOTYPE

	LOCSPX	XSP,XPTR	;SPECIFIER FOR PROTOTYPE

	STREAM	YSP,XSP,VARATB,PROTER,PROTER

;                                  BREAK OUT FUNCTION NAME

	AEQLC	STYPE,LPTYP,PROTER	;VERIFY OPEN PARENTHESIS

	RCALL	XPTR,GENVAR,<YSPPTR>

;                                  GET VARIABLE FOR FUNCTION NAME

	RCALL	ZCL,FINDEX,<XPTR>	;GET FUNCTION DESCRIPTOR FOR FUNCTION

	DEQL	YPTR,NULVCL,DEFIN3	;CHECK FOR OMITTED ENTRY POINT

	MOVD	YPTR,XPTR	;IF OMITTED USE FUNCTION NAME

DEFIN3:	PUSH	YPTR	;SAVE ENTRY POINT

	MOVD	YCL,ZEROCL	;SET ARGUMENT COUNT TO 0

	PUSH	XPTR	;SAVE FUNCTION NAME

DEFIN4:	FSHRTN	XSP,1	;REMOVE BREAK CHARACTER

	STREAM	YSP,XSP,VARATB,PROTER,PROTER

;                                  BREAK OUT ARGUMENT

	SELBRA	STYPE,<PROTER,,DEFIN6>

;                                  CHECK FOR END

	LEQLC	YSP,0,,DEFIN4	;CHECK FOR NULL ARGUMENT

	RCALL	XPTR,GENVAR,<YSPPTR>

;                                  GENERATE VARIABLE FOR ARGUMENT

	PUSH	XPTR	;SAVE ARGUMENT

	INCRA	YCL,1	;INCREMENT ARGUMENT COUNT

	BRANCH	DEFIN4	;CONTINUE

;_

DEFIN6:	LEQLC	YSP,0,,DEFIN9

	INCRA	YCL,1	;INCREMENT ARGUMENT COUNT

	RCALL	XPTR,GENVAR,<YSPPTR>

;                                  GENERATE VARIABLE FOR ARGUMENT

	PUSH	XPTR	;SAVE ARGUMENT

DEFIN9:	SETVA	DEFCL,YCL

DEFIN8:	FSHRTN	XSP,1

	STREAM	YSP,XSP,VARATB,PROTER,DEF10

;                                  BREAK OUT LOCAL ARGUMENTS

	AEQLC	STYPE,CMATYP,PROTER	;VERIFY COMMA

	LEQLC	YSP,0,,DEFIN8	;CHECK FOR NULL ARGUMENT

	RCALL	XPTR,GENVAR,<YSPPTR>

;                                  GENERATE VARIABLE

	PUSH	XPTR	;SAVE LOCAL ARGUMENT

	INCRA	YCL,1	;INCREMENT TOTAL COUNT

	BRANCH	DEFIN8	;CONTINUE

;_

DEF10:	LEQLC	YSP,0,,DEF11	;CHECK FOR NULL ARGUMENT

	RCALL	XPTR,GENVAR,YSPPTR	;GENERATE VARIABLE

	PUSH	XPTR	;SAVE ARGUMENT

	INCRA	YCL,1	;INCREMENT TOTAL COUNT

DEF11:	INCRA	YCL,2	;INCREMENT FOR NAME AND LABEL

	MULTC	XCL,YCL,DESCR	;CONVERT TO ADDRESS UNITS

	SETVC	XCL,B	;INSERT BLOCK DATA TYPE

	RCALL	XPTR,BLOCK,XCL	;ALLOCATE BLOCK FOR DEFINITION

	PUTDC	ZCL,0,DEFCL	;POINT TO PROCEDURE DESCRIPTOR

	PUTDC	ZCL,DESCR,XPTR	;INSERT DEFINITION BLOCK

	SUM	XPTR,XPTR,XCL	;COMPUTE END OF BLOCK

DEF12:	DECRA	XPTR,DESCR	;DECREMENT POINTER

	POP	YPTR	;RESTORE ARGUMENT

	PUTDC	XPTR,DESCR,YPTR	;INSERT IN DEFINITION BLOCK

	DECRA	YCL,1	;DECREMENT TOTAL COUNT

	AEQLC	YCL,0,DEF12,RETNUL	;CHECK FOR END

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      INVOCATION OF DEFINED FUNCTION

;

DEFFNC:	PROC	,	;PROCEDURE TO INVOKE DEFINED FUNCTION

	SETAV	XCL,INCL	;GET NUMBER OF ARGUMENTS IN CALL

	MOVD	WCL,XCL	;SAVE COPY

	MOVD	YCL,INCL	;SAVE FUNCTION DESCRIPTOR

	PSTACK	YPTR	;POST STACK POSITION

	PUSH	NULVCL	;SAVE NULL VALUE FOR FUNCTION NAME

DEFF1:	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,DEFFC	;CHECK FOR FUNCTION DESCRIPTOR

DEFF2:	AEQLC	INSW,0,,DEFF14	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,XPTR,DEFF14

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET ASSOCIATION

	PUSH	<XCL,WCL,YCL,YPTR>	;SAVE RELEVANT DESCRIPTORS

	RCALL	XPTR,PUTIN,<ZPTR,XPTR>,FAIL

;                                  PERFORM INPUT

	POP	<YPTR,YCL,WCL,XCL>	;RESTORE DESCRIPTORS

	BRANCH	DEFF3	;JOIN PROCESSING

;_

DEFF14:	GETDC	XPTR,XPTR,DESCR	;GET VALUE

DEFF3:	PUSH	XPTR	;SAVE VALUE

	DECRA	XCL,1	;DECREMENT ARGUMENT COUNT

	ACOMPC	XCL,0,DEFF1,,INTR10	;CHECK FOR END

	GETDC	XCL,YCL,0	;GET EXPECTED NUMBER OF ARGUMENTS

	SETAV	XCL,XCL	;INSERT IN A-FIELD

DEFF4:	ACOMP	WCL,XCL,DEFF9,DEFF5	;COMPARE GIVEN AND EXPECTED

	PUSH	NULVCL	;NOT ENOUGH, SAVE NULL STRING

	INCRA	WCL,1	;INCREMENT COUNT

	BRANCH	DEFF4	;CONTINUE

;_

DEFF9:	POP	ZCL	;THROW AWAY EXTRA ARGUMENT

	DECRA	WCL,1	;DECREMENT COUNT

	BRANCH	DEFF4	;CONTINUE

;_

DEFF5:	GETDC	ZCL,YCL,DESCR	;GET DEFINITION BLOCK

	MOVD	XPTR,ZCL	;SAVE COPY

	GETSIZ	WCL,ZCL	;GET SIZE OF BLOCK

	SUM	WPTR,ZCL,WCL	;COMPUTE POINTER TO END

	INCRA	XCL,1	;INCREMENT FOR FUNCTION NAME

DEFF8:	INCRA	XPTR,DESCR	;INCREMENT POINTER TO BLOCK

	INCRA	YPTR,DESCR	;ADJUST STACK POINTER

	GETDC	ZPTR,XPTR,DESCR	;GET ARGUMENT NAME

	GETDC	TPTR,ZPTR,DESCR	;GET CURRENT ARGUMENT VALUE

	GETDC	ATPTR,YPTR,DESCR	;GET VALUE FROM STACK

	PUTDC	ZPTR,DESCR,ATPTR	;ASSIGN TO ARGUMENT NAME

	PUTDC	YPTR,DESCR,TPTR	;PUT CURRENT ARGUMENT ON STACK

	DECRA	XCL,1	;DECREMENT COUNT

	ACOMPC	XCL,0,DEFF8,,INTR10	;CHECK FOR END

DEFF10:	INCRA	XPTR,DESCR	;INCREMENT POINTER TO BLOCK

	AEQL	XPTR,WPTR,,DEFFGO

	GETDC	ZPTR,XPTR,DESCR	;GET ARGUMENT NAME FROM BLOCK

	GETDC	TPTR,ZPTR,DESCR	;GET CURRENT VALUE OF ARGUMENT

	PUSH	TPTR	;SAVE CURRENT VALUE

	PUTDC	ZPTR,DESCR,NULVCL	;ASSIGN NULL VALUE TO LOCAL

	BRANCH	DEFF10	;CONTINUE

;_

DEFFGO:	PUSH	<FRTNCL,STNOCL,OCICL,OCBSCL,ZCL,ZCL>

;                                  SAVE SYSTEM STATE

	GETDC	XCL,ZCL,DESCR	;GET ENTRY LABEL

;VERSION 3.3 CHANGE
	AEQLIC XCL,ATTRIB,0,,UNDFFE
	GETDC OCBSCL,XCL,ATTRIB
;VERSION 3.3 CHANGE END
	ACOMPC	TRACL,0,,DEFF18,DEFF18

;                                  CHECK &FTRACE

	DECRA	TRACL,1	;DECREMENT &FTRACE

	GETDC	ATPTR,ZCL,2*DESCR	;GET FUNCTION NAME

	PUSH	ZCL	;SAVE DEFINITION BLOCK

	RCALL	,FENTR2,<ATPTR>,<INTR10,INTR10>

;                                  PERFORM FUNCTION TRACE

	POP	ZCL	;RESTORE DEFINITION BLOCK

DEFF18:	ACOMPC	TRAPCL,0,,DEFF19,DEFF19

;                                  CHECK &TRACE

	GETDC	ATPTR,ZCL,2*DESCR	;GET FUNCTION NAME

	LOCAPT	ATPTR,TFENTL,ATPTR,DEFF19

;                                  CHECK FOR CALL TRACE

	PUSH	<OCBSCL,ZCL>	;SAVE OBJECT CODE BASE AND BLOCK

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	POP	<ZCL,OCBSCL>	;RESTORE BASE AND BLOCK

DEFF19:	INCRA	LVLCL,1	;INCREMENT &FNCLEVEL

	ACOMPC	TRAPCL,0,,DEFF15,DEFF15

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TKEYL,FNCLKY,DEFF15

;                                  LOOK FOR KEYWORD TRACE

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

DEFF15:	SETAC	OCICL,0	;ZERO OFFSET

	RCALL	,INTERP,,<DEFFF,DEFFNR>

;                                  CALL INTERPRETER

	MOVD	RETPCL,RETCL	;SET &RTNTYPE TO RETURN

DEFFS1:	POP	ZCL	;RESTORE DEFINITION BLOCK

	ACOMPC	TRACL,0,,DEFF20,DEFF20

;                                  CHECK &FTRACE

	DECRA	TRACL,1	;DECREMENT &FTRACE

	GETDC	ATPTR,ZCL,2*DESCR	;GET FUNCTION NAME

	PUSH	ZCL	;SAVE DEFINITION BLOCK

	RCALL	,FNEXT2,<ATPTR>,<INTR10,INTR10>

;                                  PERFORM FUNCTION TRACE

	POP	ZCL	;RESTORE DEFINITION BLOCK

DEFF20:	ACOMPC	TRAPCL,0,,DEFFS2,DEFFS2

;                                  CHECK &TRACE

	GETDC	ATPTR,ZCL,2*DESCR	;GET FUNCTION NAME

	LOCAPT	ATPTR,TFEXTL,ATPTR,DEFFS2

;                                  CHECK FOR RETURN TRACE

	PUSH	<RETPCL,ZCL>	;SAVE RETURN AND BLOCK

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	POP	<ZCL,RETPCL>	;RESTORE BLOCK AND RETURN

DEFFS2:	DECRA	LVLCL,1	;DECREMENT &FNCLEVEL

	ACOMPC	TRAPCL,0,,DEFF17,DEFF17

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TKEYL,FNCLKY,DEFF17

;                                  CHECK FOR KEYWORD TRACE

	PUSH	<RETPCL,ZCL>	;SAVE RETURN AND BLOCK

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	POP	<ZCL,RETPCL>	;RESTORE BLOCK AND RETURN

DEFF17:	POP	<ZCL,OCBSCL,OCICL,STNOCL,FRTNCL>

;                                  RESTORE SYSTEM STATE

	GETSIZ	WCL,ZCL	;GET SIZE OF DEFINITION BLOCK

	DECRA	WCL,DESCR	;DECREMENT POINTER

	ACOMPC	WCL,0,,INTR10,INTR10

;                                  CHECK FOR END

	SUM	WPTR,ZCL,WCL	;COMPUTE POINTER TO LAST DESCRIPTOR

	MOVD	YPTR,ZCL	;SAVE POINTER TO BLOCK

	INCRA	YPTR,DESCR	;INCREMENT POINTER

	GETDC	ZPTR,YPTR,DESCR	;GET FUNCTION NAME

	GETDC	ZPTR,ZPTR,DESCR	;GET VALUE TO BE RETURNED

DEFF6:	POP	XPTR	;GET OLD VALUE

	GETDC	YPTR,WPTR,DESCR	;GET ARGUMENT NAME

	PUTDC	YPTR,DESCR,XPTR	;RESTORE OLD VALUE

	DECRA	WPTR,DESCR	;DECREMENT POINTER

	AEQL	WPTR,ZCL,DEFF6	;CHECK FOR END

	DEQL	RETPCL,FRETCL,,FAIL	;CHECK FOR FRETURN

	DEQL	RETPCL,NRETCL,RTZPTR

;                                  CHECK FOR NRETURN

	MOVD	XPTR,ZPTR	;MOVE NAME TO CORRECT DESCRIPTOR

	VEQLC	XPTR,S,,DEFFVX	;CHECK FOR NATURAL VARIABLE

	VEQLC	XPTR,I,,GENVIX	;CONVERT INTEGER

	VEQLC	XPTR,N,,RTXNAM	;CHECK FOR CREATED VARIABLE

	VEQLC	XPTR,K,NONAME,RTXNAM

;                                  CHECK FOR KEYWORD VARIABLE

DEFFVX:	AEQLC	XPTR,0,RTXNAM,NONAME

;                                  CHECK FOR NULL STRING

;_

DEFFF:	MOVD	RETPCL,FRETCL	;SET UP FRETURN

	BRANCH	DEFFS1	;JOIN PROCESSING

;_

DEFFC:	PUSH	<XCL,WCL,YCL,YPTR>	;SAVE RELEVANT DESCRIPTORS

	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,DEFFN>

;                                  EVALUATE ARGUMENT

	POP	<YPTR,YCL,WCL,XCL>	;RESTORE RELEVANT VARIABLES

	BRANCH	DEFF3	;JOIN PROCESSING

;_

DEFFN:	POP	<YPTR,YCL,WCL,XCL>	;RESTORE RELEVANT VARIABLES

	BRANCH	DEFF2	;JOIN PROCESSING

;_

DEFFNR:	MOVD	RETPCL,NRETCL	;SET UP NRETURN

	BRANCH	DEFFS1	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'EXTERNAL FUNCTIONS'

;

;      LOAD(P)

;

LOAD:	PROC	,	;LOAD(P)

	RCALL	XPTR,VARVAL,,FAIL	;GET PROTOTYPE

	PUSH	XPTR	;SAVE PROTOTYPE

	RCALL	WPTR,VARVAL,,FAIL	;GET LIBRARY NAME

	LOCSPX	VSP,WPTR	;GET SPECIFIER FOR LIBRARY

	POP	XPTR	;RESTORE PROTOTYPR

	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR PROTOTYPE

	STREAM	YSP,XSP,VARATB,PROTER,PROTER

;                                  GET FUNCTION NAME FROM PROTOTYPE

	AEQLC	STYPE,LPTYP,PROTER	;VERIFY LEFT PARENTHESIS

	RCALL	XPTR,GENVAR,YSPPTR	;GENERATE VARIABLE FOR FUNCTION

	RCALL	ZCL,FINDEX,XPTR	;FIND FUNCTION

	MOVD	YCL,ZEROCL	;SET ARGUMENT COUNT TO ZERO

LOAD4:	FSHRTN	XSP,1	;REMOVE BREAK CHARACTER

	STREAM	ZSP,XSP,VARATB,LOAD1,PROTER

;                                  BREAK OUT ARGUMENT

	SELBRA	STYPE,<PROTER,,LOAD6>

;                                  BRANCH ON BREAK TYPE

	RCALL	XPTR,GENVAR,ZSPPTR	;GENERATE VARIABLE FOR DATA TYPE

	LOCAPV	XPTR,DTATL,XPTR,LOAD9

;                                  LOOK UP DATA TYPE

	GETDC	XPTR,XPTR,DESCR	;EXTRACT DATA TYPE CODE

	PUSH	XPTR	;SAVE DATA TYPE CODE

LOAD10:	INCRA	YCL,1	;INCREMENT COUNT OF ARGUMENTS

	BRANCH	LOAD4	;CONTINUE

;_

LOAD6:	INCRA	YCL,1	;COUNT LAST ARGUMENT

	RCALL	XPTR,GENVAR,ZSPPTR	;GENERATE VARIABLE FOR DATA TYPE

	LOCAPV	XPTR,DTATL,XPTR,LOAD11

;                                  LOOK UP DATA TYPE

	GETDC	XPTR,XPTR,DESCR	;GET DATA TYPE CODE

	PUSH	XPTR	;SAVE DATA TYPE CODE

LOAD13:	FSHRTN	XSP,1	;DELETE RIGHT PARENTHESIS

	RCALL	XPTR,GENVAR,XSPPTR	;GENERATE VARIABLE FOR TARGET

	LOCAPV	XPTR,DTATL,XPTR,LOAD7

;                                  LOOK UP DATA TYPE

	GETDC	XPTR,XPTR,DESCR	;GET DATA TYPE CODE

	PUSH	XPTR	;SAVE DATA TYPE CODE

LOAD8:	SETVA	LODCL,YCL	;INSERT NUMBER OF ARGUMENTS

	INCRA	YCL,1	;INCREMENT COUNT

	MULTC	XCL,YCL,DESCR	;CONVERT TO ADDRESS UNITS

	INCRA	XCL,DESCR	;ADD SPACE FOR ENTRY POINT

	SETVC	XCL,B	;INSERT BLOCK DATA TYPE

	RCALL	XPTR,BLOCK,XCL	;ALLOCATE BLOCK FOR DEFINITION

	PUTDC	ZCL,0,LODCL	;INSERT PROCEDURE DESCRIPTOR

	PUTDC	ZCL,DESCR,XPTR	;INSERT DEFINITION BLOCK

	SUM	XPTR,XPTR,XCL	;COMPUTE POINTER TO END OF BLOCK

LOAD12:	DECRA	XPTR,DESCR	;DECREMENT POINTER

	POP	YPTR	;RESTORE DATA TYPE

	PUTDC	XPTR,DESCR,YPTR	;INSERT IN BLOCK

	DECRA	YCL,1	;DECREMENT COUNT

	ACOMPC	YCL,0,LOAD12	;CHECK FOR END

	LOAD	YPTR,YSP,VSP,FAIL	;LOAD EXTERNAL FUNCTION

	PUTDC	XPTR,0,YPTR	;INSERT ENTRY POINT

	BRANCH	RETNUL	;RETURN NULL STRING AS VALUE

;_

LOAD7:	PUSH	ZEROCL	;SAVE 0 FOR UNSPECIFIED TYPE

	BRANCH	LOAD8	;CONTINUE

;_

LOAD9:	PUSH	ZEROCL	;SAVE 0 FOR UNSPECIFIED TYPE

	BRANCH	LOAD10	;CONTINUE

;_

LOAD1:	PUSH	ZEROCL	;SAVE 0 FOR UNSPECIFIED TYPE

	SETSP	TSP,XSP	;SET UP BREAK CHECK

	SETLC	TSP,1	;SET LENGTH TO 1

	INCRA	YCL,1

	LEXCMP	TSP,RPRNSP,LOAD4,LOAD13,LOAD4

;_

LOAD11:	PUSH	ZEROCL	;SAVE 0 FOR UNSPECIFIED TYPE

	BRANCH	LOAD13	;CONTINUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      UNLOAD(F)

;

UNLOAD:	PROC	,	;UNLOAD(F)

	RCALL	XPTR,VARVAL,,FAIL	;GET FUNCTION NAME

	RCALL	ZCL,FINDEX,XPTR	;LOCATE FUNCTION DESCRIPTOR

	PUTDC	ZCL,0,UNDFCL	;UNDEFINE FUNCTION

	LOCSPX	XSP,XPTR	;GET SPECIFIER

	UNLOAD	XSP	;UNLOAD EXTERNAL DEFINITION

	BRANCH	RETNUL	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      LINKAGE TO EXTERNAL FUNCTIONS

;

LNKFNC:	PROC	,	;PROCEDURE TO LINK TO EXTERNALS

	SETAV	XCL,INCL	;GET ACTUAL NUMBER OF ARGUMENTS

	MOVD	WCL,XCL	;SAVE COPY

	MOVD	YCL,INCL	;SAVE FUNCTION DESCRIPTOR

	GETDC	ZCL,YCL,DESCR	;GET DEFINITION BLOCK

	PSTACK	YPTR	;POST STACK POSITION

	SETAC	TCL,2*DESCR	;SET OFFSET FOR FIRST ARGUMENT

LNKF1:	PUSH	<XCL,ZCL,TCL,YPTR,WCL,YCL>

;                                  SAVE WORKING DESCRIPTORS

	RCALL	XPTR,ARGVAL,,FAIL	;EVALUATE ARGUMENT

	POP	<YCL,WCL,YPTR,TCL,ZCL,XCL>

;                                  RESTORE WORKING DESCRIPTORS

LNKF7:	GETD	ZPTR,ZCL,TCL	;GET DATA TYPE REQUIRED

	VEQLC	ZPTR,0,,LNKF6	;CHECK FOR POSSIBLE CONVERSION

	VEQL	ZPTR,XPTR,,LNKF6	;SKIP IF DATA TYPES THE SAME

	SETAV	DTCL,XPTR	;DATA TYPE OF ARGUMENT

	MOVV	DTCL,ZPTR	;DATA TYPE REQUIRED

	DEQL	DTCL,VIDTP,,LNKVI	;STRING-INTEGER

	DEQL	DTCL,IVDTP,,LNKIV	;INTEGER-STRING

	DEQL	DTCL,RIDTP,,LNKRI	;REAL-INTEGER

	DEQL	DTCL,IRDTP,,LNKIR	;INTEGER-REAL

	DEQL	DTCL,RVDTP,,LNKRV	;REAL-STRING

	DEQL	DTCL,VRDTP,INTR1,LNKVR

;                                  STRING-REAL

LNKIV:	RCALL	XPTR,GNVARI,XPTR,LNKF6

;                                  CONVERT INTEGER TO STRING

;_

LNKRI:	RLINT	XPTR,XPTR,INTR1,LNKF6

;                                  CONVERT REAL TO INTEGER

;_

LNKIR:	INTRL	XPTR,XPTR	;CONVERT INTEGER TO REAL

	BRANCH	LNKF6

;_

LNKVR:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	SPCINT	XPTR,XSP,,LNKIR	;CONVERT STRING TO INTEGER

	SPREAL	XPTR,XSP,INTR1,LNKF6

;                                  CONVERT STRING TO REAL

;_

LNKRV:	REALST	XSP,XPTR

	RCALL	XPTR,GENVAR,XSPPTR,LNKF6

;_

LNKVI:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	SPCINT	XPTR,XSP,,LNKF6	;CONVERT TO INTEGER

	SPREAL	XPTR,XSP,INTR1,LNKRI

;                                  CONVERT STRING TO REAL

LNKF6:	INCRA	TCL,DESCR	;INCREMENT OFFSET

	PUSH	XPTR	;SAVE ARGUMENT

	DECRA	XCL,1	;DECREMENT ARGUMENT COUNT

	ACOMPC	XCL,0,LNKF1,,LNKF4	;CHECK FOR END

	GETDC	WPTR,YCL,0	;GET PROCEDURE DESCRIPTOR

	SETAV	WPTR,WPTR	;GET ARGUMENT COUNT REQUIRED

LNKF4:	ACOMP	WCL,WPTR,LNKF9,LNKF5

;                                  CHECK AGAINST ARGUMENTS OCCURRING

	MOVD	XPTR,NULVCL	;SUPPLY NULL STRING

	INCRA	WCL,1	;INCREMENT COUNT

	BRANCH	LNKF7

;_

LNKF9:	POP	ZPTR	;THROW AWAY EXTRA ARGUMENT

	DECRA	WCL,1	;DECREMENT ARGUMENT COUNT

	BRANCH	LNKF4	;CONTINUE

;_

LNKF5:	GETSIZ	WCL,ZCL	;GET SIZE OF DEFINITION BLOCK

	SUM	XPTR,ZCL,WCL	;COMPUTE POINTER TO END

	GETDC	ZPTR,XPTR,0	;GET DATA TARGET DESCRIPTOR

	GETDC	ZCL,ZCL,DESCR	;GET FUNCTION ADDRESS

	INCRA	YPTR,2*DESCR	;GET POINTER TO ARGUMENT LIST

	LINK	ZPTR,YPTR,WPTR,ZCL,FAIL

;                                  LINK TO EXTERNAL FUNCTION

	VEQLC	ZPTR,L,RTZPTR	;CHECK FOR LINKED STRING

	GETSPC	ZSP,ZPTR,0	;GET SPECIFIER

	BRANCH	GENVRZ	;GO GENERATE VARIABLE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'ARRAYS, TABLES, AND DEFINED DATA OBJECTS'

;

;      ARRAY(P,V)

;

ARRAY:	PROC	,	;ARRAY(P,V)

	RCALL	XPTR,VARVAL,,FAIL	;GET PROTOTYPE

	PUSH	XPTR	;SAVE PROTOTYPE

	RCALL	TPTR,ARGVAL,,FAIL	;GET INITIAL VALUE FOR ARRAY ELEMENTS

	POP	XPTR	;RESTORE PROTOTYPE

	SETAC	ARRMRK,0	;CLEAR PROTOTYPE ANALYSIS SWITCH

	MOVD	WCL,ZEROCL	;INITIALIZE DIMENSIONALITY TO ZERO

	MOVD	XCL,ONECL	;INITIALIZE SIZE TO ONE

	LOCSPX	XSP,XPTR	;GET SPECIFIER TO PROTOTYPE

	PUSH	XPTR	;SAVE PROTOTYPE FOR LATER INSERTION

ARRAY1:	AEQLC	ARRMRK,0,ARRAY7	;TEST FOR END OF PROTOTYPE ANALYSIS

	STREAM	YSP,XSP,NUMBTB,PROTER,ARROT1

	SPCINT	YCL,YSP,PROTER	;CONVERT STRING TO INTEGER

	SELBRA	STYPE,<,ARRAY3>	;BRANCH ON COLON OR COMMA

	FSHRTN	XSP,1	;DELETE COLON

	STREAM	ZSP,XSP,NUMBTB,PROTER,ARROT2

	SPCINT	ZCL,ZSP,PROTER	;CONVERT UPPER BOUND TO INTEGER

	SELBRA	STYPE,<PROTER,ARRAY5>

;                                  VERIFY BREAK CHARACTER

;_

ARRAY3:	ACOMPC	YCL,0,,PROTER,PROTER

;                                  SINGLE NUMBER MUST BE POSITIVE

	MOVD	ZCL,YCL	;MOVE TO COPY

	SETAC	YCL,1	;SET LOWER BOUND TO DEFAULT OF ONE

	BRANCH	ARRAY6

;_

ARRAY5:	SUBTRT	ZCL,ZCL,YCL	;COMPUTE DIFFERENCE

	SUM	ZCL,ZCL,ONECL	;ADD ONE

	ACOMPC	ZCL,0,,,PROTER

ARRAY6:	SETVA	YCL,ZCL	;INSERT WIDTH OF DIMENSION

	PUSH	YCL	;SAVE DIMENSION INFORMATION

	MULT	XCL,XCL,ZCL,PROTER	;COMPUTE SIZE OF ARRAY TO THIS POINT

	INCRA	WCL,1	;INCREASE COUNT OF DIMENSIONS

	FSHRTN	XSP,1	;REMOVE BREAK CHARACTER

	BRANCH	ARRAY1

;_

ARROT1:	SETAC	ARRMRK,1	;ON RUN OUT, MARK END OF PROTOTYPE

	SPCINT	YCL,YSP,PROTER,ARRAY3

;                                  CONVERT STRING TO INTEGER

;_

ARROT2:	SETAC	ARRMRK,1	;ON RUN OUT, MARK END OF PROTOTYPE

	SPCINT	ZCL,ZSP,PROTER,ARRAY5

;                                  CONVERT STRING TO INTEGER

;_

ARRAY7:	SUM	ZCL,XCL,WCL	;ADD DIMENSIONALITY TO ARRAY SIZE

	INCRA	ZCL,2	;ADD TWO FOR HEADING INFORMATION

	MULTC	ZCL,ZCL,DESCR	;CONVERT TO ADDRESS UNITS

	SETVC	ZCL,A	;INSERT ARRAY DATA TYPE

	RCALL	ZPTR,BLOCK,ZCL	;ALLOCATE BLOCK FOR ARRAY STRUCTURE

	MOVD	XPTR,ZPTR	;SAVE COPY

	SUM	WPTR,XPTR,ZCL	;GET POINTER TO LAST DESCRIPTOR

	PUTDC	ZPTR,2*DESCR,WCL	;INSERT DIMENSIONALITY

	INCRA	XPTR,DESCR	;UPDATE WORKING POINTER

ARRAY8:	INCRA	XPTR,DESCR	;UPDATE WORKING POINTER FOR ANOTHER

	POP	YPTR	;RESTORE INDEX PAIR

	PUTDC	XPTR,DESCR,YPTR	;INSERT IN STRUCTURE

	DECRA	WCL,1	;DECREMENT DIMENSIONALITY

	ACOMPC	WCL,0,ARRAY8,ARRFIL	;CHECK FOR LAST ONE

ARRAY9:	PUTDC	XPTR,DESCR,TPTR	;INSERT INITIAL VALUE

ARRFIL:	INCRA	XPTR,DESCR	;UPDATE WORKING POINTER

	ACOMP	XPTR,WPTR,INTR10,,ARRAY9

;                                  CHECK FOR END

	POP	YPTR	;RESTORE PROTOTYPE

	PUTDC	ZPTR,DESCR,YPTR	;INSERT PROTOTYPE IN STRUCTURE

	BRANCH	RTZPTR	;RETURN POINTER TO ARRAY STRUCTURE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      TABLE(N,M)

;

ASSOC:	PROC	,	;TABLE(N,M)

	RCALL	XPTR,INTVAL,,FAIL	;GET TABLE SIZE

	PUSH	XPTR	;SAVE SIZE

	RCALL	WPTR,INTVAL,,FAIL	;GET SECONDARY ALLOCATION

	POP	XPTR	;RESTORE SIZE

	ACOMPC	XPTR,0,ASSOC1,,LENERR

	SETAC	XPTR,EXTSIZ

;VERSION 3.3 CHANGE
ASSOC1:	INCRA XPTR,1
	MULTC XPTR,XPTR,2*DESCR
;VERSION 3.3 CHANGE END
	ACOMPC	WPTR,0,ASSOC4,,LENERR

	SETAC	WPTR,EXTSIZ

;VERSION 3.3 CHANGE
ASSOC4:	INCRA WPTR,1
	MULTC WPTR,WPTR,2*DESCR
	SETVC XPTR,T
;VERSION 3.3 CHANGE END
;VERSION 3.3 CHANGE
ASSOCE:	PROC ASSOC
	RCALL ZPTR,BLOCK,XPTR
	PUTD ZPTR,XPTR,ONECL
	DECRA XPTR,DESCR
	PUTD ZPTR,XPTR,WPTR
ASSOC2:	DECRA XPTR,2*DESCR
	PUTD ZPTR,XPTR,NULVCL
	AEQLC XPTR,DESCR,ASSOC2,RTZPTR
;VERSION 3.3 CHANGE END
;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DATA(P)

;

DATDEF:	PROC	,	;DATA(P)

	RCALL	XPTR,VARVAL,,FAIL	;GET PROTOTYPE

	SETAC	DATACL,0	;INITIALIZE PROTOTYPE SWITCH

	LOCSPX	XSP,XPTR	;GET SPECIFIER

	STREAM	YSP,XSP,VARATB,PROTER,PROTER

;                                  BREAK OUT DATA TYPE NAME

	AEQLC	STYPE,LPTYP,PROTER	;VERIFY LEFT PARENTHESIS

	RCALL	XPTR,GENVAR,<YSPPTR>

;                                  GENERATE VARIABLE FOR NAME

	RCALL	ZCL,FINDEX,<XPTR>	;FIND FUNCTION DESCRIPTOR

	INCRV	DATSEG,1	;INCREMENT DATA TYPE CODE

	VEQLC	DATSEG,DATSIZ,,INTR27

;                                  CHECK AGAINST LIMIT

	MOVD	YCL,ZEROCL	;INITIALIZE COUNT OF FIELDS

	RCALL	DTATL,AUGATL,<DTATL,DATSEG,XPTR>

;                                  AUGMENT DATA TYPE PAIR LIST

	PSTACK	WPTR	;POST STACK POSITION

	PUSH	<DATSEG,XPTR>	;SAVE CODE AND NAME

DATA3:	FSHRTN	XSP,1	;DELETE BREAK CHARACTER

	AEQLC	DATACL,0,DAT5	;CHECK FOR PROTOTYPE END

	STREAM	YSP,XSP,VARATB,PROTER,PROTER

;                                  BREAK OUT FIELD

	SELBRA	STYPE,<PROTER,,DATA6>

DATA4:	LEQLC	YSP,0,,DATA3	;CHECK FOR ZERO LENGTH

	RCALL	XPTR,GENVAR,YSPPTR	;GENERATE VARIABLE

	PUSH	XPTR	;SAVE FIELD NAME

	RCALL	XCL,FINDEX,<XPTR>	;FIND FUNCTION DESCRIPTOR FOR FIELD

	GETDC	WCL,XCL,0	;GET PROCEDURE DESCRIPTOR

	DEQL	WCL,FLDCL,DAT6	;CHECK FOR FIELD PROCEDURE

	GETDC	ZPTR,XCL,DESCR	;GET FIELD DEFINITION BLOCK

	MULTC	TCL,YCL,DESCR

	RCALL	ZPTR,AUGATL,<ZPTR,DATSEG,TCL>

DAT7:	PUTDC	XCL,DESCR,ZPTR	;INSERT NEW DEFINITION BLOCK

	INCRA	YCL,1

	BRANCH	DATA3	;CONTINUE

;_

DATA6:	SETAC	DATACL,1	;NOTE END OF PROTOTYPE ANALYSIS

	BRANCH	DATA4	;JOIN FIELD PROCESSING

;_

DAT5:	LEQLC	XSP,0,PROTER	;VERIFY PROTOTYPE CONSUMPTION
;VERSION 3.3 ADDITION
	AEQLC YCL,0,,PROTER
;VERSION 3.3 ADDITION END

	SETVA	DATCL,YCL	;INSERT FIELD COUNT FOR DATA FUNCTION

	PUTDC	ZCL,0,DATCL	;INSERT NEW PROCEDURE DESCRIPTOR

	MULTC	YCL,YCL,DESCR

	INCRA	YCL,2*DESCR	;ADD TWO FOR THE NUMBER AND NAME

	MOVV	YCL,DATSEG	;INSERT DEFINED DATA CODE

	RCALL	ZPTR,BLOCK,YCL	;ALLOCATE DEFINITION BLOCK
;VERSION 3.3 ADDITION
	INCRA WPTR,DESCR
;VERSION 3.3 ADDITION END

	MOVBLK	ZPTR,WPTR,YCL	;COPY FROM STACK INTO BLOCK

	PUTDC	ZCL,DESCR,ZPTR	;INSERT DEFINITION BLOCK

	BRANCH	RETNUL	;RETURN NULL VALUE

;_

DAT6:	PUTDC	XCL,0,FLDCL	;INSERT FIELD PROCEDURE DESCRIPTOR

	RCALL	ZPTR,BLOCK,TWOCL	;ALLOCATE DEFINITION BLOCK

	PUTDC	ZPTR,DESCR,DATSEG	;INSERT DATA TYPE CODE

	MULTC	TCL,YCL,DESCR

	PUTDC	ZPTR,2*DESCR,TCL

	BRANCH	DAT7	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      PROTOTYPE(A)

;

PROTO:	PROC	,	;PROTOTYPE(A)

	RCALL	XPTR,ARGVAL,,FAIL	;GET ARGUMENT

	VEQLC	XPTR,A,NONARY	;VERIFY ARRAY

	GETDC	ZPTR,XPTR,DESCR	;GET PROTOTYPE

	BRANCH	RTZPTR	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ARRAY AND TABLE REFERENCES

;

ITEM:	PROC	,	;ARRAY OR TABLE REFERENCE

	SETAV	XCL,INCL	;GET ARGUMENT COUNT

	DECRA	XCL,1	;SKIP REFERENCED OBJECT

	PUSH	XCL	;SAVE COUNT

	RCALL	YCL,ARGVAL,,FAIL	;GET REFERENCED OBJECT

	POP	XCL	;RESTORE COUNT

	VEQLC	YCL,A,,ARYAD3	;ARRAY IS ACCEPTABLE

	VEQLC	YCL,T,NONARY,ASSCR	;TABLE IS ACCEPTABLE

ARYAD3:	MOVD	WCL,XCL	;SAVE COPY OF ARGUMENT COUNT

ARYAD1:	ACOMPC	XCL,0,,ARYAD2,ARYAD2

;                                  COUNT DOWN ON ARGUMENTS

	PUSH	<XCL,WCL,YCL>	;SAVE

	RCALL	XPTR,INTVAL,,FAIL	;GET INDEX

	POP	<YCL,WCL,XCL>	;RESTORE SAVED DESCRIPTORS

	PUSH	XPTR	;SAVE INDEX

	DECRA	XCL,1	;DECREMENT ARGUMENT COUNT

	BRANCH	ARYAD1

;_

ARYAD2:	MOVD	ZPTR,ZEROCL	;INITIALIZE OFFSET TO ZERO

	GETDC	ZCL,YCL,2*DESCR	;GET NUMBER OF DIMENSIONS

	MULTC	YPTR,ZCL,DESCR	;CONVERT TO ADDRESSING UNITS

	SUM	YPTR,YCL,YPTR	;ADD BASE AND OFFSET

	INCRA	YPTR,2*DESCR	;ADD TWO FOR HEADING

ARYAD7:	ACOMP	WCL,ZCL,ARGNER,ARYAD9

;                                  COMPARE GIVEN AND REQUIRED NUMBER

	PUSH	ZEROCL	;IF TOO FEW, SUPPLY A ZERO

	INCRA	WCL,1	;INCREMENT AND LOOP

	BRANCH	ARYAD7

;_

ARYAD9:	INCRA	YCL,2*DESCR

	GETDC	WPTR,YCL,DESCR	;GET INDEX PAIR

	SETAV	TPTR,WPTR	;GET EXTENT OF DIMENSION

ARYA11:	POP	XPTR	;GET INDEX VALUE

	SUBTRT	XPTR,XPTR,WPTR	;COMPUTE DIFFERNECE FROM LOWER BOUND

	ACOMPC	XPTR,0,,,FAIL	;IF LESS THAN ZERO, OUT OF BOUNDS

	ACOMP	XPTR,TPTR,FAIL,FAIL	;IF GREATER THAN EXTENT, OUT OF BOUND

	SUM	XPTR,ZPTR,XPTR	;ELSE ADD TO EVOLVING SUM

	DECRA	ZCL,1	;DECREMENT DIMENSION COUNT

	ACOMPC	ZCL,0,,ARYA12	;GET OUT IF DONE

	INCRA	YCL,DESCR	;ADJUST BAS POINTER

	GETDC	WPTR,YCL,DESCR	;GET INDEX PAIR

	SETAV	TPTR,WPTR	;GET EXTENT OF DIMENSION

	MULT	ZPTR,XPTR,TPTR	;MULTIPLY FOR NEXT DIMENSION

	BRANCH	ARYA11	;CONTINUE WITH NEXT DIMENSION

;_

ARYA12:	MULTC	XPTR,XPTR,DESCR	;EXPAND OFFSET INTO ADDRESSING UNITS

	SUM	XPTR,YPTR,XPTR	;ADD TO ADJUSTED BASE

ARYA10:	SETVC	XPTR,N	;INSERT NAME DATA TYPE

	BRANCH	RTXNAM	;RETURN INTERIOR POINTER

;_

ASSCR:	AEQLC	XCL,1,ARGNER	;ONLY ONE ARGUMENT FOR TABLES

	PUSH	YCL	;SAVE POINTER TO OBJECT

	RCALL	YPTR,ARGVAL,,FAIL	;EVALUATE ARGUMENT

;VERSION 3.3 CHANGE
	POP XPTR
ASSCR5:	LOCAPV WPTR,XPTR,YPTR,,ASSCR4
;VERSION 3.3 CHANGE END
	LOCAPV	WPTR,XPTR,ZEROCL,ASSCR2

;                                  LOOK FOR ITEM WITH NULL VALUE

ASSCR4:	MOVA	XPTR,WPTR

;VERSION 3.3 CHANGE
	PUTDC XPTR,2*DESCR,YPTR
;VERSION 3.3 CHANGE END
	BRANCH	ARYA10	;JOIN ARRAY REFERENCE EXIT

;_

;VERSION 3.3 CHANGE
ASSCR2:	GETSIZ TCL,XPTR
	GETD ZPTR,XPTR,TCL
	AEQLC ZPTR,1,,ASSCR3
	MOVD XPTR,ZPTR
	BRANCH ASSCR5
;_
ASSCR3:	DECRA TCL,DESCR
	GETD WPTR,XPTR,TCL
	PUSH <XPTR,TCL,YPTR>
	MOVD XPTR,WPTR
	RCALL ZPTR,ASSOCE,,<INTR10,INTR10>
	POP <YPTR,TCL,XPTR>
	SETVC ZPTR,B
	INCRA TCL,DESCR
	PUTD XPTR,TCL,ZPTR
	PUTDC ZPTR,2*DESCR,YPTR
	MOVD XPTR,ZPTR
	BRANCH ARYA10
;VERSION 3.3 CHANGE END
;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;      DEFINED OBJECT CREATION

;

DEFDAT:	PROC	,	;PROCEDURE TO CREATE DEFINED OBJECTS

	SETAV	XCL,INCL	;GET GIVEN NUMBER OF ARGUMENTS

	MOVD	WCL,XCL	;SAVE A COPY

	MOVD	YCL,INCL	;SAVE FUNCTION DESCRIPTOR

	PSTACK	YPTR	;POST STACK POSITION

DEFD1:	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,DEFDC	;CHECK FOR FUNCTION

DEFD2:	AEQLC	INSW,0,,DEFD8	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,XPTR,DEFD8

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET ASSOCIATION

	PUSH	<XCL,WCL,YCL,YPTR>	;SAVE RELEVANT DESCRIPTORS

	RCALL	XPTR,PUTIN,<ZPTR,XPTR>,FAIL

	POP	<YPTR,YCL,WCL,XCL>	;RESTORE RELEVANT DESCRIPTORS

	BRANCH	DEFD3	;JOIN MAIN PROCESSING

;_

DEFD8:	GETDC	XPTR,XPTR,DESCR	;GET VALUE

DEFD3:	PUSH	XPTR	;SAVE VALUE

	DECRA	XCL,1	;DECREMENT ARGUMENT COUNT

	ACOMPC	XCL,0,DEFD1,,INTR10	;CHECK FOR END

	GETDC	XCL,YCL,0	;GET PROCEDURE DESCRIPTOR

	SETAV	XCL,XCL	;GET NUMBER OF ARGUMENTS EXPECTED

DEFD4:	ACOMP	WCL,XCL,DEFD5,DEFD5	;COMPARE GIVEN WITH EXPECTED

	PUSH	NULVCL	;SAVE NULL FOR OMITTED ARGUMENT

	INCRA	WCL,1	;INCREMENT COUNT

	BRANCH	DEFD4	;CONTINUE

;_

DEFD5:	GETDC	WCL,YCL,DESCR	;GET DEFINITION BLOCK

	MULTC	XCL,XCL,DESCR

	MOVV	XCL,WCL	;INSERT DATA TYPE CODE

	RCALL	ZPTR,BLOCK,XCL	;ALLOCATE BLOCK FOR DATA OBJECT

	INCRA	YPTR,DESCR	;ADJUST STACK POSITION

	MOVBLK	ZPTR,YPTR,XCL	;MOVE VALUES INTO BLOCK

	BRANCH	RTZPTR	;RETURN NEW OBJECT

;_

DEFDC:	PUSH	<XCL,WCL,YCL,YPTR>	;SAVE RELEVANT DESCRIPTORS

	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,DEFDN>

	POP	<YPTR,YCL,WCL,XCL>	;RESTORE RELEVANT DESCRIPTORS

	BRANCH	DEFD3	;JOIN MAIN PROCESSING

;_

DEFDN:	POP	<YPTR,YCL,WCL,XCL>	;RESTORE RELEVANT DESCRIPTORS

	BRANCH	DEFD2	;JOIN MAIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      FIELDS OF DEFINED DATA OBJECTS

;

FIELD:	PROC	,	;FIELD FUNCTION PROCEDURE

	PUSH	INCL	;SAVE FUNCTION DESCRIPTOR

	RCALL	XPTR,ARGVAL,,FAIL	;GET VALUE

	DEQL	XPTR,NULVCL,,NONAME	;CHECK FOR NULL VALUE

	POP	YCL	;RESTORE FUNCTION DESCRIPTOR

	VEQLC	XPTR,I,FIELD1	;CHECK FOR INTEGER

	RCALL	XPTR,GNVARI,XPTR	;CONVERT INTEGER TO STRING

FIELD1:	MOVV	DT1CL,XPTR	;SET UP DATA TYPE

	GETDC	YPTR,YCL,DESCR	;GET DEFINITION BLOCK

	LOCAPT	ZCL,YPTR,DT1CL,INTR1

;                                  LOOK FOR DATA TYPE OFFSET

	GETDC	ZCL,ZCL,2*DESCR	;GET OFFSET

	SUM	XPTR,XPTR,ZCL	;COMPUTE FIELD POSITION

	SETVC	XPTR,N	;INSERT NAME DATA TYPE

	BRANCH	RTXNAM	;RETURN NAME

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'INPUT AND OUTPUT'

;

;      INPUT(V,U,L)

;

READ:	PROC	,	;INPUT(V,U,L)

	RCALL	XPTR,IND,,FAIL	;GET VARIABLE

	PUSH	XPTR	;SAVE VARIABLE

	RCALL	YPTR,INTVAL,,FAIL	;GET UNIT

	PUSH	YPTR	;SAVE UNIT

	RCALL	ZPTR,INTVAL,,FAIL	;GET LENGTH

	POP	<YPTR,XPTR>	;RESTORE UNIT AND VARIABLE

	ACOMPC	YPTR,0,,READ5,UNTERR

;                                  CHECK FOR DEFAULTED UNIT

READ6:	ACOMPC	ZPTR,0,READ2,,LENERR

;                                  CHECK FOR DEFAULTED LENGTH

	LOCAPT	TPTR,INSATL,YPTR,READ4

;                                  LOOK FOR DEFAULT LENGTH

READ3:	LOCAPV	ZPTR,INATL,XPTR,READ1

;                                  LOOK FOR EXISTING ASSOCIATION

	PUTDC	ZPTR,DESCR,TPTR	;INSET INPUT BLOCK

	BRANCH	RETNUL	;RETURN

;_                                 ADD NEW ASSOCIATION PAIR

READ1:	RCALL	INATL,AUGATL,<INATL,TPTR,XPTR>,RETNUL

;_

READ4:	MOVD	ZPTR,DFLSIZ	;SET STANDARD DEFAULT

READ2:	RCALL	TPTR,BLOCK,IOBLSZ	;ALLOCATE BLOCK

	PUTDC	TPTR,DESCR,YPTR	;INSERT UNIT

	PUTDC	TPTR,2*DESCR,ZPTR	;INSERT FORMAT

	BRANCH	READ3	;REJOIN PROCESSING

;_

READ5:	SETAC	YPTR,UNITI	;SET UP DEFAULT UNIT

	BRANCH	READ6	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      OUTPUT(V,U,F)

;

PRINT:	PROC	,	;OUTPUT(V,U,F)

	RCALL	XPTR,IND,,FAIL	;GET VARIABLE

	PUSH	XPTR	;SAVE VARIABLE

	RCALL	YPTR,INTVAL,,FAIL	;GET UNIT

	PUSH	YPTR	;SAVE UNIT

	RCALL	ZPTR,VARVAL,,FAIL	;GET FORMAT

	POP	<YPTR,XPTR>	;RESTORE UNIT AND VARIABLE

	ACOMPC	YPTR,0,,PRINT5,UNTERR

PRINT6:	AEQLC	ZPTR,0,PRINT2	;CHECK FOR DEFAULTED FORMAT

	LOCAPT	TPTR,OTSATL,YPTR,PRINT4

;                                  INSERT LENGTH

PRINT3:	LOCAPV	ZPTR,OUTATL,XPTR,PRINT1

;                                  LOOK FOR OUTPUT ASSOCIATION

	PUTDC	ZPTR,DESCR,TPTR	;INSERT OUTPUT BLOCK

	BRANCH	RETNUL	;RETURN

;_

PRINT1:	RCALL	OUTATL,AUGATL,<OUTATL,TPTR,XPTR>,RETNUL

;                                  ADD NEW ASSOCIATION PAIR

;_

PRINT4:	MOVD	ZPTR,DFLFST	;SET UP STANDARD DEFAULT

PRINT2:	RCALL	TPTR,BLOCK,IOBLSZ	;ALLOCATE BLOCK

	PUTDC	TPTR,DESCR,YPTR	;INSERT UNIT

	PUTDC	TPTR,2*DESCR,ZPTR	;INSERT FORMAT

	BRANCH	PRINT3	;REJOIN PROCESSING

;_

PRINT5:	SETAC	YPTR,UNITO	;SET DEFAULT UNIT

	BRANCH	PRINT6	;JOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      BACKSPACE(U), ENDFILE(U), AND REWIND(U)

;

BKSPCE:	PROC	,	;BACKSPACE(N)

	SETAC	SCL,1	;INDICATE BACKSPACE

	BRANCH	IOOP

;_

ENFILE:	PROC	BKSPCE	;ENDFILE(N)

	SETAC	SCL,2	;INDICATE END OF FILE

	BRANCH	IOOP

;_

REWIND:	PROC	BKSPCE	;REWIND(N)

	SETAC	SCL,3	;INDICATE REWIND

IOOP:	PUSH	SCL	;PUSH INDICATOR

	RCALL	XCL,INTVAL,,FAIL	;EVALUATE INTEGER ARGUMENT

	ACOMPC	XCL,0,,UNTERR,UNTERR

;                                  REJECT NEGATIVE OR ZERO

	POP	SCL	;RESTORE INDICATOR

	SELBRA	SCL,<,EOP,ROP>	;SELECT OPERATION

	BKSPCE	XCL	;BACKSPACE UNIT

	BRANCH	RETNUL

;_

EOP:	ENFILE	XCL	;END FILE UNIT

	BRANCH	RETNUL

;_

ROP:	REWIND	XCL	;REWIND UNIT

	BRANCH	RETNUL

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DETACH(N)

;

DETACH:	PROC	,	;DETACH(N)

	RCALL	XPTR,IND,,FAIL	;GET NAME OF VARIABLE

	LOCAPV	ZPTR,INATL,XPTR,DTCH1

;                                  LOOK FOR INPUT ASSOCIATION

	PUTDC	ZPTR,DESCR,ZEROCL	;DELETE ASSOCIATION IF THERE IS ONE

	PUTDC	ZPTR,2*DESCR,ZEROCL	;CLEAR ASSOCIATION POINTER ALSO

DTCH1:	LOCAPV	ZPTR,OUTATL,XPTR,RETNUL

;                                  LOOK FOR OUTPUT ASSOCIATION

	PUTDC	ZPTR,DESCR,ZEROCL	;DELETE ASSOCIATION IS THERE IS ONE

	PUTDC	ZPTR,2*DESCR,ZEROCL	;CLEAR ASSOCIATION POINTER ALSO

	BRANCH	RETNUL	;RETURN NULL VALUE

;_

;	THIS CODING HANDLES AN END OF FILE WHILE READING
;	IN A SOURCE FILE. WHEN AN EOF IS SEEN AN ATTEMPT
;	IS MADE TO SEE IF THE USER SPECIFIED  ANOTHER
;	FILENAME TO READ FROM, I.E.

;	FACTOR_SYS:FUNCT1,FUNCT2,DSK:MYPROG<CR>

;	THIS ALLOWS A USER TO RETREIVE LIBRARY FILES  OR
;	PROGRAMS PREVIOUSLY WRITTEN AS SEPARATE FILES.
;	THIS ROUTINE IS CALLABLE FROM A VARIETY
;	OF PLACES, BUT PRIMARILY IN STREAD MACRO CALLS
;	ON THE EOF EXIT


	EXTERN RELEASE,ACSAVE,GETSRC,FIXSRC,NUMINP,SRCFIL
	EXTERN SNOFLG
EOF:
NXTSRC:	JSA Q,RELEASE	;TURN OFF CURRENT ASSOCIATIONS
	JUMP 0,NUMINP
	PUSHJ PDP,ACSAVE
	SETOM SNOFLG
	PUSHJ PDP,GETSRC
	SETZM SNOFLG
	PUSHJ PDP,FIXSRC
	PUSHJ PDP,ACSAVE
	SKIPA 1,.+1
	EXP -1
	CAME 1,SRCFIL	;SEE IF THERE WAS AN EOF
	JRST EOFW1
	UNSTAK PDP,(PDP)	;CLEAN THE STACK
	JRST FAIL
EOFW1:	POPJ PDP,
;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      INPUT PROCEDURE

;

PUTIN:	PROC	,	;INPUT PROCEDURE

	POP	<IO1PTR,IO2PTR>	;RESTORE BLOCK AND VARIABLE

	GETDC	IO3PTR,IO1PTR,DESCR	;GET UNIT

	GETDC	IO1PTR,IO1PTR,2*DESCR

;                                  GET LENGTH

	ACOMP	IO1PTR,MLENCL,INTR8	;CHECK &MAXLNGTH

	RCALL	IO4PTR,CONVAR,<IO1PTR>

;                                  GET SPACE FOR STRING

	LOCSPX	IOSP,IO4PTR	;GET SPECIFIER

	INCRA	RSTAT,1	;INCREMENT COUNT OF READS

;	THIS CODE HANDLES CHARACTER INPUT FROM THE USER'S TTY.
;	IT INTERFACES THE SNOBOL USER TO THE TTCALL UUO OF THE
;	PDP-10/50 MONITOR.
;	THIS CODE IS MEANT TO BE INSERTED BEFORE THE 'STREAD'
;	CALL IN THE PUTIN ROUTINE.

;	THE KEY IDEA IS TO INTERCEPT ALL INPUT FROM UNIT 99
;	AND ACCEPT IT ONLY FROM THE TTY.

	MOVEI A0,UNITC	;IS IT UNIT 99?
	CAME A0,IO3PTR
	JRST PUTIN2	;NO

;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

	TTCALL 0,A0
	MOVE A1,IOSP+SPECO
	IDPB A0,A1
	MOVE A2,IOSP+SPECL	;CLEAR THE REMAINDER OF THE BLOCK
	SUBI A2,1	;ACCOUNT FOR THE REAL CHARACTER
	MOVEI A0,0	;FILL IT WITH NULLS
	IDPB A0,A1
	SOJG A2,.-1
	MOVEI A0,1	;INDICATE STRING LENGTH OF 1
	MOVEM A0,IOSP+SPECL
	MOVEM A0,IO1PTR	;JAM NEW STRING LENGTH IN THIS MAGIC LOC
	JRST PUTIN3

PWADE1:	PUSHJ PDP,EOF


	JRST PUTIN2
PUTIN2:

;	THE STREAD LOGICALLY GOES HERE, WITH THE PUTIN3 LABEL
;	AFTER IT
;PUTIN3:

	STREAD	IOSP,IO3PTR,PWADE1,COMP5

PUTIN3:

;                                  PERFORM READ

	AEQLC	TRIMCL,0,,PUTIN1	;CHECK &INPUT

	TRIMSP	IOSP,IOSP	;TRIM STRING

	GETLG	IO1PTR,IOSP	;GET LENGTH

PUTIN1:	RCALL	IO1PTR,GNVARS,IO1PTR

;                                  FORM VARIABLE FOR STRING

	PUTDC	IO2PTR,DESCR,IO1PTR	;ASSIGN VALUE

; THIS CODE GIVES A FATAL ERROR MESSAGE IF THE USER IO BUFFER
; SPACE HAS SPILLED OUT INTO THE FREE STORAGE AREA. IT PREVENTS
; HIM FROM GETTING RANDOM GARBAGING AND MEANINGLESS ERROR MSGS.


; ADD A CALL OUTSIDE FOR MORE INTELLIGENT RECOVERY LATER

	EXTERN INCIOB
	PUSHJ PDP,INCIOB

	HRRZ A0,JOBFF
	EXTERN JOBFF
	CAML A0,HDSGPT
	JRST IOBERR	;A NEW ERROR MESSAGE

;********************************************* LPW :****
	RRTURN	IO1PTR,2	;RETURN VALUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      OUTPUT PROCEDURE

;

PUTOUT:	PROC	,	;OUTPUT PROCEDURE

	POP	<IO1PTR,IO2PTR>	;RESTORE BLOCK AND VALUE

	VEQLC	IO2PTR,S,,PUTV	;IS VALUE STRING?

	VEQLC	IO2PTR,I,,PUTI	;IS VALUE INTEGER?

	RCALL	IO2PTR,DTREP,IO2PTR	;GET DATA TYPE REPRESENTATION

	GETSPC	IOSP,IO2PTR,0	;GET SPECIFIER

	BRANCH	PUTVU	;JOIN PROCESSING

;_

PUTV:	LOCSPX	IOSP,IO2PTR	;GET SPECIFIER

PUTVU:

;	THIS CODE HANDLES CHARACTER OUTPUT TO THE USER'S TTY
;	AND INTERFACES THE SNOBOL USER TO THE TTCALL UUO
;	OF THE PDP-10/50 MONITOR.
;	THIS CODE IS MEANT TO BE INSERTED AT PUTVU IN THE
;	PUTOUT ROUTINE

;	THE KEY IDEA HERE IS TO INTERCEPT
;	ALL OUTPUT TO UNIT '99' ( A DUMMY UNIT ) AND SEND
;	IT TO THE TTY

	MOVE A0,IO1PTR
	MOVE A0,DESCR(A0)	;GET FORTRAN DEVICE NO.
	CAIE A0,UNITC		;SPECIAL CHECK FOR 99
	JRST PUTVU1
	MOVEI A1,0	;TRICK IS TO TERMINATE STRING WITH A NULL
	MOVE A0,IOSP+SPECO
	SKIPN A2,IOSP+SPECL	;CAREFUL FOR NULL STRINGS
	JRST PUTVU2
	IBP A0
	SOJG A2,.-1
	IDPB A1,A0	;DROP IN A NULL CHARACTER
	HRRZ A0,IOSP+SPECO
	TTCALL 3,(A0)		;ASSUME IT IS LEFT JUSTIFIED
	JRST PUTVU2
PUTVU1:

;	STPRNT GOES BETWEEN THE LABELS
;	PUTVU1 AND PUTVU2

;PUTVU2:

	STPRNT	IOKEY,IO1PTR,IOSP	;PERFORM THE PRINT

PUTVU2:


	INCRA	WSTAT,1	;INCREMENT COUNT OF WRITES

; THIS CODE WATCHES FOR THE CASE WHERE THE USERS IO BUFFER SPACE
; HAS OVERFLOWED INTO THE FREE STORAGE AREA AND GIVES A FATAL ERROR
; MESSAGE.


; ADD A CALL OUT FOR A MORE INTELLIGENT ERROR RECOVERY PROCED LATER

	PUSHJ PDP,INCIOB

	HRRZ A0,JOBFF
	CAML A0,HDSGPT	;HAVE BOUNDARIES CROSSED
	JRST IOBERR	;YES, SO GIVE THE NEW ERROR MESSAGE

;**************************** LPW ******************************
	BRANCH	RTN1	;RETURN

;_

PUTI:	INTSPC	IOSP,IO2PTR	;CONVERT INTEGER TO STRING

	BRANCH	PUTVU	;REJOIN PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE 'OFILE (PRIMITIVE FUNCTION)'

OFILEF:	PROC	,	;OF THE FORM OFILE(I,F)

;	EVALUATE I AS AN INTEGER

	RCALL XPTR,INTVAL,,FAIL
	PUSH XPTR

;	EVALUATE F AS A VARIABLE (STRING)

	RCALL YPTR,VARVAL,,FAIL
	POP XPTR
	LOCSPX YSP,YPTR
	OFILEM XPTR,YSP
	BRANCH RETNUL

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE 'IFILE-PRIMITIVE FUNCTION'

;	UNIQUE TO THE PDP-10, THIS FUNCTION ALLOWS THE
;	SNOBOL PROGRAMMER THE ABILITY TO OPEN DISK OR
;	DECTAPE FILES AT RUN TIME. THIS CODE INTERFACES
;	TO THE IFILE FORTRAN SUBROUTINE.

IFILEF:	PROC	,
;	EVALUATE I AS AN INTEGER

	RCALL XPTR,INTVAL,,FAIL
	PUSH XPTR
;	EVALUATE F AS A VARIABLE(STRING)

	RCALL YPTR,VARVAL,,FAIL
	POP XPTR
	LOCSPX YSP,YPTR
	IFILEM XPTR,YSP		;OPEN THE FILE
	BRANCH RETNUL


;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'TRACING PROCEDURES AND FUNCTIONS'

;

;      TRACE(V,R,T,F)

;

TRACE:	PROC	,	;TRACE(V,R,T,F)

	RCALL	XPTR,IND,,FAIL	;GET NAME OF VARIABLE

	PUSH	XPTR	;SAVE NAME

	RCALL	YPTR,VARVAL,,FAIL	;GET TRACE TYPE

	PUSH	YPTR	;SAVE TYPE

	RCALL	WPTR,ARGVAL,,FAIL	;GET TAG

	PUSH	WPTR	;SAVE TAG

	RCALL	ZPTR,VARVAL,,FAIL	;GET TRACE FUNCTION

	POP	<WPTR,YPTR,XPTR>	;RESTORE SAVED ARGUMENTS

	DEQL	YPTR,NULVCL,TRAC5	;IS TYPE DEFAULTED??

	MOVD	YPTR,VALTRS	;SET UP VALUE DEFAULT

TRAC5:	LOCAPV	YPTR,TRATL,YPTR,TRAC1

;                                  LOOK FOR TRACE TYPE

	GETDC	YPTR,YPTR,DESCR	;GET SUB PAIR LIST

TRACEP:	PROC	TRACE	;SUBENTRY FOR TRACE

	GETDC	TPTR,YPTR,DESCR	;GET DEFAULT FUNCTION

	DEQL	ZPTR,NULVCL,,TRAC2	;CHECK FOR NULL

	RCALL	TPTR,FINDEX,<ZPTR>	;LOCATE FUNCTION DESCRIPTOR

TRAC2:	SETAC	XSIZ,7*DESCR	;SET SIZE FOR PSEUDO-CODE

	SETVC	XSIZ,C	;INSERT CODE DATA TYPE

	RCALL	XCL,BLOCK,XSIZ	;ALLOCATE BLOCK FOR CODE

	MOVBLK	XCL,TRSKEL,XSIZ	;MOVE COPY

	SETVC	TPTR,2	;SET UP 2 ARGUMENTS

	PUTDC	XCL,1*DESCR,TPTR	;INSERT FUNCTION DESCRIPTOR

	PUTDC	XCL,3*DESCR,XPTR	;INSERT NAME TO BE TRACED

	PUTDC	XCL,5*DESCR,WPTR	;INSERT TAG

	GETDC	TPTR,YPTR,0	;MAKE ENTRY FOR PROPER ATTRIBUTE

	AEQLC	TPTR,0,,TRAC4

	LOCAPT	TPTR,TPTR,XPTR,TRAC3

;                                  LOCATE TRACE

	PUTDC	TPTR,2*DESCR,XCL	;INSERT NEW CODE BLOCK

	BRANCH	RETNUL	;RETURN

;_

TRAC3:	RCALL	TPTR,AUGATL,<TPTR,XPTR,XCL>

;                                  AUGMENT PAIR LIST FOR NEW ENTRY

TRAC6:	PUTDC	YPTR,0,TPTR	;LINK IN NEW PAIR LIST

	BRANCH	RETNUL	;RETURN

;_

TRAC1:	DEQL	YPTR,FUNTCL,INTR30	;IS TYPE FUNCTION?

	MOVD	YPTR,TFNCLP	;SET UP CALL TRACE

	RCALL	,TRACEP,,<INTR10,INTR10>

;                                  CALL SUBENTRY TO DO IT

	MOVD	YPTR,TFNRLP	;SET UP RETURN TRACE

	BRANCH	TRACEP	;BRANCH TO SUBENTRY TO DO IT

;_

TRAC4:	RCALL	TPTR,BLOCK,TWOCL	;ALLOCATE NEW PAIR LIST

	PUTDC	TPTR,DESCR,XPTR	;INSERT NAME TO BE TRACED

	PUTDC	TPTR,2*DESCR,XCL	;INSERT POINTER TO PSEUDO-CODE

	BRANCH	TRAC6

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      STOPTR(N,T)

;

STOPTR:	PROC	,	;STOPTR(T,R)

	RCALL	XPTR,IND,,FAIL	;GET NAME OF VARIABLE

	PUSH	XPTR	;SAVE NAME

	RCALL	YPTR,VARVAL,,FAIL	;GET TRACE RESPECT

	POP	XPTR

	DEQL	YPTR,NULVCL,STOPT2	;CHECK FOR DEFAULTED RESPECT

	MOVD	YPTR,VALTRS	;SET UP VALUE AS DEFAULT

STOPT2:	LOCAPV	YPTR,TRATL,YPTR,STOPT1

;                                  LOOK FOR TRACE RESPECT

	GETDC	YPTR,YPTR,DESCR	;GET POINTER TO TRACE LIST

STOPTP:	PROC	STOPTR	;SUBENTRY FOR FUNCTION

	GETDC	YPTR,YPTR,0	;GET TRACE LIST

	LOCAPT	YPTR,YPTR,XPTR,FAIL	;LOOK FOR TRACED VARIABLE

	PUTDC	YPTR,DESCR,ZEROCL	;ZERO THE ENTRY

	PUTDC	YPTR,2*DESCR,ZEROCL	;OVERWRITE TRACE

	BRANCH	RETNUL	;RETURN

;_

STOPT1:	DEQL	YPTR,FUNTCL,INTR30	;CHECK FOR FUNCTION

	MOVD	YPTR,TFNCLP	;SET UP CALL

	RCALL	,STOPTP,,<FAIL,INTR10>

;                                  CALL SUBPROCEDURE

	MOVD	YPTR,TFNRLP	;SET UP RETURN

	BRANCH	STOPTP	;BRANCH TO SUBENTRY

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      CALL TRACING

;

FENTR:	PROC	,	;PROCEDURE TO TRACE ON CALL

	RCALL	WPTR,VARVAL,,FAIL	;GET ARGUMENT

FENTR3:	SETLC	PROTSP,0	;CLEAR SPECIFIER

	APDSP	PROTSP,TRSTSP	;APPEND TRACE MESSAGE

	INTSPC	XSP,STNOCL	;CONVERT &STNO TO STRING

	APDSP	PROTSP,XSP	;APPEND &STNO

	APDSP	PROTSP,COLSP	;APPEND COLON

	APDSP	PROTSP,TRLVSP	;APPEND LEVEL MESSAGE

	INTSPC	XSP,LVLCL	;CONVERT &FNCLEVEL TO STRING

	APDSP	PROTSP,XSP	;APPEND &FNCLEVEL

	APDSP	PROTSP,TRCLSP	;APPEND CALL MESSAGE

	LOCSPX	XSP,WPTR	;GET SPECIFIER FOR ARGUMENT

	GETLG	TCL,XSP	;GET LENGTH

	ACOMPC	TCL,BUFLEN,FXOVR,FXOVR

;                                  CHECK FOR EXCESSIVELY LONG STRING

	APDSP	PROTSP,XSP	;APPEND FUNCTION NAME

	APDSP	PROTSP,LPRNSP	;APPEND LEFT PARENTHESIS

	SETAC	WCL,0	;SET ARGUMENT COUNT TO 0

FNTRLP:	INCRA	WCL,1	;INCREMENT ARGUMENT COUNT

	RCALL	ZPTR,ARGINT,<WPTR,WCL>,<FENTR4,INTR10>

;                                  GET ARGUMENT

	GETDC	ZPTR,ZPTR,DESCR	;GET VALUE

	VEQLC	ZPTR,S,,DEFTV	;IS IT STRING?

	VEQLC	ZPTR,I,,DEFTI	;IS IT INTEGER?

	RCALL	A2PTR,DTREP,ZPTR	;GET DATA TYPE REPRESENTATION

	GETSPC	XSP,A2PTR,0	;GET SPECIFIER

	GETLG	SCL,XSP	;GET LENGTH

	SUM	TCL,TCL,SCL	;TOTAL LENGTH

	ACOMPC	TCL,BUFLEN,FXOVR,FXOVR

;                                  CHECK FOR EXCESSIVELY LONG STRING

DEFTIA:	APDSP	PROTSP,XSP	;APPEND VALUE

	BRANCH	DEFDTT	;CONTINUE WITH NEXT ARGUMENT

;_

DEFTI:	INTSPC	XSP,ZPTR	;CONVERT INTEGER TO STRING

	BRANCH	DEFTIA	;REJOIN PROCESSING

;_

DEFTV:	LOCSPX	XSP,ZPTR	;GET SPECIFIER

	GETLG	SCL,XSP	;GET LENGTH

	SUM	TCL,TCL,SCL	;GET TOTAL LENGTH

	ACOMPC	TCL,BUFLEN,FXOVR,FXOVR

;                                  CHECK FOR EXCESSIVELY LONG STRING

	APDSP	PROTSP,QTSP	;APPEND QUOTE

	APDSP	PROTSP,XSP	;APPEND VALUE

	APDSP	PROTSP,QTSP	;APPEND QUOTE

DEFDTT:	APDSP	PROTSP,CMASP	;APPEND COMMA

	BRANCH	FNTRLP	;CONTINUE PROCESSING

;_

FENTR4:	AEQLC	WCL,1,,FENTR5	;LEAVE PAREN IF NO ARGUMENTS

	SHORTN	PROTSP,1	;DELETE LAST COMMA

FENTR5:	APDSP	PROTSP,RPRNSP	;APPEND RIGHT PARENTHESIS

	MSTIME	ZPTR	;GET TIME

	SUBTRT	ZPTR,ZPTR,ETMCL	;COMPUTE ELAPSED TIME

	INTSPC	XSP,ZPTR	;CONVERT TO STRING

	APDSP	PROTSP,ETIMSP	;APPEND TIME MESSAGE

	APDSP	PROTSP,XSP	;APPEND TIME

	STPRNT	IOKEY,OUTBLK,PROTSP	;PRINT TRACE MESSAGE

	BRANCH	RTNUL3	;RETURN

;_

FENTR2:	PROC	FENTR	;STANDARD ENTRY

	POP	WPTR	;RESTORE FUNCTION NAME

	BRANCH	FENTR3

;_

FXOVR:	OUTPUX	OUTPUT,PRTOVF	;PRINT ERROR MESSAGE

	BRANCH	RTNUL3	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      KEYWORD AND LABEL TRACING

;

KEYTR:	PROC	,	;PROCEDURE TO TRACE KEYWORDS

	SETAC	FNVLCL,1	;SET ENTRY INDICATOR

	RCALL	WPTR,VARVAL,,FAIL	;GET KEYWORD

	LOCSPX	XSP,WPTR	;GET SPECIFIER

	RCALL	YCL,KEYT,<WPTR>,<INTR10,>

;                                  GET VALUE OF KEYWORD

KEYTR3:	SETLC	PROTSP,0	;CLEAR SPECIFIER

	APDSP	PROTSP,TRSTSP	;APPEND TRACE MESSAGE

	INTSPC	TSP,STNOCL	;CONVERT &STNO TO STRING

	APDSP	PROTSP,TSP	;APPEND &STNO

	APDSP	PROTSP,COLSP	;APPEND COLON

	AEQLC	FNVLCL,0,,KEYTR4	;CHECK ENTRY INDICATOR

	APDSP	PROTSP,AMPSP	;APPEND AMPERSAND

KEYTR4:	APDSP	PROTSP,XSP	;APPEND NAME OF KEYWORD

	APDSP	PROTSP,BLSP	;APPEND BLANK

	AEQLC	FNVLCL,0,,KEYTR5	;CHECK ENTRY INDICATOR

	INTSPC	YSP,YCL	;CONVERT KEYWORD VALUE TO STRING

	APDSP	PROTSP,EQLSP	;APPEND EQUAL SIGN

KEYTR5:	APDSP	PROTSP,YSP	;APPEND VALUE

	MSTIME	YPTR	;GET TIME

	SUBTRT	YPTR,YPTR,ETMCL	;COMPUTE ELAPSED TIME

	INTSPC	XSP,YPTR	;CONVERT TIME TO STRING

	APDSP	PROTSP,ETIMSP	;APPEND TIME MESSAGE

	APDSP	PROTSP,XSP	;APPEND TIME

	STPRNT	IOKEY,OUTBLK,PROTSP	;PRINT TRACE MESSAGE

	BRANCH	RTN2	;RETURN

;_

LABTR:	PROC	KEYTR	;PROCEDURE TO TRACE LABELS

	SETAC	FNVLCL,0	;SET ENTRY INDICATOR

	RCALL	YPTR,VARVAL,,FAIL	;GET LABEL NAME

	LOCSPX	YSP,YPTR	;GET SPECIFIER

	SETSP	XSP,XFERSP	;SET UP MESSAGE SPECIFIER

	BRANCH	KEYTR3	;JOIN COMMON PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      TRACE HANDLER

;

TRPHND:	PROC	,	;TRACE HANDLING PROCEDURE

	POP	ATPTR	;RESTORE TRACE

	DECRA	TRAPCL,1	;DECREMENT &TRACE

	PUSH	<LSTNCL,STNOCL,FRTNCL,OCBSCL,OCICL,TRAPCL,TRACL>

;                                  SAVE SYSTEM DESCRIPTORS

	GETDC	OCBSCL,ATPTR,2*DESCR	;NEW CODE BASE

;                                  GET NEW CODE BASE

	SETAC	OCICL,DESCR	;SET UP OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET FUNCTION DESCRIPTOR

	SETAC	TRAPCL,0	;SET &TRACE TO 0

	SETAC	TRACL,0	;SET &FTRACE TO 0

;VERSION 3.4 CHANGE

	RCALL ,INVOKE,XPTR,<,>

;VERSION 3.4 CHANGE END

;                                  EVALUATE FUNCTION

	POP	<TRACL,TRAPCL,OCICL,OCBSCL,FRTNCL,STNOCL,LSTNCL>

;                                  RESTORE SYSTEM DESCRIPTORS

;VERSION 3.4 CHANGE

	BRANCH RTN1

;VERSION 3.4 CHANGE END

;_

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      VALUE TRACING

;

VALTR:	PROC	,	;TRACING PROCEDURES

	SETAC	FNVLCL,1	;NOTE ENTRY

VALTR2:	RCALL	XPTR,IND,,FAIL	;GET VARIABLE TO BE TRACED

	PUSH	XPTR	;SAVE NAME

	RCALL	ZPTR,VARVAL,,FAIL	;GET TAG

	POP	XPTR	;RESTORE VARIABLE

VALTR4:	SETLC	TRACSP,0	;CLEAR SPECIFIER

	APDSP	TRACSP,TRSTSP	;APPEND TRACE MESSAGE

	INTSPC	XSP,STNOCL	;CONVERT &STNO TO STRING

	APDSP	TRACSP,XSP	;APPEND &STNO

	APDSP	TRACSP,COLSP	;APPEND COLON

	AEQLC	FNVLCL,0,,FNEXT1	;CHECK ENTRY INDICATOR

	VEQLC	XPTR,S,DEFDT	;IS VARIABLE A STRING?

VALTR3:	LOCSPX	XSP,XPTR	;GET SPECIFIER

	GETLG	TCL,XSP	;GET LENGTH

	ACOMPC	TCL,BUFLEN,VXOVR,VXOVR

;                                  CHECK FOR EXCESSIVELY LONG NAME

VALTR1:	APDSP	TRACSP,XSP	;APPEND NAME OF VARIABLE

	APDSP	TRACSP,BLEQSP	;APPEND ' = '

	GETDC	YPTR,XPTR,DESCR	;GET VALUE OF TRACED VARIABLE

	VEQLC	YPTR,S,,TRV	;IS IT STRING?

	VEQLC	YPTR,I,,TRI	;IS IT INTEGER?

	RCALL	XPTR,DTREP,YPTR	;ELSE GET DATA TYPE REPRESENTATION

	GETSPC	XSP,XPTR,0	;GET SPECIFIER

TRI2:	APDSP	TRACSP,XSP	;APPEND VALUE

	BRANCH	TRPRT	;JOIN COMMON PROCESSING

;_

TRV:	LOCSPX	XSP,YPTR	;GET SPECIFIER

	GETLG	SCL,XSP	;GET LENGTH

	SUM	TCL,TCL,SCL	;COMPUTE TOTAL LENGTH

	ACOMPC	TCL,BUFLEN,VXOVR,VXOVR

;                                  CHECK FOR EXCESSIVELY LONG MESSAGE

	APDSP	TRACSP,QTSP	;APPEND QUOTE

	APDSP	TRACSP,XSP	;APPEND STRING

	APDSP	TRACSP,QTSP	;APPEND QUOTE

TRPRT:	MSTIME	YPTR	;GET TIME

	SUBTRT	YPTR,YPTR,ETMCL	;COMPUTE TIME IN INTERPRETER

	INTSPC	XSP,YPTR	;CONVERT TO STRING

	APDSP	TRACSP,ETIMSP	;APPEND TIME MESSAGE

	APDSP	TRACSP,XSP	;APPEND TIME

	STPRNT	IOKEY,OUTBLK,TRACSP	;PRINT TRACE MESSAGE

	BRANCH	RTNUL3	;RETURN

;_

TRI:	INTSPC	XSP,YPTR	;CONVERT INTEGER TO STRING

	BRANCH	TRI2	;JOIN PROCESSING

;_

DEFDT:	LOCSPX	XSP,ZPTR	;GET SPECIFIER FOR TAG

	BRANCH	VALTR1	;JOIN PROCESSING

;_

FNEXTR:	PROC	VALTR	;RETURN TRACING PROCEDURE

	SETAC	FNVLCL,0	;NOTE ENTRY

	BRANCH	VALTR2	;JOIN PROCESSING

;_

FNEXT1:	APDSP	TRACSP,TRLVSP	;APPEND LEVEL MESSAGE

	MOVD	XCL,LVLCL	;COPY &FNCLEVEL

	DECRA	XCL,1	;DECREMENT

	INTSPC	XSP,XCL	;CONVERT TO STRING

	APDSP	TRACSP,XSP	;APPEND FUNCTION LEVEL

	APDSP	TRACSP,BLSP	;APPEND BLANK

	LOCSPX	XSP,RETPCL	;GET SPECIFIER FOR RETURN

	APDSP	TRACSP,XSP	;APPEND RETURN TYPE

	APDSP	TRACSP,OFSP	;APPEND ' OF '

	DEQL	RETPCL,FRETCL,VALTR3

;                                  CHECK FOR FRETURN

	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR FUNCTION NAME

	GETLG	TCL,XSP	;GET LENGTH

	ACOMPC	TCL,BUFLEN,VXOVR,VXOVR

;                                  CHECK FOR EXCESSIVELY LONG STRING

	APDSP	TRACSP,XSP	;APPEND NAME OF FUNCTION

	BRANCH	TRPRT	;JOIN COMMON PROCESSING

;_                                 FTRACE CALL TRACE

FNEXT2:	PROC	VALTR	;NOTE ENTRY

	SETAC	FNVLCL,0	;RESTORE FUNCTION NAME

	POP	XPTR	;JOIN COMMON PROCESSING

	BRANCH	VALTR4

;_

VXOVR:	OUTPUX	OUTPUT,PRTOVF	;PRINT ERROR MESSAGE

	BRANCH	RTNUL3	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'OTHER OPERATIONS'

;

;      ASSIGNMENT

;

ASGN:	PROC	,	;X = Y

	INCRA	OCICL,DESCR	;INCREMENT OFFSET IN OBJECT CODE

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,ASGNC	;TEST FOR FUNCTION DESCRIPTOR

ASGNV:	VEQLC	XPTR,K,,ASGNIC	;CHECK FOR KEYWORD SUBJECT

	INCRA	OCICL,DESCR	;INCREMENT OFFSET IN OBJECT CODE

	GETD	YPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	YPTR,FNC,,ASGNCV	;TEST FOR FUNCTION DESCRIPTOR

ASGNVN:	AEQLC	INSW,0,,ASGNV1	;CHECK &INPUT

	LOCAPV	ZPTR,INATL,YPTR,ASGNV1

;                                  LOOK FOR INPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET INPUT ASSOCIATION DESCRIPTOR

	RCALL	YPTR,PUTIN,<ZPTR,YPTR>,<FAIL,ASGNVV>

;_

ASGNV1:	GETDC	YPTR,YPTR,DESCR	;GET VALUE

ASGNVV:	PUTDC	XPTR,DESCR,YPTR	;PERFORM ASSIGNMENT

	AEQLC	OUTSW,0,,ASGN1	;CHECK &OUTPUT

	LOCAPV	ZPTR,OUTATL,XPTR,ASGN1

;                                  LOOK FOR OUTPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET OUTPUT ASSOCIATION DESCRIPTOR

	RCALL	,PUTOUT,<ZPTR,YPTR>	;PERFORM OUTPUT

ASGN1:	ACOMPC	TRAPCL,0,,RTNUL3,RTNUL3

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TVALL,XPTR,RTNUL3

;                                  LOOK FOR VALUE TRACE

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR,RTNUL3

;VERSION 3.4 CHANGE END

;_

ASGNC:	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,ASGNV,NEMO>

;_

ASGNCV:	PUSH	XPTR	;SAVE SUBJECT OF ASSIGNMENT

	RCALL	YPTR,INVOKE,<YPTR>,<FAIL,ASGNVP>

ASGNCJ:	POP	XPTR	;RESTORE SUBJECT

	BRANCH	ASGNVV

;_

ASGNVP:	POP	XPTR	;RESTORE SUBJECT

	BRANCH	ASGNVN

;_

ASGNIC:	PUSH	XPTR	;SAVE SUBJECT OF ASSIGNMENT

	RCALL	YPTR,INTVAL,,<FAIL,ASGNCJ>

;                                  GET INTEGER VALUE FOR KEYWORD

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      X Y (CONCATENATION)

;

CON:	PROC	,	;X Y (CONCATENATION)

	RCALL	,XYARGS,,FAIL	;GET TWO ARGUMENTS

	DEQL	XPTR,NULVCL,,RTYPTR	;IF FIRST IS NULL, RETURN SECOND

	DEQL	YPTR,NULVCL,,RTXPTR	;IF SECOND IS NULL, RETURN FIRST

	VEQLC	XPTR,S,,CON5	;IS FIRST STRING?

	VEQLC	XPTR,P,,CON5	;IS FIRST PATTERN?

	VEQLC	XPTR,I,,CON4I	;IS FIRST INTEGER?

	VEQLC	XPTR,R,,CON4R	;IS FIRST REAL?

	VEQLC	XPTR,E,INTR1	;IS FIRST EXPRESSION?

	RCALL	TPTR,BLOCK,STARSZ	;ALLOCATE BLOCK FOR PATTERN

	MOVBLK	TPTR,STRPAT,STARSZ	;SET UP PATTERN FOR EXPRESSION

	PUTDC	TPTR,4*DESCR,XPTR	;INSERT POINTER TO EXPRESSION

	MOVD	XPTR,TPTR	;SET UP AS FIRST ARGUMENT

	BRANCH	CON5

;_

CON4R:	REALST	REALSP,XPTR	;CONVERT REAL TO STRING

	SETSP	XSP,REALSP	;SET UP SPECIFIER

	RCALL	XPTR,GENVAR,XSPPTR,CON5

;                                  GENERATE VARIABLE

;_

CON4I:	INTSPC	ZSP,XPTR	;CONVERT INTEGER TO STRING

	RCALL	XPTR,GENVAR,<ZSPPTR>

;                                  GENERATE VARIABLE

CON5:	VEQLC	YPTR,S,,CON7	;IS SECOND STRING?

	VEQLC	YPTR,P,,CON7	;IS SECOND PATTERN?

	VEQLC	YPTR,I,,CON5I	;IS SECOND INTEGER?

	VEQLC	YPTR,R,,CON5R	;IS SECOND REAL?

	VEQLC	YPTR,E,INTR1	;IS SECOND EXPRESSION?

	RCALL	TPTR,BLOCK,STARSZ	;ALLOCATE BLOCK FOR PATTERN

	MOVBLK	TPTR,STRPAT,STARSZ	;SET UP PATTERN FOR EXPRESSION

	PUTDC	TPTR,4*DESCR,YPTR	;INSERT POINTER TO EXPRESSION

	MOVD	YPTR,TPTR	;SET UP AS SECOND ARGUMENT

	BRANCH	CON7	;JOIN PROCESSING

;_

CON5R:	REALST	REALSP,YPTR	;CONVERT REAL TO STRING

	SETSP	YSP,REALSP	;SET UP SEPCIFIER

	RCALL	YPTR,GENVAR,YSPPTR,CON7

;                                  GENERATE VARIABLE

;_

CON5I:	INTSPC	ZSP,YPTR	;CONVERT INTEGER TO STRING

	RCALL	YPTR,GENVAR,<ZSPPTR>

;                                  GENERATE VARIABLE

CON7:	SETAV	DTCL,XPTR	;GET DATA TYPE OF FIRST

	MOVV	DTCL,YPTR	;GET DATA TYPE OF SECOND

	DEQL	DTCL,VVDTP,,CONVV	;CHECK FOR STRING-STRING

	DEQL	DTCL,VPDTP,,CONVP	;CHECK FOR STRING-PATTERN

	DEQL	DTCL,PVDTP,,CONPV	;CHECK FOR PATTERN-STRING

	DEQL	DTCL,PPDTP,INTR1,CONPP

;                                  CHECK FOR PATTERN-PATTERN

;_

CONVV:	LOCSPX	XSP,XPTR	;SPECIFIER FOR FIRST STRING

	LOCSPX	YSP,YPTR	;SPECIFIER FOR SECOND STRING

	GETLG	XCL,XSP	;LENGTH OF FIRST STRING

	GETLG	YCL,YSP	;LENGTH OF SECOND STRING

	SUM	XCL,XCL,YCL	;TOTAL LENGTH

	ACOMP	XCL,MLENCL,INTR8	;CHECK AGAINST &MAXLNGTH

	RCALL	ZPTR,CONVAR,<XCL>	;ALLOCATE SPACE FOR STRING

	LOCSPX	TSP,ZPTR	;GET SPECIFIER TO ALLOCATED SPACE

	SETLC	TSP,0	;CLEAR LENGTH

	APDSP	TSP,XSP	;MOVE IN FIRST STRING

	APDSP	TSP,YSP	;APPEND SECOND STRING

	BRANCH	GENVSZ	;GENERATE VARIABLE

;_

CONVP:	LOCSPX	TSP,XPTR	;SPECIFIER TO STRING

	GETLG	TMVAL,TSP	;GET LENGTH OF STRING

	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR PATTERN

	MAKNOD	XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR

;                                  CONSTRUCT PATTERN

CONPP:	GETSIZ	XSIZ,XPTR	;GET SIZE OF FIRST PATTERN

	GETSIZ	YSIZ,YPTR	;GET SIZE OF SECOND PATTERN

	SUM	TSIZ,XSIZ,YSIZ	;COMPUTE TOTAL SIZE REQUIRED

	SETVC	TSIZ,P	;INSERT PATTERN DATA TYPE

	RCALL	TPTR,BLOCK,TSIZ	;ALLOCATE BLOCK FOR NEW PATTERN

	MOVD	ZPTR,TPTR	;SAVE COPY TO RETURN

	LVALUE	TVAL,YPTR	;GET LEAST VALUE FOR SECOND PATTERN

	CPYPAT	TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ

;                                  COPY IN FIRST PATTERN

	CPYPAT	TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ

;                                  COPY IN SECOND PATTERN

	BRANCH	RTZPTR	;RETURN PATTERN AS VALUE

;_

CONPV:	LOCSPX	TSP,YPTR	;GET SPECIFIER TO STRING

	GETLG	TMVAL,TSP	;GET LENGTH OF STRING

	RCALL	TPTR,BLOCK,LNODSZ	;ALLOCATE BLOCK FOR PATTERN

	MAKNOD	YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR

;                                  CONSTRUCT PATTERN FOR STRING

	BRANCH	CONPP	;JOIN COMMON PROCESSING

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      INDIRECT REFERENCE

;

IND:	PROC	,	;$X

	RCALL	XPTR,ARGVAL,,FAIL	;GET ARGUMENT

	VEQLC	XPTR,S,,INDV	;STRING IS ACCEPTABLE

	VEQLC	XPTR,N,,RTXNAM	;NAME CAN BE RETURNED DIRECTLY

	VEQLC	XPTR,I,,GENVIX	;CONVERT INTEGER

	VEQLC	XPTR,K,INTR1,RTXNAM	;KEYWORD IS LIKE NAME

;_

INDV:	AEQLC	XPTR,0,RTXNAM,NONAME

;                                  BE SURE STRING IS NOT NULL

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      KEYWORDS

;

KEYWRD:	PROC	,	;&X

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	XPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	XPTR,FNC,,KEYC	;CHECK FOR FUNCTION

KEYN:	LOCAPV	XPTR,KNATL,XPTR,KEYV

;                                  LOOK UP X ON UNPROTECTED LIST

	SETVC	XPTR,K	;SET KEYWORD (NAME) DATA TYPE

	BRANCH	RTXNAM	;RETURN BY NAME

;_

KEYV:	LOCAPV	ATPTR,KVATL,XPTR,UNKNKW

;                                  LOOK UP X ON PROTECTED LIST

	GETDC	ZPTR,ATPTR,DESCR	;GET VALUE

	BRANCH	RTZPTR	;RETURN BY VALUE

;_

KEYC:	RCALL	XPTR,INVOKE,<XPTR>,<FAIL,KEYN,NEMO>

;                                  EVALUATE COMPUTED KEYWORD

;_

KEYT:	PROC	KEYWRD	;PROCEDURE TO GET KEYWORD FOR TRACE

	POP	XPTR	;RESTORE ARGUMENT

	BRANCH	KEYN

;_                                 JOIN COMMON PROCESSING

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;      LITERAL EVALUATION

;

;

LIT:	PROC	,	;'X'

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	ZPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	BRANCH	RTZPTR	;RETURN VALUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      UNARY NAME OPERATOR

;

NAME:	PROC	,	;.X

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	ZPTR,OCBSCL,OCICL	;GET OBJECT CODE DESCRIPTOR

	TESTF	ZPTR,FNC,RTZPTR	;TEST FOR FUNCTION

	RCALL	ZPTR,INVOKE,ZPTR,<FAIL,RTZPTR,NEMO>

;_

;

;

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      VALUE ASSIGNMENT IN PATTERN MATCHING

;

NMD:	PROC	,

	MOVD	TCL,NHEDCL

NMD1:	ACOMP	TCL,NAMICL,INTR13,RTN2

;                                  CHECK FOR END

	SUM	TPTR,NBSPTR,TCL	;COMPUTE ADDRESS

	GETSPC	TSP,TPTR,DESCR	;GET SPECIFIER

	GETDC	TVAL,TPTR,DESCR+SPEC

;                                  GET VARIABLE

	GETLG	XCL,TSP	;GET LENGTH

	ACOMP	XCL,MLENCL,INTR8	;CHECK &MAXLNGTH

	VEQLC	TVAL,E,,NAMEXN	;IS VARIABLE EXPRESSION?

NMD5:	VEQLC	TVAL,K,,NMDIC	;IS VARIABLE KEYWORD?

	RCALL	VVAL,GENVAR,<TSPPTR>

;                                  GENERATE STRING

NMD4:	PUTDC	TVAL,DESCR,VVAL	;ASSIGN VALUE

	AEQLC	OUTSW,0,,NMD3	;CHECK &OUTPUT

	LOCAPV	ZPTR,OUTATL,TVAL,NMD3

;                                  LOOK FOR OUTPUT ASSOCIATION

	GETDC	ZPTR,ZPTR,DESCR	;GET ASSOCIATION

	RCALL	,PUTOUT,<ZPTR,VVAL>	;PERFORM OUTPUT

NMD3:	ACOMPC	TRAPCL,0,,NMD2,NMD2	;CHECK &TRACE

	LOCAPT	ATPTR,TVALL,TVAL,NMD2

;                                  LOOK FOR VALUE TRACE

	PUSH	<TCL,NAMICL,NHEDCL>	;SAVE STATE

	MOVD	NHEDCL,NAMICL	;SET UP NEW NAME LIST

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE

	POP	<NHEDCL,NAMICL,TCL>	;RESTORE STATE

NMD2:	INCRA	TCL,DESCR+SPEC	;MOVE TO NEXT NAME

	BRANCH	NMD1	;CONTINUE

;_

NMDIC:	SPCINT	VVAL,TSP,INTR1,NMD4	;CONVERT TO INTEGER

;_

NAMEXN:	RCALL	TVAL,EXPEVL,TVAL,<NMD2,NMD5,NEMO>

;                                  EVALUATE EXPRESSION

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      UNEVALUATED EXPRESSION

;

STR:	PROC	,	;*X

	SUM	ZPTR,OCBSCL,OCICL	;COMPUTE POSITION IN CODE

	RCALL	,CODSKP,<ONECL>	;SKIP ONE NEST

	SETVC	ZPTR,E	;INSERT EXPRESSION DATA TYPE

	BRANCH	RTZPTR	;RETURN POINTER TO CODE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'OTHER PREDICATES'

;

;      DIFFER(X,Y)

;

DIFFER:	PROC	,	;DIFFER(X,Y)

	RCALL	,XYARGS,,FAIL	;EVALUATE ARGUMENTS

	DEQL	XPTR,YPTR,RETNUL,FAIL

;                                  COMPARE THEM

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      IDENT(X,Y)

;

IDENT:	PROC	,	;IDENT(X,Y)

	RCALL	,XYARGS,,FAIL	;EVALUATE ARGUMENTS

	DEQL	XPTR,YPTR,FAIL,RETNUL

;                                  COMPARE ARGUMENTS

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      LGT(X,Y)

;

LGT:	PROC	,	;LGT(X,Y)

	RCALL	XPTR,VARVAL,,FAIL	;EVALUATE FIRST ARGUMENT

	PUSH	XPTR	;SAVE FIRST ARGUMENT

	RCALL	YPTR,VARVAL,,FAIL	;EVALUATE SECOND ARGUMENT

	POP	XPTR	;RESTORE FIRST ARGUMENT

	AEQLC	XPTR,0,,FAIL	;NULL IS NOT GREATER THAN ANYTHING

	AEQLC	YPTR,0,,RETNUL	;SIMILARLY FOR SECOND ARGUMENT

	LOCSPX	XSP,XPTR	;GET SPECIFIER TO FIRST ARGUMENT

	LOCSPX	YSP,YPTR	;GET SPECIFIER TO SECOND ARGUMENT

	LEXCMP	XSP,YSP,RETNUL,FAIL,FAIL

;                                  COMPARE LEXICALLY

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      UNARY NEGATION OPERATOR

;

NEG:	PROC	,	;>X

	PUSH	<OCBSCL,OCICL>	;SAVE OBJECT CODE POSITION

	RCALL	,ARGVAL,,<,FAIL>	;FAIL ON SUCCESS

	POP	<OCICL,OCBSCL>	;RESTORE OBJECT CODE POSITION

	RCALL	,CODSKP,<ONECL>,RETNUL

;                                  SKIP ARGUMENT AND RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      UNARY INTERROGATION OPERATOR

;

QUES:	PROC	,	;?X

	RCALL	,ARGVAL,,<FAIL,RETNUL>

;                                  EVALUATE ARGUMENT

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'OTHER FUNCTIONS'

;

;      APPLY(F,A+,...A/)

;

APPLY:	PROC	,	;APPLY(F,A+,...,A/)

	SETAV	XCL,INCL	;GET COUNT OF ARGUMENTS

	DECRA	XCL,1	;DECREMENT TO SKIP FUNCTION NAME

;VERSION 3.4 CHANGE

	ACOMPC XCL,1,,,ARGNER

;VERSION 3.4 CHANGE END

	PUSH	XCL	;SAVE ARGUMENT COUNT

	RCALL	XPTR,VARVAL,,FAIL	;GET FUNCTION NAME

	POP	XCL	;RESTORE ARGUMENT COUNT

	LOCAPV	XPTR,FNCPL,XPTR,UNDF

;                                  LOCATE FUNCTION

	GETDC	INCL,XPTR,DESCR	;GET FUNCTION DESCRIPTOR

	SETVA	INCL,XCL	;INSERT ACTUAL NUMBER OF ARGUMENTS

	RCALL	ZPTR,INVOKE,<INCL>,<FAIL,,RTZPTR>

	MOVD	XPTR,ZPTR	;RETURN BY NAME

	BRANCH	RTXNAM

;_

;	THIS CODING IMPLEMENTS A NEW PRIMITIVE FUNCTION
;	CALLED 'ASCII' WHICH TAKES A NUMERIC ARGUMENT
;	AND CONSTRUCTS AN ASCII CHARACTER.
;	THIS CODING TO BE INSERTED ALPHABETTICALLY 
;	IN THE SOURCE CODE

;	FOR EXAMPLE,
;	CARRIAGE.RETURN = ASCII(15)
;	LINE.FEED = ASCII(12)
;	EOT = ASCII(4)
;	A = ASCII(72)

ASCII:	PROC	,	;ASCII(N)
	RCALL XPTR,INTVAL,,FAIL
	MOVE A0,BUFPNT	;STORE VALUE TEMPORARILY IN BUFIN
	MOVEM A0,ZSP+SPECO
	HRRZM A0,ZSP
	MOVE A1,XPTR	;GET THE CHARACTER
	MOVEI A3,0
	IDIVI A1,^O12
	ADD A3,A2
	IDIVI A1,^O12
	IMULI A2,^D8
	ADD A3,A2
	IDIVI A1,^O12
	IMULI A2,^D64
	ADD A3,A2
	IDPB A3,A0
	MOVEI A0,1	;GIVE IT A LENGTH OF 1
	MOVEM A0,ZSP+SPECL
	BRANCH GENVRZ	;GENERATE STORAGE FOR THIS NEW STRING
;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      ARG(F,N), FIELD(F,N), AND LOCAL(F,N)

;

ARG:	PROC	,	;ARG(F,N)

	PUSH	<ONECL,DEFCL>	;SAVE ARG INDICATORS

	BRANCH	ARG1	;JOIN MAIN PROCESSING

;_

ARGINT:	PROC	ARG	;PROCEDURE USED FOR CALL TRACING

	POP	<XPTR,XCL>	;RESTORE ARGUMENTS

	PUSH	<ONECL,DEFCL>	;SAVE INDICATORS

	BRANCH	ARG2	;JOIN PROCESSING

;_

LOCAL:	PROC	ARG	;LOCAL(F,N)

	PUSH	<ONECL,ZEROCL,DEFCL>

;                                  SAVE LOCAL INDICATORS

	BRANCH	ARG1	;JOIN MAIN PROCESSING

;_

FIELDS:	PROC	ARG	;FIELD(F,N)

	PUSH	<ZEROCL,ZEROCL,DATCL>

;                                  SAVE FIELD INDICATORS

ARG1:	RCALL	XPTR,VARVAL,,FAIL	;GET FUNCTION NAME

	PUSH	XPTR	;SAVE FUNCTION NAME

	RCALL	XCL,INTVAL,,FAIL	;GET NUMBER

	ACOMP	ZEROCL,XCL,FAIL,FAIL

;                                  VERIFY POSITIVE NUMBER

	POP	XPTR	;RESTORE FUNCTION NAME

ARG2:	LOCAPV	XPTR,FNCPL,XPTR,INTR30

;                                  LOOK FOR FUNCTION DESCRIPTOR

	GETDC	XPTR,XPTR,DESCR	;GET FUNCTION DESCRIPTOR

	GETDC	YCL,XPTR,0	;GET PROCEDURE DESCRIPTOR

	GETDC	XPTR,XPTR,DESCR	;GET DEFINITION BLOCK

	POP	<ZCL,ALCL>	;RESTORE INDICATORS

	AEQL	YCL,ZCL,INTR30	;CHECK PROCEDURE TYPE

	MULTC	XCL,XCL,DESCR	;CONVERT NUMBER TO ADDRESS UNITS

	INCRA	XCL,2*DESCR	;SKIP PROTOTYPE INFORMATION

	SETAV	YCL,YCL	;GET ARGUMENT COUNT

	MULTC	YCL,YCL,DESCR	;CONVERT TO ADDRESS UNITS

	AEQLC	ALCL,0,,ARG4	;CHECK FUNCION TYPE

	INCRA	YCL,2*DESCR	;INCREMENT FOR HEADING

	MOVD	ZCL,YCL	;GET WORKING COPY

	BRANCH	ARG5	;BRANCH TO CONTINUE PROCESSING

;_

ARG4:	GETSIZ	ZCL,XPTR	;GET SIZE OF BLOCK

	POP	ALCL	;RESTORE ENTRY INDICATOR

	AEQLC	ALCL,0,,ARG5	;CHECK ENTRY TYPE

	SUM	XCL,XCL,YCL	;SKIP FORMAL ARGUMENTS

ARG5:	ACOMP	XCL,ZCL,FAIL	;CHECK NUMBER IN BOUNDS

	GETD	ZPTR,XPTR,XCL	;GET THE DESIRED NAME

	BRANCH	RTZPTR	;RETURN NAME AS VALUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      CLEAR()

;

CLEAR:	PROC	,	;CLEAR()

	RCALL	,ARGVAL,,FAIL	;GET RID OF ARGUMENT

	SETAC	DMPPTR,OBLIST-DESCR	;INITIALIZE BIN POINTER

CLEAR1:	ACOMP	DMPPTR,OBEND,RETNUL	;CHECK FOR END

	INCRA	DMPPTR,DESCR	;UPDATE FOR NEXT BIN

	MOVD	YPTR,DMPPTR	;GET WORKING COPY

CLEAR2:	GETAC	YPTR,YPTR,LNKFLD	;GET NEXT VARIABLE

	AEQLC	YPTR,0,,CLEAR1	;CHECK FOR END OF CHAIN

	PUTDC	YPTR,DESCR,NULVCL	;ASSIGN NULL VALUE

	BRANCH	CLEAR2	;CONTINUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      COLLECT(N)

;

COLECT:	PROC	,	;COLLECT(N)

	RCALL	XPTR,INTVAL,,FAIL	;GET NUMBER OF ADDRESS UNITS REQUIRED

	ACOMPC	XPTR,0,,,LENERR	;VERIFY POSITIVE INTEGER

	RCALL	ZPTR,GC,<XPTR>,FAIL	;CALL FOR STORAGE REGENERATION

	SETVC	ZPTR,I	;SET INTEGER DATA TYPE

	BRANCH	RTZPTR	;RETURN AMOUNT COLLECTED

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      COPY(X)

;

COPY:	PROC	,	;COPY(X)

	RCALL	XPTR,ARGVAL,,FAIL	;GET OBJECT TO COPY

	VEQLC	XPTR,S,,INTR1	;STRING CANNOT BE COPIED

	VEQLC	XPTR,I,,INTR1	;INTEGER CANNOT BE COPIED

	VEQLC	XPTR,R,,INTR1	;REAL CANNOT BE COPIED

	VEQLC	XPTR,N,,INTR1	;NAME CANNOT BE COPIED

	VEQLC	XPTR,K,,INTR1	;KEYWORD (NAME) CANNOT BE COPIED

	VEQLC	XPTR,E,,INTR1	;EXPRESSION CANNOT BE COPIED

	VEQLC	XPTR,T,,INTR1	;TABLE CANNOT BE COPIED

	GETSIZ	XCL,XPTR	;GET SIZE OF OBJECT TO COPY

	MOVV	XCL,XPTR	;INSERT DATA TYPE

	RCALL	ZPTR,BLOCK,XCL	;ALLOCATE BLOCK FOR COPY

	MOVBLK	ZPTR,XPTR,XCL	;COPY CONTENTS

	BRANCH	RTZPTR	;RETURN THE COPY

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      CONVERT(X,T)

;

CNVRT:	PROC	,	;CONVERT(X,T)

	RCALL	ZPTR,ARGVAL,,FAIL	;GET OBJECT TO BE CONVERTED

	PUSH	ZPTR	;SAVE OBJECT

	RCALL	YPTR,VARVAL,,FAIL	;GET DATA TYPE TARGET

	POP	ZPTR	;RESTORE OBJECT

	LOCAPV	XPTR,DTATL,YPTR,INTR1

;                                  LOOK FOR DATA TYPE CODE

	GETDC	XPTR,XPTR,DESCR	;GET CODE

	SETAV	DTCL,ZPTR	;INSERT OBJECT DATA TYPE

	MOVV	DTCL,XPTR	;INSERT TARGET DATA TYPE

	DEQL	DTCL,IVDTP,,CNVIV	;CHECK FOR INTEGER-STRING

	DEQL	DTCL,VCDTP,,RECOMP	;CHECK FOR STRING-CODE

	DEQL	DTCL,VEDTP,,CONVE

	DEQL	DTCL,VRDTP,,CONVR	;CHECK FOR STRING-REAL

	DEQL	DTCL,RIDTP,,CONRI	;CHECK FOR REAL-INTEGER

	DEQL	DTCL,IRDTP,,CONIR	;CHECK FOR INTEGER-REAL

	DEQL	DTCL,VIDTP,,CNVVI	;CHECK FOR STRING-INTEGER

	DEQL	DTCL,ATDTP,,CNVAT	;CHECK FOR ARRAY-TABLE

	DEQL	DTCL,TADTP,,CNVTA	;CHECK FOR TABLE-ARRAY

;VERSION 3.3 CHANGE
	VEQL ZPTR,XPTR,,RTZPTR
	VEQLC XPTR,S,FAIL,CNVRTS
;VERSION 3.3 CHANGE END
;                                  CHECK FOR IDEM-CONVERSION

;_

RECOMP:	SETAC	SCL,1	;NOTE STRING-CODE CONVERSION

RECOMJ:	LOCSPX	TEXTSP,ZPTR	;SET UP GLOBAL SPECIFIER

;VERSION 3.3 CHANGE
RECOMT:	GETLG OCALIM,TEXTSP
	AEQLC OCALIM,0,,RECOMN
;VERSION 3.3 CHANGE END
	MULTC	OCALIM,OCALIM,DESCR	;CONVERT TO ADDRESS UNITS

	INCRA	OCALIM,6*DESCR	;LEAVE ROOM FOR SAFETY

	SETVC	OCALIM,C	;INSERT CODE DATA TYPE

	RCALL	CMBSCL,BLOCK,OCALIM	;ALLOCATE BLOCK FOR OBJECT CODE

	SUM	OCLIM,CMBSCL,OCALIM	;COMPUTE END

	DECRA	OCLIM,6*DESCR

	SETAC	CMOFCL,0	;ZERO OFFSET

	SETAC	ESAICL,0	;ZERO ERROR COUNT

	PUSH	CMBSCL	;SAVE BLOCK POINTER

	SELBRA	SCL,<,CONVEX>	;SELECT CORRECT PROCEDURE

RECOM1:	LEQLC	TEXTSP,0,,RECOM2	;IS STRING EXHAUSTED?

	RCALL	,CMPILE,,<RECOMF,,RECOM1>

;                                  COMPILE STATEMENT

RECOM2:	SETAC	SCL,3	;SET RETURN SWITCH

RECOMQ:	INCRA	CMOFCL,DESCR	;INCREMENT OFFSET

	PUTD	CMBSCL,CMOFCL,ENDCL	;INSERT END FUNCTION

	POP	ZPTR	;RESTORE POINTER TO CODE BLOCK

RECOMZ:	SUM	CMBSCL,CMBSCL,CMOFCL

;                                  COMPUTE USED PORTION OF BLOCK

	RCALL	,SPLIT,<CMBSCL>	;SPLIT OFF REMAINDER

	SETAC	OCLIM,0	;CLEAR LIMIT POINTER

	SETAC	LPTR,0	;CLEAR LABEL POINTER

	ZERBLK	COMREG,COMDCT	;ZERO COMPILER DESCRIPTORS

	SELBRA	SCL,<FAIL,INTR10,RTZPTR>

;                                  SELECT RETURN

;_

RECOMF:	SETAC	SCL,1	;SET FAILURE RETURN

	BRANCH	RECOMQ	;REJOIN PROCESSING

;_
;VERSION 3.3 ADDITION
RECOMN:	SETSP TEXTSP,BLSP
	BRANCH RECOMT
;_
;VERSION 3.3 ADDITION END

CODER:	PROC	CNVRT	;CODE(S)

	RCALL	ZPTR,VARVAL,,<FAIL,RECOMP>

;                                  GET ARGUMENT

;_

CONVE:	PROC	CNVRT	;CONVERT TO EXPRESSION

	SETAC	SCL,2	;SET SWITCH

	BRANCH	RECOMJ	;JOIN COMMON PROGRAM

;_

CONVEX:	RCALL	FORMND,EXPR,,FAIL	;COMPILE EXPRESSION

	LEQLC	TEXTSP,0,FAIL	;VERIFY COMPLETE COMPILATION

	RCALL	,TREPUB,FORMND	;PUBLISH CODE TREE

;VERSION 3.3 CHANGE
	MOVD ZPTR,CMBSCL
;VERSION 3.3 CHANGE END
	SETVC	ZPTR,E	;INSERT EXPRESSION DATA TYPE

	SETAC	SCL,3	;SET RETURN BRANCH

	BRANCH	RECOMZ	;JOIN COMMON PROGRAM

;_

CONVR:	LOCSPX	ZSP,ZPTR	;GET SPECIFIER

	SPCINT	ZPTR,ZSP,,CONIR	;TRY CONVERSION TO INTEGER FIRST

	SPREAL	ZPTR,ZSP,FAIL,RTZPTR

;                                  CONVERT TO REAL

;_

CONIR:	INTRL	ZPTR,ZPTR	;CONVERT INTEGER TO REAL

	BRANCH	RTZPTR	;RETURN VALUE

;_

CONRI:	RLINT	ZPTR,ZPTR,FAIL,RTZPTR

;                                  CONVERT REAL TO INTEGER

;_

CNVIV:	RCALL	ZPTR,GNVARI,ZPTR,RTZPTR

;                                  CONVERT INTEGER TO STRING

;_

CNVVI:	LOCSPX	ZSP,ZPTR	;GET SPECIFIER

	SPCINT	ZPTR,ZSP,,RTZPTR	;CONVERT STRING TO INTEGER

	SPREAL	ZPTR,ZSP,FAIL,CONRI	;TRY CONVERSION TO REAL

;_

CNVRTS:	RCALL	XPTR,DTREP,ZPTR	;GET DATA TYPE REPRESENTATION

	GETSPC	ZSP,XPTR,0	;GET SPECIFIER

	BRANCH	GENVRZ	;GO GENERATE VARIABLE

;_

;VERSION 3.3 CHANGE
CNVTA:	MOVD YPTR,ZPTR
	MOVD YCL,ZEROCL
CNVTA7:	GETSIZ XCL,YPTR
	MOVD WPTR,YPTR
	MOVD ZCL,XCL
;VERSION 3.3 CHANGE END
;VERSION 3.3 CHANGE
	DECRA XCL,3*DESCR
;VERSION 3.3 CHANGE END
CNVTA1:	GETD	WCL,WPTR,XCL	;GET ITEM VALUE

	DEQL	WCL,NULVCL,,CNVTA2	;CHECK FOR NULL VALUE

	INCRA	YCL,1	;OTHERWISE COUNT ITEM

;VERSION 3.3 CHANGE
CNVTA2:	AEQLC XCL,DESCR,,CNVTA6
;VERSION 3.3 CHANGE END
	DECRA	XCL,2*DESCR	;COUNT DOWN

	BRANCH	CNVTA1	;PROCESS NEXT ITEM

;_
;VERSION 3.3 ADDITION
CNVTA6:	GETD YPTR,YPTR,ZCL
	AEQLC YPTR,1,CNVTA7
;VERSION 3.3 ADDITION END

CNVTA4:	AEQLC	YCL,0,,FAIL	;FAIL ON EMPTY TABLE

;VERSION 3.3 ADDITION
	MOVD WPTR,ZPTR
;VERSION 3.3 ADDITION END
	MULTC	XCL,YCL,2*DESCR	;CONVERT COUNT TO ADDRESS UNITS

	INTSPC	YSP,YCL	;GET PROTOTYPE FOR SIZE

	SETLC	PROTSP,0	;CLEAR SPECIFIER

	APDSP	PROTSP,YSP	;APPEND LENGTH

	APDSP	PROTSP,CMASP	;APPEND COMMA

;VERSION 3.3 ADDITION
	MOVD WCL,ZEROCL
;VERSION 3.3 ADDITION END
	SETAC	WCL,2	;SET UP 2 FOR SECOND DIMENSION

	INTSPC	XSP,WCL	;CONVERT TO STRING

	APDSP	PROTSP,XSP	;APPEND 2

	SETSP	XSP,PROTSP	;MOVE SPECIFIER

	RCALL	ATPRCL,GENVAR,XSPPTR

;                                  GENERATE VARIABLE FOR PROTOTYPE

	MOVD	ZCL,XCL	;SAVE SIZE

	INCRA	XCL,4*DESCR	;INCREMENT FOR HEADING

	RCALL	ZPTR,BLOCK,XCL	;GET BLOCK FOR ARRAY

	SETVC	ZPTR,A	;INSERT ARRAY DATA TYPE

	SETVA	ATEXCL,YCL	;INSERT FIRST DIMENSION IN HEAD

	MOVBLK	ZPTR,ATRHD,FRDSCL	;COPY HEADING INFORMATION

	MOVD	YPTR,ZPTR	;SAVE COPY OF BLOCK POINTER

	MULTC	YCL,YCL,DESCR	;CONVERT ITEM COUNT TO ADDRESS UNITS

	INCRA	YPTR,5*DESCR	;SKIP HEADING

	SUM	TPTR,YPTR,YCL	;COMPUTE SECOND HALF POSITION

;VERSION 3.3 ADDITION
CNVTA8:	GETSIZ WCL,WPTR
	DECRA WCL,2*DESCR
	SUM WCL,WPTR,WCL
;VERSION 3.3 ADDITION END
;VERSION 3.3 CHANGE
CNVTA3:	GETDC TCL,WPTR,DESCR
	DEQL TCL,NULVCL,,CNVTA5
	PUTDC TPTR,0,TCL
;VERSION 3.3 CHANGE END
	MOVDIC	YPTR,0,WPTR,2*DESCR

;VERSION 3.3 CHANGE (DELETED TWO LINES)
	INCRA	YPTR,DESCR	;INCREMENT UPPER POINTER

	INCRA	TPTR,DESCR	;INCREMENT LOWER POINTER

CNVTA5:	INCRA	WPTR,2*DESCR

;VERSION 3.3 CHANGE
	AEQL WCL,WPTR,CNVTA3
	GETDC WPTR,WCL,2*DESCR
	AEQLC WPTR,1,CNVTA8,RTZPTR
;VERSION 3.3 CHANGE END
;_

CNVAT:	GETDC	XCL,ZPTR,2*DESCR	;GET ARRAY DIMENSIONALITY

	MOVD	YPTR,ZPTR	;SAVE COPY OF ARRAY POINTER

	AEQLC	XCL,2,FAIL	;VERIFY RECTANGULAR ARRAY

	GETDC	XCL,ZPTR,3*DESCR	;GET SECOND DIMENSION

	VEQLC	XCL,2,FAIL	;VERIFY EXTENT OF 2

	GETSIZ	XCL,ZPTR	;GET SIZE OF ARRAY BLOCK

;VERSION 3.3 CHANGE
	DECRA XCL,2*DESCR
;VERSION 3.3 CHANGE END
	RCALL	XPTR,BLOCK,XCL	;ALLOCATE BLOCK FOR PAIR LIST

;VERSION 3.3 CHANGE
	SETVC XPTR,T
	GETDC YCL,ZPTR,4*DESCR
	MOVD ZPTR,XPTR
	PUTD XPTR,XCL,ONECL
	DECRA XCL,DESCR
	MOVD TCL,EXTVAL
	INCRA TCL,2*DESCR
	PUTD XPTR,XCL,TCL
	SETAV YCL,YCL
	MULTC YCL,YCL,DESCR
	INCRA YPTR,5*DESCR
	SUM WPTR,YPTR,YCL
CNVAT2:	MOVDIC XPTR,DESCR,WPTR,0
	MOVDIC XPTR,2*DESCR,YPTR,0
	DECRA YCL,DESCR
	AEQLC YCL,0,,RTZPTR
;VERSION 3.3 CHANGE END
	INCRA	XPTR,2*DESCR	;INCREMENT PAIR LIST POINTER

	INCRA	WPTR,DESCR	;INCREMENT LOWER ARRAY POINTER

	INCRA	YPTR,DESCR	;INCREMENT UPPER ARRAY POINTER

	BRANCH	CNVAT2	;CONTINUE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DATE()

;

DATE:	PROC	,	;DATE()

	RCALL	,ARGVAL,,FAIL	;GET RID OF ARGUMENT

	DATE	ZSP	;GET THE DATE

	BRANCH	GENVRZ	;GO GENERATE THE VARIABLE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DATATYPE(X)

;

DT:	PROC	,	;DATATYPE(X)

	RCALL	A2PTR,ARGVAL,,FAIL	;GET OBJECT

	MOVV	DT1CL,A2PTR	;INSERT DATA TYPE

	LOCAPT	A3PTR,DTATL,DT1CL,DTEXTN

;                                  LOOK FOR DATA TYPE

	GETDC	A3PTR,A3PTR,2*DESCR	;GET DATA TYPE NAME

DTRTN:	RRTURN	A3PTR,3	;RETURN NAME

;_

DTEXTN:	MOVD	A3PTR,EXTPTR	;SET UP EXTERNAL DATA TYPE

	BRANCH	DTRTN	;RETURN

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DUMP(N)

;

DMP:	PROC	,	;DUMP(N)

	RCALL	XPTR,INTVAL,,FAIL	;EVALUATE ARGUMENT

	AEQLC	XPTR,0,,RETNUL	;NO DUMP IF ZERO

DUMP:	PROC	DMP	;END GAME DUMP PROCEDURE

	SETAC	WPTR,OBLIST-DESCR	;INITIALIZE BIN LIST POINTER

DMPB:	ACOMP	WPTR,OBEND,RETNUL	;CHECK FOR END

	INCRA	WPTR,DESCR	;INCREMENT POINTER

	MOVD	YPTR,WPTR	;SAVE WORKING COPY

DMPA:	GETAC	YPTR,YPTR,LNKFLD	;GET STRING STRUCTURE

	AEQLC	YPTR,0,,DMPB	;CHECK FOR END OF CHAIN

	GETDC	XPTR,YPTR,DESCR	;GET VALUE

	DEQL	XPTR,NULVCL,,DMPA	;SKIP NULL STRING VALUES

	SETLC	DMPSP,0	;CLEAR SPECIFIER

	LOCSPX	YSP,YPTR	;GET SPECIFIER FOR VARIABLE

	GETLG	YCL,YSP	;GET LENGTH

	ACOMPC	YCL,BUFLEN,DMPOVR,DMPOVR

;                                  CHECK FOR EXCESSIVE LENGTH

	APDSP	DMPSP,YSP	;APPEND VARIABLE

	APDSP	DMPSP,BLEQSP	;APPEND ' = '

	VEQLC	XPTR,S,,DMPV	;STRING IS ALRIGHT

	VEQLC	XPTR,I,,DMPI	;CONVERT INTEGER

	RCALL	A1PTR,DTREP,XPTR	;ELSE GET REPRESENTATION

	GETSPC	YSP,A1PTR,0	;GET SPECIFIER

DMPX:	GETLG	XCL,YSP	;GET LENGTH

	SUM	YCL,YCL,XCL	;GET TOTAL

	ACOMPC	YCL,BUFLEN,DMPOVR	;CHECK FOR EXCESSIVE LENGTH

	APDSP	DMPSP,YSP	;APPEND VALUE

	BRANCH	DMPRT	;GO PRINT IT

;_

DMPV:	LOCSPX	YSP,XPTR	;GET SPECIFIER

	GETLG	XCL,YSP	;GET LENGTH

	SUM	YCL,YCL,XCL	;TOTAL LENGTH

	ACOMPC	YCL,BUFLEN,DMPOVR	;CHECK FOR EXCESSIVE LENGTH

	APDSP	DMPSP,QTSP	;APPEND QUOTE

	APDSP	DMPSP,YSP	;APPEND VALUE

	APDSP	DMPSP,QTSP	;APPEND QUOTE

DMPRT:	STPRNT	IOKEY,OUTBLK,DMPSP	;PRINT LINE

	BRANCH	DMPA	;CONTINUE

;_

DMPI:	INTSPC	YSP,XPTR	;CONVERT INTEGER

	BRANCH	DMPX	;REJOIN PROCESSING

;_

DMPOVR:	OUTPUX	OUTPUT,PRTOVF	;PRINT ERROR MESSAGE

	BRANCH	DMPA	;CONTINUE

;_

DMK:	PROC	,	;PROCEDURE TO DUMP KEYWORDS

	OUTPUX	OUTPUT,PKEYF	;PRINT CAPTION

	GETSIZ	XCL,KNLIST	;GET SIZE OF PAIR LIST

DMPK1:	GETD	XPTR,KNLIST,XCL	;GET NAME OF KEYWORD

	DECRA	XCL,DESCR	;ADJUST OFFSET

	GETD	YPTR,KNLIST,XCL	;GET VALUE OF KEYWORD

	INTSPC	YSP,YPTR	;CONVERT INTEGER TO STRING

	LOCSPX	XSP,XPTR	;GET SPECIFIER

	SETLC	DMPSP,0	;CLEAR SPECIFIER

	APDSP	DMPSP,AMPSP	;APPEND AMPERSAND

	APDSP	DMPSP,XSP	;APPEND NAME

	APDSP	DMPSP,BLEQSP	;APPEND ' = '

	APDSP	DMPSP,YSP	;APPEND VALUE

	STPRNT	IOKEY,OUTBLK,DMPSP	;PRINT LINE

	DECRA	XCL,DESCR	;ADJUST OFFSET

	AEQLC	XCL,0,DMPK1,RTN1	;CHECK FOR END

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      DUPL(S,N)

;

DUPL:	PROC	,	;DUPL(S,N)

	RCALL	XPTR,VARVAL,,FAIL	;GET STRING TO DUPLICATE

	PUSH	XPTR	;SAVE STRING

	RCALL	YPTR,INTVAL,,FAIL	;GET DUPLICATION FACTOR

	POP	XPTR	;RESTORE STRING

	ACOMPC	YPTR,0,,RETNUL,FAIL	;RETURN NULL FOR 0 DUPLICATIONS

	LOCSPX	XSP,XPTR	;GET SPECIFIER

	GETLG	XCL,XSP	;GET LENGTH

	MULT	XCL,XCL,YPTR	;MULTIPLY BY FACTOR

	ACOMP	XCL,MLENCL,INTR8	;CHECK &MAXLNGTH

	RCALL	ZPTR,CONVAR,XCL	;ALLOCATE SPACE FOR STRING

	LOCSPX	TSP,ZPTR	;GET SPECIFIER

	SETLC	TSP,0	;ZERO LENGTH

DUPL1:	APDSP	TSP,XSP	;APPEND A COPY

	DECRA	YPTR,1	;COUNT DOWN

	AEQLC	YPTR,0,DUPL1,GENVSZ	;CHECK FOR END

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      OPSYN(F+,F(,N)

;

OPSYN:	PROC	,	;OPSYN(F,G,N)

	RCALL	XPTR,VARVAL,,FAIL	;GET OBJECT FUNCTION

	PUSH	XPTR	;SAVE OBJECT FUNCTION

	RCALL	YPTR,VARVAL,,FAIL	;GET IMAGE FUNCTION

	PUSH	YPTR	;SAVE IMAGE FUNCTION

	RCALL	ZPTR,INTVAL,,FAIL	;GET TYPE INDICATOR

	POP	<YPTR,XPTR>	;RESTORE IMAGE AND OBJECT FUNCTIONS

	AEQLC	XPTR,0,,NONAME	;OBJECT MAY NOT BE NULL

	AEQLC	ZPTR,1,,UNYOP	;CHECK FOR UNARY DEFINITION

	AEQLC	ZPTR,2,,BNYOP	;CHECK FOR BINARY DEFINITION

	AEQLC	ZPTR,0,INTR30	;CHECK FOR FUNCTION DEFINITION

	RCALL	XPTR,FINDEX,XPTR	;GET FUNCTION DESCRIPTOR FOR OBJECT

UNBF:	LOCAPV	YPTR,FNCPL,YPTR,RETNUL

;                                  LOOK FOR IMAGE FUNCTION

	GETDC	YPTR,YPTR,DESCR	;GET OBJECT FUNCTION DESCRIPTOR

OPPD:	MOVDIC	XPTR,0,YPTR,0	;MOVE PROCEDURE DESCRIPTOR PAIR

	MOVDIC	XPTR,DESCR,YPTR,DESCR

	BRANCH	RETNUL

;_

UNYOP:	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR IMAGE

	LEQLC	XSP,1,UNAF	;LENGTH MUST BE 1 FOR OPERATOR

	SETLC	PROTSP,0	;CLEAR WORKING SPECIFIER

	APDSP	PROTSP,XSP	;COPY IN ARGUMENT

	APDSP	PROTSP,LPRNSP	;APPEND BREAK CHARACTER

	STREAM	TSP,PROTSP,UNOPTB,UNAF,UNAF

	MOVD	XPTR,STYPE	;STYPE HAS FUNCTION DESCRIPTOR

UNCF:	LOCSPX	YSP,YPTR	;GET SPECIFIER FOR IMAGE

	LEQLC	YSP,1,UNBF	;LENGTH MUST BE 1 FOR OPERATOR

	SETLC	PROTSP,0	;CLEAR WORKING SPECIFIER

	APDSP	PROTSP,YSP	;COPY IN ARGUMENT

	APDSP	PROTSP,LPRNSP	;APPEND BREAK CHARACTER

	STREAM	TSP,PROTSP,UNOPTB,UNBF,UNBF

	MOVD	YPTR,STYPE	;STYPE HAS FUNCTION DESCRIPTOR

	BRANCH	OPPD	;JOIN TO COPY DESCRIPTORS

;_

UNAF:	RCALL	XPTR,FINDEX,XPTR	;FIND DEFINITION OF IMAGE

	BRANCH	UNCF	;JOIN SEARCH FOR OBJECT

;_

BNYOP:	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR IMAGE

	LCOMP	XSP,EQLSP,BNAF	;LENGTH MUST BE 2 OR LESS

	SETLC	PROTSP,0	;CLEAR WORKING SPECIFIER

	APDSP	PROTSP,XSP	;COPY IN IMAGE

	APDSP	PROTSP,BLSP	;APPEND BREAK CHARACTER

	STREAM	TSP,PROTSP,BIOPTB,BNAF,BNAF

	LEQLC	PROTSP,0,BNAF	;BE SURE STRING IS EXHAUSTED

	MOVD	XPTR,STYPE	;STYPE HAS FUNCTION DESCRIPTOR

BNCF:	LOCSPX	YSP,YPTR	;GET SPECIFIER FOR OBJECT

	LCOMP	YSP,EQLSP,BNBF	;LENGTH MUST BE 2 OR LESS

	SETLC	PROTSP,0	;CLEAR WORKING SPECIFIER

	APDSP	PROTSP,YSP	;COPY IN OBJECT

	APDSP	PROTSP,BLSP	;APPEND BREAK CHARACTER

	STREAM	TSP,PROTSP,BIOPTB,BNBF,BNBF

	LEQLC	PROTSP,0,BNBF	;BE SURE STRING IS EXHAUSTED

	MOVD	YPTR,STYPE	;STYPE HAS FUNCTION DESCRIPTOR

	BRANCH	OPPD	;JOIN TO COPY DESCRIPTORS

;_

BNAF:	LEXCMP	XSP,BLSP,,BNCN	;CHECK FOR CONCATENATION

	RCALL	XPTR,FINDEX,XPTR	;FIND DEFINITION OF IMAGE

	BRANCH	BNCF	;JOIN SEARCH FOR OBJECT

;_

BNCN:	MOVD	XPTR,CONCL	;CONCL REPRESENTS CONCATENATION

	BRANCH	BNCF	;JOIN SEARCH FOR OBJECT

;_

BNBF:	LEXCMP	YSP,BLSP,UNBF,,UNBF	;CHECK FOR CONCATENATION

	MOVD	YPTR,CONCL	;CONCL REPRESENTS CONCATENATION

	BRANCH	OPPD	;JOIN TO COPY DESCRIPTORS

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      REPLACE(S+,S(,S))

;

RPLACE:	PROC	,	;REPLACE(S+,S(,S))

	RCALL	XPTR,VARVAL,,FAIL	;GET FIRST ARGUMENT

	PUSH	XPTR	;SAVE FIRST ARGUMENT

	RCALL	YPTR,VARVAL,,FAIL	;GET SECOND ARGUMENT

	PUSH	YPTR	;SAVE SECOND ARGUMENT

	RCALL	ZPTR,VARVAL,,FAIL	;GET THIRD ARGUMENT

	POP	<YPTR,XPTR>	;RESTORE FIRST AND SECOND

	AEQLC	XPTR,0,,RTXPTR	;IGNORE REPLACEMENT ON NULL

	LOCSPX	YSP,YPTR	;GET SPECIFIER FOR SECOND

	LOCSPX	ZSP,ZPTR	;GET SPECIFIER FOR THIRD

	LCOMP	ZSP,YSP,FAIL,,FAIL	;VERIFY SAME LENGTHS

	AEQLC	YPTR,0,,FAIL	;IGNORE NULL REPLACEMENT

	LOCSPX	XSP,XPTR	;GET SPECIFIER FOR FIRST

	GETLG	XCL,XSP	;GET LENGTH

	RCALL	ZPTR,CONVAR,XCL	;ALLOCATE SPACE FOR RESULT

	LOCSPX	TSP,ZPTR	;GET SPECIFIER

	SETLC	TSP,0	;CLEAR SPECIFIER

	APDSP	TSP,XSP	;APPEND FIRST ARGUMENT

	RPLACE	TSP,YSP,ZSP	;PERFORM REPLACEMENT

	BRANCH	GENVSZ	;GOT GENERATE VARIABLE

;_

;""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

;	SAVE(S)

;

SAVE:	PROC	,

	RCALL XPTR,VARVAL,,FAIL	;GET THE ARGUMENT

	LOCSPX	XSP,XPTR	;GENERATE A SPECIFIER

	SAVEM XSP

	BRANCH RETNUL


;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      SIZE(S)

;

SIZE:	PROC	,	;SIZE(S)

	RCALL	XPTR,VARVAL,,FAIL	;GET ARGUMENT

	LOCSPX	XSP,XPTR	;GET SPECIFIER

	GETLG	ZPTR,XSP	;GET LENGTH

	SETVC	ZPTR,I	;INSERT INTEGER DATA TYPE

	BRANCH	RTZPTR	;RETURN LENGTH

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      TIME()

;

TIME:	PROC	,	;TIME()

	RCALL	,ARGVAL,,FAIL	;GET RID OF ARGUMENT

	MSTIME	ZPTR	;GET ELAPSED TIME

	SUBTRT	ZPTR,ZPTR,ETMCL	;COMPUTE TIME IN INTERPRETER

	SETVC	ZPTR,I	;INSERT INTEGER DATA TYPE

	BRANCH	RTZPTR	;RETURN TIME

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE 'MSTIME (PRIMITIVE FUNCTION)'

MSTIMF:	PROC	,
	RCALL ,ARGVAL,,FAIL
	TIMER ZPTR
	SETVC ZPTR,I
	BRANCH RTZPTR

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

;

;      TRIM(S)

;

TRIM:	PROC	,	;TRIM(S)

	RCALL	XPTR,VARVAL,,FAIL	;GET STRING

	LOCSPX	ZSP,XPTR	;GET SPECIFIER

	TRIMSP	ZSP,ZSP	;TRIM STRING

	BRANCH	GENVRZ	;GENERATE NEW VARIABLE

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'COMMON CODE'

DATA:	LHERE	,

RT1NUL:	RRTURN	NULVCL,1	;RETURN NULL STRING BY EXIT 1

;_

RTN1:	LHERE	,

FAIL:	RRTURN	,1	;RETURN BY EXIT 1

;_

RETNUL:	RRTURN	NULVCL,3	;RETURN NULL STRING BY EXIT 3

;_

RTN2:	RRTURN	,2	;RETURN BY EXIT 2

;_

RTN3:	LHERE	,

RTNUL3:	RRTURN	,3	;RETURN BY EXIT 3

;_

RTXNAM:	RRTURN	XPTR,2	;RETURN XPTR BY EXIT 2

;_

RTXPTR:	RRTURN	XPTR,3	;RETURN XPTR BY EXIT 3

;_

RTYPTR:	RRTURN	YPTR,3	;RETURN YPTR BY EXIT 3

;_

ARTN:	INCRA	ARTHCL,1	;INCREMENT COUNT OF ARITHMETIC

RTZPTR:	RRTURN	ZPTR,3	;RETURN ZPTR BY EXIT 3

;_

A5RTN:	RRTURN	A5PTR,1	;RETURN A5PTR BY EXIT 1

;_

TSALF:	BRANCH	SALF,SCNR	;BRANCH TO SALF IN SCANNER

;_

TSALT:	BRANCH	SALT,SCNR	;BRANCH TO SALT IN SCANNER

;_

TSCOK:	BRANCH	SCOK,SCNR	;BRANCH TO SCOK IN SCANNER

;_

GENVSZ:	RCALL	ZPTR,GNVARS,XCL,RTZPTR

;                                  GENERATE VARIABLE FROM STORAGE

;_

GENVRZ:	RCALL	ZPTR,GENVAR,ZSPPTR,RTZPTR

;                                  GENERATE VARIABLE

;_

GENVIX:	RCALL	XPTR,GNVARI,XPTR,RTXNAM

;                                  GENERATE VARIABLE FROM INTEGER

;_

	TITLE	'TERMINATION'

END:	OUTPUX	OUTPUT,NRMEND,<LVLCL>

;                                  END PROCEDURE

	OUTPUX	OUTPUT,LASTSF,<STNOCL>

;                                  PRINT STATUS

	BRANCH	FTLEN2	;JOIN TERMINATION PROCEDURE

;_

FTLEND:	SETAC	FATLCL,1	;ERROR TERMINATION

	OUTPUX	OUTPUT,FTLCF,<ERRTYP,STNOCL,LVLCL>

;                                  PRINT STATUS

	MULTC	YCL,ERRTYP,DESCR	;CONVERT ERROR TYPE TO ADDRESS UNITS

	GETD	YCL,MSGNO,YCL	;GET MESSAGE POINTER

	GETSPC	TSP,YCL,0	;GET MESSAGE SPECIFIER

	STPRNT	IOKEY,OUTBLK,TSP	;PRINT ERROR MESSAGE

FTLEN2:	ISTACK	,	;RESET SYSTEM STACK

	AEQLC	ETMCL,0,FTLEN4	;WAS COMPILER DONE?

	MSTIME	ETMCL	;TIME OUT COMPILER

	SUBTRT	TIMECL,ETMCL,TIMECL	;COMPUTE TIME IN COMPILER

	SETAC	ETMCL,0	;SET INTERPRETER TIME TO 0

	BRANCH	FTLEN1	;JOIN END GAME

;_

FTLEN4:	MSTIME	XCL	;TIME OUT INTERPRETER

	SUBTRT	ETMCL,XCL,ETMCL	;COMPUTE TIME IN INTERPRETER

FTLEN1:	AEQLC	DMPCL,0,,END1	;CHECK &DUMP

	AEQLC	NODPCL,0,DMPNO	;CHECK STORAGE CONDITION

	ORDVST	,	;ORDER STRING STRUCTURES

	OUTPUX	OUTPUT,STDMP	;PRINT DUMP TITLE

	OUTPUX	OUTPUT,NVARF	;PRINT SUBTITLE

	RCALL	,DUMP,,<INTR10,INTR10,DMPK>

;                                  DUMP NATURAL VARIABLES

;_

DMPNO:	OUTPUX	OUTPUT,INCGCF	;PRINT DISCLAIMER

	OUTPUX	OUTPUT,NODMPF	;PRINT REASON

	BRANCH	END1	;JOIN END GAME

;_

DMPK:	RCALL	,DMK	;DUMP KEYWORDS

END1:	OUTPUX	OUTPUT,STATHD	;PRINT STATISTICS TITLE

	OUTPUX	OUTPUT,CMTIME,<TIMECL>

;                                  PRINT COMPILATION TIME

	OUTPUX	OUTPUT,INTIME,<ETMCL>

;                                  PRINT INTERPRETATION TIME

	OUTPUX	OUTPUT,EXNO,<EXNOCL,FALCL>

;                                  PRINT EXECUTION STATS

	OUTPUX	OUTPUT,ARTHNO,<ARTHCL>

;                                  PRINT ARITHMETIC STATS

	OUTPUX	OUTPUT,SCANNO,<SCNCL>

;                                  PRINT SCANNER STATS

	OUTPUX	OUTPUT,STGENO,<GCNO>

;                                  PRINT REGENERATION STATS

	OUTPUX	OUTPUT,READNO,<RSTAT>

;                                  PRINT READ STATS

	OUTPUX	OUTPUT,WRITNO,<WSTAT>

;                                  PRINT WRITE STATS

	AEQLC	EXNOCL,0,END2	;CHECK FOR NO INTERPRETATION

	INTRL	FCL,ZEROCL

	BRANCH	AVTIME	;JOIN END GAME

;_

END2:	INTRL	EXNOCL,EXNOCL	;CONVERT EXECUTION TOTAL TO REAL

	INTRL	XCL,ETMCL	;CONVERT EXECUTION TIME TO REAL

	DVREAL	FCL,XCL,EXNOCL	;COMPUTE AVERAGE TIME

AVTIME:

;	THIS CODE PRINTS THE CORE USAGE STATISTICES AS 
;	PART OF THE TERMINATION PRINTOUT

;	IT IS MEANT TO BE INSERTED RIGHT AFTER 'AVTIME'

	JRST COREPR
VARFOR:	FORMAT <(1H0,I15,' STRING LOOKUPS')>
COREF:	FORMAT <(1H0,I15,' K CORE USED,'I8,' FREE WORDS LEFT')>
COREPR:	SUBTRT TLSGP1,TLSGP1,FRSGPT
	MOVE A0,JOBREL
	IDIVI A0,^O1777	;CONVERT TO K
IFN REENTR,<
	EXTERN JOBHRL
	HLRZ A1,JOBHRL
	IDIVI A1,^O1777
	ADD A0,A1	;ACCOUNT FOR BOTH HIGH AND LOW SEGS
>
	MOVEM A0,HDSGPT
	OUTPUX OUTPUT,COREF,<HDSGPT,TLSGP1>

	EXTERN STRREF,VARPRT
; VARPRT MUST BE NON-ZERO TO PRINT THE STRING REFERENCE COUNT

	SKIPN VARPRT
	JRST NOVARP
	OUTPUX OUTPUT,VARFOR,STRREF
NOVARP:

	OUTPUX OUTPUT,TIMEPS,<FCL> ;PRINT AVERAGE TIME
;VERSION 3.3 CHANGE
ENDALL:	ENDEX ABNDCL
;VERSION 3.3 CHANGE END
;_

SYSCUT:	OUTPUX	OUTPUT,SYSCMT,<STNOCL,LVLCL>

;                                  SYSTEM CUT EXIT
;VERSION 3.3 ADDITION
	AEQLC CUTNO,0,ENDALL
	SETAC CUTNO,1
;VERSION 3.3 ADDITION END

	BRANCH	FTLEN2	;JOIN END GAME

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	TITLE	'ERROR HANDLING'

AERROR:	SETAC	ERRTYP,2	;ARITHMETIC ERROR

	BRANCH	FTLTST

;_

ALOC2:	SETAC	ERRTYP,20	;STORAGE EXHAUSTED

	BRANCH	FTLEND

;_

ARGNER:	SETAC	ERRTYP,25	;INCORRECT NUMBER OF ARGUMENTS

	BRANCH	FTLEND

;_

INTR10:	LHERE	,

INTR13:	LHERE	,

COMP3:	SETAC	ERRTYP,17	;PROGRAM ERROR

	BRANCH	FTLEND

;_

COMP5:	SETAC	ERRTYP,11	;READING ERROR

	BRANCH	FTLTST

;_

COMP7:	SETAC	ERRTYP,27	;ERRONEOUS END STATEMENT

	BRANCH	FTLEND

;_

COMP9:	SETAC	ERRTYP,26	;COMPILATION ERROR LIMIT

	DECRA	ESAICL,DESCR	;DECREMENT ERROR COUNT

	BRANCH	FTLEND

;_

EROR:	SETAC	ERRTYP,28	;ERRONEOUS STATEMENT

	INCRA	OCICL,DESCR	;INCREMENT OFFSET

	GETD	STNOCL,OCBSCL,OCICL	;GET STATEMENT NUMBER

	BRANCH	FTLEND

;_

EXEX:	SETAC	ERRTYP,22	;EXCEEDED &STLIMIT

	BRANCH	FTLEND

;_

INTR1:	SETAC	ERRTYP,1	;ILLEGAL DATA TYPE

	BRANCH	FTLTST

;_

INTR4:	SETAC	ERRTYP,24	;ERRONEOUS GOTO

	BRANCH	FTLEND

;_

INTR5:	SETAC	ERRTYP,19	;FAILURE IN GOTO

	BRANCH	FTLEND

;_

INTR8:	SETAC	ERRTYP,15	;EXCEEDED &MAXLNGTH

	BRANCH	FTLTST

;_

INTR27:	SETAC	ERRTYP,13	;EXCESSIVE DATA TYPES

	BRANCH	FTLTST

;_

INTR30:	SETAC	ERRTYP,10	;ILLEGAL ARGUMENT

	BRANCH	FTLTST

;_

INTR31:	SETAC	ERRTYP,16	;OVERFLOW IN PATTERN MATCHING

	SETAC	SCERCL,3

	BRANCH	FTERST

;_

LENERR:	SETAC	ERRTYP,14	;NEGATIVE NUMBER

	BRANCH	FTLTST

;_

MAIN1:	SETAC	ERRTYP,18	;RETURN FROM LEVEL ZERO

	BRANCH	FTLEND

;_

NEMO:	SETAC	ERRTYP,8	;VARIABLE NOT PRESENT

	BRANCH	FTLTST

;_

NONAME:	SETAC	ERRTYP,4	;NULL STRING

	BRANCH	FTLTST

;_

NONARY:	SETAC	ERRTYP,3	;ERRONEOUS ARRAY OR TABLE REFERENCE

	BRANCH	FTLTST

;_

OVER:	SETAC	ERRTYP,21	;STACK OVERFLOW

	BRANCH	FTLEND

;_

PROTER:	SETAC	ERRTYP,6	;ERRONEOUS PROTOTYPE

	BRANCH	FTLTST

;_

SCDTER:	SETAC	ERRTYP,1	;ILLEGAL DATA TYPE

	BRANCH	SCERST

;_

SCLENR:	SETAC	ERRTYP,14	;NEGATIVE NUMBER

	BRANCH	SCERST

;_

SCLNOR:	SETAC	ERRTYP,15	;STRING OVERFLOW

	BRANCH	SCERST

;_

SCNAME:	SETAC	ERRTYP,4	;NULL STRING

	BRANCH	SCERST

;_

SIZERR:	SETAC	ERRTYP,23	;OBJECT TOO LARGE

	BRANCH	FTLEND

;_

UNDF:	SETAC	ERRTYP,5	;UNDEFINED FUNCTION

	BRANCH	FTLTST

;_

UNDFFE:	SETAC	ERRTYP,9	;FUNCTION ENTRY POINT NOT LABEL

	BRANCH	FTLTST

;_

UNKNKW:	SETAC	ERRTYP,7	;UNKNOWN KEYWORD

	BRANCH	FTLTST

;_

UNTERR:	SETAC	ERRTYP,12	;ILLEGAL I/O UNIT

	BRANCH	FTLTST

;_

SCERST:	SETAC	SCERCL,1	;NOTE FAILURE DURING PATTERN MATCHING

	BRANCH	FTERST

IOBERR:	SETAC ERRTYP,29	;IO BUFFER SPACE MUST BE INCREASED

	BRANCH FTLEND

	INTERN CORERR
CORERR:	SETAC ERRTYP,30	;NOT ENOUGH STARTING CORE

	BRANCH FTLEND

	INTERN EOFERR

EOFERR:	SETAC ERRTYP,31	;READ BEYOND END OF FILE

	BRANCH FTLTST

	INTERN OPRERR

OPRERR:	SETAC ERRTYP,32	;SNOBOL OPERATING SYSTEM DETECTED ERROR

	BRANCH FTLTST

;_

FTLTST:	SETAC	SCERCL,2	;NOTE FAILURE OUTSIDE PATTERN MATCHIN

FTERST:	ACOMPC	ERRLCL,0,,FTLEND,FTLEND

;                                  CHECK &ERRLIMIT

	DECRA	ERRLCL,1	;DECREMENT &ERRLIMIT

	ACOMPC	TRAPCL,0,,FTERBR,FTERBR

;                                  CHECK &TRACE

	LOCAPT	ATPTR,TKEYL,ERRTKY,FTERBR

;                                  LOOK FOR KEYWORD TRACE
;VERSION 3.3 ADDITION
	PUSH SCERCL
;VERSION 3.3 ADDITION END

;VERSION 3.4 CHANGE

	RCALL ,TRPHND,ATPTR

;VERSION 3.4 CHANGE END

;                                  PERFORM TRACE
;VERSION 3.3 ADDITION
	POP SCERCL
;VERSION 3.3 ADDITION CHANGE END

FTERBR:	SELBRA	SCERCL,<TSALF,FAIL,RTNUL3>

;_

;"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""*

	LOW

;******************************************************************
	TITLE	'DATA'

DTLIST:	DESCX	DTLIST,TTL+MARK,DTLEND-DTLIST-DESCR

	DESCX	0,0,S

	DESCX	VARSP,0,0	;STRING

	DESCX	0,0,I

	DESCX	INTGSP,0,0	;INTEGER

	DESCX	0,0,P

	DESCX	PATSP,0,0	;PATTERN

	DESCX	0,0,A

	DESCX	ARRSP,0,0	;ARRAY

	DESCX	0,0,R

	DESCX	RLSP,0,0	;REAL

	DESCX	0,0,C

	DESCX	CODESP,0,0	;CODE

	DESCX	0,0,N

	DESCX	NAMESP,0,0	;NAME

	DESCX	0,0,K

	DESCX	NAMESP,0,0	;NAME (FOR KEYWORD)

	DESCX	0,0,E

	DESCX	EXPSP,0,0	;EXPRESSION

	DESCX	0,0,T

	DESCX	ASSCSP,0,0	;TABLE

DTLEND:	LHERE	,

;

KNLIST:	DESCX	KNLIST,TTL+MARK,KNEND-KNLIST-DESCR

TRIMCL:	DESCX	0,0,I	;&TRIM

	DESCX	TRMSP,0,0

TRAPCL:	DESCX	0,0,I	;&TRACE

	DESCX	TRCESP,0,0

EXLMCL:	DESCX	50000,0,I	;&STLIMIT

	DESCX	STLMSP,0,0

SAVECL:	DESCX 0,0,I

	DESCX SAVESP,0,0

OUTSW:	DESCX	1,0,I	;&OUTPUT

	DESCX	OUTSP,0,0

MLENCL:	DESCX	5000,0,I	;&MAXLNGTH

	DESCX	MAXLSP,0,0

INSW:	DESCX	1,0,I	;&INPUT

	DESCX	INSP,0,0

FULLCL:	DESCX	0,0,I	;&FULLSCAN

	DESCX	FULLSP,0,0

TRACL:	DESCX	0,0,I	;&FTRACE

	DESCX	FTRCSP,0,0

ERRLCL:	DESCX	0,0,I	;&ERRLIMIT

	DESCX	ERRLSP,0,0

DMPCL:	DESCX	0,0,I	;&DUMP

	DESCX	DUMPSP,0,0

RETCOD:	DESCX	0,0,I	;&CODE

	DESCX	CODESP,0,0

ANCCL:	DESCX	0,0,I	;&ANCHOR

	DESCX	ANCHSP,0,0

ABNDCL:	DESCX	0,0,I	;&ABEND

	DESCX	ABNDSP,0,0

KNEND:	LHERE	,

;

KVLIST:	DESCX	KVLIST,TTL+MARK,KVEND-KVLIST-DESCR

ERRTYP:	DESCX	0,0,I	;&ERRTYPE

ERRTKY:	DESCX	ERRTSP,0,0

ARBPAT:	DESCX	ARBPT,0,P	;&ARB

ARBKY:	DESCX	ARBSP,0,0

BALPAT:	DESCX	BALPT,0,P	;&BAL

BALKY:	DESCX	BALSP,0,0

FNCPAT:	DESCX	FNCEPT,0,P	;&FENCE

FNCEKY:	DESCX	FNCESP,0,0

ABOPAT:	DESCX	ABORPT,0,P	;&ABORT

ABRTKY:	DESCX	ABORSP,0,0

FALPAT:	DESCX	FAILPT,0,P	;&FAIL

FAILKY:	DESCX	FAILSP,0,0

REMPAT:	DESCX	REMPT,0,P	;&REM

REMKY:	DESCX	REMSP,0,0

SUCPAT:	DESCX	SUCCPT,0,P	;&SUCCEED

SUCCKY:	DESCX	SUCCSP,0,0

FALCL:	DESCX	0,0,I	;&STFCOUNT

FALKY:	DESCX	STFCSP,0,0

LSTNCL:	DESCX	0,0,I	;&LASTNO

	DESCX	LSTNSP,0,0

RETPCL:	DESCX	0,0,S	;&RTNTYPE

	DESCX	RTYPSP,0,0

STNOCL:	DESCX	0,0,I	;&STNO

	DESCX	STNOSP,0,0

ALPHVL:	DESCX	0,0,0	;&ALPHABET

	DESCX	ALNMSP,0,0

EXNOCL:	DESCX	0,0,I	;&STCOUNT

STCTKY:	DESCX	STCTSP,0,0

LVLCL:	DESCX	0,0,I	;&FNCLEVEL

FNCLKY:	DESCX	FNCLSP,0,0

KVEND:	LHERE	,

;

INLIST:	DESCX	INLIST,TTL+MARK,2*DESCR

	DESCX	INPUT-DESCR,0,0	;INPUT BLOCK

	DESCX	INSP,0,0

OTLIST:	DESCX	OTLIST,TTL+MARK,4*DESCR

	DESCX	OUTPUT-DESCR,0,0	;OUTPUT BLOCK

	DESCX	OUTSP,0,0

	DESCX	PUNCH-DESCR	;PUNCH BLOCK

	DESCX	PNCHSP,0,0

OTSATL:	DESCX	OTSATL,TTL+MARK,4*DESCR

OUTPUT:	DESCX	UNITO,0,I	;OUTPUT UNIT

	DESCX	OUTPSP,0,0	;OUTPUT FORMAT

PUNCH:	DESCX	UNITP,0,I	;PUNCH UNIT

PCHFST:	DESCX	CRDFSP,0,0	;PUNCH FORMAT

INSATL:	DESCX	INSATL,TTL+MARK,2*DESCR

INPUT:	DESCX	UNITI,0,I	;INPUT UNIT

DFLSIZ:	DESCX	80,0,I	;INPUT LENGTH

;

TRLIST:	DESCX	TRLIST,TTL+MARK,10*DESCR

	DESCX	TVALL,0,0	;VALUE TRACE

VALTRS:	DESCX	VALSP,0,0

	DESCX	TLABL,0,0	;LABEL TRACE

	DESCX	TRLASP,0,0

TFNCLP:	DESCX	TFENTL,0,0	;CALL TRACE

	DESCX	TRFRSP,0,0

TFNRLP:	DESCX	TFEXTL,0,0	;RETURN TRACE

	DESCX	RETSP,0,0

	DESCX	TKEYL,0,0	;KEYWORD TRACE

	DESCX	TRKYSP,0,0

;

ATRHD:	DESCX	ATPRCL-DESCR,0,0	;ARRAY HEADER CONVERTING FROM TABLE

ATPRCL:	DESCX	0,0,0	;PROTOTYPE

	DESCX	2,0,0	;DIMENSIONALITY

	DESCX	1,0,2	;1 2 SECOND DIMENSION

ATEXCL:	DESCX	1,0,0	;1 N FIRST DIMENSION

;

;      DATA TYPE PAIRS

;

ATDTP:	DESCX	A,0,T	;ARRAY-TABLE

IIDTP:	DESCX	I,0,I	;INTEGER-INTEGER

IPDTP:	DESCX	I,0,P	;INTEGER-PATTERN

IRDTP:	DESCX	I,0,R	;INTEGER-REAL

IVDTP:	DESCX	I,0,S	;INTEGER-STRING

PIDTP:	DESCX	P,0,I	;PATTERN-INTEGER

PPDTP:	DESCX	P,0,P	;PATTERN-PATTERN

PVDTP:	DESCX	P,0,S	;PATTERN-STRING

RIDTP:	DESCX	R,0,I	;REAL-INTEGER

RPDTP:	DESCX	R,0,P	;REAL-PATTERN

RRDTP:	DESCX	R,0,R	;REAL-REAL

RVDTP:	DESCX	R,0,S	;REAL-STRING

TADTP:	DESCX	T,0,A	;TABLE-ARRAY

VCDTP:	DESCX	S,0,C	;STRING-CODE

VEDTP:	DESCX	S,0,E	;STRING-EXPRESSION

VIDTP:	DESCX	S,0,I	;STRING-INTEGER

VPDTP:	DESCX	S,0,P	;STRING-PATTERN

VRDTP:	DESCX	S,0,R	;STRING-REAL

VVDTP:	DESCX	S,0,S	;STRING-STRING

;

ARTHCL:	DESCX	0,0,0	;NUMBER OF ARITHMETIC OPERATIONS

CSTNCL:	DESCX	0,0,I	;COMPILER STATEMENT NUMBER

RSTAT:	DESCX	0,0,0	;NUMBER OF READS

SCNCL:	DESCX	0,0,0	;NUMBER OF SCANNER ENTRANCES

WSTAT:	DESCX	0,0,0	;NUMBER OF WRITES

TIMECL:	DESCX	0,0,0	;MILLISECOND TIME

;

;      SWITCHES

;

ALCL:	DESCX	0,0,0	;ENTRY POINT SWITCH FOR ARG(F,N)

ARRMRK:	DESCX	0,0,0	;PROTOTYPE END SWITCH FOR ARRAY(P,V)

;VERSION 3.3 ADDITION
CUTNO:	DESCX 0,0,0
;VERSION 3.3 ADDITION END
CNSLCL:	DESCX	0,0,0	;LABEL REDEFINITION SWITCH

DATACL:	DESCX	0,0,0	;PROTOTYPE END SWITCH FOR DATA(P)

FNVLCL:	DESCX	0,0,0	;FUNCTION-VALUE SWITCH FOR TRACE

LENFCL:	DESCX	0,0,0	;LENGTH FAILURE SWITCH

LISTCL:	DESCX	1,0,0	;COMPILER LISTING SWITCH

LLIST:	DESCX	0,0,0	;LEFT LISTING SWITCH

NAMGCL:	DESCX	0,0,0	;NAMING SWITCH FOR SJSR

SCERCL:	DESCX	0,0,0	;ERROR BRANCH SWITCH

;

;      CONSTANTS

;

ARBSIZ:	DESCX	8*NODESZ,0,0	;NODE SIZE FOR ARBNO(P)

CHARCL:	DESCX	1,0,0	;LENGTH CONSTANT 1

CNDSIZ:	DESCX	CNODSZ,0,B	;COMPILER NODE SIZE

CODELT:	DESCX	200*DESCR,0,C	;OBJECT CODE EXCESS

DSCRTW:	DESCX	2*DESCR,0,0	;CONSTANT 2*DESCR

EOSCL:	DESCX	EOSTYP,0,0	;END OF STATEMENT SWITCH

ESALIM:	DESCX	ESASIZ*DESCR,0,0	;BOUND ON COMPILATION ERRORS

EXTVAL:	DESCX	EXTSIZ*2*DESCR,0,I	;DEFAULT M FOR TABLE(N,M)

FBLKRQ:	DESCX	FBLKSZ,0,B	;QUANTUM ON ALLOCATED FUNCTION BLOCKS

GOBRCL:	DESCX	0,0,0	;GOTO BREAK CHARACTER SWITCH

GTOCL:	DESCX	FGOTYP,0,0	;GOTO DECISION SWITCH

IOBLSZ:	DESCX	2*DESCR,0,B	;SIZE OF I/O BLOCKS

LNODSZ:	DESCX	NODESZ+DESCR,0,P	;SIZE OF LONG PATTERN NODE

NODSIZ:	DESCX	NODESZ,0,P	;SIZE OF SHORT PATTERN NODE

OBEND:	DESCX	OBLIST+DESCR*OBOFF,0,0

;                                  END ON BIN LIST

OCALIM:	DESCX	OCASIZ*DESCR,0,C	;SIZE OF OBJECT CODE BLOCK

ONECL:	DESCX	1,0,0	;CONSTANT 1

OUTBLK:	DESCX	OUTPUT-DESCR,0,0	;POINTER TO OUTPUT BLOCK

SIZLMT:	DESCX	SIZLIM,0,0	;LIMIT ON SIZE OF DATA OBJECT

SNODSZ:	DESCX	NODESZ,0,P	;SMALL PATTERN NODE SIZE

STARSZ:	DESCX	11*DESCR,0,P	;SIZE OF EXPRESSION PATTERN

ZEROCL:	DESCX	0,0,0	;CONSTANT ZERO

TRSKEL:	DESCX	TRCBLK,0,0

COMDCT:	DESCX	14*DESCR,0,0

COMREG:	DESCX	ELEMND,0,0	;POINTER TO COMPILER DESCRIPTORS

;

;

;

;      POINTERS TO ASSEMBLED DATA PATTERNS

;

ARBACK:	DESCX	ARBAK,0,P

ARHEAD:	DESCX	ARHED,0,P

ARTAIL:	DESCX	ARTAL,0,P

STRPAT:	DESCX	STARPT,0,P

;

;      FUNCTION DESCRIPTORS

;

ANYCCL:	DESCX	ANYCFN,FNC,3

ASGNCL:	DESCX	ASGNFN,FNC,2

ATOPCL:	DESCX	ATOPFN,FNC,3

BASECL:	DESCX	BASEFN,FNC,0

BRKCCL:	DESCX	BRKCFN,FNC,3

CHRCL:	DESCX	CHRFN,FNC,3

CONCL:	DESCX	CONFN,FNC,0	;ARGUMENT COUNT IS INCREMENTED

DNMECL:	DESCX	DNMEFN,FNC,2

DNMICL:	DESCX	DNMIFN,FNC,2

DOTCL:	DESCX	DOTFN,FNC,1

ENDCL:	DESCX	ENDFN,FNC,0

ENMECL:	DESCX	ENMEFN,FNC,3

ENMICL:	DESCX	ENMIFN,FNC,3

ERORCL:	DESCX	ERORFN,FNC,1

FNCFCL:	DESCX	FNCFFN,FNC,2

FNMECL:	DESCX	FNMEFN,FNC,2

GOTGCL:	DESCX	GOTGFN,FNC,1

GOTLCL:	DESCX	GOTLFN,FNC,1

GOTOCL:	DESCX	GOTOFN,FNC,1

INITCL:	DESCX	INITFN,FNC,1

ITEMCL:	DESCX	AREFN,FNC,0

LITCL:	DESCX	LITFN,FNC,0	;ARGUMENT COUNT IS INCREMENTED

LNTHCL:	DESCX	LNTHFN,FNC,3

NMECL:	DESCX	NMEFN,FNC,2

NNYCCL:	DESCX	NNYCFN,FNC,3

POSICL:	DESCX	POSIFN,FNC,3

RPSICL:	DESCX	RPSIFN,FNC,3

RTBCL:	DESCX	RTBFN,FNC,3

SCANCL:	DESCX	SCANFN,FNC,2

SCFLCL:	DESCX	SCFLFN,FNC,2

SCOKCL:	DESCX	SCOKFN,FNC,2

SCONCL:	DESCX	SCONFN,FNC,2

SJSRCL:	DESCX	SJSRFN,FNC,3

SPNCCL:	DESCX	SPNCFN,FNC,3

SUCFCL:	DESCX	SUCFFN,FNC,2

TBCL:	DESCX	TBFN,FNC,3

INITB:	DESCX	ABNDB,0,0

INITE:	DESCX	DTEND+DESCR,0,0

;

;      MISCELLANEOUS DATA CELLS

;

A4PTR:	DESCX	0,0,0	;SCRATCH DESCRIPTOR

A5PTR:	DESCX	0,0,0	;SCRATCH DESCRIPTOR

A6PTR:	DESCX	0,0,0	;SCRATCH DESCRIPTOR

A7PTR:	DESCX	0,0,0	;SCRATCH DESCRIPTOR

BRTYPE:	DESCX	0,0,0	;BREAK TYPE RETURNED BY FORWRD

CMOFCL:	DESCX	0,0,0	;COMPILER OFFSET

DATSEG:	DESCX	0,0,100	;BEGINNING OF DEFINED DATA TYPES

DMPPTR:	DESCX	0,0,0	;BIN POINTER FOR DUMP

DTCL:	DESCX	0,0,0	;DATA TYPE DESCRIPTOR

DT1CL:	DESCX	0,0,0	;DATA TYPE DESCRIPTOR

EMSGCL:	DESCX	0,0,0	;PRESENT ERROR MESSAGE ADDRESS

ERRBAS:	DESCX	CARDSZ+STNOSZ-SEQSIZ,0,0

ESAICL:	DESCX	0,0,0	;COUNT OF COMPILER ERRORS

ETMCL:	DESCX	0,0,0	;TIME DESCRIPTOR

FATLCL:	DESCX	0,0,0	;FATAL ERROR SWITCH

FCL:	DESCX	0,0,0	;REAL NUMBER DESCRIPTOR

NEXFCL:	DESCX	FBLKSZ,0,0	;OFFSET IN FUNCTION BLOCK

FRTNCL:	DESCX	0,0,0	;FAILURE RETURN

GOGOCL:	DESCX	0,0,0	;GOTO DESCRIPTOR

INCL:	DESCX	0,0,0	;GLOBAL FUNCTION DESCRIPTOR

IOKEY:	DESCX	0,0,0	;I/O INDICATOR

MAXLEN:	DESCX	0,0,0	;MAXIMUM LENGTH FOR MATCHING

MSGNO:	DESCX	MSGLST,0,0	;POINTER TO ERROR MESSAGE LIST

NAMICL:	DESCX	0,0,0	;OFFSET ON NAMING LIST

NHEDCL:	DESCX	0,0,0	;NAME LIST HEAD OFFSET

NMOVER:	DESCX	NAMLSZ*SPDR,0,B	;NAME LIST END OFFSET

NULVCL:	DESCX	0,0,S	;NULL STRING VALUE

OCICL:	DESCX	0,0,0	;OBJECT CODE OFFSET

PATICL:	DESCX	0,0,0	;PATTERN CODE OFFSET

PDLEND:	DESCX	PDLBLK+SPDLDR-NODESZ,0,0

;                                  PATTERN HISTORY LIST END

PDLPTR:	DESCX	PDLBLK,0,0	;PATTERN HISTORY LIST BEGINNING

SCL:	DESCX	0,0,0	;SWITCH DESCRIPTOR

STKPTR:	DESCX	STACK,0,0	;POINTER TO STACK

STYPE:	DESCX	0,FNC,0	;DESCRIPTOR RETURN BY STREAM

TBLFNC:	DESCX	0,0,0	;POINTER TO LAST PATTERN TABLE

UNIT:	DESCX	0,0,0	;INPUT UNIT SWITCH

VARSYM:	DESCX	0,0,0

;

;      PROGRAM POINTERS

;

DATCL:	DESCX	DEFDAT,FNC,0	;DEFINED DATA OBJECTS

DEFCL:	DESCX	DEFFNC,FNC,0	;DEFINED FUNCTIONS

FLDCL:	DESCX	FIELD,0,1	;FIELD OF DEFINED DATA OBJECTS

LODCL:	DESCX	LNKFNC,FNC,0	;EXTERNAL FUNCTIONS

PDLHED:	DESCX	PDLBLK,0,0	;HISTORY LIST HEAD

UNDFCL:	DESCX	UNDF,FNC,0	;UNDEFINED FUNCTIONS

;

;      POINTERS TO SPECIFIERS

;

DPSPTR:	DESCX	DPSP,0,0

XSPPTR:	DESCX	XSP,0,0

YSPPTR:	DESCX	YSP,0,0

ZSPPTR:	DESCX	ZSP,0,0

TSPPTR:	DESCX	TSP,0,0

;

;      PERMANENT ATTRIBUTE LIST POINTERS

;

KNATL:	DESCX	KNLIST,0,0	;UNPROTECTED KEYWORD LIST

KVATL:	DESCX	KVLIST,0,0	;PROTECTED KEYWORD LIST

TRATL:	DESCX	TRLIST,0,0	;TRACE LIST

;

;      SPECIFIERS FOR COMPILATION LISTING

;

BLNSP:	SPEX	BLNBUF,0,0,0,STNOSZ

ERRSP:	SPEX	ERRBUF,0,0,0,CARDSZ+STNOSZ-SEQSIZ+1

INBFSP:	SPEX	INBUF,0,0,STNOSZ,CARDSZ

LNBFSP:	SPEX	INBUF,0,0,0,CARDSZ+DSTSZ+1

NEXTSP:	SPEX	INBUF,0,0,STNOSZ,CARDSZ-SEQSIZ

LNOSP:	SPEX	INBUF,0,0,0,STNOSZ

RNOSP:	SPEX	INBUF,0,0,CARDSZ+STNOSZ+1,STNOSZ

;

;      STRINGS AND SPECIFIERS

;

ALPHSP:	SPEX	ALPHA,0,0,0,ALPHSZ	;ALPHABET

AMPSP:	SPEX	AMPST,0,0,0,1	;AMPERSAND

CERRSP:	SPEX	ANYSP,0,0,0,0	;BUFFER SPECIFIER

COLSP:	SPEX	COLSTR,0,0,0,2	;COLON FOR TRACE MESSAGES

DMPSP:	SPEX	ANYSP,0,0,0,0	;BUFFER SPECIFIER

DTARSP:	SPEX	DTARBF,0,0,0,ARRLEN+9

;                                  ARRAY REPRESENTATION SPECIFIER

PROTSP:	SPEX	ANYSP,0,0,0,0	;BUFFER SPECIFIER

QTSP:	SPEX	QTSTR,0,0,0,1	;QUOTE FOR MESSAGES

REALSP:	SPEX	REALBF,0,0,0,10	;SPECIFIER FOR REAL CONVERSION

TRACSP:	SPEX	ANYSP,0,0,0,0	;BUFFER SPECIFIER

;
	HIGH
;**************************************************************

ARRSP:	STRING	<ARRAY>

ASSCSP:	STRING	<TABLE>

BLSP:	STRING	< >

BLEQSP:	STRING	< = >

CMASP:	STRING	<,>

EJCTSP:	STRING	<EJECT>

EQLSP:	STRING	<= >

ETIMSP:	STRING	<,TIME = >

EXDTSP:	STRING	<EXTERNAL>

LEFTSP:	STRING	<LEFT>

LISTSP:	STRING	<LIST>

LPRNSP:	STRING	<(>

OFSP:	STRING	< OF >

RPRNSP:	STRING	<)>

STARSP:	STRING	<*** >

TRCLSP:	STRING	< CALL OF >

TRLVSP:	STRING	<LEVEL >

TRSTSP:	STRING	<    STATEMENT >

UNLSP:	STRING	<UNLIST>

XFERSP:	STRING	<TRANSFER TO>
	LOW
;********************************************************************

;

;      CHARACTER BUFFERS

;

BLNBUF:	BUFFER	STNOSZ	;BLANKS FOR STATMENT NUMBER FIELD

DTARBF:	BUFFER	ARRLEN+7	;ARRAY REPRESENTATION BUFFER

ERRBUF:	BUFFER	CARDSZ+STNOSZ-SEQSIZ+1

INBUF:	BUFFER	CARDSZ+DSTSZ+1	;CARD INPUT BUFFER

REALBF:	BUFFER	36	;BUFFER FOR REAL NUMBER CONVERSION

ICLBLK:	DESCX	ICLBLK,TTL+MARK,ICLEND-ICLBLK-DESCR

;

;      POINTERS TO ATTRIBUTE LISTS

;

DTATL:	DESCX	DTLIST,0,0	;DATA TYPE PAIR LIST

FNCPL:	DESCX	FNLIST,0,0	;FUNCTION PAIR LIST

INATL:	DESCX	INLIST,0,0	;INPUT ASSOCIATION PAIR LIST

OUTATL:	DESCX	OTLIST,0,0	;OUTPUT ASSOCIATION PAIR LIST

TVALL:	DESCX	TVALPL,0,0	;VALUE TRACE PAIR LIST

	DESCX	VLTRFN,FNC,2	;DEFAULT VALUE TRACE PROCEDURE

TLABL:	DESCX	TLABPL,0,0	;LABEL TRACE PAIR LIST

	DESCX	LABTFN,FNC,1	;DEFAULT LABEL TRACE PROCEDURE

TFENTL:	DESCX	TFENPL,0,0	;CALL TRACE PAIR LIST

	DESCX	FNTRFN,FNC,2	;DEFAULT CALL TRACE PROCEDURE

TFEXTL:	DESCX	TFEXPL,0,0	;RETURN TRACE PAIR LIST

	DESCX	FXTRFN,FNC,2	;DEFAULT RETURN TRACE PROCEDURE

TKEYL:	DESCX	TKEYPL,0,0	;KEYWORD TRACE PAIR LIST

	DESCX	KEYTFN,FNC,1	;DEFAULT KEYWORD TRACE PROCEDURE

;

;      SCRATCH DESCRIPTORS

;

A1PTR:	DESCX	0,0,0

A2PTR:	DESCX	0,0,0

A3PTR:	DESCX	0,0,0

ATPTR:	DESCX	0,0,0

F1PTR:	DESCX	0,0,0

F2PTR:	DESCX	0,0,0

IO2PTR:	DESCX	0,0,0

IO1PTR:	DESCX	0,0,0

LPTR:	DESCX	0,0,0	;LAST LABEL POINTER

NVAL:	DESCX	0,0,0

IO3PTR:	DESCX	0,0,0

IO4PTR:	DESCX	0,0,0

TBLCS:	DESCX	0,0,0

TMVAL:	DESCX	0,0,0

TPTR:	DESCX	0,0,0

TCL:	DESCX	0,0,0

TSIZ:	DESCX	0,0,0

TVAL:	DESCX	0,0,0

VVAL:	DESCX	0,0,0

WCL:	DESCX	0,0,0

WPTR:	DESCX	0,0,0

XCL:	DESCX	0,0,0

XPTR:	DESCX	0,0,0

XSIZ:	DESCX	0,0,0

YCL:	DESCX	0,0,0

YPTR:	DESCX	0,0,0

YSIZ:	DESCX	0,0,0

ZCL:	DESCX	0,0,0

ZPTR:	DESCX	0,0,0

ZSIZ:	DESCX	0,0,0

;

;      SYSTEM DESCRIPTORS

;

BOSCL:	DESCX	0,0,0	;OFFSET OF BEGINNING OF STATEMENT

CMBSCL:	DESCX	0,0,0	;COMPILER CODE BASE DESCRIPTOR

NBSPTR:	DESCX	0,0,0	;NAME LIST BASE POINTER

FBLOCK:	DESCX	0,0,0	;FUNCTION PROCEDURE DESCRIPTOR BLOCK

OCBSCL:	DESCX	0,0,0	;INTERPRETER CODE BASE DESCRIPTOR

OCLIM:	DESCX	0,0,0	;END OF OBJECT CODE BLOCK

OCSVCL:	DESCX	0,0,0	;POINTER TO BASIC OBJECT CODE

PATBCL:	DESCX	0,0,0	;PATTERN CODE BASE DESCRIPTOR

SCBSCL:	DESCX	0,0,0

SRNCL:	DESCX	0,0,0	;SUCCESS RETURN DESCRIPTOR

;

;      COMPILER DESCRIPTORS

;

ELEMND:	DESCX	0,0,0	;ELEMENT NODE

ELEXND:	DESCX	0,0,0	;TEMPORARY NODE

ELEYND:	DESCX	0,0,0	;TEMPORARY NODE

EXELND:	DESCX	0,0,0	;TEMPORARY NODE

EXEXND:	DESCX	0,0,0	;TEMPORARY NODE

EXOPCL:	DESCX	0,0,0	;OPERATOR NODE

EXOPND:	DESCX	0,0,0	;OPERATOR NODE

EXPRND:	DESCX	0,0,0	;EXPRESSION NODE

FGOND:	DESCX	0,0,0	;FAILURE GOTO NODE

FORMND:	DESCX	0,0,0	;OBJECT NODE

FRNCL:	DESCX	0,0,0	;FAILURE RETURN DESCRIPTOR

GOTOND:	DESCX	0,0,0	;GOTO NODE

PATND:	DESCX	0,0,0	;PATTERN NODE

SGOND:	DESCX	0,0,0	;SUCCESS GOTO NODE

SUBJND:	DESCX	0,0,0	;SUBJECT NODE

;

;      DATA POINTERS

;

DFLFST:	DESCX	0,0,0	;DEFAULT OUTPUT FORMAT

ENDPTR:	DESCX	0,0,0	;<END>

EXTPTR:	DESCX	0,0,0	;<EXTERNAL>

FRETCL:	DESCX	0,0,0	;<FRETURN>

NRETCL:	DESCX	0,0,0	;<NRETURN>

RETCL:	DESCX	0,0,0	;<RETURN>

FUNTCL:	DESCX	0,0,0	;<FUNCTION>

;

;      SPECIFIERS

;

DPSP:	SPEX	0,0,0,0,0	;DATA TYPE SPECIFIER

HEADSP:	SPEX	0,0,0,0,0	;MATCHING HEAD SPECIFIER

IOSP:	SPEX	0,0,0,0,0	;I/O SPECIFIER

TAILSP:	SPEX	0,0,0,0,0	;MATCHING TAIL SPECIFIER

TEXTSP:	SPEX	0,0,0,0,0	;COMPILER STATEMENT SPECIFIER

TSP:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

TXSP:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

VSP:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

XSP:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

YSP:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

ZSP:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

;

;      ALLOCATOR DATA

;

ARG1CL:	DESCX	0,0,0	;SCRATCH DESCRIPTOR

BUKPTR:	DESCX	0,PTR,S	;BIN POINTER

LSTPTR:	DESCX	0,PTR,S	;POINTER TO LAST STRUCTURE

AXPTR:	DESCX	0,0,0	;ALLOCATION SIZE DESCRIPTOR

SPECR1:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

SPECR2:	SPEX	0,0,0,0,0	;SCRATCH SPECIFIER

ICLEND:	LHERE	,	;END OF BASIC BLOCK

;

;      ALLOCATOR DATA

;

BK1CL:	DESCX	0,0,0	;POINTER TO BLOCK BEING MARKED

BKDX:	DESCX	0,0,0	;OFFSET IN BLOCK BEING MARKED

BKDXU:	DESCX	0,0,0	;OFFSET IN BLOCK

BKLTCL:	DESCX	0,0,0

BKPTR:	DESCX	0,PTR,S

BLOCL:	DESCX	0,0,0

CONVSW:	DESCX	0,0,0	;CONVAR-GENVAR ENTRY SWITCH

CPYCL:	DESCX	0,0,0	;REGENERATION BLOCK POINTER

DESCL:	DESCX	0,0,0	;REGENERATION SCRATCH DESCRIPTOR

DESCL1:	DESCX 0,0,0	;EXTRA DESCRIPTOR FOR GC OF SPECIFIERS

DESCL2:	DESCX 0,0,0	;ANOTHER EXTRA FOR PDP-10

EQUVCL:	DESCX	0,0,0	;VARIABLE IDENTIFICATION DESCRIPTOR

FRDSCL:	DESCX	4*DESCR,0,0

GCBLK:	DESCX	GCXTTL,0,0	;POINTER TO MARKING BLOCK

GCNO:	DESCX	0,0,0	;COUNT OF REGENERATIONS

GCMPTR:	DESCX	0,0,0	;POINTER TO BASIC BLOCKS

GCREQ:	DESCX	0,0,0	;SPACE REQUIRED FROM REGENERATION

GCGOT:	DESCX	0,0,I	;SPACE OBTAINED FROM REGENERATION

LCPTR:	DESCX	0,0,0	;SCRATCH DESCRIPTOR

MVSGPT:	DESCX	0,0,0	;COMPRESSION BOUNDARY POINTER

NODPCL:	DESCX	0,0,0	;REGENERATION SWITCH

OBPTR:	DESCX	OBLIST,PTR,S	;POINTER TO BINS

OFSET:	DESCX	0,0,0	;OFFSET IN BLOCK DURING REGENERATION

PRMDX:	DESCX	PRMSIZ,0,0	;SIZE OF BASIC BLOCK LIST

PRMPTR:	DESCX	PRMTBL,0,0	;POINTER TO LIST OF BASIC BLOCKS

ST1PTR:	DESCX	0,PTR,S	;REGENERATION LINK POINTER

ST2PTR:	DESCX	0,PTR,S	;REGENERATION LINK POINTER

TEMPCL:	DESCX	0,PTR,0	;SCRACTH DESCRIPTOR

TOPCL:	DESCX	0,0,0	;POINTER TO BLOCK TITLE

TTLCL:	DESCX	0,0,0	;POINTER TO BLOCK TITLE

TWOCL:	DESCX	2*DESCR,0,B	;SIZE OF STRING TO BE MARKED

;

;

FRSGPT:	DESCX	0,PTR,0	;POSITION POINTER

HDSGPT:	DESCX	0,PTR,0	;HEAD OF ALLOCATED DATA REGION

TLSGP1:	DESCX	0,PTR,0	;END OF ALLOCATED DATA REGION

GCXTTL:	DESCX	GCXTTL,TTL+MARK,DESCR

;                                  BLOCK TO PRIME MARKING PROCEDURE

	DESCX	0,0,0	;POINTER TO BLOCK TO MARK

;

;      MACHINE-DEPENDENT DATA

;

	COPY	MDATA	;SEGMENT OF MACHINE-DEPENDENT DATA

;

;      FUNCTION TABLE

;

FTABLE:	DESCX	FTABLE,TTL+MARK,FTBLND-FTABLE-DESCR

;

;      PRIMITIVE FUNCTIONS

;

ANYFN:	DESCX	ANY,0,1

	DESCX	0,0,0

APLYFN:	DESCX	APPLY,FNC,1

	DESCX	0,0,0

ARBOFN:	DESCX	ARBNO,0,1

	DESCX	0,0,0

ARGFN:	DESCX	ARG,0,2

	DESCX	0,0,0

ARRAFN:	DESCX	ARRAY,0,2

	DESCX	0,0,0

ASSCFN:	DESCX	ASSOC,0,2

	DESCX	0,0,0

ASCFN:	DESCX	ASCII,0,1

	DESCX	0,0,0

BACKFN:	DESCX	BKSPCE,0,1

	DESCX	0,0,0

BREAFN:	DESCX	BREAK,0,1

	DESCX	0,0,0

CLEAFN:	DESCX	CLEAR,0,1

	DESCX	0,0,0

CODEFN:	DESCX	CODER,0,1

	DESCX	0,0,0

COLEFN:	DESCX	COLECT,0,1

	DESCX	0,0,0

CNVRFN:	DESCX	CNVRT,0,2

	DESCX	0,0,0

COPYFN:	DESCX	COPY,0,1

	DESCX	0,0,0

DATFN:	DESCX	DATE,0,1

	DESCX	0,0,0

DATDFN:	DESCX	DATDEF,0,1

	DESCX	0,0,0

DEFIFN:	DESCX	DEFINE,0,2

	DESCX	0,0,0

DIFFFN:	DESCX	DIFFER,0,2

	DESCX	0,0,0

DTCHFN:	DESCX	DETACH,0,1

	DESCX	0,0,0

DTFN:	DESCX	DT,0,1

	DESCX	0,0,0

DUMPFN:	DESCX	DMP,0,1

	DESCX	0,0,0

DUPLFN:	DESCX	DUPL,0,2

	DESCX	0,0,0

ENDFFN:	DESCX	ENFILE,0,1

	DESCX	0,0,0

EQFN:	DESCX	EQ,0,2

	DESCX	0,0,0

EVALFN:	DESCX	EVAL,0,1

	DESCX	0,0,0

FLDSFN:	DESCX	FIELDS,0,2

	DESCX	0,0,0

GEFN:	DESCX	GE,0,2

	DESCX	0,0,0

GTFN:	DESCX	GT,0,2

	DESCX	0,0,0

IDENFN:	DESCX	IDENT,0,2

	DESCX	0,0,0

IFLFN:	DESCX	IFILEF,0,2

	DESCX	0,0,0

INTGFN:	DESCX	INTGER,0,1

	DESCX	0,0,0

ITEMFN:	DESCX	ITEM,FNC,1

	DESCX	0,0,0

LEFN:	DESCX	LE,0,2

	DESCX	0,0,0

LENFN:	DESCX	LEN,0,1

	DESCX	0,0,0

LGTFN:	DESCX	LGT,0,2

	DESCX	0,0,0

LOADFN:	DESCX	LOAD,0,2

	DESCX	0,0,0

LOCFN:	DESCX	LOCAL,0,2

	DESCX	0,0,0

LTFN:	DESCX	LT,0,2

	DESCX	0,0,0

MSTFN:	DESCX	MSTIMF,0,1

	DESCX	0,0,0

NEFN:	DESCX	NE,0,2

	DESCX	0,0,0

NOTAFN:	DESCX	NOTANY,0,1

	DESCX	0,0,0

OFLFN:	DESCX	OFILEF,0,2

	DESCX	0,0,0

OPSYFN:	DESCX	OPSYN,0,3

	DESCX	0,0,0

POSFN:	DESCX	POS,0,1

	DESCX	0,0,0

PRINFN:	DESCX	PRINT,0,3

	DESCX	0,0,0

PROTFN:	DESCX	PROTO,0,1

	DESCX	0,0,0

REMDFN:	DESCX	REMDR,0,2

	DESCX	0,0,0

RPLAFN:	DESCX	RPLACE,0,3

	DESCX	0,0,0

READFN:	DESCX	READ,0,3

	DESCX	0,0,0

REWNFN:	DESCX	REWIND,0,1

	DESCX	0,0,0

RPOSFN:	DESCX	RPOS,0,1

	DESCX	0,0,0

RTABFN:	DESCX	RTAB,0,1

	DESCX	0,0,0

SAVEFN:	DESCX SAVE,0,1	;SAVE(S)

	DESCX 0,0,0

SIZEFN:	DESCX	SIZE,0,1

	DESCX	0,0,0

SPANFN:	DESCX	SPAN,0,1

	DESCX	0,0,0

STPTFN:	DESCX	STOPTR,0,2

	DESCX	0,0,0

TABFN:	DESCX	TAB,0,1

	DESCX	0,0,0

TIMFN:	DESCX	TIME,0,1

	DESCX	0,0,0

TRCEFN:	DESCX	TRACE,0,4

	DESCX	0,0,0

TRIMFN:	DESCX	TRIM,0,1

	DESCX	0,0,0

UNLDFN:	DESCX	UNLOAD,0,1

	DESCX	0,0,0

VALFN:	DESCX	FIELD,0,1

	DESCX	VALBLK,0,0

FTBLND:	LHERE	,

;

INITLS:	DESCX	INITLS,TTL+MARK,8*DESCR

	DESCX	DTLIST,0,0

	DESCX	FNLIST,0,0

	DESCX	INLIST,0,0

	DESCX	KNLIST,0,0

	DESCX	KVLIST,0,0

	DESCX	OTLIST,0,0

	DESCX	OTSATL,0,0

	DESCX	TRLIST,0,0

;

;      FUNCTION PAIR LIST

;

FNLIST:	DESCX	FNLIST,TTL+MARK,FNCPLE-FNLIST-DESCR

	DESCX	ANYFN,FNC,0	;ANY(CS)

	DESCX	ANYSP,0,0

	DESCX	APLYFN,FNC,0	;APPLY(F,A1,...,AN)

	DESCX	APLYSP,0,0

	DESCX	ARBOFN,FNC,0	;ARBNO(P)

	DESCX	ARBNSP,0,0

	DESCX	ARGFN,FNC,0	;ARG(F,N)

	DESCX	ARGSP,0,0

	DESCX	ARRAFN,FNC,0	;ARRAY(P,V)

	DESCX	ARRSP,0,0

	DESCX	ASCFN,FNC,0	;ASCII(I)

	DESCX	ASCSP,0,0

	DESCX	BACKFN,FNC,0	;BACKSPACE(N)

	DESCX	BACKSP,0,0

	DESCX	BREAFN,FNC,0	;BREAK(CS)

	DESCX	BRKSP,0,0

	DESCX	CLEAFN,FNC,0	;CLEAR()

	DESCX	CLERSP,0,0

	DESCX	CODEFN,FNC,0	;CODE(S)

	DESCX	CODESP,0,0

	DESCX	COLEFN,FNC,0	;COLLECT(N)

	DESCX	CLSP,0,0

	DESCX	CNVRFN,FNC,0	;CONVERT(V,DT)

	DESCX	CNVTSP,0,0

	DESCX	COPYFN,FNC,0	;COPY(V)

	DESCX	COPYSP,0,0

	DESCX	DATDFN,FNC,0	;DATA(P)

	DESCX	DATASP,0,0

	DESCX	DATFN,FNC,0	;DATE()

	DESCX	DATSP,0,0

	DESCX	DEFIFN,FNC,0	;DEFINE(P,L)

	DESCX	DEFISP,0,0

	DESCX	DIFFFN,FNC,0	;DIFFER(V1,V2)

	DESCX	DIFFSP,0,0

	DESCX	DTCHFN,FNC,0	;DETACH(V)

	DESCX	DTCHSP,0,0

	DESCX	DTFN,FNC,0	;DATATYPE(V)

	DESCX	DTSP,0,0

	DESCX	DUMPFN,FNC,0	;DUMP()

	DESCX	DUMPSP,0,0

	DESCX	DUPLFN,FNC,0	;DUPL(S,N)

	DESCX	DUPLSP,0,0

	DESCX	ENDFFN,FNC,0	;ENDFILE(N)

	DESCX	ENDFSP,0,0

	DESCX	EQFN,FNC,0	;EQ(I1,I2)

	DESCX	EQSP,0,0

	DESCX	EVALFN,FNC,0	;EVAL(E)

	DESCX	EVALSP,0,0

	DESCX	FLDSFN,FNC,0	;FIELD(V,N)

	DESCX	FLDSSP,0,0

	DESCX	GEFN,FNC,0	;GE(I1,I2)

	DESCX	GESP,0,0

	DESCX	GTFN,FNC,0	;GT(I1,I2)

	DESCX	GTSP,0,0

	DESCX	IDENFN,FNC,0	;IDENT(V1,V2)

	DESCX	IDENSP,0,0

	DESCX	IFLFN,FNC,0	;IFILE(I,F)

	DESCX	IFLSP,0,0

	DESCX	READFN,FNC,0	;INPUT(V,N,L)

	DESCX	INSP,0,0

	DESCX	INTGFN,FNC,0	;INTEGER(V)

	DESCX	INTGSP,0,0

	DESCX	ITEMFN,FNC,0	;ITEM(A,I1,...,IN)

	DESCX	ITEMSP,0,0

	DESCX	LENFN,FNC,0	;LEN(N)

	DESCX	LENSP,0,0

	DESCX	LEFN,FNC,0	;LE(I1,I2)

	DESCX	LESP,0,0

	DESCX	LGTFN,FNC,0	;LGT(S1,S2)

	DESCX	LGTSP,0,0

	DESCX	LOADFN,FNC,0	;LOAD(P)

	DESCX	LOADSP,0,0

	DESCX	LOCFN,FNC,0	;LOCAL(F,N)

	DESCX	LOCSP,0,0

	DESCX	LTFN,FNC,0	;LT(I1,I2)

	DESCX	LTSP,0,0

	DESCX	MSTFN,FNC,0	;MSTIME()

	DESCX	MSTSP,0,0

	DESCX	NEFN,FNC,0	;NE(I1,I2)

	DESCX	NESP,0,0

	DESCX	NOTAFN,FNC,0	;NOTANY(CS)

	DESCX	NNYSP,0,0

	DESCX	OFLFN,FNC,0	;OFILE(I,F)

	DESCX	OFLSP,0,0

	DESCX	OPSYFN,FNC,0	;OPSYN(F1,F2,N)

	DESCX	OPSNSP,0,0

	DESCX	PRINFN,FNC,0	;OUTPUT(V,N,F)

	DESCX	OUTSP,0,0

	DESCX	POSFN,FNC,0	;POS(N)

	DESCX	POSSP,0,0

	DESCX	PROTFN,FNC,0	;PROTOTYPE(A)

	DESCX	PRTSP,0,0

	DESCX	REMDFN,FNC,0	;REMDR(N,M)

	DESCX	REMDSP,0,0

	DESCX	REWNFN,FNC,0	;REWIND(N)

	DESCX	REWNSP,0,0

	DESCX	RPLAFN,FNC,0	;REPLACE(S,CS1,CS2)

	DESCX	RPLCSP,0,0

	DESCX	RPOSFN,FNC,0	;RPOS(N)

	DESCX	RPOSSP,0,0

	DESCX	RTABFN,FNC,0	;RTAB(N)

	DESCX	RTABSP,0,0

	DESCX	SAVEFN,FNC,0	;SAVE(S)

	DESCX	SAVESP,0,0

	DESCX	SIZEFN,FNC,0	;SIZE(S)

	DESCX	SIZESP,0,0

	DESCX	SPANFN,FNC,0	;SPAN(CS)

	DESCX	SPANSP,0,0

	DESCX	STPTFN,FNC,0	;STOPTR(V,R)

	DESCX	STPTSP,0,0

	DESCX	TABFN,FNC,0	;TAB(N)

	DESCX	TABSP,0,0

	DESCX	ASSCFN,FNC,0	;TABLE(N,M)

	DESCX	ASSCSP,0,0

	DESCX	TIMFN,FNC,0	;TIME()

	DESCX	TIMSP,0,0

	DESCX	TRCEFN,FNC,0	;TRACE(V,R,T,F)

	DESCX	TRCESP,0,0

	DESCX	TRIMFN,FNC,0	;TRIM(S)

	DESCX	TRMSP,0,0

	DESCX	UNLDFN,FNC,0	;UNLOAD(S)

	DESCX	UNLDSP,0,0

	DESCX	VALFN,FNC,0	;VALUE(S)

	DESCX	VALSP,0,0

	ARRAX	10*2	;SPACE FOR 10 MORE FUNCTIONS

FNCPLE:	LHERE	,	;END OF FUNCTION PAIR LIST

OPTBL:	DESCX	OPTBL,TTL+MARK,OPTBND-OPTBL-DESCR

ADDFN:	DESCX	ADD,0,2	;X + Y    ADDITION

	DESCX	0,0,0

	DESCX	30,0,29

BIAMFN:	DESCX	UNDF,FNC,0	;X & Y    DEFINABLE

	DESCX	0,0,0

	DESCX	5,0,4

BIATFN:	DESCX	UNDF,FNC,0	;X ` Y    DEFINABLE

	DESCX	0,0,0

	DESCX	25,0,24

BINGFN:	DESCX	UNDF,FNC,0	;X > Y    DEFINABLE

	DESCX	0,0,0

	DESCX	70,0,70

BIPDFN:	DESCX	UNDF,FNC,0	;X # Y    DEFINABLE

	DESCX	0,0,0

	DESCX	35,0,34

BIPRFN:	DESCX	UNDF,FNC,0	;X % Y    DEFINABLE

	DESCX	0,0,0

	DESCX	45,0,44

BIQSFN:	DESCX	UNDF,FNC,0	;X ? Y    DEFINABLE

	DESCX	0,0,0

	DESCX	70,0,69

CONFN:	DESCX	CON,0,2	;X   Y    CONCATENATION

	DESCX	0,0,0

	DESCX	20,0,19

DIVFN:	DESCX	DIV,0,2	;X / Y    DIVISION

	DESCX	0,0,0

	DESCX	40,0,39

DOLFN:	DESCX	DOL,0,2	;X $ Y    IMMEDIATE NAMING

	DESCX	0,0,0

	DESCX	60,0,59

EXPFN:	DESCX	EXP,0,2	;X ** Y   EXPONENTIATION

	DESCX	0,0,0

	DESCX	50,0,50

MPYFN:	DESCX	MPY,0,2	;X * Y    MULTIPLICATION

	DESCX	0,0,0

	DESCX	42,0,41

NAMFN:	DESCX	NAM,0,2	;X . Y    NAMING

	DESCX	0,0,0

	DESCX	60,0,59

ORFN:	DESCX	OR,0,2	;X ! Y    ALTERNATION

	DESCX	0,0,0

	DESCX	10,0,9

SUBFN:	DESCX	SUB,0,2	;X - Y    SUBTRACTION

	DESCX	0,0,0

	DESCX	30,0,29

AROWFN:	DESCX	UNDF,FNC,0	;aX       DEFINABLE

	DESCX	0,0,0

ATFN:	DESCX	ATOP,0,1	;`X       SCANNER POSITION

	DESCX	0,0,0

BARFN:	DESCX	UNDF,FNC,0	;!X       DEFINABLE

	DESCX	0,0,0

DOTFN:	DESCX	NAME,0,1	;.X       NAME

	DESCX	0,0,0

INDFN:	DESCX	IND,0,1	;$X       INDIRECT REFERENCE

	DESCX	0,0,0

KEYFN:	DESCX	KEYWRD,0,1	;&X       KEYWORD

	DESCX	0,0,0

MNSFN:	DESCX	MNS,0,1	;-X       MINUS

	DESCX	0,0,0

NEGFN:	DESCX	NEG,0,1	;>X       NEGATION

	DESCX	0,0,0

PDFN:	DESCX	UNDF,FNC,0	;#X       DEFINABLE

	DESCX	0,0,0

PLSFN:	DESCX	PLS,0,1	;+X       PLUS

	DESCX	0,0,0

PRFN:	DESCX	UNDF,FNC,0	;%X       DEFINABLE

	DESCX	0,0,0

QUESFN:	DESCX	QUES,0,1	;?X       INTERROGATION

	DESCX	0,0,0

SLHFN:	DESCX	UNDF,FNC,0	;/X       DEFINABLE

	DESCX	0,0,0

STRFN:	DESCX	STR,0,1	;*X       UNEVALUATED EXPRESSION

	DESCX	0,0,0

OPTBND:	LHERE	,	;END OF OPERATOR TABLE

;

;

AREFN:	DESCX	ITEM,FNC,1	;ARRAY OR TABLE REFERENCE

ASGNFN:	DESCX	ASGN,0,2	;X = Y

BASEFN:	DESCX	BASE,0,0	;BASE OBJECT CODE

ENDAFN:	DESCX	ARGNER,0,0	;SAFETY EXIT ON TRACE PSUEDO-CODE

ENDFN:	DESCX	END,0,0	;END OF PROGRAM

ERORFN:	DESCX	EROR,0,1	;ERRONEOUS STATEMENT

FNTRFN:	DESCX	FENTR,0,2	;CALL TRACING

FXTRFN:	DESCX	FNEXTR,0,2	;RETURN TRACING

GOTGFN:	DESCX	GOTG,0,1	;<X>

GOTLFN:	DESCX	GOTL,0,1	;(L)

GOTOFN:	DESCX	GOTO,0,1	;INTERNAL GOTO

INITFN:	DESCX	INIT,0,1	;STATEMENT INITIALIZATION

KEYTFN:	DESCX	KEYTR,0,2	;KEYWORD TRACING

LABTFN:	DESCX	LABTR,0,2	;LABEL TRACING

LITFN:	DESCX	LIT,0,1	;LITERAL EVALUATION

SCANFN:	DESCX	SCAN,0,2	;PATTERN MATCHING

SJSRFN:	DESCX	SJSR,0,3	;PATTERN MATCHING WITH REPLACEMENT

VLTRFN:	DESCX	VALTR,0,2	;VALUE TRACING

ANYCFN:	DESCX	ANYC,0,3	;MATCHING FOR ANY(S)

ARBFFN:	DESCX	ARBF,0,2	;FAILURE FOR ARB

ARBNFN:	DESCX	ARBN,0,2	;MATCHING FOR ARBNO(P)

ATOPFN:	DESCX	ATP,0,3	;MATCHING FOR `X

CHRFN:	DESCX	CHR,0,3	;MATCHING FOR STRING

BALFN:	DESCX	BAL,0,2	;MATCHING FOR BAL

BALFFN:	DESCX	BALF,0,2	;FAILURE FOR BAL

BRKCFN:	DESCX	BRKC,0,3	;MATCHING FOR BREAK(S)

DNMEFN:	DESCX	DNME,0,2

DNMIFN:	DESCX	DNME1,0,2

EARBFN:	DESCX	EARB,0,2

DSARFN:	DESCX	DSAR,0,3

ENMEFN:	DESCX	ENME,0,3

ENMIFN:	DESCX	ENMI,0,3

FARBFN:	DESCX	FARB,0,2

FNMEFN:	DESCX	FNME,0,2

LNTHFN:	DESCX	LNTH,0,3	;MATCHING FOR LEN(N)

NMEFN:	DESCX	NME,0,2

NNYCFN:	DESCX	NNYC,0,3	;MATCHING FOR NOTANY(S)

ONARFN:	DESCX	ONAR,0,2

ONRFFN:	DESCX	ONRF,0,2

POSIFN:	DESCX	POSI,0,3	;MATCHING FOR POS(N)

RPSIFN:	DESCX	RPSI,0,3	;MATCHING FOR RPOS(N)

RTBFN:	DESCX	RTB,0,3	;MATCHING FOR RTAB(N)

SALFFN:	DESCX	SALF,0,2

SCFLFN:	DESCX	FAIL,0,2

SCOKFN:	DESCX	SCOK,0,2	;SUCCESSFUL MATCH PROCEDURE

SCONFN:	DESCX	SCON,0,2

SPNCFN:	DESCX	SPNC,0,3	;MATCHING FOR SPAN(S)

STARFN:	DESCX	STAR,0,3	;MATCHING FOR *X

TBFN:	DESCX	TB,0,3	;MATCHING FOR TAB(N)

ABORFN:	DESCX	RTNUL3,0,3	;MATCHING FOR ABORT

FNCEFN:	DESCX	FNCE,0,2	;MATCHING FOR FENCE

FNCFFN:	DESCX	RTNUL3,0,2	;FAILURE FOR FENCE

SUCFFN:	DESCX	SUCF,0,2	;MATCHING FOR SUCCEED

;

;      INITIALIZATION DATA FOR FUNCTIONS

;

ABNDSP:	STRING	<ABEND>

ABORSP:	STRING	<ABORT>

ALNMSP:	STRING	<ALPHABET>

ANCHSP:	STRING	<ANCHOR>

ANYSP:	STRING	<ANY>

APLYSP:	STRING	<APPLY>

ARBSP:	STRING	<ARB>

ARBNSP:	STRING	<ARBNO>

ARGSP:	STRING	<ARG>

ASCSP:	STRING	<ASCII>

BACKSP:	STRING	<BACKSPACE>

BALSP:	STRING	<BAL>

BRKSP:	STRING	<BREAK>

TRFRSP:	STRING	<CALL>

CLERSP:	STRING	<CLEAR>

CODESP:	STRING	<CODE>

CLSP:	STRING	<COLLECT>

CNVTSP:	STRING	<CONVERT>

COPYSP:	STRING	<COPY>

DATSP:	STRING	<DATE>

DATASP:	STRING	<DATA>

DEFISP:	STRING	<DEFINE>

DIFFSP:	STRING	<DIFFER>

DTCHSP:	STRING	<DETACH>

DTSP:	STRING	<DATATYPE>

DUMPSP:	STRING	<DUMP>

DUPLSP:	STRING	<DUPL>

ENDSP:	STRING	<END>

ENDFSP:	STRING	<ENDFILE>

EQSP:	STRING	<EQ>

ERRLSP:	STRING	<ERRLIMIT>

ERRTSP:	STRING	<ERRTYPE>

EVALSP:	STRING	<EVAL>

EXPSP:	STRING	<EXPRESSION>

FAILSP:	STRING	<FAIL>

FNCESP:	STRING	<FENCE>

FLDSSP:	STRING	<FIELD>

FNCLSP:	STRING	<FNCLEVEL>

FRETSP:	STRING	<FRETURN>

FTRCSP:	STRING	<FTRACE>

FULLSP:	STRING	<FULLSCAN>

FUNTSP:	STRING	<FUNCTION>

GESP:	STRING	<GE>

GTSP:	STRING	<GT>

IDENSP:	STRING	<IDENT>

IFLSP:	STRING	<IFILE>

INSP:	STRING	<INPUT>

INTGSP:	STRING	<INTEGER>

ITEMSP:	STRING	<ITEM>

TRKYSP:	STRING	<KEYWORD>

TRLASP:	STRING	<LABEL>

LSTNSP:	STRING	<LASTNO>

LENSP:	STRING	<LEN>

LESP:	STRING	<LE>

LGTSP:	STRING	<LGT>

LOADSP:	STRING	<LOAD>

LOCSP:	STRING	<LOCAL>

LTSP:	STRING	<LT>

MAXLSP:	STRING	<MAXLNGTH>

MSTSP:	STRING	<MSTIME>

NAMESP:	STRING	<NAME>

NESP:	STRING	<NE>

NNYSP:	STRING	<NOTANY>

NRETSP:	STRING	<NRETURN>

OFLSP:	STRING	<OFILE>

OPSNSP:	STRING	<OPSYN>

OUTSP:	STRING	<OUTPUT>

PATSP:	STRING	<PATTERN>

POSSP:	STRING	<POS>

PRTSP:	STRING	<PROTOTYPE>

PNCHSP:	STRING	<PUNCH>

RLSP:	STRING	<REAL>

REMSP:	STRING	<REM>

REMDSP:	STRING	<REMDR>

RETSP:	STRING	<RETURN>

REWNSP:	STRING	<REWIND>

RPLCSP:	STRING	<REPLACE>

RPOSSP:	STRING	<RPOS>

RTABSP:	STRING	<RTAB>

RTYPSP:	STRING	<RTNTYPE>

SAVESP:	STRING <SAVE>

SIZESP:	STRING	<SIZE>

SPANSP:	STRING	<SPAN>

STCTSP:	STRING	<STCOUNT>

STFCSP:	STRING	<STFCOUNT>

STLMSP:	STRING	<STLIMIT>

STPTSP:	STRING	<STOPTR>

STNOSP:	STRING	<STNO>

VARSP:	STRING	<STRING>

SUCCSP:	STRING	<SUCCEED>

TABSP:	STRING	<TAB>

TIMSP:	STRING	<TIME>

TRCESP:	STRING	<TRACE>

TRMSP:	STRING	<TRIM>

UNLDSP:	STRING	<UNLOAD>

VALSP:	STRING	<VALUE>

;

CRDFSP:	STRING	<(16A5)>	;DEFAULT OUTPUT FORMAT

OUTPSP:	STRING	<(1X,27A5)>	;STANDARD PRINT FORMAT

;

;      POINTERS TO OTHER INITIALIZATION

;

ABNDB:	LHERE	,

	DESCX	ALPHSP,0,0	;&ALPHABET

	DESCX	ALPHVL,0,0

	DESCX	CRDFSP,0,0	;DEFAULT OUTPUT FORMAT

	DESCX	DFLFST,0,0

	DESCX	EXDTSP,0,0	;<EXTERNAL>

	DESCX	EXTPTR,0,0

	DESCX	ENDSP,0,0	;<END>

	DESCX	ENDPTR,0,0

	DESCX	FRETSP,0,0	;<FRETURN>

	DESCX	FRETCL,0,0

	DESCX	FUNTSP,0,0	;<FUNCTION>

	DESCX	FUNTCL,0,0

	DESCX	NRETSP,0,0	;<NRETURN>

	DESCX	NRETCL,0,0

	DESCX	RETSP,0,0	;<RETURN>

DTEND:	DESCX	RETCL,0,0

BUFEXT=DTEND-ANYSP		

BUFLEN=BUFEXT*CPA		

;

;      SYSTEM ARRAYS

;

PRMTBL:	DESCX	PRMTBL,TTL+MARK,PRMSIZ

	DESCX	DTLIST,0,0	;DATA TYPE PAIR LIST

	DESCX	FNLIST,0,0	;FUNCTION PAIR LIST

	DESCX	FTABLE,0,0	;PROCEDURE DESCRIPTOR TABLE

	DESCX	ICLBLK,0,0	;MISCELLANEOUS DATA

	DESCX	KNLIST,0,0	;UNPROTECTED KEYWORD PAIR LIST

	DESCX	KVLIST,0,0	;PROTECTED KEYWORD PAIR LIST

	DESCX	OPTBL,0,0	;OPERATOR PROCEDURE DESCRIPTORS

	DESCX	STACK,0,0	;INTERPRETER STACK

	DESCX	INLIST,0,0	;INPUT ASSOCIATION PAIR LIST

	DESCX	OTLIST,0,0	;OUTPUT ASSOCIATION PAIR LIST

	DESCX	INSATL,0,0	;INPUT BLOCK LIST

	DESCX	OTSATL,0,0	;OUTPUT BLOCK LIST

	DESCX	TFENPL,0,0	;CALL TRACE PAIR LIST

	DESCX	TFEXPL,0,0	;RETURN TRACE PAIR LIST

	DESCX	TKEYPL,0,0	;KEYWORD TRACE PAIR LIST

	DESCX	TLABPL,0,0	;LABEL TRACE PAIR LIST

	DESCX	TRLIST,0,0	;TRACE PAIR LIST

	DESCX	TVALPL,0,0	;VALUE TRACE PAIR LIST

PRMTRM:	LHERE	,	;END OF BASIC BLOCK LIST

PRMSIZ=PRMTRM-PRMTBL-DESCR			;SIZE OF BASIC BLOCK LIST

;

;      STRING STORAGE BIN LIST

;

OBLOCK:	DESCX	OBLOCK,TTL+MARK,OBARY*DESCR

	ARRAX	3	;PSEUDO HEADING

OBSTRT:	ARRAX	OBSIZ	;BIN LIST

OBLIST=OBSTRT-LNKFLD			;PSEUDO LINK POINTER

;

;      PATTERN MATCHING HISTORY LIST

;

PDLBLK:	DESCX	PDLBLK,TTL+MARK,SPDLSZ*DESCR

	ARRAX	SPDLSZ	;PATTERN HISTORY LIST

;

;      SYSTEM  STACK

;

STACK:	DESCX	STACK,TTL+MARK,STSIZE*DESCR

	ARRAX	STSIZE	;INTERPRETER STACK

;

;      PRIMITIVE PATTERNS

;

ABORPT:	DESCX	ABORPT,TTL+MARK,3*DESCR

	DESCX	ABORFN,FNC,2	;ABORT

	DESCX	0,0,0

	DESCX	0,0,0

;

ARBAK:	DESCX	ARBAK,TTL+MARK,6*DESCR

	DESCX	ONARFN,FNC,2

	DESCX	3*DESCR,0,0

	DESCX	0,0,0

	DESCX	ONRFFN,FNC,2

	DESCX	0,0,0

	DESCX	0,0,0

;

ARBPT:	DESCX	ARBPT,TTL+MARK,9*DESCR

	DESCX	SCOKFN,FNC,2	;ARB

	DESCX	0,0,3*DESCR

	DESCX	0,0,0

	DESCX	SCOKFN,FNC,2

	DESCX	6*DESCR,0,0

	DESCX	0,0,0

	DESCX	FARBFN,FNC,2

	DESCX	6*DESCR,0,0

	DESCX	0,0,0

;

ARHED:	DESCX	ARHED,TTL+MARK,12*DESCR

	DESCX	SCOKFN,FNC,2

	DESCX	0,0,3*DESCR

	DESCX	0,0,0

	DESCX	SCOKFN,FNC,2

	DESCX	6*DESCR,0,0

	DESCX	0,0,0

	DESCX	ARBNFN,FNC,2

	DESCX	9*DESCR,0,12*DESCR

	DESCX	0,0,0

	DESCX	ARBFFN,FNC,2

	DESCX	0,0,0

	DESCX	0,0,0

;

ARTAL:	DESCX	ARTAL,TTL+MARK,6*DESCR

	DESCX	EARBFN,FNC,2

	DESCX	0,0,3*DESCR

	DESCX	0,0,0

	DESCX	SCOKFN,FNC,2

	DESCX	6*DESCR,0,0

	DESCX	0,0,0

;

BALPT:	DESCX	BALPT,TTL+MARK,9*DESCR

	DESCX	SCOKFN,FNC,2	;BAL

	DESCX	0,0,3*DESCR

	DESCX	0,0,0

	DESCX	BALFN,FNC,2

	DESCX	6*DESCR,0,0

	DESCX	0,0,0

	DESCX	BALFFN,FNC,2

	DESCX	6*DESCR,0,0

	DESCX	0,0,0

;

FAILPT:	DESCX	FAILPT,TTL+MARK,3*DESCR

	DESCX	SALFFN,FNC,2	;FAIL

	DESCX	0,0,0

	DESCX	0,0,0

;

FNCEPT:	DESCX	FNCEPT,TTL+MARK,3*DESCR

	DESCX	FNCEFN,FNC,2	;FENCE

	DESCX	0,0,0

	DESCX	0,0,0

;

REMPT:	DESCX	REMPT,TTL+MARK,4*DESCR

	DESCX	RTBFN,FNC,3	;REM

	DESCX	0,0,0

	DESCX	0,0,0

	DESCX	0,0,I

;

STARPT:	DESCX	STARPT,TTL+MARK,11*DESCR

	DESCX	STARFN,FNC,3

	DESCX	0,0,4*DESCR

	DESCX	1,0,0

	DESCX	0,0,0

	DESCX	SCOKFN,FNC,2

	DESCX	7*DESCR,0,0

	DESCX	0,0,0

	DESCX	DSARFN,FNC,3

	DESCX	0,0,4*DESCR

	DESCX	0,0,0

	DESCX	0,0,0

;

SUCCPT:	DESCX	SUCCPT,TTL+MARK,3*DESCR

	DESCX	SUCFFN,FNC,2	;SUCCEED

	DESCX	0,0,0

	DESCX	0,0,0

;

;      CODE SKELETON FOR TRACE

;

TRCBLK:	DESCX	TRCBLK,TTL+MARK,6*DESCR

	DESCX	0,FNC,2	;TRACE FUNCTION DESCRIPTOR

	DESCX	DOTFN,FNC,1	;LITERAL FUNCTION DESCRIPTOR

	DESCX	0,0,0	;VARIABLE TO BE TRACED

	DESCX	DOTFN,FNC,1	;LITERAL FUNCTION DESCRIPTOR

	DESCX	0,0,0	;TAG SUPPLIED FOR TRACE

	DESCX	ENDAFN,FNC,0	;ERROR FUNCTION FOR SAFETY

;

TVALPL:	DESCX	TVALPL,TTL+MARK,2*DESCR

	DESCX	0,0,0	;VALUE TRACE

	DESCX	0,0,0

TLABPL:	DESCX	TLABPL,TTL+MARK,2*DESCR

	DESCX	0,0,0	;LABEL TRACE

	DESCX	0,0,0

TFENPL:	DESCX	TFENPL,TTL+MARK,2*DESCR

	DESCX	0,0,0	;CALL TRACE

	DESCX	0,0,0

TFEXPL:	DESCX	TFEXPL,TTL+MARK,2*DESCR

	DESCX	0,0,0	;RETURN TRACE

	DESCX	0,0,0

TKEYPL:	DESCX	TKEYPL,TTL+MARK,2*DESCR

	DESCX	0,0,0	;KEYWORD TRACE

	DESCX	0,0,0

;

VALBLK:	DESCX	VALBLK,TTL+MARK,6*DESCR

	DESCX	0,0,S	;STRING

	DESCX	0,0,0	;0 OFFSET

	DESCX	0,0,N	;NAME

	DESCX	0,0,0	;0 OFFSET

	DESCX	0,0,K	;KEYWORD (NAME)

	DESCX	0,0,0	;0 OFFSET

;

;      FATAL ERROR MESSAGE POINTERS

;

MSGLST:	DESCX	0,0,0

	DESCX	MSG1,0,0

	DESCX	MSG2,0,0

	DESCX	MSG3,0,0

	DESCX	MSG4,0,0

	DESCX	MSG5,0,0

	DESCX	MSG6,0,0

	DESCX	MSG7,0,0

	DESCX	MSG8,0,0

	DESCX	MSG9,0,0

	DESCX	MSG10,0,0

	DESCX	MSG11,0,0

	DESCX	MSG12,0,0

	DESCX	MSG13,0,0

	DESCX	MSG14,0,0

	DESCX	MSG15,0,0

	DESCX	MSG16,0,0

	DESCX	MSG17,0,0

	DESCX	MSG18,0,0

	DESCX	MSG19,0,0

	DESCX	MSG20,0,0

	DESCX	MSG21,0,0

	DESCX	MSG22,0,0

	DESCX	MSG23,0,0

	DESCX	MSG24,0,0

	DESCX	MSG25,0,0

	DESCX	MSG26,0,0

	DESCX	MSG27,0,0

	DESCX	MSG28,0,0

	DESCX	MSG29,0,0

	DESCX	MSG30,0,0

	DESCX	MSG31,0,0

	DESCX	MSG32,0,0

	HIGH
;***********************************************************************

;

;      FATAL ERROR MESSAGES

;

MSG1:	STRING	<ILLEGAL DATA TYPE>

MSG2:	STRING	<ERROR IN ARITHMETIC OPERATION>

MSG3:	STRING	<ERRONEOUS ARRAY OR TABLE REFERENCE>

MSG4:	STRING	<NULL STRING IN ILLEGAL CONTEXT>

MSG5:	STRING	<UNDEFINED FUNCTION OR OPERATION>

MSG6:	STRING	<ERRONEOUS PROTOTYPE>

MSG7:	STRING	<UNKNOWN KEYWORD>

MSG8:	STRING	<VARIABLE NOT PRESENT WHERE REQUIRED>

MSG9:	STRING	<ENTRY POINT OF FUNCTION NOT LABEL>

MSG10:	STRING	<ILLEGAL ARGUMENT TO PRIMITIVE FUNCTION>

MSG11:	STRING	<READING ERROR>

MSG12:	STRING	<ILLEGAL I/O UNIT>

MSG13:	STRING	<LIMIT ON DEFINED DATA TYPES EXCEEDED>

MSG14:	STRING	<NEGATIVE NUMBER IN ILLEGAL CONTEXT>

MSG15:	STRING	<STRING OVERFLOW>

MSG16:	STRING	<OVERFLOW DURING PATTERN MATCHING>

MSG17:	STRING	<ERROR IN SNOBOL4 SYSTEM>

MSG18:	STRING	<RETURN FROM LEVEL ZERO>

MSG19:	STRING	<FAILURE DURING GOTO EVALUATION>

MSG20:	STRING	<INSUFFICIENT STORAGE TO CONTINUE>

MSG21:	STRING	<STACK OVERFLOW>

MSG22:	STRING	<LIMIT ON STATEMENT EXECUTION EXCEEDED>

MSG23:	STRING	<OBJECT EXCEEDS SIZE LIMIT>

MSG24:	STRING	<UNDEFINED OR ERRONEOUS GOTO>

MSG25:	STRING	<INCORRECT NUMBER OF ARGUMENTS>

MSG26:	STRING	<LIMIT ON COMPILATION ERRORS EXCEEDED>

MSG27:	STRING	<ERRONEOUS END STATEMENT>

MSG28:	STRING	<EXECUTION OF STATEMENT WITH COMPILATION ERROR>

MSG29:	STRING <IO BUFFER SPACE EXHAUSTED, RESTART AND USE THE I SWITCH>

MSG30:	STRING <INSUFFICIENT STORAGE, NOT ENOUGH CORE FOR STARTING>

MSG31:	STRING <ATTEMPT TO READ BEYOND END OF FILE>

MSG32:	STRING <ERROR DETECTED BY SNOBOL OPERATING SYSTEM>


;

;      COMPILER ERROR MESSAGES

;

EMSG1:	STRING	<ERRONEOUS LABEL>

EMSG2:	STRING	<PREVIOUSLY DEFINED LABEL>

EMSG3:	STRING	<ERRONEOUS SUBJECT>

EMSG14:	STRING	<ERROR IN GOTO>

ILCHAR:	STRING	<ILLEGAL CHARACTER IN ELEMENT>

ILLBIN:	STRING	<BINARY OPERATOR MISSING OR IN ERROR>

ILLBRK:	STRING	<ERRONEOUS OR MISSING BREAK CHARACTER>

ILLDEC:	STRING	<ERRONEOUS REAL NUMBER>

ILLEOS:	STRING	<IMPROPERLY TERMINATED STATEMENT>

ILLINT:	STRING	<ERRONEOUS INTEGER>

OPNLIT:	STRING	<UNCLOSED LITERAL>

	LOW
;************************************************************************
;

;      FORMATS

;

ARTHNO:	FORMAT	<(1H0,I15,32H ARITHMETIC OPERATIONS PERFORMED)>

	HIGH
;*****************************************************************

CMTIME:	FORMAT	<(1H0,I15,21H MS. COMPILATION TIME)>

EJECTF:	FORMAT	<(1H1)>

ERRCF:	FORMAT	<(34H0ERRORS DETECTED IN SOURCE PROGRAM/1H1)>

EXNO:	FORMAT	<(1H0,I15,21H STATEMENTS EXECUTED,,I8,7H FAILED)>

FTLCF:	FORMAT	<(6H1ERROR,I3,13H IN STATEMENT,I4,9H AT LEVEL,I3)>

INCGCF:	FORMAT	<(33H1INCOMPLETE STORAGE REGENERATION.)>

INTIME:	FORMAT	<(1H0,I15,19H MS. EXECUTION TIME)>

LASTSF:	FORMAT	<(28H LAST STATEMENT EXECUTED WAS,I5)>

NODMPF:	FORMAT	<(28H1TERMINAL DUMP NOT POSSIBLE.)>

NRMEND:	FORMAT	<(28H1NORMAL TERMINATION AT LEVEL,I3)>

NVARF:	FORMAT	<(18H0NATURAL VARIABLES,/1H )>

PKEYF:	FORMAT	<(21H0UNPROTECTED KEYWORDS/1H )>

PRTOVF:	FORMAT	<(29H ***PRINT REQUEST TOO LONG***)>

READNO:	FORMAT	<(1H0,I15,16H READS PERFORMED)>

SCANNO:	FORMAT	<(1H0,I15,26H PATTERN MATCHES PERFORMED)>

	EXTERN SOURCF
;SOURCF:	FORMAT	<(32H0DIGITAL EQUIPMENT CORP., PDP-10/)>

STATHD:	FORMAT	<(28H1SNOBOL4 STATISTICS SUMMARY-)>

STDMP:	FORMAT	<(33H1DUMP OF VARIABLES AT TERMINATION/1H )>

STGENO:	FORMAT	<(1H0,I15,33H REGENERATIONS OF DYNAMIC STORAGE)>

SUCCF:	FORMAT	<(37H0NO ERRORS DETECTED IN SOURCE PROGRAM/1H1)>

SYSCMT:	FORMAT	<(27H0CUT BY SYSTEM IN STATEMENT,I4,9H AT LEVEL,I3)>

TIMEPS:	FORMAT	<(1H0,F15.2,35H MS. AVERAGE PER STATEMENT EXECUTED/1H1)>

	EXTERN TITLEF
;TITLEF:	FORMAT	<(37H1SNOBOL4 (VERSION 3.4, JULY 10, 1970)/)>

WRITNO:	FORMAT	<(1H0,I15,17H WRITES PERFORMED)>

       END