( an implementation of standard machintosh file routines in mach forth)
( it uses the Records routines, uploaded separately )
 
( Standard File Ops)
( -------------------------------------------------------------------------)
ONLY MAC
ALso FORTH
ALSO Assembler
 
ALSO RECORDS
ALSO    I/O
DEFINITIONS
 
GLOBAL  

: BEEP 10 CALL SysBeep ;

Record SFReply 
        GLOBAL  BYTE:   SFGood
        GLOBAL  BYTE:   SFCopy
        GLOBAL  LONG:   SFFTYpe
        GLOBAL  SHORT:  SFVRefNum
        GLOBAL  SHORT:  SFVerNum
    GLOBAL      63 STRING:      SFFName
End.Record
 
1 CONSTANT SfPutFIle
2 CONSTANT SfGetFile
3 CONSTANT SfpPutFIle
4 CONSTANT SfpGetFile
 
Variable ReplyREc SFReply 4 - Vallot
 
 
Header TextType
Dc.b 'TEXT'
 
Header DataTYpe
DC.B 'DATA'
 
 
 
Create Vol.Prompt ," Enter Volume Name"
Create Fil.Prompt ," Enter File Name"
 
        
Global
CODE Get.Text   (  -- | STD GET for TEXT Files )
(       MOVE.L  A7,A0
        MOVE.L  Trap-Stack,A7
        MOVE.L  A0,-(A7)
)        
        
        Move.W  #100,-(A7)
        Move.W  #100,-(A7)      ( point)
        Move.L  #0,-(A7)        ( Prompt)
        MOVE.L  #0,-(A7)        ( FilterPtr)
        MOVE.W  #1,-(A7)        ( NumTYpes)
        PEA     TextType        ( TypeList)
        MOVE.L  #0,-(A7)        ( DLgHook)
        PEA     ReplyREc        ( SFReplyPtr)
        MOVE.W  #2,-(A7)        ( Pack COnst)
        _PACK3  
        
(       MOVE.L  (A7)+,A7 )
        RTS
        
End-Code
 
Global
CODE Get.Data   (  -- STD GET For DATA Files)
(       MOVE.L  A7,A0
        MOVE.L  Trap-Stack,A7
        MOVE.L  A0,-(A7)
)        
        
        Move.W  #100,-(A7)
        Move.W  #100,-(A7)      ( point)
        Move.L  #0,-(A7)        ( Prompt)
        MOVE.L  #0,-(A7)        ( FilterPtr)
        MOVE.W  #1,-(A7)        ( NumTYpes)
        PEA     DataType        ( TypeList)
        MOVE.L  #0,-(A7)        ( DLgHook)
        PEA     ReplyREc        ( SFReplyPtr)
        MOVE.W  #2,-(A7)        ( Pack COnst)
        _PACK3  
        
(       MOVE.L  (A7)+,A7 )
        RTS
        
End-Code
 
Global
CODE Get.All    (  -- STD GET For All file types)
(       MOVE.L  A7,A0
        MOVE.L  Trap-Stack,A7
        MOVE.L  A0,-(A7)
)        
        
        Move.W  #100,-(A7)
        Move.W  #100,-(A7)      ( point)
        Move.L  #0,-(A7)        ( Prompt)
        MOVE.L  #0,-(A7)        ( FilterPtr)
        MOVE.W  #-1,-(A7)       ( NumTYpes)
        MOVE.L  #0,-(A7)        ( TypeList)
        MOVE.L  #0,-(A7)        ( DLgHook)
        PEA     ReplyREc        ( SFReplyPtr)
        MOVE.W  #2,-(A7)        ( Pack COnst)
        _PACK3  
        
(       MOVE.L  (A7)+,A7 )
        RTS
        
End-Code
 
Global
CODE Std.Put    (  Prompt -- )
(       MOVE.L  A7,A0
        MOVE.L  Trap-Stack,A7
        MOVE.L  A0,-(A7)
)        
        
        Move.W  #100,-(A7)
        Move.W  #100,-(A7)      ( point)
        MOVE.L  (A6)+,-(A7)     ( Prompt)
        Move.L  #0,-(A7)        ( OrigName)
        MOVE.L  #0,-(A7)        ( DLgHook)
        PEA     ReplyREc        ( SFReplyPtr)
        MOVE.W  #1,-(A7)        ( Pack COnst)
        _PACK3  
        
