SECTION"STR"
GET "AHDR"

MANIFEST $( maxint.div.10 = maxint/10
            maxint.rem.10 = maxint REM 10
         $)

LET START(PARM) BE $(
   LET sco = createco(startc, 650)

 TEST sco=0 DO writes("*NNot enough store to create *'startc*'*N")
 OR
 $(
   callco(sco, 0)
   deleteco(sco)
 $)
$)


AND startc(parm) BE $(
   LET V1=VEC 20                     // PGM
   AND V2=VEC 20                     // TTL
   AND V3=VEC 72                     // P.CODEV
   AND V4=VEC 72                     // P.CODET
   AND V5=VEC 80                     // PROG.NAME
   AND V6=VEC 2                      // FSYM
   AND V7=VEC 80                    // LINE
   AND V8=VEC 8                     // DUMPV
   AND V9=VEC 39                    // BIN
   AND V10=VEC 8                     // RELBITS
   AND V11=VEC 7                        //NUMBERCHARS
   AND V12=VEC 72                       //PARMV
   AND pv = ?
   AND ACNT,RCNT=0,0                 // ABS AND REL COUNTERS
   AND mainco = ?                   // coroutine for MAIN
   AND vecsize = ?                  // size for APTOVEC
    PGM:=V1; TTL:=V2
   P.CODEV:=V3; P.CODET:=V4
   PROG.NAME:=V5
   FSYM:=V6
   LINE:=V7
   DUMPV:=V8; BIN:=V9; RELBITS:=V10
   NUMBERCHARS:=V11
   pv := v12
   ABSC:=@ACNT; RELC:=@RCNT
    VERSIONNUMBER:=2
    //SETUP FILE NAMES
   listfile := "NIL:"
    //SETUP SIZE OF WORK SPACES
   DICTSIZE:=1000     //CHARACTERS
   LISTSIZE:=2000     //WORDS
   termstr := output()
   cdsize := 500    // words
   rvsize := 100    // words
   NAMESIZE:=512    //WORDS (A POWER OF TWO!!!)
   INANALSIZE:=500

   IF rdargs("from/A,to/A/K,list/K,prof/S,cross/S,short/S,*
              *dicts/K,lists/K,cds/K,rvs/K,names/K,inanals/K",
             pv, 72)=0 DO
   $( writes("*NBad args*N")
      stop(5)
   $)

   assfile := pv!0; lgo := pv!1
   UNLESS pv!2=0 DO listfile := pv!2
   profil := pv!3; crossref := pv!4; shortcrossref := pv!5

      UNLESS pv!6=0 DO $( UNLESS strnum(pv!6) GOTO badn; dictsize := result2 $)
      UNLESS pv!7=0 DO $( UNLESS strnum(pv!7) GOTO badn; listsize := result2 $)
      UNLESS pv!8=0 DO $( UNLESS strnum(pv!8) GOTO badn; cdsize := result2 $)
      UNLESS pv!9=0 DO $( UNLESS strnum(pv!9) GOTO badn; rvsize := result2 $)
      UNLESS pv!10=0 DO $( UNLESS strnum(pv!10) GOTO badn; namesize :=result2 $)
      UNLESS pv!11=0 DO
      $( UNLESS strnum(pv!11) GOTO badn; inanalsize := result2
      $)
    ASSFILESTR:=FINDINPUT(ASSFILE)
   PENDINGLINE:=FALSE

   vecsize := listsize+1+
              4*namesize+4+
              dictsize/bytesperword+1+
              inanalsize+1+
              cdsize+1+
              rvsize+1+
              72+4*(72/bytesperword)    // safety factors
   mainco := createco(mainc, vecsize+650)
 TEST mainco=0 DO writes("*NNot enough store to create *'mainco*'*N")
 OR
 $(
   callco(mainco, vecsize)
   deleteco(mainco)
 $)
 RETURN

 badn: writes("*NBad number in argument*N")
       stop(6)
$)


AND strnum(string) = VALOF
// Convert string to number routine
// Returns TRUE if STRING represents a valid number
// (number in RESULT2), FALSE otherwise
$( LET len = string%0
   LET pos = TRUE
   LET ch = ?
   IF len=0 RESULTIS FALSE
   result2 := 0

   FOR i = 1 TO len DO
   $( LET ch = string%i
      IF ch='-' | ch='+' DO
      $( IF i\=1 | len=1 RESULTIS FALSE
         pos := ch='+'
         LOOP
      $)

      UNLESS '0'<=ch<='9' RESULTIS FALSE

      IF result2>maxint.div.10 |
         (result2=maxint.div.10 &
            [ch-'0']>[maxint.rem.10 + (pos -> 0, 1)])
      THEN RESULTIS FALSE

      result2 := result2*10 + ch - '0'
   $)
   UNLESS pos DO result2 := -result2
   RESULTIS TRUE
$)


