Patch title: Release 81 bulk changes
Abstract:
File: /pliant/language/os/posix.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

scope "/pliant/language/"
module "/pliant/install/ring2.pli"

constant linux (os_kernel="Linux")


#----------------------------------------------------------------
#  testing the distribution


function maybe solution try
  arg_rw Str solution ; arg Str try
  if solution=""
    var Int h := file_open try 1
    if h<>-1
      solution := try
      file_close h

function libpthread_filename -> filename
  arg Str filename
  filename := ""
  if os_kernel="FreeBSD"
    maybe filename "/usr/lib/libc_r.so"
    maybe filename "/usr/lib/libc_r.so.4"
    maybe filename "/usr/lib/libc_r.so.3.0"
  eif os_kernel="OpenBSD"
    maybe filename "/usr/lib/libc_r.so.3.0"   # OpenBSD 2.7
    maybe filename "/usr/lib/libc_r.so.1.1"   # OpenBSD 2.6
    maybe filename "/usr/lib/libc_r.so.0.0"   # OpenBSD 2.5
  else
    maybe filename "/lib/libpthread.so.0" 

function libc_filename -> filename
  arg Str filename
  filename := ""
  if os_kernel="FreeBSD"
    maybe filename "/usr/lib/libc_r.so"       # This is supposed to be a symlink
    maybe filename "/usr/lib/libc_r.so.4"     # ... For FreeBSD 3.X
    maybe filename "/usr/lib/libc_r.so.3.0"   # ... For FreeBSD 2.X
  eif os_kernel="OpenBSD"
    maybe filename "/usr/lib/libc_r.so.3.0"   # OpenBSD 2.7
    maybe filename "/usr/lib/libc_r.so.1.1"   # OpenBSD 2.6
    maybe filename "/usr/lib/libc_r.so.0.0"   # OpenBSD 2.5
  else
    maybe filename "/lib/libc.so.6" 
    maybe filename "/lib/libc.so.5" 

function zlib_filename -> filename
  arg Str filename
  filename := ""
  maybe filename "/lib/libz.so" 
  maybe filename "/usr/lib/libz.so" 
  maybe filename "/lib/libz.so.2" 
  maybe filename "/usr/lib/libz.so.2" 
  maybe filename "/lib/libz.so.2.0" 
  maybe filename "/usr/lib/libz.so.2.0" 
  maybe filename "/lib/libz.so.1" 
  maybe filename "/usr/lib/libz.so.1" 
  maybe filename "/lib/libz.so.1.0" 
  maybe filename "/usr/lib/libz.so.1.0"
  maybe filename "/usr/lib/libz.so.1.3"       # OpenBSD

public
  constant os_libc_filename libc_filename
  constant os_libpthread_filename libpthread_filename
  constant os_zlib_filename zlib_filename


#----------------------------------------------------------------


function os_system cmd -> err
  arg CStr cmd ; arg Int err
  external os_libc_filename "system"


function os_compute_version -> version
  arg Str version
  os_system "uname -r >/tmp/pliant.version"
  var Int h := file_open "/tmp/pliant.version" 1
  if h=-1
    return ""
  var Str buffer := repeat 80 " "
  var Int len := file_read h buffer:characters buffer:len
  version := buffer 0 len
  version := version 0 (version search "[lf]" version:len)
  file_close h
  os_system "rm -f /tmp/pliant.version"

public
  constant os_version os_compute_version


function os_query_c_headers prog -> result
  arg Str prog ; arg Str result
  var Int h := file_open "/tmp/pliant.c" 2
  if h=-1
    return ""
  file_write h prog:characters prog:len
  file_close h
  var Int err := os_system "gcc -o /tmp/pliant.exe /tmp/pliant.c 2>/dev/null"
  if err<>0
    # console prog+" -> "+('convert to string' err)+"[lf]"
    os_system "rm -f /tmp/pliant.c /tmp/pliant.exe"
    return ""
  os_system "/tmp/pliant.exe >/tmp/pliant.txt"
  h := file_open "/tmp/pliant.txt" 1
  if h=-1
    os_system "rm -f /tmp/pliant.c /tmp/pliant.exe /tmp/pliant.txt"
    return ""
  var Str buffer := repeat 80 " "
  var Int len := file_read h buffer:characters buffer:len
  file_close h
  os_system "rm -f /tmp/pliant.c /tmp/pliant.exe /tmp/pliant.txt"
  result := buffer 0 len
  
