/******************************************
             *                                         *
             *  M E M O R Y  A R R A Y  R E D C O D E  *
             *                                         *
             *           Compiler                      *
             *        (c) by G.Woigk, Erlangen         *
             *           Version 1.0 11.1988  icws '86 *
             *           Version 2.0 12.1990  icws '90 *
             *                                         *
             ***************************************gw*/

SC=$4000;
/*-L*/;/*+M*/;/*+T*/;

SHELLMODULE MARS;
RCC:'RCC';

PROBLEM; /* -------------------------------------------------------- */

SPC LOGBUCH DATION OUT ALPHIC CONTROL(ALL) GLOBAL;
SPC D1      DATION OUT ALPHIC CONTROL(ALL) GLOBAL;

TYPE FIX FIXED(15), LONG FIXED(31), CHR CHAR, BTX BIT(16), BTZ BIT(32),
     TXT CHAR(80), STR STRUCT (/LEN FIX, TXT TXT/), BLK CHAR(64),
     ZPT STRUCT (/ (TAG,ZEIT) FIX/);

TYPE CELL STRUCT (/   /* So sieht eine Zelle des Memory Arrays aus: */
     INSTR  BTX,      /* Instruction       */
     AMODE  CHAR,     /* Modus für A-Feld  */
     BMODE  CHAR,     /* Modus für B-Feld  */
     AVALUE FIX,      /* Wert des A-Feldes */
     BVALUE FIX /);   /* Wert des B-Feldes */

TYPE LBL  STRUCT (/   /* Label-Struct:     */
     NAME CHAR(8),    /* Label-Name        */
     VAL FIX /);      /* Label-Wert        */

TYPE KPF STRUCT (/
       EMPF  FIX,    /* EMPFÄNGER (PARENT-DIRECTORY/BRETT-NR)    */
       ABS   FIX,    /* ABSENDER  (VERFASSER,SUPERVISOR)         */
       DAT   ZPT,    /* ANLAGE-ZEITPUNKT (DAT.TAG + DAT.ZEIT)    */
       NR    FIX,    /* ZETTELNUMMER (IM Z-MODUL) / NAMENSNUMMER */
       LEN   FIX,    /* ZETTEL-LÄNGE / ANZ. ZETTEL IM BRETT      */
       KEY   FIX,    /* DIVERSE AUFAGBEN / KEY & LEVEL           */
       BITS  BTX /); /* FLAGS                                    */

TYPE EINK STRUCT (/ (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P) BLK /);

TYPE MEM STRUCT (/ (NEXT,PREV) REF MEM, (BYTES,LINES) FIX, V BIT,
                   (A,B,C,D) EINK, E CHAR /);
DCL MEMLEN INV LONG INIT(4112(31));

TYPE PTR STRUCT (/ MEM REF MEM /);

TYPE MPTR STRUCT (/ ADR REF LONG, DMY LONG, TXT REF TXT /);

TYPE TMNL STRUCT (/ SYS BIT, (PORT,TMNL,BPS,CS,CZ,COLS,LINS,UML) FIX,
    (ATTR,ABLE) BTX, UMLNAME CHAR(8), EMUNAME CHAR(6),
     umli CHAR, UMLI CHAR(255), umlo CHAR, UMLO CHAR(255),
    (HDGRATTR,CRSR) BIT, IBUF TXT, (SZ,LZ,MFH,SRA,SRE,LVP)FIX,
    (WHATTODO,LEVEL,BRETT,USER,ZEIT,ERROR,RESERVE,DONTCUT,ZZ) FIX,
    (LOGIN,ZPT) ZPT, Y LONG, Z FLOAT, STR REF STR, ESC CHAR,
    (KS1,KS2,PROMPT,EINGABE) STR, POS MPTR, HOOKOFF CHAR(20),
    (RELOG,EXIT,BREAK,EOL,MAINPW,CWF,FIXBPS,MSGSOFF,CTRLA) BIT,
    (PRGBPS,MSGS,KONF,CCNT) FIX, SUBTASK CHAR(10), DELAY FIX /);

SPC (MOVMEM,SELECTZETTEL,PREVZETTEL,ZETTELKOPF,Z_HEAD,LOESCHEZETTEL,
     Z_READ1,Z_WRITE,VKOPFANLEGEN,ZERASE) ENTRY GLOBAL;