AND mainc(n) BE aptovec(main, n)


 AND MAIN(V,S) BE $(
   LET PART=0
   AND KLINE=VEC 72
   AND VVV=VEC 80
   AND KLAB,KARG,KOP=0,0,0
 //NUMBERS IN BRACKETS ARE SAFETY FACTORS USUALLY ONE LINE OF 72 CHARS
   VX:=VVV       // GLOB VECTOR FOR OBJECT MODULE TEXT
   v := v+72
   DICT:=V; V:=V+DICTSIZE/BYTESPERWORD+1
   DICTMAX:=V*BYTESPERWORD-1; V:=V+(72/BYTESPERWORD)
   LISTSPACE:=V; V:=V+LISTSIZE+1
   LSPACEMAX:=V-1
   v := v+(72/bytesperword)
   NAMEP:=V; V:=V+2*NAMESIZE+2
   SNAME:=V; V:=V+NAMESIZE+1
   ONAME:=V; V:=V+NAMESIZE+1
   V:=V+(72/BYTESPERWORD)
   INANAL:=V
   INTOP:=V+INANALSIZE
   codevec := intop+1+(72/bytesperword)
   relvecc := codevec+cdsize+1
   rsym := rstream
   inparform := FALSE
   INSTR:=ASSFILESTR
  SELECTINPUT(INSTR)
   $(     //START OF BIG LOOP
      PASS:=1
      // CLEAR OUT SYMBOL TABLES & DICTIONARY
      FOR J=0 TO INANALSIZE DO INANAL!J:=0
      FOR J=0 TO DICTSIZE/BYTESPERWORD DO DICT!J:=0
      FOR J=0 TO NAMESIZE*2 DO NAMEP!J:=0
      FOR J=0 TO NAMESIZE DO SNAME!J,ONAME!J:=-1,-1
      FOR J=0 TO LISTSIZE DO LISTSPACE!J:=0
      !ABSC:=0; !RELC:=0; CNT:=RELC
      TOPRELCNT:=0; TOPABSCNT:=0
      // PROGRAM NAME, TITLE, ETC.
      !PROG.NAME:=0; FOR I=1 TO 6 DO PROG.NAME!I:=' '
      !PGM:=0
      !TTL:=0
      SCW:=FALSE
      // DICTIONARY POINTERS
      DP:=DICT*BYTESPERWORD
      // LISTS
      LSP:=LISTSPACE
      // SYMBOL TABLE POINTERS + DFF ENTRY IN SYMBOL TABLE
      $(
         LET V=VEC 4
         LET A=V+1
         UNPACKSTRING("DFF ",V)
         NAMEP!GETOPN(@A):=LIST(1,T.DIR+D.DFF)
      $)
       FAULTS:=0
      INITLISTCONTROL()
      // BINARY OUTPUT
      BINOUT:=FINDOUTPUT(LGO)
      PAGE:=0
      // STREAMS
      ERRSTR:=FINDOUTPUT("OUTPUT")
      SELECTOUTPUT(ERRSTR)
      INSTR:=FINDINPUT("M80P")
      IF INSTR=0 THEN $(
         FAULTS:=1
         SELECTOUTPUT(FINDOUTPUT(LISTFILE))
         WRITES(" ****** FAILURE TO ATTACH M8OP ******")
         WRITETOLOG(" ****** FAILURE TO ATTACH M8OP ******")
         endwrite()
         selectoutput(errstr)
         endwrite()
         selectoutput(binout)
         endwrite()
         selectinput(assfilestr)
         endread()
         FINISH
      $)
      SELECTINPUT(INSTR)
  /**/ DEBUG("Before first PASS1 ... *N")
      PASS1()
      ENDREAD()
      /**/ DEBUG(" PASS1 ,INSTR=%X8 *N",INSTR)
      INSTR:=ASSFILESTR
        SELECTINPUT(INSTR)
  /**/ DEBUG(" PASSS1 *N")
      IF INSTR=0 THEN $(
         FAULTS:=1
         SELECTOUTPUT(FINDOUTPUT(LISTFILE))
         WRITEF(" ****** NO INPUT FILE CALLED *"%S*"",ASSFILE)
         WRITETOLOG(" ****** NO INPUT FILE")
         endwrite()
         selectoutput(errstr)
         endwrite()
         selectoutput(binout)
         endwrite()
         selectinput(assfilestr)
         endread()
         FINISH
      $)
      UNLESS PART=0 THEN $(
         PENDINGLINE:=TRUE
         LAB,ARG,OP:=KLAB,KARG,KOP
         FOR I=0 TO 72 DO LINE!I:=KLINE!I
      $)
      NUMBERED:=TRUE
      ENDREC.P:=LEVEL(); ENDREC.L:=PASS1.RETURN
   /**/ DEBUG(" CALLING PASS1 FOR THE SECOND TIME*N")
      PASS1()
PASS1.RETURN:
      PASS:=2
/**/ DEBUG(" AFTER PASS1.RETURN")
      SELECTINPUT(INSTR); ENDREAD()
      INSTR := FINDINPUT(ASSFILE); SELECTINPUT(INSTR)
       ASSFILESTR := INSTR   // UPDATE CAUSE 'REWIND' CHANGES
      rsym := rstream
      inparform := false
       FOR I=1 TO PART DO $(
         LET J,T=0,0
         $(
            J:=READLINE() REPEATUNTIL J&(!LINE NE '**')&(OP NE 0)
            T:=GETOPN(@OP)
            IF NAMEP!T=0 THEN LOOP
            J:=!(NAMEP!T)
            UNLESS (J&#XFC00)=T.DIR DO LOOP
            J:=J&#X3FF
            IF J=D.END THEN BREAK
         $) REPEAT
         J:=READLINE() REPEATUNTIL J&(!LINE NE '**')&(OP NE 0)
         PENDINGLINE:=TRUE
      $)
       SELECTOUTPUT(FINDOUTPUT(LISTFILE))
      SELECTINPUT(INSTR)
      rsym := rstream
      LINES:=LINESPERPAGE; LISTINGCONTROL:=L.ALL; LINENO:=1
      !ABSC:=0; !RELC:=0; CNT:=RELC
      //INITIALISATION FOR LOADER NOW SET UP
      DUMPINIT()
      REC.P,REC.L:=LEVEL(),NO.END.DIR
      ENDREC.P:=REC.P; ENDREC.L:=PASS2.RETURN
/**/ DEBUG(" JUST BEFORE PASS2*N")
      PASS2()
/**/ DEBUG(" JUST AFTER PASS2*N")
   PASS2.RETURN:
      NEWLINE()
      TEST FAULTS=0 THEN WRITES(" NO ERRORS IN ASSEMBLY")
      ELSE WRITEF(" %N ERROR%S IN ASSEMBLY",FAULTS,(FAULTS=1)->"",
                "S")
      NEWLINE()
      WRITES(" ASSEMBLY COMPLETE")
      NEWLINE()
      UNLESS PROFIL=0 THEN PRINTPROFIL()
      IF CROSSREF THEN PRINTCROSSREFS()
      WRITETOLOG((FAULTS=0)->"NO ERRORS IN ASSEMBLY",
                 (FAULTS=1)->"ERROR IN ASSEMBLY",
                 "ERRORS IN ASSEMBLY")
      WRITETOLOG("ASSEMBLY COMPLETE")
      REC.P,REC.L:=LEVEL(),STOP.IT
      rsym := rstream
      endwrite() // list stream
      SELECTINPUT(INSTR)
      SELECTOUTPUT(ERRSTR)
      $(
         LET J=0
         J:=READLINE() REPEATUNTIL J&(!LINE NE '**')&(OP NE 0)
      $)
      PART:=PART+1
      KLAB,KARG,KOP:=LAB,ARG,OP
      FOR I=0 TO 72 DO KLINE!I:=LINE!I
   $) REPEAT
STOP.IT:
   endwrite() // error stream
   selectoutput(binout)
   endwrite()
   endread() // input
   stop(0)
NO.END.DIR:
   FAULTS:=FAULTS+1
   WRITES(" ****** NO END TERMINATOR ******")
      WRITETOLOG(" ****** NO END TERMINATOR ******")
   GOTO PASS2.RETURN
$)
 AND PRINTCROSSREFS() BE $(
   WRITES("*P CROSS REFERENCE*N *N *N")
   $(
      LET P,Q,R=-1,0,0
       FOR T=0 TO NAMESIZE DO $(
         UNLESS SNAME!T<0 THEN $(
            P:=T; BREAK
         $)
      $)
      IF P=-1 THEN RETURN
       FOR T=P+1 TO NAMESIZE DO $(
         UNLESS SNAME!T<0 THEN $(
            P:=VALOF $(
               LET LP,LT=GETBYTE(0,SNAME!P),GETBYTE(0,SNAME!T)
               LET L=(LP<LT)->LP,LT
               FOR I=1 TO L DO $(
                  LET CP,CT=GETBYTE(0,SNAME!P+I),GETBYTE(0,SNAME!T+I)
                  IF CP<CT THEN RESULTIS P
                  IF CT<CP THEN RESULTIS T
               $)
               IF LT<LP THEN RESULTIS T
               RESULTIS P
            $)
         $)
      $)
       IF SHORTCROSSREF THEN $(
         R:=NAMEP!P
         IF (R=0) LOGOR (R!3=0) THEN $(
            SNAME!P:=-1 //REMOVE ENTRY
            LOOP
         $)
      $)
       $( //PRINT NAME
         LET L=GETBYTE(0,SNAME!P)
         WRCH(' ')
         FOR I=SNAME!P+1 TO SNAME!P+L DO WRCH(GETBYTE(0,I))
         SNAME!P:=-1 //REMOVE ENTRY
         SPACES(14-L)
      $)
       R:=NAMEP!P
      UNLESS R=0 THEN $(
         UNLESS (!R&T.REDEF)=0 THEN WRITES("FINAL VALUE ")
         WRCH(SYMTYPE(!R&#XFC00)); WRCH(' ')
         WRITEHEX(1!R,4)
         R:=R!2
      $)
      Q:=-1
      UNTIL R=0 DO $(
         Q:=Q+1
         IF (Q REM 10)=0 THEN $(
            WRCH('*N'); SPACES(15)
         $)
         WRITEF("  **%X4",REFVALUE(R))
         R:=REFPOINTER(R)
      $)
      R:=NAMEP!P; UNLESS R=0 THEN R:=R!3
      UNTIL R=0 DO $(
         Q:=Q+1
         IF (Q REM 10)=0 THEN $(
            WRCH('*N'); SPACES(15)
         $)
         WRITEF("   %X4",REFVALUE(R))
         R:=REFPOINTER(R)
      $)
      WRCH('*N')
   $) REPEAT
 $)
 AND DEBUG(X,X1,X2,X3,X4,X5,X6,X7,X8,X9) BE $(
   LET A=OUTPUT()
   SELECTOUTPUT(ERRSTR)
   WRITEF(X,X1,X2,X3,X4,X5,X6,X7,X8,X9)
   SELECTOUTPUT(A)
 $)
AND PRINTPROFIL() BE $(
    WRITES("*P ASSEMBLER OPTIONS*N *N *N")
    WRITES(" FILE NAMES*N *N")
    WRITEF(" B=%S BINARY OUTPUT*N",LGO)
    WRITEF(" I=%S INPUT FILE*N",ASSFILE)
    WRITEF(" L=%S LISTING FILE*N *N *N",LISTFILE)
    WRITES(" EXTRA OPTIONS*N *N")
    WRITEF(" P %S PROFILE OF SPACE AND OPTIONS*N",
       PROFIL>0->"SET BY PROGRAM","SET")
    WRITEF(" S %S SHORT CROSS REFERENCE*N",
       SHORTCROSSREF->"SET","UNSET")
    WRITEF(" X %S CROSS REFERENCE (MAY BE SET BY 'S' OPTION)*N *N *N",
       CROSSREF->"SET","UNSET")
    WRITES(" SPACE AND ITS UTILISATION*N *N")
    WRITEF(" D%N CHARACTERS DICTIONARY, AMOUNT USED = %N*N",
       DICTSIZE,DP-DICT*BYTESPERWORD)
    WRITEF(" L%N WORDS LIST SPACE, AMOUNT USED = %N*N",
       LISTSIZE,LSP-LISTSPACE)
    WRITEF(" N%N WORDS SYMBOL TABLES ",NAMESIZE)
    WRITEF(" (%N WORDS, HASH CODED, A POWER OF TWO)",4*NAMESIZE)
   $(
      LET S1,S2=0,0
      FOR P=0 TO NAMESIZE-1 DO $(
         UNLESS ONAME!P=-1 THEN S1:=S1+1
         UNLESS SNAME!P=-1 THEN S2:=S2+1
      $)
      WRITEF(", AMOUNT USED = %N*N",S1>S2->S1,S2)
   $)
$)
  AND ADDREF(P,N,V) BE $(
    IF P=0 THEN RETURN
    P:=P+N
   UNTIL !P=0 DO P:=!P
    !P:=LIST(2,0,V)
 $)
  AND REFPOINTER(R)  = !R
  AND REFVALUE(R) = 1!R
 AND SPACES(M) BE FOR N=1 TO M DO WRCH(' ')
   AND ASKII(C) = C


AND CAN2WORDS(NAME,P) BE $(
   LET V=VEC 6
   AND L=GETBYTE(0,NAME)
    IF L>6 THEN L:=6  //TRUNCATE TO 6 CHARACTERS
   FOR I=1 TO L DO V!I:=GETBYTE(0,NAME+I)
   FOR I=L+1 TO 6 DO V!I:=' '
   P!0:=(CANVALUE(V!1)*40+CANVALUE(V!2))*40+CANVALUE(V!3)
   P!1:=(CANVALUE(V!4)*40+CANVALUE(V!5))*40+CANVALUE(V!6)
$)
.