function os_constant_value header name -> cst
  arg Str header name ; arg Int cst
  var Str prog := ""
  if os_kernel="FreeBSD" or os_kernel="OpenBSD"
    prog += "#include <sys/types.h>[lf]"
  prog += "#include <stdio.h>[lf]"
  prog += "#include <"+header+">[lf]"
  prog += "int main() { printf([dq]%i[dq],"+name+"); return 0; }[lf]"
  if not (os_query_c_headers:prog parse cst)
    error error_id_missing "Failed to extract posix constant "+name+" from C headers"
  
function os_type_size header struct -> size
  arg Str header struct ; arg Int size
  var Str prog := ""
  if os_kernel="FreeBSD" or os_kernel="OpenBSD"
    prog += "#include <sys/types.h>[lf]"
  prog += "#include <stdio.h>[lf]"
  prog += "#include <"+header+">[lf]"
  prog += "int main() { printf([dq]%i[dq],sizeof(struct "+struct+")); return 0; }[lf]"
  if not (os_query_c_headers:prog parse size)
    error error_id_missing "Failed to extract posix "+struct+" size from C headers"
  
function os_field_offset header struct field offset size
  arg Str header struct field ; arg_w Int offset size
  var Str prog := ""
  if os_kernel="FreeBSD" or os_kernel="OpenBSD"
    prog += "#include <sys/types.h>[lf]"
  prog += "#include <stdio.h>[lf]"
  prog += "#include <"+header+">[lf]"
  prog += "int main() { struct "+struct+" v; printf([dq]%i %i[dq],(int)((char *)&v."+field+"-(char *)&v),sizeof(v."+field+")); return 0; }[lf]"
  if not (os_query_c_headers:prog parse offset size)
    error error_id_missing "Failed to extract posix field "+field+" offset in "+struct+" from C headers"
  

meta os_constant e
  if e:size=3 and e:0:ident<>"" and (e:1 constant Str)<>null and e:2:ident<>""
    var Link:Expression pliant_name :> expression ident e:0:ident near e:0
    var Link:Expression header :> e:1
    var Link:Expression c_name :> expression constant e:2:ident near e:2
    e compile_as (expression immediat (constant pliant_name (os_constant_value header c_name)) substitute pliant_name pliant_name substitute header header substitute c_name c_name)


gvar Link:Type ct
gvar Str ch
gvar Str cn

function sample_function object -> field
  arg Universal object ; arg_C Universal field

meta field e
  strong_definition
  if addressof:ct=null
    return
  if e:size<2 or (e:0 constant Type)=null
    return
  var Link:Type fieldtype :> (e:0 constant Type) map Type
  check fieldtype<>Int8 and fieldtype<>Int16 and fieldtype<>Int32 "You should use Int instead"
  check fieldtype<>uInt8 and fieldtype<>uInt16 and fieldtype<>uInt32 "You should use uInt instead"
  for (var Int i) 1 e:size-1
    if e:i:ident=""
      return
    os_field_offset ch cn e:i:ident (var Int offset) (var Int size)
    var Link:Type t
    if size>=Int:size
      t :> fieldtype
    eif fieldtype=Int
      if size=1
        t :> Int8
      eif size=2
        t :> Int16
      eif size=4
        t :> Int32
      else
        t :> null map Type
    eif fieldtype=uInt
      if size=1
        t :> uInt8
      eif size=2
        t :> uInt16
      eif size=4
        t :> uInt32
      else
        t :> null map Type
    eif fieldtype=uInt_li
      if size=1
        t :> uInt8
      eif size=2
        t :> uInt16_li
      eif size=4
        t :> uInt32_li
      else
        t :> null map Type
    eif fieldtype=uInt_hi
      if size=1
        t :> uInt8
      eif size=2
        t :> uInt16_hi
      eif size=4
        t :> uInt32_hi
      else
        t :> null map Type
    else
      t :> null map Type
    check addressof:t<>null
    var Link:Function sample :> the_function sample_function Universal -> Universal
    var Link:Function f :> new Function
    f name := ". "+e:i:ident
    f position := e:i:position
    var Link:Argument object :> argument local ct
    f define_argument ct (sample arg 0):access "object" null
    (f arg 0) inline_argument :> object
    var Link:Argument field :> argument local Address
    f define_argument t (sample arg 1):access "field" null
    (f arg 1) inline_argument :> field
    f terminate_arguments function_flag_inline_instructions
    f:inline_instructions append addressof:(instruction (the_function 'translate Universal' Universal Int -> Universal) object (argument constant Int offset) field)
    e define f:name addressof:f e:module:actual
    # console "  field "+e:i:ident+" offset is "+(cast offset Str)+"[lf]"
  e set_void_result

