source: branches/1.2-devel/ccl/lib/arglist.lisp @ 7972

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

Fix &rest &key case, yet again.

  • 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      (setq restp t))
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 (if lexprp '&lexpr '&rest) res)
187                (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res))                  (when nkeys
188                (push '&key res)
189                (let ((keyvect (lfun-keyvect lfun)))
190                  (dotimes (i (length keyvect))
191                    (push (elt keyvect i) res))))
192              (when allow-other-keys
193                (push '&allow-other-keys res))))
194          (values (nreverse res) t))
195        (values nil (zerop ncells))))))
196
197(defun arg-names-from-map (lfun pc)
198  (multiple-value-bind (nreq nopt restp nkeys allow-other-keys
199                             optinit lexprp
200                             ncells nclosed)
201      (function-args lfun)
202    (declare (ignore optinit ncells allow-other-keys))
203    (collect ((req)
204              (opt)
205              (keys))
206      (let* ((rest nil)
207             (map (car (function-symbol-map lfun))))
208        (if (and map pc)
209          (let ((total (+ nreq nopt (if (or restp lexprp) 1 0) (or nkeys 0)))
210                (idx (- (length map) nclosed)))
211            (unless (zerop total)
212              (progn
213                (dotimes (x nreq)
214                  (declare (fixnum x))
215                  (req (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x))))
216                (when (neq nopt 0)
217                  (dotimes (x (the fixnum nopt))
218                    (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)))))
219                (when (or restp lexprp)
220                  (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest)))                (when nkeys
221                                                                                              (dotimes (i (the fixnum nkeys))
222                    (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i)))))))))
223        (values (not (null map)) (req) (opt) rest (keys))))))
224             
225             
226
227
228(defvar *req-arg-names*
229  #(arg-0 arg-1 arg-2 arg-3 arg-4 arg-5 arg-6 arg-7 arg-8 arg-9))
230
231(defvar *opt-arg-names*
232  #(opt-0 opt-1 opt-2 opt-3 opt-4 opt-5 opt-6 opt-7 opt-8 opt-9))
233
234
235(defun make-arg (prefix count)
236  (cond ((and (string= prefix "ARG") (< count (length *req-arg-names*)))
237         (svref *req-arg-names* count))
238        ((and (string= prefix "OPT") (< count (length *opt-arg-names*)))
239         (svref *opt-arg-names* count))
240        (t (intern (format nil "~a-~d" prefix count) :CCL))))
241
242(defun arglist-from-compiled-def (lfun &aux (res nil) argnames)
243  (multiple-value-bind (nreq nopt restp nkeys allow-other-keys
244                             optinit lexprp
245                             ncells nclosed)
246      (function-args lfun)
247    (declare (ignore optinit ncells nclosed))
248    (flet ((push-various-args (prefix count)
249             (dotimes (i (the fixnum count))
250               (push (make-arg prefix i) res))))
251      (declare (dynamic-extent #'push-various-args))
252      ;; Treat &LEXPR like &REST.
253      (if lexprp (setq restp t lexprp nil))
254      (cond ((and (eq 0 (+ nreq nopt (or nkeys 0))) (not restp))
255             nil)
256            (t 
257             (if argnames
258               (setq res (reverse (butlast argnames (- (length argnames) nreq))))
259               (push-various-args "ARG" nreq))
260             (when (> nopt 0)
261               (push '&optional res)
262               (if argnames
263                 (setq res (append (reverse (subseq argnames nreq (+ nreq nopt))) res))
264                 (push-various-args "OPT" nopt)))
265             (when restp
266               (push '&rest res)
267               (if argnames
268                 (push (nth (+ nreq nopt) argnames) res)
269                 (push 'the-rest res)))
270             (when nkeys
271               (push '&key res)
272               (let ((keyvect (lfun-keyvect lfun)))
273                 (dotimes (i (length keyvect))
274                   (push (elt keyvect i) res))))
275             (when allow-other-keys
276               (push '&allow-other-keys res))
277             (nreverse res))))))
278
279; End of arglist.lisp
Note: See TracBrowser for help on using the repository browser.