(NUMBER)
"PER BRINCH HANSEN

 INFORMATION SCIENCE
 CALIFORNIA INSTITUTE OF TECHNOLOGY

 UTILITY PROGRAMS FOR
 THE SOLO SYSTEM

 18 MAY 1975"

"###########
#  PREFIX  #
###########"


CONST NL = '(:10:)';   FF = '(:12:)';   CR = '(:13:)';   EM = '(:25:)';

CONST PAGELENGTH = 512;
TYPE PAGE = ARRAY (.1..PAGELENGTH.) OF CHAR;

CONST LINELENGTH = 132;
TYPE LINE = ARRAY (.1..LINELENGTH.) OF CHAR;

CONST IDLENGTH = 12;
TYPE IDENTIFIER = ARRAY (.1..IDLENGTH.) OF CHAR;

TYPE FILE = 1..2;

TYPE FILEKIND = (EMPTY, SCRATCH, ASCII, SEQCODE, CONCODE);

TYPE FILEATTR = RECORD
                  KIND: FILEKIND;
                  ADDR: INTEGER;
                  PROTECTED: BOOLEAN;
                  NOTUSED: ARRAY (.1..5.) OF INTEGER
                END;

TYPE IODEVICE =
  (TYPEDEVICE, DISKDEVICE, TAPEDEVICE, PRINTDEVICE, CARDDEVICE);

TYPE IOOPERATION = (INPUT, OUTPUT, MOVE, CONTROL);

TYPE IOARG = (WRITEEOF, REWIND, UPSPACE, BACKSPACE);

TYPE IORESULT =
  (COMPLETE, INTERVENTION, TRANSMISSION, FAILURE,
   ENDFILE, ENDMEDIUM, STARTMEDIUM);

TYPE IOPARAM = RECORD
                 OPERATION: IOOPERATION;
                 STATUS: IORESULT;
                 ARG: IOARG
               END;

TYPE TASKKIND = (INPUTTASK, JOBTASK, OUTPUTTASK);

TYPE ARGTAG =
  (NILTYPE, BOOLTYPE, INTTYPE, IDTYPE, PTRTYPE);

TYPE POINTER = @BOOLEAN;

TYPE ARGTYPE = RECORD
                 CASE TAG: ARGTAG OF
                   NILTYPE, BOOLTYPE: (BOOL: BOOLEAN);
                   INTTYPE: (INT: INTEGER);
                   IDTYPE: (ID: IDENTIFIER);
                   PTRTYPE: (PTR: POINTER)
               END;

CONST MAXARG = 10;
TYPE ARGLIST = ARRAY (.1..MAXARG.) OF ARGTYPE;

TYPE ARGSEQ = (INP, OUT);

TYPE PROGRESULT =
  (TERMINATED, OVERFLOW, POINTERERROR, RANGEERROR, VARIANTERROR,
   HEAPLIMIT, STACKLIMIT, CODELIMIT, TIMELIMIT, CALLERROR);

PROCEDURE READ(VAR C: CHAR);
PROCEDURE WRITE(C: CHAR);

PROCEDURE OPEN(F: FILE; ID: IDENTIFIER; VAR FOUND: BOOLEAN);
PROCEDURE CLOSE(F: FILE);
PROCEDURE GET(F: FILE; P: INTEGER; VAR BLOCK: UNIV PAGE);
PROCEDURE PUT(F: FILE; P: INTEGER; VAR BLOCK: UNIV PAGE);
FUNCTION LENGTH(F: FILE): INTEGER;

PROCEDURE MARK(VAR TOP: INTEGER);
PROCEDURE RELEASE(TOP: INTEGER);

PROCEDURE IDENTIFY(HEADER: LINE);
PROCEDURE ACCEPT(VAR C: CHAR);
PROCEDURE DISPLAY(C: CHAR);