meta os_type e
  if e:size<>4 or e:0:ident="" or (e:1 constant Str)=null or e:2:ident=""
    return
  ct :> new Type
  ch := (e:1 constant Str) map Str
  cn := e:2 ident
  ct:name := e:0:ident
  ct terminate_fields
  ct size := os_type_size ch cn
  # console cn+" size is "+(cast ct:size Str)+"[lf]"
  e define ct:name addressof:ct e:module:actual
  e:3:compile
  e suckup e:3
  ct :> null map Type
  e set_void_result


export os_constant os_constant_value os_type field


#----------------------------------------------------------------


function os_sysctl name namelen old oldlen new newlen -> err
  arg Address name ; arg Int namelen ; arg Address old ; arg_rw Int oldlen ; arg Address new ; arg Int newlen err
  external os_libc_filename "sysctl"

function os_sysctl name -> value
  arg Str name ; arg Str value
  var Address namebuf := memory_allocate name:len*Int:size null
  var Int namelen := 0
  var Str path := name
  var Int i := -1
  while i<path:len
    var Int j := ((path i+1 path:len) search "." path:len-i-1)+i+1
    var Str id := path 0 j
    if i=-1
      id := "ctl."+id
    id := replace upper:id "." "_"
    var Str prog := ""
    if os_kernel="FreeBSD" or os_kernel="OpenBSD"
      prog += "#include <sys/types.h>[lf]"
    prog += "#include <stdio.h>[lf]"
    prog += "#include <sys/sysctl.h>[lf]"
    prog += "int main() { printf([dq]%i[dq],"+id+"); return 0; }[lf]"
    if not (os_query_c_headers:prog parse (var Int c))
      # console "sysctl failed to query operating system constant "+id+"[lf]"
      return ""
    (namebuf translate Int namelen) map Int := c
    namelen := namelen+1
    i := j
  var Int valuelen := 256
  var Address valuebuf := memory_allocate valuelen null
  value set valuebuf valuelen true
  var Int err := os_sysctl namebuf namelen valuebuf valuelen null 0
  if err<>0
    # console "sysctl "+name+" returned error "+('convert to string' err)+"[lf]"
    return ""
  value := value 0 valuelen

export os_sysctl


#----------------------------------------------------------------


public
  os_constant os_O_RDONLY "fcntl.h" O_RDONLY 
  os_constant os_O_WRONLY "fcntl.h" O_WRONLY
  os_constant os_O_RDWR "fcntl.h" O_RDWR
  os_constant os_O_CREAT "fcntl.h" O_CREAT
  os_constant os_O_NOCTTY "fcntl.h" O_NOCTTY
  os_constant os_O_TRUNC "fcntl.h" O_TRUNC
  os_constant os_O_APPEND "fcntl.h" O_APPEND
  os_constant os_O_NONBLOCK "fcntl.h" O_NONBLOCK
  os_constant os_F_SETFL "fcntl.h" F_SETFL
  os_constant os_SEEK_SET "unistd.h" SEEK_SET
  os_constant os_SEEK_CUR "unistd.h" SEEK_CUR
  os_constant os_SEEK_END "unistd.h" SEEK_END

public
  os_type os_timeval "sys/time.h" timeval
    field Int tv_sec tv_usec

function os_open name flags rights -> handle
  arg CStr name ; arg Int flags rights handle
  external os_libc_filename "open"

function os_close handle -> err
  arg Int handle err
  external os_libc_filename "close"

function os_read handle address size -> err
  arg Int handle size err ; arg Address address
  external os_libc_filename "read"

public
  os_constant os_EAGAIN "errno.h" EAGAIN

function os_write handle address size -> err
  arg Int handle size err ; arg Address address
  external os_libc_filename "write"

function os_lseek handle pos mode -> err
  arg Int handle pos mode err
  external os_libc_filename "lseek"

