$title('===> N P E X (I N C L U D E M A K E R) <===') npex: DO; /************************************************************************/ /* */ /* 'Copyright 1981,1983 Intel Corporation'. All rights reserved. */ /* No part of this program or publication may be reproduced, */ /* transmitted, transcribed, stored in a retrievel system, or */ /* translated into any language or computer language, in any */ /* form or by any means, electronic, mechanical, magnetic, */ /* optical, chemical, manual or otherwise, without the prior */ /* written permission of Intel Corporation, 3065 Bowers */ /* Avenue, Santa Clara, California, 95051, Attn: Software */ /* License Administration. */ /* */ /************************************************************************/ $IF XVERSION DECLARE PROPRIETARY(*) BYTE DATA ('INTEL PROPRIETARY SOFTWARE'); DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA ('program_version_number=X108',0); $ELSE DECLARE COPYRIGHT (*) BYTE DATA ('COPYRIGHT 1981,1983 INTEL '); DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA ('program_version_number=V1.1',0); $ENDIF /**** * * PEX: * program to create declarations for external routines and variables. * has been extended to PLM86 in addition to accepting input for PLM80. * * The added characters are: * 'A' -- ADDRESS. * 'B' -- BYTE. * 'I' -- INTEGER. * 'W' -- WORD. * 'R' -- REAL. * '@' -- ADDRESS. * 'L' -- LABEL. * '"' -- "other types" * * The syntax for lines in the input file is as follows: * * line = plm-var (proc-decl | var-decl). * proc-decl = 'P'¶m-list&type. * var-decl = (type | '"' plm-var '"') [&'S'] [&'..'&plm-var]. * params = (list-12 | '(' &(type | list-12) ... ')'. * list-12 = '1' | '2'. * type = 'A' | 'B' | 'I' | 'W' | 'R' | '@' | 'L' | '"text"'. * * To use, invoke this program as * * :Fx:NPEX TO * * where * ::= , ... . * ::= { ISIS-II file name } . * ::= { ISIS-II file name } . * ****/ declare NIL literally '0'; declare BOOLEAN literally 'byte'; declare CR literally '0DH'; declare LF literally '0AH'; declare FOREVER literally 'while (1)'; declare ENDDO literally 'end'; declare CHAR literally 'byte'; declare TRUE literally '0FFH'; declare FALSE literally '000H'; declare SCANP address external; declare SCANBYTE BASED SCANP CHAR; declare SCANADDR BASED SCANP address; declare OBUFP address external; declare SCANENDED BOOLEAN external; BLNKCH:procedure BOOLEAN external;end; BUMPSCANP:procedure external;end; CONSOLEIN:procedure external;end; DDIGCH:procedure byte external;end; DECIN:procedure address external;end; ERRORMESSAGE:procedure(ZZ1) external;declare ZZ1 address;end; FILECH:procedure BOOLEAN external;end; FILL:procedure(ZZ1,ZZ2,ZZ3) external;declare ZZ1 address,ZZ2 address,ZZ3 byte;end; FMOVE:procedure(ZZ1,ZZ2,ZZ3) external;declare ZZ1 address,ZZ2 address,ZZ3 address;end; FORCUP:procedure CHAR external;end; FORCUPSTRING:procedure external;end; LENSTRNUL:procedure(ZZ1) byte external;declare ZZ1 address;end; LETRCH:procedure BOOLEAN external;end; LTNMCH: procedure byte external; end; OUTBLANK:procedure external;end; OUTCHAR:procedure(ZZ1) external;declare ZZ1 CHAR;end; OUTDEC:procedure(ZZ1) external;declare ZZ1 address;end; OUTPRINT:procedure(ZZ1) external;declare ZZ1 address;end; OUTSCANBYTE:procedure external;end; OUTWRITE:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 byte;end; PRINT:procedure(ZZ1) external;declare ZZ1 address;end; PRINTCR:procedure(ZZ1) external;declare ZZ1 address;end; PUTBLANK:procedure external;end; PUTCRLF:procedure external;end; SCANEXPECT:procedure(ZZ1) external;declare ZZ1 address;end; SCANMATCH:procedure(ZZ1) BOOLEAN external;declare ZZ1 address;end; SCANUNTIL:procedure(ZZ1) external;declare ZZ1 address;end; SCANWHILE:procedure(ZZ1) external;declare ZZ1 address;end; SCANWHILEBLANKS:procedure external;end; SETOB:procedure(ZZ1) external;declare ZZ1 address;end; SETSC:procedure(ZZ1) external;declare ZZ1 address;end; SETSCANENDED:procedure external;end; TERMCH:procedure BOOLEAN external;end; TOKNCH:procedure BOOLEAN external;end; declare STATUS byte external; declare REPORT BOOLEAN external; declare FATAL BOOLEAN external; declare ACTUAL address external; CLOSEI:procedure external;end; DEL:procedure(ZZ1) external;declare ZZ1 address;end; EX:procedure external;end; ISIS:procedure(ZZ1,ZZ2) external;declare ZZ1 byte,ZZ2 address;end; MEMCK:procedure address external;end; OPENI:procedure(ZZ1) external;declare ZZ1 address;end; OPENO:procedure(ZZ1) external;declare ZZ1 address;end; READI:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end; WRITEC:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end; WRITEO:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end; EXTRACTROOT: procedure(ZZ1) external; declare (ZZ1) address; end; FILEERRORMESSAGE:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end; MOVEFILENAME:procedure(ZZ1) external;declare ZZ1 address;end; NEWEXTENSION:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end; OPENSCAN:procedure(ZZ1) external;declare ZZ1 address;end; OUTFILENAME:procedure(ZZ1) external;declare ZZ1 address;end; READIWITHLIMIT:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end; $eject DECLARE available ADDRESS, /* address of memory available for symbols */ mem$top ADDRESS, /* last address usable */ thread$head ADDRESS, thread$end ADDRESS, file$name$buffer(15) CHAR; DECLARE SYMBOL$TABLE$ENTRY LITERALLY 'STRUCTURE(NEXT ADDRESS, MARK BYTE, THREAD ADDRESS, STR(1) CHAR)', SYMBOL$TABLE$SIZE LITERALLY '256', SYMBOL$TABLE$ENTRY$SIZE LITERALLY '5', SYMBOL$MAX LITERALLY '40', MARKED LITERALLY '0FFH', UNMARKED LITERALLY '0', symbol$length ADDRESS, hash$value ADDRESS, symbol$table(SYMBOL$TABLE$SIZE) ADDRESS, symbol$buffer(256) CHAR; DECLARE NULL$STRING CHAR DATA(0), EXTERNAL$STRING(*) CHAR DATA(' external',0), ADDRESS$VARIABLE$STRING(*) CHAR DATA(' address',0), BYTE$VARIABLE$STRING(*) CHAR DATA(' byte',0), POINTER$VARIABLE$STRING(*) CHAR DATA(' pointer',0), REAL$VARIABLE$STRING(*) CHAR DATA(' real',0), WORD$VARIABLE$STRING(*) CHAR DATA(' word',0), INTEGER$VARIABLE$STRING(*) CHAR DATA(' integer',0), LABEL$STRING(*) CHAR DATA(' label',0), DWORD$VARIABLE$STRING(*) CHAR DATA(' dword',0), SELECTOR$VARIABLE$STRING(*)CHAR DATA(' selector',0); DECLARE put$symbol$flag BOOLEAN, src$file(15) CHAR INITIAL (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0), src$root(15) CHAR INITIAL (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0), ipx$file(15) CHAR INITIAL (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0), px$file$list$p ADDRESS INITIAL(.io$buff), include$count ADDRESS INITIAL (0), include$begin ADDRESS, io$buff(1024) CHAR, io$buff$idx ADDRESS INITIAL(0); DECLARE chars$on$line BYTE, left$margin BYTE INITIAL(1); DECLARE spath LITERALLY '14', spath$buf(12) BYTE, spath$parm$blk(3) ADDRESS INITIAL(.src$file,.spath$buf,.status), numeric$extension BYTE; DECLARE state BYTE INITIAL(1), /* first line cmd line */ fsm(6) STRUCTURE(NEXT(6) BYTE) DATA( /* used to scan files */ /* ? lf $ / * A */ 0, 1, 0, 2, 0, 6, 1, 1, 7, 2, 0, 6, 0, 1, 0, 2, 3, 6, 3, 4, 3, 3, 5, 3, 3, 4, 8, 3, 5, 3, 3, 4, 3, 0, 5, 3); $eject /**** * * read$invocation$line: * reads the invocation line into .MEMORY, going past "&" and prompting * for further input with "**" if required * ****/ read$invocation$line: PROCEDURE; obufp = .memory; DO FOREVER; CALL console$in; DO WHILE (scan$byte <> '&'); IF (termch) THEN DO; CALL out$char(0); /* terminating null */ scanp = .memory; RETURN; END; CALL out$scan$byte; ENDDO; CALL print(.('**',0)); ENDDO; END read$invocation$line; $eject /**** * * read$px$file$list: * reads in the names of all the files containing definitions into * the array IO$BUFF. the list is terminated by a NULL. leaves * SCANP pointing to the character following the last filename * ****/ read$px$file$list: PROCEDURE; obufp = .io$buff; DO WHILE (obufp < .io$buff(last(io$buff))); CALL scan$while$blanks; DO WHILE (filech); CALL out$scan$byte; ENDDO; CALL out$blank; /* file names separated by BLANK */ CALL scan$while$blanks; IF (scan$byte = ',') THEN CALL bump$scanp; ELSE DO; CALL out$char(0); /* terminate list with empty filename */ RETURN; END; ENDDO; CALL error$message(.('too many files in ',0)); END read$px$file$list; $eject /**** * * read$ch: * bumps scanp. if scan$ended is set, reads more data into the buffer. * when an EOF occurs, scanp is set to point to a null string * ****/ read$ch: PROCEDURE; CALL bump$scan$p; IF (scan$ended) THEN DO; CALL readi(.io$buff, size(io$buff)-1); IF (actual = 0) THEN DO; scanp = .NULL$STRING; CALL set$scan$ended; RETURN; END; io$buff(actual) = 0; scanp = .io$buff; CALL set$scan$ended; END; END read$ch; /**** * * full$line: * assures that there is a TERMCH in the string pointed to by * scanp. moves data and reads more if required * ****/ full$line: PROCEDURE; DECLARE temp ADDRESS; temp = scanp; CALL scan$until(.termch); scanp = temp; IF (scan$ended) THEN DO; temp = .io$buff(last(io$buff)) - scanp; CALL fmove(temp, scanp, .io$buff); CALL readi(.io$buff(temp), size(io$buff) - temp - 1); io$buff(actual + temp) = 0; scanp = .io$buff; /* should check long line ... */ END; CALL set$scan$ended; END full$line; $eject /**** * * init$memory: * initializes available and mem$top * ****/ init$memory: PROCEDURE; DECLARE (m BASED mem$top) BYTE; thread$head = .memory; available = .memory; mem$top = memck; m = 0; mem$top = mem$top - 1; END init$memory; $eject /**** * * file$name$line: * returns TRUE and sets file$name$buffer to the file name if scanp points * to a string which specifies a file name. * ****/ file$name$line: PROCEDURE BOOLEAN; IF (scan$byte <> '$') THEN RETURN (FALSE); CALL bump$scan$p; CALL scan$while$blanks; IF (NOT scan$match(.('FILE',0))) THEN RETURN (FALSE); CALL scan$while$blanks; IF (scan$byte <> '(') THEN RETURN (FALSE); CALL fill(size(file$name$buffer), .file$name$buffer, 0); CALL bump$scan$p; IF numeric$extension THEN /* only save root */ DO; CALL scan$while$blanks; CALL extract$root(.file$name$buffer); CALL scan$while(.file$ch); CALL scan$while$blanks; END; ELSE DO; IF scan$byte = ':' THEN scanp = scanp + 4; CALL move$file$name(.file$name$buffer); END; IF (scan$byte <> ')') THEN RETURN (FALSE); CALL set$sc(.file$name$buffer); CALL forc$up$string; RETURN (TRUE); END file$name$line; $eject /**** * * pex$file$matches$file$name: * returns TRUE IF the file name passed in matches the file name in File- * NameBuffer. * ****/ pex$file$matches$file$name: PROCEDURE (px$name$ptr) BOOLEAN; DECLARE px$name$ptr ADDRESS; DECLARE px$name BASED px$name$ptr CHAR; IF (px$name = ':') THEN px$name$ptr= px$name$ptr + 4; CALL set$sc(.file$name$buffer); IF scan$match(px$name$ptr) THEN DO; scanp = px$name$ptr; RETURN (scan$match(.file$name$buffer)); END; RETURN false; END pex$file$matches$file$name; /**** * * check$gap: * errors out should space overflow. * ****/ check$gap: PROCEDURE; IF (available >= mem$top) THEN CALL error$message(.('dynamic storage overflow. too many PEX symbols',0)); END check$gap; $eject /**** * * point$scanp$to$next$line: * advances scanp to the first character after the current END of line. * ****/ point$scanp$to$next$line: PROCEDURE; CALL scan$until(.termch); CALL scan$while(.termch); END point$scanp$to$next$line; /**** * * find$include$file: * searches for the word INCLUDE, then copies the file name to * the area pointed to by obufp * ****/ find$include$file: PROCEDURE; CALL full$line; DO WHILE (NOT termch); CALL read$ch; IF (scan$match(.('INCLUDE',0))) OR (scan$match(.('IC',0))) THEN DO; CALL scan$until(.filech); CALL out$file$name(scanp); CALL out$char(0); CALL scan$until(.termch); include$count = include$count + 1; available = obufp; CALL check$gap; RETURN; END; IF (scan$match(.('LEFTMARGIN',0))) OR (scan$match(.('LM',0))) THEN DO; CALL scan$until(.ddigch); left$margin = LOW(decin); END; ENDDO; END find$include$file; $eject /**** * * S Y M B O L - T A B L E S E C T I O N * ****/ /**** * * init$symbol$table: * sets all the entries in the symbol table to NIL * ****/ init$symbol$table: PROCEDURE; DECLARE i ADDRESS; i = length(symbol$table); DO WHILE (i <> 0); i = i - 1; symbol$table(i) = NIL; ENDDO; END init$symbol$table; $eject /**** * * get$id: * copies the symbol currently being pointed to into symbol$buffer, converting * from lower to upper case and discarding '$'. A maximum of 32 characters * is allowed. scanp is left pointing to the character which halted the * scan. * ****/ get$id: PROCEDURE; symbol$length = 0; CALL set$ob(.symbol$buffer); DO WHILE (NOT scan$ended); IF (toknch) THEN DO; CALL out$char(forcup); symbol$length = symbol$length + 1; END; ELSE IF (scan$byte <> '$') THEN GOTO exit$loop; CALL bump$scanp; ENDDO; exit$loop:; IF (symbol$length > SYMBOL$MAX) THEN CALL error$message(.('symbol greater than 40 characters long',0)); CALL out$char(0); END get$id; $eject /**** * * hash: * sets hash$value to the hashed value of symbol$buffer; * ****/ hash: PROCEDURE; DECLARE i BYTE; i = 0; CALL set$sc(.symbol$buffer); CALL set$scan$ended; DO WHILE (NOT scan$ended); i = i + scan$byte; CALL bump$scan$p; ENDDO; hash$value = i; END hash; /**** * * lookup$id: * searches the symbol table for the entry with ID = symbol$buffer. * ****/ lookup$id: PROCEDURE ADDRESS; DECLARE ptr ADDRESS, p BASED ptr SYMBOL$TABLE$ENTRY; CALL hash; ptr = symbol$table(hash$value); CALL set$sc(0); DO WHILE (ptr <> NIL); scanp = .symbol$buffer; /* this is NOT string equality */ IF (scan$match(.p.STR(0))) THEN IF (scan$byte = 0) THEN RETURN (ptr); ptr = p.NEXT; ENDDO; RETURN (NIL); END lookup$id; $eject /**** * * insert$pex$symbol: * the string pointed to by scanp is inserted into the symbol table. * NOTE: the symbol tables grow towards mem$top from available. * ****/ insert$pex$symbol: PROCEDURE (mark$value); DECLARE mark$value BYTE; DECLARE pex$data$string$ptr ADDRESS, ste$p ADDRESS, ste$b BASED ste$p SYMBOL$TABLE$ENTRY, pex$data$string$length ADDRESS; CALL get$id; CALL scan$while$blanks; pex$data$string$ptr = scanp; CALL scan$until(.termch); pex$data$string$length = scanp - pex$data$string$ptr; ste$p = available; obufp = .ste$b.STR(0); CALL out$print(.symbol$buffer); CALL out$char(0); CALL out$write(pex$data$string$ptr, pex$data$string$length); CALL out$char(0); available = obufp; CALL check$gap; CALL hash; ste$b.NEXT = symbol$table(hash$value); ste$b.MARK = mark$value; ste$b.THREAD = available; symbol$table(hash$value) = ste$p; END insert$pex$symbol; $eject /**** * * mark$internal$references: * assures that symbols containing references to other symbols (BASEd var- * iables and literallys) are included in the declarations. * ****/ mark$internal$references: PROCEDURE (mark$value, str$p) REENTRANT; DECLARE mark$value BYTE, str$p ADDRESS; DECLARE save$scanp ADDRESS; save$scanp = scanp; scanp = str$p; DO WHILE (scan$byte <> 0); IF (scan$byte = '.') THEN CALL find$and$mark(mark$value); ELSE IF ((scan$byte = '"') OR (scan$byte = '''')) THEN /* only one level is allowed */ DO WHILE (scan$byte <> 0); CALL find$and$mark(mark$value); ENDDO; CALL bump$scan$p; ENDDO; scanp = save$scanp; END mark$internal$references; $eject /**** * * mark$id: * looks up the symbol in symbol$buffer. If found, sets MARK to the passed * in value. * ****/ mark$id: PROCEDURE (mark$value) REENTRANT; DECLARE mark$value BYTE; DECLARE ste$p ADDRESS, ste$b BASED ste$p SYMBOL$TABLE$ENTRY, save$scanp ADDRESS; save$scanp = scanp; ste$p = lookup$id; IF (ste$p <> NIL) THEN IF (ste$b.MARK <> mark$value) THEN DO; ste$b.MARK = mark$value; CALL mark$internal$references(mark$value, .ste$b.STR(1) + lenstrnul(.ste$b.STR)); ste$p = ste$b.NEXT; DO WHILE (ste$p <> NIL); scanp = .symbol$buffer; IF (scan$match(.ste$b.STR(0))) THEN IF (scan$byte = 0) THEN DO; ste$b.MARK = mark$value; CALL mark$internal$references(mark$value, .ste$b.STR(1) + lenstrnul(.ste$b.STR)); END; ste$p = ste$b.NEXT; ENDDO; END; scanp = save$scanp; END mark$id; /**** * * find$and$mark: * bump scanp to the next letter, get the symbol and set its mark field to * the passed in value. * ****/ find$and$mark: PROCEDURE (mark$value) REENTRANT; DECLARE mark$value BYTE; CALL scan$until(.toknch); CALL get$id; CALL mark$id(mark$value); END find$and$mark; $eject /**** * * flush$io$buff: * dumps io$buff to the output file * ****/ flush$io$buff: PROCEDURE; CALL writeo(.io$buff, io$buff$idx); io$buff$idx = 0; END flush$io$buff; /**** * * write$char: * writes the character to the output file * ****/ write$char: PROCEDURE (ch); DECLARE ch CHAR; io$buff(io$buff$idx) = ch; io$buff$idx = io$buff$idx + 1; IF (io$buff$idx > last(io$buff)) THEN CALL flush$io$buff; chars$on$line = chars$on$line + 1; END write$char; /**** * * write$string: * writes the null terminated string to the output file * ****/ write$string: PROCEDURE (s$p); DECLARE s$p ADDRESS; CALL setsc(s$p); DO WHILE (scan$byte <> 0); CALL write$char(scan$byte); CALL bump$scan$p; ENDDO; END write$string; $eject /**** * * write$number: * writes the decimal ADDRESS using write$char. * ****/ write$number: PROCEDURE (number); DECLARE number ADDRESS; DECLARE nbuff(6) CHAR; CALL fill(6, .nbuff, 0); CALL set$ob(.nbuff); CALL out$dec(number); CALL write$string(.nbuff); END write$number; $eject write$declare: PROCEDURE; CALL write$string(.('declare ',0)); END write$declare; write$semi: PROCEDURE; CALL write$char(';'); END write$semi; write$comma: PROCEDURE; CALL write$char(','); END write$comma; write$lp: PROCEDURE; CALL write$char('('); END write$lp; write$rp: PROCEDURE; CALL write$char(')'); END write$rp; write$crlf: PROCEDURE; CALL write$string(.(CR,LF,0)); chars$on$line = 0; END write$crlf; write$left$margin: PROCEDURE; DECLARE i BYTE; IF left$margin = 0 THEN RETURN; i = left$margin - 1; DO WHILE i > 0; CALL write$char(' '); i = i - 1; END; END; /**** * * write$lit: * writes the definition as a literally statement. * ****/ write$lit: PROCEDURE; CALL write$left$margin; CALL write$declare; CALL write$string(.symbol$buffer); CALL write$string(.(' literally ',0)); CALL write$string(scanp); CALL write$semi; CALL write$crlf; END write$lit; $eject /**** * * chr$idx: * returns an index of the character pointed to by scanp. * ****/ chr$idx: PROCEDURE (s$p) ADDRESS; DECLARE s$p ADDRESS; DECLARE i BYTE, s$b BASED s$p CHAR, ch CHAR; i = 1; ch = forcup; DO WHILE (s$b <> 0); IF (s$b = ch) THEN RETURN (i); s$p = s$p + 1; i = i + 1; ENDDO; RETURN (0); END chr$idx; $eject /**** * * quote$ch: * returns TRUE if the scan$byte is a '"' * ****/ quote$ch: PROCEDURE BOOLEAN; RETURN (scan$byte = '"'); END quote$ch; /**** * * err$msg$flush: * flushes the io$buff (to the IPX file) before reporting error and exit * ****/ err$msg$flush: PROCEDURE(ptr); DECLARE ptr ADDRESS; CALL flush$io$buff; CALL error$message(ptr); END; /**** * * copy$to$symbol$buffer: * copies into symbol$buffer from scanp until a '"' is seen. appends * a null onto the end * ****/ copy$to$symbol$buffer: PROCEDURE; CALL bump$scan$p; CALL setob(.symbol$buffer); CALL out$blank; CALL scan$while$blanks; DO WHILE (NOT quote$ch); IF (scan$ended) THEN CALL err$msg$flush(.('trailing ''"'' left off of declaration',0)); CALL out$scan$byte; END; CALL out$char(0); END copy$to$symbol$buffer; $eject /**** * * write$var: * writes a declaration for the variable with the given type. * ****/ write$var: PROCEDURE; DECLARE TYPE$TBL(*) CHAR DATA('ABIWDS@R"L',0), TYPE$PTR(*) ADDRESS DATA( .NULL$STRING, .ADDRESS$VARIABLE$STRING, .BYTE$VARIABLE$STRING, .INTEGER$VARIABLE$STRING, .WORD$VARIABLE$STRING, .dword$variable$string, .selector$variable$string, .POINTER$VARIABLE$STRING, .REAL$VARIABLE$STRING, .symbol$buffer, .LABEL$STRING), idx ADDRESS, (based$ptr, array$ptr, bvar$ptr) ADDRESS; CALL write$left$margin; CALL write$declare; CALL write$string(.symbol$buffer); CALL set$ob(.symbol$buffer); idx = chr$idx(.TYPE$TBL); IF (scan$byte = '"') THEN CALL copy$to$symbol$buffer; CALL bump$scan$p; $eject based$ptr, array$ptr, bvar$ptr= .NULL$STRING; DO WHILE (NOT scan$ended); CALL scan$while$blanks; IF (forcup = 'S') THEN DO; array$ptr = .('(1)',0); CALL bump$scan$p; END; ELSE IF (scan$addr = '..') THEN DO; based$ptr = .(' BASED ',0); scanp, bvar$ptr = scanp + 2; CALL scan$until(.blnkch); IF (NOT scan$ended) THEN DO; scan$byte = 0; scanp = scanp + 1; END; END; ELSE IF (NOT scan$ended) THEN DO; CALL print(scanp); CALL err$msg$flush(.('bad pex line',0)); END; ENDDO; CALL write$string(based$ptr); CALL write$string(bvar$ptr); CALL write$string(array$ptr); CALL write$string(TYPE$PTR(idx)); IF (bvar$ptr = .NULL$STRING) THEN CALL write$string(.EXTERNAL$STRING); CALL write$semi; CALL write$crlf; END write$var; $eject /**** * * pex$error: * prints an error message on the terminal and exits. * ****/ pex$error: PROCEDURE; CALL print$cr(.('bad PEX line',0)); CALL print(.symbol$buffer); CALL put$blank; CALL print$cr(scanp); CALL flush$io$buff; CALL ex; END pex$error; $eject /**** * * write$proc: * writes the declaration of a procedure. The format of a procedure declar- * ation is p[argument-list][type]. argument-list is either a string of * '1' or '2', or '(' type-characters ')'. type is type-character. * type-character is one of the characters '@RIWAB"'. * ****/ write$proc: PROCEDURE; DECLARE PARAM$TYPE$STRING(*) CHAR DATA('ABWDS@IR"21',0), PARAM$1$2$TYPE$STRING(2) CHAR AT(.PARAM$TYPE$STRING(9)), PARAM$TYPE$TBL(*) ADDRESS DATA( .NULL$STRING, .ADDRESS$VARIABLE$STRING, .BYTE$VARIABLE$STRING, .WORD$VARIABLE$STRING, .dword$variable$string, .selector$variable$string, .POINTER$VARIABLE$STRING, .INTEGER$VARIABLE$STRING, .REAL$VARIABLE$STRING, .symbol$buffer, .ADDRESS$VARIABLE$STRING, .BYTE$VARIABLE$STRING), ZZ$STRING(*) CHAR DATA('ZZ',0), saved$scanp ADDRESS, arg$end ADDRESS, (i, j, params) ADDRESS; check$line$len: PROCEDURE; IF chars$on$line > 71 THEN DO; CALL write$crlf; CALL write$left$margin; CALL write$string(.(' ',0)); END; END; write$args: PROCEDURE (p); DECLARE p ADDRESS; CALL write$lp; DO FOREVER; CALL write$string(.ZZ$STRING); params = params + 1; CALL write$number(params); IF (quote$ch) THEN DO; CALL bump$scan$p; CALL scan$until(.quote$ch); END; CALL bump$scan$p; IF (chr$idx(p) = 0) THEN DO; CALL write$rp; RETURN; END; CALL write$comma; CALL check$line$len; ENDDO; END write$args; $eject chars$on$line = 0; CALL bump$scan$p; CALL write$left$margin; CALL write$string(.symbol$buffer); CALL write$string(.(':procedure',0)); params = 0; CALL scan$while$blanks; IF (scan$byte = '(') THEN DO; CALL bump$scan$p; saved$scanp = scanp; CALL write$args(.PARAM$TYPE$STRING); arg$end = scanp; IF (scan$byte <> ')') THEN CALL err$msg$flush(.('Missing closing '')'' in procedure definition',0)); CALL bump$scan$p; END; ELSE IF ((scan$byte = '1') OR (scan$byte = '2')) THEN DO; saved$scanp = scanp; CALL write$args(.PARAM$1$2$TYPE$STRING); arg$end = scanp; END; $eject CALL set$scan$ended; CALL scan$while$blanks; IF (quote$ch) THEN CALL copy$to$symbol$buffer; CALL write$string(PARAM$TYPE$TBL(chr$idx(.PARAM$TYPE$STRING))); CALL write$string(.EXTERNAL$STRING); CALL write$semi; CALL check$line$len; IF (params <> 0) THEN DO; CALL write$declare; scanp = saved$scanp; j = 1; DO WHILE (scanp < arg$end); CALL write$string(.ZZ$STRING); CALL write$number(j); IF (scan$byte = '"') THEN CALL copy$to$symbol$buffer; CALL write$string(PARAM$TYPE$TBL(chr$idx(.PARAM$TYPE$STRING))); CALL bump$scan$p; j = j + 1; params = params - 1; IF (params <> 0) THEN DO; CALL write$comma; CALL check$line$len; END; ELSE CALL write$semi; ENDDO; END; CALL write$string(.('end;',CR,LF,0)); END write$proc; $eject /**** * * write$dcl: * The symbol being defined is placed into symbol$buffer. The first * non-blank character of the definition string (pointed to by * id$text$ptr) is used to determine whether a variable, procedure * or literal declaration is to be produced. * ****/ write$dcl: PROCEDURE (id$p, id$text$p); DECLARE (id$p, id$text$p) ADDRESS; DECLARE prc ADDRESS, PROC$TABLE(*) ADDRESS DATA( .pex$error, /* unknown character */ .write$proc, /* P */ .write$var, /* A */ .write$var, /* B */ .write$lit, /* ' */ .write$var, /* @ */ .write$var, /* R */ .write$var, /* W */ .WRITE$VAR, /* d */ .WRITE$VAR, /* s */ .write$var, /* i */ .write$var, /* " */ .write$var); /* L */ scanp = id$text$p; CALL set$scan$ended; obufp = .symbol$buffer; CALL out$print(id$p); CALL out$char(0); CALL scan$while$blanks; prc = PROC$TABLE(chr$idx(.('PAB''@RWDSI"L',0))); CALL prc; END write$dcl; $eject /**** * * dump$dcls: * writes the declarations for all those entries whose MARK field * is equal to MARK$VALUE * ****/ dump$dcls: PROCEDURE (mark$value); DECLARE mark$value BYTE; DECLARE s$p ADDRESS, sym$p ADDRESS, col BYTE, len BYTE, s$b BASED s$p SYMBOL$TABLE$ENTRY; s$p = thread$head; col = 0; CALL put$crlf; DO WHILE (s$p < thread$end); IF (s$b.MARK = mark$value) THEN DO; sym$p = .s$b.STR; len = lenstrnul(sym$p) + 1; col = col + len; IF (col > 78) THEN /* line end */ DO; col = len; CALL put$crlf; END; CALL print(sym$p); CALL put$blank; CALL write$dcl(sym$p, sym$p + len); END; s$p = s$b.THREAD; ENDDO; CALL flush$io$buff; END dump$dcls; $eject /**** * * class: * returns the class of scan$byte * ****/ class: PROCEDURE ADDRESS; IF (letrch) THEN RETURN (5); RETURN (chr$idx(.(LF,'$/*',0))); /* all others are class 0 */ END class; $eject /**** * * Main module: * initialize memory and symbol table. * read in command line and get filenames for SRC$FILE and PX$FILEs. * read in PX$FILEs, creating symbol table with all entries UNMARKed. * read in SRC$FILE * for each token until the END of the file, set its ste$b as MARKed. * delete all UNMARKed STEs. * transform the symbol table to preserve space. * open SRC$FILE.IPX * write the declarations. * exit. * ****/ FATAL, REPORT = TRUE; /* blab about errors */ CALL read$invocation$line; CALL read$px$file$list; CALL scan$while$blanks; CALL scan$expect(.('TO',0)); CALL scan$while$blanks; CALL forc$up$string; CALL extract$root(.src$root); CALL move$file$name(.src$file); CALL ISIS(spath,.spath$parm$blk); scanp = .spath$buf(7); /* first extension char */ CALL scan$while(.ddigch); numeric$extension = (scanp = .spath$buf(10)); $IF XVERSION CALL printcr(.(CR,LF,'ISIS-II GENPEX X108',CR,LF,0)); $ELSE CALL printcr(.(CR,LF,'ISIS-II GENPEX V1.1',CR,LF,0)); $ENDIF CALL init$memory; CALL init$symbol$table; $eject DO WHILE (lenstrnul(px$file$list$p) <> 0); scanp = px$file$list$p; /* get next file name in list */ report = FALSE; /* turn off error reporting */ CALL open$scan(.openi); /* open it, advancing SCANP */ report = TRUE; /* error report & bomb out if */ IF (status <> 0) THEN /* file couldn't be opened */ CALL file$error$message(.('could not open',0), px$file$list$p); CALL print(.('reading ',0)); /* display file name */ CALL writec(px$file$list$p, scanp - px$file$list$p); px$file$list$p = scanp + 1; /* and remember new position */ CALL put$crlf; /* read in the */ CALL readi$with$limit(available, mem$top - available + 1); CALL closei; CALL fmove(actual, available, (scanp := mem$top - actual + 1)); put$symbol$flag = TRUE; CALL set$scan$ended; DO WHILE (NOT scan$ended); IF (toknch) THEN DO; IF (put$symbol$flag) THEN CALL insert$pex$symbol(UNMARKED); END; ELSE IF (file$name$line) THEN DO; IF numeric$extension THEN /* only match root */ put$symbol$flag = NOT pex$file$matches$file$name(.src$root); ELSE put$symbol$flag = NOT pex$file$matches$file$name(.src$file); END; CALL point$scanp$to$next$line; ENDDO; ENDDO; thread$end = available; $eject /* * scan the source file for identifiers appearing in the symbol table * and mark the symbol table entries as being used. */ scanp = .src$file; /* create the .IPX file name */ CALL new$extension(.ipx$file, .('IPX',0)); REPORT, FATAL = FALSE; /* make no noise if it isn't there */ CALL del(.ipx$file); /* delete previous .IPX file */ REPORT, FATAL = TRUE; CALL print(.('- - - -',CR,LF,'source: ',0)); CALL printcr(.src$file); CALL openi(.src$file); include$begin, obufp = available; /* remember file names here */ scanp = .NULL$STRING; /* cause READ$CH to read in data */ DO FOREVER; CALL read$ch; IF (scan$ended) THEN DO; CALL closei; status = 0FFH; fatal,report = FALSE; DO /* open include files */ WHILE (status <> 0); IF (include$count = 0) THEN DO; fatal, report = TRUE; GOTO exit$loop; END; include$count = include$count - 1; scanp = include$begin; CALL print(.('source: ',0)); CALL print$cr(scanp); CALL open$scan(.openi); include$begin = scanp + 1; ENDDO; fatal, report = TRUE; scanp = .NULL$STRING; END; ELSE DO; state = fsm(state).NEXT(class); IF (state = 6) THEN DO; CALL full$line; CALL find$and$mark(MARKED); state = 0; END; ELSE IF (state > 6) THEN DO; CALL find$include$file; IF (state = 8) THEN state = 3; /* continue scanning comment */ ELSE state = 0; /* otherwise start again */ END; END; ENDDO; exit$loop:; $eject /* * write the declarations */ CALL openo(.ipx$file); CALL dump$dcls(MARKED); CALL put$crlf; CALL ex; END npex;