PROCEDURE READPAGE(VAR BLOCK: UNIV PAGE; VAR EOF: BOOLEAN);
PROCEDURE WRITEPAGE(BLOCK: UNIV PAGE; EOF: BOOLEAN);
PROCEDURE READLINE(VAR TEXT: UNIV LINE);
PROCEDURE WRITELINE(TEXT: UNIV LINE);
PROCEDURE READARG(S: ARGSEQ; VAR ARG: ARGTYPE);
PROCEDURE WRITEARG(S: ARGSEQ; ARG: ARGTYPE);

PROCEDURE LOOKUP(ID: IDENTIFIER; VAR ATTR: FILEATTR; VAR FOUND: BOOLEAN);

PROCEDURE IOTRANSFER
  (DEVICE: IODEVICE; VAR PARAM: IOPARAM; VAR BLOCK: UNIV PAGE);

PROCEDURE IOMOVE(DEVICE: IODEVICE; VAR PARAM: IOPARAM);

FUNCTION TASK: TASKKIND;

PROCEDURE RUN(ID: IDENTIFIER; VAR PARAM: ARGLIST;
              VAR LINE: INTEGER; VAR RESULT: PROGRESULT);


PROGRAM P(VAR PARAM: ARGLIST);




"###############################################################
#  SPASCAL(VAR OK: BOOLEAN; SOURCE, DEST, OBJECT: IDENTIFIER)  #
###############################################################"


"INSERT PREFIX HERE"

"THE PARAMETERS OF THE COMPILER PASSES
HAVE THE FOLLOWING MEANING:

  LIST(.1.) : BOOLEAN     (COMPILATION OK)
  LIST(.2.) : POINTER     (HEAP POINTER)
  LIST(.3.) : INTEGER     (CODE LENGTH) "


VAR

OK: BOOLEAN; SOURCE, DEST, OBJECT: ARGTYPE;
CODELENGTH: INTEGER;
WHERE: (NOWHERE, ONDISK);
REPORT: (MAIN, OUTP);

LIST: ARGLIST;


PROCEDURE INITWRITE;
BEGIN
  IDENTIFY('PASCAL:(:10:)');
  REPORT:= MAIN;
END;

PROCEDURE WRITECHAR(C: CHAR);
BEGIN
  IF REPORT = MAIN
    THEN DISPLAY(C)
    ELSE WRITE(C);
END;

PROCEDURE WRITETEXT(TEXT: LINE);
CONST NUL = '(:0:)';
VAR I: INTEGER; C: CHAR;
BEGIN
  I:= 1; C:= TEXT(.1.);
  WHILE C <> NUL DO
  BEGIN
    WRITECHAR(C);
    I:= I + 1; C:= TEXT(.I.);
  END;
END;

PROCEDURE WRITEINT(INT, LENGTH: INTEGER);
VAR NUMBER: ARRAY (.1..6.) OF CHAR;
  DIGIT, REM, I: INTEGER;
BEGIN
  DIGIT:= 0; REM:= INT;
  REPEAT
    DIGIT:= DIGIT + 1;
    NUMBER(.DIGIT.):=
      CHR(ABS(REM MOD 10) + ORD('0'));
    REM:= REM DIV 10;
  UNTIL REM = 0;
  FOR I:= 1 TO LENGTH - DIGIT - 1 DO
    WRITECHAR(' ');
  IF INT < 0 THEN WRITECHAR('-')
             ELSE WRITECHAR(' ');
  FOR I:= DIGIT DOWNTO 1 DO
    WRITECHAR(NUMBER(.I.));
END;

PROCEDURE WRITEID(ID: IDENTIFIER);
VAR I: INTEGER; C: CHAR;
BEGIN
  FOR I:= 1 TO IDLENGTH DO
  BEGIN
    C:= ID(.I.);
    IF C <> ' ' THEN WRITECHAR(C);
  END;
END;

