source: branches/ia32/level-0/l0-def.lisp @ 7430

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

%FIXNUM-REF-MACPTR, %FIXNUM-SET-MACPTR: move here.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.5 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;;; primitives that manipulate function & variable definitions.
20
21
22
23
24
25(defun functionp (arg)
26  "Return true if OBJECT is a FUNCTION, and NIL otherwise."
27  (functionp arg))
28
29(defun lfunp (arg)
30  (functionp arg))
31
32(defun %proclaim-special (sym &optional initp)
33  (let* ((oldbits (%symbol-bits sym)))
34    (declare (fixnum oldbits))
35    (%symbol-bits sym (bitset $sym_vbit_special oldbits))
36    initp))
37
38(setq *lfun-names* (make-hash-table :test 'eq :weak t))
39
40(defun lookup-lfun-name (lfun) 
41  (gethash lfun *lfun-names*))
42
43
44(defun function-name (fun)
45  (or (and (functionp fun) (lfun-name fun))
46      (if (compiled-function-p (setq fun (closure-function fun)))
47        (lfun-name fun))))
48
49
50(defun bootstrapping-fmakunbound (name)
51  (when (consp name)
52    (unless (eq (%car name) 'setf)
53      (error "Function spec handler not loaded yet"))
54    (setq name (setf-function-name (cadr name))))
55  (%unfhave name)
56  name)
57
58;;; redefined in sysutils.
59(%fhave 'fmakunbound #'bootstrapping-fmakunbound)
60
61(defun bootstrapping-fset (name fn)
62  (fmakunbound name)
63  (%fhave name fn)
64  fn)
65
66;Redefined in sysutils.
67(%fhave 'fset #'bootstrapping-fset)
68
69(defun bootstrapping-record-source-file (fn &optional type)
70  (declare (ignore fn type))
71  nil)
72
73;Redefined in l1-utils.
74(%fhave 'record-source-file #'bootstrapping-record-source-file)
75
76
77(setq *fasload-print* nil)
78(setq *save-doc-strings* t)
79
80
81
82(%fhave '%defun-encapsulated-maybe ;Redefined in encapsulate
83        (qlfun bootstrapping-defun-encapsulated (name fn)
84          (declare (ignore name fn))
85          nil))
86
87(%fhave 'encapsulated-function-name  ;Redefined in encapsulate - used in l1-io
88        (qlfun bootstrapping-encapsulated-function-name (fn)
89          (declare (ignore fn))
90          nil))
91
92(%fhave '%traced-p  ;Redefined in encapsulate - used in l1-io
93        (qlfun bootstrapping-%traced-p (fn)
94          (declare (ignore fn))
95          nil))
96
97(%fhave '%advised-p  ;Redefined in encapsulate used in l1-io
98        (qlfun bootstrapping-%advised-p (fn)
99          (declare (ignore fn))
100          nil))
101
102(%fhave 'set-function-info (qlfun set-function-info  (name info)
103                                  (if (typep info 'string)
104                                    (set-documentation name 'function info))
105                                  name))
106
107(defun %defun (named-fn &optional info)
108  (unless (typep named-fn 'function)
109    (dbg named-fn))
110  (let* ((name (function-name named-fn)))
111    (unless (and name
112                 (or (symbolp name)
113                     (setf-function-name-p name)))
114      (dbg named-fn))
115  (record-source-file name 'function)
116  (if (not (%defun-encapsulated-maybe name named-fn))
117    (fset name named-fn))
118  (set-function-info name info)
119  (when *fasload-print* (format t "~&~S~%" name))
120  name))
121
122(defun validate-function-name (name)
123  (if (symbolp name)
124    name
125    (if (setf-function-name-p name)
126      (setf-function-name (cadr name))
127      (report-bad-arg name 'function-name))))
128
129;;;    There are three kinds of things which can go in the function
130;;;    cell of a symbol: 1) A function.  2) The thing which is the
131;;;    value of %unbound-function%: a 1-element vector whose 0th
132;;;    element is a code vector which causes an "undefined function"
133;;;    error to be signalled.  3) A macro or special-form definition,
134;;;    which is a 2-element vector whose 0th element is a code vector
135;;;    which signals a "can't apply macro or special form" error when
136;;;    executed and whose 1st element is a macro or special-operator
137;;;    name.  It doesn't matter what type of gvector cases 2 and 3
138;;;    are.  Once that's decided, it wouldn't hurt if %FHAVE
139;;;    typechecked its second arg.
140
141(defun %fhave (name def)
142  (let* ((fname (validate-function-name name)))
143    (setf (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell) def)))
144
145;;; FBOUNDP is true of any symbol whose function-cell contains something other
146;;; than %unbound-function%; we expect FBOUNDP to return that something.
147(defun fboundp (name)
148  "Return true if name has a global function definition."
149  (let* ((fname (validate-function-name name))
150         (def (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell)))
151    (unless (eq def %unbound-function%)
152      def)))
153
154;;; %UNFHAVE doesn't seem to want to deal with SETF names or function specs.
155;;; Who does ?
156
157(defun %unfhave (sym)
158  (let* ((symvec (symptr->symvector (%symbol->symptr sym)))
159         (old (%svref symvec target::symbol.fcell-cell))
160         (unbound %unbound-function%))
161    (setf (%svref symvec target::symbol.fcell-cell) unbound)
162    (not (eq old unbound))))
163
164;;; It's guaranteed that lfun-bits is a fixnum.  Might be a 30-bit fixnum ...
165
166
167
168
169
170(defun lfun-vector-name (fun &optional (new-name nil set-name-p))
171  (let* ((bits (lfun-bits fun)))
172    (declare (fixnum bits))
173    (if (and (logbitp $lfbits-gfn-bit bits)
174             (not (logbitp $lfbits-method-bit bits)))
175      (progn
176        (if set-name-p
177          (%gf-name fun new-name)
178          (%gf-name fun)))
179      (let* ((has-name-cell (not (logbitp $lfbits-noname-bit bits))))
180        (if has-name-cell
181          (let* ((lfv (lfun-vector fun))
182                 (name-idx (- (the fixnum (uvsize lfv)) 2))
183                 (old-name (%svref lfv name-idx)))
184            (declare (fixnum name-idx))
185            (if (and set-name-p (not (eq old-name new-name)))
186              (setf (%svref lfv name-idx) new-name))
187            old-name))))))
188
189(defun lfun-name (fun &optional (new-name nil set-name-p))
190  (multiple-value-bind (stored-name stored?) (lookup-lfun-name fun)
191    (unless stored?
192      (setq stored-name (lfun-vector-name fun)))
193    (when (and set-name-p (neq new-name stored-name))
194      (if (and stored? (eq new-name (lfun-vector-name fun)))
195        (remhash fun *lfun-names*)
196        (if (logbitp $lfbits-noname-bit (the fixnum (lfun-bits fun)))   ; no name-cell in function vector.
197          (puthash fun *lfun-names* new-name)
198          (lfun-vector-name fun new-name))))
199    stored-name))
200
201(defun lfun-bits (function &optional new)
202  (unless (functionp function)
203    (setq function (require-type function 'function)))
204  (let* ((lfv (lfun-vector function))
205         (idx (1- (the fixnum (uvsize lfv))))
206         (old (%svref lfv idx)))
207    (declare (fixnum idx))
208    (if new
209      (setf (%svref lfv idx) new))
210    old))
211   
212(defun %macro-have (symbol macro-function)
213  (declare (special %macro-code%))      ; magically set by xloader.
214  (%fhave symbol (vector %macro-code% macro-function)))
215
216
217(defun special-operator-p (symbol)
218  "If the symbol globally names a special form, return T, otherwise NIL."
219  (let ((def (fboundp symbol)))
220    (and (typep def 'simple-vector)
221         (not (lfunp (svref def 1))))))
222
223(defun special-form-p (x) (special-operator-p x))
224
225(defun setf-function-name-p (thing)
226  (and (consp thing)
227       (consp (%cdr thing))
228       (null (%cddr thing))
229       (eq (%car thing) 'setf)
230       (symbolp (%cadr thing))))
231
232(defun macro-function (form &optional env)
233  "If SYMBOL names a macro in ENV, returns the expansion function,
234   else returns NIL. If ENV is unspecified or NIL, use the global
235   environment only."
236  (setq form (require-type form 'symbol))
237  (when env
238    ; A definition-environment isn't a lexical environment, but it can
239    ; be an ancestor of one.
240    (unless (istruct-typep env 'lexical-environment)
241        (report-bad-arg env 'lexical-environment))
242      (let ((cell nil))
243        (tagbody
244          top
245          (if (setq cell (%cdr (assq form (lexenv.functions env))))
246            (return-from macro-function 
247              (if (eq (car cell) 'macro) (%cdr cell))))
248          (unless (listp (setq env (lexenv.parent-env env)))
249            (go top)))))
250      ; Not found in env, look in function cell.
251  (%global-macro-function form))
252
253(defun %fixnum-ref-macptr (fixnum &optional (offset 0))
254  (%int-to-ptr (%fixnum-ref-natural fixnum offset)))
255
256(defun %fixnum-set-macptr (fixnum offset &optional (newval offset newval-p))
257  (%fixnum-set-natural fixnum (if newval-p offset 0) (%ptr-to-int newval))
258  newval)
259
260;;; end of l0-def.lisp
Note: See TracBrowser for help on using the repository browser.