
 1000  *SAVE S.TRAPPER
 1010  *--------------------------------
 1020  *      TRAPPER, BY ALLEN MARSALIS
 1030  *--------------------------------
 1040         .OR $9300
 1050         .TF B.TRAPPER
 1060  *--------------------------------
 1070  RLEN   .EQ $1A      RESTRICTION STRING
 1080  RSTR   .EQ $1B      DESCRIPTOR
 1090  TEMPPT .EQ $52
 1100  LASTPT .EQ $53
 1110  FRESPC .EQ $71,72
 1120  HIMEM  .EQ $73,74
 1130  VARPNT .EQ $83,84
 1140  FACMO  .EQ $A0
 1150  *--------------------------------
 1160  BUF    .EQ $200     INPUT BUFFER
 1170  AMPVEC .EQ $3F5     AMPERSAND VECTOR
 1180  STROBE .EQ $C010    KEYBOARD STROBE
 1190  *--------------------------------
 1200  AS.FRMNUM  .EQ $DD67     EVALUATE NUMERIC FORMULA
 1210  AS.CHKSTR  .EQ $DD6C     REQUIRE STRING
 1220  AS.FRMEVL  .EQ $DD7B     EVALUATE GENERAL FORMULA
 1230  AS.CHKCLS  .EQ $DEB8     REQUIRE ")"
 1240  AS.CHKCOM  .EQ $DEBE     REQUIRE ","
 1250  AS.CHKOPN  .EQ $DEBB     REQUIRE "("
 1260  AS.SYNCHR  .EQ $DEC0     REQUIRE (A-REG)
 1270  AS.SYNERR  .EQ $DEC9     SYNTAX ERROR
 1280  AS.PTRGET  .EQ $DFE3     GET VARIABLE PNTR
 1290  AS.GETSPA  .EQ $E452     GET SPACE IN STRING AREA
 1300  AS.MOVSTR  .EQ $E5E2     COPY STRING DATA
 1310  AS.FRETMP  .EQ $E604     FREE TEMPORARY STRING
 1320  AS.CONINT  .EQ $E6FB     CONVERT FAC TO 8-BITS
 1330  *--------------------------------
 1340  MON.CLREOL .EQ $FC9C     CLEAR TO END-OF-LINE
 1350  MON.RDKEY  .EQ $FD0C     READ A KEY
 1360  MON.COUT   .EQ $FDED     DISPLAY A CHARACTER
 1370  *--------------------------------
 1380  SETUP  LDA #$4C     "JMP" OPCODE
 1390         STA AMPVEC
 1400         LDA #TRAPPER
 1410         STA AMPVEC+1
 1420         LDA /TRAPPER
 1430         STA AMPVEC+2
 1440         LDA #SETUP   SET HIMEM UNDER TRAPPER
 1450         STA HIMEM
 1460         LDA /SETUP
 1470         STA HIMEM+1
 1480         RTS
 1490  *--------------------------------
 1500  *      AMPERSAND COMES HERE
 1510  *--------------------------------
 1520  TRAPPER
 1530         LDA #$84          "INPUT" TOKEN
 1540         JSR AS.SYNCHR
 1550         JSR AS.CHKOPN     "& INPUT ("
 1560         JSR AS.FRMNUM     READ FIELD LENGTH PARAMETER
 1570         JSR AS.CONINT     CONVERT TO 8-BIT VALUE
 1580         STX FL            SAVE FIELD LENGTH
 1590         JSR AS.CHKCOM     ","
 1600         JSR AS.FRMEVL     GET RESTRICTION STRING
 1610         JSR AS.CHKSTR
 1620         JSR AS.CHKCOM     ANOTHER ","
 1630         LDY #2            SAVE DESCRIPTOR
 1640  .1     LDA (FACMO),Y
 1650         STA RLEN,Y
 1660         DEY
 1670         BPL .1
 1680         LDA TEMPPT        DID FRMEVL MAKE A TEMP STRING?
 1690         CMP #$56
 1700         BCC .2            NO
 1710         LDA LASTPT        YES, SO FREE THE TEMP
 1720         LDY #0
 1730         JSR AS.FRETMP
 1740  .2     LDA #0            INIT BUFFER INDEX
 1750         STA BINDEX
 1760  *---UNDERSCORE INPUT FIELD-------
 1770         LDA #$DF          UNDERLINE CHAR
 1780         JSR PRINT.FIELD
 1790         LDA #$88          BACKSPACE  TO BEGINNING AGAIN
 1800         JSR PRINT.FIELD
 1810  *---READ A KEY-------------------
 1820         BIT STROBE        DON'T ALLOW TYPE AHEAD
 1830  .3     JSR MON.RDKEY     READ NEXT KEY
 1840         AND #$7F          INTERNAL FORM
 1850         STA KEY           SAVE IT
 1860  *---BACKSPACE--------------------
 1870         CMP #$08          BACKSPACE?
 1880         BNE .22           NO
 1890         LDA BINDEX        IGNORE AT BEGINNING OF LINE
 1900         BEQ .21
 1910         LDA #$88          YES, ECHO IT
 1920         JSR MON.COUT
 1930         LDA #$DF          REPLACE UNDERLINE
 1940         JSR MON.COUT
 1950         LDA #$88          BACKSPACE AGAIN
 1960         JSR MON.COUT
 1970         DEC BINDEX        BACK UP BUFFER TOO
 1980  .21    JMP .3
 1990  *---CARRIAGE RETURN--------------
 2000  .22    CMP #$0D          RETURN?
 2010         BNE .23           NO
 2020         JSR MON.CLREOL
 2030         JSR AS.PTRGET     GET DESTINATION STRING
 2040         JSR AS.CHKCLS     MUST HAVE ")" AT END
 2050         LDA BINDEX        LENGTH OF INPUT LINE
 2060         JSR AS.GETSPA     FIND ROOM FOR IT
 2070         LDY #0            MOVE IN DESCRIPTOR
 2080         STA (VARPNT),Y
 2090         INY
 2100         LDA FRESPC
 2110         STA (VARPNT),Y
 2120         INY
 2130         LDA FRESPC+1
 2140         STA (VARPNT),Y
 2150         LDY /BUF          COPY DATA INTO STRING
 2160         LDX #BUF
 2170         LDA BINDEX
 2180         JMP AS.MOVSTR     ...AND RETURN
 2190  *---CHECK IF VALID KEY-----------
 2200  .23    JSR CHECK.RESTRICTIONS
 2210  *---CHECK VALIDITY AND ECHO------
 2220         LDA KEY           GET KEY AGAIN
 2230         LDA BINDEX
 2240         CMP FL
 2250         BCS .27           TOO FAR, ABORT KEY
 2260         LDA NEW           IF NEW = FAIL, ABORT KEY
 2270         BEQ .27           YES, ABORT KEY
 2280         LDA KEY
 2290         LDY BINDEX
 2300         STA BUF,Y         PUT KEY INTO BUFFER
 2310         INC BINDEX
 2320         CMP #$20          IF KEY WAS CONTROL-KEY,
 2330         BCS .26              THEN PRINT SPACE
 2340         LDA #$20
 2350  .26    ORA #$80
 2360         JSR MON.COUT      ECHO
 2370         JMP .3            NEXT KEY
 2380  .27    LDA #$07          RING BELL
 2390         BNE .26
 2400  *--------------------------------
 2410  CHECK.RESTRICTIONS
 2420         LDA #0
 2430         STA RINDEX        RINDEX = 0
 2440         STA NEW           NEW = FAIL
 2450         STA ANDOR         ANDOR = OR
 2460         STA NOT           NOT = FALSE
 2470  *---FETCH OPERATOR---------------
 2480  .4     LDY RINDEX        IF RINDEX >= RLEN,
 2490         CPY RLEN              THEN QUIT SCAN
 2500         BCC .5            NOT YET
 2510         RTS
 2520  .5     LDA (RSTR),Y      FETCH OPERATOR
 2530         INC RINDEX
 2540  *---DETERMINE OPERATION----------
 2550         CMP #'            IGNORE BLANKS
 2560         BEQ .4
 2570         CMP #'<           < = >, THEN FETCH OPERAND
 2580         BEQ .10
 2590         CMP #'>
 2600         BEQ .10
 2610         CMP #'=
 2620         BEQ .10
 2630         CMP #'A           "AND"
 2640         BEQ .7
 2650         CMP #'O
 2660         BEQ .8
 2670         CMP #'N           "NOT"
 2680         BEQ .9
 2690         JMP AS.SYNERR
 2700  *---AND OPERATOR-----------------
 2710  .7     LDA #'N
 2720         JSR SYNSTR
 2730         LDA #'D
 2740         JSR SYNSTR
 2750         LDA #1            SET AND OPERATOR
 2760         STA ANDOR
 2770         BNE .4            ...ALWAYS
 2780  *---OR OPERATOR------------------
 2790  .8     LDA #'R
 2800         JSR SYNSTR
 2810         LDA #0            SET OR OPERATOR
 2820         STA ANDOR
 2830         BEQ .4            ...ALWAYS
 2840  *---NOT OPERATOR-----------------
 2850  .9     LDA #'O
 2860         JSR SYNSTR
 2870         LDA #'T
 2880         JSR SYNSTR
 2890         LDA #1            SET NOT OPERATOR "TRUE"
 2900         STA NOT
 2910         BNE .4            ...ALWAYS
 2920  *---FETCH OPERAND----------------
 2930  .10    STA ROPR
 2940         LDA #$27          CHECK FOR APOSTROPHE
 2950         JSR SYNSTR
 2960         LDY RINDEX
 2970         LDA (RSTR),Y      GET OPERAND
 2980         STA ROPD
 2990         INC RINDEX
 3000         LDA #$27          ANOTHER APOSTROPHE
 3010         JSR SYNSTR
 3020  *---EVALUATE RELATIONAL OPERATION
 3030         LDA NEW
 3040         STA LAST          LAST = NEW
 3050         LDA #0            NEW = FAIL
 3060         STA NEW
 3070         LDY ROPR          OPERATOR
 3080         LDA KEY           LATEST KEY
 3090         CMP ROPD          COMPARE TO OPERAND
 3100         BEQ .11           THEY ARE EQUAL
 3110         BCC .12           KEY < OPERAND
 3120         CPY #'>           KEY > OPERAND
 3130         BEQ .13           SUCCESS!
 3140         BNE .14           FAIL.
 3150  .11    CPY #'=
 3160         BEQ .13           SUCCESS
 3170         BNE .14           FAIL
 3180  .12    CPY #'<
 3190         BNE .14           FAIL
 3200  .13    LDA #1            FLAG SUCCESS
 3210         STA NEW
 3220  *---PERFORM NOT OPERATION--------
 3230  .14    LDA NOT           IF NOT, TOGGLE NEW
 3240         BEQ .17           NOT NOT
 3250         LDA NEW
 3260         EOR #1
 3270         STA NEW
 3280         LDA #0            CLEAR NOT
 3290         STA NOT
 3300  *---PERFORM AND/OR OPERATION-----
 3310  .17    LDA LAST
 3320         LDY ANDOR
 3330         BEQ .18           OR
 3340         AND NEW           AND
 3350         STA NEW
 3360         JMP .4
 3370  .18    ORA NEW
 3380         STA NEW
 3390         JMP .4
 3400  *--------------------------------
 3410  SYNSTR STA HOLD     SAVE CHAR
 3420  .1     LDY RINDEX
 3430         LDA (RSTR),Y
 3440         INC RINDEX
 3450         CMP #'            IGNORE BLANKS
 3460         BEQ .1
 3470         CMP HOLD
 3480         BEQ .2
 3490         JMP AS.SYNERR
 3500  .2     RTS
 3510  *--------------------------------
 3520  PRINT.FIELD
 3530         LDY FL
 3540  .1     JSR MON.COUT
 3550         DEY
 3560         BNE .1
 3570         RTS
 3580  *--------------------------------
 3590  HOLD   .BS 1
 3600  NOT    .BS 1
 3610  ANDOR  .BS 1
 3620  FL     .BS 1
 3630  NEW    .BS 1
 3640  LAST   .BS 1
 3650  KEY    .BS 1
 3660  BINDEX .BS 1
 3670  RINDEX .BS 1
 3680  ROPR   .BS 1
 3690  ROPD   .BS 1
 3700  *--------------------------------

