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:         Experimental
10% Mode:           Lisp
11% Package:        Kernel
12%
13% (c) Copyright 1983,  Hewlett-Packard Company, all rights reserved.
14% Copyright (c) 1982 University of Utah
15%
16%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
17%
18% Revisions:
19%
20% 10-Dec-90 (Winfried Neun)
21% removed (strinf  for IBM RS 6000.
22% 06-Apr-88 (Julian Padget)
23%  Must do (wgetv symval <expr>) in CPSL.
24% 4-Dec-84 15:05:34 (Vicki O'Day)
25%  Added binaryopenupdate.
26% 26-Sep-84 13:41:32 (Vicki O'Day)
27%  Added binaryopenappend for use with Nmail.
28% 27-Jul-84 (Vicki O'Day)
29%  Added redefinition of binaryopenread, so if it fails it can call
30%  conterror instead of kernel-fatal-error.
31% 10-Jul-84 13:35:24 (RAM)
32%  Replaced call to fopen with call to unixopen.  Unixopen will expand
33%  shell variables (and some other fancy stuff).
34% 2-Jul-84 (Vicki O'Day)
35%  Removed functions in kernel.
36% 27-Feb-84 17:00:24 (RAM)
37%  Changed File and Title entries in header.
38%  Added flagging as foreignfunction of fopen, fclose, putw,
39%  fread, fwrite, fseek.
40% 2-Dec-83  16:00:00 (Brian Beach)
41%   Translated from Rlisp to Lisp.
42%
43%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
44%
45
46(compiletime (load fasl-decls sys-consts sys-macros io-decls))
47
48(fluid '(argumentblock))
49
50(de depositvaluecelllocation (x)
51  (if (not *writingfaslfile)
52    (progn (setf (getmem (iplus2 codebase* currentoffset*))
53                 (loc (wgetv symval (idinf x))))
54           (setf currentoffset* (iplus2 currentoffset* 4)))
55    (progn (setf (getmem (iplus2 codebase* currentoffset*))
56                 (makerelocword reloc-value-cell (findidnumber x)))
57           (setf currentoffset* (iplus2 currentoffset* 4))
58           (updatebittable 4 reloc-word))))
59
60(de depositextrareglocation (x)
61  (if (not *writingfaslfile)
62    (progn (setf (getmem (iplus2 codebase* currentoffset*))
63                 (loc (wgetv argumentblock
64                       (wdifference x (wplus2 maxrealregs 1)))))
65           (setf currentoffset* (iplus2 currentoffset* 4)))
66    (progn (setf (getmem (iplus2 codebase* currentoffset*))
67                 (makerelocword reloc-value-cell (wplus2 x 8150)))
68           (setf currentoffset* (iplus2 currentoffset* 4))
69           (updatebittable 4 reloc-word))))
70
71(de depositfunctioncelllocation (x)
72  (if (not *writingfaslfile)
73    (progn (setf (getmem (iplus2 codebase* currentoffset*))
74                 (iplus2 symfnc (itimes2 6 (idinf x))))
75           (setf currentoffset* (iplus2 currentoffset* 4)))
76    (progn (setf (getmem (iplus2 codebase* currentoffset*))
77                 (makerelocword reloc-function-cell
78                  (findidnumber x)))
79           (setf currentoffset* (iplus2 currentoffset* 4))
80           (updatebittable 4 reloc-word))))
81
82
83
84(declare-wstring openreadflag initially "r")
85(declare-wstring openwriteflag initially "w")
86(declare-wstring openappendflag initially "a")
87(declare-wstring openupdateflag initially "r+")
88
89
90% binaryopenread, binaryread, binaryreadblock and binaryclose
91% are in the kernel, but binaryopenread needs to be redefined
92% here so conterror instead of kernel-fatal-error will be called.
93
94(de binaryopenread (filename)
95  (prog (f)
96        (setq f
97              (unixopen (strbase (strinf filename))
98			 (strbase (strinf openreadflag))))
99        (return (if (weq f 0)
100                  (conterror 99 "Couldn't open binary file for input"
101                   (binaryopenread filename))
102                  f))))
103
104(de binaryopenwrite (filename)
105  (prog (f)
106        (setq f
107              (unixopen (strbase (strinf filename))
108			(strinf (strbase openwriteflag))))
109        (return (if (weq f 0)
110                  (conterror 99 "Couldn't open binary file for output"
111                   (binaryopenwrite filename))
112                  f))))
113
114(de binaryopenappend (filename)
115  (prog (f)
116        (setq f
117              (unixopen (strinf (strbase filename))
118			(strinf  (strbase openappendflag))))
119        (return (if (weq f 0)
120                  (conterror 99 "Couldn't open binary file for append"
121                   (binaryopenappend filename))
122                  f))))
123
124(de binaryopenupdate (filename)
125  (prog (f)
126        (setq f
127              (unixopen (strinf (strbase filename))
128                        (strinf  (strbase openupdateflag))))
129        (return (if (weq f 0)
130                  (conterror 99 "Couldn't open binary file for update"
131                   (binaryopenupdate filename))
132                  f))))
133
134(de binarywrite (channel n)
135  (putw n channel))
136
137(de binarywriteblock (channel blockbase blocksize)
138  (fwrite blockbase 4 blocksize channel))
139
140(de binarypositionfile (channel nastysystemdependentnumber)
141  (fseek channel nastysystemdependentnumber 0))
142
143
144
145
146
147
148