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