CONSTINTEGER NEWLOADER=1; ! 0 for old loader, 1 for new loader
CONST INTEGER DIAGOP = 0; ! No diagnostic trace requested.
CONST INTEGER ULCEQUIV = -1
! Zero to make macro expansion distinguish upper and lower case in keywords,
! non-zero to make it treat upper and lower case as equivalent.
!
IF ULCEQUIV#0 THEN START
SYSTEM ROUTINE SPEC CAST OUT (STRING NAME PSTR)
SYSTEM ROUTINE SPEC UCTRANSLATE (INTEGER A, L)
FINISH
!
! Constants and extrinsics used by NEW loader
IF NEWLOADER#0 THEN START
CONSTINTEGER CODE=2
CONSTINTEGER MACRO=4
! %EXTRINSICINTEGER LOADLEVEL
! %EXTRINSICINTEGER SSCURBGLA
FINISH
!
INCLUDE "SS0302S_SSOWNF"
!
RECORD FORMAT HF (INTEGER DATAEND, DATASTART, FILESIZE, FILETYPE, C
SUM, DATETIME, FORMAT, RECORDS)
RECORD FORMAT RF (INTEGER ADDR, TYPE, START, LIMIT)
! %RECORD %FORMAT PD (%INTEGER BOUND, ADDRESS)
RECORD FORMAT FRF(INTEGER CONAD,FILETYPE,DATASTART,DATEND,C
SIZE,RUP,EEP,MODE,USERS,ARCH,STRING (6)TRAN,STRING (8)DATE,TIME,C
INTEGER COUNT,SPARE1,SPARE2)
SYSTEM ROUTINE SPEC FINFO(STRING (31)FILE,INTEGER MODE,C
RECORD (FRF)NAME R,INTEGERNAME FLAG)
SYSTEM ROUTINE SPEC MOVE (INTEGER LENGTH, FROM, TO)
SYSTEM ROUTINE SPEC CONNECT (STRING (31) NAME, C
INTEGER MODE, HOLE, PROT, C
RECORD (RF)NAME RR, INTEGER NAME FLAG)
SYSTEM ROUTINE SPEC DISCONNECT (STRING (31) FILE, INTEGER NAME F)
SYSTEM ROUTINE SPEC OUTFILE C
(STRING (31) FILE, INTEGER BYTES, HOLE, PROT, C
INTEGER NAME CONADDR, FLAG)
SYSTEM INTEGER FN SPEC C
STARTSWITH (STRING NAME A, STRING (255) B, INTEGER CHOP)
SYSTEM INTEGER MAP SPEC COMREG (INTEGER N)
SYSTEM ROUTINE SPEC HASH COMMAND (STRING (255) COMMAND, PARMS)
IF NEWLOADER=0 THEN START
SYSTEM ROUTINE SPEC LOAD COMMAND C
(STRING (31) NAME, STRING NAME ALIAS, C
INTEGER NAME TYPE, DR0, DR1, FLAG)
FINISH ELSE START
SYSTEMLONGINTEGERFNSPEC LOADEP C
(STRING (31) NAME, INTEGERNAME TYPE,FLAG, INTEGER LOADLEVEL)
FINISH
SYSTEM ROUTINE SPEC BEFORE COMMAND
SYSTEM ROUTINE SPEC ENTER (INTEGER CLASS, DR0, DR1, STRING (255) P)
SYSTEM ROUTINE SPEC AFTER COMMAND
EXTERNAL ROUTINE SPEC PROMPT (STRING (15) S)
EXTERNAL ROUTINE SPEC SET RETURN CODE (INTEGER N)
EXTERNAL INTEGER FN SPEC UINFI (INTEGER TYPE)
!
!
! INPUT AND MACRO EXPANSION ROUTINES:
SYSTEM INTEGER FN SPEC MASTER CHAR IN (INTEGER ADVANCE)
! %EXTRINSIC %INTEGER LAST CHAR READ
! %EXTRINSIC %INTEGER IN CHAR ADDR
! %EXTRINSIC %INTEGER KWD MAX SIZE
! %EXTRINSIC %INTEGER MAC INITIALISED
! %EXTRINSIC %INTEGER IN SOURCE
SYSTEM ROUTINE SPEC START MACROUTINES C
(INTEGER BOUND, ADDRESS, INTEGER NAME R)
SYSTEM ROUTINE SPEC NEW LEVEL C
(INTEGER BOUND, ADDRESS, EOFACT, INTEGER NAME R)
SYSTEM ROUTINE SPEC USE AS MACRO (INTEGER NPARM, C
STRING ARRAY NAME KEYWORDS, C
RECORD (PD) ARRAY NAME ACTUAL PARMS, C
INTEGER BFLAG, INTEGER NAME FAILURE)
SYSTEM ROUTINE SPEC ABANDON LEVEL
SYSTEM ROUTINE SPEC CLEAR LEVEL (INTEGER L)
SYSTEM ROUTINE SPEC GO BACK
SYSTEM ROUTINE SPEC RESTART THIS LEVEL
IF DIAGOP#0 THEN START
EXTERNAL ROUTINE SPEC PRINT LEVELS
EXTERNAL ROUTINE SPEC LIST PARAMETERS C
(INTEGER P, C
STRING ARRAY NAME KNAME, C
RECORD (PD) ARRAY NAME VALUE)
FINISH
!
! PARAMETER STRING PROCESSING ROUTINES:
SYSTEM ROUTINE SPEC ANALYSE PARAMETERS C
(STRING NAME DCL PARMS, CALL PARMS, INTEGER MAX PARMS, C
STRING ARRAY NAME KEYS, INTEGER MAX KEY SIZE, C
RECORD (PD) ARRAY NAME ACTUAL, C
INTEGER NAME TOTAL KEYS, RESPONSE)
!
ROUTINE APARAM C
(STRING NAME DCL PARMS, CALL PARMS, INTEGER MAX PARMS, C
STRING ARRAY NAME KEYS, INTEGER MAX KEY SIZE, C
RECORD (PD) ARRAY NAME ACTUAL, C
INTEGER NAME TOTAL KEYS, RESPONSE)
!
! When ANALYSE PARAMETERS was moved into the subsystem basefile, it was
! changed so that, where a parameter was not given a value in the call
! nor as a default, the corresponding ACTUAL(..)_BOUND would be set to
! -1 instead of to zero (which would mean that a null string had been
! specified). Rather than making consequential changes throughout CLI,
! I simply replaced all calls on ANALYSE PARAMETERS by calls on APARAM,
! and this routine APARAM simply calls ANALYSE PARAMETERS and then clears
! any BOUNDs which are -1.
!
INTEGER I
ANALYSE PARAMETERS (DCL PARMS, CALL PARMS, MAX PARMS, KEYS, C
MAX KEY SIZE, ACTUAL, TOTAL KEYS, RESPONSE)
I = 1
WHILE I<=TOTAL KEYS CYCLE
IF ACTUAL(I)_BOUND=-1 THEN ACTUAL(I)_BOUND = 0
I = I + 1
REPEAT
END
!
CONST INTEGER KWDS = 7
! 'RECOGNISE KWDS' CAN GIVE RESULTS IN THE RANGE 0 TO KWDS.
! %OWN %STRING (5) SPECHARS
! %OWN %STRING (3) CONTU
! %OWN %STRING (3) XSTMT
! %OWN %STRING (1) NULLSTRING = ""
CONST STRING (5) STARS = "**** "
!
!
! ERROR MESSAGES CAN BE PRINTED BY THE ROUTINE 'PRINT ERRORS', WHICH
! TAKES TWO PARAMETERS: A WORD IN WHICH EACH BIT SIGNIFIES AN ERROR
! WHICH HAS OCCURRED IF THE BIT IS ONE, AND NO ERROR IF IT IS ZERO;
! AND A %BYTE %INTEGER %ARRAY %NAME WHICH DEFINES THE MESSAGES TO BE
! PRINTED FOR EACH ERROR. THE ARRAY MUST BE ONE-DIMENSIONAL WITH
! LOWER BOUND ZERO, AND IT IS LAID OUT LIKE THIS:
! BYTES 32 ONWARDS CONTAIN THE VARIOUS STRINGS, IN ANY ORDER.
! THEY MAY, BUT THEY NEED NOT, BE PACKED CLOSE UP TOGETHER, OR
! THERE MAY BE UNUSED BYTES BETWEEN ANY STRING AND THE NEXT.
! EACH STRING CONSISTS (SURPRISE, SURPRISE!) OF A LENGTH BYTE
! FOLLOWED BY THE ISO CHARACTERS - I.E., THE NORMAL IMP %STRING.
! BYTES 0 TO 31 CORRESPOND TO THE BITS OF THE FLAG WORD. BYTE 0
! CORRESPONDS TO THE LEAST SIGNIFICANT BIT AND BYTE 31 TO THE
! MOST SIGNIFICANT BIT OF THE WORD. THUS THE NUMBERING OF THE
! BYTES IS NOT THE SAME AS THE NUMBERING OF THE BITS, AND I DON'T
! CARE. EACH BYTE IS ZERO IF THERE IS NO TEXT FOR THE CORRESPONDING
! BIT, OR (N-31) IF THE TEXT STRING STARTS IN ELEMENT (N) OF
! THE ARRAY.
!
!
!
ROUTINE PRINT ERRORS C
(INTEGER A, BYTE INTEGER ARRAY NAME MSGD)
INTEGER I, Q
FOR I=0,1,31 CYCLE
IF A&1#0 THEN START
Q = MSGD (I)
IF Q#0 THEN START
PRINT STRING (STARS)
PRINT STRING (STRING(ADDR(MSGD(31+Q))))
NEWLINE
FINISH
FINISH
A = A >> 1
REPEAT
END
!
!
! BIT TEXT
! VALUE
! 1 "BRACKETS OR QUOTES IN PREDICATE"
! 2 "PREDICATE MISSING"
! 4 "UNRECOGNISED NAME IN PREDICATE"
! 8 "INVALID COMPARATOR"
! 16 "INVALID INTEGER"
! 32 "LOGICAL INSTEAD OF INTEGER"
! 64 "INTEGER INSTEAD OF LOGICAL"
! 128 "PREDICATE INVALID FOR WHENEVER"
CONST BYTE INTEGER ARRAY PRED ETEXTS (0:232) = C
1, 33, 51, 82, 101, 117, 144, 171,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
31, 'B','r','a','c','k','e','t','s',
' ','o','r',
' ','q','u','o','t','e','s',
' ','i','n',
' ','p','r','e','d','i','c','a','t','e',
17, 'P','r','e','d','i','c','a','t','e',
' ','m','i','s','s','i','n','g',
30, 'U','n','r','e','c','o','g','n','i','s','e','d',
' ','n','a','m','e',
' ','i','n',
' ','p','r','e','d','i','c','a','t','e',
18, 'I','n','v','a','l','i','d',
' ','c','o','m','p','a','r','a','t','o','r',
15, 'I','n','v','a','l','i','d',
' ','i','n','t','e','g','e','r',
26, 'L','o','g','i','c','a','l',
' ','i','n','s','t','e','a','d',
' ','o','f',
' ','i','n','t','e','g','e','r',
26, 'I','n','t','e','g','e','r',
' ','i','n','s','t','e','a','d',
' ','o','f',
' ','l','o','g','i','c','a','l',
30, 'P','r','e','d','i','c','a','t','e',
' ','i','n','v','a','l','i','d',
' ','f','o','r',
' ','W','H','E','N','E','V','E','R'
!
!
! BIT TEXT
! VALUE
! X'00000001' "KEYWORD MISSING"
! X'00000004' "TOO MANY PARAMETER FIELDS"
! X'00000080' "KEYWORDS NOT DISTINCT IN HEADER"
! X'00000400' "WORK AREA TOO FULL"
! X'00000800' "CANNOT RECOGNISE HEADER"
! X'00001000' "TOO MANY INPUT LEVELS"
! X'00002000' "NO TEXT"
! X'00004000' "WORK SPACE EXHAUSTED"
! X'00008000' "NO NAME"
! X'00010000' "TOO MANY MACROS"
CONST BYTE INTEGER ARRAY MACRO ETEXTS (0:223) = C
1, 0, 17, 0, 0, 0, 0, 161,
0, 0, 43, 62, 86, 108, 116, 137,
145, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
15, 'K','e','y','w','o','r','d',' ','m','i','s','s','i','n','g',
25, 'T','o','o',' ','m','a','n','y',
' ','p','a','r','a','m','e','t','e','r',' ','f','i','e','l','d','s',
18, 'W','o','r','k',' ','a','r','e','a',' ','t','o','o',
' ','f','u','l','l',
23, 'C','a','n','n','o','t',' ','r','e','c','o','g','n','i','s','e',
' ','h','e','a','d','e','r',
21, 'T','o','o',' ','m','a','n','y',' ','i','n','p','u','t',
' ','l','e','v','e','l','s',
7, 'N','o',' ','t','e','x','t',
20, 'W','o','r','k',' ','s','p','a','c','e',
' ','e','x','h','a','u','s','t','e','d',
7, 'N','o',' ','n','a','m','e',
15, 'T','o','o',' ','m','a','n','y',' ','m','a','c','r','o','s',
31, 'K','e','y','w','o','r','d','s',
' ','n','o','t',
' ','d','i','s','t','i','n','c','t',
' ','i','n',
' ','h','e','a','d','e','r'
!
! BIT TEXT
! VALUE
! 1 "KWD MISSING IN DECLN"
! 2 "KWD TOO LONG IN DECLN"
! 4 "TOO MANY FIELDS IN DECLN"
! 8 "KWD TOO LONG IN CALL"
! 16 "UNKNOWN KWD IN CALL"
! 32 "PARAMETER SPECIFIED TWICE"
! 64 "WRAP-AROUND"
! 128 "INDISTINCT KWDS IN HEADER"
CONST BYTE INTEGER ARRAY PARAM ETEXTS (0:204) = C
1, 22, 44, 69, 90, 110, 136, 148,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
20, 'K','w','d',
' ','m','i','s','s','i','n','g',
' ','i','n',
' ','d','e','c','l','n',
21, 'K','w','d',
' ','t','o','o',
' ','l','o','n','g',
' ','i','n',
' ','d','e','c','l','n',
24, 'T','o','o',
' ','m','a','n','y',
' ','f','i','e','l','d','s',
' ','i','n',
' ','d','e','c','l','n',
20, 'K','w','d',
' ','t','o','o',
' ','l','o','n','g',
' ','i','n',
' ','c','a','l','l',
19, 'U','n','k','n','o','w','n',
' ','k','w','d',
' ','i','n',
' ','c','a','l','l',
25, 'P','a','r','a','m','e','t','e','r',
' ','s','p','e','c','i','f','i','e','d',
' ','t','w','i','c','e',
11, 'W','r','a','p','-','a','r','o','u','n','d',
25, 'I','n','d','i','s','t','i','n','c','t',
' ','k','w','d','s',
' ','i','n',
' ','h','e','a','d','e','r'
!
CONST STRING (5) DATA START MARK = ".DATA"
CONST STRING (3) DATA END MARK = ".ED"
! %OWN %STRING (80) D DELIM 1 = ".DATA", D DELIM 2 = ".ED"
! %OWN %INTEGER COMMENTF
!
!
!
! %OWN %INTEGER SAVE BASE = 0
! %OWN %INTEGER WARNING NUMBER = 0, SAVE LIM, SAVE PTR
! %OWN %INTEGER ACCUMULATING, STATE = 1
! %OWN %RECORD(PD) ACCUMULATION
! %OWN %INTEGER LAST PROMPT
!
! %ROUTINE TIDY ACCUMULATION (%INTEGER DISCARD)
! DISCARD IS THE NUMBER OF CHARACTERS TO THROW AWAY FROM
! THE END OF THE FILE.
! ACCUMULATING = 0
! ACCUMULATION_BOUND = (ACCUMULATION_BOUND - DISCARD) ! X'18000000'
! %IF DIAGOP#0 %THEN %START
! PRINT STRING ("++++ TIDY ACCUMULATION called.")
! NEWLINE
! %FINISH
! %END
!
! %ROUTINE SAVE SYMBOL (%INTEGER SYMB)
! %INTEGER FINAL BOUND, FINAL ADDR
! ! %INTEGER J; ! ONLY NEEDED IF WE DO NOT USE MOVE.
! !
! ! THIS ASSUMES WHAT IS IN FACT TRUE - BUT WILL IT ALWAYS BE
! ! TRUE? - THAT ACCUMULATION_BOUND HAS NOTHING IN ITS TOP BYTE.
! %IF ACCUMULATING=0 %THEN %START
! ACCUMULATING = -1
! FINAL BOUND = 1
! FINAL ADDR = SSOWN_IN CHAR ADDR
! %IF FINAL ADDR=0 %AND SSOWN_SAVE PTR<SSOWN_SAVE LIM %THEN %START
! FINAL ADDR = SSOWN_SAVE PTR
! BYTE INTEGER (FINAL ADDR) = SYMB
! SSOWN_SAVE PTR = FINAL ADDR + 1
! %FINISH
! ACCUMULATION_ADDRESS = FINAL ADDR
! %FINISH %ELSE %START
! FINAL BOUND = ACCUMULATION_BOUND + 1
! FINAL ADDR = ACCUMULATION_ADDRESS + ACCUMULATION_BOUND
! %IF FINAL ADDR#SSOWN_IN CHAR ADDR %THEN %START
! %IF FINAL ADDR#SSOWN_SAVE PTR %THEN %START
! FINAL ADDR = SSOWN_SAVE PTR + ACCUMULATION_BOUND
! %IF FINAL ADDR<SSOWN_SAVE LIM %THEN %START
! ! %FOR J=0,1,ACCUMULATION_BOUND-1 %CYCLE
! ! BYTE INTEGER (SSOWN_SAVE PTR + J) %C
! ! = BYTE INTEGER (ACCUMULATION_ADDRESS + J)
! ! %REPEAT
! ! EQUIVALENT TO:
! MOVE (ACCUMULATION_BOUND,ACCUMULATION_ADDRESS,SSOWN_SAVE PTR)
! ACCUMULATION_ADDRESS = SSOWN_SAVE PTR
! %FINISH
! %FINISH
! %IF FINAL ADDR<SSOWN_SAVE LIM %THEN %START
! BYTE INTEGER (FINAL ADDR) = SYMB
! SSOWN_SAVE PTR = FINAL ADDR + 1
! %FINISH %ELSE %START
! ACCUMULATION_ADDRESS = 0
! %FINISH
! %FINISH
! %FINISH
! ACCUMULATION_BOUND = FINAL BOUND
! %END
!
ROUTINE GATHER DATA (STRING NAME DELIMITER, INTEGER GC)
! GC=1 FOR 'SKIP DATA'.
! GC=2 FOR 'ADD DATA TO ACCUMULATION' - I.E., SAVE THE
! DATA BUT DON'T DO THE 'TIDY ACCUMULATION'
! UNLESS YOU FIND END-OF-FILE.
! GC=3 FOR 'ACCUMULATE DATA'.
INTEGER FINAL BOUND, FINAL ADDR, DISCARD
! %INTEGER J; ! ONLY NEEDED IF WE DO NOT USE MOVE.
INTEGER S, LINE POS, MATCHES EOD, TARGET
!
!
IF SSOWN_ACCUMULATING#0 THEN FINAL BOUND = SSOWN_ACCUMULATION_BOUND
! THAT IS NOT STRICTLY NECESSARY IF GC=1, BUT I DON'T
! THINK YOU COULD HAVE GC=1 %AND SSOWN_ACCUMULATING#0
! IN FACT, AND IN ANY CASE THE ASSIGNMENT WOULD BE
! HARMLESS. I BELIEVE THAT SSOWN_ACCUMULATING WILL BE
! NON-ZERO ONLY IF GC=2 ON ENTRY. THE TEST FOR
! SSOWN_ACCUMULATING#0 IS NECESSARY BECAUSE SSOWN_ACCUMULATION
! IS UNASSIGNED ON FIRST ENTRY TO THE INTERPRETER.
IF GC=3 THEN START
WHILE NL#SSOWN_LAST CHAR READ#25 CYCLE
DISCARD = MASTER CHAR IN (1)
REPEAT
FINISH
LINE POS = 1
MATCHES EOD = -1
WHILE 1<=GC<=3 CYCLE
S = MASTER CHAR IN (1)
IF S=25 THEN START
IF SSOWN_ACCUMULATING#0 THEN START ; ! TIDY SSOWN_ACCUMULATION (0)
SSOWN_ACCUMULATING = 0
SSOWN_ACCUMULATION_BOUND = FINAL BOUND ! X'18000000'
FINISH
SSOWN_WARNING NUMBER = 15
SSOWN_STATE = 10; ! CLOSING DOWN
GC = 0; ! TO FORCE EXIT FROM 'GATHER DATA'.
FINISH ELSE START
IF GC#1 THEN START ; ! SAVE SYMBOL (S)
! <<<< <<<< <<<<
!
! THIS ASSUMES WHAT IS IN FACT TRUE - BUT WILL IT ALWAYS BE
! TRUE? - THAT SSOWN_ACCUMULATION_BOUND HAS NOTHING IN ITS TOP BYTE.
IF SSOWN_ACCUMULATING=0 THEN START
SSOWN_ACCUMULATING = -1
FINAL BOUND = 1
FINAL ADDR = SSOWN_IN CHAR ADDR
IF FINAL ADDR=0 AND SSOWN_SAVE PTR<SSOWN_SAVE LIM THEN START
FINAL ADDR = SSOWN_SAVE PTR
BYTE INTEGER (FINAL ADDR) = S
SSOWN_SAVE PTR = FINAL ADDR + 1
FINISH
SSOWN_ACCUMULATION_ADDRESS = FINAL ADDR
FINISH ELSE START
FINAL ADDR = SSOWN_ACCUMULATION_ADDRESS + FINAL BOUND
IF FINAL ADDR#SSOWN_IN CHAR ADDR THEN START
IF FINAL ADDR#SSOWN_SAVE PTR THEN START
FINAL ADDR = SSOWN_SAVE PTR + FINAL BOUND
IF FINAL ADDR<SSOWN_SAVE LIM THEN START
! %FOR J=0,1,FINAL BOUND-1 %CYCLE
! BYTE INTEGER (SSOWN_SAVE PTR + J) %C
! = BYTE INTEGER (SSOWN_ACCUMULATION_ADDRESS + J)
! %REPEAT
! EQUIVALENT TO:
MOVE (FINAL BOUND,SSOWN_ACCUMULATION_ADDRESS,SSOWN_SAVE PTR)
SSOWN_ACCUMULATION_ADDRESS = SSOWN_SAVE PTR
FINISH
FINISH
IF FINAL ADDR<SSOWN_SAVE LIM THEN START
BYTE INTEGER (FINAL ADDR) = S
SSOWN_SAVE PTR = FINAL ADDR + 1
FINISH ELSE START
SSOWN_ACCUMULATION_ADDRESS = 0
FINISH
FINISH
FINAL BOUND = FINAL BOUND + 1
FINISH
! >>>> >>>> >>>>
FINISH
IF S#NL THEN START
IF MATCHES EOD#0 THEN START
IF LINE POS<=LENGTH(DELIMITER) THEN START
TARGET = BYTE INTEGER C
(ADDR(DELIMITER)+LINE POS)
FINISH ELSE START
TARGET = ' '
FINISH
IF S#TARGET THEN MATCHES EOD = 0
FINISH
FINISH ELSE START
IF MATCHES EOD=0 C
OR LINE POS<=LENGTH(DELIMITER) C
THEN START
LINE POS = 0
MATCHES EOD = -1
FINISH ELSE START
IF GC=2 THEN SSOWN_ACCUMULATION_BOUND = FINAL BOUND
IF GC=3 C
THEN START ; ! TIDY SSOWN_ACCUMULATION (LINE POS)
SSOWN_ACCUMULATING = 0
SSOWN_ACCUMULATION_BOUND = C
(FINAL BOUND-LINE POS) ! X'18000000'
FINISH
SSOWN_WARNING NUMBER = 0
GC = 0; ! TO FORCE EXIT.
FINISH
FINISH
LINE POS = LINE POS + 1
FINISH
REPEAT
END
!
ROUTINE DISCARD DATA HEADER (STRING NAME HDR)
INTEGER DLSIZE, BOUND, I, L, C, A
A = SSOWN_ACCUMULATION_ADDRESS
BOUND = SSOWN_ACCUMULATION_BOUND & X'00FFFFFF'
DLSIZE = LENGTH (HDR)
IF BOUND>=DLSIZE THEN START
!
! **** **** REPLACE THE FOLLOWING BY MACHINE CODE **** ****
I = 1
WHILE I<=DLSIZE C
AND BYTE INTEGER(A+I-1)=BYTE INTEGER(ADDR(HDR)+I) C
CYCLE
I = I + 1
REPEAT
! **** **** END OF MACHINE CODE SECTION **** ****
!
IF I>DLSIZE THEN START
! WE HAVE MATCHED THE WHOLE OF THE HEADER IN THE DATA.
! PREPARE TO EXAMINE BYTES OF DATA BEYOND HEADER.
I = A + DLSIZE
IF BOUND>DLSIZE THEN START
! IF THERE ARE ANY SUCH BYTES.
!
! **** **** REPLACE BY MACHINE CODE: **** ****
UNTIL I=A+BOUND OR C#' ' CYCLE
C = BYTE INTEGER (I)
I = I + 1
REPEAT
! **** **** END OF MACHINE CODE SECTION **** ****
!
FINISH ELSE START ; ! BOUND=DLSIZE, SO I ALREADY =A+BOUND.
C = NL
FINISH
UNLESS NL#C#' ' THEN START
L = I - A
SSOWN_ACCUMULATION_BOUND = SSOWN_ACCUMULATION_BOUND - L
SSOWN_ACCUMULATION_ADDRESS = A + L
FINISH
FINISH
FINISH
END
!
SYSTEM ROUTINE SUPPLY DATA DESCRIPTOR (RECORD (PD) NAME DR)
PROMPT ("Data:")
SSOWN_LAST PROMPT = -1
GATHER DATA (SSOWN_D DELIM 2, 3)
IF SSOWN_ACCUMULATION_ADDRESS#0 THEN DISCARD DATA HEADER (SSOWN_D DELIM 1)
DR = SSOWN_ACCUMULATION
END
!
!
! MAXPCT IS THE MAXIMUM NUMBER OF PARAMETERS ALLOWED FOR ONE
! MACRO, AND MAXKNL IS THE MAXIMUM ALLOWED LENGTH FOR
! KEYWORDS.
CONST INTEGER MAXPCT = 24, MAXKNL = 11
!
!
!
! BRACKET FLAG=0 MEANS 'NO BRACKETS',
! #0 MEANS 'BRACKETS'.
! %EXTERNAL %INTEGER BRACKET FLAG = 0
!
!
!
STRING (255) FN PURGE (STRING NAME D, F, INTEGER NAME L)
! THIS FUNCTION STARTS AT THE BEGINNING OF STRING 'D', AND (ASSUMING
! 'F' IS THE CORRESPONDING FLAGS STRING) DISCARDS ALL SPACES AND
! ACCUMULATES ALL OTHER CHARACTERS. IT WILL, HOWEVER, NEVER
! ACCUMULATE ANY CHARACTERS IN QUOTES OR IN BRACKETS, NOR THE
! ENCLOSING QUOTES OR BRACKETS. IT STOPS AS SOON AS IT FINDS THE FIRST
! SUCH CHARACTER, LEAVING THE 'DISPLACEMENT-WITHIN-STRING' OF THAT
! CHARACTER IN 'L'. IF IT FINDS NO SUCH CHARACTER, 'L' WILL BE EQUAL
! TO LENGTH(D)+1.
STRING (255) Q
INTEGER I, S, P
L = LENGTH (D) + 1
I = 1
P = 0
WHILE I<L CYCLE
S = BYTE INTEGER (ADDR(F)+I)
IF S#'A' THEN START
IF S='C' THEN START
P = P + 1
BYTE INTEGER (ADDR(Q)+P) = BYTE INTEGER (ADDR(D)+I)
FINISH ELSE L = I
FINISH
I = I + 1
REPEAT
LENGTH (Q) = P
! L IS THE "ADDRESS" IN THE STRING OF THE FIRST CHARACTER NOT ACCEPTED.
IF DIAGOP#0 THEN START
PRINT STRING ("++++ Purging: """.D.""" yields """.Q."""")
IF L<=LENGTH(D) THEN START
PRINT STRING (" with residue """.SUBSTRING(D,L,LENGTH(D))."""")
FINISH
NEWLINE
PRINT STRING (" ".F)
NEWLINE
FINISH
RESULT = Q
END
!
ROUTINE FIND FIELD (STRING NAME FLAG STRING, C
INTEGER S, C
INTEGER NAME F, L, E)
! THIS ROUTINE SCANS THE STRING 'FLAG STRING' TO FIND
! A FIELD OF CONSECUTIVE 'C' SYMBOLS. IT STARTS AT A
! SPECIFIED POSITION IN THE STRING, AND RETURNS INTEGERS
! SPECIFYING THE POSITION OF THE FIELD IF ONE IS FOUND.
!
! S IS THE 'SEARCH START POSITION' IN THE STRING.
! E IS THE 'EXISTENCE FLAG', NON-ZERO ON EXIT IFF
! A FIELD WAS FOUND.
! F IS THE 'FIELD START POSITION' IN THE STRING.
! L IS THE 'FIRST POSITION BEYOND END OF STRING'. THE FIELD
! WILL BE IN POSITIONS F TO L-1, AND THE NEXT SEARCH SHOULD
! START IN POSITION L+1.
! F AND L WILL NOT BE ASSIGNED IF E IS ZERO ON EXIT (I.E., NO
! FIELD FOUND).
!
INTEGER SEARCH LIM
SEARCH LIM = LENGTH (FLAG STRING)
!
! **** **** THIS COULD BE REPLACED BY MACHINE CODE **** ****
WHILE S<=SEARCH LIM C
AND BYTE INTEGER(ADDR(FLAG STRING)+S)#'C' C
CYCLE
S = S + 1
REPEAT
! **** **** END OF MACHINE CODE SECTION **** ****
!
IF S>SEARCH LIM C
THEN E = 0 C
ELSE START
E = -1
F = S
!
! **** **** THIS COULD BE REPLACED BY MACHINE CODE **** ****
UNTIL S>SEARCH LIM C
OR BYTE INTEGER(ADDR(FLAG STRING)+S)#'C' C
CYCLE
S = S + 1
REPEAT
! **** **** END OF MACHINE CODE SECTION **** ****
!
L = S
FINISH
END
!
IF ULCEQUIV=0 THEN START
INTEGER FN RECOGNISE KWD (STRING NAME P)
!
! IF YOU OFFER THIS FUNCTION A STRING, IT WILL RETURN ZERO IF
! IT CANNOT RECOGNISE THE STRING, OR
! 1 FOR ".GOTO",
! 2 FOR ".IF",
! 3 FOR ".THEN",
! 4 FOR ".ELSE",
! 5 FOR ".START",
! 6 FOR ".FINISH",
! 7 FOR ".WHENEVER"
!
CONST STRING (10) ARRAY KEYS (1:KWDS) = ".GOTO",
".IF",
".THEN",
".ELSE",
".START",
".FINISH",
".WHENEVER"
INTEGER I
FOR I=1,1,KWDS CYCLE
IF P=KEYS(I) THEN RESULT = I
REPEAT
RESULT = 0
END
FINISH ELSE START
INTEGER FN RECOGNISE KWD (STRING (80) P)
!
! IF YOU OFFER THIS FUNCTION A STRING, IT WILL RETURN ZERO IF
! IT CANNOT RECOGNISE THE STRING, OR
! 1 FOR ".GOTO",
! 2 FOR ".IF",
! 3 FOR ".THEN",
! 4 FOR ".ELSE",
! 5 FOR ".START",
! 6 FOR ".FINISH",
! 7 FOR ".WHENEVER"
!
CONST STRING (10) ARRAY KEYS (1:KWDS) = ".GOTO",
".IF",
".THEN",
".ELSE",
".START",
".FINISH",
".WHENEVER"
INTEGER I
UCTRANSLATE (ADDR(P)+1,LENGTH(P))
FOR I=1,1,KWDS CYCLE
IF P=KEYS(I) THEN RESULT = I
REPEAT
RESULT = 0
END
FINISH
!
!
! %ROUTINE LINE IN (%STRING %NAME TEXT, %INTEGER %NAME R)
! !
! ! THIS READS A LINE OF TEXT INTO %STRING 'TEXT', USING 'MASTER CHAR IN'.
! ! TRAILING SPACES AND THE FINAL 'NEWLINE' CHARACTER ARE NOT INCLUDED IN
! ! THE TEXT RETURNED TO THE CALLER. RESULTS ARE:
! ! 0 - O.K.
! ! 3 - END OF FILE FOUND
! ! 4 - LINE TOO LONG
! !
! ! THE DECLARED MAXIMUM LENGTH OF 'TEXT' MUST BE 255.
! !
! %INTEGER INDEX, SPACES, C
! R = 0
! !
! ! **** **** REPLACE BY MACHINE CODE **** ****
! %FOR INDEX = 1,1,255 %CYCLE
! BYTE INTEGER (ADDR(TEXT)+INDEX) = ' '
! %REPEAT
! ! **** **** END OF MACHINE CODE SECTION **** ****
! !
! SPACES = 0
! INDEX = 0
! %UNTIL C=NL %CYCLE
! C = MASTER CHAR IN (1)
! %IF C=25 %THEN %START
! C = NL
! R = 3
! %FINISH
! %IF C#NL %THEN %START
! %IF C=' ' %C
! %THEN SPACES = SPACES + 1 %C
! %ELSE %START
! INDEX = INDEX + SPACES + 1
! SPACES = 0
! %IF INDEX<=255 %C
! %THEN BYTE INTEGER (ADDR(TEXT)+INDEX) = C %C
! %ELSE %START
! INDEX = 255
! R = 4
! %FINISH
! %FINISH
! %FINISH
! %REPEAT
! LENGTH (TEXT) = INDEX
! !
! %END
!
!
!
!
! %ROUTINE TIDY LINE (%STRING %NAME RAW, RECON, MARKS, %C
! %INTEGER %NAME STATE, BL, %INTEGER QC)
! !
! ! THIS ROUTINE DOES MULTIPLE SPACE REDUCTION, BRACKET COUNTING,
! ! ELIMINATION OF COMMENTS, AND RECOGNITION OF TEXT IN QUOTES.
! ! THE ORIGINAL TEXT IN 'RAW' SHOULD CONTAIN NO NEWLINE CHARACTER.
! ! RECONSTRUCTED TEXT WILL BE APPENDED TO 'RECON', AND FLAG BYTES
! ! PUT IN THE CORRESPONDING POSITIONS IN 'MARKS'. IT IS THE
! ! CALLER'S RESPONSIBILITY TO INITIALISE 'RECON' WITH A NULL STRING
! ! BEFORE CALLING 'TIDY LINE' IF NECESSARY. HE HAS ALSO TO
! ! CLEAR 'BL' (BRACKET LEVEL) TO ZERO AND INITIALISE 'STATE' TO 1.
! ! ON EXIT, 'STATE' WILL BE 2 NORMALLY, OR 3 IF THE END OF THE INPUT
! ! LINE WAS REACHED 'IN QUOTES'. IF THE TEXT HAS OVERFLOWED 'RECON',
! ! THEN 'STATE' WILL BE 255. 'BL' WILL GIVE THE DEPTH OF BRACKETING
! ! REMAINING AT THE END OF LINE. 'QC' CONTROLS WHETHER TWO CONSECUTIVE
! ! QUOTE MARKS WITHIN QUOTES WILL BE REDUCED TO A SINGLE QUOTE (QC#0), OR
! ! NOT REDUCED (QC=0). IF IT IS CERTAIN THAT 'QC' WILL ALWAYS BE ZERO,
! ! THEN STATE 5 BECOMES REDUNDANT IN THE CODE BELOW.
! ! THE DECLARED MAXIMUM LENGTH OF 'RECON' AND 'MARKS' MUST BE 255.
! ! THE FLAG BYTES PUT INTO 'MARKS' ARE DESCRIBED IN THE COMMENT FOR
! ! 'GET STMT'.
! %CONST %BYTE %INTEGER %ARRAY MARKER (1:5,0:5) = %C
! 'E', 'E', 'E', ' ', 'E',
! ' ', 'A', 'E', ' ', 'A',
! ' ', 'A', 'E', ' ', 'A',
! 'C', 'C', 'E', ' ', 'C',
! 'C', 'C', 'E', ' ', 'C',
! 'C', 'C', 'E', ' ', 'C',
! %CONST %BYTE %INTEGER %ARRAY NEXT STATE (1:5,0:5) = %C
! 3, 3, 5, 4, 3,
! 4, 4, 3, 1, 4,
! 1, 1, 3, 4, 1,
! 2, 2, 3, 4, 2,
! 2, 2, 3, 4, 2,
! 2, 2, 3, 4, 2,
! %CONST %BYTE %INTEGER %ARRAY ACTIONS (1:5,0:5) = %C
! 0, 0, 0, 0, 3,
! 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0,
! 1, 1, 0, 0, 1,
! 2, 2, 0, 0, 2,
! 0, 0, 0, 0, 0,
! %SWITCH PROCESS (0:3)
! %INTEGER C, D, CSW, L, I, LR
! %STRING (4) RESIDUE
! I = 1
! L = LENGTH (RECON)
! LR = LENGTH (RAW) + 1
! %WHILE I<LR %CYCLE
! C = BYTE INTEGER (ADDR(RAW)+I)
! !
! ! **** **** REPLACE BY MACHINE CODE **** ****
! %IF SSOWN_SPECHARS->RESIDUE.(TOSTRING(C)) %C
! %THEN CSW = LENGTH (RESIDUE) %C
! %ELSE CSW = 5
! ! **** **** END OF MACHINE CODE SECTION **** ****
! !
! ! CSW WILL BE -
! ! 0 FOR DOUBLE-QUOTE,
! ! 1 FOR COMMENT SYMBOL,
! ! 2 FOR A SPACE,
! ! 3 FOR OPEN BRACKET,
! ! 4 FOR CLOSE BRACKET,
! ! 5 FOR ANYTHING ELSE.
! !
! ! VALUES OF 'STATE' ARE -
! ! 1 : START-OF-LINE OR AFTER A SPACE,
! ! 2 : NORMAL,
! ! 3 : IN QUOTES,
! ! 4 : IN COMMENT,
! ! 5 : AFTER A CLOSING QUOTE.
! !
! D = MARKER (STATE, CSW)
! -> PROCESS (ACTIONS(STATE,CSW))
! !
! PROCESS (1):
! BL = BL + 1
! -> PLANT
! !
! PROCESS (2):
! %IF BL>0 %THEN %START
! BL = BL - 1
! %IF BL=0 %THEN D = 'D'
! %FINISH
! -> PLANT
! !
! PROCESS (3):
! %IF QC#0 %THEN D='D'
! ! -> PLANT
! !
! PROCESS (0):
! PLANT:
! STATE = NEXT STATE (STATE, CSW)
! %IF D#' ' %THEN %START
! %IF D='A' %THEN C = ' '
! %IF BL>0 %THEN D = D + 1
! %IF L>=255 %THEN %START
! STATE = 255
! I = LR; ! ENSURES EXIT FROM THE LOOP.
! %FINISH %ELSE %START
! L = L + 1
! BYTE INTEGER (ADDR(RECON)+L) = C
! BYTE INTEGER (ADDR(MARKS)+L) = D
! %FINISH
! %FINISH
! I = I + 1
! %REPEAT
! %IF STATE=1 %AND L>0 %THEN L = L - 1
! %IF 255#STATE#3 %THEN STATE = 2
! LENGTH (RECON) <- L
! LENGTH (MARKS) <- L
! !
! %END
!
!
ROUTINE GET STMT C
(INTEGER BRACKET OPTION, C
INTEGER QUOTE CONTRACTION, C
INTEGER COMM, C
STRING (80) D DELIM 1, C
STRING (80) CONT, C
STRING (80) CANCEL, C
STRING NAME INPUT, C
STRING NAME RECON, C
STRING NAME MARKS, C
INTEGER NAME F)
!
! THIS ROUTINE READS A COMPLETE STATEMENT VIA 'MASTER CHAR IN'
! (I.E., THROUGH THE MACRO EXPANSION PROCESS WHEN APPROPRIATE).
! THE UNPROCESSED TEXT WILL BE COPIED INTO THE STRING 'INPUT'.
! THE LAST CHARACTER READ WILL ALWAYS BE A NEWLINE (OR END-OF-FILE)
! UNLESS THE TEXT OVERFLOWS 'INPUT', IN WHICH CASE READING STOPS
! AT THAT POINT.
! THE TEXT AFTER RECONSTRUCTION IS PUT INTO 'RECON'. RECONSTRUCTION
! MEANS THAT -
! EACH COMMENT IS REPLACED BY A SINGLE SPACE.
! QUOTES ARE PROPERLY MATCHED, SO THAT A NEWLINE IN QUOTES DOES NOT
! TERMINATE A STATEMENT. NO LINE RECONSTRUCTION IS APPLIED TO TEXT
! IN QUOTES (EXCEPT TRAILING SPACE DELETION).
! IF THE 'BRACKETS' OPTION IS USED, BRACKETS ARE PROPERLY MATCHED, AND
! A NEWLINE WITHIN BRACKETS DOES NOT TERMINATE THE STATEMENT. IT IS
! REPLACED BY A SINGLE SPACE, AND THE TEXT FROM THE NEXT LINE IS
! PROCESSED AS PART OF THE STATEMENT.
! WHERE A LINE ENDS WITH THE CONTINUATION MARKER, ALL CHARACTERS FROM
! THE MARKER TO THE NEWLINE ARE REPLACED BY A SINGLE SPACE, AND
! THE TEXT FROM THE NEXT LINE IS PROCESSED AS PART OF THE STATEMENT.
! THE TERMINATING NEWLINE OR END-OF-FILE CHARACTER WILL HAVE BEEN
! REMOVED, AND THE TEXT WILL HAVE NO LEADING OR TRAILING SPACES.
! ALL MULTIPLE SPACES, EXCEPT IN QUOTES, ARE REPLACED BY SINGLE SPACES.
!
! BRACKET OPTION=0 MEANS 'ASSUME NOBRACKETS'
! #0 MEANS 'ASSUME BRACKETS OPTION'.
! QUOTE CONTRACTION#0 MEANS 'REDUCE "" TO " IF ALREADY IN QUOTES'
! =0 MEANS DON'T.
! COMM IS THE (SINGLE BYTE) COMMENT SYMBOL.
! D DELIM 1 IS THE OPENING DATA DELIMITER.
! CONT IS THE CONTINUATION MARKER.
! RAW TEXT WILL BE PUT INTO 'INPUT'.
! TEXT AFTER LINE RECONSTRUCTION WILL BE PUT INTO 'RECON'.
! CORRESPONDING TO EACH BYTE IN 'RECON' WILL BE ONE BYTE IN THE SAME
! POSITION IN 'MARKS'.
! 'MARKS' WILL GET:
! IN PLAIN TEXT IN BRACKETS
! SPACE OR NEWLINE A B
! TEXT C D
! TEXT IN QUOTES E F
!
! THE OUTER BRACKETS (AND OF COURSE INNER BRACKETS ALSO)
! IN A SEQUENCE OF TEXT-IN-BRACKETS GET THE FLAG 'D'.
! THE OUTER QUOTES IN A SEQUENCE OF TEXT-IN-QUOTES GET THE
! FLAG 'E', OR 'F' IF IN BRACKETS.
!
! THE MAXIMUM LENGTH OF THE STRINGS INPUT, RECON AND MARKS MUST BE 255.
!
! 'F' WILL GET A VALUE TO INDICATE THE SUCCESS OR FAILURE OF
! GET STMT, AS FOLLOWS:
! F = 0: O.K.
! F = 1: OPENING DATA DELIMITER FOUND.
! F = 2: INCOMPLETE STATEMENT BEFORE DATA DELIMITER.
! F = 3: INCOMPLETE STATEMENT BEFORE END OF FILE.
! F = 4: STATEMENT TOO LONG.
! F = -1: PARAMETERS UNACCEPTABLE.
!
CONST BYTE INTEGER ARRAY MARKER (1:5,0:5) = C
'E', 'E', 'E', ' ', 'E',
' ', 'A', 'E', ' ', 'A',
' ', 'A', 'E', ' ', 'A',
'C', 'C', 'E', ' ', 'C',
'C', 'C', 'E', ' ', 'C',
'C', 'C', 'E', ' ', 'C'
CONST BYTE INTEGER ARRAY NEXT STATE (1:5,0:5) = C
3, 3, 5, 4, 3,
4, 4, 3, 1, 4,
1, 1, 3, 4, 1,
2, 2, 3, 4, 2,
2, 2, 3, 4, 2,
2, 2, 3, 4, 2
CONST BYTE INTEGER ARRAY ACTIONS (1:5,0:5) = C
0, 0, 0, 0, 3,
0, 0, 0, 0, 0,
0, 0, 0, 0, 0,
1, 1, 0, 0, 1,
2, 2, 0, 0, 2,
0, 0, 0, 0, 0
SWITCH PROCESS (0:3)
INTEGER D, CSW, L, I
STRING (4) RESIDUE
INTEGER LC, LR, LS, BL, IC, BM, STATE, PARMS OK
INTEGER INDEX, SPACES, C
!
! CHECK PARAMETERS:
PARMS OK = -1; ! TRUE.
LC = LENGTH (CONT)
BEGIN
STRING (255) C1, C2
IF CONT="" C
OR D DELIM 1="" C
OR COMM=' ' C
OR COMM='"' C
OR CONT->C1.(TOSTRING(COMM)).C2 C
OR CONT->C1.(" ").C2 C
OR CONT->C1.("""").C2 C
OR D DELIM 1->C1.(TOSTRING(COMM)).C2 C
OR D DELIM 1->C1.(" ").C2 C
OR D DELIM 1->C1.("""").C2 C
OR D DELIM 1->C1.(CONT).C2 C
OR CONT->C1.(D DELIM 1).C2 C
OR LENGTH(CANCEL)#LC C
THEN PARMS OK = 0; ! FALSE.
END
IF PARMS OK=0 THEN START
F = -1
RETURN
FINISH
!
!
STATE = 1
BL = 0
RECON = ""
MARKS = ""
UNTIL F#5 CYCLE
! LINE IN (INPUT, F)
! <<<<
!
! THIS READS A LINE OF TEXT INTO %STRING 'INPUT', USING 'MASTER CHAR IN'.
! TRAILING SPACES AND THE FINAL 'NEWLINE' CHARACTER ARE NOT INCLUDED IN
! THE TEXT RETURNED TO THE CALLER. RESULTS ARE:
! 0 - O.K.
! 3 - END OF FILE FOUND
! 4 - LINE TOO LONG
!
! THE DECLARED MAXIMUM LENGTH OF 'INPUT' MUST BE 255.
!
F = 0
!
! **** **** REPLACE BY MACHINE CODE **** ****
FOR INDEX = 1,1,255 CYCLE
BYTE INTEGER (ADDR(INPUT)+INDEX) = ' '
REPEAT
! **** **** END OF MACHINE CODE SECTION **** ****
!
SPACES = 0
INDEX = 0
UNTIL C=NL CYCLE
C = MASTER CHAR IN (1)
IF C=25 THEN START
C = NL
F = 3
FINISH
IF C#NL THEN START
IF C=' ' C
THEN SPACES = SPACES + 1 C
ELSE START
INDEX = INDEX + SPACES + 1
SPACES = 0
IF INDEX<=255 C
THEN BYTE INTEGER (ADDR(INPUT)+INDEX) = C C
ELSE START
INDEX = 255
F = 4
FINISH
FINISH
FINISH
REPEAT
LENGTH (INPUT) = INDEX
!
! >>>>
IF F=0 THEN START
IF INPUT=D DELIM 1 C
THEN F = 1 C
ELSE START
! TIDY LINE (INPUT,RECON,MARKS,STATE,BL,QUOTE CONTRACTION)
! <<<< <<<< <<<<
!
! THIS ROUTINE DOES MULTIPLE SPACE REDUCTION, BRACKET COUNTING,
! ELIMINATION OF COMMENTS, AND RECOGNITION OF TEXT IN QUOTES.
! THE ORIGINAL TEXT IN 'INPUT' SHOULD CONTAIN NO NEWLINE CHARACTER.
! RECONSTRUCTED TEXT WILL BE APPENDED TO 'RECON', AND FLAG BYTES
! PUT IN THE CORRESPONDING POSITIONS IN 'MARKS'. IT IS THE
! CALLER'S RESPONSIBILITY TO INITIALISE 'RECON' WITH A NULL STRING
! BEFORE CALLING 'TIDY LINE' IF NECESSARY. HE HAS ALSO TO
! CLEAR 'BL' (BRACKET LEVEL) TO ZERO AND INITIALISE 'STATE' TO 1.
! ON EXIT, 'STATE' WILL BE 2 NORMALLY, OR 3 IF THE END OF THE INPUT
! LINE WAS REACHED 'IN QUOTES'. IF THE TEXT HAS OVERFLOWED 'RECON',
! THEN 'STATE' WILL BE 255. 'BL' WILL GIVE THE DEPTH OF BRACKETING
! REMAINING AT THE END OF LINE. 'QUOTE CONTRACTION' CONTROLS WHETHER
! TWO CONSECUTIVE QUOTE MARKS WITHIN QUOTES WILL BE REDUCED TO A SINGLE
! QUOTE (QUOTE CONTRACTION#0), OR NOT REDUCED (QUOTE CONTRACTION=0).
! IF IT IS CERTAIN THAT 'QUOTE CONTRACTION' WILL ALWAYS BE ZERO,
! THEN STATE 5 BECOMES REDUNDANT IN THE CODE BELOW.
! THE DECLARED MAXIMUM LENGTH OF 'RECON' AND 'MARKS' MUST BE 255.
! THE FLAG BYTES PUT INTO 'MARKS' ARE DESCRIBED IN THE COMMENT FOR
! 'GET STMT'.
I = 1
L = LENGTH (RECON)
LR = LENGTH (INPUT) + 1
WHILE I<LR CYCLE
C = BYTE INTEGER (ADDR(INPUT)+I)
!
! **** **** REPLACE BY MACHINE CODE **** ****
IF SSOWN_SPECHARS->RESIDUE.(TOSTRING(C)) C
THEN CSW = LENGTH (RESIDUE) C
ELSE CSW = 5
! **** **** END OF MACHINE CODE SECTION **** ****
!
! CSW WILL BE -
! 0 FOR DOUBLE-QUOTE,
! 1 FOR COMMENT SYMBOL,
! 2 FOR A SPACE,
! 3 FOR OPEN BRACKET,
! 4 FOR CLOSE BRACKET,
! 5 FOR ANYTHING ELSE.
!
! VALUES OF 'STATE' ARE -
! 1 : START-OF-LINE OR AFTER A SPACE,
! 2 : NORMAL,
! 3 : IN QUOTES,
! 4 : IN COMMENT,
! 5 : AFTER A CLOSING QUOTE.
!
D = MARKER (STATE, CSW)
-> PROCESS (ACTIONS(STATE,CSW))
!
PROCESS (1):
BL = BL + 1
-> PLANT
!
PROCESS (2):
IF BL>0 THEN START
BL = BL - 1
IF BL=0 THEN D = 'D'
FINISH
-> PLANT
!
PROCESS (3):
IF QUOTE CONTRACTION#0 THEN D='D'
! -> PLANT
!
PROCESS (0):
PLANT:
STATE = NEXT STATE (STATE, CSW)
IF D#' ' THEN START
IF D='A' THEN C = ' '
IF BL>0 THEN D = D + 1
IF L>=255 THEN START
STATE = 255
I = LR; ! ENSURES EXIT FROM THE LOOP.
FINISH ELSE START
L = L + 1
BYTE INTEGER (ADDR(RECON)+L) = C
BYTE INTEGER (ADDR(MARKS)+L) = D
FINISH
FINISH
I = I + 1
REPEAT
IF STATE=1 AND L>0 THEN L = L - 1
IF 255#STATE#3 THEN STATE = 2
LENGTH (RECON) <- L
LENGTH (MARKS) <- L
!
! >>>> >>>> >>>>
LR = LENGTH (RECON)
LS = LR
IC = ' '; ! CHARACTER TO INSERT IF WE NEED TO TAG ANOTHER
! LINE ONTO THIS ONE.
BM = 'A'; ! MARKER TO INSERT.
IF STATE=3 THEN START ; ! IN QUOTES.
IF LR<255 THEN START
IC = NL
BM = 'E'
LS = LR + 1
FINISH ELSE STATE = 255
FINISH ELSE START
IF STATE=2 THEN START
LS = LR - LC
IF LS>=0 THEN START
IF SUBSTRING (RECON,LS+1,LR)=CONT C
THEN START
LR = LS
STATE = 1
IF LS#0 C
AND BYTE INTEGER(ADDR(RECON)+LS)#' ' C
THEN LS = LS + 1
FINISH ELSE START
IF SUBSTRING (RECON,LS+1,LR)=CANCEL C
THEN START
STATE = 1
BL = 0
LS = 0
FINISH ELSE START
IF BL>0 AND BRACKET OPTION#0 C
THEN START
IF LR<255 THEN START
LS = LR + 1
STATE = 1
FINISH ELSE STATE = 255
FINISH
FINISH
FINISH
FINISH
FINISH
FINISH
IF STATE=2 THEN F = 0 ELSE START
IF STATE=255 THEN F = 4 ELSE START
F = 5
IF LS>LR THEN START
IF BL#0 THEN BM = BM + 1
BYTE INTEGER (ADDR(RECON)+LS) = IC
BYTE INTEGER (ADDR(MARKS)+LS) = BM
FINISH
LENGTH (RECON) = LS
LENGTH (MARKS) = LS
FINISH
FINISH
FINISH
FINISH
REPEAT
IF F=1 AND RECON#"" THEN F = 2
RETURN
!
END
!
!
!
!
INTEGER FN CLASSIFY STMT C
(STRING NAME STMT, FLAGS, LABEL STRING, C
PREDICATE STRING, CALL STRING, DEST STRING, PF, CF, DF)
!
! IF YOU OFFER THIS FUNCTION A LINE OF TEXT, IT WILL RETURN:
! 5 FOR "SIMPLE CALL" (OR ANYTHING NOT EXPLICITLY RECOGNISED
! AS ONE OF THE OTHER FORMS),
! 6 FOR ".GOTO",
! 7 FOR ".IF .GOTO",
! 8 FOR ".IF .THEN",
! 9 FOR ".IF .START",
! 10 FOR ".ELSE",
! 11 FOR ".FINISH",
! 12 FOR ".WHENEVER .GOTO",
! 13 FOR ".WHENEVER .THEN",
! 14 FOR ".WHENEVER .START"
! IT ASSUMES THAT 'STMT' HAS BEEN SUCCESSFULLY READ AND RECONSTRUCTED
! BY 'GET STMT' - E.G., 'STMT' MUST CONTAIN NO NEWLINES OR MULTIPLE
! SPACES - AND THAT 'FLAGS' IS THE CORRESPONDING FLAG STRING. 'GET
! STMT' SHOULD HAVE RETURNED A ZERO RESULT ON READING THE LINE. ON
! EXIT, 'LABEL STRING' WILL HAVE ANY LABEL FOUND ON THE LINE, OR
! A NULL STRING IF THE LINE WAS UNLABELLED. IF THE FORM OF THE LINE
! INCLUDES A PREDICATE, THEN THE TEXT OF THE PREDICATE WILL BE COPIED
! INTO 'PRED STRING', AND 'PF' WILL GET THE CORRESPONDING FLAG STRING.
! SIMILARLY 'CALL STRING' AND 'CF' WILL BE USED FOR ANY CALL, AND
! 'DEST STRING' AND 'DF' FOR THE DESTINATION OF ANY '.GOTO'. THESE
! STRINGS MAY BE NULL IF THE FORM OF LINE INCLUDES THE APPROPRIATE PART
! BUT THE ACTUAL LINE HAD NO TEXT IN THE RELEVANT PLACE. IF THE PART IS
! NOT REQUIRED IN THE FORM OF THE LINE, THEN THE RELEVANT STRINGS MAY
! NOT BE ASSIGNED AT ALL.
!
STRING (255) FLD
INTEGER DT, KT, FIELD FOUND, FIELD START, FIELD END
INTEGER PRED START, SEARCH START, CPTR
SWITCH PKWD (0:KWDS); ! BOUNDS MUST COVER ALL VALUES WHICH CAN COME
! FROM 'RECOGNISE KWD'.
!
LABEL STRING = ""
PREDICATE STRING = ""; PF = ""
CALL STRING = ""; CF = ""
DEST STRING = ""; DF = ""
IF STMT="" THEN RESULT = 5
FIELD FOUND = 0
SEARCH START = 1
UNTIL FIELD FOUND#0 CYCLE
FIND FIELD (FLAGS, SEARCH START, C
FIELD START, FIELD END, FIELD FOUND)
IF FIELD FOUND=0 OR FIELD START#SEARCH START THEN START
CALL STRING = SUBSTRING (STMT, SEARCH START, LENGTH(STMT))
CF = SUBSTRING (FLAGS, SEARCH START, LENGTH(FLAGS))
RESULT = 5
FINISH
IF SEARCH START=1 THEN START
CPTR = 1
!
! **** **** MACHINE CODE **** ****
WHILE CPTR<FIELD END C
AND BYTE INTEGER(ADDR(STMT)+CPTR)#':' C
CYCLE
CPTR = CPTR + 1
REPEAT
! **** **** END OF MACHINE CODE **** ****
!
IF CPTR<FIELD END THEN START
FIELD FOUND = 0
IF CPTR>1 THEN START
LABEL STRING = SUBSTRING (STMT, 1, CPTR-1)
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(LABEL STRING)+1, CPTR-1)
FINISH
FINISH
IF CPTR<LENGTH(FLAGS) C
AND BYTE INTEGER(ADDR(FLAGS)+CPTR+1)='A' C
THEN CPTR = CPTR + 1
IF CPTR>=LENGTH(STMT) THEN RESULT = 5
SEARCH START = CPTR + 1
FINISH
FINISH
REPEAT
FLD = SUBSTRING (STMT,FIELD START,FIELD END-1)
CALL STRING = SUBSTRING (STMT,FIELD START,LENGTH(STMT))
CF = SUBSTRING (FLAGS,FIELD START,LENGTH(FLAGS))
IF FIELD END<=LENGTH(STMT) THEN START
DEST STRING = SUBSTRING (STMT,FIELD END,LENGTH(STMT))
DF = SUBSTRING (FLAGS,FIELD END,LENGTH(FLAGS))
FINISH ; ! %ELSE %START (BUT WE HAVE ALREADY DONE THIS):
! DEST STRING = ""
! DF = ""
! %FINISH
KT = RECOGNISE KWD (FLD)
-> PKWD (KT)
!
PKWD (0): ! NO KEYWORD RECOGNISED:
PKWD (3): ! .THEN:
PKWD (5): ! .START:
RESULT = 5; ! IGNORE THE KEYWORD - PROCESS STATEMENT AS A CALL.
!
PKWD (1): ! GOTO:
IF DEST STRING#"" THEN RESULT = 6
RESULT = 5
!
PKWD (4): ! ELSE:
CALL STRING = DEST STRING
CF = DF
RESULT = 10
!
PKWD (6): ! FINISH:
IF DEST STRING="" THEN RESULT = 11
RESULT = 5
!
PKWD (2): ! .IF:
PKWD (7): ! .WHENEVER:
PRED START = FIELD END
UNTIL FIELD FOUND=0 CYCLE
FIND FIELD (FLAGS,FIELD END+1,FIELD START,FIELD END,FIELD FOUND)
IF FIELD FOUND#0 THEN START
PREDICATE STRING = C
SUBSTRING (STMT,PRED START,FIELD START-1)
PF = SUBSTRING (FLAGS,PRED START,FIELD START-1)
FLD = SUBSTRING (STMT,FIELD START,FIELD END-1)
IF FIELD END<LENGTH(STMT) THEN START
DEST STRING = C
SUBSTRING (STMT,FIELD END,LENGTH(STMT))
DF = SUBSTRING (FLAGS,FIELD END,LENGTH(FLAGS))
FINISH ELSE START
DEST STRING = ""
DF = ""
FINISH
DT = RECOGNISE KWD (FLD)
IF DT=1 THEN START ; ! .GOTO:
IF DEST STRING#"" THEN RESULT = 5 + KT
! 7 FOR .IF - .GOTO,
! 12 FOR .WHENEVER - .GOTO,
! IGNORE .GOTO WITH NO DESTINATION.
FINISH
IF DT=3 THEN START ; ! .THEN:
CALL STRING = DEST STRING
CF = DF
RESULT = 6 + KT
! 8 FOR .IF - .THEN,
! 13 FOR .WHENEVER - .THEN
FINISH
IF DT=5 THEN START
IF DEST STRING="" THEN RESULT = 7 + KT
! 9 FOR .IF - .START,
! 14 FOR .WHENEVER - .START,
! IGNORE .START FOLLOWED BY FURTHER TEXT.
FINISH
FINISH
REPEAT
RESULT = 5
END
!
!
ROUTINE ANALYSE CALL N C
(STRING NAME CS, FS, R, P, INTEGER NAME W)
INTEGER I, NS, NE, NF
R = ""
IF LENGTH(FS)>0 THEN START
! SKIP OVER LEADING SPACES, IF ANY:
! (MULTIPLE SPACES CANNOT OCCUR).
IF BYTE INTEGER (ADDR(FS)+1)='A' THEN I = 2 ELSE I = 1
IF I<=LENGTH(FS) THEN START
FIND FIELD (FS, I, NS, NE, NF)
IF NF#0 AND NS=I THEN START
R = SUBSTRING (CS, NS, NE-1)
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(R)+1, LENGTH(R))
FINISH
IF NE<=LENGTH(FS) THEN START
IF BYTE INTEGER(ADDR(FS)+NE)#'A' C
THEN W = 16 C
ELSE START
IF NE<LENGTH(FS) THEN START
IF BYTE INTEGER(ADDR(FS)+LENGTH(FS)) C
='A' C
THEN P = SUBSTRING C
(CS,NE+1,LENGTH(FS)-1) C
ELSE P = SUBSTRING C
(CS,NE+1,LENGTH(FS))
FINISH
FINISH
FINISH
FINISH ELSE W = 16
FINISH
FINISH
END
!
ROUTINE ANALYSE CALL B C
(STRING NAME CS, FS, R, P, INTEGER NAME W)
INTEGER E, I, NS, NE
R = PURGE (CS, FS, NS)
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(R)+1, LENGTH(R))
FINISH
IF NS<=LENGTH(CS) THEN START
IF R="" THEN W = 16 ELSE START
I = NS
NE = LENGTH (CS) + 1
UNTIL I>=NE CYCLE
E = BYTE INTEGER (ADDR(FS)+I)
IF E#'B' AND E#'D' AND E#'F' THEN NE = I
I = I + 1
REPEAT
IF NE<=LENGTH(CS) THEN START
UNLESS NE=LENGTH(CS) C
AND BYTE INTEGER(ADDR(FS)+NE)='A' C
THEN W = 16
FINISH
IF W=0 AND NS<NE-2 C
THEN P = SUBSTRING (CS, NS+1, NE-2)
FINISH
FINISH
END
!
!
!
!
SYSTEM ROUTINE INIT CLI VARS
! %OWN %INTEGER CLI INITIALISED = 0
IF SSOWN_CLI INITIALISED=0 THEN START
SSOWN_COMMENTF = '@'
SSOWN_SPECHARS = """ ()"
BYTE INTEGER (ADDR(SSOWN_SPECHARS)+2) = SSOWN_COMMENTF
SSOWN_D DELIM 1 = DATA START MARK
SSOWN_D DELIM 2 = DATA END MARK
SSOWN_CONTU = ".C"
SSOWN_XSTMT = ".A"
SSOWN_CLI INITIALISED = -1
FINISH
END
!
!
SYSTEM ROUTINE EXAMINE MACRO (STRING NAME MAC NAME, CALL PARMS, C
INTEGER TEXT BOUND, TEXT ADDRESS, SET UP, C
INTEGER NAME FAIL FLAG)
!
! IF 'SET UP' IS NON-ZERO, THIS ROUTINE DOES THE 'SET UP MACRO' PROCESS.
! IF IT IS ZERO, IT SIMPLY DOES 'RECOGNISE MACRO'.
!
! POSSIBLE VALUES OF 'FAIL FLAG' ON EXIT:
! FOR 'SET UP MACRO' -
! 0 - SUCCESS
! X'80000001' - KEYWORD MISSING IN DECLARATION
! X'80000004' - TOO MANY FIELDS IN DECLARATION
! X'80000080' - KEYWORDS INDISTINCT IN HEADER
! X'80000400' - TOO LITTLE SPACE IN MACRO EXPANSION AREA
! X'80000800' - CANNOT RECOGNISE MACRO HEADER
! X'80001000' - TOO MANY INPUT LEVELS
! FOR 'RECOGNISE MACRO' -
! 0 - SUCCESS
! X'80000800' - CANNOT RECOGNISE MACRO HEADER
! X'80001000' - TOO MANY INPUT LEVELS
! THE MAXIMUM LENGTH OF THE STRINGS IN KNTXT MUST BE MAXKNL:
STRING (11) ARRAY KNTXT (1:MAXPCT)
RECORD (PD) ARRAY PVAL (1:MAXPCT)
INTEGER PCT, R, BMARK
STRING (255) RN, PS, ST, FG, LBLSTR, PREDSTR, CALLSTR, DESTR
STRING (255) PFSTR, CFSTR, DFSTR, RAW
!
!
ROUTINE GET AND CLASSIFY (INTEGER BRACKETS)
GET STMT (BRACKETS,0,SSOWN_COMMENTF,SSOWN_D DELIM 1,SSOWN_CONTU,SSOWN_XSTMT,RAW,ST,FG,R)
IF DIAGOP#0 THEN START
IF R#0 THEN START
PRINT STRING ("GET STMT fails -")
PRINT (R,8,0)
NEWLINE
FINISH
FINISH
IF R#0 THEN RETURN
R = CLASSIFY STMT C
(ST,FG,LBLSTR,PREDSTR,CALLSTR,DESTR,PFSTR,CFSTR,DFSTR)
IF DIAGOP#0 THEN START
IF R#5 THEN START
PRINT STRING ("CLASSIFY STMT fails -")
PRINT (R,8,0)
NEWLINE
FINISH
FINISH
R = R - 5
PS = ""
END
!
!
ROUTINE CHECK HDR
IF SET UP=0 THEN START
IF R#0 THEN RETURN
APARAM C
(PS,CALL PARMS,MAXPCT,KNTXT,MAXKNL,PVAL,PCT,R)
IF R>=0 THEN R = 0
FINISH ELSE START
IF DIAGOP#0 THEN START
IF R#0 THEN START
PRINT STRING ("ANALYSE CALL fails -")
PRINT (R,8,0)
NEWLINE
FINISH ELSE START
IF RN#MAC NAME THEN START
PRINT STRING ("Wrong name found - ".RN.NLSTRING)
FINISH
FINISH
FINISH
IF R#0 OR RN#MAC NAME THEN R = -1
FINISH
END
!
!
!
IF SET UP=0 THEN CALL PARMS = ""
! **** **** FOR TESTING ONLY **** ****
IF DIAGOP#0 THEN START
BEGIN
INTEGER J
PRINT STRING ("Macro text:")
NEWLINE
FOR J=1,1,TEXT BOUND&X'00FFFFFF' CYCLE
PRINT SYMBOL (BYTE INTEGER(TEXT ADDRESS+J-1))
REPEAT
PRINT STRING ("<< End of text")
NEWLINE
END
FINISH
! **** **** END OF TESTING CODE **** ****
FAIL FLAG = 0
BMARK = 0
! MAKE THE TEXT ACCESSIBLE AS A NEW LEVEL OF INPUT, SIGNALLING
! EOF AT END:
NEW LEVEL (TEXT BOUND,TEXT ADDRESS,1,R)
IF DIAGOP#0 THEN START
PRINT LEVELS
FINISH
IF R#0 THEN START
FAIL FLAG = X'00001000'
-> SIGNAL FAULT
FINISH
! TRY IT 'WITH BRACKETS' AND SUPPRESS DOUBLE QUOTE CONTRACTION:
IF DIAGOP#0 THEN START
PRINT STRING ("Trying ""with brackets"" -".NLSTRING)
FINISH
GET AND CLASSIFY (1)
IF R#0 THEN -> TRY NOBRACKETS
ANALYSE CALL B (CALLSTR,CFSTR,RN,PS,R)
CHECK HDR
IF R#0 THEN -> TRY NOBRACKETS
BMARK = -1
IF CFSTR->PFSTR.("D").DFSTR THEN -> USE MACRO
!
TRY NOBRACKETS:
RESTART THIS LEVEL
IF DIAGOP#0 THEN START
PRINT STRING ("Trying ""without brackets"" -".NLSTRING)
FINISH
GET AND CLASSIFY (0)
IF R#0 THEN -> MAC NO GOOD
ANALYSE CALL N (CALLSTR,CFSTR,RN,PS,R)
CHECK HDR
IF R#0 THEN -> MAC NO GOOD
BMARK = 0
!
USE MACRO:
!
IF SET UP=0 THEN START
MAC NAME = RN
ABANDON LEVEL
FINISH ELSE START
APARAM C
(PS,CALL PARMS,MAXPCT,KNTXT,MAXKNL,PVAL,PCT,R)
! TREAT UNRECOGNISED KEYWORDS, WRAP-AROUND AND
! DOUBLE SPECIFICATION OF PARAMETERS AS FAULTS:
IF R&X'000000E0'#0 THEN R = R ! X'80000000'
IF R<0 THEN START
FAIL FLAG = R
-> DROP
FINISH
IF R#0 THEN START
! THESE ARE ONLY WARNINGS. FAILURES HAVE BEEN DEALT
! WITH BY THE "R<0" CONDITION ABOVE.
PRINT ERRORS (R, PARAM ETEXTS)
FINISH
USE AS MACRO (PCT,KNTXT,PVAL,SSOWN_BRACKET FLAG,R)
IF R#0 THEN START
FAIL FLAG = R
-> DROP
FINISH
SSOWN_BRACKET FLAG = BMARK
FINISH
RETURN
!
MAC NO GOOD:
IF BMARK=-1 THEN -> USE MACRO
FAIL FLAG = X'00000800'
!
DROP:
ABANDON LEVEL
SIGNAL FAULT:
FAIL FLAG = FAIL FLAG ! X'80000000'
RETURN
!
END
!
!
EXTERNAL ROUTINE OBEY JOB (STRING (255) DUMMY)
!
INTEGER KNOWN MACS
! MAC LIMIT IS THE MAXIMUM NUMBER OF MACRO DECLARATIONS
! WHICH CAN BE HANDLED IN ONE JOB OR SESSION.
CONST INTEGER MAC LIMIT = 24
RECORD (PD) ARRAY MAC TEXT (1:MAC LIMIT)
RECORD (PD) ARRAY MAC NAME (1:MAC LIMIT)
STRING (255) IN, STMT, FLAGS, LBL, PRED, CALL, DEST
STRING (255) XBL, DESTINATION, PFLAGS, CFLAGS, DFLAGS
STRING (80) OLD D1, OLD D2
STRING (1) NLSTRING
INTEGER R, ACT, STATE BEFORE WHEN, LAST STATE, LBLF, CH DISCARD
INTEGER COND, ONLINE, REMPTR, INNER CALL, LAST BRACKET FLAG
INTEGER OUTER WARNING, OUTER STATE, BASE LEVEL
INTEGER TAKE ELSE, TRAP BITS, SYNTAX RESULT
INTEGER CFILEBASE, CFILESIZE, CONFLAG, RETURN NOW
RECORD (RF) IN FILE DETAILS
! I HAVE TWO VERSIONS OF THE MAIN SWITCH IN THE INTERPRETER.
! ONE IS SLIGHTLY MORE COMPACT, AND THE OTHER IS (I THINK)
! SIMPLER. I AM USING THE 'SIMPLER' VERSION, BUT THE
! 'COMPACT' CODE IS HELD IN THIS FILE AFTER %END %OF %FILE.
! THERE ARE COMMENTS ABOUT RELATED CHANGES IN OTHER PARTS OF THE
! CODE - NOT MANY OF THEM.
!
STRING (15) LABEL PROMPT
INTEGER CURRENT PROMPT
CONST BYTE INTEGER ARRAY PROMPT FOR STATE (1:9) = C
1, 0, 3, 2, 4, 2, 4, 4, 2
CONST STRING (8) ARRAY PROMPT STRINGS (1:4) = C
"Control:",
"Command:",
".ELSE?",
".FINISH?"
!
SWITCH ACTION (1:22); ! (1:48) FOR THE 'COMPACT' CODE.
CONST BYTE INTEGER ARRAY ACT TABLE (0:14,1:9) = C
1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
1, 16, 3, 17, 5, 18, 18, 18, 19, 20, 21, 12, 18, 18, 22,
23, 16, 3, 25, 26, 39, 27, 28, 28, 28, 29, 32, 39, 39, 34,
23, 2, 3, 37, 26, 38, 27, 28, 28, 28, 30, 32, 40, 41, 42,
23, 16, 3, 25, 26, 39, 27, 28, 28, 28, 31, 33, 39, 39, 34,
23, 2, 3, 37, 26, 38, 27, 28, 28, 28, 31, 32, 40, 41, 42,
23, 16, 3, 25, 26, 39, 27, 28, 28, 28, 30, 33, 39, 39, 34,
23, 16, 3, 25, 26, 39, 27, 28, 28, 28, 31, 33, 48, 48, 48,
23, 43, 44, 45, 26, 46, 27, 28, 28, 28, 31, 47, 48, 48, 48
! %CONST %STRING (64) %ARRAY CLASS TEXT (0:14) = "Unrecognised",
! "Opening data delimiter",
! "Opening data delimiter after incomplete statement",
! "Incomplete statement before end-of file",
! "Statement too long",
! "Simple call",
! ".GOTO",
! ".IF .GOTO",
! ".IF .THEN",
! ".IF .START",
! ".ELSE",
! ".FINISH",
! ".WHENEVER .GOTO",
! ".WHENEVER .THEN",
! ".WHENEVER .START"
!
INTEGER NST, TEMASK; ! NOT NEEDED FOR THE 'COMPACT' CODE.
! THE ARRAY 'NEXT STATE' IS NOT NEEDED EITHER FOR THE 'COMPACT' CODE:
CONST BYTE INTEGER ARRAY NEXT STATE (1:48) = C
0, X'C0', X'C0', X'CA', 0, 0, 0, 0,
X'C0', X'C3', X'C0', 0, 0, 0, 0, X'C0',
X'CA', 0, X'C0', X'C7', 0, X'C8', X'C0', 0,
X'CA', X'C0', X'C0', X'C0', X'C6', X'C5', X'C0', 1,
0, X'C8', 0, 0, X'CA', X'C0', X'C0', X'C0',
X'C0', X'C0', X'C0', X'C0', X'CA', X'C0', 0, X'C0'
!
! THE ARRAY 'ACTNR' IS NOT NEEDED FOR THE 'COMPACT' CODE.
CONST BYTE INTEGER ARRAY ACTNR (1:48) = C
1, 2, 3, 4, 1, 6, 7, 8,
9, 10, 11, 1, 13, 14, 15, 3,
1, 1, 19, 22, 21, 22, 1, 0,
1, 1, 1, 1, 20, 20, 1, 1,
5, 22, 0, 0, 4, 6, 1, 13,
14, 15, 18, 18, 17, 16, 12, 1
!
CONST BYTE INTEGER ARRAY CONTEXT WARNING (1:48) = C
1, 0, 3, 4, 6, 0, 0, 0,
0, 0, 0, 8, 0, 0, 0, 0,
14, 0, 0, 0, 0, 0, 1, 0,
5, 6, 10, 12, 0, 0, 7, 0,
0, 0, 0, 0, 4, 0, 0, 0,
0, 0, 0, 3, 5, 0, 0, 13
!
! THE ARRAY 'WARNING TEXTS' HAS BEEN REPLACED BY THE TWO
! ARRAYS 'WTX' AND 'WNDX', BUT 'WARNING TEXTS' IS LEFT AS
! A COMMENT SINCE IT IS EASIER TO READ.
! %CONST %STRING (48) %ARRAY WARNING TEXTS (1:22) = %C
! "Unrecognisable text",
! "Unexpected data",
! "Incomplete statement before data",
! "Statement incomplete before end-of-file",
! "End-of-file",
! "Statement too long",
! ".ELSE out of context",
! ".FINISH out of context",
! "LABEL out of context",
! ".GOTO out of context",
! "CALL out of context - ignored",
! "Nested .IF - ignored",
! "Nested .WHENEVER - ignored",
! "Label missing",
! "Data terminator missing",
! "Unacceptable form of call",
! "Destination not a valid label",
! "Macro declaration fails",
! "Macro call fails",
! "Predicate invalid",
! "no space for .WHENEVER text",
! "Parameters invalid"
!
!
CONST HALF INTEGER ARRAY WNDX (1:22) = C
0,
20,
36,
69,
109,
121,
140,
161,
184,
205,
226,
256,
277,
304,
318,
342,
368,
398,
422,
439,
457,
485
!
CONST BYTE INTEGER ARRAY WTX (0:503) = C
19, 'U','n','r','e','c','o','g','n','i','s','a','b','l','e',
' ','t','e','x','t',
15, 'U','n','e','x','p','e','c','t','e','d',
' ','d','a','t','a',
32, 'I','n','c','o','m','p','l','e','t','e',
' ','s','t','a','t','e','m','e','n','t',
' ','b','e','f','o','r','e',
' ','d','a','t','a',
39, 'S','t','a','t','e','m','e','n','t',
' ','i','n','c','o','m','p','l','e','t','e',
' ','b','e','f','o','r','e',
' ','e','n','d','-','o','f','-','f','i','l','e',
11, 'E','n','d','-','o','f','-','f','i','l','e',
18, 'S','t','a','t','e','m','e','n','t',
' ','t','o','o',
' ','l','o','n','g',
20, '.','E','L','S','E',
' ','o','u','t',
' ','o','f',
' ','c','o','n','t','e','x','t',
22, '.','F','I','N','I','S','H',
' ','o','u','t',
' ','o','f',
' ','c','o','n','t','e','x','t',
20, 'L','a','b','e','l',
' ','o','u','t',
' ','o','f',
' ','c','o','n','t','e','x','t',
20, '.','G','O','T','O',
' ','o','u','t',
' ','o','f',
' ','c','o','n','t','e','x','t',
29, 'C','a','l','l',
' ','o','u','t',
' ','o','f',
' ','c','o','n','t','e','x','t',
' ','-',
' ','i','g','n','o','r','e','d',
20, 'N','e','s','t','e','d',
' ','.','I','F',
' ','-',
' ','i','g','n','o','r','e','d',
26, 'N','e','s','t','e','d',
' ','.','W','H','E','N','E','V','E','R',
' ','-',
' ','i','g','n','o','r','e','d',
13, 'L','a','b','e','l',
' ','m','i','s','s','i','n','g',
23, 'D','a','t','a',
' ','t','e','r','m','i','n','a','t','o','r',
' ','m','i','s','s','i','n','g',
25, 'U','n','a','c','c','e','p','t','a','b','l','e',
' ','f','o','r','m',
' ','o','f',
' ','c','a','l','l',
29, 'D','e','s','t','i','n','a','t','i','o','n',
' ','n','o','t',
' ','a',
' ','v','a','l','i','d',
' ','l','a','b','e','l',
23, 'M','a','c','r','o',
' ','d','e','c','l','a','r','a','t','i','o','n',
' ','f','a','i','l','s',
16, 'M','a','c','r','o',
' ','c','a','l','l',
' ','f','a','i','l','s',
17, 'P','r','e','d','i','c','a','t','e',
' ','i','n','v','a','l','i','d',
27, 'N','o',
' ','s','p','a','c','e',
' ','f','o','r',
' ','.','W','H','E','N','E','V','E','R',
' ','t','e','x','t',
18, 'P','a','r','a','m','e','t','e','r','s',
' ','i','n','v','a','l','i','d'
!
!
!
CONST STRING (9) CTU = ".CONTINUE"
CONST STRING (9) CTF = "CCCCCCCCC"
!
!
CONST INTEGER IDENTIFIERS = 19
CONST INTEGER VARIABLES = 11
CONST INTEGER CONDITIONS = 6
CONST INTEGER COND LIM = 18; ! MUST BE VARIABLES + CONDITIONS + 1.
!
!
INTEGER ARRAY VARS (1:VARIABLES)
INTEGER NAME RETURN CODE, PROG FLAG, CMND FLAG, LOAD FLAG, JOB FLAG
INTEGER NAME FILE FLAG
INTEGER NAME RESULT A, RESULT B, RESULT C, RESULT D
INTEGER NAME COUNTER
!
RECORD FORMAT TRAP (INTEGER CLASS, BOUND, ADDRESS)
RECORD (TRAP) ARRAY WHEN ACTION (1:CONDITIONS)
RECORD (TRAP) WHEN SPEC
INTEGER WHEN CONDITION
! TRAPS ARE:
! 1 FOR USER RESULT NON-ZERO
! 2 FOR PROGRAM FAILURE
! 3 FOR COMMAND FAILURE (I.E., NON-ZERO RESULT FROM SUBSYS COMMAND)
! 4 FOR LOADER FAILURES (E.G., ROUTINE NOT FOUND)
! 5 FOR JOB FAILURES - MOSTLY JCL ERRORS
! 6 FOR FILE FAILURES (IF WE EVER DISTINGUISH THEM FROM
! COMMAND FAILURES)
!
!
!
IF ULCEQUIV=0 THEN START
INTEGER FN SPEC RECOGNISE IDENTIFIER (STRING NAME N)
ROUTINE SPEC CLOSE UP (STRING NAME S)
FINISH ELSE START
INTEGER FN SPEC RECOGNISE IDENTIFIER (STRING (80) N)
FINISH
ROUTINE SPEC COPY TO STRING (RECORD (PD) NAME D, STRING NAME S)
INTEGER FN SPEC EVAL
ROUTINE SPEC SPRING TRAP (INTEGER N)
IF DIAGOP#0 THEN START
ROUTINE SPEC LIST TRAPS
FINISH
ROUTINE SPEC SAVE BYTES (INTEGER BOUND, ADDRESS, INTEGER NAME F)
ROUTINE SPEC SAVE COND (STRING NAME P, F, INTEGER T)
ROUTINE SPEC SAVE CALL IN SEQUENCE (STRING NAME C)
ROUTINE SPEC SAVE STRINGS (STRING NAME C, F)
ROUTINE SPEC STOW WHEN ACTION
ROUTINE SPEC DEAL WITH MACRO C
(INTEGER NAME Q, STRING NAME OPENDATA, CLOSEDATA)
ROUTINE SPEC DO CALL (STRING NAME C, F, INTEGER NAME WF, FM, TRB)
ROUTINE SPEC RESTORE VALUES
!
!
!
!
NLSTRING = TOSTRING (NL)
OLD D1 = SSOWN_D DELIM 1
OLD D2 = SSOWN_D DELIM 2
LAST BRACKET FLAG = SSOWN_BRACKET FLAG
OUTER WARNING = SSOWN_WARNING NUMBER
OUTER STATE = SSOWN_STATE
INNER CALL = SSOWN_MAC INITIALISED
RETURN NOW = 0
BEGIN
INTEGER KCT, D
STRING (8) ARRAY KEYSTRING (1:3)
RECORD (PD) ARRAY TEXT VALUE (1:3)
STRING (255) TVAL
TVAL = "JOB,JOURNAL,BRACKETS"
APARAM (TVAL, DUMMY, 3, KEYSTRING, 8, TEXT VALUE, KCT, D)
COPY TO STRING (TEXT VALUE (1), TVAL)
IF TVAL="" THEN START
IF INNER CALL#0 THEN START
PRINT STRING ("**** Job file name missing")
NEWLINE
SET RETURN CODE (5)
RETURN NOW = -1
FINISH ELSE START
START MACROUTINES (0,0,D)
ONLINE = -1
FINISH
FINISH ELSE START
ONLINE = 0
CONNECT (TVAL, 1, 0, 0, IN FILE DETAILS, CONFLAG)
IF CONFLAG#0 THEN START
PRINT STRING ("**** Cannot connect job file")
NEWLINE
SET RETURN CODE (7)
RETURN NOW = -1
FINISH ELSE START
CFILEBASE = IN FILE DETAILS_ADDR + IN FILE DETAILS_START
CFILESIZE = IN FILE DETAILS_LIMIT - IN FILE DETAILS_START
START MACROUTINES (X'18000000'!CFILESIZE,CFILEBASE,D)
IF D#0 THEN START
PRINT ERRORS (X'00001000',MACRO ETEXTS)
SET RETURN CODE (2)
RETURN NOW = -1
FINISH
FINISH
FINISH
COPY TO STRING (TEXT VALUE (2), TVAL)
IF TVAL#"" THEN START
! **** **** SELECT OUTPUT **** ****
FINISH
COPY TO STRING (TEXT VALUE (3), TVAL)
IF INNER CALL=0 THEN SSOWN_BRACKET FLAG = UINFI (16)
IF LENGTH(TVAL)>=1 THEN START
D = BYTE INTEGER(ADDR(TVAL)+1)
IF D='Y' THEN SSOWN_BRACKET FLAG = -1
IF D='N' THEN SSOWN_BRACKET FLAG = 0
FINISH
END
IF RETURN NOW#0 THEN START
RESTORE VALUES
RETURN
FINISH
IF SSOWN_KWD MAX SIZE#MAXKNL THEN START
PRINT STRING ("**** Confusion about keyword size".NLSTRING)
SET RETURN CODE (1)
ABANDON LEVEL
RESTORE VALUES
RETURN
FINISH
!
BASE LEVEL = SSOWN_IN SOURCE
INIT CLI VARS
SSOWN_D DELIM 1 = DATA START MARK
SSOWN_D DELIM 2 = DATA END MARK
IF SSOWN_SAVE BASE=0 THEN START
SSOWN_SAVE LIM = 8192
OUTFILE ("T#CLISAVE",SSOWN_SAVE LIM,0,8,SSOWN_SAVE BASE,CONFLAG)
SSOWN_SAVE LIM = SSOWN_SAVE BASE + SSOWN_SAVE LIM
SSOWN_SAVE PTR = SSOWN_SAVE BASE
FINISH
RETURN CODE == VARS (1)
PROG FLAG == VARS (2)
CMND FLAG == VARS (3)
LOAD FLAG == VARS (4)
JOB FLAG == VARS (5)
FILE FLAG == VARS (6)
RESULT A == VARS (7)
RESULT B == VARS (8)
RESULT C == VARS (9)
RESULT D == VARS (10)
COUNTER == VARS (11)
RETURN NOW = 0
BEGIN
INTEGER I, CTE, CTL
FOR I=1,1,VARIABLES CYCLE
VARS (I) = 0
REPEAT
!
WHEN SPEC_CLASS = 0
WHEN SPEC_BOUND = 0
WHEN SPEC_ADDRESS = 0
FOR I=1,1,CONDITIONS CYCLE ; ! USED TO %CYCLE FROM 2 TO AVOID SETTING
! SETTING A CLASS 0 TRAP FOR 'URNZ'.
WHEN ACTION (I) = WHEN SPEC
REPEAT
!
CTL = LENGTH (CTU) + 1
SAVE BYTES (CTL, ADDR(CTU), CTE)
SAVE BYTES (CTL, ADDR(CTF), CTE)
IF CTE#0 THEN START
PRINT STRING ("**** No work space")
NEWLINE
SET RETURN CODE (3)
RETURN NOW = -1
FINISH ; ! %ELSE %START - USED TO SET A CLASS 2 TRAP
! WITH '.CONTINUE' TO HANDLE 'URNZ'.
! NO LONGER NECESSARY - SEE ABOVE.
! WHEN SPEC_CLASS = 2
! WHEN SPEC_BOUND = CTL
! WHEN SPEC_ADDRESS = SSOWN_SAVE BASE
! WHEN ACTION (1) = WHEN SPEC
! %FINISH
!
END
IF RETURN NOW#0 THEN START
ABANDON LEVEL
RESTORE VALUES
RETURN
FINISH
!
SSOWN_STATE = 1
TAKE ELSE = 0
SSOWN_ACCUMULATING = 0
KNOWN MACS = 0
SSOWN_LAST PROMPT = -1
!
! THIS ROUTINE IS DRIVEN BY THE VALUE OF 'SSOWN_STATE', WHICH REPRESENTS THE
! CURRENT CONDITION OF THE JOB CONTROL PROGRAM, AND BY THE 'STATEMENT
! CLASS' OF THE STATEMENT JUST READ. THE MAIN LOOP OF THE ROUTINE
! STARTS IMMEDIATELY AFTER THIS COMMENT, AND EXITS ONLY WHEN 'STATE'
! ACQUIRES THE VALUE 10 (JOB COMPLETE). WITHIN THE LOOP, A SINGLE
! STATEMENT IS READ AND CLASSIFIED, AND THE CLASS NUMBER AND 'STATE'
! ARE USED TO SELECT APPROPRIATE PROCESSING VIA THE ARRAY 'ACT TABLE'
! AND THE SWITCH 'ACTION'.
! VALUES OF 'STATE' ARE:
! 1 - NORMAL: OBEY ANYTHING.
! THIS STATE IS ACTUALLY SUBDIVIDED. NORMALLY 'TAKE ELSE=0', SO
! A LINE STARTING WITH '.ELSE' IS REJECTED. IF THE LAST LINE WAS
! '.IF ... .THEN ...', WE HAVE 'TAKE ELSE=1' MEANING "THE
! PREDICATE WAS TRUE, SO ACCEPT A LINE STARTING '.ELSE' BUT DO NOT
! EXECUTE ITS CALL", OR ELSE WE HAVE 'TAKE ELSE=2' MEANING "THE
! PREDICATE WAS FALSE, SO ACCEPT A LINE STARTING '.ELSE' AND DO
! THE CALL". IF WE HAVE 'TAKE ELSE=1', AND WE DO IN FACT FIND
! AN '.ELSE' WITH A CALL (WHICH IS NOT, OF COURSE, TO BE
! EXECUTED), THEN 'TAKE ELSE' GETS THE VALUE 3 (TEMPORARILY) TO
! ALLOW ANY '.DATA' TO BE SKIPPED.
! 2 - SKIPPING FOR LABEL.
! THIS IS ALSO SUBDIVIDED BY THE VALUE OF 'TAKE ELSE'. HERE,
! OF COURSE, THERE IS NO QUESTION OF OBEYING THE CALL ON AN
! '.ELSE' LINE, SINCE SUCH A LINE CANNOT (VALIDLY) BE LABELLED.
! THE INTERPRETER NEVERTHELESS RECOGNISES SUCH LINES AS PART OF
! ITS PRECAUTIONS AGAINST 'BRANCHING INTO CONDITIONALS'.
! 3 - SKIPPING FIRST HALF OF AN '.IF ... .START ... .ELSE ... .FINISH'
! CONSTRUCTION (BECAUSE THE PREDICATE WAS FALSE).
! 4 - OBEYING THE FIRST HALF (BECAUSE THE PREDICATE WAS TRUE).
! 5 - SKIPPING THE SECOND HALF (AFTER OBEYING THE FIRST, BECAUSE THE
! PREDICATE WAS TRUE).
! 6 - OBEYING THE SECOND HALF (AFTER SKIPPING THE FIRST, BECAUSE THE
! PREDICATE WAS FALSE).
! 7 - SKIPPING THE WHOLE CONSTRUCTION, E.G., WHILE LOOKING FOR A
! LABEL.
! 8 - SKIPPING OVER A '.WHENEVER ... .FINISH' CONSTRUCTION.
! 9 - SSOWN_ACCUMULATING THE TEXT OF A '.WHENEVER ... .FINISH' CONSTRUCTION.
! 10 - JOB COMPLETE - DUE TO CLOSE DOWN.
!
! STATEMENT CLASSES ARE:
! 0 "UNRECOGNISED"
! 1 "OPENING DATA DELIMITER"
! 2 "OPENING DATA DELIMITER AFTER INCOMPLETE STATEMENT"
! 3 "INCOMPLETE STATEMENT BEFORE END-OF-FILE"
! 4 "STATEMENT TOO LONG"
! 5 "SIMPLE CALL"
! 6 ".GOTO"
! 7 ".IF .GOTO"
! 8 ".IF .THEN"
! 9 ".IF .START"
! 10 ".ELSE"
! 11 ".FINISH"
! 12 ".WHENEVER .GOTO"
! 13 ".WHENEVER .THEN"
! 14 ".WHENEVER .START"
!
!
UNTIL SSOWN_STATE=10 CYCLE
TRAP BITS = 0
CURRENT PROMPT = PROMPT FOR STATE (SSOWN_STATE)
IF CURRENT PROMPT#SSOWN_LAST PROMPT THEN START
IF CURRENT PROMPT=0 C
THEN PROMPT (LABEL PROMPT) C
ELSE PROMPT (PROMPT STRINGS(CURRENT PROMPT))
SSOWN_LAST PROMPT = CURRENT PROMPT
FINISH
WHILE NL#SSOWN_LAST CHAR READ#25 CYCLE
CH DISCARD = MASTER CHAR IN (1)
REPEAT
! GET STATEMENT, CLASSIFY STATEMENT, INITIAL PROCESSING, ETC.
GET STMT (SSOWN_BRACKET FLAG, 0, SSOWN_COMMENTF, SSOWN_D DELIM 1, SSOWN_CONTU, SSOWN_XSTMT, C
IN, STMT, FLAGS, R)
! FIRST PARAMETER SHOULD BE NON-ZERO FOR BRACKET OPTION.
IF R=-1 THEN START
PRINT STRING ("**** GET STMT: bad parameters".NLSTRING)
SSOWN_STATE = 10
-> ACT DONE
FINISH
IF DIAGOP#0 THEN START
PRINT STRING ("Raw statement:")
NEWLINE
FINISH
IF ONLINE=0 THEN START
PRINT STRING (IN)
NEWLINE
FINISH
IF DIAGOP#0 THEN START
PRINT STRING ("Reconstructed as:")
NEWLINE
PRINT STRING (STMT)
NEWLINE
PRINT STRING (FLAGS)
NEWLINES (2)
FINISH
IF R=0 C
THEN R = CLASSIFY STMT (STMT,FLAGS,LBL,PRED,CALL,DEST, C
PFLAGS, CFLAGS, DFLAGS)
LBLF = 0
IF DIAGOP#0 THEN START
PRINT STRING ("Classified as - ")
PRINT STRING (CLASS TEXT(R))
NEWLINE
FINISH
IF R>4 THEN START
IF DIAGOP#0 THEN START
IF 10#R#11 THEN START
IF LBL="" THEN START
PRINT STRING (" Unlabelled")
NEWLINE
FINISH ELSE START
PRINT STRING (" Label """.LBL."""")
NEWLINE
FINISH
FINISH
IF 7<=R<=9 OR 12<=R<=14 THEN START
PRINT STRING (" Predicate """.PRED."""")
NEWLINE
PRINT STRING (" ".PFLAGS)
NEWLINE
FINISH
! %IF R=5 %OR R=8 %OR R=10 %OR R=13 %THEN %START
IF R=8 OR R=10 OR R=13 THEN START
PRINT STRING (" Call """.CALL."""")
NEWLINE
PRINT STRING (" ".CFLAGS)
NEWLINE
FINISH
IF R=6 OR R=7 OR R=12 THEN START
PRINT STRING (" Destination """.DEST."""")
NEWLINE
PRINT STRING (" ".DFLAGS)
NEWLINE
FINISH
FINISH
IF (3<=SSOWN_STATE<=9 OR R=10 OR R=11) C
AND LBL#"" C
THEN START
LBLF = -1
XBL = LBL
LBL = ""
FINISH
IF SSOWN_STATE=2 AND LBL=DESTINATION THEN START
SSOWN_STATE = 1
TAKE ELSE = 0
FINISH
FINISH
ACT = ACT TABLE (R, SSOWN_STATE)
NST = NEXT STATE (ACT); ! NOT NEEDED FOR THE 'COMPACT' CODE.
TEMASK = NST >> 6; ! NOT NEEDED FOR THE 'COMPACT' CODE.
NST = NST & X'3F'; ! NOT NEEDED FOR THE 'COMPACT' CODE.
SSOWN_WARNING NUMBER = CONTEXT WARNING (ACT)
-> ACTION (ACTNR(ACT)); ! -> ACTION (ACT) IN THE 'COMPACT' CODE.
!
! THIS IS THE START OF THE AREA OF CODE WHICH CAN BE REPLACED
! BY THE 'COMPACT' SWITCH FILED AFTER %END %OF %FILE.
ACTION (2):
UNLESS 0#TAKE ELSE#1 THEN SSOWN_WARNING NUMBER = 2
ACTION (3):
GATHER DATA (SSOWN_D DELIM 2, 1)
-> ACT DONE
!
ACTION (17):
! TIDY SSOWN_ACCUMULATION (0)
SSOWN_ACCUMULATING = 0
SSOWN_ACCUMULATION_BOUND = SSOWN_ACCUMULATION_BOUND ! X'18000000'
-> ACT DONE
!
ACTION (4):
IF STMT="" THEN SSOWN_WARNING NUMBER = 5
-> ACT DONE
!
ACTION (6):
DO CALL (CALL,CFLAGS,SSOWN_WARNING NUMBER,SYNTAX RESULT,TRAP BITS)
-> ACT DONE
!
ACTION (8):
COND = EVAL
IF COND=0 THEN -> ACT DONE
ACTION (7):
DESTINATION = PURGE (DEST,DFLAGS,REMPTR)
IF REMPTR<=LENGTH(DEST) OR DESTINATION="" OR DESTINATION="-" C
THEN SSOWN_WARNING NUMBER = 17 C
ELSE START
IF BYTE INTEGER(ADDR(DESTINATION)+1)='-' THEN START
GO BACK
DESTINATION = C
SUBSTRING (DESTINATION, 2, LENGTH(DESTINATION))
FINISH
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(DESTINATION)+1, LENGTH(DESTINATION))
FINISH
IF LENGTH(DESTINATION)>13 C
THEN LABEL PROMPT = SUBSTRING (DESTINATION,1,13).":?" C
ELSE LABEL PROMPT = DESTINATION.":?"
SSOWN_LAST PROMPT = -1
SSOWN_STATE = 2; ! SCANNING FOR LABEL
FINISH
-> ACT DONE
!
ACTION (9):
COND = EVAL
IF COND#0 THEN START
DO CALL (CALL,CFLAGS,SSOWN_WARNING NUMBER,SYNTAX RESULT,TRAP BITS)
TAKE ELSE = 1
FINISH ELSE TAKE ELSE = 2
-> ACT DONE
!
ACTION (10):
COND = EVAL
IF COND#0 THEN NST = 4; ! %ELSE NST = 3
! BUT IT ALREADY IS 3 - SEE TABLE 'NEXT STATE'.
! OBEY FIRST HALF OR SKIP TO SECOND HALF
ACTION (22):
LAST STATE = SSOWN_STATE
-> ACT DONE
!
ACTION (11):
IF TAKE ELSE#1 THEN START
IF TAKE ELSE=2 C
THEN DO CALL C
(CALL,CFLAGS,SSOWN_WARNING NUMBER,SYNTAX RESULT,TRAP BITS) C
ELSE SSOWN_WARNING NUMBER = 7
TAKE ELSE = 0
FINISH ELSE TAKE ELSE = 3
-> ACT DONE
!
ACTION (13):
DESTINATION = PURGE (DEST,DFLAGS,REMPTR)
IF REMPTR<=LENGTH(DEST) C
OR DESTINATION="" C
OR BYTE INTEGER(ADDR(DESTINATION)+1)='-' C
THEN SSOWN_WARNING NUMBER = 17 C
ELSE START
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(DESTINATION)+1, LENGTH(DESTINATION))
FINISH
SAVE COND (PRED,PFLAGS,1)
IF SSOWN_WARNING NUMBER=0 THEN SAVE STRINGS (DESTINATION,SSOWN_NULLSTRING)
FINISH
-> ACT DONE
!
ACTION (14):
SAVE COND (PRED,PFLAGS,2)
IF SSOWN_WARNING NUMBER=0 THEN SAVE STRINGS (CALL,CFLAGS)
-> ACT DONE
!
ACTION (15):
SAVE COND (PRED,PFLAGS,3)
IF SSOWN_WARNING NUMBER=0 THEN START
STATE BEFORE WHEN = SSOWN_STATE
SSOWN_STATE = 9; ! ACCUMULATING WHENEVER TEXT
FINISH
! SHOULD WE NOT DO SOMETHING ABOUT SKIPPING THE WHENEVER TEXT?
-> ACT DONE
!
ACTION (19):
TAKE ELSE = 1
-> ACT DONE
!
ACTION (21):
UNLESS 0#TAKE ELSE#3 THEN SSOWN_WARNING NUMBER = 7
-> ACT DONE
!
ACTION (20):
IF CALL#"" THEN SSOWN_WARNING NUMBER = 11
-> ACT DONE
!
ACTION (5):
SSOWN_STATE = LAST STATE
-> ACT DONE
!
ACTION (18):
GATHER DATA (SSOWN_D DELIM 2, 2)
-> ACT DONE
!
ACTION (16):
SAVE CALL IN SEQUENCE (CALL)
-> ACT DONE
!
ACTION (12):
SSOWN_ACCUMULATING = 0
WHEN SPEC_BOUND = SSOWN_SAVE PTR - WHEN SPEC_ADDRESS
STOW WHEN ACTION
SSOWN_STATE = STATE BEFORE WHEN
ACTION (1):
ACT DONE:
! THIS IS THE END OF THE SECTION OF CODE WHICH CAN BE
! REPLACED BY THE 'COMPACT' SWITCH.
IF NST#0 THEN SSOWN_STATE = NST; ! NOT NEEDED FOR 'COMPACT' CODE.
TAKE ELSE = TAKE ELSE & TEMASK; ! NOT NEEDED FOR 'COMPACT' CODE.
IF LBLF#0 THEN START
PRINT STRING ("**** Label ".XBL." out of context")
NEWLINE
TRAP BITS = TRAP BITS ! X'00000010'
FINISH
IF SSOWN_WARNING NUMBER#0 THEN START
PRINT STRING (STARS.STRING(ADDR(WTX(WNDX(SSOWN_WARNING NUMBER)))))
NEWLINE
UNLESS 18#SSOWN_WARNING NUMBER#19 C
THEN PRINT ERRORS (SYNTAX RESULT, MACRO ETEXTS)
IF SSOWN_WARNING NUMBER=20 C
THEN PRINT ERRORS (SYNTAX RESULT, PRED ETEXTS)
IF SSOWN_WARNING NUMBER#5 THEN TRAP BITS = TRAP BITS ! X'00000010'
FINISH
BEGIN
INTEGER I
FOR I=1,1,CONDITIONS CYCLE
IF TRAP BITS&1#0 THEN SPRING TRAP (I)
TRAP BITS = TRAP BITS >> 1
REPEAT
END
REPEAT
! THIS IS THE END OF THE MAIN LOOP OF THIS ROUTINE.
!
SET RETURN CODE (0)
CLEAR LEVEL (BASE LEVEL)
RESTORE VALUES
RETURN
! THIS IS THE END OF THE MAIN ROUTINE.
!
!
!
IF ULCEQUIV=0 THEN START
INTEGER FN RECOGNISE IDENTIFIER (STRING NAME N)
!
! THIS ROUTINE WILL RETURN ZERO UNLESS IT CAN MATCH 'N' IN THE ARRAY
! 'VN', IN WHICH CASE IT WILL RETURN THE INDEX OF THE MATCHING
! STRING, WHICH WILL LIE IN THE RANGE 1 TO 'IDENTIFIERS' INCLUSIVE.
!
! THE TOTAL NUMBER OF IDENTIFIERS IS GIVEN BY 'IDENTIFIERS'. THE NAMES
! MUST BE ARRANGED WITH INTEGERS FIRST, AND THEIR NUMBER IS GIVEN BY
! 'VARIABLES'. AFTER THAT COME THE BOOLEANS, AND THE ONES TESTABLE BY
! 'WHENEVER' MUST COME FIRST. 'CONDITIONS' IS THE NUMBER OF THESE
! 'WHENEVER'-TESTABLE BOOLEANS. THEIR CORRESPONDING INTEGER VALUES
! MUST APPEAR AT THE START OF THE INTEGER NAMES, IN THE SAME ORDER.
! IT IS ASSUMED ELSEWHERE IN THE CODE THAT 'URNZ' IS THE 'FIRST'
! CONDITION, AND THAT 'ANYFAIL' IS 18 AND 'ONLINE' IS 19.
CONST STRING (11) ARRAY VN (1:IDENTIFIERS) = "RESULT",
"PROGFLAG",
"CMNDFLAG",
"LOADFLAG",
"JOBFLAG",
"FILEFLAG",
"RESULTA",
"RESULTB",
"RESULTC",
"RESULTD",
"COUNTER",
"URNZ",
"PROGFAIL",
"CMNDFAIL",
"LOADFAIL",
"JOBFAIL",
"FILEFAIL",
"ANYFAIL",
"ONLINE"
INTEGER I
I = IDENTIFIERS
WHILE I>=1 AND VN(I)#N CYCLE
I = I - 1
REPEAT
RESULT = I
END
FINISH ELSE START
INTEGER FN RECOGNISE IDENTIFIER (STRING (80) N)
!
! THIS ROUTINE WILL RETURN ZERO UNLESS IT CAN MATCH 'N' IN THE ARRAY
! 'VN', IN WHICH CASE IT WILL RETURN THE INDEX OF THE MATCHING
! STRING, WHICH WILL LIE IN THE RANGE 1 TO 'IDENTIFIERS' INCLUSIVE.
!
! THE TOTAL NUMBER OF IDENTIFIERS IS GIVEN BY 'IDENTIFIERS'. THE NAMES
! MUST BE ARRANGED WITH INTEGERS FIRST, AND THEIR NUMBER IS GIVEN BY
! 'VARIABLES'. AFTER THAT COME THE BOOLEANS, AND THE ONES TESTABLE BY
! 'WHENEVER' MUST COME FIRST. 'CONDITIONS' IS THE NUMBER OF THESE
! 'WHENEVER'-TESTABLE BOOLEANS. THEIR CORRESPONDING INTEGER VALUES
! MUST APPEAR AT THE START OF THE INTEGER NAMES, IN THE SAME ORDER.
! IT IS ASSUMED ELSEWHERE IN THE CODE THAT 'URNZ' IS THE 'FIRST'
! CONDITION, AND THAT 'ANYFAIL' IS 18 AND 'ONLINE' IS 19.
CONST STRING (11) ARRAY VN (1:IDENTIFIERS) = "RESULT",
"PROGFLAG",
"CMNDFLAG",
"LOADFLAG",
"JOBFLAG",
"FILEFLAG",
"RESULTA",
"RESULTB",
"RESULTC",
"RESULTD",
"COUNTER",
"URNZ",
"PROGFAIL",
"CMNDFAIL",
"LOADFAIL",
"JOBFAIL",
"FILEFAIL",
"ANYFAIL",
"ONLINE"
INTEGER I
UCTRANSLATE (ADDR(N)+1, LENGTH(N))
I = IDENTIFIERS
WHILE I>=1 AND VN(I)#N CYCLE
I = I - 1
REPEAT
RESULT = I
END
FINISH
!
IF ULCEQUIV=0 THEN START
ROUTINE CLOSE UP (STRING NAME S)
INTEGER I, J, L, C, A
L = LENGTH (S)
A = ADDR (S)
I = 1
J = 0
WHILE I<=L CYCLE
C = BYTE INTEGER (A+I)
IF C#' ' THEN START
J = J + 1
BYTE INTEGER (A+J) = C
FINISH
I = I + 1
REPEAT
LENGTH (S) = J
END
FINISH
!
ROUTINE COPY TO STRING (RECORD (PD) NAME D, STRING NAME S)
INTEGER L
! %INTEGER I, AS, AD; ! NOT NEEDED IF WE USE 'MOVE'
L = D_BOUND & X'00FFFFFF'
! AD = D_ADDRESS - 1; ! NOT NEEDED IF WE USE 'MOVE'.
! AS = ADDR (S); ! NOT NEEDED IF WE USE 'MOVE'.
! I = 1; ! NOT NEEDED IF WE USE 'MOVE'.
!
! **** **** MACHINE CODE **** ****
! %WHILE I<=L %CYCLE
! BYTE INTEGER (AS+I) = BYTE INTEGER (AD+I)
! I = I + 1
! %REPEAT
! EQUIVALENT TO:
MOVE (L, D_ADDRESS, ADDR(S)+1)
! **** **** END OF MACHINE CODE **** ****
!
LENGTH (S) = L
END
!
!
ROUTINE SPRING TRAP (INTEGER N)
! N MUST LIE IN THE RANGE 1 TO CONDITIONS INCLUSIVE.
SWITCH DO (0:3)
INTEGER R, S, T
RECORD (TRAP) NAME PLOT
!
PLOT == WHEN ACTION (N)
-> DO (PLOT_CLASS)
!
!
DO (0):; ! NO SPECIFIC TRAP.
! DON'T STOP ON USER RESULT NON-ZERO, NOR IF WE ARE ON-LINE.
IF N#1 AND ONLINE=0 THEN START
PRINT STRING ("**** Job terminated")
NEWLINE
SSOWN_STATE = 10
FINISH
-> XND
!
DO (1):; ! .GOTO TRAP.
PRINT STRING ("**** Fault trap: .GOTO ".STRING(PLOT_ADDRESS))
NEWLINE
DESTINATION = STRING (PLOT_ADDRESS)
IF LENGTH(DESTINATION)>13 C
THEN LABEL PROMPT = SUBSTRING (DESTINATION,1,13).":?" C
ELSE LABEL PROMPT = DESTINATION.":?"
SSOWN_LAST PROMPT = -1
SSOWN_STATE = 2
FOR N=1,1,CONDITIONS CYCLE
PLOT == WHEN ACTION (N)
IF PLOT_CLASS=1 C
AND STRING(PLOT_ADDRESS)=DESTINATION C
THEN START
PLOT_CLASS = 0
PLOT_BOUND = 0
PLOT_ADDRESS = 0
FINISH
REPEAT
-> XND
!
DO (2):; ! CALL TRAP.
PRINT STRING ("**** Fault trap: call ".STRING(PLOT_ADDRESS))
NEWLINE
DO CALL (STRING(PLOT_ADDRESS), C
STRING(PLOT_ADDRESS+BYTE INTEGER(PLOT_ADDRESS)+1), C
R, S, T)
IF R#0 THEN START
PRINT STRING ("**** Trap fails! - ".STRING(ADDR(WTX(WNDX(R)))))
NEWLINE
UNLESS 18#R#19 THEN PRINT ERRORS (S, MACRO ETEXTS)
FINISH
-> XND
!
DO (3):; ! START-FINISH TRAP.
PRINT STRING ("**** Fault trap:")
NEWLINE
NEW LEVEL (PLOT_BOUND, PLOT_ADDRESS, 0, R)
IF R#0 THEN START
PRINT STRING ("**** Too many input levels: cannot trap fault")
NEWLINE
FINISH
!
XND:
!
END
!
INTEGER FN EVAL
! RESULT SHOULD BE ZERO FOR FALSE, NON-ZERO FOR TRUE.
INTEGER B, L, I, TEST, N, C, VAL, VARIABLE
INTEGER SGN, D, CLASS
SWITCH PROC (1:6)
CONST BYTE INTEGER ARRAY ESS (1:4,1:4) = C
5, 5, 2, 5,
3, 3, 6, 6,
4, 4, 6, 6,
6, 1, 6, 6
STRING (255) S, T
STRING (2) PAD
CONST STRING (3) LEG = "<=>"
CONST STRING (2) EG = "=>"
STRING (5) TVT
B = 0
SYNTAX RESULT = 0
!
! AT THE END OF THIS ROUTINE, 'SYNTAX RESULT' WILL HAVE BITS SET TO INDICATE
! ERRORS AS FOLLOWS:
! 1 - "BRACKETS OR QUOTES IN PREDICATE"
! 2 - "PREDICATE MISSING"
! 4 - "UNRECOGNISED NAME IN PREDICATE"
! 8 - "INVALID COMPARATOR"
! 16 - "INVALID INTEGER"
! 32 - "LOGICAL INSTEAD OF INTEGER"
! 64 - "INTEGER INSTEAD OF LOGICAL"
!
IF LENGTH(PRED)=0 C
THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000002' C
ELSE START
S = PURGE (PRED, PFLAGS, L); ! NOW S HAS NO SPACES.
IF L<=LENGTH(PRED) C
THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000001'
!
! **** **** MACHINE CODE FOR THIS NEXT BIT? **** ****
I = 1
WHILE I<=LENGTH(S) AND 'A'<=BYTE INTEGER(ADDR(S)+I)<='Z' CYCLE
I = I + 1
REPEAT
! **** **** END OF MACHINE CODE SECTION **** ****
!
IF I#1 THEN START
T = SUBSTRING (S, 1, I-1)
N = RECOGNISE IDENTIFIER (T)
FINISH ELSE N = 0
IF N=0 THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000004'
IF I<=LENGTH(S) THEN START
! LOOK FOR COMPARATOR:
TEST = 6
! **** **** A COUPLE OF RESOLUTIONS IN THE NEXT **** ****
! **** **** FEW LINES ARE UNNECESSARILY ELABORATE. **** ****
! **** **** SOME SIMPLE MACHINE CODE COULD DO THE **** ****
! **** **** REQUIRED TESTS EASILY. **** ****
IF LEG->PAD.(TOSTRING(BYTE INTEGER(ADDR(S)+I))) THEN START
TEST = LENGTH (PAD)
I = I + 1
IF TEST#1 C
AND I<=LENGTH(S) C
AND EG->PAD.(TOSTRING(BYTE INTEGER(ADDR(S)+I))) C
THEN START
TEST = TEST + LENGTH (PAD) + 3
I = I + 1
FINISH
FINISH
!
! VALUES OF 'TEST' ARE:
! 0 - <
! 1 - =
! 2 - >
! 3 - <=
! 4 - <>
! 5 - >=
! 6 - NO VALID COMPARATOR FOUND
!
IF TEST=6 THEN START
D = 2; ! DISCARDING TAIL OF COMPARATOR.
SYNTAX RESULT = SYNTAX RESULT ! X'00000008'
FINISH ELSE D = 1; ! EXPECTING SIGN OR DIGIT.
VAL = 0
SGN = +1
WHILE I<=LENGTH(S) CYCLE
C = BYTE INTEGER (ADDR(S) + I)
IF '0'<=C<='9' THEN CLASS = 1 ELSE START
IF C='+' THEN CLASS = 2 ELSE START
IF C='-' THEN CLASS = 3 ELSE CLASS = 4
FINISH
FINISH
-> PROC(ESS(D,CLASS))
!
PROC (6): I = 1023; ! FORCES EXIT WITH I=1024 FOR 'INVALID INTEGER'.
-> NEXT
!
PROC (4): SGN = -1
PROC (3): D = 4; ! EXPECTING FIRST DIGIT.
-> NEXT
!
PROC (5): D = 3; ! EXPECTING ANOTHER DIGIT.
PROC (2): VAL = 10*VAL + C - '0'
PROC (1):
NEXT:
I = I + 1
REPEAT
IF D#3 OR I=1024 C
THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000010'
IF N>VARIABLES C
THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000020'
IF SYNTAX RESULT=0 THEN START
VAL = SGN * VAL
VARIABLE = VARS (N)
!
! THIS NEXT BIT IS MERE BIT TWIDDLING, BUT IT IS COMPACT AND
! FAST, AND I ASSERT THAT IT GIVES B NON-ZERO IF AND ONLY IF
! THE RELATIONSHIP DEFINED BY 'TEST' HOLDS BETWEEN THE
! THE VARIABLE AND THE INTEGER VALUE.
IF VARIABLE=VAL THEN B = TEST & 1 ELSE START
IF VARIABLE<VAL C
THEN B = (TEST-1) & 2 C
ELSE B = (5*(TEST-1)) & 4
FINISH
!
FINISH
FINISH ELSE START
IF N#0 THEN START
IF N<=VARIABLES C
THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000040' C
ELSE START
IF N<COND LIM THEN B = VARS (N-VARIABLES) ELSE START
BEGIN
SWITCH LOGIC (COND LIM:IDENTIFIERS)
-> LOGIC (N)
!
LOGIC (18): B = PROG FLAG C
! CMND FLAG %C
! LOAD FLAG %C
! JOB FLAG %C
! FILE FLAG
-> LEX
!
LOGIC (19): B = ONLINE
! -> LEX
! !
! LOGIC (??): ! B = -1; ! TRUE.
! -> LEX
! !
! LOGIC (??): ! B = 0; ! FALSE.
!
LEX: END
FINISH
FINISH
FINISH
FINISH
FINISH
IF B#0 THEN TVT = "TRUE" ELSE TVT = "FALSE"
PRINT STRING ("++++ Evaluating: """.PRED.""" yields ".TVT)
NEWLINE
! PRINT STRING (" ".PFLAGS)
! NEWLINE
IF SYNTAX RESULT#0 THEN SSOWN_WARNING NUMBER = 20
RESULT = B
END
!
IF DIAGOP#0 THEN START
ROUTINE LIST TRAPS
CONST STRING (20) ARRAY CTXT (1:CONDITIONS) = C
"USER RESULT NON-ZERO",
"PROGRAM FAULT",
"COMMAND FAILURE",
"LOAD FAILURE",
"JCL ERROR",
"FILE ERROR"
INTEGER B, I, J
RECORD (TRAP) NAME PROCEDURE
SWITCH T (1:3)
FOR I=1,1,CONDITIONS CYCLE
PRINT STRING ("TRAP FOR ".CTXT(I).": ")
PROCEDURE == WHEN ACTION (I)
B = PROCEDURE_BOUND & X'00FFFFFF'
IF B=0 THEN PRINT STRING ("NONE") ELSE START
-> T (PROCEDURE_CLASS)
!
T(1): PRINT STRING (".GOTO ".STRING(PROCEDURE_ADDRESS))
-> NEXT
!
T(2): PRINT STRING ("CALL ".STRING(PROCEDURE_ADDRESS))
-> NEXT
!
T(3): PRINT STRING ("OBEY -".NLSTRING)
FOR J=0,1,B-1 CYCLE
PRINT SYMBOL (BYTE INTEGER(PROCEDURE_ADDRESS+J))
REPEAT
PRINT STRING ("<< END OF TEXT")
!
NEXT:
FINISH
NEWLINE
REPEAT
END
FINISH
!
ROUTINE SAVE BYTES (INTEGER BOUND, ADDRESS, INTEGER NAME F)
! %INTEGER I; ! NOT NEEDED IF WE USE 'MOVE'.
F = 0
BOUND = BOUND & X'00FFFFFF'
IF BOUND#0 THEN START
IF SSOWN_SAVE PTR+BOUND>=SSOWN_SAVE LIM C
THEN F = X'00004000' C
ELSE START
!
! **** **** THIS COULD BE REPLACED BY MACHINE CODE **** ****
! %FOR I=0,1,BOUND-1 %CYCLE
! BYTE INTEGER (SSOWN_SAVE PTR + I) = BYTE INTEGER (ADDRESS + I)
! %REPEAT
! EQUIVALENT TO:
MOVE (BOUND, ADDRESS, SSOWN_SAVE PTR)
! **** **** END OF MACHINE CODE SECTION **** ****
!
SSOWN_SAVE PTR = SSOWN_SAVE PTR + BOUND
FINISH
FINISH
END
!
ROUTINE SAVE COND (STRING NAME P, F, INTEGER T)
STRING (255) S
INTEGER L, N
IF DIAGOP#0 THEN START
STRING (8) TTXT
IF T=1 THEN TTXT = ".GOTO" ELSE START
IF T=2 THEN TTXT = "call" ELSE START
IF T=3 THEN TTXT = "sequence" ELSE TTXT = "T="
FINISH
FINISH
PRINT STRING ("++++ Saving .WHENEVER """.P.""" with ".TTXT)
UNLESS 1<=T<=3 THEN PRINT (T,3,0)
NEWLINE
PRINT STRING (" ".F)
NEWLINE
FINISH
SYNTAX RESULT = 0
!
! AT THE END OF THIS ROUTINE, THE GLOBAL VARIABLE 'SYNTAX RESULT'
! WILL HAVE BITS SET TO INDICATE ERRORS AS FOLLOWS:
! 1 - "BRACKETS OR QUOTES IN PREDICATE"
! 2 - "PREDICATE MISSING"
! 4 - "UNRECOGNISED NAME IN PREDICATE"
! 128 - "PREDICATE INVALID FOR WHENEVER"
! IF 'SYNTAX RESULT' IS NOT ZERO ON EXIT, THEN 'SSOWN_WARNING NUMBER' WILL BE
! SET TO 20.
!
! CHECK THE PREDICATE:
IF P="" THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000002' ELSE START
S = PURGE (P, F, L)
IF L<=LENGTH(P) THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000001'
N = RECOGNISE IDENTIFIER (S)
IF N=0 THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000004'
UNLESS VARIABLES<N<COND LIM C
OR N=18 C
THEN SYNTAX RESULT = SYNTAX RESULT ! X'00000080'
FINISH
IF SYNTAX RESULT=0 THEN START
WHEN CONDITION = N - VARIABLES
WHEN SPEC_CLASS = T
WHEN SPEC_ADDRESS = SSOWN_SAVE PTR
FINISH ELSE START
SSOWN_WARNING NUMBER = 20
WHEN CONDITION = 0
FINISH
END
!
ROUTINE SAVE CALL IN SEQUENCE (STRING NAME C)
INTEGER ERROR
IF WHEN CONDITION=0 THEN RETURN
IF DIAGOP#0 THEN START
PRINT STRING ("++++ Saving call: """.C."""")
NEWLINE
PRINT STRING (" ".F)
NEWLINE
FINISH
IF SSOWN_ACCUMULATING=0 THEN START
SSOWN_ACCUMULATION_BOUND = 0
SSOWN_ACCUMULATION_ADDRESS = SSOWN_SAVE PTR
SSOWN_ACCUMULATING = -1
FINISH
IF SSOWN_ACCUMULATION_ADDRESS+SSOWN_ACCUMULATION_BOUND=SSOWN_SAVE PTR THEN START
SAVE BYTES (LENGTH(C), ADDR(C)+1, ERROR)
IF ERROR=0 THEN START
IF SSOWN_SAVE PTR>=SSOWN_SAVE LIM C
THEN ERROR = 1 C
ELSE START
BYTE INTEGER (SSOWN_SAVE PTR) = NL
SSOWN_SAVE PTR = SSOWN_SAVE PTR + 1
SSOWN_ACCUMULATION_BOUND = SSOWN_ACCUMULATION_BOUND + LENGTH (C) + 1
FINISH
FINISH
IF ERROR#0 THEN START
SSOWN_ACCUMULATION_ADDRESS = 0
FINISH
FINISH ELSE ERROR = 1
IF ERROR#0 THEN SSOWN_WARNING NUMBER = 21
END
!
!
ROUTINE SAVE STRINGS (STRING NAME C, F)
INTEGER ERROR
IF WHEN CONDITION=0 THEN RETURN
IF DIAGOP#0 THEN START
PRINT STRING ("++++ Saving: """.C."""")
NEWLINE
PRINT STRING (" ".F)
NEWLINE
FINISH
SAVE BYTES (LENGTH(C)+1, ADDR(C), ERROR)
IF ERROR=0 THEN SAVE BYTES (LENGTH(F)+1, ADDR(F), ERROR)
IF ERROR#0 THEN SSOWN_WARNING NUMBER = 21 ELSE START
WHEN SPEC_BOUND = LENGTH (C) + 1
STOW WHEN ACTION; ! WHAT IF THIS COULD FAIL?
FINISH
END
!
ROUTINE STOW WHEN ACTION
INTEGER W
! **** **** WHAT IF WHEN CONDITION=0 ? **** ****
IF WHEN CONDITION<=CONDITIONS C
THEN WHEN ACTION (WHEN CONDITION) = WHEN SPEC C
ELSE START
IF WHEN CONDITION=18-VARIABLES THEN START
FOR W=2,1,CONDITIONS CYCLE
WHEN ACTION (W) = WHEN SPEC
REPEAT
FINISH
FINISH
END
!
ROUTINE DEAL WITH MACRO C
(INTEGER NAME Q, STRING NAME OPENDATA, CLOSEDATA)
!
! ON EXIT FROM THIS ROUTINE, Q WILL BE ZERO IF IT HAS WORKED
! SUCCESSFULLY. OTHERWISE, BITS WILL BE SET IN Q TO INDICATE
! FAILURES.
! X'00000001' - KEYWORD MISSING IN DECLARATION
! X'00000004' - TOO MANY PARAMETER FIELDS IN DECLARATION
! X'00000400' - MACRO WORK AREA TOO FULL
! X'00000800' - CANNOT RECOGNISE MACRO HEADER
! X'00001000' - TOO MANY INPUT LEVELS
! X'00002000' - MACRO DECLARATION IGNORED - NO TEXT
! X'00004000' - WORK SPACE EXHAUSTED - DECLARATION FAILS
! X'00008000' - NAMELESS MACRO
! X'00010000' - TOO MANY MACROS
!
STRING (255) ROUTINE NAME
STRING (1) DUMMY
PROMPT ("Text:")
SSOWN_LAST PROMPT = -1
GATHER DATA (CLOSEDATA, 3)
IF SSOWN_ACCUMULATION_ADDRESS=0 THEN START
Q = X'00004000'
RETURN
FINISH
DISCARD DATA HEADER (OPENDATA)
IF SSOWN_ACCUMULATION_BOUND&X'00FFFFFF'=0 THEN START
Q = X'00002000'
RETURN
FINISH
! **** **** FOR TESTING ONLY **** ****
IF DIAGOP#0 THEN START
BEGIN
INTEGER J
PRINT STRING ("Accumulated text:")
NEWLINE
FOR J=1,1,SSOWN_ACCUMULATION_BOUND&X'00FFFFFF' CYCLE
PRINT SYMBOL (BYTE INTEGER(SSOWN_ACCUMULATION_ADDRESS+J-1))
REPEAT
PRINT STRING ("<< End of text")
NEWLINE
END
FINISH
! **** **** END OF TESTING CODE **** ****
EXAMINE MACRO C
(ROUTINE NAME,DUMMY,SSOWN_ACCUMULATION_BOUND,SSOWN_ACCUMULATION_ADDRESS,0,Q)
IF Q#0 THEN RETURN
IF ROUTINE NAME="" THEN START
Q = X'00008000'
RETURN
FINISH
IF KNOWN MACS>=MAC LIMIT THEN START
Q = X'00010000'
RETURN
FINISH
! **** **** TESTING **** ****
PRINT STRING ("++++ Declaring macro ".ROUTINE NAME.NLSTRING)
! **** **** ENDS **** ****
KNOWN MACS = KNOWN MACS + 1
MAC TEXT (KNOWN MACS) = SSOWN_ACCUMULATION
SSOWN_ACCUMULATION_ADDRESS = SSOWN_SAVE PTR
SAVE BYTES (LENGTH(ROUTINE NAME), ADDR(ROUTINE NAME)+1, Q)
IF Q=0 THEN START
SSOWN_ACCUMULATION_BOUND = LENGTH (ROUTINE NAME) ! X'18000000'
MAC NAME (KNOWN MACS) = SSOWN_ACCUMULATION
FINISH ELSE START
KNOWN MACS = KNOWN MACS - 1
FINISH
END
!
ROUTINE DO CALL (STRING NAME C, F, INTEGER NAME WF, FM, TRB)
INTEGER MN, A, B, J, L, NP, PF
STRING (255) ROUTINE NAME, PARMS, PARM TEXT
STRING (255) ARRAY DATALIM (1:2)
STRING (4) ARRAY KF (1:2)
RECORD (PD) ARRAY PVAL (1:2)
RECORD (FRF) FR
CONST INTEGER SS CHAR FILE TYPE = 3
!
!
ROUTINE SDELIM (STRING (64) MACPARM)
INTEGER L, B, J
APARAM (MACPARM, PARMS, 2, KF, 4, PVAL, NP, PF)
DATALIM (1) = SSOWN_D DELIM 1
DATALIM (2) = SSOWN_D DELIM 2
IF PF#0 OR NP#2 THEN START
! **** **** WHAT SHOULD WE DO HERE? **** ****
FINISH ELSE START
J = 1
WHILE J<=2 CYCLE
L = PVAL(J)_BOUND & X'00FFFFFF'
B = PVAL(J)_ADDRESS
IF J=L=1 AND BYTE INTEGER(B)='*' THEN START
J = 3; ! FORCE EXIT WITH DELIMITERS UNCHANGED.
FINISH ELSE START
IF L#0 THEN COPY TO STRING (PVAL(J), DATALIM(J))
FINISH
J = J + 1
REPEAT
FINISH
END
PARMS = ""
TRB = 0
WF = 0
IF SSOWN_BRACKET FLAG=0 C
THEN ANALYSE CALL N (C,F,ROUTINE NAME,PARMS,WF) C
ELSE ANALYSE CALL B (C,F,ROUTINE NAME,PARMS,WF)
IF WF#0 THEN START
IF DIAGOP#0 THEN START
PRINT STRING ("++++ Executing: """.C."""")
NEWLINE
PRINT STRING (" ".F)
NEWLINE
FINISH
FINISH ELSE START
UNLESS CTU#ROUTINE NAME#"" THEN START
IF DIAGOP#0 THEN START
PRINT STRING ("++++ Null call")
NEWLINE
FINISH
-> CALL DONE
FINISH
IF DIAGOP#0 THEN START
IF ROUTINE NAME=".?W" THEN START
LIST TRAPS
-> CALL DONE
FINISH
FINISH
IF ROUTINE NAME=".MACRO" THEN START
SDELIM ("FROM=.MACBEGIN,TO=.MACEND")
DEAL WITH MACRO (FM, DATALIM(1), DATALIM (2))
IF FM#0 THEN START
WF = 18
FINISH
-> CALL DONE
FINISH
!
IF ROUTINE NAME=".LOCATE" THEN START
PARM TEXT = "FILE"
APARAM C
(PARM TEXT, PARMS, 1, KF, 4, PVAL, NP, CMND FLAG)
IF CMND FLAG#0 THEN WF = 22 ELSE START
COPY TO STRING (PVAL(1), PARM TEXT)
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(PARM TEXT)+1, LENGTH(PARM TEXT))
FINISH
FINFO (PARM TEXT, 0, FR, RETURN CODE)
FILE FLAG = RETURN CODE
PRINT STRING ("++++ File ".PARM TEXT)
IF FILE FLAG=0 C
THEN PRINT STRING (" exists") C
ELSE START
PRINT STRING (" does not exist")
TRB = TRB ! X'00000001'
FINISH
NEWLINE
FINISH
-> CALL DONE
FINISH
!
IF ROUTINE NAME=".INPUT" THEN START
BEGIN
INTEGER DL, FILE BASE
RECORD (PD) DD
RECORD (HF) NAME FILE HEADER
PARM TEXT = "FILE"
APARAM C
(PARM TEXT, PARMS, 1, KF, 4, PVAL, NP, CMND FLAG)
IF CMND FLAG#0 THEN WF = 22 ELSE START
SUPPLY DATA DESCRIPTOR (DD)
COPY TO STRING (PVAL(1), PARM TEXT)
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(PARM TEXT)+1, LENGTH(PARM TEXT))
FINISH
FINFO (PARM TEXT, 0, FR, PF)
IF PF=0 THEN START
! FILE ALREADY EXISTS.
PRINT STRING ("**** File already exists")
NEWLINE
CMND FLAG = -1
TRB = TRB ! X'00000004'
FINISH ELSE START
DL = DD_BOUND & X'00FFFFFF'
OUTFILE (PARM TEXT, DL+32, 0, 0, FILE BASE, CMND FLAG)
IF CMND FLAG#0 THEN START
PRINT STRING ("**** Cannot create file")
NEWLINE
TRB = TRB ! X'00000004'
FINISH ELSE START
FILE HEADER == RECORD (FILE BASE)
FILE HEADER_DATA END = DL + 32
FILE HEADER_DATA START = 32
FILE HEADER_FILE TYPE = SS CHAR FILE TYPE
MOVE (DL, DD_ADDRESS, FILE BASE+32)
DISCONNECT (PARM TEXT, PF)
FINISH
FINISH
FINISH
END
-> CALL DONE
FINISH
!
IF ROUTINE NAME=".DELIMITERS" THEN START
SDELIM ("FROM=.DATA,TO=.ED")
SSOWN_D DELIM 1 = DATALIM (1)
SSOWN_D DELIM 2 = DATALIM (2)
-> CALL DONE
FINISH
IF ROUTINE NAME=".SAVERESULT" THEN START
PARM TEXT = "SAVE=A"
APARAM (PARM TEXT,PARMS,1,KF,4,PVAL,NP,CMND FLAG)
IF CMND FLAG#0 THEN WF = 22 ELSE START
COPY TO STRING (PVAL(1),PARM TEXT)
IF ULCEQUIV#0 THEN START
UCTRANSLATE (ADDR(PARM TEXT)+1, LENGTH(PARM TEXT))
FINISH
IF STARTSWITH(PARM TEXT,"RESULT",-1)#0 THEN START
FINISH
PF = 0
IF LENGTH(PARM TEXT)=1 C
THEN PF = BYTE INTEGER (ADDR(PARM TEXT)+1) - 'A' + 7
IF 7<=PF<=10 C
THEN VARS (PF) = RETURN CODE C
ELSE WF = 22
FINISH
-> CALL DONE
FINISH
IF ROUTINE NAME=".ENDJOB" THEN START
SSOWN_STATE = 10
-> CALL DONE
FINISH
IF DIAGOP#0 THEN START
PRINT STRING ("++++ Routine: """.ROUTINE NAME)
IF PARMS="" C
THEN PRINT STRING (""" with no parameters") C
ELSE PRINT STRING (""", parameters: """.PARMS."""")
NEWLINE
FINISH
L = LENGTH (ROUTINE NAME)
IF BYTE INTEGER(ADDR(ROUTINE NAME)+1)='#' THEN START
HASH COMMAND (SUBSTRING(ROUTINE NAME,2,L), PARMS)
AFTER COMMAND
-> CALL DONE
FINISH
IF KNOWN MACS>0 THEN START
A = ADDR (ROUTINE NAME)
FOR MN = KNOWN MACS,-1,1 CYCLE
IF MAC NAME(MN)_BOUND&X'00FFFFFF'=L THEN START
B = MAC NAME(MN)_ADDRESS - 1
!
! **** **** USE MACHINE CODE FOR THIS: **** ****
J = 1
WHILE J<=L C
AND BYTE INTEGER(A+J)=BYTE INTEGER(B+J) C
CYCLE
J = J + 1
REPEAT
! **** **** END OF MACHINE CODE SECTION **** ****
!
IF J>L THEN START
EXAMINE MACRO (ROUTINE NAME,PARMS, C
MAC TEXT(MN)_BOUND,MAC TEXT(MN)_ADDRESS, C
-1,FM)
IF FM#0 THEN START
WF = 19
FINISH
-> CALL DONE
FINISH
FINISH
REPEAT
FINISH
!
BEGIN
INTEGER BOUND LOADED, ADDRESS LOADED, TYPE LOADED
LONGINTEGERNAME DESC
! CALL LOADER.
DESC==LONGINTEGER(ADDR(BOUND LOADED))
IF L<=31 THEN START
IF NEWLOADER=0 THEN LOAD COMMAND (ROUTINE NAME, ROUTINE NAME, C
TYPE LOADED, BOUND LOADED, ADDRESS LOADED, LOAD FLAG) C
ELSE START
TYPE LOADED=CODE!MACRO
DESC=LOADEP(ROUTINENAME,TYPELOADED,LOADFLAG,SSOWN_LOADLEVEL)
! For consistency in this module TYPELOADED should be 1 for
! 'system commands'
IF LOADFLAG=0 AND TYPELOADED=CODE AND C
INTEGER(ADDRESS LOADED+4)<SSOWN_SSCURBGLA THEN TYPELOADED=1
FINISH
FINISH ELSE LOAD FLAG = 1
! PUT RESULT CODE IN 'LOAD FLAG'.
! SET UP 'TYPE LOADED', ETC.
IF LOAD FLAG#0 THEN START
PRINT STRING ("**** Failed to load ".ROUTINE NAME.NLSTRING)
TRB = TRB ! X'00000008'
FINISH ELSE START
IF TYPE LOADED=4 THEN START
EXAMINE MACRO (ROUTINE NAME,PARMS, C
BOUND LOADED,ADDRESS LOADED,-1,FM)
IF FM#0 THEN START
WF = 19
FINISH
FINISH ELSE START
! **** **** TEMPORARY BODGE TO DEAL WITH 'RUN' **** ****
UNLESS "OBEY"#ROUTINE NAME#"RUN" THEN TYPE LOADED = 2
! **** **** END OF TEMPORARY BODGE **** ****
IF TYPE LOADED=1 THEN CMND FLAG = 0 ELSE RETURN CODE = 0
PROG FLAG = 0
! FILE FLAG = 0
! ENTER CODE
PROMPT ("Data:")
SSOWN_LAST PROMPT = -1
BEFORE COMMAND
! Set up the CLI strings SSOWN_CLICOMM and SSOWN_CLIPARM so that user progs can
! interrogate them with %systemstringfns CLICOMMAND and CLIPARAM
SSOWN_CLICOMM=ROUTINE NAME
SSOWN_CLIPARM=PARMS
COMREG (24) = 0
IF ULCEQUIV=0 THEN START
CLOSE UP (PARMS)
FINISH ELSE START
CAST OUT (PARMS)
FINISH
ENTER (2, BOUND LOADED, ADDRESS LOADED, PARMS)
! TIDY UP AFTER EXIT
AFTER COMMAND
! PUT RESULTS INTO THE
! APPROPRIATE VARIABLES
PROG FLAG = COMREG (10)
IF TYPE LOADED=1 THEN START
CMND FLAG = COMREG (24)
IF CMND FLAG#0 THEN TRB = TRB ! X'00000004'
FINISH ELSE START
RETURN CODE = COMREG (24)
NEWLINE
IF RETURN CODE#0 THEN START
PRINT STRING ("++++ Result code =")
WRITE (RETURN CODE,3)
NEWLINE
TRB = TRB ! X'00000001'
FINISH
FINISH
IF PROG FLAG#0 THEN START
TRB = TRB ! X'00000002'
FINISH
! %IF FILE FLAG#0 %THEN %START
! TRB = TRB ! X'00000020'
! %FINISH
FINISH
FINISH
END
!
CALL DONE:
FINISH
END
!
!
ROUTINE RESTORE VALUES
SSOWN_STATE = OUTER STATE
SSOWN_WARNING NUMBER = OUTER WARNING
SSOWN_BRACKET FLAG = LAST BRACKET FLAG
SSOWN_D DELIM 1 = OLD D1
SSOWN_D DELIM 2 = OLD D2
END
!
!
END
!
! AFTER THE %END %OF %FILE, THIS FILE ACTUALLY CONTAINS
! FURTHER TEXT! VIZ, THE ORIGINAL VERSION OF 'GET STMT'
! IN CASE IT IS NEEDED FOR REFERENCE.
!
END OF FILE
!
! HERE FOLLOWS THE 'COMPACT' VERSION OF THE MAIN SWITCH IN
! THE INTERPRETER.
ACTION (2):
UNLESS 0#TAKE ELSE#1 THEN WARNING NUMBER = 2
ACTION (3):
ACTION (16):
GATHER DATA (D DELIM 2, 1)
-> ACT DONE
!
ACTION (45):
! TIDY ACCUMULATION (0)
ACCUMULATING = 0
ACCUMULATION_BOUND = ACCUMULATION_BOUND ! X'18000000'
-> SET CLOSE
ACTION (4):
ACTION (37):
IF STMT="" THEN WARNING NUMBER = 5
ACTION (17):
ACTION (25):
SET CLOSE:
STATE = 10; ! CLOSING DOWN
-> ACT DONE
!
ACTION (6):
TAKE ELSE = 0
ACTION (38):
DO CALL (CALL,CFLAGS,WARNING NUMBER,SYNTAX RESULT,TRAP BITS)
-> ACT DONE
!
ACTION (8):
COND = EVAL
IF COND=0 THEN -> REJECT ELSE
ACTION (7):
DESTINATION = PURGE (DEST,DFLAGS,REMPTR)
IF REMPTR<=LENGTH(DEST) OR DESTINATION="" OR DESTINATION="-" C
THEN WARNING NUMBER = 17 C
ELSE START
IF BYTE INTEGER(ADDR(DESTINATION)+1)='-' THEN START
GO BACK
DESTINATION = C
SUBSTRING (DESTINATION, 2, LENGTH(DESTINATION))
FINISH
STATE = 2; ! SCANNING FOR LABEL
FINISH
-> REJECT ELSE
!
ACTION (9):
COND = EVAL
IF COND#0 THEN START
DO CALL (CALL,CFLAGS,WARNING NUMBER,SYNTAX RESULT,TRAP BITS)
TAKE ELSE = 1
FINISH ELSE TAKE ELSE = 2
-> ACT DONE
!
ACTION (10):
COND = EVAL
LAST STATE = STATE
IF COND#0 THEN STATE = 4 ELSE STATE = 3
! OBEY FIRST HALF OR SKIP TO SECOND HALF
-> ACT DONE
!
ACTION (11):
IF TAKE ELSE#1 THEN START
IF TAKE ELSE=2 C
THEN DO CALL C
(CALL,CFLAGS,WARNING NUMBER,SYNTAX RESULT,TRAP BITS) C
ELSE WARNING NUMBER = 7
-> REJECT ELSE
FINISH ELSE TAKE ELSE = 3
-> ACT DONE
!
ACTION (13):
TAKE ELSE = 0
ACTION (40):
DESTINATION = PURGE (DEST,DFLAGS,REMPTR)
IF REMPTR<=LENGTH(DEST) C
OR DESTINATION="" C
OR BYTE INTEGER(ADDR(DESTINATION)+1)='-' C
THEN WARNING NUMBER = 17 C
ELSE START
SAVE COND (PRED,PFLAGS,1)
IF WARNING NUMBER=0 THEN SAVE STRINGS (DESTINATION,NULLSTRING)
FINISH
-> ACT DONE
!
ACTION (14):
TAKE ELSE = 0
ACTION (41):
SAVE COND (PRED,PFLAGS,2)
IF WARNING NUMBER=0 THEN SAVE STRINGS (CALL,CFLAGS)
-> ACT DONE
!
ACTION (15):
TAKE ELSE = 0
ACTION (42):
SAVE COND (PRED,PFLAGS,3)
IF WARNING NUMBER=0 THEN START
STATE BEFORE WHEN = STATE
STATE = 9; ! ACCUMULATING WHENEVER TEXT
FINISH
-> ACT DONE
!
ACTION (19):
TAKE ELSE = 1
-> ACT DONE
!
ACTION (20):
LAST STATE = STATE
STATE = 7; ! SKIPPING TO .FINISH
-> ACT DONE
!
ACTION (21):
IF TAKE ELSE#0 THEN -> REJECT ELSE
WARNING NUMBER = 7
-> ACT DONE
!
ACTION (22):
ACTION (34):
LAST STATE = STATE
STATE = 8; ! SKIPPING OVER .WHENEVER
-> ACT DONE
!
ACTION (29):
STATE = 6
-> FLAGACT
ACTION (30):
STATE = 5
FLAG ACT:
IF CALL#"" THEN WARNING NUMBER = 11
-> ACT DONE
!
ACTION (32):
STATE = 1
-> REJECT ELSE
!
ACTION (33):
STATE = LAST STATE
-> REJECT ELSE
!
ACTION (44):
ACTION (43):
GATHER DATA (D DELIM 2, 2)
-> ACT DONE
!
ACTION (46):
SAVE CALL IN SEQUENCE (CALL)
-> ACT DONE
!
ACTION (47):
ACCUMULATING = 0
WHEN SPEC_BOUND = SAVE PTR - WHEN SPEC_ADDRESS
STOW WHEN ACTION
STATE = STATE BEFORE WHEN
ACTION (1):
ACTION (5):
ACTION (12):
ACTION (18):
REJECT ELSE:
TAKE ELSE = 0
ACTION (23):
ACTION (26):
ACTION (27):
ACTION (28):
ACTION (31):
ACTION (39):
ACTION (48):
ACT DONE:
! HERE ENDS THE 'COMPACT' VERSION OF THE MAIN SWITCH IN
! THE INTERPRETER.
!
! HERE FOLLOWS THE OLD SWITCH-DRIVEN VERSION OF 'GET STMT':
! IT DOES NOT DEAL WITH THE 'CANCEL' PARAMETER.
ROUTINE SPEC GET STMT C
(INTEGER BRACKET OPTION, C
INTEGER QUOTE CONTRACTION, C
INTEGER COMM, C
STRING (80) D DELIM 1, C
STRING (80) CONT, C
STRING NAME INPUT, C
STRING NAME RECON, C
STRING NAME MARKS, C
INTEGER NAME RESULT)
ROUTINE GET STMT C
(INTEGER BRACKET OPTION, C
INTEGER QUOTE CONTRACTION, C
INTEGER COMM, C
STRING (80) D DELIM 1, C
STRING (80) CONT, C
STRING NAME INPUT, C
STRING NAME RECON, C
STRING NAME MARKS, C
INTEGER NAME RESULT)
!
! THIS ROUTINE READS A COMPLETE STATEMENT VIA 'MASTER CHAR IN'
! (I.E., THROUGH THE MACRO EXPANSION PROCESS WHEN APPROPRIATE).
! THE UNPROCESSED TEXT WILL BE COPIED INTO THE STRING 'INPUT'.
! THE LAST CHARACTER READ WILL ALWAYS BE A NEWLINE (OR END-OF-FILE)
! UNLESS THE TEXT OVERFLOWS 'INPUT', IN WHICH CASE READING STOPS
! AT THAT POINT.
! THE TEXT AFTER RECONSTRUCTION IS PUT INTO 'RECON'. RECONSTRUCTION
! MEANS THAT -
! EACH COMMENT IS REPLACED BY A SINGLE SPACE.
! QUOTES ARE PROPERLY MATCHED, SO THAT A NEWLINE IN QUOTES DOES NOT
! TERMINATE A STATEMENT. NO LINE RECONSTRUCTION IS APPLIED TO TEXT
! IN QUOTES (EXCEPT TRAILING SPACE DELETION).
! IF THE 'BRACKETS' OPTION IS USED, BRACKETS ARE PROPERLY MATCHED, AND
! A NEWLINE WITHIN BRACKETS DOES NOT TERMINATE THE STATEMENT. IT IS
! REPLACED BY A SINGLE SPACE, AND THE TEXT FROM THE NEXT LINE IS
! PROCESSED AS PART OF THE STATEMENT.
! WHERE A LINE ENDS WITH THE CONTINUATION MARKER, ALL CHARACTERS FROM
! THE MARKER TO THE NEWLINE ARE REPLACED BY A SINGLE SPACE, AND
! THE TEXT FROM THE NEXT LINE IS PROCESSED AS PART OF THE STATEMENT.
! THE TERMINATING NEWLINE OR END-OF-FILE CHARACTER WILL HAVE BEEN
! REMOVED, AND THE TEXT WILL HAVE NO LEADING OR TRAILING SPACES.
! ALL MULTIPLE SPACES, EXCEPT IN QUOTES, ARE REPLACED BY SINGLE SPACES.
!
! BRACKET OPTION=0 MEANS 'ASSUME NOBRACKETS'
! #0 MEANS 'ASSUME BRACKETS OPTION'.
! QUOTE CONTRACTION#0 MEANS 'REDUCE "" TO " IF ALREADY IN QUOTES'
! =0 MEANS DON'T.
! COMM IS THE (SINGLE BYTE) COMMENT SYMBOL.
! D DELIM 1 IS THE OPENING DATA DELIMITER.
! CONT IS THE CONTINUATION MARKER.
! RAW TEXT WILL BE PUT INTO 'INPUT'.
! TEXT AFTER LINE RECONSTRUCTION WILL BE PUT INTO 'RECON'.
! CORRESPONDING TO EACH BYTE IN 'RECON' WILL BE ONE BYTE IN THE SAME
! POSITION IN 'MARKS'.
! 'MARKS' WILL GET:
! IN PLAIN TEXT IN BRACKETS
! SPACE OR NEWLINE A B
! TEXT C D
! TEXT IN QUOTES E F
!
! THE OUTER BRACKETS (AND OF COURSE INNER BRACKETS ALSO)
! IN A SEQUENCE OF TEXT-IN-BRACKETS GET THE FLAG 'D'.
! THE OUTER QUOTES IN A SEQUENCE OF TEXT-IN-QUOTES GET THE
! FLAG 'E', OR 'F' IF IN BRACKETS.
!
! THE MAXIMUM LENGTH OF THE STRINGS INPUT, RECON AND MARKS MUST BE 255.
!
! RESULT WILL GET A VALUE TO INDICATE THE SUCCESS OR FAILURE OF
! GET STMT, AS FOLLOWS:
! RESULT = 0: O.K.
! RESULT = 1: OPENING DATA DELIMITER FOUND.
! RESULT = 2: INCOMPLETE STATEMENT BEFORE DATA DELIMITER.
! RESULT = 3: INCOMPLETE STATEMENT BEFORE END OF FILE.
! RESULT = 4: STATEMENT TOO LONG.
! RESULT = -1: PARAMETERS UNACCEPTABLE.
!
!
SWITCH HANDLE (7:48)
INTEGER C, D, CSW, STATE, LEADING SPACES SEEN, LAST TERMINATOR
INTEGER INPUT CHAR ADDR, RECON CHAR ADDR, BRACKET LEVEL
INTEGER PARMS OK, SWAC
! INPUT GETS AN UNRECONSTRUCTED COPY OF THE TEXT READ IN.
! STATES ARE -
! 1: START OF LINE.
! 2: PLAIN TEXT.
! 3: PLAIN AFTER SPACE.
! 4: IN QUOTES.
! 5: IN COMMENT.
! 6: AFTER CLOSING QUOTE.
!
! N.B. START-OF-LINE IS NOT NECESSARILY START-OF-STATEMENT. IN
! PARTICULAR, THE LINE MAY NOT BEGIN IN THE FIRST CHARACTER OF
! THE STRING, AND 'BRACKET LEVEL' MAY BE NON-ZERO AT
! START-OF-LINE.
!
! PLAIN-AFTER-SPACE IS DIVIDED INTO TWO SUB-STATES. IF THE SPACE
! WAS A SPACE IN THE INPUT TEXT, THEN 'SWAC=0'. IF THE SPACE
! REPLACED SOME DISCARDED CHARACTER, THEN 'SWAC#0'.
!
! COMMENT IS DIVIDED INTO TWO SUB-STATES: COMMENT-AT-START-OF-LINE
! IS DISTINGUISHED FROM COMMENT BY
! 'RECON CHAR ADDR=LAST TERMINATOR'.
!
! CHECK PARAMETERS:
PARMS OK = -1; ! TRUE.
BEGIN
STRING (255) C1, C2
IF CONT="" C
OR D DELIM 1="" C
OR COMM=' ' C
OR COMM='"' C
OR CONT->C1.(TOSTRING(COMM)).C2 C
OR CONT->C1.(" ").C2 C
OR CONT->C1.("""").C2 C
OR D DELIM 1->C1.(TOSTRING(COMM)).C2 C
OR D DELIM 1->C1.(" ").C2 C
OR D DELIM 1->C1.("""").C2 C
OR D DELIM 1->C1.(CONT).C2 C
OR CONT->C1.(D DELIM 1).C2 C
THEN PARMS OK = 0; ! FALSE.
END
IF PARMS OK=0 THEN START
RESULT = -1
RETURN
FINISH
!
STATE = 1; ! START OF STATEMENT.
LEADING SPACES SEEN = 0; ! FALSE.
INPUT = ""
RECON = ""
MARKS = ""
LAST TERMINATOR = 0
INPUT CHAR ADDR = 0
RECON CHAR ADDR = 0
BRACKET LEVEL = 0
-> IN C; ! TO READ THE FIRST CHARACTER OF THE STATEMENT.
!
HANDLE (42): ! STATE 6 - AFTER CLOSING QUOTE.
! CSW 0 - NEWLINE FOUND.
LINE END:
UNLESS BRACKET OPTION#0#BRACKET LEVEL THEN START
! STATEMENT COMPLETE.
RESULT = 0
-> TIDY UP
FINISH
! WE HAVE NOT YET COME TO END OF STATEMENT.
STATE = 1; ! CARRY ON TO NEXT LINE IN "START-OF-LINE MODE".
INSERT TERMINATOR:
C = ' '; ! USE A SPACE FOR THE LINE TERMINATOR.
STRING TERMINATOR:
LEADING SPACES SEEN = 0
LAST TERMINATOR = RECON CHAR ADDR + 1; ! I.E., WHERE THE
! TERMINATOR SYMBOL WILL BE PUT IN THE RECONSTRUCTED LINE.
! CARRY ON TO INSERT THE CHARACTER -
HANDLE (20): ! STATE 2 - PLAIN TEXT.
! CSW 6 - NOT A SPECIAL CHARACTER.
! INSERT CHAR IN RECONSTRUCTED LINE.
HANDLE (30): ! STATE 4 - IN QUOTES.
! CSW 2 - COMMENT SYMBOL FOUND.
! INSERT CHAR IN RECONSTRUCTED LINE.
HANDLE (31): ! STATE 4 - IN QUOTES.
! CSW 3 - SPACE FOUND.
! INSERT CHAR IN RECONSTRUCTED LINE.
HANDLE (32): ! STATE 4 - IN QUOTES.
! CSW 4 - OPEN BRACKET FOUND.
! INSERT CHAR IN RECONSTRUCTED LINE.
HANDLE (33): ! STATE 4 - IN QUOTES.
! CSW 5 - CLOSE BRACKET FOUND.
! INSERT CHAR IN RECONSTRUCTED LINE.
HANDLE (34): ! STATE 4 - IN QUOTES.
! CSW 6 - NOT A SPECIAL CHARACTER.
! INSERT CHAR IN RECONSTRUCTED LINE.
INSERT: ! PUT CHARACTER IN RECONSTRUCTED LINE.
! FIRST DECIDE WHAT CHARACTER TO PUT IN 'MARKS'.
UNLESS 4#STATE#6 THEN D = 'E' ELSE START
UNLESS ' '#C#NL THEN D = 'A' ELSE START
IF C=')' AND BRACKET LEVEL=0 C
AND RECON CHAR ADDR>0 C
AND C
(BYTE INTEGER(ADDR(MARKS)+RECON CHAR ADDR)-'A') C
&1#0 C
THEN D = 'D' C
ELSE D = 'C'
FINISH
FINISH
IF BRACKET LEVEL>0 THEN D = D + 1
!
RECON CHAR ADDR = RECON CHAR ADDR + 1
IF RECON CHAR ADDR>255 THEN -> L O L
BYTE INTEGER (ADDR(RECON)+RECON CHAR ADDR) = C
BYTE INTEGER (ADDR(MARKS)+RECON CHAR ADDR) = D
LENGTH (RECON) = RECON CHAR ADDR
LENGTH (MARKS) = RECON CHAR ADDR
HANDLE (24): ! STATE 3 - PLAIN AFTER SPACE.
! CSW 3 - SPACE FOUND.
! NO ACTION.
HANDLE (36): ! STATE 5 - IN COMMENT.
! CSW 1 - DOUBLE-QUOTE FOUND.
! NO ACTION.
HANDLE (38): ! STATE 5 - IN COMMENT.
! CSW 3 - SPACE FOUND.
! NO ACTION.
HANDLE (39): ! STATE 5 - IN COMMENT.
! CSW 4 - OPEN BRACKET FOUND.
! NO ACTION.
HANDLE (40): ! STATE 5 - IN COMMENT.
! CSW 5 - CLOSE BRACKET FOUND.
! NO ACTION.
HANDLE (41): ! STATE 5 - IN COMMENT.
! CSW 6 - NOT A SPECIAL CHARACTER.
! NO ACTION.
IN C: ! READ IN NEXT CHARACTER.
C = MASTER CHAR IN (1)
IF C=25 THEN -> E O F
! APPEND INPUT CHARACTER ONTO INPUT STRING.
INPUT CHAR ADDR = INPUT CHAR ADDR + 1
IF INPUT CHAR ADDR>255 THEN -> L O L
BYTE INTEGER (ADDR(INPUT)+INPUT CHAR ADDR) = C
LENGTH (INPUT) = INPUT CHAR ADDR
! DISTINGUISH VARIOUS INTERESTING CHARACTERS.
IF C=NL THEN CSW = 0 ELSE START
IF C='"' THEN CSW = 1 ELSE START
IF C=COMM THEN CSW = 2 ELSE START
IF C=' ' THEN CSW = 3 ELSE START
IF C='(' THEN CSW = 4 ELSE START
IF C=')' THEN CSW = 5 ELSE START
CSW = 6
FINISH
FINISH
FINISH
FINISH
FINISH
FINISH
! CSW IS 0 FOR A NEWLINE,
! 1 FOR A DOUBLE-QUOTE,
! 2 FOR A COMMENT SYMBOL,
! 3 FOR A SPACE,
! 4 FOR AN OPEN BRACKET,
! 5 FOR A CLOSING BRACKET,
! 6 FOR ANY OTHER CHARACTER.
!
-> HANDLE (STATE*7 + CSW); ! SWITCH TO PROCESS INPUT CHARACTER.
!
HANDLE (7): ! STATE 1 - START OF STATEMENT.
! CSW 0 - NEWLINE FOUND.
LEADING SPACES SEEN = 0
-> IN C
!
HANDLE (43): ! STATE 6 - AFTER CLOSING QUOTE.
! CSW 1 - DOUBLE-QUOTE FOUND.
IF QUOTE CONTRACTION#0 THEN START
STATE = 4; ! NOW IN QUOTES AGAIN.
-> IN C; ! PUT NOTHING IN THE RECONSTRUCTED LINE -
! JUST GO AND GET THE NEXT CHARACTER.
FINISH
HANDLE (8): ! STATE 1 - START OF STATEMENT.
! CSW 1 - DOUBLE-QUOTE FOUND.
HANDLE (15): ! STATE 2 - PLAIN TEXT.
! CSW 1 - DOUBLE-QUOTE FOUND.
HANDLE (22): ! STATE 3 - PLAIN AFTER SPACE.
! CSW 1 - DOUBLE-QUOTE FOUND.
STATE = 4; ! NOW IN QUOTES.
-> INSERT; ! PUT THE CHARACTER IN THE RECONSTRUCTED LINE.
!
HANDLE (9): ! STATE 1 - START OF STATEMENT.
! CSW 2 - COMMENT SYMBOL FOUND.
LEADING SPACES SEEN = -1; ! TRUE -
! TREAT THE COMMENT LIKE A SPACE.
HANDLE (23): ! STATE 3 - PLAIN AFTER SPACE.
! CSW 2 - COMMENT SYMBOL FOUND.
STATE = 5; ! NOW IN COMMENT.
-> IN C; ! DON'T PUT THIS CHARACTER IN THE RECONSTRUCTED
! LINE: JUST GO AND GET THE NEXT ONE.
!
HANDLE (10): ! STATE 1 - START OF STATEMENT.
! CSW 3 - SPACE FOUND.
LEADING SPACES SEEN = -1; ! TRUE.
-> IN C; ! HAVING REMEMBERED THAT WE'VE SEEN THIS
! CHARACTER, WE IGNORE IT AND GET THE NEXT ONE.
!
HANDLE (11): ! STATE 1 - START OF STATEMENT.
! CSW 4 - OPEN BRACKET FOUND.
HANDLE (25): ! STATE 3 - PLAIN AFTER SPACE.
! CSW 4 - OPEN BRACKET FOUND.
HANDLE (46): ! STATE 6 - AFTER CLOSING QUOTE.
! CSW 4 - OPEN BRACKET FOUND.
STATE = 2; ! NOW IN PLAIN TEXT.
HANDLE (18): ! STATE 2 - PLAIN TEXT.
! CSW 4 - OPEN BRACKET FOUND.
! REMEMBER THE OPEN BRACKET:
BRACKET LEVEL = BRACKET LEVEL + 1
-> INSERT; ! PUT THE CHARACTER IN THE RECONSTRUCTED LINE.
!
HANDLE (12): ! STATE 1 - START OF STATEMENT.
! CSW 5 - CLOSE BRACKET FOUND.
HANDLE (26): ! STATE 3 - PLAIN AFTER SPACE.
! CSW 5 - CLOSE BRACKET FOUND.
HANDLE (47): ! STATE 6 - AFTER CLOSING QUOTE.
! CSW 5 - CLOSE BRACKET FOUND.
STATE = 2; ! NOW IN PLAIN TEXT.
HANDLE (19): ! STATE 2 - PLAIN TEXT.
! CSW 5 - CLOSE BRACKET FOUND.
! REMEMBER THE CLOSE BRACKET:
IF BRACKET LEVEL>0 THEN BRACKET LEVEL = BRACKET LEVEL - 1
-> INSERT; ! PUT THE CHARACTER IN THE RECONSTRUCTED LINE.
!
HANDLE (13): ! STATE 1 - START OF STATEMENT.
! CSW 6 - NOT A SPECIAL CHARACTER.
HANDLE (27): ! STATE 3 - PLAIN AFTER SPACE.
! CSW 6 - NOT A SPECIAL CHARACTER.
HANDLE (48): ! STATE 6 - AFTER CLOSING QUOTE.
! CSW 6 - NOT A SPECIAL CHARACTER.
STATE = 2; ! NOW IN PLAIN TEXT.
-> INSERT; ! PUT THE CHARACTER IN THE RECONSTRUCTED LINE.
!
HANDLE (16): ! STATE 2 - PLAIN TEXT.
! CSW 2 - COMMENT SYMBOL FOUND.
HANDLE (44): ! STATE 6 - AFTER CLOSING QUOTE.
! CSW 2 - COMMENT SYMBOL FOUND.
STATE = 5; ! NOW IN COMMENT.
C = ' '; ! SUBSTITUTE A SPACE IN THE RECONSTRUCTED LINE.
-> INSERT; ! PUT THE CHARACTER IN THE RECONSTRUCTED LINE.
!
HANDLE (21): ! STATE 3 - PLAIN AFTER SPACE.
! CSW 0 - NEWLINE FOUND.
! DISCARD TRAILING SPACES (THERE WILL BE EXACTLY ONE).
RECON CHAR ADDR = RECON CHAR ADDR - 1
LENGTH (RECON) = RECON CHAR ADDR
IF SWAC#0 THEN -> LINE END
HANDLE (14): ! STATE 2 - PLAIN TEXT.
! CSW 0 - NEWLINE FOUND.
! THERE ARE NO TRAILING SPACES WHEN WE GET HERE.
IF LEADING SPACES SEEN=0 C
AND SUBSTRING(RECON,LAST TERMINATOR+1, C
RECON CHAR ADDR)=D DELIM 1 C
THEN START
IF LAST TERMINATOR=0 THEN -> D D FOUND ELSE -> I C S
FINISH
! NEXT WE CHECK WHETHER THE LINE ENDS WITH
! A CONTINUATION MARKER.
IF RECON CHAR ADDR>=LENGTH(CONT) C
AND SUBSTRING(RECON,RECON CHAR ADDR-LENGTH(CONT)+1, C
RECON CHAR ADDR)=CONT C
THEN START
! DISCARD THE CONTINUATION MARKER, AND
! ADJUST RECON CHAR ADDR.
RECON CHAR ADDR = RECON CHAR ADDR - LENGTH (CONT)
LENGTH (RECON) = RECON CHAR ADDR
STATE = 1; LEADING SPACES SEEN = 0
! IF THE LINE DOES NOT END WITH A SPACE (NOW THAT THE
! CONTINUATION MARKER HAS BEEN REMOVED), WE PUT THE
! SPACE IN.
IF RECON CHAR ADDR>0 C
AND NL#BYTEINTEGER(ADDR(RECON)+RECON CHAR ADDR)#' ' C
THEN START
LAST TERMINATOR = RECON CHAR ADDR + 1
C = ' '
-> INSERT
FINISH
! LAST CHARACTER WAS A SPACE, SO WE DON'T INSERT ANOTHER.
LAST TERMINATOR = RECON CHAR ADDR
-> IN C
FINISH
-> LINE END
!
HANDLE (17): ! STATE 2 - PLAIN TEXT.
! CSW 3 - SPACE FOUND.
HANDLE (45): ! STATE 6 - AFTER CLOSING QUOTE.
! CSW 3 - SPACE FOUND.
STATE = 3; SWAC = 0; ! NOW IN PLAIN-AFTER-SPACE.
-> INSERT; ! PUT THE CHARACTER IN THE RECONSTRUCTED LINE.
!
HANDLE (28): ! STATE 4 - IN QUOTES.
! CSW 0 - NEWLINE FOUND.
! THERE MAY BE SEVERAL TRAILING SPACES (OR NONE) TO DISCARD.
WHILE BYTE INTEGER(ADDR(RECON)+RECON CHAR ADDR)=' ' CYCLE
RECON CHAR ADDR = RECON CHAR ADDR - 1
REPEAT
LENGTH (RECON) = RECON CHAR ADDR
! WE COULD NOT BE 'IN QUOTES' IF THE FIRST LINE OF THE
! STATEMENT WERE AN OPENING DATA DELIMITER, SO WE ONLY
! TEST SUBSEQUENT LINES.
IF LAST TERMINATOR#0 C
AND RECON CHAR ADDR>LAST TERMINATOR C
AND SUBSTRING(RECON,LAST TERMINATOR+1, C
RECON CHAR ADDR)=D DELIM 1 C
THEN -> I C S; ! INCOMPLETE STATEMENT FOUND BEFORE DELIMITER.
-> STRING TERMINATOR
!
HANDLE (29): ! STATE 4 - IN QUOTES.
! CSW 1 - DOUBLE-QUOTE FOUND.
STATE = 6; ! AFTER CLOSING QUOTE.
-> INSERT; ! PUT THE CHARACTER IN THE RECONSTRUCTED LINE.
!
HANDLE (35): ! STATE 5 - IN COMMENT.
! CSW 0 - NEWLINE FOUND.
! THERE MAY BE ONE TRAILING SPACE OR NONE.
IF RECON CHAR ADDR=LAST TERMINATOR THEN START
! THIS STATE - COMMENT WITH RECON CHAR ADDR=LAST TERMINATOR -
! IS ACTUALLY DISTINCT FROM ALL THE OTHERS, BUT
! THE DISTINCTION IS SO RARELY SIGNIFICANT (I.E.,
! NOWHERE ELSE BUT HERE AND AT HANDLE(37)) THAT
! NO SPECIFIC STATE NUMBER HAS BEEN ALLOCATED.
!
! WE ARE AT THE END OF A COMMENT WHICH STARTED ON THE
! FIRST CHARACTER OF THE RECONSTRUCTED LINE, SO THAT IT
! HAS NOT BEEN REPLACED BY A SINGLE SPACE,
! AND WE HAVE ONLY TO RESET THE CONDITIONS FOR
! START-OF-STATEMENT AND GO ON TO THE NEXT LINE.
STATE = 1; ! START OF STATEMENT.
LEADING SPACES SEEN = 0
-> IN C
FINISH ELSE START
! WE ARE IN A COMMENT WHICH STARTED AFTER THE
! START OF STATEMENT. THERE WILL BE
! A SINGLE TRAILING SPACE TO DELETE.
RECON CHAR ADDR = RECON CHAR ADDR - 1
LENGTH (RECON) = RECON CHAR ADDR
! RECON CHAR ADDR CANNOT BE ZERO HERE.
-> LINE END
FINISH
!
HANDLE (37): ! STATE 5 - IN COMMENT.
! CSW 2 - COMMENT SYMBOL FOUND.
IF RECON CHAR ADDR=LAST TERMINATOR THEN START
STATE = 1
FINISH ELSE START
STATE = 3
SWAC = -1
FINISH
! NOW IN PLAIN-AFTER-SPACE UNLESS WE HAVE JUST SEEN THE END
! OF A COMMENT WHICH STARTED AT THE BEGINNING OF THE
! RECONSTRUCTED LINE, IN WHICH CASE WE REVERT TO
! START-OF-STATEMENT.
-> IN C; ! PUT NOTHING IN THE RECONSTRUCTED LINE -
! JUST GO AND GET THE NEXT CHARACTER.
!
L O L: ! LINE TOO LONG.
WHILE NL#C#25 CYCLE
C = MASTER CHAR IN (1)
REPEAT
RESULT = 4
-> TIDY UP
!
E O F: ! INCOMPLETE STATEMENT FOUND BEFORE END-OF-FILE.
RESULT = 3
-> TIDY UP
!
I C S: ! INCOMPLETE STATEMENT FOUND BEFORE OPENING DATA DELIMITER.
RESULT = 2
-> TIDY UP
!
D D FOUND: ! OPENING DATA DELIMITER FOUND.
RESULT = 1
!
TIDY UP:
LENGTH (MARKS) = RECON CHAR ADDR
RETURN
!
END