(       MOVE.L  (A7)+,A7 )
        RTS
        
End-Code
 
( -------------------------------------------------------------------------)
( FIle io ops)
 
Variable TempStr ( For building 4 letter Array of char )
 
        0 CONSTANT fsCurPerm
        1 CONSTANT fsRdPerm
        2 CONSTANT fsWrPerm
        3 CONSTANT fsRdWrPerm
        
        0 CONSTANT fsAtMark
        1 CONSTANT fsFrStart
        2 CONSTANT fsFrLEOF
        3 CONSTANT fsFrMark
 
        Variable NameBuffer 100 Vallot
        
: "TEXT
        ASCII T 256 256 256 * * *
        ASCII E 256 256 * * +
        ASCII X 256 * +
        ASCii T +
        ;       
        
: "DATA
        ASCII D 256 256 256 * * *
        ASCII A 256 256 * * +
        ASCII T 256 * +
        ASCii A +
        ;       
: "WORK
        ASCII W 256 256 256 * * *
        ASCII O 256 256 * * +
        ASCII R 256 * +
        ASCii K +
        ;
 
: "HDSK
        ASCII H 256 256 256 * * *
        ASCII D 256 256 * * +
        ASCII S 256 * +
        ASCii K +
        ;
 
 
        
Record FInfo
        LONG:   FdType
        LONG:   FdCreator
        SHORT:  FdFlags
        LONG:   FdPoint
        SHORT:  FdFldr
End.record
        
Variable FInfoBUffer FInfo 4 - Vallot
 
RECORD Param.BLk.Header
        ADDR:   QLink
        SHORT:  qType
        SHORT:  ioTrap
        ADDR:   ioCmdAddr
        ADDR:   ioCompletion
        SHORT:  ioResult
        ADDR:   ioNamePtr
        SHORT:  ioVRefNum
End.Record
        
 
RECORD IO.Param.BLock
        Param.BLk.Header
        Record: ioHeader
        SHORT:  ioRefNum
        BYTE:   ioVersNumber
        BYTE:   ioPermissn
        ADDR:   ioMisc
        ADDR:   ioBUffer
        LONG:   ioReqCount
        LONG:   ioActCount
        SHORT:  ioPosMode
        LONG:   ioPosOffset
End.Record
 
 
RECORD File.Param.BLock
  Param.BLk.Header
        Record: FHeader
        SHORT:  FRefNum
        BYTE:   FVersNumber
        BYTE:   FFill1
        SHORT:  FDirIndex
        BYTE:   FFlAttributes
        BYTE:   FFlVersNum
  FInfo
        Record: FFinderInfo
        LONG:   FFileNum
        SHORT:  FFileStBlk
        LONG:   FFilLogLen
        LONG:   FFilPhyLen
        SHORT:  FResStBlk
        LONG:   FResLogLen
        LONG:   FResPhyLen
        LONG:   FFilCrDat
        LONG:   FFilMdDat
End.Record
 
 
Record Vol.Param.BLock
        Param.BLk.Header
        Record: VHeader
        LONG:   VFiller2
        SHORT:  VVolIndex
        LONG:   VCrDate
        LONG:   VLsBkUp
        SHORT:  VAtrb
        SHORT:  VNumFls
        SHORT:  VDirSt
        SHORT:  VBlLn
        SHORT:  VNmAlBLks
        LONG:   VAlBlkSiz
        LONG:   VClpSiz
        SHORT:  VAlBlSt
        LONG:   VNxtFNum
        SHORT:  VFrBlk
End.Record
        
: New.IOPBLock ( --<name>)
        Variable  IO.Param.BLock 4 - Vallot ;
 
: New.FilePBLock
        Variable  File.Param.BLock 4 - Vallot ;
 
: New.VolPBLock
        Variable  Vol.Param.BLock 4 - Vallot ;
 
        
New.FilePBLock  PBREC ( made fpb so that can hold largest possible paramblk)
        
