/[cmucl]/src/code/rt-vm.lisp
ViewVC logotype

Contents of /src/code/rt-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Tue Apr 16 19:33:16 1991 UTC (23 years ago) by wlott
Branch: MAIN
Initial revision
1 ;;; -*- Package: RT -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/rt-vm.lisp,v 1.1 1991/04/16 19:33:16 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/rt-vm.lisp,v 1.1 1991/04/16 19:33:16 wlott Exp $
15 ;;;
16 ;;; This file contains the RT specific runtime stuff.
17 ;;;
18 (in-package "RT")
19 (use-package "SYSTEM")
20
21 (export '(fixup-code-object internal-error-arguments))
22
23
24 ;;;; Add machine specific features to *features*
25
26 (pushnew :ibm-pc-rt *features*)
27 (pushnew :ibmrt *features*)
28 (pushnew :rt *features*)
29
30
31
32 ;;;; MACHINE-TYPE and MACHINE-VERSION
33
34 (defun machine-type ()
35 "Returns a string describing the type of the local machine."
36 "IBM PC/RT")
37
38 (defun machine-version ()
39 "Returns a string describing the version of the local machine."
40 "IBM PC/RT")
41
42
43
44 ;;; FIXUP-CODE-OBJECT -- Interface
45 ;;;
46 (defun fixup-code-object (code offset fixup kind)
47 (error "Not yet." code offset fixup kind))
48
49
50
51 ;;;; Internal-error-arguments.
52
53 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
54 ;;;
55 ;;; Given the sigcontext, extract the internal error arguments from the
56 ;;; instruction stream.
57 ;;;
58 (defun internal-error-arguments (sc)
59 (alien-bind ((sc sc mach:sigcontext t))
60 (values (error-number-or-lose 'unknown-error)
61 nil)))
62
63
64 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
65 ;;;
66 ;;; Given a sigcontext pointer, return the floating point modes word in the
67 ;;; same format as returned by FLOATING-POINT-MODES.
68 ;;;
69 (defun sigcontext-floating-point-modes (scp)
70 (alien-bind ((sc (make-alien 'mach:sigcontext
71 #.(ext:c-sizeof 'mach:sigcontext)
72 scp)
73 mach:sigcontext
74 t))
75 (alien-access (mach:sigcontext-fsr (alien-value sc)))))

  ViewVC Help
Powered by ViewVC 1.1.5