*****************  GPM   ******************
*
*      A GENERAL PURPOSE MACROGENERATOR.
*      AN IMPLEMENTATION FOR THE M6800,
*      AFTER AN ARTICLE IN THE COMPUTER JOURNAL
*      VOL. 8 PAGE 225 BY C.STRACHEY.
*      WRITTEN BY FRITS VAN DER WATEREN.
*      PHYSICAL LABORATORY
*      DEPT. E.N.T. WILHELMINA HOSPITAL
*      AMSTERDAM    THE NETHERLANDS.
*
       NAM GPM
       ORG 0
*      OPT 1
*
*      OPT 1 HAS THE EFFECT OF SETTING BIT-7
*      WHEN EVALUATING ASCII CHAR. IN 'FCC' OR #'X
*      OPT 0 CLEARS THIS BIT.
*      THIS FEATURE IS VERY ESSENTIAL FOR THIS
*      IMPLEMENTATION OF GPM. SINCE ALL CHARACTERS
*      (8-BITS) HAVE THIS BIT SET.
*      ALL POINTERS (16-BITS) HAVE THIS BIT CLEARED.
*      SO GPM CAN ONLY RUN IN THE FIRST 32K!
*
*


FCC8   MACR
NUM    SET '\0!+$80
       FCB NUM
       ENDM


******  BASE PAGE LOCATIONS  ******
*
*
C0     FCB 0,0,0,0,0,0 6 WARNING CHAR.
F      FDB 0 START OF NOT ENTERED MACRO
P      FDB 0 START OF ENTERED MACRO
H      FDB 0 POINTS TO 'LENGTH CELL'
C      FDB 0 POINTS TO SOURCE CHAR.
E      FDB 0 POINTS TO LAST MACRO IN E-CHAIN
Q      FCB 0 QUOTE COUNTER
S      FDB 0 POINTS TO FIRST FREE CELL
V      FDB 0 V W K L ARE TEMPORIES.
W      FDB 0
K      FDB 0
L      FDB 0
BEG    FDB 0
END    FDB 0
SAVEX  FDB 0
A16    FDB 0
B16    FDB 0
BOTTOM FDB 0
DUPLX  FCB 0 0=NO ECHO; $FF=ECHO
       PAGE
       ORG $100
*
*      INITIAL START OF GPM IS HERE!
*
GPM    LDS #$FF STACK IS IN ZERO PAGE
       LDX ACIA
       LDA A #%1 7-BIT+EVEN PARITY
       STA A 0,X CLOCK /16
       JMP CLEAR
*
*      PATCH POINTS:
*
ACIA   FDB $FCF4
FWAM   FDB FWS FIRST WORD AVAILABLE MEMORY
LWAM   FDB $1FFF LAST WORD OF AVAILABLE MEMORY
       SPC 2
       PAGE
*
*      NEXTCH  LOADS NEXT CHARACTER IN A
*
NEXTCH STX SAVEX
       LDX C C AT BOTTOM OF STACK?
       BEQ TH YES,READ CHAR.
       LDA A 0,X NO,GET CHAR OF STACK
       INX
       STX C
       BRA R1
TH     LDX H
       BNE READS
       LDX S WE ARE ON THE LOWEST LEVEL NOW
       STX BOTTOM  SAVE GPM STACK POINTER.
READS  LDX ACIA
       SPC 1
INCH   LDAA 0,X
       ASRA  WAIT FOR TTY
       BCC INCH
       LDA A 1,X READ CHAR.
       ASLA
       SEC
       RORA  SET BIT 7
       TST DUPLX ECHO?
       BEQ R1 NO
       BSR OUTCH
R1     LDX SAVEX
       TST A
       RTS
*
*      LOAD OR OUTPUT A CHAR. FROM A
*
LOAD   STX SAVEX
       LDX H H AT BOTTOM OF STACK?
       BEQ WRITES YES,WRITE CHAR.
       JSR PUSH NO,PUSH ON STACK
       BRA R2
WRITES BSR OUTCH
R2     LDX SAVEX
       RTS
       SPC 1
OUTCH  PSHA
       LDX ACIA
