!! ***PLACE ***  6/7/81
!! V3.2 [01/03/83]: mods for IMP8  
!! V3.3 [05/06/85]: error trap {jhb}
%systemstring (255) %fnspec itos(%integer v,p)
@16_10D4%integerfn TESTSYMBOL

! The algorithm has been altered.  It is still basically an exhaustive
! search for a constructive initial placement, but the search is more
! heavily pruned by:
!
! (1) correcting a bug causing pack_needed to go negative.  it was only
!     incremented in backtrack instead of in unbind which meant that
!     any unbinding caused the search to go intractable
! (2) checking in unbind that the slot becoming dead due to being unbound
!     does not cause pack_available to drop below pack_needed and backtracking
!     if it does; this causes multiple backtracking to a more sensible
!     level frequently
! (3) using the area of all the remaining slots as an additional estimate
!     of whether a placement remains feasible as well as pack_needed
! (4) selecting the order of placement dynamically.  The order is:
!     a) constrained packages
!     b) packages with only one pack and only one slot
!     c) the most desirable pack with the same number of packs and slots,
!        or with the area of packs critically close to the area of slots.
!     d) the most desirable pack
!     desirability is defined by a function of the number of wires from
!     the pack onto the board; the number of other wires from the pack;
!     how conglomerated the wire onto the board are
!
!  Because this pruning increases the computation a lot, a fast and dirty
!  attempt is made to do the placement before calling in the big guns.
!
! the area calculation could be made much more incremental but it is
! hardly worth it for the massive increase in complexity of the program.
%BEGIN
%CONSTSTRING(31) HEADING="PLACE version 3.3 (APM)"
%owninteger tracing = 0

!%EXTERNALSTRING(31)%SPEC CONSOLE INT
!%EXTERNALROUTINESPEC RESET INPUT
%EXTERNALINTEGERFNSPEC DEF STREAMS(%STRING(127)STREAMS,DEFAULTS)
%INTEGER RETURN CODE
%OWNSTRING(71) DEFAULTS= %C
   ".CIC,ESDL:PACK.LIB,ESDL:BOARD.LIB/%I1.BIC,,"


%predicate attention
  %true %if testsymbol >= 0
  %false
%end

!! portability section
%CONSTINTEGER CPW=4;      !! characters per word
%CONSTINTEGER LCPW=2;     !! log characters per word
%CONSTINTEGER AUPW=4;     !! Addressing units per word
%CONSTINTEGER LAUPW=2;    !! Log addressing units per word
%CONSTINTEGER BPW=32;     !! Bits per word
%CONSTINTEGER MAXINTEGER=(-1)>>1
%CONSTINTEGER MININTEGER=-MAXINTEGER

!! I/O streams
%CONSTINTEGER REPORT=0;   !! terminal report stream
%CONSTINTEGER CIRCUIT=1;  !! circui to be  placed
%CONSTINTEGER PACKAGES=2; !! library of package descriptions
%CONSTINTEGER BOARDS=3;   !! library of board descriptions
%CONSTINTEGER MOUT=1;     !! main output stream
%CONSTINTEGER SOUT=2;     !! secondary output (updated input)
%CONSTINTEGER BMODS=3;    !! modifications to board pre-wiring
%CONSTINTEGER DUMP=3;     !! diagnostic dump stream

!! character interface
%CONSTINTEGER ENDFILE=9,   END OF FILE=-1,   END OF STRING=-1
%CONSTINTEGER CNTRL=128,   CNTRL CHAR='^'
%OWNINTEGER CH

!! workspace
%CONSTINTEGER STACKLEN=45000
%INTEGERARRAY STACK(0:STACKLEN)
%OWNINTEGER TOS,   BOS,   STACKTOP,   MAXTOS

!! string and tag mapping
%RECORDFORMAT FTAG(%INTEGER HNEXT, %STRING(255) S)
%CONSTINTEGER TAGLEN=1

%RECORDFORMAT FFANEL(%INTEGER SUBNO, TNO)
%CONSTINTEGER FANLEN=2

%RECORDFORMAT NETF(%INTEGER NT,
                   %RECORD(FFANEL)%ARRAY F(1:1000))
%CONSTINTEGER NETLEN=1

%integer netNumber

%RECORDFORMAT SLOTPINF(%RECORD(FTAG)%NAME PIN,   NAME)
%CONSTINTEGER SLOTPINLEN=2

! slot descriptors
%recordformatspec packf
%RECORDFORMAT SLOTF(%RECORD(SLOTF)%NAME LINK,
      %RECORD(PACKF)%NAME PACK,
      %RECORD(FTAG)%NAME NAME,
      %INTEGER X,Y,PRIORITY,NT,
      %RECORD(SLOTPINF)%ARRAY PIN(1:10000))
%CONSTINTEGER SLOTLEN=7
%RECORD(SLOTF)%NAME SLOTH

%RECORDFORMAT COORDF(%INTEGER X,Y)
%CONSTINTEGER COORDLEN=2

%RECORDFORMAT EDGEF(%RECORD(EDGEF)%NAME LINK,
      %INTEGER INFO, NT, net,
      %RECORD(FTAG)%NAME PNAME, NAME,
      %RECORD(COORDF)%ARRAY PIN(1:100))
%CONSTINTEGER EDGELEN=6
%RECORD(EDGEF)%NAME EDGEH


! package descriptors
%RECORDFORMAT PACKPINF(%INTEGER X,Y, %RECORD(FTAG)%NAME NAME)
%CONSTINTEGER PACKPINLEN=3

%RECORDFORMAT PACKF(%RECORD(PACKF)%NAME LINK,
     %RECORD(SLOTF)%NAME SLOTS, %RECORD(FTAG)%NAME NAME,
      %INTEGER NEEDED,AVAILABLE,mark,forced,
      %INTEGER XDIM,YDIM,NT,
      %RECORD(PACKPINF)%ARRAY PACKPIN(1:100))
%CONSTINTEGER PACKLEN=13
%RECORD(PACKF)%NAME PACKH


! unit descriptions
%RECORDFORMAT TERMF(%RECORD(FTAG)%NAME %ARRAY PIN(1:1000))
%RECORD(TERMF)%NAME TERMINALS
%RECORD(FTAG)%NAME CIRCUITNAME
%INTEGER CIRCUITNT

!! flags for chip constraints
%CONSTINTEGER ATF=1,   PLACEF=2
%CONSTINTEGER CONSTRAINED=ATF+PLACEF

%recordformat chippinf(%record(ftag)%name name, %integer net, packpin)
%constinteger chippinlen=3

%RECORDFORMAT CHIPF(%RECORD(CHIPF)%NAME LINK,
      %RECORD(PACKF)%NAME PACK,
      %RECORD(SLOTF)%NAME SLOT,
      %integer onCon, offCon,
      %RECORD(FTAG)%NAME UNAME,NAME,ON,AT,
      %INTEGER X, Y, NT, NUM, FLAGS,
      %RECORD(chippinf)%ARRAY PIN(1:100))
%CONSTINTEGER CHIPLEN=14
%RECORD(CHIPF)%NAME CHIPH

%RECORDFORMAT FCHIPLIST(%RECORD(CHIPF)%NAME %ARRAY CHIP(1:1000))

%RECORDFORMAT ARRAYF(%INTEGERARRAY ARRAY(1:1000))

!! board description
%RECORD(FCHIPLIST)%NAME CHIPLIST
%RECORD(FTAG)%NAME BOARDNAME
%INTEGER BOARDNSUBS,   BOARDXDIM,   BOARDYDIM
%INTEGER BIN, BOUT, BIO, BOARDNT
%CONSTINTEGER MAX PARMS=8
%RECORD(FTAG)%NAME %ARRAY BPARM(1:MAX PARMS)

!! useful constants
%CONSTINTEGER NULL=0
%CONSTINTEGER YES=0,   NO=-1
%RECORD(FTAG)%NAME NULL TAG,   EMPTY TAG
%STRING(255)%NAME NULL STRING
%CONSTINTEGER BOARDTYPE=4
%CONSTINTEGER AT=1,   ON=2,   PLACE=8,   SIZE=7,   VALUE=6
%CONSTINTEGER INOUT=3,   DUMMY=0

!! errors
%CONSTINTEGER WARNING=0,   ERROR=1,   DISASTER=2
%OWNINTEGER NERRORS=0

!! distance metric
%CONSTINTEGER LINEAR=1,   QUADRATIC=2
%OWNINTEGER METRIC=LINEAR,   DISTSCALE=255
%constinteger factor = 25

!! currently selected input and output streams
%OWNINTEGER INSTREAM=REPORT,   OUTSTREAM=REPORT


%ROUTINE SELIN(%INTEGER STREAM)
   SELECTINPUT(STREAM)
   INSTREAM=STREAM
%END

%ROUTINE SELOUT(%INTEGER STREAM)
   SELECTOUTPUT(STREAM)
   OUTSTREAM=STREAM
%END

%ROUTINE RCH
   !! Read the next character from the input
   %INTEGER I,   L

   %ON %EVENT 3,ENDFILE %START
      CH=END OF FILE
      ->OUT
   %FINISH
START:
   %CYCLE
      READSYMBOL(CH)
   %REPEAT %UNTIL CH#NL

   %IF CH=CNTRL CHAR %START
      READSYMBOL(CH)
      CH=CH+CNTRL
   %FINISH
   %IF CH=CNTRL+'K' %START
      !! Read the comment text (self defining string)
      READ(L);   RCH
      %FOR I=1,1,L %CYCLE
         RCH
      %REPEAT
      ->START
   %FINISH
OUT:
%END

