* Database example machine code program.
* Example 4: Add basic procedure to dump out current record
D$       SETSTR   [.LEFT(.FILE,4)]
         INCLUDE  [D$]_QDOS_TRAP_IN
         INCLUDE  [D$]_QDOS_VECT_IN
*
         INCLUDE  [D$]_QDOS_DATA_IN
BV.CHBAS EQU      $30               Channel table pointers
BV.CHP   EQU      $34
CHB.ID   EQU      $00               Channel block channel ID
CHB.DB   EQU      $24               Channel block database ID
BV.RIP   EQU      $58               RI stack pointers
BV.RIBAS EQU      $5C  
*
         SECTION  MAIN
*
         LEA      PROCDEF(PC),A1
         MOVE.W   BP.INIT,A2
         JSR      (A2)              Add new procedure
         MOVEQ    #0,D0
         RTS
* Procedure list
PROCDEF  DC.W     1
         DC.W     DISPLAY-*
         DC.B     7,'DISPLAY'       DISPLAY #dbase TO #outchan
         DC.W     0,0,0
*
* Procedure code
*
DISPLAY
         MOVEQ    #ERR.BP,D0
         MOVE.L   A5,D1             Must be 2 parameters only
         SUB.L    A3,D1
         CMPI.L   #$10,D1
         BNE.L    DISP_ERR
*
         BSR.L    GCHAN             Get #dbase
         BNE.L    DISP_ERR
         MOVE.L   A4,D7
         BSR.L    GCHAN             Get #outchan
         BNE.L    DISP_ERR
*
         MOVEQ    #-1,D3
         MOVE.L   CHB.ID(A6,D7.L),A0
         MOVE.L   #FS.DBASE,D0      Get the database vectors address
         TRAP     #3
         TST.L    D0
         BNE.L    DISP_ERR
         MOVE.L   A1,A5             A5 = vectors address
* Get field quantity
         MOVE.L   CHB.DB(A6,D7.L),A0
         MOVEQ    #0,D1
         JSR      FSD.INFO(A5)
         BNE.L    DISP_ERR
         MOVEQ    #1,D6             D6.lsW = field number
         SWAP     D6
         MOVE.W   D2,D6             D6.msW = field quantity
         BRA.S    OUT_LOOP
* RI allocation "extra" amounts
ROOM     DC.L     2                 String
         DC.L     2                 Int.W
         DC.L     24                Int.L string
         DC.L     22                FP string
* Output handling routine pointers
HANDLER  DC.L     STRING-HANDLER
         DC.L     INT_W-HANDLER
         DC.L     INT_L-HANDLER
         DC.L     FLOAT-HANDLER
* Loop around outputting fields
OUT_LOOP SWAP     D6
         MOVE.L   BV.RIBAS(A6),A1   Contract RI stack to empty
         MOVE.L   A1,BV.RIP(A6)
         MOVE.L   CHB.DB(A6,D7.L),A0  
         MOVE.W   D6,D1
         JSR      FSD.INFO(A5)      Get field type,length
         BNE.S    DISP_ERR
         MOVE.L   D1,D5             Save type
         SWAP     D5
         MULU     #4,D5             Double type to use as an index
* Make space in stack
         ANDI.L   #$0000FFFE,D1     Make length even and remove type
         ADD.L    ROOM(PC,D5.L),D1  Must have enough
         MOVE.L   D1,-(SP)
         MOVE.W   BV.CHRIX,A2       Make sure room available on RI stack
         JSR      (A2)

         MOVE.L   BV.RIP(A6),A1     Make space in the RI stack
         SUBA.L   (SP),A1
         MOVE.L   A1,BV.RIP(A6)
* Get field
         MOVE.W   D6,D1             Field length
         MOVE.L   (SP)+,D2          Buffer length
         TRAP     #4
         JSR      FSD.GET(A5)
         BNE.S    DISP_ERR
* Print the field
         MOVE.L   HANDLER(PC,D5.L),D2
         JSR      HANDLER(PC,D2.L)
         BNE.S    DISP_ERR
* Print a LF
         MOVEQ    #-1,D3
         MOVEQ    #$0A,D1
         MOVE.L   CHB.ID(A6,A4.L),A0
         MOVEQ    #IO.SBYTE,D0      Print LF
         TRAP     #3
         TST.L    D0
         BNE.S    DISP_ERR
*
         ADDQ.W   #1,D6
         MOVE.W   D6,D1
         SWAP     D6
         CMP.W    D6,D1             CMP Field quantity,number
         BLS.S    OUT_LOOP
*
DISP_ERR RTS
*
* Print word integer
INT_W    MOVE.W   0(A6,A1.L),D1
         MOVE.L   CHB.ID(A6,A4.L),A0
         MOVE.W   UT.MINT,A2
         JSR      (A2)
         RTS
*
* Print long integer
INT_L    MOVE.L   0(A6,A1.L),D1     Reclaim spare RI stack
         MOVE.L   BV.RIBAS(A6),A1
         SUBQ.L   #4,A1
         MOVE.L   D1,0(A6,A1.L)
         MOVE.L   A1,BV.RIP(A6)
         BSR.L    FL_LONG           Convert it to a float
         BEQ.S    FLOAT2
         RTS
