ORCA libraries, from the Opus ][ CD

LICENSE

@@ -0,0 +1,11 @@
+ORCALib 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,14 @@
+# ORCALib
+Libraries for the ORCA language suite (ORCA/C, ORCA/M, ORCA/Pascal) for the Apple IIGS
+
+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 the Apple IIGS, they will generally be approved for distribution on the master branch. For changes that retarget the library to 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 library must compile under the currently released version of ORCA/M.
+
+2. The various languages that make use of the library mush still pass their respective test suites, or changes to those test suites must also be submitted.
+
+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.

assert.asm

@@ -0,0 +1 @@
+         keep  obj/assert
         mcopy assert.macros
         case  on
****************************************************************
*
*  Assert - Condition assertion macro
*
*  This code implements the subroutines needed to support the
*  standard C library assert.
*
*  October 1991
*  Mike Westerfield
*
*  Copyright 1991
*  Byte Works, Inc.
*
****************************************************************
*
Assert   start                          dummy routine

         end

****************************************************************
*
*  void __assert (char *f, int l)
*
*  Inputs:
*        f - pointer to the file name
*        l - line number
*
****************************************************************
*
__assert start

         csubroutine (4:f,2:l,4:s),0

	ph4	s
         ph2   l
         ph4   f
         ph4   #msg
	ph4	>stderr
         jsl   fprintf
         jsl   abort

         creturn

msg      dc    c'Assertion failed: file %s, line %d; assertion: %s',i1'10,0'
         end

assert.macros

@@ -0,0 +1 @@
+ MACRO
&LAB PH2 &N1
 LCLC &C
&LAB 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
 LDA (&N1)
 PHA
 AGO .E
.B
 LDA &N1
 PHA
 AGO .E
.D
&N1 AMID &N1,2,L:&N1-1
 PEA &N1
 AGO .F
.E
 AIF S:LONGA=1,.F
 SEP #%00100000
.F
 MEXIT
.G
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB PH4 &N1
 LCLC &C
&LAB 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
 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
&lab csubroutine &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 1
.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+4+&work
&totallen seta &totallen+&len
&i seta &i+1
 aif &i<=c:&parms,^b
.e
 tsc
 aif &work=0,.f
 sec
 sbc #&work
 tcs
.f
 phd
 tcd
 mend
 MACRO
&lab creturn &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
 ldy #&r
 ldx #^&r
 ago .h
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+2
 sta &worklen+&totallen+2
 lda &worklen+1
 sta &worklen+&totallen+1
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend

backup

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

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

set list        make backup smac equates.asm
set list {list} assert.asm assert.macros
set list {list} cc.asm cc.macros
set list {list} ctype.asm
set list {list} fcntl.asm fcntl.macros
set list {list} orca.asm orca.macros
set list {list} setjmp.asm
set list {list} signal.asm signal.macros
set list {list} ctype.asm
set list {list} stdio.asm stdio.macros
set list {list} stdlib.asm stdlib.macros
set list {list} string.asm string.macros
set list {list} time.asm time.macros
set list {list} toolglue.asm toolglue.macros
set list {list} vars.asm vars.macros

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

equates.asm

@@ -0,0 +1 @@
+****************************************************************
*
*  This file contains constant values defined in the C interfaces
*  that are also used in the assembly language portion of the
*  libraries.
*
****************************************************************
;
;  error numbers
;
EDOM     gequ  1                        domain error
ERANGE   gequ  2                        # too large, too small, or illegal
ENOMEM   gequ  3                        Not enough memory
ENOENT   gequ  4                        No such file or directory
EIO      gequ  5                        I/O error
EINVAL   gequ  6                        Invalid argument
EBADF    gequ  7                        bad file descriptor
EMFILE   gequ  8                        too many files are open
EACCES   gequ  9                        access bits prevent the operation
EEXIST   gequ  10                       the file exists
ENOSPC   gequ  11                       the file is too large
;
;  masks for the __ctype array
;
_digit   gequ  $01                      ['0'..'9']
_upper   gequ  $02                      ['A'..'Z']
_lower   gequ  $04                      ['a'..'z']
_control gequ  $08                      [chr(0)..chr(31),chr(127)]
_punctuation gequ $10                   [' ','!'..'/',':'..'@','['..'`','{'..'~']
_space   gequ  $20                      [chr(9)..chr(13),' ']
_hex     gequ  $40                      ['0'..'9','a'..'f','A'..'F']
_print   gequ  $80                      [' '..'~']
;
;  masks for the __ctype2 array
;
_csym    gequ  $01                      ['0'..'9','A'..'Z','a'..'z','_']
_csymf   gequ  $02                      ['A'..'Z','a'..'z'.'_']
_octal   gequ  $04                      ['0'..'7']
;
;  signal numbers
;
SIGABRT  gequ  1
SIGFPE   gequ  2
SIGILL   gequ  3
SIGINT   gequ  4
SIGSEGV  gequ  5
SIGTERM  gequ  6
;
;  The FILE record
;
!                                       flags
!                                       -----
_IOFBF   gequ  $0001                    full buffering
_IONBF   gequ  $0002                    no buffering
_IOLBF   gequ  $0004                    flush when a \n is written
_IOREAD  gequ  $0008                    currently reading
_IOWRT   gequ  $0010                    currently writing
_IORW    gequ  $0020                    read/write enabled
_IOMYBUF gequ  $0040                    buffer was allocated by stdio
_IOEOF   gequ  $0080                    has an EOF been found?
_IOERR   gequ  $0100                    has an error occurred?
_IOTEXT  gequ  $0200                    is this file a text file?
_IOTEMPFILE gequ $0400	was this file created by tmpfile()?

!                                       record structure
!                                       ----------------
FILE_next gequ 0                        disp to next pointer (must stay 0!)
FILE_ptr  gequ FILE_next+4              next location to write to
FILE_base gequ FILE_ptr+4               first byte of the buffer
FILE_end  gequ FILE_base+4              end of the file buffer
FILE_size gequ FILE_end+4               size of the file buffer
FILE_cnt  gequ FILE_size+4              # chars that can be read/writen to buffer
FILE_pbk  gequ FILE_cnt+4               put back character
FILE_flag gequ FILE_pbk+4               buffer flags
FILE_file gequ FILE_flag+2              GS/OS file ID

sizeofFILE gequ FILE_file+2             size of the record

BUFSIZ   gequ  1024                     default file buffer size
_LBUFSIZ gequ  255                      line buffer size

L_tmpnam gequ  9                        size of a temp name
TMP_MAX  gequ  10000                    # of uniq temp names
;
;  Seek codes for fseek
;
SEEK_SET gequ  0                        seek from start of file
SEEK_CUR gequ  1                        seek from current position
SEEK_END gequ  2                        seek from end of file
;
;  Values for fcntl.h
;
OPEN_MAX gequ  30                       files in the file array

F_DUPFD  gequ  1                        dup file flag (fcntl)

O_RDONLY gequ  $0001                    file is read only
O_WRONLY gequ  $0002                    file is write only
O_RDWR   gequ  $0004                    file is read/write
O_NDELAY gequ  $0008                    not used
O_APPEND gequ  $0010                    append to file on all writes
O_CREAT  gequ  $0020                    create a new file if needed
O_TRUNC  gequ  $0040                    erase old file
O_EXCL   gequ  $0080                    don't create a new file
O_BINARY gequ  $0100                    file is binary
;
;  Misc.
;
EOF      gequ  -1                       end of file character

stdinID  gequ  -1                       standard in file ID
stdoutID gequ  -2                       standard out file ID
stderrID gequ  -3                       error out file ID

make

@@ -0,0 +1 @@
+unset exit
unset cc >&/work
unset cg >&/work

if {#} == 0
   Newer obj/stdio.a stdio.asm equates.asm
   if {Status} != 0
      set exit on
      echo assemble +e +t stdio.asm
      assemble +e +t stdio.asm
      unset exit
   end

   Newer obj/assert.a assert.asm
   if {Status} != 0
      set exit on
      echo assemble +e +t assert.asm
      assemble +e +t assert.asm
      unset exit
   end

   for i in cc ctype string stdlib time setjmp orca fcntl vars toolglue signal
      Newer obj/{i}.a {i}.asm
      if {Status} != 0
         set exit on
         echo assemble +e +t {i}.asm
         assemble +e +t {i}.asm
         unset exit
      end
   end
else
   set exit on
   for i
      assemble +e +t {i}.asm
   end
end

echo delete orcalib
delete orcalib

set list        vars.a assert.a cc.a setjmp.a ctype.a string.a stdlib.a
set list {list} time.a signal.a toolglue.a orca.a fcntl.a stdio.a
for i in {list}
   echo makelib orcalib +obj/{i}
   makelib orcalib +obj/{i}
end

set echo on

obj/README.txt

@@ -0,0 +1 @@
+This directory is used by the make file for storing object files.

orca.asm

@@ -0,0 +1 @@
+         keep  obj/orca
         mcopy orca.macros
         case  on

****************************************************************
*
*  ORCA - ORCA/C specific libraries
*
*  This code implements the tables and subroutines needed to
*  support the ORCA/C library ORCA.
*
*  March 1989
*  Mike Westerfield
*
*  Copyright 1989
*  Byte Works, Inc.
*
****************************************************************
*
ORCA     start                          dummy segment
         end

****************************************************************
*
*  char *commandline(void)
*
*  Inputs:
*        ~CommandLine - address of the command line
*
****************************************************************
*
commandline start

         ldx   #0
         lda   ~COMMANDLINE
         ora   ~COMMANDLINE+2
         beq   lb1

         lda   ~COMMANDLINE
         ldx   ~COMMANDLINE+2
         clc
         adc   #8
         bcc   lb1
         inx
lb1      rtl
         end

****************************************************************
*
*  void enddesk(void)
*
****************************************************************
*
enddesk  start

         jmp   ~ENDDESK
         end

****************************************************************
*
*  void endgraph(void)
*
****************************************************************
*
endgraph start

         jmp   ~ENDGRAPH
         end

****************************************************************
*
*  char *shellid(void)
*
*  Inputs:
*        ~CommandLine - address of the command line
*
****************************************************************
*
shellid  start

         ldx   #0                       return NULL if there is no command line
         lda   >~COMMANDLINE
         ora   >~COMMANDLINE+2
         bne   lb1
         rtl

lb1      lda   >~COMMANDLINE+2
	pha
	lda   >~COMMANDLINE
	pha
         phd
         tsc
         tcd
         phb
         phk
         plb
         ldy   #6
lb2      lda   [3],Y
         sta   id,Y
         dey
         dey
         bpl   lb2
         plb
         pld
         pla
         pla
         lda   #id
         ldx   #^id
         rtl

id       dc    8c' ',i1'0'
         end

****************************************************************
*
*  void startdesk(int width)
*
****************************************************************
*
startdesk start

         jmp   ~STARTDESK
         end

****************************************************************
*
*  void startgraph(int width)
*
****************************************************************
*
startgraph start

         jmp   ~STARTGRAPH
         end

****************************************************************
*
*  int toolerror(void)
*
****************************************************************
*
toolerror start

         lda   >~TOOLERROR
         rtl
         end

****************************************************************
*
*  int userid(void)
*
****************************************************************
*
userid   start

         lda   >~USER_ID
         rtl
         end

orca.macros

@@ -0,0 +1 @@
+ MACRO
&LAB PH4 &N1
 LCLC &C
&LAB 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
 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

setjmp.asm

@@ -0,0 +1 @@
+         keep  obj/setjmp
         case  on

****************************************************************
*
*  SetJmp - Set jump library
*
*  This code implements the subroutines needed to support the
*  standard C library SETJMP.
*
*  January 1989
*  Mike Westerfield
*
*  Copyright 1989
*  Byte Works, Inc.
*
****************************************************************
*
SetJmp   start                          dummy segment

         end

****************************************************************
*
*  int setjmp(env)
*        jmp_buf env;
*
*  Inputs:
*        env - pointer to the environment array
*
*  Outputs:
*        Returns 0.
*
****************************************************************
*
setjmp   start
env      equ   4                        pointer to array
ret      equ   1                        return address

         tsc                            set up addressing
         phd
         tcd
         clc                            save the correct stack pointer
         adc   #4
         sta   [env]
         ldy   #2                       save D
         lda   1,S
         sta   [env],Y
         ldy   #4                       save the return address
         lda   ret-1
         sta   [env],Y
         iny
         iny
         lda   ret+1
         sta   [env],Y
         pld                            repair the stack
         phb
         plx
         ply
         pla
         pla
         phy
         phx
         plb
         lda   #0                       return 0
         rtl
         end

****************************************************************
*
*  void longjmp(env,status)
*        jmp_buf env;
*        int status;
*
*  Inputs:
*        env - pointer to the environment array
*        status - status to return
*
****************************************************************
*
longjmp  start
env      equ   4                        environment pointer
status   equ   8                        status to return

         tsc                            set up the local stack frame
         tcd
         phb
         phk
         plb
         ldx   status                   get the status
         bne   lb1
         inx
lb1      ldy   #6                       get the env record
lb2      lda   [env],Y
         sta   lenv,Y
         dey
         dey
         bpl   lb2
         plb
         lda   >stackPtr                reset the stack pointer
         tcs
         lda   >ret+2                   reset the return address
         sta   2,S
         lda   >ret
         sta   0,S
         lda   >dp                      reset the dp
         tcd
         txa                            return the status
         rtl

lenv     anop                           local copy of *env
stackPtr ds    2
dp       ds    2
ret      ds    4
         end

signal.asm

@@ -0,0 +1 @@
+         keep  obj/signal
         mcopy signal.macros
         case  on

****************************************************************
*
*  signal - Asyncronous event signal handler
*
*  April 1990
*  Mike Westerfield
*
*  Copyright 1990
*  Byte Works, Inc.
*
****************************************************************
*
SIGNAL   start                          dummy segment
         copy  equates.asm
SIG_DFL  gequ  -3
SIG_IGN  gequ  -2
SIG_ERR  gequ  -1

SIGMAX   gequ  6                        maximum number of signals
         end

****************************************************************
*
*  void (*signal(int sig, void (*func) (int)))(int);
*
*  Set the interupt handler
*
*  Inputs:
*        sig - signal number
*        func - signal handler
*
*  Returns:
*        Pointer to the last signal handler; SIG_ERR if sig
*        is out of range.
*
****************************************************************
*
signal   start
         using signalCommon
ptr      equ   1                        old sugnal handler

         csubroutine (2:sig,4:func),4

         lla   ptr,SIG_ERR              assume we will find an error
         lda   sig                      if (!sig in [1..6])
         beq   lb1
         cmp   #SIGMAX+1
         blt   lb2
lb1      lda   #ERANGE                    errno = ERANGE
         sta   >errno
         bra   lb3

lb2      asl   A                        get the old signal handler address
         asl   A
         tax
         lda   >subABRT-4,X
         sta   ptr
         lda   >subABRT-2,X
         sta   ptr+2
         lda   func                     set the new signal handler address
         sta   >subABRT-4,X
         lda   func+2
         sta   >subABRT-2,X

lb3      creturn 4:ptr
         end

****************************************************************
*
*  int raise(int sig);
*
*  Raise a signal.
*
*  Inputs:
*        sig - signal number
*
*  Returns:
*        0 if successful, -1 if sig is out of range
*
****************************************************************
*
raise    start
         using signalCommon
val      equ   1                        value to return

         csubroutine (2:sig),2

         stz   val                      no error
         lda   sig                      if (!sig in [1..6])
         beq   lb1
         cmp   #SIGMAX+1
         blt   lb2
lb1      lda   #-1                        val = -1
         sta   val
         lda   #ERANGE                    errno = ERANGE
         sta   >errno
         bra   lb3

lb2      asl   A                        get the signal handler address
         asl   A
         tax
         lda   >subABRT-4,X
         tay
         lda   >subABRT-2,X
         bmi   lb3                      skip if it is SIG_DFL or SIG_IGN
         short M                        set up the call address
         sta   >jsl+3
         long  M
         tya
         sta   >jsl+1
         ph2   sig                      call the user signal handler
jsl      jsl   jsl

lb3      creturn 2:val
         end

****************************************************************
*
*  signalCommon - data area for the signal unit
*
****************************************************************
*
signalCommon privdata

subABRT  dc    a4'SIG_DFL'
subFPE   dc    a4'SIG_DFL'
subILL   dc    a4'SIG_DFL'
subINT   dc    a4'SIG_DFL'
subSEGV  dc    a4'SIG_DFL'
subTERM  dc    a4'SIG_DFL'
         end

signal.macros

@@ -0,0 +1 @@
+ MACRO
&lab csubroutine &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 1
.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+4+&work
&totallen seta &totallen+&len
&i seta &i+1
 aif &i<=c:&parms,^b
.e
 tsc
 aif &work=0,.f
 sec
 sbc #&work
 tcs
.f
 phd
 tcd
 mend
 MACRO
&lab creturn &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
 ldy #&r
 ldx #^&r
 ago .h
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+2
 sta &worklen+&totallen+2
 lda &worklen+1
 sta &worklen+&totallen+1
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 MACRO
&LAB LLA &AD1,&AD2
&LAB ANOP
 LCLA &L
 LCLB &LA
 AIF S:LONGA,.A
 REP #%00100000
 LONGA ON
&LA SETB 1
.A
 LDA #&AD2
&L SETA C:&AD1
.B
 STA &AD1(&L)
&L SETA &L-1
 AIF &L,^B
 LDA #^&AD2
&L SETA C:&AD1
.C
 STA 2+&AD1(&L)
&L SETA &L-1
 AIF &L,^C
 AIF &LA=0,.D
 SEP #%00100000
 LONGA OFF
.D
 MEND
 MACRO
&LAB LONG &A,&B
 LCLB &I
 LCLB &M
&A AMID &A,1,1
&M SETB ("&A"="M").OR.("&A"="m")
&I SETB ("&A"="I").OR.("&A"="i")
 AIF C:&B=0,.A
&B AMID &B,1,1
&M SETB ("&B"="M").OR.("&B"="m").OR.&M
&I SETB ("&B"="I").OR.("&B"="i").OR.&I
.A
&LAB REP #&M*32+&I*16
 AIF .NOT.&M,.B
 LONGA ON
.B
 AIF .NOT.&I,.C
 LONGI ON
.C
 MEND
 MACRO
&LAB PH2 &N1
 LCLC &C
&LAB 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
 LDA (&N1)
 PHA
 AGO .E
.B
 LDA &N1
 PHA
 AGO .E
.D
&N1 AMID &N1,2,L:&N1-1
 PEA &N1
 AGO .F
.E
 AIF S:LONGA=1,.F
 SEP #%00100000
.F
 MEXIT
.G
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB SHORT &A,&B
 LCLB &I
 LCLB &M
&A AMID &A,1,1
&M SETB ("&A"="M").OR.("&A"="m")
&I SETB ("&A"="I").OR.("&A"="i")
 AIF C:&B=0,.A
&B AMID &B,1,1
&M SETB ("&B"="M").OR.("&B"="m").OR.&M
&I SETB ("&B"="I").OR.("&B"="i").OR.&I
.A
&LAB SEP #&M*32+&I*16
 AIF .NOT.&M,.B
 LONGA OFF
.B
 AIF .NOT.&I,.C
 LONGI OFF
.C
 MEND

smac

@@ -0,0 +1 @@
+         macro
&lab     cstr  &s
&lab     dc    c"&s",i1'0'
         mend

         MACRO
&LAB     MOVE4 &F,&T
&LAB     ~SETM
         LDA   2+&F
         STA   2+&T
         LDA   &F
         STA   &T
         ~RESTM
         MEND

         macro
&lab     csubroutine &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  1
.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+4+&work
&totallen seta &totallen+&len
&i       seta  &i+1
         aif   &i<=c:&parms,^b
.e
         tsc
         aif   &work=0,.f
         sec
         sbc   #&work
         tcs
.f
         phd
         tcd
         mend


         macro
&lab     creturn &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
         ldy   #&r
         ldx   #^&r
         ago   .h
.g
         mnote 'Not a valid return length',16
         mexit
.h
         aif   &totallen=0,.i
         lda   &worklen+2
         sta   &worklen+&totallen+2
         lda   &worklen+1
         sta   &worklen+&totallen+1
.i
         pld
         tsc
         clc
         adc   #&worklen+&totallen
         tcs
         aif   &len=0,.j
         tya
.j
         rtl
         mend

toolglue.macros

@@ -0,0 +1 @@
+ MACRO
&LAB LLA &AD1,&AD2
&LAB ANOP
 LCLA &L
 LCLB &LA
 AIF S:LONGA,.A
 REP #%00100000
 LONGA ON
&LA SETB 1
.A
 LDA #&AD2
&L SETA C:&AD1
.B
 STA &AD1(&L)
&L SETA &L-1
 AIF &L,^B
 LDA #^&AD2
&L SETA C:&AD1
.C
 STA 2+&AD1(&L)
&L SETA &L-1
 AIF &L,^C
 AIF &LA=0,.D
 SEP #%00100000
 LONGA OFF
.D
 MEND
 MACRO
&LAB PH2 &N1
 LCLC &C
&LAB 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
 LDA (&N1)
 PHA
 AGO .E
.B
 LDA &N1
 PHA
 AGO .E
.D
&N1 AMID &N1,2,L:&N1-1
 PEA &N1
 AGO .F
.E
 AIF S:LONGA=1,.F
 SEP #%00100000
.F
 MEXIT
.G
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB PL2 &N1
 LCLC &C
&LAB ANOP
 AIF S:LONGA=1,.A
 REP #%00100000
.A
&C AMID &N1,1,1
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.F
&N1 AMID &N1,2,L:&N1-2
 PLA
 STA (&N1)
 AGO .D
.B
 PLA
 STA &N1
.D
 AIF S:LONGA=1,.E
 SEP #%00100000
.E
 MEXIT
.F
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB _READTIMEHEX
&LAB LDX #$0D03
 JSL $E10000
 MEND
 MACRO
&LAB _FWENTRY
&LAB LDX #$2403
 JSL $E10000
 MEND
 MACRO
&LAB _GETMOUSECLAMP
&LAB LDX #$1D03
 JSL $E10000
 MEND
 MACRO
&LAB _READMOUSE
&LAB LDX #$1703
 JSL $E10000
 MEND
 MACRO
&LAB _GETABSCLAMP
&LAB LDX #$2B03
 JSL $E10000
 MEND
 MACRO
&lab csubroutine &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 1
.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+4+&work
&totallen seta &totallen+&len
&i seta &i+1
 aif &i<=c:&parms,^b
.e
 tsc
 aif &work=0,.f
 sec
 sbc #&work
 tcs
.f
 phd
 tcd
 mend
 MACRO
&lab creturn &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
 ldy #&r
 ldx #^&r
 ago .h
.g
 mnote 'Not a valid return length',16
 mexit
.h
 aif &totallen=0,.i
 lda &worklen+2
 sta &worklen+&totallen+2
 lda &worklen+1
 sta &worklen+&totallen+1
.i
 pld
 tsc
 clc
 adc #&worklen+&totallen
 tcs
 aif &len=0,.j
 tya
.j
 rtl
 mend
 MACRO
&LAB PH4 &N1
 LCLC &C
&LAB 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
 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
&LAB PL4 &N1
 LCLC &C
&LAB ANOP
 AIF S:LONGA=1,.A
 REP #%00100000
.A
&C AMID &N1,1,1
 AIF "&C"<>"{",.B
&C AMID &N1,L:&N1,1
 AIF "&C"<>"}",.F
&N1 AMID &N1,2,L:&N1-2
 PLA
 STA (&N1)
 LDY #2
 PLA
 STA (&N1),Y
 AGO .D
.B
 AIF "&C"<>"[",.C
 PLA
 STA &N1
 LDY #2
 PLA
 STA &N1,Y
 AGO .D
.C
 PLA
 STA &N1
 PLA
 STA &N1+2
.D
 AIF S:LONGA=1,.E
 SEP #%00100000
.E
 MEXIT
.F
 MNOTE "Missing closing '}'",16
 MEND
 MACRO
&LAB _LONGDIVIDE
&LAB LDX #$0D0B
 JSL $E10000
 MEND
 MACRO
&LAB _LONGMUL
&LAB LDX #$0C0B
 JSL $E10000
 MEND
 MACRO
&LAB _SDIVIDE
&LAB LDX #$0A0B
 JSL $E10000
 MEND
 MACRO
&LAB _UDIVIDE
&LAB LDX #$0B0B
 JSL $E10000
 MEND
 MACRO
&LAB _INITIALLOAD
&LAB LDX #$0911
 JSL $E10000
 MEND
 MACRO
&LAB _RESTART
&LAB LDX #$0A11
 JSL $E10000
 MEND
 MACRO
&LAB _LOADSEGNAME
&LAB LDX #$0D11
 JSL $E10000
 MEND
 MACRO
&LAB _UNLOADSEG
&LAB LDX #$0E11
 JSL $E10000
 MEND
 MACRO
&LAB _GETLOC
&LAB LDX #$0C1A
 JSL $E10000
 MEND
 MACRO
&LAB _GETERRGLOBALS
&LAB LDX #$0E0C
 JSL $E10000
 MEND
 MACRO
&LAB _GETINGLOBALS
&LAB LDX #$0C0C
 JSL $E10000
 MEND
 MACRO
&LAB _GETINPUTDEVICE
&LAB LDX #$120C
 JSL $E10000
 MEND
 MACRO
&LAB _GETOUTGLOBALS
&LAB LDX #$0D0C
 JSL $E10000
 MEND
 MACRO
&LAB _GETOUTPUTDEVICE
&LAB LDX #$130C
 JSL $E10000
 MEND
 MACRO
&LAB _GETERRORDEVICE
&LAB LDX #$140C
 JSL $E10000
 MEND
 MACRO
&LAB _INITIALLOAD2
&LAB LDX #$2011
 JSL $E10000
 MEND
 MACRO
&lab _GetMSData
&lab ldx #$1F23
 jsl $E10000
 MEND

vars.macros

@@ -0,0 +1 @@
+ MACRO
&LAB LLA &AD1,&AD2
&LAB ANOP
 LCLA &L
 LCLB &LA
 AIF S:LONGA,.A
 REP #%00100000
 LONGA ON
&LA SETB 1
.A
 LDA #&AD2
&L SETA C:&AD1
.B
 STA &AD1(&L)
&L SETA &L-1
 AIF &L,^B
 LDA #^&AD2
&L SETA C:&AD1
.C
 STA 2+&AD1(&L)
&L SETA &L-1
 AIF &L,^C
 AIF &LA=0,.D
 SEP #%00100000
 LONGA OFF
.D
 MEND