source: branches/rme-fpe/level-0/l0-symbol.lisp @ 15779

Last change on this file since 15779 was 13279, checked in by gb, 10 years ago

Lots of changes from "purify" branch, mostly involving:

  • new memory layout, to support x86 function purification, static cons
  • fasloader changes to load/save string constants faster

Fasl version, image version changed; new binaries for all platforms soon.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.6 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(in-package "CCL")
19
20;;; No error checking, no interrupts, no protect_caller, no nuthin.
21;;; No error, no cons.  No problem.
22(defun %progvrestore (saved)
23  (declare (optimize (speed 3) (safety 0)))
24  (dolist (pair saved)
25    (%set-sym-value (car pair) (cdr pair))))
26
27;;; Check that something that's supposed to be a proper list of
28;;; symbols is; error otherwise.
29;;; This is called only by the compiler output of a PROGV form.
30;;; It checks for the maximum length that the progvsave subprim
31;;; can handle.
32
33(defun check-symbol-list (l &optional (max-length
34                                        (floor (- 4096 20) (* target::node-size 3))
35                                       ))
36  (let ((len (list-length l)))
37    (if (and len
38             (or (null max-length)
39                 (< len max-length))
40             (dolist (s l t) 
41               (unless (and (symbolp s)
42                            (not (constant-symbol-p s))
43                            (not (logbitp $sym_vbit_global (the fixnum (%symbol-bits s))))
44                            (ensure-binding-index s))
45                 (return nil))))
46      l
47      (error "~s is not a proper list of bindable symbols~@[ of length < ~s~]." l max-length))))
48
49;;; The type-checking done on the "plist" arg shouldn't be removed.
50(defun set-symbol-plist (sym plist)
51  (when plist
52    (let* ((len (list-length plist)))
53      (unless (and len (evenp len))
54        (error "Bad plist: ~s" plist))))
55  (let* ((vector (symptr->symvector (%symbol->symptr sym)))
56         (cell (%svref vector target::symbol.plist-cell))
57         (consp (consp cell)))
58    (if plist
59      (if consp
60        (setf (cdr cell) plist)
61        (cdr (setf (%svref vector target::symbol.plist-cell) (cons nil plist))))
62      (progn
63        (if consp
64          (setf (%svref vector target::symbol.plist-cell) (%car cell)))
65        nil))))
66
67
68(eval-when (:compile-toplevel :execute)
69  (declaim (inline %pl-search)))
70
71(defun %pl-search (l key)
72  (declare (list l) (optimize (speed 3)))
73  (loop
74    (if (eq (car l) key)
75      (return)
76      (if l
77        (setq l (cdr (the list (cdr l))))
78        (return))))
79  l)
80
81
82(defun symbol-plist (sym)
83  "Return SYMBOL's property list."
84  (let* ((cell (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)))
85    (if (consp cell)
86      (cdr cell))))
87
88
89(defun get (sym key &optional default)
90  "Look on the property list of SYMBOL for the specified INDICATOR. If this
91  is found, return the associated value, else return DEFAULT."
92  (let* ((cell (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell))
93         (tail (if (consp cell)
94                 (%pl-search (cdr cell ) key))))
95    (if tail (%cadr tail) default)))
96
97(defun put (sym key value)
98  (let* ((symptr (%symbol->symptr sym))
99         (vector (symptr->symvector symptr))
100         (cell  (%svref vector target::symbol.plist-cell))
101         (plist (if (consp cell) (cdr cell)))
102         (tail (%pl-search plist key)))
103    (if tail 
104      (%rplaca (%cdr tail) value)
105      (progn
106        (setq plist (cons key (cons value plist)))
107        (if (consp cell)
108          (setf (cdr cell) plist)
109          (setf (%svref vector target::symbol.plist-cell) (cons nil plist)))))
110    value))
111
112
113(defun get-type-predicate (name)
114  (let* ((symvec (symptr->symvector (%symbol->symptr name)))
115         (pp (%svref symvec target::symbol.package-predicate-cell)))
116    (if (consp pp)
117      (%cdr pp))))
118
119(defun set-type-predicate (name function)
120  (let* ((bits (%symbol-bits name))
121         (symvec (symptr->symvector (%symbol->symptr name)))
122         (spp (%svref symvec target::symbol.package-predicate-cell)))
123    (declare (fixnum bits))
124    (if (logbitp $sym_vbit_typeppred bits)
125      (%rplacd spp function)
126      (progn
127        (%symbol-bits name (the fixnum (bitset $sym_vbit_typeppred bits)))
128        (setf (%svref symvec target::symbol.package-predicate-cell) (cons spp function))))
129    function))
130
131(defun symbol-value (sym)
132  "Return SYMBOL's current bound value."
133  (let* ((val (%sym-value sym)))
134    (if (eq val (%unbound-marker))
135      (%kernel-restart $xvunbnd sym)
136      val)))
137
138(defun set (sym value)
139  "Set SYMBOL's value cell to NEW-VALUE."
140  (let* ((bits (%symbol-bits sym)))
141    (declare (fixnum bits))
142    (if (logbitp $sym_vbit_const bits)
143      (%err-disp $XCONST sym)
144      (%set-sym-value sym value))))
145
146(defun constant-symbol-p (sym)
147  (and (symbolp sym)
148       (%ilogbitp $sym_vbit_const (%symbol-bits sym))))
149
150;;; This leaves the SPECIAL bit alone, clears the others.
151(defun makunbound (sym)
152  "Make SYMBOL unbound, removing any value it may currently have."
153  (if (and *warn-if-redefine-kernel*
154           (constant-symbol-p sym))
155    (cerror "Make ~S be unbound anyway."
156            "~S is a constant; making it unbound might be a bad idea." sym))
157  (%symbol-bits sym (the fixnum (logand (logior #xff00 (ash 1 $sym_bit_special))
158                                        (the fixnum (%symbol-bits sym)))))
159  (%set-sym-value sym (%unbound-marker))
160  sym)
161
162(defun non-nil-symbolp (x)
163  "Returns symbol if true"
164  (if (symbolp x) x))
165
166(defun symbol-package (sym)
167  "Return the package SYMBOL was interned in, or NIL if none."
168  (let* ((pp (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.package-predicate-cell)))
169    (if (consp pp) (car pp) pp)))
170
171(defun boundp (sym)
172  "Return non-NIL if SYMBOL is bound to a value."
173  (not (eq (%sym-value sym) (%unbound-marker))))
174
175(defun make-symbol (name)
176  "Make and return a new symbol with the NAME as its print name."
177  (symvector->symptr
178   (%gvector target::subtag-symbol
179             (ensure-simple-string name) ; pname
180             (%unbound-marker)          ; value cell
181             %unbound-function%         ; function cell
182             nil                        ; package&predicate
183             0                          ; flags
184             nil                        ; plist
185             0)))                       ; binding-index
186
187(defun %symbol-bits (sym &optional new)
188  (let* ((p (%symbol->symptr sym))
189         (bits (%svref (symptr->symvector p) target::symbol.flags-cell)))
190    (if new
191      (setf (%svref (symptr->symvector p) target::symbol.flags-cell) new))
192    bits))
193
194(defun %sym-value (name)
195  (%symptr-value (%symbol->symptr name)))
196
197(defun %set-sym-value (name val)
198  (%set-symptr-value (%symbol->symptr name) val))
199   
200(defun %sym-global-value (name)
201  (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell))
202
203(defun %set-sym-global-value (name val)
204  (setf (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell) val))
205
206(defun symbol-name (sym)
207  "Return SYMBOL's name as a string."
208  #+(or ppc32-target x8632-target x8664-target)
209  (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell)
210  #+ppc64-target
211  (if sym                               ;NIL's pname is implicit
212    (%svref (%symbol->symptr sym) ppc64::symbol.pname-cell)
213    "NIL")
214  )
215
216
217
218
219(defun %global-macro-function (symbol)
220  (let* ((fbinding (fboundp symbol)))
221    (if (and (typep fbinding 'simple-vector)
222             (= (the fixnum (uvsize fbinding)) 2))
223      (let* ((fun (%svref fbinding 1)))
224        (if (functionp fun) fun)))))
225
226(defun %symbol-binding-address (sym)
227  (%symptr-binding-address (%symbol->symptr sym)))
228
229(defun symbol-binding-index (sym)
230  (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell))
231
232(defvar *interrupt-level* -1)
233
234;;; Special binding indices, and the inverse mapping between indices
235;;; and symbols
236(let* ((binding-index-lock (make-lock))
237       (binding-index-reverse-map (make-hash-table :test #'eq :weak :value))
238       (next-binding-index 0))
239  (defun %set-binding-index (val) (setq next-binding-index val))
240  (defun next-binding-index () (1+ next-binding-index))
241  (defun ensure-binding-index (sym)
242    (with-lock-grabbed (binding-index-lock)
243      (let* ((symvec (symptr->symvector (%symbol->symptr sym)))
244             (idx (%svref symvec target::symbol.binding-index-cell))
245             (bits (%symbol-bits sym)))
246        (declare (fixnum idx bits))
247        (if (or (logbitp $sym_vbit_global bits)
248                (logbitp $sym_vbit_const bits))
249          (unless (zerop idx)
250            (remhash idx binding-index-reverse-map)
251            (setf (%svref symvec target::symbol.binding-index-cell) 0))
252          (if (zerop idx)
253            (let* ((new-idx (incf next-binding-index)))
254              (setf (%svref symvec target::symbol.binding-index-cell) new-idx)
255              (setf (gethash new-idx binding-index-reverse-map) sym))))
256        sym)))
257  (defun binding-index-symbol (idx)
258    (with-lock-grabbed (binding-index-lock)
259      (gethash idx binding-index-reverse-map)))
260  (defun cold-load-binding-index (sym)
261    ;; Index may have been assigned via xloader.  Update
262    ;; reverse map
263    (with-lock-grabbed (binding-index-lock)
264      (let* ((idx (%svref (symptr->symvector (%symbol->symptr sym))
265                          target::symbol.binding-index-cell)))
266        (declare (fixnum idx))
267        (unless (zerop idx)
268          (setf (gethash idx binding-index-reverse-map) sym))))))
269
270       
271
Note: See TracBrowser for help on using the repository browser.