Trailing-Edge
-
PDP-10 Archives
-
SRI_NIC_PERM_SRC_1_19910112
-
6-exec/execpc.b36
There are 2 other files named execpc.b36 in the archive. Click here to see a list.
!<5.1.EXEC>EXECPC.B36.6, 7-Nov-83 18:48:57, Edit by ALMQUIST
!Detect overly large integer constants
!<5.1.EXEC>EXECPC.B36.5, 15-Nov-82 02:32:37, Edit by PA0B
!Allow DISPLAY integer-expression, Add OUTRANGE to CASE,
!Make the square brackets around CASE and SELECT labels
!optional (the "approved" syntax is to omit them, but the
!compiler allows them), Make complex PARSE really look like
!CASE or SELECT by making the "approved" syntax be
! PARSE BEGIN parse-items END ;
!instead of
! PARSE ( parse-items ) ;
!except that I didn't hack in the optional square bracket
!stuff...
!<5.1.EXEC>EXECPC.B36.4, 13-Nov-82 14:04:06, Edit by PA0B
!Make WILD behave more as documented if paired with PARSEONLY
!(if PARSEONLY is specified, WILD doesn't cause GJ%IFG to
!be set), Allow DISPLAY'ing of integers
!<5.1.EXEC>EXECPC.B36.3, 2-Nov-82 07:47:22, Edit by PA0B
!Allow DCM ... TO system-variable, disallow DCM ... TO foo + bar
!Make sure values from WORDS are halfword values so they can
!go in the right half of TBLUK% entries
!<5.1.EXEC>EXECPC.B36.2, 30-Oct-82 15:58:43, Edit by PA0B
!Don't get confused in CERROR if line contained "%"'s
!<4.EXEC>EXECPC.B36.123, 23-Jun-81 12:46:36, Edit by DK32
!Handle stray semicolon after Otherwise field, Make DCm
!and PasO synonyms for DoCommand and PassOutput
!<4.EXEC>EXECPC.B36.122, 21-May-81 10:36:49, Edit by DK32
!Prohibit two Files in one Parse
!<4.EXEC>EXECPC.B36.121, 17-Apr-81 22:49:01, Edit by DK32
!Allow longer erroneous lines
!<4.EXEC>EXECPC.B36.120, 8-Apr-81 15:03:18, Edit by DK32
!Protect against impossibly long source lines, Allow
!negative keyword values, Fix parenthesized expressions
!<4.EXEC>EXECPC.B36.119, 24-Mar-81 20:41:41, Edit by DK32
!<4.EXEC>EXECPC.B36.118, 11-Mar-81 15:49:52, Edit by DK32
!Allow Parses with command arguments
!<4.EXEC>EXECPC.B36.117, 25-Feb-81 21:52:16, Edit by DK32
!Prompt, Convert underscores in synonym names, Some
!changes for Bliss 2.1, Redo global symbol replacement,
!PassOutput
!<4.EXEC>EXECPC.B36.116, 22-Jan-81 19:36:11, Edit by DK32
!Recognize EOF better
!<4.EXEC>EXECPC.B36.115, 12-Jan-81 21:40:30, Edit by DK32
!Allow 512-character quoted strings
!<4.EXEC>EXECPC.B36.114, 23-Dec-80 18:45:31, Edit by DK32
!Use Exec linkage, Clean out CM_SHR, Parse Invisible and
!Deleted, Fix Parse Wild+Parseonly
!<4.EXEC>EXECPC.B36.113, 15-Dec-80 22:37:56, Edit by DK32
!Larger constant work area
!<4.EXEC>EXECPC.B36.112, 9-Dec-80 00:20:28, Edit by DK32
!Allow overwrite of routines of different classes, Exit
!Save and ToProgram
!<4.EXEC>EXECPC.B36.111, 26-Nov-80 20:12:08, Edit by DK32
!Change an error message, Don't OR together generation
!numbers, Change some indenting, Allow for preserved
!commands
!<4.EXEC>EXECPC.B36.110, 25-Oct-80 23:00:53, Edit by DK32
!Handle bad identifier in declaration better, Handle File
!with Wild and Parseonly
!<4.EXEC>EXECPC.B36.109, 21-Oct-80 18:01:34, Edit by DK32
!Allow underscore in system names
!<4.EXEC>EXECPC.B36.108, 18-Oct-80 15:52:36, Edit by DK32
!Parse FileList, Default_Gen, Wild
!<4.EXEC>EXECPC.B36.107, 9-Oct-80 20:36:22, Edit by DK32
!Synonym and NoOriginal
!<4.EXEC>EXECPC.B36.106, 2-Oct-80 20:09:43, Edit by DK32
!Allow terminal semicolon in multiple-field Parse, Allow
!Else after short-form Parse, Add Parse NoIndirect and NoHelp,
!Fix writeable system variable
!<4.EXEC>EXECPC.B36.105, 25-Sep-80 15:07:58, Edit by DK32
!Allow commands to replace synonyms, Reset transparency
!before first scan, Correct diagnostic for type mismatch
!<4.EXEC>EXECPC.B36.104, 15-Sep-80 14:23:04, Edit by DK32
!Fix routine replacement, Fudge line number in CALL,
!Implement all two-character relationals
!<4.EXEC>EXECPC.B36.103, 10-Sep-80 16:04:00, Edit by DK32
!Add symbol definitions in source files, Long labels,
!Made Let optional, Add parenthesized expressions
!<4.EXEC>EXECPC.B36.102, 7-Sep-80 20:40:30, Edit by DK32
!Fix Parseonly of File fields, Allow numeric Words, Fix
!integer arithmetic, Forbid Parse chaining from Noise fields,
!More detail on missing labels, Prohibit declarations after
!first statement
!<4.EXEC>EXECPC.B36.101, 20-Aug-80 17:23:17, Edit by DK32
!Larger constant pool, Better scan status save, Allow for
!256-character strings
!<DK32.CG>EXECPC.B36.100, 8-Aug-80 17:41:05, Edit by DK32
!Don't say "Name not found" for a type mismatch, Point
!to correct atom for unrecognized keyword, Allow 100 keywords
!<DK32.CG>EXECPC.B36.99, 31-Jul-80 18:52:48, Edit by DK32
!Change GETTYPOUT and CLEARTYPOUT to GETTYPEOUT and CLEARTYPEOUT,
!Parse command names transparently
!<DK32.CG>EXECPC.B36.98, 18-Jul-80 13:40:11, Edit by DK32
!Fix quoted strings to not include following character, Change TAD to Daytime
!<DK32.CG>EXECPC.B36.97, 17-Jul-80 14:29:40, Edit by DK32
!Two doublequotes in a quoted string just generate a doublequote
!<DK32.CG>EXECPC.B36.96, 2-Jul-80 14:51:39, Edit by DK32
!A form feed is as good as a line feed, Tell CERROR about tabs,
!Add Substring[Start:*]
MODULE EXECPC =
BEGIN
!++
!
! This is the first attempt at the Programmable Command Language compiler
!
! Dave King, Carnegie-Mellon University Computation Cenetr
!
! January, 1980
!
! Copyright (C) 1980, Carnegie-Mellon University
!
!--
!
! Standard definitions
!
LIBRARY 'EXECPD';
LIBRARY 'BLI:TENDEF';
LIBRARY 'BLI:MONSYM';
SWITCHES LINKAGE(EXEC);
!
! Table of contents:
!
FORWARD ROUTINE
CERROR, ! Report compilation error
SCACHR, ! Return next character from input stream
SCAN, ! Get next atom
ADDSMB, ! Add current atom to symbol table
FNDSMB, ! Find current atom in symbol table
DEFLBL: NOVALUE, ! Define label
GENINS, ! Generate an instruction
GETCNS, ! Find or create constant
ASMPRC: NOVALUE, ! Assemble components of procedure
DEFPRC: NOVALUE, ! Define procedure in global symbol table
PCCCPL: NOVALUE, ! Main entry point to compiler
CPVARD: NOVALUE, ! Define a variable
CPSYND: NOVALUE, ! Define a synonym
CPCMPL: NOVALUE, ! Compile a routine
CPRTNC: NOVALUE, ! <Procedure-declaration>
CPFRML: NOVALUE, ! <Formal-parameter-list>
CPCARG: NOVALUE, ! Command arguments
CPBODY: NOVALUE, ! <Procedure-body>
CPDECL, ! <Declaration>
CPSTMT, ! <Statement>
CPASGN: NOVALUE, ! <Assignment-statement>
CPCNDI: NOVALUE, ! <Conditional-statement>
CPIFST, ! <If-statement>
CPGOTO: NOVALUE, ! <Goto-statement>
CPCASE: NOVALUE, ! <Case-statement>
CPLOOP: NOVALUE, ! <Do-statement>
CPSELE: NOVALUE, ! <Select-statement>
CPCOMS: NOVALUE, ! Common string statement
CPPFRM: NOVALUE, ! <DoCommand-statement>
CPGUID: NOVALUE, ! <Guide-statement
CPPMPT: NOVALUE, ! <Prompt-statement>
CPINVK: NOVALUE, ! <Invoke-statement>
CPPRSE: NOVALUE, ! <Parse-statement>
CPPRSI, ! <Parse-item>
CPPRSO: NOVALUE, ! <Parse-options>
CPPRSW, ! <Parse-option> Words
CPPRSF: NOVALUE, ! File parse options
CPTYIN: NOVALUE, ! Typein statement
CPDPLY: NOVALUE, ! Display statement
CPEXIT: NOVALUE, ! Exit statement
CPCALL: NOVALUE, ! <Call-statement>
CPACTL: NOVALUE, ! <Actual-parameter-list>
CPRETN: NOVALUE, ! <Return-statement>
CPIEXP, ! <Integer-expression>
CPSEXP, ! <String-expression>
CPLEXP, ! <Logical-expression>
CPITRM, ! <Integer-term>
CPIPRM, ! <Integer-primary>
CPSPRM, ! <String-primary>
CPCLSE; ! Classify expression
!
! Macros:
!
MACRO ERROR(TXT) = CERROR(UPLIT(%ASCIZ TXT)) %;
!
! External references:
!
EXTERNAL ROUTINE
PCMCER, ! Report compilation error
PCMITS, ! CVTBDO routine
PCMGMM, ! General memory allocator
PCIFGS, ! Find global symbol entry
PCICGS, ! Create global symbol entry
PCIDFV: NOVALUE, ! Define global variable
PCIDFS: NOVALUE, ! Define synonym
PCIUDF: NOVALUE, ! Undefine global object
GTBUFX; ! EXECSU Memory allocate
EXTERNAL
BUF0, ! Temporary work areas
PCTEXT: VECTOR, ! Pure text region
PCTXFR, ! Pure text free list
PCGBST: GST_TBL, ! Global symbol table
PSDEFN: SYN_TBL, ! System name table
DICT; ! Short term free space pool
EXTERNAL LITERAL
PSDEFL: UNSIGNED(6); ! Length of system name table
!
! Equated symbols:
!
LITERAL
CODWKL = 1024, ! Size of code work area
SYMWKL = 512, ! Size of symbol table work area
CNSWKL = 3072, ! Size of constant pool work area
CURSML = SYMWKL/STE_LEN; ! Maximum index into symbol table work area
BIND
CERM1 = UPLIT(%ASCIZ 'Constants work area full'),
CERM2 = UPLIT(%ASCIZ 'Field type missing in Parse, perhaps missing ")"'),
CERM3 = UPLIT(%ASCIZ 'Name invalid or missing'),
CERM4 = UPLIT(%ASCIZ 'Name not unique'),
CERM5 = UPLIT(%ASCIZ 'Unrecognized statement keyword'),
CERM6 = UPLIT(%ASCIZ 'Semicolon missing'),
CERM7 = UPLIT(%ASCIZ 'END not found where required'),
CERM8 = UPLIT(%ASCIZ 'Destination name missing'),
CERM9 = UPLIT(%ASCIZ 'Unable to recognize statement'),
CERM10 = UPLIT(%ASCIZ 'Too many labels'),
CERM11 = UPLIT(%ASCIZ 'Colon missing'),
CERM12 = UPLIT(%ASCIZ 'Statement missing'),
CERM13 = UPLIT(%ASCIZ 'Integer not found where required'),
CERM14 = UPLIT(%ASCIZ 'Right parenthesis missing'),
CERM15 = UPLIT(%ASCIZ 'Too many variables'),
CERM16 = UPLIT(%ASCIZ 'Left parenthesis missing'),
CERM17 = UPLIT(%ASCIZ 'Unexpected end of input'),
CERM18 = UPLIT(%ASCIZ 'Unable to recognize expression'),
CERM19 = UPLIT(%ASCIZ 'String missing'),
CERM20 = UPLIT(%ASCIZ 'OF missing'),
CERM21 = UPLIT(%ASCIZ 'BEGIN missing'),
CERM22 = UPLIT(%ASCIZ 'Superfluous right bracket'),
CERM23 = UPLIT(%ASCIZ 'Right bracket missing'),
CERM24 = UPLIT(%ASCIZ 'String not found where required'),
CODWRK = BUF0: COD_BLK, ! Code work area
SYMWRK = CODWRK+CODWKL: SYMENT, ! Symbol table work area
CNSWRK = SYMWRK+SYMWKL: VECTOR, ! Constant pool work area
CURRTN = CNSWRK+CNSWKL: VECTOR, ! Name of routine being compiled
CURNML = CURRTN+8, ! Length of the above
CURCLS = CURNML+1, ! Class of routine being compiled
CURTYP = CURCLS+1, ! Type of function
CURTXT = CURTYP+1, ! Text address of routine
PRCARG = CURTXT+1: VECTOR, ! Formal arguments to procedure
CMDARG = PRCARG+MAXPRM, ! Constant index of command argument list
! -2 if Parse instead, -1 if neither
NEXTIN = CMDARG+1, ! Relative address of next instruction
SCAPTR = NEXTIN+1, ! Source pointer
SCALIN = SCAPTR+1, ! Source line counter
LLNPTR = SCALIN+1, ! Pointer to first character of last line
SCATRP = LLNPTR+1, ! Nonzero to scan transparently
SCABUF = SCATRP+1: VECTOR, ! Line buffer
SCATOM = SCABUF+25: VECTOR, ! Atom buffer
SCALEN = SCATOM+103, ! Length of atom
SCANUM = SCALEN+1, ! Numeric atom
SCACOD = SCANUM+1, ! Scan code of current atom
NUMVRS = SCACOD+1, ! Number of variables declared in routine
CONSTP = NUMVRS+1, ! Next available constant pool entry
SYMTBP = CONSTP+1, ! Next available symbol table index
LBLNAM = SYMTBP+1: VECTOR, ! Pointers to label names
LBLADR = LBLNAM+MAXLBL: VECTOR, ! Label locations
LBLCNT = LBLADR+MAXLBL; ! Number defined
GLOBAL
PCCWKE: INITIAL (LBLCNT); ! Last location used by compiler
!
! Reserved name table
!
FIELD RSNFLD =
SET
RSNSTR = [0,0,18,0], ! Address of string
RSNLEN = [0,18,9,0], ! Length of string
RSNSCN = [0,27,9,0] ! Corresponding scanner code
TES;
MACRO RESNAM(NAM) =
%NAME('SCN_',NAM)^27 + %CHARCOUNT(%STRING(NAM))^18 + UPLIT(%STRING(NAM)) %;
BIND
RSNTBL = PLIT
(
RESNAM(LSS),
RESNAM(LEQ),
RESNAM(NEQ),
RESNAM(EQL),
RESNAM(GTR),
RESNAM(GEQ),
RESNAM(PROCEDURE),
RESNAM(COMMAND),
RESNAM(SYNONYM),
RESNAM(NOORIGINAL),
RESNAM(BEGIN),
RESNAM(END),
RESNAM(EXTERNAL),
RESNAM(INTEGER),
RESNAM(STRING),
RESNAM(LET),
RESNAM(IF),
RESNAM(THEN),
RESNAM(ELSE),
RESNAM(GOTO),
RESNAM(RETURN),
RESNAM(CASE),
RESNAM(FROM),
RESNAM(TO),
RESNAM(OF),
RESNAM(INRANGE),
RESNAM(OUTRANGE),
RESNAM(DO),
RESNAM(WHILE),
RESNAM(UNTIL),
RESNAM(SELECT),
RESNAM(DOCOMMAND),
RESNAM(ORIGINAL),
RESNAM(GUIDE),
RESNAM(PARSE),
RESNAM(OTHERWISE),
RESNAM(NOINDIRECT),
RESNAM(DEFAULT),
RESNAM(HELP),
RESNAM(NOHELP),
RESNAM(WORDS),
RESNAM(RADIX),
RESNAM(PARSEONLY),
RESNAM(STDHELP),
RESNAM(TIME),
RESNAM(DATE),
RESNAM(DEFAULT_DEV),
RESNAM(DEFAULT_DIR),
RESNAM(DEFAULT_NAM),
RESNAM(DEFAULT_EXT),
RESNAM(DEFAULT_GEN),
RESNAM(INPUT),
RESNAM(OUTPUT),
RESNAM(WILD),
RESNAM(INVISIBLE),
RESNAM(DELETED),
SCN_ERROR^27 + 5^18 + UPLIT('ERROR'),
RESNAM(PROMPT),
RESNAM(NOECHO),
RESNAM(INVOKE),
RESNAM(PASSOUTPUT),
RESNAM(TYPEIN),
RESNAM(NORETURN),
RESNAM(GETTYPEOUT),
RESNAM(CLEARTYPEOUT),
RESNAM(KILLPROGRAM),
RESNAM(DISPLAY),
RESNAM(BINARY),
RESNAM(EXIT),
RESNAM(SAVE),
RESNAM(TOPROGRAM),
RESNAM(ABORT),
RESNAM(NOP),
RESNAM(CALL),
SCN_DOCOMMAND^27 + 3^18 + UPLIT('DCM'),
SCN_PASSOUTPUT^27 + 4^18 + UPLIT('PASO')
): BLOCKVECTOR[1,1] FIELD(RSNFLD);
LITERAL
RSNCNT=77;
!
! Special characters
!
BIND RESCHR=UPLIT (
%C'+',SCN_PLUS, %C'-',SCN_MINUS, %C'*',SCN_TIMES, %C'/',SCN_DIV,
%C'=',SCN_EQL, %C'(',SCN_LPAREN, %C')',SCN_RPAREN, %C';',SCN_SEMI,
%C':',SCN_COLON,%C',',SCN_COMMA, %C'<',SCN_LSS, %C'>',SCN_GTR,
%C'[',SCN_LBRKT,%C']',SCN_RBRKT, %C'"',0) : VECTOR;
LITERAL
RSCCNT=15;
!
! Field type names for Parse
!
MACRO FNMDEF(NAM,VAL) =
%NAME('$CM',VAL)^27 + %CHARCOUNT(%STRING(NAM))^18 + UPLIT(%STRING(NAM)) %;
BIND
FNMTBL = PLIT
(
FNMDEF(KEYWORD,KEY),
FNMDEF(NUMBER,NUM),
FNMDEF(NOISE,NOI),
FNMDEF(SWITCH,SWI),
FNMDEF(INPUTFILE,IFI),
FNMDEF(OUTPUTFILE,OFI),
FNMDEF(FILE,FIL),
$CMFLD^27 + 5^18 + UPLIT('FIELD'),
! FNMDEF(FIELD,FLD), doesn't work
FNMDEF(EOL,CFM),
FNMDEF(DIRECTORY,DIR),
FNMDEF(USERNAME,USR),
FNMDEF(COMMA,CMA),
FNMDEF(DEVICE,DEV),
FNMDEF(TEXT,TXT),
FNMDEF(DAYTIME,TAD),
FNMDEF(QUOTEDSTRING,QST),
FNMDEF(TOKEN,TOK),
FNMDEF(NODE,NOD),
FNMDEF(FILELIST,FLS)
): BLOCKVECTOR[1,1] FIELD(RSNFLD);
LITERAL
FNMCNT=19;
ROUTINE CERROR(MSG,PAR1) = ! Report compilation error
!++
! Functional description:
! Issue error message, type out offending source line, and stop.
! The error message is provided as an ASCIZ string; anywhere a
! #n appears the n'th message parameter is inserted.
!
! Formal parameters:
! Address of error message string
! Address of parameter string #1
!
! Implicit inputs:
! LLNPTR, SCALIN
!
! Implicit outputs:
! SCATOM
!
! Routine value:
! Really, none; does not return. I wish I could convince BLISS of that.
!
! Side effects:
! None
!
!--
%( Presently only works with one insert )%
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
IPT, ! String pointers
OPT,
POS, ! Horizontal position on line
INSRT, ! Insertion pointer
CT, ! Character count
CHR;
IPT = CH$PTR(UPLIT (%ASCIZ 'Line '));
OPT = CH$PTR(SCATOM);
WHILE (CHR = CH$RCHAR_A(IPT)) NEQ 0 DO CH$WCHAR_A(.CHR,OPT);
OPT = PCMITS(.SCALIN,.OPT);
CH$WCHAR_A(%C':', OPT);
CH$WCHAR_A(%C' ', OPT);
IPT = BYTPTR(.MSG);
WHILE
(CHR = CH$RCHAR_A(IPT)) NEQ 0
DO
IF .CHR EQL %C'#'
THEN
BEGIN
CH$RCHAR_A(IPT); ! Skip the 1 which must follow
INSRT = BYTPTR(.PAR1);
WHILE (CHR = CH$RCHAR_A(INSRT)) NEQ 0 DO CH$WCHAR_A(.CHR,OPT)
END
ELSE
CH$WCHAR_A(.CHR,OPT);
IPT = .LLNPTR;
IF .IPT NEQ 0
THEN
BEGIN
CH$WCHAR_A(%C'%',OPT);
CH$WCHAR_A(%C'_',OPT);
CH$WCHAR_A(%C'%',OPT);
CT = 256;
WHILE (CHR = CH$RCHAR_A(IPT)) NEQ $CHCRT AND .CT GTR 5
! DO (CH$WCHAR_A(.CHR,OPT); CT=.CT-1);
DO
IF (.CHR EQL %C'%') AND (.CT GTR 7)
THEN
BEGIN
CH$WCHAR_A(%C'%',OPT);
CH$WCHAR_A(%C'%',OPT);
CH$WCHAR_A(%C'%',OPT);
CT = .CT-3
END
ELSE IF (.CHR NEQ %C'%')
THEN
BEGIN
CH$WCHAR_A(.CHR,OPT);
CT=.CT-1
END
ELSE
EXITLOOP;
CH$WCHAR_A(%C'%',OPT);
CH$WCHAR_A(%C'_',OPT);
CT = .CT - 2;
IPT = .LLNPTR;
POS = 0;
WHILE
(CHR = CH$RCHAR_A(IPT)) NEQ $CHCRT
DO
IF .IPT EQL .SCAPTR
THEN
EXITLOOP
ELSE
IF .CHR EQL $CHTAB
THEN
DO
(IF (CT=.CT-1) GTR 3 THEN CH$WCHAR_A(%C'.',OPT);
POS=.POS+1)
UNTIL
.POS MOD 8 EQL 0
ELSE
BEGIN
IF (CT=.CT-1) GTR 3 THEN CH$WCHAR_A(%C'.',OPT);
POS = .POS + 1
END;
IF (CT=.CT-1) GTR 1 THEN CH$WCHAR_A(%C'^',OPT)
END;
CH$WCHAR_A($CHNUL,OPT);
PCMCER(SCATOM)
END;
ROUTINE SCACHR = ! Return next character from input stream
!++
! Functional description:
! Returns next character from source input stream.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source pointer
!
! Implicit outputs:
! Last line-start pointer, line counter
!
! Routine value:
! ASCII character from source; a null indicates the end
!
! Side effects:
! None
!
!--
BEGIN
LOCAL
CHR;
CHR = CH$RCHAR_A(SCAPTR);
IF .CHR EQL $CHLFD OR .CHR EQL $CHFFD
THEN
BEGIN
SCALIN = .SCALIN + 1;
LLNPTR = .SCAPTR
END
ELSE
IF .CHR EQL $CHNUL THEN LLNPTR = 0;
.CHR
END;
ROUTINE SCAN = ! Get next atom
!++
! Functional description:
! Reads next atom from source file and converts it into scan code.
! Conversion may require resolution of reserved words and special
! symbols, and interpretation of numeric and string constants.
! Comments are skipped as they are read; alphabetic atoms are folded
! to upper case (outside quoted strings). Alphabetic atoms are
! returned transparently (i.e., not converted into reserved words)
! if the SCATRP flag is set. Returns scan code; end-of-file is
! represented by a particular scan code. If atom type requires it,
! atom is left in SCATOM, with length in SCALEN, or in SCANUM.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source characters, reserved character and word tables, SCATRP
!
! Implicit outputs:
! SCATOM, SCALEN, SCACOD, SCANUM
!
! Routine value:
! Scan code
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL CHR;
DO
BEGIN
CHR = SCACHR();
IF .CHR EQL %O'41'
THEN
DO CHR=SCACHR() UNTIL (.CHR EQL $CHLFD) OR (.CHR EQL $CHFFD)
OR (.CHR EQL 0)
END
WHILE
((.CHR EQL %C' ') OR (.CHR EQL $CHCRT) OR (.CHR EQL $CHLFD)
OR (.CHR EQL 9) OR (.CHR EQL $CHFFD));
IF .CHR LEQ 0 THEN RETURN (SCACOD=SCN_EOFILE);
IF .CHR GEQ %C'a' AND .CHR LEQ %C'z' THEN CHR = .CHR - %C'a'+%C'A';
SELECTONE .CHR OF
SET
[%C'A' TO %C'Z']:
BEGIN
! Scan an alphanumeric string of some sort, either a reserved
! word or a user identifier. Copy the string into the atom
! buffer, then look it up in the reserved word table and
! set the scan code appropriately.
LOCAL
PTR, ! String pointer
LEN, ! String length
PTRI, ! More pointers
PTRO;
PTR = CH$PTR(SCATOM);
SCATOM[0] = 0;
LEN=0;
DO
BEGIN
LEN=.LEN+1;
IF .LEN GTR 40 THEN ERROR('Atom too long');
CH$WCHAR_A(.CHR,PTR);
CHR = SCACHR();
IF .CHR GEQ %C'a' AND .CHR LEQ %C'z' THEN CHR = .CHR - %C'a'+%C'A'
END
WHILE
(.CHR GEQ %C'A' AND .CHR LEQ %C'Z') OR
(.CHR GEQ %C'0' AND .CHR LEQ %C'9') OR .CHR EQL %C'_';
CH$WCHAR_A($CHNUL,PTR);
SCACOD = SCN_IDENT;
SCALEN = .LEN;
IF .SCATRP EQL 0
THEN
(DECR PTR FROM RSNCNT-1 DO
IF .LEN EQL .RSNTBL[.PTR,RSNLEN]
THEN
IF CH$EQL(.LEN,CH$PTR(SCATOM),
.LEN,BYTPTR(.RSNTBL[.PTR,RSNSTR]))
THEN
(SCACOD = .RSNTBL[.PTR,RSNSCN]; EXITLOOP);
0)
END;
[%C'0' TO %C'9']:
BEGIN
! Scan a decimal number, store in atom buffer.
LOCAL NUM;
NUM=0;
DO
BEGIN
IF .NUM GEQ (%O'377777777777'/10) - ((.CHR-%C'0')/10)
THEN
ERROR('Number too large');
NUM=.NUM*10+.CHR-%C'0';
CHR=SCACHR()
END
WHILE
.CHR GEQ %C'0' AND .CHR LEQ %C'9';
SCANUM = .NUM;
SCACOD = SCN_NUMB
END;
[%C'$']:
BEGIN
! Scan a system identifier, store in atom buffer
LOCAL
PTR, ! Pointer to atom buffer
LEN; ! Name length
PTR = CH$PTR(SCATOM);
SCATOM[0] = 0;
LEN = 0;
DO
BEGIN
CHR = SCACHR();
IF .CHR GEQ %C'a' AND .CHR LEQ %C'z' THEN CHR=.CHR-%C'a'+%C'A';
IF (.CHR GEQ %C'A' AND .CHR LEQ %C'Z') OR .CHR EQL %C'_'
THEN
BEGIN
CH$WCHAR_A(.CHR,PTR);
LEN = .LEN + 1
END
END
WHILE
(.CHR GEQ %C'A' AND .CHR LEQ %C'Z') OR .CHR EQL %C'_';
PTR =
(DECR I FROM PSDEFL-1 DO
IF .PSDEFN[.I,SYN_NML] EQL .LEN THEN
IF CH$EQL( .LEN,CH$PTR(SCATOM),
.LEN,BYTPTR(.PSDEFN[.I,SYN_NAM]))
THEN
EXITLOOP .I);
IF .PTR LSS 0 THEN ERROR('No such system name');
SCATOM = .PTR;
SCACOD = SCN_SYSNAME
END;
[OTHERWISE]:
BEGIN
! Scan a special character
SCACOD =
(DECR I FROM RSCCNT-1 DO
IF .CHR EQL .RESCHR[.I*2]
THEN
EXITLOOP .RESCHR[.I*2+1]);
IF .SCACOD LSS 0 THEN ERROR('Illegal character');
IF .CHR EQL %C'"'
THEN
BEGIN
! Quoted string
LOCAL
LEN,
PTRO;
PTRO = CH$PTR(SCATOM);
LEN=0;
WHILE
1
DO
BEGIN
CHR = SCACHR();
IF .CHR EQL %C'"'
THEN
BEGIN
CHR = SCACHR();
IF .CHR NEQ %C'"' THEN EXITLOOP
END;
LEN = .LEN + 1;
IF .LEN GTR 512 THEN ERROR('String over 512 characters');
CH$WCHAR_A(.CHR,PTRO)
END;
CH$WCHAR_A($CHNUL,PTRO);
SCACOD = SCN_QSTRING;
SCALEN = .LEN
END
ELSE
IF .CHR EQL %C'<'
THEN
BEGIN
CHR = SCACHR();
IF .CHR EQL %C'>'
THEN
BEGIN
SCACOD = SCN_NEQ;
SCACHR()
END
ELSE
IF .CHR EQL %C'='
THEN
BEGIN
SCACOD = SCN_LEQ;
SCACHR()
END
END
ELSE
IF .CHR EQL %C'>'
THEN
BEGIN
IF SCACHR() EQL %C'='
THEN
BEGIN
SCACOD = SCN_GEQ;
SCACHR()
END
END
ELSE
SCACHR()
END;
TES;
SCAPTR = CH$PLUS(.SCAPTR, -1);
.SCACOD
END;
ROUTINE ADDSMB = ! Add current atom to symbol table
!++
! Functional description:
! Define the current atom as a new entry in the symbol table,
! and return the index of the new entry. Entry must be unique;
! duplicate names return -1. Fills in only the name, so the
! caller must fill in everything else as he sees fit.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Current atom
!
! Implicit outputs:
! Symbol table, constants (to store identifier name)
!
! Routine value:
! Index of new symbol table entry, or -1 if not unique
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
CHR, ! Character
SYMP, ! Symbol table index
CP; ! Constant table index
LABEL
F;
DECR I FROM .SYMTBP-1 DO
IF .SCALEN EQL .SYMWRK[.I,STE_NML] THEN
IF CH$EQL( .SCALEN,CH$PTR(SCATOM),
.SCALEN,BYTPTR(CNSWRK[.SYMWRK[.I,STE_NMA]]))
THEN
RETURN -1;
SYMP = .SYMTBP;
SYMTBP = .SYMTBP+1;
IF .SYMTBP GTR CURSML THEN ERROR('Compiler symbol table full');
SYMWRK[.SYMP,STE_VLD] = STE_VLD_NUM;
CP =
F: BEGIN
LOCAL VAL;
DECR I FROM .CONSTP-1 DO
IF CH$EQL(.SCALEN+1,CH$PTR(SCATOM),.SCALEN+1,BYTPTR(CNSWRK[.I]))
THEN
LEAVE F WITH .I;
IF .CONSTP + (.SCALEN+5)/5 GTR CNSWKL
THEN
CERROR(CERM1);
CH$COPY(.SCALEN,CH$PTR(SCATOM),0,.SCALEN+1,BYTPTR(CNSWRK[.CONSTP]));
VAL = .CONSTP;
CONSTP = .CONSTP + (.SCALEN+5)/5;
.VAL
END;
SYMWRK[.SYMP,STE_NML] = .SCALEN;
SYMWRK[.SYMP,STE_NMA] = .CP;
.SYMP
END;
ROUTINE FNDSMB(CLASS,TYPE) = ! Find current atom in symbol table
!++
! Functional description:
! Search symbol table for entry with the same name as the current
! atom, and the same class, and data type if a variable or function.
!
! Formal parameters:
! Class of symbol (STE_CLS), -1 if unimportant
! Type of variable or function (STE_TYP), -1 if unimportant
!
! Implicit inputs:
! Symbol table, current atom
!
! Implicit outputs:
! None
!
! Routine value:
! Symbol table index of entry,
! -1 if name not found,
! -2 if name found but of wrong class or type
!
! Side effects:
! None
!
!--
DECR I FROM .SYMTBP-1 DO
IF .SYMWRK[.I,STE_NML] EQL .SCALEN THEN
IF CH$EQL( .SCALEN,CH$PTR(SCATOM),
.SCALEN,BYTPTR(CNSWRK[.SYMWRK[.I,STE_NMA]]))
THEN
BEGIN
IF .CLASS GEQ 0 AND .SYMWRK[.I,STE_CLS] NEQ .CLASS
THEN
RETURN -2;
IF .SYMWRK[.I,STE_CLS] NEQ STE_CLS_PRC
THEN
IF .TYPE GEQ 0 AND .SYMWRK[.I,STE_TYP] NEQ .TYPE
THEN
RETURN -2;
RETURN .I
END;
ROUTINE DEFLBL: NOVALUE = ! Define label
!++
! Functional description:
! Defines the current atom to be a label with a given code index,
! by locating or creating an entry in the label table.
! If the entry already exists with outstanding references,
! they are resolved.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Current atom
!
! Implicit outputs:
! Label table, code
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
LPTR; ! Label table index
LPTR =
(DECR I FROM .LBLCNT-1 DO
IF CH$EQL(.SCALEN+1, .LBLNAM[.I], .SCALEN+1, BYTPTR(SCATOM))
THEN
EXITLOOP .I);
IF .LPTR LSS 0
THEN
BEGIN
LBLNAM[.LBLCNT] = BYTPTR(PCMGMM((.SCALEN+5)/5, DICT));
CH$MOVE(.SCALEN+1, BYTPTR(SCATOM), .LBLNAM[.LBLCNT]);
LBLADR[.LBLCNT] = .NEXTIN;
LBLCNT = .LBLCNT + 1;
IF .LBLCNT GTR MAXLBL THEN CERROR(CERM10)
END
ELSE
IF .LBLADR[.LPTR] LSS 0
THEN
BEGIN
LOCAL
CPTR, ! Code pointers
NPTR,
HLFTMP: HLF_WRD;
CPTR = - .LBLADR[.LPTR];
WHILE
.CPTR GTR 0
DO
BEGIN
IF .CPTR LSS 2^17
THEN
BEGIN
NPTR = .CODWRK[.CPTR,COD_OPA];
CODWRK[.CPTR,COD_OPA] = .NEXTIN
END
ELSE
BEGIN
CPTR = .CPTR - 2^17;
HLFTMP = .CNSWRK[.CPTR];
NPTR = .HLFTMP[HLF_RGT];
HLFTMP[HLF_RGT] = .NEXTIN;
CNSWRK[.CPTR] = .HLFTMP
END;
CPTR = .NPTR
END;
LBLADR[.LPTR] = .NEXTIN
END
END;
ROUTINE GENINS(OPR,OPA,OPB,OPC) = ! Generate an instruction
!++
! Functional description:
! Add an instruction in the code work area, with the given
! operation code and operand descriptors, and the current
! source line number. Steps the next-instruction
! index by 1 or 2 depending on the operation code.
!
! Formal parameters:
! Operation code
! Three operand descriptors
!
! Implicit inputs:
! Next instruction index
!
! Implicit outputs:
! Code
!
! Routine value:
! Index of code location of instruction
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PTR, ! Code pointers
EPTR;
PTR = .NEXTIN;
IF .OPR LSS OPR_11W THEN EPTR = .PTR+2 ELSE EPTR = .PTR+1;
IF .EPTR GEQ CODWKL THEN ERROR('Code work area full');
CODWRK[.PTR,COD_VLD] = COD_VLD_NUM;
CODWRK[.PTR,COD_LNO] = .SCALIN;
CODWRK[.PTR,COD_OPR] = .OPR;
CODWRK[.PTR,COD_OPA] = .OPA;
IF .OPR LSS OPR_11W
THEN
(CODWRK[.PTR,COD_OPB] = .OPB;
CODWRK[.PTR,COD_OPC] = .OPC);
NEXTIN = .EPTR;
.PTR
END;
ROUTINE GETCNS(VALUE,TYPE)= ! Find/create constant
!++
! Functional description:
! Locates desired constant in constant pool work area, or
! creates it if not found. Returns constant table index.
!
! Formal parameters:
! Value of constant (integer number or real stringvalue)
! Type of constant (STE_TYP)
!
! Implicit inputs:
! None
!
! Implicit outputs:
! Constant pool
!
! Routine value:
! Index into constant pool
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
IF .TYPE EQL STE_TYP_INT
THEN
BEGIN
DECR I FROM .CONSTP-1 DO
IF .CNSWRK[.I] EQL .VALUE THEN RETURN .I;
IF .CONSTP GEQ CNSWKL THEN CERROR(CERM1);
CNSWRK[.CONSTP] = .VALUE;
CONSTP = .CONSTP + 1;
.CONSTP - 1
END
ELSE
BEGIN
MAP VALUE:STR_VAL;
LOCAL
LEN, ! String length
PTR, ! String pointer
SVAL: STR_VAL, ! String value of constant
CPTR; ! Constant table pointer
LABEL
FOUND;
LEN = .VALUE[STV_LEN];
PTR = BYTPTR(.VALUE[STV_ADR]);
CPTR =
FOUND: BEGIN
DECR I FROM .CONSTP-1 DO
IF CH$EQL(.LEN+1,.PTR,.LEN+1,CH$PTR(CNSWRK[.I]))
THEN
LEAVE FOUND WITH .I;
IF .CONSTP + (.LEN+5)/5 GTR CNSWKL
THEN
CERROR(CERM1);
CH$COPY(.LEN,.PTR,0,.LEN+1,CH$PTR(CNSWRK[.CONSTP]));
PTR = .CONSTP;
CONSTP = .CONSTP + (.LEN+5)/5;
.PTR
END;
SVAL[STV_ADR] = .CPTR;
SVAL[STV_LEN] = .LEN;
DECR I FROM .CONSTP-1 DO
IF .CNSWRK[.I] EQL .SVAL THEN RETURN .I;
IF .CONSTP GEQ CNSWKL THEN CERROR(CERM1);
CPTR = .CONSTP;
CNSWRK[.CPTR] = .SVAL;
CONSTP = .CPTR + 1;
.CPTR
END
END;
ROUTINE ASMPRC: NOVALUE = ! Assemble components
!++
! Functional description:
! Merge the parameter list, constant pool, and symbol table into
! the code work area, find the total length of the procedure text,
! allocate space for it in the text region, copy into the text region the
! procedure's text. Leaves assorted information around to be
! entered into global symbol table.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Code, arguments, constants, symbols
!
! Implicit outputs:
! Text area
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
MAP
SYMWRK: VECTOR; ! Simpler access
LOCAL
PTRI, ! Copy pointers
PTRO;
CURTXT = PCMGMM(.NEXTIN+.PRCARG[0]+.CONSTP+.SYMTBP*STE_LEN, PCTXFR);
IF .CURTXT LEQ 0 THEN ERROR('Out of text space');
PTRI = CODWRK;
PTRO = .CURTXT;
DECR I FROM .NEXTIN-1 DO
BEGIN
.PTRO = ..PTRI;
PTRI = .PTRI + 1;
PTRO = .PTRO + 1
END;
PTRI = PRCARG[1];
DECR I FROM .PRCARG[0]-1 DO
BEGIN
.PTRO = ..PTRI;
PTRI = .PTRI + 1;
PTRO = .PTRO + 1
END;
PTRI = CNSWRK;
DECR I FROM .CONSTP-1 DO
BEGIN
.PTRO = ..PTRI;
PTRI = .PTRI + 1;
PTRO = .PTRO + 1
END;
PTRI = SYMWRK;
DECR I FROM (.SYMTBP*STE_LEN)-1 DO
BEGIN
.PTRO = ..PTRI;
PTRI = .PTRI + 1;
PTRO = .PTRO + 1
END
END;
ROUTINE DEFPRC: NOVALUE = ! Define procedure
!++
! Functional description:
! Creates global symbol table entry for newly-compiled routine.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Key indices describing lengths of various objects
!
! Implicit outputs:
! Global symbol table
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
GS:BLOCK[GST_LEN] FIELD (GST_FLD); ! A global symbol entry
GS[GST_CLS] = .CURCLS;
IF .CURCLS EQL GST_CLS_CMD
THEN
GS[GST_CMA] = .CMDARG
ELSE
GS[GST_PCT] = .PRCARG[0];
IF .CURCLS EQL GST_CLS_FCN THEN GS[GST_TYP] = .CURTYP;
GS[GST_SLN] = .NUMVRS;
GS[GST_TXT] = .CURTXT;
GS[GST_COD] = .NEXTIN;
GS[GST_CNS] = .CONSTP;
GS[GST_SML] = .SYMTBP;
GS[GST_NML] = .CURNML;
GS[GST_NMA] = GTBUFX(((.CURNML+5)/5));
CH$COPY(.CURNML, CH$PTR(CURRTN), 0, .CURNML+1, BYTPTR(.GS[GST_NMA]));
PCICGS(GS)
END;
GLOBAL ROUTINE PCCCPL(CPLPTR): NOVALUE = ! Main routine
!++
! Functional description:
! Defines a sequence of commands, procedures, and global variables,
! from source string provided by caller.
!
! Formal parameters:
! Pointer to ASCIZ source string
!
! Implicit inputs:
! The source
!
! Implicit outputs:
! Text region, global symbol table, the three work areas
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
SCAPTR = .CPLPTR;
LLNPTR = .SCAPTR;
SCATRP = 0;
SCALIN = 1;
SCAN();
DO
BEGIN
SELECTONE .SCACOD OF
SET
[SCN_COMMAND]: CURCLS = GST_CLS_CMD;
[SCN_INTEGER,
SCN_STRING]: BEGIN
CURTYP =
(IF .SCACOD EQL SCN_INTEGER THEN GST_TYP_INT ELSE GST_TYP_STR);
IF SCAN() EQL SCN_PROCEDURE
THEN
CURCLS = GST_CLS_FCN
ELSE
IF .SCACOD EQL SCN_IDENT
THEN
CURCLS = GST_CLS_VAR
ELSE
ERROR('PROCEDURE or variable name missing')
END;
[SCN_PROCEDURE]:
CURCLS = GST_CLS_PRC;
[SCN_SYNONYM,
SCN_NOORIGINAL]:
BEGIN
CURCLS = GST_CLS_SYN;
CURTYP = (IF .SCACOD EQL SCN_SYNONYM THEN 0 ELSE 1)
END;
[OTHERWISE]: ERROR('Unable to recognize definition')
TES;
SELECTONE .CURCLS OF
SET
[GST_CLS_VAR]: CPVARD();
[GST_CLS_SYN]: CPSYND();
[OTHERWISE]: CPCMPL()
TES;
IF .SCACOD EQL SCN_SEMI THEN SCAN()
END
UNTIL
.SCACOD EQL SCN_EOFILE
END;
ROUTINE CPVARD: NOVALUE = ! Define a variable
!++
! Functional description:
! Defines a global variable.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source file, CURTYP
!
! Implicit outputs:
! Global symbol table
!
! Routine value:
! None
!
! Side effects:
! Scans past variable name
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
PCIDFV(.SCALEN^18 + SCATOM, (IF .CURTYP EQL GST_TYP_INT THEN 0 ELSE -1));
SCAN()
END;
ROUTINE CPSYND: NOVALUE = ! Define a synonym
!++
! Functional description:
! Defines a synonym or removed original command.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source file, CURTYP
!
! Implicit outputs:
! Global symbol table
!
! Routine value:
! None
!
! Side effects:
! Scans to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
NAME: VECTOR[8], ! Command name
NAMVAL: STR_VAL, ! Stringvalue of it
NAMLEN, ! Its length
PTRI, ! Character pointers
PTRO,
CHR;
SCATRP = -1;
IF SCAN() NEQ SCN_IDENT THEN ERROR('Command name not found');
PTRI = BYTPTR(SCATOM);
PTRO = BYTPTR(NAME);
DO
BEGIN
CHR = CH$RCHAR_A(PTRI);
IF .CHR GEQ %C'a' AND .CHR LEQ %C'z' THEN CHR = .CHR - %C'a' + %C'A';
IF .CHR EQL %C'_' THEN CHR = %C'-';
CH$WCHAR_A(.CHR,PTRO)
END
UNTIL
.CHR EQL $CHNUL;
NAMVAL[STV_ADR] = NAME;
NAMVAL[STV_LEN] = .SCALEN;
IF .CURTYP EQL 0
THEN
BEGIN
IF SCAN() NEQ SCN_IDENT THEN ERROR('Old command name missing');
PTRI = PTRO = BYTPTR(SCATOM);
DO
BEGIN
CHR = CH$RCHAR_A(PTRI);
IF .CHR EQL %C'_' THEN CHR = %C'-';
CH$WCHAR_A(.CHR,PTRO)
END
UNTIL
.CHR EQL $CHNUL
END;
SCATRP = 0;
PCIDFS(.NAMVAL, (IF .CURTYP EQL 0 THEN SCATOM ELSE 0));
SCAN()
END;
ROUTINE CPCMPL: NOVALUE = ! Define a routine
!++
! Functional description:
! Compiles a command or procedure into temporary work areas defined
! in EXECDE. It then merges the generated code, constants, and
! symbol table into the text region, and creates the global symbol
! entry for the routine.
!
! Formal parameters:
! None
!
! Implicit inputs:
! The source, CURCLS, CURTYP
!
! Implicit outputs:
! Text, global symbol table
!
! Routine value:
! None
!
! Side effects:
! Scans from routine name to after last atom of routine
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
GS: REF GST_BLK; ! GST entry
NEXTIN = 0;
SCATRP = 0;
CONSTP = 0;
SYMTBP = 0;
CURNML = 0;
PRCARG[0] = 0;
CMDARG = -1;
NUMVRS = 0;
LBLCNT = 0;
CPRTNC(); ! Compile the routine
GENINS(OPR_RET,0,0,0); ! Provide a free RET
ASMPRC(); ! Assemble the components into text region
DEFPRC() ! Define in global symbol table
END;
ROUTINE CPRTNC: NOVALUE = ! <Procedure-declaration>
!++
! Functional description:
! Compile one command, procedure or function. Find routine name, proces
! any formal parameter list, do routine body, do final label
! processing.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source, label table
!
! Implicit outputs:
! Routine name, class, type
!
! Routine value:
! None
!
! Side effects:
! Scans from routine name to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
SCATRP = -1;
IF SCAN() NEQ SCN_IDENT THEN CERROR(CERM3);
SCATRP = 0;
CURNML = .SCALEN;
CH$MOVE(.SCALEN, CH$PTR(SCATOM), CH$PTR(CURRTN));
IF .CURCLS EQL GST_CLS_CMD
THEN
BEGIN
LOCAL PTR,CHR;
PTR = CH$PTR(CURRTN);
DECR I FROM .SCALEN-1 DO
IF CH$RCHAR_A(PTR) EQL %C'_' THEN CH$WCHAR(%C'-',CH$PLUS(.PTR,-1));
END;
IF SCAN() EQL SCN_LPAREN
THEN
BEGIN
IF .CURCLS EQL GST_CLS_CMD THEN CPCARG() ELSE CPFRML();
IF .SCACOD NEQ SCN_RPAREN THEN CERROR(CERM6);
SCAN()
END;
IF .SCACOD NEQ SCN_SEMI THEN CERROR(CERM6);
SCAN();
CPBODY();
DECR I FROM .LBLCNT-1 DO
IF .LBLADR[.I] LSS 0
THEN
BEGIN
LOCAL
STR: STR_VAL;
STR = .LBLNAM[.I];
CERROR( UPLIT(%ASCIZ 'Label #1 left undefined'), .STR[STV_ADR])
END
END;
ROUTINE CPFRML: NOVALUE = ! <Formal-parameter-list>
!++
! Functional description:
! Called from <Procedure-declaration> to compile formal parameter
! list. Builds parameter list into PRCARG.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! PRCARG
!
! Routine value:
! None
!
! Side effects:
! Scans from ( to )
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
STE, ! Symbol table index of parameter
TYP; ! Type of parameter
DO
BEGIN
TYP = SCAN();
IF .TYP NEQ SCN_INTEGER AND .TYP NEQ SCN_STRING
THEN
ERROR('Type missing');
TYP = (IF .TYP EQL SCN_INTEGER THEN STE_TYP_INT ELSE STE_TYP_STR);
DO
BEGIN
IF SCAN() NEQ SCN_IDENT THEN CERROR(CERM3);
STE = ADDSMB();
IF .STE LSS 0 THEN CERROR(CERM4);
SYMWRK[.STE,STE_CLS] = STE_CLS_FML;
SYMWRK[.STE,STE_TYP] = .TYP;
IF .PRCARG[0] GEQ MAXPRM THEN ERROR('Too many parameters');
PRCARG[0] = .PRCARG[0] + 1;
PRCARG[.PRCARG[0]] = .STE
END
WHILE
SCAN() EQL SCN_COMMA;
END
WHILE
.SCACOD EQL SCN_SEMI;
DECR I FROM .PRCARG[0] TO 1 DO
BEGIN
STE = .PRCARG[.I];
SYMWRK[.STE,STE_LOC] = - .PRCARG[0] + .I - 1;
PRCARG[.I] = .SYMWRK[.STE,STE_TYP]
END
END;
ROUTINE CPCARG: NOVALUE = ! Command arguments
!++
! Functional description:
! Compile command arguments: Generate appropriate field descriptors
! in constants, containing descriptors of local symbols in which
! results should be stored. Declare each symbol used.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Constants
!
! Routine value:
! None
!
! Side effects:
! Scans from ( to )
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
FNC, ! Parse-type code
FDB, ! Constant index of current FLDDB
LFDB; ! Constant index of last FLDDB
LFDB = -1;
DO
BEGIN
SCAN();
! Identify the parse-type
FDB = CPPRSI(1,0);
IF .FDB LSS 0 THEN ERROR('OTHERWISE meaningless here');
! Link the new FLDDB to the preceding FLDDB
IF .LFDB GEQ 0
THEN
POINTR((CNSWRK[.LFDB+$CMFNP]),CM_LST) = .FDB
ELSE
CMDARG = .FDB;
LFDB = .FDB;
END
WHILE
.SCACOD EQL SCN_SEMI
END;
ROUTINE CPBODY: NOVALUE = !<Procedure-body>
!++
! Functional description:
! Called from <Procedure-declaration> to compile body of routine.
! This may be a block or just a statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! Scans from BEGIN to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
IF .SCACOD NEQ SCN_BEGIN
THEN
BEGIN
IF CPSTMT() EQL FALSE THEN CERROR(CERM9);
RETURN
END;
SCAN();
WHILE
CPDECL() NEQ FALSE
DO
(IF .SCACOD NEQ SCN_SEMI THEN CERROR(CERM6); SCAN());
WHILE
.SCACOD NEQ SCN_END AND CPSTMT() NEQ FALSE
DO
(IF .SCACOD NEQ SCN_SEMI AND .SCACOD NEQ SCN_END
THEN
ERROR('No semicolon or End after last statement');
IF .SCACOD EQL SCN_SEMI THEN SCAN());
IF .SCACOD NEQ SCN_END THEN CERROR(CERM7);
SCAN()
END;
ROUTINE CPDECL = ! <Declaration>
!++
! Functional description:
! Called from <Procedure-body> to process one declaration.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Symbol table
!
! Routine value:
! TRUE if declaration recognized, FALSE if not
!
! Side effects:
! Scans from <Simple-type> past last <Identifier>
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
STE, ! Symbol table index
CLS, ! Variable class
TYP; ! Variable type
IF .SCACOD NEQ SCN_EXTERNAL AND .SCACOD NEQ SCN_INTEGER
AND .SCACOD NEQ SCN_STRING THEN RETURN FALSE;
CLS = STE_CLS_VAR;
IF .SCACOD EQL SCN_EXTERNAL THEN (CLS = STE_CLS_GBL; SCAN());
IF .SCACOD EQL SCN_INTEGER OR .SCACOD EQL SCN_STRING
THEN
BEGIN
TYP = (IF .SCACOD EQL SCN_INTEGER THEN STE_TYP_INT ELSE STE_TYP_STR);
IF SCAN() EQL SCN_PROCEDURE
THEN
BEGIN
CLS = STE_CLS_FCN;
SCAN()
END
END
ELSE
IF .SCACOD EQL SCN_PROCEDURE
THEN
BEGIN
CLS = STE_CLS_PRC;
SCAN()
END
ELSE
ERROR('Type not found where required');
IF .SCACOD NEQ SCN_IDENT THEN CERROR(CERM3);
WHILE
.SCACOD EQL SCN_IDENT
DO
BEGIN
STE = ADDSMB();
IF .STE LSS 0 THEN CERROR(CERM4);
IF .NUMVRS GEQ MAXVRC THEN CERROR(CERM15);
SYMWRK[.STE,STE_CLS] = .CLS;
SYMWRK[.STE,STE_TYP] = .TYP;
IF .CLS EQL STE_CLS_VAR
THEN
BEGIN
SYMWRK[.STE,STE_LOC] = .NUMVRS + FRM_LOC;
NUMVRS = .NUMVRS + 1
END;
IF SCAN() NEQ SCN_COMMA THEN EXITLOOP;
SCAN()
END;
TRUE
END;
ROUTINE CPSTMT = ! <Statement>
!++
! Functional description:
! Called to process one statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code, Label table
!
! Routine value:
! TRUE if statement recognized, FALSE if not
!
! Side effects:
! Scans from potential statement keyword (or label) to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
WHILE
.SCACOD EQL SCN_IDENT OR .SCACOD EQL SCN_SYSNAME
DO
BEGIN
LOCAL
IDNLLN, ! Pointer to line with bad identifier
IDNPTR, ! Pointer to bad identifier
IDNCOD; ! Scan code of identifier
IDNLLN = .LLNPTR;
IDNPTR = .SCAPTR;
IDNCOD = .SCACOD;
SCAN();
IF .IDNCOD EQL SCN_IDENT AND .SCACOD EQL SCN_COLON
THEN
BEGIN
DEFLBL();
SCAN()
END
ELSE
IF .SCACOD EQL SCN_EQL
THEN
BEGIN
CPASGN(.IDNCOD);
RETURN TRUE
END
ELSE
BEGIN
LLNPTR = .IDNLLN;
SCAPTR = .IDNPTR;
CERROR(CERM5);
END
END;
SELECTONE .SCACOD OF
SET
[SCN_BEGIN]: BEGIN
SCAN();
WHILE
.SCACOD NEQ SCN_END AND CPSTMT() NEQ FALSE
DO
BEGIN
IF .SCACOD NEQ SCN_SEMI AND .SCACOD NEQ SCN_END
THEN
CERROR(CERM6);
IF .SCACOD EQL SCN_SEMI THEN SCAN()
END;
IF .SCACOD NEQ SCN_END
THEN
CERROR(CERM7);
SCAN()
END;
[SCN_LET]: CPASGN(-1);
[SCN_IF]: CPCNDI();
[SCN_GOTO]: CPGOTO();
[SCN_RETURN]: CPRETN();
[SCN_CASE]: CPCASE();
[SCN_DO,
SCN_WHILE,
SCN_UNTIL]: CPLOOP();
[SCN_SELECT]: CPSELE();
[SCN_DOCOMMAND]:CPPFRM();
[SCN_GUIDE]: CPGUID();
[SCN_PARSE]: CPPRSE();
[SCN_PROMPT]: CPPMPT();
[SCN_INVOKE]: CPINVK();
[SCN_TYPEIN]: CPTYIN();
[SCN_GETTYPEOUT]:CPCOMS(OPR_GTO,1);
[SCN_CLEARTYPEOUT]: (GENINS(OPR_GTO,-1,0,0); SCAN());
[SCN_KILLPROGRAM]: (GENINS(OPR_KIL,0,0,0); SCAN());
[SCN_DISPLAY]: CPDPLY();
[SCN_EXIT]: CPEXIT();
[SCN_ABORT]: CPCOMS(OPR_ABT,0);
[SCN_NOP]: (GENINS(OPR_NOP,0,0,0); SCAN());
[SCN_CALL]: CPCALL();
[SCN_END]: RETURN FALSE;
[SCN_EOFILE]: CERROR(CERM17);
[SCN_INTEGER,
SCN_STRING,
SCN_EXTERNAL]: ERROR('Declarations not permitted after first statement');
[OTHERWISE]: CERROR(CERM5)
TES;
TRUE
END;
ROUTINE CPASGN(SCN): NOVALUE = ! <Assignment-statement>
!++
! Functional description:
! Called from <Statement> to process an assignment statement.
!
! Formal parameters:
! Scan code of destination if already scanned and ready in SCATOM,
! -1 if it is yet to be scanned. If the scan code is provided,
! then the equals sign is the current atom.
!
! Implicit inputs:
! Source, symbol table
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from LET or destination identifier to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
DSTN, ! Destination designator
TYPE; ! Data type
IF .SCN LSS 0 THEN SCAN() ELSE SCACOD = .SCN;
IF .SCACOD EQL SCN_IDENT
THEN
BEGIN
DSTN = FNDSMB(-1,-1);
IF .DSTN LSS 0 THEN ERROR('Undefined variable');
IF .SYMWRK[.DSTN,STE_CLS] EQL STE_CLS_PRC
OR .SYMWRK[.DSTN,STE_CLS] EQL STE_CLS_FCN
THEN
ERROR('Cannot store into a procedure');
TYPE = .SYMWRK[.DSTN,STE_TYP]
END
ELSE
IF .SCACOD EQL SCN_SYSNAME
THEN
BEGIN
MAP DSTN: OPRAND;
IF .PSDEFN[.SCATOM,SYN_CLS] NEQ SYN_CLS_VAR
THEN
ERROR('Cannot store into routine');
IF NOT .PSDEFN[.SCATOM,SYN_WRT] THEN ERROR('Variable is readonly');
DSTN[OPN_ADR] = .SCATOM;
DSTN[OPN_CLS] = OPN_CLS_SYN;
TYPE = .PSDEFN[.SCATOM,SYN_TYP]
END
ELSE
CERROR(CERM8);
IF .SCN LSS 0 THEN IF SCAN() NEQ SCN_EQL THEN ERROR('Equal sign missing');
SCAN();
CASE .TYPE FROM STE_TYP_INT TO STE_TYP_STR OF
SET
[STE_TYP_INT]: CPIEXP(.DSTN);
[STE_TYP_STR]: CPSEXP(.DSTN);
TES
END;
ROUTINE CPCNDI: NOVALUE = ! <Conditional-statement>
!++
! Functional description:
! Called from <Statement> to process a conditional statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from IF to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
CNDADR, ! Location of Compare instruction
JMPADR; ! Location if Jump instruction before Else
SCAN();
CNDADR = CPIFST(); ! Emit Compare and true-statement
IF .SCACOD EQL SCN_ELSE
THEN
BEGIN
JMPADR = .NEXTIN;
GENINS(OPR_JMP,0,0,0);
CODWRK[.CNDADR,COD_OPA] = .NEXTIN;
SCAN();
IF CPSTMT() EQL FALSE THEN CERROR(CERM9);
CODWRK[.JMPADR,COD_OPA] = .NEXTIN
END
END;
ROUTINE CPIFST = ! <If-statement>
!++
! Functional description:
! Called from <Conditional-statement> to compile a simple IF
! statement, generating the appropriate Compare instruction
! and the true-statement, with the Compare branch address
! adjusted after the true-statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! Code index of Compare instruction
!
! Side effects:
! Scans from first atom of logical expression past last atom
! of true-expression
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
IFADDR; ! Location of Compare instruction
IFADDR = CPLEXP();
IF .SCACOD NEQ SCN_THEN THEN ERROR('THEN missing');
SCAN();
IF CPSTMT() EQL FALSE THEN CERROR(CERM9);
CODWRK[.IFADDR,COD_OPA] = .NEXTIN;
.IFADDR
END;
ROUTINE CPGOTO: NOVALUE = ! <Goto-statement>
!++
! Functional description:
! Called from <Statement> to process a Goto statement.
! Generates a Jump to the labelled location; if the label is not yet
! defined, the Jump address is placed in the labels table.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Code, label table
!
! Implicit outputs:
! Code, label table
!
! Routine value:
! None
!
! Side effects:
! Scans from GOTO to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL PTR;
IF SCAN() NEQ SCN_IDENT THEN CERROR(CERM3);
PTR =
(DECR I FROM .LBLCNT-1 DO
IF CH$EQL(.SCALEN+1, BYTPTR(SCATOM), .SCALEN+1, .LBLNAM[.I])
THEN
EXITLOOP .I);
IF .PTR LSS 0
THEN
BEGIN
IF .LBLCNT GEQ MAXLBL THEN CERROR(CERM10);
LBLNAM[.LBLCNT] = BYTPTR(PCMGMM((.SCALEN+5)/5, DICT));
CH$MOVE(.SCALEN+1, BYTPTR(SCATOM), .LBLNAM[.LBLCNT]);
LBLADR[.LBLCNT] = -.NEXTIN;
LBLCNT = .LBLCNT + 1;
PTR = 0
END
ELSE
IF .LBLADR[.PTR] LSS 0
THEN
BEGIN
LOCAL
EPTR;
EPTR = - .LBLADR[.PTR];
LBLADR[.PTR] = - .NEXTIN;
PTR = .EPTR
END
ELSE
PTR = .LBLADR[.PTR];
GENINS(OPR_JMP,.PTR,0,0);
SCAN()
END;
ROUTINE CPCASE: NOVALUE = ! <Case-statement>
!++
! Functional description:
! Called from <Statement> to compile a Case statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source atoms
!
! Implicit outputs:
! Code, constants
!
! Routine value:
! None
!
! Side effects:
! Scans from CASE to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OPN, ! Operand descriptor
IDX, ! Case index
LOC, ! Location of CAS-JMP sequence
LEN, ! Length of dispatch table
TBL, ! Constant index of dispatch table
BIAS, ! User's index to first word
BRKHAK; ! Hack flag to handle omission of ['s
SCAN();
OPN = CPIEXP(OPN_TMP_INT);
IF .OPN LSS 0 THEN ERROR('Index missing');
IF .SCACOD NEQ SCN_FROM THEN ERROR('FROM missing');
IF SCAN() NEQ SCN_NUMB THEN ERROR('Starting index missing');
BIAS = .SCANUM;
IF SCAN() NEQ SCN_TO THEN ERROR('TO missing');
IF SCAN() NEQ SCN_NUMB THEN ERROR('Ending index missing');
LEN = .SCANUM-.BIAS+1;
IF .LEN LEQ 0 THEN ERROR('Invalid range');
TBL = .CONSTP + 1;
CONSTP = .CONSTP + .LEN + 2;
IF .CONSTP GEQ CNSWKL THEN CERROR(CERM1);
CNSWRK[.TBL] = .LEN; ! Table[0] = length of jump vector
CNSWRK[.TBL-1] = -1; ! No OUTRANGE jump address yet
DECR I FROM .LEN DO CNSWRK[.TBL+.I+1] = -1;
LOC = GENINS(OPR_CAS,.OPN,.TBL,GETCNS(.BIAS,STE_TYP_INT));
GENINS(OPR_JMP,0,0,0);
IF SCAN() NEQ SCN_OF THEN CERROR(CERM20);
IF SCAN() NEQ SCN_BEGIN THEN CERROR(CERM21);
DO
BEGIN
IF SCAN() EQL SCN_END THEN EXITLOOP;
BRKHAK = 0; ! Assume no square brackets around labels
IF .SCACOD EQL SCN_LBRKT
THEN
BEGIN
BRKHAK = -1; ! We do have square brackets on this one
SCAN() ! Read next token (skip over bracket)
END;
IF .SCACOD EQL SCN_NUMB
THEN
BEGIN
IF .SCANUM LSS .BIAS OR .SCANUM GEQ .BIAS+.LEN
THEN
ERROR('Index out of range');
CNSWRK[.TBL+1+.SCANUM-.BIAS] = .NEXTIN;
END
ELSE
IF .SCACOD EQL SCN_INRANGE
THEN
DECR I FROM .LEN DO
IF .CNSWRK[.TBL+1+.I] EQL -1 THEN CNSWRK[.TBL+1+.I] = .NEXTIN;
IF .SCACOD EQL SCN_OUTRANGE
THEN
CNSWRK[.TBL-1] = .NEXTIN;
IF SCAN() EQL SCN_RBRKT
THEN
BEGIN
IF .BRKHAK NEQ 0
THEN
SCAN() ! Skip iff matching open bracket
ELSE
CERROR(CERM22)
END
ELSE
IF .BRKHAK NEQ 0 THEN CERROR(CERM23); ! Complain if unmatched open
IF .SCACOD NEQ SCN_COLON THEN CERROR(CERM11);
SCAN();
IF CPSTMT() EQL FALSE THEN CERROR(CERM12);
GENINS(OPR_JMP,.LOC+2,0,0)
END
UNTIL
.SCACOD NEQ SCN_SEMI;
IF .SCACOD NEQ SCN_END THEN CERROR(CERM7);
SCAN();
CODWRK[.LOC+2,COD_OPA] = .NEXTIN
END;
ROUTINE CPLOOP: NOVALUE = ! <Do-statement>
!++
! Functional description:
! Called from <Statement> to compile a DO statement. This may
! be a DO-WHILE, DO-UNTIL, WHILE-DO, or UNTIL-DO statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Current atom, source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from statement keyword to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
TOPADR, ! Location of top of loop
IFADDR; ! Location of compare instruction
CASE .SCACOD FROM SCN_DO TO SCN_UNTIL OF
SET
[SCN_DO]: BEGIN
LOCAL
SWITCH;
TOPADR = .NEXTIN;
SCAN();
IF CPSTMT() EQL FALSE THEN CERROR(CERM9);
IF .SCACOD EQL SCN_WHILE OR .SCACOD EQL SCN_UNTIL
THEN
SWITCH = .SCACOD
ELSE
ERROR('WHILE or UNTIL missing');
SCAN();
IFADDR = CPLEXP();
IF .SWITCH EQL SCN_WHILE
THEN
BEGIN
CODWRK[.IFADDR,COD_OPA] = .IFADDR + 3;
GENINS(OPR_JMP,.TOPADR,0,0)
END
ELSE
CODWRK[.IFADDR,COD_OPA] = .TOPADR
END;
[SCN_WHILE]:BEGIN
TOPADR = .NEXTIN;
SCAN();
IFADDR = CPLEXP();
IF .SCACOD NEQ SCN_DO THEN ERROR('DO missing after WHILE');
SCAN();
IF CPSTMT() EQL FALSE THEN CERROR(CERM9);
GENINS(OPR_JMP,.TOPADR,0,0);
CODWRK[.IFADDR,COD_OPA] = .NEXTIN
END;
[SCN_UNTIL]:BEGIN
TOPADR = .NEXTIN;
SCAN();
IFADDR = CPLEXP();
GENINS(OPR_JMP,0,0,0);
CODWRK[.IFADDR,COD_OPA] = .NEXTIN;
IF .SCACOD NEQ SCN_DO THEN ERROR('DO missing after UNTIL');
SCAN();
IF CPSTMT() EQL FALSE THEN CERROR(CERM9);
GENINS(OPR_JMP,.TOPADR,0,0);
CODWRK[.IFADDR+2,COD_OPA] = .NEXTIN
END
TES
END;
ROUTINE CPSELE: NOVALUE = ! <Select-statement>
!++
! Functional description:
! Called from <Statement> to compile a Select statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from Select to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
SDESC, ! Select-expression operand descriptor
TDESC, ! Test-expression operand descriptor
TESTADDR, ! Location of comparison instruction
EXITADDR, ! Location of last JMP instruction to exit
TYPE, ! Data type of test
OPR, ! Comparison operation code
BRKHAK; ! Hack flag to handle omission of ['s
SCAN();
TYPE = CPCLSE();
IF .TYPE LSS 0 THEN CERROR(CERM18);
IF .TYPE EQL STE_TYP_INT
THEN
BEGIN
SDESC = CPIEXP(OPN_TMP_INT);
OPR = OPR_BNE
END
ELSE
BEGIN
SDESC = CPSEXP(OPN_TMP_STR);
OPR = OPR_CNE
END;
IF .SCACOD NEQ SCN_OF THEN CERROR(CERM20);
IF SCAN() NEQ SCN_BEGIN THEN CERROR(CERM21);
EXITADDR = %O'777777';
DO
BEGIN
IF SCAN() EQL SCN_END THEN EXITLOOP;
BRKHAK = 0; ! Assume no square brackets around labels
IF .SCACOD EQL SCN_LBRKT
THEN
BEGIN
BRKHAK = -1; ! We do have square brackets on this one
SCAN() ! Read next token (skip over bracket)
END;
IF .SCACOD EQL SCN_OTHERWISE
THEN
BEGIN
SCAN();
TESTADDR = -1
END
ELSE
BEGIN
IF .SDESC EQL OPN_TMP_INT OR .SDESC EQL OPN_TMP_STR
THEN
GENINS(OPR_PSH,.SDESC,0,0);
IF .TYPE EQL STE_TYP_INT
THEN
TDESC = CPIEXP(OPN_TMP_INT)
ELSE
TDESC = CPSEXP(OPN_TMP_STR);
TESTADDR = .NEXTIN;
GENINS(.OPR,0,.SDESC,.TDESC)
END;
IF .SCACOD EQL SCN_RBRKT
THEN
BEGIN
IF .BRKHAK NEQ 0
THEN
SCAN() ! Skip iff matching open bracket
ELSE
CERROR(CERM22)
END
ELSE
IF .BRKHAK NEQ 0 THEN CERROR(CERM23); ! Complain if unmatched open
IF .SCACOD NEQ SCN_COLON THEN CERROR(CERM11);
SCAN();
IF CPSTMT() EQL FALSE THEN CERROR(CERM12);
EXITADDR = GENINS(OPR_JMP,.EXITADDR,0,0);
IF .TESTADDR GEQ 0 THEN CODWRK[.TESTADDR,COD_OPA] = .NEXTIN
END
UNTIL
.SCACOD NEQ SCN_SEMI;
IF .SCACOD NEQ SCN_END THEN CERROR(CERM7);
SCAN();
WHILE
.EXITADDR NEQ %O'777777'
DO
BEGIN
TESTADDR = .CODWRK[.EXITADDR,COD_OPA];
CODWRK[.EXITADDR,COD_OPA] = .NEXTIN;
EXITADDR = .TESTADDR
END;
IF .SDESC EQL OPN_TMP_INT OR .SDESC EQL OPN_TMP_STR
THEN
GENINS(OPR_POP,.SDESC,0,0)
END;
ROUTINE CPCOMS(OPCODE,REQVAR): NOVALUE = ! Common string statement
!++
! Functional description:
! Called from <Statement> to compile any sort of statement
! which is merely an operation code with a string argument.
! The string may be required to be a string identifier, or
! be allowed to be a string-expression.
!
! Formal parameters:
! Operation code of the instruction to be generated
! Switch: Require variable if 1, otherwise permit any string-expression
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from statement keyword to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
SCAN();
IF .REQVAR NEQ 0 AND .SCACOD NEQ SCN_IDENT AND .SCACOD NEQ SCN_SYSNAME
THEN
CERROR(CERM3);
GENINS(.OPCODE,CPSEXP(OPN_TMP_STR),0,0)
END;
ROUTINE CPPFRM: NOVALUE = ! <DoCommand-statement>
!++
! Functional description:
! Called from <Statement> to compile a DoCommand statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from DOCOMMAND to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OPA, ! Operand descriptors
OPB,
OPC;
OPB = -1;
OPC = -1;
IF SCAN() EQL SCN_ORIGINAL
THEN
BEGIN
OPB = 0;
SCAN()
END;
OPA = CPSEXP(OPN_TMP_STR);
IF .SCACOD EQL SCN_TO
THEN
BEGIN
! IF SCAN() NEQ SCN_IDENT THEN CERROR(CERM3);
! OPC = CPSEXP(OPN_TMP_STR)
IF SCAN() EQL SCN_IDENT
THEN
OPC = CPSPRM()
ELSE IF .SCACOD EQL SCN_SYSNAME
THEN
BEGIN
IF .PSDEFN[.SCATOM,SYN_CLS] NEQ SYN_CLS_VAR
THEN
ERROR('Cannot store into routine');
IF NOT .PSDEFN[.SCATOM,SYN_WRT]
THEN
ERROR('Variable is readonly');
OPC = CPSPRM()
END
ELSE
CERROR(CERM3);
IF .SCACOD EQL SCN_PLUS
THEN
ERROR('Complex string expression illegal after TO')
END;
GENINS(OPR_DCM,.OPA,.OPB,.OPC)
END;
ROUTINE CPGUID: NOVALUE = ! <Guide-statement>
!++
! Functional description:
! Called from <Statement> to compile a Guide statement.
! It's just an Parse statement, but the FLDDB takes no work.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from GUIDE to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
FDB;
IF .CMDARG EQL -1 THEN CMDARG = -2;
FDB = .CONSTP;
CONSTP = .CONSTP + $CMBRK + 1;
CNSWRK[.FDB+$CMFNP] = 0;
CNSWRK[.FDB+$CMDAT] = 0;
CNSWRK[.FDB+$CMDEF] = 0;
CNSWRK[.FDB+$CMHLP] = 0;
CNSWRK[.FDB+$CMBRK] = 0;
POINTR((CNSWRK[.FDB+$CMFNP]),CM_FNC) = $CMNOI;
IF SCAN() NEQ SCN_QSTRING THEN CERROR(CERM19);
CNSWRK[.FDB+$CMDAT] = CPSPRM();
CNSWRK[.FDB+$CMBRK] = .NEXTIN + 2;
GENINS(OPR_PRS,.FDB,0,-1)
END;
ROUTINE CPPMPT: NOVALUE = ! <Prompt-statement>
!++
! Functional description:
! Compiles a Prompt statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Instruction
!
! Routine value:
! None
!
! Side effects:
! Scans from PROMPT to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL OPR; ! Operation code to use
OPR = OPR_PMT;
IF SCAN() EQL SCN_NOECHO
THEN
BEGIN
OPR = OPR_PMN;
SCAN();
END;
GENINS(.OPR,CPSEXP(OPN_TMP_STR),0,0)
END;
ROUTINE CPINVK: NOVALUE = ! <Invoke-statement>
!++
! Functional description:
! Compile an Invoke statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Instructions
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL OPR;
OPR = OPR_IVP;
IF SCAN() EQL SCN_PASSOUTPUT
THEN
BEGIN
OPR = OPR_IVO;
SCAN()
END;
GENINS(.OPR,CPSEXP(OPN_TMP_STR),0,0)
END;
ROUTINE CPPRSE: NOVALUE = ! <Parse-statement>
!++
! Functional description:
! Called from <Statement> to compile an Parse statement,
! generating the corresponding list of Field Descriptor Blocks
! and the Parse instruction referencing it.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code, constants
!
! Routine value:
! None
!
! Side effects:
! Scans from PARSE to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PRSINSTR, ! Location of PRS instruction
FAILADDR, ! Location of failure instruction
FDB; ! Constant index of FLDDB list
IF .CMDARG EQL -1 THEN CMDARG = -2;
PRSINSTR = GENINS(OPR_PRS,0,0,0);
GENINS(OPR_JMP,0,0,0);
FAILADDR = -1;
SCAN();
IF (.SCACOD EQL SCN_LPAREN) OR (.SCACOD EQL SCN_BEGIN)
THEN
BEGIN
LOCAL
LFDB, ! Last FLDDB built
NFDB, ! New FLDDB
FILOPT, ! Whether a File parse is on the list
PRNHAK; ! Hack flag for old syntax
IF .SCACOD EQL SCN_LPAREN
THEN
PRNHAK = -1
ELSE
PRNHAK = 0;
LFDB = -1;
FILOPT = 0;
SCAN();
DO
BEGIN
! Identify the parse-type
NFDB = CPPRSI(0,.PRSINSTR+2);
! Handle OTHERWISE, which must be last before the ")"
IF .NFDB LSS 0
THEN
BEGIN
FAILADDR = -.NFDB;
IF .SCACOD EQL SCN_SEMI THEN SCAN();
EXITLOOP
END;
IF .POINTR((CNSWRK[.NFDB+$CMFNP]),CM_FNC) EQL $CMFIL
THEN
IF .FILOPT EQL 0
THEN
FILOPT = -1
ELSE
ERROR('Cannot have two File fields in one Parse');
IF .LFDB LSS 0
THEN
FDB = .NFDB
ELSE
BEGIN
IF .POINTR((CNSWRK[.LFDB+$CMFNP]),CM_FNC) EQL $CMNOI
THEN
ERROR('Cannot chain Noise field-type to another type');
IF .POINTR((CNSWRK[.LFDB+$CMFNP]),CM_FNC) EQL $CMFLS
THEN
ERROR('Cannot chain FileList field-type to another type');
IF .POINTR((CNSWRK[.NFDB+$CMFNP]),CM_FNC) EQL $CMFLS
THEN
ERROR('Cannot chain any other field-type to FileList');
POINTR((CNSWRK[.LFDB+$CMFNP]),CM_LST) = .NFDB
END;
LFDB = .NFDB;
IF .SCACOD NEQ SCN_SEMI AND .SCACOD NEQ SCN_RPAREN
AND .SCACOD NEQ SCN_END
THEN
CERROR(CERM14);
IF .SCACOD EQL SCN_SEMI THEN SCAN();
IF (.PRNHAK NEQ 0) AND (.SCACOD EQL SCN_END)
THEN
CERROR(CERM14);
IF (.PRNHAK EQL 0) AND (.SCACOD EQL SCN_RPAREN)
THEN
CERROR(CERM7)
END
UNTIL
.SCACOD EQL SCN_RPAREN OR .SCACOD EQL SCN_END;
SCAN()
END
ELSE
BEGIN
FDB = CPPRSI(0,.PRSINSTR+2);
IF .FDB LSS 0 THEN ERROR('OTHERWISE meaningless here');
IF .SCACOD NEQ SCN_SEMI AND .SCACOD NEQ SCN_END
AND .SCACOD NEQ SCN_RPAREN AND .SCACOD NEQ SCN_ELSE
THEN
ERROR('Garbage following PARSE')
END;
CODWRK[.PRSINSTR,COD_OPA] = .FDB;
CODWRK[.PRSINSTR,COD_OPC] = .FAILADDR;
CODWRK[.PRSINSTR+2,COD_OPA] = .NEXTIN
END;
ROUTINE CPPRSI(FLG,DONEAD) = ! <Parse-item>
!++
! Functional description:
! Compiles one item of a Parse list, whether for Command arguments
! or for a Parse statement. I build an FLDDB in the constants,
! containing everything necessary for COMND% but in position-
! independent form. If compiling a Parse, I compile any success-
! statement and set the .CMBRK word to it; if none is requested
! I set .CMBRK to the done-address passed by my caller. If compiling
! Command arguments, I declare any destination-variable and put its
! symbol index in .CMBRK<LH>, or -1 if none is desired.
! In the Parse case, there is a complication: An OTHERWISE Parse-type
! does not result in an FLDDB, but only the compilation of its
! success-statement; in this case I return the negative of the address
! of the code compiled.
!
! Formal parameters:
! Flag: 0=Parse, 1=Command arguments
! Location to jump to after completion of success-statement (Parse)
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code, constants
!
! Routine value:
! Constants index of FLDDB, or negative of jump address if
! OTHERWISE requested
!
! Side effects:
! Scans from Parse-type to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
FDB, ! Index of FLDDB being constructed
FNC; ! Function code
%( This should be built symbolically )%
BIND
TYPTBL = UPLIT(%B'000011110110001111100111000000000000');
IF .FLG EQL 0
THEN
IF .SCACOD EQL SCN_OTHERWISE
THEN
BEGIN
IF SCAN() NEQ SCN_COLON THEN CERROR(CERM11);
SCAN();
FDB = -.NEXTIN;
IF CPSTMT() EQL FALSE THEN CERROR(CERM12);
RETURN .FDB
END;
! Identify the field type
IF .SCACOD NEQ SCN_IDENT THEN CERROR(CERM2);
FNC =
(DECR I FROM FNMCNT-1 DO
IF .SCALEN EQL .FNMTBL[.I,RSNLEN] THEN
IF CH$EQL( .SCALEN, CH$PTR(SCATOM),
.SCALEN, BYTPTR(.FNMTBL[.I,RSNSTR]))
THEN
EXITLOOP .I);
IF .FNC LSS 0 THEN CERROR(CERM2);
FNC = .FNMTBL[.FNC,RSNSCN];
IF .FLG NEQ 0
THEN
IF .FNC EQL $CMCFM THEN ERROR('EOL parse-type invalid');
! Allocate the FLDDB
FDB = .CONSTP;
CONSTP = .CONSTP + $CMBRK + 1;
IF .CONSTP GEQ CNSWKL THEN CERROR(CERM1);
CNSWRK[.FDB+$CMFNP] = 0;
CNSWRK[.FDB+$CMDAT] = 0;
CNSWRK[.FDB+$CMHLP] = 0;
CNSWRK[.FDB+$CMDEF] = 0;
IF .FLG EQL 0
THEN
CNSWRK[.FDB+$CMBRK] = .DONEAD
ELSE
CNSWRK[.FDB+$CMBRK] = -1;
POINTR((CNSWRK[.FDB+$CMFNP]),CM_FNC) = .FNC;
IF .FNC EQL $CMTOK OR .FNC EQL $CMNOI
THEN
BEGIN
IF SCAN() NEQ SCN_QSTRING THEN CERROR(CERM19);
CNSWRK[.FDB+$CMDAT] = CPSPRM()
END
ELSE
SCAN();
! Process options
IF .SCACOD EQL SCN_LPAREN THEN CPPRSO(.FNC,.FDB,.FLG);
! Do some defaulting
SELECTONE .FNC OF
SET
[$CMKEY,
$CMSWI]: IF .CNSWRK[.FDB+$CMDAT] EQL 0 THEN ERROR('Must provide word list');
[$CMNUM]: IF .CNSWRK[.FDB+$CMDAT] EQL 0 THEN CNSWRK[.FDB+$CMDAT] = 10;
[$CMTAD]: IF .CNSWRK[.FDB+$CMDAT] EQL 0
THEN
CNSWRK[.FDB+$CMDAT] = CM_IDA + CM_ITM;
[$CMFLS]: CPPRSF(.FDB,-1,GJ_IFG)
TES;
IF .SCACOD EQL SCN_COLON
THEN
IF .FLG EQL 0
THEN
BEGIN
! Compile success-statement
SCAN();
CNSWRK[.FDB+$CMBRK] = .NEXTIN;
IF CPSTMT() EQL FALSE THEN CERROR(CERM9);
GENINS(OPR_JMP,.DONEAD,0,0)
END
ELSE
BEGIN
! Define destination identifier
LOCAL
HLFTMP: HLF_WRD,
STE; ! Symbol table index
IF SCAN() NEQ SCN_IDENT THEN CERROR(CERM3);
STE = ADDSMB();
IF .STE LSS 0 THEN CERROR(CERM4);
IF .NUMVRS GEQ MAXVRC THEN CERROR(CERM15);
SYMWRK[.STE,STE_CLS] = STE_CLS_VAR;
SYMWRK[.STE,STE_LOC] = .NUMVRS + FRM_LOC;
NUMVRS = .NUMVRS + 1;
SYMWRK[.STE,STE_TYP] = CH$RCHAR(CH$PTR(TYPTBL,.FNC,1));
HLFTMP = .CNSWRK[.FDB+$CMBRK];
HLFTMP[HLF_LFT] = .STE;
CNSWRK[.FDB+$CMBRK] = .HLFTMP;
SCAN()
END;
.FDB
END;
ROUTINE CPPRSO(FNC,FDB,FLG): NOVALUE = ! <Parse-options>
!++
! Functional description:
! Compile Parse options.
!
! Formal parameters:
! Function code of field being described
! Constant index of FLDDB being constructed
! 0 if compiling PARSE, 1 if compiling Command arguments
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Constants
!
! Routine value:
! None
!
! Side effects:
! Scans from ( to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
DO
BEGIN
SELECTONE SCAN() OF
SET
[SCN_NOINDIRECT]:
BEGIN
SCAN();
POINTR((CNSWRK[.FDB+$CMFNP]),CM_NIN) = 1
END;
[SCN_DEFAULT]: BEGIN
SCAN();
CNSWRK[.FDB+$CMDEF] = CPSPRM();
POINTR((CNSWRK[.FDB+$CMFNP]),CM_DPP) = 1
END;
[SCN_HELP]: BEGIN
SCAN();
CNSWRK[.FDB+$CMHLP] = CPSPRM();
POINTR((CNSWRK[.FDB+$CMFNP]),CM_HPP) = 1;
IF .POINTR((CNSWRK[.FDB+$CMFNP]),CM_SHR) EQL 0
THEN
POINTR((CNSWRK[.FDB+$CMFNP]),CM_SDH) = 1
END;
[SCN_NOHELP]: BEGIN
SCAN();
POINTR((CNSWRK[.FDB+$CMFNP]),CM_SDH) = 1
END;
[SCN_WORDS]: CNSWRK[.FDB+$CMDAT] = CPPRSW(.FNC);
[SCN_RADIX]: BEGIN
IF .FNC NEQ $CMNUM THEN ERROR('RADIX only for CMNUM fields');
IF SCAN() NEQ SCN_NUMB THEN ERROR('Radix missing');
IF .SCANUM LSS 2 OR .SCANUM GTR 10 THEN ERROR('Illegal radix');
CNSWRK[.FDB+$CMDAT] = .SCANUM;
SCAN()
END;
[SCN_PARSEONLY]:BEGIN
SELECTONE .FNC OF
SET
[$CMFIL]: CPPRSF(.FDB,-1,GJ_OFG);
[$CMDEV,
$CMNOD,
$CMDIR,
$CMUSR]: POINTR((CNSWRK[.FDB+$CMFNP]),CM_PO) = 1;
[OTHERWISE]:ERROR('PARSEONLY meaningless for this field type')
TES;
SCAN()
END;
[SCN_STDHELP]: BEGIN
POINTR((CNSWRK[.FDB+$CMFNP]),CM_SDH) = 0;
POINTR((CNSWRK[.FDB+$CMFNP]),CM_SHR) = 1;
SCAN()
END;
[SCN_TIME]: BEGIN
POINTR((CNSWRK[.FDB+$CMDAT]),CM_ITM) = 1;
SCAN()
END;
[SCN_DATE]: BEGIN
POINTR((CNSWRK[.FDB+$CMDAT]),CM_IDA) = 1;
SCAN()
END;
[SCN_INPUT]: BEGIN
IF .FNC NEQ $CMFIL AND .FNC NEQ $CMFLS
THEN
ERROR('INPUT only for FILE or FILELIST fields');
CPPRSF(.FDB,-1,GJ_OLD);
SCAN()
END;
[SCN_OUTPUT]: BEGIN
IF .FNC NEQ $CMFIL AND .FNC NEQ $CMFLS
THEN
ERROR('OUTPUT only for FILE or FILELIST fields');
CPPRSF(.FDB,-1,GJ_FOU);
SCAN()
END;
[SCN_WILD]: BEGIN
IF .FNC NEQ $CMFIL AND .FNC NEQ $CMFLS
THEN
ERROR('WILD only for FILE and FILELIST fields');
POINTR((CNSWRK[.FDB+$CMFNP]),CM_WLD) = 1;
CPPRSF(.FDB,-1,GJ_IFG);
SCAN()
END;
[SCN_INVISIBLE]:BEGIN
IF .FNC NEQ $CMFIL AND .FNC NEQ $CMFLS
THEN
ERROR('INVISIBLE only for FILE and FILELIST fields');
CPPRSF(.FDB,-2,G1_IIN);
SCAN()
END;
[SCN_DELETED]: BEGIN
IF .FNC NEQ $CMFIL AND .FNC NEQ $CMFLS
THEN
ERROR('DELETED only for FILE and FILELIST fields');
CPPRSF(.FDB,-1,GJ_DEL);
SCAN()
END;
[SCN_DEFAULT_DEV,
SCN_DEFAULT_DIR,
SCN_DEFAULT_NAM,
SCN_DEFAULT_EXT]: BEGIN
LOCAL
COD, ! Scan code
STR; ! String location
BIND DEF_LST = UPLIT($GJDEV,$GJDIR,$GJNAM,$GJEXT): VECTOR;
IF .FNC NEQ $CMFIL AND .FNC NEQ $CMFLS
THEN
ERROR('Only for FILE and FILELIST fields');
COD = .DEF_LST[.SCACOD-SCN_DEFAULT_DEV];
SCAN();
STR = CPSPRM();
CPPRSF(.FDB,.COD,.STR)
END;
[SCN_DEFAULT_GEN]: BEGIN
LOCAL
CODE;
IF .FNC NEQ $CMFIL AND .FNC NEQ $CMFLS
THEN
ERROR('Only for FILE and FILELIST fields');
SELECTONE SCAN() OF
SET
[SCN_NUMB]: CODE = .SCANUM;
[SCN_PLUS]: CODE = $GJNHG;
[SCN_MINUS]: CODE = $GJLEG;
[SCN_TIMES]: CODE = $GJALL;
[OTHERWISE]: ERROR('Invalid code')
TES;
CPPRSF(.FDB,$GJGEN,.CODE);
SCAN()
END;
[SCN_ERROR]: IF .FLG EQL 0
THEN
ERROR('ERROR not permitted here')
ELSE
BEGIN
LOCAL
HLFTMP: HLF_WRD,
PTR;
IF SCAN() NEQ SCN_IDENT THEN CERROR(CERM3);
PTR =
(DECR I FROM .LBLCNT-1 DO
IF CH$EQL( .SCALEN+1,BYTPTR(SCATOM),
.SCALEN+1,.LBLNAM[.I])
THEN
EXITLOOP .I);
IF .PTR LSS 0
THEN
BEGIN
IF .LBLCNT GEQ MAXLBL THEN CERROR(CERM10);
LBLNAM[.LBLCNT] = BYTPTR(PCMGMM((.SCALEN+5)/5, DICT));
CH$MOVE(.SCALEN+1, BYTPTR(SCATOM), .LBLNAM[.LBLCNT]);
LBLADR[.LBLCNT] = - ((2^17) + .FDB + $CMBRK);
LBLCNT = .LBLCNT + 1;
PTR = 0
END
ELSE
IF .LBLADR[.PTR] LSS 0
THEN
BEGIN
LOCAL
EPTR;
EPTR = -.LBLADR[.PTR];
LBLADR[.PTR] = - ((2^17) + .FDB + $CMBRK);
PTR = .EPTR
END
ELSE
PTR = .LBLADR[.PTR];
HLFTMP = .CNSWRK[.FDB+$CMBRK];
HLFTMP[HLF_RGT] = .PTR;
CNSWRK[.FDB+$CMBRK] = .HLFTMP;
SCAN()
END;
[OTHERWISE]: ERROR('Parse option not found where required')
TES
END
UNTIL
.SCACOD NEQ SCN_COMMA;
POINTR((CNSWRK[.FDB+$CMFNP]),CM_SHR) = 0;
IF .SCACOD NEQ SCN_RPAREN
THEN
ERROR('Garbage found after parse option');
SCAN()
END;
ROUTINE CPPRSW(FNC) = ! <Parse-option> WORDS
!++
! Functional description:
! Defines keyword table for Words option.
!
! Formal parameters:
! Function code for field descriptor block being generated
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Constants
!
! Routine value:
! Constant index of keyword table
!
! Side effects:
! Scans from WORDS past final right parenthesis
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PTR, ! Word index
IPTR, ! Byte pointers
OPTR,
CHR,
HLFTMP: HLF_WRD, ! Temporary
TBL, ! Table pointer
WTBL: VECTOR[100], ! Word pointers
VTBL: VECTOR[100]; ! Word values
IF .FNC NEQ $CMKEY AND .FNC NEQ $CMSWI
THEN
ERROR('Word list only for keywords and switches');
IF SCAN() NEQ SCN_LPAREN THEN CERROR(CERM16);
PTR = -1;
DO
BEGIN
SCATRP = -1;
IF SCAN() NEQ SCN_IDENT AND .SCACOD NEQ SCN_NUMB
THEN
ERROR('Word missing');
SCATRP = 0;
IF .SCACOD EQL SCN_NUMB
THEN
CH$WCHAR($CHNUL, PCMITS(.SCANUM,BYTPTR(SCATOM)));
IF SCAN() NEQ SCN_COLON THEN CERROR(CERM11);
IPTR = CH$PTR(SCATOM);
OPTR = .IPTR;
DO
BEGIN
CHR = CH$RCHAR_A(IPTR);
IF .CHR EQL %C'_' THEN CHR = %C'-';
CH$WCHAR_A(.CHR,OPTR)
END
UNTIL
.CHR EQL $CHNUL;
IF SCAN() EQL SCN_COLON
THEN
BEGIN
CH$WCHAR(%C':',CH$PTR(SCATOM,.SCALEN));
SCALEN = .SCALEN + 1;
SCAN();
END;
PTR = .PTR + 1;
IF .PTR GTR 100 THEN ERROR('Too many keywords');
IF .CONSTP + (.SCALEN+5)/5 GTR CNSWKL
THEN
CERROR(CERM1);
CH$COPY(.SCALEN,CH$PTR(SCATOM),
0,.SCALEN+1,CH$PTR(CNSWRK[.CONSTP]));
WTBL[.PTR] = .CONSTP;
CONSTP = .CONSTP + (.SCALEN+5)/5;
IF .SCACOD EQL SCN_MINUS
THEN
BEGIN
IF SCAN() NEQ SCN_NUMB THEN ERROR('Word value missing');
IF .SCANUM GEQ %O'1000000'
THEN
ERROR('Word value must be greater than -262144');
SCANUM = -.SCANUM
END
ELSE
BEGIN
IF .SCACOD NEQ SCN_NUMB THEN ERROR('Word value missing');
IF .SCANUM GEQ %O'777777'
THEN
ERROR('Word value must be less than 262143')
END;
VTBL[.PTR] = .SCANUM AND %O'777777' ! Make halfword even if negative
END
UNTIL
SCAN() NEQ SCN_COMMA;
IF .SCACOD NEQ SCN_RPAREN THEN CERROR(CERM14);
SCAN();
IF .CONSTP + .PTR +2 GEQ CNSWKL
THEN
CERROR(CERM1);
TBL = .CONSTP;
CONSTP = .CONSTP + .PTR + 2;
CNSWRK[.TBL] = .PTR + 1;
%( Must be a better way to alphabetize the table )%
DECR I FROM .PTR DO
BEGIN
REGISTER R1=1,R2=2;
BUILTIN JSYS;
R1 = CNSWRK[.TBL];
R2 = CNSWRK[.WTBL[.I]]^18 + .VTBL[.I];
JSYS(-1,TBADD,R1,R2)
END;
DECR I FROM .PTR DO
BEGIN
HLFTMP = .CNSWRK[.TBL+.I+1];
HLFTMP[HLF_LFT] = .HLFTMP[HLF_LFT] - CNSWRK;
CNSWRK[.TBL+.I+1] = .HLFTMP
END;
.TBL
END;
ROUTINE CPPRSF(FDB,COD,VAL): NOVALUE = ! File parse options
!++
! Functional description:
! Fill in words of GTJFN block, creating it if it does not
! yet exist.
!
! Formal parameters:
! Constant index of FLDDB
! Index into GTJFN block of word to define, -1 for flags,
! -2 for secondary flags
! Value to place in word (or to OR into word if index is negative)
!
! Implicit inputs:
! Pointer in .CMDAT
!
! Implicit outputs:
! None
!
! Routine value:
! None
!
! Side effects:
! None
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PTR; ! Location of option list
PTR = .CNSWRK[.FDB+$CMDAT];
IF .PTR EQL 0
THEN
BEGIN
PTR = CNSWRK[.FDB+$CMDAT] = .CONSTP;
CONSTP = .CONSTP + 6;
IF .CONSTP GEQ CNSWKL THEN CERROR(CERM1);
CNSWRK[.PTR] = 0; ! Flags and generation
CNSWRK[.PTR+1] = 0; ! Secondary flags
CNSWRK[.PTR+$GJDEV] = -1; ! Device
CNSWRK[.PTR+$GJDIR] = -1; ! Directory
CNSWRK[.PTR+$GJNAM] = -1; ! Name
CNSWRK[.PTR+$GJEXT] = -1 ! Type
END;
IF .COD LSS 0
THEN
BEGIN
CNSWRK[.PTR-(.COD+1)] = .CNSWRK[.PTR-(.COD+1)] OR .VAL;
!GJ%IFG and GJ%OFG together give strange results which the user
!probably doesn't want. Therefore, If the user has specified
!both WILD and PARSEONLY clear GJ%IFG:
IF .POINTR((CNSWRK[.PTR-(.COD+1)]),GJ_OFG) NEQ 0
THEN
POINTR((CNSWRK[.PTR-(.COD+1)]),GJ_IFG) = 0;
END
ELSE
IF .COD EQL $GJGEN
THEN
BEGIN
LOCAL
HLF: HLF_WRD;
HLF = .CNSWRK[.PTR+$GJGEN];
HLF[HLF_RGT] = .VAL;
CNSWRK[.PTR+$GJGEN] = .HLF
END
ELSE
CNSWRK[.PTR+.COD] = .VAL
END;
ROUTINE CPTYIN: NOVALUE = ! Typein statement
!++
! Functional description:
! Compiles a Typein statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from TYPEIN to atom after argument
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OPR; ! Operation code to use
OPR = OPR_TIN;
IF SCAN() EQL SCN_NORETURN
THEN
BEGIN
OPR = OPR_TIX;
SCAN()
END;
GENINS(.OPR,CPSEXP(OPN_TMP_STR),0,0)
END;
ROUTINE CPDPLY: NOVALUE = ! Display statement
!++
! Functional description:
! Compiles a Display statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from DISPLAY to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
TYP, ! Operand type (STE_TYP_INT or STE_TYP_STR)
OPR; ! Operation code to use
OPR = OPR_DPY;
IF SCAN() EQL SCN_BINARY
THEN
BEGIN
OPR = OPR_DPB;
SCAN()
END
ELSE
IF .SCACOD EQL SCN_NORETURN
THEN
BEGIN
OPR = OPR_DPN;
SCAN()
END;
TYP = CPCLSE(); ! Get type of expression
IF .TYP EQL STE_TYP_INT ! Integer?
THEN ! Yes
BEGIN
OPR = (SELECTONE .OPR OF
SET
[OPR_DPY]: OPR_DIY;
[OPR_DPB]: OPR_DIB;
[OPR_DPN]: OPR_DIN;
TES);
GENINS(.OPR,CPIEXP(OPN_TMP_INT),0,0)
END
ELSE ! No, so had better be a string...
GENINS(.OPR,CPSEXP(OPN_TMP_STR),0,0)
END;
ROUTINE CPEXIT: NOVALUE = ! Exit statement
!++
! Functional description:
! Compiles an Exit statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from keyword to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OPT; ! Options
OPT = 0;
IF SCAN() EQL SCN_SAVE
THEN
OPT = 1
ELSE
IF .SCACOD EQL SCN_TOPROGRAM
THEN
OPT = 2;
IF .OPT NEQ 0 THEN SCAN();
GENINS(OPR_XIT, .OPT, 0, 0)
END;
ROUTINE CPCALL: NOVALUE = ! <Call-statement>
!++
! Functional description:
! Called from <Statement> to compile a CALL statement,
! generating a CAL instruction with the appropriate operands;
! generate actual parameter list in constant table.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code, constants
!
! Routine value:
! None
!
! Side effects:
! Scans from CALL to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PDESIG, ! Procedure designator
PLIST, ! Actual parameter list constant index
LINE, ! Line number of CALL
SAVELINE; ! Save for real line number
LINE = .SCALIN;
IF SCAN() EQL SCN_IDENT
THEN
BEGIN
PDESIG = FNDSMB(STE_CLS_PRC,-1);
IF .PDESIG LSS 0 THEN ERROR('Procedure not defined')
END
ELSE
IF .SCACOD EQL SCN_SYSNAME
THEN
BEGIN
MAP PDESIG: OPRAND;
IF .PSDEFN[.SCATOM,SYN_CLS] NEQ SYN_CLS_PRC
THEN
ERROR('Typed routine cannot be CALLed');
PDESIG[OPN_ADR] = .SCATOM;
PDESIG[OPN_CLS] = OPN_CLS_SYN
END
ELSE
ERROR('Procedure name missing');
PLIST = -1;
IF SCAN() EQL SCN_LPAREN THEN CPACTL(PLIST);
SAVELINE = .SCALIN;
SCALIN = .LINE;
GENINS(OPR_CAL,.PDESIG,.PLIST,0);
SCALIN = .SAVELINE
END;
ROUTINE CPACTL(LIST): NOVALUE = ! <Actual-parameter-list>
!++
! Functional description:
! Processes actual parameter list in source, generating in the
! constants area the corresponding list of operand descriptors.
!
! Formal parameters:
! Address of word in which to store constant index of argument list
!
! Implicit inputs:
! Symbol table, source
!
! Implicit outputs:
! Constants
!
! Routine value:
! None
!
! Side effects:
! Scans from ( past )
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
PCNT, ! Argument count
IPTR, ! Temporary pointers
OPTR,
TBL: VECTOR[MAXPRM]; ! Argument list being created
OPTR = TBL[0];
PCNT = 0;
DO
BEGIN
LOCAL
TYPE; ! Data type
SCAN();
TYPE = CPCLSE();
IF .TYPE LSS 0 THEN CERROR(CERM18);
IF .TYPE EQL STE_TYP_INT
THEN
.OPTR = CPIEXP(OPN_TMP_INT)
ELSE
.OPTR = CPSEXP(OPN_TMP_STR);
OPTR = .OPTR + 1;
PCNT = .PCNT + 1;
IF .SCACOD NEQ SCN_COMMA AND .SCACOD NEQ SCN_RPAREN
THEN
ERROR('Comma or parenthesis missing after actual argument')
END
UNTIL
.SCACOD EQL SCN_RPAREN;
SCAN();
.LIST = .CONSTP;
OPTR = CNSWRK[.CONSTP];
.OPTR = .PCNT;
CONSTP = .CONSTP + .PCNT + 1;
IPTR = TBL[0];
DO
(OPTR=.OPTR+1; .OPTR=..IPTR; IPTR=.IPTR+1)
UNTIL
(PCNT=.PCNT-1) LEQ 0
END;
ROUTINE CPRETN: NOVALUE = ! <Return-statement>
!++
! Functional description:
! Called from <Statement> to compile a Return statement.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! None
!
! Side effects:
! Scans from RETURN to unrecognized atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
DESC;
SCAN();
IF .CURCLS EQL GST_CLS_FCN
THEN
IF .CURTYP EQL GST_TYP_INT
THEN
DESC = CPIEXP(OPN_TMP_INT)
ELSE
DESC = CPSEXP(OPN_TMP_STR);
GENINS(OPR_RET,.DESC,0,0)
END;
ROUTINE CPIEXP(DSTN) = ! <Integer-expression>
!++
! Functional description:
! Compiles integer expression, and generates necessary instructions
! to place value of expression into destination provided. Caller
! may require that result be placed in a particular variable; if
! he requires only OPN_TMP_INT then I can put it anyplace and
! return a read designator.
!
! Formal parameters:
! Operand descriptor into which expression should be stored.
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! Operand descriptor into which expression was stored
!
! Side effects:
! Scans from first atom of expression past last atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OPR, ! Operator
BDESC, ! Source designator
CDESC; ! Source designator
CDESC = CPITRM();
IF .CDESC LSS 0 THEN CERROR(CERM13);
OPR = OPR_STO;
WHILE
.SCACOD EQL SCN_PLUS OR .SCACOD EQL SCN_MINUS
DO
BEGIN
IF .OPR EQL OPR_STO
THEN
BDESC = .CDESC
ELSE
BEGIN
GENINS(.OPR,OPN_TMP_INT,.BDESC,.CDESC);
BDESC = OPN_TMP_INT
END;
OPR = (IF .SCACOD EQL SCN_PLUS THEN OPR_ADD ELSE OPR_SUB);
SCAN();
IF (CDESC = CPITRM()) LSS 0 THEN CERROR(CERM13)
END;
IF .DSTN EQL OPN_TMP_INT AND .OPR EQL OPR_STO THEN RETURN .CDESC;
GENINS(.OPR,.DSTN,.BDESC,.CDESC);
.DSTN
END;
ROUTINE CPSEXP(DSTN) = ! <String-expression>
!++
! Functional description:
! Compiles string expression, and generates necessary instructions
! to place value of expression into destination provided. Caller
! may require that result be placed in a particular variable; if
! he requires only OPN_TMP_STR then I can put it anyplace and
! return a real designator.
!
! Formal parameters:
! Operand descriptor into which expression should be stored.
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! Operand descriptor into which expression was stored
!
! Side effects:
! Scans from first atom of expression past last atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OPR, ! Operation code to be used
BDESC, ! Designators
CDESC;
OPR = OPR_STS;
CDESC = CPSPRM();
WHILE
.SCACOD EQL SCN_PLUS
DO
BEGIN
IF .OPR EQL OPR_STS
THEN
BEGIN
OPR = OPR_CNS;
BDESC = .CDESC
END
ELSE
BEGIN
GENINS(OPR_CNS,OPN_TMP_STR,.BDESC,.CDESC);
BDESC = OPN_TMP_STR
END;
SCAN();
CDESC = CPSPRM()
END;
IF .DSTN EQL OPN_TMP_STR AND .OPR EQL OPR_STS THEN RETURN .CDESC;
GENINS(.OPR,.DSTN,.BDESC,.CDESC);
.DSTN
END;
ROUTINE CPLEXP = ! <Logical-expression>
!++
! Functional description:
! Compiles logical expression, generating appropriate Compare
! instruction to apply test to the primaries (actually, generates
! opposite Compare instruction, so that true-statement can
! immediately follow the Compare). Returns index
! of Compare instruction.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source, symbol table
!
! Implicit outputs:
! Code
!
! Routine value:
! Index of Compare instruction
!
! Side effects:
! Scans from first atom of expression past last atom
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
TYPE, ! Data type of comparison
OPR, ! Operation code
BDESC, ! B operand descriptor
CDESC; ! C operand descriptor
! Must be in the same order as the relational scan codes
BIND
CMP_TBL_INT =
UPLIT(OPR_BGE,OPR_BGT,OPR_BEQ,OPR_BNE,OPR_BLE,OPR_BLT): VECTOR,
CMP_TBL_STR =
UPLIT(OPR_CGE,OPR_CGT,OPR_CEQ,OPR_CNE,OPR_CLE,OPR_CLT): VECTOR;
TYPE = CPCLSE();
IF .TYPE LSS 0 THEN CERROR(CERM18);
IF .TYPE EQL STE_TYP_INT
THEN
BDESC = CPIEXP(OPN_TMP_INT)
ELSE
BDESC = CPSEXP(OPN_TMP_STR);
IF .SCACOD LSS SCN_1RL OR .SCACOD GTR SCN_LRL
THEN
ERROR('Relational missing');
OPR = (CASE .TYPE FROM STE_TYP_INT TO STE_TYP_STR OF
SET
[STE_TYP_INT]: .CMP_TBL_INT[.SCACOD-SCN_LSS];
[STE_TYP_STR]: .CMP_TBL_STR[.SCACOD-SCN_LSS]
TES);
SCAN();
CDESC = (CASE .TYPE FROM STE_TYP_INT TO STE_TYP_STR OF
SET
[STE_TYP_INT]: CPIEXP(OPN_TMP_INT);
[STE_TYP_STR]: CPSEXP(OPN_TMP_STR);
TES);
GENINS(.OPR,0,.BDESC,.CDESC)
END;
ROUTINE CPITRM = ! <Integer-term>
!++
! Functional description:
! Compile an integer term, returning a source operand descriptor.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! Code
!
! Routine value:
! Operand descriptor, or -1 if not an integer
!
! Side effects:
! Scans past term
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
OPR, ! Operator
BDESC, ! Source designators
CDESC;
IF (BDESC = CPIPRM()) LSS 0 THEN RETURN -1;
OPR = OPR_STO;
WHILE
.SCACOD EQL SCN_TIMES OR .SCACOD EQL SCN_DIV
DO
BEGIN
OPR = (IF .SCACOD EQL SCN_TIMES THEN OPR_MUL ELSE OPR_DIV);
SCAN();
IF (CDESC = CPIPRM()) LSS 0 THEN CERROR(CERM13);
GENINS(.OPR,OPN_TMP_INT,.BDESC,.CDESC);
BDESC = OPN_TMP_INT
END;
.BDESC
END;
ROUTINE CPIPRM = ! <Integer-primary>
!++
! Functional description:
! Processes an integer primary from the source stream, either
! an integer identifier, an integer system variable, an integer
! constant, or a temporary designator for the results of a function
! invocation. Returns a suitable source operand descriptor.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source, symbols
!
! Implicit outputs:
! Constants
!
! Routine value:
! Operand descriptor, or -1 if not recognized
!
! Side effects:
! Scans past end of primary
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
DESC; ! Value to be constructed
IF .SCACOD EQL SCN_IDENT
THEN
BEGIN
DESC = FNDSMB(-1,STE_TYP_INT);
IF .DESC LSS 0 THEN RETURN -1;
IF .SYMWRK[.DESC,STE_CLS] EQL STE_CLS_PRC THEN RETURN -1;
IF .SYMWRK[.DESC,STE_CLS] EQL STE_CLS_FCN
THEN
BEGIN
LOCAL
PLIST; ! Actual argument list pointer
PLIST = -1;
IF SCAN() EQL SCN_LPAREN THEN CPACTL(PLIST);
GENINS(OPR_CAL,.DESC,.PLIST,OPN_TMP_INT);
DESC = OPN_TMP_INT
END
ELSE
SCAN()
END
ELSE
IF .SCACOD EQL SCN_SYSNAME
THEN
BEGIN
IF .PSDEFN[.SCATOM,SYN_CLS] EQL SYN_CLS_VAR
THEN
IF .PSDEFN[.SCATOM,SYN_TYP] EQL SYN_TYP_INT
THEN
BEGIN
MAP DESC: OPRAND;
DESC[OPN_ADR] = .SCATOM;
DESC[OPN_CLS] = OPN_CLS_SYN;
SCAN()
END
ELSE
RETURN -1
ELSE
IF .PSDEFN[.SCATOM,SYN_CLS] NEQ SYN_CLS_FCN
THEN
RETURN -1
ELSE
IF .PSDEFN[.SCATOM,SYN_TYP] EQL SYN_TYP_INT
THEN
BEGIN
LOCAL
PLIST; ! Actual argument list pointer
BEGIN
MAP DESC: OPRAND;
DESC[OPN_ADR] = .SCATOM;
DESC[OPN_CLS] = OPN_CLS_SYN
END;
PLIST = -1;
IF SCAN() EQL SCN_LPAREN THEN CPACTL(PLIST);
GENINS(OPR_CAL,.DESC,.PLIST,OPN_TMP_INT);
DESC = OPN_TMP_INT
END
ELSE
RETURN -1
END
ELSE
IF .SCACOD EQL SCN_LPAREN
THEN
BEGIN
SCAN();
DESC = CPIEXP(OPN_TMP_INT);
IF .SCACOD NEQ SCN_RPAREN THEN CERROR(CERM14);
SCAN()
END
ELSE
IF .SCACOD EQL SCN_MINUS
THEN
BEGIN
MAP DESC: OPRAND;
IF SCAN() NEQ SCN_NUMB THEN ERROR('Unary minus only for constants');
DESC[OPN_ADR] = GETCNS(-.SCANUM,STE_TYP_INT);
DESC[OPN_CLS] = OPN_CLS_CNS;
DESC[OPN_STR] = 0;
SCAN()
END
ELSE
BEGIN
MAP DESC: OPRAND;
IF .SCACOD NEQ SCN_NUMB THEN RETURN -1;
DESC[OPN_ADR] = GETCNS(.SCANUM,STE_TYP_INT);
DESC[OPN_CLS] = OPN_CLS_CNS;
DESC[OPN_STR] = 0;
SCAN()
END;
.DESC
END;
ROUTINE CPSPRM = ! <String-primary>
!++
! Functional description:
! Processes a string primary from the source stream, either
! a string identifier, a string system variable, a string
! constant, or a call to a string-valued function. If necessary,
! generates instructions to calculate value, storing it in a
! stack temporary. Returns a suitable source operand descriptor.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source, symbols
!
! Implicit outputs:
! Constants
!
! Routine value:
! Operand descriptor
!
! Side effects:
! Scans past end of primary
!
!--
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
DESC; ! Value to be constructed
IF .SCACOD EQL SCN_IDENT
THEN
BEGIN
DESC = FNDSMB(-1,STE_TYP_STR);
IF .DESC EQL -1 THEN ERROR('Undefined name');
IF .DESC EQL -2 THEN CERROR(CERM24);
IF .SYMWRK[.DESC,STE_CLS] EQL STE_CLS_PRC
THEN
ERROR('Procedure name illegal');
IF .SYMWRK[.DESC,STE_CLS] EQL STE_CLS_FCN
THEN
BEGIN
LOCAL
PLIST; ! Actual argument list pointer
PLIST = -1;
IF SCAN() EQL SCN_LPAREN THEN CPACTL(PLIST);
GENINS(OPR_CAL,.DESC,.PLIST,OPN_TMP_STR);
DESC = OPN_TMP_STR
END
ELSE
SCAN()
END
ELSE
IF .SCACOD EQL SCN_SYSNAME
THEN
BEGIN
IF .PSDEFN[.SCATOM,SYN_CLS] EQL SYN_CLS_VAR
THEN
IF .PSDEFN[.SCATOM,SYN_TYP] EQL SYN_TYP_STR
THEN
BEGIN
MAP DESC: OPRAND;
DESC[OPN_ADR] = .SCATOM;
DESC[OPN_CLS] = OPN_CLS_SYN;
SCAN()
END
ELSE
CERROR(CERM24)
ELSE
IF .PSDEFN[.SCATOM,SYN_CLS] EQL SYN_CLS_FCN
THEN
IF .PSDEFN[.SCATOM,SYN_TYP] EQL SYN_TYP_STR
THEN
BEGIN
LOCAL
PLIST; ! Actual argument list pointer
BEGIN
MAP DESC: OPRAND;
DESC = .SCATOM;
DESC[OPN_CLS] = OPN_CLS_SYN
END;
PLIST = -1;
IF SCAN() EQL SCN_LPAREN THEN CPACTL(PLIST);
GENINS(OPR_CAL,.DESC,.PLIST,OPN_TMP_STR);
DESC = OPN_TMP_STR
END
ELSE
ERROR('Not a string procedure or variable')
ELSE
ERROR('Not a string procedure or variable')
END
ELSE
BEGIN
LOCAL SPTR:STR_VAL;
MAP DESC: OPRAND;
IF .SCACOD NEQ SCN_QSTRING
THEN
CERROR(CERM24);
SPTR[STV_LEN] = .SCALEN;
SPTR[STV_ADR] = SCATOM[0];
DESC[OPN_ADR] = GETCNS(.SPTR,STE_TYP_STR);
DESC[OPN_CLS] = OPN_CLS_CNS;
DESC[OPN_STR] = 1;
SCAN()
END;
IF .SCACOD EQL SCN_LBRKT
THEN
BEGIN
LOCAL
ARGL, ! Argument descriptors
ARGR;
SCAN();
IF (ARGL = CPIEXP(OPN_TMP_INT)) LSS 0
THEN
ERROR('Start position missing');
IF .SCACOD NEQ SCN_COLON THEN CERROR(CERM11);
IF SCAN() EQL SCN_TIMES
THEN
BEGIN
ARGR = -1;
SCAN()
END
ELSE
IF (ARGR = CPIEXP(OPN_TMP_INT)) LSS 0 THEN ERROR('Count missing');
IF .SCACOD NEQ SCN_RBRKT THEN CERROR(CERM23);
SCAN();
IF .CONSTP+2 GEQ CNSWKL THEN CERROR(CERM1);
CNSWRK[.CONSTP] = .ARGL;
CNSWRK[.CONSTP+1] = .ARGR;
GENINS(OPR_SBS,OPN_TMP_STR,.CONSTP,.DESC);
CONSTP = .CONSTP + 2;
DESC = OPN_TMP_STR
END;
.DESC
END;
ROUTINE CPCLSE = ! Classify expression
!++
! Functional description:
! Examines current atom in an attempt to classify the expression.
! Returns STE_TYP_INT, STE_TYP_STR, or -1 if it can't tell.
!
! Formal parameters:
! None
!
! Implicit inputs:
! Source
!
! Implicit outputs:
! None
!
! Routine value:
! STE_TYP_INT, STE_TYP_STR, or -1
!
! Side effects:
! None
!
!--
IF .SCACOD EQL SCN_IDENT
THEN
BEGIN
EXTERNAL REGISTER Z=0;
LOCAL
STE;
STE = FNDSMB(-1,-1);
IF .STE LSS 0 THEN RETURN -1;
IF .SYMWRK[.STE,STE_CLS] EQL STE_CLS_PRC THEN RETURN -1;
.SYMWRK[.STE,STE_TYP]
END
ELSE
IF .SCACOD EQL SCN_NUMB
THEN
STE_TYP_INT
ELSE
IF .SCACOD EQL SCN_MINUS
THEN
STE_TYP_INT
ELSE
IF .SCACOD EQL SCN_QSTRING
THEN
STE_TYP_STR
ELSE
IF .SCACOD EQL SCN_SYSNAME
THEN
CASE .PSDEFN[.SCATOM,SYN_CLS] FROM SYN_CLS_PRC TO SYN_CLS_VAR OF
SET
[SYN_CLS_PRC]: -1;
[SYN_CLS_FCN,
SYN_CLS_VAR]: .PSDEFN[.SCATOM,SYN_TYP]
TES
ELSE
-1;
END
ELUDOM