Borland Programmer's Resource

home *** CD-ROM | disk | FTP | other *** search

/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / jx4files.a < prev next >

Wrap

Text File | 1995-05-19 | 29.3 KB | 967 lines

; jx4files.a ... File-Access wordset words for Jax4th 32-bit ANS Forth for Windows NT ; copyright (c) 1993, 1994 by jack j. woehr ; p.o. box 51, golden, co 80402-0051 ; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com ; sysop, rcfb (303) 278-0364 COMMENT ! This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (doc\license.txt) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ ! ; ; $Log: jx4files.a,v $ ; Revision 1.9 1994/08/21 07:35:12 jax ; Fixed OPEN-FILE to do its own null padding. ; ; Revision 1.9 1994/08/21 07:35:12 jax ; Fixed OPEN-FILE to do its own null padding. ; ; Revision 1.8 1994/08/20 09:27:14 jax ; Added INCLUDED. ; Fixed CREATE-FILE to do its own null appending. ; ; Revision 1.7 1994/08/20 05:51:03 jax ; added INCLUDE-FILE ; ; Revision 1.6 1994/08/04 02:02:24 jax ; Added READ-LINE. Moved the A and W words to NONSTANDARD-WORDLIST. ; ; Revision 1.5 1994/07/28 18:26:23 jax ; Changed all the file words so that they have both ascii and ; unicode versions, with a deferred top-level word init'ed ; by COLD at powerup. ; ; Revision 1.4 1994/07/18 07:05:57 jax ; Worked on READ-LINE, didn't finish. ; ; Revision 1.3 1994/06/13 22:40:54 jax ; masm 6.11 protos ; ; Revision 1.2 1994/05/21 06:25:03 jax ; Changed copyright dates. ; ; Revision 1.1 1993/12/29 21:06:34 jax ; Initial revision ; fnamemanque <CLOSE-FILE> ; fileid -- ior ( == system error if failure, == 0 if success) fw_CLOSEFILE: ; FILE docode call CloseHandle and eax,eax ; indicates success, but we reverse the code jne closefile1 INVOKE GetLastError ; get error push eax ; push error ior store lastError,eax ; to be consistent with rest of system next closefile1: xor eax,eax push eax ; success next fnamemanque <CREATE-FILE> ; c-addr u x1 -- x2 ior (== 0 | system err) fw_CREATEFILE: ; FILE ctok NEST ctok TO_R ; -- c-addr u R: -- x1 ctok CHARS ctok TUCK ; -- u' c-addr u' R: -- x1 literal zeroBuffer ; -- u' c-addr1 u' c-addr2 R: -- x1 ctok SWAP ; -- u' c-addr1 c-addr2 u' R: -- x1 ctok MOVE ; -- u' R: -- x1 literal zeroBuffer ; -- u' c-addr R: -- x1 ctok OVER ; -- u' c-addr u' R: -- x1 ctok PLUS ; -- u' c-addr' R: -- x1 literal 0 ; -- u' c-addr' 0 R: -- x1 ctok SWAP ; -- u' 0 c-addr' R: -- x1 ctok C_STORE ; -- u' R: -- literal zeroBuffer ; -- u' c-addr R: -- x1 ctok SWAP ; -- c-addr u' R: -- x1 ctok R_FROM ; -- c-addr u' x1 R: -- ctok CREATFILE ; -- x2 ior ctok UNNEST zname <CREATFILE> ; c-addr u x1 -- x2 ior (== 0 | system err) docode pop eax ; x1 pop ecx ; u pop edx ; c-addr add edx,dp ; abs-addr INVOKE CreateFileW, edx, eax, 0, OFFSET FLAT:secAttrib, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 push eax ; push resultant handle cmp eax,INVALID_HANDLE_VALUE jne createfile1 ; if handle is invalid, we don't branch INVOKE GetLastError ; get error push eax ; push error ior store lastError,eax ; to be consistent with rest of system next createfile1: xor eax,eax push eax ; success, ior is zero next fnamemanque <DELETE-FILE> ; c-addr u -- ior (== 0 | system err) fw_DELETEFILE: ; FILE docode pop edx ; u pop eax ; c-addr add eax,dp ; abs-addr INVOKE DeleteFileW, eax and eax,eax je deletefile1 ; if zero, we failed xor eax,eax ; but our Forth result for success is zero (0) push eax ; success next deletefile1: INVOKE GetLastError ; failure, get system error code push eax ; push error ior store lastError,eax ; to be consistent with rest of system next nname <FERROR> ; -- a-addr ctok DOCONST ; CORE dd var_ferror fnamemanque <FILE-POSITION> ; fileid -- ud ior (0= success , nz== last error fw_FILEPOSITION: ; FILE defers nnamemanque <FILE-POSITIONW> ; fileid -- ud-chars ior (0= success , nz== last error fw_FILEPOSITIONW: ; FILE ctok NEST ctok FILEPOSITIONA ; -- ud-bytes ior ctok TO_R ; -- ud-bytes R: -- ior literal tchar ctok DUMSLMOD ; -- modulus ud-chars R: -- ior ctok ROT ; -- ud-chars modulus R: -- ior ctok DROP ; -- ud-chars R: -- ior ctok R_FROM ; -- ud-chars ior R: -- ctok UNNEST nnamemanque <FILE-POSITIONA> ; fileid -- ud=-bytes ior (0= success , nz== last error fw_FILEPOSITIONA: ; FILE docode pop edx ; fileid mov DWORD PTR distMoveHigh,0 ; hi word of dist to move INVOKE SetFilePointer, edx, 0, OFFSET FLAT:distMoveHigh, FILE_CURRENT cmp eax,-1 ; if -1, must check distMoveHigh jne filepos1 cmp DWORD PTR distMoveHigh,0 ; if zero, we have an err jne filepos1 ; not zero is success INVOKE GetLastError ; get error push 0 push 0 ; ud push eax ; push error ior store lastError,eax ; to be consistent with rest of system next filepos1: push eax push DWORD PTR distMoveHigh push 0 ; success, ior is zero next fnamemanque <FILE-SIZE> ; fileid -- ud ior fw_FILESIZE: ; FILE defers nnamemanque <FILE-SIZEW> ; fileid -- ud-chars ior fw_FILESIZEW: ; FILE ctok NEST ctok FILESIZEA ; -- ud-bytes ior ctok TO_R ; -- ud-bytes R: -- ior literal tchar ; -- ud-bytes u R: -- ior ctok DUMSLMOD ; -- mod ud-chars R: -- ior ctok ROT ; -- ud-chars mod R: -- ior ctok DROP ; -- ud-chars R: -- ior ctok R_FROM ; -- ud-chars ior R: -- ctok UNNEST nnamemanque <FILE-SIZEA> ; fileid -- ud-bytes ior fw_FILESIZEA: ; FILE docode pop eax INVOKE GetFileInformationByHandle, eax, OFFSET FLAT:fileInfo cmp eax,0 jne filesize1 ; if handle is invalid, we don't branch INVOKE GetLastError ; get error push 0 push 0 ; ud push eax ; push error ior store lastError,eax ; to be consistent with rest of system next filesize1: push DWORD PTR fileInfo.nFileSizeLow push DWORD PTR fileInfo.nFileSizeHigh xor eax,eax push eax ; success, ior is zero next fnamemanque <INCLUDE-FILE> ; i*x fileid -- j*x fw_INCLUDEFILE: ; FILE ctok NEST ctok TIB ctok TO_R ; -- i*x fileid R: -- 'TIB ctok NUMTIB ctok FETCH ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB ctok TO_IN ctok FETCH ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN ctok SOURCE_ID ctok FETCH ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN SOURCE-ID ctok BLK ctok FETCH ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN SOURCE-ID BLK literal endq ctok FETCH ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN SOURCE-ID BLK endq ctok SOURCE_ID ; -- i*x fileid a-addr R: -- 'TIB #TIB >IN SOURCE-ID BLK endq ctok STORE ; -- i*x R: -- x x x x x x incfileloop: ; -- i*x R: -- x x x x x x literal tickftib literal tibsize ctok SOURCE_ID ctok FETCH ctok READLINE ; -- i*x u flag ior R: -- x x x x x x ctok QDUP ; -- i*x u flag ior ior|-- R: -- x x x x x x compif incfile1 ; -- i*x u flag ior, there was an error R: -- x x x x x x ctok FERROR ; -- i*x u flag ior a-addr R: -- x x x x x x ctok STORE ; -- i*x u flag, save file error R: -- x x x x x x literal -37 ; File I/O Error ctok THROW ; -- j*x n R: -- (to be cleared) incfile1: ; -- i*x u flag, no error, flag false or true? R: -- x x x x x x compif incfile3 ; -- i*x u, true, there were some chars R: -- x x x x x x ctok FALSE literal endq ctok STORE ; -- i*x R: -- x x x x x x ctok NUMTIB ctok STORE ; -- i*x R: -- x x x x x x literal tickftib ctok TICK_TIB ctok STORE ; -- i*x R: -- x x x x x x ctok FALSE ctok TO_IN ctok STORE ; -- i*x R: -- x x x x x x literal tickftib ; see if first char is the Unicode byte-order marker ctok C_FETCH ; -- i*x char R: -- x x x x x x literal 0FEFFH ctok EQUAL ; -- i*x flag R: -- x x x x x x compif incfile2 ; -- i*x R: -- x x x x x x ctok BL literal tickftib ; -- i*x char c-addr R: -- x x x x x x ctok C_STORE ; -- i*x R: -- x x x x x x incfile2: ctok INTERPRET ; -- j*x compelse incfileloop incfile3: ; -- j*x u, chars read (0) R: -- x x x x x x ; Start restoring the input stream ctok DROP ; -- j*x R: -- x x x x x x ctok R_FROM literal endq ctok STORE ; -- j*x R: -- x x x x x ctok R_FROM ctok BLK ctok STORE ; -- j*x R: -- x x x x ctok R_FROM ctok SOURCE_ID ctok STORE ; -- j*x R: -- x x x ctok R_FROM ctok TO_IN ctok STORE ; -- j*x R: -- x x ctok R_FROM ctok NUMTIB ctok STORE ; -- j*x R: -- x ctok R_FROM ctok TICK_TIB ctok STORE ; -- j*x R: -- ctok UNNEST fname <INCLUDED> ; i*x c-addr u -- j*x ctok NEST ; FILE ctok RO ; -- x1 ctok OPENFILE ; -- x2 ior ctok QDUP compif included1 ; file error ctok FERROR ctok STORE ; save error for analysis literal -37 ctok THROW ; throw exception included1: ctok DUP ; -- fid fid ctok TO_R ; -- fid R: -- fid ctok DOLIT ctok INCLUDEFILE ; -- fid xt R: -- fid ctok CATCH ; -- 0|n R: -- fid ctok R_FROM ; -- 0|n fid R: -- ctok CLOSEFILE ; -- 0|n ior ctok DROP ; -- 0|n ctok THROW ; if an error occured, THROW it! ctok UNNEST fnamemanque <OPEN-FILE> ; c-addr u x1 -- x2 ior (== 0 | system err) fw_OPENFILE: ; FILE ctok NEST ctok TO_R ; -- c-addr u R: -- x1 ctok CHARS ctok TUCK ; -- u' c-addr u' R: -- x1 literal zeroBuffer ; -- u' c-addr1 u' c-addr2 R: -- x1 ctok SWAP ; -- u' c-addr1 c-addr2 u' R: -- x1 ctok MOVE ; -- u' R: -- x1 literal zeroBuffer ; -- u' c-addr R: -- x1 ctok OVER ; -- u' c-addr u' R: -- x1 ctok PLUS ; -- u' c-addr' R: -- x1 literal 0 ; -- u' c-addr' 0 R: -- x1 ctok SWAP ; -- u' 0 c-addr' R: -- x1 ctok C_STORE ; -- u' R: -- literal zeroBuffer ; -- u' c-addr R: -- x1 ctok SWAP ; -- c-addr u' R: -- x1 ctok R_FROM ; -- c-addr u' x1 R: -- ctok OPEFILE ; -- x2 ior ctok UNNEST zname <OPEFILE> ; c-addr u x1 -- x2 ior (== 0 | system err) docode pop eax ; x1 pop ecx ; u pop edx ; c-addr add edx,dp ; abs-addr INVOKE CreateFileW, edx, eax, 0, OFFSET FLAT:secAttrib, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 push eax ; push resultant handle cmp eax,INVALID_HANDLE_VALUE jne openfile1 ; if handle is invalid, we don't branch INVOKE GetLastError ; get error push eax ; push error ior store lastError,eax ; to be consistent with rest of system next openfile1: xor eax,eax push eax ; success, ior is zero next fnamemanque <READ-FILE> ; c|b-addr u1 fileid -- u2 ior fw_READFILE: defers nnamemanque <READ-FILEW> ; c-addr u1 fileid -- u2 ior (== 0 | system err) fw_READFILEW: ; FILE ctok NEST ctok SWAP ; -- c-addr fileid u-chars ctok TWO_STAR ; -- c-addr fileid u-bytes ctok SWAP ; -- c-addr u-bytes fileid ctok READFILEA ; -- u2 ior ctok SWAP ; -- ior u2 ctok TWO_SLASH ; -- ior u2' ctok SWAP ; -- u2' ior ctok UNNEST nnamemanque <READ-FILEA> ; b-addr u1 fileid -- u2 ior (== 0 | system err) fw_READFILEA: ; FILE docode pop edx ; fileid pop ecx ; u1 pop eax ; c-addr add eax,dp ; abs-addr INVOKE ReadFile, edx, eax, ecx, OFFSET FLAT:numRead, 0 push DWORD PTR numRead ; u2 and eax,eax jne readfile1 ; result was bool true, so we branch on success INVOKE GetLastError ; get error push eax ; push error ior store lastError,eax ; to be consistent with rest of system next readfile1: xor eax,eax push eax ; success, ior is zero next fnamemanque <READ-LINE> ; c-addr u1 fileid -- u2 flag ior (== 0 | system err) fw_READLINE: ; FILE ctok NEST ctok SWAP ; -- c-addr fileid u1 literal rlbuffsize ; -- c-addr fileid u1 n, let's only allow this many max ctok MIN ; -- c-addr fileid u1' literal 0 ; -- c-addr fileid u1' 0 ctok MAX ; -- c-addr fileid u1'' ctok SWAP ; -- c-addr u1 fileid, 0 - rlbuffsize is acceptable ctok DUP ; -- c-addr u1 fileid fileid ctok FILESIZEW ; -- c-addr u1 fileid ud2 ior ctok QDUP ; -- c-addr u1 fileid ud2 ior ior|-- compif rline1 ; -- c-addr u1 fileid ud2 ior, FILE-SIZE failed ctok TO_R ; -- c-addr u1 fileid ud2 R: -- ior ctok ROT ctok DROP ; -- c-addr u1 ud2 R: -- ior ctok ROT ctok DROP ; -- c-addr ud2 R: -- ior ctok ROT ctok DROP ; -- ud2 R: -- ior ctok R_FROM ; -- x x ior R: -- ctok EXIT ; -- u2 flag ior, failure indicated by ior, ud2 subs for u2 flag rline1: ; we have a FILE-SIZE literal 2 ctok PICK ; -- c-addr u1 fileid ud2 fileid ctok FILEPOSITIONW ; -- c-addr u1 fileid ud2 ud3 ior ctok QDUP ; -- c-addr u1 fileid ud2 ud3 ior ior|-- compif rline2 ; -- c-addr u1 fileid ud2 ud3 ior, FILE-POSITION failed ctok TO_R ; -- c-addr u1 fileid ud2 ud3 R: -- ior ctok TWO_TO_R ; -- c-addr u1 fileid ud2 R: -- ior ud3 ctok TWO_DROP ; -- c-addr u1 fileid R: -- ior ud3 ctok TWO_DROP ; -- c-addr R: -- ior ud3 ctok DROP ; -- R: -- ior ud3 ctok TWO_R_FROM ; -- ud2 R: -- ior ctok R_FROM ; -- x x ior R: -- ctok EXIT ; -- ud2 ior, failure indicated by ior, ud2 subs for u2 flag rline2: ; -- c-addr u1 fileid ud2 ud3, we have file position and size ctok TWO_DUP ; -- c-addr u1 fileid ud2 ud3 ud3 ctok TWO_TO_R ; -- c-addr u1 fileid ud2 ud3 R: -- ud3 ctok D_EQUAL ; -- c-addr u1 fileid flag, is the file at the end? R: -- ud3 compif rline3 ; -- c-addr u1 fileid, yes R: -- ud3 ctok TWO_R_FROM ; -- c-addr u1 fileid ud3 R: -- ctok TWO_DROP ; -- c-addr u1 fileid ctok TWO_DROP ; -- c-addr ctok DROP ; -- ctok FALSE ctok FALSE ctok FALSE ctok EXIT ; -- 0 0 0, proper return if file was exhausted when we started rline3: ; -- c-addr u1 fileid flag, file not at end yet R: -- ud3 literal rlBuffer ; -- c-addr u1 fileid a-addr R: -- ud3 literal rlbuffsize ; -- c-addr u1 fileid a-addr u2 R: -- ud3 literal 2 ctok PICK ; -- c-addr u1 fileid a-addr u2 fileid R: -- ud3 ctok READFILEW ; -- c-addr u1 fileid u2 ior R: -- ud3 ctok QDUP ; -- c-addr u1 fileid u2 ior ior|-- R: -- ud3 compif rline4 ; -- c-addr u1 fileid u2 ior, error on read R: -- ud3 ctok TO_R ; -- c-addr u1 fileid u2 R: -- ud3 ior ctok TWO_DROP ctok TWO_DROP ; -- R: -- ud3 ior ctok FALSE ctok FALSE ctok R_FROM ; -- 0 0 ior R: -- ud3 ctok TWO_R_FROM ; -- 0 0 ior ud3 R: -- ctok TWO_DROP ; -- 0 0 ior ctok EXIT ; -- 0 0 ior, this looks good on a read error rline4: ; -- c-addr u1 fileid u2 R: -- ud3 ctok SWAP ; -- c-addr u1 u2 fileid R: -- ud3 ctok TO_R ; -- c-addr u1 u2 R: -- ud3 fileid literal rlBuffer ; -- c-addr1 u1 u2 c-addr2 R: -- ud3 fileid ctok SWAP ; -- c-addr1 u1 c-addr2 u2 R: -- ud3 fileid literal lFeed ; -- c-addr1 u1 c-addr2 u2 char R: -- ud3 fileid ctok SCAN ; -- c-addr1 u1 c-addr2' u2' R: -- ud3 fileid ctok DROP ; -- c-addr1 u1 c-addr2' R: -- ud3 fileid literal rlBuffer ; -- c-addr1 u1 c-addr2' c-a-buff R: -- ud3 fileid ctok TUCK ; -- c-addr1 u1 c-a-buff c-addr2' c-a-buff R: -- ud3 fileid ctok MINUS ; -- c-addr1 u1 c-a-buff ubytes R: -- ud3 fileid ctok S_TO_D literal 1 ctok CHARS ; dividing since address arithmentic resulted in bytes, not chars ctok UMSLMOD ; -- c-addr1 u1 c-a-buff umod uchars R: -- ud3 fileid ctok NIP ; -- c-addr1 u1 c-a-buff uchars R: -- ud3 fileid ctok ONE_PLUS ; Since SCAN returned the address of the LF, ; our subtraction is one char short of the total read. ctok TWO_DUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars R: -- ud3 fileid ctok DUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars uchars R: -- ud3 fileid ctok R_FROM ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars uchars fileid R: -- ud3 ctok SWAP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fileid uchars R: -- ud3 ctok S_TO_D ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fileid ud4 R: -- ud3 ctok TWO_R_FROM ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud4 ud3 R: -- ctok D_PLUS ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 literal 2 ctok PICK ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 fid ctok FILESIZEW ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 ior ctok QDUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 ior ior|-- compif rlineZZ ; FILE-SIZE failed ctok TO_R ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 R: -- ior ctok TWO_DROP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 R: -- ior ctok TWO_DROP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid R: -- ior ctok TWO_DROP ; -- c-a1 u1 c-a-buff uchars c-a-buff R: -- ior ctok TWO_DROP ; -- c-a1 u1 c-a-buff R: -- ior ctok DROP ; -- x x R: -- ior ctok R_FROM ; -- x x ior R: -- ctok EXIT ; -- u2 flag ior, failure indicated by ior, ud2 subs for u2 flag rlineZZ: ctok UDMIN ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud' ctok ROT ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ud' fid ctok REPOFILEW ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior ctok QDUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior|- compif rline5 ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior, we had a reposition err ctok NIP ; Only the IOR matters here, so we toss three stack items ctok NIP ; and, leave whatever was below to fill out stack return. ctok NIP ; -- x x ior, we had a reposition error ctok EXIT rline5: ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars R: -- ctok DUP ; we start off assuming all chars will count in the count ctok TO_R ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars R: -- uchars ctok ONE_MINUS ; -- c-a1 u1 c-a-buff uchars c-a-buff u4 R: -- uchars ; we want to point *to* the last char, the LF, not *past* it ctok CHARS ; -- c-a1 u1 c-a-buff uchars c-a-buff u4' R: -- uchars ctok PLUS ; -- c-a1 u1 c-a-buff uchars c-addr2 R: -- uchars ctok DUP ; -- v-a1 u1 c-a-buff uchars c-addr2 c-addr2 R: -- uchars ctok C_FETCH ; -- c-a1 u1 c-a-buff uchars c-addr2 char R: -- uchars literal lFeed ctok EQUAL ; -- c-addr1 u1 c-a-buff uchars c-addr2 flag R: -- uchars compif rline6 ; Last char we read into buffer turns out to be LF ctok R_FROM ; -- c-addr1 u1 c-a-buff uchars c-addr2 uchars R: -- ctok ONE_MINUS ; -- c-addr1 u1 c-a-buff uchars c-addr2 uchars' R: -- ctok TO_R ; -- c-addr1 u1 c-a-buff uchars c-addr2 R: -- uchars' literal 1 ctok CHARS ; subtract a char from the returned count ctok MINUS ; -- c-addr1 u1 c-a-buff uchars c-addr2' R: -- uchars' ctok C_FETCH ; -- c-addr1 u1 c-a-buff uchars char R: -- uchars' literal cRet ctok EQUAL ; -- c-addr1 u1 c-a-buff uchars flag R: -- uchars' compif rline7 ; There's a CR before the LF ctok R_FROM ctok ONE_MINUS ; subtract yet another char from the returned count ctok TO_R ; -- c-addr1 u1 c-a-buff uchars R: -- uchars'' compelse rline7 rline6: ; -- c-addr1 u1 c-a-buff uchars c-addr2 R: -- uchars' ctok DROP ; get rid of extra address, we don't check for CR rline7: ; -- c-addr1 u1 c-a-buff uchars R: -- uchars'' ctok ROT ; -- c-addr1 c-a-buff uchars u1 R: -- uchars'' ctok MIN ; -- c-addr1 c-a-buff u R: -- uchars'' literal 0 ctok MAX ; -- c-addr1 c-a-buff u R: -- uchars'' ctok TO_R ctok SWAP ctok R_FROM ; -- c-a-buff c-addr1 u R: -- uchars'' ctok CMOVE ; -- R: -- uchars'' ctok R_FROM ctok TRUE literal 0 ; -- u flag ior R: -- ctok UNNEST fnamemanque <REPOSITION-FILE> ; ud fileid -- ior (== 0 | system err) fw_REPOFILE: ; FILE defers nnamemanque <REPOSITION-FILEW> ; ud-chars fileid -- ior (== 0 | system err) fw_REPOFILEW: ; FILE ctok NEST ctok TO_R ; -- ud-chars R: -- fileid literal tchar ; -- ud-chars u R: -- fileid ctok UDSTARU ; -- ud-bytess R: -- fileid ctok R_FROM ; -- ud-chars fileid R: -- ctok REPOFILEA ; -- ior ctok UNNEST nnamemanque <REPOSITION-FILEA> ; ud-bytes fileid -- ior (== 0 | system err) fw_REPOFILEA: ; FILE docode pop edx ; fileid pop DWORD PTR distMoveHigh ; hi word of dist to move pop eax ; low INVOKE SetFilePointer, edx, eax, OFFSET FLAT:distMoveHigh, FILE_BEGIN cmp eax,-1 ; if -1, must check distMoveHigh jne repofile1 cmp DWORD PTR distMoveHigh,0 ; if zero, we have an err jne repofile1 ; not zero is success INVOKE GetLastError ; get error push eax ; push error ior store lastError,eax ; to be consistent with rest of system next repofile1: xor eax,eax push eax ; success, ior is zero next fnamemanque <RESIZE-FILE> ; ud fileid -- ior (== 0 | system err) fw_RESIZEFILE: ; FILE defers nnamemanque <RESIZE-FILEW> ; ud-chars fileid -- ior (== 0 | system err) fw_RESIZEFILEW: ; FILE ctok NEST ctok TO_R ; -- ud-chars R: -- fileid literal tchar ctok UDSTARU ; -- ud-bytes R: -- fileid ctok R_FROM ; -- ud-bytes fileid ctok RESIZEFILEA ; -- ior ctok UNNEST nnamemanque <RESIZE-FILEA> ; ud-bytes fileid -- ior (== 0 | system err) fw_RESIZEFILEA: ; FILE ctok NEST ctok DUP ; -- ud fileid fileid ctok TO_R ; -- ud fileid R: -- fileid ctok REPOFILEA ; -- flag R: -- fileid ctok R_FROM ; -- flag fileid ctok SWAP ; -- fileid flag ctok DUP ; -- fileid flag flag ctok ZEROEQ compif resizefile1 ctok DROP ; -- fileid ctok SETEOF ; -- ior ctok EXIT resizefile1: ctok SWAP ; -- ior fileid ctok DROP ; -- ior ctok UNNEST ; -- ior sname <SETEOF> ; fileid -- ior Set end of file at current file pointer docode mov eax,[esp] INVOKE SetEndOfFile, eax and eax,eax je seteofend INVOKE GetLastError mov [esp],eax next seteofend: xor eax,eax mov [esp],eax next fnamemanque <WRITE-FILE> ; b|c-addr u fileid -- ior (== 0 | system err) fw_WRITEFILE: defers nnamemanque <WRITE-FILEW> ; c-addr u fileid -- ior (== 0 | system err) fw_WRITEFILEW: ctok NEST ctok SWAP ; -- c-addr fileid u-chars ctok TWO_STAR ; -- c-addr fileid u-bytes ctok SWAP ; -- c-addr u-bytes fileid ctok WRITEFILEA ; -- ior ctok UNNEST nnamemanque <WRITE-FILEA> ; b-addr u fileid -- ior (== 0 | system err) fw_WRITEFILEA: ; FILE docode pop edx ; fileid pop ecx ; u1 pop eax ; c-addr add eax,dp ; abs-addr INVOKE WriteFile, edx, eax, ecx, OFFSET FLAT:numRead, 0 and eax,eax jne writefile1 ; result was bool true, so we branch on success INVOKE GetLastError ; get error push eax ; push error ior store lastError,eax ; to be consistent with rest of system next writefile1: xor eax,eax push eax ; success, ior is zero next fnamemanque <R/O> ; -- x fw_RO: ctok DOCONST ; FILE dd GENERIC_READ fnamemanque <R/W> ; -- x fw_RW: ctok DOCONST ; FILE dd GENERIC_READ OR GENERIC_WRITE fnamemanque <W/O> ; -- x fw_WO: ctok DOCONST ; FILE dd GENERIC_WRITE fname <BIN> ; fam1 -- fam2 docode ; FILE next ;--( BLOCK stuff ) nnamemanque <BLOCK-FILE> ; -- a-addr fw_BLOCKFILE: ctok DOCONST dd blockFile ; holds the file id for active BLOCK file fname <BLOCK> ; u -- a-addr ctok NEST ctok DUP ; -- u u ctok INVALIDBLOCK ; -- u flag literal -35 ; invalid block number THROW ctok AND ; throw if block was invalid ctok THROW ctok BLOCKFILE ; -- u a-addr ctok FETCH ; -- u file-id ctok ZEROEQ ; -- u flag literal -37 ; file I/O exception ctok AND ; so that we either THROW a -37 or a 0 (e.g., continue on) ctok THROW literal blockNum ; -- u a-addr ctok FETCH ; -- u1 u2 ctok OVER ; -- u1 u2 u1 ctok NEQUAL ; -- u flag TRUE if blockBuffer doesn't current hold that block number compif block2 ; -- u If they are equal, jump ahead and exit ctok DUP ; -- u u Not equal, get a BUFFER ctok BUFFER ; -- u a-addr ctok SWAP ; -- a-addr u literal blockSize ctok UMSTAR ; -- a-addr ud ctok BLOCKFILE ctok FETCH ; -- a-addr ud file-id ctok REPOFILEW ; -- a-addr flag compif block1 literal -35 ; Invalid Block Number ctok THROW block1: ; -- a-addr literal blockSize ctok BLOCKFILE ctok FETCH ; -- a-addr ud file-id ctok READFILEW ; -- numread ior ctok SWAP ; -- ior numread literal blockSize ; -- ior numread n ctok NEQUAL ; -- ior flag ctok OR ; -- flag compif block3 literal -33 ; BLOCK read error ctok THROW block2: ; -- u we're already there ctok DROP ; -- block3: literal blockBuffer ; -- a-addr ctok UNNEST nname <BLOCKNUM> ctok DOCONST dd blockNum nname <UPDATED> ctok DOCONST dd updated fname <BUFFER> ; u -- a-addr ctok NEST literal blockNum ctok FETCH ; -- u1 u2 ctok OVER ; -- u1 u2 u1 ctok NEQUAL ; -- u flag TRUE if blockBuffer doesn't current hold that block number compif buffer2 literal updated ctok FETCH ; -- u flag Is BLOCK we're going to replace an UPDATEd BLOCK? compif buffer1 ctok SAVEBUFFERS ; -- u Yes, save buffer(s), mark not updated buffer1: literal blockNum ctok STORE ; -- Renumber buffer compelse buffer3 buffer2: ; -- u Buffer was already present ctok DROP ; -- buffer3: literal blockBuffer ; -- a-addr ctok UNNEST fnamemanque <EMPTY-BUFFERS> ; -- fw_EMPTYBUFFERS: ; BLOCK EXT ctok NEST ctok FALSE literal updated ctok STORE ctok TRUE literal blockNum ctok STORE literal blockBuffer literal blockSize ctok BL ctok FILL ctok UNNEST fnamemanque <SAVE-BUFFERS> ; -- fw_SAVEBUFFERS: ; BLOCK ctok NEST literal updated ctok FETCH ; -- flag compif savebuf7 ; 0 == not updated, leave literal blockNum ctok FETCH ; -- n ctok TRUE ctok NEQUAL ; -- flag compif savebuf7 ; BLOCK number of TRUE == no block, leave ctok BLOCKFILE ctok FETCH ; -- file-id ctok DUP ; -- file-id file-id ctok ZEROEQ ; -- file-id flag compif savebuf4 ; 0 == no BLOCK file literal -37 ; file I/O exception ctok THROW savebuf4: ; yes, there is a BLOCK file handle in the controlling blockFile variable literal blockNum ; -- file-id u ctok FETCH literal blockSize ; -- file-id u' ctok UMSTAR ; -- file-id ud literal 2 ctok PICK ; -- file-id ud file-id ctok REPOFILEW ; -- file-id ior compif savebuf5 literal -35 ; Invalid Block Number ctok THROW savebuf5: literal blockBuffer ; -- file-id c-addr literal blockSize ; -- file-id c-addr u ctok ROT ; -- file-id c-addr u file-id ctok WRITEFILEW ; -- ior compif savebuf6 literal -34 ; BLOCK write error ctok THROW savebuf6: ctok FALSE ; -- 0 literal updated ctok STORE ; -- compelse savebuf7 savebuf7: ctok UNNEST fname <FLUSH> ; -- ctok NEST ; BLOCK ctok SAVEBUFFERS ctok EMPTYBUFFERS ctok UNNEST fname <UPDATE> ; -- ctok NEST ; BLOCK ctok TRUE literal updated ctok STORE ctok UNNEST fname <SCR> ; -- a-addr ctok DOCONST ; BLOCK EXT dd var_scr fname <LIST> ; u -- ctok NEST ; BLOCK EXT ctok DUP ctok SCR ctok STORE ; -- u ctok PAGE ctok DOKDOTQUOTE dd listMsg1 ctok DUP ; -- u u ctok DOT ; -- u literal 28 literal 0 ctok AT_XY ; center justify ctok DOKDOTQUOTE dd listMsg2 ctok BLOCKFILE ; -- u a-addr ctok FETCH ; -- u1 fid ctok DOT ; -- u1 ctok BLOCK ; -- a-addr literal 16 literal 0 compdo list2 list1: ctok CR ; -- a-addr ctok I ; -- a-addr n ctok DUP ; -- a-addr n n literal 2 ctok DOT_R ; -- a-addr n ctok SPACE literal 64 ctok CHARS ctok STAR ; -- a-addr n' ctok OVER ; -- a-addr n' a-addr ctok PLUS ; -- a-addr1 a-addr2 literal 64 ctok TYPE ; -- a-addr1 ctok I literal 2 ctok DOT_R ; -- a-addr comploop list1 list2: ctok DROP ; -- ctok UNNEST fname <LOAD> ; i*x u -- j*x ctok NEST ; BLOCK ctok QDUP ctok ZEROEQ compif load1 ctok okPrompt ctok QUIT ; Quit if Block number is 0 load1: ctok BLK ; Save input on return stack ctok FETCH ctok TO_R ctok TIB ctok TO_R ctok NUMTIB ctok FETCH ctok TO_R ctok TO_IN ctok FETCH ctok TO_R ctok SOURCE_ID ctok FETCH ctok TO_R literal endq ctok FETCH ctok TO_R ctok FALSE literal endq ctok STORE ctok BLK ctok STORE ctok FALSE ctok SOURCE_ID ctok STORE ctok FALSE ctok TO_IN ctok STORE ctok INTERPRET ctok R_FROM ; Restore input spec literal endq ctok STORE ctok R_FROM ctok SOURCE_ID ctok STORE ctok R_FROM ctok TO_IN ctok STORE ctok R_FROM ctok NUMTIB ctok STORE ctok R_FROM ctok TICK_TIB ctok STORE ctok R_FROM ctok BLK ctok STORE ; -- j*x R: -- ctok UNNEST fname <THRU> ; i*x u1 u2 -- j*x ctok NEST ; BLOCK EXT ctok ONE_PLUS ctok SWAP compqdo thru2 thru1: ctok I ctok LOAD comploop thru1 thru2: ctok UNNEST zname <INVALIDBLOCK> ; u -- flag ctok NEST ctok ONE_PLUS ; we're calculating the bytes needed to complete the BLOCK. literal blockSize ; -- u1 u2 ctok UMSTAR ; -- ud ctok BLOCKFILE ; -- ud a-addr ctok FETCH ; -- ud file-id ctok FILESIZEW ; -- ud1 ud2 ior ctok ZERONE ; -- ud1 ud2 flag literal -37 ; file I/O exception ctok AND ; so that we either THROW a -37 or a 0 (e.g., continue on) ctok THROW ctok TWO_SWAP ; -- ud2 ud1 ctok UD_LESS ; block requested greater than blocks in file? ( ud2 < ud1 ) if so, invalid block ctok UNNEST ; END of jx4files.a