PROCEDURE CONVRESULT(RESULT: PROGRESULT; VAR ID: IDENTIFIER);
BEGIN
  CASE RESULT OF
    TERMINATED:    ID:= 'TERMINATED  ';
    OVERFLOW:      ID:= 'OVERFLOW    ';
    POINTERERROR:  ID:= 'POINTERERROR';
    RANGEERROR:    ID:= 'RANGEERROR  ';
    VARIANTERROR:  ID:= 'VARIANTERROR';
    HEAPLIMIT:     ID:= 'HEAPLIMIT   ';
    STACKLIMIT:    ID:= 'STACKLIMIT  ';
    CODELIMIT:     ID:= 'CODELIMIT   ';
    TIMELIMIT:     ID:= 'TIMELIMIT   ';
    CALLERROR:     ID:= 'CALLERROR   '
  END;
END;

PROCEDURE WRITERESULT
  (ID: IDENTIFIER; LINE: INTEGER; RESULT: PROGRESULT);
VAR ARG: IDENTIFIER;
BEGIN
  WRITECHAR(NL);
  WRITEID(ID);
  WRITETEXT(': LINE (:0:)');
  WRITEINT(LINE, 4);
  WRITECHAR(' ');
  CONVRESULT(RESULT, ARG);
  WRITEID(ARG);
  WRITECHAR(NL);
  OK:= (RESULT = TERMINATED);
END;

PROCEDURE ERROR(TEXT: LINE);
BEGIN
  INITWRITE;
  WRITETEXT(TEXT);
  OK:= FALSE;
END;

PROCEDURE HELP;
BEGIN
  IF OK THEN
  BEGIN
    WRITETEXT('TRY AGAIN (:10:)(:0:)');
    WRITETEXT
      ('     SPASCAL(SOURCE, DESTINATION, OBJECT: IDENTIFIER) (:10:)(:0:)');
    OK:= FALSE;
  END;
END;

PROCEDURE OPENFILE(F: FILE; ID: IDENTIFIER);
VAR FOUND: BOOLEAN;
BEGIN
  OPEN(F, ID, FOUND);
  IF NOT FOUND THEN
    ERROR('TEMPORARY FILE MISSING(:10:)(:0:)');
END;

PROCEDURE SAVEFILE;
VAR LENGTH, LINE: INTEGER; RESULT: PROGRESULT;
BEGIN
  LENGTH:= (CODELENGTH + 511) DIV 512;
  WITH LIST(.1.) DO
  BEGIN TAG:= BOOLTYPE; BOOL:= FALSE END;
  WITH LIST(.2.) DO
  BEGIN TAG:= IDTYPE;
    IF WHERE = NOWHERE THEN ID:= 'CREATE      '
                       ELSE ID:= 'REPLACE     ';
  END;
  WITH LIST(.3.) DO
  BEGIN TAG:= IDTYPE; ID:= OBJECT.ID END;
  WITH LIST(.4.) DO
  BEGIN TAG:= INTTYPE; INT:= LENGTH END;
  WITH LIST(.5.) DO
  BEGIN TAG:= IDTYPE; ID:= 'SEQCODE     ' END;
  WITH LIST(.6.) DO
  BEGIN TAG:= BOOLTYPE; BOOL:= FALSE END;
  RUN('FILE        ', LIST, LINE, RESULT);
  IDENTIFY('PASCAL:(:10:)');
  IF (RESULT <> TERMINATED) OR
    NOT LIST(.1.).BOOL
    THEN ERROR('OBJECT FILE LOST(:10:)(:0:)');
END;

