[OpenSPARC-T2-SAM] / obp / obp / cpu / sparc / ccalls.fth

\ ========== 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 
\    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 ============================================
\ 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.
\
\ Defines:
\
\ 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.

decimal
only forth assembler also forth also hidden also definitions

headerless
variable #args  variable #results  variable arg#

: system-call ( syscall# -- )
   [ also assembler ]
   %g2 sc1 move
   ( call# )  %g1  move
   %g0 0  always  trapif
   u< if
      0    up  ['] errno >user#  st   \ Delay slot
      %o0  up  ['] errno >user#  st
      -1  %o0  move
   then
   sc1 %g2 move
   [ previous ]
;
\ : subroutine-call   ( subroutine-adr -- )
\    [ also assembler ]
\    ( adr )  call
\    %g2 sc1 move		\ Delay slot
\    sc1 %g2 move
\    [ previous ]
\ ;
: wrapper-call  ( call# -- )
   [ also assembler ]
					\ Get address of system call table
   'user syscall-vec  scr  nget
   bubble
   ( call# ) scr swap  scr nget		\ Address of routine
   %g1 sc1 move
   scr %g0  %o7  jmpl
   %g2 sc2 move		\ Delay slot
   sc1 %g1 move
   sc2 %g2 move
   [ previous ]
;

: sys:  \ name ( call# -- )
   code
;
: %o#  ( -- reg )  [ also assembler ]  arg# @ %o0 +  [ previous ]  ;
: arg  ( -- )
   arg# @  if
      [ also assembler ]  sp  arg# @ 1- /n*   %o#  nget  [ previous ]
   else
      [ also assembler ]  tos  %o0  move  [ previous ]
   then
   1 arg# +!
;
: str  ( -- )
   arg# @  if
      [ also assembler ]  sp   arg# @ 1- /n*   %o#  nget
                          %o#  1               %o#  add [ previous ]
   else
      [ also assembler ]  tos  1  %o0  add  [ previous ]
   then
   1 arg# +!
;   
: res  ( -- )  1 #results +!  ;
: }  ( -- )
   #results @  if
      #args @ 0=  if  [ also assembler ]
         tos  sp  push
      [ previous ]  then

      #args @ 1 > if  [ also assembler ]
         sp  #args @ 1- /n*  sp   add
      [ previous ]  then

      [ also assembler ]  %o0 tos  move   [ previous ]
   else   \ No results
      #args @     if  [ also assembler ]
         sp  #args @ 1- /n*  tos  nget
         sp  #args @    /n*  sp   add
      [ previous ]  then
   then
;
: scan-args ( -- )
   #args off
   0   ( marker )
   begin
      bl word  1+ c@
      case
      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             false endof
      ascii } of  ." Where's the -- ?" abort endof
      ( default ) ." Bad type specifier: " dup emit abort
    endcase
  while
    1 #args +!
  repeat
  arg# off
  begin  ?dup  while  execute  repeat
;
: do-call  ( ??? 'call-assembler -- ) \ ??? is args specific to the call type
   execute
;
: scan-results ( -- )
   #results off
   begin
      bl word  1+ c@
      case
      ascii l of                  true  endof 
      ascii i of                  true  endof 
      ascii a of                  true  endof 
      ascii s of  ." Can't return strings yet" abort   true  endof 
      ascii } of                  false endof
      ( default ) ." Bad type specifier: " dup emit
      endcase
   while
      1 #results +!
   repeat
   }
;
only forth hidden  also forth assembler  also forth  definitions
: {  \ args -- results }  ( -- )
   scan-args  do-call  scan-results    next
;

headers
: syscall:  \ name  ( syscall# -- syscall# 'system-call )
   ['] 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
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: ccalls.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	\ ccalls.fth 2.4 94/05/30
	43	\ Copyright 1985-1990 Bradley Forthware
	44
	45	\ Defining words to construct Forth interfaces to C subroutines
	46	\ and Unix system calls. This is strongly implementation dependent, and will
	47	\ require EXTENSIVE modifications for other Forth systems, other CPU's,
	48	\ and other operating systems.
	49	\
	50	\ Defines:
	51	\
	52	\ syscall: ( syscall# -- ) ( Input Stream: name arg-spec )
	53	\ subroutine: ( adr -- ) ( Input Stream: name arg-spec )
	54	\
	55	\ This version is for SPARC Unix systems where ints, longs, and addresses
	56	\ are all the same size. Under this assumption, the only thing we have to
	57	\ do to the stack arguments is to convert Forth strings to C strings.
	58
	59	decimal
	60	only forth assembler also forth also hidden also definitions
	61
	62	headerless
	63	variable #args variable #results variable arg#
	64
65	: system-call ( syscall# -- )
66	[ also assembler ]
67	%g2 sc1 move
68	( call# ) %g1 move
69	%g0 0 always trapif
70	u< if
71	0 up ['] errno >user# st \ Delay slot
72	%o0 up ['] errno >user# st
73	-1 %o0 move
74	then
75	sc1 %g2 move
76	[ previous ]
77	;
78	\ : subroutine-call ( subroutine-adr -- )
79	\ [ also assembler ]
80	\ ( adr ) call
81	\ %g2 sc1 move \ Delay slot
82	\ sc1 %g2 move
83	\ [ previous ]
84	\ ;
85	: wrapper-call ( call# -- )
86	[ also assembler ]
87	\ Get address of system call table
88	'user syscall-vec scr nget
89	bubble
90	( call# ) scr swap scr nget \ Address of routine
91	%g1 sc1 move
92	scr %g0 %o7 jmpl
93	%g2 sc2 move \ Delay slot
94	sc1 %g1 move
95	sc2 %g2 move
96	[ previous ]
97	;
98
99	: sys: \ name ( call# -- )
100	code
101	;
102	: %o# ( -- reg ) [ also assembler ] arg# @ %o0 + [ previous ] ;
103	: arg ( -- )
104	arg# @ if
105	[ also assembler ] sp arg# @ 1- /n* %o# nget [ previous ]
106	else
107	[ also assembler ] tos %o0 move [ previous ]
108	then
109	1 arg# +!
110	;
111	: str ( -- )
112	arg# @ if
113	[ also assembler ] sp arg# @ 1- /n* %o# nget
114	%o# 1 %o# add [ previous ]
115	else
116	[ also assembler ] tos 1 %o0 add [ previous ]
117	then
118	1 arg# +!
119	;
120	: res ( -- ) 1 #results +! ;
121	: } ( -- )
122	#results @ if
123	#args @ 0= if [ also assembler ]
124	tos sp push
125	[ previous ] then
126
127	#args @ 1 > if [ also assembler ]
128	sp #args @ 1- /n* sp add
129	[ previous ] then
130
131	[ also assembler ] %o0 tos move [ previous ]
132	else \ No results
133	#args @ if [ also assembler ]
134	sp #args @ 1- /n* tos nget
135	sp #args @ /n* sp add
136	[ previous ] then
137	then
138	;
139	: scan-args ( -- )
140	#args off
141	0 ( marker )
142	begin
143	bl word 1+ c@
144	case
145	ascii l of ['] arg true endof
146	ascii i of ['] arg true endof
147	ascii a of ['] arg true endof
148	ascii s of ['] str true endof
149	ascii - of false endof
150	ascii } of ." Where's the -- ?" abort endof
151	( default ) ." Bad type specifier: " dup emit abort
152	endcase
153	while
154	1 #args +!
155	repeat
156	arg# off
157	begin ?dup while execute repeat
158	;
159	: do-call ( ??? 'call-assembler -- ) \ ??? is args specific to the call type
160	execute
161	;
162	: scan-results ( -- )
163	#results off
164	begin
165	bl word 1+ c@
166	case
167	ascii l of true endof
168	ascii i of true endof
169	ascii a of true endof
170	ascii s of ." Can't return strings yet" abort true endof
171	ascii } of false endof
172	( default ) ." Bad type specifier: " dup emit
173	endcase
174	while
175	1 #results +!
176	repeat
177	}
178	;
179	only forth hidden also forth assembler also forth definitions
180	: { \ args -- results } ( -- )
181	scan-args do-call scan-results next
182	;
183
184	headers
185	: syscall: \ name ( syscall# -- syscall# 'system-call )
186	['] system-call
187	code current @ context ! \ don't want to be in assembler voc
188	;
189	\ : subroutine: \ name ( adr -- adr 'subroutine-call )
190	\ ['] subroutine-call code current @ context !
191	\ ;
192
193	only forth also definitions