OUTC1  LDA A 0,X
       ASRA
       ASRA
       BCC OUTC1 WAIT FOT TTY DONE!
       PULA
       STA A 1,X PRINT CHAR
       RTS
       PAGE
*      ROUTINE 'FIND' SEARCHES FOR A MACRONAME
*      ( X POINTS TO THIS NAME ) IN THE E-CHAIN
*      ON EXIT X AND W POINT TO
*      THE FIRST WORD OF THE MACROBODY.
*      WHEN MACRO IS NOT IN THE E-CHAIN,
*      FIND RETURNS THE NULL STRING
       SPC 1
FIND   STX W
       LDX E
       STX K
SETUP  LDX W
       STX V
       LDX 0,X GET LENGTH OF MACRO NAME.
       STX A16
       LDX K
       STX L
SEARCH LDX V
       LDAA 0,X
       INX
       STX V
       LDX L
       CMP A 2,X COMPARE CHAR. BY CHAR.
       BNE NEXT SEARCH FAIL,SO PREVIOUS MACRO
       INX    IN E-CHAIN.
       STX L
       LDX A16
       DEX  ALL CHARACTERS MATCH?
       STX A16
       BNE SEARCH NOT YET!
FOUND  LDX K
       STX A16
       LDX 2,X
       JSR ADD SKIP MACRONAME.
       INX
       INX  THIS IS THE FIRST WORD
       STX W   OF THE MACRO BODY.
       RTS
NEXT   LDX K
       CPX #NIL. E-CHAIN EXAUSTED?
       BEQ FOUND YES,RETURN A NIL-BODY.
       LDX 0,X NO,NEXT MEMBER OF E-CHAIN
       STX K
       BRA SETUP
       SPC 1
       PAGE
*
*      SUBROUTINE ADD   X=A16=A16+X
*          B16= 'OLD' X
*
ADD    STX B16
       PSH A
       LDA A B16+1
       ADD A A16+1 ADD LSB
       STA A A16+1
       LDA A B16
       ADC A A16 ADD MSB
       BRA EX
*
*      SUBROUTINE SUB  X=A16=A16-X
*
SUB    STX B16
       PSH A
       LDA A A16+1
       SUB A B16+1 SUBSTRACT LSB
       STA A A16+1
       LDA A A16
       SBC A B16 SUBSTRACT MSB
EX     STA A A16
       PUL A
       LDX A16
       RTS
*
*       REVERSE SUBSTRACT  X=B16=X-A16
*
RSUB   STX B16
       PSH A
       LDA A B16+1
       SUB A A16+1 SUBSTRACT LSB
       STA A B16+1
       LDA A B16
       SBC A A16 SUBSTRACT MSB
       STA A B16
       PUL A
       LDX B16
       RTS
*
*      SUBROUTINE ADDB X=X+A
*
ADDB   STX B16
       ADDA B16+1
       STAA B16+1
       LDAA B16
       ADCA #0
       STAA B16
       LDX B16
       RTS
       PAGE
*
*      COMPUTE CHARACTER EQUIVALENT NUMBER IN A
*
*       0 - 9 (ASCII) GIVES 0 - 9 (DEC NUMBER)
*       A - Z (ASCII) GIVES 10 - 35 (DEC NUMBER)
*       ALL OTHER CHARACTERS GIVE A ZERO RESULT.
*
NUMBER SUB A #@260
       BLT ZERO NO LEGAL CHAR.
       CMP A #9 0 - 9 ?
       BLE ZERO+1 YES
       SUB A #7 NO,
       CMP A #9
       BLT ZERO A - Z ?
       CMP A #35
       BGT ZERO+1 YES
ZERO   CLR A
       RTS
*
*      MEMORY FULL!
*      PRINT THIS MESSAGE AND
*      DELETE F-CHAIN AND P-CHAIN, SAVE E-CHAIN.
*
FULL   LDX #MEMFUL
FULLL  LDAA 0,X
       CMPA #4
       BEQ RSTART
       INX
       STX SAVEX
       JSR OUTCH PRINT STRING
       LDX SAVEX
       BRA FULLL
