/[cmucl]/src/code/lispinit.lisp
ViewVC logotype

Diff of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.25 by wlott, Sun Dec 15 10:21:38 1991 UTC revision 1.26 by wlott, Mon Dec 16 18:47:09 1991 UTC
# Line 470  Line 470 
470  ;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms  ;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms
471  ;;; in Unwind-Protects will get executed.  ;;; in Unwind-Protects will get executed.
472    
473  (proclaim '(special *lisp-initialization-functions*))  (proclaim '(special *lisp-initialization-functions*
474                        *load-time-values*))
475    
476  (eval-when (compile)  (eval-when (compile)
477    (defmacro print-and-call (name)    (defmacro print-and-call (name)
# Line 499  Line 500 
500    ;; Some of the random top-level forms call Make-Array, which calls Subtypep...    ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
501    (print-and-call type-init)    (print-and-call type-init)
502    
503    (setf *lisp-initialization-functions*    (let ((funs (nreverse *lisp-initialization-functions*)))
504          (nreverse *lisp-initialization-functions*))      (%primitive print "Calling top-level forms.")
505    (%primitive print "Calling top-level forms.")      (dolist (fun funs)
506    (dolist (fun *lisp-initialization-functions*)        (typecase fun
507      (funcall fun))          (function
508             (funcall fun))
509            (cons
510             (case (car fun)
511               (:load-time-value
512                (setf (svref *load-time-values* (third fun))
513                      (funcall (second fun))))
514               (:load-time-value-fixup
515                (setf (sap-ref-32 (second fun) 0)
516                      (get-lisp-obj-address
517                       (svref *load-time-values* (third fun)))))
518               (t
519                (%primitive print
520                            "Bogus fixup in *lisp-initialization-functions*")
521                (%halt))))
522            (t
523             (%primitive print
524                         "Bogus function in *lisp-initialization-functions*")
525             (%halt)))))
526    (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.    (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
527      (makunbound '*load-time-values*)
528    
529    ;; Only do this after top level forms have run, 'cause thats where    ;; Only do this after top level forms have run, 'cause thats where
530    ;; deftypes are.    ;; deftypes are.

Legend:
Removed from v.1.25  
changed lines
  Added in v.1.26

  ViewVC Help
Powered by ViewVC 1.1.5