Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0028/sno313.mac
There are 2 other files named sno313.mac in the archive. Click here to see a list.
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