home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Pocket 6.3 ƒ / Pocket DA / DA Source / PocketDA.asm < prev    next >
Encoding:
Assembly Source File  |  1993-07-04  |  8.9 KB  |  330 lines  |  [TEXT/ttxt]
  1. ; File is PocketDA.asm  10:04:36 AM  6/26/87
  2. ; Sat Feb 13, 1988 14:37:31 version 1.3+  move DICT control to dSupport.txt
  3. ; Tue May 10, 1988 02:46:06 version 1.4  DRVR is purgable
  4. ; Thu Jul 04, 1991 11:27:00 version 1.5
  5. ; Sat Aug 08, 1992 19:09:00 version 1.6    ( no Apple Events )
  6. ; Sat Jan 23, 1993 21:43:00 version 1.6.2  ( bug fix only )
  7. ; Fri May 28, 1993 22:16:00 version 1.6.3
  8.  
  9. ; ----- definitions ------
  10.  
  11. INCLUDE    Traps.txt
  12. INCLUDE    Macros.txt
  13. JIODone        EQU    $8FC    ; IODone entry location [pointer]
  14.  
  15. csCode        EQU    $1A    ; param block message record offset
  16. csEvent        EQU    $1C    ; param block event record offset
  17. csMenu        EQU    $1E    ; param block menu offset
  18. dCtlWindow    EQU    $1E    ; DCE window pointer offset
  19. dCtlRefNum    EQU    $18    ; DCE refNum offset
  20. WindowKind    EQU    $6C    ; Window pointer offset
  21. accEvent    EQU    $40
  22. accRun        EQU    $41
  23. accCursor    EQU    $42
  24. accMenu        EQU    $43
  25. accUndo        EQU    $44
  26. useritem    EQU    0
  27. staticText    EQU    8
  28. disabled    EQU    128
  29.  
  30. OpenJMP        EQU    4    ; offsets into the DICT
  31. CloseJMP    EQU    8
  32. ControlJMP    EQU    0
  33. ExpandJMP    EQU    12
  34.  
  35. evtNum        EQU    0    ; event field offset: event type
  36. evtASCII    EQU    4    ; event field offset: ASCII code
  37. evtMeta        EQU    14    ; event field offset: meta keys
  38. LHeight        EQU    11    ; line height
  39. WHeight        EQU    178    ; 16 lines
  40. WWidth        EQU    384    ; 64 chars
  41. CR        EQU    $0D    ; carrage return
  42. BS        EQU    8    ; backspace
  43. BL        EQU    32    ; blank
  44.  
  45. MACRO    Base    = Baddr |    ; start of the address space
  46. MACRO    theLink    = Base-6 |    ; calculate the link address
  47. MACRO    BP    = A3 |        ; base pointer
  48. MACRO    DP    = A2 |        ; compile pointer
  49. MACRO    PS    = A6 |        ; parameter stack pointer
  50. MACRO    RS    = A7 |        ; return stack pointer
  51. MACRO    IS    = A4 |        ; input stream buffer pointer
  52. MACRO    Counter    = D7 |        ; character count
  53. MACRO    Dict    = D6 |        ; start search
  54.  
  55. .ALIGN 2  ; ------ the DRVR resource ------
  56. RESOURCE 'DRVR'    26  ' Pocket Forth 1.6.3' 32    ; purgable
  57.  
  58. Start:    ; ----- Header ------
  59.     DC.W        $6400        ; Locked, ctlEnabled
  60.     DC.W        2        ; run every 1/30th sec
  61.     DC.W        362        ; KeyDown&Auto, button, act & update
  62.     DC.W        -1        ; a user menu
  63.  
  64.     DC.W    Openda-Start
  65.     DC.W    done-Start        ; prime - unused
  66.     DC.W    Control-Start
  67.     DC.W    done-Start        ; status - unused
  68.     DC.W    Close-Start
  69.  
  70. ; ----- Data ------
  71. ResID:        DC.W    0        ; resource ID to be set at runtime
  72. ResType:    DC.L    'DRVR'        ; resource type code
  73. ResName:    DCB.B    16,0        ; a string for the DA's name 
  74. DictH:        DC.L    0        ; the DICT's handle
  75. Running:    DC.W    0
  76.  
  77. Openda:        ; ----- Open routine ------
  78.     MOVEM.L    D0-D7/A0-A6,-(SP)
  79.     TST.L    DCtlWindow(A1)        ; be sure this DA's not open
  80.     BNE.S    GoodOpenDone        ; if so, don't make a new one
  81.     MOVE.L    A1,A4            ; hold the DCE in a stable register
  82.     LEA    Start,A0        ; A0 has the DA's pointer
  83.     _RecoverHandle            ; A0 has the DA's handle
  84.     MOVE.L    A0,-(SP)        ; Push DA handle,
  85.     PEA    ResID            ;   addr for ID number...
  86.     PEA    ResType            ;   addr for type code...
  87.     PEA    ResName            ;   addr for a Str(255)
  88.     _GetResInfo            ; set this resource ID number
  89.     JSR    OldPort            ; save old port on stack
  90.     JSR    LoadWIND        ; load the WIND resource
  91.     MOVE.L    #512,D0
  92.     _NewPtr                ; create a pStack block
  93.     MOVE.L    A0,PS            ; carry it there in A6 (PS)
  94.     JSR    LoadDICT        ; load the DICT resource
  95.     JSR    DictAddr        ; get the dictionary address into A0
  96.     LEA    doExpand,A1        ; carry the expand routine in A1
  97.     JSR    OwnedID            ; carry the ID of the DICT in D0
  98.     JSR    OpenJMP(A0)        ; jsr to the dictionary open
  99.     _SetPort        ; <-- DICT RETURNS HERE
  100.  
  101.   GoodOpenDone:
  102.     MOVEQ    #0,D0            ; return no error
  103.   OpenDone:
  104.     MOVEM.L    (A7)+,D0-D7/A0-A6
  105.   Done:    RTS                ; all done, exit
  106.  
  107.   BadOpenDone:
  108.       MOVE.W    #-1,D0            ; set error condition
  109.     BRA.S    OpenDone
  110.  
  111. Close:        ; ----- Close routine ------
  112.     MOVEM.L    D0-D7/A0-A6,-(SP)
  113.     MOVE.L    DCtlWindow(A1),-(SP)    ; push the window
  114.     CLR.L    DCtlWindow(A1)        ; clear the pointer in the DCE
  115.     _DisposWindow            ; dispose it
  116.     JSR    DictAddr        ; get the dictionary address into 
  117.     JSR    CloseJMP(A0)        ; jsr to the DICT's close routine
  118.     JSR    DisposeDICT    ; <-- DICT RETURNS HERE
  119.     BRA.S    GoodOpenDone        ; all done with close
  120.     
  121. Control:    ; ----- Control routine ------
  122.     MOVEM.L    D0-D7/A0-A6,-(SP)
  123.     LEA    running,A3
  124.     TST    (A3)
  125.     BNE.S    cdone
  126.     MOVE    #-1,(A3)
  127.     MOVE.L    A0,D4            ; pBlock always in D4 during control
  128.     JSR    OldPort            ; save old port on stack
  129.     JSR    DictAddr        ; get the dictionary address into 
  130.     JSR    ControlJMP(A0)        ; jsr to the dictionary control
  131.     _SetPort        ; <-- DICT RETURNS HERE
  132.     LEA    running,A0
  133.     CLR    (A0)
  134.  
  135. CDone:    MOVEM.L    (A7)+,D0-D7/A0-A6
  136.     MOVEQ    #0,D0            ; no error
  137.     MOVE.L    JIODone,-(SP)        ; jump to IODone
  138.     RTS
  139.  
  140. ; ----- Expand routine ( entry from DICT ) ------
  141.  
  142. doExpand:
  143.     MOVE.L    DictH,A0
  144.     _HUnlock            ; unlock the dictionary
  145.     _GetHandleSize            ; add the passed in size ...
  146.     ADD    (A6)+,D0        ;  ...to the previous size and ...
  147.     _SetHandleSize            ;  ... reset dictionary size
  148.     _HLock
  149.  
  150.     JSR    DictAddr        ; get the dictionary address
  151.     JMP    ExpandJMP(A0)        ; jsr to the dictionary expand
  152.  
  153. ; ----- subroutines ------
  154.  
  155. LoadDICT:    ; load in the DICT
  156.     CLR.L    -(SP)            ; room for dict handle
  157.     MOVE.L    #'DICT',-(SP)        ; type of resource
  158.     BSR.S    OwnedID
  159.     ADD.W    #0,D0            ; plus the 'private' ID of the DICT
  160.     MOVE.W    D0,-(SP)
  161.     _GetResource
  162.     LEA    DictH,A0        ; stash the resource handle
  163.     MOVE.L    (SP)+,(A0)
  164.     MOVE.L    (A0),A0
  165.     _HLock                ; Lock the DICT
  166.     RTS
  167.  
  168. OwnedID:  ; get an owned ID number into D0 
  169.     MOVE    ResID,D0        ; this DA's ID
  170.     ASL    #5,D0            ; times 32
  171.     OR    #$C000,D0        ; -16384
  172.     RTS
  173.  
  174. LoadWIND:
  175.     CLR.L    -(SP)            ; make room for the new window pointer
  176.     BSR.S    OwnedID
  177.     ADD.W    #0,D0            ; plus the 'private' ID of the WIND
  178.     MOVE.W    D0,-(SP)
  179.     CLR.L    -(SP)            ; put it on the heap
  180.     MOVE.L    #-1,-(SP)        ; behind none
  181.     bsr.s    qcolor
  182.     BEQ.S    @1
  183.     _GetNewCWindow
  184.     BRA.S    @2
  185.     @1:    _GetNewWindow
  186.     @2:    MOVE.L  (SP)+,A0
  187.     MOVE.L    A0,DCtlWindow(A4)    ; put window pointer into DCE
  188.     MOVE.W    DCtlRefNum(A4),WindowKind(A0)    ; mark as system window 
  189.     RTS
  190.     
  191. QColor: ; true if color
  192.     ; check for 64K ROM
  193.     MOVE    #$A86E,D0        ; _InitGraf
  194.     _GetTrapAddress.newTool
  195.     MOVE.L    A0,D1
  196.     MOVE    #$AA6E,D0        ; _InitGraf AND $200
  197.     _GetTrapAddress.newTool
  198.     CMP.L    A0,D1
  199.     BEQ.S    nc            ; 64KROM -- no color back then
  200.  
  201.     ; Check for gestalt
  202.     MOVE.W    #$A89F,D0        ; _Unimplemented
  203.     _GetTrapAddress.newTool        ; NGetTrapAddress
  204.     MOVE.L    A0,D1
  205.     MOVE.W    #$A1AD,D0        ; _Gestalt
  206.     _GetTrapAddress.newOS        ; NGetTrapAddress
  207.     CMP.L    A0,D1
  208.     BEQ.S    nc            ; no gestalt -- assume no color
  209.  
  210.     ; run gestalt
  211.     MOVE.L    #'qd  ',D0
  212.     _Gestalt
  213.     CMPA.L    #$100,A0
  214.     BLT.S    nc
  215.     moveq    #-1,d0
  216.     RTS
  217.  nc:    clr    d0
  218.     RTS
  219.  
  220. DICTAddr:    ; return the address of the DICT's block in A0
  221.     MOVE.L    DictH,A0        ; get the DICT's handle
  222.     MOVE.L    (A0),D0            ; dereference into D0
  223.     ANDI.L    #$1FFFFFFF,D0        ; mask out resource flags
  224.     MOVE.L    D0,A0            ; load the jump address
  225.     RTS
  226.  
  227. DisposeDICT:
  228.     MOVE.L    DictH,-(SP)        ; the DICT's handle
  229.     _ReleaseResource        ; dispose of the DICT
  230.     RTS
  231.  
  232. OldPort:
  233.     MOVE.L    (SP)+,D3        ; hold return address
  234.     SUBQ.L    #4,SP            ; open a hole in the stack
  235.     MOVE.L    SP,-(SP)        ; push address of the hole
  236.     _GetPort            ; put the port into the hole
  237.     MOVE.L    D3,-(SP)        ; restore the return address
  238.     RTS
  239.  
  240.  
  241. .ALIGN 2 ; ----- the DICT resource ------
  242. RESOURCE 'DICT' $C340  'PocketForth' 16 ; locked (not necc. to be p'able)
  243.  
  244. Baddr:                    ; start of forth's address space
  245. Bottom:    JMP    DictControl        ; jump into sections of the driver
  246.     JMP    DictOpen
  247.     JMP    DictClose
  248.     JMP    GRet
  249.  
  250. DictOpen:    ; ----- Open routine------
  251.       LEA    Baddr,BP        ; Set the base pointer
  252.     MOVE    D0,MyID-base(BP)    ; set the id holder
  253.     MOVE.L    A1,Expand-base(BP)    ; set the expand routine's address
  254.     MOVE.L    PS,PStackH-base(BP)
  255.  
  256.     MOVE.L    DCtlWindow(A4),-(SP)
  257.     MOVE.L    (SP),theWindow-base(BP) ; Put the window into theWindow
  258.     MOVE.L    (SP),-(SP)
  259.     MOVE.L    WSize-base(BP),-(SP)
  260.     CLR.W    -(SP)
  261.     _SizeWindow
  262.     MOVE.L    (SP),-(SP)
  263.     _ShowWindow
  264.     _SetPort
  265.  
  266.     ADDA.L    #512,PS
  267.     MOVE.L    PS,UFlow-base(BP)
  268.     SUBQ.L    #2,PS            ; leave a 2 byte underflow buffer
  269.     MOVE.L    PS,SZero-base(BP)
  270.  
  271.     CLR.L    Dict
  272.     MOVE    DictPt-base(BP),Dict    ; Set the dictionary search pointer
  273.     MOVE    FreePt-base(BP),D0
  274.     LEA    0(BP,D0.W),DP        ; set the compile pointer
  275.     LEA    TermBuf-base(BP),IS    ; set the input stream pointer
  276.     CLR.L    Counter            ; clear character count
  277.     CLR.L    fcolon-base(BP)        ; set the compiler flags
  278.     BSET.B    #7,fint-base(BP)
  279.     
  280.     MOVE.L    #10,D0
  281.     _NewHandle            ; pasting text block
  282.     MOVE.L    A0,TextH-base(BP)
  283.     
  284.     MOVE.L    #10,D0
  285.     _NewHandle            ; to save rStack during "key"
  286.     MOVE.L    A0,oldStackH-base(BP)
  287.     
  288.     MOVE    freesz-base(BP),-(PS)
  289.     JSR    grow-base(BP)        ; grow to the current size
  290.     JSR    ClearTermBuf-base(BP)
  291.     JSR    Page-base(BP)
  292.     
  293.     MOVE    opener-base(BP),D0
  294.     JSR    0(BP,D0)        ; run the open routine 3/30/88
  295.  
  296.     JSR    SaveFRegs-base(BP)    ; save the initial register values
  297.     RTS
  298.  
  299. DictClose:    ; ----- Close routine ------
  300.     JSR    SetFRegs        ; set the Forth registers    
  301.     MOVE    Closer-base(BP),D0
  302.     JSR    0(BP,D0.W)        ; jump to the closer vector
  303.  
  304.     MOVE.L    PStackH-base(BP),A0
  305.     _DisposPtr            ; dispose of the stack block
  306.     MOVE.L    TextH,A0
  307.     _DisposHandle            ; dispose of the private scrap block
  308.     MOVE.L    OldStackH,A0
  309.     _DisposHandle            ; dispose of "key"'s storage
  310.     RTS
  311.  
  312. INCLUDE    dSupport.txt            ; unnamed interface routines
  313. INCLUDE    dInterp.txt            ; interpreter words
  314. INCLUDE    dDict.txt
  315.  
  316. .ALIGN    2    ; ----- the WIND resource ------
  317. RESOURCE 'WIND' $C340  'PocketForth' 32 ; purgable
  318.     DC.W    40,2,41,102
  319.     DC.W    4            ; no grow doc proc
  320.     DC.W    0            ; invisable
  321.     DC.W    $100            ; closable
  322.     DC.L    0
  323.     DC.B    18,'Pocket Forth 1.6.3'
  324.  
  325. .ALIGN    2    ; ----- the signature resource for identification ------
  326. RESOURCE 'p4TH' $C340  'PocketForth' 32 ; purgable
  327.      DC.B    25,'v1.6.3  C.Heilman  7/4/93'
  328.  
  329. END
  330.