diff --git a/code/alieneval.lisp b/code/alieneval.lisp index 0628e1d6d21c9bab7615b58ccfa3fa980eb37e27..0f3c668698e0e3b2ac9b56afebf4a16dc0523fe4 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.33 1993/08/26 15:27:02 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.33.1.1 1994/10/19 23:17:11 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -128,6 +128,8 @@ (defun guess-alignment (bits) (cond ((null bits) nil) + #+sparc + ((> bits 32) 64) ((> bits 16) 32) ((> bits 8) 16) ((> bits 1) 8) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index db9216582289f49eddd79a23f89f0088bc6da856..ea3c82c9dacca6756324966f2d58687a4ce9d65e 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.64 1993/11/08 00:22:25 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.64.1.1 1994/10/19 23:18:36 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -367,7 +367,7 @@ ;; ;; Indicates whether someone interrupted frame. (unexported). ;; If escaped, this is a pointer to the state that was saved when we were - ;; interrupted. On the non-gengc system, this is a sigcontext pointer. + ;; interrupted. On the non-gengc system, this is a s-context pointer. ;; On the gengc system, this is a state pointer from saved-state-chain. escaped ;; @@ -1071,20 +1071,20 @@ (declare (type system:system-area-pointer frame-pointer)) (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil)) (alien:with-alien - ((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern)) + ((lisp-interrupt-contexts (array (* unix:s-context) nil) :extern)) (let ((scp (alien:deref lisp-interrupt-contexts index))) (when (= (system:sap-int frame-pointer) - (vm:sigcontext-register scp vm::cfp-offset)) + (vm:s-context-register scp vm::cfp-offset)) (system:without-gcing (let ((code (code-object-from-bits - (vm:sigcontext-register scp vm::code-offset)))) + (vm:s-context-register scp vm::code-offset)))) (when (symbolp code) (return (values code 0 scp))) (let* ((code-header-len (* (kernel:get-header-data code) vm:word-bytes)) (pc-offset (- (system:sap-int - (vm:sigcontext-program-counter scp)) + (vm:s-context-program-counter scp)) (- (kernel:get-lisp-obj-address code) vm:other-pointer-type) code-header-len))) @@ -1099,7 +1099,7 @@ ;; We were in an assembly routine. Therefore, use the LRA as ;; the pc. (setf pc-offset - (- (vm:sigcontext-register scp vm::lra-offset) + (- (vm:s-context-register scp vm::lra-offset) (kernel:get-lisp-obj-address code) code-header-len))) (return @@ -1214,9 +1214,9 @@ ;;; #+gengc (defun extract-info-from-state (state) - (declare (type (alien:alien (* unix:sigcontext)) state) + (declare (type (alien:alien (* unix:s-context)) state) (values debug-function unsigned-byte system:system-area-pointer)) - (let* ((pc (vm:sigcontext-program-counter state)) + (let* ((pc (vm:s-context-program-counter state)) (component-ptr (component-ptr-from-pc pc))) (if (zerop (system:sap-int component-ptr)) ;; We were in one of the trampoline routines or off in the ether. @@ -1237,13 +1237,13 @@ (values (make-bogus-debug-function "Assembler routine.") 0 (system:int-sap - (vm:sigcontext-register state vm::cfp-offset)))) + (vm:s-context-register state vm::cfp-offset)))) (#.vm:trace-table-call-site ;; ### Need to do something real. (values (make-bogus-debug-function "Assembler routine.") 0 (system:int-sap - (vm:sigcontext-register state vm::ocfp-offset)))) + (vm:s-context-register state vm::ocfp-offset)))) (#.vm:trace-table-function-prologue (values (make-bogus-debug-function "Function-Prologue in an assembler routine?") @@ -1264,16 +1264,16 @@ (values (debug-function-from-pc component pc-offset) pc-offset (system:int-sap - (vm:sigcontext-register state vm::cfp-offset)))) + (vm:s-context-register state vm::cfp-offset)))) (#.vm:trace-table-call-site (values (debug-function-from-pc component pc-offset) pc-offset (system:int-sap - (vm:sigcontext-register state vm::ocfp-offset)))) + (vm:s-context-register state vm::ocfp-offset)))) (#.vm:trace-table-function-prologue #+nil ;; ### Need to do something real. (let* ((ra (system:int-sap - (vm:sigcontext-register state vm::ra-offset))) + (vm:s-context-register state vm::ra-offset))) (caller-ptr (component-ptr-from-pc ra))) ...) (values (make-bogus-debug-function @@ -1321,7 +1321,7 @@ (locally (declare (optimize (inhibit-warnings 3))) (alien:sap-alien (car saved-state-chain) - (* unix:sigcontext))))) + (* unix:s-context))))) (multiple-value-bind (dfun pc-offset cfp) (extract-info-from-state state) @@ -2695,14 +2695,14 @@ (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped - (let ((,var (vm:sigcontext-register + (let ((,var (vm:s-context-register escaped (c::sc-offset-offset sc-offset)))) ,@forms) :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) `(if escaped - (vm:sigcontext-float-register + (vm:s-context-float-register escaped (c::sc-offset-offset sc-offset) ',format) @@ -2710,7 +2710,7 @@ (with-nfp ((var) &body body) `(let ((,var (if escaped (system:int-sap - (vm:sigcontext-register escaped + (vm:s-context-register escaped vm::nfp-offset)) (system:sap-ref-sap fp (* vm::nfp-save-offset vm:word-bytes))))) @@ -2824,14 +2824,14 @@ (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped - (setf (vm:sigcontext-register + (setf (vm:s-context-register escaped (c::sc-offset-offset sc-offset)) ,val) value)) (set-escaped-float-value (format val) `(if escaped - (setf (vm:sigcontext-float-register + (setf (vm:s-context-float-register escaped (c::sc-offset-offset sc-offset) ',format) @@ -2840,7 +2840,7 @@ (with-nfp ((var) &body body) `(let ((,var (if escaped (system:int-sap - (vm:sigcontext-register escaped + (vm:s-context-register escaped vm::nfp-offset)) (system:sap-ref-sap fp (* vm::nfp-save-offset @@ -3529,7 +3529,7 @@ (old-inst c-call:unsigned-long)) (alien:def-alien-routine "breakpoint_do_displaced_inst" c-call:void - (scp (* unix:sigcontext)) + (scp (* unix:s-context)) (orig-inst c-call:unsigned-long)) ;;; @@ -3648,7 +3648,7 @@ ;;; HANDLE-FUNCTION-END-BREAKPOINT -- Internal Interface ;;; -(defun handle-function-end-breakpoint (offset component sigcontext) +(defun handle-function-end-breakpoint (offset component s-context) (let ((data (breakpoint-data component offset nil))) (unless data (error "Unknown breakpoint in ~S at offset ~S." @@ -3657,7 +3657,7 @@ (let ((breakpoints (breakpoint-data-breakpoints data))) (when breakpoints (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) - (handle-function-end-breakpoint-aux breakpoints data sigcontext))))) + (handle-function-end-breakpoint-aux breakpoints data s-context))))) ;;; HANDLE-FUNCTION-END-BREAKPOINT-AUX -- Internal. ;;; @@ -3669,8 +3669,8 @@ (let* ((scp (locally (declare (optimize (ext:inhibit-warnings 3))) - (alien:sap-alien signal-context (* unix:sigcontext)))) - (frame (do ((cfp (vm:sigcontext-register scp vm::cfp-offset)) + (alien:sap-alien signal-context (* unix:s-context)))) + (frame (do ((cfp (vm:s-context-register scp vm::cfp-offset)) (f (top-frame) (frame-down f))) ((= cfp (system:sap-int (frame-pointer f))) f) (declare (type (unsigned-byte #.vm:word-bits) cfp)))) @@ -3684,16 +3684,16 @@ cookie)))) (defun get-function-end-breakpoint-values (scp) - (let ((ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset))) + (let ((ocfp (system:int-sap (vm:s-context-register scp vm::ocfp-offset))) (nargs (kernel:make-lisp-obj - (vm:sigcontext-register scp vm::nargs-offset))) + (vm:s-context-register scp vm::nargs-offset))) (reg-arg-offsets '#.vm::register-arg-offsets) (results nil)) (system:without-gcing (dotimes (arg-num nargs) (push (if reg-arg-offsets (kernel:make-lisp-obj - (vm:sigcontext-register scp (pop reg-arg-offsets))) + (vm:s-context-register scp (pop reg-arg-offsets))) (kernel:stack-ref ocfp arg-num)) results))) (nreverse results))) diff --git a/code/exports.lisp b/code/exports.lisp index b2c96b39b553d012fd8092b350de0de4fa49f9e3..848ac162bebe8d07988b291d223cb4158c69e8f9 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.98 1993/11/06 04:32:34 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.98.1.1 1994/10/19 23:20:04 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -181,7 +181,7 @@ "S-IFREG" "S-IFSOCK" "S-IREAD" "S-ISGID" "S-ISUID" "S-ISVTX" "S-IWRITE" "SAVETEXT" "SC-MASK" "SC-ONSTACK" "SC-PC" "SETGIDEXEC" "SETUIDEXEC" "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL" - "SG-OSPEED" "SGTTYB" "SIGCONTEXT" "SIZE-T" "ST-ATIME" "ST-BLKSIZE" + "SG-OSPEED" "SGTTYB" "S-CONTEXT" "SIZE-T" "ST-ATIME" "ST-BLKSIZE" "ST-BLOCKS" "ST-CTIME" "ST-DEV" "ST-GID" "ST-MODE" "ST-MTIME" "ST-NLINK" "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "SWBLK-T" "T-BRKC" "T-DSUSPC" "T-EOFC" "T-FLUSHC" "T-INTRC" "T-LNEXTC" "T-QUITC" @@ -673,8 +673,8 @@ "WEAK-POINTER-BROKEN-SLOT" "WEAK-POINTER-NEXT-SLOT" "WEAK-POINTER-SIZE" "WEAK-POINTER-TYPE" "WEAK-POINTER-VALUE-SLOT" "WORD-BITS" "WORD-BYTES" "WORD-SHIFT" "ZERO-SC-NUMBER" - "SIGCONTEXT-FLOATING-POINT-MODES" "SIGCONTEXT-FLOAT-REGISTER" - "SIGCONTEXT-PROGRAM-COUNTER" "SIGCONTEXT-REGISTER" + "S-CONTEXT-FLOATING-POINT-MODES" "S-CONTEXT-FLOAT-REGISTER" + "S-CONTEXT-PROGRAM-COUNTER" "S-CONTEXT-REGISTER" "EXTERN-ALIEN-NAME" "SANCTIFY-FOR-EXECUTION" "FUNCTION-ARGLIST-SLOT" "INSTANCE-USAGE" diff --git a/code/float-trap.lisp b/code/float-trap.lisp index 093f64ce58e5cdfc771a524389a87a540d2f06cc..0f1cc05ba70afdd6afdd2dec945f0a7dcfe6ea29 100644 --- a/code/float-trap.lisp +++ b/code/float-trap.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.7 1992/12/10 01:26:41 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.7.1.1 1994/10/19 23:20:31 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -23,8 +23,10 @@ (export '(set-floating-point-modes get-floating-point-modes)) (in-package "VM") + (eval-when (compile load eval) + (defconstant float-trap-alist (list (cons :underflow float-underflow-trap-bit) (cons :overflow float-overflow-trap-bit) @@ -157,8 +159,8 @@ (defun sigfpe-handler (signal code scp) (declare (ignore signal code) (type system-area-pointer scp)) - (let* ((modes (sigcontext-floating-point-modes - (alien:sap-alien scp (* unix:sigcontext)))) + (let* ((modes (s-context-floating-point-modes + (alien:sap-alien scp (* unix:s-context)))) (traps (logand (ldb float-exceptions-byte modes) (ldb float-traps-byte modes)))) (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) diff --git a/code/foreign.lisp b/code/foreign.lisp index 32acd22437fb6cee06c9ab2a452899ba40b60424..d70a4b446b56ca14971bb4bd1d4c249d129bf07e 100644 --- a/code/foreign.lisp +++ b/code/foreign.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.14 1993/07/05 01:47:44 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.14.1.1 1994/10/19 23:20:59 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -50,7 +50,7 @@ (t (incf code)))))))) -#+sparc +#+(and sparc (not svr4)) (alien:def-alien-type exec (alien:struct nil (magic c-call:unsigned-long) @@ -62,6 +62,7 @@ (trsize c-call:unsigned-long) (drsize c-call:unsigned-long))) +#-svr4 (defun allocate-space-in-foreign-segment (bytes) (let* ((pagesize-1 (1- (get-page-size))) (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1)) @@ -73,7 +74,7 @@ (allocate-system-memory-at addr memory-needed) addr)) -#+sparc +#+(and sparc (not svr4)) (defun load-object-file (name) (format t ";;; Loading object file...~%") (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0) @@ -153,6 +154,7 @@ (unix:unix-read fd addr len-of-text-and-data))) (unix:unix-close fd)))) +#-solaris (defun parse-symbol-table (name) (format t ";;; Parsing symbol table...~%") (let ((symbol-table (make-hash-table :test #'equal))) @@ -170,6 +172,7 @@ (setf (gethash symbol symbol-table) address))))) (setf lisp::*foreign-symbols* symbol-table))) +#-solaris (defun load-foreign (files &key (libraries '("-lc")) (base-file @@ -223,3 +226,100 @@ (when old-file (unix:unix-unlink old-file))))) (format t ";;; Done.~%")) + + +(export '(alternate-get-global-address)) + +#-solaris +(defun alternate-get-global-address (symbol) 0) + +#+solaris +(progn + +(defconstant rtld-lazy 1) +(defconstant rtld-now 2) +(defconstant rtld-global #o400) +(defvar *global-table* NIL) + +(alien:def-alien-routine dlopen system-area-pointer + (str c-call:c-string) (i c-call:int)) +(alien:def-alien-routine dlsym system-area-pointer + (lib system-area-pointer) + (str c-call:c-string)) +(alien:def-alien-routine dlclose void (lib system-area-pointer)) +(alien:def-alien-routine dlerror c-call:c-string) + +(defun load-object-file (file) + ; rtld global: so it can find all the symbols previously loaded + ; rtld now: that way dlopen will fail if not all symbols are defined. + (let ((sap (dlopen file (logior rtld-now rtld-global)))) + (if (zerop (sap-int sap)) + (error "Can't open object ~S: ~S" file (dlerror)) + (pushnew sap *global-table*)))) + +(defun alternate-get-global-address (symbol) + (unless *global-table* + ;; Prevent recursive call when dlopen isn't defined. + (setq *global-table* (int-sap 0)) + ;; Load standard object + (setq *global-table* (list (dlopen nil rtld-lazy))) + (if (zerop (system:sap-int (car *global-table*))) + (error "Can't open global symbol table: ~S" (dlerror)))) + ;; find the symbol in any of the loaded obbjects, + ;; search in reverse order of loading, later loadings + ;; take precedence + (let ((result 0)) + (do ((table *global-table* (cdr table))) + ((or (null (car table)) (not (zerop result)))) + (setq result (sap-int (dlsym (car table) symbol)))) + (values result))) + +(defun load-foreign (files &key + (libraries '("-lc")) + (base-file nil) + (env ext:*environment-list*)) + "Load-foreign loads a list of C object files into a running Lisp. The files + argument should be a single file or a list of files. The files may be + specified as namestrings or as pathnames. The libraries argument should be a + list of library files as would be specified to ld. They will be searched in + the order given. The default is just \"-lc\", i.e., the C library. The + base-file argument is used to specify a file to use as the starting place for + defined symbols. The default is the C start up code for Lisp. The env + argument is the Unix environment variable definitions for the invocation of + the linker. The default is the environment passed to Lisp." + ;; Note: dlopen remembers the name of an object, when dlopenin + ;; the same name twice, the old objects is reused. + (declare (ignore base-file)) + (let ((output-file (pick-temporary-file-name + (concatenate 'string "/tmp/~D~S" (string (gensym))))) + (error-output (make-string-output-stream))) + + (format t ";;; Running /usr/ccs/bin/ld...~%") + (force-output) + (let ((proc (ext:run-program + "/usr/ccs/bin/ld" + (list* + "-G" + "-o" + output-file + (append (mapcar #'(lambda (name) + (unix-namestring name nil)) + (if (atom files) + (list files) + files)) + libraries)) + :env env + :input nil + :output error-output + :error :output))) + (unless proc + (error "Could not run /usr/ccs/bin/ld")) + (unless (zerop (ext:process-exit-code proc)) + (system:serve-all-events 0) + (error "/usr/ccs/bin/ld failed:~%~A" + (get-output-stream-string error-output))) + (load-object-file output-file) + (unix:unix-unlink output-file) + )) + (format t ";;; Done.~%")) +) diff --git a/code/hppa-vm.lisp b/code/hppa-vm.lisp index 62c8a011a2bf7e4a04efadea33a976a7b4d8635c..3ea6cb393a8b7e40d0f6b8246c6fea7e750cca6b 100644 --- a/code/hppa-vm.lisp +++ b/code/hppa-vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hppa-vm.lisp,v 1.6 1993/07/26 19:28:04 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hppa-vm.lisp,v 1.6.1.1 1994/10/19 23:21:29 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -20,12 +20,12 @@ (use-package "UNIX") (export '(fixup-code-object internal-error-arguments - sigcontext-program-counter sigcontext-register - sigcontext-float-register sigcontext-floating-point-modes + s-context-program-counter s-context-register + s-context-float-register s-context-floating-point-modes extern-alien-name sanctify-for-execution)) -;;;; The sigcontext structure. +;;;; The s-context structure. #+hpux (def-alien-type save-state @@ -80,7 +80,7 @@ (sl-ss save-state))) #+hpux -(def-alien-type sigcontext +(def-alien-type s-context (struct nil (sc-sl siglocal) ; the rest of this structure left out (since save-state not complete?) @@ -94,7 +94,7 @@ (fpregs (array unsigned-long 32)))) #+MACH -(def-alien-type sigcontext +(def-alien-type s-context (struct nil (sc-onstack unsigned-long) (sc-mask unsigned-long) @@ -164,13 +164,13 @@ ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; -;;; Given the sigcontext, extract the internal error arguments from the +;;; Given the s-context, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - (let ((pc (sigcontext-program-counter scp))) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) + (let ((pc (s-context-program-counter scp))) (declare (type system-area-pointer pc)) (let* ((length (sap-ref-8 pc 4)) (vector (make-array length :element-type '(unsigned-byte 8)))) @@ -190,66 +190,66 @@ (values error-number (sc-offsets)))))))) -;;;; Sigcontext access functions. +;;;; s-context access functions. -;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface +;;; s-context-PROGRAM-COUNTER -- Interface ;;; -(defun sigcontext-program-counter (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-program-counter (scp) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) #+hpux (int-sap (logandc2 (slot (slot (slot scp 'sc-sl) 'sl-ss) 'ss-pcoq-head) 3)) #+MACH (int-sap (logandc2 (slot scp 'sc-pcoqh) 3)) )) -;;; SIGCONTEXT-REGISTER -- Interface +;;; s-context-REGISTER -- Interface ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-register (scp index) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) #+hpux (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index) #+MACH (deref (slot (slot scp 'sc-ap) 'regs) index) )) -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun %set-s-context-register (scp index new) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) #+hpux (setf (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index) new) #+MACH (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new) new)) -(defsetf sigcontext-register %set-sigcontext-register) +(defsetf s-context-register %set-s-context-register) -;;; SIGCONTEXT-FLOAT-REGISTER -- Interface +;;; s-context-FLOAT-REGISTER -- Interface ;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. +;;; Like s-context-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp)) - (error "sigcontext-float-register not implemented." scp index format) +(defun s-context-float-register (scp index format) + (declare (type (alien (* s-context)) scp)) + (error "s-context-float-register not implemented." scp index format) #+nil - (with-alien ((scp (* sigcontext) scp)) + (with-alien ((scp (* s-context) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (system:sap-ref-single sap (* index vm:word-bytes))) (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) ;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp)) - (error "%set-sigcontext-float-register not implemented." +(defun %set-s-context-float-register (scp index format new-value) + (declare (type (alien (* s-context)) scp)) + (error "%set-s-context-float-register not implemented." scp index format new-value) #+nil - (with-alien ((scp (* sigcontext) scp)) + (with-alien ((scp (* s-context) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float @@ -257,19 +257,19 @@ (double-float (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) ;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) +(defsetf s-context-float-register %set-s-context-float-register) -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface +;;; s-context-FLOATING-POINT-MODES -- Interface ;;; -;;; Given a sigcontext pointer, return the floating point modes word in the +;;; Given a s-context pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; -(defun sigcontext-floating-point-modes (scp) - (declare (type (alien (* sigcontext)) scp)) - (error "sigcontext-floating-point-modes not implimented." scp) +(defun s-context-floating-point-modes (scp) + (declare (type (alien (* s-context)) scp)) + (error "s-context-floating-point-modes not implimented." scp) #+nil - (with-alien ((scp (* sigcontext) scp)) + (with-alien ((scp (* s-context) scp)) (slot scp 'sc-fpc-csr))) diff --git a/code/internet.lisp b/code/internet.lisp index 968716bc87ffde607b0e288ff4f1dc9a849dc5d4..e6c8568c2ea2daef91c2b268003d710ec3fced03 100644 --- a/code/internet.lisp +++ b/code/internet.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.13 1993/12/09 12:56:58 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.13.1.1 1994/10/19 23:22:18 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -30,9 +30,18 @@ send-character-out-of-band)) +#-svr4 (defconstant sock-stream 1) +#+svr4 +(defconstant sock-stream 2) +#-svr4 (defconstant sock-dgram 2) +#+svr4 +(defconstant sock-dgram 1) +#-svr4 (defconstant sock-raw 3) +#+svr4 +(defconstant sock-raw 4) (defconstant af-unix 1) (defconstant af-inet 2) diff --git a/code/interr.lisp b/code/interr.lisp index 6ce5f0489999604d26f34bf01877626e85c09667..d343287783f665f6dbf5aaa845d2c1d2858ec613 100644 --- a/code/interr.lisp +++ b/code/interr.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.28 1993/06/24 12:53:57 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.28.1.1 1994/10/19 23:22:30 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -37,13 +37,13 @@ (let* ((rest-pos (position '&rest args)) (required (if rest-pos (subseq args 0 rest-pos) args)) (fp (gensym)) - (sigcontext (gensym)) + (s-context (gensym)) (sc-offsets (gensym)) (temp (gensym)) (fn-name (symbolicate name "-HANDLER"))) `(progn - (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets) - (declare (ignorable name ,fp ,sigcontext ,sc-offsets)) + (defun ,fn-name (name ,fp ,s-context ,sc-offsets) + (declare (ignorable name ,fp ,s-context ,sc-offsets)) (macrolet ((set-value (var value) (let ((pos (position var ',required))) (unless pos @@ -52,7 +52,7 @@ `(let ((,',temp ,value)) (di::sub-set-debug-var-slot ,',fp (nth ,pos ,',sc-offsets) - ,',temp ,',sigcontext) + ,',temp ,',s-context) (setf ,var ,',temp))))) (let (,@(let ((offset -1)) (mapcar #'(lambda (var) @@ -60,7 +60,7 @@ ,fp (nth ,(incf offset) ,sc-offsets) - ,sigcontext))) + ,s-context))) required)) ,@(when rest-pos `((,(nth (1+ rest-pos) args) @@ -68,7 +68,7 @@ (di::sub-access-debug-var-slot ,fp sc-offset - ,sigcontext)) + ,s-context)) (nthcdr ,rest-pos ,sc-offsets)))))) ,@body))) (setf (svref *internal-errors* ,(error-number-or-lose name)) @@ -499,14 +499,14 @@ (infinite-error-protect (let ((scp (locally (declare (optimize (inhibit-warnings 3))) - (alien:sap-alien scp (* unix:sigcontext))))) + (alien:sap-alien scp (* unix:s-context))))) (multiple-value-bind (error-number arguments) (vm:internal-error-arguments scp) (multiple-value-bind (name debug:*stack-top-hint*) (find-interrupted-name) - (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset))) + (let ((fp (int-sap (vm:s-context-register scp vm::cfp-offset))) (handler (and (< -1 error-number (length *internal-errors*)) (svref *internal-errors* error-number)))) (cond ((null handler) diff --git a/code/load.lisp b/code/load.lisp index e1fc7b0ed936b4ab01cfb72825a08f72344d9374..3b6e4f6b61a972384f756c3345ed039fd7f8967c 100644 --- a/code/load.lisp +++ b/code/load.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.55 1993/08/19 23:09:38 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.55.1.1 1994/10/19 23:21:58 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,7 +21,7 @@ (export '(*load-if-source-newer* *load-source-types* *load-object-types*)) (in-package "SYSTEM") -(export 'foreign-symbol-address) +(export '(foreign-symbol-address alternate-get-global-address)) (in-package "LISP") @@ -1143,7 +1143,9 @@ (value found) (gethash (vm:extern-alien-name symbol) *foreign-symbols* 0) (unless found - (error "Unknown foreign symbol: ~S" symbol)) + (setq value (system:alternate-get-global-address symbol)) + (when (zerop value) + (error "Unknown foreign symbol: ~S" symbol))) (int-sap value))) (define-fop (fop-foreign-fixup 147) diff --git a/code/pmax-machdef.lisp b/code/pmax-machdef.lisp index 1e9536445049c425c5851dc478466c70703aa404..465d380149eaabb23d936277e7ff42d20ca81878 100644 --- a/code/pmax-machdef.lisp +++ b/code/pmax-machdef.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-machdef.lisp,v 1.2 1991/02/08 13:34:41 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-machdef.lisp,v 1.2.1.1 1994/10/19 23:22:57 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -16,14 +16,14 @@ (in-package "MACH") -(export '(sigcontext-onstack sigcontext-mask sigcontext-pc sigcontext-regs - sigcontext-mdlo sigcontext-mdhi sigcontext-ownedfp sigcontext-fpregs - sigcontext-fpc_csr sigcontext-fpc_eir sigcontext-cause - sigcontext-badvaddr sigcontext-badpaddr sigcontext *sigcontext - indirect-*sigcontext)) +(export '(s-context-onstack s-context-mask s-context-pc s-context-regs + s-context-mdlo s-context-mdhi s-context-ownedfp s-context-fpregs + s-context-fpc_csr s-context-fpc_eir s-context-cause + s-context-badvaddr s-context-badpaddr s-context *s-context + indirect-*s-context)) -(def-c-record sigcontext +(def-c-record s-context (onstack unsigned-long) (mask unsigned-long) (pc system-area-pointer) diff --git a/code/pmax-vm.lisp b/code/pmax-vm.lisp index 1bb5a1980885ebe9c6258fc92282f9b5b43ffdd5..9aba52335a8b515435347eef13ee4a6659b9029e 100644 --- a/code/pmax-vm.lisp +++ b/code/pmax-vm.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.14 1993/08/27 17:15:20 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.14.1.1 1994/10/19 23:22:43 ram Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.14 1993/08/27 17:15:20 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.14.1.1 1994/10/19 23:22:43 ram Exp $ ;;; ;;; This file contains the PMAX specific runtime stuff. ;;; @@ -22,14 +22,14 @@ (use-package "UNIX") (export '(fixup-code-object internal-error-arguments - sigcontext-program-counter sigcontext-register - sigcontext-float-register sigcontext-floating-point-modes + s-context-program-counter s-context-register + s-context-float-register s-context-floating-point-modes extern-alien-name sanctify-for-execution)) -;;;; The sigcontext structure. +;;;; The s-context structure. -(def-alien-type sigcontext +(def-alien-type s-context (struct nil (sc-onstack unsigned-long) (sc-mask unsigned-long) @@ -92,12 +92,12 @@ ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; -;;; Given the sigcontext, extract the internal error arguments from the +;;; Given the s-context, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (let ((pc (slot scp 'sc-pc))) (declare (type system-area-pointer pc)) (when (logbitp 31 (slot scp 'sc-cause)) @@ -122,50 +122,50 @@ (values error-number (sc-offsets)))))))) -;;;; Sigcontext access functions. +;;;; s-context access functions. -;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. +;;; s-context-PROGRAM-COUNTER -- Interface. ;;; -(defun sigcontext-program-counter (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-program-counter (scp) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (slot scp 'sc-pc))) -;;; SIGCONTEXT-REGISTER -- Interface. +;;; s-context-REGISTER -- Interface. ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-register (scp index) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (deref (slot scp 'sc-regs) index))) -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun %set-s-context-register (scp index new) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (setf (deref (slot scp 'sc-regs) index) new) new)) -(defsetf sigcontext-register %set-sigcontext-register) +(defsetf s-context-register %set-s-context-register) -;;; SIGCONTEXT-FLOAT-REGISTER -- Interface. +;;; s-context-FLOAT-REGISTER -- Interface. ;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. +;;; Like s-context-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-float-register (scp index format) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (system:sap-ref-single sap (* index vm:word-bytes))) (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) ;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun %set-s-context-float-register (scp index format new-value) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float @@ -173,17 +173,17 @@ (double-float (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) ;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) +(defsetf s-context-float-register %set-s-context-float-register) -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface +;;; s-context-FLOATING-POINT-MODES -- Interface ;;; -;;; Given a sigcontext pointer, return the floating point modes word in the +;;; Given a s-context pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; -(defun sigcontext-floating-point-modes (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-floating-point-modes (scp) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (slot scp 'sc-fpc-csr))) diff --git a/code/rt-machdef.lisp b/code/rt-machdef.lisp index f858194598871df137b33bd67d3b637df78d2c90..8173588a689c84146a779256f87afe6d14233848 100644 --- a/code/rt-machdef.lisp +++ b/code/rt-machdef.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-machdef.lisp,v 1.3 1991/07/22 23:54:55 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-machdef.lisp,v 1.3.1.1 1994/10/19 23:23:26 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,12 +15,12 @@ ;;; (in-package "MACH") -(export '(sigcontext-onstack sigcontext-mask sigcontext-sp sigcontext-fp - sigcontext-ap sigcontext-iar sigcontext-icscs sigcontext-saveiar - sigcontext-regs sigcontext *sigcontext indirect-*sigcontext - sigcontext-pc)) +(export '(s-context-onstack s-context-mask s-context-sp s-context-fp + s-context-ap s-context-iar s-context-icscs s-context-saveiar + s-context-regs s-context *s-context indirect-*s-context + s-context-pc)) -(def-c-record sigcontext +(def-c-record s-context (onstack unsigned-long) (mask unsigned-long) (floatsave system-area-pointer) @@ -32,5 +32,5 @@ (saveiar system-area-pointer) (regs int-array)) -(defoperator (sigcontext-pc system-area-pointer) ((x sigcontext)) - `(sigcontext-iar (alien-value ,x))) +(defoperator (s-context-pc system-area-pointer) ((x s-context)) + `(s-context-iar (alien-value ,x))) diff --git a/code/rt-vm.lisp b/code/rt-vm.lisp index a69caa9cfedb1f71164530d8eb39683a66d48e9a..27f4b112ba45414a9a3ad80ab6a0547d78786186 100644 --- a/code/rt-vm.lisp +++ b/code/rt-vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-vm.lisp,v 1.6 1992/03/10 10:21:34 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-vm.lisp,v 1.6.1.1 1994/10/19 23:23:40 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -20,13 +20,13 @@ (use-package "UNIX") (export '(fixup-code-object internal-error-arguments - sigcontext-register sigcontext-float-register - sigcontext-floating-point-modes extern-alien-name)) + s-context-register s-context-float-register + s-context-floating-point-modes extern-alien-name)) -;;;; The sigcontext structure. +;;;; The s-context structure. -(def-alien-type sigcontext +(def-alien-type s-context (struct nil (sc-onstack unsigned-long) (sc-mask unsigned-long) @@ -89,11 +89,11 @@ ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; -;;; Given the sigcontext, extract the internal error arguments from the +;;; Given the s-context, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) - (with-alien ((scp (* sigcontext) scp)) + (with-alien ((scp (* s-context) scp)) (let ((pc (slot scp 'sc-pc))) (declare (type system-area-pointer pc)) (let* ((length (sap-ref-8 pc 4)) @@ -115,55 +115,55 @@ -;;;; Sigcontext accessing stuff. +;;;; s-context accessing stuff. -;;; SIGCONTEXT-REGISTER -- Internal. +;;; s-context-REGISTER -- Internal. ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-register (scp index) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (deref (slot scp 'sc-regs) index))) -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun %set-s-context-register (scp index new) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (setf (deref (slot scp 'sc-regs) index) new) new)) -(defsetf sigcontext-register %set-sigcontext-register) +(defsetf s-context-register %set-s-context-register) -;;; SIGCONTEXT-FLOAT-REGISTER -- Internal +;;; s-context-FLOAT-REGISTER -- Internal ;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. +;;; Like s-context-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp) +(defun s-context-float-register (scp index format) + (declare (type (alien (* s-context)) scp) (ignore scp index)) ;; ### Some day we should figure out how to do this right. (ecase format (single-float 0.0s0) (double-float 0.0d0))) ;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp) +(defun %set-s-context-float-register (scp index format new-value) + (declare (type (alien (* s-context)) scp) (ignore scp index format)) ;; ### Some day we should figure out how to do this right. new-value) ;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) +(defsetf s-context-float-register %set-s-context-float-register) -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface +;;; s-context-FLOATING-POINT-MODES -- Interface ;;; -;;; Given a sigcontext pointer, return the floating point modes word in the +;;; Given a s-context pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; -(defun sigcontext-floating-point-modes (scp) +(defun s-context-floating-point-modes (scp) (declare (ignore scp)) ;; ### Some day we should figure out how to do this right. 0) diff --git a/code/run-program.lisp b/code/run-program.lisp index 2e2f6cb639cc4dd6e821974307871a4dc624de09..b89568872945fdf2ca30852e79504b01db605973 100644 --- a/code/run-program.lisp +++ b/code/run-program.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/run-program.lisp,v 1.14 1994/02/04 15:10:46 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/run-program.lisp,v 1.14.1.1 1994/10/19 23:24:04 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -35,10 +35,17 @@ (options c-call:int) (rusage c-call:int)) -(eval-when (load eval compile) +;(eval-when (load eval compile) (defconstant wait-wstopped #o177) + #-svr4 (defconstant wait-wnohang 1) - (defconstant wait-wuntraced 2)) + #+svr4 + (defconstant wait-wnohang #o100) + #-svr4 + (defconstant wait-wuntraced 2) + #+svr4 + (defconstant wait-wuntraced 4) +;) (defun wait3 (&optional do-not-hang check-for-stopped) "Return any available status information on child processed. " diff --git a/code/signal.lisp b/code/signal.lisp index 59f8fdf4036544fdb612dd42c58e49b405bc4759..9e132e9cd09f881354bfb39fee737169acbbee54 100644 --- a/code/signal.lisp +++ b/code/signal.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.21 1993/08/27 14:58:35 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.21.1.1 1994/10/19 23:24:19 ram Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.21 1993/08/27 14:58:35 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.21.1.1 1994/10/19 23:24:19 ram Exp $ ;;; ;;; Code for handling UNIX signals. ;;; @@ -109,27 +109,33 @@ (def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it") (def-unix-signal :SIGALRM 14 "Alarm clock") (def-unix-signal :SIGTERM 15 "Software termination signal") -(def-unix-signal :SIGURG #-hpux 16 #+hpux 29 +(def-unix-signal :SIGURG #+svr4 21 #-(or hpux svr4) 16 #+hpux 29 "Urgent condition present on socket") -(def-unix-signal :SIGSTOP #-hpux 17 #+hpux 24 "Stop") -(def-unix-signal :SIGTSTP #-hpux 18 #+hpux 25 +(def-unix-signal :SIGSTOP #-(or hpux svr4) 17 #+hpux 24 #+svr4 23 "Stop") +(def-unix-signal :SIGTSTP #-(or hpux svr4) 18 #+hpux 25 #+svr4 24 "Stop signal generated from keyboard") -(def-unix-signal :SIGCONT #-hpux 19 #+hpux 26 "Continue after stop") +(def-unix-signal :SIGCONT #-(or hpux svr4) 19 #+hpux 26 #+svr4 25 + "Continue after stop") (def-unix-signal :SIGCHLD #-hpux 20 #+hpux 18 "Child status has changed") -(def-unix-signal :SIGTTIN #-hpux 21 #+hpux 27 +(def-unix-signal :SIGTTIN #-(or hpux svr4) 21 #+hpux 27 #+svr4 26 "Background read attempted from control terminal") -(def-unix-signal :SIGTTOU #-hpux 22 #+hpux 28 +(def-unix-signal :SIGTTOU #-(or hpux svr4) 22 #+hpux 28 #+svr4 27 "Background write attempted to control terminal") (def-unix-signal :SIGIO #-hpux 23 #+hpux 22 "I/O is possible on a descriptor") #-hpux -(def-unix-signal :SIGXCPU 24 "Cpu time limit exceeded") +(def-unix-signal :SIGXCPU #-svr4 24 #+svr4 30 "Cpu time limit exceeded") #-hpux -(def-unix-signal :SIGXFSZ 25 "File size limit exceeded") -(def-unix-signal :SIGVTALRM #-hpux 26 #+hpux 20 "Virtual time alarm") -(def-unix-signal :SIGPROF #-hpux 27 #+hpux 21 "Profiling timer alarm") -(def-unix-signal :SIGWINCH #-hpux 28 #+hpux 23 "Window size change") -(def-unix-signal :SIGUSR1 #-hpux 30 #+hpux 16 "User defined signal 1") -(def-unix-signal :SIGUSR2 #-hpux 31 #+hpux 17 "User defined signal 2") +(def-unix-signal :SIGXFSZ #-svr4 25 #+svr4 31 "File size limit exceeded") +(def-unix-signal :SIGVTALRM #-(or hpux svr4) 26 #+hpux 20 #+svr4 28 + "Virtual time alarm") +(def-unix-signal :SIGPROF #-(or hpux svr4) 27 #+hpux 21 #+svr4 29 + "Profiling timer alarm") +(def-unix-signal :SIGWINCH #-(or hpux svr4) 28 #+hpux 23 #+svr4 20 + "Window size change") +(def-unix-signal :SIGUSR1 #-(or hpux svr4) 30 #+(or hpux svr4) 16 + "User defined signal 1") +(def-unix-signal :SIGUSR2 #-(or hpux svr4) 31 #+(or hpux svr4) 17 + "User defined signal 2") ;;; ;;; These are Mach Specific #+mach @@ -137,6 +143,10 @@ #+mach (def-unix-signal :SIGMSG 31 "Mach message") +;;; SVR4 (or Solaris?) specific signals +#+svr4 +(def-unix-signal :SIGWAITING 32 "Process's lwps are blocked") + ;;; SIGMASK -- Public ;;; (defmacro sigmask (&rest signals) @@ -240,8 +250,8 @@ (type system-area-pointer scp)) (system:without-hemlock (,function ,(concatenate 'simple-string what " at #x~x.") - (with-alien ((scp (* sigcontext) scp)) - (sap-int (vm:sigcontext-program-counter scp))))))) + (with-alien ((scp (* s-context) scp)) + (sap-int (vm:s-context-program-counter scp))))))) (define-signal-handler sigint-handler "Interrupted" break) (define-signal-handler sigill-handler "Illegal Instruction") @@ -284,7 +294,7 @@ ;;; Before invoking the supplied handler for any of the signals that can be ;;; blocked, the C interrupt support code checks to see if *interrupts-enabled* ;;; has been bound to NIL. If so, it saves the signal number and the value of -;;; the signal mask (from the sigcontext), sets the signal mask to block all +;;; the signal mask (from the s-context), sets the signal mask to block all ;;; blockable signals, sets *interrupt-pending* and returns without handling ;;; the signal. ;;; @@ -292,7 +302,7 @@ ;;; *interrupt-pending* has been set. If so, we call do-pending-interrupt, ;;; which generates a SIGTRAP. The C code invokes the handler for the saved ;;; signal instead of the SIGTRAP after replacing the signal mask in the -;;; sigcontext with the saved value. When that hander returns, the original +;;; s-context with the saved value. When that hander returns, the original ;;; signal mask is installed, allowing any other pending signals to be handled. ;;; ;;; This means that the cost of without-interrupts is just a special binding in diff --git a/code/sparc-machdef.lisp b/code/sparc-machdef.lisp index 5baee104cc36a704575350b1034e59440561a0c7..b8d56feafe703fd4fabf6375cd35d7b14c8b8971 100644 --- a/code/sparc-machdef.lisp +++ b/code/sparc-machdef.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-machdef.lisp,v 1.2 1991/02/08 13:35:49 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-machdef.lisp,v 1.2.1.1 1994/10/19 23:24:40 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,12 +15,12 @@ ;;; (in-package "MACH") -(export '(sigcontext-onstack sigcontext-mask sigcontext-sp sigcontext-pc - sigcontext-npc sigcontext-psr sigcontext-g1 sigcontext-o0 - sigcontext-regs sigcontext-fpregs sigcontext-y sigcontext-fsr - sigcontext *sigcontext indirect-*sigcontext)) +(export '(s-context-onstack s-context-mask s-context-sp s-context-pc + s-context-npc s-context-psr s-context-g1 s-context-o0 + s-context-regs s-context-fpregs s-context-y s-context-fsr + s-context *s-context indirect-*s-context)) -(def-c-record sigcontext +(def-c-record s-context (onstack unsigned-long) (mask unsigned-long) (sp system-area-pointer) diff --git a/code/sparc-vm.lisp b/code/sparc-vm.lisp index 2870804c15c8d9d5297613baa157de9267b30b20..a2798e7608b3d66a59da94a8a5f438fa6951a736 100644 --- a/code/sparc-vm.lisp +++ b/code/sparc-vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-vm.lisp,v 1.16 1993/03/16 13:04:15 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-vm.lisp,v 1.16.1.1 1994/10/19 23:25:47 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,21 +18,21 @@ (use-package "UNIX") (export '(fixup-code-object internal-error-arguments - sigcontext-program-counter sigcontext-register - sigcontext-float-register sigcontext-floating-point-modes + s-context-program-counter s-context-register + s-context-float-register s-context-floating-point-modes extern-alien-name sanctify-for-execution)) -;;;; The sigcontext structure. +;;;; The s-context structure. -(def-alien-type sigcontext-regs +(def-alien-type s-context-regs (struct nil (regs (array unsigned-long 32)) (fpregs (array unsigned-long 32)) (y unsigned-long) (fsr unsigned-long))) -(def-alien-type sigcontext +(def-alien-type s-context (struct nil (sc-onstack unsigned-long) (sc-mask unsigned-long) @@ -40,7 +40,7 @@ (sc-pc system-area-pointer) (sc-npc system-area-pointer) (sc-psr unsigned-long) - (sc-g1 (* sigcontext-regs)) + (sc-g1 (* s-context-regs)) (sc-o0 unsigned-long))) @@ -89,12 +89,12 @@ ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; -;;; Given the sigcontext, extract the internal error arguments from the +;;; Given the s-context, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) - (declare (type (alien (* sigcontext)) scp)) - (let* ((pc (with-alien ((scp (* sigcontext) scp)) + (declare (type (alien (* s-context)) scp)) + (let* ((pc (with-alien ((scp (* s-context) scp)) (slot scp 'sc-pc))) (bad-inst (sap-ref-32 pc 0)) (op (ldb (byte 2 30) bad-inst)) @@ -111,8 +111,8 @@ (values #.(error-number-or-lose 'unknown-error) nil))))) (defun args-for-unimp-inst (scp) - (declare (type (alien (* sigcontext)) scp)) - (let* ((pc (with-alien ((scp (* sigcontext) scp)) + (declare (type (alien (* s-context)) scp)) + (let* ((pc (with-alien ((scp (* s-context) scp)) (slot scp 'sc-pc))) (length (sap-ref-8 pc 4)) (vector (make-array length :element-type '(unsigned-byte 8)))) @@ -133,13 +133,13 @@ (values error-number (sc-offsets)))))) (defun args-for-tagged-add-inst (scp bad-inst) - (declare (type (alien (* sigcontext)) scp)) + (declare (type (alien (* s-context)) scp)) (let* ((rs1 (ldb (byte 5 14) bad-inst)) - (op1 (di::make-lisp-obj (sigcontext-register scp rs1)))) + (op1 (di::make-lisp-obj (s-context-register scp rs1)))) (if (fixnump op1) (if (zerop (ldb (byte 1 13) bad-inst)) (let* ((rs2 (ldb (byte 5 0) bad-inst)) - (op2 (di::make-lisp-obj (sigcontext-register scp rs2)))) + (op2 (di::make-lisp-obj (s-context-register scp rs2)))) (if (fixnump op2) (values #.(error-number-or-lose 'unknown-error) nil) (values #.(error-number-or-lose 'object-not-fixnum-error) @@ -164,50 +164,50 @@ (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg))))) -;;;; Sigcontext access functions. +;;;; s-context access functions. -;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. +;;; s-context-PROGRAM-COUNTER -- Interface. ;;; -(defun sigcontext-program-counter (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-program-counter (scp) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (slot scp 'sc-pc))) -;;; SIGCONTEXT-REGISTER -- Interface. +;;; s-context-REGISTER -- Interface. ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; -(defun sigcontext-register (scp index) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-register (scp index) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (deref (slot (slot scp 'sc-g1) 'regs) index))) -(defun %set-sigcontext-register (scp index new) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun %set-s-context-register (scp index new) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new) new)) -(defsetf sigcontext-register %set-sigcontext-register) +(defsetf s-context-register %set-s-context-register) -;;; SIGCONTEXT-FLOAT-REGISTER -- Interface +;;; s-context-FLOAT-REGISTER -- Interface ;;; -;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. +;;; Like s-context-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-float-register (scp index format) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs)))) (ecase format (single-float (system:sap-ref-single sap (* index vm:word-bytes))) (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) ;;; -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun %set-s-context-float-register (scp index format new-value) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs)))) (ecase format (single-float @@ -215,17 +215,17 @@ (double-float (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) ;;; -(defsetf sigcontext-float-register %set-sigcontext-float-register) +(defsetf s-context-float-register %set-s-context-float-register) -;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface +;;; s-context-FLOATING-POINT-MODES -- Interface ;;; -;;; Given a sigcontext pointer, return the floating point modes word in the +;;; Given a s-context pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; -(defun sigcontext-floating-point-modes (scp) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) +(defun s-context-floating-point-modes (scp) + (declare (type (alien (* s-context)) scp)) + (with-alien ((scp (* s-context) scp)) (slot (slot scp 'sc-g1) 'fsr))) diff --git a/code/stream.lisp b/code/stream.lisp index 2257ba2e9c51572f2840140524b3a44f84447454..1d7fdaf2598cb3194617e125e114be037c5d94d5 100644 --- a/code/stream.lisp +++ b/code/stream.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.19 1993/03/12 21:05:38 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.19.1.1 1994/10/19 23:26:02 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -848,13 +848,15 @@ ;;;; String Input Streams: (defstruct (string-input-stream - (:include stream - (in #'string-inch) - (misc #'string-in-misc)) - (:print-function %print-string-input-stream) - ;(:constructor nil) - (:constructor internal-make-string-input-stream - (string current end))) + (:include stream + (in #'string-inch) + (bin #'string-binch) + (n-bin #'string-stream-read-n-bytes) + (misc #'string-in-misc)) + (:print-function %print-string-input-stream) + ;(:constructor nil) + (:constructor internal-make-string-input-stream + (string current end))) (string nil :type simple-string) (current nil :type fixnum) (end nil :type fixnum)) @@ -873,6 +875,37 @@ (setf (string-input-stream-current stream) (1+ index)) (aref string index))))) +(defun string-binch (stream eof-errorp eof-value) + (let ((string (string-input-stream-string stream)) + (index (string-input-stream-current stream))) + (declare (simple-string string) (fixnum index)) + (cond ((= index (the fixnum (string-input-stream-end stream))) + (eof-or-lose stream eof-errorp eof-value)) + (t + (setf (string-input-stream-current stream) (1+ index)) + (char-code (aref string index)))))) + +(defun string-stream-read-n-bytes (stream buffer start requested eof-errorp) + (declare (type string-input-stream stream) + (type index start requested)) + (let ((string (string-input-stream-string stream)) + (index (string-input-stream-current stream)) + (end (string-input-stream-end stream))) + (declare (simple-string string) (fixnum index end)) + (cond ((>= (+ index requested) end) + (eof-or-lose stream eof-errorp nil)) + (t + (setf (string-input-stream-current stream) (+ index requested)) + (system:without-gcing + (system-area-copy (vector-sap string) + (* index vm:byte-bits) + (if (typep buffer 'system-area-pointer) + buffer + (vector-sap buffer)) + (* start vm:byte-bits) + (* requested vm:byte-bits))) + requested)))) + (defun string-in-misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) (case operation diff --git a/code/unix.lisp b/code/unix.lisp index 9a56faf87edfd3b056f2973c9bf4db82bec7f56a..dd971caff87239bc11f6301373a7bea0747f807a 100644 --- a/code/unix.lisp +++ b/code/unix.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.29 1994/02/11 19:30:31 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.29.1.1 1994/10/19 23:26:18 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -26,7 +26,7 @@ t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel - direct d-off d-ino d-reclen d-namlen d-name + direct d-off d-ino d-reclen #-svr4 d-namlen d-name stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size st-atime st-mtime st-ctime st-blksize st-blocks s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock @@ -34,7 +34,7 @@ ruseage ru-utime ru-stime ru-maxrss ru-ixrss ru-idrss ru-isrss ru-minflt ru-majflt ru-nswap ru-inblock ru-oublock ru-msgsnd ru-msgrcv ru-nsignals ru-nvcsw ru-nivcsw - rlimit rlim-cur rlim-max sigcontext sc-onstack sc-mask sc-pc + rlimit rlim-cur rlim-max s-context sc-onstack sc-mask sc-pc unix-errno get-unix-error-msg @@ -53,13 +53,13 @@ unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl tcsetpgrp tcgetpgrp tty-process-group terminal-speeds tty-raw tty-crmod tty-echo tty-lcase - #-hpux tty-cbreak #-hpux tty-tandem #+hpux termios #+hpux c-lflag - #+hpux c-iflag #+hpux c-oflag #+hpux tty-icrnl #+hpux tty-ocrnl - #+hpux vdsusp #+hpux veof #+hpux vintr #+hpux vquit #+hpux vstart - #+hpux vstop #+hpux vsusp #+hpux c-cflag - #+hpux c-cc #+hpux tty-icanon #+hpux vmin #+hpux vtime + #-hpux tty-cbreak #-hpux tty-tandem #+(or svr4 hpux) termios #+(or svr4 hpux) c-lflag + #+(or svr4 hpux) c-iflag #+(or svr4 hpux) c-oflag #+(or svr4 hpux) tty-icrnl #+hpux tty-ocrnl + #+(or svr4 hpux) vdsusp #+(or svr4 hpux) veof #+(or svr4 hpux) vintr #+(or svr4 hpux) vquit #+(or svr4 hpux) vstart + #+(or svr4 hpux) vstop #+(or svr4 hpux) vsusp #+(or svr4 hpux) c-cflag + #+(or svr4 hpux) c-cc #+hpux tty-icanon #+hpux vmin #+hpux vtime #+hpux tty-ixon - #+hpux tcsaflush #+hpux unix-tcgetattr #+hpux unix-tcsetattr + #+(or svr4 hpux) tcsaflush #+(or svr4 hpux) unix-tcgetattr #+(or svr4 hpux) unix-tcsetattr TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK @@ -67,7 +67,8 @@ unix-exit unix-stat unix-lstat unix-fstat unix-getrusage unix-fast-getrusage rusage_self rusage_children unix-gettimeofday - #-hpux unix-utimes #-hpux unix-setreuid #-hpux unix-setregid + #-hpux unix-utimes #-(or svr4 hpux) unix-setreuid + #-(or svr4 hpux) unix-setregid unix-getpid unix-getppid unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid unix-getpagesize unix-gethostname unix-gethostid unix-fork @@ -88,10 +89,19 @@ (def-alien-type swblk-t long) (def-alien-type size-t long) (def-alien-type time-t long) +#-svr4 (def-alien-type dev-t short) +#+svr4 +(def-alien-type dev-t unsigned-long) (def-alien-type off-t long) +#-svr4 (def-alien-type uid-t unsigned-short) +#+svr4 +(def-alien-type uid-t long) +#-svr4 (def-alien-type gid-t unsigned-short) +#+svr4 +(def-alien-type gid-t long) (defconstant FD-SETSIZE #-hpux 256 #+hpux 2048) @@ -183,23 +193,26 @@ ;;; From sys/termio.h -#+hpux +#+(or svr4 hpux) (def-alien-type nil (struct termios (c-iflag unsigned-int) (c-oflag unsigned-int) (c-cflag unsigned-int) (c-lflag unsigned-int) + #-svr4 (c-reserved unsigned-int) - (c-cc (array unsigned-char 16)))) + (c-cc (array unsigned-char #-svr4 16 #+svr4 19)))) ;;; From sys/dir.h (def-alien-type nil (struct direct - #+sunos (d-off long) ; offset of next disk directory entry + #+(and sunos (not svr4)) (d-off long) ; offset of next disk directory entry (d-ino unsigned-long) ; inode number of entry + #+svr4 (d-off long) (d-reclen unsigned-short) ; length of this record + #-svr4 (d-namlen unsigned-short) ; length of string in d-name (d-name (array char 256)))) ; name must be no longer than this @@ -208,13 +221,25 @@ (def-alien-type nil (struct stat (st-dev dev-t) +#+svr4 + (st-pad1 (array long 3)) (st-ino ino-t) +#-svr4 (st-mode unsigned-short) +#+svr4 + (st-mode unsigned-long) +#-svr4 (st-nlink short) +#+svr4 + (st-nlink unsigned-long) (st-uid uid-t) (st-gid gid-t) (st-rdev dev-t) +#+svr4 + (st-pad2 (array long 2)) (st-size off-t) +#+svr4 + (st-pad3 long) (st-atime time-t) (st-spare1 int) (st-mtime time-t) @@ -223,7 +248,13 @@ (st-spare3 int) (st-blksize long) (st-blocks long) - (st-spare4 (array long 2)))) +#-svr4 + (st-spare4 (array long 2)) +#+svr4 + (st-fstype (array char 16)) +#+svr4 + (st-pad4 (array long 8)) + )) (defconstant s-ifmt #o0170000) (defconstant s-ifdir #o0040000) @@ -332,6 +363,8 @@ (def-unix-error EDOM 33 "Argument too large") (def-unix-error ERANGE 34 "Result too large") ;;; +#-svr4 +(progn ;;; non-blocking and interrupt i/o (def-unix-error EWOULDBLOCK 35 "Operation would block") (def-unix-error EDEADLK 35 "Operation would block") ; Ditto @@ -388,6 +421,93 @@ ;;; ;;; Mach Emulation (def-unix-error ERESTART 72 "Mach Emulation Error (?)") +) +#+svr4 +(progn +(def-unix-error ENOMSG 35 "No message of desired type") +(def-unix-error EIDRM 36 "Identifier removed") +(def-unix-error ECHRNG 37 "Channel number out of range") +(def-unix-error EL2NSYNC 38 "Level 2 not synchronized") +(def-unix-error EL3HLT 39 "Level 3 halted") +(def-unix-error EL3RST 40 "Level 3 reset") +(def-unix-error ELNRNG 41 "Link number out of range") +(def-unix-error EUNATCH 42 "Protocol driver not attached") +(def-unix-error ENOCSI 43 "No CSI structure available") +(def-unix-error EL2HLT 44 "Level 2 halted") +(def-unix-error EDEADLK 45 "Deadlock situation detected/avoided") +(def-unix-error ENOLCK 46 "No record locks available") +(def-unix-error ECANCELED 47 "Error 47") +(def-unix-error ENOTSUP 48 "Error 48") +(def-unix-error EBADE 50 "Bad exchange descriptor") +(def-unix-error EBADR 51 "Bad request descriptor") +(def-unix-error EXFULL 52 "Message tables full") +(def-unix-error ENOANO 53 "Anode table overflow") +(def-unix-error EBADRQC 54 "Bad request code") +(def-unix-error EBADSLT 55 "Invalid slot") +(def-unix-error EDEADLOCK 56 "File locking deadlock") +(def-unix-error EBFONT 57 "Bad font file format") +(def-unix-error ENOSTR 60 "Not a stream device") +(def-unix-error ENODATA 61 "No data available") +(def-unix-error ETIME 62 "Timer expired") +(def-unix-error ENOSR 63 "Out of stream resources") +(def-unix-error ENONET 64 "Machine is not on the network") +(def-unix-error ENOPKG 65 "Package not installed") +(def-unix-error EREMOTE 66 "Object is remote") +(def-unix-error ENOLINK 67 "Link has been severed") +(def-unix-error EADV 68 "Advertise error") +(def-unix-error ESRMNT 69 "Srmount error") +(def-unix-error ECOMM 70 "Communication error on send") +(def-unix-error EPROTO 71 "Protocol error") +(def-unix-error EMULTIHOP 74 "Multihop attempted") +(def-unix-error EBADMSG 77 "Not a data message") +(def-unix-error ENAMETOOLONG 78 "File name too long") +(def-unix-error EOVERFLOW 79 "Value too large for defined data type") +(def-unix-error ENOTUNIQ 80 "Name not unique on network") +(def-unix-error EBADFD 81 "File descriptor in bad state") +(def-unix-error EREMCHG 82 "Remote address changed") +(def-unix-error ELIBACC 83 "Can not access a needed shared library") +(def-unix-error ELIBBAD 84 "Accessing a corrupted shared library") +(def-unix-error ELIBSCN 85 ".lib section in a.out corrupted") +(def-unix-error ELIBMAX 86 "Attempting to link in more shared libraries than system limit") +(def-unix-error ELIBEXEC 87 "Can not exec a shared library directly") +(def-unix-error EILSEQ 88 "Error 88") +(def-unix-error ENOSYS 89 "Operation not applicable") +(def-unix-error ELOOP 90 "Number of symbolic links encountered during path name traversal exceeds MAXSYMLINKS") +(def-unix-error ERESTART 91 "Error 91") +(def-unix-error ESTRPIPE 92 "Error 92") +(def-unix-error ENOTEMPTY 93 "Directory not empty") +(def-unix-error EUSERS 94 "Too many users") +(def-unix-error ENOTSOCK 95 "Socket operation on non-socket") +(def-unix-error EDESTADDRREQ 96 "Destination address required") +(def-unix-error EMSGSIZE 97 "Message too long") +(def-unix-error EPROTOTYPE 98 "Protocol wrong type for socket") +(def-unix-error ENOPROTOOPT 99 "Option not supported by protocol") +(def-unix-error EPROTONOSUPPORT 120 "Protocol not supported") +(def-unix-error ESOCKTNOSUPPORT 121 "Socket type not supported") +(def-unix-error EOPNOTSUPP 122 "Operation not supported on transport endpoint") +(def-unix-error EPFNOSUPPORT 123 "Protocol family not supported") +(def-unix-error EAFNOSUPPORT 124 "Address family not supported by protocol family") +(def-unix-error EADDRINUSE 125 "Address already in use") +(def-unix-error EADDRNOTAVAIL 126 "Cannot assign requested address") +(def-unix-error ENETDOWN 127 "Network is down") +(def-unix-error ENETUNREACH 128 "Network is unreachable") +(def-unix-error ENETRESET 129 "Network dropped connection because of reset") +(def-unix-error ECONNABORTED 130 "Software caused connection abort") +(def-unix-error ECONNRESET 131 "Connection reset by peer") +(def-unix-error ENOBUFS 132 "No buffer space available") +(def-unix-error EISCONN 133 "Transport endpoint is already connected") +(def-unix-error ENOTCONN 134 "Transport endpoint is not connected") +(def-unix-error ESHUTDOWN 143 "Cannot send after socket shutdown") +(def-unix-error ETOOMANYREFS 144 "Too many references: cannot splice") +(def-unix-error ETIMEDOUT 145 "Connection timed out") +(def-unix-error ECONNREFUSED 146 "Connection refused") +(def-unix-error EHOSTDOWN 147 "Host is down") +(def-unix-error EHOSTUNREACH 148 "No route to host") +(def-unix-error EWOULDBLOCK 11 "Resource temporarily unavailable") +(def-unix-error EALREADY 149 "Operation already in progress") +(def-unix-error EINPROGRESS 150 "Operation now in progress") +(def-unix-error ESTALE 151 "Stale NFS file handle") +) ;;; ;;; And now for something completely different ... (emit-unix-errors) @@ -409,11 +529,20 @@ ;;;; Lisp types used by syscalls. (deftype unix-pathname () 'simple-string) +#-svr4 (deftype unix-file-mode () '(unsigned-byte 16)) +#+svr4 +(deftype unix-file-mode () '(unsigned-byte 32)) (deftype unix-fd () `(integer 0 ,most-positive-fixnum)) (deftype unix-pid () '(unsigned-byte 16)) +#-svr4 (deftype unix-uid () '(unsigned-byte 16)) +#+svr4 +(deftype unix-uid () '(unsigned-byte 32)) +#-svr4 (deftype unix-gid () '(unsigned-byte 16)) +#+svr4 +(deftype unix-gid () '(unsigned-byte 32)) @@ -619,18 +748,24 @@ (defconstant F-SETFD 2 "Set file desc. flags") (defconstant F-GETFL 3 "Get file flags") (defconstant F-SETFL 4 "Set file flags") +#-svr4 (defconstant F-GETOWN 5 "Get owner") +#+svr4 +(defconstant F-GETOWN 23 "Get owner") +#-svr4 (defconstant F-SETOWN 6 "Set owner") +#+svr4 +(defconstant F-SETOWN 24 "Set owner") ;;; File flags for F-GETFL and F-SETFL: (defconstant FNDELAY #o0004 "Non-blocking reads") (defconstant FAPPEND #o0010 "Append on each write") -(defconstant FASYNC #o0100 "Signal pgrp when data ready") -(defconstant FCREAT #-hpux #o1000 #+hpux #o0400 "Create if nonexistant") -(defconstant FTRUNC #-hpux #o2000 #+hpux #o1000 "Truncate to zero length") -(defconstant FEXCL #-hpux #o4000 #+hpux #o2000 "Error if already created") +(defconstant FASYNC #-svr4 #o0100 #+svr4 #o10000 "Signal pgrp when data ready") +(defconstant FCREAT #-(or hpux svr4) #o1000 #+(or hpux svr4) #o0400 "Create if nonexistant") +(defconstant FTRUNC #-(or hpux svr4) #o2000 #+(or hpux svr4) #o1000 "Truncate to zero length") +(defconstant FEXCL #-(or hpux svr4) #o4000 #+(or hpux svr4) #o2000 "Error if already created") (defun unix-fcntl (fd cmd arg) "Unix-fcntl manipulates file descriptors according to the @@ -703,12 +838,12 @@ (defconstant o_wronly 1 "Write-only flag.") (defconstant o_rdwr 2 "Read-write flag.") (defconstant o_append #o10 "Append flag.") -#+hpux +#+(or hpux svr4) (progn (defconstant o_creat #o400 "Create if nonexistant flag.") (defconstant o_trunc #o1000 "Truncate flag.") (defconstant o_excl #o2000 "Error if already exists.")) -#-hpux +#-(or hpux svr4) (progn (defconstant o_creat #o1000 "Create if nonexistant flag.") (defconstant o_trunc #o2000 "Truncate flag.") @@ -999,6 +1134,24 @@ (defconstant vmin 11) (defconstant vtime 12) (defconstant tcsaflush 2)) +#+svr4 +(progn + (defconstant tty-icanon #o2) + (defconstant tty-icrnl #o400) + (defconstant tty-ocrnl #o10) + (defconstant tty-ixon #o2000) + + (defconstant vintr 0) + (defconstant vquit 1) + (defconstant veof 4) + (defconstant vstart 8) + (defconstant vstop 9) + (defconstant vsusp 10) + (defconstant vdsusp 11) + + (defconstant vmin 4) + (defconstant vtime 5) + (defconstant tcsaflush 2)) (eval-when (compile load eval) @@ -1044,8 +1197,8 @@ (progn (define-ioctl-command TIOCSLTC #\t 117 (struct ltchars) :in) (define-ioctl-command TIOCGLTC #\t 116 (struct ltchars) :out) - (define-ioctl-command TIOCSPGRP #\t 118 int :in) - (define-ioctl-command TIOCGPGRP #\t 119 int :out)) + (define-ioctl-command TIOCSPGRP #\t #-svr4 118 #+svr4 21 int :in) + (define-ioctl-command TIOCGPGRP #\t #-svr4 119 #+svr4 20 int :out)) #+hpux (progn (define-ioctl-command TIOCSLTC #\T 23 (struct ltchars) :in) @@ -1065,13 +1218,13 @@ (type (unsigned-byte 32) cmd)) (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) -#+hpux +#+(or svr4 hpux) (defun unix-tcgetattr (fd termios) "Get terminal attributes." (declare (type unix-fd fd)) (void-syscall ("tcgetattr" int (* (struct termios))) fd termios)) -#+hpux +#+(or svr4 hpux) (defun unix-tcsetattr (fd opt termios) "Set terminal attributes." (declare (type unix-fd fd)) @@ -1255,6 +1408,29 @@ (slot usage 'ru-nivcsw)) who (addr usage)))) +;; Requires call to tzset() in main. +;; Don't use this now: we +#+svr4 +(progn + (def-alien-variable ("daylight" unix-daylight) int) + (def-alien-variable ("timezone" unix-timezone) time-t) + (def-alien-variable ("altzone" unix-altzone) time-t) + (def-alien-variable ("tzname" unix-tzname) (array c-string 2)) + (def-alien-routine get-timezone c-call:void + (when c-call:long :in) + (minutes-west c-call:int :out) + (daylight-savings-p alien:boolean :out)) + (defun unix-get-minutes-west (secs) + (multiple-value-bind (ignore minutes dst) (get-timezone secs) + (declare (ignore ignore) (ignore dst)) + (values minutes)) + ) + (defun unix-get-timezone (secs) + (multiple-value-bind (ignore minutes dst) (get-timezone secs) + (declare (ignore ignore) (ignore minutes)) + (values (deref unix-tzname (if dst 1 0))) + ) ) +) (declaim (inline unix-gettimeofday)) (defun unix-gettimeofday () "If it works, unix-gettimeofday returns 5 values: T, the seconds and @@ -1262,15 +1438,18 @@ of Greenwich), and a daylight-savings flag. If it doesn't work, it returns NIL and the errno." (with-alien ((tv (struct timeval)) - (tz (struct timezone))) - (syscall* ("gettimeofday" (* (struct timeval)) (* (struct timezone))) + #-svr4 (tz (struct timezone))) + (syscall* ("gettimeofday" (* (struct timeval)) #-svr4 (* (struct timezone))) (values T (slot tv 'tv-sec) (slot tv 'tv-usec) - (slot tz 'tz-minuteswest) - (slot tz 'tz-dsttime)) + #-svr4 (slot tz 'tz-minuteswest) + #+svr4 (unix-get-minutes-west (slot tv 'tv-sec)) + #-svr4 (slot tz 'tz-dsttime) + #+svr4 (unix-get-timezone (slot tv 'tv-sec)) + ) (addr tv) - (addr tz)))) + #-svr4 (addr tz)))) ;;; Unix-utimes changes the accessed and updated times on UNIX ;;; files. The first argument is the filename (a string) and @@ -1300,7 +1479,7 @@ ;;; restricted for anyone but the super-user. Setting either "ruid" or ;;; "euid" to -1 makes the system use the current id instead. -#-hpux +#-(or svr4 hpux) (defun unix-setreuid (ruid euid) "Unix-setreuid sets the real and effective user-id's of the current process to the specified ones. NIL and an error number is returned @@ -1312,7 +1491,7 @@ ;;; restricted for anyone but the super-user. Setting either "rgid" or ;;; "egid" to -1 makes the system use the current id instead. -#-hpux +#-(or svr4 hpux) (defun unix-setregid (rgid egid) "Unix-setregid sets the real and effective group-id's of the current process process to the specified ones. NIL and an error number is @@ -1348,7 +1527,7 @@ (defun unix-setpgrp (pid pgrp) "Unix-setpgrp sets the process group on the process pid to pgrp. NIL and an error number is returned upon failure." - (void-syscall ("setpgrp" int int) pid pgrp)) + (void-syscall (#-svr4 "setpgrp" #+svr4 "setpgid" int int) pid pgrp)) (def-alien-routine ("getuid" unix-getuid) int "Unix-getuid returns the real user-id associated with the @@ -1420,6 +1599,7 @@ (if (zerop (sap-int daddr)) nil (with-alien ((direct (* (struct direct)) daddr)) + #-svr4 (let ((nlen (slot direct 'd-namlen)) (ino (slot direct 'd-ino))) (declare (type (unsigned-byte 16) nlen)) @@ -1428,7 +1608,12 @@ (alien-sap (addr (slot direct 'd-name))) 0 string (* vm:vector-data-offset vm:word-bits) (* nlen vm:byte-bits)) - (values string ino))))))) + (values string ino))) + #+svr4 + (let ((str (cast (slot direct 'd-name) c-string)) + (ino (slot direct 'd-ino))) + (values str ino)) + )))) (defun close-dir (dir) (declare (type directory dir))