home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / forst / extend.s < prev    next >
Encoding:
Text File  |  1993-10-23  |  24.9 KB  |  913 lines
  1. ; EXTRAS: compilation extensions 22/6/90
  2. ; Copyright <C> John Redmond 1989,1990
  3. ; Public domain for non-commercial use.
  4. ;
  5.         section text
  6.         even
  7. ;
  8. maxregs = 6                     ;# register variables allowed
  9. perreg = 8                      ;bytes per register in lookup table
  10. maclen = 31                     ;mask for largest macro
  11. ;
  12. ; system variables and pointers
  13. ;
  14. largnumb: dc.w  0               ;# local arguments
  15. regnumb: dc.w   0               ;# register variables
  16. regargs: dc.w   0               ;# register arguments
  17. frdepth: dc.l   0               ;depth of stack frame
  18. argdpth: dc.l   0               ;base of local args
  19. regoffs: dc.l   0               ;^ regvals
  20. rargptr: dc.l   0               ;^ reg arg params
  21. pushptr: dc.l   regpush
  22. pushval: dc.l   0
  23. toptyp: dc.w    0               ;3=local,2=addrreg,1=datreg on top,else 0
  24. adjust: dc.w    0
  25. lastused: dc.l  1               ;offset (for locals) or last register params
  26. ;
  27. locops: offs    dofrom
  28.         offs    doaddr
  29.         offs    doto
  30.         offs    doaddto
  31.         offs    dofor
  32. ;
  33. regops: offs    regfrom
  34.         offs    strerror        ;no address for a register
  35.         offs    regto
  36.         offs    regaddto
  37.         offs    regfor
  38. ;
  39. ;pop/push/add opcodes for all registers:
  40. ;
  41. ;specialist address registers:
  42.          dc.l   $245e2d0a,$d5c00000                     ;a2
  43.          dc.l   $205e2d08,$d1c00000,$225e2d09,$d3c00000 ;a0,a1
  44.          dc.l   $285e2d0c,$d9c00000,$2a5e2d0d,$dbc00000 ;a4,a5
  45.          dc.l   $2c5e2d0e,$ddc00000,$2e5e2d0f,$dfc00000 ;a6,a7
  46. ;
  47. ;user registers:
  48. regvals: dc.l   $265e2d0b,$d7c00000,$245e2d0a,$d5c00000 ;a3,a2
  49.          dc.l   $2a1e2d05,$da800000,$281e2d04,$d8800000 ;d5,d4
  50.          dc.l   $261e2d03,$d6800000,$241e2d02,$d4800000 ;d3,d2
  51. ;
  52. ;specialist data registers:
  53.          dc.l   $201e2d00,$d0800000,$221e2d01,$d2800000 ;d0,d1
  54.          dc.l   $2c1e2d06,$dc800000,$2e1e2d07,$de800000 ;d6,d7
  55.          dc.l   $241e2d02,$d4800000                     ;d2
  56. ;
  57. ;auto preserving of user registers(a3,a2,d5,d4,d3,d2):
  58. regpush: dc.l   $00000000,$08000010,$0c000030,$0c200430
  59.          dc.l   $0c300c30,$0c381c30,$0c3c3c30           ;popm/pushm
  60. ;
  61. _loc:   push    a0
  62.         bsr     _ifcomp
  63.         bsr     toptypoff
  64.         pop     a0
  65.         lea     locops,a1
  66. loc2:   push    4(a0)           ;value in pfa
  67.         lea     lastused,a2
  68.         move.l  (a6),(a2)       ;save this as the local offset
  69.         move.w  store(pc),d1
  70.         move.l  (a1,d1.w),d1
  71.         jmp     (a5,d1.l)
  72. ;
  73. _reg:   push    a0
  74.         bsr     _ifcomp
  75.         pop     a0
  76.         move.l  4(a0),d0
  77.         push    d0              ;for vectored subroutines
  78.         lea     regvals,a1
  79.         lea     lastused,a2
  80.         move.l  (a1,d0.l),(a2)
  81.         lea     regops,a1
  82.         move.w  store(pc),d1
  83.         move.l  (a1,d1.w),d1
  84.         jmp     (a5,d1.l)
  85. ;
  86. setfrom: lea    store,a0
  87.         clr.w   (a0)
  88.         rts
  89. ;
  90. dofrom: push    #$202c          ;'move.l xx(a4),d0'
  91.         bsr     _comma
  92.         bsr     _comma          ;negative value of xx
  93.         push    #$2d00          ;push d0
  94.         lea     toptyp,a0
  95.         move.w  #3,(a0)         ;local on top of stack
  96.         bra.s   doaddx
  97. ;
  98. _lb:    push    4(a0)           ;value in pfa
  99. doaddr: push    #$41ec          ;lea -xx(a4),a0
  100.         bsr     _comma
  101.         bsr     _comma          ;negative offset
  102.         push    #$2d08          ;push a0
  103. doaddx: bsr     _comma
  104.         bsr     plusedge
  105.         bsr     setfrom         ;default fetch
  106.         rts
  107. ;
  108. doaddto: lea    baddto,a0
  109.         bra     doto1
  110. ;
  111. dofor:  push    #$222c          ;move local to d1 to do value test
  112.         bsr     _comma
  113.         push    (a6)            ;copy the offset
  114.         bsr     _comma
  115.         push    #$6f00          ;BLE (counter must start with pos value)
  116.         bsr     _comma
  117.         pop     -(a7)           ;get the offset out of the way
  118.         bsr     _fmark          ;BLE XXXX
  119.         bsr     _bmark          ;HERE
  120.         push    (a7)+           ;offset
  121.         push    #$53ac          ;'subq.l #1,xx(a4)'
  122.         push    #22             ;balance marker
  123.         push    #0
  124.         bsr     pushlve         ;marker on leave stack
  125.         bsr     setfrom
  126.         bsr     edgeoff
  127.         rts
  128. ;
  129. doto:   lea     bto,a0
  130. doto1:  move.l  #$80002d00,d2
  131.         move.w  #2,d4
  132.         bsr     expand
  133. dotow:  bsr     _comma
  134. dotox:  bsr     edgeoff
  135. dotoy:  bsr     setfrom         ;fetch is default state
  136.         bsr     toptypoff
  137.         rts
  138. ;
  139. whichreg: push  a0              ;^reg opcodes
  140.         moveq.l #2,d1           ;2 = an address register
  141.         cmp.w   #(2*perreg),d0
  142.         blt.s   .wr5
  143.         subq.l  #1,d1           ;1 = a data register
  144. .wr5:   lea     toptyp,a0
  145.         move.w  d1,(a0)
  146.         pop     a0
  147.         rts
  148. ;
  149. toregval: lea   regvals,a0
  150.         pop     d0              ;pop pointer offset
  151.         adda.l  d0,a0
  152.         rts
  153. ;
  154. regfrom: bsr.s  toregval
  155.         bsr     whichreg
  156.         push    (a0)
  157.         bsr     _comma          ;low bytes of long value
  158.         bsr     plusedge
  159.         bsr     setfrom
  160.         rts
  161. ;
  162. regto:  bsr.s   toregval
  163.         move.l  (a0),d0
  164.         move.l  #$80000000,d2   ;1 param no result
  165.         move.w  d0,d2           ;edge
  166.         move.w  #1,d4           ;single word of code (high bytes of d0)
  167. regto1: push    d0
  168.         move.l  a6,a0           ;^code
  169.         bsr     expand
  170.         addq.l  #4,a6           ;clean up stack
  171.         bra     dotox
  172. ;
  173. regaddto: bsr.s toregval
  174.         move.l  #$80002d00,d2   ;1 param no result
  175.         move.l  #$201e0000,d0   ;'pop d0'
  176.         move.w  4(a0),d0        ;addto code
  177.         move.w  #2,d4           ;1 word of code after pop
  178.         bra     regto1
  179. ;
  180. regfor: push    (a6)            
  181.         bsr     toregval
  182.         move.l  (a0),d0
  183.         and.w   #$0f,d0         ;mask out all irrelevant bits
  184.         or.w    #$2200,d0       ;make it a move to d1 to test value
  185.         push    d0
  186.         bsr     _comma
  187.         push    #$6f00
  188.         bsr     _comma
  189.         pop     -(a7)           ;offset
  190.         bsr     _fmark
  191.         bsr     _bmark
  192.         push    (a7)+           ;offset
  193.         bsr     toregval
  194.         move.l  (a0),d0
  195.         and.w   #$0f,d0         ;mask out all irrelevant bits
  196.         or.w    #$5380,d0       ;make it SUBQ.L #1,reg
  197.         push    d0              ;opcode
  198.         push    #21             ;balance marker
  199.         push    #0
  200.         bsr     pushlve         ;marker on leave stack
  201.         bsr     setfrom
  202.         bsr     edgeoff
  203.         bsr     toptypoff
  204.         rts
  205. ;
  206. _next:  bsr     _ifcomp
  207.         pop     d0
  208.         cmp.l   #21,d0
  209.         beq     .reg
  210.         cmp.l   #22,d0
  211.         beq     .loc
  212.         bra     strerror
  213. .reg:   push    (a6)            ;dup opcode on stack
  214.         bsr     _comma          ;'SUBQ.L #1,reg'
  215.         pop     d0
  216.         btst    #3,d0
  217.         beq     .nx5            ;ok if a data register
  218.         and.w   #$0f,d0
  219.         or.w    #$2000,d0       ;'MOVE.L reg,d0'
  220.         push    d0
  221.         bsr     _comma          ;move from addr reg to set flags!
  222. .nx5:   push    #$6E00          ;'BGT'
  223.         bsr     _comma
  224.         bsr     _bresolve
  225.         bsr     _fresolve       ;BEQ from start of loop
  226.         bsr     reslve          ;destination for LEAVEs
  227.         rts
  228. .loc:   bsr     _comma          ;'SUBQ.L #1,xx(a4)
  229.         bsr     _comma          ;negative offset
  230.         bra.s   .nx5
  231. ;
  232. _addr:  moveq   #4,d0
  233.         bra.s   storeit
  234. _to:    moveq   #8,d0
  235.         bra.s   storeit
  236. _addto: moveq   #12,d0
  237.         bra.s   storeit
  238. _for:   moveq   #16,d0
  239. storeit: lea    store,a0
  240.         move.w  d0,(a0)
  241.         rts
  242. ;
  243. bto:    pop     d0
  244.         dc.w    $2940           ;move.l d0,xx(a4)
  245. ;
  246. baddto: pop     d0
  247.         dc.w    $d1ac           ;add.l  d0,xx(a4)
  248. ;
  249. _inc:   lea     adjust,a0
  250.         move.w  #$00d8,(a0)
  251.         rts
  252. ;
  253. _dec:   lea     adjust,a0
  254.         move.w  #$0120,(a0)
  255.         rts
  256. ;
  257. lerror: lea     locerr,a0
  258.         bra     _error
  259. ;
  260. local:  push    #4
  261.         lea     _loc,a0
  262. dolocal: suba.l a5,a0
  263.         push    a0              ;address of generic code
  264.         bsr     header
  265.         bsr     _hcomma         ;code pointer in cfa
  266.         pop     d0              ;local data size
  267.         lea     frdepth,a0      ;depth of stack frame
  268.         sub.l   d0,(a0)         ;space for a new entry
  269.         push    (a0)            ;get depth to stack
  270.         bsr     _hcomma         ;constant value in pfa
  271.         bsr     dolength
  272.         bsr     _immediate
  273.         rts
  274. ;
  275. locsok: cmp.l   #998,4(a6)      ;something really on the stack?
  276.         bne     lerror          ;no parameter count on top
  277.         rts
  278. ;
  279. _locals: bsr.s  locsok
  280.         pop     d0              ;#params
  281. locs1:  push    d0              ;entry point for args
  282. .llp:   pop     d0
  283.         beq.s   .lx
  284.         subq.l  #1,d0
  285.         push    d0
  286.         bsr     local
  287.         bra     .llp
  288. .lx:    rts
  289. ;
  290. reg:    bsr     header
  291.         lea     _reg,a0
  292.         suba.l  a5,a0
  293.         push    a0
  294.         bsr     _hcomma         ;cfa
  295.         lea     regoffs,a0      
  296.         move.l  (a0),a1
  297.         push    a1
  298.         addq.l  #perreg,a1      ;bump pointer
  299.         move.l  a1,(a0)
  300.         bsr     _hcomma         ;regoffs into pfa
  301.         bsr     dolength
  302.         bsr     _immediate
  303.         lea     pushptr,a0
  304.         move.l  (a0),a1
  305.         addq.l  #4,a1           ;advance pointer
  306.         move.l  a1,(a0)
  307.         lea     pushval,a0
  308.         move.l  (a1),(a0)
  309.         rts
  310. ;
  311. _regs:  bsr     locsok
  312.         pop     d0              ;#params
  313.         move.l  d0,d1
  314.         lea     regnumb,a0
  315.         add.w   (a0),d1
  316.         cmp.l   #maxregs,d1
  317.         bhi     lerror          ;too many parameters
  318.         move.w  d1,(a0)         ;update # reg args
  319.         push    d0
  320. rlp:    pop     d0
  321.         beq.s   .rx
  322.         subq.l  #1,d0
  323.         push    d0
  324.         bsr     reg
  325.         bra.s   rlp
  326. .rx:    rts
  327. ;
  328. _args:  bsr     locsok
  329.         pop     d0
  330.         lea     largnumb,a0
  331.         move.w  d0,(a0)         ;save for auto pops
  332.         bsr     locs1           ;continue as for locals
  333.         lea     frdepth,a0
  334.         lea     argdpth,a1
  335.         move.l  (a0),(a1)       ;frame offset for auto pops
  336.         rts
  337. ;
  338. _regargs: bsr   locsok
  339.         pop     d0              ;# reg args
  340.         cmp.l   #maxregs,d0
  341.         bhi     lerror          ;too many parameters
  342.         lea     regnumb,a0
  343.         tst.w   (a0)
  344.         bne     lerror          ;regargs must be declared before regs
  345.         move.w  d0,(a0)
  346.         push    d0
  347.         bsr     rlp
  348.         lea     pushptr,a0
  349.         lea     rargptr,a1
  350.         move.l  (a0),(a1)       ;needed for auto popm
  351.         rts
  352. ;
  353. _locbuff: bsr   _even
  354.         lea     _lb,a0
  355.         bra     dolocal
  356. ;
  357. endlocs: lea    frdepth,a0
  358.         move.l  (a0),d0
  359.         beq.s   .elx            ;if no local stack frame
  360.         push    #$4e5c          ;'unlk a4'
  361.         bsr     _comma
  362. .elx:   lea     pushval,a0
  363.         move.l  (a0),d0
  364.         beq.s   .ely            ;if no regs used
  365.         swap    d0
  366.         push    d0
  367.         push    #$4cdf          ;'popm'
  368.         bsr     _comma
  369.         bsr     _comma
  370. .ely:   rts
  371. ;
  372. kheads: lea     hp,a0
  373.         lea     tothere,a1
  374.         move.l  (a1),d0
  375.         move.l  d0,(a0)         ;delete temporary heads
  376.         add.l   a5,d0
  377.         lea     entry,a0
  378.         move.l  d0,(a0)         ;correct entry point
  379.         rts
  380. ;
  381. pushes: lea     pushval,a0
  382.         move.l  (a0),d0
  383.         beq     .pux            ;if no reg variables
  384.         push    d0
  385.         push    #$48e7          ;'pushm to rstack'
  386.         bsr     _comma
  387.         bsr     _comma
  388.         lea     rargptr,a0
  389.         move.l  (a0),a0
  390.         move.l  (a0),d0
  391.         beq     .pux
  392.         swap    d0
  393.         push    d0
  394.         push    #$4cde          ;'popm from dstack'
  395.         bsr     _comma
  396.         bsr     _comma
  397. .pux:   rts
  398. ;
  399. frame:  lea     frdepth,a0
  400.         move.l  (a0),d0         ;get stack frame size
  401.         beq     .frx
  402.         push    d0
  403.         push    #$4e54          ;'link a4,#xxxx'
  404.         bsr     _comma
  405.         bsr     _comma          ;frame size
  406. .frx:   rts
  407. ;
  408. getargs: lea    largnumb,a0
  409.         move.w  (a0),d0
  410.         beq     .gax
  411.         push    d0              ;# args
  412.         lea     argdpth,a0
  413.         move.l  (a0),d0         ;where to start loading args
  414.         push    d0
  415.         push    #$41ec          ;'lea xx(a4),a0'
  416.         bsr     _comma
  417.         bsr     _comma          ;a0 points to args in stack frame
  418. .galp:  pop     d0
  419.         beq     .gax
  420.         subq.l  #1,d0
  421.         push    d0
  422.         push    #$20de          ;'pop (a0)+'
  423.         bsr     _comma
  424.         bra     .galp
  425. .gax:   rts
  426. ;
  427. _cbra:  bsr     _bra
  428.         push    #998            ;balance marker
  429.         rts
  430. ;
  431. _cket:  bsr     pushes
  432.         bsr     frame
  433.         bsr     getargs
  434.         pop     d0
  435.         cmp.l   #998,d0
  436.         bne     strerror
  437.         bsr     _ket
  438.         rts
  439. ;
  440. regdrop: moveq.l #2,d0
  441.         bra.s   ld5
  442. locdrop: moveq.l #6,d0
  443. ld5:    lea     cp,a2
  444.         sub.l   d0,(a2)
  445.         lea     edge,a2
  446.         subq.w  #1,(a2)
  447.         lea     edges,a2
  448.         move.l  (a2)+,(a2)
  449.         rts
  450. ;
  451. kpreg:  lea     lastused,a0     
  452.         move.w  (a0),d0         ;pop opcode
  453.         and.w   #$0fc0,d0
  454.         or.w    #$2008,d0
  455.         push    d0              ;'move.l a0,reg'
  456.         bsr     _comma
  457.         rts
  458. ;
  459. kploc:  push    #$2948          ;'move.l a0,xx(a4)'
  460.         bsr     _comma
  461.         lea     lastused,a2
  462.         push    (a2)
  463.         bsr     _comma
  464.         rts
  465. ;
  466. ptchptr: bsr    tocode          ;returned in a1
  467.         subq.l  #2,a1           ;point to word to be patched
  468.         move.w  (a1),d0
  469.         move.w  (a0),d1
  470.         and.w   d4,d1
  471.         or.w    d1,d0           ;convert to a fetch pointed to by reg
  472.         move.w  d0,(a1)         ;replace code
  473.         rts
  474. ;
  475. ftchadj: moveq.l #$38,d3        ;mask for fetch inc/dec 
  476.         bra.s   ptchadj
  477. storadj: move.l #$01c0,d3       ;mask for fetch inc/dec 
  478. ptchadj: lea    adjust,a0
  479.         move.w  (a0),d1
  480.         clr.w   (a0)            ;clear adjust field
  481.         move.w  d1,d2           ;save the flag
  482.         beq     .pmx
  483.         bsr     tocode
  484.         subq.l  #2,a1           ;point to code to be patched
  485.         move.w  (a1),d0
  486.         and.w   d3,d1
  487.         not.w   d3              ;reverse the mask
  488.         and.w   d3,d0           ;mask out old EA field
  489.         or.w    d1,d0           ;insert new field
  490.         move.w  d0,(a1)         ;replace the patched opcode
  491.         tst.w   d2              ;return the flag
  492. .pmx:   rts
  493. ;
  494. useloc: bsr     locdrop
  495.         push    #$206c          ;'move xx(a4),a0'
  496.         bsr     _comma
  497.         lea     lastused,a2
  498.         push    (a2)            ;get last offset
  499.         bsr     _comma          ;compile it
  500.         rts
  501. ;
  502. fetchnorm: pop  a0              ;^code
  503.         bsr     expand
  504.         bsr     oneon
  505.         bsr     setfrom         ;fetch is default state
  506.         bsr     toptypoff
  507.         rts
  508. ;
  509. _fetchopt: move.l -4(a0),d2     ;expansion flags
  510.         move.l  4(a0),a0        ;pfa has offset of address
  511.         adda.l  a5,a0
  512.         push    a0              ;^code
  513.         bsr     stateat
  514.         beq     do_op           ;execute if not compiling
  515.         move.l  d2,d4
  516.         swap    d4
  517.         and.w   #maclen,d4      ;mask out macro length
  518.  
  519.         lea     toptyp,a1
  520.         move.w  (a1),d0
  521.         beq     fetchnorm       ;no local on top
  522.  
  523.         clr.w   (a1)
  524.         cmp.w   #3,d0           ;non-register local?
  525.         beq     .locptr
  526.         cmp.w   #2,d0           ;an address register?
  527.         beq     .addreg
  528.         bra     .datreg         ;must be a data register
  529.         
  530. .addreg: bsr    regdrop
  531.         move.w  #$ffff,d2       ;no edge to look for
  532.         pop     a0              ;^code
  533.         addq.l  #2,a0           ;bump code pointer
  534.         subq.l  #2,d4           ;skip pop and drop push
  535.         bsr     inline
  536.         
  537.         lea     (lastused+2),a0 ;ptchptr needs this
  538.         moveq.l #7,d4           ;mask for push opcode
  539.         bsr     ptchptr
  540.         bsr     ftchadj
  541.         bra.s   .finish
  542.         
  543. .datreg: pop    a0
  544.         subq.l  #1,d4           ;drop final push
  545.         bsr     inline
  546.         
  547.         bsr     ftchadj
  548.         tst.w   d2
  549.         beq.s   .finish
  550.         bsr     kpreg
  551.  
  552. .finish: push   #$2d00          ;'push d0'
  553.         bsr     _comma
  554. .fox:   bsr     oneon           ;return one edge
  555.         rts
  556.         
  557. .locptr: bsr    useloc          
  558.         move.w  #$ffff,d2       ;no edge to look for
  559.         pop     a0              ;code to copy
  560.         addq.l  #2,a0
  561.         subq.w  #2,d4           ;one word less at each end
  562.         bsr     inline
  563.  
  564.         bsr     ftchadj
  565.         beq.s   .finish
  566.         
  567.         bsr     kploc
  568.         bra.s   .finish
  569.  
  570. .doit:  pop     a0
  571.         jsr     (a0)
  572.         rts
  573.  
  574. storenorm: pop  a0              ;^code
  575.         bsr     expand
  576.         bra     dotox
  577. ;
  578. _storeopt: move.l -4(a0),d2     ;expansion flags
  579.         move.l  4(a0),a0        ;pfa has offset of address
  580.         adda.l  a5,a0
  581.         push    a0              ;^code
  582.         bsr     stateat
  583.         beq     do_op           ;execute if not compiling
  584.  
  585.         move.l  d2,d4
  586.         swap    d4
  587.         and.w   #maclen,d4      ;mask out macro length
  588.  
  589.         lea     toptyp,a1
  590.         move.w  (a1),d0
  591.         beq     storenorm       ;no local on top
  592.  
  593.         clr.w   (a1)            ;reset flag
  594.         cmp.w   #3,d0
  595.         beq     .locptr
  596.         cmp.w   #2,d0           ;an address register just pushed?
  597.         beq     .addreg         ;no special pointer used
  598.         bra     .datreg         ;must be a data register
  599.         
  600. .addreg: bsr    regdrop
  601.         move.w  #$2d00,d2       ;'push d0' edge to look for
  602.         pop     a0
  603.         addq.l  #2,a0           ;bump code pointer
  604.         subq.l  #1,d4           ;less code needed
  605.         bsr     inline
  606.  
  607.         lea     lastused,a0     ;ptchptr needs this
  608.         move.l  #$0e00,d4       ;mask for pop opcode
  609.         bsr     ptchptr
  610.         bsr     storadj
  611.                 
  612. .finish: bsr    edgeoff         ;no edges left
  613.         rts
  614.         
  615. .datreg: pop    a0
  616.         bsr     inline
  617.         bsr     storadj
  618.         beq.s   .finish         ;no register save needed
  619.         
  620.         bsr     kpreg
  621.         bra.s   .finish
  622.         
  623. .locptr: bsr    useloc
  624.         move.w  #$ffff,d2       ;no edge to look for
  625.         pop     a0
  626.         addq.l  #2,a0           ;bump code pointer
  627.         subq.l  #1,d4           ;less code needed
  628.         bsr     inline
  629.         
  630.         bsr     storadj
  631.         beq.s   .finish         ;no register save needed
  632.  
  633.         bsr     kploc
  634.         bra.s   .finish
  635.                 
  636. do_op:  pop     a0
  637.         jsr     (a0)
  638.         rts
  639. ;
  640. _notopt: move.l -4(a0),d2       ;expansion flags
  641.         move.l  4(a0),a0        ;pfa has offset of address
  642.         adda.l  a5,a0
  643.         push    a0              ;^code
  644.         bsr     stateat
  645.         beq     do_op           ;execute if not compiling
  646.  
  647.         pop     a0              ;code address
  648.         lea     mcro,a1
  649.         tst.l   (a1)            ;just expanded a macro?
  650.         bne.s   .no5
  651.         bsr     mustcall        ;compile a call
  652.         rts
  653. ;
  654. .no5:   lea     edge,a1
  655.         cmp.w   #99,(a1)        ;a test just performed?
  656.         bne.s   .no6
  657.         
  658.         bsr     tocode          ;returned in a1
  659.         eori.w  #$0100,-8(a1)   ;invert the test logic
  660.         rts
  661.  
  662. .no6:   bsr     call
  663.         bra     dotoy
  664. ;
  665. xcol:   lea     todepth,a0      ;local flag off
  666.         clr.w   (a0)
  667.         lea     pushval,a0
  668.         clr.l   (a0)            ;no regs being used
  669.         lea     frdepth,a0
  670.         clr.l   (a0)            ;initialise stack frame depth
  671.         lea     regoffs,a0      ;remember last address reg used
  672.         clr.l   (a0)
  673.         lea     adjust,a0       ;any inc/dec of address register
  674.         clr.w   (a0)
  675.         lea     regpush,a1
  676.         lea     pushptr,a0
  677.         move.l  a1,(a0)         ;initialize register push values
  678.         lea     rargptr,a0
  679.         move.l  a1,(a0)         ;initialize register push values
  680.         lea     largnumb,a0
  681.         clr.w   (a0)            ;number of local arguments passed
  682.         lea     regnumb,a0
  683.         clr.w   (a0)            ;number of register arguments passed
  684.         bsr     edgeoff
  685.         bsr     setfrom         ;default fetch from stack frame
  686.         bsr     toptypoff
  687.         rts
  688. ;
  689. _xcolon: bsr    xcol
  690.         bsr     _colon
  691.         lea     hp,a0
  692.         lea     tothere,a1
  693.         move.l  (a0),(a1)       ;offset of start of temporary heads
  694.         rts
  695. ;
  696. _xsemi: bsr     endlocs
  697.         bsr     kheads
  698.         bsr     _semicolon
  699.         rts
  700. ;
  701. _xexit: bsr     endlocs
  702.         bsr     _exit
  703.         rts
  704. ;
  705. _xdoes: bsr     endlocs
  706.         bsr     xcol
  707.         bsr     _does
  708.         rts
  709. ;
  710. _gemdos:push    d2
  711.         push    a2
  712.         trap    #1
  713.         pop     a2
  714.         pop     d2
  715.         rts
  716. ;
  717. _xbdos: push    d2
  718.         push    a2
  719.         trap    #2
  720.         pop     a2
  721.         pop     d2
  722.         rts
  723. ;
  724. _bios:  push    d2
  725.         push    a2
  726.         trap    #14
  727.         pop     a2
  728.         pop     d2
  729.         rts
  730. ;
  731. _xbios: pop     d2
  732.         push    a2
  733.         trap    #13
  734.         pop     a2
  735.         pop     d2
  736.         rts
  737. ;
  738.         section data
  739.         even
  740. ;
  741. ;local definitions group:
  742. ;
  743.         dc.b    $83,'AR','G'!$80
  744.         ptrs    _args,16
  745. ;
  746.         dc.b    $84,'ARGS',$a0          ;synonym for arg
  747.         ptrs    _args,18
  748. ;
  749.         dc.b    $86,'REGARG',$a0
  750.         ptrs    _regargs,20
  751. ;
  752.         dc.b    $87,'REGARG','S'!$80    ;synonym for regarg
  753.         ptrs    _regargs,20
  754. ;
  755.         dc.b    $85,'LOCA','L'!$80
  756.         ptrs    _locals,18
  757. ;
  758.         dc.b    $86,'LOCALS',$a0        ;synonym for local
  759.         ptrs    _locals,20
  760. ;
  761.         dc.b    $83,'RE','G'!$80
  762.         ptrs    _regs,16
  763. ;
  764.         dc.b    $84,'REGS',$a0
  765.         ptrs    _regs,18
  766. ;
  767.         dc.b    $c7,'LOCBUF','F'!$80
  768.         ptrs    _locbuff,20
  769. ;
  770.         dc.b    $c1,'{'!$80
  771.         ptrs    _cbra,14
  772. ;
  773.         dc.b    $81,'}'!$80
  774.         ptrs    _cket,14
  775. ;
  776. ;user words for locals:
  777. ;
  778.         dc.b    $c2,'TO',$a0
  779.         ptrs    _to,16
  780. ;
  781.         dc.b    $c5,'ADDT','O'!$80
  782.         ptrs    _addto,18
  783. ;
  784.         dc.b    $c4,'ADDR',$a0
  785.         ptrs    _addr,18
  786. ;
  787.         dc.b    $c3,'FO','R'!$80        ;loop start
  788.         ptrs    _for,16
  789. ;
  790.         dc.b    $c4,'NEXT',$a0          ;loop end
  791.         ptrs    _next,18
  792. ;
  793.         dc.b    $c3,'IN','C'!$80
  794.         ptrs    _inc,16
  795. ;
  796.         dc.b    $c3,'DE','C'!$80
  797.         ptrs    _dec,16
  798. ;
  799. ;enhanced definitions of compilation words:
  800. ;
  801.         dc.b    $c1,';'!$80
  802.         ptrs    _xsemi,14
  803. ;
  804.         dc.b    $81,':'!$80
  805.         ptrs    _xcolon,14
  806. ;
  807.         dc.b    $c4,'EXIT',$a0
  808.         ptrs    _xexit,18
  809. ;
  810.         dc.b    $c5,'DOES','>'!$80
  811.         ptrs    _xdoes,18
  812. ;
  813. ;direct access to processor registers:
  814. ;
  815.         dc.b    $c2,'A0',$a0
  816.         dc.l    0
  817.         offs    _reg
  818.         dc.l    -(6*perreg)
  819.         dc.w    16
  820. ;
  821.         dc.b    $c2,'A1',$a0
  822.         dc.l    0
  823.         offs    _reg
  824.         dc.l    -(5*perreg)
  825.         dc.w    16
  826. ;
  827.         dc.b    $c2,'A2',$a0
  828.         dc.l    0
  829.         offs    _reg
  830.         dc.l    -(7*perreg)
  831.         dc.w    16
  832. ;
  833.         dc.b    $c2,'A4',$a0
  834.         dc.l    0
  835.         offs    _reg
  836.         dc.l    -(4*perreg)
  837.         dc.w    16
  838. ;
  839.         dc.b    $c2,'A5',$a0
  840.         dc.l    0
  841.         offs    _reg
  842.         dc.l    -(3*perreg)
  843.         dc.w    16
  844. ;
  845.         dc.b    $c2,'A6',$a0
  846.         dc.l    0
  847.         offs    _reg
  848.         dc.l    -(2*perreg)
  849.         dc.w    16
  850. ;
  851.         dc.b    $c2,'A7',$a0
  852.         dc.l    0
  853.         offs    _reg
  854.         dc.l    -(perreg)
  855.         dc.w    16
  856. ;
  857.         dc.b    $c2,'D0',$a0
  858.         dc.l    0
  859.         offs    _reg
  860.         dc.l    6*perreg
  861.         dc.w    16
  862. ;
  863.         dc.b    $c2,'D1',$a0
  864.         dc.l    0
  865.         offs    _reg
  866.         dc.l    7*perreg
  867.         dc.w    16
  868. ;
  869.         dc.b    $c2,'D6',$a0
  870.         dc.l    0
  871.         offs    _reg
  872.         dc.l    8*perreg
  873.         dc.w    16
  874. ;
  875.         dc.b    $c2,'D7',$a0
  876.         dc.l    0
  877.         offs    _reg
  878.         dc.l    9*perreg
  879.         dc.w    16
  880. ;
  881.         dc.b    $c2,'D2',$a0
  882.         dc.l    0
  883.         offs    _reg
  884.         dc.l    10*perreg
  885.         dc.w    16
  886. ;
  887.         dc.b    $c2,'SP',$a0
  888.         dc.l    0
  889.         offs    _reg
  890.         dc.l    -(2*perreg)
  891.         dc.w    16
  892. ;
  893.         dc.b    $c2,'RP',$a0
  894.         dc.l    0
  895.         offs    _reg
  896.         dc.l    -(perreg)
  897.         dc.w    16
  898. ;
  899. ; trap group:
  900. ;
  901.         dc.b    $86,'GEMDOS',$a0
  902.         mptrs   _gemdos,noedge,5,0,20
  903. ;
  904.         dc.b    $85,'XBDO','S'!$80
  905.         mptrs   _xbdos,noedge,5,0,18
  906. ;
  907.         dc.b    $85,'XBIO','S'!$80
  908.         mptrs   _xbios,noedge,5,0,18
  909. ;
  910.         dc.b    $84,'BIOS',$a0
  911.         mptrs   _bios,noedge,5,0,18
  912. ;
  913.