(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);



"############################################
#  DO(VAR OK: BOOLEAN; SOURCE: IDENTIFIER)  #
############################################"


"INSERT PREFIX HERE"


TYPE

CHARKIND = (LETTER, DIGIT, SPECIAL, OTHERCHAR);

TOKENKIND =
  (OPERAND, LEFTPAR, COMMA, RIGHTPAR, SEMICOLON,
   NEWLINE, ENDMEDIUM, OTHERTOKEN);

VAR

OK, ONLINE: BOOLEAN;

SOURCE: ARGTYPE;

COPY: IDENTIFIER;

BUFFER: RECORD
          TEXT: PAGE;
          PAGENO, CHARNO: INTEGER
        END;

SYMB: RECORD KIND: CHARKIND; CH: CHAR END;

TOKEN: RECORD KIND: TOKENKIND; ARG: ARGTYPE END;

COMMAND: RECORD
           CODE: IDENTIFIER;
           ATTR: FILEATTR;
           LIST: ARGLIST;
           COUNT, HEAPTOP: INTEGER
         END;


"CHARACTER OUTPUT"

PROCEDURE WRITETEXT(TEXT: LINE);
CONST NUL = '(:0:)';
VAR I: INTEGER; C: CHAR;
BEGIN
  I:= 1; C:= TEXT(.1.);
  WHILE C <> NUL DO
  BEGIN
    DISPLAY(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
    DISPLAY(' ');
  IF INT < 0 THEN DISPLAY('-')
             ELSE DISPLAY(' ');
  FOR I:= DIGIT DOWNTO 1 DO
    DISPLAY(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 DISPLAY(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
  WRITEID(ID);
  WRITETEXT(': LINE (:0:)');
  WRITEINT(LINE, 4);
  DISPLAY(' ');
  CONVRESULT(RESULT, ARG);
  WRITEID(ARG);
  DISPLAY(NL);
  OK:= (RESULT = TERMINATED);
END;

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

PROCEDURE HELP1;
BEGIN
  WRITETEXT('TRY AGAIN (:10:)(:0:)');
  WRITETEXT('     PROGRAMNAME(:10:)(:0:)');
  WRITETEXT('OR(:10:)(:0:)');
  WRITETEXT('     PROGRAMNAME(ARG, ... , ARG)(:10:)(:0:)');
  WRITETEXT('USING (:10:)(:0:)');
  WRITETEXT('     ARG: BOOLEAN, INTEGER, OR IDENTIFIER (:10:)(:0:)');
  OK:= FALSE;
END;

PROCEDURE HELP2;
BEGIN
  WRITETEXT('TRY AGAIN (:10:)(:0:)');
  WRITETEXT('     DO(SOURCE: IDENTIFIER) (:10:)(:0:)');
  OK:= FALSE;
END;

PROCEDURE HELP3;
BEGIN
  WRITETEXT('NOT EXECUTABLE, TRY (:10:)(:0:)');
  WRITETEXT('     LIST(CATALOG, SEQCODE, CONSOLE)(:10:)(:0:)');
  OK:= FALSE;
END;

"CHARACTER INPUT"

PROCEDURE READCHAR(VAR C: CHAR);
VAR FOUND: BOOLEAN;
BEGIN
  IF ONLINE THEN ACCEPT(C) ELSE
  WITH BUFFER DO
  BEGIN
    IF CHARNO = PAGELENGTH THEN
    BEGIN
      OPEN(1, COPY, FOUND);
      PAGENO:= PAGENO + 1;
      GET(1, PAGENO, TEXT);
      CLOSE(1);
      CHARNO:= 0;
    END;
    CHARNO:= CHARNO + 1;
    C:= TEXT(.CHARNO.);
    IF C <> EM THEN DISPLAY(C);
  END;
END;

PROCEDURE NEXTCHAR;
BEGIN
  WITH SYMB DO
  BEGIN
    REPEAT "SKIP BLANKS"
      READCHAR(CH);
      WHILE CH = '"' DO
      BEGIN "SKIP COMMENT"
        REPEAT READCHAR(CH)
        UNTIL (CH = '"') OR
              (CH = EM);
        IF CH <> EM THEN READCHAR(CH);
      END;
    UNTIL CH <> ' ';
    KIND:= OTHERCHAR;
    IF (NL <= CH) & (CH <= '_') THEN
    CASE CH OF

      'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L',
      'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X',
      'Y', 'Z', '_':
        KIND:= LETTER;

      '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':
        KIND:= DIGIT;

      '(', ')', ',', ';', NL, EM:
        KIND:= SPECIAL

    END;
  END;
END;

"TOKEN INPUT"

PROCEDURE SCANID;
VAR I: INTEGER;
BEGIN
  WITH TOKEN, ARG DO
  BEGIN
    KIND:= OPERAND;
    TAG:= IDTYPE;
    WITH SYMB DO
    BEGIN
      I:= 1;
      WHILE ((KIND = LETTER) OR (KIND = DIGIT))
          & (I <= IDLENGTH) DO
      BEGIN
        ID(.I.):= CH; I:= I + 1;
        NEXTCHAR;
      END;
      WHILE I <= IDLENGTH DO
      BEGIN ID(.I.):= ' '; I:= I + 1 END;
    END;
    IF ID = 'FALSE       ' THEN
    BEGIN TAG:= BOOLTYPE; BOOL:= FALSE END
    ELSE
    IF ID = 'TRUE        ' THEN
    BEGIN TAG:= BOOLTYPE; BOOL:= TRUE END;
  END;
END;

PROCEDURE SCANINT;
CONST MAXINT = 32767;
VAR D: INTEGER; OVERFLOW: BOOLEAN;
BEGIN
  WITH TOKEN, ARG DO
  BEGIN
    TAG:= INTTYPE;
    WITH SYMB DO
    BEGIN
      INT:= 0; OVERFLOW:= FALSE;
      WHILE (KIND = DIGIT) & NOT OVERFLOW DO
      BEGIN
        D:= ORD(CH) - ORD('0');
        IF INT > (MAXINT - D) DIV 10
          THEN OVERFLOW:= TRUE
          ELSE INT:= 10 * INT + D;
        NEXTCHAR;
      END;
    END;
    IF OVERFLOW THEN KIND:= OTHERTOKEN
                ELSE KIND:= OPERAND;
  END;
END;

PROCEDURE SCANSPEC;
BEGIN
  WITH TOKEN DO
  CASE SYMB.CH OF
    '(': BEGIN KIND:= LEFTPAR; NEXTCHAR END;

    ')': BEGIN KIND:= RIGHTPAR; NEXTCHAR END;

    ',': BEGIN KIND:= COMMA; NEXTCHAR END;

    ';': BEGIN KIND:= SEMICOLON; NEXTCHAR END;

    NL:  KIND:= NEWLINE;

    EM:  KIND:= ENDMEDIUM
  END;
END;

PROCEDURE SCANOTHER;
BEGIN
  TOKEN.KIND:= OTHERTOKEN;
  NEXTCHAR;
END;

PROCEDURE NEXTTOKEN;
BEGIN
  CASE SYMB.KIND OF
    LETTER:  SCANID;

    DIGIT:  SCANINT;

    SPECIAL: SCANSPEC;

    OTHERCHAR: SCANOTHER
  END;
END;

"COMMAND ANALYSIS"

PROCEDURE INITARG;
VAR I: INTEGER;
BEGIN
  WITH COMMAND DO
  BEGIN
    WITH LIST(.1.) DO
    BEGIN TAG:= BOOLTYPE; BOOL:= FALSE END;
    COUNT:= 1;
    FOR I:= 2 TO MAXARG DO
      LIST(.I.).TAG:= NILTYPE;
  END;
END;

PROCEDURE SCANARG;
BEGIN
  WITH TOKEN, COMMAND DO
  BEGIN
    COUNT:= COUNT + 1;
    IF (KIND = OPERAND) & (COUNT <= MAXARG) THEN
    BEGIN LIST(.COUNT.):= ARG; NEXTTOKEN END
    ELSE OK:= FALSE;
  END;
END;

PROCEDURE NEXTCOMMAND;
BEGIN
  WITH TOKEN, ARG, COMMAND DO
  BEGIN
    OK:= TRUE;
    IF (KIND = OPERAND) & (TAG = IDTYPE) THEN
    BEGIN CODE:= ID; NEXTTOKEN END
    ELSE OK:= FALSE;
    INITARG;
    IF KIND = LEFTPAR THEN
    BEGIN
      REPEAT
        NEXTTOKEN; SCANARG;
      UNTIL KIND <> COMMA;
      IF KIND = RIGHTPAR THEN NEXTTOKEN
                         ELSE OK:= FALSE;
    END;
    IF KIND = SEMICOLON THEN NEXTTOKEN;
    IF KIND <> NEWLINE THEN
    BEGIN
      REPEAT NEXTTOKEN
      UNTIL KIND = NEWLINE;
      OK:= FALSE;
    END;
  END;
  IF NOT OK THEN HELP1;
END;

PROCEDURE CHECKCOMMAND;
VAR I: INTEGER;
BEGIN
  WITH COMMAND DO
  BEGIN
    LOOKUP(CODE, ATTR, OK);
    IF NOT OK THEN HELP3 ELSE
    IF ATTR.KIND <> SEQCODE THEN HELP3;
  END;
END;

PROCEDURE EXECUTE;
VAR LINE: INTEGER; RESULT: PROGRESULT; C: CHAR; HEAPTOP: INTEGER;
BEGIN
  WITH COMMAND DO
  BEGIN
    MARK(HEAPTOP);
    RUN(CODE, LIST, LINE, RESULT);
    RELEASE(HEAPTOP);
    IDENTIFY('DO:(:10:)');
    IF RESULT <> TERMINATED THEN
      WRITERESULT(CODE, LINE, RESULT) ELSE
    BEGIN
      WITH LIST(.1.) DO
      IF TAG = BOOLTYPE THEN OK:= BOOL
                        ELSE OK:= FALSE;
    END;
  END;
END;

"INITIALIZATION AND TERMINATION"

PROCEDURE CHECKARG;
VAR ATTR: FILEATTR; FOUND: BOOLEAN;
BEGIN
  SOURCE:= PARAM(.2.);
  WITH SOURCE DO
  IF TAG <> IDTYPE THEN HELP2 ELSE
  IF ID = 'CONSOLE     ' THEN
    ONLINE:= TRUE 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;
    ONLINE:= FALSE;
  END;
END;

PROCEDURE SAVECOPY(LENGTH: INTEGER);
VAR ATTR: FILEATTR; FOUND: BOOLEAN;
    LINE: INTEGER; RESULT: PROGRESULT;
    LIST: ARGLIST;
BEGIN
  COPY:= 'COMMANDS    ';
  LOOKUP(COPY, ATTR, FOUND);
  WITH LIST(.1.) DO
  BEGIN TAG:= BOOLTYPE; BOOL:= FALSE END;
  WITH LIST(.2.) DO
  BEGIN TAG:= IDTYPE;
    IF FOUND THEN ID:= 'REPLACE     '
             ELSE ID:= 'CREATE      ';
  END;
  WITH LIST(.3.) DO
  BEGIN TAG:= IDTYPE; ID:= COPY END;
  WITH LIST(.4.) DO
  BEGIN TAG:= INTTYPE; INT:= LENGTH END;
  WITH LIST(.5.) DO
  BEGIN TAG:= IDTYPE; ID:= 'ASCII       ' END;
  WITH LIST(.6.) DO
  BEGIN TAG:= BOOLTYPE; BOOL:= FALSE END;
  RUN('FILE        ', LIST, LINE, RESULT);
  IDENTIFY('DO:(:10:)');
  IF RESULT <> TERMINATED
    THEN WRITERESULT('FILE        ', LINE, RESULT)
    ELSE IF NOT LIST(.1.).BOOL THEN
           ERROR('SOURCE COPY LOST(:10:)(:0:)');
END;

PROCEDURE MAKECOPY;
VAR ARG: ARGTYPE; LENGTH: INTEGER; C: CHAR;
BEGIN
  WRITEARG(INP, SOURCE);
  WITH ARG DO
  BEGIN TAG:= IDTYPE; ID:= 'NEXT        ' END;
  WRITEARG(OUT, ARG);
  REPEAT
    READ(C); WRITE(C);
  UNTIL C = EM;
  READARG(INP, ARG);
  IF NOT ARG.BOOL THEN OK:= FALSE;
  READARG(OUT, ARG);
  LENGTH:= ARG.INT;
  READARG(OUT, ARG);
  IF NOT ARG.BOOL THEN OK:= FALSE;
  IF OK THEN SAVECOPY(LENGTH);
END;

FUNCTION CONTINUE: BOOLEAN;
BEGIN
  CONTINUE:= ONLINE OR
    OK & (TOKEN.KIND <> ENDMEDIUM);
END;

FUNCTION ANYTHING: BOOLEAN;
BEGIN
  ANYTHING:= (TOKEN.KIND <> NEWLINE);
END;

PROCEDURE INITNEXT;
BEGIN
  IDENTIFY('DO:(:10:)');
  OK:= TRUE;
  NEXTCHAR; NEXTTOKEN;
END;

PROCEDURE INITIALIZE;
BEGIN
  IDENTIFY('DO:(:10:)');
  OK:= TRUE;
  CHECKARG;
  IF ONLINE THEN INITNEXT ELSE
  BEGIN
    IF OK THEN MAKECOPY;
    WITH BUFFER DO
    BEGIN
      PAGENO:= 0;
      CHARNO:= PAGELENGTH;
    END;
    IF OK THEN INITNEXT;
  END;
END;

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

"MAIN CYCLE"

BEGIN
  IF TASK = JOBTASK THEN
  BEGIN
    INITIALIZE;
    WHILE CONTINUE DO
    BEGIN
      IF ANYTHING THEN
      BEGIN
        NEXTCOMMAND;
        IF OK THEN CHECKCOMMAND;
        IF OK THEN EXECUTE;
      END;
      IF CONTINUE THEN INITNEXT;
    END;
    TERMINATE;
  END;
END.