source: branches/qres/ccl/level-0/l0-def.lisp @ 14261

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