RSTART LDX BOTTOM
       STX S BOTTOM OF GPM STACK
       JMP INIT
       SPC 1
MEMFUL FCB $D,$A
       FCC8 *
       FCC8 *
       FCB $A0 SPACE
       FCC8 M
       FCC8 E
       FCC8 M
       FCC8 O
       FCC8 R
       FCC8 Y 
       FCB $A0
       FCC8 F
       FCC8 U
       FCC8 L
       FCC8 L
       FCB $A0
       FCC8 *
       FCC8 *
       FCB $D,$A,4
*
*      PUSH A ON TOP OF GPM STACK
*
PUSH   LDX S
       CPX LWAM MEMORY FULL?
       BEQ FULL YES
       STA A 0,X NO,LOAD CHAR. AT TOP OF STACK
       INX  ADVANCE STACKPOINTER
       STX S
       RTS
       PAGE
       SPC 1
*
*      GET A CHARACTER AND SEARCH FOR WARNING CHARACTER
*
START  JSR NEXTCH
       BPL ENDFN. MARKER!
       CMPA C0 $
       BEQ FN CREATE NEW F-MEMBER
       CMPA C0+1 ,
       BEQ NXTITM NEXT ITEM
       CMPA C0+2 ;
       BEQ APPLY. ADD F-MEMBER TO P-CHAIN
       CMPA C0+3 #
       BEQ LDARG. LOAD ARGUMENT
       CMPA C0+4 >
       BEQ EXIT
       CMPA C0+5 <
       BEQ Q2 Q=Q+1
COPY   JSR LOAD NO WARNING CHAR. SO COPY
SCAN   LDA A Q BETWEEN <> ?
       BEQ START NO
Q1     JSR NEXTCH YES,COPY CHAR.
       CMPA C0+5 < ?
       BNE Q3
       INC Q YES, Q=Q+1
       BRA COPY
       SPC 1
Q2     INC Q
       BRA Q1
       SPC 1
Q3     CMPA C0+4 > ?
       BNE COPY NO,COPY CHAR.
       DEC Q YES,Q=Q-1
       BEQ START OUT OF <> !
       BRA COPY
       SPC 1
EXIT   SWI SINGLE > IS USED TO LEAVE GPM
       SPC 1
APPLY. JMP APPLY
LDARG. JMP LDARG
ENDFN. JMP ENDFN
       PAGE
*       WARNINGCHARACTER $
*      CREATE NEW MEMBER AT TOP OF F-CHAIN.
       SPC 1
FN     LDA A H PUSH H ON STACK
       BSR PUSH
       LDA A H+1
       BSR PUSH
       LDA A F PUSH F ON STACK
       BSR PUSH
       LDA A F+1
       BSR PUSH
       DEX
       DEX
       STX F F NOW POINTS TO NEW MEMBER
       CLR A
       BSR PUSH RESERVE WORD FOR C-POINTER
       BSR PUSH
NEWH   STX H H POINTS TO NEW LENGTH CELL
       BSR PUSH AND CLEAR THIS CELL
       BSR PUSH
       BRA START
       SPC 2
*       WARNINGCHARACTER ,
*      CLOSE CURRENT ITEM AND SETUP NEW ONE.
       SPC 1
NXTITM LDX H ANY STRING ON STACK?
       BEQ COPY NO,COPY ,
       LDX S YES,COMPUTE LENGTH OF CURRENT ITEM
       STX A16
       LDX H
       JSR SUB S-H
       LDX H
       LDX 0,X
       JSR SUB S-H-(H)
       LDX H
       LDA A A16
       STA A 0,X AND LOAD CURRENT LENGTH CELL
       LDA A A16+1
       STA A 1,X
       LDX S
       CLR A
       BRA NEWH
       PAGE
*       WARNING CHARACTER ;
*      ADD F MEMBER TO TOP OF P-CHAIN
*      TOP F-MEMBER IS THEN DELETED.
       SPC 1
COPY.  JMP COPY
       SPC 1
