Added parameter-specifier method for destructuring-lambda-list.
[com-informatimago:com-informatimago.git] / common-lisp / lisp-sexp / source-form.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               source-form.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;
9 ;;;;    This package exports functions to parse and manipulate
10 ;;;;    Common Lisp sources as lisp forms (such as in macros).
11 ;;;;
12 ;;;;AUTHORS
13 ;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
14 ;;;;MODIFICATIONS
15 ;;;;    2010-02-06 <PJB> Corrected the superclass of orakawbe-ll.
16 ;;;;                     preqvars instanciated the wrong parameter class.
17 ;;;;                     bodyvar poped the body parameter name.
18 ;;;;    2006-05-25 <PJB> Created
19 ;;;;BUGS
20 ;;;;LEGAL
21 ;;;;    GPL
22 ;;;;
23 ;;;;    Copyright Pascal Bourguignon 2006 - 2007
24 ;;;;
25 ;;;;    This program is free software; you can redistribute it and/or
26 ;;;;    modify it under the terms of the GNU General Public License
27 ;;;;    as published by the Free Software Foundation; either version
28 ;;;;    2 of the License, or (at your option) any later version.
29 ;;;;
30 ;;;;    This program is distributed in the hope that it will be
31 ;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
32 ;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
33 ;;;;    PURPOSE.  See the GNU General Public License for more details.
34 ;;;;
35 ;;;;    You should have received a copy of the GNU General Public
36 ;;;;    License along with this program; if not, write to the Free
37 ;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
38 ;;;;    Boston, MA 02111-1307 USA
39 ;;;;**************************************************************************
40 (in-package "COMMON-LISP-USER")
41
42 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM"
43   (:use "COMMON-LISP")
44   (:export
45    ;; Parameter Classes:
46    "PARAMETER" "ENVIRONMENT-PARAMETER" "WHOLE-PARAMETER"
47    "REST-PARAMETER" "BODY-PARAMETER"
48    "SPECIALIZED-PARAMETER" "AUXILIARY-PARAMETER"
49    "OPTIONAL-PARAMETER" "GENERIC-OPTIONAL-PARAMETER"
50    "KEYWORD-PARAMETER"  "GENERIC-KEYWORD-PARAMETER"
51    ;; Parameter Methods:
52    "PARAMETER-NAME" "PARAMETER-LABEL" #|"PARAMETER-HELP-LABEL"|#
53    "PARAMETER-LAMBDA-LIST-KEYWORD"
54    "PARAMETER-SPECIFIER" "PARAMETER-INDICATOR" "PARAMETER-INDICATOR-P"
55    "PARAMETER-INITFORM" "PARAMETER-INITFORM-P" "PARAMETER-KEYWORD"
56    "PARAMETER-KEYWORD-P" "ENSURE-PARAMETER-KEYWORD"
57    "PARAMETER-SPECIALIZER" "PARAMETER-SPECIALIZER-P"
58    ;; Lambda-List Classes:
59    "LAMBDA-LIST" "ORDINARY-LAMBDA-LIST" "BOA-LAMBDA-LIST"
60    "SPECIALIZED-LAMBDA-LIST" "MODIFY-MACRO-LAMBDA-LIST" "GENERIC-LAMBDA-LIST"
61    "MACRO-LAMBDA-LIST" "TYPE-LAMBDA-LIST" "DESTRUCTURING-LAMBDA-LIST"
62    "SETF-LAMBDA-LIST" "METHOD-COMBINATION-LAMBDA-LIST"
63    ;; Lambda-List Methods:
64    "ORIGINAL-LAMBDA-LIST" #|"LAMBDA-LIST-PARAMETERS"|#
65    "LAMBDA-LIST-MANDATORY-PARAMETERS"  "LAMBDA-LIST-OPTIONAL-PARAMETERS"
66    "LAMBDA-LIST-REST-PARAMETER" "LAMBDA-LIST-ALLOW-OTHER-KEYS-P" "LAMBDA-LIST-KEY-P"
67    "LAMBDA-LIST-KEYWORD-PARAMETERS" "LAMBDA-LIST-ENVIRONMENT-PARAMETER"
68    "LAMBDA-LIST-AUXILIARY-PARAMETERS" "LAMBDA-LIST-WHOLE-PARAMETER"
69    "LAMBDA-LIST-ENVIRONMENT-PARAMETER" "LAMBDA-LIST-BODY-PARAMETER"
70    "LAMBDA-LIST-KIND" "LAMBDA-LIST-ALLOWED-KEYWORDS"
71    "LAMBDA-LIST-MANDATORY-PARAMETER-COUNT"
72    "LAMBDA-LIST-OPTIONAL-PARAMETER-COUNT" "LAMBDA-LIST-REST-P"
73    "LAMBDA-LIST-MANDATORY-PARAMETERS-P" "LAMBDA-LIST-OPTIONAL-PARAMETERS-P"
74    "LAMBDA-LIST-REST-PARAMETER-P" "LAMBDA-LIST-AUXILIARY-PARAMETERS-P"
75    "LAMBDA-LIST-WHOLE-PARAMETER-P" "LAMBDA-LIST-BODY-PARAMETER-P"
76    "LAMBDA-LIST-ENVIRONMENT-PARAMETER-P"
77    ;; Parsing lambda-lists:
78    "PARSE-LAMBDA-LIST" "PARSE-ORIGINAL-LAMBDA-LIST"
79    ;; Generating information from a lambda-list instance:
80    "MAKE-HELP" "MAKE-ARGUMENT-LIST" "MAKE-ARGUMENT-LIST-FORM" "MAKE-LAMBDA-LIST"
81    ;; Parsing sources:
82    "EXTRACT-DOCUMENTATION" "EXTRACT-DECLARATIONS" "EXTRACT-BODY"
83    "DECLARATIONS-HASH-TABLE"
84    "EXTRACT-METHOD-QUALIFIERS"   "EXTRACT-METHOD-LAMBDA-LIST"
85    "EXTRACT-METHOD-DDL"          "EXTRACT-METHOD-DOCUMENTATION"
86    "EXTRACT-METHOD-DECLARATIONS" "EXTRACT-METHOD-BODY"
87    ;; "DEFUN""DEFGENERIC""DEFMETHOD"
88    ;; *CALL-STACK*" ;; not yet
89    )
90   (:shadow "READTABLE"
91            "COPY-READTABLE" "MAKE-DISPATCH-MACRO-CHARACTER"
92            "READ" "READ-PRESERVING-WHITESPACE"
93            "READ-DELIMITED-LIST"
94            "READ-FROM-STRING"
95            "READTABLE-CASE" "READTABLEP"
96            "SET-DISPATCH-MACRO-CHARACTER" "GET-DISPATCH-MACRO-CHARACTER"
97            "SET-MACRO-CHARACTER" "GET-MACRO-CHARACTER"
98            "SET-SYNTAX-FROM-CHAR"
99            "WITH-STANDARD-IO-SYNTAX"
100            "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*"
101            "*READ-SUPPRESS*" "*READTABLE*")
102   (:documentation "
103     This package exports functions to parse and manipulate
104     Common Lisp sources as lisp forms (such as in macros).
105
106     Copyright Pascal J. Bourguignon 2003 - 2007
107     This package is provided under the GNU General Public License.
108     See the source file for details."))
109 (in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM")
110
111
112 ;;;----------------------------------------
113 ;;; Parameter specifications in lambda-lists
114 ;;;----------------------------------------
115
116 ;; Syntax of parameter specifications:
117 ;;
118 ;;    name
119 ;; | (name [ specializer ])                       ; for specialized lambda-lists
120 ;; | (name [ init-form [ indicator ]])            ; for &key &optional
121 ;; | ((name keyword) [ init-form [ indicator ]])  ; for &key
122
123
124 (defmacro define-default-generic (name class default-value)
125   `(defgeneric ,name (self)
126      (:method ((self ,class)) (declare (ignore self)) ,default-value)))
127
128 ;;;--------------------
129
130 (defgeneric parameter-name-p (self))
131 (defgeneric parse-parameter (self form))
132 (defgeneric parse-parameter-name (self form))
133 (defgeneric ensure-parameter-keyword (self))
134 (defgeneric lambda-list-mandatory-parameter-count (self))
135 (defgeneric lambda-list-optional-parameter-count (self))
136 (defgeneric parse-optvars (self current slot lambda-list-keyword class))
137 (defgeneric auxvars (self current))
138 (defgeneric optvars (self current))
139 (defgeneric goptvars (self current))
140 (defgeneric parse-keyvars (self current class))
141 (defgeneric keyvars (self current))
142 (defgeneric gkeyvars (self current))
143 (defgeneric parse-reqvars (self current class))
144 (defgeneric reqvars (self current))
145 (defgeneric sreqvars (self current))
146 (defgeneric preqvars (self current))
147 (defgeneric parse-original-lambda-list (self))
148 (defgeneric make-help (self))
149 (defgeneric make-argument-list (self))
150 (defgeneric make-lambda-list (self))
151
152 ;;;--------------------
153
154 (defclass parameter ()
155   ((name :accessor parameter-name
156          :initarg :name
157          :type     symbol
158          :documentation "The name of the parameter."))
159   (:documentation "A generic parameter."))
160
161 (defmethod parameter-name-p ((self parameter))
162   (slot-boundp self 'name))
163
164
165 (define-default-generic parameter-indicator     parameter nil)
166 (define-default-generic parameter-indicator-p   parameter nil)
167 (define-default-generic parameter-initform      parameter nil)
168 (define-default-generic parameter-initform-p    parameter nil)
169 (define-default-generic parameter-keyword       parameter nil)
170 (define-default-generic parameter-keyword-p     parameter nil)
171 (define-default-generic parameter-specializer   parameter nil)
172 (define-default-generic parameter-specializer-p parameter nil)
173
174
175 (defmethod parse-parameter-name ((self parameter) form)
176   (if (symbolp form)
177       (setf (parameter-name self) form)
178       (error "Invalid parameter name: ~S" form))
179   self)
180
181
182 (defmethod parse-parameter ((self parameter) form)
183   (parse-parameter-name self form))
184
185 (defmethod print-object ((self parameter) stream)
186   (print-unreadable-object (self stream :identity t)
187     (format stream "~A ~S"
188             (parameter-lambda-list-keyword self)
189             (parameter-specifier self))))
190
191 ;;;--------------------
192
193 (defclass environment-parameter (parameter)
194   ()
195   (:documentation "An &ENVIRONMENT parameter."))
196
197 (defclass whole-parameter (parameter)
198   ()
199   (:documentation "A &WHOLE parameter."))
200
201 (defclass rest-parameter (parameter)
202   ()
203   (:documentation "A &REST parameter."))
204
205 (defclass body-parameter (parameter)
206   ()
207   (:documentation "A &BODY parameter."))
208
209
210 ;;;--------------------
211
212 (defclass specialized-parameter (parameter)
213   ((specializer :accessor parameter-specializer
214                 :initarg :specializer
215                 :type    (or symbol cons)
216                 :documentation "
217    A specializer can be either NIL (no specializer),p
218    a symbol denoting a class, or
219    a cons (eql object) denoting an EQL specializer."))
220   (:documentation "A specialized parameter."))
221
222 (defmethod parameter-specializer-p ((self specialized-parameter))
223   (slot-boundp self 'specializer))
224
225 (defmethod parse-parameter ((self specialized-parameter) form)
226   (etypecase form
227     (symbol (call-next-method))
228     (cons   (call-next-method self (first form))
229             (when (cdr form)
230               (setf (parameter-specializer self) (second form))
231               (when (cddr form)
232                 (error "~A specification must be a ~
233                         list of two elements at most, not ~S"
234                        (parameter-label self) form)))))
235   self)
236
237
238 ;;;--------------------
239
240 (defclass parameter-with-initform ()
241   ((initform   :accessor parameter-initform
242                :initarg :initform
243                :documentation "The initial form for the parameter."))
244   (:documentation "A mixin for a parameter that may have an initform."))
245
246 (defmethod parameter-initform-p ((self parameter-with-initform))
247   (slot-boundp self 'initform))
248
249 (defmethod parse-parameter ((self parameter-with-initform) form)
250   (etypecase form
251     (symbol (call-next-method))
252     (cons   (call-next-method self (first form))
253             (when  (cdr form)
254               (setf (parameter-initform self) (second form)))))
255   self)
256
257
258 ;;;--------------------
259
260
261 (defclass auxiliary-parameter (parameter-with-initform parameter)
262   ;; The order of the superclasses is important
263   ;; to find the methods in the right order!
264   ()
265   (:documentation "An auxiliary parameter."))
266
267 (defmethod parse-parameter ((self auxiliary-parameter) form)
268   (etypecase form
269     (symbol (call-next-method))
270     (cons   (call-next-method)
271             (when (cddr form)
272               (error "~A specification must be a ~
273                       list of two elements at most, not ~S"
274                      (parameter-label self) form))))
275   self)
276
277
278 ;;;--------------------
279
280 (defclass optional-parameter (parameter-with-initform parameter)
281   ;; The order of the superclasses is important
282   ;; to find the methods in the right order!
283   ((indicator :accessor parameter-indicator
284               :initarg :indicator
285               :type symbol
286               :documentation "NIL, or the name of the indicator parameter."))
287   (:documentation "An optional parameter.
288     Note that while auxiliary-parameter and optional-parameter have the
289     same initform attribute, an optional-parameter is a different kind from
290     an auxiliary-parameter, semantically."))
291
292 (defmethod parameter-initform-p ((self optional-parameter))
293   (slot-boundp self 'initform))
294
295 (defmethod parameter-indicator-p ((self optional-parameter))
296   (slot-boundp self 'indicator))
297
298 (defmethod parse-parameter ((self optional-parameter) form)
299   (etypecase form
300     (symbol (call-next-method))
301     (cons   (call-next-method)
302             (when (cddr form)
303               (setf (parameter-indicator self) (third form))
304               (when (cdddr form)
305                 (error "~A specification must be a ~
306                         list of three elements at most, not ~S"
307                        (parameter-label self) form)))))
308   self)
309
310 ;;;--------------------
311
312 (defclass generic-optional-parameter (parameter)
313   ()
314   (:documentation "An optional parameter in generic lambda-lists."))
315
316 (defmethod parse-parameter ((self generic-optional-parameter) form)
317   (etypecase form
318     (symbol (call-next-method))
319     (cons   (call-next-method self (first form))
320             (when (cdr form)
321               (error "~A specification must be a ~
322                         list of one element at most, not ~S"
323                      (parameter-label self) form)))))
324
325
326 ;;;--------------------
327
328 (defclass parameter-with-keyword ()
329   ((keyword :accessor parameter-keyword
330             :initarg :keyword
331             :type    symbol
332             :documentation "NIL, or the keyword specified for the parameter."))
333   (:documentation "A mixin for keyword parameters."))
334
335 (defmethod parameter-keyword-p ((self parameter-with-keyword))
336   (slot-boundp self 'keyword))
337
338 (defmethod parse-parameter-name ((self parameter-with-keyword) form)
339   (etypecase form
340     (symbol (call-next-method))
341     (cons   (if (= 2 (length form))
342                 (progn
343                   (call-next-method self (second form))
344                   (setf (parameter-keyword self) (first form)))
345                 (error "~A specification must be a ~
346                         list of two elements, not ~S"
347                        (parameter-label self) form))))
348   self)
349
350 (defmethod ensure-parameter-keyword ((self parameter-with-keyword))
351   (if (parameter-keyword-p self)
352       (parameter-keyword self)
353       (intern (string (parameter-name self)) "KEYWORD")))
354
355 ;;;--------------------
356
357 (defclass keyword-parameter (parameter-with-keyword optional-parameter)
358   ;; The order of the superclasses is important
359   ;; to find the methods in the right order!
360   ()
361   (:documentation "A keyword parameter."))
362
363
364 ;;;--------------------
365
366 (defclass generic-keyword-parameter (parameter-with-keyword
367                                      generic-optional-parameter)
368   ;; The order of the superclasses is important
369   ;; to find the methods in the right order!
370   ()
371   (:documentation "A generic keyword parameter."))
372
373
374
375 ;;;--------------------
376
377 (defgeneric parameter-label (parameter)
378   (:method ((self parameter))                  (declare (ignorable self)) "A mandatory parameter")
379   (:method ((self environment-parameter))      (declare (ignorable self)) "An environment parameter")
380   (:method ((self whole-parameter))            (declare (ignorable self)) "A whole parameter")
381   (:method ((self rest-parameter))             (declare (ignorable self)) "A rest parameter")
382   (:method ((self body-parameter))             (declare (ignorable self)) "A body parameter")
383   (:method ((self specialized-parameter))      (declare (ignorable self)) "A specialized parameter")
384   (:method ((self auxiliary-parameter))        (declare (ignorable self)) "An auxiliary parameter")
385   (:method ((self optional-parameter))         (declare (ignorable self)) "An optional parameter")
386   (:method ((self generic-optional-parameter)) (declare (ignorable self)) "A generic optional parameter")
387   (:method ((self keyword-parameter))          (declare (ignorable self)) "A keyword parameter")
388   (:method ((self generic-keyword-parameter))  (declare (ignorable self)) "A generic keyword parameter"))
389
390 (defgeneric parameter-lambda-list-keyword (parameter)
391   (:method ((self parameter))                  (declare (ignorable self)) '&mandatory)
392   (:method ((self environment-parameter))      (declare (ignorable self)) '&environment)
393   (:method ((self whole-parameter))            (declare (ignorable self)) '&whole)
394   (:method ((self rest-parameter))             (declare (ignorable self)) '&rest)
395   (:method ((self body-parameter))             (declare (ignorable self)) '&body)
396   (:method ((self specialized-parameter))      (declare (ignorable self)) '&specialized)
397   (:method ((self auxiliary-parameter))        (declare (ignorable self)) '&aux)
398   (:method ((self optional-parameter))         (declare (ignorable self)) '&optional)
399   (:method ((self generic-optional-parameter)) (declare (ignorable self)) '&generic-optional)
400   (:method ((self keyword-parameter))          (declare (ignorable self)) '&key)
401   (:method ((self generic-keyword-parameter))  (declare (ignorable self)) '&generic-key))
402
403
404 (defgeneric parameter-specifier (parameter)
405   (:doucmentation "Return a parameter specifier sexp, which can be used to build a lambda list.")
406   (:method ((self parameter))
407     (parameter-name self))
408   (:method ((self specialized-parameter))
409     (cons (parameter-name self)
410           (when (parameter-specializer-p self)
411             (list (parameter-specializer self)))))
412   (:method ((self auxiliary-parameter))
413     (if (parameter-initform-p self)
414         (list (parameter-name self)  (parameter-initform self))
415         (parameter-name self)))
416   (:method ((self parameter-with-initform))
417     (if (parameter-initform-p self)
418         (cons (parameter-name self)
419               (cons (parameter-initform self)
420                     (when (parameter-indicator-p self)
421                       (list (parameter-indicator self)))))
422         (parameter-name self)))
423   (:method ((self parameter-with-keyword))
424     (if (or (parameter-keyword-p self) (parameter-initform-p self))
425         (cons (if (parameter-keyword-p self)
426                   (list (parameter-keyword self)  (parameter-name self))
427                   (parameter-name self))
428               (when  (parameter-initform-p self)
429                 (cons (parameter-initform self)
430                       (when (parameter-indicator-p self)
431                         (list (parameter-indicator self))))))
432         (parameter-name self)))
433   (:method ((self generic-keyword-parameter))
434     (if (parameter-keyword-p self)
435         (list (list (parameter-keyword self) (parameter-name self)))
436         (parameter-name self))))
437
438
439 ;;;--------------------
440
441 (defclass or-ll ()
442   ((mandatories      :accessor lambda-list-mandatory-parameters
443                      :initarg :mandatory-parameters
444                      :initform '()
445                      :type     list)
446    (optionals        :accessor lambda-list-optional-parameters
447                      :initarg :optional-parameters
448                      :initform '()
449                      :type     list)
450    (rest             :accessor lambda-list-rest-parameter
451                      :initarg :rest-parameter
452                      :type     (or null rest-parameter)))
453   (:documentation
454    "This class and its subclasses are mixin declaring formally
455 the attributes for the various lambda-list classes.  Semantically,
456 some constraints may be different from one lambda-list to the other."))
457
458 (defgeneric lambda-list-mandatory-parameters-p (self)
459   (:method ((self or-ll)) (not (not (lambda-list-mandatory-parameters self))))
460   (:method ((self t))     (declare (ignorable self)) nil))
461
462 (defgeneric lambda-list-optional-parameters-p (self)
463   (:method ((self or-ll)) (not (not (lambda-list-optional-parameters self))))
464   (:method ((self t))     (declare (ignorable self)) nil))
465
466 (defgeneric lambda-list-rest-parameter-p (self)
467   (:method ((self or-ll)) (slot-boundp self 'rest))
468   (:method ((self t))     (declare (ignorable self)) nil))
469
470
471
472
473 (define-default-generic lambda-list-allow-other-keys-p    or-ll nil)
474 (define-default-generic lambda-list-key-p                 or-ll nil)
475 (define-default-generic lambda-list-keyword-parameters    or-ll nil)
476 (define-default-generic lambda-list-environment-parameter or-ll nil)
477 (define-default-generic lambda-list-auxiliary-parameters  or-ll nil)
478 (define-default-generic lambda-list-whole-parameter       or-ll nil)
479 (define-default-generic lambda-list-body-parameter        or-ll nil)
480
481
482 (defclass orak-ll (or-ll)
483   ((allow-other-keys-p :accessor lambda-list-allow-other-keys-p
484                        :initarg :allow-other-keys-p
485                        :initform nil
486                        :type     boolean
487                        :documentation  "Whether &ALLOW-OTHER-KEYS is present.")
488    (key-p              :accessor lambda-list-key-p
489                        :initarg :key-p
490                        :initform nil
491                        :type     boolean
492                        :documentation "Whether &KEY is present.")
493    ;; We can have &KEY &ALLOW-OTHER-KEYS without any keyword.
494    (keys               :accessor lambda-list-keyword-parameters
495                        :initarg :keyword-parameters
496                        :initform '()
497                        :type     list)))
498
499 (defgeneric lambda-list-keyword-parameters-p (self)
500   (:method ((self or-ll)) (not (not (lambda-list-keyword-parameters self)))))
501
502
503
504 (defclass orake-ll (orak-ll)
505   ((environment      :accessor lambda-list-environment-parameter
506                      :initarg :environment-parameter
507                      :type     environment-parameter)))
508
509 (defclass oraka-ll (orak-ll)
510   ((aux              :accessor lambda-list-auxiliary-parameters
511                      :initarg :auxiliary-parameters
512                      :initform '()
513                      :type     list)))
514
515 (defclass orakawb-ll (oraka-ll)
516   ((whole            :accessor lambda-list-whole-parameter
517                      :initarg :whole-parameter
518                      :type     whole-parameter)
519    (body             :accessor lambda-list-body-parameter
520                      :initarg :body-parameter
521                      :type     body-parameter)))
522
523 (defclass orakawbe-ll (orakawb-ll)
524   ((environment      :accessor lambda-list-environment-parameter
525                      :initarg :environment-parameter
526                      :type     environment-parameter)))
527
528 (defgeneric lambda-list-auxiliary-parameters-p (self)
529   (:method ((self oraka-ll)) (not (not (lambda-list-auxiliary-parameters self))))
530   (:method ((self t))        (declare (ignorable self)) nil))
531
532 (defgeneric lambda-list-whole-parameter-p (self)
533   (:method ((self orakawb-ll)) (slot-boundp self 'whole))
534   (:method ((self t))          (declare (ignorable self)) nil))
535
536 (defgeneric lambda-list-body-parameter-p (self)
537   (:method ((self orakawb-ll)) (slot-boundp self 'body))
538   (:method ((self t))          (declare (ignorable self)) nil))
539
540 (defgeneric lambda-list-environment-parameter-p (self)
541   (:method ((self orakawbe-ll)) (slot-boundp self 'environment))
542   (:method ((self orake-ll))    (slot-boundp self 'environment))
543   (:method ((self t))           (declare (ignorable self)) nil))
544
545
546
547 ;;;----------------------------------------
548
549 (defclass lambda-list ()
550   ((original   :accessor original-lambda-list
551                :initarg :lambda-list
552                :type     list)
553    (parameters :accessor lambda-list-parameters
554                :initarg :parameters
555                :type     list
556                :documentation "An ordered list of the parameters or destructuring-lambda-list instances."))
557   (:documentation "An abstract lambda-list."))
558
559 (defclass ordinary-lambda-list           (lambda-list oraka-ll)    ())
560 (defclass boa-lambda-list                (lambda-list oraka-ll)    ())
561 (defclass specialized-lambda-list        (lambda-list oraka-ll)    ())
562 (defclass modify-macro-lambda-list       (lambda-list or-ll)       ())
563 (defclass generic-lambda-list            (lambda-list orak-ll)     ())
564 (defclass macro-lambda-list              (lambda-list orakawbe-ll) ())
565 (defclass type-lambda-list               (lambda-list orakawbe-ll) ())
566 (defclass destructuring-lambda-list      (lambda-list orakawb-ll)  ())
567 (defclass setf-lambda-list               (lambda-list orake-ll)    ())
568 (defclass method-combination-lambda-list (lambda-list orakaw-ll)   ())
569
570 (defgeneric lambda-list-kind (lambda-list)
571   (:method ((self ordinary-lambda-list))           (declare (ignorable self)) :ordinary)
572   (:method ((self boa-lambda-list))                (declare (ignorable self)) :boa)
573   (:method ((self specialized-lambda-list))        (declare (ignorable self)) :specialized)
574   (:method ((self modify-macro-lambda-list))       (declare (ignorable self)) :modify-macro)
575   (:method ((self generic-lambda-list))            (declare (ignorable self)) :generic)
576   (:method ((self macro-lambda-list))              (declare (ignorable self)) :macro)
577   (:method ((self type-lambda-list))               (declare (ignorable self)) :type)
578   (:method ((self destructuring-lambda-list))      (declare (ignorable self)) :destructuring)
579   (:method ((self setf-lambda-list))               (declare (ignorable self)) :setf)
580   (:method ((self method-combination-lambda-list)) (declare (ignorable self)) :method-combination))
581
582 (defgeneric lambda-list-allowed-keywords (lambda-list)
583   (:method ((self ordinary-lambda-list))
584     (declare (ignorable self)) 
585     '(&optional &rest &allow-other-keys &key &aux))
586   (:method ((self boa-lambda-list))
587     (declare (ignorable self)) 
588     '(&optional &rest &allow-other-keys &key &aux))
589   (:method ((self specialized-lambda-list))
590     (declare (ignorable self)) 
591     '(&optional &rest &allow-other-keys &key &aux))
592   (:method ((self modify-macro-lambda-list)) 
593     (declare (ignorable self))
594     '(&optional &rest))
595   (:method ((self generic-lambda-list))
596     (declare (ignorable self)) 
597     '(&optional &rest &allow-other-keys &key))
598   (:method ((self macro-lambda-list))
599     (declare (ignorable self)) 
600     '(&optional &rest &allow-other-keys &key &aux &whole &body &environment))
601   (:method ((self type-lambda-list))
602     (declare (ignorable self)) 
603     '(&optional &rest &allow-other-keys &key &aux &whole &body &environment))
604   (:method ((self destructuring-lambda-list))
605     (declare (ignorable self)) 
606     '(&optional &rest &allow-other-keys &key &aux &whole &body))
607   (:method ((self setf-lambda-list))
608     (declare (ignorable self)) 
609     '(&optional &rest &allow-other-keys &key &environment))
610   (:method ((self method-combination-lambda-list))
611     (declare (ignorable self)) 
612     '(&optional &rest &allow-other-keys &key &aux &whole)))
613
614
615 (defmethod lambda-list-mandatory-parameter-count ((self or-ll))
616   "RETURN: The number of mandatory parameters."
617   (length (lambda-list-mandatory-parameters self)))
618
619 (defmethod lambda-list-optional-parameter-count ((self or-ll))
620   "RETURN: The number of optional parameters."
621   (length (lambda-list-mandatory-parameters self)))
622
623 (defgeneric lambda-list-rest-p (self)
624   (:documentation "RETURN: Whether &REST or &BODY parameters are present.")
625   (:method ((self or-ll))      (lambda-list-rest-parameter-p self))
626   (:method ((self orakawb-ll)) (or (lambda-list-rest-parameter-p self)
627                                    (lambda-list-body-parameter-p self))))
628
629
630 ;; auxvars  ::= [&aux {var | (var [init-form])}*]
631 ;; optvars  ::= [&optional {var | (var [init-form [supplied-p-parameter]])}*]
632 ;; goptvars ::= [&optional {var | (var)}*]
633
634 (defmethod parse-optvars ((self or-ll) current slot lambda-list-keyword class)
635   "
636 DO:     Parses optional parameters.
637 RETURN: The remaining tokens.
638 "
639   (when (eq (car current) lambda-list-keyword)
640     (pop current)
641     (setf (slot-value self slot)
642           (loop
643              :while (and current (not (member (car current) lambda-list-keywords)))
644              :collect (parse-parameter (make-instance class) (pop current)))))
645   current)
646
647 (defmethod auxvars  ((self or-ll) current)
648   (parse-optvars self current 'aux       '&aux      'auxiliary-parameter))
649 (defmethod optvars  ((self or-ll) current)
650   (parse-optvars self current 'optionals '&optional 'optional-parameter))
651 (defmethod goptvars ((self or-ll) current)
652   (parse-optvars self current 'optionals '&optional 'generic-optional-parameter))
653
654
655 ;; keyvars  ::= [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*  [&allow-other-keys]]
656 ;; gkeyvars ::= [&key {var | ({var | (keyword-name var)})}* [&allow-other-keys]])
657 (defmethod parse-keyvars ((self orak-ll) current class)
658   "
659 DO:     Parses keywork parameters.
660 RETURN: The remaining tokens.
661 "
662   (when (eq '&key (car current))
663     (pop current)
664     (setf (lambda-list-key-p self) t
665           (lambda-list-keyword-parameters self)
666           (loop
667              :while (and current (not (member (car current) lambda-list-keywords)))
668              :collect (parse-parameter (make-instance class) (pop current)))
669           (lambda-list-allow-other-keys-p self)
670           (and (eq '&allow-other-keys (car current)) (pop current) t)))
671   current)
672
673 (defmethod keyvars  ((self orak-ll) current)
674   (parse-keyvars self current 'keyword-parameter))
675 (defmethod gkeyvars ((self orak-ll) current)
676   (parse-keyvars self current 'generic-keyword-parameter))
677
678
679 ;; reqvars  ::= var*
680 ;; sreqvars ::= {var | (var [specializer])}*
681 ;; preqvars ::= {var | destructuring-lambda-list}*
682
683 (defmethod parse-reqvars ((self or-ll) current class)
684   "
685 DO:     Parses required parameters.
686 RETURN: (values list-of-parameters following)
687 "
688   (setf (lambda-list-mandatory-parameters self)
689         (loop
690            :while (and current (not (member (car current) lambda-list-keywords)))
691            :collect (parse-parameter (make-instance class) (pop current))))
692   current)
693
694 (defmethod reqvars  ((self or-ll) current)
695   (parse-reqvars self current  'parameter))
696 (defmethod sreqvars ((self or-ll) current)
697   (parse-reqvars self current  'specialized-parameter))
698
699
700 (defmethod preqvars ((self or-ll) current)
701   "
702 DO:     Parses required parameters or patterns.
703 RETURN: (values list-of-parameters following)
704 "
705   (setf (lambda-list-mandatory-parameters self)
706         (loop
707            :while (and current (not (member (car current) lambda-list-keywords)))
708            :collect (if (consp (car current))
709                         (parse-original-lambda-list
710                          (make-instance 'destructuring-lambda-list
711                            :lambda-list (pop current)))
712                         (parse-parameter
713                          (make-instance 'parameter)
714                          (pop current)))))
715   current)
716
717
718 ;; bodyvar  ::= [{&rest | &body} var]
719 ;; restvar  ::= [&rest var]
720 ;; wholevar ::= [&whole var]
721 ;; envvar   ::= [&environment var]
722
723 (defun bodyvar (self current)
724   "
725 RETURN: (values parameter following)
726 "
727   (flet ((check-duplicate (lambda-list-keyword)
728            (when (lambda-list-rest-p self)
729              (error "~:[&BODY~;&REST~] parameter already given before ~A in ~S"
730                     (lambda-list-rest-parameter-p self)
731                     lambda-list-keyword
732                     (original-lambda-list self)))))
733     (case (car current)
734       ((&rest)
735        (check-duplicate (pop current))
736        (setf (lambda-list-rest-parameter self)
737              (parse-parameter (make-instance 'rest-parameter) (pop current))))
738       ((&body)
739        (check-duplicate (pop current))
740        (setf (lambda-list-body-parameter self)
741              (parse-parameter (make-instance 'body-parameter) (pop current)))))
742     current))
743
744
745 (defun parse-var (self current slot lambda-list-keyword class )
746   "
747 RETURN: (values parameter following)
748 "
749   (when (eq (car current) lambda-list-keyword)
750     (pop current)
751     (when (slot-boundp self slot)
752       (error "~A parameter duplicated in ~S"
753              lambda-list-keyword (original-lambda-list self)))
754     (setf (slot-value self slot)
755           (parse-parameter (make-instance class) (pop current))))
756   current)
757
758 (defun restvar  (self current)
759   (parse-var self current 'rest        '&rest        'rest-parameter))
760 (defun wholevar (self current)
761   (parse-var self current 'whole       '&whole       'whole-parameter))
762 (defun envvar   (self current)
763   (parse-var self current 'environment '&environment 'environment-parameter))
764
765
766
767 ;; macro-lambda-list ::= (wholevar envvar preqvars envvar optvars envvar
768 ;;                   bodyvar  envvar keyvars envvar auxvars envvar)
769 ;;                | (wholevar envvar preqvars envvar optvars envvar .  var)
770 ;;
771 ;; destructuring-lambda-list ::= (wholevar preqvars optvars bodyvar keyvars auxvars)
772 ;;                        | (wholevar preqvars optvars . var)
773 ;;
774 ;; type-lambda-list               ::= macro-lambda-list
775 ;;
776 ;;
777 ;; ordinary-lambda-list           ::= (reqvars  optvars restvar keyvars auxvars)
778 ;; boa-lambda-list                ::= ordinary-lambda-list
779 ;; specialized-lambda-list        ::= (sreqvars optvars restvar keyvars auxvars)
780 ;; generic-lambda-list            ::= (reqvars  goptvars restvar gkeyvars)
781 ;; setf-lambda-list               ::= (reqvars optvars restvar keyvars envvar)
782 ;; modify-macro-lambda-list       ::= (reqvars optvars restvar)
783 ;; method-combination-lambda-list ::= (wholevar reqvars optvars restvar keyvars auxvars)
784
785
786 (defun parse-rest (self current syntax)
787   (if (listp current)
788       (dolist (fun syntax current)
789         (setf current (funcall fun self current)))
790       (restvar self (list '&rest current))))
791
792 (defun destructuring-rest (self current)
793   (parse-rest self current  '(bodyvar keyvars auxvars)))
794
795 (defun macro-rest (self current)
796   (parse-rest self current '(bodyvar envvar keyvars envvar auxvars envvar)))
797
798
799
800 (defgeneric lambda-list-syntax (self)
801   (:method ((self ordinary-lambda-list))
802     (declare (ignorable self)) 
803     '(reqvars  optvars  restvar keyvars auxvars))
804   (:method ((self boa-lambda-list))
805     (declare (ignorable self)) 
806     '(reqvars  optvars  restvar keyvars auxvars))
807   (:method ((self specialized-lambda-list))
808     (declare (ignorable self)) 
809     '(sreqvars optvars  restvar keyvars auxvars))
810   (:method ((self generic-lambda-list))
811     (declare (ignorable self)) 
812     '(reqvars  goptvars restvar gkeyvars))
813   (:method ((self setf-lambda-list))
814     (declare (ignorable self)) 
815     '(reqvars  optvars restvar keyvars envvar))
816   (:method ((self modify-macro-lambda-list))
817     (declare (ignorable self)) 
818     '(reqvars  optvars restvar))
819   (:method ((self method-combination-lambda-list))
820     (declare (ignorable self))
821     '(wholevar reqvars optvars restvar keyvars auxvars))
822   (:method ((self macro-lambda-list))
823     (declare (ignorable self)) 
824     '(wholevar envvar preqvars envvar optvars envvar macro-rest))
825   (:method ((self type-lambda-list))
826     (declare (ignorable self)) 
827     '(wholevar envvar preqvars envvar optvars envvar macro-rest))
828   (:method ((self destructuring-lambda-list))
829     (declare (ignorable self)) 
830     '(wholevar preqvars optvars destructuring-rest)))
831
832
833 (defmethod parse-original-lambda-list ((self lambda-list))
834   (let ((current (original-lambda-list self)))
835     (dolist (fun (lambda-list-syntax self))
836       (setf current (funcall fun self current)))
837     (when current
838       (error "Syntax error in ~(~A~) at: ~S~%in ~S"
839              (class-name (class-of self)) current (original-lambda-list self)))
840     self))
841
842
843 (defun parse-lambda-list (lambda-list &optional (kind :ordinary))
844   "
845 DO:      Parse a lambda-list of the specified kind.
846 KIND:    (MEMBER :ORDINARY :BOA :SPECIALIZED :MODIFY-MACRO :GENERIC
847                  :MACRO :TYPE :DESTRUCTURING :SETF :METHOD-COMBINATION)
848 RETURN:  A lambda-list instance.
849
850 NOTE:    In the case of :macro, :destructuring lambda lists, some
851          parameter lists may further contain destructuring-lambda-list
852          instances instead of lambda-list-parameter instances.
853
854 "
855   (parse-original-lambda-list
856    (make-instance
857        (or (cdr (assoc
858                  kind
859                  '((:ordinary           . ordinary-lambda-list)
860                    (:boa                . boa-lambda-list)
861                    (:specialized        . specialized-lambda-list)
862                    (:modify-macro       . modify-macro-lambda-list)
863                    (:generic            . generic-lambda-list)
864                    (:macro              . macro-lambda-list)
865                    (:type               . type-lambda-list)
866                    (:destructuring      . destructuring-lambda-list)
867                    (:setf               . setf-lambda-list)
868                    (:method-combination . method-combination-lambda-list))))
869            (error "Invalid lambda-list kind ~S" kind))
870      :lambda-list lambda-list)))
871
872 ;;------------------------------------------------------------------------
873
874 (defgeneric parameter-help-label (self)
875   (:method ((self parameter))
876     (format nil "~A" (parameter-name self)))
877   (:method ((self optional-parameter))
878     (format nil "[~A]" (parameter-name self)))
879   (:method ((self rest-parameter))
880     (format nil "~A..." (parameter-name self)))
881   (:method ((self body-parameter))
882     (format nil "~A..." (parameter-name self)))
883   (:method ((self keyword-parameter))
884     (format nil "~A" (ensure-parameter-keyword self))))
885
886
887 (defmethod make-help ((self lambda-list))
888   "
889 RETURN: A list describing the lambda-list for the user. Each item is a cons:
890         (lambda-list-keyword . description) where
891         - the lambda-list-keyword is either
892           :mandatory, :optional, :rest, :body, :key,  or :allow-other-keys.
893         - the description is a string indicating the name of the parameter,
894           and whether it's optional '[n]' or takes several arguments 'n...'.
895 "
896   (append
897    ;; mandatory:
898    (mapcar (lambda (par) (cons :mandatory (parameter-help-label par)))
899            (lambda-list-mandatory-parameters self))
900    ;; optional:
901    (mapcar (lambda (par) (cons :optional  (parameter-help-label par)))
902            (lambda-list-optional-parameters self))
903    (when (lambda-list-rest-parameter-p self)
904      (list (cons :rest (parameter-help-label (lambda-list-rest-parameter self)))))
905    (when (lambda-list-body-parameter-p self)
906      (list (cons :body (parameter-help-label (lambda-list-body-parameter self)))))
907    ;; keywords:
908    (mapcar (lambda (par) (cons :key (parameter-help-label par)))
909            (lambda-list-keyword-parameters self))
910    (when (lambda-list-allow-other-keys-p self)
911      (list (cons :allow-other-keys "(other keys allowed)")))))
912
913
914 (defmethod make-argument-list ((self lambda-list))
915   "
916 RETURN: A list of arguments taken from the parameters usable with apply
917         to call a function with the same lambda-list.
918 "
919   (let ((rest (lambda-list-rest-p self)))
920     (append
921      (mapcar (function parameter-name) (lambda-list-mandatory-parameters self))
922      (mapcar (function parameter-name) (lambda-list-optional-parameters  self))
923      (when (lambda-list-key-p self)
924        (mapcan (lambda (par) (list (ensure-parameter-keyword par)
925                               (parameter-name par)))
926                (lambda-list-keyword-parameters  self)))
927      (list (if rest  (parameter-name rest) 'nil)))))
928
929
930
931
932 ;;;; MAKE-ARGUMENT-LIST-FORM
933 ;; +------+--------+-----+---------+
934 ;; | rest | k-wo-i | aok | all-opt |
935 ;; +------+--------+-----+---------+
936 ;; |  no  |   no   |  no | <=> there is some keyword
937 ;; |  no  |   no   | yes | <=> there is some keyword ; we can't know the other keywords!
938 ;; |  no  |   yes  |  no | yes
939 ;; |  no  |   yes  | yes | yes ; we can't know the other keywords!
940 ;; |  yes |   no   |  no | <=> there is some keyword <=> (not (null rest))
941 ;; |  yes |   no   | yes | <=> there is some keyword <=> (not (null rest))
942 ;; |  yes |   yes  |  no | yes
943 ;; |  yes |   yes  | yes | yes
944 ;; +------+--------+-----+---------+
945
946 (defgeneric make-argument-list-form (lambda-list))
947 (defmethod make-argument-list-form ((self lambda-list))
948   "
949 RETURN: A form that will build a list of arguments passing the same arguments
950         given to lambda-list, to be passed to APPLY.
951 NOTE:   If optional or key arguments have an indicator,
952         then they're not passed unless necessary or the indicator is true.
953 BUG:    We don't handle MACRO-LAMBDA-LISTs nor DESTRUCTURING-LAMBDA-LISTs, etc.
954 "
955   (flet ((genopt ()
956            (loop
957               :with result = '()
958               :with pars = (reverse (lambda-list-optional-parameters self))
959               :for par = (pop pars)
960               :while (and par (parameter-indicator-p par))
961               :do (push `(when ,(parameter-indicator par)
962                            (list ,(parameter-name par))) result) 
963               :finally (return
964                          `(,@(when (or par pars)
965                                    `((list ,@(nreverse
966                                               (mapcar
967                                                (function parameter-name)
968                                                (if par
969                                                    (cons par pars)
970                                                    pars))))))
971                              ,@result)))))
972     (let* ((rest
973             (cond
974               ((lambda-list-rest-parameter-p self) (lambda-list-rest-parameter self))
975               ((lambda-list-body-parameter-p self) (lambda-list-body-parameter self))))
976            (form
977              `(append
978                ,@(if (not (every (function parameter-indicator-p)
979                                  (lambda-list-keyword-parameters self)))
980                      ;; If some keyword parameter has no indicator,
981                      ;; we will be forced to pass it again as argument,
982                      ;; therefore we must pass all optional argumentst too.
983                      `( (list ,@(mapcar (function parameter-name)
984                                         (lambda-list-mandatory-parameters self))
985                               ,@(mapcar (function parameter-name)
986                                         (lambda-list-optional-parameters self))))
987
988                      `( (list ,@(mapcar (function parameter-name)
989                                         (lambda-list-mandatory-parameters self)))
990                         ,@(if (not (or rest (lambda-list-keyword-parameters self)))
991                               (genopt)
992                               `((if
993                                  ,(if rest
994                                       (parameter-name rest)
995                                       `(or
996                                         ,@(mapcar
997                                            (function parameter-indicator)
998                                            (lambda-list-keyword-parameters self))))
999                                  (list ,@(mapcar
1000                                           (function parameter-name)
1001                                           (lambda-list-optional-parameters self)))
1002                                  ,(let ((subforms (genopt)))
1003                                        (cond
1004                                          ((null subforms) '())
1005                                          ((cdr subforms) `(append ,@subforms))
1006                                          (t (car subforms)))))))))
1007                ,@(if rest
1008                      ;; When we have a rest (or body) parameter, we don't need
1009                      ;; to generate the keyword parameters, since they're 
1010                      ;; covered by the rest. We just append the rest to the
1011                      ;;  list of arguments.
1012                      `(,(parameter-name rest))
1013                      ;; Without a rest (or body) parameter, we need to pass
1014                      ;; the keyword arguments.
1015                      (mapcar (lambda (parameter)
1016                                (if (parameter-indicator-p parameter)
1017                                    ;; If we have an indicator parameter,
1018                                    ;; we pass the keyword argument
1019                                    ;; only when we got it.
1020                                    `(when ,(parameter-indicator parameter)
1021                                       (list
1022                                        ,(ensure-parameter-keyword parameter)
1023                                        ,(parameter-name parameter)))
1024                                    ;; otherwise we pass the keyword argument
1025                                    ;; unconditionnaly:
1026                                    `(list ,(ensure-parameter-keyword parameter)
1027                                           ,(parameter-name parameter))))
1028                              (lambda-list-keyword-parameters  self))))))
1029       (if (= 2 (length form))
1030           (second form)
1031           form))))
1032
1033
1034
1035 (defmethod make-lambda-list ((self lambda-list))
1036   "
1037 RETURN:     A newly rebuilt lambda-list s-expr.
1038 "
1039   (append
1040    (when (lambda-list-whole-parameter-p self)
1041      (list '&whole
1042            (parameter-specifier (lambda-list-whole-parameter self))))
1043    (when (lambda-list-environment-parameter-p self)
1044      (list '&environment
1045            (parameter-specifier (lambda-list-environment-parameter self))))
1046    (mapcar (function parameter-specifier) (lambda-list-mandatory-parameters self))
1047    (when (lambda-list-optional-parameters self)
1048      (cons '&optional
1049            (mapcar (function parameter-specifier)
1050                    (lambda-list-optional-parameters self))))
1051    (when (lambda-list-body-parameter-p self)
1052      (list '&body (parameter-specifier (lambda-list-body-parameter self))))
1053    (when (lambda-list-rest-parameter-p self)
1054      (list '&rest (parameter-specifier (lambda-list-rest-parameter self))))
1055    (when (lambda-list-key-p self)
1056      '(&key))
1057    (when (lambda-list-keyword-parameters self)
1058      (mapcar (function parameter-specifier)
1059              (lambda-list-keyword-parameters self)))
1060    (when (lambda-list-allow-other-keys-p self)
1061      '(&allow-other-keys))
1062    (when (lambda-list-auxiliary-parameters self)
1063      (cons '&aux (mapcar (function parameter-specifier)
1064                          (lambda-list-auxiliary-parameters self))))))
1065
1066
1067 (defmethod parameter-specifier ((parameter destructuring-lambda-list))
1068   "
1069 NOTE:   DESTRUCTURING-LAMBDA-LIST instances may appear in parameter lists.
1070         Therefore we need to build the parameter-specifier sexp for them.
1071 "
1072   (make-lambda-list parameter))
1073
1074
1075
1076
1077 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1078
1079
1080
1081 ;; (defmacro m (&environment env &whole whole
1082 ;;              ((a b) (c (d e)) &optional (o t op))
1083 ;;              e f &body g &key k1 k2)
1084 ;;   (print (list env whole a b c d e o op e f g k1 k2)) nil)
1085 ;;
1086 ;; (m ((1 2) (3 (4 5))) 6 7  :k1 (print c) :k2 (print d))
1087 ;;
1088 ;; (#(NIL NIL)
1089 ;;   (M ((1 2) (3 (4 5))) 6 7 :K1 (PRINT C) :K2 (PRINT D))
1090 ;;   1 2 3 4 6 T NIL 6 7
1091 ;;   (:K1 (PRINT C) :K2 (PRINT D))
1092 ;;   (PRINT C)
1093 ;;   (PRINT D))
1094
1095
1096 ;; (make-help-from-split-lambda-list
1097 ;;  (split-lambda-list-on-keywords
1098 ;;   '(m1 m2 m3 &optional o1 o2 o3 &rest r1 &key k1 k2 k3 &aux a1 a2 a3
1099 ;;     &allow-other-keys)
1100 ;;   :ordinary))
1101 ;;'(m1 m2 m3 &optional o1 o2 o3 &rest r1 &key k1 k2 k3 &aux a1 a2 a3  &allow-other-keys)
1102
1103
1104
1105
1106 (eval-when (:compile-toplevel :load-toplevel :execute)
1107   (defun extract-documentation (body)
1108     "
1109 RETURN: The documentation string found in BODY, or NIL if none is present.
1110
1111 3.4.11 Syntactic Interaction of Documentation Strings and Declarations
1112
1113 In a number of situations, a documentation string can appear amidst a series of
1114 declare expressions prior to a series of forms.
1115
1116 In that case, if a string S appears where a documentation string is permissible
1117 and is not followed by either a declare expression or a form then S is taken to
1118 be a form; otherwise, S is taken as a documentation string. The consequences
1119 are unspecified if more than one such documentation string is present.
1120 "
1121     (loop
1122        :for (item . rest) :on body
1123        :while (and (consp item) (eq 'declare (first item)))
1124        :finally (return (and (stringp item) rest item))))
1125
1126
1127   (defun extract-declarations (body)
1128     "
1129 RETURN: The list of declaration forms.
1130 "
1131     (loop
1132        :with seen-doc = nil
1133        :for item :in body
1134        :while (or (and (not seen-doc) (stringp item))
1135                   (and (consp item) (eq 'declare (car item))))
1136        :when  (and (not seen-doc) (stringp item)) :do (setf seen-doc t)
1137        :when  (and (consp item) (eq 'declare (car item))) :collect item))
1138
1139
1140   (defun declarations-hash-table (declarations)
1141     ;; Todo: add some knowledge on how declarations merge.
1142     (loop
1143        :with table = (make-hash-table)
1144        :for decl :in declarations
1145        :do (loop
1146               :for (key . value) :in (rest decl)
1147               :do (push value (gethash key table '())))
1148        :finally (return table)))
1149
1150
1151   (defun extract-body (body)
1152     (loop
1153        :with seen-doc = nil
1154        :for (item . rest) :on body
1155        :while (or (and (not seen-doc) (stringp item))
1156                   (and (consp item) (eq 'declare (car item))))
1157        :when (and (not seen-doc) (stringp item)) :do (setf seen-doc t)
1158        :finally (return (cons item rest)))))
1159
1160
1161 (defun extract-method-qualifiers (method-stuff)
1162   (loop
1163      :for item :in method-stuff
1164      :until (listp item)
1165      :collect item))
1166
1167 (defun extract-method-lambda-list (method-stuff)
1168   (loop
1169      :for item :in method-stuff
1170      :until (listp item)
1171      :finally (return item)))
1172
1173 (defun extract-method-ddl (method-stuff)
1174   (loop
1175      :for (item . body) :in method-stuff
1176      :until (listp item)
1177      :finally (return body)))
1178
1179 (defun extract-method-documentation (method-stuff)
1180   (extract-documentation (extract-method-ddl method-stuff)))
1181
1182 (defun extract-method-declarations (method-stuff)
1183   (extract-declarations (extract-method-ddl method-stuff)))
1184
1185 (defun extract-method-body (method-stuff)
1186   (extract-body (extract-method-ddl method-stuff)))
1187
1188
1189
1190 ;; (eval-when (:compile-toplevel :load-toplevel :execute)
1191 ;;   (shadow '(DEFUN DEFGENERIC DEFMETHOD)))
1192 ;; 
1193 ;; 
1194 ;; (defparameter *call-stack* '())
1195 ;; 
1196 ;; 
1197 ;; (cl:defmacro defun (name args &body body)
1198 ;;   (let ((lambda-list (parse-lambda-list args :ordinary))
1199 ;;         (docu (extract-documentation body))
1200 ;;         (decl (extract-declarations  body))
1201 ;;         (body (extract-body          body)))
1202 ;;     `(cl:defun ,name ,args
1203 ;;        ,@(when docu (list docu))
1204 ;;        ,@decl
1205 ;;        (push (list ',name ,@(make-argument-list lambda-list)) *call-stack*)
1206 ;;        (multiple-value-prog1 (progn ,@body)
1207 ;;          (pop *call-stack*)))))
1208 ;; 
1209 ;; 
1210 ;; (cl:defmacro defmethod (name &rest stuff)
1211 ;;   (let* ((qualifiers (extract-method-qualifiers stuff))
1212 ;;          (args       (extract-method-lambda-list     stuff))
1213 ;;          (lambda-list     (parse-lambda-list args :specialized))
1214 ;;          (docu       (extract-method-documentation stuff))
1215 ;;          (decl       (extract-method-declarations  stuff))
1216 ;;          (body       (extract-method-body          stuff)))
1217 ;;     `(cl:defmethod
1218 ;;          ,name ,@qualifiers ,args
1219 ;;          ,@(when docu (list docu))
1220 ;;          ,@decl
1221 ;;          (push (list ',name ,@(make-argument-list lambda-list)) *call-stack*)
1222 ;;          (multiple-value-prog1 (progn ,@body)
1223 ;;            (pop *call-stack*)))))
1224 ;; 
1225 ;; (cl:defmacro defgeneric (name args &rest options-and-methods)
1226 ;;   `(cl:defgeneric ,name ,args
1227 ;;      ,@(mapcar
1228 ;;         (lambda (item)
1229 ;;           (if (and (consp item) (eq :method (car item)))
1230 ;;               (let* ((stuff      (rest item))
1231 ;;                      (qualifiers (extract-method-qualifiers stuff))
1232 ;;                      (args       (extract-method-lambda-list     stuff))
1233 ;;                      (lambda-list     (parse-lambda-list args :specialized))
1234 ;;                      (docu       (extract-method-documentation stuff))
1235 ;;                      (decl       (extract-method-declarations  stuff))
1236 ;;                      (body       (extract-method-body          stuff)))
1237 ;;                 `(:method ,@qualifiers ,args
1238 ;;                           ,@(when docu (list docu))
1239 ;;                           ,@decl
1240 ;;                           (push (list ',name ,@(make-argument-list lambda-list))
1241 ;;                                 *call-stack*)
1242 ;;                           (multiple-value-prog1 (progn ,@body)
1243 ;;                             (pop *call-stack*))))
1244 ;;               item))
1245 ;;         options-and-methods)))
1246
1247 ;;;; THE END ;;;;