1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:           PXNK:SYSTEM-FASLIN.SL
4% Title:          Fasl stuff needed at run time
5%                 Based on VAX version.
6% Author:         Eric Benson
7% Created:        25 April 1982
8% Modified:       4-Dec-84 15:05:42 (Vicki O'Day)
9% Status:         Open Source: BSD License
10% Mode:           Lisp
11% Package:        Kernel
12%
13% (c) Copyright 1983, Hewlett-Packard Company, see the file
14%            HP_disclaimer at the root of the PSL file tree
15%
16% (c) Copyright 1982, University of Utah
17%
18% Redistribution and use in source and binary forms, with or without
19% modification, are permitted provided that the following conditions are met:
20%
21%    * Redistributions of source code must retain the relevant copyright
22%      notice, this list of conditions and the following disclaimer.
23%    * Redistributions in binary form must reproduce the above copyright
24%      notice, this list of conditions and the following disclaimer in the
25%      documentation and/or other materials provided with the distribution.
26%
27% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
28% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
29% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
30% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
31% CONTRIBUTORS
32% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
33% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
34% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
35% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
36% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
37% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
38% POSSIBILITY OF SUCH DAMAGE.
39%
40%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
41%
42% Revisions:
43%
44% 03-May-90 (herbert Melenk)
45%  Inserted calls to MS-DOS file name expansion
46% 06-Apr-88 (Julian Padget)
47%  Must do (wgetv symval <expr>) in CPSL.
48% 4-Dec-84 15:05:34 (Vicki O'Day)
49%  Added binaryopenupdate.
50% 26-Sep-84 13:41:32 (Vicki O'Day)
51%  Added binaryopenappend for use with Nmail.
52% 27-Jul-84 (Vicki O'Day)
53%  Added redefinition of binaryopenread, so if it fails it can call
54%  conterror instead of kernel-fatal-error.
55% 10-Jul-84 13:35:24 (RAM)
56%  Replaced call to fopen with call to unixopen.  Unixopen will expand
57%  shell variables (and some other fancy stuff).
58% 2-Jul-84 (Vicki O'Day)
59%  Removed functions in kernel.
60% 27-Feb-84 17:00:24 (RAM)
61%  Changed File and Title entries in header.
62%  Added flagging as foreignfunction of fopen, fclose, putw,
63%  fread, fwrite, fseek.
64% 2-Dec-83  16:00:00 (Brian Beach)
65%   Translated from Rlisp to Lisp.
66%
67%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
68%
69
70(compiletime (load fasl-decls sys-consts sys-macros io-decls))
71
72(fluid '(argumentblock))
73(fluid '(kernel-maxsymbols))
74(when (not kernel-maxsymbols)(setq kernel-maxsymbols 0))
75
76(de depositvaluecelllocation (x)
77  (if (not *writingfaslfile)
78    (progn (setf (getmem (iplus2 codebase* currentoffset*))
79              (if (wgreaterp (idinf x) kernel-maxsymbols)
80                  (loc (wgetv symval (idinf x)))
81                  (loc (wgetv old_symval (idinf x)))
82           )  )
83           (setf currentoffset* (iplus2 currentoffset* 4)))
84    (progn (setf (getmem (iplus2 codebase* currentoffset*))
85                 (makerelocword reloc-value-cell (findidnumber x)))
86           (setf currentoffset* (iplus2 currentoffset* 4))
87           (updatebittable 4 reloc-word))))
88
89(de depositextrareglocation (x)
90  (if (not *writingfaslfile)
91    (progn (setf (getmem (iplus2 codebase* currentoffset*))
92                 (loc (wgetv argumentblock
93                       (wdifference x (wplus2 maxrealregs 1)))))
94           (setf currentoffset* (iplus2 currentoffset* 4)))
95    (progn (setf (getmem (iplus2 codebase* currentoffset*))
96                 (makerelocword reloc-value-cell (wplus2 x 8150)))
97           (setf currentoffset* (iplus2 currentoffset* 4))
98           (updatebittable 4 reloc-word))))
99
100(de depositfunctioncelllocation (x)
101  (if (not *writingfaslfile)
102    (progn (setf (getmem (iplus2 codebase* currentoffset*))
103                 (iplus2 symfnc (itimes2 4 (idinf x))))
104           (setf currentoffset* (iplus2 currentoffset* 4)))
105    (progn (setf (getmem (iplus2 codebase* currentoffset*))
106                 (makerelocword reloc-function-cell
107                  (findidnumber x)))
108           (setf currentoffset* (iplus2 currentoffset* 4))
109           (updatebittable 4 reloc-word))))
110
111
112% binary IO
113
114(declare-wstring openreadflag initially "rb")
115(declare-wstring openwriteflag initially "wb")
116(declare-wstring openappendflag initially "a")
117(declare-wstring openupdateflag initially "r+")
118
119
120% binaryopenread, binaryread, binaryreadblock and binaryclose
121% are in the kernel, but binaryopenread needs to be redefined
122% here so conterror instead of kernel-fatal-error will be called.
123
124(de binaryopenread (filename)
125  (prog (f)
126        (setq filename (fnexpand filename))
127        (&time-control nil)
128        (setq f
129              (unixopen (strbase (strinf filename))
130                     (strbase openreadflag)))
131        (&time-control t)
132        (return (if (wleq f 2)
133                  (conterror 99 "Couldn't open binary file for input"
134                   (binaryopenread filename))
135                  f))))
136
137(de binaryopenwrite (filename)
138  (prog (f)
139        (setq filename (fnexpand filename))
140        (&time-control nil)
141        (setq f
142              (unixopen (strbase (strinf filename))
143                     (strbase openwriteflag)))
144        (&time-control t)
145        (return (if (wleq f 2)
146                  (conterror 99 "Couldn't open binary file for output"
147                   (binaryopenwrite filename))
148                  f))))
149
150(de binaryopenappend (filename)
151  (prog (f)
152        (setq filename (fnexpand filename))
153        (&time-control nil)
154        (setq f
155              (unixopen (strbase (strinf filename))
156                     (strbase openappendflag)))
157        (&time-control t)
158        (return (if (wleq f 2)
159                  (conterror 99 "Couldn't open binary file for append"
160                   (binaryopenappend filename))
161                  f))))
162
163(de binaryopenupdate (filename)
164  (prog (f)
165        (setq filename (fnexpand filename))
166        (&time-control nil)
167        (setq f
168              (unixopen (strbase (strinf filename))
169                     (strbase openupdateflag)))
170        (&time-control t)
171        (return (if (wleq f 2)
172                  (conterror 99 "Couldn't open binary file for update"
173                   (binaryopenupdate filename))
174                  f))))
175
176(de binarywrite (channel n)
177 (prog(r)
178  (&time-control nil)
179  (setq r (putw n channel))
180  (&time-control t)
181  (return r)))
182
183(de binarywriteblock (channel blockbase blocksize)
184 (prog(r)
185  (&time-control nil)
186  (setq r (fwrite blockbase (wtimes2 4 blocksize) 1  channel))
187  (&time-control t)
188  (return r)))
189
190(de binarypositionfile (channel nastysystemdependentnumber)
191 (prog(r)
192  (&time-control nil)
193  (setq r (fseek channel nastysystemdependentnumber 0))
194  (&time-control t)
195  (return r)))
196
197(de binaryread (filepointer)            % Read one word, 32 bits.
198 (prog(r)
199  (&time-control nil)
200  (setq r (getw filepointer))
201  (&time-control t)
202  (return r)))
203
204(de binaryreadblock (filepointer blockbase blocksize)
205 (prog(r)
206  (&time-control nil)
207  (setq r (fread blockbase 4 blocksize filepointer))
208  (&time-control t)
209  (return r)))
210
211