head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @ * @;


56.3
date     93.01.27.13.38.26;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.13.42;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.35.20;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.13.53;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.21.02;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.22.25;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.06.04;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.05.13;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.20.38;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.04.58;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.10.42;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.49.13;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.36.54;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.44.01;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.01.52;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.51.46;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.37.12;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.19.31;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.42.17;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.27.46;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.18.15;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.31.48;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.10.47;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.22.30;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.15.57.47;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.32.44;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.38.59;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.17.59.57;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.38.12;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.22.14;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.51.27;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.17.44;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.12.36.31;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.13.08;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.09.25.56;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.10.01.55;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.43.55;  author bayes;  state Exp;
branches ;
next     21.3;

21.3
date     87.08.15.16.57.30;  author larry;  state Exp;
branches ;
next     21.2;

21.2
date     87.08.13.17.42.37;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.30.23;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.42.03;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.07.59.46;  author jws;  state Exp;
branches ;
next     18.2;

18.2
date     87.05.26.15.28.12;  author bayes;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.14.54.37;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.11.21;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.25.16;  author jws;  state Exp;
branches ;
next     15.2;

15.2
date     87.04.20.16.34.09;  author bayes;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.08.53.47;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.14.51.38;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.12.52;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.00.49;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.26.39;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.33.31;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.13.58.54;  author bayes;  state Exp;
branches ;
next     8.2;

8.2
date     86.12.04.14.43.25;  author jws;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.30.37;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.13.18.50;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.17.21.52;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.16.07.57;  author hal;  state Exp;
branches ;
next     4.3;

4.3
date     86.10.22.19.06.07;  author hal;  state Exp;
branches ;
next     4.2;

4.2
date     86.10.20.14.59.01;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.23.06;  author hal;  state Exp;
branches ;
next     3.2;

3.2
date     86.09.04.17.33.01;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.32.14;  author hal;  state Exp;
branches ;
next     2.6;

2.6
date     86.08.28.12.43.32;  author hal;  state Exp;
branches ;
next     2.5;

2.5
date     86.08.27.12.29.38;  author hal;  state Exp;
branches ;
next     2.4;

2.4
date     86.08.26.16.16.00;  author hal;  state Exp;
branches ;
next     2.3;

2.3
date     86.08.25.10.38.59;  author hal;  state Exp;
branches ;
next     2.2;

2.2
date     86.08.20.16.07.11;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.23.34;  author hal;  state Exp;
branches ;
next     1.19;

1.19
date     86.07.28.08.52.07;  author hal;  state Exp;
branches ;
next     1.18;

1.18
date     86.07.23.18.33.10;  author hal;  state Exp;
branches ;
next     1.17;

1.17
date     86.07.22.16.22.54;  author hal;  state Exp;
branches ;
next     1.16;

1.16
date     86.07.21.16.53.27;  author hal;  state Exp;
branches ;
next     1.15;

1.15
date     86.07.18.14.26.53;  author hal;  state Exp;
branches ;
next     1.14;

1.14
date     86.07.17.17.20.37;  author hal;  state Exp;
branches ;
next     1.13;

1.13
date     86.07.17.08.24.02;  author hal;  state Exp;
branches ;
next     1.12;

1.12
date     86.07.16.10.04.54;  author hal;  state Exp;
branches ;
next     1.11;

1.11
date     86.07.14.08.50.05;  author hal;  state Exp;
branches ;
next     1.10;

1.10
date     86.07.11.14.18.22;  author hal;  state Exp;
branches ;
next     1.9;

1.9
date     86.07.09.08.43.15;  author hal;  state Exp;
branches ;
next     1.8;

1.8
date     86.07.08.18.53.19;  author hal;  state Exp;
branches ;
next     1.7;

1.7
date     86.07.08.08.47.38;  author hal;  state Exp;
branches ;
next     1.6;

1.6
date     86.07.04.10.10.16;  author hal;  state Exp;
branches ;
next     1.5;

1.5
date     86.07.03.11.20.55;  author danm;  state Exp;
branches ;
next     1.4;

1.4
date     86.06.30.20.33.03;  author danm;  state Exp;
branches ;
next     1.3;

1.3
date     86.06.06.18.24.08;  author danm;  state Exp;
branches ;
next     1.2;

1.2
date     86.06.06.13.43.28;  author danm;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.04.08.40.03;  author geli;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@$modcal$

$linenum 5000$
$lines 54$

$partial_eval on$
$allow_packed on$

$range off$
$ovflcheck off$
$debug off$

module hfsalloc;

$search 'hfstuff', 'hfsupport', 'hfscalc', 'hfscache'$

import
    hfstuff,
    hfsupport,
    sysglobals,
    sysdevs,
    iocomasm,
    asm,
    hfscalc,
    hfscache;

export

const
    BMAP_HOLE = -1;             { bmap reading a hole }
    BMAP_ERROR = 0;             { bmap had error }

    no_permission = 0;
    x_permission  = 1;
    w_permission  = 2;
    r_permission  = 4;


type
    bmap_mode = (B_READ, B_WRITE, B_ZWRITE);
    time_stamp_type = (IACC, IMOD, ICHG);
    time_stamp_set = set of time_stamp_type;

    scan_proc = procedure(dp: direntry_ptr_type;
			  offset: integer;
			  anyvar inparams, outparams: integer;
			  var keep_going: boolean);

    pathinfotype = packed record
	ino: integer;
	diroff: integer;
	basename: string255;
	parent_ino: integer;
    end;

    permission_type = integer;

procedure init_hfsalloc;

function get_dbnum(ip: inode_ptr_type;
		   position: integer;
		   rwflag: bmap_mode;
		   length: integer): integer;

function create_file(var filename: string255;
		     mode: integer;
		     pdir: inode_ptr_type;
		     offset, filebytes: integer): inode_ptr_type;

function create_dir(var filename: string255;
		    mode: integer;
		    pdir: inode_ptr_type;
		    offset: integer): integer;

procedure link_file(ip: inode_ptr_type;
		    var filename: string255;
		    pdir: inode_ptr_type;
		    offset: integer);

function change_file_size(ip: inode_ptr_type;
			  size: integer): boolean;

procedure time_stamp(ip: inode_ptr_type;
		     which: time_stamp_set);

procedure scan_dir(pdir: inode_ptr_type;
		   scanner: scan_proc;
		   anyvar inparams, outparams: integer);

function alloc_inode(pdir: inode_ptr_type;
		     mode: integer;
		     bytes: integer): inode_ptr_type;

procedure dealloc_inode(var ip: inode_ptr_type);

procedure enter_file(ip, pdir: inode_ptr_type;
		     var name: string255);

procedure delete_file(ip, pdir: inode_ptr_type;
		      offset: integer);

procedure delete_filename(ip, pdir: inode_ptr_type;
			  var name: string255);

function foundname(var name: string;
		   dir_required: boolean;
		   pdir: inode_ptr_type;
		   var pathinfo: pathinfotype): boolean;

function permission(inodep: inode_ptr_type;
		    perm_needed: permission_type): boolean;

function has_blocks(ip: inode_ptr_type): boolean;

implement

const
    debug = false;

    bytes_per_ptr = 4;
    SINGLE = 0;
    DOUBLE = 1;
    TRIPLE = 2;
    DOT = 0;
    DOTDOT = 1;

type
    blk_type = integer;

    cluster_array_type = packed array[0..8] of shortint;

    fragtbl_type = packed array[0..255] of 0..255;
    fragtbl_ptr_type = ^fragtbl_type;
    fragtbl_array_type = array [1..8] of fragtbl_ptr_type;

    alloc_proc = procedure(ip: inode_ptr_type;
			   cg: integer;
			   bpref: frag_type;
			   size_or_mode: integer;
			   var result: integer);

    dirtemplate_type = array [DOT..DOTDOT] of direntrytype;



var
    around, inside: cluster_array_type;
    fragtbl8, fragtbl124: fragtbl_type;
    fragtbl: fragtbl_array_type;
    dirtemplate: dirtemplate_type;
    prealloc_pref: integer;

