\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: ccalls.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
\ - 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
\ ========== Copyright Header End ============================================
\ ccalls.fth 2.4 94/05/30
\ Copyright 1985-1990 Bradley Forthware
\ Defining words to construct Forth interfaces to C subroutines
\ and Unix system calls. This is strongly implementation dependent, and will
\ require EXTENSIVE modifications for other Forth systems, other CPU's,
\ and other operating systems.
\ syscall: ( syscall# -- ) ( Input Stream: name arg-spec )
\ subroutine: ( adr -- ) ( Input Stream: name arg-spec )
\ This version is for SPARC Unix systems where ints, longs, and addresses
\ are all the same size. Under this assumption, the only thing we have to
\ do to the stack arguments is to convert Forth strings to C strings.
only forth assembler also forth also hidden also definitions
variable #args variable #results variable arg#
: system-call ( syscall# -- )
0 up ['] errno >user# st \ Delay slot
%o0 up ['] errno >user# st
\ : subroutine-call ( subroutine-adr -- )
\ %g2 sc1 move \ Delay slot
: wrapper-call ( call# -- )
\ Get address of system call table
'user syscall-vec scr nget
( call# ) scr swap scr nget \ Address of routine
%g2 sc2 move \ Delay slot
: sys: \ name ( call# -- )
: %o# ( -- reg ) [ also assembler ] arg# @ %o0 + [ previous ] ;
[ also assembler ] sp arg# @ 1- /n* %o# nget [ previous ]
[ also assembler ] tos %o0 move [ previous ]
[ also assembler ] sp arg# @ 1- /n* %o# nget
%o# 1 %o# add [ previous ]
[ also assembler ] tos 1 %o0 add [ previous ]
: res ( -- ) 1 #results +! ;
#args @ 0= if [ also assembler ]
#args @ 1 > if [ also assembler ]
[ also assembler ] %o0 tos move [ previous ]
#args @ if [ also assembler ]
sp #args @ 1- /n* tos nget
ascii l of ['] arg true endof
ascii i of ['] arg true endof
ascii a of ['] arg true endof
ascii s of ['] str true endof
ascii } of ." Where's the -- ?" abort endof
( default ) ." Bad type specifier: " dup emit abort
begin ?dup while execute repeat
: do-call ( ??? 'call-assembler -- ) \ ??? is args specific to the call type
ascii s of ." Can't return strings yet" abort true endof
( default ) ." Bad type specifier: " dup emit
only forth hidden also forth assembler also forth definitions
: { \ args -- results } ( -- )
scan-args do-call scan-results next
: syscall: \ name ( syscall# -- syscall# 'system-call )
code current @ context ! \ don't want to be in assembler voc
\ : subroutine: \ name ( adr -- adr 'subroutine-call )
\ ['] subroutine-call code current @ context !
only forth also definitions