source: trunk/source/lib/arglist.lisp @ 14423

Last change on this file since 14423 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.9 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;;; Record pseudo-arglist info for special operators.
21(record-arglist 'catch "tag &body body")
22(record-arglist 'progn "&BODY BODY")
23(record-arglist 'function "NAME-OR-LAMBDA-EXPRESSION")
24(record-arglist 'go "TAG")
25(record-arglist 'symbol-macrolet "(&REST BINDINGS) &BODY BODY")
26(record-arglist 'locally "DECLARATION* &BODY BODY")
27(record-arglist 'setq "[SYMBOL VALUE]*")
28(record-arglist 'tagbody "&REST TAGS-OR-FORMS")
29(record-arglist 'return-from "BLOCK VALUES")
30(record-arglist 'quote '(form))
31(record-arglist 'macrolet "(&REST BINDINGS) &BODY BODY")
32(record-arglist 'the '(type-specifier form))
33(record-arglist 'eval-when "(&REST SITUATIONS) &BODY BODY")
34(record-arglist 'let* "(&REST BINDINGS) &BODY BODY")
35(record-arglist 'let "(&REST BINDINGS) &BODY BODY")
36(record-arglist 'load-time-value '(form))
37(record-arglist 'throw '(tag value))
38(record-arglist 'unwind-protect "PROTECTED-FORM &BODY CLEANUP-FORMS")
39(record-arglist 'flet "(&REST BINDINGS) &BODY BODY")
40(record-arglist 'multiple-value-call '(function &rest values-producing-forms))
41(record-arglist 'block "NAME &BODY BODY")
42(record-arglist 'labels "(&REST BINDINGS) &BODY BODY")
43(record-arglist 'multiple-value-prog1 "VALUES-PRODUCING-FORM &BODY FORMS-FOR-EFFECT")
44(record-arglist 'if '(test true &optional false))
45(record-arglist 'progv "(&REST VARS) (&REST VALUES) &BODY BODY")
46(record-arglist 'nfunction '(function-name lambda-expression))
47
48
49; Returns two values: the arglist & it's functions binding.
50; If the second arg is NIL, there was no function binding.
51(defun arglist (sym &optional include-bindings)
52  (%arglist sym include-bindings))
53
54(defun arglist-string (sym &optional include-bindings)
55  (multiple-value-bind (res type)
56                       (%arglist-internal sym include-bindings)
57    (values
58     (if (stringp res)
59       res
60       (and res (princ-to-string res)))
61     type)))
62
63(defun set-arglist (sym arglist)
64  (let ((real-sym (arglist-sym-and-def sym)))
65    (when (or real-sym (null sym))
66      (if (eq arglist t)
67        (remhash real-sym %lambda-lists%)
68        (setf (gethash real-sym %lambda-lists%) arglist)))))
69
70(defsetf arglist set-arglist)
71
72; Same as ARGLIST, but has the option of using TEMP-CONS instead of CONS
73; to cons up the list.
74(defun %arglist (sym &optional include-bindings)
75  (multiple-value-bind (res type)
76                       (%arglist-internal
77                        sym include-bindings)
78    (when (stringp res)
79      (with-input-from-string (stream res)
80        (setq res nil)
81        (let ((eof (list nil))
82              val errorp)
83          (declare (dynamic-extent eof))
84          (loop
85            (multiple-value-setq (val errorp)
86              (ignore-errors (values (read stream nil eof))))
87            (when errorp
88              (push '&rest res)
89              (push ':unparseable res)
90              (return))
91            (when (eq val eof)
92              (return))
93            (push val res))
94          (setq res
95                (if (and (null (cdr res)) (listp (car res)))
96                  (car res)
97                  (nreverse res))))))
98    (values res type)))
99
100(defun %arglist-internal (sym include-bindings 
101                              &aux def type)
102  (multiple-value-setq (sym def) (arglist-sym-and-def sym))
103  (if (generic-function-p def)
104    (values (generic-function-lambda-list def) :declaration)
105    (let ((ll (gethash sym %lambda-lists% *eof-value*))
106        (macrop (and (symbolp sym) (eq (macro-function sym) def))))
107    (flet ((strip (f) (if (stringp f) f (strip-bindings f include-bindings))))
108      (declare (dynamic-extent #'strip))
109      (cond ((neq ll *eof-value*) (values (strip ll) :declaration))
110            ((consp def)
111             ;; Presumably (lambda (... arglist) ...)
112             (values (strip (cadr def)) :definition))
113            ((neq (setq ll (getf (%lfun-info def) 'arglist *eof-value*)) *eof-value*)
114             (values ll :definition))
115            ((and (not macrop) (setq ll (uncompile-function def)))
116             (values (strip (cadr ll)) (or type :definition)))
117            ((lfunp def)
118             (multiple-value-bind (arglist gotit) 
119                                  (unless macrop (arglist-from-map def))
120               (if gotit
121                 (values arglist :analysis)
122                 (cond  (macrop (values nil :unknown))
123                       (t (values (arglist-from-compiled-def def) :analysis))))))
124            (t (values nil nil)))))))
125
126           
127
128(defun strip-bindings (arglist include-bindings)
129  (if include-bindings
130    arglist
131    (let ((res nil))
132      (do ((args arglist (%cdr args)))
133          ((not (consp args)) (nreconc res args))
134        (let ((arg (car args)))
135          (cond ((atom arg)
136                 (push arg res))
137                ((atom (car arg))
138                 (push (car arg) res))
139                (t (push (caar arg) res))))))))
140
141(defun arglist-sym-and-def (sym &aux def)
142  (cond ((functionp sym)
143         (setq def sym
144               sym (function-name def))
145         (unless (and (symbolp sym) (eq def (fboundp sym)))
146           (setq sym nil)))
147        ((listp sym)
148         (if (eq (car sym) 'setf)
149           (setq sym (setf-function-name (cadr sym))
150                 def (find-unencapsulated-definition (fboundp sym)))
151           (setq sym nil def nil)))
152        ((standard-method-p sym)
153         (setq def (closure-function 
154                    (find-unencapsulated-definition (%method-function sym)))))
155        ((and (macro-function sym))
156         (setq def (macro-function sym)))
157        ((special-operator-p sym)
158         nil)
159        (t (setq def (find-unencapsulated-definition (fboundp sym)))))
160  (values sym (if (standard-generic-function-p def) def (closure-function def))))
161
162(defun arglist-from-map (lfun)
163  (multiple-value-bind (nreq nopt restp nkeys allow-other-keys
164                        optinit lexprp
165                        ncells nclosed)
166      (function-args lfun)
167    (declare (ignore optinit))
168    (if lexprp
169      (setq restp t))
170    (let ((map (car (function-symbol-map lfun))))
171      (if map
172        (let ((total (+ nreq nopt (if restp 1 0) (or nkeys 0)))
173              (idx (- (length map) nclosed))
174              (res nil))
175          (if (%izerop total)
176            (values nil t)
177            (progn
178              (dotimes (x nreq)
179                (declare (fixnum x))
180                (push (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)) res))
181              (when (neq nopt 0)
182                (push '&optional res)
183                (dotimes (x (the fixnum nopt))
184                  (push (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)) res)))
185
186              (when restp
187                (push (if lexprp '&lexpr '&rest) res)
188                (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res))
189              (when nkeys
190                (push '&key res)
191                (let ((keyvect (lfun-keyvect lfun)))
192                  (dotimes (i (length keyvect))
193                    (push (elt keyvect i) res))))
194              (when allow-other-keys
195                (push '&allow-other-keys res))))
196          (values (nreverse res) t))
197        (values nil (zerop ncells))))))
198
199(defun arg-names-from-map (lfun pc)
200  (when lfun
201    (multiple-value-bind (nreq nopt restp nkeys allow-other-keys
202                               optinit lexprp
203                               ncells nclosed)
204        (function-args lfun)
205      (declare (ignore optinit ncells allow-other-keys))
206      (collect ((req)
207                (opt)
208                (keys))
209        (let* ((rest nil)
210               (map (if (and pc (> pc target::arg-check-trap-pc-limit))
211                        (car (function-symbol-map lfun)))))
212          (if (and map pc)
213              (let ((total (+ nreq nopt (if (or restp lexprp) 1 0) (or nkeys 0)))
214                    (idx (- (length map) nclosed)))
215                (unless (zerop total)
216                  (progn
217                    (dotimes (x (the fixnum nreq))
218                      (declare (fixnum x))
219                      (req (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x))))
220                    (when (neq nopt 0)
221                      (dotimes (x (the fixnum nopt))
222                        (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)))))
223                    (when (or restp lexprp)
224                      (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest)))
225                    (when nkeys
226                      (dotimes (i (the fixnum nkeys))
227                        (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i)))))))))
228          (values (or (not (null map))
229                      (and (eql 0 nreq) (eql 0 nopt) (not restp) (null nkeys)))
230                  (req) (opt) rest (keys)))))))
231             
232             
233
234
235(defvar *req-arg-names*
236  #(arg-0 arg-1 arg-2 arg-3 arg-4 arg-5 arg-6 arg-7 arg-8 arg-9))
237
238(defvar *opt-arg-names*
239  #(opt-0 opt-1 opt-2 opt-3 opt-4 opt-5 opt-6 opt-7 opt-8 opt-9))
240
241
242(defun make-arg (prefix count)
243  (cond ((and (string= prefix "ARG") (< count (length *req-arg-names*)))
244         (svref *req-arg-names* count))
245        ((and (string= prefix "OPT") (< count (length *opt-arg-names*)))
246         (svref *opt-arg-names* count))
247        (t (intern (format nil "~a-~d" prefix count) :CCL))))
248
249(defun arglist-from-compiled-def (lfun &aux (res nil) argnames)
250  (multiple-value-bind (nreq nopt restp nkeys allow-other-keys
251                             optinit lexprp
252                             ncells nclosed)
253      (function-args lfun)
254    (declare (ignore optinit ncells nclosed))
255    (flet ((push-various-args (prefix count)
256             (dotimes (i (the fixnum count))
257               (push (make-arg prefix i) res))))
258      (declare (dynamic-extent #'push-various-args))
259      ;; Treat &LEXPR like &REST.
260      (if lexprp (setq restp t lexprp nil))
261      (cond ((and (eq 0 (+ nreq nopt (or nkeys 0))) (not restp))
262             nil)
263            (t 
264             (if argnames
265               (setq res (reverse (butlast argnames (- (length argnames) nreq))))
266               (push-various-args "ARG" nreq))
267             (when (> nopt 0)
268               (push '&optional res)
269               (if argnames
270                 (setq res (append (reverse (subseq argnames nreq (+ nreq nopt))) res))
271                 (push-various-args "OPT" nopt)))
272             (when restp
273               (push '&rest res)
274               (if argnames
275                 (push (nth (+ nreq nopt) argnames) res)
276                 (push 'the-rest res)))
277             (when nkeys
278               (push '&key res)
279               (let ((keyvect (lfun-keyvect lfun)))
280                 (dotimes (i (length keyvect))
281                   (push (elt keyvect i) res))))
282             (when allow-other-keys
283               (push '&allow-other-keys res))
284             (nreverse res))))))
285
286; End of arglist.lisp
Note: See TracBrowser for help on using the repository browser.