: InitPBREC  (  -- | Fills PBREC with 0, SET PERMISSION TO RDWR ) 
        PBREC File.Param.BLock 0 Fill 
        fsRdWrPerm  PBREC ioPermissn  C! ;
 
Global
: Create.File (  -- Result )
        InitPBREC
        Fil.Prompt Std.Put
        ReplyREc SFGood C@
        IF
                ReplyREc SFFName  PBREC ioNamePtr !
                ReplyREc SFVRefNum W@ PBREC ioVRefNum W!
                PBRec Call Create 
        Else
                -1
        THEN ;
        
: Set.Data.Type ( -- | Sets file type as DATA)
        PBRec Call GetFileInfo Drop
        "HDSK PBREC FFinderInfo FdCreator !
        "DATA PBREC FFinderInfo FdType !
        PBRec Call SetFileInfo Drop
        ;
 
: Set.Text.Type ( -- | Sets file type as TEXT)
        PBRec Call GetFileInfo Drop
        "HDSK PBREC FFinderInfo FdCreator !
        "TEXT PBREC FFinderInfo FdType !
        PBRec Call SetFileInfo Drop
        ;
 
( -----------------------------------------------------------------------)
( Synch. File Calls similar to Pascal calls in Inside Machintosh)
 
Global
: New.Text.File ( -- [Result FileRef] or [-1 0] )
        Create.File 0=
        IF
                Set.Text.Type
                PBREC Call Open
                PBREC ioRefNum W@
        Else
                -1 0
        Then ;
        
Global
: New.Data.File ( -- [Result FileRef] or [-1 0] )
        Create.File 0=
        IF
                Set.Data.Type
                PBREC Call Open
                PBREC ioRefNum W@
        Else
                -1 0
        Then ;  
 
        
Global
: Open.Text  ( -- [Result FileRef] or [-1 0] )
        InitPBREC
        GET.Text
        ReplyREc SFGood C@
        IF
                ReplyREc SFFName  PBREC ioNamePtr !  
                ReplyREc SFVRefNum W@ PBREC ioVRefNum W! 
                PBREC Call Open
                PBREC ioRefNum W@
        Else
                -1 0
        Then
         ;
         
Global   
: Open.Data  ( -- [Result FileRef] or [-1 0] )
        InitPBREC
        GET.Data
        ReplyREc SFGood C@
        IF
                ReplyREc SFFName  PBREC ioNamePtr !  
                ReplyREc SFVRefNum W@ PBREC ioVRefNum W! 
                PBREC Call Open
                PBREC ioRefNum W@
        else
                -1 0
        Then
         ;
 
GLOBAL
: Open.RSRC ( -- [Result FileRef] or [-1 0] )
        InitPBREC
        GET.ALL
        ReplyREc SFGood C@
        IF
                ReplyREc SFVRefNum W@ PBREC ioVRefNum W!
                PBREC Call SetVol       0=
                IF
                        ReplyREc SFFName  DUP
                        Call CreateResFile
                        Call OpenResFile 
                        Call ResError L_EXT SWAP
                ELSE
                        BEEP BEEP -1 0
                THEN
        ELSE
                BEEP -1 0
        THEN
        ;
        
Global   
: Close.File {  FileRef -- Result }
        InitPBREC
        FileRef PBREC ioRefNum W! 
        PBREC CALL CLOSE ;
 
Global
: FSRead { FileRef  RCount FBuffer -- ActCount Result }
        InitPBREC
        FileRef         PBRec IoRefNum          W!
        RCount          PBREC ioReqCount        !
        FBuffer         PBRec ioBUffer          !
        PBRec Call Read
        PBREC ioActCount @ Swap ;       
 
Global  
: FSWrite { FileRef  RCount FBuffer -- Actcount Result }
        InitPBREC
        FileRef         PBRec IoRefNum          W!
        RCount          PBREC ioReqCount        !
        FBuffer         PBRec ioBUffer          !
        PBRec Call Write
        PBREC ioActCount @ Swap ;       
 
Global
: FSGetFpos { FileREf -- pos result }
        InitPBREC
        FileRef         PBRec IoRefNum          W!
        PBREc Call GetFPos
        PBREc ioPosOffset @ Swap ;
 
