Skip to content
Snippets Groups Projects
Commit f12c0cef authored by wlott's avatar wlott
Browse files

Fixed load-time-value hackery for the gengc system. Tweeked in-package

forms to get rid of warnings.
parent ba6afac0
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.35 1993/05/22 14:01:25 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.36 1993/05/25 18:39:59 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -16,18 +16,18 @@ ...@@ -16,18 +16,18 @@
;;; ;;;
;;; Written by Skef Wholey and Rob MacLachlan. ;;; Written by Skef Wholey and Rob MacLachlan.
;;; ;;;
(in-package "LISP" :use '("SYSTEM" "DEBUG")) (in-package :lisp)
(export '(most-positive-fixnum most-negative-fixnum sleep (export '(most-positive-fixnum most-negative-fixnum sleep
++ +++ ** *** // ///)) ++ +++ ** *** // ///))
(in-package "SYSTEM" :nicknames '("SYS")) (in-package :system)
(export '(compiler-version scrub-control-stack)) (export '(compiler-version scrub-control-stack))
(in-package "EXTENSIONS") (in-package :extensions)
(export '(quit *prompt*)) (export '(quit *prompt*))
(in-package "LISP") (in-package :lisp)
;;; Make the error system enable interrupts. ;;; Make the error system enable interrupts.
...@@ -91,6 +91,7 @@ ...@@ -91,6 +91,7 @@
(defun %initial-function () (defun %initial-function ()
"Gives the world a shove and hopes it spins." "Gives the world a shove and hopes it spins."
(%primitive print "In initial-function, and running.")
#-gengc (setf *already-maybe-gcing* t) #-gengc (setf *already-maybe-gcing* t)
#-gengc (setf *gc-inhibit* t) #-gengc (setf *gc-inhibit* t)
#-gengc (setf *need-to-collect-garbage* nil) #-gengc (setf *need-to-collect-garbage* nil)
...@@ -100,7 +101,6 @@ ...@@ -100,7 +101,6 @@
#-gengc (setf unix::*interrupts-enabled* t) #-gengc (setf unix::*interrupts-enabled* t)
#-gengc (setf unix::*interrupt-pending* nil) #-gengc (setf unix::*interrupt-pending* nil)
(setf *type-system-initialized* nil) (setf *type-system-initialized* nil)
(%primitive print "In initial-function, and running.")
;; Many top-level forms call INFO, (SETF INFO). ;; Many top-level forms call INFO, (SETF INFO).
(print-and-call c::globaldb-init) (print-and-call c::globaldb-init)
...@@ -125,9 +125,12 @@ ...@@ -125,9 +125,12 @@
(setf (svref *load-time-values* (third fun)) (setf (svref *load-time-values* (third fun))
(funcall (second fun)))) (funcall (second fun))))
(:load-time-value-fixup (:load-time-value-fixup
#-gengc
(setf (sap-ref-32 (second fun) 0) (setf (sap-ref-32 (second fun) 0)
(get-lisp-obj-address (get-lisp-obj-address
(svref *load-time-values* (third fun))))) (svref *load-time-values* (third fun))))
#+gengc
(do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
(t (t
(%primitive print (%primitive print
"Bogus fixup in *lisp-initialization-functions*") "Bogus fixup in *lisp-initialization-functions*")
...@@ -183,6 +186,28 @@ ...@@ -183,6 +186,28 @@
(write-line "You're certainly a clever child."))) (write-line "You're certainly a clever child.")))
(unix:unix-exit 0)) (unix:unix-exit 0))
#+gengc
(defun do-load-time-value-fixup (object offset value)
(declare (type index offset))
(macrolet ((lose (msg)
`(progn
(%primitive print ,msg)
(%halt))))
(typecase object
(list
(case offset
(0 (setf (car object) value))
(1 (setf (cdr object) value))
(t (lose "Bogus offset in cons cell."))))
(instance
(setf (%instance-ref object (- offset vm:instance-slots-offset)) value))
(code-component
(setf (code-header-ref object offset) value))
(simple-vector
(setf (svref object (- offset vm:vector-data-offset)) value))
(t
(lose "Unknown kind of object for load-time-value fixup.")))))
;;;; Initialization functions: ;;;; Initialization functions:
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment