! CIF PARSER   Version 3.9   Oct 1982   J. Gordon Hughes
! Program to analyse a CIF description.

!%record %format POINTFM (%integer X, Y)

! Portability comments -
!$IF VMS 
!%include "edwin_dir:TXSTACK.INC"
!$IF APM
!%include "edwin:TXSTACK.INC"
!$IF EMAS
!%include "ECSC17.IMP77SPECS"
!%include "ECSLIB.EDWIN_TXS"
!$FINISH

! The user is expected to provide the following routines -
{%external} %routine %spec D W BOX (%integer L, W, %record (POINTFM) %name C,D)
{%external} %routine %spec D W CALL (%integer CELL, %real %array %name TX (0:8))
{%external} %routine %spec D W COMMENT (%string(255) COMMENT)
{%external} %routine %spec D W DEF  (%integer ID, INFO)
{%external} %routine %spec D W LAYER (%string (63) NAME)
{%external} %routine %spec D W POLYGON (%integer NP,
                                      %record (POINTFM) %array %name P(1:*))
{%external} %routine %spec D W USER CODE (%integer CODE, %string (255) LINE)
{%external} %routine %spec D W WIRE (%integer WIDTH, NP,
                                   %record (POINTFM) %array %name P(1:*))

! D W stands for 'deal with', no doubt you were wondering.

{%external} %routine ANALYSE CIF (%integer %name LINES, STATEMENTS, WERRORS, FERRORS, %integer MAX ELEMENTS)

%routine %spec SKIP SYM

%real R SCALE
%switch CS(32:96); ! Other command symbols are blanks and will have been skiped.
%integer NEST, NS, X, Y, L, W, ID, SFAULTS, COMMAND, INDEF, IGNORE, LVALID, NUM ELEMENTS, OLD LAYER
%record (POINTFM) P, D
%record (POINTFM) %array POINTS (1:MAX ELEMENTS)
%record (TRANSFM) TT, OT, NT, UNITY
%string (255) STR
%const %string (31) LAYER NOT VALID = "No layer is currently defined"
%const %integer TRUE = 1, FALSE = 0
%const %integer MAX VALID INT = 16_FFFFFF
%own %integer INIT = FALSE, NL in user code = false, NL in comment = false
%own %integer INCLUDE DEPTH = 0

%routine FAIL (%string(255) REASON, %integer MODE)
   %integer ST
   ST = OUT STREAM
   SELECT OUTPUT (0)
   PRINT SYMBOL (MODE)
   PRINT STRING (" Line")
   WRITE (LINES,4)
   SPACE
   SPACE
   PRINT STRING (REASON)
   NEWLINE
   SELECT OUTPUT (ST)
%end

%routine WARN (%string(255) REASON)
   FAIL (REASON,'?')
   W ERRORS = W ERRORS + 1
%end

%routine FAULT (%string(255) REASON)
   FAIL (REASON,'*')
   F ERRORS = F ERRORS + 1
   %if COMMAND#'E' %start
       SKIP SYM %until NEXT SYMBOL = ';'
       SKIP SYMBOL
   %finish
   IGNORE = TRUE
   %signal 14
%end

%routine SKIP SYM
   LINES = LINES + 1 %if NEXT SYMBOL = NL
   SKIP SYMBOL
%end

%integer %fn BLANK
   %integer NS
   NS = NEXT SYMBOL
   %result = FALSE %if 'A' <= NS <= 'Z' %or '0' <= NS <= '9'
   %result = FALSE %if NS = '-' %or NS = ';' %or NS = ')' %or NS = '('
   %result = TRUE
%end

%routine SKIP BLANKS
   SKIP SYM %while BLANK = TRUE
%end

%routine SKIP SEPS
   SKIP SYM %while 'A' <= NEXT SYMBOL <= 'Z' %or BLANK = TRUE
%end

%integer %fn GET INT (%integer %name D)
   %integer NS,SIGN
   SKIP SEPS
   NS = NEXT SYMBOL
   %result = FALSE %unless '0'<= NS <='9' %or NS = '-'
   SIGN = 1
   SIGN = -1 %and SKIP SYMBOL %and NS = NEXT SYMBOL %if NS = '-'
   %result = FALSE %unless '0' <= NS <= '9'
   D = 0
   %while '0' <= NS <= '9' %cycle
      FAULT ("Integer too large") %if D > MAX VALID INT//10
      D = D * 10 - '0' + NS
      SKIP SYMBOL
      NS = NEXT SYMBOL
   %repeat
   D = D * SIGN
   %result = TRUE
%end