%ROUTINE SKIP TO(%INTEGER WHERE)
   RCH %WHILE CH#WHERE
%END

%OWNINTEGER LINECT=0
%CONSTINTEGER LINELEN=60

%ROUTINE PCH(%INTEGER CH)
   PRINTSYMBOL(CNTRL CHAR) %AND LINECT=LINECT+1 %IF CH>127
   PRINTSYMBOL(CH&127)
   LINECT=LINECT+1
%END

%ROUTINE BLANK
   PCH(' ')
%END

%ROUTINE SEPARATE
   NEWLINE %AND LINECT=0 %IF LINECT>=LINELEN
%END

%ROUTINE PNUM(%INTEGER N)
   WRITE(N,0)
   LINECT=LINECT+2
%END

%ROUTINE SPNUM(%INTEGER N)
   PNUM(N)
   BLANK
%END

%ROUTINE PUT STRING(%STRING(*)%NAME S)
   PNUM(LENGTH(S)); PCH(':')
   PRINTSTRING(S)
   LINECT=LINECT+LENGTH(S)+1
   SEPARATE
%END

%ROUTINE PUT TAG(%RECORD(FTAG)%NAME TAG)
   %IF TAG==NULL TAG %THEN PUT STRING(NULL STRING) %C
   %ELSE PUT STRING(TAG_S)
%END

%ROUTINE COPY TO(%INTEGER WHERE)
   %RETURN %IF CH=WHERE
   %CYCLE
      RCH
      %EXIT %IF CH=WHERE
      PCH(CH)
   %REPEAT
%END

%STRING(63)%FN CTOS(%INTEGER X, Y)
   %RESULT=ITOS(X,0).":".ITOS(Y,0)
%END

%ROUTINE CHECK(%INTEGER WHAT)
  %RETURN %IF CH=WHAT
  SELECTOUTPUT(REPORT)
  PRINTSTRING("Invalid I-code, Expecting ")
  PCH(WHAT)
  PRINTSTRING(", read ")
  PCH(CH)
  NEWLINE
  %STOP
%END

%ROUTINE MONITOR(%INTEGER SEVERE, %STRING(63) S)
   SELECTOUTPUT(REPORT)
   PRINTSYMBOL('*') %AND NERRORS=NERRORS+1 %IF SEVERE>WARNING
   PRINTSTRING(S)
   NEWLINE
   SELOUT(OUTSTREAM)
   %STOP %IF SEVERE=DISASTER
%END

%ROUTINE ZERO(%INTEGER NWORDS)
   !! ZERO the top NWORDS of the stack
   %INTEGER I,   P
   P=TOS
   %FOR I=1,1,NWORDS %CYCLE
      INTEGER(P)=0
      P=P+AUPW
   %REPEAT
%END

!! hashtable 
%CONSTINTEGER HASHTABLE LEN=127;   !! must be 2**N-1
%OWNINTEGERARRAY HASHTABLE(0:HASHTABLE LEN)=NULL(*)

