! Grammar5.txt :  Turbo Pascal  rules
! list of semantic actions, "forbidden" MUST be the last one:

(ifThen,     elseDo,     endIf,      doLoop,     doWhile,    endWhile,
 endRep,     caseSel,    blockEntry, blockBegin, blockEnd,   pointTo,
 subField,   arrayAddr,  getAddr,    pushVar,    pushConst,  assignmt,
 addit,      subtr,      multi,      divis,      modulo,     negate,
 andLog,     orLog,      notLog,     equal,      unEqual,    greater,
 less,       greaterEqu, lessEqu,    arrayDef,   midIndex,   lastIndex,
 arrayEnd,   recordDef,  newField,   fieldType,  recordEnd,  ptrDef,
 linkToPtr,  typeDef,    enumDef,    newConst,   enumEnd,    subranDef,
 subranEnd,  typeName,   typeEnd,    firstVar,   nextVar,    tpVarList,
 constIde,   assignCon,  stringCon,  plus,       minus,      constRef,
 intConst,   endConst,   nilSymbol,  paramDef,   paramTp,    paramEnd,
 procEnd,    functEnd,   functName,  functCall,  procCall,   pushParam,
 doCall,     forInit,    comparTo,   increment,  comparDown, decrement,
 caseFirst,  caseNext,   caseLast,   caseEnd,    caseOther,  caseTerm,
 withFirst,  withNext,   withReleas, withAddr,   assignDef,  parAddr,
 valpAddr,   typeBool,   typeByte,   typeChar,   typeInt,    typeWord,
 typeLong,   typeReal,   typeDoub,   typeText,   typePoin,   typeStr,
 maxiStr,    trueSymb,   falsSymb,   forwDecl,   terminator, repLoop,
 beginSymb,  endSymb,    parenthes,  shfLeft,    shfRight,   xorLog,
 setDef,     interval,   setList,    setMake,    inOper,     formData,
 fmtOne,     fmtTwo,     fileRef,    doRead,     doRdLn,     doWrite,
 doWriLn,    rdVar,      wrFmt,      numToStr,   fileAddr,   memAlloc,
 typeShort,  dotSymb,    typeNull,   typeSet,    tpSetEnd,   mainFile,
 unitFile,   implPart,   useUnit,    mainPrgr,   linkTname,  intLabel,
 intJump,    intLbDef,   symbLabel,  symbJump,   symbLbDef,  normUnit,
 optional,   typeFile,   tpFlEnd,    forDef,     typeCast,   valCast,
 relaxTp,    dummyTp,    isMissing,  doProg,     doUnit,     doIntf,
 typConst,   initUnit,   getPtr,     getSize,    gotoExit,   setcoInit,
 setcoOne,   setcoTwo,   setcoTerm,  tradCons,   tradOpen,   tradSepa,
 tradClos,   assignTC,   typeSize,   typeComp,   typeExte,   mkVariant,
 extDecla,   intfDecl,   kwMem,      kwMemw,     kwMeml,     memArray,
 kwPort,     kwPortw,    ioPort,     caseIntv,   ignore,     forbidden
)

!  grammar non-terminal symbols in the exact order of declaration :
(constant,   posiConst,  paramType,  simpType,   strucType,  genType,
 fieldList,  field,      variant,    sintrval,
 tpdConst,   address,    variable,   memport,
 varRefer,   assiLeft,   modifier,   unsigned,   factor,     term,
 simpExpr,   expression, format,     binary,     sizeCode,   inlCode,
 inOut,      interval,   oneCase,    statement,  statemt,    paramLis,
 subList,    varList,    constDef,   typeDef,    lablDef,    declPart,
 block,      useList,    externals,  mainProg,   goodFile,   intrFace
)

!  identifier classes:
(constId,    typeId,     fieldId,    varId,      functId,    procId,
 varParId,   valParId,   fileId,     forwId,     unitId,     otherId,
 labelId
)

