stdlib/io.ajla

   1 {*
   2  * Copyright (C) 2024 Mikulas Patocka
   3  *
   4  * This file is part of Ajla.
   5  *
   6  * Ajla is free software: you can redistribute it and/or modify it under the
   7  * terms of the GNU General Public License as published by the Free Software
   8  * Foundation, either version 3 of the License, or (at your option) any later
   9  * version.
  10  *
  11  * Ajla is distributed in the hope that it will be useful, but WITHOUT ANY
  12  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  13  * A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License along with
  16  * Ajla. If not, see <https://www.gnu.org/licenses/>.
  17  *}
  18
  19 unit io;
  20
  21 uses treemap;
  22
  23 {---------
  24  - WORLD -
  25  ---------}
  26
  27 type world;
  28
  29 private fn unsafe_get_world : world;
  30 fn recover_world(w old_w : world) : world;
  31 fn join(t : type, w1 w2 : t) : t;
  32 fn any~lazy(t1 t2 : type, w1 : t1, w2 : t2) : bool;
  33 fn any_list~lazy(t : type, wx : list(t)) : int;
  34 fn is_ready(t : type, v : t) : bool;
  35 fn never(t : type) : t;
  36 fn fork(t : type, w : t) : (t, t);
  37 fn atomic_enter~inline(w : world) : world;
  38 fn atomic_exit~inline(w : world) : world;
  39 fn wait_for_dereferenced(w : world) : world;
  40 fn exit(w : world, n : int) : world;
  41 fn exit_msg(w : world, n : int, m : bytes) : world;
  42
  43 {--------
  44  - ARGS -
  45  --------}
  46
  47 private fn get_args(w : world) : list(bytes);
  48
  49 {-------
  50  - I/O -
  51  -------}
  52
  53 type handle;
  54 type dhandle;
  55
  56 const open_flag_read : int;
  57 const open_flag_write : int;
  58 const open_flag_append : int;
  59 const open_flag_create : int;
  60 const open_flag_must_create : int;
  61 const open_flag_no_follow : int;
  62 const open_mode_ro_current_user : int;
  63 const open_mode_ro_all_users : int;
  64 const open_mode_rw_current_user : int;
  65 const open_mode_read_all_users : int;
  66 const open_mode_default : int;
  67
  68 fn ropen(w : world, d : dhandle, f : bytes, flags : int) : (world, handle);
  69 fn read(w : world, h : handle, size : int) : (world, bytes);
  70 fn read_full(w : world, h : handle) : (world, bytes);
  71 fn read_partial(w : world, h : handle, size : int) : (world, bytes);
  72 fn wopen(w : world, d : dhandle, f : bytes, flags : int, mode : int) : (world, handle);
  73 fn write(w : world, h : handle, s : bytes) : world;
  74 fn wcontiguous(w : world, h : handle, size : int64) : world;
  75
  76 fn ropen_lazy(d : dhandle, f : bytes, flags : int) : handle;
  77 fn read_lazy~lazy(r : handle) : bytes;
  78
  79 private fn read_console_packet(w : world, h : handle) : (world, list(int32));
  80 private fn write_console_packet(w : world, h : handle, cp : list(int32)) : world;
  81
  82 fn pipe(w : world) : (world, handle, handle);
  83
  84 fn bopen(w : world, d : dhandle, f : bytes, flags : int, mode : int) : (world, handle);
  85 fn bread(w : world, h : handle, position : int64, size : int) : (world, bytes);
  86 fn bwrite(w : world, h : handle, position : int64, s : bytes) : world;
  87 fn bsize(w : world, h : handle) : (world, int64);
  88 fn bdata(w : world, h : handle, off : int64) : (world, int64);
  89 fn bhole(w : world, h : handle, off : int64) : (world, int64);
  90 fn bsetsize(w : world, h : handle, size : int64) : world;
  91 fn bcontiguous(w : world, h : handle, pos : int64, size : int64) : world;
  92 fn bclone(w : world, src_h : handle, src_pos : int64, dst_h : handle, dst_pos : int64, size : int64) : world;
  93 fn bopen_lazy(d : dhandle, f : bytes, flags : int) : handle;
  94 fn bread_lazy~lazy(h : handle, position : int64) : bytes;
  95 fn bsize_lazy(h : handle) : int64;
  96 fn bdata_lazy(h : handle, off : int64) : int64;
  97 fn bhole_lazy(h : handle, off : int64) : int64;
  98
  99 fn fdatasync(w : world, h : handle) : world;
 100 fn fsync(w : world, h : handle) : world;
 101 fn ffssync(w : world, h : handle) : world;
 102 fn sync(w : world) : world;
 103
 104 fn droot(w : world) : dhandle;
 105 private fn dcwd(w : world) : dhandle;
 106 private fn dlib(w : world) : dhandle;
 107 private fn dexe(w : world) : dhandle;
 108 fn dnone(w : world) : dhandle;
 109 private fn libpath : bytes;
 110 fn dopen(w : world, d : dhandle, f : bytes, flags : int) : (world, dhandle);
 111 fn dread(w : world, d : dhandle) : (world, list(bytes));
 112 fn dpath(w : world, d : dhandle) : (world, bytes);
 113 fn dopen_lazy(d : dhandle, f : bytes, flags : int) : dhandle;
 114 fn dread_lazy(d : dhandle) : list(bytes);
 115 fn dpath_lazy(d : dhandle) : bytes;
 116 fn dmonitor(w : world, d : dhandle) : (world, world);
 117
 118 const stat_flag_devmajor : int;
 119 const stat_flag_devminor : int;
 120 const stat_flag_inode : int;
 121 const stat_flag_type : int;
 122 const stat_flag_mode : int;
 123 const stat_flag_nlink : int;
 124 const stat_flag_uid : int;
 125 const stat_flag_gid : int;
 126 const stat_flag_rdevmajor : int;
 127 const stat_flag_rdevminor : int;
 128 const stat_flag_size : int;
 129 const stat_flag_optimaliosize : int;
 130 const stat_flag_allocated : int;
 131 const stat_flag_atime : int;
 132 const stat_flag_mtime : int;
 133 const stat_flag_ctime : int;
 134
 135 const stat_type_file : int;
 136 const stat_type_directory : int;
 137 const stat_type_link : int;
 138 const stat_type_fifo : int;
 139 const stat_type_chardev : int;
 140 const stat_type_blockdev : int;
 141 const stat_type_socket : int;
 142
 143 fn stat(w : world, d : dhandle, f : bytes, flags : int) : (world, list(int64));
 144 fn lstat(w : world, d : dhandle, f : bytes, flags : int) : (world, list(int64));
 145 fn fstat(w : world, h : handle, flags : int) : (world, list(int64));
 146
 147 fn stat_lazy(d : dhandle, f : bytes, flags : int) : list(int64);
 148 fn lstat_lazy(d : dhandle, f : bytes, flags : int) : list(int64);
 149 fn fstat_lazy(h : handle, flags : int) : list(int64);
 150
 151 const statfs_flag_bsize : int;
 152 const statfs_flag_frsize : int;
 153 const statfs_flag_frtotal : int;
 154 const statfs_flag_frfree : int;
 155 const statfs_flag_fravail : int;
 156 const statfs_flag_intotal : int;
 157 const statfs_flag_infree : int;
 158 const statfs_flag_inavail : int;
 159 const statfs_flag_fsid : int;
 160 const statfs_flag_flags : int;
 161 const statfs_flag_namelen : int;
 162
 163 const statfs_st_readonly : int;
 164 const statfs_st_nosuid : int;
 165 const statfs_st_nodev : int;
 166 const statfs_st_noexec : int;
 167 const statfs_st_synchronous : int;
 168 const statfs_st_mandlock : int;
 169 const statfs_st_noatime : int;
 170 const statfs_st_nodiratime : int;
 171 const statfs_st_relatime : int;
 172
 173 fn fstatfs(w : world, h : handle, flags : int) : (world, list(int64));
 174 fn dstatfs(w : world, d : dhandle, flags : int) : (world, list(int64));
 175
 176 fn readlink(w : world, d : dhandle, f : bytes) : (world, bytes);
 177 fn readlink_lazy(d : dhandle, f : bytes) : bytes;
 178
 179 fn unlink(w : world, d : dhandle, f : bytes) : world;
 180 fn rmdir(w : world, d : dhandle, f : bytes) : world;
 181 fn mkdir(w : world, d : dhandle, f : bytes, mode : int) : world;
 182 fn mkpipe(w : world, d : dhandle, f : bytes, mode : int) : world;
 183 fn mksocket(w : world, d : dhandle, f : bytes, mode : int) : world;
 184 fn mkchardev(w : world, d : dhandle, f : bytes, mode major minor : int) : world;
 185 fn mkblockdev(w : world, d : dhandle, f : bytes, mode major minor : int) : world;
 186 fn mksymlink(w : world, d : dhandle, f t : bytes) : world;
 187 fn mklink(w : world, d : dhandle, f : bytes, e : dhandle, t : bytes) : world;
 188 fn rename(w : world, d : dhandle, f : bytes, e : dhandle, t : bytes) : world;
 189 fn chmod(w : world, d : dhandle, f : bytes, m : int) : world;
 190 fn chown(w : world, d : dhandle, f : bytes, uid gid : int) : world;
 191 fn lchown(w : world, d : dhandle, f : bytes, uid gid : int) : world;
 192 fn utime(w : world, d : dhandle, f : bytes, atime mtime : int64) : world;
 193 fn lutime(w : world, d : dhandle, f : bytes, atime mtime : int64) : world;
 194 fn mount_points(w : world) : (world, list(bytes));
 195
 196 const stty_flag_raw : int;
 197 const stty_flag_noecho : int;
 198 const stty_flag_nosignal : int;
 199 const stty_flag_nocrlf : int;
 200
 201 fn stty(w : world, h : handle, flags : int) : world;
 202 fn tty_size(w : world, h : handle) : (world, int, int, int, int);
 203 fn tty_background(w : world) : world;
 204 fn tty_foreground(w : world) : (world, bool);
 205
 206 const uname_flag_ajla_version : int;
 207 const uname_flag_flavor : int;
 208 const uname_flag_system : int;
 209 const uname_flag_release : int;
 210 const uname_flag_version : int;
 211 const uname_flag_machine : int;
 212
 213 fn uname(flags : int) : list(bytes);
 214 fn get_host_name(w : world) : (world, bytes);
 215
 216 fn get_real_time(w : world) : (world, int64);
 217 fn get_monotonic_time(w : world) : (world, int64);
 218 fn sleep(t : type, w : t, tm : int64) : t;
 219
 220 {--------
 221  - PATH -
 222  --------}
 223
 224 const path_separator : byte;
 225 fn path_is_separator(b : byte) : bool;
 226 fn path_is_dir_separator(b : byte) : bool;
 227 fn path_compare(a b : bytes) : bool;
 228 fn path_is_absolute(p : bytes) : bool;
 229 fn path_is_root(p : bytes) : bool;
 230 fn path_to_dir_file(p : bytes) : (bytes, bytes);
 231 fn path_append(pd pf : bytes) : bytes;
 232 fn path_contract(p : bytes) : bytes;
 233 fn path_join(pd pf : bytes) : bytes;
 234 fn path_canonical(w : world, d : dhandle, p : bytes) : (world, bytes);
 235 fn path_get_cwd(implicit w : world, d : dhandle, env : treemap(bytes, bytes)) : (world, bytes);
 236 fn path_shortcut_home(home : maybe(bytes), p : bytes) : bytes;
 237 fn path_expand_home(home : maybe(bytes), p : bytes) : bytes;
 238 fn path_mkdir(w : world, d : dhandle, f : bytes, mode : int) : world;
 239 fn path_xdg(implicit w : world, env : treemap(bytes, bytes), xdg_env : bytes, deflt : bytes, appname : bytes) : (world, dhandle);
 240 fn path_config(w : world, env : treemap(bytes, bytes), appname : bytes) : (world, dhandle);
 241 fn path_write_atomic(w : world, d : dhandle, f : bytes, content : bytes) : world;
 242
 243 {----------------
 244  - DEPENDENCIES -
 245  ----------------}
 246
 247 fn register_dependence(w : world, d : dhandle, p : bytes) : world;
 248
 249
 250 implementation
 251
 252 uses pcode;
 253 uses exception;
 254
 255 {---------
 256  - WORLD -
 257  ---------}
 258
 259 option world [
 260         world;
 261 ]
 262
 263 fn unsafe_get_world : world
 264 [
 265         return world.world;
 266 ]
 267
 268 fn recover_world(w old_w : world) : world
 269 [
 270         if is_exception w then
 271                 return old_w;
 272         return w;
 273 ]
 274
 275 fn join(t : type, w1 w2 : t) : t
 276 [
 277         if is_exception w1 then [
 278                 eval w2;
 279                 return w1;
 280         ]
 281         if is_exception w2 then
 282                 return w2;
 283         return w1;
 284 ]
 285
 286 fn any~lazy(t1 t2 : type, w1 : t1, w2 : t2) : bool
 287 [
 288         var b : bool;
 289         pcode IO IO_Any 1 2 0 =b w1 w2;
 290         return b;
 291 ]
 292
 293 fn any_list~lazy(t : type, wx : list(t)) : int
 294 [
 295         if not len_greater_than(wx, 0) then
 296                 return never(int);
 297         var n := any_list~lazy(wx[1 .. ]);
 298         var b := any(wx[0], n);
 299         return select(b, 0, n + 1);
 300 ]
 301
 302 fn is_ready(t : type, v : t) : bool
 303 [
 304         return not any(v, unit_value);
 305 ]
 306
 307 fn never(t : type) : t
 308 [
 309         var w : t;
 310         pcode IO IO_Never 1 0 0 =w;
 311         return w;
 312 ]
 313
 314 fn fork(t : type, w : t) : (t, t)
 315 [
 316         var w1 w2 : t;
 317         pcode IO IO_Fork 2 1 0 =w1 =w2 w;
 318         return w1, w2;
 319 ]
 320
 321 fn atomic_enter~inline(w : world) : world
 322 [
 323         var w2 : world;
 324         pcode IO IO_Atomic_Enter 1 1 0 =w2 w;
 325         return w2;
 326 ]
 327
 328 fn atomic_exit~inline(w : world) : world
 329 [
 330         var w2 : world;
 331         pcode IO IO_Atomic_Exit 1 1 0 =w2 w;
 332         return w2;
 333 ]
 334
 335 fn wait_for_dereferenced(w : world) : world
 336 [
 337         var w2 : world;
 338         pcode IO IO_Wait_For_Dereferenced 1 1 0 =w2 w;
 339         return w2;
 340 ]
 341
 342 fn exit(w : world, n : int) : world
 343 [
 344         var exc := exception_make(world, ec_exit, error_exit, n, false);
 345         return join(w, exc);
 346 ]
 347
 348 fn exit_msg(w : world, n : int, m : bytes) : world
 349 [
 350         var exc := exception_make_str(world, ec_exit, error_exit, n, false, m);
 351         return join(w, exc);
 352 ]
 353
 354 {--------
 355  - ARGS -
 356  --------}
 357
 358 fn get_args(w : world) : list(bytes)
 359 [
 360         var r : list(bytes);
 361         pcode IO IO_Get_Args 1 1 0 =r w;
 362         return r;
 363 ]
 364
 365 {-------
 366  - I/O -
 367  -------}
 368
 369 type handle := internal_type;
 370 type dhandle := internal_type;
 371
 372 const open_flag_read : int := IO_Open_Flag_Read;
 373 const open_flag_write : int := IO_Open_Flag_Write;
 374 const open_flag_append : int := IO_Open_Flag_Append;
 375 const open_flag_create : int := IO_Open_Flag_Create;
 376 const open_flag_must_create : int := IO_Open_Flag_Must_Create;
 377 const open_flag_no_follow : int := IO_Open_Flag_No_Follow;
 378 const open_mode_ro_current_user : int := #100;
 379 const open_mode_ro_all_users : int := #124;
 380 const open_mode_rw_current_user : int := #180;
 381 const open_mode_read_all_users : int := #1a4;
 382 const open_mode_default : int := #1b6;
 383
 384 fn ropen(w : world, d : dhandle, f : bytes, flags : int) : (world, handle)
 385 [
 386         var h : handle;
 387         var w2 : world;
 388         var mode := 0;
 389         pcode IO IO_Stream_Open_Read 2 5 0 =w2 =h w d f flags mode;
 390         return w2, h;
 391 ]
 392
 393 fn read(w : world, h : handle, size : int) : (world, bytes)
 394 [
 395         var read_so_far := 0;
 396         var s := bytes.[];
 397         while read_so_far < size do [
 398                 var s1 : bytes;
 399                 var w2 : world;
 400                 w2, s1 := read_partial~strict(w, h, size - read_so_far);
 401                 w := w2;
 402                 var l1 := len(s1);
 403                 if l1 = 0 then
 404                         break;
 405                 read_so_far += l1;
 406                 s += s1;
 407         ]
 408         return w, s;
 409 ]
 410
 411 fn read_full(w : world, h : handle) : (world, bytes)
 412 [
 413         var s := bytes.[];
 414         while true do [
 415                 var s1 : bytes;
 416                 var w2 : world;
 417                 w2, s1 := read_partial~strict(w, h, 16384);
 418                 w := w2;
 419                 var l1 := len(s1);
 420                 if l1 = 0 then
 421                         break;
 422                 s += s1;
 423         ]
 424         return w, s;
 425 ]
 426
 427 fn read_partial(w : world, h : handle, size : int) : (world, bytes)
 428 [
 429         var s : bytes;
 430         var w2 : world;
 431         pcode IO IO_Stream_Read_Partial 2 3 0 =w2 =s w h size;
 432         return w2, s;
 433 ]
 434
 435 fn wopen(w : world, d : dhandle, f : bytes, flags : int, mode : int) : (world, handle)
 436 [
 437         var h : handle;
 438         var w2 : world;
 439         pcode IO IO_Stream_Open_Write 2 5 0 =w2 =h w d f flags mode;
 440         return w2, h;
 441 ]
 442
 443 fn write(w : world, h : handle, s : bytes) : world
 444 [
 445         while len_greater_than(byte, s, 0) do [
 446                 var sz : int;
 447                 var w2 : world;
 448                 pcode IO IO_Stream_Write 2 3 0 =w2 =sz w h s;
 449                 w := w2;
 450                 s := s[sz .. ];
 451         ]
 452         return w;
 453 ]
 454
 455 fn wcontiguous(implicit w : world, h : handle, size : int64) : world
 456 [
 457         var offset := bsize(h);
 458         bcontiguous(w, h, offset, size);
 459 ]
 460
 461 fn ropen_lazy(d : dhandle, f : bytes, flags : int) : handle
 462 [
 463         var h : handle;
 464         var w := unsafe_get_world;
 465         w, h := ropen(w, d, f, flags);
 466         return h;
 467 ]
 468
 469 fn read_lazy~lazy(r : handle) : bytes
 470 [
 471         var b : bytes;
 472         var w := unsafe_get_world;
 473         w, b := read_partial~strict(w, r, 16384);
 474         if len(b) = 0 then
 475                 return b;
 476         return b + read_lazy(r);
 477 ]
 478
 479 fn read_console_packet(w : world, h : handle) : (world, list(int32))
 480 [
 481         var cp : list(int32);
 482         var w2 : world;
 483         pcode IO IO_Read_Console_Packet 2 2 0 =w2 =cp w h;
 484         return w2, cp;
 485 ]
 486
 487 fn write_console_packet(w : world, h : handle, cp : list(int32)) : world
 488 [
 489         var w2 : world;
 490         pcode IO IO_Write_Console_Packet 1 3 0 =w2 w h cp;
 491         return w2;
 492 ]
 493
 494 fn pipe(w : world) : (world, handle, handle)
 495 [
 496         var rh : handle, wh : handle;
 497         var w2 : world;
 498         pcode IO IO_Pipe 3 1 0 =w2 =rh =wh w;
 499         return w2, rh, wh;
 500 ]
 501
 502 fn bopen(w : world, d : dhandle, f : bytes, flags : int, mode : int) : (world, handle)
 503 [
 504         var h : handle;
 505         var w2 : world;
 506         pcode IO IO_Block_Open 2 5 0 =w2 =h w d f flags mode;
 507         return w2, h;
 508 ]
 509
 510 fn bread(w : world, h : handle, position : int64, size : int) : (world, bytes)
 511 [
 512         var s : bytes;
 513         var w2 : world;
 514         pcode IO IO_Block_Read 2 4 0 =w2 =s w h size position;
 515         return w2, s;
 516 ]
 517
 518 fn bwrite(w : world, h : handle, position : int64, s : bytes) : world
 519 [
 520         while len_greater_than(byte, s, 0) do [
 521                 var sz : int;
 522                 var w2 : world;
 523                 pcode IO IO_Block_Write 2 4 0 =w2 =sz w h s position;
 524                 s := s[sz .. ];
 525                 w := w2;
 526                 position += sz;
 527         ]
 528         return w;
 529 ]
 530
 531 fn bsize(w : world, h : handle) : (world, int64)
 532 [
 533         var sz : int64;
 534         var w2 : world;
 535         var off : int64 := 0;
 536         pcode IO IO_LSeek 2 3 1 =w2 =sz w h off 2;
 537         return w2, sz;
 538 ]
 539
 540 fn bdata(w : world, h : handle, off : int64) : (world, int64)
 541 [
 542         var sz : int64;
 543         var w2 : world;
 544         pcode IO IO_LSeek 2 3 1 =w2 =sz w h off 3;
 545         return w2, sz;
 546 ]
 547
 548 fn bhole(w : world, h : handle, off : int64) : (world, int64)
 549 [
 550         var sz : int64;
 551         var w2 : world;
 552         pcode IO IO_LSeek 2 3 1 =w2 =sz w h off 4;
 553         return w2, sz;
 554 ]
 555
 556 fn bsetsize(w : world, h : handle, size : int64) : world
 557 [
 558         var w2 : world;
 559         pcode IO IO_FTruncate 1 3 0 =w2 w h size;
 560         return w2;
 561 ]
 562
 563 fn bcontiguous(w : world, h : handle, pos : int64, size : int64) : world
 564 [
 565         var w2 : world;
 566         pcode IO IO_FAllocate 1 4 0 =w2 w h pos size;
 567         return w2;
 568 ]
 569
 570 fn bclone(w : world, src_h : handle, src_pos : int64, dst_h : handle, dst_pos : int64, size : int64) : world
 571 [
 572         var w2 : world;
 573         pcode IO IO_CloneRange 1 6 0 =w2 w src_h src_pos dst_h dst_pos size;
 574         return w2;
 575 ]
 576
 577 fn bopen_lazy(d : dhandle, f : bytes, flags : int) : handle
 578 [
 579         var h : handle;
 580         if flags <> IO_Open_Flag_Read then [
 581                 h := exception_make(handle, ec_sync, error_invalid_operation, 0, true);
 582                 return h;
 583         ]
 584         var w := unsafe_get_world;
 585         w, h := bopen(w, d, f, flags, 0);
 586         return h;
 587 ]
 588
 589 fn bread_lazy~lazy(h : handle, position : int64) : bytes
 590 [
 591         var b : bytes;
 592         var w := unsafe_get_world;
 593         w, b := bread(w, h, position, 16384);
 594         if len(b) < 16384 then
 595                 return b;
 596         return b + bread_lazy(h, position + 16384);
 597 ]
 598
 599 fn bsize_lazy(h : handle) : int64
 600 [
 601         var sz : int64;
 602         var w := unsafe_get_world;
 603         w, sz := bsize(w, h);
 604         return sz;
 605 ]
 606
 607 fn bdata_lazy(h : handle, off : int64) : int64
 608 [
 609         var sz : int64;
 610         var w := unsafe_get_world;
 611         w, sz := bdata(w, h, off);
 612         return sz;
 613 ]
 614
 615 fn bhole_lazy(h : handle, off : int64) : int64
 616 [
 617         var sz : int64;
 618         var w := unsafe_get_world;
 619         w, sz := bhole(w, h, off);
 620         return sz;
 621 ]
 622
 623 fn fdatasync(w : world, h : handle) : world
 624 [
 625         var w2 : world;
 626         pcode IO IO_FSync 1 2 1 =w2 w h 0;
 627         return w2;
 628 ]
 629
 630 fn fsync(w : world, h : handle) : world
 631 [
 632         var w2 : world;
 633         pcode IO IO_FSync 1 2 1 =w2 w h 1;
 634         return w2;
 635 ]
 636
 637 fn ffssync(w : world, h : handle) : world
 638 [
 639         var w2 : world;
 640         pcode IO IO_FSync 1 2 1 =w2 w h 2;
 641         return w2;
 642 ]
 643
 644 fn sync(w : world) : world
 645 [
 646         var w2 : world;
 647         pcode IO IO_Sync 1 1 0 =w2 w;
 648         return w2;
 649 ]
 650
 651 fn droot(w : world) : dhandle
 652 [
 653         var dh : dhandle;
 654         pcode IO IO_Root_Dir 1 1 1 =dh w 1;
 655         return dh;
 656 ]
 657
 658 fn dcwd(w : world) : dhandle
 659 [
 660         var dh : dhandle;
 661         pcode IO IO_Root_Dir 1 1 1 =dh w 2;
 662         return dh;
 663 ]
 664
 665 fn dlib(w : world) : dhandle
 666 [
 667         var dh : dhandle;
 668         pcode IO IO_Root_Dir 1 1 1 =dh w 3;
 669         return dh;
 670 ]
 671
 672 fn dexe(w : world) : dhandle
 673 [
 674         var dh : dhandle;
 675         pcode IO IO_Root_Dir 1 1 1 =dh w 4;
 676         return dh;
 677 ]
 678
 679 fn dnone(w : world) : dhandle
 680 [
 681         var dh : dhandle;
 682         pcode IO IO_Root_Dir 1 1 1 =dh w 5;
 683         return dh;
 684 ]
 685
 686 private fn libpath : bytes
 687 [
 688         var lp : bytes;
 689         pcode IO IO_Lib_Path 1 0 0 =lp;
 690         return lp;
 691 ]
 692
 693 fn dopen(w : world, d : dhandle, f : bytes, flags : int) : (world, dhandle)
 694 [
 695         var dh : dhandle;
 696         var w2 : world;
 697         pcode IO IO_Open_Dir 2 4 0 =w2 =dh w d f flags;
 698         return w2, dh;
 699 ]
 700
 701 fn dread(w : world, d : dhandle) : (world, list(bytes))
 702 [
 703         var res : list(bytes);
 704         var w2 : world;
 705         pcode IO IO_Read_Dir 2 2 0 =w2 =res w d;
 706         return w2, res;
 707 ]
 708
 709 fn dpath(w : world, d : dhandle) : (world, bytes)
 710 [
 711         var res : bytes;
 712         var w2 : world;
 713         pcode IO IO_Dir_Path 2 2 0 =w2 =res w d;
 714         return w2, res;
 715 ]
 716
 717 fn dopen_lazy(d : dhandle, f : bytes, flags : int) : dhandle
 718 [
 719         var res : dhandle;
 720         var w := unsafe_get_world;
 721         w, res := dopen(w, d, f, flags);
 722         return res;
 723 ]
 724
 725 fn dread_lazy(d : dhandle) : list(bytes)
 726 [
 727         var res : list(bytes);
 728         var w := unsafe_get_world;
 729         w, res := dread(w, d);
 730         return res;
 731 ]
 732
 733 fn dpath_lazy(d : dhandle) : bytes
 734 [
 735         var res : bytes;
 736         var w := unsafe_get_world;
 737         w, res := dpath(w, d);
 738         return res;
 739 ]
 740
 741 type mhandle := internal_type;
 742
 743 fn dmonitor_wait(w2 : world, h : mhandle) : world
 744 [
 745         var w3 : world;
 746         pcode IO IO_DMonitor_Wait 1 2 0 =w3 w2 h;
 747         return w3;
 748 ]
 749
 750 fn dmonitor(w : world, d : dhandle) : (world, world)
 751 [
 752         var h : mhandle;
 753         var w2 w3 : world;
 754         pcode IO IO_DMonitor_Prepare 2 2 0 =w2 =h w d;
 755         w3 := dmonitor_wait~spark(w2, h);
 756         return w2, w3;
 757 ]
 758
 759 const stat_flag_devmajor : int := IO_Stat_Flag_DevMajor;
 760 const stat_flag_devminor : int := IO_Stat_Flag_DevMinor;
 761 const stat_flag_inode : int := IO_Stat_Flag_Inode;
 762 const stat_flag_type : int := IO_Stat_Flag_Type;
 763 const stat_flag_mode : int := IO_Stat_Flag_Mode;
 764 const stat_flag_nlink : int := IO_Stat_Flag_NLink;
 765 const stat_flag_uid : int := IO_Stat_Flag_UID;
 766 const stat_flag_gid : int := IO_Stat_Flag_GID;
 767 const stat_flag_rdevmajor : int := IO_Stat_Flag_RDevMajor;
 768 const stat_flag_rdevminor : int := IO_Stat_Flag_RDevMinor;
 769 const stat_flag_size : int := IO_Stat_Flag_Size;
 770 const stat_flag_optimaliosize : int := IO_Stat_Flag_OptimalIOSize;
 771 const stat_flag_allocated : int := IO_Stat_Flag_Allocated;
 772 const stat_flag_atime : int := IO_Stat_Flag_ATime;
 773 const stat_flag_mtime : int := IO_Stat_Flag_MTime;
 774 const stat_flag_ctime : int := IO_Stat_Flag_CTime;
 775
 776 const stat_type_file : int := IO_Stat_Type_File;
 777 const stat_type_directory : int := IO_Stat_Type_Directory;
 778 const stat_type_link : int := IO_Stat_Type_Link;
 779 const stat_type_fifo : int := IO_Stat_Type_Pipe;
 780 const stat_type_chardev : int := IO_Stat_Type_CharDev;
 781 const stat_type_blockdev : int := IO_Stat_Type_BlockDev;
 782 const stat_type_socket : int := IO_Stat_Type_Socket;
 783
 784 fn stat(w : world, d : dhandle, f : bytes, flags : int) : (world, list(int64))
 785 [
 786         var res : list(int64);
 787         var w2 : world;
 788         pcode IO IO_Stat 2 4 1 =w2 =res w d f flags 1;
 789         return w2, res;
 790 ]
 791
 792 fn lstat(w : world, d : dhandle, f : bytes, flags : int) : (world, list(int64))
 793 [
 794         var res : list(int64);
 795         var w2 : world;
 796         pcode IO IO_Stat 2 4 1 =w2 =res w d f flags 2;
 797         return w2, res;
 798 ]
 799
 800 fn fstat(w : world, h : handle, flags : int) : (world, list(int64))
 801 [
 802         var res : list(int64);
 803         var w2 : world;
 804         pcode IO IO_FStat 2 3 0 =w2 =res w h flags;
 805         return w2, res;
 806 ]
 807
 808 fn stat_lazy(d : dhandle, f : bytes, flags : int) : list(int64)
 809 [
 810         var res : list(int64);
 811         var w := unsafe_get_world;
 812         w, res := stat(w, d, f, flags);
 813         return res;
 814 ]
 815
 816 fn lstat_lazy(d : dhandle, f : bytes, flags : int) : list(int64)
 817 [
 818         var res : list(int64);
 819         var w := unsafe_get_world;
 820         w, res := lstat(w, d, f, flags);
 821         return res;
 822 ]
 823
 824 fn fstat_lazy(h : handle, flags : int) : list(int64)
 825 [
 826         var res : list(int64);
 827         var w := unsafe_get_world;
 828         w, res := fstat(w, h, flags);
 829         return res;
 830 ]
 831
 832 const statfs_flag_bsize : int := IO_StatFS_Flag_BSize;
 833 const statfs_flag_frsize : int := IO_StatFS_Flag_FrSize;
 834 const statfs_flag_frtotal : int := IO_StatFS_Flag_FrTotal;
 835 const statfs_flag_frfree : int := IO_StatFS_Flag_FrFree;
 836 const statfs_flag_fravail : int := IO_StatFS_Flag_FrAvail;
 837 const statfs_flag_intotal : int := IO_StatFS_Flag_InTotal;
 838 const statfs_flag_infree : int := IO_StatFS_Flag_InFree;
 839 const statfs_flag_inavail : int := IO_StatFS_Flag_InAvail;
 840 const statfs_flag_fsid : int := IO_StatFS_Flag_FSId;
 841 const statfs_flag_flags : int := IO_StatFS_Flag_Flags;
 842 const statfs_flag_namelen : int := IO_StatFS_Flag_NameLen;
 843
 844 const statfs_st_readonly : int := IO_StatFS_ST_ReadOnly;
 845 const statfs_st_nosuid : int := IO_StatFS_ST_NoSuid;
 846 const statfs_st_nodev : int := IO_StatFS_ST_NoDev;
 847 const statfs_st_noexec : int := IO_StatFS_ST_NoExec;
 848 const statfs_st_synchronous : int := IO_StatFS_ST_Synchronous;
 849 const statfs_st_mandlock : int := IO_StatFS_ST_MandLock;
 850 const statfs_st_noatime : int := IO_StatFS_ST_NoAtime;
 851 const statfs_st_nodiratime : int := IO_StatFS_ST_NoDirAtime;
 852 const statfs_st_relatime : int := IO_StatFS_ST_RelAtime;
 853
 854 fn fstatfs(w : world, h : handle, flags : int) : (world, list(int64))
 855 [
 856         var res : list(int64);
 857         var w2 : world;
 858         pcode IO IO_FStatFS 2 3 0 =w2 =res w h flags;
 859         return w2, res;
 860 ]
 861
 862 fn dstatfs(w : world, d : dhandle, flags : int) : (world, list(int64))
 863 [
 864         var res : list(int64);
 865         var w2 : world;
 866         pcode IO IO_DStatFS 2 3 0 =w2 =res w d flags;
 867         return w2, res;
 868 ]
 869
 870 fn readlink(w : world, d : dhandle, f : bytes) : (world, bytes)
 871 [
 872         var res : bytes;
 873         var w2 : world;
 874         pcode IO IO_ReadLink 2 3 0 =w2 =res w d f;
 875         return w2, res;
 876 ]
 877
 878 fn readlink_lazy(d : dhandle, f : bytes) : bytes
 879 [
 880         var res : bytes;
 881         var w := unsafe_get_world;
 882         w, res := readlink(w, d, f);
 883         return res;
 884 ]
 885
 886 fn unlink(w : world, d : dhandle, f : bytes) : world
 887 [
 888         var w2 : world;
 889         pcode IO IO_Dir_Action 1 3 1 =w2 w d f IO_Action_Rm;
 890         return w2;
 891 ]
 892
 893 fn rmdir(w : world, d : dhandle, f : bytes) : world
 894 [
 895         var w2 : world;
 896         pcode IO IO_Dir_Action 1 3 1 =w2 w d f IO_Action_Rm_Dir;
 897         return w2;
 898 ]
 899
 900 fn mkdir(w : world, d : dhandle, f : bytes, mode : int) : world
 901 [
 902         var w2 : world;
 903         pcode IO IO_Dir_Action 1 4 1 =w2 w d f mode IO_Action_Mk_Dir;
 904         return w2;
 905 ]
 906
 907 fn mkpipe(w : world, d : dhandle, f : bytes, mode : int) : world
 908 [
 909         var w2 : world;
 910         pcode IO IO_Dir_Action 1 4 1 =w2 w d f mode IO_Action_Mk_Pipe;
 911         return w2;
 912 ]
 913
 914 fn mksocket(w : world, d : dhandle, f : bytes, mode : int) : world
 915 [
 916         var w2 : world;
 917         pcode IO IO_Dir_Action 1 4 1 =w2 w d f mode IO_Action_Mk_Socket;
 918         return w2;
 919 ]
 920
 921 fn mkchardev(w : world, d : dhandle, f : bytes, mode major minor : int) : world
 922 [
 923         var w2 : world;
 924         pcode IO IO_Dir_Action 1 6 1 =w2 w d f mode major minor IO_Action_Mk_CharDev;
 925         return w2;
 926 ]
 927
 928 fn mkblockdev(w : world, d : dhandle, f : bytes, mode major minor : int) : world
 929 [
 930         var w2 : world;
 931         pcode IO IO_Dir_Action 1 6 1 =w2 w d f mode major minor IO_Action_Mk_BlockDev;
 932         return w2;
 933 ]
 934
 935 fn mksymlink(w : world, d : dhandle, f t : bytes) : world
 936 [
 937         var w2 : world;
 938         pcode IO IO_Dir_Action 1 4 1 =w2 w d f t IO_Action_Mk_SymLink;
 939         return w2;
 940 ]
 941
 942 fn mklink(w : world, d : dhandle, f : bytes, e : dhandle, t : bytes) : world
 943 [
 944         var w2 : world;
 945         pcode IO IO_Dir2_Action 1 5 1 =w2 w d f e t IO_Action_Mk_Link;
 946         return w2;
 947 ]
 948
 949 fn rename(w : world, d : dhandle, f : bytes, e : dhandle, t : bytes) : world
 950 [
 951         var w2 : world;
 952         pcode IO IO_Dir2_Action 1 5 1 =w2 w d f e t IO_Action_Rename;
 953         return w2;
 954 ]
 955
 956 fn chmod(w : world, d : dhandle, f : bytes, m : int) : world
 957 [
 958         var w2 : world;
 959         pcode IO IO_Dir_Action 1 4 1 =w2 w d f m IO_Action_ChMod;
 960         return w2;
 961 ]
 962
 963 fn chown(w : world, d : dhandle, f : bytes, uid gid : int) : world
 964 [
 965         var w2 : world;
 966         pcode IO IO_Dir_Action 1 5 1 =w2 w d f uid gid IO_Action_ChOwn;
 967         return w2;
 968 ]
 969
 970 fn lchown(w : world, d : dhandle, f : bytes, uid gid : int) : world
 971 [
 972         var w2 : world;
 973         pcode IO IO_Dir_Action 1 5 1 =w2 w d f uid gid IO_Action_LChOwn;
 974         return w2;
 975 ]
 976
 977 fn utime(w : world, d : dhandle, f : bytes, atime mtime : int64) : world
 978 [
 979         var w2 : world;
 980         pcode IO IO_Dir_Action 1 5 1 =w2 w d f mtime atime IO_Action_UTime;
 981         return w2;
 982 ]
 983
 984 fn lutime(w : world, d : dhandle, f : bytes, atime mtime : int64) : world
 985 [
 986         var w2 : world;
 987         pcode IO IO_Dir_Action 1 5 1 =w2 w d f mtime atime IO_Action_LUTime;
 988         return w2;
 989 ]
 990
 991 fn mount_points(implicit w : world) : (world, list(bytes))
 992 [
 993         var result := empty(bytes);
 994         var os := sysprop(SystemProperty_OS);
 995         if os = SystemProperty_OS_DOS or
 996            os = SystemProperty_OS_OS2 or
 997            os = SystemProperty_OS_Windows or
 998            os = SystemProperty_OS_Cygwin then [
 999                 goto call_io_drives;
1000         ]
1001         var is_minix := uname(uname_flag_system)[0] = "Minix";
1002         var w1 := w;
1003         var d := ropen(dnone(), "/etc/mtab", 0);
1004         if not is_exception w then
1005                 goto have_d;
1006         recover_world(w1);
1007         w1 := w;
1008         d := ropen(dnone(), "/proc/mounts", 0);
1009         if not is_exception w then
1010                 goto have_d;
1011         recover_world(w1);
1012         goto call_io_drives;
1013
1014 have_d:
1015         var mtab := read_full(d);
1016         var lines := list_break_to_lines(mtab);
1017         for l in lines do [
1018                 if len(l) = 0 or l[0] = '#' then
1019                         continue;
1020                 var brk := list_break_whitespace(l);
1021                 var q : bytes;
1022                 if is_minix then
1023                         q := brk[2];
1024                 else
1025                         q := brk[1];
1026                 if is_exception q then
1027                         continue;
1028                 var w2 := w;
1029                 var qh := dopen(dnone(), q, 0);
1030                 var st := dstatfs(qh, statfs_flag_frtotal);
1031                 if is_exception st then [
1032                         recover_world(w2);
1033                         continue;
1034                 ]
1035                 //eval debug(q + " " + ntos(st[0]));
1036                 if st[0] > 2 then
1037                         result +<= q;
1038         ]
1039         result := list_sort(result);
1040         return w, result;
1041
1042 call_io_drives:
1043         var w2 : world;
1044         var drvs : bytes;
1045         pcode IO IO_Drives 2 1 0 =w2 =drvs w;
1046         w := w2;
1047         return w, list_break(drvs, 0);
1048 ]
1049
1050
1051 const stty_flag_raw : int := IO_Stty_Flag_Raw;
1052 const stty_flag_noecho : int := IO_Stty_Flag_Noecho;
1053 const stty_flag_nosignal : int := IO_Stty_Flag_Nosignal;
1054 const stty_flag_nocrlf : int := IO_Stty_Flag_NoCRLF;
1055
1056 fn stty(w : world, h : handle, flags : int) : world
1057 [
1058         var w2 : world;
1059         pcode IO IO_Stty 1 3 0 =w2 w h flags;
1060         return w2;
1061 ]
1062
1063 fn tty_size(w : world, h : handle) : (world, int, int, int, int)
1064 [
1065         var nx ny ox oy : int;
1066         var w2 : world;
1067         pcode IO IO_Tty_Size 5 2 0 =w2 =nx =ny =ox =oy w h;
1068         return w2, nx, ny, ox, oy;
1069 ]
1070
1071 fn tty_background(w : world) : world
1072 [
1073         var w2 : world;
1074         pcode IO IO_Tty_Background 1 1 0 =w2 w;
1075         return w2;
1076 ]
1077
1078 fn tty_foreground(w : world) : (world, bool)
1079 [
1080         var b : bool;
1081         var w2 : world;
1082         pcode IO IO_Tty_Foreground 2 1 0 =w2 =b w;
1083         return w2, b;
1084 ]
1085
1086
1087 const uname_flag_ajla_version : int := IO_UName_Flag_Ajla_Version;
1088 const uname_flag_flavor : int := IO_UName_Flag_Flavor;
1089 const uname_flag_system : int := IO_UName_Flag_System;
1090 const uname_flag_release : int := IO_UName_Flag_Release;
1091 const uname_flag_version : int := IO_UName_Flag_Version;
1092 const uname_flag_machine : int := IO_UName_Flag_Machine;
1093
1094 fn uname(flags : int) : list(bytes)
1095 [
1096         var res : list(bytes);
1097         pcode IO IO_UName 1 1 0 =res flags;
1098         return res;
1099 ]
1100
1101 fn get_host_name(w : world) : (world, bytes)
1102 [
1103         var res : bytes;
1104         var w2 : world;
1105         pcode IO IO_GetHostName 2 1 0 =w2 =res w;
1106         return w2, res;
1107 ]
1108
1109
1110 fn get_real_time(w : world) : (world, int64)
1111 [
1112         var ret : int64;
1113         var w2 : world;
1114         pcode IO IO_GetTime 2 1 1 =w2 =ret w 1;
1115         return w2, ret;
1116 ]
1117
1118 fn get_monotonic_time(w : world) : (world, int64)
1119 [
1120         var ret : int64;
1121         var w2 : world;
1122         pcode IO IO_GetTime 2 1 1 =w2 =ret w 2;
1123         return w2, ret;
1124 ]
1125
1126 fn sleep(t : type, w : t, tm : int64) : t
1127 [
1128         xeval w;
1129         var w2 : t;
1130         var u : int64;
1131         var w3 : world;
1132         w3, u := get_monotonic_time(unsafe_get_world);
1133         u += tm;
1134         pcode IO IO_Sleep 1 2 0 =w2 w u;
1135         return w2;
1136 ]
1137
1138 {--------
1139  - PATH -
1140  --------}
1141
1142 const path_separator : byte
1143 [
1144         var os := sysprop(SystemProperty_OS);
1145         if os = SystemProperty_OS_DOS or
1146            os = SystemProperty_OS_OS2 or
1147            os = SystemProperty_OS_Windows then
1148                 return '\';
1149         return '/';
1150 ]
1151
1152 fn path_is_separator(b : byte) : bool
1153 [
1154         if b = '\' or b = ':' then [
1155                 var os := sysprop(SystemProperty_OS);
1156                 if os = SystemProperty_OS_DOS or
1157                    os = SystemProperty_OS_OS2 or
1158                    os = SystemProperty_OS_Cygwin or
1159                    os = SystemProperty_OS_Windows then
1160                         return true;
1161         ]
1162         return b = '/';
1163 ]
1164
1165 fn path_is_dir_separator(b : byte) : bool
1166 [
1167         if b = '\' then [
1168                 var os := sysprop(SystemProperty_OS);
1169                 if os = SystemProperty_OS_DOS or
1170                    os = SystemProperty_OS_OS2 or
1171                    os = SystemProperty_OS_Cygwin or
1172                    os = SystemProperty_OS_Windows then
1173                         return true;
1174         ]
1175         return b = '/';
1176 ]
1177
1178 fn path_compare(a b : bytes) : bool
1179 [
1180         var os := sysprop(SystemProperty_OS);
1181         if os = SystemProperty_OS_DOS or
1182            os = SystemProperty_OS_OS2 or
1183            os = SystemProperty_OS_Windows then [
1184                 if len(a) <> len(b) then
1185                         return false;
1186                 for i := 0 to len(a) do [
1187                         var a1 := a[i];
1188                         var b1 := b[i];
1189                         if a1 >= 'a', a1 <= 'z' then
1190                                 a1 -= #20;
1191                         if b1 >= 'a', b1 <= 'z' then
1192                                 b1 -= #20;
1193                         if a1 <> b1 then
1194                                 return false;
1195                 ]
1196                 return true;
1197         ]
1198         return a = b;
1199 ]
1200
1201 fn dos_path_is_absolute(p : bytes) : bool
1202 [
1203         if len_at_least(p, 3), (p[0] and #DF) >= 'A', (p[0] and #DF) <= 'Z', p[1] = ':', path_is_dir_separator(p[2]) then
1204                 return true;
1205         if len_at_least(p, 2), path_is_dir_separator(p[0]), path_is_dir_separator(p[1]) then
1206                 return true;
1207         return false;
1208 ]
1209
1210 fn path_is_absolute(p : bytes) : bool
1211 [
1212         var os := sysprop(SystemProperty_OS);
1213         if os = SystemProperty_OS_DOS or
1214            os = SystemProperty_OS_OS2 or
1215            os = SystemProperty_OS_Windows then [
1216                 return dos_path_is_absolute(p);
1217         ]
1218         if len_at_least(p, 1), path_is_dir_separator(p[0]) then
1219                 return true;
1220         if os = SystemProperty_OS_Cygwin then
1221                 return dos_path_is_absolute(p);
1222         return false;
1223 ]
1224
1225 fn path_is_root(p : bytes) : bool
1226 [
1227         p := path_contract(p);
1228         if len(p) = 1, path_is_dir_separator(p[0]) then
1229                 return true;
1230         var os := sysprop(SystemProperty_OS);
1231         if os = SystemProperty_OS_DOS or
1232            os = SystemProperty_OS_OS2 or
1233            os = SystemProperty_OS_Cygwin or
1234            os = SystemProperty_OS_Windows then [
1235                 if len(p) = 3, (p[0] and #DF) >= 'A', (p[0] and #DF) <= 'Z', p[1] = ':', path_is_dir_separator(p[2]) then
1236                         return true;
1237         ]
1238         return false;
1239 ]
1240
1241 fn path_to_dir_file(p : bytes) : (bytes, bytes)
1242 [
1243         var idx := list_search_backwards_fn(p, path_is_separator);
1244         var dir := p[ .. idx + 1];
1245         var file := p[idx + 1 .. ];
1246         if file = "." or file = ".." then [
1247                 dir := p +< path_separator;
1248                 file := "";
1249         ]
1250         if dir = "" then
1251                 dir := "." + bytes.[ path_separator ];
1252         if len(dir) > 1 then
1253                 dir := dir[ .. len(dir) - 1];
1254         return dir, file;
1255 ]
1256
1257 fn path_append(pd pf : bytes) : bytes
1258 [
1259         if len(pd) > 0, not path_is_separator(pd[len(pd) - 1]) then
1260                 pd += bytes.[ path_separator ];
1261         return pd + pf;
1262 ]
1263
1264 fn path_contract_unix(p : bytes, trim_dot : bool) : bytes
1265 [
1266         for i := 0 to len(p) do [
1267                 if path_is_dir_separator(p[i]) then
1268                         p[i] := '/';
1269         ]
1270         var leading_slash := false;
1271         if len_at_least(p, 1), p[0] = '/' then [
1272                 p := p[1 .. ];
1273                 leading_slash := true;
1274         ]
1275         var components := list_break(p, '/');
1276         var result := empty(bytes);
1277         for i := 0 to len(components) do [
1278                 if components[i] = "" then
1279                         continue;
1280                 if components[i] = ".", trim_dot then
1281                         continue;
1282                 if components[i] = ".." then [
1283                         if len(result) >= 1 then [
1284                                 if result[len(result) - 1] = ".." then
1285                                         goto add_to_result;
1286                                 result := result[ .. len(result) - 1];
1287                                 continue;
1288                         ] else [
1289                                 if leading_slash then
1290                                         continue;
1291                         ]
1292                 ]
1293 add_to_result:
1294                 result +<= components[i];
1295         ]
1296         var r := "";
1297         if leading_slash then
1298                 r +<= path_separator;
1299         for i := 0 to len(result) do [
1300                 if i > 0 then
1301                         r +<= path_separator;
1302                 r += result[i];
1303         ]
1304         if r = "" then
1305                 r := ".";
1306         return r;
1307 ]
1308
1309 fn path_contract(p : bytes) : bytes
1310 [
1311         if path_is_separator(':') then [
1312                 if len_at_least(p, 2), (p[0] and #DF) >= 'A', (p[0] and #DF) <= 'Z', p[1] = ':' then
1313                         return p[ .. 2] + path_contract_unix(p[2 .. ], true);
1314                 if len_at_least(p, 2), path_is_dir_separator(p[0]), path_is_dir_separator(p[1]) then
1315                         return [ path_separator ] + path_contract_unix(p[1 .. ], false);
1316         ]
1317         return path_contract_unix(p, true);
1318 ]
1319
1320 fn path_join(pd pf : bytes) : bytes
1321 [
1322         if path_is_absolute(pf) then
1323                 return path_contract(pf);
1324         if path_is_separator(':') then [
1325                 if len_at_least(pf, 1), path_is_separator(pf[0]) then [
1326                         if len_at_least(pd, 2), (pd[0] and #DF) >= 'A', (pd[0] and #DF) <= 'Z', pd[1] = ':' then [
1327                                 return path_contract(pd[ .. 2] + pf);
1328                         ]
1329                         if len_at_least(pd, 2), path_is_dir_separator(pd[0]), path_is_dir_separator(pd[1]) then [
1330                                 return path_contract(pd[ .. 1] + pf);
1331                         ]
1332                         return path_contract(pf);
1333                 ]
1334                 if len_at_least(pf, 2), (pf[0] and #DF) >= 'A', (pf[0] and #DF) <= 'Z', pf[1] = ':' then [
1335                         if len_at_least(pd, 3), (pd[0] and #DF) = (pf[0] and #DF), pd[1] = ':', path_is_dir_separator(pd[2]) then [
1336                                 pf := pf[2 .. ];
1337                         ] else [
1338                                 return path_contract(pf[ .. 2] + [ path_separator ] + pf[2 .. ]);
1339                         ]
1340                 ]
1341         ]
1342         return path_contract(path_append(pd, pf));
1343 ]
1344
1345 fn path_canonical(implicit w : world, d : dhandle, p : bytes) : (world, bytes)
1346 [
1347         var dir, file := path_to_dir_file(p);
1348         var pd := dopen(d, dir, 0);
1349         var pdp := dpath(pd);
1350         var pj := path_append(pdp, file);
1351         return pj;
1352 ]
1353
1354 fn path_get_cwd(implicit w : world, d : dhandle, env : treemap(bytes, bytes)) : (world, bytes)
1355 [
1356         var p1 := dpath(d);
1357         var t := treemap_search(env, "PWD");
1358         if t is j, path_is_absolute(t.j) then [
1359                 var ctr := path_contract(t.j);
1360                 var old_w := w;
1361                 var pd2 := dopen(dnone(), ctr, 0);
1362                 if is_exception pd2 then [
1363                         recover_world(old_w);
1364                         return p1;
1365                 ]
1366                 old_w := w;
1367                 var p2 := dpath(pd2);
1368                 if is_exception p2 then [
1369                         recover_world(old_w);
1370                         return p1;
1371                 ]
1372                 if p1 = p2 then
1373                         return ctr;
1374         ]
1375         return p1;
1376 ]
1377
1378 fn path_shortcut_home(home : maybe(bytes), p : bytes) : bytes
1379 [
1380         if home is n then
1381                 return p;
1382         if not path_is_absolute(home.j) then
1383                 return p;
1384         var h := path_contract(home.j);
1385         if h = p then
1386                 return "~";
1387         if len(h) < len(p), path_compare(h, p[ .. len(h)]), path_is_dir_separator(p[len(h)]) then
1388                 return "~" + p[len(h) .. ];
1389         return p;
1390 ]
1391
1392 fn path_expand_home(home : maybe(bytes), p : bytes) : bytes
1393 [
1394         if home is n then
1395                 return p;
1396         var h := home.j;
1397         if not path_is_absolute(h) then
1398                 return p;
1399         h := path_contract(h);
1400         if p = "~" then
1401                 return h;
1402         if len(p) >= 2, p[0] = '~', path_is_dir_separator(p[1]) then [
1403                 var i := 2;
1404                 while len(p) > i, path_is_dir_separator(p[i]) do
1405                         i += 1;
1406                 return path_append(h, p[i .. ]);
1407         ]
1408         return p;
1409 ]
1410
1411 fn path_mkdir_step(implicit w : world, d : dhandle, f : bytes, mode : int) : world
1412 [
1413         var w1 := w;
1414         mkdir(d, f, mode);
1415         if is_exception w then [
1416                 if exception_type w = error_system, exception_aux w = system_error_eexist then [
1417                         recover_world(w1);
1418                 ]
1419         ]
1420 ]
1421
1422 fn path_mkdir(implicit w : world, d : dhandle, f : bytes, mode : int) : world
1423 [
1424         var w1 := w;
1425         path_mkdir_step(d, f, mode);
1426         if not is_exception w then
1427                 return w;
1428         recover_world(w1);
1429
1430         var i := 0;
1431         while i < len(f), path_is_separator(f[i]) do
1432                 i += 1;
1433         if i = 0, path_is_absolute(f) then [
1434                 while i < len(f), not path_is_separator(f[i]) do
1435                         i += 1;
1436                 while i < len(f), path_is_separator(f[i]) do
1437                         i += 1;
1438         ]
1439
1440         while i < len(f) do [
1441                 while i < len(f), not path_is_separator(f[i]) do
1442                         i += 1;
1443                 while i < len(f), path_is_separator(f[i]) do
1444                         i += 1;
1445                 path_mkdir_step(d, f[ .. i], mode);
1446                 xeval w;
1447         ]
1448 ]
1449
1450 fn path_xdg(implicit w : world, env : treemap(bytes, bytes), xdg_env : bytes, deflt : bytes, appname : bytes) : (world, dhandle)
1451 [
1452         var w1 := w;
1453 again:
1454         var d : bytes;
1455         var x := treemap_search(env, xdg_env);
1456         if x is j then [
1457                 if path_is_absolute(x.j) then [
1458                         d := x.j;
1459                         goto have_d;
1460                 ]
1461         ]
1462         if sysprop(SystemProperty_OS) = SystemProperty_OS_Windows then [
1463                 x := treemap_search(env, "APPDATA");
1464                 if x is j then
1465                         goto have_x;
1466         ]
1467         x := treemap_search(env, "HOME");
1468         if x is j then [
1469 have_x:
1470                 var a := path_append(x.j, deflt);
1471                 if path_is_absolute(a) then [
1472                         d := a;
1473                         goto have_d;
1474                 ]
1475         ]
1476         d := dpath(dexe());
1477 have_d:
1478         d := path_append(d, appname);
1479         path_mkdir(dnone(), d, #1c0);
1480         if is_exception w then [
1481                 if len(deflt) > 0, deflt[0] = '.' then [
1482                         recover_world(w1);
1483                         deflt := deflt[1 .. ];
1484                         goto again;
1485                 ]
1486         ]
1487         return dopen(dnone(), d, 0);
1488 ]
1489
1490 fn path_config(implicit w : world, env : treemap(bytes, bytes), appname : bytes) : (world, dhandle)
1491 [
1492         return path_xdg(env, "XDG_CONFIG_HOME", ".config", appname);
1493 ]
1494
1495 fn path_write_atomic(implicit w : world, d : dhandle, f : bytes, content : bytes) : world
1496 [
1497         var w1 := w;
1498         var tmp_file := f;
1499         var i := len(tmp_file) - 1;
1500         while i >= 0 do [
1501                 if path_is_separator(tmp_file[i]) then
1502                         break;
1503                 if tmp_file[i] = '.' then [
1504                         tmp_file := tmp_file[ .. i];
1505                         break;
1506                 ]
1507                 i -= 1;
1508         ]
1509         tmp_file +<= '.';
1510         var num := 0;
1511         atomic_enter();
1512 next_num:
1513         var tmp_file_x := tmp_file + ntos(num);
1514         var wf := wopen(d, tmp_file_x, open_flag_create or open_flag_must_create, #180);
1515         if is_exception w, exception_aux w = system_error_eexist, not is_exception w1 then [
1516                 recover_world(w1);
1517                 num += 1;
1518                 goto next_num;
1519         ]
1520         write(wf, content);
1521         rename(d, f, d, tmp_file_x);
1522         if is_exception w then [
1523                 var xw := w;
1524                 recover_world(w1);
1525                 unlink(d, tmp_file);
1526                 atomic_exit();
1527                 keep w;
1528                 return xw;
1529         ]
1530         atomic_exit();
1531 ]
1532
1533 {----------------
1534  - DEPENDENCIES -
1535  ----------------}
1536
1537 fn register_dependence(implicit w : world, d : dhandle, p : bytes) : world
1538 [
1539         var cp := path_canonical(d, p);
1540         var w2 : world;
1541         pcode IO IO_Register_Dependence 1 2 0 =w2 w cp;
1542         return w2;
1543 ]