source: trunk/ccl/lib/arglist.lisp @ 7019

Last change on this file since 7019 was 7019, checked in by gb, 13 years ago

Use PRINC-TO-STRING (not PRIN1-TO-STRING) in ARGLIST-STRING, to avoid
prinding package qualfiers (ticket:30).

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