From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- system/dos/1986/doc/DSKDOS.ELA | 967 ++++++++++++++++++++++ system/dos/1986/src/252 | Bin 0 -> 1024 bytes system/dos/1986/src/253 | Bin 0 -> 1024 bytes system/dos/1986/src/254 | Bin 0 -> 1024 bytes system/dos/1986/src/255 | Bin 0 -> 1024 bytes system/dos/1986/src/COND.TXT | 5 + system/dos/1986/src/block i-o | 104 +++ system/dos/1986/src/cluster | 109 +++ system/dos/1986/src/disk descriptor.dos.fd | 290 +++++++ system/dos/1986/src/disk descriptor.dos.hd | 290 +++++++ system/dos/1986/src/disk manager | 245 ++++++ system/dos/1986/src/eu disk descriptor.fd | 102 +++ system/dos/1986/src/eu disk descriptor.hd | 102 +++ system/dos/1986/src/eumel-ebcdic + sub | 550 +++++++++++++ system/dos/1986/src/fat and dir.dos.fd | 1190 ++++++++++++++++++++++++++++ system/dos/1986/src/fat and dir.dos.hd | 1190 ++++++++++++++++++++++++++++ system/dos/1986/src/fetch | 333 ++++++++ system/dos/1986/src/files.dos | 23 + system/dos/1986/src/gen.dos | 99 +++ system/dos/1986/src/manager-M.dos.fd | 198 +++++ system/dos/1986/src/manager-M.dos.hd | 198 +++++ system/dos/1986/src/name conversion | 77 ++ system/dos/1986/src/open | 51 ++ system/dos/1986/src/save | 273 +++++++ system/dos/1986/src/shard interface | 19 + system/dos/1986/src/table thes.dos | 5 + 26 files changed, 6420 insertions(+) create mode 100644 system/dos/1986/doc/DSKDOS.ELA create mode 100644 system/dos/1986/src/252 create mode 100644 system/dos/1986/src/253 create mode 100644 system/dos/1986/src/254 create mode 100644 system/dos/1986/src/255 create mode 100644 system/dos/1986/src/COND.TXT create mode 100644 system/dos/1986/src/block i-o create mode 100644 system/dos/1986/src/cluster create mode 100644 system/dos/1986/src/disk descriptor.dos.fd create mode 100644 system/dos/1986/src/disk descriptor.dos.hd create mode 100644 system/dos/1986/src/disk manager create mode 100644 system/dos/1986/src/eu disk descriptor.fd create mode 100644 system/dos/1986/src/eu disk descriptor.hd create mode 100644 system/dos/1986/src/eumel-ebcdic + sub create mode 100644 system/dos/1986/src/fat and dir.dos.fd create mode 100644 system/dos/1986/src/fat and dir.dos.hd create mode 100644 system/dos/1986/src/fetch create mode 100644 system/dos/1986/src/files.dos create mode 100644 system/dos/1986/src/gen.dos create mode 100644 system/dos/1986/src/manager-M.dos.fd create mode 100644 system/dos/1986/src/manager-M.dos.hd create mode 100644 system/dos/1986/src/name conversion create mode 100644 system/dos/1986/src/open create mode 100644 system/dos/1986/src/save create mode 100644 system/dos/1986/src/shard interface create mode 100644 system/dos/1986/src/table thes.dos (limited to 'system/dos') diff --git a/system/dos/1986/doc/DSKDOS.ELA b/system/dos/1986/doc/DSKDOS.ELA new file mode 100644 index 0000000..69bc714 --- /dev/null +++ b/system/dos/1986/doc/DSKDOS.ELA @@ -0,0 +1,967 @@ +#type ("17.klein")# +prefix of extended fcb: + + offset size name + -7 1 flag byte 255 + -6 5 reserved + -1 1 attribute byte 2=hidden file, 4=system file + +normal fcb format: + + offset size name + 0 1 drive number 0=default (for open), 1=A, 2=B + 1 8 filename 8 chars, left aligned and padded + (if necessary) with blanks + 9 3 extension 3 chars, left aligned and padded + (if necessary) with blanks + 12 2 current block pointer to the block of 128 records + containing the current record + (0 after open) + 14 2 record size logical record size in bytes + (128 after open, changed eventually) + 16 4 file size file size in bytes (1. byte low) + 20 2 date of last write 20:mmmddddd 21:yyyyyyym + 22 2 time of last write 22:mmmsssss 23:hhhhhmmm + 24 8 reserved + 32 1 current record pointer to one of the 128 records in + the block (not initialized by open) + must be set before sequential read/write + 33 4 relative record pointer to selected record + (counting from the beginning of file by 0) + not initialized by open + must be set before sequential read/write + record size less than + 64 bytes: both words used + else only first 3 bytes + +fields of directory entry: + + offset size name + 0 8 filename 8 chars, left aligned and padded + (if necessary) with blanks + special use of first byte: + 0 : end of allocated directory + 229: free directory entry + 8 3 extension 3 chars, left aligned and padded + (if necessary) with blanks + 11 1 attributes 1: read only file + 2: hidden file + 4: system file + 8: entry is the volume's id + 16: entry is subdirectory's name + 32: archive bit (set, when written to) + 12 10 reserved + 22 2 time of last write 22:mmmsssss 23:hhhhhmmm + 24 2 date of last write 24:mmmddddd 25:yyyyyyym + 26 2 reserved + 28 4 file size file size in bytes (1. byte low) + +directory structure: + + - the root directory has a fixed number of entries + - entries that represent a subdirectory have a special attribute in their + entry set + - the subdirectories are themselves files which records are of the same type + as those in the root directory + - the number of entries in subdirectories are not limited + - the length of a path to a subdirectory is not limited + +application of the directory entry fields on subdirectory entries: + + volume id : present at root, only one entry has this attribute + directory : the directory entry represents itself an directory + read only : meaningless + archive : meaningless + hidden/system: prevents directories from beeing found, function $3B + will still work + +ms-dos interrupts: + + $20 : program terminate + call: + CS: segment address + terminates process, returns control to parent process, + file handles are closed, disk cache cleaned, file buffers flushed + programm terminate, alt-c and critical error addresses are restored + new programs should use function $4C + $21 : function request + call: + AH: function number + other registers dependent on function + $22 to $24 : + address locations for msdos use + can be changed by function $25 + $22 : terminate address + $23 : alt-c exit address + address of an alt-c routine + $24 : fatal error abort address + address of the error handler + BP:SI can contain further information + not called if error occurs during absolute disk operations (int $25,$26) + $25 : absolute disk read + call: + AL: drive number + DS:BX: disk transfer address + CX: number of sectors + DX: beginning relative sector + return: + CF: 0=successful + 1=unsuccessful + AL: error code if unsuccessful + $26 : absolute disk write + call: + AL: drive number + DS:BX: disk transfer address + CX: number of sectors + DX: beginning relative sector + return: + CF: 0=successful + 1=unsuccessful + AL: error code if unsuccessful + $27 : terminate but stay resident + call: + CS:DX: first byte following the code + new programms should use function $31 + +ms-dos function requests: + + $00 : terminate program + call: + AH: $00 + CS: segment of programm prefix + $01 : read keyboard and echo + call: + AH: $01 + return: + AL: character typed + waits for input, echos and returns it + alt-c will call interrupt + $02 : display character + call: + AH: $02 + DL: character to be displayed + alt-c will call interrupt + $03 : auxiliary input + call: + AH: $03 + return: + AL: character from auxiliary device + waits for input, alt-c will call interrupt + $04 : auxiliary output + call: + AH: $04 + DL: character to output + alt-c will call interrupt + $05 : print character + call: + AH: $05 + DL: character for printer + alt-c will call interrupt + $06 : direct console i/o + call: + AH: $06 + DL: $FF: check for keyboard input + otherwise: display DL on screen + return: + ZF: 0=no char available + 1=char was read + AL: char if read + $07 : direct konsole input + call: + AH: $07 + return: + AL: character from keyboard + waits for character + $08 : read keyboard + call: + AH: $08 + return: + AL: character from keyboard + waits for character, alt-c will call interrupt + $09 : display string + call: + AH: $09 + DS:DX: string, ending with '$' + $0A : buffered keyboard input + call: + AH: $0A + DS:DX: input buffer + byte 1: maximum number of chars in buffer (with CR) + 2: actual number of chars in buffer (set by function) + 3-n: must be at least as long as the max + waits for chars, allows editing, ignores overflow, + alt-c will call interrupt + $0B : check keyboard status + call: + AH: $0B + return: + AL: 0=no chars in type-ahead buffer + 255=chars available + $0C : flush buffer and read keyboard + call: + AH: $0C + AL: $01,$06,$07,$08 or $0A: corresponding function is called + other values: no further processing + return: + AL: 0=type ahead buffer was flushed, no processing performed + $0D : disk reset + call: + AH: $0D + all disk buffers are flushed, no directory updates performed + $0E : select disk + call: + AH: $0E + DL: drive number, 1=A, 2=B, .. + return: + AL: number of logical drives + $0F : open file + call: + AH: $0F + DS:DX: unopened fcb + return: + AL: 0=directory entry found + if drive code was 0, it is set to the default + current block is set to 0 + record size is set to 128 + file size, time and date of last modification are set + from directory + the default record size must be set, if not 128 + before performing a sequential (random) operation, + current record (relative record) field must be set + 255=no directory entry found + + $10 : close file + call: + AH: $10 + DS:DX: opened fcb + return: + AL: 0=directory entry found + 255=no directory entry found + $11 : search for first entry + call: + AH: $11 + DS:DX: unopened fcb + return: + 0=directory entry found + fcb (normal or extended) is created + at the disk transfer address + 255=no directory entry found + to search for hidden or system files, the fcb must be extended + see notes on search attributes + $12 : search for next entry + call: + AH: $12 + DS:DX: unopened fcb + return: + AL: 0=directory entry found + fcb (normal or extended) is created + at the disk transfer address + 255=no directory entry found + the fcb must be one used previously in a call to $11 + $13 : delete file + call: + AH: $13 + DS:DX: unopened fcb + return: + AL: 0=directory entry found + 255=no directory entry found + deletes all files with matching names + $14 : sequential read + call: + AH: $14 + DS:DX: opened fcb + return: + AL: 0=read completed successfully + 1=eof, no data in the record + 2=dta too small, not enough space to read without exceeding + the segment boundaries, read cancelled + 3=eof, partial record was read and padded to the record + length with zeros + the record pointed to by the current block and current record + is loaded to the disk transfer address and the fields are incremented + $15 : sequential write + call: + AH: $15 + DS:DX: opened fcb + return: + AL: 0=write completed successfully + 1=disk full, write canceled + 2=dta too small to write one record without exceeding the + segment boundaries, write canceled + the record pointed to by the current block and current record + are written from the disk transfer address and the fields are incremented + $16 : create file + call: + AH: $16 + DS:DX: unopened fcb + return: + AL: 0=empty directory entry found + 255=no empty entry available and file didn't exist before + if the file does already exist, it is made a zero length file + else it is created if an empty entry is found + $17 : rename file + call: + AH: $17 + DS:DX: modified fcb + return: + AL: 0=directory entry found + 255=no directory entry found or destination already exists + the fcb must contain the search file name and another file name + at offset $11 + $19 : current disk + call: + AH: $19 + return: + AL: selected drive (0=A, 1=B, .. ) + $1A : set disk transfer address + call: + AH: $1A + DS:DX: disk transfer address + default is $80 in the psp + $21 : random read + call: + AH: $21 + DS:DX: opened fcb + return: + 0=read completed successfully + 1=eof, no data read + 2=dta too small, read canceled + 3=eof, partial record, padded with zeros + the current block and current record fields are set to match the + relative record field, then the record is loaded + $22 : random write + call: + AH: $22 + DS:DX: opened fcb + return: + AL: 0=write completed successfully + 1=disk full + 2=dta too small, read canceled + $23 : file size + call: + AH: $23 + DS:DX: unopened fcb + return: + AL: 0=directory entry found + the relative record field is set to the number + of records in the file + 255=no directory entry found + the record size field must be set + $24 : set relative record + call: + AH: $24 + DS:DX: opened fcb + the relative record field is set to the same record as the current block + an the current record field + $25 : set vector + call: + AH: $25 + AL: interrupt number + DS:DX: interrupt handling routine + $27 : random block read + call: + AH: $27 + DS:DX: opened fcb + CX: number of blocks to read + return: + AL: 0=read completed successfully + 1=eof, no data read + 2=end of segment, read canceled + 3=eof, partial record, padded with zeros + CX: number of blocks read + the reading starts at the relative record + the current block, current record and relative record field are updated + $28 : random block write + call: + AH: $28 + DS:DX: opened fcb + CX: number of records to write + 0=set file size + the file size field of thedirectory entry is set to the number + of records specified by the relative record field + return: + AL: 0=write completed successfully + 1=disk full, no records written + 2=end of dta-segment, read canceled + CX: number of blocks written + the writing starts at the relative record + the current block, current record and relative record field are updated + $29 : parse file name + call: + AH: $29 + AL: controls parsing + bit 0: if file separators are encountered + (: . ; , = + / " [ ] \ < ] | blank tab) + 0: all parsing stops + 1: leading separators are ignored + bit 1: if the string does not contain a drive letter + 0: the fcb drive number is set to 0 (default) + 1: the fcb drive number is not changed + bit 2: if the string does not contain a filename + 0: the fcb filename is set to 8 blanks + 1: the fcb filename is not changed + bit 3: if the string does not contain an extension + 0: the fcb extension is set to three blanks + 1: the fcb extension is not changed + DS:SI: string to parse + filename terminators include all filename separators + plus any control character + ES:DI: if the string contained a valid filename, + it points to an unopened fcb + else ES:DI+1 points to a blank + return: + AL: 0=no wild card characters + 1=wild card characters used + 255=drive letter invalid + DS:SI: first byte past string that was parsed + if the filename contains an asterisk, + all folowing letters are set to question mark + ES:DI: unopened fcb + if filename is found, an unopened fcb is created here + $2A : get date + call: + AH: $2A + return: + CX: year (1980-2099) + DH: month (1-12) + DL: day (1-31) + AL: day of week (0=sun, .., 6=sat) + $2B : set date + call: + AH: $2B + CX: year (1980-2099) + DH: month (1-12) + DL: day (1-31) + return: + AL: 0=date was valid + 255=date was invalid + $2C : get time + call: + AH: $2C + return: + CH: hour (0-23) + CL: minutes (0-59) + DH: seconds (0-59) + DL: hundredths (0-99) + $2D : set time + call: + AH: $2D + CH: hour (0-23) + CL: minutes (0-59) + DH: seconds (0-59) + DL: hundredths (0-99) + return: + AL: 0=time was valid + 255=time was invalid + $2E : set/reset verify flag + call: + AH: $2E + AL: 0=do not verify + 1=verify + $2F : get disk transfer address + call: + AH: $2F + return: + ES:BX: points to disk transfer address + $30 : get dos version number + call: + AH: $30 + return: + AL: major version number + AH: minor version number + $31 : keep process + call: + AH: $31 + AL: exit code + DX: memory size in paragraphs + attemts to set the initial allocation block to a specific size + in paragraphs, will not free up other allocation blocks belonging + to that process, the exit code is available via function $4D + $33 : alt-c check + call: + AH: $33 + AL: function + 0=request current state + 1=set state + DL: if setting + 0=off + 1=on + return: + AL: 255=al parameter was not in range 0..1 + DL: if requesting current state + 0=off + 1=on + if check is on, every system call executes the check, + else only the device operations + $35 : get interrupt vector + call: + AH: $35 + AL: interrupt number + return: + ES:BX: pointer to interrupt routine + $36 : get disk free space + call: + AH: $36 + DL: drive (0=default, .....) + return: + BX: available clusters + DX: clusters per drive + CX: bytes per sector + AX: $FFFF=drive number invalid + otherwise sectors per cluster + $38 : return country-dependent information + call: + AH: $38 + DS:DX: pointer to 32 byte memory area + area format: + size name + 2 date/time format + 0=usa standard h:m:s m/d/y + 1=europe standard h:m:s d/m/y + 2=japan standard y/m/d h:m:s + 5 asciz currency symbol + 2 asciz thousands separator + 2 asciz decimal separator + 2 asciz date separator + 2 asciz time separator + 1 bit field + bit 0: 0=currency symbol precedes amount + 1=symbol comes after amount + bit 1: 0=symbol immediately precedes the amount + 1=space between symbol and amount + 1 currency places + figures after decimal point of currency amounts + 1 time format + 0=12 hour time + 1=24 hour time + 4 case mapping call + FAR procedure performs country-specific + lower- to uppercase mapping + 2 asciz data list separator + if dx=-1 and the country code in AL is found, + the current country is set accordingly + + AL: function code + 0=current country + or country code (usually international telephone prefix) + must be 0 in msdos 2.0 (only fully implemented after 2.01) + return: + CARRY: 1 + AX: 2=file not found + CARRY: 0 + DS:DX: filled with country data + $39 : create subdirectory + call: + AH: $39 + DS:DX: pointer to pathname (asciz) + return: + CARRY: 1 + AX: 3=path not found + 5=access denied + no room in parent, + directory already exists or device was specified + CARRY: 0=no error + $3A : remove a directory entry + call: + AH: $3A + DS:DX: pointer to pathname (asciz) + return: + CARRY: 1 + AX: 3=path not found + 5=access denied + directory not empty, not a directory, root directory + 16=current directory + CARRY: 0=no error + $3B : change the current directory + call: + AH: $3B + DS:DX: pointer to pathname (asciz) + return: + CARRY: 1 + AX: 3=path not found + CARRY: 0=no error + $3C : create a file + call: + AH: $3C + DS:DX: pointer to pathname + CX: file attribute + return: + CARRY: 1 + AX: 3=path not found + 4=too many open files + file was created, but no room for handle + 5=access denied + uncreatable attribute (directory or volume id), + a file with a more inklusive attribute set exists, + or a directory with the same name exists + CARRY: 0 + AX is handle number + handle is open for read/write + creates a new file or truncates existing to length 0 + $3D : open a file + call: + AH: $3D + DS:DX: pointer to pathname (asciz) + AL: access + 0=open for reading + 1=open for writing + 2=open for both + return: + CARRY: 1 + AX: 2=file not found + 4=too many open files + no file handles available + 5=access denied + attempted to open a directory, volume id or + a read only file for writing + 12=invalid access + AL was not in range 0..2 + CARRY: 0 + AX is handle number + read/write pointer is set to the first byte of the file + and the record size is set to 1 + the returned file handle must be used in subsequent operations + $3E : close a file handle + call: + AH: $3E + BX: file handle + return: + CARRY: 1 + 6=invalid handle (not currently open) + CARRY: 0=no error + the associated file is closed, buffers are flushed + $3F : read from file/device + call: + AH: $3F + DS:DX: pointer to buffer + CX: bytes to read + BX: file handle + return: + CARRY: 1 + AX: 5=access denied + not opened for read + 6=invalid handle (not currently open) + CARRY: 0 + AX: number of bytes read + 0=eof + $40 : write to file/device + call: + AH: $40 + DS:DX: pointer to buffer + CX: bytes to write + if 0, the file size is set to the current position + BX: file handle + return: + CARRY: 1 + AX: 5=access denied + 6=invalid handle + CARRY: 0 + AX: number of bytes written + is error if not the same number as requested + $41 : delete a directory entry + call: + AH: $41 + DS:DX: pointer to pathname + return: + CARRY: 1 + AX: 2=file not found + 5=access denied + directory or read only + CARRY: 0=no error + $42 : move file pointer + call: + AH: $42 + CX:DX: distance to move, in bytes + AL: method of moving + 0=move pointer to offset from beginning of file + 1=move to offset from current location + 2=move to offset from eof + BX: file handle + return: + CARRY: 1 + AX: 1=invalid function + AL not in range 0..2 + 6=invalid handle + CARRY 0: + DX:AX: new pointer location + moves the read/write file pointer + $43 : change attributes + call: + AH: $43 + DS:DX: pointer to pathname (asciz) + AL: function + 0=return in CX + 1=set to CX + CX: if AL=1 + attribute to be set + return: + CARRY: 1 + AX: 1=invalid function + AL not in range 0..1 + 3=path not found + 5=access denied + CX contained attributes that can not be changed + (directory, volume id) + CARRY: 0 + if AL=0 + CX: attributes + $44 : i/o control for devices + call: + AH: $44 + BX: handle + BL: (for calls AL=4, 5) drive: 0=default, .. + DS:DX: data or buffer + CX: bytes to read or write + AL: function code + calls 0,1: bits of DX (DH must be 0 on a set call) + 0: iscin + 1: iscot + 2: isnul + 3: isclk + 4: specl + 5: raw + 6: eof + 7: isdev + 8-13: reserved + 14: ctrl + 15: res + if isdev=0 then channel is a disk file + eof: 0=channel has been written + bits 0-5 are block device number for the channel + (0=a, 1=b, ..) + if isdev=1 then channel is device + eof : 0=end of file on input + raw : 0=this device is cooked + 1=device in raw mode + isclk: 1=clock + isnul: 1=nul + iscot: 1=console output + iscin: 1=console input + specl: 1=device is special + ctrl : 0=device can not do control strings + via calls 2,3 + 1=can do control + 0=get device information (returned in DX) + 1=set device information (according to DX) + calls 2,5: arbitrary control strings sent or received + to or from a device + call syntax is the same as in read/write calls, + except for 4 and 5, which take drive number in BL + instead of a handle in BX + an invalid function error is returned, if + the ctrl bit is 0 + 2=read CX number of bytes to DS:DX from device control channel + 3=write CX number of bytes from DS:DX to device control channel + 4=read CX number of bytes to DS:DX from device control channel + drive number in BL (0=default, ..) + 5=write CX number of bytes from DS:DX to device control channel + drive number in BL (0=default, ..) + calls 6,7: check, if a file handle is ready for i/o + intended for status of handles associated with + devices, but checks of file handles are allowed + and defined: input: always ready (255), until eof + then always not ready (0) + output: always ready + 6=get input status + 7=get output status + return: + CARRY: 1 + AX: 1=invalid function + 5=access denied + 6=invalid handle + 13=invalid data + CARRY: 0 + AL: 2,3,4,5 + AX: count transferred + AL: 6,7 + 0=not ready + 255=ready + sets or gets device information associated with an open handle + or sends or receives a control string to or from a device handle or device + if the function is used for files, only functions 0,6,7 are defined + $45 : duplicate a file handle + call: + AH: $45 + BX: file handle + return: + CARRY: 1 + AX: 4=too many files open + 6=invalid handle + CARRY: 0 + AX: new file handle + retruns a new handle that refers to the same file + $46 : force a duplicate of a handle + call: + AH: $46 + BX: existing file handle + CX: new file handle + return: + CARRY: 1 + AX: 4=too many open files + 6=invalid handle + CARRY: 0=no error + CX then refers to the same file as BX, eventually, CX is closed first + $47 : return text of current directory + call: + AH: $47 + DS:SI: pointer to 64 byte area + DL: drive number (0=default, ..) + return: + CARRY: 1 + AX: 15=invalid drive + CARRY: 0=no error + the path name does not contain the leading separators + $48 : allocate memory + call: + AH: $48 + BX: size of memory to be allocated + return: + CARRY: 1 + AX: 7=arena trashed + internal consistency has been destroyed + 8=not enough memory + BX: maximum size that could be allocated + CARRY: 0 + AX:0: pointer to the allocated memory + $49 : free allocated memory + call: + AH: $49 + ES: segment address of memory area to be freed + return: + CARRY: 1 + AX: 7=arena trashed + internal consistency has been destroyed + 9=invalid block + the block was not allocated by $49 + CARRY: 0=no error + returns a piece of memory to the system pool that was allocated with $49 + $4A : modify allocated memory blocks + call: + AH: $4A + ES: segment address of memory area + BX: requested memory area + return: + CARRY: 1 + AX: 7=arena trashed + internal consistency has been destroyed + 8=not enough memory + 9=invalid block + the block was not allocated by $49 + BX: maximum size possible + CARRY: 0=no error + attempts to grow or shrink an allocated block + $4B : load and execute a program + call: + AH: $4B + DS:DX: pointer to pathname (asciz) + ES:BX: pointer to parameter block + for AL=0: + size name + 2 segment address of environment + 4 pointer to command line at $80 + 4 pointer to default fcb to be passed at $5C + 4 pointer to default fcb to be passed at $6C + for AL=3: + size name + 2 segment address where file will be loaded + 2 relocation factor to be applied to the image + AL: 0=load and execute + 3=load (overlay) + return: + CARRY: 1 + AX: 1=invalid function + AL was not in range 0,3 + 2=file not found + 8=not enough memory + 10=bad environment + larger than 32K + 11=bad format + EXE file contained inconsistent information + CARRY: 0=no error + all open files of a parent are copied to the child process + also inherited is an environment (block of text strings less than 32K) + a zero environment address causes the child to inherit then parents + environment unchanged + $4C : terminate process + call: + AH: $4C + AL: return code + $4D : retrieve then return code of a child + call: + AH: $4D + return: + AX: exit code + high byte: 0=terminate/abort + 1=alt-c + 2=hard error + 3=terminate and stay resident + returns code only once + $4E : find match file + call: + AH: $4E + DS:DX: pointer to pathname + CX: search attributes + return: + CARRY: 1 + AX: 2=file not found + 18=no more files + CARRY: 0=no error + data block is written to current dma address: + size name + 21 reserved for subsequent calls + 1 attribute found + 2 time + 2 date + 2 low(size) + 2 high(size) + 13 packed name + subsequent calls: see $4F + $4F : step through a directory matching files + call: + AH: $4F + return: + CARRY: 1 + AX: 18=no more files + CARRY: 0=no error + only used for subsequent calls after $4E + dma address must point to the parablock + $54 : return current setting of verify after write flag + call: + AH: $54 + return: + current verify flag value + $56 : move a directory entry + call: + AH: $56 + DS:DX: pointer to pathname of existing file + ES:DI: pointer to new pathname + return: + CARRY: 1 + AX: 2=file not found + 5=access denied + path is directory or new file exists + or directory entry could not be created + 17=not same device + CARRY: 0=no error + attempts to rename a file in the directory of one device + $57 : get/set date/time of file + call: + AH: $57 + AL: 0=get date and time + 1=set date and time + BX: file handle + CX: if AL=1 + time to be set + DX: if AL=1 + date to be set + return: + CARRY: 1 + AX: 1=invalid function + 6=invalid handle + CARRY: 0=no error + CX: if AL=0 + time + DX: if AL=0 + date + date and time are not recorded until file is closed + diff --git a/system/dos/1986/src/252 b/system/dos/1986/src/252 new file mode 100644 index 0000000..b4369b6 Binary files /dev/null and b/system/dos/1986/src/252 differ diff --git a/system/dos/1986/src/253 b/system/dos/1986/src/253 new file mode 100644 index 0000000..c7a4494 Binary files /dev/null and b/system/dos/1986/src/253 differ diff --git a/system/dos/1986/src/254 b/system/dos/1986/src/254 new file mode 100644 index 0000000..f71eeb6 Binary files /dev/null and b/system/dos/1986/src/254 differ diff --git a/system/dos/1986/src/255 b/system/dos/1986/src/255 new file mode 100644 index 0000000..d21b649 Binary files /dev/null and b/system/dos/1986/src/255 differ diff --git a/system/dos/1986/src/COND.TXT b/system/dos/1986/src/COND.TXT new file mode 100644 index 0000000..02cb949 --- /dev/null +++ b/system/dos/1986/src/COND.TXT @@ -0,0 +1,5 @@ +FLOPPY = TRUE +HDU = FALSE +TEST = FALSE +DOS = TRUE +CPM = FALSE diff --git a/system/dos/1986/src/block i-o b/system/dos/1986/src/block i-o new file mode 100644 index 0000000..4336746 --- /dev/null +++ b/system/dos/1986/src/block i-o @@ -0,0 +1,104 @@ +PACKET disk block io DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 25.03.86 *) + read disk block, + read disk cluster, + write disk block, + write disk cluster, + io error, + first non dummy ds page: + +INT CONST first non dummy ds page := 2; + +INT VAR error; + +PROC read disk block (DATASPACE VAR ds, + INT CONST ds page no, + INT CONST block no, + INT VAR error): + check rerun; + read block (ds, ds page no, eublock (block no), error). + +END PROC read disk block; + +PROC read disk block (DATASPACE VAR ds, + INT CONST ds page no, + INT CONST block no): + check rerun; + read block (ds, ds page no, eublock (block no), error); + IF error <> 0 + THEN io error (error) + FI. + +END PROC read disk block; + +PROC read disk block (DATASPACE VAR ds, + INT CONST block no): + read disk block (ds, first non dummy ds page, block no) + +END PROC read disk block; + +PROC read disk cluster (DATASPACE VAR ds, + INT CONST first ds page no, + INT CONST cluster no): + INT VAR i; + FOR i FROM 0 UPTO sectors per cluster - 1 REP + read disk block (ds, first ds page no + i, block no + i) + PER. + +block no: + first block no of cluster (cluster no). + +END PROC read disk cluster; + +PROC write disk block (DATASPACE CONST ds, + INT CONST ds page no, + INT CONST block no, + INT VAR error): + check rerun; + write block (ds, ds page no, 0,eu block (block no), error). + +END PROC write disk block; + +PROC write disk block (DATASPACE CONST ds, + INT CONST ds page no, + INT CONST block no): + check rerun; + write block (ds, ds page no, 0, eu block (block no), error); + IF error <> 0 + THEN io error (error) + FI. + +END PROC write disk block; + +PROC write disk block (DATASPACE CONST ds, + INT CONST block no): + write disk block (ds, first non dummy ds page, block no) + +END PROC write disk block; + +PROC write disk cluster (DATASPACE CONST ds, + INT CONST first ds page no, + INT CONST cluster no): + INT VAR i; + FOR i FROM 0 UPTO sectors per cluster - 1 REP + write disk block (ds, first ds page no + i, block no + i) + PER. + +block no: + first block no of cluster (cluster no). + +END PROC write disk cluster; + +PROC io error (INT CONST error code): + SELECT error code OF + CASE 1: errorstop ("Laufwerk nicht betriebsbereit") + CASE 2: errorstop ("Schreib-/Lesefehler") + CASE 3: errorstop ("Interner Fehler (Blocknummer zu hoch)") + CASE 4: errorstop ("Block nicht lesbar") + OTHERWISE errorstop ("Schreib-/Lesefehler " + text (error)) + END SELECT. + +END PROC io error; + +END PACKET disk block io; diff --git a/system/dos/1986/src/cluster b/system/dos/1986/src/cluster new file mode 100644 index 0000000..ef2720b --- /dev/null +++ b/system/dos/1986/src/cluster @@ -0,0 +1,109 @@ +PACKET cluster DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + (* 19.03.86 *) + + CLUSTER, + :=, + text, + text 32, (* typical dir entry *) + write text, + write text 32, + reduce cluster buffer: + +LET max cluster size = 8192; (* 8192 * 8 = 64 KB *) + +TYPE CLUSTER = BOUND STRUCT (ALIGN dummy, + ROW max cluster size REAL cluster row); + +TEXT VAR string; +INT VAR string length; + +INT VAR sector no, eight byte pos, index; + +reduce cluster buffer; + +.reals per sector: sector size DIV 8. +.reals per std eu sector: 512 DIV 8. + +PROC reduce cluster buffer: + string := 32 * "*"; + string length := 32. + +END PROC reduce cluster buffer; + +OP := (CLUSTER VAR cluster, DATASPACE VAR ds): + CONCR (cluster) := ds + +END OP :=; + +TEXT PROC text (CLUSTER CONST cluster, INT CONST from, to): + init string; + FOR sector no FROM 0 UPTO sectors per cluster - 1 REP + get text of sector + PER; + subtext (string, from, to). + +init string: + IF string length < cluster size + THEN string := cluster size * "*"; + string length := cluster size + FI. + +get text of sector: + FOR eight byte pos FROM 1 UPTO reals per sector REP + replace (string, string index, cluster.cluster row [row index]) + PER. + +string index: + reals per sector * sector no + eight byte pos. + +row index: + reals per std eu sector * sector no + eight byte pos. + +END PROC text; + +TEXT PROC text 32 (CLUSTER CONST cluster, INT CONST part): + FOR index FROM 1 UPTO 4 REP + replace (string, index, cluster.cluster row [index + 4 * part]) + PER; + subtext (string, 1, 32). + +END PROC text 32; + +PROC write text (CLUSTER VAR cluster, + TEXT CONST string): + IF LENGTH string < cluster size + THEN execute write text (cluster, text (string, cluster size)) + ELSE execute write text (cluster, string) + FI. + +END PROC write text; + +PROC execute write text (CLUSTER VAR cluster, + TEXT CONST string): + FOR sector no FROM 0 UPTO sectors per cluster - 1 REP + write text of sector + PER. + +write text of sector: + FOR eight byte pos FROM 1 UPTO reals per sector REP + cluster.cluster row [row index] := string RSUB (string index) + PER. + +row index: + reals per std eu sector * sector no + eight byte pos. + +string index: + reals per sector * sector no + eight byte pos. + + +END PROC execute write text; + +PROC write text 32 (CLUSTER VAR cluster, TEXT CONST string, INT CONST part): + FOR index FROM 1 UPTO 4 REP + cluster.cluster row [index + 4 * part] := string RSUB (index) + PER; + +END PROC write text 32; + +END PACKET cluster; diff --git a/system/dos/1986/src/disk descriptor.dos.fd b/system/dos/1986/src/disk descriptor.dos.fd new file mode 100644 index 0000000..660dd46 --- /dev/null +++ b/system/dos/1986/src/disk descriptor.dos.fd @@ -0,0 +1,290 @@ +PACKET dos disk DEFINES (* Copyright (C) 1985, 86 *) + (* Frank Klapper *) + first fat byte, (* 30.05.86 *) + begin of fat, + number of fat sectors, + number of fat entrys, + number of fat copies, + begin of dir, + number of dir sectors, + begin of data area, + sectors per cluster, + cluster size, + sector size, + + eublock, + first block no of cluster, + + reset disk attributes, + set disk attributes: + +LET dir entrys per block = 16, + first non dummy ds page = 2; + +LET DOSDISK = STRUCT (INT sectors per cluster, + number of reserved sectors, + number of fats, + number of dir sectors, + first fat byte, + number of fat sectors, + heads, + sectors per track, + tracks, + number of fat entrys, + REAL size); + +LET BLOCK = BOUND STRUCT (ALIGN dummy, ROW 64 REAL block row); + +INT CONST sector size :: 512; + +TEXT VAR bpb := 32 * " "; + +INITFLAG VAR bpb ds used := FALSE; + +DATASPACE VAR bpb ds; + +BLOCK VAR bpb block; + +DOSDISK VAR disk format; +BOUND DOSDISK VAR format table; + +INT VAR eu sectors, + xbegin of data area; + +INT PROC eublock (INT CONST nr): +(*COND FLOPPY*) + IF page format + THEN head * eu sectors per head + trac * eu sectors + sector + ELSE head * eu sectors + trac * abs (eu heads) * eu sectors + sector + FI. + +page format: + eu heads < 0. + +sector: + nr MOD disk format.sectors per track. + +trac: + (nr DIV disk format.sectors per track) DIV disk format.heads. + +head: + (nr DIV disk format.sectors per track) MOD disk format.heads. + +eu sectors per head: + eu sectors * eu tracks. + +(*ENDCOND*) +(*COND HDU + nr + +ENDCOND*) + +END PROC eublock; + +INT PROC first block no of cluster (INT CONST cluster no): + IF cluster no < 2 + THEN error stop ("interner Fehler") + FI; + begin of data area + (cluster no - 2) * sectors per cluster. + +END PROC first block no of cluster; + +INT PROC first fat byte: + disk format.first fat byte + +END PROC first fat byte; + +INT PROC number of fat copies: + disk format.number of fats + +END PROC number of fat copies; + +INT PROC number of fat sectors: + disk format.number of fat sectors + +END PROC number of fat sectors; + +INT PROC number of fat entrys: + disk format.number of fat entrys + +END PROC number of fat entrys; + +INT PROC number of dir sectors: + disk format.number of dir sectors + +END PROC number of dir sectors; + +INT PROC begin of fat (INT CONST no): + disk format.number of reserved sectors + no * disk format.number of fat sectors + +END PROC begin of fat; + +INT PROC begin of dir: + disk format.number of reserved sectors + + disk format.number of fats * disk format.number of fat sectors + +END PROC begin of dir; + +INT PROC begin of data area: + xbegin of data area + +END PROC begin of data area; + +INT PROC sectors per cluster: + disk format.sectors per cluster + +END PROC sectors per cluster; + +INT PROC cluster size: + disk format.sectors per cluster * 512 + +END PROC cluster size; + +PROC set disk attributes (INT CONST first fat byte): + enable stop; +(*COND FLOPPY*) + get bios parameter block; + IF is valid bpb + THEN load disk data from bpb + ELSE load disk disk data from ds + FI; + eu sectors := eu last sector - eu first sector +1; +(*ENDCOND*) + xbegin of data area := disk format.number of reserved sectors + + disk format.number of fats * disk format.number of fat sectors + + disk format.number of dir sectors; +(*COND FLOPPY*) + test compatibility + +.is valid bpb: + first fat byte < 252 OR code (bpb SUB 22) = first fat byte. + +load disk disk data from ds: + IF exists (text (first fat byte)) + THEN format table := old (text (first fat byte)); + copy values + ELSE error stop ("DOS-Diskettenformat nicht implementiert") + FI. + +copy values: + disk format.sectors per cluster := format table.sectors per cluster; + disk format.number of reserved sectors := format table.number of reserved sectors; + disk format.number of fats := format table.number of fats; + disk format.size := format table.size; + disk format.number of dir sectors := format table.number of dir sectors; + disk format.first fat byte := format table.first fat byte; + disk format.number of fat sectors := format table.number of fat sectors; + disk format.heads := format table.heads; + disk format.sectors per track := format table.sectors per track; + disk format.tracks := format table.tracks; + disk format.number of fat entrys := format table.number of fat entrys. + +test compatibility: + IF disk format.sectors per track > eu sectors + OR eu tracks <> disk format.tracks + OR abs (eu heads) < disk format.heads + OR disk format.number of reserved sectors <> 1 + THEN error stop ("DOS-Format auf diesem Diskettenlaufwerk nicht lesbar") + FI; +(*ENDCOND*) + +END PROC set disk attributes; + +PROC reset disk attributes: +(*COND FLOPPY*) + disk format.sectors per cluster := 1; + disk format.number of reserved sectors := 1; + disk format.number of fats := 1; + disk format.size := real (eu size); + disk format.number of dir sectors := 4; + disk format.first fat byte := 255; + disk format.number of fat sectors := 1; + disk format.heads := eu heads; + disk format.sectors per track := eu tracks; + disk format.tracks := eu sectors; + disk format.number of fat entrys := 100. + +(*ENDCOND*) +(*COND HDU + get bios parameter block; + load disk data from bpb (248). + +ENDCOND*) + +END PROC reset disk attributes; + +PROC get bios parameter block: + init bpb ds; + read bpb; + copy bpb block to bpb text. + +init bpb ds: + IF NOT initialized (bpb ds used) + THEN bpb ds := nilspace; + bpb block := bpb ds + FI. + +read bpb: + INT VAR error; + read block (bpb ds, first non dummy ds page, 0, error); + IF error <> 0 + THEN SELECT error OF + CASE 1: errorstop ("Floppylaufwerk nicht betriebsbereit") + CASE 2: errorstop ("Schreib-/Lesefehler") + CASE 3: errorstop ("Interner Fehler (Blocknummer zu hoch)") + OTHERWISE errorstop ("Schreib-/Lesefehler " + text (error)) + END SELECT + FI. + +copy bpb block to bpb text: + replace (bpb, 1, bpb block. block row [1]); + replace (bpb, 2, bpb block. block row [2]); + replace (bpb, 3, bpb block. block row [3]); + replace (bpb, 4, bpb block. block row [4]). + +END PROC get bios parameter block; + +PROC load disk data from bpb: + disable stop; + enable load disk data from bpb; + IF is error + THEN clear error; + enable stop; + error stop ("Bios-Parameterblock ungltig") + FI. + +END PROC load disk data from bpb; + +PROC enable load disk data from bpb: + disk format.sectors per cluster := code (bpb SUB 14); + disk format.number of reserved sectors := code (bpb SUB 16) * 256 + code (bpb SUB 15); + disk format.number of fats := code (bpb SUB 17); + disk format.number of dir sectors := dir entrys DIV dir entrys per block; + disk format.size := real (code (bpb SUB 21)) * 256.0 + real (code (bpb SUB 20)); + disk format.first fat byte := code (bpb SUB 22); + disk format.number of fat sectors := code (bpb SUB 24) * 256 + code (bpb SUB 23); + disk format.heads := dos heads; + disk format.sectors per track := code (bpb SUB 26) * 256 + code (bpb SUB 25); + disk format.tracks := + int(disk format.size / real(disk format.sectors per track * disk format.heads)); + disk format.number of fat entrys := fat entrys. + +dir entrys: + code (bpb SUB 19) * 256 + code (bpb SUB 18). + +dos heads: + code (bpb SUB 28) * 256 + code (bpb SUB 27). + +fat entrys: + data clusters + 2. + +data clusters: + int ((disk format.size - real (no of table sectors)) / real (sectors per cluster)). + +no of table sectors: + disk format.number of reserved sectors + disk format.number of fats * disk format.number of fat sectors + + disk format.number of dir sectors. + +END PROC enable load disk data from bpb; + +END PACKET dos disk; diff --git a/system/dos/1986/src/disk descriptor.dos.hd b/system/dos/1986/src/disk descriptor.dos.hd new file mode 100644 index 0000000..312b273 --- /dev/null +++ b/system/dos/1986/src/disk descriptor.dos.hd @@ -0,0 +1,290 @@ +PACKET dos disk DEFINES (* Copyright (C) 1985, 86 *) + (* Frank Klapper *) + first fat byte, (* 30.05.86 *) + begin of fat, + number of fat sectors, + number of fat entrys, + number of fat copies, + begin of dir, + number of dir sectors, + begin of data area, + sectors per cluster, + cluster size, + sector size, + + eublock, + first block no of cluster, + + reset disk attributes, + set disk attributes: + +LET dir entrys per block = 16, + first non dummy ds page = 2; + +LET DOSDISK = STRUCT (INT sectors per cluster, + number of reserved sectors, + number of fats, + number of dir sectors, + first fat byte, + number of fat sectors, + heads, + sectors per track, + tracks, + number of fat entrys, + REAL size); + +LET BLOCK = BOUND STRUCT (ALIGN dummy, ROW 64 REAL block row); + +INT CONST sector size :: 512; + +TEXT VAR bpb := 32 * " "; + +INITFLAG VAR bpb ds used := FALSE; + +DATASPACE VAR bpb ds; + +BLOCK VAR bpb block; + +DOSDISK VAR disk format; +BOUND DOSDISK VAR format table; + +INT VAR eu sectors, + xbegin of data area; + +INT PROC eublock (INT CONST nr): +(*COND FLOPPY + IF page format + THEN head * eu sectors per head + trac * eu sectors + sector + ELSE head * eu sectors + trac * abs (eu heads) * eu sectors + sector + FI. + +page format: + eu heads < 0. + +sector: + nr MOD disk format.sectors per track. + +trac: + (nr DIV disk format.sectors per track) DIV disk format.heads. + +head: + (nr DIV disk format.sectors per track) MOD disk format.heads. + +eu sectors per head: + eu sectors * eu tracks. + +ENDCOND*) +(*COND HDU*) + nr + +(*ENDCOND*) + +END PROC eublock; + +INT PROC first block no of cluster (INT CONST cluster no): + IF cluster no < 2 + THEN error stop ("interner Fehler") + FI; + begin of data area + (cluster no - 2) * sectors per cluster. + +END PROC first block no of cluster; + +INT PROC first fat byte: + disk format.first fat byte + +END PROC first fat byte; + +INT PROC number of fat copies: + disk format.number of fats + +END PROC number of fat copies; + +INT PROC number of fat sectors: + disk format.number of fat sectors + +END PROC number of fat sectors; + +INT PROC number of fat entrys: + disk format.number of fat entrys + +END PROC number of fat entrys; + +INT PROC number of dir sectors: + disk format.number of dir sectors + +END PROC number of dir sectors; + +INT PROC begin of fat (INT CONST no): + disk format.number of reserved sectors + no * disk format.number of fat sectors + +END PROC begin of fat; + +INT PROC begin of dir: + disk format.number of reserved sectors + + disk format.number of fats * disk format.number of fat sectors + +END PROC begin of dir; + +INT PROC begin of data area: + xbegin of data area + +END PROC begin of data area; + +INT PROC sectors per cluster: + disk format.sectors per cluster + +END PROC sectors per cluster; + +INT PROC cluster size: + disk format.sectors per cluster * 512 + +END PROC cluster size; + +PROC set disk attributes (INT CONST first fat byte): + enable stop; +(*COND FLOPPY + get bios parameter block; + IF is valid bpb + THEN load disk data from bpb + ELSE load disk disk data from ds + FI; + eu sectors := eu last sector - eu first sector +1; +ENDCOND*) + xbegin of data area := disk format.number of reserved sectors + + disk format.number of fats * disk format.number of fat sectors + + disk format.number of dir sectors; +(*COND FLOPPY + test compatibility + +.is valid bpb: + first fat byte < 252 OR code (bpb SUB 22) = first fat byte. + +load disk disk data from ds: + IF exists (text (first fat byte)) + THEN format table := old (text (first fat byte)); + copy values + ELSE error stop ("DOS-Diskettenformat nicht implementiert") + FI. + +copy values: + disk format.sectors per cluster := format table.sectors per cluster; + disk format.number of reserved sectors := format table.number of reserved sectors; + disk format.number of fats := format table.number of fats; + disk format.size := format table.size; + disk format.number of dir sectors := format table.number of dir sectors; + disk format.first fat byte := format table.first fat byte; + disk format.number of fat sectors := format table.number of fat sectors; + disk format.heads := format table.heads; + disk format.sectors per track := format table.sectors per track; + disk format.tracks := format table.tracks; + disk format.number of fat entrys := format table.number of fat entrys. + +test compatibility: + IF disk format.sectors per track > eu sectors + OR eu tracks <> disk format.tracks + OR abs (eu heads) < disk format.heads + OR disk format.number of reserved sectors <> 1 + THEN error stop ("DOS-Format auf diesem Diskettenlaufwerk nicht lesbar") + FI; +ENDCOND*) + +END PROC set disk attributes; + +PROC reset disk attributes: +(*COND FLOPPY + disk format.sectors per cluster := 1; + disk format.number of reserved sectors := 1; + disk format.number of fats := 1; + disk format.size := real (eu size); + disk format.number of dir sectors := 4; + disk format.first fat byte := 255; + disk format.number of fat sectors := 1; + disk format.heads := eu heads; + disk format.sectors per track := eu tracks; + disk format.tracks := eu sectors; + disk format.number of fat entrys := 100. + +ENDCOND*) +(*COND HDU*) + get bios parameter block; + load disk data from bpb. + +(*ENDCOND*) + +END PROC reset disk attributes; + +PROC get bios parameter block: + init bpb ds; + read bpb; + copy bpb block to bpb text. + +init bpb ds: + IF NOT initialized (bpb ds used) + THEN bpb ds := nilspace; + bpb block := bpb ds + FI. + +read bpb: + INT VAR error; + read block (bpb ds, first non dummy ds page, 0, error); + IF error <> 0 + THEN SELECT error OF + CASE 1: errorstop ("Floppylaufwerk nicht betriebsbereit") + CASE 2: errorstop ("Schreib-/Lesefehler") + CASE 3: errorstop ("Interner Fehler (Blocknummer zu hoch)") + OTHERWISE errorstop ("Schreib-/Lesefehler " + text (error)) + END SELECT + FI. + +copy bpb block to bpb text: + replace (bpb, 1, bpb block. block row [1]); + replace (bpb, 2, bpb block. block row [2]); + replace (bpb, 3, bpb block. block row [3]); + replace (bpb, 4, bpb block. block row [4]). + +END PROC get bios parameter block; + +PROC load disk data from bpb: + disable stop; + enable load disk data from bpb; + IF is error + THEN clear error; + enable stop; + error stop ("Bios-Parameterblock ungltig") + FI. + +END PROC load disk data from bpb; + +PROC enable load disk data from bpb: + disk format.sectors per cluster := code (bpb SUB 14); + disk format.number of reserved sectors := code (bpb SUB 16) * 256 + code (bpb SUB 15); + disk format.number of fats := code (bpb SUB 17); + disk format.number of dir sectors := dir entrys DIV dir entrys per block; + disk format.size := real (code (bpb SUB 21)) * 256.0 + real (code (bpb SUB 20)); + disk format.first fat byte := code (bpb SUB 22); + disk format.number of fat sectors := code (bpb SUB 24) * 256 + code (bpb SUB 23); + disk format.heads := dos heads; + disk format.sectors per track := code (bpb SUB 26) * 256 + code (bpb SUB 25); + disk format.tracks := + int(disk format.size / real(disk format.sectors per track * disk format.heads)); + disk format.number of fat entrys := fat entrys. + +dir entrys: + code (bpb SUB 19) * 256 + code (bpb SUB 18). + +dos heads: + code (bpb SUB 28) * 256 + code (bpb SUB 27). + +fat entrys: + data clusters + 2. + +data clusters: + int ((disk format.size - real (no of table sectors)) / real (sectors per cluster)). + +no of table sectors: + disk format.number of reserved sectors + disk format.number of fats * disk format.number of fat sectors + + disk format.number of dir sectors. + +END PROC enable load disk data from bpb; + +END PACKET dos disk; diff --git a/system/dos/1986/src/disk manager b/system/dos/1986/src/disk manager new file mode 100644 index 0000000..5711ee7 --- /dev/null +++ b/system/dos/1986/src/disk manager @@ -0,0 +1,245 @@ +PACKET disk manager DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + disk fetch, (* 07.05.86 *) + disk check, + disk save first phase, + disk save second phase, + disk clear, + disk format, + disk erase, + disk exists, + disk list, + disk all, + disk reserve, + disk free: + +LET ascii = 1, + ascii german = 2, + transparent = 3, + ebcdic = 4, + row text = 5, + ds = 6, + atari st = 10; + +TEXT VAR file name; + +INT VAR mode := 0; +TEXT VAR mode extension; + +REAL VAR last access time := 0.0; + +PROC disk fetch (TEXT CONST name, DATASPACE VAR file ds): + enable stop; + access disk; + file name := adapted name (name, TRUE); + IF dir contains (file name) + THEN do fetch + ELSE errorstop ("die Datei """ + file name + """ gibt es nicht") + FI; + last access time := clock (1). + +do fetch: + SELECT mode OF + CASE ascii, ascii german, atari st, ebcdic, transparent: fetch filemode (file ds, filename, mode) + CASE row text : fetch row textmode (file ds, filename) + CASE ds : fetch dsmode (file ds, filename) + OTHERWISE error stop ("Unzulssige Betriebsart") + END SELECT. + +END PROC disk fetch; + +PROC disk check (TEXT CONST name): + enable stop; + access disk; + file name := adapted name (name, TRUE); + IF dir contains (file name) + THEN disable stop; + check file (file name); + IF is error + THEN clear error; + error stop ("Fehler beim Prflesen der Datei """ + file name + """") + FI; + ELSE error stop ("""" + file name + """ gibt es nicht") + FI; + last access time := clock (1). + +END PROC disk check; + +PROC disk save first phase (TEXT CONST name, BOOL VAR overwrite question): + enable stop; + overwrite question := FALSE; + access disk; + file name := adapted name (name, FALSE); + IF dir contains (file name) + THEN overwrite question := TRUE + FI; + last access time := clock (1). + +END PROC disk save first phase; + +PROC disk save second phase (DATASPACE CONST file ds): + enable stop; + access disk; + erase file if necessary; + do save; + last access time := clock (1). + +erase file if necessary: + IF dir contains (file name) + THEN erase table entrys (file name) + FI. + +do save: + SELECT mode OF + CASE ascii, ascii german,atari st, ebcdic, transparent: save filemode (file ds, filename, mode) + CASE row text : save row textmode (file ds, filename) + CASE ds : save dsmode (file ds, filename) + OTHERWISE error stop ("Unzulssige Betriebsart") + END SELECT. + +END PROC disk save second phase; + +(* DOS bekommt die Tabellenparameter von der Diskette + CPM bekommt die Tabellenparameter ber 'reserve' *) + +PROC disk clear: + enable stop; +(*COND DOS*) + access disk; +(*ENDCOND*) +(*COND CPM + open eu disk; + open action; +ENDCOND*) + format disk; + last access time := clock (1). + +END PROC disk clear; + +PROC disk erase (TEXT CONST name): + enable stop; + access disk; + file name := adapted name (name, TRUE); + IF NOT dir contains (file name) + THEN errorstop ("die Datei """ + file name + """ gibt es nicht") + ELSE erase table entrys (file name); + FI; + last access time := clock (1). + +END PROC disk erase; + +BOOL PROC disk exists (TEXT CONST name): + enable stop; + access disk; + last access time := clock (1); + dir contains (adapted name (name, TRUE)). + +END PROC disk exists; + +PROC disk list (DATASPACE VAR list ds): + enable stop; + access disk; + dir list (list ds); + last access time := clock (1). + +END PROC disk list; + +THESAURUS PROC disk all: + enable stop; + access disk; + last access time := clock (1); + dir all. + +END PROC disk all; + +PROC disk format: + +(*COND DOS*) + error stop ("nicht implementiert") +(*ENDCOND*) + +(*COND CPM + enable stop; + open eu disk; + open action; + format archive (eu disk format no); + format disk; + last access time := clock (1). +ENDCOND*) + +END PROC disk format; + +PROC disk reserve (TEXT CONST reserve string): + enable stop; + close action; + last access time := clock (1); + get mode. + +get mode: + TEXT VAR mode text; + IF pos (reserve string, ":") = 0 + THEN mode text := reserve string; + mode extension := "" + ELSE mode text := subtext (reserve string, 1, pos (reserve string, ":") - 1); + mode extension := subtext (reserve string, pos (reserve string, ":") + 1) + FI; + prepare modetext; + IF mode text = "FILEASCII" + THEN mode := ascii + ELIF mode text = "FILEASCIIGERMAN" + THEN mode := asciigerman + ELIF mode text = "FILEATARIST" + THEN mode := atari st + ELIF modetext = "FILEEBCDIC" + THEN mode := ebcdic + ELIF modetext = "FILETRANSPARENT" + THEN mode := transparent + ELIF mode text = "ROWTEXT" + THEN mode := row text + ELIF mode text = "DS" + THEN mode := ds + ELSE error stop ("Unzulssige Betriebsart") + FI. + +prepare modetext: + change all (mode text, " ", ""); + INT VAR i; + FOR i FROM 1 UPTO LENGTH mode text REP + IF is lower case + THEN replace (mode text, i, upper case char) + FI + PER. + +is lower case: + code (mode text SUB i) > 96 AND code (mode text SUB i) < 123. + +upper case char: + code (code (mode text SUB i) - 32). + +END PROC disk reserve; + +PROC disk free: + disable stop; + close action; + close disk; + reduce cluster buffer. + +END PROC disk free; + +PROC access disk: + IF action closed COR (last access more than two seconds ago CAND disk changed) + THEN open disk archive + FI. + +open disk archive: + close action; + open eu disk; + open disk (mode extension); + open action. + +last access more than two seconds ago: + abs (clock (1) - last access time) > 2.0. + +END PROC access disk; + +END PACKET disk manager; diff --git a/system/dos/1986/src/eu disk descriptor.fd b/system/dos/1986/src/eu disk descriptor.fd new file mode 100644 index 0000000..c09c820 --- /dev/null +++ b/system/dos/1986/src/eu disk descriptor.fd @@ -0,0 +1,102 @@ +PACKET eu disk DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + (* 25.03.86 *) + load shard interface table, + open eu disk, + eu size, + eu heads, + eu tracks, + eu first sector, + eu last sector: + +LET table length = 15, + + size field = 1, + head field = 2, + track field = 3, + first sector field = 4, + last sector field = 5; + +ROW table length ROW 5 INT VAR format table; + +INT VAR table top, + table pointer; + +PROC open eu disk: + enable stop; + init check rerun; +(*COND FLOPPY*) + INT VAR blocks := archive blocks; + search format table entry; +(*ENDCOND*) +. + +(*COND FLOPPY*) +search format table entry: + table pointer := 1; + WHILE format table [table pointer][size field] <> blocks REP + table pointer INCR 1; + IF table pointer > table top + THEN error stop ("Diskettenformat nicht implementiert") + FI + PER. +(*ENDCOND*) + +END PROC open eu disk; + +PROC load shard interface table: + FILE VAR f := sequential file (input, "shard interface"); + TEXT VAR line; + table top := 0; + WHILE NOT eof (f) REP + get line (f, line); + IF (line SUB 1) <> ";" + THEN load line + FI + PER. + +load line: + table top INCR 1; + IF table top > table length + THEN error stop ("Shard Interface Tabelle zu gro") + FI; + INT VAR blank pos := 1; + format table [table top][size field] := next int; + format table [table top][head field] := next int; + format table [table top][track field] := next int; + format table [table top][first sector field] := next int; + format table [table top][last sector field] := next int. + +next int: + line := compress (subtext (line, blank pos)) + " "; + blank pos := pos (line, " "); + int (subtext (line, 1, blank pos - 1)). + +END PROC load shard interface table; + +INT PROC eu size: + format table [table pointer][size field] + +END PROC eu size; + +INT PROC eu heads: + format table [table pointer][head field] + +END PROC eu heads; + +INT PROC eu tracks: + format table [table pointer][track field] + +END PROC eu tracks; + +INT PROC eu first sector: + format table [table pointer][first sector field] + +END PROC eu first sector; + +INT PROC eu last sector: + format table [table pointer][last sector field] + +END PROC eu last sector; + +END PACKET eu disk; diff --git a/system/dos/1986/src/eu disk descriptor.hd b/system/dos/1986/src/eu disk descriptor.hd new file mode 100644 index 0000000..73179db --- /dev/null +++ b/system/dos/1986/src/eu disk descriptor.hd @@ -0,0 +1,102 @@ +PACKET eu disk DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + (* 25.03.86 *) + load shard interface table, + open eu disk, + eu size, + eu heads, + eu tracks, + eu first sector, + eu last sector: + +LET table length = 15, + + size field = 1, + head field = 2, + track field = 3, + first sector field = 4, + last sector field = 5; + +ROW table length ROW 5 INT VAR format table; + +INT VAR table top, + table pointer; + +PROC open eu disk: + enable stop; + init check rerun; +(*COND FLOPPY + INT VAR blocks := archive blocks; + search format table entry; +ENDCOND*) +. + +(*COND FLOPPY +search format table entry: + table pointer := 1; + WHILE format table [table pointer][size field] <> blocks REP + table pointer INCR 1; + IF table pointer > table top + THEN error stop ("Diskettenformat nicht implementiert") + FI + PER. +ENDCOND*) + +END PROC open eu disk; + +PROC load shard interface table: + FILE VAR f := sequential file (input, "shard interface"); + TEXT VAR line; + table top := 0; + WHILE NOT eof (f) REP + get line (f, line); + IF (line SUB 1) <> ";" + THEN load line + FI + PER. + +load line: + table top INCR 1; + IF table top > table length + THEN error stop ("Shard Interface Tabelle zu gro") + FI; + INT VAR blank pos := 1; + format table [table top][size field] := next int; + format table [table top][head field] := next int; + format table [table top][track field] := next int; + format table [table top][first sector field] := next int; + format table [table top][last sector field] := next int. + +next int: + line := compress (subtext (line, blank pos)) + " "; + blank pos := pos (line, " "); + int (subtext (line, 1, blank pos - 1)). + +END PROC load shard interface table; + +INT PROC eu size: + format table [table pointer][size field] + +END PROC eu size; + +INT PROC eu heads: + format table [table pointer][head field] + +END PROC eu heads; + +INT PROC eu tracks: + format table [table pointer][track field] + +END PROC eu tracks; + +INT PROC eu first sector: + format table [table pointer][first sector field] + +END PROC eu first sector; + +INT PROC eu last sector: + format table [table pointer][last sector field] + +END PROC eu last sector; + +END PACKET eu disk; diff --git a/system/dos/1986/src/eumel-ebcdic + sub b/system/dos/1986/src/eumel-ebcdic + sub new file mode 100644 index 0000000..5a571cb --- /dev/null +++ b/system/dos/1986/src/eumel-ebcdic + sub @@ -0,0 +1,550 @@ +PACKET eumel ebcdic DEFINES (* Copyright (c) 1986 *) + (* Frank Klapper *) + (* 19.02.86 *) + ebcdic to eumel with substitution, + eumel to ebcdic with substitution: + +TEXT VAR bild; + +PROC eumel to ebcdic with substitution (TEXT VAR string): + bild := ""; + INT VAR pos; + FOR pos FROM 1 UPTO LENGTH string REP + bild CAT conversion + PER; + string := bild. + +conversion: + SELECT code (string SUB pos) OF + CASE 0: "{"240""240""240"{" + CASE 1: "{"240""240""241"{" + CASE 2: "{"240""240""242"{" + CASE 3: "{"240""240""243"{" + CASE 4: "{"240""240""244"{" + CASE 5: "{"240""240""245"{" + CASE 6: "{"240""240""246"{" + CASE 7: "{"240""240""247"{" + CASE 8: "{"240""240""248"{" + CASE 9: "{"240""240""249"{" + CASE 10: "%" + CASE 11: "{"240""241""241"{" + CASE 12: ""12"" + CASE 13: ""13"" + CASE 14: "{"240""241""244"{" + CASE 15: "{"240""241""245"{" + CASE 16: "{"240""241""246"{" + CASE 17: "{"240""241""247"{" + CASE 18: "{"240""241""248"{" + CASE 19: "{"240""241""249"{" + CASE 20: "{"240""242""240"{" + CASE 21: "{"240""242""241"{" + CASE 22: "{"240""242""242"{" + CASE 23: "{"240""242""243"{" + CASE 24: "{"240""242""244"{" + CASE 25: "{"240""242""245"{" + CASE 26: "{"240""242""246"{" + CASE 27: "{"240""242""247"{" + CASE 28: "{"240""242""248"{" + CASE 29: "{"240""242""249"{" + CASE 30: "{"240""243""240"{" + CASE 31: "{"240""243""241"{" + CASE 32: "@" + CASE 33: "O" + CASE 34: "" + CASE 35: "{" + CASE 36: "{"240""243""246"{" + CASE 37: "l" + CASE 38: "P" + CASE 39: "}" + CASE 40: "M" + CASE 41: "]" + CASE 42: "\" + CASE 43: "N" + CASE 44: "k" + CASE 45: "`" + CASE 46: "K" + CASE 47: "a" + CASE 48: ""240"" + CASE 49: ""241"" + CASE 50: ""242"" + CASE 51: ""243"" + CASE 52: ""244"" + CASE 53: ""245"" + CASE 54: ""246"" + CASE 55: ""247"" + CASE 56: ""248"" + CASE 57: ""249"" + CASE 58: "z" + CASE 59: "^" + CASE 60: "L" + CASE 61: "~" + CASE 62: "n" + CASE 63: "o" + CASE 64: "|" + CASE 65: "" + CASE 66: "" + CASE 67: "" + CASE 68: "" + CASE 69: "" + CASE 70: "" + CASE 71: "" + CASE 72: "" + CASE 73: "" + CASE 74: "" + CASE 75: "" + CASE 76: "" + CASE 77: "" + CASE 78: "" + CASE 79: "" + CASE 80: "" + CASE 81: "" + CASE 82: "" + CASE 83: ""226"" + CASE 84: ""227"" + CASE 85: ""228"" + CASE 86: ""229"" + CASE 87: ""230"" + CASE 88: ""231"" + CASE 89: ""232"" + CASE 90: ""233"" + CASE 91: "J" + CASE 92: ""224"" + CASE 93: "Z" + CASE 94: "{"240""249""244"{" + CASE 95: "m" + CASE 96: "y" + CASE 97: "" + CASE 98: "" + CASE 99: "" + CASE 100: "" + CASE 101: "" + CASE 102: "" + CASE 103: "" + CASE 104: "" + CASE 105: "" + CASE 106: "" + CASE 107: "" + CASE 108: "" + CASE 109: "" + CASE 110: "" + CASE 111: "" + CASE 112: "" + CASE 113: "" + CASE 114: "" + CASE 115: "" + CASE 116: "" + CASE 117: "" + CASE 118: "" + CASE 119: "" + CASE 120: "" + CASE 121: "" + CASE 122: "" + CASE 123: "" + CASE 124: "{"241""242""244"{" + CASE 125: "" + CASE 126: "" + CASE 127: "{"241""242""247"{" + CASE 128: "{"241""242""248"{" + CASE 129: "{"241""242""249"{" + CASE 130: "{"241""243""240"{" + CASE 131: "{"241""243""241"{" + CASE 132: "{"241""243""242"{" + CASE 133: "{"241""243""243"{" + CASE 134: "{"241""243""244"{" + CASE 135: "{"241""243""245"{" + CASE 136: "{"241""243""246"{" + CASE 137: "{"241""243""247"{" + CASE 138: "{"241""243""248"{" + CASE 139: "{"241""243""249"{" + CASE 140: "{"241""244""240"{" + CASE 141: "{"241""244""241"{" + CASE 142: "{"241""244""242"{" + CASE 143: "{"241""244""243"{" + CASE 144: "{"241""244""244"{" + CASE 145: "{"241""244""245"{" + CASE 146: "{"241""244""246"{" + CASE 147: "{"241""244""247"{" + CASE 148: "{"241""244""248"{" + CASE 149: "{"241""244""249"{" + CASE 150: "{"241""245""240"{" + CASE 151: "{"241""245""241"{" + CASE 152: "{"241""245""242"{" + CASE 153: "{"241""245""243"{" + CASE 154: "{"241""245""244"{" + CASE 155: "{"241""245""245"{" + CASE 156: "{"241""245""246"{" + CASE 157: "{"241""245""247"{" + CASE 158: "{"241""245""248"{" + CASE 159: "{"241""245""249"{" + CASE 160: "{"241""246""240"{" + CASE 161: "{"241""246""241"{" + CASE 162: "{"241""246""242"{" + CASE 163: "{"241""246""243"{" + CASE 164: "{"241""246""244"{" + CASE 165: "{"241""246""245"{" + CASE 166: "{"241""246""246"{" + CASE 167: "{"241""246""247"{" + CASE 168: "{"241""246""248"{" + CASE 169: "{"241""246""249"{" + CASE 170: "{"241""247""240"{" + CASE 171: "{"241""247""241"{" + CASE 172: "{"241""247""242"{" + CASE 173: "{"241""247""243"{" + CASE 174: "{"241""247""244"{" + CASE 175: "{"241""247""245"{" + CASE 176: "{"241""247""246"{" + CASE 177: "{"241""247""247"{" + CASE 178: "{"241""247""248"{" + CASE 179: "{"241""247""249"{" + CASE 180: "{"241""248""240"{" + CASE 181: "{"241""248""241"{" + CASE 182: "{"241""248""242"{" + CASE 183: "{"241""248""243"{" + CASE 184: "{"241""248""244"{" + CASE 185: "{"241""248""245"{" + CASE 186: "{"241""248""246"{" + CASE 187: "{"241""248""247"{" + CASE 188: "{"241""248""248"{" + CASE 189: "{"241""248""249"{" + CASE 190: "{"241""249""240"{" + CASE 191: "{"241""249""241"{" + CASE 192: "{"241""249""242"{" + CASE 193: "{"241""249""243"{" + CASE 194: "{"241""249""244"{" + CASE 195: "{"241""249""245"{" + CASE 196: "{"241""249""246"{" + CASE 197: "{"241""249""247"{" + CASE 198: "{"241""249""248"{" + CASE 199: "{"241""249""249"{" + CASE 200: "{"242""240""240"{" + CASE 201: "{"242""240""241"{" + CASE 202: "{"242""240""242"{" + CASE 203: "{"242""240""243"{" + CASE 204: "{"242""240""244"{" + CASE 205: "{"242""240""245"{" + CASE 206: "{"242""240""246"{" + CASE 207: "{"242""240""247"{" + CASE 208: "{"242""240""248"{" + CASE 209: "{"242""240""249"{" + CASE 210: "{"242""241""240"{" + CASE 211: "{"242""241""241"{" + CASE 212: "{"242""241""242"{" + CASE 213: "{"242""241""243"{" + CASE 214: "{"242""241""244"{" + CASE 215: "{"242""241""245"{" + CASE 216: "{"242""241""246"{" + CASE 217: "{"242""241""247"{" + CASE 218: "{"242""241""248"{" + CASE 219: "{"242""241""249"{" + CASE 220: "" + CASE 221: "`" + CASE 222: "{" + CASE 223: "@" + CASE 224: "{"242""242""244"{" + CASE 225: "{"242""242""245"{" + CASE 226: "{"242""242""246"{" + CASE 227: "{"242""242""247"{" + CASE 228: "{"242""242""248"{" + CASE 229: "{"242""242""249"{" + CASE 230: "{"242""243""240"{" + CASE 231: "{"242""243""241"{" + CASE 232: "{"242""243""242"{" + CASE 233: "{"242""243""243"{" + CASE 234: "{"242""243""244"{" + CASE 235: "{"242""243""245"{" + CASE 236: "{"242""243""246"{" + CASE 237: "{"242""243""247"{" + CASE 238: "{"242""243""248"{" + CASE 239: "{"242""243""249"{" + CASE 240: "{"242""244""240"{" + CASE 241: "{"242""244""241"{" + CASE 242: "{"242""244""242"{" + CASE 243: "{"242""244""243"{" + CASE 244: "{"242""244""244"{" + CASE 245: "{"242""244""245"{" + CASE 246: "{"242""244""246"{" + CASE 247: "{"242""244""247"{" + CASE 248: "{"242""244""248"{" + CASE 249: "{"242""244""249"{" + CASE 250: "{"242""245""240"{" + CASE 251: "{"242""245""241"{" + CASE 252: "{"242""245""242"{" + CASE 253: "{"242""245""243"{" + CASE 254: "{"242""245""244"{" + CASE 255: "{"242""245""245"{" + OTHERWISE "" + END SELECT. + +END PROC eumel to ebcdic with substitution; + +PROC ebcdic to eumel with substitution (TEXT VAR string): + bild := ""; + INT VAR pos; + FOR pos FROM 1 UPTO LENGTH string REP + bild CAT conversion + PER; + string := bild. + +conversion: + SELECT code (string SUB pos) OF + CASE 0: "#000#" + CASE 1: "#001#" + CASE 2: "#002#" + CASE 3: "#003#" + CASE 4: "#004#" + CASE 5: "#005#" + CASE 6: "#006#" + CASE 7: "#007#" + CASE 8: "#008#" + CASE 9: "#009#" + CASE 10: "#010#" + CASE 11: "#011#" + CASE 12: "#012#" + CASE 13: "#013#" + CASE 14: "#014#" + CASE 15: "#015#" + CASE 16: "#016#" + CASE 17: "#017#" + CASE 18: "#018#" + CASE 19: "#019#" + CASE 20: "#020#" + CASE 21: "#021#" + CASE 22: "#022#" + CASE 23: "#023#" + CASE 24: "#024#" + CASE 25: "#025#" + CASE 26: "#026#" + CASE 27: "#027#" + CASE 28: "#028#" + CASE 29: "#029#" + CASE 30: "#030#" + CASE 31: "#031#" + CASE 32: "#032#" + CASE 33: "#033#" + CASE 34: "#034#" + CASE 35: "#035#" + CASE 36: "#036#" + CASE 37: "#037#" + CASE 38: "#038#" + CASE 39: "#039#" + CASE 40: "#040#" + CASE 41: "#041#" + CASE 42: "#042#" + CASE 43: "#043#" + CASE 44: "#044#" + CASE 45: "#045#" + CASE 46: "#046#" + CASE 47: "#047#" + CASE 48: "#048#" + CASE 49: "#049#" + CASE 50: "#050#" + CASE 51: "#051#" + CASE 52: "#052#" + CASE 53: "#053#" + CASE 54: "#054#" + CASE 55: "#055#" + CASE 56: "#056#" + CASE 57: "#057#" + CASE 58: "#058#" + CASE 59: "#059#" + CASE 60: "#060#" + CASE 61: "#061#" + CASE 62: "#062#" + CASE 63: "#063#" + CASE 64: "#064#" + CASE 65: "#065#" + CASE 66: "#066#" + CASE 67: "#067#" + CASE 68: "#068#" + CASE 69: "#069#" + CASE 70: "#070#" + CASE 71: "#071#" + CASE 72: "#072#" + CASE 73: "#073#" + CASE 74: "[" + CASE 75: "." + CASE 76: "<" + CASE 77: "(" + CASE 78: "+" + CASE 79: "!" + CASE 80: "&" + CASE 81: "#081#" + CASE 82: "#082#" + CASE 83: "#083#" + CASE 84: "#084#" + CASE 85: "#085#" + CASE 86: "#086#" + CASE 87: "#087#" + CASE 88: "#088#" + CASE 89: "#089#" + CASE 90: "]" + CASE 91: "$" + CASE 92: "*" + CASE 93: ")" + CASE 94: ";" + CASE 95: "^" + CASE 96: "-" + CASE 97: "/" + CASE 98: "#098#" + CASE 99: "#099#" + CASE 100: "#100#" + CASE 101: "#101#" + CASE 102: "#102#" + CASE 103: "#103#" + CASE 104: "#104#" + CASE 105: "#105#" + CASE 106: "|" + CASE 107: "," + CASE 108: "%" + CASE 109: "_" + CASE 110: ">" + CASE 111: "?" + CASE 112: "#112#" + CASE 113: "#113#" + CASE 114: "#114#" + CASE 115: "#115#" + CASE 116: "#116#" + CASE 117: "#117#" + CASE 118: "#118#" + CASE 119: "#119#" + CASE 120: "#120#" + CASE 121: "`" + CASE 122: ":" + CASE 123: "#" + CASE 124: "@" + CASE 125: "'" + CASE 126: "=" + CASE 127: """" + CASE 128: "#128#" + CASE 129: "a" + CASE 130: "b" + CASE 131: "c" + CASE 132: "d" + CASE 133: "e" + CASE 134: "f" + CASE 135: "g" + CASE 136: "h" + CASE 137: "i" + CASE 138: "#138#" + CASE 139: "#139#" + CASE 140: "#140#" + CASE 141: "#141#" + CASE 142: "#142#" + CASE 143: "#143#" + CASE 144: "#144#" + CASE 145: "j" + CASE 146: "k" + CASE 147: "l" + CASE 148: "m" + CASE 149: "n" + CASE 150: "o" + CASE 151: "p" + CASE 152: "q" + CASE 153: "r" + CASE 154: "#154#" + CASE 155: "#155#" + CASE 156: "#156#" + CASE 157: "#157#" + CASE 158: "#158#" + CASE 159: "#159#" + CASE 160: "#160#" + CASE 161: "~" + CASE 162: "s" + CASE 163: "t" + CASE 164: "u" + CASE 165: "v" + CASE 166: "w" + CASE 167: "x" + CASE 168: "y" + CASE 169: "z" + CASE 170: "#170#" + CASE 171: "#171#" + CASE 172: "#172#" + CASE 173: "#173#" + CASE 174: "#174#" + CASE 175: "#175#" + CASE 176: "#176#" + CASE 177: "#177#" + CASE 178: "#178#" + CASE 179: "#179#" + CASE 180: "#180#" + CASE 181: "#181#" + CASE 182: "#182#" + CASE 183: "#183#" + CASE 184: "#184#" + CASE 185: "#185#" + CASE 186: "#186#" + CASE 187: "#187#" + CASE 188: "#188#" + CASE 189: "#189#" + CASE 190: "#190#" + CASE 191: "#191#" + CASE 192: "{" + CASE 193: "A" + CASE 194: "B" + CASE 195: "C" + CASE 196: "D" + CASE 197: "E" + CASE 198: "F" + CASE 199: "G" + CASE 200: "H" + CASE 201: "I" + CASE 202: "#202#" + CASE 203: "#203#" + CASE 204: "#204#" + CASE 205: "#205#" + CASE 206: "#206#" + CASE 207: "#207#" + CASE 208: "}" + CASE 209: "J" + CASE 210: "K" + CASE 211: "L" + CASE 212: "M" + CASE 213: "N" + CASE 214: "O" + CASE 215: "P" + CASE 216: "Q" + CASE 217: "R" + CASE 218: "#218#" + CASE 219: "#219#" + CASE 220: "#220#" + CASE 221: "#221#" + CASE 222: "#222#" + CASE 223: "#223#" + CASE 224: "\" + CASE 225: "#225#" + CASE 226: "S" + CASE 227: "T" + CASE 228: "U" + CASE 229: "V" + CASE 230: "W" + CASE 231: "X" + CASE 232: "Y" + CASE 233: "Z" + CASE 234: "#234#" + CASE 235: "#235#" + CASE 236: "#236#" + CASE 237: "#237#" + CASE 238: "#238#" + CASE 239: "#239#" + CASE 240: "0" + CASE 241: "1" + CASE 242: "2" + CASE 243: "3" + CASE 244: "4" + CASE 245: "5" + CASE 246: "6" + CASE 247: "7" + CASE 248: "8" + CASE 249: "9" + CASE 250: "#250#" + CASE 251: "#251#" + CASE 252: "#252#" + CASE 253: "#253#" + CASE 254: "#254#" + CASE 255: "#255#" + OTHERWISE "" + END SELECT. +END PROC ebcdic to eumel with substitution; + +END PACKET eumel ebcdic; diff --git a/system/dos/1986/src/fat and dir.dos.fd b/system/dos/1986/src/fat and dir.dos.fd new file mode 100644 index 0000000..5a82655 --- /dev/null +++ b/system/dos/1986/src/fat and dir.dos.fd @@ -0,0 +1,1190 @@ +PACKET dos fat and dir DEFINES (* Copyright (C) 1985, 86 *) + (* Frank Klapper *) + open disk, (* 30.05.86 *) + close disk, + format disk, + disk changed, + open fetch, + next fetch cluster no, + open save, + next save cluster no, + close save, + erase table entrys, +(*COND TEST + dump fat, +ENDCOND*) + dir all, + dir list, + dir contains: + +LET fat row size = 16384, (* 32 KB *) + max fat blocks = 25, + first fat entry no = 2, + last entry of fat chain = 4088, + dir entrys per block = 16, + max dir entrys = 1600, (* 100 KB *) + archive byte = " "; + +LET FAT = BOUND STRUCT (ALIGN dummy, + ROW 256 INT block row, + ROW fat row size INT fat row); + +LET LOCATION = STRUCT (INT msdos block no, + block entry no), + + FILEENTRY = STRUCT (TEXT date and time, + REAL size, + INT first cluster, + LOCATION location), + + DIRENTRY = INT, + + FILELIST = STRUCT (THESAURUS thes, + ROW max dir entrys FILEENTRY entry, + INT no of entrys), + + DIRLIST = STRUCT (THESAURUS thes, + ROW max dir entrys DIRENTRY entry, + INT no of entrys), + + FREELIST = STRUCT (ROW max dir entrys LOCATION stack, + INT stacktop, + LOCATION begin of free area, + end of dir, + INT dir chain root), + + DIR = BOUND STRUCT (FILELIST filelist, + DIRLIST dirlist, + FREELIST freelist, + TEXT disklabel, + path); + +INITFLAG VAR this packet := FALSE; + +DATASPACE VAR fat space, + dir ds, + block ds; + +BOOL VAR dataspaces open; + +FAT VAR fat struct; +ROW max fat blocks BOOL VAR write access; +INT VAR first possible available fat entry; + +DIR VAR dir; + +CLUSTER VAR block; + +INT VAR akt file cluster no, + first file cluster no; +BOOL VAR no cluster saved; +TEXT VAR save name; + +INT VAR count; + +TEXT VAR convert buffer := " ", + name, + dir entry; + +.fat: + fat struct.fat row. + +PROC open disk (TEXT CONST subdir path): + disable stop; + enable open disk (subdir path); + IF is error + THEN close action + FI + +END PROC open disk; + +PROC enable open disk (TEXT CONST subdir path): + enable stop; + init dataspaces; + open fat; + open dir. + +open fat: + reset disk attributes; + read first fat block; + set disk attributes (fat byte (0)); + read other fat blocks; + define write access table (FALSE); + first possible available fat entry := first fat entry no. + +read first fat block: + read fat block (0, FALSE). + +read other fat blocks: + INT VAR block no; + FOR block no FROM 1 UPTO number of fat sectors - 1 REP + read fat block (block no, FALSE) + PER. + +open dir: + init dir struct (subdir path, -1); + load main dir blocks; + load subdirs if necessary. + +load main dir blocks: + BOOL VAR last block; + store end of dir (loc (end of main dir, dir entrys per block - 1)); + FOR block no FROM begin of dir UPTO end of main dir REP + load dir block (block no, last block); + UNTIL last block + PER. + +end of main dir: + begin of dir + number of dir sectors - 1. + +load subdirs if necessary: + TEXT VAR path := subdir path; + WHILE path <> "" REP + load next subdir if possible + PER. + +load next subdir if possible: + INT VAR cluster no; + get next subdir name; + get first cluster no of subdir table; + clear dir entrys (cluster no); + WHILE cluster no >= 0 REP + load subdir entrys of cluster; + cluster no := next fetch cluster no + UNTIL last block + PER. + +get next subdir name: + TEXT VAR subdir name; + IF (path SUB 1) <> "\" + THEN error stop ("ungltige Pfadbezeichnung") + FI; + INT VAR backslash pos := pos (path, "\", "\", 2); + IF backslash pos = 0 + THEN subdir name := subtext (path, 2); + path := "" + ELSE subdir name := subtext (path, 2, backslash pos - 1); + path := subtext (path, backslash pos) + FI; + subdir name := adapted name (subdir name, TRUE). + +get first cluster no of subdir table: + IF dir thes CONTAINS subdir name + THEN open fetch subdir (subdir name, cluster no); + ELSE error stop ("Subdirectory existiert nicht") + FI. + +load subdir entrys of cluster: + store end of dir (loc (last block no of cluster, dir entrys per block - 1)); + FOR block no FROM 0 UPTO (sectors per cluster - 1) REP + load dir block (first block no of cluster (cluster no) + block no, last block) + UNTIL last block + PER. + +last block no of cluster: + first block no of cluster (cluster no) + sectors per cluster - 1. + +END PROC enable open disk; + +PROC init dataspaces: + enable stop; + IF NOT initialized (this packet) + THEN dataspaces open := FALSE + FI; + IF NOT dataspaces open + THEN disable stop; + dataspaces open := TRUE; + fat space := nilspace; + dir ds := nilspace; + block ds := nilspace; + fat struct := fat space; + dir := dir ds; + block := block ds + FI. + +END PROC init dataspaces; + +PROC init dir struct (TEXT CONST path string, INT CONST root): + clear dir entrys (root); + dir.path := path string; + dir.disk label := "". + +END PROC init dir struct; + +PROC clear dir entrys (INT CONST root): + init file list; + init dir list; + init free list (root). + +init file list: + dir.file list.thes := empty thesaurus; + dir.file list.no of entrys := 0. + +init dir list: + dir.dir list.thes := empty thesaurus; + dir.dir list.no of entrys := 0. + +END PROC clear dir entrys; + +PROC close disk: + enable stop; + IF NOT initialized (this packet) + THEN dataspaces open := FALSE + FI; + IF dataspaces open + THEN forget (dir ds); + forget (block ds); + forget (fat space); + dataspaces open := FALSE + FI. + +END PROC close disk; + +(*COND FLOPPY*) +PROC format disk: + enable stop; + init dataspaces; + format fat; + format dir. + +format fat: + write first four fat bytes; + write other fat bytes; + define write access table (TRUE); + copy fat to disk. + +write first four fat bytes: + fat [1] := word (first fat byte, 255); + fat [2] := word (255, 0). + +write other fat bytes: + FOR count FROM 3 UPTO fat length REP + fat [count] := 0 + PER. + +fat length: + INT VAR len := number of fat entrys + number of fat entrys DIV 2 + + number of fat entrys MOD 2; + len DIV 2 + len MOD 2. + +format dir: + init dir struct ("", -1); + store begin of free area (loc (begin of dir, 0)); + store end of dir (loc (end of dir, dir entrys per block - 1)); + FOR count FROM 0 UPTO dir entrys per block - 1 REP + write text 32 (block, ""0"" + 31 * ""246"", count) + PER; + disable stop; + FOR count FROM begin of dir UPTO end of dir REP + write disk block (block ds, count); + PER. + +end of dir: + begin of dir + number of dir sectors - 1. + +END PROC format disk; +(*ENDCOND*) + +(*COND HDU +PROC disk clear: + error stop ("nicht implementiert") + +END PROC disk clear; + +PROC format disk: + error stop ("nicht implementiert") + +END PROC format disk; +ENDCOND*) + +INT PROC word (INT CONST low byte, high byte): + convert buffer := code (low byte) + code (high byte); + convert buffer ISUB 1. + +END PROC word; + +BOOL PROC disk changed: +(*COND FLOPPY*) + disable stop; + NOT first fat block ok COR is error (* must be COR *) +(*ENDCOND*) +(*COND HDU + FALSE +ENDCOND*) + +END PROC disk changed; + +BOOL PROC first fat block ok: + enable stop; + read fat block (0, TRUE); + FOR count FROM 1 UPTO 256 REP + compare word + PER; + TRUE. + +compare word: + IF fat struct.fat row [count] <> fat struct.block row [count] + THEN LEAVE first fat block ok WITH FALSE + FI. + +END PROC first fat block ok; + +PROC open fetch (TEXT CONST name, REAL VAR size, INT VAR first cluster no): + enable stop; + first cluster no := dir.file list.entry [link index].first cluster; + size := dir.file list.entry [link index].size; + IF first cluster no >= 4088 + THEN first cluster no := -1 + FI; + akt file cluster no := first cluster no. + +link index: + link (file thes, name). + +END PROC open fetch; + +PROC open fetch subdir (TEXT CONST subdir name, INT VAR first cluster no): + first cluster no := dir.dir list.entry [link index]; + IF first cluster no >= 4088 + THEN first cluster no := -1 + FI; + akt file cluster no := first cluster no. + +link index: + link (dir thes, subdir name). + +END PROC open fetch subdir; + +INT PROC next fetch cluster no: + enable stop; + akt file cluster no := fat entry (akt file cluster no); + IF akt file cluster no < 4088 (*ff8h *) + THEN akt file cluster no + ELSE -1 + FI. + +END PROC next fetch cluster no; + +PROC open save (TEXT CONST file name): + enable stop; + save name := file name; + IF dir full + THEN error stop ("Directory voll") + FI; + IF dir thes CONTAINS file name + THEN error stop ("Subdirectory mit gleichem Namen existiert bereits") + FI; + IF file thes CONTAINS file name + THEN error stop ("Datei mit gleichem Namen existiert bereits") + FI; + no cluster saved := TRUE. + +END PROC open save; + +INT PROC next save cluster no: + enable stop; + IF no cluster saved + THEN akt file cluster no := available fat entry; + first file cluster no := akt file cluster no; + no cluster saved := FALSE + ELSE INT VAR old cluster no := akt file cluster no; + akt file cluster no := available fat entry; + write fat entry (old cluster no, akt file cluster no) + FI; + write fat entry (akt file cluster no, last entry of fat chain); + akt file cluster no. + +END PROC next save cluster no; + +PROC close save (REAL CONST size): + enable stop; + IF no cluster saved + THEN insert dir entry (save name, 4088, 0.0) + ELSE copy fat to disk; + insert dir entry (save name, first file cluster no, size) + FI. + +END PROC close save; + +PROC erase table entrys (TEXT CONST name): + enable stop; + INT VAR first file cluster := first cluster; + delete dir entry (name); + erase fat chain (first file cluster); + copy fat to disk. + +first cluster: + dir.file list.entry [link index].first cluster. + +link index: + link (file thes, name). + +END PROC erase table entrys; + +INT PROC fat entry (INT CONST entry no): + fix bytes; + construct value. + +fix bytes: + INT VAR first byte no := entry no + entry no DIV 2. + +construct value: + IF entry no MOD 2 = 0 + THEN (right byte MOD 16) * 256 + left byte + ELSE right byte * 16 + left byte DIV 16 + FI. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (first byte no + 1). + +END PROC fat entry; + +INT PROC available fat entry: + FOR count FROM first possible available fat entry UPTO number of fat entrys - 1 REP + IF is available entry (count) + THEN first possible available fat entry := count; + LEAVE available fat entry WITH count + FI; + PER; + close action; error stop ("MS-DOS Datentraeger voll"); maxint. + +END PROC available fat entry; + +BOOL PROC is available entry (INT CONST entry no): + is zero entry. + +is zero entry: + IF entry no MOD 2 = 0 + THEN (left byte = 0) CAND ((right byte MOD 16) = 0) + ELSE (right byte = 0) CAND ((left byte DIV 16) = 0) + FI. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (first byte no + 1). + +first byte no: + entry no + entry no DIV 2. + +END PROC is available entry; + +PROC erase fat chain (INT CONST first entry): + INT VAR akt entry no := first entry, + entry := fat entry (akt entry no); + WHILE akt entry no not last chain entry no REP + erase akt entry; + akt entry no := entry; + entry := fat entry (akt entry no) + PER; + erase akt entry. + +akt entry no not last chain entry no: + (entry < last entry of fat chain) AND (entry > 1). + +erase akt entry: + write fat entry (akt entry no, 0). + +END PROC erase fat chain; + +PROC write fat entry (INT CONST entry no, value): + fix bytes; + remark write access (fat block of first byte); + remark write access (fat block of second byte); + write value; + update first possible available entry. + +fix bytes: + INT VAR first byte no := entry no + entry no DIV 2. + +fat block of first byte: + first byte no DIV 512. + +fat block of second byte: + second byte no DIV 512. + +write value: + IF even entry no + THEN write fat byte (first byte no, value MOD 256); + write fat byte (second byte no, + (right byte DIV 16) * 16 + value DIV 256) + ELSE write fat byte (first byte no, + (left byte MOD 16) + 16 * (value MOD 16)); + write fat byte (second byte no, value DIV 16) + FI. + +even entry no: + entry no MOD 2 = 0. + +second byte no: + first byte no + 1. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (second byte no). + +update first possible available entry: + IF value = 0 + THEN first possible available fat entry := + min (first possible available fat entry, entry no) + FI. + +END PROC write fat entry; + +INT PROC fat byte (INT CONST no): + replace (convert buffer, 1, word); + IF even byte no + THEN code (convert buffer SUB 1) + ELSE code (convert buffer SUB 2) + FI. + +even byte no: + no MOD 2 = 0. + +word: + fat [no DIV 2 + 1]. + +END PROC fat byte; + +PROC write fat byte (INT CONST byte no, new value): + read old word; + change byte; + write new word. + +read old word: + replace (convert buffer, 1, word). + +write new word: + word := convert buffer ISUB 1. + +word: + fat [byte no DIV 2 + 1]. + +change byte: + replace (convert buffer, byte pos, code (new value)). + +byte pos: + byte no MOD 2 + 1. + +END PROC write fat byte; + +PROC copy fat to disk: + INT VAR block no; + FOR block no FROM 0 UPTO number of fat sectors - 1 REP + IF was write access (block no) + THEN write fat block (block no) + FI + PER. + +END PROC copy fat to disk; + +PROC write fat block (INT CONST fat block no): + INT VAR fat copy no; + INT VAR return code; + disable stop; + FOR fat copy no FROM 0 UPTO number of fat copies -1 REP + write disk block (fat space, ds page no, block no, return code); + IF return code > 0 + THEN close action + FI + PER; + remark no write access (block no); + enable stop. + +ds page no: + first non dummy ds page + fat block no + 1. + +block no: + begin of fat (fat copy no) + fat block no. + +END PROC write fat block; + +PROC read fat block (INT CONST fat block, BOOL CONST test block): + INT VAR fat copy no; + disable stop; + FOR fat copy no FROM 0 UPTO number of fat copies - 1 REP + clear error; + read disk block (fat space, ds page no, fat block no) + UNTIL NOT is error + PER; + IF is error + THEN close action + FI; + enable stop. + +ds page no: + IF test block + THEN first non dummy ds page + ELSE fat block + first non dummy ds page + 1 + FI. + +fat block no: + begin of fat (fat copy no) + fat block. + +END PROC read fat block; + +PROC define write access table (BOOL CONST status): + FOR count FROM 1 UPTO number of fat sectors REP + write access [count] := status + PER. + +END PROC define write access table; + +PROC remark write access (INT CONST fat block no): + write access [fat block no + 1] := TRUE + +END PROC remark write access; + +PROC remark no write access (INT CONST fat block no): + write access [fat block no + 1] := FALSE + +END PROC remark no write access; + +BOOL PROC was write access (INT CONST fat block no): + write access [fat block no + 1] + +END PROC was write access; + +(*COND TEST +PROC dump fat: + IF NOT exists ("fat dump") + THEN open file + FI; + DATASPACE VAR ds := nilspace; + FILE VAR in := sequential file (input, "fat dump"), + out := sequential file (output, ds); + INT VAR i; + TEXT VAR line; + FOR i FROM 0 UPTO number of fat entrys - 1 REP + dump fat entry + PER; + forget ("fat dump", quiet); + copy (ds, "fat dump"); + forget (ds). + +open file: + in := sequential file (output, "fat dump"); + FOR i FROM 0 UPTO number of fat entrys - 1 REP + putline (in, text (i, 4) + ": ") + PER. + +dump fat entry: + cout (i); + getline (in, line); + putline (out, line + " " + text (fat entry (i), 4)). + +END PROC dump fat; +ENDCOND*) + +PROC load dir block (INT CONST block no, BOOL VAR last block): + last block := FALSE; + INT VAR return code; + read disk block (block ds, first non dummy ds page, block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI; + INT VAR entry no, + thes index; + FOR entry no FROM 0 UPTO dir entrys per block - 1 REP + dir entry := text 32 (block, entry no); + process entry + PER. + +process entry: + SELECT pos (""0"."229"", dir entry SUB 1) OF + CASE 1: end of dir search + CASE 2: main dir entry + CASE 3: free entry + OTHERWISE file entry + END SELECT. + +end of dir search: + last block := TRUE; + store begin of free area (loc (block no, entry no)); + LEAVE load dir block. + +main dir entry: + (* no operation *). + +free entry: + store in free list (loc (block no, entry no)). + +file entry: + SELECT code (dir entry SUB 12) OF + CASE 8: volume label + CASE 16: sub dir entry + OTHERWISE dos file entry + END SELECT. + +volume label: + dir.disk label := text (dir entry, 1, 11). + +sub dir entry: + dir.dir list.no of entrys INCR 1; + insert (dir thes, name, thes index); + dir list entry := first cluster no. + +dos file entry: + IF dir.file list.no of entrys >= max dir entrys + THEN error stop ("Directorytabelle voll") + FI; + dir.file list.no of entrys INCR 1; + insert (file thes, name, thes index); + file list entry.first cluster := first cluster no; + file list entry.date and time := dos date + " " + dos time; + file list entry.size := dos storage; + file list entry.location.msdos block no := block no; + file list entry.location.block entry no := entry no. + +name: + IF name post <> "" + THEN name pre + "." + name post + ELSE name pre + FI. + +name pre: + compress (subtext (dir entry, 1, 8)). + +name post: + compress (subtext (dir entry, 9, 11)). + +file list entry: + dir.file list.entry [thes index]. + +dir list entry: + dir.dir list.entry [thes index]. + +first cluster no: + code (dir entry SUB 27) + 256 * code (dir entry SUB 28). + +dos storage: + real (code (dir entry SUB 29)) + + real (code (dir entry SUB 30)) * 256.0 + + real (code (dir entry SUB 31)) * 65536.0 + + real (code (dir entry SUB 32)) * 16777216.0. + +dos date: + day + "." + month + "." + year. + +day: + IF code (dir entry SUB 25) MOD 32 < 10 + THEN "0" + text (code (dir entry SUB 25) MOD 32) + ELSE text (code (dir entry SUB 25) MOD 32) + FI. + +month: + INT VAR dummy := code (dir entry SUB 25) DIV 32 + 8 * (code (dir entry SUB 26) MOD 2); + IF dummy < 10 + THEN "0" + text (dummy) + ELSE text (dummy) + FI. + +year: + text (80 + code (dir entry SUB 26) DIV 2, 2). + +dos time: + hour + ":" + minute. + +hour: + dummy := code (dir entry SUB 24) DIV 8; + IF dummy < 10 + THEN "0" + text (dummy) + ELSE text (dummy) + FI. + +minute: + dummy := code (dir entry SUB 23) DIV 32 + 8 * (code (dir entry SUB 24) MOD 8); + IF dummy < 10 + THEN "0" + text (dummy) + ELSE text (dummy) + FI. + +END PROC load dir block; + +PROC insert dir entry (TEXT CONST name, INT CONST start cluster, REAL CONST used storage): + (* name must be a dos name *) + LOCATION VAR ins pos := free location; + TEXT VAR akt date := date (clock (1)), + akt time := time of day (clock (1)); + write disk entry; + write dir struct entry. + +write disk entry: + INT VAR return code; + read disk block (block ds, first non dummy ds page, ins pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI; + prepare name; + dir entry := name pre + name post + archive byte + (10 * ""0"") + dos time + + dos date + starting cluster + storage; + write text 32 (block, dir entry, ins pos.block entry no); + write disk block (block ds, first non dummy ds page,ins pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI. + +prepare name: + TEXT VAR name pre, name post; + IF point pos > 0 + THEN name pre := subtext (name, 1, point pos - 1); + name post := subtext (name, point pos + 1); + name pre CAT (8 - LENGTH name pre) * " "; + name post CAT (3 - LENGTH name post) * " " + ELSE name pre := name + (8 - LENGTH name) * " "; + name post := " " + FI. + +point pos: + pos (name, "."). + +dos time: + code ((minute MOD 8) * 32) + code (8 * hour + minute DIV 8). + +hour: + int (subtext (akt time, 1, 2)). + +minute: + int (subtext (akt time, 4, 5)). + +dos date: + code (32 * (month MOD 8) + day) + code ((year - 80) * 2 + month DIV 8). + +day: + int (subtext (akt date, 1, 2)). + +month: + int (subtext (akt date, 4, 5)). + +year: + int (subtext (akt date, 7, 8)). + +starting cluster: + code (start cluster MOD 256) + code (start cluster DIV 256). + +storage: + code (int (round (256.0 * frac (used storage / 256.0), 0))) + + code (int (round (frac (floor (used storage / 256.0) / 256.0) * 256.0, 0))) + + code (int (floor (used storage / 65536.0))) + + code (0). (* maximal 16384 K *********************************) + +write dir struct entry: + INT VAR thes link; + insert (file thes, name, thes link); + file list entry.location := ins pos; + file list entry.first cluster := start cluster; + file list entry.date and time := akt date + " " + akt time; + file list entry.size := used storage. + +file list entry: + dir.filelist.entry [thes link]. + +END PROC insert dir entry; + +PROC delete dir entry (TEXT CONST name): + LOCATION VAR del pos; + get del pos; + erase dir struct entry; + erase disk entry; + store in free list (del pos). + +get del pos: + del pos := dir.filelist.entry [link index].location. + +link index: + link (file thes, name). + +erase dir struct entry: + INT VAR i; + delete (file thes, name, i). + +erase disk entry: + INT VAR return code; + read disk block (block ds, first non dummy ds page, del pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI; + dir entry := text 32 (block, del pos.block entry no); + replace (dir entry, 1, ""229""); + write text 32 (block, dir entry, del pos.block entry no); + write disk block (block ds, first non dummy ds page, del pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI. + +END PROC delete dir entry; + +. +file thes: + dir.filelist.thes. + +dir thes: + dir.dir list.thes. + +(*********************** dir information ******************************) + +THESAURUS PROC dir all: + file thes. + +END PROC dir all; + +BOOL PROC dir contains (TEXT CONST name): + file thes CONTAINS name + +END PROC dir contains; + +PROC dir list (DATASPACE VAR ds): + enable stop; + open list file; + list files; + list dirs; + write list head. + +open list file: + forget (ds); + ds := nilspace; + FILE VAR list file := sequential file (output, ds); + putline (list file, ""). + +list files: + INT VAR number := 0; + get (file thes, name, number); + WHILE number > 0 REP + generate file list line; + get (file thes, name, number) + PER. + +generate file list line: + write (list file, centered name); + write (list file, " "); + write (list file, text (act file entry.size, 11, 0)); + write (list file, " Bytes belegt "); + write (list file, act file entry.date and time); +(*COND TEST + write (list file, " +++ "); + write (list file, text (act file entry.first cluster)); +ENDCOND*) + line (list file). + +list dirs: + number := 0; + get (dir thes, name, number); + WHILE number > 0 REP + generate dir list line; + get (dir thes, name, number) + PER. + +generate dir list line: + write (list file, centered name); + write (list file, " "); +(*COND TEST + write (list file, " +++ "); + write (list file, text (dir.dir list.entry [number])); +ENDCOND*) + line (list file). + +centered name: + INT VAR point pos := pos (name, "."); + IF point pos > 0 + THEN name pre + "." + name post + ELSE text (name, 12) + FI. + +name pre: + text (subtext (name, 1, point pos - 1), 8). + +name post: + text (subtext (name, point pos + 1, point pos + 4), 3). + +act file entry: + dir.file list.entry [number]. + +write list head: + head line (list file, head). + +head: + "DOS" + disk label string + path string. + +disk label string: + IF dir.disk label <> "" + THEN ": " + dir.disk label + ELSE "" + FI. + +path string: + IF dir.path <> "" + THEN " PATH: " + dir.path + ELSE "" + FI. + +END PROC dir list; + +(************ free list handling ******************************************) +LOCATION PROC loc (INT CONST block, entry): + LOCATION : (block, entry) + +END PROC loc; + +BOOL OP > (LOCATION CONST l, r): + l.msdos block no > r.msdos block no + OR ((l.msdos block no = r.msdos block no) AND + (l.block entry no > r.block entry no) ) + +END OP >; + +OP INCR (LOCATION VAR l): + IF l.block entry no = dir entrys per block -1 + THEN l.block entry no := 0; + l.msdos block no INCR 1 + ELSE l.block entry no INCR 1 + FI. + +END OP INCR; + +PROC init free list (INT CONST dir root): + dir.freelist.stacktop := 0; + dir.freelist.begin of free area.msdos block no := maxint; + dir.freelist.end of dir.msdos block no := -1; + dir.freelist.dir chain root := dir root. + +END PROC init free list; + +BOOL PROC dir full: + stack empty AND free area empty AND NOT expansion alloweded. + +stack empty: + dir.freelist.stacktop < 1. + +free area empty: + dir.freelist.begin of free area > dir.freelist.end of dir. + +expansion alloweded: + dir.freelist.dir chain root >= 0. + +END PROC dir full; + +PROC store in free list (LOCATION CONST free): + dir.freelist.stacktop INCR 1; + dir.freelist.stack [top] := free. + +top: + dir.freelist.stacktop. + +END PROC store in free list; + +PROC store begin of free area (LOCATION CONST begin): + dir.freelist.begin of free area := begin + +END PROC store begin of free area; + +PROC store end of dir (LOCATION CONST end): + dir.freelist.end of dir := end + +END PROC store end of dir; + +LOCATION PROC free location: + LOCATION VAR result; + IF dir.freelist.stacktop > 0 + THEN pop + ELIF NOT free area empty + THEN first of free area + ELIF expansion alloweded + THEN allocate new dir space; + result := free location + ELSE error stop ("Directorytabelle voll") + FI; + result. + +pop: + result := dir.freelist.stack [top]; + top DECR 1. + +top: + dir.freelist.stack top. + +free area empty: + dir.freelist.begin of free area > dir.freelist.end of dir. + +first of free area: + result := dir.freelist.begin of free area; + INCR dir.freelist.begin of free area. + +expansion alloweded: + dir.freelist.dir chain root >= 0. + +END PROC free location; + +PROC allocate new dir space: + enable stop; + INT VAR new cluster no := available fat entry; + IF new cluster no < 0 + THEN error stop ("MS-DOS Datentraeger voll") + FI; + INT VAR last entry no; + search last entry of fat chain; + write fat entry (new cluster no, 4095); + write fat entry (last entry no, new cluster no); + copy fat to disk; + store begin of free area (loc (first new block, 0)); + store end of dir (loc (last new block, dir entrys per block - 1)); + init new dir cluster. + +search last entry of fat chain: + last entry no := dir.freelist.dir chain root; + WHILE fat entry (last entry no) < last entry of fat chain REP + last entry no := fat entry (last entry no) + PER. + +init new dir cluster: + FOR count FROM 0 UPTO dir entrys per block - 1 REP + write text 32 (block, ""0"" + 31 * ""246"", count) + PER; + disable stop; + FOR count FROM first new block UPTO last new block REP + write disk block (block ds, count); + PER. + +first new block: + firstblock no of cluster (new cluster no). + +last new block: + first block no of cluster (new cluster no) + sectors per cluster - 1. + +END PROC allocate new dir space; + +(*COND TEST +PROC dump freelist: + command dialogue (FALSE); + FILE VAR f := sequential file (output, "freelistdump"); + INT VAR i; + putline (f, "STACKTOP: " + text (fl.stacktop)); + putline (f, "STACK:"); + FOR i FROM 1 UPTO 16 * number of dir sectors REP + putline (f, " " + text (i, 4) + ": " + + text (fl.stack [i].msdos block no) + ", " + + text (fl.stack [i].block entry no)) + PER; + line (f); + putline (f, "BEGIN OF FREE: " + text (fl.begin of free area.msdos block no) + + ", " + text (fl.begin of free area.block entry no)); + putline (f, "END OF DIR: " + text (fl.end of dir.msdos block no) + + ", " + text (fl.end of dir.block entry no)). + +fl: + dir.freelist. + +END PROC dump free list; +ENDCOND*) + +END PACKET dos fat and dir; diff --git a/system/dos/1986/src/fat and dir.dos.hd b/system/dos/1986/src/fat and dir.dos.hd new file mode 100644 index 0000000..7d53f41 --- /dev/null +++ b/system/dos/1986/src/fat and dir.dos.hd @@ -0,0 +1,1190 @@ +PACKET dos fat and dir DEFINES (* Copyright (C) 1985, 86 *) + (* Frank Klapper *) + open disk, (* 30.05.86 *) + close disk, + format disk, + disk changed, + open fetch, + next fetch cluster no, + open save, + next save cluster no, + close save, + erase table entrys, +(*COND TEST + dump fat, +ENDCOND*) + dir all, + dir list, + dir contains: + +LET fat row size = 16384, (* 32 KB *) + max fat blocks = 25, + first fat entry no = 2, + last entry of fat chain = 4088, + dir entrys per block = 16, + max dir entrys = 1600, (* 100 KB *) + archive byte = " "; + +LET FAT = BOUND STRUCT (ALIGN dummy, + ROW 256 INT block row, + ROW fat row size INT fat row); + +LET LOCATION = STRUCT (INT msdos block no, + block entry no), + + FILEENTRY = STRUCT (TEXT date and time, + REAL size, + INT first cluster, + LOCATION location), + + DIRENTRY = INT, + + FILELIST = STRUCT (THESAURUS thes, + ROW max dir entrys FILEENTRY entry, + INT no of entrys), + + DIRLIST = STRUCT (THESAURUS thes, + ROW max dir entrys DIRENTRY entry, + INT no of entrys), + + FREELIST = STRUCT (ROW max dir entrys LOCATION stack, + INT stacktop, + LOCATION begin of free area, + end of dir, + INT dir chain root), + + DIR = BOUND STRUCT (FILELIST filelist, + DIRLIST dirlist, + FREELIST freelist, + TEXT disklabel, + path); + +INITFLAG VAR this packet := FALSE; + +DATASPACE VAR fat space, + dir ds, + block ds; + +BOOL VAR dataspaces open; + +FAT VAR fat struct; +ROW max fat blocks BOOL VAR write access; +INT VAR first possible available fat entry; + +DIR VAR dir; + +CLUSTER VAR block; + +INT VAR akt file cluster no, + first file cluster no; +BOOL VAR no cluster saved; +TEXT VAR save name; + +INT VAR count; + +TEXT VAR convert buffer := " ", + name, + dir entry; + +.fat: + fat struct.fat row. + +PROC open disk (TEXT CONST subdir path): + disable stop; + enable open disk (subdir path); + IF is error + THEN close action + FI + +END PROC open disk; + +PROC enable open disk (TEXT CONST subdir path): + enable stop; + init dataspaces; + open fat; + open dir. + +open fat: + reset disk attributes; + read first fat block; + set disk attributes (fat byte (0)); + read other fat blocks; + define write access table (FALSE); + first possible available fat entry := first fat entry no. + + read first fat block: + read fat block (0, FALSE). + +read other fat blocks: + INT VAR block no; + FOR block no FROM 1 UPTO number of fat sectors - 1 REP + read fat block (block no, FALSE) + PER. + +open dir: + init dir struct (subdir path, -1); + load main dir blocks; + load subdirs if necessary. + +load main dir blocks: + BOOL VAR last block; + store end of dir (loc (end of main dir, dir entrys per block - 1)); + FOR block no FROM begin of dir UPTO end of main dir REP + load dir block (block no, last block); + UNTIL last block + PER. + +end of main dir: + begin of dir + number of dir sectors - 1. + +load subdirs if necessary: + TEXT VAR path := subdir path; + WHILE path <> "" REP + load next subdir if possible + PER. + +load next subdir if possible: + INT VAR cluster no; + get next subdir name; + get first cluster no of subdir table; + clear dir entrys (cluster no); + WHILE cluster no >= 0 REP + load subdir entrys of cluster; + cluster no := next fetch cluster no + UNTIL last block + PER. + +get next subdir name: + TEXT VAR subdir name; + IF (path SUB 1) <> "\" + THEN error stop ("ungltige Pfadbezeichnung") + FI; + INT VAR backslash pos := pos (path, "\", "\", 2); + IF backslash pos = 0 + THEN subdir name := subtext (path, 2); + path := "" + ELSE subdir name := subtext (path, 2, backslash pos - 1); + path := subtext (path, backslash pos) + FI; + subdir name := adapted name (subdir name, TRUE). + +get first cluster no of subdir table: + IF dir thes CONTAINS subdir name + THEN open fetch subdir (subdir name, cluster no); + ELSE error stop ("Subdirectory existiert nicht") + FI. + +load subdir entrys of cluster: + store end of dir (loc (last block no of cluster, dir entrys per block - 1)); + FOR block no FROM 0 UPTO (sectors per cluster - 1) REP + load dir block (first block no of cluster (cluster no) + block no, last block) + UNTIL last block + PER. + +last block no of cluster: + first block no of cluster (cluster no) + sectors per cluster - 1. + +END PROC enable open disk; + +PROC init dataspaces: + enable stop; + IF NOT initialized (this packet) + THEN dataspaces open := FALSE + FI; + IF NOT dataspaces open + THEN disable stop; + dataspaces open := TRUE; + fat space := nilspace; + dir ds := nilspace; + block ds := nilspace; + fat struct := fat space; + dir := dir ds; + block := block ds + FI. + +END PROC init dataspaces; + +PROC init dir struct (TEXT CONST path string, INT CONST root): + clear dir entrys (root); + dir.path := path string; + dir.disk label := "". + +END PROC init dir struct; + +PROC clear dir entrys (INT CONST root): + init file list; + init dir list; + init free list (root). + +init file list: + dir.file list.thes := empty thesaurus; + dir.file list.no of entrys := 0. + +init dir list: + dir.dir list.thes := empty thesaurus; + dir.dir list.no of entrys := 0. + +END PROC clear dir entrys; + +PROC close disk: + enable stop; + IF NOT initialized (this packet) + THEN dataspaces open := FALSE + FI; + IF dataspaces open + THEN forget (dir ds); + forget (block ds); + forget (fat space); + dataspaces open := FALSE + FI. + +END PROC close disk; + +(*COND FLOPPY +PROC format disk: + enable stop; + init dataspaces; + format fat; + format dir. + +format fat: + write first four fat bytes; + write other fat bytes; + define write access table (TRUE); + copy fat to disk. + +write first four fat bytes: + fat [1] := word (first fat byte, 255); + fat [2] := word (255, 0). + +write other fat bytes: + FOR count FROM 3 UPTO fat length REP + fat [count] := 0 + PER. + +fat length: + INT VAR len := number of fat entrys + number of fat entrys DIV 2 + + number of fat entrys MOD 2; + len DIV 2 + len MOD 2. + +format dir: + init dir struct ("", -1); + store begin of free area (loc (begin of dir, 0)); + store end of dir (loc (end of dir, dir entrys per block - 1)); + FOR count FROM 0 UPTO dir entrys per block - 1 REP + write text 32 (block, ""0"" + 31 * ""246"", count) + PER; + disable stop; + FOR count FROM begin of dir UPTO end of dir REP + write disk block (block ds, count); + PER. + +end of dir: + begin of dir + number of dir sectors - 1. + +END PROC format disk; +ENDCOND*) + +(*COND HDU*) +PROC disk clear: + error stop ("nicht implementiert") + +END PROC disk clear; + +PROC format disk: + error stop ("nicht implementiert") + +END PROC format disk; +(*ENDCOND*) + +INT PROC word (INT CONST low byte, high byte): + convert buffer := code (low byte) + code (high byte); + convert buffer ISUB 1. + +END PROC word; + +BOOL PROC disk changed: +(*COND FLOPPY + disable stop; + NOT first fat block ok COR is error (* must be COR *) +ENDCOND*) +(*COND HDU*) + FALSE +(*ENDCOND*) + +END PROC disk changed; + +BOOL PROC first fat block ok: + enable stop; + read fat block (0, TRUE); + FOR count FROM 1 UPTO 256 REP + compare word + PER; + TRUE. + +compare word: + IF fat struct.fat row [count] <> fat struct.block row [count] + THEN LEAVE first fat block ok WITH FALSE + FI. + +END PROC first fat block ok; + +PROC open fetch (TEXT CONST name, REAL VAR size, INT VAR first cluster no): + enable stop; + first cluster no := dir.file list.entry [link index].first cluster; + size := dir.file list.entry [link index].size; + IF first cluster no >= 4088 + THEN first cluster no := -1 + FI; + akt file cluster no := first cluster no. + +link index: + link (file thes, name). + +END PROC open fetch; + +PROC open fetch subdir (TEXT CONST subdir name, INT VAR first cluster no): + first cluster no := dir.dir list.entry [link index]; + IF first cluster no >= 4088 + THEN first cluster no := -1 + FI; + akt file cluster no := first cluster no. + +link index: + link (dir thes, subdir name). + +END PROC open fetch subdir; + +INT PROC next fetch cluster no: + enable stop; + akt file cluster no := fat entry (akt file cluster no); + IF akt file cluster no < 4088 (*ff8h *) + THEN akt file cluster no + ELSE -1 + FI. + +END PROC next fetch cluster no; + +PROC open save (TEXT CONST file name): + enable stop; + save name := file name; + IF dir full + THEN error stop ("Directory voll") + FI; + IF dir thes CONTAINS file name + THEN error stop ("Subdirectory mit gleichem Namen existiert bereits") + FI; + IF file thes CONTAINS file name + THEN error stop ("Datei mit gleichem Namen existiert bereits") + FI; + no cluster saved := TRUE. + +END PROC open save; + +INT PROC next save cluster no: + enable stop; + IF no cluster saved + THEN akt file cluster no := available fat entry; + first file cluster no := akt file cluster no; + no cluster saved := FALSE + ELSE INT VAR old cluster no := akt file cluster no; + akt file cluster no := available fat entry; + write fat entry (old cluster no, akt file cluster no) + FI; + write fat entry (akt file cluster no, last entry of fat chain); + akt file cluster no. + +END PROC next save cluster no; + +PROC close save (REAL CONST size): + enable stop; + IF no cluster saved + THEN insert dir entry (save name, 4088, 0.0) + ELSE copy fat to disk; + insert dir entry (save name, first file cluster no, size) + FI. + +END PROC close save; + +PROC erase table entrys (TEXT CONST name): + enable stop; + INT VAR first file cluster := first cluster; + delete dir entry (name); + erase fat chain (first file cluster); + copy fat to disk. + +first cluster: + dir.file list.entry [link index].first cluster. + +link index: + link (file thes, name). + +END PROC erase table entrys; + +INT PROC fat entry (INT CONST entry no): + fix bytes; + construct value. + +fix bytes: + INT VAR first byte no := entry no + entry no DIV 2. + +construct value: + IF entry no MOD 2 = 0 + THEN (right byte MOD 16) * 256 + left byte + ELSE right byte * 16 + left byte DIV 16 + FI. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (first byte no + 1). + +END PROC fat entry; + +INT PROC available fat entry: + FOR count FROM first possible available fat entry UPTO number of fat entrys - 1 REP + IF is available entry (count) + THEN first possible available fat entry := count; + LEAVE available fat entry WITH count + FI; + PER; + close action; error stop ("MS-DOS Datentraeger voll"); maxint. + +END PROC available fat entry; + +BOOL PROC is available entry (INT CONST entry no): + is zero entry. + +is zero entry: + IF entry no MOD 2 = 0 + THEN (left byte = 0) CAND ((right byte MOD 16) = 0) + ELSE (right byte = 0) CAND ((left byte DIV 16) = 0) + FI. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (first byte no + 1). + +first byte no: + entry no + entry no DIV 2. + +END PROC is available entry; + +PROC erase fat chain (INT CONST first entry): + INT VAR akt entry no := first entry, + entry := fat entry (akt entry no); + WHILE akt entry no not last chain entry no REP + erase akt entry; + akt entry no := entry; + entry := fat entry (akt entry no) + PER; + erase akt entry. + +akt entry no not last chain entry no: + (entry < last entry of fat chain) AND (entry > 1). + +erase akt entry: + write fat entry (akt entry no, 0). + +END PROC erase fat chain; + +PROC write fat entry (INT CONST entry no, value): + fix bytes; + remark write access (fat block of first byte); + remark write access (fat block of second byte); + write value; + update first possible available entry. + +fix bytes: + INT VAR first byte no := entry no + entry no DIV 2. + +fat block of first byte: + first byte no DIV 512. + +fat block of second byte: + second byte no DIV 512. + +write value: + IF even entry no + THEN write fat byte (first byte no, value MOD 256); + write fat byte (second byte no, + (right byte DIV 16) * 16 + value DIV 256) + ELSE write fat byte (first byte no, + (left byte MOD 16) + 16 * (value MOD 16)); + write fat byte (second byte no, value DIV 16) + FI. + +even entry no: + entry no MOD 2 = 0. + +second byte no: + first byte no + 1. + +left byte: + fat byte (first byte no). + +right byte: + fat byte (second byte no). + +update first possible available entry: + IF value = 0 + THEN first possible available fat entry := + min (first possible available fat entry, entry no) + FI. + +END PROC write fat entry; + +INT PROC fat byte (INT CONST no): + replace (convert buffer, 1, word); + IF even byte no + THEN code (convert buffer SUB 1) + ELSE code (convert buffer SUB 2) + FI. + +even byte no: + no MOD 2 = 0. + +word: + fat [no DIV 2 + 1]. + +END PROC fat byte; + +PROC write fat byte (INT CONST byte no, new value): + read old word; + change byte; + write new word. + +read old word: + replace (convert buffer, 1, word). + +write new word: + word := convert buffer ISUB 1. + +word: + fat [byte no DIV 2 + 1]. + +change byte: + replace (convert buffer, byte pos, code (new value)). + +byte pos: + byte no MOD 2 + 1. + +END PROC write fat byte; + +PROC copy fat to disk: + INT VAR block no; + FOR block no FROM 0 UPTO number of fat sectors - 1 REP + IF was write access (block no) + THEN write fat block (block no) + FI + PER. + +END PROC copy fat to disk; + +PROC write fat block (INT CONST fat block no): + INT VAR fat copy no; + INT VAR return code; + disable stop; + FOR fat copy no FROM 0 UPTO number of fat copies -1 REP + write disk block (fat space, ds page no, block no, return code); + IF return code > 0 + THEN close action + FI + PER; + remark no write access (block no); + enable stop. + +ds page no: + first non dummy ds page + fat block no + 1. + +block no: + begin of fat (fat copy no) + fat block no. + +END PROC write fat block; + +PROC read fat block (INT CONST fat block, BOOL CONST test block): + INT VAR fat copy no; + disable stop; + FOR fat copy no FROM 0 UPTO number of fat copies - 1 REP + clear error; + read disk block (fat space, ds page no, fat block no) + UNTIL NOT is error + PER; + IF is error + THEN close action + FI; + enable stop. + +ds page no: + IF test block + THEN first non dummy ds page + ELSE fat block + first non dummy ds page + 1 + FI. + +fat block no: + begin of fat (fat copy no) + fat block. + +END PROC read fat block; + +PROC define write access table (BOOL CONST status): + FOR count FROM 1 UPTO number of fat sectors REP + write access [count] := status + PER. + +END PROC define write access table; + +PROC remark write access (INT CONST fat block no): + write access [fat block no + 1] := TRUE + +END PROC remark write access; + +PROC remark no write access (INT CONST fat block no): + write access [fat block no + 1] := FALSE + +END PROC remark no write access; + +BOOL PROC was write access (INT CONST fat block no): + write access [fat block no + 1] + +END PROC was write access; + +(*COND TEST +PROC dump fat: + IF NOT exists ("fat dump") + THEN open file + FI; + DATASPACE VAR ds := nilspace; + FILE VAR in := sequential file (input, "fat dump"), + out := sequential file (output, ds); + INT VAR i; + TEXT VAR line; + FOR i FROM 0 UPTO number of fat entrys - 1 REP + dump fat entry + PER; + forget ("fat dump", quiet); + copy (ds, "fat dump"); + forget (ds). + +open file: + in := sequential file (output, "fat dump"); + FOR i FROM 0 UPTO number of fat entrys - 1 REP + putline (in, text (i, 4) + ": ") + PER. + +dump fat entry: + cout (i); + getline (in, line); + putline (out, line + " " + text (fat entry (i), 4)). + +END PROC dump fat; +ENDCOND*) + +PROC load dir block (INT CONST block no, BOOL VAR last block): + last block := FALSE; + INT VAR return code; + read disk block (block ds, first non dummy ds page, block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI; + INT VAR entry no, + thes index; + FOR entry no FROM 0 UPTO dir entrys per block - 1 REP + dir entry := text 32 (block, entry no); + process entry + PER. + +process entry: + SELECT pos (""0"."229"", dir entry SUB 1) OF + CASE 1: end of dir search + CASE 2: main dir entry + CASE 3: free entry + OTHERWISE file entry + END SELECT. + +end of dir search: + last block := TRUE; + store begin of free area (loc (block no, entry no)); + LEAVE load dir block. + +main dir entry: + (* no operation *). + +free entry: + store in free list (loc (block no, entry no)). + +file entry: + SELECT code (dir entry SUB 12) OF + CASE 8: volume label + CASE 16: sub dir entry + OTHERWISE dos file entry + END SELECT. + +volume label: + dir.disk label := text (dir entry, 1, 11). + +sub dir entry: + dir.dir list.no of entrys INCR 1; + insert (dir thes, name, thes index); + dir list entry := first cluster no. + +dos file entry: + IF dir.file list.no of entrys >= max dir entrys + THEN error stop ("Directorytabelle voll") + FI; + dir.file list.no of entrys INCR 1; + insert (file thes, name, thes index); + file list entry.first cluster := first cluster no; + file list entry.date and time := dos date + " " + dos time; + file list entry.size := dos storage; + file list entry.location.msdos block no := block no; + file list entry.location.block entry no := entry no. + +name: + IF name post <> "" + THEN name pre + "." + name post + ELSE name pre + FI. + +name pre: + compress (subtext (dir entry, 1, 8)). + +name post: + compress (subtext (dir entry, 9, 11)). + +file list entry: + dir.file list.entry [thes index]. + +dir list entry: + dir.dir list.entry [thes index]. + +first cluster no: + code (dir entry SUB 27) + 256 * code (dir entry SUB 28). + +dos storage: + real (code (dir entry SUB 29)) + + real (code (dir entry SUB 30)) * 256.0 + + real (code (dir entry SUB 31)) * 65536.0 + + real (code (dir entry SUB 32)) * 16777216.0. + +dos date: + day + "." + month + "." + year. + +day: + IF code (dir entry SUB 25) MOD 32 < 10 + THEN "0" + text (code (dir entry SUB 25) MOD 32) + ELSE text (code (dir entry SUB 25) MOD 32) + FI. + +month: + INT VAR dummy := code (dir entry SUB 25) DIV 32 + 8 * (code (dir entry SUB 26) MOD 2); + IF dummy < 10 + THEN "0" + text (dummy) + ELSE text (dummy) + FI. + +year: + text (80 + code (dir entry SUB 26) DIV 2, 2). + +dos time: + hour + ":" + minute. + +hour: + dummy := code (dir entry SUB 24) DIV 8; + IF dummy < 10 + THEN "0" + text (dummy) + ELSE text (dummy) + FI. + +minute: + dummy := code (dir entry SUB 23) DIV 32 + 8 * (code (dir entry SUB 24) MOD 8); + IF dummy < 10 + THEN "0" + text (dummy) + ELSE text (dummy) + FI. + +END PROC load dir block; + +PROC insert dir entry (TEXT CONST name, INT CONST start cluster, REAL CONST used storage): + (* name must be a dos name *) + LOCATION VAR ins pos := free location; + TEXT VAR akt date := date (clock (1)), + akt time := time of day (clock (1)); + write disk entry; + write dir struct entry. + +write disk entry: + INT VAR return code; + read disk block (block ds, first non dummy ds page, ins pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI; + prepare name; + dir entry := name pre + name post + archive byte + (10 * ""0"") + dos time + + dos date + starting cluster + storage; + write text 32 (block, dir entry, ins pos.block entry no); + write disk block (block ds, first non dummy ds page,ins pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI. + +prepare name: + TEXT VAR name pre, name post; + IF point pos > 0 + THEN name pre := subtext (name, 1, point pos - 1); + name post := subtext (name, point pos + 1); + name pre CAT (8 - LENGTH name pre) * " "; + name post CAT (3 - LENGTH name post) * " " + ELSE name pre := name + (8 - LENGTH name) * " "; + name post := " " + FI. + +point pos: + pos (name, "."). + +dos time: + code ((minute MOD 8) * 32) + code (8 * hour + minute DIV 8). + +hour: + int (subtext (akt time, 1, 2)). + +minute: + int (subtext (akt time, 4, 5)). + +dos date: + code (32 * (month MOD 8) + day) + code ((year - 80) * 2 + month DIV 8). + +day: + int (subtext (akt date, 1, 2)). + +month: + int (subtext (akt date, 4, 5)). + +year: + int (subtext (akt date, 7, 8)). + +starting cluster: + code (start cluster MOD 256) + code (start cluster DIV 256). + +storage: + code (int (round (256.0 * frac (used storage / 256.0), 0))) + + code (int (round (frac (floor (used storage / 256.0) / 256.0) * 256.0, 0))) + + code (int (floor (used storage / 65536.0))) + + code (0). (* maximal 16384 K *********************************) + +write dir struct entry: + INT VAR thes link; + insert (file thes, name, thes link); + file list entry.location := ins pos; + file list entry.first cluster := start cluster; + file list entry.date and time := akt date + " " + akt time; + file list entry.size := used storage. + +file list entry: + dir.filelist.entry [thes link]. + +END PROC insert dir entry; + +PROC delete dir entry (TEXT CONST name): + LOCATION VAR del pos; + get del pos; + erase dir struct entry; + erase disk entry; + store in free list (del pos). + +get del pos: + del pos := dir.filelist.entry [link index].location. + +link index: + link (file thes, name). + +erase dir struct entry: + INT VAR i; + delete (file thes, name, i). + +erase disk entry: + INT VAR return code; + read disk block (block ds, first non dummy ds page, del pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI; + dir entry := text 32 (block, del pos.block entry no); + replace (dir entry, 1, ""229""); + write text 32 (block, dir entry, del pos.block entry no); + write disk block (block ds, first non dummy ds page, del pos.msdos block no, return code); + IF return code > 0 + THEN close action; + io error (return code) + FI. + +END PROC delete dir entry; + +. +file thes: + dir.filelist.thes. + +dir thes: + dir.dir list.thes. + +(*********************** dir information ******************************) + +THESAURUS PROC dir all: + file thes. + +END PROC dir all; + +BOOL PROC dir contains (TEXT CONST name): + file thes CONTAINS name + +END PROC dir contains; + +PROC dir list (DATASPACE VAR ds): + enable stop; + open list file; + list files; + list dirs; + write list head. + +open list file: + forget (ds); + ds := nilspace; + FILE VAR list file := sequential file (output, ds); + putline (list file, ""). + +list files: + INT VAR number := 0; + get (file thes, name, number); + WHILE number > 0 REP + generate file list line; + get (file thes, name, number) + PER. + +generate file list line: + write (list file, centered name); + write (list file, " "); + write (list file, text (act file entry.size, 11, 0)); + write (list file, " Bytes belegt "); + write (list file, act file entry.date and time); +(*COND TEST + write (list file, " +++ "); + write (list file, text (act file entry.first cluster)); +ENDCOND*) + line (list file). + +list dirs: + number := 0; + get (dir thes, name, number); + WHILE number > 0 REP + generate dir list line; + get (dir thes, name, number) + PER. + +generate dir list line: + write (list file, centered name); + write (list file, " "); +(*COND TEST + write (list file, " +++ "); + write (list file, text (dir.dir list.entry [number])); +ENDCOND*) + line (list file). + +centered name: + INT VAR point pos := pos (name, "."); + IF point pos > 0 + THEN name pre + "." + name post + ELSE text (name, 12) + FI. + +name pre: + text (subtext (name, 1, point pos - 1), 8). + +name post: + text (subtext (name, point pos + 1, point pos + 4), 3). + +act file entry: + dir.file list.entry [number]. + +write list head: + head line (list file, head). + +head: + "DOS" + disk label string + path string. + +disk label string: + IF dir.disk label <> "" + THEN ": " + dir.disk label + ELSE "" + FI. + +path string: + IF dir.path <> "" + THEN " PATH: " + dir.path + ELSE "" + FI. + +END PROC dir list; + +(************ free list handling ******************************************) +LOCATION PROC loc (INT CONST block, entry): + LOCATION : (block, entry) + +END PROC loc; + +BOOL OP > (LOCATION CONST l, r): + l.msdos block no > r.msdos block no + OR ((l.msdos block no = r.msdos block no) AND + (l.block entry no > r.block entry no) ) + +END OP >; + +OP INCR (LOCATION VAR l): + IF l.block entry no = dir entrys per block -1 + THEN l.block entry no := 0; + l.msdos block no INCR 1 + ELSE l.block entry no INCR 1 + FI. + +END OP INCR; + +PROC init free list (INT CONST dir root): + dir.freelist.stacktop := 0; + dir.freelist.begin of free area.msdos block no := maxint; + dir.freelist.end of dir.msdos block no := -1; + dir.freelist.dir chain root := dir root. + +END PROC init free list; + +BOOL PROC dir full: + stack empty AND free area empty AND NOT expansion alloweded. + +stack empty: + dir.freelist.stacktop < 1. + +free area empty: + dir.freelist.begin of free area > dir.freelist.end of dir. + +expansion alloweded: + dir.freelist.dir chain root >= 0. + +END PROC dir full; + +PROC store in free list (LOCATION CONST free): + dir.freelist.stacktop INCR 1; + dir.freelist.stack [top] := free. + +top: + dir.freelist.stacktop. + +END PROC store in free list; + +PROC store begin of free area (LOCATION CONST begin): + dir.freelist.begin of free area := begin + +END PROC store begin of free area; + +PROC store end of dir (LOCATION CONST end): + dir.freelist.end of dir := end + +END PROC store end of dir; + +LOCATION PROC free location: + LOCATION VAR result; + IF dir.freelist.stacktop > 0 + THEN pop + ELIF NOT free area empty + THEN first of free area + ELIF expansion alloweded + THEN allocate new dir space; + result := free location + ELSE error stop ("Directorytabelle voll") + FI; + result. + +pop: + result := dir.freelist.stack [top]; + top DECR 1. + +top: + dir.freelist.stack top. + +free area empty: + dir.freelist.begin of free area > dir.freelist.end of dir. + +first of free area: + result := dir.freelist.begin of free area; + INCR dir.freelist.begin of free area. + +expansion alloweded: + dir.freelist.dir chain root >= 0. + +END PROC free location; + +PROC allocate new dir space: + enable stop; + INT VAR new cluster no := available fat entry; + IF new cluster no < 0 + THEN error stop ("MS-DOS Datentraeger voll") + FI; + INT VAR last entry no; + search last entry of fat chain; + write fat entry (new cluster no, 4095); + write fat entry (last entry no, new cluster no); + copy fat to disk; + store begin of free area (loc (first new block, 0)); + store end of dir (loc (last new block, dir entrys per block - 1)); + init new dir cluster. + +search last entry of fat chain: + last entry no := dir.freelist.dir chain root; + WHILE fat entry (last entry no) < last entry of fat chain REP + last entry no := fat entry (last entry no) + PER. + +init new dir cluster: + FOR count FROM 0 UPTO dir entrys per block - 1 REP + write text 32 (block, ""0"" + 31 * ""246"", count) + PER; + disable stop; + FOR count FROM first new block UPTO last new block REP + write disk block (block ds, count); + PER. + +first new block: + firstblock no of cluster (new cluster no). + +last new block: + first block no of cluster (new cluster no) + sectors per cluster - 1. + +END PROC allocate new dir space; + +(*COND TEST +PROC dump freelist: + command dialogue (FALSE); + FILE VAR f := sequential file (output, "freelistdump"); + INT VAR i; + putline (f, "STACKTOP: " + text (fl.stacktop)); + putline (f, "STACK:"); + FOR i FROM 1 UPTO 16 * number of dir sectors REP + putline (f, " " + text (i, 4) + ": " + + text (fl.stack [i].msdos block no) + ", " + + text (fl.stack [i].block entry no)) + PER; + line (f); + putline (f, "BEGIN OF FREE: " + text (fl.begin of free area.msdos block no) + + ", " + text (fl.begin of free area.block entry no)); + putline (f, "END OF DIR: " + text (fl.end of dir.msdos block no) + + ", " + text (fl.end of dir.block entry no)). + +fl: + dir.freelist. + +END PROC dump free list; +ENDCOND*) + +END PACKET dos fat and dir; diff --git a/system/dos/1986/src/fetch b/system/dos/1986/src/fetch new file mode 100644 index 0000000..ad00ab6 --- /dev/null +++ b/system/dos/1986/src/fetch @@ -0,0 +1,333 @@ +PACKET fetch DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + (* 07.05.86 *) + fetch filemode, + fetch rowtextmode, + fetch dsmode, + check file: + +LET ascii = 1, + ascii german = 2, + transparent = 3, + ebcdic = 4, + atari st = 10; + +LET row text mode length = 4000, + row text type = 1000, + + ctrl z = ""26"", + tab = ""9"", + page cmd = "#page#"; + +CLUSTER VAR cluster; + +DATASPACE VAR cluster space; + +BOUND STRUCT (INT size, + ROW row text mode length TEXT cluster row) VAR cluster struct; + +INT VAR next cluster no; +REAL VAR file rest; + +FILE VAR file; + +PROC fetch filemode (DATASPACE VAR file space, + TEXT CONST name, INT CONST code type): + disable stop; + cluster space := nilspace; + cluster := cluster space; + enabled fetch filemode (file space, name, code type); + forget (cluster space). + +END PROC fetch filemode; + +PROC enabled fetch filemode (DATASPACE VAR file space, + TEXT CONST name, + INT CONST code type): + enable stop; + initialize fetch filemode; + open fetch (name, file rest, next cluster no); + WHILE (next cluster no >= 0) AND (file rest > 0.0) REP + get text of act cluster; + write lines; +(***************************************) + IF lines (file) > 3950 + THEN putline (file, ">>> FREMDDATEI FUER EUMEL ZU LANG. ES KNNEN DATEN FEHLEN <<<"); + LEAVE enabled fetch filemode + FI; +(***************************************) + PER; + write last line if necessary. + +initialize fetch filemode: + REAL VAR real cluster size := real (cluster size); + TEXT VAR buffer := ""; + forget (file space); + file space := nilspace; + file := sequential file (output, file space); + init cr lf ff const. + +init cr lf ff const: + TEXT VAR cr, lf, ff; + SELECT codetype OF + CASE ascii, ascii german, atari st: cr := ""13""; lf := ""10""; ff := ""12"" + CASE transparent: cr := ""13""; lf := ""10""; ff := ""12"" + CASE ebcdic: cr := ""13""; lf := "%"; ff := ""12"" + END SELECT; + TEXT CONST select buffer := cr + lf + ff; + TEXT CONST min line end char := code (min (code (cr), min (code (lf), code (ff)))), + max line end char := code (max (code (cr), max (code (lf), code (ff)))). + +get text of act cluster: + fetch next cluster (cluster space, first non dummy ds page); + buffer CAT text (cluster, 1, valid buffer length); + file rest DECR real cluster size; + IF seven bit code + THEN cancel bit 8 + FI; + IF ctrl z end + THEN test ctrl z + FI; + INT CONST bufferlength := LENGTH buffer. + +ctrl z end: + (code type = ascii) OR (code type = ascii german). + +seven bit code: + code type = ascii OR code type = ascii german. + +valid buffer length: + int (min (file rest, real cluster size)). + +cancel bit 8: + INT VAR set pos := pos (buffer, "", ""255"", 1); + WHILE set pos > 0 REP + replace (buffer, set pos, seven bit char); + set pos := pos (buffer, "", ""255"", set pos + 1) + PER. + +seven bit char: + code (code (buffer SUB set pos) AND 127). + +test ctrl z: + IF pos (buffer, ctrl z) > 0 + THEN file rest := 0.0; + buffer := subtext (buffer, 1, pos (buffer, ctrl z) - 1) + FI. + +write lines: + INT VAR begin pos := 1, end pos; + next cr lf ff pos; + WHILE end pos > 0 REP + execute char and get new pos pointer; + next cr lf ff pos + PER; + compress buffer. + +next cr lf ff pos: + end pos := pos (buffer, min line end char, max line end char, begin pos); + WHILE no line end char REP + end pos := pos (buffer, min line end char, max line end char, end pos + 1) + PER. + +no line end char: + (end pos > 0) AND (pos (select buffer, buffer SUB end pos) = 0). + +compress buffer: + buffer := subtext (buffer, begin pos). + +execute char and get new pos pointer: + SELECT pos (select buffer, buffer SUB end pos) OF + CASE 1: execute cr + CASE 2: execute lf + CASE 3: execute ff + END SELECT. + +execute cr: + IF (end pos = bufferlength) AND (file rest > 0.0) + THEN compress buffer; + LEAVE write lines + FI; + write line (subtext (buffer, begin pos, end pos - 1), code type); + IF (buffer SUB (end pos + 1)) = lf + THEN begin pos := end pos + 2 + ELSE begin pos := end pos + 1 + FI. + +execute ff: + write line (subtext (buffer, begin pos, end pos - 1), code type); + putline (file, page cmd); + begin pos := end pos + 1. + +execute lf: + IF (end pos = bufferlength) AND (file rest > 0.0) + THEN compress buffer; + LEAVE write lines + FI; + write line (subtext (buffer, begin pos, end pos - 1), code type); + IF (buffer SUB (end pos + 1)) = cr + THEN begin pos := end pos + 2 + ELSE begin pos := end pos + 1 + FI. + +write last line if necessary: + IF buffer <> "" + THEN end pos := LENGTH buffer + 1; + write line (subtext (buffer, begin pos, end pos - 1), code type) + FI. + +END PROC enabled fetch filemode; + +PROC write line (TEXT CONST line, INT CONST code type): + TEXT VAR result; + SELECT code type OF + CASE ascii: ascii conversion + CASE ascii german: ascii german conversion + CASE atari st: atari st conversion + CASE transparent: putline (file, line) + CASE ebcdic: ebcdic conversion + END SELECT. + +ascii conversion: + expand tabs; + replace steuerzeichen; + putline (file, result). + +ascii german conversion: + expand tabs; + replace steuerzeichen; + replace ascii german umlaute; + putline (file, result). + +atari st conversion: + expand tabs; + replace steuerzeichen; + replace atari st umlaute; + putline (file, result). + +replace ascii german umlaute: + change all (result, "[", ""); + change all (result, "\", ""); + change all (result, "]", ""); + change all (result, "{", ""); + change all (result, "|", ""); + change all (result, "}", ""); + change all (result, "~", ""). + +replace atari st umlaute: + change all (result, ""142"", ""); + change all (result, ""153"", ""); + change all (result, ""154"", ""); + change all (result, ""132"", ""); + change all (result, ""148"", ""); + change all (result, ""129"", ""); + change all (result, ""158"", ""). + +expand tabs: + result := line; + INT VAR tab pos := pos (result, tab); + WHILE tab pos > 0 REP + expand tab; + tab pos := pos (result, tab) + PER. + +expand tab: + result := subtext (result, 1, tab pos - 1) + (8 - ((tab pos - 1)) MOD 8) * " " + + subtext (result, tab pos + 1). + +replace steuerzeichen: + INT VAR position := pos (result, ""0"", ""31"", 1); + WHILE position > 0 REP + TEXT VAR char := result SUB position; + change all (result, char, "#" + int code + "#"); + position := pos (result, ""0"", ""31"", position) + PER. + +ebcdic conversion: + result := line; + ebcdic to eumel with substitution (result); + putline (file, result). + +int code: + (3 - LENGTH text (code (char))) * "0" + text (code (char)). + +END PROC write line; + +PROC fetch rowtextmode (DATASPACE VAR file space, + TEXT CONST name): + disable stop; + cluster space := nilspace; + cluster := cluster space; + enabled fetch rowtextmode (file space, name); + forget (cluster space). + +END PROC fetch rowtextmode; + +PROC enabled fetch rowtextmode (DATASPACE VAR file space, + TEXT CONST name): + enable stop; + open fetch (name, file rest, next cluster no); + initialize fetch rowtext mode; + WHILE next cluster no >= 0 REP + fetch next cluster (cluster space, first non dummy ds page); + cluster struct.size INCR 1; + IF file rest < real cluster size + THEN cluster struct.cluster row [cluster struct.size] + := text (cluster, 1, int (file rest)); + file rest := 0.0 + ELSE cluster struct.cluster row [cluster struct.size] := text (cluster, 1, cluster size); + file rest DECR real cluster size + FI + PER. + +initialize fetch row text mode: + forget (file space); + file space := nilspace; + cluster struct := file space; + type (file space, row text type); + REAL VAR real cluster size := real (cluster size); + cluster struct.size := 0. + +END PROC enabled fetch rowtext mode; + +PROC fetch ds mode (DATASPACE VAR ds, TEXT CONST name): + enable stop; + open fetch (name, file rest, next cluster no); + init fetch dsmode; + WHILE next cluster no >= 0 REP + fetch next cluster (ds, ds block no); + ds block no INCR sectors per cluster; + PER. + +init fetch dsmode: + forget (ds); + ds := nilspace; + INT VAR ds block no := 2. + +END PROC fetch ds mode; + +PROC check file (TEXT CONST name): + disable stop; + cluster space := nilspace; + cluster := cluster space; + enabled check file (name); + forget (cluster space). + +END PROC check file; + +PROC enabled check file (TEXT CONST name): + enable stop; + open fetch (name, file rest, next cluster no); + WHILE next cluster no >= 0 REP + fetch next cluster (cluster space, first non dummy ds page) + PER. + +END PROC enabled check file; + +PROC fetch next cluster (DATASPACE VAR fetch space, INT CONST first page): + read disk cluster (fetch space, first page, next cluster no); + next cluster no := next fetch cluster no. + +END PROC fetch next cluster; + +END PACKET fetch; diff --git a/system/dos/1986/src/files.dos b/system/dos/1986/src/files.dos new file mode 100644 index 0000000..0dd792f --- /dev/null +++ b/system/dos/1986/src/files.dos @@ -0,0 +1,23 @@ +eumel-ebcdic + sub +open +block i/o +cluster +name conversion +eu disk descriptor.fd +disk descriptor.dos.fd +fat and dir.dos.fd +eu disk descriptor.hd +disk descriptor.dos.hd +fat and dir.dos.hd +fetch +save +disk manager +manager/M.dos.fd +manager/M.dos.hd +table thes.dos +252 +253 +254 +255 +shard interface + diff --git a/system/dos/1986/src/gen.dos b/system/dos/1986/src/gen.dos new file mode 100644 index 0000000..5493272 --- /dev/null +++ b/system/dos/1986/src/gen.dos @@ -0,0 +1,99 @@ +(* 28.02.88, DOS Inserter HD/FD *) +TASK VAR fd, hd ; +IF NOT exists ("files.dos") THEN fetch ("files.dos", archive) FI ; +IF highest entry (ALL "files.dos" - all) > 0 + THEN fetch (ALL "files.dos" - all, archive) ; +FI ; +forget ("files.dos", quiet) ; +forget ("gen.dos", quiet) ; +release (archive) ; +ins ("eumel-ebcdic + sub") ; +ins ("open") ; +ins ("name conversion") ; +begin ("FD", PROC fd start, fd) ; +begin ("HD", PROC hd start, hd) ; +globalmanager ; + +PROC ins (TEXT CONST name) : + insert (name) ; + forget (name, quiet) +ENDPROC ins ; + +PROC hd start : + command dialogue (FALSE) ; + + fetch ("eu disk descriptor.hd") ; + erase ("eu disk descriptor.hd") ; + fetch ("disk descriptor.dos.hd") ; + erase ("disk descriptor.dos.hd") ; + fetch ("cluster") ; + fetch ("block i/o") ; + fetch ("fat and dir.dos.hd") ; + erase ("fat and dir.dos.hd") ; + fetch ("fetch") ; + fetch ("save") ; + fetch ("disk manager") ; + fetch ("manager/M.dos.hd") ; + erase ("manager/M.dos.hd") ; (* fetch beendet signalieren *) + + IF NOT exists ("manager/M.dos.fd", father) (* FD auch fertig ? *) + THEN erase ("block i/o") ; + erase ("cluster") ; + erase ("fetch") ; + erase ("save") ; + erase ("disk manager") + FI ; + + ins ("eu disk descriptor.hd") ; + ins ("disk descriptor.dos.hd") ; + ins ("cluster") ; + ins ("block i/o") ; + ins ("fat and dir.dos.hd") ; + ins ("fetch") ; + ins ("save") ; + ins ("disk manager") ; + ins ("manager/M.dos.hd") ; + do ("dos manager") +ENDPROC hd start ; + +PROC fd start : + disablestop ; + command dialogue (FALSE) ; + fetch ("table thes.dos") ; + erase ("table thes.dos") ; + fetch (ALL "table thes.dos") ; + erase (ALL "table thes.dos") ; + fetch ("eu disk descriptor.fd") ; + erase ("eu disk descriptor.fd") ; + fetch ("disk descriptor.dos.fd") ; + erase ("disk descriptor.dos.fd") ; + fetch ("cluster") ; + fetch ("block i/o") ; + fetch ("fat and dir.dos.fd") ; + erase ("fat and dir.dos.fd") ; + fetch ("fetch") ; + fetch ("save") ; + fetch ("disk manager") ; + fetch ("manager/M.dos.fd") ; + erase ("manager/M.dos.fd") ; (* fetch beendet signalieren *) + + IF NOT exists ("manager/M.dos.hd", father) (* HD auch fertig ? *) + THEN erase ("block i/o") ; + erase ("cluster") ; + erase ("fetch") ; + erase ("save") ; + erase ("disk manager") + FI ; + + ins ("eu disk descriptor.fd") ; + ins ("disk descriptor.dos.fd") ; + ins ("cluster") ; + ins ("block i/o") ; + ins ("fat and dir.dos.fd") ; + ins ("fetch") ; + ins ("save") ; + ins ("disk manager") ; + ins ("manager/M.dos.fd") ; + do ("dos manager") +ENDPROC fd start ; + diff --git a/system/dos/1986/src/manager-M.dos.fd b/system/dos/1986/src/manager-M.dos.fd new file mode 100644 index 0000000..601d521 --- /dev/null +++ b/system/dos/1986/src/manager-M.dos.fd @@ -0,0 +1,198 @@ +PACKET dos manager multi DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + provide channel, (* 25.03.86 *) + dos manager: + +LET std archive channel = 31, + + ack = 0, + second phase ack = 5, + false code = 6, + + fetch code = 11, + save code = 12, + exists code = 13, + erase code = 14, + list code = 15, + all code = 17, + clear code = 18, + reserve code = 19, + free code = 20, + check read code = 22, + + quote = """"; + +BOUND STRUCT (TEXT name, pass) VAR msg; + +TASK VAR order task; + +INT VAR dos channel; + +REAL VAR last access time := 0.0; + +TASK VAR disk owner := niltask; + +PROC provide channel (INT CONST channel): + dos channel := channel + +END PROC provide channel; + +(*COND FLOPPY*) +provide channel (std archive channel); +(*ENDCOND*) + +(*COND HDU +provide channel (29) +ENDCOND*) + +PROC dos manager: + dos manager (dos channel) + +END PROC dos manager; + +PROC dos manager (INT CONST channel): +(*COND FLOPPY*) + load shard interface table; +(*ENDCOND*) + dos channel := channel; + task password ("-"); + global manager + (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) dos manager) + +END PROC dos manager; + +PROC dos manager (DATASPACE VAR ds, INT CONST order code, phase, + TASK CONST from task): + enable stop; + order task := from task; + msg := ds; + IF NOT (order task = disk owner) AND + order code <> free code AND order code <> reserve code + THEN errorstop ("DOS nicht angemeldet") + FI; + SELECT order code OF + CASE fetch code : fetch file + CASE save code : save file + CASE erase code : erase file + CASE clear code : clear disk + CASE exists code : exists file + CASE list code : list disk + CASE all code : deliver directory + CASE reserve code : reserve + CASE free code : free + CASE check read code: check + OTHERWISE errorstop ("unbekannter Auftrag fr Task: " + name (myself)) + END SELECT. + +fetch file: + disk fetch (msg.name, ds); + manager ok (ds). + +check: + disk check (msg.name); + manager message (expanded name (msg.name, TRUE) + " ohne Fehler gelesen"). + +save file: + IF phase = 1 + THEN save first phase + ELSE save second phase + FI. + +save first phase: + BOOL VAR overwrite question; + disk save first phase (msg.name, overwrite question); + IF overwrite question + THEN manager question (expanded name (msg.name, FALSE) + " auf der MS-DOS Disk ueberschreiben") + ELSE send (order task, second phase ack, ds) + FI. + +save second phase: + disable stop; + disk save second phase (ds); + forget (ds) ; + ds := nilspace ; + enable stop; + manager ok (ds). + +clear disk: + IF NOT (from task = disk owner) + THEN error stop ("DOS nicht angemeldet") + FI; + IF phase = 1 + THEN manager question ("Diskette loeschen") + ELSE disk clear; + manager ok (ds) + FI. + +erase file: + IF disk exists (msg.name) + THEN IF phase = 1 + THEN manager question (expanded name (msg.name, TRUE) + " auf der MS-DOS Disk loeschen") + ELSE disk erase (msg.name); + manager ok (ds) + FI + ELSE manager message ("die Datei " + expanded name (msg.name, TRUE) + " gibt es nicht auf der MS-DOS Disk") + FI. + +exists file: + IF disk exists (msg.name) + THEN manager ok (ds) + ELSE send (order task, false code, ds) + FI. + +list disk: + disk list (ds); + manager ok (ds). + +deliver directory: + forget (ds); + ds := nilspace; + BOUND THESAURUS VAR all names := ds; + all names := disk all; + manager ok (ds). + +reserve: + IF reserve or free permitted + THEN do continue channel; + disk owner := from task; + disk reserve (msg.name); + manager ok (ds) + ELSE errorstop ("Archivlaufwerk wird von Task """+ name (disk owner) + """ benutzt") + FI. + +do continue channel: + IF channel <> dos channel + THEN continue channel (dos channel) + FI. + +reserve or free permitted : + from task = disk owner OR last access more than five minutes ago + OR disk owner = niltask OR NOT + (exists (disk owner) OR station(disk owner) <> station (myself)). + +last access more than five minutes ago : + abs (last access time - clock (1)) > 300.0. + +free: + IF reserve or free permitted + THEN disk free; + disk owner := niltask; + break (quiet); + manager ok (ds) + ELSE manager message ("DOS nicht angemeldet") + FI. + +END PROC dos manager; + +PROC manager ok (DATASPACE VAR ds): + send (order task, ack, ds); + last access time := clock (1). + +END PROC manager ok; + +TEXT PROC expanded name (TEXT CONST name, BOOL CONST status): + text (quote + adapted name (name, status) + quote, 14) + +END PROC expanded name; + +END PACKET dos manager multi; diff --git a/system/dos/1986/src/manager-M.dos.hd b/system/dos/1986/src/manager-M.dos.hd new file mode 100644 index 0000000..5eb97c7 --- /dev/null +++ b/system/dos/1986/src/manager-M.dos.hd @@ -0,0 +1,198 @@ +PACKET dos manager multi DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + provide channel, (* 25.03.86 *) + dos manager: + +LET std archive channel = 31, + + ack = 0, + second phase ack = 5, + false code = 6, + + fetch code = 11, + save code = 12, + exists code = 13, + erase code = 14, + list code = 15, + all code = 17, + clear code = 18, + reserve code = 19, + free code = 20, + check read code = 22, + + quote = """"; + +BOUND STRUCT (TEXT name, pass) VAR msg; + +TASK VAR order task; + +INT VAR dos channel; + +REAL VAR last access time := 0.0; + +TASK VAR disk owner := niltask; + +PROC provide channel (INT CONST channel): + dos channel := channel + +END PROC provide channel; + +(*COND FLOPPY +provide channel (std archive channel); +ENDCOND*) + +(*COND HDU*) +provide channel (29) +(*ENDCOND*) + +PROC dos manager: + dos manager (dos channel) + +END PROC dos manager; + +PROC dos manager (INT CONST channel): +(*COND FLOPPY + load shard interface table; +ENDCOND*) + dos channel := channel; + task password ("-"); + global manager + (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) dos manager) + +END PROC dos manager; + +PROC dos manager (DATASPACE VAR ds, INT CONST order code, phase, + TASK CONST from task): + enable stop; + order task := from task; + msg := ds; + IF NOT (order task = disk owner) AND + order code <> free code AND order code <> reserve code + THEN errorstop ("DOS nicht angemeldet") + FI; + SELECT order code OF + CASE fetch code : fetch file + CASE save code : save file + CASE erase code : erase file + CASE clear code : clear disk + CASE exists code : exists file + CASE list code : list disk + CASE all code : deliver directory + CASE reserve code : reserve + CASE free code : free + CASE check read code: check + OTHERWISE errorstop ("unbekannter Auftrag fr Task: " + name (myself)) + END SELECT. + +fetch file: + disk fetch (msg.name, ds); + manager ok (ds). + +check: + disk check (msg.name); + manager message (expanded name (msg.name, TRUE) + " ohne Fehler gelesen"). + +save file: + IF phase = 1 + THEN save first phase + ELSE save second phase + FI. + +save first phase: + BOOL VAR overwrite question; + disk save first phase (msg.name, overwrite question); + IF overwrite question + THEN manager question (expanded name (msg.name, FALSE) + " auf der MS-DOS Disk ueberschreiben") + ELSE send (order task, second phase ack, ds) + FI. + +save second phase: + disable stop; + disk save second phase (ds); + forget (ds) ; + ds := nilspace ; + enable stop; + manager ok (ds). + +clear disk: + IF NOT (from task = disk owner) + THEN error stop ("DOS nicht angemeldet") + FI; + IF phase = 1 + THEN manager question ("Diskette loeschen") + ELSE disk clear; + manager ok (ds) + FI. + +erase file: + IF disk exists (msg.name) + THEN IF phase = 1 + THEN manager question (expanded name (msg.name, TRUE) + " auf der MS-DOS Disk loeschen") + ELSE disk erase (msg.name); + manager ok (ds) + FI + ELSE manager message ("die Datei " + expanded name (msg.name, TRUE) + " gibt es nicht auf der MS-DOS Disk") + FI. + +exists file: + IF disk exists (msg.name) + THEN manager ok (ds) + ELSE send (order task, false code, ds) + FI. + +list disk: + disk list (ds); + manager ok (ds). + +deliver directory: + forget (ds); + ds := nilspace; + BOUND THESAURUS VAR all names := ds; + all names := disk all; + manager ok (ds). + +reserve: + IF reserve or free permitted + THEN do continue channel; + disk owner := from task; + disk reserve (msg.name); + manager ok (ds) + ELSE errorstop ("Archivlaufwerk wird von Task """+ name (disk owner) + """ benutzt") + FI. + +do continue channel: + IF channel <> dos channel + THEN continue channel (dos channel) + FI. + +reserve or free permitted : + from task = disk owner OR last access more than five minutes ago + OR disk owner = niltask OR NOT + (exists (disk owner) OR station(disk owner) <> station (myself)). + +last access more than five minutes ago : + abs (last access time - clock (1)) > 300.0. + +free: + IF reserve or free permitted + THEN disk free; + disk owner := niltask; + break (quiet); + manager ok (ds) + ELSE manager message ("DOS nicht angemeldet") + FI. + +END PROC dos manager; + +PROC manager ok (DATASPACE VAR ds): + send (order task, ack, ds); + last access time := clock (1). + +END PROC manager ok; + +TEXT PROC expanded name (TEXT CONST name, BOOL CONST status): + text (quote + adapted name (name, status) + quote, 14) + +END PROC expanded name; + +END PACKET dos manager multi; diff --git a/system/dos/1986/src/name conversion b/system/dos/1986/src/name conversion new file mode 100644 index 0000000..1f9a797 --- /dev/null +++ b/system/dos/1986/src/name conversion @@ -0,0 +1,77 @@ +PACKET name conversion DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + adapted name: (* 20.02.86 *) + +LET upper case chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$#&@!(){}", + lower case chars = "abcdefghijklmnopqrstuvwxyz"; + +TEXT VAR name pre, + name post, + new, + char; + +INT VAR point pos, + count; + +TEXT PROC adapted name (TEXT CONST eu name, BOOL CONST read modus): + enable stop; + point pos := pos (eu name, "."); + IF name extension exists + THEN changed name with extension + ELSE changed name without extension + FI. + +name extension exists: + point pos > 0. + +changed name with extension: + name pre := compress (subtext (eu name, 1, point pos - 1)); + name post := compress (subtext (eu name, point pos + 1)); + IF LENGTH name pre = 0 OR LENGTH name pre > 8 OR LENGTH name post > 3 + THEN error + FI; + IF LENGTH name post = 0 + THEN new name (name pre, read modus) + ELSE new name (name pre, read modus) + "." + + new name (name post, read modus) + FI. + +changed name without extension: + IF LENGTH eu name > 8 OR LENGTH euname < 1 + THEN error + FI; + new name (eu name, read modus). + +error: + errorstop ("Unzulssiger Name"). + +END PROC adapted name; + +TEXT PROC new name (TEXT CONST old name, BOOL CONST read modus): + new := ""; + FOR count FROM 1 UPTO LENGTH old name REP + convert char + PER; + new. + +convert char: + char := old name SUB count; + IF is lower case char + THEN new CAT (upper case chars SUB string pos) + ELIF is upper case char OR read modus + THEN new CAT char + ELSE error stop ("Unzulssiger Name") + FI. + +is lower case char: + pos (lower case chars, char) > 0. + +is upper case char: + pos (upper case chars, char) > 0. + +string pos: + pos (lower case chars, char). + +END PROC new name; + +END PACKET name conversion; diff --git a/system/dos/1986/src/open b/system/dos/1986/src/open new file mode 100644 index 0000000..92e81e9 --- /dev/null +++ b/system/dos/1986/src/open @@ -0,0 +1,51 @@ +PACKET open DEFINES (* Copyright (C) 1986 *) + (* Frank Klapper *) + open action, (* 20.03.86 *) + close action, + action opened, + action closed, + init check rerun, + check rerun: + +BOOL VAR open; +INT VAR old session; + +INITFLAG VAR packet := FALSE; + +PROC open action: + open := TRUE + +END PROC open action; + +PROC close action: + open := FALSE + +END PROC close action; + +BOOL PROC action opened: + IF NOT initialized (packet) + THEN close action + FI; + open + +END PROC action opened; + +BOOL PROC action closed: + NOT action opened + +END PROC action closed; + +PROC init check rerun: + old session := session + +END PROC init check rerun; + +PROC check rerun: + IF session <> old session + THEN close action; + error stop ("Diskettenzugriff im RERUN") + FI. + +END PROC check rerun; + +END PACKET open; diff --git a/system/dos/1986/src/save b/system/dos/1986/src/save new file mode 100644 index 0000000..89d1108 --- /dev/null +++ b/system/dos/1986/src/save @@ -0,0 +1,273 @@ +PACKET save DEFINES (* Copyright (C) 1985 *) + (* Frank Klapper *) + (* 07.05.86 *) + save filemode, + save rowtextmode, + save dsmode: + +LET ascii = 1, + ascii german = 2, + transparent = 3, + ebcdic = 4, + atari st = 10; + +LET ascii ctrl z = ""26""; + +LET row text mode length = 4000; + +CLUSTER VAR cluster; + +DATASPACE VAR cluster space; + +BOUND STRUCT (INT size, + ROW row text mode length TEXT cluster row) VAR cluster struct; + +REAL VAR storage; +TEXT VAR cr lf, ff; +TEXT VAR buffer; + +PROC save filemode (DATASPACE CONST file space, + TEXT CONST name, + INT CONST code type): + disable stop; + cluster space := nilspace; + cluster := cluster space; + enable save filemode (file space, name, code type); + buffer := ""; + forget (cluster space). + +END PROC save filemode; + +PROC enable save filemode (DATASPACE CONST file space, + TEXT CONST name, + INT CONST code type): + enable stop; + open save (name); + init save filemode; + INT VAR line no; + FOR line no FROM 1 UPTO lines (file) REP + to line (file, line no); + buffer cat file line; + WHILE LENGTH buffer >= cluster size REP + copy buffer to cluster; + write disk cluster (cluster space, first non dummy ds page, next save cluster no); + remember rest + PER + PER; + cat ctrl z if necessary; + write rest; + close save (storage). + +init save filemode: + storage := 0.0; + FILE VAR file := sequential file (modify, file space); + SELECT code type OF + CASE ascii, ascii german, atari st, transparent: cr lf := ""13""10""; ff := ""12"" + CASE ebcdic: cr lf := ""13"%"; ff := ""12"" + END SELECT; + buffer := "". + +buffer cat file line: + exec (PROC (TEXT CONST, INT CONST) cat adapted line, file, code type). + +copy buffer to cluster: + write text (cluster, buffer); + storage INCR real (min (cluster size, LENGTH buffer)). + +remember rest: + buffer := subtext (buffer, cluster size + 1). + +write rest: + WHILE buffer <> "" + REP copy buffer to cluster; + write disk cluster (cluster space, first non dummy ds page, next save cluster no); + remember rest + PER. + +cat ctrl z if necessary: + IF code type <> ebcdic + THEN buffer CAT ascii ctrl z + FI. + +END PROC enable save filemode; + +PROC cat adapted line (TEXT VAR line, INT CONST code type): + IF subtext (line, 1, 6) = "#page#" + THEN buffer CAT ff; + LEAVE cat adapted line + FI; + SELECT code type OF + CASE transparent: (* no operation *) + CASE ascii: change eumel print chars; ascii change + CASE ascii german: change eumel print chars; ascii german change + CASE atari st: change eumel print chars; atari st change + CASE ebcdic: change eumel print chars; eumel to ebcdic with substitution (line) + END SELECT; + buffer CAT line; + buffer CAT cr lf. + +change eumel print chars: + INT VAR char pos := pos (line, ""220"", ""223"", 1); + WHILE char pos > 0 REP + replace (line, char pos, std char); + char pos := pos (line, ""220"", ""223"", char pos + 1) + PER. + +std char: + SELECT code (line SUB char pos) OF + CASE 220: "k" + CASE 221: "-" + CASE 222: "#" + CASE 223: " " + OTHERWISE "" + END SELECT. + +ascii change: + change all (line, ""251"", "#251#"); + char pos := pos (line, "", "", 1); + WHILE char pos > 0 REP + line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1); + char pos := pos (line, "", "", char pos + 1) + PER. + +ascii german change: + char pos := pos (line, "[", "]", 1); + WHILE char pos > 0 REP + line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1); + char pos := pos (line, "[", "]", char pos + 1) + PER; + char pos := pos (line, "{", "}", 1); + WHILE char pos > 0 REP + line := subtext (line, 1, char pos - 1) + ersatzdarstellung + subtext (line, char pos + 1); + char pos := pos (line, "{", "}", char pos + 1) + PER; + change all (line, ""251"", "~"); + char pos := pos (line, "", "", 1); + WHILE char pos > 0 REP + replace (line, char pos, umlaut in ascii german); + char pos := pos (line, "", "", char pos + 1) + PER. + +atari st change: + change all (line, "", ""158""); + char pos := pos (line, "", "", 1); + WHILE char pos > 0 REP + replace (line, char pos, umlaut in atari st); + char pos := pos (line, "", "", char pos + 1) + PER. + +ersatzdarstellung: + TEXT VAR char code := text (code (line SUB char pos)); + "#" + (3 - LENGTH char code) * "0" + char code + "#". + +umlaut in ascii german: + SELECT code (line SUB char pos) OF + CASE 214: "[" + CASE 215: "\" + CASE 216: "]" + CASE 217: "{" + CASE 218: "|" + CASE 219: "}" + OTHERWISE "" + END SELECT. + +umlaut in atari st: + SELECT code (line SUB char pos) OF + CASE 214: ""142"" + CASE 215: ""153"" + CASE 216: ""154"" + CASE 217: ""132"" + CASE 218: ""148"" + CASE 219: ""129"" + OTHERWISE "" + END SELECT. + +END PROC cat adapted line; + +PROC save rowtextmode (DATASPACE CONST space, + TEXT CONST name): + disable stop; + cluster space := nilspace; + cluster := cluster space; + enable save rowtext mode (space, name); + forget (cluster space). + +END PROC save rowtextmode; + +PROC enable save rowtextmode (DATASPACE CONST space, + TEXT CONST name): + enable stop; + open save (name); + init save row textmode; + WHILE line no < cluster struct.size REP + fill buffer; + copy buffer to cluster; + write disk cluster (cluster space, first non dummy ds page, next save cluster no); + remember rest + PER; + write rest; + close save (storage). + +init save rowtextmode: + storage := 0.0; + cluster struct := space; + INT VAR line no := 0; + TEXT VAR buffer := "". + +fill buffer: + WHILE line no < cluster struct.size AND NOT buffer full REP + line no INCR 1; + buffer CAT cluster struct.cluster row [line no] + PER. + +buffer full: + LENGTH buffer >= cluster size. + +copy buffer to cluster: + write text (cluster, buffer); + storage INCR real (min (cluster size, LENGTH buffer)). + +remember rest: + buffer := subtext (buffer, cluster size + 1). + +write rest: + WHILE buffer <> "" + REP copy buffer to cluster; + write disk cluster (cluster space, first non dummy ds page, next save cluster no); + remember rest + PER. + +END PROC enable save rowtextmode; + +PROC save ds mode (DATASPACE CONST ds, + TEXT CONST name): + disable stop; + enable save ds mode (ds, name). + +END PROC save ds mode; + +PROC enable save ds mode (DATASPACE CONST ds, + TEXT CONST name): + enable stop; + open save (name); + INT VAR page no := first non dummy ds page; + get last allocated ds page; + WHILE page no <= last allocated ds page REP + write disk cluster (ds, page no, next save cluster no); + page no INCR sectors per cluster + PER; + close save (size). + +get last allocated ds page: + INT VAR last allocated ds page := -1, + i; + FOR i FROM 1 UPTO ds pages (ds) REP + last allocated ds page := next ds page (ds, last allocated ds page) + PER. + +size: + real (last allocated ds page - first non dummy ds page + 1) * 512.0. + +END PROC enable save ds mode; + +END PACKET save; diff --git a/system/dos/1986/src/shard interface b/system/dos/1986/src/shard interface new file mode 100644 index 0000000..67bf654 --- /dev/null +++ b/system/dos/1986/src/shard interface @@ -0,0 +1,19 @@ +; ';' in Spalte 1 kennzeichnet eine Kommentarzeile +; alle Werte mssen durch Blanks getrennt werden +; +;heads: Anzahl der Kpfe, positiv fr cylinderorientiertes Lesen +; negativ fr seitenorientiertes Lesen +; +;size heads tracks first sectors last sector +;===================================================== +320 1 40 1 8 +360 1 40 1 9 +640 -2 40 1 8 +720 -2 40 1 9 +800 2 40 1 10 +1440 -2 80 1 9 +1600 2 80 1 10 +2400 -2 80 1 15 +1232 1 77 0 15 +2464 -2 77 0 15 +; END OF FILE diff --git a/system/dos/1986/src/table thes.dos b/system/dos/1986/src/table thes.dos new file mode 100644 index 0000000..8b254cf --- /dev/null +++ b/system/dos/1986/src/table thes.dos @@ -0,0 +1,5 @@ +shard interface +252 +253 +254 +255 -- cgit v1.2.3