%EXTERNALROUTINE A68(%STRING(63) SRCE)
%STRING(15) OBJ,LIST
%EXTERNALROUTINESPEC DEFINE(%STRING(63) S)
%CONSTINTEGER IHASH=59
%CONSTBYTEINTEGERARRAY HILINK(0: 58)= %C
   2, 0, 5, 8, 10, 11, 12, 15, 0, 17, 21, 23, 26, 30, 32, 36,
   0, 38, 41, 0, 42, 46, 50, 52, 53, 55, 57, 58, 0, 0, 60, 0,
   62, 66, 69, 73, 76, 0, 77, 0, 79, 82, 85, 88, 0, 0, 0, 91,
   92, 93, 95, 97, 100, 0, 102, 107, 110, 111, 113
%CONSTSTRING(4)%ARRAY INSTR(1:113)= %C
  "PULB","BVS","BHI","SBA","DECA","DECB","CLRA","BLE","DES",
  "CLRB","ANDA","ANDB","NOP","TAB","ORG","DEX","BITA","TPA","BSR",
  "TSTA","BITB","TSTB","FDB","SEV","INS","INCA","PSHA","JMP","INCB",
  "STS","LSRA","PSHB","LSRB","BPL","WAI","NEG","INX","BLS","STX",
  "TST","BLT","COM","NEGA","TAP","CLC","BEQ","TSX","TBA","SBCA",
  "NEGB","BMI","SBCB","ROL","RORA","ADCA","RORB","ADCB","CLI","LDS",
  "ROR","SUBA","LDAA","LSR","ORAA","SUBB","LDAB","BCC","ASRA","ORAB",
  "ASRB","END","BNE","LDX","CBA","CLR","BRA","TXS","DAA","CLV",
  "BGE","EQU","ADDA","COMA","ADDB","RTI","BVC","ASL","COMB","CPX",
  "ROLA","DEC","ROLB","ASR","BCS","CMPA","SWI","CMPB","SEC","RTS",
  "JSR","EORA","FCB","EORB","FCC","INC","ABA","STAA","ASLA","BGT",
  "STAB","ASLB","SEI","PULA"
%CONSTBYTEINTEGERARRAY ICODE(1:113)= %C
  X'33',X'29',X'22',X'10',X'4A',X'5A',X'4F',X'2F',X'34',
  X'5F',X'84',X'C4',X'01',X'16',X'00',X'09',X'85',X'07',X'8D',
  X'4D',X'C5',X'5D',X'00',X'0F',X'31',X'4C',X'36',X'6E',X'5C',
  X'9F',X'44',X'37',X'54',X'2A',X'3E',X'60',X'08',X'23',X'DF',
  X'6D',X'2D',X'63',X'40',X'06',X'0C',X'27',X'30',X'17',X'82',
  X'50',X'2B',X'C2',X'69',X'46',X'89',X'56',X'C9',X'0E',X'8E',
  X'66',X'80',X'86',X'64',X'8A',X'C0',X'C6',X'24',X'47',X'CA',
  X'57',X'00',X'26',X'CE',X'11',X'6F',X'20',X'35',X'19',X'0A',
  X'2C',X'00',X'8B',X'43',X'CB',X'3B',X'28',X'68',X'53',X'8C',
  X'49',X'6A',X'59',X'67',X'25',X'81',X'3F',X'C1',X'0D',X'39',
  X'AD',X'88',X'00',X'C8',X'00',X'6C',X'1B',X'87',X'48',X'2E',
  X'C7',X'58',X'0F',X'32'
%CONSTBYTEINTEGERARRAY ITYPE(1:113)= %C
   1, 2, 2, 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 8,
   1, 3, 1, 2, 1, 3, 1, 10, 1, 1, 6, 1, 6, 1, 5, 1,
   1, 1, 2, 1, 6, 1, 2, 5, 6, 2, 6, 1, 1, 1, 2, 1,
   1, 3, 1, 2, 3, 6, 1, 3, 1, 3, 1, 4, 6, 3, 3, 6,
   3, 3, 3, 2, 1, 3, 1, 12, 2, 4, 1, 6, 2, 1, 1, 1,
   2, 7, 3, 1, 3, 1, 2, 6, 1, 4, 1, 6, 1, 6, 2, 3,
   1, 3, 1, 1, 6, 3, 9, 3, 11, 6, 1, 5, 1, 2, 5, 1,
   1, 1