Global  
: FSSetFPos { FileRef Mode Offset -- Result }
        InitPBREC
        FileRef         PBRec IoRefNum          W!
        Mode            PBREC ioPosMode         W!
        Offset          PBRec ioPosOffset       !
        PBREc Call SetFPos ;
 
Global  
: FSGetEof { FIleRef -- EOF Result }
        InitPBREC
        FileRef         PBRec IoRefNum          W!
        PBRec Call GetEOF
        PBREc ioMisc @ Swap  ;
 
Global  
: FSSetEof { FIleRef Offset --  Result }
        InitPBREC
        FileRef         PBRec IoRefNum          W!
        Offset          PBRec ioMisc            !
        PBRec Call SetEOF ;
 
Global
: FSAllocate { FIleRef AddBYtes -- Count Result }
        InitPBREC
        FileRef         PBRec IoRefNum          W!
        AddBYtes        PBREC ioReqCount        !
        PBRec Call Allocate
        PBREC ioActCount @ Swap ;
 
Global
: FSDelete
        InitPBREC
        Get.All
        ReplyREc SFGood C@
        IF
                ReplyREc SFFName  PBREC ioNamePtr !  
                ReplyREc SFVRefNum W@ PBREC ioVRefNum W! 
                PBREC Call Delete
        Then
         ;
 
Global  
: GetFInfo 
        InitPBREC
        Get.All
        ReplyREc SFGood C@
        IF
                ReplyREc SFFName  PBREC ioNamePtr !  
                ReplyREc SFVRefNum W@ PBREC ioVRefNum W! 
                PBREC Call GetFileInfo
        Then
         ;
 
Global   
: SetFinfo { FNamePtr VRef FInfoPtr }
        FNamePtr PBRec ioNamePtr !
        VRef    PBREC ioVRefNum W!
        PBREc Call GetFileInfo
        FinfoPtr PBREc FFinderInfo FInfo CMove
        PBREc Call SetFileInfo
        ;
 
        
        
Global
: GetVInfo { VolName VolRef }
        InitPBRec
        -1              PBRec VVolIndex         W!
        VolRef  PBRec ioVRefNum         W!
        VolName PBRec ioNamePtr         !
        PBRec Call GetVolInfo
        ;
 
Global  
: GetDefVol 
        InitPBRec
        NameBuffer PBRec ioNamePtr  !
        PBRec Call GetVol
;
 
Global
: SetDefVol { VolNamePtr VolRef }
        InitPBRec
        -1              PBRec VVolIndex         W!
        VolRef  PBRec ioVRefNum         W!
        VolNamePtr      PBRec ioNamePtr         !
        PBRec Call SetVol
        ;
 
Global
: FSFlushVol { VolNamePtr VolRef }
        InitPBRec
        -1              PBRec VVolIndex         W!
        VolRef  PBRec ioVRefNum         W!
        VolNamePtr      PBRec ioNamePtr         !
        PBRec Call FlushVol
        ;
 
Global  
: FSUnmount { VolNamePtr VolRef }
        InitPBRec
        -1              PBRec VVolIndex         W!
        VolRef  PBRec ioVRefNum         W!
        VolNamePtr      PBRec ioNamePtr         !
        PBRec Call UnMountVol
        ;
 
Global  
: FSEject { VolNamePtr VolRef }
        InitPBRec
        -1              PBRec VVolIndex         W!
        VolRef  PBRec ioVRefNum         W!
        VolNamePtr      PBRec ioNamePtr         !
        PBRec Call Eject
        ;
        
        
( -------------------------------------------------------------------------)
 
