[OpenSPARC-T2-SAM] / obp / obp / fm / kernel / fileio.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: fileio.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: @(#)fileio.fth 1.3 04/04/15 19:10:04
purpose: 
copyright: Copyright 1994-2004 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.
\ Copyright 1994 FirmWorks  All Rights Reserved

headerless

: (file-read-line) ( adr fd -- actual not-eof? error? )
   dup if						( adr source )
      /tib swap read-line				( adr len id )
      ( -37 ) abort" Read error in refill"  ( cnt more? )
      over /tib = ( -18 ) abort" line too long in input file"  ( cnt more? )
   else							( adr )
      simple-refill-line				( cnt more? )
   then							( cnt more? )
; ' (file-read-line) is refill-line

: interpret-lines  ( -- )  begin  refill  while  interpret  repeat  ;

: include-file  ( fid -- )
   /tib 4 + allocate throw	( fid adr )
   save-input 2>r 2>r 2>r       ( fid adr )

   /tib rot set-input

   ['] interpret-lines catch    ( error# )
   source-id close-file drop    ( error# )

   source-adr free drop         ( error# )

   2r> 2r> 2r> restore-input  throw  ( error# )
   throw
;

defer $open-error        ' noop is $open-error

[ifnexist] include-hook 	\  Might be defined in  xref.fth 
   headers
   defer include-hook       ' noop is include-hook
   defer include-exit-hook  ' noop is include-exit-hook
   headerless
[then]

: include-buffer  ( adr len -- )
   open-buffer  ?dup  if  " <buffer>" $open-error  then  include-file
;

: $abort-include  ( error# filename$ -- )  2drop  throw  ;
' $abort-include is $open-error

headers
: included  ( adr len -- )
   include-hook
   r/o open-file  ?dup  if
      opened-filename 2@ $open-error
   then                 ( fid )
   include-file
   include-exit-hook
;
headerless
' included is cmdline-file

: including  ( "name" -- )  safe-parse-word included  ;
: fl  ( "name" -- )  including  ;

0 value error-file
nuser error-line#
nuser error-source-id
nuser error-source-adr
nuser error-#source
chain: init  ( -- )
   d# 128 alloc-mem  is error-file
   error-source-id off
   0 error-file c!
   error-line# off
;

: (eol-mark?) ( c -- flag )
   dup 0= >r			( c )
   dup control M = r> or	( c cr? )
   swap control J = or		( cr? )
;

: (mark-error)  ( -- )
   \ Suppress message if input is interactive or from "evaluate"
   source-id  error-source-id !
   source-id  0<>  if
      source-id  -1 =  if
         \ Record the approx error position not the whole buffer!!
         true source >r >in @		( flag adr offset )
         begin				( flag adr offset )
            rot				( adr offset more? )
            over and while		( adr offset )
               2dup + c@		( adr offset )
               (eol-mark?) if		( adr offset )
                  1+ 0 -rot		( 0 adr offset )
               else			( adr offset )
                  true -rot 1-		( -1 adr offset )
               then			( flag adr offset )
         repeat				( adr offset )
         r> swap /string 		( adr' len' )
         >r 0 over r>			( adr' 0 adr' len )
         bounds ?do			( adr' 0 )
            i c@ (eol-mark?) if		( adr' len' )
               leave			( adr' len' )
            else			( adr' len' )
               1+			( adr' len' )
            then			( adr' len' )
         loop				( adr' len' )
         error-#source !  error-source-adr !
      else
         source-id file-name error-file place
         source-id file-line error-line# !
      then
   then
;
' (mark-error) is mark-error
: (show-error)  ( -- )
   ??cr
   error-source-id @  if
      error-source-id @ -1  =  if
         ." Evaluating: " error-source-adr @ error-#source @  type cr
      else
         error-file count ?dup if		( va,len )
            type  ." :"				( )
            error-line# @ (.d)			( $adr,len )
            type  ." : "			( )
         else					( va )
            drop				( )
         then					( )
      then					( )
   then						( )
;
' (show-error) is show-error

\ Environment?

headers

defer environment?
: null-environment?  ( c-addr u -- false | i*x true )  2drop false  ;
' null-environment? is environment?

: fload fl ;

: $report-name  ( name$ -- name$ )
   ??cr ." Loading " 2dup type cr
;
: fexit ( -- )  source-id close-file drop -1 'source-id !  ;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: fileio.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	id: @(#)fileio.fth 1.3 04/04/15 19:10:04
	43	purpose:
	44	copyright: Copyright 1994-2004 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46	\ Copyright 1994 FirmWorks All Rights Reserved
	47
	48	headerless
	49
	50	: (file-read-line) ( adr fd -- actual not-eof? error? )
	51	dup if ( adr source )
	52	/tib swap read-line ( adr len id )
	53	( -37 ) abort" Read error in refill" ( cnt more? )
	54	over /tib = ( -18 ) abort" line too long in input file" ( cnt more? )
	55	else ( adr )
	56	simple-refill-line ( cnt more? )
	57	then ( cnt more? )
	58	; ' (file-read-line) is refill-line
	59
	60	: interpret-lines ( -- ) begin refill while interpret repeat ;
	61
	62	: include-file ( fid -- )
	63	/tib 4 + allocate throw ( fid adr )
	64	save-input 2>r 2>r 2>r ( fid adr )
65
66	/tib rot set-input
67
68	['] interpret-lines catch ( error# )
69	source-id close-file drop ( error# )
70
71	source-adr free drop ( error# )
72
73	2r> 2r> 2r> restore-input throw ( error# )
74	throw
75	;
76
77	defer $open-error ' noop is $open-error
78
79	[ifnexist] include-hook \ Might be defined in xref.fth
80	headers
81	defer include-hook ' noop is include-hook
82	defer include-exit-hook ' noop is include-exit-hook
83	headerless
84	[then]
85
86	: include-buffer ( adr len -- )
87	open-buffer ?dup if " <buffer>" $open-error then include-file
88	;
89
90	: $abort-include ( error# filename$ -- ) 2drop throw ;
91	' $abort-include is $open-error
92
93	headers
94	: included ( adr len -- )
95	include-hook
96	r/o open-file ?dup if
97	opened-filename 2@ $open-error
98	then ( fid )
99	include-file
100	include-exit-hook
101	;
102	headerless
103	' included is cmdline-file
104
105	: including ( "name" -- ) safe-parse-word included ;
106	: fl ( "name" -- ) including ;
107
108	0 value error-file
109	nuser error-line#
110	nuser error-source-id
111	nuser error-source-adr
112	nuser error-#source
113	chain: init ( -- )
114	d# 128 alloc-mem is error-file
115	error-source-id off
116	0 error-file c!
117	error-line# off
118	;
119
120	: (eol-mark?) ( c -- flag )
121	dup 0= >r ( c )
122	dup control M = r> or ( c cr? )
123	swap control J = or ( cr? )
124	;
125
126	: (mark-error) ( -- )
127	\ Suppress message if input is interactive or from "evaluate"
128	source-id error-source-id !
129	source-id 0<> if
130	source-id -1 = if
131	\ Record the approx error position not the whole buffer!!
132	true source >r >in @ ( flag adr offset )
133	begin ( flag adr offset )
134	rot ( adr offset more? )
135	over and while ( adr offset )
136	2dup + c@ ( adr offset )
137	(eol-mark?) if ( adr offset )
138	1+ 0 -rot ( 0 adr offset )
139	else ( adr offset )
140	true -rot 1- ( -1 adr offset )
141	then ( flag adr offset )
142	repeat ( adr offset )
143	r> swap /string ( adr' len' )
144	>r 0 over r> ( adr' 0 adr' len )
145	bounds ?do ( adr' 0 )
146	i c@ (eol-mark?) if ( adr' len' )
147	leave ( adr' len' )
148	else ( adr' len' )
149	1+ ( adr' len' )
150	then ( adr' len' )
151	loop ( adr' len' )
152	error-#source ! error-source-adr !
153	else
154	source-id file-name error-file place
155	source-id file-line error-line# !
156	then
157	then
158	;
159	' (mark-error) is mark-error
160	: (show-error) ( -- )
161	??cr
162	error-source-id @ if
163	error-source-id @ -1 = if
164	." Evaluating: " error-source-adr @ error-#source @ type cr
165	else
166	error-file count ?dup if ( va,len )
167	type ." :" ( )
168	error-line# @ (.d) ( $adr,len )
169	type ." : " ( )
170	else ( va )
171	drop ( )
172	then ( )
173	then ( )
174	then ( )
175	;
176	' (show-error) is show-error
177
178	\ Environment?
179
180	headers
181
182	defer environment?
183	: null-environment? ( c-addr u -- false \| i*x true ) 2drop false ;
184	' null-environment? is environment?
185
186	: fload fl ;
187
188	: $report-name ( name$ -- name$ )
189	??cr ." Loading " 2dup type cr
190	;
191	: fexit ( -- ) source-id close-file drop -1 'source-id ! ;