PROCEDURE CHECKARG;
VAR ATTR: FILEATTR; FOUND: BOOLEAN;
BEGIN
  OK:= (TASK = JOBTASK);
  SOURCE:= PARAM(.2.);
  WITH SOURCE DO
  IF TAG <> IDTYPE THEN HELP ELSE
  BEGIN
    LOOKUP(ID, ATTR, FOUND);
    IF NOT FOUND THEN
      ERROR('SOURCE FILE UNKNOWN (:10:)(:0:)') ELSE
    CASE ATTR.KIND OF
      SCRATCH, CONCODE:
        ERROR('SOURCE KIND MUST BE ASCII OR SEQCODE(:10:)(:0:)');
      ASCII, SEQCODE:
    END;
  END;
  DEST:= PARAM(.3.);
  WITH DEST DO
  IF TAG <> IDTYPE THEN HELP ELSE
  BEGIN
    LOOKUP(ID, ATTR, FOUND);
    IF NOT FOUND THEN
      ERROR('DESTINATION FILE UNKNOWN(:10:)(:0:)') ELSE
    IF ATTR.KIND <> SEQCODE THEN
      ERROR('DESTINATION KIND MUST BE SEQCODE(:10:)(:0:)');
  END;
  OBJECT:= PARAM(.4.);
  WITH OBJECT DO
  IF TAG <> IDTYPE THEN HELP ELSE
  BEGIN
    LOOKUP(ID, ATTR, FOUND);
    IF NOT FOUND THEN
      WHERE:= NOWHERE ELSE
    IF ATTR.PROTECTED THEN
      ERROR('OBJECT FILE PROTECTED (:10:)(:0:)') ELSE
      WHERE:= ONDISK;
  END;
END;

PROCEDURE CHECKIO;
VAR ARG: ARGTYPE; C: CHAR;
BEGIN
  "COMPLETE SOURCE TEXT INPUT/OUTPUT:"
  REPEAT READ(C) UNTIL C = EM;
  WRITE(EM);
  READARG(INP, ARG);
  IF NOT ARG.BOOL THEN OK:= FALSE;
  READARG(OUT, ARG);
  IF NOT ARG.BOOL THEN OK:= FALSE;
END;

PROCEDURE INITIALIZE;
BEGIN
  WRITEARG(INP, SOURCE);
  WRITEARG(OUT, DEST);
  WITH LIST(.1.) DO
  BEGIN TAG:= BOOLTYPE; BOOL:= FALSE END;
  WITH LIST(.2.) DO
  BEGIN TAG:= PTRTYPE; PTR:= NIL END;
  WITH LIST(.3.) DO
  BEGIN TAG:= INTTYPE; INT:= 0 END;
END;

PROCEDURE TERMINATE;
BEGIN
  WITH PARAM(.1.) DO
  BEGIN TAG:= BOOLTYPE; BOOL:= OK END;
END;

PROCEDURE CALLPASS(ID: IDENTIFIER);
VAR LINE: INTEGER; RESULT: PROGRESULT;
BEGIN
  LIST(.1.).BOOL:= FALSE;
  RUN(ID, LIST, LINE, RESULT);
  IF RESULT <> TERMINATED THEN
  BEGIN
    REPORT:= OUTP;
    WRITERESULT(ID, LINE, RESULT);
  END ELSE
  BEGIN
    OK:= LIST(.1.).BOOL;
    CODELENGTH:= LIST(.3.).INT;
    IF NOT OK THEN
      ERROR('COMPILATION ERRORS(:10:)(:0:)');
  END;
END;


BEGIN
  CHECKARG;
  IF OK THEN
  BEGIN
    OPENFILE(1, 'TEMP1       ');
    OPENFILE(2, 'TEMP2       ');
    IF OK THEN
    BEGIN
      INITIALIZE;
      CALLPASS('SPASS1      ');
      IF OK THEN CALLPASS('SPASS2      ');
      IF OK THEN CALLPASS('SPASS3      ');
      IF OK THEN CALLPASS('SPASS4      ');
      IF OK THEN CALLPASS('SPASS5      ');
      IF OK THEN CALLPASS('SPASS6      ');
      IF OK THEN OPENFILE(2, 'NEXT        ');
      IF OK THEN CALLPASS('SPASS7      ');
      CHECKIO;
      IF OK & (CODELENGTH > 0) THEN SAVEFILE;
      TERMINATE;
    END;
    CLOSE(1); CLOSE(2);
  END;
END.