( Utilities )
: Display.io (  -- )
        PBREc
        CR ." QLink"            DUP     QLink ?
        CR ." qType"            DUP     qType W@ .
        CR ." ioTrap "          DUP     ioTrap W@ .
        CR ." ioCmdAddr"        DUP     ioCmdAddr ?
        CR ." ioCompletion"     DUP     ioCompletion ?
        CR ." ioResult" DUP ioResult W@ .
        CR ." ioNamePtr"        DUP     ioNamePtr DUP ? @ Space Count Type
        CR ." ioVRefNum"        DUP     ioVRefNum W@ .
 
        CR ." ioRefNum"         DUP ioRefNum W@ .
        CR ." ioVersNumber"     DUP     ioVersNumber C@ .
        CR ." ioPermissn"       DUP     ioPermissn C@ .
        CR ." ioMisc"           DUP     ioMisc  ?
        CR ." ioBUffer" DUP     ioBUffer ?
        CR ." ioReqCount"       DUP     ioReqCount ?
        CR ." ioActCount"       DUP     ioActCount ?
        CR ." ioPosMode"        DUP     ioPosMode W@ .
        CR ." ioPosOffset"              ioPosOffset ?
;
 
: Display.File (  -- )
        PBREc
        CR ." QLink"            DUP     QLink ?
        CR ." qType"            DUP     qType W@ .
        CR ." ioTrap "          DUP     ioTrap W@ .
        CR ." ioCmdAddr"        DUP     ioCmdAddr ?
        CR ." ioCompletion"     DUP     ioCompletion ?
        CR ." ioResult" DUP ioResult W@ .
        CR ." ioNamePtr"        DUP     ioNamePtr DUP ? @ Space Count Type
        CR ." ioVRefNum"        DUP     ioVRefNum W@ .
        
        
        CR ." FRefNum"          DUP FRefNum W@ .
        CR ." FVersNumber"      DUP     FVersNumber C@ .
        CR ." FFill1"           DUP     FFill1 C@ .
        CR ." FDirIndex"        DUP     FDirIndex       W@ .
        CR ." FFlAttributes" DUP        FFlAttributes C@ . 
        CR ." FFlVersNum"       DUP     FFlVersNum C@ .
        
                DUP FFinderInfo 
        CR ." FdType "          DUP FdType 4 Type
        CR ." FdCreator "       DUP FdCreator 4 Type
        CR ." FdFlags"          DUP FdFlags W@ .
        CR ." FdPoint"          DUP FdPoint DUP W@ . 2+ W@ .
        CR ." FdFldr"                   FdFldr W@ .
                        
        CR ." FFileNum"         DUP     FFileNum ?
        CR ." FFileStBlk"       DUP     FFileStBlk W@ .
        CR ." FFilLogLen"       DUP FFilLogLen ?
        Cr ." FFilPhyLen"       DUP FFilPhyLen ?
        CR ." FResStBlk"        DUP FResStBlk W@ .
        CR ." FResLogLen"       DUP FResLogLen ?
        CR ." FResPhyLen"       DUP FResPhyLen ?
        CR ." FFilCrDat"        DUP FFilCrDat ?
        CR ." FFilMdDat"        FFilMdDat ?
;
 
 
 
 
: Display.Vol ( ioPBPtr -- )
        PBREc
        CR ." QLink"            DUP     QLink ?
        CR ." qType"            DUP     qType W@ .
        CR ." ioTrap "          DUP     ioTrap W@ .
        CR ." ioCmdAddr"        DUP     ioCmdAddr ?
        CR ." ioCompletion"     DUP     ioCompletion ?
        CR ." ioResult"         DUP ioResult W@ .
        CR ." ioNamePtr"        DUP     ioNamePtr DUP ? @ Space Count Type
        CR ." ioVRefNum"        DUP     ioVRefNum W@ .
 
        CR ." VFiller2"         DUP VFiller2 ?
        CR ." VVolIndex"        DUP VVolIndex W@ .
        CR ." VCrDate"          DUP VCrDate ?
        CR ." VLsBkUp"          DUP VLsBkUp ?
        CR ." VAtrb"            DUP VAtrb W@ .
        CR ." VNumFls"          DUP VNumFls W@ .
        CR ." VDirSt"           DUP VDirSt W@ .
        CR ." VBlLn"            DUP VBlLn W@ .
        CR ." VNmAlBLks"        DUP VNmAlBLks W@ .
        CR ." VAlBlkSiz"        DUP VAlBlkSiz ?
        CR ." VClpSiz"          DUP VClpSiz ?
        CR ." VAlBlSt"          DUP VAlBlSt W@ .
        CR ." VNxtFNum"         DUP VNxtFNum ?
        CR ." VFrBlk"           VFrBlk W@ .
;