obp/obp/os/unix/sparc/sys.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: sys.fth
\
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\
\  - Do no alter or remove copyright notices
\
\  - Redistribution and use of this software in source and binary forms, with
\    or without modification, are permitted provided that the following
\    conditions are met:
\
\  - Redistribution of source code must retain the above copyright notice,
\    this list of conditions and the following disclaimer.
\
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\    Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\
\     This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility.
\
\ ========== Copyright Header End ============================================
id: @(#)sys.fth 2.20 07/06/05 10:54:56
purpose:
copyright: Copyright 2007 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.
\ Copyright 1985-1990 Bradley Forthware

\ Very-low-level interfaces to the Sun 4.2 BSD version of Unix
\ These routines may have to be rewritten for other flavors of
\ Unix, because the mechanism for doing system calls may differ.
\ The names and the stack diagrams should not need to change, however.

\ The wrapper is expected to implement the forth stack semantics of the
\ routines and match the stack direction.
\
decimal

headerless

/l ualloc-t  dup equ syscall-user#
headers
user syscall-vec   \ long address of system call vector
headerless

nuser sysretval

\ I/O for running under Unix with a C program providing actual I/O routines

headers
meta
0 [if]
code syscall? ( call# -- ok? )  \ For backwards compatibility
   'user syscall-vec   %l0  nget
   bubble
32\ tos 2               tos     slln            \ multiply by 4
64\ tos 3               tos     slln            \ multiply by 8
   %l0 tos              %l0     ld              \ Address of routine
   %l0 %g0              %g0     subcc
   0=  if
      %g0  1            tos     sub             \ (delay)
      %g0               tos     move
   then
c;
[then]

code syscall ( ?? call# -- ?? ) \ For backwards compatibility
                                \ Get address of system call table
   'user syscall-vec    %l0     nget
   bubble
32\ tos 2               tos     slln            \ multiply by 4
64\ tos 3               tos     slln            \ multiply by 8
   %l0 tos              %l0     nget            \ Address of routine
   sp                   tos     pop
   tos                  %o0     move            \ Get some arguments
   sp  0 /n*            %o1     nget
   sp  1 /n*            %o2     nget
   sp  2 /n*            %o3     nget
   sp  3 /n*            %o4     nget
   sp  4 /n*            %o5     nget
   %g2                  %l2     move
   %g3                  %l3     move
   %g4                  %l4     move
   %g5                  %l5     move
   %g6                  %l6     move
   %g7                  %l7     move
   %l0 %g0              %o7     jmpl
   %g1                  %l1     move            \ Delay slot

   %l1                  %g1     move
   %l2                  %g2     move
   %l3                  %g3     move
   %l4                  %g4     move
   %l5                  %g5     move
   %l6                  %g6     move
   %l7                  %g7     move

   %o0  'user sysretval         nput    \ Save the result

c;

\ A syscall wrapper that uses the stack so that the wrapper can return
\ data on the forth stacks.
\
code fsyscall ( ?? call# -- ?? )
   'user syscall-vec    %l0     nget
   bubble
32\ tos 2               tos     slln            \ multiply by 4
64\ tos 3               tos     slln            \ multiply by 8
   %l0 tos              %l0     nget            \ Address of routine
   sp                   %o0     move
   %g2                  %l2     move
   %g3                  %l3     move
   %g4                  %l4     move
   %g5                  %l5     move
   %g6                  %l6     move
   %g7                  %l7     move
   %l0 %g0              %o7     jmpl
   %g1                  %l1     move            \ Delay slot

   %l1                  %g1     move
   %l2                  %g2     move
   %l3                  %g3     move
   %l4                  %g4     move
   %l5                  %g5     move
   %l6                  %g6     move
   %l7                  %g7     move
   %o0                  sp      move            \ new stack pointer
   sp                   tos     pop
c;

: retval   ( -- return_value )     sysretval @  ;
: lretval  ( -- l.return_value )   sysretval @ n->l ;

headers
nuser errno     \ The last system error code
headerless

: error?  ( return-value -- return-value error? )
   dup 0< dup  if  15 syscall retval errno !  then   ( return-value flag )
;

headers
\ Depends on null-termination of Forth strings
overload: cstr  ( pstr -- cstr )  1+  ;

\ Rounds down to a block boundary.  This causes all file accesses to the
\ underlying operating system to occur on disk block boundaries.  Some
\ systems (e.g. CP/M) require this; others which don't require it
\ usually run faster with alignment than without.
hex
headerless

chain: unix-init-io
   install-wrapper-io

   \ Don't poll the keyboard under Unix; block waiting for a key
   ['] (key              ['] key            (is
;
' unix-init-io is init-io

: unix-init ;  \ Environment initialization chain
' unix-init is init-environment
decimal
headers