APPLY  LDX P
       STX W
       LDX #F
       JSR CMP P>F ?
       BCC COPY. YES,UNMATCHED ;
       LDX H NO,ANY STRING ON STACK?
       BEQ COPY. NO,COPY ;
       LDX S
       STX A16
       LDX H
       JSR SUB S-H
       LDX H
       LDA A A16 ADJUST LENGTH CELL
       STA A 0,X OF CURRENT ITEM
       LDA A A16+1
       STA A 1,X
       CLR A  YES,APPEND MARKER
       JSR PUSH  (= TWO ZERO BYTES)
       JSR PUSH
       STX A16
       LDX F
       DEX
       DEX  POINTS TO LENGTH CELL
       STX K
       LDX F
       LDX 0,X
       STX F F NOW POINTS TO PREVIOUS F-MEMBER
       LDX K
       JSR SUB S-F+2 (F-MEMBER LENGTH)
       LDX K
       LDX 0,X H NOW POINTS TO
       STX H  THE MOST PREVIOUS LENGTH CELL
       LDX K
       LDA A A16 INSERT TRUE LENGTH
       STA A 0,X OF F-MEMBER
       LDA A A16+1
       STA A 1,X
       LDA A P
       STA A 2,X CHANGE F-MEMBER INTO P-MEMBER
       LDA A P+1
       STA A 3,X
       LDA A C
       STA A 4,X
       LDA A C+1
       STA A 5,X
       INX
       INX
       STX P P NOW POINTS TO NEW MEMBER
       LDX H WAS THERE ANY PREVIOUS STRING.
       BEQ FMACRO NO
       LDX K
       LDX 0,X YES,GET LENGTH OF NEW P-MEMBER
       STX A16
       LDX H
       LDX 0,X AND LENGTH OF PREVIOUS ITEM
       JSR ADD AND CORRECT IT
       LDX H
       LDA A A16
       STA A 0,X
       LDA A A16+1
       STA A 1,X
       SPC 1
FMACRO LDX P
       INX
       INX
       INX
       INX POINTS TO LENGTH CELL OF MACRO TO BE CALLED
       JSR FIND SEARCH FOR MACRO IN E-CHAIN
       LDX 0,X IS IT A MACHINE MACRO?
       BPL MBODY NO
       STX W YES (BIT 15 IS SET)
       ASL W NOW CLEAR THIS BIT
       LSR W
       LDX W
       JMP X AND EXECUTE MACINE MACRO
MBODY  LDX W
       INX
       INX
       STX C POINTS TO FIRST CHARACTER OF
       JMP START CALLED MACRO BODY
       SPC 1
       PAGE
*       WARNING CHARACTER #
*       REPLACES ARGUMENTNUMBER BY ARGUMENT.
       SPC 1
*       WHEN THERE IS NO ARGUMENT FOR THIS
*      NUMBER,NOTHING IS REPLACED.
LDARG  LDX P ANY MACRO CALL ENTERED?
       BEQ COPY.. NO,COPY #
       INX
       INX
       INX
       INX
       STX A16 POINTS TO LENGTH CELL.
       JSR NEXTCH GET NEXT SINGLE CHARACTER
       JSR NUMBER A=NUMBER REPRESENTATION
GETARG LDX 0,X GET LENGTH CELL
       CPX #0 IF IT IS A MARKER,
       BEQ START. ARGUMENT LIST IS EXAUSTED.
       DEC A  PARAMETER NUMBER REACHED?
       BMI REACHD YES!
       JSR ADD NO,COMPUTE NEXT ARGUMENT ADRES.
       STX A16
       BRA GETARG
       SPC 1
REACHD LDX A16
       STX BEG
       LDX 0,X GET LENGTH OF THIS ARGUMENT
       JSR ADD END OF STRING+1 IN A16
       LDX BEG GET BEGIN OF STRING
       INX
MOVARG INX
       CPX A16 EMPTY?
       BEQ START.
       JSR PUSH
       LDA A E+1
       JSR PUSH
       LDX P PREPAIRE FOR E-CHAIN
       DEX   POINTER CORRECTIONS.
       DEX
       STX BEG X POINTS TO BEGIN OF P-MEMBER
       STX A16
       LDX 0,X
       STX W W=LENGTH OF ARG.
       JSR ADD
       STX END END POINTS TO END+1 OF P-MEMBER
       LDX W
       STX A16
       LDX K
