* $Id: v311.sil,v 1.141 2014/12/30 05:05:00 phil Exp $
*
* $Log: v311.sil,v $
* Revision 1.141  2014/12/30 05:05:00  phil
* [PLB125] use PCOMP in GC
* died when dynamic region straddled 2G line on OpenBSD
*
* Revision 1.140  2014/12/05 18:59:40  phil
* fix commenting
*
* Revision 1.139  2014/12/05 18:58:11  phil
* v311.sil: Fix compilation without BLOCKS: commented out unused R_R_N
* (nested .IFs don't work)
*
* Revision 1.138  2014/10/13 23:32:28  phil
* Makefile: cleanup for modules directories
* 	add "with" as configure output
* 	remove configure dependancy
* 		(runs constantly when newer than with)
* Makefile2.m4: explictly pass -N to test/run.sh
* v311.sil,procs: remove unused blocks code/functions
*
* Revision 1.137  2014/01/18 23:37:31  phil
* [PLB124] fix "FUNCTION" TRACE()
*
* Revision 1.136  2013/10/28 02:52:30  phil
* [PLB123] Add &COMPNO (ala SITBOL/SNOBOL4B)
*
* Revision 1.135  2013/10/26 19:17:38  phil
* [PLB122] Fix paste-o for single letter 'R' trace
*
* Revision 1.134  2013/10/23 02:49:46  phil
* Merge from BR_1_5_PLUS_BLOCKS
*
* Revision 1.133.2.5  2013/10/18 02:30:58  phil
* v311.sil: [PLB121] Clean up PRINT/EJECT carriage control
* Implement ASCII Carriage Control if CC(unit) < 0
*
* Revision 1.133.2.4  2013/10/16 00:33:37  phil
* [PLB120] change DI_8 to DI_DSC for 64-bit systems!
*
* Revision 1.133.2.3  2013/10/15 20:23:52  phil
* [PLB119] fix BCHAR() -- was writing into const string
* clean up warning FORMATs, report file & line
*
* Revision 1.133.2.2  2013/10/12 02:03:55  phil
* v311.sil: [PLB118] replace MOVBLK with MOVBLK2 in BLAND
*
* Revision 1.133.2.1  2013/10/11 23:09:06  phil
* [BLOCKS] add BLOCKS code thanks to Mike Alexander
* [PLB117] add -[NO]BLOCKS to disable/enable blocks operator changes
*
* Revision 1.133  2013/09/23 21:38:32  phil
* [PLB116] use SMAXINT
*
* Revision 1.132  2013/09/13 01:14:07  phil
* [PLB115] single letter trace types (ala SPITBOL)
*
* Revision 1.131  2013/09/13 00:35:38  phil
* [PLB114] pulled LASTFILE/LINE & USRINT checks to top of INIT
*
* Revision 1.130  2013/09/01 03:37:25  phil
* v311.sil: [PLB113] fix keyword trace output I broke in 2005 (edit PLB90)
* add chk_break() call -- fires &STNO KEYWORD trace
*
* Revision 1.129  2013/08/31 03:02:30  phil
* [PLB112] save/restore &LAST{FILE,LINE} calling trace handlers
* restore saved &LINE in ABORT handler
*
* Revision 1.128  2013/08/27 04:59:02  phil
* [PLB111] check for null value in LABEL()
*
* Revision 1.127  2013/08/23 23:08:13  phil
* [PLB110] fix continue from END after an error
* 	fix duplicate END2 label
*
* Revision 1.126  2013/08/22 19:52:30  phil
* [PLB109] Implement "User Interrupt" (SIGINT) handling
* Set &LAST{NO,FILE,LINE} in XITHND
* Allow new errors to overwrite old return information
*
* Revision 1.125  2013/08/08 01:07:41  phil
* [PLB108] Add &MAXINT
*
* Revision 1.124  2013/08/04 17:21:03  phil
* [PLB107] Display avg ns. per statement
* Add &STEXEC -- total statements executed
*     &GCTIME -- total time in GC
*
* Revision 1.123  2013/08/02 04:09:07  phil
* [PLB106] add &PI
*
* Revision 1.122  2013/08/01 02:58:32  phil
* [PLB105] add &DIGITS
*
* Revision 1.121  2012/02/26 00:32:07  phil
* [PLB104] safety check KSt/sec division; use REAL constants
*          flush SPDLDR; increase PMSTACK to 8000, ISTACK to 4000
*
* Revision 1.120  2012/02/23 23:27:11  phil
* [PLB103] Report K Statements/sec
*
* Revision 1.119  2012/02/14 19:04:16  phil
* [PLB102] Add -HIDE for sdb
*
* Revision 1.118  2012/02/03 05:40:56  phil
* [PLB101] only modify function entry if LOAD succeeds
*
* Revision 1.117  2011/12/29 23:00:30  phil
* [PLB100] SETEXIT returns old value
*
* Revision 1.116  2011/01/24 04:33:49  phil
* [PLB99] fix FUNCTION for referenced, but undefined functions
*
* Revision 1.115  2011/01/22 02:39:38  phil
* [PLB98] SETEXIT cleanup; prohibit re-entry, implement trap at END
*
* Revision 1.114  2011/01/21 06:04:31  phil
* [PLB97] implement SETEXIT/CONTINUE/SCONTINUE/ABORT
*
* Revision 1.113  2009/08/29 18:57:42  phil
* [PLB96] need to FULLY clear WPTR in LNKFNC or
* COLLECT() crashes if called immediately after an
* "external" function.  Add collect2 test.
* reported by Laurence Battin <beamtuner@att.net>
*
* Revision 1.112  2005/11/22 21:13:55  phil
* [PLB95] Add SPCSP for explicit output of spaces
*
* Revision 1.111  2005/11/10 16:51:53  phil
* [PLB94] decrement &GTRACE if positive
*
* Revision 1.110  2005/10/30 05:31:00  phil
* [PLB93] Use TEMPCL for GC time tracking
*
* Revision 1.109  2005/10/28 04:40:48  phil
* [PLB92] Implement GC trace (&GTRACE) and GC stats
*
* Revision 1.108  2005/10/24 06:51:19  phil
* [PLB91] Fix backtracking for *opr
*
* Revision 1.107  2005/10/21 22:08:21  phil
* [PLB90] prepend &FILE and &LINE to trace output!
*
* Revision 1.106  2005/10/21 18:09:03  phil
* [PLB89] Perform case folding on alternate function entry label
*
* Revision 1.105  2004/09/08 05:27:17  phil
* undo two PCOMPS at SPCNV2; detected by HP-UX compiler
*
* Revision 1.104  2004/08/12 16:07:53  phil
* [PLB88] Use PCOMP[C] SIL operators for pointer comparison
* Locations thanks to Mark Emmer (from SNOBOL4+)
*
* Revision 1.103  2004/01/12 07:05:08  phil
* track passed arg count using WPTR
*
* Revision 1.102  2004/01/12 06:42:36  phil
* remove unused label LNKF8
*
* Revision 1.101  2004/01/12 06:32:39  phil
* [PLB87] Fix argument processing for LOADed functions:
* if there are more actuals than formals, pass extras
* without conversion (was looking past end of formal list)!
*
* Revision 1.100  2003/04/24 04:07:41  phil
* [PLB86] upcase library function names (use casting macros)
* rename ENFILE to ENDFIL to avoid Unix errno.h collision
*
* Revision 1.99  2002/06/05 16:10:50  phil
* [PLB85] Allocate interpreter stack at startup (-S option)
*
* Revision 1.98  2002/03/01 19:03:59  phil
* [PLB84] remove an empty RCALL label list
*
* Revision 1.97  2002/02/22 19:29:46  phil
* [PLB83] 3-way return for XINCLD
*
* Revision 1.96  2002/02/18 18:53:17  phil
* [PLB82] compile cleanly with gcc -Wunused
* removed unused code; add new top-of-procedure labels where needed
* add XECODE operator to tag end of source code
*
* Revision 1.95  2002/01/26 15:44:43  phil
* [PLB81] set &MAXLNGTH to SIZLIM
* increase FNLIST free space to 40 functions
* (to allow for growing number of PML functions)
*
* Revision 1.94  2002/01/22 17:17:37  phil
* [PLB80] Add experimental FUNCTION() predicate
*
* Revision 1.93  2002/01/22 16:52:23  phil
* [PLB79] make LABEL() honor case folding
*
* Revision 1.92  2002/01/22 01:48:06  phil
* updated Table of Contents
*
* Revision 1.91  2002/01/21 17:19:14  phil
* [PLB78] add new functions (ideas from Steve Duff's Macro SPITBOL)
* LABEL(V) - predicate returns true if V is a defined label
* VDIFFER(X,Y) - returns X if X and Y DIFFER(), else fails
*
* Revision 1.90  2002/01/18 23:49:16  phil
* [PLB77] fix compiler syntax error pointer display
* fix internal error trying to compile " ()("
*
* Revision 1.89  2002/01/18 05:06:27  phil
* [PLB76] Fix lexical comparison optimizations
* add new lexical functions to index
*
* Revision 1.88  2002/01/17 18:57:40  phil
* [PLB75] Increase hash table size to 8K
* define OBSFT (shift factor) for table size
*
* Revision 1.87  2002/01/06 16:57:27  phil
* [PLB74] rename "CON" to "CONCAT"
* subr/CON was being interpreted as CONSOLE
* in Cygwin isnobol4.c build
*
* Revision 1.86  2001/12/27 17:42:30  phil
* [PLB73] rearrange some code to avoid functionization
* eliminate procs (and loops): TRAC{1,4,6}, STOPT1, RECOM{N,F,Q,T}
*
* Revision 1.85  2001/12/26 23:15:51  phil
* [PLB72] Use %G for us/stmt
*
* Revision 1.84  2001/12/18 22:15:00  phil
* fix edit tags on CASECL
* tweaked comment on previous edit
*
* Revision 1.83  2001/12/18 21:27:42  phil
* [PLB71] Keep runtimes in REALs, effects TIME(), trace messages,
* statistics.  Report average in microseconds/statement.
*
* Revision 1.82  2001/12/18 02:05:51  phil
* [PLB70] use COMPCL to determine if compiler done at FTLEN2
* ETMCL can be zero, on a fast machine (1MHz Athlon) and an O/S
* with poor runtime resolution (Linux).  Result was all execution
* time was charged to compiler, and execution time reported as zero!
*
* Revision 1.81  1998/12/29 06:14:48  phil
* [PLB69] move CASECL to alphabeticly correct location
*
* Revision 1.80  1997/11/08  03:03:12  phil
* [PLB68] remove keyword tracing for ERRTEXT
* doesn't work (output as integer)
* neither SNOBOL4+ nor SPITBOL do it
*
* Revision 1.79  1997/11/06  05:59:02  phil
* [PLB67] replace PROC with XPROC on merged scanner functions
*
* Revision 1.78  1997/10/31  05:13:16  phil
* [PLB66] catch bad data at PATBRA
*
* Revision 1.77  1997/10/29  06:36:09  phil
* XRTNL3 typo
*
* Revision 1.76  1997/10/29  06:21:53  phil
* [PLB65] merged matching functions into SCIN1
*
* Revision 1.75  1997/10/24  20:21:04  phil
* [PLB64] from SNOBOL4+
* Allow reals in INTVAL
*
* Revision 1.74  1997/09/09  20:14:14  phil
* [PLB63] call io_pad() to fix up for -LIST RIGHT
*
* Revision 1.73  1997/09/08  05:22:19  phil
* [PLB62] set LNBFSP length from TEXTSP after input
* so listings don't end up showing old, long lines
* this kills "LIST RIGHT", but it was of pretty dubious
* value with a compiler "card size" of 1024
*
* Revision 1.72  1997/09/08  03:40:11  phil
* [PLB61] flushed INBFSP, SEQSIZ
* init TEXTSP before STREAD in compiler
* perform STREAD using TEXTSP to get returned line length
*
* Revision 1.71  1997/09/03  04:44:07  phil
* [PLB60] Add "Output error"
* Check IOKEY after user OUTPUT
* Check return from ENDFILE
*
* Revision 1.70  1997/08/06  05:51:27  phil
* [PLB59] from SNOBOL4+
* seperate syntax tables for BREAK(X) and SPAN
* simple index lookup for ANY/NOTANY
*
* Revision 1.69  1997/07/25  21:53:52  phil
* [PLB58] Incremented COMDCT, added comment
* no need to explicitly clear INCSTK!
*
* Revision 1.68  1997/07/03  02:08:29  phil
* [PLB57] Upped CARDSZ back to 1024
*
* Revision 1.67  1997/05/22  05:03:21  phil
* [PLB56] Removed duplicate COPYSP; Expressions now legal in ARRAY macro
*
* Revision 1.66  1997/04/03  02:55:36  phil
* [PLB55] Add Catspaw SPITBOL style optional arg to DATE()
*
* Revision 1.65  1997/02/13  06:53:54  phil
* [PLB54] add vm_gc_advise calls
*
* Revision 1.64  1996/10/25  21:34:22  phil
* [PLB53] Add io_flushall calls
*
* Revision 1.63  1996/10/20  04:06:15  phil
* [PLB52] add SPITBOL SET() function (from SNOBOL4+ SEEK/TELL)
*
* Revision 1.62  1996/10/17  02:31:18  phil
* [PLB51] Implement format/options for INPUT()
* Pass format/options to OUTPUT()
* Use XCALLC; XOPEN[IO] deprecated
* fixed INPUT(V,U,O,N) and OUTPUT(V,U,O,N) comments
*
* Revision 1.61  1996/10/13  22:04:16  phil
* [PLB50] fixes from SNOBOL4+ to avoid "Internal Errors" on bad CODE() args
*
* Revision 1.60  1996/10/13  05:53:04  phil
* [PLB49] use YCL for error pointer
* add COMPCL; don't show syntax errors after compilation done
* set &ERRTEXT with compilation error messages!
*
* Revision 1.59  1996/10/12  04:09:35  phil
* [PLB48] Don't crash trying to print CODE() syntax errors
*
* Revision 1.58  1996/10/08  06:21:28  phil
* [PLB47] display signal number (SIGNCL) in SYSCUT
*
* Revision 1.57  1996/10/05  06:28:51  phil
* [PLB46] moved INCSTK to ICLBLK (sir.sno GC crashed compiler)
* increased FNLIST free space to 20 functions
* more comment tweaking
*
* Revision 1.56  1996/10/04  04:17:13  phil
* [PLB45] increased STSIZE from 1000 to 1500
* use plain constant for space at end of FNLIST
*
* Revision 1.55  1996/09/30  23:41:41  phil
* [PLB44] use getpmproto() to get autoload prototypes
*
* Revision 1.54  1996/09/30  17:07:21  phil
* don't zap FILENM at XLATND, so if there are no executable statements
* (just an END), we have a file name to display for "Last statement"!
*
* Revision 1.53  1996/09/30  05:53:19  phil
* [PLB43] renamed EXP to EXPOP
*
* Revision 1.52  1996/09/28  05:20:56  phil
* fix typos from last checkin
*
* Revision 1.51  1996/09/25  07:46:20  phil
* [PLB42] added auto-load; uses pm_prototypes from pml.c
*
* Revision 1.50  1996/09/24  06:45:22  phil
* [PLB41] removed PDLBLK (pm stack); now allocated in init.c
* dropped SPDLDZ back to 5000
*
* Revision 1.49  1996/09/23  04:59:32  phil
* [PLB40] handle tabs in error pointer code
* include file & line in compiler error messages
* use MOVA for &LAST(FILE|LINE), moved FILCHK
*
* Revision 1.48  1996/09/22  05:52:28  phil
* [PLB39] add &PARM, fixed yesterdays pre-checkin typos
*
* Revision 1.47  1996/09/21  07:05:58  phil
* [PLB38] more comment cleanup, fixed comment typos
* don't increment &STCOUNT if &STLIMIT < 0
* 	keep seperate stmt count for stats output
* add errors for bad INCLUDE, INCLUDE open error, missing END
* add &LINE &FILE and -LINE for real source line in errors
* add S4+ CTLADV proc, use for INCLUDE and LINE processing
* put all control card tests in a row
* add &LASTLINE &LASTFILE &ERRTEXT keywords
* changed formats; added file/line to errors
*
* Revision 1.46  1996/09/19  01:02:25  phil
* [PLB37] add REVERSE(), SUBSTR(), LEQ(), LGE(), LLE(), LLT(), LNE()
* from SNOBOL4+ & Minnesota SNOBOL4
*
* Revision 1.45  1996/09/13  03:45:23  phil
* [PLB36] Add TERMINAL I/O variable; flushed PUNCH
*
* Revision 1.44  1996/09/12  00:46:52  phil
* fix sort; edit [PLB31] added one MULTC too many
*
* Revision 1.43  1996/09/09  02:47:33  phil
* [PLB35] only case fold strings in FIELD (fix from SNOBOL4+)
* upped SPLDSZ to 10k for snocone.sno
*
* Revision 1.42  1996/09/07  05:25:55  phil
* [PLB34] FREEZE()/THAW(), new table access code from SNOBOL4+
* added -EXECUTE/-NOEXECUTE control cards
* ran untabify (skipped RCS History)
* moved all [edit] ids to column 64+
* moved SORT to Arrays, Tables etc section
*
* Revision 1.41  1996/09/05  04:32:22  phil
* [PLB33] control card/switch/system variable changes;
*  &STLIMIT < 0 means no limit, default to -1
*  always case fold control card keywords
*  disable stats by default
*  default listing off (was being hit by init.c)
*  removed EXPCL; default SPITCL to on
* fixed SPITBOL ? operator at top level
*
* Revision 1.40  1996/09/04  03:00:06  phil
* [PLB32] Add SPITBOL operators (under -PLUSOPS) from SNOBOL4+
*
* Revision 1.39  1996/09/01  05:12:56  phil
* [PLB31] Add SPITBOL features with code from SNOBOL4+ and Minnesota SNOBOL4;
* CHAR(), RPAD()/LPAD(), BREAKX(), SORT()/RSORT()
*
* Revision 1.38  1996/08/25  01:55:14  phil
* [PLB30] pull CASECL check up out of VPXPTR; saves call if not folding
*
* Revision 1.37  1996/08/20  04:12:59  phil
* [PLB29] added real VARVUP, VPXPTR (Thanks to Mark Emmer)
*
* Revision 1.36  1996/08/08  03:38:01  phil
* [PLB28] changes from 7/28/95!!
* VARVUP (copy of VARVAL for now), and calls to it
*
* Revision 1.35  1995/07/28  18:40:34  phil
* [PLB27] change GNVARC to GENVUP (what it's called in SNOBOL4+ sources)
*
* Revision 1.34  1995/01/06  18:25:37  phil
* [PLB26] 11/3/94 fixed case sensitivity for local variables
*
* Revision 1.33  1994/07/07  15:15:57  budd
* [PLB25] Added FAILG label so FAIL can be inlined
* Another 9% improvement in compile and execution times!
*
* Revision 1.32  94/06/24  14:53:11  budd
* [PLB24] Added RTNL3G label so RTNUL3 can be inlined
* 
* Revision 1.31  94/06/21  02:43:12  budd
* [PLB23] fixed problem reported by Phillip Thomas
* moved XLATNX label so that "card" processing restarts after
* and EOS (semi).  This allows ';*' to be used as an EOL comment
* Also allows control cards after EOS!
* Negative side effect is that listings show the STNO of the *LAST*
* statement on the line, rather than the first, as before!!
* 
* Revision 1.30  94/06/17  16:06:19  budd
* [PLB22] drop CARDSZ down to 132 to make listings managable!
* 
* Revision 1.29  94/06/15  23:33:12  budd
* [PLB21] Upped compiler and default input record (line)
* buffer length from 80 to 1024.
* 
* Revision 1.28  94/06/13  02:25:18  budd
* [PLB20] Implement -COPY/-INCLUDE
* 
* Revision 1.27  94/06/03  12:50:49  budd
* [PLB19] always honor length from STREAD
* otherwise input ends up padded
* 
* Revision 1.26  94/05/29  15:00:35  budd
* [PLB18] Added &LCASE &UCASE
* Fixed a bug in -CASE processing
* Changed ms/stmt output format
* 
* Revision 1.25  94/05/26  01:14:52  budd
* [PLB17] More CASE dependancies
* 
* Revision 1.24  94/05/25  23:28:35  budd
* [PLB16] changed &TRIM default back to 0
* 
* Revision 1.23  94/05/25  02:30:10  budd
* [PLB15] Implemented SPITBOL &CASE/-CASE
* Moved Un*x version messages to version.c
* 
* Revision 1.22  94/05/02  19:03:26  budd
* [PLB14] use %15d formats (were %15i)
* discovered by Jerry Leichter in port to VMS!
* 
* Revision 1.21  94/02/19  00:21:31  budd
* updated date, for *REAL* BETA1!
* 
* Revision 1.20  94/01/25  12:29:29  budd
* BETA1 release
* 
* Revision 1.19  94/01/17  01:54:42  budd
* [PLB13] set RETCOD (exit code) for compilation/runtime errors
* including when execution aborted by -NOERRORS
* 
* Revision 1.18  94/01/09  00:16:03  budd
* default listing side now LEFT
* tweaked SOURCF, UNIXF2
* 
* Revision 1.17  94/01/08  23:37:41  budd
* [PLB12] output UNIXF UNIXF2 at startup
* output error name string to stderr
* implemented -b (BANRCL), -s (STATCL)
* 
* Revision 1.16  94/01/07  17:54:04  budd
* [PLB11] caseifed STRINGS, fixed TIMEPS format
* 
* Revision 1.15  94/01/07  16:23:28  budd
* [PLB10] converted FORMAT strings to printf-style, mixed-case
* 
* Revision 1.14  93/12/09  14:37:00  budd
* ALPHA1 release
* 
* Revision 1.13  93/12/04  23:51:26  budd
* [PLB9] Implemented -ERRORS/-NOERRORS control cards (default -NOERRORS)
* 
* Revision 1.12  93/12/04  00:13:25  budd
* [PLB8] send errors to stderr (via ERRBLK) as well as listing
* 
* Revision 1.11  93/11/23  11:05:43  budd
* [PLB7] upped SPDLSZ to 5000 to run atn.sno
* 
* Revision 1.10  93/11/19  16:32:38  budd
* [PLB6] default &TRIM to 1
* 
* Revision 1.9  93/11/10  20:52:49  phil
* [PLB5] send all termination msgs, stats to stderr (PUNCH)
* 
* Revision 1.8  93/11/10  20:11:08  phil
* [PLB4] added (optional) 4th filename arg to
* INPUT() and OUTPUT() using XOPENI and XOPENO ops.
* Added XECOMP op to tell I/O sys when compile done.
* 
* Revision 1.7  93/11/10  11:12:55  phil
* dropped initial FNLIST user functions back to 10
* 
* Revision 1.6  93/11/10  01:38:50  phil
* [PLB3] send title, attribution and compilation results
* to stderr (PUNCH)
* 
* Revision 1.5  93/11/10  01:28:29  phil
* [PLB2] made space for up to 50 user function at end of FNLIST
* 
* Revision 1.4  93/11/02  13:35:01  phil
* [PLB1] dropped sequence field size (SEQSIZ) to zero!
* 
* Revision 1.3  93/11/02  13:26:11  phil
* Fixed garbled characters near END2 and AERROR
* 
* Revision 1.2  93/11/02  13:25:46  phil
* Added RCS Id and Log keywords
* 
*
       TITLE   'Table of Contents'
*
*
*	       E32 (DECEMBER 18, 1969)				V3.7
*	       UPDATED TO VERSION 3.10, NOV. 1, 1972		V3.10
*
*	       UPDATED TO VERSION 3.11, MAY 19, 1975.		V3.11
*	       RESEQUENCED DECEMBER 20, 1980.			V3.11
*	       Corrected April 10, 1985 (lines 3393 and 5033).
*      1.   Linkage and Equivalences 
*	       Linkage 
*	       Machine Dependent Parameters
*	       Constants 
*	       Equivalences
*	       Data Type Codes 
*      2.   Program Initialization 
*      3.   Compilation and Interpreter Invocation 
*      4.   Support Procedures 
*	       AUGATL
*	       CODSKP
*	       DTREP 
*	       FINDEX
*      5.   Storage Allocation and Regeneration Procedures 
*	       BLOCK 
*	       GENVAR
*	       GNVARI
*	       CONVAR
*	       GNVARS
*	       GC
*	       GCM 
*	       SPLIT 
*      6.   Compilation Procedures 
*	       BINOP 
*	       CMPILE
*	       ELEMNT
*	       EXPR
*	       FORWRD
*	       NEWCRD
*	       TREPUB
*	       UNOP
*      7.   Interpreter Executive and Control Procedures 
*	       BASE
*	       GOTG
*	       GOTL
*	       GOTO
*	       INIT
*	       INTERP
*	       INVOKE
*      8.   Argument Evaluation Procedures 
*	       ARGVAL
*	       EXPVAL
*	       EXPEVL
*	       EVAL
*	       INTVAL
*	       PATVAL
*	       VARVAL
*	       VARVUP
*	       VPXPTR
*	       XYARGS
*      9.   Arithmetic Operations, Predicates and Functions
*	       ADD 
*	       DIV 
*	       EXPOP
*	       MPY 
*	       SUB 
*	       EQ
*	       GE
*	       GT
*	       LE
*	       LT
*	       NE
*	       REMDR 
*	       INTGER
*	       MNS 
*	       PLS 
*      10.   Pattern-Valued Functions and Operations 
*	       ANY 
*	       BREAKX
*	       BREAK 
*	       NOTANY
*	       SPAN
*	       LEN 
*	       POS 
*	       RPOS
*	       RTAB
*	       TAB 
*	       ARBNO 
*	       ATOP (Cursor Position)
*	       NAM (Value Assignment)
*	       DOL
*	       OR
*      11.  Pattern Matching Procedures
*	       SCAN
*	       SJSR (Scan and Replace) 
*	       SCNR (Basic Scanner)
*	       BRKC
*	       BRKX
*	       NNYC
*	       SPNC
*	       ANYC
*	       BRKXF
*	       LNTH
*	       POSI
*	       RPSI
*	       RTB 
*	       TB
*	       ARBN (ARBNO)
*	       FARB (ARB Backup) 
*	       ATP (Cursor Position) 
*	       BAL 
*	       CHR
*	       STAR (Unevaluated Expression) 
*	       DSAR
*	       FNCE
*	       NME (Value Assignment)
*	       ENME
*	       DNME
*	       ENMI (Immediate Value Assignment) 
*	       SUCE (SUCCEED)
*      12.  Defined Functions
*	       DEFINE
*	       DEFFNC (Invoke Defined Function)
*      13.  External Functions 
*	       LOAD
*	       UNLOAD
*	       LNKFNC (Link to External Function)
*      14.  Arrays, Tables, and Defined Data Objects 
*	       ARRAY 
*	       ASSOC (TABLE) 
*	       DATDEF (DATA) 
*	       PROTO 
*	       FREEZE
*	       THAW
*	       ITEM (Array and Table References) 
*	       DEFDAT (Create Data Object) 
*	       FIELD 
*	       RSORT
*	       SSORT
*      15.  Input and Output 
*	       READ (INPUT)
*	       PRINT (OUTPUT)
*	       BKSPCE
*	       ENDFIL
*	       REWIND
*	       SET
*	       DETACH
*	       PUTIN 
*	       PUTOUT
*      16.  Tracing Procedures and Functions 
*	       TRACE 
*	       STOPTR
*	       FENTR (Call Tracing)
*	       FENTR2
*	       KEYTR 
*	       TRPHND (Trace Handler)
*	       VALTR 
*	       FNEXT2
*      17.  Other Operations 
*	       ASGN (=)
*	       CONCAT (Concatenation) 
*	       IND (Indirect Reference)
*	       KEYWRD
*	       LIT 
*	       NAME
*	       NMD (Value Assignment)
*	       STR (Unevaluated Expression)
*      18.  Other Predicates 
*	       DIFFER
*	       FUNCTN
*	       IDENT 
*	       LABEL 
*	       LEQ 
*	       LGE 
*	       LGT 
*	       LLE 
*	       LLT 
*	       LNE 
*	       NEG 
*	       QUES (?)
*	       CHAR
*	       LPAD
*	       RPAD
*      19.  Other Functions
*	       APPLY 
*	       ARG 
*	       LOCAL 
*	       FIELDS
*	       CLEAR 
*	       CMA
*	       COLECT
*	       COPY
*	       CNVRT 
*	       DATE
*	       DT
*	       DMP 
*	       DUMP
*	       DUPL
*	       OPSYN 
*	       RPLACE
*	       REVERS
*	       SIZE
*	       TIME
*	       TRIM
*	       VDIFFR
*      20.  Common Code
*      21.  Termination
*	       END 
*	       FTLEND
*	       SYSCUT
*      22.  Error Handling 
*      23.  Data 
*	       Pair Lists
*	       Data Type Pairs 
*	       Switches
*	       Constants 
*	       Pointers to Patterns
*	       Function Descriptors
*	       Miscellaneous Data
*	       Program Pointers
*	       Pointers to Specifiers
*	       Permanent Pair List Pointers
*	       Specifiers for Compilation
*	       Strings and Specifiers
*	       Character Buffers 
*	       Pointers to Pair Lists
*	       Scratch Descriptors 
*	       System Descriptors
*	       Compiler Descriptors
*	       Data Pointers 
*	       Specifiers
*	       Allocator Data
*	       Machine Dependent Data
*	       Function Table
*	       Function Pair List
*	       Function Initialization Data
*	       Pointers to Initialization Data 
*	       System Arrays 
*	       String Storage Bin List 
*	       Pattern-Matching History List 
*	       System Stack
*	       Primitive Patterns
*	       Code Skeleton for TRACE 
*	       Fatal Error Message Pointers
*	       Fatal Error Messages
*	       Compiler Error Messages 
*	       Formats 
*
       TITLE   'Linkage and Equivalences'
       COPY    MLINK		   Linkage segment
       COPY    PARMS		   Machine-dependent parameters
*
*      Constants
*
ATTRIB EQU     2*DESCR		   Offset of label in string structure
LNKFLD EQU     3*DESCR		   Offset of link in string structure
BCDFLD EQU     4*DESCR		   Offset of string in string structure
FATHER EQU     DESCR		   Offset of father in code node
LSON   EQU     2*DESCR		   Offset of left son in code node
RSIB   EQU     3*DESCR		   Offset of right sibling in code node
CODE   EQU     4*DESCR		   Offset of code in code node
ESASIZ EQU     50		   Limit on number of syntactic errors
FBLKSZ EQU     10*DESCR		   Size of function descriptor block
ARRLEN EQU     20		   Limit on length of array print image
CARDSZ EQU     1024		   Width of compiler input	[PLB21][PLB57]
STNOSZ EQU     8		   Length of statement number field
DSTSZ  EQU     2*STNOSZ		   Space for left and right numbering
CNODSZ EQU     4*DESCR		   Size of code node
DATSIZ EQU     1000		   Limit on number of defined data type
EXTSIZ EQU     10		   Default allocation for tables
NAMLSZ EQU     20		   Growth quantum for name list
NODESZ EQU     3*DESCR		   Size of pattern node
OBSFT  EQU     13		   Power of two for bin headers		[PLB75]
OBSIZ  EQU     1<<OBSFT		   Number of bin headers 		[PLB75]
OBARY  EQU     OBSIZ+3		   Total number for bins
OCASIZ EQU     1500		   Descriptors of initial object code
SPDLSZ EQU     8000		   Descriptors of pattern stack        [PLB104]
STSIZE EQU     4000		   Descriptors of interpreter stack    [PLB104]
SPDR   EQU     SPEC+DESCR	   Descriptor plus specifier
OBOFF  EQU     OBSIZ-2		   Offset length in bins
*
*      Equivalences
*
ARYTYP EQU     7		   Array reference
CLNTYP EQU     5		   Goto field
CMATYP EQU     2		   Comma
CMTTYP EQU     2		   Comment card
CNTTYP EQU     4		   Continue card
CTLTYP EQU     3		   Control card
DIMTYP EQU     1		   Dimension separator
EOSTYP EQU     6		   End of statement
EQTYP  EQU     4		   Equal sign
FGOTYP EQU     3		   Failure goto
FTOTYP EQU     6		   Failure direct goto
FLITYP EQU     6		   Literal real
FNCTYP EQU     5		   Function call
ILITYP EQU     2		   Literal integer
LPTYP  EQU     1		   Left parenthesis
NBTYP  EQU     1		   Nonbreak character
NEWTYP EQU     1		   New statement
NSTTYP EQU     4		   Parenthesized expression
QLITYP EQU     1		   Quoted literal
RBTYP  EQU     7		   Right bracket
RPTYP  EQU     3		   Right parenthesis
SGOTYP EQU     2		   Success goto
STOTYP EQU     5		   Success direct goto
UGOTYP EQU     1		   Unconditional goto
UTOTYP EQU     4		   Unconditional direct goto
VARTYP EQU     3		   Variable
*
*      Data type Codes
*
A      EQU     4		   ARRAY
B      EQU     2		   BLOCK (internal)
C      EQU     8		   CODE
E      EQU     11		   EXPRESSION
I      EQU     6		   INTEGER
K      EQU     10		   KEYWORD (NAME)
L      EQU     12		   LINKED STRING (internal)
N      EQU     9		   NAME
P      EQU     3		   PATTERN
R      EQU     7		   REAL
S      EQU     1		   STRING
T      EQU     5		   TABLE
BL     EQU     20		   BLOCK			[BLOCKS]
DATSTA EQU     100		   First user datatpe		[PLB31]
*
* [PLB65] pattern matching function indexes (see PATBRA);
XANYC   EQU    1
XARBF   EQU    2
XARBN   EQU    3
XATP    EQU    4
XCHR    EQU    5
XBAL    EQU    6
XBALF   EQU    7
XBRKC   EQU    8
XBRKX   EQU    9
XBRKXF  EQU    10
XDNME   EQU    11
XDNME1  EQU    12
XEARB   EQU    13
XDSAR   EQU    14
XENME   EQU    15
XENMI   EQU    16
XFARB   EQU    17
XFNME   EQU    18
XLNTH   EQU    19
XNME    EQU    20
XNNYC   EQU    21
XONAR   EQU    22
XONRF   EQU    23
XPOSI   EQU    24
XRPSI   EQU    25
XRTB    EQU    26
XFAIL   EQU    27
XSALF   EQU    28
XSCOK   EQU    29
XSCON   EQU    30
XSPNC   EQU    31
XSTAR   EQU    32
XTB     EQU    33
XRTNL3  EQU    34
XFNCE   EQU    35
XSUCF   EQU    36
*---------------------------------------------------------------------*
       TITLE   'Program Initialization'
BEGIN  INIT    ,		   Initialize system
       ISTACK  ,		   Initialize stack
       AEQLC   BANRCL,0,,NOBANR	   Check if banner suppressed	[PLB12]
       OUTPUT  PUNCH,TITLEF	   Title listing		[PLB3]
.IF BLOCKS
       OUTPUT  PUNCH,TITLEF1	   BLOCKS version		[BLOCKS]
.FI
       OUTPUT  PUNCH,SOURCF	   Print attribution		[PLB3]
NOBANR LHERE			   here after banner		[PLB12]
       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
       PCOMP   INITB,INITE,,,INITD1
*				   Compare with end		[PLB88]
       XCALLC  GETPARM,(XSP)	   Get user parameters		[PLB39][PLB86]
       RCALL   PARMVL,GENVAR,XSPPTR				[PLB39]
*				   Convert to string for &PARM	[PLB39]
*
       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,7*DESCR	   Leave room for overflow	[PLB38]
       SETAC   INICOM,1		   SIGNAL COMPLETION		E3.10.6
       XCALLC  IO_FILE,(UNIT,XSP)  Get initial filename		[PLB38][PLB86]
       RCALL   FILENM,GENVAR,(XSPPTR)				[PLB38]
*
* spin through list of functions to auto-load
       SETAC   TMVAL,0		   Loop index			[PLB42]
AUTLOP XCALLC  GETPMPROTO,(XSP,TMVAL),XLATRN			[PLB44][PLB86]
*				   Get next prototype specifier	[PLB44]
       RCALL   XPTR,GENVAR,(XSPPTR)				[PLB42]
*				   Get prototype string in XPTR	[PLB42]
       MOVD    WPTR,NULVCL	   Get null string (library)	[PLB42]
       INCRA   ERRLCL,1		   Make sure &ERRLIMIT nonzero	[PLB42]
       RCALL   ,LOAD2		   Call into LOAD		[PLB42]
       SETAC   ERRLCL,0		   Clear &ERRLIMIT		[PLB42]
       INCRA   TMVAL,1		   Next!			[PLB42]
       BRANCH  AUTLOP		   Go back, jack		[PLB42]
*_
*---------------------------------------------------------------------*
       TITLE   'Compilation and Interpreter Invocation'
XLATRD AEQLC   LISTCL,0,,XLATRN	   Skip print if list is off
       STPRNT  IOKEY,OUTBLK,LNBFSP Print line image
XLATRN SETSP   TEXTSP,NEXTSP	   Read card and set up line	[PLB61]
       STREAD  TEXTSP,UNIT,XLATIN,COMP1				[PLB38][PLB61]
       GETLG   TMVAL,TEXTSP	   Get line length		[PLB62]
       INCRA   TMVAL,STNOSZ	   Add sequence number length	[PLB62]
       PUTLG   LNBFSP,TMVAL	   Save for listings		[PLB62]
       INCRA   LNNOCL,1		   Increment source line number	[PLB38]
XLATNX STREAM  XSP,TEXTSP,CARDTB,COMP3,XLATRD			[PLB50]
*				   Determine type of card	[PLB23]
       RCALL   ,NEWCRD,,(XLATRD,,) Process card type
       RCALL   ,CMPILE,,(COMP3,,XLATNX)
*				   Compile statement		[PLB23]
       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,GENVUP,(XSPPTR)
*				   Generate variable for label	[PLB15][PLB27]
       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?
       OUTPUT  PUNCH,ERRCF	   Print message of errors	[PLB3]
       AEQLC   NERRCL,0,,XLATND	   execute if -NOERROR clear	[PLB9][PLB13]
       SETAC   RETCOD,1		   set exit code (use EQU???)	[PLB13]
       BRANCH  FTLEN2		   join endgame			[PLB13]
*_
XLATIN RCALL   ,FILCHK		   Pick up file change		[PLB38]
       BRANCH  XLATRN		   Try reading again		[PLB38]
*_
XLATSC AEQLC   BANRCL,0,,XLATND	   Suppress message if no banner [PLB12]
       OUTPUT  PUNCH,SUCCF	   Print message if no errors	[PLB3]
XLATND AEQLC   EXECCL,0,,END	   Just compile? Quiting time!	[PLB34]
       XECOMP  ,		   Tell I/O system compile done	[PLB4]
       SETAC   UNIT,0		   Reset input unit
       SETAC   LPTR,0		   Reset last label pointer
       SETAC   OCLIM,0		   Reset limit on object code
       SETAC   LNNOCL,0		   Reset source line number	[PLB38]
       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
       SETAC   COMPCL,0		   Turn off error listings	[PLB49]
       MSTIME  ETMCL		   Time out compiler
       SBREAL  TIMECL,ETMCL,TIMECL Compute elapsed time		[PLB71]
       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
       DECRA   A4PTR,DESCR	   Adjust size			[PLB82]
       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
       LOCSP   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
*_
DTABLE GETSIZ  A3PTR,A2PTR					E3.2.3
       GETD    A1PTR,A2PTR,A3PTR				E3.2.3
       DECRA   A3PTR,DESCR					E3.2.3
       GETD    A2PTR,A2PTR,A3PTR				E3.2.3
DTABL1 AEQLC   A1PTR,1,,DTABL2					E3.2.3
       SUM     A3PTR,A3PTR,A2PTR				E3.2.3
       DECRA   A3PTR,2*DESCR					E3.2.3
       GETD    A1PTR,A1PTR,A2PTR				E3.2.3
       BRANCH  DTABL1						E3.2.3
*_								E3.2.3
DTABL2 DECRA   A3PTR,DESCR					E3.2.3
       DECRA   A2PTR,2*DESCR					E3.2.3
       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
       DIVIDE  A2PTR,A2PTR,DSCRTW				E3.2.3
       INTSPC  ZSP,A2PTR					E3.2.3
       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
       LOCSP   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 Regeneration 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
       PCOMP   TLSGP1,FRSGPT,,,BLOGC				[PLB125]
*				   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
       LOCSP   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
       PCOMP   TLSGP1,FRSGPT,,,LOCA4				[PLB125]
*				   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
       LOCSP   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
*_
*---------------------------------------------------------------------*
*
* New [PLB15]
*      Generation of Variable or Label, honoring &CASE
*
GENVUP PROC    GENVAR		   Procedure to generate string
       AEQLC   CASECL,0,,GENVAR	   Skip out if case sensitve
       POP     AXPTR		   Restore pointer to specifier
       PUSH    AXPTR		   Put it back
       GETSPC  SPECR1,AXPTR,0	   Get specifier
       XRAISP  SPECR1		   Force to upper case
       BRANCH  GENVAR		   Join regular 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
       MOVA    BKLTCL,FRSGPT					E3.3.2
       RRTURN  BKLTCL,1						E3.3.2
*_
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
       LOCSP   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
       MSTIME  GCTMCL		   Time of GC start		[PLB92]
       XCALLC  vm_gc_advise,(1)	   Advise GC memory behavior	[PLB54]
       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  PCOMP   BKPTR,OBEND,GCLAD   Check for end of bins	[PLB88]
       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  PCOMP   BKPTR,OBEND,GCLAP   Check for end of bins	[PLB88]
       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?
       PCOMP   DESCL,MVSGPT,,,GCLAP4				[PLB88]
*				   Is it above compression barrier?
       TOP     TOPCL,OFSET,DESCL   Compute offset to target
       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?
       PCOMP   DESCL,MVSGPT,,,GCLAT3				[PLB88]
*				   Is it above compression barrier?
       TOP     TOPCL,OFSET,DESCL   Compute offset to target
       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
       PCOMP   TTLCL,MVSGPT,GCLAM5,GCLAM5			[PLB88]
*				   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
       XCALLC  vm_gc_advise,(0)	   Advise normal memory behavior [PLB54]
       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
       RESETF  FRSGPT,FNC	   Clear possible function flag
       SUBTRT  GCGOT,TLSGP1,FRSGPT Compute amount reclaimed
       DECRA   GCGOT,DESCR
       RESETF  GCGOT,PTR	   Clear pointer flag
       MSTIME  TEMPCL		   Time for end of GC		[PLB92][PLB93]
       SBREAL  TEMPCL,TEMPCL,GCTMCL Compute elapsed time in GC	[PLB92][PLB93]
       ADREAL  GCTTTL,GCTTTL,TEMPCL Compute total time in GC	[PLB92][PLB93]
       ACOMPC  GCTRCL,0,,NOGCTR,GCTRC
*				   Check &GTRACE		[PLB92][PLB94]
       DECRA   GCTRCL,1		   Decrement &GTRACE		[PLB94]
GCTRC  OUTPUT  PUNCH,GCFMT,(FILENM,LNNOCL,TEMPCL,GCGOT)
*				   GC trace			[PLB92][PLB93]
NOGCTR ACOMP   GCREQ,GCGOT,FAIL	   Compare with amount required
       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,EQTYP,,BINOP2				[PLB32]
*				   Embedded ='s			[PLB32]
BINOP4 AEQLC   BRTYPE,NBTYP,RTN2   If so, fail on break		[PLB32]
       AEQLC   SPITCL,0,BINOP5	   Jump if SPITBOL ops enabled	[PLB32]
.IF BLOCKS
       AEQLC   BLOKCL,0,BINOP7	   Jump if BLOCKS enabled	[PLB117]
.FI
       STREAM  XSP,TEXTSP,BIOPTB,BINCON
BINOP3 MOVD    ZPTR,STYPE	   Move function descriptor	[PLB32]
       BRANCH  RTZPTR		   Return function descriptor
*_
BINOP2 AEQLC   SPITCL,0,,BINOP4	   Jump if no SPITBOL ops	[PLB32]
       SETAC   STYPE,BIEQFN					[PLB32]
       BRANCH  BINOP3						[PLB32]
*_
BINOP1 RCALL   ,FORWRD,,COMP3	   If no blank, find character
       SELBRA  BRTYPE,(,RTN2,RTN2,,,RTN2,RTN2)
       SETAC   EMSGCL,ILLBIN	   Set up error message		[PLB82]
       BRANCH  RTN1		   Take error return
*_
BINCON MOVD    ZPTR,CONCL	   No operator, concatenation
       BRANCH  RTZPTR		   Return function descriptor
*_
* Here for SPITBOL ops
BINOP5 LHERE
.IF BLOCKS
       AEQLC   BLOKCL,0,BINOP6	   Jump if BLOCKS enabled	[PLB117]
.FI
       STREAM  XSP,TEXTSP,SBIPTB,BINCON				[PLB32]
*				   Use special SPITBOL table	[PLB32]
       BRANCH  BINOP3		   Rejoin regular program	[PLB32]
*_
.IF BLOCKS
* Here for SPITBOL ops + BLOCKS!!
BINOP6 STREAM  XSP,TEXTSP,BSBIPTB,BINCON			[PLB117]
*				   Use SPITBOL + BLOCKS table	[PLB117]
       BRANCH  BINOP3		   Rejoin regular program	[PLB117]
*_
* BLOCKS, but no SPITBOL ops
BINOP7 STREAM  XSP,TEXTSP,BBIOPTB,BINCON			[PLB117]
*				   Use special BLOCKS table	[PLB117]
       BRANCH  BINOP3		   Rejoin regular program	[PLB117]
*_
.FI
*---------------------------------------------------------------------*
*
*      Statement Compilation
*
CMPILE PROC    ,		   Procedure to compile statement
       SETAC   BRTYPE,0		   Clear break indicator
       MOVD    BOSCL,CMOFCL	   Set statement beginning offset
       AEQLC   HIDECL,0,CMPIL0	   Don't increment stno if hidden [PLB102]
       INCRA   CSTNCL,1		   Increment statement number
CMPIL0 STREAM  XSP,TEXTSP,LBLTB,CERR1				[PLB102]
*				   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
       PCOMP   CMBSCL,OCLIM,,,CMPILO
*				   Check for end of object code	[PLB88]
       RCALL   XCL,BLOCK,CODELT	   Get block for more
       PUTDC   CMBSCL,0,GOTGCL	   Replace BASE with direct goto
       PUTDC   CMBSCL,DESCR,LIT1CL				E3.7.1
       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,7*DESCR	   Leave safety factor		[PLB38]
       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,GENVUP,XSPPTR  Get variable for label	[PLB15][PLB27]
       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 found?
       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
       INCRA   CMOFCL,DESCR	   Increment offset		[PLB38]
       PUTD    CMBSCL,CMOFCL,LNNOCL				[PLB38]
*				   Store line number		[PLB38]
       INCRA   CMOFCL,DESCR	   Increment offset		[PLB38]
       PUTD    CMBSCL,CMOFCL,FILENM				[PLB38]
*				   Store file name		[PLB38]
       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,CMPSB1 Check for nonbreak		[PLB32]
       AEQLC   SPITCL,0,,CMPAT2	   Jump if no SPITBOL ops	[PLB32]
%{
	/* Sigh; this was in assembler in SNOBOL4+		[PLB32] */
	register char *cp;		/*			[PLB33] */
	cp = S_SP(TEXTSP);		/*			[PLB33] */
	if (*cp == '?' &&		/* is break char '?'	[PLB32] */
	    (S_L(TEXTSP) == 1 ||	/* yes; is last char?	[PLB32] */
	     cp[1] == ' ' || cp[1] == '\t')) { /* or next is white? [PLB33] */
	    S_O(TEXTSP)++;		/* binary ? found.	[PLB32] */
	    S_L(TEXTSP)--;		/* remove from TEXTSP	[PLB32] */
	}				/*			[PLB32] */
%}
       BRANCH  CMPATN						[PLB32]
*_
CMPSB1 AEQLC   BRTYPE,EQTYP,,CMPFRM				[PLB32]
*				   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   EXOPND,BLOCK,CNDSIZ Build tree with SCAN op	[PLB32]
       PUTDC   EXOPND,CODE,SCANCL				[PLB32]
       PUTVC   EXOPND,CODE,ZEROCL  Let ADDSON count nodes	[PLB32]
       ADDSON  EXOPND,SUBJND
       MOVD    EXPRND,SUBJND
       RCALL   PATND,EXPR1,,(CDIAG,CMPAT1)
*				   Compile pattern as right node [PLB32]
*_
CMPAT2 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
CMPAT1 RCALL   ,TREPUB,(PATND)	   Copy pattern into object code [PLB32]
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
       SETVC   CSTNCL,I		   Restore type for &COMPNO	[PLB123]
       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
       SETVC   CSTNCL,I		   Restore type for &COMPNO	[PLB123]
       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
       SETVC   CSTNCL,I		   Restore type for &COMPNO	[PLB123]
       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
       SETVC   CSTNCL,I		   Restore type for &COMPNO	[PLB123]
       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
       SETVC   CSTNCL,I		   Restore type for &COMPNO	[PLB123]
       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
       INCRA   BOSCL,DESCR	   Increment offset		[PLB38]
       PUTD    CMBSCL,BOSCL,LNNOCL Insert line number		[PLB38]
       INCRA   BOSCL,DESCR	   Increment offset		[PLB38]
       PUTD    CMBSCL,BOSCL,FILENM Insert file name		[PLB38]
       MOVD    CMOFCL,BOSCL	   Reposition offset
       INCRA   ESAICL,DESCR	   Increment count of errors
       ACOMP   ESAICL,ESALIM,COMP9 Test for excessive errors
       ACOMPC  COMPCL,0,,CDIAG4	   Done compiling? Skip this	[PLB49]
%{
	char *sp, *dp;		/* src ptr, desr ptr		[PLB40] */
	int len;		/* src char count		[PLB40] */
	sp = INBUF + STNOSZ;	/* get start of statement buffer [PLB40] */
	len = S_O(TEXTSP);	/* number of spaces/tabs to skip [PLB77] */
	S_L(ERRSP) = len + 1;	/* set pointer line length	[PLB77] */
	dp = ERRBUF + STNOSZ;	/* get start of marker buffer	[PLB40] */
	while (len-- > STNOSZ) { /* for all chars in statement	[PLB77] */
	    if (*sp++ == '\t')	/* if tab			[PLB77] */
		*dp++ = '\t';	/*	put tab in errbuf	[PLB40] */
	    else		/* else				[PLB40] */
		*dp++ = ' ';	/*	put space		[PLB40] */
	}			/*				[PLB40] */
	*dp++ = '^';		/* store pointer		[PLB40] */
%}
       STPRNT  IOKEY,ERRBLK,LNBFSP Print statement to stderr	[PLB8]
       STPRNT  IOKEY,ERRBLK,ERRSP  Print error marker to stderr	[PLB8]
       AEQLC   LISTCL,0,,CDIAG2	   Check for listing mode	[PLB8]
       STPRNT  IOKEY,OUTBLK,LNBFSP Print statement
       STPRNT  IOKEY,OUTBLK,ERRSP  Print error marker
CDIAG2 GETSPC  TSP,EMSGCL,0	   Get error message		[PLB40]
       SETLC   CERRSP,0		   Clear specifier
       LOCSP   XSP,FILENM	   Get specifier for filename	[PLB40]
       APDSP   CERRSP,XSP	   Append filename		[PLB40]
       APDSP   CERRSP,COLSP	   Append colon			[PLB40]
       INTSPC  XSP,LNNOCL	   Get specifer for line number	[PLB40]
       APDSP   CERRSP,XSP	   Append line number		[PLB40]
       APDSP   CERRSP,COLSP	   Append colon			[PLB40]
       APDSP   CERRSP,SPCSP	   Append space			[PLB95]
       APDSP   CERRSP,STARSP	   Append attention getter
       APDSP   CERRSP,TSP	   Append error message
       AEQLC   LISTCL,0,,CDIAG1	   Check for listing mode	[PLB8]
       STPRNT  IOKEY,OUTBLK,CERRSP Print error message
       STPRNT  IOKEY,OUTBLK,BLSP   Print blank line
CDIAG1 STPRNT  IOKEY,ERRBLK,CERRSP Print error message to stderr [PLB8]
       STPRNT  IOKEY,ERRBLK,BLSP   Print blank line to stderr	[PLB8]
CDIAG4 RCALL   ERRTXT,GENVAR,EMSGCL				[PLB49]
*				   Generate &ERRTEXT value	[PLB49]
       AEQLC   UNIT,0,,RTN1					E3.0.1
       AEQLC   BRTYPE,EOSTYP,,RTN3				E3.0.1
       STREAM  XSP,TEXTSP,EOSTB,COMP3,,RTN3
*				   Get to end of statement
DIAGRN SETSP   TEXTSP,NEXTSP	   Set up new line		[PLB61]
       STREAD  TEXTSP,UNIT,DIAGIN,COMP1				[PLB38][PLB61]
*				   Read card image
       GETLG   TMVAL,TEXTSP	   Get line length		[PLB62]
       INCRA   TMVAL,STNOSZ	   Add sequence number length	[PLB62]
       PUTLG   LNBFSP,TMVAL	   Save for listings		[PLB62]
       INCRA   LNNOCL,1		   Count line numbers		[PLB38]
       STREAM  XSP,TEXTSP,CARDTB,COMP3,CDIAG7			[PLB50]
*				   Analyze card type
       RCALL   ,NEWCRD,,(,,RTN3)   Process card image
CDIAG7 AEQLC   LISTCL,0,,DIAGRN					[PLB50]
       STPRNT  IOKEY,OUTBLK,LNBFSP Print out bypassed card
       BRANCH  DIAGRN
*_
DIAGIN RCALL   ,FILCHK		   Pick up file change		[PLB38]
       BRANCH  DIAGRN		   Try reading again		[PLB38]
*_
*---------------------------------------------------------------------*
*
*      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,,ELEM10				[PLB32]
*				   Is pointer at top of tree?
       GETDC   ZPTR,ZPTR,FATHER	   Move back to father
       BRANCH  ELEMRR		   Continue up tree
*_
* [PLB32]
* Here with ZPTR pointing to top of tree.  Peek ahead for a "<" or "["
* immediately following this element.  If found, take the entire tree
* so far, and make it the first argument of yet another item function.
* Note that we needn't look ahead to a continuation line if out of
* characters on this line -- the implicit blank with a continuation
* disqualifies the ELEMENT<> construction.
*
ELEM10 STREAM  XSP,TEXTSP,GOTSTB,RTZPTR,RTZPTR,			[PLB32]
*				   Examine next character	[PLB32]
       AEQLC   STYPE,SGOTYP,,ELECMA  Error if ELEMENT-PAREN	[PLB77]
       MOVD    ELEMND,ZEROCL	   Clear top of tree pointer	[PLB32]
       MOVD    ELEXND,ZPTR	   Existing tree becomes ITEM's 1st arg [PLB32]
       BRANCH  ELEAR2		   Build ITEM function		[PLB32]
*_
ELEILT SPCINT  XPTR,XSP,ELEINT,ELEMN5
*				   Convert string to integer
*_
ELEFLT SPREAL  XPTR,XSP,ELEDEC,ELEMN5
*				   Convert string to real
*_
ELEVBL RCALL   XPTR,GENVUP,(XSPPTR)
*				   Generate variable		[PLB15][PLB27]
       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,,ELEMN1
*				   Simple (exp) if right paren	[PLB32]
       AEQLC   SPITCL,0,,ELECMA	   Jump if no SPITBOL ops	[PLB32]
       AEQLC   BRTYPE,CMATYP,ELECMA				[PLB32]
*				   Error if not e1,		[PLB32]
       RCALL   ,ELEARG,CMACL,RTN1  Process list for CMA function [PLB32]
       AEQLC   BRTYPE,RPTYP,ELECMA,ELEMNR			[PLB32]
*				   List must end with RP	[PLB32]
*_
ELEFNC SHORTN  XSP,1		   Delete open parenthesis
       RCALL   XPTR,GENVUP,(XSPPTR)
*				   Generate var for function nm	[PLB17][PLB27]
       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,GENVUP,(XSPPTR)
*				   Generate variable for array or table
*								[PLB17][PLB27]
       RCALL   ELEXND,BLOCK,CNDSIZ Allocate block for tree node
       PUTDC   ELEXND,CODE,XPTR	   Insert ITEM function (?)
ELEAR2 RCALL   ,ELEARG,ITEMCL,RTN1 Process list for ITEM function [PLB32]
       AEQLC   BRTYPE,RBTYP,ELECMA,ELEMNR			[PLB32]
*				   list must end with right bracket [PLB32]
*_
*---------------------------------------------------------------------*
*
* New [PLB32] from SNOBOL4+
* Process list of args for selection (comma) function and array reference.
*
* Call;
* ELEXND = First argument code node
*      RCALL   ,ELEARG,function code word,(fail,OK))
*
* Returns;
* BRTYPE = ending char type
* ELEMND = current node
*
ELEARG PROC    ,
       POP     XCL		   Get function
       RCALL   XPTR,BLOCK,CNDSIZ,  Get function node
       PUTDC   XPTR,CODE,XCL	   Set function in it
       AEQLC   ELEMND,0,,ELEMN8	   Anything above
       ADDSON  ELEMND,XPTR	   Yes, make function node its son
ELEMN8 ADDSON  XPTR,ELEXND	   Make first arg function node's son
       MOVD    ELEMND,ELEXND	   Make first arg current node
ELEAR1 PUSH    ELEMND		   Save current
       RCALL   ELEXND,EXPR,,RTN1   Get next arg
       POP     ELEMND		   Restore current
       ADDSIB  ELEMND,ELEXND	   Make next arg current's sibling
       MOVD    ELEMND,ELEXND	   Next arg becomes current
       AEQLC   BRTYPE,CMATYP,RTN2,ELEAR1
*				   Verify comma
*_
ELEICH SETAC   EMSGCL,ILCHAR	   'ILLEGAL CHARACTER IN ELEMENT'
       BRANCH  RTN1		   Error return
*_
ELEILI AEQLC   STYPE,0,,ELEICH	   Protect against runout	[PLB50]
       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
* [PLB32] played with ordering to appease gendep
*
EXPR   PROC    ,		   Procedure to compile expression
       RCALL   EXELND,ELEMNT,,(RTN1,EXPNUL)
*				   Compile element
       SETAC   EXPRND,0		   Zero expression tree
       BRANCH  EXPR2		   Join main processing
*_
EXPNUL RCALL   XPTR,NULNOD,,RTXNAM Return null string		[PLB32]
*_
EXPR1  PROC    ,						[PLB32]
       PUSH    EXPRND		   Save expression tree
       RCALL   EXELND,ELEMNT,,(RTN1,EXPR12)			[PLB32]
*				   Compile element
       POP     EXPRND		   Restore expression tree
       BRANCH  EXPR2		   Contortion to appease gendep	[PLB32]
*_
* Here when right operand of binary operator was missing	[PLB32]
EXPR12 AEQLC   SPITCL,0,,EXPERR	   Error if no SPITBOL ops	[PLB32]
       AEQLIC  EXOPND,CODE,BISRFN,,EXPR17			[PLB32]
*				   Was op Scan and Replace?	[PLB32]
       AEQLIC  EXOPND,CODE,BIEQFN,EXPERR			[PLB32]
*				   No, Was op assignment?	[PLB32]
EXPR17 RCALL   EXELND,NULNOD,,EXPR13				[PLB32]
*				   Yes, default null string operand [PLB32]
*_
EXPR13 POP     EXPRND						[PLB32]
       BRANCH  EXPR7						[PLB32]
*_
EXPERR SETAC   EMSGCL,ILLEOS	   'ILLEGAL END OF STATEMENT'
       BRANCH  RTN1		   Take error return
*_
EXPR2  RCALL   EXOPCL,BINOP,,(RTN1,EXPR7)
*				   Get binary operator
       AEQLC   SPITCL,0,,EXPR14	   SPITBOL ops?			[PLB32]
       AEQL    EXOPCL,ASGNCL,EXPR14				[PLB32]
* [PLB32] SPITBOL Assignment must be checked for previous SCAN operator;
* If SCAN found, convert to SJSR
       AEQLC   EXPRND,0,,EXPR14					[PLB32]
       MOVD    EXOPND,EXPRND					[PLB32]
EXPR15 MOVD    EXEXND,EXOPND					[PLB32]
       AEQLIC  EXEXND,FATHER,0,,EXPR14				[PLB32]
*				   Does this node have a father? [PLB32]
       GETDC   EXOPND,EXEXND,FATHER				[PLB32]
*				   Yes, get to it		[PLB32]
       AEQLIC  EXOPND,CODE,BISNFN,EXPR15			[PLB32]
*				   Father SCAN?			[PLB32]
       PUTAC   EXOPND,CODE,SJSRCL  Convert SCAN to SJSR		[PLB32]
       ADDSIB  EXPRND,EXELND	   Unload current node		[PLB32]
       MOVD    EXPRND,EXELND	   Move to middle sub-tree	[PLB32]
EXPR16 GETDC   EXOPND,EXPRND,FATHER				[PLB32]
*				   Ascend to top of tree	[PLB32]
       AEQLIC  EXOPND,FATHER,0,,EXPR1				[PLB32]
*				   Process statement object	[PLB32]
       MOVD    EXPRND,EXOPND	   Keep going up		[PLB32]
       BRANCH  EXPR16						[PLB32]
*_
EXPR14 RCALL   EXOPND,BLOCK,CNDSIZ Allocate block for tree node	[PLB32]
       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
*_
EXPR11 ADDSON  EXOPND,EXPRND	   Add node as son
       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
*_
*---------------------------------------------------------------------*
*
* New [PLB32] from EXPNUL
* Subroutine to build lit op with null string arg
NULNOD PROC    ,
       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
       RRTURN  EXPRND,1		   Return			[PLB32]
*_
*---------------------------------------------------------------------*
*
*      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 PROC							[PLB82]
FORRN0 AEQLC   UNIT,0,,FOREOS	   Check for input stream	[PLB82]
       AEQLC   LISTCL,0,,FORRUR	   Check listing switch
       STPRNT  IOKEY,OUTBLK,LNBFSP Print card image
FORRUR SETSP   TEXTSP,NEXTSP	   Set up new line		[PLB61]
       STREAD  TEXTSP,UNIT,FORINC,COMP1				[PLB38][PLB61]
*				   Read new card iamge
       GETLG   TMVAL,TEXTSP	   Get line length		[PLB62]
       INCRA   TMVAL,STNOSZ	   Add sequence number length	[PLB62]
       PUTLG   LNBFSP,TMVAL	   Save for listings		[PLB62]
       INCRA   LNNOCL,1		   Count line numbers		[PLB38]
       STREAM  XSP,TEXTSP,CARDTB,COMP3,FORRN0			[PLB50][PLB82]
*				   Determine card type
       RCALL   ,NEWCRD,,(FORRN0,FORWRD)				[PLB82]
*				   Process new card
FOREOS MOVD    BRTYPE,EOSCL	   Set up end-of-card
       BRANCH  RTN2		   Return
*_
FORINC RCALL   ,FILCHK		   Pick up file change		[PLB38]
       BRANCH  FORRUR		   Try reading again		[PLB38]
*_
FORBLK PROC    FORWRD		   Procedure to get to nonblank
       STREAM  XSP,TEXTSP,IBLKTB,RTN1,FORRUN,FORJRN
*				   Break out nonblank from blank
*_
*---------------------------------------------------------------------*
*
* New [PLB38] from SNOBOL4+ INCCK
* Here on STREAD EOF while compiling.
*
* Takes return 1 if premature EOF (changed files)
* Takes return 2 if popped out of an include file.
*
FILCHK PROC    ,
       AEQLC   INCSTK,0,,FILCK2	   Premature EOF if not INCLUDE
       GETDC   LNNOCL,INCSTK,2*DESCR
*				   Restore old line number
       GETDC   FILENM,INCSTK,3*DESCR
*				   Restore old file name
       GETDC   INCSTK,INCSTK,DESCR Pop stack
       BRANCH  RTN2		   Return happy
*_
* here when EOF and not in an include file; query I/O system
FILCK2 XCALLC  IO_FILE,(UNIT,XSP),RTN1
       RCALL   FILENM,GENVAR,(XSPPTR)
       SETAC   LNNOCL,0
       BRANCH  RTN1
*_
*---------------------------------------------------------------------*
*
*      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
       XCALLC  IO_PAD,(LNBFSP,CARDSZ+DSTSZ)			[PLB63][PLB86]
*				   Pad line with spaces			[PLB63]
       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
       XCALLC  IO_PAD,(LNBFSP,CARDSZ+DSTSZ)			[PLB63][PLB86]
*				   Pad line with spaces			[PLB63]
       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
       XRAISP  XSP		   Raise before compare		[PLB15][PLB33]
* I'm tired of making up CTLCxx labels; do compares here at top	[PLB38]
       LEXCMP  XSP,UNLSP,,UNLIST   Is it UNLIST?		[PLB38]
       LEXCMP  XSP,LISTSP,,LIST	   Is it LIST?			[PLB38]
       LEXCMP  XSP,EJCTSP,,EJECT   Is it EJECT?			[PLB38]
       LEXCMP  XSP,ERORSP,,ERRORS  Is it ERRORS?		[PLB9][PLB38]
       LEXCMP  XSP,NERRSP,,NOERRS  Is it NOERRORS?		[PLB9][PLB38]
       LEXCMP  XSP,CASESP,,CASE	   Is it CASE?			[PLB15][PLB38]
       LEXCMP  XSP,INCLSP,,INCLUD  Is it INCLUDE?		[PLB20][PLB38]
       LEXCMP  XSP,COPYSP,,INCLUD  Is it COPY?			[PLB20][PLB38]
       LEXCMP  XSP,SPITSP,,PLSOPS  Is it PLUSOPS?		[PLB32][PLB38]
       LEXCMP  XSP,EXECSP,,EXEC	   Is it EXECUTE?		[PLB34][PLB38]
       LEXCMP  XSP,NEXESP,,NOEXEC  Is it NOEXECUTE?		[PLB34][PLB38]
       LEXCMP  XSP,LINESP,,LINE	   Is it LINE?			[PLB38]
       LEXCMP  XSP,HIDESP,,HIDE    Is it HIDE?			[PLB102]
.IF BLOCKS
       LEXCMP  XSP,BLKSSP,,BLOCKS  Is it BLOCKS?		[PLB117]
       LEXCMP  XSP,NOBLSP,,NOBLKS  Is it NOBLOCKS?		[PLB117]
.FI
       BRANCH  CMTCLR		   None of the above		[PLB38]
*_
HIDE   SETAC   HIDECL,1		   Hide statements		[PLB102]
UNLIST SETAC   LISTCL,0		   Zero listing switch		[PLB38]
       BRANCH  RTN1		   Return
*_
LIST   SETAC   LISTCL,1		   Turn on listing		[PLB38]
       SETAC   HIDECL,0		   Unhide statements		[PLB102]
       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
       XRAISP  XSP		   Raise before compare		[PLB33]
       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
*_
EJECT  AEQLC   LISTCL,0,,CMTCLR	   Skip eject if not listing	[PLB38]
       OUTPUT  OUTPUT,EJECTF	   Eject page
       BRANCH  CMTCLR		   Join terminal processing
*_
ERRORS SETAC   NERRCL,0		   Clear NOERRORS switch	[PLB9][PLB38]
       BRANCH  CMTCLR		   Join terminal processing	[PLB9]
*_
NOERRS SETAC   NERRCL,1		   Set NOERRORS switch		[PLB9][PLB38]
       BRANCH  CMTCLR		   Join terminal processing	[PLB9]
*_
CASE   STREAM  XSP,TEXTSP,FRWDTB,COMP3,CASE1			[PLB15][PLB38]
*				   Get to next nonblank char	[PLB15]
       AEQLC   STYPE,NBTYP,CMTCLR  Verify nonbreak		[PLB15]
       STREAM  XSP,TEXTSP,ELEMTB,CMTCLR,CMTCLR			[PLB15]
*				   Get value			[PLB15]
       AEQLC   STYPE,ILITYP,CMTCLR				[PLB15]
*				   Verify integer		[PLB15]
       SPCINT  CASECL,XSP,CMTCLR,CMTCLR				[PLB15]
*_
CASE1  SETAC   CASECL,0		   Clear case folding		[PLB15][PLB38]
       BRANCH  CMTCLR		   Join terminal processing	[PLB15]
*_
INCLUD RCALL   ,CTLADV,,(COMP10,COMP10)				[PLB38]
*				   Advance to filename		[PLB38]
       XINCLD  UNIT,XSP,COMP11,CMTCLR				[PLB20][PLB83]
*				   Process include		[PLB20]
       TRIMSP  XSP,XSP		   Remove trailing spaces	[PLB38]
       RCALL   XCL,BLOCK,INCLSZ	   Allocate include save block	[PLB38]
       PUTDC   XCL,DESCR,INCSTK	   Save pointer to top of stack	[PLB38]
       PUTDC   XCL,2*DESCR,LNNOCL  Save line number		[PLB38]
       PUTDC   XCL,3*DESCR,FILENM  Save pointer to file name	[PLB38]
       MOVD    INCSTK,XCL	   Make new entry top of stack	[PLB38]
       RCALL   FILENM,GENVAR,XSPPTR				[PLB38]
*				   Gen var for new filename	[PLB38]
       SETAC   LNNOCL,0		   Reset line number		[PLB38]
       BRANCH  CMTCLR		   Join terminal processing	[PLB38]
*_
COMP10 SETAC   ERRTYP,29	   Erroneous INCLUDE statement	[PLB38]
       BRANCH  FTLEND						[PLB38]
*_
COMP11 SETAC   ERRTYP,30	   Could not open INCLUDE file	[PLB38]
       BRANCH  FTLEND						[PLB38]
*_
PLSOPS STREAM  XSP,TEXTSP,FRWDTB,COMP3,PLSOP2			[PLB32][PLB38]
       AEQLC   STYPE,NBTYP,CMTCLR				[PLB32]
       STREAM  XSP,TEXTSP,INTGTB,CMTCLR,PLSOP1			[PLB32][PLB38]
       AEQLC   STYPE,ILITYP,CMTCLR				[PLB32]
PLSOP1 SPCINT  SPITCL,XSP					[PLB32][PLB38]
       BRANCH  PLSOP3						[PLB32][PLB38]
*_
PLSOP2 SETAC   SPITCL,0						[PLB32][PLB38]
PLSOP3 BRANCH  CMTCLR		   Processing for EXPCL here?	[PLB33][PLB38]
*_
EXEC   SETAC   EXECCL,1		   Enable program execution 	[PLB34][PLB38]
       BRANCH  CMTCLR		   Join terminal processing	[PLB9]
*_
NOEXEC SETAC   EXECCL,0		   Disable program execution 	[PLB34][PLB38]
       BRANCH  CMTCLR		   Join terminal processing	[PLB9]
*_
* -LINE lineno [ "filenm" ]					[PLB38]
LINE   STREAM  XSP,TEXTSP,FRWDTB,COMP3,CMTCLR			[PLB38]
       AEQLC   STYPE,NBTYP,CMTCLR				[PLB38]
       STREAM  XSP,TEXTSP,INTGTB,COMP12,LINE1			[PLB38]
       AEQLC   STYPE,ILITYP,COMP12 Must be integer line number	[PLB38]
LINE1  SPCINT  LNNOCL,XSP,COMP12   Get line number		[PLB38]
       DECRA   LNNOCL,1		   Adjust for -LINE stmt itself	[PLB38]
       RCALL   ,CTLADV,,(CMTCLR,COMP12)				[PLB38]
*				   Advance to filenm if present	[PLB38]
       RCALL   FILENM,GENVAR,XSPPTR				[PLB38]
*				   Generate natural variable	[PLB38]
       BRANCH  CMTCLR						[PLB38]
*_
COMP12 SETAC   ERRTYP,31	   Erroneous LINE statement	[PLB38]
       BRANCH  FTLEND						[PLB38]
*_
.IF BLOCKS
BLOCKS SETAC   BLOKCL,1		   Enable SNOBOL4B operators 	[PLB117]
       BRANCH  CMTCLR		   Join terminal processing	[PLB117]
*_
NOBLKS SETAC   BLOKCL,0		   Disable SNOBOL4B operators 	[PLB117]
       BRANCH  CMTCLR		   Join terminal processing	[PLB117]
*_
.FI
*---------------------------------------------------------------------*
*
* New [PLB38] from SNOBOL4+
* Advance to arg on control card.
* Input:
*      TEXTSP = Input string
* Return:
*      RTN1 = No Arg
*      RTN2 = Arg does not begin with quote
*      RTN3 = OK, Result in XSP, with quotes removed
*
CTLADV PROC    ,
       STREAM  XSP,TEXTSP,FRWDTB,COMP3,RTN1
*				   Advance to argument
       AEQLC   STYPE,NBTYP,RTN1
       STREAM  XSP,TEXTSP,ELEMTB,RTN2,RTN2
       AEQLC   STYPE,QLITYP,RTN2
       FSHRTN  XSP,1		   Remove leading quote
       SHORTN  XSP,1		   Remove trailing quote
       BRANCH  RTN3
*_
*---------------------------------------------------------------------*
*
*      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
       PCOMP   ZPTR,OCLIM,TREPU5   Check against limit		[PLB88]
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,LIT1CL				E3.7.1
*				   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,7*DESCR	   Leave safety factor		[PLB38]
       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,RTXNAM			E3.4.3[PLB50]
*				   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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   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  DEQL    XPTR,ABORCL,GOTL4   Compare with ABORT		[PLB97]
       AEQLC   XOCBSC,0,,CNTERR	   Must be in a handler!!	[PLB98]
       MOVD    ERRTYP,XERRTY	   Restore saved &ERRTYPE	[PLB97]
       MOVD    FILENM,XFILEN	   Restore saved &FILE		[PLB97]
       MOVD    LNNOCL,XLNNOC	   Restore saved &LINE		[PLB112]
       MOVD    STNOCL,XSTNOC	   Restore saved &STNO		[PLB97]
       BRANCH  FTLEND		   Fatal ending			[PLB97]
*_
GOTL4  DEQL    XPTR,SCNTCL,GOTL5   Compare with SCONTINUE	[PLB97]
       MOVD    FRTNCL,XOCICL	   Restore saved offset		[PLB97]
       BRANCH  GOTL5B						[PLB97]
*_
GOTL5  DEQL    XPTR,CONTCL,GOTL6   Compare with CONTINUE	[PLB97]
       MOVD    FRTNCL,XFRTNC	   Restore saved failure offset	[PLB97]
GOTL5B AEQLC   XOCBSC,0,,CNTERR	   Must be in a handler!!	[PLB97]
       MOVD    OCBSCL,XOCBSC	   Restore code base		[PLB97]
       MOVD    FILENM,XFILEN	   Restore &FILE		[PLB97]
       MOVD    LNNOCL,XLNNOC	   Restore &LINE		[PLB98]
       MOVD    STNOCL,XSTNOC	   Restore &STNO		[PLB97]
       MOVD    LSFLNM,XLSFLN	   Restore &LASTFILE		[PLB97]
       MOVD    LSLNCL,XLSLNC	   Restore &LASTLINE		[PLB98]
       MOVD    LSTNCL,XLNNOC	   Restore &LASTNO		[PLB98]
       SETAC   XOCBSC,0		   Clear saved code base	[PLB98]
       AEQLC   ERRTYP,0,,END0	   Check if at END		[PLB110]
       MOVD    ERRTYP,XERRTY	   Restore &ERRTYPE		[PLB97][PLB110]
       BRANCH  FAIL		   Return eval failure		[PLB97]
*_
GOTL6  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,,INTR4)			E3.10.3
*				   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
* [PLB114] pulled LASTFILE/LINE & USRINT checks to top;
       MOVA    LSFLNM,FILENM	   Update &LASTFILE		[PLB38][PLB40]
       MOVA    LSLNCL,LNNOCL	   Update &LASTLINE		[PLB38][PLB40]
       AEQLC   UINTCL,0,USRINT     Check for SIGINT		[PLB109]
       INCRA   OCICL,DESCR	   Increment offset
       GETD    XCL,OCBSCL,OCICL	   Get statement data
       MOVA    STNOCL,XCL	   Update &STNO
       SETAV   FRTNCL,XCL	   Set up failure offset
       INCRA   OCICL,DESCR	   Increment offset		[PLB38]
       GETD    LNNOCL,OCBSCL,OCICL Update &LINE			[PLB38]
       INCRA   OCICL,DESCR	   Increment offset		[PLB38]
       GETD    FILENM,OCBSCL,OCICL Update &FILE			[PLB38]
       INCRA   EXN2CL,1		   Increment stats stmt count	[PLB38]
       ACOMPC  EXLMCL,0,,,RTNUL3   Done if &STLIMIT < 0		[PLB33][PLB38]
       ACOMP   EXNOCL,EXLMCL,EXEX,EXEX
*				   Check &STLIMIT
       INCRA   EXNOCL,1		   Increment &STCOUNT
       ACOMPC  TRAPCL,0,,RTNUL3,RTNUL3
*				   Check &TRACE
       XCALLC  chk_break,(0),INIT1 Check for breakpoint		[PLB113]
       LOCAPT  ATPTR,TKEYL,STNOKY,INIT1				[PLB113]
*				   Look for STNO trace		[PLB113]
       RCALL   ,TRPHND,ATPTR					[PLB113]
INIT1  LHERE							[PLB113]
       LOCAPT  ATPTR,TKEYL,STCTKY,RTNUL3
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   Perform trace
       BRANCH  RTNUL3
*_
*---------------------------------------------------------------------*
*
*      Basic Interpreter Procedure
*
INTERP PROC    ,		   Interpreter core procedure
INTRP0 INCRA   OCICL,DESCR	   Increment offset		[PLB82]
       GETD    XPTR,OCBSCL,OCICL   Get object code descriptor
       TESTF   XPTR,FNC,INTRP0	   Test for function		[PLB82]
       RCALL   XPTR,INVOKE,(XPTR),(,INTRP0,INTRP0,RTN1,RTN2,RTN3) [PLB82]
       MOVD    OCICL,FRTNCL	   Set offset for failure
       INCRA   FALCL,1		   Increment &STFCOUNT
       ACOMPC  TRAPCL,0,,INTRP0,INTRP0				[PLB82]
*				   Check &TRACE
       LOCAPT  ATPTR,TKEYL,FALKY,INTRP0				[PLB82]
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   Perform trace
       BRANCH  INTRP0						[PLB82]
*_
*---------------------------------------------------------------------*
*
*      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?
       LOCSP   XSP,XPTR		   Get specifier
       LEQLC   XSP,0,,RTXPTR					E3.1.4
       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   LOCSP   XSP,XPTR		   Get specifier for string
       SPCINT  XPTR,XSP,,RTXNAM					[PLB64]
*				   Convert to integer
       SPREAL  XPTR,XSP,INTR1					[PLB64]
*				   Try conversion to REAL	[PLB64]
INTRI  RLINT   XPTR,XPTR,INTR1,RTXNAM				[PLB64]
*_
INTV3  GETDC   XPTR,XPTR,DESCR	   Get value
INTV2  VEQLC   XPTR,I,,RTXNAM	   INTEGER desired
       VEQLC   XPTR,R,,INTRI	   REAL allowed			[PLB64]
       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
*_
*
* New [PLB28][PLB29] from SNOBOL4+
*
*      Evaluation of argument as upper case string if case folding.
*      Just like VARVAL, returns by exit 2.  Source string is not
*      modified.  If the upper case version already exists, it's
*      values take precedence.
*
*      Thanks to Mark Emmer for the name, behavior and use of this
*      function!
*
VARVUP PROC    VARVAL
       RCALL   ,VARVAL,,FAIL	   Get string ptr to XPTR
       AEQLC   CASECL,0,VPXPTR,RTXNAM
*				   Return name			[PLB30]
*_
*
* New [PLB29]
* Case-folding version of RTXNAM.
* here from IND, VARVUP to convert XPTR to upper case
*
VPXPTR PROC    VARVAL
       LOCSP   SPECR1,XPTR	   Get specifier to string
       LEQLC   SPECR1,0,,RTXNAM	   Avoid null string
       GETLG   AXPTR,SPECR1	   Get string length
       RCALL   ,CONVAR,AXPTR,	   Allocate scratch space at FRSGPT
       LOCSP   XSP,FRSGPT	   Get specifier for scratch string
       XCALLC  RAISE2,(SPECR1,XSP),RTXNAM			[PLB86]
*				   Copy & raise; fails if no LC chars
       MOVDIC  FRSGPT,DESCR,XPTR,DESCR
*				   Give new string same value and
       MOVDIC  FRSGPT,ATTRIB,XPTR,ATTRIB
*				   label as original
       RCALL   XPTR,GNVARS,AXPTR,RTXNAM
*				   Make upper case version official
       BRANCH  RTXNAM		   Return by name
*_
*---------------------------------------------------------------------*
*
*      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
*_
EXPOP  PROC    ADD		   X ** Y and X ^ Y		[PLB43]
       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 LOCSP   XSP,XPTR		   Get specifier
       SPCINT  XPTR,XSP,,ARTHII	   Convert string to integer
       SPREAL  XPTR,XSP,INTR1,ARTHRI
*				   Convert to real if possible
*_
ARTHIV LOCSP   YSP,YPTR		   Get specifier
       SPCINT  YPTR,YSP,,ARTHII	   Convert string to integer
       SPREAL  YPTR,YSP,INTR1,ARTHIR
*				   Convert to real if possible
*_
ARTHVV LOCSP   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 LOCSP   XSP,XPTR		   Get spedifier
       SPCINT  XPTR,XSP,,ARTHIR	   Convert string to integer
       SPREAL  XPTR,XSP,INTR1,ARTHRR
*				   Convert to real if possible
*_
ARTHRV LOCSP   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
       LOCSP   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   LOCSP   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   LOCSP   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
*_
BREAKX PROC    ANY		   BREAKX(S)			[PLB31]
       PUSH    BRXCCL		   Save function descriptor	[PLB31]
       PUSH    ZEROCL		   Save minimum length of zero	[PLB31]
       BRANCH  ABNSND		   Join common processing	[PLB31]
*_
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 DEQL    XPTR,NULVCL,,NONAME				E3.5.4
       RCALL   TPTR,BLOCK,LNODSZ				E3.5.4
       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
       LOCSP   ZSP,XPTR		   Get specifier
       SPCINT  XPTR,ZSP,INTR1	   Convert to INTEGER
LPRTNI ACOMPC  XPTR,0,,,LENERR					E3.6.1
       DEQL    YCL,LNTHCL,PATNOD				E3.6.1
       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
       LOCSP   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   LOCSP   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   LOCSP   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   LOCSP   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   LOCSP   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 LOCSP   XSP,XPTR		   Get specifier for subject
       LOCSP   YSP,YPTR		   Get specifier for pattern
SCANVB SUBSP   TSP,YSP,XSP,FAIL	   Get part to compare
       LEXCMP  TSP,YSP,,RTYPTR	   Compare strings		[PLB32]
       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 LOCSP   XSP,XPTR		   Get specifier for subject
       RCALL   ,SCNR,,(FAIL,,FAIL) Call scanner
       RCALL   ,NMD,,(FAIL)	   Perform naming		[PLB32]
       LCOMP   TXSP,HEADSP,SCANV1,SCANV1			[PLB32]
*				   Allow for negatives		[PLB32]
       REMSP   XSP,HEADSP,TXSP	   Head is larger than match	[PLB32]
       BRANCH  SCANV2						[PLB32]
*_
SCANV1 REMSP   XSP,TXSP,HEADSP	   Get matching substring	[PLB32]
SCANV2 RCALL   YPTR,GENVAR,XSPPTR,RTYPTR			[PLB32]
*_
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 LOCSP   XSP,XPTR		   Get specifier
       RCALL   ,SCNR,,(FAIL,,FAIL) Call scanner
       SETAC   NAMGCL,1		   Set naming switch
       REMSP   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 LOCSP   XSP,XPTR		   Get specifier for subject
       LOCSP   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
       REMSP   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  LOCSP   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
       LOCSP   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,,RTZPTR,RTZPTR				[PLB32]
*				   Check &TRACE
       LOCAPT  ATPTR,TVALL,WPTR,RTZPTR				[PLB32]
*				   Look for VALUE trace
       RCALL   ,TRPHND,ATPTR,RTZPTR				E3.3.1 [PLB32]
*				   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
       PUSH    (YPTR,YSIZ)	   Save pattern and length	[PLB82]
       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  SCIN		   Join common scanning		[PLB65]
*_
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  SCIN		   Join common scanning		[PLB65]
*_
SCIN   PROC    SCNR
       SETAC   UNSCCL,0		   Clear UNSC flag		[PLB65]
SCIN1  PROC    SCNR						[PLB82]
SCIN1A MOVD    PATBCL,YPTR	   Set up pattern base pointer	[PLB82]
       AEQLC   UNSCCL,0,UNSC	   Test UNSC flag		[PLB65][PLB91]
       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  GETDC   PTBRCL,ZCL,0	   Get index			[PLB65]
       BRANCH  PATBRA
*_
SALF   XPROC   SCNR		   Nonlength failure procedure	[PLB67]
TSALF  LHERE							[PLB65]
SALF1  SETAC   LENFCL,0		   Clear length failure
       BRANCH  SALT2		   Join common processing
*_
SALT   XPROC   SCNR		   Length failure procedure	[PLB67]
TSALT  LHERE							[PLB65]
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
* [PLB65] replaces BRANIC:
       GETDC   PTBRCL,PATICL,0	   Get index			[PLB65]
PATBRA SELBRA  PTBRCL,(ANYC,ARBF,ARBN,ATP,CHR,BAL,BALF,BRKC,BRKX,BRKXF,DNME,DNME1,EARB,DSAR,ENME,ENMI,FARB,FNME,LNTH,NME,NNYC,ONAR,ONRF,POSI,RPSI,RTB,FAIL,SALF,SCOK,SCON,SPNC,STAR,TB,RTNUL3,FNCE,SUCF)
*				   Dispatch on index		[PLB65]
       BRANCH  INTR13		   Catch bad data		[PLB66]
*_
UNSC   SETAC   UNSCCL,0		   Clear UNSC flag		[PLB91]
       MOVD    PATBCL,YPTR	   Reset pattern base		[PLB91]
SALT3  AEQLC   LENFCL,0,SALT1	   Check length failure
       BRANCH  SALF1		   Go to nonlength failure
*_
SCOK   XPROC   SCNR		   Successful scanning procedure [PLB67]
TSCOK  LHERE							[PLB65]
       SETAV   PATICL,XCL	   Set offset from THEN link
       AEQLC   PATICL,0,SCIN2,RTN2 Check for none
*_
SCON   XPROC   SCNR						[PLB67]
       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
* [PLB65] copied from 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  SCIN1A		   Join common scanning		[PLB82]
*_
*---------------------------------------------------------------------*
*
*      ANY, BREAK, NOTANY, SPAN
*
*      [PLB59] from SNOBOL4+;
*      Recoded ANY, NOTANY, BREAK and SPAN for speedup: ANY and NOTANY
*      take the next subject character and perform "index()" BREAK and
*      SPAN each have their own stream table.
*
BRKC   XPROC   ,		   BREAK			[PLB67]
       SETAC   SCL,2
       BRANCH  ABNS
*_
BRKX   XPROC   BRKC		   BREAKX			[PLB67]
       SETAC   SCL,5
       BRANCH  ABNS
*_
NNYC   XPROC   BRKC		   NOTANY			[PLB67]
       SETAC   SCL,3
       BRANCH  ABNS
*_
SPNC   XPROC   BRKC		   SPAN				[PLB67]
       SETAC   SCL,4
       BRANCH  ABNS
*_
ANYC   XPROC   BRKC		   Matching procedure for ANY(S) [PLB67]
       SETAC   SCL,1		   Post entry
*
ABNS   INCRA   PATICL,DESCR	   Increment offset
       GETD    XPTR,PATBCL,PATICL  Get argument
ABNS1  VEQLC   XPTR,S,,ABNSV	   String
       VEQLC   XPTR,E,,ABNSE	   Expr
       VEQLC   XPTR,I,SCDTER,ABNSI Int
*_
ABNSE  PUSH    SCL
       RCALL   XPTR,EXPVAL,XPTR,(ABNSF,ABNS2)
ABNSF  POP     SCL
       BRANCH  SALF		   Match failure
*_
ABNS2  POP     SCL		   Restore procedure switch
       BRANCH  ABNS1
*_
ABNSI  RCALL   XPTR,GNVARI,XPTR,
ABNSV  AEQLC   XPTR,0,,SCNAME	   Error if null string
       SELBRA  SCL,(ANYC3,,ANYC3,SPNV,) SPAN departs here
*
       DEQL    XPTR,TBLBCS,,ANYC3  Same BREAK arg as last time?
       CLERTB  BRKTB,CONTIN	   No, create STREAM table
       LOCSP   YSP,XPTR
       PLUGTB  BRKTB,STOPSH,YSP	   Plug entries for characters
       MOVD    TBLBCS,XPTR	   Save argument to check next time
*
ANYC3  SETSP   VSP,XSP		   Get portion of subject to scan
       AEQLC   FULLCL,0,ANYC4,	   Leave length alone in FULLSCAN mode
       PUTLG   VSP,MAXLEN	   Else insert maximum length
       LCOMP   VSP,TXSP,,,SALT	   Length failure if too short
       CHKVAL  MAXLEN,ZEROCL,XSP,,ANYC4,ANYC4
       ADDLG   VSP,ONECL
*
ANYC4  REMSP   YSP,VSP,TXSP	   Get specifier to unscanned portion
       SELBRA  SCL,(ANYC7,,ANYC7,,) ANY and NOTANY depart here
       STREAM  ZSP,YSP,BRKTB,SALF,SALT, Perform BREAK, BREAKX scanning
       GETLG   XPTR,ZSP		   Get length accepted
       ADDLG   TXSP,XPTR	   Add length accepted
       AEQLC   SCL,5,SCOK,	   Done if BRKC call
*				   Success on BREAKX
       INCRA   PDLPTR,3*DESCR	   Make room for history entry
       ACOMP   PDLPTR,PDLEND,INTR31
       PUTDC   PDLPTR,DESCR,ZEROCL Should never take alternative
       PUTDC   PDLPTR,2*DESCR,PATICL Save pattern position of BREAKX
       PUTDC   PDLPTR,3*DESCR,LENFCL
       GETLG   TVAL,TXSP	   Get cursor position
       MOVA    TMVAL,TVAL	   for history list to lock
       INCRA   PDLPTR,3*DESCR	   Make room for history entry
       ACOMP   PDLPTR,PDLEND,INTR31
       PUTDC   PDLPTR,DESCR,BRXFCL Routine for BREAKX rematch
       PUTDC   PDLPTR,2*DESCR,TMVAL Save cursor (will set up
       PUTDC   PDLPTR,3*DESCR,LENFCL TXSP if backup later)
       BRANCH  SCOK
*_
* ANY, NOTANY
ANYC7  LEQLC   YSP,0,,SALT	   Length failure if subject null
       XCALLC  XANY,(YSP,XPTR),,ANYC5 				[PLB86]
*				   Look for first char of subj in arg str
       AEQLC   SCL,1,,SALF	   Not found, fail if ANY
ANYC6  ADDLG   TXSP,ONECL	   Accept next subject char
       BRANCH  SCOK
ANYC5  AEQLC   SCL,3,ANYC6,SALF	   Found, fail if NOTANY
*_
BRKXF  XPROC   ,		   BREAKX rematch		[PLB67]
       GETDC   PATICL,PDLPTR,2*DESCR Restore position in pattern
       DECRA   PATICL,DESCR	   Point to BREAKX argument
       DECRA   PDLPTR,3*DESCR	   Discard frame holding PATICL
       AEQLC   FULLCL,0,,BRXF1	   J. if FULLSCAN off
       SETAC   NVAL,0		   Set residual length to 0
       BRANCH  BRXF3		   Join processing
*_
BRXF1  AEQLC   LENFCL,0,SALT,	   Check for length failure
       SETAV   NVAL,YCL		   Get residual length
BRXF3  CHKVAL  MAXLEN,NVAL,TXSP,SALT,SALT, Check against maximum
       GETDC   XCL,PDLPTR,DESCR	   Restore from BREAKX stack entry
       ADDLG   TXSP,ONECL	   Add one to length matched
       BRANCH  BRKX		   Try BREAK again with locked in advance
*_
SPNV   DEQL    XPTR,TBLSCS,,SPNC3  Same SPAN arg as last time?
       CLERTB  SPANTB,STOPSH	   No, create STREAM table
       LOCSP   YSP,XPTR
       PLUGTB  SPANTB,CONTIN,YSP   Plug entries for characters
       MOVD    TBLSCS,XPTR	   Save argument to check next time
*
SPNC3  LCOMP   XSP,TXSP,,SALT,SALT Length failure if too short
       REMSP   YSP,XSP,TXSP	   Get specifier to unscanned portion
       STREAM  ZSP,YSP,SPANTB,SALF,,
       LEQLC   ZSP,0,,SALF	   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,SALT,,
SPNC5  ADDLG   TXSP,XPTR	   Add length accepted
       BRANCH  SCOK
*_
*---------------------------------------------------------------------*
*
*      LEN, POS, RPOS, RTAB, TAB
*
LNTH   XPROC   ,		   Matching procedure for LEN(N) [PLB67]
       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,,LPRRTV					E3.5.6
       POP     SCL						E3.5.6
       BRANCH  SCDTER						E3.5.6
*				   Is it STRING?
LPRRTE RCALL   XPTR,EXPVAL,XPTR,(,LPRRT1)			E3.2.1
       POP     SCL						E3.2.1
       BRANCH  TSALF						E3.2.1
*_								E3.2.1
*				   Evaluate EXPRESSION
LPRRTV LOCSP   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
       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   XPROC   LNTH		   Matching procedure for POS(N) [PLB67]
       SETAC   SCL,2		   Note entry
       BRANCH  LPRRT		   Join common processing
*_
RPSI   XPROC   LNTH		   Matching procedure for RPOS(N) [PLB67]
       SETAC   SCL,3		   Note entry
       BRANCH  LPRRT		   Join common processing
*_
RTB    XPROC   LNTH		   Matching procedure for RTAB(N) [PLB67]
       SETAC   SCL,4		   Note entry
       BRANCH  LPRRT		   Join common processing
*_
TB     XPROC   LNTH		   Matching procedure for TAB(N) [PLB67]
       SETAC   SCL,5		   Note entry
       BRANCH  LPRRT		   Join common processing
*_
*---------------------------------------------------------------------*
*
*      ARBNO
*
ARBN   XPROC   ,		   Matching for ARBNO(P)	[PLB67]
       GETLG   TMVAL,TXSP	   Get cursor position
       PUSH    TMVAL		   Save cursor position
       BRANCH  SCOK,SCNR	   Return matching successfully
*_
ARBF   XPROC   ARBN		   Backup matching for ARBNO(P)	[PLB67]
       POP     (TMVAL)		   Restore cursor position
       BRANCH  ONAR2		   Join common processing
*_
EARB   XPROC   ARBN						[PLB67]
       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   XPROC   ARBN						[PLB67]
       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   XPROC   ARBN						[PLB67]
       MOVD    TVAL,ZEROCL
       GETAC   TVAL,PDLPTR,-2*DESCR
*				   Get old cursor position
       BRANCH  ONAR1		   Join processing
*_
FARB   XPROC   ,						[PLB67]
       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    XPROC   ,		   Matching procedure for @X	[PLB67]
       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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   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,SCNEMO)		E3.4.4
*_
*---------------------------------------------------------------------*
*
*      BAL
*
BAL    XPROC   ,		   Matching procedure for BAL	[PLB67]
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
       PCOMP   PDLPTR,PDLHED,TSALF,TSALF,INTR13			[PLB88]
*_
BALF   XPROC   BAL		   Matching procedure for BAL retry [PLB67]
       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    XPROC   ,		   Matching character string	[PLB67]
       INCRA   PATICL,DESCR	   Increment offset
       GETD    YPTR,PATBCL,PATICL  Get argument
CHR1   LOCSP   TSP,YPTR		   Get specifier
CHR2   REMSP   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   XPROC   CHR		   Matching procedure for expressions [PLB67]
       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   XPROC   CHR		   Backup matching for expression [PLB67]
       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
       SETAC   UNSCCL,1		   Set UNSC hack flag		[PLB65]
       RCALL   ,SCIN1,,(STARP5,STARP2,RTNUL3)			[PLB65]
*				   Call unscanning procedure
*_
*---------------------------------------------------------------------*
*
*      FENCE
*
FNCE   XPROC   ,		   Procedure for matching FENCE	[PLB67]
       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
       BRANCH  SCOK		   Return matching		[PLB65]
*_
*---------------------------------------------------------------------*
*
*      X . Y and X $ Y
*
NME    XPROC   ,		   Matching procedure for naming [PLB67]
       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   XPROC   NME		   Backup procedure for naming	[PLB67]
       POP     (TVAL)		   Restore cursor
FNME1  AEQLC   LENFCL,0,TSALT,TSALF
*				   Check length failure indicator
*_
ENME   XPROC   NME		   Naming process for X . Y	[PLB67]
       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
       REMSP   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   XPROC   NME		   Unravelling procedure for naming [PLB67]
       DECRA   NAMICL,DESCR+SPEC   Back off named string
       SUM     TPTR,NBSPTR,NAMICL  Compute current position
DNME1  XPROC   NME						[PLB67]
       SETAV   VVAL,YCL
       PUSH    (VVAL)		   Preserve length
       BRANCH  FNME1
*_
ENMI   XPROC   NME		   Matching for X $ Y		[PLB67]
       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
       REMSP   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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   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 PUSH    ZEROCL				       E3.4.4 & E3.5.8
       RCALL   YPTR,EXPEVL,YPTR,(TSALF,,SCNEMO)	       E3.4.4 & E3.5.8
       POP     ZEROCL				       E3.4.4 & E3.5.8
       BRANCH  ENMI5				       E3.4.4 & E3.5.8
*_
*---------------------------------------------------------------------*
*
*      SUCCEED
*
SUCE   XPROC   ,		   Matching procedure for SUCCEED [PLB67]
       INCRA   PDLPTR,3*DESCR	   Make room for history entry	[PLB82]
       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
       BRANCH  SCOK		   Return successful match	[PLB65]
*_
SUCF   XPROC   SUCE		   SUCCEED failure		[PLB67]
       GETDC   XCL,PDLPTR,DESCR	   Get history entries
       GETDC   YCL,PDLPTR,2*DESCR
       BRANCH  SUCE		   Go in front door		[PLB82]
*_
* [PLB65] here from end of file;
SCDTER SETAC   ERRTYP,1		   Illegal data type
       BRANCH  SCERSX						[PLB65]
*_
SCLENR SETAC   ERRTYP,14	   Negative number
       BRANCH  SCERSX						[PLB65]
*_
SCLNOR SETAC   ERRTYP,15	   String overflow
       BRANCH  SCERSX						[PLB65]
*_
SCNAME SETAC   ERRTYP,4		   Null string
       BRANCH  SCERSX						[PLB65]
*_
SCNEMO SETAC   ERRTYP,8						E3.4.4
SCERSX RCALL   ,SCERST						[PLB65]
       BRANCH  TSALF						[PLB65]
*_
*---------------------------------------------------------------------*
       TITLE   'Defined Functions'
*
*      DEFINE(P,E)
*
DEFINE PROC    ,		   DEFINE(P,E)
       RCALL   XPTR,VARVAL,,FAIL   Get prototype
       PUSH    XPTR		   Save prototype
       RCALL   YPTR,VARVUP,,FAIL   Get entry point		[PLB89]
       POP     XPTR		   Restore prototype
       LOCSP   XSP,XPTR		   Specifier for prototype
       STREAM  YSP,XSP,VARATB,PROTER,PROTER
*				   Break out function name
       AEQLC   STYPE,LPTYP,PROTER  Verify open parenthesis
       RCALL   XPTR,GENVUP,(YSPPTR)
*				   Get variable for function nm	[PLB17][PLB27]
       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,GENVUP,(YSPPTR)
*				   Generate var for argument	[PLB17][PLB27]
       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,GENVUP,(YSPPTR)
*				   Generate var for argument	[PLB17][PLB27]
       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,GENVUP,(YSPPTR)
*				   Generate variable		[PLB17][PLB27]
       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,GENVUP,YSPPTR  Generate variable		[PLB26][PLB27]
       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    (FILENM,LNNOCL,FRTNCL,STNOCL,OCICL,OCBSCL,ZCL,ZCL) [PLB38]
*				   Save system state
       GETDC   XCL,ZCL,DESCR	   Get entry label
       AEQLIC  XCL,ATTRIB,0,,UNDFFE				E3.0.2
       GETDC   OCBSCL,XCL,ATTRIB				E3.0.2
       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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   Perform trace
       POP     (ZCL,RETPCL)	   Restore block and return
DEFF17 POP     (ZCL,OCBSCL,OCICL,STNOCL,FRTNCL,LNNOCL,FILENM)	[PLB38]
*				   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
       POP     XPTR		   Restore prototype		[PLB42]
LOAD2  LOCSP   VSP,WPTR		   Get specifier for library	[PLB42]
       LOCSP   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,GENVUP,YSPPTR  Generate var for function nm	[PLB17][PLB27]
       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,GENVUP,ZSPPTR  Generate var for data type	[PLB17][PLB27]
       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   ZPTR,BLOCK,XCL	   Allocate block for definition [PLB101]
       SUM     XPTR,ZPTR,XCL	   Compute pointer to end of block [PLB101]
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
       PUTDC   ZCL,0,LODCL	   Insert procedure descriptor	[PLB101]
       PUTDC   ZCL,DESCR,ZPTR	   Insert definition block	[PLB101]
       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,VARVUP,,FAIL   Get function name		[PLB28]
       RCALL   ZCL,FINDEX,XPTR	   Locate function descriptor
       PUTDC   ZCL,0,UNDFCL	   Undefine function
       LOCSP   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    YCL,INCL		   Save function descriptor
       GETDC   WCL,YCL,0	   Get procedure descriptor	[PLB87]
       SETAV   WCL,WCL		   Get formal argument count	[PLB87]
       MOVD    WPTR,ZEROCL	   Clear count of passed args	[PLB87][PLB96]
       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,WPTR)			[PLB87]
*				   Save working descriptors
       RCALL   XPTR,ARGVAL,,FAIL   Evaluate argument
       POP     (WPTR,YCL,WCL,YPTR,TCL,ZCL,XCL)			[PLB87]
*				   Restore working descriptors
       DECRA   WCL,1						E3.9.1
       ACOMPC  WCL,0,,,LNKF6	   Pass extras w/o conversion	[PLB87]
       GETD    ZPTR,ZCL,TCL	   Get data type required	[PLB82]
       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  LOCSP   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  LOCSP   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
       INCRA   WPTR,1		   Keep count			[PLB87]
       DECRA   XCL,1						E3.9.1
       ACOMPC  XCL,0,LNKF1					E3.9.1
LNKF4  ACOMPC  WCL,0,,LNKF5,LNKF5				E3.9.1
       PUSH    NULVCL						E3.9.1
       INCRA   WPTR,1		   Keep count			[PLB87]
       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
       LOCSP   XSP,XPTR		   Get specifier to prototype
       PUSH    XPTR		   Save prototype for later insertion
ARRAY1 STREAM  YSP,XSP,NUMBTB,PROTER,ARROT1			E3.5.1
       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
       AEQLC   ARRMRK,0,ARRAY7					E3.5.1
       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
       PCOMP   XPTR,WPTR,INTR10,,ARRAY9
*				   Check for end		[PLB88]
       POP     WPTR		   RESTORE PROTOTYPE		E3.10.1
       PUTDC   ZPTR,DESCR,WPTR	   RETURN POINTER TO ARRAY	E3.10.1
       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
       MULT    ZPTR,WPTR,DSCRTW,SIZERR				E3.10.4
       INCRA   ZPTR,2*DESCR					E3.10.4
       ACOMP   ZPTR,SIZLMT,SIZERR,SIZERR			E3.10.4
       POP     XPTR		   Restore size
       ACOMPC  XPTR,0,ASSOC1,,LENERR
       SETAC   XPTR,EXTSIZ
ASSOC1 INCRA   XPTR,1						E3.2.3
       MULTC   XPTR,XPTR,2*DESCR				E3.2.3
       ACOMPC  WPTR,0,ASSOC4,,LENERR
       SETAC   WPTR,EXTSIZ
ASSOC4 INCRA   WPTR,1						E3.2.3
       MULTC   WPTR,WPTR,2*DESCR				E3.2.3
       SETVC   XPTR,T						E3.2.3
ASSOCE PROC    ASSOC						E3.2.3
       RCALL   ZPTR,BLOCK,XPTR					E3.2.3
       PUTD    ZPTR,XPTR,ONECL					E3.2.3
       DECRA   XPTR,DESCR					E3.2.3
       PUTD    ZPTR,XPTR,WPTR					E3.2.3
ASSOC2 DECRA   XPTR,2*DESCR					E3.2.3
       PUTD    ZPTR,XPTR,NULVCL					E3.2.3
       AEQLC   XPTR,DESCR,ASSOC2,RTZPTR				E3.2.3
*_
*---------------------------------------------------------------------*
*
*      DATA(P)
*
DATDEF PROC    ,		   DATA(P)
       RCALL   XPTR,VARVAL,,FAIL   Get prototype
       SETAC   DATACL,0		   Initialize prototype switch
       LOCSP   XSP,XPTR		   Get specifier
       STREAM  YSP,XSP,VARATB,PROTER,PROTER
*				   Break out data type name
       AEQLC   STYPE,LPTYP,PROTER  Verify left parenthesis
       RCALL   XPTR,GENVUP,(YSPPTR)
*				   Generate variable for name	[PLB17][PLB27]
       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,GENVUP,YSPPTR  Generate variable		[PLB17][PLB27]
       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
       AEQLC   YCL,0,,PROTER					E3.1.2
       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
       INCRA   WPTR,DESCR					E3.0.3
       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
*_
*---------------------------------------------------------------------*
*
* New [PLB34] from SNOBOL4+
*	FREEZE(T)
*
FREEZE PROC    ,		   FREEZE(T)
       RCALL   XPTR,ARGVAL,,FAIL   Get argument
       VEQLC   XPTR,T,NONARY	   Verify TABLE
       SETFI   XPTR,FRZN	   Freeze it
       BRANCH  RETNUL		   Return
*_
*---------------------------------------------------------------------*
*
* New [PLB34] from SNOBOL4+
*	THAW(T)
*
THAW   PROC    ,		   THAW(T)
       RCALL   XPTR,ARGVAL,,FAIL   Get argument
       VEQLC   XPTR,T,NONARY	   Verify TABLE
       RSETFI  XPTR,FRZN	   Thaw it
       BRANCH  RETNUL		   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
*_
* New [PLB34] from SNOBOL4+
* Table Reference
ASSCR  AEQLC   XCL,1,ARGNER,	   Only one argument for tables
       PUSH    YCL		   Save pointer to object
       RCALL   YPTR,ARGVAL,,FAIL   Evaluate argument
       POP     XPTR
       MOVD    YCL,XPTR		   Save ptr to start of table
* Rewritten to only search for zero entry in last extent
ASSCR5 LOCAPV  XPTR,XPTR,YPTR,,ARYA10
*				   Look up in this table extent
       GETSIZ  TCL,XPTR		   Not found. Get size of table
       GETD    ZPTR,XPTR,TCL	   Get last value entry		[PLB82]
       AEQLC   ZPTR,1,,ASSCR6	   Jump if this was last extent
       MOVD    XPTR,ZPTR	   No. Move to next extent
       BRANCH  ASSCR5		   and search there
*_
* Here if not found
ASSCR6 TESTFI  YCL,FRZN,,RETNUL	   Return null by value if frozen
       LOCAPV  XPTR,XPTR,ZEROCL,ASSCR3,
*				   Not found. Find empty slot
ASSCR8 PUTDC   XPTR,2*DESCR,YPTR   Make value entry (subscript)
       BRANCH  ARYA10		   Join array reference exit
*_
ASSCR3 DECRA   TCL,DESCR	   No zero entry
       GETD    WPTR,XPTR,TCL	   Get expansion size
       MOVD    ZCL,XPTR		   Save current extent
       RCALL   ZPTR,BLOCK,WPTR,	   Get new next one
       MOVD    XPTR,WPTR	   New extent's size
       RCALL   XPTR,ASSOCE,,(INTR10,INTR10)
*				   Initialize new extent
       INCRA   TCL,DESCR
       PUTD    ZCL,TCL,XPTR	   Point old extent to new one
       BRANCH  ASSCR8
*_
*---------------------------------------------------------------------*
*      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,,FIELD2	   Check for INTEGER		[PLB35]
       VEQLC   XPTR,S,FIELD1	   Check if not STRING		[PLB35]
       AEQLC   CASECL,0,,FIELD1	   Case folding enabled?	[PLB35]
       RCALL   ,VPXPTR,,FAIL	   Yes, take care of it		[PLB35]
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
*_
FIELD2 RCALL   XPTR,GNVARI,XPTR,FIELD1
*				   Create var from integer	[PLB35]
*_
*---------------------------------------------------------------------*
*
* New [PLB31] from SNOBOL4+
*	RSORT(T,C), SORT(T,C)
*
RSORT  PROC    ,		   RSORT function
       SETAC   SCL,1
       BRANCH  SORT1
*_
SORT   PROC    RSORT		   SORT function
       SETAC   SCL,0
*
SORT1  SETAV   WCL,INCL		   Get arg count
       PUSH    (WCL,SCL)	   V1.7A Protect SCL
       RCALL   XPTR,ARGVAL,,FAIL   Get first argument
       MOVD    WPTR,XPTR	   Save copy
       VEQLC   XPTR,A,,SORT2	   J. if array
       VEQLC   XPTR,T,NONARY	   Error if not table or array
       RCALL   XPTR,ICNVTA,XPTR,(FAIL)
*				   Cvt table to array
*
SORT2  POP     (SCL,WCL)	   R/SORT flag, arg count
       GETDC   XCL,XPTR,2*DESCR	   No. of dimensions in array
       MULTC   YPTR,XCL,DESCR	   Convert to address units
       SUM     YPTR,XPTR,YPTR	   Add base and offset
       INCRA   YPTR,2*DESCR	   Add 2 for heading
       MOVD    YCL,ONECL	   Assume vector - 1 column
       ACOMPC  XCL,2,INTR30,,SORT3 No. dimensions. J. if vector
       GETDC   YCL,XPTR,3*DESCR
       SETAV   YCL,YCL		   2-d array; Get no. of columns
*
SORT3  GETDC   ZCL,YPTR,0
       SETAV   ZCL,ZCL		   Column length
       MULTC   ZCL,ZCL,DESCR	   Convert to address units	[PLB31]
       MOVD    ZPTR,YPTR	   Assume one arg to function
       ACOMPC  WCL,2,ARGNER,,SORT5 J. if 1 arg
       PUSH    (WPTR,XPTR,YPTR,ZPTR,XCL,YCL,ZCL,SCL)
*				   2 args. save everything
       RCALL   WCL,ARGVAL,,FAIL	   Get column no. or field name
       POP     (SCL,ZCL,YCL,XCL,ZPTR,YPTR,XPTR,WPTR)
*				   Restore
       MOVD    A3PTR,ZEROCL	   Assume no Field arg
* was:								[PLB31]
*      VEQBRA  WCL,(I,,SORT3C,S,,SORT3B,R,INTR30,SORT3A)	[PLB31]
       VEQLC   WCL,I,,SORT3C					[PLB31]
       VEQLC   WCL,S,,SORT3B					[PLB31]
       VEQLC   WCL,R,INTR30,SORT3A				[PLB31]
*_
SORT3A RLINT   WCL,WCL,INTR30,SORT3C
*				   Real, convert to Int
SORT3B LOCSP   XSP,WCL		   String
       SPCINT  WCL,XSP,,SORT3C	   Convert to int?
       SPREAL  WCL,XSP,,SORT3A	   Convert to real?
       AEQLC   XCL,1,INTR30	   Possible field function, must be 1-d
       LOCAPV  WCL,FNCPL,WCL,INTR30
*				   Field function?
       GETDC   WCL,WCL,DESCR	   Possibly, get function descriptor
       GETDC   TCL,WCL,0	   Get procedure definition
       AEQL    TCL,FLDCL,INTR30	   Not field function
       GETDC   A3PTR,WCL,DESCR	   Field Block
       MOVD    WCL,ONECL	   Sort on column 1
*
SORT3C AEQLC   XCL,1,SORT4,	   Jump if 2-d array
       AEQLC   WCL,1,INTR30,SORT5  1-D, 2nd arg must=1 if present
*_
SORT4  GETDC   TCL,XPTR,3*DESCR	   Array. Get column bounds
       SUBTRT  WCL,WCL,TCL,INTR30,SORT4A
*				   Subtract 2nd dim. lower bound
SORT4A ACOMPC  WCL,0,,,INTR30	   Column offset must be >=0
       ACOMP   WCL,YCL,INTR30,INTR30
*				   Col. offset must be < no. cols.
       MULT    WCL,WCL,ZCL,INTR30  Offset * column length
       SUM     ZPTR,YPTR,WCL	   Ptr to col. block being sorted
*
SORT5  SETAC   XCL,0		   Prepare to build index
       VEQLC   WPTR,A,,SORTA	   J. if source was array
*
* Source was a table.
*
       GETSIZ  TCL,XPTR		   Size of new array
       SUM     TPTR,XPTR,TCL	   Last element of new array
       SUBTRT  TPTR,TPTR,ZCL	   - no. rows = start of index table-1
*				   Assume SORT(Table,1)
       SETAC   A4PTR,-DESCR	   Table advance to get to 2nd col. elt [PLB31]
       SETAC   A5PTR,0		   Offset to element in 1st column
       AEQL    ZPTR,YPTR,,SORTT1   J. if sorting on Table(1)	[PLB31]
       SETAC   A5PTR,-DESCR	   SORT(Table,2). Get to 1st element [PLB31]
*
SORTT1 GETSIZ  WCL,WPTR		   Get size of next table extent
       DECRA   WCL,2*DESCR	   Less special words at end
       SUM     WCL,WPTR,WCL	   End of extent pointer	[PLB82]
SORTT2 GETDC   TCL,WPTR,DESCR	   Get value entry
       DEQL    TCL,NULVCL,,SORTT3  Ignore null entries		[PLB31]
       INCRA   XCL,DESCR	   Next index entry		[PLB31]
       SUM     A6PTR,WPTR,A5PTR	   Pointer to sort element is
       INCRA   A6PTR,2*DESCR	   WPTR + 2 + A5PTR   (0 or -1)
       PUTD    TPTR,XCL,A6PTR	   Add index entry
       AEQL    XCL,ZCL,,SORTGO	   J. if index fully loaded.	[PLB31]
SORTT3 INCRA   WPTR,2*DESCR	   Next table entry
       AEQL    WCL,WPTR,SORTT2	   If more in this extent
       GETDC   WPTR,WCL,2*DESCR	   Link to next extent
       BRANCH  SORTT1		   Process it
*_
* Source was an array.	Get new array to sort into.
*
SORTA  GETSIZ  WCL,WPTR		   Get size of old array
       SETVC   WCL,A		   Allocating array
       RCALL   XPTR,BLOCK,WCL	   Get new array
       SETAC   A4PTR,4*DESCR	   Size of header and dimensions
       MOVBLK  XPTR,WPTR,A4PTR	   Copy header descriptors
       SUM     TPTR,XPTR,WCL	   Last element of new array
       SUBTRT  TPTR,TPTR,ZCL	   - no. rows = start of index table-1
*
       SUBTRT  A5PTR,ZPTR,YPTR	   Offset to first element in row
       RESETF  A5PTR,PTR	   Clear pointer flag
       MOVA    A4PTR,ZCL	   Offset to advance a column
SORTA1 INCRA   XCL,DESCR	   Next index entry			[PLB31]
       INCRA   ZPTR,DESCR	   Next sort element
       PUTD    TPTR,XCL,ZPTR	   Add to index
       AEQL    XCL,ZCL,SORTA1	   Loop on no. of rows.			[PLB31]
*
*
* XPTR = New Array, YPTR = 1st element-1 in old array
* TPTR = Index table - 1 in new array
* SCL = 1/0 = RSORT/SORT, YCL = NC = no. columns, ZCL = N = no. rows
* A3PTR = Field Block if second argument was a field name.
*
* Setup: A6PTR = G, XCL = M, TCL = K, A7PTR = I, LPTR = J
* Scratch: A1PTR, A2PTR, F1PTR, F2PTR
*
SORTGO MOVA    A6PTR,ZCL	   G = N
*
SORT6  ACOMPC  A6PTR,DESCR,,SORT12,SORT12
*				   Done if G <= DESCR		[PLB31]
       DIVIDE  A6PTR,A6PTR,TWOCL   G = G/2
       MULTC   A6PTR,A6PTR,DESCR   Convert back to address units [PLB31]
       SUBTRT  XCL,ZCL,A6PTR	   M = N - G
*
SORT7  MOVD    TCL,ZEROCL	   K = 0
       SETAC   A7PTR,DESCR	   I = DESCR			[PLB31]
*
SORT8  SUM     LPTR,A7PTR,A6PTR	   J = I + G
       GETD    F1PTR,TPTR,A7PTR	   .A<I,C>
       GETD    F2PTR,TPTR,LPTR	   .A<J,C>
       GETDC   A1PTR,F1PTR,0	   A<I,C>
       GETDC   A2PTR,F2PTR,0	   A<J,C>
*
* COMPARE ELEMENTS IN A1PTR AND A2PTR
*
* was:								[PLB31]
*      DEQBRA  A1PTR,A2PTR,(VVQ,IRQ,RIQ,IIQ,RRQ),(CVV,CIRX,CRI,CII,CRR),COTH
SORT9  SETAV   DTCL,A1PTR	   Set up data type pair	[PLB31]
       MOVV    DTCL,A2PTR					[PLB31]
       DEQL    DTCL,VVDTP,,CVV	   STRING-STRING		[PLB31]
       DEQL    DTCL,IIDTP,,CII	   INTEGER-INTEGER		[PLB31]
       DEQL    DTCL,RIDTP,,CRI	   REAL-INTEGER			[PLB31]
       DEQL    DTCL,IRDTP,,CIRX	   INTEGER-REAL			[PLB31]
       DEQL    DTCL,RRDTP,,CRR	   REAL-REAL			[PLB31]
       BRANCH  COTH		   None of the above		[PLB31]
*_
CVV    LOCSP   XSP,A1PTR	   String/String
       LOCSP   YSP,A2PTR
       LEXCMP  XSP,YSP,CMPGT,CMPEQ,CMPLT			[PLB82]
*
CIRX  INTRL   A1PTR,A1PTR	   Integer/Real
       BRANCH  CRR		   Compare as reals
*_
CRI    INTRL   A2PTR,A2PTR	   Real/Integer
       BRANCH  CRR
*_
CII    ACOMP   A1PTR,A2PTR,CMPGT,CMPEQ,CMPLT			[PLB31]
*				   Compare integers
*_
CRR    NANCHK  A1PTR,,CRR1	   J. if R1 is NAN
       NANCHK  A2PTR,,CMPLT	   J. if R1 OK, R2 NAN
       RCOMP   A1PTR,A2PTR,CMPGT,CMPEQ,CMPLT
*				   R1 and R2 OK, straight compare
*_
CRR1   NANCHK  A2PTR,CMPGT,CMPEQ   R1 NAN, check R2
*_
* V2.18a On equal case, use ascending compare in all cases
CMPEQ  PCOMP   F1PTR,F2PTR,SWAP,CMPNXT,CMPNXT
*				   Elements =, compare array pos. [PLB88]
CMPGT  AEQLC   SCL,0,CMPNXT,SWAP   RSORT/SORT
CMPLT  AEQLC   SCL,0,,CMPNXT
*
SWAP   PUTD    TPTR,A7PTR,F2PTR	   Swap pointers
       PUTD    TPTR,LPTR,F1PTR
*
       INCRA   TCL,1		   K = K + 1
*
CMPNXT ACOMP   A7PTR,XCL,SORT11,SORT11,
*				   J. if I >= M
       INCRA   A7PTR,DESCR	   I = I + DESCR		[PLB31]
       BRANCH  SORT8
*_
SORT11 AEQLC   TCL,0,SORT7,SORT6   K = 0?
*_
COTH   AEQLC   A3PTR,0,,COTH2	   If 2nd arg not field name
       VCOMPC  A1PTR,DATSTA,,,COTH0
*				   If not user data type
       MOVV    DT1CL,A1PTR	   Datatype of element
       LOCAPT  ZPTR,A3PTR,DT1CL,INTR1,
*				   Find it in field block
       GETDC   ZPTR,ZPTR,2*DESCR   Get offset in datastructure
       SUM     A1PTR,A1PTR,ZPTR	   Point to real data
       GETDC   A1PTR,A1PTR,DESCR   Get value
       BRANCH  SORT9		   Try again
*_
COTH0  VCOMPC  A2PTR,DATSTA,,,COTH2
*				   If not user data type
       MOVV    DT1CL,A2PTR	   Datatype of element
       LOCAPT  ZPTR,A3PTR,DT1CL,INTR1,
*				   Find it in field block
       GETDC   ZPTR,ZPTR,2*DESCR   Get offset in datastructure
       SUM     A2PTR,A2PTR,ZPTR	   Point to real data
       GETDC   A2PTR,A2PTR,DESCR   Get value
       BRANCH  SORT9		   Try again
*
COTH2  VEQL    A1PTR,A2PTR,,COTH1  Other datatypes, J. if same
       SETAV   A1PTR,A1PTR	   Types not equal, compare them
       SETAV   A2PTR,A2PTR
COTH1  PCOMP   A1PTR,A2PTR,CMPGT,CMPEQ,CMPLT
*				   Compare addresses		[PLB88]
*_
* Sorting complete.  Now unravel index table as copy elements from old
* array to new.
*
* LPTR = Row counter
* TPTR = Index table - 1 in new array
* WPTR = 1st element of row being transferred in new array
* XPTR = New array
* YPTR = Row ptr of row being transferred in new array
* ZPTR = Row ptr of row being transferred in old array
* YCL  = No. columns
* ZCL  = No. rows
* A4PTR = offset to get from one column to another in same row
*	(= no. rows for arrays)
* A5PTR = offset to get from sort element to first element in row
*
SORT12 GETDC   XCL,XPTR,2*DESCR	   Get no. dimensions
       MULTC   WPTR,XCL,DESCR	   Convert to address units
       SUM     WPTR,XPTR,WPTR	   Add base and offset
       INCRA   WPTR,3*DESCR	   Add 2 for heading + 1 for 1st row
       MOVD    LPTR,ONECL	   Set up row counter
       MULTC   LPTR,LPTR,DESCR	   Convert to address units	[PLB31]
*				   Move a row:
SORT13 GETD    ZPTR,TPTR,LPTR	   Ptr to source sort element
       SUBTRT  ZPTR,ZPTR,A5PTR	   Ptr to first element in row
       MOVD    YPTR,WPTR	   Index to target
       MOVA    A6PTR,YCL	   Number of columns
       MULTC   A6PTR,A6PTR,DESCR   Convert to address units	[PLB31]
*				   Move all elements in this row:
SORT14 MOVDIC  YPTR,0,ZPTR,0	   Move an element in row
       SUM     ZPTR,ZPTR,A4PTR	   Offset to advance a column
       SUM     YPTR,YPTR,ZCL	   Advance by length of column
       DECRA   A6PTR,DESCR	   Count column done		[PLB31]
       AEQLC   A6PTR,0,SORT14,	   Move another element in row
*
       INCRA   WPTR,DESCR	   Do next row
       INCRA   LPTR,DESCR	   More rows left?
       PCOMP   LPTR,ZCL,,SORT13,SORT13				[PLB88]
*
       PUSH    (ZEROCL,ZEROCL,ZEROCL,ZEROCL)
*				   Kill some pointers
       POP     (YPTR,ZPTR,F1PTR,F2PTR)
       BRANCH  RTXPTR
*_
*---------------------------------------------------------------------*
       TITLE   'Input and Output'
*
*      INPUT(V,U,O,N)						[PLB4]
*
READ   PROC    ,		   INPUT(V,U,O,N)		[PLB4]
       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 options			[PLB51]
       POP     (YPTR)		   Restore unit			[PLB4]
       ACOMPC  YPTR,0,,READ5,UNTERR
*				   Check for defaulted unit
READ6  PUSH    (YPTR,ZPTR)	   Save unit, options		[PLB4][PLB51]
       RCALL   TPTR,VARVAL,,FAIL   Get optional file spec!	[PLB4]
       LOCSP   XSP,TPTR		   Get specifier for filename	[PLB4]
       POP     (ZPTR,YPTR,XPTR)	   Restore opts, unit and variable [PLB4][PLB51]
       LOCSP   ZSP,ZPTR		   Get specifier for options	[PLB51]
       MOVD    ZPTR,ZEROCL	   Clear length			[PLB51]
       XCALLC  IO_OPENI,(YPTR,XSP,ZSP,ZPTR),FAIL		[PLB51][PLB86]
*				   Tell I/O routines about filename [PLB4]
       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,O,N)						[PLB4]
*
PRINT  PROC    ,		   OUTPUT(V,U,O,N)		[PLB4]
       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
       PUSH    ZPTR		   Save format			[PLB4]
       RCALL   TPTR,VARVAL,,FAIL   Get optional filename	[PLB4]
       POP     (ZPTR,YPTR,XPTR)	   Restore format, unit and variable [PLB4]
       LOCSP   XSP,TPTR		   Get specifier for filename	[PLB4]
       LOCSP   ZSP,ZPTR		   Get specifier for format	[PLB51]
       XCALLC  IO_OPENO,(YPTR,XSP,ZSP),FAIL			[PLB51][PLB86]
*				   Tell I/O routines about filename! [PLB4]
       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
*_
ENDFIL PROC    BKSPCE		   ENDFILE(N)			[PLB86]
       SETAC   SCL,2		   Indicate end of file
       BRANCH  IOOP
*_
REWIND PROC    BKSPCE		   REWIND(N)
       SETAC   SCL,3		   Indicate rewind
       BRANCH  IOOP						[PLB52]
*_
SET    PROC    BKSPCE		   SET(N,O,W)			[PLB52]
       SETAC   SCL,4		   Indicate set
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,SOP)  Select operation		[PLB52]
       BKSPCE  XCL		   Backspace unit
       BRANCH  RETNUL
*_
EOP    ENFILE  XCL,COMP6	   End file unit		[PLB60]
       BRANCH  RETNUL
*_
ROP    REWIND  XCL		   Rewind unit
       BRANCH  RETNUL
*_
SOP    PUSH    XCL		   Save unit			[PLB52]
       RCALL   XPTR,INTVAL,,FAIL   Get offset			[PLB52]
       PUSH    XPTR		   Save offset			[PLB52]
       RCALL   YPTR,INTVAL,,FAIL   Get whence			[PLB52]
       POP     (XPTR,XCL)	   Restore offset, unit		[PLB52]
       XCALLC  IO_SEEK,(XCL,XPTR,YPTR),FAIL,RTXPTR		[PLB52][PLB86]
*				   Set (seek) unit		[PLB52]
*_
*---------------------------------------------------------------------*
*
*      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
*_
*---------------------------------------------------------------------*
*
*      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
       RCALL   IO4PTR,CONVAR,(IO1PTR)
*				   Get space for string
       LOCSP   IOSP,IO4PTR	   Get specifier
       INCRA   RSTAT,1		   Increment count of reads
       STREAD  IOSP,IO3PTR,FAIL,COMP5
*				   Perform read
       AEQLC   TRIMCL,0,,PUTIN1	   Check &INPUT
       TRIMSP  IOSP,IOSP	   Trim string
PUTIN1 GETLG   IO1PTR,IOSP	   Get length			[PLB19]
       ACOMP   IO1PTR,MLENCL,INTR8				E3.9.2 [PLB19]
       VEQLC   IO2PTR,K,,PUTIN3	   CHECK FOR KEYWORD		E3.10.2
       RCALL   IO1PTR,GNVARS,IO1PTR				E3.9.2
*				   Form variable for string
PUTIN2 PUTDC   IO2PTR,DESCR,IO1PTR				E3.10.2
       RRTURN  IO1PTR,2		   Return value
PUTIN3 LOCSP   XSP,IO1PTR					E3.10.2
       SPCINT  IO1PTR,XSP,INTR1,PUTIN2				E3.10.2
*_
*---------------------------------------------------------------------*
*
*      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   LOCSP   IOSP,IO2PTR	   Get specifier
PUTVU  STPRNT  IOKEY,IO1PTR,IOSP   Perform print
       AEQLC   IOKEY,0,,COMP6	   Check status			[PLB60]
       INCRA   WSTAT,1		   Increment count of writes
       BRANCH  RTN1		   Return
*_
PUTI   INTSPC  IOSP,IO2PTR	   Convert INTEGER to STRING
       BRANCH  PUTVU		   Rejoin processing
*_
*---------------------------------------------------------------------*
       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,VARVUP,,FAIL   Get trace type		[PLB28]
       PUSH    YPTR		   Save type
       RCALL   WPTR,ARGVAL,,FAIL   Get tag
       PUSH    WPTR		   Save tag
       RCALL   ZPTR,VARVUP,,FAIL   Get trace function		[PLB28]
       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
       BRANCH  TRACEP		   Branch to subentry		[PLB73]
*_
* moved [PLB73]
TRAC1  DEQL    YPTR,FUNTCL,,TRACF  Is type FUNCTION?		[PLB115]
       DEQL    YPTR,EFFCL,INTR30   Is 'F'?			[PLB115]
TRACF  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
*_
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,5*DESCR					V3.7
       SETVC   XSIZ,C		   Insert CODE data type
       RCALL   XCL,BLOCK,XSIZ	   Allocate block for code
       MOVBLK  XCL,TRCBLK,XSIZ					V3.7
       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
*_
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,VARVUP,,FAIL   Get trace respect		[PLB28]
       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
       BRANCH  STOPTP		   Branch to FUNCTION subentry	[PLB73]
*_
* moved [PLB73]
STOPT1 DEQL    YPTR,FUNTCL,,STOPTF Check for FUNCTION		[PLB115]
       DEQL    YPTR,EFFCL,INTR30   Check for FUNCTION		[PLB115]
STOPTF MOVD    YPTR,TFNCLP	   Set up CALL			[PLB115]
       RCALL   ,STOPTP,,(FAIL,INTR10)
*				   Call subprocedure
       MOVD    YPTR,TFNRLP	   Set up RETURN
       BRANCH  STOPTP		   Branch to subentry
*_
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
*_
*---------------------------------------------------------------------*
*
*      Call Tracing
*
FENTR  PROC    ,		   Procedure to trace on CALL
       RCALL   WPTR,VARVAL,,FAIL   Get argument
FENTR3 SETLC   PROTSP,0		   Clear specifier
       LOCSP   XSP,FILENM	   Get specifier for &FILE	[PLB90]
       APDSP   PROTSP,XSP	   Append &FILE			[PLB90]
       APDSP   PROTSP,COLSP	   Append colon			[PLB90]
       INTSPC  XSP,LNNOCL	   Convert &LINE to string	[PLB90]
       APDSP   PROTSP,XSP	   Append &LINE			[PLB90]
       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,SPCSP	   Append space			[PLB95]
       APDSP   PROTSP,TRLVSP	   Append level message
       INTSPC  XSP,LVLCL	   Convert &FNCLEVEL to string
       APDSP   PROTSP,XSP	   Append &FNCLEVEL
       APDSP   PROTSP,TRCLSP	   Append call message
       LOCSP   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  LOCSP   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
       SBREAL  ZPTR,ZPTR,ETMCL	   Compute elapsed time		[PLB71]
       REALST  XSP,ZPTR		   Convert to STRING		[PLB71]
       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  OUTPUT  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
       LOCSP   XSP,WPTR		   Get specifier
       RCALL   YCL,KEYT,(WPTR),(INTR10,)
*				   Get value of keyword
KEYTR3 SETLC   PROTSP,0		   Clear specifier
       LOCSP   TSP,FILENM	   Get specifier for &FILE	[PLB90][PLB113]
       APDSP   PROTSP,TSP	   Append &FILE			[PLB90][PLB113]
       APDSP   PROTSP,COLSP	   Append colon			[PLB90]
       INTSPC  TSP,LNNOCL	   Convert &LINE to string	[PLB90][PLB113]
       APDSP   PROTSP,TSP	   Append &LINE			[PLB90][PLB113]
       APDSP   PROTSP,TRSTSP	   Append trace message
       INTSPC  TSP,STNOCL	   Convert &STNO to string
       APDSP   PROTSP,TSP	   Append &STNO
       APDSP   PROTSP,COLSP	   Append colon
       APDSP   PROTSP,SPCSP	   Append space			[PLB95]
       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
       SBREAL  YPTR,YPTR,ETMCL	   Compute elapsed time		[PLB71]
       REALST  XSP,YPTR		   Convert time to STRING	[PLB71]
       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
       LOCSP   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    (FILENM,LNNOCL,LSTNCL,STNOCL,FRTNCL,OCBSCL,OCICL,TRAPCL,TRACL)
*				   Save system descriptors	[PLB38]
       PUSH    (LSFLNM,LSLNCL)	   Save &LAST{FILE,LINE}	[PLB112]
       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
       RCALL   ,INVOKE,XPTR					E3.3.1[PLB84]
*				   Evaluate function
       POP     (LSLNCL,LSFLNM)	   Restore &LAST{FILE,LINE}	[PLB112]
       POP     (TRACL,TRAPCL,OCICL,OCBSCL,FRTNCL,STNOCL,LSTNCL,LNNOCL,FILENM)
*				   Restore system descriptors	[PLB38]
       BRANCH  RTN1						E3.3.1
*_
*---------------------------------------------------------------------*
*
*      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
       LOCSP   XSP,FILENM	   Get specifier for &FILE	[PLB90]
       APDSP   TRACSP,XSP	   Append &FILE			[PLB90]
       APDSP   TRACSP,COLSP	   Append colon			[PLB90]
       INTSPC  XSP,LNNOCL	   Convert &LINE to string	[PLB90]
       APDSP   TRACSP,XSP	   Append &LINE			[PLB90]
       APDSP   TRACSP,TRSTSP	   Append trace message
       INTSPC  XSP,STNOCL	   Convert &STNO to string
       APDSP   TRACSP,XSP	   Append &STNO
       APDSP   TRACSP,COLSP	   Append colon
       APDSP   TRACSP,SPCSP	   Append space			[PLB95]
       AEQLC   FNVLCL,0,,FNEXT1	   Check entry indicator
       VEQLC   XPTR,S,DEFDT	   Is variable a string?
VALTR3 LOCSP   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    LOCSP   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
       SBREAL  YPTR,YPTR,ETMCL	   Compute time in interpreter	[PLB71]
       REALST  XSP,YPTR		   Convert to STRING		[PLB71]
       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  LOCSP   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
       LOCSP   XSP,RETPCL	   Get specifier for return
       APDSP   TRACSP,XSP	   Append return type
       APDSP   TRACSP,OFSP	   Append ' OF '
       DEQL    RETPCL,FRETCL,VALTR3
*				   Check for FRETURN
       LOCSP   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  OUTPUT  OUTPUT,PRTOVF	   Print error message
       BRANCH  RTNUL3		   Return
*_
*---------------------------------------------------------------------*
*
* New [PLB97]
*      SETEXIT(LBL)
*
SETXIT PROC    ,		   SETEXIT(LBL)
       RCALL   XPTR,VARVUP,,INTR30 Get label
       AEQLC   XPTR,0,,SETXI2	   Allow null string (clear handler)
       GETDC   YPTR,XPTR,ATTRIB    Get label code base
       AEQLC   YPTR,0,,INTR30	   Fatal if no code
SETXI2 MOVD    YPTR,XITPTR	   Fetch old handler		[PLB100]
       MOVD    XITPTR,XPTR	   Save new handler
       BRANCH  RTYPTR		   Return old value		[PLB100]
*_
*---------------------------------------------------------------------*
*
* New [PLB97]
*      SETEXIT handler
*
XITHND PROC    ,		   SETEXIT handling procedure
       AEQLC   XITPTR,0,,FAIL	   Handler not set
       MOVD    XFILEN,FILENM	   Save &FILE
       MOVD    XLNNOC,LNNOCL	   Save &LINE			[PLB98]
       MOVD    XSTNOC,STNOCL	   Save &STNO
       MOVD    XLSFLN,LSFLNM	   Save &LASTFILE
       MOVD    XLSLNC,LSLNCL	   Save &LASTLINE		[PLB98]
       MOVD    XLNNOC,LNNOCL	   Save &LASTNO
       MOVD    XERRTY,ERRTYP	   Save &ERRTYPE
       MOVD    XOCBSC,OCBSCL	   Save code base
       MOVD    XFRTNC,FRTNCL	   Save failure offset
       MOVD    XOCICL,OCICL	   Save code offset
       GETDC   OCBSCL,XITPTR,ATTRIB  Get new object code base
       AEQLC   OCBSCL,0,,INTR4	   Must not be zero
       SETAC   FRTNCL,0		   Zero offset
       SETAC   XITPTR,0		   Clear handler
       MOVD    LSTNCL,STNOCL	   Update &LASTNO		[PLB109]
       MOVA    LSLNCL,LNNOCL	   Update &LASTLINE		[PLB109]
       MOVA    LSFLNM,FILENM	   Update &LASTFILE		[PLB109]
       BRANCH  RETNUL
*_
*---------------------------------------------------------------------*
       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,,RTYPTR,RTYPTR				[PLB32]
*				   Return value, imbedded asgn	[PLB32]
       LOCAPT  ATPTR,TVALL,XPTR,RTYPTR				[PLB32]
*				   Look for VALUE trace
       PUSH    YPTR						[PLB32]
       RCALL   ,TRPHND,ATPTR,					E3.3.1 [PLB32]
       POP     YPTR						[PLB32]
       BRANCH  RTYPTR						[PLB32]
*_
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)
*
CONCAT PROC    ,		   X Y (concatenation)		[PLB74]
       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?
.IF BLOCKS
       VEQLC   XPTR,BL,,CON5	   Is first BLOCK?		[BLOCKS]
.FI
       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?
.IF BLOCKS
       VEQLC   YPTR,BL,,CON7	   Is second BLOCK?		[BLOCKS]
.FI
       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
.IF BLOCKS
       DEQL    DTCL,PPDTP,CCATB,CONPP
*				   Check for PATTERN-PATTERN
*				   Else hand to BLOCKS code
.FI
.IFE BLOCKS
       DEQL    DTCL,PPDTP,INTR1,CONPP
*				   Check for PATTERN-PATTERN
.FI
*_
CONVP  LOCSP   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  LOCSP   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
*_
* [PLB117] moved
CONVV  LOCSP   XSP,XPTR		   Specifier for first string
       LOCSP   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
       LOCSP   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
*_
*---------------------------------------------------------------------*
*
*      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,,NONAME
*				   Be sure string is not null	[PLB29]
       AEQLC   CASECL,0,VPXPTR,RTXNAM
*				   Return name			[PLB30]
*_
*---------------------------------------------------------------------*
*
*      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
.IF BLOCKS
       GETDC   YPTR,XPTR,DESCR					[BLOCKS]
       VEQLC   YPTR,I,,KEYN1	   Is value an integer?		[BLOCKS]
       SETVC   XPTR,N		   No, take any value		[BLOCKS]
       BRANCH  RTXNAM		       	    			[BLOCKS]
KEYN1  LHERE							[BLOCKS]
.FI
       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
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   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,(FAIL,NMD5,NEMO)		E3.10.5
*				   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
*_
*---------------------------------------------------------------------*
*
* New [PLB80]
*      FUNCTION(X) test if named function defined
*
FUNCTN PROC    ,		   FUNCTION(X)
       RCALL   XPTR,VARVUP,,FAIL   Evaluate argument	[PLB99]
       LOCAPV  XPTR,FNCPL,XPTR,FAIL Locate function	[PLB99]
       GETDC   XPTR,XPTR,DESCR	   Get function descriptor [PLB99]
       GETDC   XPTR,XPTR,0	   Get link descriptor	[PLB99]
       AEQL    XPTR,UNDFCL,RETNUL,FAIL			[PLB99]
*				   Fail if undefined	[PLB99]
*_
*---------------------------------------------------------------------*
*
*      IDENT(X,Y)
*
IDENT  PROC    ,		   IDENT(X,Y)
       RCALL   ,XYARGS,,FAIL	   Evaluate arguments
       DEQL    XPTR,YPTR,FAIL,RETNUL
*				   Compare arguments
*_
*---------------------------------------------------------------------*
*
* New [PLB78] idea from Steve Duff's Macro SPITBOL
*      LABEL(X)
*
LABEL  PROC    ,		   LABEL(X)
       RCALL   ,VARVUP,,FAIL	   Evaluate argument		[PLB79]
       AEQLC   XPTR,0,,FAIL	   Check for null		[PLB111]
       GETDC   XPTR,XPTR,ATTRIB    Get object code base
       AEQLC   XPTR,0,RETNUL,FAIL  Fail if zero
*_
*---------------------------------------------------------------------*
*
* New [PLB37] copied from LGT
*      LEQ(X,Y)
*
LEQ    PROC    ,		   LEQ(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
       DEQL    XPTR,YPTR,FAIL,RETNUL
*				   See if IDENT()		[PLB76]
*_
*---------------------------------------------------------------------*
*
* New [PLB37] copied from LGT
*      LGE(X,Y)
*
LGE    PROC    ,		   LGE(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
       DEQL    XPTR,YPTR,,RETNUL   If IDENT() no need to compare [PLB76]
       AEQLC   XPTR,0,,FAIL	   Null is not greater than anything
       AEQLC   YPTR,0,,RETNUL	   Similarly for second argument
       LOCSP   XSP,XPTR		   Get specifier to first argument
       LOCSP   YSP,YPTR		   Get specifier to second argument
       LEXCMP  XSP,YSP,RETNUL,RETNUL,FAIL
*				   Compare lexically
*_
*---------------------------------------------------------------------*
*
*      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
       DEQL    XPTR,YPTR,,FAIL	   If IDENT() no need to compare [PLB76]
       AEQLC   XPTR,0,,FAIL	   Null is not greater than anything
       AEQLC   YPTR,0,,RETNUL	   Similarly for second argument
       LOCSP   XSP,XPTR		   Get specifier to first argument
       LOCSP   YSP,YPTR		   Get specifier to second argument
       LEXCMP  XSP,YSP,RETNUL,FAIL,FAIL
*				   Compare lexically
*_
*---------------------------------------------------------------------*
*
* New [PLB37] copied from LGT
*      LLE(X,Y)
*
LLE    PROC    ,		   LLE(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
       DEQL    XPTR,YPTR,,RETNUL   If IDENT() no need to compare [PLB76]
       AEQLC   XPTR,0,,RETNUL	   Null is less than everything	 [PLB76]
       AEQLC   YPTR,0,,FAIL	   Similarly for second argument [PLB76]
       LOCSP   XSP,XPTR		   Get specifier to first argument
       LOCSP   YSP,YPTR		   Get specifier to second argument
       LEXCMP  XSP,YSP,FAIL,RETNUL,RETNUL
*				   Compare lexically
*_
*---------------------------------------------------------------------*
*
* New [PLB37] copied from LGT
*      LLT(X,Y)
*
LLT    PROC    ,		   LLT(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
       DEQL    XPTR,YPTR,,FAIL     If IDENT() no need to compare [PLB76]
       AEQLC   XPTR,0,,RETNUL	   Null is less than everything	 [PLB76]
       AEQLC   YPTR,0,,FAIL	   Similarly for second argument [PLB76]
       LOCSP   XSP,XPTR		   Get specifier to first argument
       LOCSP   YSP,YPTR		   Get specifier to second argument
       LEXCMP  XSP,YSP,FAIL,FAIL,RETNUL
*				   Compare lexically
*_
*---------------------------------------------------------------------*
*
* New [PLB37] copied from LGT
*      LNE(X,Y)
*
LNE    PROC    ,		   LNE(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
       DEQL    XPTR,YPTR,RETNUL,FAIL
*				   Must DIFFER()	[PLB76]
*_
*---------------------------------------------------------------------*
*
*      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
*_
*---------------------------------------------------------------------*
*
* New [PLB31] from SNOBOL4+
*      CHAR(N)
*
CHAR   PROC    ,		   CHAR(N)
       RCALL   XCL,INTVAL,,FAIL	   Get argument
       ACOMPC  XCL,0,,,LENERR	   Must be > 0
       ACOMPC  XCL,256,INTR30,INTR30,
*				   Must be <256 (ALPHSZ)
       RCALL   XPTR,CONVAR,ONECL,  Allocate space for result
       LOCSP   XSP,XPTR		   Get specifier
%{
	*S_SP(XSP) = D_A(XCL);	   /* Store argument as char */
%}
       RCALL   XPTR,GNVARS,ONECL,  Fix in memory
       BRANCH  RTXPTR
*_
*---------------------------------------------------------------------*
*
* New [PLB31] from Minnesota SNOBOL4 and SNOBOL4+
*      LPAD, RPAD(S,N,C)
*
LPAD   PROC    ,		   LPAD(S,N,C)
       SETAC   SCL,0
       BRANCH  RPAD0
*_
RPAD   PROC    ,		   RPAD(S,N,C)
       SETAC   SCL,1
RPAD0  PUSH    SCL		   Protect SCL
       RCALL   XPTR,VARVAL,,FAIL   Get 1st arg=string
       PUSH    XPTR		   Save string
       RCALL   ZPTR,INTVAL,,FAIL   Get 2rd arg=integer length
       PUSH    ZPTR
       RCALL   WPTR,VARVAL,,FAIL   Get pad character if any
       POP     (ZPTR,XPTR,SCL)	   Restore length, string, direction
       LOCSP   VSP,WPTR		   Pad character
       LOCSP   XSP,XPTR		   Subject string
       ACOMP   ZPTR,MLENCL,INTR8   Check against &MAXLNGTH
       ACOMP   ZEROCL,ZPTR,LENERR  Make sure length not minus
       GETLG   YPTR,XSP		   Subject string length
       ACOMP   YPTR,ZPTR,RTXPTR,RTXPTR
*				   Return subject if already long enough
       MOVA    XCL,ZPTR		   Copy length (for GENVSZ)	[PLB82]
       RCALL   ZPTR,CONVAR,XCL	   Allocate space for string
       LOCSP   TSP,ZPTR		   Get specifier
       XCALLC  PAD,(SCL,TSP,XSP,VSP)				[PLB86]
*				   Do function (dir,out,subj,pad)
       BRANCH  GENVSZ		   Return the string
*_
*---------------------------------------------------------------------*
       TITLE   'Other Functions'
*
*      APPLY(F,A1,...AN)
*
APPLY  PROC    ,		   APPLY(F,A1,...,AN)
       SETAV   XCL,INCL		   Get count of arguments
       DECRA   XCL,1		   Decrement to skip function name
       ACOMPC  XCL,1,,,ARGNER					E3.3.3
       PUSH    XCL		   Save argument count
       RCALL   XPTR,VARVUP,,FAIL   Get function name		[PLB28]
       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
*_
*---------------------------------------------------------------------*
*
*      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,VARVUP,,FAIL   Get function name		[PLB28]
       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 PCOMP   DMPPTR,OBEND,RETNUL Check for end		[PLB88]
       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
*_
*---------------------------------------------------------------------*
*
* New [PLB32]
*	(e1, e2, ... , en)	(Selection - from SPITBOL) ; 
*
CMA    PROC    ,
       SETAV   ZCL,INCL		   Get number of arguments
CMA1   AEQLC   ZCL,0,,FAIL	   Fail if all arguments failed
       PUSH    (ZCL,OCBSCL,OCICL)  Save count, code position
       RCALL   XPTR,ARGVAL,,CMA2   Evaluate next argument
       POP     (OCICL,OCBSCL,ZCL)  Success!    Restore count and position
       RCALL   ,CODSKP,ZCL,RTXPTR  Skip this and remaining args
CMA2   POP     (OCICL,OCBSCL,ZCL)  Arg evaluation failed
       DECRA   ZCL,1		   One less arg left
       RCALL   ,CODSKP,ONECL,CMA1  Skip this arg, try next one
*_
*---------------------------------------------------------------------*
*
*      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,VARVUP,,FAIL   Get data type target		[PLB28]
       POP     ZPTR		   Restore object
       LOCAPV  XPTR,DTATL,YPTR,CNV1				[PLB32]
*				   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
       VEQL    ZPTR,XPTR,,RTZPTR				E3.0.4
       VEQLC   XPTR,S,FAIL,CNVRTS				E3.0.4
*				   Check for idem-conversion
*_
CNV1   LOCSP   YSP,YPTR						[PLB32]
       LEXCMP  YSP,NUMSP,INTR1,,INTR1				[PLB32]
*				   NUMERIC?			[PLB32]
       VEQLC   ZPTR,I,,RTZPTR	   Yes; If integer, no change	[PLB32]
       VEQLC   ZPTR,R,,RTZPTR	   If real, no change		[PLB32]
       VEQLC   ZPTR,S,FAIL	   If not string, can't convert	[PLB32]
       LOCSP   ZSP,ZPTR		   Get specifier		[PLB32]
       SPCINT  ZPTR,ZSP,,RTZPTR	   Try conversion to INTEGER	[PLB32]
       SPREAL  ZPTR,ZSP,FAIL,RTZPTR				[PLB32]
*				   Try conversion to REAL	[PLB32]
*_
RECOMP SETAC   SCL,1		   Note STRING-CODE conversion
RECOMJ LOCSP   TEXTSP,ZPTR	   Set up global specifier
RECOMT GETLG   OCALIM,TEXTSP					E3.1.5
       AEQLC   OCALIM,0,,RECOMN					E3.1.5
       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
       BRANCH  RECOMZ						[PLB73]
*_
RECOMF SETAC   SCL,1		   Set failure return
       BRANCH  RECOMQ		   Rejoin processing
*_
RECOMN SETSP   TEXTSP,BLSP					E3.1.5
       BRANCH  RECOMT						E3.1.5
*_								E3.1.5
* moved to end (used by CONVEX) [PLB73]
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
*_
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
       MOVD    ZPTR,CMBSCL					E3.1.6
       SETVC   ZPTR,E		   Insert EXPRESSION data type
       SETAC   SCL,3		   Set return branch
       BRANCH  RECOMZ		   Join common program
*_
CONVR  LOCSP   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  LOCSP   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
*_
CNVTA  MOVD    WPTR,ZPTR	   Make copy of input pointer	[PLB31]
       RCALL   ZPTR,ICNVTA,ZPTR,(FAIL)				[PLB31]
*				   Allocate array to hold table	[PLB31]
       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
CNVTA8 GETSIZ  WCL,WPTR						E3.2.3
       DECRA   WCL,2*DESCR					E3.2.3
       SUM     WCL,WPTR,WCL					E3.2.3
CNVTA3 GETDC   TCL,WPTR,DESCR					E3.2.3
       DEQL    TCL,NULVCL,,CNVTA5				E3.2.3
       PUTDC   TPTR,0,TCL					E3.2.3
       MOVDIC  YPTR,0,WPTR,2*DESCR
       INCRA   YPTR,DESCR	   Increment upper pointer
       INCRA   TPTR,DESCR	   Increment lower pointer
CNVTA5 INCRA   WPTR,2*DESCR
       AEQL    WCL,WPTR,CNVTA3					E3.2.3
       GETDC   WPTR,WCL,2*DESCR					E3.2.3
       AEQLC   WPTR,1,CNVTA8					E3.8.1
       SETAC   TPTR,0						E3.8.1
       BRANCH  RTZPTR						E3.8.1
*_
*---------------------------------------------------------------------*
*
* New [PLB31] from SNOBOL4+
*      created from CNVTA -- common code for CONVERT/SORT
*
*      Initial Conversion of Table to Array.
*      Scans table counting elements, fails if all null.
*      Allocates block for array, installs proper heading and dimemnsions in
*      block, but does not copy table elements over.
*
*      RCALL   ZPTR,ICNVTA,TPTR,(FAIL)
*
* Side effects of call:
*      YCL = Item count
*
ICNVTA PROC    CNVRT
       POP     YPTR				
       MOVD    YCL,ZEROCL					E3.2.3
CNVTA7 GETSIZ  XCL,YPTR						E3.2.3
       MOVD    ZCL,XCL						E3.2.3
       DECRA   XCL,3*DESCR					E3.2.3
CNVTA1 GETD    WCL,YPTR,XCL	   Get item value
       DEQL    WCL,NULVCL,,CNVTA2  Check for null value
       INCRA   YCL,1		   Otherwise count item
CNVTA2 AEQLC   XCL,DESCR,,CNVTA6
       DECRA   XCL,2*DESCR	   Count down
       BRANCH  CNVTA1		   Process next item
*_
CNVTA6 GETD    YPTR,YPTR,ZCL
       AEQLC   YPTR,1,CNVTA7,
       AEQLC   YCL,0,,FAIL	   Fail on empty table		[PLB82]
       MULTC   XCL,YCL,2*DESCR	   Convert count to address units
       INTSPC  YSP,YCL		   Get prototype for size
       SETLC   PROTSP,0		   Clear specifier		[PLB31]
       APDSP   PROTSP,YSP	   Append length		[PLB31]
       APDSP   PROTSP,CMASP	   Append comma			[PLB31]
       MOVD    WCL,ZEROCL
       SETAC   WCL,2		   Set up 2 for second dimension
       INTSPC  XSP,WCL		   Convert to string
       APDSP   PROTSP,XSP	   Append 2			[PLB31]
       SETSP   XSP,PROTSP	   Move specifier		[PLB31]
       RCALL   TPTR,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
       MOVD    ATPRCL,TPTR
       SETVA   ATEXCL,YCL	   Insert First dimension in head
       MOVBLK  ZPTR,ATRHD,FRDSCL   Copy heading information
       RRTURN  ZPTR,2
*_
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
       DECRA   XCL,2*DESCR				E3.2.3
       RCALL   XPTR,BLOCK,XCL,	   Allocate block for pair list
       SETVC   XPTR,T				E3.2.3
       GETDC   YCL,ZPTR,4*DESCR				E3.2.3
       MOVD    ZPTR,XPTR				E3.2.3
       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
       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   XPTR,ARGVAL,,FAIL   Get argument			[PLB55]
       DATE    ZSP,XPTR		   Get the date			[PLB55]
       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   PCOMP   WPTR,OBEND,RETNUL   Check for end		[PLB88]
       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
       LOCSP   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
       VEQLC   XPTR,T,DMPRT	   Table? if not, just print it	[PLB34]
       TESTFI  XPTR,FRZN,DMPRT	   No action if not frozen	[PLB34][PLB82]
       APDSP   DMPSP,FRZNSP	   Append " - FROZEN"		[PLB34]
       BRANCH  DMPRT		   Go print it
*_
DMPV   LOCSP   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 OUTPUT  OUTPUT,PRTOVF	   Print error message
       BRANCH  DMPA		   Continue
*_
DMK    PROC    ,		   Procedure to dump keywords
       OUTPUT  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
       LOCSP   XSP,XPTR		   Get specifier
       SETLC   DMPSP,0		   Clear specifier
       APDSP   DMPSP,AMPSP	   Append ampersand
       APDSP   DMPSP,XSP	   Append name
       APDSP   DMPSP,BLEQSP	   Append ' = '
.IF BLOCKS
       VEQLC   YPTR,S,,DMPKV	   Is string?			[BLOCKS]
.FI
       APDSP   DMPSP,YSP	   Append value
.IF BLOCKS
DMPK2  LHERE   			      				[BLOCKS]
.FI
       STPRNT  IOKEY,OUTBLK,DMPSP  Print line
       DECRA   XCL,DESCR	   Adjust offset
       AEQLC   XCL,0,DMPK1,RTN1	   Check for end
*_
.IF BLOCKS
DMPKV  LOCSP   YSP,YPTR						[BLOCKS]
       APDSP   DMPSP,QTSP	   Append quote			[BLOCKS]
       GETLG   YCL,YSP						[BLOCKS]
       ACOMPC  YCL,BUFLEN-20,DMPK3 Skip if value is large	[BLOCKS]
       APDSP   DMPSP,YSP	   Append value			[BLOCKS]
DMPK3  APDSP   DMPSP,QTSP	   Append quote			[BLOCKS]
       BRANCH  DMPK2		   	  			[BLOCKS]
*_
.FI      
*---------------------------------------------------------------------*
*
*      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
       LOCSP   XSP,XPTR		   Get specifier
       GETLG   XCL,XSP		   Get length
       MULT    XCL,XCL,YPTR,AERROR				E3.9.3
       ACOMP   XCL,MLENCL,INTR8	   Check &MAXLNGTH
       RCALL   ZPTR,CONVAR,XCL	   Allocate space for string
       LOCSP   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(F1,F2,N)
*
OPSYN  PROC    ,		   OPSYN(F,G,N)
       RCALL   XPTR,VARVUP,,FAIL   Get object function		[PLB28]
       PUSH    XPTR		   Save object function
       RCALL   YPTR,VARVUP,,FAIL   Get image function		[PLB28]
       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   RCALL   YPTR,FINDEX,YPTR					E3.6.2
OPPD   MOVDIC  XPTR,0,YPTR,0	   Move procedure descriptor pair
       MOVDIC  XPTR,DESCR,YPTR,DESCR
       BRANCH  RETNUL
*_
UNYOP  LOCSP   XSP,XPTR		   Get specifier for image
       LEQLC   XSP,1,UNAF	   Length must be 1 for operator
       SETSP   ZSP,PROTSP					E3.5.3
       SETLC   ZSP,0						E3.5.3
       APDSP   ZSP,XSP						E3.5.3
       APDSP   ZSP,LPRNSP					E3.5.3
       STREAM  TSP,ZSP,UNOPTB,UNAF,UNAF				E3.5.3
       MOVD    XPTR,STYPE	   STYPE has function descriptor
UNCF   LOCSP   YSP,YPTR		   Get specifier for image
       LEQLC   YSP,1,UNBF	   Length must be 1 for operator
       SETSP   ZSP,PROTSP					E3.5.3
       SETLC   ZSP,0						E3.5.3
       APDSP   ZSP,YSP						E3.5.3
       APDSP   ZSP,LPRNSP					E3.5.3
       STREAM  TSP,ZSP,UNOPTB,UNBF,UNBF				E3.5.3
       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  LOCSP   XSP,XPTR		   Get specifier for image
       LCOMP   XSP,EQLSP,BNAF	   Length must be 2 or less
       SETSP   ZSP,PROTSP					E3.5.3
       SETLC   ZSP,0						E3.5.3
       APDSP   ZSP,XSP						E3.5.3
       APDSP   ZSP,BLSP						E3.5.3
       AEQLC   SPITCL,0,BNYOP2	   SPITBOL ops enabled?		[PLB32]
.IF BLOCKS
       AEQLC   BLOKCL,0,BNYOP4	   BLOCKS enabled?		[PLB117]
.FI
       STREAM  TSP,ZSP,BIOPTB,BNAF,BNAF				E3.5.3
       BRANCH  BNYOP3						[PLB32]
*_
.IF BLOCKS
* SNOBOL4B, no SPITBOL ops
BNYOP4 STREAM  TSP,ZSP,BBIOPTB,BNAF,BNAF			[PLB117]
       BRANCH  BNYOP3						[PLB117]
*_
.FI
* here with SPITBOL ops enabled
BNYOP2 LHERE
.IF BLOCKS
       AEQLC   BLOKCL,0,BNYOP5	   BLOCKS enabled?		[PLB117]
.FI
* SPITBOL, no BLOCKS
       STREAM  TSP,ZSP,SBIPTB,BNAF,BNAF				[PLB32]
.IF BLOCKS
       BRANCH  BNYOP3						[PLB117]
*_
* BLOCKS & SPITBOL!
BNYOP5 STREAM  TSP,ZSP,BSBIPTB,BNAF,BNAF			[PLB117]
.FI
BNYOP3 LEQLC   ZSP,0,BNAF					E3.5.3 [PLB32]
       MOVD    XPTR,STYPE	   STYPE has function descriptor
BNCF   LOCSP   YSP,YPTR		   Get specifier for object
       LCOMP   YSP,EQLSP,BNBF	   Length must be 2 or less
       SETSP   ZSP,PROTSP					E3.5.3
       SETLC   ZSP,0						E3.5.3
       APDSP   ZSP,YSP						E3.5.3
       APDSP   ZSP,BLSP						E3.5.3
       AEQLC   SPITCL,0,BNCF2	   SPITBOL ops enabled?		[PLB32]
.IF BLOCKS
       AEQLC   BLOKSP,0,BNCF4	   BLOCKS enabled?		[PLB117]
.FI
       STREAM  TSP,ZSP,BIOPTB,BNBF,BNBF				E3.5.3
       BRANCH  BNCF3						[PLB117]
*_
.IF BLOCKS
* SNOBOL4B, no SPITBOL ops
BNCF4  STREAM  TSP,ZSP,BBIOPTB,BNBF,BNBF			[PLB117]
       BRANCH  BNCF3						[PLB117]
*_
.FI
* here with SPITBOL ops enabled
BNCF2  LHERE
.IF BLOCKS
       AEQLC   BLOKSP,0,BNCF5	   BLOCKS enabled?		[PLB117]
.FI
* SPITBOL, no BLOCKS:
       STREAM  TSP,ZSP,SBIPTB,BNBF,BNBF				E3.5.3
.IF BLOCKS
       BRANCH  BNCF3						[PLB117]
*_
* BLOCKS & SPITBOL!
BNCF5  STREAM  TSP,ZSP,BSBIPTB,BNBF,BNBF			[PLB117]
.FI
BNCF3  LEQLC   ZSP,0,BNBF					E3.5.3 [PLB32]
       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(S1,S2,S3)
*
RPLACE PROC    ,		   REPLACE(S1,S2,S3)
       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
       LOCSP   YSP,YPTR		   Get specifier for second
       LOCSP   ZSP,ZPTR		   Get specifier for third
       LCOMP   ZSP,YSP,FAIL,,FAIL  Verify same lengths
       AEQLC   YPTR,0,,FAIL	   Ignore null replacement
       LOCSP   XSP,XPTR		   Get specifier for first
       GETLG   XCL,XSP		   Get length
       RCALL   ZPTR,CONVAR,XCL	   Allocate space for result
       LOCSP   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
*_
*---------------------------------------------------------------------*
*
* New [PLB37] from Minnesota SNOBOL4
*      REVERSE(S)
*
REVERS PROC    ,		   REVERSE(S)
       RCALL   XPTR,VARVAL,,FAIL   Get 1st arg=string
       LOCSP   XSP,XPTR		   Source string
       GETLG   ZPTR,XSP		   Source string length
       ACOMPC  ZPTR,0,,RETNUL	   Check for null string
       MOVA    XCL,ZPTR		   Copy length (for GENVSZ)
       RCALL   ZPTR,CONVAR,XCL	   Allocate space for string
       LOCSP   TSP,ZPTR		   Get specifier
       XCALLC  REVERSE,(TSP,XSP)   Do function			[PLB86]
       BRANCH  GENVSZ		   Return the string
*_
*---------------------------------------------------------------------*
*
*      SIZE(S)
*
SIZE   PROC    ,		   SIZE(S)
       RCALL   XPTR,VARVAL,,FAIL   Get argument
       LOCSP   XSP,XPTR		   Get specifier
       GETLG   ZPTR,XSP		   Get length
       SETVC   ZPTR,I		   Insert INTEGER data type
       BRANCH  RTZPTR		   Return length
*_
*---------------------------------------------------------------------*
*
* New [PLB37] from Minnesota SNOBOL4, modified to SPITBOL specs
*      SUBSTR(S,P,L)
*
SUBSTR PROC    ,		   SUBSTR(S,P,L)
       RCALL   XPTR,VARVAL,,FAIL   Get 1st arg=string
       PUSH    XPTR		   Save string
       RCALL   YPTR,INTVAL,,FAIL   Get 2nd arg=integer position
       PUSH    YPTR		   Save position
       RCALL   ZPTR,INTVAL,,FAIL   Get 3rd arg=integer length
       POP     (YPTR,XPTR)	   Restore position, string
       ACOMPC  YPTR,1,,,FAIL	   Make sure offset is >=1	[PLB37]
       DECRA   YPTR,1		   Make zero-based		[PLB37]
       LOCSP   XSP,XPTR		   Source string
       GETLG   WPTR,XSP		   Source string length
       SUBTRT  WPTR,WPTR,YPTR	   To see if substring too big
       ACOMP   ZPTR,WPTR,FAIL	   Fail if substr too long	[PLB37]
       ACOMPC  ZPTR,0,SSNOFX,,FAIL Check length			[PLB37][PLB82]
       MOVA    ZPTR,WPTR	   Remaining length if = zero
SSNOFX ACOMPC  ZPTR,0,,RETNUL,FAIL NULL string?
       MOVA    XCL,ZPTR		   Copy length (for GENVSZ)
       RCALL   ZPTR,CONVAR,XCL	   Allocate space for string
       LOCSP   TSP,ZPTR		   Get specifier
       XCALLC  XSUBSTR,(TSP,XSP,YPTR)				[PLB86]
       BRANCH  GENVSZ		   Return the string
*_
*---------------------------------------------------------------------*
*
*      TIME()
*
TIME   PROC    ,		   TIME()
       RCALL   ,ARGVAL,,FAIL	   Get rid of argument
       MSTIME  ZPTR		   Get elapsed time
       SBREAL  ZPTR,ZPTR,ETMCL	   Compute time in interpreter	[PLB71]
       SETVC   ZPTR,R		   Insert REAL data type	[PLB71]
       BRANCH  RTZPTR		   Return time
*_
*---------------------------------------------------------------------*
*
*      TRIM(S)
*
TRIM   PROC    ,		   TRIM(S)
       RCALL   XPTR,VARVAL,,FAIL   Get string
       LOCSP   ZSP,XPTR		   Get specifier
       TRIMSP  ZSP,ZSP		   Trim string
       BRANCH  GENVRZ		   Generate new variable
*_
*---------------------------------------------------------------------*
*
* New [PLB78] idea from Steve Duff's Macro SPITBOL
*      VDIFFER(X,Y)
*
VDIFFR PROC    ,		   VDIFFER(X,Y)
       RCALL   ,XYARGS,,FAIL	   Evaluate arguments
       DEQL    XPTR,YPTR,RTXPTR,FAIL
*				   Compare them, return X if they DIFFER()
*_
*---------------------------------------------------------------------*
.IF BLOCKS
****************
* BLOCKS (VERSION 1.10, APRIL 1, 1973)
         TITLE     'BLOCKS'
*
*        BLOCK ORGANIZATIONS
*
SER_     EQU       1
PAR_     EQU       2
OVY_     EQU       3
MERGE_   EQU       4
IT_      EQU       5
REP_     EQU       6
NODE_    EQU       7
DEF_     EQU       8
PHY_     EQU       9
*
*        DIRECTIONS
*
HT_      EQU       DESCR
WTH_     EQU       2*DESCR
DTH_     EQU       3*DESCR
*
*        BLOCK FIELDS
*
ORG_     EQU       DESCR           VALUE FIELD
REG_     EQU       2*DESCR         WHOLE WORD OR ADDRESS
SET_     EQU       REG_            VALUE FIELD
TOP_     EQU       DESCR           ADDRESS FIELD
FIRST_   EQU       3*DESCR
ELEMENT_ EQU       2*DESCR
NAME_    EQU       2*DESCR
ID_      EQU       DESCR           ADDRESS FIELD
*
*        P_BLOCK FIELDS
*
BL_      EQU       2*DESCR
FRAME_   EQU       3*DESCR
ARRAY_   EQU       4*DESCR
*
*        EDGES
*
*        ACTIVE EDGE
AEDGDT   EQU       40
AEDGEDT  EQU       AEDGDT
VAL_     EQU       DESCR
NEXT_    EQU       2*DESCR
*        PLAIN EDGE
EDGDT    EQU       41
TR1_     EQU       DESCR
NN1_     EQU       2*DESCR
RELS1_   EQU       3*DESCR
*
*        TREE NODE
*
TNDT     EQU       42
FATHER_  EQU       DESCR
LSO_     EQU       2*DESCR
RSIB_    EQU       3*DESCR
VALUE_   EQU       4*DESCR
TNREG_   EQU       5*DESCR
*
*        MISCELLANY
*
SBDT     EQU       43
FRSIZE_  EQU       DTH_            FRAME SIZE
DIAGUN   EQU       UNITP           FORTRAN UNIT NO FOR DIAGNOSTIC OUTPUT [PLB117]
PRUNO    EQU       UNITO           PRINTER UNIT NO     		  	 [PLB117]
MAXW     EQU       20              MAXIMUM WARNINGS
ERRNO    EQU       35		   Last error before BLOCKS		 [PLB117]
*
**********************************************************************
*                                                                     *
*        ADD_NP  ADDS A NODE PAIR TO AN EDGE.  THE EDGE MAY BE        *
*        SIMPLE OR COMPOUND.                                          *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,ADD_NP,(EDGE,NODE,DIST)                     *
*        REGISTERS CLOBBERED:  TEMP31,TEMP32,TEMP33                   *
*                                                                     *
**********************************************************************
ADD_NP   PROC
         POP       (AN_EDGE,AN_NODE,AN_DIST)
         SETVA     AN_NODE,AN_DIST
         VEQLC     AN_EDGE,EDGDT,,AN1
         RCALL     TEMP31,BLOCK,(AN_RD)
         RCALL     TEMP32,BLOCK,(AN_ED)
         PUTDC     TEMP32,RELS1_,TEMP31
         PUTDC     TEMP32,NN1_,AN_1
         PUTDC     TEMP32,TR1_,AN_EDGE
         PUTDC     TEMP31,DESCR,AN_NODE
         BRANCH    AN99
AN1      LHERE
         GETDC     TEMP32,AN_EDGE,RELS1_
         RCALL     AN_EDGE,BCOPY,AN_EDGE
         PUSH      AN_EDGE
         RCALL     TEMP32,BCOPY,TEMP32
         POP       AN_EDGE
         GETSIZ    TEMP31,TEMP32
         GETDC     TEMP33,AN_EDGE,NN1_
         INCRA     TEMP33,1
         PUTDC     AN_EDGE,NN1_,TEMP33
         MULTC     TEMP33,TEMP33,DESCR
         ACOMP     TEMP31,TEMP33,,,AN2
AN3      LHERE
         PUTD      TEMP32,TEMP33,AN_NODE
         MOVD      TEMP32,AN_EDGE
         BRANCH    AN99
AN2      LHERE
         PUSH      (AN_EDGE,XPTR)
         RCALL     TEMP32,MORE,(TEMP32)
         POP       (XPTR,AN_EDGE)
         PUTDC     AN_EDGE,RELS1_,TEMP32
         BRANCH    AN3
AN99     RRTURN    TEMP32,1
AN_EDGE  DESCR     0,0,0
AN_NODE  DESCR     0,0,0
AN_DIST  DESCR     0,0,0
AN_RD    DESCR     3*DESCR,0,A
AN_ED    DESCR     RELS1_,0,EDGDT
AN_1     DESCR     1,0,I
*
***********************************************************************
*                                                                     *
*        AF_MERGE  MERGES TWO ACTIVE FRAMES AF1 AND AF2 AND REPLACES  *
*        THE FIRST ARGUMENT WITH THE RESULT                           *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,AF_MERGE,(AF1,AF2)                                *
*                                                                     *
***********************************************************************
AF_MERGE PROC
         POP       (TEMP41,TEMP42)
*        TEMP41 = AF1
*        TEMP42 = AF2
*        TEMP43 = E1
*        TEMP44 = E2
         MOVD      AM_DIR,ZEROCL
AM4      INCRA     AM_DIR,DESCR
         ACOMPC    AM_DIR,FRSIZE_,RTN1
         GETD      TEMP43,TEMP41,AM_DIR
         VEQLC     TEMP43,AEDGDT,,AM1
         RCALL     AM_AE,BLOCK,(AM_DE)
         PUTDC     AM_AE,VAL_,TEMP43
         PUTD      TEMP41,AM_DIR,AM_AE
         MOVD      TEMP43,AM_AE
AM1      LHERE
         GETD      TEMP44,TEMP42,AM_DIR
         VEQLC     TEMP44,AEDGDT,,AM2
         RCALL     ,COAG,(TEMP43,TEMP44)
         BRANCH    AM4
AM2      LHERE
AM3      GETDC     AM_E,TEMP44,VAL_
         RCALL     ,COAG,(TEMP43,AM_E)
         GETDC     TEMP44,TEMP44,NEXT_
         AEQLC     TEMP44,0,AM3
         BRANCH    AM4
AM_E     DESCR     0,0,0
AM_AE    DESCR     0,0,0
AM_DE    DESCR     NEXT_,0,AEDGDT
AM_DIR   DESCR     0,0,0
*
***********************************************************************
*                                                                     *
*        AFRAME  RETURNS AN ACTIVE FRAME.  IT CAN CALL ITSELF RECUR-  *
*        SIVELY BY CALLING FORCING WHICH CALLS B_PB WHICH CALLS AFRAME*
*        AN AFRAME CONTAINS ALL FRAME INFORMATION EXCEPT THAT PROVIDED*
*        BY UNRESOLVED REPLICATED BLOCKS                              *
*        CALLING SEQUENCE:                                            *
*           RCALL    ______,AFRAME,(TN)                               *
*                                                                     *
***********************************************************************
AFRAME   PROC
         POP       TEMP1                     TEMP1 IS TN
         GETDC     TEMP2,TEMP1,VALUE_        TEMP2 IS B
         IFCONT    TEMP2,AFR4
         RCALL     TEMP3,BLOCK,(AF_SIZE)
*                                            TEMP3 IS AFRAME
         GETDC     TEMP4,TEMP2,ORG_          TEMP4 IS DIR
         SETAV     TEMP4,TEMP4
         MULTC     TEMP4,TEMP4,DESCR
         GETDC     TEMP5,TEMP1,TNREG_        TEMP5 IS REG
         RCALL     TEMP6,BLOCK,(AF_SIZE)
*                                            TEMP6 IS F
         PUTD      TEMP6,TEMP4,AF_Z        ZERO OUT THE EDGE IN THE
*                                          DIRECTION OF JOINING
         RCALL     TEMP7,LSOHN,(TEMP1)
         PUSH      (TEMP2,TEMP3,TEMP5)
         PUSH      (TEMP1,TEMP4,TEMP6)
         MOVD      AF_NF,ZEROCL            NODE FLAG
*        BUILD ALL DAUGHTERS THAT ARE NOT REPLICATED (I.E. THAT CAN BE
*        BE BUILT)
AFR3A    LHERE
         GETDC     TEMP31,TEMP7,VALUE_     PICK UP THE BLOCK
         IFREP     TEMP31,,AFR1A           BRANCH IF REPLICATED
         PUSH      (TEMP7,AF_NF)
         RCALL     TEMP31,B_PB,(TEMP7,NULVCL)
         POP       (AF_NF,TEMP7)
         GETDC     TEMP31,TEMP31,FRAME_    BRANCH IF ...
         GETDC     TEMP31,TEMP31,HT_       IT HAS ...
         VEQLC     TEMP31,EDGDT,AFR1A      NO NODES
         SETAC     AF_NF,1                 SET NODE FLAG
AFR1A    LHERE
         GETDC     TEMP7,TEMP7,RSIB_       GET NEXT SIBLING
         AEQLC     TEMP7,0,AFR3A           GO BACK UNLESS NULL
* THIS SECTION SETS THE OVERALL OTHOGONAL SIZES OF THE FRMME.
         POP       (TEMP6,TEMP4,TEMP1)
         PUSH      AF_NF                   SAVE NODE FLAG
         CYC       TEMP4                   GET FIRST ORTH. DIR.
         PUSH      (TEMP1,TEMP4,TEMP6)
         RCALL     TEMP31,FORCING,(TEMP1,TEMP4)
         POP       (TEMP6,TEMP4,TEMP1)
         PUTD      TEMP6,TEMP4,TEMP31      KEEP SIZE
         CYC       TEMP4                   GET NEXT DIRECTION
         PUSH      (TEMP1,TEMP4,TEMP6)
         RCALL     TEMP31,FORCING,(TEMP1,TEMP4)
         POP       (TEMP6,TEMP4,TEMP1)
         PUTD      TEMP6,TEMP4,TEMP31      KEEP IT
         CYC       TEMP4                   RESTORE THE DIRECTION
         POP       AF_NF
* NOW WE GO THROUGH THE LOOP TO COMPUTE THE FRAME
         POP       (TEMP5,TEMP3,TEMP2)
         GETDC     TEMP7,TEMP1,LSO_
AFR3     LHERE
         GETDC     TEMP31,TEMP7,VALUE_
         IFREP     TEMP31,,AFR1
         GETDC     TEMP8,TEMP31,FRAME_
         AEQLC     AF_NF,0,AFR6            BRANCH IF NODES
         GETD      TEMP8,TEMP8,TEMP4       GET THE EDGE
         GETD      TEMP31,TEMP6,TEMP4
         SUM       TEMP31,TEMP31,TEMP8
         PUTD      TEMP6,TEMP4,TEMP31
         BRANCH    AFR2
AFR6     LHERE
         RCALL     TEMP6,F_JOIN,(TEMP4,TEMP6,TEMP8,TEMP5)
AFR2     LHERE
         GETDC     TEMP7,TEMP7,RSIB_
         AEQLC     TEMP7,0,AFR3
         GETD      TEMP31,TEMP3,TEMP4
         GETD      TEMP32,TEMP6,TEMP4
         DEQL      TEMP31,ZEROCL,,AFNOTA     IF AFRAME<DIR> IS NULL
*                                            THEN THE FRAME IS NOT ACT.
         RCALL     TEMP32,E_ATTACH,(TEMP31,TEMP32)
         PUTD      TEMP3,TEMP4,TEMP32
         CYC       TEMP4
         GETD      TEMP31,TEMP6,TEMP4
         PUTD      TEMP3,TEMP4,TEMP31
         CYC       TEMP4
         GETD      TEMP31,TEMP6,TEMP4
         PUTD      TEMP3,TEMP4,TEMP31
AFR21    LHERE
         RCALL     TEMP31,NP_BLOCK,(TEMP2,TEMP3,NULVCL)
         PUTDC     TEMP1,VALUE_,TEMP31
         BRANCH    AFR99
AFNOTA   MOVD      TEMP3,TEMP6
         BRANCH    AFR21
AFR1     LHERE
         GETD      TEMP31,TEMP3,TEMP4
         GETD      TEMP32,TEMP6,TEMP4
         DEQL      TEMP31,ZEROCL,,AFR11
         RCALL     TEMP32,E_ATTACH,(TEMP31,TEMP32)
AFR11    PUTD      TEMP3,TEMP4,TEMP32
         PUTD      TEMP6,TEMP4,AF_Z
         BRANCH    AFR2
* TRANSFER IS MADE HERE IF THE BLOCK IS NOT CONTIGUOUS.
AFR4     LHERE
         GETDC   TEMP31,TEMP2,ORG_     PICK UP ORG.-BEARING DESCRIPTOR
         VEQLC   TEMP31,NODE_,AFR5     IS IT A NODE?
         PUSH    TEMP1                 YES , MUST FIX IT
         RCALL   TEMP2,B_PB,(TEMP1)
         POP     TEMP1
AFR5     LHERE   ,                     IF NOT PHYSICAL ..
         IFPHY   TEMP2,,AFR51          AT THIS POINT THEN ERROR
         SETAC   ERRTYP,ERRNO+3					[PLB117]
         BRANCH  FTLEND
AFR51    LHERE   ,                     ARRIVAL HERE MEANS PHYSICAL BL
         GETDC   TEMP3,TEMP2,FRAME_    PICK UP FRAME AND RETURN
         BRANCH    AFR99
AFR99    RRTURN    TEMP3,1
AF_Z     DESCR     0,0,I
AF_SIZE  DESCR     3*DESCR,0,A
AF_DIRS  DESCR     0,0,0
AF_NF    DESCR     0,0,0
*
**********************************************************************
*        B_PB  BUILDS A PHYSICAL BLOCK GIVEN A TREE NODE AS ARGUMENT. *
*        A  IS THE AMOUNT OF SPACE AVAILABLE (USED ONLY WITH REPLICA- *
*        TED BLOCKS.)                                                 *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,B_PB,(TN,A)                                 *
*                                                                     *
**********************************************************************
B_PB     PROC
         POP       XPTR
         GETDC     TEMP1,XPTR,VALUE_   TEMP1 IS B
         VEQLC     TEMP1,S,BPNOST
         AEQLC     TEMP1,0,BPNONL
         RCALL     TEMP12,P_BLOCK,(NULVCL,BP_0,BP_0,BP_0,NULVCL)
         BRANCH    BPST1
BPNONL   RCALL     BP_T,BLOCK,(BP_ARY)
         PUTDC     BP_T,DESCR,TEMP1
         GETSIZ    BP_L,TEMP1
         SETVC     BP_L,I
         RCALL     TEMP12,P_BLOCK,(TEMP1,BP_1,BP_L,BP_1,BP_T)
BPST1    PUTDC     XPTR,VALUE_,TEMP12
         BRANCH    BP99
BPNOST   LHERE
         GETDC     BP_ORG,TEMP1,ORG_
         SETAV     BP_ORG,BP_ORG
         SELBRA    BP_ORG,(BPORG1,BPORG2,BPORG3,BPORG4,BPORG5,BPORG6,BPORG7,BPORG8,BPORG9)
*        CONTIGUOUS ORGANIZATION
BPORG1   LHERE
BPORG2   LHERE
BPORG3   LHERE
         PUSH      (XPTR,TEMP1)
         RCALL     TEMP3,AFRAME,(XPTR)
         POP       (TEMP1,XPTR)
*                                      TEMP3 IS AF
         GETDC     BP_ORG,TEMP1,ORG_
         SETAV     BP_ORG,BP_ORG
         MULTC     BP_DIR,BP_ORG,DESCR
         GETDC     TEMP2,XPTR,TNREG_
*                                      TEMP2 IS REG
         GETD      TEMP4,TEMP3,BP_DIR
*                                             TEMP4 IS CURRENT
         VEQLC     TEMP4,AEDGEDT,BPCONT1
         MOVD      BP_N,ZEROCL
         MOVD      BP_L,ZEROCL
BPCONT2  LHERE
         INCRA     BP_N,DESCR
         GETDC     BP_EDGE,TEMP4,VAL_
         TRL       XCL,BP_EDGE
         SUM       BP_L,BP_L,XCL
         GETDC     YPTR,TEMP4,NEXT_
         AEQLC     YPTR,0,,BPCONT3
         MOVD      TEMP4,YPTR
         BRANCH    BPCONT2
BPCONT1  LHERE
         SETAC     BP_N,DESCR
         MOVD      TEMP5,TEMP3         TEMP5 IS F
         GETD      BP_L,TEMP3,BP_DIR
         TRL       BP_L,BP_L
         BRANCH    BPCONT4
BPCONT3  LHERE
         PUSH      (XPTR,TEMP1,TEMP2,TEMP3)
         PUSH      (BP_DIR,BP_L,BP_N)
         MOVD      BP_A,BP_L
         RCALL     YPTR,PAR_CONG,(XPTR),BPCONT31
         RCALL     BP_A,FORCING,(YPTR,BP_DIR)
BPCONT31 LHERE
         POP       (BP_N,BP_L,BP_DIR)
         POP       (TEMP3,TEMP2,TEMP1,XPTR)
         SUBTRT    BP_A,BP_A,BP_L
         DECRA     BP_N,DESCR
         RCALL     TEMP6,DISTR,(BP_A,BP_N)
         SETAC     BP_N,DESCR
*                                      TEMP6 IS THE ARRAY A
         GETD      TEMP4,TEMP3,BP_DIR
         GETDC     TEMP7,TEMP4,VAL_    TEMP7 IS EDGE
         VEQLC     TEMP7,EDGDT,BPCONT33
         RCALL     TEMP7,BCOPY,(TEMP7)
BPCONT33 LHERE
         GETDC     TEMP4,TEMP4,NEXT_
         AEQLC     TEMP4,0,,BPCONT34
         GETD      BP_L,TEMP6,BP_N
         INCRA     BP_N,DESCR
         RCALL     TEMP7,JE_LONGI,(TEMP7,BP_L)
         GETDC     BP_L,TEMP4,VAL_
         RCALL     TEMP7,JE_LONGI,(TEMP7,BP_L)
         BRANCH    BPCONT33
BPCONT34 LHERE
         MOVD      BP_N,ZEROCL
         RCALL     TEMP5,BCOPY,(TEMP3)
         PUTD      TEMP5,BP_DIR,TEMP7
BPCONT4  LHERE
         RCALL     TEMP8,LSOHN,(XPTR)        TEMP8 IS D
         RCALL     TEMP9,STRIP_F,(TEMP5)
*                                      TEMP9 IS SF
         GETDC     BP_H,TEMP9,HT_
         GETDC     BP_D,TEMP9,DTH_
         GETDC     BP_W,TEMP9,WTH_
         PUSH      XPTR
         RCALL     TEMP10,BLAND,(BP_H,BP_W,BP_D),BPCONTNL
*                                            TEMP10 IS PHY
         POP       XPTR
*BPCT1    LHERE
         RCALL     TEMP11,IDENT_SB,(TEMP9)
*                                      TEMP11 IS S
         RCALL     TEMP12,NP_BLOCK,(TEMP1,TEMP5,TEMP10)
*                                      TEMP12 IS B.PB
BPCONT5  LHERE
         GETDC     BP_T,TEMP8,VALUE_
         IFREP     BP_T,,BPCONT6
         PUSH      TEMP9
         PUSH      (XPTR,BP_DIR,BP_N,TEMP2,TEMP5,TEMP6,TEMP8,TEMP10,TEMP11,TEMP12)
         RCALL     TEMP13,B_PB,(TEMP8,NULVCL)
         POP       (TEMP12,TEMP11,TEMP10,TEMP8,TEMP6,TEMP5,TEMP2,BP_N,BP_DIR,XPTR)
         POP       TEMP9
*                                      TEMP13 IS PB
         GETDC     BP_T,TEMP13,FRAME_
         RCALL     TEMP14,STRIP_F,(BP_T)
*                                      TEMP14 IS DF
BPCONT51 LHERE
         RCALL     TEMP15,INIT_SUB,(TEMP11,TEMP14,BP_DIR,TEMP2)
*                                      TEMP15 IS SD
BPCONT52 LHERE
         GETDC     BP_T,TEMP13,ARRAY_
         RCALL     ,INSERT,(TEMP10,TEMP9,BP_T,TEMP15)
*BPCONT7  LHERE
         GETDC     TEMP8,TEMP8,RSIB_
         AEQLC     TEMP8,0,BPCONT5
         PUTDC     XPTR,LSO_,NULVCL
         PUTDC     XPTR,VALUE_,TEMP12
         BRANCH    BP99
BPCONT6  LHERE
         INCRA     BP_N,DESCR
         GETD      BP_L,TEMP6,BP_N
         PUSH      (TEMP2,TEMP5,TEMP6,TEMP8,TEMP9,TEMP10,TEMP11,TEMP12)
         PUSH      (XPTR,BP_L,BP_DIR,BP_N)
         RCALL     TEMP13,B_PB,(TEMP8,BP_L)
         POP       (BP_N,BP_DIR,BP_L,XPTR)
         POP       (TEMP12,TEMP11,TEMP10,TEMP9,TEMP8,TEMP6,TEMP5,TEMP2)
         GETDC     TEMP14,TEMP13,FRAME_
         GETD      BP_T,TEMP14,BP_DIR
         AEQL      BP_T,BP_L,,BPCONT8
         RCALL     TEMP16,BCOPY,(TEMP5)
*                                      TEMP16 IS PF
         RCALL     TEMP17,BCOPY,(TEMP5)
*                                      TEMP17 IS SF
         SUBTRT    BP_DIF,BP_L,BP_T
         DIVIDE    BP_PREF,BP_DIF,BP_TWO,FAIL
         PUTD      TEMP16,BP_DIR,BP_PREF
         SUBTRT    BP_T,BP_DIF,BP_PREF
         PUTD      TEMP17,BP_DIR,BP_T
         RCALL     ,INIT_SUB,(TEMP11,TEMP16,BP_DIR,TEMP2)
         RCALL     TEMP15,INIT_SUB,(TEMP11,TEMP14,BP_DIR,TEMP2)
         RCALL     ,INIT_SUB,(TEMP11,TEMP17,BP_DIR,TEMP2)
         BRANCH    BPCONT52
BPCONT8  LHERE
         BRANCH    BPCONT51
BPCONTNL LHERE
         RCALL     TEMP12,NP_BLOCK,(TEMP1,TEMP5,NULVCL)
         PUTDC     XPTR,LSO_,NULVCL
         PUTDC     XPTR,VALUE_,TEMP12
         BRANCH    BP99
BPORG4   BRANCH    BMORG4,BMORG4
BPORG5   BRANCH    BMORG5,BMORG5
BPORG6   BRANCH    BMORG6,BMORG6
BPORG7   BRANCH    BMORG7,BMORG7
BP99     RRTURN    TEMP12,1
BPORG8   LHERE
         SETAC     ERRTYP,ERRNO+1
         BRANCH    FTLEND
BPORG9   MOVD      TEMP12,TEMP1
         BRANCH    BP99
BP_T     DESCR     0,0,0
BP_ARY   DESCR     DESCR,0,A
BP_L     DESCR     0,0,0
BP_EDGE  DESCR     0,0,0
BP_TWO   DESCR     2,0,I
BP_DIF   DESCR     0,0,0
BP_PREF  DESCR     0,0,0
BP_DIR   DESCR     0,0,0
BP_N     DESCR     0,0,0
BP_A     DESCR     0,0,0
BP_W     DESCR     0,0,0
BP_H     DESCR     0,0,0
BP_D     DESCR     0,0,0
BP_ORG   DESCR     0,0,0
BP_0     DESCR     0,0,I
BP_1     DESCR     1,0,I
*BMORG    PROC
*
*        MERGED ORGANIZATION
BMORG4   PROC      BMORG
*                  D = LSON(TN)
         RCALL     TEMP8,LSOHN,(XPTR)
*BPMRG5   LHERE
*                  F  =  COPY(AFRAME(D))
         PUSH      (XPTR,TEMP8)
         RCALL     TEMP5,AFRAME,(TEMP8)
         POP       (TEMP8,XPTR)
         RCALL     TEMP5,BCOPY,(TEMP5)
*        F<HT.> = CAE(F<HT.>)
*        F<WTH.> = CAE(F<WTH.>)
*        F<DTH.> = CAE(F<DTH.>)
         MOVD    TEMP32,ZEROCL
BPMRG51  INCRA     TEMP32,DESCR
         ACOMPC    TEMP32,FRSIZE_,BPMRG52
         GETD      TEMP31,TEMP5,TEMP32
         RCALL     TEMP31,CAE,(TEMP31)
         PUTD      TEMP5,TEMP32,TEMP31
         BRANCH    BPMRG51
BPMRG52  LHERE
         MOVD      TEMP31,NULVCL
*                  D  =  RSIB(D)  DIFFER(RSIB(D))   :F(BPMRG2)
BPMRG1   LHERE
         GETDC     TEMP8,TEMP8,RSIB_
         AEQLC     TEMP8,0,,BPMRG2
*                  F  =  AF.MERGE(F,AFRAME(D))
         PUSH      (XPTR,TEMP5,TEMP8)
         RCALL     TEMP31,AFRAME,(TEMP8)
         POP       (TEMP8,TEMP5,XPTR)
         RCALL     ,AF_MERGE,(TEMP5,TEMP31)
         BRANCH    BPMRG1
BPMRG2   LHERE
*                  F  =  COMPLETED.FRAME(F)
         RCALL     ,COMPFR,(TEMP5)
*!         BRANCH    BPMRG22
*!R_R_N    LHERE
*!*        REMOVE REDUNDANT NODES HAS NOT BEEN ENCODED YET
*!*                  R.R.N(F<HT.>)
*!*                  R.R.N(F<WTH.>)
*!*                  R.R.N(F<DTH.>)
*!         MOVD      TEMP31,TEMP5
*!         MOVD      TEMP32,TEMP5
*!         INCRA     TEMP32,FRSIZE_
*!BPMRG21  LHERE
*!         INCRA     TEMP31,DESCR
*!         ACOMP     TEMP31,TEMP32,BPMRG22
*!         RCALL     ,R_R_N,(TEMP31),BPMRG21
*!BPMRG22  LHERE
*                  SF  =  STRIP.FRAME(F)
         RCALL     TEMP9,STRIP_F,(TEMP5)
*                  PHY = BLAND(SF<HT.> , SF<WTH.> , SF<DTH.> )
         GETDC     BM_H,TEMP9,HT_
         GETDC     BM_W,TEMP9,WTH_
         GETDC     BM_D,TEMP9,DTH_
         PUSH      XPTR
         RCALL     TEMP10,BLAND,(BM_H,BM_W,BM_D),BMNULL
         POP       XPTR
*                  B.PB = NP.BLOCK(VALUE(TN),F,PHY)
         GETDC     TEMP1,XPTR,VALUE_
         RCALL     TEMP12,NP_BLOCK,(TEMP1,TEMP5,TEMP10)
*                  VALUE(TN) = B.PB
         PUTDC     XPTR,VALUE_,TEMP12
*                  D = LSON(TN)
         GETDC     TEMP8,XPTR,LSO_
BPMRG3   LHERE
*                  EMB.PHY(D)
         PUSH      (XPTR,TEMP8,TEMP12)
         RCALL     ,EMB_PHY,(TEMP8)
         POP       (TEMP12,TEMP8,XPTR)
*                  D  =  RSIB(D)  DIFFER(RSIB(D))   :S(BPMRG3)
         GETDC     TEMP8,TEMP8,RSIB_
         AEQLC     TEMP8,0,BPMRG3
*                  LSO(TN)  =    :(RETURN)
         PUTDC     XPTR,LSO_,NULVCL
         BRANCH    BM99
*
*        ITERATED ORGANIZATION
BMORG5   PROC      BMORG
         GETDC     TEMP31,XPTR,LSO_
         PUSH      XPTR
         RCALL     TEMP13,B_PB,(TEMP31)
         POP       XPTR
         GETDC     TEMP10,TEMP13,ARRAY_
         GETDC     TEMP31,TEMP13,FRAME_
         RCALL     TEMP5,STRIP_F,(TEMP31)
*
         RCALL     BM_PC,PAR_CONG,(XPTR),BMNULL
         GETDC     BM_PCD,BM_PC,VALUE_
         IFPHY     BM_PCD,BPIT3
         GETDC     BM_PCD,BM_PCD,BL_
BPIT3    LHERE
         GETDC     BM_PCD,BM_PCD,ORG_
         SETAV     BM_PCD,BM_PCD
         MULTC     BM_PCD,BM_PCD,DESCR
         MOVD      BM_DIR,BM_PCD
         CYC       BM_DIR
BPIT1    LHERE
         PUSH      (XPTR,TEMP10,TEMP5,BM_DIR,BM_PC,BM_PCD)
         RCALL     TEMP6,FORCING,(BM_PC,BM_DIR)
         POP       (BM_PCD,BM_PC,BM_DIR,TEMP5,TEMP10,XPTR)
         GETD      TEMP31,TEMP5,BM_DIR
         AEQLC     TEMP31,0,,BPIT2
         DIVIDE    TEMP6,TEMP6,TEMP31,FAIL
BPIT2    LHERE
         PUSH    BM_PC
         RCALL     TEMP10,REPL,(TEMP10,TEMP5,BM_DIR,TEMP6)
         POP     BM_PC
         CYC       BM_DIR
         AEQL      BM_DIR,BM_PCD,BPIT1
         GETDC     TEMP31,XPTR,VALUE_
         RCALL     TEMP12,NP_BLOCK,(TEMP31,TEMP5,TEMP10)
         PUTDC     XPTR,VALUE_,TEMP12
         PUTDC     XPTR,LSO_,NULVCL
         BRANCH    BM99
*
*        REPLICATED ORGANIZATION
*
BMORG6   PROC      BMORG
*        THE REPLICATED BLOCK'S FATHER IS ASSUMED TO HAVE HAD ITS
* AFRAME COMPUTED AND THEREFORE WILL APPEAR TO BE PHYSICAL.
         GETDC     TEMP31,XPTR,FATHER_
         GETDC     BM_PC,TEMP31,VALUE_
*        PC IS THE PARENTIAL CONGLOMERATE, ITS PHYSICAL, GO AFTER THE
*        ORGANIZATION.
         GETDC     TEMP32,BM_PC,BL_
         GETDC     BM_ORG,TEMP32,ORG_
         SETAV     BM_DIR,BM_ORG
         MULTC     BM_DIR,BM_DIR,DESCR
*
         GETDC     TEMP31,XPTR,LSO_
         PUSH      (BM_DIR,XPTR)
         RCALL     TEMP13,B_PB,(TEMP31,NULVCL)
         POP       (XPTR,BM_DIR)
         GETDC     TEMP10,TEMP13,ARRAY_
         GETDC     TEMP31,TEMP13,FRAME_
         RCALL     TEMP5,STRIP_F,(TEMP31)
         POP       BM_A
         GETD      BM_L,TEMP5,BM_DIR
         DIVIDE    BM_A,BM_A,BM_L,BPREP1
BPREP1   LHERE
         RCALL     TEMP10,REPL,(TEMP10,TEMP5,BM_DIR,BM_A)
         RCALL     TEMP12,NP_BLOCK,(NULVCL,TEMP5,TEMP10)
         PUTDC     XPTR,VALUE_,TEMP12
         PUTDC     XPTR,LSO_,NULVCL
         BRANCH    BM99
*
*        NODE ORGANIZATION
*
BMORG7   PROC      BMORG
         GETDC     BM_T,TEMP1,ID_
         LOCAPT    TEMP31,TEMP50,BM_T,BPND0
*        WAS PREVIOUSLY CREATED
         GETDC     TEMP12,TEMP31,2*DESCR
         PUTDC     XPTR,VALUE_,TEMP12
         BRANCH    BM99
BPND0    LHERE
*        NOT PREVIOUSLY CREATED
         GETDC     TEMP31,XPTR,LSO_
         PUSH      (XPTR,BM_T,TEMP1)
         RCALL     TEMP13,B_PB,(TEMP31,NULVCL)
         POP       (TEMP1,BM_T,XPTR)
*                  F  =  PB<FRAME.>
         GETDC     TEMP5,TEMP13,FRAME_
         RCALL     TEMP5,BCOPY,TEMP5
         SETAC     BM_DIR,0
BPND1    LHERE
         INCRA     BM_DIR,DESCR
         ACOMPC    BM_DIR,DTH_,BPND2
         GETD      TEMP31,TEMP5,BM_DIR
         RCALL     TEMP31,ADD_NP,(TEMP31,BM_T,BM_0)
         PUTD      TEMP5,BM_DIR,TEMP31
         BRANCH    BPND1
BPND2    LHERE
         GETDC     TEMP31,TEMP13,ARRAY_
         RCALL     TEMP12,NP_BLOCK,(TEMP1,TEMP5,TEMP31)
         MOVD      WCL,TEMP50
         RCALL     TEMP31,BTAIL
         PUTD      WCL,TEMP31,BM_T
         RCALL     TEMP31,BTAIL
         PUTD      WCL,TEMP31,TEMP12
         MOVD      TEMP50,WCL
         PUTDC     XPTR,VALUE_,TEMP12
         BRANCH    BM99
BMNULL   LHERE
         PUTDC     XPTR,LSO_,NULVCL
         RCALL     TEMP12,P_BLOCK,(NULVCL,BM_0,BM_0,BM_0,NULVCL)
         PUTDC     XPTR,VALUE_,TEMP12
         BRANCH    BM99
BM99     RRTURN    TEMP12,1
BM_T     DESCR     0,0,0
BM_L     DESCR     0,0,0
BM_DIR   DESCR     0,0,0
BM_A     DESCR     0,0,0
BM_W     DESCR     0,0,0
BM_H     DESCR     0,0,0
BM_D     DESCR     0,0,0
BM_ORG   DESCR     0,0,0
BM_0     DESCR     0,0,I
BM_PC    DESCR     0,0,0
BM_PCD   DESCR     0,0,0
*
***********************************************************************
*                                                                     *
*         BCOPY   WILL COPY A BLOCK WITHOUT DESTROYING TEMPORARY      *
*         LOCATIONS.                                                  *
*         CALLING SEQUENCE:                                           *
*         RCALL      ______,BCOPY,(BLOCK)                             *
*                                                                     *
***********************************************************************
BCOPY    PROC
         POP       BC_B1
         GETSIZ    BC_N,BC_B1
         PUSH      BC_B1
         MOVV      BC_N,BC_B1
         RCALL     BC_B2,BLOCK,(BC_N)
         POP       BC_B1
         MOVBLK    BC_B2,BC_B1,BC_N
         RRTURN    BC_B2,1
BC_B1    DESCR     0,0,0
BC_B2    DESCR     0,0,0
BC_N     DESCR     0,0,0
*
***********************************************************************
*                                                                     *
*         BHEAD   MOVES THE DAUGHTERS OF THE BLOCK  WCL   ONE SPACE   *
*         FORWARD TO MAKE ROOM FOR AN ENTRY AT THE BEGINNING          *
*            CALLING SEQUENCE:                                        *
*            RCALL    ,BHEAD
*             LOCATIONS CLOBBERED:  WCL,XPTR                          *
*                                                                     *
***********************************************************************
BHEAD    PROC
BHEAD0	 LHERE								[PLB117]
         GETSIZ    BH_SIZE,WCL
         GETDC     BH_TOP,WCL,TOP_
         ACOMP     BH_TOP,BH_SIZE,BH_MORE,BH_MORE
         SUM       BH_PTR,WCL,BH_TOP
         INCRA     BH_TOP,DESCR
         PUTDC     WCL,TOP_,BH_TOP
         MOVD      BH_1ST,WCL
         INCRA     BH_1ST,FIRST_
BH1      LHERE
         GETDC     BH_TEMP,BH_PTR,0
         PUTDC     BH_PTR,DESCR,BH_TEMP
         DECRA     BH_PTR,DESCR
         ACOMP     BH_PTR,BH_1ST,BH1,BH1
         RRTURN    ,1
BH_MORE  RCALL     WCL,MORE,WCL
         BRANCH    BHEAD0						[PLB117]
BH_SIZE  DESCR     0,0,0
BH_TOP   DESCR     0,0,0
BH_PTR   DESCR     0,0,0
BH_1ST   DESCR     0,0,0
BH_TEMP  DESCR     0,0,0
*
***********************************************************************
*                                                                     *
*        BLAND   RETURNS AN ARRAY OF LENGTH H * D EACH OF WHOSE ELEM- *
*        ENTS POINTS TO A BLANK STRING OF WIDTH W.  IT FAILS IF THE   *
*        BLOCK IS EMPTY.                                              *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,BLAND,(H,W,D),(FAIL,SUCCESS)                *
***********************************************************************
BLAND    PROC
         POP       (BL_H,BL_W,BL_D)
         MULT      BL_L,BL_H,BL_D
         MULTC     BL_L,BL_L,DESCR
         AEQLC     BL_L,0,,FAIL
         AEQLC     BL_W,0,,FAIL
        SETVC     BL_L,A
         RCALL     TEMP31,BLOCK,(BL_L)
         RCALL     TEMP32,BLANK,(BL_W)
         PUTDC     TEMP31,DESCR,TEMP32
         MOVD      TEMP33,TEMP31             33 POINTS TO ONE MORE THAN
         INCRA     TEMP33,DESCR              TEMP31
         DECRA     BL_L,DESCR                INIT THE L-1 DESCRIPTORS
         AEQLC     BL_L,0,,BL1
         MOVBLK2   TEMP33,TEMP31,BL_L				[PLB118]
*        NOTE:  THIS SHOULD WORK IF MOVBLK IS IMPLEMENTED STRICTLY AC-
*        CORDING TO THE RULES.  I.E. ONE DESCRIPTOR AT A TIME FROM
*        TOP TO BOTTOM.
BL1      LHERE
         RRTURN    TEMP31,2
BL_H     DESCR     0,0,0
BL_W     DESCR     0,0,0
BL_D     DESCR     0,0,0
BL_L     DESCR     0,0,0
*
***********************************************************************
*                                                                     *
*        BLANK   RETURNS A BLANK STRING OF LENGTH N                   *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,BLANK,(N)                                   *
*        LOCATIONS CLOBBERED:  ZPTR,YPTR,ZPTR,XCL,YCL,TEMP49,         *
*                  TSP,XSP,YSP,ZSP                                    *
*                                                                     *
***********************************************************************
BLANK    PROC
         POP       BK_N
BKB      PUTLG     YSP,BK_N
         AEQLC     TEMP49,0,,BK3
         DEQL      BKGNCL,TEMP26,,BK2
         VEQLC     BKGNCL,S,BK2
         AEQLC     BKGNCL,0,,BK2
         MOVD      TEMP26,BKGNCL
         MOVD      TEMP49,BKGNCL
BK2      LOCSP     ZSP,TEMP49            TEMP49 CONTAINS MANY BLANKS
         SUBSP     ZSP,YSP,ZSP,BK1
         RCALL     YPTR,GENVAR,(ZSPPTR)
         RRTURN    YPTR,1
BK1      LHERE
*        DOUBLE THE NUMBER OF BLANKS
         MOVD      XPTR,TEMP49
         MOVD      YPTR,TEMP49
         RCALL     TEMP49,CONVV,,(FAIL,FAIL,BKB)
BK3      LHERE
         RCALL     TEMP49,GENVAR,(BK_PTR)
         MOVD      TEMP26,TEMP49
         BRANCH    BKB
BK_N     DESCR     0,0,0
BK_PTR   DESCR     BK_SPEC,0,0
BK_SPEC  STRING    ' '
*
***********************************************************************
*                                                                     *
*        ENTRY POINTS:                                                *
*                  HEIGHT   DEPTH   WIDTH   BLOCK.SIZE                *
*                                                                     *
***********************************************************************
HEIGHT   PROC
         SETAC     BS_DIR,HT_
         BRANCH    BLS2,BLS2
WIDTH    PROC
         SETAC     BS_DIR,WTH_
         BRANCH    BLS2,BLS2
DEPTH    PROC
         SETAC     BS_DIR,DTH_
         BRANCH    BLS2,BLS2
BLS2     PROC
         VEQLC     INCL,1,BLS3
         RCALL     BS_B,BLOKVAL,,FAIL
         BRANCH    BLS1,BLS1
BLS3     VEQLC     INCL,0,ARGNER
         MOVD      BS_B,NULVCL
         BRANCH    BLS1,BLS1
BLOCKSIZ PROC
         VEQLC     INCL,2,ARGNER
         RCALL     BS_B,BLOKVAL,,FAIL
         PUSH      BS_B
         RCALL     BS_DIR,INTVAL,,FAIL
         POP       BS_B
         INCRA     BS_DIR,1
         MULTC     BS_DIR,BS_DIR,DESCR
         BRANCH    BLS1,BLS1
BLS1     PROC
         RCALL     BS_B,FIXINL,(BS_B,BS_B)
         GETDC     BS_B,BS_B,FRAME_
         GETD      BS_B,BS_B,BS_DIR
         SETVC     BS_B,I
         RRTURN    BS_B,3
BS_DIR   DESCR     0,0,0
BS_B     DESCR     0,0,0
*
***********************************************************************
*                                                                     *
*        BLOKVAL    FETCHES  THE NEXT ARGUMENT AND CONVERTS IT TO     *
*                  BLOCK IF NECESSARY.  THE CALLING SEQUENCE IS       *
*        RCALL     _____,BLOKVAL,,(FAIL,SUCCESS)                      *
*        LOCATIONS CLOBBERED:   ANYTHING EXCEPT THE STACK!            *
*                  BLOKVAL CALLS ARGVAL WHICH CAN CALL APPLY WHICH    *
*                  IN TURN CAN CALL ANY FUNCTION UNDER THE SUN.       *
*                                                                     *
***********************************************************************
BLOKVAL  PROC
         RCALL     XPTR,ARGVAL,,FAIL
         VEQLC     XPTR,BL,,RTXNAM
         VEQLC     XPTR,S,,RTXNAM
         VEQLC     XPTR,R,BLOKV1
         REALST    REALSP,XPTR
         SETSP     XSP,REALSP
         RCALL     XPTR,GENVAR,XSPPTR,RTXNAM
BLOKV1   LHERE
         VEQLC     XPTR,I,INTR1,BLOKVI
BLOKVI   RCALL     XPTR,GNVARI,XPTR,RTXNAM
*
***********************************************************************
*                                                                     *
*        BOX IS A PRIMITIVE FUNCTION WHICH RETURNS A MILKY WHITENESS  *
*        OF SPECIFIED DIMENSION.  THE OTHER ENTRY POINTS ARE:         *
*        FRONT   VER   HOR                                            *
*                                                                     *
***********************************************************************
FRONT    PROC
         BRANCH    BOX,BOX
VER      PROC
         BRANCH    BOX,BOX
HOR      PROC
         RCALL     BX_W,INTVAL,,FAIL
         ACOMPC    BX_W,0,,,FAIL
         MOVD      BX_H,BX_ZERO
         MOVD      BX_D,BX_ZERO
         BRANCH    BOXIN,BOXIN
*HOR1     BRANCH    BOX,BOX
BOX      PROC
         SETAV     TEMP1,INCL
         PUSH      TEMP1
         RCALL     BX_H,INTVAL,,FAIL
         POP       TEMP1
         ACOMPC    BX_H,0,,,LENERR
         MOVD      BX_W,BX_ZERO
         ACOMPC    TEMP1,1,,BOX2,BOX2
         PUSH      (TEMP1,BX_H)
         RCALL     BX_W,INTVAL,,FAIL
         POP       (BX_H,TEMP1)
         ACOMPC    BX_W,0,,,LENERR
BOX2     LHERE
         MOVD      BX_D,BX_ZERO
         ACOMPC    TEMP1,2,,BOX3,BOX3
         PUSH      (BX_H,BX_W)
         RCALL     BX_D,INTVAL,,FAIL
         POP       (BX_W,BX_H)
         ACOMPC    BX_D,0,,,LENERR
BOX3     LHERE
         BRANCH    BOXIN,BOXIN
BOXIN    PROC
         RCALL     XPTR,BLAND,(BX_H,BX_W,BX_D),BOXNL
BOX4     RCALL     XPTR,P_BLOCK,(NULVCL,BX_H,BX_W,BX_D,XPTR)
         BRANCH    RTXPTR
BOXNL    MOVD      XPTR,NULVCL
         BRANCH    BOX4
BX_H     DESCR     0,0,0
BX_W     DESCR     0,0,0
BX_D     DESCR     0,0,0
BX_ZERO  DESCR     0,0,I
*
***********************************************************************
*                                                                     *
*         BTAIL   RETURNS THE FIRST LOCATION IN THE BLOCK   WCL       *
*         NOT OCCUPIED BY A DAUGHTER                                  *
*         CALLING SEQUENCE:                                           *
*         RCALL     ______,BTAIL                                      *
*         LOCATIONS CLOBBERED:   WCL,XPTR                             *
*                                                                     *
***********************************************************************
BTAIL    PROC
BTAIL0	 LHERE								[PLB117]
         GETSIZ    BT_SIZE,WCL
         GETDC     BT_TOP,WCL,TOP_
         ACOMP     BT_TOP,BT_SIZE,BT_MORE,BT_MORE
         INCRA     BT_TOP,DESCR
         PUTDC     WCL,TOP_,BT_TOP
         RRTURN    BT_TOP,1
BT_MORE  RCALL     WCL,MORE,(WCL)
         BRANCH    BTAIL0						[PLB117]
BT_TOP   DESCR     0,0,0
BT_SIZE  DESCR     0,0,0
*
**********************************************************************
*                                                                     *
*        CAE  COPIES AN ACTIVE EDGE                                   *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,CAE,(AE)                                    *
*        REGISTERS CLOBBERED:  TEMP35,TEMP36                          *
*                                                                     *
**********************************************************************
CAE      PROC
         POP       TEMP35
         VEQLC     TEMP35,AEDGDT,CA99
         RCALL     TEMP35,BCOPY,(TEMP35)
         GETDC     TEMP36,TEMP35,NEXT_
         PUSH      TEMP35
         RCALL     TEMP36,CAE,(TEMP36)
         POP       TEMP35
         PUTDC     TEMP35,NEXT_,TEMP36
CA99     RRTURN    TEMP35,1
*
***********************************************************************
* [PLB117] was CHAR                                                   *
*        BCHAR  IS AN EXTERNAL PROCEDURE WHICH RETURNS AN ARRAY OF    *
*        CHARACTERS CORRESPONDING TO THE BLOCK WHICH IT RECEIVES AS   *
*        ARGUMENT.  THE ARRAY RETURNED IS TWO DIMENSIONAL.            *
*        THE FIRST DIMENSION IS EQUAL TO THE DEPTH OF THE BLOCK AND   *
*        THE SECOND DIMENSION IS EQUAL TO THE HEIGHT OF THE BLOCK.    *
*        EACH STRING IN THE ARRAY IS AS LONG AS THE BLOCK IS WIDE.    *
*                                                                     *
***********************************************************************
BCHAR    PROC							[PLB117]
         VEQLC     INCL,1,CH1
         RCALL     ZPTR,BLOKVAL,,FAIL
         RCALL     ZPTR,FIXINL,(ZPTR,ZPTR)
         GETDC     CH_F,ZPTR,FRAME_
         GETDC     TEMP1,ZPTR,ARRAY_
         GETDC     CH_H,CH_F,HT_
         GETDC     CH_D,CH_F,DTH_
         SETVA     CH_H1,CH_H
         SETVA     CH_D1,CH_D
         MULT      TEMP3,CH_H,CH_D
         MULTC     TEMP2,TEMP3,DESCR
         MOVA      CH_LG,TEMP2
         SUM       TEMP2,TEMP2,CH_DL
         SETVC     TEMP2,A
         RCALL     YPTR,BLOCK,(TEMP2)
         SETSP     TSP,CH_SPEC					[PLB119]
         PUTLG     TSP,ZEROCL
         INTSPC    XSP,CH_D
         APDSP     TSP,XSP
         APDSP     TSP,CMASP
         INTSPC    XSP,CH_H
         APDSP     TSP,XSP
         RCALL     CH_PR,GENVAR,(TSPPTR)
         MOVBLK    YPTR,CH_DOPE,CH_DL
         SUM       TPTR,YPTR,CH_DL
         AEQLC     TEMP1,0,,CH2
         MOVBLK    TPTR,TEMP1,CH_LG
CH3      LHERE
         BRANCH    RTYPTR
CH1      VEQLC     INCL,0,ARGNER,RETNUL
CH2      AEQLC     CH_LG,0,,CH3
         MOVD      TEMP4,CH_LG
         DECRA     TEMP4,DESCR
         PUTDC     TPTR,DESCR,NULVCL
         MOVD      TEMP5,TPTR
         INCRA     TEMP5,DESCR
         AEQLC     TEMP4,0,,CH3
         MOVBLK    TEMP5,TPTR,TEMP4
         BRANCH    CH3
CH_DOPE  DESCR     CH_DOPE,0,0
CH_PR    DESCR     0,0,0               PROTOTYPE
         DESCR     2,0,0               DIMENSIONALITY
CH_H1    DESCR     1,0,S-S             VERTICAL DIMENSION
CH_D1    DESCR     1,0,S-S             NORMAL DIMENSION
CH_DL    DESCR     4*DESCR,0,0         DOPE LENGTH
CH_LG    DESCR     0,0,0               ARRAY LENGTH
CH_D     DESCR     0,0,0               DEPTH
CH_H     DESCR     0,0,0               HEIGHT
CH_F     DESCR     0,0,0               FRAME
CH_SPEC  SPEC      CH_BUF,0,0,0,16     Specifier for PROTOTYPE BUFFER [PLB119]
CH_BUF   BUFFER    16		       BUFFER FOR PROTOTYPE [PLB119]
*
***********************************************************************
*                                                                     *
*        CIR  -  COMBINE AND INCREMENT RELATIONS.                     *
*        THIS ROUTINE TAKES RELATION SEQUENCE A1 OF LENGTH N1         *
*        AND RELATION SEQUENCE A2 OF LENGTH N2 AND RETURNS A RELATION *
*        SEQUENCE OF LENGTH N1 + N2 SUCH THAT THE FIRST N1 TERMS      *
*        ARE EQUAL TO A1 AND THE SECOND N2 TERMS ARE EQUAL TO A2 BUT  *
*        WITH THE DISTANCE FIELD INCREASED BY D.                      *
*        A1 AND A2 AREN'T DISTURBED BUT EITHER MAY BE RETURNED IF     *
*        THAT WILL SPEED THINGS UP                                    *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,CIR,(A1,N1,A2,N2,D)                         *
*        LOCATIONS CLOBBERED:  POTENTIALLY ANY POINTER                *
*                                                                     *
***********************************************************************
CIR      PROC
         POP       (CI_A1,CI_N1,CI_A2,CI_N2,CI_D)
         AEQLC     CI_N2,0,CIR11
         MOVD      CI_CI,CI_A1
         BRANCH    CI99
CIR11    AEQLC     CI_N1,0,CIR12
         AEQLC     CI_D,0,CIR12
         MOVD      CI_CI,CI_A2
         BRANCH    CI99
CIR12    LHERE
         MULTC     CI_N1,CI_N1,DESCR
         MULTC     CI_N2,CI_N2,DESCR
         SUM       TEMP31,CI_N1,CI_N2
         PUSH      (CI_A1,CI_A2)
         SETVC     TEMP31,A
         RCALL     CI_CI,BLOCK,(TEMP31)
         POP       (CI_A2,CI_A1)
         MOVBLK    CI_CI,CI_A1,CI_N1
         SETAC     CI_J,0
         SUM       TEMP31,CI_CI,CI_N1
CIR1     LHERE
         ACOMP     CI_J,CI_N2,CI99,CI99
         INCRA     CI_J,DESCR
         GETD      TEMP32,CI_A2,CI_J
         SETAV     TEMP33,TEMP32
         SUM       TEMP33,TEMP33,CI_D
         SETVA     TEMP32,TEMP33
         PUTD      TEMP31,CI_J,TEMP32
         BRANCH    CIR1
CI99     LHERE
         RRTURN    CI_CI,1
CI_A1    DESCR     0,0,0
CI_N1    DESCR     0,0,0
CI_A2    DESCR     0,0,0
CI_N2    DESCR     0,0,0
CI_D     DESCR     0,0,0
CI_CI    DESCR     0,0,0
CI_J     DESCR     0,0,0
*
***********************************************************************
*                                                                     *
*         CLASS     CLASSIFIES ITS ARGUMENT AS EITHER A BLOCK WITH THE*
*         GRAIN, AGAINST THE GRAIN OR A STRING.  THE 'GRAIN' IS       *
*         CONTAINED IN TEMP1.                                         *
*         0  =  STRING                                                *
*         1  =  BLOCK  WITH THE GRAIN                                 *
*         2  =  BLOCK AGAINST THE GRAIN                               *
*                                                                     *
*         CALLING SEQUENCE:                                           *
*         RCALL  ______,CLASS,(BLOCK)                                 *
*         LOCATIONS CLOBBERED:   NONE                                 *
*                                                                     *
***********************************************************************
CLASS    PROC
         POP       (CL_B)
         VEQLC     CL_B,S,CLASS1
         SETAC     CL_CLASS,0
CLASS2   RRTURN    CL_CLASS,1
CLASS1   LHERE
         SETAC     CL_CLASS,1
         GETDC     CL_REG,CL_B,SET_
         VEQLC     CL_REG,0,CLASS3
         GETDC     CL_B,CL_B,ORG_
         VEQL      CL_B,TEMP1,,CLASS2
CLASS3   INCRA     CL_CLASS,1
         BRANCH    CLASS2
CL_CLASS DESCR     0,0,0
CL_B     DESCR     0,0,0
CL_REG   DESCR     0,0,0
*
**********************************************************************
*
*        COAG      COAGULATES THE ACTIVE EDGE AE BY INFORMATION
*        SUPPLIED WITH THE EDGE E.  THAT IS THE RELATIONS OF E ARE    *
*        THROWN IN WITH THE GROWING COLLECTION OF RELATIONS ASSOCIATED
*        WITH AE.
*        CALLING SEQUENCE:
*        RCALL     ,COAG,(AE,E)
*                                                                     *
***********************************************************************
COAG     PROC
         POP       (TEMP45,TEMP46)
*        TEMP45 IS AE
*        TEMP46 IS E
*        TEMP47 IS AESAVED
         MOVD      TEMP47,TEMP45
         SETAC     CO_HIT,0
COAG2    LHERE
         GETDC     TEMP31,TEMP45,VAL_
         RCALL     TEMP46,MINGLE,(TEMP31,TEMP46),COAG1
         SETAC     CO_HIT,1
         PUTDC     TEMP45,VAL_,ZEROCL
COAG1    LHERE
         AEQLIC    TEMP45,NEXT_,0,,COAG11
         GETDC     TEMP45,TEMP45,NEXT_
         BRANCH    COAG2
COAG11   LHERE
         AEQLC     CO_HIT,0,COAG12
*        NO HITS, APPEND E
         RCALL     TEMP31,BLOCK,(CO_DE)
         PUTDC     TEMP31,VAL_,TEMP46
         PUTDC     TEMP45,NEXT_,TEMP31
         BRANCH    COAG99
COAG12   LHERE
         MOVD      TEMP45,TEMP47
*        FIND THE FIRST NULL OPENING
COAG3    LHERE
         AEQLIC    TEMP45,VAL_,0,,COAG31
         GETDC     TEMP45,TEMP45,NEXT_
         BRANCH    COAG3
COAG31   PUTDC     TEMP45,VAL_,TEMP46
*        NOW CLEAR OUT THE NULL LINKS
COAG4    LHERE
         AEQLIC    TEMP45,NEXT_,0,,COAG99
         GETDC     TEMP31,TEMP45,NEXT_
         AEQLIC    TEMP31,VAL_,0,COAG41
         GETDC     TEMP31,TEMP31,NEXT_
         PUTDC     TEMP45,NEXT_,TEMP31
         BRANCH    COAG4
COAG41   LHERE
         GETDC     TEMP45,TEMP45,NEXT_
         BRANCH    COAG4
COAG99   BRANCH    RTN1
CO_HIT   DESCR     0,0,0
CO_DE    DESCR     2*DESCR,0,AEDGDT
*
**********************************************************************
*                                                                     *
*        COMPFR  COMPLETES A FRAME.  IF ALL WENT WELL IN THE MERGING  *
*        PROCESS, COMPFR HAS NOTHING TO DO BUT RETURN THE RESULTING   *
*        FRAME.  IF SOME INFORMATION WAS MISSING SO THAT A COMPLETE   *
*        FRAME COULD NOT BE BUILT THEN COMPFR MAKES A GUESS AS TO HOW *
*        THE COMPONENTS SHOULD FIT TOGETHER.                          *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,COMPFR,(AF)                                       *
*        REGISTERS CLOBBERED:   TEMP31,TEMP32                         *
*                                                                     *
**********************************************************************
COMPFR   PROC
         POP       (CF_AF)
         SETAC     CF_DIR,HT_
CF2      GETD      CF_E,CF_AF,CF_DIR
         VEQLC     CF_E,AEDGDT,CF1
         AEQLIC    CF_E,NEXT_,0,CF3
         GETDC     CF_E,CF_E,VAL_
         PUTD      CF_AF,CF_DIR,CF_E
         BRANCH    CF1
CF3      OUTPUT    CF_UNIT,CF_FMT
         RCALL     ,WARNING
         GETDC     TEMP31,CF_E,VAL_
CF5      GETDC     CF_E,CF_E,NEXT_
         AEQLC     CF_E,0,,CF4
         GETDC     TEMP32,CF_E,VAL_
         PUSH      (CF_AF,CF_E)
         RCALL     TEMP31,JE_LONGI,(TEMP31,TEMP32)
         POP       (CF_E,CF_AF)
         BRANCH    CF5
CF4      PUTD      CF_AF,CF_DIR,TEMP31
CF1      INCRA     CF_DIR,DESCR
         ACOMPC    CF_DIR,DTH_,RTN1,CF2,CF2
CF_AF    DESCR     0,0,0
CF_DIR   DESCR     0,0,0
CF_E     DESCR     0,0,0
CF_UNIT  DESCR     DIAGUN,0,0
CF_FMT   FORMAT    'Some information needed to form a merger was missing; A guess was made.\n'
*
***********************************************************************
*                                                                     *
*        DISTR   DISTRIBUTES IN AS EVEN A WAY AS POSSIBLE AN INTEGER  *
*        A  INTO N INTEGERS WHOSE SUM IS A.  IT RETURNS AN ARRAY      *
*                                                                     *
***********************************************************************
DISTR    PROC
         POP       (DI_A,DI_N)
        SETVC     DI_N,A
         RCALL     DI_DI,BLOCK,(DI_N)
DI1      LHERE
         ACOMPC    DI_N,0,,DI99,DI99
         DIVIDE    DI_M,DI_N,DI_DSC,FAIL
         DIVIDE    DI_V,DI_A,DI_M,FAIL
         PUTD      DI_DI,DI_N,DI_V
         SUBTRT    DI_A,DI_A,DI_V
         DECRA     DI_N,DESCR
         BRANCH    DI1
DI99     LHERE
         RRTURN    DI_DI,1
DI_DI    DESCR     0,0,0
DI_N     DESCR     0,0,0
DI_A     DESCR     0,0,0
DI_M     DESCR     0,0,0
DI_V     DESCR     0,0,0
DI_DSC   DESCR     DESCR,0,0				[PLB120]
*
***********************************************************************
*                                                                     *
*        DUMP_B  DUMPS  A  BLOCK                                      *
*        CALLING  SEQUENCE:                                           *
*        RCALL     ,DUMP_B,(BLOCK)                                    *
*                  NO REGISTERS ARE CLOBBERED                         *
*                                                                     *
***********************************************************************
DUMP_B   PROC
         OUTPUT    DP_UNIT,DP_FT1      PUT OUT HEADER
         POP       DP_BLOCK            FETCH ARG
         GETAC     DP_TEMP,DP_BLOCK,0  DOES ARG POINT TO BLOCK
         AEQL      DP_TEMP,DP_BLOCK,DP_NOBLK
         SETAC     DP_I,0              INITIALIZE ITERATION VARIABLE
         GETSIZ    DP_SIZE,DP_BLOCK
DP_LOOP  GETD      DP_TEMP,DP_BLOCK,DP_I
         OUTPUT    DP_UNIT,DP_FT2,(DP_TEMP,DP_TEMP,DP_TEMP)
         ACOMP     DP_I,DP_SIZE,DP_END,DP_END
         INCRA     DP_I,DESCR
         BRANCH    DP_LOOP
DP_NOBLK LHERE
DP_END   LHERE
         RRTURN    ,1
DUMP_A   PROC      DUMP_B
         POP       DP_BLOCK
         AEQLC     DP_BLOCK,0,DP1
         OUTPUT    DP_UNIT,DP_FT3,(ZEROCL)
         BRANCH    RTN1
DP1      LHERE
         GETSIZ    DP_SIZE,DP_BLOCK
         DIVIDE    DP_TEMP,DP_SIZE,DP_8,FAIL
         OUTPUT    DP_UNIT,DP_FT3,(DP_TEMP)
         SETAC     DP_I,DESCR
DP_LP    GETD      DP_TEMP,DP_BLOCK,DP_I
         LOCSP     YSP,DP_TEMP
         FASTPR    IOKEY,DP_UNIT,DP_UNIT,YSP,BLSP
         INCRA     DP_I,DESCR
         ACOMP     DP_I,DP_SIZE,RTN1,DP_LP,DP_LP
DP_UF1   DESCR     0,0,0
DP_8     DESCR     8,0,0
DP_FT3   FORMAT    '\nARRAY of length %d\n'
DP_FT1   FORMAT    '        Address            Flag           Value\n'
DP_FT2   FORMAT    '%A %L %V\n'
DP_I     DESCR     0,0,0
DP_SIZE  DESCR     0,0,0
DP_TEMP  DESCR     0,0,0
DP_BLOCK DESCR     0,0,0
DP_UNIT  DESCR     PRUNO,0,0
**********************************************************************
*                                                                     *
*        DUP  DUPLICATES A BLOCK B A NUMBER OF TIMES N IN THE         *
*        DIRECTION DIR                                                *
*        CALLING SEQUENCE (EXTERNAL):                                 *
*        DUP(B,DIR,N)                                                 *
*        WHERE DIR IS 0,1 OR 2 FOR VERTICAL, HORIZONTAL OR NORMAL     *
*                                                                     *
**********************************************************************
DUP      PROC
         SETAV     DUP_NA,INCL
         ACOMPC    DUP_NA,3,ARGNER,,ARGNER
         RCALL     XPTR,BLOKVAL,,FAIL
         IFPHY     XPTR,DUP2
         RCALL     XPTR,BCOPY,(XPTR)
DUP2     LHERE
         PUSH      XPTR
         RCALL     DUP_DIR,INTVAL,,FAIL
         PUSH      DUP_DIR
         RCALL     DUP_N,INTVAL,,FAIL
         POP       (DUP_DIR,XPTR)
         ACOMPC    DUP_N,0,,,FAIL
         VEQLC     XPTR,S,DUP1
         AEQLC     DUP_DIR,1,DUP1
         RCALL     XPTR,DUPE,(XPTR,DUP_N),RTXPTR
DUP1     LHERE
         RCALL     XPTR,FIXINL,(XPTR,XPTR)
         INCRA     DUP_DIR,1
         MULTC     DUP_DIR,DUP_DIR,DESCR
         GETDC     TEMP1,XPTR,ARRAY_
         GETDC     TEMP2,XPTR,FRAME_
         PUSH      XPTR
         RCALL     TEMP1,REPL,(TEMP1,TEMP2,DUP_DIR,DUP_N)
         POP       XPTR
         PUTDC     XPTR,ARRAY_,TEMP1
         BRANCH    RTXPTR
DUP_N    DESCR     0,0,0
DUP_DIR  DESCR     0,0,0
DUP_NA   DESCR     0,0,0
***********************************************************************
*                                                                     *
*        DUPE   WILL DUPLICATE A STRING N TIMES.                      *
*                                                                     *
***********************************************************************
DUPE     PROC
         POP       (YPTR,DU_N)
         AEQLC     DU_N,0,,RT1NUL
         LOCSP     YSP,YPTR
         GETLG     YCL,YSP
         MULT      YCL,YCL,DU_N
         ACOMP     YCL,MLENCL,INTR8          CHECK FOR EXCESSIVELY L S
         RCALL     ZPTR,CONVAR,(YCL)
         LOCSP     TSP,ZPTR
         SETLC     TSP,0
DUPE2    ACOMPC    DU_N,0,,DUPE1,DUPE1
         DECRA     DU_N,1
         APDSP     TSP,YSP
         BRANCH    DUPE2
DUPE1    LHERE
         RCALL     ZPTR,GNVARS,(YCL)
         RRTURN    ZPTR,1
DU_N     DESCR     0,0,0
***********************************************************************
*                                                                     *
*        E_ATTACH   ATTACHES AN EDGE E TO A POSSIBLY ACTIVE EDGE AE.  *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,E_ATTACH,(AE,E)                             *
*                                                                     *
***********************************************************************
E_ATTACH PROC
         POP       (EA_AE,EA_E)
*        IF THE FIRST ARGUMENT IS NOT ACTIVE MAKE IT ACTIVE.
         VEQLC     EA_AE,AEDGDT,,EA1
         PUSH      (EA_AE,EA_E)
         RCALL     EA_T,BLOCK,(EA_DE)
         POP       (EA_E,EA_AE)
         PUTDC     EA_T,VAL_,EA_AE
         MOVD      EA_AE,EA_T
*
EA1      MOVD      EA_T,EA_AE
EA2      LHERE
         AEQLIC    EA_T,NEXT_,0,,EA3
         GETDC     EA_T,EA_T,NEXT_
         BRANCH    EA2
EA3      LHERE
         PUSH      (EA_AE,EA_T,EA_E)
         RCALL     TEMP31,BLOCK,(EA_DE)
         POP       (EA_E,EA_T,EA_AE)
         PUTDC     EA_T,NEXT_,TEMP31
         PUTDC     TEMP31,VAL_,EA_E
         RRTURN    EA_AE,1
EA_AE    DESCR     0,0,0
EA_E     DESCR     0,0,0
EA_T     DESCR     0,0,0
EA_DE    DESCR     NEXT_,0,AEDGDT
***********************************************************************
*                                                                     *
*        EMB_PHY   EMBELLISHES A PHYSICAL BLOCK.  THE ARGUMENT IS A   *
*        TREE NODE WHICH POINTS TO AN EMBELLISHER                     *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,EMB_PHY,(TN)                                      *
*                                                                     *
***********************************************************************
EMB_PHY  PROC
         POP       XPTR
*                  IFPHY(VALUE(TN))          :F(EMERR)
         GETDC     TEMP31,XPTR,VALUE_
         IFPHY     TEMP31,EMERR
*                  B = ITEM(VALUE(TN),BL.)
         GETDC     TEMP1,TEMP31,BL_
*                  AF = ITEM(VALUE(TN),FRAME.)
         GETDC     TEMP3,TEMP31,FRAME_
*                  F  =  COPY(AF)
         RCALL     TEMP5,BCOPY,(TEMP3)
*                  GF = ITEM(VALUE(FATHER(TN)),FRAME)
         GETDC     TEMP32,XPTR,FATHER_
         GETDC     TEMP33,TEMP32,VALUE_
         GETDC     TEMP18,TEMP33,FRAME_
*                  PHY  =  ITEM(VALUE(FATHER(TN)),ARRAY_)
         GETDC     TEMP10,TEMP33,ARRAY_
*                  IDENT(B)                  :S(EM4)
         AEQLC     TEMP1,0,,EM4
*                  DIR  =  B<ORG.>
         GETDC     EM_DIR,TEMP1,ORG_
         SETAV     EM_DIR,EM_DIR
         MULTC     EM_DIR,EM_DIR,DESCR
*                  CURRENT = AF<DIR>
         GETD      TEMP4,TEMP3,EM_DIR
*                  F<DIR>  =  IDENT(DATATYPE(CURRENT),'AEDGE')  VALUE(
*                                            CURRENT)
         VEQLC     TEMP4,AEDGDT,EM11
         GETDC     TEMP31,TEMP4,VAL_
         PUTD      TEMP5,EM_DIR,TEMP31
EM11     LHERE
*                  SF = STRIP.FRAME(GF)
         RCALL     TEMP9,STRIP_F,(TEMP18)
*                  S = SUBBLOCK(GF,F)
         RCALL     TEMP11,SUBBLOCK,(TEMP18,TEMP5),EMERR1
*                  IFCONT(B)                 :F(EM3)
         IFCONT    TEMP1,EM3
*                  SS =  COPY(S)
         RCALL     TEMP20,BCOPY,(TEMP11)
*                  REG = REG(TN)
         GETDC     TEMP2,XPTR,TNREG_
*                  D  =  LSO(TN)
         GETDC     TEMP8,XPTR,LSO_
EM1      LHERE
*                  DF = STRIP.FRAME(ITEM(VALUE(D)),FRAME.)
         GETDC     TEMP31,TEMP8,VALUE_
         GETDC     TEMP32,TEMP31,FRAME_
         RCALL     TEMP21,STRIP_F,(TEMP32)
*                  D.PHY = ITEM(VALUE(D),ARRAY.)
         GETDC     TEMP22,TEMP31,ARRAY_
*                  SD = INIT.SUB(S,DF,DIR,REG)
         RCALL     TEMP15,INIT_SUB,(TEMP11,TEMP21,EM_DIR,TEMP2)
*                  INSERT(PHY,SF,D.PHY,SD)
         RCALL     ,INSERT,(TEMP10,TEMP9,TEMP22,TEMP15)
*                  D  =  RSIB(D)  DIFFER(RSIB(D))            :F(RETURN)
         GETDC     TEMP8,TEMP8,RSIB_
         AEQLC     TEMP8,0,,EM99
*                  IFREP(VALUE(D))           :F(EM1)
         GETDC     TEMP31,TEMP8,VALUE_
         IFREP     TEMP31,EM1
*                  CURRENT  =  NEXT(CURRENT)
         GETDC     TEMP4,TEMP4,NEXT_
*                  F<DIR>  =  VALUE(CURRENT)
         GETDC     TEMP32,TEMP4,VAL_
         PUTD      TEMP5,EM_DIR,TEMP32
*                  SNEXT = SUBBLOCK(GF,F)
         RCALL     TEMP23,SUBBLOCK,(TEMP18,TEMP5),EMERR1
*                  S  =  MIDREGION(SS,SNEXT,DIR)  :S(EM2)
         RCALL     TEMP11,MIDREG,(TEMP20,TEMP23,EM_DIR),(,EM2)
*                  S  =  MIDREGION(SNEXT,SS,DIR)     :S(EM2)
         RCALL     TEMP11,MIDREG,(TEMP23,TEMP20,EM_DIR),(,EM2)
*                  S  =  SNEXT
         MOVD      TEMP11,TEMP23
*                  SS  =  COPY(S)
         RCALL     TEMP20,BCOPY,(TEMP11)
*                  D  =  RSIB(D)           :(EM1)
         GETDC     TEMP8,TEMP8,RSIB_
         BRANCH    EM1
EM2      LHERE
*                  A  =  EXT(S<DIR>)
         GETD      TEMP31,TEMP11,EM_DIR
         SETAV     EM_A,TEMP31
*                  DPB = B.PB(D,A)
         PUSH      (EM_DIR,TEMP2,TEMP4,TEMP5,TEMP8,TEMP9,TEMP10,TEMP11)
         PUSH      (TEMP18,TEMP21,TEMP23)
         RCALL     TEMP24,B_PB,(TEMP8,EM_A)
         POP       (TEMP23,TEMP21,TEMP18)
         POP       (TEMP11,TEMP10,TEMP9,TEMP8,TEMP5,TEMP4,TEMP2,EM_DIR)
*                  DF = DPB<FRAME.>
         GETDC     TEMP14,TEMP24,FRAME_
*                  SD = INIT.SUB(S,DF,DIR,REG)
         RCALL     TEMP15,INIT_SUB,(TEMP11,TEMP14,EM_DIR,TEMP2)
*                  INSERT(PHY,SF,DPB<ARRAY.>,SD)
         GETDC     TEMP31,TEMP24,ARRAY_
         RCALL     ,INSERT,(TEMP10,TEMP9,TEMP31,TEMP15)
*                  S = SNEXT
         MOVD      TEMP11,TEMP23
*                  SS = COPY(S)
         RCALL     TEMP20,BCOPY,(TEMP11)
*                  D = RSIB(D)               :(EM1)
         GETDC     TEMP8,TEMP8,RSIB_
         BRANCH    EM1
EM4      LHERE
*                  F = STRIP.FRAME(GF)
         RCALL     TEMP9,STRIP_F,TEMP18
*                  S  =  SUBBLOCK(GF,F)
         RCALL     TEMP11,SUBBLOCK,(TEMP18,TEMP5),EMERR1
EM3      LHERE
*                  B = VALUE(TN)
         GETDC     TEMP1,XPTR,VALUE_
*                  INSERT(PHY,SF,B<ARRAY.>,S)     :(RETURN)
         GETDC     TEMP31,TEMP1,ARRAY_
         RCALL     ,INSERT,(TEMP10,TEMP9,TEMP31,TEMP11)
         BRANCH    EM99
EMERR1   LHERE
         OUTPUT    EM_DIAG,EM_FMT2
         RCALL     ,WARNING
         BRANCH    EM99
EMERR    LHERE
         OUTPUT    EM_DIAG,EM_FMT3
         RCALL     ,WARNING
         BRANCH    EM99
EM99     RRTURN    ,1
EM_A     DESCR     0,0,0
EM_DIR   DESCR     0,0,0
EM_DIAG  DESCR     DIAGUN,0,0
EM_FMT1  FORMAT 'A replicated block appears between two blocks which overlap\n'
EM_FMT2  FORMAT 'All or part of an embellisher could not be located within a merged block\n'
EM_FMT3  FORMAT 'Meaningless embellisher\n'
***********************************************************************
*                                                                     *
*        FICOM SEARCHES FOR A PAIR OF IDENTICAL NODES IN TWO LISTS OF *
*        NODES (LIST A1 HAS LENGTH N1 AND LIST A2 HAS LENGTH N2).  IF *
*        A PAIR OF IDENTICAL NODES CANNOT BE FOUND THEN THE FUNCTION  *
*        FAILS.  OTHERWISE GLOBAL INDICES TEMP31 AND TEMP32 ARE SET TO*
*        POINT TO THE IDENTICAL NODES.                                *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,FICOM,(A1,N1,A2,N2),(FAIL,SUCC)                   *
*                                                                     *
***********************************************************************
FICOM    PROC
         POP       (FC_A1,FC_N1,FC_A2,FC_N2)
         MOVD      TEMP31,ZEROCL
         MOVD      TEMP32,ZEROCL
         MULTC     FC_N1,FC_N1,DESCR
         MULTC     FC_N2,FC_N2,DESCR
FICOM2   LHERE
         INCRA     TEMP31,DESCR
         ACOMP     TEMP31,FC_N1,FAIL
         SETAC     TEMP32,0
         GETD      FC_ND1,FC_A1,TEMP31
FICOM1   LHERE
         INCRA     TEMP32,DESCR
         ACOMP     TEMP32,FC_N2,FICOM2
         GETD      FC_ND2,FC_A2,TEMP32
         AEQL      FC_ND1,FC_ND2,FICOM1,RTN2
FC_A1    DESCR     0,0,0
FC_A2    DESCR     0,0,0
FC_N1    DESCR     0,0,0
FC_N2    DESCR     0,0,0
FC_ND1   DESCR     0,0,0
FC_ND2   DESCR     0,0,0
***********************************************************************
*                                                                     *
*        FIX  IS A PRIMITIVE FUNCTION WHICH WILL CONVERT ANY BLOCK    *
*        TO PHYSICAL ORGANIZATION.  CALLING SEQUENCE:                 *
*             FIX(B,FLAG)                                             *
*        WHERE FLAG IS 1 WILL STRIP AWAY NODE INFORMATION.  IF FLAG   *
*        IS 0 OR ABSENT, ALL NODE INFO IS RETAINED.                   *
*             FIX(B,N1,N2,...,NK)                                     *
*        WILL REMOVE ALL NODE INFO EXCEPT THAT PERTAINING TO THE GIVEN*
*        NODES.                                                       *
*                                                                     *
***********************************************************************
FIX      PROC
         PUSH      INCL
         RCALL     TEMP1,BLOKVAL,,FAIL
         POP       INCL
         MOVD      TEMP2,NULVCL
         VEQLC     INCL,1,,FIXCL
         PUSH      (INCL,TEMP1)
         RCALL     TEMP2,ARGVAL,,FAIL
         POP       (TEMP1,INCL)
         AEQLC     TEMP2,1,FIXNDS
FIXCL    RCALL     ZPTR,FIXINL,(TEMP1,TEMP2),RTZPTR
FIXNDS   LHERE     ,                     TEMP2 IS A NODE
         PUSH      (TEMP2,INCL)
         RCALL     ZPTR,FIXINL,(TEMP1,NULVCL)
         POP       (INCL,TEMP2)
         SETAV     FX_ARGS,INCL          CONTAINS NO. OF ARGS
         DECRA     FX_ARGS,2             ... REMAINING
         GETDC     TEMP10,ZPTR,FRAME_    TEMP10 HOLDS OLD FRAME
         RCALL     TEMP20,STRIP_F,(TEMP10)
*                                        TEMP20 HOLDS NEW FRAME
         BRANCH    FIX1
FIX2     LHERE     ,                     PICK UP NEXT ARGUMENT
         ACOMPC    FX_ARGS,0,,FIX99,FIX99  ARE WE DONE?
         DECRA     FX_ARGS,1             NO, GO ON
         PUSH      (FX_ARGS,TEMP10,TEMP20,ZPTR)
         RCALL     TEMP2,BLOKVAL,,FAIL
         POP       (ZPTR,TEMP20,TEMP10,FX_ARGS)
FIX1     LHERE     ,                     PROCESS NODE (TEMP2)
         GETDC     FX_ND,TEMP2,ID_       GET THE NODE I.D.
         SETAC     FX_DIR,HT_            DIRECTION 1 IS HEIGHT
FIX11    GETD      TEMP11,TEMP10,FX_DIR  GET THE OLD EDGE
         RELS TEMP12,TEMP11              GET THE OLD RELATIONS
         NN        TEMP13,TEMP11         FIND THE NO. OF NODES
*        FIND A COMMON NODE
         RCALL     ,FICOM,(FX_A1,FX_N1,TEMP12,TEMP13),FIX2
         GETD      TEMP14,TEMP12,TEMP32  GET FOUND NODE
         SETAV     TEMP13,TEMP14         GET DISTANCE
         GETD      TEMP21,TEMP20,FX_DIR  GET NEW EDGE
*  ADD NODE-PAIR TO IT
         RCALL     TEMP21,ADD_NP,(TEMP21,TEMP14,TEMP13)
         PUTD      TEMP20,FX_DIR,TEMP21  PUT AUGMENTED EDGE BACK
         INCRA     FX_DIR,DESCR          GET NEXT DIRECTION
         ACOMPC    FX_DIR,DTH_,FIX2,FIX11,FIX11   ARE WE BEYOND DEPTH?
FIX99    LHERE
         PUTDC     ZPTR,FRAME_,TEMP20
         BRANCH    RTZPTR
FX_DIR   DESCR     0,0,0                 HOLDS CURRENT DIRECTION
FX_ARGS  DESCR     0,0,0                 HOLDS NO. OF ARGUMENTS.
FX_A1    DESCR     FX_N1,0,4             SIMULATED ARRAY PTR.
FX_N1    DESCR     1,0,6                 SIMULATED ARRAY OF RELATIONS.
FX_ND    DESCR     0,0,0                 NODE-DISTANCE(TO BE PLUGGED)
***********************************************************************
*                                                                     *
*        FIXINL IS THE INTERNAL VERSION OF THE FIX ROUTINE            *
*        CALLING SEQUENCE:                                            *
*             RCALL   ______,FIXINL,(BLOCK,FLAG)                      *
*                                                                     *
***********************************************************************
FIXINL   PROC
         POP       (FIX_B,FIX_FLAG)
         IFPHY     FIX_B,,FIXI1
         MOVD      TEMP50,FX_NN
         RCALL     FIX_B,T_LEAF,(NULVCL,NULVCL,FIX_B)
         RCALL     FIX_B,B_PB,(FIX_B)
         PUTDC     FIX_B,BL_,NULVCL
         MOVD      TEMP50,FX_NN
FIXI1    LHERE
         RCALL     FIX_B,BCOPY,FIX_B
         AEQLC     FIX_FLAG,0,,FIXI99
         GETDC     TEMP31,FIX_B,FRAME_
         PUSH      FIX_B
         RCALL     TEMP31,STRIP_F,(TEMP31)
         POP       FIX_B
         PUTDC     FIX_B,FRAME_,TEMP31
FIXI99   LHERE
         RRTURN    FIX_B,1
FIX_B    DESCR     0,0,0
FIX_FLAG DESCR     0,0,0
FX_NN    DESCR     FX_NA,0,A
FX_NA    DESCR     FX_NA,0,2*DESCR
         DESCR     2*DESCR,0,0
         DESCR     0,0,0
***********************************************************************
*                                                                     *
*        FORCING    FINDS THE FORCING SIZE OF THE BLOCK ASSOCIATED    *
*        WITH TREE NODE TN IN THE DIRECTION DIR.  THE FORCING SIZE OF *
*        A BLOCK IS THE ABSOLUTELY MINIMUM SPACE THAT A BLOCK CAN     *
*        OCCUPY TAKING THE MINIMUM OVERALL POSSIBLE ENVIRONMENT.      *
*        CALLING SEQUENCE:                                            *
*        RCALL    ______,FORCING,(TN,DIR)                             *
*        WHERE DIR IS EQUAL TO EITHER HT_, WTH_, OR DTH_.             *
*        LOCATIONS CLOBBERED:  POTENTIALLY ANYTHING                   *
*                                                                     *
***********************************************************************
FORCING  PROC
         POP       (FO_TN,FO_DIR)
         MOVD      FO_FO,FO_ZERO
         GETDC     FO_B,FO_TN,VALUE_
         VEQLC     FO_B,S,FO1
         AEQLC     FO_B,0,,FO99
         AEQLC     FO_DIR,WTH_,,FO2
         SETAC     FO_FO,1
         BRANCH    FO99
FO2      GETSIZ    FO_FO,FO_B
         SETVC     FO_FO,I
         BRANCH    FO99
FO1      LHERE
         GETDC     TEMP1,FO_B,ORG_
         SETAV     TEMP1,TEMP1
         SELBRA    TEMP1,(FORCE1,FORCE2,FORCE3,FORCE4,FORCE5,FORCE6,FORCE7,FORCE8,FORCE9)
*
*        CONTIGUOUS ORGANIZATION
*
FORCE1   LHERE
FORCE2   LHERE
FORCE3   LHERE
         PUSH      FO_TN
         RCALL     FO_P,LSOHN,FO_TN
         POP       (FO_TN)
*        IS THE ORG. THE SAME AS THE DIRECTION?  IF SO WE MUST TOTAL
*        THE FORCING SIZES OF EACH DAUGHTER.  OTHERWISE WE FIND THE MAX
         SETAC     FO_SW,1             SWITCH IS 1 IF ORTHOGONAL
         MULTC     TEMP1,TEMP1,DESCR
         AEQL      TEMP1,FO_DIR,FO3    IS 2 IF LONGITUDINAL
         SETAC     FO_SW,2
FO3      LHERE
         BRANCH    FO4
FO31     GETDC     FO_P,FO_P,RSIB_
FO4      AEQLC     FO_P,0,,FO99
         PUSH      (FO_P,FO_DIR,FO_SW,FO_FO)
         RCALL     TEMP1,FORCING,(FO_P,FO_DIR)
         POP       (FO_FO,FO_SW,FO_DIR,FO_P)
         SELBRA    FO_SW,(FO_ORTH,FO_LONGI)
FO_ORTH  LHERE
         ACOMP     FO_FO,TEMP1,FO31,FO31
         MOVA      FO_FO,TEMP1
         BRANCH    FO31
FO_LONGI LHERE
         SUM       FO_FO,FO_FO,TEMP1
         BRANCH    FO31
*
*        COMPOSITE ORGANIZATION
*
FORCE4   LHERE
         PUSH      (FO_DIR)
         RCALL     FO_B,B_PB,(FO_TN,NULVCL)
         POP       (FO_DIR)
         GETDC     FO_B,FO_B,FRAME_
         GETD      FO_E,FO_B,FO_DIR
         TRL       FO_FO,FO_E
         BRANCH    FO99
*
*        ITERATED AND REPLICATED ORGANIZATION
*
FORCE5   LHERE
FORCE6   LHERE
         RCALL     FO_P,PAR_CONG,(FO_TN),FO99
         GETDC     FO_P,FO_P,VALUE_    GET THE ORG. OF THE PARENTIAL
         GETDC     FO_P,FO_P,ORG_      CONGLOMERATE
         SETAV     FO_P,FO_P           TIMES
         MULTC     FO_P,FO_P,DESCR     DESCR.
         AEQL      FO_P,FO_DIR,FORCE52
         AEQLC     TEMP1,REP_,FORCE51,FO99
FORCE52  AEQLC     TEMP1,IT_,FORCE51,FO99
FORCE51  LHERE
         RCALL     FO_TN,LSOHN,(FO_TN)
         RCALL     FO_FO,FORCING,(FO_TN,FO_DIR),FO99
*
*        NODE ORGANIZATION
*
FORCE7   LHERE
         BRANCH    FORCE51
FORCE8   LHERE     ,                   THIS LOCATION CAN'T BE REACHED
         SETAC     ERRTYP,ERRNO+1
         BRANCH    FTLEND
*
*        PHYSICAL ORGANIZATION
*
FORCE9   LHERE
         GETDC     FO_P,FO_B,FRAME_    FIRST GET
         GETD      FO_P,FO_P,FO_DIR    THE RIGHT EDGE
         VEQLC     FO_P,AEDGEDT,,FORCE91
         TRL       FO_FO,FO_P
         BRANCH    FO99
FORCE91  LHERE
         GETDC     FO_E,FO_P,VAL_
         TRL       TEMP1,FO_E
         SUM       FO_FO,FO_FO,TEMP1
         GETDC     FO_P,FO_P,NEXT_
         AEQLC     FO_P,0,FORCE91,FO99
*
FO99     RRTURN    FO_FO,1
*
FO_FO    DESCR     0,0,0
FO_P     DESCR     0,0,0
FO_E     DESCR     0,0,0
FO_B     DESCR     0,0,0
FO_DIR   DESCR     0,0,0
FO_TN    DESCR     0,0,0
FO_SW    DESCR     0,0,0
FO_ZERO  DESCR     0,0,I
***********************************************************************
*                                                                     *
*        F_JOIN     JOINS TWO FRAMES TOGETHER IN THE DIRECTION DIR    *
*        WITH REGISTRATION REG.  THE FIRST FRAME IS MODIFIED          *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,F_JOIN,(DIR,F1,F2,REG)                      *
*                                                                     *
***********************************************************************
F_JOIN   PROC
         POP       (FJ_DIR,FJ_F1,FJ_F2,FJ_REG)
*FJ1	 LHERE
         DEQL      FJ_F2,NULVCL,,FJ99
         SETAC     FJ_I,HT_
FJ6      GETD      FJ_T1,FJ_F1,FJ_I
         GETD      FJ_T2,FJ_F2,FJ_I
         GETD      FJ_RI,FJ_REG,FJ_I
         PUSH      (FJ_F1,FJ_F2,FJ_REG)
         AEQL      FJ_I,FJ_DIR,FJ3
         RCALL     FJ_T,JE_LONGI,(FJ_T1,FJ_T2),FJ4
FJ3      RCALL     FJ_T,JE_ORTHO,(FJ_T1,FJ_T2,FJ_RI)
FJ4      LHERE
         POP       (FJ_REG,FJ_F2,FJ_F1)
         PUTD      FJ_F1,FJ_I,FJ_T
         AEQLC     FJ_I,DTH_,,FJ99
         INCRA     FJ_I,DESCR
         BRANCH    FJ6
FJ99     RRTURN    FJ_F1,1
FJ_I     DESCR     0,0,0
FJ_F1    DESCR     0,0,0
FJ_F2    DESCR     0,0,0
FJ_REG   DESCR     0,0,0
FJ_RI    DESCR     0,0,0
FJ_T1    DESCR     0,0,0
FJ_T2    DESCR     0,0,0
FJ_DIR   DESCR     0,0,0
FJ_T     DESCR     0,0,0
***********************************************************************
*                                                                     *
*        ENTRY POINTS:                                                *
*            HOR_REG, VER_REG, NORM_REG                               *
*        ARE EXTERNAL ENTRY POINTS FOR SETTING THE REGISTRATIONS IN TH*
*        E INDICATED DIRECTIONS                                       *
*                                                                     *
***********************************************************************
HOR_REG  PROC
         SETAC     GR_DIR,WTH_-DESCR
         BRANCH    GR1,GR1
VER_REG  PROC
         SETAC     GR_DIR,HT_-DESCR
         BRANCH    GR1,GR1
NORM_REG PROC
         SETAC     GR_DIR,DTH_-DESCR
         BRANCH    GR1,GR1
GR1      PROC
         VEQLC     INCL,1,GRERR
         RCALL     TEMP1,BLOKVAL,,FAIL
         IFCONT    TEMP1,FAIL
         AEQLIC    TEMP1,REG_,0,GR2
         RCALL     TEMP2,BLOCK,(GR_REG)
         PUTDC     TEMP1,REG_,TEMP2
GR2      GETDC     XPTR,TEMP1,REG_
         SUM       XPTR,XPTR,GR_DIR
         BRANCH    RTXNAM
GRERR    BRANCH    ARGNER
GR_REG   DESCR     3*DESCR,0,A
GR_DIR   DESCR     0,0,0
***********************************************************************
*                                                                     *
*        IDENT_SB  RETURNS THE IDENTITY SUBBLOCK.  THAT IS THE        *
*        IMPROPER, NONNULL, SUBBLOCK OF A BLOCK WHOSE SIZE IS DICTATED*
*        BY THE STRIPPED FRAME RECEIVED AS ARGUMENT.                  *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,IDENT_SB,(SF)                               *
*                                                                     *
***********************************************************************
IDENT_SB PROC
         RCALL     ID_ID,BLOCK,(ID_D)
         POP       ID_SF
         GETDC     ID_T,ID_SF,HT_
         SETVA     ID_T,ID_T
         PUTVC     ID_ID,HT_,ID_T
         GETDC     ID_T,ID_SF,WTH_
         SETVA     ID_T,ID_T
         PUTVC     ID_ID,WTH_,ID_T
         GETDC     ID_T,ID_SF,DTH_
         SETVA     ID_T,ID_T
         PUTVC     ID_ID,DTH_,ID_T
         RRTURN    ID_ID,1
ID_D     DESCR     DTH_,0,SBDT
ID_ID    DESCR     0,0,0
ID_T     DESCR     0,0,0
ID_SF    DESCR     0,0,0
***********************************************************************
*                                                                     *
*        INIT.SUB   RETURNS AN INITIAL SUBBLOCK OF THE STRIPPED FRAME *
*        SF.  THE ARGUMENT SB IS A SUBBLOCK.  DIR IS A DIRECTION AND  *
*        REG IS AN ARRAY OF REGISTRATIONS.  THE FUNCTION RETURNS      *
*        A SUBBLOCK AND REDUCES SB ACCORDINGLY.                       *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,INIT.SUB,(SB,SF,DIR,REG)                    *
*                                                                     *
***********************************************************************
INIT_SUB PROC
         RCALL     IS_IS,BLOCK,(IS_SBD)
         POP       (IS_SB,IS_SF,IS_DIR,IS_REG)
         MOVD      IS_DS,IS_DIR
*
         GETD      TEMP31,IS_SF,IS_DIR
         GETD      TEMP32,IS_SB,IS_DIR
         MOVD      TEMP33,TEMP32
         SETVA     TEMP32,TEMP31
         PUTD      IS_IS,IS_DIR,TEMP32
*
         SETAV     TEMP34,TEMP33
         SUBTRT    TEMP34,TEMP34,TEMP31
         SUM       TEMP33,TEMP33,TEMP31
         SETVA     TEMP33,TEMP34
         PUTD      IS_SB,IS_DIR,TEMP33
*
IS1      LHERE
         CYC       IS_DIR
*
         AEQL      IS_DIR,IS_DS,,IS2
         GETD      IS_ST,IS_SB,IS_DIR
         SETAV     TEMP31,IS_ST
         GETD      IS_SFD,IS_SF,IS_DIR
         GETD      TEMP33,IS_REG,IS_DIR
         RCALL     ,PRE_SUF,(TEMP31,IS_SFD,TEMP33)
*
         SUM       IS_ST,IS_ST,TEMP31
         SETVA     IS_ST,IS_SFD
         PUTD      IS_IS,IS_DIR,IS_ST
*
         BRANCH    IS1
*
IS2      LHERE
         RRTURN    IS_IS,1
IS_IS    DESCR     0,0,0
IS_DIR   DESCR     0,0,0
IS_SF    DESCR     0,0,0
IS_SBD   DESCR     3*DESCR,0,SBDT
IS_SB    DESCR     0,0,0
IS_REG   DESCR     0,0,0
IS_SFD   DESCR     0,0,0
IS_ST    DESCR     0,0,0
IS_DS    DESCR     0,0,0
***********************************************************************
*                                                                     *
*        INSERT   INSERTS A LOCAL PHYSICAL BLOCK (LP) INTO A GLOBAL   *
*        PHYSICAL BLOCK (GP) ACCORDING TO A POSITION INDICATED BY     *
*        SUBBLOCK SB.  GF IS A STRIPPED FRAME OF THE GLOBAL BLOCK     *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,INSERT,(GP,GF,LP,SB)                              *
*        REGISTERS CLOBBERED:   TEMP31,TEMP32,TEMP35,TEMP36,ZPTR,VSP  *
*                  ,XSP,YSP,ZSP                                       *
*                                                                     *
***********************************************************************
INSERT   PROC
         POP       (TEMP35,IN_GF,TEMP36,IN_SB)
         GETDC     IN_HO,IN_SB,HT_
         SETAV     IN_H,IN_HO
         GETDC     IN_WO,IN_SB,WTH_
         SETAV     IN_W,IN_WO
         GETDC     IN_DO,IN_SB,DTH_
         SETAV     IN_D,IN_DO
         GETDC     IN_DG,IN_GF,DTH_
         GETDC     IN_WG,IN_GF,WTH_
         PUTLG IN_REM,IN_WO
         AEQLC     IN_W,0,,IN99
*        INITIALIZE N AND INC
         MULT      IN_N,IN_HO,IN_DG
         SUBTRT    IN_INC,IN_DG,IN_D
         SUBTRT    IN_N,IN_N,IN_INC
         SUM       IN_N,IN_N,IN_DO
         MULTC     IN_N,IN_N,DESCR
         MULTC     IN_INC,IN_INC,DESCR
         SETAC     IN_I,0
         SETAC     IN_M,0
         LOCSP     TXSP,BKGNCL
IN1      LHERE
         SETAC     IN_J,0
         INCRA     IN_I,1
         ACOMP     IN_I,IN_H,IN99
         SUM       IN_N,IN_N,IN_INC
IN2      LHERE
         INCRA     IN_J,1
         ACOMP     IN_J,IN_D,IN1
         INCRA     IN_M,DESCR
         INCRA     IN_N,DESCR
*        N  NOW POINTS INTO THE GLOBAL PHYSICAL BLOCK
*        M NOW POINTS INTO THE LOCAL PHYSICAL BLOCK
         GETD      TEMP31,TEMP35,IN_N
         LOCSP     VSP,TEMP31                VSP IS STRING OF GLOBAL
         GETD      TEMP32,TEMP36,IN_M
         LOCSP     YSP,TEMP32                YSP IS STRING OF LOCAL
         RCALL     ZPTR,CONVAR,(IN_WG) MANUFACTURE STR. STRUCTURE
         LOCSP     XSP,ZPTR
         SETLC     XSP,0
         APDSP     XSP,VSP             ZPTR NOW POINTS TO REPLICA OF
*                                      GLOBAL STRING
         REMSP     ZSP,XSP,IN_REM      ZSP SPECIFIES AREA INTO WHICH
*                                      LOCAL STRING IS TO BE MERGED
         MERGSP    ZSP,YSP,TXSP        NOW DO THE MERGE
         RCALL     ZPTR,GNVARS,(IN_WG)  PUT STRING INTO HASH STORAGE
         PUTD      TEMP35,IN_N,ZPTR
         BRANCH    IN2
IN99     LHERE
         AEQLC     DMPCL,50,RTN1
         OUTPUT    IN_UNIT,IN_FT1
         RCALL     ,DUMP_A,(TEMP35)
         RCALL     ,DUMP_B,(IN_GF)
         RCALL     ,DUMP_A,(TEMP36)
         RCALL     ,DUMP_B,(IN_SB)
         BRANCH    RTN1
*
IN_UNIT  DESCR     DIAGUN,0,0
IN_FT1   FORMAT    '\nOn exit from INSERT: GP,GF,LP,SB\n'
IN_HO    DESCR     0,0,0
IN_H     DESCR     0,0,0
IN_WO    DESCR     0,0,0
IN_W     DESCR     0,0,0
IN_DO    DESCR     0,0,0
IN_D     DESCR     0,0,0
IN_DG    DESCR     0,0,0
IN_WG    DESCR     0,0,0
IN_GF    DESCR     0,0,0
IN_SB    DESCR     0,0,0
IN_N     DESCR     0,0,0
IN_M     DESCR     0,0,0
IN_I     DESCR     0,0,0
IN_J     DESCR     0,0,0
IN_INC   DESCR     0,0,0
IN_GP    DESCR     0,0,0
IN_REM   SPEC      0,0,0,0,0
***********************************************************************
*                                                                     *
*        JE_LONGI   JOINS TWO EDGES LONGITUDINALLY.  THE FIRST EDGE   *
*        IF IT IS COMPLEX IS SUBJECT TO MODIFICATION                  *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,JE_LONGI,(E1,E2)                            *
*                                                                     *
***********************************************************************
JE_LONGI PROC
         POP       (JEL_E1,JEL_E2)
         VEQLC     JEL_E1,EDGDT,,JEL1
         VEQLC     JEL_E2,EDGDT,,JEL1
         SUM       JEL_E1,JEL_E1,JEL_E2
         BRANCH    JEL99
JEL1     LHERE
         TRL       JEL_T1,JEL_E1
         TRL       JEL_T2,JEL_E2
         SUM       JEL_T,JEL_T1,JEL_T2
         NN        JEL_N1,JEL_E1
         NN        JEL_N2,JEL_E2
         SUM       JEL_N,JEL_N1,JEL_N2
         RELS      JEL_R1,JEL_E1
         RELS      JEL_R2,JEL_E2
         BRANCH    JELCO
***********************************************************************
*                                                                     *
*        JE_ORTHO  JOINS TWO EDGES ORTHOGONALLY.                      *
*        THE THIRD ARGUMENT IS THE REGISTRATION.                      *
*        THE FIRST ARGUMENT IS SUBJECT TO BEING MODIFIED              *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,JE_ORTHO,(E1,E2,REG)                        *
*                                                                     *
***********************************************************************
JE_ORTHO PROC      JE_LONGI
         POP       (JEL_E1,JEL_E2,JEL_REG)
         VEQLC     JEL_E1,EDGDT,,JEL3
         VEQLC     JEL_E2,EDGDT,,JEL3
         MAX       JEL_E1,JEL_E1,JEL_E2
         BRANCH    JEL99
JEL3     LHERE
         TRL       JEL_T1,JEL_E1
         TRL       JEL_T2,JEL_E2
         NN        JEL_N1,JEL_E1
         NN        JEL_N2,JEL_E2
         RELS      JEL_R1,JEL_E1
         RELS      JEL_R2,JEL_E2
         ACOMP     JEL_T1,JEL_T2,JEL4,JEL4
         SWAP      JEL_T1,JEL_T2
         SWAP      JEL_N1,JEL_N2
         SWAP      JEL_R1,JEL_R2
JEL4     LHERE
         SUM       JEL_N,JEL_N1,JEL_N2
         MOVD      JEL_T,JEL_T1
         RCALL     ,PRE_SUF,(JEL_T1,JEL_T2,JEL_REG)
         MOVD      JEL_T1,TEMP31
JELCO    LHERE
         PUSH      JEL_E1
         RCALL     JEL_R,CIR,(JEL_R1,JEL_N1,JEL_R2,JEL_N2,JEL_T1)
         POP       JEL_E1
         VEQLC     JEL_E1,EDGDT,,JEL2
         PUSH      JEL_R
         RCALL     JEL_E1,BLOCK,(JEL_SIZE)
         POP       JEL_R
JEL2     PUTDC     JEL_E1,TR1_,JEL_T
         PUTDC     JEL_E1,NN1_,JEL_N
         PUTDC     JEL_E1,RELS1_,JEL_R
JEL99    RRTURN    JEL_E1,1
JEL_T1   DESCR     0,0,0
JEL_T2   DESCR     0,0,0
JEL_T    DESCR     0,0,0
JEL_N1   DESCR     0,0,0
JEL_N2   DESCR     0,0,0
JEL_R1   DESCR     0,0,0
JEL_R2   DESCR     0,0,0
JEL_R    DESCR     0,0,0
JEL_E1   DESCR     0,0,0
JEL_E2   DESCR     0,0,0
JEL_SIZE DESCR     RELS1_,0,EDGDT
JEL_REG  DESCR     0,0,0
JEL_N    DESCR     0,0,0
***********************************************************************
*                                                                     *
*         JOIN    JOINS TWO BLOCKS TOGETHER ACCORDING TO AN ORGANIZA- *
*         TION INDICATED IN TEMP1.                                    *
*         CALLING SEQUENCE:                                           *
*         RCALL    ______,JOIN,(B1,B2)                                *
*         LOCATIONS CLOBBERED:  WCL,XPTR,YPTR,TEMP2                   *
*                                                                     *
***********************************************************************
JOIN     PROC
         POP       (JN_B1,JN_B2)
         DEQL      JN_B1,NULVCL,JOIN1
         MOVD      WCL,JN_B2
         BRANCH    JOIN99
JOIN1    DEQL      JN_B2,NULVCL,JOIN2
         MOVD      WCL,JN_B1
         BRANCH    JOIN99
JOIN2    RCALL     JN_CL1,CLASS,JN_B1
         MULTC     JN_CL1,JN_CL1,3
         RCALL     JN_CL2,CLASS,JN_B2
         SUM        JN_CL1,JN_CL1,JN_CL2
         INCRA     JN_CL1,1
         PUSH      (JN_B1,JN_B2)
         SELBRA    JN_CL1,(ST_ST,ST_BW,ST_BA,BW_ST,BW_BW,BW_BA,BA_ST,BA_BW,BA_BA)
ST_BA    LHERE
BA_ST    LHERE
BA_BA    RCALL     WCL,BLOCK,(JN_SIZE)
         POP       (JN_B2,JN_B1)
         PUTVC     WCL,ORG_,TEMP1
         SETAC     TEMP1,FIRST_+DESCR
         PUTAC     WCL,TOP_,TEMP1
         PUTDC     WCL,FIRST_,JN_B1
         PUTDC     WCL,FIRST_+DESCR,JN_B2
         BRANCH    JOIN99
ST_BW    LHERE
BA_BW    LHERE
         RCALL     WCL,BCOPY,JN_B2
         RCALL     ,BHEAD
         POP       (JN_B2,JN_B1)
         PUTDC     WCL,FIRST_,JN_B1
         BRANCH    JOIN99
BW_ST    LHERE
BW_BA    LHERE
         RCALL     WCL,BCOPY,JN_B1
         RCALL     JN_TOP,BTAIL
         POP       (JN_B2,JN_B1)
         PUTD      WCL,JN_TOP,JN_B2
         BRANCH    JOIN99
BW_BW    LHERE
         RCALL     WCL,BCOPY,JN_B1
         POP       TEMP2
         GETDC     JN_TOP,TEMP2,TOP_
         SETAC     JN_I,FIRST_
BW_BW_1  LHERE
         ACOMP     JN_I,JN_TOP,JOIN99
         RCALL     JN_K,BTAIL
         GETD      TEMP22,TEMP2,JN_I
         PUTD      WCL,JN_K,TEMP22
         INCRA     JN_I,DESCR
         BRANCH    BW_BW_1
ST_ST    VEQLC     TEMP1,PAR_,BA_BA
         MOVD      XPTR,JN_B1
         MOVD      YPTR,JN_B2
         RCALL     WCL,CONVV,,(FAIL,,JOIN99)
JOIN99   RRTURN    WCL,1
JN_B1    DESCR     0,0,0
JN_B2    DESCR     0,0,0
JN_CL1   DESCR     0,0,0
JN_CL2   DESCR     0,0,0
JN_TOP   DESCR     0,0,0
JN_I     DESCR     0,0,0
JN_K     DESCR     0,0,0
JN_SIZE  DESCR     3*DESCR+FIRST_,0,BL
***********************************************************************
*                                                                     *
*        LOC(N,B,D)  IS AN EXTERNAL FUNCTION WHICH WILL DETERMINE THE *
*        LOCATION OF A NODE N IN BLOCK B IN DIRECTION D.              *
*                                                                     *
***********************************************************************
LOC      PROC
         SETAV     LO_AC,INCL
         ACOMPC    LO_AC,2,,,FAIL
         PUSH      LO_AC
         RCALL     TEMP1,BLOKVAL,,FAIL
         PUSH      TEMP1
         RCALL     TEMP2,BLOKVAL,,FAIL
         RCALL     TEMP2,FIXINL,(TEMP2,NULVCL)
         POP       (TEMP1,LO_AC)
         MOVD      TEMP3,ZEROCL
         AEQLC     LO_AC,3,LOC1
         PUSH      (TEMP1,TEMP2)
         RCALL     TEMP3,INTVAL,,FAIL
LOC1     LHERE
         GETDC     LO_ND,TEMP1,ID_       GET THE NODE I.D.
         INCRA     TEMP3,1
         MULTC     TEMP3,TEMP3,DESCR     MULT. DIR. BY ADDR. MULT.
         GETDC     TEMP4,TEMP2,FRAME_    GET THE FRAME
         GETD      TEMP5,TEMP4,TEMP3     GET APPROPRIATE EDGE
         RELS      TEMP6,TEMP5           GET RELATIONS
         NN        TEMP7,TEMP5           GET NUMBER OF NODES
*                                        NOW FIND THE NODE IN QUESTION
         RCALL     ,FICOM,(LO_A1,LO_N1,TEMP6,TEMP7),FAIL
         GETD      ZPTR,TEMP6,TEMP32     GET FOUND NODE
         SETAV     ZPTR,ZPTR             GET DISTANCE INTO ADD.
         SETVC     ZPTR,I            SET INTEGER DATA TYPE
         BRANCH    RTZPTR
LO_AC    DESCR     0,0,0                 ARGUMENT COUNT
LO_A1    DESCR     LO_N1,0,4             SIMULATED ARRAY PTR
LO_N1    DESCR     1,0,6                 NUMBER OF NODES IN THE ARRAY
LO_ND    DESCR     0,0,0                 NODE-DISTANCE (TO BE PLUGGED)
LRECL    PROC
CC       PROC
         VEQLC     INCL,1,ARGNER
         RCALL     XPTR,INTVAL,,FAIL
         MOVD    YPTR,ONECL        PUT DEFAULT VALUE INTO YPTR
         SETVC   YPTR,I            MAKE IT AN INTEGER
         AEQLC   XPTR,0,,LRECL5    EQUAL TO 1 IF XPTR = 0
         SETAC   YPTR,0            EQUAL TO 0 IF OTHERWISE
LRECL5   LHERE
         AEQLC     TEMP48,0,,LRECL4
LRECL3   LOCAPT    XPTR,TEMP48,XPTR,LRECL2
         INCRA     XPTR,DESCR
         SETVC     XPTR,N
         BRANCH    RTXNAM
LRECL2   LHERE
         RCALL     TEMP48,AUGATL,(TEMP48,XPTR,YPTR)
         BRANCH    LRECL3
LRECL4   LHERE
         MOVD      TEMP48,LR_1
         BRANCH    LRECL2
LR_1     DESCR     LR_2,0,B
LR_2     DESCR     LR_2,0,2*DESCR
         DESCR     0,0,0
         DESCR     0,0,0
***********************************************************************
*                                                                     *
*        LSOHN  RETURNS THE LEFT SON OF A TREE NODE.                  *
*        IF THIS LEFT SON IS NULL IT BUILDS THE TREE NODES FOR EACH   *
*        DAUGHTER.                                                    *
*        CALLING SEQUENCE:                                            *
*          RCALL    ______,LSOHN,(TN)                                 *
*        LOCATIONS CLOBBERED:   NONE                                  *
*                                                                     *
***********************************************************************
LSOHN    PROC
         POP       LS_TN
         GETDC     LS_LS,LS_TN,LSO_
         AEQLC     LS_LS,0,LS99
         GETDC     LS_B,LS_TN,VALUE_
         GETDC     LS_I,LS_B,TOP_
         GETDC     LS_ORG,LS_B,ORG_
LS1      LHERE
         ACOMPC    LS_I,FIRST_,,,LS2
         GETD      LS_BI,LS_B,LS_I
         DECRA     LS_I,DESCR
LS4      LHERE
         IFDEF     LS_BI,,LS3
         PUSH      (LS_TN,LS_B)
         RCALL     LS_LS,T_LEAF,(LS_TN,LS_LS,LS_BI)
         POP       (LS_B,LS_TN)
         BRANCH    LS1
LS2      PUTDC     LS_TN,LSO_,LS_LS
         BRANCH    LS99
LS3      LHERE
         GETDC     LS_BI,LS_BI,NAME_
         GETDC     LS_BI,LS_BI,DESCR
         VEQLC     LS_BI,BL,,LS7
         VEQLC     LS_BI,S,,LS4
         VEQLC     LS_BI,I,LS8
         RCALL     LS_BI,GNVARI,LS_BI,LS4
LS8      LHERE
         VEQLC     LS_BI,R,INTR1
         REALST    REALSP,LS_BI
         SETSP     YSP,REALSP
         RCALL     YPTR,GENVAR,YSPPTR,LS4
LS7      LHERE
         VCMPIC    LS_BI,ORG_,LS_ORG,LS4,,LS4
         VCMPIC    LS_BI,SET_,LS_NULL,LS4,,LS4
*        ARRIVAL HERE MEANS THAT THE DAUGHTERS OF THE DEFERED BLOCK
*        WILL BE DAUGHTERS OF THE NODE.
         MOVD      LS_OLDP,LS_LS
         PUTDC     LS_TN,VALUE_,LS_BI
         PUSH      (LS_OLDP,LS_TN,LS_B,LS_I,LS_ORG)
         RCALL     LS_LS,LSOHN,(LS_TN)
         POP       (LS_ORG,LS_I,LS_B,LS_TN,LS_OLDP)
         PUTDC     LS_TN,VALUE_,LS_B
         MOVD      LS_P,LS_LS
LS5      LHERE
         AEQLIC    LS_P,RSIB_,0,,LS6
         GETDC     LS_P,LS_P,RSIB_
         BRANCH    LS5
LS6      LHERE
         PUTDC     LS_P,RSIB_,LS_OLDP
         BRANCH    LS1
LS99     RRTURN    LS_LS,1
LS_TN    DESCR     0,0,0
LS_LS    DESCR     0,0,0
LS_B     DESCR     0,0,0
LS_I     DESCR     0,0,0
LS_ORG   DESCR     0,0,0
LS_BI    DESCR     0,0,0
LS_NULL  DESCR     0,0,0
LS_P     DESCR     0,0,0
LS_OLDP  DESCR     0,0,0
***********************************************************************
*                                                                     *
*        MIDREG      RETURNS A SUBBLOCK EQUAL TO THE MIDREGION BETWEEN*
*        TWO SUBBLOCKS SB1 AND SB2. THEY ARE ASSUMED TO BE SEPARATED  *
*        IN THE DIRECTION DIR.  IF THE TRAILING EDGE OF SB1 FOLLOWS   *
*        THE LEADING EDGE OF SB2 THEN THE FUNCTION FAILS.             *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,MIDREG,(SB1,SB2,DIR),(FAIL,SUCC)                  *
*                                                                     *
***********************************************************************
MIDREG   PROC
         POP       (MR_SB1,MR_SB2,MR_DIR)
         GETD      TEMP31,MR_SB1,MR_DIR
         SETAV     TEMP32,TEMP31
         SUM       MR_NO,TEMP32,TEMP31
         GETD      TEMP31,MR_SB2,MR_DIR
         SUBTRT    MR_NE,TEMP31,MR_NO
         ACOMPC    MR_NE,0,,,FAIL
         SETVA     MR_NO,MR_NE
         RCALL     MR_MR,BCOPY,(MR_SB1)
         PUTD      MR_MR,MR_DIR,MR_NO
         RRTURN    MR_MR,2
MR_SB1   DESCR     0,0,0
MR_SB2   DESCR     0,0,0
MR_DIR   DESCR     0,0,0
MR_NO    DESCR     0,0,0                         NEW.OFFSET
MR_NE    DESCR     0,0,0                         NEW.EXTENT
MR_MR    DESCR     0,0,0                         VALUE
**********************************************************************
*                                                                     *
*        MINGLE  MERGES TWO EDGES TOGETHER IF THEY HAVE A COMMON NODE.*
*        IF THEY DO NOT HAVE A COMMON NODE MINGLE FAILS.              *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,MINGLE,(E1,E2),(FAIL,SUCCESS)               *
*        REGISTERS CLOBBERED:  TEMP28,TEMP29,TEMP31,TEMP32,TEMP33     *
*                                                                     *
**********************************************************************
MINGLE   PROC
         POP       (TEMP28,TEMP29)
         RELS      MI_R1,TEMP28
         NN        MI_N1,TEMP28
         RELS      MI_R2,TEMP29
         NN        MI_N2,TEMP29
         RCALL     ,FICOM,(MI_R1,MI_N1,MI_R2,MI_N2),FAIL
         GETD      MI_D1,MI_R1,TEMP31
         SETAV     MI_D1,MI_D1
         GETD      MI_D2,MI_R2,TEMP32
         SETAV     MI_D2,MI_D2
         SUBTRT    MI_D1,MI_D1,MI_D2
         ACOMPC    MI_D1,0,MI1,MI1
         MNSINT    MI_D1,MI_D1,MI62,MI62
MI62     LHERE
         SWAP      TEMP28,TEMP29
         SWAP      MI_R1,MI_R2
         SWAP      MI_N1,MI_N2
MI1      LHERE
         RCALL     TEMP33,CIR,(MI_R1,MI_N1,MI_R2,MI_N2,MI_D1)
         TRL       MI_T1,TEMP28
         TRL       MI_T2,TEMP29
         SUM       MI_T2,MI_T2,MI_D1
         SUM       MI_N1,MI_N1,MI_N2
         MAX       MI_T1,MI_T1,MI_T2
         RCALL     MI_MI,BLOCK,(MI_ED)
         PUTDC     MI_MI,TR1_,MI_T1
         PUTDC     MI_MI,NN1_,MI_N1
         PUTDC     MI_MI,RELS1_,TEMP33
         RRTURN    MI_MI,2
MI_R1    DESCR     0,0,0
MI_R2    DESCR     0,0,0
MI_D1    DESCR     0,0,0
MI_D2    DESCR     0,0,0
MI_N1    DESCR     0,0,0
MI_N2    DESCR     0,0,0
MI_T1    DESCR     0,0,0
MI_T2    DESCR     0,0,0
MI_ED    DESCR     RELS1_,0,EDGDT
MI_MI    DESCR     0,0,0
***********************************************************************
*                                                                     *
*         MORE   ASSUMES ITS ARGUMENT IS A POINTER TO A BLOCK.        *
*         IT DOUBLES ITS SIZE COPYING THE OLD CONTENTS INTO THE       *
*         INITIAL PART OF THE NEW BLOCK AND RETURNS THE NEW BLOCK     *
*         CALLING SEQUENCE:                                           *
*         RCALL  ______,MORE,(BLOCK)                                  *
*                                                                     *
***********************************************************************
MORE     PROC
         POP       MR_BLOCK
         GETSIZ    MR_SIZE1,MR_BLOCK
         MULTC     MR_SIZE2,MR_SIZE1,2
         MOVV     MR_SIZE2,MR_BLOCK
         RCALL     MR_X,BLOCK,(MR_SIZE2)
         MOVBLK    MR_X,MR_BLOCK,MR_SIZE1
         RRTURN    MR_X,1
MR_SIZE1 DESCR     0,0,0
MR_SIZE2 DESCR     0,0,0
MR_BLOCK DESCR     0,0,0
MR_X     DESCR     0,0,0
***********************************************************************
*                                                                     *
*        NRMZ_REG IS CALLED TO NORMALIZE THE REGISTRATION (I.E. PUT   *
*        IT IN A STANDARD FORMAT).  IT REPLACES THE STRINGS WITH INT- *
*        EGERS.                                                       *
*        0  =  CENTRAL REGISTRATION                                   *
*        1  =  ALLIGNED FORE (LEFT,TOP,FRONT)                         *
*        2  =  ALLIGNED AFT (RIGHT,BOTTOM,REAR)                       *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,NRMZ_REG,(REG)                                    *
*                                                                     *
***********************************************************************
NRMZ_REG PROC
         POP       ZCL
         SETAC     NR_DIR,HT_
         RCALL     ,N_REG,(NR_VF,NR_VA)
         SETAC     NR_DIR,WTH_
         RCALL     ,N_REG,(NR_HF,NR_HA)
         SETAC     NR_DIR,DTH_
         RCALL     ,N_REG,(NR_NF,NR_NA)
         BRANCH    NR99
N_REG    PROC
         POP       (NR_F,NR_A)
         GETD      NR_VAL,ZCL,NR_DIR
         VEQLC     NR_VAL,S,NR99
         AEQLC     NR_VAL,0,NR1
NR0      LHERE
         PUTD      ZCL,NR_DIR,NR_SC
         BRANCH    NR99
NR1      LOCSP     TXSP,NR_VAL         SPECIFY ...
         SETLC     TXSP,1              1ST CHAR. OF USER'S STRING
         GETSPC    NR_SP,NR_F,0        GET FORE SPECIFIER
         LEXCMP    TXSP,NR_SP,NR2,,NR2 DOES IT REPRESENT FORE?
         PUTD      ZCL,NR_DIR,NR_SF    YES, PUT IN STND FORE
         BRANCH    NR99                BRANCH TO COMMON RETURN
NR2      LHERE     ,                   NOT FORE, TRY AFT.
         GETSPC    NR_SP,NR_A,0        GET AFT SPECIFIER
         LEXCMP    TXSP,NR_SP,NR3,,NR3 DOES IT REPRESENT AFT?
         PUTD      ZCL,NR_DIR,NR_SA    YES, PUT IN STND AFT.
         BRANCH    NR99                BRANCH TO COMMON RETURN
NR3      LHERE     ,                   ERROR:  STRING NOT RECOGNIZED
         LOCSP     TXSP,NR_VAL         REOBTAIN SPECIFIER TO USER'S ...
*                                      STRING.
         DIVIDE    NR_DIR,NR_DIR,NR_DES,NR9
NR9      LHERE
         DECRA     NR_DIR,1            MAKE DIR. NO MEANINGFUL TO USER
         OUTPUT    NR_UNIT,NR_FMT1
         OUTPUT    NR_UNIT,NR_FMT2,(NR_DIR)
         INCRA     NR_DIR,1            RESTORE DIRECTION
         MULTC     NR_DIR,NR_DIR,DESCR
         FASTPR    IOKEY,NR_UNIT,NR_UNIT,TXSP,BLSP
         RCALL     ,WARNING
         BRANCH    NR0
NR99     RRTURN    ,1
NR_VF    DESCR     NR_VFS,0,0                    VERTICAL
NR_VA    DESCR     NR_VAS,0,0                    VERTICAL
NR_HF    DESCR     NR_HFS,0,0                    HORIZONTAL
NR_HA    DESCR     NR_HAS,0,0                    HORIZONTAL
NR_NF    DESCR     NR_NFS,0,0                    NORMAL
NR_NA    DESCR     NR_NAS,0,0                    NORMAL
NR_VFS   STRING    'T'
NR_VAS   STRING    'B'
NR_HFS   STRING    'L'
NR_HAS   STRING    'R'
NR_NFS   STRING    'F'
NR_NAS   STRING    'R'
NR_SC    DESCR     0,0,I                  STANDARD
NR_SF    DESCR     1,0,I                  STANDARD
NR_SA    DESCR     2,0,I                  STANDARD
NR_F     DESCR     0,0,0
NR_A     DESCR     0,0,0
NR_DIR   DESCR     0,0,0
NR_VAL   DESCR     0,0,0
NR_FMT1  FORMAT    'The following string was used to set the '
NR_FMT2  FORMAT    'registration of a BLOCK in the direction %d'
NR_UNIT  DESCR     PRUNO,0,0
NR_DES   DESCR     DESCR,0,0           CONSTANT VALUE
NR_SP    SPEC      0,0,0,0,0
***********************************************************************
*                                                                     *
*         PAR    SER    OVY     MERGE                                 *
*         CALLED COLLECTIVELY   OPS                                   *
*         ARE PRIMITIVE ROUTINES BEARING THE SAME NAMES.              *
*                                                                     *
***********************************************************************
PAR      PROC
         MOVD      TEMP1,ZEROCL
         SETVC     TEMP1,PAR_
         BRANCH    OPS1,OPS1
SER      PROC
         MOVD      TEMP1,ZEROCL
         SETVC     TEMP1,SER_
         BRANCH    OPS1,OPS1
OVY      PROC
         MOVD      TEMP1,ZEROCL
         SETVC     TEMP1,OVY_
         BRANCH    OPS1,OPS1
MERGE    PROC
         MOVD      TEMP1,ZEROCL
         SETVC     TEMP1,MERGE_
         BRANCH    OPS1,OPS1
OPS1     PROC
         MOVD      ZPTR,NULVCL
         SETAV     OP_N,INCL
OPS4     AEQLC     OP_N,0,OPS2
         BRANCH    RTZPTR
OPS2     DECRA     OP_N,1
         PUSH      (ZPTR,TEMP1,OP_N)
         RCALL     YPTR,BLOKVAL,,FAIL
         POP       (OP_N,TEMP1,ZPTR)
         RCALL     ZPTR,JOIN,(ZPTR,YPTR)
         BRANCH    OPS4
OP_N     DESCR     0,0,0
*        CONCATENATE BLOCKS
CCATB    PROC
         MOVD      TEMP1,ZEROCL
         SETVC     TEMP1,PAR_
         RCALL     XPTR,JOIN,(XPTR,YPTR)
         BRANCH    RTXPTR
***********************************************************************
*                                                                     *
*        PAR_CONG  RETURNS THE PARENTIAL CONGLOMERATE OF A TREE NODE. *
*        IT CRAWLS UP THE TREE UNTIL IT HITS A PARENT WHOSE           *
*        ORGANIZATION IS CONGLOMERATE.                                *
*        CALLING SEQUENCE:                                            *
*           RCALL   ______,PAR_CONG,(TN)                              *
*        LOCATIONS CLOBBERED:  NONE                                   *
*                                                                     *
***********************************************************************
PAR_CONG PROC
         POP       (PC_TN)
PC1      GETDC     PC_PC,PC_TN,FATHER_
         AEQLC     PC_PC,0,,FAIL
         GETDC     PC_VAL,PC_PC,VALUE_
         VCMPIC    PC_VAL,ORG_,PC_MG,,PC3,PC3
         IFPHY     PC_VAL,PC2
PC3      LHERE
         RRTURN    PC_PC,2
PC2      MOVD      PC_TN,PC_PC
         BRANCH    PC1
PC_MG    DESCR     0,0,MERGE_
PC_PC    DESCR     0,0,0
PC_TN    DESCR     0,0,0
PC_VAL   DESCR     0,0,0
***********************************************************************
*                                                                     *
*        PRE_SUF   SETS TEMP31 AND TEMP32 TO THE PREFIX AND SUFFIX    *
*        RESPECTIVELY WHERE OTR IS THE OVERALL SIZE OF THE PARENT,    *
*        INR IS THE SIZE OF THE DAUGHTER AND REG IS THE REGISTRATION. *
*        CALLING SEQUENCE:                                            *
*        RCALL     ,PRE_SUF,(OTR,INR,REG)                             *
*        LOCATIONS CLOBBERRED:   TEMP31,TEMP32,TEMP33                 *
*                                                                     *
***********************************************************************
PRE_SUF  PROC
         POP       (PS_OTR,PS_INR,PS_REG)
         SUBTRT    TEMP33,PS_OTR,PS_INR      TEMP33 IS THE DIFFERENCE
*                  IN SIZE BETWEEN THE PARENT AND THE DAUGHTER
         AEQLC     PS_REG,0,PS1
         DIVIDE    TEMP31,TEMP33,PS_TWO,FAIL
         SUBTRT    TEMP32,TEMP33,TEMP31
PS99     RRTURN    ,1
PS1      AEQLC     PS_REG,1,PS2
         MOVD      TEMP32,TEMP33
         MOVD      TEMP31,PS_ZR
         BRANCH    PS99
PS2      MOVD      TEMP32,PS_ZR
         MOVD      TEMP31,TEMP33
         BRANCH    PS99
PS_OTR   DESCR     0,0,0
PS_INR   DESCR     0,0,0
PS_REG   DESCR     0,0,0
PS_TWO   DESCR     2,0,I
PS_ZR    DESCR     0,0,I
***********************************************************************
*                                                                     *
*        PRINTB    PRINTS A BLOCK                                     *
*                                                                     *
***********************************************************************
PRINTB   PROC
         SETAV     PR_NA,INCL
         AEQLC     PR_NA,0,,ARGNER
         DECRA     PR_NA,1
         RCALL     XCL,BLOKVAL,,FAIL
         AEQLC   XCL,0,,RETNUL
         VEQLC   XCL,S,,PR6
         RCALL     XCL,FIXINL,(XCL,ZEROCL)
PR6      LHERE
         PUSH      XCL
         RCALL     PR_UF1,UNITS,(PR_NA),FAIL
         POP       XCL
         AEQLC     PR_UF1,0,,RETNUL
         GETSIZ    PR_NA,PR_UF1
         BRANCH    PR3
PR4      INCRA     PR_UF1,2*DESCR
PR3      AEQLC     PR_NA,0,,RETNUL
         DECRA   PR_NA,2*DESCR
         GETDC   PR_UNIT,PR_UF1,DESCR
         AEQLC     PR_UNIT,0,,PR4
         GETDC   PR_FLAG,PR_UF1,2*DESCR
         VEQLC   XCL,S,,PRSTR
         GETDC     TEMP2,XCL,FRAME_
         GETDC     PR_HT,TEMP2,HT_
         TRL       PR_HT,PR_HT
         GETDC     PR_DTH,TEMP2,DTH_
         TRL       PR_DTH,PR_DTH
         SETAC     PR_N,0
         SETAC     PR_I,0
         GETDC     TEMP1,XCL,ARRAY_
         AEQLC     TEMP1,0,,PRNOTH
         MOVD      PR_UF2,ZEROCL
PR1      LHERE
         INCRA     PR_I,1
         ACOMP     PR_I,PR_HT,PR99
         SETAC     PR_J,1
         INCRA     PR_N,DESCR
         GETD      YCL,TEMP1,PR_N
         LOCSP     YSP,YCL
         FASTPR    IOKEY,PR_UNIT,PR_FLAG,YSP,BLSP
         AEQLC     IOKEY,0,PRERR
PR2      LHERE
         INCRA     PR_J,1
         ACOMP     PR_J,PR_DTH,PR1
         INCRA     PR_N,DESCR
         GETD      YCL,TEMP1,PR_N
         AEQLC     PR_UF2,0,PR21
         LOCSP     YSP,YCL
         STREAM    XSP,YSP,FRWDTB,PR23,PR23
PR22     LHERE
         LOCSP     YSP,YCL
         FASTPR  IOKEY,PR_UNIT,PR_FLAG,YSP,PR_PLUS
         AEQLC     IOKEY,0,PRERR
         BRANCH    PR2
PR21     ACOMP     PR_UF2,YCL,,PR2
         BRANCH    PR22
PR23     MOVD      PR_UF2,YCL
         BRANCH    PR2
PR99     ACOMPC	   PR_FLAG,0,PR4,PR4		If ASCII CC	[PLB121]
         FASTPR    IOKEY,PR_UNIT,PR_FLAG,PR_NULL,BLSP  add NL	[PLB121]
         AEQLC     IOKEY,0,PRERR				[PLB121]
         BRANCH    PR4
PRSTR    LHERE
         LOCSP   YSP,XCL
         FASTPR  IOKEY,PR_UNIT,PR_FLAG,YSP,BLSP
         AEQLC     IOKEY,0,PRERR
         BRANCH  PR99
* here to print nothing!
PRNOTH   LHERE
PRN1     INCRA     PR_I,1
         ACOMP     PR_I,PR_HT,PR99
         FASTPR    IOKEY,PR_UNIT,PR_FLAG,PR_NULL,BLSP		[PLB121]

         AEQLC     IOKEY,0,PRERR
         BRANCH    PRN1
NEW_PAGE PROC      PRINTB
         SETAV     PR_NA,INCL
         RCALL     PR_UF1,UNITS,(PR_NA),FAIL
         AEQLC     PR_UF1,0,,RETNUL
         GETSIZ    PR_NA,PR_UF1
NP1      AEQLC     PR_NA,0,,RETNUL
         GETDC     PR_I,PR_UF1,DESCR
         AEQLC     PR_I,0,,NP2
         GETDC     PR_FLAG,PR_UF1,2*DESCR			[PLB121]
         FASTPR    IOKEY,PR_I,PR_FLAG,PR_NULL,PR_1		[PLB121]
         AEQLC     IOKEY,0,PRERR
NP2      LHERE
         DECRA     PR_NA,2*DESCR
         INCRA     PR_UF1,2*DESCR
         BRANCH    NP1
PRERR    BRANCH    COMP6					[PLB117]
PR_NA    DESCR     0,0,0
PR_UF1   DESCR     0,0,0
PR_UF2   DESCR     0,0,0
PR_I     DESCR     0,0,0
PR_J     DESCR     0,0,0
PR_N     DESCR     0,0,0
PR_DTH   DESCR     0,0,0
PR_HT    DESCR     0,0,0
PR_PUN   DESCR     PRUNO,0,0
PR_FLAG  DESCR     0,0,0
PR_UNIT  DESCR     0,0,0
PR_PLUS  STRING    '+'			Overstrike
PR_1     STRING    '1'			Form feed
PR_NULL  STRING	   ''			Null string		[PLB121]

***********************************************************************
*                                                                     *
*        P_BLOCK  RETURNS A PHYSICAL BLOCK.  IT COMBINES ITS 2ND      *
*        THROUGH 4TH ARGUMENT INTO A FRAME.                           *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,P_BLOCK,(BL,H,W,D,ARRAY)                    *
***********************************************************************
P_BLOCK  PROC
         SETVC     PB_FS,A
         RCALL     NP_FR,BLOCK,(PB_FS)
         POP       (NP_BL,PB_H,PB_W,PB_D,NP_AR)
         MOVBLK    NP_FR,PB_FR,PB_FS
         PUSH      (NP_AR,NP_FR,NP_BL)
         BRANCH    NP_BLOCK,NP_BLOCK
PB_FS    DESCR     DTH_,0,0
PB_FR    DESCR     PB_FR,0,0
PB_H     DESCR     0,0,0
PB_W     DESCR     0,0,0
PB_D     DESCR     0,0,0
***********************************************************************
*                                                                     *
*        NP_BLOCK   ALLOCATES SPACE FOR A NEW PHYSICAL BLOCK AND      *
*        PLUNKS ITS ARGUMENTS INTO THE APPROPRIATE LOCATIONS.         *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,NP_BLOCK,(BL,FRAME,ARRAY)                   *
*                                                                     *
***********************************************************************
NP_BLOCK PROC
         RCALL     NP_NP,BLOCK,(NP_DE)
         POP       (NP_BL,NP_FR,NP_AR)
         MOVBLK    NP_NP,NP_BK,NP_DE
         RRTURN    NP_NP,1
NP_DE    DESCR     ARRAY_,0,BL
NP_BK    DESCR     NP_BK,0,0
NP_ORG   DESCR     0,0,PHY_
NP_BL    DESCR     0,0,0
NP_FR    DESCR     0,0,0
NP_AR    DESCR     0,0,0
NP_NP    DESCR     0,0,0
***********************************************************************
*                                                                     *
*        REPLICATE   REPLICATES AN ARRAY A WITH FRAME F  A NUMBER OF  *
*        TIMES  N IN A DIRECTION  DIR.   THE ARRAY A IS NOT MODIFIED. *
*        BUT THE FRAME F IS.                                          *
*                                                                     *
***********************************************************************
REPL     PROC
         POP       (RE_A,RE_F,RE_DIR,RE_N)
         MOVD      RE_RE,NULVCL
         AEQLC     RE_A,0,,RE99
         ACOMPC    RE_N,1,,RES1,RESZ
         AEQLC     RE_DIR,WTH_,,REH
*
*        THIS IS COMMON CODE FOR REPLICATING IN THE VERTICAL
*        AND NORMAL DIRECTIONS
         GETDC     RE_H,RE_F,HT_
         GETDC     RE_D,RE_F,DTH_
         MULT      RE_L,RE_D,RE_H
         MULTC     RE_L,RE_L,DESCR
         MULT      RE_SIZE,RE_L,RE_N
         PUSH      (RE_A,RE_F)
        SETVC     RE_SIZE,A
         RCALL     RE_RE,BLOCK,(RE_SIZE)
         POP       (RE_F,RE_A)
         MOVD      RE_P,RE_RE
         AEQLC     RE_DIR,HT_,REN
*
*        REPLICATE IN THE VERTICAL DIRECTION
         MULT      RE_H,RE_H,RE_N
         PUTDC     RE_F,HT_,RE_H
REV1     LHERE
         AEQLC     RE_N,0,,REV2
         DECRA     RE_N,1
         MOVBLK    RE_P,RE_A,RE_L
         SUM       RE_P,RE_P,RE_L
         BRANCH    REV1
REV2     LHERE
         BRANCH    RE99
*
*        REPLICATE IN THE NORMAL DIRECTION
REN      LHERE
         MULT      RE_L,RE_D,RE_N
         PUTDC     RE_F,DTH_,RE_L
         MULTC     RE_D,RE_D,DESCR
         MOVD      RE_Q,RE_A
         MOVD      RE_I,RE_N
REN1     LHERE
         AEQLC     RE_H,0,,RE99
         DECRA     RE_H,1
REN2     LHERE
         AEQLC     RE_I,0,,REN3
         DECRA     RE_I,1
         MOVBLK    RE_P,RE_Q,RE_D
         SUM       RE_P,RE_P,RE_D
         BRANCH    REN2
REN3     SUM       RE_Q,RE_Q,RE_D
         MOVD      RE_I,RE_N
         BRANCH    REN1
*
*        REPLICATING IN THE HORIZONTAL DIRECTION
REH      LHERE
         RCALL     TEMP31,BCOPY,(RE_A)
         GETSIZ    RE_SIZE,TEMP31
         MOVD      TEMP32,TEMP31
         SUM       TEMP33,TEMP32,RE_SIZE
*
         GETDC     RE_W,RE_F,WTH_
         MULT      RE_W,RE_W,RE_N
         PUTDC     RE_F,WTH_,RE_W
*
REH1     LHERE
         INCRA     TEMP32,DESCR
         ACOMP     TEMP32,TEMP33,REH99
         GETDC     RE_P,TEMP32,0
         RCALL     RE_P,DUPE,(RE_P,RE_N)
         PUTDC     TEMP32,0,RE_P
         BRANCH    REH1
REH99    MOVD      RE_RE,TEMP31
         BRANCH    RE99
RES1     LHERE
         RCALL     RE_RE,BCOPY,(RE_A)
         BRANCH    RE99
RESZ     LHERE
         MOVD      RE_RE,NULVCL
         PUTD      RE_F,RE_DIR,RE_0
         BRANCH    RE99
RE99     RRTURN    RE_RE,1
RE_A     DESCR     0,0,0
RE_D     DESCR     0,0,0
RE_DIR   DESCR     0,0,0
RE_F     DESCR     0,0,0
RE_H     DESCR     0,0,0
RE_L     DESCR     0,0,0
RE_N     DESCR     0,0,0
RE_P     DESCR     0,0,0
RE_Q     DESCR     0,0,0
RE_RE    DESCR     0,0,0
RE_SIZE  DESCR     0,0,0
RE_W     DESCR     0,0,0
RE_I     DESCR     0,0,0
RE_0     DESCR     0,0,I
***********************************************************************
*        SLAB  RETURNS A SUBSECTION OF A BLOCK B EQUAL TO A COLLECTION*
*        OF CONTIGUOUS PLANES NORMAL TO THE DIRECTION DIR STARTING    *
*        WITH THE ITH PLANE.                                          *
*        THE LENGTH OF THE BLOCK IN THE DIR TH DIRECTION IS GIVEN     *
*        BY L.                                                        *
*        CALLING SEQUENCE (EXTERNAL):                                 *
*        SLAB(B,DIR,I,L)                                              *
*                                                                     *
***********************************************************************
SLAB     PROC
         SETAV     SL_NA,INCL
         ACOMPC    SL_NA,4,ARGNER,,ARGNER
         RCALL     ZPTR,BLOKVAL,,FAIL
         RCALL     ZPTR,FIXINL,(ZPTR,NULVCL)
         RCALL     ZPTR,BCOPY,(ZPTR)
         GETDC     TEMP2,ZPTR,FRAME_
         RCALL     TEMP2,STRIP_F,TEMP2
         PUTDC     ZPTR,FRAME_,TEMP2
         PUSH      ZPTR
         RCALL     SL_DIR,INTVAL,,FAIL
         ACOMPC  SL_DIR,0,,,LENERR
         PUSH      SL_DIR
         RCALL     SL_I,INTVAL,,FAIL
         PUSH      SL_I
         RCALL     SL_L,INTVAL,,FAIL
         ACOMPC   SL_L,0,,,LENERR
         POP       (SL_I,SL_DIR,ZPTR)
         INCRA     SL_DIR,1
         GETDC     TEMP1,ZPTR,ARRAY_
         PUTDC   ZPTR,ARRAY_,NULVCL
         GETDC     TEMP2,ZPTR,FRAME_
         GETDC     SL_H,TEMP2,HT_
         GETDC     SL_W,TEMP2,WTH_
         GETDC     SL_D,TEMP2,DTH_
*        CONSTRAIN THE SLAB TO DWELL WITHIN THE BORDERS OF THE
*                                            ORIGINAL BLOCK.
         MOVD      WPTR,ZEROCL
         MULTC     WPTR,SL_DIR,DESCR
         GETD      SL_T,TEMP2,WPTR           GET SIZE OF ORIGINAL
*                                            BLOCK IN THE DIRECTION DIR
         ACOMPC    SL_I,1,SL1,SL1                MAKE SURE START OF
         DECRA   SL_L,1
         SUM     SL_L,SL_L,SL_I
         SETAC     SL_I,1                    SLAB IS AFTER BEGINNING
*                                            OF THE BLOCK
         ACOMPC   SL_L,0,SL1
         SETAC   SL_L,0
         BRANCH  SL2
SL1      LHERE
         ACOMP     SL_I,SL_T,,SL11,SL11         MAKE SURE START OF SLAB
         SETAC   SL_L,0
         BRANCH  SL2
*                                            IS NOT AFTER THE END
SL11     LHERE
         DECRA     SL_I,1                    THIS IS MORE CONVENIENT
         SUBTRT    SL_T,SL_T,SL_I            FIND MAX. POSSIBLE SLAB
*                                            LENGTH
         ACOMP     SL_L,SL_T,,SL2,SL2        MAKE SURE SLAB LENGTH DOES
*                                            NOT EXCEED THIS LENGTH
         MOVA      SL_L,SL_T
SL2      LHERE
         PUTD      TEMP2,WPTR,SL_L           FIX FRAME TO SHOW
*                                            SIZE OF SLAB
         AEQLC     SL_L,0,,RTZPTR
         AEQLC   TEMP1,0,,RTZPTR   IF ARRAY IS BARE, SLAB WILL ALSO BE
         SELBRA    SL_DIR,(SLAB1,SLAB2,SLAB3)
*
*        THE VERTICAL
SLAB1    LHERE
         MULTC     SL_D,SL_D,DESCR
         MULT      SL_L,SL_L,SL_D
        SETVC     SL_L,A
         RCALL     TEMP3,BLOCK,(SL_L)
         MULT      SL_I,SL_I,SL_D
         SUM       TEMP1,TEMP1,SL_I
         MOVBLK    TEMP3,TEMP1,SL_L
         PUTDC     ZPTR,ARRAY_,TEMP3
         BRANCH    RTZPTR
*
*        THE HORIZONTAL
SLAB2    LHERE
         RCALL     TEMP1,BCOPY,(TEMP1)
         GETSIZ    SL_T,TEMP1
         SETAC     SL_H,0
SLAB21   INCRA     SL_H,DESCR
         ACOMP     SL_H,SL_T,SLAB22
         GETD      YPTR,TEMP1,SL_H
         RCALL     XPTR,CONVAR,(SL_L)
         LOCSP     YSP,YPTR
         LOCSP     VSP,XPTR
         SETLC     VSP,0
*        GET SPECIFIER OF SUBSTRING
         PUTLG     XSP,SL_I
         REMSP     YSP,YSP,XSP               OFFSET HS BEEN BUMPED BY I
         PUTLG     YSP,SL_L
         APDSP     VSP,YSP
         RCALL     XPTR,GNVARS,(SL_L)
         PUTD      TEMP1,SL_H,XPTR
         BRANCH    SLAB21
SLAB22   LHERE
         PUTDC     ZPTR,ARRAY_,TEMP1
         BRANCH    RTZPTR
*
*        THE NORMAL
SLAB3    LHERE
         MULTC     SL_D,SL_D,DESCR
         MULTC     SL_L,SL_L,DESCR
         MULT      SL_T,SL_H,SL_L
        SETVC     SL_T,A
         RCALL     TEMP3,BLOCK,(SL_T)
         MOVD      TEMP11,TEMP1
         MOVD      TEMP31,TEMP3
         MULTC     SL_I,SL_I,DESCR
         SUM       TEMP11,TEMP11,SL_I
         SETAC     SL_T,0
SLAB32   INCRA     SL_T,1
         ACOMP     SL_T,SL_H,SLAB31
         MOVBLK    TEMP31,TEMP11,SL_L
         SUM       TEMP31,TEMP31,SL_L
         SUM       TEMP11,TEMP11,SL_D
         BRANCH    SLAB32
SLAB31   LHERE
         PUTDC     ZPTR,ARRAY_,TEMP3
         BRANCH    RTZPTR
SL_H     DESCR     0,0,0
SL_D     DESCR     0,0,0
SL_W     DESCR     0,0,0
SL_L     DESCR     0,0,0
SL_I     DESCR     0,0,0
SL_T     DESCR     0,0,0
SL_DIR   DESCR     0,0,0
SL_NA    DESCR     0,0,0
***********************************************************************
*                                                                     *
*        SUBBLOCK  RETURNS A SUBBLOCK WHICH DESCRIBES WHERE WITHIN    *
*        THE GLOBAL FRAME GF THE LOCAL FRAME LF IS SITUATED.  IT IS   *
*        ASSUMED THAT LF AND GF HAVE AT LEAST ONE NODE IN COMMON.  IF *
*        THIS IS NOT THE CASE THEN SUBBLOCK FAILS.                    *
*        CALLING SEQUENCE:                                            *
*        RCALL     ______,SUBBLOCK,(GF,LF),(FAIL,SUCCESS)             *
*                                                                     *
***********************************************************************
SUBBLOCK PROC
         RCALL     SB_SB,BLOCK,(SB_DSB)
         POP       (SB_GF,SB_LF)
         SETAC     SB_DIR,0
SB1      INCRA     SB_DIR,DESCR
         ACOMPC    SB_DIR,FRSIZE_,SB99
         GETD      SB_GE,SB_GF,SB_DIR
         GETD      SB_LE,SB_LF,SB_DIR
         RELS      SB_GR,SB_GE
         RELS      SB_LR,SB_LE
         NN        SB_GN,SB_GE
         NN        SB_LN,SB_LE
         RCALL     ,FICOM,(SB_GR,SB_GN,SB_LR,SB_LN),FAIL
         GETD      TEMP33,SB_GR,TEMP31
         GETD      TEMP34,SB_LR,TEMP32
         SETAV     TEMP33,TEMP33
         SETAV     TEMP34,TEMP34
         SUBTRT    TEMP35,TEMP33,TEMP34
         TRL       TEMP36,SB_LE
         SETVA     TEMP35,TEMP36
         PUTD      SB_SB,SB_DIR,TEMP35
         BRANCH    SB1
SB99     RRTURN    SB_SB,2
SB_DSB   DESCR     FRSIZE_,0,SBDT
SB_GF    DESCR     0,0,0
SB_LF    DESCR     0,0,0
SB_DIR   DESCR     0,0,0
SB_GE    DESCR     0,0,0
SB_LE    DESCR     0,0,0
SB_GR    DESCR     0,0,0
SB_LR    DESCR     0,0,0
SB_GN    DESCR     0,0,0
SB_LN    DESCR     0,0,0
SB_SB    DESCR     0,0,0
***********************************************************************
*                                                                     *
*        STRIP_F    STRIP_F  IS USED TO STRIP A FRAME OF ALL          *
*        NODE INFORMATION.IT DOES NOT ALTER THE FRAME WHICH IS        *
*        GIVEN AS ARGUMENT                                            *
*                                                                     *
***********************************************************************
STRIP_F  PROC
         POP       SF_F
         RCALL     SF_F,BCOPY,(SF_F)
         SETAC     SF_DIR,HT_
SF1      GETD      SF_E,SF_F,SF_DIR
         TRL       SF_E,SF_E
         PUTD      SF_F,SF_DIR,SF_E
         INCRA     SF_DIR,DESCR
         ACOMPC    SF_DIR,DTH_,,SF1,SF1
         RRTURN    SF_F,1
SF_DIR   DESCR     0,0,0
SF_E     DESCR     0,0,0
SF_F     DESCR     0,0,0
***********************************************************************
*                                                                     *
*        T_LEAF  BUILDS A LEAF OF THE GROWING TREE.  A LEAF IS        *
*        DEFINED AS THE LONGEST SEQUENCE OF NODES                     *
*        WITHOUT GOING INTO MULTIBLE DAUGHTERS                        *
*        CALLING SEQUENCE:                                            *
*                  RCALL    ______,T_LEAF,(F,RS,V)                    *
*        LOCATIONS CLOBBERED:  NONE                                   *
*                                                                     *
***********************************************************************
T_LEAF   PROC
         RCALL     TL_TL,BLOCK,(TL_SIZE)
         POP       (TL_F,TL_RS,TL_V)
         PUTDC     TL_TL,FATHER_,TL_F
         PUTDC     TL_TL,RSIB_,TL_RS
TLF0     PUTDC     TL_TL,VALUE_,TL_V
         VEQLC     TL_V,S,,TLF99
         GETDC     TL_N,TL_V,ORG_
         SETAV     TL_N,TL_N
         SELBRA    TL_N,(TLF1,TLF2,TLF3,TLF4,TLF5,TLF6,TLF7,TLF8,TLF9)
*
*        CONTIGUOUS ORGANIZATIONS
*
TLF1     LHERE
TLF2     LHERE
TLF3     LHERE
         GETDC     TL_REG,TL_V,REG_
         AEQLC     TL_REG,0,TLF11
         PUTDC     TL_TL,TNREG_,CTR_REG
         BRANCH    TLF99
TLF11    PUSH      TL_TL
         RCALL     TL_REG,BCOPY,(TL_REG)
         POP       TL_TL
         RCALL     ,NRMZ_REG,(TL_REG)
         PUTDC     TL_TL,TNREG_,TL_REG
         BRANCH    TLF99
*        MERGE ORGANIZATION
TLF4     BRANCH    TLF99
*        ITERATED ORGANIZATION
TLF5     LHERE
         GETDC     TL_V,TL_V,ELEMENT_
         PUSH      TL_TL
         RCALL     TL_TN2,T_LEAF,(TL_TL,NULVCL,TL_V)
         POP       TL_TL
         PUTDC     TL_TL,LSO_,TL_TN2
         GETDC     TL_V,TL_TN2,VALUE_
         IFREP     TL_V,TLF99
         GETDC     TL_TEMP,TL_TL,VALUE_
         PUTDC     TL_TN2,VALUE_,TL_TEMP
         PUTDC     TL_TL,VALUE_,TL_V
         BRANCH    TLF99
*        REPLICATED AND NODE ORGANIZATION
TLF6     LHERE
TLF7     LHERE
         GETDC     TL_V,TL_V,ELEMENT_
         PUSH      TL_TL
         RCALL     TL_TN2,T_LEAF,(TL_TL,NULVCL,TL_V)
         POP       TL_TL
         PUTDC     TL_TL,LSO_,TL_TN2
         BRANCH    TLF99
*        DEFERED ORGANIZATION
TLF8     LHERE
         GETDC     TL_V,TL_V,NAME_
         GETDC     TL_V,TL_V,DESCR
         BRANCH    TLF0
*        PHYSICAL ORGANIZATION
TLF9     BRANCH    TLF99
TLF99    RRTURN    TL_TL,1
CTR_REG  DESCR     TL_STR,0,A
TL_STR   DESCR     TL_STR,0,3*DESCR
         DESCR     0,0,0
         DESCR     0,0,0
         DESCR     0,0,0
TL_F     DESCR     0,0,0
TL_RS    DESCR     0,0,0
TL_V     DESCR     0,0,0
TL_TL    DESCR     0,0,0
TL_N     DESCR     0,0,0
TL_REG   DESCR     0,0,0
TL_TN2   DESCR     0,0,0
TL_SIZE  DESCR     TNREG_,0,TNDT
TL_TEMP  DESCR     0,0,0
***********************************************************************
*                                                                     *
*        UNI-DAUGHTER BLOCKS :                                        *
*        IT   REP   NODE   DEF                                        *
*                                                                     *
***********************************************************************
*
IT       PROC
         MOVD      UD_TP,UD_IT
         BRANCH    UDCOM,UDCOM
*
REP      PROC
         MOVD      UD_TP,UD_REP
         BRANCH    UDCOM,UDCOM
*
NODE     PROC
         INCRA     UD_ID,1
         MOVD      UD_TP,UD_ID
         BRANCH    UDCOM,UDCOM
*
UDCOM    PROC
         PUSH      UD_TP
         RCALL     TEMP1,BLOKVAL,,FAIL
         VEQLC   TEMP1,S,UDCOM1
         RCALL   TEMP1,FIXINL,(TEMP1,NULVCL)
UDCOM1   LHERE
         POP       UD_TP
         RCALL     XPTR,BLOCK,(UD_SIZE)
         PUTDC     XPTR,ELEMENT_,TEMP1
         PUTDC     XPTR,ORG_,UD_TP
         BRANCH    RTXPTR
*
DEF      PROC
         RCALL     TEMP1,IND,,FAIL
         RCALL     XPTR,BLOCK,(UD_SIZE)
         PUTDC     XPTR,ORG_,UD_DFT
         PUTDC     XPTR,NAME_,TEMP1
         BRANCH    RTXPTR
UD_DFT   DESCR     0,0,DEF_
UD_ID    DESCR     0,0,NODE_
UD_TP    DESCR     0,0,0
UD_SIZE  DESCR     ELEMENT_,0,BL
UD_IT    DESCR     0,0,IT_
UD_REP   DESCR     0,0,REP_
*
UNITS    PROC
         MOVD    UN_I,UN_0             DEFAULT ARG IF NO ARGS
         MOVD    UN_UN,UN_UN1          INITIALIZE LIST CONTAINING ...
         ZERBLK  UN_UN3,UN_UN4         RESULT TO ZERO
         POP       UN_N
         AEQLC     UN_N,0,,UNITS2
UNITS1   LHERE
         AEQLC     UN_N,0,,UN99
         DECRA     UN_N,1
         PUSH    (UN_UN,UN_N)
         RCALL     UN_I,INTVAL,,FAIL
         POP     (UN_N,UN_UN)
*UNITS3   LHERE
         ACOMPC    UN_I,0,,,UNITS1
UNITS2   LHERE
         AEQLC     TEMP48,0,,UNNATL
         LOCAPT    XCL,TEMP48,UN_I,UNNATL
         GETDC     YCL,XCL,2*DESCR
         AEQLC   UN_I,0,UNITS5         IF ZERO ...
         SETAC   UN_I,PRUNO            SET UNIT TO DEFAULT
UNITS5   LHERE
         RCALL     UN_UN,AUGATL,(UN_UN,UN_I,YCL)
         BRANCH    UNITS1
UNNATL   LHERE
*        NOT ON THE ATTRIBUTE LIST
         MOVD    YPTR,ZEROCL           DEFAULT CARRIAGE CONTROL IS NO
         AEQLC   UN_I,0,UNITS4         IF UNIT IS NONZERO
         SETAC   YPTR,1                IS YES OTHERWISE
         SETAC   UN_I,PRUNO         ALSO SET PRINTER UNIT NO.
UNITS4   LHERE
         RCALL     UN_UN,AUGATL,(UN_UN,UN_I,YPTR)
         BRANCH    UNITS1
UN99     RRTURN    UN_UN,2
UN_STD   DESCR     PRUNO,0,I
UN_DFP   DESCR     UN_DFT,0,0
UN_DFT   DESCR     UN_DFT,0,2*DESCR
         DESCR     PRUNO,0,I
         DESCR     1,0,0
UN_UN    DESCR     0,0,0
UN_N     DESCR     0,0,0
UN_I     DESCR     0,0,0
UN_0     DESCR     0,0,I
UN_UN4   DESCR     3*DESCR,0,0
UN_UN3   DESCR     UN_UN2+DESCR,0,0
UN_UN1   DESCR     UN_UN2,0,0
UN_UN2   DESCR     UN_UN2,0,4*DESCR
         DESCR     0,0,0
         DESCR     0,0,0
         DESCR     0,0,0
         DESCR     0,0,0
*
WARNING  PROC
         INCRA     WA_N,1
         OUTPUT    WA_DIAG,WA_FMT,(FILENM,LNNOCL,WA_N,STNOCL)	[PLB119]
         ACOMPC    WA_N,MAXW,WA1
         BRANCH    RTN1
WA_FMT   FORMAT    '%v:%d: BLOCKS warning #%d in statement %d\n' [PLB119]
WA1      LHERE
         SETAC     ERRTYP,ERRNO+2
         BRANCH    FTLEND
WA_N     DESCR     0,0,0
WA_DIAG  DESCR     DIAGUN,0,0
.FI
*---------------------------------------------------------------------*
       TITLE   'Common Code'
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
*_
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    ACOMPC  ERRLCL,0,,END0,END0 Check &ERRLIMIT		[PLB98][PLB110]
       DECRA   ERRLCL,1		   Decrement &ERRLIMIT		[PLB98]
       SETAC   ERRTYP,0		   Clear &ERRTYPE		[PLB98]
       SETAC   ERRTXT,0		   Clear &ERRTEXT		[PLB98]
       MOVD    FRTNCL,OCICL	   Crock error return		[PLB98]
       DECRA   FRTNCL,DESCR	   Back up to restart on return	[PLB98]
       MOVD    LSTNCL,STNOCL	   Crock &LASTNO		[PLB98]
       MOVA    LSLNCL,LNNOCL	   Crock &LASTLINE		[PLB98]
       MOVA    LSFLNM,FILENM	   Crock &LASTFILE		[PLB98]
       RCALL   ,XITHND,,(,,RTNUL3) Call exit handler, if any	[PLB98]
END0   XCALLC  io_flushall,(0)	   Empty output buffers		[PLB53][PLB110]
       AEQLC   BANRCL,0,,FTLEN2	   Skip message if banner (stats?) off [PLB12]
       OUTPUT  PUNCH,NRMEND,(LVLCL)				[PLB5]
*				   End procedure
       OUTPUT  PUNCH,LASTSF,(FILENM,LNNOCL,STNOCL)		[PLB5][PLB38]
*				   Print status
       BRANCH  FTLEN2		   Join termination procedure
*_
FTLEND XCALLC  io_flushall,(0)	   Empty output buffers		[PLB53]
       OUTPUT  PUNCH,FTLCF,(FILENM,LNNOCL,ERRTYP,STNOCL,LVLCL)	[PLB5][PLB38]
       SETAC   RETCOD,1		   set exit code (use an EQU? ERRTYP?) [PLB13]
       AEQLC   INICOM,0,FTLEN3	   BE SURE OF INITIALIZATION	E3.10.6
       OUTPUT  PUNCH,ALOCFL	   WARN USER			[PLB5] E3.10.6
       BRANCH  ENDALL		   GET OUT			E3.10.6
*_								E3.10.6
FTLEN3 MULTC   YCL,ERRTYP,DESCR					E3.10.6
       GETD    YCL,MSGNO,YCL	   Get message pointer
       GETSPC  TSP,YCL,0	   Get message specifier
       STPRNT  IOKEY,ERRBLK,TSP	   Print error message		[PLB12]
FTLEN2 ISTACK  ,		   Reset system stack
       AEQLC   COMPCL,0,,FTLEN4	   Was compiler done?		[PLB70]
       MSTIME  ETMCL		   Time out compiler
       SBREAL  TIMECL,ETMCL,TIMECL Compute time in compiler	[PLB71]
       SETAC   ETMCL,0		   Set interpreter time to 0
       BRANCH  FTLEN1		   Join end game
*_
FTLEN4 MSTIME  XCL		   Time out interpreter
       SBREAL  ETMCL,XCL,ETMCL	   Compute time in interpreter	[PLB71]
FTLEN1 AEQLC   DMPCL,0,,END1	   Check &DUMP
       AEQLC   NODPCL,0,DMPNO	   Check storage condition
       ORDVST  ,		   Order string structures
       OUTPUT  OUTPUT,STDMP	   Print dump title
       OUTPUT  OUTPUT,NVARF	   Print subtitle
       RCALL   ,DUMP,,(INTR10,INTR10,DMPK)
*				   Dump natural variables
*_
DMPNO  OUTPUT  OUTPUT,INCGCF	   Print disclaimer
       OUTPUT  OUTPUT,NODMPF	   Print reason
       BRANCH  END1		   Join end game
*_
DMPK   RCALL   ,DMK		   Dump keywords
END1   AEQLC   STATCL,0,,ENDALL	   Skip stats if suppressed	[PLB12]
       OUTPUT  PUNCH,STATHD	   Print statistics title	[PLB5]
       OUTPUT  PUNCH,CMTIME,(TIMECL)				[PLB5]
*				   Print compilation time
       OUTPUT  PUNCH,INTIME,(ETMCL)				[PLB5]
*				   Print interpretation time
       OUTPUT  PUNCH,EXNO,(EXN2CL,FALCL)			[PLB5]
*				   Print execution stats
       OUTPUT  PUNCH,ARTHNO,(ARTHCL)				[PLB5]
*				   Print arithmetic stats
       OUTPUT  PUNCH,SCANNO,(SCNCL)				[PLB5]
*				   Print scanner stats
       OUTPUT  PUNCH,STGENO,(GCNO)				[PLB5]
*				   Print regeneration stats
       OUTPUT  PUNCH,STGETM,(GCTTTL)				[PLB92]
*				   Print regeneration time
       OUTPUT  PUNCH,READNO,(RSTAT)				[PLB5]
*				   Print read stats
       OUTPUT  PUNCH,WRITNO,(WSTAT)				[PLB5]
*				   Print write stats
       AEQLC   EXN2CL,0,END2	   Check for no interpretation
       INTRL   FCL,ZEROCL
       BRANCH  AVTIME		   Join end game
*_
END2   INTRL   EXN2CL,EXN2CL	   Convert execution total to REAL
       DVREAL  FCL,ETMCL,EXN2CL	   Compute average time		[PLB71]
       MPREAL  FCL,FCL,R1MCL	   Convert to nanoseconds	[PLB71][PLB107]
AVTIME OUTPUT  PUNCH,TIMEPS,(FCL)  Print average time		[PLB5]
       RCOMP   ETMCL,RZERCL,,ENDALL  Avoid divide by zero	[PLB104]
       DVREAL  FCL,EXN2CL,ETMCL,ENDALL  Compute KStatements/s [PLB103][PLB104]
       OUTPUT  PUNCH,KSTSF,(FCL)				[PLB103]
ENDALL ENDEX   ABNDCL						E3.2.2
*_
SYSCUT XCALLC  io_flushall,(0)	   Empty output buffers		[PLB53]
       OUTPUT  PUNCH,SYSCMT,(FILENM,LNNOCL,SIGNCL,STNOCL,LVLCL)	[PLB5][PLB38]
*								[PLB47]
*				   System cut exit
       AEQLC   CUTNO,0,ENDALL					E3.2.2
       SETAC   CUTNO,1						E3.2.2
       SETAC   RETCOD,1		   set exit code (use an EQU???) [PLB13]
       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
*_
COMP1  SETAC   ERRTYP,32	   Missing END statement	[PLB38]
       BRANCH  FTLTST						[PLB38]
*_
INTR10 LHERE   ,
INTR13 LHERE   ,
COMP3  SETAC   ERRTYP,17	   Program error
       BRANCH  FTLEND
*_
COMP5  SETAC   ERRTYP,11	   Reading error
       BRANCH  FTLTST
*_
COMP6  SETAC   ERRTYP,33	   Writing 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
       INCRA   OCICL,DESCR	   Increment offset		[PLB38]
       GETD    LNNOCL,OCBSCL,OCICL Get line number		[PLB38]
       INCRA   OCICL,DESCR	   Increment offset		[PLB38]
       GETD    FILENM,OCBSCL,OCICL Get file name		[PLB38]
       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
*_
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
*_
USRINT SETAC   ERRTYP,34	   User Interrupt (SIGINT)	[PLB109]
       SETAC   UINTCL,0		   Clear condition		[PLB109]
       BRANCH  FTLTST						[PLB109]
*_
CNTERR SETAC   ERRTYP,35	   Not in a SETEXIT handler	[PLB97]
       BRANCH  FTLEND						[PLB97]
*_
SCERST SETAC   SCERCL,1		   Note failure during pattern matching
       BRANCH  FTERST						[PLB97]
*_
FTLTST SETAC   SCERCL,2		   Note failure out of pattern matching
FTERST ACOMPC  ERRLCL,0,,FTLEND,FTLEND
*				   Check &ERRLIMIT
       DECRA   ERRLCL,1		   Decrement &ERRLIMIT
       MULTC   YCL,ERRTYP,DESCR					[PLB38]
       GETD    YCL,MSGNO,YCL	   Get message pointer		[PLB38]
       GETSPC  TSP,YCL,0	   Get message specifier	[PLB38]
       RCALL   ERRTXT,GENVAR,TSPPTR				[PLB38]
*				   Set &ERRTEXT to natural var	[PLB38]
       ACOMPC  TRAPCL,0,,FTERBR,FTERBR				[PLB68]
*				   Check &TRACE
       LOCAPT  ATPTR,TKEYL,ERRTKY,FTERBR
*				   Look for KEYWORD trace
       PUSH    SCERCL						E3.1.3
       RCALL   ,TRPHND,ATPTR					E3.3.1
*				   Perform trace
       POP     SCERCL						E3.1.3
FTERBR RCALL   ,XITHND		   Call SETEXIT handler, if any	[PLB97]
       SELBRA  SCERCL,(FAIL,FAIL,RTNUL3)			[PLB65]
       XECODE							[PLB82]
*_
*---------------------------------------------------------------------*
       TITLE   'Data'
DTLIST DESCR   DTLIST,TTL+MARK,DTLEND-DTLIST-DESCR
       DESCR   0,0,S
       DESCR   VARSP,0,0	   STRING
       DESCR   0,0,I
       DESCR   INTGSP,0,0	   INTEGER
       DESCR   0,0,P
       DESCR   PATSP,0,0	   PATTERN
       DESCR   0,0,A
       DESCR   ARRSP,0,0	   ARRAY
       DESCR   0,0,R
       DESCR   RLSP,0,0		   REAL
       DESCR   0,0,C
       DESCR   CODESP,0,0	   CODE
       DESCR   0,0,N
       DESCR   NAMESP,0,0	   NAME
       DESCR   0,0,K
       DESCR   NAMESP,0,0	   NAME (for keyword)
       DESCR   0,0,E
       DESCR   EXPSP,0,0	   EXPRESSION
       DESCR   0,0,T
       DESCR   ASSCSP,0,0	   TABLE
.IF BLOCKS
       DESCR   0,0,BL
       DESCR   BLOKSP,0,0	   BLOCK
.FI
DTLEND LHERE   ,
*
* [PLB92] NOTE! In reverse alphabetical order!
KNLIST DESCR   KNLIST,TTL+MARK,KNEND-KNLIST-DESCR
TRIMCL DESCR   0,0,I		   &TRIM
       DESCR   TRMSP,0,0
TRAPCL DESCR   0,0,I		   &TRACE
       DESCR   TRCESP,0,0
EXLMCL DESCR   -1,0,I		   &STLIMIT			[PLB33]
       DESCR   STLMSP,0,0
OUTSW  DESCR   1,0,I		   &OUTPUT
       DESCR   OUTSP,0,0
MLENCL DESCR   SIZLIM,0,I	   &MAXLNGTH			[PLB81]
       DESCR   MAXLSP,0,0
INSW   DESCR   1,0,I		   &INPUT
       DESCR   INSP,0,0
GCTRCL DESCR   0,0,I		   &GTRACE			[PLB92]
       DESCR   GTRCSP,0,0					[PLB92]
FULLCL DESCR   0,0,I		   &FULLSCAN
       DESCR   FULLSP,0,0
TRACL  DESCR   0,0,I		   &FTRACE
       DESCR   FTRCSP,0,0
.IF BLOCKS
BKGNCL DESCR   0,0,0		   &FILL			[BLOCKS]
       DESCR   BKGNSP,0,0
.FI
ERRLCL DESCR   0,0,I		   &ERRLIMIT
       DESCR   ERRLSP,0,0
DMPCL  DESCR   0,0,I		   &DUMP
       DESCR   DUMPSP,0,0
RETCOD DESCR   0,0,I		   &CODE
       DESCR   CODESP,0,0
CASECL DESCR   1,0,I		   &CASE (folding)		[PLB15][PLB69]
       DESCR   CASESP,0,0					[PLB15][PLB69]
ANCCL  DESCR   0,0,I		   &ANCHOR
       DESCR   ANCHSP,0,0
ABNDCL DESCR   0,0,I		   &ABEND
       DESCR   ABNDSP,0,0
KNEND  LHERE   ,
*
KVLIST DESCR   KVLIST,TTL+MARK,KVEND-KVLIST-DESCR
ERRTYP DESCR   0,0,I		   &ERRTYPE
ERRTKY DESCR   ERRTSP,0,0
ERRTXT DESCR   0,0,S		   &ERRTEXT			[PLB38]
ETXTKY DESCR   ERTXSP,0,0					[PLB38]
ARBPAT DESCR   ARBPT,0,P	   &ARB
ARBKY  DESCR   ARBSP,0,0
BALPAT DESCR   BALPT,0,P	   &BAL
BALKY  DESCR   BALSP,0,0
FNCPAT DESCR   FNCEPT,0,P	   &FENCE
FNCEKY DESCR   FNCESP,0,0
ABOPAT DESCR   ABORPT,0,P	   &ABORT
ABRTKY DESCR   ABORSP,0,0
FALPAT DESCR   FAILPT,0,P	   &FAIL
FAILKY DESCR   FAILSP,0,0
FILENM DESCR   0,0,S		   &FILE			[PLB38]
       DESCR   FILESP,0,0					[PLB38]
LNNOCL DESCR   0,0,I		   &LINE			[PLB38]
       DESCR   LINESP,0,0					[PLB38]
LSFLNM DESCR   0,0,S		   &LASTFILE			[PLB38]
       DESCR   LSFNSP,0,0					[PLB38]
LSLNCL DESCR   0,0,I		   &LASTLINE			[PLB38]
       DESCR   LSLNSP,0,0					[PLB38]
REMPAT DESCR   REMPT,0,P	   &REM
REMKY  DESCR   REMSP,0,0
SUCPAT DESCR   SUCCPT,0,P	   &SUCCEED
SUCCKY DESCR   SUCCSP,0,0
FALCL  DESCR   0,0,I		   &STFCOUNT
FALKY  DESCR   STFCSP,0,0
LSTNCL DESCR   0,0,I		   &LASTNO
       DESCR   LSTNSP,0,0
RETPCL DESCR   0,0,S		   &RTNTYPE
       DESCR   RTYPSP,0,0
STNOCL DESCR   0,0,I		   &STNO
STNOKY DESCR   STNOSP,0,0					[PLB113]
ALPHVL DESCR   0,0,0		   &ALPHABET
       DESCR   ALNMSP,0,0
EXNOCL DESCR   0,0,I		   &STCOUNT
STCTKY DESCR   STCTSP,0,0
LVLCL  DESCR   0,0,I		   &FNCLEVEL
FNCLKY DESCR   FNCLSP,0,0
LCASVL DESCR   0,0,0		   &LCASE			[PLB18]
       DESCR   LCNMSP,0,0					[PLB18]
UCASVL DESCR   0,0,0		   &UCASE			[PLB18]
       DESCR   UCNMSP,0,0					[PLB18]
PARMVL DESCR   0,0,S		   &PARM			[PLB39]
       DESCR   PARMSP,0,0					[PLB39]
DIGSVL DESCR   0,0,0		   &DIGITS			[PLB105]
       DESCR   DGNMSP,0,0					[PLB105]
       REAL    3.1415926535897932384626433 &PI			[PLB106]
       DESCR   PISP,0,0		   				[PLB106]
EXN2CL DESCR   0,0,I		   Stats stmt count &STEXEC	[PLB38][PLB107]
       DESCR   STXTSP,0,0	   	      	    		[PLB107]
GCTTTL REAL    0.0		   GC total time &GCTIME	[PLB92][PLB107]
       DESCR   GCTMSP,0,0					[PLB107]
       DESCR   SMAXINT,0,I	   &MAXINT			[PLB108][PLB116]
       DESCR   MAXISP,0,0	   				[PLB108]
CSTNCL DESCR   0,0,I		   Compiler statement number	[PLB123]
       DESCR   CNOSP,0,0	   &COMPNO  	      		[PLB123]
KVEND  LHERE   ,
*
INLIST DESCR   INLIST,TTL+MARK,4*DESCR				[PLB36]
       DESCR   INPUT-DESCR,0,0	   INPUT block
       DESCR   INSP,0,0
       DESCR   TERMIN-DESCR,0,0	   TERMINAL input block		[PLB36]
       DESCR   TERMSP,0,0
OTLIST DESCR   OTLIST,TTL+MARK,4*DESCR
       DESCR   OUTPUT-DESCR,0,0	   OUTPUT block
       DESCR   OUTSP,0,0
       DESCR   PUNCH-DESCR,0,0	   PUNCH block
       DESCR   TERMSP,0,0					[PLB36]
OTSATL DESCR   OTSATL,TTL+MARK,4*DESCR
OUTPUT DESCR   UNITO,0,I	   OUTPUT unit
       DESCR   OUTPSP,0,0	   OUTPUT format
PUNCH  DESCR   UNITP,0,I	   PUNCH unit
PCHFST DESCR   CRDFSP,0,0	   PUNCH format
INSATL DESCR   INSATL,TTL+MARK,2*DESCR
INPUT  DESCR   UNITI,0,I	   INPUT unit
DFLSIZ DESCR   1024,0,I		   INPUT length			[PLB21]
TERMIN DESCR   UNITT,0,I	   TERMINAL input unit		[PLB36]
       DESCR   1024,0,I		   TERMINAL input length	[PLB36]
*
TRLIST DESCR   TRLIST,TTL+MARK,20*DESCR
       DESCR   TVALL,0,0	   VALUE trace
VALTRS DESCR   VALSP,0,0
       DESCR   TLABL,0,0	   LABEL trace
       DESCR   TRLASP,0,0
TFNCLP DESCR   TFENTL,0,0	   CALL trace
       DESCR   TRFRSP,0,0
TFNRLP DESCR   TFEXTL,0,0	   RETURN trace
       DESCR   RETSP,0,0
       DESCR   TKEYL,0,0	   KEYWORD trace
       DESCR   TRKYSP,0,0
* [PLB115] single letters ala SPITBOL
       DESCR   TVALL,0,0	   VALUE trace
       DESCR   VEESP,0,0	   'V'
       DESCR   TLABL,0,0	   LABEL trace
       DESCR   LSP,0,0		   'L'
       DESCR   TFENTL,0,0	   CALL trace
       DESCR   CSP,0,0		   'C'
       DESCR   TFEXTL,0,0	   RETURN trace
       DESCR   RSP,0,0		   'R'
       DESCR   TKEYL,0,0	   KEYWORD trace
       DESCR   KSP,0,0		   'K'
*
TRCBLK DESCR   TRCBLK,TTL+MARK,5*DESCR				V3.7
       DESCR   0,FNC,2		   TRACE FUNCTION DESCRIPTOR	V3.7
LIT1CL DESCR   LITFN,FNC,1	   LITERAL FUNCTION DESCRIPTOR	E3.7.1
       DESCR   0,0,0		   VARIABLE TO BE TRACED	V3.7
       DESCR   LITFN,FNC,1	   LITERAL FUNCTION DESCRIPTOR	E3.7.1
       DESCR   0,0,0		   TAG SUPPLIED FOR TRACE	V3.7
*
ATRHD  DESCR   ATPRCL-DESCR,0,0	   Array header converting from TABLE
ATPRCL DESCR   0,0,0		   Prototype
       DESCR   2,0,0		   Dimensionality
       DESCR   1,0,2		   1:2 second dimension
ATEXCL DESCR   1,0,0		   1:n first dimension
*
*      Data type pairs
*
ATDTP  DESCR   A,0,T		   ARRAY-TABLE
IIDTP  DESCR   I,0,I		   INTEGER-INTEGER
IPDTP  DESCR   I,0,P		   INTEGER-PATTERN
IRDTP  DESCR   I,0,R		   INTEGER-REAL
IVDTP  DESCR   I,0,S		   INTEGER-STRING
PIDTP  DESCR   P,0,I		   PATTERN-INTEGER
PPDTP  DESCR   P,0,P		   PATTERN-PATTERN
PVDTP  DESCR   P,0,S		   PATTERN-STRING
RIDTP  DESCR   R,0,I		   REAL-INTEGER
RPDTP  DESCR   R,0,P		   REAL-PATTERN
RRDTP  DESCR   R,0,R		   REAL-REAL
RVDTP  DESCR   R,0,S		   REAL-STRING
TADTP  DESCR   T,0,A		   TABLE-ARRAY
VCDTP  DESCR   S,0,C		   STRING-CODE
VEDTP  DESCR   S,0,E		   STRING-EXPRESSION
VIDTP  DESCR   S,0,I		   STRING-INTEGER
VPDTP  DESCR   S,0,P		   STRING-PATTERN
VRDTP  DESCR   S,0,R		   STRING-REAL
VVDTP  DESCR   S,0,S		   STRING-STRING
*
ARTHCL DESCR   0,0,0		   Number of arithmetic operations
RSTAT  DESCR   0,0,0		   Number of reads
SCNCL  DESCR   0,0,0		   Number of scanner entrances
WSTAT  DESCR   0,0,0		   Number of writes
TIMECL DESCR   0,0,0		   Millisecond time
*
*      SWITCHES
*
ALCL   DESCR   0,0,0		   Entry point switch for ARG(F,N)
ARRMRK DESCR   0,0,0		   Prototype end switch for ARRAY(P,V)
BANRCL DESCR   1,0,0		   Display startup banner	[PLB12]
COMPCL DESCR   1,0,0		   Compiling; list syntax errors [PLB49]
CUTNO  DESCR   0,0,0						E3.2.2
CNSLCL DESCR   0,0,0		   Label redefinition switch
DATACL DESCR   0,0,0		   Prototype end switch for DATA(P)
EXECCL DESCR   1,0,0		   EXECUTE switch		[PLB34]
FNVLCL DESCR   0,0,0		   FUNCTION-VALUE switch for trace
HIDECL DESCR   0,0,0		   Hide statement numbers	[PLB102]
INICOM DESCR   0,0,0		   INITIALIZATION SWITCH	E3.10.6
LENFCL DESCR   0,0,0		   Length failure switch
LISTCL DESCR   0,0,0		   Compiler listing switch	[PLB33]
LLIST  DESCR   1,0,0		   Left listing switch		[PLB12]
NAMGCL DESCR   0,0,0		   Naming switch for SJSR
NERRCL DESCR   1,0,0		   NOERROR switch		[PLB9]
SCERCL DESCR   0,0,0		   Error branch switch
SPITCL DESCR   1,0,I		   SPITBOL features (-PLUSOPS)	[PLB32][PLB33]
STATCL DESCR   0,0,0		   Display statistics		[PLB12][PLB33]
.IF BLOCKS
BLOKCL DESCR   0,0,I		   SNOBOL4B/BLOCKS (-BLOCKS)	[PLB117]
.FI
*
*      Constants
*
ARBSIZ DESCR   8*NODESZ,0,0	   Node size for ARBNO(P)
CHARCL DESCR   1,0,0		   Length constant 1
CNDSIZ DESCR   CNODSZ,0,B	   Compiler node size
CODELT DESCR   200*DESCR,0,C	   Object code excess
DSCRTW DESCR   2*DESCR,0,0	   Constant 2*DESCR
EOSCL  DESCR   EOSTYP,0,0	   End of statement switch
ESALIM DESCR   ESASIZ*DESCR,0,0	   Bound on compilation errors
EXTVAL DESCR   EXTSIZ*2*DESCR,0,0				V3.11
FBLKRQ DESCR   FBLKSZ,0,B	   Quantum on allocated function blocks
GOBRCL DESCR   0,0,0		   Goto break character switch
GTOCL  DESCR   FGOTYP,0,0	   Goto decision switch
INCLSZ DESCR   4*DESCR,0,B	   Size of include save block	[PLB38]
IOBLSZ DESCR   2*DESCR,0,B	   Size of I/O blocks
LNODSZ DESCR   NODESZ+DESCR,0,P	   Size of long pattern node
NODSIZ DESCR   NODESZ,0,P	   Size of short pattern node
OBEND  DESCR   OBLIST+DESCR*OBOFF,0,0
*				   End on bin list
OCALIM DESCR   OCASIZ*DESCR,0,C	   Size of object code block
ONECL  DESCR   1,0,0		   Constant 1
OUTBLK DESCR   OUTPUT-DESCR,0,0	   Pointer to OUTPUT block
ERRBLK DESCR   PUNCH-DESCR,0,0	   Pointer to PUNCH (stderr) block [PLB8]
SIZLMT DESCR   SIZLIM,0,0	   Limit on size of data object
SNODSZ DESCR   NODESZ,0,P	   Small pattern node size
STARSZ DESCR   11*DESCR,0,P	   Size of EXPRESSION pattern
ZEROCL DESCR   0,0,0		   Constant zero
TRSKEL DESCR   TRCBLK,0,0
COMDCT DESCR   15*DESCR,0,0					[PLB58]
COMREG DESCR   ELEMND,0,0	   Pointer to compiler descriptors
*
*
*
*      Pointers to Assembled Data Patterns
*
ARBACK DESCR   ARBAK,0,P
ARHEAD DESCR   ARHED,0,P
ARTAIL DESCR   ARTAL,0,P
STRPAT DESCR   STARPT,0,P
*
*      Function Descriptors
*
ANYCCL DESCR   ANYCFN,FNC,3
ASGNCL DESCR   ASGNFN,FNC,2
ATOPCL DESCR   ATOPFN,FNC,3
BASECL DESCR   BASEFN,FNC,0
BRKCCL DESCR   BRKCFN,FNC,3
BRXCCL DESCR   BRXCFN,FNC,3					[PLB31]
BRXFCL DESCR   BRFCFN,FNC,2					[PLB31]
CHRCL  DESCR   CHRFN,FNC,3
CMACL  DESCR   CMAFN,FNC,0					[PLB32]
CONCL  DESCR   CONFN,FNC,0	   Argument count is incremented
DNMECL DESCR   DNMEFN,FNC,2
DNMICL DESCR   DNMIFN,FNC,2
ENDCL  DESCR   ENDFN,FNC,0
ENMECL DESCR   ENMEFN,FNC,3
ENMICL DESCR   ENMIFN,FNC,3
ERORCL DESCR   ERORFN,FNC,1
FNCFCL DESCR   FNCFFN,FNC,2
FNMECL DESCR   FNMEFN,FNC,2
GOTGCL DESCR   GOTGFN,FNC,1
GOTLCL DESCR   GOTLFN,FNC,1
GOTOCL DESCR   GOTOFN,FNC,1
INITCL DESCR   INITFN,FNC,1
ITEMCL DESCR   AREFN,FNC,0
LITCL  DESCR   LITFN,FNC,0	   Argument count is incremented
LNTHCL DESCR   LNTHFN,FNC,3
NMECL  DESCR   NMEFN,FNC,2
NNYCCL DESCR   NNYCFN,FNC,3
POSICL DESCR   POSIFN,FNC,3
RPSICL DESCR   RPSIFN,FNC,3
RTBCL  DESCR   RTBFN,FNC,3
SCANCL DESCR   SCANFN,FNC,2
SCFLCL DESCR   SCFLFN,FNC,2
SCOKCL DESCR   SCOKFN,FNC,2
SCONCL DESCR   SCONFN,FNC,2
SJSRCL DESCR   SJSRFN,FNC,3
SPNCCL DESCR   SPNCFN,FNC,3
SUCFCL DESCR   SUCFFN,FNC,2
TBCL   DESCR   TBFN,FNC,3
INITB  DESCR   ABNDB,0,0
INITE  DESCR   DTEND+DESCR,0,0
*
*      Miscellaneous Data Cells
*
A4PTR  DESCR   0,0,0		   Scratch descriptor
A5PTR  DESCR   0,0,0		   Scratch descriptor
A6PTR  DESCR   0,0,0		   Scratch descriptor
A7PTR  DESCR   0,0,0		   Scratch descriptor
BRTYPE DESCR   0,0,0		   Break type returned by FORWRD
CMOFCL DESCR   0,0,0		   Compiler offset
DATSEG DESCR   0,0,DATSTA	   Beginning of defined data types  [PLB31]
DMPPTR DESCR   0,0,0		   Bin pointer for DUMP
DTCL   DESCR   0,0,0		   Data type descriptor
DT1CL  DESCR   0,0,0		   Data type descriptor
EMSGCL DESCR   0,0,0		   Present error message address
ERRBAS DESCR   CARDSZ+STNOSZ,0,0				[PLB61]
ESAICL DESCR   0,0,0		   Count of compiler errors
ETMCL  DESCR   0,0,0		   Time descriptor
FCL    DESCR   0,0,0		   Real number descriptor
NEXFCL DESCR   FBLKSZ,0,0	   Offset in function block
FRTNCL DESCR   0,0,0		   Failure return
GCTMCL DESCR   0,0,0		   GC Start time		[PLB92]
GOGOCL DESCR   0,0,0		   goto descriptor
INCL   DESCR   0,0,0		   Global function descriptor
IOKEY  DESCR   0,0,0		   I/O indicator
MAXLEN DESCR   0,0,0		   Maximum length for matching
MSGNO  DESCR   MSGLST,0,0	   Pointer to error message list
NAMICL DESCR   0,0,0		   Offset on naming list
NHEDCL DESCR   0,0,0		   Name list head offset
NMOVER DESCR   NAMLSZ*SPDR,0,B	   Name list end offset
NULVCL DESCR   0,0,S		   Null string value
OCICL  DESCR   0,0,0		   Object code offset
PATICL DESCR   0,0,0		   Pattern code offset
PDLEND DESCR   0,0,0		   Pattern history list end	[PLB41]
PDLPTR DESCR   0,0,0		   Pattern history list beginning [PLB41]
SCL    DESCR   0,0,0		   Switch descriptor
SIGNCL DESCR   0,0,0		   Terminating signal() for SYSCUT [PLB47]
STKPTR DESCR   0,0,0		   Pointer to stack		[PLB85]
STKEND DESCR   0,0,0		   Pointer to stack end		[PLB85]
STYPE  DESCR   0,FNC,0		   Descriptor return by STREAM
TBLFNC DESCR   0,0,0		   Pointer to last pattern table
UINTCL DESCR   0,0,0		   User interrupt flag		[PLB109]
UNIT   DESCR   0,0,0		   Input unit switch
VARSYM DESCR   0,0,0
*
*      Program Pointers
*
DATCL  DESCR   DEFDAT,FNC,0	   Defined data objects
DEFCL  DESCR   DEFFNC,FNC,0	   Defined functions
FLDCL  DESCR   FIELD,0,1	   Field of defined data objects
LODCL  DESCR   LNKFNC,FNC,0	   External functions
PDLHED DESCR   0,0,0		   History list head		[PLB41]
UNDFCL DESCR   UNDF,FNC,0	   Undefined functions
*
*      Pointers to Specifiers
*
DPSPTR DESCR   DPSP,0,0
XSPPTR DESCR   XSP,0,0
YSPPTR DESCR   YSP,0,0
ZSPPTR DESCR   ZSP,0,0
TSPPTR DESCR   TSP,0,0
*
*      Permanent Attribute List Pointers
*
KNATL  DESCR   KNLIST,0,0	   Unprotected keyword list
KVATL  DESCR   KVLIST,0,0	   Protected keyword list
TRATL  DESCR   TRLIST,0,0	   Trace list
*
*      Specifiers for Compilation Listing
*
BLNSP  SPEC    BLNBUF,0,0,0,STNOSZ
ERRSP  SPEC    ERRBUF,0,0,0,CARDSZ+STNOSZ+1			[PLB61]
LNBFSP SPEC    INBUF,0,0,0,CARDSZ+DSTSZ+1
NEXTSP SPEC    INBUF,0,0,STNOSZ,CARDSZ				[PLB61]
LNOSP  SPEC    INBUF,0,0,0,STNOSZ
RNOSP  SPEC    INBUF,0,0,CARDSZ+STNOSZ+1,STNOSZ
*
*      Strings and Specifiers
*
ALPHSP SPEC    ALPHA,0,0,0,ALPHSZ  Alphabet
AMPSP  SPEC    AMPST,0,0,0,1	   Ampersand
CERRSP SPEC    ANYSP,0,0,0,0	   Buffer specifier
COLSP  SPEC    COLSTR,0,0,0,1	   Colon for trace messages	[PLB95]
DIGSSP SPEC    DIGITS,0,0,0,DIGSSZ Digits			[PLB105]
DMPSP  SPEC    ANYSP,0,0,0,0	   Buffer specifier
DTARSP SPEC    DTARBF,0,0,0,ARRLEN+9
*				   Array representation specifier
LCASSP SPEC    LCASE,0,0,0,LCASSZ  Lower case letters		[PLB18]
PROTSP SPEC    ANYSP,0,0,0,0	   Buffer specifier
QTSP   SPEC    QTSTR,0,0,0,1	   Quote for messages
REALSP SPEC    REALBF,0,0,0,10	   Specifier for real conversion
SPCSP  SPEC    SPCSTR,0,0,0,1	   Space for trace messages	[PLB95]
TRACSP SPEC    ANYSP,0,0,0,0	   Buffer specifier
UCASSP SPEC    UCASE,0,0,0,UCASSZ  Upper case letters		[PLB18]
*
ARRSP  STRING  'ARRAY'
ASSCSP STRING  'TABLE'
BLSP   STRING  ' '
BLEQSP STRING  ' = '
CMASP  STRING  ','
COL1SP STRING  ':'						[PLB40]
EJCTSP STRING  'EJECT'
EQLSP  STRING  '= '
ERORSP STRING  'ERRORS'						[PLB9]
ETIMSP STRING  ', time = '					[PLB11]
EXECSP STRING  'EXECUTE'					[PLB34]
EXDTSP STRING  'EXTERNAL'
FILESP STRING  'FILE'						[PLB38]
FRZNSP STRING  ' - FROZEN'					[PLB34]
HIDESP STRING  'HIDE'						[PLB102]
INCLSP STRING  'INCLUDE'					[PLB20]
LEFTSP STRING  'LEFT'
LINESP STRING  'LINE'						[PLB38]
LISTSP STRING  'LIST'
LPRNSP STRING  '('
LSFNSP STRING  'LASTFILE'					[PLB38]
LSLNSP STRING  'LASTLINE'					[PLB38]
NERRSP STRING  'NOERRORS'					[PLB9]
NEXESP STRING  'NOEXECUTE'					[PLB34]
OFSP   STRING  ' of '						[PLB11]
RPRNSP STRING  ')'
STARSP STRING  '*** '
TRCLSP STRING  ' call of '					[PLB11]
TRLVSP STRING  'level '						[PLB11]
TRSTSP STRING  ' stmt '						[PLB11][PLB95]
SPITSP STRING  'PLUSOPS'					[PLB32]
UNLSP  STRING  'UNLIST'
XFERSP STRING  'transfer to'					[PLB11]
*
*      Character Buffers
*
BLNBUF BUFFER  STNOSZ		   Blanks for statment number field
DTARBF BUFFER  ARRLEN+7		   Array representation buffer
ERRBUF BUFFER  CARDSZ+STNOSZ+1					[PLB61]
INBUF  BUFFER  CARDSZ+DSTSZ+1	   Card input buffer
REALBF BUFFER  36		   Buffer for real number conversion
ICLBLK DESCR   ICLBLK,TTL+MARK,ICLEND-ICLBLK-DESCR
*
*      Pointers to Attribute Lists
*
DTATL  DESCR   DTLIST,0,0	   Data type pair list
FNCPL  DESCR   FNLIST,0,0	   Function pair list
INATL  DESCR   INLIST,0,0	   Input association pair list
OUTATL DESCR   OTLIST,0,0	   Output association pair list
TVALL  DESCR   TVALPL,0,0	   Value trace pair list
       DESCR   VLTRFN,FNC,2	   Default value trace procedure
TLABL  DESCR   TLABPL,0,0	   Label trace pair list
       DESCR   LABTFN,FNC,1	   Default label trace procedure
TFENTL DESCR   TFENPL,0,0	   Call trace pair list
       DESCR   FNTRFN,FNC,2	   Default call trace procedure
TFEXTL DESCR   TFEXPL,0,0	   Return trace pair list
       DESCR   FXTRFN,FNC,2	   Default return trace procedure
TKEYL  DESCR   TKEYPL,0,0	   Keyword trace pair list
       DESCR   KEYTFN,FNC,1	   Default keyword trace procedure
*
*      Scratch Descriptors
*
A1PTR  DESCR   0,0,0
A2PTR  DESCR   0,0,0
A3PTR  DESCR   0,0,0
ATPTR  DESCR   0,0,0
F1PTR  DESCR   0,0,0
F2PTR  DESCR   0,0,0
IO2PTR DESCR   0,0,0
IO1PTR DESCR   0,0,0
LPTR   DESCR   0,0,0		   Last label pointer
NVAL   DESCR   0,0,0
IO3PTR DESCR   0,0,0
IO4PTR DESCR   0,0,0
TBLBCS DESCR   0,0,0		   Last BREAK string		[PLB59]
TBLSCS DESCR   0,0,0		   Last SPAN string		[PLB59]
TMVAL  DESCR   0,0,0
TPTR   DESCR   0,0,0
TCL    DESCR   0,0,0
TSIZ   DESCR   0,0,0
TVAL   DESCR   0,0,0
VVAL   DESCR   0,0,0
WCL    DESCR   0,0,0
WPTR   DESCR   0,0,0
XCL    DESCR   0,0,0
XPTR   DESCR   0,0,0
XSIZ   DESCR   0,0,0
YCL    DESCR   0,0,0
YPTR   DESCR   0,0,0
YSIZ   DESCR   0,0,0
ZCL    DESCR   0,0,0
ZPTR   DESCR   0,0,0
ZSIZ   DESCR   0,0,0
UNSCCL DESCR   0,0,0		   SCIN entry point hack for UNSC [PLB65]
PTBRCL DESCR   0,0,0		   Index for BATPRA dispatch	[PLB65]
.IF BLOCKS
TEMP1  DESCR   0,0,0
TEMP2  DESCR   0,0,0
TEMP3  DESCR   0,0,0
TEMP4  DESCR   0,0,0
TEMP5  DESCR   0,0,0
TEMP6  DESCR   0,0,0
TEMP7  DESCR   0,0,0
TEMP8  DESCR   0,0,0
TEMP9  DESCR   0,0,0
TEMP10 DESCR   0,0,0
TEMP11 DESCR   0,0,0
TEMP12 DESCR   0,0,0
TEMP13 DESCR   0,0,0
TEMP14 DESCR   0,0,0
TEMP15 DESCR   0,0,0
TEMP16 DESCR   0,0,0
TEMP17 DESCR   0,0,0
TEMP18 DESCR   0,0,0
TEMP19 DESCR   0,0,0
TEMP20 DESCR   0,0,0
TEMP21 DESCR   0,0,0
TEMP22 DESCR   0,0,0
TEMP23 DESCR   0,0,0
TEMP24 DESCR   0,0,0
TEMP25 DESCR   0,0,0
TEMP26 DESCR   0,0,0
TEMP27 DESCR   0,0,0
TEMP28 DESCR   0,0,0
TEMP29 DESCR   0,0,0
TEMP30 DESCR   0,0,0
TEMP31 DESCR   0,0,0
TEMP32 DESCR   0,0,0
TEMP33 DESCR   0,0,0
TEMP34 DESCR   0,0,0
TEMP35 DESCR   0,0,0
TEMP36 DESCR   0,0,0
TEMP37 DESCR   0,0,0
TEMP38 DESCR   0,0,0
TEMP39 DESCR   0,0,0
TEMP40 DESCR   0,0,0
TEMP41 DESCR   0,0,0
TEMP42 DESCR   0,0,0
TEMP43 DESCR   0,0,0
TEMP44 DESCR   0,0,0
TEMP45 DESCR   0,0,0
TEMP46 DESCR   0,0,0
TEMP47 DESCR   0,0,0
TEMP48 DESCR   0,0,0
TEMP49 DESCR   0,0,0
TEMP50 DESCR   0,0,0
.FI
*
*      System Descriptors
*
BOSCL  DESCR   0,0,0		   Offset of beginning of statement
CMBSCL DESCR   0,0,0		   Compiler code base descriptor
NBSPTR DESCR   0,0,0		   Name list base pointer
FBLOCK DESCR   0,0,0		   Function procedure descriptor block
OCBSCL DESCR   0,0,0		   Interpreter code base descriptor
OCLIM  DESCR   0,0,0		   End of object code block
OCSVCL DESCR   0,0,0		   Pointer to basic object code
PATBCL DESCR   0,0,0		   Pattern code base descriptor
SCBSCL DESCR   0,0,0
SRNCL  DESCR   0,0,0		   Success return descriptor
XITPTR DESCR   0,0,S		   Pointer for SETEXIT handler [PLB97][PLB100]
*
*      Compiler Descriptors
*
* zeroed on compiler termination; increment COMDCT when adding entries [PLB58]
ELEMND DESCR   0,0,0		   Element node
ELEXND DESCR   0,0,0		   Temporary node
ELEYND DESCR   0,0,0		   Temporary node
EXELND DESCR   0,0,0		   Temporary node
EXEXND DESCR   0,0,0		   Temporary node
EXOPCL DESCR   0,0,0		   Operator node
EXOPND DESCR   0,0,0		   Operator node
EXPRND DESCR   0,0,0		   Expression node
FGOND  DESCR   0,0,0		   Failure goto node
FORMND DESCR   0,0,0		   Object node
FRNCL  DESCR   0,0,0		   Failure return descriptor
GOTOND DESCR   0,0,0		   Goto node
INCSTK DESCR   0,0,0		   Include stack		[PLB38][PLB46]
PATND  DESCR   0,0,0		   Pattern node
SGOND  DESCR   0,0,0		   Success goto node
SUBJND DESCR   0,0,0		   Subject node
*
*      Data Pointers
*
DFLFST DESCR   0,0,0		   Default output format
ENDPTR DESCR   0,0,0		   'END'
EXTPTR DESCR   0,0,0		   'EXTERNAL'
FRETCL DESCR   0,0,0		   'FRETURN'
NRETCL DESCR   0,0,0		   'NRETURN'
RETCL  DESCR   0,0,0		   'RETURN'
FUNTCL DESCR   0,0,0		   'FUNCTION'
ABORCL DESCR   0,0,0		   'ABORT'			[PLB97]
CONTCL DESCR   0,0,0		   'CONTINUE'			[PLB97]
SCNTCL DESCR   0,0,0		   'SCONTINUE'			[PLB97]
EFFCL  DESCR   0,0,0		   'F'				[PLB115]
*
*      Specifiers
*
DPSP   SPEC    0,0,0,0,0	   Data type specifier
HEADSP SPEC    0,0,0,0,0	   Matching head specifier
IOSP   SPEC    0,0,0,0,0	   I/O specifier
TAILSP SPEC    0,0,0,0,0	   Matching tail specifier
TEXTSP SPEC    0,0,0,0,0	   Compiler statement specifier
TSP    SPEC    0,0,0,0,0	   Scratch specifier
TXSP   SPEC    0,0,0,0,0	   Scratch specifier
VSP    SPEC    0,0,0,0,0	   Scratch specifier
XSP    SPEC    0,0,0,0,0	   Scratch specifier
YSP    SPEC    0,0,0,0,0	   Scratch specifier
ZSP    SPEC    0,0,0,0,0	   Scratch specifier
*
*      Allocator Data
*
ARG1CL DESCR   0,0,0		   Scratch descriptor
BUKPTR DESCR   0,PTR,S		   Bin pointer
LSTPTR DESCR   0,PTR,S		   Pointer to last structure
AXPTR  DESCR   0,0,0		   Allocation size descriptor
SPECR1 SPEC    0,0,0,0,0	   Scratch specifier
SPECR2 SPEC    0,0,0,0,0	   Scratch specifier
ICLEND LHERE   ,		   End of basic block
*
*      Allocator Data
*
BK1CL  DESCR   0,0,0		   Pointer to block being marked
BKDX   DESCR   0,0,0		   Offset in block being marked
BKDXU  DESCR   0,0,0		   Offset in block
BKLTCL DESCR   0,0,0
BKPTR  DESCR   0,PTR,S
BLOCL  DESCR   0,0,0
CONVSW DESCR   0,0,0		   CONVAR-GENVAR entry switch
CPYCL  DESCR   0,0,0		   Regeneration block pointer
DESCL  DESCR   0,0,0		   Regeneration scratch descriptor
EQUVCL DESCR   0,0,0		   Variable identification descriptor
FRDSCL DESCR   4*DESCR,0,0
GCBLK  DESCR   GCXTTL,0,0	   Pointer to marking block
GCNO   DESCR   0,0,0		   Count of regenerations
GCMPTR DESCR   0,0,0		   Pointer to basic blocks
GCREQ  DESCR   0,0,0		   Space required from regeneration
GCGOT  DESCR   0,0,I		   Space obtained from regeneration
LCPTR  DESCR   0,0,0		   Scratch descriptor
MVSGPT DESCR   0,0,0		   Compression boundary pointer
NODPCL DESCR   0,0,0		   Regeneration switch
OBPTR  DESCR   OBLIST,PTR,S	   Pointer to bins
OFSET  DESCR   0,0,0		   Offset in block during regeneration
PRMDX  DESCR   PRMSIZ,0,0	   Size of basic block list
PRMPTR DESCR   PRMTBL,0,0	   Pointer to list of basic blocks
ST1PTR DESCR   0,PTR,S		   Regeneration link pointer
ST2PTR DESCR   0,PTR,S		   Regeneration link pointer
TEMPCL DESCR   0,PTR,0		   Scracth descriptor
TOPCL  DESCR   0,0,0		   Pointer to block title
TTLCL  DESCR   0,0,0		   Pointer to block title
TWOCL  DESCR   2*DESCR,0,B	   Size of string to be marked
*
*
FRSGPT DESCR   0,PTR,0		   Position pointer
HDSGPT DESCR   0,PTR,0		   Head of allocated data region
TLSGP1 DESCR   0,PTR,0		   End of allocated data region
GCXTTL DESCR   GCXTTL,TTL+MARK,DESCR
*				   Block to prime marking procedure
       DESCR   0,0,0		   Pointer to block to mark
*
*      Saved state for SETEXIT handler			[PLB97]
*
XERRTY DESCR   0,0,0		   Saved &ERRTYPE	[PLB97]
XFILEN DESCR   0,0,0   	           Saved &FILE		[PLB97]
XLNNOC DESCR   0,0,0		   Saved &LINE		[PLB97]
XSTNOC DESCR   0,0,0		   Saved &STNO		[PLB97]
XLSFLN DESCR   0,0,0		   Saved &LASTFILE	[PLB97]
XLSLNC DESCR   0,0,0		   Saved &LASTLINE	[PLB98]
XLSTNC DESCR   0,0,0		   Saved &LASTNO	[PLB98]
XFRTNC DESCR   0,0,0		   Saved FRTNCL		[PLB97]
XOCBSC DESCR   0,0,0		   Saved OCBSCL		[PLB97]
XOCICL DESCR   0,0,0		   Saved OCICL		[PLB97]
*
*      Machine-dependent Data
*
       COPY    MDATA		   Segment of machine-dependent data
*
*      Function Table
*
FTABLE DESCR   FTABLE,TTL+MARK,FTBLND-FTABLE-DESCR
*
*      Primitive Functions
*
ANYFN  DESCR   ANY,0,1
       DESCR   0,0,0
APLYFN DESCR   APPLY,FNC,1
       DESCR   0,0,0
ARBOFN DESCR   ARBNO,0,1
       DESCR   0,0,0
ARGFN  DESCR   ARG,0,2
       DESCR   0,0,0
ARRAFN DESCR   ARRAY,0,2
       DESCR   0,0,0
ASSCFN DESCR   ASSOC,0,2
       DESCR   0,0,0
BACKFN DESCR   BKSPCE,0,1
       DESCR   0,0,0
BREAFN DESCR   BREAK,0,1
       DESCR   0,0,0
BREXFN DESCR   BREAKX,0,1					[PLB31]
       DESCR   0,0,0						[PLB31]
CHARFN DESCR   CHAR,0,1						[PLB31]
       DESCR   0,0,0						[PLB31]
CLEAFN DESCR   CLEAR,0,1
       DESCR   0,0,0
CODEFN DESCR   CODER,0,1
       DESCR   0,0,0
COLEFN DESCR   COLECT,0,1
       DESCR   0,0,0
CNVRFN DESCR   CNVRT,0,2
       DESCR   0,0,0
COPYFN DESCR   COPY,0,1
       DESCR   0,0,0
DATFN  DESCR   DATE,0,1
       DESCR   0,0,0
DATDFN DESCR   DATDEF,0,1
       DESCR   0,0,0
DEFIFN DESCR   DEFINE,0,2
       DESCR   0,0,0
DIFFFN DESCR   DIFFER,0,2
       DESCR   0,0,0
DTCHFN DESCR   DETACH,0,1
       DESCR   0,0,0
DTFN   DESCR   DT,0,1
       DESCR   0,0,0
DUMPFN DESCR   DMP,0,1
       DESCR   0,0,0
DUPLFN DESCR   DUPL,0,2
       DESCR   0,0,0
ENDFFN DESCR   ENDFIL,0,1					[PLB86]
       DESCR   0,0,0
EQFN   DESCR   EQ,0,2
       DESCR   0,0,0
EVALFN DESCR   EVAL,0,1
       DESCR   0,0,0
FLDSFN DESCR   FIELDS,0,2
       DESCR   0,0,0
FREZFN DESCR   FREEZE,0,1					[PLB34]
       DESCR   0,0,0
FUNTFN DESCR   FUNCTN,0,1					[PLB80]
       DESCR   0,0,0						[PLB80]
GEFN   DESCR   GE,0,2
       DESCR   0,0,0
GTFN   DESCR   GT,0,2
       DESCR   0,0,0
IDENFN DESCR   IDENT,0,2
       DESCR   0,0,0
INTGFN DESCR   INTGER,0,1
       DESCR   0,0,0
ITEMFN DESCR   ITEM,FNC,1
       DESCR   0,0,0
LABLFN DESCR   LABEL,0,1					[PLB78]
       DESCR   0,0,0						[PLB78]
LEFN   DESCR   LE,0,2
       DESCR   0,0,0
LENFN  DESCR   LEN,0,1
       DESCR   0,0,0
LEQFN  DESCR   LEQ,0,2						[PLB37]
       DESCR   0,0,0						[PLB37]
LGEFN  DESCR   LGE,0,2						[PLB37]
       DESCR   0,0,0						[PLB37]
LGTFN  DESCR   LGT,0,2
       DESCR   0,0,0
LLEFN  DESCR   LLE,0,2						[PLB37]
       DESCR   0,0,0						[PLB37]
LLTFN  DESCR   LLT,0,2						[PLB37]
       DESCR   0,0,0						[PLB37]
LNEFN  DESCR   LNE,0,2						[PLB37]
       DESCR   0,0,0						[PLB37]
LOADFN DESCR   LOAD,0,2
       DESCR   0,0,0
LOCFN  DESCR   LOCAL,0,2
       DESCR   0,0,0
LPADFN DESCR   LPAD,0,3						[PLB31]
       DESCR   0,0,0						[PLB31]
LTFN   DESCR   LT,0,2
       DESCR   0,0,0
NEFN   DESCR   NE,0,2
       DESCR   0,0,0
NOTAFN DESCR   NOTANY,0,1
       DESCR   0,0,0
OPSYFN DESCR   OPSYN,0,3
       DESCR   0,0,0
POSFN  DESCR   POS,0,1
       DESCR   0,0,0
PRINFN DESCR   PRINT,0,4					[PLB4]
       DESCR   0,0,0
PROTFN DESCR   PROTO,0,1
       DESCR   0,0,0
REMDFN DESCR   REMDR,0,2
       DESCR   0,0,0
RPLAFN DESCR   RPLACE,0,3
       DESCR   0,0,0
READFN DESCR   READ,0,4						[PLB4]
       DESCR   0,0,0
REVRFN DESCR   REVERS,0,1					[PLB37]
       DESCR   0,0,0						[PLB37]
REWNFN DESCR   REWIND,0,1
       DESCR   0,0,0
RPOSFN DESCR   RPOS,0,1
       DESCR   0,0,0
RPADFN DESCR   RPAD,0,3						[PLB31]
       DESCR   0,0,0						[PLB31]
RSRTFN DESCR   RSORT,FNC,1					[PLB31]
       DESCR   0,0,0						[PLB31]
RTABFN DESCR   RTAB,0,1
       DESCR   0,0,0
SETFN  DESCR   SET,0,3						[PLB52]
       DESCR   0,0,0						[PLB52]
SETXFN DESCR   SETXIT,0,1					[PLB97]
       DESCR   0,0,0						[PLB97]
SIZEFN DESCR   SIZE,0,1
       DESCR   0,0,0
SORTFN DESCR   SORT,FNC,1					[PLB31]
       DESCR   0,0,0						[PLB31]
SSTRFN DESCR   SUBSTR,0,3					[PLB37]
       DESCR   0,0,0						[PLB37]
SPANFN DESCR   SPAN,0,1
       DESCR   0,0,0
STPTFN DESCR   STOPTR,0,2
       DESCR   0,0,0
TABFN  DESCR   TAB,0,1
       DESCR   0,0,0
THAWFN DESCR   THAW,0,1						[PLB34]
       DESCR   0,0,0
TIMFN  DESCR   TIME,0,1
       DESCR   0,0,0
TRCEFN DESCR   TRACE,0,4
       DESCR   0,0,0
TRIMFN DESCR   TRIM,0,1
       DESCR   0,0,0
UNLDFN DESCR   UNLOAD,0,1
       DESCR   0,0,0
VALFN  DESCR   FIELD,0,1
       DESCR   VALBLK,0,0
VDIFFN DESCR   VDIFFR,0,2
       DESCR   0,0,0
.IF BLOCKS
F1FN   DESCR   PRINTB,FNC,0	   PRINT
       DESCR   0,0,0
F2FN   DESCR   HOR,FNC,0	   HOR
       DESCR   0,0,0
F3FN   DESCR   VER,FNC,0	   VER
       DESCR   0,0,0
F4FN   DESCR   FRONT,FNC,0	   FRONT
       DESCR   0,0,0
F5FN   DESCR   BOX,FNC,0	   BOX
       DESCR   0,0,0
F6FN   DESCR   PAR,FNC,0	   PAR
       DESCR   0,0,0
F7FN   DESCR   SER,FNC,0	   SER
       DESCR   0,0,0
F8FN   DESCR   OVY,FNC,0	   OVY
       DESCR   0,0,0
F9FN   DESCR   HOR_REG,FNC,0	   HOR_REG
       DESCR   0,0,0
F10FN  DESCR   VER_REG,FNC,0	   VER_REG
       DESCR   0,0,0
F11FN  DESCR   NORM_REG,FNC,0	   NORM_REG
       DESCR   0,0,0
F12FN  DESCR   IT,FNC,0		   IT
       DESCR   0,0,0
F13FN  DESCR   REP,FNC,0	   REP
       DESCR   0,0,0
F14FN  DESCR   DEF,FNC,0	   DEF
       DESCR   0,0,0
F15FN  DESCR   NODE,FNC,0	   NODE
       DESCR   0,0,0
F16FN  DESCR   MERGE,FNC,0	   MERGE
       DESCR   0,0,0
F17FN  DESCR   HEIGHT,FNC,0	   HEIGHT
       DESCR   0,0,0
F18FN  DESCR   WIDTH,FNC,0	   WIDTH
       DESCR   0,0,0
F19FN  DESCR   DEPTH,FNC,0	   DEPTH
       DESCR   0,0,0
F20FN  DESCR   BLOCKSIZ,FNC,0	   BSIZE
       DESCR   0,0,0
F21FN  DESCR   SLAB,FNC,0	   SLAB
       DESCR   0,0,0
F22FN  DESCR   FIX,FNC,0	   FIX
       DESCR   0,0,0
F23FN  DESCR   BCHAR,FNC,0	   BCHAR			[PLB117]
       DESCR   0,0,0
F24FN  DESCR   DUP,FNC,0	   DUP
       DESCR   0,0,0
F25FN  DESCR   CC,FNC,0		   CC
       DESCR   0,0,0
F26FN  DESCR   NEW_PAGE,FNC,0	   EJECT
       DESCR   0,0,0
F27FN  DESCR   LRECL,FNC,0	   LRECL
       DESCR   0,0,0
F28FN  DESCR   LOC,FNC,0	   LOC
       DESCR   0,0,0
.FI       
FTBLND LHERE   ,
*
INITLS DESCR   INITLS,TTL+MARK,8*DESCR
       DESCR   DTLIST,0,0
       DESCR   FNLIST,0,0
       DESCR   INLIST,0,0
       DESCR   KNLIST,0,0
       DESCR   KVLIST,0,0
       DESCR   OTLIST,0,0
       DESCR   OTSATL,0,0
       DESCR   TRLIST,0,0
*
*      Function Pair List
*
FNLIST DESCR   FNLIST,TTL+MARK,FNCPLE-FNLIST-DESCR
       DESCR   ANYFN,FNC,0	   ANY(CS)
       DESCR   ANYSP,0,0
       DESCR   APLYFN,FNC,0	   APPLY(F,A1,...,AN)
       DESCR   APLYSP,0,0
       DESCR   ARBOFN,FNC,0	   ARBNO(P)
       DESCR   ARBNSP,0,0
       DESCR   ARGFN,FNC,0	   ARG(F,N)
       DESCR   ARGSP,0,0
       DESCR   ARRAFN,FNC,0	   ARRAY(P,V)
       DESCR   ARRSP,0,0
       DESCR   BACKFN,FNC,0	   BACKSPACE(N)
       DESCR   BACKSP,0,0
       DESCR   BREAFN,FNC,0	   BREAK(CS)
       DESCR   BRKSP,0,0
       DESCR   BREXFN,FNC,0	   BREAKX(CS)			[PLB31]
       DESCR   BRKXSP,0,0					[PLB31]
       DESCR   CHARFN,FNC,0	   CHAR(N)			[PLB31]
       DESCR   CHARSP,0,0					[PLB31]
       DESCR   CLEAFN,FNC,0	   CLEAR()
       DESCR   CLERSP,0,0
       DESCR   CODEFN,FNC,0	   CODE(S)
       DESCR   CODESP,0,0
       DESCR   COLEFN,FNC,0	   COLLECT(N)
       DESCR   CLSP,0,0
       DESCR   CNVRFN,FNC,0	   CONVERT(V,DT)
       DESCR   CNVTSP,0,0
       DESCR   COPYFN,FNC,0	   COPY(V)
       DESCR   COPYSP,0,0
       DESCR   DATDFN,FNC,0	   DATA(P)
       DESCR   DATASP,0,0
       DESCR   DATFN,FNC,0	   DATE()			E3.0.5
       DESCR   DATSP,0,0
       DESCR   DEFIFN,FNC,0	   DEFINE(P,L)
       DESCR   DEFISP,0,0
       DESCR   DIFFFN,FNC,0	   DIFFER(V1,V2)
       DESCR   DIFFSP,0,0
       DESCR   DTCHFN,FNC,0	   DETACH(V)
       DESCR   DTCHSP,0,0
       DESCR   DTFN,FNC,0	   DATATYPE(V)
       DESCR   DTSP,0,0
       DESCR   DUMPFN,FNC,0	   DUMP()
       DESCR   DUMPSP,0,0
       DESCR   DUPLFN,FNC,0	   DUPL(S,N)
       DESCR   DUPLSP,0,0
       DESCR   ENDFFN,FNC,0	   ENDFILE(N)
       DESCR   ENDFSP,0,0
       DESCR   EQFN,FNC,0	   EQ(I1,I2)
       DESCR   EQSP,0,0
       DESCR   EVALFN,FNC,0	   EVAL(E)
       DESCR   EVALSP,0,0
       DESCR   FLDSFN,FNC,0	   FIELD(V,N)
       DESCR   FLDSSP,0,0
       DESCR   FREZFN,FNC,0	   FREEZE(T)			[PLB34]
       DESCR   FREZSP,0,0					[PLB34]
       DESCR   FUNTFN,FNC,0	   FUNCTION(N)			[PLB80]
       DESCR   FUNTSP,0,0					[PLB80]
       DESCR   GEFN,FNC,0	   GE(I1,I2)
       DESCR   GESP,0,0
       DESCR   GTFN,FNC,0	   GT(I1,I2)
       DESCR   GTSP,0,0
       DESCR   IDENFN,FNC,0	   IDENT(V1,V2)
       DESCR   IDENSP,0,0
       DESCR   READFN,FNC,0	   INPUT(V,U,O,N)		[PLB4]
       DESCR   INSP,0,0
       DESCR   INTGFN,FNC,0	   INTEGER(V)
       DESCR   INTGSP,0,0
       DESCR   ITEMFN,FNC,0	   ITEM(A,I1,...,IN)
       DESCR   ITEMSP,0,0
       DESCR   LABLFN,FNC,0	   LABEL(V)			[PLB78]
       DESCR   TRLASP,0,0					[PLB78]
       DESCR   LENFN,FNC,0	   LEN(N)
       DESCR   LENSP,0,0
       DESCR   LEFN,FNC,0	   LE(I1,I2)
       DESCR   LESP,0,0
       DESCR   LEQFN,FNC,0	   LEQ(S1,S2)			[PLB37]
       DESCR   LEQSP,0,0					[PLB37]
       DESCR   LGEFN,FNC,0	   LGE(S1,S2)			[PLB37]
       DESCR   LGESP,0,0					[PLB37]
       DESCR   LGTFN,FNC,0	   LGT(S1,S2)
       DESCR   LGTSP,0,0
       DESCR   LLEFN,FNC,0	   LLE(S1,S2)			[PLB37]
       DESCR   LLESP,0,0					[PLB37]
       DESCR   LLTFN,FNC,0	   LLT(S1,S2)			[PLB37]
       DESCR   LLTSP,0,0					[PLB37]
       DESCR   LNEFN,FNC,0	   LNE(S1,S2)			[PLB37]
       DESCR   LNESP,0,0					[PLB37]
       DESCR   LOADFN,FNC,0	   LOAD(P)
       DESCR   LOADSP,0,0
       DESCR   LOCFN,FNC,0	   LOCAL(F,N)
       DESCR   LOCSP,0,0
       DESCR   LPADFN,FNC,0	   LPAD(S,N,C)			[PLB31]
       DESCR   LPADSP,0,0					[PLB31]
       DESCR   LTFN,FNC,0	   LT(I1,I2)
       DESCR   LTSP,0,0
       DESCR   NEFN,FNC,0	   NE(I1,I2)
       DESCR   NESP,0,0
       DESCR   NOTAFN,FNC,0	   NOTANY(CS)
       DESCR   NNYSP,0,0
       DESCR   OPSYFN,FNC,0	   OPSYN(F1,F2,N)
       DESCR   OPSNSP,0,0
       DESCR   PRINFN,FNC,0	   OUTPUT(V,U,O,N)		[PLB4]
       DESCR   OUTSP,0,0
       DESCR   POSFN,FNC,0	   POS(N)
       DESCR   POSSP,0,0
       DESCR   PROTFN,FNC,0	   PROTOTYPE(A)
       DESCR   PRTSP,0,0
       DESCR   REMDFN,FNC,0	   REMDR(N,M)
       DESCR   REMDSP,0,0
       DESCR   REVRFN,FNC,0	   REVERSE(S)			[PLB37]
       DESCR   REVRSP,0,0					[PLB37]
       DESCR   REWNFN,FNC,0	   REWIND(N)
       DESCR   REWNSP,0,0
       DESCR   RPLAFN,FNC,0	   REPLACE(S,CS1,CS2)
       DESCR   RPLCSP,0,0
       DESCR   RPOSFN,FNC,0	   RPOS(N)
       DESCR   RPOSSP,0,0
       DESCR   RPADFN,FNC,0	   RPAD(S,N,C)			[PLB31]
       DESCR   RPADSP,0,0					[PLB31]
       DESCR   RSRTFN,FNC,0	   RSORT(T,C)			[PLB31]
       DESCR   RSRTSP,0,0					[PLB31]
       DESCR   RTABFN,FNC,0	   RTAB(N)
       DESCR   RTABSP,0,0
       DESCR   SETFN,FNC,0	   SET(N,O,W)			[PLB52]
       DESCR   SETSP,0,0					[PLB52]
       DESCR   SETXFN,FNC,0	   SETEXIT(LBL)			[PLB97]
       DESCR   SETXSP,0,0					[PLB97]
       DESCR   SIZEFN,FNC,0	   SIZE(S)
       DESCR   SIZESP,0,0
       DESCR   SORTFN,FNC,0	   SORT(T,C)			[PLB31]
       DESCR   SORTSP,0,0					[PLB31]
       DESCR   SPANFN,FNC,0	   SPAN(CS)
       DESCR   SPANSP,0,0
       DESCR   STPTFN,FNC,0	   STOPTR(V,R)
       DESCR   STPTSP,0,0
       DESCR   SSTRFN,FNC,0	   SUBSTR(S,P,L)		[PLB37]
       DESCR   SSTRSP,0,0					[PLB37]
       DESCR   TABFN,FNC,0	   TAB(N)
       DESCR   TABSP,0,0
       DESCR   ASSCFN,FNC,0	   TABLE(N,M)
       DESCR   ASSCSP,0,0
       DESCR   THAWFN,FNC,0	   THAW(T)			[PLB34]
       DESCR   THAWSP,0,0					[PLB34]
       DESCR   TIMFN,FNC,0	   TIME()
       DESCR   TIMSP,0,0
       DESCR   TRCEFN,FNC,0	   TRACE(V,R,T,F)
       DESCR   TRCESP,0,0
       DESCR   TRIMFN,FNC,0	   TRIM(S)
       DESCR   TRMSP,0,0
       DESCR   UNLDFN,FNC,0	   UNLOAD(S)
       DESCR   UNLDSP,0,0
       DESCR   VALFN,FNC,0	   VALUE(S)
       DESCR   VALSP,0,0
       DESCR   VDIFFN,FNC,0	   VDIFFER(V1,V2)		[PLB78]
       DESCR   VDIFSP,0,0					[PLB78]
.IF BLOCKS
       DESCR   F1FN,FNC,0	   PRINT
       DESCR   F1SP,0,0
       DESCR   F2FN,FNC,0		   HOR
       DESCR   F2SP,0,0
       DESCR   F3FN,FNC,0	   VER
       DESCR   F3SP,0,0
       DESCR   F4FN,FNC,0	   FRONT
       DESCR   F4SP,0,0
       DESCR   F5FN,0,0		   BOX
       DESCR   F5SP,0,0
       DESCR   F6FN,FNC,0	   PAR
       DESCR   F6SP,0,0
       DESCR   F7FN,FNC,0	   SER
       DESCR   F7SP,0,0
       DESCR   F8FN,FNC,0	   OVY
       DESCR   F8SP,0,0
       DESCR   F9FN,FNC,0	   HOR_REG
       DESCR   F9SP,0,0
       DESCR   F10FN,FNC,0	   VER_REG
       DESCR   F10SP,0,0
       DESCR   F11FN,FNC,0	   NORM_REG
       DESCR   F11SP,0,0
       DESCR   F12FN,FNC,0	   IT
       DESCR   F12SP,0,0
       DESCR   F13FN,FNC,0	   REP
       DESCR   F13SP,0,0
       DESCR   F14FN,FNC,0	   DEF
       DESCR   F14SP,0,0
       DESCR   F15FN,FNC,0	   NODE
       DESCR   F15SP,0,0
       DESCR   F16FN,FNC,0	   MERGE
       DESCR   F16SP,0,0
       DESCR   F17FN,FNC,0	   HEIGHT
       DESCR   F17SP,0,0
       DESCR   F18FN,FNC,0	   WIDTH
       DESCR   F18SP,0,0
       DESCR   F19FN,FNC,0	   DEPTH
       DESCR   F19SP,0,0
       DESCR   F20FN,FNC,0	   BSIZE
       DESCR   F20SP,0,0
       DESCR   F21FN,FNC,0	   SLAB
       DESCR   F21SP,0,0
       DESCR   F22FN,FNC,0	   FIX
       DESCR   F22SP,0,0
       DESCR   F23FN,FNC,0	   BCHAR			[PLB117]
       DESCR   F23SP,0,0
       DESCR   F24FN,FNC,0	   DUP
       DESCR   F24SP,0,0
       DESCR   F25FN,FNC,0	   CC
       DESCR   F25SP,0,0
       DESCR   F26FN,FNC,0	   EJECT
       DESCR   F26SP,0,0
       DESCR   F27FN,FNC,0	   LRECL
       DESCR   F27SP,0,0
       DESCR   F28FN,FNC,0	   LOC
       DESCR   F28SP,0,0
.FI
       ARRAY   40*2		   Space for 40 more functions	[PLB56][PLB81]
FNCPLE LHERE   ,		   End of function pair list
OPTBL  DESCR   OPTBL,TTL+MARK,OPTBND-OPTBL-DESCR
ADDFN  DESCR   ADD,0,2		   X + Y    addition
       DESCR   0,0,0
       DESCR   30,0,29
BIAMFN DESCR   UNDF,FNC,0	   X & Y    definable
       DESCR   0,0,0
       DESCR   5,0,4
BIATFN DESCR   UNDF,FNC,0	   X @ Y    definable
       DESCR   0,0,0
       DESCR   25,0,24
BINGFN DESCR   UNDF,FNC,0	   X \ Y    definable
       DESCR   0,0,0
       DESCR   70,0,70
BIPDFN DESCR   UNDF,FNC,0	   X # Y    definable
       DESCR   0,0,0
       DESCR   35,0,34
BIPRFN DESCR   UNDF,FNC,0	   X % Y    definable
       DESCR   0,0,0
       DESCR   45,0,44
.IF BLOCKS
BIBDFN DESCR   OVY,FNC,0	   X # Y    overlay		[BLOCKS]
       DESCR   0,0,0
       DESCR   16,0,15
BIBRFN DESCR   SER,FNC,0	   X % Y    serial?		[BLOCKS]
       DESCR   0,0,0
       DESCR   18,0,17
.FI
BISNFN LHERE   ,						[PLB32]
SCANFN DESCR   SCAN,0,2		   X ? Y    SPITBOL scan	[PLB32]
       DESCR   0,0,0						[PLB32]
       DESCR   3,0,2						[PLB32]
BIQSFN DESCR   UNDF,FNC,0	   X ? Y    definable
       DESCR   0,0,0
       DESCR   70,0,69
BISRFN LHERE   ,						[PLB32]
SJSRFN DESCR   SJSR,0,3		   X ? Y =  SPITBOL scan & repl [PLB32]
       DESCR   0,0,0						[PLB32]
       DESCR   3,0,2						[PLB32]
BIEQFN LHERE   ,						[PLB32]
ASGNFN DESCR   ASGN,0,2		   X = Y    SPITBOL assignment	[PLB32]
       DESCR   0,0,0						[PLB32]
       DESCR   1,0,1						[PLB32]
CONFN  DESCR   CONCAT,0,2	   X   Y    concatenation	[PLB74]
       DESCR   0,0,0
       DESCR   20,0,19
DIVFN  DESCR   DIV,0,2		   X / Y    division
       DESCR   0,0,0
       DESCR   40,0,39
DOLFN  DESCR   DOL,0,2		   X $ Y    immediate naming
       DESCR   0,0,0
       DESCR   60,0,59
EXPFN  DESCR   EXPOP,0,2	   X ** Y   exponentiation	[PLB43]
       DESCR   0,0,0
       DESCR   50,0,50
MPYFN  DESCR   MPY,0,2		   X * Y    multiplication
       DESCR   0,0,0
       DESCR   42,0,41
NAMFN  DESCR   NAM,0,2		   X . Y    naming
       DESCR   0,0,0
       DESCR   60,0,59
ORFN   DESCR   OR,0,2		   X | Y    alternation
       DESCR   0,0,0
       DESCR   10,0,9
SUBFN  DESCR   SUB,0,2		   X - Y    subtraction
       DESCR   0,0,0
       DESCR   30,0,29
AROWFN DESCR   UNDF,FNC,0	   !X	    definable
       DESCR   0,0,0
ATFN   DESCR   ATOP,0,1		   @X	    scanner position
       DESCR   0,0,0
BARFN  DESCR   UNDF,FNC,0	   |X	    definable
       DESCR   0,0,0
DOTFN  DESCR   NAME,0,1		   .X	    name
       DESCR   0,0,0
INDFN  DESCR   IND,0,1		   $X	    indirect reference
       DESCR   0,0,0
KEYFN  DESCR   KEYWRD,0,1	   &X	    keyword
       DESCR   0,0,0
MNSFN  DESCR   MNS,0,1		   -X	    minus
       DESCR   0,0,0
NEGFN  DESCR   NEG,0,1		   \X	    negation
       DESCR   0,0,0
PDFN   DESCR   UNDF,FNC,0	   #X	    definable
       DESCR   0,0,0
PLSFN  DESCR   PLS,0,1		   +X	    plus
       DESCR   0,0,0
PRFN   DESCR   UNDF,FNC,0	   %X	    definable
       DESCR   0,0,0
QUESFN DESCR   QUES,0,1		   ?X	    interrogation
       DESCR   0,0,0
SLHFN  DESCR   UNDF,FNC,0	   /X	    definable
       DESCR   0,0,0
STRFN  DESCR   STR,0,1		   *X	    unevaluated expression
       DESCR   0,0,0
OPTBND LHERE   ,		   End of operator table
*
*
AREFN  DESCR   ITEM,FNC,1	   Array or table reference
BASEFN DESCR   BASE,0,0		   Base object code
CMAFN  DESCR   CMA,FNC,1					[PLB32]
ENDAFN DESCR   ARGNER,0,0	   Safety exit on trace psuedo-code
ENDFN  DESCR   END,0,0		   End of program
ERORFN DESCR   EROR,0,1		   Erroneous statement
FNTRFN DESCR   FENTR,0,2	   Call tracing
FXTRFN DESCR   FNEXTR,0,2	   Return tracing
GOTGFN DESCR   GOTG,0,1		   :<X>
GOTLFN DESCR   GOTL,0,1		   :(L)
GOTOFN DESCR   GOTO,0,1		   Internal goto
INITFN DESCR   INIT,0,1		   Statement initialization
KEYTFN DESCR   KEYTR,0,2	   Keyword tracing
LABTFN DESCR   LABTR,0,2	   Label tracing
LITFN  DESCR   LIT,0,1		   Literal evaluation
VLTRFN DESCR   VALTR,0,2	   Value tracing
*
* [PLB65] use PATBRA index defines;
ANYCFN DESCR   XANYC,0,3	   Matching for ANY(S)
ARBFFN DESCR   XARBF,0,2	   Failure for ARB
ARBNFN DESCR   XARBN,0,2	   Matching for ARBNO(P)
ATOPFN DESCR   XATP,0,3		   Matching for @X
CHRFN  DESCR   XCHR,0,3		   Matching for string
BALFN  DESCR   XBAL,0,2		   Matching for BAL
BALFFN DESCR   XBALF,0,2	   Failure for BAL
BRKCFN DESCR   XBRKC,0,3	   Matching for BREAK(S)
BRXCFN DESCR   XBRKX,0,3	   Matching for BREAKX(S)	[PLB31]
BRFCFN DESCR   XBRKXF,0,2	   Rematching for BREAKX(S)	[PLB31]
DNMEFN DESCR   XDNME,0,2
DNMIFN DESCR   XDNME1,0,2
EARBFN DESCR   XEARB,0,2
DSARFN DESCR   XDSAR,0,3
ENMEFN DESCR   XENME,0,3
ENMIFN DESCR   XENMI,0,3
FARBFN DESCR   XFARB,0,2
FNMEFN DESCR   XFNME,0,2
LNTHFN DESCR   XLNTH,0,3	   Matching for LEN(N)
NMEFN  DESCR   XNME,0,2
NNYCFN DESCR   XNNYC,0,3	   Matching for NOTANY(S)
ONARFN DESCR   XONAR,0,2
ONRFFN DESCR   XONRF,0,2
POSIFN DESCR   XPOSI,0,3	   Matching for POS(N)
RPSIFN DESCR   XRPSI,0,3	   Matching for RPOS(N)
RTBFN  DESCR   XRTB,0,3		   Matching for RTAB(N)
SALFFN DESCR   XSALF,0,2
SCFLFN DESCR   XFAIL,0,2
SCOKFN DESCR   XSCOK,0,2	   Successful match procedure
SCONFN DESCR   XSCON,0,2
SPNCFN DESCR   XSPNC,0,3	   Matching for SPAN(S)
STARFN DESCR   XSTAR,0,3	   Matching for *X
TBFN   DESCR   XTB,0,3		   Matching for TAB(N)
ABORFN DESCR   XRTNL3,0,3	   Matching for ABORT
FNCEFN DESCR   XFNCE,0,2	   Matching for FENCE
FNCFFN DESCR   XRTNL3,0,2	   Failure for FENCE
SUCFFN DESCR   XSUCF,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'
BACKSP STRING  'BACKSPACE'
BALSP  STRING  'BAL'
BRKSP  STRING  'BREAK'
BRKXSP STRING  'BREAKX'						[PLB31]
TRFRSP STRING  'CALL'
CSP    STRING  'C'						[PLB115]
CASESP STRING  'CASE'						[PLB15]
CHARSP STRING  'CHAR'						[PLB31]
CLERSP STRING  'CLEAR'
CODESP STRING  'CODE'
CLSP   STRING  'COLLECT'
CNOSP  STRING  'COMPNO'						[PLB123]
CNVTSP STRING  'CONVERT'
CONTSP STRING  'CONTINUE'					[PLB97]
COPYSP STRING  'COPY'
DATSP  STRING  'DATE'
DATASP STRING  'DATA'
DEFISP STRING  'DEFINE'
DIFFSP STRING  'DIFFER'
DGNMSP STRING  'DIGITS'						[PLB105]
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'
ERTXSP STRING  'ERRTEXT'					[PLB38]
EVALSP STRING  'EVAL'
EXPSP  STRING  'EXPRESSION'
FSP    STRING  'F'						[PLB115]
FAILSP STRING  'FAIL'
FNCESP STRING  'FENCE'
FLDSSP STRING  'FIELD'
FNCLSP STRING  'FNCLEVEL'
FREZSP STRING  'FREEZE'						[PLB34]
FRETSP STRING  'FRETURN'
FTRCSP STRING  'FTRACE'
FULLSP STRING  'FULLSCAN'
FUNTSP STRING  'FUNCTION'
GCTMSP STRING  'GCTIME'						[PLB107]
GESP   STRING  'GE'
GTSP   STRING  'GT'
GTRCSP STRING  'GTRACE'						[PLB92]
IDENSP STRING  'IDENT'
INSP   STRING  'INPUT'
INTGSP STRING  'INTEGER'
ITEMSP STRING  'ITEM'
KSP    STRING  'K'						[PLB115]
TRKYSP STRING  'KEYWORD'
LSP    STRING  'L'						[PLB115]
TRLASP STRING  'LABEL'
LSTNSP STRING  'LASTNO'
LCNMSP STRING  'LCASE'						[PLB18]
LENSP  STRING  'LEN'
LESP   STRING  'LE'
LEQSP  STRING  'LEQ'						[PLB37]
LGESP  STRING  'LGE'						[PLB37]
LGTSP  STRING  'LGT'
LLESP  STRING  'LLE'						[PLB37]
LLTSP  STRING  'LLT'						[PLB37]
LNESP  STRING  'LNE'						[PLB37]
LOADSP STRING  'LOAD'
LOCSP  STRING  'LOCAL'
LPADSP STRING  'LPAD'						[PLB31]
LTSP   STRING  'LT'
MAXLSP STRING  'MAXLNGTH'
MAXISP STRING  'MAXINT'						[PLB108]
NAMESP STRING  'NAME'
NESP   STRING  'NE'
NNYSP  STRING  'NOTANY'
NRETSP STRING  'NRETURN'
NUMSP  STRING  'NUMERIC'					[PLB32]
OPSNSP STRING  'OPSYN'
OUTSP  STRING  'OUTPUT'
PARMSP STRING  'PARM'						[PLB39]
PATSP  STRING  'PATTERN'
PISP   STRING  'PI'						[PLB106]
POSSP  STRING  'POS'
PRTSP  STRING  'PROTOTYPE'
RSP    STRING  'R'						[PLB122]
RLSP   STRING  'REAL'
REMSP  STRING  'REM'
REMDSP STRING  'REMDR'
RETSP  STRING  'RETURN'
REVRSP STRING  'REVERSE'					[PLB37]
REWNSP STRING  'REWIND'
RPLCSP STRING  'REPLACE'
RPOSSP STRING  'RPOS'
RPADSP STRING  'RPAD'						[PLB31]
RSRTSP STRING  'RSORT'						[PLB31]
RTABSP STRING  'RTAB'
RTYPSP STRING  'RTNTYPE'
SETSP  STRING  'SET'						[PLB52]
SETXSP STRING  'SETEXIT'					[PLB97]
SCNTSP STRING  'SCONTINUE'					[PLB97]
SIZESP STRING  'SIZE'
SSTRSP STRING  'SUBSTR'						[PLB37]
SORTSP STRING  'SORT'						[PLB31]
SPANSP STRING  'SPAN'
STCTSP STRING  'STCOUNT'
STFCSP STRING  'STFCOUNT'
STLMSP STRING  'STLIMIT'
STPTSP STRING  'STOPTR'
STXTSP STRING  'STEXEC'						[PLB107]
STNOSP STRING  'STNO'
VARSP  STRING  'STRING'
SUCCSP STRING  'SUCCEED'
TABSP  STRING  'TAB'
TERMSP STRING  'TERMINAL'	   was PUNCH			[PLB36]
THAWSP STRING  'THAW'						[PLB34]
TIMSP  STRING  'TIME'
TRCESP STRING  'TRACE'
TRMSP  STRING  'TRIM'
UCNMSP STRING  'UCASE'						[PLB18]
UNLDSP STRING  'UNLOAD'
VEESP  STRING  'V'						[PLB115]
VALSP  STRING  'VALUE'
VDIFSP STRING  'VDIFFER'					[PLB78]
.IF BLOCKS
BLOKSP STRING  'BLOCK'
BLKSSP STRING  'BLOCKS'
BKGNSP STRING  'FILL'
NOBLSP STRING  'NOBLOCKS'
F1SP   STRING  'PRINT'
F2SP   STRING  'HOR'
F3SP   STRING  'VER'
F4SP   STRING  'FRONT'
F5SP   STRING  'BOX'
F6SP   STRING  'PAR'
F7SP   STRING  'SER'
F8SP   STRING  'OVY'
F9SP   STRING  'HOR_REG'
F10SP  STRING  'VER_REG'
F11SP  STRING  'NORM_REG'
F12SP  STRING  'IT'
F13SP  STRING  'REP'
F14SP  STRING  'DEF'
F15SP  STRING  'NODE'
F16SP  STRING  'MERGE'
F17SP  STRING  'HEIGHT'
F18SP  STRING  'WIDTH'
F19SP  STRING  'DEPTH'
F20SP  STRING  'BSIZE'
F21SP  STRING  'SLAB'
F22SP  STRING  'FIX'
F23SP  STRING  'BCHAR'				[PLB117]
F24SP  STRING  'DUP'
F25SP  STRING  'CC'
F26SP  STRING  'EJECT'
F27SP  STRING  'LRECL'
F28SP  STRING  'LOC'
.FI
*
CRDFSP STRING  '(80A1)'		   Default output format
OUTPSP STRING  '(1X,132A1)'	   Standard print format
*
*      Pointers to Other Initialization
*
ABNDB  LHERE   ,
       DESCR   ALPHSP,0,0	   &ALPHABET
       DESCR   ALPHVL,0,0
       DESCR   CRDFSP,0,0	   Default output format
       DESCR   DFLFST,0,0
       DESCR   EXDTSP,0,0	   'EXTERNAL'
       DESCR   EXTPTR,0,0
       DESCR   ENDSP,0,0	   'END'
       DESCR   ENDPTR,0,0
       DESCR   FRETSP,0,0	   'FRETURN'
       DESCR   FRETCL,0,0
       DESCR   FUNTSP,0,0	   'FUNCTION'
       DESCR   FUNTCL,0,0
       DESCR   LCASSP,0,0	   &LCASE			[PLB18]
       DESCR   LCASVL,0,0					[PLB18]
       DESCR   NRETSP,0,0	   'NRETURN'
       DESCR   NRETCL,0,0
       DESCR   RETSP,0,0	   'RETURN'
       DESCR   RETCL,0,0					[PLB18]
       DESCR   UCASSP,0,0	   &UCASE			[PLB18]
       DESCR   UCASVL,0,0					[PLB18]
       DESCR   DIGSSP,0,0	   &DIGITS			[PLB105]
       DESCR   DIGSVL,0,0	   				[PLB105]
       DESCR   ABORSP,0,0	   'ABORT'			[PLB97]
       DESCR   ABORCL,0,0					[PLB97]
       DESCR   CONTSP,0,0	   'CONTINUE'			[PLB97]
       DESCR   CONTCL,0,0					[PLB97]
       DESCR   SCNTSP,0,0	   'SCONTINUE'			[PLB97]
       DESCR   SCNTCL,0,0					[PLB97]
.IF BLOCKS
       DESCR   BLSP,0,0		   &FILL			[BLOCKS]
       DESCR   BKGNCL,0,0					[BLOCKS]
.FI
       DESCR   FSP,0,0		   'F'				[PLB115]
DTEND  DESCR   EFFCL,0,0					[PLB115][PLB124]
*
BUFEXT EQU     DTEND-ANYSP
BUFLEN EQU     BUFEXT*CPA
*
*      System Arrays
*
PRMTBL DESCR   PRMTBL,TTL+MARK,PRMSIZ
       DESCR   DTLIST,0,0	   Data type pair list
       DESCR   FNLIST,0,0	   Function pair list
       DESCR   FTABLE,0,0	   Procedure descriptor table
       DESCR   ICLBLK,0,0	   Miscellaneous data
       DESCR   KNLIST,0,0	   Unprotected keyword pair list
       DESCR   KVLIST,0,0	   Protected keyword pair list
       DESCR   OPTBL,0,0	   Operator procedure descriptors
STKHED DESCR   0,0,0		   Interpreter stack		[PLB85]
       DESCR   INLIST,0,0	   Input association pair list
       DESCR   OTLIST,0,0	   Output association pair list
       DESCR   INSATL,0,0	   Input block list
       DESCR   OTSATL,0,0	   Output block list
       DESCR   TFENPL,0,0	   Call trace pair list
       DESCR   TFEXPL,0,0	   Return trace pair list
       DESCR   TKEYPL,0,0	   Keyword trace pair list
       DESCR   TLABPL,0,0	   Label trace pair list
       DESCR   TRLIST,0,0	   Trace pair list
       DESCR   TVALPL,0,0	   Value trace pair list
PRMTRM LHERE   ,		   End of basic block list
PRMSIZ EQU     PRMTRM-PRMTBL-DESCR Size of basic block list
*
*      String Storage Bin List
*
OBLOCK DESCR   OBLOCK,TTL+MARK,OBARY*DESCR
       ARRAY   3		   Pseudo heading
OBSTRT ARRAY   OBSIZ		   Bin list
OBLIST EQU     OBSTRT-LNKFLD	   Pseudo link pointer
*
*      Pattern Matching History List
* now allocated in init.c					[PLB41]
*
*      SYSTEM  STACK
* interpreter now allocated in init.c				[PLB85]
*
*      Primitive Patterns
*
ABORPT DESCR   ABORPT,TTL+MARK,3*DESCR
       DESCR   ABORFN,FNC,2	   ABORT
       DESCR   0,0,0
       DESCR   0,0,0
*
ARBAK  DESCR   ARBAK,TTL+MARK,6*DESCR
       DESCR   ONARFN,FNC,2
       DESCR   3*DESCR,0,0
       DESCR   0,0,0
       DESCR   ONRFFN,FNC,2
       DESCR   0,0,0
       DESCR   0,0,0
*
ARBPT  DESCR   ARBPT,TTL+MARK,9*DESCR
       DESCR   SCOKFN,FNC,2	   ARB
       DESCR   0,0,3*DESCR
       DESCR   0,0,0
       DESCR   SCOKFN,FNC,2
       DESCR   6*DESCR,0,0
       DESCR   0,0,0
       DESCR   FARBFN,FNC,2
       DESCR   6*DESCR,0,0
       DESCR   0,0,0
*
ARHED  DESCR   ARHED,TTL+MARK,12*DESCR
       DESCR   SCOKFN,FNC,2
       DESCR   0,0,3*DESCR
       DESCR   0,0,0
       DESCR   SCOKFN,FNC,2
       DESCR   6*DESCR,0,0
       DESCR   0,0,0
       DESCR   ARBNFN,FNC,2
       DESCR   9*DESCR,0,12*DESCR
       DESCR   0,0,0
       DESCR   ARBFFN,FNC,2
       DESCR   0,0,0
       DESCR   0,0,0
*
ARTAL  DESCR   ARTAL,TTL+MARK,6*DESCR
       DESCR   EARBFN,FNC,2
       DESCR   0,0,3*DESCR
       DESCR   0,0,0
       DESCR   SCOKFN,FNC,2
       DESCR   6*DESCR,0,0
       DESCR   0,0,0
*
BALPT  DESCR   BALPT,TTL+MARK,9*DESCR
       DESCR   SCOKFN,FNC,2	   BAL
       DESCR   0,0,3*DESCR
       DESCR   0,0,0
       DESCR   BALFN,FNC,2
       DESCR   6*DESCR,0,0
       DESCR   0,0,0
       DESCR   BALFFN,FNC,2
       DESCR   6*DESCR,0,0
       DESCR   0,0,0
*
FAILPT DESCR   FAILPT,TTL+MARK,3*DESCR
       DESCR   SALFFN,FNC,2	   FAIL
       DESCR   0,0,0
       DESCR   0,0,0
*
FNCEPT DESCR   FNCEPT,TTL+MARK,3*DESCR
       DESCR   FNCEFN,FNC,2	   FENCE
       DESCR   0,0,0
       DESCR   0,0,0
*
REMPT  DESCR   REMPT,TTL+MARK,4*DESCR
       DESCR   RTBFN,FNC,3	   REM
       DESCR   0,0,0
       DESCR   0,0,0
       DESCR   0,0,I
*
STARPT DESCR   STARPT,TTL+MARK,11*DESCR
       DESCR   STARFN,FNC,3
       DESCR   0,0,4*DESCR
       DESCR   1,0,0
       DESCR   0,0,0
       DESCR   SCOKFN,FNC,2
       DESCR   7*DESCR,0,0
       DESCR   0,0,0
       DESCR   DSARFN,FNC,3
       DESCR   0,0,4*DESCR
       DESCR   0,0,0
       DESCR   0,0,0
*
SUCCPT DESCR   SUCCPT,TTL+MARK,3*DESCR
       DESCR   SUCFFN,FNC,2	   SUCCEED
       DESCR   0,0,0
       DESCR   0,0,0
*
TVALPL DESCR   TVALPL,TTL+MARK,2*DESCR
       DESCR   0,0,0		   VALUE trace
       DESCR   0,0,0
TLABPL DESCR   TLABPL,TTL+MARK,2*DESCR
       DESCR   0,0,0		   LABEL trace
       DESCR   0,0,0
TFENPL DESCR   TFENPL,TTL+MARK,2*DESCR
       DESCR   0,0,0		   CALL trace
       DESCR   0,0,0
TFEXPL DESCR   TFEXPL,TTL+MARK,2*DESCR
       DESCR   0,0,0		   RETURN trace
       DESCR   0,0,0
TKEYPL DESCR   TKEYPL,TTL+MARK,2*DESCR
       DESCR   0,0,0		   KEYWORD trace
       DESCR   0,0,0
*
VALBLK DESCR   VALBLK,TTL+MARK,6*DESCR
       DESCR   0,0,S		   STRING
       DESCR   0,0,0		   0 offset
       DESCR   0,0,N		   NAME
       DESCR   0,0,0		   0 offset
       DESCR   0,0,K		   KEYWORD (NAME)
       DESCR   0,0,0		   0 offset
*
*      Fatal Error Message Pointers
*
MSGLST DESCR   0,0,0
       DESCR   MSG1,0,0
       DESCR   MSG2,0,0
       DESCR   MSG3,0,0
       DESCR   MSG4,0,0
       DESCR   MSG5,0,0
       DESCR   MSG6,0,0
       DESCR   MSG7,0,0
       DESCR   MSG8,0,0
       DESCR   MSG9,0,0
       DESCR   MSG10,0,0
       DESCR   MSG11,0,0
       DESCR   MSG12,0,0
       DESCR   MSG13,0,0
       DESCR   MSG14,0,0
       DESCR   MSG15,0,0
       DESCR   MSG16,0,0
       DESCR   MSG17,0,0
       DESCR   MSG18,0,0
       DESCR   MSG19,0,0
       DESCR   MSG20,0,0
       DESCR   MSG21,0,0
       DESCR   MSG22,0,0
       DESCR   MSG23,0,0
       DESCR   MSG24,0,0
       DESCR   MSG25,0,0
       DESCR   MSG26,0,0
       DESCR   MSG27,0,0
       DESCR   MSG28,0,0
       DESCR   MSG29,0,0					[PLB38]
       DESCR   MSG30,0,0					[PLB38]
       DESCR   MSG31,0,0					[PLB38]
       DESCR   MSG32,0,0					[PLB38]
       DESCR   MSG33,0,0					[PLB60]
       DESCR   MSG34,0,0					[PLB97]
       DESCR   MSG35,0,0					[PLB97]
       DESCR   MSG36,0,0					[BLOCKS]
       DESCR   MSG37,0,0					[BLOCKS]
       DESCR   MSG38,0,0					[BLOCKS]
*
*      Fatal Error Messages
*
* [PLB11] made mixed case
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  'Erroneous INCLUDE statement'			[PLB38]
MSG30  STRING  'Cannot open INCLUDE file'			[PLB38]
MSG31  STRING  'Erroneous LINE statement'			[PLB38]
MSG32  STRING  'Missing END statement'				[PLB38]
MSG33  STRING  'Output error'					[PLB60]
MSG34  STRING  'User interrupt'					[PLB109]
MSG35  STRING  'Not in a SETEXIT handler'			[PLB97]
MSG36  STRING  'Error in BLOCKS'				[BLOCKS]
MSG37  STRING  'Too many warnings in BLOCKS'			[BLOCKS]
MSG38  STRING  'Mystery error in BLOCKS'			[BLOCKS]
*
*      Compiler Error Messages
*
* [PLB11] made mixed case
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'
*
*      Formats
*
* [PLB10] converted to printf() style formats
* [PLB38] use %D/%F for stats, added file:line
ALOCFL FORMAT  'Insufficient storage for initialization\n'	E3.10.6
ARTHNO FORMAT  '%D Arithmetic operations performed\n'
CMTIME FORMAT  '%F ms. Compilation time\n'			[PLB71]
EJECTF FORMAT  '\f'
ERRCF  FORMAT  'ERRORS DETECTED IN SOURCE PROGRAM\n\n'
EXNO   FORMAT  '%D Statements executed, %d failed\n'
FTLCF  FORMAT  '%v:%d: Error %d in statement %d at level %d\n'
*								E3.4.1
GCFMT  FORMAT  '%v:%d: GC %g ms %d free\n'			[PLB92]
INCGCF FORMAT  'INCOMPLETE STORAGE REGENERATION.\n'
INTIME FORMAT  '%F ms. Execution time\n'			[PLB71]
KSTSF  FORMAT  '%F Thousand statements per second\n'		[PLB103]
LASTSF FORMAT  '%v:%d: Last statement executed was %d\n'
NODMPF FORMAT  'TERMINAL DUMP NOT POSSIBLE.\n'
NRMEND FORMAT  'Normal termination at level %d\n'
NVARF  FORMAT  'Natural variables\n\n'
PKEYF  FORMAT  '\nUnprotected keywords\n\n'
PRTOVF FORMAT  '***PRINT REQUEST TOO LONG***\n'
READNO FORMAT  '%D Reads performed\n'
SCANNO FORMAT  '%D Pattern matches performed\n'
SOURCF FORMAT  '    Bell Telephone Laboratories, Incorporated\n\n'
STATHD FORMAT  'SNOBOL4 statistics summary-\n'
STDMP  FORMAT  '\fDump of variables at termination\n\n'
STGENO FORMAT  '%D Regenerations of dynamic storage\n'
STGETM FORMAT  '%F ms. Execution time in GC\n'			[PLB92]
SUCCF  FORMAT  'No errors detected in source program\n\n'
SYSCMT FORMAT  '%v:%d: Caught signal %d in statement %d at level %d\n'
*								E3.4.1[PLB47]
TIMEPS FORMAT  '%F ns. Average per statement executed\n' [PLB71][PLB72][PLB107]
TITLEF FORMAT  'SNOBOL4 (Version 3.11, May 19, 1975)\n'
*								V3.11
.IF BLOCKS
TITLEF1 FORMAT  'BLOCKS (Version 1.10, April 1, 1973)\n'	[BLOCKS]
.FI
WRITNO FORMAT  '%D Writes performed\n'
*
*      Real constants
RZERCL REAL	0.0			Zero			[PLB104]
R1MCL  REAL	1.0e6			1e6			[PLB107]
       END