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% Status: Open Source: BSD License 10% 11% (c) Copyright 1982, University of Utah 12% 13% Redistribution and use in source and binary forms, with or without 14% modification, are permitted provided that the following conditions are met: 15% 16% * Redistributions of source code must retain the relevant copyright 17% notice, this list of conditions and the following disclaimer. 18% * Redistributions in binary form must reproduce the above copyright 19% notice, this list of conditions and the following disclaimer in the 20% documentation and/or other materials provided with the distribution. 21% 22% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 23% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 24% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 25% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 26% CONTRIBUTORS 27% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 28% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 29% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 30% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 31% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 32% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33% POSSIBILITY OF SUCH DAMAGE. 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(de delete-file (unixstring) 137 (if (stringp unixstring) 138 (weq 0 (external_unlink (strbase (strinf unixstring)))) 139 (nonstringerror unixstring 'delete-file))) 140 141 142(declare-warray filestatus-work size 13) 143 144(de filestatus (filenamestring dostrings) 145 (let ((status (get_file_status 146 (expand_file_name (unixstring filenamestring)) 147 filestatus-work 148 (if dostrings 1 0)))) 149 (when (weq status 0) % 0 = success 150 (for (from i 0 12 2) 151 (in label '(user group mode size writetime accesstime 152 statuschangetime)) 153 (collect (cons label 154 (cons 155 (importforeignstring (wgetv filestatus-work i)) 156 (sys2int (wgetv filestatus-work (+ i 1)))))) 157 )))) 158 159 160% Inf is used heavily here just to mask off the high order byte. 161% 9836 assembler and linker generate addresses with high order 162% byte value -1. PSL tends to generate addresses with high order 163% byte 0. On 9836 these are equivalent, but we must mask them 164% off. Comparing X against NextBps helps assure it points to 165% code, but more importantly assures it points to existing 166% memory. /csp 167 168(compiletime (put 'get_a_halfword 'opencode '( 169 (*move (reg 1) (reg 2)) 170 (*wxor (reg 1) (reg 1)) 171 (mov (displacement (reg ebx) 0) (reg eax))))) 172 173(de returnaddressp (x) 174 (prog (s y) 175 (unless (and (intp x) (wgreaterp x 16#400000)) (return nil)) 176 % Actually, top bits must 177 % be 0 or -1 due to 178 % 9836 assembler, linker 179% (when (weq (wand x 1) 1) (return nil)) 180 % if OddP X 181 (when (not (codeaddressp x)) 182 (return nil)) 183 (setq x (inf x)) 184% (cond ((not (wlessp x nextbps)) % Assures X points to real memory 185% (return nil))) 186 (setq s (inf symfnc)) 187%%% (unless (weq (halfword x -3) 16#15ff) (return nil)) 188 % call longword 189 (setq y (inf (get_a_halfword (wplus2 x -4)))) 190 (setq y (wdifference y s)) 191 (setq y (wquotient y addressingunitsperfunctioncell)) 192 (if (or (wlessp y 0) (wgreaterp y maxsymbols)) 193 (return nil) 194 (return (mkid y))))) 195 196% **************************************************************** 197% EMODE terminal control functions, passed through to C code. 198% To allow same names as C routines. 199 200(fluid '(channeltable)) 201 202(de charsininputbuffer () 203 % Returns nbr of input chars waiting. 204 (external_charsininputbuffer (wgetv channeltable 0))) 205 206(de channelflush (chnl) 207 % Flush any channel. 208 (fflush (wgetv channeltable chnl))) 209 210% **************************************************************** 211% String-oriented Unix interface functions. 212 213% Copy and tag a Lisp string, given a C string pointer. 214(de importforeignstring (c_s) 215 (prog (new_s len) 216 (when (weq c_s 0) 217 (return nil)) 218 % Not a string, pass it on. 219 (setq len (wdifference (external_strlen c_s) 1)) 220 (setq new_s (gtstr len)) 221 (for (from i 0 len 1) 222 (do (setf (strbyt new_s i) (r_byte c_s i)))) 223 (return (mkstr new_s)))) 224 225(de external-allocatemorebps () 226 (allocatemorebps)) 227 228(de init-file-string (program-name) 229 % Build init file name. 230 (bldmsg "%w.%wrc" (user-homedir-string) program-name)) 231 232(de user-homedir-string () 233 (concat (importforeignstring (external_user_homedir_string)) "/")) 234 235(de anyuser-homedir-string (username) 236 (if (stringp username) 237 (concat (importforeignstring 238 (external_anyuser_homedir_string (strbase (strinf username)))) 239 "/") 240 (nonstringerror username 'anyuser-homedir-string))) 241 242(de getenv (s) 243 % String from environment, or NIL. 244 (prog nil 245 (unless (stringp s) 246 (return nil)) 247 (return (importforeignstring (external_getenv (strbase (strinf s))))))) 248 249(de setenv (var val) 250 (cond ((not (stringp var)) 251 (nonstringerror var 'setenv)) 252 ((not (stringp val)) 253 (nonstringerror val 'setenv)) 254 (t 255 (external_setenv (strbase (strinf var)) (strbase (strinf val))) 256 NIL))) 257 258(de cd (s) % Set current working directory. 259 (when (stringp s) 260 (weq 0 (unixcd (strbase (strinf s)))))) % 0 is success. 261 262(de pwd () % Return current working directory. 263 (importforeignstring (external_pwd))) 264 265(dm vecbase (u) % Missing, along with wrdBase. 266 (list 'wplus2 (cadr u) 8)) 267 268% Fluid to stash the arg vector. 269(fluid '(argc argv)) 270(de getunixargs () % (argc argv) 271 (prog (sz v) 272 (setq sz (wdifference argc 1)) 273 (setq v (vecbase (strinf (setf unixargs* (mkvect sz))))) 274 (for (from i 0 sz 1) 275 (do (setf (wgetv v i) (importforeignstring (wgetv argv i))))))) 276 277(loadtime (getunixargs)) 278 279(de get-image-path () 280 (prog (val) 281 (setq val (get_imagefilepath)) 282 (cond ((eq val 0) (return nil)) 283 (t (return (importforeignstring val)))))) 284 285(de get-exec-path () 286 (prog (val) 287 (setq val (get_execfilepath)) 288 (cond ((eq val 0) (return nil)) 289 (t (return (importforeignstring val)))))) 290 291(de get-fullpath (relpath) 292 (prog (val) 293 (setq val (external_fullpath (strbase (strinf relpath)))) 294 (cond ((eq val 0) (return nil)) 295 (t (return (importforeignstring val)))))) 296 297 298% getStartupName - Figure out the filename that PSL was started from. 299(de getstartupname () 300 (prog (arg0 path pathsz dirstart i dir filename) 301 (if (null unixargs*) 302 (getunixargs)) 303 % Just the 0th unix arg, if it is a full path starting with /. 304 (setq arg0 (indx unixargs* 0)) 305 (when (setq filename 306 (progn (for (from i 0 (size arg0) 1) 307 (do (when (eq (indx arg0 i) (char '/)) 308 (return arg0)))))) 309 (return filename)) 310 % Otherwise, have to look along the PATH environment var for directory. 311 312 (setq path (concat (getenv "PATH") ":")) 313 (setq pathsz (size path)) 314 (setq dirstart 0) 315 (setq i 0) 316 (repeat (progn (cond ((eq (indx path i) (char ':)) % Dir strings are separated by colons. 317 318 (progn (setq dir 319 (concat 320 (sub path dirstart 321 (difference 322 (difference i dirstart) 1)) 323 "/")) 324 (when (or (equal dir "./") 325 (equal dir "/")) 326 (setq dir (pwd))) 327 (when (equal dir "//") 328 (setq dir "/")) 329 % Dot is current directory. 330 (setq filename (concat dir arg0)) 331 % Build a name. 332 (unless (filep filename) 333 (setq filename nil)) 334 % Keep going if not found there. 335 (setq dirstart (plus i 1))))) 336 % Next one starts after colon. 337 (setq i (plus i 1))) 338 (or filename (greaterp i pathsz))) 339 (return filename))) 340 341(de unix-time () 342 (sys2int (external_time 0))) 343 344% misusing ieeeflags!! 345 346(de flock (a1 a2) 347 (ieee_flags 1 a1 a2)) 348 349(de fcntl (a1 a2 a3) 350 (ieee_flags 2 a1 a2 a3)) 351 352(de Linux_read (a1 a2 a3) % all following expect an int fd 353 (ieee_flags 5 a1 (strbase (strinf a2)) a3)) 354 355(de Linux_write (a1 a2 a3) 356 (ieee_flags 6 a1 (strbase (strinf a2)) a3)) 357 358(de lseek (a1 a2 a3) 359 (ieee_flags 7 a1 (strbase (strinf a2)) a3)) 360 361(de Linux_open(a1 a2 a3) % uses open in Linux sense, returns an int fd 362 (ashift (wshift (ieee_flags 3 (strbase (strinf a1)) a2 a3) 363 32 ) -32)) % sign extended 364 365(de Linux_close(a1) % expects an int fd 366 (ieee_flags 4 a1)) 367 368(define-constant O_ACCMODE 8#003 ) 369(define-constant O_RDONLY 8#0 ) 370(define-constant O_WRONLY 8#1 ) 371(define-constant O_RDWR 8#2 ) 372(define-constant O_CREAT 8#100 ) 373(define-constant O_EXCL 8#200 ) 374(define-constant O_NOCTTY 8#400 ) 375(define-constant O_TRUNC 8#1000 ) 376(define-constant O_APPEND 8#2000 ) 377(define-constant O_NONBLOCK 8#4000 ) 378(define-constant O_NDELAY O_NONBLOCK ) 379(define-constant O_SYNC 8#10000 ) 380 381(define-constant LOCK_SH 1 )% /* Shared lock. */ 382(define-constant LOCK_EX 2 ) % /* Exclusive lock. */ 383(define-constant LOCK_UN 8 ) % /* Unlock. */ 384 385%%%%% /* Can be OR'd in to one of the above. */ 386(define-constant LOCK_NB 4 )% /* Don't block when locking. */ 387 388(define-constant F_GETLK 5)% /* Get record locking info. */ 389(define-constant F_SETLK 6)% /* Set record locking info (non-blocking). */ 390(define-constant F_SETLKW 7)% /* Set record locking info (blocking). */ 391 392 393(off fast-integers) 394 395%% End of File. 396