Author: wmb Date: 2007-08-20 21:37:58 +0200 (Mon, 20 Aug 2007) New Revision: 570
Added: forth/lib/tofile.fth Log: forth/lib/tofile.fth - Initial checkin
Added: forth/lib/tofile.fth =================================================================== --- forth/lib/tofile.fth (rev 0) +++ forth/lib/tofile.fth 2007-08-20 19:37:58 UTC (rev 570) @@ -0,0 +1,97 @@ +purpose: Redirect the output stream. +\ See license at end of file + +\ to-file \ filename ( -- ) +\ causes output to be temporarily diverted to the named file. +\ The file is created if it doesn't exist, and overwritten if it does. +\ Output is restored to the console just before Forth prompts for a +\ new line of input. +\ append-to-file \ filename ( -- ) +\ Similar to to-file but if the file already exists, the new stuff is +\ tacked onto the end, rather than overwriting the file. + +\ We really need to make the output stream a multi-field structure, and +\ keep a stack of output streams. + +only forth also hidden also definitions +variable old-status ' noop old-status token! +variable old-(emit ' noop old-(emit token! +variable old-(type ' noop old-(type token! +variable old-cr ' noop old-cr token! +variable old-exit? ' noop old-exit? token! +variable old-#out 0 old-#out ! +variable old-#line 0 old-#line ! +variable saved-output-valid saved-output-valid off + +forth definitions +: save-output ( -- ) + ['] status behavior old-status token! + ['] (emit behavior old-(emit token! + ['] (type behavior old-(type token! + ['] cr behavior old-cr token! + ['] exit? behavior old-exit? token! + #out @ old-#out ! + #line @ old-#line ! + saved-output-valid on +; +: unsave-output ( -- ) + saved-output-valid @ if + old-(emit token@ is (emit + old-(type token@ is (type + old-status token@ is status + old-cr token@ is cr + old-exit? token@ is exit? + old-#out @ #out ! + old-#line @ #line ! + saved-output-valid off + then +; +hidden definitions +: undo-file-output ( -- ) unsave-output ofd @ fclose ; +: file-(emit ( char -- ) ofd @ fputc ; +: file-(type ( adr len -- ) ofd @ fputs ; +: file-cr ( adr len -- ) + #out off 1 #line +! newline-string ofd @ fputs +; +forth definitions +: file-output ( -- ) + save-output + ['] undo-file-output is status + ['] file-(emit is (emit + ['] file-(type is (type + ['] file-cr is cr + ['] false is exit? + #out off #line off +; + +: to-file \ filename ( -- ) + writing file-output +; +: append-to-file \ filename ( -- ) + appending file-output +; +only forth also definitions + +\ LICENSE_BEGIN +\ Copyright (c) 2007 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END