function os_select n readfds writefds exceptfds timeout -> fd
  arg Int n ; arg Address readfds writefds exceptfds ; arg_rw os_timeval timeout ; arg Int fd
  external os_libc_filename "select"

public
  os_type os_pollfd "poll.h" pollfd
    field Int fd
    field uInt events revents
  os_constant os_POLLIN "poll.h" POLLIN
  os_constant os_POLLOUT "poll.h" POLLOUT
  os_constant os_POLLERR "poll.h" POLLERR
  os_constant os_POLLHUP "poll.h" POLLHUP
  os_constant os_POLLNVAL "poll.h" POLLNVAL

function os_poll fds nfds timeout -> count
  arg Address fds ; arg Int nfds timeout ; arg Int count
  external os_libc_filename "poll"

function os_fcntl handle cmd arg -> err
  arg Int handle cmd arg err
  external os_libc_filename "fcntl"

public
  os_constant os_F_SETFD "fcntl.h" F_SETFD
  os_constant os_FD_CLOEXEC "fcntl.h" FD_CLOEXEC

function os_fsync handle -> err
  arg Int handle err
  external os_libc_filename "fsync"

function os_dup src -> dest
  arg Int src dest
  external os_libc_filename "dup"

function os_dup2 src dest
  arg Int src dest
  external os_libc_filename "dup2"

function os_chdir path -> err
  arg CStr path ; arg Int err
  external os_libc_filename "chdir"

export os_open os_close os_read os_write os_select os_poll os_lseek os_fcntl os_fsync
export os_dup os_dup2 os_chdir


function os_link src dest -> err
  arg CStr src dest ; arg Int err
  external os_libc_filename "link"

function os_symlink src dest -> err
  arg CStr src dest ; arg Int err
  external os_libc_filename "symlink"

function os_unlink name -> err
  arg CStr name ; arg Int err
  external os_libc_filename "unlink"

function os_rename oldpath newpath -> err
  arg CStr oldpath newpath ; arg Int err
  external os_libc_filename "rename"

function os_chmod name rights -> err
  arg CStr name ; arg Int rights err
  external os_libc_filename "chmod"

function os_lchown name uid gid -> err
  arg CStr name ; arg Int uid gid err
  external os_libc_filename "lchown"

public
  os_type os_utimbuf "utime.h" utimbuf
    field uInt actime modtime

function os_utime name buf -> err
  arg CStr name ; arg os_utimbuf buf ; arg Int err
  external os_libc_filename "utime"

function os_mkdir name mode -> err
  arg CStr name ; arg Int mode err
  external os_libc_filename "mkdir"

function os_rmdir name -> err
  arg CStr name ; arg Int err
  external os_libc_filename "rmdir"

export os_link os_symlink os_unlink os_rename os_chmod os_lchown os_utime os_mkdir os_rmdir


public
  os_type os_stat "sys/stat.h" stat 
    field uInt st_size
    field uInt st_mtime st_atime
    field uInt st_mode
    field uInt st_uid st_gid

os_constant os_S_IFMT "sys/stat.h" S_IFMT
os_constant os_S_IFDIR "sys/stat.h" S_IFDIR
os_constant os_S_IFLNK "sys/stat.h" S_IFLNK
  
function os_S_ISDIR mode -> dir
  arg Int mode ; arg CBool dir
  dir := (mode .and. os_S_IFMT)=os_S_IFDIR

function os_S_ISLNK mode -> dir
  arg Int mode ; arg CBool dir
  dir := (mode .and. os_S_IFMT)=os_S_IFLNK

if linux
  os_constant os__STAT_VER "sys/stat.h" _STAT_VER
  function __xstat version filename stat -> err
    arg Int version ; arg CStr filename ; arg_w os_stat stat ; arg Int err
    external os_libc_filename "__xstat"
  function os_stat filename stat -> err
    arg CStr filename ; arg_w os_stat stat ; arg Int err
    err := __xstat os__STAT_VER filename stat
  function __lxstat version filename stat -> err
    arg Int version ; arg CStr filename ; arg_w os_stat stat ; arg Int err
    external os_libc_filename "__lxstat"
  function os_lstat filename stat -> err
    arg CStr filename ; arg_w os_stat stat ; arg Int err
    err := __lxstat os__STAT_VER filename stat
