\\                  *** File Interface ***        32b  07may97py                                                                This file contains the rest of the file interface. The basic    part of the file interface is already in the kernel, therefore  this file contains only the higher level parts, as file lists   (ls, files), path search and friends.                                                                                           Geschrieben von Bernd Pennemann                                 An 32bit angepasst von georg rehfeld                            PC-Version von Bernd Paysan                                                                                                                                                                                                                                                                                                                                                                                                                                     \ File interface load and patch block             32b  16jan05py                                                                \needs >len : >len ( addr -- a l ) dup $100 0 scan drop over - ;                                                                $35 +load \ Load structs for interpreter                                                                                        \ Load additional File Interface                                DOS joined Module DOS  1 $30 +thru   Module;                                                                                    \ Load additional Memory Management                             \ Memory joined Module Memory  $31 $33 +thru   Module;                                                                                                                                                                                                                                                                                                                                          \ disk errors                                     32b  09mar97py                                                                defined? go32 defined? win32 or [IF]                            : >diskerror ( -n -- string )                                     "error push $400 - >error "error @ ;                                                                                          : .diskerror  ( -n -- ) >diskerror count type ;                                                                                 : ?diskabort   ( -n -- )                                          dup 0< IF $400 - dup lasterr ! throw  THEN  drop ;                                                                            : (diskerr ( error# string -- ) pushi/o standardi/o               >r .diskerror r> throw ;                                                                                                      ' (diskerr IS diskerr                                           [THEN]                                                          \ disk errors                                          17oct99py[IFDEF] unix                                                    libc strerror int (int) strerror                                Create errorstring $40 allot                                    : >diskerror ( -n -- string )                                     negate strerror >len errorstring place  errorstring ;         : .diskerror  ( -n -- ) >diskerror count type ;                                                                                 : ?diskabort   ( -n -- )                                          dup 0< IF dup $400 - lasterr ! >diskerror >r 'abort                       r> "error ! lasterr @ throw  THEN  drop ;           : (diskerr ( error# string -- ) pushi/o standardi/o               >r .diskerror r> throw ;                                                                                                      ' (diskerr IS diskerr                                           [THEN]                                                          \ create and search for files                     32b  09mar97py[IFDEF] go32                                                    Create dta &46 allot  \needs go32 -2 allot                      : fsfirst  ( C$ attr -- ior )           $60814E00 ms-dos ;      : fsnext   ( -- ior )                   $00814F00 ms-dos ;      : dcreate  ( C$ -- ior )                $20813900 ms-dos ;      : ddelete  ( C$ -- ior )                $20813A00 ms-dos ;      : dsetpath ( C$ -- ior )                $20813B00 ms-dos ;      : fdelete  ( C$ -- ior )                $20814100 ms-dos ;      : fsetdta  ( addr -- )                  $20001A00 ms-dos drop ; : dgetpath ( buffer drive -- ior )      $22814700 ms-dos ;      : frename  ( C$old C$new -- ior )       swap $21815600 ms-dos ; : dfree    ( drive+1 -- total_units free_units b/unit )           $20703600 ms-dos rot Q* >r $FFFF and swap $FFFF and r> ;      \ : pexec  ( name parameter -- ior )      $30814B00 ms-dos ;    [THEN]                                                          \ create and search for files                     32b  22jan10py[IFDEF] unix                                                    [DEFINED] glibc [DEFINED] bsd or [IF]                                  Variable dent-basep                                             libc getdirentries [ 4 ] ints (int) getdirentries               : getdents  dent-basep  getdirentries                             dup 0= IF  dent-basep off  THEN ;                      [IFDEF] bsd                                                            libc lstat <rev> [ 2 ] ints (int) lstat                         libc stat  <rev> [ 2 ] ints (int) stat                   [ELSE] libc lxstat <rev> [ 3 ] ints (int) __lxstat                     libc xstat  <rev> [ 3 ] ints (int) __xstat                      : lstat  1 lxstat ;     ( buf name -- r )                       : stat   1 xstat ;      ( buf name -- r )  [THEN]               libc wcwidth int (int) wcwidth ( u -- n )                \       libc wcswidth ptr int (int) wcswidth ( addr u -- n )    \ non-glibc part                                       13nov10py                                                                [ELSE] legacy on                                                       3 libc (getdents getdents      ( count dirp fd -- n )           : getdents  swap rot (getdents ;                                2 libc lstat lstat            ( buf name -- r )                 2 libc stat stat              ( buf name -- r )                 legacy off                                                      libc wcwidth int (int) wcwidth ( u -- n )                [THEN]                                                          libc mkdir <rev> int int (int) mkdir   ( mode pathname -- r )   libc rmdir int (int) rmdir             ( pathname -- r )        libc chdir int (int) chdir             ( pathname -- r )        libc unlink int (int) unlink           ( pathname -- r )        libc getcwd <rev> int int (int) getcwd ( size buf -- buf )                                                                      \ create and search for files                     32b  13nov10pylibc fnmatch <rev> [ 3 ] ints (int) fnmatch ( fs strs pat -- f )libc rename <rev> int int (int) rename ( newpath oldpath -- r ) libc statfs <rev> int int (int) statfs ( buf path -- r )        [IFDEF] osx                                                     libc ftruncate int llong (int) ftruncate ( dl fd -- r )         [ELSE]                                                          libc ftruncate int llong (int) ftruncate64 ( dl fd -- r )       [THEN]                                                          libc execve <rev> [ 3 ] ints (int) execve ( envp argv file -- r)libc fork (int) fork                   ( -- pid )               libc mmap <rev> [ 6 ] ints (int) mmap                                   ( offset fd flags prot u addr -- addr )                 libc munmap <rev> int int (int) munmap ( u addr -- n )          libc setlocale int ptr (ptr) setlocale ( locale addr -- addr )                                                                  \ create and search for files                     32b  22jan10py                                                                Variable dirbuf dirbuf off                                      Variable dirpath                                                Variable direndp                                                Create dta $50 allot [IFDEF] bsd $100 allot [THEN]              Create pattern $80 allot                                        | dta 1 cells + AConstant diroff                                | dta 2 cells + AConstant dirsize                               | dta 3 cells + AConstant dirfd                                 : dirstat ( -- 0/ior )  dta @ >len 1+ direndp @ swap move         dta $10 +  dirpath @  2dup stat                                 IF  lstat  ELSE  2drop 0  THEN ;                              : ?allot ( n addr -- )  dup @ IF  2drop EXIT  THEN                [ also Memory ]  Handle! [ previous ] ;                                                                                       \ create and search for files                     32b  22jan10py                                                                forward makec$                                                  : fsend ( -- )  dirfd @ ?dup IF  _close drop  THEN  dirfd off ; : fsnext ( -- ior )                                               BEGIN  diroff @ dirsize @ =                                            IF  diroff off                                                      dirfd @ dirbuf @ $400 getdents                                  dup 0 max dirsize ! /ior dup 0<=                                IF  fsend dup 0= or                                                 EXIT  THEN  drop                                        THEN  0  diroff @ dirbuf @ +                                          [IFDEF] bsd 4+ [ELSE] 8+ [THEN] dup w@ diroff +!  [IFDEF] glibc 3 + [ELSE] [IFDEF] bsd 4+ [ELSE] 2+ [THEN] [THEN]         dup dta !  pattern  fnmatch 0= UNTIL                     dirstat ;                                                     \ create and search for files                     32b  17oct99py                                                                : fsfirst ( C$ attr -- ior )   drop >len makec$                   dup dirpath !  diroff off  dirsize off                          $400 dirbuf ?allot                                              >len '/ -scan over + dup >r >len 1+ pattern swap move           '. r@ c! 0 r@ 1+ c! r> direndp !                                0 0 _open                                                       dup dirfd ! dup /ior swap -1 = ?EXIT  drop  fsnext ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                          \ open-dir read-dir close-dir filename-match           15jul01py                                                                libc opendir int (int) opendir                                  libc readdir int (int) readdir                                  libc closedir int (int) closedir                                : open-dir ( addr u -- wdirid wior )                              makec$ opendir dup 0= /ior ;                                  : close-dir ( wdirid -- wior )  closedir /ior ;                 : read-dir ( addr u1 wdirid -- u2 flag wior )                     readdir dup 0= IF  drop 2drop 0 0 0 EXIT  THEN                  swap >r  $B + >len  dup r@ >                                    IF  r> min -$424 >r  ELSE  rdrop 0 >r  THEN                     dup >r rot swap move r> true r> ;                             : filename-match ( c-addr1 u1 c-addr2 u2 -- flag )                pattern swap 2dup + >r move 0 r> c!  makec$                     0 swap pattern fnmatch 0= ;                                   \ create and search for files                     32b  15jul01py                                                                Create statbuf 15 cells allot                                                                                                   : dcreate  ( C$ -- ior ) mkdir ;                                : ddelete  ( C$ -- ior ) rmdir ;                                : dsetpath ( C$ -- ior ) chdir ;                                : fdelete  ( C$ -- ior ) unlink ;                               : fsetdta  ( addr -- )   drop ;                                 : dgetpath ( buffer drive -- ior )  drop $100 swap getcwd 0= ;  : frename  ( C$old C$new -- ior )  swap rename ;                : dfree    ( C$ -- total_units free_units b/unit )                statbuf swap statfs drop statbuf 2 cells + 2@ swap              statbuf cell+ @ ;                                                                                                             [THEN]                                                          \ Win32 file links                                     16may00py[IFDEF] win32                                                   legacy on                                                       1 kernel32 DeleteFile DeleteFileA                               1 kernel32 RemoveDirectory RemoveDirectoryA                     1 kernel32 CreateDirectory CreateDirectoryA                     1 kernel32 SetCurrentDirectory SetCurrentDirectoryA             2 kernel32 GetCurrentDirectory GetCurrentDirectoryA             2 kernel32 MoveFile MoveFileA                                   2 kernel32 FindFirstFile FindFirstFileA                         2 kernel32 FindNextFile FindNextFileA                           1 kernel32 FindClose FindClose                                                                                                  create DTA &11 cells &260 + &14 + allot                                $20 allot                                                | Variable find-handle                                          \ create and search for files                     32b  09mar97py: fsnext   ( -- ior )  dta find-handle @ FindNextFile 0=          dup IF  find-handle @ FindClose drop  THEN ;                  : fsfirst  ( C$ attr -- ior )  drop dta swap FindFirstFile        dup find-handle ! 0< ;                                        : dcreate  ( C$ -- ior )                CreateDirectory ;       : ddelete  ( C$ -- ior )                RemoveDirectory ;       : dsetpath ( C$ -- ior )                SetCurrentDirectory ;   : fdelete  ( C$ -- ior )                DeleteFile ;            : fsetdta  ( dta -- )                   drop ;                  : dgetpath ( buffer drive -- ior )                                drop $100 GetCurrentDirectory ;                               : frename  ( C$old C$new -- ior )       swap MoveFile ;         : dfree    ( drive+1 -- total_units free_units b/unit )           drop $1000 $800 $400 ;                                        [THEN]                                                          \ sh                                                   11jul99py                                                                : PC>sh  cr curon  r> execute  curoff ;                         Defer >sh       ' PC>sh IS >sh                                  [IFDEF] go32                                                    : system ( addr count -- ret )                                    >sh pad swap 2dup + 0 swap c! move  pad $1000FF07 ms-dos ;    : sh  '# parse system drop ;                                    [ELSE] [IFDEF] unix                                             libc system int (int) system    ( C$ -- r )                     : sh  '# parse tuck pad swap move pad + 0 swap c! pad system      drop ;                                                                                                                                                                                                                                                                                                                        \ sh                                                   23oct99py                                                                [ELSE] [IFDEF] win32                                            \ library msvcrt msvcrt.dll       0 msvcrt system system        Variable app-win                                                library shell32 shell32.dll                                     6 shell32 ShellExecute ShellExecuteA                            | Create "open S" open" here over allot swap move 0 c,          | Create fnbuf $100 allot                                       : system ( addr -- r ) >len  2dup bl scan tuck bl skip drop >r    - 0 over fnbuf + c! fnbuf swap move                             1 0 r> >len 0<> and fnbuf "open app-win @ ShellExecute ;      : sh  '# parse tuck pad swap move pad + 0 swap c! pad system      drop ;                                                        [ELSE] : sh  '# parse 2drop ; [THEN] [THEN] [THEN]                                                                              \ env$                                                 05apr09py                                                                | : env@  mroot $20 + @ ;                                       : env$ ( addr count -- addr' count' )  env@                       BEGIN  BEGIN  >r 2dup r@ @ -text  WHILE                                       r> cell+ dup @ 0= UNTIL                                  2drop drop 0 0 exit  THEN                                       r> cell+ 2dup cell- @ + c@ '= =  UNTIL                   cell- @ + 1+ nip >len ;                                                                                                       : .env ( -- ) env@                                                BEGIN  dup @  WHILE  cr dup @ >len type cell+  stop? UNTIL      THEN  cr drop ;                                                                                                                                                                                                                                               \ position into files                             32b  05feb95py                                                                : position      ( offset handle -- false/-error )                  0 fseek  dup 0< ?exit   drop false ;                         : position?     ( handle -- offset )                               0 swap 1 fseek   dup ?diskabort ;                                                                                            \ twiggling the file variables                    32b  11aug86re                                                                : ?fcb ( fcb/ff -- fcb )                                          ?dup 0= abort" not for direct access !"  dup assign? ;                                                                        : .fcb      ( fcb -- ) cell+  ?fcb         \ print filename        dup filehandle @ 2 .r space                                     dup filesize @ 6 .r space                                       dup .file   filename >len type ;                             \ PATHes                                          32b  22jun98py                                                                [IFDEF] unix ': [ELSE] '; [THEN]  Constant pathsep                                                                              Create pathes  $80 allot        \ counted string of pathes         pathes off                                                                                                                   : .pathes       ( -- )          \ print the pathes                 cr  3 spaces  pathes count type ;                                                                                            : setpath       ( addr len -- )  \ set's the list of pathes          under  pathes count + swap move                                 pathes c@ + pathes c!                                           pathsep  pathes count + c!   pathes c@ 1+ pathes c! ;                                                                      \\ PATH : see elsewhere in this file                            \ search for files                                32b  09dec01pyalso Memory | $400 NewPtr Value workspace previous              [IFDEF] unix                                                    : try.path   ( addr len filename attr -- f )  \ true if found     drop -rot  workspace swap   2dup + >r  move                     '/ r@ c!  >len 1+  r> 1+ swap move                              workspace DTA $10 + swap  stat 0= ;                           [ELSE]                                                          : try.path   ( addr len filename attr -- f )  \ true if found     >r  -rot  workspace swap   2dup + >r   move                     '\ r@ c!  >len 1+  r> 1+ swap  move                             dta fsetdta  workspace r>  fsfirst 0= ;                       [THEN]                                                          : makec$     ( addr len -- c$ )        \ make addr len to a c$    workspace swap  2dup + >r   move     \ in "workspace"           r> 0 swap c!  ( make a c$ ) workspace ;                       \ search for files                                32b  09dec01py                                                                | 7 Constant defaultattr               \ find all filetypes     | : path.file? ( filename -- ff/ C$ tf ) >r pathes count over 0     BEGIN   r@  defaultattr   try.path                                      IF  2drop rdrop workspace true exit  THEN                       pathsep skip dup  WHILE  2dup  pathsep scan                     2swap  2 pick -  REPEAT  rdrop nip ;                | : (>path.file  dup path.file?  IF  nip  THEN ;                ' (>path.file IS >path.file                                                                                                     : (searchfile   ( fcb -- ff/ C$ tf )   \ search for file in path   ?fcb filename  path.file?  ;       \ and in act. directory   : searchfile    ( fcb -- C$ )   \ file was found in path           (searchfile  0= abort" File not found"  ;                                                                                    \ Dateidatum und -uhrzeit ausgeben                     00jan80py                                                                [IFDEF] go32                                                    : @time   dta &22 + w@ dta &24 + w@ $10 lshift or ;             : @attr   dta &21 + c@ ;                                        : @length dta &28 +  @ ;                                        : dtaname  dta $20 + ;                                          : >hms  $FFFF and 2* $40 /mod  $40 /mod  $1F and swap 1- rot ;  : >ymd  $10 rshift $20 /mod  $10 /mod  &1980 + swap 1- swap ;   [THEN]                                                                                                                                                                                                                                                                                                                                                                                                                                                          \ Dateidatum und -uhrzeit ausgeben                     22jan10py                                                                [IFDEF] unix                                                    \ 1 libc localtime localtime      ( &time_t -- tm )                                                                             : @time   dta [IFDEF] bsd $30 [ELSE] $38 [THEN] + @ ;           : @attr   dta $18 + w@ ;                                        : @length dta [IFDEF] bsd $40 [ELSE] $24 [THEN] + @ ;           : dtaname  dta @ ;                                              : !dtaname ( addr u -- ) makec$ dta ! ;                         : >hms  sp@ localtime nip @+ @+ @ swap rot ;                    : >ymd  sp@ localtime nip $C + @+ @+ @ ;                        [THEN]                                                                                                                                                                                                                                                          \ Dateidatum und -uhrzeit ausgeben                     06dec03py[IFDEF] win32                                                   3 kernel32 FileTimeToDosDateTime FileTimeToDosDateTime          | Variable FatDate                                              | Variable FatTime                                              | : (@time ( -- )                                                   FatTime FatDate dta cell+ FileTimeToDosDateTime drop ;      : @time   (@time FatTime @ FatDate @ $10 lshift or ;            : @attr   dta @ ;                                               : @length dta 8 cells + @ ;                                     : dtaname  dta &11 cells + ;                                    : !dtaname ( addr u -- )  tuck dtaname swap move                  0 swap dtaname + c! ;                                         : >hms  $FFFF and 2* $40 /mod  $40 /mod  $1F and swap 1- rot ;  : >ymd  $10 rshift $20 /mod  $10 /mod  &1980 + swap 1- swap ;   [THEN]                                                          \ Dateidatum und -uhrzeit ausgeben                     07aug10pyVariable  #col                                                  : >time  ( time -- addr count )  base push decimal   >hms         0 <<# # # ': hold drop # # ': hold drop # # #> #>> ;          | : .dtatime ( time -- )  >time type ;                          : >date ( date -- string len )  base push decimal  >ymd           0 <<#  # # 2drop  >r S" janfebmaraprmayjunjulaugsepoctnovdec"          r> 0 max &11 min dup dup + + /string 3 min                      over + 1- DO  I c@ hold -1  +LOOP  0 # #  #> #>> ;     | : .dtadate      ( date -- ) >date type ;                      | : .dtaname      ( C$ -- )       \ C$ is addr of name              >len under type  negate $10 + 1 max spaces ;                [IFDEF] unix                                                    | : .dtalname      ( C$ -- )       \ C$ is addr of name             >len under type  negate $28 + #col @ - 1 max spaces ;       [THEN]                                                          \ print dta and directory                        32b   06dec03py                                                                Variable dir"                                                   | Variable  -opt                                                | Variable +opt                                                 : -opt? ( Char -- flag ) $1F and -opt swap  Bit@ ;              : -opt! ( Char -- flag ) $1F and -opt swap  +Bit ;              : +opt! ( Char -- flag ) $1F and +opt swap  +Bit ;              | : +cr  cr #col @ spaces ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     \ print dta and directory                        32b   07aug10pydefined? go32 defined? win32 or [IF]                            : .dta  'L -opt?  0= IF  dtaname >len under type                        @attr $10 and IF ." /" 1+  THEN                                 @attr   8 and IF ." :" 1+  THEN negate $E + spaces              col cols $F - u>  IF  +cr  THEN                           ELSE  0 0  <<#  @attr  S" RHSVDA" bounds                                        DO  dup 1 and IF  i c@ hold  THEN  2/  LOOP              drop  #>  6 over - spaces type #>> space                     dtaname  .dtaname   @length  8 .r 2 spaces                      @time .dtatime  2 spaces  @time .dtadate +cr  THEN ;    [IFDEF] win32 &11 cells &260 + &14 + [ELSE] &44 [THEN]          Constant denlen                 '\  Constant dirsep             | : <path dirsep -scan over 1+ c@ ': = IF  2 max  THEN ;        | : ?dir  $10 and ; hmacro                                      | : all-files s" *.*" ;                         [THEN]          \ print dta and directory                        32b   07aug10py[IFDEF] unix                                                    : .dta  'L -opt?  0= IF  dtaname >len under type                        S"  |  /     @ =   " drop @attr $C >> + c@ emit 1+              negate $E + spaces col cols $F - u>  IF  +cr  THEN        ELSE  0 0  <<#  @attr  S" xwrxwrxwr" bounds                                     DO    dup 1 and IF i c@ ELSE '- THEN hold 2/                    LOOP  3 >> s" -pc-d-b---l-s---" drop + c@ hold              #>  &10 over - spaces type  #>>  space                    dtaname  .dtalname   @length  8 .r 2 spaces                     @time .dtatime  2 spaces  @time .dtadate +cr  THEN ;    '/ constant dirsep              $4C Constant denlen             | : <path dirsep -scan ;                                        | : ?dir  $4000 and ; hmacro                                    | : all-files s" *" ;                                           [THEN]                                                          \ print dta and directory                        32b   06dec03py: .dta?  @attr $20 and 0<>  'N -opt? invert or   'O -opt? xor     IF  .dta  THEN ;                                              : ((dir  ( addr attr -- flag )  fsfirst                           BEGIN  0= WHILE stop? IF  true exit  THEN  .dta?                       fsnext  REPEAT  false ;                                | : insdir ( addr u addr -- ) >len <path + >r r@ >len >r            2dup + 1+ r> 1+ move r> swap 2dup + >r move dirsep r> c! ;  | : deldir ( addr -- ) >len <path 2dup + >r 1-                      <path + r> >len 1+ rot swap move ;                          | : +path ( path addr u -- ) rot swap 2dup + >r move 0 r> c! ;  | : ?break  IF  2drop 2drop true rdrop r> dir" !  THEN  ;       | : ?+cr  'L -opt?  0= IF  +cr  THEN  ;                         : +dta  dtaname >len tuck s" .." drop -text swap 2 > or           IF    dtaname >len dir" @ place  dir" @ c@ 1+ dir" +!  THEN ;                                                                 \ ((hir (dir                                           06dec03py: get-dirs  over >len <path + all-files +path over $10 fsfirst    BEGIN  0=  WHILE  stop? ?break  @attr ?dir IF  +dta  THEN              fsnext  REPEAT ;                                       : ((hir  ( addr count addr attr -- flag )  recursive              dir" @ >r  get-dirs  2over 2over drop >len <path + -rot +path   2dup ((dir drop dir" @ r@                                       ?DO  I count type ." :" 4 #col +! +cr                                over I count rot insdir 2over 2over ((hir -4 #col +!            IF  2drop 2drop true r> dir" ! unloop exit THEN                 over deldir col #col @ 4+ = IF at? 4- at ELSE +cr THEN          I c@ 1+  +LOOP  r> dir" ! 2drop 2drop false ;            : (dir ( attr addr len -- ) cr dta fsetdta  pad dir" !  'R -opt?  IF    0 #col ! rot >r 2dup makec$ >r                                  2dup <path nip /string r> r> ((hir                        ELSE  #col off  makec$ swap ((dir  THEN drop ;                \ primitives for fcb's                           32b   10oct99py                                                                : forthfiles         ( -- )     \ print a list of :                 file-link LIST>             \ forthword,filename,handle,len     cr .fcb  stop? IF unlist THEN ;                                                                                             \ Next Words are for export                                                                                                     : path          ( -- )          \ this is a smart word !        \   name count                                                     /parse dup 0=   IF  2drop  .pathes  exit  THEN                  over c@ pathsep =  IF  pathes off  1 /string  THEN              setpath ;                                                                                                                                                                                                                                                    \ Killfile                                             09mar09py                                                                : scanopt ( -- addr count )  +opt @ -opt ! +opt off               BEGIN  /parse dup  WHILE  over c@ '- =  WHILE                          1 /string bounds  ?DO  i c@ -opt!  LOOP                  REPEAT THEN ;                                                 | : dir$        ( -- addr )  scanopt makec$ ;                   : free?                                                         [IFDEF] unix  s" ." makec$  [ELSE]  0  [THEN]                     dfree  >r  cr                                                   dgetdrv 'A + emit ." : Von " over . ." Units (" swap r@         m* d. ." Bytes) sind " dup . ." (" r> m* d. ." Bytes) frei." ;                                                                                                                                                                                                                                                                \ Killfile                                             17may99py                                                                [IFDEF] unix                                                    : killfile  dir$  'A -opt? $80 and  'D -opt? $100 and or          fsfirst  ?diskabort  0                                          BEGIN  0=  WHILE  cr ." Kill? " .dta  'Y -opt? ?dup 0=                 IF  key $FF and capital 'J over = swap 'Y = or  THEN            IF  dtaname fdelete                                                 ?diskabort ."  killed" THEN fsnext REPEAT ;                                                                        : files scanopt  dup 0=  IF  2drop S" *"  THEN                    'A -opt? $80 and  'D -opt? $100 and or -rot (dir ;            [THEN]                                                                                                                                                                                                                                                          \ Killfile                                             09mar97py                                                                defined? go32 defined? win32 or [IF]                            : killfile  dta fsetdta  dir$ dup 'A -opt? IF $F ELSE 0 THEN      fsfirst  ?diskabort  >len '\ -scan                              over 1+ c@ ': = IF  2 max  THEN  0                              BEGIN  0=  WHILE  cr ." Kill? " .dta  'Y -opt? ?dup 0=                 IF  key $FF and capital 'J over = swap 'Y = or  THEN            IF  2dup + >r dtaname r> &14 move  over fdelete          ?diskabort ."  killed" THEN fsnext REPEAT 2drop ;                                                                             : files scanopt  dup 0=  IF  2drop S" *.*"  THEN                  $10 'A -opt? $F and + -rot (dir ;                             [THEN]                                                                                                                                                                                          \ File Interface User words                       32b  21jun01py                                                                : makefile    dir$ 0 fcreate dup ?diskabort fclose ?diskabort ; : rename      dir$ bl word count over + 0 swap c! frename                     ?diskabort ;                                      : from        isfile push  use ;         \ sets only fromfile                                                                   : "use ( addr count -- )  dup 0= abort" missing filename!"         ">tib USE ;                                                                                                                  : eof         ( -- f )        \ end of file ?                      isfile@  dup  filehandle @  position?  swap  filesize @ = ;                                                                                                                                                                                                                                                                  \ extend files                                    mod  25may03py                                                                | : addblock    ( n -- )        \ add block n to file               buffer dup b/blk bl fill update                                 b/blk isfile@ filesize +! Backup ;                                                                                          : (more   ( n -- )                                                  capacity swap bounds ?DO  I addblock  LOOP  ;                                                                               : more  ( n -- )   open  (more  close ;                                                                                                                                                                                                                                                                                                                                                                                                                         \ moving blocks                                   mod  03nov91py                                                                | : fromblock  ( blk -- addr )  fromfile @ (block ;             | : (copy ( from to -- )                                            dup isfile@  core?  IF  prev @ emptybuf  THEN                   swap >r  isfile@ [ memory ] >Purge                              r> fromblock GetMP dup >r HNoPurge  r> HPurge  Update ; dos | : blkmove ( from to quan --)    save-buffers  >r                  over r@ +  over u> >r  2dup u< r>  and                          IF    r@ r@ d+  r> 0 ?DO  -1 -2 d+  2dup (copy  LOOP            ELSE  r> 0 ?DO  2dup (copy  1 1 d+ LOOP  THEN                   save-buffers 2drop ;                                                                                                        : copy ( from to -- )           1 blkmove ;                     : convey ( [blk1 blk2] [to.blk -- )                               swap 1+ 2 pick - dup  0> 0= abort" No Sir"   blkmove ;        \ Allocating buffers index                             03nov91py                                                                | : range  ( from to -- to+1 from )                                 capacity 1- umin   swap   capacity 1- umin                      2dup > IF  swap  THEN  1+ swap ;                                                                                            : index ( from to -- )                                            range DO  cr  I 4 .r  space  I block  c/l type                            stop? ?LEAVE  LOOP ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ make, kill and set directories                  32b  09mar97py: killdir       dir$ ddelete ?diskabort ;                       : makedir       dir$ dcreate ?diskabort ;                       : pwd           here dgetdrv over 0 dgetpath ?diskabort         [IFDEF] go32    abs 'A + emit ." :/"  [ELSE]  drop  [THEN]                      >len type ;                                     : cd            dir$ dup c@  0= IF  drop pwd  exit  THEN                        dup 1+ c@ ': =    \ Laufwerk als Kopf?                          IF  dup c@ capital 'A - dsetdrv drop  THEN                      dsetpath ?diskabort ;                           \ Die allseits geforderten Unix-like-Aliases:                   ' files    Alias dir            ' files    Alias ls             ' rename   Alias mv             ' killfile Alias rm             \ ' free?    Alias df                                           : ll  'L +opt! ls ;                                                                                                             \ words for VIEWing                               32b  19oct98py                                                                | $400 Constant viewoffset      \ max. &512 Kbyte lange Files                                                                   : (view   ( %ffffffbbbbbbbbbb -- blk' )                            dup  0= ?exit                                                   viewoffset  u/mod  file-link                                    BEGIN  @ dup  WHILE  2dup cell+ fileno w@ = UNTIL  THEN         dup IF  cell+ dup assign?  dup searchfile drop  THEN            !files  drop  ;                                                                                                              also memory                                                     | : ~file ( fid -- )  dup unlink-file DisposHandle ;            previous                                                                                                                                                                                        \ missing ANS file words                               13nov10py: file-status ( c-addr u -- x ior )  !fid                         dup >r filename $1F fsfirst dta swap ior                        [IFDEF] fsend  fsend  [THEN]  r> ~file ;                      : delete-file ( addr count -- ior )                               !fid >r r@ filename fdelete ior  r> ~file ;                   : load-file ( u fileid -- ) isfile push isfile ! load ;         : flush-file ( fid -- ior ) isfile push isfile !                  ['] close! catch dup 0= IF drop ['] open catch THEN ;         : resize-file ( ud fileid -- ior )  >r over r@ filesize !         r@ reposition-file drop r@ ?pos dup IF rdrop EXIT THEN drop     [IFDEF] unix  r@ filehandle @ r> filesize @ 0 ftruncate ior     [ELSE]        -1 0 r> write-file [THEN] ;                     : rename-file ( addr1 u1 addr2 u2 -- ior )                        !fid >r !fid dup filename r@ filename frename ior swap          ~file r> ~file ;                                              \ Init path at boot time for Linux                     31may02pyalso Memory                                                     [IFDEF] unix                                                    | : ?path ( addr u -- )  over IF  setpath  ELSE  2drop  THEN ;  cold: pathes off  $400 NewPtr to workspace                            s" HOME" env$ ?path                                             s" BIGFORTH_PATH" env$ ?path                                    [ s" LIBDIR" env$ 2dup d0= [IF] 2drop                             s" /usr/local/lib/bigforth" [THEN] ] SLiteral setpath         [ s" SRCDIR" env$ 2dup d0= [IF] 2drop                             s" /usr/local/lib/bigforth/src" [THEN] ]                      SLiteral setpath ;                                        [ELSE]                                                          cold: $400 NewPtr to workspace ;                                [THEN] previous                                                                                                                 \\ direct access  diskchange?                     mod  03jan93py                                                                \ DOS primitives                                                                                                                | Variable (drv                 | Variable (r/w                 $10000000     | Constant b/dev                                  b/dev b/blk / | Constant blk/dev                                                                                                Code mediach   ( drive -- flag )   \ false = no change               SP ) A7 -) move   .w 9 # A7 ) move   $D trap                    .l 4 A7 addq   D0 ext   D0 SP ) move   Next   end-code                                                                     Code getbpb   ( drive -- bpb )                                       SP ) A7 -) move  .w 7 # A7 ) move                               $D trap   .l 4 A7 addq   D0 SP ) move  Next end-code                                                                       \\ blk/drv getblocks                                   03jan93py                                                                | : R/Werr  ( err# -- )                                             (r/w @ IF  " write "  ELSE  " read "  THEN diskerr ;        | : ?R/Werr  ( err# -- ) dup 0< IF  R/Werr  THEN  drop ;                                                                        Create bpbs     $10 cells allot                                 | : bpb ( -- addr )  bpbs  (drv @ cells + ;                     | : getblocks  (drv @  getbpb bpb ! ;                           : b/drv  ( -- n ) 0 drv? (drv !  bpb @ >r                         (drv @ mediach dup ?R/Werr                                      r@ 0= or  IF  getblocks rdrop  bpb @ >r  THEN                   r@ 4+ w@  r> $E + w@ Q* ;                                     : blk/drv  ( -- n )                                               isfile@ 0= IF b/drv b/blk / ELSE defers capacity THEN ;       ' blk/drv IS capacity                                           \\ readsector writesector                         mod  03jan93py                                                                Code rwabs   ( drv begsec #sec lbuf r/w -- flag )                    SP )+ $001F # movem   A7 USP move                               $FFFE # D3 cmpi  > IF  D3 A7 -) move   -1 D3 moveq  THEN        .w D4 A7 -) move                    \ Drive                        D3 A7 -) move                    \ Startsektor                  D2 A7 -) move                    \ Anzahl Sektoren           .l D1 A7 -) move                    \ Buffer                    .w D0 A7 -) move                    \ r/w-Flag                  4 # A7 -) move                      \ Funktionsnummer           $0D trap   .l USP A7 move                                       .l D0 SP -) move                    \ Fehlerflag            Next end-code                                                                                                                                                                                  \\ (drvinit                                            03jan93py                                                                also Memory                                                     Variable R/Wbuffer  $200 ,                                                                                                      | : drvinit  bpbs $40 erase  dgetdrv drive R/Wbuffer @ 0=           IF  R/Wbuffer 4+ @ $04810001 gemdos R/Wbuffer ! THEN ;                                                                      drvinit                                                         cold: drvinit ;                                                                                                                 | : R/Walloc ( buflen -- )  dup R/Wbuffer 4+ @ >                    IF  dup R/Wbuffer 4+ ! R/Wbuffer @ $04910001 gemdos R/Werr          $04810001 gemdos R/Wbuffer ! exit  THEN  drop ;         toss                                                            bye: r> R/Wbuffer dup push off >r ;                             \\ FileR/W                                             03jan93py                                                                | : R/Wsec ( r/w pos bpb -- ) rot >r >r (drv @ swap                 r@ w@ / r> $C + w@ + 1 R/Wbuffer @ r> rwabs ?R/Werr ;       | : R/Wrest ( addr pos1 len1 bpb -- addr pos2 len2 )                >r over r@ w@ 1- and 0= over r@ w@ > and over 0= or             IF  rdrop exit  THEN  r@ w@ R/Walloc  0 2 pick r@ R/Wsec        dup 2over r@ w@ under 1- and under - >r R/Wbuffer @ +           rot r> min  (r/w @  0= IF  >r swap r>  THEN  move               (r/w @  IF  1 2 pick r@ R/Wsec  THEN                            r> w@ 2 pick over 1- and - dup >r /string rot r> + -rot ;   | : R/Wmid ( addr pos1 len1 bpb -- addr pos2 len2 )                 >r dup r@ w@ < IF  rdrop exit  THEN                             (drv @ 2 pick r@ w@ / r@ $C + w@ + 2 pick r@ w@ / 5 pick        (r/w @ rwabs ?R/Werr  dup r> w@ under / * dup >r /string        rot r> + -rot ;                                             \ stdin stdout stderr (linux)                          07jul01py                                                                [IFDEF] unix                                                    : set-file ( fd fcb -- )  >r 0 over 2 fseek                       dup $7FFFFFFF umin r@ filesize !                                0 max r@ fileOSpos !  r> filehandle ! ;                                                                                       file-link @                                                     File stdin  DOES> cell+ dup @ ?EXIT  >r s" stdin"  r@ assign         0 r@ set-file  r> ;                                        File stdout DOES> cell+ dup @ ?EXIT  >r s" stdout" r@ assign         1 r@ set-file  r> ;                                        File stderr DOES> cell+ dup @ ?EXIT  >r s" stderr" r@ assign         2 r@ set-file  r> ;                                        file-link !  \ these three aren't real files                    [THEN]                                                          \ exports                                              08aug08py[IFDEF] win32  export DOS app-win  time&date source-id                 open-file create-file close-file delete-file                    r/o r/w w/o bin  read-file write-file flush-file                file-position reposition-file  file-size resize-file            path killfile free? makefile rename from "use eof files         (more more copy convey index killdir makedir pwd dir            CD free? LS LL MV RM (view sh ;                          [ELSE] export DOS  time&date source-id stdin stdout stderr             open-file create-file close-file delete-file                    open-dir close-dir read-dir filename-match                      r/o r/w w/o bin  read-file write-file flush-file                file-position reposition-file  file-size resize-file            path killfile free? makefile rename from "use eof files         (more more copy convey index killdir makedir pwd dir            CD free? LS LL MV RM (view sh ;  [THEN]                  \ HandToHand PtrToHand PtrToXHand                      18apr91py                                                                DOS also                                                                                                                        : HandToHand ( MP1 -- MP2 ) dup GetHandleSize under               NewHandle >r @ r@ @ rot move r> ;                                                                                             : PtrToHand  ( addr -- MP ) dup GetPtrSize    under               NewHandle >r @ r@ @ rot move r> ;                                                                                             : PtrToXHand ( addr MP -- ) dup >r over GetPtrSize                SetHandleSize r> @ over GetPtrSize move ;                                                                                                                                                                                                                                                                                     \ HandAndHand PtrAndHand                               11jun88py                                                                : HandAndHand ( MP1 MP2 -- ) dup >r                               over GetHandleSize  over GetHandleSize + SetHandleSize          dup @ swap GetHandleSize r@ @ r> GetHandleSize +                swap >r r@ - r> move ;                                                                                                        : PtrAndHand ( Addr MP -- ) dup >r                                over GetPtrSize  over GetHandleSize + SetHandleSize             dup GetPtrSize r@ @ r> GetHandleSize +                          swap >r r@ - r> move ;                                                                                                                                                                                                                                                                                                                                                                        \ .Heap                                                11oct91py: .Heap ( -- ) HeapStart  base push  HeapSem lock                 BEGIN  cr dup @  WHILE  hex dup 8+ 6 u.r ': emit                       dup @ $C - 7 u.r dup NextBlock 4- @ $C - 7 u.r                  dup Full? ?dup  IF dup >r  1+ ?dup                                 IF ."   <- " 1- abs 2dup @ 8 - =  IF    6 u.r                      ELSE  4+ @ dup 6 u.r  dup Purge@ rot space .File                      swap 6 .r ': emit . @ 4- @ abs $14 + wx@                        0< IF  ."  x"  THEN  THEN  THEN                           r> 0<  IF  ."   locked "  THEN                            ELSE  ."   Frei "  THEN                                         [IFDEF] Pool  dup Pool @ = IF ."  Pool" THEN                    dup Pool 2 cells + @ = IF ."  First" THEN                       dup Pool 3 cells + @ = IF ."  Shift" THEN  [THEN]               NextBlock  stop?  UNTIL THEN  drop  HeapSem unlock ;                                                                   \ .blocks                                              29oct91py                                                                : .blocks ( -- ) prev                                             BEGIN  @ dup  WHILE  cr dup                                            dup 4+ @ @ 6 .r 8+                                              ."     Block : " 4+ dup @ over 4+ @ / 4 .r                      ."     File : " dup 4- @ .file                                  8+ w@ IF ."  updated " THEN                              stop?  UNTIL THEN  drop ;                                                                                                     toss                                                                                                                            export Memory ;                                                                                                                                                                                                                                                 \ Interpretative Structuren                            14sep09py| Variable #I                                                   | Variable countif                                              Vocabulary [struct] [struct] also definitions                   : [IF]      1 countif +! ;      : [THEN]   -1 countif +! ;      : [ELSE]   [THEN] r> execute [IF] ;                             ' [IF] alias [IFDEF]            ' [IF] alias [IFUNDEF]          ' [IF] alias [BEGIN]            ' [IF] alias [WHILE]            ' [THEN] alias [UNTIL]          ' [THEN] alias [AGAIN]          ' [IF] alias [DO]               ' [IF] alias [?DO]              ' [THEN] alias [LOOP]           ' [THEN] alias [+LOOP]          : [REPEAT] [AGAIN] [THEN] ;     ' [THEN] alias [ENDIF]          ' ( alias (                     ' (* alias (*                   ' /* alias /*                   ' \* alias \*                   ' \ alias \                     ' \\ alias \\                   ' \\\ alias \\\                                 -->             \ Interpretative Structuren                            14sep09py| Variable parser'                                              | : scanIF  [ context @ ] ALiteral (find                            IF    name> execute  countif @ 0<                                     IF  parser' @ IS parser  THEN                             ELSE  drop  THEN ;          Forth definitions               : defined?   name find nip 0<> ;                                : [defined]  defined? ;                          immediate      : [undefined]  defined? 0= ;                     immediate      : [IF]   what's parser parser' !                                  0= IF  countif off ['] scanIF IS parser THEN ; immediate      : [IFDEF]   defined?    compile [IF] ;           immediate      : [IFUNDEF] defined? 0= compile [IF] ;           immediate      : [ELSE] 0 compile [IF] ;                        immediate      : [THEN] ;  immediate           : [ENDIF] ;  immediate          Onlyforth                                       -->             \ Structs for interpreter                              11mar00py: [DO]  ( start end -- )  #I push >in @ -rot  DO  I #I !          dup >r >in ! interpret r> swap +LOOP  drop ;   immediate      : [?DO] 2dup = IF 2drop compile [ELSE] ELSE compile [DO] THEN ;                                                       immediate : [+LOOP] ( n -- ) rdrop rdrop ;                      immediate : [LOOP] ( -- ) 1 rdrop rdrop ;                       immediate : [FOR] ( n -- )  0 swap compile [DO] ;               immediate : [NEXT] ( n -- ) -1 rdrop rdrop ;                    immediate : [I] ( -- index ) #I @ ?lit, ;                       immediate : [BEGIN] >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop ;         immediate     ' [+LOOP]  alias [UNTIL] immediate              : [REPEAT]  ( -- )  false rdrop rdrop ;               immediate                 ' [REPEAT] alias [AGAIN] immediate              : [WHILE] 0= IF   compile [ELSE] true rdrop rdrop 1 countif +!               THEN ;                                   immediate