%external %string (31) %fn CIFSYS VERSION
   %result = "CIFSYS  Version 3.12V  Oct 1983"
%end

{#######################################################################}
{#                                                                     #}
{#     This program is part of the ILAP library, and was written in    #}
{#  The Department of Computer Science at the University of Edinburgh  #}
{#      (James Clerk Maxwell Building, Kings Buildings, Edinburgh)     #}
{#                                                                     #}
{#  This software is available free to other educational establisments #}
{#  but the University of Edinburgh, retains all commercial rights.    #}
{#  It is a condition of having this software is that the sources are  #}
{#  not passed on to any other site, and that Edinburgh University is  #}
{#  given credit in any re-implementations of any of the algorithms    #}
{#  used, or articles published which refer to the software.           #}
{#                                                                     #}
{#  There is no formal support for this software, but any bugs should  #}
{#  be reported to Gordon Hughes or David Rees at the above address,   #}
{#  and these are likely to be fixed in a future release.              #}
{#                                                                     #}
{#######################################################################}

!############################################################################
!#                                                                          #
!#                          General  Comments -                             #
!#                                                                          #
!############################################################################
!
! This is the main program in the Edinburgh CIF SYStem suite.
! It was implemented in 1980/1981 by J Gordon Hughes.
! It is very losely based on the CIF20P Software system which was developed at
! CALTEC for the Dec System 10/20.
!
! This consists of the following modules -
!
!
! a) Geometrical language parsers -
!
! CIF PARSER    - A syntactic analyser for CIF files.
!
! GAELIC PARSER - A syntactic analyser for GAELIC files.
!
!
! b) Utility programs which use the parsers -
!
! CIFSYS - This is the main program in the suite, (this file).
!          It holds the main data structure, and controls all the semantic
!          analysis and storage of the CIF description.
!          The calling program must set up the streams for CIFSYS.
!
! TO GAELIC - A program to write the output from the CIF parser in GAELIC.
!
! TO CIF    - A program to write the output from the GAELIC parser in CIF.
!
!
! c) Programs that use CIFSYS and CIF PARSER -
!
! CIF CHECK - A program to satisfy the references in CIF SYS, and thus
!             perform a syntactic and semantic check of a CIF file.
!
! CIF VIEW - A main program which allows the user to interactively view the
!            CIF description.
!
! FLAT CIF - A program which takes a hierarchical CIF file, and transforms it
!            into a CIF file with no Calls to other symbols.


%const %integer TRUE = 1, FALSE = 0

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

!############################################################################
!#                                                                          #
!#    E X T E R N A L   R O U T I N E S   A N D   S Y S T E M   S P E C S   #
!#                                                                          #
!############################################################################

! External to be found on all other systems -
%include "Inc:maths.imp"
%include "Inc:util.imp"
%include "edwin:txstack.inc"
!%external %string (63) %fn %spec ITOS (%integer V, P)
!%external %routine %spec PROMPT (%string (63) TS)
!%external %integer %fn %spec STOI (%string (255) S)

! The CIF parser
!%external %routine %spec ANALYSE CIF (%integer %name LINES, STATEMENTS, WARNS, ERRORS, %integer MAX POINT)
%include "cparse"

! Routines provided by the calling program -
%external %routine %spec DO BOX     (%integer L, W, %record (POINTFM) %name C, D)
%external %routine %spec DO WIRE    (%integer W, NP, %record (POINTFM) %array %name P(1:*))
%external %routine %spec DO POLYGON (%integer NP, %record (POINTFM) %array %name P(1:*))
%external %routine %spec DO TEXT    (%integer SIZE, DIR, X, Y, %string (255) STR)
%external %routine %spec DO MB BOX  (%string (255) NAME, %integer XL, YB, XR, YT)
%external %routine %spec DO LAYER   (%string (5) L)
%external %routine %spec GET WINDOW (%integer %name XL, XR, YB, YT)

! System specific procedures
!$IF VAX or MOUSES
!%external %string (15) %spec CONSOLE INT
!$IF EMAS
!%external %integer %fn %spec IN STREAM
!%external %string (15) %fn %spec INTERRUPT; ! and change the line where CONSOLE INT is checked
!$FINISH

!###########################################################################
!#                                                                         #
!#                Global constants for use in CIFSYS.                      #
!#                                                                         #
!###########################################################################

! Disaster failure codes - given as the sub-event of %signal 13
%const %integer USER TERMINATE = 0
%const %integer TOO MANY DEFS = 1
%const %integer TOO LARGE PERCENTAGE = 2
%const %integer DATA OVERFLOWED = 3
%const %integer CALLING UNDEFINED CELL = 4
%const %integer DATA CORRUPT = 5
%const %integer DICTIONARY CORRUPT = 6
%const %integer INVALID CIF STRUCTURE = 7

%const %integer INFINITY = 2\\30
! This is machine depeandant, but 2\\30 is recomended as MAX.

%const %integer MAX DEF = 200
! MAX DEF is the number of DF's allowed.

%external %integer MAX ELEMENTS = 500
! MAX ELEMENTS is the number of elements allowed in a wire or polygon.

%const %integer MAX LAYERS = 23
%own %integer N LAYERS = MAX LAYERS
! N LAYERS is the number of internal layers used.
! but note that N LAYERS can't exceed MAX LAYERS owe to use in records

%own %string(4) %array %name L NAMES (1:max layers)
! L NAMES string array of layer names
! Note that the last layer in list MUST be an invalid one.
! But the layer number is used for storing CALLS on.

%own %integer %array %name R LAYERS (1:max layers)
! R LAYERS is an array which says whether a given layer should be drawn.
! 0 => it is to be drawn,  #0 => do not draw

%own %integer %array %name PERCENTS (1:max layers)
! This holds the percentage of the data structure to be used for each layer.

! This is the record format used for cell descriptors -
%const %integer COM LEN = 31
%record %format SUB DEF F (%integer ID, (%integer XL, YB, XR, YT %or %record (POINTFM) PL, PU),
   %integer LAYER MAP, %integer %array EP(1:MAX LAYERS),
   %byte VALID, DELED, MBB, ANNOT, %string (COM LEN) NAME)


!###########################################################################
!#                                                                         #
!#                  V A R I A B L E   D E C L A R A T I O N S              #
!#                                                                         #
!#                        and non-configration constants                   #
!#                                                                         #
!###########################################################################

%own %integer INIT = FALSE
%own %record (SUBDEFF) %array DEFS(0:MAX DEF);   ! Pointers to the CELL definitions
%const %integer NULL CELL = 0
%const %integer NO FAST REF = 255
%const %integer ALL LAYERS = -1
%own %byte %integer %array FAST FIND (0:MAX DEF) = NO FAST REF (*)
%own %integer CWXR, CWXL, CWYB, CWYT
%own %integer ND = 0, MONITOR = 0, LEVEL = 99, C LAYER = -1
%own %integer IGNORE = FALSE; ! TRUE when recovering from errors
%own %record (SUB DEF F) %name CCELL ;      ! The current cell.
%own %real R SCALE
%own %integer WERRORS, FERRORS, STATEMENTS, LINES, FORWARD REFS
%own %integer C LEVEL = 0, MBBUSED, INDEF = FALSE, CALL LAYER
%own %integer %name CXMIN, CXMAX, CYMIN, CYMAX
%own %record (POINTFM) P, PU, PL, PD, NO ROT
%own %record (POINTFM) %array %name POINTS (1:*)

!###########################################################################
!#                                                                         #
!#        D A T A    S T R U C T U R E    M A N A G E R   R T S            #
!#                                                                         #
!###########################################################################

%include "CIFDATAS"

!###########################################################################
!#                                                                         #
!#     U t i l i t y   r o u t i n e s   f o r   w h o l e    f i l e      #
!#                                                                         #
!###########################################################################

%routine %spec EXTERNAL THING IN FILE
%const %integer EXTERNAL NUMBER = 16_7FFFFFFF
%own %integer EXTERNAL GEOMETRY = FALSE

%routine LAYER MONITOR
   %integer I, N

   PRINT STRING ("Layer monitor -")
   NEWLINE
   PRINT STRING ("Layer   start     end    used from limit")
   NEWLINE
   %for I = 1, 1, N LAYERS %cycle
        SPACES (2)
        PRINT STRING (LNAMES (I))
        SPACE %if LENGTH(LNAMES(I)) = 2
        WRITE (OFFSETS(I), 7)
        WRITE (LAYERS(I), 7)
        WRITE (LAYERS(I)-OFFSETS(I), 7)
        %if I#N LAYERS %then N = OFFSETS(I+1)-OFFSETS(I) %else N = LAYERS(1)+TANKSIZE-OFFSETS(N LAYERS-1)
        WRITE (N, 10)
        NEWLINE
   %repeat
%end

%routine SWAP (%integer %name A, B)
   %integer C

   C = A;   A = B;   B = C
%end

!#############################################################################
!#                                                                           #
!#         C I F A A D      Semantic analysis and drawing section            #
!#                                                                           #
!#############################################################################

%routine FAIL (%string(255) REASON, %integer MODE)
   PRINT SYMBOL (MODE)
   PRINT STRING (" Line")
   WRITE (LINES, 4)
   SPACE
   SPACE
   PRINT STRING (REASON)
   NEWLINE
%end

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

%routine AFAULT (%string(255) REASON)
   FAIL (REASON, '*')
   F ERRORS = F ERRORS + 1
   %monitor %if MONITOR&2#0
   %signal 14, 0
%end

%routine SET POINTERS FOR CELL (%integer N)
   CCELL == DEFS(N)
   CXMIN == CCELL_XL;   CXMAX == CCELL_XR
   CYMIN == CCELL_YB;   CYMAX == CCELL_YT
%end

%routine BOUND CHECK (%record (POINTFM) %name P)
   CXMIN = P_X %if P_X<CXMIN
   CXMAX = P_X %if P_X>CXMAX
   CYMIN = P_Y %if P_Y<CYMIN
   CYMAX = P_Y %if P_Y>CYMAX
%end

%integer %fn FIND (%integer ID)
   %integer I

   %if ID< MAX DEF %start
       I = FAST FIND (ID)
       %result = I %if I # NO FAST REF
   %else
       %for I = 1, 1, ND-1 %cycle
            %result = I %if ID=DEFS(I)_ID
       %repeat
   %finish
   %result = -1
%end

%routine MB BOX (%integer CELL)
   ! Call DO MB BOX with the appropriate parameters
   %record (SUB DEF F) %name CCELL
   %string (255) NAME

   CCELL == DEFS(CELL)
   POINT TRANSFORM (CCELL_PL, PL)
   POINT TRANSFORM (CCELL_PU, PU)
   SWAP (PL_X, PU_X) %if PL_X > PU_X
   SWAP (PL_Y, PU_Y) %if PL_Y > PU_Y
   %if CCELL_ANNOT # 0 %start
       NAME = CCELL_NAME
       NAME = ITOS(CCELL_ID, 0) %if NAME=""
   %finish %else NAME=""
   DO MB BOX (NAME, PL_X, PL_Y, PU_X, PU_Y)
%end

%routine INTERPRET (%integer ADR)
   ! This routines interprets the data structure for a CALL command.
   %integer C, W, L, S, NUM ELEMENTS, X, Y
   %real %array TT (0:8)
   %string (255) STR
   %record (SUB DEF F) %name CELL
   %switch CS(0:127)

   ! The following is the format expected in the data structure.
   !
   ! !LX, 'b'!  !LY!  !UX!  !UY!                       Simple Box
   ! !width, 'B'!  !L!  !CX!  !CY!  !DX! !DY!          Box
   ! !id, 'C'!  T(1, 1) T(1, 2) T(2, 1) T(2, 2) T(3, 1) T(3, 2)
   ! !'F'!                                             Finish of Def.
   ! !no, 'P'!  <no of coordinate pairs>               Polygon
   ! !no, 'W'!  !width!  <no of coordinate pairs>      Wire
   ! !len, 'T'! !size,dir! !X! !Y! !str..!             Text

   C LEVEL = C LEVEL + 1
   %cycle
!!!      CONSOLE INT = "" %and %signal 13, USER TERMINATE %if CONSOLE INT # ""
!!!      %signal 13, USER TERMINATE %if INTERRUPT # ""
      C = GET (ADR)
      S = C&127
      -> CS(S)

CS('b'): ! No rotation vector
CS('B'): L = GET (ADR)
         GET POINT (ADR, P)
         %if S='B' %then GET VECTOR (ADR, PD) %else VECTOR TRANSFORM (NO ROT, PD)
         DO BOX (L, C>>8, P, PD)
         %continue

CS('c'): ! If cell wasn't known when used.
CS('C'): ! If cell was known when used.
         ! Internal call of cell's worth of current colour.
         C = C>>8&16_FFFF
         %if S='c' %start
             C = FIND (C)
             %signal 13, CALLING UNDEFINED CELL %if C<0
             ! There is no need to tell the user which cell, as he was warned earlier of cells which were undefined.
         %finish
         CELL == DEFS(C)
         GET TRANS (ADR, TT)
         %continue %if 1<<CLAYER & CELL_LAYER MAP = 0
         PUSH TRANSFORM (record (addr(TT(0))))
         POINT TRANSFORM (CELL_PL, P)
         POINT TRANSFORM (CELL_PU, PD)
         SWAP (P_X, PD_X) %if P_X>PD_X
         SWAP (P_Y, PD_Y) %if P_Y>PD_Y
         %unless P_X>CWXR %or P_Y>CWYT %or PD_X<CWXL %or PD_Y<CWYB %start
             %if CELL_MBB=1 %or CLEVEL>=LEVEL %start
                 %if C LAYER # CALL LAYER %then MBB USED=TRUE %else MB BOX(C)
             %finish %else %start
                 INTERPRET (CELL_EP(CALL LAYER)) %if CELL_EP(CALL LAYER)#0
                 INTERPRET (CELL_EP(CLAYER)) %if CELL_EP(CLAYER)#0 %and CLAYER#CALLLAYER
             %finish
         %finish
         POP TRANSFORM
         %continue

CS('F'): CLEVEL = CLEVEL - 1
         %return

CS('P'): NUM ELEMENTS = C>>8
         %for L = 1, 1, NUM ELEMENTS %cycle
           GET POINT (ADR, POINTS(L))
         %repeat
         DO POLYGON (NUM ELEMENTS, POINTS)
         %continue

CS('T'): NUM ELEMENTS = C>>8
         S = GET(ADR)
         W = S & 255
         S = S >> 8
         X = GET(ADR);   Y = GET(ADR)
         STR = ""
         C = GET(ADR) %and STR = STR.TOSTRING(C) %for L = 1, 1, NUM ELEMENTS
         DO TEXT (S, W, X, Y, STR)
         %continue

CS('W'): NUM ELEMENTS = C>>8
         W = GET (ADR)
         GET POINT (ADR, POINTS(L)) %for L = 1, 1, NUM ELEMENTS
         DO WIRE (W, NUM ELEMENTS, POINTS)
         %continue

CS(*):  %signal 13, DATA CORRUPT
   %repeat
%end

%routine DO CALL (%integer I)
   ! Call cell I
   %integer J, OLD LAYER, CLP, P
   %record (SUB DEF F) %name THIS CELL

   OLD LAYER = CLAYER
   THIS CELL == DEFS(I)
   %unless THIS CELL_MBB=1 %or LEVEL=0 %start
       MBB USED = FALSE
       CLP = THIS CELL_EP(CALL LAYER)
       %for J=1, 1, N LAYERS-1 %cycle
            %continue %if R LAYERS (J) = FALSE
            CLAYER = J
            DO LAYER (L NAMES(CLAYER))
            INTERPRET (CLP) %if CLP#0
            P = THIS CELL_EP(CLAYER)
            INTERPRET (P) %if P#0
       %repeat
       ! NB - MBB USED is set in the routine INTERPRET if DO MB BOX is called.
       CLAYER = CALL LAYER %and INTERPRET (CLP) %if MBB USED = TRUE
   %finish %else CLAYER = CALL LAYER %and MB BOX (I)
   CLAYER = OLD LAYER
%end

%routine %spec CLEAN UP AT END { HMD should be hung drawn & Quartered for this! }

%external %routine ANAL OR DRAW CIF (%integer PARM, CELL, M LAYERS, FACTOR,
   %string (4) %array %name  LAYER NAMES(1:max layers),
   %integer %array %name VALID(1:max layers), PERCENTAGES(1:max layers))
   ! PARM =0 => ANALYSIS,  #0 => draw
   ! Cell = internal number of cell if PARM#0
   ! MAX LAYERS = number of layers defined, = 'N LAYERS' of CIFSYS
   ! FACTOR = A scaling factor for initilaisation.
   ! LAYER NAMES = names of valid layers
   ! VALID = decided if layer should be drawn or not.
   ! PERCENTAGES = used at initialisation, to divide the data structure.
   %record (POINTFM) %array P (1:MAX ELEMENTS)

   %on 0 %start
       %signal 13, USER TERMINATE
   %finish

   GET WINDOW (CWXL, CWXR, CWYB, CWYT)
   FORWARD REFS = FALSE
   C LEVEL = 0
   R SCALE = 1
   N LAYERS = M LAYERS
   CALL LAYER = N LAYERS
   L NAMES == LAYER NAMES
   R LAYERS == VALID
   POINTS == P
   %if INIT#TRUE %start
       PERCENTS == PERCENTAGES
       GET DATA SPACE (FACTOR)
       DEFS (NULL CELL) = 0
       SET POINTERS FOR CELL (NULL CELL)
       ND = 1; ! Next definition
       NO ROT_X = 1;   NO ROT_Y = 0;   ! Set up a unit rotation vector
       INIT = TRUE
   %finish
   %if PARM = 0 %start
       INIT TRANSFORM
       SET POINTERS FOR CELL (NULL CELL)
       WERRORS = 0
       FERRORS = 0
       STATEMENTS = 0
       IGNORE = FALSE
       LINES = 1

       ANALYSE CIF (LINES, STATEMENTS, W ERRORS, F ERRORS, MAX ELEMENTS)
       CLEAN UP AT END

       WRITE (STATEMENTS, 0)
       PRINT STRING (" CIF statements analysed")
       %if FERRORS#0 %or WERRORS#0 %start
           PRINT STRING (" with")
           WRITE (FERRORS, 1)
           PRINT STRING (" fault")
           PRINT SYMBOL ('s') %if FERRORS#1
           PRINT STRING (" and")
           WRITE (WERRORS, 1)
           PRINT STRING (" warning")
           PRINT SYMBOL ('s') %if WERRORS#1
       %finish
       NEWLINE
       LAYER MONITOR %if MONITOR&1#0
   %finish %else %start
       DO CALL (CELL)
   %finish
%end

%external %routine CIFSYS LEVEL (%integer REQ LEVEL)
   LEVEL = REQ LEVEL
%end

%external %routine CIFSYS MONITOR (%integer REQ MONITOR)
   MONITOR = REQ MONITOR
%end

{%external} %routine D W BOX (%integer L, W, %record(POINTFM) %name P, D)
   %integer I, NS, TYPE
   %record (POINTFM) PL, PU

   %return %if IGNORE=TRUE

   EXTERNAL THING IN FILE %if INDEF#TRUE

   %if D_X=0 %or D_Y=0 %start; ! Simple box.
       %if D_Y=1 %start
           I = L; L = W; W = I
       %finish
       PL_X = P_X - L//2;   PL_Y = P_Y - W//2
       PU_X = P_X + L//2;   PU_Y = P_Y + W//2
       TYPE = 'b'
   %finish %else %start
      ! To save calculation, a bad (ie. too large) estimate is found.
       %if L>W %then NS = L %else NS = W
       PL_X = P_X - NS;   PL_Y = P_Y - NS
       PU_X = P_X + NS;   PU_Y = P_Y + NS
       TYPE = 'B'
   %finish
   ADD (W<<8!TYPE);   ADD (L);   ADD POINT (P)
   ADD POINT (D) %if TYPE='B'
   BOUND CHECK (PL)
   BOUND CHECK (PU)
%end

{%external} %routine D W CALL (%integer CELL, %real %array %name TX(0:8))
   %integer ID, L, MAP
   %record (POINTFM) PU, PL
   %record (SUB DEF F) %name OLD CELL

   %on 2, 8 %start
       LAYER MONITOR
       %signal 13, DATA OVERFLOWED
   %finish

   %return %if IGNORE=TRUE

   ID = FIND(CELL)
   EXTERNAL THING IN FILE %if INDEF#TRUE
   AFAULT ("Recursive Calls are not allowed") %if CELL=CCELL_ID
   FORWARD REFS = TRUE %if ID < 0
   %if FORWARD REFS#TRUE %start; ! Calculate BB as analysis is done.
       OLD CELL == DEFS (ID)
       MAP = OLD CELL_LAYER MAP
       PUSH TRANSFORM (record(addr(TX(0))))
       BB TRANSFORM (OLD CELL_PL, OLD CELL_PU, Pl, PU)
       POP TRANSFORM
       BOUND CHECK (PL)
       BOUND CHECK (PU)
   %finish %else MAP <- ALL LAYERS
   CCELL_LAYER MAP = CCELL_LAYER MAP ! MAP
   %signal 13, DATA OVERFLOWED %if LAYERS(CALL LAYER)+8*4 >= OFFSETS(1) + TANK SIZE
   L = CLAYER
   CLAYER = CALL LAYER
   %if ID>0 %and DEFS(ID)_MBB=0 %then ADD (ID<<8!'C') %else ADD (CELL<<8!'c')
   { Don't use the fast lookup if the cell has errors, or was an external symbol, as it can be re-defined }
   ADD TRANS (TX)
   CLAYER = L
%end

{%external} %routine D W DEF (%integer ID, INFO)
   %own %integer OLAYER = -1
   %integer I, Y, W

   %if ID='F' %start
       CCELL_ANNOT = 1
       %if INFO = 0 %then CCELL_VALID = 1 %else CCELL_MBB = 1
       INDEF = FALSE
       %for I = 1, 1, N LAYERS %cycle
            CLAYER = I
            LAYER MONITOR %and %signal 13, DATA OVERFLOWED %if CLAYER<N LAYERS %and LAYERS(CLAYER)>OFFSETS(CLAYER+1)
            %if CCELL_EP(C LAYER)#LAYERS(CLAYER) %then ADD('F') %else CCELL_EP(CLAYER)=0
       %repeat
       %if CXMIN = INFINITY %and CCELL_EP(C LAYER)=0 %start
           ! If there is no geometry + no symbol calls
           WARN ("No geometry in cell """.CCELL_NAME."""")
           CXMIN = 0;   CYMIN = 0;   CXMAX = 0;   CYMAX = 0
       %finish
       CLAYER = OLAYER; ! Return to the layer setting before the def started.
       SET POINTERS FOR CELL (NULL CELL)
       %return
   %finish

   %if ID='S' %start
       %signal 13, TOO MANY DEFS %if ND>MAX DEF
       W = FIND(INFO)
       WARN ("Multiple definition of cell".ITOS(INFO, 1)) %if W>0 %and DEFS(W)_MBB=0
       { Don't fault it if it was an external symbol, being re-defined }
       INDEF =  TRUE
       SET POINTERS FOR CELL (ND)
       FAST FIND (INFO) = ND %if INFO < MAX DEF
       CCELL = 0
       CCELL_ID = INFO
       CCELL_LAYER MAP = 1 << CALL LAYER
       ! These are given impossible values
       CXMIN = INFINITY;   CYMAX = -INFINITY
       CYMIN = INFINITY;   CXMAX = -INFINITY
       CCELL_EP(I) = LAYERS(I) %for I=1, 1, N LAYERS
       ND = ND + 1
       OLAYER = CLAYER; ! remember this for after the defn.
       %return
   %finish

   %if ID='D' %start
       INFO = 0 %if INFO < 1
       Y = 0
       %for I = ND-1, -1, 1 %cycle
            CCELL == DEFS(I)
            %if CCELL_ID>=INFO %start
                EXTERNAL GEOMETRY = FALSE %if CCELL_ID = EXTERNAL NUMBER
                FAST FIND (CCELL_ID) = NO FAST REF %if CCELL_ID<MAX DEF
                %if Y=0 %start
                    %for W = 1, 1, N LAYERS %cycle; ! Return to free space.
                         LAYERS(W) = CCELL_EP(W) %if CCELL_EP(W) # 0
                    %repeat
                    ! Return library entry.
                    CCELL = 0
                    ND = ND-1
                %finish %else CCELL_ID = -1
            %finish %else Y = 1
       %repeat
   %finish
%end

{%external} %routine D W LAYER (%string(63) LAYER)
   %integer I

   IGNORE = FALSE
   %for I=1, 1, N LAYERS %cycle
      %if LAYER=L NAMES(I) %start
          C LAYER = I
          EXTERNAL THING IN FILE %if INDEF#TRUE
          CCELL_LAYER MAP = CCELL_LAYER MAP ! 1<<CLAYER
          %return
      %finish
   %repeat
   IGNORE = TRUE
   WARN ("Unknown layer name - ".LAYER.", (ignored)")
%end

{%external} %routine D W POLYGON (%integer NUM ELEMENTS, %record(POINTFM) %array %name PTS(1:*))
   %integer I

   %return %if IGNORE=TRUE

   EXTERNAL THING IN FILE %if INDEF#TRUE

   AFAULT ("Too many elements in Polygon") %if NUM ELEMENTS > MAX ELEMENTS
   ADD (NUM ELEMENTS<<8!'P')
   %for I=1, 1, NUM ELEMENTS %cycle
        BOUND CHECK (PTS(I))
        ADD POINT (PTS(I))
   %repeat
%end

{%external} %routine D W WIRE (%integer W, NUM ELEMENTS, %record(POINTFM) %arrayname P(1:*))
   %integer I

   %return %if IGNORE=TRUE

   EXTERNAL THING IN FILE %if INDEF#TRUE

   AFAULT ("Too many elements in Wire") %if NUM ELEMENTS > MAX ELEMENTS
   ADD (NUM ELEMENTS<<8!'W')
   ADD (W)
   %for I = 1, 1, NUM ELEMENTS %cycle
        PL_X = P(I)_X - W;   PL_Y = P(I)_Y - W
        BOUND CHECK (PL)
        PU_X = P(I)_X + W;   PU_Y = P(I)_Y + W
        BOUND CHECK (PU)
        ADD POINT (P(I))
   %repeat
%end

{%external} %routine D W COMMENT (%string(255) COMMENT)
   ! Comments ignored
%end

{%external} %routine D W USER CODE (%integer COMMAND, %string(255) LINE)
   %own %byte %integer %array WARNED (0:7) = 0 (*)
   %on 1, 2, 3, 4, 5, 6, 7, 8, 9 %start
       WARN ("User code ".ITOS(COMMAND,0)." did not have expected format")
       %return
   %finish

   %if COMMAND = 9 %start
       LENGTH(LINE) = COM LEN %if LENGTH(LINE)>COM LEN
       CCELL_NAME = LINE
   %finish %else %if COMMAND = 8 %start
       ! This is an 'external symbol spec', if there is no such symbol define a null one.
       %begin
          %integer xl, yb, xr, yt, num
          %record (sub def f) %name cell
          %integer %fn extract
             %string (255) val
             line -> val.(",").line
             %result = stoi (val)
          %end
          num = extract;   xl  = extract;   yb  = extract;   xr  = extract;   yt  = extract
          %if find(num) <= 0 %start
              cell == defs (nd)
              cell = 0
              cell_id = num
              fast find (num) = nd %if num < max def
              cell_NAME = "(".line.")"
              cell_ep(num) = 0 %for num = 1, 1, n layers
              cell_xl = xl;   cell_yb = yb;   cell_xr = xr;   cell_yt = yt
              cell_layer map <- all layers;    cell_mbb = 1;   cell_annot = 1
              nd = nd + 1
          %finish
       %end
   %finish %else %start
       WARN ("User code ".TO STRING (COMMAND+'0')." ignored") %if WARNED (COMMAND) = 0
       WARNED (COMMAND) = 1
   %finish
%end

{%external} %routine D W TEXT (%integer SIZE, DIR, X, Y, %string (255) STR)
   %integer I
   %return %if IGNORE = TRUE %or STR=""
   EXTERNAL THING IN FILE %if INDEF#TRUE
   ADD (LENGTH(STR)<<8!'T');   ADD (SIZE<<16!DIR);   ADD (X);   ADD (Y)
   ADD (CHARNO(STR,I)) %for I = 1, 1, LENGTH(STR)
%end

%external %routine LIST CELLS (%integer ILAP SCALE, INTERACTS, NUM PER PAGE)
   ! Dump the cell descriptors to the current stream
   %integer I, C, ID

   %routine SPRINT (%real R)
      ! Print a real number or "Uknown" (add scaling to Lambda too).
      %if CCELL_XL=0=CCELL_XR %then PRINT STRING ("     ????") %else PRINT (R/ILAP SCALE, 6, 1)
   %end

   %routine STATE (%integer ON or OFF)
      %if ONorOFF=0 %then PRINT STRING ("off") %else PRINT STRING (" on")
      SPACES (2)
   %end

   %routine HEADER
      C = 0
      PRINT STRING ("Cell No       XL       YB        XR       YT    BB   ID  Cell Name")
      NEWLINES (2)
   %end

   %on 9 %start
       %stop
   %finish

   HEADER
   %return %if ND <= 1
   %for I=ND-1, -1, 1 %cycle
        CCELL == DEFS(I)
        ID = CCELL_ID
        %if ID>=0 %start
            %if ID#EXTERNAL NUMBER %then WRITE (ID, 6) %else SPACES (7)
            SPRINT (CCELL_XL)
            SPRINT (CCELL_YB)
            SPACE
            SPRINT (CCELL_XR)
            SPRINT (CCELL_YT)
            SPACES (3)
            STATE (CCELL_MBB)
            STATE (CCELL_ANNOT)
            PRINT STRING (CCELL_NAME)
            NEWLINE
            %if INTERACTS=TRUE %start
                C = C + 1
                %if C=NUM PER PAGE %and I>1 %start
                    NEWLINE
                    PRINT STRING ("Press RETURN for more ....")
                    NEWLINES (2)
                    PROMPT ("CIF: ")
                    %return %if NEXT SYMBOL#NL
                    SKIP SYMBOL
                    HEADER
                %finish
            %finish
        %finish
   %repeat
   NEWLINE
%end

%external %integer %fn FIND CELL (%string (255) NAME, %integer N, %integer %name XL, YB, XR, YT)
   ! Find cell refered to by NAME or N, & set window bounds for it.

   %integer %fn MATCH (%string(255) S1, S2)
      ! Sees whether S1 & S2 match. Ignoring spaces & case

      %string(31) %fn CANONICAL(%string(31) NAME)
        %string(31) CANON NAME
        %integer I, CHAR
        CANON NAME = ""
        %for I = 1, 1, LENGTH(NAME) %cycle
           CHAR = CHARNO(NAME, I)
           CHAR = CHAR-32 %if 96<CHAR<123
           CANON NAME = CANON NAME.TOSTRING(CHAR) %if CHAR#' '
        %repeat
        %result = CANON NAME
      %end

      S1 = CANONICAL (S1)
      S2 = CANONICAL (S2)
      %result = FALSE %if S1#S2
      %result = TRUE
   %end

   %integer I, STAR

   %result = -1 %if ND <= 1; ! No cells defined

   %if NAME="" %and N < MAX DEF %start
       I = FAST FIND (N)
       I = 1 %if I=NO FAST REF
   %finish %else I = 1

   STAR = 1
   %for I = I, 1, ND-1 %cycle
        CCELL == DEFS(I)
        %if NAME#"*" %start
            %if NAME#"" %start
                %continue %unless MATCH (NAME, CCELL_NAME) = TRUE
            %finish %else %start
                %continue %unless CCELL_ID = N
            %finish
            STAR = I
        %finish
        %if CCELL_ID >= DEFS(STAR)_ID %start
            STAR = I
            ! Set the last four parameters to the window bounds
            XL = CCELL_XL
            YB = CCELL_YB
            XR = CCELL_XR
            YT = CCELL_YT
            %result = I %if NAME#"*"
        %finish
   %repeat
   %result = STAR %if NAME="*"
   %result = -1
%end

%external %integer %fn CIF CELL NUMBER (%integer CIFSYS ID)
   %result = DEFS(CIFSYS ID)_ID
%end

%external %routine SET CELL (%integer CELL ID, WHICH, ONOFF)
   ! CELL ID is -1 for all cells, or id of cell.
   ! WHICH = 'B' for Bounding Box, or 'I' for cell Identification.
   ! ONOFF = 'N' or 'F'
   %integer I, FIRST, LAST
   %string (127) REST

   %return %unless ND > 1;           ! No cells defined
   %return %unless CELL ID < ND;     ! Cell out of range

   %if CELL ID < 0 %then FIRST = 1 %and LAST = ND-1 %else %start
       FIRST = CELL ID
       LAST = FIRST; ! Frig to get
   %finish
   WHICH = WHICH&95
   ONOFF = ONOFF&95
   %for I = FIRST, 1, LAST %cycle
        CCELL == DEFS(I)
        %if ONOFF = 'F' %start
            CCELL_ANNOT = 0 %if WHICH = 'I'
            CCELL_MBB   = 0 %if WHICH = 'B'
        %finish %else %start
            CCELL_ANNOT = 1 %if WHICH = 'I'
            %if WHICH = 'B' %and CHARNO(CCELL_NAME, 1)#'(' %start
                %if CCELL_VALID#0 %then CCELL_MBB=1 %else %start
                    PRINT STRING ("Bounding Box still set on cell '".CCELL_NAME."' as cell contains errors")
                    NEWLINE
                %finish
            %finish
        %finish
   %repeat
   %if WHICH = 'I' %then REST="Identification" %else REST="Bounding Box"
   PRINT STRING (REST)
   %if FIRST = LAST %then REST=" of cell '".CCELL_NAME."' is" %else REST=" of all cells are"
   PRINT STRING (REST." now ")
   %if ONOFF = 'F' %then REST="off" %else REST="on"
   PRINT STRING (REST)
   NEWLINE
%end

%external %string (63) %fn CIFSYS ERROR (%integer I)
   ! This returns a string which describes error number I
   %const %integer MAX ERR = 7
   %const %string (79) %array ERRORS (0:MAX ERR) = "interrupted by user",
      "too many definitions",      "layer percentages exceed 100%",
      "data structure overflow",   "attempt to call undefined cell",
      "data structure corrupt",    "dictionary corrupt",
      "Cannot cope with CIF files with multiple sections of external geometry"

   %result = "error number".ITOS(I,1) %unless 0 <= I <= MAX ERR
   %result = ERRORS (I)
%end

%routine EXTERNAL THING IN FILE
   %signal 13, INVALID CIF STRUCTURE %if EXTERNAL GEOMETRY = TRUE
   D W DEF ('S', external number)
   D W USER CODE (9, "External Geometry")
   EXTERNAL GEOMETRY = TRUE
%end

%routine CLEAN UP AT END
   %record (SUB DEF F) %name CCELL
   %integer START, I

   %routine FIND BB (%record (SUB DEF F) %name CCELL, %integer START, CELL)
      %integer A, C, ID, LAST ERR ID, LAST ERR CELL
      %record (SUB DEF F) %name NCELL
      %string (127) MESSAGE
      %real %array TX (0:8)

      LAST ERR ID = -1
      LAST ERR CELL = -1
      %cycle
         C = GET (START)
         %exit %if C&127='F'
         GET TRANS (START, TX)
         ID = C >> 8
         ID = FIND (ID) %if C&127='c'
         %if ID < 0 %start
             C = C >> 8
             %continue %if LAST ERR ID = CCELL_ID %and LAST ERR CELL = C
             %if CCELL_ID#External Number %start
                 MESSAGE = "Cell ".ItoS(CCELL_ID,0)." uses"
             %else
                 MESSAGE = "Outer level has a call to"
             %finish
             WARN (MESSAGE." undefined cell ".ITOS(C,0))
             LAST ERR ID = CCELL_ID
             LAST ERR CELL = C
             CCELL_MBB = 1
             CCELL_VALID = 0
             %continue
         %finish
         NCELL == DEFS(ID)
         A = NCELL_EP(CALL LAYER)
         FIND BB (NCELL, A, ID) %if A#0

         ! The BB of this cell is now know
         SET POINTERS FOR CELL (CELL)
         PUSH TRANSFORM (record(addr(TX(0))))
         BB TRANSFORM (NCELL_PL, NCELL_PU, PL, PU)
         POP TRANSFORM
         BOUND CHECK (PL)
         BOUND CHECK (PU)
      %repeat
   %end

   D W DEF ('F', 0) %if External Geometry = TRUE %and INDEF=TRUE
   %return %if FORWARD REFS # TRUE

   ! Satisfy the forward references.
   %for I = ND-1, -1, 1 %cycle
        CCELL == DEFS (I)
        START = CCELL_EP(CALL LAYER)
        %continue %if START = 0
        FIND BB (CCELL, START, I)
   %repeat
%end

%external %routine Del def %alias "dwdef" (%integer ID, I)
   D W DEF ('D', I)
%end

%end %of %file