NEXTE  LDX 0,X POINTS TO PREVIOUS E-MEMBER
       STX W
       LDX #END
       JSR CMP BELOW END OF P-MEMBER.?
       BCS LOCAL YES,PERHAPS A LOCAL DEF.
       JSR RSUB NO,CORRECT E-POINTER
       LDX K I.E. E=E-W
       LDA A B16
       STA A 0,X
       LDA A B16+1
       STA A 1,X
       LDX W
       STX K
       BRA NEXTE
       SPC 1
LOCAL  STX W
       LDX #BEG
       BSR CMP E-MEMBER BEFORE P-MEMBER.?
       BCS NOLOC YES,NO LOCAL DEFS LEFT!
       LDX 0,X NO,GET PREVIOUS E-MEMBER
       BRA LOCAL
NOLOC  STX W
       LDX K E-CHAIN OF LOCAL DEFS
       LDA A W  IS NOW DISCONNECTED.
       STA A 0,X
       LDA A W+1
       STA A 1,X
       LDX S
       DEX
       DEX
       STX S
       LDX 0,X PULL NEW E FROM STACK
       STX E
       LDX H DEFS ONLY?
       BEQ MOVDWN YES,GO DELETE ARG.
       STX W
       LDX #P
       BSR CMP H-P
       BCS HLP H<P!
       JSR RSUB H>=P!
       STX H H=H-PHI
       BRA MOVDWN  ( PHI = ARG. LENGTH )
HLP    LDX 0,X
       JSR RSUB (H)=(H)-PHI
       LDX H
       LDA A B16
       STA A 0,X
       LDA A B16+1
       STA A 1,X
MOVDWN LDX P
       LDX 2,X
       STX C C NOW POINTS TO PREVIOUS P-MEMBER
       LDX P
       LDX 0,X
       STX P SO DO P
       LDX S
       JSR RSUB S=S-PHI
       STX S
MOVN1  LDX END
       LDAA 0,X NOW MOVE DOWN,
       INX   AND OVERWRITE TOP P-MEMBER.
       STX END
       LDX BEG
       CPX S MOVE DONE?
       BEQ STRT
       STA A 0,X
       INX
       STX BEG
       BRA MOVN1
       SPC 1
*      CMP COMPARES THE 16-BIT VALUE IN W
*      WITH THE 16-BIT VALUE WHERE X POINTS TO.
*      [(X)-W]  (UNSIGNED)
*       C=0 W >= (X)
*       C=1 W <  (X)
       SPC 1
CMP    LDA B W+1
       SUB B 1,X
       LDA B W
       SBC B 0,X
       LDX W
       RTS
       PAGE
*      MACHINE MACRO 'DEF'
*
*      $DEF,MACRONAME,ARGUMENT;
*
*      SET MACRO 'MACRONAME' WITH ITS ARGUMENT
*      ON TOP OF THE E-CHAIN.
*
DEF    LDX P
       DEX
       DEX
       STX BEG POINTS TO LENGTH CELL
       LDX 0,X
       STX A16
       LDX H ANY STRINGS LEFT?
       BEQ APPEND NO,THATS EASY
       LDX 0,X YES,CORRECT LENGTH CELL
       JSR RSUB
       LDX H
       LDA A B16
       STA A 0,X (H)=(H)-PHI
       LDA A B16+1
       STA A 1,X
APPEND LDX P
       LDX 0,X
       STX P REMOVE TOP MEMBER
       LDX BEG  OF P-CHAIN.
       LDA A E
       STA A 0,X
       LDA A E+1 AND APPEND IT TO E-CHAIN.
       STA A 1,X
       STX E
       LDX BEG REMOVE MACRONAME
DELDEF LDA A 11,X  'DEF' FROM LIST!
       STA A 2,X
       INX
       CPX S DONE?
       BNE DELDEF NO!
       LDA B #9 YES,STACKPOINTER 9 BACK
SMIN   DEX
       DEC B
       BNE SMIN
       STX S
