Merged back com.informatimago.common-lisp.file into com.informatimago.common-lisp...
[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   (:method ((self parameter))
406     (parameter-name self))
407   (:method ((self specialized-parameter))
408     (cons (parameter-name self)
409           (when (parameter-specializer-p self)
410             (list (parameter-specializer self)))))
411   (:method ((self auxiliary-parameter))
412     (if (parameter-initform-p self)
413         (list (parameter-name self)  (parameter-initform self))
414         (parameter-name self)))
415   (:method ((self parameter-with-initform))
416     (if (parameter-initform-p self)
417         (cons (parameter-name self)
418               (cons (parameter-initform self)
419                     (when (parameter-indicator-p self)
420                       (list (parameter-indicator self)))))
421         (parameter-name self)))
422   (:method ((self parameter-with-keyword))
423     (if (or (parameter-keyword-p self) (parameter-initform-p self))
424         (cons (if (parameter-keyword-p self)
425                   (list (parameter-keyword self)  (parameter-name self))
426                   (parameter-name self))
427               (when  (parameter-initform-p self)
428                 (cons (parameter-initform self)
429                       (when (parameter-indicator-p self)
430                         (list (parameter-indicator self))))))
431         (parameter-name self)))
432   (:method ((self generic-keyword-parameter))
433     (if (parameter-keyword-p self)
434         (list (list (parameter-keyword self) (parameter-name self)))
435         (parameter-name self))))
436
437
438 ;;;--------------------
439
440 (defclass or-ll ()
441   ((mandatories      :accessor lambda-list-mandatory-parameters
442                      :initarg :mandatory-parameters
443                      :initform '()
444                      :type     list)
445    (optionals        :accessor lambda-list-optional-parameters
446                      :initarg :optional-parameters
447                      :initform '()
448                      :type     list)
449    (rest             :accessor lambda-list-rest-parameter
450                      :initarg :rest-parameter
451                      :type     (or null rest-parameter)))
452   (:documentation
453    "This class and its subclasses are mixin declaring formally
454 the attributes for the various lambda-list classes.  Semantically,
455 some constraints may be different from one lambda-list to the other."))
456
457 (defgeneric lambda-list-mandatory-parameters-p (self)
458   (:method ((self or-ll)) (not (not (lambda-list-mandatory-parameters self))))
459   (:method ((self t))     (declare (ignorable self)) nil))
460
461 (defgeneric lambda-list-optional-parameters-p (self)
462   (:method ((self or-ll)) (not (not (lambda-list-optional-parameters self))))
463   (:method ((self t))     (declare (ignorable self)) nil))
464
465 (defgeneric lambda-list-rest-parameter-p (self)
466   (:method ((self or-ll)) (slot-boundp self 'rest))
467   (:method ((self t))     (declare (ignorable self)) nil))
468
469
470
471
472 (define-default-generic lambda-list-allow-other-keys-p    or-ll nil)
473 (define-default-generic lambda-list-key-p                 or-ll nil)
474 (define-default-generic lambda-list-keyword-parameters    or-ll nil)
475 (define-default-generic lambda-list-environment-parameter or-ll nil)
476 (define-default-generic lambda-list-auxiliary-parameters  or-ll nil)
477 (define-default-generic lambda-list-whole-parameter       or-ll nil)
478 (define-default-generic lambda-list-body-parameter        or-ll nil)
479
480
481 (defclass orak-ll (or-ll)
482   ((allow-other-keys-p :accessor lambda-list-allow-other-keys-p
483                        :initarg :allow-other-keys-p
484                        :initform nil
485                        :type     boolean
486                        :documentation  "Whether &ALLOW-OTHER-KEYS is present.")
487    (key-p              :accessor lambda-list-key-p
488                        :initarg :key-p
489                        :initform nil
490                        :type     boolean
491                        :documentation "Whether &KEY is present.")
492    ;; We can have &KEY &ALLOW-OTHER-KEYS without any keyword.
493    (keys               :accessor lambda-list-keyword-parameters
494                        :initarg :keyword-parameters
495                        :initform '()
496                        :type     list)))
497
498 (defgeneric lambda-list-keyword-parameters-p (self)
499   (:method ((self or-ll)) (not (not (lambda-list-keyword-parameters self)))))
500
501
502
503 (defclass orake-ll (orak-ll)
504   ((environment      :accessor lambda-list-environment-parameter
505                      :initarg :environment-parameter
506                      :type     environment-parameter)))
507
508 (defclass oraka-ll (orak-ll)
509   ((aux              :accessor lambda-list-auxiliary-parameters
510                      :initarg :auxiliary-parameters
511                      :initform '()
512                      :type     list)))
513
514 (defclass orakawb-ll (oraka-ll)
515   ((whole            :accessor lambda-list-whole-parameter
516                      :initarg :whole-parameter
517                      :type     whole-parameter)
518    (body             :accessor lambda-list-body-parameter
519                      :initarg :body-parameter
520                      :type     body-parameter)))
521
522 (defclass orakawbe-ll (orakawb-ll)
523   ((environment      :accessor lambda-list-environment-parameter
524                      :initarg :environment-parameter
525                      :type     environment-parameter)))
526
527 (defgeneric lambda-list-auxiliary-parameters-p (self)
528   (:method ((self oraka-ll)) (not (not (lambda-list-auxiliary-parameters self))))
529   (:method ((self t))        (declare (ignorable self)) nil))
530
531 (defgeneric lambda-list-whole-parameter-p (self)
532   (:method ((self orakawb-ll)) (slot-boundp self 'whole))
533   (:method ((self t))          (declare (ignorable self)) nil))
534
535 (defgeneric lambda-list-body-parameter-p (self)
536   (:method ((self orakawb-ll)) (slot-boundp self 'body))
537   (:method ((self t))          (declare (ignorable self)) nil))
538
539 (defgeneric lambda-list-environment-parameter-p (self)
540   (:method ((self orakawbe-ll)) (slot-boundp self 'environment))
541   (:method ((self orake-ll))    (slot-boundp self 'environment))
542   (:method ((self t))           (declare (ignorable self)) nil))
543
544
545
546 ;;;----------------------------------------
547
548 (defclass lambda-list ()
549   ((original   :accessor original-lambda-list
550                :initarg :lambda-list
551                :type     list)
552    (parameters :accessor lambda-list-parameters
553                :initarg :parameters
554                :type     list
555                :documentation "An ordered list of the parameters or destructuring-lambda-list instances."))
556   (:documentation "An abstract lambda-list."))
557
558 (defclass ordinary-lambda-list           (lambda-list oraka-ll)    ())
559 (defclass boa-lambda-list                (lambda-list oraka-ll)    ())
560 (defclass specialized-lambda-list        (lambda-list oraka-ll)    ())
561 (defclass modify-macro-lambda-list       (lambda-list or-ll)       ())
562 (defclass generic-lambda-list            (lambda-list orak-ll)     ())
563 (defclass macro-lambda-list              (lambda-list orakawbe-ll) ())
564 (defclass type-lambda-list               (lambda-list orakawbe-ll) ())
565 (defclass destructuring-lambda-list      (lambda-list orakawb-ll)  ())
566 (defclass setf-lambda-list               (lambda-list orake-ll)    ())
567 (defclass method-combination-lambda-list (lambda-list orakaw-ll)   ())
568
569 (defgeneric lambda-list-kind (lambda-list)
570   (:method ((self ordinary-lambda-list))           (declare (ignorable self)) :ordinary)
571   (:method ((self boa-lambda-list))                (declare (ignorable self)) :boa)
572   (:method ((self specialized-lambda-list))        (declare (ignorable self)) :specialized)
573   (:method ((self modify-macro-lambda-list))       (declare (ignorable self)) :modify-macro)
574   (:method ((self generic-lambda-list))            (declare (ignorable self)) :generic)
575   (:method ((self macro-lambda-list))              (declare (ignorable self)) :macro)
576   (:method ((self type-lambda-list))               (declare (ignorable self)) :type)
577   (:method ((self destructuring-lambda-list))      (declare (ignorable self)) :destructuring)
578   (:method ((self setf-lambda-list))               (declare (ignorable self)) :setf)
579   (:method ((self method-combination-lambda-list)) (declare (ignorable self)) :method-combination))
580
581 (defgeneric lambda-list-allowed-keywords (lambda-list)
582   (:method ((self ordinary-lambda-list))
583     (declare (ignorable self)) 
584     '(&optional &rest &allow-other-keys &key &aux))
585   (:method ((self boa-lambda-list))
586     (declare (ignorable self)) 
587     '(&optional &rest &allow-other-keys &key &aux))
588   (:method ((self specialized-lambda-list))
589     (declare (ignorable self)) 
590     '(&optional &rest &allow-other-keys &key &aux))
591   (:method ((self modify-macro-lambda-list)) 
592     (declare (ignorable self))
593     '(&optional &rest))
594   (:method ((self generic-lambda-list))
595     (declare (ignorable self)) 
596     '(&optional &rest &allow-other-keys &key))
597   (:method ((self macro-lambda-list))
598     (declare (ignorable self)) 
599     '(&optional &rest &allow-other-keys &key &aux &whole &body &environment))
600   (:method ((self type-lambda-list))
601     (declare (ignorable self)) 
602     '(&optional &rest &allow-other-keys &key &aux &whole &body &environment))
603   (:method ((self destructuring-lambda-list))
604     (declare (ignorable self)) 
605     '(&optional &rest &allow-other-keys &key &aux &whole &body))
606   (:method ((self setf-lambda-list))
607     (declare (ignorable self)) 
608     '(&optional &rest &allow-other-keys &key &environment))
609   (:method ((self method-combination-lambda-list))
610     (declare (ignorable self)) 
611     '(&optional &rest &allow-other-keys &key &aux &whole)))
612
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   (parse-original-lambda-list
851    (make-instance
852        (or (cdr (assoc
853                  kind
854                  '((:ordinary           . ordinary-lambda-list)
855                    (:boa                . boa-lambda-list)
856                    (:specialized        . specialized-lambda-list)
857                    (:modify-macro       . modify-macro-lambda-list)
858                    (:generic            . generic-lambda-list)
859                    (:macro              . macro-lambda-list)
860                    (:type               . type-lambda-list)
861                    (:destructuring      . destructuring-lambda-list)
862                    (:setf               . setf-lambda-list)
863                    (:method-combination . method-combination-lambda-list))))
864            (error "Invalid lambda-list kind ~S" kind))
865      :lambda-list lambda-list)))
866
867 ;;------------------------------------------------------------------------
868
869 (defgeneric parameter-help-label (self)
870   (:method ((self parameter))
871     (format nil "~A" (parameter-name self)))
872   (:method ((self optional-parameter))
873     (format nil "[~A]" (parameter-name self)))
874   (:method ((self rest-parameter))
875     (format nil "~A..." (parameter-name self)))
876   (:method ((self body-parameter))
877     (format nil "~A..." (parameter-name self)))
878   (:method ((self keyword-parameter))
879     (format nil "~A" (ensure-parameter-keyword self))))
880
881
882 (defmethod make-help ((self lambda-list))
883   "
884 RETURN: A list describing the lambda-list for the user. Each item is a cons:
885         (lambda-list-keyword . description) where
886         - the lambda-list-keyword is either
887           :mandatory, :optional, :rest, :body, :key,  or :allow-other-keys.
888         - the description is a string indicating the name of the parameter,
889           and whether it's optional '[n]' or takes several arguments 'n...'.
890 "
891   (append
892    ;; mandatory:
893    (mapcar (lambda (par) (cons :mandatory (parameter-help-label par)))
894            (lambda-list-mandatory-parameters self))
895    ;; optional:
896    (mapcar (lambda (par) (cons :optional  (parameter-help-label par)))
897            (lambda-list-optional-parameters self))
898    (when (lambda-list-rest-parameter-p self)
899      (list (cons :rest (parameter-help-label (lambda-list-rest-parameter self)))))
900    (when (lambda-list-body-parameter-p self)
901      (list (cons :body (parameter-help-label (lambda-list-body-parameter self)))))
902    ;; keywords:
903    (mapcar (lambda (par) (cons :key (parameter-help-label par)))
904            (lambda-list-keyword-parameters self))
905    (when (lambda-list-allow-other-keys-p self)
906      (list (cons :allow-other-keys "(other keys allowed)")))))
907
908
909 (defmethod make-argument-list ((self lambda-list))
910   "
911 RETURN: A list of arguments taken from the parameters usable with apply
912         to call a function with the same lambda-list.
913 "
914   (let ((rest (lambda-list-rest-p self)))
915     (append
916      (mapcar (function parameter-name) (lambda-list-mandatory-parameters self))
917      (mapcar (function parameter-name) (lambda-list-optional-parameters  self))
918      (when (lambda-list-key-p self)
919        (mapcan (lambda (par) (list (ensure-parameter-keyword par)
920                               (parameter-name par)))
921                (lambda-list-keyword-parameters  self)))
922      (list (if rest  (parameter-name rest) 'nil)))))
923
924
925
926
927 ;;;; MAKE-ARGUMENT-LIST-FORM
928 ;; +------+--------+-----+---------+
929 ;; | rest | k-wo-i | aok | all-opt |
930 ;; +------+--------+-----+---------+
931 ;; |  no  |   no   |  no | <=> there is some keyword
932 ;; |  no  |   no   | yes | <=> there is some keyword ; we can't know the other keywords!
933 ;; |  no  |   yes  |  no | yes
934 ;; |  no  |   yes  | yes | yes ; we can't know the other keywords!
935 ;; |  yes |   no   |  no | <=> there is some keyword <=> (not (null rest))
936 ;; |  yes |   no   | yes | <=> there is some keyword <=> (not (null rest))
937 ;; |  yes |   yes  |  no | yes
938 ;; |  yes |   yes  | yes | yes
939 ;; +------+--------+-----+---------+
940
941 (defgeneric make-argument-list-form (lambda-list))
942 (defmethod make-argument-list-form ((self lambda-list))
943   "
944 RETURN: A form that will build a list of arguments passing the same arguments
945         given to lambda-list, to be passed to APPLY.
946 NOTE:   If optional or key arguments have an indicator,
947         then they're not passed unless necessary or the indicator is true.
948 BUG:    We don't handle MACRO-LAMBDA-LISTs nor DESTRUCTURING-LAMBDA-LISTs, etc.
949 "
950   (flet ((genopt ()
951            (loop
952               :with result = '()
953               :with pars = (reverse (lambda-list-optional-parameters self))
954               :for par = (pop pars)
955               :while (and par (parameter-indicator-p par))
956               :do (push `(when ,(parameter-indicator par)
957                            (list ,(parameter-name par))) result) 
958               :finally (return
959                          `(,@(when (or par pars)
960                                    `((list ,@(nreverse
961                                               (mapcar
962                                                (function parameter-name)
963                                                (if par
964                                                    (cons par pars)
965                                                    pars))))))
966                              ,@result)))))
967     (let* ((rest
968             (cond
969               ((lambda-list-rest-parameter-p self) (lambda-list-rest-parameter self))
970               ((lambda-list-body-parameter-p self) (lambda-list-body-parameter self))))
971            (form
972              `(append
973                ,@(if (not (every (function parameter-indicator-p)
974                                  (lambda-list-keyword-parameters self)))
975                      ;; If some keyword parameter has no indicator,
976                      ;; we will be forced to pass it again as argument,
977                      ;; therefore we must pass all optional argumentst too.
978                      `( (list ,@(mapcar (function parameter-name)
979                                         (lambda-list-mandatory-parameters self))
980                               ,@(mapcar (function parameter-name)
981                                         (lambda-list-optional-parameters self))))
982
983                      `( (list ,@(mapcar (function parameter-name)
984                                         (lambda-list-mandatory-parameters self)))
985                         ,@(if (not (or rest (lambda-list-keyword-parameters self)))
986                               (genopt)
987                               `((if
988                                  ,(if rest
989                                       (parameter-name rest)
990                                       `(or
991                                         ,@(mapcar
992                                            (function parameter-indicator)
993                                            (lambda-list-keyword-parameters self))))
994                                  (list ,@(mapcar
995                                           (function parameter-name)
996                                           (lambda-list-optional-parameters self)))
997                                  ,(let ((subforms (genopt)))
998                                        (cond
999                                          ((null subforms) '())
1000                                          ((cdr subforms) `(append ,@subforms))
1001                                          (t (car subforms)))))))))
1002                ,@(if rest
1003                      ;; When we have a rest (or body) parameter, we don't need
1004                      ;; to generate the keyword parameters, since they're 
1005                      ;; covered by the rest. We just append the rest to the
1006                      ;;  list of arguments.
1007                      `(,(parameter-name rest))
1008                      ;; Without a rest (or body) parameter, we need to pass
1009                      ;; the keyword arguments.
1010                      (mapcar (lambda (parameter)
1011                                (if (parameter-indicator-p parameter)
1012                                    ;; If we have an indicator parameter,
1013                                    ;; we pass the keyword argument
1014                                    ;; only when we got it.
1015                                    `(when ,(parameter-indicator parameter)
1016                                       (list
1017                                        ,(ensure-parameter-keyword parameter)
1018                                        ,(parameter-name parameter)))
1019                                    ;; otherwise we pass the keyword argument
1020                                    ;; unconditionnaly:
1021                                    `(list ,(ensure-parameter-keyword parameter)
1022                                           ,(parameter-name parameter))))
1023                              (lambda-list-keyword-parameters  self))))))
1024       (if (= 2 (length form))
1025           (second form)
1026           form))))
1027
1028
1029
1030 (defmethod make-lambda-list ((self lambda-list))
1031   "
1032 RETURN:     A newly rebuilt lambda-list s-expr.
1033 "
1034   (append
1035    (when (lambda-list-whole-parameter-p self)
1036      (list '&whole
1037            (parameter-specifier (lambda-list-whole-parameter self))))
1038    (when (lambda-list-environment-parameter-p self)
1039      (list '&environment
1040            (parameter-specifier (lambda-list-environment-parameter self))))
1041    (mapcar (function parameter-specifier) (lambda-list-mandatory-parameters self))
1042    (when (lambda-list-optional-parameters self)
1043      (cons '&optional
1044            (mapcar (function parameter-specifier)
1045                    (lambda-list-optional-parameters self))))
1046    (when (lambda-list-body-parameter-p self)
1047      (list '&body (parameter-specifier (lambda-list-body-parameter self))))
1048    (when (lambda-list-rest-parameter-p self)
1049      (list '&rest (parameter-specifier (lambda-list-rest-parameter self))))
1050    (when (lambda-list-key-p self)
1051      '(&key))
1052    (when (lambda-list-keyword-parameters self)
1053      (mapcar (function parameter-specifier)
1054              (lambda-list-keyword-parameters self)))
1055    (when (lambda-list-allow-other-keys-p self)
1056      '(&allow-other-keys))
1057    (when (lambda-list-auxiliary-parameters self)
1058      (cons '&aux (mapcar (function parameter-specifier)
1059                          (lambda-list-auxiliary-parameters self))))))
1060
1061
1062
1063 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1064
1065
1066
1067 ;; (defmacro m (&environment env &whole whole
1068 ;;              ((a b) (c (d e)) &optional (o t op))
1069 ;;              e f &body g &key k1 k2)
1070 ;;   (print (list env whole a b c d e o op e f g k1 k2)) nil)
1071 ;;
1072 ;; (m ((1 2) (3 (4 5))) 6 7  :k1 (print c) :k2 (print d))
1073 ;;
1074 ;; (#(NIL NIL)
1075 ;;   (M ((1 2) (3 (4 5))) 6 7 :K1 (PRINT C) :K2 (PRINT D))
1076 ;;   1 2 3 4 6 T NIL 6 7
1077 ;;   (:K1 (PRINT C) :K2 (PRINT D))
1078 ;;   (PRINT C)
1079 ;;   (PRINT D))
1080
1081
1082 ;; (make-help-from-split-lambda-list
1083 ;;  (split-lambda-list-on-keywords
1084 ;;   '(m1 m2 m3 &optional o1 o2 o3 &rest r1 &key k1 k2 k3 &aux a1 a2 a3
1085 ;;     &allow-other-keys)
1086 ;;   :ordinary))
1087 ;;'(m1 m2 m3 &optional o1 o2 o3 &rest r1 &key k1 k2 k3 &aux a1 a2 a3  &allow-other-keys)
1088
1089
1090
1091
1092 (eval-when (:compile-toplevel :load-toplevel :execute)
1093   (defun extract-documentation (body)
1094     "
1095 RETURN: The documentation string found in BODY, or NIL if none is present.
1096
1097 3.4.11 Syntactic Interaction of Documentation Strings and Declarations
1098
1099 In a number of situations, a documentation string can appear amidst a series of
1100 declare expressions prior to a series of forms.
1101
1102 In that case, if a string S appears where a documentation string is permissible
1103 and is not followed by either a declare expression or a form then S is taken to
1104 be a form; otherwise, S is taken as a documentation string. The consequences
1105 are unspecified if more than one such documentation string is present.
1106 "
1107     (loop
1108        :for (item . rest) :on body
1109        :while (and (consp item) (eq 'declare (first item)))
1110        :finally (return (and (stringp item) rest item))))
1111
1112
1113   (defun extract-declarations (body)
1114     "
1115 RETURN: The list of declaration forms.
1116 "
1117     (loop
1118        :with seen-doc = nil
1119        :for item :in body
1120        :while (or (and (not seen-doc) (stringp item))
1121                   (and (consp item) (eq 'declare (car item))))
1122        :when  (and (not seen-doc) (stringp item)) :do (setf seen-doc t)
1123        :when  (and (consp item) (eq 'declare (car item))) :collect item))
1124
1125
1126   (defun declarations-hash-table (declarations)
1127     ;; Todo: add some knowledge on how declarations merge.
1128     (loop
1129        :with table = (make-hash-table)
1130        :for decl :in declarations
1131        :do (loop
1132               :for (key . value) :in (rest decl)
1133               :do (push value (gethash key table '())))
1134        :finally (return table)))
1135
1136
1137   (defun extract-body (body)
1138     (loop
1139        :with seen-doc = nil
1140        :for (item . rest) :on body
1141        :while (or (and (not seen-doc) (stringp item))
1142                   (and (consp item) (eq 'declare (car item))))
1143        :when (and (not seen-doc) (stringp item)) :do (setf seen-doc t)
1144        :finally (return (cons item rest)))))
1145
1146
1147 (defun extract-method-qualifiers (method-stuff)
1148   (loop
1149      :for item :in method-stuff
1150      :until (listp item)
1151      :collect item))
1152
1153 (defun extract-method-lambda-list (method-stuff)
1154   (loop
1155      :for item :in method-stuff
1156      :until (listp item)
1157      :finally (return item)))
1158
1159 (defun extract-method-ddl (method-stuff)
1160   (loop
1161      :for (item . body) :in method-stuff
1162      :until (listp item)
1163      :finally (return body)))
1164
1165 (defun extract-method-documentation (method-stuff)
1166   (extract-documentation (extract-method-ddl method-stuff)))
1167
1168 (defun extract-method-declarations (method-stuff)
1169   (extract-declarations (extract-method-ddl method-stuff)))
1170
1171 (defun extract-method-body (method-stuff)
1172   (extract-body (extract-method-ddl method-stuff)))
1173
1174
1175
1176 ;; (eval-when (:compile-toplevel :load-toplevel :execute)
1177 ;;   (shadow '(DEFUN DEFGENERIC DEFMETHOD)))
1178 ;; 
1179 ;; 
1180 ;; (defparameter *call-stack* '())
1181 ;; 
1182 ;; 
1183 ;; (cl:defmacro defun (name args &body body)
1184 ;;   (let ((lambda-list (parse-lambda-list args :ordinary))
1185 ;;         (docu (extract-documentation body))
1186 ;;         (decl (extract-declarations  body))
1187 ;;         (body (extract-body          body)))
1188 ;;     `(cl:defun ,name ,args
1189 ;;        ,@(when docu (list docu))
1190 ;;        ,@decl
1191 ;;        (push (list ',name ,@(make-argument-list lambda-list)) *call-stack*)
1192 ;;        (multiple-value-prog1 (progn ,@body)
1193 ;;          (pop *call-stack*)))))
1194 ;; 
1195 ;; 
1196 ;; (cl:defmacro defmethod (name &rest stuff)
1197 ;;   (let* ((qualifiers (extract-method-qualifiers stuff))
1198 ;;          (args       (extract-method-lambda-list     stuff))
1199 ;;          (lambda-list     (parse-lambda-list args :specialized))
1200 ;;          (docu       (extract-method-documentation stuff))
1201 ;;          (decl       (extract-method-declarations  stuff))
1202 ;;          (body       (extract-method-body          stuff)))
1203 ;;     `(cl:defmethod
1204 ;;          ,name ,@qualifiers ,args
1205 ;;          ,@(when docu (list docu))
1206 ;;          ,@decl
1207 ;;          (push (list ',name ,@(make-argument-list lambda-list)) *call-stack*)
1208 ;;          (multiple-value-prog1 (progn ,@body)
1209 ;;            (pop *call-stack*)))))
1210 ;; 
1211 ;; (cl:defmacro defgeneric (name args &rest options-and-methods)
1212 ;;   `(cl:defgeneric ,name ,args
1213 ;;      ,@(mapcar
1214 ;;         (lambda (item)
1215 ;;           (if (and (consp item) (eq :method (car item)))
1216 ;;               (let* ((stuff      (rest item))
1217 ;;                      (qualifiers (extract-method-qualifiers stuff))
1218 ;;                      (args       (extract-method-lambda-list     stuff))
1219 ;;                      (lambda-list     (parse-lambda-list args :specialized))
1220 ;;                      (docu       (extract-method-documentation stuff))
1221 ;;                      (decl       (extract-method-declarations  stuff))
1222 ;;                      (body       (extract-method-body          stuff)))
1223 ;;                 `(:method ,@qualifiers ,args
1224 ;;                           ,@(when docu (list docu))
1225 ;;                           ,@decl
1226 ;;                           (push (list ',name ,@(make-argument-list lambda-list))
1227 ;;                                 *call-stack*)
1228 ;;                           (multiple-value-prog1 (progn ,@body)
1229 ;;                             (pop *call-stack*))))
1230 ;;               item))
1231 ;;         options-and-methods)))
1232
1233 ;;;; THE END ;;;;