else
  function os_stat filename stat -> err
    arg CStr filename ; arg_w os_stat stat ; arg Int err
    external os_libc_filename "stat"
  function os_lstat filename stat -> err
    arg CStr filename ; arg_w os_stat stat ; arg Int err
    external os_libc_filename "lstat"

function os_readlink path buffer size -> err
  arg CStr path ; arg Address buffer ; arg Int size err
  external os_libc_filename "readlink"
  
function os_opendir path -> handle
  arg CStr path ; arg Address handle
  external os_libc_filename "opendir"

if os_kernel="FreeBSD" or os_kernel="OpenBSD"
  os_constant os_NAME_MAX "sys/syslimits.h" NAME_MAX
else
  os_constant os_NAME_MAX "dirent.h" NAME_MAX

public
  os_type os_dirent "dirent.h" dirent
    field (Array Char os_NAME_MAX) d_name

function os_readdir handle -> dirent
  arg Address handle ; arg_RW os_dirent dirent
  external os_libc_filename "readdir"

function os_closedir handle
  arg Address handle
  external os_libc_filename "closedir"

export os_stat os_lstat os_S_ISDIR os_S_ISLNK
export os_readlink os_opendir os_readdir os_closedir


public
  constant os_default_directory_mode 7*8^2+5*8+5
  constant os_default_file_mode 6*8^2+4*8+4


#----------------------------------------------------------------


public
  os_constant os_SIGSEGV "signal.h" SIGSEGV
  os_constant os_SIGBUS "signal.h" SIGBUS
  os_constant os_SIGFPE "signal.h" SIGFPE
  os_constant os_SIGINT "signal.h" SIGINT
  os_constant os_SIGTERM "signal.h" SIGTERM
  os_constant os_SIGCONT "signal.h" SIGCONT
  os_constant os_SIGSTOP "signal.h" SIGSTOP
  os_constant os_SIGPIPE "signal.h" SIGPIPE

  os_constant os_SIG_IGN "signal.h" SIG_IGN

  if os_kernel="OpenBSD"   # probably FreeBSD too (atleast ver >= 4.0)
    os_constant os_SA_SIGINFO "signal.h" SA_SIGINFO
    os_type os_sigcontext "signal.h" sigcontext
      field Int sc_pc
      field Int sc_fp

public
  os_type os_sigaction "signal.h" sigaction
    field Address sa_handler
    if os_kernel="OpenBSD"
      field Address sa_sigaction
    field uInt sa_mask
    field Int sa_flags

function build  sa
  arg_w os_sigaction sa
  memory_clear addressof:sa os_sigaction:size

function os_sigaction num newaction oldaction -> err
  arg Int num err ; arg os_sigaction newaction ; arg_w os_sigaction oldaction
  external os_libc_filename "sigaction"
  
export os_sigaction


#----------------------------------------------------------------


function os_execvp cmd args -> err
  arg CStr cmd ; arg Address args ; arg Int err
  external os_libc_filename "execvp"

function os_setuid id -> err
  arg Int id err
  external os_libc_filename "setuid"

function os_setgid id -> err
  arg Int id err
  external os_libc_filename "setgid"

function os_exit retcode
  arg Int retcode
  external os_libc_filename "exit"

export os_execvp os_setuid os_setgid os_exit


if (constant os_kernel="FreeBSD" and (os_version 0 1)<"3" and (os_version 1 1)=".") or (constant os_kernel="OpenBSD")
  public
    os_type os_timespec "sys/time.h" timespec
      field Int tv_sec tv_nsec
else
  public
    os_type os_timespec "time.h" timespec
      field Int tv_sec tv_nsec

function os_nanosleep req rem
  arg os_timespec req ; arg_w os_timespec rem
  external os_libc_filename "nanosleep"
 
function os_yield
  if os_kernel<>"Linux"
    external os_libc_filename "sched_yield"
  else
    var os_timespec ts
    ts tv_sec := 0
    ts tv_nsec := 0
    os_nanosleep ts ts
   
export os_nanosleep os_yield


public
  type os_timezone
    void

function os_gettimeofday tv tz
  arg_w os_timeval tv ; arg_w os_timezone tz
  external os_libc_filename "gettimeofday"

export os_gettimeofday


#----------------------------------------------------------------


function os_getpid -> pid
  arg Int pid
  external os_libc_filename "getpid"

export os_getpid