SPC FIXTOCH2 ENTRY RETURNS(CHAR(2)) GLOBAL;
SPC (SETATTR,XSENDEN,OUTPUT) ENTRY GLOBAL;
SPC  MENUE ENTRY RETURNS(FIX) GLOBAL;
SPC (MENUEZEILE,NORMALISED) ENTRY RETURNS(STR) GLOBAL;
SPC (SEEKMENUE,SCRIPT) ENTRY GLOBAL;
SPC (BRETTNUMMER,WAHL) ENTRY RETURNS(FIX) GLOBAL;
SPC (NGETNAMES,NRENAME,NGETNAME,NGETNR) ENTRY GLOBAL;
SPC (EMPTYSTR,SAMESTR,ZIFFER) ENTRY RETURNS(BIT) GLOBAL;
SPC (RND,MIN,MAX,FIXEDVALUE) ENTRY RETURNS(FIX) GLOBAL;
SPC (LONGTOSTR,CATSTR,LEFTSTR,RIGHTSTR) ENTRY RETURNS(STR) GLOBAL;
SPC SPACESTR ENTRY RETURNS(STR) GLOBAL;
SPC (BITVALUE,HEXVALUE) ENTRY RETURNS(BTX) GLOBAL;
SPC (CUTSPACES,SKIPSPACES,ADDTXTTOSTR,INSERTSTR) ENTRY GLOBAL;
SPC (INSTR,INCHR) ENTRY RETURNS(FIX) GLOBAL;
SPC (TOSTR,TAGESTEXT,MIDSTR) ENTRY RETURNS(STR) GLOBAL;
SPC DATETOTXT ENTRY RETURNS(CHAR(8)) GLOBAL;
SPC (FIXTOTXT,CLKTOTXT) ENTRY RETURNS(CHAR(5)) GLOBAL;
SPC FIXTOCH4 ENTRY RETURNS(CHAR(4)) GLOBAL;
SPC (CHECKNAME,JETZT) ENTRY GLOBAL;
SPC (SEND,SENDEN,SENDCR,SENDCHAR) ENTRY GLOBAL;
SPC (READCHAR,TESTCHAR,WAITCHAR) ENTRY RETURNS(CHAR) GLOBAL;
SPC (BACKCHAR,FLUSHINPUT) ENTRY GLOBAL;
SPC (BELL,OUTCR,OUTCHAR,OUTPOLY,OUTSTR,OUTTXT,SPACES) ENTRY GLOBAL;
SPC (HIP,LED,TEXTEDITOR) ENTRY GLOBAL;
SPC UC ENTRY RETURNS(CHAR) GLOBAL;

SPC GET_TASKNAME ENTRY RETURNS(CHAR(24)) GLOBAL;
SPC GSEM SEMA GLOBAL;
SPC AP CHAR GLOBAL;
SPC DEVICE() TMNL GLOBAL;

DCL (OK,ABKALIAS,KEINRECHT,SUBTASKERROR) INV FIX INIT(0,3,19,26);

/* ------------------------------- Konstanten --------------------- */

DCL LEEREZELLE CELL;            /* eine "leere" Zelle               */
DCL MSK    BTX INIT('1FFF'B4);  /* Force-Legal-Maske für Core-Adr.  */

/* -------------- UP's -------------------------------------------- */

CINIT: PROC;
  LEEREZELLE.AMODE='#';
  LEEREZELLE.BMODE='#';
END;

