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