Path: utzoo!utgpu!news-server.csri.toronto.edu!bonnie.concordia.ca!thunder.mcrcim.mcgill.edu!snorkelwacker.mit.edu!mintaka!bloom-beacon!eru!hagbard!sunic!ugle.unit.no!solan1.solan.unit.no!egeberg
From: egeberg@solan.unit.no (Christian Egeberg)
Newsgroups: comp.sys.handhelds
Subject: Chipper source & stuff
Keywords: Chipper, Chip-48, Games, S-Chip
Message-ID: <1991Jun6.150011.14993@ugle.unit.no>
Date: 6 Jun 91 15:00:11 GMT
Sender: news@ugle.unit.no
Reply-To: egeberg@solan.unit.no (Christian Egeberg)
Organization: Norwegian Institue of Technology
Lines: 1815

This is the Chipper V1.12 Source
---------------------------------------------------------------------
{ Chip-48 Assembler V1.12 by Christian Egeberg 2/11-'90 .. 7/11-'90 }

PROGRAM Chipper;

{$R-,S+,I+,F-,O-,A+,V+,B-,N-,E-,D-,L-,M 16384,16384,655360}

USES Dos, Crt;

CONST
  CopyRight= 'Chip-48 Assembler V1.12 by Christian Egeberg 7/11-''90';
  ErrorExitCode= 1;
  StartAddress= $200;
  StopAddress= $fff;
  WordMask= $ffff;
  AddrMask= $fff;
  ByteMask= $ff;
  NibbleMask= $f;
  LineLength= 160;
  ParamLength= 80;
  SymbolLength= 16;
  MaxParams= 64;
  NullChar= Chr( 0);
  BellChar= Chr( 7);
  SpaceChar= Chr( 32);
  SeparatorChar= ',';
  RemarkChar= ';';
  SymbolChar= '_';
  LabelChar= ':';
  EqualChar= '=';
  TextChar= '''';
  AddressChar= '?';
  HexChar= '#';
  BinChar= '$';
  OctChar= '@';
  AscChar= '"';
  StartChar= '(';
  StopChar= ')';
  PlusChar= '+';
  MinusChar= '-';
  NotChar= '~';
  PowerChar= '!';
  ShlChar= '<';
  ShrChar= '>';
  MulChar= '*';
  FracChar= '/';
  AndChar= '&';
  OrChar= '|';
  XorChar= '^';
  DivChar= '\';
  ModChar= '%';
  NameDefault= '';
  InExtDefault= '.CHP';
  OutExtDefault= '.';
  ListExtDefault= '.LST';
  RunErrorMessage= 'Fatal error: ';
  RunWarningMessage= 'Warning: ';
  WarningNumMessage= 'Total number of warnings: ';
  NoSourceError= 'No source file found';
  FileAccessError= 'Unable to open file';
  BoundsError= 'Outside legal address range';
  ParamCountWarning= 'Incorrect number of parameters';
  DualSymbolWarning= 'No directive found';
  NoSymbolWarning= 'No symbol associated';
  CopySymbolWarning= 'Attempt to redefine existing symbol';
  UndefinedWarning= 'Badly defined parameter';
  RangeWarning= 'Parameter out of range';
  NoRegisterWarning= 'Register not found';
  BadRegisterWarning= 'Illegal register';
  InternalWarning= 'Internal data structure mismatch';

TYPE
  Token= ( EqualToken, AddToken, AndToken, CallToken, ClsToken, DaToken,
    DbToken, DrwToken, DsToken, DwToken, EndToken, EquToken, IncludeToken,
    JpToken, LdToken, OrToken, OrgToken, RetToken, RndToken, SeToken,
    ShlToken, ShrToken, SknpToken, SkpToken, SneToken, SubToken, SubnToken,
    SysToken, XorToken, LastToken);
  Register= ( BReg, DtReg, FReg, IReg, KReg, V0Reg, V1Reg, V2Reg, V3Reg,
    V4Reg, V5Reg, V6Reg, V7Reg, V8Reg, V9Reg, VaReg, VbReg, VcReg, VdReg,
    VeReg, VfReg, StReg, IiReg, LastReg);
  CharSet= SET OF Char;
  LineString= STRING[ LineLength];
  ParamString= STRING[ ParamLength];
  SymbolString= STRING[ SymbolLength];
  ParamPointer= ^ParamRecord;
  ParamRecord=
    RECORD
      Param: ParamString;
      Next: ParamPointer;
    END;
  SymbolPointer= ^SymbolRecord;
  SymbolRecord=
    RECORD
      Symbol: SymbolString;
      Address: LongInt;
      Left, Right: SymbolPointer;
    END;
  InstPointer= ^InstRecord;
  InstRecord=
    RECORD
      Line: Word;
      Name: PathStr;
      Address: LongInt;
      Inst: Token;
      Count: Byte;
      Params: ParamPointer;
      Next, Prev: InstPointer;
    END;

CONST
  TokenText: ARRAY[ Token] OF SymbolString=
    ( EqualChar, 'ADD', 'AND', 'CALL', 'CLS', 'DA', 'DB', 'DRW', 'DS', 'DW',
    'END', 'EQU', 'INCLUDE', 'JP', 'LD', 'OR', 'ORG', 'RET', 'RND', 'SE',
    'SHL', 'SHR', 'SKNP', 'SKP', 'SNE', 'SUB', 'SUBN', 'SYS', 'XOR', '');
  RegisterText: ARRAY[ Register] OF SymbolString=
    ( 'B', 'DT', 'F', 'I', 'K', 'V0', 'V1', 'V2', 'V3', 'V4', 'V5', 'V6',
    'V7', 'V8', 'V9', 'VA', 'VB', 'VC', 'VD', 'VE', 'VF', 'ST', '[I]', '');
  Operators: CharSet=
    [ StartChar, StopChar, PlusChar, MinusChar, NotChar, PowerChar, ShlChar,
    ShrChar, MulChar, FracChar, AndChar, OrChar, XorChar, DivChar, ModChar];
  DigitText: ParamString= '0123456789ABCDEF';
  Instructions: InstPointer= NIL;
  Directives: SymbolPointer= NIL;
  Registers: SymbolPointer= NIL;
  Symbols: SymbolPointer= NIL;
  LastSymbol: SymbolPointer= NIL;
  Current: LongInt= StartAddress;
  Finish: LongInt= StartAddress;
  LineText: LineString= '';
  LineName: PathStr= NameDefault;
  LineNum: Word= 1;
  InstPoint: InstPointer= NIL;
  ListOpen: Boolean= False;
  WarningCount: Word= 0;

VAR
  Memory: ARRAY[ StartAddress .. StopAddress] OF Byte;
  OutFile: FILE OF Byte;
  StdIn, StdOut, ListFile: Text;
  InFileName, OutFileName, ListFileName: PathStr;
  FileDir: DirStr;
  FileName: NameStr;
  FileExt: ExtStr;

PROCEDURE RunError( Message: STRING);

VAR
  Number: SymbolString;
  Param: ParamPointer;

BEGIN
  WriteLn( StdOut, BellChar, RunErrorMessage, Message);
  IF ListOpen THEN
    WriteLn( ListFile, RunErrorMessage, Message);
  IF LineName <> NameDefault THEN
    BEGIN
      Str( LineNum, Number);
      WriteLn( StdOut, 'Current file ', LineName, ' line ', Number);
      WriteLn( StdOut, LineText);
      IF ListOpen THEN
        BEGIN
          WriteLn( ListFile, 'Current file ', LineName, ' line ', Number);
          WriteLn( ListFile, LineText);
        END;
    END;
  IF InstPoint <> NIL THEN
    BEGIN
      Str( InstPoint^.Line, Number);
      WriteLn( StdOut, 'Associated file ', InstPoint^.Name, ' line ',
        Number);
      Write( StdOut, TokenText[ InstPoint^.Inst]);
      IF ListOpen THEN
        BEGIN
          WriteLn( ListFile, 'Associated file ', InstPoint^.Name, ' line ',
            Number);
          Write( ListFile, TokenText[ InstPoint^.Inst]);
        END;
      Param:= InstPoint^.Params;
      WHILE Param <> NIL DO
        BEGIN
          Write( StdOut, ', ', Param^.Param);
          IF ListOpen THEN
            Write( ListFile, ', ', Param^.Param);
          Param:= Param^.Next;
        END;
      WriteLn( StdOut);
      IF ListOpen THEN
        WriteLn( ListFile);
    END;
  WriteLn( StdOut);
  IF ListOpen THEN
    WriteLn( ListFile);
  Halt( ErrorExitCode);
  { Turbo Pascal closes all files on exit }
END;

PROCEDURE RunWarning( Message: STRING);

VAR
  Number: SymbolString;
  Param: ParamPointer;

BEGIN
  WriteLn( StdOut, RunWarningMessage, Message);
  WriteLn( ListFile, RunWarningMessage, Message);
  IF LineName <> NameDefault THEN
    BEGIN
      Str( LineNum, Number);
      WriteLn( StdOut, 'Current file ', LineName, ' line ', Number);
      WriteLn( StdOut, LineText);
      WriteLn( ListFile, 'Current file ', LineName, ' line ', Number);
      WriteLn( ListFile, LineText);
    END;
  IF InstPoint <> NIL THEN
    BEGIN
      Str( InstPoint^.Line, Number);
      WriteLn( StdOut, 'Associated file ', InstPoint^.Name, ' line ',
        Number);
      Write( StdOut, TokenText[ InstPoint^.Inst]);
      WriteLn( ListFile, 'Associated file ', InstPoint^.Name, ' line ',
        Number);
      Write( ListFile, TokenText[ InstPoint^.Inst]);
      Param:= InstPoint^.Params;
      WHILE Param <> NIL DO
        BEGIN
          Write( StdOut, ', ', Param^.Param);
          Write( ListFile, ', ', Param^.Param);
          Param:= Param^.Next;
        END;
      WriteLn( StdOut);
      WriteLn( ListFile);
    END;
  WriteLn( StdOut);
  WriteLn( ListFile);
  Inc( WarningCount);
END;

FUNCTION HexString( Value: LongInt; Count: Byte): SymbolString;

VAR
  FoundWord: SymbolString;
  Digit: Byte;

BEGIN
  FoundWord:= '';
  WHILE Value > 0 DO
    BEGIN
      Digit:= Value AND NibbleMask;
      FoundWord:= DigitText[ Succ( Digit)] + FoundWord;
      Value:= Value DIV 16;
    END;
  WHILE Length( FoundWord) < Count DO
    FoundWord:= '0' + FoundWord;
  HexString:= FoundWord;
END;

PROCEDURE ListInstruction( Address, Count: Word; Inst: InstPointer;
  Number: Byte);

VAR
  Param: ParamPointer;
  This: Word;

BEGIN
  Write( ListFile, Inst^.Line:5, ' ', TokenText[ Inst^.Inst]);
  Param:= Inst^.Params;
  FOR This:= 1 TO Number DO
    IF Param <> NIL THEN
      BEGIN
        Write( ListFile, ', ', Param^.Param);
        Param:= Param^.Next;
      END;
  WriteLn( ListFile);
  Write( ListFile, HexString( Address, 3), ' ');
  FOR This:= 0 TO Pred( Count) DO
    Write( ListFile, HexString( Memory[ Address + This], 2));
  WriteLn( ListFile);
  WriteLn( ListFile);
END;

PROCEDURE ListSymbols( Head: SymbolPointer);

BEGIN
  IF Head^.Left <> NIL THEN
    ListSymbols( Head^.Left);
  WriteLn( ListFile, HexString( Head^.Address, 3), ' ', Head^.Symbol);
  IF Head^.Right <> NIL THEN
    ListSymbols( Head^.Right);
END;

PROCEDURE ListWarnings;

BEGIN
  WriteLn( StdOut, WarningNumMessage, WarningCount);
  WriteLn( ListFile);
  WriteLn( ListFile, WarningNumMessage, WarningCount);
END;

FUNCTION ExpandFileName( Path: PathStr; DefName: NameStr; DefExt: ExtStr):
  PathStr;

VAR
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;

BEGIN
  FSplit( FExpand( Path), Dir, Name, Ext);
  IF Name = '' THEN
    Name:= DefName;
  IF Ext = '' THEN
    Ext:= DefExt;
  FileDir:= Dir;
  FileName:= Name;
  FileExt:= Ext;
  ExpandFileName:= Dir + Name + Ext;
END;

FUNCTION OpenFiles: Boolean;

VAR
  InFile: Text;

BEGIN
  OpenFiles:= False;
  IF ParamCount >= 1 THEN
    BEGIN
      InFileName:= ExpandFileName( ParamStr( 1), NameDefault, InExtDefault);
      IF FileName <> NameDefault THEN
        BEGIN
          OutFileName:= ParamStr( 2);
          ListFileName:= ParamStr( 3);
        END
      ELSE
        RunError( NoSourceError);
    END
  ELSE
    BEGIN
      Write( StdOut, 'SourceFileName? ');
      ReadLn( StdIn, InFileName);
      InFileName:= ExpandFileName( InFileName, NameDefault, InExtDefault);
      IF FileName <> NameDefault THEN
        BEGIN
          Write( StdOut, 'TargetFileName? ');
          ReadLn( StdIn, OutFileName);
          Write( StdOut, 'ListFileName? ');
          ReadLn( StdIn, ListFileName);
          WriteLn( StdOut);
        END
      ELSE
        RunError( NoSourceError);
    END;
  OutFileName:= ExpandFileName( OutFileName, FileName, OutExtDefault);
  ListFileName:= ExpandFileName( ListFileName, FileName, ListExtDefault);
  WriteLn( StdOut, 'SourceFile: ', InFileName);
  WriteLn( StdOut, 'TargetFile: ', OutFileName);
  Assign( OutFile, OutFileName);
  {$I-}
  ReWrite( OutFile);
  {$I+}
  IF IOResult <> 0 THEN
    RunError( FileAccessError);
  WriteLn( StdOut, 'ListFile: ', ListFileName);
  Assign( ListFile, ListFileName);
  {$I-}
  ReWrite( ListFile);
  {$I+}
  IF IOResult <> 0 THEN
    RunError( FileAccessError);
  WriteLn( StdOut);
  ListOpen:= True;
  WriteLn( ListFile, CopyRight);
  WriteLn( ListFile);
  WriteLn( ListFile, 'SourceFile: ', InFileName);
  WriteLn( ListFile, 'TargetFile: ', OutFileName);
  WriteLn( ListFile, 'ListFile: ', ListFileName);
  WriteLn( ListFile);
  OpenFiles:= True;
END;

FUNCTION StripSymbol( Symbol: SymbolString): SymbolString;

BEGIN
  IF Symbol[ 1] = SymbolChar THEN
    Symbol:= Copy( Symbol, 2, Pred( Length( Symbol)));
  IF Symbol[ Length( Symbol)] = LabelChar THEN
    Dec( Symbol[ 0]);
  StripSymbol:= Symbol;
END;

FUNCTION DefineSymbol( Symbol: SymbolString; Value: LongInt;
  VAR Head: SymbolPointer): Boolean;

VAR
  Symb, Last: SymbolPointer;

BEGIN
  DefineSymbol:= True;
  Symbol:= StripSymbol( Symbol);
  Last:= NIL;
  Symb:= Head;
  WHILE Symb <> NIL DO
    BEGIN
      Last:= Symb;
      IF Symbol = Last^.Symbol THEN
        DefineSymbol:= False;
      IF Symbol <= Symb^.Symbol THEN
        Symb:= Symb^.Left
      ELSE
        Symb:= Symb^.Right;
    END;
  New( Symb);
  Symb^.Symbol:= Symbol;
  Symb^.Address:= Value;
  Symb^.Left:= NIL;
  Symb^.Right:= NIL;
  IF Last = NIL THEN
    Head:= Symb
  ELSE
    IF Symbol <= Last^.Symbol THEN
      Last^.Left:= Symb
    ELSE
      Last^.Right:= Symb;
  LastSymbol:= Symb;
END;

FUNCTION ResolveSymbol( Symbol: SymbolString; VAR Value: LongInt;
  Head: SymbolPointer): Boolean;

BEGIN
  ResolveSymbol:= False;
  Value:= 0;
  Symbol:= StripSymbol( Symbol);
  WHILE Head <> NIL DO
    BEGIN
      IF Symbol = Head^.Symbol THEN
        BEGIN
          Value:= Head^.Address;
          ResolveSymbol:= True;
          Head:= NIL;
        END
      ELSE
        IF Symbol < Head^.Symbol THEN
          Head:= Head^.Left
        ELSE
          Head:= Head^.Right;
    END;
END;

FUNCTION ResolveNumber( Symbol: SymbolString; Base: Byte;
  VAR Value: LongInt): Boolean;

VAR
  Digit, Count: Byte;

BEGIN
  ResolveNumber:= True;
  IF Symbol = '' THEN
    ResolveNumber:= False;
  Value:= 0;
  Count:= 1;
  WHILE Count <= Length( Symbol) DO
    BEGIN
      Digit:= Pos( Symbol[ Count], DigitText);
      IF NOT ( Digit IN [ 1 .. Base]) THEN
        BEGIN
          ResolveNumber:= False;
          Count:= Length( Symbol);
        END
      ELSE
        Value:= Base * Value + Pred( Digit);
      Inc( Count);
    END;
END;

FUNCTION ResolveValue( Symbol: SymbolString; VAR Value: LongInt;
  Head: SymbolPointer): Boolean;

BEGIN
  ResolveValue:= False;
  Value:= 0;
  IF Symbol = AddressChar THEN
    BEGIN
      Value:= Current;
      ResolveValue:= True;
    END
  ELSE
    CASE Symbol[ 1] OF
      '0' .. '9':
        ResolveValue:= ResolveNumber( Symbol, 10, Value);
      HexChar:
        ResolveValue:= ResolveNumber( Copy( Symbol, 2,
          Pred( Length( Symbol))), 16, Value);
      BinChar:
        ResolveValue:= ResolveNumber( Copy( Symbol, 2,
          Pred( Length( Symbol))), 2, Value);
      OctChar:
        ResolveValue:= ResolveNumber( Copy( Symbol, 2,
          Pred( Length( Symbol))), 8, Value);
      AscChar:
        BEGIN
          IF Length( Symbol) >= 2 THEN
            Value:= Ord( Symbol[ 2]);
          IF Length( Symbol) = 2 THEN
            ResolveValue:= True;
        END;
    ELSE
      ResolveValue:= ResolveSymbol( Symbol, Value, Head);
    END;
END;

FUNCTION SplitParam( VAR Param: ParamString): SymbolString;

VAR
  FoundWord: ParamString;
  Character: Char;
  Start, Count: Byte;
  Reading: Boolean;

BEGIN
  FoundWord:= '';
  Reading:= True;
  Start:= 0;
  Count:= 1;
  WHILE Count <= Length( Param) DO
    BEGIN
      Character:= Param[ Count];
      IF ( Character > SpaceChar) THEN
        BEGIN
          Start:= Count;
          Count:= Length( Param);
        END;
      Inc( Count);
    END;
  IF Start > 0 THEN
    BEGIN
      Count:= Start;
      Character:= Param[ Count];
      IF Character IN Operators THEN
        BEGIN
          FoundWord:= Character;
          Param:= Copy( Param, Succ( Count), Length( Param) - Count);
          Reading:= False;
        END
      ELSE
        WHILE Count <= Length( Param) DO
          BEGIN
            Character:= Param[ Count];
            IF ( Character <= SpaceChar) OR ( Character IN Operators) THEN
              BEGIN
                Param:= Copy( Param, Count, Length( Param) - Pred( Count));
                Count:= Length( Param);
                Reading:= False;
              END
            ELSE
              FoundWord:= FoundWord + Character;
            Inc( Count);
          END;
    END;
  IF Reading THEN
    Param:= '';
  SplitParam:= FoundWord;
END;

FUNCTION ResolveOperator( Symbol: SymbolString; VAR Token: Char;
  Legal: CharSet): Boolean;

BEGIN
  Token:= SpaceChar;
  IF Length( Symbol) >= 1 THEN
    Token:= Symbol[ 1];
  ResolveOperator:= Token IN Legal;
END;

FUNCTION ResolveSingle( Token: Char; VAR Value: LongInt): Boolean;

BEGIN
  ResolveSingle:= True;
  CASE Token OF
    PlusChar:
      { Nothing to be done };
    MinusChar:
      Value:= - Value;
    NotChar:
      Value:= NOT Value;
  ELSE
    ResolveSingle:= False;
  END;
END;

FUNCTION ResolveDouble( Token: Char; VAR Value: LongInt;
  Operand: LongInt): Boolean;

VAR
  Count, This: LongInt;

BEGIN
  ResolveDouble:= True;
  CASE Token OF
    PowerChar:
      BEGIN
        This:= 1;
        FOR Count:= 1 TO Operand DO
          This:= This * Value;
        Value:= This;
      END;
    ShlChar:
      Value:= Value SHL Operand;
    ShrChar:
      Value:= Value SHR Operand;
    MulChar:
      Value:= Value * Operand;
    FracChar, DivChar:
      Value:= Value DIV Operand;
    PlusChar:
      Value:= Value + Operand;
    MinusChar:
      Value:= Value - Operand;
    AndChar:
      Value:= Value AND Operand;
    OrChar:
      Value:= Value OR Operand;
    XorChar:
      Value:= Value XOR Operand;
    ModChar:
      Value:= Value MOD Operand;
  ELSE
    ResolveDouble:= False;
  END;
END;

FUNCTION ResolveDivMod( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

FORWARD;

FUNCTION ResolveParent( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

VAR
  Token: Char;
  Status: Boolean;

BEGIN
  IF ResolveOperator( Symbol, Token, [ StartChar]) THEN
    BEGIN
      Symbol:= SplitParam( Param);
      Status:= ResolveDivMod( Symbol, Param, Value, Head);
      IF NOT ResolveOperator( Symbol, Token, [ StopChar]) THEN
        Status:= False;
      Symbol:= SplitParam( Param);
    END
  ELSE
    BEGIN
      Status:= ResolveValue( Symbol, Value, Head);
      Symbol:= SplitParam( Param);
    END;
  ResolveParent:= Status;
END;

FUNCTION ResolveUnary( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

VAR
  Token: Char;
  Status: Boolean;

BEGIN
  IF ResolveOperator( Symbol, Token, [ PlusChar, MinusChar, NotChar]) THEN
    BEGIN
      Symbol:= SplitParam( Param);
      Status:= ResolveParent( Symbol, Param, Value, Head);
      Status:= Status AND ResolveSingle( Token, Value);
    END
  ELSE
    Status:= ResolveParent( Symbol, Param, Value, Head);
  ResolveUnary:= Status;
END;

FUNCTION ResolvePower( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

VAR
  Operand: LongInt;
  Token: Char;
  Status: Boolean;

BEGIN
  Operand:= 0;
  Status:= ResolveUnary( Symbol, Param, Value, Head);
  WHILE ResolveOperator( Symbol, Token, [ PowerChar, ShlChar, ShrChar]) DO
    BEGIN
      Symbol:= SplitParam( Param);
      Status:= Status AND ResolveUnary( Symbol, Param, Operand, Head);
      Status:= Status AND ResolveDouble( Token, Value, Operand);
    END;
  ResolvePower:= Status;
END;

FUNCTION ResolveMulDiv( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

VAR
  Operand: LongInt;
  Token: Char;
  Status: Boolean;

BEGIN
  Operand:= 0;
  Status:= ResolvePower( Symbol, Param, Value, Head);
  WHILE ResolveOperator( Symbol, Token, [ MulChar, FracChar]) DO
    BEGIN
      Symbol:= SplitParam( Param);
      Status:= Status AND ResolvePower( Symbol, Param, Operand, Head);
      Status:= Status AND ResolveDouble( Token, Value, Operand);
    END;
  ResolveMulDiv:= Status;
END;

FUNCTION ResolvePlusMinus( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

VAR
  Operand: LongInt;
  Token: Char;
  Status: Boolean;

BEGIN
  Operand:= 0;
  Status:= ResolveMulDiv( Symbol, Param, Value, Head);
  WHILE ResolveOperator( Symbol, Token, [ PlusChar, MinusChar]) DO
    BEGIN
      Symbol:= SplitParam( Param);
      Status:= Status AND ResolveMulDiv( Symbol, Param, Operand, Head);
      Status:= Status AND ResolveDouble( Token, Value, Operand);
    END;
  ResolvePlusMinus:= Status;
END;

FUNCTION ResolveBitWise( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

VAR
  Operand: LongInt;
  Token: Char;
  Status: Boolean;

BEGIN
  Operand:= 0;
  Status:= ResolvePlusMinus( Symbol, Param, Value, Head);
  WHILE ResolveOperator( Symbol, Token, [ AndChar, OrChar, XorChar]) DO
    BEGIN
      Symbol:= SplitParam( Param);
      Status:= Status AND ResolvePlusMinus( Symbol, Param, Operand, Head);
      Status:= Status AND ResolveDouble( Token, Value, Operand);
    END;
  ResolveBitWise:= Status;
END;

FUNCTION ResolveDivMod( VAR Symbol: SymbolString; VAR Param: ParamString;
  VAR Value: LongInt; Head: SymbolPointer): Boolean;

VAR
  Operand: LongInt;
  Token: Char;
  Status: Boolean;

BEGIN
  Operand:= 0;
  Status:= ResolveBitWise( Symbol, Param, Value, Head);
  WHILE ResolveOperator( Symbol, Token, [ DivChar, ModChar]) DO
    BEGIN
      Symbol:= SplitParam( Param);
      Status:= Status AND ResolveBitWise( Symbol, Param, Operand, Head);
      Status:= Status AND ResolveDouble( Token, Value, Operand);
    END;
  ResolveDivMod:= Status;
END;

FUNCTION ResolveExpression( Param: ParamString; VAR Value: LongInt;
  Head: SymbolPointer): Boolean;

VAR
  Symbol: SymbolString;

BEGIN
  ResolveExpression:= False;
  Value:= 0;
  Symbol:= SplitParam( Param);
  IF Symbol <> '' THEN
    ResolveExpression:= ResolveDivMod( Symbol, Param, Value, Head);
  IF Symbol <> '' THEN
    ResolveExpression:= False;
END;

PROCEDURE StoreDirectives( Min, Max: Byte; VAR DirHead: SymbolPointer);

VAR
  This: Byte;

BEGIN
  This:= Min + (( Max - Min) DIV 2);
  IF NOT DefineSymbol( TokenText[ Token( This)], This, DirHead) THEN
    RunWarning( CopySymbolWarning);
  IF This <> Min THEN
    StoreDirectives( Min, Pred( This), DirHead);
  IF This <> Max THEN
    StoreDirectives( Succ( This), Max, DirHead);
END;

PROCEDURE StoreRegisters( Min, Max: Byte; VAR RegHead: SymbolPointer);

VAR
  This: Byte;

BEGIN
  This:= Min + (( Max - Min) DIV 2);
  IF NOT DefineSymbol( RegisterText[ Register( This)], This, RegHead) THEN
    RunWarning( CopySymbolWarning);
  IF This <> Min THEN
    StoreRegisters( Min, Pred( This), RegHead);
  IF This <> Max THEN
    StoreRegisters( Succ( This), Max, RegHead);
END;

FUNCTION SplitLine( VAR Line: LineString; AbortFlag: Boolean): ParamString;

VAR
  FoundWord: ParamString;
  Character: Char;
  Level, Start, Count: Byte;
  TextFlag, Reading: Boolean;

BEGIN
  FoundWord:= '';
  Level:= 0;
  TextFlag:= False;
  Reading:= True;
  Start:= 0;
  Count:= 1;
  WHILE Count <= Length( Line) DO
    BEGIN
      Character:= Line[ Count];
      IF Character = RemarkChar THEN
        Count:= Length( Line)
      ELSE
        IF ( Character > SpaceChar) AND ( Character <> SeparatorChar) THEN
          BEGIN
            Start:= Count;
            Count:= Length( Line);
          END;
      Inc( Count);
    END;
  IF Start > 0 THEN
    BEGIN
      Count:= Start;
      Dec( Count);
      WHILE Count < Length( Line) DO
        BEGIN
          Inc( Count);
          Character:= Line[ Count];
          IF Character = TextChar THEN
            BEGIN
              IF Line[ Pred( Count)] = TextChar THEN
                FoundWord:= FoundWord + TextChar;
              TextFlag:= NOT TextFlag;
            END
          ELSE
            IF TextFlag THEN
              FoundWord:= FoundWord + Character
            ELSE
              CASE Character OF
                NullChar .. SpaceChar:
                  IF AbortFlag AND ( Level = 0) THEN
                    BEGIN
                      Line:= Copy( Line, Count,
                        Length( Line) - Pred( Count));
                      Reading:= False;
                      Count:= Length( Line);
                    END
                  ELSE
                    IF FoundWord[ Length( FoundWord)] <> SpaceChar THEN
                      FoundWord:= FoundWord + SpaceChar;
                SeparatorChar:
                  IF Level = 0 THEN
                    BEGIN
                      Line:= Copy( Line, Count,
                        Length( Line) - Pred( Count));
                      Reading:= False;
                      Count:= Length( Line);
                    END
                  ELSE
                    FoundWord:= FoundWord + Character;
                RemarkChar:
                  BEGIN
                    Line:= '';
                    Reading:= False;
                    Count:= Length( Line);
                  END;
                StartChar:
                  BEGIN
                    Inc( Level);
                    FoundWord:= FoundWord + Character;
                  END;
                StopChar:
                  BEGIN
                    Dec( Level);
                    FoundWord:= FoundWord + Character;
                  END;
              ELSE
                FoundWord:= FoundWord + UpCase( Character);
              END;
        END;
    END;
  IF Reading THEN
    Line:= '';
  WHILE FoundWord[ Length( FoundWord)] = SpaceChar DO
    Dec( FoundWord[ 0]);
  SplitLine:= FoundWord;
END;

PROCEDURE ReleaseSymbols( VAR SymbHead: SymbolPointer);

BEGIN
  IF SymbHead^.Left <> NIL THEN
    ReleaseSymbols( SymbHead^.Left);
  IF SymbHead^.Right <> NIL THEN
    ReleaseSymbols( SymbHead^.Right);
  Dispose( SymbHead);
  SymbHead:= NIL;
END;

PROCEDURE ReleaseParams( VAR ParamHead: ParamPointer);

VAR
  Param: ParamPointer;

BEGIN
  WHILE ParamHead <> NIL DO
    BEGIN
      Param:= ParamHead^.Next;
      Dispose( ParamHead);
      ParamHead:= Param;
    END;
END;

PROCEDURE ReleaseInsts( VAR InstHead: InstPointer);

VAR
  Inst: InstPointer;

BEGIN
  WHILE InstHead <> NIL DO
    BEGIN
      ReleaseParams( InstHead^.Params);
      Inst:= InstHead^.Prev;
      Dispose( InstHead);
      InstHead:= Inst;
    END;
END;

PROCEDURE AlignWordBounds;

BEGIN
  Current:= 2 * ( Succ( Current) DIV 2);
  IF Current > Finish THEN
    Finish:= Current;
  IF ( Current < StartAddress) OR ( Current > StopAddress) THEN
    RunError( BoundsError);
END;

FUNCTION ParamCheck( Count, Min, Max: Byte): Boolean;

BEGIN
  ParamCheck:= False;
  IF ( Count < Min) OR ( Count > Max) THEN
    RunWarning( ParamCountWarning);
  IF Count >= Min THEN
    ParamCheck:= True;
END;

FUNCTION RangeCheck( Value, Min, Max: LongInt; Message: STRING): Boolean;

BEGIN
  RangeCheck:= False;
  IF ( Value < Min) OR ( Value > Max) THEN
    BEGIN
      RunWarning( Message);
      RangeCheck:= True;
    END;
END;

PROCEDURE DecodeFile( Name: PathStr; VAR Head: InstPointer;
  Dir: SymbolPointer; VAR Symb: SymbolPointer);

FORWARD;

FUNCTION DecodeParameters( Line: LineString; VAR Head: ParamPointer): Byte;

VAR
  FoundWord: ParamString;
  Param, Last: ParamPointer;
  Count: Byte;

BEGIN
  Head:= NIL;
  Count:= 0;
  Last:= NIL;
  REPEAT
    FoundWord:= SplitLine( Line, False);
    IF FoundWord <> '' THEN
      BEGIN
        New( Param);
        Param^.Param:= FoundWord;
        Param^.Next:= NIL;
        IF Last = NIL THEN
          Head:= Param
        ELSE
          Last^.Next:= Param;
        Last:= Param;
        Inc( Count);
      END;
  UNTIL Line = '';
  DecodeParameters:= Count;
END;

PROCEDURE DecodeDirective( Direct: Token; Line: LineString; Valid: Boolean;
  VAR Head: InstPointer; Dir: SymbolPointer; VAR Symb: SymbolPointer);

VAR
  Inst: InstPointer;
  ParamHead: ParamPointer;
  Value: LongInt;
  Count: Byte;

BEGIN
  Count:= DecodeParameters( Line, ParamHead);
  CASE Direct OF
    EquToken, EqualToken:
      IF NOT Valid THEN
        RunWarning( NoSymbolWarning)
      ELSE
        IF ParamCheck( Count, 1, 1) THEN
          BEGIN
            IF NOT ResolveExpression( ParamHead^.Param, Value, Symb) THEN
              RunWarning( UndefinedWarning);
            IF LastSymbol <> NIL THEN
              LastSymbol^.Address:= Value;
          END;
    DsToken:
      IF ParamCheck( Count, 1, 1) THEN
        BEGIN
          IF NOT ResolveExpression( ParamHead^.Param, Value, Symb) THEN
            RunWarning( UndefinedWarning);
          Inc( Current, Value);
        END;
    OrgToken:
      IF ParamCheck( Count, 1, 1) THEN
        BEGIN
          IF ResolveExpression( ParamHead^.Param, Value, Symb) THEN
            Current:= Value
          ELSE
            RunWarning( UndefinedWarning);
        END;
    IncludeToken:
      BEGIN
        IF ParamCheck( Count, 1, 1) THEN
          DecodeFile( ParamHead^.Param, Head, Dir, Symb);
        ReleaseParams( ParamHead);
      END;
    EndToken:
      BEGIN
        IF ParamCheck( Count, 0, 0) THEN
        { The END directive is ignored };
        ReleaseParams( ParamHead);
      END;
  ELSE
    New( Inst);
    Inst^.Line:= LineNum;
    Inst^.Name:= LineName;
    Inst^.Address:= Current;
    Inst^.Inst:= Direct;
    Inst^.Count:= Count;
    Inst^.Params:= ParamHead;
    Inst^.Next:= NIL;
    Inst^.Prev:= Head;
    IF Head <> NIL THEN
      Head^.Next:= Inst;
    Head:= Inst;
    CASE Direct OF
      DbToken:
        IF ParamCheck( Count, 1, MaxParams) THEN
          Inc( Current, Count);
      DwToken:
        IF ParamCheck( Count, 1, MaxParams) THEN
          Inc( Current, 2 * Count);
      DaToken:
        IF ParamCheck( Count, 1, 1) THEN
          Inc( Current, Length( ParamHead^.Param));
    ELSE
      Inc( Current, 2);
    END;
  END;
END;

PROCEDURE DecodeLine( Line: LineString; VAR Head: InstPointer;
  Dir: SymbolPointer; VAR Symb: SymbolPointer);

VAR
  Direct: ParamString;
  Value: LongInt;
  Valid: Boolean;

BEGIN
  Valid:= False;
  REPEAT
    Direct:= SplitLine( Line, True);
    IF Direct <> '' THEN
      BEGIN
        IF NOT ResolveSymbol( Direct, Value, Dir) THEN
          BEGIN
            IF Valid THEN
              RunWarning( DualSymbolWarning);
            IF NOT DefineSymbol( Direct, Current, Symb) THEN
              RunWarning( CopySymbolWarning);
            Valid:= True;
          END
        ELSE
          BEGIN
            DecodeDirective( Token( Value), Line, Valid, Head, Dir, Symb);
            AlignWordBounds;
            Line:= '';
          END;
      END;
  UNTIL Line = '';
END;

PROCEDURE DecodeFile( Name: PathStr; VAR Head: InstPointer;
  Dir: SymbolPointer; VAR Symb: SymbolPointer);

VAR
  InFile: Text;
  Line: LineString;
  StoreName: PathStr;
  StoreNum: Word;

BEGIN
  StoreName:= LineName;
  StoreNum:= LineNum;
  LineName:= ExpandFileName( Name, NameDefault, InExtDefault);
  LineNum:= 1;
  WriteLn( StdOut, 'Reading: ', LineName);
  WriteLn( StdOut);
  WriteLn( ListFile, 'Reading: ', LineName);
  WriteLn( ListFile);
  Assign( InFile, LineName);
  {$I-}
  ReSet( InFile);
  {$I+}
  IF IOResult <> 0 THEN
    RunError( FileAccessError);
  WHILE NOT EOF( InFile) DO
    BEGIN
      ReadLn( InFile, Line);
      LineText:= Line;
      DecodeLine( Line, Head, Dir, Symb);
      Inc( LineNum);
    END;
  Close( InFile);
  LineName:= StoreName;
  LineNum:= StoreNum;
  IF LineName <> NameDefault THEN
    BEGIN
      WriteLn( StdOut, 'Reading: ', LineName);
      WriteLn( StdOut);
      WriteLn( ListFile, 'Reading: ', LineName);
      WriteLn( ListFile);
    END
  ELSE
    BEGIN
      WriteLn( StdOut, 'Done reading');
      WriteLn( StdOut);
      WriteLn( ListFile, 'Done reading');
      WriteLn( ListFile);
    END;
END;

PROCEDURE EncodeNoneToken( Instruct: InstPointer; OpCode: Word;
  Reg, Symb: SymbolPointer);

BEGIN
  WITH Instruct^ DO
    BEGIN
      IF ParamCheck( Count, 0, 0) THEN
        { Generate instruction anyway };
      Memory[ Address]:= OpCode DIV 256;
      Memory[ Succ( Address)]:= OpCode MOD 256;
      ListInstruction( Address, 2, Instruct, 0);
    END;
END;

PROCEDURE EncodeAddrToken( Instruct: InstPointer; OpCode: Word;
  Reg, Symb: SymbolPointer);

VAR
  Addr: LongInt;

BEGIN
  Addr:= 0;
  WITH Instruct^ DO
    BEGIN
      IF ParamCheck( Count, 1, 1) THEN
        IF NOT ResolveExpression( Params^.Param, Addr, Symb) THEN
          RunWarning( UndefinedWarning);
      IF RangeCheck( Addr, 0, AddrMask, RangeWarning) THEN
        Addr:= Addr AND AddrMask;
      Addr:= OpCode OR Addr;
      Memory[ Address]:= Addr DIV 256;
      Memory[ Succ( Address)]:= Addr MOD 256;
      ListInstruction( Address, 2, Instruct, 1);
    END;
END;

PROCEDURE EncodeRegToken( Instruct: InstPointer; OpCode: Word;
  Reg, Symb: SymbolPointer);

VAR
  RegX: LongInt;

BEGIN
  RegX:= Ord( V0Reg);
  WITH Instruct^ DO
    BEGIN
      IF ParamCheck( Count, 1, 1) THEN
        IF ResolveSymbol( Params^.Param, RegX, Reg) THEN
          RegX:= RegX - Ord( V0Reg)
        ELSE
          RunWarning( NoRegisterWarning);
      IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
        RegX:= 0;
      RegX:= OpCode OR $100 * RegX;
      Memory[ Address]:= RegX DIV 256;
      Memory[ Succ( Address)]:= RegX MOD 256;
      ListInstruction( Address, 2, Instruct, 1);
    END;
END;

PROCEDURE EncodeRegValToken( Instruct: InstPointer; OpCode: Word;
  Reg, Symb: SymbolPointer);

VAR
  RegX, Value: LongInt;

BEGIN
  RegX:= Ord( V0Reg);
  Value:= 0;
  WITH Instruct^ DO
    BEGIN
      IF Count >= 1 THEN
        IF ResolveSymbol( Params^.Param, RegX, Reg) THEN
          RegX:= RegX - Ord( V0Reg)
        ELSE
          RunWarning( NoRegisterWarning);
      IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
        RegX:= 0;
      IF ParamCheck( Count, 2, 2) THEN
        IF NOT ResolveExpression( Params^.Next^.Param, Value, Symb) THEN
          RunWarning( UndefinedWarning);
      IF RangeCheck( Value, 0, ByteMask, RangeWarning) THEN
        Value:= Value AND ByteMask;
      Value:= OpCode OR $100 * RegX OR Value;
      Memory[ Address]:= Value DIV 256;
      Memory[ Succ( Address)]:= Value MOD 256;
      ListInstruction( Address, 2, Instruct, 2);
    END;
END;

PROCEDURE EncodeRegRegToken( Instruct: InstPointer; OpCode: Word; Min: Byte;
  Reg, Symb: SymbolPointer);

VAR
  RegX, RegY: LongInt;

BEGIN
  RegX:= Ord( V0Reg);
  RegY:= Ord( V0Reg);
  WITH Instruct^ DO
    BEGIN
      IF ParamCheck( Count, Min, 2) THEN
        IF ResolveSymbol( Params^.Param, RegX, Reg) THEN
          RegX:= RegX - Ord( V0Reg)
        ELSE
          RunWarning( NoRegisterWarning);
      IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
        RegX:= 0;
      IF Count >= 2 THEN
        IF ResolveSymbol( Params^.Next^.Param, RegY, Reg) THEN
          RegY:= RegY - Ord( V0Reg)
        ELSE
          RunWarning( NoRegisterWarning);
      IF RangeCheck( RegY, 0, NibbleMask, BadRegisterWarning) THEN
        RegY:= 0;
      RegX:= OpCode OR $100 * RegX OR $10 * RegY;
      Memory[ Address]:= RegX DIV 256;
      Memory[ Succ( Address)]:= RegX MOD 256;
      ListInstruction( Address, 2, Instruct, 2);
    END;
END;

PROCEDURE EncodeRegRegOrValToken( Instruct: InstPointer;
  OpCode1, OpCode2: Word; Reg, Symb: SymbolPointer);

VAR
  RegX, RegY, Value: LongInt;

BEGIN
  RegX:= Ord( V0Reg);
  RegY:= Ord( V0Reg);
  Value:= 0;
  WITH Instruct^ DO
    BEGIN
      IF Count >= 1 THEN
        IF ResolveSymbol( Params^.Param, RegX, Reg) THEN
          RegX:= RegX - Ord( V0Reg)
        ELSE
          RunWarning( NoRegisterWarning);
      IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
        RegX:= 0;
      IF ParamCheck( Count, 2, 2) THEN
        IF ResolveSymbol( Params^.Next^.Param, RegY, Reg) THEN
          BEGIN
            RegY:= RegY - Ord( V0Reg);
            IF RangeCheck( RegY, 0, NibbleMask, BadRegisterWarning) THEN
              RegY:= 0;
            Value:= OpCode1 OR $100 * RegX OR $10 * RegY;
            Memory[ Address]:= Value DIV 256;
            Memory[ Succ( Address)]:= Value MOD 256;
            ListInstruction( Address, 2, Instruct, 2);
          END
        ELSE
          BEGIN
            IF NOT ResolveExpression( Params^.Next^.Param, Value, Symb) THEN
              RunWarning( UndefinedWarning);
            IF RangeCheck( Value, 0, ByteMask, RangeWarning) THEN
              Value:= Value AND ByteMask;
            Value:= OpCode2 OR $100 * RegX OR Value;
            Memory[ Address]:= Value DIV 256;
            Memory[ Succ( Address)]:= Value MOD 256;
            ListInstruction( Address, 2, Instruct, 2);
          END;
    END;
END;

PROCEDURE EncodeRegRegValToken( Instruct: InstPointer; OpCode: Word;
  Reg, Symb: SymbolPointer);

VAR
  RegX, RegY, Value: LongInt;

BEGIN
  RegX:= Ord( V0Reg);
  RegY:= Ord( V0Reg);
  Value:= 0;
  WITH Instruct^ DO
    BEGIN
      IF Count >= 1 THEN
        IF ResolveSymbol( Params^.Param, RegX, Reg) THEN
          RegX:= RegX - Ord( V0Reg)
        ELSE
          RunWarning( NoRegisterWarning);
      IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
        RegX:= 0;
      IF Count >= 2 THEN
        IF ResolveSymbol( Params^.Next^.Param, RegY, Reg) THEN
          RegY:= RegY - Ord( V0Reg)
        ELSE
          RunWarning( NoRegisterWarning);
      IF RangeCheck( RegY, 0, NibbleMask, BadRegisterWarning) THEN
        RegY:= 0;
      IF ParamCheck( Count, 3, 3) THEN
        IF NOT ResolveExpression( Params^.Next^.Next^.Param, Value,
          Symb) THEN
            RunWarning( UndefinedWarning);
      IF RangeCheck( Value, 0, NibbleMask, RangeWarning) THEN
        Value:= Value AND NibbleMask;
      Value:= OpCode OR $100 * RegX OR $10 * RegY OR Value;
      Memory[ Address]:= Value DIV 256;
      Memory[ Succ( Address)]:= Value MOD 256;
      ListInstruction( Address, 2, Instruct, 3);
    END;
END;

PROCEDURE EncodeAddToken( Instruct: InstPointer; Reg, Symb: SymbolPointer);

VAR
  RegX, RegY, Value: LongInt;

BEGIN
  RegX:= Ord( V0Reg);
  RegY:= Ord( V0Reg);
  Value:= 0;
  WITH Instruct^ DO
    BEGIN
      IF Count >= 1 THEN
        IF NOT ResolveSymbol( Params^.Param, RegX, Reg) THEN
          RunWarning( NoRegisterWarning);
      IF RegX = Ord( IReg) THEN
        BEGIN
          IF ParamCheck( Count, 2, 2) THEN
            IF ResolveSymbol( Params^.Next^.Param, RegX, Reg) THEN
              RegX:= RegX - Ord( V0Reg)
            ELSE
              RunWarning( NoRegisterWarning);
          IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
            RegX:= 0;
          Value:= $f01e OR $100 * RegX;
          Memory[ Address]:= Value DIV 256;
          Memory[ Succ( Address)]:= Value MOD 256;
          ListInstruction( Address, 2, Instruct, 2);
        END
      ELSE
        BEGIN
          RegX:= RegX - Ord( V0Reg);
          IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
            RegX:= 0;
          IF ParamCheck( Count, 2, 2) THEN
            IF ResolveSymbol( Params^.Next^.Param, RegY, Reg) THEN
              BEGIN
                RegY:= RegY - Ord( V0Reg);
                IF RangeCheck( RegY, 0, NibbleMask, BadRegisterWarning) THEN
                  RegY:= 0;
                Value:= $8004 OR $100 * RegX OR $10 * RegY;
                Memory[ Address]:= Value DIV 256;
                Memory[ Succ( Address)]:= Value MOD 256;
                ListInstruction( Address, 2, Instruct, 2);
              END
            ELSE
              BEGIN
                IF NOT ResolveExpression( Params^.Next^.Param, Value,
                  Symb) THEN
                    RunWarning( UndefinedWarning);
                IF RangeCheck( Value, 0, ByteMask, RangeWarning) THEN
                  Value:= Value AND ByteMask;
                Value:= $7000 OR $100 * RegX OR Value;
                Memory[ Address]:= Value DIV 256;
                Memory[ Succ( Address)]:= Value MOD 256;
                ListInstruction( Address, 2, Instruct, 2);
              END;
        END;
    END;
END;

PROCEDURE EncodeJpToken( Instruct: InstPointer; Reg, Symb: SymbolPointer);

VAR
  RegX, Addr: LongInt;

BEGIN
  RegX:= Ord( V0Reg);
  Addr:= Ord( V0Reg);
  WITH Instruct^ DO
    IF ParamCheck( Count, 1, 2) THEN
      IF ResolveSymbol( Params^.Param, RegX, Reg) THEN
        BEGIN
          IF RegX <> Ord( V0Reg) THEN
            RunWarning( BadRegisterWarning);
          IF Count = 1 THEN
            RunWarning( ParamCountWarning)
          ELSE
            IF NOT ResolveExpression( Params^.Next^.Param, Addr, Symb) THEN
              RunWarning( UndefinedWarning);
          IF RangeCheck( Addr, 0, AddrMask, RangeWarning) THEN
            Addr:= Addr AND AddrMask;
          Addr:= $b000 OR Addr;
          Memory[ Address]:= Addr DIV 256;
          Memory[ Succ( Address)]:= Addr MOD 256;
          ListInstruction( Address, 2, Instruct, 2);
        END
      ELSE
        BEGIN
          IF NOT ResolveExpression( Params^.Param, Addr, Symb) THEN
            RunWarning( UndefinedWarning);
          IF Count = 2 THEN
            RunWarning( ParamCountWarning);
          IF RangeCheck( Addr, 0, AddrMask, RangeWarning) THEN
            Addr:= Addr AND AddrMask;
          Addr:= $1000 OR Addr;
          Memory[ Address]:= Addr DIV 256;
          Memory[ Succ( Address)]:= Addr MOD 256;
          ListInstruction( Address, 2, Instruct, 1);
        END;
END;

PROCEDURE EncodeLdToken( Instruct: InstPointer; Reg, Symb: SymbolPointer);

VAR
  RegX, RegY, Value: LongInt;
  RegFlag: Boolean;

BEGIN
  RegX:= Ord( V0Reg);
  RegY:= Ord( V0Reg);
  Value:= 0;
  RegFlag:= True;
  WITH Instruct^ DO
    BEGIN
      IF Count >= 1 THEN
        IF NOT ResolveSymbol( Params^.Param, RegX, Reg) THEN
          RunWarning( NoRegisterWarning);
      CASE RegX OF
        Ord( BReg), Ord( DtReg), Ord( FReg), Ord( StReg), Ord( IiReg):
          BEGIN
            RegY:= RegX;
            RegX:= Ord( V0Reg);
            IF ParamCheck( Count, 2, 2) THEN
              IF ResolveSymbol( Params^.Next^.Param, RegX, Reg) THEN
                RegX:= RegX - Ord( V0Reg)
              ELSE
                RunWarning( NoRegisterWarning);
            IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
              RegX:= 0;
            CASE RegY OF
              Ord( BReg):
                Value:= $f033 OR $100 * RegX;
              Ord( DtReg):
                Value:= $f015 OR $100 * RegX;
              Ord( Freg):
                Value:= $f029 OR $100 * RegX;
              Ord( StReg):
                Value:= $f018 OR $100 * RegX;
              Ord( IiReg):
                Value:= $f055 OR $100 * RegX;
            ELSE
              RunWarning( InternalWarning);
            END;
            Memory[ Address]:= Value DIV 256;
            Memory[ Succ( Address)]:= Value MOD 256;
            ListInstruction( Address, 2, Instruct, 2);
          END;
        Ord( IReg):
          BEGIN
            IF ParamCheck( Count, 2, 2) THEN
              IF NOT ResolveExpression( Params^.Next^.Param, Value,
                Symb) THEN
                  RunWarning( UndefinedWarning);
            IF RangeCheck( Value, 0, AddrMask, RangeWarning) THEN
              Value:= Value AND AddrMask;
            Value:= $a000 OR Value;
            Memory[ Address]:= Value DIV 256;
            Memory[ Succ( Address)]:= Value MOD 256;
            ListInstruction( Address, 2, Instruct, 2);
          END;
      ELSE
        RegX:= RegX - Ord( V0Reg);
        IF RangeCheck( RegX, 0, NibbleMask, BadRegisterWarning) THEN
          RegX:= 0;
        IF ParamCheck( Count, 2, 2) THEN
          RegFlag:= ResolveSymbol( Params^.Next^.Param, RegY, Reg);
        IF RegFlag THEN
          CASE RegY OF
            Ord( DtReg):
              BEGIN
                Value:= $f007 OR $100 * RegX;
                Memory[ Address]:= Value DIV 256;
                Memory[ Succ( Address)]:= Value MOD 256;
                ListInstruction( Address, 2, Instruct, 2);
              END;
            Ord( KReg):
              BEGIN
                Value:= $f00a OR $100 * RegX;
                Memory[ Address]:= Value DIV 256;
                Memory[ Succ( Address)]:= Value MOD 256;
                ListInstruction( Address, 2, Instruct, 2);
              END;
            Ord( IiReg):
              BEGIN
                Value:= $f065 OR $100 * RegX;
                Memory[ Address]:= Value DIV 256;
                Memory[ Succ( Address)]:= Value MOD 256;
                ListInstruction( Address, 2, Instruct, 2);
              END;
          ELSE
            RegY:= RegY - Ord( V0Reg);
            IF RangeCheck( RegY, 0, NibbleMask,
              BadRegisterWarning) THEN
                RegY:= 0;
            Value:= $8000 OR $100 * RegX OR $10 * RegY;
            Memory[ Address]:= Value DIV 256;
            Memory[ Succ( Address)]:= Value MOD 256;
            ListInstruction( Address, 2, Instruct, 2);
          END
        ELSE
          BEGIN
            IF Count >= 2 THEN
              IF NOT ResolveExpression( Params^.Next^.Param, Value,
                Symb) THEN
                  RunWarning( UndefinedWarning);
            IF RangeCheck( Value, 0, ByteMask, RangeWarning) THEN
              Value:= Value AND ByteMask;
            Value:= $6000 OR $100 * RegX OR Value;
            Memory[ Address]:= Value DIV 256;
            Memory[ Succ( Address)]:= Value MOD 256;
            ListInstruction( Address, 2, Instruct, 2);
          END;
      END;
    END;
END;

PROCEDURE EncodeDaToken( Instruct: InstPointer; Reg, Symb: SymbolPointer);

VAR
  Param: ParamString;
  This: Byte;

BEGIN
  Param:= '';
  WITH Instruct^ DO
    BEGIN
      IF Count >= 1 THEN
        Param:= Params^.Param;
      FOR This:= 1 TO Length( Param) DO
        Memory[ Address + Pred( This)]:= Ord( Param[ This]);
      ListInstruction( Address, Length( Param), Instruct, 1);
    END;
END;

PROCEDURE EncodeDbToken( Instruct: InstPointer; Reg, Symb: SymbolPointer);

VAR
  Param: ParamPointer;
  Value: LongInt;
  This: Byte;

BEGIN
  This:= 0;
  Value:= 0;
  WITH Instruct^ DO
    BEGIN
      Param:= Params;
      WHILE Param <> NIL DO
        BEGIN
          IF NOT ResolveExpression( Param^.Param, Value, Symb) THEN
            RunWarning( UndefinedWarning);
          IF RangeCheck( Value, 0, ByteMask, RangeWarning) THEN
            Value:= Value AND ByteMask;
          Memory[ Address + This]:= Value;
          Inc( This);
          Param:= Param^.Next;
        END;
      ListInstruction( Address, Count, Instruct, Count);
    END;
END;

PROCEDURE EncodeDwToken( Instruct: InstPointer; Reg, Symb: SymbolPointer);

VAR
  Param: ParamPointer;
  Value: LongInt;
  This: Byte;

BEGIN
  This:= 0;
  Value:= 0;
  WITH Instruct^ DO
    BEGIN
      Param:= Params;
      WHILE Param <> NIL DO
        BEGIN
          IF NOT ResolveExpression( Param^.Param, Value, Symb) THEN
            RunWarning( UndefinedWarning);
          IF RangeCheck( Value, 0, WordMask, RangeWarning) THEN
            Value:= Value AND WordMask;
          Memory[ Address + This]:= Value DIV 256;
          Memory[ Address + Succ( This)]:= Value MOD 256;
          Inc( This, 2);
          Param:= Param^.Next;
        END;
      ListInstruction( Address, 2 * Count, Instruct, Count);
    END;
END;

PROCEDURE EncodeInstruction( Inst: InstPointer; Reg, Symb: SymbolPointer);

BEGIN
  CASE Inst^.Inst OF
    AddToken:
      EncodeAddToken( Inst, Reg, Symb);
    AndToken:
      EncodeRegRegToken( Inst, $8002, 2, Reg, Symb);
    CallToken:
      EncodeAddrToken( Inst, $2000, Reg, Symb);
    ClsToken:
      EncodeNoneToken( Inst, $00e0, Reg, Symb);
    DaToken:
      EncodeDaToken( Inst, Reg, Symb);
    DbToken:
      EncodeDbToken( Inst, Reg, Symb);
    DrwToken:
      EncodeRegRegValToken( Inst, $d000, Reg, Symb);
    DwToken:
      EncodeDwToken( Inst, Reg, Symb);
    JpToken:
      EncodeJpToken( Inst, Reg, Symb);
    LdToken:
      EncodeLdToken( Inst, Reg, Symb);
    OrToken:
      EncodeRegRegToken( Inst, $8001, 2, Reg, Symb);
    RetToken:
      EncodeNoneToken( Inst, $00ee, Reg, Symb);
    RndToken:
      EncodeRegValToken( Inst, $c000, Reg, Symb);
    SeToken:
      EncodeRegRegOrValToken( Inst, $5000, $3000, Reg, Symb);
    ShlToken:
      EncodeRegRegToken( Inst, $800e, 1, Reg, Symb);
    ShrToken:
      EncodeRegRegToken( Inst, $8006, 1, Reg, Symb);
    SknpToken:
      EncodeRegToken( Inst, $e0a1, Reg, Symb);
    SkpToken:
      EncodeRegToken( Inst, $e09e,Reg, Symb);
    SneToken:
      EncodeRegRegOrValToken( Inst, $9000, $4000, Reg, Symb);
    SubToken:
      EncodeRegRegToken( Inst, $8005, 2, Reg, Symb);
    SubnToken:
      EncodeRegRegToken( Inst, $8007, 2, Reg, Symb);
    SysToken:
      EncodeAddrToken( Inst, $2000, Reg, Symb);
    XorToken:
      EncodeRegRegToken( Inst, $8003, 2, Reg, Symb);
  ELSE
    RunWarning( InternalWarning);
  END;
END;

PROCEDURE EncodeMemory( Inst: InstPointer; Reg, Symb: SymbolPointer);

VAR
  Prev: InstPointer;
  Count: Word;

BEGIN
  FOR Count:= StartAddress TO StopAddress DO
    Memory[ Count]:= 0;
  Prev:= Inst;
  WHILE Prev <> NIL DO
    BEGIN
      Inst:= Prev;
      Prev:= Prev^.Prev;
    END;
  WHILE Inst <> NIL DO
    BEGIN
      InstPoint:= Inst;
      Current:= Inst^.Address;
      EncodeInstruction( Inst, Reg, Symb);
      Inst:= Inst^.Next;
    END;
  InstPoint:= NIL;
  ListSymbols( Symb);
  ListWarnings;
END;

PROCEDURE WriteMemory( Start, Stop: Word);

VAR
  HpHeading: ARRAY[ $0 .. $c] OF Byte;
  Size, Count: LongInt;

BEGIN
  Size:= 2 * ( Stop - Start) + 5;
  HpHeading[ $0]:= Ord( 'H');
  HpHeading[ $1]:= Ord( 'P');
  HpHeading[ $2]:= Ord( 'H');
  HpHeading[ $3]:= Ord( 'P');
  HpHeading[ $4]:= Ord( '4');
  HpHeading[ $5]:= Ord( '8');
  HpHeading[ $6]:= Ord( '-');
  HpHeading[ $7]:= Ord( 'A');
  HpHeading[ $8]:= $2c;
  HpHeading[ $9]:= $2a;
  HpHeading[ $a]:= $0 OR $10 * ( Size MOD 16);
  HpHeading[ $b]:= ( Size DIV 16) MOD 256;
  HpHeading[ $c]:= ( Size DIV ( 16 * 256)) MOD 256;
  FOR Count:= $0 TO $c DO
    Write( OutFile, HpHeading[ Count]);
  FOR Count:= Start TO Pred( Stop) DO
    Write( OutFile, Memory[ Count]);
END;

BEGIN
  Assign( StdIn, '');
  Assign( StdOut, '');
  ReSet( StdIn);
  ReWrite( StdOut);
  WriteLn( StdOut, CopyRight);
  WriteLn( StdOut);
  IF OpenFiles THEN
    BEGIN
      StoreDirectives( 0, Ord( Pred( LastToken)), Directives);
      StoreRegisters( 0, Ord( Pred( LastReg)), Registers);
      DecodeFile( InFileName, Instructions, Directives, Symbols);
      EncodeMemory( Instructions, Registers, Symbols);
      WriteMemory( StartAddress, Finish);
      Close( OutFile);
      Close( ListFile);
      ReleaseSymbols( Symbols);
      ReleaseSymbols( Registers);
      ReleaseSymbols( Directives);
      ReleaseInsts( Instructions);
    END;
  Close( StdIn);
  Close( StdOut);
END.