! standard symbols:
! double-strokes, keywords, std types, std constants, irregular proc./funct
!                  Alphabetic Order.  All Upper case if strictly reserved !
..|:=|>=|<=|<>|
ABSOLUTE|AND|ARRAY|BEGIN|Boolean|Byte|CASE|Char|Comp|Concat|CONST|DIV|DO|
Double|DOWNTO|ELSE|END|Exit|Extended|EXTERNAL|False|FILE|FOR|FORWARD|FUNCTION|
GOTO|IF|IMPLEMENTATION|IN|INLINE|Integer|INTERFACE|INTERRUPT|LABEL|
Longint|Mem|Meml|Memw|MOD|New|NIL|NOT|OF|OR|OTHERWISE|PACKED|
Pointer|Port|Portw|PROCEDURE|PROGRAM|Read|Readln|Real|RECORD|
REPEAT|SET|SHL|Shortint|SHR|Sizeof|Str|STRING|Text|THEN|TO|True|TYPE|UNIT|
UNTIL|USES|VAR|WHILE|WITH|Word|Write|Writeln|XOR||

!  Top-down grammar rules use non-Pascal chars as metasymbols:
!  underbar semantic action, ?  marks new identifier, &  known identifier.
!  % is number, ' is string
!  {||} is list of alternatives,  # means 0 or more repetitions

"constant"
   {' _stringCon | + _plus posiConst | - _minus posiConst | posiConst |
     NIL _nilSymbol | TRUE _trueSymb | FALSE _falsSymb }
"posiConst"
   { {&constId _constRef |% _intConst } _endConst }
"paramType"  ! all named types
   {BOOLEAN _typeBool | BYTE _typeByte | CHAR _typeChar | SHORTINT _typeShort|
    INTEGER _typeInt | WORD _typeWord | LONGINT _typeLong | REAL _typeReal |
    DOUBLE _typeDoub | TEXT _typeText | POINTER _typePoin| STRING _maxiStr |
    FILE _typeFile | COMP _typeComp | EXTENDED _typeExte |&typeId _typeName }
