source: branches/qres/ccl/level-0/l0-symbol.lisp @ 14055

Last change on this file since 14055 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: 9.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(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    (if plist
58      (if (consp cell)
59        (setf (cdr cell) plist)
60        (cdr (setf (%svref vector target::symbol.plist-cell) (cons nil plist))))
61      (if (car cell)
62        (setf (cdr cell) nil)
63        (if cell (setf (cdr cell) nil))))))
64
65
66(eval-when (:compile-toplevel :execute)
67  (declaim (inline %pl-search)))
68
69(defun %pl-search (l key)
70  (declare (list l) (optimize (speed 3)))
71  (loop
72    (if (eq (car l) key)
73      (return)
74      (if l
75        (setq l (cdr (the list (cdr l))))
76        (return))))
77  l)
78
79
80(defun symbol-plist (sym)
81  "Return SYMBOL's property list."
82  (cdr (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)))
83
84
85(defun get (sym key &optional default)
86  "Look on the property list of SYMBOL for the specified INDICATOR. If this
87  is found, return the associated value, else return DEFAULT."
88  (let* ((tail (%pl-search
89                (cdr (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)) key)))
90    (if tail (%cadr tail) default)))
91
92(defun put (sym key value)
93  (let* ((symptr (%symbol->symptr sym))
94         (vector (symptr->symvector symptr))
95         (cell  (%svref vector target::symbol.plist-cell))
96         (plist (cdr cell))
97         (tail (%pl-search plist key)))
98    (if tail 
99      (%rplaca (%cdr tail) value)
100      (progn
101        (setq plist (cons key (cons value plist)))
102        (if cell
103          (setf (cdr cell) plist)
104          (setf (%svref vector target::symbol.plist-cell) (cons nil plist)))))
105    value))
106
107
108(defun get-type-predicate (name)
109  (let* ((symvec (symptr->symvector (%symbol->symptr name)))
110         (pp (%svref symvec target::symbol.package-predicate-cell)))
111    (if (consp pp)
112      (%cdr pp))))
113
114(defun set-type-predicate (name function)
115  (let* ((bits (%symbol-bits name))
116         (symvec (symptr->symvector (%symbol->symptr name)))
117         (spp (%svref symvec target::symbol.package-predicate-cell)))
118    (declare (fixnum bits))
119    (if (logbitp $sym_vbit_typeppred bits)
120      (%rplacd spp function)
121      (progn
122        (%symbol-bits name (the fixnum (bitset $sym_vbit_typeppred bits)))
123        (setf (%svref symvec target::symbol.package-predicate-cell) (cons spp function))))
124    function))
125
126(defun symbol-value (sym)
127  "Return SYMBOL's current bound value."
128  (let* ((val (%sym-value sym)))
129    (if (eq val (%unbound-marker))
130      (%kernel-restart $xvunbnd sym)
131      val)))
132
133(defun set (sym value)
134  "Set SYMBOL's value cell to NEW-VALUE."
135  (let* ((bits (%symbol-bits sym)))
136    (declare (fixnum bits))
137    (if (logbitp $sym_vbit_const bits)
138      (%err-disp $XCONST sym)
139      (%set-sym-value sym value))))
140
141(defun constant-symbol-p (sym)
142  (and (symbolp sym)
143       (%ilogbitp $sym_vbit_const (%symbol-bits sym))))
144
145;;; This leaves the SPECIAL bit alone, clears the others.
146(defun makunbound (sym)
147  "Make SYMBOL unbound, removing any value it may currently have."
148  (if (and *warn-if-redefine-kernel*
149           (constant-symbol-p sym))
150    (cerror "Make ~S be unbound anyway."
151            "~S is a constant; making it unbound might be a bad idea." sym))
152  (%symbol-bits sym (the fixnum (logand (logior #xff00 (ash 1 $sym_bit_special))
153                                        (the fixnum (%symbol-bits sym)))))
154  (%set-sym-value sym (%unbound-marker))
155  sym)
156
157(defun non-nil-symbolp (x)
158  "Returns symbol if true"
159  (if (symbolp x) x))
160
161(defun symbol-package (sym)
162  "Return the package SYMBOL was interned in, or NIL if none."
163  (let* ((pp (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.package-predicate-cell)))
164    (if (consp pp) (car pp) pp)))
165
166(defun boundp (sym)
167  "Return non-NIL if SYMBOL is bound to a value."
168  (not (eq (%sym-value sym) (%unbound-marker))))
169
170(defun make-symbol (name)
171  "Make and return a new symbol with the NAME as its print name."
172  (symvector->symptr
173   (%gvector target::subtag-symbol
174             (ensure-simple-string name) ; pname
175             (%unbound-marker)          ; value cell
176             %unbound-function%         ; function cell
177             nil                        ; package&predicate
178             0                          ; flags
179             nil                        ; plist
180             0)))                       ; binding-index
181
182(defun %symbol-bits (sym &optional new)
183  (let* ((p (%symbol->symptr sym))
184         (bits (%svref (symptr->symvector p) target::symbol.flags-cell)))
185    (if new
186      (setf (%svref (symptr->symvector p) target::symbol.flags-cell) new))
187    bits))
188
189(defun %sym-value (name)
190  (%symptr-value (%symbol->symptr name)))
191
192(defun %set-sym-value (name val)
193  (%set-symptr-value (%symbol->symptr name) val))
194   
195(defun %sym-global-value (name)
196  (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell))
197
198(defun %set-sym-global-value (name val)
199  (setf (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell) val))
200
201(defun symbol-name (sym)
202  "Return SYMBOL's name as a string."
203  #+(or ppc32-target x8632-target x8664-target)
204  (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell)
205  #+ppc64-target
206  (if sym                               ;NIL's pname is implicit
207    (%svref (%symbol->symptr sym) ppc64::symbol.pname-cell)
208    "NIL")
209  )
210
211
212
213
214(defun %global-macro-function (symbol)
215  (let* ((fbinding (fboundp symbol)))
216    (if (and (typep fbinding 'simple-vector)
217             (= (the fixnum (uvsize fbinding)) 2))
218      (let* ((fun (%svref fbinding 1)))
219        (if (functionp fun) fun)))))
220
221(defun %symbol-binding-address (sym)
222  (%symptr-binding-address (%symbol->symptr sym)))
223
224(defun symbol-binding-index (sym)
225  (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell))
226
227(defvar *interrupt-level* -1)
228
229;;; Special binding indices, and the inverse mapping between indices
230;;; and symbols
231(let* ((binding-index-lock (make-lock))
232       (binding-index-reverse-map (make-hash-table :test #'eq :weak :value))
233       (next-binding-index 0))
234  (defun %set-binding-index (val) (setq next-binding-index val))
235  (defun next-binding-index () (1+ next-binding-index))
236  (defun ensure-binding-index (sym)
237    (with-lock-grabbed (binding-index-lock)
238      (let* ((symvec (symptr->symvector (%symbol->symptr sym)))
239             (idx (%svref symvec target::symbol.binding-index-cell))
240             (bits (%symbol-bits sym)))
241        (declare (fixnum idx bits))
242        (if (or (logbitp $sym_vbit_global bits)
243                (logbitp $sym_vbit_const bits))
244          (unless (zerop idx)
245            (remhash idx binding-index-reverse-map)
246            (setf (%svref symvec target::symbol.binding-index-cell) 0))
247          (if (zerop idx)
248            (let* ((new-idx (incf next-binding-index)))
249              (setf (%svref symvec target::symbol.binding-index-cell) new-idx)
250              (setf (gethash new-idx binding-index-reverse-map) sym))))
251        sym)))
252  (defun binding-index-symbol (idx)
253    (with-lock-grabbed (binding-index-lock)
254      (gethash idx binding-index-reverse-map)))
255  (defun cold-load-binding-index (sym)
256    ;; Index may have been assigned via xloader.  Update
257    ;; reverse map
258    (with-lock-grabbed (binding-index-lock)
259      (let* ((idx (%svref (symptr->symvector (%symbol->symptr sym))
260                          target::symbol.binding-index-cell)))
261        (declare (fixnum idx))
262        (unless (zerop idx)
263          (setf (gethash idx binding-index-reverse-map) sym))))))
264
265       
266
Note: See TracBrowser for help on using the repository browser.