home *** CD-ROM | disk | FTP | other *** search
/ The Best of Mecomp Multimedia 2 / MECOMP-CD-II.iso / amiga / emulation / qlsource / romsrc / jan / jan_asm
Encoding:
Text File  |  1992-01-07  |  11.9 KB  |  557 lines
  1.     SECTION    JAN
  2.  
  3. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  4. ; JAN_asm - directory device driver for JANUS IBM interface
  5. ;     - last modified 07/01/92
  6.  
  7. ; Directory device driver for the JANUS IBM interface for use
  8. ; with the TURBO-PASCAL program QLDISK
  9.  
  10. ; This device driver is very simple!
  11.  
  12. ; More sofisticated software would make use of the slave
  13. ; blocks. But this Program was written within three weeks
  14. ; evenings (together with the TURBO PASCAL part on the IBM).
  15.  
  16. ; It works, that's all !
  17.  
  18.  
  19. ; QDOS-Amiga sources by Rainer Kowallik
  20.  
  21. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  22. BASE:
  23.     DC.L    $4AFB0001    ; ROM recognition code
  24.     DC.W    FNTAB-BASE
  25.     DC.W    INIT-BASE
  26.     DC.B    0,20,'JANus device driver',$A
  27.  
  28. FNTAB    DC.W    5        ; 5 procedures
  29.     DC.W    CHDIR-*
  30.     DC.B    5,'CHDIR'
  31.     DC.W    SHODIR-*
  32.     DC.B    6,'SHODIR',0
  33.     DC.W    MKDIR-*
  34.     DC.B    5,'MKDIR'
  35.     DC.W    RMDIR-*
  36.     DC.B    5,'RMDIR'
  37.     DC.W    JAN_USE-*
  38.     DC.B    7,'JAN_USE'
  39.     DC.W    0
  40.     DC.W    0
  41.     DC.W    0
  42.  
  43. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  44. INIT:
  45.     movem.l     a0/a3,-(a7)    ;*/mend
  46.  
  47. ; first we try to find the Buffer address of the Dual ported RAM
  48.  
  49.     MOVE.L    #$910000,A2    ; highest possible address
  50.     MOVE.L    #$100000,D0    ; decrement for searching
  51.     MOVE.L    #$210000,D1    ; lowest possible address
  52. SEA_JAN:
  53.     SUB.L    D0,A2
  54.     CMP.W    #$4AFB,(A2)    ; test for QDOS identifier
  55.     BEQ.S    JANFOUND
  56.     CMP.L    A2,D1        ; give up ?
  57.     BNE.S    SEA_JAN
  58.     BRA    NOTFOUND
  59. JANFOUND:
  60.     LEA    DPRAM(PC),A3    ; (changed to LEA(PC) - MJS)
  61.     MOVE.L    A2,(A3)        ; save this address
  62.     MOVE.B    #$AA,(A2)    ; signal QDOS request to IBM
  63. ;
  64.     MOVEQ    #$18,D0        ; MT.ALCHP
  65.     MOVEQ    #$42,D1        ; We need some memory
  66.     MOVEQ    #0,D2        ; owned by job 0
  67.     TRAP    #1
  68.     TST.L    D0
  69.     BNE.S    ERR_EXIT
  70.     LEA    $1C(A0),A3    ; start filling linkage
  71.                 ; block
  72.     LEA    FS_JAN(PC),A2    ; I/O routine (changed to
  73.                 ; LEA(PC) - MJS)
  74.     MOVE.L    A2,(A3)+     ; at $1C
  75.     LEA    JAN_OPEN(PC),A2    ; Open
  76.     MOVE.L    A2,(A3)+     ; at $20
  77.     LEA    JAN_CLOSe(PC),A2    ; close
  78.     MOVE.L    A2,(A3)+     ; at $24
  79.     LEA    JAN_SERV(PC),A2    ; forced slaving
  80.     MOVE.L    A2,(A3)+     ; at $28
  81.     ADDQ.L    #8,A3        ; next two long words are
  82.                 ; reserved
  83.     LEA    JAN_FORMat(PC),A2 ; Format routine
  84.     MOVE.L    A2,(A3)+     ; at $34
  85.     MOVE.L    #$428,(A3)+    ; length of physical def.
  86.                 ; block at $38
  87.     MOVE.W    #3,(A3)+     ; length of drive name at
  88.                 ; $3C
  89.     MOVE.L    #$4A414E00,(A3)+    ; drive name 'JAN' at $3E
  90.     LEA    $18(A0),A0    ; link address
  91.     MOVEQ    #$22,D0        ; MT.LDD link in Directory
  92.                 ; device driver
  93.     TRAP    #1
  94.  
  95. ERR_EXIT:
  96.     movem.l    (a7)+,a0/a3    ;*/mend
  97.     RTS
  98.  
  99. DPRAM    DS.L    2
  100.  
  101. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  102. ; if the IBM server  was not found, tell this to the USER
  103.  
  104. NOTFOUND:
  105.     LEA    NF_MESS(PC),A1    ; (changed to LEA(PC) - MJS)
  106.     MOVE.W    (A1)+,D2     ; number of bytes to send
  107.     BSR    IOSSTRG
  108.     MOVEQ    #8,D0        ; MT.SUSJB
  109.     MOVEQ    #-1,D1        ; me
  110.     SUBA.L    A1,A1        ; no flag
  111.     MOVEQ    #100,D3        ; 2 seconds to read the
  112.                 ; message
  113.     TRAP    #1
  114.     BRA.S    ERR_EXIT
  115.  
  116. NF_MESS    DC.B    0,36,'!!!! QLDISK not running on IBM !!!!',$A
  117.  
  118. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  119. ; here we handle those routines, which are not actually used
  120.  
  121. JAN_SERV:
  122.     RTS
  123. JAN_FORMat:
  124.     MOVEQ    #-19,D0        ; not implemented yet
  125.     RTS
  126.  
  127. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  128. INIDPRAM:
  129.     MOVE.L    DPRAM,A2     ; get start of dualported
  130.                 ; RAM
  131.     CMP.B    #$55,(A2)    ; IBM ready ?
  132.     BNE.S    ERR_NC
  133.     MOVE.B    D0,2(A2)     ; tell IBM the function
  134.                 ; number
  135.     RTS
  136. ERR_NC:
  137.     ADDQ.L    #4,A7
  138.     MOVEQ    #-1,D0
  139.     RTS
  140. IBM_EXIT:
  141.     MOVE.B    #$AA,(A2)
  142. IBM_WAIT:
  143.     NOP    ; Wait a bit
  144.     NOP
  145.     NOP
  146.     NOP
  147.     CMP.B    #$55,(A2)    ; IBM ready ?
  148.     BNE.S    IBM_WAIT
  149.     MOVEQ    #0,D0
  150.     MOVE.B    1(A2),D0     ; get error flag
  151.     TST.B    D0
  152.     BEQ.S    IBMEXITX
  153.     OR.L    #$FFFFFF00,D0    ; extend error to negative
  154.                 ; long
  155. IBMEXITX:
  156.     RTS
  157.  
  158. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  159. ;           I/O routines
  160. ; A0 points to the channel definition block
  161.  
  162. FS_JAN    ; I/O for JANus driver
  163.     BSR    INIDPRAM     ; get address of dual ported
  164.                 ; RAM ...
  165.     MOVE.B    $1F(A0),4(A2)    ; set File number for
  166.                 ; operation
  167.     CMP.B    #1,D0        ; IO.FBYTE ?
  168.     BEQ    IO_FBYTE
  169.     CMP.B    #2,D0        ; IO.FLINE ?
  170.     BEQ    IO_FLINE
  171.     CMP.B    #3,D0        ; IO.FSTRG ?
  172.     BEQ    IO_FSTRG
  173.     CMP.B    #5,D0        ; IO.SBYTE ?
  174.     BEQ    IO_SBYTE
  175.     CMP.B    #7,D0        ; IO.SSTRG ?
  176.     BEQ    IO_SSTRG
  177.     CMP.B    #$42,D0        ; FS.POSAB ?
  178.     BEQ    FS_POSAB
  179.     CMP.B    #$43,D0        ; FS.POSRE ?
  180.     BEQ    FS_POSRE
  181.     CMP.B    #$45,D0        ; FS.MDINF ?
  182.     BEQ    FS_MDINF
  183.     CMP.B    #$46,D0        ; FS.HEADS ?
  184.     BEQ    FS_HEADS
  185.     CMP.B    #$47,D0        ; FS.HEADR ?
  186.     BEQ    FS_HEADR
  187.     CMP.B    #$48,D0        ; FS.LOAD ?
  188.     BEQ    FS_LOAD
  189.     CMP.B    #$49,D0        ; FS.SAVE ?
  190.     BEQ    FS_SAVE
  191.     BRA    IBM_EXIT     ; The other functions don't
  192.                 ; need parameters
  193. IO_FBYTE:
  194.     BSR    IBM_EXIT
  195.     MOVE.B    6(A2),D1     ; get byte
  196.     TST.B    D0        ; set flags on error
  197.     RTS
  198. IO_FLINE:
  199. IO_FSTRG:
  200.     MOVE.W    D2,6(A2)     ; number of  bytes to fetch
  201.     BSR    IBM_EXIT
  202.     LEA    6(A2),A3
  203.     MOVEQ    #0,D1        ; reset number of bytes
  204.                 ; fetched
  205.     MOVE.W    (A3)+,D1     ; get number of bytes
  206.     MOVE.W    D1,D7
  207. CPY_IOFS:
  208.     MOVE.B    (A3)+,(A1)+    ; copy line to buffer
  209.     DBRA    D7,CPY_IOFS
  210.     TST.B    D0        ; set flags on error
  211.     RTS
  212. IO_SBYTE:
  213.     MOVE.B    D1,6(A2)     ; put byte into buffer
  214.     BRA    IBM_EXIT
  215. IO_SSTRG:
  216.     MOVE.W    D2,D1        ; assume, we are sending all
  217.                 ; bytes
  218.     MOVE.W    D2,D7
  219.     MOVE.W    D2,6(A2)     ; tell length of string to
  220.                 ; IBM
  221.     LEA    8(A2),A3     ; get string body
  222. CPY_IOSS:
  223.     MOVE.B    (A1)+,(A3)+    ; copy string to send
  224.     DBRA    D7,CPY_IOSS
  225.     BRA    IBM_EXIT
  226. FS_POSAB:
  227. FS_POSRE:
  228.     MOVE.L    D1,6(A2)     ; write offset or absolute
  229.                 ; pointer to IBM
  230.     BSR    IBM_EXIT
  231.     MOVE.L    6(A2),D1     ; get new file position
  232.     TST.B    D0        ; set flags on error
  233.     RTS
  234. FS_MDINF:
  235.     BSR    IBM_EXIT
  236.     MOVE.L    6(A2),D1     ; get empty/good sectors
  237.     MOVEQ    #10,D2        ; number of bytes of Medium
  238.                 ; name
  239.     LEA    $A(A2),A5
  240. CPY_MDI:
  241.     MOVE.B    (A5)+,(A1)+
  242.     DBRA    D2,CPY_MDI
  243.     TST.B    D0
  244.     RTS
  245. FS_LOAD:
  246.     MOVE.L    D2,D7        ; length of file
  247.     MOVE.B    #$AA,(A2)    ; start transfer
  248. LOA_512:
  249.     BSR    WT_IBM5
  250.     CMP.L    #512,D7
  251.     BLT.S    CPY_LREM
  252. CPY_L512:
  253.     MOVE.L    (A5)+,(A1)+
  254.     DBRA    D5,CPY_L512
  255.     MOVE.B    #$AA,5(A2)    ; signal 'ready' to IBM
  256.     SUB.L    #512,D7
  257.     BRA    LOA_512
  258.     BSR    WT_IBM5
  259. CPY_LREM:
  260.     SUBQ.L    #1,D7
  261.     BMI.S    TSTD0RTS
  262.     MOVE.B    (A5)+,(A1)+    ; copy remainding bytes
  263.     BRA.S    CPY_LREM
  264. TSTD0RTS:
  265.     MOVE.B    #$AA,5(A2)    ; signal 'ready' to IBM
  266.     BRA    IBM_WAIT
  267. WT_IBM5:
  268.     NOP
  269.     NOP
  270.     NOP
  271.     NOP
  272.     NOP
  273.     NOP
  274.     CMP.B    #$55,5(A2)    ; IBM ready ?
  275.     BNE.S    WT_IBM5
  276.     LEA    6(A2),A5     ; get buffer start
  277.     MOVE.W    #127,D5
  278.     RTS
  279. FS_SAVE:
  280.     MOVE.L    D2,6(A2)     ; tell IBM length of file
  281.     MOVE.L    D2,D7        ; length of file
  282.     MOVE.B    #$AA,(A2)    ; initialize transfer
  283. SAV_512:
  284.     BSR    WT_IBM5
  285.     CMP.L    #512,D7
  286.     BLT.S    CPY_SREM
  287. CPY_S512:
  288.     MOVE.L    (A1)+,(A5)+
  289.     DBRA    D5,CPY_S512
  290.     MOVE.B    #$AA,5(A2)    ; signal 'ready' to IBM
  291.     SUB.L    #512,D7
  292.     BRA    SAV_512
  293.     BSR    WT_IBM5
  294. CPY_SREM:
  295.     SUBQ.L    #1,D7
  296.     BMI.S    TSTD0RTS
  297.     MOVE.B    (A1)+,(A5)+    ; copy remainding bytes
  298.     BRA.S    CPY_SREM
  299. FS_HEADR:
  300.     BSR    IBM_EXIT     ; read header
  301.     MOVE.L    D2,D1        ; length of file header read
  302.     MOVE.L    D2,D7        ; assume, its OK
  303.     LEA    6(A2),A5     ; Get dual ported buffer
  304.     BRA    CPY_LREM     ; OK, bad style, but it
  305.                 ; works !
  306. FS_HEADS:
  307.     MOVEQ    #14,D1        ; this will be the correct
  308.                 ; length
  309.     MOVEQ    #14,D7        ; counter
  310.     LEA    6(A2),A5     ; Get dual ported buffer
  311.     BSR    CPY_SREM     ; again bad style...
  312.     BRA    IBM_EXIT     ; the rest will be done by
  313.                 ; the IBM
  314.  
  315. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  316. ;        OPEN routine
  317. ; A0 points to the channel definition block
  318. ; A1 points to the physical definition block
  319. ; A3 points to the assumed basse of the linkage block
  320. ; DELETE is performed if the file access key $1C(A0) is negative
  321.  
  322. FNUMS    DC.L    0        ; here we store the
  323.                 ; filenumber in use
  324. JAN_OPEN ; open microdrive channel
  325.     MOVE.B    $1C(A0),D0    ; get access mode
  326.     OR.B    #$80,D0        ; signal OPEN call
  327.     BSR    INIDPRAM     ; get address of dual ported
  328.                 ; RAM...
  329.     MOVE.B    #0,1(A2)     ; reset error flag from last
  330.                 ; call
  331.     LEA    $32(A0),A5    ; point to file name
  332.     LEA    6(A2),A4     ; point to PASCAL string for
  333.                 ; name
  334.     MOVE.W    (A5)+,D0     ; get length of name
  335.     MOVE.B    D0,(A4)+
  336. WRFNAM1    ; copy file name
  337.     MOVE.B    (A5)+,(A4)+
  338.     DBRA    D0,WRFNAM1
  339.     MOVE.W    #$FF,D0        ; dummy file number
  340.     TST.B    $1C(A0)        ; only delete call ?
  341.     BMI    IBM_EXIT
  342.     LEA    FNUMS(PC),A5    ; now find the next free
  343.                 ; filenumber
  344.                  ; (changed to LEA(PC) - MJS)
  345.     MOVE.L    (A5),D1
  346.     CMP.L    #-1,D1        ; all numbers used ?
  347.     BEQ    ERR_IU
  348.     MOVEQ    #-1,D0
  349. FFNUM    ADDQ.L    #1,D0
  350.     BTST    D0,D1
  351.     BNE.S    FFNUM
  352.     BSET    D0,D1        ; mark filenumber as used
  353.     MOVE.L    D1,(A5)
  354. IBM_OPEN:
  355.     MOVE.B    D0,4(A2)     ; give filenumber to IBM
  356.     MOVE.B    #$AA,(A2)    ; let the IBM do its work
  357.     MOVE.W    D0,$1E(A0)    ; store filenumber to
  358.                 ; channel def. block
  359.     BSR    IBM_WAIT     ; handshake and error
  360.                 ; handling
  361.     TST.B    D0        ; any errors ?
  362.     BEQ.S    RET
  363.     MOVE.W    $1E(A0),D2    ; restore file number
  364.     MOVE.L    (A5),D1
  365.     BCLR    D2,D1        ; reset usage
  366.     MOVE.L    D1,(A5)        ; and save this
  367.     TST.B    D0
  368. RET    RTS
  369.  
  370. ERR_IU    MOVEQ    #-9,D0
  371.     RTS
  372.  
  373. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  374. ;              CLOSE routine
  375. ; A0 points to the channel definition block
  376. ; A3 points  to the device driver definition block
  377.  
  378. JAN_CLOSe ; channel close for Microdrive device driver
  379.     MOVE.B    #$90,D0        ; signal CLOSE   call to IBM
  380.     BSR    INIDPRAM     ; get address of dual ported
  381.                 ; RAM ...
  382.     MOVE.W    $1E(A0),D0    ; restore file number
  383.     LEA    FNUMS(PC),A5    ; (changed to LEA(PC) - MJS)
  384.     MOVE.L    (A5),D1        ; get numbers of files in
  385.                 ; use
  386.     BCLR    D0,D1        ; reset actual file number
  387.     MOVE.L    D1,(A5)
  388.     MOVE.B    D0,4(A2)     ; tell IBM, which file
  389.                 ; number to close
  390.     BSR    GETTIME
  391.     MOVE.L    D1,6(A2)     ; give QDOS time to  IBM
  392.     BSR    IBM_EXIT     ; Let  IBM close    the file
  393.     MOVE.L    A0,-(A7)     ; clean up
  394.     LEA    $18(A0),A0    ; Link to next file system
  395.                 ; channel
  396.     LEA    $140(A6),A1    ; pointer to list of file
  397.                 ; channel defs
  398.     BSR    MT_UNLNK
  399.     MOVE.L    (A7)+,A0
  400.     BRA    MM_RECHP
  401.  
  402. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  403. MT_UNLNK:
  404.     MOVE.W    $D4,-(A7)
  405.     CLR.W    -(A7)
  406.     RTS
  407.  
  408. MM_RECHP:
  409.     MOVE.W    $C2,-(A7)
  410.     CLR.W    -(A7)
  411.     RTS
  412.  
  413. CA_GTSTR:
  414.     MOVE.W    $116,-(A7)
  415.     CLR.W    -(A7)
  416.     RTS
  417.  
  418. IOSSTRG:
  419.     suba    a0,a0        ; -> channel 0 (mjs)
  420.     MOVEQ    #-1,D3        ; don't time out
  421.     MOVEQ    #7,D0        ; IO.SSTRG
  422.     TRAP    #3
  423.     RTS
  424.  
  425. GETTIME:
  426.     MOVEM.L    D0/D2/A0,-(A7)
  427.     MOVEQ    #$13,D0
  428.     TRAP    #1
  429.     MOVEM.L    (A7)+,D0/D2/A0
  430.     RTS
  431.  
  432. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  433. ;      Implement Subdirectory handling procedures
  434.  
  435. CHDIR:
  436.     BSR    STRTOBUF
  437.     MOVE.B    #$B0,2(A2)    ; perform QCHDIR
  438.     BRA    IBM_EXIT
  439.  
  440. SHODIR:
  441.     MOVE.B    #$B1,D0        ; perform QDIR
  442.     BSR    INIDPRAM     ; get dualported ram ...
  443.     BSR    IBM_EXIT
  444.     LEA    6(A2),A1     ; base of string
  445.     MOVEQ    #0,D2
  446.     MOVE.B    (A1)+,D2     ; number of bytes to send
  447.     MOVE.B    #10,0(A1,D2.W)    ; add LF
  448.     ADDQ.W    #1,D2        ; one more for LF
  449.     BRA    IOSSTRG
  450.  
  451. MKDIR:
  452.     BSR    STRTOBUF
  453.     MOVE.B    #$B2,2(A2)    ; perform MAKEDIR
  454.     BRA    IBM_EXIT
  455.  
  456. RMDIR:
  457.     BSR    STRTOBUF
  458.     MOVE.B    #$B3,2(A2)    ; perform REMDIR
  459.     BRA    IBM_EXIT
  460.  
  461. STRTOBUF:
  462.     BSR    STR_RIX
  463.     bne.l    fini
  464. ; Here (a6,a1) points to the string
  465.     PEA    0(A6,A1.L)
  466.     BSR    INIDPRAM     ; get address of dual ported
  467.                 ; ram
  468.     LEA    6(A2),A3     ; get address of PASCAL
  469.                 ; string
  470.     MOVE.L    (A7)+,A0
  471.     MOVE.W    (A0)+,D1     ; get length of string
  472.     MOVE.B    D1,(A3)+     ; save length for pascal
  473.                 ; string
  474. CPY_PSTR:
  475.     MOVE.B    (A0)+,(A3)+    ; copy string to IBM
  476.     DBRA    D1,CPY_PSTR
  477. ;       MOVE.L  A1STO(PC),A1
  478.     RTS
  479. fini:
  480. ;       MOVE.L  A1STO(PC),A1
  481.     ADDQ.L    #4,A7
  482.     RTS
  483.  
  484. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  485. ;          JAN_USE
  486.  
  487. JAN_USE:
  488.     BSR    STR_RIX
  489.     BNE.S    LB8474
  490.     SUBQ.W    #3,0(A6,A1.L)
  491.     BNE.S    LB8472
  492.     MOVE.L    2(A6,A1.L),D6
  493.     ANDI.L    #$5F5F5F00,D6
  494.     ADDI.B    #$30,D6
  495. LB845A    MOVEQ    #$00,D0
  496.     TRAP    #$01
  497.     MOVEA.L    $48(A0),A0
  498.     LEA    FS_JAN(PC),A2    ; (changed to LEA(PC) - MJS)
  499. LB8466    CMPA.L    4(A0),A2
  500.     BEQ.S    LB8476
  501.     MOVEA.L    (A0),A0
  502.     MOVE.L    A0,D1
  503.     BNE.S    LB8466
  504. LB8472    MOVEQ    #-$0F,D0
  505. LB8474    RTS
  506.  
  507. LB8476    MOVE.L    D6,$26(A0)
  508.     RTS
  509.  
  510. STR_RIX:
  511.     MOVEQ    #$0F,D0
  512.     AND.B    $01(A6,A3.L),D0
  513.     SUBQ.B    #1,D0
  514.     BNE.S    LB84A6
  515.     MOVE.L    A5,-(A7)
  516.     LEA    $8(A3),A5
  517.     BSR    CA_GTSTR
  518.     MOVEA.L    (A7)+,A5
  519.     BNE.S    LB84F2
  520.     MOVEQ    #3,D1
  521.     ADD.W    0(A6,A1.L),D1
  522.     BCLR    #0,D1
  523.     ADD.L    D1,$58(A6)
  524.     BRA.S    LB84F0
  525. LB84A6    MOVEQ    #-$0F,D0
  526.     MOVEQ    #$00,D1
  527.     MOVE.W    $02(A6,A3.L),D1
  528.     BMI.S    LB84F2
  529.     LSL.L    #3,D1
  530.     ADD.L    $0018(A6),D1
  531.     MOVEQ    #$00,D6
  532.     MOVE.W    $02(A6,D1.L),D6
  533.     ADD.L    $0020(A6),D6
  534.     MOVEQ    #$00,D1
  535.     MOVE.B    $00(A6,D6.L),D1
  536.     ADDQ.L    #1,D1
  537.     BCLR    #$00,D1
  538.     MOVE.W    D1,D4
  539.     ADDQ.L    #2,D1
  540.     SUBA    A2,A2
  541.     MOVEA.W    $011A,A2     ; allocate space on
  542.                 ; arithmetic stack
  543.     JSR    (A2)
  544.     MOVEA.L    $58(A6),A1
  545.     ADD.W    D4,D6
  546. LB84DC    SUBQ.L    #1,A1
  547.     MOVE.B    0(A6,D6.L),0(A6,A1.L)
  548.     SUBQ.L    #1,D6
  549.     DBF    D4,LB84DC
  550.     SUBQ.L    #1,A1
  551.     CLR.B    0(A6,A1.L)
  552. LB84F0    MOVEQ    #0,D0
  553. LB84F2    RTS
  554.  
  555. ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  556.     END
  557.