%integer %fn GET POINT (%record (POINTFM) %name P)
   %result = FALSE %unless GET INT (P_X) = TRUE
!BUG!write (p_x,1)
   FAULT ("Point in path only contains one digit") %unless GET INT (P_Y) = TRUE
!BUG!write (p_y,1)
   P_X = INT(P_X * R SCALE)
   P_Y = INT(P_Y * R SCALE)
!DIAG!write (p_x, 1); write (p_y,1)
   %result = TRUE
%end

%routine CHECK SEMI
   SKIP BLANKS
   FAULT ("Semi-colon missing") %if NEXT SYMBOL#';'
   SKIP SYMBOL
%end

%routine GET PATH
   ! Read a path of co-ordinates
   %record (POINTFM) %name P, NP
   %integer CH

   FAULT ("No points in Polygon or Wire path") %unless GET POINT (POINTS(1)) = TRUE
   NUM ELEMENTS = 2
   %while GET POINT (POINTS(NUM ELEMENTS)) = TRUE %cycle
      P == POINTS (NUM ELEMENTS-1)
      NP == POINTS (NUM ELEMENTS)
      NUM ELEMENTS = NUM ELEMENTS + 1 %unless NUM ELEMENTS > 1 %and P_X=NP_X %and P_Y=NP_Y
      FAULT ("Too many points in path") %if NUM ELEMENTS> MAX ELEMENTS
   %repeat
   WARN ("Redundant information after path description") %if NEXT SYMBOL # ';'
   %cycle
      READ SYMBOL (CH)
      LINES = LINES + 1 %if CH = NL
   %repeat %until CH=';'
   NUM ELEMENTS = NUM ELEMENTS -1 ; ! To balance  the books!
%end

%integer %fn GET US INT (%integer %name D)
   ! This is called when an Un-signed integer is required
   %result = FALSE %unless GET INT (D) = TRUE
   FAULT ("Un-wanted negative integer ".ITOS(D,0)) %if D<0
   %result = TRUE
%end

%routine GET LAYER NAME (%string(*) %name S)
   %const %integer MAX L NAME LENGTH = 4
   %integer NC

   SKIP BLANKS
   NC = NEXT SYMBOL
   %unless 'A' <= NC <= 'Z' %or '0' <= NC <= '9' %start
      FAULT ("Invalid symbol `".TO STRING(NC)."' in layer name")
   %finish
   S = ""
   %cycle
      SKIP SYMBOL
      S = S.TO STRING(NC)
      %exit %if LENGTH(S)>MAX L NAME LENGTH
      NC = NEXT SYMBOL
      %exit %unless 'A' <= NC <= 'Z' %or '0' <= NC <= '9'
   %repeat
   LINES = LINES + 1 %if NC = NL
   FAULT ("Layer name `".S."' too long") %and S="" %if LENGTH(S) > 4
%end

