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(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 (external_system (strbase (mkfixn unixstring))) 132 (nonstringerror unixstring 'system))) 133 134(de delete-file (unixstring) 135 (if (stringp unixstring) 136 (weq 0 (external_unlink (strbase (strinf unixstring)))) 137 (nonstringerror unixstring 'delete-file))) 138 139 140(declare-warray filestatus-work size 13) 141 142(de filestatus (filenamestring dostrings) 143 (let ((status (get_file_status 144 (expand_file_name (unixstring filenamestring)) 145 filestatus-work 146 (if dostrings 1 0)))) 147 (when (weq status 0) % 0 = success 148 (for (from i 0 12 2) 149 (in label '(user group mode size writetime accesstime 150 statuschangetime)) 151 (collect (cons label 152 (cons 153 (importforeignstring (wgetv filestatus-work i)) 154 (sys2int (wgetv filestatus-work (+ i 1)))))) 155 )))) 156 157 158% Inf is used heavily here just to mask off the high order byte. 159% 9836 assembler and linker generate addresses with high order 160% byte value -1. PSL tends to generate addresses with high order 161% byte 0. On 9836 these are equivalent, but we must mask them 162% off. Comparing X against NextBps helps assure it points to 163% code, but more importantly assures it points to existing 164% memory. /csp 165 166 167(de returnaddressp (x) 168 (prog (s y) 169 (unless (and (fixnp x) (>= x 2000)) (return nil)) 170 % Actually, top bits must 171 % be 0 or -1 due to 172 % 9836 assembler, linker 173 (when (weq (wand x 1) 1) 174 (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 (wgetv x -1))) 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 (mkfixn 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 (mkfixn 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 (mkfixn var)) (strbase (mkfixn val))) 251 NIL))) 252 253(de cd (s) % Set current working directory. 254 (when (stringp s) 255 (weq 0 (unixcd (strbase (mkfixn 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) 4)) 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 (mkfixn (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(de get-image-path () 275 (prog (val) 276 (setq val (get_imagefilepath)) 277 (cond ((eq val 0) (return nil)) 278 (t (return (importforeignstring val)))))) 279 280(de get-exec-path () 281 (prog (val) 282 (setq val (get_execfilepath)) 283 (cond ((eq val 0) (return nil)) 284 (t (return (importforeignstring val)))))) 285 286(de get-fullpath (relpath) 287 (prog (val) 288 (setq val (external_fullpath (unixstring relpath))) 289 (cond ((eq val 0) (return nil)) 290 (t (return (importforeignstring val)))))) 291 292 293% getStartupName - Figure out the filename that PSL was started from. 294(de getstartupname () 295 (prog (arg0 path pathsz dirstart i dir filename) 296 (if (null unixargs*) 297 (getunixargs)) 298 % Just the 0th unix arg, if it is a full path starting with /. 299 (setq arg0 (indx unixargs* 0)) 300 (when (setq filename 301 (progn (for (from i 0 (size arg0) 1) 302 (do (when (eq (indx arg0 i) (char '/)) 303 (return arg0)))))) 304 (return filename)) 305 % Otherwise, have to look along the PATH environment var for directory. 306 307 (setq path (concat (getenv "PATH") ":")) 308 (setq pathsz (size path)) 309 (setq dirstart 0) 310 (setq i 0) 311 (repeat (progn (cond ((eq (indx path i) (char ':)) % Dir strings are separated by colons. 312 313 (progn (setq dir 314 (concat 315 (sub path dirstart 316 (difference 317 (difference i dirstart) 1)) 318 "/")) 319 (when (or (equal dir "./") 320 (equal dir "/")) 321 (setq dir (pwd))) 322 (when (equal dir "//") 323 (setq dir "/")) 324 % Dot is current directory. 325 (setq filename (concat dir arg0)) 326 % Build a name. 327 (unless (filep filename) 328 (setq filename nil)) 329 % Keep going if not found there. 330 (setq dirstart (plus i 1))))) 331 % Next one starts after colon. 332 (setq i (plus i 1))) 333 (or filename (greaterp i pathsz))) 334 (return filename))) 335 336(de unix-time () 337 (sys2int (external_time 0))) 338 339% misusing ieeeflags!! 340 341(de flock (a1 a2) 342 (ieee_flags 1 a1 a2)) 343 344(de fcntl (a1 a2 a3) 345 (ieee_flags 2 a1 a2 a3)) 346 347(de Linux_open(a1 a2 a3) % uses open in Linux sense, returns an int fd 348 (ieee_flags 3 (strbase (strinf a1)) a2 a3)) 349 350(de Linux_close(a1) % exptects an int fd 351 (ieee_flags 4 a1)) 352 353(define-constant O_ACCMODE 8#003 ) 354(define-constant O_RDONLY 8#0 ) 355(define-constant O_WRONLY 8#1 ) 356(define-constant O_RDWR 8#2 ) 357(define-constant O_CREAT 8#100 ) 358(define-constant O_EXCL 8#200 ) 359(define-constant O_NOCTTY 8#400 ) 360(define-constant O_TRUNC 8#1000 ) 361(define-constant O_APPEND 8#2000 ) 362(define-constant O_NONBLOCK 8#4000 ) 363(define-constant O_NDELAY O_NONBLOCK ) 364(define-constant O_SYNC 8#10000 ) 365 366(define-constant LOCK_SH 1 )% /* Shared lock. */ 367(define-constant LOCK_EX 2 ) % /* Exclusive lock. */ 368(define-constant LOCK_UN 8 ) % /* Unlock. */ 369 370%%%%% /* Can be OR'd in to one of the above. */ 371(define-constant LOCK_NB 4 )% /* Don't block when locking. */ 372 373(define-constant F_GETLK 5)% /* Get record locking info. */ 374(define-constant F_SETLK 6)% /* Set record locking info (non-blocking). */ 375(define-constant F_SETLKW 7)% /* Set record locking info (blocking). */ 376 377(off fast-integers) 378 379%% End of File. 380