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% 06-Apr-88 (Julian Padget)
45%  Must do (wgetv symval <expr>) in CPSL.
46% 4-Dec-84 15:05:34 (Vicki O'Day)
47%  Added binaryopenupdate.
48% 26-Sep-84 13:41:32 (Vicki O'Day)
49%  Added binaryopenappend for use with Nmail.
50% 27-Jul-84 (Vicki O'Day)
51%  Added redefinition of binaryopenread, so if it fails it can call
52%  conterror instead of kernel-fatal-error.
53% 10-Jul-84 13:35:24 (RAM)
54%  Replaced call to fopen with call to unixopen.  Unixopen will expand
55%  shell variables (and some other fancy stuff).
56% 2-Jul-84 (Vicki O'Day)
57%  Removed functions in kernel.
58% 27-Feb-84 17:00:24 (RAM)
59%  Changed File and Title entries in header.
60%  Added flagging as foreignfunction of fopen, fclose, putw,
61%  fread, fwrite, fseek.
62% 2-Dec-83  16:00:00 (Brian Beach)
63%   Translated from Rlisp to Lisp.
64%
65%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
66%
67
68(compiletime (load fasl-decls sys-consts sys-macros io-decls))
69
70(fluid '(argumentblock))
71
72(compiletime (put 'put_a_halfword 'opencode '(
73   (mov (reg ebx) (displacement (reg eax) 0))))))
74
75(de depositvaluecelllocation (x)
76  (if (not *writingfaslfile)
77    (progn (put_a_halfword (iplus2 codebase* currentoffset*)
78                 (iplus2 symval (itimes2 8 (idinf x))))
79           (setf currentoffset* (iplus2 currentoffset* 4)))
80    (progn (put_a_halfword (iplus2 codebase* currentoffset*)
81                 (makerelocword reloc-value-cell (findidnumber x)))
82           (setf currentoffset* (iplus2 currentoffset* 4))
83           (updatebittable 4 reloc-word))))
84
85(de depositextrareglocation (x)
86  (if (not *writingfaslfile)
87    (progn (put_a_halfword (iplus2 codebase* currentoffset*)
88                 (loc (wgetv argumentblock
89                       (wdifference x (wplus2 maxrealregs 1)))))
90           (setf currentoffset* (iplus2 currentoffset* 4)))
91    (progn (put_a_halfword (iplus2 codebase* currentoffset*)
92                 (makerelocword reloc-value-cell (wplus2 x 8150)))
93           (setf currentoffset* (iplus2 currentoffset* 4))
94           (updatebittable 4 reloc-word))))
95
96(de depositfunctioncelllocation (x)
97  (if (not *writingfaslfile)
98    (progn (put_a_halfword (iplus2 codebase* currentoffset*)
99                 (iplus2 symfnc (itimes2 8 (idinf x))))
100           (setf currentoffset* (iplus2 currentoffset* 4)))
101    (progn (put_a_halfword (iplus2 codebase* currentoffset*)
102                 (makerelocword reloc-function-cell
103                  (findidnumber x)))
104           (setf currentoffset* (iplus2 currentoffset* 4))
105           (updatebittable 4 reloc-word))))
106
107
108
109(declare-wstring openreadflag initially "r")
110(declare-wstring openwriteflag initially "w")
111(declare-wstring openappendflag initially "a")
112(declare-wstring openupdateflag initially "r+")
113
114
115% binaryopenread, binaryread, binaryreadblock and binaryclose
116% are in the kernel, but binaryopenread needs to be redefined
117% here so conterror instead of kernel-fatal-error will be called.
118
119(de binaryopenread (filename)
120  (let ((f (unixopen (strbase (strinf filename))
121                 (strbase (strinf openreadflag)))))
122        (if (weq f 0)
123                  (conterror 99 "Couldn't open binary file for input"
124                   (binaryopenread filename))
125                  f)))
126
127(de binaryopenwrite (filename)
128  (prog (f)
129        (setq f
130              (unixopen (strbase (inf filename))
131                     (strbase (strinf openwriteflag))))
132        (return (if (weq f 0)
133                  (conterror 99 "Couldn't open binary file for output"
134                   (binaryopenwrite filename))
135                  f))))
136
137(de binaryopenappend (filename)
138  (prog (f)
139        (setq f
140              (unixopen (strbase (strinf filename))
141                     (strbase (strinf openappendflag))))
142        (return (if (weq f 0)
143                  (conterror 99 "Couldn't open binary file for append"
144                   (binaryopenappend filename))
145                  f))))
146
147(de binaryopenupdate (filename)
148  (prog (f)
149        (setq f
150              (unixopen (strbase (strinf filename))
151                     (strbase (strinf openupdateflag))))
152        (return (if (weq f 0)
153                  (conterror 99 "Couldn't open binary file for update"
154                   (binaryopenupdate filename))
155                  f))))
156
157(de binarywrite (channel n)
158	(putw (wshift (wshift n 32) -32) channel)
159	(putw (wshift n -32) channel)) % little endian
160
161(de binarywriteblock (channel blockbase blocksize)
162  (fwrite blockbase 8 blocksize channel))
163
164(de binarypositionfile (channel nastysystemdependentnumber)
165  (fseek channel nastysystemdependentnumber 0))
166