1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PXNK:SYSTEM-EXTRAS.SL 4% Title: HPUX Unix specific code for PSL 5% Author: Eric Benson 6% Created: 9 October 1981 7% Modified: 2-Jan-85 (Vicki O'Day) 8% Package: Kernel 9% 10% (c) Copyright 1982, University of Utah 11% 12% Redistribution and use in source and binary forms, with or without 13% modification, are permitted provided that the following conditions are met: 14% 15% * Redistributions of source code must retain the relevant copyright 16% notice, this list of conditions and the following disclaimer. 17% * Redistributions in binary form must reproduce the above copyright 18% notice, this list of conditions and the following disclaimer in the 19% documentation and/or other materials provided with the distribution. 20% 21% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 23% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 24% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 25% CONTRIBUTORS 26% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 27% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 28% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 29% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 30% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 31% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32% POSSIBILITY OF SUCH DAMAGE. 33 34% 35%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 36% 37% Revisions: 38% 39% 25-Aug-87 (Leigh Stoller) 40% Added definition of external-allocatemorebps to map to allocatemorebps. 41% Vax nameing convention fix. 42% 29-May-87 (Leigh Stoller & Harold Carr) 43% Added setenv function. 44% 28-May-87 (Leigh Stoller & Harold Carr) 45% Added unix-time function for pcls. 46% 02-Sep-86 (Harold Carr) 47% Made QUIT call exit-with-status with 0 instead of doing a 48% (throw 'reset 'quit). (throw 'reset 'quit) makes it impossible to 49% make special PSLs with initcode to do some work and then call 50% (exitlisp) or (quit). The initcode is evaluated before the reset 51% tag is in place. 52% 01-Sep-86 (Leigh Stoller) 53% Modified the system function to call an external C routine that does 54% makes the actual call to system and returns the value. 55% 19-Aug-86 (Leigh Stoller) 56% Added the filestatus function. 57% 03-Aug-86 (Leigh Stoller) 58% Modified the quit function so that it looks at the break loop level to 59% determine if a nonzero status should be returned to the OS. 60% 2-Jan-85 (Vicki O'Day) 61% Now that system signal-handler frames are popped from the stack, deref 62% isn't necessary, so it was removed. 63% 21-Dec-84 (Vicki O'Day) 64% Added new check to returnaddressp: it now calls a function "deref", 65% which invokes the C routine "dereference" to find out if dereferencing 66% an address is safe. 67% 14-Nov-84 (Vicki O'Day) 68% Changed returnaddressp to check for address >= 2000, to account 69% for HP-UX mapping above ROM. 70% 17-Jul-84 23:13:12 (RAM) 71% Removed coredump routines because they kept getting in the way. 72% Changed call to chdir to a call on unixcd, to incorporate expand_file_name. 73% 12 June 84 (Vicki O'Day) 74% Added routines to turn coredumps on and off, with the help of 75% a super-user owned "createcore" program. 76% 11-May-84 10:00:00 (Vicki O'Day) 77% Changed system to call nof_system, a no-fork version. 78% This is part of Bill Watkins' escape-to-shell mechanism. 79% 27-Feb-84 16:52:12 (RAM) 80% Pathin the appropriate files for HPUX200. 81% Set system_list* to reasonable HPUX200 default. 82% Modified quit, exitlisp, and returnaddressp to do right things. 83% Added system function, like elsewhere on VAX version. 84% Changed all references to _filepointerofchannel to channeltable. 85% Changed call to byte in importforeignstring to getbyte since byte not 86% defined yet. 87% Fixed some bugs in getstartupname. 88% 2-Dec-83 16:00:00 (Brian Beach) 89% Translated from Rlisp to Lisp. 90% 91%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 92 93% 94% $pv/system-extras.red, Tue Nov 23 16:43:32 1982, Edit by fish 95% Added getUnixArgs and getStartupName, factored out importForeignString. 96% $pv/system-extras.red, Nov 1 12:41:36 1982, Edit by fish 97% Added cd, pwd, channelFlush. 98% <PSL.KERNEL-VAX>SYSTEM-EXTRAS.RED.5, 22-Sep-82 10:57:37, Edit by BENSON 99% Added user-homedir-string and getenv to end of file 100% $pi/system-extras.red, Aug 11 07:19:06 1982, Edit by fish 101% Added flushStdOutputBuffer for Emode. 102 103(compiletime (load sys-consts sys-macros)) 104 105(on fast-integers) 106 107% Import Unix argument vector as a vector of strings. 108(initcode) 109(fluid '(unixargs*)) 110 111%(de quit () 112% (errorprintf "%f%nQuitting") 113% (throw 'reset 'quit)) 114% 115% Quit know looks at the break loop level to determine if we are exiting 116% with a truly 0 status. If breaklevel* is > 0, then something is wrong, and 117% we should return some other value besides the default zero status. /LBS 118 119(de quit () 120 (errorprintf "%f%nQuitting") 121 (cond 122 ((greaterp breaklevel* 0) 123 (exit-with-status -1)) 124 (t 125 (exit-with-status 0)))) 126 127(de exitlisp () 128 (quit)) 129 130(de system (unixstring) 131 (if (stringp unixstring) 132 (ashift (wshift (external_system (strbase (strinf unixstring))) 133 32 ) -32) % sign extended 134 (nonstringerror unixstring 'system))) 135 136 137(declare-warray filestatus-work size 13) 138 139(de filestatus (filenamestring dostrings) 140 (let ((status (get_file_status 141 (expand_file_name (unixstring filenamestring)) 142 filestatus-work 143 (if dostrings 1 0)))) 144 (when (weq status 0) % 0 = success 145 (for (from i 0 12 2) 146 (in label '(user group mode size writetime accesstime 147 statuschangetime)) 148 (collect (cons label 149 (cons 150 (importforeignstring (wgetv filestatus-work i)) 151 (sys2int (wgetv filestatus-work (+ i 1)))))) 152 )))) 153 154 155% Inf is used heavily here just to mask off the high order byte. 156% 9836 assembler and linker generate addresses with high order 157% byte value -1. PSL tends to generate addresses with high order 158% byte 0. On 9836 these are equivalent, but we must mask them 159% off. Comparing X against NextBps helps assure it points to 160% code, but more importantly assures it points to existing 161% memory. /csp 162 163(compiletime (put 'get_a_halfword 'opencode '( 164 (*move (reg 1) (reg 2)) 165 (*wxor (reg 1) (reg 1)) 166 (mov (displacement (reg ebx) 0) (reg eax))))) 167 168(de returnaddressp (x) 169 (prog (s y) 170 (unless (and (intp x) (wgreaterp x 200000)) (return nil)) 171 % Actually, top bits must 172 % be 0 or -1 due to 173 % 9836 assembler, linker 174% (when (weq (wand x 1) 1) (return nil)) 175 % if OddP X 176 (setq x (inf x)) 177 (when (wlessp x 8198) 178 (return nil)) 179 (cond ((not (wlessp x nextbps)) % Assures X points to real memory 180 (return nil))) 181 (setq s (inf symfnc)) 182%%% (unless (weq (halfword x -3) 16#15ff) (return nil)) 183 % call longword 184 (setq y (inf (get_a_halfword (wplus2 x -4)))) 185 (setq y (wdifference y s)) 186 (setq y (wquotient y addressingunitsperfunctioncell)) 187 (if (or (wlessp y 0) (wgreaterp y maxsymbols)) 188 (return nil) 189 (return (mkid y))))) 190 191% **************************************************************** 192% EMODE terminal control functions, passed through to C code. 193% To allow same names as C routines. 194 195(fluid '(channeltable)) 196 197(de charsininputbuffer () 198 % Returns nbr of input chars waiting. 199 (external_charsininputbuffer (wgetv channeltable 0))) 200 201(de channelflush (chnl) 202 % Flush any channel. 203 (fflush (wgetv channeltable chnl))) 204 205% **************************************************************** 206% String-oriented Unix interface functions. 207 208% Copy and tag a Lisp string, given a C string pointer. 209(de importforeignstring (c_s) 210 (prog (new_s len) 211 (when (weq c_s 0) 212 (return nil)) 213 % Not a string, pass it on. 214 (setq len (wdifference (external_strlen c_s) 1)) 215 (setq new_s (gtstr len)) 216 (for (from i 0 len 1) 217 (do (setf (strbyt new_s i) (r_byte c_s i)))) 218 (return (mkstr new_s)))) 219 220(de external-allocatemorebps () 221 (allocatemorebps)) 222 223(de init-file-string (program-name) 224 % Build init file name. 225 (bldmsg "%w.%wrc" (user-homedir-string) program-name)) 226 227(de user-homedir-string () 228 (concat (importforeignstring (external_user_homedir_string)) "/")) 229 230(de anyuser-homedir-string (username) 231 (if (stringp username) 232 (concat (importforeignstring 233 (external_anyuser_homedir_string (strbase (strinf username)))) 234 "/") 235 (nonstringerror username 'anyuser-homedir-string))) 236 237(de getenv (s) 238 % String from environment, or NIL. 239 (prog nil 240 (unless (stringp s) 241 (return nil)) 242 (return (importforeignstring (external_getenv (strbase (strinf s))))))) 243 244(de setenv (var val) 245 (cond ((not (stringp var)) 246 (nonstringerror var 'setenv)) 247 ((not (stringp val)) 248 (nonstringerror val 'setenv)) 249 (t 250 (external_setenv (strbase (strinf var)) (strbase (strinf val))) 251 NIL))) 252 253(de cd (s) % Set current working directory. 254 (when (stringp s) 255 (weq 0 (unixcd (strbase (strinf s)))))) % 0 is success. 256 257(de pwd () % Return current working directory. 258 (importforeignstring (external_pwd))) 259 260(dm vecbase (u) % Missing, along with wrdBase. 261 (list 'wplus2 (cadr u) 8)) 262 263% Fluid to stash the arg vector. 264(fluid '(argc argv)) 265(de getunixargs () % (argc argv) 266 (prog (sz v) 267 (setq sz (wdifference argc 1)) 268 (setq v (vecbase (strinf (setf unixargs* (mkvect sz))))) 269 (for (from i 0 sz 1) 270 (do (setf (wgetv v i) (importforeignstring (wgetv argv i))))))) 271 272(loadtime (getunixargs)) 273 274% getStartupName - Figure out the filename that PSL was started from. 275(de getstartupname () 276 (prog (arg0 path pathsz dirstart i dir filename) 277 (if (null unixargs*) 278 (getunixargs)) 279 % Just the 0th unix arg, if it is a full path starting with /. 280 (setq arg0 (indx unixargs* 0)) 281 (when (setq filename 282 (progn (for (from i 0 (size arg0) 1) 283 (do (when (eq (indx arg0 i) (char '/)) 284 (return arg0)))))) 285 (return filename)) 286 % Otherwise, have to look along the PATH environment var for directory. 287 288 (setq path (concat (getenv "PATH") ":")) 289 (setq pathsz (size path)) 290 (setq dirstart 0) 291 (setq i 0) 292 (repeat (progn (cond ((eq (indx path i) (char ':)) % Dir strings are separated by colons. 293 294 (progn (setq dir 295 (concat 296 (sub path dirstart 297 (difference 298 (difference i dirstart) 1)) 299 "/")) 300 (when (or (equal dir "./") 301 (equal dir "/")) 302 (setq dir (pwd))) 303 (when (equal dir "//") 304 (setq dir "/")) 305 % Dot is current directory. 306 (setq filename (concat dir arg0)) 307 % Build a name. 308 (unless (filep filename) 309 (setq filename nil)) 310 % Keep going if not found there. 311 (setq dirstart (plus i 1))))) 312 % Next one starts after colon. 313 (setq i (plus i 1))) 314 (or filename (greaterp i pathsz))) 315 (return filename))) 316 317(de unix-time () 318 (sys2int (external_time 0))) 319 320% misusing ieeeflags!! 321 322(de flock (a1 a2) 323 (ieee_flags 1 a1 a2)) 324 325(de fcntl (a1 a2 a3) 326 (ieee_flags 2 a1 a2 a3)) 327 328(de Linux_read (a1 a2 a3) % all following expect an int fd 329 (ieee_flags 5 a1 (strbase (strinf a2)) a3)) 330 331(de Linux_write (a1 a2 a3) 332 (ieee_flags 6 a1 (strbase (strinf a2)) a3)) 333 334(de lseek (a1 a2 a3) 335 (ieee_flags 7 a1 (strbase (strinf a2)) a3)) 336 337(de Linux_open(a1 a2 a3) % uses open in Linux sense, returns an int fd 338 (ashift (wshift (ieee_flags 3 (strbase (strinf a1)) a2 a3) 339 32 ) -32)) % sign extended 340 341(de Linux_close(a1) % expects an int fd 342 (ieee_flags 4 a1)) 343 344(define-constant O_ACCMODE 8#003 ) 345(define-constant O_RDONLY 8#0 ) 346(define-constant O_WRONLY 8#1 ) 347(define-constant O_RDWR 8#2 ) 348(define-constant O_CREAT 8#100 ) 349(define-constant O_EXCL 8#200 ) 350(define-constant O_NOCTTY 8#400 ) 351(define-constant O_TRUNC 8#1000 ) 352(define-constant O_APPEND 8#2000 ) 353(define-constant O_NONBLOCK 8#4000 ) 354(define-constant O_NDELAY O_NONBLOCK ) 355(define-constant O_SYNC 8#10000 ) 356 357(define-constant LOCK_SH 1 )% /* Shared lock. */ 358(define-constant LOCK_EX 2 ) % /* Exclusive lock. */ 359(define-constant LOCK_UN 8 ) % /* Unlock. */ 360 361%%%%% /* Can be OR'd in to one of the above. */ 362(define-constant LOCK_NB 4 )% /* Don't block when locking. */ 363 364(define-constant F_GETLK 5)% /* Get record locking info. */ 365(define-constant F_SETLK 6)% /* Set record locking info (non-blocking). */ 366(define-constant F_SETLKW 7)% /* Set record locking info (blocking). */ 367 368 369(off fast-integers) 370 371%% End of File. 372