%routine DO INCLUDE FILE (%string (127) STR)
   %integer OSTM, STM, S, L, W, E
   %on 3,9 %start
       %if EVENT_SUB=2 %start
           WARN ("Include file nesting too large with """.STR."""")
       %finish %else %start
           WARN ("Include file """.STR.""" does not exist or no access")
       %finish
       %return
   %finish

   STM = IN STREAM + 1
   OPEN INPUT (STM, STR)
   SELECT INPUT (STM)
   INIT = FALSE
   INCLUDE DEPTH = INCLUDE DEPTH + 1
   L = LINES;   S = STATEMENTS;   W = WERRORS;   E = FERRORS
   ANALYSE CIF (LINES, STATEMENTS, WERRORS, FERRORS, MAX ELEMENTS)
   OSTM = OUT STREAM
   SELECT OUTPUT (0)
   SPACES (INCLUDE DEPTH * 2)
   PRINT STRING ("Include file """.IN FILE NAME.""" contained ")
   WRITE (STATEMENTS, 0)
   PRINT STRING (" statements")
   %if WERRORS#0 %or FERRORS#0 %start
       PRINT STRING (", ")
       WRITE (FERRORS, 0);   PRINT STRING (" fault")
       PRINT SYMBOL ('s') %if FERRORS#1
       PRINT STRING (" and ")
       WRITE (WERRORS, 0);   PRINT STRING (" warning")
       PRINT SYMBOL ('s') %if WERRORS#1
   %finish
   NEWLINE
   INCLUDE DEPTH = INCLUDE DEPTH - 1
   LINES = L;   STATEMENTS = S;   WERRORS = W;   FERRORS = E
   SELECT OUTPUT (OSTM)
   SELECT INPUT (STM-1)
%end

   %on 9,14 %start
       %if event_event=9 %start
           STR = "Unexpected end of CIF, "
           %if INDEF = TRUE %start
               D W DEF ('F', FERRORS-SFAULTS)
               STR = STR."Definition Finish and End assumed"
           %finish %else STR = STR."End assumed"
           WARN (STR)
           INIT = FALSE
           %return
       %finish
       ! 14 is signaled after a fault is found, analysis starts at the next command.
   %finish

   %if INIT=FALSE %start
       R SCALE = 1
       LINES = 1
       WERRORS = 0
       FERRORS = 0
       STATEMENTS = 0
       IGNORE = FALSE
       L VALID = FALSE
       OLD LAYER = FALSE
       INDEF = FALSE
       UNITY TRANSFORM (UNITY)
       INIT = TRUE
   %finish

   %cycle

      SKIP BLANKS
      READ SYMBOL (COMMAND)
      STATEMENTS = STATEMENTS + 1
      -> CS(COMMAND)

CS('B'): ! Box
         FAULT ("Invalid Box length specification") %unless GET US INT (L) = TRUE
         L = INT(L * R SCALE)
         FAULT ("Invalid Box width specification") %unless GET US INT (W) = TRUE
         W = INT(W * R SCALE)
         FAULT ("Box centre point wrong") %unless GET POINT (P) = TRUE;     ! Centre
         ! Optional direction vector may follow
         D_X = 1 %unless GET INT (D_X) = TRUE
         D_Y = 0 %unless GET INT (D_Y) = TRUE
         CHECK SEMI

         %continue %if IGNORE = TRUE
         FAULT(LAYER NOT VALID) %if LVALID = FALSE
         WARN ("Zero area box ignored") %and %continue %if L=0 %or W=0
         D W BOX (L, W, P, D)
         %continue

CS('C'): ! Call definition with possible transformation
         FAULT ("Invalid definition description ".TO STRING (NEXT SYMBOL)) %unless GET US INT (X) = TRUE
         ! Optional transformation now follows.
         NT = UNITY
         OT = UNITY
         %cycle
            SKIP BLANKS
            READ SYMBOL (NS)
            %exit %if NS=';'
            FAULT ("Invalid symbol call transformation '".TO STRING(NS)."'") %if NS#'M' %and NS#'T' %and NS#'R'
            %if NS='T' %start
                FAULT ("Invalid symbol call Transformation Vector") %unless GET POINT(P) = TRUE
                TRANSLATE TRANSFORM (P_X, P_Y, TT)
            %finish
            %if NS='M' %start
                SKIP BLANKS
                READ SYMBOL (NS)
                FAULT("Invalid symbol call mirroring operation") %unless NS='X' %or NS='Y'
                MIRROR X TRANSFORM (TT) %if NS = 'X'
                MIRROR Y TRANSFORM (TT) %if NS = 'Y'
            %finish
            %if NS='R' %start
                FAULT ("Invalid symbol call Rotation vector") %unless GET POINT(D) = TRUE
                ROT DV TRANSFORM (D_X, D_Y, TT)
            %finish
            COMPOSE TRANSFORM (OT,TT,NT)
            OT = NT
         %repeat

         %continue %if IGNORE = TRUE

         D W CALL (X, NT_A)
         %continue

CS('D'): ! Start Defn, End Defn, Delete Defn.
         IGNORE = FALSE
         ! Coming back to normal analysis to give better error mess.
         SKIP BLANKS
         READ SYMBOL (NS)
         FAULT ("Invalid symbol definition operation '".TO STRING(NS)."'") %unless NS='F' %or NS='S' %or NS='D'

         %if NS='F' %start; ! No more parameters
             CHECK SEMI
             FAULT ("Too many Definition Finishes") %if INDEF = FALSE
             D W DEF ('F', FERRORS-SFAULTS)
             INDEF = FALSE
             R SCALE = 1
             LVALID = OLD LAYER
             %continue
         %finish

         FAULT ("Invalid definition description ".TO STRING(NEXT SYMBOL)) %unless GET US INT (ID) = TRUE
         %if NS='D' %start
             CHECK SEMI
             Y = 0
             FAULT ("DD is not allowed inside a definition") %if INDEF = TRUE
             D W DEF ('D',ID)
             %continue
         %finish

         ! Optional scaling factor
         X = 1 %unless GET US INT (X) = TRUE
         WARN ("Zero value for DS scaling ignored") %and X=1 %if X=0
         Y = 1 %unless GET US INT (Y) = TRUE
         %if Y=0 %start
             WARN ("DS scaling factor included a division by 0 - IGNORED")
             R SCALE = 1
         %finish %else R SCALE = X/Y
         CHECK SEMI

         %if INDEF = TRUE %start
             WARN ("Missing Definition Finish")
             D W DEF ('F', FERRORS-SFAULTS)
         %finish
         D W DEF ('S',ID)
         OLD LAYER = LVALID
         LVALID = FALSE
         INDEF = TRUE
         SFAULTS = FERRORS; ! Used to find if any faults occurred during defn.
         %continue

CS('E'): ! End
         FAULT ("Missing Definition Finish at End") %if INDEF = TRUE
         INIT = FALSE %if INCLUDE DEPTH = 0
         %return

CS('L'): ! Layer specification
         GET LAYER NAME (STR)
         CHECK SEMI
         IGNORE = FALSE
         LVALID = TRUE
         D W LAYER (STR)
         %continue

CS('P'): ! Polygon
         GET PATH

         WARN ("Polygon with less than 3 points ignored") %and %continue %if NUM ELEMENTS<3
         %continue %if IGNORE = TRUE
         FAULT (LAYER NOT VALID) %if L VALID = FALSE

         D W POLYGON (NUM ELEMENTS, POINTS)
         %continue

CS('R'): ! Round Flash
         FAULT ("Invalid flash diameter spec") %unless GET US INT(W) = TRUE
         W = INT(W * R SCALE)
         FAULT ("Flash centre not correctly specified") %unless GET POINT (POINTS(1)) = TRUE
         CHECK SEMI

         WARN ("Zero diameter flash ignored") %and %continue %if W=0
         %continue %if IGNORE = TRUE
         FAULT (LAYER NOT VALID) %if L VALID = FALSE

         D W WIRE (W, 1, POINTS)
         %continue

CS('W'): ! Wire
         FAULT ("Invalid wire width spec") %unless GET US INT (W) = TRUE
         W = INT(W * R SCALE)
         GET PATH

         %continue %if IGNORE = TRUE
         FAULT (LAYER NOT VALID) %if L VALID = FALSE

         D W WIRE (W, NUM ELEMENTS, POINTS)
         %continue

CS(';'): ! Ignore separators
         %continue

CS('('): ! Comment
         NEST = 1
         STR = ""
         %cycle
            %cycle
               READ SYMBOL (NS)
               STR = STR.TO STRING (NS) %if LENGTH(STR)<255
            %repeat %until NS=')' %or NS='(' %or NS=NL
            NEST = NEST-1 %if NS=')'
            %exit %if NEST = 0
            NEST = NEST+1 %if NS='('
            %if NS = NL %start
                LINES = LINES + 1
                WARN ("Comment crosses line boundary") %if NL in comment # TRUE
                NL in comment = true
            %finish
         %repeat
         SKIP BLANKS
         SKIP SYMBOL %and -> CS('(') %if NEXT SYMBOL = '('; ! More comment!!
         CHECK SEMI
         LENGTH(STR) = LENGTH(STR) - 1 ; ! Loose the last ')'
         D W COMMENT (STR)
         %continue

CS('0'): ! CIF include file
         WARN ("Missing Definition Finish at Include") %and D W DEF ('F', 1) %if INDEF=TRUE
         SKIP SYMBOL %while NEXT SYMBOL <=' '
         STR = ""
         %cycle
            READ SYMBOL (NS)
            %exit %if NS = ';'
            STR = STR.TO STRING(NS) %if LENGTH(STR)<255 %and NS>' '
         %repeat
         do include file (str)
         %continue

CS('1'): ! Comment to be typed
         NEST = OUT STREAM
         SELECT OUTPUT (0)
         PRINT STRING ("Comment: ")
         %cycle
            READ SYMBOL (NS)
            %exit %if NS = ';'
            PRINT SYMBOL (NS)
         %repeat
         NEWLINE
         SELECT OUTPUT (NEST)
         %continue

CS('2'): CS('3'): CS('4'): CS('5'): CS('6'): CS('7'): CS('8'): CS('9'): ! User expansions
         STR = ""
         SKIP SYMBOL %while NEXT SYMBOL <=' '
         %cycle
            ! Only 1st. 255 chars of comment significant
            READ SYMBOL (NS)
            %exit %if NS = ';'
            %if NS = NL %start
                WARN ("User Code string crosses line boundary") %if NL in user code # TRUE
                NL in user code = TRUE
            %finish
            STR = STR.TO STRING (NS) %if LENGTH(STR)<255
         %repeat
         D W USER CODE (COMMAND-'0', STR)
         %continue

CS(*): FAULT ("Invalid command symbol '".TO STRING (COMMAND)."'")
%repeat

%end

%end %of %file