ORCA/Pascal 2.2 source from the Opus ][ CD

LICENSE.txt

@@ -0,0 +1,11 @@
+ORCA/Pascal is released by the copyright holder under the terms of the original copyright.
+
+The Byte Works, Inc. grants you the right to use this source code privately, fork it, and change it.
+
+You may not redistribute the code in any form other than submission to this repository without the written permission of the copyright holder.
+
+The copyright holder decided to do things this way for two reasons:
+
+1. Reserve commercial distribution rights.
+
+2. Ensure that any contributions and updates are available from a centralized source (this GitHib repository, for now).

README.md

@@ -0,0 +1,52 @@
+# ORCA-Pascal
+Apple IIGS ORCA/Pascal Compiler, an ISO Pascal compiler for the 65816 with libraries for the Apple IIGS
+
+__Binary downloads for the latest ORCA/Pascal release are on the [releases page][releases].__
+
+[releases]: https://github.com/byteworksinc/ORCA-Pascal/releases
+
+If you would like to make changes to this compiler and distribute them to others, feel free to submit them here. If the changes apply to compilation on and for an Apple IIGS, they will generally be approved for distribution on the master branch unless the changes deviate significantly from the ISO Pascal standard. For changes that deviate from ISO Pascal or changes that retarget the compiler to run on a different platform or generate code for a different platform, the project will either be forked or a new repository will be created, as appropriate.
+
+The general conditions that must be met before a change is released on master are:
+
+1. The modified compiler must compile under the currently released version of ORCA/M and ORCA/Pascal.
+
+2. All samples from the original ORCA/Pascal distribution must compile and execute under the modified compiler, or the sample must be updated, too.
+
+3. The compiler must pass the ORCA/Pascal test suite, or the test suite must be suitably modified, too. The test suite is based on a commercial product, so it cannot be uploaded here. Contributors should contact the Byte Works to inquire about acces to the test suite.
+
+4. The compiler must work with the current ORCA/Pascal libraries, or the libraries must be modified, too.
+
+Contact support@byteworks.us if you need contributor access.
+
+A complete distribution of the ORCA languages, including installers and documentation, is available from the Juiced GS store at https://juiced.gs/store/category/software/. It is distributed as part of the Opus ][ package.
+
+## Line Endings and File Types
+
+The text and source files in this repository originally used CR line endings, as usual for Apple II text files, but they have been converted to use LF line endings because that is the format expected by Git. If you wish to move them to a real or emulated Apple II and build them there, you will need to convert them back to CR line endings.
+
+If you wish, you can configure Git to perform line ending conversions as files are checked in and out of the Git repository. With this configuration, the files in your local working copy will contain CR line endings suitable for use on an Apple II. To set this up, perform the following steps in your local copy of the Git repository (these should be done when your working copy has no uncommitted changes):
+
+1. Add the following lines at the end of the `.git/config` file:
+```
+[filter "crtext"]
+	clean = LC_CTYPE=C tr \\\\r \\\\n
+	smudge = LC_CTYPE=C tr \\\\n \\\\r
+```
+
+2. Add the following line to the `.git/info/attributes` file, creating it if necessary:
+```
+* filter=crtext
+```
+
+3. Run the following commands to convert the existing files in your working copy:
+```
+rm .git/index
+git checkout HEAD -- .
+```
+
+Alternatively, you can keep the LF line endings in your working copy of the Git repository, but convert them when you copy the files to an Apple II. There are various tools to do this.  One option is `udl`, which is [available][udl] both as a IIGS shell utility and as C code that can be built and used on modern systems.
+
+[udl]: http://ftp.gno.org/pub/apple2/gs.specific/gno/file.convert/udl.114.shk
+
+In addition to converting the line endings, you will also have to set the files to the appropriate file types before building ORCA/C on a IIGS. The included `settypes` script (for use under the ORCA shell) does this for the sources to the ORCA/C compiler itself, although it does not currently cover the test cases and headers.

backup

@@ -0,0 +1 @@
+if "{#}" != "1"
   echo Form: backup [day]
   exit 65535
end

set dest /library/mike/{1}/pascal

set list        make linkit count backup smac pascal.notes
set list {list} pascal.pas pascal.rez
set list {list} parser.pas
set list {list} call.pas
set list {list} symbols.pas symbols.asm symbols.macros
set list {list} pcommon.pas pcommon.asm pcommon.macros
set list {list} scanner.pas scanner.asm scanner.macros
set list {list} cgi.pas cgi.comments cgi.asm
set list {list} native.pas native.asm native.macros
set list {list} objout.pas objout.asm objout.macros
set list {list} dag.pas dag.asm dag.macros
set list {list} cgc.pas cgc.asm cgc.macros
set list {list} gen.pas

unset exit
create {dest} >.null >&.null
for i in {list}
   newer {dest}/{i} {i}
   if {Status} != 0
      copy -c {i} {dest}/{i}
   end
end

cgc.asm

@@ -0,0 +1 @@
+	mcopy	cgc.macros
****************************************************************
*
*  CnvSX - Convert floating point to SANE extended
*
*  Inputs:
*        rec - pointer to a record
*
****************************************************************
*
CnvSX    start
rec      equ   4                        record containing values
rec_real equ   0                        disp to real value
rec_ext  equ   8                        disp to extended (SANE) value

         tsc                            set up DP
         phd
         tcd
         ph4   rec                      push addr of real number
         clc                            push addr of SANE number
         lda   rec
         adc   #rec_ext
         tax
         lda   rec+2
         adc   #0
         pha
         phx
         fd2x                           convert TOS to extended
         move4 0,4                      return
         pld
         pla
         pla
         rtl
         end

cgc.macros

@@ -0,0 +1 @@
+ macro
&l move4 &m1,&m2
 lclb &yistwo
&l ~setm
 ~lda &m1
 ~sta &m2
 ~lda.h &m1
 ~sta.h &m2
 ~restm
 mend
 macro
&l ph4 &n1
 aif "&n1"="*",.f
 lclc &c
&l anop
&c amid &n1,1,1
 aif "&c"="#",.d
 aif s:longa=1,.a
 rep #%00100000
.a
 aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
 aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
 ldy #2
 lda (&n1),y
 pha
 lda (&n1)
 pha
 ago .e
.b
 aif "&c"<>"[",.c
 ldy #2
 lda &n1,y
 pha
 lda &n1
 pha
 ago .e
.c
 aif "&c"<>"<",.c1
&n1 amid &n1,2,l:&n1-1
 pei &n1+2
 pei &n1
 ago .e
.c1
 lda &n1+2
 pha
 lda &n1
 pha
 ago .e
.d
&n1 amid &n1,2,l:&n1-1
 pea +(&n1)|-16
 pea &n1
 ago .f
.e
 aif s:longa=1,.f
 sep #%00100000
.f
 mexit
.g
 mnote "Missing closing '}'",16
 mend
 macro
&l ~lda &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l lda &op
 mend
 macro
&l ~lda.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 lda &op
 mexit
.d
 aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
 lda &op
 mexit
.e
 lda 2+&op
 mend
 macro
&l ~restm
&l anop
 aif (&~la+&~li)=2,.i
 sep #32*(.not.&~la)+16*(.not.&~li)
 aif &~la,.h
 longa off
.h
 aif &~li,.i
 longi off
.i
 mend
 macro
&l ~setm
&l anop
 aif c:&~la,.b
 gblb &~la
 gblb &~li
.b
&~la setb s:longa
&~li setb s:longi
 aif s:longa.and.s:longi,.a
 rep #32*(.not.&~la)+16*(.not.&~li)
 longa on
 longi on
.a
 mend
 macro
&l ~sta &op
 lclc &c
&c amid "&op",1,1
 aif "&c"<>"{",.b
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l sta &op
 mend
 macro
&l ~sta.h &op
&l anop
 lclc &c
&c amid "&op",1,1
 aif "&c"="[",.b
 aif "&c"<>"{",.d
&c amid "&op",l:&op,1
 aif "&c"="}",.a
 mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
 aif &yistwo,.c
&yistwo setb 1
 ldy #2
.c
&op setc "&op,y"
 sta &op
 mexit
.d
 sta 2+&op
 mend
 MACRO
&LAB FD2X
&LAB PEA $010E
 LDX #$090A
 JSL $E10000
 MEND
 MACRO
&LAB FX2C
&LAB PEA $0510
 LDX #$090A
 JSL $E10000
 MEND

cgi.asm

@@ -0,0 +1 @@
+****************************************************************
*
*  InitLabels - initialize the labels array
*
*  Outputs:
*        labelTab - initialized
*        intLabel - initialized
*
****************************************************************
*
InitLabels start
maxLabel equ   2400

!                                       with labelTab[0] do begin
         lda   #-1                         val := -1;
         sta   labelTab+6
         sta   labelTab+8
         stz   labelTab                    defined := false;
         stz   labelTab+2                  chain := nil;
         stz   labelTab+4
!                                          end; {with}
         ldx   #labelTab                for i := 1 to maxLabel do
         ldy   #labelTab+10                labelTab[i] := labelTab[0];
         lda   #maxLabel*10-1
         mvn   labelTab,labelTab
         stz   intLabel                 intLabel := 0;
         rtl
         end

count

@@ -0,0 +1 @@
+echo Pascal:

set list cg.pas stage3.pas stage3.save stage3.gentree
set list {list} cg.writecode native.pas
set list {list} pascal.pas pascal.exp pascal.body
set list {list} symbols.pas cgi.pas call.pas

wc -l {list}

echo Assembly:

set list sc.asm sc.insymbol sc.options ob.asm symbols.asm

wc -l {list}

echo Special Macros:

set list sc.smac sym.smac

wc -l {list}

echo Link and Make files:

set list lk backup make msym mcg count msc mcall mpascal

wc -l {list}

echo Macros:

set list sc.macros ob.macros sym.macros

wc -l {list}

dag.macros

@@ -0,0 +1 @@
+ MACRO
&lab subroutine &parms,&work
&lab anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+3+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 sec
 sbc #&work
 tcs
 inc a
 phd
 tcd
 mend
 MACRO
&lab return &r
&lab anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 aif &totallen=0,.f
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.f
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 phb
 plx
 ply
 lda &r+8
 pha
 lda &r+6
 pha
 lda &r+4
 pha
 lda &r+2
 pha
 lda &r
 pha
 phy
 phx
 plb
 rtl
 mexit
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 MACRO
&LAB MOVE4 &F,&T
&LAB ~SETM
 LDA 2+&F
 STA 2+&T
 LDA &F
 STA &T
 ~RESTM
 MEND
 MACRO
&LAB ~SETM
&LAB ANOP
 AIF C:&~LA,.B
 GBLB &~LA
 GBLB &~LI
.B
&~LA SETB S:LONGA
&~LI SETB S:LONGI
 AIF S:LONGA.AND.S:LONGI,.A
 REP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 LONGA ON
 LONGI ON
.A
 MEND
 MACRO
&LAB ~RESTM
&LAB ANOP
 AIF (&~LA+&~LI)=2,.I
 SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI)
 AIF &~LA,.H
 LONGA OFF
