home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTH / FIG_4TH.ZIP / 4THXTNS.ASM < prev    next >
Encoding:
Assembly Source File  |  1987-01-16  |  4.1 KB  |  209 lines
  1. SUBTTL Code-level extensions
  2. PAGE
  3.  
  4.  
  5. ;This file contains extensions to the FORTH kernel.
  6. ;These extensions are in assembly language either for speed, or
  7. ;to access specific processor functions.
  8. ;These are NOT system-dependent functions!
  9.  
  10. ;=C+  (XOF)    primitive compiled by CASE..OF        n1 n2 -- [n1]
  11.  
  12. ;    Code added for Dr. Eaker's CASE construct
  13. ;    After John Cassady's 8080 code in FD 3:187 1982
  14. ;    (jes ver1.2C,1982)
  15. ;
  16.         $CODE    85H,(XOF,)
  17.         POP    BX        ;BX := case tag
  18.         POP    AX        ;AX := search tag
  19.         CMP    AX,BX        ;This one ?
  20.         JE    XOF1        ;Yes...
  21.         PUSH    AX        ;No, save search tag,
  22.         JMP    BRAN1        ;   and check the next case.
  23. XOF1:        INC    SI        ;...skip the branch offset,
  24.         INC    SI        ;   and
  25.         JMP    NEXT        ;   don't save the search tag.
  26.  
  27. ;********************************************************
  28. ;*                            *
  29. ;*    long fetch/store operators:    L@, L!        *
  30. ;*                    LC@, LC!    *
  31. ;*                    MYSEG        *
  32. ;*                            *
  33. ;********************************************************
  34.  
  35. ;=C+  L@    intersegment fetch operator        seg off -- n
  36.  
  37.         $CODE    82H,L,@
  38.         POP    BX        ;Offset
  39.         MOV    DX,DS        ;Save current segment
  40.         POP    DS        ;Segment
  41.         MOV    AX,[BX]        ;Fetch word at DS:BX
  42.         MOV    DS,DX        ;Restore segment register
  43.         JMP    APUSH        ;Return
  44.  
  45. ;=C+  L!    intersegment store operator        n seg off --
  46.  
  47.         $CODE    82H,L,!!!!
  48.         MOV    DX,DS
  49.         POP    BX        ;Offset
  50.         POP    DS        ;Segment
  51.         POP    AX        ;Data
  52.         MOV    [BX],AX
  53.         MOV    DS,DX
  54.         JMP    NEXT
  55.  
  56. ;=C+  LC@    intersegment byte fetch            seg off -- b
  57.  
  58.         $CODE    83H,LC,@
  59.         MOV    DX,DS        ;put DS in a safe place
  60.         POP    BX        ;offset
  61.         POP    DS        ;segment
  62.         MOV    AL,BYTE PTR [BX]    ;get it
  63.         XOR    AH,AH        ;make sure AH is clear
  64.         MOV    DS,DX        ;restore data segment
  65.         JMP    APUSH
  66.  
  67. ;=C+  LC!    intersegment byte store            b seg off --
  68.  
  69.         $CODE    83H,LC,!!!!
  70.         MOV    DX,DS        ;save DS
  71.         POP    BX        ;offset
  72.         POP    DS        ;segment
  73.         POP    AX        ;data
  74.         MOV    BYTE PTR [BX],AL    ;move it
  75.         MOV    DS,DX        ;back to old data segment
  76.         JMP    NEXT
  77.  
  78. ;=C+  MYSEG    get FORTH's segment            -- seg
  79.  
  80.         $CODE    85H,MYSE,G
  81.         MOV    AX,DS        ;could just as well be CS or SS
  82.         JMP    APUSH
  83.  
  84. ;=C+  (ARRAY)    1d array addressing primitive        n1 addr1 -- addr2
  85.  
  86. ;
  87. ;    Code added to support array references.
  88. ;    Used by ARRAY to calculate the address of the
  89. ;    nth element of the array.
  90. ;    (jes ver1.2c,1982)
  91. ;
  92.         $CODE    87H,(ARRAY,)
  93.         POP    BX        ;BX -> SIZE
  94.         POP    AX        ;AX := n
  95.         ADD    AX,AX        ;AX := AX*2
  96.         ADD    AX,BX        ;AX -> ARRAY[n]
  97.         ADD    AX,2        ;Offset to ARRAY[0]
  98.         JMP    APUSH
  99.  
  100. ;=C+  (2ARR)    2d array addressing primitive        n1 n2 addr1 -- addr2
  101.  
  102.         $CODE    86H,(2ARR,)
  103.         POP    BX        ;BX -> rowsize
  104.         POP    CX        ;CX := column
  105.         POP    AX        ;AX := row
  106.         MUL    [BX]        ;AX := row*row dim.
  107.         ADD    AX,CX        ;AX := AX + col
  108.         ADD    AX,AX        ;2 bytes per element
  109.         ADD    AX,BX        ;AX := AX+PFA
  110.         ADD    AX,4        ;Offset to ARRAY[0]
  111.         JMP    APUSH
  112.  
  113. ;=C+  (CARR)    1d byte array addressing primitive    n addr1 -- addr2
  114.  
  115.         $CODE    86H,(CARR,)
  116.         POP    BX
  117.         POP    AX
  118.         ADD    AX,BX
  119.         ADD    AX,2
  120.         JMP    APUSH
  121.  
  122. ;=C+  (2CARR)    2d byte array addressing primitive    n1 n2 addr1 -- addr2
  123.  
  124.         $CODE    87H,(2CARR,)
  125.         POP    BX
  126.         POP    CX
  127.         POP    AX
  128.         MUL    [BX]
  129.         ADD    AX,CX
  130.         ADD    AX,BX
  131.         ADD    AX,4
  132.         JMP    APUSH
  133.  
  134. ;    Port fetch/store operators
  135. ;    FIG-listing, pp. 76,77
  136.  
  137. ;=C   PC@    fetch byte from a port            port# --
  138.  
  139.         $CODE    83H,PC,@
  140.         POP    DX
  141.         IN    AL,DX
  142.         SUB    AH,AH        ;make sure high byte is zero
  143.         JMP    APUSH
  144.  
  145. ;=C   PC!    send byte to port            b port# --
  146.  
  147.         $CODE    83H,PC,!!!!
  148.         POP    DX        ;port
  149.         POP    AX        ;data
  150.         OUT    DX,AL
  151.         JMP    NEXT
  152.  
  153. ;=C   P@    16-bit port fetch            port# -- n
  154.  
  155.         $CODE    82H,P,@
  156.         POP    DX
  157.         IN    AX,DX
  158.         JMP    APUSH
  159.  
  160. ;=C   P!    16-bit port output            n port# --
  161.  
  162.         $CODE    82H,P,!!!!
  163.         POP    DX
  164.         POP    AX
  165.         OUT    DX,AX
  166.         JMP    NEXT
  167.  
  168. ;=C   MATCH    string search primtive            addr1 n addr2 n -- f addr3
  169.  
  170.         $CODE    85H,MATC,H
  171.         MOV    DI,SI
  172.         POP    CX
  173.         POP    BX
  174.         POP    DX
  175.         POP    SI
  176.         PUSH    SI
  177. MATCH1:        LODSB
  178.         CMP    AL,BYTE PTR [BX]
  179.         JNZ    MATCH3
  180.         PUSH    BX
  181.         PUSH    CX
  182.         PUSH    SI
  183. MATCH2:        DEC    CX
  184.         JZ    MATCHOK
  185.         DEC    DX
  186.         JZ    NOMATCH
  187.         INC    BX
  188.         LODSB
  189.         CMP    AL,BYTE PTR [BX]
  190.         JZ    MATCH2
  191.         POP    SI
  192.         POP    CX
  193.         POP    BX
  194. MATCH3:        DEC    DX
  195.         JNZ    MATCH1
  196.         JMP    SHORT MATCH4
  197. MATCHOK:
  198. NOMATCH:     POP    CX
  199.         POP    CX
  200.         POP    CX
  201. MATCH4:        MOV    AX,SI
  202.         POP    SI
  203.         SUB    AX,SI
  204.         MOV    SI,DI
  205.         JMP    DPUSH
  206.  
  207.     $REPORT    <CODE-level extensions>
  208.  
  209.