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