.H
 AIF &~LI,.I
 LONGI OFF
.I
 MEND

linkit

@@ -0,0 +1 @@
+set list        obj/pascal obj/call obj/parser obj/native obj/cgi obj/symbols
set list {list} obj/scanner obj/dag obj/cgc obj/gen obj/objout obj/pcommon

echo link {parameters} {list} keep=obj/pascal
link {parameters} {list} keep=obj/pascal
echo filetype obj/pascal exe $DB01
filetype obj/pascal exe $DB01

make

@@ -0,0 +1 @@
+unset exit
set flags +t +e

Newer obj/pascal pascal.rez
if {status} != 0
   set exit on
   echo compile -e pascal.rez keep=obj/Pascal
   compile -e pascal.rez keep=obj/Pascal
   unset exit
end

if {#} == 0 then

   Newer obj/gen.a gen.pas
   if {Status} != 0
      set gen gen
      set dag dag
   end                   

   Newer obj/cgc.a cgc.pas cgc.asm cgc.macros
   if {Status} != 0
      set cgc cgc
      set dag dag
      set gen gen
      set objout objout
      set native native
      set symbols symbols
   end                   

   Newer obj/dag.a dag.pas dag.asm dag.macros
   if {Status} != 0
      set dag dag
   end                   

   Newer obj/pascal.a pascal.pas
   if {Status} != 0
      set pascal pascal
   end                   

   Newer obj/parser.a parser.pas
   if {Status} != 0
      set parser parser
      set pascal pascal
   end                   

   Newer obj/call.a call.pas
   if {Status} != 0
      set call call
      set parser parser
   end                   

   Newer obj/objout.a objout.pas objout.asm objout.macros
   if {Status} != 0
      set objout objout
      set symbols symbols
      set native native
      set gen gen
   end                   

   Newer obj/native.a native.pas native.asm native.pas
   if {Status} != 0
      set native native
      set symbols symbols
      set gen gen
   end                   

   Newer obj/cgi.a cgi.pas cgi.asm
   if {Status} != 0
      set cgi cgi
      set call call
      set native native
      set scanner scanner
      set symbols symbols
      set parser parser
      set pascal pascal
      set dag dag
      set cgc cgc
      set gen gen
      set objout objout
   end                   

   Newer obj/scanner.a scanner.pas scanner.asm scanner.macros
   if {Status} != 0
      set scanner scanner
      set symbols symbols
      set call call
      set parser parser
      set pascal pascal
   end                   

   Newer obj/symbols.a symbols.pas symbols.asm symbols.macros
   if {Status} != 0
      set symbols symbols
      set call call
      set parser parser
      set pascal pascal
   end                 

   Newer obj/pcommon.a pcommon.pas pcommon.asm pcommon.macros
   if {Status} != 0
      set pcommon pcommon
      set call call
      set symbols symbols
      set cgi cgi
      set native native
      set objout objout
      set parser parser
      set dag dag
      set cgc cgc
      set gen gen
   end                   

   set exit on
   set list {pcommon} {cgi} {cgc} {objout} {native} {gen} {dag} {scanner} {symbols} {call} {parser} {pascal}
   for i in {list}
      echo compile {flags} {i}.pas keep=obj/{i}
      compile {flags} {i}.pas keep=obj/{i}
   end

else

   set exit on
   for i in {parameters}
      echo compile {flags} {i}.pas keep=obj/{i}
      compile {flags} {i}.pas keep=obj/{i}
   end
end

* echo purge
* purge >.null
echo linkit
linkit
echo copy -c obj/pascal 16/Pascal
copy -c obj/pascal 16/Pascal

native.macros

@@ -0,0 +1 @@
+ MACRO
&lab subroutine &parms,&work
&lab anop
 aif c:&work,.a
 lclc &work
&work setc 0
.a
 gbla &totallen
 gbla &worklen
&worklen seta &work
&totallen seta 0
 aif c:&parms=0,.e
 lclc &len
 lclc &p
 lcla &i
&i seta c:&parms
.b
&p setc &parms(&i)
&len amid &p,2,1
 aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
 ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+3+&work
&totallen seta &totallen+&len
&i seta &i-1
 aif &i,^b
.e
 tsc
 sec
 sbc #&work
 tcs
 inc a
 phd
 tcd
 mend
 MACRO
&lab return &r
&lab anop
 lclc &len
 aif c:&r,.a
 lclc &r
&r setc 0
&len setc 0
 ago .h
.a
&len amid &r,2,1
 aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
 ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
 aif &len<>2,.d
 ldy &r
 ago .h
.d
 aif &len<>4,.e
 ldx &r+2
 ldy &r
 ago .h
.e
 aif &len<>10,.g
 aif &totallen=0,.f
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.f
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 phb
 plx
 ply
 lda &r+8
 pha
 lda &r+6
 pha
 lda &r+4
 pha
 lda &r+2
 pha
 lda &r
 pha
 phy
 phx
 plb
 rtl
 mexit
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+1
 sta &worklen+&totallen+1
 lda &worklen
 sta &worklen+&totallen
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend

pascal.pas

@@ -0,0 +1 @@
+{$optimize -1}
{$stacksize $4000}
{------------------------------------------------------------}
{							     }
{  ORCA/Pascal 2.2					     }
{							     }
{  A native code compiler for the Apple IIGS.		     }
{							     }
{  By Mike Westerfield					     }
{							     }
{  Copyright March 1988					     }
{  By the Byte Works, Inc.				     }
{							     }
{------------------------------------------------------------}
{							     }
{  Version 2.2 prepared in March, 1996		     	     }
{  Version 2.1 prepared in July, 1994		     	     }
{  Version 2.0.1 prepared in June, 1993		     	     }
{  Version 2.0.0 prepared in March, 1993		     }
{  Version 1.4.2 prepared in October, 1992		     }
{  Version 1.4.1 prepared in October, 1991		     }
{  Version 1.4 prepared in September, 1991		     }
{  Version 1.3 prepared in September, 1990		     }
{							     }
{------------------------------------------------------------}
 
program pascal (output);

{$segment 'pascal'}

{$LibPrefix '0/obj/'}

uses PCommon, CGI, Scanner, Symbols, Parser;

begin
{initialization:}
MMInit;					{memory manager}
InitPCommon;				{common module}
InitScalars;				{global variables}
InitSets;     
CodeGenScalarInit;
scanner_init; 
enterstdtypes;
stdnames;     
entstdnames;  
EnterUndecl;  
if progress or list then begin
   writeln('ORCA/Pascal 2.2.0'); 	{write banner}
   writeln('Copyright 1987,1988,1991,1993,1994,1996, Byte Works, Inc.');
   writeln;
   end; {if}
level := 1;				{set the top symbol level}
top := 1;

{compile:}
InSymbol;				{get the first symbol}
programme(blockbegsys+statbegsys-[casesy]); {compile the program}
               
{termination:}
if codeGeneration then CodeGenFini;	{shut down code generator}
scanner_fini;				{shut down scanner}
StopSpin;
end.

pascal.rez

@@ -0,0 +1 @@
+#include "types.rez"

resource rVersion(1) {
   {
      2,				/* Major revision */
      2,				/* Minor revision */
      0,				/* Bug version */
      release,				/* Release stage */
      0,				/* Non-final release # */
      },
   verUS,				/* Region code */
   "ORCA/Pascal",			/* Short version number */
   "Copyright 1996, Byte Works, Inc."	/* Long version number */
   };

smac

@@ -0,0 +1 @@
+         MACRO
&LAB     ENUM  &LIST,&START
&LAB     ANOP
         AIF   C:&~ENUM,.A
         GBLA  &~ENUM
.A
         AIF   C:&START=0,.B
&~ENUM   SETA  &START
.B
         LCLA  &CNT
&CNT     SETA  1
.C
&LIST(&CNT) EQU &~ENUM
&~ENUM   SETA  &~ENUM+1
&CNT     SETA  &CNT+1
         AIF   &CNT<=C:&LIST,^C
         MEND


         MACRO
&LAB     SUBR  &PARMS
&LAB     PHD
         LDA   MY_DP
         TCD
         AIF   C:&PARMS=0,.F
         LCLC  &PARM
         LCLA  &P
         LCLA  &LEN
         LCLA  &TOTALLEN
         LCLC  &C
&P       SETA  1
.A
&PARM    SETC  &PARMS(&P)
&C       AMID  &PARM,1,1
&PARM    AMID  &PARM,3,L:&PARM-2
&LEN     SETA  &C
&PARM    EQU   &TOTALLEN
&TOTALLEN SETA &TOTALLEN+&C
&P       SETA  &P+1
         AIF   &P<=C:&PARMS,^A
         AIF   &TOTALLEN<>2,.B
         LDA   6,S
         STA   0
         LDA   4,S
         STA   6,S
         LDA   2,S
         STA   4,S
         PLA
         STA   1,S
         MEXIT
.B
         AIF   &TOTALLEN<>4,.C
         LDA   6,S
         STA   0
         LDA   8,S
         STA   2
         LDA   4,S
         STA   8,S
         LDA   2,S
         STA   6,S
         PLA
         STA   3,S
         PLA
         MEXIT
.C
         PHB
         PLA
         STA   R0
         PLA
         STA   R2
         PLA
         STA   R4
         AIF   (&TOTALLEN/2*2)<>&TOTALLEN,.D
         LDX   #0
~&SYSCNT PLA
         STA   0,X
         INX
         INX
         CPX   #&TOTALLEN
         BNE   ~&SYSCNT
         AGO   .E
.D
         SEP   #$20
         LDX   #0
~&SYSCNT PLA
         STA   0,X
         INX
         CPX   #&TOTALLEN
         BNE   ~&SYSCNT
         REP   #$20
.E
         LDA   R4
         PHA
         LDA   R2
         PHA
         LDA   R0
         PHA
         PLB
.F
         MEND


         MACRO
&LAB     RETURN &VAL
         AIF   C:&VAL<>0,.A
&LAB     PLD
         RTL
         MEXIT
.A
         AIF   "&VAL"<>"2",.B
&LAB     PLD
         TAX
         RTL
         MEXIT
.B
         MNOTE 'Return values not implemented yet.',16
         MEND


         MACRO
&LAB     PASCAL
&LAB     TSC
         PLD
         PLB
         TCS
         MEND


         MACRO
&LAB     ASSEMBLY
&LAB     PHK
         PLB
         LDA   MY_DP
         TCD
         MEND


         MACRO
&LAB     MOVE4 &A,&B
&LAB     LDA   &A
         STA   &B
         LDA   2+&A
         STA   2+&B
         MEND


         MACRO
&LAB     TERR  &ERR
&LAB     LDA   &ERR
         PHA
         JSL   TERMERROR
         MEND


         MACRO
&LAB     LISTERROR &ERR
&LAB     LDA   0
         PHA
         PH2   &ERR
         JSL   ERROR
         PLA
         STA   0
         MEND


        macro
&lab    FastFile &DCB
&lab    ~setm
        jsl     $E100A8
        dc      i2'$010E'
        dc      i4'&DCB'
        ~restm
        mend


         macro
&lab     sub   &p,&w
&lab     anop
         lcla  &pc
         lclc  &n
         lclc  &s
         lclc  &pr
         gbla  &disp
         gbla  &ws
&ws      seta  &w
&pc      seta  1
&disp    seta  3+&w
.a
&pr      setc  &p(&pc)
&s       amid  &pr,1,1
&n       amid  &pr,3,l:&pr-2
&n       equ   &disp
&disp    seta  &disp+&s
&pc      seta  &pc+1
         aif   &pc<=c:&p,^a
         tdc
         tax
         tsc
         sec
         sbc   #&w-1
         tcd
         dec   a
         tcs
         phx
         mend


         macro
&lab     return
&lab     lda   &ws
         sta   &disp-3
         lda   &ws+1
         sta   &disp-2
         clc
         tdc
         adc   #&disp-4
         plx
         tcs
         txa
         tcd
         rtl
         mend


         macro
&lab     enum  &list,&start
&lab     anop
         aif   c:&~enum,.a
         gbla  &~enum
.a
         aif   c:&start=0,.b
&~enum   seta  &start
.b
         lcla  &cnt
&cnt     seta  1
.c
&list(&cnt) equ &~enum
&~enum   seta  &~enum+1
&cnt     seta  &cnt+1
         aif   &cnt<=c:&list,^c
         mend


         macro
&lab     terr  &err
&lab     lda   &err
         brl   termerror
         mend


         macro
&lab     move4 &a,&b
&lab     lda   &a
         sta   &b
         lda   2+&a
         sta   2+&b
         mend