%CONSTBYTEINTEGERARRAY ILINK(1:113)= %C
   0, 1, 0, 3, 4, 0, 6, 7, 0, 9, 0, 0, 0, 13, 14,
   0, 16, 0, 18, 19, 20, 0, 22, 0, 24, 25, 0, 27, 28, 29, 0,
   31, 0, 33, 34, 35, 0, 37, 0, 39, 40, 0, 0, 43, 44, 45, 0,
   47, 48, 49, 0, 51, 0, 0, 54, 0, 56, 0, 0, 59, 0, 61, 0,
   63, 64, 65, 0, 67, 68, 0, 70, 71, 72, 0, 74, 75, 0, 0, 78,
   0, 80, 81, 0, 83, 84, 0, 86, 87, 0, 89, 90, 0, 0, 0, 94,
   0, 96, 0, 98, 99, 0, 101, 0, 103, 104, 105, 106, 0, 108, 109, 0,
   0, 112
%ROUTINESPEC READ LINE
%INTEGERFNSPEC GET NAME(%INTEGERNAME NID)
%INTEGERFNSPEC GET INSTR(%INTEGERNAME ID)
%INTEGERFNSPEC GET OPD(%INTEGERNAME OPD)
%INTEGERFNSPEC GET CONST(%INTEGERNAME CVAL)
%ROUTINESPEC INSTR OUT(%INTEGER OP,OPD,B)
%ROUTINESPEC FAULT(%STRING(63) S)
%STRING(4)%FNSPEC STRHEX(%INTEGER N,D)
%ROUTINESPEC SQS(%INTEGER FROM,TO)
%BYTEINTEGERARRAY LINE(1:73)
%INTEGER CA,CA1,FAULTS,LP,OPD,IID,LID,CVAL,PASS,LN,NNAMES,I,J
%CONSTINTEGER EQU=7,NAMES=255,NHASH=67
%BYTEINTEGERARRAY HNLINK(0:NHASH-1)
%STRING(7)%ARRAY NAME(1:NAMES)
%INTEGERARRAY NVAL(1:NAMES)
%BYTEINTEGERARRAY NASS(1:NAMES)
%BYTEINTEGERARRAY NLINK(1:NAMES)
%SWITCH ITYPE1,ITYPE2(1:12)
  %IF SRCE->SRCE.(",").OBJ %THEN %START
    %UNLESS OBJ->OBJ.(",").LIST %THEN LIST="A68LIST"
  %FINISH %ELSE OBJ="A68OBJ" %AND LIST="A68LIST"
  DEFINE("STREAM01,".SRCE)
  DEFINE("STREAM02,".OBJ)
  DEFINE("STREAM03,".LIST)
  SELECT OUTPUT(3)
  PRINT STRING("

MOTOROLA 6800 ASSEMBLER MKI

SOURCE : ".SRCE."
OBJECT : ".OBJ."
LISTING : ".LIST."

")
  FAULTS=0
  NNAMES=0
  %CYCLE I=0,1,NHASH-1
    HNLINK(I)=0
  %REPEAT
!-----------------------------------------------------------------------
! PASS 1 - EVALUATE ALL NAMES
  PASS=1
  SELECT INPUT(1)
  LN=0
  CA=0
RL1:READ LINE
  %IF LINE(1)='*' %THEN ->RL1    ;! IGNORE COMMENTS
  LP=1
  %IF GET NAME(LID)=0 %THEN %START    ;! LABEL PRESENT
    %IF NASS(LID)=0 %THEN NASS(LID)=1 %ELSE %C
      FAULT("NAME ".NAME(LID)." ALREADY HAS VALUE ".STRHEX(NVAL(LID),4))
    NVAL(LID)=CA
  %FINISH %ELSE LID=0
  %IF GET INSTR(IID)#0 %THEN ->RL1
  ->ITYPE1(ITYPE(IID))
!-----------------------------------------------------------------------
ITYPE1(1):! IMPLIED
!-----------------------------------------------------------------------
ITYPE1(9):! FCB
  CA=CA+1
  ->RL1
!-----------------------------------------------------------------------
ITYPE1(2):! RELATIVE
!-----------------------------------------------------------------------
ITYPE1(10):! FDB
  CA=CA+2
  ->RL1
!-----------------------------------------------------------------------
ITYPE1(3):! IMMEDIATE(2), DIRECT, INDEX, EXTEND
!-----------------------------------------------------------------------
ITYPE1(4):! IMMEDIATE(3), DIRECT, INDEX, EXTEND
  %WHILE LINE(LP)=' ' %THEN LP=LP+1    ;! LOOK FOR OPERAND
  %IF LINE(LP)='#' %THEN CA=CA+ITYPE(IID)-1 %AND ->RL1    ;! IMMEDIATE
!-----------------------------------------------------------------------
ITYPE1(5):! DIRECT, INDEX, EXTEND
  I=GET OPD(OPD)
  %IF LINE(LP)=',' %AND LINE(LP+1)='X' %THEN CA=CA+2 %AND ->RL1    ;! X
  %IF I=0 %AND 0<=OPD<=255 %THEN CA=CA+2 %ELSE CA=CA+3    ;! D OR E
  ->RL1
!-----------------------------------------------------------------------
ITYPE1(6):! INDEX, EXTEND
  I=GET OPD(OPD)
  %IF LINE(LP)=',' %AND LINE(LP+1)='X' %THEN CA=CA+2 %ELSE CA=CA+3
  ->RL1
!-----------------------------------------------------------------------
ITYPE1(7):! EQU
  %IF LID=0 %THEN FAULT("NO NAME TO EQUATE") %ELSE %START
    %IF GET OPD(OPD)=0 %THEN NVAL(LID)=OPD %ELSE %C
      NASS(LID)=0 %AND FAULT("CANNOT EVALUATE OPERAND")
  %FINISH
  ->RL1
!-----------------------------------------------------------------------
ITYPE1(8):! ORG
  %IF GET OPD(OPD)=0 %THEN CA=OPD %ELSE FAULT("CANNOT EVALUATE OPERAND")
  ->RL1
!-----------------------------------------------------------------------
ITYPE1(11):! FCC
  %WHILE LINE(LP)=' ' %THEN LP=LP+1
  %IF LINE(LP)#'"' %THEN ->RL1    ;! FAULTY SYNTAX
  LP=LP+1
  %CYCLE
    %IF LINE(LP)='"' %THEN %START
      %IF LINE(LP+1)='"' %THEN LP=LP+1 %ELSE ->RL1
    %FINISH
    LP=LP+1
    CA=CA+1
  %REPEAT
!-----------------------------------------------------------------------
ITYPE1(12):! END
  CA1=CA    ;! SAVE LENGTH FOUND BY FIRST PASS
  PASS=2
  NEWLINE
  %CYCLE I=1,1,NNAMES
    %IF NASS(I)=0 %THEN FAULT("NAME ".NAME(I)." HAS NO VALUE")
  %REPEAT
!-----------------------------------------------------------------------
! PASS 2
  NEWLINES(2)
  SELECT INPUT(0)
  CLOSE STREAM(1)
  SELECT INPUT(1)
  LN=0
  CA=0
RL2:READ LINE
  %IF LINE(1)='*' %THEN INSTR OUT(0,0,0) %AND ->RL2
  LP=1
  I=GET NAME(LID)    ;! IGNORE LABELS ON THIS PASS
  %IF GET INSTR(IID)#0 %THEN INSTR OUT(0,0,0) %AND %C
    FAULT("UNKNOWN INSTRUCTION") %AND ->RL2
  ->ITYPE2(ITYPE(IID))
!-----------------------------------------------------------------------
ITYPE2(1):! IMPLIED
  INSTR OUT(ICODE(IID),0,1)
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(2):! RELATIVE
  I=GET OPD(OPD)
  J=OPD-CA-2
  INSTR OUT(ICODE(IID),J&255,2)
  %IF I#0 %THEN FAULT("CANNOT EVALUATE OPERAND") %ELSE %START
    %UNLESS -127<=J<=127 %THEN FAULT("BRANCH OUT OF RANGE")
  %FINISH
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(3):! IMMEDIATE(2), DIRECT, INDEX, EXTEND
!-----------------------------------------------------------------------
ITYPE2(4):! IMMEDIATE(3), DIRECT, INDEX, EXTEND
  %WHILE LINE(LP)=' ' %THEN LP=LP+1
  %IF LINE(LP)='#' %THEN %START
    LP=LP+1
    I=GET OPD(OPD)
    INSTR OUT(ICODE(IID),OPD,ITYPE(IID)-1)
    %IF I#0 %THEN FAULT("CANNOT EVALUATE OPERAND")
    ->RL2
  %FINISH
!-----------------------------------------------------------------------
ITYPE2(5):! DIRECT,INDEX,EXTEND
  I=GET OPD(OPD)
  %IF LINE(LP)=',' %AND LINE(LP+1)='X' %THEN %START
    INSTR OUT(ICODE(IID)+X'20',OPD,2)
    %IF I#0 %THEN FAULT("CANNOT EVALUATE OPERAND")
    ->RL2
  %FINISH
  %IF I=0 %AND 0<=OPD<=255 %THEN INSTR OUT(ICODE(IID)+X'10',OPD,2) %C
    %ELSE INSTR OUT(ICODE(IID)+X'30',OPD,3)
  %IF I#0 %THEN FAULT("CANNOT EVALUATE OPERAND")
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(6):! INDEX, EXTEND
  I=GET OPD(OPD)
  %IF LINE(LP)=',' %AND LINE(LP+1)='X' %THEN %C
    INSTR OUT(ICODE(IID),OPD,2) %ELSE INSTR OUT(ICODE(IID)+X'10',OPD,3)
  %IF I#0 %THEN FAULT("CANNOT EVALUATE OPERAND")
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(7):! EQU
  INSTR OUT(0,0,0)
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(8):! ORG
  %IF GET OPD(OPD)=0 %THEN CA=OPD
  INSTR OUT(0,0,0)
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(9):! FCB
  %WHILE LINE(LP)=' ' %THEN LP=LP+1
  I=GET CONST(CVAL)
  INSTR OUT(CVAL&255,0,1)
  %UNLESS I=0 %AND -128<=CVAL<=255 %THEN FAULT("INVALID CONSTANT")
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(10):! FDB
  %WHILE LINE(LP)=' ' %THEN LP=LP+1
  I=GET CONST(CVAL)
  INSTR OUT(CVAL>>8&255,CVAL&255,2)
  %UNLESS I=0 %AND 0<=CVAL<=65535 %THEN FAULT("INVALID CONSTANT")
  ->RL2
!-----------------------------------------------------------------------
ITYPE2(11):! FCC
  %WHILE LINE(LP)=' ' %THEN LP=LP+1
  %IF LINE(LP)#'"' %THEN INSTR OUT(0,0,0) %AND %C
    FAULT("INVALID STRING") %AND ->RL2
  LP=LP+1
  I=LP
  %CYCLE
    %IF LINE(LP)='"' %THEN %START
      %IF LINE(LP+1)='"' %THEN LP=LP+1 %ELSE %START
        %IF LP=I %THEN INSTR OUT(0,0,0) %AND FAULT("INVALID STRING")
        ->RL2
      %FINISH
    %FINISH
    INSTR OUT(LINE(LP),0,1)
    LP=LP+1
    LINE(1)=NL    ;! TO AVOID REPRINTING THE TEXT LINE
  %REPEAT
!-----------------------------------------------------------------------
ITYPE2(12):! END
  INSTR OUT(0,0,0)
  %IF CA#CA1 %THEN FAULT("DIRECT/EXTEND MODE INCONSISTENCY")
!-----------------------------------------------------------------------
  SQS(1,NNAMES)
  NEWLINES(2)
  I=1
  %CYCLE J=1,1,NNAMES
    %IF I=I//8*8 %THEN NEWLINE
    PRINT STRING(NAME(J))
    SPACES(8-LENGTH(NAME(J)))
    %IF NASS(J)=0 %THEN PRINT STRING("****    ") %C
       %ELSE PRINT STRING(STRHEX(NVAL(J),4)."    ")
  %REPEAT
  NEWLINES(2)
  WRITE(FAULTS,1)
  PRINT STRING(" FAULTS IN ASSEMBLY
")
  %STOP
!-----------------------------------------------------------------------
%ROUTINE READ LINE
%INTEGER I
  LN=LN+1
  %CYCLE I=1,1,73
RL: READ SYMBOL(LINE(I))
    %IF LINE(I)=NL %THEN %START
      %IF I=1 %THEN ->RL %ELSE %RETURN
    %FINISH
  %REPEAT
  READ SYMBOL(LINE(I)) %UNTIL LINE(I)=NL    ;! SKIP BEYOND 72
%END
!-----------------------------------------------------------------------
%INTEGERFN GET NAME(%INTEGERNAME NID)
%STRING(7) N
%INTEGER H,L,SYM
  %UNLESS 'A'<=LINE(LP)<='Z' %THEN NID=0 %AND %RESULT=1
  H=LINE(LP)-'0'
  N=TOSTRING(LINE(LP))
  %CYCLE L=2,1,73
    LP=LP+1
    SYM=LINE(LP)
    %UNLESS 'A'<=SYM<='Z' %OR '0'<=SYM<='9' %THEN %EXIT
    H=H<<4+SYM-'0' %AND N=N.TOSTRING(SYM) %UNLESS L>7
  %REPEAT
  H=H-H//NHASH*NHASH
  L=HNLINK(H)
  %WHILE L#0 %CYCLE
    %IF NAME(L)=N %THEN NID=L %AND %RESULT=0
    L=NLINK(L)
  %REPEAT
  %IF NNAMES=NAMES %THEN FAULT("TOO MANY NAMES") %AND %STOP
  NNAMES=NNAMES+1
  NAME(NNAMES)=N
  NLINK(NNAMES)=L
  NASS(NNAMES)=0
  NVAL(NNAMES)=0
  HNLINK(H)=NNAMES
  NID=NNAMES
  %RESULT=0
%END
!-----------------------------------------------------------------------
%INTEGERFN GET INSTR(%INTEGERNAME IID)
%STRING(4) I
%INTEGER H,L,SYM
  IID=0
  %WHILE LINE(LP)=' ' %THEN LP=LP+1
  %UNLESS 'A'<=LINE(LP)<='Z' %THEN %RESULT=1
  H=LINE(LP)-'0'
  I=TOSTRING(LINE(LP))
  %CYCLE L=2,1,4
    LP=LP+1
    SYM=LINE(LP)
    %UNLESS 'A'<=SYM<='Z' %THEN ->GOTI
    H=H<<4+SYM-'0'
    I=I.TOSTRING(SYM)
  %REPEAT
  LP=LP+1
  %IF 'A'<=LINE(LP)<='Z' %THEN %RESULT=1
GOTI:H=H-H//IHASH*IHASH
  L=HILINK(H)
  %WHILE L#0 %CYCLE
    %IF INSTR(L)=I %THEN IID=L %AND %RESULT=0
    L=ILINK(L)
  %REPEAT
  %RESULT=1
%END
!-----------------------------------------------------------------------
%INTEGERFN GET OPD(%INTEGERNAME OPD)
%INTEGER NID,OP,CVAL
  %WHILE LINE(LP)=' ' %THEN LP=LP+1
  OPD=0
  OP='+'
  %CYCLE
    %IF GET NAME(NID)=0 %THEN %START
      %IF NASS(NID)=0 %THEN %RESULT=1
      CVAL=NVAL(NID)
    %FINISH %ELSE %START
      %IF GET CONST(CVAL)#0 %THEN %RESULT=1
    %FINISH
    %IF OP='+' %THEN OPD=OPD+CVAL %ELSE OPD=OPD-CVAL
    OP=LINE(LP)
    %UNLESS OP='+' %OR OP='-' %THEN %RESULT=0
    LP=LP+1
  %REPEAT
%END
!-----------------------------------------------------------------------
%INTEGERFN GET CONST(%INTEGERNAME CVAL)
%INTEGER I
  %IF LINE(LP)='*' %THEN LP=LP+1 %AND CVAL=CA %AND %RESULT=0
  CVAL=0
  %IF '0'<=LINE(LP)<='9' %THEN %START    ;! DECIMAL
    %CYCLE I=1,1,6
      CVAL=10*CVAL+LINE(LP)-'0'
      LP=LP+1
      %UNLESS '0'<=LINE(LP)<='9' %THEN ->GOT
    %REPEAT
    %RESULT=1    ;! TOO MANY DIGITS
  %FINISH
  %IF LINE(LP)='$' %THEN %START    ;! HEX
    %CYCLE I=0,1,4
      LP=LP+1
      %IF '0'<=LINE(LP)<='9' %THEN CVAL=CVAL<<4!(LINE(LP)-'0') %C
        %ELSE %START
        %IF 'A'<=LINE(LP)<='F' %THEN CVAL=CVAL<<4!(LINE(LP)-'A'+10) %C
          %ELSE ->GOT
      %FINISH
    %REPEAT
    %RESULT=1    ;! TOO MANY DIGITS
  %FINISH
  %IF LINE(LP)='@' %THEN %START    ;! OCTAL
    %CYCLE I=0,1,6
      LP=LP+1
      %IF '0'<=LINE(LP)<='7' %THEN CVAL=CVAL<<3!(LINE(LP)-'0') %C
        %ELSE ->GOT
    %REPEAT
    %RESULT=1
  %FINISH
  %IF LINE(LP)='''' %THEN %START
    LP=LP+1
    %IF LINE(LP)=' ' %OR LINE(LP)=NL %THEN %RESULT=1
    CVAL=LINE(LP)
    LP=LP+1
    %RESULT=0
  %FINISH
  %RESULT=1
GOT:%IF CVAL>X'FFFF' %THEN %RESULT=1 %ELSE %RESULT=0
%END
!-----------------------------------------------------------------------
%ROUTINE INSTR OUT(%INTEGER OP,OPD,B)
%INTEGER I
  %IF B#0 %THEN %START
    SELECT OUTPUT(2)
    PRINT CH(OP)
    %IF B#1 %THEN %START
      %IF B=2 %THEN PRINT CH(OPD) %ELSE PRINT CH(OPD>>8) %AND %C
        PRINT CH(OPD&255)
    %FINISH
    SELECT OUTPUT(3)
  %FINISH
  WRITE(LN,5)
  PRINT STRING("   ".STRHEX(CA,4)."   ")
  %IF B=0 %THEN SPACES(10) %ELSE %START
    PRINT STRING(STRHEX(OP,2)." ")
    %IF B=1 %THEN SPACES(7) %ELSE %START
      %IF B=2 %THEN PRINT STRING(STRHEX(OPD,2)."     ") %C
        %ELSE PRINT STRING(STRHEX(OPD,4)."   ")
    %FINISH
  %FINISH
  I=0
  I=I+1 %AND PRINT SYMBOL(LINE(I)) %UNTIL LINE(I)=NL
  CA=CA+B
%END
!-----------------------------------------------------------------------
%ROUTINE FAULT(%STRING(63) S)
  FAULTS=FAULTS+1
  %IF PASS=1 %THEN %START
    WRITE(LN,4)
    SPACES(6)
    %CYCLE I=1,1,73
      PRINT SYMBOL(LINE(I))
      %IF LINE(I)=NL %THEN %EXIT
    %REPEAT
  %FINISH
  PRINT STRING("****  ".S."
")
%END
!-----------------------------------------------------------------------
%STRING(4)%FN STRHEX(%INTEGER N,D)
%CONSTSTRING(1)%ARRAY H(0:15)="0","1","2","3","4","5","6","7","8","9",
  "A","B","C","D","E","F"
%INTEGER I
%STRING(4) S
  S=""
  %CYCLE I=1,1,D
    S=H(N&15).S
    N=N>>4
  %REPEAT
  %RESULT=S
%END
!-----------------------------------------------------------------------
%ROUTINE SQS(%INTEGER FROM,TO)
%STRING(7) NAMET
%INTEGER NASST,NVALT,L,U
  L=FROM
  U=TO
  NAMET=NAME(U)
  NASST=NASS(U)
  NVALT=NVAL(U)
  ->IN
  %CYCLE
    %UNTIL NAME(L)>NAMET %CYCLE
      L=L+1
      %IF L=U %THEN ->OUT
IN: %REPEAT
    NAME(U)=NAME(L)
    NASS(U)=NASS(L)
    NVAL(U)=NVAL(L)
    %UNTIL NAME(U)<NAMET %CYCLE
      U=U-1
      %IF L=U %THEN ->OUT
    %REPEAT
    NAME(L)=NAME(U)
    NASS(L)=NASS(U)
    NVAL(L)=NVAL(U)
  %REPEAT
OUT:NAME(U)=NAMET
  NASS(U)=NASST
  NVAL(U)=NVALT
  SQS(FROM,U-1) %IF FROM<U-1
  SQS(U+1,TO) %IF TO>U+1
%END
!-----------------------------------------------------------------------
%END
%ENDOFFILE