!DIAGNOSTICS
!%ROUTINE PHEX(%INTEGER H)
!   ! routine to print a hexadecimal number
!   %INTEGER I,C
!   %FOR I=1,1,(BPW>>2) %CYCLE
!      C=H>>(BPW-4)
!      %IF C<10 %THEN C=C+'0' %ELSE C=C+'A'-10
!      PRINTSYMBOL(C)
!      H=H<<4
!   %REPEAT
!%END
!
!%ROUTINE DUMP STACK
!   ! dump the stack in hex format, 8-words to the line
!   ! followed by character equivalent
!   %INTEGER P,   I,   L,   Q,   END
!   %CONSTINTEGER MASK=(AUPW<<3)-1
!
!   %OWNBYTEINTEGERARRAY ASCII(0:127)='.'(32),
!   '.', '!','"','#','$','%','&', '''', '(',
!   ')', '*', '+', ',', '-', '.', '/', '0','1',
!   '2','3','4','5','6','7','8','9', ':', ';',
!    '<', '=', '>', '?', '@','A','B','C','D',
!   'E','F','G','H','I','J','K','L','M','N','O',
!   'P','Q','R','S','T','U','V','W','X','Y','Z',
!    '[', '^', ']', '^', '.', '.','a','b','c',
!   'd','e','f','g','h','i','j','k','l','m','n',
!   'o','p','q','r','s','t','u','v','w','x','y',
!   'z', '.'(5)
!
!   SELECTOUTPUT(DUMP)
!   P=ADDR(STACK(0));   END=TOS
!START:
!   Q=P
!   ! print the address
!   NEWLINE
!   PHEX(P); PRINTSYMBOL(':')
!   %WHILE P#END %CYCLE
!      %IF P&MASK=0 %START
!         SPACES(4)
!         ! output character equivalent of line
!         L=(((P-Q)>>LAUPW)<<LCPW)-1
!         %FOR I=0,1,L %CYCLE
!            PRINTSYMBOL(ASCII(BYTEINTEGER(Q+I)&127))
!         %REPEAT
!         Q=P
!         NEWLINE
!         ! and print the address again
!         PHEX(P); PRINTSYMBOL(':')
!      %FINISH
!      SPACE; PHEX(INTEGER(P))
!      P=P+AUPW
!   %REPEAT
!   NEWLINE
!   %IF END#STACKTOP<<LAUPW %START
!      END=STACKTOP<<LAUPW
!      P=BOS<<LAUPW
!      ->START
!   %FINISH
!   SELOUT(OUTSTREAM)
!%END
!DIAGNOSTIC END

%ROUTINE CLAIM(%INTEGER NWORDS)
!! claim NWORDS of the stack
   TOS=(TOS>>LAUPW)+NWORDS
   MONITOR(DISASTER,"Workspace full") %IF TOS>BOS
   MAXTOS=TOS %IF TOS>MAXTOS
   TOS=TOS<<LAUPW
%END

%STRING(255)%MAP READ STRING
   %STRING(255)%NAME S
   %INTEGER LEN,   I
!! read a string from the I-code and map it at the end of the stack
   READ(LEN);   RCH
   S==STRING((BOS-(LEN+CPW)>>LCPW)<<LAUPW)
   s = ""
   %FOR I=1,1,LEN %CYCLE
      RCH
      s = s.tostring(ch)
   %REPEAT
   %RESULT==S
%END

%ROUTINE SKIP STRING
   %STRING(255)%NAME DISCARD
   DISCARD==READ STRING
%END

%ROUTINE SKIP NUM
   %INTEGER DISCARD
   READ(DISCARD)
%END

%STRING(255)%MAP MAP STRING(%STRING(255) S)
   %STRING(255)%NAME N
   N==STRING((BOS-(LENGTH(S)+CPW)>>LCPW)<<LAUPW)
   N=S
   %RESULT==N
%END

%STRING(255)%MAP GET STRING
   %INTEGER CH
   %STRING(63) S
   s = ""
   %CYCLE
      READSYMBOL(CH)
   %REPEAT %UNTIL CH#' ' %AND CH#NL
   %CYCLE
      %IF 'a'<=CH<='z' %THEN CH=CH-'a'+'A'
      s = s.tostring(ch)
      READSYMBOL(CH)
   %REPEAT %UNTIL CH=' ' %OR CH=NL
   READSYMBOL(CH) %WHILE CH=' '
   %RESULT==MAP STRING(S)
%END

%RECORD(FTAG)%MAP STORE TAG(%STRING(255)%NAME S)
!! assume that S is already on the end of the stack
!! but that space has not yet been claimed for it
   %RECORD(FTAG)%NAME OLD,   NEW
   %INTEGER HASH,   I
   %INTEGERNAME H

   HASH=length(s)
   %FOR I=1,1,LENGTH(S) %CYCLE
      HASH=HASH+CHARNO(S,I)
   %REPEAT
   H==HASHTABLE(HASH&HASHTABLELEN)
   %WHILE H#NULL %CYCLE
      OLD==RECORD(H)
      %RESULT==OLD %IF OLD_S=S
      H==OLD_HNEXT
   %REPEAT
   !! create a new TAG
   BOS=BOS-TAGLEN-(LENGTH(S)+CPW)>>LCPW
   H=BOS<<LAUPW
   NEW==RECORD(H)
   NEW_HNEXT=0
   %RESULT==NEW
%END

%ROUTINE PRINT TAG(%RECORD(FTAG)%NAME TAG)
   PRINTSTRING(TAG_S) %UNLESS TAG==NULL TAG
%END

%OWNINTEGER STRINGLEN=-1

%ROUTINE GETCH
   READ(STRINGLEN) %AND RCH %IF STRINGLEN<0
   CH=END OF STRING %AND %RETURN %IF STRINGLEN=0
   RCH
   STRINGLEN=STRINGLEN-1
%END

%ROUTINE FLUSH
   GETCH %WHILE STRINGLEN>0
   STRINGLEN=-1
%END

%ROUTINE RNUM(%INTEGERNAME RESULT)
   %INTEGER SIGN,   N
   GETCH
   %IF CH='-' %THEN SIGN=-1 %AND GETCH %ELSE SIGN=1
   %RETURN %UNLESS '0'<=CH<='9'
   N=0
   %WHILE '0'<=CH<='9' %CYCLE
      N=N*10+CH-'0'
      GETCH
   %REPEAT
   N=-N %IF SIGN<0
   RESULT=N
%END

%STRING(255)%MAP SLOT PIN NAME(%INTEGER SUBNO, TNO)
   %RECORD(SLOTF)%NAME SLOT
   %RECORD(chippinf)%NAME PIN
   %RECORD(CHIPF)%NAME CHIP
   %RECORD(SLOTPINF)%NAME SLOTPIN
   %INTEGER F
   CHIP==CHIPLIST_CHIP(SUBNO)
   SLOT==CHIP_SLOT;   PIN==CHIP_PIN(TNO)
   %FOR F=1,1,SLOT_NT %CYCLE
      SLOTPIN==SLOT_PIN(F)
      %RESULT==SLOTPIN_NAME_S %IF SLOTPIN_PIN==PIN_name
   %REPEAT
   %RESULT==NULL STRING
%END

%RECORD(PACKPINF)%MAP PACK PIN OF(%INTEGER SUBNO, TNO, %integername index)
   %RECORD(CHIPF)%NAME CHIP
   %RECORD(chippinf)%NAME PIN
   %RECORD(PACKF)%NAME PACK
   %RECORD(PACKPINF)%NAME PACKPIN
   %INTEGER I
   CHIP==CHIPLIST_CHIP(SUBNO)
   PIN==CHIP_PIN(TNO)
   PACK==CHIP_PACK
   %FOR I=1,1,PACK_NT %CYCLE
      PACKPIN==PACK_PACKPIN(I)
      index = i %and %RESULT==PACKPIN %IF PACKPIN_NAME==PIN_name
   %REPEAT
   %RESULT==RECORD(NULL);   !! not found
%END

%STRING(63)%FN CHIP NAME(%RECORD(CHIPF)%NAME CHIP)
   %RESULT=CHIP_UNAME_S.":".CHIP_NAME_S
%END


!!*******************************************
!! routines to locate edges and slots       *
!!*******************************************

%RECORD(EDGEF)%MAP FIND EDGE(%INTEGER TNO)
   %RECORD(EDGEF)%NAME EDGE
   %RECORD(FTAG)%NAME TAG
   %STRING(63) MESSAGE
   TAG==TERMINALS_PIN(TNO)
   EDGE==EDGEH_LINK
   %WHILE %NOT EDGE==EDGEH %CYCLE
      %RESULT==EDGE %IF EDGE_PNAME==TAG
      EDGE==EDGE_LINK
   %REPEAT
   MESSAGE="Edge ".TAG_S." not found"
   MONITOR(ERROR,MESSAGE)
   %RESULT==EDGEH
%END

%RECORD(SLOTF)%MAP FINDSLOT(%RECORD(PACKF)%NAME PACK,
   %RECORD(FTAG)%NAME SLOTNAME)
   ! FIND THE SLOT CALLED SLOTNAME
   %RECORD(SLOTF)%NAME SLOT
   SLOT == PACK_SLOTS
   %WHILE %NOT SLOT==SLOTH %CYCLE
      %RESULT == SLOT %IF SLOT_NAME==SLOTNAME
      SLOT == SLOT_LINK
   %REPEAT
   MONITOR(ERROR,"Slot ".SLOTNAME_S." for ".PACK_NAME_S." not found")
   %RESULT == SLOTH
%END

%RECORD(PACKF)%MAP FIND PACK(%RECORD(FTAG)%NAME PACKNAME)
   !! find the pack called PACKNAME
   %RECORD(PACKF)%NAME PACK
   PACK==PACKH_LINK
   %WHILE %NOT PACK==PACKH %CYCLE
      %RESULT==PACK %IF PACK_NAME==PACKNAME
      PACK==PACK_LINK
   %REPEAT
   %RESULT==PACKH
%END


%routine printPack(%record(packf)%name pack)
   printstring(pack_name_s)
%end


%routine printChip(%record(chipf)%name chip)
   %unless chip_uname==record(null) %start
      printstring(chip_uname_s); printsymbol(':')
   %finish
   printstring(chip_name_s)
%end


%routine printSlot(%record(slotf)%name slot)
   printstring(slot_name_s)
   printstring(" (")
   printPack(slot_pack)
   printString(") at ")
   write(slot_x,0); printsymbol(':')
   write(slot_y,0)
%end


!!********************************************************
!! Actually perform the placement.  On entry to routine !!
!! PLACEMENT the lists of chips, packs and slots are    !!
!! used to decide on the placement.  On exit from the   !!
!! routine, the lists of slots have been destroyed but  !!
!! the list of chips has been recreated (not in the same!!
!! order as input) with each package placed in a slot   !!
!!********************************************************

%routine placement

%recordformat bindingf(%record(chipf)%name chip,
   %record(slotf)%name slot,dead,tried)
%constinteger bindinglen=4
%recordformat blistf(%record(bindingf)%array binding(1:1000))
%record(blistf)%name blist
%recordformat pinf(%record(pinf)%name link, %integer x,y)
%constinteger pinlen = 3
%recordformat pinlistf(%record(pinf)%namearray pin(1:1000))
%record(pinlistf)%name pinHead
%record(pinf)%name pinh == record(0)
%integer bindingn,oldtos,f,badchoice,backtracks
%record(chipf)%name chip
%record(edgef)%name edge
%record(slotf)%name slot
%record(packf)%name pack
%record(bindingf)%name binding
%integer j,n,pass,ceiling


%integerfn sign(%integer n)
   %result = 1 %if n>0
   %result = -1 %if n<0
   %result = 0
%end

%predicate overlap(%record(slotf)%name slot1,slot2,
   %record(packf)%name pack1,pack2)
!! true iff slots overlap and so conflict
   %false %if sign(slot1_x+pack1_xdim-slot2_x) * %c
              sign(slot1_x-(slot2_x+pack2_xdim)) >= 0
   %false %if sign(slot1_y+pack1_ydim-slot2_y) * %c
              sign(slot1_y-(slot2_y+pack2_ydim)) >= 0
   %true
%end


%routine pinToBoard(%integer net,x,y)
   %record(pinf)%name pin
   %return %if net=0
   %if tracing>=4 %start
      printstring("        Pin ")
      write(x,0); write(y,1); printstring("  (net ")
      write(net,0); printstring(")"); newline
   %finish
   pin == record(tos); claim(pinlen)
   pin_link == pinhead_pin(net)
   pinhead_pin(net) == pin
   pin_x = x; pin_y = y
%end


%routine pinFromBoard(%integer net)
   %record(pinf)%name pin
   %return %if net=0
   pin == pinHead_pin(net)
   %if tracing>=5 %start
      printstring("      Unpin ")
      write(pin_x,0); write(pin_y,1)
      printstring("  (net "); write(net,0)
      printstring(")"); newline
   %finish
   pinHead_pin(net) == pin_link
   tos = tos-(pinlen<<laupw)
   %if addr(pin)#tos %then monitor(disaster,"pin from board")
%end


%routine place(%record(chipf)%name which)
!! remove chip from list of those to be placed
   %record(chipf)%name chip,prev
   prev == chiph; chip == prev_link
   %while chip##which %cycle
      prev == chip; chip == chip_link
   %repeat
   prev_link == chip_link
%end


%routine unplace(%record(chipf)%name which)
!! put chip back on list of chips to be placed
   %record(chipf)%name chip
   which_link == chiph_link
   chiph_link == which
   chip == chiph_link
%end


%integerfn area(%record(packf)%namearrayname packs(1:1));  !*APM temp*
!
!! Calculates the total area remaining for placement of packs(1)
!! taking into account overlapping slots
!
   %record(slotf)%name slf,slg
   %integer total,f,nbits,plx,phx,ply,phy,gindex
   %recordformat bitf(%integer lx,ly,hx,hy)
   %record(bitf)%array bits(1:20)
   %record(bitf)%name bit

   %record(slotf)%map nextslot(%record(slotf)%name slot, %integername n)
      slot == slot_link %if slot##sloth
      %while slot==sloth %and n>1 %cycle
         n = n-1
         %if packs(n)##packh %then slot == packs(n)_slots
      %repeat
      %result == slot
   %end

   %routine order(%integername l,h)
      %integer t
      %if l>h %start
         t = l; l = h; h = t
      %finish
   %end

   %routine eliminate(%integer which)
      %integer f
      bits(f) = bits(f+1) %for f = which,1,nbits-1
      nbits = nbits-1
   %end

   %routine append(%integer lx,hx,ly,hy)
      %record(bitf)%name b
      order(lx,hx); order(ly,hy)
      nbits = nbits+1
      b == bits(nbits)
      b_lx = lx; b_hx = hx; b_ly = ly; b_hy = hy
   %end

   total = 0

! the outer loop runs calculates the area of the next slot
! which does not overlap any already considered
   slf == packs(1)_slots
   %while slf##sloth %cycle

! the inner loop compares the current slot with each already
! considered slot and breaks it up appropriately into bits
      nbits = 0; append(slf_x,slf_x+slf_pack_xdim,
            slf_y,slf_y+slf_pack_ydim)
      bit == bits(1)
      gindex = 4; slg == nextslot(sloth,gindex)
      %while slf##slg %and nbits>0 %cycle
         plx = slg_x; phx = slg_x+slg_pack_xdim
         ply = slg_y; phy = slg_y+slg_pack_ydim
         order(plx,phx); order(ply,phy)
         f = 1
         %while f<=nbits %cycle
            bit == bits(f)
            %if sign(phx-bit_lx)*sign(plx-bit_hx)>=0 %c
            %or sign(phy-bit_ly)*sign(ply-bit_hy)>=0 %c
            %then f = f+1 %c
            %else %start
               ! interference
               %if plx<=bit_lx %and phx>=bit_hx %start
                  ! x-coordinates bracket the bit
                  %if ply<=bit_ly %and phy>=bit_hy %c
                     %then eliminate(f) %else %start
                     %if ply>bit_ly %then bit_hy = ply
                     %if phy<bit_hy %then bit_ly = phy
                     f = f+1
                  %finish
               %finish %else %if ply<=bit_ly %and phy>=bit_hy %start
                  ! y-coordinates (but not x) bracket the bit
                  %if plx>bit_lx %then bit_hx = plx
                  %if phx<bit_hx %then bit_lx = phx
                  f = f+1
               %finish %else %start
                  ! complex interference requiring bit dismantling
                  %if ply<bit_ly %start
                     append(bit_lx,bit_hx,bit_ly,phy)
                     bit_ly = phy
                  %finish %else %start
                     append(bit_lx,bit_hx,ply,bit_hy)
                     bit_hy = ply
                  %finish
                  ! both bits now get reconsidered, one will reconflict
               %finish
            %finish
         %repeat
         slg == nextslot(slg,gindex)
      %repeat

! now total up the area remaining
      %for f = 1,1,nbits %cycle
         bit = bits(f)
         total = total+(bit_hx-bit_lx)*(bit_hy-bit_ly)
      %repeat

      slf == slf_link
   %repeat

   %result = total
%end

%record(bindingf)%map bindings(%integer n)
   %result==blist_binding(n)
%end


%predicate enoughroom(%record(packf)%name pack1,pack2,pack3,
   %integer extraArea, %integername newExtraArea, %integer fatal)
! checks up that there is room for packs 1,2,3   with extraArea
! being the (already known) area of packs 2 and 3.  newExtraArea
! gets set to the total area for all three (probably actually only
! one or two)
   %integer wanted,got
   %record(packf)%namearray packs(1:3)
   %record(packf)%name pack
   %integer f,a,max

   %routine force(%record(packf)%name pack)
      %if pack##packh %and pack_forced=0 %then pack_forced = bindingn
   %end

   %if pack1_needed>pack1_available %start
      %if tracing#0 %or fatal#0 %start
         write(pack1_needed,0); space
         printPack(pack1); printstring("s only have ")
         write(pack1_available,0); printstring(" slots")
         newline
      %finish
      %false
   %finish
   %true %if pass=1
   packs(1) == pack1
   packs(2) == pack2
   packs(3) == pack3
   wanted = 0; max = 0
   %for f = 1,1,3 %cycle
      pack == packs(f)
      %if pack##packh %start
         a = |pack_xdim*pack_ydim|
         max = a %if a>max
         wanted = wanted+a*pack_needed
      %finish
   %repeat
   got = area(packs)+extraArea
   newExtraArea = got
   %if wanted>got %then %start
      %if tracing#0 %or fatal#0 %start
         %for f = 1,1,3 %cycle
            pack == packs(f)
            %if pack##packh %start
               printstring("s & ") %if f#1
               write(pack_needed,0); space
               printPack(packs(f))
            %finish
         %repeat
         printstring("s need area of "); write(wanted,0)
         printstring(" but only have "); write(got,0)
         newline
      %finish
      %false
   %finish
   %if pack1_needed=pack1_available %start
      %if tracing>2 %and pack1_forced=0 %start
         printstring("Slot count forcing "); printPack(pack1); newline
      %finish
      force(pack1)
   %finish %else %if wanted>got-max %start
      force(pack1); force(pack2); force(pack3)
      %if tracing>2 %start
         printstring("Area forcing "); printPack(pack1)
         printstring(" & ") %and printPack(pack2) %if pack2##packh
         printstring(" & ") %and printPack(pack3) %if pack3##packh
         newline
      %finish
   %finish
   %true
%end


%routine bind(%record(chipf)%name chip, %record(slotf)%name slot)
!! bind chip to slot and remove any conflicting slots
   %record(bindingf)%name binding
   %record(slotf)%name oslot,nslot,nextslot
   %record(packf)%name pack,cpack
   %record(packf)%namearray marked(0:20)
   %integer nmarked,f,g,h,af,ag,ah,pno
   %record(packpinf)%name packpin
   binding == bindings(bindingn)
   binding_chip == chip
   binding_slot == slot
   chip_slot == slot
   cpack == chip_pack
   %if tracing#0 %start
      newline
      write(bindingn,4); printstring(":: ")
      printstring("Binding ")
      printChip(chip)
      printstring(" to ")
      printSlot(slot)
      %if chip_flags&constrained#0 %then printstring(" (constrained)")
      newline
   %finish
   cpack_needed = cpack_needed-1
   %for pno = 1,1,chip_nt %cycle
      packPin == cpack_packpin(chip_pin(pno)_packpin)
      pinToBoard(chip_pin(pno)_net,slot_x+packpin_x,slot_y+packpin_y)
   %repeat
   pack == packh_link
   %while %not pack==packh %cycle
      %if pack_needed>0 %start
         oslot == sloth
         nslot == pack_slots
         %while %not nslot==sloth %cycle
            %if overlap(slot,nslot,cpack,pack) %start
               !conflict - kill it
               pack_mark = 1 %if pack_needed#0
               pack_available = pack_available-1
               badchoice = yes %if pack_available<pack_needed
               %if oslot==sloth %then pack_slots == nslot_link %c
                   %else oslot_link  == nslot_link
               nextslot == nslot_link
               %unless nslot==slot %start
                  nslot_link == binding_dead
                  binding_dead == nslot
                  %if tracing>=2 %or %c
                     (tracing#0 %and chip_flags&constrained#0) %start
                     printstring("Slot ")
                     printSlot(nslot)
                     printstring(" killed by ")
                     printChip(chip)
                     newline
                  %finish
               %finish
               nslot == nextslot
            %else
               oslot == nslot; nslot == nslot_link
            %finish
         %repeat
      %finish
      pack == pack_link
   %repeat
   nmarked = 0
   pack == packh_link
   %while pack##packh %cycle
      %if pack_mark#0 %start
         pack_mark = 0
         %if nmarked=6 %start
            monitor(warning,"More than 6 conflict types")
            badchoice = yes %unless enoughRoom(pack,packh,packh,0,af,0)
         %else
            nmarked = nmarked+1; marked(nmarked) == pack
         %finish
     %finish
     pack == pack_link
   %repeat
   %for f = 1,1,nmarked %cycle
      badchoice = yes %and %return %unless %c
             enoughRoom(marked(f),packh,packh,0,af,0)
      %if pass#1 %start
         %for g = f+1,1,nmarked %cycle
            badchoice = yes %and %return %unless %c
               enoughRoom(marked(g),marked(f),packh,af,ag,0)
            %for h = g+1,1,nmarked %cycle
               badchoice = yes %and %return %unless %c
                  enoughRoom(marked(h),marked(g),marked(f),ag,ah,0)
            %repeat
         %repeat
      %finish
   %repeat
%end


%routine unbind(%record(bindingf)%name binding)
!! break a binding of a chip to a slot
   %integer pno
   %record(slotf)%name slot,nextslot
   %record(packf)%name pack
   %record(chipf)%name chip
   %integer dum
   %if tracing#0 %start
      printstring("Unbinding"); newline
   %finish
   chip == binding_chip
   %for pno = chip_nt,-1,1 %cycle
      pinFromBoard(chip_pin(pno)_net)
   %repeat
   binding_slot_link == binding_tried
   binding_tried == binding_slot
   slot == binding_dead
   %while %not slot==sloth %cycle
      pack == slot_pack
      nextslot == slot_link
      slot_link == pack_slots
      pack_slots == slot
      pack_available = pack_available+1
      slot == nextslot
   %repeat
   pack == chip_pack
   pack_needed = pack_needed+1
   binding_dead == sloth
   chip_slot == sloth
   %unless enoughroom(pack,packh,packh,0,dum,0) %then badchoice = yes
%end


%routine backtrack(%record(bindingf)%name binding)
   !prepare to backtrack to retry previos binding
   ! reinstate all dead and tried slots
   %record(slotf)%name slot,nextslot
   %record(packf)%name pack
   %if tracing#0 %start
      printstring("Backtracking"); newline
   %finish
   backtracks = backtracks+1
   unplace(binding_chip)
   pack == binding_chip_pack
   slot == binding_tried
   %while %not slot==sloth %cycle
      pack_available = pack_available+1
      nextslot == slot_link
      slot_link == pack_slots
      pack_slots == slot
      slot == nextslot
   %repeat
   binding_tried == sloth
%end


%routine initialcheck
   %integer f,g,h,npacks,af,ag,ah
   %constinteger maxpack = 20
   %record(packf)%namearray packs(1:maxpack)
   %record(packf)%name pack
   npacks = 0
   pack == packh_link
   %while pack##packh %cycle
      %if pack_needed#0 %start
         %if tracing>=2 %start
            write(pack_needed,0); space
            printPack(pack)
            printsymbol('s') %if pack_needed#1
            newline
         %finish
         %if npacks<maxpack %start
             npacks = npacks+1
             packs(npacks) == pack
         %else
             monitor(warning,"More pack types than desirable")
         %finish
      %finish
      pack == pack_link
   %repeat
   %return %if pass=1
   %for f = 1,1,npacks %cycle
      nerrors = nerrors+1 %unless enoughRoom(packs(f),packh,packh,0,af,1)
      %for g = f+1,1,npacks %cycle
         nerrors = nerrors+1 %unless enoughRoom(packs(g),packs(f),packh,af,ag,1)
         %for h = g+1,1,npacks %cycle
            nerrors = nerrors+1 %unless enoughroom(packs(f),packs(g),packs(h),
                                                   ag,ah,1)
         %repeat
      %repeat
   %repeat
%end


%integerfn manhattan(%integer x1,y1,x2,y2)
   %integer d
   d=|x1-x2|+|y1-y2|
   d=(d<<7)//distscale
   d=(d*d)>>7 %if metric=quadratic
   %result=d
%end



%integerfn nearest(%record(pinf)%name pin, %integer x,y)
   %integer min, this
   min = maxinteger
   %while pin##pinh %cycle
      this = manhattan(x,y,pin_x,pin_y)
      %if this<min %then min = this
      pin == pin_link
   %repeat
   %result = min
%end


%record(slotf)%map choose(%record(chipf)%name chip)
   %record(slotf)%name slot, best
   %record(packf)%name pack
   %record(pinf)%name pin
   %integer sx,sy,x,y,tot,max,pn,pn2,pnpin,pn2pin,net
   %integerarray d(1:300)
   slot == chip_pack_slots; max = maxinteger
   pack == chip_pack
   %while %not slot==sloth %cycle
      sx = slot_x; sy = slot_y
      tot = 0
      %for pn = 1,1,chip_nt %cycle
         d(pn) = 0
         net = chip_pin(pn)_net
         %continue %if net=0;   !not connected
         pin == pinHead_pin(net)
         %continue %if pin==pinh; !net entirely offboard
         pnpin = chip_pin(pn)_packpin
         x = sx+pack_packpin(pnpin)_x
         y = sy+pack_packpin(pnpin)_y
         d(pn) = nearest(pin,x,y)
         %for pn2 = 1,1,pn-1 %cycle
            %if net=chip_pin(pn2)_net %start
               %if d(pn2)<d(pn) %start
                  tot = tot-d(pn2)
                  d(pn) = d(pn2)
                  d(pn2) = maxinteger
               %finishelse %if d(pn2)#maxinteger %start
                  tot = tot-d(pn2)
                  d(pn2) = maxinteger
               %finish
            %finish
         %repeat
         tot = tot+d(pn)
      %repeat
      %if tot<max %start
         max = tot; best == slot
      %finish
      slot == slot_link
   %repeat
   %result == best
%end


%record(chipf)%map nextToPlace
   %integer mratio,onval,offval,forcing,f,net,g,ratio
   %integer win1,win2,win3
   %real xsum,xsumsq,ysum,ysumsq
   %record(packf)%name pack
   %record(chipf)%name chip,winner
   %record(pinf)%name pin
   chip == chiph_link
   mratio = -1
   forcing = 0
   %while chip##chiph %cycle
      pack == chip_pack
      pack_forced = 0 %if pack_forced>bindingn
      %if pack_forced#0 %or forcing=0 %start
         onVal = 0; offVal = 0
         xsum = 0; ysum = 0; xsumsq = 0; ysumsq = 0
         %for f = 1,1,chip_nt %cycle
            net = chip_pin(f)_net
            %if net#0 %start
               %for g = 1,1,f-1 %cycle
                   -> duplicated %if chip_pin(g)_net=net
               %repeat
               pin == pinHead_pin(net)
               %if pin==pinh %start
                  offVal = offVal+1
               %else
                  onVal = onVal+1
                  g = pin_x; xsum = xsum+g; xsumsq = xsumsq+(g*g)
                  g = pin_y; ysum = ysum+g; ysumsq = ysumsq+(g*g)
               %finish
            %finish
   duplicated:
         %repeat
         ratio = 0
         %if onval#0 %start
            xsum = xsum/onVal; xsum = (xsum*xsum)
            ysum = ysum/onVal; ysum = (ysum*ysum)
            xsum = (xsumsq*((onVal+offVal)//onVal)-xsum)/onVal
            ysum = (ysumsq*((onVal+offVal)//onVal)-ysum)/onVal
            xsum = (xsum*5000)/(boardxdim*boardxdim)
            ysum = (ysum*5000)/(boardydim*boardydim)
            f = intpt(xsum+ysum); !varies from 0 to 10000
            f = 1 %if f=0;        !to prevent division by zero
            ratio = (onVal*onVal*10000)//f
         %finish
         %if (forcing=0 %and pack_forced#0) %or ratio>mratio %start
             forcing = pack_forced
             mratio = ratio
             winner == chip
             win1 = onval; win2 = f; win3=offval
         %finish
      %finish
      chip == chip_link
   %repeat
   %if tracing>=3 %start
      printstring("Choosing "); printPack(winner_pack); space
      printChip(winner)
      printstring("  (desirability="); write(mratio,0)
      printstring(")")
space; printstring("on=");write(win1,0); printstring(" var=");write(win2,0)
printstring(" off="); write(win3,0)
      %if forcing#0 %then printstring(" * forced *")
      newline
   %finish
   place(winner)
   %result == winner
%end


! initialise pinheads
   pinHead == record(tos); zero(netNumber); claim(netNumber)

! pre-place edge connectors now
   edge == edgeh_link
   %while %not edge==edgeh %cycle
      %for f = 1,1,edge_nt %cycle
         pinToBoard(edge_net,edge_pin(f)_x,edge_pin(f)_y)
      %repeat
      edge == edge_link
   %repeat

! initialise binding arrays
   pass = 1
   oldtos = tos
   blist==record(tos)
   chip == chiph_link
   %while %not chip==chiph %cycle
      binding==record(tos);   claim(bindinglen)
      binding_dead == sloth
      binding_tried == sloth
      binding_chip == chip
      chip == chip_link
   %repeat
   bindingn = 1
   badchoice = no; backtracks = 0
   chip == chiph_link

! place the constrained chips and those with only one choice
   %cycle
      chip == chiph_link
      %while chip##chiph %cycle
         pack == chip_pack
         %exit %if chip_flags&constrained#0
         %if pack_needed=1=pack_available %start
            chip_slot == pack_slots
            %exit
         %finish
         chip == chip_link
      %repeat
      %exit %if chip==chiph; !no more constrained
      %if chip_flags&atf#0 %then chip_slot == findslot(chip_pack,chip_at)
      place(chip)
      bind(chip,chip_slot)
      monitor(disaster,"Constraints preclude placement") %if badchoice=yes
      ->  done %if bindingn=boardnsubs
      bindingn = bindingn+1
   %repeat
   ceiling = bindingn

! reentry point in the event that fast placement fails
slowly:
   %if pass#1 %start
      %cycle
         unbind(bindings(bindingn))
         backtrack(bindings(bindingn))
         %exit %if bindingn=ceiling
         bindingn = bindingn-1
      %repeat
      monitor(warning,"Fast and dirty technique fails")
      badchoice = no
      backtracks = 0
   %finish

! check that a placement is possible in the first place
! also sets up stuff ready for selecting order
   initialcheck
   monitor(disaster,"No placement possible") %if nerrors#0

! do the real work of placement
chip == nextToPlace
%cycle
   bindings(bindingn)_chip == chip

   %if attention %start
      printstring("* Placement so far"); newline
      %for f = 1,1,bindingn-1 %cycle
         printChip(bindings(f)_chip); printString(" at ")
         printSlot(bindings(f)_slot); newLine
      %repeat
      printstring("Trying ")
      printChip(chip); newline
   %finish

   badchoice = yes
   %unless chip_pack_slots==sloth %start
      badchoice = no
      bind(chip,choose(chip))
      %if badchoice=yes %start
         pass = 2 %and -> slowly %if pass=1
         badchoice = no
         unbind(bindings(bindingn))
         ! may reset badchoice to yes
      %else
         %exit %if bindingn=boardnsubs
         bindingn = bindingn+1
         chip == nextToPlace
      %finish
   %finish
   %while badchoice=yes %cycle
      badchoice = no
      backtrack(bindings(bindingn))
      bindingn = bindingn-1
      %if bindingn=0 %or %c
         %not bindings(bindingn)_chip_at==null tag %then %c
            monitor(disaster,"No placement possible")
      unbind(bindings(bindingn))
      chip == bindings(bindingn)_chip
   %repeat
%repeat

!put everything in its place of abode
!and relink the list of chips
%for f = 1,1,boardnsubs %cycle
   binding == bindings(f)
   chip == binding_chip; slot == binding_slot
   chip_slot==slot
   chip_x = slot_x; chip_y = slot_y
   !! in case we are using slots that do
   !! not correspond to CHIP_ON
   chip_pack==find pack(chip_on)
   chip_link == chiph_link; chiph_link == chip
%repeat
done:
tos=oldtos
selectoutput(report)
printstring("Placement completed with "); write(backtracks,0)
printstring(" backups"); newline
selectoutput(outstream)
%end

!!***************************************************
!! routines for outputting the board                *
!!***************************************************

%STRING(63)%FN PIN COORDS(%RECORD(CHIPF)%NAME CHIP,
                          %STRING(255)%NAME PIN)
   %INTEGER P, X, Y
   %RECORD(PACKF)%NAME PACK
   %RECORD(PACKPINF)%NAME PACKPIN
   PACK==CHIP_PACK
   X=CHIP_SLOT_X;   Y=CHIP_SLOT_Y
   %FOR P=1,1,PACK_NT %CYCLE
      PACKPIN==PACK_PACKPIN(P)
      %IF PACKPIN_NAME_S=PIN %THEN %RESULT=CTOS(X+PACKPIN_X,Y+PACKPIN_Y)
   %REPEAT
   %RESULT=NULL STRING
%END

%ROUTINE PUT PARMS(%RECORD(CHIPF)%NAME CHIP, %INTEGERNAME PNO,
                                             %INTEGER MPNO)
   %OWNINTEGERARRAY P(1:MAX PARMS)=AT,NULL,NULL,NULL,NULL,NULL,SIZE,PLACE
   %INTEGER I, PN
   %STRING(255) S
   %RECORD(PACKF)%NAME PACK
   %RECORD(SLOTF)%NAME SLOT
   PACK==CHIP_PACK;   SLOT==CHIP_SLOT
   %FOR I=PNO+1,1,MPNO %CYCLE
      PN=P(I)
      %CONTINUE %IF PN=NULL
      PCH(CNTRL+'P'); SPNUM(I)
      %IF PN=AT %START
         PUT TAG(SLOT_NAME)
      %FINISH %ELSE %IF PN=SIZE %START
         S=CTOS(PACK_XDIM,PACK_YDIM)
         PUT STRING(S)
      %FINISH %ELSE %IF PN=PLACE %START
         S=CTOS(SLOT_X,SLOT_Y)
         PUT STRING(S)
      %FINISH
   %REPEAT
   PNO=MPNO %IF PN#NULL
%END

%ROUTINE UNWIRE(%INTEGER SUBNO, TNO, %STRING(255)%NAME NETNAME)
   %RECORD(SLOTF)%NAME SLOT
   %STRING(255)%NAME PIN NAME
   %STRING(63) COORDS
   %RECORD(PACKPINF)%NAME PACKPIN
   %integer dummy

%ROUTINE MESSAGE
   PRINTSTRING("*Unwire ")
   PRINTSTRING(PIN NAME)
   PRINTSTRING(" from ")
   PRINT TAG(SLOT_NAME);   PRINTSYMBOL('.')
   PRINT TAG(PACKPIN_NAME)
   SPACE
   PRINTSYMBOL('(')
   PRINTSTRING(COORDS)
   PRINTSYMBOL(')')
   %IF NETNAME==NULL STRING %START
      PRINTSTRING(", unused")
   %ELSE
      PRINTSTRING(", replaced by ")
      PRINTSTRING(NETNAME)
   %FINISH
   NEWLINE
%END

   SLOT==CHIPLIST_CHIP(SUBNO)_SLOT
   PACKPIN==PACK PIN OF(SUBNO,TNO,dummy)
   PIN NAME==SLOT PIN NAME(SUBNO,TNO)
   COORDS=CTOS(PACKPIN_X+SLOT_X,PACKPIN_Y+SLOT_Y)
   SELECTOUTPUT(REPORT);   MESSAGE
   SELECTOUTPUT(BMODS);    MESSAGE
   SELECTOUTPUT(OUTSTREAM)
%END

!!***************************************
!!       mainline variables             *
!!***************************************

%INTEGER TYPE,   PNO,   SUBNO,   TNO, index
%INTEGER I,   REFS,   NT,   PINS
%STRING(255)%NAME PIN,   PACKNAME,   NAME
%RECORD(CHIPF)%NAME CHIP
%RECORD(PACKF)%NAME PACK,   ALT PACK
%RECORD(SLOTPINF)%NAME SLOTPIN
%RECORD(PACKPINF)%NAME PACKPIN
%RECORD(FTAG)%NAME TAG

%INTEGER ENT,   NSLOTS,   NEW SLOTS
%RECORD(EDGEF)%NAME EDGE,   TAIL
%RECORD(SLOTF)%NAME SLOT, newSlot
%RECORD(COORDF)%NAME COORD

%INTEGER F, oldtos
%BYTEINTEGERNAME N
%string(255)%name netname
%integer only, onlys

%STRING(63) S
%STRING(255)%NAME PARM
%RECORD(NETF)%NAME TNET
%RECORD(FFANEL)%NAME FAN
%RECORD(FTAG)%NAME USED

!!****************************************************
!!      MAINLINE CODE FOR PLACE                      *
!!****************************************************

!! initialisation
TOS=ADDR(STACK(0));   MAXTOS=(TOS>>LAUPW)
STACKTOP=ADDR(STACK(STACKLEN))>>LAUPW;   BOS=STACKTOP+1
NULL STRING==MAP STRING("")
NULL TAG==RECORD(NULL);   EMPTY TAG==STORE TAG(NULL STRING)

!! output heading and promt for METRIC
RETURN CODE=DEF STREAMS(CLIPARAM,DEFAULTS)
->DONE %UNLESS RETURN CODE=1
SELOUT(REPORT);   SELIN(REPORT)
PRINTSTRING(HEADING);   NEWLINE;   NEWLINE
PRINTSTRING("Linear or Quadratic distance metric ?"); NEWLINE
PROMPT("Metric=")
%CYCLE
   READSYMBOL(CH)
   %if '0'<=ch<='9' %then tracing = ch-'0' %and ch = ' '
%REPEAT %UNTIL CH#' ' %AND CH#NL
METRIC=LINEAR
%IF CH='q' %OR CH='Q' %THEN METRIC=QUADRATIC
READSYMBOL(CH) %UNTIL CH=NL
NEWLINE

!! build heads of circular lists (dummies)
CHIPH==RECORD(TOS); ZERO(CHIPLEN); CLAIM(CHIPLEN); CHIPH_LINK==CHIPH
SLOTH==RECORD(TOS); ZERO(SLOTLEN); CLAIM(SLOTLEN); SLOTH_LINK==SLOTH
PACKH==RECORD(TOS); ZERO(PACKLEN); CLAIM(PACKLEN); PACKH_LINK==PACKH
EDGEH==RECORD(TOS); ZERO(EDGELEN); CLAIM(EDGELEN); EDGEH_LINK==EDGEH

!!***************************************
!! read in the circuit to be placed     *
!!***************************************

SELIN(CIRCUIT)
RCH
SKIP NUM %AND RCH %IF CH=CNTRL+'S'
CHECK(CNTRL+'U')
SKIP NUM
RCH
SKIPNUM;   SKIPNUM;   SKIPNUM;   READ(I);   !! NIO

READ(NT);   CIRCUITNT=NT-I
SKIP STRING
CIRCUIT NAME==STORE TAG(READ STRING)

TERMINALS==RECORD(TOS);   CLAIM(CIRCUITNT)

TNO=0
%FOR I=1,1,NT %CYCLE
   RCH
   READ(TYPE)
   TAG==STORE TAG(READ STRING);   !! the pin name
   NAME==READ STRING
   %IF TYPE&INOUT#DUMMY %START
      TNO=TNO+1
      TERMINALS_PIN(TNO)==TAG
      MONITOR(ERROR,"No edge connector for ".NAME) %IF TAG==EMPTY TAG
   %FINISH
%REPEAT

RCH;   BOARDNAME==NULL TAG
%WHILE CH=CNTRL+'P' %CYCLE
   READ(PNO)
   %IF PNO=ON %START
      BOARDNAME==STORE TAG(READ STRING)
   %ELSE
      SKIP STRING
   %FINISH
   RCH
%REPEAT
RCH;   !! skip ^G

!! Should be at the subinstances - fail if still hierarchical
CHECK(CNTRL+'J')
%IF BOARDNAME==NULL TAG %START
   SELOUT(REPORT);   SELIN(REPORT)
   PRINTSTRING("Board name missing");   NEWLINE
   PROMPT("Board name=")
   BOARDNAME==STORE TAG(GET STRING)
   NEWLINE
   SELIN(CIRCUIT)
%FINISH

!!***************************************
!!    read in the list of chips         *
!!***************************************

READ(BOARDNSUBS)
CHIPLIST==RECORD(TOS);   CLAIM(BOARDNSUBS)
%FOR SUBNO=1,1,BOARDNSUBS %CYCLE
   !! read in the chips
   CHIP==RECORD(TOS);   ZERO(CHIPLEN);   CLAIM(CHIPLEN)
   CHIPLIST_CHIP(SUBNO)==CHIP
   CHIP_LINK==CHIPH_LINK;   CHIPH_LINK==CHIP
   RCH;   CHECK(CNTRL+'H')
   SKIPNUM;   SKIPNUM;   SKIPNUM;   SKIPNUM;
   READ(CHIP_NT)
   CHIP_UNAME==STORE TAG(READ STRING)
   CHIP_NAME==STORE TAG(READ STRING)
   CHIP_NUM=SUBNO
   CHIP_PACK==PACKH
   CHIP_SLOT==SLOTH

   PINS=1
   %FOR TNO=1,1,CHIP_NT %CYCLE
      RCH
      SKIPNUM
      TAG==STORE TAG(READ STRING)
      CHIP_PIN(TNO)_name==TAG
      chip_pin(tno)_net = 0
      PINS=0 %IF TAG==EMPTY TAG
      SKIP STRING
      CLAIM(chippinlen)
   %REPEAT
   MONITOR(ERROR,"PINS not specified for ".CHIP NAME(CHIP)) %C
      %IF PINS=0

   RCH
   %WHILE CH=CNTRL+'P' %CYCLE
      READ(PNO)
      %IF PNO=ON %START
         CHIP_ON==STORE TAG(READ STRING)
      %FINISH %ELSE %IF PNO=AT %START
         CHIP_AT==STORE TAG(READ STRING)
         CHIP_FLAGS=CHIP_FLAGS!ATF
      %FINISH %ELSE %IF PNO=PLACE %START
         RNUM(CHIP_X);   RNUM(CHIP_Y);   FLUSH
         CHIP_FLAGS=CHIP_FLAGS!PLACEF
      %ELSE
         SKIP STRING
      %FINISH
      RCH
   %REPEAT
%REPEAT

!!*****************************************
!! read in the package descriptions and   *
!! store those that have been referenced  *
!!*****************************************

SELIN(PACKAGES)
%CYCLE
   RCH
   %EXIT %IF CH=END OF FILE
   SKIP NUM %AND RCH %IF CH=CNTRL+'S'
   CHECK(CNTRL+'U')
   SKIPNUM;   !! skip type
   RCH;       !! skip ^H
   SKIPNUM %FOR I=1,1,4
   READ(NT)
   SKIP STRING
   PACKNAME==READ STRING
   REFS=0
   %FOR SUBNO=1,1,BOARDNSUBS %CYCLE
      TAG==CHIPLIST_CHIP(SUBNO)_ON
      %CONTINUE %IF TAG==NULL TAG %OR TAG_S#PACKNAME
      REFS=REFS+1
   %REPEAT
   ->UNWANTED %IF REFS=0

   !! allocate another pack
   PACK==RECORD(TOS);   ZERO(PACKLEN);   CLAIM(PACKLEN+PACKPINLEN*NT)
   PACK_LINK==PACKH_LINK;   PACKH_LINK==PACK
   PACK_NAME==STORE TAG(PACKNAME)
   PACK_NEEDED=REFS
   PACK_SLOTS==SLOTH
   PACK_NT=NT

   %FOR TNO=1,1,NT %CYCLE
      PACKPIN==PACK_PACKPIN(TNO)
      RCH
      SKIPNUM
      RNUM(PACKPIN_X);   RNUM(PACKPIN_Y);   FLUSH
      PACKPIN_NAME==STORE TAG(READ STRING)
   %REPEAT

   !! Read the SIZE
   RCH
   %WHILE CH=CNTRL+'P' %CYCLE
      READ(PNO)
      %IF PNO=SIZE %START
         RNUM(PACK_XDIM);   RNUM(PACK_YDIM);   FLUSH
      %ELSE
         SKIP STRING
      %FINISH
      RCH
   %REPEAT
UNWANTED:
   SKIP TO(CNTRL+'E')
%REPEAT

!!*********************************************
!! check that each chip has a pack to live on *
!!*********************************************

%FOR SUBNO=1,1,BOARDNSUBS %CYCLE
   CHIP==CHIPLIST_CHIP(SUBNO)
   %IF CHIP_ON==NULL TAG %START
      MONITOR(ERROR,"No package specified for ".CHIP_NAME_S)
   %ELSE
      CHIP_PACK==FIND PACK(CHIP_ON)
      %IF CHIP_PACK==PACKH %START
         MONITOR(ERROR,CHIP_ON_S." not in package library")
      %ELSE
         !! check that all pins have valid names
         %FOR TNO=1,1,CHIP_NT %CYCLE
            PACKPIN==PACK PIN OF(SUBNO,TNO,index)
            %IF PACKPIN==RECORD(NULL) %START
               !! pin not found
               PIN==CHIP_PIN(TNO)_name_S
               MONITOR(ERROR,"Pin ".PIN." of ".CHIP NAME(CHIP). %C
                  " not on ".PACK_NAME_S)
            %else
                chip_pin(tno)_packpin = index
            %FINISH
         %REPEAT
      %FINISH
   %FINISH
%REPEAT

!!********************************************
!!      now read in the board                *
!!********************************************

SELIN(BOARDS)
%CYCLE
   RCH
   SKIP NUM %AND RCH %IF CH=CNTRL+'S'
   MONITOR(DISASTER,"Board ".BOARDNAME_S." not found") %IF CH=END OF FILE
   READ(TYPE)
   MONITOR(WARNING,"Invalid BOARD in board library") %C
      %UNLESS TYPE=BOARDTYPE
   RCH;   SKIP NUM
   READ(BIN);   READ(BOUT);   READ(BIO);   READ(BOARDNT)
   SKIP STRING
   %EXIT %IF READ STRING=BOARDNAME_S
   SKIP TO(CNTRL+'E')
%REPEAT

!!***************************************
!! found the board - now read in the    *
!! edge connector information           *
!!***************************************

TAIL==EDGEH
%FOR I=1,1,BOARDNT %CYCLE
   RCH
   EDGE==RECORD(TOS);   ZERO(EDGELEN);   CLAIM(EDGELEN)
   TAIL_LINK==EDGE;   EDGE_LINK==EDGEH;   TAIL==EDGE
   READ(EDGE_INFO)
   !! now get list of pin coordinates for the edge connector
   ENT=0
   %CYCLE
      ENT=ENT+1;   !! no of coord pairs for edge
      COORD==EDGE_PIN(ENT)
      RNUM(COORD_X);   RNUM(COORD_Y)
      claim(edgelen)
   %REPEAT %UNTIL CH#'+'
   FLUSH
   EDGE_NT=ENT
   EDGE_PNAME==STORE TAG(READ STRING)
%REPEAT

!!***********************************
!! get the board SIZE               *
!!***********************************

BPARM(I)==NULL TAG %FOR I=1,1,MAX PARMS
BOARDXDIM=MININTEGER;   BOARDYDIM=MININTEGER
RCH
%WHILE CH=CNTRL+'P' %CYCLE
   READ(PNO)
   %IF PNO=SIZE %START
      RNUM(BOARDXDIM);   RNUM(BOARDYDIM);   FLUSH
      BPARM(SIZE)==STORE TAG(MAP STRING(CTOS(BOARDXDIM,BOARDYDIM)))
   %ELSE
      BPARM(PNO)==STORE TAG(READ STRING)
   %FINISH
   RCH
%REPEAT
MONITOR(ERROR,"Board SIZE missing") %IF BOARDXDIM=MININTEGER %C
                                      %OR BOARDYDIM=MININTEGER

!!*******************************************
!! set the distance scale for MANHATTAN     *
!!*******************************************

DISTSCALE=|BOARDXDIM|
%IF |BOARDYDIM|>DISTSCALE %THEN DISTSCALE=|BOARDYDIM|


!!*********************************
!! read the slot positions        *
!!*********************************

RCH
CHECK(CNTRL+'J')
READ(NSLOTS)
%FOR SUBNO=1,1,NSLOTS %CYCLE
   RCH;   READ(NT) %FOR I=1,1,5
   TAG==STORE TAG(READ STRING);   !! unique name
   PACKNAME==READ STRING
   !! find the named pack
   PACK==PACKH_LINK
   %WHILE %NOT PACK==PACKH %CYCLE
      %EXIT %IF PACK_NAME_S=PACKNAME
      PACK==PACK_LINK
   %REPEAT
   !! if found the named pack, then keep the slot
   %UNLESS PACK==PACKH %START
      PACK_AVAILABLE=PACK_AVAILABLE+1
      SLOT==RECORD(TOS);   ZERO(SLOTLEN);   CLAIM(SLOTLEN+NT*SLOTPINLEN)
      SLOT_LINK==PACK_SLOTS;   PACK_SLOTS==SLOT
      SLOT_PACK==PACK
      SLOT_NAME==TAG
      SLOT_NT=NT
      %FOR I=1,1,NT %CYCLE
         SLOTPIN==SLOT_PIN(I)
         RCH;   SKIP NUM;   !! skip ^T and INFO
         TAG==STORE TAG(READ STRING);   !! pin name
         SLOTPIN_NAME==STORE TAG(READ STRING);   !! signal name
         !! get logical signal number of pin
         %FOR TNO=1,1,PACK_NT %CYCLE
            PACKPIN==PACK_PACKPIN(TNO)
            %CONTINUE %UNLESS PACKPIN_NAME==TAG
            SLOTPIN_PIN==TAG
            ->NEXT PIN
         %REPEAT
         MONITOR(ERROR,"Prewired pin ".TAG_S." of ".SLOT_NAME_S. %C
            " not on ".PACK_NAME_S)
NEXT PIN:
      %REPEAT

      !! get the position of the slot
      RCH
      %WHILE CH=CNTRL+'P' %CYCLE
         READ(PNO)
         %UNLESS PACK==PACKH %START
            %IF PNO=AT %START
               RNUM(SLOT_X);   RNUM(SLOT_Y);   FLUSH
            %FINISH %ELSE %IF PNO=VALUE %START
               RNUM(SLOT_PRIORITY);   FLUSH
            %ELSE
               SKIP STRING
            %FINISH
         %ELSE
            SKIP STRING
         %FINISH
         RCH
      %REPEAT
   %ELSE
      SKIP TO(CNTRL+'G');   !! get to end of slot description
   %FINISH
%REPEAT

!!********************************************
!! give up if too many errors to proceed     *
!!********************************************

MONITOR(DISASTER,"Placement abandoned") %IF NERRORS>0

!!**************************************************
!! check that we have slots for all the pack types *
!! and create slots for chips that have positions  *
!! but no referenced slot (PLACEd but no AT)       *
!!**************************************************

NEW SLOTS=0
%FOR SUBNO=1,1,BOARDNSUBS %CYCLE
   CHIP==CHIPLIST_CHIP(SUBNO)
   %CONTINUE %UNLESS CHIP_FLAGS&CONSTRAINED=PLACEF
   !! placed, but with no AT
   PACK==CHIP_PACK;   !! each CHIP has one by now
   PACK_AVAILABLE=PACK_AVAILABLE+1
   NEW SLOTS=NEW SLOTS+1
   SLOT==RECORD(TOS);   ZERO(SLOTLEN);   CLAIM(SLOTLEN)
   SLOT_LINK==PACK_SLOTS;   PACK_SLOTS==SLOT
   SLOT_PACK==PACK
   SLOT_NAME==STORE TAG(MAP STRING("New".ITOS(NEW SLOTS,0)))
   SLOT_X=CHIP_X;   SLOT_Y=CHIP_Y;   SLOT_PRIORITY=1000
   CHIP_SLOT==SLOT
%REPEAT

SELIN(REPORT)
PACK==PACKH_LINK
%WHILE %NOT PACK==PACKH %CYCLE
   ->NEXT PACK %IF PACK_AVAILABLE>0
   TAG==PACK_NAME
   %CYCLE
      PRINTSTRING("No slots available for ")
      PRINTTAG(TAG);   NEWLINE
      PROMPT("Use ")
      TAG==STORE TAG(GET STRING)
      ->NEXT PACK %IF TAG_S=""
      ALT PACK==FIND PACK(TAG)
      %EXIT %UNLESS ALT PACK==PACKH;   !! not found
   %REPEAT
   NEWLINE
   slot == altPack_slots
   pack_slots == sloth
   %while slot##sloth %cycle
      pack_available = pack_available+1
      newSlot == record(tos)
      claim(slotlen)
      newSlot_link == pack_slots; pack_slots == newSlot
      newSlot_pack == pack
      newSlot_name == slot_name
      newSlot_x = slot_x; newSlot_y = slot_y
      newSlot_priority = slot_priority
      newSlot_nt = 0; !discard all prewired terminals
      slot == slot_link
   %repeat
NEXT PACK:
   PACK==PACK_LINK
%REPEAT

!!************************************************
!! read the connection nets                      *
!!************************************************

netNumber = 0

SELIN(CIRCUIT)
RCH
%WHILE CH=CNTRL+'N' %CYCLE
   netNumber = netNumber+1
   only = 0
   RCH
   %WHILE CH=CNTRL+'A' %CYCLE
      NETNAME==READ STRING
      READ(NT)
      %FOR F=1,1,NT %CYCLE
         READ(SUBNO);   READ(TNO)
         %if only=0 %then only = 1 %and onlys = subno %c
         %else %if only=1 %and onlys#subno %then only = 2
         %IF SUBNO=0 %START
            EDGE==FIND EDGE(TNO)
            %UNLESS EDGE==EDGEH %START
               edge_net = netNumber
               EDGE_NAME==STORE TAG(NETNAME)
            %FINISH
         %ELSE
            NAME==SLOT PIN NAME(SUBNO,TNO)
            %if name##netname %then %c
               chiplist_chip(subno)_pin(tno)_net = netNumber
         %FINISH
      %REPEAT
      RCH
   %REPEAT
   %if only#2 %and onlys#0 %start
      ! net is internal to a subinstance, so remove it
      chip == chiplist_chip(onlys)
      %for f = 1,1,chip_nt %cycle
         %if chip_pin(f)_net=netNumber %then chip_pin(f)_net = 0
      %repeat
   %finish
%REPEAT

SKIP TO(CNTRL+'E')
RCH
CHECK(END OF FILE)


!!****************************************
!! now decide in what order to place the *
!! chips, and then place them.           *
!!****************************************

MONITOR(DISASTER,"Placement abandoned") %IF NERRORS>0
MONITOR(WARNING,"Commencing placement")
PLACEMENT

!!****************************************
!! and finally produce the I-code output *
!!****************************************

SELOUT(MOUT)
PCH(CNTRL+'S'); PNUM(3)
PCH(CNTRL+'U'); PNUM(BOARDTYPE)
PCH(CNTRL+'H'); SPNUM(0)
SPNUM(BIN); SPNUM(BOUT); SPNUM(BIO); SPNUM(BOARDNT)
PUT TAG(CIRCUITNAME);   PUT TAG(BOARDNAME)

EDGE==EDGEH_LINK
%WHILE %NOT EDGE==EDGEH %CYCLE
   PCH(CNTRL+'T')
   SPNUM(EDGE_INFO)
   S=""
   %FOR I=1,1,EDGE_NT %CYCLE
      COORD==EDGE_PIN(I)
      S=S.CTOS(COORD_X,COORD_Y)
      %EXIT %IF I=EDGE_NT
      S=S."+"
   %REPEAT
   S=S."/".EDGE_PNAME_S
   PUT STRING(S)
   PUT TAG(EDGE_NAME)
   EDGE==EDGE_LINK
%REPEAT

%FOR I=1,1,MAX PARMS %CYCLE
   TAG==BPARM(I)
   %unless tag==null tag %start;{*compiler bug*%CONTINUE %IF TAG==NULL TAG
      PCH(CNTRL+'P'); SPNUM(I)
      PUT TAG(TAG)
   %finish
%REPEAT
PCH(CNTRL+'G')

!!***************************************
!! now output the circuit body          *
!!***************************************

SELIN(CIRCUIT);   RESET INPUT
SKIP TO(CNTRL+'J');   PCH(CNTRL+'J');   NEWLINE

%FOR SUBNO=1,1,BOARDNSUBS %CYCLE
   CHIP==CHIPLIST_CHIP(SUBNO)
   COPY TO(CNTRL+'T')
   %WHILE CH=CNTRL+'T' %CYCLE
      PCH(CNTRL+'T')
      READ(I);   SPNUM(I)
      PIN==READ STRING
      S=PIN COORDS(CHIP,PIN)."/".PIN
      PUT STRING(S)
      PUT STRING(READ STRING)
      RCH
   %REPEAT

   PNO=0
   %WHILE CH=CNTRL+'P' %CYCLE
      READ(I)
      PARM==READ STRING
      PUT PARMS(CHIP,PNO,I)
      %IF PNO<I %START
         PCH(CNTRL+'P'); SPNUM(I)
         PUT STRING(PARM)
         PNO=I
      %FINISH
      RCH
   %REPEAT
   PUT PARMS(CHIP,PNO,MAX PARMS)
   PCH(CNTRL+'G');   NEWLINE
%REPEAT

!!**********************************************
!! relocate nets that refer to edge connectors *
!! and output the nets                         *
!! nets that are prewired have to be removed   *
!! and clashes resolved by generating an       *
!! unwiring list of connections to be broken   *
!!**********************************************

COPY TO(CNTRL+'N')
TNET==RECORD(TOS);   OLDTOS=TOS;   USED==RECORD(TOS)
%WHILE CH=CNTRL+'N' %CYCLE
   PCH(CNTRL+'N');   RCH
   %WHILE CH=CNTRL+'A' %CYCLE
      PCH(CNTRL+'A')
      NETNAME==READ STRING
      PUT STRING(NETNAME)
      READ(NT)
      TNET_NT=NT;   CLAIM(NETLEN+NT*FANLEN)
      NT=0
      %FOR I=1,1,TNET_NT %CYCLE
         READ(SUBNO);   READ(TNO)
{jhb}    %if subno>=1000 %or tno>=1000 %start
{jhb}       printstring("Pin reference out of range, Subno = "); write(subno,-1)
{jhb}       printstring(", tno = "); write(tno, -1); newline
{jhb}       %stop
{jhb}    %finish
         %IF SUBNO=0 %START
            EDGE==FIND EDGE(TNO)
            TNO=EDGE_INFO>>2
         %ELSE
            !! flag the pin as used
            NAME==SLOT PIN NAME(SUBNO,TNO)
            ->NEXT %IF NAME=NETNAME
            UNWIRE(SUBNO,TNO,NETNAME) %UNLESS NAME==NULL STRING
         %FINISH
         NT=NT+1
         FAN==TNET_F(NT)
         FAN_SUBNO=SUBNO;   FAN_TNO=TNO
NEXT:
         %IF SUBNO>0 %START
            !! mark the terminal as used
            CHIPLIST_CHIP(SUBNO)_PIN(TNO)_name==USED
         %FINISH
      %REPEAT
      PNUM(NT)
      %FOR I=1,1,NT %CYCLE
         FAN==TNET_F(I)
         BLANK;   SPNUM(FAN_SUBNO);   PNUM(FAN_TNO)
         SEPARATE
      %REPEAT
      TOS=OLDTOS
      RCH
   %REPEAT
%REPEAT

!! find all unused pins and list those that have to be unwired
%FOR SUBNO=1,1,BOARDNSUBS %CYCLE
   CHIP==CHIPLIST_CHIP(SUBNO)
   %FOR TNO=1,1,CHIP_NT %CYCLE
      TAG==CHIP_PIN(TNO)_name
      %CONTINUE %IF TAG==USED
      NAME==SLOT PIN NAME(SUBNO,TNO)
      %CONTINUE %IF NAME==NULL STRING
      UNWIRE(SUBNO,TNO,NULL STRING)
   %REPEAT
%REPEAT

COPY TO(CNTRL+'E')
PCH(CNTRL+'E')
NEWLINE

!!***********************************************
!! produce updated input on output stream 2     *
!!***********************************************

SELOUT(SOUT);   RESET INPUT

COPY TO(CNTRL+'J');   PCH(CNTRL+'J');   NEWLINE

%FOR SUBNO=1,1,BOARDNSUBS %CYCLE
   CHIP==CHIPLIST_CHIP(SUBNO)
   %CYCLE
      RCH
      %EXIT %IF CH=CNTRL+'G' %OR CH=CNTRL+'P'
      PCH(CH)
   %REPEAT
   !! got a parameter, or end of subunit
   PNO=0
   %WHILE CH=CNTRL+'P' %CYCLE
      !! for each parameter
      READ(I)
      PARM==READ STRING
      PUT PARMS(CHIP,PNO,I)
      %IF PNO<I %START
         PCH(CNTRL+'P');   SPNUM(I)
         PUT STRING(PARM)
         PNO=I
      %FINISH
      RCH
   %REPEAT
   PUT PARMS(CHIP,PNO,MAX PARMS)
   PCH(CNTRL+'G');   NEWLINE
%REPEAT

COPY TO(CNTRL+'E');   PCH(CNTRL+'E');   NEWLINE

!!***************************
!! report on space usage    *
!!***************************

SELECTOUTPUT(REPORT)
PRINTSTRING("Used ");   WRITE(STACKLEN-(BOS-MAXTOS),0)
PRINTSTRING(" out of ");   WRITE(STACKLEN,0)
PRINTSTRING(" words");   NEWLINE

DONE:
%ENDOFPROGRAM