|
DataMuseum.dkPresents historical artifacts from the history of: Philips Data Systems |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Philips Data Systems Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 52490 (0xcd0a)
Notes: pts_type(SC)
Names: »OBJVAL.SC«
└─⟦f45ea3bc3⟧ Bits:30009713 Philips computer tape "WSM"
└─⟦this⟧ »WSM:CREA/OBJVAL.SC«
IDENT OBJVAL REL=2.3,850703,870155940230
**********************************************************************
*
* LATEST UPDATE 850703 MADE BY:JE
*
* HISTORY=
* 850703/JE CHECK IF VALBUF EMPTY AFTER MODIFICATION
* 850606/JE CHECK OVFL-ENTRIES IN ATTAB ROUTINE 'VARDET'
* 850509/JE ORDER OF CONTROL CHANGED VARDET BEFORE FUNCTIONS
* 850327/JE SYNTAX ERROR NOT FOUND IN ERR "HI............."
* 850313/JE PERFORMANCE DIRECT MOVE VAL.OBJ. WHEN UNCHANGED
* 850305/JE SECURITY WHEN DISASTER ERRORS (LOST FIDS ETC.)
* 850214/JE FASTER PROCESSING OF EVALUATION OF FID:S
* 841120/CJ MUL&DIV NOW FROM ASS.ROUTINE
* 840921/CJ BASIC ERROR IF FID= AB OR ST - SOLVED
* 831208/CJ ADAPTION TO "NEW" POLICE
* 831205/CJ OBJSTR-> INTERMEDIATE BUFFER OBJCT OF 1 LINE
* 830519/CJ TAKE CARE OF WHEN "VALBUF" IS COMPLETILY FILLED
* 830422/CJ EXTANSION OF ATTRIBUTES "ATTR" SA,CA
*
**********************************************************************
DDUM WSMDDV
PDIV
ENTRY OBJVAL ***OBJECT OF VALIDATION
EXPROC POLICE,PBIN,PBOOL,PBOOL,PSTRG ***POOL LIMIT CONTROLER
EXPROC MOVVAL ***MOVE VALIDATION OBJECT
EXT ICLEAR ---CLEAR ITEM
EXT EMPTYT ---CHECK IF EMPTY
EXT GETIND ---GET ITEM LENGTH
EXT SETB ---SET BIT POSITION
EXT WXMUL ---MULTIPLICATION
EXT WXDIV ---DIVISION
EXT WXSLL ---SHIFT LEFT
EJECT
*
* OBJECT OF VALIDATION
*
* INPUT : VALBUF = VALIDATION BUFFER
* LBIN2 = OPTIONAL ATTRIBUTE CODE = 1
* LBIN20 = TOTAL LENGTH OF OPTIONAL ATTRIBUTES
* GBIN4 = INDEX TO BUFFER POOL
* GBIN5 = POINTER TO BUFFER POOL
*
* USED : LBIN1 = WORK
* LBIN3 = WORK
* LBIN12 = WORK
* SLBIN6 = WORK
* LBIN15 = WORK
* SLBIN5 = WORK
* SLBIN4 = WORK
* LBIN4 = BASIC LINE POINTER
* VBIN1 = SAVED START POINTER OF OPTIONAL VALIDATION
* VBIN2 = LENGTH OF VALIDATION
* VBIN3 = INTER MEDIATE BUFFER POINTER
* VBIN4 = LENGTH-LIMIT OF A SOURCE LINE
* VBIN5 = POINTER START OF STATEMENT
* VBIN6 = OP-CODE
* VBIN7 = WORK
* VBIN8 = LENGTH OF STATEMENT
* OBJSTR = INTERMEDIATE BUFFER OBJECT OF ONE LINE
*
EJECT
* OUTPUT: LBIN20 = LENGTH OF OPTIONAL PART ADJUSTED
* BPOOL = BUFFER POOL STORED WITH VALIDATION OBJECT
* GBIN4 = BUFFER POOL IDEX ADJUSTED IF POOL OVERFLOW
* GBIN5 = BUFFER POOL POINTER ADJUSTED
* SLBIN8 = LINE NUMBER OF DISASTER ERROR
* SLBIN9 = VALBUF-POINTER WHEN DISASTER ERROR FOUND
* CR = 0 OK
* = 1 NOT OK
* = 2 DISASTER ERROR SYNTAX ERROR FOUND
*
************************************************************************
EJECT
OBJVAL PROC
*
* SAVE START ADRESS WHERE OPTIONAL VALIDATION STARTS
* - BUFFER POOL INDEX
* - BUFFER POOL POINTER
*
MOVE LSTR6A,=X'FF' E-O-P-DELIMITER
CLEAR LBOOL4 FALSE NO SPLIT AT POOL CHANGE
CLEAR VBOOL8 F NO COMPULSARY DELIMITER
MOVE VBIN1,W2 NUMBER OF CHARACTERS TO STORE
PERF POLICE,VBIN1,LBOOL4,VBOOL8,LSTR81 ***POOL LIMIT CONTROLER
BG OBJ980 JMP IF MEMORY OVERFLOW
SET LBOOL4 SPLITT AT POOL CHANGE ALLOWED
SET VBOOL8 T COMPULSORY DELIMITER
MOVE VBIN1,GBIN5 STORE POOL-POINTER
XCOPY VBIN1,W0,W1,GBIN4,W1 STORE BUFFER POOL-INDEX
CBNE LBIN1,W0,OBJ010 JJMP IF NOT POOL-LIMIT
ADD GBIN4,W1 NEXT POOL-UNIT
CMP GBIN4,DPBIN CHECK MAX NUMB OF POOL-UNITS
BG OBJ980 JMP IF OVERFLOW
MOVE GBIN5,W4
OBJ010
ADD GBIN5,W2 ADJUST FOR OPT-TYP & LENGTH
*
* MOVE VALIDATION OBJECT IF NO MODIFIED FIELDS/FIELD-TYPE/FIELD-ID
*
TBT CMBOOL,OBJ020 JMP IF FIELD MODIFIED
TBT CHABOL,OBJ020 JMP IF VAL.ROUTINE MODIFIED
CBE VALPTR,W0,OBJ020 JMP IF NO VALIDATION-ROUTINE
PERF MOVVAL ***MOVE VALIDATION OBJECT
BG OBJ980 POOL OVERFLOW
B OBJ990 NORMAL EXIT
OBJ020
CALL EMPTYT,VALBUF ---CHECK IF EMPTY
BOK OBJ030 JMP IF NOT EMPTY
XCOPY GBIN4,W1,W1,VBIN1,W0 STORE BUFFER POOL-INDEX
XCOPY GBIN5,W1,W1,VBIN1,W1 STORE BUFFER POOL-POINTER
B OBJ998
OBJ030
MOVE VBIN2,W2 LENGTH OF VALIDATION:=2
MOVE LBIN4,W0 VALIDATION BUFFER POINTER:=0
EJECT
*
* BASIC LINE INITIALISATION
*
OBJ050
MOVE VBIN4,W0 SOURCE LINE END LIMIT:=0
CBNL LBIN4,VBBIN,OBJ060 JMP IF VALBUF-MAX REACHED
XCOPY VBIN4,W1,W1,VALBUF,LBIN4 GET LENGTH OF SOURCE LINE
OBJ060
CMP VBIN4,W0 CHECK IF END OF VALBUF
BE OBJ990 JMP IF WHOLE VALIDATION DONE
ADD VBIN4,LBIN4 CALC-END-OF-LINE LIMIT
CALL ICLEAR,OBJSTR ---CLEAR ITEM
MOVE VBIN3,W1 INT.MED.BUFFERPOINTER:=1
MOVE SLBIN9,LBIN4 SAVE ST.POINTER OF SOURCE
ADD LBIN4,W1 ADJUST VALBUF POINTER
XCOPY LBIN1,W0,W2,VALBUF,LBIN4 GET LINE NUMBER
MOVE SLBIN8,LBIN1 SAVE LINE NUMBER
ADD LBIN4,W2 ADJUST VALBUF POINTER
*
* CHECK IF INDENTION(LEADING SPACES
*
PERF INDCNT ***INDENTION COUNTING
CALL WXSLL,VBIN7,W11,VBIN7 SHIFT LEFT BIT 0-4
ADD VBIN7,LBIN1 INDENTIONS + LINE NUMBER
*
* STORE INDENTIONS BIT 0-4 + LINE NUMBER 5-15
*
XCOPY OBJSTR,VBIN3,W2,VBIN7,W0 STORE IND+LINE NUMBER
ADD VBIN3,W2 ADJUST INT MED BUFFER POINTER
EJECT
*
* BASIC STATEMENT INITIALIZATION
*
OBJ110
MOVE VBIN5,VBIN3 SAVE START OF STATEMENTPOS
MOVE VBIN8,W2 LENGTH OF STATEMENT:=2
ADD VBIN3,W2 ADJUST INT.MED.BUFFER POINTER
*
* CHECK BASIC VERB
*
CALL GETIND,STMTS,SLBIN6,LBIN3 ---GET ITEM LENGTH
PERF BSVOPC,W2,VBIN6 ***BASIC VERB OP-CODE LENGTH=2
BOK OBJ120 BASIC VERB FOUND
PERF BSVOPC,W3,VBIN6 ***BASIC VERB OP-CODE LENGTH=3
BOK OBJ120 BASIC VERB FOUND
PERF BSVOPC,W4,VBIN6 ***BASIC VERB OP-CODE LENGTH=4
BOK OBJ120 BASIC VERB FOUND
PERF BSVOPC,W5,VBIN6 ***BASIC VERB OP-CODE LENGTH=5
BOK OBJ120 BASIC VERB FOUND
*
* SEPARATOR ; EMPTY STATEMENT ?
*
SUB SLBIN6,W1 ADJUST POINTER
MATCH STMTS,SLBIN6,W1,VALBUF,LBIN4,W1
BNOK OBJ115 JMP IF NOT ;-STATEMENT
XCOPY VBIN6,W1,W1,STVAL,SLBIN6 LOAD OP-CODE ;
ADD LBIN4,W1 ADJUST VALBUF POINTER
B OBJ120
OBJ115
MOVE VBIN6,W0 ALPHANUM.LET WITHOUT L
PERF VARDET ***VARIABLE/!INP/!FID
BNOK OBJ950 JMP IF DISASTER/ERROR
B OBJ152 LET WITHOUT LET
*
* BRANCH ON OPERATION CODE
*
OBJ120
CBE VBIN6,W0,OBJ150 0=ASSIGNMENT
IB VBIN6,OBJ150, 1=ASSIGNMENT LET C
OBJ150, 2=ASSIGNMNET C
OBJ150, 3=ASSIGNMNET LET C
OBJ200, 4=GO TO C
OBJ200, 5=GOTO C
OBJ250, 6=IF ..THEN ..<LINE> C
OBJ980, 7=NOT VALID C
OBJ250, 8=IF ..THEN ..<STMT> C
OBJ980, 9=NOT VALID C
OBJ350, 10=ON .. GO TO.. C
OBJ350, 11=ON .. GOTO.. C
OBJ400, 12=CALL C
OBJ980, 13=NOT VALID C
OBJ450, 14=SECT C
OBJ980, 15=NOT VALID C
OBJ500, 16=ATTR C
OBJ980, 17=NOT VALID C
OBJ550, 18=STOP C
OBJ980, 19=NOT VALID C
OBJ600, 20=EXIT C
OBJ980, 21=NOT VALID C
OBJ650, 22=ERR C
OBJ980, 23=NOT VALID C
OBJ650, 24=WARN C
OBJ980, 25=NOT VALID C
OBJ750, 26=REM C
OBJ980, 27=NOT VALID C
OBJ800 28=;
EJECT
*
* 0,1,2,3 LET <VARIABLE> = <ARITHMETIC EXPRESSION>/<STRING EXPRESSION
*
OBJ150
PERF INDCNT ***INDENTION COUNTING
*
* TARGET VARIABLE
*
PERF VARDET ***VARIABLE DETERMINATION
BNOK OBJ950 JMP IF DISASTER-ERROR
OBJ152
PERF INDCNT ***INDENTION COUNTING
*
* ASSIGNMENT OPERATOR '='
*
OBJ155
ADD LBIN4,W1 ADJUST INPUT BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
PERF CLRLST ***CLEAR STACK
TBF VBOOL2,OBJ160 JMP IF ARITHMETIC EXPR.
*
* STRING EXPRESSION EXPECTED
*
PERF STREXP ***STRING EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
B OBJ890 END OF STATEMENT
*
* ARITHMETIC EXPRESSION EXPECTED
*
OBJ160
PERF ARTEXP ***ARITHMETIC EXPR. EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
ADD VBIN6,W2 OPERATION-CODE:=03
B OBJ890 END OF STATEMENT
EJECT
*
* 4,5 GO TO/GOTO <LINE-NUMBER>
*
OBJ200
PERF INDCNT ***INDENTION COUNTING
*
* LABEL LINE NUMBER EXPECTED
*
PERF LABLIN,W4 ***LABEL LINE NUMBER
B OBJ890 END OF STATEMENT
EJECT
*
* 6 IF <RELATIONAL EXPRESSION> THEN <LINE>/<STATEMENT>
*
OBJ250
PERF INDCNT ***INDENTION COUNTING
*
* ARITHMETIC EXPRESSION EXPECTED
*
PERF CLRLST ***CLEAR STACK
PERF ARTEXP ***ARITHMETIC EXPR. EVALUATION
BOK OBJ260 JMP OK
*
* ...OR STRING EXPRESSION EXPECTED
*
PERF CLRLST ***CLEAR STACK
PERF STREXP ***STRING EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
EJECT
*
* RELATIONAL OPERATOR
*
OBJ260
PERF INDCNT ***INDENTION COUNTING
MOVE LBIN3,W0 POINTER:=0
MATCH OPRTS,LBIN3,W3,VALBUF,LBIN4,W1
MOVE VBIN7,LBIN3 SAVE FOUND POINTER
CBE VBIN7,W0,OBJ270 JMP IF EQUAL SIGN =
MOVE LBIN3,W3 POINTER:=3
MATCH OPRTS,LBIN3,W6,VALBUF,LBIN4,W2 MATCH FOLLOWING OPERAND
BNOK OBJ270 NO FOLLOWING OPERAND
MOVE VBIN7,LBIN3 SAVE FOUND POINTER
ADD LBIN4,W1 ADJUST BUFFER POINTER
OBJ270
MOVE SLBIN4,W0 RELATIONAL OPERATOR CODE:=0
XCOPY SLBIN4,W1,W1,OPRVAL,VBIN7 LOAD REL.OP-CODE
ADD LBIN4,W1 ADJUST INPUT BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
PERF CLRLST ***CLEAR STACK
TBT VBOOL2,OBJ290 JMP IF STRING EXPRESSION
ADD SLBIN4,W6 ADJUST REL.OP-CODE NUMERIC
EJECT
*
* ARITHMETIC EXPRESSION EXPECTED
*
PERF ARTEXP ***ARITHMETIC EXPR. EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
B OBJ300
*
* STRING EXPRESSION EXPECTED
*
OBJ290
PERF STREXP ***STRING EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
OBJ300
*
* STORE RELATIONAL OPERATOR CODE
*
XCOPY OBJSTR,VBIN3,W1,SLBIN4,W1 STORE REL.OP-CODE
ADD VBIN3,W1 ADJUST INT.MED.BUFFER POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
PERF INDCNT ***INDENTION COUNTING
*
* 'THEN'
*
ADD LBIN4,W4 ADJUST VALBUF POINTER
PERF INDCNT ***INDENTION COUNTING
*
* LABEL LINE NUMBER EXPECTED
*
PERF LABLIN,W4 ***LABEL LINE NUMBER
BOK OBJ890 END OF STATEMENT
EJECT
*
* STATEMENT EXPECTED
*
OBJ310
ADD VBIN6,W2 ADJUST OP-CODE:=08
PERF STTYLN ***STATEMENT TYPE + LENGTH
PERF INDCNT ***INDENTION COUNTING
B OBJ110
EJECT
*
* 10 ON <ARITHMETIC EXPRESSION> GO TO/GOTO <LINE-NUMBER-LIST>
*
OBJ350
PERF INDCNT ***INDENTION COUNTING
*
* ARITHMETIC EXPRESSION EXPECTED
*
PERF CLRLST ***CLEAR STACK
PERF ARTEXP ***ARITHMETIC EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
PERF INDCNT ***INDENTION COUNTING
*
* STORE END-OF-EXPRESSION '01'
*
XCOPY OBJSTR,VBIN3,W1,W1,W1 STORE END-OF-EXPR.
ADD VBIN3,W1 ADJUST INT.MED.BUFFER POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
*
* MATCH FOR GO TO/GOTO
*
CALL GETIND,STMTS,SLBIN6,LBIN3 ---GET ITEM LENGTH
PERF BSVOPC,W5,LBIN1 ***BASIC VERB SEARCH LENGTH=5
BOK OBJ360 BASIC VERB FOUND
PERF BSVOPC,W4,LBIN1 ***BASIC VERB SEARCH LENGTH=4
ADD VBIN6,W1 OP-CODE:=0B
EJECT
*
* LABEL LINE NUMBER EXPECTED
*
OBJ360
PERF INDCNT ***INDENTION COUNTING
PERF LABLIN,W4 ***LABEL LINE NUMBER
CMP LBIN4,VBIN4 CHECK END-OF-SOURCE-LINE LIMIT
BE OBJ890 END-OF-SOURCE LINE
PERF INDCNT ***INDENTION COUNTING
*
* MATCH FOR LABEL LIST SEPARATOR
*
MOVE LSTR1,=C',' SEPARATOR=,
MOVE LBIN3,W0 POINTER:=0
MATCH LSTR1,LBIN3,W1,VALBUF,LBIN4,W1 MATCH ','
BNOK OBJ890 END OF STATEMENT
ADD LBIN4,W1 ADJUST VALBUF POINTER
B OBJ360 NEXT LABEL LINE NUMBER
EJECT
*
* 12 CALL UF<DIGIT> !<PARAMETERLIST>!
*
OBJ400
PERF INDCNT ***INDENTION COUNTING
*
* USER FUNCTION IDENT 'UF'
*
ADD LBIN4,W2 ADJUST BUFFER POINTER
*
* FUNCTION NUMBER
*
PERF LABLIN,W2 ***LABEL LINE NUMBER
CMP LBIN4,VBIN4 CHECK END-OF-SOURCE-LINE LIMIT
BE OBJ890 END OF SOURCE LINE FOUND
*
* PARAMETER-LIST
*
PERF INDCNT ***INDENTION COUNTING
*
* BEGIN OF PARAMETER LIST '('
*
MOVE LSTR1,=C'(' LOAD LEFT PARENTHESIS
MOVE LBIN3,W0 POINTER:=0
MATCH LSTR1,LBIN3,W1,VALBUF,LBIN4,W1 MATCH '('
BNOK OBJ890 JMP END OF STATEMENT
EJECT
OBJ410
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
*
* STRING EXPRESSION EXPECTED
*
PERF CLRLST ***CLEAR STACK
PERF STREXP ***STRING EXPR EVALUATION
BOK OBJ420 EXPR OK
*
* ... OR ARITHMETIC EXPRESSION
*
PERF CLRLST ***CLEAR STACK
PERF ARTEXP ***ARITHMETIC EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
OBJ420
PERF INDCNT ***INDENTION COUNTING
*
* PARAMETER EXPRESSION SEPARATOR ','
*
MOVE LSTR1,=C',' LOAD PAR-SEPARATOR
MOVE LBIN3,W0 POINT0
MATCH LSTR1,LBIN3,W1,VALBUF,LBIN4,W1 MATCH ','
BOK OBJ410 JMP IF OK
*
* END OF PARAMETER LIST ')'
*
ADD LBIN4,W1 ADJUST BUFFER POINTER
B OBJ890 JMP END OF STATEMENT
EJECT
*
* 14 SECT <STRING EXPRESSION>
*
OBJ450
PERF INDCNT ***INDENTION COUNTING
*
* STRING EXPRESSION EXPECTED
*
PERF CLRLST ***CLEAR STACK
PERF STREXP ***STRING EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
B OBJ890 END OF STATEMENT
EJECT
*
* 16 ATTR <ATTRIBUTE> <DYNAMIC FIELD>
*
OBJ500
PERF INDCNT ***INDENTION COUNTING
*
* ATTRIBUTE => DECORATION OR PROTECTION
*
MOVE LBIN12,=W'26'
PERF DECOPC,LBIN12 ***DECORATION OPERATION CODE
XCOPY OBJSTR,VBIN3,W1,LBIN1,W1 STORE NUMERIC CONSTANT
ADD VBIN3,W1 ADJUST INT.MED.BUFFER POINTER
ADD VBIN8,W1 ADJUST STATEMNET LENGTH
PERF INDCNT ***INDENTION COUNTING
*
* SEPARATOR ','
*
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
*
* DYNAMIC FIELD
*
PERF VARDET ****VARIABLE DETERMINATION
BNOK OBJ950 JMP IF DISASTER-ERROR
B OBJ890 END OF STATEMENT
EJECT
*
* 18 STOP !<DYNAMIC FIELD>!
*
OBJ550
CMP LBIN4,VBIN4 CHECK END-OF-SOURCE LINE LIMIT
BE OBJ890 END-OF-SOURCE LINE
PERF INDCNT ***INDENTION COUNTING
*
* STOP WITH TARGET DYNAMIC FIELD
*
PERF VARDET ****VARIABLE DETERMINATION
BNOK OBJ950 JMP IF DISASTER-ERROR
B OBJ890 END OF STATEMENT
EJECT
*
* 20 EXIT <ARITHMETIC EXPRESSION>
*
OBJ600
PERF INDCNT ***INDENTION COUNTING
*
* ARITHMETIC EXPRESSION EXPECTED
*
PERF CLRLST ***CLEAR STACK
PERF ARTEXP ***ARITHMETIC EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
B OBJ890 END OF STATEMENT
EJECT
*
* 22 ERR <DECORATION LIST> <STRING-EXPRESSION>
* 24 WARN <DECORATION LIST> <STRING-EXPRESSION>
*
OBJ650
PERF INDCNT ***INDENTION COUNTING
MMOVE LBIN12,SLBIN5,W0 NUMB OF DECORS:=0
DECOR BIT PATTERN:=0
*
* DECORATION LIST
*
OBJ660
CMP LBIN12,W5 CHECK IF ALREADY 5 DECORS
BE OBJ675 INCOMPLETE STATEMENT
PERF DECOPC,W10 ***DECORATION OPERATION CODE
BNOK OBJ675 JMP IF NOT OK
ADD SLBIN5,LBIN1 ADD FOUND DECOR CODE
PERF INDCNT ***INDENTION COUNTING
ADD LBIN12,W1 INCREMENT NUMB OF DECORATIONS
EJECT
*
* DECORATION LIST SEPARATOR ','
*
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
B OBJ660 NEXT DECORATION
*
* STRING EXPRESSION EXPECTED
*
OBJ675
XCOPY OBJSTR,VBIN3,W1,SLBIN5,W1 STORE DECOR BIT PATTERN
ADD VBIN3,W1 ADJUST INT.MED.BUFFER POINTER
ADD VBIN8,W1 ADJUST STATEMNET LENGTH
PERF CLRLST ***CLEAR STACK
PERF STREXP ***STRING EXPR EVALUATION
BNOK OBJ950 JMP IF DISASTER-ERROR
B OBJ890 END OF STATEMENT
EJECT
*
* 26 REM !<ALPHNUMERIC CHARACTERS>!
*
OBJ750
CMP LBIN4,VBIN4 CHECK END-OF-SOURCE LINE LIMIT
BE OBJ890 END-OF-SOURCE LINE
PERF INDCNT ***INDENTION COUNTING
MOVE LBIN1,VBIN4 STORE END OF SOURCE LIMIT
SUB LBIN1,LBIN4 CALC NUMB OF REMARK CHARACTERS
XCOPY OBJSTR,VBIN3,LBIN1,VALBUF,LBIN4 GET REMARKTEXT
ADD LBIN4,LBIN1 ADJUST VALBUF POINTER
ADD VBIN3,LBIN1 ADJUST INT.MED.BUFFER-POINTER
ADD VBIN8,LBIN1 ADJUST LENGTH OF STATEMENT
B OBJ890
EJECT
*
* 28 ; (BASIC STATEMENT SEPARATOR)
*
OBJ800
CMP LBIN4,VBIN4 CHECK IF E-O-B
BE OBJ890 OBJECT IF LAST IN LINE
SUB VBIN3,W2 ADJUST INT.MED.BUFFERPOINTER
B OBJ895 NO OBJECT IF SEPARATOR
*
* END OF STATEMENT
*
OBJ890
PERF STTYLN ***STATEMENT TYPE + LENGTH
CMP LBIN4,VBIN4 CHECK END-OF-SOURCE LINE
BE OBJ900 END-OF-SOURCE LINE
OBJ895
PERF INDCNT ***INDENTION COUNTING
B OBJ110 NEXT BASIC STATEMENT
EJECT
*
* END OF VALIDATION LINE
*
OBJ900
MOVE LSTR6A,=X'FF' E-O-P-DELIMITER
XCOPY OBJSTR,W0,W1,VBIN3,W1 STORE LENGTH OF LINE
ADD VBIN2,VBIN3 ADJUST LENGTH OF OBJ LINE
CMP VBIN2,=X'0FFF' CHECK MAX SIZE OF VALID.
BG OBJ980 JMP IF GREATER MAXSIZE
MOVE VBIN4,W0 SOURCE LINE END LIMIT:=0
CBNL LBIN4,VBBIN,OBJ910 JMP IF VALBUF-MAX REACHED
XCOPY VBIN4,W1,W1,VALBUF,LBIN4 GET LENGTH OF SOURCE LINE
OBJ910
CBNE VBIN4,W0,OBJ920 CHECK IF END OF VALBUF
CLEAR VBOOL8 FALSE NO E-O-P NEEDED IF EXACT
OBJ920
PERF POLICE,VBIN3,LBOOL4,VBOOL8,OBJSTR ***POOL-LIMIT CONTROLER
BG OBJ980 JMP IF MEMORY OVERFLOW
XCOPY BPOOL(GBIN4),GBIN5,VBIN3,OBJSTR,W0 STORE VAL.OBJECT LINE
ADD GBIN5,VBIN3 ADJUST BUFFER POINTER
B OBJ050 NEXT LINE
EJECT
*
* DISASTER-ERRORS ; -FIELD-ID DELETED OR CHANGED
* -FIELD-TYPE (NUM OR ALPHANUM) CHANGED
* *** WITHOUT SYNTAX CONTROL ***
*
OBJ950
CMP W0,W1 CR:=2
B OBJ999 EXIT
EJECT
*
* MEMORY OVERFLOW
*
OBJ980
CMP W1,W0 CR:=1
B OBJ999
*
* EXIT OK STORE OPTIONAL TYPE $ LENGTH
*
OBJ990
MOVE LBIN3,W0 WORKITEM:=0
XCOPY LBIN3,W1,W1,VBIN1,W0 RELOAD BUFFER POOL-INDEX
XCOPY VBIN1,W0,W1,W0,W0 OVERWRITE POOL-INDEX
MOVE LBIN2,W1 RELOAD OPTIONAL ATTRIBUTE CODE
MOVE LBIN1,LBIN2 STORE OPTIONAL TYPE
CALL WXSLL,LBIN1,W12,LBIN1 SHIFT LEFT BIT 0-3
ADD LBIN1,VBIN2 ADD LENGTH OF VALIDATION
XCOPY BPOOL(LBIN3),VBIN1,W2,LBIN1,W0 STORE TYPE & LENGTH
ADD LBIN20,VBIN2 ADJUST OPTIONAL PART LENGTH
CMP LBIN20,=X'0FFF' CHECK MAXSIZE OPTIONALS
BG OBJ980 JMP IF GREATER
OBJ998
CMP W1,W1 CR:=0
OBJ999
RET
PEND
EJECT
*
* BASIC VERB OPERATION CODE
*
* INPUT : STLEN =(FORMAL) BASIC VERB LENGTH
* LBIN12 = FILLER CHARACTER /FF
* SLBIN6 = LENGTH OF STMTS
*
* USED : VBIN7 = WORKITEM
* LBIN3 = WORKITEM
*
* OUTPUT: LBIN4 = INPUT BUFFER POINTER ADJUSTED
* OPCODE = CORRESPONDING OBJECT-CODE (BASIC VERB)
* CR = 0 = OK
* = 1 = NOT OK
*
************************************************************************
BSVOPC PROC STLEN,OPCODE
PBIN STLEN
PBIN OPCODE
MOVE OPCODE,W0 BASIC-VERB OBJECT:=0
MOVE LBIN3,W0 POINTER:=0
MOVE LSTR1,=X'FF' LOAD FILLER
MATCH STMTS,LBIN3,SLBIN6,VALBUF,LBIN4,STLEN BASICVERBMATCH
BNOK BSV999 JMP IF NOT FOUND
XCOPY OPCODE,W1,W1,STVAL,LBIN3 LOAD OBJECT CODE
CBE OPCODE,=X'00FF',BSV980 JMP IF FILLER
EJECT
*
* CHECK IF PROPER LENGTH
*
MOVE VBIN7,LBIN3 STORE POINTER VALUE
ADD VBIN7,STLEN ADD POINTER STATMENT LENGTH
MATCH STVAL,VBIN7,W1,LSTR1,W0,W1 MATCH IF FILLER
BOK BSV980 JMP IF FILLER /FF FOUND NOT OK
BSV100
ADD LBIN4,STLEN ADJUST POINTER WITH LENGTH
CMP W1,W1 CR:=0
B BSV999
BSV980
CMP W1,W0 CR:=1
BSV999
RET
PEND
EJECT
*
* INDENTION COUNTING
*
* INPUT : VALBUF = INPUT BUFFER
* LBIN4 = VALIDATION BUFFER POINTER
*
* OUTPUT: LBIN4 = ADJUSTED
* VBIN7 = NUMBER OF INDENTIONS
*
************************************************************************
INDCNT PROC
MOVE LSTR1,=X'20' LOAD SPACE CHARACTER
MOVE VBIN7,W0 NUMB OF LEADING SPACES:=0
IND100
MOVE LBIN3,W0 MATCH-POINTER:=0
MATCH LSTR1,LBIN3,W1,VALBUF,LBIN4,W1 MATCH FOR SPACE
BNOK IND999 JMP IF NO MORE SPACES
ADD VBIN7,W1 INCREMENT NO OF SPACES
ADD LBIN4,W1 ADJUST BUFFER-POINTER
B IND100 GO ON
IND999
RET
PEND
EJECT
*
* STATEMENT TYPE & LENGTH
*
************************************************************************
STTYLN PROC
XCOPY OBJSTR,VBIN5,W1,VBIN6,W1 STORE OP-CODE
ADD VBIN5,W1 ADJUST POINTER
XCOPY OBJSTR,VBIN5,W1,VBIN8,W1 STORE STATEMENT-LENGTH
RET
PEND
EJECT
*
* VARIABLE DETERMINATION
*
* INPUT : VALBUF = BASIC LINE
* LBIN4 = BASIC LINE POINTER
* FIDTAB = FIELD ID TABLE
* ATTAB = ATTRIBUTE TABLE
* GVDUR = SCREEN ROW BUFFER
*
* USED : LBIN3
* VBIN7
* LBIN12
* LBIN1
* SLBIN5
*
* OUTPUT : VBOOL2 = FALSE NUMERIC => ARITHMETIC VARIABLE
* = TRUE ALPHANUM => STRING VARIABLE
* VBOOL3 = FALSE !INP- OR !FID-ITEM VARIABLE
* = TRUE WSM-WORK-ITEM DYNAMIC FIELD VARIABLE
* CR = 0 OK
* = 1 OBJECT ERROR
*
************************************************************************
VARDET PROC
CLEAR VBOOL2 FALSE = ARITHMETIC VARIABLE
CLEAR VBOOL3 FALSE = WSM WORK ITEM VARIABLE
MOVE SLBIN5,W4 VARIABLE LENGTH:=4
EJECT
*
* CURRENT FIELD '!FID' OR CURRENT INPUT '!INP'
*
MOVE LSTR9A,=C'!INP!FID' LOAD IDENTIFIERS
MOVE LBIN3,W0 POINTER :=0
MATCH LSTR9A,LBIN3,W8,VALBUF,LBIN4,W4 MATCH '!FID' & '!INP'
BNOK VAR100 JMP IF NOT CURRENT FID/INP
CBE LBIN3,W0,VAR010 JMP IF '!INP' = 0000
SUB LBIN3,W3 CALC '!FID' = 0001
VAR010
XCOPY OBJSTR,VBIN3,W2,LBIN3,W0 STORE OP-CODE CURRENT FID/INP
SUB SLBIN5,W2 VARIABLE LENGTH :=2
ADD LBIN4,W2 ADJUST BUFFER POINTER
TBT LBOOL5,VAR105 JMP IF STRING
B VAR300
*
* WSM WORK ITEM INVESTIGATION
*
VAR100
MOVE LBIN3,W0 WORKITEM
MOVE LSTR6A,=C'WSWAWN' WSM-WORKITEN PREFIX
MATCH LSTR6A,LBIN3,W6,VALBUF,LBIN4,W2 SEARC WSMITEM PREFIX
BNOK VAR190 JMP IF NOT A WSM-ITEM
*
* WSM WORK-ITEM FOUND OK
*
SET VBOOL3 TRUE=WSM WORK ITEM
XCOPY OBJSTR,VBIN3,SLBIN5,VALBUF,LBIN4 LOAD WSM WORKITEM NAME
CBE LBIN3,W4,VAR110 NUM WSM-ITEM
VAR105
B VAR250 ALPHANUMERIC = STRING
VAR110
B VAR300 NUMERIC = ARITHMETIC
*
* DYNAMIC FIELD INVESTIGATION
*
VAR190
MOVE LSTR6A,=X'422A580020' B*X=ALPHANUMERIC CHARS
MOVE LSTR16,=X'2B2D2A2F28293A263D3C3E2C3B2000' +-*/():&=<>,;B/00
MMOVE VBIN7,LBIN12,LBIN4 LOAD ACTUAL BUF. POPINTER
ADD VBIN7,W4 ADJUST TO GET MATCH-LIMIT
VAL192
MOVE LBIN3,W0 MATCHPOINTER:=0
MATCH LSTR16,LBIN3,W15,VALBUF,LBIN12,W1
BOK VAL194 DELIMITER-CHAR. FOUND
ADD LBIN12,W1 ADJUST TEMP BUFFER POINTER
CBE LBIN12,VBIN4,VAL194 JMP IF E-O-SOURCE
CBE LBIN12,VBIN7,VAL194 4 POSITIONS MATCHED. JMP
B VAL192 GO ON MATCH DELIMITER
VAL194
SUB LBIN12,LBIN4 CALC EFF. FID-LENGTH ?
BE VAR980 IF = 0 => NO VARIABEL
MOVE LBIN3,W0 WORKITEM:=0
VAR200
CMP LBIN3,LABIN CHECK IF END ATTAB
BE VAR980 OBJECT ERROR
XCOPY VBIN7,W0,W2,ATTAB,LBIN3 FETCH ROW & COL
CBE VBIN7,W0,VAR980 JMP IF E-O-BUFFER
ADD LBIN3,W2 ADJUST ATAB-POINTER
XCOPY VBIN7,W0,W1,W0,W0 DELETE ROW NO
CBG VBIN7,LBIN9,VAR206 JMP IF OVFL-ENTRY
XCOPY VBIN7,W1,W1,ATTAB,LBIN3 GET SEQ.NO
CBNE VBIN7,=X'00FF',VAR208 JMP IF DYNAMIC FIELD
VAR206
ADD LBIN3,W2 ADJUST ATTAB -POINTER
B VAR200 GO ON
EJECT
*
* DYNAMIC FIELD SEQ.NO FOUND
*
VAR208
CALL WXMUL,VBIN7,W5,VBIN7
SUB VBIN7,W5 CALC FIELD-ID POSITION
MOVE LBIN1,VBIN7 LOAD FIDTAB-POINTER
MATCH FIDTAB,LBIN1,W4,LSTR16,W13,W1 MATCH 1ST SPACE
SUB LBIN1,VBIN7 CALC FIDTAB-FID LENGTH
CBNE LBIN12,LBIN1,VAR206 JMP IF NOT SAME LENGTH
MATCH FIDTAB,VBIN7,LBIN12,VALBUF,LBIN4,LBIN12 MATCH FIELD NAME
BNOK VAR206 NOT THIS FIELD ID
MOVE SLBIN5,LBIN12 SAVE FOUND FID-LENGTH
EJECT
*
* RIGHT FIELD ID FOUND
*
SET VBOOL3 TRUE = DYNAMIC FIELD VARIABLE
XCOPY OBJSTR,VBIN3,W4,FIDTAB,VBIN7 LOAD DYN FIELD ID
MOVE LBIN1,W4 MAXLENGTH OF VARIABLE-NAME
SUB LBIN1,SLBIN5 CALC NUMBER TO CORRECT OB-LENGTHS
ADD VBIN3,LBIN1 ADJUST INT.MED.BUFFER-POINTER
ADD VBIN8,LBIN1 ADJUST STATEMENT LENGTH
SUB LBIN3,W2 ADJUST ATTAB-POINTER
MOVE VBIN7,W0 CLEAR FIRST
XCOPY VBIN7,W1,W1,ATTAB,LBIN3 GET ROW NO
ADD LBIN3,W1 ADJUST ATTAB-POINTER
MOVE LBIN1,W0 WORKITEM:=0
XCOPY LBIN1,W1,W1,ATTAB,LBIN3 GET COL NO
SUB LBIN1,W1 ADJUST COL.NO TO POINTER
ADD LBIN3,W3 ADJUST ATTAB-POINTER
CMP LBIN3,LABIN CHECK END OF ATTAB
BE VAR210 JMP IF E-O-B FOUND
MOVE LBIN12,W0 WORKITEM:=0
XCOPY LBIN12,W1,W1,ATTAB,LBIN3 GET NEXT ROW NO
CBNE LBIN12,VBIN7,VAR210 JMP IF NOT SAME ROW NO
ADD LBIN3,W1 ADJUST ATTAB-POINTER
XCOPY LBIN12,W1,W1,ATTAB,LBIN3 GET NEXT COL NO
SUB LBIN12,W1 ADUST ENDPOSITION
B VAR215
EJECT
*
* SEARCH FOR 1ST /00
*
VAR210
MOVE LBIN3,LBIN9 LOAD MAX COL POSITION
SUB LBIN3,LBIN1 CALC PICTURESTRING LENGTH
MOVE LBIN12,LBIN1 LOAD START POSITION
MATCH GVDUR(VBIN7),LBIN12,LBIN3,LSTR6A,W3,W1 MATCH 1ST 00
BOK VAR215 ENDPOS FOUND
MOVE LBIN12,LBIN9 ENDPOS=MAX ENDCOLPOS
VAR215
SUB LBIN12,LBIN1 CALC PICTURE LENGTH
MOVE LBIN3,W0 POINTER:=0
MATCH LSTR6A,LBIN3,W3,GVDUR(VBIN7),LBIN1,W1 MATCH 1ST CHAR
BNOK VAR300 NO ALPHANUM CHAR
*
* ALPHANUMERIC CHARACTER FOUND
*
XCOPY LSTR1,W0,W1,LSTR6A,LBIN3 LOAD FOUND SIGN
MOVE GST80I(W7),LSTR1 FILL WITH FOUND CHAR
MOVE LBIN3,W0 POINTER:=0
MATCH GST80I(W7),LBIN3,LBIN12,GVDUR(VBIN7),LBIN1,LBIN12
BNOK VAR300 ALL CHARACTERS NOT ALPHA
EJECT
*
* ALL CHARACTERS ARE ALPHANUMERIC => STRING VARIABLE
*
VAR250
SET VBOOL2 TRUE=ALPHANUMERIC =>STRING
*
* NUMERIC DYNAMIC FIELD => ARITHMETIC VARIABLE
*
VAR300
B VAR990 OK
*
* OBJECT ERROR
*
VAR980
CMP W1,W0 CR:=1
B VAR999
*
* OK EXIT
*
VAR990
ADD LBIN4,SLBIN5 ADJUST VALBUF POINTER
ADD VBIN3,SLBIN5 ADJUST INT.MED.BUFFER-POINTER
ADD VBIN8,SLBIN5 ADJUST LENGTH OF STATEMENT
CMP W1,W1 CR:=0
VAR999
RET
PEND
EJECT
*
* STRING EXPRESSION EVALUATION
*
* OUTPUT: CR = 0 OK
* = 1 NOT OK
*
************************************************************************
STREXP PROC
MOVE LBIN3,=W'62' POINTER:=62
XCOPY LSTACK(LBIN2),W1,W1,OPRVAL,LBIN3 LOAD EXPR SEP )
ADD LBIN2,W1 INCREMENT STACK INDEX
*
* STRING CONSTANT
*
STR000
MOVE VBIN7,W0 NUMB OF EXPR-CHA0
MOVE LSTR1,=X'22' LOAD STRING QUOTE "
MATCH LSTR1,VBIN7,W1,VALBUF,LBIN4,W1 MATCH "
BNOK STR100 JMP IF NOTSTRING QUOTE
MOVE VBIN7,LBIN4 LOAD BUFFER POINTER
ADD VBIN7,W1 ADJUST FOR "
MOVE LBIN1,VBIN4 LOAD END OF SOURCE-LINE
SUB LBIN1,VBIN7 CALC MATCH LENGTH
MATCH VALBUF,VBIN7,LBIN1,LSTR1,W0,W1 MATCH NEXT "
SUB VBIN7,W1 ADJUST NUMB FOR 1ST "
SUB VBIN7,LBIN4 CALC NUMB OF CHARS
ADD LBIN4,W1 ADJUSTVALBUF POINTER 1ST "
PERF CONSTO ***CONSTANT STORAGE
B STR400 OK
EJECT
*
* STRING VARIABLE
*
STR100
PERF VARDET ***VARIABLE DETERMINATION
BNOK STR300 JMP IF NOT OK
TBT VBOOL2,STR200 JMP IF STRING VARIABLE
TBT VBOOL3,STR110 JMP IF DYN FIELD/WSM-W-I
SUB LBIN4,W4 ADJUST POINTER IF WRONG TYPE
SUB VBIN3,SLBIN5 ADJUST INT MED BUFFER POINTER
SUB VBIN8,SLBIN5 ADJUST STATEMENT LENGTH
B STR120
STR110
SUB LBIN4,SLBIN5 ADJUST POINTER IF WRONG TYPE
SUB VBIN3,W4 ADJUST INT MED BUFFER POINTER
SUB VBIN8,W4 ADJUST STATEMENT LENGTH
STR120
B STR980 NOT OK
*
* QUALIFIED STRING VARIABLE =====> SUBSTRING
*
STR200
CMP LBIN4,VBIN4 CHECK E-O-L
BE STR990 JMP IF E-O-L
PERF INDCNT ***INDENTION COUNTING
CMP LBIN4,VBIN4 CHECK E-O-L
BE STR990 JMP IF E-O-L
EJECT
*
* BEGIN OF SUBSTRING '('
*
MOVE LSTR1,=C'(' LOAD LEFT PARENTHESIS
MOVE LBIN3,W0
MATCH LSTR1,LBIN3,W1,VALBUF,LBIN4,W1 MATCH '('
BNOK STR400 NO SUBSTRING
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
*
* ARITHMETIC EXPRESSION EXPECTED
*
PERF ARTEXP ***ARITHMETIC EXPR EVALUATION
BNOK STR980 JMP IF DISASTER ERROR
PERF INDCNT ***INDENTION COUNTING
*
* SUBSTRING OPERATOR ':'
*
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
*
* ARITHMETIC EXPRESSION EXPECTED
*
PERF ARTEXP ***ARITHMETIC EXPR. EVALUATION
BNOK STR980 JMP IF DISASTER ERROR
PERF INDCNT ***INDENTION COUNTING
*
* END OF SUBSTRING ')' STORE SUBSTRING OPERATOR
*
XCOPY OBJSTR,VBIN3,W1,OPRVAL,W19 LOAD SUBSTRING OP-CODE
ADD VBIN3,W1 ADJUST INT.MED. BUFFER-POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
ADD LBIN4,W1 ADJUST BUFFER POINTER
B STR400
EJECT
*
* STRING FUNCTION
*
STR300
MOVE LBIN3,W20 POINTER:=20
MATCH OPRTS,LBIN3,W3,VALBUF,LBIN4,W3 MATCH FUNCTION
BNOK STR980 NO FUNCTION GO SCONSTANT
ADD LBIN4,W3 ADJUST BUFFER POINTER
XCOPY LSTACK(LBIN2),W1,W1,OPRVAL,LBIN3 STACK FUNC-CODE
ADD LBIN2,W1 INCREMENT STACK-INDEX
PERF INDCNT ***INDENTION COUNTING
EJECT
*
* BEGIN OF PARAMETER LIST '('
*
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
*
* ARITMETIC EXPRESSION EXPECTED
*
PERF ARTEXP ***ARITHMETIC EXPR EVALUATION
BNOK STR980 JMP IF DISASTER ERROR
PERF INDCNT ***INDENTION COUNTING
*
* END OF PARAMETER LIST ')' STORE FUNCTION OPERATION-CODE
*
SUB LBIN2,W1 DECREASE STACK-INDEX
XCOPY OBJSTR,VBIN3,W1,LSTACK(LBIN2),W1 STORE OP-CODE
ADD VBIN3,W1 ADJUST INT.MED BUFFER-POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
MOVE LSTACK(LBIN2),W0 CLEAR STACK-ENTRY
ADD LBIN4,W1 ADJUST BUFFER POINTER
*
* CONCATENATED STRING EXPRESSION
*
STR400
CMP LBIN4,VBIN4 CHECK E-O-LINE
BE STR990 E0L
PERF INDCNT ***INDENTION COUNTING
CMP LBIN4,VBIN4 CHECK E-O-LINE
BE STR990 E0L
MOVE LBIN3,W18 POINTER:=18
MATCH OPRTS,LBIN3,W1,VALBUF,LBIN4,W1 MATCH &
BNOK STR990 NO CONCATENATED STR
PERF OPSTCK,W14 ***OPERATOR-STACK HANDLING
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
B STR000 GO ON
EJECT
*
* OBJECT ERROR
*
STR980
CMP W1,W0 CR:=1
B STR999
*
* EXIT OK
*
STR990
SUB LBIN2,W1 DECREASE STACK INDEX
CBE LSTACK(LBIN2),=X'0022',STR995 JMP IF E-O-E
XCOPY OBJSTR,VBIN3,W1,LSTACK(LBIN2),W1 STORE OPERATOR
ADD VBIN3,W1 ADJUST INT.MED. BUFFER-POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
MOVE LSTACK(LBIN2),W0 CLEAR STACK ENTRY
B STR990
STR995
MOVE LSTACK(LBIN2),W0 CLEAR STACK ENTRY
SET VBOOL2 TRUE =STRING EXPRESSION
CMP W1,W1 CR:=0 OK
STR999
RET
PEND
EJECT
*
* ARITHMETC EXPRESSION EVALUATION
*
* OUTPUT: CR = 0 OK
* = 1 NOT OK
*
************************************************************************
ARTEXP PROC
MOVE LBIN3,=W'62' POINTER:=62
XCOPY LSTACK(LBIN2),W1,W1,OPRVAL,LBIN3 LOAD EXPR SEP )
ADD LBIN2,W1 INCREMENT STACK INDEX
*
* SIGNED FACTOR
*
ART000
MOVE LBIN3,W23 POINTER:=23
MATCH OPRTS,LBIN3,W2,VALBUF,LBIN4,W1 MATCH '+-'
BNOK ART050 JMP IF NO SIGN
PERF OPSTCK,W20 ***OPERATOR STACK-HANDLER
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
EJECT
*
* ARITHMETIC CONSTNAT
*
ART050
MOVE VBIN7,W0 NUMB OF CHARACTERS:=0
CLEAR VBOOL4 FALSE NO DECIMAL
MOVE LBIN3,LBIN4 LOAD BUFFER POINTER
ART060
XCOPY LSTR1,W0,W1,VALBUF,LBIN3 GET ONE CHARACTER
CBL LSTR1,=X'30',ART070 JMP IF NOT DIGIT BUT . OR ,
CBG LSTR1,=X'39',ART080 JMP IF NOT DIGIT
ART065
ADD VBIN7,W1 ADJUST NUMB OF CHARACTERS
ADD LBIN3,W1 ADJUST BUFFER POINTER
CMP LBIN3,VBIN4 CHECK END-OF-SOURCE LINE LIMIT
BE ART080 OK EXIT
B ART060 GO ON
*
* DECIMAL CHARACTER FOUND ?
*
ART070
CBNE LSTR1,=C'.',ART080 JMP IF NOT A DECIMAL CHAR
SET VBOOL4 TRUE DECIMAL FOUND
BOK ART065 OK 1ST DEC CHAR
*
* END OF DIGITS
*
ART080
CBE VBIN7,W0,ART100 NO DIGITS
PERF CONSTO ***CONSTANT STORAGE
SUB LBIN4,W1 ADJUST VALBUF POINTER
B ART500
EJECT
*
* ARITHMETIC VARIABLE
*
ART100
PERF VARDET ***VARIABLE DETERMINATION
BNOK ART200 JMP IF OBJECT ERROR
TBF VBOOL2,ART500 JMP IF ARITHMETIC VARIABLE
TBT VBOOL3,ART110 JMP IF DYN FIELD/WSM-W-I
SUB LBIN4,W4 ADJUST POINTER IF WRONG TYPE
SUB VBIN3,SLBIN5 ADJUST INT MED BUFFER POINTER
SUB VBIN8,SLBIN5 ADJUST STATEMENT LENGTH
B ART120
ART110
SUB LBIN4,SLBIN5 ADJUST POINTER IF WRONG TYPE
SUB VBIN3,W4 ADJUST INT MED BUFFER POINTER
SUB VBIN8,W4 ADJUST STATEMENT LENGTH
ART120
B ART980 NOT OK
EJECT
*
* ARITHMETIC FUNCTION
*
ART200
CALL GETIND,OPRTS,VBIN7,LBIN3 ---GET ITEM LENGTH
MOVE LBIN3,=W'29' POINTER:=29
SUB VBIN7,LBIN3 CALC LENGTH TO MATCH
MATCH OPRTS,LBIN3,VBIN7,VALBUF,LBIN4,W3 MATCH FUNCTION
BNOK ART300 NO FUNCTION
XCOPY LSTACK(LBIN2),W1,W1,OPRVAL,LBIN3 LOAD FUNC OP-CODE
ADD LBIN2,W1 INCREMENT STACK INDEX
ADD LBIN4,W3 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
*
* BEGIN OF PARAMETER LIST '('
*
ADD LBIN4,W1 ADJUST BUFFER POINTER
EJECT
*
* ARITHMETIC OR STRING EXPRESSION EXPECTED
*
PERF INDCNT ***INDENTION COUNTING
MOVE SLBIN5,LBIN2 LOAD CURRENT STACK INDEX
SUB SLBIN5,W1 CALC PREVIOUS STACK INDEX
CBE LSTACK(SLBIN5),=X'001D',ART210 JMP IF STRING-FUNC
CBE LSTACK(SLBIN5),=X'001E',ART210 JMP IF STRING-FUNC
CBE LSTACK(SLBIN5),=X'0021',ART210 JMP IF STRING-FUNC
PERF ARTEXP ***ARITHMETIC EXPRESSION
BNOK ART980 JMP IF DISASTER ERROR
B ART220
ART210
PERF STREXP ***STRING EXPR. EVALUATION
BNOK ART980 JMP IF DISASTER ERROR
ART220
PERF INDCNT ***INDENTION COUNTING
MOVE SLBIN5,LBIN2 LOAD CURRENT STACK-INDEX
SUB SLBIN5,W1 CALC PREVIOUS STACK-INDEX
CBG LSTACK(SLBIN5),=X'001E',ART230 JMP IF MORE THAN 1 PAR
B ART260 NO MORE PARAMETERS
EJECT
*
* PARAMETER LIST SEPARATOR ','
*
ART230
ADD LBIN4,W1 ADJUST BUFFER POINTER
*
* 2ND PARAMETER STRING OR ARITHMETIC EXPRESSION EXPECTED
*
CBE LSTACK(SLBIN5),=X'0021',ART240 JMP IF STRING-FUNC
PERF ARTEXP ***ARITHMETIC EXPR EVALUATION
BNOK ART980 JMP IF DISASTER ERROR
B ART250
ART240
PERF STREXP ***STRING EXPR
BNOK ART980 JMP IF DISASTER ERROR
ART250
PERF INDCNT ***INDENTION COUNTING
*
* END OF PARAMETER LIST ')' STORE FUNCTION OPERATION CODE
*
ART260
SUB LBIN2,W1 DECREASE STACK-INDEX
XCOPY OBJSTR,VBIN3,W1,LSTACK(LBIN2),W1 STORE OP-CODE
ADD VBIN3,W1 ADJUST INT.MED BUFFER-POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
MOVE LSTACK(LBIN2),W0 CLEAR STACK-ENTRY
ADD LBIN4,W1 ADJUST BUFFER POINTER
B ART500
EJECT
*
* PRIORED EXPRESSION ( <ARITHMETIC EXPRESSION>)
* BEGIN OF PRIORED EXPRESSION '('
*
ART300
MOVE LSTR1,=C'(' LOAD LEFT PARENTHESIS
MOVE LBIN3,W0 POINTER:
MATCH LSTR1,LBIN3,W1,VALBUF,LBIN4,W1 MATCH '('
BNOK ART500 NO PRIORED EXPRESSION
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
*
* ARITHMETIC EXPRESSION EXPECTED
*
PERF ARTEXP ***ARITHMETIC EXPR. EVALUATION
BNOK ART980 JMP IF DISASTER ERROR
PERF INDCNT ***INDENTION COUNTING
*
* END OF PRIORED EXPRESSION
*
MOVE LBIN3,=W'62' POINTER:=62
XCOPY OBJSTR,VBIN3,W1,OPRVAL,LBIN3 STACK )-CODE
ADD VBIN3,W1 ADJUST INT MED. BUFFER-POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
ADD LBIN4,W1 ADJUST BUFFER POINTER
EJECT
*
* COMBINED FACTOR MULTIPLY OPERATOR
*
ART500
CMP LBIN4,VBIN4 CHECK E-O-L
BE ART655 JMP IF E-O-L
PERF INDCNT ***INDENTION COUNTING
CMP LBIN4,VBIN4 CHECK E-O-L
BE ART655 JMP IF E-O-L
MOVE LBIN3,=W'27' POINTER:=27
MATCH OPRTS,LBIN3,W2,VALBUF,LBIN4,W1 MATCH '/*'
BNOK ART600 NO MULTIPLY OPERATOR
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF OPSTCK,W20 ***OPERATOR STACK-HANDLER
PERF INDCNT ***INDENTION COUNTING
B ART050 GO ON
*
* COMBINED EXPRESSION ADDING OPERATOR
*
ART600
MOVE LBIN3,=W'25' POINTER:=25
MATCH OPRTS,LBIN3,W2,VALBUF,LBIN4,W1 MATCH '+-'
BNOK ART650 NO SIGN OPERATOR
PERF OPSTCK,W20 ***OPERATOR STACK-HANDLER
ADD LBIN4,W1 ADJUST BUFFER POINTER
PERF INDCNT ***INDENTION COUNTING
B ART050 GO ON
EJECT
*
* END OF EXPRESSION
*
ART650
SUB LBIN4,VBIN7 ADJUST BUFFER POINTER
ART655
SUB LBIN2,W1 DECREASE STACK INDEX
CBE LSTACK(LBIN2),=X'0022',ART660 JMP IF E-O-E
XCOPY OBJSTR,VBIN3,W1,LSTACK(LBIN2),W1
ADD VBIN3,W1
ADD VBIN8,W1
MOVE LSTACK(LBIN2),W0 CLEAR STACK ENTRY
B ART655
ART660
MOVE LSTACK(LBIN2),W0 CLEAR STACK ENTRY
B ART990
*
* OBJECT ERROR
*
ART980
CMP W1,W0 CR:=1
B ART999
*
* OK EXIT
*
ART990
CLEAR VBOOL2 FALSE = ARITHMETIC EXPR
CMP W1,W1 CR:=0
ART999
RET
PEND
EJECT
*
* CONSTANT STORAGE
*
* INPUT : VALBUF = VALIDATION BUFFER
* LBIN4 = POINTER OF VALIDATION BUFFER
* VBIN7 = LENGTH OF CONSTANT
* VBIN3 = POINTER OF INTER MEDIATE BUFFER BASIC LINE
* VBIN8 = LENGTH OF STATEMENT
*
* USED : LBIN1 = WORK
*
* OUTPUT : OBJSTR = INTERMEDIATE BUFFER HOLDING ONE LINE
* VBIN3 = UPDATED
* , VBIN8 = UPDATED
* LBIN4 = UPDATED
*
************************************************************************
CONSTO PROC
MOVE LBIN1,VBIN7 LOAD LENGTH OF CONSTANT
ADD LBIN1,W1 COUNT INDICATOR ITSELF
CALL SETB,LBIN1,W8 ---SET BIT NO:=8
XCOPY OBJSTR,VBIN3,W1,LBIN1,W1 STORE CONSTANT INDICATOR
ADD VBIN3,W1 ADJUST INT.MED.BUFFER POINTER
XCOPY OBJSTR,VBIN3,VBIN7,VALBUF,LBIN4 STORE STRING CONSTANT
ADD VBIN3,VBIN7 ADJUST INT.MED.BUFFER POINTER
ADD VBIN7,W1 ADJUST FOR CONSTANT INDICATOR
ADD VBIN8,VBIN7 ADJUST STATEMNET LENGTH
ADD LBIN4,VBIN7 ADJUST VALBUF POINTER
RET
PEND
EJECT
*
* LABEL LINE NUMBER
*
* INPUT : VALBUF = BASIC LINE
* LBIN4 = BASIC LINE POINTER
* VBIN4 = END-OF-SOURCE LIMIT
* LENGTH = (FORMAL) MAX LENGTH OF NUMBER TO BE CONTROLL
*
* USED : LSTR1
*
* OUTPUT : CR = 0 OK
* = 1 NOT OK
* VBIN7 = NUMBER OF EXPRESSION CHARACTER
*
************************************************************************
LABLIN PROC LENGTH
PBIN LENGTH
CALL ICLEAR,LSTR4A ---CLEAR ITEM
MOVE LBIN3,LBIN4 LOAD CURRENT BUFFER POSITION
MOVE VBIN7,W0 NUMB OF LINE-NUMB CHARS:
LAB100
XCOPY LSTR1,W0,W1,VALBUF,LBIN3 GET ONE CHARACTER
CBL LSTR1,=X'30',LAB150 JMP IF NOT A DIGIT
CBG LSTR1,=X'39',LAB150 JMP IF NOT A DIGIT
XCOPY LSTR4A,VBIN7,W1,LSTR1,W0 STORE DIGIT
ADD VBIN7,W1 ADJUST LINE NUMBER LENGTH
ADD LBIN3,W1 ADJUST POINTER
CBE LBIN3,VBIN4,LAB150 JMP IF END-OF-SOURCE LINE
CBNE VBIN7,LENGTH,LAB100 JMP IF NOT MAXLENGTH
EJECT
LAB150
CALL EMPTYT,LSTR4A ---CHECK IF EMPTY
BNOK LAB980 JMP IF NO LINE NUMBER
MOVE LINNO(W9),LSTR4A CONVERT TO BCD
MOVE LBIN3,LINNO(W9) CONVERT TO BINARY
*
* LINE NUMBER FOUND OK
*
ADD LBIN4,VBIN7 ADJUST VALBUF POINTER
MOVE LBIN1,LENGTH STORE LENGTH
CALL WXDIV,LBIN1,W2,LBIN1 DIVIDE TO GET CONSTANT LENGTH
MOVE VBIN7,W2 STORE MAX-LENGTH
SUB VBIN7,LBIN1 CALC POINTER
XCOPY OBJSTR,VBIN3,LBIN1,LBIN3,VBIN7 STORE NUMERIC CONSTANT
ADD VBIN3,LBIN1 ADJUST INT.MED.BUFFER POINTER
ADD VBIN8,LBIN1 ADJUST STATEMNET LENGTH
CMP W1,W1 CR:=0
B LAB999 EXIT
*
* OBJECT ERROR
*
LAB980
CMP W1,W0 CR:=1
LAB999
RET
PEND
EJECT
*
* DECORATION OPERATION CODE
*
* INPUT : VALBUF = BASIC LINE
* LBIN4 = BASIC LINE POINTER
* DSTLEN = (FORMAL) DECOR-STRING LENGTH
* DECOR = DECOR STRING
*
* USED : LBIN3
*
* OUTPUT: CR = 0 OK
* = 1 NOT OK
* LBIN1 = DECORATION CODE
*
************************************************************************
DECOPC PROC DSTLEN
PBIN DSTLEN
MOVE LBIN1,W0 DECORATION CODE:=0
*
* DECORATION DELIMITER
*
ADD LBIN4,W1 ADJUST BUFFER POINTER
EJECT
*
* DECORATION VERB
*
MOVE LBIN3,W0
MATCH DECOR,LBIN3,DSTLEN,VALBUF,LBIN4,W2 MATCH DECOR
BNOK DEC988 JMP IF NOT FOUND
XCOPY LBIN1,W1,W1,DECVAL,LBIN3 GET OP-CODE
CBE LBIN1,=X'00FF',DEC980 JMP IF FILLER
ADD LBIN4,W2 ADJUST BUFFER POINTER
*
* DECORATION DELIMITER "
*
MOVE LSTR1,=X'22' LOAD STRING QUOTE
MOVE LBIN3,W0
MATCH LSTR1,LBIN3,W1,VALBUF,LBIN4,W1 MATCH DECOR DELIMITOR
BNOK DEC980 JMP IF NOT FOUND
ADD LBIN4,W1 ADJUST BUFFER POINTER
*
* OK EXIT
*
CMP W1,W1 CR:=0 OK
B DEC999
*
* OBJECT ERROR
*
DEC980
SUB LBIN4,W2 ADJUST WHEN ERROR
DEC988
SUB LBIN4,W1 ADJUST WHEN ERROR
CMP W1,W0 CR:=1
DEC999
RET
PEND
EJECT
*
* CLEAR LSTACK
*
* INPUT : LSTACK = STACK-INFORMATION
*
* USED : LBIN2 = STACK-INDEX
*
* OUPUT : LBIN2 = STACK-INDEX = 1
*
************************************************************************
CLRLST PROC
CALL GETIND,LSTACK(W1),LBIN2,LBIN3 ---GET LENGTH & DIMENSION
MOVE LBIN2,W1 STACK-INDEX:=1
CLR010
CALL ICLEAR,LSTACK(LBIN2) ---CLEAR ITEM
ADD LBIN2,W1 INCREMENT STACK-INDEX
CMP LBIN2,LBIN3 WHOLE STACK CLEARED
BG CLR999
B CLR010 GO ON
CLR999
MOVE LBIN2,W1 STACK INDEX:=1
RET
PEND
EJECT
*
* OPERATOR STACK HANDLING
*
* INPUT : OPRVAL = OPERATOR-CODES
* LBIN3 = POINTER TO OPERATOR-CODE(OPRVAL)
*
* USED : SLBIN5
* VBIN7
*
* OUTPUT: OBJSTR = INTERMEDIATE BUFFER UPDATED WITH OPERATOR CODE(ES
* VBIN3 = POINTER TO INTERMEDIATE BUFFER
* VBIN8 = STATEMENT LENGTH
*
* LSTACK = STACKED OPERATOR CODES CLEARED IF ENTERD IN INTME
* LBIN2 = STACK POINTER DECREASED IF ENTRY CLEARED
*
************************************************************************
OPSTCK PROC HPRIOR
PBIN HPRIOR
XCOPY LSTACK(LBIN2),W1,W1,OPRVAL,LBIN3 LOAD OPERATOR-CODE
OPS000
MOVE SLBIN5,LBIN2 LOAD CURREEN STACK-INDEX
SUB SLBIN5,W1 CALC PREVIOUS STACK-INDEX
CBE LSTACK(SLBIN5),=X'0022',OPS900 JMP IF E-O-E
MOVE VBIN7,LSTACK(LBIN2) LOAD CURRENT OP-CODE
MOVE LBIN3,LSTACK(SLBIN5) LOAD PREVIOUS OP-CODE
*
* CHECK PRIORITY
*
CBG VBIN7,HPRIOR,OPS010 JMP IF HIGH PRIORITY
MOVE VBIN7,W2 PRIORITY:=2
B OPS020
OPS010
MOVE VBIN7,W3 PRIORITY:=3
OPS020
CBG LBIN3,HPRIOR,OPS030 JMP IF HIGH PRIORITY
MOVE LBIN3,W2 PRIORITY:=2
B OPS040
OPS030
MOVE LBIN3,W3 PRIORITY:=3
OPS040
CMP LBIN3,VBIN7 CHECK PRIORITY
BL OPS900 JMP IF LESS PRIORTY
*
* STORE PREVIOUS OPERATOR-CODE
*
XCOPY OBJSTR,VBIN3,W1,LSTACK(SLBIN5),W1 STOR OP-CODE
ADD VBIN3,W1 ADJUST BUFFER POINTER
ADD VBIN8,W1 ADJUST STATEMENT LENGTH
MOVE LSTACK(SLBIN5),LSTACK(LBIN2) POP-UP CURRENT OP-CODE
MOVE LSTACK(LBIN2),W0 CLEAR STACK ENTRY
SUB LBIN2,W1
B OPS000 GO ON NEXT
OPS900
ADD LBIN2,W1 INCREMENT STACK-INDEX
OPS999
RET
PEND
END