*
* Print floating point number
FLOAT    MOVE.W   0(A6,A1.L),-(SP)  Reclaim spare RI stack
         MOVE.L   2(A6,A1.L),-(SP)
         MOVE.L   BV.RIBAS(A6),A1
         SUBQ.L   #6,A1
         MOVE.L   (SP)+,2(A6,A1.L)
         MOVE.W   (SP)+,0(A6,A1.L)
FLOAT2
         LEA      -22(A1),A0
         MOVE.L   A0,BV.RIP(A6)     Use room for string storage
         MOVE.W   CN.FTOD,A2        Convert fp to ascii
         JSR      (A2)
         MOVE.L   BV.RIP(A6),A1
         MOVE.L   A0,D1             Get length in D1
         SUB.L    A1,D1
*
* Print string
STRING
         MOVE.W   D1,D2             Length to D2
         MOVEQ    #-1,D3
         MOVE.L   CHB.ID(A6,A4.L),A0
         MOVEQ    #IO.SSTRG,D0      Print string
         TRAP     #4
         TRAP     #3
         TST.L    D0
         RTS
*
* Get channel block pointer
*
GCHAN    MOVEM.L  D3/D4/D6,-(SP)
         MOVE.L   A5,A4             Save A5
         LEA      8(A3),A5          Point to parameter 1
         MOVE.W   CA.GTINT,A2       Get channel block
         JSR      (A2)
         BNE.S    GC_ER
         MOVE.W   0(A6,A1.L),D1     Get the channel number
         MOVE.L   BV.RIBAS(A6),A1   Contract down RI stack
         MOVE.L   A1,BV.RIP(A6)
         MOVE.L   A5,A3             Point to parameter 2
         MOVE.L   A4,A5             Restore A5
*
         MOVEQ    #ERR.NO,D0
         MULU     #40,D1            Point to entry
         ADD.L    BV.CHBAS(A6),D1
         CMP.L    BV.CHP(A6),D1     Must be in the table
         BGE.S    GC_ER             Not open if not in
         MOVE.L   D1,A4             Point A4 to channel block
         TST.L    0(A6,A4.L)        If channel ID -ve then not open
         BMI.S    GC_ER
         MOVEQ    #0,D0
GC_ER    MOVEM.L  (SP)+,D3/D4/D6
         TST.L    D0
         RTS
* Float a long word on RI stack
FL_LONG  MOVEM.L  D1/D5-D7/A2,-(A7)
         MOVEQ    #4*6,D1
         MOVE.W   BV.CHRIX,A2       Must be sufficient room for calculations
         JSR      (A2)
         MOVE.L   BV.RIP(A6),A1
*
         TST.L    0(A6,A1.L)        Set a flag if int.l -ve
         SMI      D6
         BPL.S    FL_POS
         NEG.L    0(A6,A1.L)        INT.L must be positive
FL_POS   MOVE.W   0(A6,A1.L),D1     Unstack the MSW
         ADDQ.L   #2,A1
*
         MOVEQ    #RI.FLOAT,D0      LSW must not be negative
         MOVEQ    #0,D7
         BCLR     #7,0(A6,A1.L)     Clear bit 15 of LSW
         SNE      D5                Flag if bit 15 of LSW was set
         MOVE.W   RI.EXEC,A2        Float the LSW
         JSR      (A2)
         BNE.S    FL_ERR
         TST.B    D5                Skip next part if bit 15 of LSW = 0
         BEQ.S    FL_WPOS
         SUBQ.W   #6,A1
         MOVE.W   #$0810,0(A6,A1.L) Stack 32768
         MOVE.L   #$40000000,2(A6,A1.L)
         MOVEQ    #RI.ADD,D0        And add it on
         JSR      (A2)
         BNE.S    FL_ERR
*
FL_WPOS  SUBQ.L   #2,A1             Stack the MSW
         MOVE.W   D1,0(A6,A1.L)
         MOVEQ    #RI.FLOAT,D0      Float it
         JSR      (A2)
         BNE.S    FL_ERR

         SUBQ.L   #2,A1             Stack 256
         MOVE.W   #256,0(A6,A1.L)
         MOVEQ    #RI.FLOAT,D0      Float it
         JSR      (A2)
         BNE.S    FL_ERR

         MOVEQ    #RI.DUP,D0        LSW,MSW,256,256
         JSR      (A2)
         BNE.S    FL_ERR

         MOVEQ    #RI.MULT,D0       LSW,MSW,65536
         JSR      (A2)
         BNE.S    FL_ERR

         MOVEQ    #RI.MULT,D0       LSW,MSW*65536
         JSR      (A2)
         BNE.S    FL_ERR

         MOVEQ    #RI.ADD,D0        LSW+MSW*65536
         JSR      (A2)
         BNE.S    FL_ERR

         TST.B    D6                Skip next part if INT.L was +ve
         BEQ.S    FL_ERR
         MOVEQ    #RI.NEG,D0        0-(LSW+MSW*65536)
         JSR      (A2)
FL_ERR   MOVEM.L  (A7)+,D1/D5-D7/A2
         TST.L    D0
         RTS
         END