STRT   JMP START
       PAGE
*      MACHINEMACRO 'CW' CHANGE WARNINGCHARACTERS
*
*      $CW,<ABCDEF>;
*
*      ABCDEF STANDS FOR THE DEFAULT
*      WARNING CHARACTERS: $,;#>< IN THIS ORDER.
*
CW     LDX P
       STX W
       LDA B 9,X GET LENGTH (LSB) OF BODY
       SUBB #2
       STAB BEG NUMBER OF CHAR. IN BODY
       CLRB
       LDX #C0
CW1    STX K
       LDX W
       INX
       CMPB #6
       BEQ CW2 MORE THAN 6 WARNINGCHAR.!
       CMPB BEG
       BEQ CW2 MACRO BODY EXAUSTED!
       INCB
       LDAA 9,X
       STX W
       LDX K
       STAA 0,X CHANGE WARNINGCHARACTER.
       INX
       BRA CW1
CW2    JMP ENDFN
*
*      MACHINE MACRO 'VAL'
*
*      $VAL,XXX;
*
*      RETURNS THE BODY OF MACRO XXX
*      WITHOUT EVALUATING IT
*
VAL    LDX P
       LDAA #9
       JSR ADDB
       JSR FIND FIND THIS MACRO
       LDAA 0,X
       BMI CW2 IGNORE MACHINE MACROS
VAL1   INX  POINTS TO FIRST CHAR.
       LDAA 1,X  OF BODY.
       BEQ CW2 AND LOAD ALL CHAR. OF BODY
       JSR LOAD  UNTIL A MARKER.
       BRA VAL1
       PAGE
*
*      MACHINE MACRO 'CLEAR'
*
*      $CLEAR;
*
*      CLEAR FLUSHES THE GPM STACK
*      AND SETS THE WARNING CHARACTERS
*      TO THEIR DEFAULT VALUE
*
CLEAR  LDAA #$FF
       STAA DUPLX
       LDX #DUPL.
       STX E
       LDX FWAM
       STX S
       LDX SWC SET WARNING CHARACTERS.
       STX C0
       LDX SWC+2
       STX C0+2
       LDX SWC+4
       STX C0+4
INIT   LDX #0
       STX F SET GPM POINTERS TO
       STX P THERE INITIAL VALUES
       STX C
       STX H
       CLRA
       STAA Q
       JMP START