FTC4: PROC (N FIX) RETURNS(CHAR(4)) REENT;
  IF N>=0 THEN RETURN(FIXTOCH4(N));FIN;
  N=-N;
  RETURN('-'><TOCHAR(48+N//100)><FIXTOCH2(N));
END;

/* ***************************************************************** */
/*                                                                   */
/*                     M A R S - C O M P I L E R                     */
/*                                                                   */
/* ***************************************************************** */


/* UP: Ausdrucks-Auswertung für A- oder B-Feld */

ENUMERA: PROC (S CHAR(60),            /* aktuelle Zeile              */
              (PC,Z,ZL) FIX IDENT,    /* wie bei Proc 'Argumente'    */
               L() LBL IDENT,         /* Label-Feld                  */
               MODE CHAR IDENT,       /* Rückgabe: Adressierungsart  */
               VALUE FIX IDENT,       /* Rückgabe: Ausdrucks-Wert    */
               ERRMSG CHAR(20) IDENT) /* Fehler -> Text in ErrMsg &  */
      RETURNS (BIT);                  /*           Return (false)    */

DCL KF BIT,                           /* Kommaflag: Skip max 1 Komma */
    LZ REF LBL,                       /* Labelzeiger bei Labelsuche  */
    LN CHAR(8),                       /* Suchname bei Labelsuche     */
    C REF CHAR,                       /* Lesezeiger in Sourcezeile   */
    N FIX,                            /* benutzt zum Zahlenbasteln   */
    VZ FIX;                           /* Vorzeichen zu N             */

C=S.CHAR(Z);KF='0'B;VALUE=0;
PE1:WHILE Z<=ZL AND C==' ' REPEAT;CALL REFADD(C,1);Z=Z+1;END;
    IF Z>ZL THEN ERRMSG='ARGUMENT MISSING';RETURN('0'B);FIN;
    IF C==',' THEN                                   /* skip 1 Komma */
      IF KF THEN GOTO PE9;FIN;
      KF='1'B;CALL REFADD(C,1);Z=Z+1;GOTO PE1;
    FIN;

MODE='$';                               /* bestimme Adressierungsart */
IF C=='#' OR C=='$' OR C=='§' OR C=='<' THEN MODE=C;
  CALL REFADD(C,1);Z=Z+1;IF C==' ' THEN CALL REFADD(C,1);Z=Z+1;FIN;
FIN;

REPEAT;          /* Ausdruck = Summe aller N mit Vorzeichen + oder - */
  VZ=1;                                            /* "+" by Default */
  IF C=='-' OR C=='+' THEN         /* übernehme VZ falls es vorkommt */
    IF C=='-' THEN VZ=-1;FIN;
    CALL REFADD(C,1);Z=Z+1;IF C==' ' THEN CALL REFADD(C,1);Z=Z+1;FIN;
  FIN;
  IF Z>ZL THEN GOTO PE9;FIN;
  IF TOFIXED(C)>64 THEN
    LN='';                                            /* ** Label ** */
    FOR I TO 8 WHILE Z<=ZL AND TOFIXED(C)>=48 REPEAT;  /* Lese Namen */
      LN.CHAR(I)=C;CALL REFADD(C,1);Z=Z+1;        /* aus Sourcezeile */
    END;
    IF Z<=ZL AND TOFIXED(C)>=48 THEN
      ERRMSG='WRONG LABEL';RETURN('0'B);
    FIN;
    LZ=L(1);                                 /* Suche Label in Liste */
    TO 1 UPB L -1 WHILE LZ.NAME/=' ' AND LZ.NAME/=LN REPEAT;
      CALL REFADD(LZ,1);
    END;
    IF LZ.NAME/=LN THEN ERRMSG='LABEL NOT FOUND';RETURN('0'B);FIN;
    N=LZ.VAL-PC;                              /* relativieren zum PC */
  ELSE
    IF TOFIXED(C)<48 OR TOFIXED(C)>=58 THEN GOTO PE9;FIN;
    N=0;                                               /* ** Zahl ** */
    TO 4 WHILE Z<=ZL AND TOFIXED(C)>=48 AND TOFIXED(C)<58 REPEAT;
      N=N*10+TOFIXED(C)-48;Z=Z+1;CALL REFADD(C,1);      /* Lese Zahl */
    END;                                          /* aus Sourcezeile */
    IF Z<=ZL AND TOFIXED(C)>=48 AND TOFIXED(C)<58 THEN
      ERRMSG='NUMBER TOO BIG';RETURN('0'B);
    FIN;
  FIN;
  VALUE=TOFIXED(TOBIT(VALUE+VZ*N)AND'1FFF'B4);     /* add N zum Wert */
  IF C==' ' THEN CALL REFADD(C,1);Z=Z+1;FIN;
  IF Z>ZL OR (C/='+' AND C/='-') THEN         /* Ausdruck ist zuende */
    IF VALUE>=7193 THEN VALUE=VALUE-8192;FIN;       /* -999 ... 7192 */
    RETURN('1'B);                                      /* Fehlerfrei */
  FIN;
END;                           /* sonst weiter mit +/- nächster Zahl */

PE9: ERRMSG='SYNTAX ERROR';RETURN('0'B);         /* allg. Error-Exit */
END;

                                     /* UP: A- und B-Feld auswerten  */
ARGUMENTS: PROC(S CHAR(60),          /* aktuelle Zeile               */
                PC FIX IDENT,        /* zugehöriger PC               */
                Z  FIX IDENT,        /* Spaltenindex des Parsers     */
                ZL FIX,              /* Zeilenlänge ohne Kommentar   */
                L()LBL IDENT,        /* Label-Feld                   */
                CZ CELL IDENT,       /* Ein: Instr, Aus: A- & B-Feld */
                ERRMSG CHAR(20)IDENT);   /* na watt dett woll iss .. */

  IF CZ.INSTR/='0'B4 AND CZ.INSTR/='000A'B4 THEN/* A-Feld Auswertung */
    IF NOT ENUMERA(S,PC,Z,ZL,L,CZ.AMODE,CZ.AVALUE,ERRMSG) THEN
      RETURN;                             /* wenn ein Fehler auftrat */
    FIN;
    IF CZ.AMODE=='#' THEN IF (CZ.INSTR OR '0003'B4) == '0007'B4 THEN
                           /* CZ.INSTR>=4 AND CZ.INSTR<=7 THEN */
      GOTO A1;             /* JMP, JMZ, JMN, DJN  niemals immediate! */
    FIN;FIN;
  FIN;

  IF CZ.INSTR/='0004'B4 THEN                    /* B-Feld Auswertung */
    IF NOT ENUMERA(S,PC,Z,ZL,L,CZ.BMODE,CZ.BVALUE,ERRMSG) THEN
      RETURN;                             /* wenn ein Fehler auftrat */
    FIN;
    IF CZ.INSTR=='0'B4 THEN
      IF TOFIXED(CZ.BMODE)>49 THEN  /* DAT nur immediate evtl direkt */
A1:     ERRMSG='WRONG MODE';RETURN;
      FIN;
      CZ.BMODE='#';         /* DAT #nn == DAT $nn  (wichtig für CMP) */
    ELSE
      IF CZ.BMODE=='#' THEN IF CZ.INSTR=='000A'B4/*OR CZ.INSTR<=3*/ THEN
        GOTO A1;           /* SPL, MOV, ADD, SUB  niemals immediate! */
      FIN;FIN;
    FIN;
  FIN;

  IF Z<=ZL THEN ERRMSG='END OF LINE EXPECTED';FIN;
END;


INSTRNR: PROC (I CHAR(3)) RETURNS(BTX);    /* UP: Instruction-Nummer */
  IF I=='DAT' THEN RETURN ('0000'B4);FIN;
  IF I=='MOV' THEN RETURN ('0001'B4);FIN;
  IF I=='ADD' THEN RETURN ('0002'B4);FIN;
  IF I=='SUB' THEN RETURN ('0003'B4);FIN;
  IF I=='JMP' THEN RETURN ('0004'B4);FIN;
  IF I=='JMZ' THEN RETURN ('0005'B4);FIN;
  IF I=='JMN' THEN RETURN ('0006'B4);FIN;
  IF I=='DJN' THEN RETURN ('0007'B4);FIN;
  IF I=='CMP' THEN RETURN ('0008'B4);FIN;
  IF I=='SPL' THEN RETURN ('000A'B4);FIN;
  RETURN('99'B4);  /* Error */
  END;


GETLINE: PROC (T TMNL IDENT, S STR IDENT, Z FIX IDENT,
               MM MEM IDENT, ZN FIX, (POS,LEN) LONG IDENT) REENT;
  DCL C REF CHAR;
  IF Z>=MM.BYTES THEN
    IF LEN<=0(31) THEN T.ERROR=202;RETURN;FIN; /* EOF */
G1:
    CALL Z_READ1(T,ZN,POS,LEN,MM);
    IF T.ERROR/=OK THEN RETURN;FIN;
    Z=0;
  FIN;

  C=MM.A.A.CHAR(1);CALL REFADD(C,Z);
  S.LEN=TOFIXED(C)-32;
  IF S.LEN<0 OR S.LEN>80 THEN S.LEN=0;FIN;
  IF Z+S.LEN>=MM.BYTES THEN  /* Z+S.LEN+1>MM.BYTES */
    IF Z==0 THEN
      PUT 'MARS: GETLINE: ERROR!' TO LOGBUCH BY A,SKIP;
      T.ERROR=202;
      RETURN;
    FIN;
    POS=POS-(MM.BYTES-Z);
    LEN=LEN+(MM.BYTES-Z);
    GOTO G1;
  FIN;

  CALL REFADD(C,1);
  CALL MOVMEM(C,S.TXT.CHAR(1),S.LEN);
  Z=Z+S.LEN+1;
  T.ERROR=OK;
END;

/* -------------- C o m p i l i e r e  QDAT -> ZDAT ---------------- */

/* REDCODE COMPILER:
   Auf Terminal T
   compiliert Z_Zettelnummer SZN -> XMM Memory-Modul
   Source kann beliebig lang sein
   Destination max. 512 Instructions: XMM.NEXT immer NIL !
*/

COMP: PROC (T TMNL IDENT, SZN FIX,(P0,L0) LONG,XMM MEM IDENT) REENT;

DCL L(100) LBL,                              /* Array für alle Label */
    LZ REF LBL, NL CHAR(8), /* Zeiger in L() und Name für neue Label */
    (S,S2) STR,                                 /* Akt. Sourcezeile. */
    PC FIX,                /* Programm Counter zu dieser Sourcezeile */
    Z FIX, C REF CHAR,       /* Lesezeiger und -Index in Sourcezeile */
    SP FIX,                /* PC des Label "START" falls es vorkommt */
    IS CHAR(3),      /* Hilfszelle zum Auslesen der MARS-Instruction */
    ERRMSG CHAR(20),ERR FIX, /* Fehlermeldg. wenn nicht leer, Zähler */
    SI FIX, SMM MEM, (LEN,POS)LONG,               /* Source-Handling */
    lz REF LONG, l LONG, cz REF BLK, CZ REF CELL;
                                             /* Destination-Handling */

ERR=0;SP=0;                                      /* Inits */
FOR I TO 1 UPB L REPEAT;L(I).NAME='';END;

lz=l;CALL REFADD(lz,1);cz=XMM.A.A;l=lz;            /* init Zieldatei */
CALL REFADD(lz,1);CONT lz=l;

                                           /* Pass 1: Bestimme Label */
FOR PASS TO 2 WHILE ERR==0 REPEAT;         /* Pass 2: Assembliere    */
  T.ERROR=OK;
  CALL SENDEN(T,TOSTR('*** '><TOCHAR(48+PASS)><'. Durchgang ***'));
  CALL SENDCR(T);

  SI=0;SMM.BYTES=0;LEN=L0;POS=P0;                /* Öffne Quelldatei */
  PC=0;                                                   /* init PC */

P1:                              /* Schleife über alle Source-Zeilen */
  CALL GETLINE(T,S,SI,SMM,SZN,POS,LEN);S2=S;           /* Lese Zeile */
  IF T.ERROR/=OK THEN GOTO P3;FIN;                       /* Loop End */

  ERRMSG='';                      /* init Fehlermeldung: kein Fehler */
  CONT CZ=LEEREZELLE;CZ.INSTR='99'B4;/*init Corezelle leer,kein Code */

  Z=INCHR(S,';',1);IF Z/=0 THEN S.LEN=Z-1;FIN;       /* clip comment */
  Z=INSTR(S,SPACESTR(10),1);IF Z/=0 THEN S.LEN=Z-1;FIN;
  IF EMPTYSTR(S) THEN GOTO P2;FIN;           /* reine Kommentarzeile */

  C=S.TXT.CHAR(1);Z=1;            /* init Zeichenzeiger und -Index */
  IF C/=' ' THEN                                  /* *** Label *** */
    IF PASS==1 THEN                /* Pass 1 => in Liste aufnehmen */
      IF TOFIXED(UC(C))<65 OR TOFIXED(UC(C))>93 THEN
        ERRMSG='WRONG LABEL';GOTO P2;
      FIN;
      NL='';
      WHILE Z<=8 AND TOFIXED(C)>=48 AND C/=':' AND C/=';' REPEAT;
        NL.CHAR(Z)=C;Z=Z+1;CALL REFADD(C,1);      /* Name auslesen */
      END;
      IF (C/=' ' AND C/=':' AND C/=';') THEN
        ERRMSG='WRONG LABEL';GOTO P2;
      FIN;
      LZ=L(1);                              /* suche nächsten Slot */
      TO 1 UPB L -1 WHILE NL/=LZ.NAME AND LZ.NAME/=' ' REPEAT;
        CALL REFADD(LZ,1);
      END;
      IF LZ.NAME/=' ' THEN ERRMSG='DOUBLE DEF';GOTO P2;FIN;
      LZ.NAME=NL;LZ.VAL=PC;                           /* eintragen */
      IF NL=='START' OR NL=='Start' OR NL=='start' THEN
        SP=PC;                                 /* Test auf "START" */
      FIN;
    ELSE                              /* Pass 2 => Skip Definition */
      WHILE C/=' ' AND C/=':' AND C/=';' REPEAT;
        CALL REFADD(C,1);Z=Z+1;
      END;
    FIN;
    IF C==':' THEN CALL REFADD(C,1);Z=Z+1;FIN;     /* ":" optional */
  FIN;

  CALL SKIPSPACES(S,Z);                                /* Skip Gap */
  IF Z>S.LEN THEN GOTO P2;FIN;               /* Rest ist Kommentar */
  C=S.TXT.CHAR(Z);
                                                    /* fetch Instr */
  FOR I TO 3 REPEAT;IS.CHAR(I)=UC(C);CALL REFADD(C,1);END;Z=Z+3;
  CZ.INSTR=INSTRNR(IS);                            /* Get Instr-Nr */

  IF CZ.INSTR=='99'B4 THEN     /* check out for pseudo instructions */
    IF IS=='END' THEN GOTO P3;FIN;
    ERRMSG='ILL. INSTR.';
  ELSE IF PASS==2 THEN  /* Legal Instr. & Pass 2: Argument-Auswertung */
      CALL ARGUMENTS(S.TXT,PC,Z,S.LEN,L,CZ,ERRMSG);
    FIN;
  FIN;

P2:                                            /* Compiler-Listing */
  IF S2.LEN>62 THEN S2.LEN=62;FIN;
  IF CZ.INSTR=='99'B4 THEN
    CALL SPACES(T,17);CALL SENDEN(T,S2);        /* kein Object-Code */
  ELSE
    CALL SEND(T,TOSTR(IS><' '><CZ.AMODE><FTC4(CZ.AVALUE)><
                          ','><CZ.BMODE><FTC4(CZ.BVALUE)));
    CALL SPACES(T,2);
    CALL SENDEN(T,S2);
    IF PASS==2 THEN                              /* Save Object-Code */
      CZ.INSTR=CZ.INSTR SHIFT 2;
      CZ.INSTR.BIT(1)=PC==SP;
      CZ.AVALUE=TOFIXED(TOBIT(CZ.AVALUE) SHIFT 3);
      CZ.BVALUE=TOFIXED(TOBIT(CZ.BVALUE) SHIFT 3);
      CALL REFADD(CZ,1);
    FIN;
    PC=PC+1;                                /* Object-Code erzeugt */
  FIN;
  IF ERRMSG/=' ' THEN ERR=ERR+1;           /* falls Fehler auftrat */
    S.TXT=ERRMSG;                            /* zeige welchen & wo */
    S.LEN=MIN(Z+16,79);
    S.TXT.CHAR(S.LEN)='^';
    CALL SENDEN(T,S);
  FIN;

  GOTO P1;  /* *********** end of loop over all lines ************ */

P3:
  IF PC<=0 THEN
    CALL SENDEN(T,TOSTR('SOURCE INPUT FAIL'));
    ERR=ERR+1;
  FIN;
  IF PC>512 THEN /* MAX. MÖGL. CODE-LEN IN XMM !! */
           /* PASS 2 DARF NICHT DURCHLAUFEN WERDEN FÜR PC >= 512 !! */
    CALL SENDEN(T,TOSTR('COMPILED WARRIOR EXCEEDS 512 INSTRUCTIONS'));
    ERR=ERR+1;
  FIN;
  CALL SENDCR(T);
END;                                    /* of Loop over Pass 1 and 2 */

  CALL SENDEN(T,TOSTR('ERRORS: '><FIXTOCH2(ERR)));
  CALL SENDCR(T);
  XMM.BYTES=8*PC;
  XMM.NEXT=NIL;
  T.ERROR=OK;IF ERR/=0 THEN T.ERROR=26; /* subtask-error */ FIN;
END;  /* OF PROCEDURE */


/* ************************* REDCODE COMPILER ********************** */

RCC: PROC ( STDIN          DATION IN  ALPHIC CONTROL(ALL) IDENT,
           (STDOUT,STDERR) DATION OUT ALPHIC CONTROL(ALL) IDENT,
            L FIX, PAR CHAR(255)) RETURNS(BIT);
  DCL T REF TMNL, (ZZ,N,ZN,P,B,S,X) FIX, OWNNAME CHAR(24),
      (BETREFF,NAME) STR, (POS,LEN)LONG,  TYP BTX, KOPF KPF, XMM MEM;

  OWNNAME=GET_TASKNAME;

  P=TOFIXED(OWNNAME.CHAR(4))-47;
  IF P<1 OR P>1 UPB DEVICE OR L==0 OR
     OWNNAME/='RCC'><OWNNAME.CHAR(4) THEN
     PUT 'RCC, der Redcodecompiler. Nur aus dem KMS-Script aufrufen!',
         'use: CALL "RCC PRIO 15 <Betreff|Kampfprogrammname>"'
         TO STDERR BY A,SKIP;
     RETURN('0'B);
  FIN;

  CALL CINIT;
  XMM.NEXT=NIL;
  T=DEVICE(P);
  B=T.BRETT;                    /* ASSUMED TO BE "ROOT/GAMES/MARS"  */

  CALL XSENDEN(T,
       TOSTR('^I^RedFox^0^ Redcode-Compiler --- Impl: icws 1990'));
  CALL SENDEN(T,TOSTR('       © 12.90 G.Woigk (KIO !)'));
  CALL SENDCR(T);

  S=BRETTNUMMER(T,TOSTR('SO')); /* S := BRETTNUMMER DER SOURCEN     */
  IF T.ERROR>ABKALIAS THEN RETURN('1'B);FIN;

  X=BRETTNUMMER(T,TOSTR('EX')); /* X := BRETTNUMMER DER EXECUTABLES */
  IF T.ERROR>ABKALIAS THEN RETURN('1'B);FIN;

  NAME.TXT=PAR;NAME.LEN=L;
  NAME=NORMALISED(NAME);

/* SUCHE UND LADE WARRIOR SOURCE */
  CALL SELECTZETTEL(T,32500);
RCC1:
  CALL PREVZETTEL(T,T.USER,S);
  IF T.ERROR/=OK THEN RETURN('1'B);FIN;
  CALL ZETTELKOPF(T.PORT,ZN, KOPF);ZN=KOPF.NR;
  CALL Z_HEAD(T,ZN,POS,LEN,TYP,ZZ,BETREFF);
  IF T.ERROR/=OK THEN GOTO RCC1;FIN;
  IF TYP.BIT(16) THEN /* BINÄRFILE */ GOTO RCC1;FIN;
  IF INSTR(NORMALISED(BETREFF),NAME,1)/=1 THEN GOTO RCC1;FIN;

/* COMPILIERE */

  CALL SEND(T,TOSTR('compiling'));CALL OUTCHAR(T,' ');
  CALL SENDEN(T,BETREFF);
  CALL SENDCR(T);

  CALL COMP(T,ZN,POS,LEN,XMM);
  IF T.ERROR/=OK /* COMPILER-ERROR */ THEN RETURN('1'B);FIN;

/* LÖSCHE EVTL. EXISTIERENDEN ALTEN WARRIOR */
  CALL SELECTZETTEL(T,32500);
RCC2:
  CALL PREVZETTEL(T,T.USER,X);
  IF T.ERROR/=OK THEN GOTO RCC3;FIN;
  CALL ZETTELKOPF(T.PORT,ZN, KOPF);ZN=KOPF.NR;
  CALL Z_HEAD(T,ZN,POS,LEN,TYP,ZZ,NAME); /* NAME := BETREFF2 */
  IF T.ERROR/=OK THEN GOTO RCC2;FIN;
  IF NOT TYP.BIT(16) THEN /* TEXTFILE */ GOTO RCC2;FIN;
  IF NOT SAMESTR(NAME,BETREFF) THEN GOTO RCC2;FIN;
  CALL LOESCHEZETTEL(T.PORT);

RCC3:
/* SPEICHERE */
  CALL Z_WRITE(T,ZN,'00F1'B4,0,BETREFF,XMM);
  CALL VKOPFANLEGEN(T.USER,X,ZN,'1'B,N,T.ERROR);
  IF T.ERROR/=OK THEN CALL ZERASE(ZN);FIN;
  RETURN('1'B);
END;

MODEND;