diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:19 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:39 +0100 |
| commit | 98cab31fc3659e33aef260efca55bf9f1753164c (patch) | |
| tree | f1affa84049ef9b268e6c4f521f000478b0f3a8e /system/dos | |
| parent | 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff) | |
| download | eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2 eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip | |
Add source files from Michael
Diffstat (limited to 'system/dos')
26 files changed, 6420 insertions, 0 deletions
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 Binary files differnew file mode 100644 index 0000000..b4369b6 --- /dev/null +++ b/system/dos/1986/src/252 diff --git a/system/dos/1986/src/253 b/system/dos/1986/src/253 Binary files differnew file mode 100644 index 0000000..c7a4494 --- /dev/null +++ b/system/dos/1986/src/253 diff --git a/system/dos/1986/src/254 b/system/dos/1986/src/254 Binary files differnew file mode 100644 index 0000000..f71eeb6 --- /dev/null +++ b/system/dos/1986/src/254 diff --git a/system/dos/1986/src/255 b/system/dos/1986/src/255 Binary files differnew file mode 100644 index 0000000..d21b649 --- /dev/null +++ b/system/dos/1986/src/255 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, " <DIR>");
+(*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, " <DIR>");
+(*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
|