"simpType"
   {BOOLEAN _typeBool | BYTE _typeByte | CHAR _typeChar |
    INTEGER _typeInt | WORD _typeWord | SHORTINT _typeShort |
   &typeId _typeName | ( _enumDef ?constId _newConst #{,?constId _newConst })
   _enumEnd  |constant _subranDef .. constant _subranEnd }
"strucType"
   { SET OF _typeSet simpType _tpSetEnd |
     FILE _typeFile {OF genType _tpFlEnd|} |
     ARRAY _arrayDef
   [ simpType#{,_midIndex simpType} ] _lastIndex OF genType _arrayEnd |
   RECORD _recordDef fieldList END _recordEnd }
"genType"
   { LONGINT _typeLong | REAL _typeReal | DOUBLE _typeDoub | simpType |
     COMP _typeComp | EXTENDED _typeExte |
   TEXT _typeText | POINTER _typePoin|
   STRING _maxiStr {[posiConst _typeStr ]|} |
   PACKED strucType | strucType |
   ^ _ptrDef { paramType _linkTname | ?forwId  _linkToPtr} }
"fieldList"
   {field#{;field} { CASE ! nested CASE is buggy
    {paramType _dummyTp| ?fieldId _newField: paramType _fieldType}
    OF variant #{;variant} |} } ! field and variant may be void!
"field"
   {?fieldId _newField #{,?fieldId _newField }:genType _fieldType |}
"variant"
   {constant #{,constant} :_mkVariant (fieldList) |} ! possibly recursion
"sintrval"
   {constant _setcoOne {..constant _setcoTwo|}}
"tpdConst" ! typed constants: simple,set, array,record, recursive!
   {constant _tradCons|
    (_tradOpen {&fieldId:tpdConst #{;_tradSepa &fieldId:tpdConst} | !record
     tpdConst #{,_tradSepa tpdConst} } )_tradClos | ! ... and array
   [ _setcoInit {sintrval #{, sintrval} |} ] _setcoTerm }  ! set const
"address"   ! simplest variable references
   {&varId _getAddr | &varParId _parAddr | &valParId _valpAddr |
    &fieldId _withAddr | &fileId _fileAddr }
"variable"  ! in  @ operator: loss of generality bug?
   { address #modifier }
"memport"
   {{MEM _kwMem |MEMW _kwMemw |MEML _kwMeml} _forbidden
     [expression:expression] _memArray|
    {PORT _kwPort | PORTW _kwPortw } _forbidden [expression] _ioPort}
"varRefer" !  general variable reference : functionCall^ and var-typeCast
    {{address| &typeId(varRefer) _typeCast| &functId _functCall
     {(expression _pushParam #{,expression _pushParam })|} _doCall ^ _pointTo}
     #modifier |memport}
"assiLeft" ! left side of assignment: complicated because of functions
    {{address| &typeId(varRefer) _typeCast}#modifier _assignDef:= |
     &functId { ! if "(" or "^" follows here, PointerFctCall !
     {( _functCall expression _pushParam #{,expression _pushParam })^|
       ^ _functCall} _doCall _pointTo
     #modifier _assignDef:= |:= _functName }|  ! void: function return value.
     memport _assignDef :=  }
"modifier" ! array,record,pointer addressing
   { [expression _arrayAddr #{,expression _arrayAddr } ]|
   . _dotSymb &fieldId _subField | ^ _pointTo }
"unsigned"
   {&constId _constRef |% _intConst |NIL _nilSymbol |
   TRUE _trueSymb | FALSE _falsSymb | ' _stringCon }
"factor"   ! Bug: allow #modifier after valCast ?
   {unsigned _pushConst |variable _pushVar |
   &functId _functCall { (expression
   _pushParam #{,expression _pushParam })| } _doCall
    {^ _pointTo #modifier|} |  ! pointer-valued function call
   (expression) _parenthes|
   [ _setDef {expression {..expression _interval |} _setList  !set construct
    #{,expression{..expression _interval|} _setList}|} ] _setMake |
   NOT factor _notLog |
   @ _forbidden {variable|&procId _functName|&functId _functName} _getPtr |
   paramType _forbidden (expression) _valCast | ! value OR variable type cast
   CONCAT(expression #{,expression _addit}) |
   SIZEOF ({paramType _typeSize |expression _getSize}) |
   memport }
"term"
   {factor #{* factor _multi |/ factor _divis |DIV factor _divis |MOD factor
   _modulo |AND factor _andLog|SHL factor _shfLeft| SHR factor _shfRight }}
"simpExpr"
   {{+term|-term _negate |term} #{+ term _addit |- term _subtr |
   OR term _orLog| XOR term _xorLog }}       ! simple expr
"expression"
   {simpExpr {=simpExpr _equal |<simpExpr _less |>simpExpr _greater |
   <>simpExpr _unEqual |<=simpExpr _lessEqu |>=simpExpr _greaterEqu |
   IN simpExpr _inOper |}}
"format"
   {expression _formData {:expression _fmtOne {:expression _fmtTwo |}|}}
   ! formatted data needed in write and str
"binary"
   {INLINE _forbidden (sizeCode inlCode #{/sizeCode inlCode}) }
"sizeCode"
   {<|>|}
"inlCode"
   {constant _ignore| {&varId|&varParId|&valParId} #{{+|-}constant _ignore} }
"inOut"
   {READ({&fileId _fileRef,|}varRefer _rdVar #{,varRefer _rdVar }) _doRead|
   READLN{({&fileId _fileRef|varRefer _rdVar }#{,varRefer _rdVar })|} _doRdLn|
   WRITE({&fileId _fileRef,|}format _wrFmt #{,format _wrFmt}) _doWrite|
   WRITELN{({&fileId _fileRef|format _wrFmt} #{,format _wrFmt})|} _doWriLn|
   STR(format,varRefer _numToStr ) | NEW (varRefer _memAlloc ) }
"interval"
   {.. _caseIntv constant|}
"oneCase"
   {constant interval _caseFirst #{, constant interval _caseNext}
    : _caseLast statement _caseEnd |}
"statement" ! may be labeled
  { {% _intLabel| &labelId _symbLabel}: statemt _terminator|
    statemt _terminator}
"statemt"
   { assiLeft expression _assignmt |
   &procId _procCall
   { (expression _pushParam #{,expression _pushParam })| } _doCall |
   BEGIN _beginSymb statement #{;statement} END _endSymb |
   IF expression THEN _ifThen statement {ELSE _elseDo statement|} _endIf |
   WHILE _doLoop expression DO _doWhile statement _endWhile |
   REPEAT _repLoop statement#{;statement} UNTIL expression _endRep |
   FOR &varId _forDef := expression _forInit
     {TO expression _comparTo DO statement _increment
     |DOWNTO expression _comparDown DO statement _decrement } |
   inOut | ! irregular (read,write,str) procedures
   CASE expression OF _caseSel oneCase #{;oneCase} ! case items
    {{ELSE|OTHERWISE} _caseOther statement #{;statement} END| END} _caseTerm |
   WITH varRefer _withFirst #{,varRefer _withNext } DO statement _withReleas |
   EXIT _gotoExit |
   GOTO {% _intJump |&labelId _symbJump} |
   binary |} ! Inline statement, null statement
"paramLis"   ! parameter list of proc or funct declaration.
   { (subList #{;subList} {)| [_optional #{;subList} ]) } _paramEnd |
     [_optional subList #{;subList} ] _paramEnd |}
!  { (subList #{;subList} { [_optional #{;subList} ]|} )} has a bug! Where?
"subList"
   {{VAR ?varParId _paramDef #{,?varParId _paramDef } |
   ?valParId _paramDef #{,?valParId _paramDef }} _typeNull !typeless params !
   {: {:_relaxTp |} paramType _paramTp |} }
"varList" ! declare variable list
   {?varId _firstVar #{,?varId _nextVar}:genType _tpVarList
    {ABSOLUTE _forbidden {posiConst:posiConst|&varId|&varParId|&valParId}|} ;}
"constDef" ! normal or typed const definition
   {?constId _constIde {= constant _assignCon|
    : genType _typConst = tpdConst _assignTC} ;}
"typeDef"
   { {&forwId|?typeId} _typeDef = genType _typeEnd;} ! type definition
"lablDef"
   { % _intLbDef| ?labelId _symbLbDef}
"declPart"  ! declaration part
   { LABEL lablDef #{,lablDef}; |
     CONST constDef#constDef|
     TYPE typeDef#typeDef|
     VAR varList#varList| !block header.
    {PROCEDURE ?procId _blockEntry paramLis _procEnd; {INTERRUPT; _forbidden|}
     | FUNCTION ?functId _blockEntry paramLis ! fct type = option after Forwd
      {: paramType;|; _typeInt} _functEnd }
      {FORWARD _forwDecl| EXTERNAL _extDecla _forbidden| binary _forwDecl|
      #declPart block} ;
   }  ! series of proc/funct
"block"
   { BEGIN _blockBegin statement#{;statement} END _blockEnd }
"useList"
   {USES &unitId _useUnit #{,&unitId _useUnit} ;|}
"externals"   !  unit headings, for level 0
   { ?unitId _unitFile ; INTERFACE  useList
    #{CONST constDef#constDef|
    TYPE typeDef#typeDef|
    VAR varList#varList|
    PROCEDURE ?procId _blockEntry paramLis _procEnd; _intfDecl {@ _isMissing|}|
    FUNCTION ?functId _blockEntry paramLis: {: _relaxTp|} paramType _functEnd;
    _intfDecl {@ _isMissing|} }
   IMPLEMENTATION } ! header stops here !
"mainProg"
   { ?unitId _mainFile _blockEntry {( ?otherId#{,?otherId})|} _procEnd ;
     useList #declPart block. _mainPrgr } ! main program.
"goodFile" ! either program or unit
   {PROGRAM _doProg mainProg |
    UNIT _doUnit externals _implPart #declPart
    {END _normUnit | block _initUnit} .}
"intrFace" ! part of unit
   {UNIT _doIntf externals }
~

{header of standard Pascal procedures/functions for Level 0
 special [ ] and :: syntax in "prototypes" allowed ONLY here !
 They all get uppercase initials --> avoid  C library conflicts !
}

unit System; interface

const Pi=3.1415926;
var  CSeg,DSeg,SSeg,SPtr: word;

function  Copy(s:string; ix,count:integer): string;
procedure Insert(source:string; var s::string; ix::word);
procedure Delete(var s::string; ix,count::word);
function  Pos(sub,s: string):byte;
function  Length(s:string):integer;
procedure Val(s:string; var v::real; var code::word);
function  UpCase(c:char):char;
procedure Inc(var x::integer[; n:integer]);
procedure Dec(var x::integer[; n:integer]);
function  Hi(x:integer):byte;
function  Lo(x:integer):byte;

function  Ofs(var x): word;
function  Seg(var x): word;
procedure Halt [exitcode:word];
procedure BlockRead (var f:file; var buf; count:word [; var res: word]); @
procedure BlockWrite(var f:file; var buf; count:word [; var res: word]); @

procedure Dispose(p:pointer);
procedure Mark(var p::pointer);
procedure Release(var p::pointer);
function  MemAvail:longInt;
procedure Reset(var f::file [;rsize:word]);
procedure Rewrite(var f::file [;rsize:word]);
procedure Close(var f::file);
procedure Assign(var f::file; s:string);
function  Eof[var f::file]:boolean;
function  Eoln[var f:text]:boolean;
function  IoResult:word;
procedure Rename(var f::file; s:string);
procedure Erase(var f::file);
function  ParamCount: integer;
function  ParamStr(i:integer): string;
function  Ord(c::integer):byte;
function  Chr(i:integer):char;
function  Succ(i::integer)::integer;
function  Pred(i::integer)::integer;
function  Abs(r::real)::real;
function  Round(r:real):integer;
function  Trunc(r:real):integer;
function  Odd(i:integer):boolean;
function  Sqr(r:real):real;
function  Sqrt(r:real):real;
function  ArcTan(r:real):real;
function  Exp(r:real):real;
function  Ln(r:real):real;
function  Cos(r:real):real;
function  Sin(r:real):real;

var
  Input: Text;
  Output: Text;
  PrefixSeg: Word;
  HeapOrg: Pointer;
  HeapPtr: Pointer;
  FreePtr: Pointer;
  FreeMin: Word;
  HeapError: Pointer;
  ExitProc: Pointer;
  ExitCode: Integer;
  ErrorAddr: Pointer;
  RandSeed: Longint;
  SaveInt00: Pointer;
  SaveInt02: Pointer;
  SaveInt23: Pointer;
  SaveInt24: Pointer;
  SaveInt75: Pointer;
  FileMode: Byte;

procedure Append(var f:text); @
procedure Flush(var f:text);  @
procedure ChDir(s:string);    @
procedure MkDir(s:string);    @
procedure RmDir(s:string);    @
procedure GetDir(d:byte; var s::string); @
procedure SeekEof[var f:text];   @
procedure SeekEoln[var f:text];  @
function  FilePos(var f:file): longInt;   @
function  FileSize(var f:file): longInt;  @
procedure Seek(var f:file; n:longInt);    @
procedure Truncate(var f:file);           @
procedure SetTextBuf(var f:text; var buf [; size:word]); @

{ procedure Exit; @ }
function  Addr(var x): pointer; @
procedure FillChar(var x; count:word; ch::integer);
procedure Move(var source,dest; count:word);    @
procedure Randomize;                            @
function  Random[range:word] :word; {or real!}  @
procedure GetMem (var p::pointer; size:word);
procedure FreeMem(var p::pointer; size:word);
function  Frac(x:real):real;     @
function  Int(x:real): real;     @
function  MaxAvail: longInt;     @
function  Ptr(seg,ofs:word): pointer;  @
procedure Swap(var x::word);           @

implementation

{Things Left Out:
   exit absolute addr
   external TypeCasts TypedConstants @-operator concat sizeof
   chDir getDir mkDir rmDir append flush seekEof seekEoln setTextBuf
   blockread blockwrite seek truncate freeMem getMem maxAvail
   frac int fillchar move paramCount paramStr random randomize swap
   inline interrupt shortint single extended comp ptr
   UnitQualifiers TypelessParameters
}
