Menu
▾
▴
win32forth-cvs
|
From: Dirk B. <db...@us...> - 2006-09-23 07:32:41
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv21094/src Modified Files: extend.f Added Files: paths.f Log Message: Ported the Path support to the STC-Kernel. Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** extend.f 23 Sep 2006 06:00:17 -0000 1.2 --- extend.f 23 Sep 2006 07:32:38 -0000 1.3 *************** *** 24,30 **** --- 24,36 ---- 8 constant B/FLOAT \ default to 8 byte floating point numbers FLOAD src\float.f \ floating point support + + : DEPRECATED ; immediate + + FLOAD src\paths.f \ multi path support words + .olly + \s \ FLOAD src\lineedit.f \ a line editor utility --- NEW FILE: paths.f --- \ $Id: paths.f,v 1.1 2006/09/23 07:32:38 dbu_de Exp $ \ *D doc\ \ *! Paths \ *T Paths -- Multiple search path support \ *S Glossary cr .( Loading Path Functions...) \ anew -paths.f internal external in-application [undefined] deprecated [if] : deprecated ; immediate [endif] [undefined] defextz$ [if] : defextz$ defext$ 1+ ; \ default file extension (as zString) [endif] \ ------------------------------------------------------------------------ \ Some filename supporting words. \ ------------------------------------------------------------------------ [undefined] MAX-PATH [if] MAXBUFFER CONSTANT MAX-PATH \ maximum length of a filename buffer [endif] 1 PROC PathRemoveFileSpec as (call-prfs) 1 PROC PathRemoveExtension as (call-pre) \ Temp fix until AS work's within the STC-Kernel \ : ("path-func") ( a1 n1 xt -- a2 n2 ) \ execute path function \ -rot \ save the xt under the string \ over >r \ save original address \ MAX-PATH _localalloc \ allocate space on stack \ -z dup>r \ make a zstring \ swap execute drop \ call the function \ r> zcount \ count the chars \ _localfree \ nip r> swap \ use original address \ ; \ : "path-only" ( a1 n1 -- a2 n2 ) \ return path, minus final '\' \ ['] (call-prfs) ("path-func") \ ; \ \ : "minus-ext" ( a1 n1 -- a2 n2 ) \ remove the file extension \ ['] (call-pre) ("path-func") \ ; : "path-only" ( a1 n1 -- a2 n2 ) \ *G Return path, minus final '\' over >r \ save original address MAX_PATH _localalloc \ allocate space on stack ascii-z dup>r \ make a zstring call PathRemoveFileSpec drop \ call the function r> zcount \ count the chars _localfree nip r> swap \ use original address ; : "minus-ext" ( a1 n1 -- a2 n2 ) \ *G Remove the file extension over >r \ save original address MAX_PATH _localalloc \ allocate space on stack ascii-z dup>r \ make a zstring call PathRemoveExtension drop \ call the function r> zcount \ count the chars _localfree nip r> swap \ use original address ; : ".ext-only" ( a1 n1 -- a1 n1 ) \ *G returns dotted file extension 2dup "minus-ext" nip /string ; : "TO-PATHEND" ( a1 n1 --- a2 n2 ) \ *G return a2 and count=n1 of filename 2dup \ save originals MAX_PATH _LOCALALLOC ascii-z dup \ make zstring on the stack call PathFindFileName \ find the file part swap - /string \ remove the chars from caller _LOCALFREE ; : endchar? ( a1 char -- flag ) \ *G check the end character in a c-string swap dup c@ + c@ = ; : ?-\ ( a1 -- ) \ *G delete trailing '\' if present dup [char] \ endchar? \ end in '\'? if -1 swap c+! \ if so, delete it else drop \ else discard a1 then ; : ?+\ ( a1 -- ) \ *G append a '\' if not already present dup [char] \ endchar? \ end in '\'? if drop \ discard a1 else s" \" rot +place \ if not, append \ then ; : ?+; ( a1 -- ) \ *G append a ';' if not already present dup [char] ; endchar? \ end in ';'? if drop \ discard a1 else s" ;" rot +place \ if not, append ; then ; \ ------------------------------------------------------------------------ \ ------------------------------------------------------------------------ : ?DEFEXT ( addr -- ) \ *G Conditionally add a default extension defext$ add.ext \ add extension if needed ; \ ------------------------------------------------------------------------ \ ------------------------------------------------------------------------ create &forthdir \ *G A static forth installation directory. MAXCOUNTED 1+ allot &forthdir off : init-Win32fDirectory { \ kernel$ -- } \ *G Set &forthdir to the folder of the current forth application. \n &prognam count "path-only" &forthdir place &forthdir c@ 0= if \ if no dir specified make it the current dir current-dir$ count &forthdir place then &forthdir c@ if &forthdir ?+\ \ append '\' if needed &forthdir +null \ append 0 terminator then ; init-Win32fDirectory initialization-chain chain-add init-Win32fDirectory IN-SYSTEM : .program ( -- ) \ *G Type the program path. &prognam count type ; : .forthdir ( -- ) \ *G Type the forth directory. &forthdir count type ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ change directory \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION : "chdir ( a1 n1 -- ) \ *G Set the current directory. IF $current-dir! THEN drop ; IN-SYSTEM : .dir ( -- ) \ *G Print the current directory. cr ." Current directory: " current-dir$ count type ; : chdir ( -<optional_new_directory>- ) \ *G Set the current directory. /parse-word count "chdir cr .dir ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Multiple directory path search capability for file open \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION : path: ( - ) \ *G Defines a directory search path. \n \ ** The first 2 cells are used too handle a search path. \n \ ** The next 260 bytes are reserved for a counted string of a path. \n \ ** followed by 0. \n \ ** In runtime it returns adres of the counted string of a path create -1 , 0 , MAX-PATH 1+ allot does> \ run-time: ( - path ) [ 2 cells ] literal + ; INTERNAL create path-file$ MAX-PATH 1+ allot : path-source ( path - 2variable_path-source ) \ *G Path-source points to a substring in a path. \n \ ** Path-source returns this adress. 2 cells- ; EXTERNAL path: path-ptr deprecated \ *G The old functionality had the bad habbit to pass a pointer through a \ ** value instead of passing the parameter over the stack. \n \ ** Use win32forth\src\Compat\OldPaths.f for the old functionality. \n \ ** Words like first-path" and next-path" are now able to handle \ ** each path separate without saving and restoring a path-ptr. path: search-path \ *G search-path defines the path buffer for Forth.\n Applications that let Forth \ ** compile should not change it in a way that Forth is not able too compile. : next-path" ( path -- a1 n1 ) \ *G Get the next path from dir list. dup>r path-source 2@ 2dup ';' scan 2dup 1 /string r> path-source 2! nip - 2dup s" %FORTHDIR%" ISTR= if 2drop &forthdir dup ?+\ count "path-only" exit then 2dup s" %CURRENTDIR%" ISTR= if 2drop current-dir$ dup ?+\ count "path-only" exit then 2dup s" %APPDIR%" ISTR= if 2drop &prognam count "path-only" exit then ; : reset-path-source ( path -- ) \ *G Points the path-source to the whole path. dup>r count r> path-source 2! ; : first-path" ( path -- a1 n1 ) \ *G Get the first forth directory path. dup>r reset-path-source r> next-path" ; : "path+ ( a1 n1 path -- ) \ *G Append a directory to a path. >r 2dup upper 2dup + 1- c@ '\' = \ end in '\'? if 1- 0max \ if so, delete it then r@ first-path" \ get first path begin dup 0> >r 2over compare 0<> dup r> and \ check it while drop r@ next-path" \ and remaining paths repeat 0= \ -- f1=true if already in list if 2drop else dup r@ c@ if char+ then MAX-PATH >= abort" Path overflow" r@ c@ if r@ ?+; then r@ +place then r>drop ; : "fpath+ ( a1 n1 -- ) \ *G Append a directory to the Forth path. search-path "path+ ; : fpath+ ( -<directory>- ) \ *G Append a directory to the Forth path. /parse-s$ count "fpath+ ; : .path ( path -- ) \ *G Display a directory search path list. count begin ?dup while 2dup ';' scan 2dup 2>r nip - dup char+ ?cr type 2r> 1 /string dup if ." ;" then repeat drop ; : .fpath ( -- ) \ *G Display the Forth directory search path list. search-path .path ; INTERNAL : volume-indication? ( adr - flag ) \ *G True when the counted string at adr starts with x: or \\name dup 2 + c@ [char] : <> if count drop 2 s" \\" compare 0= else drop true then ; 6 PROC SearchPath : full-path { a1 n1 path \ searchpath$ filename$ current$ -- a2 n2 f1 } \ *G Find file a1,n1 in a path and return the full path. \n \ ** a2,n2 and f1=false, succeeded. a1 n1 MAX-PATH 1+ localalloc ascii-z to filename$ MAX-PATH 1+ localalloc: searchpath$ MAX_PATH 1+ LocalAlloc: current$ current-dir$ count current$ place current$ +null \ save current dir search-path first-path" begin dup>r searchpath$ place searchpath$ +null searchpath$ volume-indication? \ Test for another volume if searchpath$ char+ $current-dir! \ 0 fails, then try next else true then if 0 \ file component path-file$ \ found file name buffer max-path \ size of buffer defextz$ \ file extension filename$ \ file name searchpath$ char+ \ search path call SearchPath 0<> if path-file$ zcount false \ path found current$ char+ $current-dir! not abort" $current-dir!" \ restore current dir r>drop exit \ clear the retun stack and exit then then r> while searchpath$ off search-path next-path" repeat a1 n1 path-file$ place path-file$ count true \ return input file and error flag current$ char+ $current-dir! not abort" $current-dir!" \ restore current dir ; EXTERNAL : program-path-init ( -- ) \ *G Initialize the Forth directory search path list. Automatically done at program \ ** initialization and when Paths.f is loaded. search-path off \ clear path list s" %CURRENTDIR%" "fpath+ s" %FORTHDIR%" "fpath+ s" %APPDIR%" "fpath+ s" src" "fpath+ s" src\lib" "fpath+ \ s" src\tools" "fpath+ \ this is causing problems when compiling the IDE... s" src\gdi" "fpath+ \ GDI class library s" src\res" "fpath+ s" src\console" "fpath+ \ s" demos" "fpath+ s" doc" "fpath+ \ last ; program-path-init INITIALIZATION-CHAIN CHAIN-ADD PROGRAM-PATH-INIT : "path-file { a1 n1 \ current$ -- a2 n2 f1 } \ *G Find file a1,n1 in the Forth path and return the full path. \n \ ** a2,n2 and f1=false, succeeded. \ first try it in the current directory a1 n1 search-path full-path -if 3drop \ then try it in the forth directory a1 n1 search-path full-path then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ "open with Multiple directory path search \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ create open-path$ MAXSTRING allot : n"open ( a1 n1 -- handle f1 ) \ *G Open file a1,n1 with a Forth path search. "path-file if 2drop 0 -1 else 2dup open-path$ place \ save full path _"open \ open file then ; ' n"open is "open \ link multi-path open word into system \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ MakeAbsolutePath MakeRelativePath \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ INTERNAL create <AbsRelPath$> max-path 1+ allot EXTERNAL : IsAbsolutePath? ( a1 n1 -- f ) \ *G Returns true if path is absolute. MAXCOUNTED _LOCALALLOC \ allocate a string dup>r place r@ +null \ move the string r> 1+ \ for call call PathIsRelative 0= \ call function _LOCALFREE \ free buffer ; : MakeAbsolutePath ( a1 n1 a2 n2 -- a3 ) \ *G Make path a1 n1 absolute to path a2 n2. ?DUP \ only if a2 n2 point's to a path IF 2OVER IsAbsolutePath? IF 2DROP <AbsRelPath$> PLACE ELSE <AbsRelPath$> PLACE \ store path <AbsRelPath$> ?+\ \ append '\' if not already present <AbsRelPath$> +PLACE \ append file name THEN else DROP <AbsRelPath$> PLACE then <AbsRelPath$> dup +null ; : IsPathRelativeTo? { a1 n1 a2 n2 -- f } \ *G Return true if path a1 n1 is relative to path a2 n2 a1 n1 n2 MIN a2 OVER ISTR= ; : MakePathRelativeTo ( a1 n1 a2 n2 -- a3 ) \ *G Make path a1 n1 relative to path a2 n2. 4DUP IsPathRelativeTo? IF NIP DUP>R - SWAP R> + SWAP ( a2 n3 ) ELSE 2DROP ( a1 n1 ) THEN <AbsRelPath$> PLACE <AbsRelPath$> ; : FindRelativePath ( a1 n1 path - a2 n2 ) \ *G Returns a relative path for file a1 n1 in path ( first part ). \n \ ** n2=0 means not in search path. dup>r reset-path-source begin r@ path-source 2@ nip 0> if r@ next-path" 4dup IsPathRelativeTo? not else over 0 false then while 2drop repeat 2nip r>drop ; : FindRelativeName ( a1 n1 path - a2 n2 f ) \ *G Returns a relative name for file a1 n1 in path ( last-part ). \n \ ** n2=0 means not in search path. >r 2dup r> FindRelativePath dup 0> if nip dup 3 > if 1+ then /string true else 2drop false then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Prepend<home>\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : Prepend<home>\ ( a1 n1 -- a2 n2 ) &forthdir count MakeAbsolutePath count ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ "LOADED? \LOADED- \LOADED NEEDS \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ in-system : "LOADED? ( addr len -- flag ) \ *G True if a file addr len is loaded. The filename must contain a full path. CONTEXT @ >R \ save context files \ set context CONTEXT @ SEARCH-WORDLIST \ search for word IF DROP TRUE ELSE FALSE THEN \ correct the flag R> CONTEXT ! ; : LOADED? ( -<name>- -- flag ) { \ current$ } \ *G True if the following file is loaded. The filename may be relative. MAX_PATH 1+ LocalAlloc: current$ current-dir$ count current$ place \ get current dir current$ ?+\ \ append '\' new$ >r /parse-s$ count r@ place \ store file name r@ ?defext r> count \ add default ext if needed "path-file drop \ extend to full path "loaded? ; : \LOADED- ( -<name>- ) \ *G If the following file IS NOT LOADED interpret line. loaded? if postpone \ then ; : \LOADED ( -<name>- ) \ *G If the following file IS LOADED interpret line. loaded? 0= if postpone \ then ; : NEEDS ( -<name>- ) \ *G Conditionally load file "name" if not loaded. >in @ loaded? 0= if >in ! fload else drop then ; synonym Require needs \ *G Forth 200X name for needs. in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : "file-clip" { adr len limit \ temp$ pre -- 'adr 'len } \ *G Clip filename to limit. new$ to temp$ \ so string isn't de-allocated on exit limit 20 max to limit \ must be at east 16 limit 20 - 2 / 6 + to pre \ balance start and end len limit > if adr pre 3 - temp$ place \ lay in first 5 chars s" ..." temp$ +place \ append some dots adr len dup limit pre - - 0MAX /string \ clip to last part temp$ +place \ of name and lay in temp$ count else adr len \ no need to clip file then ; MODULE \ *Z |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X