SECTION"UT1"
GET "AHDR"
 LET LIST(SIZE,A0,A1,A2,A3,A4,A5,A6,A7) = VALOF $(
   LET P=@A0
   AND LSPP=LSP
    LSP:=LSP+SIZE
   IF LSP>LSPACEMAX THEN $(
      PROFIL:=1; FAULT('Z')
      RESULTIS 0
   $)
   FOR N=0 TO SIZE-1 DO LSPP!N:=P!N
   RESULTIS LSPP
$)
 AND SETLABEL(LAB) BE $(
   UNLESS LAB=0 THEN SETSYMBOL(LAB,((CNT=ABSC)->T.ABS,T.REL),!CNT)
$)
 AND SETSYMBOL(SYMB,TYPE,VALUE) = VALOF $(
   LET T=GETNAME(@SYMB)
   IF T=-1 THEN RETURN
   IF PASS=1 THEN $(
      IF NAMEP!T=0 THEN $(
         TEST CROSSREF THEN $(
            NAMEP!T:=LIST(4,TYPE,VALUE,0,0)
            ADDREF(NAMEP!T,2,!CNT)
         $)
         ELSE NAMEP!T:=LIST(2,TYPE,VALUE)
         RETURN
      $)
      IF CROSSREF THEN ADDREF(NAMEP!T,2,!CNT)
      $(
         LET A=!(NAMEP!T)
         UNLESS (A&T.MULDEF)=0 RETURN
         IF (A&T.REDEF)=0 THEN $(
            !(NAMEP!T):=A LOGOR T.MULDEF
            RETURN
         $)
         !(NAMEP!T):=TYPE
         1!(NAMEP!T):=VALUE
      $)
      RETURN
   $)
   IF NAMEP!T=0 THEN $(
      FAULT('P')
      RETURN
   $)
   $(
      LET A=!(NAMEP!T)
      UNLESS (A&T.MULDEF)=0 THEN $(
         FAULT('M')
         RETURN
      $)
      IF (A&T.REDEF)=0 THEN $(
         UNLESS (A&T.PASS2SET)=0 THEN $(
            FAULT('M')
            RETURN
         $)
         UNLESS (TYPE=!(NAMEP!T))&(VALUE=1!(NAMEP!T)) THEN FAULT('P')
         !(NAMEP!T):=TYPE LOGOR T.PASS2SET
         RETURN
      $)
      IF (TYPE&T.REDEF)=0 THEN $(
        FAULT('L')
        RETURN
      $)
      !(NAMEP!T):=TYPE LOGOR T.PASS2SET
      1!(NAMEP!T):=VALUE
   $)
$)
 AND READITEM(AP,ATYPE,AVAL) = VALOF $(
   LET P=!AP
   AND K=0
   AND T,L=0,0
   AND SIGN=1
   AND NOTF = 0            // COPE WITH ~ FOR 'NOT'
   IF !P='~' THEN
   $( NOTF := -1          // ALL 1S ON 2S COMPLEMENT MC
      P := P+1
   $)
   IF !P='-' THEN SIGN:=-1
    IF (!P='+') LOGOR (!P='-') THEN P:=P+1
    IF !P='~' THEN
    $( NOTF := -1           // ALL 1S ON 2S COMPLEMENT MC
       P := P+1
    $)
    IF LETTER(!P) THEN $(
      T:=GETNAME(@P)
      IF (T=-1) LOGOR (NAMEP!T=0) THEN $(
         FAULT('U');!AP:=P
         RESULTIS FALSE
      $)
      IF PASS=2 THEN $(
         LET A=!(NAMEP!T)
         IF CROSSREF THEN ADDREF(NAMEP!T,3,!CNT)
         IF ((A&T.REDEF) NE 0)&((A&T.PASS2SET)=0) THEN $(
            FAULT('U'); !AP:=P
            RESULTIS FALSE
         $)
         IF (A&T.PASS2SET)=0 THEN ITEMSET:=FALSE
      $)
      !ATYPE:=!(NAMEP!T)&#XFC00
      SWITCHON !ATYPE INTO $(
      CASE T.ABS:
      CASE T.REL:
         !AVAL := (SIGN*(1!(NAMEP!T))) NEQV NOTF
         ENDCASE
      CASE  T.COMMON:
         !ATYPE:=!(NAMEP!T)
         !AVAL:=0
         ENDCASE
      CASE T.COMMONTAG:
         !ATYPE:=T.COMMON+(!(NAMEP!T)&#X3FF)
         !AVAL := (SIGN*(1!(NAMEP!T))) NEQV NOTF
         ENDCASE
      CASE T.EXT:
         !ATYPE:=!(NAMEP!T)
         !AVAL:=0
         ENDCASE
      DEFAULT:
         FAULT('P'); !AP:=P
         RESULTIS FALSE
      $)
      !AP:=P; RESULTIS TRUE
   $)
     IF '0'<=!P<='9' THEN $(
      !AVAL:=0
      $(
         IF !AVAL>32767 THEN FAULT('C')
         !AVAL:=!AVAL*10+!P-'0'
         P:=P+1
      $) REPEATWHILE '0'<=!P<='9'
      !ATYPE:=T.ABS
      !AVAL := (SIGN*(!AVAL&#X7FFF)) NEQV NOTF
      !AP:=P
      RESULTIS TRUE
   $)
    P:=P+1; SWITCHON !(P-1) INTO $(
    CASE '$':
      TEST !P='$' THEN $(
         P:=P+1; !AVAL:=0
         !ATYPE:=T.ABS
      $)
      ELSE $(
         !AVAL := (SIGN*!CNT) NEQV NOTF
         !ATYPE:=(CNT=ABSC)->T.ABS,T.REL
      $)
      !AP:=P; RESULTIS TRUE
   CASE '#':
      IF !P='T' THEN $(
         P:=P+1
         !AVAL:=BINDIGIT(!P) ; P:=P+1
         IF !AVAL<0 THEN $(
            FAULT('C')
            !AP:=P
            RESULTIS FALSE
            $)
         K:=0
         $(
            K:=K+1
            L:=BINDIGIT(!P)
            IF L<0 THEN BREAK
            P:=P+1
            !AVAL:=(!AVAL<<1)+L
         $) REPEAT
         IF K>16 THEN $(
            FAULT('C');!AP:=P
            RESULTIS FALSE
            $)
         !ATYPE:=T.ABS ;!AP:=P
         !AVAL := (SIGN*!AVAL) NEQV NOTF
         RESULTIS TRUE
         $)
      IF !P='Q'  THEN $(
         P:=P+1
         !AVAL:=OCTDIGIT(!P); P:=P+1
         IF !AVAL <0 THEN $(
            FAULT('C') ; !AP:=P
            RESULTIS FALSE
            $)
         K:=0
         $(
            K:=K+1
            L:=OCTDIGIT(!P)
            IF L<0 THEN BREAK
            P:=P+1
            !AVAL:=(!AVAL<<3)+L
         $) REPEAT
         IF K>6 THEN $(
            FAULT('C'); !AP:=P
            RESULTIS FALSE
         $)
         !ATYPE:=T.ABS
         !AVAL := (SIGN*!AVAL) NEQV NOTF
         !AP:=P
         RESULTIS TRUE
      $)
      !AVAL:=HEXDIGIT(!P); P:=P+1
      IF !AVAL<0 THEN $(
         FAULT('C'); !AP:=P
         RESULTIS FALSE
      $)
      K:=0
      $(
         K:=K+1
         L:=HEXDIGIT(!P)
         IF L<0 BREAK
         P:=P+1
         !AVAL:=(!AVAL<<4)+L
      $) REPEAT
      IF K>4 THEN $(
         FAULT('C'); !AP:=P
         RESULTIS FALSE
      $)
      !ATYPE:=T.ABS
      !AVAL := (SIGN*!AVAL) NEQV NOTF
      !AP:=P
      RESULTIS TRUE
   CASE '"':
      !AVAL:=#X0020; !ATYPE:=T.ABS
      IF GETSYM(@P) DO $(
         !AVAL:=ASKII(!P)
         P:=P+1
         IF  !P ~= '"' DO $(
               FAULT('A'); !AP:=P+1; RESULTIS FALSE
         $)
      P:=P+1
      $)
      !AVAL:=(SIGN*!AVAL) NEQV NOTF; !AP:=P; RESULTIS TRUE
   CASE '@':
      UNLESS CAN(!P) LOGOR (!P=' ') THEN $(
         FAULT('C'); !AP:=P
         RESULTIS FALSE
      $)
      !AVAL:=CANVALUE(!P); P:=P+1
      FOR K=1 TO 2 DO $(
         L:=CANVALUE(!P)
         TEST L<0 THEN !AVAL:=!AVAL*40
         ELSE $(
            P:=P+1; !AVAL:=!AVAL*40+L
         $)
      $)
      !ATYPE:=T.ABS
      !AVAL := (SIGN*!AVAL) NEQV NOTF
      !AP:=P
      RESULTIS TRUE
   DEFAULT:
      FAULT('S'); !AP:=P
      RESULTIS FALSE
   $)
$)
 AND GETSYM(A)=VALOF $(
   LET B=!A
   IF !B='"' THEN $(
      B:=B+1; !A:=B
      UNLESS !B='"' THEN RESULTIS FALSE
   $)
   IF !B='*N' THEN $(
      FAULT('S'); RESULTIS FALSE
   $)
   RESULTIS TRUE
$)
 AND READFIELD(N,AP) = VALOF $(
   LET F,V=1,0
    READEXPR(AP)
   IF EXPR.TYPE=-1 THEN RETURN
   UNLESS EXPR.TYPE=T.ABS DO $(
      FAULT('F'); RESULTIS 0
   $)
    FOR I=1 TO N DO F:=2*F
   F:=F-1
    V:=EXPR.VALUE&F
   UNLESS EXPR.VALUE=V FAULT('T')
   RESULTIS V
$)
 AND TWOSCOMP(N) = VALOF $(
   IF N<0 RESULTIS #X10000+N
   RESULTIS N
$)
AND BINDIGIT(N) = VALOF $(
   IF '0' <= N <= '1' THEN RESULTIS N-'0'
   RESULTIS -1
$)
 AND OCTDIGIT(N) = VALOF $(
   IF '0' <= N <= '7' THEN RESULTIS N-'0'
   RESULTIS -1
$)
  AND UNPACKBITS(WORD,VECTOR) BE $(
   FOR I=0 TO 15 DO VECTOR!I:=(WORD>>I)&1
$)
 AND DFC(DIR) BE $(
         LET ARGCNT=0
         IF ARG=0 THEN $(
            FAULT('S')
            RETURN
         $)
         $(
            TEST !ARG='"' THEN $(
               ARG:=ARG+1
               $(
                  P.CODEV!ARGCNT:=0
                  P.CODET!ARGCNT:=T.ABS
                  UNLESS GETSYM(@ARG) THEN BREAK
                  P.CODEV!ARGCNT:=ASKII(!ARG)
                  ARG:=ARG+1
                  ARGCNT:=ARGCNT+1
               $) REPEAT
            $) ELSE $(
               TEST !ARG=',' THEN $(
                  EXPR.TYPE,EXPR.VALUE:=T.ABS,0
               $)
               ELSE $(
                  READEXPR(@ARG)
                  IF EXPR.TYPE=-1 THEN $(
                     EXPR.VALUE:=0
                     UNTIL TERM(!ARG) DO ARG:=ARG+1
                  $)
               $)
               TEST DIR=D.DB THEN $(
                  P.CODET!ARGCNT:=EXPR.TYPE
                  P.CODEV!ARGCNT:=EXPR.VALUE
                  UNLESS (EXPR.VALUE & #XFF00)=0 LOGOR
                         (EXPR.VALUE & #XFF00)=#XFF00 THEN FAULT('S')
                  ARGCNT:=ARGCNT+1
               $)
               ELSE $(
                  IF EXPR.TYPE=T.ABS
               THEN EXPR.VALUE:=(EXPR.VALUE<<8&#XFF00)|(EXPR.VALUE>>8&#XFF)
                  P.CODET!ARGCNT:=EXPR.TYPE
                  P.CODEV!ARGCNT:=(EXPR.VALUE>>8)&#XFF
                  ARGCNT:=ARGCNT+1
                  P.CODET!ARGCNT:=EXPR.TYPE
                  P.CODEV!ARGCNT:=EXPR.VALUE & #XFF
                  ARGCNT:=ARGCNT+1
               $)
            $)
            UNLESS !ARG=',' THEN BREAK
            ARG:=ARG+1
         $) REPEAT
         UNLESS (!ARG=' ') LOGOR (!ARG='*N') THEN FAULT('S')
         P.CODEN:=ARGCNT-1
         P.LOCF,P.LOC:=TRUE,!CNT
         FOR I=0 TO P.CODEN DO DUMP(P.CODET!I,P.CODEV!I,P.LOC+I)
         !CNT:=!CNT+ARGCNT
$)
 AND PRINTLINE() BE $(
      //
      // P.LOCF -> IS LOCN COUNTER TO BE PRINTED  (DEFAULT - FALSE)
      // P.LOC  -> LOCN COUNTER
      // P.CODET -> CODE TYPE
      // P.CODEV -> CODE VALUE
      // P.CODEN -> NO. OF WORDS OF CODE - 1
      //
      // LISTINGCONTROL < 0   ---> SUPPRESS PRINTING FOR THIS LINE ONLY
      //       "        = 0   ---> (L.NO) PRINTING SUPPRESSED COMPLETELY
      //       "        = 1   ---> (L.ALL) PRINT ALL (DEFAULT)
      //       "        = 2   ---> (L.SHORT) SUPPRESS 'CODE OVERFLOW' PR
      //
   //<3032
   UNLESS macexp THEN
   /*3032>*/
   lineno := lineno + 1
   IF (FNO=0)&(LISTINGCONTROL<=0) THEN $(
      LISTINGCONTROL:=-LISTINGCONTROL; RETURN
   $)
   INCRLINES()
   //<3032
   TEST macexp THEN spaces(5)
   ELSE
   /*3032>*/
        $(
      TEST NUMBERED THEN $(
         WRCH(' ')
//CII         IF NUMBERCHARS!7='0' THEN $(
//CII            NUMBERCHARS!7:=' '
//CII            IF NUMBERCHARS!6='0' THEN $(
//CII               NUMBERCHARS!6:=' '
//CII               IF NUMBERCHARS!5 ='0' THEN NUMBERCHARS!5:=' '
//CII            $)
//CII         $)
         FOR I=0 TO 5 DO $(
            TEST NUMBERCHARS!I='0' THEN NUMBERCHARS!I:=' '
            ELSE BREAK
         $)
//CII         WRCH('.')
         FOR N=5 TO 7 DO WRCH(NUMBERCHARS!N)
         WRCH(' ')
      $)
      ELSE WRITEF(" %I4",LINENO-1)
   $)
   WRCH(' ')
   FOR N=0 TO 2 DO WRCH(FSYM!N)
   WRCH(' ')
   TEST P.LOCF THEN $(
      WRITEHEX(P.LOC,4)
      P.LOC:=P.LOC+1
   $)
   ELSE WRITES("    ")
   WRCH(' ')
   WRCH(SYMTYPE(P.CODET!0))
   WRCH(' ')
    INTYPE:=(!(NAMEP!GLOBT)>>11)&1
   INNUM:= !(NAMEP!GLOBT)&#XFF
   TEST INTYPE=0 THEN $(   // NOT A PSEUDO OP OR DELCARARTIPN
      LET MAXBYTES=P.CODEN>8->8,P.CODEN
      FOR I=0 TO MAXBYTES DO WRITEHEX(TWOSCOMP(P.CODEV!I),2)
      FOR I=0 TO (8-MAXBYTES) DO WRITES("  ")
      P.LOC := P.LOC + MAXBYTES
      P.CODEN:=P.CODEN-MAXBYTES
   $)
   ELSE $(
      TEST INTYPE=0 THEN INSIZE:=0
      ELSE TEST INNUM=#X26 THEN INSIZE:=0
           ELSE INSIZE:=1
      // INSIZE IS 0 FOR INSTRUCTIONS AND  AND PSEUDO OP DB
      // ALL OTHER PSEUDO OPS ARE 1
      TEST P.CODEN>=0 THEN $(
         TEST INNUM=#X27 THEN $( WRITEHEX(TWOSCOMP(P.CODEV!0),2)
                                 WRITEHEX(TWOSCOMP(P.CODEV!1),2)
                                 $)
         ELSE $(
             WRITEHEX(TWOSCOMP(P.CODEV!0),INSIZE*2+2)
            IF INSIZE=0 THEN WRITES("  ")
            $)
         $)
      ELSE  WRITES("    ")
      WRITES("                ")
      P.LOC:=P.LOC+INSIZE
      $)
   WRITES("  ")
    $(
   FOR N=0 TO 71 DO $(
      IF LINE!N='*N' THEN BREAK
    WRCH(LINE!N)
   $)
   $)
   WRCH('*N')
    IF LISTINGCONTROL=L.ALL THEN $(
      LET N=1+INSIZE
     UNTIL N > P.CODEN DO $(
         INCRLINES()
         SPACES(10)
         WRITEHEX(P.LOC,4)
         P.LOC:=P.LOC+(INSIZE+1)
         WRCH(' ')
         WRCH(SYMTYPE(P.CODET!N))
         WRCH(' ')
         FOR I=0 TO INSIZE DO WRITEHEX(TWOSCOMP(P.CODEV!(I+N)),2)
         WRCH('*N')
         N:=N+1+INSIZE
      $)
   $)
    INITLISTCONTROL()
$)
 AND INITLISTCONTROL() BE $(
   P.LOCF:=FALSE
   FOR N=0 TO 2 DO FSYM!N:=' '
   FNO:=0
   P.CODEN:=-1
   P.CODET!0:=T.NULL
$)
 AND MNEWLINES(N) BE $(
   UNLESS LISTINGCONTROL=L.NO THEN $(
      FOR J=1 TO N DO $(
         WRITES(" *N"); INCRLINES()
      $)
    $)
$)
 AND MNEWPAGE() BE $(
   UNLESS LISTINGCONTROL=L.NO THEN $(
      PAGE:=PAGE+1
      WRITEF("*P BCPL 8086 ASSEMBLER VERSION %N",VERSIONNUMBER)
      WRITEF("  DATE %S          PAGE %N*N",DATE(),PAGE)
      WRITEF("  %S --- SECTION %S",TTL,PGM)
      WRITES(" *N *N *N")
      LINES:=4
   $)
$)
.