source: branches/qres/ccl/lib/prepare-mcl-environment.lisp @ 14308

Last change on this file since 14308 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.5 KB
Line 
1;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;; prepare-mcl-environment.lisp
19;; Load this into a PPCCL to make it into an MCL-PPC for shipping
20;; Sort of.
21
22(in-package "CCL")
23
24(defun %reset-outermost-binding (symbol value)
25  (let* ((symvector (symptr->symvector symbol))
26         (idx (%svref symvector target::symbol.binding-index-cell))
27         (marker (%no-thread-local-binding-marker)))
28    (if (> idx 0)
29      (do-db-links (db var)
30        (when (eq var idx)
31          (let* ((oldval (%fixnum-ref db (* 2 target::node-size))))
32            (unless (eq oldval marker)
33              (setf (%fixnum-ref db (* 2 target::node-size)) value))))))
34    (setf (uvref symvector target::symbol.vcell-cell) value)))
35
36(defun freeze-current-definitions ()
37  ;; Set the frozen bits so that redefine-kernel-function
38  ;; will error if a builtin function is redefined.
39  (do-all-symbols (s)
40    (when (fboundp s)
41      (%symbol-bits s (bitset $sym_fbit_frozen (%symbol-bits s)))))
42  ;; Force an error if a kernel method is redefined.
43  (make-all-methods-kernel))
44
45(defun thaw-current-definitions ()
46  ;; Clear the frozen bits on all fboundp symbols
47  (do-all-symbols (s)
48    (when (fboundp s)
49      (%symbol-bits s (bitclr $sym_fbit_frozen (%symbol-bits s)))))
50  ;; Allow redefinition of kernel methods.
51  (make-all-methods-non-kernel))
52
53(defun set-user-environment (&optional (freeze-definitions nil))
54  "Arrange that the outermost special bindings of *PACKAGE* and
55*WARN-IF-REDEFINE-KERNEL* restore values of the CL-USER package and T
56respectively, and set *CCL-SAVE-SOURCE-LOCATIONS* to :NO-TEXT.
57If the optional argument is true, marks all globally defined
58functions and methods as being predefined (this is a fairly
59expensive operation.)"
60  (when freeze-definitions
61    (freeze-current-definitions))
62  ;; enable redefine-kernel-function's error checking
63  (%reset-outermost-binding '*warn-if-redefine-kernel* t)
64  ;; Set the top-level *package* to the CL-USER package
65  (%reset-outermost-binding '*package* (find-package "CL-USER"))
66  (setq *ccl-save-source-locations* :NO-TEXT))
67
68(defun set-development-environment (&optional (thaw-definitions nil))
69  "Arrange that the outermost special bindings of *PACKAGE* and
70*WARN-IF-REDEFINE-KERNEL* restore values of the CCL package and NIL
71respectively, and set *ccl-save-source-locations* to T. If the
72optional argument is true, mark all globally defined functions and
73methods as being not predefined (this is a fairly expensive operation.)"
74  (when thaw-definitions
75    (thaw-current-definitions))
76  ;; enable redefine-kernel-function's error checking
77  (%reset-outermost-binding '*warn-if-redefine-kernel* nil)
78  ;; Set the top-level *package* to the CCL package
79  (%reset-outermost-binding '*package* (find-package "CCL"))
80  (setq *ccl-save-source-locations* T))
81 
82
83
84(defmacro in-development-mode (&body body)
85  `(let* ((*package* (find-package "CCL"))
86          (*warn-if-redefine-kernel* nil))
87    ,@body))
88
89
90
91
Note: See TracBrowser for help on using the repository browser.