source: trunk/source/level-0/l0-def.lisp @ 15601

Last change on this file since 15601 was 15540, checked in by gb, 8 years ago

Add a functional interface to THROW (%THROW).

Add %THROWING-THROUGH-CLEANUP-P, which tries to determine whether
an UNWIND-PROTECT clanup was invoked in response to THROW or "just
fell in". (Both of these functions are currently only implemented
on x86; they're primarily intended to be used in the ObjC bridge,
and the bridge is currently effectively x86-only.)

option are incompatible. The :PROPAGATE-THROW option can be used
to specify a function which can arrange that foreign cleanup code
(as established by ObjC exception handlers) is run on attempts to
"throw through them".

Make the ObjC bridge use the new mechanism to ensure that throwing
through ObjC handlers works without affecting condition handling
in methods defined by OBJC:DEFMETHOD.

Warn on first use of some deprecated ObjC bridge constructs (SEND etc.)

Fixes ticket:682 in the trunk.

Note that there may be code which has depended on the old behavior
(and that code could include the CCL IDE's handling of exception
on the event thread.) Standard CL condition-handling facilities
should work a lot better in the presence of ObjC callbacks now, and
using those facilities is likely the best approach to dealing with
any problems that arise.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.6 KB
[6]1;;;-*- Mode: Lisp; Package: CCL -*-
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[13066]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
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
15;;;   The LLGPL is also available online at
[1937]18(in-package "CCL")
[1937]20;;; primitives that manipulate function & variable definitions.
26(defun functionp (arg)
[929]27  "Return true if OBJECT is a FUNCTION, and NIL otherwise."
[6]28  (functionp arg))
30(defun lfunp (arg)
31  (functionp arg))
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))
39(setq *lfun-names* (make-hash-table :test 'eq :weak t))
41(defun lookup-lfun-name (lfun) 
42  (gethash lfun *lfun-names*))
45(defun function-name (fun)
46  (or (and (functionp fun) (lfun-name fun))
47      (if (compiled-function-p (setq fun (closure-function fun)))
[1596]48        (lfun-name fun))))
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)
[1937]59;;; redefined in sysutils.
[6]60(%fhave 'fmakunbound #'bootstrapping-fmakunbound)
62(defun bootstrapping-fset (name fn)
63  (fmakunbound name)
64  (%fhave name fn)
65  fn)
67;Redefined in sysutils.
68(%fhave 'fset #'bootstrapping-fset)
[14577]70(defun fset-symbol (name fn)
71  (fset (require-type name 'symbol) fn))
[6]74(defun bootstrapping-record-source-file (fn &optional type)
75  (declare (ignore fn type))
76  nil)
78;Redefined in l1-utils.
79(%fhave 'record-source-file #'bootstrapping-record-source-file)
82(setq *fasload-print* nil)
83(setq *save-doc-strings* t)
87(%fhave '%defun-encapsulated-maybe ;Redefined in encapsulate
88        (qlfun bootstrapping-defun-encapsulated (name fn)
89          (declare (ignore name fn))
90          nil))
92(%fhave 'encapsulated-function-name  ;Redefined in encapsulate - used in l1-io
93        (qlfun bootstrapping-encapsulated-function-name (fn)
94          (declare (ignore fn))
95          nil))
[1222]97(%fhave 'set-function-info (qlfun set-function-info  (name info)
98                                  (if (typep info 'string)
99                                    (set-documentation name 'function info))
100                                  name))
[3837]102(defun %defun (named-fn &optional info)
103  (unless (typep named-fn 'function)
104    (dbg named-fn))
105  (let* ((name (function-name named-fn)))
106    (unless (and name
107                 (or (symbolp name)
108                     (setf-function-name-p name)))
109      (dbg named-fn))
110  (record-source-file name 'function)
[14325]111  (when (not (%defun-encapsulated-maybe name named-fn))
112    (when (and (symbolp name) (macro-function name nil))
113      (warn "The macro ~s is being redefined as a function." name)
114      (fmakunbound name))
[3837]115    (fset name named-fn))
116  (set-function-info name info)
117  (when *fasload-print* (format t "~&~S~%" name))
118  name))
120(defun validate-function-name (name)
121  (if (symbolp name)
122    name
123    (if (setf-function-name-p name)
124      (setf-function-name (cadr name))
125      (report-bad-arg name 'function-name))))
[1326]127;;;    There are three kinds of things which can go in the function
128;;;    cell of a symbol: 1) A function.  2) The thing which is the
129;;;    value of %unbound-function%: a 1-element vector whose 0th
130;;;    element is a code vector which causes an "undefined function"
131;;;    error to be signalled.  3) A macro or special-form definition,
132;;;    which is a 2-element vector whose 0th element is a code vector
133;;;    which signals a "can't apply macro or special form" error when
134;;;    executed and whose 1st element is a macro or special-operator
[1596]135;;;    name.  It doesn't matter what type of gvector cases 2 and 3
136;;;    are.  Once that's decided, it wouldn't hurt if %FHAVE
137;;;    typechecked its second arg.
139(defun %fhave (name def)
140  (let* ((fname (validate-function-name name)))
[3837]141    (setf (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell) def)))
[1326]143;;; FBOUNDP is true of any symbol whose function-cell contains something other
144;;; than %unbound-function%; we expect FBOUNDP to return that something.
[6]145(defun fboundp (name)
[929]146  "Return true if name has a global function definition."
[6]147  (let* ((fname (validate-function-name name))
[3837]148         (def (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell)))
[6]149    (unless (eq def %unbound-function%)
150      def)))
[1326]152;;; %UNFHAVE doesn't seem to want to deal with SETF names or function specs.
153;;; Who does ?
155(defun %unfhave (sym)
[3837]156  (let* ((symvec (symptr->symvector (%symbol->symptr sym)))
157         (old (%svref symvec target::symbol.fcell-cell))
[1596]158         (unbound %unbound-function%))
[3837]159    (setf (%svref symvec target::symbol.fcell-cell) unbound)
[1596]160    (not (eq old unbound))))
[1937]162;;; It's guaranteed that lfun-bits is a fixnum.  Might be a 30-bit fixnum ...
[6]168(defun lfun-vector-name (fun &optional (new-name nil set-name-p))
169  (let* ((bits (lfun-bits fun)))
170    (declare (fixnum bits))
171    (if (and (logbitp $lfbits-gfn-bit bits)
172             (not (logbitp $lfbits-method-bit bits)))
[3837]173      (progn
174        (if set-name-p
175          (%gf-name fun new-name)
176          (%gf-name fun)))
[6]177      (let* ((has-name-cell (not (logbitp $lfbits-noname-bit bits))))
178        (if has-name-cell
[3714]179          (let* ((lfv (lfun-vector fun))
180                 (name-idx (- (the fixnum (uvsize lfv)) 2))
181                 (old-name (%svref lfv name-idx)))
[6]182            (declare (fixnum name-idx))
183            (if (and set-name-p (not (eq old-name new-name)))
[3714]184              (setf (%svref lfv name-idx) new-name))
[6]185            old-name))))))
187(defun lfun-name (fun &optional (new-name nil set-name-p))
188  (multiple-value-bind (stored-name stored?) (lookup-lfun-name fun)
189    (unless stored?
190      (setq stored-name (lfun-vector-name fun)))
191    (when (and set-name-p (neq new-name stored-name))
192      (if (and stored? (eq new-name (lfun-vector-name fun)))
193        (remhash fun *lfun-names*)
[1596]194        (if (logbitp $lfbits-noname-bit (the fixnum (lfun-bits fun)))   ; no name-cell in function vector.
[6]195          (puthash fun *lfun-names* new-name)
196          (lfun-vector-name fun new-name))))
197    stored-name))
[3714]199(defun lfun-bits (function &optional new)
200  (unless (functionp function)
201    (setq function (require-type function 'function)))
202  (let* ((lfv (lfun-vector function))
203         (idx (1- (the fixnum (uvsize lfv))))
204         (old (%svref lfv idx)))
205    (declare (fixnum idx))
206    (if new
207      (setf (%svref lfv idx) new))
208    old))
210(defun %macro-have (symbol macro-function)
211  (declare (special %macro-code%))      ; magically set by xloader.
[15093]212  (%fhave symbol
213          #-arm-target (vector %macro-code% macro-function)
214          #+arm-target (%fix-fn-entrypoint (gvector :pseudofunction 0 %macro-code% macro-function))))
[929]217(defun special-operator-p (symbol)
218  "If the symbol globally names a special form, return T, otherwise NIL."
[6]219  (let ((def (fboundp symbol)))
[15122]220    (and #-arm-target (typep def 'simple-vector)
221         #+arm-target (= (typecode def) arm::subtag-pseudofunction)
222         (not (lfunp #-arm-target (svref def 1)
223                     #+arm-target (uvref def 2))))))
225(defun special-form-p (x) (special-operator-p x))
227(defun setf-function-name-p (thing)
228  (and (consp thing)
229       (consp (%cdr thing))
230       (null (%cddr thing))
231       (eq (%car thing) 'setf)
232       (symbolp (%cadr thing))))
[1222]234(defun macro-function (form &optional env)
235  "If SYMBOL names a macro in ENV, returns the expansion function,
236   else returns NIL. If ENV is unspecified or NIL, use the global
237   environment only."
238  (setq form (require-type form 'symbol))
239  (when env
[15093]240    ;; A definition-environment isn't a lexical environment, but it can
241    ;; be an ancestor of one.
[1222]242    (unless (istruct-typep env 'lexical-environment)
243        (report-bad-arg env 'lexical-environment))
244      (let ((cell nil))
245        (tagbody
246          top
247          (if (setq cell (%cdr (assq form (lexenv.functions env))))
248            (return-from macro-function 
249              (if (eq (car cell) 'macro) (%cdr cell))))
250          (unless (listp (setq env (lexenv.parent-env env)))
251            (go top)))))
[15093]252      ;; Not found in env, look in function cell.
[1222]253  (%global-macro-function form))
[6485]255(defun %fixnum-ref-macptr (fixnum &optional (offset 0))
256  (%int-to-ptr (%fixnum-ref-natural fixnum offset)))
258(defun %fixnum-set-macptr (fixnum offset &optional (newval offset newval-p))
259  (%fixnum-set-natural fixnum (if newval-p offset 0) (%ptr-to-int newval))
260  newval)
[15540]262(defun nth-catch-frame-tag (n)
263  (declare (fixnum n))
264  (let* ((frame (%catch-top (%current-tcr))))
265    (dotimes (i n (%svref frame target::catch-frame.catch-tag-cell))
266      (setq frame (%svref frame
268;;; This function is magic, and it can only be called from
269;;; an unwind-protect cleanup form (making it even more magic.)
270;;; If we can tell that we reached the unwind-protect via THROW,
271;;; return a list of the target catch tag and all values being
272;;; thrown.
274(defun %throwing-through-cleanup-p ()
275  ;; when we enter and unwind-protect cleanup on x8664, the
276  ;; top frame on the tstack contains state information that's
277  ;; used both by THROW and by normal exit from the protected
278  ;; form.  That state information contains a count of the number
279  ;; of catch/unwind-protect frames still to be processed (non-zero
280  ;; only in the case where we're actually throwing), the value(s)
281  ;; being thrown, and a return address that isn't interesting to
282  ;; us.  It's an historical accident that that information is stored
283  ;; differently in the cases where a single value is being thrown
284  ;; and multiple values are thrown.
285  ;; A tstack frame is always doubleword aligned, and the first two
286  ;; words are a backpointer to the previous tstack frame and a
287  ;; pointer into the main lisp stack.  In the single value case,
288  ;; we then have 3 words: return address, frame count, value;
289  ;; in the multiple-value we have 3 fixed words (value count,
290  ;; return address, frame count) with the values following the
291  ;; frame count (value 0 follows immediately.)
292  ;; A cleanup form is always called from either .SPnthrowvalues
293  ;; of .SPnthrow1value, and those subprims can be called either
294  ;; by .SPthrow (in which case the return address in the frame
295  ;; will have no function associated with it) or by Lisp code
296  ;; (in which case it will.)
297  ;; We (have to) just assume that the frame on top of the temp
298  ;; stack is context info for the nthrow stuff.  Tracing this
299  ;; function may violate this assumption and cause misbehavior
300  ;; here.
301  (let* ((frame (%current-tsp))
302         (single-value-case (not (typep (%lisp-word-ref frame 2) 'fixnum)))
303         (frame-count (%lisp-word-ref frame (if single-value-case 3 4)))
304         (throwing (null (%return-address-function (if single-value-case
305                                                     (%lisp-word-ref frame 2)
306                                                     (%lisp-word-ref frame 3))))))
307    (declare (fixnum frame))
308    (if throwing
309      (collect ((info))
310        (info (nth-catch-frame-tag frame-count))
311        (if single-value-case
312          (info (%lisp-word-ref frame 4))
313          (let* ((valptr (+ frame 5)))
314            (declare (fixnum valptr))
315            (dotimes (i (%lisp-word-ref frame 2))
316              (declare (fixnum i))
317              (info (%lisp-word-ref valptr i)))))
318        (info)))))
[1937]320;;; end of l0-def.lisp
Note: See TracBrowser for help on using the repository browser.