SWC    EQU *
       FCB $24!+$80 ASCII($)
       FCB $2C!+$80 ASCII(,)
       FCB $BB  ASCII(;)
       FCB $23!+$80 ASCII(#)
       FCC8 >
       FCC8 <
       SPC 1
*
*      MACHINE MACRO 'DUPLEX'
*
*      $DUPLEX,0;
*      CHARACTERS ARE NOT ECHOED!
*
*      $DUPLEX,1;
*      CHARACTERS ARE ECHOED!
*
DUPLEX LDX P
       LDA A 13,X GET LENHTH OF BODY
       CMPA #2 EMPTY BODY?
       BLE NOP YES,NO ACTION.
       LDA A 14,X NO,GET FIRST CHAR.
       CMPA #$B0 0=SIMPLEX
       BEQ SIMPLX
       CMP A #$B1 1=DUPLEX
       BNE NOP ALL OTHERS=NO ACTION.
       LDA A #$FF
       STA A DUPLX
NOP    JMP ENDFN
SIMPLX CLR DUPLX
       BRA NOP
       PAGE
*
*      MACHINE MACRO 'UPDATE'
*
*      $UPDATE,MACRONAME,ARGUMENT;
*
*      UPDATE MACRO 'MACRONAME' IN THE E-CHAIN.
*      WITH A NEW 'ARGUMENT'.
*      WHEN THE NEW ARGUMENT DOES NOT FIT,
*      IT IS TRUNCTATED.
*      WHEN THE MACRO IS NOT IN THE E-CHAIN,
*      'UPDATE' HAS NO RESULT.
*
UPDATE LDX P
       LDA A #12 SKIP OVER MACRONAME 'UPDATE'
       JSR ADDB
       JSR FIND FIND MACRO TO BE UPDATED.
       LDX 0,X MAX LENGTH OF MACRO BODY TO BE UPDATED.
       BMI UPDONE IGNORE MACHINE MACROS.
       STX V
       LDX P
       LDX 12,X
       STX A16
       LDX P
       JSR ADD
       LDX V
       DEX
UPDMOV DEX  DOES IT STILL FIT?
       BEQ UPDEND NO,TRUNCTATE
       STX V
       LDX A16 YES,CHANGE ARGUMENT!
       LDA A 14,X MARKER?
       BPL UPDEND YES,TRANSFER DONE!
       INX
       STX A16
       LDX W
       STA A 2,X
       INX
       STX W
       LDX V
       BRA UPDMOV
       SPC 1
UPDEND CLR A
       LDX W
       STA A 2,X APPEND MARKER
       STA A 3,X
UPDONE JMP ENDFN
       PAGE
*      MACHINE MACRO 'USER'
*
*      $USER,XXXX,ANY ARGUMENT;
*
*      CALL USER ROUTINE AT ADDRESS XXXX (HEX)
*      WITH ANY ARGUMENT STRUCTURE TO BE USED
*      IN THE USER ROUTINE.
*      ON ENTRY 'W' POINTS TO THE FIRST WORD
*      OF THIS ARGUMENT ON THE GPM STACK
*      THE USER MUST RETURN WITH 'JMP ENDFN'
*
USER   LDX P
       STX W
       LDX 10,X GET LENGTH OF ADDRESS ARGUMENT
       DEX
       STX V
       CLR BEG
       CLR BEG+1
NXTHEX LDX V
       DEX  ALL DIGITS DONE?
       BEQ GO.MAC YES,GO
       STX V
       LDX W
       LDA A 12,X NO,GET CHAR.
       INX
       STX W AND TRANSFORM TO HEX.
       SUB A #$B0 WHEN NOT HEX,SKIP THIS CHAR.
       BLT NXTHEX
       CMP A #9
       BLE INHEX
       SUB A #7
       CMP A #10
       BLT NXTHEX
       CMP A #16
       BGE NXTHEX
INHEX  LDA B BEG+1
       ASL B  SHIFT DIGIT INTO 16-BIT ADDRESS
       ROL BEG
       ASL B
       ROL BEG
       ASL B
       ROL BEG
       ASL B
       ROL BEG
       ABA
       STA A BEG+1
       BRA NXTHEX
GO.MAC LDX W
       LDA A #12 CALCULATE USER ARGUMENT ADRRESS
       JSR ADDB
       STX W
       LDX BEG
       JMP 0,X HERE WE GO!?
       PAGE
       SPC 2
*
*      THE ENVIRONMENT CHAIN (E-CHAIN)
*
NIL.   FDB 0,5
       FCC8 N
       FCC8 I
       FCC8 L
       FDB 2,0 NULL STRING
DEF.   FDB NIL.,5
       FCC8 D
       FCC8 E
       FCC8 F
       FDB DEF+$8000
*      BIT-15 =1 INDICATES A MACHINE MACRO
CW.    FDB DEF.,4
       FCC8 C
       FCC8 W
       FDB CW+$8000
USER.  FDB CW.,6
       FCC8 U
       FCC8 S
       FCC8 E
       FCC8 R
       FDB USER+$8000
VAL.   FDB USER.,5
       FCC8 V
       FCC8 A
       FCC8 L
       FDB VAL+$8000
UPD.   FDB VAL.,8
       FCC8 U
       FCC8 P
       FCC8 D
       FCC8 A
       FCC8 T
       FCC8 E
       FDB UPDATE+$8000
CLEAR. FDB UPD.,7
       FCC8 C
       FCC8 L
       FCC8 E
       FCC8 A
       FCC8 R
       FDB CLEAR+$8000
DUPL.  FDB CLEAR.,8
       FCC8 D
       FCC8 U
       FCC8 P
       FCC8 L
       FCC8 E
       FCC8 X
       FDB DUPLEX+$8000
FWS    EQU * FIRST WORD OF GPM STACK
       SPC 1
       END