{
{ Map of calls
{ BLOCK ALLOCATION FOR READING AND WRITING
{ bmap
{       blkpref
{       realloccg
{               hashalloc(alloccg)
{               fragextend
{               xfree
{                       fragacct
{       alloc
{               hashalloc(alloccg)
{
{ alloccg
{       alloccgblk
{               mapsearch
{       mapsearch
{
{ FILE CREATION
{ create_file
{       maknode
{               dirpref
{               ialloc
{               direnter
{
{ FILE DELETION
{ delete_file
{       unlink
{               dirremove
{               zapinode
{                       itrunc
{                               xfree
{                               indirtrunc
{                                       xfree
{               ifree
{        rmdir
{               dirempty
{               dirremove
{               zapinode
{                       itrunc
{                               xfree
{                               indirtrunc
{                                       xfree
{
{ LINK
{ link_file
{       direnter
{
{ MAKE DIRECTORY
{ create_dir
{       ialloc
{       rdwri
{       direnter
{
{ CLOSE CRUNCH
{ change_file_size
{       itrunc
{       bmap
}


procedure init_hfsalloc;
const
    {
    { Bit patterns for identifying fragments in the block map
    { used as ((map & around) = inside)
    { inside[i] has an i-bit cluster, plus a 0 bit at the end.
    { around[i] is inside[i] with an extra 1 bit on each end.
    { if map & around[i] = inside[i], then there is an i-bit
    { cluster, no larger and no smaller, in map.
    }
    around_def = cluster_array_type[
	hex('03'), hex('07'), hex('0f'), hex('1f'),
	hex('3f'), hex('7f'), hex('ff'), hex('1ff'), hex('3ff')
    ];
    inside_def = cluster_array_type[
	hex('00'), hex('02'), hex('06'), hex('0e'),
	hex('1e'), hex('3e'), hex('7e'), hex('fe'), hex('1fe')
    ];

    {
    { Given a block map bit pattern, the frag tables tell whether a
    { particular size fragment is available.
    { fragtbl8 is for 8 frags/big block
    { fragtbl124 is for 1, 2, or 4
    {
    { fragtbl8 is used as:
    { if ((1 << (size - 1)) & fragtbl[fs^.frag][map]
    {   at least one fragment of the indicated size is available
    {
    { fragtbl124 is similar.  The left 4 bits are for 4 frags/block,
    { the next 2 for 2 frags/block, and the next 1 for 1 frag/block.
    { The rightmost bit is unused.
    {
    { These tables are used by scanc to
    {  quickly find an appropriate fragment.
    }
    fragtbl124_def = fragtbl_type[
	hex('00'), hex('16'), hex('16'), hex('2a'),
	hex('16'), hex('16'), hex('26'), hex('4e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('2a'), hex('3e'), hex('4e'), hex('8a'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('2a'), hex('3e'), hex('3e'), hex('2a'),
	hex('3e'), hex('3e'), hex('2e'), hex('6e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('2a'), hex('3e'), hex('6e'), hex('aa'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('26'), hex('36'), hex('36'), hex('2e'),
	hex('36'), hex('36'), hex('26'), hex('6e'),
	hex('36'), hex('36'), hex('36'), hex('3e'),
	hex('2e'), hex('3e'), hex('6e'), hex('ae'),
	hex('4e'), hex('5e'), hex('5e'), hex('6e'),
	hex('5e'), hex('5e'), hex('6e'), hex('4e'),
	hex('5e'), hex('5e'), hex('5e'), hex('7e'),
	hex('6e'), hex('7e'), hex('4e'), hex('ce'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('3e'), hex('7e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('7e'), hex('be'),
	hex('2a'), hex('3e'), hex('3e'), hex('2a'),
	hex('3e'), hex('3e'), hex('2e'), hex('6e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('2a'), hex('3e'), hex('6e'), hex('aa'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('3e'), hex('7e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('7e'), hex('be'),
	hex('4e'), hex('5e'), hex('5e'), hex('6e'),
	hex('5e'), hex('5e'), hex('6e'), hex('4e'),
	hex('5e'), hex('5e'), hex('5e'), hex('7e'),
	hex('6e'), hex('7e'), hex('4e'), hex('ce'),
	hex('8a'), hex('9e'), hex('9e'), hex('aa'),
	hex('9e'), hex('9e'), hex('ae'), hex('ce'),
	hex('9e'), hex('9e'), hex('9e'), hex('be'),
	hex('aa'), hex('be'), hex('ce'), hex('8a')];

    fragtbl8_def = fragtbl_type[
	hex('00'), hex('01'), hex('01'), hex('02'),
	hex('01'), hex('01'), hex('02'), hex('04'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('02'), hex('03'), hex('04'), hex('08'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('04'), hex('05'), hex('08'), hex('10'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('03'), hex('03'), hex('02'), hex('06'),
	hex('04'), hex('05'), hex('05'), hex('06'),
	hex('08'), hex('09'), hex('10'), hex('20'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('05'), hex('05'), hex('09'), hex('11'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('03'), hex('03'), hex('02'), hex('06'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('02'), hex('03'), hex('06'), hex('0a'),
	hex('04'), hex('05'), hex('05'), hex('06'),
	hex('05'), hex('05'), hex('06'), hex('04'),
	hex('08'), hex('09'), hex('09'), hex('0a'),
	hex('10'), hex('11'), hex('20'), hex('40'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('05'), hex('05'), hex('09'), hex('11'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('03'), hex('03'), hex('03'), hex('07'),
	hex('05'), hex('05'), hex('05'), hex('07'),
	hex('09'), hex('09'), hex('11'), hex('21'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('03'), hex('03'), hex('02'), hex('06'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('02'), hex('03'), hex('06'), hex('0a'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('03'), hex('03'), hex('03'), hex('07'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('06'), hex('07'), hex('0a'), hex('12'),
	hex('04'), hex('05'), hex('05'), hex('06'),
	hex('05'), hex('05'), hex('06'), hex('04'),
	hex('05'), hex('05'), hex('05'), hex('07'),
	hex('06'), hex('07'), hex('04'), hex('0c'),
	hex('08'), hex('09'), hex('09'), hex('0a'),
	hex('09'), hex('09'), hex('0a'), hex('0c'),
	hex('10'), hex('11'), hex('11'), hex('12'),
	hex('20'), hex('21'), hex('40'), hex('80')];

    dirtemplate_def = dirtemplate_type[
	direntrytype[
	    ino: 0,
	    reclen: 32,
	    namlen: 1,
	    name: '.'#0#0#0#0#0#0#0#0#0#0#0#0#0,
	    pad: #0#0#0#0#0#0#0#0#0#0
	],
	direntrytype[
	    ino: 0,
	    reclen: DIRBLKSIZE - 32,
	    namlen: 2,
	    name: '..'#0#0#0#0#0#0#0#0#0#0#0#0,
	    pad: #0#0#0#0#0#0#0#0#0#0
	]
    ];

begin
    around := around_def;
    inside := inside_def;

    fragtbl124 := fragtbl124_def;
    fragtbl8 := fragtbl8_def;

    fragtbl[1] := fragtbl_ptr_type(addr(fragtbl124));
    fragtbl[2] := fragtbl_ptr_type(addr(fragtbl124));
    fragtbl[3] := nil;
    fragtbl[4] := fragtbl_ptr_type(addr(fragtbl124));
    fragtbl[5] := nil;
    fragtbl[6] := nil;
    fragtbl[7] := nil;
    fragtbl[8] := fragtbl_ptr_type(addr(fragtbl8));

    dirtemplate := dirtemplate_def;

end;

{---------------------------------------------------------------}
{
{ ERROR AND MISCELLANEOUS ROUTINES
}

{
{ Something corrupt in the file system.
}
procedure hfs_corrupt(fs: super_block_ptr_type);
begin
$if debug$
    xreport('HFS CORRUPT');
$end$
    fs^.clean := chr(FS_NOTOK);
    fs^.fmod := FS_MODIFIED;
    put_superblock(fs, [immediate]);
    set_corrupt;
    ioresult := ord(icorrupt);
end;

{
{ Fserr prints the name of a file system with an error diagnostic.
{
{ The form of the error message is:
{       fs: error message
}
$if debug$
procedure fserr(fs: super_block_ptr_type; cp: string255);
begin
	writeln(fs^.fname, ': ', cp);
end;
$end$

{
{ Check that a specified block number is in range.
}
function badblock(fs: super_block_ptr_type;
		  bn: frag_type): boolean;
var
    bad: boolean;
begin
    bad := (bn >= fs^.size);
    if bad then begin
	hfs_corrupt(fs);
$if debug$
	writeln('bad block ', bn:1);
	fserr(fs, 'bad block');
$end$
    end;
    badblock := bad;
end;

{
{ Zeroes the disk at fragnum for size bytes.
{ For directories and indirect blocks.
{ Warning: if user data goes through here, we must
{ either put ALL user data through the cache, or we must
{ immediately invalidate the cache buffer.
{ Zeroes from the LAST cache blk to the FIRST, so that the
{ first block is sure to be left in the cache.
}
procedure zero_data(fragnum: frag_type;
		    size: integer);
label
    999;
var
    ip: cache_blk_ptr_type;
    cp: ^char;
    offset: integer;
    i, bytes: integer;
begin
$if debug$
    xreport('ZERO DATA');
$end$
    { set offset to highest cache blk multiple < size }
    offset := rounddownp2(size-1, cache_blk_size);
    while offset >= 0 do begin
	{ bytes = number of bytes this transfer }
	if size - offset < cache_blk_size then begin
	    bytes := size - offset;
	    ip := get_datablk(fragnum, offset);
	end
	else begin
	    bytes := cache_blk_size;
	    ip := get_edatablk(fragnum, offset);
	end;
	cp := addr(ip^);
	for i := 1 to bytes do begin
	    cp^ := chr(0);
	    cp := addr(cp^, 1);
	end;
	put_datablk(ip, [release,dirty,immediate]);
	offset := offset - cache_blk_size;
    end;
999:
end;


{
{ Copies size bytes from fragment ofrag to fragment nfrag.
{ Copies through cache.  Use copy_user_data to go around cache.
{ After copy, source data blocks now free on disc, so don't leave
{ them valid in the cache.
}
procedure copy_control_data(ofrag, nfrag: frag_type;
			    size: integer);
label
    999;
type
    charptr = ^char;
var
    fp, tp: cache_blk_ptr_type;
    offset: integer;
    bytes: integer;
begin
$if debug$
    xreport('COPY CONTROL DATA');
$end$
    offset := 0;
    while offset < size do begin
	fp := get_datablk(ofrag, offset);
	if size - offset < cache_blk_size then begin
	    bytes := size - offset;
	    tp := get_datablk(nfrag, offset);
	end
	else begin
	    bytes := cache_blk_size;
	    tp := get_edatablk(nfrag, offset);
	end;
	moveleft(fp^, tp^, bytes);
	put_datablk(fp, [release,invalid]);
	put_datablk(tp, [release,dirty,immediate]);
	offset := offset + cache_blk_size;
    end;
999:
end;

{
{ stamp the time on an inode
{ there are 3 time fields:
{       atime -- file read
{       mtime -- file modified
{       ctime -- inode changed
{ we now set these times when the routine is called
{ we could set flags in the inode, and set the times only when we
{ go to disc.
{ To save inode writes, we don't update IACC unless it's more than
{ 10 seconds old.
}
procedure time_stamp(ip: inode_ptr_type;
		     which: time_stamp_set);
var
    now: integer;
    isdirty: boolean;
begin
    now := sysgmttime;
    with ip^ do begin
	if IACC in which then begin
	    isdirty := (now - atime > 10);
	    atime := now;
	end;
	if ICHG in which then begin
	    isdirty := true;
	    ctime := now;
	end;
	if IMOD in which then begin
	    isdirty := true;
	    mtime := now;
	end;
    end;
    if isdirty then
	put_inode(ip, [dirty]);
end;

$if debug$
procedure panic(str: string255);
begin
    writeln('******************************************');
    writeln('HFS PANIC: ', str);
    writeln('******************************************');
end;
$end$


{-------------------------------------------------------------------}
{
{ BLOCK OPERATIONS ON THE BITMAP
}

{
{ See if block at address 'h' is free.
}
function isblock(fs: super_block_ptr_type;
		 anyvar cp: freemap_type; h: blk_type): boolean;
label
    999;
var
    mask: integer;
    index: integer;
begin
    case fs^.frag of
      8:
	begin
	    isblock := cp[h] = hex('ff');
	    goto 999;
	end;

      4:
	begin
	    {
	    { mask = 0x0f << ((h & 0x1) << 2);
	    { return ((cp[h >> 1] & mask) == mask);
	    }
	    index := binlsr(h,1);
	    mask := binasl(hex('f'),binasl(binand(h,1),2));
	end;

      2:
	begin
	    {
	    { mask = 0x03 << ((h & 0x3) << 1);
	    { return ((cp[h >> 2] & mask) == mask);
	    }
	    index := binlsr(h,2);
	    mask := binasl(3,binasl(binand(h,3),1));
	end;

      1:
	begin
	    {
	    { mask = 0x01 << (h & 0x7);
	    { return ((cp[h >> 3] & mask) == mask);
	    }
	    index := binlsr(h,3);
	    mask := binasl(1,binand(h,7));
	end;

      otherwise
	begin
$if debug$
	    panic('isblock');
$end$
	    hfs_corrupt(fs);
	end;

    end;
    isblock := binand(cp[index], mask) = mask;
999:
end;

{
{ Take block 'h' out of bit map cp, showing it is used.
}
procedure clrblock(fs: super_block_ptr_type;
		   anyvar cp: freemap_type; h: blk_type);
label
    999;
var
    index: integer;
    mask: integer;
begin
    case fs^.frag of

      8:
	begin
	    cp[h] := 0;
	    goto 999;
	end;

      4:
	begin
	    {
	    { cp[h >> 1] &= ~(0x0f << ((h & 0x1) << 2));
	    }
	    index := binlsr(h,1);
	    mask := binasl(hex('f'),binasl(binand(h,1),2));
	end;

      2:
	begin
	    {
	    { cp[h >> 2] &= ~(0x03 << ((h & 0x3) << 1));
	    }
	    index := binlsr(h,2);
	    mask := binasl(3,binasl(binand(h,3),1));
	end;

      1:
	begin
	    {
	    { cp[h >> 3] &= ~(0x01 << (h & 0x7));
	    }
	    index := binlsr(h,3);
	    mask := binasl(1,binand(h,7));
	end;

      otherwise
	begin
$if debug$
	    panic('clrblock');
$end$
	    hfs_corrupt(fs);
	end;

    end;
    cp[index] := binand(cp[index], bincmp(mask));
999:
end;

{
{ Put bsize block 'h' into bit map cp, showing it is free.
}
procedure setblock(fs: super_block_ptr_type;
		   anyvar cp: freemap_type; h: blk_type);
label
    999;
var
    index: integer;
    mask: integer;
begin

    case fs^.frag of

      8:
	begin
	    cp[h] := hex('ff');
	    goto 999;
	end;

      4:
	begin
	    {
	    { cp[h >> 1] |= (0x0f << ((h & 0x1) << 2));
	    }
	    index := binlsr(h,1);
	    mask := binasl(hex('f'),binasl(binand(h,1),2));
	end;

      2:
	begin
	    {
	    { cp[h >> 2] |= (0x03 << ((h & 0x3) << 1));
	    }
	    index := binlsr(h,2);
	    mask := binasl(3,binasl(binand(h,3),1));
	end;

      1:
	begin
	    {
	    { cp[h >> 3] |= (0x01 << (h & 0x7));
	    }
	    index := binlsr(h,3);
	    mask := binasl(1,binand(h,7));
	end;

      otherwise
	begin
$if debug$
	    panic('setblock');
$end$
	    hfs_corrupt(fs);
	end;

    end;
    cp[index] := binior(cp[index], mask);
999:
end;



{--------------------------------------------------------}
{
{ FREEMAP MANIPULATION
}

{
{ scanc scans through the freemap cp until it finds a byte
{ with a fragment cluster of the correct size.  Each byte indexes
{ fragtbl8 or fragtbl124; the result has bits for the sizes
{ of each cluster in that byte.  'mask' has the
{ bit for size we want.
}
function scanc(size: integer; cp: freemap_ptr_type;
	       table: fragtbl_ptr_type; mask: integer): integer;
var
    i: integer;
begin
    i := 0;
    while (binand(table^[cp^[i]],mask) = 0) and (i < size) do
	i := i + 1;
    scanc := (size - i);
end;

{
{ Find a block of the specified size in the specified cylinder group.
{ Caller ensures that a block of this size exists.
{ It is a panic if a request is made to find a block if none are
{ available.
{ The previous sentence, from the original C comments, is only
{ partially true; a scanc failure causes a -1 return (hfs_corrupt),
{ where a failure to find the cluster is a panic.
}
function mapsearch(fs: super_block_ptr_type;
		   cgp: cgroup_ptr_type;
		   bpref: frag_type;
		   allocsiz: integer): frag_type;
label
    999;
var
    bno: frag_type;
    start, len, loc, i: integer;
    blk, field, subfield, pos: integer;
begin
    mapsearch := -1;

    {
    { find the fragment by searching through the free block
    { map for an appropriate bit pattern
    }
    { where to start looking }
    if bpref <> 0 then
	start := dtogd(fs, bpref) div NBBY
    else
	start := cgp^.frotor div NBBY;
    { and how far until run off end }
    len := howmany(fs^.fpg, NBBY) - start;

    { scan from starting pt to end of freemap }
    loc := scanc(len,
	    addr(cgp^.free, start),
	    fragtbl[fs^.frag],
	    binasl(1, allocsiz - 1 + (fs^.frag mod NBBY)));
    { if not found, scan up to starting pt }
    if loc = 0 then begin
	len := start + 1;
	start := 0;
	loc := scanc(len,
		addr(cgp^.free, start),
		fragtbl[fs^.frag],
		binasl(1, allocsiz - 1 + (fs^.frag mod NBBY)));
	if loc = 0 then begin
	    hfs_corrupt(fs);
	    goto 999;
	end;
    end;
    { bno is the block found }
    bno := (start + len - loc) * NBBY;
    cgp^.frotor := bno;

    {
    { found the byte in the map
    { Now we must find the fragment cluster within the byte
    { sift through the bits to find the selected frag
    }
    { i is the first frag addr of next byte }
    i := bno + NBBY;
    { bno is the lblk under consideration }
    while bno < i do begin
	{ blk is the freemap byte, with a 0 at the end }
	blk := blkmap(fs, cgp^.free, bno);
	blk := binasl(blk, 1);
	{ field is the bit pattern we want with extra 1 at each end }
	field := around[allocsiz];
	{ subfield is the bit pattern we want }
	subfield := inside[allocsiz];

	{ pos is the bit position within the freemap byte }
	for pos := 0 to fs^.frag - allocsiz do begin
	    if binand(blk, field) = subfield then begin
		mapsearch := bno + pos;
		goto 999;
	    end;
	    field := binasl(field, 1);
	    subfield := binasl(subfield, 1);
	end;
	bno := bno + fs^.frag;
    end;
$if debug$
    writeln('bno = ', bno:1, ', fs = ', fs^.fname);
    panic('mapsearch: block not in map');
$end$
    hfs_corrupt(fs);
999:
end;


{
{ Update the frsum fields to reflect addition or deletion
{ of some frags.
{ We look at the freemap byte 'fragmap', and update
{ 'fraglist' by 'cnt' (1 or -1) for each fragment cluster
{ in fragmap.  fraglist is an array of integers, where
{ fraglist[i] tells how many frag clusters of size i exist.
{ cnt 1 means we're adding these clusters, -1 deleting.
}
procedure fragacct(fs: super_block_ptr_type; fragmap: integer;
		   var fraglist: frag_avail_type; cnt: integer);
var
    inblk, field, subfield, siz, pos: integer;
begin

    { inblk has bits for each size fragment in fragmap }
    inblk := binasl(fragtbl[fs^.frag]^[fragmap], 1);

    { fragmap is the byte from the free map, with a 0 bit at the end }
    fragmap := binasl(fragmap, 1);

    { look for each possible size of fragment }
    for siz := 1 to fs^.frag - 1 do begin

	{ if there is a fragment (or more) of this size }
	if binand(inblk, binasl(1, siz + fs^.frag mod NBBY)) <> 0 then begin

	    { then find them so they can be counted }
	    field := around[siz];
	    subfield := inside[siz];

	    { pos shows where we're looking }
	    pos := siz;
	    while pos <= fs^.frag do begin
		if binand(fragmap, field) = subfield then begin
		    { there is a cluster size siz at pos }
		    fraglist[siz] := fraglist[siz] + cnt;
		    { so can skip the next siz bits, + 1 }
		    pos := pos + siz;
		    field := binasl(field, siz);
		    subfield := binasl(subfield, siz);
		end;
		field := binasl(field, 1);
		subfield := binasl(subfield, 1);
		pos := pos + 1;
	    end;
	end;
    end;
end;

{------------------------------------------------------------------}
{
{ PREFERRED BLOCK AND INODE CALCULATIONS
}


{
{ Select the desired position for the next block in a file.  The file is
{ logically divided into sections. The first section is composed of the
{ direct blocks. Each additional section contains fs_maxbpg blocks.
{
{ If no blocks have been allocated in the first section, the policy is to
{ request a block in the same cylinder group as the inode that describes
{ the file. If no blocks have been allocated in some other section, the
{ policy is to place the section in a cylinder group with a greater than
{ average number of free blocks.  An appropriate cylinder group is found
{ by maintaining a rotor that sweeps the cylinder groups. When a new
{ group of blocks is needed, the rotor is advanced until a cylinder group
{ with greater than the average number of free blocks is found.
{
{ If a section is already partially allocated, the policy is to
{ contiguously allocate fs_maxcontig blocks.  The end of one of these
{ contiguous blocks and the beginning of the next is physically separated
{ so that the disk head will be in transit between them for at least
{ fs_rotdelay milliseconds.  This is to allow time for the processor to
{ schedule another I/O transfer.
}
function blkpref(ip: inode_ptr_type;
		lbn: lblk_type; indx: integer;
		bap: indir_ptr_type): frag_type;
label
    999;
var
    fs: super_block_ptr_type;
    cg: integer;
    avgbfree: integer;
    nextblk: frag_type;
    use_delay: boolean;
    i: integer;
begin
    fs := current_super;

    {
    { Special hack for preallocation.
    { If "prealloc_pref" is set, the preallocator is telling us
    { to use that block.
    }
    if prealloc_pref <> 0 then begin
	blkpref := prealloc_pref;
	prealloc_pref := prealloc_pref + fs^.frag;
	goto 999;
    end;

    { starting new section? }
    if (indx mod fs^.maxbpg = 0) or (bap^[indx - 1] = 0) then begin

	{ starting first section? }
	if lbn < NDADDR then begin
	    cg := itog(fs, binode_ptr_type(ip)^.inumber);
	    blkpref := (fs^.fpg * cg + fs^.frag);
	    goto 999;
	end;

	{
	{ starting section after first
	{ Find a cylinder with greater than average number of
	{ unused data blocks.
	}
	avgbfree := fs^.cstotal.nbfree div fs^.ncg;
	for cg := fs^.cgrotor + 1 to fs^.ncg - 1 do
	    if fs_cs(fs, cg)^.nbfree >= avgbfree then begin
		fs^.cgrotor := cg;
		blkpref := (fs^.fpg * cg + fs^.frag);
		goto 999;
	    end;
	for cg := 0 to fs^.cgrotor do
	    if fs_cs(fs, cg)^.nbfree >= avgbfree then begin
		fs^.cgrotor := cg;
		blkpref := (fs^.fpg * cg + fs^.frag);
		goto 999;
	    end;
	blkpref := 0;
	goto 999;
    end;

    {
    { One or more previous blocks have been laid out. If fewer
    { than fs_maxcontig previous blocks are contiguous, the
    { next block is requested contiguously, otherwise it is
    { requested rotationally delayed by fs_rotdelay milliseconds.
    {
    { use_delay if there are maxcontig contig blks before indx
    { we know from above tests that indx > 0 and bap^[indx-1] <> 0
    }
    if indx < fs^.maxcontig then
	{ not enough addresses yet }
	use_delay := false
    else begin
	use_delay := true;
	for i := (indx - fs^.maxcontig) to indx - 2 do
	    if (bap^[i] = 0) or
	    (bap^[i] + fs^.frag <> bap^[i+1]) then
		use_delay := false;
    end;

    nextblk := bap^[indx - 1] + fs^.frag;

    { allocate after rotational delay? }
    if use_delay and (fs^.rotdelay <> 0) then
	{
	{ Here we convert ms of delay to frags as:
	{ (frags) = (ms) * (rev/sec) * (sect/rev) /
	{       ((sect/frag) * (ms/sec))
	{ then round up to the next block.
	}
	nextblk := nextblk + roundup(fs^.rotdelay * fs^.rps * fs^.nsect
			div (NSPF(fs) * 1000), fs^.frag);

    blkpref := nextblk;
999:
end;

{-------------------------------------------------------------------}
{
{ LOW-LEVEL ALLOCATION ROUTINES
{ These allocate the block out of the bitmap; the high-level
{       routines access the contents.
}

{
{ Implement the cylinder overflow algorithm.
{
{ The policy implemented by this algorithm is:
{   1) allocate the block in its requested cylinder group.
{   2) quadradically rehash on the cylinder group number.
{   3) brute force search for a free block.
{
{ "size" is size for data blocks, mode for inodes
{ "tried" prevents us from looking at the same cgroups
{ more than once.  But if tried is too small for this
{ fs, we set "tried_valid" to false, and ignore "tried".
{
{ allocator is either alloccg or ialloccg or prealloccg
{ alloccgblk is subroutine of alloccg
}
function hashalloc(ip: inode_ptr_type; cg: integer;
		   pref: frag_type; size: integer;
		   allocator: alloc_proc): frag_type;
label
    999;
const
    maxcg = 256;
type
    tried_type = packed array[0..maxcg-1] of boolean;
const
    tried_def = tried_type[maxcg of false];
var
    fs: super_block_ptr_type;
    result: frag_type;
    i, icg: integer;
    tried: tried_type;
    tried_valid: boolean;
begin

    hashalloc := 0;
    icg := cg;
    fs := current_super;
    tried_valid := (fs^.ncg <= maxcg);
    if tried_valid then
	tried := tried_def;

    {
    { 1: preferred cylinder group
    }
    call(allocator, ip, cg, pref, size, result);
    if result <> 0 then begin
	hashalloc := result;
	goto 999;
    end;
    if tried_valid then
	tried[cg] := true;

    {
    { 2: quadratic rehash
    }
    i := 1;
    while i < fs^.ncg do begin
	cg := cg + i;
	if cg >= fs^.ncg then
	    cg := cg - fs^.ncg;
	call(allocator, ip, cg, 0, size, result);
	if result <> 0 then begin
	    hashalloc := result;
	    goto 999;
	end;
	if tried_valid then
	    tried[cg] := true;
	i := i * 2;
    end;

    {
    { 3: brute force search
    { Note that we start at i = 2, since 0 was checked initially,
    { and 1 is always checked in the quadratic rehash.
    }
    cg := (icg + 2) mod fs^.ncg;
    for i := 2 to fs^.ncg-1 do begin
	if not tried_valid or not tried[cg] then begin
	    call(allocator, ip, cg, 0, size, result);
	    if result <> 0 then begin
		hashalloc := result;
		goto 999;
	    end;
	end;
	if tried_valid then
	    tried[cg] := true;
	cg := cg + 1;
	if cg = fs^.ncg then
	    cg := 0;
    end;
999:
end;

{
{ Allocate an entire block in a given cylinder group.
{
{ This algorithm implements the following policy:
{   1) allocate the requested block.
{   2) allocate a rotationally optimal block in the same cylinder.
{   3) allocate the next available block on the block rotor for the
{      specified cylinder group.
{ Note that this routine only allocates fs_bsize blocks; these
{ blocks may be fragmented by the routine that allocates them.
}
function alloccgblk(fs: super_block_ptr_type;
		    cgp: cgroup_ptr_type;
		    bpref: frag_type): frag_type;
label
    111, 555, 999;
type
    rpos_ptr_type = ^rpos_array_type;
    rotbl_array_type = packed array[0..maxint] of 0..255;
var
    bno: frag_type;
    cylno, pos, delta: integer;
    i: integer;
    cylbp: rpos_ptr_type;
    loopdone: boolean;
begin

    { if no preference, we just take whatever's available }
    if bpref = 0 then begin
	bpref := cgp^.rotor;
	goto 111;
    end;

    { bpref is blk number within this cg }
    bpref := binand(bpref, bincmp(fs^.frag-1));
    bpref := dtogd(fs, bpref);

    {
    { if the requested block is available, use it
    }
    if isblock(fs, cgp^.free, fragstoblks(fs, bpref)) then begin
	bno := bpref;
	goto 555;
    end;

    {
    { check for a block available on the same cylinder
    }
    cylno := cbtocylno(fs, bpref);
    { if none here, don't care about location }
    if cgp^.btot[cylno] = 0 then
	goto 111;
    if fs^.cpc = 0 then begin
	{
	{ block layout info is not available, so just have
	{ to take any block in this cylinder.
	}
	bpref := howmany(fs^.spc * cylno, NSPF(fs));
	goto 111;
    end;

    {
    { There is a block in same cylinder as bpref.
    { Find the block at the same rotational position as
    { bpref, or as close rotationally as possible.
    { check the summary information to see if a block is
    { available in the requested cylinder starting at the
    { requested rotational position and proceeding around.
    }
    cylbp := rpos_ptr_type(addr(cgp^.b[cylno]));
    { pos is the optimal rotational position }
    pos := cbtorpos(fs, bpref);
    i := pos;
    loopdone := false;
    while (i < NRPOS) and not loopdone do begin
	if cylbp^[i] > 0 then
	    loopdone := true
	else
	    i := i + 1;
    end;
    if i = NRPOS then begin
	i := 0;
	loopdone := false;
	while (i < pos) and not loopdone do begin
	    if cylbp^[i] > 0 then
		loopdone := true
	    else
		i := i + 1;
	end;
    end;
    { I think this test should always succeed -- Hal }
    if cylbp^[i] > 0 then begin
	{
	{ found a rotational position (i), now find the actual
	{ block. A panic if none is actually there.
	}
	{ pos is cylinder's position within cylinder cycle }
	pos := cylno mod fs^.cpc;
	{ bno is first bblk in cylinder cycle }
	bno := (cylno - pos) * fs^.spc div NSPB(fs);
	{
	{ postbl gives first bblk in this position,
	{ offset from beginning of cycle.
	}
	if fs^.postbl[pos][i] = -1 then begin
$if debug$
	    writeln('pos = ', pos:1, ',  i = ', i:1, ', fs = ',
		    fs^.fname);
	    panic('alloccgblk: postbl corrupted');
$end$
	    hfs_corrupt(fs);
	end;
	{ i runs over all blocks in this position }
	loopdone := false;
	i := fs^.postbl[pos][i];
	while not loopdone do begin
	    if isblock(fs, cgp^.free, bno + i) then begin
		bno := blkstofrags(fs, (bno + i));
		goto 555;
	    end;
	    delta := rotbl_array_type(fs^.rotbl)[i];
	    if (delta <= 0) or (delta > maxbpc - i) then
		loopdone := true
	    else
		i := i + delta;
	end;
$if debug$
	writeln('pos = ', pos:1, ',  i = ', i:1, ', fs = ',
		fs^.fname);
	panic('alloccgblk: cannot find blk in cyl');
$end$
	hfs_corrupt(fs);
    end
    else
	{ concluding corruption not in UNIX code }
	hfs_corrupt(fs);

111:
    {
    { no blocks in the requested cylinder, so take next
    { available one in this cylinder group.
    }
    bno := mapsearch(fs, cgp, bpref, fs^.frag);
    if bno < 0 then begin
	alloccgblk := 0;
	goto 999;
    end;
    cgp^.rotor := bno;

555:
    { have the block number now in bno }
    clrblock(fs, cgp^.free, fragstoblks(fs, bno));
    with cgp^.cs do
	nbfree := nbfree - 1;
    with fs^.cstotal do
	nbfree := nbfree - 1;
    with fs_cs(fs, cgp^.cgx)^ do
	nbfree := nbfree - 1;
    { and per-cylinder free block counts }
    cylno := cbtocylno(fs, bno);
    i := cbtorpos(fs, bno);
    with cgp^ do begin
	b[cylno][i] := b[cylno][i] - 1;
	btot[cylno] := btot[cylno] - 1;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty]);
    alloccgblk := (cgp^.cgx * fs^.fpg + bno);
999:
end;

{
{ Determine whether a block can be allocated.
{ (size is some multiple of fsize <= bsize)
{ Check to see if a block of the appropriate size is available,
{ and if it is, allocate it.
{ 0 return means not present in this cg
}
procedure alloccg(ip: inode_ptr_type;
		  cg: integer;
		  bpref: frag_type; size: integer;
		  var result: integer);
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    bno: frag_type;
    frags: integer;
    allocsiz: integer;
    i: integer;
    loopdone: boolean;
begin
    fs := current_super;
    result := 0;

    if (fs_cs(fs, cg)^.nbfree = 0) and (size = fs^.bsize) then
	goto 999;
    cgp := get_cgroup(cg);
    if (cgp^.cs.nbfree = 0) and (size = fs^.bsize) then begin
	hfs_corrupt(fs);
	put_cgroup(cgp, [release]);
	goto 999;
    end;

    { call another routine for allocation of an entire block }
    if size = fs^.bsize then begin
	bno := alloccgblk(fs, cgp, bpref);
	put_cgroup(cgp, [release]);
	result := bno;
	goto 999;
    end;

    {
    { check to see if any fragments are already available
    { allocsiz is the size which will be allocated, hacking
    { it down to a smaller size if necessary
    }
    frags := numfrags(fs, size);
    allocsiz := frags;
    loopdone := false;
    while (allocsiz < fs^.frag) and not loopdone do begin
	if cgp^.frsum[allocsiz] <> 0 then
	    loopdone := true
	else
	    allocsiz := allocsiz + 1;
    end;

    { must use whole new bblock? }
    if allocsiz = fs^.frag then begin
	{
	{ no fragments were available, so a block will be
	{ allocated, and hacked up
	}
	if cgp^.cs.nbfree = 0 then begin
	    put_cgroup(cgp, [release]);
	    goto 999;
	end;
	{ bno is the block we allocate }
	bno := alloccgblk(fs, cgp, bpref);
	if bno = 0 then begin
	    put_cgroup(cgp, [release]);
	    goto 999;
	end;
	{ bpref is the position within this cg }
	bpref := dtogd(fs, bno);

	{ clear bits for frags we won't use }
	for i := frags to fs^.frag - 1 do
	    setbit(cgp^.free, bpref + i);

	{ i is the number of new frags we are creating }
	i := fs^.frag - frags;

	{ update total fragment counts }
	with cgp^.cs do
	    nffree := nffree + i;
	with fs^.cstotal do
	    nffree := nffree + i;
	with fs_cs(fs, cg)^ do
	    nffree := nffree + i;
	fs^.fmod := FS_MODIFIED;
	with cgp^ do
	    frsum[i] := frsum[i] + 1;

	put_cgroup(cgp, [dirty,release]);
	result := bno;
	goto 999;
    end;

    {
    { We don't need to break up a bblk, because there
    { is a fragment cluster of size allocsiz, which
    { may be bigger than frags, which is how many we want.
    }
    bno := mapsearch(fs, cgp, bpref, allocsiz);
    if bno < 0 then begin
	put_cgroup(cgp, [release]);
	goto 999;
    end;

    { show our cluster now in use }
    for i := 0 to frags - 1 do
	clrbit(cgp^.free, bno + i);
    { update total fragment counts }
    with cgp^.cs do
	nffree := nffree - frags;
    with fs^.cstotal do
	nffree := nffree - frags;
    with fs_cs(fs, cg)^ do
	nffree := nffree - frags;
    fs^.fmod := FS_MODIFIED;
    { took a cluster of size allocsiz }
    with cgp^ do
	frsum[allocsiz] := frsum[allocsiz] - 1;
    { maybe created a cluster if allocsiz was too big }
    if frags <> allocsiz then
	with cgp^ do
	    frsum[allocsiz - frags] := frsum[allocsiz - frags] + 1;
    put_cgroup(cgp, [dirty,release]);
    result := (cg * fs^.fpg + bno);
999:
end;


{
{ Determine whether fragment bprev can be extended
{ from osize to nsize, both fs_fsize multiples.
{ Check to see if the necessary fragments are available, and
{ if they are, allocate them.
{ 0 means cannot do it.
}
function fragextend(ip: inode_ptr_type;
		    cg: integer;
		    bprev: frag_type;
		    osize, nsize: integer): frag_type;
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    bno, bbase: frag_type;
    frags, i, j: integer;
    loopdone: boolean;
begin
    fragextend := 0;

    fs := current_super;
    if fs_cs(fs, cg)^.nffree < numfrags(fs, nsize - osize) then
	goto 999;

    { frags is how many frags we want }
    frags := numfrags(fs, nsize);
    { bbase is the 0..fs_frag-1 offset within the bblk }
    bbase := bprev mod fs^.frag;
    { be sure not trying to extend too far }
    if bbase > (bprev + frags - 1) mod fs^.frag then
	{ cannot extend across a block boundary }
	goto 999;

    { look at the cg data }
    cgp := get_cgroup(cg);

    { see if the following frags are free }
    bno := dtogd(fs, bprev);
    for i := numfrags(fs, osize) to frags-1 do
	if isclr(cgp^.free, bno + i) then begin
	    put_cgroup(cgp, [release]);
	    goto 999;
	end;

    {
    { the current fragment can be extended
    { deduct the count on fragment being extended into
    { increase the count on the remaining fragment (if any)
    { allocate the extended piece
    }
    { "i" marks end of free cluster }
    i := frags;
    while (i < fs^.frag - bbase) and not isclr(cgp^.free, bno + i) do
	i := i + 1;
    { dec count of original cluster }
    j := i - numfrags(fs, osize);
    with cgp^ do
	frsum[j] := frsum[j] - 1;
    { increment count of cluster left over }
    if i <> frags then
	with cgp^ do
	    frsum[i - frags] := frsum[i - frags] + 1;
    { now for the new frags we are using }
    for i := numfrags(fs, osize) to frags-1 do begin
	clrbit(cgp^.free, bno + i);
	with cgp^.cs do
	    nffree := nffree - 1;
	with fs^.cstotal do
	    nffree := nffree - 1;
	with fs_cs(fs, cg)^ do
	    nffree := nffree - 1;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty,release]);
    fragextend := bprev;
999:
end;


{
{ Free a block or fragment.
{
{ The specified block or fragment is placed back in the
{ free map. If a fragment is deallocated, a possible
{ block reassembly is checked.
}
procedure xfree(ip: inode_ptr_type; bno: frag_type; size: integer);
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    cg: integer;
    bbase: frag_type;
    blk: integer;
    frags: integer;
    i, j: integer;
begin
    fs := current_super;
    if (size > fs^.bsize) or (fragoff(fs, size) <> 0) then begin
$if debug$
	writeln('bsize = ', fs^.bsize:1, ', size = ', size:1,
		', fs = ', fs^.fname);
	panic('xfree: bad size');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    { cg is the cgroup number for the block bno }
    if badblock(fs, bno) then begin
	hfs_corrupt(fs);
	goto 999;
    end;
    cg := dtog(fs, bno);

    { cgp is the cylinder group structure }
    cgp := get_cgroup(cg);

    { bno is the offset within cg }
    bno := dtogd(fs, bno);

    { freeing an entire bblock? }
    if size = fs^.bsize then begin
	{ already free? }
	if isblock(fs, cgp^.free, fragstoblks(fs, bno)) then begin
$if debug$
	    writeln('cg = ', cg:1, ', block = ', bno:1, ', fs = ',
		fs^.fname);
	    panic('xfree: freeing free block');
$end$
	    hfs_corrupt(fs);
	end;
	{ mark it as free }
	setblock(fs, cgp^.free, fragstoblks(fs, bno));
	{ update free block counts }
	with cgp^.cs do
	    nbfree := nbfree + 1;
	with fs^.cstotal do
	    nbfree := nbfree + 1;
	with fs_cs(fs, cg)^ do
	    nbfree := nbfree + 1;
	{ and per-cylinder free block counts }
	i := cbtocylno(fs, bno);
	j := cbtorpos(fs, bno);
	with cgp^ do begin
	    b[i][j] := b[i][j] + 1;
	    btot[i] := btot[i] + 1;
	end;
    end

    { freeing a fragment cluster }
    else begin

	{ bbase is the blk containing the cluster }
	bbase := bno - (bno mod fs^.frag);
	{
	{ decrement the counts associated with the old frags
	}
	blk := blkmap(fs, cgp^.free, bbase);
	fragacct(fs, blk, cgp^.frsum, -1);
	{
	{ deallocate the fragment
	}
	frags := numfrags(fs, size);
	{ free each frag }
	for i := 0 to frags - 1 do begin
	    { already free? }
	    if isset(cgp^.free, bno + i) then begin
$if debug$
		writeln('cg = ', cg:1, ', block = ', bno+i:1, ', fs = ',
		    fs^.fname);
		panic('xfree: freeing free frag');
$end$
		hfs_corrupt(fs);
	    end;
	    setbit(cgp^.free, bno + i);
	end;
	i := frags;
	{ update total fragment counts }
	with cgp^.cs do
	    nffree := nffree + i;
	with fs^.cstotal do
	    nffree := nffree + i;
	with fs_cs(fs, cg)^ do
	    nffree := nffree + i;
	{
	{ add back in counts associated with the new frags
	}
	blk := blkmap(fs, cgp^.free, bbase);
	fragacct(fs, blk, cgp^.frsum, 1);
	{
	{ if a complete block has been reassembled, account for it
	}
	if isblock(fs, cgp^.free, fragstoblks(fs, bbase)) then begin
	    with cgp^.cs do begin
		nffree := nffree - fs^.frag;
		nbfree := nbfree + 1;
	    end;
	    with fs^.cstotal do begin
		nffree := nffree - fs^.frag;
		nbfree := nbfree + 1;
	    end;
	    with fs_cs(fs, cg)^ do begin
		nffree := nffree - fs^.frag;
		nbfree := nbfree + 1;
	    end;
	    i := cbtocylno(fs, bbase);
	    j := cbtorpos(fs, bbase);
	    with cgp^ do begin
		b[i][j] := b[i][j] + 1;
		btot[i] := btot[i] + 1;
	    end;
	end;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty,release]);
999:
end;


{------------------------------------------------------------------}
{
{ HIGH-LEVEL ALLOCATION ROUTINES
{ These call the low-level routines to get disk addresses,
{ then (often) access the data at that address.
}

{
{ Allocate a block in the file system.
{
{ The size of the requested block is given, which must be some
{ multiple of fs_fsize and <= fs_bsize.
{ A preference may be optionally specified. If a preference is given
{ the following hierarchy is used to allocate a block:
{   1) allocate the requested block.
{   2) allocate a rotationally optimal block in the same cylinder.
{   3) allocate a block in the same cylinder group.
{   4) quadradically rehash into other cylinder groups, until an
{      available block is located.
{ If no block preference is given the following heirarchy is used
{ to allocate a block:
{   1) allocate a block in the cylinder group that contains the
{      inode for the file.
{   2) quadratically rehash into other cylinder groups, until an
{      available block is located.
}
function alloc(ip: inode_ptr_type;
	       bpref: frag_type;
	       size: integer;
	       is_control: boolean): frag_type;
label
    555, 999;
var
    cg: integer;
    bno: frag_type;
    fs: super_block_ptr_type;
begin

    alloc := 0;
    fs := current_super;
    { param check }
    if (size > fs^.bsize) or (fragoff(fs, size) <> 0) then begin
$if debug$
	writeln('size = ', size:1, ', fs = ', fs^.fname);
	panic('alloc: bad size');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;
    { space check }
    if (size = fs^.bsize) and (fs^.cstotal.nbfree = 0) then
	goto 555;
    if freespace(fs, fs^.minfree) <= 0 then
	goto 555;

    if bpref >= fs^.size then
	bpref := 0;
    {
    { preferred cg is the one with the preferred block,
    { or the one with the inode if no preferred block.
    }
    if bpref = 0 then
	cg := itog(fs, binode_ptr_type(ip)^.inumber)
    else
	cg := dtog(fs, bpref);

    bno := hashalloc(ip, cg, bpref, size, alloccg);
    if bno <= 0 then
	goto 555;
    ip^.blocks := ip^.blocks + btodb(size);
    put_inode(ip, [dirty]);
    if is_control then
	zero_data(bno, size);
    alloc := bno;
    goto 999;
555:
    { no space }
$if debug$
    fserr(fs, 'file system full');
$end$
    ioresult := ord(inoroom);
999:
end;

{
{ Reallocate a fragment to a bigger size
{
{ The number and size of the old block is given, and a preference
{ and new size is also specified. The allocator attempts to extend
{ the original block. Failing that, the regular block allocator is
{ invoked to get an appropriate block.
}
function realloccg(ip: inode_ptr_type;
		   bprev, bpref: frag_type;
		   osize, nsize: integer;
		   lbn: lblk_type;
		   is_control: boolean): frag_type;
label
    555, 999;
var
    cg: integer;
    bno: frag_type;
    fs: super_block_ptr_type;
begin
    fs := current_super;
    realloccg := 0;

    { param check }
    if (osize > fs^.bsize) or (fragoff(fs, osize) <> 0) or
       (nsize > fs^.bsize) or (fragoff(fs, nsize) <> 0) then begin
$if debug$
	    writeln('osize = ', osize:1, ', nsize = ', nsize:1,
		    'fs = ', fs^.fname, ', bprev = ', bprev:1);
	    panic('realloccg: bad size');
$end$
	    ioresult := ord(zcatchall);
	    goto 999;
    end;

    { see if space left }
    if freespace(fs, fs^.minfree) <= 0 then
	goto 555;

    { more param check }
    if bprev = 0 then begin
$if debug$
	writeln('osize = ', osize:1, ', nsize = ', nsize:1,
		'fs = ', fs^.fname, ', bprev = ', bprev:1);
	panic('realloccg: bad bprev');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    { cg is same group as bprev }
    cg := dtog(fs, bprev);
    { try to extend fragment in place }
    bno := fragextend(ip, cg, bprev, osize, nsize);
    if bno <> 0 then begin
	if is_control then
	    zero_data(bprev+numfrags(fs,osize), nsize-osize);
	ip^.blocks := ip^.blocks + btodb(nsize - osize);
	put_inode(ip, [dirty]);
	realloccg := bno;
	goto 999;
    end;

    { could not extend it in place, so move it }
    if bpref >= fs^.size then
	bpref := 0;
    bno := hashalloc(ip, cg, bpref, nsize, alloccg);
    if bno > 0 then begin
	if is_control then begin
	    copy_control_data(bprev, bno, osize);
	    zero_data(bno+numfrags(fs,osize), nsize-osize);
	end
	else
	    copy_user_data(fragstobytes(fs, bprev),
			   fragstobytes(fs, bno),
			   osize);
	ip^.blocks := ip^.blocks + btodb(nsize - osize);
	ip^.db[lbn] := bno;
	{ immediate write-thru to show old block no longer ours }
	put_inode(ip, [dirty,immediate]);
	xfree(ip, bprev, osize);
	realloccg := bno;
	goto 999;
    end;
555:
    {
    { no space available
    }
$if debug$
    fserr(fs, 'file system full');
$end$
    ioresult := ord(inoroom);
999:
end;

{------------------------------------------------------------------}
{
{ MAP LOGICAL BLOCK NUMBERS TO FRAGMENT NUMBERS
}


{
{ Bmap defines the structure of file system storage
{ by returning the physical block number on a device given the
{ inode and the logical block number in a file.
{ size is <= bsize.  It tells how far in this lblk we want to write,
{ and is ignored when we're reading.
{ rwflg is B_READ for reading, B_WRITE or B_ZWRITE for writing.
{ B_ZWRITE means that bmap zeroes every newly allocated block.
{ Otherwise, zeroing of user data is skipped (bmap always zeroes
{ indir blocks and directories).  Exception: when extending
{ fragmented file into new logical block, the old fragment
{ must be extended; bmap always zeroes it.
{ This setup allows several zeroing strategies:
{   never zero -- caller uses B_WRITE
{   always zero in bmap -- caller always uses B_ZWRITE
{   zero in bmap sometimes -- caller uses B_ZWRITE sometimes
}
function bmap(ip: inode_ptr_type; bn: lblk_type;
	      rwflg: bmap_mode; size: integer): frag_type;
label
    999;
var
    i, j: integer;
    sh: integer;
    osize, nsize: integer;
    fs: super_block_ptr_type;
    lbn: lblk_type;
    nb: integer; { sometimes lblk_type, sometimes frag_type }
    bp, pref: frag_type;
    bap: indir_ptr_type;
    loopdone: boolean;
    is_control, this_control: boolean;
begin
    bmap := BMAP_ERROR;
    {zlength := 0;}
    is_control := (binand(ip^.mode, IFMT) = IFDIR) or (rwflg = B_ZWRITE);

    if bn < 0 then begin
$if debug$
	panic('bmap negative bn');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    fs := current_super;

    {
    { If the next write will extend the file into a new block,
    { and the file is currently composed of a fragment
    { this fragment has to be extended to be a full block.
    { This never happens with directories.
    }
    { nb is the last lblk in the file }
    nb := lblkno(fs, ip^.size.ls);

    { only direct addresses can be fragments }
    if (rwflg <> B_READ) and (nb < NDADDR) and (nb < bn) then begin

	{ osize is size (frag multiple) of last lblk }
	osize := blksize(fs, ip, nb);
	if (osize < fs^.bsize) and (osize > 0) then begin
	    bp := realloccg(ip, ip^.db[nb],
			    blkpref(ip, nb, nb, indir_ptr_type(addr(ip^.db))),
			    osize, fs^.bsize, nb,
			    is_control);
	    if bp = 0 then
		goto 999;
	    ip^.size.ls := (nb + 1) * fs^.bsize;
	    ip^.db[nb] := bp;
	    put_inode(ip, [dirty]);
	end;
    end;

    {
    { The first NDADDR blocks are direct blocks
    }
    if bn < NDADDR then begin
	{ nb is frag # for lblk bn, which we're accessing }
	nb := ip^.db[bn];

	{ reading }
	if rwflg = B_READ then begin
	    { reading a hole? }
	    if nb = 0 then nb := BMAP_HOLE;
	    bmap := nb;
	    goto 999;
	end;

	{ writing }
	{ writing a hole or writing last frag? }
	if (nb = 0) or (ip^.size.ls < (bn + 1) * fs^.bsize) then begin


	    { writing last frag? }
	    if nb <> 0 then begin
		{ consider need to reallocate a frag }
		osize := fragroundup(fs, blkoff(fs, ip^.size.ls));
		nsize := fragroundup(fs, size);
		if (nsize <= osize) then begin
		    bmap := nb;
		    goto 999;
		end;
		bp := realloccg(ip, nb,
			blkpref(ip, bn, bn, indir_ptr_type(addr(ip^.db))),
			osize, nsize, bn, is_control);
	    end

	    { writing a hole }
	    else begin
		osize := 0;
		if ip^.size.ls < (bn + 1) * fs^.bsize then
		    nsize := fragroundup(fs, size)
		else
		    nsize := fs^.bsize;
		bp := alloc(ip,
			blkpref(ip, bn, bn, indir_ptr_type(addr(ip^.db))),
			nsize, is_control);
	    end;

	    if bp = 0 then
		goto 999;
	    {if not is_control then begin
		zstart := fragstobytes(fs, bp) + osize;
		zlength := nsize - osize;
	    end;}
	    nb := bp;
	    ip^.db[bn] := nb;
	    put_inode(ip, [dirty]);
	end;
	bmap := nb;
	goto 999;
    end;

    {
    { Determine how many levels of indirection.
    { NIADDR-j will be the (0-based) index into ip^.ib
    }
    pref := 0;
    sh := 1;
    lbn := bn;
    bn := bn - NDADDR;
    j := NIADDR;
    loopdone := false;
    while (j > 0) and not loopdone do begin
	{ sh is num of lblks reachable this level }
	sh := sh * fs^.nindir;
	if (bn < sh) then
	    loopdone := true
	else begin
	    bn := bn - sh;
	    j := j - 1;
	end;
    end;

    if j = 0 then begin
$if debug$
	panic('bmap -- file too big');
$end$
	hfs_corrupt(fs);
	goto 999;
    end;

    {
    { fetch the first indirect block; its addr is nb.
    { It may not be there; if writing, we allocate it.
    }
    nb := ip^.ib[NIADDR - j];
    { not there? }
    if nb = 0 then begin
	{ reading a hole? }
	if rwflg = B_READ then begin
	    bmap := BMAP_HOLE;
	    goto 999;
	end;
	{ writing a hole, so allocate }
	pref := blkpref(ip, lbn, 0, nil);
	bp := alloc(ip, pref, fs^.bsize, true);
	if bp = 0 then
	    goto 999;
	nb := bp;
	ip^.ib[NIADDR - j] := nb;
	put_inode(ip, [dirty]);
    end;

    {
    { fetch through the indirect blocks
    { until we find the target block.
    { the number of levels is (0-based) NIADDR - j.
    { nb is current indir block number (frag)
    { bap is the indir block itself
    { nb is the next indir block number
    }
    while j <= NIADDR do begin
	{ i is the index in indir nb of next indir or target }
	sh := sh div fs^.nindir;
	i := (bn div sh) mod fs^.nindir;
	bap := indir_ptr_type(get_datablk(nb, i*bytes_per_ptr));
	{ i is index in cache chunk bap }
	i := i mod (cache_blk_size div bytes_per_ptr);
	nb := bap^[i];
	if nb = 0 then begin

	    { reading a hole? }
	    if rwflg = B_READ then begin
		put_datablk(cache_blk_ptr_type(bap), [release]);
		bmap := BMAP_HOLE;
		goto 999;
	    end;

	    { writing a hole }
	    { no pref yet? }
	    if pref = 0 then
		{ this is an indir block? }
		if j < NIADDR then
		    pref := blkpref(ip, lbn, 0, nil)
		{ this is the target block }
		else
		    pref := blkpref(ip, lbn, i, bap);

	    {
	    { This time through loop, it's control data if it
	    { was control data before, or if this is an indirect block.
	    }
	    this_control := is_control or (j < NIADDR);

	    { allocate the block }
	    nb := alloc(ip, pref, fs^.bsize, this_control);
	    if nb = 0 then begin
		put_datablk(cache_blk_ptr_type(bap), [release]);
		goto 999;
	    end;
	    {if not this_control then begin
		zstart := fragstobytes(fs, nb);
		zlength := fs^.bsize;
	    end;}
	    bap^[i] := nb;
	    { ***5.1 -- write immediate if dir }
	    put_datablk(cache_blk_ptr_type(bap), [dirty,release]);
	end
	else
	    put_datablk(cache_blk_ptr_type(bap), [release]);
	j := j + 1;
    end;
    bmap := nb;
999:
end;

{--------------------------------------------------------------------------}
{
{ PREALLOCATION
}

{
{ Get a single chunk of disk for the given space.
{ Return the fragment number of the beginning, or 0 if not found,
{ in the var parameter "result".
{ We don't try terribly hard to find the space.  To keep the
{ code simple and fast, we look for the space only in freemap bytes
{ that are entirely clear.  Example: you want to preallocate
{ 9K.  On an 8K/1K system, the code looks for TWO set freemap
{ bytes, which requires that 16K be free.  If preallocation
{ is really all that great, we can look more carefully.
}
procedure prealloccg(ip: inode_ptr_type;
		     cg, pref, fragcount: integer;
		     var result: integer);
label
    999;
var
    chunk_start: integer;
    cgp: cgroup_ptr_type;
    num_bytes_set: integer;
    fs: super_block_ptr_type;
    found_used_space: boolean;
    freemap_size: integer;
    i: integer;
    cgp_free: freemap_ptr_type;
begin
    { how many 0xff bytes do we need in the free map? }
    num_bytes_set := howmany(fragcount, NBBY);
    fs := current_super;
    result := 0;
    cgp := nil;

    { enough blocks in the cg? }
    if fs_cs(fs, cg)^.nbfree < fragstoblks(fs, num_bytes_set*NBBY) then
	goto 999;

    cgp := get_cgroup(cg);

    {
    { set "chunk_start" to a place with num_bytes_set consecutive
    { bytes of ones (indicating all frags in this byte are free)
    }
    chunk_start := 0;
    freemap_size := howmany(fs^.fpg, NBBY);
    cgp_free := addr(cgp^.free[0]);
    while chunk_start + num_bytes_set <= freemap_size do begin
	i := 0;
	found_used_space := false;
	while (i < num_bytes_set) and not found_used_space do
	    if cgp_free^[chunk_start+i] <> hex('ff') then begin
		found_used_space := true;
		{ start looking AFTER this byte }
		chunk_start := chunk_start + i + 1;
	    end
	    else
		i := i + 1;
	if not found_used_space then begin
	    result := cg * fs^.fpg + chunk_start*NBBY;
	    goto 999;
	end;
    end;
999:
    if cgp <> nil then
	put_cgroup(cgp, [release]);
end;


{
{ See if space exists for a requested preallocation.
{ We are given the size requested.
{ Return a boolean telling whether space is there.
{ Pass back block and fragment count for convenience.
{ This check is made AFTER the file is created, so we
{ do not worry about space in the parent directory.
}
function space_exists(filebytes: integer;
		      var blkcount, fragcount: integer): boolean;
label
    999;
var
    fs: super_block_ptr_type;
    extra, bn: integer;
    exists: boolean;
begin
    space_exists := false;
    fs := current_super;

    { filebytes: how many big blocks, how many frags }
    filebytes := fragroundup(fs, filebytes);
    blkcount := lblkno(fs, filebytes);
    fragcount := numfrags(fs, blkoff(fs, filebytes));
    if (blkcount > NDADDR) and (fragcount <> 0) then begin
	blkcount := blkcount + 1;
	fragcount := 0;
    end;

    { plus indirect blocks }
    extra := 0;
    bn := blkcount - NDADDR;
    if bn > 0 then begin
	{ first indirect block }
	extra := 1;
	bn := bn - fs^.nindir;
	if bn > 0 then
	    { second indir block, plus one for each nindir blocks }
	    extra := 2 + howmany(bn, fs^.nindir);
    end;

    { this space must exist somewhere on disc }
    with fs^.cstotal do begin
	if (blkcount + extra > nbfree)
	or ((blkcount + extra = nbfree) and (fragcount > nffree)) then
	    goto 999;

	{ temporarily tamper with nbfree/nffree so freespace call works }
	nbfree := nbfree - (blkcount + extra);
	nffree := nffree - fragcount;
	space_exists := (freespace(fs, fs^.minfree) >= 0);
	nbfree := nbfree + (blkcount + extra);
	nffree := nffree + fragcount;
	{ end of tampering with nbfree }

    end;
999:
end;


{
{ Preallocation
{ We are given the file and the number of bytes.
{ We return a boolean showing success.
{ If the space exists in a single chunk, we use it.
{ This is done by setting "prealloc_pref" to the desired
{ address, then calling bmap, which calls "blkpref" to
{ calculate the preferred block.  bpref uses prealloc_pref,
{ if non-zero.  If prealloc_pref is 0, it is ignored,
{ and bmap works as usual.
}
function preallocate(ip: inode_ptr_type;
		     filebytes: integer): boolean;
label
    999;
var
    fs: super_block_ptr_type;
    lbn, size: integer;
    blkcount, fragcount: integer;
begin
    preallocate := false;
    fs := current_super;

    { is there space? }
    if not space_exists(filebytes, blkcount, fragcount) then
	goto 999;

    { see if we can grab a single chunk }
    prealloc_pref := hashalloc(ip, 0, 0,
			       blkstofrags(fs, blkcount) + fragcount,
			       prealloccg);

    { call bmap to do the work }
    for lbn := 0 to blkcount - 1 do
	if bmap(ip, lbn, B_WRITE, fs^.bsize) = BMAP_ERROR then begin
$if debug$
	    report('prealloc gets bmap error, blks');
$end$
	    goto 999;
	end;
    if fragcount <> 0 then
	if bmap(ip, blkcount, B_WRITE, blkoff(fs, filebytes)) = BMAP_ERROR then begin
$if debug$
	    report('prealloc gets bmap error, frags');
$end$
	    goto 999;
	end;

    preallocate := true;

999:
    { reset prealloc_pref so blkpref routines will work normally }
    prealloc_pref := 0;
end;


{----------------------------------------------------------------------}
{
{ FILE DELETION
}

{
{ Read or write a directory.  rw is B_READ or B_WRITE.
{ ip is the inode.
{ offset is the logical byte offset within the file.
{ Returns a data blk ptr, which caller must release.
{ Returns nil on failure.
{ Caller must update inode size
}
function rdwri(rw: bmap_mode;
	       ip: inode_ptr_type;
	       offset, len: integer): cache_blk_ptr_type;
label
    999;
var
    fs: super_block_ptr_type;
    lbn: lblk_type;
    bn: frag_type;
    on: integer;
begin
$if debug$
    if (rw <> B_READ) and (rw <> B_WRITE) then
	panic('rwip');
$end$

    rdwri := nil;
    fs := current_super;

    { lbn is logical blk within file }
    lbn := lblkno(fs, offset);
    { on is the offset within lbn }
    on := blkoff(fs, offset);

$if debug$
    { no xfer can cross cache blk boundary }
    if (on div cache_blk_size) <> ((on+len-1) div cache_blk_size) then
	panic('rwdri crossing cache boundary');
    { no xfer can read past eof }
    if (rw = B_READ) and (offset + len > ip^.size.ls) then
	panic('rdwri reading past eof');
    { no xfer can cross logical block boundary }
    if on + len > fs^.bsize then
	panic('rdwri going over lblk boundary');
$end$

    { get the disk block number }
    bn := bmap(ip, lbn, rw, on+len);
    if bn = BMAP_HOLE then begin
$if debug$
	panic('rdwri bmap error');
$end$
	goto 999;
    end;
    if bn = BMAP_ERROR then
	goto 999;

    rdwri := get_datablk(bn, on);
999:
end;

{
{ Free an inode.
{
{ The specified inode is placed back in the free map.
}
procedure ifree(ip: inode_ptr_type;
		ino, mode: integer);
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    cg: integer;
begin
    fs := current_super;
    if ino >= (fs^.ipg * fs^.ncg) then begin
$if debug$
	writeln('ino = ', ino:1, ', fs = ', fs^.fname);
	panic('ifree: range');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    { get the cgroup }
    cg := itog(fs, ino);
    cgp := get_cgroup(cg);

    { update all the counts }
    ino := ino mod fs^.ipg;
    if isclr(cgp^.iused, ino) then begin
$if debug$
	writeln('ino = ', ino:1, ', fs = ', fs^.fname);
	panic('ifree: freeing free inode');
$end$
	hfs_corrupt(fs);
    end;
    clrbit(cgp^.iused, ino);
    with cgp^.cs do
	nifree := nifree + 1;
    with fs^.cstotal do
	nifree := nifree + 1;
    with fs_cs(fs, cg)^ do
	nifree := nifree + 1;
    if binand(mode, IFMT) = IFDIR then begin
	with cgp^.cs do
	    ndir := ndir - 1;
	with fs^.cstotal do
	    ndir := ndir - 1;
	with fs_cs(fs, cg)^ do
	    ndir := ndir - 1;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty,release]);
999:
end;

{
{ Release blocks associated with the inode ip and
{ stored in the indirect block bn.  Blocks are free'd
{ in LIFO order up to (but not including) lastbn,
{ the frag offset from the beginning of the group of blocks
{ pointed to by this block.  If
{ level is greater than SINGLE, the block is an indirect
{ block and recursive calls to indirtrunc must be used to
{ cleanse other indirect blocks.
{
{ NB: triple indirect blocks are untested.
{ lastbn < 0 means free all blocks.
{ Returns number of device blocks freed.
{
{ This routine zeros parts of an indirect block which we could,
{ if we were a little more careful, deduce was already zero.
{ The current code doesn't write these parts back out, but a better
{ fix would be to not even read them in.
}
function indirtrunc(ip: inode_ptr_type;
		    bn: frag_type;
		    lastbn, level: integer): integer;
label
    999;
const
    ptrs_per_cache = cache_blk_size div bytes_per_ptr;
var
    i: integer;
    fs: super_block_ptr_type;
    nb: frag_type;
    last, factor: integer;
    blocksreleased, nblocks: integer;
    bap: indir_ptr_type;
    cbeg, cend, zbeg, ibeg, iend: integer;
    bapcopy: array[0..ptrs_per_cache-1] of integer;
    bap_changed: boolean;
begin
    fs := current_super;
    blocksreleased := 0;

    {
    { Calculate index in current block of last
    { block to be kept.  -1 indicates the entire
    { block so we need not calculate the index.
    }
    factor := 1;
    for i := SINGLE to level - 1 do
	factor := factor * fs^.nindir;
    last := lastbn;
    if lastbn > 0 then
	    last := last div factor;
    nblocks := btodb(fs^.bsize);

    {
    { Loop over the indir block backwards.  First, zero the
    { ptrs and force the block back to disk.
    { Then free the blocks.  The order ensures that
    { no indir addresses point to free blocks.
    { cend -- index in indir of last address in cache blk
    { cbeg -- index in indir of first address in cache blk
    { zbeg -- index in indir of where we start zeroing in cache blk
    { ibeg, iend -- indices in the cache blk of zbeg, cend
    { indir[last] is NOT to be zeroed (last might even be -1).
    }
    cend := fs^.nindir - 1;
    bap := nil;
    ibeg := -1;
    while cend > last do begin

	{ get new cache blk }
	if bap <> nil then
	    put_datablk(cache_blk_ptr_type(bap), [release]);
	bap := indir_ptr_type(get_datablk(bn, cend*bytes_per_ptr));

	{ find limits of cache blk relative to indir blk }
	cbeg := cend - ptrs_per_cache + 1;
	zbeg := max(cbeg, last + 1);

	{ zbeg and cend are now both covered by cache blk }
	ibeg := zbeg mod ptrs_per_cache;
	iend := cend mod ptrs_per_cache;

	{ copy old ptrs so can release blocks }
	moveleft(bap^, bapcopy, cache_blk_size);

	{ zero them on disk }
	bap_changed := false;
	for i := ibeg to iend do
	    if bap^[i] <> 0 then begin
		bap^[i] := 0;
		bap_changed := true;
	    end;
	if bap_changed then
	    put_datablk(cache_blk_ptr_type(bap), [dirty,immediate]);

	{ release the blocks }
	for i := ibeg to iend do begin
	    nb := bapcopy[i];
	    if nb <> 0 then begin
		if level > SINGLE then
		    blocksreleased := blocksreleased +
			indirtrunc(ip, nb, -1, level-1);
		xfree(ip, nb, fs^.bsize);
		blocksreleased := blocksreleased + nblocks;
	    end;
	end;

	cend := cend - ptrs_per_cache;
    end;

    {
    { Recursively free last partial block.
    { its index is ibeg-1, but that might be off the cache block
    }
    if (level > SINGLE) and (lastbn >= 0) then begin
	i := ibeg - 1;
	if i < 0 then begin
	    { not in cache block }
	    if bap <> nil then
		put_datablk(cache_blk_ptr_type(bap), [release]);
	    bap := indir_ptr_type(get_datablk(bn, last*bytes_per_ptr));
	    i := last mod ptrs_per_cache;
	end;
	last := lastbn mod factor;
	nb := bap^[i];
	put_datablk(cache_blk_ptr_type(bap), [release]);
	if nb <> 0 then
	    blocksreleased := blocksreleased +
		indirtrunc(ip, nb, last, level - 1);
    end
    else
	if bap <> nil then
	    put_datablk(cache_blk_ptr_type(bap), [release]);
999:
    indirtrunc := blocksreleased;
end;

{
{ Truncate the inode ip to at most
{ length size.  Free affected disk
{ blocks -- the blocks of the file
{ are removed in reverse order.
{
{ NB: triple indirect blocks are untested.
}
procedure itrunc(oip: inode_ptr_type;
		 length: integer);
label
    555, 999;
var
    i, lastblock, bn, obn, nbn: integer;
    lastiblock: array [SINGLE..TRIPLE] of integer;
    fs: super_block_ptr_type;
    ip: inode_ptr_type;
    tip: inode_type;
    blocksreleased, nblocks: integer;
    size, level, oldspace, newspace: integer;
begin
    { count blocks released so can update inode }
    blocksreleased := 0;

    { no work to do? }
    if oip^.size.ls <= length then
	    goto 999;

    {
    { Calculate index into inode's block list of
    { last direct and indirect blocks (if any)
    { which we want to keep.  Lastblock is -1 when
    { the file is truncated to 0.
    }
    fs := current_super;
    lastblock := lblkno(fs, length + fs^.bsize - 1) - 1;
    lastiblock[SINGLE] := lastblock - NDADDR;
    lastiblock[DOUBLE] := lastiblock[SINGLE] - fs^.nindir;
    lastiblock[TRIPLE] := lastiblock[DOUBLE] - fs^.nindir * fs^.nindir;
    { device blocks per big block }
    nblocks := btodb(fs^.bsize);

    {
    { Update size of file and block pointers
    { on disk before we start freeing blocks.
    { If we crash before free'ing blocks below,
    { the blocks will be returned to the free list.
    { negative lastiblock values are also normalized to -1
    { (meaning everything in this block must be deleted)
    { for calls to indirtrunc below.
    }
    { tip has copy of block addresses we're about to zero }
    tip := oip^;
    for level := TRIPLE downto SINGLE do
	if lastiblock[level] < 0 then begin
	    { this indir block will go }
	    oip^.ib[level] := 0;
	    lastiblock[level] := -1;
	end;
    for i := NDADDR - 1 downto lastblock + 1 do
	oip^.db[i] := 0;
    oip^.size.ls := length;
    {
    { i_blocks will be 0 since file size is being truncated
    { to 0, so might as well have i_blocks and i_size
    { consistent when write out inode.
    }
    if length = 0 then
	oip^.blocks := 0;
    put_inode(oip, [dirty,immediate]);

    { now we actually release the blocks }
    ip := addr(tip);

    {
    { Indirect blocks first.
    }
    for level := TRIPLE downto SINGLE do begin
	bn := ip^.ib[level];
	if bn <> 0 then begin
	    { release blocks addressed by indir block }
	    blocksreleased := blocksreleased +
		indirtrunc(ip, bn, lastiblock[level], level);
	    { release indir block }
	    if lastiblock[level] < 0 then begin
		ip^.ib[level] := 0;
		xfree(ip, bn, fs^.bsize);
		blocksreleased := blocksreleased + nblocks;
	    end;

	end;
	{ finished? }
	if lastiblock[level] >= 0 then
		goto 555;
    end;

    {
    { All whole direct blocks or frags.
    }
    for i := NDADDR - 1 downto lastblock + 1 do begin
	bn := ip^.db[i];
	if bn <> 0 then begin
	    ip^.db[i] := 0;
	    size := blksize(fs, ip, i);
	    xfree(ip, bn, size);
	    blocksreleased := blocksreleased + btodb(size);
	end;
    end;
    { freed everything? }
    if lastblock < 0 then
	goto 555;

    {
    { Finally, look for a change in size of the
    { last direct block; release any frags.
    }
    obn := ip^.db[lastblock];
    if obn <> 0 then begin
	{
	{ Calculate amount of space we're giving
	{ back as old block size minus new block size.
	}
	oldspace := blksize(fs, ip, lastblock);
	ip^.size.ls := length;
	newspace := blksize(fs, ip, lastblock);
$if debug$
	if newspace = 0 then
	    panic('itrunc: newspace');
$end$
	if oldspace - newspace > 0 then begin
	    {
	    { Try to put newspace into a fragment cluster.
	    { If it won't fit, just break up the current block.
	    { In second case, block number of space to be freed is
	    { the old block # plus the number of frags
	    { required for the storage we're keeping.
	    }
	    if oldspace = fs^.bsize then
		nbn := alloc(oip, 0, newspace, false);
	    if (oldspace = fs^.bsize) and (nbn <> 0) then begin
		copy_user_data(fragstobytes(fs, obn),
			       fragstobytes(fs, nbn), newspace);
		xfree(oip, obn, oldspace);
		oip^.db[lastblock] := nbn;
		{ next line only to satisfy debugging check below }
		ip^.db[lastblock] := nbn;
		put_inode(oip, [dirty]);
		{ alloc already changes block count for newspace }
		blocksreleased := blocksreleased + btodb(oldspace);
	    end
	    else begin
		xfree(oip, obn + numfrags(fs, newspace), oldspace - newspace);
		blocksreleased := blocksreleased + btodb(oldspace - newspace);
	    end;
	end;
    end;

{done:}
555:
$if debug$
    { BEGIN PARANOIA }
    for level := SINGLE to TRIPLE do
	if ip^.ib[level] <> oip^.ib[level] then
	    panic('itrunc1');
    for i := 0 to NDADDR - 1 do
	if ip^.db[i] <> oip^.db[i] then
	    panic('itrunc2');
    { END PARANOIA }
$end$

    if length <> 0 then begin
	with oip^ do begin
	    blocks := blocks - blocksreleased;
	    if blocks < 0 then blocks := 0;       { sanity }
	end;
	put_inode(oip, [dirty]);
    end;
999:
end;


{
{ Truncate the file and free the inode.
}
procedure zapinode(ip: inode_ptr_type);
var
    mode: integer;
    saveioresult: integer;
    needs_trunc: boolean;
begin
    saveioresult := ioresult;
    ioresult := ord(inoerror);

    needs_trunc := has_blocks(ip) and (ip^.size.ls > 0);
    mode := ip^.mode;
    ip^.nlink := 0;
    ip^.mode := 0;
    if needs_trunc then
	itrunc(ip, 0)
    else begin
	{ next 2 lines useless but harmless for non-special files }
	ip^.db[0] := 0; {"rdev" field for special files}
	ip^.db[1] := 0; {"pseudo" field for special files}
	put_inode(ip, [dirty,immediate]);
    end;
    ifree(ip, binode_ptr_type(ip)^.inumber, mode);

    if ioresult = ord(inoerror) then
	ioresult := saveioresult;
end;


{
{ Remove the entry for inode ip from the directory pdir.
{ offset tells where it is.  We must change the previous
{ entry so that its reclen covers the one being deleted,
{ unless we are at a DIRBLKSIZE boundary, in which case
{ the previous entry is unchanged and our ino becomes 0.
{ Returns boolean indicating success.
}
function dirremove(ip, pdir: inode_ptr_type;
		   offset: integer): boolean;
label
    999;
var
    bp: cache_blk_ptr_type;
    dp, prevp: direntry_ptr_type;
    coffset, cblkstart: integer;
begin
    dirremove := false;

    { get slot to be removed }
    bp := rdwri(B_READ, pdir, offset, sizeof(direntrytype));
    if bp = nil then
	goto 999;

    coffset := offset mod cache_blk_size;
    dp := addr(bp^, coffset);
    cblkstart := coffset - (offset mod DIRBLKSIZE);
$if debug$
    if cblkstart < 0 then
	panic('dirremove');
$end$

    { show no longer in use }
    dp^.ino := 0;

    { adjust previous entry unless on DIRBLKSIZE boundary }
    if cblkstart < coffset then begin
	prevp := addr(bp^, cblkstart);
	{ point prev to previous entry }
	while integer(prevp) + prevp^.reclen < integer(dp) do
	    prevp := addr(prevp^, prevp^.reclen);
	if integer(prevp) + prevp^.reclen <> integer(dp) then begin
$if debug$
	    panic('bad dir in dirremove');
$end$
	    hfs_corrupt(current_super);
	    goto 999;
	end;
	{ lengthen previous entry }
	prevp^.reclen := prevp^.reclen + dp^.reclen;
    end;

    time_stamp(pdir, [ICHG,IMOD]);
    put_datablk(bp, [dirty,immediate,release]);
    dirremove := true;
999:
end;

{
{ drop a link to a file, zapping it if this is the last one.
}
procedure drop_link(ip: inode_ptr_type);
begin
    with ip^ do begin
	nlink := nlink - 1;
	if nlink = 0 then
	    zapinode(ip)
	else begin
	    time_stamp(ip, [ICHG]);
	    put_inode(ip, [dirty,immediate]);
	end;
    end;
end;



{
{ Delete a file (not a directory)
{ pdir is the parent directory, ip is the file to be deleted.
}
procedure unlink(ip, pdir: inode_ptr_type;
		 offset: integer);
begin
    if dirremove(ip, pdir, offset) then
	drop_link(ip);
end;


{----------------------------------------------------------------------}
{
{ FILE CREATION
}

{
{ Find a cylinder to place a directory.
{
{ The policy implemented by this algorithm is to select from
{ among those cylinder groups with above the average number of
{ free inodes, the one with the smallest number of directories.
{
{ Returns a preferred inumber (just the first inumber of
{ the preferred cg).
}
function dirpref(fs: super_block_ptr_type): integer;
var
    cg, minndir, mincg, avgifree: integer;
begin
    avgifree := fs^.cstotal.nifree div fs^.ncg;
    minndir := fs^.ipg;
    mincg := 0;
    for cg := 0 to fs^.ncg - 1 do
	with fs_cs(fs, cg)^ do
	    if (ndir < minndir) and
	       (nifree >= avgifree) then begin
		    mincg := cg;
		    minndir := ndir;
	    end;
    dirpref := fs^.ipg * mincg;
end;

{
{ Determine whether an inode can be allocated in a given cg.
{
{ Check to see if an inode is available, and if it is,
{ allocate it using the following policy:
{   1) allocate the requested inode.
{   2) allocate the next available inode after the requested
{      inode in the specified cylinder group.
{ Returns the inumber, or 0 if none there.
}
procedure ialloccg(ip: inode_ptr_type;
		   cg, ipref, mode: integer;
		   var result: integer);
label
    555, 999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    i: integer;
begin
    result := 0;
    fs := current_super;

    { any free? }
    if fs_cs(fs, cg)^.nifree = 0 then
	goto 999;

    { get cgroup }
    cgp := get_cgroup(cg);
    if cgp^.cs.nifree = 0 then begin
	hfs_corrupt(fs);
	put_cgroup(cgp, [release]);
	goto 999;
    end;

    { if have preference and it's free, take it }
    if ipref <> 0 then begin
	ipref := ipref mod fs^.ipg;
	if isclr(cgp^.iused, ipref) then
	    goto 555;
    end
    else
	ipref := cgp^.irotor;

    { look sequentially, starting at pref (or rotor if no pref) }
    for i := 0 to fs^.ipg - 1 do begin
	ipref := ipref + 1;
	if ipref >= fs^.ipg then
	    ipref := 0;
	if isclr(cgp^.iused, ipref) then begin
	    cgp^.irotor := ipref;
	    goto 555;
	end;
    end;
    put_cgroup(cgp, [release]);
    goto 999;

555:
    { have free inode in pref }
    setbit(cgp^.iused, ipref);
    with cgp^.cs do
	nifree := nifree - 1;
    with fs^.cstotal do
	nifree := nifree - 1;
    with fs_cs(fs, cg)^ do
	nifree := nifree - 1;
    fs^.fmod := FS_MODIFIED;
    if binand(mode, IFMT) = IFDIR then begin
	with cgp^.cs do
	    ndir := ndir + 1;
	with fs^.cstotal do
	    ndir := ndir + 1;
	with fs_cs(fs, cg)^ do
	    ndir := ndir + 1;
    end;
    put_cgroup(cgp, [dirty,release]);
    result := (cg * fs^.ipg + ipref);
999:
end;

{
{ Allocate an inode in the file system.
{
{ A preference may be optionally specified. If a preference is given
{ the following hierarchy is used to allocate an inode:
{   1) allocate the requested inode.
{   2) allocate an inode in the same cylinder group.
{   3) quadradically rehash into other cylinder groups, until an
{      available inode is located.
{ If no inode preference is given the following heirarchy is used
{ to allocate an inode:
{   1) allocate an inode in cylinder group 0.
{   2) quadratically rehash into other cylinder groups, until an
{      available inode is located.
{
{ Returns ptr to the inode, or nil if none left or error.
}
function ialloc(pip: inode_ptr_type;
		ipref, mode: integer): inode_ptr_type;
label
    555, 999;
var
    fs: super_block_ptr_type;
    ino, cg: integer;
    ip: inode_ptr_type;
begin
    fs := current_super;
    ialloc := nil;

    { no inodes? }
    if fs^.cstotal.nifree = 0 then
	goto 555;

    { get preferred cg }
    if ipref >= (fs^.ncg * fs^.ipg) then
	ipref := 0;
    cg := itog(fs, ipref);

    ino := hashalloc(pip, cg, ipref, mode, ialloccg);
    if ino = 0 then
	goto 555;

    {
    { Some consistency checks.
    }
    ip := get_inode(ino);
    { KERNEL CODE DOES IFREE(PIP, INO, 0) IF IP IS NIL }
    if ip^.mode <> 0 then begin
$if debug$
	writeln('mode = ', ip^.mode:1, ', inum = ',
		ino:1, ', fs = ', fs^.fname);
	panic('ialloc: dup alloc');
$end$
	hfs_corrupt(fs);
	goto 999;
    end;
    if ip^.blocks <> 0 then begin
$if debug$
	writeln('free inode ', fs^.fname, ':', ino:1,
		' had ', ip^.blocks:1, ' blocks.');
$end$
	ip^.blocks := 0;
	hfs_corrupt(fs);
    end;

    {
    { The following fields are cleared because of their use
    { with fifos.  If the system crashed then their old
    { values would still be there.
    }
    if (ip^.ib[0] <> 0) or (ip^.ib[1] <> 0) or (ip^.ib[2] <> 0) then begin
	ip^.ib[0] := 0;
	ip^.ib[1] := 0;
	ip^.ib[2] := 0;
	put_inode(ip, [dirty,immediate]);
    end;

    { set all time stamps }
    time_stamp(ip, [IACC,ICHG,IMOD]);
    ialloc := ip;
    goto 999;
555:
    { no inodes }
$if debug$
    fserr(fs, 'out of inodes');
$end$
    ioresult := ord(idirfull);
999:
end;

{
{ Write a directory entry.  ip is the inode
{ to which the new entry refers.  pdir (parent ip) is the inode
{ of the directory containing the new entry.
{ offset is the location of a free slot, or the size of
{ the directory if there is no free slot.  Note that,
{ because of the way directories are grown, if offset = dir size,
{ then the dir size is at a DIRBLKSIZE boundary.
{ Returns boolean indicating success.
}
function direnter(ip: inode_ptr_type;
		  var filename: string255;
		  pdir: inode_ptr_type;
		  var offset: integer): boolean;
label
    999;
var
    dp, ep: direntry_ptr_type;
    bp: cache_blk_ptr_type;
    coffset, i: integer;
begin
    direnter := false;

    { get the slot at given offset }
    if offset = pdir^.size.ls then
	bp := rdwri(B_WRITE, pdir, offset, DIRBLKSIZE)
    else
	bp := rdwri(B_WRITE, pdir, offset, sizeof(direntrytype));
    if bp = nil then
	goto 999;
    coffset := offset mod cache_blk_size;
    dp := addr(bp^, coffset);

    { if growing dir, set reclen to cover new dirblk }
    if offset = pdir^.size.ls then begin
	dp^.ino := 0;
	dp^.reclen := DIRBLKSIZE;
    end
    else
    if coffset + dp^.reclen > cache_blk_size then begin
$if debug$
	panic('direnter');
$end$
	hfs_corrupt(current_super);
	goto 999;
    end;

    { claim entry for this inode }
    if dp^.ino <> 0 then begin
	{ this entry must be shrunk and skipped }
	ep := addr(dp^, sizeof(direntrytype));
	ep^.reclen := dp^.reclen - sizeof(direntrytype);
	dp^.reclen := sizeof(direntrytype);
	dp := ep;
	offset := offset + sizeof(direntrytype);
    end;
    { dp is our entry, and has correct reclen }
    with dp^ do begin
	ino := binode_ptr_type(ip)^.inumber;
	i := 0;
	while (i < DIRSIZ) and (i+1 <= strlen(filename)) do begin
	    name[i] := filename[i+1];
	    i := i + 1;
	end;
	namlen := i;
	while i < DIRSIZ do begin
	    name[i] := chr(0);
	    i := i + 1;
	end;
	{ this is probably unnecessary }
	for i := 0 to DIR_PADSIZE - 1 do
	    pad[i] := chr(0);
    end;

    { update dir first }
    put_datablk(bp, [release,dirty,immediate]);
    time_stamp(pdir, [ICHG,IMOD]);

    { then dir size, if needed }
    if pdir^.size.ls < offset + sizeof(direntrytype) then begin
	pdir^.size.ls := offset + sizeof(direntrytype);
	put_inode(pdir, [dirty,immediate]);
    end;

    direnter := true;
999:
end;


{
{ Make a new file by creating inode and entering name.
{ Returns the inode ptr, or nil if none.
{ Passes back corrected value of offset -- where the file
{ REALLY is in the parent dir.
{ make_entry tells whether to make dir entry
{ filebytes is preallocated size, or maj/min device number
}
function maknode(var filename: string255;
		 mode: integer;
		 pdir: inode_ptr_type;
		 make_entry: boolean;
		 filebytes: integer;
		 var offset: integer): inode_ptr_type;
label
    999;
var
    ip: inode_ptr_type;
    ipref: integer;
    fs: super_block_ptr_type;
    fmode: integer;
begin
    maknode := nil;
    fs := current_super;
    fmode := binand(mode, IFMT);

    { get preferred cg }
    if fmode = IFDIR then
	ipref := dirpref(current_super)
    else
	ipref := binode_ptr_type(pdir)^.inumber;

    ip := ialloc(pdir, ipref, mode);
    if ip = nil then
	goto 999;

    mode := binand(mode, bincmp(get_umask));

    ip^.mode := mode;
    if make_entry then
	ip^.nlink := 1;
    ip^.uid := get_uid;
    ip^.gid := get_gid;

    { try to preallocate the requested size }
    if fmode = IFREG then begin
	if filebytes > 0 then begin
	    if preallocate(ip, filebytes) then
		{ preallocate succeeded }
		ip^.size.ls := filebytes
	    else begin
		{
		{ prealloc failed.  set ioresult to inoroom
		{ unless there was already some other ioresult
		}
		{ must set size so deallocation will work }
		ip^.size.ls := filebytes; {JT/SFB 4/16/87}
		zapinode(ip);
		put_inode(ip, [release]);
		if ioresult = ord(inoerror) then
		    ioresult := ord(inoroom);
		goto 999;
	    end;
	end;
    end
    else
    if (fmode = IFBLK) or (fmode = IFCHR) then
	ip^.db[0] := filebytes;

    {
    { Make sure inode goes to disk before directory entry.
    }
    put_inode(ip, [dirty,immediate]);
    if make_entry and not direnter(ip, filename, pdir, offset) then begin
	{
	{ Write error occurred trying to update directory
	{ so must deallocate the inode.
	}
	zapinode(ip);
	put_inode(ip, [release]);
	goto 999;
    end;
    maknode := ip;
999:
end;


{
{ Create a new file.  We are given the name and mode, the parent inode, and
{ a size for preallocation.
{ We return the new inumber, or no_inode for failure.
{ Caller guarantees user has permission.
{ dir_entry tells whether to make a directory entry.
}
function create(var filename: string255;
		mode: integer;
		pdir: inode_ptr_type;
		offset, filebytes: integer;
		dir_entry: boolean): inode_ptr_type;
label
    999;
var
    ip: inode_ptr_type;
    fmode: integer;
    result: boolean;
begin
    create := nil;

    { be sure parent is a directory }
    if (binand(pdir^.mode, IFMT) <> IFDIR)
    or (binand(mode, IFMT) = IFDIR) then begin
$if debug$
	panic('create_file');
$end$
	ioresult := ord(inotondir);
	goto 999;
    end;

    { get a new inode and enter into this directory }
    if binand(mode, IFMT) = 0 then
	mode := binior(mode, IFREG);
    ip := maknode(filename, mode, pdir, dir_entry, filebytes, offset);

    create := ip;
999:
end;

function create_file(var filename: string255;
		     mode: integer;
		     pdir: inode_ptr_type;
		     offset, filebytes: integer): inode_ptr_type;
begin
    create_file := create(filename, mode, pdir, offset, filebytes, true);
end;

{
{ Link the file ip into the directory pdir under the
{ given simple name.  Caller guarantees that the name
{ doesn't already exist in this directory.
}
procedure link_file(ip: inode_ptr_type;
		    var filename: string255;
		    pdir: inode_ptr_type;
		    offset: integer);
label
    999;
begin
    if binand(ip^.mode, IFMT) = IFDIR then begin
$if debug$
	panic('link_file -- directory');
$end$
	ioresult := ord(inotondir);
	goto 999;
    end;

    if not direnter(ip, filename, pdir, offset) then
	goto 999;

    ip^.nlink := ip^.nlink + 1;
    time_stamp(ip, [ICHG]);
    put_inode(ip, [dirty,immediate]);
999:
end;

{------------------------------------------------------------------------}
{
{ DIRECTORY CREATION AND DELETION
}


{
{ Create a directory with the given mode.  pdir is the parent.
{ Returns ptr to inode of new dir.
}
function create_dir(var filename: string255;
		    mode: integer;
		    pdir: inode_ptr_type;
		    offset: integer): integer;
label
    888, 999;
var
    fs: super_block_ptr_type;
    ip: inode_ptr_type;
    bp: cache_blk_ptr_type;
    oldior: integer;    {to "protect" ioresult during cleanup. SFB}
begin
    create_dir := no_inode;
    fs := current_super;

    { normalize mode }
    if binand(pdir^.mode, IFMT) <> IFDIR then begin
$if debug$
	panic('create_dir');
$end$
	ioresult := ord(ifilenotdir);
	goto 999;
    end;

    mode := binand(mode, octal('777'));
    mode := binior(mode, IFDIR);

    {
    { Must simulate part of maknode here
    { in order to acquire the inode, but
    { not have it entered in the parent
    { directory.  The entry is made later
    { after writing "." and ".." entries out.
    }
    { get an inode for the directory }
    ip := ialloc(pdir, dirpref(fs), mode);
    mode := binand(mode, bincmp(get_umask));

    ip^.mode := mode;
    ip^.nlink := 2;
    ip^.uid := get_uid;
    ip^.gid := get_gid;
    put_inode(ip, [dirty,immediate]);

    {
    { Bump link count in parent directory
    { to reflect work done below.  Should
    { be done before reference is created
    { so repair is possible if we crash.
    }
    pdir^.nlink := pdir^.nlink + 1;
    put_inode(pdir, [dirty,immediate]);

    {
    { Initialize directory with "."
    { and ".." from static template.
    }
    dirtemplate[DOT].ino := binode_ptr_type(ip)^.inumber;
    dirtemplate[DOTDOT].ino := binode_ptr_type(pdir)^.inumber;

    bp := rdwri(B_WRITE, ip, 0, sizeof(dirtemplate));
    if bp = nil then
	goto 888;
    moveleft(dirtemplate, bp^, sizeof(dirtemplate));
    put_datablk(bp, [release,dirty,immediate]);

    ip^.size.ls := sizeof(dirtemplate);
    put_inode(ip, [dirty]);

    {
    { Directory all set up, now
    { install the entry for it in
    { the parent directory.
    }
    if not direnter(ip, filename, pdir, offset) then
	goto 888;

    create_dir := binode_ptr_type(ip)^.inumber;
    put_inode(ip, [release]);
    goto 999;

888:
    {
    { Got an error.  Ditch ip (the new dir) and reset link
    { count in parent directory.
    }
    oldior:=ioresult;   {SFB}
    ioresult:=ord(inoerror);    {SFB per Jim Tear example}
    zapinode(ip);
    put_inode(ip, [release]);
    pdir^.nlink := pdir^.nlink - 1;
    put_inode(pdir, [dirty,immediate]);
    if ioresult=ord(inoerror) then      {SFB}
     ioresult:=oldior;

999:
end;


{
{ Check if a directory is empty or not.
}
function dirempty(ip: inode_ptr_type): boolean;
var
    dummy: integer;
    empty: boolean;
    thisname: string255;
{------------------------}
procedure check(dp: direntry_ptr_type;
		offset: integer;
		anyvar inparams: integer;
		anyvar empty: boolean;
		var keep_going: boolean);
begin
    with dp^ do
	if ino <> 0 then begin
	    pac_to_string(name, namlen, thisname);
	    if (thisname <> '.') and (thisname <> '..') then begin
		empty := false;
		keep_going := false;
	    end;
	end;
end;
{------------------------}
begin
    empty := true;
    scan_dir(ip, check, dummy, empty);
    dirempty := empty;
end;

{
{ Remove a directory, including its entry in the parent dir.
{ Return boolean indicating success.
}
procedure rmdir(ip, pdir: inode_ptr_type;
		offset: integer);
label
    999;
begin
    {
    { No rmdir "." please.
    }
    if pdir = ip then begin
	ioresult := ord(inotclosed);
	goto 999;
    end;

    {
    { Verify the directory is empty (and valid).
    { (Rmdir ".." won't be valid since
    {  ".." will contain a reference to
    {  the current directory and thus be
    {  non-empty.)
    }
    if (ip^.nlink > 2) or not dirempty(ip) then begin
	ioresult := ord(idirnotempty);
	goto 999;
    end;

    {
    { Delete reference to directory before purging
    { inode.  If we crash in between, the directory
    { will be reattached to lost+found,
    }
    if not dirremove(ip, pdir, offset) then
	goto 999;
    pdir^.nlink := pdir^.nlink - 1;
    put_inode(pdir, [dirty,immediate]);

    {
    { Truncate inode.  The only stuff left
    { in the directory is "." and "..".  The
    { "." reference is inconsequential since
    { we're quashing it.  The ".." reference
    { has already been adjusted above.
    }
    zapinode(ip);
999:
end;

{
{ Delete a file or directory.
}
procedure delete_file(ip, pdir: inode_ptr_type;
		      offset: integer);
begin
    if binand(ip^.mode, IFMT) = IFDIR then
	rmdir(ip, pdir, offset)
    else
	unlink(ip, pdir, offset);
end;

{---------------------------------------------------------------}
{
{ CHANGE FILE SIZE
}

{
{ Truncate the file to the given length.  Ensure that
{ the file doesn't have a hole at its very end.
{ Returns boolean indicating success.
{ Intended for close(f, 'crunch').
{ Grows the file if needed; caller must ensure this is OK.
}
function change_file_size(ip: inode_ptr_type;
			  size: integer): boolean;
label
    999;
var
    frag: frag_type;
    fs: super_block_ptr_type;
begin
    change_file_size := true;
    if not has_blocks(ip) then begin
$if debug$
	panic('change_file_size');
$end$
	ioresult := ord(inoaccess);
	goto 999;
    end;

    if size = ip^.size.ls then
	goto 999;

    { truncate file }
    itrunc(ip, size);

    { be sure last byte is not a hole }
    if size > 0 then begin
	fs := current_super;
	frag := bmap(ip,
		     lblkno(fs, size - 1),
		     B_WRITE,
		     blkoff(fs, size-1)+1);
	if frag = BMAP_ERROR then begin
	    change_file_size := false;
	    goto 999;
	end;
    end;

    if size <> ip^.size.ls then begin
	ip^.size.ls := size;
	put_inode(ip, [dirty]);
    end;

    time_stamp(ip, [IMOD,ICHG]);
999:
end;

{--------------------------------------------------------------------}
{
{ GET_DBNUM
}

{
{ get_dbnum
{ translates a logical file position into a physical disc position
{ (both in bytes).  Params are:
{       inode of file
{       logical position in file
{       length of desired transfer
{       type of transfer (B_READ, B_WRITE, B_ZWRITE)
{ Returns:
{       fragment number
{       or BMAP_HOLE when reading a hole,
{       or BMAP_ERROR on error
{ The length of the transfer is ignored with B_READ.
{ It is important with B_WRITE, because we may have to allocate new blocks.
{ B_WRITE and B_ZWRITE are the same, except that B_ZWRITE always zeroes
{ new blocks, while B_WRITE does not.  B_WRITE causes the zeroing info
{ to appear in
{       zstart          byte start of new block
{       zlength         length of new block in bytes, or 0 if none
{ Caller guarantees that the requested transfer does NOT cross
{ a bsize (normally 8K) boundary.
{ Caller must check for reading past EOF.
{ We update the inode size when writing past EOF.
}
function get_dbnum(ip: inode_ptr_type;
		   position: integer;
		   rwflag: bmap_mode;
		   length: integer): integer;
var
    lblk: lblk_type;
    dblk: frag_type;
    xfer_length: integer;
begin
    try
	lblk := lblkno(current_super, position);
	xfer_length := blkoff(current_super, position) + length;
	if xfer_length > current_super^.bsize then begin
$if debug$
	    panic('get_dbnum');
$end$
	    ioresult := ord(zcatchall);
	    escape(0);
	end;
	dblk := bmap(ip, lblk, rwflag, xfer_length);

	if (dblk <> BMAP_ERROR)
	and (dblk <> BMAP_HOLE)
	and (rwflag <> B_READ) then
	    { update EOF if writing past it }
	    if ip^.size.ls < position + length then begin
		ip^.size.ls := position + length;
		put_inode(ip, [dirty]);
	    end;

	get_dbnum := dblk;
    recover
	get_dbnum := BMAP_ERROR;
end;

{---------------------------------------------------------------------------}
{
{ SCAN_DIR
{
{ directory scanner
{ scans directories, calling given procedure with given params.
{ procedure sets keep_going false when ready to stop
}
procedure scan_dir(pdir: inode_ptr_type;
		   scanner: scan_proc;
		   anyvar inparams, outparams: integer);
label
    999;
var
    dp: direntry_ptr_type;
    begp, endp: cache_blk_ptr_type;
    diskblk, thisread, offset: integer;
    fs: super_block_ptr_type;
    keep_going: boolean;
begin
    offset := 0;
    begp := nil;
    fs := current_super;
    keep_going := true;

    { scan through directory }
    while offset < pdir^.size.ls do begin

	{ bytes to read this time }
	thisread := min(cache_blk_size, pdir^.size.ls - offset);

	{ get next cache blk }
	if begp <> nil then
	    put_datablk(begp, [release]);
	diskblk := get_dbnum(pdir, offset, B_READ, thisread);
	begp := get_datablk(diskblk, blkoff(fs, offset));

	dp := direntry_ptr_type(begp);
	endp := addr(begp^, thisread);

	{ scan through this cache blk }
	while integer(dp) < integer(endp) do begin
	    call (scanner, dp, offset, inparams, outparams, keep_going);
	    if not keep_going then
		goto 999;
	    offset := offset + dp^.reclen;
	    dp := addr(dp^, dp^.reclen);
	end;
    end;

999:
    if begp <> nil then
	put_datablk(begp, [release]);
end;

{-----------------------------------------------------------------------}
{
{ FOUNDNAME
{ find name in directory pdir
{ returns true if found
{ sets, in pathinfo
{       ino -- inumber of file found
{       parent_ino -- inumber of parent dir
{               can be incorrect if name is ..
{       offset -- dir offset (see comments at traverse_path)
{ dir_required -- if entry is not a dir, pretend we couldn't find it.
{ NOTE: we return no ioresult if file not found, since many callers
{ use this routine when it's illegal for the file to exist anyway.
}
function foundname(var name: string;
		   dir_required: boolean;
		   pdir: inode_ptr_type;
		   var pathinfo: pathinfotype): boolean;
label
    999;
type
    inrec_type = record
	nameptr: string255ptr;
	want_dir: boolean;
    end;
    outrec_type = record
	ino: integer;
	diroff: integer;
    end;
var
    inrec: inrec_type;
    outrec: outrec_type;
    ip: inode_ptr_type;
{--------------------}
procedure check_entry(dp: direntry_ptr_type;
		      offset: integer;
		      anyvar inrec: inrec_type;
		      anyvar outrec: outrec_type;
		      var keep_going: boolean);
var
    thisname: string255;
    ip: inode_ptr_type;
    entry_wanted: boolean;
begin
    with dp^ do begin
	{ is this the entry we want? }
	pac_to_string(name, namlen, thisname);
	if (ino <> 0) and (thisname = inrec.nameptr^) then
	    if inrec.want_dir then begin
		ip := get_inode(ino);
		entry_wanted := (itype(ip) = IFDIR);
		{ stop looking, whether it's a dir or not }
		keep_going := false;
		put_inode(ip, [release]);
	    end
	    else
		entry_wanted := true
	else
	    entry_wanted := false;

	if entry_wanted then begin
	    keep_going := false;
	    outrec.ino := ino;
	    outrec.diroff := offset;
	end
	else
	if (ino = 0) or (reclen > sizeof(direntrytype)) then
	    outrec.diroff := offset;
    end;
end;
{--------------------}
begin {foundname}
    foundname := false;

    if itype(pdir) <> IFDIR then begin
	ioresult := ord(ifilenotdir);
	goto 999;
    end;

    inrec.nameptr := addr(name);
    inrec.want_dir := dir_required;

    outrec.diroff := -1;
    outrec.ino := no_inode;

    scan_dir(pdir, check_entry, inrec, outrec);

    { diroff meaningful whether file found or not }
    if outrec.diroff = -1 then
	pathinfo.diroff := pdir^.size.ls
    else
	pathinfo.diroff := outrec.diroff;

    if outrec.ino <> no_inode then begin
	foundname := true;
	{ ino, parent_ino meaningful only if file found }
	pathinfo.ino := outrec.ino;
	pathinfo.parent_ino := inumber(pdir);
    end;
999:
end;

{
{ allocate an anonymous inode.
{ we use pdir to help choose the cgroup.
}
function alloc_inode(pdir: inode_ptr_type;
		     mode: integer;
		     bytes: integer): inode_ptr_type;
var
    dummyname: string255;
begin
    dummyname := '';
    alloc_inode := create(dummyname, mode, pdir, 0, bytes, false);
end;

{
{ deallocate an inode not in any directory
}
procedure dealloc_inode(var ip: inode_ptr_type);
label
    999;
begin
    if ip^.nlink <> 0 then begin
$if debug$
	panic('dealloc called on ip with links');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;
    zapinode(ip);
    put_inode(ip, [release]);
999:
    ip := nil;
end;


{
{ Enter a file in a directory.
{ ip is the file, pdir the directory.
{ name is the new name.
{ If a file with this name already exists, delete it.
}
procedure enter_file(ip, pdir: inode_ptr_type;
		     var name: string255);
label
    999;
var
    pathinfo: pathinfotype;
    blocknum: integer;
    cache_ptr: cache_blk_ptr_type;
    dir_ptr: direntry_ptr_type;
    old_inodep: inode_ptr_type;
begin
    old_inodep := nil;
    cache_ptr := nil;
    { don't touch directories }
    if itype(ip) = IFDIR then begin
	ioresult := ord(inotondir);
	goto 999;
    end;
    ip^.nlink := 1;
    put_inode(ip, [dirty,immediate]);

    if foundname(name, false, pdir, pathinfo) then begin
	{ file exists, so look at dir entry }
	blocknum := get_dbnum(pdir, pathinfo.diroff, B_READ, 0);
	if blocknum = BMAP_ERROR then
	    goto 999;
	cache_ptr := get_datablk(blocknum,
				 blkoff(current_super, pathinfo.diroff));
	dir_ptr := addr(cache_ptr^, pathinfo.diroff mod cache_blk_size);

	{ don't touch a directory }
	old_inodep := get_inode(dir_ptr^.ino);
	if itype(old_inodep) = IFDIR then begin
	    ioresult := ord(inotondir);
	    goto 999;
	end;

	{ drop old file, substitute new one }
	drop_link(old_inodep);
	dir_ptr^.ino := inumber(ip);
	put_datablk(cache_ptr, [dirty,immediate]);
    end
    else begin
	{ file not there }
	if not direnter(ip, name, pdir, pathinfo.diroff) then
	    ;
    end;
999:
    put_inode(old_inodep, [release]);
    put_datablk(cache_ptr, [release]);
end;

{
{ delete ip from pdir
{ We don't know dir offset, but we know the file's name.
}
procedure delete_filename(ip, pdir: inode_ptr_type;
			  var name: string255);
var
    pathinfo: pathinfotype;
begin
    if foundname(name, false, pdir, pathinfo) then
	delete_file(ip, pdir, pathinfo.diroff)
    else
	ioresult := ord(inofile);
end;

{-----------------------------------------------------------------------}
{
{ Tell whether user has given permission on given inode.
{ Sets ioresult to inopermission if not.
{ Uses HP-UX algorithm: look at the "most privileged" category
{     only, with no second or third try.
}
function permission(inodep: inode_ptr_type;
		    perm_needed: permission_type): boolean;
var
    themode: packed record case boolean of
	      true : (num: ushort);
	      false: (pad: 0..127;
		      usr: 0..7;
		      grp: 0..7;
		      oth: 0..7);
	     end;
    sameuser, samegroup: boolean;
    tmp_perm: boolean;
begin
    if get_uid = 0 {superuser} then
	permission := true
    else with inodep^ do begin
	themode.num    := mode;
	sameuser       := get_uid = uid;
	samegroup      := get_gid = gid;

	if sameuser then
	    tmp_perm := (iand(themode.usr, perm_needed) = perm_needed)
	else
	if samegroup then
	    tmp_perm := (iand(themode.grp, perm_needed) = perm_needed)
	else
	    tmp_perm := (iand(themode.oth, perm_needed) = perm_needed);
	if not tmp_perm then
	    ioresult := ord(inopermission);
	permission := tmp_perm;
    end;
end;

{
{ Does this inode have disk blocks?
}
function has_blocks(ip: inode_ptr_type): boolean;
var
    filetype: integer;
begin
    filetype := itype(ip);
    has_blocks := (filetype <> IFBLK) and
		  (filetype <> IFCHR);
end;


end.


@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 3984
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 3984
$modcal$

$linenum 5000$
$lines 54$

$partial_eval on$
$allow_packed on$

$range off$
$ovflcheck off$
$debug off$

module hfsalloc;

$search 'hfstuff', 'hfsupport', 'hfscalc', 'hfscache'$

import
    hfstuff,
    hfsupport,
    sysglobals,
    sysdevs,
    iocomasm,
    asm,
    hfscalc,
    hfscache;

export

const
    BMAP_HOLE = -1;             { bmap reading a hole }
    BMAP_ERROR = 0;             { bmap had error }

    no_permission = 0;
    x_permission  = 1;
    w_permission  = 2;
    r_permission  = 4;


type
    bmap_mode = (B_READ, B_WRITE, B_ZWRITE);
    time_stamp_type = (IACC, IMOD, ICHG);
    time_stamp_set = set of time_stamp_type;

    scan_proc = procedure(dp: direntry_ptr_type;
			  offset: integer;
			  anyvar inparams, outparams: integer;
			  var keep_going: boolean);

    pathinfotype = packed record
	ino: integer;
	diroff: integer;
	basename: string255;
	parent_ino: integer;
    end;

    permission_type = integer;

procedure init_hfsalloc;

function get_dbnum(ip: inode_ptr_type;
		   position: integer;
		   rwflag: bmap_mode;
		   length: integer): integer;

function create_file(var filename: string255;
		     mode: integer;
		     pdir: inode_ptr_type;
		     offset, filebytes: integer): inode_ptr_type;

function create_dir(var filename: string255;
		    mode: integer;
		    pdir: inode_ptr_type;
		    offset: integer): integer;

procedure link_file(ip: inode_ptr_type;
		    var filename: string255;
		    pdir: inode_ptr_type;
		    offset: integer);

function change_file_size(ip: inode_ptr_type;
			  size: integer): boolean;

procedure time_stamp(ip: inode_ptr_type;
		     which: time_stamp_set);

procedure scan_dir(pdir: inode_ptr_type;
		   scanner: scan_proc;
		   anyvar inparams, outparams: integer);

function alloc_inode(pdir: inode_ptr_type;
		     mode: integer;
		     bytes: integer): inode_ptr_type;

procedure dealloc_inode(var ip: inode_ptr_type);

procedure enter_file(ip, pdir: inode_ptr_type;
		     var name: string255);

procedure delete_file(ip, pdir: inode_ptr_type;
		      offset: integer);

procedure delete_filename(ip, pdir: inode_ptr_type;
			  var name: string255);

function foundname(var name: string;
		   dir_required: boolean;
		   pdir: inode_ptr_type;
		   var pathinfo: pathinfotype): boolean;

function permission(inodep: inode_ptr_type;
		    perm_needed: permission_type): boolean;

function has_blocks(ip: inode_ptr_type): boolean;

implement

const
    debug = false;

    bytes_per_ptr = 4;
    SINGLE = 0;
    DOUBLE = 1;
    TRIPLE = 2;
    DOT = 0;
    DOTDOT = 1;

type
    blk_type = integer;

    cluster_array_type = packed array[0..8] of shortint;

    fragtbl_type = packed array[0..255] of 0..255;
    fragtbl_ptr_type = ^fragtbl_type;
    fragtbl_array_type = array [1..8] of fragtbl_ptr_type;

    alloc_proc = procedure(ip: inode_ptr_type;
			   cg: integer;
			   bpref: frag_type;
			   size_or_mode: integer;
			   var result: integer);

    dirtemplate_type = array [DOT..DOTDOT] of direntrytype;



var
    around, inside: cluster_array_type;
    fragtbl8, fragtbl124: fragtbl_type;
    fragtbl: fragtbl_array_type;
    dirtemplate: dirtemplate_type;
    prealloc_pref: integer;

{
{ Map of calls
{ BLOCK ALLOCATION FOR READING AND WRITING
{ bmap
{       blkpref
{       realloccg
{               hashalloc(alloccg)
{               fragextend
{               xfree
{                       fragacct
{       alloc
{               hashalloc(alloccg)
{
{ alloccg
{       alloccgblk
{               mapsearch
{       mapsearch
{
{ FILE CREATION
{ create_file
{       maknode
{               dirpref
{               ialloc
{               direnter
{
{ FILE DELETION
{ delete_file
{       unlink
{               dirremove
{               zapinode
{                       itrunc
{                               xfree
{                               indirtrunc
{                                       xfree
{               ifree
{        rmdir
{               dirempty
{               dirremove
{               zapinode
{                       itrunc
{                               xfree
{                               indirtrunc
{                                       xfree
{
{ LINK
{ link_file
{       direnter
{
{ MAKE DIRECTORY
{ create_dir
{       ialloc
{       rdwri
{       direnter
{
{ CLOSE CRUNCH
{ change_file_size
{       itrunc
{       bmap
}


procedure init_hfsalloc;
const
    {
    { Bit patterns for identifying fragments in the block map
    { used as ((map & around) = inside)
    { inside[i] has an i-bit cluster, plus a 0 bit at the end.
    { around[i] is inside[i] with an extra 1 bit on each end.
    { if map & around[i] = inside[i], then there is an i-bit
    { cluster, no larger and no smaller, in map.
    }
    around_def = cluster_array_type[
	hex('03'), hex('07'), hex('0f'), hex('1f'),
	hex('3f'), hex('7f'), hex('ff'), hex('1ff'), hex('3ff')
    ];
    inside_def = cluster_array_type[
	hex('00'), hex('02'), hex('06'), hex('0e'),
	hex('1e'), hex('3e'), hex('7e'), hex('fe'), hex('1fe')
    ];

    {
    { Given a block map bit pattern, the frag tables tell whether a
    { particular size fragment is available.
    { fragtbl8 is for 8 frags/big block
    { fragtbl124 is for 1, 2, or 4
    {
    { fragtbl8 is used as:
    { if ((1 << (size - 1)) & fragtbl[fs^.frag][map]
    {   at least one fragment of the indicated size is available
    {
    { fragtbl124 is similar.  The left 4 bits are for 4 frags/block,
    { the next 2 for 2 frags/block, and the next 1 for 1 frag/block.
    { The rightmost bit is unused.
    {
    { These tables are used by scanc to
    {  quickly find an appropriate fragment.
    }
    fragtbl124_def = fragtbl_type[
	hex('00'), hex('16'), hex('16'), hex('2a'),
	hex('16'), hex('16'), hex('26'), hex('4e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('2a'), hex('3e'), hex('4e'), hex('8a'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('2a'), hex('3e'), hex('3e'), hex('2a'),
	hex('3e'), hex('3e'), hex('2e'), hex('6e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('2a'), hex('3e'), hex('6e'), hex('aa'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('26'), hex('36'), hex('36'), hex('2e'),
	hex('36'), hex('36'), hex('26'), hex('6e'),
	hex('36'), hex('36'), hex('36'), hex('3e'),
	hex('2e'), hex('3e'), hex('6e'), hex('ae'),
	hex('4e'), hex('5e'), hex('5e'), hex('6e'),
	hex('5e'), hex('5e'), hex('6e'), hex('4e'),
	hex('5e'), hex('5e'), hex('5e'), hex('7e'),
	hex('6e'), hex('7e'), hex('4e'), hex('ce'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('16'), hex('16'), hex('36'), hex('5e'),
	hex('16'), hex('16'), hex('16'), hex('3e'),
	hex('3e'), hex('3e'), hex('5e'), hex('9e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('3e'), hex('7e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('7e'), hex('be'),
	hex('2a'), hex('3e'), hex('3e'), hex('2a'),
	hex('3e'), hex('3e'), hex('2e'), hex('6e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('2a'), hex('3e'), hex('6e'), hex('aa'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('3e'), hex('7e'),
	hex('3e'), hex('3e'), hex('3e'), hex('3e'),
	hex('3e'), hex('3e'), hex('7e'), hex('be'),
	hex('4e'), hex('5e'), hex('5e'), hex('6e'),
	hex('5e'), hex('5e'), hex('6e'), hex('4e'),
	hex('5e'), hex('5e'), hex('5e'), hex('7e'),
	hex('6e'), hex('7e'), hex('4e'), hex('ce'),
	hex('8a'), hex('9e'), hex('9e'), hex('aa'),
	hex('9e'), hex('9e'), hex('ae'), hex('ce'),
	hex('9e'), hex('9e'), hex('9e'), hex('be'),
	hex('aa'), hex('be'), hex('ce'), hex('8a')];

    fragtbl8_def = fragtbl_type[
	hex('00'), hex('01'), hex('01'), hex('02'),
	hex('01'), hex('01'), hex('02'), hex('04'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('02'), hex('03'), hex('04'), hex('08'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('04'), hex('05'), hex('08'), hex('10'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('03'), hex('03'), hex('02'), hex('06'),
	hex('04'), hex('05'), hex('05'), hex('06'),
	hex('08'), hex('09'), hex('10'), hex('20'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('05'), hex('05'), hex('09'), hex('11'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('03'), hex('03'), hex('02'), hex('06'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('02'), hex('03'), hex('06'), hex('0a'),
	hex('04'), hex('05'), hex('05'), hex('06'),
	hex('05'), hex('05'), hex('06'), hex('04'),
	hex('08'), hex('09'), hex('09'), hex('0a'),
	hex('10'), hex('11'), hex('20'), hex('40'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('05'), hex('05'), hex('09'), hex('11'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('01'), hex('01'), hex('03'), hex('05'),
	hex('01'), hex('01'), hex('01'), hex('03'),
	hex('03'), hex('03'), hex('05'), hex('09'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('03'), hex('03'), hex('03'), hex('07'),
	hex('05'), hex('05'), hex('05'), hex('07'),
	hex('09'), hex('09'), hex('11'), hex('21'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('03'), hex('03'), hex('02'), hex('06'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('02'), hex('03'), hex('06'), hex('0a'),
	hex('03'), hex('03'), hex('03'), hex('03'),
	hex('03'), hex('03'), hex('03'), hex('07'),
	hex('02'), hex('03'), hex('03'), hex('02'),
	hex('06'), hex('07'), hex('0a'), hex('12'),
	hex('04'), hex('05'), hex('05'), hex('06'),
	hex('05'), hex('05'), hex('06'), hex('04'),
	hex('05'), hex('05'), hex('05'), hex('07'),
	hex('06'), hex('07'), hex('04'), hex('0c'),
	hex('08'), hex('09'), hex('09'), hex('0a'),
	hex('09'), hex('09'), hex('0a'), hex('0c'),
	hex('10'), hex('11'), hex('11'), hex('12'),
	hex('20'), hex('21'), hex('40'), hex('80')];

    dirtemplate_def = dirtemplate_type[
	direntrytype[
	    ino: 0,
	    reclen: 32,
	    namlen: 1,
	    name: '.'#0#0#0#0#0#0#0#0#0#0#0#0#0,
	    pad: #0#0#0#0#0#0#0#0#0#0
	],
	direntrytype[
	    ino: 0,
	    reclen: DIRBLKSIZE - 32,
	    namlen: 2,
	    name: '..'#0#0#0#0#0#0#0#0#0#0#0#0,
	    pad: #0#0#0#0#0#0#0#0#0#0
	]
    ];

begin
    around := around_def;
    inside := inside_def;

    fragtbl124 := fragtbl124_def;
    fragtbl8 := fragtbl8_def;

    fragtbl[1] := fragtbl_ptr_type(addr(fragtbl124));
    fragtbl[2] := fragtbl_ptr_type(addr(fragtbl124));
    fragtbl[3] := nil;
    fragtbl[4] := fragtbl_ptr_type(addr(fragtbl124));
    fragtbl[5] := nil;
    fragtbl[6] := nil;
    fragtbl[7] := nil;
    fragtbl[8] := fragtbl_ptr_type(addr(fragtbl8));

    dirtemplate := dirtemplate_def;

end;

{---------------------------------------------------------------}
{
{ ERROR AND MISCELLANEOUS ROUTINES
}

{
{ Something corrupt in the file system.
}
procedure hfs_corrupt(fs: super_block_ptr_type);
begin
$if debug$
    xreport('HFS CORRUPT');
$end$
    fs^.clean := chr(FS_NOTOK);
    fs^.fmod := FS_MODIFIED;
    put_superblock(fs, [immediate]);
    set_corrupt;
    ioresult := ord(icorrupt);
end;

{
{ Fserr prints the name of a file system with an error diagnostic.
{
{ The form of the error message is:
{       fs: error message
}
$if debug$
procedure fserr(fs: super_block_ptr_type; cp: string255);
begin
	writeln(fs^.fname, ': ', cp);
end;
$end$

{
{ Check that a specified block number is in range.
}
function badblock(fs: super_block_ptr_type;
		  bn: frag_type): boolean;
var
    bad: boolean;
begin
    bad := (bn >= fs^.size);
    if bad then begin
	hfs_corrupt(fs);
$if debug$
	writeln('bad block ', bn:1);
	fserr(fs, 'bad block');
$end$
    end;
    badblock := bad;
end;

{
{ Zeroes the disk at fragnum for size bytes.
{ For directories and indirect blocks.
{ Warning: if user data goes through here, we must
{ either put ALL user data through the cache, or we must
{ immediately invalidate the cache buffer.
{ Zeroes from the LAST cache blk to the FIRST, so that the
{ first block is sure to be left in the cache.
}
procedure zero_data(fragnum: frag_type;
		    size: integer);
label
    999;
var
    ip: cache_blk_ptr_type;
    cp: ^char;
    offset: integer;
    i, bytes: integer;
begin
$if debug$
    xreport('ZERO DATA');
$end$
    { set offset to highest cache blk multiple < size }
    offset := rounddownp2(size-1, cache_blk_size);
    while offset >= 0 do begin
	{ bytes = number of bytes this transfer }
	if size - offset < cache_blk_size then begin
	    bytes := size - offset;
	    ip := get_datablk(fragnum, offset);
	end
	else begin
	    bytes := cache_blk_size;
	    ip := get_edatablk(fragnum, offset);
	end;
	cp := addr(ip^);
	for i := 1 to bytes do begin
	    cp^ := chr(0);
	    cp := addr(cp^, 1);
	end;
	put_datablk(ip, [release,dirty,immediate]);
	offset := offset - cache_blk_size;
    end;
999:
end;


{
{ Copies size bytes from fragment ofrag to fragment nfrag.
{ Copies through cache.  Use copy_user_data to go around cache.
{ After copy, source data blocks now free on disc, so don't leave
{ them valid in the cache.
}
procedure copy_control_data(ofrag, nfrag: frag_type;
			    size: integer);
label
    999;
type
    charptr = ^char;
var
    fp, tp: cache_blk_ptr_type;
    offset: integer;
    bytes: integer;
begin
$if debug$
    xreport('COPY CONTROL DATA');
$end$
    offset := 0;
    while offset < size do begin
	fp := get_datablk(ofrag, offset);
	if size - offset < cache_blk_size then begin
	    bytes := size - offset;
	    tp := get_datablk(nfrag, offset);
	end
	else begin
	    bytes := cache_blk_size;
	    tp := get_edatablk(nfrag, offset);
	end;
	moveleft(fp^, tp^, bytes);
	put_datablk(fp, [release,invalid]);
	put_datablk(tp, [release,dirty,immediate]);
	offset := offset + cache_blk_size;
    end;
999:
end;

{
{ stamp the time on an inode
{ there are 3 time fields:
{       atime -- file read
{       mtime -- file modified
{       ctime -- inode changed
{ we now set these times when the routine is called
{ we could set flags in the inode, and set the times only when we
{ go to disc.
{ To save inode writes, we don't update IACC unless it's more than
{ 10 seconds old.
}
procedure time_stamp(ip: inode_ptr_type;
		     which: time_stamp_set);
var
    now: integer;
    isdirty: boolean;
begin
    now := sysgmttime;
    with ip^ do begin
	if IACC in which then begin
	    isdirty := (now - atime > 10);
	    atime := now;
	end;
	if ICHG in which then begin
	    isdirty := true;
	    ctime := now;
	end;
	if IMOD in which then begin
	    isdirty := true;
	    mtime := now;
	end;
    end;
    if isdirty then
	put_inode(ip, [dirty]);
end;

$if debug$
procedure panic(str: string255);
begin
    writeln('******************************************');
    writeln('HFS PANIC: ', str);
    writeln('******************************************');
end;
$end$


{-------------------------------------------------------------------}
{
{ BLOCK OPERATIONS ON THE BITMAP
}

{
{ See if block at address 'h' is free.
}
function isblock(fs: super_block_ptr_type;
		 anyvar cp: freemap_type; h: blk_type): boolean;
label
    999;
var
    mask: integer;
    index: integer;
begin
    case fs^.frag of
      8:
	begin
	    isblock := cp[h] = hex('ff');
	    goto 999;
	end;

      4:
	begin
	    {
	    { mask = 0x0f << ((h & 0x1) << 2);
	    { return ((cp[h >> 1] & mask) == mask);
	    }
	    index := binlsr(h,1);
	    mask := binasl(hex('f'),binasl(binand(h,1),2));
	end;

      2:
	begin
	    {
	    { mask = 0x03 << ((h & 0x3) << 1);
	    { return ((cp[h >> 2] & mask) == mask);
	    }
	    index := binlsr(h,2);
	    mask := binasl(3,binasl(binand(h,3),1));
	end;

      1:
	begin
	    {
	    { mask = 0x01 << (h & 0x7);
	    { return ((cp[h >> 3] & mask) == mask);
	    }
	    index := binlsr(h,3);
	    mask := binasl(1,binand(h,7));
	end;

      otherwise
	begin
$if debug$
	    panic('isblock');
$end$
	    hfs_corrupt(fs);
	end;

    end;
    isblock := binand(cp[index], mask) = mask;
999:
end;

{
{ Take block 'h' out of bit map cp, showing it is used.
}
procedure clrblock(fs: super_block_ptr_type;
		   anyvar cp: freemap_type; h: blk_type);
label
    999;
var
    index: integer;
    mask: integer;
begin
    case fs^.frag of

      8:
	begin
	    cp[h] := 0;
	    goto 999;
	end;

      4:
	begin
	    {
	    { cp[h >> 1] &= ~(0x0f << ((h & 0x1) << 2));
	    }
	    index := binlsr(h,1);
	    mask := binasl(hex('f'),binasl(binand(h,1),2));
	end;

      2:
	begin
	    {
	    { cp[h >> 2] &= ~(0x03 << ((h & 0x3) << 1));
	    }
	    index := binlsr(h,2);
	    mask := binasl(3,binasl(binand(h,3),1));
	end;

      1:
	begin
	    {
	    { cp[h >> 3] &= ~(0x01 << (h & 0x7));
	    }
	    index := binlsr(h,3);
	    mask := binasl(1,binand(h,7));
	end;

      otherwise
	begin
$if debug$
	    panic('clrblock');
$end$
	    hfs_corrupt(fs);
	end;

    end;
    cp[index] := binand(cp[index], bincmp(mask));
999:
end;

{
{ Put bsize block 'h' into bit map cp, showing it is free.
}
procedure setblock(fs: super_block_ptr_type;
		   anyvar cp: freemap_type; h: blk_type);
label
    999;
var
    index: integer;
    mask: integer;
begin

    case fs^.frag of

      8:
	begin
	    cp[h] := hex('ff');
	    goto 999;
	end;

      4:
	begin
	    {
	    { cp[h >> 1] |= (0x0f << ((h & 0x1) << 2));
	    }
	    index := binlsr(h,1);
	    mask := binasl(hex('f'),binasl(binand(h,1),2));
	end;

      2:
	begin
	    {
	    { cp[h >> 2] |= (0x03 << ((h & 0x3) << 1));
	    }
	    index := binlsr(h,2);
	    mask := binasl(3,binasl(binand(h,3),1));
	end;

      1:
	begin
	    {
	    { cp[h >> 3] |= (0x01 << (h & 0x7));
	    }
	    index := binlsr(h,3);
	    mask := binasl(1,binand(h,7));
	end;

      otherwise
	begin
$if debug$
	    panic('setblock');
$end$
	    hfs_corrupt(fs);
	end;

    end;
    cp[index] := binior(cp[index], mask);
999:
end;



{--------------------------------------------------------}
{
{ FREEMAP MANIPULATION
}

{
{ scanc scans through the freemap cp until it finds a byte
{ with a fragment cluster of the correct size.  Each byte indexes
{ fragtbl8 or fragtbl124; the result has bits for the sizes
{ of each cluster in that byte.  'mask' has the
{ bit for size we want.
}
function scanc(size: integer; cp: freemap_ptr_type;
	       table: fragtbl_ptr_type; mask: integer): integer;
var
    i: integer;
begin
    i := 0;
    while (binand(table^[cp^[i]],mask) = 0) and (i < size) do
	i := i + 1;
    scanc := (size - i);
end;

{
{ Find a block of the specified size in the specified cylinder group.
{ Caller ensures that a block of this size exists.
{ It is a panic if a request is made to find a block if none are
{ available.
{ The previous sentence, from the original C comments, is only
{ partially true; a scanc failure causes a -1 return (hfs_corrupt),
{ where a failure to find the cluster is a panic.
}
function mapsearch(fs: super_block_ptr_type;
		   cgp: cgroup_ptr_type;
		   bpref: frag_type;
		   allocsiz: integer): frag_type;
label
    999;
var
    bno: frag_type;
    start, len, loc, i: integer;
    blk, field, subfield, pos: integer;
begin
    mapsearch := -1;

    {
    { find the fragment by searching through the free block
    { map for an appropriate bit pattern
    }
    { where to start looking }
    if bpref <> 0 then
	start := dtogd(fs, bpref) div NBBY
    else
	start := cgp^.frotor div NBBY;
    { and how far until run off end }
    len := howmany(fs^.fpg, NBBY) - start;

    { scan from starting pt to end of freemap }
    loc := scanc(len,
	    addr(cgp^.free, start),
	    fragtbl[fs^.frag],
	    binasl(1, allocsiz - 1 + (fs^.frag mod NBBY)));
    { if not found, scan up to starting pt }
    if loc = 0 then begin
	len := start + 1;
	start := 0;
	loc := scanc(len,
		addr(cgp^.free, start),
		fragtbl[fs^.frag],
		binasl(1, allocsiz - 1 + (fs^.frag mod NBBY)));
	if loc = 0 then begin
	    hfs_corrupt(fs);
	    goto 999;
	end;
    end;
    { bno is the block found }
    bno := (start + len - loc) * NBBY;
    cgp^.frotor := bno;

    {
    { found the byte in the map
    { Now we must find the fragment cluster within the byte
    { sift through the bits to find the selected frag
    }
    { i is the first frag addr of next byte }
    i := bno + NBBY;
    { bno is the lblk under consideration }
    while bno < i do begin
	{ blk is the freemap byte, with a 0 at the end }
	blk := blkmap(fs, cgp^.free, bno);
	blk := binasl(blk, 1);
	{ field is the bit pattern we want with extra 1 at each end }
	field := around[allocsiz];
	{ subfield is the bit pattern we want }
	subfield := inside[allocsiz];

	{ pos is the bit position within the freemap byte }
	for pos := 0 to fs^.frag - allocsiz do begin
	    if binand(blk, field) = subfield then begin
		mapsearch := bno + pos;
		goto 999;
	    end;
	    field := binasl(field, 1);
	    subfield := binasl(subfield, 1);
	end;
	bno := bno + fs^.frag;
    end;
$if debug$
    writeln('bno = ', bno:1, ', fs = ', fs^.fname);
    panic('mapsearch: block not in map');
$end$
    hfs_corrupt(fs);
999:
end;


{
{ Update the frsum fields to reflect addition or deletion
{ of some frags.
{ We look at the freemap byte 'fragmap', and update
{ 'fraglist' by 'cnt' (1 or -1) for each fragment cluster
{ in fragmap.  fraglist is an array of integers, where
{ fraglist[i] tells how many frag clusters of size i exist.
{ cnt 1 means we're adding these clusters, -1 deleting.
}
procedure fragacct(fs: super_block_ptr_type; fragmap: integer;
		   var fraglist: frag_avail_type; cnt: integer);
var
    inblk, field, subfield, siz, pos: integer;
begin

    { inblk has bits for each size fragment in fragmap }
    inblk := binasl(fragtbl[fs^.frag]^[fragmap], 1);

    { fragmap is the byte from the free map, with a 0 bit at the end }
    fragmap := binasl(fragmap, 1);

    { look for each possible size of fragment }
    for siz := 1 to fs^.frag - 1 do begin

	{ if there is a fragment (or more) of this size }
	if binand(inblk, binasl(1, siz + fs^.frag mod NBBY)) <> 0 then begin

	    { then find them so they can be counted }
	    field := around[siz];
	    subfield := inside[siz];

	    { pos shows where we're looking }
	    pos := siz;
	    while pos <= fs^.frag do begin
		if binand(fragmap, field) = subfield then begin
		    { there is a cluster size siz at pos }
		    fraglist[siz] := fraglist[siz] + cnt;
		    { so can skip the next siz bits, + 1 }
		    pos := pos + siz;
		    field := binasl(field, siz);
		    subfield := binasl(subfield, siz);
		end;
		field := binasl(field, 1);
		subfield := binasl(subfield, 1);
		pos := pos + 1;
	    end;
	end;
    end;
end;

{------------------------------------------------------------------}
{
{ PREFERRED BLOCK AND INODE CALCULATIONS
}


{
{ Select the desired position for the next block in a file.  The file is
{ logically divided into sections. The first section is composed of the
{ direct blocks. Each additional section contains fs_maxbpg blocks.
{
{ If no blocks have been allocated in the first section, the policy is to
{ request a block in the same cylinder group as the inode that describes
{ the file. If no blocks have been allocated in some other section, the
{ policy is to place the section in a cylinder group with a greater than
{ average number of free blocks.  An appropriate cylinder group is found
{ by maintaining a rotor that sweeps the cylinder groups. When a new
{ group of blocks is needed, the rotor is advanced until a cylinder group
{ with greater than the average number of free blocks is found.
{
{ If a section is already partially allocated, the policy is to
{ contiguously allocate fs_maxcontig blocks.  The end of one of these
{ contiguous blocks and the beginning of the next is physically separated
{ so that the disk head will be in transit between them for at least
{ fs_rotdelay milliseconds.  This is to allow time for the processor to
{ schedule another I/O transfer.
}
function blkpref(ip: inode_ptr_type;
		lbn: lblk_type; indx: integer;
		bap: indir_ptr_type): frag_type;
label
    999;
var
    fs: super_block_ptr_type;
    cg: integer;
    avgbfree: integer;
    nextblk: frag_type;
    use_delay: boolean;
    i: integer;
begin
    fs := current_super;

    {
    { Special hack for preallocation.
    { If "prealloc_pref" is set, the preallocator is telling us
    { to use that block.
    }
    if prealloc_pref <> 0 then begin
	blkpref := prealloc_pref;
	prealloc_pref := prealloc_pref + fs^.frag;
	goto 999;
    end;

    { starting new section? }
    if (indx mod fs^.maxbpg = 0) or (bap^[indx - 1] = 0) then begin

	{ starting first section? }
	if lbn < NDADDR then begin
	    cg := itog(fs, binode_ptr_type(ip)^.inumber);
	    blkpref := (fs^.fpg * cg + fs^.frag);
	    goto 999;
	end;

	{
	{ starting section after first
	{ Find a cylinder with greater than average number of
	{ unused data blocks.
	}
	avgbfree := fs^.cstotal.nbfree div fs^.ncg;
	for cg := fs^.cgrotor + 1 to fs^.ncg - 1 do
	    if fs_cs(fs, cg)^.nbfree >= avgbfree then begin
		fs^.cgrotor := cg;
		blkpref := (fs^.fpg * cg + fs^.frag);
		goto 999;
	    end;
	for cg := 0 to fs^.cgrotor do
	    if fs_cs(fs, cg)^.nbfree >= avgbfree then begin
		fs^.cgrotor := cg;
		blkpref := (fs^.fpg * cg + fs^.frag);
		goto 999;
	    end;
	blkpref := 0;
	goto 999;
    end;

    {
    { One or more previous blocks have been laid out. If fewer
    { than fs_maxcontig previous blocks are contiguous, the
    { next block is requested contiguously, otherwise it is
    { requested rotationally delayed by fs_rotdelay milliseconds.
    {
    { use_delay if there are maxcontig contig blks before indx
    { we know from above tests that indx > 0 and bap^[indx-1] <> 0
    }
    if indx < fs^.maxcontig then
	{ not enough addresses yet }
	use_delay := false
    else begin
	use_delay := true;
	for i := (indx - fs^.maxcontig) to indx - 2 do
	    if (bap^[i] = 0) or
	    (bap^[i] + fs^.frag <> bap^[i+1]) then
		use_delay := false;
    end;

    nextblk := bap^[indx - 1] + fs^.frag;

    { allocate after rotational delay? }
    if use_delay and (fs^.rotdelay <> 0) then
	{
	{ Here we convert ms of delay to frags as:
	{ (frags) = (ms) * (rev/sec) * (sect/rev) /
	{       ((sect/frag) * (ms/sec))
	{ then round up to the next block.
	}
	nextblk := nextblk + roundup(fs^.rotdelay * fs^.rps * fs^.nsect
			div (NSPF(fs) * 1000), fs^.frag);

    blkpref := nextblk;
999:
end;

{-------------------------------------------------------------------}
{
{ LOW-LEVEL ALLOCATION ROUTINES
{ These allocate the block out of the bitmap; the high-level
{       routines access the contents.
}

{
{ Implement the cylinder overflow algorithm.
{
{ The policy implemented by this algorithm is:
{   1) allocate the block in its requested cylinder group.
{   2) quadradically rehash on the cylinder group number.
{   3) brute force search for a free block.
{
{ "size" is size for data blocks, mode for inodes
{ "tried" prevents us from looking at the same cgroups
{ more than once.  But if tried is too small for this
{ fs, we set "tried_valid" to false, and ignore "tried".
{
{ allocator is either alloccg or ialloccg or prealloccg
{ alloccgblk is subroutine of alloccg
}
function hashalloc(ip: inode_ptr_type; cg: integer;
		   pref: frag_type; size: integer;
		   allocator: alloc_proc): frag_type;
label
    999;
const
    maxcg = 256;
type
    tried_type = packed array[0..maxcg-1] of boolean;
const
    tried_def = tried_type[maxcg of false];
var
    fs: super_block_ptr_type;
    result: frag_type;
    i, icg: integer;
    tried: tried_type;
    tried_valid: boolean;
begin

    hashalloc := 0;
    icg := cg;
    fs := current_super;
    tried_valid := (fs^.ncg <= maxcg);
    if tried_valid then
	tried := tried_def;

    {
    { 1: preferred cylinder group
    }
    call(allocator, ip, cg, pref, size, result);
    if result <> 0 then begin
	hashalloc := result;
	goto 999;
    end;
    if tried_valid then
	tried[cg] := true;

    {
    { 2: quadratic rehash
    }
    i := 1;
    while i < fs^.ncg do begin
	cg := cg + i;
	if cg >= fs^.ncg then
	    cg := cg - fs^.ncg;
	call(allocator, ip, cg, 0, size, result);
	if result <> 0 then begin
	    hashalloc := result;
	    goto 999;
	end;
	if tried_valid then
	    tried[cg] := true;
	i := i * 2;
    end;

    {
    { 3: brute force search
    { Note that we start at i = 2, since 0 was checked initially,
    { and 1 is always checked in the quadratic rehash.
    }
    cg := (icg + 2) mod fs^.ncg;
    for i := 2 to fs^.ncg-1 do begin
	if not tried_valid or not tried[cg] then begin
	    call(allocator, ip, cg, 0, size, result);
	    if result <> 0 then begin
		hashalloc := result;
		goto 999;
	    end;
	end;
	if tried_valid then
	    tried[cg] := true;
	cg := cg + 1;
	if cg = fs^.ncg then
	    cg := 0;
    end;
999:
end;

{
{ Allocate an entire block in a given cylinder group.
{
{ This algorithm implements the following policy:
{   1) allocate the requested block.
{   2) allocate a rotationally optimal block in the same cylinder.
{   3) allocate the next available block on the block rotor for the
{      specified cylinder group.
{ Note that this routine only allocates fs_bsize blocks; these
{ blocks may be fragmented by the routine that allocates them.
}
function alloccgblk(fs: super_block_ptr_type;
		    cgp: cgroup_ptr_type;
		    bpref: frag_type): frag_type;
label
    111, 555, 999;
type
    rpos_ptr_type = ^rpos_array_type;
    rotbl_array_type = packed array[0..maxint] of 0..255;
var
    bno: frag_type;
    cylno, pos, delta: integer;
    i: integer;
    cylbp: rpos_ptr_type;
    loopdone: boolean;
begin

    { if no preference, we just take whatever's available }
    if bpref = 0 then begin
	bpref := cgp^.rotor;
	goto 111;
    end;

    { bpref is blk number within this cg }
    bpref := binand(bpref, bincmp(fs^.frag-1));
    bpref := dtogd(fs, bpref);

    {
    { if the requested block is available, use it
    }
    if isblock(fs, cgp^.free, fragstoblks(fs, bpref)) then begin
	bno := bpref;
	goto 555;
    end;

    {
    { check for a block available on the same cylinder
    }
    cylno := cbtocylno(fs, bpref);
    { if none here, don't care about location }
    if cgp^.btot[cylno] = 0 then
	goto 111;
    if fs^.cpc = 0 then begin
	{
	{ block layout info is not available, so just have
	{ to take any block in this cylinder.
	}
	bpref := howmany(fs^.spc * cylno, NSPF(fs));
	goto 111;
    end;

    {
    { There is a block in same cylinder as bpref.
    { Find the block at the same rotational position as
    { bpref, or as close rotationally as possible.
    { check the summary information to see if a block is
    { available in the requested cylinder starting at the
    { requested rotational position and proceeding around.
    }
    cylbp := rpos_ptr_type(addr(cgp^.b[cylno]));
    { pos is the optimal rotational position }
    pos := cbtorpos(fs, bpref);
    i := pos;
    loopdone := false;
    while (i < NRPOS) and not loopdone do begin
	if cylbp^[i] > 0 then
	    loopdone := true
	else
	    i := i + 1;
    end;
    if i = NRPOS then begin
	i := 0;
	loopdone := false;
	while (i < pos) and not loopdone do begin
	    if cylbp^[i] > 0 then
		loopdone := true
	    else
		i := i + 1;
	end;
    end;
    { I think this test should always succeed -- Hal }
    if cylbp^[i] > 0 then begin
	{
	{ found a rotational position (i), now find the actual
	{ block. A panic if none is actually there.
	}
	{ pos is cylinder's position within cylinder cycle }
	pos := cylno mod fs^.cpc;
	{ bno is first bblk in cylinder cycle }
	bno := (cylno - pos) * fs^.spc div NSPB(fs);
	{
	{ postbl gives first bblk in this position,
	{ offset from beginning of cycle.
	}
	if fs^.postbl[pos][i] = -1 then begin
$if debug$
	    writeln('pos = ', pos:1, ',  i = ', i:1, ', fs = ',
		    fs^.fname);
	    panic('alloccgblk: postbl corrupted');
$end$
	    hfs_corrupt(fs);
	end;
	{ i runs over all blocks in this position }
	loopdone := false;
	i := fs^.postbl[pos][i];
	while not loopdone do begin
	    if isblock(fs, cgp^.free, bno + i) then begin
		bno := blkstofrags(fs, (bno + i));
		goto 555;
	    end;
	    delta := rotbl_array_type(fs^.rotbl)[i];
	    if (delta <= 0) or (delta > maxbpc - i) then
		loopdone := true
	    else
		i := i + delta;
	end;
$if debug$
	writeln('pos = ', pos:1, ',  i = ', i:1, ', fs = ',
		fs^.fname);
	panic('alloccgblk: cannot find blk in cyl');
$end$
	hfs_corrupt(fs);
    end
    else
	{ concluding corruption not in UNIX code }
	hfs_corrupt(fs);

111:
    {
    { no blocks in the requested cylinder, so take next
    { available one in this cylinder group.
    }
    bno := mapsearch(fs, cgp, bpref, fs^.frag);
    if bno < 0 then begin
	alloccgblk := 0;
	goto 999;
    end;
    cgp^.rotor := bno;

555:
    { have the block number now in bno }
    clrblock(fs, cgp^.free, fragstoblks(fs, bno));
    with cgp^.cs do
	nbfree := nbfree - 1;
    with fs^.cstotal do
	nbfree := nbfree - 1;
    with fs_cs(fs, cgp^.cgx)^ do
	nbfree := nbfree - 1;
    { and per-cylinder free block counts }
    cylno := cbtocylno(fs, bno);
    i := cbtorpos(fs, bno);
    with cgp^ do begin
	b[cylno][i] := b[cylno][i] - 1;
	btot[cylno] := btot[cylno] - 1;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty]);
    alloccgblk := (cgp^.cgx * fs^.fpg + bno);
999:
end;

{
{ Determine whether a block can be allocated.
{ (size is some multiple of fsize <= bsize)
{ Check to see if a block of the appropriate size is available,
{ and if it is, allocate it.
{ 0 return means not present in this cg
}
procedure alloccg(ip: inode_ptr_type;
		  cg: integer;
		  bpref: frag_type; size: integer;
		  var result: integer);
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    bno: frag_type;
    frags: integer;
    allocsiz: integer;
    i: integer;
    loopdone: boolean;
begin
    fs := current_super;
    result := 0;

    if (fs_cs(fs, cg)^.nbfree = 0) and (size = fs^.bsize) then
	goto 999;
    cgp := get_cgroup(cg);
    if (cgp^.cs.nbfree = 0) and (size = fs^.bsize) then begin
	hfs_corrupt(fs);
	put_cgroup(cgp, [release]);
	goto 999;
    end;

    { call another routine for allocation of an entire block }
    if size = fs^.bsize then begin
	bno := alloccgblk(fs, cgp, bpref);
	put_cgroup(cgp, [release]);
	result := bno;
	goto 999;
    end;

    {
    { check to see if any fragments are already available
    { allocsiz is the size which will be allocated, hacking
    { it down to a smaller size if necessary
    }
    frags := numfrags(fs, size);
    allocsiz := frags;
    loopdone := false;
    while (allocsiz < fs^.frag) and not loopdone do begin
	if cgp^.frsum[allocsiz] <> 0 then
	    loopdone := true
	else
	    allocsiz := allocsiz + 1;
    end;

    { must use whole new bblock? }
    if allocsiz = fs^.frag then begin
	{
	{ no fragments were available, so a block will be
	{ allocated, and hacked up
	}
	if cgp^.cs.nbfree = 0 then begin
	    put_cgroup(cgp, [release]);
	    goto 999;
	end;
	{ bno is the block we allocate }
	bno := alloccgblk(fs, cgp, bpref);
	if bno = 0 then begin
	    put_cgroup(cgp, [release]);
	    goto 999;
	end;
	{ bpref is the position within this cg }
	bpref := dtogd(fs, bno);

	{ clear bits for frags we won't use }
	for i := frags to fs^.frag - 1 do
	    setbit(cgp^.free, bpref + i);

	{ i is the number of new frags we are creating }
	i := fs^.frag - frags;

	{ update total fragment counts }
	with cgp^.cs do
	    nffree := nffree + i;
	with fs^.cstotal do
	    nffree := nffree + i;
	with fs_cs(fs, cg)^ do
	    nffree := nffree + i;
	fs^.fmod := FS_MODIFIED;
	with cgp^ do
	    frsum[i] := frsum[i] + 1;

	put_cgroup(cgp, [dirty,release]);
	result := bno;
	goto 999;
    end;

    {
    { We don't need to break up a bblk, because there
    { is a fragment cluster of size allocsiz, which
    { may be bigger than frags, which is how many we want.
    }
    bno := mapsearch(fs, cgp, bpref, allocsiz);
    if bno < 0 then begin
	put_cgroup(cgp, [release]);
	goto 999;
    end;

    { show our cluster now in use }
    for i := 0 to frags - 1 do
	clrbit(cgp^.free, bno + i);
    { update total fragment counts }
    with cgp^.cs do
	nffree := nffree - frags;
    with fs^.cstotal do
	nffree := nffree - frags;
    with fs_cs(fs, cg)^ do
	nffree := nffree - frags;
    fs^.fmod := FS_MODIFIED;
    { took a cluster of size allocsiz }
    with cgp^ do
	frsum[allocsiz] := frsum[allocsiz] - 1;
    { maybe created a cluster if allocsiz was too big }
    if frags <> allocsiz then
	with cgp^ do
	    frsum[allocsiz - frags] := frsum[allocsiz - frags] + 1;
    put_cgroup(cgp, [dirty,release]);
    result := (cg * fs^.fpg + bno);
999:
end;


{
{ Determine whether fragment bprev can be extended
{ from osize to nsize, both fs_fsize multiples.
{ Check to see if the necessary fragments are available, and
{ if they are, allocate them.
{ 0 means cannot do it.
}
function fragextend(ip: inode_ptr_type;
		    cg: integer;
		    bprev: frag_type;
		    osize, nsize: integer): frag_type;
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    bno, bbase: frag_type;
    frags, i, j: integer;
    loopdone: boolean;
begin
    fragextend := 0;

    fs := current_super;
    if fs_cs(fs, cg)^.nffree < numfrags(fs, nsize - osize) then
	goto 999;

    { frags is how many frags we want }
    frags := numfrags(fs, nsize);
    { bbase is the 0..fs_frag-1 offset within the bblk }
    bbase := bprev mod fs^.frag;
    { be sure not trying to extend too far }
    if bbase > (bprev + frags - 1) mod fs^.frag then
	{ cannot extend across a block boundary }
	goto 999;

    { look at the cg data }
    cgp := get_cgroup(cg);

    { see if the following frags are free }
    bno := dtogd(fs, bprev);
    for i := numfrags(fs, osize) to frags-1 do
	if isclr(cgp^.free, bno + i) then begin
	    put_cgroup(cgp, [release]);
	    goto 999;
	end;

    {
    { the current fragment can be extended
    { deduct the count on fragment being extended into
    { increase the count on the remaining fragment (if any)
    { allocate the extended piece
    }
    { "i" marks end of free cluster }
    i := frags;
    while (i < fs^.frag - bbase) and not isclr(cgp^.free, bno + i) do
	i := i + 1;
    { dec count of original cluster }
    j := i - numfrags(fs, osize);
    with cgp^ do
	frsum[j] := frsum[j] - 1;
    { increment count of cluster left over }
    if i <> frags then
	with cgp^ do
	    frsum[i - frags] := frsum[i - frags] + 1;
    { now for the new frags we are using }
    for i := numfrags(fs, osize) to frags-1 do begin
	clrbit(cgp^.free, bno + i);
	with cgp^.cs do
	    nffree := nffree - 1;
	with fs^.cstotal do
	    nffree := nffree - 1;
	with fs_cs(fs, cg)^ do
	    nffree := nffree - 1;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty,release]);
    fragextend := bprev;
999:
end;


{
{ Free a block or fragment.
{
{ The specified block or fragment is placed back in the
{ free map. If a fragment is deallocated, a possible
{ block reassembly is checked.
}
procedure xfree(ip: inode_ptr_type; bno: frag_type; size: integer);
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    cg: integer;
    bbase: frag_type;
    blk: integer;
    frags: integer;
    i, j: integer;
begin
    fs := current_super;
    if (size > fs^.bsize) or (fragoff(fs, size) <> 0) then begin
$if debug$
	writeln('bsize = ', fs^.bsize:1, ', size = ', size:1,
		', fs = ', fs^.fname);
	panic('xfree: bad size');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    { cg is the cgroup number for the block bno }
    if badblock(fs, bno) then begin
	hfs_corrupt(fs);
	goto 999;
    end;
    cg := dtog(fs, bno);

    { cgp is the cylinder group structure }
    cgp := get_cgroup(cg);

    { bno is the offset within cg }
    bno := dtogd(fs, bno);

    { freeing an entire bblock? }
    if size = fs^.bsize then begin
	{ already free? }
	if isblock(fs, cgp^.free, fragstoblks(fs, bno)) then begin
$if debug$
	    writeln('cg = ', cg:1, ', block = ', bno:1, ', fs = ',
		fs^.fname);
	    panic('xfree: freeing free block');
$end$
	    hfs_corrupt(fs);
	end;
	{ mark it as free }
	setblock(fs, cgp^.free, fragstoblks(fs, bno));
	{ update free block counts }
	with cgp^.cs do
	    nbfree := nbfree + 1;
	with fs^.cstotal do
	    nbfree := nbfree + 1;
	with fs_cs(fs, cg)^ do
	    nbfree := nbfree + 1;
	{ and per-cylinder free block counts }
	i := cbtocylno(fs, bno);
	j := cbtorpos(fs, bno);
	with cgp^ do begin
	    b[i][j] := b[i][j] + 1;
	    btot[i] := btot[i] + 1;
	end;
    end

    { freeing a fragment cluster }
    else begin

	{ bbase is the blk containing the cluster }
	bbase := bno - (bno mod fs^.frag);
	{
	{ decrement the counts associated with the old frags
	}
	blk := blkmap(fs, cgp^.free, bbase);
	fragacct(fs, blk, cgp^.frsum, -1);
	{
	{ deallocate the fragment
	}
	frags := numfrags(fs, size);
	{ free each frag }
	for i := 0 to frags - 1 do begin
	    { already free? }
	    if isset(cgp^.free, bno + i) then begin
$if debug$
		writeln('cg = ', cg:1, ', block = ', bno+i:1, ', fs = ',
		    fs^.fname);
		panic('xfree: freeing free frag');
$end$
		hfs_corrupt(fs);
	    end;
	    setbit(cgp^.free, bno + i);
	end;
	i := frags;
	{ update total fragment counts }
	with cgp^.cs do
	    nffree := nffree + i;
	with fs^.cstotal do
	    nffree := nffree + i;
	with fs_cs(fs, cg)^ do
	    nffree := nffree + i;
	{
	{ add back in counts associated with the new frags
	}
	blk := blkmap(fs, cgp^.free, bbase);
	fragacct(fs, blk, cgp^.frsum, 1);
	{
	{ if a complete block has been reassembled, account for it
	}
	if isblock(fs, cgp^.free, fragstoblks(fs, bbase)) then begin
	    with cgp^.cs do begin
		nffree := nffree - fs^.frag;
		nbfree := nbfree + 1;
	    end;
	    with fs^.cstotal do begin
		nffree := nffree - fs^.frag;
		nbfree := nbfree + 1;
	    end;
	    with fs_cs(fs, cg)^ do begin
		nffree := nffree - fs^.frag;
		nbfree := nbfree + 1;
	    end;
	    i := cbtocylno(fs, bbase);
	    j := cbtorpos(fs, bbase);
	    with cgp^ do begin
		b[i][j] := b[i][j] + 1;
		btot[i] := btot[i] + 1;
	    end;
	end;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty,release]);
999:
end;


{------------------------------------------------------------------}
{
{ HIGH-LEVEL ALLOCATION ROUTINES
{ These call the low-level routines to get disk addresses,
{ then (often) access the data at that address.
}

{
{ Allocate a block in the file system.
{
{ The size of the requested block is given, which must be some
{ multiple of fs_fsize and <= fs_bsize.
{ A preference may be optionally specified. If a preference is given
{ the following hierarchy is used to allocate a block:
{   1) allocate the requested block.
{   2) allocate a rotationally optimal block in the same cylinder.
{   3) allocate a block in the same cylinder group.
{   4) quadradically rehash into other cylinder groups, until an
{      available block is located.
{ If no block preference is given the following heirarchy is used
{ to allocate a block:
{   1) allocate a block in the cylinder group that contains the
{      inode for the file.
{   2) quadratically rehash into other cylinder groups, until an
{      available block is located.
}
function alloc(ip: inode_ptr_type;
	       bpref: frag_type;
	       size: integer;
	       is_control: boolean): frag_type;
label
    555, 999;
var
    cg: integer;
    bno: frag_type;
    fs: super_block_ptr_type;
begin

    alloc := 0;
    fs := current_super;
    { param check }
    if (size > fs^.bsize) or (fragoff(fs, size) <> 0) then begin
$if debug$
	writeln('size = ', size:1, ', fs = ', fs^.fname);
	panic('alloc: bad size');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;
    { space check }
    if (size = fs^.bsize) and (fs^.cstotal.nbfree = 0) then
	goto 555;
    if freespace(fs, fs^.minfree) <= 0 then
	goto 555;

    if bpref >= fs^.size then
	bpref := 0;
    {
    { preferred cg is the one with the preferred block,
    { or the one with the inode if no preferred block.
    }
    if bpref = 0 then
	cg := itog(fs, binode_ptr_type(ip)^.inumber)
    else
	cg := dtog(fs, bpref);

    bno := hashalloc(ip, cg, bpref, size, alloccg);
    if bno <= 0 then
	goto 555;
    ip^.blocks := ip^.blocks + btodb(size);
    put_inode(ip, [dirty]);
    if is_control then
	zero_data(bno, size);
    alloc := bno;
    goto 999;
555:
    { no space }
$if debug$
    fserr(fs, 'file system full');
$end$
    ioresult := ord(inoroom);
999:
end;

{
{ Reallocate a fragment to a bigger size
{
{ The number and size of the old block is given, and a preference
{ and new size is also specified. The allocator attempts to extend
{ the original block. Failing that, the regular block allocator is
{ invoked to get an appropriate block.
}
function realloccg(ip: inode_ptr_type;
		   bprev, bpref: frag_type;
		   osize, nsize: integer;
		   lbn: lblk_type;
		   is_control: boolean): frag_type;
label
    555, 999;
var
    cg: integer;
    bno: frag_type;
    fs: super_block_ptr_type;
begin
    fs := current_super;
    realloccg := 0;

    { param check }
    if (osize > fs^.bsize) or (fragoff(fs, osize) <> 0) or
       (nsize > fs^.bsize) or (fragoff(fs, nsize) <> 0) then begin
$if debug$
	    writeln('osize = ', osize:1, ', nsize = ', nsize:1,
		    'fs = ', fs^.fname, ', bprev = ', bprev:1);
	    panic('realloccg: bad size');
$end$
	    ioresult := ord(zcatchall);
	    goto 999;
    end;

    { see if space left }
    if freespace(fs, fs^.minfree) <= 0 then
	goto 555;

    { more param check }
    if bprev = 0 then begin
$if debug$
	writeln('osize = ', osize:1, ', nsize = ', nsize:1,
		'fs = ', fs^.fname, ', bprev = ', bprev:1);
	panic('realloccg: bad bprev');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    { cg is same group as bprev }
    cg := dtog(fs, bprev);
    { try to extend fragment in place }
    bno := fragextend(ip, cg, bprev, osize, nsize);
    if bno <> 0 then begin
	if is_control then
	    zero_data(bprev+numfrags(fs,osize), nsize-osize);
	ip^.blocks := ip^.blocks + btodb(nsize - osize);
	put_inode(ip, [dirty]);
	realloccg := bno;
	goto 999;
    end;

    { could not extend it in place, so move it }
    if bpref >= fs^.size then
	bpref := 0;
    bno := hashalloc(ip, cg, bpref, nsize, alloccg);
    if bno > 0 then begin
	if is_control then begin
	    copy_control_data(bprev, bno, osize);
	    zero_data(bno+numfrags(fs,osize), nsize-osize);
	end
	else
	    copy_user_data(fragstobytes(fs, bprev),
			   fragstobytes(fs, bno),
			   osize);
	ip^.blocks := ip^.blocks + btodb(nsize - osize);
	ip^.db[lbn] := bno;
	{ immediate write-thru to show old block no longer ours }
	put_inode(ip, [dirty,immediate]);
	xfree(ip, bprev, osize);
	realloccg := bno;
	goto 999;
    end;
555:
    {
    { no space available
    }
$if debug$
    fserr(fs, 'file system full');
$end$
    ioresult := ord(inoroom);
999:
end;

{------------------------------------------------------------------}
{
{ MAP LOGICAL BLOCK NUMBERS TO FRAGMENT NUMBERS
}


{
{ Bmap defines the structure of file system storage
{ by returning the physical block number on a device given the
{ inode and the logical block number in a file.
{ size is <= bsize.  It tells how far in this lblk we want to write,
{ and is ignored when we're reading.
{ rwflg is B_READ for reading, B_WRITE or B_ZWRITE for writing.
{ B_ZWRITE means that bmap zeroes every newly allocated block.
{ Otherwise, zeroing of user data is skipped (bmap always zeroes
{ indir blocks and directories).  Exception: when extending
{ fragmented file into new logical block, the old fragment
{ must be extended; bmap always zeroes it.
{ This setup allows several zeroing strategies:
{   never zero -- caller uses B_WRITE
{   always zero in bmap -- caller always uses B_ZWRITE
{   zero in bmap sometimes -- caller uses B_ZWRITE sometimes
}
function bmap(ip: inode_ptr_type; bn: lblk_type;
	      rwflg: bmap_mode; size: integer): frag_type;
label
    999;
var
    i, j: integer;
    sh: integer;
    osize, nsize: integer;
    fs: super_block_ptr_type;
    lbn: lblk_type;
    nb: integer; { sometimes lblk_type, sometimes frag_type }
    bp, pref: frag_type;
    bap: indir_ptr_type;
    loopdone: boolean;
    is_control, this_control: boolean;
begin
    bmap := BMAP_ERROR;
    {zlength := 0;}
    is_control := (binand(ip^.mode, IFMT) = IFDIR) or (rwflg = B_ZWRITE);

    if bn < 0 then begin
$if debug$
	panic('bmap negative bn');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    fs := current_super;

    {
    { If the next write will extend the file into a new block,
    { and the file is currently composed of a fragment
    { this fragment has to be extended to be a full block.
    { This never happens with directories.
    }
    { nb is the last lblk in the file }
    nb := lblkno(fs, ip^.size.ls);

    { only direct addresses can be fragments }
    if (rwflg <> B_READ) and (nb < NDADDR) and (nb < bn) then begin

	{ osize is size (frag multiple) of last lblk }
	osize := blksize(fs, ip, nb);
	if (osize < fs^.bsize) and (osize > 0) then begin
	    bp := realloccg(ip, ip^.db[nb],
			    blkpref(ip, nb, nb, indir_ptr_type(addr(ip^.db))),
			    osize, fs^.bsize, nb,
			    is_control);
	    if bp = 0 then
		goto 999;
	    ip^.size.ls := (nb + 1) * fs^.bsize;
	    ip^.db[nb] := bp;
	    put_inode(ip, [dirty]);
	end;
    end;

    {
    { The first NDADDR blocks are direct blocks
    }
    if bn < NDADDR then begin
	{ nb is frag # for lblk bn, which we're accessing }
	nb := ip^.db[bn];

	{ reading }
	if rwflg = B_READ then begin
	    { reading a hole? }
	    if nb = 0 then nb := BMAP_HOLE;
	    bmap := nb;
	    goto 999;
	end;

	{ writing }
	{ writing a hole or writing last frag? }
	if (nb = 0) or (ip^.size.ls < (bn + 1) * fs^.bsize) then begin


	    { writing last frag? }
	    if nb <> 0 then begin
		{ consider need to reallocate a frag }
		osize := fragroundup(fs, blkoff(fs, ip^.size.ls));
		nsize := fragroundup(fs, size);
		if (nsize <= osize) then begin
		    bmap := nb;
		    goto 999;
		end;
		bp := realloccg(ip, nb,
			blkpref(ip, bn, bn, indir_ptr_type(addr(ip^.db))),
			osize, nsize, bn, is_control);
	    end

	    { writing a hole }
	    else begin
		osize := 0;
		if ip^.size.ls < (bn + 1) * fs^.bsize then
		    nsize := fragroundup(fs, size)
		else
		    nsize := fs^.bsize;
		bp := alloc(ip,
			blkpref(ip, bn, bn, indir_ptr_type(addr(ip^.db))),
			nsize, is_control);
	    end;

	    if bp = 0 then
		goto 999;
	    {if not is_control then begin
		zstart := fragstobytes(fs, bp) + osize;
		zlength := nsize - osize;
	    end;}
	    nb := bp;
	    ip^.db[bn] := nb;
	    put_inode(ip, [dirty]);
	end;
	bmap := nb;
	goto 999;
    end;

    {
    { Determine how many levels of indirection.
    { NIADDR-j will be the (0-based) index into ip^.ib
    }
    pref := 0;
    sh := 1;
    lbn := bn;
    bn := bn - NDADDR;
    j := NIADDR;
    loopdone := false;
    while (j > 0) and not loopdone do begin
	{ sh is num of lblks reachable this level }
	sh := sh * fs^.nindir;
	if (bn < sh) then
	    loopdone := true
	else begin
	    bn := bn - sh;
	    j := j - 1;
	end;
    end;

    if j = 0 then begin
$if debug$
	panic('bmap -- file too big');
$end$
	hfs_corrupt(fs);
	goto 999;
    end;

    {
    { fetch the first indirect block; its addr is nb.
    { It may not be there; if writing, we allocate it.
    }
    nb := ip^.ib[NIADDR - j];
    { not there? }
    if nb = 0 then begin
	{ reading a hole? }
	if rwflg = B_READ then begin
	    bmap := BMAP_HOLE;
	    goto 999;
	end;
	{ writing a hole, so allocate }
	pref := blkpref(ip, lbn, 0, nil);
	bp := alloc(ip, pref, fs^.bsize, true);
	if bp = 0 then
	    goto 999;
	nb := bp;
	ip^.ib[NIADDR - j] := nb;
	put_inode(ip, [dirty]);
    end;

    {
    { fetch through the indirect blocks
    { until we find the target block.
    { the number of levels is (0-based) NIADDR - j.
    { nb is current indir block number (frag)
    { bap is the indir block itself
    { nb is the next indir block number
    }
    while j <= NIADDR do begin
	{ i is the index in indir nb of next indir or target }
	sh := sh div fs^.nindir;
	i := (bn div sh) mod fs^.nindir;
	bap := indir_ptr_type(get_datablk(nb, i*bytes_per_ptr));
	{ i is index in cache chunk bap }
	i := i mod (cache_blk_size div bytes_per_ptr);
	nb := bap^[i];
	if nb = 0 then begin

	    { reading a hole? }
	    if rwflg = B_READ then begin
		put_datablk(cache_blk_ptr_type(bap), [release]);
		bmap := BMAP_HOLE;
		goto 999;
	    end;

	    { writing a hole }
	    { no pref yet? }
	    if pref = 0 then
		{ this is an indir block? }
		if j < NIADDR then
		    pref := blkpref(ip, lbn, 0, nil)
		{ this is the target block }
		else
		    pref := blkpref(ip, lbn, i, bap);

	    {
	    { This time through loop, it's control data if it
	    { was control data before, or if this is an indirect block.
	    }
	    this_control := is_control or (j < NIADDR);

	    { allocate the block }
	    nb := alloc(ip, pref, fs^.bsize, this_control);
	    if nb = 0 then begin
		put_datablk(cache_blk_ptr_type(bap), [release]);
		goto 999;
	    end;
	    {if not this_control then begin
		zstart := fragstobytes(fs, nb);
		zlength := fs^.bsize;
	    end;}
	    bap^[i] := nb;
	    { ***5.1 -- write immediate if dir }
	    put_datablk(cache_blk_ptr_type(bap), [dirty,release]);
	end
	else
	    put_datablk(cache_blk_ptr_type(bap), [release]);
	j := j + 1;
    end;
    bmap := nb;
999:
end;

{--------------------------------------------------------------------------}
{
{ PREALLOCATION
}

{
{ Get a single chunk of disk for the given space.
{ Return the fragment number of the beginning, or 0 if not found,
{ in the var parameter "result".
{ We don't try terribly hard to find the space.  To keep the
{ code simple and fast, we look for the space only in freemap bytes
{ that are entirely clear.  Example: you want to preallocate
{ 9K.  On an 8K/1K system, the code looks for TWO set freemap
{ bytes, which requires that 16K be free.  If preallocation
{ is really all that great, we can look more carefully.
}
procedure prealloccg(ip: inode_ptr_type;
		     cg, pref, fragcount: integer;
		     var result: integer);
label
    999;
var
    chunk_start: integer;
    cgp: cgroup_ptr_type;
    num_bytes_set: integer;
    fs: super_block_ptr_type;
    found_used_space: boolean;
    freemap_size: integer;
    i: integer;
    cgp_free: freemap_ptr_type;
begin
    { how many 0xff bytes do we need in the free map? }
    num_bytes_set := howmany(fragcount, NBBY);
    fs := current_super;
    result := 0;
    cgp := nil;

    { enough blocks in the cg? }
    if fs_cs(fs, cg)^.nbfree < fragstoblks(fs, num_bytes_set*NBBY) then
	goto 999;

    cgp := get_cgroup(cg);

    {
    { set "chunk_start" to a place with num_bytes_set consecutive
    { bytes of ones (indicating all frags in this byte are free)
    }
    chunk_start := 0;
    freemap_size := howmany(fs^.fpg, NBBY);
    cgp_free := addr(cgp^.free[0]);
    while chunk_start + num_bytes_set <= freemap_size do begin
	i := 0;
	found_used_space := false;
	while (i < num_bytes_set) and not found_used_space do
	    if cgp_free^[chunk_start+i] <> hex('ff') then begin
		found_used_space := true;
		{ start looking AFTER this byte }
		chunk_start := chunk_start + i + 1;
	    end
	    else
		i := i + 1;
	if not found_used_space then begin
	    result := cg * fs^.fpg + chunk_start*NBBY;
	    goto 999;
	end;
    end;
999:
    if cgp <> nil then
	put_cgroup(cgp, [release]);
end;


{
{ See if space exists for a requested preallocation.
{ We are given the size requested.
{ Return a boolean telling whether space is there.
{ Pass back block and fragment count for convenience.
{ This check is made AFTER the file is created, so we
{ do not worry about space in the parent directory.
}
function space_exists(filebytes: integer;
		      var blkcount, fragcount: integer): boolean;
label
    999;
var
    fs: super_block_ptr_type;
    extra, bn: integer;
    exists: boolean;
begin
    space_exists := false;
    fs := current_super;

    { filebytes: how many big blocks, how many frags }
    filebytes := fragroundup(fs, filebytes);
    blkcount := lblkno(fs, filebytes);
    fragcount := numfrags(fs, blkoff(fs, filebytes));
    if (blkcount > NDADDR) and (fragcount <> 0) then begin
	blkcount := blkcount + 1;
	fragcount := 0;
    end;

    { plus indirect blocks }
    extra := 0;
    bn := blkcount - NDADDR;
    if bn > 0 then begin
	{ first indirect block }
	extra := 1;
	bn := bn - fs^.nindir;
	if bn > 0 then
	    { second indir block, plus one for each nindir blocks }
	    extra := 2 + howmany(bn, fs^.nindir);
    end;

    { this space must exist somewhere on disc }
    with fs^.cstotal do begin
	if (blkcount + extra > nbfree)
	or ((blkcount + extra = nbfree) and (fragcount > nffree)) then
	    goto 999;

	{ temporarily tamper with nbfree/nffree so freespace call works }
	nbfree := nbfree - (blkcount + extra);
	nffree := nffree - fragcount;
	space_exists := (freespace(fs, fs^.minfree) >= 0);
	nbfree := nbfree + (blkcount + extra);
	nffree := nffree + fragcount;
	{ end of tampering with nbfree }

    end;
999:
end;


{
{ Preallocation
{ We are given the file and the number of bytes.
{ We return a boolean showing success.
{ If the space exists in a single chunk, we use it.
{ This is done by setting "prealloc_pref" to the desired
{ address, then calling bmap, which calls "blkpref" to
{ calculate the preferred block.  bpref uses prealloc_pref,
{ if non-zero.  If prealloc_pref is 0, it is ignored,
{ and bmap works as usual.
}
function preallocate(ip: inode_ptr_type;
		     filebytes: integer): boolean;
label
    999;
var
    fs: super_block_ptr_type;
    lbn, size: integer;
    blkcount, fragcount: integer;
begin
    preallocate := false;
    fs := current_super;

    { is there space? }
    if not space_exists(filebytes, blkcount, fragcount) then
	goto 999;

    { see if we can grab a single chunk }
    prealloc_pref := hashalloc(ip, 0, 0,
			       blkstofrags(fs, blkcount) + fragcount,
			       prealloccg);

    { call bmap to do the work }
    for lbn := 0 to blkcount - 1 do
	if bmap(ip, lbn, B_WRITE, fs^.bsize) = BMAP_ERROR then begin
$if debug$
	    report('prealloc gets bmap error, blks');
$end$
	    goto 999;
	end;
    if fragcount <> 0 then
	if bmap(ip, blkcount, B_WRITE, blkoff(fs, filebytes)) = BMAP_ERROR then begin
$if debug$
	    report('prealloc gets bmap error, frags');
$end$
	    goto 999;
	end;

    preallocate := true;

999:
    { reset prealloc_pref so blkpref routines will work normally }
    prealloc_pref := 0;
end;


{----------------------------------------------------------------------}
{
{ FILE DELETION
}

{
{ Read or write a directory.  rw is B_READ or B_WRITE.
{ ip is the inode.
{ offset is the logical byte offset within the file.
{ Returns a data blk ptr, which caller must release.
{ Returns nil on failure.
{ Caller must update inode size
}
function rdwri(rw: bmap_mode;
	       ip: inode_ptr_type;
	       offset, len: integer): cache_blk_ptr_type;
label
    999;
var
    fs: super_block_ptr_type;
    lbn: lblk_type;
    bn: frag_type;
    on: integer;
begin
$if debug$
    if (rw <> B_READ) and (rw <> B_WRITE) then
	panic('rwip');
$end$

    rdwri := nil;
    fs := current_super;

    { lbn is logical blk within file }
    lbn := lblkno(fs, offset);
    { on is the offset within lbn }
    on := blkoff(fs, offset);

$if debug$
    { no xfer can cross cache blk boundary }
    if (on div cache_blk_size) <> ((on+len-1) div cache_blk_size) then
	panic('rwdri crossing cache boundary');
    { no xfer can read past eof }
    if (rw = B_READ) and (offset + len > ip^.size.ls) then
	panic('rdwri reading past eof');
    { no xfer can cross logical block boundary }
    if on + len > fs^.bsize then
	panic('rdwri going over lblk boundary');
$end$

    { get the disk block number }
    bn := bmap(ip, lbn, rw, on+len);
    if bn = BMAP_HOLE then begin
$if debug$
	panic('rdwri bmap error');
$end$
	goto 999;
    end;
    if bn = BMAP_ERROR then
	goto 999;

    rdwri := get_datablk(bn, on);
999:
end;

{
{ Free an inode.
{
{ The specified inode is placed back in the free map.
}
procedure ifree(ip: inode_ptr_type;
		ino, mode: integer);
label
    999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    cg: integer;
begin
    fs := current_super;
    if ino >= (fs^.ipg * fs^.ncg) then begin
$if debug$
	writeln('ino = ', ino:1, ', fs = ', fs^.fname);
	panic('ifree: range');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;

    { get the cgroup }
    cg := itog(fs, ino);
    cgp := get_cgroup(cg);

    { update all the counts }
    ino := ino mod fs^.ipg;
    if isclr(cgp^.iused, ino) then begin
$if debug$
	writeln('ino = ', ino:1, ', fs = ', fs^.fname);
	panic('ifree: freeing free inode');
$end$
	hfs_corrupt(fs);
    end;
    clrbit(cgp^.iused, ino);
    with cgp^.cs do
	nifree := nifree + 1;
    with fs^.cstotal do
	nifree := nifree + 1;
    with fs_cs(fs, cg)^ do
	nifree := nifree + 1;
    if binand(mode, IFMT) = IFDIR then begin
	with cgp^.cs do
	    ndir := ndir - 1;
	with fs^.cstotal do
	    ndir := ndir - 1;
	with fs_cs(fs, cg)^ do
	    ndir := ndir - 1;
    end;
    fs^.fmod := FS_MODIFIED;
    put_cgroup(cgp, [dirty,release]);
999:
end;

{
{ Release blocks associated with the inode ip and
{ stored in the indirect block bn.  Blocks are free'd
{ in LIFO order up to (but not including) lastbn,
{ the frag offset from the beginning of the group of blocks
{ pointed to by this block.  If
{ level is greater than SINGLE, the block is an indirect
{ block and recursive calls to indirtrunc must be used to
{ cleanse other indirect blocks.
{
{ NB: triple indirect blocks are untested.
{ lastbn < 0 means free all blocks.
{ Returns number of device blocks freed.
{
{ This routine zeros parts of an indirect block which we could,
{ if we were a little more careful, deduce was already zero.
{ The current code doesn't write these parts back out, but a better
{ fix would be to not even read them in.
}
function indirtrunc(ip: inode_ptr_type;
		    bn: frag_type;
		    lastbn, level: integer): integer;
label
    999;
const
    ptrs_per_cache = cache_blk_size div bytes_per_ptr;
var
    i: integer;
    fs: super_block_ptr_type;
    nb: frag_type;
    last, factor: integer;
    blocksreleased, nblocks: integer;
    bap: indir_ptr_type;
    cbeg, cend, zbeg, ibeg, iend: integer;
    bapcopy: array[0..ptrs_per_cache-1] of integer;
    bap_changed: boolean;
begin
    fs := current_super;
    blocksreleased := 0;

    {
    { Calculate index in current block of last
    { block to be kept.  -1 indicates the entire
    { block so we need not calculate the index.
    }
    factor := 1;
    for i := SINGLE to level - 1 do
	factor := factor * fs^.nindir;
    last := lastbn;
    if lastbn > 0 then
	    last := last div factor;
    nblocks := btodb(fs^.bsize);

    {
    { Loop over the indir block backwards.  First, zero the
    { ptrs and force the block back to disk.
    { Then free the blocks.  The order ensures that
    { no indir addresses point to free blocks.
    { cend -- index in indir of last address in cache blk
    { cbeg -- index in indir of first address in cache blk
    { zbeg -- index in indir of where we start zeroing in cache blk
    { ibeg, iend -- indices in the cache blk of zbeg, cend
    { indir[last] is NOT to be zeroed (last might even be -1).
    }
    cend := fs^.nindir - 1;
    bap := nil;
    ibeg := -1;
    while cend > last do begin

	{ get new cache blk }
	if bap <> nil then
	    put_datablk(cache_blk_ptr_type(bap), [release]);
	bap := indir_ptr_type(get_datablk(bn, cend*bytes_per_ptr));

	{ find limits of cache blk relative to indir blk }
	cbeg := cend - ptrs_per_cache + 1;
	zbeg := max(cbeg, last + 1);

	{ zbeg and cend are now both covered by cache blk }
	ibeg := zbeg mod ptrs_per_cache;
	iend := cend mod ptrs_per_cache;

	{ copy old ptrs so can release blocks }
	moveleft(bap^, bapcopy, cache_blk_size);

	{ zero them on disk }
	bap_changed := false;
	for i := ibeg to iend do
	    if bap^[i] <> 0 then begin
		bap^[i] := 0;
		bap_changed := true;
	    end;
	if bap_changed then
	    put_datablk(cache_blk_ptr_type(bap), [dirty,immediate]);

	{ release the blocks }
	for i := ibeg to iend do begin
	    nb := bapcopy[i];
	    if nb <> 0 then begin
		if level > SINGLE then
		    blocksreleased := blocksreleased +
			indirtrunc(ip, nb, -1, level-1);
		xfree(ip, nb, fs^.bsize);
		blocksreleased := blocksreleased + nblocks;
	    end;
	end;

	cend := cend - ptrs_per_cache;
    end;

    {
    { Recursively free last partial block.
    { its index is ibeg-1, but that might be off the cache block
    }
    if (level > SINGLE) and (lastbn >= 0) then begin
	i := ibeg - 1;
	if i < 0 then begin
	    { not in cache block }
	    if bap <> nil then
		put_datablk(cache_blk_ptr_type(bap), [release]);
	    bap := indir_ptr_type(get_datablk(bn, last*bytes_per_ptr));
	    i := last mod ptrs_per_cache;
	end;
	last := lastbn mod factor;
	nb := bap^[i];
	put_datablk(cache_blk_ptr_type(bap), [release]);
	if nb <> 0 then
	    blocksreleased := blocksreleased +
		indirtrunc(ip, nb, last, level - 1);
    end
    else
	if bap <> nil then
	    put_datablk(cache_blk_ptr_type(bap), [release]);
999:
    indirtrunc := blocksreleased;
end;

{
{ Truncate the inode ip to at most
{ length size.  Free affected disk
{ blocks -- the blocks of the file
{ are removed in reverse order.
{
{ NB: triple indirect blocks are untested.
}
procedure itrunc(oip: inode_ptr_type;
		 length: integer);
label
    555, 999;
var
    i, lastblock, bn, obn, nbn: integer;
    lastiblock: array [SINGLE..TRIPLE] of integer;
    fs: super_block_ptr_type;
    ip: inode_ptr_type;
    tip: inode_type;
    blocksreleased, nblocks: integer;
    size, level, oldspace, newspace: integer;
begin
    { count blocks released so can update inode }
    blocksreleased := 0;

    { no work to do? }
    if oip^.size.ls <= length then
	    goto 999;

    {
    { Calculate index into inode's block list of
    { last direct and indirect blocks (if any)
    { which we want to keep.  Lastblock is -1 when
    { the file is truncated to 0.
    }
    fs := current_super;
    lastblock := lblkno(fs, length + fs^.bsize - 1) - 1;
    lastiblock[SINGLE] := lastblock - NDADDR;
    lastiblock[DOUBLE] := lastiblock[SINGLE] - fs^.nindir;
    lastiblock[TRIPLE] := lastiblock[DOUBLE] - fs^.nindir * fs^.nindir;
    { device blocks per big block }
    nblocks := btodb(fs^.bsize);

    {
    { Update size of file and block pointers
    { on disk before we start freeing blocks.
    { If we crash before free'ing blocks below,
    { the blocks will be returned to the free list.
    { negative lastiblock values are also normalized to -1
    { (meaning everything in this block must be deleted)
    { for calls to indirtrunc below.
    }
    { tip has copy of block addresses we're about to zero }
    tip := oip^;
    for level := TRIPLE downto SINGLE do
	if lastiblock[level] < 0 then begin
	    { this indir block will go }
	    oip^.ib[level] := 0;
	    lastiblock[level] := -1;
	end;
    for i := NDADDR - 1 downto lastblock + 1 do
	oip^.db[i] := 0;
    oip^.size.ls := length;
    {
    { i_blocks will be 0 since file size is being truncated
    { to 0, so might as well have i_blocks and i_size
    { consistent when write out inode.
    }
    if length = 0 then
	oip^.blocks := 0;
    put_inode(oip, [dirty,immediate]);

    { now we actually release the blocks }
    ip := addr(tip);

    {
    { Indirect blocks first.
    }
    for level := TRIPLE downto SINGLE do begin
	bn := ip^.ib[level];
	if bn <> 0 then begin
	    { release blocks addressed by indir block }
	    blocksreleased := blocksreleased +
		indirtrunc(ip, bn, lastiblock[level], level);
	    { release indir block }
	    if lastiblock[level] < 0 then begin
		ip^.ib[level] := 0;
		xfree(ip, bn, fs^.bsize);
		blocksreleased := blocksreleased + nblocks;
	    end;

	end;
	{ finished? }
	if lastiblock[level] >= 0 then
		goto 555;
    end;

    {
    { All whole direct blocks or frags.
    }
    for i := NDADDR - 1 downto lastblock + 1 do begin
	bn := ip^.db[i];
	if bn <> 0 then begin
	    ip^.db[i] := 0;
	    size := blksize(fs, ip, i);
	    xfree(ip, bn, size);
	    blocksreleased := blocksreleased + btodb(size);
	end;
    end;
    { freed everything? }
    if lastblock < 0 then
	goto 555;

    {
    { Finally, look for a change in size of the
    { last direct block; release any frags.
    }
    obn := ip^.db[lastblock];
    if obn <> 0 then begin
	{
	{ Calculate amount of space we're giving
	{ back as old block size minus new block size.
	}
	oldspace := blksize(fs, ip, lastblock);
	ip^.size.ls := length;
	newspace := blksize(fs, ip, lastblock);
$if debug$
	if newspace = 0 then
	    panic('itrunc: newspace');
$end$
	if oldspace - newspace > 0 then begin
	    {
	    { Try to put newspace into a fragment cluster.
	    { If it won't fit, just break up the current block.
	    { In second case, block number of space to be freed is
	    { the old block # plus the number of frags
	    { required for the storage we're keeping.
	    }
	    if oldspace = fs^.bsize then
		nbn := alloc(oip, 0, newspace, false);
	    if (oldspace = fs^.bsize) and (nbn <> 0) then begin
		copy_user_data(fragstobytes(fs, obn),
			       fragstobytes(fs, nbn), newspace);
		xfree(oip, obn, oldspace);
		oip^.db[lastblock] := nbn;
		{ next line only to satisfy debugging check below }
		ip^.db[lastblock] := nbn;
		put_inode(oip, [dirty]);
		{ alloc already changes block count for newspace }
		blocksreleased := blocksreleased + btodb(oldspace);
	    end
	    else begin
		xfree(oip, obn + numfrags(fs, newspace), oldspace - newspace);
		blocksreleased := blocksreleased + btodb(oldspace - newspace);
	    end;
	end;
    end;

{done:}
555:
$if debug$
    { BEGIN PARANOIA }
    for level := SINGLE to TRIPLE do
	if ip^.ib[level] <> oip^.ib[level] then
	    panic('itrunc1');
    for i := 0 to NDADDR - 1 do
	if ip^.db[i] <> oip^.db[i] then
	    panic('itrunc2');
    { END PARANOIA }
$end$

    if length <> 0 then begin
	with oip^ do begin
	    blocks := blocks - blocksreleased;
	    if blocks < 0 then blocks := 0;       { sanity }
	end;
	put_inode(oip, [dirty]);
    end;
999:
end;


{
{ Truncate the file and free the inode.
}
procedure zapinode(ip: inode_ptr_type);
var
    mode: integer;
    saveioresult: integer;
    needs_trunc: boolean;
begin
    saveioresult := ioresult;
    ioresult := ord(inoerror);

    needs_trunc := has_blocks(ip) and (ip^.size.ls > 0);
    mode := ip^.mode;
    ip^.nlink := 0;
    ip^.mode := 0;
    if needs_trunc then
	itrunc(ip, 0)
    else begin
	{ next 2 lines useless but harmless for non-special files }
	ip^.db[0] := 0; {"rdev" field for special files}
	ip^.db[1] := 0; {"pseudo" field for special files}
	put_inode(ip, [dirty,immediate]);
    end;
    ifree(ip, binode_ptr_type(ip)^.inumber, mode);

    if ioresult = ord(inoerror) then
	ioresult := saveioresult;
end;


{
{ Remove the entry for inode ip from the directory pdir.
{ offset tells where it is.  We must change the previous
{ entry so that its reclen covers the one being deleted,
{ unless we are at a DIRBLKSIZE boundary, in which case
{ the previous entry is unchanged and our ino becomes 0.
{ Returns boolean indicating success.
}
function dirremove(ip, pdir: inode_ptr_type;
		   offset: integer): boolean;
label
    999;
var
    bp: cache_blk_ptr_type;
    dp, prevp: direntry_ptr_type;
    coffset, cblkstart: integer;
begin
    dirremove := false;

    { get slot to be removed }
    bp := rdwri(B_READ, pdir, offset, sizeof(direntrytype));
    if bp = nil then
	goto 999;

    coffset := offset mod cache_blk_size;
    dp := addr(bp^, coffset);
    cblkstart := coffset - (offset mod DIRBLKSIZE);
$if debug$
    if cblkstart < 0 then
	panic('dirremove');
$end$

    { show no longer in use }
    dp^.ino := 0;

    { adjust previous entry unless on DIRBLKSIZE boundary }
    if cblkstart < coffset then begin
	prevp := addr(bp^, cblkstart);
	{ point prev to previous entry }
	while integer(prevp) + prevp^.reclen < integer(dp) do
	    prevp := addr(prevp^, prevp^.reclen);
	if integer(prevp) + prevp^.reclen <> integer(dp) then begin
$if debug$
	    panic('bad dir in dirremove');
$end$
	    hfs_corrupt(current_super);
	    goto 999;
	end;
	{ lengthen previous entry }
	prevp^.reclen := prevp^.reclen + dp^.reclen;
    end;

    time_stamp(pdir, [ICHG,IMOD]);
    put_datablk(bp, [dirty,immediate,release]);
    dirremove := true;
999:
end;

{
{ drop a link to a file, zapping it if this is the last one.
}
procedure drop_link(ip: inode_ptr_type);
begin
    with ip^ do begin
	nlink := nlink - 1;
	if nlink = 0 then
	    zapinode(ip)
	else begin
	    time_stamp(ip, [ICHG]);
	    put_inode(ip, [dirty,immediate]);
	end;
    end;
end;



{
{ Delete a file (not a directory)
{ pdir is the parent directory, ip is the file to be deleted.
}
procedure unlink(ip, pdir: inode_ptr_type;
		 offset: integer);
begin
    if dirremove(ip, pdir, offset) then
	drop_link(ip);
end;


{----------------------------------------------------------------------}
{
{ FILE CREATION
}

{
{ Find a cylinder to place a directory.
{
{ The policy implemented by this algorithm is to select from
{ among those cylinder groups with above the average number of
{ free inodes, the one with the smallest number of directories.
{
{ Returns a preferred inumber (just the first inumber of
{ the preferred cg).
}
function dirpref(fs: super_block_ptr_type): integer;
var
    cg, minndir, mincg, avgifree: integer;
begin
    avgifree := fs^.cstotal.nifree div fs^.ncg;
    minndir := fs^.ipg;
    mincg := 0;
    for cg := 0 to fs^.ncg - 1 do
	with fs_cs(fs, cg)^ do
	    if (ndir < minndir) and
	       (nifree >= avgifree) then begin
		    mincg := cg;
		    minndir := ndir;
	    end;
    dirpref := fs^.ipg * mincg;
end;

{
{ Determine whether an inode can be allocated in a given cg.
{
{ Check to see if an inode is available, and if it is,
{ allocate it using the following policy:
{   1) allocate the requested inode.
{   2) allocate the next available inode after the requested
{      inode in the specified cylinder group.
{ Returns the inumber, or 0 if none there.
}
procedure ialloccg(ip: inode_ptr_type;
		   cg, ipref, mode: integer;
		   var result: integer);
label
    555, 999;
var
    fs: super_block_ptr_type;
    cgp: cgroup_ptr_type;
    i: integer;
begin
    result := 0;
    fs := current_super;

    { any free? }
    if fs_cs(fs, cg)^.nifree = 0 then
	goto 999;

    { get cgroup }
    cgp := get_cgroup(cg);
    if cgp^.cs.nifree = 0 then begin
	hfs_corrupt(fs);
	put_cgroup(cgp, [release]);
	goto 999;
    end;

    { if have preference and it's free, take it }
    if ipref <> 0 then begin
	ipref := ipref mod fs^.ipg;
	if isclr(cgp^.iused, ipref) then
	    goto 555;
    end
    else
	ipref := cgp^.irotor;

    { look sequentially, starting at pref (or rotor if no pref) }
    for i := 0 to fs^.ipg - 1 do begin
	ipref := ipref + 1;
	if ipref >= fs^.ipg then
	    ipref := 0;
	if isclr(cgp^.iused, ipref) then begin
	    cgp^.irotor := ipref;
	    goto 555;
	end;
    end;
    put_cgroup(cgp, [release]);
    goto 999;

555:
    { have free inode in pref }
    setbit(cgp^.iused, ipref);
    with cgp^.cs do
	nifree := nifree - 1;
    with fs^.cstotal do
	nifree := nifree - 1;
    with fs_cs(fs, cg)^ do
	nifree := nifree - 1;
    fs^.fmod := FS_MODIFIED;
    if binand(mode, IFMT) = IFDIR then begin
	with cgp^.cs do
	    ndir := ndir + 1;
	with fs^.cstotal do
	    ndir := ndir + 1;
	with fs_cs(fs, cg)^ do
	    ndir := ndir + 1;
    end;
    put_cgroup(cgp, [dirty,release]);
    result := (cg * fs^.ipg + ipref);
999:
end;

{
{ Allocate an inode in the file system.
{
{ A preference may be optionally specified. If a preference is given
{ the following hierarchy is used to allocate an inode:
{   1) allocate the requested inode.
{   2) allocate an inode in the same cylinder group.
{   3) quadradically rehash into other cylinder groups, until an
{      available inode is located.
{ If no inode preference is given the following heirarchy is used
{ to allocate an inode:
{   1) allocate an inode in cylinder group 0.
{   2) quadratically rehash into other cylinder groups, until an
{      available inode is located.
{
{ Returns ptr to the inode, or nil if none left or error.
}
function ialloc(pip: inode_ptr_type;
		ipref, mode: integer): inode_ptr_type;
label
    555, 999;
var
    fs: super_block_ptr_type;
    ino, cg: integer;
    ip: inode_ptr_type;
begin
    fs := current_super;
    ialloc := nil;

    { no inodes? }
    if fs^.cstotal.nifree = 0 then
	goto 555;

    { get preferred cg }
    if ipref >= (fs^.ncg * fs^.ipg) then
	ipref := 0;
    cg := itog(fs, ipref);

    ino := hashalloc(pip, cg, ipref, mode, ialloccg);
    if ino = 0 then
	goto 555;

    {
    { Some consistency checks.
    }
    ip := get_inode(ino);
    { KERNEL CODE DOES IFREE(PIP, INO, 0) IF IP IS NIL }
    if ip^.mode <> 0 then begin
$if debug$
	writeln('mode = ', ip^.mode:1, ', inum = ',
		ino:1, ', fs = ', fs^.fname);
	panic('ialloc: dup alloc');
$end$
	hfs_corrupt(fs);
	goto 999;
    end;
    if ip^.blocks <> 0 then begin
$if debug$
	writeln('free inode ', fs^.fname, ':', ino:1,
		' had ', ip^.blocks:1, ' blocks.');
$end$
	ip^.blocks := 0;
	hfs_corrupt(fs);
    end;

    {
    { The following fields are cleared because of their use
    { with fifos.  If the system crashed then their old
    { values would still be there.
    }
    if (ip^.ib[0] <> 0) or (ip^.ib[1] <> 0) or (ip^.ib[2] <> 0) then begin
	ip^.ib[0] := 0;
	ip^.ib[1] := 0;
	ip^.ib[2] := 0;
	put_inode(ip, [dirty,immediate]);
    end;

    { set all time stamps }
    time_stamp(ip, [IACC,ICHG,IMOD]);
    ialloc := ip;
    goto 999;
555:
    { no inodes }
$if debug$
    fserr(fs, 'out of inodes');
$end$
    ioresult := ord(idirfull);
999:
end;

{
{ Write a directory entry.  ip is the inode
{ to which the new entry refers.  pdir (parent ip) is the inode
{ of the directory containing the new entry.
{ offset is the location of a free slot, or the size of
{ the directory if there is no free slot.  Note that,
{ because of the way directories are grown, if offset = dir size,
{ then the dir size is at a DIRBLKSIZE boundary.
{ Returns boolean indicating success.
}
function direnter(ip: inode_ptr_type;
		  var filename: string255;
		  pdir: inode_ptr_type;
		  var offset: integer): boolean;
label
    999;
var
    dp, ep: direntry_ptr_type;
    bp: cache_blk_ptr_type;
    coffset, i: integer;
begin
    direnter := false;

    { get the slot at given offset }
    if offset = pdir^.size.ls then
	bp := rdwri(B_WRITE, pdir, offset, DIRBLKSIZE)
    else
	bp := rdwri(B_WRITE, pdir, offset, sizeof(direntrytype));
    if bp = nil then
	goto 999;
    coffset := offset mod cache_blk_size;
    dp := addr(bp^, coffset);

    { if growing dir, set reclen to cover new dirblk }
    if offset = pdir^.size.ls then begin
	dp^.ino := 0;
	dp^.reclen := DIRBLKSIZE;
    end
    else
    if coffset + dp^.reclen > cache_blk_size then begin
$if debug$
	panic('direnter');
$end$
	hfs_corrupt(current_super);
	goto 999;
    end;

    { claim entry for this inode }
    if dp^.ino <> 0 then begin
	{ this entry must be shrunk and skipped }
	ep := addr(dp^, sizeof(direntrytype));
	ep^.reclen := dp^.reclen - sizeof(direntrytype);
	dp^.reclen := sizeof(direntrytype);
	dp := ep;
	offset := offset + sizeof(direntrytype);
    end;
    { dp is our entry, and has correct reclen }
    with dp^ do begin
	ino := binode_ptr_type(ip)^.inumber;
	i := 0;
	while (i < DIRSIZ) and (i+1 <= strlen(filename)) do begin
	    name[i] := filename[i+1];
	    i := i + 1;
	end;
	namlen := i;
	while i < DIRSIZ do begin
	    name[i] := chr(0);
	    i := i + 1;
	end;
	{ this is probably unnecessary }
	for i := 0 to DIR_PADSIZE - 1 do
	    pad[i] := chr(0);
    end;

    { update dir first }
    put_datablk(bp, [release,dirty,immediate]);
    time_stamp(pdir, [ICHG,IMOD]);

    { then dir size, if needed }
    if pdir^.size.ls < offset + sizeof(direntrytype) then begin
	pdir^.size.ls := offset + sizeof(direntrytype);
	put_inode(pdir, [dirty,immediate]);
    end;

    direnter := true;
999:
end;


{
{ Make a new file by creating inode and entering name.
{ Returns the inode ptr, or nil if none.
{ Passes back corrected value of offset -- where the file
{ REALLY is in the parent dir.
{ make_entry tells whether to make dir entry
{ filebytes is preallocated size, or maj/min device number
}
function maknode(var filename: string255;
		 mode: integer;
		 pdir: inode_ptr_type;
		 make_entry: boolean;
		 filebytes: integer;
		 var offset: integer): inode_ptr_type;
label
    999;
var
    ip: inode_ptr_type;
    ipref: integer;
    fs: super_block_ptr_type;
    fmode: integer;
begin
    maknode := nil;
    fs := current_super;
    fmode := binand(mode, IFMT);

    { get preferred cg }
    if fmode = IFDIR then
	ipref := dirpref(current_super)
    else
	ipref := binode_ptr_type(pdir)^.inumber;

    ip := ialloc(pdir, ipref, mode);
    if ip = nil then
	goto 999;

    mode := binand(mode, bincmp(get_umask));

    ip^.mode := mode;
    if make_entry then
	ip^.nlink := 1;
    ip^.uid := get_uid;
    ip^.gid := get_gid;

    { try to preallocate the requested size }
    if fmode = IFREG then begin
	if filebytes > 0 then begin
	    if preallocate(ip, filebytes) then
		{ preallocate succeeded }
		ip^.size.ls := filebytes
	    else begin
		{
		{ prealloc failed.  set ioresult to inoroom
		{ unless there was already some other ioresult
		}
		{ must set size so deallocation will work }
		ip^.size.ls := filebytes; {JT/SFB 4/16/87}
		zapinode(ip);
		put_inode(ip, [release]);
		if ioresult = ord(inoerror) then
		    ioresult := ord(inoroom);
		goto 999;
	    end;
	end;
    end
    else
    if (fmode = IFBLK) or (fmode = IFCHR) then
	ip^.db[0] := filebytes;

    {
    { Make sure inode goes to disk before directory entry.
    }
    put_inode(ip, [dirty,immediate]);
    if make_entry and not direnter(ip, filename, pdir, offset) then begin
	{
	{ Write error occurred trying to update directory
	{ so must deallocate the inode.
	}
	zapinode(ip);
	put_inode(ip, [release]);
	goto 999;
    end;
    maknode := ip;
999:
end;


{
{ Create a new file.  We are given the name and mode, the parent inode, and
{ a size for preallocation.
{ We return the new inumber, or no_inode for failure.
{ Caller guarantees user has permission.
{ dir_entry tells whether to make a directory entry.
}
function create(var filename: string255;
		mode: integer;
		pdir: inode_ptr_type;
		offset, filebytes: integer;
		dir_entry: boolean): inode_ptr_type;
label
    999;
var
    ip: inode_ptr_type;
    fmode: integer;
    result: boolean;
begin
    create := nil;

    { be sure parent is a directory }
    if (binand(pdir^.mode, IFMT) <> IFDIR)
    or (binand(mode, IFMT) = IFDIR) then begin
$if debug$
	panic('create_file');
$end$
	ioresult := ord(inotondir);
	goto 999;
    end;

    { get a new inode and enter into this directory }
    if binand(mode, IFMT) = 0 then
	mode := binior(mode, IFREG);
    ip := maknode(filename, mode, pdir, dir_entry, filebytes, offset);

    create := ip;
999:
end;

function create_file(var filename: string255;
		     mode: integer;
		     pdir: inode_ptr_type;
		     offset, filebytes: integer): inode_ptr_type;
begin
    create_file := create(filename, mode, pdir, offset, filebytes, true);
end;

{
{ Link the file ip into the directory pdir under the
{ given simple name.  Caller guarantees that the name
{ doesn't already exist in this directory.
}
procedure link_file(ip: inode_ptr_type;
		    var filename: string255;
		    pdir: inode_ptr_type;
		    offset: integer);
label
    999;
begin
    if binand(ip^.mode, IFMT) = IFDIR then begin
$if debug$
	panic('link_file -- directory');
$end$
	ioresult := ord(inotondir);
	goto 999;
    end;

    if not direnter(ip, filename, pdir, offset) then
	goto 999;

    ip^.nlink := ip^.nlink + 1;
    time_stamp(ip, [ICHG]);
    put_inode(ip, [dirty,immediate]);
999:
end;

{------------------------------------------------------------------------}
{
{ DIRECTORY CREATION AND DELETION
}


{
{ Create a directory with the given mode.  pdir is the parent.
{ Returns ptr to inode of new dir.
}
function create_dir(var filename: string255;
		    mode: integer;
		    pdir: inode_ptr_type;
		    offset: integer): integer;
label
    888, 999;
var
    fs: super_block_ptr_type;
    ip: inode_ptr_type;
    bp: cache_blk_ptr_type;
    oldior: integer;    {to "protect" ioresult during cleanup. SFB}
begin
    create_dir := no_inode;
    fs := current_super;

    { normalize mode }
    if binand(pdir^.mode, IFMT) <> IFDIR then begin
$if debug$
	panic('create_dir');
$end$
	ioresult := ord(ifilenotdir);
	goto 999;
    end;

    mode := binand(mode, octal('777'));
    mode := binior(mode, IFDIR);

    {
    { Must simulate part of maknode here
    { in order to acquire the inode, but
    { not have it entered in the parent
    { directory.  The entry is made later
    { after writing "." and ".." entries out.
    }
    { get an inode for the directory }
    ip := ialloc(pdir, dirpref(fs), mode);
    mode := binand(mode, bincmp(get_umask));

    ip^.mode := mode;
    ip^.nlink := 2;
    ip^.uid := get_uid;
    ip^.gid := get_gid;
    put_inode(ip, [dirty,immediate]);

    {
    { Bump link count in parent directory
    { to reflect work done below.  Should
    { be done before reference is created
    { so repair is possible if we crash.
    }
    pdir^.nlink := pdir^.nlink + 1;
    put_inode(pdir, [dirty,immediate]);

    {
    { Initialize directory with "."
    { and ".." from static template.
    }
    dirtemplate[DOT].ino := binode_ptr_type(ip)^.inumber;
    dirtemplate[DOTDOT].ino := binode_ptr_type(pdir)^.inumber;

    bp := rdwri(B_WRITE, ip, 0, sizeof(dirtemplate));
    if bp = nil then
	goto 888;
    moveleft(dirtemplate, bp^, sizeof(dirtemplate));
    put_datablk(bp, [release,dirty,immediate]);

    ip^.size.ls := sizeof(dirtemplate);
    put_inode(ip, [dirty]);

    {
    { Directory all set up, now
    { install the entry for it in
    { the parent directory.
    }
    if not direnter(ip, filename, pdir, offset) then
	goto 888;

    create_dir := binode_ptr_type(ip)^.inumber;
    put_inode(ip, [release]);
    goto 999;

888:
    {
    { Got an error.  Ditch ip (the new dir) and reset link
    { count in parent directory.
    }
    oldior:=ioresult;   {SFB}
    ioresult:=ord(inoerror);    {SFB per Jim Tear example}
    zapinode(ip);
    put_inode(ip, [release]);
    pdir^.nlink := pdir^.nlink - 1;
    put_inode(pdir, [dirty,immediate]);
    if ioresult=ord(inoerror) then      {SFB}
     ioresult:=oldior;

999:
end;


{
{ Check if a directory is empty or not.
}
function dirempty(ip: inode_ptr_type): boolean;
var
    dummy: integer;
    empty: boolean;
    thisname: string255;
{------------------------}
procedure check(dp: direntry_ptr_type;
		offset: integer;
		anyvar inparams: integer;
		anyvar empty: boolean;
		var keep_going: boolean);
begin
    with dp^ do
	if ino <> 0 then begin
	    pac_to_string(name, namlen, thisname);
	    if (thisname <> '.') and (thisname <> '..') then begin
		empty := false;
		keep_going := false;
	    end;
	end;
end;
{------------------------}
begin
    empty := true;
    scan_dir(ip, check, dummy, empty);
    dirempty := empty;
end;

{
{ Remove a directory, including its entry in the parent dir.
{ Return boolean indicating success.
}
procedure rmdir(ip, pdir: inode_ptr_type;
		offset: integer);
label
    999;
begin
    {
    { No rmdir "." please.
    }
    if pdir = ip then begin
	ioresult := ord(inotclosed);
	goto 999;
    end;

    {
    { Verify the directory is empty (and valid).
    { (Rmdir ".." won't be valid since
    {  ".." will contain a reference to
    {  the current directory and thus be
    {  non-empty.)
    }
    if (ip^.nlink > 2) or not dirempty(ip) then begin
	ioresult := ord(idirnotempty);
	goto 999;
    end;

    {
    { Delete reference to directory before purging
    { inode.  If we crash in between, the directory
    { will be reattached to lost+found,
    }
    if not dirremove(ip, pdir, offset) then
	goto 999;
    pdir^.nlink := pdir^.nlink - 1;
    put_inode(pdir, [dirty,immediate]);

    {
    { Truncate inode.  The only stuff left
    { in the directory is "." and "..".  The
    { "." reference is inconsequential since
    { we're quashing it.  The ".." reference
    { has already been adjusted above.
    }
    zapinode(ip);
999:
end;

{
{ Delete a file or directory.
}
procedure delete_file(ip, pdir: inode_ptr_type;
		      offset: integer);
begin
    if binand(ip^.mode, IFMT) = IFDIR then
	rmdir(ip, pdir, offset)
    else
	unlink(ip, pdir, offset);
end;

{---------------------------------------------------------------}
{
{ CHANGE FILE SIZE
}

{
{ Truncate the file to the given length.  Ensure that
{ the file doesn't have a hole at its very end.
{ Returns boolean indicating success.
{ Intended for close(f, 'crunch').
{ Grows the file if needed; caller must ensure this is OK.
}
function change_file_size(ip: inode_ptr_type;
			  size: integer): boolean;
label
    999;
var
    frag: frag_type;
    fs: super_block_ptr_type;
begin
    change_file_size := true;
    if not has_blocks(ip) then begin
$if debug$
	panic('change_file_size');
$end$
	ioresult := ord(inoaccess);
	goto 999;
    end;

    if size = ip^.size.ls then
	goto 999;

    { truncate file }
    itrunc(ip, size);

    { be sure last byte is not a hole }
    if size > 0 then begin
	fs := current_super;
	frag := bmap(ip,
		     lblkno(fs, size - 1),
		     B_WRITE,
		     blkoff(fs, size-1)+1);
	if frag = BMAP_ERROR then begin
	    change_file_size := false;
	    goto 999;
	end;
    end;

    if size <> ip^.size.ls then begin
	ip^.size.ls := size;
	put_inode(ip, [dirty]);
    end;

    time_stamp(ip, [IMOD,ICHG]);
999:
end;

{--------------------------------------------------------------------}
{
{ GET_DBNUM
}

{
{ get_dbnum
{ translates a logical file position into a physical disc position
{ (both in bytes).  Params are:
{       inode of file
{       logical position in file
{       length of desired transfer
{       type of transfer (B_READ, B_WRITE, B_ZWRITE)
{ Returns:
{       fragment number
{       or BMAP_HOLE when reading a hole,
{       or BMAP_ERROR on error
{ The length of the transfer is ignored with B_READ.
{ It is important with B_WRITE, because we may have to allocate new blocks.
{ B_WRITE and B_ZWRITE are the same, except that B_ZWRITE always zeroes
{ new blocks, while B_WRITE does not.  B_WRITE causes the zeroing info
{ to appear in
{       zstart          byte start of new block
{       zlength         length of new block in bytes, or 0 if none
{ Caller guarantees that the requested transfer does NOT cross
{ a bsize (normally 8K) boundary.
{ Caller must check for reading past EOF.
{ We update the inode size when writing past EOF.
}
function get_dbnum(ip: inode_ptr_type;
		   position: integer;
		   rwflag: bmap_mode;
		   length: integer): integer;
var
    lblk: lblk_type;
    dblk: frag_type;
    xfer_length: integer;
begin
    try
	lblk := lblkno(current_super, position);
	xfer_length := blkoff(current_super, position) + length;
	if xfer_length > current_super^.bsize then begin
$if debug$
	    panic('get_dbnum');
$end$
	    ioresult := ord(zcatchall);
	    escape(0);
	end;
	dblk := bmap(ip, lblk, rwflag, xfer_length);

	if (dblk <> BMAP_ERROR)
	and (dblk <> BMAP_HOLE)
	and (rwflag <> B_READ) then
	    { update EOF if writing past it }
	    if ip^.size.ls < position + length then begin
		ip^.size.ls := position + length;
		put_inode(ip, [dirty]);
	    end;

	get_dbnum := dblk;
    recover
	get_dbnum := BMAP_ERROR;
end;

{---------------------------------------------------------------------------}
{
{ SCAN_DIR
{
{ directory scanner
{ scans directories, calling given procedure with given params.
{ procedure sets keep_going false when ready to stop
}
procedure scan_dir(pdir: inode_ptr_type;
		   scanner: scan_proc;
		   anyvar inparams, outparams: integer);
label
    999;
var
    dp: direntry_ptr_type;
    begp, endp: cache_blk_ptr_type;
    diskblk, thisread, offset: integer;
    fs: super_block_ptr_type;
    keep_going: boolean;
begin
    offset := 0;
    begp := nil;
    fs := current_super;
    keep_going := true;

    { scan through directory }
    while offset < pdir^.size.ls do begin

	{ bytes to read this time }
	thisread := min(cache_blk_size, pdir^.size.ls - offset);

	{ get next cache blk }
	if begp <> nil then
	    put_datablk(begp, [release]);
	diskblk := get_dbnum(pdir, offset, B_READ, thisread);
	begp := get_datablk(diskblk, blkoff(fs, offset));

	dp := direntry_ptr_type(begp);
	endp := addr(begp^, thisread);

	{ scan through this cache blk }
	while integer(dp) < integer(endp) do begin
	    call (scanner, dp, offset, inparams, outparams, keep_going);
	    if not keep_going then
		goto 999;
	    offset := offset + dp^.reclen;
	    dp := addr(dp^, dp^.reclen);
	end;
    end;

999:
    if begp <> nil then
	put_datablk(begp, [release]);
end;

{-----------------------------------------------------------------------}
{
{ FOUNDNAME
{ find name in directory pdir
{ returns true if found
{ sets, in pathinfo
{       ino -- inumber of file found
{       parent_ino -- inumber of parent dir
{               can be incorrect if name is ..
{       offset -- dir offset (see comments at traverse_path)
{ dir_required -- if entry is not a dir, pretend we couldn't find it.
{ NOTE: we return no ioresult if file not found, since many callers
{ use this routine when it's illegal for the file to exist anyway.
}
function foundname(var name: string;
		   dir_required: boolean;
		   pdir: inode_ptr_type;
		   var pathinfo: pathinfotype): boolean;
label
    999;
type
    inrec_type = record
	nameptr: string255ptr;
	want_dir: boolean;
    end;
    outrec_type = record
	ino: integer;
	diroff: integer;
    end;
var
    inrec: inrec_type;
    outrec: outrec_type;
    ip: inode_ptr_type;
{--------------------}
procedure check_entry(dp: direntry_ptr_type;
		      offset: integer;
		      anyvar inrec: inrec_type;
		      anyvar outrec: outrec_type;
		      var keep_going: boolean);
var
    thisname: string255;
    ip: inode_ptr_type;
    entry_wanted: boolean;
begin
    with dp^ do begin
	{ is this the entry we want? }
	pac_to_string(name, namlen, thisname);
	if (ino <> 0) and (thisname = inrec.nameptr^) then
	    if inrec.want_dir then begin
		ip := get_inode(ino);
		entry_wanted := (itype(ip) = IFDIR);
		{ stop looking, whether it's a dir or not }
		keep_going := false;
		put_inode(ip, [release]);
	    end
	    else
		entry_wanted := true
	else
	    entry_wanted := false;

	if entry_wanted then begin
	    keep_going := false;
	    outrec.ino := ino;
	    outrec.diroff := offset;
	end
	else
	if (ino = 0) or (reclen > sizeof(direntrytype)) then
	    outrec.diroff := offset;
    end;
end;
{--------------------}
begin {foundname}
    foundname := false;

    if itype(pdir) <> IFDIR then begin
	ioresult := ord(ifilenotdir);
	goto 999;
    end;

    inrec.nameptr := addr(name);
    inrec.want_dir := dir_required;

    outrec.diroff := -1;
    outrec.ino := no_inode;

    scan_dir(pdir, check_entry, inrec, outrec);

    { diroff meaningful whether file found or not }
    if outrec.diroff = -1 then
	pathinfo.diroff := pdir^.size.ls
    else
	pathinfo.diroff := outrec.diroff;

    if outrec.ino <> no_inode then begin
	foundname := true;
	{ ino, parent_ino meaningful only if file found }
	pathinfo.ino := outrec.ino;
	pathinfo.parent_ino := inumber(pdir);
    end;
999:
end;

{
{ allocate an anonymous inode.
{ we use pdir to help choose the cgroup.
}
function alloc_inode(pdir: inode_ptr_type;
		     mode: integer;
		     bytes: integer): inode_ptr_type;
var
    dummyname: string255;
begin
    dummyname := '';
    alloc_inode := create(dummyname, mode, pdir, 0, bytes, false);
end;

{
{ deallocate an inode not in any directory
}
procedure dealloc_inode(var ip: inode_ptr_type);
label
    999;
begin
    if ip^.nlink <> 0 then begin
$if debug$
	panic('dealloc called on ip with links');
$end$
	ioresult := ord(zcatchall);
	goto 999;
    end;
    zapinode(ip);
    put_inode(ip, [release]);
999:
    ip := nil;
end;


{
{ Enter a file in a directory.
{ ip is the file, pdir the directory.
{ name is the new name.
{ If a file with this name already exists, delete it.
}
procedure enter_file(ip, pdir: inode_ptr_type;
		     var name: string255);
label
    999;
var
    pathinfo: pathinfotype;
    blocknum: integer;
    cache_ptr: cache_blk_ptr_type;
    dir_ptr: direntry_ptr_type;
    old_inodep: inode_ptr_type;
begin
    old_inodep := nil;
    cache_ptr := nil;
    { don't touch directories }
    if itype(ip) = IFDIR then begin
	ioresult := ord(inotondir);
	goto 999;
    end;
    ip^.nlink := 1;
    put_inode(ip, [dirty,immediate]);

    if foundname(name, false, pdir, pathinfo) then begin
	{ file exists, so look at dir entry }
	blocknum := get_dbnum(pdir, pathinfo.diroff, B_READ, 0);
	if blocknum = BMAP_ERROR then
	    goto 999;
	cache_ptr := get_datablk(blocknum,
				 blkoff(current_super, pathinfo.diroff));
	dir_ptr := addr(cache_ptr^, pathinfo.diroff mod cache_blk_size);

	{ don't touch a directory }
	old_inodep := get_inode(dir_ptr^.ino);
	if itype(old_inodep) = IFDIR then begin
	    ioresult := ord(inotondir);
	    goto 999;
	end;

	{ drop old file, substitute new one }
	drop_link(old_inodep);
	dir_ptr^.ino := inumber(ip);
	put_datablk(cache_ptr, [dirty,immediate]);
    end
    else begin
	{ file not there }
	if not direnter(ip, name, pdir, pathinfo.diroff) then
	    ;
    end;
999:
    put_inode(old_inodep, [release]);
    put_datablk(cache_ptr, [release]);
end;

{
{ delete ip from pdir
{ We don't know dir offset, but we know the file's name.
}
procedure delete_filename(ip, pdir: inode_ptr_type;
			  var name: string255);
var
    pathinfo: pathinfotype;
begin
    if foundname(name, false, pdir, pathinfo) then
	delete_file(ip, pdir, pathinfo.diroff)
    else
	ioresult := ord(inofile);
end;

{-----------------------------------------------------------------------}
{
{ Tell whether user has given permission on given inode.
{ Sets ioresult to inopermission if not.
{ Uses HP-UX algorithm: look at the "most privileged" category
{     only, with no second or third try.
}
function permission(inodep: inode_ptr_type;
		    perm_needed: permission_type): boolean;
var
    themode: packed record case boolean of
	      true : (num: ushort);
	      false: (pad: 0..127;
		      usr: 0..7;
		      grp: 0..7;
		      oth: 0..7);
	     end;
    sameuser, samegroup: boolean;
    tmp_perm: boolean;
begin
    if get_uid = 0 {superuser} then
	permission := true
    else with inodep^ do begin
	themode.num    := mode;
	sameuser       := get_uid = uid;
	samegroup      := get_gid = gid;

	if sameuser then
	    tmp_perm := (iand(themode.usr, perm_needed) = perm_needed)
	else
	if samegroup then
	    tmp_perm := (iand(themode.grp, perm_needed) = perm_needed)
	else
	    tmp_perm := (iand(themode.oth, perm_needed) = perm_needed);
	if not tmp_perm then
	    ioresult := ord(inopermission);
	permission := tmp_perm;
    end;
end;

{
{ Does this inode have disk blocks?
}
function has_blocks(ip: inode_ptr_type): boolean;
var
    filetype: integer;
begin
    filetype := itype(ip);
    has_blocks := (filetype <> IFBLK) and
		  (filetype <> IFCHR);
end;


end.


@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.3
log
@Pws2unix automatic delta on Sat Aug 15 16:14:36 MDT 1987
@
text
@@


21.2
log
@Set ioresult <> inoerror when escaping bmap
Set ioresult <> inoerror when escaping bmap (escape(0)).
@
text
@a119 1
    {
a120 1
    }
@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@d120 1
d122 1
d3440 1
@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.2
log
@"Out of space" was not reported when making directory on full disc.
Data space is need (1KB) for "." and "..". This is fixed: now reports
out of space error in this circumstance
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@d3361 1
d3437 1
d3442 2
@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.2
log
@Added proper deallocation of bigblock when not enough contiguous frags
to create prealloc file. Needs testing in 3.2I.
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@d3232 2
@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.2
log
@ls
Fixes at FSDat00572. Reorder code to force superblock to disk before
setting corrupt bit.
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@a431 1
    set_corrupt;
d434 2
@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.3
log
@Fix terrible bug whereby deleting 0-length file (must be .ux file) creates corrupt fs
because zapped inode never marked dirty.
@
text
@@


4.2
log
@Remove references to hfs_user.
@
text
@d2773 1
d2778 2
a2780 1
    mode := ip^.mode;
d2782 1
a2782 1
    if has_blocks(ip) then
d2785 1
@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@d15 1
a15 1
$search 'hfstuff', 'hfsupport', 'hfscalc', 'hfscache', 'hfs_user'$
@


3.2
log
@Protect debugging stuff with $if debug$ (now off).
Some cases of better error handling.
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@d1 2
a3 1
$modcal$
a4 2
$partial_eval$ { a MUST for this module }
$allow_packed$
d6 3
a12 2
$search 'hfstuff', 'support', 'hfscalc', 'hfscache'$

d15 2
a114 3
var
    zstart, zlength: integer;

d118 2
d429 1
d431 1
d444 1
d449 1
d462 1
d465 1
d489 1
d491 1
d533 1
d535 1
d592 1
d599 1
d627 4
a630 2
	    {mask = 0x0f << ((h & 0x1) << 2);
	    return ((cp[h >> 1] & mask) == mask);}
d637 4
a640 2
	    {mask = 0x03 << ((h & 0x3) << 1);
	    return ((cp[h >> 2] & mask) == mask);}
d647 4
a650 2
	    {mask = 0x01 << (h & 0x7);
	    return ((cp[h >> 3] & mask) == mask);}
d657 1
d659 1
d689 3
a691 1
	    {cp[h >> 1] &= ~(0x0f << ((h & 0x1) << 2));}
d698 3
a700 1
	    {cp[h >> 2] &= ~(0x03 << ((h & 0x3) << 1));}
d707 3
a709 1
	    {cp[h >> 3] &= ~(0x01 << (h & 0x7));}
d716 1
d718 1
d749 3
a751 1
	    {cp[h >> 1] |= (0x0f << ((h & 0x1) << 2));}
d758 3
a760 1
	    {cp[h >> 2] |= (0x03 << ((h & 0x3) << 1));}
d767 3
a769 1
	    {cp[h >> 3] |= (0x01 << (h & 0x7));}
d776 1
d778 1
d896 1
d899 1
d1283 1
d1287 1
d1304 1
d1308 1
d1585 1
d1589 2
d1611 1
d1615 1
d1654 1
d1658 1
d1744 1
d1748 1
d1751 3
d1783 1
d1785 1
a1786 1
    alloc := 0;
d1811 1
d1816 1
d1820 3
d1831 1
d1835 3
d1878 1
d1880 1
a1881 1
    realloccg := 0;
a1906 2
{   zero by caller -- caller looks at zstart and zlength, which
{       give (bytes) the start and length of the unzeroed piece.
d1925 1
a1925 1
    zlength := 0;
d1929 1
d1931 2
d2013 1
a2013 1
	    if not is_control then begin
d2016 1
a2016 1
	    end;
d2046 2
a2047 1
    if j = 0 then
d2049 4
d2123 1
a2123 1
	    if not this_control then begin
d2126 1
a2126 1
	    end;
d2306 1
d2308 1
d2313 1
d2315 1
d2351 1
d2354 1
d2364 1
d2374 1
d2378 2
a2379 1
    if bn = BMAP_HOLE then
d2381 3
d2407 1
d2410 3
d2422 1
d2425 1
d2710 1
d2713 1
d2744 1
d2753 1
d2821 1
d2824 1
d2835 2
a2836 1
	if integer(prevp) + prevp^.reclen <> integer(dp) then
d2838 4
d3021 1
d3042 1
d3045 2
d3048 1
a3048 1
	panic('ialloc: dup alloc');
d3051 1
d3054 1
d3056 1
d3077 1
d3079 1
a3080 1
    ialloc := nil;
d3123 7
a3129 2
	if coffset + dp^.reclen > cache_blk_size then
	    panic('direnter');
d3280 3
a3282 1
    if (binand(pdir^.mode, IFMT) <> IFDIR) or (binand(mode, IFMT) = IFDIR) then
d3284 4
d3319 3
a3322 1
	panic('link_file -- directory');
d3360 2
a3361 1
    if binand(pdir^.mode, IFMT) <> IFDIR then
d3363 5
d3553 2
a3554 1
    if not has_blocks(ip) then
d3556 4
d3630 2
a3631 1
	if xfer_length > current_super^.bsize then
d3633 4
d3639 3
a3641 1
	if (dblk <> BMAP_ERROR) and (dblk <> BMAP_HOLE) then
d3828 2
d3831 2
a3832 1
    if ip^.nlink <> 0 then
d3834 4
d3840 1
@


2.6
log
@Remove the "invalid"s from last delta; they were wrong and caused
a corrupt file system.
@
text
@@


2.5
log
@In indirtrunc, make changed indir blocks invalid in cache.  This
causes the same cache block to be reused, which is OK
since the info won't be looked at again anyway.
@
text
@d2429 1
a2429 1
	    put_datablk(cache_blk_ptr_type(bap), [release,invalid]);
d2477 1
a2477 1
		put_datablk(cache_blk_ptr_type(bap), [release,invalid]);
d2490 1
a2490 1
	    put_datablk(cache_blk_ptr_type(bap), [release,invalid]);
@


2.4
log
@Avoid read access time stamp unless old stamp older than 10 seconds old.
Rearrange code slightly so that file creation only writes new inode
once (was twice, once before and once after dir entry made).
@
text
@d2371 5
d2429 1
a2429 1
	    put_datablk(cache_blk_ptr_type(bap), [release]);
d2477 1
a2477 1
		put_datablk(cache_blk_ptr_type(bap), [release]);
d2490 1
a2490 1
	    put_datablk(cache_blk_ptr_type(bap), [release]);
@


2.3
log
@Debug etc now off.
@
text
@d111 2
d553 2
d560 1
d564 12
a575 6
	if IACC in which then
		atime := now;
	if ICHG in which then
		ctime := now;
	if IMOD in which then
		mtime := now;
d577 2
a578 1
    put_inode(ip, [dirty]);
d2388 1
d2439 1
d2441 6
a2446 2
	    bap^[i] := 0;
	put_datablk(cache_blk_ptr_type(bap), [dirty,immediate]);
d2509 1
a2509 1
    size, level, ftype, oldspace, newspace: integer;
a2517 5
    { be sure file type has blocks }
    ftype := binand(oip^.mode, IFMT);
    if (ftype <> IFREG) and (ftype <> IFDIR) and (ftype <> IFLNK) then
	    goto 999;

d2673 1
d2675 3
a2678 1
    itrunc(ip, 0);
d2681 7
a2687 2
    ip^.db[0] := 0; {"rdev" field for special files}
    ip^.db[1] := 0; {"pseudo" field for special files}
d2689 3
a2691 1
    put_inode(ip, [dirty,immediate]);
d2715 1
a2715 1
    bp := rdwri(B_WRITE, pdir, offset, sizeof(direntrytype));
d3060 1
d3066 1
d3074 1
d3078 1
d3081 1
a3081 1
    if binand(mode, IFMT) = IFDIR then
d3098 23
d3167 1
a3167 3
    ip := maknode(filename, mode, pdir, dir_entry, offset);
    if ip = nil then
	goto 999;
a3168 31
    fmode := binand(ip^.mode, IFMT);
    if fmode = IFREG then begin
	if filebytes > 0 then begin
	    if preallocate(ip, filebytes) then begin
		{ preallocate succeeded }
		ip^.size.ls := filebytes;
		put_inode(ip, [dirty,immediate]);
	    end
	    else begin
		{
		{ prealloc failed.  set ioresult to inoroom
		{ unless there was already some other ioresult
		}
		if ioresult = ord(inoroom) then
		    ioresult := ord(inoerror);
		if dir_entry then
		    result := dirremove(ip, pdir, offset);
		zapinode(ip);
		put_inode(ip, [release]);
		if ioresult = ord(inoerror) then
		    ioresult := ord(inoroom);
		goto 999;
	    end;
	end;
    end
    else
    if (fmode = IFBLK) or (fmode = IFCHR) then begin
	ip^.db[0] := filebytes;
	put_inode(ip, [dirty]);
    end;

d3420 1
a3420 1
    if binand(ip^.mode, IFMT) <> IFREG then
d3805 13
a3819 4
{
{ Things to do:
{ review all "immediate"s
}
@


2.2
log
@Moved permission function to here so hfstm can use it.
hfs_corrupt now sets fclean to FS_NOTOK.
@
text
@a3 1
$debug on$
d6 4
@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@d28 6
d51 2
d105 3
d421 1
a421 1
procedure hfs_corrupt;
d425 2
d451 1
a451 1
	hfs_corrupt;
d624 1
a624 1
	    hfs_corrupt;
d675 1
a675 1
	    hfs_corrupt;
d727 1
a727 1
	    hfs_corrupt;
d808 1
a808 1
	    hfs_corrupt;
d846 1
a846 1
    hfs_corrupt;
d1232 1
a1232 1
	    hfs_corrupt;
d1251 1
a1251 1
	hfs_corrupt;
d1255 1
a1255 1
	hfs_corrupt;
d1320 1
a1320 1
	hfs_corrupt;
d1535 1
a1535 1
	hfs_corrupt;
d1553 1
a1553 1
	    hfs_corrupt;
d1594 1
a1594 1
		hfs_corrupt;
d2321 1
a2321 1
	hfs_corrupt;
d2812 1
a2812 1
	hfs_corrupt;
d2911 1
a2911 1
	hfs_corrupt;
d3745 26
d3772 13
a3788 4
{       1) standardize error reporting and ioerrors
{       2) recover from panics, more or less
{ when get a disc error, set ioerror right away.  perhaps refuse to
{ deal with the FS until run fsck?
@


1.19
log
@use xreport for writeln
@
text
@@


1.18
log
@Postpone setting inoroom in preallocate() to prevent problems
with lower routines seeing an ioresult and not working.

@
text
@d412 1
a412 1
    writeln('HFS CORRUPT');
d464 1
a464 1
    writeln('ZERO DATA');
d506 1
a506 1
writeln('COPY CONTROL DATA');
@


1.17
log
@Fix bug where copy_control_data called instead of
copy_user_data.
In itrunc, use existing frag cluster for end of file if possible.
@
text
@d413 1
d2128 1
a2128 1
    exists := false;
d2161 1
a2161 1
	exists := (freespace(fs, fs^.minfree) >= 0);
a2167 3
    if not exists then
	ioresult := ord(inoroom);
    space_exists := exists;
a2180 2
{ It's not clear to me (Hal) that a big chunk of space
{ provides any advantage over a series of smaller chunks.
d3118 2
d3124 2
@


1.16
log
@Change a few functions to procedures.
In foundname, stop if find name, regardless of dir_required.
@
text
@d463 1
d505 1
d1829 1
a1829 1
    is_control: boolean;
d1860 1
a1860 1
			    true);
d2010 5
a2014 2
	    { do zeroing if indirect block, or dir, or B_ZWRITE }
	    is_control := is_control or (j < NIADDR);
d2017 1
a2017 1
	    nb := alloc(ip, pref, fs^.bsize, is_control);
d2022 1
a2022 1
	    if not is_control then begin
d2473 1
a2473 1
    i, lastblock, bn: integer;
d2581 2
a2582 2
    bn := ip^.db[lastblock];
    if bn <> 0 then begin
d2594 3
a2596 1
	    { Block number of space to be free'd is
d2600 17
a2616 3
	    bn := bn + numfrags(fs, newspace);
	    xfree(ip, bn, oldspace - newspace);
	    blocksreleased := blocksreleased + btodb(oldspace - newspace);
d2631 1
a2631 1
    if length <> 0 then
d2636 2
a2637 1
    put_inode(oip, [dirty]);
a3395 6
    { change inode size to reflect possible shrinking by itrunc }
    if size < ip^.size.ls then begin
	ip^.size.ls := size;
	put_inode(ip, [dirty]);
    end;

d3409 1
a3409 2
    { set inode size if file grew }
    if size > ip^.size.ls then begin
@


1.15
log
@Better error checking.
dirempty now uses scan_dir.
scan_dir now assumes that scanner routines leave "keep_going" param
alone unless they want to stop scanning.
@
text
@d62 4
a65 4
function link_file(ip: inode_ptr_type;
		   var filename: string255;
		   pdir: inode_ptr_type;
		   offset: integer): boolean;
d86 2
a87 2
function delete_file(ip, pdir: inode_ptr_type;
		     offset: integer): boolean;
d2711 2
a2712 2
function unlink(ip, pdir: inode_ptr_type;
		offset: integer): boolean;
d2714 1
a2714 1
    if dirremove(ip, pdir, offset) then begin
a2715 4
	unlink := true;
    end
    else
	unlink := false;
d3131 4
a3134 4
function link_file(ip: inode_ptr_type;
		   var filename: string255;
		   pdir: inode_ptr_type;
		   offset: integer): boolean;
a3137 1
    link_file := false;
a3149 1
    link_file := true;
d3286 2
a3287 2
function rmdir(ip, pdir: inode_ptr_type;
	       offset: integer): boolean;
a3290 1
    rmdir := false;
a3328 1
    rmdir := true;
d3335 2
a3336 2
function delete_file(ip, pdir: inode_ptr_type;
		     offset: integer): boolean;
d3339 1
a3339 1
	delete_file := rmdir(ip, pdir, offset)
d3341 1
a3341 1
	delete_file := unlink(ip, pdir, offset);
d3525 3
d3566 2
d3711 2
a3712 4
    if foundname(name, false, pdir, pathinfo) then begin
	if delete_file(ip, pdir, pathinfo.diroff) then
	    ;
    end
@


1.14
log
@Use sysgmttime instead of homegrown routine.
@
text
@d402 148
d606 4
a609 1
	panic('isblock');
d657 1
d659 2
d709 4
a712 1
	panic('setblock');
a719 4
{---------------------------------------------------------------}
{
{ ERROR AND MISCELLANEOUS ROUTINES
}
a720 143
{
{ Something corrupt in the file system.
}
procedure hfs_corrupt;
begin
    writeln('HFS CORRUPT');
    ioresult := ord(icorrupt);
end;

{
{ Fserr prints the name of a file system with an error diagnostic.
{
{ The form of the error message is:
{       fs: error message
}
procedure fserr(fs: super_block_ptr_type; cp: string255);
begin
	writeln(fs^.fname, ': ', cp);
end;

{
{ Check that a specified block number is in range.
}
function badblock(fs: super_block_ptr_type;
		  bn: frag_type): boolean;
var
    bad: boolean;
begin
    bad := (bn >= fs^.size);
    if bad then begin
	hfs_corrupt;
	writeln('bad block ', bn:1);
	fserr(fs, 'bad block');
    end;
    badblock := bad;
end;

{
{ Zeroes the disk at fragnum for size bytes.
{ For user data AND directories, so go through the cache.
{ Zeroes from the LAST cache blk to the FIRST, so that the
{ first block is sure to be left in the cache.
}
procedure zero_data(fragnum: frag_type;
		    size: integer);
label
    999;
var
    ip: cache_blk_ptr_type;
    cp: ^char;
    offset: integer;
    i, bytes: integer;
begin
    { set offset to highest cache blk multiple < size }
    offset := rounddownp2(size-1, cache_blk_size);
    while offset >= 0 do begin
	{ bytes = number of bytes this transfer }
	if size - offset < cache_blk_size then begin
	    bytes := size - offset;
	    ip := get_datablk(fragnum, offset);
	end
	else begin
	    bytes := cache_blk_size;
	    ip := get_edatablk(fragnum, offset);
	end;
	{if ip = nil then
	    goto 999;}
	cp := addr(ip^);
	for i := 1 to bytes do begin
	    cp^ := chr(0);
	    cp := addr(cp^, 1);
	end;
	put_datablk(ip, [release,dirty,immediate]);
	offset := offset - cache_blk_size;
    end;
999:
end;


{
{ Copies size bytes from fragment ofrag to fragment nfrag.
{ Copies through cache.  Use copy_user_data to go around cache.
{ After copy, source data blocks now free on disc, so don't leave
{ them valid in the cache.
}
procedure copy_control_data(ofrag, nfrag: frag_type;
			    size: integer);
label
    999;
type
    charptr = ^char;
var
    fp, tp: cache_blk_ptr_type;
    offset: integer;
    bytes: integer;
begin
    offset := 0;
    while offset < size do begin
	fp := get_datablk(ofrag, offset);
	if size - offset < cache_blk_size then begin
	    bytes := size - offset;
	    tp := get_datablk(nfrag, offset);
	end
	else begin
	    bytes := cache_blk_size;
	    tp := get_edatablk(nfrag, offset);
	end;
	moveleft(fp^, tp^, bytes);
	put_datablk(fp, [release,invalid]);
	put_datablk(tp, [release,dirty,immediate]);
	offset := offset + cache_blk_size;
    end;
999:
end;

{
{ stamp the time on an inode
{ there are 3 time fields:
{       atime -- file read
{       mtime -- file modified
{       ctime -- inode changed
{ we now set these times when the routine is called
{ we could set flags in the inode, and set the times only when we
{ go to disc.
}
procedure time_stamp(ip: inode_ptr_type;
		     which: time_stamp_set);
var
    now: integer;
begin
    now := sysgmttime;
    with ip^ do begin
	if IACC in which then
		atime := now;
	if ICHG in which then
		ctime := now;
	if IMOD in which then
		mtime := now;
    end;
    put_inode(ip, [dirty]);
end;


d830 1
d1216 1
d1235 1
a1302 2
    {if cgp = nil then
	goto 999;}
a1445 2
    {if cgp = nil then
	goto 999;}
a1517 1
    cg := dtog(fs, bno);
d1522 1
a1525 2
    {if cgp = nil then
	goto 999;}
a1985 2
	{if bap = nil then
	    goto 999;}
a2074 2
    {if cgp = nil then
	goto 999;}
d2120 1
d2122 1
a2122 1
    space_exists := false;
d2155 1
a2155 1
	space_exists := (freespace(fs, fs^.minfree) >= 0);
d2162 3
a2300 2
    {if cgp = nil then
	goto 999;}
d2307 1
a2395 2
	{if bap = nil then
	    goto 999;}
a2438 2
	    {if bap = nil then
		goto 999;}
d2479 4
a2487 4
    { no work to do? }
    if oip^.size.ls <= length then
	    goto 999;

a2783 2
    {if cgp = nil then
	goto 999;}
a3107 2
		if ioresult = ord(inoerror) then
		    ioresult := ord(inoroom);
a3260 2
label
    999;
d3262 9
a3270 3
    off, thisread: integer;
    bp: cache_blk_ptr_type;
    dp: direntry_ptr_type;
d3272 7
a3278 36
    dirempty := false;
    off := 0;
    bp := nil;
    { scan through directory }
    while off < ip^.size.ls do begin

	{ bytes to read this time }
	thisread := min(cache_blk_size, ip^.size.ls - off);

	{ get next cache blk }
	if bp <> nil then
	    put_datablk(bp, [release]);
	bp := rdwri(B_READ, ip, off, thisread);
	if bp = nil then
	    goto 999;
	dp := direntry_ptr_type(bp);

	{ scan through this cache blk }
	while integer(dp) < integer(bp) + cache_blk_size do begin
	    { skip empty entries }
	    with dp^ do
		if ino <> 0 then begin
		    { accept only "." and ".." }
		    if namlen > 2 then
			goto 999;
		    if name[0] <> '.' then
			goto 999;
		    {
		    { At this point d_namlen must be 1 or 2.
		    { 1 implies ".", 2 implies ".." if second
		    { char is also "."
		    }
		    if (namlen <> 1) and (name[1] <> '.') then
			goto 999;
		end;
	    dp := addr(dp^, dp^.reclen);
a3279 6
	off := off + cache_blk_size;
    end;
    dirempty := true;
999:
    if bp <> nil then
	put_datablk(bp, [release]);
d3281 6
d3449 6
a3454 6
    lblk := lblkno(current_super, position);
    xfer_length := blkoff(current_super, position) + length;
    if xfer_length > current_super^.bsize then
	panic('get_dbnum');
    dblk := bmap(ip, lblk, rwflag, xfer_length);
    if (dblk <> BMAP_ERROR) and (dblk <> BMAP_HOLE) then begin
d3456 6
a3461 8
	{
	{ Set time stamp in inode.
	{ Here we used to set access time for reading, but this
	{ is now gone because of performance and because of problems
	{ with read-only discs.
	}
	if (rwflag = B_WRITE) or (rwflag = B_ZWRITE) then
	    time_stamp(ip, [IMOD,ICHG]);
d3463 3
a3465 7
	{ update EOF if writing past it }
	if ip^.size.ls < position + length then begin
	    ip^.size.ls := position + length;
	    put_inode(ip, [dirty]);
	end;
    end;
    get_dbnum := dblk;
d3474 1
a3474 1
{ procedure sets keep_going to control whether we continue.
d3491 1
d3583 3
a3585 5
	else begin
	    keep_going := true;
	    if (ino = 0) or (reclen > sizeof(direntrytype)) then
		outrec.diroff := offset;
	end;
a3731 5
{ NEW release 3
{       5.1 security change
{       preallocation
{       zero backwards, use "reuse"
{       get_dbnum replaces bmap for export
a3733 3


{THESE ROUTINES SHOULD ALWAYS SET IORESULT IF THEY FAIL}
@


1.13
log
@Fix bug in change_file_size; could cause inode size to
grow, but not file itself.
@
text
@d16 1
a674 1
	{checkzer(charptr(fp), bytes);}
d698 1
a698 1
    now := hfs_time;
@


1.12
log
@New routines to support tmpfiles: alloc_inode, dealloc_inode,
enter_file, delete_filename.  foundname moved from hfsdam to here.  findoff now removed, also init_called testing gone.
@
text
@d3402 1
d3421 1
a3421 1
		     blkoff(fs, size));
a3697 1
report('enter file ' + name);
a3708 1
report('enter_file -- name exists; change entry');
a3730 1
reportn('enter_file -- calling direnter, offset', pathinfo.diroff);
@


1.11
log
@Add directory scanning routine.  It takes a procedure parameter,
and calls the procedure on every dir entry.
@
text
@d37 7
d51 1
a51 1
function create_file(filename: string255;
d54 1
a54 1
		     offset, filebytes: integer): integer;
d56 1
a56 1
function create_dir(filename: string255;
a60 3
function delete_file(ip, pdir: inode_ptr_type;
		     offset: integer): boolean;

d62 1
a62 1
		   filename: string255;
d76 3
a78 3
{ EXPORTED JUST FOR TEST DRIVER.  NOT A REAL ROUTINE.  DON'T CALL. }
function findoff(pdir: inode_ptr_type;
		 filename: string255): integer;
d80 16
a132 1
    init_called: boolean;
a398 1
    init_called := true;
a1825 2
    if not init_called then
	panic('not initialized');
a2636 77
{ Find a directory offset.  This routine digs up the info that
{ eventually should be left around by the path traverser.  If filename
{ is '', we want the offset of a free slot in the dir.  Otherwise,
{ we want the offset of the given filename.
{ NOT USED FROM THIS FILE.  HERE JUST FOR TEST DRIVER.  SHOULD NOT
{ BE CALLED BY ANY NEW ROUTINES.
}
function findoff(pdir: inode_ptr_type;
		 filename: string255): integer;
label
    999;
var
    offset: integer;
    begp: cache_blk_ptr_type;
    dp, endp: direntry_ptr_type;
    i, thisread: integer;
    match: boolean;
begin
    findoff := -1;
    offset := 0;
    begp := nil;

    { scan through directory }
    while offset < pdir^.size.ls do begin

	{ bytes to read this time }
	thisread := min(cache_blk_size, pdir^.size.ls - offset);

	{ get next cache blk }
	if begp <> nil then
	    put_datablk(begp, [release]);
	begp := rdwri(B_READ, pdir, offset, thisread);
	if begp = nil then
	    goto 999;
	dp := direntry_ptr_type(begp);
	endp := addr(begp^, thisread);

	{ scan through this cache blk }
	while integer(dp) < integer(endp) do begin
	    if filename = '' then begin
		{ want a free slot }
		if (dp^.ino = 0)
		or (dp^.reclen > sizeof(direntrytype)) then begin
		    findoff := offset;
		    goto 999;
		end;
	    end
	    else begin
		{ want a name match }
		if strlen(filename) = dp^.namlen then begin
		    match := true;
		    for i := 1 to dp^.namlen do
			if filename[i] <> dp^.name[i-1] then
			    match := false;
		    if match then begin
			findoff := offset;
			goto 999;
		    end;
		end;
	    end;

	    offset := offset + dp^.reclen;
	    dp := addr(dp^, dp^.reclen);
	end;
    end;

    { at end of dir now }
    if filename <> '' then
	findoff := -1
    else
	findoff := offset;
999:
    if begp <> nil then
	put_datablk(begp, [release]);
end;

{
d2688 18
d2713 1
a2713 9
	with ip^ do begin
	    nlink := nlink - 1;
	    if nlink = 0 then
		zapinode(ip)
	    else begin
		time_stamp(ip, [ICHG]);
		put_inode(ip, [dirty,immediate]);
	    end;
	end;
d2928 1
a2928 1
		  filename: string255;
d3006 1
d3008 1
a3008 1
function maknode(filename: string255;
d3011 1
d3036 2
a3037 1
    ip^.nlink := 1;
d3045 1
a3045 1
    if not direnter(ip, filename, pdir, offset) then begin
d3064 1
d3066 5
a3070 4
function create_file(filename: string255;
		     mode: integer;
		     pdir: inode_ptr_type;
		     offset, filebytes: integer): integer;
d3078 1
a3078 3
    if not init_called then
	panic('not initialized');
    create_file := no_inode;
d3087 1
a3087 1
    ip := maknode(filename, mode, pdir, offset);
d3104 2
a3105 1
		result := dirremove(ip, pdir, offset);
d3120 1
a3120 2
    create_file := binode_ptr_type(ip)^.inumber;
    put_inode(ip, [release]);
d3124 8
d3138 1
a3138 1
		   filename: string255;
a3143 2
    if not init_called then
	panic('not initialized');
d3171 1
a3171 1
function create_dir(filename: string255;
a3181 2
    if not init_called then
	panic('not initialized');
a3372 2
    if not init_called then
	panic('not initialized');
a3378 1

a3398 3
    if not init_called then
	panic('not initialized');

d3552 204
@


1.10
log
@call copy_user_data for user data (not thru cache).
copy_data -> copy_control_data.
copy_control_data always invalidates source buffer.
fix yet another bug in space_exists.  don't ZWRITE in change_file_size.
@
text
@d32 5
d68 4
a601 1
{writeln('ZEROING ', size:1, ' bytes at frag ', fragnum:1);}
a643 3
{procedure checkzer(cp: charptr; size: integer);
var
   x: integer;
a644 13
    x := 0;
    while size > 0 do begin
	if cp^ = #0 then
	    x := x + 1;
	cp := addr(cp^, 1);
	size := size - 1;
    end;
    if x <> 0 then writeln('MOVED ', x:1, ' ZEROES');
end;}

begin
    {writeln('copy ', size:1, ' bytes from frag ',
	     ofrag:1, ' to frag ', nfrag:1);}
a2112 1
{writeln('space exists -- blkcount ', blkcount:1, ' fragcount ',fragcount:1);}
d3549 55
@


1.9
log
@yet another version of space_exists (counting blocks and frags).
@
text
@d593 1
d613 1
a613 1
	put_datablk(ip, [release,dirty,immediate,reuse]);
d622 3
d626 2
a627 2
procedure copy_data(ofrag, nfrag: frag_type;
		    size: integer);
d630 2
d636 3
d640 13
a655 2
	{if fp = nil then
	    goto 999;}
d664 1
a664 4
	{if tp = nil then begin
	    put_datablk(fp, [release]);
	    goto 999;
	end;}
d666 2
a667 2
	put_datablk(fp, [release]);
	put_datablk(tp, [release,dirty,immediate,reuse]);
d1637 1
a1637 1
	       do_zero: boolean): frag_type;
d1674 1
a1674 1
    if do_zero then
d1698 1
a1698 1
		   do_zero: boolean): frag_type;
d1732 1
a1732 1
	if do_zero then
d1745 2
a1746 2
	copy_data(bprev, bno, osize);
	if do_zero then
d1748 5
d1810 1
a1810 1
    do_zero: boolean;
d1814 1
a1814 1
    do_zero := (binand(ip^.mode, IFMT) = IFDIR) or (rwflg = B_ZWRITE);
d1883 1
a1883 1
			osize, nsize, bn, do_zero);
d1895 1
a1895 1
			nsize, do_zero);
d1900 1
a1900 1
	    if not do_zero then begin
d1996 1
a1996 1
	    do_zero := do_zero or (j < NIADDR);
d1999 1
a1999 1
	    nb := alloc(ip, pref, fs^.bsize, do_zero);
d2004 1
a2004 1
	    if not do_zero then begin
d2121 1
a2121 1
writeln('space exists -- blkcount ', blkcount:1, ' fragcount ', fragcount:1);
d2189 10
a2198 10
    for lbn := 0 to blkcount do begin
	{ calculate size of this logical block }
	if lbn < blkcount then
	    size := fs^.bsize
	else
	    size := blkoff(fs, filebytes);
	if size <> 0 then
	    if bmap(ip, lbn, B_WRITE, size) = BMAP_ERROR then
		goto 999;
    end;
a2998 1
reportn('direnter, offset', offset);
d3478 1
a3478 1
		     B_ZWRITE,
@


1.8
log
@fix space_exists bugs in counting blocks and frags.
remove mode diddles since inode mode now unsigned.
@
text
@d2093 1
a2093 1
    blkcount := lblkno(fs, filebytes-1)+1;
d2095 1
a2095 1
    if (blkcount >= NDADDR) and (fragcount <> 0) then begin
d2977 1
@


1.7
log
@hfsalloc_init -> init_hfsalloc
@
text
@d2092 2
a2093 1
    blkcount := lblkno(fs, filebytes);
a2094 2
    if fragoff(fs, filebytes) <> 0 then
	fragcount := fragcount + 1;
d2099 1
d2115 2
a2116 1
	if (blkcount + extra > nbfree) or (fragcount > nffree) then
a3070 3
    { Run-time checker needs mode -32768..32767 }
    if mode > 32767 then mode := mode - 65536;

a3232 3
    { range checker requires mode -32768..32767 }
    if mode > 32767 then mode := mode - 65536;

d3254 1
d3260 1
@


1.6
log
@Remove checks for nil return from get_*; get_* now escapes in this case.
Don't zero in change_file_size.
Use no_inode for failure; used to use inumber 0.
@
text
@d32 1
a32 1
procedure hfsalloc_init;
d168 1
a168 1
procedure hfsalloc_init;
@


1.5
log
@diffs from 3.2c build, local edits during build process
@
text
@d605 2
a606 2
	if ip = nil then
	    goto 999;
d634 2
a635 2
	if fp = nil then
	    goto 999;
d644 1
a644 1
	if tp = nil then begin
d647 1
a647 1
	end;
d1263 2
a1264 2
    if cgp = nil then
	goto 999;
d1408 2
a1409 2
    if cgp = nil then
	goto 999;
d1490 2
a1491 2
    if cgp = nil then
	goto 999;
d1911 1
a1911 2
    if j = 0 then begin
	ioresult := ord(itoobig);
a1912 2
	goto 999;
    end;
d1949 2
a1950 2
	if bap = nil then
	    goto 999;
d2040 2
a2041 2
    if cgp = nil then
	goto 999;
a2150 1
    rwflg: bmap_mode;
a2166 1
	rwflg := B_WRITE;
d2170 1
a2170 1
	else begin
a2171 4
	    { we zero new block if not allocating full fragment(s) }
	    if fragoff(fs, size) <> 0 then
		rwflg := B_ZWRITE;
	end;
d2173 1
a2173 1
	    if bmap(ip, lbn, rwflg, size) = BMAP_ERROR then
d2264 2
a2265 2
    if cgp = nil then
	goto 999;
d2360 2
a2361 2
	if bap = nil then
	    goto 999;
d2405 2
a2406 2
	    if bap = nil then
		goto 999;
d2819 2
a2820 2
    if cgp = nil then
	goto 999;
a2924 1
	{
a2926 1
	}
d3099 1
a3099 1
{ We return the new inumber, or 0 for failure.
d3115 1
a3115 1
    create_file := 0;
d3138 2
a3139 3
		{ prealloc failed.  ioresult <> 0 means
		{ no space.  else some other error, which we
		{ don't know how to recover from.
d3141 5
a3145 7
		if ioresult = 0 then begin
		    result := dirremove(ip, pdir, offset);
		    zapinode(ip);
		    put_inode(ip, [release]);
		    if ioresult = 0 then
			ioresult := ord(inoroom);
		end;
d3178 1
d3215 1
a3215 1
    create_dir := 0;
d3363 1
a3363 1
	ioresult := ord(ibadvalue);
d3522 7
a3528 4
	{ set time stamp in inode }
	if rwflag = B_READ then
	    time_stamp(ip, [IACC])
	else
a3545 1
{       3) inode times?
d3558 1
a3558 1

@


1.4
log
@changes from "newest" dam received 23.06.86 from Scott
@
text
@d546 1
a546 1
    ioresult := ord(IOERRcorrupt);
d1664 1
a1664 1
    ioresult := ord(IOERRnospace);
d1744 1
a1744 1
    ioresult := ord(IOERRnospace);
d1912 1
a1912 1
	ioresult := ord(IOERRtoobig);
d2960 1
a2960 1
    ioresult := ord(IOERRnoinodes);
d3158 1
a3158 1
			ioresult := ord(IOERRnospace);
d3191 1
a3191 1
	ioresult := ord(IOERRinvalid);
d3376 1
a3376 1
	ioresult := ord(IOERRinvalid);
d3388 1
a3388 1
	ioresult := ord(IOERRnotempty);
@


1.3
log
@change bit shift routine names from bit_ to bin
@
text
@d2934 1
d2937 1
@


1.2
log
@removal of cbit dependencies
@
text
@d409 2
a410 2
	    index := bit_lsr(h,1);
	    mask := bit_asl(hex('f'),bit_asl(binand(h,1),2));
d417 2
a418 2
	    index := bit_lsr(h,2);
	    mask := bit_asl(3,bit_asl(binand(h,3),1));
d425 2
a426 2
	    index := bit_lsr(h,3);
	    mask := bit_asl(1,binand(h,7));
d459 2
a460 2
	    index := bit_lsr(h,1);
	    mask := bit_asl(hex('f'),bit_asl(binand(h,1),2));
d466 2
a467 2
	    index := bit_lsr(h,2);
	    mask := bit_asl(3,bit_asl(binand(h,3),1));
d473 2
a474 2
	    index := bit_lsr(h,3);
	    mask := bit_asl(1,binand(h,7));
d508 2
a509 2
	    index := bit_lsr(h,1);
	    mask := bit_asl(hex('f'),bit_asl(binand(h,1),2));
d515 2
a516 2
	    index := bit_lsr(h,2);
	    mask := bit_asl(3,bit_asl(binand(h,3),1));
d522 2
a523 2
	    index := bit_lsr(h,3);
	    mask := bit_asl(1,binand(h,7));
d745 1
a745 1
	    bit_asl(1, allocsiz - 1 + (fs^.frag mod NBBY)));
d753 1
a753 1
		bit_asl(1, allocsiz - 1 + (fs^.frag mod NBBY)));
d774 1
a774 1
	blk := bit_asl(blk, 1);
d786 2
a787 2
	    field := bit_asl(field, 1);
	    subfield := bit_asl(subfield, 1);
d813 1
a813 1
    inblk := bit_asl(fragtbl[fs^.frag]^[fragmap], 1);
d816 1
a816 1
    fragmap := bit_asl(fragmap, 1);
d822 1
a822 1
	if binand(inblk, bit_asl(1, siz + fs^.frag mod NBBY)) <> 0 then begin
d836 2
a837 2
		    field := bit_asl(field, siz);
		    subfield := bit_asl(subfield, siz);
d839 2
a840 2
		field := bit_asl(field, 1);
		subfield := bit_asl(subfield, 1);
@


1.1
log
@Initial revision
@
text
@d8 1
a8 1
$search 'hfstuff', 'cbit', 'support', 'hfscalc', 'hfscache'$
a14 1
    cbit,
@
