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