source: trunk/ccl/level-0/l0-symbol.lisp @ 3839

Last change on this file since 3839 was 3839, checked in by gb, 15 years ago

Lots of SYMPTR->SYMVECTOR usage.

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